1      SUBROUTINE DPFUNC(IBUGA3,ISUBRO,IERROR,ISFLAG)
2CCCCC APRIL 1996.  ADD ISFLAG ARGUMENT
3CCCCC AUGUST 2010.  ADD ISUBRO ARGUMENT
4CCCCC SUBROUTINE DPFUNC(IBUGA3,IERROR)
5C
6C     PURPOSE--TREAT THE SUBCASE OF THE LET FUNCTION COMMAND
7C              IN WHICH A FUNCTION IS DEFINED.
8C     EXAMPLE--LET FUNCTION F1 = SIN(2*X)
9C            --LET FUNCTION F2 = SIN(A*B*X+2*C)+E*X**4  FOR X=Z
10C            --LET FUNCTION F3 = F1 FOR X=7
11C     WRITTEN BY--JAMES J. FILLIBEN
12C                 STATISTICAL ENGINEERING DIVISION
13C                 INFORMATION TECHNOLOGY LABORATORY
14C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
15C                 GAITHERSBURG, MD 20899-8980
16C                 PHONE--301-975-2855
17C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
18C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
19C     LANGUAGE--ANSI FORTRAN (1977)
20C     VERSION NUMBER--82/7
21C     ORIGINAL VERSION--JANUARY   1979.
22C     UPDATED         --FEBRUARY  1979.
23C     UPDATED         --MARCH     1979.
24C     UPDATED         --JULY      1981.
25C     UPDATED         --MARCH     1982.
26C     UPDATED         --MAY       1982.
27C     UPDATED         --APRIL     1996.  ISFLAG TO PRESERVE STRING CASE
28C     UPDATED         --JULY      1998.  FOR STRINGS, CHECK FOR
29C                                        SP() AND CONVERT TO SPACE.
30C     UPDATED         --FEBRUARY  2009.  FOR STRINGS, MAKE SP() ACTION
31C                                        USER SETTABLE (FOR STRINGS
32C                                        USED FOR LABLELING PLOTS, WE
33C                                        MAY WANT TO IGNORE THE SP()
34C                                        SO THAT IT WILL BE PASSED TO
35C                                        THE PLOT ROUTINES).
36C     UPDATED         --MARCH     2015.  CALL LIST TO DPINFU
37C
38C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
39C
40      CHARACTER*4 IBUGA3
41      CHARACTER*4 ISUBRO
42      CHARACTER*4 IERROR
43C
44      CHARACTER*4 NEWNAM
45      CHARACTER*4 IWD1
46      CHARACTER*4 IWD2
47      CHARACTER*4 IWD12
48      CHARACTER*4 IWD22
49      CHARACTER*4 ILAB
50      CHARACTER*4 IKEY
51      CHARACTER*4 IKEY2
52      CHARACTER*4 INCLUN
53      CHARACTER*4 IFOUND
54      CHARACTER*4 IFOUN1
55      CHARACTER*4 IFOUN2
56      CHARACTER*4 IHLEFT
57      CHARACTER*4 IHLEF2
58      CHARACTER*4 IOLD
59      CHARACTER*4 IOLD2
60      CHARACTER*4 INEW
61      CHARACTER*4 INEW2
62      CHARACTER*4 IHOUT
63      CHARACTER*4 IHOUT2
64      CHARACTER*4 IUOUT
65C
66      CHARACTER*4 ISUBN1
67      CHARACTER*4 ISUBN2
68      CHARACTER*4 ISTEPN
69CCCCC APRIL 1996.  ADD FOLLOWING LINE
70      CHARACTER*10 ISFLAG
71CCCCC JULY 1998.  ADD FOLLOWING LINE
72      CHARACTER*4 IATEMP
73C
74C---------------------------------------------------------------------
75C
76      DIMENSION ILAB(10)
77C
78      DIMENSION IOLD(10)
79      DIMENSION IOLD2(10)
80      DIMENSION INEW(10)
81      DIMENSION INEW2(10)
82C
83C-----COMMON----------------------------------------------------------
84C
85      INCLUDE 'DPCOPA.INC'
86      INCLUDE 'DPCOHK.INC'
87      INCLUDE 'DPCODA.INC'
88      INCLUDE 'DPCOST.INC'
89      INCLUDE 'DPCOP2.INC'
90C
91C-----START POINT-----------------------------------------------------
92C
93      ISUBN1='DPFU'
94      ISUBN2='NC  '
95      IERROR='NO'
96C
97      ILOC3=0
98C
99C               *****************************************************
100C               **  TREAT THE SUBCASE OF THE LET FUNCTION COMMAND  **
101C               **  WHICH DEFINES A FUNCTION                       **
102C               *****************************************************
103C
104      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FUNC')THEN
105        WRITE(ICOUT,999)
106        CALL DPWRST('XXX','BUG ')
107        WRITE(ICOUT,51)
108   51   FORMAT('***** AT THE BEGINNING OF DPFUNC--')
109        CALL DPWRST('XXX','BUG ')
110        WRITE(ICOUT,52)IBUGA3,NUMNAM,NUMCHF,MAXCHF
111   52   FORMAT('IBUGA3,NUMNAM,NUMCHF,MAXCHF = ',A4,2X,3I8)
112        CALL DPWRST('XXX','BUG ')
113        DO55I=1,NUMNAM
114          WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),
115     1                   IVSTOP(I)
116   56     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),IVSTOP(I)=',
117     1           I8,2X,A4,A4,2X,A4,I8,I8)
118          CALL DPWRST('XXX','BUG ')
119   55   CONTINUE
120        NMAX=MIN(120,NUMCHF)
121        NMAX=MIN(NMAX,MAXCHF)
122        WRITE(ICOUT,60)(IFUNC(I),I=1,NMAX)
123   60   FORMAT('IFUNC(.)  = ',120A1)
124        CALL DPWRST('XXX','BUG ')
125      ENDIF
126C
127C               **********************************
128C               **  STEP 1--                    **
129C               **  INITIALIZE SOME VARIABLES.  **
130C               **********************************
131C
132      ISTEPN='1'
133      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FUNC')
134     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
135C
136      NEWNAM='NO'
137C
138      MAXN2=MAXCHF
139      MAXN3=MAXCHF
140C
141C               ********************************************************
142C               **  STEP 2--                                           *
143C               **  EXAMINE THE LEFT-HAND SIDE--                       *
144C               **  IS THE FUNCTION NAME TO LEFT OF = SIGN             *
145C               **  ALREADY IN THE NAME LIST?                          *
146C               **  NOTE THAT     ILISTL    IS THE LINE IN THE TABLE   *
147C               **  OF THE NAME ON THE LEFT.                           *
148C               ********************************************************
149C
150      ISTEPN='2'
151      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FUNC')
152     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
153C
154      IHLEFT=IHARG(2)
155      IHLEF2=IHARG2(2)
156      DO2000I=1,NUMNAM
157        I2=I
158        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
159          IF(IUSE(I).EQ.'F')THEN
160            ILISTL=I2
161            GOTO2900
162          ELSE
163            WRITE(ICOUT,999)
164            CALL DPWRST('XXX','BUG ')
165            WRITE(ICOUT,2201)
166            CALL DPWRST('XXX','BUG ')
167            WRITE(ICOUT,2102)
168 2102       FORMAT('      THE NAME OF THE FUNCTION/STRING ON THE ',
169     1             'LEFT HAND SIDE')
170            CALL DPWRST('XXX','BUG ')
171            WRITE(ICOUT,2104)
172 2104       FORMAT('      OF THE EQUAL SIGN WAS FOUND IN THE CURRENT ')
173            CALL DPWRST('XXX','BUG ')
174            WRITE(ICOUT,2106)
175 2106       FORMAT('      NAME TABLE, BUT NOT AS A STRING OR A ',
176     1             'FUNCTION.')
177            CALL DPWRST('XXX','BUG ')
178            IERROR='YES'
179            GOTO9000
180          ENDIF
181        ENDIF
182 2000 CONTINUE
183C
184      NEWNAM='YES'
185      ILISTL=NUMNAM+1
186      IF(ILISTL.GT.MAXNAM)THEN
187        WRITE(ICOUT,999)
188  999   FORMAT(1X)
189        CALL DPWRST('XXX','BUG ')
190        WRITE(ICOUT,2201)
191 2201   FORMAT('***** ERROR IN DPFUNC--')
192        CALL DPWRST('XXX','BUG ')
193        WRITE(ICOUT,2202)
194 2202   FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, & FUNCTION')
195        CALL DPWRST('XXX','BUG ')
196        WRITE(ICOUT,2203)MAXNAM
197 2203   FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
198        CALL DPWRST('XXX','BUG ')
199        WRITE(ICOUT,2204)
200 2204   FORMAT('      ENTER      STAT')
201        CALL DPWRST('XXX','BUG ')
202        WRITE(ICOUT,2205)
203 2205   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES,')
204        CALL DPWRST('XXX','BUG ')
205        WRITE(ICOUT,2206)
206 2206   FORMAT('      AND THEN REDEFINE (REUSE) SOME OF THE')
207        CALL DPWRST('XXX','BUG ')
208        WRITE(ICOUT,2207)
209 2207   FORMAT('      ALREADY-USED NAMES')
210        CALL DPWRST('XXX','BUG ')
211        IERROR='YES'
212        GOTO9000
213      ENDIF
214C
215 2900 CONTINUE
216C
217C               ********************************************************
218C               **  STEP 3--                                          **
219C               **  EXTRACT THE RIGHT-SIDE                            **
220C               **  EXPRESSION FROM THE INPUT COMMAND LINE            **
221C               **  (STARTING WITH THE FIRST NON-BLANK LOCATION AFTER **
222C               **  THE EQUAL SIGN AND ENDING WITH THE END OF THE LINE**
223C               **  OR WITH THE LAST NON-BLANK CHARACTER BEFORE       **
224C               **  FOR  .                                            **
225C               ********************************************************
226C
227      ISTEPN='3'
228      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FUNC')
229     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
230C
231CCCCC APRIL 1996.  FOR LET STRING, PRESERVE CASE.  FOR LET FUNCTION,
232CCCCC CONVERT TO UPPER CASE.
233CCCCC MARCH 2009.  FOR LET STRING, DON'T CHECK FOR "FOR".  THIS IS
234CCCCC IS SPECIFIC TO FUNCTIONS.
235C
236      IF(ISFLAG.EQ.'FUNCTION')THEN
237        IWD1='=   '
238        IWD12='    '
239        IWD2='FOR '
240        IWD22='    '
241        CALL DPEXST(IANS,IWIDTH,IWD1,IWD12,IWD2,IWD22,MAXN2,
242     1              IFUNC2,N2,IBUGA3,IFOUND,IERROR)
243        IF(IERROR.EQ.'YES')GOTO9000
244        IF(IFOUND.EQ.'YES')GOTO3900
245      ENDIF
246C
247      IWD1='=   '
248      IWD12='    '
249      IWD2='    '
250      IWD22='    '
251      IF(ISFLAG.EQ.'FUNCTION')THEN
252        CALL DPEXST(IANS,IWIDTH,IWD1,IWD12,IWD2,IWD22,MAXN2,
253     1              IFUNC2,N2,IBUGA3,IFOUND,IERROR)
254      ELSE
255        CALL DPEXST(IANSLC,IWIDTH,IWD1,IWD12,IWD2,IWD22,MAXN2,
256     1              IFUNC2,N2,IBUGA3,IFOUND,IERROR)
257      ENDIF
258      IF(IERROR.EQ.'YES')GOTO9000
259      IF(IFOUND.EQ.'YES')GOTO3900
260C
261      WRITE(ICOUT,999)
262      CALL DPWRST('XXX','BUG ')
263      WRITE(ICOUT,2201)
264      CALL DPWRST('XXX','BUG ')
265      WRITE(ICOUT,3102)
266 3102 FORMAT('      INVALID COMMAND FORM FOR FUNCTION DEFINITION.')
267      CALL DPWRST('XXX','BUG ')
268      WRITE(ICOUT,3103)
269 3103 FORMAT('      GENERAL FORM--')
270      CALL DPWRST('XXX','BUG ')
271      WRITE(ICOUT,3104)
272 3104 FORMAT('      LET FUNCTION ... = ... FOR ... = ... ')
273      CALL DPWRST('XXX','BUG ')
274      WRITE(ICOUT,3105)
275 3105 FORMAT('      THE ENTIRE COMMAND LINE WAS AS FOLLOWS--')
276      CALL DPWRST('XXX','BUG ')
277      IF(IWIDTH.GE.1)THEN
278        WRITE(ICOUT,3106)(IANS(I),I=1,MIN(IWIDTH,100))
279 3106   FORMAT('      ',100A1)
280        CALL DPWRST('XXX','BUG ')
281      ENDIF
282      IERROR='YES'
283      GOTO9000
284C
285 3900 CONTINUE
286C
287C               *********************************************************
288C               **  STEP 4.1--                                         **
289C               **  DETERMINE IF THE EXPRESSION HAS ANY FUNCTION NAMES **
290C               **  EMBEDDED.  IF SO, REPLACE THE FUNCTION NAMES       **
291C               **  BY EACH FUNCTION'S DEFINITION.  DO SO REPEATEDLY   **
292C               **  UNTIL ALL FUNCTION REFERENCES HAVE BEEN ANNIHILATED**
293C               **  AND THE EXPRESSION IS LEFT ONLY WITH               **
294C               **  CONSTANTS, PARAMETERS, AND VARIABLES--NO FUNCTIONS.**
295C               **  PLACE THE RESULTING FUNCTIONAL EXPRESSION INTO     **
296C               **  IFUNC3(.)                                          **
297C               *********************************************************
298C
299      ISTEPN='4.1'
300      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FUNC')
301     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
302C
303      CALL DPEXFU(IFUNC2,N2,IHNAME,IHNAM2,IUSE,IVSTAR,IVSTOP,
304     1NUMNAM,IANS,IWIDTH,IFUNC,NUMCHF,MAXCHF,IFUNC3,N3,MAXN3,
305     1IBUGA3,IERROR)
306      IF(IERROR.EQ.'YES')GOTO9000
307C
308CCCCC JULY 1998:     CHECK FOR "SP()" IN STRINGS AND CONVERT TO SPACE.
309CCCCC OCTOBER 2017:  HOWEVER, IF "SP()" IS PART OF "UNSP()", THEN THIS
310CCCCC                IS THE "UNSUPERSCRIPT" SYMBOL AND SHOULD NOT BE
311CCCCC                EXPANDED.
312C
313      IF(ISFLAG.NE.'FUNCTION'.AND.N3.GE.4.AND.ISTRSP.EQ.'EXPA')THEN
314        DO4100I=N3,4,-1
315          IATEMP(1:1)=IFUNC3(I-3)(1:1)
316          IATEMP(2:2)=IFUNC3(I-2)(1:1)
317          IATEMP(3:3)=IFUNC3(I-1)(1:1)
318          IATEMP(4:4)=IFUNC3(I)(1:1)
319          IF(
320     1       IATEMP(3:4).EQ.'()'.AND.
321     1      (IATEMP(2:2).EQ.'P'.OR.IATEMP(2:2).EQ.'p').AND.
322     1      (IATEMP(1:1).EQ.'S'.OR.IATEMP(1:1).EQ.'s')
323     1    )THEN
324C
325            IF(I.GT.5)THEN
326              IF(
327     1        (IFUNC3(I-4)(1:1).EQ.'N' .OR.  IFUNC3(I-4)(1:1).EQ.'n')
328     1        .AND.
329     1        (IFUNC3(I-5)(1:1).EQ.'U' .OR.  IFUNC3(I-5)(1:1).EQ.'u')
330     1        )THEN
331                GOTO4100
332              ENDIF
333            ENDIF
334C
335            IFUNC3(I-3)=' '
336            DO4110J=I-2,N3-3
337              J2=J+3
338              IFUNC3(J)=IFUNC3(J2)
339 4110       CONTINUE
340            DO4120J=N3-2,N3
341              IFUNC3(J)=' '
342 4120       CONTINUE
343            N3=N3-3
344          ENDIF
345 4100   CONTINUE
346      ENDIF
347C
348C               **********************************************
349C               **  STEP 4.2--                              **
350C               **  PRINT OUT A BRIEF MESSAGE               **
351C               **  INDICATING THAT THE FUNCTION            **
352C               **  DEFINITION HAS BEEN CARRIED OUT.        **
353C               **********************************************
354C
355      ISTEPN='4.2'
356      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FUNC')
357     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
358C
359      IF(IFEEDB.EQ.'ON')THEN
360        WRITE(ICOUT,999)
361        CALL DPWRST('XXX','BUG ')
362        ILAB(1)='INPU'
363        ILAB(2)='T FU'
364        ILAB(3)='NCTI'
365        ILAB(4)='ON  '
366        ILAB(5)='    '
367        ILAB(6)='  = '
368        NUMWDL=6
369        CALL DPPRIF(ILAB,NUMWDL,IFUNC2,N2,IBUGA3)
370C
371        ILAB(1)='OUTP'
372        ILAB(2)='UT F'
373        ILAB(3)='UNCT'
374        ILAB(4)='ION '
375        ILAB(5)='    '
376        ILAB(6)='  = '
377        NUMWDL=6
378        CALL DPPRIF(ILAB,NUMWDL,IFUNC3,N3,IBUGA3)
379      ENDIF
380C
381C               *************************************
382C               **  STEP 5--                       **
383C               **  EXTRACT QUALIFIER INFORMATION. **
384C               *************************************
385C
386      ISTEPN='5'
387      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FUNC')
388     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
389C
390C               **********************************************
391C               **  STEP 6.3--                              **
392C               **  SCAN THE QUALIFIERS FOR VARIABLE,       **
393C               **  PARAMETER, FUNCTION, AND VALUE CHANGES  **
394C               **  IN THE FUNCTION.                        **
395C               **********************************************
396C
397      ISTEPN='6.3'
398      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FUNC')
399     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
400C
401      ILOCLM=1
402C
403CCCCC MARCH 2009: SKIP THIS STEP FOR A STRING
404C
405      NCHANG=0
406      IF(ISFLAG.NE.'FUNCTION')GOTO6390
407C
408      DO6300IFORI=1,10
409C
410      IKEY='FOR '
411      IKEY2='    '
412      ISHIFT=1
413      IF(IFORI.EQ.1)ILOCA=ILOCLM
414      IF(IFORI.NE.1)ILOCA=ILOC3
415      ILOCB=NUMARG
416      INCLUN='NO'
417      CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB,
418     1IHARG,IHARG2,NUMARG,
419     1INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,IUSE,IN,NUMNAM,
420     1IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT,IVOUT,VOUT,IUOUT,
421     1INOUT,IBUGA3,IERROR)
422      IF(IERROR.EQ.'YES')GOTO6380
423      IF(IFOUN1.EQ.'NO'.OR.IFOUN2.EQ.'NO')GOTO6350
424C
425      ILOC3=ILOC2+2
426      IF(ILOC3.GT.NUMARG)GOTO6380
427      NCHANG=NCHANG+1
428      IOLD(NCHANG)=IHARG(ILOC2)
429      IOLD2(NCHANG)=IHARG2(ILOC2)
430      INEW(NCHANG)=IHARG(ILOC3)
431      INEW2(NCHANG)=IHARG2(ILOC3)
432C
433 6300 CONTINUE
434 6350 CONTINUE
435      GOTO6390
436C
437 6380 CONTINUE
438      WRITE(ICOUT,999)
439      CALL DPWRST('XXX','BUG ')
440      WRITE(ICOUT,2201)
441      CALL DPWRST('XXX','BUG ')
442      WRITE(ICOUT,6302)
443 6302 FORMAT('      INVALID COMMAND FORM FOR LET FUNCTION.')
444      CALL DPWRST('XXX','BUG ')
445      WRITE(ICOUT,6303)
446 6303 FORMAT('      GENERAL FORM--')
447      CALL DPWRST('XXX','BUG ')
448      WRITE(ICOUT,6304)
449 6304 FORMAT('      LET FUNCTION ... = ...  FOR ... ',
450     1'FOR ... = ...')
451      CALL DPWRST('XXX','BUG ')
452      WRITE(ICOUT,3105)
453      CALL DPWRST('XXX','BUG ')
454      IF(IWIDTH.GE.1)THEN
455        WRITE(ICOUT,3106)(IANS(I),I=1,MIN(IWIDTH,100))
456        CALL DPWRST('XXX','BUG ')
457      ENDIF
458      IERROR='YES'
459      GOTO9000
460C
461 6390 CONTINUE
462C
463C               **********************************************
464C               **  STEP 6.4--                              **
465C               **  CARRY OUT THE VARIABLE,                 **
466C               **  PARAMETER, AND FUNCTION CHANGES         **
467C               **  AND THEN PRINT OUT A BRIEF MESSAGE      **
468C               **  INDICATING THAT THE CHANGES             **
469C               **  HAVE BEEN MADE.                         **
470C               **********************************************
471C
472      ISTEPN='6.4'
473      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FUNC')
474     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
475C
476      IF(IFEEDB.EQ.'OFF')GOTO6490
477      IF(NCHANG.LE.0)GOTO6490
478C
479      WRITE(ICOUT,999)
480      CALL DPWRST('XXX','BUG ')
481      ILAB(1)='PRE '
482      ILAB(2)='-CHA'
483      ILAB(3)='NGE '
484      ILAB(4)='FUNC'
485      ILAB(5)='TION'
486      ILAB(6)='  = '
487      NUMWDL=6
488      CALL DPPRIF(ILAB,NUMWDL,IFUNC3,N3,IBUGA3)
489C
490      CALL COMPIC(IFUNC3,N3,IOLD,IOLD2,INEW,INEW2,NCHANG,
491     1IFUNC3,N3,IBUGA3,IERROR)
492      IF(IERROR.EQ.'YES')GOTO9000
493C
494      ILAB(1)='POST'
495      ILAB(2)='-CHA'
496      ILAB(3)='NGE '
497      ILAB(4)='FUNC'
498      ILAB(5)='TION'
499      ILAB(6)='  = '
500      NUMWDL=6
501      CALL DPPRIF(ILAB,NUMWDL,IFUNC3,N3,IBUGA3)
502C
503 6490 CONTINUE
504C
505C               *******************************************************
506C               **  STEP 6.5--                                       **
507C               **  FOR THE CASE WHEN THE OUTPUT IS A FUNCTION,      **
508C               **  DETERMINE IF THE INSERTION  OF THE NEW FUNCTION  **
509C               **  INTO THE GENERAL FUNCTION TABLE WOULD OVERFLOW   **
510C               **  THE TABLE.  IF NOT, THEN INSERT THE FUNCTION     **
511C               **  INTO THE GENERAL FUNCTION TABLE.                 **
512C               **  MAKE ADJUSTMENTS TO THE INTERNAL LIST.           **
513C               *******************************************************
514C
515      ISTEPN='6.5'
516      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FUNC')
517     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
518C
519      CALL DPINFU(IFUNC3,N3,IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP,
520     1NUMNAM,IANS,IWIDTH,IHLEFT,IHLEF2,ILISTL,NEWNAM,MAXNAM,
521     1IFUNC,NUMCHF,MAXCHF,IBUGA3,IERROR)
522      IF(IERROR.EQ.'YES')GOTO9000
523C
524C               **********************************************
525C               **  STEP 6.6--                              **
526C               **  FOR THE CASE WHEN THE OUTPUT            **
527C               **  IS A FUNCTION,                          **
528C               **  PRINT OUT A BRIEF MESSAGE               **
529C               **  INDICATING THAT THE FUNCTION            **
530C               **  DEFINITION HAS BEEN CARRIED OUT.        **
531C               **********************************************
532C
533      ISTEPN='6.6'
534      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FUNC')
535     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
536C
537      IF(IPRINT.EQ.'ON' .AND. IFEEDB.EQ.'ON')THEN
538        WRITE(ICOUT,999)
539        CALL DPWRST('XXX','BUG ')
540        WRITE(ICOUT,6606)IHLEFT,IHLEF2
541 6606   FORMAT('THE NAME ',A4,A4,' HAS JUST BEEN EQUIVALENCED ')
542        CALL DPWRST('XXX','BUG ')
543        ILAB(1)='TO T'
544        ILAB(2)='HE F'
545        ILAB(3)='UNCT'
546        ILAB(4)='ION '
547        ILAB(5)='    '
548        ILAB(6)=' -- '
549        NUMWDL=6
550        CALL DPPRIF(ILAB,NUMWDL,IFUNC3,N3,IBUGA3)
551C
552        WRITE(ICOUT,999)
553        CALL DPWRST('XXX','BUG ')
554C
555      ENDIF
556C
557C               ****************
558C               **  STEP 90-- **
559C               **  EXIT.     **
560C               ****************
561C
562 9000 CONTINUE
563      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FUNC')THEN
564        WRITE(ICOUT,999)
565        CALL DPWRST('XXX','BUG ')
566        WRITE(ICOUT,9011)
567 9011   FORMAT('***** AT THE END       OF DPFUNC--')
568        CALL DPWRST('XXX','BUG ')
569        WRITE(ICOUT,9012)IBUGA3,IERROR,NUMNAM
570 9012   FORMAT('IBUGA3,IERROR,NUMNAM = ',2(A4,2X),I8)
571        CALL DPWRST('XXX','BUG ')
572        DO9015I=1,NUMNAM
573          WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),
574     1                     IVSTOP(I)
575 9016     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),IVSTOP(I)=',
576     1           I8,2X,A4,A4,2X,A4,I8,I8)
577         CALL DPWRST('XXX','BUG ')
578 9015   CONTINUE
579        WRITE(ICOUT,9017)N2,N3,NUMCHF,MAXN2,MAXN3,MAXCHF
580 9017   FORMAT('N2,N3,NUMCHF,MAXN2,MAXN3,MAXCHF = ',6I8)
581        CALL DPWRST('XXX','BUG ')
582        NMAX=N2
583        IF(NMAX.GT.120)NMAX=120
584        WRITE(ICOUT,9018)(IFUNC2(I),I=1,NMAX)
585 9018   FORMAT('IFUNC2(.) = ',120A1)
586        CALL DPWRST('XXX','BUG ')
587        WRITE(ICOUT,9019)(IFUNC3(I),I=1,MIN(N3,120))
588 9019   FORMAT('IFUNC3(.) = ',120A1)
589        CALL DPWRST('XXX','BUG ')
590        WRITE(ICOUT,9020)(IFUNC(I),I=1,MIN(MAXCHF,120))
591 9020   FORMAT('IFUNC(.)  = ',120A1)
592        CALL DPWRST('XXX','BUG ')
593      ENDIF
594C
595      RETURN
596      END
597      SUBROUTINE DPGCI(NPTS,NLAB,
598     1                 AMEAN,ASD,N,
599     1                 DTEMP1,DTEMP2,
600     1                 XGCI,SEGCI,
601     1                 DLOWGC,DHIGGC,
602     1                 IWRITE,IOUNI5,
603     1                 ICAPSW,ICAPTY,NUMDIG,
604     1                 ISUBRO,IBUGA3,IERROR)
605C
606C     PURPOSE--IMPLEMENT IYER-WANG APPROACH OF GENERALIZED CONFIDENCE
607C              INTERVALS TO CONSENSUS MEANS.  NOTE THAT THIS
608C              ROUTINE DOES NOT RETURN AN ESTIMATE OF THE
609C              STANDARD ERROR OF THE CONSENSUS MEAN, JUST CONFIDENCE
610C              LIMITS DETERMINED VIA SIMULATION.
611C     PRINTING--YES
612C     SUBROUTINES NEEDED--GCI1
613C     WRITTEN BY--ALAN HECKERT
614C                 STATISTICAL ENGINEERING DIVISION
615C                 INFORMATION TECHNOLOGY LABORATORY
616C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
617C                 GAITHERSBURG, MD 20899-8980
618C                 PHONE--301-975-2899
619C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
620C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
621C     LANGUAGE--ANSI FORTRAN (1977)
622C     VERSION NUMBER--2006/3
623C     ORIGINAL VERSION--MARCH     2006.
624C     UPDATED         --MAY       2006. CHECK FOR NGROUPS = 1 CASE,
625C                                       THIS RESULTS IN 0 DEGREES
626C                                       OF FREEDOM FOR CHI-SQUARE
627C                                       RANDOM NUMBERS
628C     UPDATED         --JUNE      2006. CHECK FOR LABS THAT HAVE
629C                                       ONLY 1 OBSERVATION.
630C     UPDATED         --FEBRUARY  2010. USE DPDTA1 TO PRINT
631C
632C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES--------------
633C
634      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
635C
636      CHARACTER*4 ICAPSW
637      CHARACTER*4 ICAPTY
638      CHARACTER*4 ISUBRO
639      CHARACTER*4 IBUGA3
640      CHARACTER*4 IERROR
641C
642      CHARACTER*4 IWRITE
643      CHARACTER*4 ISUBN1
644      CHARACTER*4 ISUBN2
645C
646      DOUBLE PRECISION DTEMP1(*)
647      DOUBLE PRECISION DTEMP2(*)
648C
649      REAL AMEAN(*)
650      REAL ASD(*)
651C
652      REAL XGCI
653      REAL SEGCI
654C
655      INTEGER N(*)
656C
657      DOUBLE PRECISION DALPHA
658      DOUBLE PRECISION DTERM1
659      DOUBLE PRECISION DTERM2
660C
661C----------------------------------------------------------------
662C
663      INCLUDE 'DPCOST.INC'
664C
665      PARAMETER (MAXROW=20)
666      CHARACTER*60 ITITLE
667      CHARACTER*60 ITITLZ
668      CHARACTER*60 ITITL9
669      CHARACTER*60 ITEXT(MAXROW)
670      REAL         AVALUE(MAXROW)
671      INTEGER      NCTEXT(MAXROW)
672      INTEGER      IDIGIT(MAXROW)
673      INTEGER      NTOT(MAXROW)
674      LOGICAL IFRST
675      LOGICAL ILAST
676C
677      INCLUDE 'DPCOP2.INC'
678C
679C-----START POINT------------------------------------------------
680C
681      IERROR='NO'
682      ISUBN1='DPGC'
683      ISUBN2='I   '
684C
685      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PGCI')THEN
686        WRITE(ICOUT,999)
687  999   FORMAT(1X)
688        CALL DPWRST('XXX','BUG ')
689        WRITE(ICOUT,51)
690   51   FORMAT('***** AT THE BEGINNING OF DPGCI--')
691        CALL DPWRST('XXX','BUG ')
692        WRITE(ICOUT,52)IWRITE,NPTS,NLAB
693   52   FORMAT('IWRITE,NPTS,NLAB = ',A4,2X,2I8)
694        CALL DPWRST('XXX','BUG ')
695      ENDIF
696C
697      IFLAG=0
698      DO100I=1,NLAB
699        IINDX1=I
700        IINDX2=I+NLAB
701        DTEMP1(IINDX1)=DBLE(AMEAN(I))
702        DTEMP1(IINDX2)=DBLE(ASD(I))**2
703        NITEMP=ABS(N(I))
704        IF(NITEMP.LE.1)IFLAG=1
705  100 CONTINUE
706      IINDX1=1
707      IINDX2=1+NLAB
708      IINDX3=1+2*NLAB
709      IINDX4=1+3*NLAB
710C
711      DALPHA=0.95
712      NRUN=10000
713      IERROR='NO'
714C
715      IF(NLAB.GT.1.AND.IFLAG.EQ.0)THEN
716        CALL GCI1(NLAB,N,DTEMP1(IINDX1),DTEMP1(IINDX2),
717     1            DALPHA,NRUN,DTERM1,
718     1            DLOWGC,DHIGGC,DTERM2,
719     1            DTEMP1(IINDX3),DTEMP1(IINDX4),DTEMP2,
720     1            IERROR)
721        SEGCI=REAL(DTERM2)
722        IF(IERROR.EQ.'YES')THEN
723           XGCI=0.0
724           SEGCI=0.0
725           DLOWGC=0.0D0
726           DHIGGC=0.0D0
727           GOTO9000
728        ELSE
729           XGCI=REAL(DTERM1)
730        ENDIF
731      ELSE
732        XGCI=0.0
733        SEGCI=0.0
734        DLOWGC=0.0D0
735        DHIGGC=0.0D0
736        GOTO9000
737      ENDIF
738C
739      IF(IPRINT.EQ.'OFF')GOTO9000
740C
741      WRITE(IOUNI5,201)
742  201 FORMAT('RESULTS FROM GENERALIZED CONFIDENCE INTERVAL SIMULATIONS')
743      DO200I=1,NRUN
744        WRITE(IOUNI5,'(E15.7)')DTEMP2(I)
745  200 CONTINUE
746C
747      ITITLE=' '
748      NCTITL=0
749      ITITLZ=' '
750      NCTITZ=0
751C
752      ICNT=1
753      ITEXT(ICNT)=' 7. Method: Generalized Confidence Intervals'
754      NCTEXT(ICNT)=44
755      AVALUE(ICNT)=0.0
756      IDIGIT(ICNT)=-1
757C
758      ICNT=ICNT+1
759      ITEXT(ICNT)='    Estimate of Consensus Mean:'
760      NCTEXT(ICNT)=31
761      AVALUE(ICNT)=XGCI
762      IDIGIT(ICNT)=NUMDIG
763      ICNT=ICNT+1
764      ITEXT(ICNT)='    Standard Uncertainty (k = 1):'
765      NCTEXT(ICNT)=33
766      AVALUE(ICNT)=SEGCI
767      IDIGIT(ICNT)=NUMDIG
768      ICNT=ICNT+1
769      ITEXT(ICNT)='    Expanded Uncertainty (k = 2):'
770      NCTEXT(ICNT)=33
771      AVALUE(ICNT)=2.0*SEGCI
772      IDIGIT(ICNT)=NUMDIG
773      ICNT=ICNT+1
774      ITEXT(ICNT)='    Lower 95% (Simulation) Confidence Limit:'
775      NCTEXT(ICNT)=44
776      AVALUE(ICNT)=DLOWGC
777      IDIGIT(ICNT)=NUMDIG
778      ICNT=ICNT+1
779      ITEXT(ICNT)='    Upper 95% (Simulation) Confidence Limit:'
780      NCTEXT(ICNT)=44
781      AVALUE(ICNT)=DHIGGC
782      IDIGIT(ICNT)=NUMDIG
783      ICNT=ICNT+1
784      ITEXT(ICNT)=
785     1 '    Note: Generalized Confidence Interval Best Usage:'
786      NCTEXT(ICNT)=53
787      AVALUE(ICNT)=0.0
788      IDIGIT(ICNT)=-1
789      ICNT=ICNT+1
790      ITEXT(ICNT)='          Any Number of Labs:'
791      NCTEXT(ICNT)=39
792      AVALUE(ICNT)=0.0
793      IDIGIT(ICNT)=-1
794C
795      NUMROW=ICNT
796      DO310I=1,NUMROW
797        NTOT(I)=15
798  310 CONTINUE
799C
800      IFRST=.TRUE.
801      ILAST=.TRUE.
802      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
803     1            AVALUE,IDIGIT,
804     1            NTOT,NUMROW,
805     1            ICAPSW,ICAPTY,ILAST,IFRST,
806     1            ISUBRO,IBUGA3,IERROR)
807      ITITLE=' '
808      NCTITL=0
809      ITITLZ=' '
810      NCTITZ=0
811      ITITL9=' '
812      NCTIT9=0
813C
814C               *****************
815C               **  STEP 90--  **
816C               **  EXIT       **
817C               *****************
818C
819 9000 CONTINUE
820      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PGCI')THEN
821        WRITE(ICOUT,999)
822        CALL DPWRST('XXX','BUG ')
823        WRITE(ICOUT,9011)
824 9011   FORMAT('***** AT THE END       OF DPGCI--')
825        CALL DPWRST('XXX','BUG ')
826        WRITE(ICOUT,9012)IERROR
827 9012   FORMAT('IERROR = ',A4)
828        CALL DPWRST('XXX','BUG ')
829        WRITE(ICOUT,9013)NPTS,NLAB
830 9013   FORMAT('NPTS,NLAB = ',2I8)
831        CALL DPWRST('XXX','BUG ')
832        WRITE(ICOUT,9014)XGCI
833 9014   FORMAT('XGCI = ',G15.7)
834        CALL DPWRST('XXX','BUG ')
835        WRITE(ICOUT,9015)DLOWGC,DHIGGC
836 9015   FORMAT('DLOWGC,DHIGGC = ',2G15.7)
837        CALL DPWRST('XXX','BUG ')
838      ENDIF
839C
840      RETURN
841      END
842      SUBROUTINE DPGCL(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS,
843     1IBUGD2,IFOUND,IERROR)
844C
845C     PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES
846C              FOR GREEK COMPLEX LOWER CASE.
847C     WRITTEN BY--JAMES J. FILLIBEN
848C                 STATISTICAL ENGINEERING DIVISION
849C                 INFORMATION TECHNOLOGY LABORATORY
850C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
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 TECHNOOGY.
855C     LANGUAGE--ANSI FORTRAN (1977)
856C     VERSION NUMBER--87/4
857C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH     1981.
858C     UPDATED         --MAY       1982.
859C     UPDATED         --MARCH     1987.
860C
861C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
862C
863      CHARACTER*4 ICHAR2
864      CHARACTER*4 IOP
865      CHARACTER*4 IBUGD2
866      CHARACTER*4 IFOUND
867      CHARACTER*4 IERROR
868C
869C---------------------------------------------------------------------
870C
871      DIMENSION IOP(*)
872      DIMENSION X(*)
873      DIMENSION Y(*)
874C
875C---------------------------------------------------------------------
876C
877      INCLUDE 'DPCOP2.INC'
878C
879C-----START POINT-----------------------------------------------------
880C
881      IFOUND='NO'
882      IERROR='NO'
883C
884      NUMCO=1
885      ISTART=1
886      ISTOP=1
887      NC=1
888C
889C               ******************************************
890C               **  TREAT THE ROMAN SIMPLEX UPPER CASE  **
891C               **  HERSHEY CHARACTER SET CASE          **
892C               ******************************************
893C
894C
895      IF(IBUGD2.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 DPGCL--')
901      CALL DPWRST('XXX','BUG ')
902      WRITE(ICOUT,52)ICHAR2
903   52 FORMAT('ICHAR2 = ',A4)
904      CALL DPWRST('XXX','BUG ')
905      WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR
906   59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
907      CALL DPWRST('XXX','BUG ')
908   90 CONTINUE
909C
910C               **************************************************
911C               **  STEP 1--                                    **
912C               **  SEARCH FOR THE INPUT CHARACTER(S).          **
913C               **  MAP THE CHARACTER(S) INTO A NUMERIC VALUE.  **
914C               **************************************************
915C
916      CALL DPCHGR(ICHAR2,ICHARN,IBUGD2,IFOUND)
917      IF(IFOUND.EQ.'NO')GOTO9000
918C
919      IF(ICHARN.LE.9)GOTO1010
920      GOTO1019
921 1010 CONTINUE
922      CALL DGCL1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS,
923     1IBUGD2,IFOUND,IERROR)
924      GOTO9000
925 1019 CONTINUE
926C
927      IF(10.LE.ICHARN.AND.ICHARN.LE.20)GOTO1020
928      GOTO1029
929 1020 CONTINUE
930      CALL DGCL2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS,
931     1IBUGD2,IFOUND,IERROR)
932      GOTO9000
933 1029 CONTINUE
934C
935      IF(ICHARN.GE.21)GOTO1030
936      GOTO1039
937 1030 CONTINUE
938      CALL DGCL3(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS,
939     1IBUGD2,IFOUND,IERROR)
940      GOTO9000
941 1039 CONTINUE
942C
943      IFOUND='NO'
944      GOTO9000
945C
946C               *****************
947C               **  STEP 90--  **
948C               **  EXIT       **
949C               *****************
950C
951 9000 CONTINUE
952      IF(IBUGD2.EQ.'OFF')GOTO9090
953      WRITE(ICOUT,999)
954      CALL DPWRST('XXX','BUG ')
955      WRITE(ICOUT,9011)
956 9011 FORMAT('***** AT THE END       OF DPGCL--')
957      CALL DPWRST('XXX','BUG ')
958      WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR
959 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
960      CALL DPWRST('XXX','BUG ')
961      WRITE(ICOUT,9013)ICHAR2,ICHARN
962 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8)
963      CALL DPWRST('XXX','BUG ')
964      WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO
965 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8)
966      CALL DPWRST('XXX','BUG ')
967      IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019
968      DO9015I=1,NUMCO
969      WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I)
970 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2)
971      CALL DPWRST('XXX','BUG ')
972 9015 CONTINUE
973 9019 CONTINUE
974      WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS
975 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8)
976      CALL DPWRST('XXX','BUG ')
977 9090 CONTINUE
978C
979      RETURN
980      END
981      SUBROUTINE DPGCU(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS,
982     1IBUGD2,IFOUND,IERROR)
983C
984C     PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES
985C              FOR GREEK COMPLEX UPPER CASE.
986C     WRITTEN BY--JAMES J. FILLIBEN
987C                 STATISTICAL ENGINEERING DIVISION
988C                 INFORMATION TECHNOLOGY LABORATORY
989C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
990C                 GAITHERSBURG, MD 20899-8980
991C                 PHONE--301-975-2855
992C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
993C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
994C     LANGUAGE--ANSI FORTRAN (1977)
995C     VERSION NUMBER--87/4
996C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH     1981.
997C     UPDATED         --MAY       1982.
998C     UPDATED         --MARCH     1987.
999C
1000C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
1001C
1002      CHARACTER*4 ICHAR2
1003      CHARACTER*4 IOP
1004      CHARACTER*4 IBUGD2
1005      CHARACTER*4 IFOUND
1006      CHARACTER*4 IERROR
1007C
1008C---------------------------------------------------------------------
1009C
1010      DIMENSION IOP(*)
1011      DIMENSION X(*)
1012      DIMENSION Y(*)
1013C
1014C---------------------------------------------------------------------
1015C
1016      INCLUDE 'DPCOP2.INC'
1017C
1018C-----START POINT-----------------------------------------------------
1019C
1020      IFOUND='NO'
1021      IERROR='NO'
1022C
1023      NUMCO=1
1024      ISTART=1
1025      ISTOP=1
1026      NC=1
1027C
1028C               ******************************************
1029C               **  TREAT THE ROMAN SIMPLEX UPPER CASE  **
1030C               **  HERSHEY CHARACTER SET CASE          **
1031C               ******************************************
1032C
1033C
1034      IF(IBUGD2.EQ.'OFF')GOTO90
1035      WRITE(ICOUT,999)
1036  999 FORMAT(1X)
1037      CALL DPWRST('XXX','BUG ')
1038      WRITE(ICOUT,51)
1039   51 FORMAT('***** AT THE BEGINNING OF DPGCU--')
1040      CALL DPWRST('XXX','BUG ')
1041      WRITE(ICOUT,52)ICHAR2
1042   52 FORMAT('ICHAR2 = ',A4)
1043      CALL DPWRST('XXX','BUG ')
1044      WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR
1045   59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
1046      CALL DPWRST('XXX','BUG ')
1047   90 CONTINUE
1048C
1049C               **************************************************
1050C               **  STEP 1--                                    **
1051C               **  SEARCH FOR THE INPUT CHARACTER(S).          **
1052C               **  MAP THE CHARACTER(S) INTO A NUMERIC VALUE.  **
1053C               **************************************************
1054C
1055      CALL DPCHGR(ICHAR2,ICHARN,IBUGD2,IFOUND)
1056      IF(IFOUND.EQ.'NO')GOTO9000
1057C
1058      IF(ICHARN.LE.14)GOTO1010
1059      GOTO1019
1060 1010 CONTINUE
1061      CALL DGCU1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS,
1062     1IBUGD2,IFOUND,IERROR)
1063      GOTO9000
1064 1019 CONTINUE
1065C
1066      IF(ICHARN.GE.15)GOTO1020
1067      GOTO1029
1068 1020 CONTINUE
1069      CALL DGCU2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS,
1070     1IBUGD2,IFOUND,IERROR)
1071      GOTO9000
1072 1029 CONTINUE
1073C
1074      IFOUND='NO'
1075      GOTO9000
1076C
1077C               *****************
1078C               **  STEP 90--  **
1079C               **  EXIT       **
1080C               *****************
1081C
1082 9000 CONTINUE
1083      IF(IBUGD2.EQ.'OFF')GOTO9090
1084      WRITE(ICOUT,999)
1085      CALL DPWRST('XXX','BUG ')
1086      WRITE(ICOUT,9011)
1087 9011 FORMAT('***** AT THE END       OF DPGCU--')
1088      CALL DPWRST('XXX','BUG ')
1089      WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR
1090 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
1091      CALL DPWRST('XXX','BUG ')
1092      WRITE(ICOUT,9013)ICHAR2,ICHARN
1093 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8)
1094      CALL DPWRST('XXX','BUG ')
1095      WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO
1096 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8)
1097      CALL DPWRST('XXX','BUG ')
1098      IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019
1099      DO9015I=1,NUMCO
1100      WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I)
1101 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2)
1102      CALL DPWRST('XXX','BUG ')
1103 9015 CONTINUE
1104 9019 CONTINUE
1105      WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS
1106 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8)
1107      CALL DPWRST('XXX','BUG ')
1108 9090 CONTINUE
1109C
1110      RETURN
1111      END
1112      SUBROUTINE DPGENS(INCASE,TEMP,TEMP2,ISUBRO,IBUGA3,IBUGQ,
1113     1                  IFOUND,IERROR)
1114C
1115C     PURPOSE--GENERATE SPECIALIZED MATHEMATICAL NUMBER SEQUENCES--
1116C                 1) PRIME NUMBERS
1117C                 2) FIBONACCI SEQUENCES
1118C                 3) LOGISTIC NUMBERS
1119C                 4) BERNOULI NUMBERS
1120C                 5) EULER NUMBERS
1121C     WRITTEN BY--JAMES J. FILLIBEN
1122C                 STATISTICAL ENGINEERING DIVISION
1123C                 INFORMATION TECHNOLOGY LABORATORY
1124C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
1125C                 GAITHERSBURG, MD 20899-8980
1126C                 PHONE--301-975-2855
1127C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
1128C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
1129C     LANGUAGE--ANSI FORTRAN (1977)
1130C     VERSION NUMBER--87/10
1131C     ORIGINAL VERSION--SEPTEMBER 1987.
1132C     UPDATED         --APRIL     1989. LOGISTIC SEQUENCE (CHAOS THEORY)
1133C     UPDATED         --APRIL     1989. CANTOR SET (CHAOS THEORY)
1134C     UPDATED         --JULY      1993. CANTOR SET (NO ERROR IF P NOT
1135C                                       PREVIOUSLY DEFINED)
1136C     UPDATED         --FEBRUARY  1994. EQUIVALENCE
1137C     UPDATED         --SEPTEMBER 1997. BERNOULI NUMBERS
1138C     UPDATED         --SEPTEMBER 1997. EULER NUMBERS
1139C     UPDATED         --JULY      2019. MOVE CREATION OF SCRATCH STORAGE
1140C                                       TO DPLET
1141C     UPDATED         --JULY      2019. ADD ISUBRO TO CALL LIST
1142C
1143C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
1144C
1145      CHARACTER*4 INCASE
1146      CHARACTER*4 ISUBRO
1147      CHARACTER*4 IBUGA3
1148      CHARACTER*4 IBUGQ
1149      CHARACTER*4 IFOUND
1150      CHARACTER*4 IERROR
1151C
1152      DIMENSION TEMP(*)
1153      DOUBLE PRECISION TEMP2(*)
1154C
1155      CHARACTER*4 NEWNAM
1156      CHARACTER*4 NEWCOL
1157      CHARACTER*4 ICASEQ
1158      CHARACTER*4 ILEFT
1159      CHARACTER*4 ILEFT2
1160      CHARACTER*4 IHP
1161      CHARACTER*4 IHP2
1162      CHARACTER*4 IHWUSE
1163      CHARACTER*4 MESSAG
1164      CHARACTER*4 ISUBN1
1165      CHARACTER*4 ISUBN2
1166      CHARACTER*4 ISTEPN
1167C
1168C-----COMMON----------------------------------------------------------
1169C
1170      INCLUDE 'DPCOPA.INC'
1171      INCLUDE 'DPCOHK.INC'
1172      INCLUDE 'DPCODA.INC'
1173      INCLUDE 'DPCOP2.INC'
1174C
1175C-----START POINT-----------------------------------------------------
1176C
1177      ISUBN1='DPGE'
1178      ISUBN2='NS  '
1179      IFOUND='NO'
1180      IERROR='NO'
1181      IFOUND='YES'
1182C
1183      MAXCP1=MAXCOL+1
1184      MAXCP2=MAXCOL+2
1185      MAXCP3=MAXCOL+3
1186      MAXCP4=MAXCOL+4
1187      MAXCP5=MAXCOL+5
1188      MAXCP6=MAXCOL+6
1189C
1190      NS2=0
1191C
1192C               ***********************************************
1193C               **  TREAT THE MATH NUMBER GENERATION CASE    **
1194C               **       1) FOR A FULL VARIABLE, OR          **
1195C               **       2) FOR PART OF A VARIABLE.          **
1196C               ***********************************************
1197C
1198      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GENS')THEN
1199        WRITE(ICOUT,999)
1200  999   FORMAT(1X)
1201        CALL DPWRST('XXX','BUG ')
1202        WRITE(ICOUT,51)
1203   51   FORMAT('***** AT THE BEGINNING OF DPGENS--')
1204        CALL DPWRST('XXX','BUG ')
1205        WRITE(ICOUT,52)INCASE,IBUGA3,IBUGQ
1206   52   FORMAT('INCASE,IBUGA3,IBUGQ = ',2(A4,2X),A4)
1207        CALL DPWRST('XXX','BUG ')
1208      ENDIF
1209C
1210C               **********************************
1211C               **  STEP 1--                    **
1212C               **  INITIALIZE SOME VARIABLES.  **
1213C               **********************************
1214C
1215      ISTEPN='1'
1216      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GENS')
1217     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1218C
1219      NEWNAM='NO'
1220      NEWCOL='NO'
1221C
1222C               *******************************************************
1223C               **  STEP 2--                                         **
1224C               **  CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS.  **
1225C               *******************************************************
1226C
1227      ISTEPN='2'
1228      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GENS')
1229     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1230C
1231      MINNA=3
1232      MAXNA=100
1233      CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,
1234     1IERROR)
1235      IF(IERROR.EQ.'YES')GOTO9000
1236C
1237C               ********************************************************
1238C               **  STEP 3--                                           *
1239C               **  EXAMINE THE LEFT-HAND SIDE--                       *
1240C               **  IS THE PARAMETER OR VARIABLE NAME TO LEFT OF =     *
1241C               **  SIGN ALREADY IN THE NAME LIST?  NOTE THAT          *
1242C               **  ILEFT  IS THE NAME OF THE VARIABLE ON THE LEFT     *
1243C               **  NOTE THAT  ILISTL  IS THE LINE IN THE TABLE OF THE *
1244C               **  NAME ON THE LEFT.  NOTE THAT  ICOLL  IS THE DATA   *
1245C               **  COLUMN (1 TO 12) FOR THE NAME OF THE LEFT.         *
1246C               ********************************************************
1247C
1248      ISTEPN='3'
1249      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GENS')
1250     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1251C
1252      ILEFT=IHARG(1)
1253      ILEFT2=IHARG2(1)
1254      DO310I=1,NUMNAM
1255        I2=I
1256        IF(ILEFT.EQ.IHNAME(I).AND.ILEFT2.EQ.IHNAM2(I).AND.
1257     1     IUSE(I).EQ.'P')THEN
1258          ILISTL=I2
1259          GOTO330
1260        ELSEIF(ILEFT.EQ.IHNAME(I).AND.ILEFT2.EQ.IHNAM2(I).AND.
1261     1         IUSE(I).EQ.'V')THEN
1262          ILISTL=I2
1263          ICOLL=IVALUE(ILISTL)
1264          NLEFT=IN(ILISTL)
1265          GOTO390
1266        ENDIF
1267  310 CONTINUE
1268      NEWNAM='YES'
1269      ILISTL=NUMNAM+1
1270C
1271      IF(ILISTL.GT.MAXNAM)THEN
1272        WRITE(ICOUT,999)
1273        CALL DPWRST('XXX','BUG ')
1274        WRITE(ICOUT,321)
1275  321   FORMAT('***** ERROR IN DPGENS--')
1276        CALL DPWRST('XXX','BUG ')
1277        WRITE(ICOUT,322)
1278  322   FORMAT('      THE NUMBER OF VARIABLE AND/OR PARAMETER')
1279        CALL DPWRST('XXX','BUG ')
1280        WRITE(ICOUT,323)MAXNAM
1281  323   FORMAT('      NAMES HAS JUST EXCEEDED THE MAX ALLOWABLE ',
1282     1         I8,'  .')
1283        CALL DPWRST('XXX','BUG ')
1284        WRITE(ICOUT,324)
1285  324   FORMAT('      SUGGESTED ACTION--')
1286        CALL DPWRST('XXX','BUG ')
1287        WRITE(ICOUT,325)
1288  325   FORMAT('      ENTER      STATUS')
1289        CALL DPWRST('XXX','BUG ')
1290        WRITE(ICOUT,326)
1291  326   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES,')
1292        CALL DPWRST('XXX','BUG ')
1293        WRITE(ICOUT,327)
1294  327   FORMAT('      AND THEN REDEFINE (REUSE) SOME OF THE')
1295        CALL DPWRST('XXX','BUG ')
1296        WRITE(ICOUT,328)
1297  328   FORMAT('      ALREADY-USED NAMES')
1298        CALL DPWRST('XXX','BUG ')
1299        IERROR='YES'
1300        GOTO9000
1301      ENDIF
1302C
1303  330 CONTINUE
1304      NLEFT=0
1305      ICOLL=NUMCOL+1
1306      IF(ICOLL.GT.MAXCOL)THEN
1307        WRITE(ICOUT,321)
1308        CALL DPWRST('XXX','BUG ')
1309        WRITE(ICOUT,342)
1310  342   FORMAT('      THE NUMBER OF DATA COLUMNS HAS JUST')
1311        CALL DPWRST('XXX','BUG ')
1312        WRITE(ICOUT,343)MAXCOL
1313  343   FORMAT('      EXCEEDED THE MAX ALLOWABLE ',I8,'  .')
1314        CALL DPWRST('XXX','BUG ')
1315        WRITE(ICOUT,324)
1316        CALL DPWRST('XXX','BUG ')
1317        WRITE(ICOUT,345)
1318  345   FORMAT('      ENTER      STATUS VARIABLES')
1319        CALL DPWRST('XXX','BUG ')
1320        WRITE(ICOUT,346)
1321  346   FORMAT('      TO FIND OUT THE FULL LIST OF USED COLUMNS')
1322        CALL DPWRST('XXX','BUG ')
1323        WRITE(ICOUT,347)
1324  347   FORMAT('      AND THEN OVERWRITE SOME COLUMNS.   EXAMPLE--')
1325        CALL DPWRST('XXX','BUG ')
1326        WRITE(ICOUT,348)
1327  348   FORMAT('      IF       LET X(I) = 3.14         FAILED')
1328        CALL DPWRST('XXX','BUG ')
1329        WRITE(ICOUT,349)
1330  349   FORMAT('      THEN ONE MIGHT ENTER     NAME X 7')
1331        CALL DPWRST('XXX','BUG ')
1332        WRITE(ICOUT,350)
1333  350   FORMAT('      (THEREBY EQUATING THE NAME X WITH COLUMN 7')
1334        CALL DPWRST('XXX','BUG ')
1335        WRITE(ICOUT,351)
1336  351   FORMAT('      FOLLOWED BY              LET X = 3.14')
1337        CALL DPWRST('XXX','BUG ')
1338        WRITE(ICOUT,352)
1339  352   FORMAT('      (WHICH WILL ACTUALLY OVERWRITE COLUMN 7')
1340        CALL DPWRST('XXX','BUG ')
1341        WRITE(ICOUT,353)
1342  353   FORMAT('      WITH THE NUMERIC CONSTANTS 3.14)')
1343        CALL DPWRST('XXX','BUG ')
1344        IERROR='YES'
1345        GOTO9000
1346      ENDIF
1347C
1348  390 CONTINUE
1349C
1350C               *****************************************
1351C               **  STEP 6--                           **
1352C               **  CHECK TO SEE THE TYPE SUBCASE      **
1353C               **  (BASED ON THE QUALIFIER)           **
1354C               **    1) UNQUALIFIED (THAT IS, FULL);  **
1355C               **    2) SUBSET/EXCEPT; OR             **
1356C               **    3) FOR.                          **
1357C               *****************************************
1358C
1359      ISTEPN='6'
1360      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GENS')
1361     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1362C
1363      ICASEQ='FULL'
1364      ILOCQ=NUMARG+1
1365      IF(NUMARG.GE.1)THEN
1366        DO610J=1,NUMARG
1367          J1=J
1368          IF((IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET  ') .OR.
1369     1       (IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT  '))THEN
1370            ICASEQ='SUBS'
1371            ILOCQ=J1
1372            GOTO680
1373          ELSEIF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.'    ')THEN
1374            ICASEQ='FOR'
1375            ILOCQ=J1
1376            GOTO680
1377          ENDIF
1378  610   CONTINUE
1379        GOTO680
1380      ELSE
1381        WRITE(ICOUT,999)
1382        CALL DPWRST('XXX','BUG ')
1383        WRITE(ICOUT,321)
1384        CALL DPWRST('XXX','BUG ')
1385        WRITE(ICOUT,672)
1386  672   FORMAT('      AT BRANCH POINT 5081--')
1387        CALL DPWRST('XXX','BUG ')
1388        WRITE(ICOUT,673)
1389  673   FORMAT('      NUMARG LESS THAN 1 EVEN THOUGH')
1390        CALL DPWRST('XXX','BUG ')
1391        WRITE(ICOUT,674)
1392  674   FORMAT('      NUMARG HAD PREVIOUSLY PASSED THIS TEST')
1393        CALL DPWRST('XXX','BUG ')
1394        WRITE(ICOUT,675)NUMARG
1395  675   FORMAT('      ONCE ALREADY.  VALUE OF NUMARG = ',I8)
1396        CALL DPWRST('XXX','BUG ')
1397        WRITE(ICOUT,676)
1398  676   FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
1399        CALL DPWRST('XXX','BUG ')
1400        IF(IWIDTH.GE.1)THEN
1401          WRITE(ICOUT,677)(IANS(I),I=1,MIN(80,IWIDTH))
1402  677     FORMAT(80A1)
1403          CALL DPWRST('XXX','BUG ')
1404        ENDIF
1405        IERROR='YES'
1406        GOTO9000
1407      ENDIF
1408C
1409  680 CONTINUE
1410      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GENS')THEN
1411        WRITE(ICOUT,681)NUMARG,ILOCQ,ICASEQ
1412  681   FORMAT('NUMARG,ILOCQ,ICASEQ = ',2I8,2X,A4)
1413        CALL DPWRST('XXX','BUG ')
1414      ENDIF
1415C
1416C               ******************************************************
1417C               **  STEP 7--                                        **
1418C               **  BRANCH TO THE APPROPRIATE SUBCASE               **
1419C               **  (BASED ON THE QUALIFIER);                       **
1420C               **  DETERMINE THE NUMBER (= NUMNUM)                 **
1421C               **  OF NUMBERS TO BE GENERATED.                     **
1422C               **  NOTE THAT THE VARIABLE NIISUB                   **
1423C               **  IS THE LENGTH OF THE RESULTING                  **
1424C               **  VARIABLE ISUB(.).                               **
1425C               **  NOTE THAT DPFOR AUTOMATICALLY EXTENDS           **
1426C               **  THE INPUT LENGTH OF ISUB(.) IF NECESSARY.       **
1427C               **  (HENCE THE REDEFINITION OF NIISUB TO NINEW      **
1428C               **  AFTER THE CALL TO DPFOR.                        **
1429C               ******************************************************
1430C
1431      ISTEPN='7'
1432      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GENS')
1433     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1434C
1435      IF(ICASEQ.EQ.'FULL')THEN
1436        IF(NEWNAM.EQ.'NO')NIISUB=NLEFT
1437        IF(NEWNAM.EQ.'YES')NIISUB=MAXN
1438        DO715I=1,NIISUB
1439          ISUB(I)=1
1440  715   CONTINUE
1441        NUMNUM=NIISUB
1442      ELSEIF(ICASEQ.EQ.'SUBS')THEN
1443        NIISUB=MAXN
1444        CALL DPSUBS(NIISUB,ILOCS,NS,IBUGQ,IERROR)
1445        NUMNUM=NS
1446      ELSEIF(ICASEQ.EQ.'FOR')THEN
1447        IF(NEWNAM.EQ.'NO')NIISUB=NLEFT
1448        IF(NEWNAM.EQ.'YES')NIISUB=MAXN
1449        CALL DPFOR(NIISUB,NINEW,IROW1,IROWN,
1450     1             NLOCAL,ILOCS,NS,IBUGQ,IERROR)
1451        NIISUB=NINEW
1452        NUMNUM=NS
1453      ENDIF
1454C
1455C               *******************************************
1456C               **  STEP 8--                             **
1457C               **  GENERATE    NUMNUM    NUMBERS        **
1458C               **  STORE THEM TEMPORARILY IN            **
1459C               **  THE VECTOR Y(.).                     **
1460C               *******************************************
1461C
1462      ISTEPN='8'
1463      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GENS')
1464     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1465C
1466      IF(INCASE.EQ.'PRIM')THEN
1467        CALL PRIMES(NUMNUM,Y,IERROR)
1468        IF(IERROR.EQ.'YES')GOTO9000
1469      ELSEIF(INCASE.EQ.'FIBO')THEN
1470        CALL FIBONN(NUMNUM,Y,IERROR)
1471        IF(IERROR.EQ.'YES')GOTO9000
1472      ELSEIF(INCASE.EQ.'LOGI')THEN
1473        IHP='X0  '
1474        IHP2='    '
1475        IHWUSE='P'
1476        MESSAG='YES'
1477        CALL CHECKN(IHP,IHP2,IHWUSE,
1478     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
1479     1              ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
1480        IF(IERROR.EQ.'YES')GOTO9000
1481        Y0=VALUE(ILOCP)
1482C
1483        IF(Y0.LT.0.0.OR.Y0.GT.1.0)THEN
1484          WRITE(ICOUT,999)
1485          CALL DPWRST('XXX','BUG ')
1486          WRITE(ICOUT,321)
1487          CALL DPWRST('XXX','BUG ')
1488          WRITE(ICOUT,1312)
1489 1312     FORMAT('      THE STARTING POINT X0 FOR THE LOGISTIC ',
1490     1           'SEQUENCE')
1491          CALL DPWRST('XXX','BUG ')
1492          WRITE(ICOUT,1314)
1493 1314     FORMAT('      X(N+1) = K * X(N) * (1 - X(N))')
1494          CALL DPWRST('XXX','BUG ')
1495          WRITE(ICOUT,1315)
1496 1315     FORMAT('      MUST BE BETWEEN 0 AND 1 INCLUSIVE;')
1497          CALL DPWRST('XXX','BUG ')
1498          WRITE(ICOUT,1316)
1499 1316     FORMAT('      SUCH WAS NOT THE CASE HERE.')
1500          CALL DPWRST('XXX','BUG ')
1501          WRITE(ICOUT,1317)Y0
1502 1317     FORMAT('      THE CURRENT VALUE OF X0 IS ',E15.7)
1503          CALL DPWRST('XXX','BUG ')
1504          IERROR='YES'
1505          GOTO9000
1506        ENDIF
1507C
1508        IHP='K   '
1509        IHP2='    '
1510        IHWUSE='P'
1511        MESSAG='YES'
1512        CALL CHECKN(IHP,IHP2,IHWUSE,
1513     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
1514     1              ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
1515        IF(IERROR.EQ.'YES')GOTO9000
1516        AK=VALUE(ILOCP)
1517C
1518        IF(AK.LT.0.0.OR.AK.GT.4.0)THEN
1519          WRITE(ICOUT,999)
1520          CALL DPWRST('XXX','BUG ')
1521          WRITE(ICOUT,321)
1522          CALL DPWRST('XXX','BUG ')
1523          WRITE(ICOUT,1322)
1524 1322     FORMAT('      THE MULTIPLICATION FACTOR K FOR THE LOGISTIC ',
1525     1           'SEQUENCE')
1526          CALL DPWRST('XXX','BUG ')
1527          WRITE(ICOUT,1324)
1528 1324     FORMAT('      X(N+1) = K * X(N) * (1 - X(N))')
1529          CALL DPWRST('XXX','BUG ')
1530          WRITE(ICOUT,1325)
1531 1325     FORMAT('      MUST BE BETWEEN 0 AND 4 INCLUSIVE;.')
1532          CALL DPWRST('XXX','BUG ')
1533          WRITE(ICOUT,1316)
1534          CALL DPWRST('XXX','BUG ')
1535          WRITE(ICOUT,1327)AK
1536 1327     FORMAT('      THE CURRENT VALUE OF K IS ',E15.7)
1537          CALL DPWRST('XXX','BUG ')
1538          IERROR='YES'
1539          GOTO9000
1540        ENDIF
1541C
1542        CALL LOGIST(NUMNUM,Y,Y0,AK,IERROR)
1543        IF(IERROR.EQ.'YES')GOTO9000
1544      ELSEIF(INCASE.EQ.'CANT')THEN
1545CCCCC   JULY 1993.  SET P TO 0.33333 IF NOT PROVIDED.
1546CCCCC   DON'T CALL CHECKN (AVOID ERROR MESSAGE)
1547        IHP='P   '
1548        IHP2='    '
1549        IHWUSE='P'
1550        MESSAG='NO'
1551        CALL CHECKN(IHP,IHP2,IHWUSE,
1552     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
1553     1              ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
1554        IF(IERROR.EQ.'YES')THEN
1555          P=0.333333
1556        ELSE
1557          P=VALUE(ILOCP)
1558        ENDIF
1559C
1560        IF(P.LT.0.0.OR.P.GT.1.0)THEN
1561          WRITE(ICOUT,999)
1562          CALL DPWRST('XXX','BUG ')
1563          WRITE(ICOUT,321)
1564          CALL DPWRST('XXX','BUG ')
1565          WRITE(ICOUT,1412)
1566 1412     FORMAT('      THE FRACTIONAL HOLE SIZE P FOR THE CANTOR SET')
1567          CALL DPWRST('XXX','BUG ')
1568          WRITE(ICOUT,1414)
1569 1414     FORMAT('      MUST BE BETWEEN 0 AND 1 INCLUSIVE;.')
1570          CALL DPWRST('XXX','BUG ')
1571          WRITE(ICOUT,1316)
1572          CALL DPWRST('XXX','BUG ')
1573          WRITE(ICOUT,1416)P
1574 1416     FORMAT('      THE CURRENT VALUE OF P IS ',G15.7)
1575          CALL DPWRST('XXX','BUG ')
1576          IERROR='YES'
1577          GOTO9000
1578        ENDIF
1579C
1580        CALL CANTOR(NUMNUM,Y,P,TEMP,IERROR)
1581        IF(IERROR.EQ.'YES')GOTO9000
1582      ELSEIF(INCASE.EQ.'BERN')THEN
1583        CALL BERNOB(NUMNUM,TEMP2(1))
1584        DO1510I=1,NUMNUM
1585          IF(TEMP2(I).GE.DBLE(CPUMAX))THEN
1586            Y(I)=CPUMAX
1587            WRITE(ICOUT,1515)
1588            CALL DPWRST('XXX','BUG ')
1589 1515       FORMAT('**** ERROR: COMPUTED BERNOULLI NUMBER RESULTS ',
1590     1             'IN OVERFLOW, SET TO MACHINE MAXIMUM.')
1591          ELSE
1592            Y(I)=REAL(TEMP2(I))
1593          ENDIF
1594 1510   CONTINUE
1595        IF(IERROR.EQ.'YES')GOTO9000
1596      ELSEIF(INCASE.EQ.'EULE')THEN
1597        CALL EULERB(NUMNUM,TEMP2(1))
1598        DO1610I=1,NUMNUM
1599          IF(TEMP2(I).GE.DBLE(CPUMAX))THEN
1600            Y(I)=CPUMAX
1601            WRITE(ICOUT,1615)
1602            CALL DPWRST('XXX','BUG ')
1603 1615       FORMAT('**** ERROR: COMPUTED EULER NUMBER RESULTS ',
1604     1             'IN OVERFLOW, SET TO MACHINE MAXIMUM.')
1605          ELSE
1606            Y(I)=REAL(TEMP2(I))
1607          ENDIF
1608 1610   CONTINUE
1609        IF(IERROR.EQ.'YES')GOTO9000
1610      ELSE
1611        IFOUND='NO'
1612        GOTO9000
1613      ENDIF
1614C
1615C               ********************************************************
1616C               **  STEP 8--                                          **
1617C               **  IF CALLED FOR (THAT IS, IF IBUGA3 IS ON),         **
1618C               **  PRINT OUT THE INTERMEDIATE VARIABLE Y(.).         **
1619C               **  THIS IS USEFUL FOR DIAGNOSTIC PURPOSES            **
1620C               **  IN REVIEWING THE OUTPUT FROM THIS SUBROUTINE.     **
1621C               ********************************************************
1622C
1623      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GENS')THEN
1624        ISTEPN='9'
1625        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1626        WRITE(ICOUT,2051)
1627 2051   FORMAT('OUTPUT FROM MIDDLE OF DPGENS AFTER INDIVIDUAL ',
1628     1         'GENERATORS HAVE BEEN CALLED--')
1629        CALL DPWRST('XXX','BUG ')
1630        WRITE(ICOUT,2052)NUMNUM
1631 2052   FORMAT('NUMNUM = ',I8)
1632        CALL DPWRST('XXX','BUG ')
1633        IF(NUMNUM.GT.0)THEN
1634          DO2054I=1,NUMNUM
1635            WRITE(ICOUT,2055)I,Y(I)
1636 2055       FORMAT('I,Y(I) = ',I8,F12.5)
1637            CALL DPWRST('XXX','BUG ')
1638 2054     CONTINUE
1639        ENDIF
1640      ENDIF
1641C
1642C               ******************************************************
1643C               **  STEP 9--                                        **
1644C               **  COPY THE GENERATED NUMBERS                      **
1645C               **  FROM THE INTERMEDIATE VECTOR Y(.)               **
1646C               **  TO THE APPROPRIATE COLUMN                       **
1647C               **  (BASED ON THE QUALIFIER--FULL, SUBSET, OR FOR)  **
1648C               **  IN THE INTERNAL DATAPLOT DATA TABLE.            **
1649C               ******************************************************
1650C
1651      ISTEPN='10'
1652      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GENS')
1653     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1654C
1655      NS2=0
1656      DO2100I=1,NIISUB
1657        IJ=MAXN*(ICOLL-1)+I
1658        IF(ISUB(I).EQ.0)GOTO2100
1659        NS2=NS2+1
1660        IF(ICOLL.LE.MAXCOL)V(IJ)=Y(NS2)
1661        IF(ICOLL.EQ.MAXCP1)PRED(I)=Y(NS2)
1662        IF(ICOLL.EQ.MAXCP2)RES(I)=Y(NS2)
1663        IF(ICOLL.EQ.MAXCP3)YPLOT(I)=Y(NS2)
1664        IF(ICOLL.EQ.MAXCP4)XPLOT(I)=Y(NS2)
1665        IF(ICOLL.EQ.MAXCP5)X2PLOT(I)=Y(NS2)
1666        IF(ICOLL.EQ.MAXCP6)TAGPLO(I)=Y(NS2)
1667        IF(NS2.EQ.1)IROW1=I
1668        IROWN=I
1669 2100 CONTINUE
1670C
1671C               *******************************************
1672C               **  STEP 10--                            **
1673C               **  CARRY OUT THE LIST UPDATING AND      **
1674C               **  GENERATE THE INFORMATIVE PRINTING.   **
1675C               *******************************************
1676C
1677      ISTEPN='11'
1678      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GENS')
1679     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1680C
1681      IF(ICASEQ.EQ.'FULL'.AND.NEWNAM.EQ.'NO')NINEW=NLEFT
1682      IF(ICASEQ.EQ.'FULL'.AND.NEWNAM.EQ.'YES')NINEW=MAXN
1683      IF(ICASEQ.EQ.'SUBS'.AND.NEWNAM.EQ.'NO'.AND.
1684     1NLEFT.GE.IROWN)NINEW=NLEFT
1685      IF(ICASEQ.EQ.'SUBS'.AND.NEWNAM.EQ.'NO'.AND.
1686     1NLEFT.LT.IROWN)NINEW=IROWN
1687      IF(ICASEQ.EQ.'SUBS'.AND.NEWNAM.EQ.'YES')NINEW=IROWN
1688      IF(ICASEQ.EQ.'FOR'.AND.NEWNAM.EQ.'NO'.AND.
1689     1NLEFT.GE.IROWN)NINEW=NLEFT
1690      IF(ICASEQ.EQ.'FOR'.AND.NEWNAM.EQ.'NO'.AND.
1691     1NLEFT.LT.IROWN)NINEW=IROWN
1692      IF(ICASEQ.EQ.'FOR'.AND.NEWNAM.EQ.'YES')NINEW=IROWN
1693C
1694      IHNAME(ILISTL)=ILEFT
1695      IHNAM2(ILISTL)=ILEFT2
1696      IUSE(ILISTL)='V'
1697      IVALUE(ILISTL)=ICOLL
1698      VALUE(ILISTL)=ICOLL
1699      IN(ILISTL)=NINEW
1700C
1701      IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1
1702      IF(NEWNAM.EQ.'YES')NUMCOL=NUMCOL+1
1703C
1704      DO4100J4=1,NUMNAM
1705        IF(IUSE(J4).EQ.'V'.AND.IVALUE(J4).EQ.ICOLL)THEN
1706          IUSE(J4)='V'
1707          IVALUE(J4)=ICOLL
1708          VALUE(J4)=ICOLL
1709          IN(J4)=NINEW
1710        ENDIF
1711 4100 CONTINUE
1712C
1713      IF(IPRINT.EQ.'ON' .AND. IFEEDB.EQ.'ON')THEN
1714        WRITE(ICOUT,999)
1715        CALL DPWRST('XXX','BUG ')
1716        WRITE(ICOUT,4011)ILEFT,ILEFT2,NS2
1717 4011   FORMAT('THE NUMBER OF VALUES GENERATED FOR ',
1718     1         'THE VARIABLE ',A4,A4,' = ',I8)
1719        CALL DPWRST('XXX','BUG ')
1720        WRITE(ICOUT,999)
1721        CALL DPWRST('XXX','BUG ')
1722        IJ=MAXN*(ICOLL-1)+IROW1
1723        IJN=MAXN*(ICOLL-1)+IROWN
1724        IF(ICOLL.LE.MAXCOL)THEN
1725          WRITE(ICOUT,4021)ILEFT,ILEFT2,V(IJ),IROW1
1726 4021     FORMAT('THE FIRST           COMPUTED VALUE OF ',2A4,
1727     1           ' = ',E15.7,'   (ROW ',I6,')')
1728          CALL DPWRST('XXX','BUG ')
1729          IF(NS2.GT.1)THEN
1730            WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,V(IJN),IROWN
1731 4031       FORMAT('THE LAST (',I5,'-TH) COMPUTED VALUE OF ',2A4,
1732     1             ' = ',E15.7,'   (ROW ',I6,')')
1733            CALL DPWRST('XXX','BUG ')
1734          ENDIF
1735        ELSEIF(ICOLL.EQ.MAXCP1)THEN
1736          WRITE(ICOUT,4021)ILEFT,ILEFT2,PRED(IROW1),IROW1
1737          CALL DPWRST('XXX','BUG ')
1738          IF(NS2.GT.1)THEN
1739            WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,PRED(IROWN),IROWN
1740            CALL DPWRST('XXX','BUG ')
1741          ENDIF
1742        ELSEIF(ICOLL.EQ.MAXCP2)THEN
1743          WRITE(ICOUT,4021)ILEFT,ILEFT2,RES(IROW1),IROW1
1744          CALL DPWRST('XXX','BUG ')
1745          IF(NS2.GT.1)THEN
1746            WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,RES(IROWN),IROWN
1747            CALL DPWRST('XXX','BUG ')
1748          ENDIF
1749        ELSEIF(ICOLL.EQ.MAXCP3)THEN
1750          WRITE(ICOUT,4021)ILEFT,ILEFT2,YPLOT(IROW1),IROW1
1751          CALL DPWRST('XXX','BUG ')
1752          IF(NS2.GT.1)THEN
1753            WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,YPLOT(IROWN),IROWN
1754            CALL DPWRST('XXX','BUG ')
1755          ENDIF
1756        ELSEIF(ICOLL.EQ.MAXCP4)THEN
1757          WRITE(ICOUT,4021)ILEFT,ILEFT2,XPLOT(IROW1),IROW1
1758          CALL DPWRST('XXX','BUG ')
1759          IF(NS2.GT.1)THEN
1760            WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,XPLOT(IROWN),IROWN
1761            CALL DPWRST('XXX','BUG ')
1762          ENDIF
1763        ELSEIF(ICOLL.EQ.MAXCP5)THEN
1764          WRITE(ICOUT,4021)ILEFT,ILEFT2,X2PLOT(IROW1),IROW1
1765          CALL DPWRST('XXX','BUG ')
1766          IF(NS2.GT.1)THEN
1767            WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,X2PLOT(IROWN),IROWN
1768            CALL DPWRST('XXX','BUG ')
1769          ENDIF
1770        ELSEIF(ICOLL.EQ.MAXCP6)THEN
1771          WRITE(ICOUT,4021)ILEFT,ILEFT2,TAGPLO(IROW1),IROW1
1772          CALL DPWRST('XXX','BUG ')
1773          IF(NS2.GT.1)THEN
1774            WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,TAGPLO(IROWN),IROWN
1775            CALL DPWRST('XXX','BUG ')
1776          ENDIF
1777        ENDIF
1778C
1779        IF(NS2.EQ.1)THEN
1780          WRITE(ICOUT,4041)
1781 4041     FORMAT('SINCE THE GENERATED SAMPLE SIZE WAS ONLY 1,')
1782          CALL DPWRST('XXX','BUG ')
1783          WRITE(ICOUT,4042)
1784 4042     FORMAT('THE ABOVE VALUE WAS THE SOLE VALUE COMPUTED.')
1785          CALL DPWRST('XXX','BUG ')
1786        ENDIF
1787C
1788        WRITE(ICOUT,999)
1789        CALL DPWRST('XXX','BUG ')
1790        WRITE(ICOUT,4112)ILEFT,ILEFT2,ICOLL
1791 4112   FORMAT('THE CURRENT COLUMN FOR THE VARIABLE ',2A4,' = ',I8)
1792        CALL DPWRST('XXX','BUG ')
1793        WRITE(ICOUT,4113)ILEFT,ILEFT2,NINEW
1794 4113   FORMAT('THE CURRENT LENGTH OF  THE VARIABLE ',2A4,' = ',I8)
1795        CALL DPWRST('XXX','BUG ')
1796        WRITE(ICOUT,999)
1797        CALL DPWRST('XXX','BUG ')
1798        WRITE(ICOUT,999)
1799        CALL DPWRST('XXX','BUG ')
1800      ENDIF
1801C
1802C               *****************
1803C               **  STEP 90--  **
1804C               **  EXIT       **
1805C               *****************
1806C
1807 9000 CONTINUE
1808      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GENS')THEN
1809        WRITE(ICOUT,999)
1810        CALL DPWRST('XXX','BUG ')
1811        WRITE(ICOUT,9011)
1812 9011   FORMAT('***** AT THE END       OF DPGENS--')
1813        CALL DPWRST('XXX','BUG ')
1814        WRITE(ICOUT,9012)IFOUND,IERROR
1815 9012   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
1816        CALL DPWRST('XXX','BUG ')
1817        WRITE(ICOUT,9016)NS2,NS,NIISUB,NUMNUM
1818 9016   FORMAT('NS2,NS,NIISUB,NUMNUM = ',4I8)
1819        CALL DPWRST('XXX','BUG ')
1820      ENDIF
1821C
1822      RETURN
1823      END
1824      SUBROUTINE DPGESD(XTEMP1,MAXNXT,
1825     1                  ICAPSW,ICASAN,IFORSW,ISEED,
1826     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
1827C
1828C     PURPOSE--PERFORM EXTREME STUDENTIZED DEVIATE TEST FOR UNIVARIATE
1829C              OUTLIERS.  WHILE MOST OUTLIER TESTS REQUIRE THAT THE
1830C              NUMBER OF OUTLIERS BE SPECIFIED EXACTLY, THIS TEST
1831C              ONLY REQUIRES AN UPPER BOUND FOR THE NUMBER OF
1832C              OUTLIERS.  LIKE GRUBBS TEST, THIS TEST ASSUMES THE DATA
1833C              FOLLOWS AN APPROXIMATELY NORMAL DISRIBUTION.
1834C     WRITTEN BY--ALAN HECKERT
1835C                 STATISTICAL ENGINEERING DIVISION
1836C                 INFORMATION TECHNOLOGY LABORAOTRY
1837C                 NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY
1838C                 GAITHERSBURG, MD 20899-8980
1839C                 PHONE--301-975-2855
1840C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
1841C           OF THE NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY.
1842C     LANGUAGE--ANSI FORTRAN (1977)
1843C     VERSION NUMBER--2009/11
1844C     ORIGINAL VERSION--NOVEMBER  2009.
1845C     UPDATED         --JULY      2019.
1846C
1847C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
1848C
1849      CHARACTER*4 ICASAN
1850      CHARACTER*4 ICAPSW
1851      CHARACTER*4 IFORSW
1852      CHARACTER*4 IBUGA2
1853      CHARACTER*4 IBUGA3
1854      CHARACTER*4 IBUGQ
1855      CHARACTER*4 ISUBRO
1856      CHARACTER*4 IFOUND
1857      CHARACTER*4 IERROR
1858C
1859      CHARACTER*4 IWRITE
1860      CHARACTER*4 IHWUSE
1861      CHARACTER*4 MESSAG
1862      CHARACTER*4 IDATSW
1863      CHARACTER*4 IHP
1864      CHARACTER*4 IHP2
1865      CHARACTER*4 ISUBN1
1866      CHARACTER*4 ISUBN2
1867      CHARACTER*4 ISTEPN
1868      CHARACTER*4 IREPL
1869      CHARACTER*4 IMULT
1870      CHARACTER*4 IRANSV
1871      CHARACTER*4 ICTMP1
1872      CHARACTER*4 ICTMP2
1873      CHARACTER*4 ICTMP3
1874      CHARACTER*4 ICTMP4
1875      CHARACTER*4 ICASE
1876C
1877      CHARACTER*40 INAME
1878      PARAMETER (MAXSPN=30)
1879      CHARACTER*4 IVARN1(MAXSPN)
1880      CHARACTER*4 IVARN2(MAXSPN)
1881      CHARACTER*4 IVARTY(MAXSPN)
1882      CHARACTER*4 IVARID(MAXSPN)
1883      CHARACTER*4 IVARI2(MAXSPN)
1884      REAL PVAR(MAXSPN)
1885      REAL PID(MAXSPN)
1886      INTEGER ILIS(MAXSPN)
1887      INTEGER NRIGHT(MAXSPN)
1888      INTEGER ICOLR(MAXSPN)
1889C
1890C---------------------------------------------------------------------
1891C
1892      INCLUDE 'DPCOPA.INC'
1893      INCLUDE 'DPCOZZ.INC'
1894      INCLUDE 'DPCOZI.INC'
1895C
1896      DIMENSION Y1(MAXOBV)
1897      DIMENSION X1(MAXOBV)
1898      DIMENSION TEMP1(MAXOBV)
1899      DIMENSION TEMP2(MAXOBV)
1900      DIMENSION XTEMP1(MAXOBV)
1901      DIMENSION XTEMP2(MAXOBV)
1902      DIMENSION XTEMP3(MAXOBV)
1903      DIMENSION XTEMP4(MAXOBV)
1904      DIMENSION YSTAT(MAXOBV)
1905      DIMENSION ITEMP1(MAXOBV)
1906      DIMENSION ITEMP2(MAXOBV)
1907      DIMENSION ITEMP3(MAXOBV)
1908C
1909      DIMENSION XDESGN(MAXOBV,7)
1910      DIMENSION XIDTEM(MAXOBV)
1911      DIMENSION XIDTE2(MAXOBV)
1912      DIMENSION XIDTE3(MAXOBV)
1913      DIMENSION XIDTE4(MAXOBV)
1914      DIMENSION XIDTE5(MAXOBV)
1915      DIMENSION XIDTE6(MAXOBV)
1916C
1917      EQUIVALENCE (GARBAG(IGARB1),Y1(1))
1918      EQUIVALENCE (GARBAG(IGARB2),X1(1))
1919      EQUIVALENCE (GARBAG(IGARB4),XTEMP2(1))
1920      EQUIVALENCE (GARBAG(IGARB5),XTEMP3(1))
1921      EQUIVALENCE (GARBAG(IGARB6),XTEMP4(1))
1922      EQUIVALENCE (GARBAG(IGARB7),TEMP1(1))
1923      EQUIVALENCE (GARBAG(IGARB8),TEMP2(1))
1924      EQUIVALENCE (GARBAG(IGARB9),YSTAT(1))
1925      EQUIVALENCE (GARBAG(IGAR10),XIDTEM(1))
1926      EQUIVALENCE (GARBAG(JGAR11),XIDTE2(1))
1927      EQUIVALENCE (GARBAG(JGAR12),XIDTE3(1))
1928      EQUIVALENCE (GARBAG(JGAR13),XIDTE4(1))
1929      EQUIVALENCE (GARBAG(JGAR14),XIDTE5(1))
1930      EQUIVALENCE (GARBAG(JGAR15),XIDTE6(1))
1931      EQUIVALENCE (GARBAG(JGAR16),XDESGN(1,1))
1932      EQUIVALENCE (IGARBG(IIGAR1),ITEMP1(1))
1933      EQUIVALENCE (IGARBG(IIGAR2),ITEMP2(1))
1934      EQUIVALENCE (IGARBG(IIGAR3),ITEMP3(1))
1935C
1936C-----COMMON----------------------------------------------------------
1937C
1938      INCLUDE 'DPCOHK.INC'
1939      INCLUDE 'DPCODA.INC'
1940      INCLUDE 'DPCOSU.INC'
1941      INCLUDE 'DPCOS2.INC'
1942      INCLUDE 'DPCOHO.INC'
1943      INCLUDE 'DPCOMC.INC'
1944      INCLUDE 'DPCOST.INC'
1945      INCLUDE 'DPCOF2.INC'
1946C
1947      CHARACTER*4 IOP
1948C
1949      COMMON/ISED/ISED1,ISED2,ISED3,ISED4,ISED5,ISED6,
1950     1            ISED7,ISED8,ISED9,ISED10,ISED11
1951C
1952C-----COMMON VARIABLES (GENERAL)--------------------------------------
1953C
1954      INCLUDE 'DPCOP2.INC'
1955C
1956C-----START POINT-----------------------------------------------------
1957C
1958      IERROR='NO'
1959      ICASAN='GESD'
1960      IREPL='OFF'
1961      IMULT='OFF'
1962      IRANSV=IRANAL
1963      IRANAL='FINC'
1964      ISEESV=ISEED
1965      ISEED=2503
1966      ISUBN1='DPGE'
1967      ISUBN2='SD  '
1968C
1969      MAXCP1=MAXCOL+1
1970      MAXCP2=MAXCOL+2
1971      MAXCP3=MAXCOL+3
1972      MAXCP4=MAXCOL+4
1973      MAXCP5=MAXCOL+5
1974      MAXCP6=MAXCOL+6
1975C
1976      MINN2=3
1977C
1978C               ***************************************************
1979C               **  TREAT THE EXTREME STUDENTIZED DEVIATE   CASE **
1980C               ***************************************************
1981C
1982      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'GESD')THEN
1983        WRITE(ICOUT,999)
1984  999   FORMAT(1X)
1985        CALL DPWRST('XXX','BUG ')
1986        WRITE(ICOUT,51)
1987   51   FORMAT('***** AT THE BEGINNING OF DPGESD--')
1988        CALL DPWRST('XXX','BUG ')
1989        WRITE(ICOUT,52)ICASAN,MAXNXT
1990   52   FORMAT('ICASAN,MAXNXT = ',A4,2X,I8)
1991        CALL DPWRST('XXX','BUG ')
1992        WRITE(ICOUT,53)IBUGA2,IBUGA3,IBUGQ
1993   53   FORMAT('IBUGA2,IBUGA3,IBUGQ = ',A4,2X,A4,2X,A4)
1994        CALL DPWRST('XXX','BUG ')
1995      ENDIF
1996C
1997C               *********************************************************
1998C               **  STEP 1--                                           **
1999C               **  EXTRACT THE COMMAND                                **
2000C               **  LOOK FOR ONE OF THE FOLLOWING COMMANDS:            **
2001C               **    1) EXTREME STUDENTIZED DEVIATE TEST Y            **
2002C               **    2) EXTREME STUDENTIZED DEVIATE TEST Y LABID      **
2003C               **    3) EXTREME STUDENTIZED DEVIATE TEST Y1 ... YK    **
2004C               **    4) REPLICATED EXTREME STUDENTIZED DEVIATE TEST   **
2005C               **                  Y X1 ... XK                        **
2006C               **    5) REPLICATED EXTREME STUDENTIZED DEVIATE TEST   **
2007C               **                  Y LABID X1 ... XK                  **
2008C               *********************************************************
2009C
2010      ISTEPN='1'
2011      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GESD')
2012     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2013C
2014      ILASTC=9999
2015      ILASTZ=9999
2016      IFOUND='NO'
2017      ICASAN='TWOS'
2018C
2019      DO100I=0,NUMARG-1
2020C
2021        IF(I.EQ.0)THEN
2022          ICTMP1=ICOM
2023          ICTMP2=IHARG(I+1)
2024          ICTMP3=IHARG(I+2)
2025        ELSE
2026          ICTMP1=IHARG(I)
2027          ICTMP2=IHARG(I+1)
2028          ICTMP3=IHARG(I+2)
2029          ICTMP4=IHARG(I+3)
2030        ENDIF
2031C
2032        IF(ICTMP1.EQ.'EXTR' .AND. ICTMP2.EQ.'STUD' .AND.
2033     1     ICTMP3.EQ.'DEVI' .AND. ICTMP4.EQ.'TEST')THEN
2034          IFOUND='YES'
2035          ILASTC=I
2036          ILASTZ=I+3
2037        ELSEIF(ICTMP1.EQ.'EXTR' .AND. ICTMP2.EQ.'STUD' .AND.
2038     1         ICTMP3.EQ.'DEVI')THEN
2039          IFOUND='YES'
2040          ILASTC=I
2041          ILASTZ=I+2
2042        ELSEIF(ICTMP1.EQ.'ESD ' .AND. ICTMP2.EQ.'TEST')THEN
2043          IFOUND='YES'
2044          ILASTC=I
2045          ILASTZ=I+1
2046        ELSEIF(ICTMP1.EQ.'ESD ')THEN
2047          IFOUND='YES'
2048          ILASTC=I
2049          ILASTZ=I
2050        ELSEIF(ICTMP1.EQ.'REPL')THEN
2051          IREPL='ON'
2052          ILASTC=MIN(ILASTC,I)
2053          ILASTZ=MAX(ILASTZ,I)
2054        ELSEIF(ICTMP1.EQ.'MULT')THEN
2055          IMULT='ON'
2056          ILASTC=MIN(ILASTC,I)
2057          ILASTZ=MAX(ILASTZ,I)
2058        ELSEIF(ICTMP1.EQ.'TEST')THEN
2059          ILASTC=MIN(ILASTC,I)
2060          ILASTZ=MAX(ILASTZ,I)
2061        ENDIF
2062  100 CONTINUE
2063C
2064      ISHIFT=ILASTZ
2065      CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
2066     1            IBUGA2,IERROR)
2067C
2068      IF(IFOUND.EQ.'NO')GOTO9000
2069      IF(IMULT.EQ.'ON')THEN
2070        IF(IREPL.EQ.'ON')THEN
2071          WRITE(ICOUT,999)
2072          CALL DPWRST('XXX','BUG ')
2073          WRITE(ICOUT,101)
2074  101     FORMAT('***** ERROR IN EXTREME STUDENTIZED DEVIATE TEST--')
2075          CALL DPWRST('XXX','BUG ')
2076          WRITE(ICOUT,102)
2077  102     FORMAT('      YOU CANNOT SPECIFY BOTH "MULTIPLE" AND ',
2078     1           '"REPLICATION" FOR')
2079          CALL DPWRST('XXX','BUG ')
2080          WRITE(ICOUT,103)
2081  103     FORMAT('      THE EXTREME STUDENTIZED DEVIATE TEST COMMAND.')
2082          CALL DPWRST('XXX','BUG ')
2083          IERROR='YES'
2084          GOTO9000
2085        ENDIF
2086      ENDIF
2087C
2088C               *********************************
2089C               **  STEP 4--                   **
2090C               **  EXTRACT THE VARIABLE LIST  **
2091C               *********************************
2092C
2093      ISTEPN='4'
2094      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GESD')
2095     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2096C
2097      INAME='OUTLIER EXTREME STUDENTIZED DEVIATE TEST'
2098      MINNA=1
2099      MAXNA=100
2100      MINN2=2
2101      IFLAGE=1
2102      IF(IMULT.EQ.'ON')IFLAGE=0
2103      IFLAGM=1
2104      IF(IREPL.EQ.'ON')IFLAGM=0
2105      IFLAGP=0
2106      JMIN=1
2107      JMAX=NUMARG
2108      MINNVA=-99
2109      MAXNVA=-99
2110C
2111      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
2112     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
2113     1            JMIN,JMAX,
2114     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
2115     1            IVARN1,IVARN2,IVARTY,PVAR,
2116     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
2117     1            MINNVA,MAXNVA,
2118     1            IFLAGM,IFLAGP,
2119     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
2120      IF(IERROR.EQ.'YES')GOTO9000
2121C
2122      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GESD')THEN
2123        WRITE(ICOUT,999)
2124        CALL DPWRST('XXX','BUG ')
2125        WRITE(ICOUT,281)
2126  281   FORMAT('***** AFTER CALL DPPARS--')
2127        CALL DPWRST('XXX','BUG ')
2128        WRITE(ICOUT,282)NQ,NUMVAR
2129  282   FORMAT('NQ,NUMVAR = ',2I8)
2130        CALL DPWRST('XXX','BUG ')
2131        IF(NUMVAR.GT.0)THEN
2132          DO285I=1,NUMVAR
2133            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
2134     1                      ICOLR(I)
2135  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
2136     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
2137            CALL DPWRST('XXX','BUG ')
2138  285     CONTINUE
2139        ENDIF
2140      ENDIF
2141C
2142C               ***********************************************
2143C               **  STEP 5--                                 **
2144C               **  DETERMINE:                               **
2145C               **  1) NUMBER OF REPLICATION VARIABLES (0-6) **
2146C               **  2) NUMBER OF RESPONSE    VARIABLES (>= 1)**
2147C               ***********************************************
2148C
2149      ISTEPN='5'
2150      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GESD')
2151     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2152C
2153      NRESP=0
2154      NREPL=0
2155      NLABID=0
2156      IF(IMULT.EQ.'ON')THEN
2157        NRESP=NUMVAR
2158      ELSEIF(IREPL.EQ.'ON')THEN
2159        NRESP=1
2160        IF(NUMVAR.EQ.2)THEN
2161          NLABID=0
2162          NREPL=1
2163        ELSE
2164          NLABID=1
2165          NREPL=NUMVAR-NRESP-NLABID
2166        ENDIF
2167        IF(NREPL.LT.1 .OR. NREPL.GT.6)THEN
2168          WRITE(ICOUT,999)
2169          CALL DPWRST('XXX','BUG ')
2170          WRITE(ICOUT,101)
2171          CALL DPWRST('XXX','BUG ')
2172          WRITE(ICOUT,511)
2173  511     FORMAT('      FOR THE REPLICATION CASE, THE NUMBER OF ',
2174     1           'REPLICATION VARIABLES')
2175          CALL DPWRST('XXX','BUG ')
2176          WRITE(ICOUT,513)NREPL
2177  513     FORMAT('      THE NUMBER OF REPLICATION VARIABLES = ',I5)
2178          CALL DPWRST('XXX','BUG ')
2179          IERROR='YES'
2180          GOTO9000
2181        ENDIF
2182      ELSE
2183        NRESP=1
2184        NLABID=NUMVAR-NRESP
2185        IF(NLABID.GT.1)NLABID=1
2186      ENDIF
2187C
2188      IHP='NOUT'
2189      IHP2='LIER'
2190      IHWUSE='P'
2191      MESSAG='NO'
2192      CALL CHECKN(IHP,IHP2,IHWUSE,
2193     1            IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
2194     1            ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
2195      IF(IERROR.EQ.'YES')THEN
2196        IR=1
2197      ELSE
2198        AR=VALUE(ILOCV)
2199        IR=INT(AR+0.1)
2200        IF(IR.LT.1)IR=1
2201      ENDIF
2202C
2203      IOP='OPEN'
2204      IFLAG1=0
2205      IFLAG2=1
2206      IFLAG3=1
2207      IFLAG4=0
2208      IFLAG5=0
2209      CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
2210     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
2211     1            IBUGA3,ISUBRO,IERROR)
2212      IF(IERROR.EQ.'YES')GOTO9000
2213C
2214      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GESD')THEN
2215        WRITE(ICOUT,521)NRESP,NLABID,NREPL,IR
2216  521   FORMAT('NRESP,NLABID,NREPL,IR = ',4I5)
2217        CALL DPWRST('XXX','BUG ')
2218      ENDIF
2219C
2220C               ******************************************************
2221C               **  STEP 6--                                        **
2222C               **  GENERATE THE EXTREME STUDENTIZED DEVIATE TEST   **
2223C               **  FOR THE VARIOUS  CASES                          **
2224C               ******************************************************
2225C
2226      ISTEPN='6'
2227      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GESD')
2228     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2229C
2230C               *****************************************
2231C               **  STEP 7A--                          **
2232C               **  CASE 1: SINGLE RESPONSE VARIABLE   **
2233C               **          WITH NO REPLICATION        **
2234C               *****************************************
2235C
2236      IF(NRESP.EQ.1 .AND. NREPL.EQ.0)THEN
2237        ISTEPN='7A'
2238        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GESD')
2239     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2240C
2241        PID(1)=CPUMIN
2242        IVARID(1)=IVARN1(1)
2243        IVARI2(1)=IVARN2(1)
2244C
2245        ICOL=1
2246        NUMVA2=1
2247        IF(NLABID.GE.1)NUMVA2=2
2248        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
2249     1              INAME,IVARN1,IVARN2,IVARTY,
2250     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
2251     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
2252     1              MAXCP4,MAXCP5,MAXCP6,
2253     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
2254     1              Y1,X1,X1,NLOCAL,NLOCA2,NLOCA2,ICASE,
2255     1              IBUGA3,ISUBRO,IFOUND,IERROR)
2256        IF(IERROR.EQ.'YES')GOTO9000
2257        IF(NLABID.EQ.0)THEN
2258          DO720I=1,NLOCAL
2259            X1(I)=REAL(I)
2260  720     CONTINUE
2261        ENDIF
2262C
2263C       *****************************************************
2264C       **  STEP 7B--                                      **
2265C       **  CALL DPGES2 TO PERFORM OUTLIER TEST.           **
2266C       *****************************************************
2267C
2268        IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'GESD')THEN
2269          ISTEPN='7B'
2270          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2271          WRITE(ICOUT,999)
2272          CALL DPWRST('XXX','BUG ')
2273          WRITE(ICOUT,711)
2274  711     FORMAT('***** FROM THE MIDDLE  OF DPGESD--')
2275          CALL DPWRST('XXX','BUG ')
2276          WRITE(ICOUT,712)ICASAN,NUMVAR,NLOCAL
2277  712     FORMAT('ICASAN,NUMVAR,NQ = ',A4,2I8)
2278          CALL DPWRST('XXX','BUG ')
2279          IF(NLOCAL.GE.1)THEN
2280            DO715I=1,NLOCAL
2281              WRITE(ICOUT,716)I,Y1(I),X1(I)
2282  716         FORMAT('I,Y1(I),X1(I) = ',I8,2F12.5)
2283              CALL DPWRST('XXX','BUG ')
2284  715       CONTINUE
2285          ENDIF
2286        ENDIF
2287C
2288        NREPL=0
2289        NCURVE=1
2290        CALL DPGES2(Y1,X1,NLOCAL,IOUNI2,IOUNI3,ISEED,
2291     1              YSTAT,XTEMP1,XTEMP2,XTEMP3,XTEMP4,
2292     1              ITEMP1,ITEMP2,ITEMP3,
2293     1              PID,IVARID,IVARI2,NCURVE,NREPL,NLABID,IR,
2294     1              ICAPSW,ICAPTY,IFORSW,
2295     1              ISUBRO,IBUGA3,IERROR)
2296C
2297C               ******************************************
2298C               **  STEP 8A--                           **
2299C               **  CASE 2: MULTIPLE RESPONSE VARIABLES **
2300C               **          NOTE THAT A LABID VARIABLE  **
2301C               **          IS NOT SUPPORTED FOR THIS   **
2302C               **          CASE.                       **
2303C               ******************************************
2304C
2305      ELSEIF(NRESP.GT.1)THEN
2306        ISTEPN='8A'
2307        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GESD')
2308     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2309C
2310C       LOOP THROUGH EACH OF THE RESPONSE VARIABLES
2311C
2312        NCURVE=0
2313        DO810IRESP=1,NRESP
2314          NCURVE=NCURVE+1
2315C
2316          IINDX=ICOLR(IRESP)
2317          PID(1)=CPUMIN
2318          IVARID(1)=IVARN1(IRESP)
2319          IVARI2(1)=IVARN2(IRESP)
2320C
2321          IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GESD')THEN
2322            WRITE(ICOUT,999)
2323            CALL DPWRST('XXX','BUG ')
2324            WRITE(ICOUT,811)IRESP,NCURVE
2325  811       FORMAT('IRESP,NCURVE = ',2I5)
2326            CALL DPWRST('XXX','BUG ')
2327          ENDIF
2328C
2329          ICOL=IRESP
2330          NUMVA2=1
2331          CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
2332     1                INAME,IVARN1,IVARN2,IVARTY,
2333     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
2334     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
2335     1                MAXCP4,MAXCP5,MAXCP6,
2336     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
2337     1                Y1,XTEMP1,XTEMP2,NLOCAL,NLOCA2,NLOCA3,ICASE,
2338     1                IBUGA3,ISUBRO,IFOUND,IERROR)
2339          IF(IERROR.EQ.'YES')GOTO9000
2340          DO820I=1,NLOCAL
2341            X1(I)=REAL(I)
2342  820     CONTINUE
2343C
2344C         *****************************************************
2345C         **  STEP 8B--                                      **
2346C         **  CALL DPGES2 TO PERFORM THE OUTLIER TEST.       **
2347C         *****************************************************
2348C
2349C
2350          IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'GESD')THEN
2351            ISTEPN='8B'
2352            CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2353            WRITE(ICOUT,999)
2354            CALL DPWRST('XXX','BUG ')
2355            WRITE(ICOUT,822)
2356  822       FORMAT('***** FROM THE MIDDLE  OF DPGESD--')
2357            CALL DPWRST('XXX','BUG ')
2358            WRITE(ICOUT,823)ICASAN,NUMVAR,IDATSW,NLOCAL
2359  823       FORMAT('ICASAN,NUMVAR,IDATSW,NQ = ',
2360     1             A4,I8,2X,A4,I8)
2361            CALL DPWRST('XXX','BUG ')
2362            IF(NLOCAL.GE.1)THEN
2363              DO825I=1,NLOCAL
2364                WRITE(ICOUT,826)I,Y1(I),X1(I)
2365  826           FORMAT('I,Y1(I),X1(I) = ',I8,2F12.5)
2366                CALL DPWRST('XXX','BUG ')
2367  825         CONTINUE
2368            ENDIF
2369          ENDIF
2370C
2371          CALL DPGES2(Y1,X1,NLOCAL,IOUNI2,IOUNI3,ISEED,
2372     1                YSTAT,XTEMP1,XTEMP2,XTEMP3,XTEMP4,
2373     1                ITEMP1,ITEMP2,ITEMP3,
2374     1                PID,IVARID,IVARI2,NCURVE,NREPL,NLABID,IR,
2375     1                ICAPSW,ICAPTY,IFORSW,
2376     1                ISUBRO,IBUGA3,IERROR)
2377C
2378  810   CONTINUE
2379C
2380C               ****************************************************
2381C               **  STEP 9A--                                     **
2382C               **  CASE 3: ONE OR MORE REPLICATION VARIABLES.    **
2383C               **          FOR THIS CASE, THE NUMBER OF RESPONSE **
2384C               **          VARIABLES MUST BE EXACTLY 1.          **
2385C               **          FOR THIS CASE, ALL VARIABLES MUST     **
2386C               **          HAVE THE SAME LENGTH.                 **
2387C               ****************************************************
2388C
2389      ELSEIF(IREPL.EQ.'ON')THEN
2390        ISTEPN='9A'
2391        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GESD')
2392     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2393C
2394        J=0
2395        IMAX=NRIGHT(1)
2396        IF(NQ.LT.NRIGHT(1))IMAX=NQ
2397        DO910I=1,IMAX
2398          IF(ISUB(I).EQ.0)GOTO910
2399          J=J+1
2400C
2401C         RESPONSE VARIABLE IN Y1
2402C
2403          ICOLC=1
2404          IJ=MAXN*(ICOLR(ICOLC)-1)+I
2405          IF(ICOLR(ICOLC).LE.MAXCOL)Y1(J)=V(IJ)
2406          IF(ICOLR(ICOLC).EQ.MAXCP1)Y1(J)=PRED(I)
2407          IF(ICOLR(ICOLC).EQ.MAXCP2)Y1(J)=RES(I)
2408          IF(ICOLR(ICOLC).EQ.MAXCP3)Y1(J)=YPLOT(I)
2409          IF(ICOLR(ICOLC).EQ.MAXCP4)Y1(J)=XPLOT(I)
2410          IF(ICOLR(ICOLC).EQ.MAXCP5)Y1(J)=X2PLOT(I)
2411          IF(ICOLR(ICOLC).EQ.MAXCP6)Y1(J)=TAGPLO(I)
2412C
2413C         LABID VARIABLE IN X1
2414C
2415          IF(NLABID.GE.1)THEN
2416            ICOLC=ICOLC+1
2417            ICOLT=ICOLR(ICOLC)
2418            IJ=MAXN*(ICOLT-1)+I
2419            IF(ICOLT.LE.MAXCOL)X1(J)=V(IJ)
2420            IF(ICOLT.EQ.MAXCP1)X1(J)=PRED(I)
2421            IF(ICOLT.EQ.MAXCP2)X1(J)=RES(I)
2422            IF(ICOLT.EQ.MAXCP3)X1(J)=YPLOT(I)
2423            IF(ICOLT.EQ.MAXCP4)X1(J)=XPLOT(I)
2424            IF(ICOLT.EQ.MAXCP5)X1(J)=X2PLOT(I)
2425            IF(ICOLT.EQ.MAXCP6)X1(J)=TAGPLO(I)
2426          ELSE
2427            X1(J)=REAL(I)
2428          ENDIF
2429C
2430          IF(NREPL.GE.1)THEN
2431            DO920IR=1,MIN(NREPL,6)
2432              ICOLC=ICOLC+1
2433              ICOLT=ICOLR(ICOLC)
2434              IJ=MAXN*(ICOLT-1)+I
2435              IF(ICOLT.LE.MAXCOL)XDESGN(J,IR)=V(IJ)
2436              IF(ICOLT.EQ.MAXCP1)XDESGN(J,IR)=PRED(I)
2437              IF(ICOLT.EQ.MAXCP2)XDESGN(J,IR)=RES(I)
2438              IF(ICOLT.EQ.MAXCP3)XDESGN(J,IR)=YPLOT(I)
2439              IF(ICOLT.EQ.MAXCP4)XDESGN(J,IR)=XPLOT(I)
2440              IF(ICOLT.EQ.MAXCP5)XDESGN(J,IR)=X2PLOT(I)
2441              IF(ICOLT.EQ.MAXCP6)XDESGN(J,IR)=TAGPLO(I)
2442  920       CONTINUE
2443          ENDIF
2444C
2445  910   CONTINUE
2446        NLOCAL=J
2447C
2448        ISTEPN='9B'
2449        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GESD')
2450     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2451C
2452C       NOTE: CHECK TO SEE IF X1 HAS ALL UNIQUE ELEMENTS.  IF NOT,
2453C             THEN INTERPRET THIS AS A REPLICATION VARIABLE.
2454C
2455        CALL DISTIN(X1,NLOCAL,IWRITE,XTEMP2,NDIST,IBUGA3,IERROR)
2456        IF(NLOCAL.NE.NDIST)THEN
2457          NLABID=0
2458          IF(NREPL.GT.6)NREPL=6
2459          IF(NREPL.GE.1)THEN
2460            DO930J=1,NREPL-1
2461              DO935I=1,NLOCAL
2462                XDESGN(I,J+1)=XDESGN(I,J)
2463  935         CONTINUE
2464  930       CONTINUE
2465          ENDIF
2466          NREPL=NREPL+1
2467          DO938I=1,NLOCAL
2468            XDESGN(I,1)=X1(I)
2469            X1(I)=REAL(I)
2470  938     CONTINUE
2471        ENDIF
2472C
2473        PID(1)=CPUMIN
2474        IVARID(1)=IVARN1(1)
2475        IVARI2(1)=IVARN2(1)
2476        IF(NLABID.EQ.1)THEN
2477          PID(2)=CPUMIN
2478          IVARID(2)=IVARN1(2)
2479          IVARI2(2)=IVARN2(2)
2480        ENDIF
2481        IADD=NRESP+NLABID
2482        DO940II=1,NREPL
2483          IVARID(II+IADD)=IVARN1(II+IADD)
2484          IVARI2(II+IADD)=IVARN2(II+IADD)
2485  940   CONTINUE
2486C
2487C       *****************************************************
2488C       **  STEP 9B--                                      **
2489C       **  FORM THE VERTICAL AND HORIZONTAL AXIS          **
2490C       **  VALUES Y(.) AND X(.) FOR THE PLOT.             **
2491C       **                                                 **
2492C       **  FOR THIS CASE, WE NEED TO LOOP THROUGH THE     **
2493C       **  VARIOUS REPLICATIONS.                          **
2494C       *****************************************************
2495C
2496        IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'GESD')THEN
2497          ISTEPN='9C'
2498          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2499          WRITE(ICOUT,999)
2500          CALL DPWRST('XXX','BUG ')
2501          WRITE(ICOUT,941)
2502  941     FORMAT('***** FROM THE MIDDLE  OF DPGESD--')
2503          CALL DPWRST('XXX','BUG ')
2504          WRITE(ICOUT,942)ICASAN,NUMVAR,IDATSW,NLOCAL,NREPL
2505  942     FORMAT('ICASAN,NUMVAR,IDATSW,NLOCAL,NREPL = ',
2506     1           A4,I8,2X,A4,2I8)
2507          CALL DPWRST('XXX','BUG ')
2508          IF(NLOCAL.GE.1)THEN
2509            DO945I=1,NLOCAL
2510              WRITE(ICOUT,946)I,Y1(I),X1(I),XDESGN(I,1),XDESGN(I,2)
2511  946         FORMAT('I,Y1(I),X1(I),XDESGN(I,1),XDESGN(I,2) = ',
2512     1               I8,4F12.5)
2513              CALL DPWRST('XXX','BUG ')
2514  945       CONTINUE
2515          ENDIF
2516        ENDIF
2517C
2518C       *****************************************************
2519C       **  STEP 9C--                                      **
2520C       **  FIND THE DISTINCT VALUES IN EACH OF THE        **
2521C       **  REPLICATION VARIABLES.                         **
2522C       *****************************************************
2523C
2524        CALL DPPP5(XDESGN(1,1),XDESGN(1,2),XDESGN(1,3),
2525     1             XDESGN(1,4),XDESGN(1,5),XDESGN(1,6),
2526     1             NREPL,NLOCAL,MAXOBV,
2527     1             XIDTEM,XIDTE2,XIDTE3,XIDTE4,XIDTE5,XIDTE6,
2528     1             XTEMP1,XTEMP2,
2529     1             NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,NUMSE6,
2530     1             IBUGA3,ISUBRO,IERROR)
2531C
2532C       *****************************************************
2533C       **  STEP 9D--                                      **
2534C       **  NOW LOOP THROUGH THE VARIOUS REPLICATIONS      **
2535C       *****************************************************
2536C
2537        NPLOTP=0
2538        NCURVE=0
2539        IF(NREPL.EQ.1)THEN
2540          J=0
2541          DO1110ISET1=1,NUMSE1
2542            K=0
2543            PID(IADD+1)=XIDTEM(ISET1)
2544            DO1130I=1,NLOCAL
2545              IF(XIDTEM(ISET1).EQ.XDESGN(I,1))THEN
2546                K=K+1
2547                TEMP1(K)=Y1(I)
2548                TEMP2(K)=X1(I)
2549              ENDIF
2550 1130       CONTINUE
2551            NTEMP=K
2552            NCURVE=NCURVE+1
2553            NPLOT1=NPLOTP
2554            IF(NTEMP.GT.0)THEN
2555              CALL DPGES2(TEMP1,TEMP2,NTEMP,IOUNI2,IOUNI3,ISEED,
2556     1                    YSTAT,XTEMP1,XTEMP2,XTEMP3,XTEMP4,
2557     1                    ITEMP1,ITEMP2,ITEMP3,
2558     1                    PID,IVARID,IVARI2,NCURVE,NREPL,NLABID,IR,
2559     1                    ICAPSW,ICAPTY,IFORSW,
2560     1                    ISUBRO,IBUGA3,IERROR)
2561            ENDIF
2562 1110     CONTINUE
2563        ELSEIF(NREPL.EQ.2)THEN
2564          J=0
2565          NTOT=NUMSE1*NUMSE2
2566          DO1210ISET1=1,NUMSE1
2567          DO1220ISET2=1,NUMSE2
2568            K=0
2569            PID(1+IADD)=XIDTEM(ISET1)
2570            PID(2+IADD)=XIDTE2(ISET2)
2571            DO1290I=1,NLOCAL
2572              IF(
2573     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
2574     1           XIDTE2(ISET2).EQ.XDESGN(I,2)
2575     1          )THEN
2576                K=K+1
2577                TEMP1(K)=Y1(I)
2578                TEMP2(K)=X1(I)
2579              ENDIF
2580 1290       CONTINUE
2581            NTEMP=K
2582            NCURVE=NCURVE+1
2583            NPLOT1=NPLOTP
2584            IF(NTEMP.GT.0)THEN
2585              CALL DPGES2(TEMP1,TEMP2,NTEMP,IOUNI2,IOUNI3,ISEED,
2586     1                    YSTAT,XTEMP1,XTEMP2,XTEMP3,XTEMP4,
2587     1                    ITEMP1,ITEMP2,ITEMP3,
2588     1                    PID,IVARID,IVARI2,NCURVE,NREPL,NLABID,IR,
2589     1                    ICAPSW,ICAPTY,IFORSW,
2590     1                    ISUBRO,IBUGA3,IERROR)
2591            ENDIF
2592 1220     CONTINUE
2593 1210     CONTINUE
2594        ELSEIF(NREPL.EQ.3)THEN
2595          J=0
2596          NTOT=NUMSE1*NUMSE2*NUMSE3
2597          DO1310ISET1=1,NUMSE1
2598          DO1320ISET2=1,NUMSE2
2599          DO1330ISET3=1,NUMSE3
2600            K=0
2601            PID(1+IADD)=XIDTEM(ISET1)
2602            PID(2+IADD)=XIDTE2(ISET2)
2603            PID(3+IADD)=XIDTE3(ISET3)
2604            DO1390I=1,NLOCAL
2605              IF(
2606     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
2607     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
2608     1           XIDTE3(ISET3).EQ.XDESGN(I,3)
2609     1          )THEN
2610                K=K+1
2611                TEMP1(K)=Y1(I)
2612                TEMP2(K)=X1(I)
2613              ENDIF
2614 1390       CONTINUE
2615            NTEMP=K
2616            NCURVE=NCURVE+1
2617            NPLOT1=NPLOTP
2618            IF(NTEMP.GT.0)THEN
2619              CALL DPGES2(TEMP1,TEMP2,NTEMP,IOUNI2,IOUNI3,ISEED,
2620     1                    YSTAT,XTEMP1,XTEMP2,XTEMP3,XTEMP4,
2621     1                    ITEMP1,ITEMP2,ITEMP3,
2622     1                    PID,IVARID,IVARI2,NCURVE,NREPL,NLABID,IR,
2623     1                    ICAPSW,ICAPTY,IFORSW,
2624     1                    ISUBRO,IBUGA3,IERROR)
2625            ENDIF
2626 1330     CONTINUE
2627 1320     CONTINUE
2628 1310     CONTINUE
2629        ELSEIF(NREPL.EQ.4)THEN
2630          J=0
2631          NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4
2632          DO1410ISET1=1,NUMSE1
2633          DO1420ISET2=1,NUMSE2
2634          DO1430ISET3=1,NUMSE3
2635          DO1440ISET4=1,NUMSE4
2636            K=0
2637            PID(1+IADD)=XIDTEM(ISET1)
2638            PID(2+IADD)=XIDTE2(ISET2)
2639            PID(3+IADD)=XIDTE3(ISET3)
2640            PID(4+IADD)=XIDTE4(ISET4)
2641            DO1490I=1,NLOCAL
2642              IF(
2643     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
2644     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
2645     1           XIDTE3(ISET3).EQ.XDESGN(I,3) .AND.
2646     1           XIDTE4(ISET4).EQ.XDESGN(I,4)
2647     1          )THEN
2648                K=K+1
2649                TEMP1(K)=Y1(I)
2650                TEMP2(K)=X1(I)
2651              ENDIF
2652 1490       CONTINUE
2653            NTEMP=K
2654            NCURVE=NCURVE+1
2655            NPLOT1=NPLOTP
2656            IF(NTEMP.GT.0)THEN
2657              CALL DPGES2(TEMP1,TEMP2,NTEMP,IOUNI2,IOUNI3,ISEED,
2658     1                    YSTAT,XTEMP1,XTEMP2,XTEMP3,XTEMP4,
2659     1                    ITEMP1,ITEMP2,ITEMP3,
2660     1                    PID,IVARID,IVARI2,NCURVE,NREPL,NLABID,IR,
2661     1                    ICAPSW,ICAPTY,IFORSW,
2662     1                    ISUBRO,IBUGA3,IERROR)
2663            ENDIF
2664 1440     CONTINUE
2665 1430     CONTINUE
2666 1420     CONTINUE
2667 1410     CONTINUE
2668        ELSEIF(NREPL.EQ.5)THEN
2669          J=0
2670          NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5
2671          DO1510ISET1=1,NUMSE1
2672          DO1520ISET2=1,NUMSE2
2673          DO1530ISET3=1,NUMSE3
2674          DO1540ISET4=1,NUMSE4
2675          DO1550ISET5=1,NUMSE5
2676            K=0
2677            PID(1+IADD)=XIDTEM(ISET1)
2678            PID(2+IADD)=XIDTE2(ISET2)
2679            PID(3+IADD)=XIDTE3(ISET3)
2680            PID(4+IADD)=XIDTE4(ISET4)
2681            PID(5+IADD)=XIDTE5(ISET4)
2682            DO1590I=1,NLOCAL
2683              IF(
2684     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
2685     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
2686     1           XIDTE3(ISET3).EQ.XDESGN(I,3) .AND.
2687     1           XIDTE4(ISET4).EQ.XDESGN(I,4) .AND.
2688     1           XIDTE5(ISET5).EQ.XDESGN(I,5)
2689     1          )THEN
2690                K=K+1
2691                TEMP1(K)=Y1(I)
2692                TEMP2(K)=X1(I)
2693              ENDIF
2694 1590       CONTINUE
2695            NTEMP=K
2696            NCURVE=NCURVE+1
2697            NPLOT1=NPLOTP
2698            IF(NTEMP.GT.0)THEN
2699              CALL DPGES2(TEMP1,TEMP2,NTEMP,IOUNI2,IOUNI3,ISEED,
2700     1                    YSTAT,XTEMP1,XTEMP2,XTEMP3,XTEMP4,
2701     1                    ITEMP1,ITEMP2,ITEMP3,
2702     1                    PID,IVARID,IVARI2,NCURVE,NREPL,NLABID,IR,
2703     1                    ICAPSW,ICAPTY,IFORSW,
2704     1                    ISUBRO,IBUGA3,IERROR)
2705            ENDIF
2706 1550     CONTINUE
2707 1540     CONTINUE
2708 1530     CONTINUE
2709 1520     CONTINUE
2710 1510     CONTINUE
2711        ELSEIF(NREPL.EQ.6)THEN
2712          J=0
2713          NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5*NUMSE6
2714          DO1610ISET1=1,NUMSE1
2715          DO1620ISET2=1,NUMSE2
2716          DO1630ISET3=1,NUMSE3
2717          DO1640ISET4=1,NUMSE4
2718          DO1650ISET5=1,NUMSE5
2719          DO1660ISET6=1,NUMSE6
2720            K=0
2721            PID(1+IADD)=XIDTEM(ISET1)
2722            PID(2+IADD)=XIDTE2(ISET2)
2723            PID(3+IADD)=XIDTE3(ISET3)
2724            PID(4+IADD)=XIDTE4(ISET4)
2725            PID(5+IADD)=XIDTE5(ISET4)
2726            PID(6+IADD)=XIDTE6(ISET4)
2727            DO1690I=1,NLOCAL
2728              IF(
2729     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
2730     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
2731     1           XIDTE3(ISET3).EQ.XDESGN(I,3) .AND.
2732     1           XIDTE4(ISET4).EQ.XDESGN(I,4) .AND.
2733     1           XIDTE5(ISET5).EQ.XDESGN(I,5) .AND.
2734     1           XIDTE6(ISET6).EQ.XDESGN(I,6)
2735     1          )THEN
2736                K=K+1
2737                TEMP1(K)=Y1(I)
2738                TEMP2(K)=X1(I)
2739              ENDIF
2740 1690       CONTINUE
2741            NTEMP=K
2742            NCURVE=NCURVE+1
2743            NPLOT1=NPLOTP
2744            IF(NTEMP.GT.0)THEN
2745              CALL DPGES2(TEMP1,TEMP2,NTEMP,IOUNI2,IOUNI3,ISEED,
2746     1                    YSTAT,XTEMP1,XTEMP2,XTEMP3,XTEMP4,
2747     1                    ITEMP1,ITEMP2,ITEMP3,
2748     1                    PID,IVARID,IVARI2,NCURVE,NREPL,NLABID,IR,
2749     1                    ICAPSW,ICAPTY,IFORSW,
2750     1                    ISUBRO,IBUGA3,IERROR)
2751            ENDIF
2752 1660     CONTINUE
2753 1650     CONTINUE
2754 1640     CONTINUE
2755 1630     CONTINUE
2756 1620     CONTINUE
2757 1610     CONTINUE
2758        ENDIF
2759C
2760      ENDIF
2761C
2762C               *****************
2763C               **  STEP 90--  **
2764C               **  EXIT       **
2765C               *****************
2766C
2767 9000 CONTINUE
2768C
2769      IRANAL=IRANSV
2770      ISEED=ISEESV
2771C
2772      IOP='CLOS'
2773      CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
2774     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
2775     1            IBUGA3,ISUBRO,IERROR)
2776C
2777      IF(IERROR.EQ.'YES')THEN
2778        IF(IWIDTH.GE.1)THEN
2779          WRITE(ICOUT,9001)(IANS(I),I=1,MIN(100,IWIDTH))
2780 9001     FORMAT(100A1)
2781          CALL DPWRST('XXX','BUG ')
2782        ENDIF
2783      ENDIF
2784C
2785      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'GESD')THEN
2786        WRITE(ICOUT,999)
2787        CALL DPWRST('XXX','BUG ')
2788        WRITE(ICOUT,9011)
2789 9011   FORMAT('***** AT THE END       OF DPGESD--')
2790        CALL DPWRST('XXX','BUG ')
2791        WRITE(ICOUT,9012)IFOUND,IERROR
2792 9012   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
2793        CALL DPWRST('XXX','BUG ')
2794        WRITE(ICOUT,9013)NLOCAL,NS,ICASAN
2795 9013   FORMAT('NLOCAL,NS,ICASAN = ',I8,I8,2X,A4)
2796        CALL DPWRST('XXX','BUG ')
2797      ENDIF
2798C
2799      RETURN
2800      END
2801      SUBROUTINE DPGES2(Y,X,N,IOUNI2,IOUNI3,ISEED,
2802     1                  YSTAT,TEMP1,TEMP2,TEMP4,STATV,
2803     1                  ITEMP1,ITEMP2,ITEMP3,
2804     1                  PID,IVARID,IVARI2,NCURVE,NREPL,NLABID,IR,
2805     1                  ICAPSW,ICAPTY,IFORSW,
2806     1                  ISUBRO,IBUGA3,IERROR)
2807C
2808C     PURPOSE--THIS ROUTINE CARRIES OUT THE EXTREME STUDENTIZED DEVIATE
2809C              TEST FOR UNIVARIATE OUTLIERS (DATA ASSUMED TO FOLLOW AN
2810C              APPROXIMATELY NORMAL DISTRIBUTION).  AN UPPER BOUND FOR
2811C              THE MAXIMUM NUMBER OF OUTLIERS MUST BE SPECIFIED.
2812C              SUSPECTED OUTLIERS MUST BE SPECIFIED IN ADVANCE.
2813C     EXAMPLE--EXTREME STUDENTIZED DEVIATE TEST Y
2814C     REFERENCE--IGLEWICZ AND HOAGLIN (1993), "VOLUME 16: HOW TO DETECT
2815C                AND HANDLE OUTLIERS", THE ASQC BASIC REFERENCE IN
2816C                QUALITY CONTROL: STATISTICAL TECHNIQUES, EDWARD
2817C                F. MYKYTKA, Ph.D., EDITOR.
2818C     WRITTEN BY--ALAN HECKERT
2819C                 STATISTICAL ENGINEERING DIVISION
2820C                 INFORMATION TECHNOLOGY LABORATORY
2821C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
2822C                 GAITHERSBURG, MD 20899-8980
2823C                 PHONE--301-975-2899
2824C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
2825C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
2826C     LANGUAGE--ANSI FORTRAN (1977)
2827C     VERSION NUMBER--2009/11
2828C     ORIGINAL VERSION--NOVEMBER  2009.
2829C     UPDATED         --JULY      2014. ADD SKEWNESS AND KURTOSIS TO
2830C                                       SUMMARY STATISTICS
2831C
2832C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
2833C
2834      CHARACTER*4 ISUBRO
2835      CHARACTER*4 IBUGA3
2836      CHARACTER*4 IERROR
2837      CHARACTER*4 IVARID(*)
2838      CHARACTER*4 IVARI2(*)
2839      CHARACTER*4 ICAPSW
2840      CHARACTER*4 ICAPTY
2841      CHARACTER*4 IFORSW
2842C
2843      CHARACTER*4 IWRITE
2844      CHARACTER*4 IDIR
2845C
2846      CHARACTER*4 ISUBN1
2847      CHARACTER*4 ISUBN2
2848      CHARACTER*4 ISTEPN
2849C
2850      CHARACTER*4 IRTFMD
2851      COMMON/COMRTF/IRTFMD
2852C
2853      PARAMETER (NUMALP=7)
2854      REAL ALPHA(NUMALP)
2855C
2856      CHARACTER*40 IDIST
2857      PARAMETER(NUMCLI=5)
2858      PARAMETER(MAXLIN=3)
2859      PARAMETER (MAXROW=100)
2860      CHARACTER*60 ITITLE
2861      CHARACTER*60 ITITLZ
2862      CHARACTER*1  ITITL9
2863      CHARACTER*60 ITEXT(MAXROW)
2864      CHARACTER*4  ALIGN(NUMCLI)
2865      CHARACTER*4  VALIGN(NUMCLI)
2866      REAL         AVALUE(MAXROW)
2867      INTEGER      NCTEXT(MAXROW)
2868      INTEGER      IDIGIT(MAXROW)
2869      INTEGER      NTOT(MAXROW)
2870      CHARACTER*60 ITITL2(MAXLIN,NUMCLI)
2871      CHARACTER*15 IVALUE(MAXROW,NUMCLI)
2872      CHARACTER*4  ITYPCO(NUMCLI)
2873      INTEGER      NCTIT2(MAXLIN,NUMCLI)
2874      INTEGER      NCVALU(MAXROW,NUMCLI)
2875      INTEGER      IWHTML(NUMCLI)
2876      INTEGER      IWRTF(NUMCLI)
2877      REAL         AMAT(MAXROW,NUMCLI)
2878      LOGICAL IFRST
2879      LOGICAL ILAST
2880C
2881C---------------------------------------------------------------------
2882C
2883      DIMENSION Y(*)
2884      DIMENSION X(*)
2885      DIMENSION TEMP1(*)
2886      DIMENSION TEMP2(*)
2887      DIMENSION TEMP4(*)
2888      DIMENSION YSTAT(*)
2889      DIMENSION STATV(*)
2890      DIMENSION PID(*)
2891C
2892      INTEGER ITEMP1(*)
2893      INTEGER ITEMP2(*)
2894      INTEGER ITEMP3(*)
2895C
2896C---------------------------------------------------------------------
2897C
2898      INCLUDE 'DPCOP2.INC'
2899C
2900      DATA ALPHA/100.0, 50.0, 25.0, 10.0, 5.0, 2.5, 1.0/
2901C
2902C-----START POINT-----------------------------------------------------
2903C
2904      ISUBN1='DPGE'
2905      ISUBN2='S2  '
2906      IERROR='NO'
2907      STATVA=CPUMIN
2908      STATCD=CPUMIN
2909      PVAL=CPUMIN
2910      CUT99=CPUMIN
2911      CUT975=CPUMIN
2912      CUT95=CPUMIN
2913      CUT90=CPUMIN
2914      CUT75=CPUMIN
2915      CUT50=CPUMIN
2916      NCUT=-99
2917C
2918      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GES2')THEN
2919        WRITE(ICOUT,999)
2920  999   FORMAT(1X)
2921        CALL DPWRST('XXX','WRIT')
2922        WRITE(ICOUT,51)
2923   51   FORMAT('**** AT THE BEGINNING OF DPGES2--')
2924        CALL DPWRST('XXX','WRIT')
2925        WRITE(ICOUT,52)ISUBRO,IBUGA3
2926   52   FORMAT('ISUBRO,IBUGA3 = ',2(A4,2X))
2927        CALL DPWRST('XXX','WRIT')
2928        WRITE(ICOUT,55)N,IR
2929   55   FORMAT('N,IR = ',2I8)
2930        CALL DPWRST('XXX','WRIT')
2931        DO56I=1,N
2932          WRITE(ICOUT,57)I,Y(I),X(I)
2933   57     FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
2934          CALL DPWRST('XXX','WRIT')
2935   56   CONTINUE
2936      ENDIF
2937C
2938C               ********************************************
2939C               **  STEP 11--                             **
2940C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
2941C               ********************************************
2942C
2943      ISTEPN='11'
2944      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GES2')
2945     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2946C
2947      IF(N.LT.3)THEN
2948        WRITE(ICOUT,999)
2949        CALL DPWRST('XXX','WRIT')
2950        WRITE(ICOUT,1111)
2951 1111   FORMAT('***** ERROR IN EXTREME STUDENTIZED DEVIATE TEST--')
2952        CALL DPWRST('XXX','WRIT')
2953        WRITE(ICOUT,1113)
2954 1113   FORMAT('      THE NUMBER OF OBSERVATIONS IS LESS THAN 3.')
2955        CALL DPWRST('XXX','WRIT')
2956        WRITE(ICOUT,1114)N
2957 1114   FORMAT('SAMPLE SIZE = ',I8)
2958        CALL DPWRST('XXX','WRIT')
2959        IERROR='YES'
2960        GOTO9000
2961      ENDIF
2962C
2963      IF(IR.GT.N/2)THEN
2964        WRITE(ICOUT,999)
2965        CALL DPWRST('XXX','WRIT')
2966        WRITE(ICOUT,1111)
2967        CALL DPWRST('XXX','WRIT')
2968        WRITE(ICOUT,1121)
2969 1121   FORMAT('      THE SPECIFIED NUMBER OF SUSPECTED OUTLIERS IS ',
2970     1         'GREATER THAN N/2')
2971        CALL DPWRST('XXX','WRIT')
2972        WRITE(ICOUT,1123)IR
2973 1123   FORMAT('THE SUSPECTED NUMBER OF OUTLIERS = ',I8)
2974        CALL DPWRST('XXX','WRIT')
2975        WRITE(ICOUT,1125)N
2976 1125   FORMAT('THE SAMPLE SIZE                  = ',I8)
2977        CALL DPWRST('XXX','WRIT')
2978        IERROR='YES'
2979        GOTO9000
2980      ENDIF
2981C
2982      HOLD=Y(1)
2983      DO1135I=2,N
2984        IF(Y(I).NE.HOLD)GOTO1139
2985 1135 CONTINUE
2986      WRITE(ICOUT,999)
2987      CALL DPWRST('XXX','WRIT')
2988      WRITE(ICOUT,1111)
2989      CALL DPWRST('XXX','WRIT')
2990      WRITE(ICOUT,1131)HOLD
2991 1131 FORMAT('      THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7)
2992      CALL DPWRST('XXX','WRIT')
2993      IERROR='YES'
2994      GOTO9000
2995 1139 CONTINUE
2996C
2997C               **************************************************
2998C               **  STEP 21--                                   **
2999C               **  CARRY OUT CALCULATIONS                      **
3000C               **  FOR    EXTREME STUDENTIZED DEVIATE    TEST  **
3001C               **  NOTE THAT THIS RETURNS IR SEPARATE VALUES   **
3002C               **  OF THE STATISTIC.                           **
3003C               **************************************************
3004C
3005      ISTEPN='21'
3006      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GES2')
3007     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3008C
3009      IDIST=' '
3010      IFLAG=0
3011      CALL SUMRAW(Y,N,IDIST,IFLAG,
3012     1            YMEAN,YVAR,YSD,YMIN,YMAX,
3013     1            ISUBRO,IBUGA3,IERROR)
3014      CALL STMOM3(Y,N,IWRITE,YSKEW,IBUGA3,IERROR)
3015      CALL STMOM4(Y,N,IWRITE,YKURT,IBUGA3,IERROR)
3016C
3017      CALL DPGES3(Y,N,IR,
3018     1            TEMP1,STATV,ITEMP1,ITEMP2,
3019     1            STATVA,
3020     1            ISUBRO,IBUGA3,IERROR)
3021C
3022      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GES2')THEN
3023        DO2130I=1,IR
3024          WRITE(ICOUT,2131)I,STATV(I)
3025 2131     FORMAT('I,STATV(I) = ',I8,G15.7)
3026          CALL DPWRST('XXX','WRIT')
3027 2130   CONTINUE
3028      ENDIF
3029C
3030C               *************************************************
3031C               **  STEP 22--                                  **
3032C               **  LOOP THROUGH EACH VALUE FOR THE NUMBER OF  **
3033C               **  OUTLIERS.  COMPUTE THE CRITICAL VALUES AND **
3034C               **  PRINT THE TABLE.                           **
3035C               **                                             **
3036C               **  FIRST WRITE INITIAL PART OF TABLE THAT IS  **
3037C               **  GENERIC FOR ALL LEVELS FOR THE NUMBER OF   **
3038C               **  OUTLIERS.                                  **
3039C               *************************************************
3040C
3041C
3042      ISTEPN='22'
3043      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GES2')
3044     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3045C
3046      IF(IPRINT.EQ.'OFF')GOTO9000
3047C
3048      NUMDIG=7
3049      IF(IFORSW.EQ.'1')NUMDIG=1
3050      IF(IFORSW.EQ.'2')NUMDIG=2
3051      IF(IFORSW.EQ.'3')NUMDIG=3
3052      IF(IFORSW.EQ.'4')NUMDIG=4
3053      IF(IFORSW.EQ.'5')NUMDIG=5
3054      IF(IFORSW.EQ.'6')NUMDIG=6
3055      IF(IFORSW.EQ.'7')NUMDIG=7
3056      IF(IFORSW.EQ.'8')NUMDIG=8
3057      IF(IFORSW.EQ.'9')NUMDIG=9
3058      IF(IFORSW.EQ.'0')NUMDIG=0
3059      IF(IFORSW.EQ.'E')NUMDIG=-2
3060      IF(IFORSW.EQ.'-2')NUMDIG=-2
3061      IF(IFORSW.EQ.'-3')NUMDIG=-3
3062      IF(IFORSW.EQ.'-4')NUMDIG=-4
3063      IF(IFORSW.EQ.'-5')NUMDIG=-5
3064      IF(IFORSW.EQ.'-6')NUMDIG=-6
3065      IF(IFORSW.EQ.'-7')NUMDIG=-7
3066      IF(IFORSW.EQ.'-8')NUMDIG=-8
3067      IF(IFORSW.EQ.'-9')NUMDIG=-9
3068C
3069      ITITLE=
3070     1  'Generalized Extreme Studentized Deviate Test for'
3071      NCTITL=48
3072      ITITLZ='Multiple Outliers (Assumption: Normality)'
3073      NCTITZ=41
3074C
3075      ICNT=1
3076      ITEXT(ICNT)=' '
3077      NCTEXT(ICNT)=0
3078      AVALUE(ICNT)=0.0
3079      IDIGIT(ICNT)=-1
3080      ICNT=ICNT+1
3081      ITEXT(ICNT)='Response Variable: '
3082      WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1)(1:4)
3083      WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1)(1:4)
3084      NCTEXT(ICNT)=27
3085      AVALUE(ICNT)=0.0
3086      IDIGIT(ICNT)=-1
3087C
3088      IF(NREPL.GT.0)THEN
3089        NRESP=1
3090        IADD=NLABID+NRESP
3091        DO2210I=1,NREPL
3092          ICNT=ICNT+1
3093          ITEMP=I+IADD
3094          ITEXT(ICNT)='Factor Variable  : '
3095          WRITE(ITEXT(ICNT)(17:17),'(I1)')I
3096          WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(ITEMP)(1:4)
3097          WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(ITEMP)(1:4)
3098          NCTEXT(ICNT)=27
3099          AVALUE(ICNT)=PID(ITEMP)
3100          IDIGIT(ICNT)=NUMDIG
3101 2210   CONTINUE
3102      ENDIF
3103C
3104      ICNT=ICNT+1
3105      ITEXT(ICNT)=' '
3106      NCTEXT(ICNT)=1
3107      AVALUE(ICNT)=0.0
3108      IDIGIT(ICNT)=-1
3109C
3110      ICNT=ICNT+1
3111      ITEXT(ICNT)='Summary Statistics:'
3112      NCTEXT(ICNT)=19
3113      AVALUE(ICNT)=0.0
3114      IDIGIT(ICNT)=-1
3115      ICNT=ICNT+1
3116      ITEXT(ICNT)='Number of Observations:'
3117      NCTEXT(ICNT)=23
3118      AVALUE(ICNT)=REAL(N)
3119      IDIGIT(ICNT)=0
3120      ICNT=ICNT+1
3121      ITEXT(ICNT)='Sample Minimum:'
3122      NCTEXT(ICNT)=15
3123      AVALUE(ICNT)=YMIN
3124      IDIGIT(ICNT)=NUMDIG
3125      ICNT=ICNT+1
3126      ITEXT(ICNT)='Sample Maximum:'
3127      NCTEXT(ICNT)=15
3128      AVALUE(ICNT)=YMAX
3129      IDIGIT(ICNT)=NUMDIG
3130      ICNT=ICNT+1
3131      ITEXT(ICNT)='Sample Mean:'
3132      NCTEXT(ICNT)=12
3133      AVALUE(ICNT)=YMEAN
3134      IDIGIT(ICNT)=NUMDIG
3135      ICNT=ICNT+1
3136      ITEXT(ICNT)='Sample SD:'
3137      NCTEXT(ICNT)=10
3138      AVALUE(ICNT)=YSD
3139      IDIGIT(ICNT)=NUMDIG
3140      ICNT=ICNT+1
3141      ITEXT(ICNT)='Sample Skewness:'
3142      NCTEXT(ICNT)=16
3143      AVALUE(ICNT)=YSKEW
3144      IDIGIT(ICNT)=NUMDIG
3145      ICNT=ICNT+1
3146      ITEXT(ICNT)='Sample Kurtosis:'
3147      NCTEXT(ICNT)=16
3148      AVALUE(ICNT)=YKURT
3149      IDIGIT(ICNT)=NUMDIG
3150      ICNT=ICNT+1
3151      ITEXT(ICNT)=' '
3152      NCTEXT(ICNT)=1
3153      AVALUE(ICNT)=0.0
3154      IDIGIT(ICNT)=-1
3155C
3156      ISTEPN='22A'
3157      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GES2')
3158     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3159C
3160      NUMROW=ICNT
3161      DO2215II=1,NUMROW
3162        NTOT(II)=15
3163 2215 CONTINUE
3164C
3165      IFRST=.TRUE.
3166      ILAST=.TRUE.
3167C
3168      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
3169     1            AVALUE,IDIGIT,
3170     1            NTOT,NUMROW,
3171     1            ICAPSW,ICAPTY,ILAST,IFRST,
3172     1            ISUBRO,IBUGA3,IERROR)
3173C
3174      ISTEPN='22B'
3175      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GES2')
3176     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3177C
3178      DO2310I=1,IR
3179C
3180        IRT=I
3181        STATVA=STATV(I)
3182        WRITE(IOUNI2,'(3I8,2X,E15.7)')NCURVE,NREPL,I,STATVA
3183C
3184        IF(N.GE.NCUT)THEN
3185          NTEMP1=N-IRT+1
3186          NTEMP2=N-IRT
3187          NTEMP3=N-IRT-1
3188          DO2320J=1,NUMALP
3189            ALPT=ALPHA(J)/100.0
3190            IF(J.GT.1)THEN
3191              ANU=REAL(NTEMP3)
3192              TERM1=2.0*REAL(NTEMP1)
3193              PTEMP=1.0 - (ALPT/TERM1)
3194              CALL TPPF(PTEMP,ANU,APPF)
3195              TERM1=REAL(NTEMP3) + APPF**2
3196              TERM2=REAL(NTEMP1)
3197              TEMP1(J)=APPF*REAL(NTEMP2)/SQRT(TERM1*TERM2)
3198            ELSE
3199              TEMP1(J)=0.0
3200            ENDIF
3201            IF(J.EQ.2)CUT50=TEMP1(2)
3202            IF(J.EQ.3)CUT75=TEMP1(3)
3203            IF(J.EQ.4)CUT90=TEMP1(4)
3204            IF(J.EQ.5)CUT95=TEMP1(5)
3205            IF(J.EQ.6)CUT975=TEMP1(6)
3206            IF(J.EQ.7)CUT99=TEMP1(7)
3207 2320     CONTINUE
3208          WRITE(IOUNI3,'(3I8,2X,7E15.7)')NCURVE,NREPL,I,
3209     1                                   (TEMP1(JJ),JJ=1,7)
3210        ELSE
3211C
3212C               ************************************
3213C               **  STEP 24--                     **
3214C               **  COMPUTE CRITICAL VALUES VIA   **
3215C               **  MONTE-CARLO SIMULATION FOR    **
3216C               **  SMALL SAMPLES (N < 25)        **
3217C               ************************************
3218C
3219C         NOTE: NEED TO VERIFY THE SIMULATION METHOD BEFORE
3220C               USING IT.  ONCE SIMULATION METHOD IS VERIFIED,
3221C               SET NCUT = 25.  FOR NOW, IT IS SET TO -99 WHICH
3222C               EFFECTIVELY MEANS SIMULATION NOT DONE.
3223C
3224          ISTEPN='24'
3225          IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TIE2')
3226     1      CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3227C
3228          NMCSAM=10000
3229          NTEMP=N
3230          DO2410II=1,NMCSAM
3231            CALL NORRAN(NTEMP,ISEED,TEMP4)
3232            CALL DPGES3(TEMP4,NTEMP,IRT,
3233     1                  TEMP1,TEMP2,ITEMP1,ITEMP3,
3234     1                  STATVA,
3235     1                  ISUBRO,IBUGA3,IERROR)
3236            YSTAT(II)=TEMP2(IRT)
3237 2410     CONTINUE
3238          IDIR='LOWE'
3239          CALL DPGOF8(YSTAT,NMCSAM,STATVA,PVAL,IDIR,
3240     1                IBUGA3,ISUBRO,IERROR)
3241          STATCD=1.0 - PVAL
3242          IWRITE='OFF'
3243          DO2420II=2,7
3244            P100=ALPHA(II)
3245            CALL PERCEN(P100,YSTAT,NMCSAM,IWRITE,TEMP1,NMCSAM,
3246     1                  XSTAT,IBUGA3,IERROR)
3247            IF(II.EQ.2)CUT50=XSTAT
3248            IF(II.EQ.3)CUT75=XSTAT
3249            IF(II.EQ.4)CUT90=XSTAT
3250            IF(II.EQ.5)CUT95=XSTAT
3251            IF(II.EQ.6)CUT975=XSTAT
3252            IF(II.EQ.7)CUT99=XSTAT
3253 2420     CONTINUE
3254C
3255        ENDIF
3256C
3257        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GES2')THEN
3258          WRITE(ICOUT,2331)I,STATVA,CUT99,CUT975,CUT95
3259 2331     FORMAT('I,STATVA,CUT99,CUT975,CUT95 = ',I8,4G15.7)
3260          CALL DPWRST('XXX','WRIT')
3261          WRITE(ICOUT,2333)CUT90,CUT75,CUT50
3262 2333     FORMAT('CUT90,CUT75,CUT50 = ',5G15.7)
3263          CALL DPWRST('XXX','WRIT')
3264          ISTEPN='42'
3265          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3266        ENDIF
3267C
3268C               ********************************************
3269C               **   STEP 42--                            **
3270C               **   WRITE OUT TABLES                     **
3271C               ********************************************
3272C
3273        ITITLE=' '
3274        NCTITL=0
3275        ITITLZ=' '
3276        NCTITZ=0
3277C
3278        ICNT=1
3279        ITEXT(ICNT)=' '
3280        NCTEXT(ICNT)=1
3281        AVALUE(ICNT)=0.0
3282        IDIGIT(ICNT)=-1
3283        ICNT=ICNT+1
3284        ITEXT(ICNT)='H0: There are no outliers'
3285        NCTEXT(ICNT)=25
3286        AVALUE(ICNT)=0.0
3287        IDIGIT(ICNT)=-1
3288        ICNT=ICNT+1
3289C
3290        IF(IRT.EQ.1)THEN
3291          ITEXT(ICNT)(1:21)='Ha: There is exactly '
3292          WRITE(ITEXT(ICNT)(22:26),'(I5)')IRT
3293          ITEXT(ICNT)(27:34)=' outlier'
3294          NCTEXT(ICNT)=34
3295        ELSE
3296          ITEXT(ICNT)(1:22)='Ha: There are exactly '
3297          WRITE(ITEXT(ICNT)(23:27),'(I5)')IRT
3298          ITEXT(ICNT)(28:36)=' outliers'
3299          NCTEXT(ICNT)=36
3300        ENDIF
3301        AVALUE(ICNT)=0.0
3302        IDIGIT(ICNT)=-1
3303C
3304        ICNT=ICNT+1
3305        ITEXT(ICNT)='Potential Outlier Value Tested at This Step:      '
3306        NCTEXT(ICNT)=50
3307        AVALUE(ICNT)=Y(ITEMP2(I))
3308        IDIGIT(ICNT)=NUMDIG
3309C
3310        ICNT=ICNT+1
3311        ITEXT(ICNT)=' '
3312        NCTEXT(ICNT)=1
3313        AVALUE(ICNT)=0.0
3314        IDIGIT(ICNT)=-1
3315        ICNT=ICNT+1
3316        ITEXT(ICNT)='Extreme Studentized Deviate Test Statistic Value:'
3317        NCTEXT(ICNT)=50
3318        AVALUE(ICNT)=STATVA
3319        IDIGIT(ICNT)=NUMDIG
3320C
3321        IF(N.LT.NCUT)THEN
3322          ICNT=ICNT+1
3323          ITEXT(ICNT)='CDF Value:'
3324          NCTEXT(ICNT)=10
3325          AVALUE(ICNT)=STATCD
3326          IDIGIT(ICNT)=NUMDIG
3327          ICNT=ICNT+1
3328          ITEXT(ICNT)='P-Value:'
3329          NCTEXT(ICNT)=7
3330          AVALUE(ICNT)=PVAL
3331          IDIGIT(ICNT)=NUMDIG
3332          ICNT=ICNT+1
3333          ITEXT(ICNT)=' '
3334          NCTEXT(ICNT)=1
3335          AVALUE(ICNT)=0.0
3336          IDIGIT(ICNT)=-1
3337        ENDIF
3338C
3339        NUMROW=ICNT
3340        DO4210II=1,NUMROW
3341          NTOT(II)=15
3342 4210   CONTINUE
3343C
3344        IFRST=.TRUE.
3345        ILAST=.FALSE.
3346C
3347        ISTEPN='42A'
3348        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GES2')
3349     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3350C
3351        CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
3352     1              AVALUE,IDIGIT,
3353     1              NTOT,NUMROW,
3354     1              ICAPSW,ICAPTY,ILAST,IFRST,
3355     1              ISUBRO,IBUGA3,IERROR)
3356C
3357        ISTEPN='42B'
3358        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GES2')
3359     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3360C
3361        ITITLE=' '
3362        NCTITL=0
3363C
3364        ITITL9=' '
3365        NCTIT9=0
3366        ITITLE(1:44)='Percent Points of the Reference Distribution'
3367        NCTITL=44
3368        NUMLIN=1
3369        NUMROW=NUMALP
3370        NUMCOL=3
3371        ITITL2(1,1)='Percent Point'
3372        ITITL2(1,2)=' '
3373        ITITL2(1,3)='Value'
3374        NCTIT2(1,1)=13
3375        NCTIT2(1,2)=1
3376        NCTIT2(1,3)=5
3377C
3378        NMAX=0
3379        DO4221II=1,NUMCOL
3380          VALIGN(II)='b'
3381          ALIGN(II)='r'
3382          NTOT(II)=15
3383          IF(II.EQ.2)NTOT(II)=5
3384          NMAX=NMAX+NTOT(II)
3385          IDIGIT(II)=NUMDIG
3386          ITYPCO(II)='NUME'
3387 4221   CONTINUE
3388        ITYPCO(2)='ALPH'
3389        IDIGIT(1)=1
3390        IDIGIT(3)=3
3391        DO4223II=1,NUMROW
3392          DO4225J=1,NUMCOL
3393            NCVALU(II,J)=0
3394            IVALUE(II,J)=' '
3395            NCVALU(II,J)=0
3396            AMAT(II,J)=0.0
3397CCCCC       JINDX=NUMCOL-II+1
3398            JINDX=II
3399            IF(J.EQ.1)THEN
3400              AMAT(II,J)=100.0 - ALPHA(II)
3401            ELSEIF(J.EQ.2)THEN
3402              IVALUE(II,J)='='
3403              NCVALU(II,J)=1
3404            ELSEIF(J.EQ.3)THEN
3405              IF(II.EQ.1)THEN
3406                AMAT(JINDX,J)=0.0
3407              ELSEIF(II.EQ.2)THEN
3408                AMAT(JINDX,J)=RND(CUT50,IDIGIT(J))
3409              ELSEIF(II.EQ.3)THEN
3410                AMAT(JINDX,J)=RND(CUT75,IDIGIT(J))
3411              ELSEIF(II.EQ.4)THEN
3412                AMAT(JINDX,J)=RND(CUT90,IDIGIT(J))
3413              ELSEIF(II.EQ.5)THEN
3414                AMAT(JINDX,J)=RND(CUT95,IDIGIT(J))
3415              ELSEIF(II.EQ.6)THEN
3416                AMAT(JINDX,J)=RND(CUT975,IDIGIT(J))
3417              ELSEIF(II.EQ.7)THEN
3418                AMAT(JINDX,J)=RND(CUT99,IDIGIT(J))
3419              ENDIF
3420            ENDIF
3421 4225     CONTINUE
3422 4223   CONTINUE
3423C
3424        IWHTML(1)=150
3425        IWHTML(2)=50
3426        IWHTML(3)=150
3427        IWRTF(1)=2000
3428        IWRTF(2)=IWRTF(1)+500
3429        IWRTF(3)=IWRTF(2)+2000
3430C
3431        ISTEPN='42C'
3432        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GES2')
3433     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3434C
3435        IFRST=.FALSE.
3436        ILAST=.FALSE.
3437C
3438        CALL DPDTA4(ITITL9,NCTIT9,
3439     1              ITITLE,NCTITL,ITITL2,NCTIT2,
3440     1              MAXLIN,NUMLIN,NUMCLI,NUMCOL,
3441     1              IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW,
3442     1              IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
3443     1              ICAPSW,ICAPTY,IFRST,ILAST,
3444     1              ISUBRO,IBUGA3,IERROR)
3445C
3446        ISTEPN='42D'
3447        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GES2')
3448     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3449C
3450        CDF1=CUT90
3451        CDF2=CUT95
3452        CDF3=CUT975
3453        CDF4=CUT99
3454C
3455        ITITL9=' '
3456        NCTIT9=0
3457        ITITLE='Conclusions (2-Tailed Test)'
3458        NCTITL=27
3459        NUMLIN=1
3460        NUMROW=4
3461        NUMCOL=4
3462        ITITL2(1,1)='Alpha'
3463        ITITL2(1,2)='CDF'
3464        ITITL2(1,3)='Critical Value'
3465        ITITL2(1,4)='Conclusion'
3466        NCTIT2(1,1)=5
3467        NCTIT2(1,2)=3
3468        NCTIT2(1,3)=14
3469        NCTIT2(1,4)=10
3470C
3471        NMAX=0
3472        DO4321II=1,NUMCOL
3473          ALIGN(II)='r'
3474          NTOT(II)=15
3475          IF(II.EQ.1 .OR. II.EQ.2)NTOT(II)=7
3476          IF(II.EQ.3)NTOT(II)=17
3477          NMAX=NMAX+NTOT(II)
3478          IDIGIT(II)=3
3479          ITYPCO(II)='ALPH'
3480 4321   CONTINUE
3481        ITYPCO(3)='NUME'
3482        IDIGIT(1)=0
3483        IDIGIT(2)=0
3484        DO4323II=1,NUMROW
3485          DO4325J=1,NUMCOL
3486            NCVALU(II,J)=0
3487            IVALUE(II,J)=' '
3488            NCVALU(II,J)=0
3489            AMAT(II,J)=0.0
3490 4325     CONTINUE
3491 4323   CONTINUE
3492        IVALUE(1,1)='10%'
3493        IVALUE(2,1)='5%'
3494        IVALUE(3,1)='2.5%'
3495        IVALUE(4,1)='1%'
3496        IVALUE(1,2)='90%'
3497        IVALUE(2,2)='95%'
3498        IVALUE(3,2)='97.5%'
3499        IVALUE(4,2)='99%'
3500        NCVALU(1,1)=3
3501        NCVALU(2,1)=2
3502        NCVALU(3,1)=4
3503        NCVALU(4,1)=2
3504        NCVALU(1,2)=3
3505        NCVALU(2,2)=3
3506        NCVALU(3,2)=5
3507        NCVALU(4,2)=3
3508        IVALUE(1,4)='Accept H0'
3509        IVALUE(2,4)='Accept H0'
3510        IVALUE(3,4)='Accept H0'
3511        IVALUE(4,4)='Accept H0'
3512        NCVALU(1,4)=9
3513        NCVALU(2,4)=9
3514        NCVALU(3,4)=9
3515        NCVALU(4,4)=9
3516C
3517C       AUGUST 2011: INVERTED ORDER OF CRITICAL VALUES
3518C
3519CCCCC   IF(STATVA.GT.CDF1)IVALUE(1,4)='Reject H0'
3520CCCCC   IF(STATVA.GT.CDF2)IVALUE(2,4)='Reject H0'
3521CCCCC   IF(STATVA.GT.CDF3)IVALUE(3,4)='Reject H0'
3522CCCCC   IF(STATVA.GT.CDF4)IVALUE(4,4)='Reject H0'
3523CCCCC   AMAT(1,3)=RND(CDF4,IDIGIT(3))
3524CCCCC   AMAT(2,3)=RND(CDF3,IDIGIT(3))
3525CCCCC   AMAT(3,3)=RND(CDF2,IDIGIT(3))
3526CCCCC   AMAT(4,3)=RND(CDF1,IDIGIT(3))
3527        IF(STATVA.GT.CDF1)IVALUE(1,4)='Reject H0'
3528        IF(STATVA.GT.CDF2)IVALUE(2,4)='Reject H0'
3529        IF(STATVA.GT.CDF3)IVALUE(3,4)='Reject H0'
3530        IF(STATVA.GT.CDF4)IVALUE(4,4)='Reject H0'
3531        AMAT(1,3)=RND(CDF1,IDIGIT(3))
3532        AMAT(2,3)=RND(CDF2,IDIGIT(3))
3533        AMAT(3,3)=RND(CDF3,IDIGIT(3))
3534        AMAT(4,3)=RND(CDF4,IDIGIT(3))
3535C
3536        IWHTML(1)=150
3537        IWHTML(2)=150
3538        IWHTML(3)=150
3539        IWHTML(4)=150
3540        IWRTF(1)=1500
3541        IWRTF(2)=IWRTF(1)+1500
3542        IWRTF(3)=IWRTF(2)+2000
3543        IWRTF(4)=IWRTF(3)+2000
3544        IFRST=.FALSE.
3545        ILAST=.TRUE.
3546C
3547        ISTEPN='42E'
3548        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GES2')
3549     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3550C
3551        IFRST=.FALSE.
3552        ILAST=.TRUE.
3553C
3554        CALL DPDTA4(ITITL9,NCTIT9,
3555     1              ITITLE,NCTITL,ITITL2,NCTIT2,
3556     1              MAXLIN,NUMLIN,NUMCLI,NUMCOL,
3557     1              IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW,
3558     1              IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
3559     1              ICAPSW,ICAPTY,IFRST,ILAST,
3560     1              ISUBRO,IBUGA3,IERROR)
3561C
3562      STATV(I+1000)=CUT90
3563      STATV(I+2000)=CUT95
3564      STATV(I+3000)=CUT99
3565C
3566 2310 CONTINUE
3567C
3568C               ********************************************
3569C               **   STEP 43--                            **
3570C               **   WRITE OUT A SUMMARY TABLE            **
3571C               ********************************************
3572C
3573        ISTEPN='43'
3574        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GES2')
3575     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3576C
3577        ITITL9=' '
3578        NCTIT9=0
3579        ITITLE='Summary Table'
3580        NCTITL=13
3581        NUMLIN=3
3582        NUMROW=IR
3583        NUMCOL=5
3584        ITITL2(1,1)='Exact'
3585        ITITL2(1,2)='Test'
3586        ITITL2(1,3)='Critical'
3587        ITITL2(1,4)='Critical'
3588        ITITL2(1,5)='Critical'
3589        NCTIT2(1,1)=5
3590        NCTIT2(1,2)=4
3591        NCTIT2(1,3)=8
3592        NCTIT2(1,4)=8
3593        NCTIT2(1,5)=8
3594        ITITL2(2,1)='Number of'
3595        ITITL2(2,2)='Statistic'
3596        ITITL2(2,3)='Value'
3597        ITITL2(2,4)='Value'
3598        ITITL2(2,5)='Value'
3599        NCTIT2(2,1)=9
3600        NCTIT2(2,2)=9
3601        NCTIT2(2,3)=5
3602        NCTIT2(2,4)=5
3603        NCTIT2(2,5)=5
3604        ITITL2(3,1)='Outliers'
3605        ITITL2(3,2)='Value'
3606        ITITL2(3,3)='10%'
3607        ITITL2(3,4)='5%'
3608        ITITL2(3,5)='1%'
3609        NCTIT2(3,1)=8
3610        NCTIT2(3,2)=5
3611        NCTIT2(3,3)=3
3612        NCTIT2(3,4)=2
3613        NCTIT2(3,5)=2
3614C
3615        NMAX=0
3616        DO5321II=1,NUMCOL
3617          ALIGN(II)='r'
3618          NTOT(II)=15
3619          IF(II.EQ.1)NTOT(II)=10
3620          NMAX=NMAX+NTOT(II)
3621          IDIGIT(II)=NUMDIG
3622          ITYPCO(II)='NUME'
3623 5321   CONTINUE
3624        IDIGIT(1)=0
3625        DO5323II=1,NUMROW
3626          DO5325J=1,NUMCOL
3627            NCVALU(II,J)=0
3628            IVALUE(II,J)=' '
3629            IF(J.EQ.1)THEN
3630              AMAT(II,J)=REAL(II)
3631            ELSEIF(J.EQ.2)THEN
3632              AMAT(II,J)=STATV(II)
3633            ELSEIF(J.EQ.3)THEN
3634              AMAT(II,J)=STATV(II+1000)
3635            ELSEIF(J.EQ.4)THEN
3636              AMAT(II,J)=STATV(II+2000)
3637            ELSEIF(J.EQ.5)THEN
3638              AMAT(II,J)=STATV(II+3000)
3639            ENDIF
3640 5325     CONTINUE
3641 5323   CONTINUE
3642C
3643        IWHTML(1)=150
3644        IWHTML(2)=150
3645        IWHTML(3)=150
3646        IWHTML(4)=150
3647        IWHTML(5)=150
3648        IWRTF(1)=1200
3649        IWRTF(2)=IWRTF(1)+1500
3650        IWRTF(3)=IWRTF(2)+2000
3651        IWRTF(4)=IWRTF(3)+2000
3652        IWRTF(5)=IWRTF(4)+2000
3653        IFRST=.TRUE.
3654        ILAST=.TRUE.
3655C
3656        ISTEPN='43B'
3657        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GES2')
3658     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3659C
3660        CALL DPDTA4(ITITL9,NCTIT9,
3661     1              ITITLE,NCTITL,ITITL2,NCTIT2,
3662     1              MAXLIN,NUMLIN,NUMCLI,NUMCOL,
3663     1              IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW,
3664     1              IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
3665     1              ICAPSW,ICAPTY,IFRST,ILAST,
3666     1              ISUBRO,IBUGA3,IERROR)
3667C
3668C               *****************
3669C               **  STEP 90--  **
3670C               **  EXIT       **
3671C               *****************
3672C
3673 9000 CONTINUE
3674      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GES2')THEN
3675        WRITE(ICOUT,999)
3676        CALL DPWRST('XXX','WRIT')
3677        WRITE(ICOUT,9011)
3678 9011   FORMAT('***** AT THE END       OF DPGES2--')
3679        CALL DPWRST('XXX','WRIT')
3680        WRITE(ICOUT,9012)N,IERROR
3681 9012   FORMAT('N,IERROR = ',I8,2X,A4)
3682        CALL DPWRST('XXX','WRIT')
3683        WRITE(ICOUT,9013)STATVA
3684 9013   FORMAT('STATVA = ',G15.7)
3685        CALL DPWRST('XXX','WRIT')
3686      ENDIF
3687C
3688      RETURN
3689      END
3690      SUBROUTINE DPGES3(Y,N,IR,
3691     1                  TEMP1,STATV,ITEMP1,ITEMP2,
3692     1                  STATVA,
3693     1                  ISUBRO,IBUGA3,IERROR)
3694C
3695C     PURPOSE--THIS ROUTINE IS SPLIT OFF FROM DPGES2 TO COMPUTE THE
3696C              GENERALIZED ESD (EXTREME STUDENTIZED DEVIATE) STATISTIC.
3697C              THIS ROUTINE JUST RETURNS THE VALUE OF THE TEST STATISTIC
3698C              (I.E., NO CRITICAL VALUES OR PRINTING).  NOTE THAT IT ALSO
3699C              ONLY COMPUTES THE STATISTIC FOR A SINGLE STAGE (I.E.,
3700C              FIXED VALUE FOR THE NUMBER OF OUTLIERS).
3701C     REFERENCE--IGLEWICZ AND HOAGLIN (1993), "VOLUME 16: HOW TO DETECT
3702C                AND HANDLE OUTLIERS", THE ASQC BASIC REFERENCE IN
3703C                QUALITY CONTROL: STATISTICAL TECHNIQUES, EDWARD
3704C                F. MYKYTKA, Ph.D., EDITOR.
3705C     WRITTEN BY--ALAN HECKERT
3706C                 STATISTICAL ENGINEERING DIVISION
3707C                 INFORMATION TECHNOLOGY LABORATORY
3708C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
3709C                 GAITHERSBURG, MD 20899-8980
3710C                 PHONE--301-975-2899
3711C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
3712C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
3713C     LANGUAGE--ANSI FORTRAN (1977)
3714C     VERSION NUMBER--2009/11
3715C     ORIGINAL VERSION--NOVEMBER  2009.
3716C
3717C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
3718C
3719      CHARACTER*4 ISUBRO
3720      CHARACTER*4 IBUGA3
3721      CHARACTER*4 IERROR
3722C
3723      CHARACTER*4 IWRITE
3724C
3725      CHARACTER*4 ISUBN1
3726      CHARACTER*4 ISUBN2
3727      CHARACTER*4 ISTEPN
3728C
3729C---------------------------------------------------------------------
3730C
3731      REAL Y(*)
3732      REAL TEMP1(*)
3733      REAL STATV(*)
3734      INTEGER ITEMP1(*)
3735      INTEGER ITEMP2(*)
3736C
3737C---------------------------------------------------------------------
3738C
3739      INCLUDE 'DPCOP2.INC'
3740C
3741C-----START POINT-----------------------------------------------------
3742C
3743      ISUBN1='DPGE'
3744      ISUBN2='S3  '
3745      IERROR='NO'
3746      STATVA=CPUMIN
3747C
3748      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GES3')THEN
3749        WRITE(ICOUT,999)
3750  999   FORMAT(1X)
3751        CALL DPWRST('XXX','WRIT')
3752        WRITE(ICOUT,51)
3753   51   FORMAT('**** AT THE BEGINNING OF DPGES3--')
3754        CALL DPWRST('XXX','WRIT')
3755        WRITE(ICOUT,52)ISUBRO,IBUGA3
3756   52   FORMAT('ISUBRO,IBUGA3 = ',A4,2X,A4)
3757        CALL DPWRST('XXX','WRIT')
3758        WRITE(ICOUT,55)N,IR
3759   55   FORMAT('N,IR = ',2I8)
3760        CALL DPWRST('XXX','WRIT')
3761        DO56I=1,N
3762          WRITE(ICOUT,57)I,Y(I)
3763   57     FORMAT('I,Y(I) = ',I8,G15.7)
3764          CALL DPWRST('XXX','WRIT')
3765   56   CONTINUE
3766      ENDIF
3767C
3768C               ********************************************
3769C               **  STEP 11--                             **
3770C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
3771C               ********************************************
3772C
3773      ISTEPN='11'
3774      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GES3')
3775     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3776C
3777      IF(N.LT.3)THEN
3778        WRITE(ICOUT,999)
3779        CALL DPWRST('XXX','WRIT')
3780        WRITE(ICOUT,1111)
3781 1111   FORMAT('***** ERROR IN EXTREME STUDENTIZED DEVIATE TEST--')
3782        CALL DPWRST('XXX','WRIT')
3783        WRITE(ICOUT,1113)
3784 1113   FORMAT('      THE NUMBER OF OBSERVATIONS IS LESS THAN 3.')
3785        CALL DPWRST('XXX','WRIT')
3786        WRITE(ICOUT,1114)N
3787 1114   FORMAT('SAMPLE SIZE = ',I8)
3788        CALL DPWRST('XXX','WRIT')
3789        IERROR='YES'
3790        GOTO9000
3791      ENDIF
3792C
3793      IF(IR.GT.N/2)THEN
3794        WRITE(ICOUT,999)
3795        CALL DPWRST('XXX','WRIT')
3796        WRITE(ICOUT,1111)
3797        CALL DPWRST('XXX','WRIT')
3798        WRITE(ICOUT,1121)
3799 1121   FORMAT('      THE SPECIFIED NUMBER OF SUSPECTED OUTLIERS IS ',
3800     1         'GREATER THAN N/2')
3801        CALL DPWRST('XXX','WRIT')
3802        WRITE(ICOUT,1123)IR
3803 1123   FORMAT('THE SUSPECTED NUMBER OF OUTLIERS = ',I8)
3804        CALL DPWRST('XXX','WRIT')
3805        WRITE(ICOUT,1125)N
3806 1125   FORMAT('THE SAMPLE SIZE                  = ',I8)
3807        CALL DPWRST('XXX','WRIT')
3808        IERROR='YES'
3809        GOTO9000
3810      ENDIF
3811C
3812      HOLD=Y(1)
3813      DO1135I=2,N
3814        IF(Y(I).NE.HOLD)GOTO1139
3815 1135 CONTINUE
3816      WRITE(ICOUT,999)
3817      CALL DPWRST('XXX','WRIT')
3818      WRITE(ICOUT,1111)
3819      CALL DPWRST('XXX','WRIT')
3820      WRITE(ICOUT,1131)HOLD
3821 1131 FORMAT('      THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7)
3822      CALL DPWRST('XXX','WRIT')
3823      IERROR='YES'
3824      GOTO9000
3825 1139 CONTINUE
3826C
3827C               **************************************
3828C               **  STEP 21--                       **
3829C               **  CARRY OUT CALCULATIONS          **
3830C               **  FOR    GENERALIZED ESD    TEST  **
3831C               **************************************
3832C
3833      ISTEPN='21'
3834      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GES3')
3835     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3836C
3837C     THE ESD TEST STATISTIC IS:
3838C
3839C        Ts = MAX(i){|x(i) - xbar|/s : i = 1, ..., n}
3840C
3841C     IF IR > 1, APPLY THIS PROCEDURE IR TIMES BY REMOVING
3842C     MOST OUTLYING POINT AT EACH STAGE.
3843C
3844C     RETURN BOTH THE VALUE FOR THE IR-TH STAGE AS A SCALAR
3845C     AND AN ARRAY OF VALUES FOR EACH STAGE.
3846C
3847      IWRITE='OFF'
3848C
3849      DO2010I=1,N
3850        ITEMP1(I)=1
3851        ITEMP2(I)=0
3852 2010 CONTINUE
3853C
3854      DO2100IINDX=1,IR
3855C
3856        STATT=CPUMIN
3857        ICNT=0
3858        DO2110I=1,N
3859          IF(ITEMP1(I).EQ.1)THEN
3860            ICNT=ICNT+1
3861            TEMP1(ICNT)=Y(I)
3862          ENDIF
3863 2110   CONTINUE
3864        CALL MEAN(TEMP1,ICNT,IWRITE,YMEAN,IBUGA3,IERROR)
3865        CALL SD(TEMP1,ICNT,IWRITE,YSD,IBUGA3,IERROR)
3866C
3867        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GES3')THEN
3868          WRITE(ICOUT,2113)IINDX,ICNT,YMEAN,YSD
3869 2113     FORMAT('IINDX,ICNT,YMEAN,YSD = ',2I8,2G15.7)
3870          CALL DPWRST('XXX','WRIT')
3871        ENDIF
3872C
3873        INDXT=-99
3874        DO2120I=1,N
3875          IF(ITEMP1(I).EQ.1)THEN
3876            AVAL=ABS(Y(I) - YMEAN)/YSD
3877            IF(AVAL.GT.STATT)THEN
3878              STATT=AVAL
3879              INDXT=I
3880            ENDIF
3881          ENDIF
3882 2120   CONTINUE
3883        ITEMP2(IINDX)=INDXT
3884        ITEMP1(INDXT)=0
3885        STATV(IINDX)=STATT
3886C
3887 2100 CONTINUE
3888      STATVA=STATV(IR)
3889C
3890C               *****************
3891C               **  STEP 90--  **
3892C               **  EXIT       **
3893C               *****************
3894C
3895 9000 CONTINUE
3896      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GES3')THEN
3897        WRITE(ICOUT,999)
3898        CALL DPWRST('XXX','WRIT')
3899        WRITE(ICOUT,9011)
3900 9011   FORMAT('***** AT THE END       OF DPGES3--')
3901        CALL DPWRST('XXX','WRIT')
3902        DO9012I=1,IR
3903          WRITE(ICOUT,9013)I,STATV(I),ITEMP1(I)
3904 9013     FORMAT('I,STATV(I),ITEMP1(I) = ',I8,G15.7,I8)
3905          CALL DPWRST('XXX','WRIT')
3906 9012   CONTINUE
3907        WRITE(ICOUT,9018)N,IR
3908 9018   FORMAT('N,IR = ',2I8)
3909        CALL DPWRST('XXX','WRIT')
3910      ENDIF
3911C
3912      RETURN
3913      END
3914      SUBROUTINE DPGETC(IOUNI0,MAXWID,ITERCH,ICONCH,IANS,IANSLC,IWIDTH,
3915     1                  IANSV,IWIDSV,
3916     1                  IREPST,IREPPO,IANSSV,IREPMX,IPOINT,
3917     1                  IPLTST,IPLTPO,IPLTSV,IPROSW,
3918     1                  ICLIFL,ICLILO,ICLILN,ICLIL2,
3919     1                  IMACRO,IMACNU,IMACCS,IMACL1,IMACL2,
3920     1                  IMACLR,IMALEV,
3921     1                  IPROGR,ICONCL,IEOF,IIFSW,ICAPSW,IPRDEF,IATXSW,
3922     1                  IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,IVARLB,
3923     1                  IROWLB,
3924     1                  IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,ILOOST,
3925     1                  IBUGS2,ISUBRO,IFOUND,IERROR)
3926C
3927C     PURPOSE--GET A COMMAND TO BE PROCESSED.
3928C              SUCH A COMMAND IS GOTTEN IN 2 WAYS--
3929C                   1) TO READ FROM THE STANDARD INPUT UNIT (THIS IS
3930C                      DONE ONLY WHEN NO PREVIOUS COMMANDS HAVE BEEN
3931C                      SAVED IN A BUFFER);
3932C                   2) TO EXTRACT THE NEXT COMMAND STATEMENT IN THE
3933C                      SAVED BUFFER (THIS IS DONE ONLY WHEN PREVIOUS
3934C                      COMMANDS HAVE IN FACT BEEN SAVED IN A BUFFER).
3935C
3936C     INPUT  ARGUMENTS--MAXWID (AN INTEGER VARIABLE WHICH CONTAINS THE
3937C                              MAXIMUM NUMBER OF CHARACTERS PER LINE
3938C                              THAT MAY BE READ.
3939C                     --ITERCH (A HOLLARITH VARIABLE CONTAINING THE
3940C                              SEPARATOR CHARACTOR WHICH MAY BE USED FOR
3941C                              SEPARATING MULTIPLE COMMAND STATEMENTS
3942C                              PER LINE.
3943C                     --ICONCH (A HOLLERITH VARIABLE CONTAINING THE
3944C                              CONTINUE CHARACTER WHICH MAY BE USED FOR
3945C                              EXTENDING COMMANDS ONTO A SECOND LINE
3946C                     --IANSV  (A  HOLLARITH VECTOR WHOSE I-TH ELEMENT
3947C                              CONTAINS THE I-TH CHARACTER OF THE SAVED
3948C                              COMMAND LINE.
3949C                     --IWIDSV (AN INTEGER VARIABLE WHICH CONTAINS THE
3950C                              NUMBER OF CHARACTERS IN THE SAVED COMMAND
3951C                              LINE.
3952C                     --IPOINT THE CURRENT  POINTER POSITION IN THE SAVE
3953C                              ARRAY WHERE THE CURRENT COMMAND LINE WILL
3954C                              BE SAVED.
3955C                     --ISAVPO IF IN REPEAT MODE EXECUTION, THE CURRENT
3956C                              POINTER POSITION IN THE SAVE ARRAY WOF THE
3957C                              COMMAND CURRENTLY BEING EXECUTED.
3958C     OUTPUT ARGUMENTS--IANS   (A  HOLLARITH VECTOR WHOSE I-TH ELEMENT
3959C                              CONTAINS THE I-TH CHARACTER OF THE
3960C                              CURRENT COMMAND STATEMENT (BUT TRANSLATED
3961C                              TO UPPER CASE).
3962C                     --IANSLC (A  HOLLARITH VECTOR WHOSE I-TH ELEMENT
3963C                              CONTAINS THE I-TH CHARACTER OF THE
3964C                              CURRENT COMMAND STATEMENT (UNCONVERTED,
3965C                              AND SO MAY BE LOWER CASE).
3966C                     --IWIDTH (AN INTEGER VARIABLE WHICH CONTAINS THE
3967C                              NUMBER OF CHARACTERS IN THE CURRENT
3968C                              COMMAND STATEMENT.
3969C                     --IBUGS2 (A HOLLARITH VARIABLE FOR DEBUGGING
3970C                     --IERROR ('YES' OR 'NO' )
3971C
3972C     WRITTEN BY--JAMES J. FILLIBEN
3973C                 STATISTICAL ENGINEERING DIVISION
3974C                 INFORMATION TECHNOLOGY LABORATORY
3975C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
3976C                 GAITHERSBURG, MD 20899-8980
3977C                 PHONE--301-975-2855
3978C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
3979C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
3980C     LANGUAGE--ANSI FORTRAN (1977)
3981C     VERSION NUMBER--86/1
3982C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--NOVEMBER  1980.
3983C     UPDATED--MAY       1982.
3984C     UPDATED--JANUARY   1983.
3985C     UPDATED--DECEMBER  1985.
3986C     UPDATED--DECEMBER  1988.  SUPPRESS ERROR MESSAGE FOR \ IN FALSE IF
3987C     UPDATED--FEBRUARY  1989.  CONTINUE CHARACTER (ALAN)
3988C     UPDATED--JUNE      1989.  SUPPRESS ERROR MESSAGE FOR \ IN COMMENT
3989C     UPDATED--JUNE      1989.  ADD ARGS AND ADJUST PROMPT FOR CAPTURE
3990C     UPDATED--JUNE      1991.  READ FROM TURBO-C GUI MENU  JJF
3991C     UPDATED--JUNE      1991.  CHANGE NUMBERING (15XX TO 16XX)  JJF
3992C     UPDATED--APRIL     1992.  COMMENT OUT IOFILE
3993C     UPDATED--FEBRUARY  1993.  POINTER PROBLEMS WITH /
3994C     UPDATED--FEBRUARY  1993.  POINTER PROBLEMS WITH EOF
3995C     UPDATED--OCTOBER   1993.  CONVERT NON-PRINTING TO SPACES
3996C     UPDATED--AUGUST    1994.  EXECUTE SUBSET OF MACRO
3997C     UPDATED--NOVEMBER  1994.  PROMPT FOR VAX
3998C     UPDATED--JANUARY   1995.  ALLOW    LIST <FILE>   TO BE SAVED
3999C     UPDATED--JULY      1996.  FIX PROMPT FOR LAHEY PC IMPLEMENTATION
4000C     UPDATED--OCTOBER   1996.  FIX PROMPT FOR MICROSOFT PC IMPLEMENTATION
4001C     UPDATED--NOVEMBER  1997.  DON'T STORE COMMANDS STARTING WITH
4002C                               "GUI"
4003C     UPDATED--DECEMBER  1997.  REPLOT COMMAND
4004C     UPDATED--OCTOBER   1998.  PROMPT FOR LAHEY GUI
4005C     UPDATED--JANUARY   2000.  CALL LIST TO DPREP2
4006C     UPDATED--AUGUST    2002.  IATXSW (IF ON, PREPEND
4007C                               "TEXT" TO COMMAND LINE)
4008C     UPDATED--DECEMBER  2004.  DO NOT ALLOW CONTINUATION LINES WHILE
4009C                               RUNNING THE GUI
4010C     UPDATED--AUGUST    2007.  SUPPORT NON-ADVANCING PROMPT FOR
4011C                               FORTRAN-90 COMPILERS
4012C     UPDATED--SEPTEMBER 2007.  PASS ROW LABELS TO DPGETC
4013C     UPDATED--APRIL     2009.  REWRITE FOR BETTER CLARITY
4014C     UPDATED--APRIL     2009.  SUPPORT GNU READLINE FACILITY
4015C     UPDATED--MAY       2009.  ALLOW INDEFINITE NUMBER OF CONTINUATION
4016C                               LINES (BASICALLY, UNTIL REACH MAXIMUM
4017C                               NUMBER OF CHARACTERS IN THE COMMAND LINE)
4018C     UPDATED--JULY      2009.  IF RUNNING GUI, DON'T WANT TO USE
4019C                               "ADVANCE" MODE WITH gfortran COMPILER.
4020C                               MODIFY ARGUMENT LIST FOR DPPRMP.
4021C     UPDATED--NOVEMBER  2014.  OPTION FOR READING COMMANDS FROM
4022C                               CLIPBOARD
4023C     UPDATED--FEBRUARY  2019.  SET CLIPBOARD RUN CLEAR OPTION
4024C
4025C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
4026C
4027      INCLUDE 'DPCOPA.INC'
4028C
4029      CHARACTER*4 ICLIFL
4030      CHARACTER*4 ICLILO
4031      CHARACTER*4 ITERCH
4032      CHARACTER*4 IANS(*)
4033      CHARACTER*4 IANSLC(*)
4034      CHARACTER*4 IANSV(*)
4035      CHARACTER*4 IPROSW
4036      CHARACTER*4 IMACRO
4037      CHARACTER*12 IMACCS
4038C
4039      CHARACTER*4 IPROGR
4040      CHARACTER*4 ICONCL
4041      CHARACTER*4 IEOF
4042      CHARACTER*4 IIFSW
4043      CHARACTER*4 IATXSW
4044C
4045      CHARACTER*4 IREPST
4046      CHARACTER*1 IANSSV
4047      CHARACTER*4 IPLTST
4048      CHARACTER*1 IPLTSV
4049C
4050      CHARACTER*4 ILOOST
4051C
4052      CHARACTER*4 IHNAME(*)
4053      CHARACTER*4 IHNAM2(*)
4054      CHARACTER*4 IUSE
4055      CHARACTER*4 IFUNC
4056      CHARACTER*40 IVARLB(*)
4057      CHARACTER*24 IROWLB(*)
4058C
4059      CHARACTER*1 IREPCH
4060      CHARACTER*4 IC4
4061      CHARACTER*10 IFORMT
4062C
4063      CHARACTER*4 ISUBN1
4064      CHARACTER*4 ISUBN2
4065      CHARACTER*4 ISTEPN
4066      CHARACTER*4 IBUGS2
4067      CHARACTER*4 ISUBRO
4068      CHARACTER*4 IFOUND
4069      CHARACTER*4 IERROR
4070      CHARACTER (LEN=MAXSTR) :: ISTRZZ
4071C
4072CCCCC CHARACTER*80 IFILE
4073      CHARACTER (LEN=MAXFNC) :: IFILE
4074      CHARACTER*12 ISTAT
4075      CHARACTER*12 IFORM
4076      CHARACTER*12 IACCES
4077      CHARACTER*12 IPROT
4078      CHARACTER*12 ICURST
4079      CHARACTER*4 IREWIN
4080      CHARACTER*4 IENDFI
4081      CHARACTER*4 ISUBN0
4082      CHARACTER*4 IERRFI
4083      CHARACTER*4 ICAPSW
4084C
4085      DIMENSION IANSSV(MAXLIS,MAXCIS)
4086      DIMENSION IPLTSV(MAXLIP,MAXCIS)
4087C
4088      DIMENSION IUSE(*)
4089      DIMENSION IVALUE(*)
4090      DIMENSION VALUE(*)
4091      DIMENSION IVSTAR(*)
4092      DIMENSION IVSTOP(*)
4093      DIMENSION IFUNC(*)
4094C
4095      DIMENSION XJUNK(1)
4096      CHARACTER*4   IRTYPE
4097      CHARACTER*4   IVLIST(1)
4098      CHARACTER*4   IVLIS2(1)
4099C
4100CCCCC DIMENSION IA(132)
4101C
4102C-----COMMON----------------------------------------------------------
4103C
4104      INCLUDE 'DPCOHO.INC'
4105      INCLUDE 'DPCOFO.INC'
4106      INCLUDE 'DPCOF2.INC'
4107      INCLUDE 'DPCOWI.INC'
4108      INCLUDE 'DPCODV.INC'
4109      INCLUDE 'DPCONP.INC'
4110      INCLUDE 'DPCOST.INC'
4111      INCLUDE 'DPCOMC.INC'
4112C
4113      CHARACTER*4 ICONCH
4114      CHARACTER*1 IATEMP
4115      CHARACTER*4 IHARG
4116      CHARACTER*4 IHARG2
4117      CHARACTER*4 IARGT
4118C
4119      DIMENSION IHARG(1)
4120      DIMENSION IHARG2(1)
4121      DIMENSION IARGT(1)
4122      DIMENSION IARG(1)
4123      DIMENSION ARG(1)
4124C
4125      PARAMETER (MAXRLI=MAXSTR)
4126      INTEGER IADE(MAXRLI)
4127C
4128C-----COMMON VARIABLES (GENERAL)--------------------------------------
4129C
4130      INCLUDE 'DPCOP2.INC'
4131C
4132C-----START POINT-----------------------------------------------------
4133C
4134      ISUBN1='DPGE'
4135      ISUBN2='TC  '
4136C
4137      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC')THEN
4138         WRITE(ICOUT,999)
4139  999    FORMAT(1X)
4140         CALL DPWRST('XXX','BUG ')
4141         WRITE(ICOUT,51)
4142   51    FORMAT('***** AT THE BEGINNING OF DPGETC--')
4143         CALL DPWRST('XXX','BUG ')
4144         WRITE(ICOUT,52)IOUNI0,MAXWID,IWIDSV,ITERCH,IHOST1,TCMENU
4145   52    FORMAT('IOUNI0,MAXWID,IWIDSV,ITERCH,IHOST1,TCMENU = ',
4146     1          3I8,3(2X,A4))
4147         CALL DPWRST('XXX','BUG ')
4148         IF(IWIDSV.GE.1)THEN
4149           WRITE(ICOUT,56)(IANSV(I),I=1,MIN(100,IWIDSV))
4150   56      FORMAT('(IANSV(I),I=1,IWIDSV) = ',100A1)
4151           CALL DPWRST('XXX','BUG ')
4152         ENDIF
4153         WRITE(ICOUT,60)IREPST,IREPPO,IREPMX,IPOINT
4154   60    FORMAT('IREPST,IREPPO,IREPMX,IPOINT = ',A4,3I8)
4155         CALL DPWRST('XXX','BUG ')
4156         DO62J=1,MIN(20,IREPMX)
4157            WRITE(ICOUT,63)J,(IANSSV(J,I),I=1,80)
4158   63       FORMAT('J,(IANSSV(J,I),I=1,80) = ',I8,2X,80A1)
4159            CALL DPWRST('XXX','BUG ')
4160   62    CONTINUE
4161         WRITE(ICOUT,64)ICAPSW,IPR,IPRDEF,IRD
4162   64    FORMAT('ICAPSW,IPR,IPRDEF,IRD = ',A4,3I8)
4163         CALL DPWRST('XXX','BUG ')
4164C
4165         WRITE(ICOUT,69)IBUGS2,IFOUND,IERROR
4166   69    FORMAT('IBUGS2,IFOUND,IERROR = ',2(A4,2X),A4)
4167         CALL DPWRST('XXX','BUG ')
4168         WRITE(ICOUT,77)(IA(I),I=1,10)
4169   77    FORMAT('IA(.) = ',10A4)
4170         CALL DPWRST('XXX','BUG ')
4171         WRITE(ICOUT,78)IWIDTH,NUMCHA,ICLILN
4172   78    FORMAT('IWIDTH,NUMCHA,ICLILN = ',3I8)
4173         CALL DPWRST('XXX','BUG ')
4174         WRITE(ICOUT,79)(IANS(I),I=1,MIN(120,IWIDTH))
4175   79    FORMAT('IANS(.) = ',120A1)
4176         CALL DPWRST('XXX','BUG ')
4177         WRITE(ICOUT,80)(IANSLC(I),I=1,MIN(120,IWIDTH))
4178   80    FORMAT('IANSLC(.) = ',120A1)
4179         CALL DPWRST('XXX','BUG ')
4180         WRITE(ICOUT,81)IMACRO,IMACNU,IMACCS
4181   81    FORMAT('IMACRO,IMACNU,IMACCS = ',A4,I8,2X,A12)
4182         CALL DPWRST('XXX','BUG ')
4183         WRITE(ICOUT,82)IMACL1,IMACL2,IMACLR
4184   82    FORMAT(1H ,'IMACL1,IMACL2,IMACLR = ',3I8)
4185         CALL DPWRST('XXX','BUG ')
4186         WRITE(ICOUT,84)IPRONU,IPRONA
4187   84    FORMAT('IPRONU,IPRONA = ',I8,2X,A80)
4188         CALL DPWRST('XXX','BUG ')
4189         WRITE(ICOUT,85)ICRENU,ICRENA
4190   85    FORMAT('ICRENU,IPRONA = ',I8,2X,A80)
4191         CALL DPWRST('XXX','BUG ')
4192         WRITE(ICOUT,86)IPROSW,IPROGR,IPRONU
4193   86    FORMAT('IPROSW,IPROGR,IPRONU = ',A4,2X,A4,I8)
4194         CALL DPWRST('XXX','BUG ')
4195         WRITE(ICOUT,87)ICONCL,ICONNU,IEOF,IIFSW
4196   87    FORMAT('ICONCL,ICONNU,IEOF,IIFSW = ',A4,I8,2(2X,A4))
4197         CALL DPWRST('XXX','BUG ')
4198         WRITE(ICOUT,89)IREPCH,ILOOST,ICLIFL,ICLILO
4199   89    FORMAT('IREPCH,ILOOST,ICLIFL,ICLILO = ',A1,3(2X,A4))
4200         CALL DPWRST('XXX','BUG ')
4201      ENDIF
4202C
4203      NCCNT=0
4204      DO91I=4,1,-1
4205        IF(ICONCH(I:I).NE.' ')THEN
4206          NCCNT=I
4207          GOTO92
4208        ENDIF
4209   91 CONTINUE
4210   92 CONTINUE
4211C
4212      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC')THEN
4213        WRITE(ICOUT,93)NCCNT
4214   93   FORMAT('NUMBER OF CHARACTERS IN CONTINUE CHARACTER = ',I4)
4215        CALL DPWRST('XXX','BUG ')
4216        WRITE(ICOUT,94)(ICONCH(J:J),J=1,4)
4217   94   FORMAT('ICONCH(1:1)=',A1,'ICONCH(2:2)=',A1,'ICONCH(3:3)=',A1,
4218     1         'ICONCH(4:4)=',A1)
4219        CALL DPWRST('XXX','BUG ')
4220      ENDIF
4221C
4222C               **************************************
4223C               **  STEP 1--                        **
4224C               **  COPY THE INPUT VARIABLE IOUNI0  **
4225C               **  INTO THE LOCAL VARIABLE IOUNIT  **
4226C               **************************************
4227C
4228      ISTEPN='1'
4229      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC')
4230     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4231C
4232      IOUNIT=IOUNI0
4233      DO101I=1,MAXSTR
4234        IANS(I)=' '
4235        IANSLC(I)=' '
4236  101 CONTINUE
4237C
4238C
4239C               *********************************************************
4240C               **  STEP 1B--                                          **
4241C               **  GET A NEW FULL COMMAND LINE INTO IANSLC(.) BY      **
4242C               **  EITHER USING THE SAVED LINE (IF ANY) IN IANSV(.),  **
4243C               **  OR BY READING IN A COMPLETELY NEW LINE             **
4244C               **  FROM THE STANDARD INPUT UNIT.                      **
4245C               **  FOR SAVED LINE, REMOVE NON-PRINTING CHARACTERS     **
4246C               **  AND CONVERT TO UPPER CASE.                         **
4247C               *********************************************************
4248C
4249      ISTEPN='1B'
4250      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC')
4251     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4252C
4253      IF(IWIDSV.GT.0)THEN
4254        DO1020I=1,IWIDSV
4255          IANSLC(I)=IANSV(I)
4256 1020   CONTINUE
4257        IWIDTH=IWIDSV
4258        GOTO2100
4259      ENDIF
4260C
4261C               *******************************************
4262C               **  STEP 1C--                            **
4263C               **  CHECK TO SEE IF HAVE REPLOT COMMAND  **
4264C               *******************************************
4265C
4266      IF(IPLTST.EQ.'ON')THEN
4267C
4268        ISTEPN='1C'
4269        IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC')
4270     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4271C
4272        DO1060I=1,MAXSTR
4273          IANSLC(I)=IPLTSV(IPLTPO,I)
4274 1060   CONTINUE
4275C
4276        DO1080I=MAXSTR,1,-1
4277          IWIDTH=I
4278          IF(IANSLC(I).NE.'    ')GOTO1089
4279 1080   CONTINUE
4280 1089   CONTINUE
4281C
4282        GOTO2100
4283      ENDIF
4284C
4285C               *******************************************
4286C               **  STEP 11--                            **
4287C               **  CHECK TO SEE IF REPEATING A COMMAND  **
4288C               *******************************************
4289C
4290      IF(IREPST.EQ.'ON')THEN
4291C
4292        ISTEPN='11'
4293        IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC')
4294     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4295C
4296        DO1110I=1,MAXSTR
4297          IANSLC(I)=IANSSV(IREPPO,I)
4298 1110   CONTINUE
4299C
4300        IWIDTH=MAXSTR
4301C
4302        IF(NCCNT.GE.1)THEN
4303C
4304 1119     CONTINUE
4305C
4306          DO1120I=1,MAXSTR-NCCNT+1
4307            DO1125J=1,NCCNT
4308              K=I+J-1
4309              IF(IANSLC(K).NE.ICONCH(J:J))GOTO1120
4310 1125       CONTINUE
4311C
4312C           GET NEXT LINE
4313C
4314            IREPPO=IREPPO+1
4315            IF(IREPPO.GT.MAXLIS)IREPPO=1
4316            K=0
4317            IFIRST=I
4318            IWIDTH=IFIRST+MAXSTR-1
4319            IF(IWIDTH.GT.MAXSTR)IWIDTH=MAXSTR
4320            DO1130J=IFIRST,IWIDTH
4321              IF(J.GT.MAXSTR)THEN
4322                WRITE(ICOUT,1131)
4323 1131           FORMAT('***** WARNING FROM READ LINE--')
4324                CALL DPWRST('XXX','BUG ')
4325                WRITE(ICOUT,1133)
4326 1133           FORMAT('      MAXIMUM LINE LENGTH EXCEEDED, REST OF ',
4327     1                 'LINE WILL BE IGNORED.')
4328                CALL DPWRST('XXX','BUG ')
4329                GOTO1180
4330              ENDIF
4331              K=K+1
4332              IANSLC(J)=IANSSV(IREPPO,K)
4333 1130       CONTINUE
4334            GOTO1119
4335C
4336 1120     CONTINUE
4337        ENDIF
4338C
4339 1180   CONTINUE
4340        DO1185I=MAXSTR,1,-1
4341          IWIDTH=I
4342          IF(IANSLC(I).NE.'    ')GOTO1189
4343 1185   CONTINUE
4344 1189   CONTINUE
4345C
4346        GOTO2100
4347      ENDIF
4348C
4349C               *****************************************************
4350C               **  STEP 13--                                      **
4351C               **  CHECK TO SEE IF READING FROM THE PROGRAM FILE  **
4352C               **  OR FROM A MACRO FILE                           **
4353C               *****************************************************
4354C
4355      IF(IPROGR.EQ.'EXEC' .OR. IMACRO.EQ.'EXEC')THEN
4356C
4357        ISTEPN='13'
4358        IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC')
4359     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4360C
4361        ISUBN0='GETC'
4362        IERRFI='NO'
4363C
4364        IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC')THEN
4365          WRITE(ICOUT,1311)IOUNIT,ISUBN0,IERRFI
4366 1311     FORMAT('IOUNIT,ISUBN0,IERRFI = ',I8,2X,A4,2X,A4)
4367          CALL DPWRST('XXX','BUG ')
4368          WRITE(ICOUT,1313)IFILE
4369 1313     FORMAT('IFILE = ',A80)
4370          CALL DPWRST('XXX','BUG ')
4371          WRITE(ICOUT,1315)ISTAT,IFORM,IACCES,IPROT,ICURST
4372 1315     FORMAT('ISTAT,IFORM,IACCES,IPROT,ICURST = ',
4373     1           A12,2X,A12,2X,A12,2X,A12,2X,A12)
4374          CALL DPWRST('XXX','BUG ')
4375          WRITE(ICOUT,1317)
4376 1317     FORMAT('***** A LINE FROM THE PROGRAM FILE SHOULD BE ',
4377     1           'READ IN AT THIS TIME.')
4378          CALL DPWRST('XXX','BUG ')
4379        ENDIF
4380C
4381C       2014/11: IF CLIPBOARD SWITCH ON, THEN GET NEXT COMMAND
4382C                FROM CLIPBOARD RATHER THAN THE MACRO FILE.
4383C                HOWEVER, ONLY DO THIS FOR A LEVEL ONE MACRO
4384C                (I.E., IF CLIPBOARD COMMAND GIVEN IN A
4385C                SUB-MACRO, IGNORE IT).  DO THIS SO THAT IF
4386C                THE CLIPBOARD COMMAND HAS A "CALL" COMMAND,
4387C                WE WILL READ FROM THE MACRO FILE RATHER THAN
4388C                THE CLIPBOARD.
4389C
4390        IF(ICLIFL.EQ.'ON' .AND. IMALEV.LE.1)GOTO1600
4391C
4392        IF(IMACLR.LT.IMACL2)THEN
4393          NUMCHA=MAXSTR
4394          CALL DPREFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
4395     1                IA,NUMCHA,
4396     1                ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
4397          IMACLR=IMACLR+1
4398          IF(IERROR.EQ.'YES')GOTO9000
4399        ELSE
4400          IA(1)='E'
4401          IA(2)='O'
4402          IA(3)='F'
4403          NUMCHA=3
4404        ENDIF
4405C
4406        IF(NUMCHA.EQ.3.AND.
4407     1    IA(1).EQ.'E'.AND.IA(2).EQ.'O'.AND.IA(3).EQ.'F')THEN
4408          IF(IOUNIT.EQ.IPRONU)IPROGR='EOF'
4409          IF(IOUNIT.EQ.ICONNU)ICONCL='EOF'
4410          IF(IOUNIT.NE.IPRONU.AND.IOUNIT.NE.ICONNU)IMACRO='EOF'
4411          IEOF='YES'
4412        ENDIF
4413C
4414        IWIDTH=NUMCHA
4415        DO1330I=1,NUMCHA
4416          IANSLC(I)=IA(I)(1:1)
4417 1330   CONTINUE
4418C
4419        IF(NCCNT.GE.1)THEN
4420C
4421 1380     CONTINUE
4422C
4423          DO1381I=1,IWIDTH-NCCNT+1
4424            DO1382J=1,NCCNT
4425              K=I+J-1
4426              IATEMP=IANSLC(K)(1:1)
4427              IF(IATEMP.NE.ICONCH(J:J))GOTO1381
4428 1382       CONTINUE
4429C
4430C           GET NEXT LINE
4431C
4432            NUMCHA=MAXSTR
4433            CALL DPREFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
4434     1                  IA,NUMCHA,
4435     1                  ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
4436            IF(IERROR.EQ.'YES')GOTO9000
4437C
4438            IF(NUMCHA.EQ.3.AND.
4439     1        IA(1).EQ.'E'.AND.IA(2).EQ.'O'.AND.IA(3).EQ.'F')THEN
4440              IF(IOUNIT.EQ.IPRONU)IPROGR='EOF'
4441              IF(IOUNIT.EQ.ICONNU)ICONCL='EOF'
4442              IF(IOUNIT.NE.IPRONU.AND.IOUNIT.NE.ICONNU)IMACRO='EOF'
4443              IEOF='YES'
4444            ENDIF
4445C
4446            IFIRST=I
4447            NTEMP=0
4448            DO1388J=NUMCHA,1,-1
4449              NTEMP=J
4450              IF(IA(J).NE.' ')GOTO1387
4451 1388       CONTINUE
4452 1387       CONTINUE
4453            IWIDTH=IFIRST+NTEMP-1
4454            IF(IWIDTH.GT.MAXSTR)IWIDTH=MAXSTR
4455            K=0
4456            DO1383J=IFIRST,IWIDTH
4457              IF(J.GT.MAXSTR)THEN
4458                WRITE(ICOUT,1131)
4459                CALL DPWRST('XXX','BUG ')
4460                WRITE(ICOUT,1133)
4461                CALL DPWRST('XXX','BUG ')
4462                GOTO1389
4463              ENDIF
4464              K=K+1
4465              IANSLC(J)=IA(K)
4466 1383       CONTINUE
4467            GOTO1380
4468 1381     CONTINUE
4469 1389     CONTINUE
4470C
4471        ENDIF
4472        GOTO2100
4473      ENDIF
4474C
4475C               *****************************************************
4476C               **  STEP 15--                                      **
4477C               **  CHECK TO SEE IF READING FROM THE               **
4478C               **  FRONT-END GRAPHICAL USER INTERFACE MENU        **
4479C               *****************************************************
4480C
4481CCCCC THIS CODE IS FOR OLD TURBO C BASED GUI.  SINCE THIS CODE IS
4482CCCCC NO LONGER USED, COMMENT IT OUT.
4483C
4484CCCCC IF(IHOST1.EQ.'IBM-'.AND.TCMENU.EQ.'ON')THEN
4485CCCCC   ISTEPN='15'
4486CCCCC   IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC')
4487CCCCC1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4488C
4489CCCCC   CALL TCGECO(IB,NUMCHA,IBUGS2,ISUBRO)
4490C
4491CCCCC   IF(NUMCHA.GT.0)THEN
4492CCCCC     ISTEPN='15.2'
4493CCCCC     IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC')
4494CCCCC1      CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4495C
4496CCCCC     IWIDTH=NUMCHA
4497CCCCC     DO1580I=1,NUMCHA
4498CCCCC       IANSLC(I)=IB(I:I)
4499C1580     CONTINUE
4500C
4501CCCCC     IF(NCCNT.GT.0)THEN
4502CCCCC       DO1581I=1,IWIDTH-NCCNT+1
4503CCCCC         DO1582J=1,NCCNT
4504CCCCC           K=I+J-1
4505CCCCC           IATEMP=IANSLC(K)
4506CCCCC           IF(IATEMP.NE.ICONCH(J:J))GOTO1581
4507C1582         CONTINUE
4508C
4509CCCCC         ISTEPN='15.3'
4510CCCCC         IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC')
4511CCCCC1          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4512C
4513CCCCC         CALL TCGECO(IB,NUMCHA,IBUGS2,ISUBRO)
4514C
4515CCCCC         ISTEPN='15.4'
4516CCCCC         IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC')
4517CCCCC1          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4518C
4519CCCCC         IFIRST=I
4520CCCCC         NTEMP=0
4521CCCCC         DO1588J=NUMCHA,1,-1
4522CCCCC           NTEMP=J
4523CCCCC           IF(IB(J:J).NE.'    ')GOTO1587
4524C1588         CONTINUE
4525C1587         CONTINUE
4526CCCCC         IWIDTH=IFIRST+NTEMP-15
4527CCCCC         IF(IWIDTH.GT.MAXSTR)IWIDTH=MAXSTR
4528CCCCC         K=0
4529CCCCC         DO1583J=IFIRST,IWIDTH
4530CCCCC           K=K+1
4531CCCCC           IANSLC(J)=IB(K:K)
4532C1583         CONTINUE
4533CCCCC         GOTO1589
4534C1581       CONTINUE
4535C1589       CONTINUE
4536CCCCC     ENDIF
4537C
4538CCCCC     ISTEPN='15.5'
4539CCCCC     IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC')
4540CCCCC1      CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4541C
4542CCCCC   ENDIF
4543C
4544CCCCC   CALL DPNONP(IANSLC,IWIDTH,IANSLC,IBUGS2,ISUBRO,IERROR)
4545CCCCC   CALL DPUPPE(IANSLC,IWIDTH,IANS,IBUGS2,IERROR)
4546C
4547CCCCC   ISTEPN='15.6'
4548CCCCC   IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC')
4549CCCCC1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4550CCCCC   GOTO2100
4551C
4552CCCCC ENDIF
4553C
4554C               *****************************************************
4555C               **  STEP 16--                                      **
4556C               **  IF NOT READING FROM THE PROGRAM FILE, AND      **
4557C               **  IF NOT READING FROM A MACRO FILE, AND          **
4558C               **  IF NOT READING FROM A FRONT-END GUI MENU,      **
4559C               **  THEN READ FROM THE STANDARD INPUT FILE.        **
4560C               **  (IF CALLED FOR, WRITE OUT A PROMPT (>) FIRST.  **
4561C               *****************************************************
4562C
4563CCCCC FEBRUARY 1998 UPDATE.  FOR TCL/TK GUI, WINDOWS 95 VERSION
4564CCCCC NEEDS SPECIAL HANDLING.  THIS IS CONTROLLED BY ENVIRONMENT
4565CCCCC VARIABLE "DATAPLOT_GUI_IO".  IF EQUAL TO PIPE, DO STANDARD
4566CCCCC READ AS BEFORE.  HOWEVER, IF "FILE", THEN SPECIAL CODE.
4567C
4568CCCCC APRIL 2009: OPTIONALLY USE THE GNU READLINE LIBRARY FOR UNIX
4569CCCCC SYSTEMS (THIS ALLOWS COMMAND LINE EDITING, HISTORY RECALL).
4570C
4571CCCCC NOVEMBER 2014: OPTION FOR READING FROM CLIPBOARD.
4572C
4573 1600 CONTINUE
4574C
4575      ISTEPN='16'
4576      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC')
4577     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4578C
4579      IF(ICLILO.EQ.'ON')THEN
4580C
4581C       IF CLIPBOARD LOOP IS ON:
4582C
4583C          1. IF CLIPBOARD IS CURRENTLY ACTIVE, THEN
4584C             GET COMMANDS FROM CLIPBOARD.
4585C
4586C          2. IF CLIPBOARD IS CURRENTLY NOT ACTIVE, THEN
4587C             PAUSE AND CHECK IF ANYTHING IS IN CLIPBOARD.
4588C
4589C          3. IF CLIPBOARD IS EMPTY, RESTART PROCESS.  IF
4590C             CLIPBOARD IS NOT EMPTY, THEN SET ICLIFL TO ON
4591C             AND BEGIN PROCESSING.
4592C
4593        IF(ICLIFL.EQ.'ON')GOTO1609
4594        IF(ICLIFL.EQ.'PAUS')GOTO9000
4595C
4596        ICLIL2=ICLIL2+1
4597        IF(ICLIL2.GT.ICLILL)THEN
4598          ICLIL2=0
4599          ICLILO='OFF'
4600          GOTO9000
4601        ENDIF
4602C
4603        IF(PCLIDE.GT.0.0)THEN
4604          CALL DPSLE2(PCLIDE,IBUGS2,ISUBRO,IERROR)
4605        ENDIF
4606C
4607C       INTEROGATE CLIPBOARD
4608C
4609        ISTRZZ=' '
4610        IRTYPE='COMM'
4611        MAXVAL=1
4612        NUMETT=0
4613        ISKIPT=0
4614        MAXRDV=100
4615        CALL DPCLIP(XJUNK,MAXVAL,NPTS,NUMETT,NUMVLN,PREAMV,ISKIPT,
4616     1              IGRPAU,
4617     1              IVLIST,IVLIS2,IAVANM,MAXRDV,
4618     1              IRTYPE,ISTRZZ,NCSTR,IEOFFL,
4619     1              IBUGS2,ISUBRO,IERROR)
4620C
4621C       IF CLIPBOARD EMPTY, THEN JUST CONTINUE INTEROGATION.
4622C
4623        IF(IEOFFL.EQ.1)THEN
4624          GOTO1600
4625        ELSE
4626          ICLILO='CLIP'
4627          ICLIFL='ON'
4628          ICLILN=0
4629          GOTO1608
4630        ENDIF
4631      ENDIF
4632C
4633 1608 CONTINUE
4634C
4635      IF(ICLIFL.EQ.'ON')THEN
4636        ISTRZZ=' '
4637        IRTYPE='COMM'
4638        MAXVAL=1
4639        NUMETT=0
4640        ICLILN=ICLILN+1
4641        ISKIPT=ICLILN-1
4642        MAXRDV=100
4643        CALL DPCLIP(XJUNK,MAXVAL,NPTS,NUMETT,NUMVLN,PREAMV,ISKIPT,
4644     1              IGRPAU,
4645     1              IVLIST,IVLIS2,IAVANM,MAXRDV,
4646     1              IRTYPE,ISTRZZ,NCSTR,IEOFFL,
4647     1              IBUGS2,ISUBRO,IERROR)
4648C
4649C       END OF CLIPBOARD
4650C
4651        IF(IEOFFL.EQ.1)THEN
4652          IF(ILOOST.EQ.'PAUS')ILOOST='EXEC'
4653          ICLIFL='OFF'
4654          ICLILN=0
4655          IF(ICLIRC.EQ.'ON')THEN
4656            CALL DPCLI3(IBUGS2,ISUBRO,IERROR)
4657          ENDIF
4658          IF(ICLILO.EQ.'CLIP')THEN
4659            ICLILO='ON'
4660            GOTO1600
4661          ENDIF
4662          IF(IPROGR.EQ.'EXEC' .OR. IMACRO.EQ.'EXEC')THEN
4663            GOTO9000
4664          ELSEIF(ILOOST.EQ.'EXEC' .OR. ILOOST.EQ.'PAUS')THEN
4665            GOTO9000
4666          ELSE
4667            GOTO1600
4668          ENDIF
4669C
4670C       BLANK LINE (IGNORE, GET NEXT COMMAND IN CLIPBOARD)
4671C
4672        ELSEIF(NCSTR.LE.0 .OR.
4673     1    (NCSTR.EQ.4 .AND. ISTRZZ(1:4).EQ.'NULL'))THEN
4674            GOTO1600
4675        ELSE
4676          IWIDTH=NCSTR
4677          DO1603II=1,IWIDTH
4678            IANSLC(II)(1:1)=ISTRZZ(II:II)
4679 1603     CONTINUE
4680          GOTO2100
4681        ENDIF
4682      ELSEIF(IREALI.EQ.'ON')THEN
4683C
4684        IFRST=0
4685 1619   CONTINUE
4686C
4687#ifdef HAVE_READLINE
4688        DO1620KK=1,MAXRLI
4689          IADE(KK)=0
4690 1620   CONTINUE
4691        IWIDTH=0
4692        CALL RLDP(IWIDTH,IERRFL,IADE)
4693#endif
4694        IF(IERRFL.EQ.-99)THEN
4695          IREALI='OFF'
4696          GOTO1609
4697        ELSEIF(IERRFL.GT.0)THEN
4698          WRITE(ICOUT,1611)
4699 1611     FORMAT('***** ERROR FROM READLINE--')
4700          CALL DPWRST('XXX','BUG ')
4701          WRITE(ICOUT,1613)
4702 1613     FORMAT('      WILL READ FROM TERMINAL WITHOUT USING ',
4703     1           'READLINE.')
4704          CALL DPWRST('XXX','BUG ')
4705          GOTO1609
4706        ELSE
4707          IF(IWIDTH.GT.0)THEN
4708            DO1616JJ=1,IWIDTH
4709              IFRST=IFRST+1
4710C
4711              IF(IFRST.GT.MAXSTR)THEN
4712                WRITE(ICOUT,1131)
4713                CALL DPWRST('XXX','BUG ')
4714                WRITE(ICOUT,1133)
4715                CALL DPWRST('XXX','BUG ')
4716                GOTO1629
4717              ENDIF
4718C
4719              IF(IADE(JJ).GT.MAXRLI .OR. IADE(JJ).LT.0)THEN
4720                IANSLC(IFRST)=' '
4721              ELSE
4722                CALL DPCONA(IADE(JJ),IATEMP)
4723                IANSLC(IFRST)=IATEMP
4724              ENDIF
4725 1616       CONTINUE
4726          ENDIF
4727C
4728          IF(IWIDTH.LT.NCCNT)GOTO1629
4729          DO1621I=1,IFRST-NCCNT+1
4730            DO1622J=1,NCCNT
4731              K=I+J-1
4732              IF(IANSLC(K).NE.ICONCH(J:J))GOTO1621
4733 1622       CONTINUE
4734C
4735C           GET NEXT LINE
4736C
4737            IFRST=I-1
4738            GOTO1619
4739 1621     CONTINUE
4740 1629     CONTINUE
4741          IWIDTH=IFRST
4742          GOTO2100
4743        ENDIF
4744      ENDIF
4745C
4746 1609 CONTINUE
4747C
4748      IF(IPROSW.EQ.'ON'.AND.IOUNIT.EQ.IRD)THEN
4749        IF(IHOST1.EQ.'IBM-'.AND.ICOMPI.EQ.'LAHE')THEN
4750          WRITE(IPRDEF,1630)ICRC,ILFC
4751 1630     FORMAT(1X,'>',A1,A1)
4752        ELSEIF(IHOST1.EQ.'IBM-'.AND.ICOMPI.EQ.'MS-F')THEN
4753          IF(IRD.EQ.I1MACH(1))THEN
4754            IFLAG=1
4755            CALL DPPRMP(IPRDEF,IFLAG)
4756          ENDIF
4757        ELSE
4758          IFLAG=0
4759          IF(IHOST1.EQ.'VAX')IFLAG=1
4760          IF(IPROAD.EQ.'ON')IFLAG=2
4761          CALL DPPRMP(IPRDEF,IFLAG)
4762        ENDIF
4763      ENDIF
4764C
4765      CALL DPFLSH(IPR,IBUGS2,ISUBRO,IFOUND,IERROR)
4766C
4767      IF(IGUIIO.NE.'FILE')THEN
4768C
4769C       IF USER HAS RESET STANDARD INPUT TO A FILE, THEN NEED
4770C       CHECK FOR END OF FILE (I.E., RESET STANDARD INPUT TO
4771C       TERMINAL IF END OF FILE DETECTED).
4772C
4773 1631   CONTINUE
4774        IFORMT='(    A1)'
4775        WRITE(IFORMT(2:5),'(I4)')MAXSTR
4776        IF(IOUNIT.EQ.IRD .AND. IRD.NE.I1MACH(1))THEN
4777          READ(IOUNIT,IFORMT,END=1633)(IANSLC(I),I=1,MAXSTR)
4778          GOTO1634
4779C
4780 1633     CONTINUE
4781          CLOSE(IOUNIT)
4782          IRD=I1MACH(1)
4783          IOUNIT=IRD
4784          GOTO1631
4785C
4786        ELSE
4787          READ(IOUNIT,IFORMT,END=1680)(IANSLC(I),I=1,MAXSTR)
4788        ENDIF
4789C1632   FORMAT(255A1)
4790 1634   CONTINUE
4791        IWIDTH=MAXSTR
4792C
4793        IF(NCCNT.GT.0)THEN
4794          IFORMT='(    A1)'
4795          WRITE(IFORMT(2:5),'(I4)')MAXSTR
4796C
4797 1639     CONTINUE
4798C
4799          DO1641I=1,MAXSTR-NCCNT+1
4800            DO1642J=1,NCCNT
4801              K=I+J-1
4802              IF(IANSLC(K).NE.ICONCH(J:J))GOTO1641
4803 1642       CONTINUE
4804C
4805C           GET NEXT LINE
4806C
4807            IFIRST=I
4808C
4809            IF(IFIRST.GT.MAXSTR)THEN
4810              WRITE(ICOUT,1131)
4811              CALL DPWRST('XXX','BUG ')
4812              WRITE(ICOUT,1133)
4813              CALL DPWRST('XXX','BUG ')
4814              GOTO1640
4815            ENDIF
4816C
4817            IWIDTH=IFIRST+MAXSTR-1
4818            IF(IWIDTH.GT.MAXSTR)IWIDTH=MAXSTR
4819            READ(IOUNIT,IFORMT,END=1680)(IANSLC(J),J=IFIRST,IWIDTH)
4820            GOTO1639
4821 1641     CONTINUE
4822 1640     CONTINUE
4823        ENDIF
4824C
4825      ELSE
4826C
4827        IFORMT='(    A1)'
4828        WRITE(IFORMT(2:5),'(I4)')MAXSTR
4829        IOTEMP=10
4830        DO16210KK=1,1
483116290     CONTINUE
4832          OPEN(UNIT=IOTEMP,FILE='fort.10',FORM='FORMATTED',
4833     1         STATUS='OLD',ERR=16291)
4834          REWIND(IOTEMP)
4835          READ(IOTEMP,IFORMT,END=16210)(IANSLC(I),I=1,MAXSTR)
4836          CLOSE(IOTEMP,STATUS='DELETE')
4837          IWIDTH=MAXSTR
4838          GOTO16210
4839C
484016291     CONTINUE
4841          IHARG(1)='1.0'
4842          IHARG2(1)=' '
4843          IARGT(1)='NUMB'
4844          ARG(1)=1.0
4845          IARG(1)=1
4846          NUMARG=1
4847          CALL DPSLEE(IHARG,IHARG2,IARGT,IARG,ARG,NUMARG,
4848     1                IBUGS2,ISUBRO,IFOUND,IERROR)
4849          GOTO16290
4850C
485116210   CONTINUE
4852      ENDIF
4853C
4854      ISTEPN='16.1'
4855      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC')
4856     1   CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4857C
4858      GOTO2100
4859C
4860 1680 CONTINUE
4861      IF(IHOST1.EQ.'CDC')THEN
4862        ICURST='OPEN'
4863        IENDFI='OFF'
4864        IREWIN='OFF'
4865        ISUBN0='GETC'
4866        CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
4867     1              IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
4868        ICURST='CLOSED'
4869        IREWIN='OFF'
4870        ISUBN0='GETC'
4871        CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
4872     1              IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
4873      ENDIF
4874C
4875      GOTO2100
4876C
4877C               ******************************************************
4878C               **  STEP 21--                                       **
4879C               **  DETERMINE IF IANSLC(.) CONSISTS OF MULTIPLE     **
4880C               **  COMMAND STATEMENTS (AS IS POSSIBLE BY THE       **
4881C               **  USE OF SEPARATOR CHARACTERS IN THE TEXT),       **
4882C               **  IF SO, THEN UPDATE IANSLC(.), IWIDTH,           **
4883C               **  IANSV(.), AND IWIDSV BY TRUNCATING              **
4884C               **  IANSLC(.) AT THE FIRST SEPARATION CHARACTER,    **
4885C               **  AND COPYING THE REST OF IANSLC(.) INTO IANSV(.) *
4886C               ******************************************************
4887C
4888 2100 CONTINUE
4889C
4890      ISTEPN='21'
4891      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC')THEN
4892        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4893        WRITE(ICOUT,2101)IWIDTH
4894 2101   FORMAT('FROM 2100, IWIDTH =',I4)
4895        CALL DPWRST('XXX','BUG ')
4896        DO2110II=1,IWIDTH
4897          WRITE(ICOUT,2111)II,IANSLC(II)
4898 2111     FORMAT('II,IANSLC(II) = ',I4,2X,A4)
4899          CALL DPWRST('XXX','BUG ')
4900 2110   CONTINUE
4901      ENDIF
4902C
4903      CALL DPNONP(IANSLC,IWIDTH,IANSLC,IBUGS2,ISUBRO,IERROR)
4904      CALL DPUPPE(IANSLC,IWIDTH,IANS,IBUGS2,IERROR)
4905      CALL DPSPLC(IANSLC,IWIDTH,ITERCH,
4906     1            IANSV,IWIDSV,IBUGS2,IERROR)
4907C
4908C               *******************************************************
4909C               **  STEP 23--                                        **
4910C               **  SCAN THE ENTIRE STRING--                         **
4911C               **  SEARCH FOR THE SUBSTITUTION-VALUE CHARACTER.     **
4912C               **  IF FOUND (AND IF WE ARE NOT IN THE MIDDLE OF     **
4913C               **  STORING THE BODY OF A LOOP),                     **
4914C               **  THEN FORM A NEW STRING BY SUBSTITUTING           **
4915C               **  THE VALUE OF THE IMMEDIATELY SUCCEEDING VARIABLE **
4916C               **  IF NOT FOUND (OR IF WE ARE IN THE MIDDLE OF      **
4917C               **  STORING THE BODY OF A LOOP),                     **
4918C               **  THEN DO NOTHING.                                 **
4919C               **  FINALLY (AND IN ALL CASES) CONVERT TO UPPER CASE **
4920C               *******************************************************
4921C
4922      ISTEPN='23'
4923      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC')
4924     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4925C
4926      IF(ILOOST.NE.'STOR')THEN
4927        IF(IIFSW.EQ.'TRUE'.AND.IANSLC(1).NE.'.')THEN
4928          CALL DPREP2(IANSLC,IWIDTH,
4929     1                IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,
4930     1                IVARLB,IROWLB,MAXOBV,
4931     1                IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,IMALEV,
4932     1                IBUGS2,ISUBRO,IERROR)
4933        ENDIF
4934      ENDIF
4935      CALL DPNONP(IANSLC,IWIDTH,IANSLC,IBUGS2,ISUBRO,IERROR)
4936      CALL DPUPPE(IANSLC,IWIDTH,IANS,IBUGS2,IERROR)
4937C
4938CCCCC IF AUTO TEXT ON, THE PREPEND "TEXT" TO COMMAND LINE.  BUT
4939CCCCC CHECK TO SEE IF "AUTO TEXT" COMMAND IS BEING ENTERED.
4940C
4941      IF(IATXSW.EQ.'ON')THEN
4942        IF(IANS(1).EQ.'A'.AND.IANS(2).EQ.'U'.AND.IANS(3).EQ.'T'.AND.
4943     1    IANS(4).EQ.'O'.AND.IANS(5).EQ.' '.AND.IANS(6).EQ.'T'.AND.
4944     1    IANS(7).EQ.'E'.AND.IANS(8).EQ.'X'.AND.IANS(9).EQ.'T')
4945     1    GOTO2109
4946          DO2105I=MIN(IWIDTH,MAXWID-4),1,-1
4947            IANSLC(I+5)=IANSLC(I)
4948            IANS(I+5)=IANS(I)
4949 2105     CONTINUE
4950          IANSLC(1)='T'
4951          IANSLC(2)='E'
4952          IANSLC(3)='X'
4953          IANSLC(4)='T'
4954          IANSLC(5)=' '
4955          IANS(1)='T'
4956          IANS(2)='E'
4957          IANS(3)='X'
4958          IANS(4)='T'
4959          IANS(5)=' '
4960          IWIDTH=MIN(MAXWID,IWIDTH+5)
4961 2109   CONTINUE
4962      ENDIF
4963C
4964C
4965C               ******************************************************
4966C               **  STEP 80--                                       **
4967C               **  STORE THE LINE IN THE SAVE TABLE, FOR FUTURE    **
4968C               **  USE BY THE REPEAT COMMAND.  NOTE--              **
4969C               **  CERTAIN COMMANDS ARE NOT TO BE STORED, NAMELY-- **
4970C               **     LIST (AND L AND RECALL)                      **
4971C               **     REPEAT (AND R)                               **
4972C               **     SAVE (AND S)                                 **
4973C               **     SPACE BAR COMMAND (CHANGED TO / TEMPORARILY) **
4974C               **     CARRIAGE RETURN ONLY (= NO-OP COMMAND)       **
4975C               **     GUI STATUS                                   **
4976C               **     GUI WRITE/PRINT                              **
4977C               **     BASICALLY, ANY COMMAND                       **
4978C               **     STARTING WITH "GUI"                          **
4979C               ******************************************************
4980C
4981      ISTEPN='80'
4982      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC')THEN
4983        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4984        WRITE(ICOUT,8001)IANS(1),IANS(2),IWIDTH
4985 8001   FORMAT('IANS(1),IANS(2),IWIDTH = ',A4,2X,A4,I8)
4986        CALL DPWRST('XXX','BUG ')
4987      ENDIF
4988C
4989      IF(IREPST.EQ.'ON')GOTO8190
4990C
4991      IF(IANS(1).EQ.'L'.AND.IANS(2).EQ.'I'.AND.
4992     1IANS(3).EQ.'S'.AND.IANS(4).EQ.'T'.AND.IWIDTH.LE.5)GOTO8190
4993      IF(IANS(1).EQ.'L'.AND.IANS(2).EQ.' ')GOTO8190
4994      IF(IANS(1).EQ.'L'.AND.IWIDTH.LE.1)GOTO8190
4995      IF(IANS(1).EQ.'R'.AND.IANS(2).EQ.'E'.AND.
4996     1IANS(3).EQ.'C'.AND.IANS(4).EQ.'A')GOTO8190
4997C
4998      IF(IANS(1).EQ.'R'.AND.IANS(2).EQ.'E'.AND.
4999     1IANS(3).EQ.'P'.AND.IANS(4).EQ.'E')GOTO8190
5000      IF(IANS(1).EQ.'R'.AND.IANS(2).EQ.' ')GOTO8190
5001      IF(IANS(1).EQ.'R'.AND.IWIDTH.LE.1)GOTO8190
5002C
5003      IF(IANS(1).EQ.'S'.AND.IANS(2).EQ.'A'.AND.
5004     1   IANS(3).EQ.'V'.AND.IANS(4).EQ.'E')GOTO8190
5005      IF(IANS(1).EQ.'S'.AND.IANS(2).EQ.' ')GOTO8190
5006      IF(IANS(1).EQ.'S'.AND.IWIDTH.LE.1)GOTO8190
5007C
5008      IF(IANS(1).EQ.'G'.AND.IANS(2).EQ.'U'.AND.
5009     1   IANS(3).EQ.'I'.AND.IANS(4).EQ.' ')GOTO8190
5010      IF(IANS(1).EQ.'/'.AND.IWIDTH.LE.1)THEN
5011         IPOINT=IPOINT-1
5012         IF(IPOINT.LE.0)IPOINT=IREPMX
5013         GOTO8190
5014      ENDIF
5015      IF(IANS(1).EQ.'E'.AND.IANS(2).EQ.'O'.AND.
5016     1   IANS(3).EQ.'F')THEN
5017         IPOINT=IPOINT-1
5018         IF(IPOINT.LE.0)IPOINT=IREPMX
5019         GOTO8190
5020      ENDIF
5021C
5022      IF(IWIDTH.GT.0)THEN
5023C
5024        DO8110I=1,MAXCIS
5025          IANSSV(IPOINT,I)=' '
5026 8110   CONTINUE
5027C
5028        IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC')THEN
5029          WRITE(ICOUT,8030)MAXSTR,IWIDTH,IPOINT
5030 8030     FORMAT('MAXSTR,IWIDTH,IPOINT=',I4,2X,I4,2X,I4)
5031          CALL DPWRST('XXX','BUG ')
5032        ENDIF
5033C
5034        IMAX=IWIDTH
5035        IF(IWIDTH.GT.MAXCIS)IMAX=MAXCIS-4
5036        DO8100I=1,IMAX
5037          IANSSV(IPOINT,I)=IANSLC(I)(1:1)
5038 8100   CONTINUE
5039C
5040C       CASE FOR MORE THAN 80 CHARACTER LINE
5041C
5042        IF(IWIDTH.GT.MAXCIS)THEN
5043          ITEMP=MAXCIS-4
5044          DO8200I=ITEMP+1,MAXCIS
5045            IANSSV(IPOINT,I)=ICONCH(I-ITEMP:I-ITEMP)
5046 8200     CONTINUE
5047C
5048          IPOINT=IPOINT+1
5049          IF(IPOINT.GT.IREPMX)IPOINT=1
5050          ISTART=IMAX
5051          IMAX=IWIDTH-IMAX
5052          IF(IMAX.GT.MAXCIS)IMAX=MAXCIS
5053C
5054          DO8210I=1,MAXCIS
5055            IANSSV(IPOINT,I)=' '
5056 8210     CONTINUE
5057C
5058          DO8220I=1,IMAX
5059            J=ISTART+I
5060            IC4=IANSLC(J)
5061            IANSSV(IPOINT,I)=IC4(1:1)
5062 8220     CONTINUE
5063C
5064        ENDIF
5065      ENDIF
5066C
5067 8190 CONTINUE
5068C
5069CCCCC IF(IHOST1.EQ.'IBM-'.AND.TCMENU.EQ.'ON')THEN
5070CCCCC    DO8230I=1,80
5071CCCCC      STRING(I:I)=IANSSV(IPOINT,I)
5072C8230    CONTINUE
5073CCCCC    CALL TCWRCO(STRING,ISUBRO)
5074CCCCC ENDIF
5075C
5076C               *****************
5077C               **  STEP 90--  **
5078C               **  EXIT.      **
5079C               *****************
5080C
5081 9000 CONTINUE
5082      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC')THEN
5083         WRITE(ICOUT,999)
5084         CALL DPWRST('XXX','BUG ')
5085         WRITE(ICOUT,9011)
5086 9011    FORMAT('***** AT THE END       OF DPGETC--')
5087         CALL DPWRST('XXX','BUG ')
5088         WRITE(ICOUT,9012)IOUNI0,IOUNIT,MAXWID,ITERCH
5089 9012    FORMAT('IOUNI0,IOUNIT,MAXWID,ITERCH = ',3I8,2X,A4)
5090         CALL DPWRST('XXX','BUG ')
5091         WRITE(ICOUT,9013)IHOST1,TCMENU,IWIDTH
5092 9013    FORMAT('IHOST1,TCMENU,IWIDTH = ',A4,2X,A4,I8)
5093         CALL DPWRST('XXX','BUG ')
5094         WRITE(ICOUT,9014)(IANS(I),I=1,MIN(100,IWIDTH))
5095 9014    FORMAT('(IANS(I),I=1,IWIDTH) = ',100A1)
5096         CALL DPWRST('XXX','BUG ')
5097         WRITE(ICOUT,9015)(IANSLC(I),I=1,MIN(100,IWIDTH))
5098 9015    FORMAT('(IANSLC(I),I=1,IWIDTH) = ',100A1)
5099         CALL DPWRST('XXX','BUG ')
5100         WRITE(ICOUT,9016)IWIDSV,NUMCHA
5101 9016    FORMAT('IWIDSV,NUMCHA = ',2I8)
5102         CALL DPWRST('XXX','BUG ')
5103         WRITE(ICOUT,9017)(IANSV(I),I=1,MIN(100,IWIDSV))
5104 9017    FORMAT('(IANSV(I),I=1,IWIDSV) = ',100A1)
5105         CALL DPWRST('XXX','BUG ')
5106         WRITE(ICOUT,9020)IREPST,IREPPO,IREPMX,IPOINT
5107 9020    FORMAT('IREPST,IREPPO,IREPMX,IPOINT = ',A4,3I8)
5108         CALL DPWRST('XXX','BUG ')
5109         DO9022J=1,20
5110            WRITE(ICOUT,9023)J,(IANSSV(J,I),I=1,80)
5111 9023       FORMAT('J,(IANSSV(J,I),I=1,80) = ',I8,2X,80A1)
5112            CALL DPWRST('XXX','BUG ')
5113 9022    CONTINUE
5114         CALL DPWRST('XXX','BUG ')
5115         WRITE(ICOUT,9030)(IA(I),I=1,10)
5116 9030    FORMAT('IA(.) = ',10A4)
5117         CALL DPWRST('XXX','BUG ')
5118         WRITE(ICOUT,9031)IMACRO,IMACNU,IMACCS
5119 9031    FORMAT('IMACRO,IMACNU,IMACCS = ',A4,I8,2X,A12)
5120         CALL DPWRST('XXX','BUG ')
5121         WRITE(ICOUT,9032)IMACL1,IMACL2,IMACLR
5122 9032    FORMAT(1H ,'IMACL1,IMACL2,IMACLR = ',3I8)
5123         CALL DPWRST('XXX','BUG ')
5124         WRITE(ICOUT,9034)IPROGR,IPROSW,IPRONU
5125 9034    FORMAT('IPROGR,IPROSW,IPRONU = ',3(2X,A4))
5126         CALL DPWRST('XXX','BUG ')
5127         WRITE(ICOUT,9039)IBUGS2,IFOUND,IERROR
5128 9039    FORMAT('IBUGS2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
5129         CALL DPWRST('XXX','BUG ')
5130         WRITE(ICOUT,9042)IFILE
5131 9042    FORMAT('IFILE  = ',A80)
5132         CALL DPWRST('XXX','BUG ')
5133         WRITE(ICOUT,9043)ISTAT,IFORM,IACCES,IPROT,ICURST
5134 9043    FORMAT('ISTAT,IFORM,IACCES,IPROT,ICURST  = ',5(2X,A12))
5135         CALL DPWRST('XXX','BUG ')
5136         WRITE(ICOUT,9048)IENDFI,IREWIN,ISUBN0,IERRFI
5137 9048    FORMAT('IENDFI,IREWIN,ISUBN0,IERRFI = ',A4,3(2X,A12))
5138         CALL DPWRST('XXX','BUG ')
5139         WRITE(ICOUT,9062)ICONCL,ICONNU,IEOF,IIFSW
5140 9062    FORMAT('ICONCL,ICONNU,IEOF,IIFSW = ',A4,I8,2X,A4,2X,A4)
5141         CALL DPWRST('XXX','BUG ')
5142         WRITE(ICOUT,9064)IREPCH,ILOOST,IPOINT
5143 9064    FORMAT('IREPCH,ILOOST,IPOINT = ',A1,2X,A4,2X,I8)
5144         CALL DPWRST('XXX','BUG ')
5145         WRITE(ICOUT,9067)(IANSSV(IPOINT,I),I=1,80)
5146 9067    FORMAT('(IANSSV(IPOINT,I),I=1,80) = ',80A1)
5147         CALL DPWRST('XXX','BUG ')
5148      ENDIF
5149C
5150      RETURN
5151      END
5152      SUBROUTINE DPGMEA(NPTS,NLAB,
5153     1XGRAND,SDGRAN,SET1,SET1K1,SET1K2,
5154     1DLOWT2,DHIGT2,
5155     1IWRITE,
5156     1ICAPSW,ICAPTY,NUMDIG,
5157     1ISUBRO,IBUGA3,IERROR)
5158C
5159C     PURPOSE--IMPLEMENT GRAND MEAN APPROACH TO CONSENSUS MEANS
5160C     PRINTING--YES
5161C     SUBROUTINES NEEDED--NONE
5162C     WRITTEN BY--JAMES J. FILLIBEN
5163C                 STATISTICAL ENGINEERING DIVISION
5164C                 INFORMATION TECHNOLOGY LABORATORY
5165C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
5166C                 GAITHERSBURG, MD 20899-8980
5167C                 PHONE--301-975-2899
5168C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
5169C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
5170C     LANGUAGE--ANSI FORTRAN (1977)
5171C     VERSION NUMBER--2006/3
5172C     ORIGINAL VERSION--MARCH     2006. EXTRACTED FROM DPMAN2 ROUTINE
5173C     UPDATED         --OCTOBER   2006. CALL LIST TO TPPF
5174C     UPDATED         --FEBRUARY  2010. USE DPDTA1 TO PRINT
5175C
5176C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES--------------
5177C
5178      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
5179C
5180      CHARACTER*4 ICAPSW
5181      CHARACTER*4 ICAPTY
5182      CHARACTER*4 ISUBRO
5183      CHARACTER*4 IBUGA3
5184      CHARACTER*4 IERROR
5185C
5186      CHARACTER*4 IWRITE
5187      CHARACTER*4 ISUBN1
5188      CHARACTER*4 ISUBN2
5189C
5190      REAL APPF
5191      REAL XGRAND
5192      REAL SDGRAN
5193      REAL SET1
5194      REAL SET1K1
5195      REAL SET1K2
5196C
5197C----------------------------------------------------------------
5198C
5199      INCLUDE 'DPCOST.INC'
5200C
5201      PARAMETER (MAXROW=20)
5202      CHARACTER*60 ITITLE
5203      CHARACTER*60 ITITLZ
5204      CHARACTER*60 ITITL9
5205      CHARACTER*60 ITEXT(MAXROW)
5206      REAL         AVALUE(MAXROW)
5207      INTEGER      NCTEXT(MAXROW)
5208      INTEGER      IDIGIT(MAXROW)
5209      INTEGER      NTOT(MAXROW)
5210      LOGICAL IFRST
5211      LOGICAL ILAST
5212C
5213      INCLUDE 'DPCOP2.INC'
5214C
5215C-----START POINT------------------------------------------------
5216C
5217      IERROR='NO'
5218      ISUBN1='DPGM'
5219      ISUBN2='EA  '
5220C
5221      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GMEA')THEN
5222        WRITE(ICOUT,999)
5223  999   FORMAT(1X)
5224        CALL DPWRST('XXX','BUG ')
5225        WRITE(ICOUT,51)
5226   51   FORMAT('***** AT THE BEGINNING OF DPGMEA--')
5227        CALL DPWRST('XXX','BUG ')
5228        WRITE(ICOUT,52)IWRITE,NPTS,NLAB,XGRAND,SDGRAN
5229   52   FORMAT('IWRITE,NPTS,NLAB,XGRAND,SDGRAN = ',A4,2X,2I8,2G15.7)
5230        CALL DPWRST('XXX','BUG ')
5231      ENDIF
5232C
5233      IDF=NPTS-1
5234CCCC  CALL TPPF(0.975,IDF,APPF)
5235      CALL TPPF(0.975,REAL(IDF),APPF)
5236      DLOWT2=DBLE(XGRAND - APPF*SDGRAN/SQRT(REAL(NPTS)))
5237      DHIGT2=DBLE(XGRAND + APPF*SDGRAN/SQRT(REAL(NPTS)))
5238      SET1=SDGRAN/SQRT(REAL(NPTS))
5239      SET1K1=SET1
5240      SET1K2=2.0*SET1
5241C
5242      IF(IPRINT.EQ.'OFF')GOTO9000
5243C
5244      ITITLE=' '
5245      NCTITL=0
5246      ITITLZ=' '
5247      NCTITZ=0
5248C
5249      ICNT=1
5250      ITEXT(ICNT)=' 8. Method: Grand Mean (No Lab Effect)'
5251      NCTEXT(ICNT)=38
5252      AVALUE(ICNT)=0.0
5253      IDIGIT(ICNT)=-1
5254C
5255      ICNT=ICNT+1
5256      ITEXT(ICNT)='    Mean of All Data:'
5257      NCTEXT(ICNT)=21
5258      AVALUE(ICNT)=XGRAND
5259      IDIGIT(ICNT)=NUMDIG
5260      ICNT=ICNT+1
5261      ITEXT(ICNT)='    Standard Deviation of All Data:'
5262      NCTEXT(ICNT)=35
5263      AVALUE(ICNT)=SDGRAN
5264      IDIGIT(ICNT)=NUMDIG
5265      ICNT=ICNT+1
5266      ITEXT(ICNT)='    SD of Consensus Mean (sd/sqrt(n)):'
5267      NCTEXT(ICNT)=38
5268      AVALUE(ICNT)=SET1
5269      IDIGIT(ICNT)=NUMDIG
5270      ICNT=ICNT+1
5271      ITEXT(ICNT)='    Standard Uncertainty (k = 1):'
5272      NCTEXT(ICNT)=33
5273      AVALUE(ICNT)=SET1
5274      IDIGIT(ICNT)=NUMDIG
5275      ICNT=ICNT+1
5276      ITEXT(ICNT)='    Expanded Uncertainty (k = 2):'
5277      NCTEXT(ICNT)=33
5278      AVALUE(ICNT)=2.0*SET1
5279      IDIGIT(ICNT)=NUMDIG
5280      ICNT=ICNT+1
5281      ITEXT(ICNT)='    Expanded Uncertainty (k =           ):'
5282      WRITE(ITEXT(ICNT)(31:40),'(F10.7)')APPF
5283      NCTEXT(ICNT)=42
5284      AVALUE(ICNT)=APPF*SET1
5285      IDIGIT(ICNT)=NUMDIG
5286      ICNT=ICNT+1
5287      ITEXT(ICNT)='    Degrees of Freedom:'
5288      NCTEXT(ICNT)=23
5289      AVALUE(ICNT)=IDF
5290      IDIGIT(ICNT)=0
5291      ICNT=ICNT+1
5292      ITEXT(ICNT)='    t Percent Point Value (alpha = 0.05)'
5293      NCTEXT(ICNT)=40
5294      AVALUE(ICNT)=APPF
5295      IDIGIT(ICNT)=NUMDIG
5296      ICNT=ICNT+1
5297      ITEXT(ICNT)='    Lower 95% (t-value) Confidence Limit:'
5298      NCTEXT(ICNT)=41
5299      AVALUE(ICNT)=DLOWT2
5300      IDIGIT(ICNT)=NUMDIG
5301      ICNT=ICNT+1
5302      ITEXT(ICNT)='    Upper 95% (t-value) Confidence Limit:'
5303      NCTEXT(ICNT)=41
5304      AVALUE(ICNT)=DHIGT2
5305      IDIGIT(ICNT)=NUMDIG
5306      ICNT=ICNT+1
5307      ITEXT(ICNT)='    Note: Grand Mean Best Usage:'
5308      NCTEXT(ICNT)=32
5309      AVALUE(ICNT)=0.0
5310      IDIGIT(ICNT)=-1
5311      ICNT=ICNT+1
5312      ITEXT(ICNT)='          Any Number of Labs, but no'
5313      NCTEXT(ICNT)=36
5314      AVALUE(ICNT)=0.0
5315      IDIGIT(ICNT)=-1
5316      ICNT=ICNT+1
5317      ITEXT(ICNT)='          Lab-to-Lab Differences'
5318      NCTEXT(ICNT)=32
5319      AVALUE(ICNT)=0.0
5320      IDIGIT(ICNT)=-1
5321C
5322      NUMROW=ICNT
5323      DO310I=1,NUMROW
5324        NTOT(I)=15
5325  310 CONTINUE
5326C
5327      IFRST=.TRUE.
5328      ILAST=.TRUE.
5329      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
5330     1            AVALUE,IDIGIT,
5331     1            NTOT,NUMROW,
5332     1            ICAPSW,ICAPTY,ILAST,IFRST,
5333     1            ISUBRO,IBUGA3,IERROR)
5334      ITITLE=' '
5335      NCTITL=0
5336      ITITLZ=' '
5337      NCTITZ=0
5338      ITITL9=' '
5339      NCTIT9=0
5340C
5341C               *****************
5342C               **  STEP 90--  **
5343C               **  EXIT       **
5344C               *****************
5345C
5346 9000 CONTINUE
5347      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GMEA')THEN
5348        WRITE(ICOUT,999)
5349        CALL DPWRST('XXX','BUG ')
5350        WRITE(ICOUT,9011)
5351 9011   FORMAT('***** AT THE END       OF DPGMEA--')
5352        CALL DPWRST('XXX','BUG ')
5353        WRITE(ICOUT,9012)IERROR
5354 9012   FORMAT('IERROR = ',A4)
5355        CALL DPWRST('XXX','BUG ')
5356        WRITE(ICOUT,9013)NPTS,NLAB
5357 9013   FORMAT('NPTS,NLAB = ',2I8)
5358        CALL DPWRST('XXX','BUG ')
5359        WRITE(ICOUT,9014)SET1
5360 9014   FORMAT('SET1 = ',G15.7)
5361        CALL DPWRST('XXX','BUG ')
5362        WRITE(ICOUT,9015)DLOWT2,DHIGT2
5363 9015   FORMAT('DLOWT2,DHIGT2 = ',2G15.7)
5364        CALL DPWRST('XXX','BUG ')
5365      ENDIF
5366C
5367      RETURN
5368      END
5369      SUBROUTINE DPGOFI(MAXNXT,ICAPSW,IFORSW,ISEED,
5370     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
5371C
5372C     PURPOSE--COMPUTE VARIOUS DISTRIBUTIONAL GOODNESS OF FIT STATISTICS
5373C              (SEE EXTDIS FOR A LIST OF SUPPORTED DISTRIBUTIONS)
5374C
5375C              FOR THE INITIAL IMPLEMENTATION, KOLMOGOROV-SMIRNOV
5376C              AND ANDERSON-DARLING ARE SUPPORTED.  IT IS ANTICIPATED
5377C              THAT ADDITIONAL GOODNESS OF FIT STATISTICS WILL BE
5378C              ADDED IN SUBSEQUENT UPDATES.
5379C
5380C              THIS ROUTINE BASICALLY REPLACES THE "DP1KST"
5381C              ROUTINE.  IT IS MORE GENERAL BOTH IN THE SENSE OF
5382C              INCORPORATING MORE GOODNESS OF FIT TESTS AND IN
5383C              THAT IT ACCOMODATES REPLICATED DATA.  THE STRUCTURE
5384C              CURRENTLY ALLOWS FOR CENSORING/GROUPING IN THE
5385C              DATA, ALTHOUGH THESE ARE NOT ACTUALLY IMPLEMENTED
5386C              IN THE INITIAL IMPLEMENTATION (HOWEVER, IT IS
5387C              ANTICIPATED THAT THEY WILL BE ADDED IN A SUBSEQUENT
5388C              UPDATE).
5389C
5390C     WRITTEN BY--ALAN HECKERT
5391C                 STATISTICAL ENGINEERING DIVISION
5392C                 INFORMATION TECHNOLOGY LABORAOTRY
5393C                 NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY
5394C                 GAITHERSBURG, MD 20899-8980
5395C                 PHONE--301-975-2899
5396C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
5397C           OF THE NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY.
5398C     LANGUAGE--ANSI FORTRAN (1977)
5399C     VERSION NUMBER--2009/9
5400C     ORIGINAL VERSION--SEPTEMBER 2009.
5401C     UPDATED         --OCTOBER   2009. ACTIVATE ANDERSON-DARLING OPTION
5402C     UPDATED         --OCTOBER   2009. ACTIVATE PPCC OPTION
5403C     UPDATED         --DECEMBER  2009. ACTIVATE CHI-SQUARE OPTION
5404C     UPDATED         --MAY       2010. UPDATES FOR PPCC CASE WHEN
5405C                                       THERE ARE SHAPE PARAMETERS
5406C     UPDATED         --SEPTEMBER 2010. SUPPORT A "LEVEL" VARIABLE
5407C                                       FOR BRITTLE FIBER WEIBULL
5408C                                       (MAY ADD TO A FEW OTHERS AT
5409C                                       A LATER TIME).  NOTE THAT THIS
5410C                                       IS CURRENTLY ONLY SUPPORTED
5411C                                       FOR THE SINGLE RESPONSE
5412C                                       VARIABLE RAW DATA CASE
5413C     UPDATED         --AUGUST    2011. MAKE WORD "TEST" OPTIONAL
5414C     UPDATED         --JULY      2019. TWEAK SCRATCH SPACE, DELETE SOME
5415C                                       SCRATCH ARRAYS, ADJUST CALL LIST
5416C                                       TO DPGOF2, DPGOF3
5417C
5418C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
5419C
5420      CHARACTER*4 ICASPL
5421      CHARACTER*4 ICAPSW
5422      CHARACTER*4 IFORSW
5423      CHARACTER*4 IBUGA2
5424      CHARACTER*4 IBUGA3
5425      CHARACTER*4 IBUGQ
5426      CHARACTER*4 ISUBRO
5427      CHARACTER*4 IFOUND
5428      CHARACTER*4 IERROR
5429C
5430      CHARACTER*4 ICASP2
5431      CHARACTER*4 IHSTO2
5432      CHARACTER*4 IHWUSE
5433      CHARACTER*4 MESSAG
5434      CHARACTER*4 IDATSW
5435      CHARACTER*4 IHP
5436      CHARACTER*4 IHP2
5437      CHARACTER*4 ISUBN1
5438      CHARACTER*4 ISUBN2
5439      CHARACTER*4 ISTEPN
5440      CHARACTER*4 IFLAGU
5441      CHARACTER*4 ICENSO
5442      CHARACTER*4 IMETHD
5443      CHARACTER*4 IREPL
5444      CHARACTER*4 IMULT
5445      CHARACTER*4 ILEVEL
5446      CHARACTER*4 IRELAT
5447      CHARACTER*4 IRANSV
5448C
5449      CHARACTER*60 IDIST
5450      CHARACTER*40 INAME
5451C
5452      LOGICAL IFRST
5453      LOGICAL ILAST
5454C
5455      PARAMETER (MAXSPN=30)
5456      CHARACTER*4 IVARN1(MAXSPN)
5457      CHARACTER*4 IVARN2(MAXSPN)
5458      CHARACTER*4 IVARTY(MAXSPN)
5459      CHARACTER*4 IVARID(7)
5460      CHARACTER*4 IVARI2(7)
5461      REAL PVAR(MAXSPN)
5462      REAL PID(7)
5463      INTEGER ILIS(MAXSPN)
5464      INTEGER NRIGHT(MAXSPN)
5465      INTEGER ICOLR(MAXSPN)
5466C
5467      REAL KSLOC
5468      REAL KSSCAL
5469C
5470C---------------------------------------------------------------------
5471C
5472      INCLUDE 'DPCOPA.INC'
5473      INCLUDE 'DPCODA.INC'
5474      INCLUDE 'DPCOZZ.INC'
5475      INCLUDE 'DPCOZD.INC'
5476      INCLUDE 'DPCOZI.INC'
5477C
5478      DIMENSION Y1(MAXOBV)
5479      DIMENSION X1(MAXOBV)
5480      DIMENSION XCENS(MAXOBV)
5481      DIMENSION XLEVEL(MAXOBV)
5482      DIMENSION XHIGH(MAXOBV)
5483      DIMENSION XTEMP1(MAXOBV)
5484      DIMENSION XTEMP2(MAXOBV)
5485      DIMENSION XIDTEM(MAXOBV)
5486      DIMENSION XIDTE2(MAXOBV)
5487      DIMENSION XIDTE3(MAXOBV)
5488      DIMENSION XIDTE4(MAXOBV)
5489      DIMENSION XIDTE5(MAXOBV)
5490      DIMENSION XIDTE6(MAXOBV)
5491      DIMENSION TEMP1(MAXOBV)
5492      DIMENSION TEMP2(MAXOBV)
5493      DIMENSION TEMP3(MAXOBV)
5494      DIMENSION ZY(MAXOBV)
5495      DIMENSION ZXLOW(MAXOBV)
5496      DIMENSION ZXHIGH(MAXOBV)
5497      DIMENSION ZCENS(MAXOBV)
5498      DIMENSION ZTEMP1(MAXOBV)
5499      DIMENSION ZTEMP2(MAXOBV)
5500      DIMENSION ZTEMP3(MAXOBV)
5501      DIMENSION ZTEMP4(MAXOBV)
5502      DIMENSION ZTEMP5(MAXOBV)
5503      DIMENSION ZTEMP6(MAXOBV)
5504      DIMENSION ZTEMP7(MAXOBV)
5505      DIMENSION ZTEMP8(MAXOBV)
5506      DIMENSION ZTEMP9(MAXOBV)
5507      DIMENSION ZTMP10(MAXOBV)
5508      DIMENSION ZTMP11(MAXOBV)
5509      DIMENSION XDESGN(MAXOBV,6)
5510C
5511      DOUBLE PRECISION DTEMP(MAXOBV)
5512      DOUBLE PRECISION DTEMP2(MAXOBV)
5513      DOUBLE PRECISION DTEMP3(MAXOBV)
5514C
5515      DIMENSION ITEMP1(MAXOBV)
5516C
5517      EQUIVALENCE (GARBAG(IGARB1),Y1(1))
5518      EQUIVALENCE (GARBAG(IGARB2),X1(1))
5519      EQUIVALENCE (GARBAG(IGARB3),XCENS(1))
5520      EQUIVALENCE (GARBAG(IGARB4),XHIGH(1))
5521      EQUIVALENCE (GARBAG(IGARB5),XTEMP1(1))
5522      EQUIVALENCE (GARBAG(IGARB6),XTEMP2(1))
5523      EQUIVALENCE (GARBAG(IGARB7),TEMP1(1))
5524      EQUIVALENCE (GARBAG(IGARB8),TEMP2(1))
5525      EQUIVALENCE (GARBAG(IGARB9),TEMP3(1))
5526      EQUIVALENCE (GARBAG(IGAR10),XIDTEM(1))
5527      EQUIVALENCE (GARBAG(JGAR11),XIDTE2(1))
5528      EQUIVALENCE (GARBAG(JGAR12),XIDTE3(1))
5529      EQUIVALENCE (GARBAG(JGAR13),XIDTE4(1))
5530      EQUIVALENCE (GARBAG(JGAR14),XIDTE5(1))
5531      EQUIVALENCE (GARBAG(JGAR15),XIDTE6(1))
5532      EQUIVALENCE (GARBAG(JGAR16),ZY(1))
5533      EQUIVALENCE (GARBAG(JGAR17),ZCENS(1))
5534      EQUIVALENCE (GARBAG(JGAR18),ZXLOW(1))
5535      EQUIVALENCE (GARBAG(JGAR19),ZXHIGH(1))
5536      EQUIVALENCE (GARBAG(JGAR20),ZTEMP1(1))
5537      EQUIVALENCE (GARBAG(IGAR11),ZTEMP2(1))
5538      EQUIVALENCE (GARBAG(IGAR12),ZTEMP3(1))
5539      EQUIVALENCE (GARBAG(IGAR13),ZTEMP4(1))
5540      EQUIVALENCE (GARBAG(IGAR14),ZTEMP5(1))
5541      EQUIVALENCE (GARBAG(IGAR15),ZTEMP6(1))
5542      EQUIVALENCE (GARBAG(IGAR16),ZTEMP7(1))
5543      EQUIVALENCE (GARBAG(IGAR17),ZTEMP8(1))
5544      EQUIVALENCE (GARBAG(IGAR18),ZTEMP9(1))
5545      EQUIVALENCE (GARBAG(IGAR19),ZTMP10(1))
5546      EQUIVALENCE (GARBAG(IGAR20),ZTMP11(1))
5547      EQUIVALENCE (GARBAG(IGAR21),XLEVEL(1))
5548      EQUIVALENCE (DSYMB(1),XDESGN(1,1))
5549C
5550      EQUIVALENCE (DGARBG(IDGAR1),DTEMP(1))
5551      EQUIVALENCE (DGARBG(IDGAR2),DTEMP2(1))
5552      EQUIVALENCE (DGARBG(IDGAR3),DTEMP3(1))
5553      EQUIVALENCE (IGARBG(IDGAR1),ITEMP1(1))
5554CCCCC END CHANGE
5555C
5556C-----COMMON----------------------------------------------------------
5557C
5558      COMMON/ISED/ISED1,ISED2,ISED3,ISED4,ISED5,ISED6,
5559     1            ISED7,ISED8,ISED9,ISED10,ISED11
5560C
5561      INCLUDE 'DPCOHK.INC'
5562      INCLUDE 'DPCOSU.INC'
5563      INCLUDE 'DPCOS2.INC'
5564      INCLUDE 'DPCOHO.INC'
5565      INCLUDE 'DPCOMC.INC'
5566      INCLUDE 'DPCOST.INC'
5567      INCLUDE 'DPCOP2.INC'
5568C
5569C-----START POINT-----------------------------------------------------
5570C
5571      IERROR='NO'
5572      ICASPL='    '
5573      ICENSO='OFF'
5574      IREPL='OFF'
5575      IMULT='OFF'
5576      ILEVEL='OFF'
5577      IRELAT='OFF'
5578      IRANSV=IRANAL
5579      IRANAL='FIBC'
5580      ISEESV=ISEED
5581      ISEED=2503
5582      IMETHD='UNIM'
5583      IF(IPPCCN.EQ.'KAPL')IMETHD='KAPL'
5584      IHSTO2=IHSTOU
5585      IHSTOU='ON'
5586      NSAVE=-9999
5587C
5588      ISUBN1='DPGO'
5589      ISUBN2='FI  '
5590C
5591      MAXCP1=MAXCOL+1
5592      MAXCP2=MAXCOL+2
5593      MAXCP3=MAXCOL+3
5594      MAXCP4=MAXCOL+4
5595      MAXCP5=MAXCOL+5
5596      MAXCP6=MAXCOL+6
5597C
5598      MINN2=3
5599C
5600C               ***************************************************
5601C               **  TREAT THE <TEST>   GOODNESS OF FIT  CASE     **
5602C               ***************************************************
5603C
5604      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'GOFI')THEN
5605        WRITE(ICOUT,999)
5606  999   FORMAT(1X)
5607        CALL DPWRST('XXX','BUG ')
5608        WRITE(ICOUT,51)
5609   51   FORMAT('***** AT THE BEGINNING OF DPGOFI--')
5610        CALL DPWRST('XXX','BUG ')
5611        WRITE(ICOUT,52)ICASPL,MAXNXT
5612   52   FORMAT('ICASPL,MAXNXT = ',A4,2X,I8)
5613        CALL DPWRST('XXX','BUG ')
5614        WRITE(ICOUT,53)IBUGA2,IBUGA3,IBUGQ
5615   53   FORMAT('IBUGA2,IBUGA3,IBUGQ = ',2(A4,2X),A4)
5616        CALL DPWRST('XXX','BUG ')
5617      ENDIF
5618C
5619C               *********************************************************
5620C               **  STEP 1--                                           **
5621C               **  EXTRACT THE COMMAND                                **
5622C               **  LOOK FOR ONE OF THE FOLLOWING COMMANDS:            **
5623C               **    1) <DIST> KOLMOGOROV SMIRNOV GOODNESS OF FIT Y   **
5624C               **    2) <DIST> KOLMOGOROV SMIRNOV GOODNESS OF FIT Y X **
5625C               **    3) <DIST> KOLMOGOROV SMIRNOV GOODNESS OF FIT     **
5626C               **       Y XLOW XHIGH                                  **
5627C               **                                                     **
5628C               **    4) <DIST> CENSORED KOLMOGOROV SMIRNOV            **
5629C               **       GOODNESS OF FIT Y X                           **
5630C               **    5) <DIST> CENSORED KOLMOGOROV SMIRNOV            **
5631C               **       GOODNESS OF FIT Y X XMID                      **
5632C               **    6) <DIST> CENSORED KOLMOGOROV SMIRNOV            **
5633C               **       GOODNESS OF FIT Y X XLOW XHIGH                **
5634C               **                                                     **
5635C               **    7) <DIST> MULTIPLE KOLMOGOROV SMIRNOV            **
5636C               **       GOODNESS OF FIT Y1 ... YK                     **
5637C               **    8) <DIST> REPLICATED KOLMOGOROV SMIRNOV          **
5638C               **       GOODNESS OF FIT Y X1 ...XK                    **
5639C               **    9) <DIST> REPLICATED CENSORED KOLMOGOROV SMIRNOV **
5640C               **       GOODNESS OF FIT   Y X X1 ...XK                **
5641C               *********************************************************
5642C
5643C     LOOK FOR THE WORD "KOLMOGOROV SMIRNOV GOODNESS OF FIT" OR
5644C     SUPPORTED SYNONYMS (ERROR IF NOT FOUND).  SPECIFICALLY,
5645C
5646C          KOLMOGOROV SMIRNOV GOODNESS OF FIT
5647C          KOLMOGOROV SMIRNOV GOODNESS FIT
5648C          KOLMOGOROV SMIRNOV GOF
5649C          KS GOODNESS OF FIT
5650C          KS GOODNESS FIT
5651C          KS GOF
5652C          K S GOODNESS OF FIT
5653C          K S GOODNESS FIT
5654C          K S GOF
5655C
5656C     IN ADDITION, THE FOLLOWING ADDITIONAL GOODNESS OF FIT
5657C     STATISTICS ARE SUPPORTED (ADDITIONAL STATISTICS BASED ON
5658C     THE EMPIRICAL/THOERETICAL CDF FUNCTIONS WILL BE ADDED LATER):
5659C
5660C          1) ANDERSON-DARLING
5661C             AD
5662C             A-D
5663C
5664C          2) PPCC
5665C
5666C          3) CHI-SQUARE
5667C             CHISQUARE
5668C
5669C     ALSO LOOK FOR OPTIONAL KEYWORDS "CENSOR", "REPLICATION",
5670C     AND "MULTIPLE". AND "TEST"
5671C
5672      ISTEPN='1'
5673      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GOFI')
5674     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5675C
5676      ILASTC=9999
5677      ILASTZ=9999
5678      IFOUND='NO'
5679      DO100I=1,NUMARG-1
5680        IF(IHARG(I).EQ.'KOLM' .AND. IHARG(I+1).EQ.'SMIR' .AND.
5681     1     IHARG(I+2).EQ.'GOOD' .AND. IHARG(I+3).EQ.'OF  ' .AND.
5682     1     IHARG(I+4).EQ.'FIT')THEN
5683          IFOUND='YES'
5684          ICASP2='KS  '
5685          ILASTC=MIN(ILASTC,I-1)
5686          ILASTZ=I+5
5687        ELSEIF(IHARG(I).EQ.'KOLM' .AND. IHARG(I+1).EQ.'SMIR' .AND.
5688     1     IHARG(I+2).EQ.'GOOD' .AND. IHARG(I+3).EQ.'FIT ')THEN
5689          IFOUND='YES'
5690          ICASP2='KS  '
5691          ILASTC=MIN(ILASTC,I-1)
5692          ILASTZ=I+4
5693        ELSEIF(IHARG(I).EQ.'KOLM' .AND. IHARG(I+1).EQ.'SMIR' .AND.
5694     1     IHARG(I+2).EQ.'GOF ')THEN
5695          IFOUND='YES'
5696          ICASP2='KS  '
5697          ILASTC=MIN(ILASTC,I-1)
5698          ILASTZ=I+3
5699        ELSEIF(IHARG(I).EQ.'KS  ' .AND. IHARG(I+1).EQ.'GOOD' .AND.
5700     1     IHARG(I+2).EQ.'OF  ' .AND. IHARG(I+3).EQ.'FIT ')THEN
5701          IFOUND='YES'
5702          ICASP2='KS  '
5703          ILASTC=MIN(ILASTC,I-1)
5704          ILASTZ=I+4
5705        ELSEIF(IHARG(I).EQ.'KS  ' .AND. IHARG(I+1).EQ.'GOOD' .AND.
5706     1     IHARG(I+2).EQ.'FIT ')THEN
5707          IFOUND='YES'
5708          ICASP2='KS  '
5709          ILASTC=MIN(ILASTC,I-1)
5710          ILASTZ=I+3
5711        ELSEIF(IHARG(I).EQ.'KS  ' .AND. IHARG(I+1).EQ.'GOF ')THEN
5712          IFOUND='YES'
5713          ICASP2='KS  '
5714          ILASTC=MIN(ILASTC,I-1)
5715          ILASTZ=I+2
5716        ELSEIF(IHARG(I).EQ.'K   ' .AND. IHARG(I+1).EQ.'S   ' .AND.
5717     1     IHARG(I+2).EQ.'GOOD' .AND. IHARG(I+3).EQ.'OF  ' .AND.
5718     1     IHARG(I+4).EQ.'FIT')THEN
5719          IFOUND='YES'
5720          ICASP2='KS  '
5721          ILASTC=MIN(ILASTC,I-1)
5722          ILASTZ=I+5
5723        ELSEIF(IHARG(I).EQ.'K   ' .AND. IHARG(I+1).EQ.'S   ' .AND.
5724     1     IHARG(I+2).EQ.'GOOD' .AND. IHARG(I+3).EQ.'FIT ')THEN
5725          IFOUND='YES'
5726          ICASP2='KS  '
5727          ILASTC=MIN(ILASTC,I-1)
5728          ILASTZ=I+4
5729        ELSEIF(IHARG(I).EQ.'K   ' .AND. IHARG(I+1).EQ.'S   ' .AND.
5730     1     IHARG(I+2).EQ.'GOF ')THEN
5731          IFOUND='YES'
5732          ICASP2='KS  '
5733          ILASTC=MIN(ILASTC,I-1)
5734          ILASTZ=I+3
5735        ELSEIF(IHARG(I).EQ.'ANDE' .AND. IHARG(I+1).EQ.'DARL' .AND.
5736     1     IHARG(I+2).EQ.'GOOD' .AND. IHARG(I+3).EQ.'OF  ' .AND.
5737     1     IHARG(I+4).EQ.'FIT')THEN
5738          IFOUND='YES'
5739          ICASP2='AD  '
5740          ILASTC=MIN(ILASTC,I-1)
5741          ILASTZ=I+5
5742        ELSEIF(IHARG(I).EQ.'ANDE' .AND. IHARG(I+1).EQ.'DARL' .AND.
5743     1     IHARG(I+2).EQ.'GOOD' .AND. IHARG(I+3).EQ.'FIT ')THEN
5744          IFOUND='YES'
5745          ICASP2='AD  '
5746          ILASTC=MIN(ILASTC,I-1)
5747          ILASTZ=I+4
5748        ELSEIF(IHARG(I).EQ.'ANDE' .AND. IHARG(I+1).EQ.'DARL' .AND.
5749     1     IHARG(I+2).EQ.'GOF ')THEN
5750          IFOUND='YES'
5751          ICASP2='AD  '
5752          ILASTC=MIN(ILASTC,I-1)
5753          ILASTZ=I+3
5754        ELSEIF(IHARG(I).EQ.'AD  ' .AND. IHARG(I+1).EQ.'GOOD' .AND.
5755     1     IHARG(I+2).EQ.'OF  ' .AND. IHARG(I+3).EQ.'FIT ')THEN
5756          IFOUND='YES'
5757          ICASP2='AD  '
5758          ILASTC=MIN(ILASTC,I-1)
5759          ILASTZ=I+4
5760        ELSEIF(IHARG(I).EQ.'AD  ' .AND. IHARG(I+1).EQ.'GOOD' .AND.
5761     1     IHARG(I+2).EQ.'FIT ')THEN
5762          IFOUND='YES'
5763          ICASP2='AD  '
5764          ILASTC=MIN(ILASTC,I-1)
5765          ILASTZ=I+3
5766        ELSEIF(IHARG(I).EQ.'AD  ' .AND. IHARG(I+1).EQ.'GOF ')THEN
5767          IFOUND='YES'
5768          ICASP2='AD  '
5769          ILASTC=MIN(ILASTC,I-1)
5770          ILASTZ=I+2
5771        ELSEIF(IHARG(I).EQ.'A   ' .AND. IHARG(I+1).EQ.'D   ' .AND.
5772     1     IHARG(I+2).EQ.'GOOD' .AND. IHARG(I+3).EQ.'OF  ' .AND.
5773     1     IHARG(I+4).EQ.'FIT')THEN
5774          IFOUND='YES'
5775          ICASP2='AD  '
5776          ILASTC=MIN(ILASTC,I-1)
5777          ILASTZ=I+5
5778        ELSEIF(IHARG(I).EQ.'A   ' .AND. IHARG(I+1).EQ.'D   ' .AND.
5779     1     IHARG(I+2).EQ.'GOOD' .AND. IHARG(I+3).EQ.'FIT ')THEN
5780          IFOUND='YES'
5781          ICASP2='AD  '
5782          ILASTC=MIN(ILASTC,I-1)
5783          ILASTZ=I+4
5784        ELSEIF(IHARG(I).EQ.'A   ' .AND. IHARG(I+1).EQ.'D   ' .AND.
5785     1     IHARG(I+2).EQ.'GOF ')THEN
5786          IFOUND='YES'
5787          ICASP2='AD  '
5788          ILASTC=MIN(ILASTC,I-1)
5789          ILASTZ=I+3
5790        ELSEIF(IHARG(I).EQ.'PPCC' .AND. IHARG(I+1).EQ.'GOOD' .AND.
5791     1     IHARG(I+2).EQ.'OF  ' .AND. IHARG(I+3).EQ.'FIT ')THEN
5792          IFOUND='YES'
5793          ICASP2='PPCC'
5794          ILASTC=MIN(ILASTC,I-1)
5795          ILASTZ=I+4
5796        ELSEIF(IHARG(I).EQ.'CHI ' .AND. IHARG(I+1).EQ.'SQUA' .AND.
5797     1     IHARG(I+2).EQ.'GOOD' .AND. IHARG(I+3).EQ.'OF  ' .AND.
5798     1     IHARG(I+4).EQ.'FIT')THEN
5799          IFOUND='YES'
5800          ICASP2='CHSQ'
5801          ILASTC=MIN(ILASTC,I-1)
5802          ILASTZ=I+5
5803        ELSEIF(IHARG(I).EQ.'CHI ' .AND. IHARG(I+1).EQ.'SQUA' .AND.
5804     1     IHARG(I+2).EQ.'GOOD' .AND. IHARG(I+3).EQ.'FIT ')THEN
5805          IFOUND='YES'
5806          ICASP2='CHSQ'
5807          ILASTC=MIN(ILASTC,I-1)
5808          ILASTZ=I+4
5809        ELSEIF(IHARG(I).EQ.'CHI ' .AND. IHARG(I+1).EQ.'SQUA' .AND.
5810     1     IHARG(I+2).EQ.'GOF ')THEN
5811          IFOUND='YES'
5812          ICASP2='CHSQ'
5813          ILASTC=MIN(ILASTC,I-1)
5814          ILASTZ=I+3
5815        ELSEIF(IHARG(I).EQ.'CHIS' .AND. IHARG(I+1).EQ.'GOOD' .AND.
5816     1     IHARG(I+2).EQ.'OF  ' .AND. IHARG(I+3).EQ.'FIT ')THEN
5817          IFOUND='YES'
5818          ICASP2='CHSQ'
5819          ILASTC=MIN(ILASTC,I-1)
5820          ILASTZ=I+4
5821        ELSEIF(IHARG(I).EQ.'CHIS' .AND. IHARG(I+1).EQ.'GOOD' .AND.
5822     1     IHARG(I+2).EQ.'FIT ')THEN
5823          IFOUND='YES'
5824          ICASP2='CHSQ'
5825          ILASTC=MIN(ILASTC,I-1)
5826          ILASTZ=I+3
5827        ELSEIF(IHARG(I).EQ.'CHIS' .AND. IHARG(I+1).EQ.'GOF ')THEN
5828          IFOUND='YES'
5829          ICASP2='CHSQ'
5830          ILASTC=MIN(ILASTC,I-1)
5831          ILASTZ=I+2
5832        ELSEIF(IHARG(I).EQ.'CENS')THEN
5833          ICENSO='ON'
5834          ILASTC=MIN(ILASTC,I-1)
5835        ELSEIF(IHARG(I).EQ.'REPL')THEN
5836          IREPL='ON'
5837          ILASTC=MIN(ILASTC,I-1)
5838        ELSEIF(IHARG(I).EQ.'MULT')THEN
5839          IMULT='ON'
5840          ILASTC=MIN(ILASTC,I-1)
5841C
5842C       MAKE "GOODNESS OF FIT TEST" EQUIVALENT TO "GOODNESS OF FIT".
5843C       IF "TEST" IS NOT PRECEEDED BY "GOODNESS OF FIT" OR "GOF",
5844C       THEN ASSUME IT IS A VARIABLE NAME.
5845C
5846        ELSEIF(IHARG(I).EQ.'TEST')THEN
5847          IF(IHARG(I-1).EQ.'GOF')THEN
5848            ILASTZ=I+1
5849          ELSEIF(IHARG(I-3).EQ.'GOOD' .AND. IHARG(I-2).EQ.'OF  ' .AND.
5850     1           IHARG(I-1).EQ.'FIT ')THEN
5851            ILASTZ=I+1
5852          ENDIF
5853        ENDIF
5854  100 CONTINUE
5855C
5856      IF(IFOUND.EQ.'NO')GOTO9000
5857      IF(IMULT.EQ.'ON')THEN
5858        IF(IREPL.EQ.'ON')THEN
5859          WRITE(ICOUT,999)
5860          CALL DPWRST('XXX','BUG ')
5861          WRITE(ICOUT,101)
5862  101     FORMAT('***** ERROR IN GOODNESS OF FIT--')
5863          CALL DPWRST('XXX','BUG ')
5864          WRITE(ICOUT,102)
5865  102     FORMAT('      YOU CANNOT SPECIFY BOTH "MULTIPLE" AND ',
5866     1           '"REPLICATION" FOR THE GOODNESS OF FIT COMMAND.')
5867          CALL DPWRST('XXX','BUG ')
5868          IERROR='YES'
5869          GOTO9000
5870        ELSEIF(ICENSO.EQ.'ON')THEN
5871          WRITE(ICOUT,999)
5872          CALL DPWRST('XXX','BUG ')
5873          WRITE(ICOUT,101)
5874          CALL DPWRST('XXX','BUG ')
5875          WRITE(ICOUT,112)
5876  112     FORMAT('      YOU CANNOT SPECIFY BOTH "MULTIPLE" AND ',
5877     1           '"CENSORING" FOR THE GOODNESS OF FIT COMMAND.')
5878          CALL DPWRST('XXX','BUG ')
5879          IERROR='YES'
5880          GOTO9000
5881        ENDIF
5882      ENDIF
5883C
5884C               ***************************************************
5885C               **  STEP 2--EXTRACT THE DISTRIBUTION NAME        **
5886C               ***************************************************
5887C
5888      ISTEPN='2'
5889      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GOFI')THEN
5890        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5891        WRITE(ICOUT,211)IMULT,IREPL,ICENSO,ILASTC,ILASTZ
5892  211   FORMAT('IMULT,IREPL,ICENSO,ILASTC,ILASTZ = ',3(A4,2X),2I5)
5893        CALL DPWRST('XXX','BUG ')
5894      ENDIF
5895C
5896      JMIN=0
5897      JMAX=ILASTC
5898C
5899      IDIST=' '
5900      CALL EXTDIS(ICOM,ICOM2,IHARG,IHARG2,NUMARG,JMIN,JMAX,
5901     1            ICASPL,IDIST,NUMSHA,IFOUND,ILOCV,
5902     1            ISUBRO,IBUGA3,IERROR)
5903C
5904      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GOFI')THEN
5905        WRITE(ICOUT,999)
5906        CALL DPWRST('XXX','BUG ')
5907        WRITE(ICOUT,251)
5908  251   FORMAT('***** AFTER CALL EXTDIS--')
5909        CALL DPWRST('XXX','BUG ')
5910        WRITE(ICOUT,252)ICASPL,NUMSHA,IDIST
5911  252   FORMAT('ICASPL,NUMSHA,IDIST = ',A4,2X,I8,2X,A60)
5912        CALL DPWRST('XXX','BUG ')
5913      ENDIF
5914C
5915      IF(IFOUND.EQ.'NO')THEN
5916        WRITE(ICOUT,999)
5917        CALL DPWRST('XXX','BUG ')
5918        WRITE(ICOUT,101)
5919        CALL DPWRST('XXX','BUG ')
5920        WRITE(ICOUT,262)
5921  262   FORMAT('      NO MATCH FOUND FOR DISTRIBUTION NAME.')
5922        CALL DPWRST('XXX','BUG ')
5923        IERROR='YES'
5924        GOTO9000
5925      ELSE
5926        ISHIFT=ILASTZ-1
5927        IF(ISHIFT.GT.0)THEN
5928          CALL ADJUST(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
5929        ENDIF
5930      ENDIF
5931C
5932C               ***************************************************
5933C               **  STEP 3--EXTRACT THE SHAPE PARAMETERS FOR     **
5934C               **          THE SPECIFIED DISTRIBUTION.          **
5935C               ***************************************************
5936C
5937      ISTEPN='3'
5938      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GOFI')
5939     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5940C
5941      IFLAGL=0
5942      AL=CPUMIN
5943C
5944      IHP='KSLO'
5945      IHP2='C   '
5946      IHWUSE='P'
5947      MESSAG='NO'
5948      CALL CHECKN(IHP,IHP2,IHWUSE,
5949     1            IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
5950     1            ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
5951      IF(IERROR.EQ.'YES')THEN
5952        KSLOC=0.0
5953      ELSE
5954        KSLOC=VALUE(ILOCV)
5955      ENDIF
5956      IHP='KSSC'
5957      IHP2='ALE '
5958      IHWUSE='P'
5959      MESSAG='NO'
5960      CALL CHECKN(IHP,IHP2,IHWUSE,
5961     1            IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
5962     1            ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
5963      IF(IERROR.EQ.'YES')THEN
5964        KSSCAL=1.0
5965      ELSE
5966        KSSCAL=VALUE(ILOCV)
5967        IF(KSSCAL.LE.0.0)KSSCAL=1.0
5968      ENDIF
5969C
5970      IF(ICASPL.EQ.'PARE' .OR. ICASPL.EQ.'PAR2')THEN
5971        IHP='A   '
5972        IHP2='    '
5973        IHWUSE='P'
5974        MESSAG='NO'
5975        CALL CHECKN(IHP,IHP2,IHWUSE,
5976     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
5977     1              ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
5978        IF(IERROR.EQ.'YES')THEN
5979          SHAPE2=1.0
5980        ELSE
5981          SHAPE2=VALUE(ILOCV)
5982        ENDIF
5983      ELSEIF(ICASPL.EQ.'GMCL' .OR. ICASPL.EQ.'TRAP' .OR.
5984     1       ICASPL.EQ.'GTRA' .OR. ICASPL.EQ.'UTSP' .OR.
5985     1       ICASPL.EQ.'GLGP')THEN
5986        CONTINUE
5987      ELSEIF(ICASPL.EQ.'WEIB' .OR. ICASPL.EQ.'3WEI')THEN
5988        IF(IWEIGL.EQ.'ON')THEN
5989          IHP='L   '
5990          IHP2='    '
5991          IHWUSE='P'
5992          MESSAG='NO'
5993          CALL CHECKN(IHP,IHP2,IHWUSE,
5994     1                IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
5995     1                ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
5996          IF(IERROR.EQ.'NO')AL=VALUE(ILOCP)
5997          IF(AL.LE.0.0)THEN
5998            AL=CPUMIN
5999          ELSE
6000            IFLAGL=1
6001          ENDIF
6002        ENDIF
6003      ELSE
6004        IHP='A   '
6005        IHP2='    '
6006        IHWUSE='P'
6007        MESSAG='NO'
6008        CALL CHECKN(IHP,IHP2,IHWUSE,
6009     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
6010     1              ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
6011        IF(IERROR.EQ.'YES')THEN
6012          A=0.0
6013        ELSE
6014          A=VALUE(ILOCV)
6015        ENDIF
6016C
6017        IHP='B   '
6018        IHP2='    '
6019        IHWUSE='P'
6020        MESSAG='NO'
6021        CALL CHECKN(IHP,IHP2,IHWUSE,
6022     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
6023     1              ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
6024        IF(IERROR.EQ.'YES')THEN
6025          B=1.0
6026        ELSE
6027          B=VALUE(ILOCV)
6028        ENDIF
6029C
6030      ENDIF
6031C
6032      IF(NUMSHA.GE.1)THEN
6033        CALL EXTPA1(ICASPL,IDIST,A,B,
6034     1              SHAPE1,SHAPE2,SHAPE3,SHAPE4,
6035     1              SHAPE5,SHAPE6,SHAPE7,
6036     1              IADEDF,IGEPDF,IMAKDF,IBEIDF,
6037     1              ILGADF,ISKNDF,IGLDDF,IBGEDF,
6038     1              IGETDF,ICONDF,IGOMDF,IKATDF,
6039     1              IGIGDF,IGEODF,
6040     1              IBFWLI,IEEWLI,
6041     1              ISUBRO,IBUGA2,IERROR)
6042      ENDIF
6043C
6044C               ***************************************************
6045C               **  STEP 3B--EXTRACT THE LIMITS FOR THE SHAPE    **
6046C               **           PARAMETERS FOR THE PPCC CASE.       **
6047C               ***************************************************
6048      IF((ICASP2.EQ.'PPCC' .OR. IGOFFM.EQ.'PPCC') .AND. NUMSHA.GT.0)THEN
6049        IF(ICASPL.EQ.'GMCL' .OR. ICASP2.EQ.'TRAP' .OR.
6050     1         ICASP2.EQ.'GTRA' .OR. ICASP2.EQ.'UTSP' .OR.
6051     1         ICASP2.EQ.'GLGP' .OR.
6052     1         ICASP2.EQ.'PARE' .OR. ICASP2.EQ.'PAR2'
6053     1    )THEN
6054          CONTINUE
6055        ELSE
6056          IHP='A   '
6057          IHP2='    '
6058          IHWUSE='P'
6059          MESSAG='NO'
6060          CALL CHECKN(IHP,IHP2,IHWUSE,
6061     1                IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
6062     1                ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
6063          IF(IERROR.EQ.'YES')THEN
6064            A=0.0
6065          ELSE
6066            A=VALUE(ILOCV)
6067          ENDIF
6068C
6069          IHP='B   '
6070          IHP2='    '
6071          IHWUSE='P'
6072          MESSAG='NO'
6073          CALL CHECKN(IHP,IHP2,IHWUSE,
6074     1                IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
6075     1                ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
6076          IF(IERROR.EQ.'YES')THEN
6077            B=1.0
6078          ELSE
6079            B=VALUE(ILOCV)
6080          ENDIF
6081C
6082        ENDIF
6083C
6084        CALL EXTPA2(ICASPL,IDIST,A,B,
6085     1              SHAP11,SHAP12,SHAP21,SHAP22,
6086     1              SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5,
6087     1              IADEDF,IGEPDF,IMAKDF,IBEIDF,
6088     1              ILGADF,ISKNDF,IGLDDF,IBGEDF,
6089     1              IGETDF,ICONDF,IGOMDF,IKATDF,
6090     1              IGIGDF,IGEODF,
6091     1              ISUBRO,IBUGA2,IERROR)
6092        IF(IERROR.EQ.'YES')THEN
6093          WRITE(ICOUT,999)
6094          CALL DPWRST('XXX','BUG ')
6095          WRITE(ICOUT,101)
6096          CALL DPWRST('XXX','BUG ')
6097          WRITE(ICOUT,302)
6098  302     FORMAT('      UNABLE TO EXTRACT PARAMETER RANGES.')
6099          CALL DPWRST('XXX','BUG ')
6100          WRITE(ICOUT,304)ICASP2
6101  304     FORMAT('      ICASP2 = ',A4)
6102          CALL DPWRST('XXX','BUG ')
6103          IERROR='YES'
6104          GOTO9000
6105        ENDIF
6106C
6107        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GOFI')THEN
6108          WRITE(ICOUT,312)ICASP2,IDIST
6109  312     FORMAT('AFTER EXTPA2: ICASP2,IDIST = ',A4,2X,A60)
6110          CALL DPWRST('XXX','BUG ')
6111          WRITE(ICOUT,314)SHAPE1,SHAPE2,SHAP11,SHAP12,SHAP21,SHAP22
6112  314     FORMAT('SHAPE1,SHAPE2,SHAP11,SHAP12,SHAP21,SHAP22 = ',6G15.7)
6113          CALL DPWRST('XXX','BUG ')
6114        ENDIF
6115      ENDIF
6116C
6117C               *********************************
6118C               **  STEP 4--                   **
6119C               **  EXTRACT THE VARIABLE LIST  **
6120C               *********************************
6121C
6122      ISTEPN='4'
6123      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GOFI')
6124     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6125C
6126      INAME='KOLMOGOROV SMIRNOV GOODNESS OF FIT'
6127      IF(ICASP2.EQ.'AD  ')INAME='ANDERSON-DARLING GOODNESS OF FIT'
6128      IF(ICASP2.EQ.'CHSQ')INAME='CHI-SQUARE GOODNESS OF FIT'
6129      IF(ICASP2.EQ.'PPCC')INAME='PPCC GOODNESS OF FIT'
6130      MINNA=1
6131      MAXNA=100
6132      MINN2=2
6133      IFLAGE=1
6134      IF(IMULT.EQ.'ON')IFLAGE=0
6135      IFLAGM=0
6136      IFLAGP=0
6137      JMIN=1
6138      JMAX=NUMARG
6139      MINNVA=-99
6140      MAXNVA=-99
6141C
6142      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
6143     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
6144     1            JMIN,JMAX,
6145     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
6146     1            IVARN1,IVARN2,IVARTY,PVAR,
6147     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
6148     1            MINNVA,MAXNVA,
6149     1            IFLAGM,IFLAGP,
6150     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
6151      IF(IERROR.EQ.'YES')GOTO9000
6152C
6153      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GOFI')THEN
6154        WRITE(ICOUT,999)
6155        CALL DPWRST('XXX','BUG ')
6156        WRITE(ICOUT,281)
6157  281   FORMAT('***** AFTER CALL DPPARS--')
6158        CALL DPWRST('XXX','BUG ')
6159        WRITE(ICOUT,282)NQ,NUMVAR
6160  282   FORMAT('NQ,NUMVAR = ',2I8)
6161        CALL DPWRST('XXX','BUG ')
6162        IF(NUMVAR.GT.0)THEN
6163          DO285I=1,NUMVAR
6164            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
6165     1                      ICOLR(I)
6166  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
6167     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
6168            CALL DPWRST('XXX','BUG ')
6169  285     CONTINUE
6170        ENDIF
6171      ENDIF
6172C
6173C               ***********************************************
6174C               **  STEP 5--                                 **
6175C               **  DETERMINE:                               **
6176C               **  1) NUMBER OF REPLICATION VARIABLES (0-6) **
6177C               **  2) NUMBER OF CENSORING   VARIABLES (0-1) **
6178C               **  3) NUMBER OF GROUPING    VARIABLES (0-2) **
6179C               **  4) NUMBER OF RESPONSE    VARIABLES (>= 1)**
6180C               ***********************************************
6181C
6182      ISTEPN='5'
6183      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GOFI')
6184     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6185C
6186      NRESP=0
6187      NREPL=0
6188      NCENS=0
6189      NGROUP=0
6190      NLEVEL=0
6191      IDATSW='RAW'
6192      IF(IMULT.EQ.'ON')THEN
6193        NRESP=NUMVAR
6194      ELSEIF(IREPL.EQ.'ON')THEN
6195        NRESP=1
6196        IF(ICENSO.EQ.'ON')THEN
6197          NCENS=1
6198        ENDIF
6199        NREPL=NUMVAR-NRESP-NCENS
6200        IF(NREPL.LT.1 .OR. NREPL.GT.6)THEN
6201          WRITE(ICOUT,999)
6202          CALL DPWRST('XXX','BUG ')
6203          WRITE(ICOUT,101)
6204          CALL DPWRST('XXX','BUG ')
6205          WRITE(ICOUT,511)
6206  511     FORMAT('      FOR THE REPLICATION CASE, THE NUMBER OF ',
6207     1           'REPLICATION VARIABLES')
6208          CALL DPWRST('XXX','BUG ')
6209          WRITE(ICOUT,513)NREPL
6210  513     FORMAT('      THE NUMBER OF REPLICATION VARIABLES = ',I5)
6211          CALL DPWRST('XXX','BUG ')
6212          IERROR='YES'
6213          GOTO9000
6214        ENDIF
6215      ELSE
6216        NLEVEL=0
6217        NRESP=1
6218        IF(ICASPL.EQ.'BFWE')THEN
6219          IF(IBFWTY.EQ.'ON' .AND. NUMVAR.GT.1 .AND.
6220     1       IFLAGM.EQ.0)THEN
6221             NLEVEL=1
6222             ILEVEL='ON'
6223          ENDIF
6224          IF(ICENSO.EQ.'ON' .AND. NUMVAR.GT.1)THEN
6225            NCENS=1
6226          ENDIF
6227          NGROUP=NUMVAR-NRESP-NCENS-NLEVEL
6228          IF(NGROUP.EQ.1)IDATSW='FREQ'
6229          IF(NGROUP.EQ.2)IDATSW='FRE2'
6230        ELSE
6231          IF(ICENSO.EQ.'ON')THEN
6232            NCENS=1
6233          ENDIF
6234          NGROUP=NUMVAR-NRESP-NCENS
6235        ENDIF
6236C
6237        IF(NGROUP.EQ.1)IDATSW='FREQ'
6238        IF(NGROUP.EQ.2)IDATSW='FRE2'
6239        IF(NGROUP.LT.0 .OR. NGROUP.GT.2)THEN
6240          WRITE(ICOUT,999)
6241          CALL DPWRST('XXX','BUG ')
6242          WRITE(ICOUT,101)
6243          CALL DPWRST('XXX','BUG ')
6244          WRITE(ICOUT,521)
6245  521     FORMAT('      THE NUMBER OF CLASS VARIABLES IS LESS THAN ',
6246     1           'ZERO OR GREATER THAN TWO.')
6247          CALL DPWRST('XXX','BUG ')
6248          WRITE(ICOUT,523)NGROUP
6249  523     FORMAT('      THE NUMBER OF CLASS VARIABLES = ',I5)
6250          CALL DPWRST('XXX','BUG ')
6251          IERROR='YES'
6252          GOTO9000
6253        ENDIF
6254      ENDIF
6255C
6256C               ***********************************************
6257C               **  STEP 6--                                 **
6258C               **  GENERATE THE KOLMOGOROV SMIRNOV          **
6259C               **  GOODNESS OF FITS FOR THE VARIOUS CASES.  **
6260C               ***********************************************
6261C
6262      ISTEPN='6'
6263      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GOFI')
6264     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6265C
6266C               *****************************************
6267C               **  STEP 7A--                          **
6268C               **  CASE 1: SINGLE RESPONSE VARIABLE   **
6269C               **          WITH NO REPLICATION        **
6270C               *****************************************
6271C
6272      DO701I=1,MAXOBV
6273        Y1(I)=0.0
6274        X1(I)=0.0
6275        XHIGH(I)=0.0
6276        XCENS(I)=1.0
6277        XLEVEL(I)=CPUMIN
6278  701 CONTINUE
6279C
6280      IF(NRESP.EQ.1 .AND. NREPL.EQ.0)THEN
6281        ISTEPN='7A'
6282        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GOFI')
6283     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6284C
6285        PID(1)=CPUMIN
6286        IVARID(1)=IVARN1(1)
6287        IVARI2(1)=IVARN2(1)
6288        IF(IDATSW.EQ.'FREQ')THEN
6289          IVARID(2)=IVARN1(2)
6290          IVARI2(2)=IVARN2(2)
6291        ELSEIF(IDATSW.EQ.'FRE2')THEN
6292          IVARID(2)=IVARN1(2)
6293          IVARI2(2)=IVARN2(2)
6294          IVARID(3)=IVARN1(3)
6295          IVARI2(3)=IVARN2(3)
6296        ENDIF
6297C
6298        J=0
6299        IMAX=NRIGHT(1)
6300        IF(NQ.LT.NRIGHT(1))IMAX=NQ
6301        DO710I=1,IMAX
6302          IF(ISUB(I).EQ.0)GOTO710
6303          J=J+1
6304C
6305C         RESPONSE VARIABLE IN Y1
6306C
6307          IJ=MAXN*(ICOLR(1)-1)+I
6308          IF(ICOLR(1).LE.MAXCOL)Y1(J)=V(IJ)
6309          IF(ICOLR(1).EQ.MAXCP1)Y1(J)=PRED(I)
6310          IF(ICOLR(1).EQ.MAXCP2)Y1(J)=RES(I)
6311          IF(ICOLR(1).EQ.MAXCP3)Y1(J)=YPLOT(I)
6312          IF(ICOLR(1).EQ.MAXCP4)Y1(J)=XPLOT(I)
6313          IF(ICOLR(1).EQ.MAXCP5)Y1(J)=X2PLOT(I)
6314          IF(ICOLR(1).EQ.MAXCP6)Y1(J)=TAGPLO(I)
6315          ICOLC=1
6316C
6317C         LENGTH VARIABLE IN XLEVEL
6318C
6319          IF(ILEVEL.EQ.'ON' .AND. NLEVEL.GT.0)THEN
6320            ICOLC=ICOLC+1
6321            ICOLT=ICOLR(ICOLC)
6322            IJ=MAXN*(ICOLT-1)+I
6323            IF(ICOLT.LE.MAXCOL)XLEVEL(J)=V(IJ)
6324            IF(ICOLT.EQ.MAXCP1)XLEVEL(J)=PRED(I)
6325            IF(ICOLT.EQ.MAXCP2)XLEVEL(J)=RES(I)
6326            IF(ICOLT.EQ.MAXCP3)XLEVEL(J)=YPLOT(I)
6327            IF(ICOLT.EQ.MAXCP4)XLEVEL(J)=XPLOT(I)
6328            IF(ICOLT.EQ.MAXCP5)XLEVEL(J)=X2PLOT(I)
6329            IF(ICOLT.EQ.MAXCP6)XLEVEL(J)=TAGPLO(I)
6330          ENDIF
6331C
6332C         CENSORING VARIABLE IN XCENS
6333C
6334          IF(ICENSO.EQ.'ON')THEN
6335            ICOLC=ICOLC+1
6336            ICOLT=ICOLR(ICOLC)
6337            IJ=MAXN*(ICOLT-1)+I
6338            IF(ICOLT.LE.MAXCOL)XCENS(J)=V(IJ)
6339            IF(ICOLT.EQ.MAXCP1)XCENS(J)=PRED(I)
6340            IF(ICOLT.EQ.MAXCP2)XCENS(J)=RES(I)
6341            IF(ICOLT.EQ.MAXCP3)XCENS(J)=YPLOT(I)
6342            IF(ICOLT.EQ.MAXCP4)XCENS(J)=XPLOT(I)
6343            IF(ICOLT.EQ.MAXCP5)XCENS(J)=X2PLOT(I)
6344            IF(ICOLT.EQ.MAXCP6)XCENS(J)=TAGPLO(I)
6345          ENDIF
6346C
6347C         CLASS VARIABLE IN X1 FOR FREQUENCY DATA
6348C
6349          IF(NGROUP.GE.1)THEN
6350            ICOLC=ICOLC+1
6351            ICOLT=ICOLR(ICOLC)
6352            IJ=MAXN*(ICOLT-1)+I
6353            IF(ICOLT.LE.MAXCOL)X1(J)=V(IJ)
6354            IF(ICOLT.EQ.MAXCP1)X1(J)=PRED(I)
6355            IF(ICOLT.EQ.MAXCP2)X1(J)=RES(I)
6356            IF(ICOLT.EQ.MAXCP3)X1(J)=YPLOT(I)
6357            IF(ICOLT.EQ.MAXCP4)X1(J)=XPLOT(I)
6358            IF(ICOLT.EQ.MAXCP5)X1(J)=X2PLOT(I)
6359            IF(ICOLT.EQ.MAXCP6)X1(J)=TAGPLO(I)
6360          ENDIF
6361C
6362C         IF FREQUENCY DATA GIVEN WITH LOWER AND UPPER CLASS LIMITS,
6363C         THEN UPPER CLASS LIMIT VARIABLE IN XHIGH
6364C
6365          IF(NGROUP.EQ.2)THEN
6366            ICOLC=ICOLC+1
6367            ICOLT=ICOLR(ICOLC)
6368            IJ=MAXN*(ICOLT-1)+I
6369            IF(ICOLT.LE.MAXCOL)XHIGH(J)=V(IJ)
6370            IF(ICOLT.EQ.MAXCP1)XHIGH(J)=PRED(I)
6371            IF(ICOLT.EQ.MAXCP2)XHIGH(J)=RES(I)
6372            IF(ICOLT.EQ.MAXCP3)XHIGH(J)=YPLOT(I)
6373            IF(ICOLT.EQ.MAXCP4)XHIGH(J)=XPLOT(I)
6374            IF(ICOLT.EQ.MAXCP5)XHIGH(J)=X2PLOT(I)
6375            IF(ICOLT.EQ.MAXCP6)XHIGH(J)=TAGPLO(I)
6376          ENDIF
6377C
6378  710   CONTINUE
6379        NLOCAL=J
6380C
6381C       *****************************************************
6382C       **  STEP 7B--                                      **
6383C       **  FORM THE VERTICAL AND HORIZONTAL AXIS          **
6384C       **  VALUES Y(.) AND X(.) FOR THE PLOT.             **
6385C       **  RESET THE VECTOR D(.) TO ALL ONES.             **
6386C       **  DEFINE THE NUMBER OF PLOT POINTS    (NPLOTP).  **
6387C       **  DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV).  **
6388C       *****************************************************
6389C
6390        ISTEPN='7B'
6391        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GOFI')
6392     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6393C
6394        IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'GOFI')THEN
6395          WRITE(ICOUT,999)
6396          CALL DPWRST('XXX','BUG ')
6397          WRITE(ICOUT,711)
6398  711     FORMAT('***** FROM THE MIDDLE  OF DPGOFI--')
6399          CALL DPWRST('XXX','BUG ')
6400          WRITE(ICOUT,712)ICASPL,NUMVAR,IDATSW,NLOCAL
6401  712     FORMAT('ICASPL,NUMVAR,IDATSW,NQ = ',
6402     1           A4,I8,2X,A4,I8)
6403          CALL DPWRST('XXX','BUG ')
6404          IF(NLOCAL.GE.1)THEN
6405            DO715I=1,NLOCAL
6406              WRITE(ICOUT,716)I,Y1(I),X1(I),XHIGH(I),XCENS(I)
6407  716         FORMAT('I,Y1(I),X1(I),XHIGH(I),XCENS(I) = ',I8,4F12.5)
6408              CALL DPWRST('XXX','BUG ')
6409  715       CONTINUE
6410          ENDIF
6411        ENDIF
6412C
6413        NCURVE=1
6414        IF(NGROUP.EQ.0 .AND. ICASP2.NE.'CHSQ')THEN
6415          CALL DPGOF2(Y1,XCENS,XLEVEL,NLOCAL,ICASPL,ICASP2,
6416     1               PID,IVARID,IVARI2,NREPL,
6417     1               XTEMP1,XTEMP2,NOUT,
6418     1               TEMP1,TEMP2,TEMP3,DTEMP,DTEMP2,DTEMP3,ITEMP1,
6419     1               ZTEMP1,ZTEMP2,ZTEMP3,ZTEMP4,ZTEMP5,
6420     1               ZTEMP6,ZTEMP7,ZTEMP8,ZTEMP9,ZTMP10,ZTMP11,
6421     1               YLOWLM,YUPPLM,A,B,MINMAX,
6422     1               SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5,
6423     1               SHAPE6,SHAPE7,NUMSHA,
6424     1               SHAP11,SHAP12,SHAP21,SHAP22,
6425     1               IADEDF,IGEPDF,IMAKDF,IBEIDF,
6426     1               ILGADF,ISKNDF,IGLDDF,IBGEDF,IGETDF,ICONDF,
6427     1               IGOMDF,IKATDF,IGIGDF,IGEODF,IGAUDF,
6428     1               IEXPBC,IWEIBC,ICENTY,IDFTTY,
6429     1               IFLAGL,AL,
6430     1               IDIST,MAXOBV,ICENSO,NMCSAM,NSAVE,
6431     1               KSLOC,KSSCAL,ICAPSW,ICAPTY,IRTFFF,IRTFFP,
6432     1               IKSCVM,IADCVM,IFORSW,ISEED,IGOFFS,IGOFFM,
6433     1               IPPLDP,IMETHD,IPPCBW,IPPCCC,IPPCFO,
6434     1               IPPCDP,IPPCAP,IPPCAO,PCHSLM,ILEVEL,
6435     1               CLLIMI,CLWIDT,IHSTCW,IHSTOU,IRELAT,IRHSTG,
6436     1               STATVA,STATCD,PVAL,CDF1,CDF2,CDF3,CDF4,
6437     1               IBUGA3,ISUBRO,IERROR)
6438        ELSE
6439          IHP='MINS'
6440          IHP2='IZE '
6441          IHWUSE='P'
6442          MESSAG='NO'
6443          CALL CHECKN(IHP,IHP2,IHWUSE,
6444     1                IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
6445     1                ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
6446          IF(IERROR.EQ.'YES')THEN
6447            MINSZ=1
6448          ELSE
6449            MINSZ=INT(VALUE(ILOCV)+0.1)
6450            IF(MINSZ.LT.1)MINSZ=1
6451          ENDIF
6452          IERROR='NO'
6453          NOUT=0
6454          STATVA=0.0
6455          STATCD=0.0
6456          PVAL=0.0
6457          CDF1=0.0
6458          CDF2=0.0
6459          CDF3=0.0
6460          CDF4=0.0
6461C
6462          CALL DPGOF3(Y1,XCENS,X1,XHIGH,NLOCAL,ICASPL,ICASP2,IDATSW,
6463     1               PID,IVARID,IVARI2,NREPL,MINSZ,PCHSLM,
6464     1               XTEMP1,XTEMP2,ZTEMP1,ZTEMP2,
6465     1               TEMP1,TEMP2,TEMP3,ZTEMP3,ZTEMP4,
6466     1               ZTEMP5,ZTEMP6,ZTEMP7,
6467     1               DTEMP,DTEMP2,DTEMP3,ITEMP1,
6468     1               NOUT,YLOWLM,YUPPLM,A,B,MINMAX,
6469     1               SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5,
6470     1               SHAPE6,SHAPE7,NUMSHA,
6471     1               IADEDF,IGEPDF,IMAKDF,IBEIDF,
6472     1               ILGADF,ISKNDF,IGLDDF,IBGEDF,
6473     1               IGETDF,ICONDF,IGOMDF,IKATDF,
6474     1               IGIGDF,IGEODF,IGAUDF,
6475     1               IEXPBC,IWEIBC,ICENTY,IDFTTY,
6476     1               IDIST,MAXOBV,ICENSO,NMCSAM,NSAVE,
6477     1               KSLOC,KSSCAL,ICAPSW,ICAPTY,
6478     1               IKSCVM,IADCVM,IFORSW,ISEED,IGOFFS,IMETHD,
6479     1               IRHSTG,IHSTCW,CLWIDT,CLLIMI,IHSTOU,
6480     1               STATVA,STATCD,PVAL,CDF1,CDF2,CDF3,CDF4,
6481     1               IBUGA3,ISUBRO,IERROR)
6482        ENDIF
6483C
6484C               ***************************************
6485C               **  STEP 7C--                        **
6486C               **  COMPUTE KS        STAT           **
6487C               **  UPDATE INTERNAL DATAPLOT TABLES  **
6488C               ***************************************
6489C
6490        ISTEPN='7C'
6491        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GOFI')
6492     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6493C
6494        IFLAGU='ON'
6495        IFRST=.FALSE.
6496        ILAST=.FALSE.
6497        CALL DPGOF4(STATVA,STATCD,PVAL,CDF1,CDF2,CDF3,CDF4,
6498     1             IFLAGU,IFRST,ILAST,ICASP2,
6499     1             IBUGA2,IBUGA3,ISUBRO,IERROR)
6500C
6501C               ******************************************
6502C               **  STEP 8A--                           **
6503C               **  CASE 2: MULTIPLE RESPONSE VARIABLES **
6504C               **          NOTE THAT CENSORING AND     **
6505C               **          GROUPING ARE NOT SUPPORTED  **
6506C               **          FOR THIS CASE.              **
6507C               ******************************************
6508C
6509      ELSEIF(NRESP.GT.1)THEN
6510        ISTEPN='8A'
6511        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GOFI')
6512     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6513C
6514C       LOOP THROUGH EACH OF THE RESPONSE VARIABLES
6515C
6516        NCURVE=0
6517        DO810IRESP=1,NRESP
6518          NCURVE=NCURVE+1
6519C
6520          IINDX=ICOLR(IRESP)
6521          PID(1)=CPUMIN
6522          IVARID(1)=IVARN1(IRESP)
6523          IVARI2(1)=IVARN2(IRESP)
6524C
6525          IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GOFI')THEN
6526            WRITE(ICOUT,999)
6527            CALL DPWRST('XXX','BUG ')
6528            WRITE(ICOUT,811)IRESP,NCURVE
6529  811       FORMAT('IRESP,NCURVE = ',2I5)
6530            CALL DPWRST('XXX','BUG ')
6531          ENDIF
6532C
6533          J=0
6534          IMAX=NRIGHT(IRESP)
6535          IF(NQ.LT.NRIGHT(IRESP))IMAX=NQ
6536          DO820I=1,IMAX
6537            IF(ISUB(I).EQ.0)GOTO820
6538            J=J+1
6539C
6540C           RESPONSE VARIABLE IN Y1
6541C
6542            IJ=MAXN*(ICOLR(IRESP)-1)+I
6543            IF(ICOLR(IRESP).LE.MAXCOL)Y1(J)=V(IJ)
6544            IF(ICOLR(IRESP).EQ.MAXCP1)Y1(J)=PRED(I)
6545            IF(ICOLR(IRESP).EQ.MAXCP2)Y1(J)=RES(I)
6546            IF(ICOLR(IRESP).EQ.MAXCP3)Y1(J)=YPLOT(I)
6547            IF(ICOLR(IRESP).EQ.MAXCP4)Y1(J)=XPLOT(I)
6548            IF(ICOLR(IRESP).EQ.MAXCP5)Y1(J)=X2PLOT(I)
6549            IF(ICOLR(IRESP).EQ.MAXCP6)Y1(J)=TAGPLO(I)
6550C
6551  820     CONTINUE
6552          NLOCAL=J
6553C
6554C         *****************************************************
6555C         **  STEP 8B--                                      **
6556C         **  FORM THE VERTICAL AND HORIZONTAL AXIS          **
6557C         **  VALUES Y(.) AND X(.) FOR THE PLOT.             **
6558C         **  RESET THE VECTOR D(.) TO ALL ONES.             **
6559C         **  DEFINE THE NUMBER OF PLOT POINTS    (NPLOTP).  **
6560C         **  DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV).  **
6561C         *****************************************************
6562C
6563          ISTEPN='8B'
6564          IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GOFI')
6565     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6566C
6567          IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'GOFI')THEN
6568            WRITE(ICOUT,999)
6569            CALL DPWRST('XXX','BUG ')
6570            WRITE(ICOUT,822)
6571  822       FORMAT('***** FROM THE MIDDLE  OF DPGOFI--')
6572            CALL DPWRST('XXX','BUG ')
6573            WRITE(ICOUT,823)ICASPL,NUMVAR,IDATSW,NLOCAL
6574  823       FORMAT('ICASPL,NUMVAR,IDATSW,NQ = ',
6575     1             A4,I8,2X,A4,I8)
6576            CALL DPWRST('XXX','BUG ')
6577            IF(NLOCAL.GE.1)THEN
6578              DO825I=1,NLOCAL
6579                WRITE(ICOUT,826)I,Y1(I),X1(I),XHIGH(I),XCENS(I)
6580  826           FORMAT('I,Y1(I),X1(I),XHIGH(I),XCENS(I) = ',I8,4F12.5)
6581                CALL DPWRST('XXX','BUG ')
6582  825         CONTINUE
6583            ENDIF
6584          ENDIF
6585C
6586          CALL DPGOF2(Y1,XCENS,XLEVEL,NLOCAL,ICASPL,ICASP2,
6587     1               PID,IVARID,IVARI2,NREPL,
6588     1               XTEMP1,XTEMP2,NOUT,
6589     1               TEMP1,TEMP2,TEMP3,DTEMP,DTEMP2,DTEMP3,ITEMP1,
6590     1               ZTEMP1,ZTEMP2,ZTEMP3,ZTEMP4,ZTEMP5,
6591     1               ZTEMP6,ZTEMP7,ZTEMP8,ZTEMP9,ZTMP10,ZTMP11,
6592     1               YLOWLM,YUPPLM,A,B,MINMAX,
6593     1               SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5,
6594     1               SHAPE6,SHAPE7,NUMSHA,
6595     1               SHAP11,SHAP12,SHAP21,SHAP22,
6596     1               IADEDF,IGEPDF,IMAKDF,IBEIDF,
6597     1               ILGADF,ISKNDF,IGLDDF,IBGEDF,IGETDF,ICONDF,
6598     1               IGOMDF,IKATDF,IGIGDF,IGEODF,IGAUDF,
6599     1               IEXPBC,IWEIBC,ICENTY,IDFTTY,
6600     1               IFLAGL,AL,
6601     1               IDIST,MAXOBV,ICENSO,NMCSAM,NSAVE,
6602     1               KSLOC,KSSCAL,ICAPSW,ICAPTY,IRTFFF,IRTFFP,
6603     1               IKSCVM,IADCVM,IFORSW,ISEED,IGOFFS,IGOFFM,
6604     1               IPPLDP,IMETHD,IPPCBW,IPPCCC,IPPCFO,
6605     1               IPPCDP,IPPCAP,IPPCAO,PCHSLM,ILEVEL,
6606     1               CLLIMI,CLWIDT,IHSTCW,IHSTOU,IRELAT,IRHSTG,
6607     1               STATVA,STATCD,PVAL,CDF1,CDF2,CDF3,CDF4,
6608     1               IBUGA3,ISUBRO,IERROR)
6609C
6610C               ***************************************
6611C               **  STEP 8C--                        **
6612C               **  COMPUTE KS        STAT           **
6613C               **  UPDATE INTERNAL DATAPLOT TABLES  **
6614C               ***************************************
6615C
6616          ISTEPN='8C'
6617          IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GOFI')
6618     1      CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6619C
6620          IFLAGU='FILE'
6621          IFRST=.FALSE.
6622          ILAST=.FALSE.
6623          IF(IRESP.EQ.1)IFRST=.TRUE.
6624          IF(IRESP.EQ.NRESP)ILAST=.TRUE.
6625          CALL DPGOF4(STATVA,STATCD,PVAL,CDF1,CDF2,CDF3,CDF4,
6626     1                 IFLAGU,IFRST,ILAST,ICASP2,
6627     1                 IBUGA2,IBUGA3,ISUBRO,IERROR)
6628C
6629  810   CONTINUE
6630C
6631C               ***************************************************
6632C               **  STEP 9A--                                    **
6633C               **  CASE 3: ONE OR MORE REPLICATION VARIABLES.   **
6634C               **          FOR THIS CASE, THE NUMBER OF         **
6635C               **          VARIABLES MUST BE EXACTLY 1.  BOTH   **
6636C               **          CENSORING AND GROUPING ARE SUPPORTED.**
6637C               **          FOR THIS CASE, ALL VARIABLES MUST    **
6638C               **          HAVE THE SAME LENGTH.                **
6639C               ***************************************************
6640C
6641      ELSEIF(NRESP.EQ.1 .AND. NREPL.GE.1)THEN
6642        ISTEPN='9A'
6643        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GOFI')
6644     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6645C
6646        PID(1)=CPUMIN
6647        IVARID(1)=IVARN1(1)
6648        IVARI2(1)=IVARN2(1)
6649        IADD=1
6650        IF(ICENSO.EQ.'ON')IADD=IADD+1
6651        IF(NGROUP.GE.1)IADD=IADD+1
6652        IF(NGROUP.GE.2)IADD=IADD+1
6653        DO903II=1,NREPL
6654          IVARID(II+1)=IVARN1(II+IADD)
6655          IVARI2(II+1)=IVARN2(II+IADD)
6656  903   CONTINUE
6657C
6658        J=0
6659        IMAX=NRIGHT(1)
6660        IF(NQ.LT.NRIGHT(1))IMAX=NQ
6661        DO910I=1,IMAX
6662          IF(ISUB(I).EQ.0)GOTO910
6663          J=J+1
6664C
6665C         RESPONSE VARIABLE IN Y1
6666C
6667          IJ=MAXN*(ICOLR(1)-1)+I
6668          IF(ICOLR(1).LE.MAXCOL)Y1(J)=V(IJ)
6669          IF(ICOLR(1).EQ.MAXCP1)Y1(J)=PRED(I)
6670          IF(ICOLR(1).EQ.MAXCP2)Y1(J)=RES(I)
6671          IF(ICOLR(1).EQ.MAXCP3)Y1(J)=YPLOT(I)
6672          IF(ICOLR(1).EQ.MAXCP4)Y1(J)=XPLOT(I)
6673          IF(ICOLR(1).EQ.MAXCP5)Y1(J)=X2PLOT(I)
6674          IF(ICOLR(1).EQ.MAXCP6)Y1(J)=TAGPLO(I)
6675C
6676C         CENSORING VARIABLE IN XCENS
6677C
6678          ICOLC=1
6679          IF(ICENSO.EQ.'ON')THEN
6680            ICOLC=ICOLC+1
6681            ICOLT=ICOLR(ICOLC)
6682            IJ=MAXN*(ICOLT-1)+I
6683            IF(ICOLT.LE.MAXCOL)XCENS(J)=V(IJ)
6684            IF(ICOLT.EQ.MAXCP1)XCENS(J)=PRED(I)
6685            IF(ICOLT.EQ.MAXCP2)XCENS(J)=RES(I)
6686            IF(ICOLT.EQ.MAXCP3)XCENS(J)=YPLOT(I)
6687            IF(ICOLT.EQ.MAXCP4)XCENS(J)=XPLOT(I)
6688            IF(ICOLT.EQ.MAXCP5)XCENS(J)=X2PLOT(I)
6689            IF(ICOLT.EQ.MAXCP6)XCENS(J)=TAGPLO(I)
6690          ENDIF
6691C
6692C         CLASS VARIABLE IN X1 FOR FREQUENCY DATA
6693C
6694          IF(NGROUP.GE.1)THEN
6695            ICOLC=ICOLC+1
6696            ICOLT=ICOLR(ICOLC)
6697            IJ=MAXN*(ICOLT-1)+I
6698            IF(ICOLT.LE.MAXCOL)X1(J)=V(IJ)
6699            IF(ICOLT.EQ.MAXCP1)X1(J)=PRED(I)
6700            IF(ICOLT.EQ.MAXCP2)X1(J)=RES(I)
6701            IF(ICOLT.EQ.MAXCP3)X1(J)=YPLOT(I)
6702            IF(ICOLT.EQ.MAXCP4)X1(J)=XPLOT(I)
6703            IF(ICOLT.EQ.MAXCP5)X1(J)=X2PLOT(I)
6704            IF(ICOLT.EQ.MAXCP6)X1(J)=TAGPLO(I)
6705          ENDIF
6706C
6707C         IF FREQUENCY DATA GIVEN WITH LOWER AND UPPER CLASS LIMITS,
6708C         THEN UPPER CLASS LIMIT VARIABLE IN XHIGH
6709C
6710          IF(NGROUP.EQ.2)THEN
6711            ICOLC=ICOLC+1
6712            ICOLT=ICOLR(ICOLC)
6713            IJ=MAXN*(ICOLT-1)+I
6714            IF(ICOLT.LE.MAXCOL)XHIGH(J)=V(IJ)
6715            IF(ICOLT.EQ.MAXCP1)XHIGH(J)=PRED(I)
6716            IF(ICOLT.EQ.MAXCP2)XHIGH(J)=RES(I)
6717            IF(ICOLT.EQ.MAXCP3)XHIGH(J)=YPLOT(I)
6718            IF(ICOLT.EQ.MAXCP4)XHIGH(J)=XPLOT(I)
6719            IF(ICOLT.EQ.MAXCP5)XHIGH(J)=X2PLOT(I)
6720            IF(ICOLT.EQ.MAXCP6)XHIGH(J)=TAGPLO(I)
6721          ENDIF
6722C
6723          DO920IR=1,MIN(NREPL,6)
6724            ICOLC=ICOLC+1
6725            ICOLT=ICOLR(ICOLC)
6726            IJ=MAXN*(ICOLT-1)+I
6727            IF(ICOLT.LE.MAXCOL)XDESGN(J,IR)=V(IJ)
6728            IF(ICOLT.EQ.MAXCP1)XDESGN(J,IR)=PRED(I)
6729            IF(ICOLT.EQ.MAXCP2)XDESGN(J,IR)=RES(I)
6730            IF(ICOLT.EQ.MAXCP3)XDESGN(J,IR)=YPLOT(I)
6731            IF(ICOLT.EQ.MAXCP4)XDESGN(J,IR)=XPLOT(I)
6732            IF(ICOLT.EQ.MAXCP5)XDESGN(J,IR)=X2PLOT(I)
6733            IF(ICOLT.EQ.MAXCP6)XDESGN(J,IR)=TAGPLO(I)
6734  920     CONTINUE
6735C
6736  910   CONTINUE
6737        NLOCAL=J
6738C
6739C       *****************************************************
6740C       **  STEP 9B--                                      **
6741C       **  FORM THE VERTICAL AND HORIZONTAL AXIS          **
6742C       **  VALUES Y(.) AND X(.) FOR THE PLOT.             **
6743C       **                                                 **
6744C       **  FOR THIS CASE, WE NEED TO LOOP THROUGH THE     **
6745C       **  VARIOUS REPLICATIONS.                          **
6746C       *****************************************************
6747C
6748        ISTEPN='9B'
6749        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GOFI')
6750     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6751C
6752        IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'GOFI')THEN
6753          WRITE(ICOUT,999)
6754          CALL DPWRST('XXX','BUG ')
6755          WRITE(ICOUT,931)
6756  931     FORMAT('***** FROM THE MIDDLE  OF DPGOFI--')
6757          CALL DPWRST('XXX','BUG ')
6758          WRITE(ICOUT,932)ICASPL,NUMVAR,IDATSW,NLOCAL
6759  932     FORMAT('ICASPL,NUMVAR,IDATSW,NQ = ',
6760     1           A4,I8,2X,A4,I8)
6761          CALL DPWRST('XXX','BUG ')
6762          IF(NLOCAL.GE.1)THEN
6763            DO935I=1,NLOCAL
6764              WRITE(ICOUT,936)I,Y1(I),X1(I),XHIGH(I),XCENS(I),
6765     1                        XDESGN(I,1),XDESGN(I,2)
6766  936         FORMAT('I,Y1(I),X1(I),XHIGH(I),XCENS(I),XDESGN(I,1)',
6767     1               'XDESGN(I,2) = ',I8,6F12.5)
6768              CALL DPWRST('XXX','BUG ')
6769  935       CONTINUE
6770          ENDIF
6771        ENDIF
6772C
6773C       *****************************************************
6774C       **  STEP 9C--                                      **
6775C       **  FIND THE DISTINCT VALUES IN EACH OF THE        **
6776C       **  REPLICATION VARIABLES.                         **
6777C       *****************************************************
6778C
6779        CALL DPPP5(XDESGN(1,1),XDESGN(1,2),XDESGN(1,3),
6780     1             XDESGN(1,4),XDESGN(1,5),XDESGN(1,6),
6781     1             NREPL,NLOCAL,MAXOBV,
6782     1             XIDTEM,XIDTE2,XIDTE3,XIDTE4,XIDTE5,XIDTE6,
6783     1             XTEMP1,XTEMP2,
6784     1             NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,NUMSE6,
6785     1             IBUGA3,ISUBRO,IERROR)
6786C
6787C       *****************************************************
6788C       **  STEP 9D--                                      **
6789C       **  NOW LOOP THROUGH THE VARIOUS REPLICATIONS      **
6790C       *****************************************************
6791C
6792        NPLOTP=0
6793        NCURVE=0
6794        IF(NREPL.EQ.1)THEN
6795          J=0
6796          DO1110ISET1=1,NUMSE1
6797            K=0
6798            PID(2)=XIDTEM(ISET1)
6799            DO1130I=1,NLOCAL
6800              IF(XIDTEM(ISET1).EQ.XDESGN(I,1))THEN
6801                K=K+1
6802                ZY(K)=Y1(I)
6803                ZXLOW(K)=X1(I)
6804                ZXHIGH(K)=XHIGH(I)
6805                ZCENS(K)=XCENS(I)
6806              ENDIF
6807 1130       CONTINUE
6808            NTEMP=K
6809            NCURVE=NCURVE+1
6810            NPLOT1=NPLOTP
6811            IF(NGROUP.EQ.0)THEN
6812              IF(NTEMP.GT.0)THEN
6813                CALL DPGOF2(ZY,ZCENS,XLEVEL,NTEMP,ICASPL,ICASP2,
6814     1                      PID,IVARID,IVARI2,NREPL,
6815     1                      XTEMP1,XTEMP2,NOUT,
6816     1                      TEMP1,TEMP2,TEMP3,
6817     1                      DTEMP,DTEMP2,DTEMP3,ITEMP1,
6818     1                      ZTEMP1,ZTEMP2,ZTEMP3,ZTEMP4,ZTEMP5,
6819     1                      ZTEMP6,ZTEMP7,ZTEMP8,ZTEMP9,ZTMP10,ZTMP11,
6820     1                      YLOWLM,YUPPLM,A,B,MINMAX,
6821     1                      SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5,
6822     1                      SHAPE6,SHAPE7,NUMSHA,
6823     1                      SHAP11,SHAP12,SHAP21,SHAP22,
6824     1                      IADEDF,IGEPDF,IMAKDF,IBEIDF,
6825     1                      ILGADF,ISKNDF,IGLDDF,IBGEDF,IGETDF,ICONDF,
6826     1                      IGOMDF,IKATDF,IGIGDF,IGEODF,IGAUDF,
6827     1                      IEXPBC,IWEIBC,ICENTY,IDFTTY,
6828     1                      IFLAGL,AL,
6829     1                      IDIST,MAXOBV,ICENSO,NMCSAM,NSAVE,
6830     1                      KSLOC,KSSCAL,ICAPSW,ICAPTY,IRTFFF,IRTFFP,
6831     1                      IKSCVM,IADCVM,IFORSW,ISEED,IGOFFS,IGOFFM,
6832     1                      IPPLDP,IMETHD,IPPCBW,IPPCCC,IPPCFO,
6833     1                      IPPCDP,IPPCAP,IPPCAO,PCHSLM,ILEVEL,
6834     1                      CLLIMI,CLWIDT,IHSTCW,IHSTOU,IRELAT,IRHSTG,
6835     1                      STATVA,STATCD,PVAL,CDF1,CDF2,CDF3,CDF4,
6836     1                      IBUGA3,ISUBRO,IERROR)
6837              ENDIF
6838            ELSE
6839              IF(NTEMP.GT.0)THEN
6840                CALL DPGOF3(ZY,ZCENS,ZXLOW,ZXHIGH,NTEMP,
6841     1                      ICASPL,ICASP2,IDATSW,
6842     1                      PID,IVARID,IVARI2,NREPL,MINSZ,PCHSLM,
6843     1                      XTEMP1,XTEMP2,ZTEMP1,ZTEMP2,
6844     1                      TEMP1,TEMP2,TEMP3,ZTEMP3,ZTEMP4,
6845     1                      ZTEMP5,ZTEMP6,ZTEMP7,
6846     1                      DTEMP,DTEMP2,DTEMP3,ITEMP1,
6847     1                      NOUT,YLOWLM,YUPPLM,A,B,MINMAX,
6848     1                      SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5,
6849     1                      SHAPE6,SHAPE7,NUMSHA,
6850     1                      IADEDF,IGEPDF,IMAKDF,IBEIDF,
6851     1                      ILGADF,ISKNDF,IGLDDF,IBGEDF,
6852     1                      IGETDF,ICONDF,IGOMDF,IKATDF,
6853     1                      IGIGDF,IGEODF,IGAUDF,
6854     1                      IEXPBC,IWEIBC,ICENTY,IDFTTY,
6855     1                      IDIST,MAXOBV,ICENSO,NMCSAM,NSAVE,
6856     1                      KSLOC,KSSCAL,ICAPSW,ICAPTY,
6857     1                      IKSCVM,IADCVM,IFORSW,ISEED,IGOFFS,IMETHD,
6858     1                      IRHSTG,IHSTCW,CLWIDT,CLLIMI,IHSTOU,
6859     1                      STATVA,STATCD,PVAL,CDF1,CDF2,CDF3,CDF4,
6860     1                      IBUGA3,ISUBRO,IERROR)
6861              ENDIF
6862            ENDIF
6863            NPLOT2=NPLOTP
6864            IFLAGU='FILE'
6865            IFRST=.FALSE.
6866            ILAST=.FALSE.
6867            IF(NCURVE.EQ.1)IFRST=.TRUE.
6868            IF(NCURVE.EQ.NUMSE1)ILAST=.TRUE.
6869            NPTEMP=NPLOT2-NPLOT1
6870            CALL DPGOF4(STATVAL,STATCD,PVAL,CDF1,CDF2,CDF3,CDF4,
6871     1                  IFLAGU,IFRST,ILAST,ICASP2,
6872     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
6873 1110     CONTINUE
6874        ELSEIF(NREPL.EQ.2)THEN
6875          J=0
6876          NTOT=NUMSE1*NUMSE2
6877          DO1210ISET1=1,NUMSE1
6878          DO1220ISET2=1,NUMSE2
6879            K=0
6880            PID(2)=XIDTEM(ISET1)
6881            PID(3)=XIDTE2(ISET2)
6882            DO1290I=1,NLOCAL
6883              IF(
6884     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
6885     1           XIDTE2(ISET2).EQ.XDESGN(I,2)
6886     1          )THEN
6887                K=K+1
6888                ZY(K)=Y1(I)
6889                ZXLOW(K)=X1(I)
6890                ZXHIGH(K)=XHIGH(I)
6891                ZCENS(K)=XCENS(I)
6892              ENDIF
6893 1290       CONTINUE
6894            NTEMP=K
6895            NCURVE=NCURVE+1
6896            NPLOT1=NPLOTP
6897            IF(NGROUP.EQ.0)THEN
6898              IF(NTEMP.GT.0)THEN
6899                CALL DPGOF2(ZY,ZCENS,XLEVEL,NTEMP,ICASPL,ICASP2,
6900     1                      PID,IVARID,IVARI2,NREPL,
6901     1                      XTEMP1,XTEMP2,NOUT,
6902     1                      TEMP1,TEMP2,TEMP3,
6903     1                      DTEMP,DTEMP2,DTEMP3,ITEMP1,
6904     1                      ZTEMP1,ZTEMP2,ZTEMP3,ZTEMP4,ZTEMP5,
6905     1                      ZTEMP6,ZTEMP7,ZTEMP8,ZTEMP9,ZTMP10,ZTMP11,
6906     1                      YLOWLM,YUPPLM,A,B,MINMAX,
6907     1                      SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5,
6908     1                      SHAPE6,SHAPE7,NUMSHA,
6909     1                      SHAP11,SHAP12,SHAP21,SHAP22,
6910     1                      IADEDF,IGEPDF,IMAKDF,IBEIDF,
6911     1                      ILGADF,ISKNDF,IGLDDF,IBGEDF,IGETDF,ICONDF,
6912     1                      IGOMDF,IKATDF,IGIGDF,IGEODF,IGAUDF,
6913     1                      IEXPBC,IWEIBC,ICENTY,IDFTTY,
6914     1                      IFLAGL,AL,
6915     1                      IDIST,MAXOBV,ICENSO,NMCSAM,NSAVE,
6916     1                      KSLOC,KSSCAL,ICAPSW,ICAPTY,IRTFFF,IRTFFP,
6917     1                      IKSCVM,IADCVM,IFORSW,ISEED,IGOFFS,IGOFFM,
6918     1                      IPPLDP,IMETHD,IPPCBW,IPPCCC,IPPCFO,
6919     1                      IPPCDP,IPPCAP,IPPCAO,PCHSLM,ILEVEL,
6920     1                      CLLIMI,CLWIDT,IHSTCW,IHSTOU,IRELAT,IRHSTG,
6921     1                      STATVA,STATCD,PVAL,CDF1,CDF2,CDF3,CDF4,
6922     1                      IBUGA3,ISUBRO,IERROR)
6923              ENDIF
6924            ELSE
6925              IF(NTEMP.GT.0)THEN
6926                CALL DPGOF3(ZY,ZCENS,ZXLOW,ZXHIGH,NTEMP,
6927     1                      ICASPL,ICASP2,IDATSW,
6928     1                      PID,IVARID,IVARI2,NREPL,MINSZ,PCHSLM,
6929     1                      XTEMP1,XTEMP2,ZTEMP1,ZTEMP2,
6930     1                      TEMP1,TEMP2,TEMP3,ZTEMP3,ZTEMP4,
6931     1                      ZTEMP5,ZTEMP6,ZTEMP7,
6932     1                      DTEMP,DTEMP2,DTEMP3,ITEMP1,
6933     1                      NOUT,YLOWLM,YUPPLM,A,B,MINMAX,
6934     1                      SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5,
6935     1                      SHAPE6,SHAPE7,NUMSHA,
6936     1                      IADEDF,IGEPDF,IMAKDF,IBEIDF,
6937     1                      ILGADF,ISKNDF,IGLDDF,IBGEDF,
6938     1                      IGETDF,ICONDF,IGOMDF,IKATDF,
6939     1                      IGIGDF,IGEODF,IGAUDF,
6940     1                      IEXPBC,IWEIBC,ICENTY,IDFTTY,
6941     1                      IDIST,MAXOBV,ICENSO,NMCSAM,NSAVE,
6942     1                      KSLOC,KSSCAL,ICAPSW,ICAPTY,
6943     1                      IKSCVM,IADCVM,IFORSW,ISEED,IGOFFS,IMETHD,
6944     1                      IRHSTG,IHSTCW,CLWIDT,CLLIMI,IHSTOU,
6945     1                      STATVA,STATCD,PVAL,CDF1,CDF2,CDF3,CDF4,
6946     1                      IBUGA3,ISUBRO,IERROR)
6947              ENDIF
6948            ENDIF
6949            NPLOT2=NPLOTP
6950            IFLAGU='FILE'
6951            IFRST=.FALSE.
6952            ILAST=.FALSE.
6953            IF(NCURVE.EQ.1)IFRST=.TRUE.
6954            IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
6955            NPTEMP=NPLOT2-NPLOT1
6956            CALL DPGOF4(STATVA,STATCD,PVAL,CDF1,CDF2,CDF3,CDF4,
6957     1                  IFLAGU,IFRST,ILAST,ICASP2,
6958     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
6959 1220     CONTINUE
6960 1210     CONTINUE
6961        ELSEIF(NREPL.EQ.3)THEN
6962          J=0
6963          NTOT=NUMSE1*NUMSE2*NUMSE3
6964          DO1310ISET1=1,NUMSE1
6965          DO1320ISET2=1,NUMSE2
6966          DO1330ISET3=1,NUMSE3
6967            K=0
6968            PID(2)=XIDTEM(ISET1)
6969            PID(3)=XIDTE2(ISET2)
6970            PID(4)=XIDTE3(ISET3)
6971            DO1390I=1,NLOCAL
6972              IF(
6973     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
6974     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
6975     1           XIDTE3(ISET3).EQ.XDESGN(I,3)
6976     1          )THEN
6977                K=K+1
6978                ZY(K)=Y1(I)
6979                ZXLOW(K)=X1(I)
6980                ZXHIGH(K)=XHIGH(I)
6981                ZCENS(K)=XCENS(I)
6982              ENDIF
6983 1390       CONTINUE
6984            NTEMP=K
6985            NCURVE=NCURVE+1
6986            NPLOT1=NPLOTP
6987            IF(NGROUP.EQ.0)THEN
6988              IF(NTEMP.GT.0)THEN
6989                CALL DPGOF2(ZY,ZCENS,XLEVEL,NTEMP,ICASPL,ICASP2,
6990     1                      PID,IVARID,IVARI2,NREPL,
6991     1                      XTEMP1,XTEMP2,NOUT,
6992     1                      TEMP1,TEMP2,TEMP3,
6993     1                      DTEMP,DTEMP2,DTEMP3,ITEMP1,
6994     1                      ZTEMP1,ZTEMP2,ZTEMP3,ZTEMP4,ZTEMP5,
6995     1                      ZTEMP6,ZTEMP7,ZTEMP8,ZTEMP9,ZTMP10,ZTMP11,
6996     1                      YLOWLM,YUPPLM,A,B,MINMAX,
6997     1                      SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5,
6998     1                      SHAPE6,SHAPE7,NUMSHA,
6999     1                      SHAP11,SHAP12,SHAP21,SHAP22,
7000     1                      IADEDF,IGEPDF,IMAKDF,IBEIDF,
7001     1                      ILGADF,ISKNDF,IGLDDF,IBGEDF,IGETDF,ICONDF,
7002     1                      IGOMDF,IKATDF,IGIGDF,IGEODF,IGAUDF,
7003     1                      IEXPBC,IWEIBC,ICENTY,IDFTTY,
7004     1                      IFLAGL,AL,
7005     1                      IDIST,MAXOBV,ICENSO,NMCSAM,NSAVE,
7006     1                      KSLOC,KSSCAL,ICAPSW,ICAPTY,IRTFFF,IRTFFP,
7007     1                      IKSCVM,IADCVM,IFORSW,ISEED,IGOFFS,IGOFFM,
7008     1                      IPPLDP,IMETHD,IPPCBW,IPPCCC,IPPCFO,
7009     1                      IPPCDP,IPPCAP,IPPCAO,PCHSLM,ILEVEL,
7010     1                      CLLIMI,CLWIDT,IHSTCW,IHSTOU,IRELAT,IRHSTG,
7011     1                      STATVA,STATCD,PVAL,CDF1,CDF2,CDF3,CDF4,
7012     1                      IBUGA3,ISUBRO,IERROR)
7013              ENDIF
7014            ELSE
7015              IF(NTEMP.GT.0)THEN
7016                CALL DPGOF3(ZY,ZCENS,ZXLOW,ZXHIGH,NTEMP,
7017     1                      ICASPL,ICASP2,IDATSW,
7018     1                      PID,IVARID,IVARI2,NREPL,MINSZ,PCHSLM,
7019     1                      XTEMP1,XTEMP2,ZTEMP1,ZTEMP2,
7020     1                      TEMP1,TEMP2,TEMP3,ZTEMP3,ZTEMP4,
7021     1                      ZTEMP5,ZTEMP6,ZTEMP7,
7022     1                      DTEMP,DTEMP2,DTEMP3,ITEMP1,
7023     1                      NOUT,YLOWLM,YUPPLM,A,B,MINMAX,
7024     1                      SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5,
7025     1                      SHAPE6,SHAPE7,NUMSHA,
7026     1                      IADEDF,IGEPDF,IMAKDF,IBEIDF,
7027     1                      ILGADF,ISKNDF,IGLDDF,IBGEDF,
7028     1                      IGETDF,ICONDF,IGOMDF,IKATDF,
7029     1                      IGIGDF,IGEODF,IGAUDF,
7030     1                      IEXPBC,IWEIBC,ICENTY,IDFTTY,
7031     1                      IDIST,MAXOBV,ICENSO,NMCSAM,NSAVE,
7032     1                      KSLOC,KSSCAL,ICAPSW,ICAPTY,
7033     1                      IKSCVM,IADCVM,IFORSW,ISEED,IGOFFS,IMETHD,
7034     1                      IRHSTG,IHSTCW,CLWIDT,CLLIMI,IHSTOU,
7035     1                      STATVA,STATCD,PVAL,CDF1,CDF2,CDF3,CDF4,
7036     1                      IBUGA3,ISUBRO,IERROR)
7037              ENDIF
7038            ENDIF
7039            NPLOT2=NPLOTP
7040            IFLAGU='FILE'
7041            IFRST=.FALSE.
7042            ILAST=.FALSE.
7043            IF(NCURVE.EQ.1)IFRST=.TRUE.
7044            IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
7045            NPTEMP=NPLOT2-NPLOT1
7046            CALL DPGOF4(STATVA,STATCD,PVAL,CDF1,CDF2,CDF3,CDF4,
7047     1                  IFLAGU,IFRST,ILAST,ICASP2,
7048     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
7049 1330     CONTINUE
7050 1320     CONTINUE
7051 1310     CONTINUE
7052        ELSEIF(NREPL.EQ.4)THEN
7053          J=0
7054          NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4
7055          DO1410ISET1=1,NUMSE1
7056          DO1420ISET2=1,NUMSE2
7057          DO1430ISET3=1,NUMSE3
7058          DO1440ISET4=1,NUMSE4
7059            K=0
7060            PID(2)=XIDTEM(ISET1)
7061            PID(3)=XIDTE2(ISET2)
7062            PID(4)=XIDTE3(ISET3)
7063            PID(5)=XIDTE4(ISET4)
7064            DO1490I=1,NLOCAL
7065              IF(
7066     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
7067     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
7068     1           XIDTE3(ISET3).EQ.XDESGN(I,3) .AND.
7069     1           XIDTE4(ISET4).EQ.XDESGN(I,4)
7070     1          )THEN
7071                K=K+1
7072                ZY(K)=Y1(I)
7073                ZXLOW(K)=X1(I)
7074                ZXHIGH(K)=XHIGH(I)
7075                ZCENS(K)=XCENS(I)
7076              ENDIF
7077 1490       CONTINUE
7078            NTEMP=K
7079            NCURVE=NCURVE+1
7080            NPLOT1=NPLOTP
7081            IF(NGROUP.EQ.0)THEN
7082              IF(NTEMP.GT.0)THEN
7083                CALL DPGOF2(ZY,ZCENS,XLEVEL,NTEMP,ICASPL,ICASP2,
7084     1                      PID,IVARID,IVARI2,NREPL,
7085     1                      XTEMP1,XTEMP2,NOUT,
7086     1                      TEMP1,TEMP2,TEMP3,
7087     1                      DTEMP,DTEMP2,DTEMP3,ITEMP1,
7088     1                      ZTEMP1,ZTEMP2,ZTEMP3,ZTEMP4,ZTEMP5,
7089     1                      ZTEMP6,ZTEMP7,ZTEMP8,ZTEMP9,ZTMP10,ZTMP11,
7090     1                      YLOWLM,YUPPLM,A,B,MINMAX,
7091     1                      SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5,
7092     1                      SHAPE6,SHAPE7,NUMSHA,
7093     1                      SHAP11,SHAP12,SHAP21,SHAP22,
7094     1                      IADEDF,IGEPDF,IMAKDF,IBEIDF,
7095     1                      ILGADF,ISKNDF,IGLDDF,IBGEDF,IGETDF,ICONDF,
7096     1                      IGOMDF,IKATDF,IGIGDF,IGEODF,IGAUDF,
7097     1                      IEXPBC,IWEIBC,ICENTY,IDFTTY,
7098     1                      IFLAGL,AL,
7099     1                      IDIST,MAXOBV,ICENSO,NMCSAM,NSAVE,
7100     1                      KSLOC,KSSCAL,ICAPSW,ICAPTY,IRTFFF,IRTFFP,
7101     1                      IKSCVM,IADCVM,IFORSW,ISEED,IGOFFS,IGOFFM,
7102     1                      IPPLDP,IMETHD,IPPCBW,IPPCCC,IPPCFO,
7103     1                      IPPCDP,IPPCAP,IPPCAO,PCHSLM,ILEVEL,
7104     1                      CLLIMI,CLWIDT,IHSTCW,IHSTOU,IRELAT,IRHSTG,
7105     1                      STATVA,STATCD,PVAL,CDF1,CDF2,CDF3,CDF4,
7106     1                      IBUGA3,ISUBRO,IERROR)
7107              ENDIF
7108            ELSE
7109              IF(NTEMP.GT.0)THEN
7110                CALL DPGOF3(ZY,ZCENS,ZXLOW,ZXHIGH,NTEMP,
7111     1                      ICASPL,ICASP2,IDATSW,
7112     1                      PID,IVARID,IVARI2,NREPL,MINSZ,PCHSLM,
7113     1                      XTEMP1,XTEMP2,ZTEMP1,ZTEMP2,
7114     1                      TEMP1,TEMP2,TEMP3,ZTEMP3,ZTEMP4,
7115     1                      ZTEMP5,ZTEMP6,ZTEMP7,
7116     1                      DTEMP,DTEMP2,DTEMP3,ITEMP1,
7117     1                      NOUT,YLOWLM,YUPPLM,A,B,MINMAX,
7118     1                      SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5,
7119     1                      SHAPE6,SHAPE7,NUMSHA,
7120     1                      IADEDF,IGEPDF,IMAKDF,IBEIDF,
7121     1                      ILGADF,ISKNDF,IGLDDF,IBGEDF,
7122     1                      IGETDF,ICONDF,IGOMDF,IKATDF,
7123     1                      IGIGDF,IGEODF,IGAUDF,
7124     1                      IEXPBC,IWEIBC,ICENTY,IDFTTY,
7125     1                      IDIST,MAXOBV,ICENSO,NMCSAM,NSAVE,
7126     1                      KSLOC,KSSCAL,ICAPSW,ICAPTY,
7127     1                      IKSCVM,IADCVM,IFORSW,ISEED,IGOFFS,IMETHD,
7128     1                      IRHSTG,IHSTCW,CLWIDT,CLLIMI,IHSTOU,
7129     1                      STATVA,STATCD,PVAL,CDF1,CDF2,CDF3,CDF4,
7130     1                      IBUGA3,ISUBRO,IERROR)
7131              ENDIF
7132            ENDIF
7133            NPLOT2=NPLOTP
7134            IFLAGU='FILE'
7135            IFRST=.FALSE.
7136            ILAST=.FALSE.
7137            IF(NCURVE.EQ.1)IFRST=.TRUE.
7138            IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
7139            NPTEMP=NPLOT2-NPLOT1
7140            CALL DPGOF4(STATVA,STATCD,PVAL,CDF1,CDF2,CDF3,CDF4,
7141     1                  IFLAGU,IFRST,ILAST,ICASP2,
7142     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
7143 1440     CONTINUE
7144 1430     CONTINUE
7145 1420     CONTINUE
7146 1410     CONTINUE
7147        ELSEIF(NREPL.EQ.5)THEN
7148          J=0
7149          NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5
7150          DO1510ISET1=1,NUMSE1
7151          DO1520ISET2=1,NUMSE2
7152          DO1530ISET3=1,NUMSE3
7153          DO1540ISET4=1,NUMSE4
7154          DO1550ISET5=1,NUMSE5
7155            K=0
7156            PID(2)=XIDTEM(ISET1)
7157            PID(3)=XIDTE2(ISET2)
7158            PID(4)=XIDTE3(ISET3)
7159            PID(5)=XIDTE4(ISET4)
7160            PID(6)=XIDTE5(ISET5)
7161            DO1590I=1,NLOCAL
7162              IF(
7163     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
7164     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
7165     1           XIDTE3(ISET3).EQ.XDESGN(I,3) .AND.
7166     1           XIDTE4(ISET4).EQ.XDESGN(I,4) .AND.
7167     1           XIDTE5(ISET5).EQ.XDESGN(I,5)
7168     1          )THEN
7169                K=K+1
7170                ZY(K)=Y1(I)
7171                ZXLOW(K)=X1(I)
7172                ZXHIGH(K)=XHIGH(I)
7173                ZCENS(K)=XCENS(I)
7174              ENDIF
7175 1590       CONTINUE
7176            NTEMP=K
7177            NCURVE=NCURVE+1
7178            NPLOT1=NPLOTP
7179            IF(NGROUP.EQ.0)THEN
7180              IF(NTEMP.GT.0)THEN
7181                CALL DPGOF2(ZY,ZCENS,XLEVEL,NTEMP,ICASPL,ICASP2,
7182     1                      PID,IVARID,IVARI2,NREPL,
7183     1                      XTEMP1,XTEMP2,NOUT,
7184     1                      TEMP1,TEMP2,TEMP3,
7185     1                      DTEMP,DTEMP2,DTEMP3,ITEMP1,
7186     1                      ZTEMP1,ZTEMP2,ZTEMP3,ZTEMP4,ZTEMP5,
7187     1                      ZTEMP6,ZTEMP7,ZTEMP8,ZTEMP9,ZTMP10,ZTMP11,
7188     1                      YLOWLM,YUPPLM,A,B,MINMAX,
7189     1                      SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5,
7190     1                      SHAPE6,SHAPE7,NUMSHA,
7191     1                      SHAP11,SHAP12,SHAP21,SHAP22,
7192     1                      IADEDF,IGEPDF,IMAKDF,IBEIDF,
7193     1                      ILGADF,ISKNDF,IGLDDF,IBGEDF,IGETDF,ICONDF,
7194     1                      IGOMDF,IKATDF,IGIGDF,IGEODF,IGAUDF,
7195     1                      IEXPBC,IWEIBC,ICENTY,IDFTTY,
7196     1                      IFLAGL,AL,
7197     1                      IDIST,MAXOBV,ICENSO,NMCSAM,NSAVE,
7198     1                      KSLOC,KSSCAL,ICAPSW,ICAPTY,IRTFFF,IRTFFP,
7199     1                      IKSCVM,IADCVM,IFORSW,ISEED,IGOFFS,IGOFFM,
7200     1                      IPPLDP,IMETHD,IPPCBW,IPPCCC,IPPCFO,
7201     1                      IPPCDP,IPPCAP,IPPCAO,PCHSLM,ILEVEL,
7202     1                      CLLIMI,CLWIDT,IHSTCW,IHSTOU,IRELAT,IRHSTG,
7203     1                      STATVA,STATCD,PVAL,CDF1,CDF2,CDF3,CDF4,
7204     1                      IBUGA3,ISUBRO,IERROR)
7205              ENDIF
7206            ELSE
7207              IF(NTEMP.GT.0)THEN
7208                CALL DPGOF3(ZY,ZCENS,ZXLOW,ZXHIGH,NTEMP,
7209     1                      ICASPL,ICASP2,IDATSW,
7210     1                      PID,IVARID,IVARI2,NREPL,MINSZ,PCHSLM,
7211     1                      XTEMP1,XTEMP2,ZTEMP1,ZTEMP2,
7212     1                      TEMP1,TEMP2,TEMP3,ZTEMP3,ZTEMP4,
7213     1                      ZTEMP5,ZTEMP6,ZTEMP7,
7214     1                      DTEMP,DTEMP2,DTEMP3,ITEMP1,
7215     1                      NOUT,YLOWLM,YUPPLM,A,B,MINMAX,
7216     1                      SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5,
7217     1                      SHAPE6,SHAPE7,NUMSHA,
7218     1                      IADEDF,IGEPDF,IMAKDF,IBEIDF,
7219     1                      ILGADF,ISKNDF,IGLDDF,IBGEDF,
7220     1                      IGETDF,ICONDF,IGOMDF,IKATDF,
7221     1                      IGIGDF,IGEODF,IGAUDF,
7222     1                      IEXPBC,IWEIBC,ICENTY,IDFTTY,
7223     1                      IDIST,MAXOBV,ICENSO,NMCSAM,NSAVE,
7224     1                      KSLOC,KSSCAL,ICAPSW,ICAPTY,
7225     1                      IKSCVM,IADCVM,IFORSW,ISEED,IGOFFS,IMETHD,
7226     1                      IRHSTG,IHSTCW,CLWIDT,CLLIMI,IHSTOU,
7227     1                      STATVA,STATCD,PVAL,CDF1,CDF2,CDF3,CDF4,
7228     1                      IBUGA3,ISUBRO,IERROR)
7229              ENDIF
7230            ENDIF
7231            NPLOT2=NPLOTP
7232            IFLAGU='FILE'
7233            IFRST=.FALSE.
7234            ILAST=.FALSE.
7235            IF(NCURVE.EQ.1)IFRST=.TRUE.
7236            IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
7237            NPTEMP=NPLOT2-NPLOT1
7238            CALL DPGOF4(STATVA,STATCD,PVAL,CDF1,CDF2,CDF3,CDF4,
7239     1                  IFLAGU,IFRST,ILAST,ICASP2,
7240     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
7241 1550     CONTINUE
7242 1540     CONTINUE
7243 1530     CONTINUE
7244 1520     CONTINUE
7245 1510     CONTINUE
7246        ELSEIF(NREPL.EQ.6)THEN
7247          J=0
7248          NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5*NUMSE6
7249          DO1610ISET1=1,NUMSE1
7250          DO1620ISET2=1,NUMSE2
7251          DO1630ISET3=1,NUMSE3
7252          DO1640ISET4=1,NUMSE4
7253          DO1650ISET5=1,NUMSE5
7254          DO1660ISET6=1,NUMSE6
7255            K=0
7256            PID(2)=XIDTEM(ISET1)
7257            PID(3)=XIDTE2(ISET2)
7258            PID(4)=XIDTE3(ISET3)
7259            PID(5)=XIDTE4(ISET4)
7260            PID(6)=XIDTE5(ISET5)
7261            PID(7)=XIDTE6(ISET6)
7262            DO1690I=1,NLOCAL
7263              IF(
7264     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
7265     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
7266     1           XIDTE3(ISET3).EQ.XDESGN(I,3) .AND.
7267     1           XIDTE4(ISET4).EQ.XDESGN(I,4) .AND.
7268     1           XIDTE5(ISET5).EQ.XDESGN(I,5) .AND.
7269     1           XIDTE6(ISET6).EQ.XDESGN(I,6)
7270     1          )THEN
7271                K=K+1
7272                ZY(K)=Y1(I)
7273                ZXLOW(K)=X1(I)
7274                ZXHIGH(K)=XHIGH(I)
7275                ZCENS(K)=XCENS(I)
7276              ENDIF
7277 1690       CONTINUE
7278            NTEMP=K
7279            NCURVE=NCURVE+1
7280            NPLOT1=NPLOTP
7281            IF(NGROUP.EQ.0)THEN
7282              IF(NTEMP.GT.0)THEN
7283                CALL DPGOF2(ZY,ZCENS,XLEVEL,NTEMP,ICASPL,ICASP2,
7284     1                      PID,IVARID,IVARI2,NREPL,
7285     1                      XTEMP1,XTEMP2,NOUT,
7286     1                      TEMP1,TEMP2,TEMP3,
7287     1                      DTEMP,DTEMP2,DTEMP3,ITEMP1,
7288     1                      ZTEMP1,ZTEMP2,ZTEMP3,ZTEMP4,ZTEMP5,
7289     1                      ZTEMP6,ZTEMP7,ZTEMP8,ZTEMP9,ZTMP10,ZTMP11,
7290     1                      YLOWLM,YUPPLM,A,B,MINMAX,
7291     1                      SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5,
7292     1                      SHAPE6,SHAPE7,NUMSHA,
7293     1                      SHAP11,SHAP12,SHAP21,SHAP22,
7294     1                      IADEDF,IGEPDF,IMAKDF,IBEIDF,
7295     1                      ILGADF,ISKNDF,IGLDDF,IBGEDF,IGETDF,ICONDF,
7296     1                      IGOMDF,IKATDF,IGIGDF,IGEODF,IGAUDF,
7297     1                      IEXPBC,IWEIBC,ICENTY,IDFTTY,
7298     1                      IFLAGL,AL,
7299     1                      IDIST,MAXOBV,ICENSO,NMCSAM,NSAVE,
7300     1                      KSLOC,KSSCAL,ICAPSW,ICAPTY,IRTFFF,IRTFFP,
7301     1                      IKSCVM,IADCVM,IFORSW,ISEED,IGOFFS,IGOFFM,
7302     1                      IPPLDP,IMETHD,IPPCBW,IPPCCC,IPPCFO,
7303     1                      IPPCDP,IPPCAP,IPPCAO,PCHSLM,ILEVEL,
7304     1                      CLLIMI,CLWIDT,IHSTCW,IHSTOU,IRELAT,IRHSTG,
7305     1                      STATVA,STATCD,PVAL,CDF1,CDF2,CDF3,CDF4,
7306     1                      IBUGA3,ISUBRO,IERROR)
7307              ENDIF
7308            ELSE
7309              IF(NTEMP.GT.0)THEN
7310                CALL DPGOF3(ZY,ZCENS,ZXLOW,ZXHIGH,NTEMP,
7311     1                      ICASPL,ICASP2,IDATSW,
7312     1                      PID,IVARID,IVARI2,NREPL,MINSZ,PCHSLM,
7313     1                      XTEMP1,XTEMP2,ZTEMP1,ZTEMP2,
7314     1                      TEMP1,TEMP2,TEMP3,ZTEMP3,ZTEMP4,
7315     1                      ZTEMP5,ZTEMP6,ZTEMP7,
7316     1                      DTEMP,DTEMP2,DTEMP3,ITEMP1,
7317     1                      NOUT,YLOWLM,YUPPLM,A,B,MINMAX,
7318     1                      SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5,
7319     1                      SHAPE6,SHAPE7,NUMSHA,
7320     1                      IADEDF,IGEPDF,IMAKDF,IBEIDF,
7321     1                      ILGADF,ISKNDF,IGLDDF,IBGEDF,
7322     1                      IGETDF,ICONDF,IGOMDF,IKATDF,
7323     1                      IGIGDF,IGEODF,IGAUDF,
7324     1                      IEXPBC,IWEIBC,ICENTY,IDFTTY,
7325     1                      IDIST,MAXOBV,ICENSO,NMCSAM,NSAVE,
7326     1                      KSLOC,KSSCAL,ICAPSW,ICAPTY,
7327     1                      IKSCVM,IADCVM,IFORSW,ISEED,IGOFFS,IMETHD,
7328     1                      IRHSTG,IHSTCW,CLWIDT,CLLIMI,IHSTOU,
7329     1                      STATVA,STATCD,PVAL,CDF1,CDF2,CDF3,CDF4,
7330     1                      IBUGA3,ISUBRO,IERROR)
7331              ENDIF
7332            ENDIF
7333            NPLOT2=NPLOTP
7334            IFLAGU='FILE'
7335            IFRST=.FALSE.
7336            ILAST=.FALSE.
7337            IF(NCURVE.EQ.1)IFRST=.TRUE.
7338            IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
7339            NPTEMP=NPLOT2-NPLOT1
7340            CALL DPGOF4(STATVA,STATCD,PVAL,CDF1,CDF2,CDF3,CDF4,
7341     1                  IFLAGU,IFRST,ILAST,ICASP2,
7342     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
7343 1660     CONTINUE
7344 1650     CONTINUE
7345 1640     CONTINUE
7346 1630     CONTINUE
7347 1620     CONTINUE
7348 1610     CONTINUE
7349        ENDIF
7350C
7351      ENDIF
7352C
7353C               *****************
7354C               **  STEP 90--  **
7355C               **  EXIT       **
7356C               *****************
7357C
7358 9000 CONTINUE
7359C
7360      IRANAL=IRANSV
7361      ISEED=ISEESV
7362      IHSTOU=IHSTO2
7363C
7364      IF(IERROR.EQ.'YES')THEN
7365        IF(IWIDTH.GE.1)THEN
7366          WRITE(ICOUT,9001)(IANS(I),I=1,MIN(100,IWIDTH))
7367 9001     FORMAT(100A1)
7368          CALL DPWRST('XXX','BUG ')
7369        ENDIF
7370      ENDIF
7371C
7372      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'GOFI')THEN
7373        WRITE(ICOUT,999)
7374        CALL DPWRST('XXX','BUG ')
7375        WRITE(ICOUT,9011)
7376 9011   FORMAT('***** AT THE END       OF DPGOFI--')
7377        CALL DPWRST('XXX','BUG ')
7378        WRITE(ICOUT,9012)IFOUND,IERROR,MINMAX
7379 9012   FORMAT('IFOUND,IERROR,MINMAX = ',2(A4,2X),I8)
7380        CALL DPWRST('XXX','BUG ')
7381      ENDIF
7382C
7383      RETURN
7384      END
7385      SUBROUTINE DPGOF2(Y,CENSOR,XLEVEL,N,ICASPL,ICASP2,
7386     1                  PID,IVARID,IVARI2,NREPL,
7387     1                  YTEMP,YSTAT,N2,
7388     1                  TEMP1,TEMP2,TEMP3,DTEMP,DTEMP2,DTEMP3,ITEMP1,
7389     1                  ZTEMP1,ZTEMP2,ZTEMP3,ZTEMP4,ZTEMP5,
7390     1                  ZTEMP6,ZTEMP7,ZTEMP8,ZTEMP9,ZTMP10,ZTMP11,
7391     1                  YLOWLM,YUPPLM,A,B,MINMAX,
7392     1                  SHAPE1,SHAPE2,SHAPE3,SHAPE4,
7393     1                  SHAPE5,SHAPE6,SHAPE7,NUMSHA,
7394     1                  SHAP11,SHAP12,SHAP21,SHAP22,
7395     1                  IADEDF,IGEPDF,IMAKDF,IBEIDF,
7396     1                  ILGADF,ISKNDF,IGLDDF,IBGEDF,IGETDF,ICONDF,
7397     1                  IGOMDF,IKATDF,IGIGDF,IGEODF,IGAUDF,
7398     1                  IEXPBC,IWEIBC,ICENTY,IDFTTY,
7399     1                  IFLAGL,AL,
7400     1                  IDIST,MAXOBV,ICENSO,NMCSAM,NSAVE,
7401     1                  KSLOC,KSSCAL,ICAPSW,ICAPTY,IRTFFF,IRTFFP,
7402     1                  IKSCVM,IADCVM,IFORSW,ISEED,IGOFFS,IGOFFM,
7403     1                  IPPLDP,IMETHD,IPPCBW,IPPCCC,IPPCFO,
7404     1                  IPPCDP,IPPCAP,IPPCAO,PCHSLM,ILEVEL,
7405     1                  CLLIMI,CLWIDT,IHSTCW,IHSTOU,IRELAT,IRHSTG,
7406     1                  STATVA,STATCD,PVAL,CDF1,CDF2,CDF3,CDF4,
7407     1                  IBUGA3,ISUBRO,IERROR)
7408C
7409C     PURPOSE--COMPUTE ONE OF THE FOLLOWING GOODNESS OF FIT TESTS:
7410C              (SOME ARE STILL BEING IMPLEMENTED)
7411C
7412C              1) KOLMOGOROV-SMIRNOV
7413C              2) ANDERSON-DARLING
7414C              3) CHI-SQUARE
7415C              4) AIC/BIC/BICC
7416C              5) PPCC
7417C
7418C              THE STEPS ARE:
7419C
7420C              1) CALL DPGOF9 TO COMPUTE VALUE OF GOODNESS OF FIT
7421C                 STATISTIC
7422C
7423C              2) THERE ARE 2 METHODS FOR COMPUTING CRITICAL VALUES:
7424C
7425C                 A) MONTE CARLO SIMULATION
7426C                 B) FROM TABLE VALUES
7427C
7428C                 COMPUTE RELEVANT CRITICAL VALUES/CONFIDENCE
7429C                 INTERVALS BASED ON THESE METHODS (MONTE CARLO
7430C                 IS MORE GENERAL, BUT SLOWER).  NOTE THAT TABLED
7431C                 VALUES ARE ONLY AVAILABLE FOR A LIMITED NUMBER
7432C                 OF DISTRIBUTIONS FOR THE ANDERSON DARLING.
7433C
7434C                 AS A FURTHER COMPLICATION, THE SIMULATION DEPENDS
7435C                 ON WHETHER WE ASSUME THE "FULLY SPECIFIED" CASE
7436C                 (I.E., PARAMETERS ASSUMED KNOWN) OR THE PARAMETERS
7437C                 ARE ESTIMATED FROM THE DATA.  FOR THE SECOND CASE,
7438C                 WE HAVE TO ESTIMATE THE PARAMETERS FROM EACH OF THE
7439C                 MONTE CARLO SAMPLES.
7440C
7441C              3) PRINT OUTPUT USING
7442C
7443C                 DP1KS3   - FOR K-S STATISTIC
7444C                 DPADA3   - FOR ANDERSON DARLING STATISTIC
7445C                 DPPPC8   - FOR PPCC STATISTIC
7446C
7447C              NOTE THAT CURRENTLY ONLY UNGROUPED AND UNCENSORED DATA
7448C              IS SUPPORTED.  HOWEVER, IT IS ANTICIPATED THAT
7449C              CENSORING AND GROUPING WILL BE ADDED IN A SUBSEQUENT
7450C              UPDATE.
7451C
7452C              NOTE: PPCC OPTION SUPPORTS BOTH CENSORING AND GROUPING.
7453C
7454C                    CHI-SQUARE OPTION SUPPORTS GROUPING, BUT NOT
7455C                    CENSORING.
7456C
7457C     WRITTEN BY--ALAN HECKERT
7458C                 STATISTICAL ENGINEERING DIVISION
7459C                 INFORMATION TECHNOLOGY LABORATORY
7460C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
7461C                 GAITHERSBURG, MD 20899-8980
7462C                 PHONE--301-975-2899
7463C         --DATAPLOT IS A REGISTERED TRADEMARK
7464C           OF THE NATIONAL BUREAU OF STANDARDS.
7465C     LANGUAGE--ANSI FORTRAN (1977)
7466C     VERSION NUMBER--2009/9
7467C     ORIGINAL VERSION--SEPTEMBER 2009.
7468C     UPDATED         --OCTOBER   2009. ACTIVATE PPCC OPTION
7469C     UPDATED         --MAY       2010. IMPLEMENT MONTE CARLO FOR
7470C                                       PPCC OPTION WHEN THERE ARE
7471C                                       SHAPE PARAMETERS
7472C     UPDATED         --JUNE      2011. IF IGOFFM = NULL, ONLY PRINT
7473C                                       SUMMARY TABLE (I.E., VALUE
7474C                                       OF STATISTIC, BUT NO P-VALUES
7475C                                       OR CRITICAL VALUES)
7476C     UPDATED         --MARCH     2013. FOR WEIBULL, ADJUST SCALE
7477C                                       PARAMETER IF GAUGE LENGTH
7478C                                       OPTION SPECIFIED
7479C     UPDATED         --JULY      2019. CALL LIST TO DPPP2
7480C     UPDATED         --JULY      2019. CALL LIST TO DPPPC2
7481C
7482C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
7483C
7484      CHARACTER*4 ICASPL
7485      CHARACTER*4 ICASP2
7486      CHARACTER*4 IVARID(*)
7487      CHARACTER*4 IVARI2(*)
7488      CHARACTER*4 ICAPSW
7489      CHARACTER*4 ICAPTY
7490      CHARACTER*4 IKSCVM
7491      CHARACTER*4 IADCVM
7492      CHARACTER*4 IFORSW
7493      CHARACTER*4 IGOFFS
7494      CHARACTER*4 IGOFFM
7495      CHARACTER*4 IBUGA3
7496      CHARACTER*4 ISUBRO
7497      CHARACTER*4 ICENSO
7498      CHARACTER*4 IADEDF
7499      CHARACTER*4 IGEPDF
7500      CHARACTER*4 IMAKDF
7501      CHARACTER*4 IBEIDF
7502      CHARACTER*4 ILGADF
7503      CHARACTER*4 ISKNDF
7504      CHARACTER*4 IGLDDF
7505      CHARACTER*4 IBGEDF
7506      CHARACTER*4 IGETDF
7507      CHARACTER*4 ICONDF
7508      CHARACTER*4 IGOMDF
7509      CHARACTER*4 IKATDF
7510      CHARACTER*4 IGIGDF
7511      CHARACTER*4 IGEODF
7512      CHARACTER*4 IGAUDF
7513      CHARACTER*4 IEXPBC
7514      CHARACTER*4 IWEIBC
7515      CHARACTER*4 ICENTY
7516      CHARACTER*4 IDFTTY
7517      CHARACTER*4 IPPCCC
7518      CHARACTER*4 IPPCFO
7519      CHARACTER*4 IPPCAO
7520      CHARACTER*4 IPPCBW
7521      CHARACTER*4 IHSTCW
7522      CHARACTER*4 IHSTOU
7523      CHARACTER*4 IRELAT
7524      CHARACTER*4 IRHSTG
7525      CHARACTER*4 IMETHD
7526      CHARACTER*4 ILEVEL
7527      CHARACTER*4 IFOUND
7528      CHARACTER*4 IERROR
7529C
7530      CHARACTER*60 IDIST
7531      CHARACTER*40 IRTFFF
7532      CHARACTER*40 IRTFFP
7533C
7534      CHARACTER*4 IDIR
7535      CHARACTER*4 IFLAGF
7536      CHARACTER*4 IGOFSV
7537      CHARACTER*4 ISUBN1
7538      CHARACTER*4 ISUBN2
7539      CHARACTER*4 IGOFF2
7540      CHARACTER*4 ICASP8
7541      CHARACTER*4 ICASP9
7542C
7543      REAL KSLOC
7544      REAL KSSCAL
7545CCCCC REAL KSSCSV
7546C
7547      DOUBLE PRECISION DM
7548      DOUBLE PRECISION DMTEMP
7549C
7550C---------------------------------------------------------------------
7551C
7552      DIMENSION Y(*)
7553      DIMENSION CENSOR(*)
7554      DIMENSION XLEVEL(*)
7555      DIMENSION YTEMP(*)
7556      DIMENSION YSTAT(*)
7557      DIMENSION PID(*)
7558C
7559      DIMENSION TEMP1(*)
7560      DIMENSION TEMP2(*)
7561      DIMENSION TEMP3(*)
7562      DIMENSION ZTEMP1(*)
7563      DIMENSION ZTEMP2(*)
7564      DIMENSION ZTEMP3(*)
7565      DIMENSION ZTEMP4(*)
7566      DIMENSION ZTEMP5(*)
7567      DIMENSION ZTEMP6(*)
7568      DIMENSION ZTEMP7(*)
7569      DIMENSION ZTEMP8(*)
7570      DIMENSION ZTEMP9(*)
7571      DIMENSION ZTMP10(*)
7572      DIMENSION ZTMP11(*)
7573C
7574      DIMENSION CLWIDT(*)
7575      DIMENSION CLLIMI(*)
7576C
7577      DOUBLE PRECISION DTEMP(*)
7578      DOUBLE PRECISION DTEMP2(*)
7579      DOUBLE PRECISION DTEMP3(*)
7580      INTEGER ITEMP1(*)
7581C
7582      INTEGER IPPCAP(2)
7583C
7584C---------------------------------------------------------------------
7585C
7586      INCLUDE 'DPCOP2.INC'
7587C
7588C-----START POINT-----------------------------------------------------
7589C
7590C
7591      ISUBN1='DPGO'
7592      ISUBN2='F2  '
7593      IERROR='NO'
7594C
7595      STATVA=CPUMIN
7596      STATCD=CPUMIN
7597      PVAL=CPUMIN
7598      CDF1=CPUMIN
7599      CDF2=CPUMIN
7600      CDF3=CPUMIN
7601      CDF4=CPUMIN
7602      SH1NEW=CPUMIN
7603      SH2NEW=CPUMIN
7604      ITYPE=0
7605C
7606      IGOFF2=IGOFFM
7607      IF(IGOFF2.EQ.'DEFA')THEN
7608        IF(ICASP2.EQ.'PPCC')THEN
7609          IGOFF2='PPCC'
7610        ELSEIF(ICASP2.EQ.'AD')THEN
7611          IGOFF2='ML'
7612        ELSEIF(ICASP2.EQ.'KS')THEN
7613          IGOFF2='ML'
7614        ELSEIF(ICASP2.EQ.'AIC')THEN
7615          IGOFF2='ML'
7616        ENDIF
7617      ENDIF
7618C
7619C     OCTOBER 2010: FOR PPCC GOODNES OF FIT, FORCE "FULLY SPECIFIED"
7620C                   OPTION TO BE OFF.  THE PROBABILITY PLOT IS
7621C                   INVARIANT TO LOCATION AND SCALE, SO WE
7622C                   EFFECTIVELY ESTIMATE LOCATION/SCALE FROM THE
7623C                   DATA TO OBTAIN THE PPCC VALUE.
7624C
7625      IGOFSV=IGOFFS
7626      IF(ICASP2.EQ.'PPCC')IGOFFS='OFF'
7627C
7628      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GOF2')THEN
7629        WRITE(ICOUT,999)
7630        CALL DPWRST('XXX','BUG ')
7631        WRITE(ICOUT,11)
7632   11   FORMAT('***** AT THE BEGINNING OF DPGOF2--')
7633        CALL DPWRST('XXX','BUG ')
7634        WRITE(ICOUT,12)ICASPL,ICASP2,N,MINMAX
7635   12   FORMAT('ICASPL,ICASP2,N,MINMAX = ',2(A4,2X),2I8)
7636        CALL DPWRST('XXX','BUG ')
7637        WRITE(ICOUT,15)KSLOC,KSSCAL,ILEVEL
7638   15   FORMAT('KSLOC,KSSCAL,ILEVEL = ',2G15.7,2X,A4)
7639        CALL DPWRST('XXX','BUG ')
7640        WRITE(ICOUT,16)SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5
7641   16   FORMAT('SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5 = ',5G15.7)
7642        CALL DPWRST('XXX','BUG ')
7643        WRITE(ICOUT,17)SHAP11,SHAP12,SHAP21,SHAP22
7644   17   FORMAT('SHAP11,SHAP12,SHAP21,SHAP22 = ',4G15.7)
7645        CALL DPWRST('XXX','BUG ')
7646        IF(N.GE.1)THEN
7647          DO25I=1,N
7648            WRITE(ICOUT,26)I,Y(I),CENSOR(I)
7649   26       FORMAT('I,Y(I),CENSOR(I) = ',I8,2G15.7)
7650            CALL DPWRST('XXX','BUG ')
7651   25     CONTINUE
7652        ENDIF
7653      ENDIF
7654C
7655C               ********************************************
7656C               **  STEP 1--                              **
7657C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
7658C               ********************************************
7659C
7660      IF(N.LT.2)THEN
7661        WRITE(ICOUT,999)
7662  999   FORMAT(1X)
7663        CALL DPWRST('XXX','BUG ')
7664        WRITE(ICOUT,31)
7665   31   FORMAT('***** ERROR IN GOODNESS OF FIT--')
7666        CALL DPWRST('XXX','BUG ')
7667        WRITE(ICOUT,32)
7668   32   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 2.')
7669        CALL DPWRST('XXX','BUG ')
7670        WRITE(ICOUT,34)N
7671   34   FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6)
7672        CALL DPWRST('XXX','BUG ')
7673        WRITE(ICOUT,999)
7674        CALL DPWRST('XXX','BUG ')
7675        IERROR='YES'
7676        GOTO9000
7677      ENDIF
7678C
7679      HOLD=Y(1)
7680      DO60I=1,N
7681        IF(Y(I).NE.HOLD)GOTO69
7682   60 CONTINUE
7683      WRITE(ICOUT,999)
7684      CALL DPWRST('XXX','BUG ')
7685      WRITE(ICOUT,31)
7686      CALL DPWRST('XXX','BUG ')
7687      WRITE(ICOUT,62)HOLD
7688   62 FORMAT('      ALL ELEMENTS OF THE RESPONSE VARIABLE ARE ',
7689     1       'IDENTICALLY EQUAL TO ',G15.7)
7690
7691      CALL DPWRST('XXX','BUG ')
7692      WRITE(ICOUT,999)
7693      CALL DPWRST('XXX','BUG ')
7694      IERROR='YES'
7695      GOTO9000
7696   69 CONTINUE
7697C
7698C               *****************************************
7699C               **  STEP 1--                           **
7700C               **  COMPUTE THE BASIC TEST STATISTIC   **
7701C               *****************************************
7702C
7703      IF(ICENSO.EQ.'ON')THEN
7704        CONTINUE
7705      ELSE
7706        IFLAG=0
7707        CALL SUMRAW(Y,N,IDIST,IFLAG,
7708     1              XMEAN,XVAR,XSD,XMIN,XMAX,
7709     1              ISUBRO,IBUGA3,IERROR)
7710        N2=0
7711        IERRFL=0
7712C
7713        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GOF2')THEN
7714          WRITE(ICOUT,71)XMEAN,XSD,XMIN,XMAX
7715   71     FORMAT('AFTER SUMRAW: XMEAN,XSD,XMIN,XMAX = ',4G15.7)
7716          CALL DPWRST('XXX','BUG ')
7717        ENDIF
7718C
7719        IF(ICASP2.EQ.'PPCC')THEN
7720          NCURVE=1
7721          NJUNK1=0
7722          NJUNK2=0
7723          NHIGH=0
7724          PPLOC=0.0
7725          PPSCAL=1.0
7726CCCCC     KSLOC2=KSLOC
7727CCCCC     KSSCA2=KSSCAL
7728          SHAP1Z=SHAPE1
7729          SHAP2Z=SHAPE2
7730          CALL DPPP2(Y,CENSOR,XLEVEL,N,ICASPL,NHIGH,
7731     1               ZTEMP1,ZTEMP2,ZTEMP3,
7732     1               YLOWLM,YUPPLM,A,B,MINMAX,
7733     1               SHAP1Z,SHAP2Z,SHAPE3,SHAPE4,
7734     1               SHAPE5,SHAPE6,SHAPE7,
7735     1               IADEDF,IGEPDF,IMAKDF,IBEIDF,
7736     1               ILGADF,ISKNDF,IGLDDF,IBGEDF,
7737     1               IGETDF,ICONDF,IGOMDF,IKATDF,
7738     1               IGIGDF,IGEODF,
7739     1               IPPLDP,MAXOBV,ICENSO,IMETHD,ILEVEL,
7740     1               PPLOC,PPSCAL,
7741     1               PPA0,PPA1,PPCC,SDPPA0,SDPPA1,XRESSD,XRESDF,
7742     1               CCALBE,PPA0BW,PPA1BW,
7743     1               ZTEMP4,ZTEMP5,
7744     1               TEMP1,TEMP2,TEMP3,NJUNK1,NJUNK2,NCURVE,
7745     1               IBUGA3,ISUBRO,IERROR)
7746          STATVA=PPCC
7747          IF(IGOFFM.EQ.'PPCC')THEN
7748            KSLOC=PPA0
7749            KSSCAL=PPA1
7750          ENDIF
7751C
7752          IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GOF2')THEN
7753            WRITE(ICOUT,81)STATVA,PPA0,PPA1,SHAP1Z,SHAP2Z
7754   81       FORMAT('AFTER DPPP2: STATVA,PPA0,PPA1,SHAP1Z,SHAP2Z = ',
7755     1             5G15.7)
7756            CALL DPWRST('XXX','BUG ')
7757          ENDIF
7758C
7759        ELSE
7760C
7761C       2013/03: FOR WEIBULL, CHECK FOR "GAUGE LENGTH" OPTION.
7762C                IF FOUND, AUTOMATICALLY CONVERT THIS TO THE
7763C                "BRITTLE FIBER WEIBULL" CASE.  DO NOT TRANSFORM
7764C                THE SCALE PARAMETER AS IT IS ASSUMED THAT THIS
7765C                IS ALREADY GIVEN IN FORM WITH GAUGE LENGTH PARAMETER.
7766C
7767          IF(IFLAGL.EQ.1 .AND. ICASPL.EQ.'WEIB')THEN
7768            ICASP8=ICASPL
7769            ICASPL='BFWE'
7770            SHAPE2=AL
7771          ENDIF
7772C
7773          CALL DPGOF9(Y,N,ICASPL,ICASP2,
7774     1                ZTEMP6,ZTEMP7,ZTEMP8,N2,
7775     1                YLOWLM,YUPPLM,A,B,MINMAX,
7776     1                SHAPE1,SHAPE2,SHAPE3,SHAPE4,
7777     1                SHAPE5,SHAPE6,SHAPE7,
7778     1                IADEDF,IGEPDF,IMAKDF,IBEIDF,
7779     1                ILGADF,ISKNDF,IGLDDF,IBGEDF,IGETDF,ICONDF,
7780     1                IGOMDF,IKATDF,IGIGDF,IGEODF,
7781     1                MAXOBV,
7782     1                KSLOC,KSSCAL,
7783     1                STATVA,DM,
7784     1                IBUGA3,ISUBRO,IERROR,IERRFL)
7785C
7786CCCCC     IF(IFLAGL.EQ.1 .AND. ICASP8.EQ.'WEIB')THEN
7787CCCCC       ICASPL=ICASP8
7788CCCCC       KSSCAL=KSSCSV
7789CCCCC     ENDIF
7790C
7791        ENDIF
7792C
7793        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GOF2')THEN
7794          WRITE(ICOUT,999)
7795          CALL DPWRST('XXX','BUG ')
7796          WRITE(ICOUT,211)
7797  211     FORMAT('AFTER INITIAL CALL TO DPGOF9:')
7798          CALL DPWRST('XXX','BUG ')
7799          WRITE(ICOUT,213)XMEAN,XSD,XMIN,XMAX,STATVA
7800  213     FORMAT('XMEAN,XSD,XMIN,XMAX,STATVA = ',5G15.7)
7801          CALL DPWRST('XXX','BUG ')
7802        ENDIF
7803C
7804        IF(IERROR.EQ.'YES')THEN
7805          IF(IERRFL.EQ.3)THEN
7806            WRITE(ICOUT,31)
7807            CALL DPWRST('XXX','BUG ')
7808            IF(ICASP2.EQ.'KS  ')THEN
7809              WRITE(ICOUT,1012)
7810 1012         FORMAT('      THE KOLMOGOROV-SMIRNOV GOODNESS OF FIT ',
7811     1               'TEST IS NOT SUPPORTED')
7812              CALL DPWRST('XXX','BUG ')
7813              WRITE(ICOUT,1013)
7814 1013         FORMAT('      FOR DISCRETE DISTRIBUTIONS.')
7815              CALL DPWRST('XXX','BUG ')
7816            ELSEIF(ICASP2.EQ.'AD  ')THEN
7817              WRITE(ICOUT,1022)
7818 1022         FORMAT('      THE ANDERSON-DARLING GOODNESS OF FIT ',
7819     1               'TEST IS NOT SUPPORTED')
7820              CALL DPWRST('XXX','BUG ')
7821              WRITE(ICOUT,1023)
7822 1023         FORMAT('      FOR DISCRETE DISTRIBUTIONS.')
7823              CALL DPWRST('XXX','BUG ')
7824            ENDIF
7825          ELSE
7826            WRITE(ICOUT,31)
7827            CALL DPWRST('XXX','BUG ')
7828            WRITE(ICOUT,1032)
7829 1032       FORMAT('      FAILURE IN ESTIMATING THE PARAMETERS FOR ',
7830     1             'THE ORIGINAL SAMPLE.')
7831            CALL DPWRST('XXX','BUG ')
7832          ENDIF
7833          GOTO9000
7834        ENDIF
7835      ENDIF
7836C
7837C               ****************************************************
7838C               **  STEP 2--                                      **
7839C               **  IF REQUESTED, PERFORM MONTE CARLO SIMULATIONS **
7840C               **  TO DETERMINE P-VALUES/CONFIDENCE INTERVALS    **
7841C               **  FOR THE STATISTIC.  FOR THE TABLE CASE,       **
7842C               **  APPROPRIATE OUTPUT VALUES WILL BE GIVEN IN    **
7843C               **  ROUTINES THAT PRINT THE RESULTS.              **
7844C               ****************************************************
7845C
7846C     NOTE: FOR "MULTIPLE" AND "REPLICATION" CASES, IF SAMPLE SIZE
7847C           IS THE SAME, NO NEED TO REGENERATE THE MONTE CARLO
7848C           SAMPLES.
7849C
7850      IF(IGOFFM.EQ.'NULL')GOTO3000
7851C
7852      IF(ICASP2.EQ.'KS  ')THEN
7853        ITYPE=0
7854        IF(IKSCVM.EQ.'TABL')ITYPE=1
7855      ELSEIF(ICASP2.EQ.'AD  ')THEN
7856        ITYPE=1
7857        IF(IADCVM.EQ.'SIMU')ITYPE=0
7858        IF(ITYPE.EQ.1)THEN
7859          IF(ICASPL.NE.'NORM' .AND. ICASPL.NE.'LOGN' .AND.
7860     1       ICASPL.NE.'WEIB' .AND. ICASPL.NE.'GPAR' .AND.
7861     1       ICASPL.NE.'GAMM' .AND. ICASPL.NE.'EV2 ' .AND.
7862     1       ICASPL.NE.'UNIF' .AND. ICASPL.NE.'EXPO ' .AND.
7863     1       ICASPL.NE.'CAUC' .AND.
7864     1       ICASPL.NE.'LOGI' .AND. ICASPL.NE.'DEXP ')THEN
7865             ITYPE=0
7866          ENDIF
7867        ENDIF
7868      ELSEIF(ICASP2.EQ.'PPCC')THEN
7869        ITYPE=0
7870      ENDIF
7871C
7872      IF(ITYPE.EQ.0)THEN
7873        IF(ICENSO.EQ.'ON')THEN
7874          CONTINUE
7875        ELSE
7876          NMCSAM=10000
7877CCCCC     NMCSAM=100
7878          NCNT=0
7879          NTEMP=N
7880          IF(NSAVE.EQ.NTEMP)GOTO2119
7881          NSAVE=NTEMP
7882          DO2110I=1,NMCSAM
7883C
7884            IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GOF2')THEN
7885              WRITE(ICOUT,999)
7886              CALL DPWRST('XXX','BUG ')
7887              WRITE(ICOUT,311)I
7888  311         FORMAT('MONTE CARLO ITERATION ',I8)
7889              CALL DPWRST('XXX','BUG ')
7890              WRITE(ICOUT,313)KSLOC,KSSCAL,ICENSO
7891  313         FORMAT('KSLOC,KSSCAL,ICENSO = ',2G15.7,2X,A4)
7892              CALL DPWRST('XXX','BUG ')
7893            ENDIF
7894C
7895CCCCC       IF(IFLAGL.EQ.1 .AND. ICASPL.EQ.'WEIB')THEN
7896CCCCC         KSSCSV=KSSCAL
7897CCCCC         ICASP8=ICASPL
7898CCCCC         ICASPL='BFWE'
7899CCCCC         KSSCAL=AL**(1.0/SHAPE1)*KSSCAL
7900CCCCC         SHAPE2=AL
7901CCCCC       ENDIF
7902C
7903            CALL DPRAN2(ICASPL,ISEED,YTEMP,NTEMP,ZTMP10,
7904     1                  A,B,MINMAX,
7905     1                  SHAPE1,SHAPE2,SHAPE3,SHAPE4,
7906     1                  SHAPE5,SHAPE6,SHAPE7,
7907     1                  IADEDF,IGEPDF,IMAKDF,IBEIDF,
7908     1                  ILGADF,ISKNDF,IGLDDF,IBGEDF,IGETDF,ICONDF,
7909     1                  IGOMDF,IKATDF,IGIGDF,IGEODF,
7910     1                  IBUGA3,ISUBRO,IFOUND,IERROR)
7911C
7912            IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GOF2')THEN
7913              WRITE(ICOUT,999)
7914              CALL DPWRST('XXX','BUG ')
7915              WRITE(ICOUT,3311)NTEMP,ICASPL,IERROR
7916 3311         FORMAT('AFTER DPRAN2: NTEMP,ICASPL,IERROR = ',I8,2(2X,A4))
7917              CALL DPWRST('XXX','BUG ')
7918            ENDIF
7919C
7920CCCCC       IF(IFLAGL.EQ.1 .AND. ICASP8.EQ.'WEIB')THEN
7921CCCCC         ICASPL=ICASP8
7922CCCCC         KSSCAL=KSSCSV
7923CCCCC       ENDIF
7924C
7925C           NOTE: DISTINGUISH BETWEEN FULLY SPECIFIED CASE (I.E.,
7926C                 DISTRIBUTION PARAMETERS ASSUMED KNOWN) AND
7927C                 UNKNOWN CASE (I.E., WE NEED TO ESTIMATE PARAMETERS
7928C                 FROM THE DATA).  ALTHOUGH THIS APPLIES TO THE
7929C                 K-S DISTRIBUTION, IT IS EVEN MORE CRITICAL FOR THE
7930C                 ANDERSON DARLING CASE.
7931C
7932C           NOTE: 2012/07 - FOR THOSE DISTRIBUTIONS THAT ARE
7933C                 SPECIFIED IN TERMS OF THEIR LOWER AND UPPER
7934C                 LIMITS (RATHER THAN THEIR LOCATION/SCALE
7935C                 PARAMETERS), CONVERT A AND B PARAMETERS INTO
7936C                 KSLOC AND KSSCALE PARAMETERS.
7937C
7938C                 A FEW OF THESE HAVE THE A AND B PARAMETERS
7939C                 BUILT-IN, SO DON'T TRANSFORM AFTER GENERATING
7940C                 THE RANDOM NUMBERS.
7941C
7942            IF(ICASPL.EQ.'UNIF' .OR. ICASPL.EQ.'BETA' .OR.
7943     1         ICASPL.EQ.'NCBE' .OR. ICASPL.EQ.'POWF' .OR.
7944     1         ICASPL.EQ.'JOSB' .OR. ICASPL.EQ.'SLOP' .OR.
7945     1         ICASPL.EQ.'OGIV' .OR. ICASPL.EQ.'RGTL' .OR.
7946     1         ICASPL.EQ.'RPOW')THEN
7947              ALOCT=A
7948              ASCALE=B - A
7949            ELSEIF(ICASPL.EQ.'TSSL' .OR. ICASPL.EQ.'TSPO' .OR.
7950     1             ICASPL.EQ.'TNOR' .OR. ICASPL.EQ.'TSOG' .OR.
7951     1             ICASPL.EQ.'TRIA')THEN
7952              ALOCT=0.0
7953              ASCALE=1.0
7954            ELSE
7955              ALOCT=KSLOC
7956              ASCALE=KSSCAL
7957            ENDIF
7958C
7959            DO2115JJ=1,NTEMP
7960              YTEMP(JJ)=ALOCT + ASCALE*YTEMP(JJ)
7961 2115       CONTINUE
7962C
7963C           STEP 1: PARAMETER ESTIMATION
7964C
7965CCCCC       IF(IGOFFS.EQ.'OFF' .AND. ICASP2.NE.'PPCC')THEN
7966CCCCC       IF(IGOFFS.EQ.'OFF' .AND. ICASP2.NE.'PPCC' .AND.
7967CCCCC1         IGOFFM.EQ.'ML')THEN
7968            IF(IGOFFS.EQ.'OFF' .AND.  IGOFF2.EQ.'ML')THEN
7969              CALL DPML1(YTEMP,CENSOR,NTEMP,ICASPL,IFLAGD,IFLAG9,
7970     1                   TEMP1,TEMP2,TEMP3,ZTEMP1,ZTEMP2,ZTEMP3,
7971     1                   DTEMP,DTEMP2,DTEMP3,ITEMP1,MAXOBV,
7972     1                   ALOC,ASCALE,ALOWLI,AUPPLI,
7973     1                   SH1,SH2,SH3,SH4,
7974     1                   SH5,SH6,S7,
7975     1                   YLOWLM,YUPPLM,A,B,MINMAX,ISEED,
7976     1                   IADEDF,IGEPDF,IMAKDF,IBEIDF,
7977     1                   ILGADF,ISKNDF,IGLDDF,IGOMDF,IGIGDF,
7978     1                   IGEODF,IBGEDF,IGAUDF,
7979     1                   ICENSO,IEXPBC,IWEIBC,ICENTY,IDFTTY,
7980     1                   CLLIMI,CLWIDT,IHSTCW,IHSTOU,IRELAT,IRHSTG,
7981     1                   IBUGA3,ISUBRO,IERROR)
7982C
7983CCCCC         IF(IFLAGL.EQ.1 .AND. ICASPL.EQ.'WEIB')THEN
7984CCCCC           ASCALE=AL**(1.0/SH1)*ASCALE
7985CCCCC         ENDIF
7986C
7987              IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GOF2')THEN
7988                WRITE(ICOUT,315)ALOC,ASCALE,SH1,SH2
7989  315           FORMAT('AFTER DPML1: ALOC,ASCALE,SH1,SH2 = ',4G15.7)
7990                CALL DPWRST('XXX','BUG ')
7991              ENDIF
7992C
7993              IF(IFLAG9.EQ.-99)THEN
7994                WRITE(ICOUT,31)
7995                CALL DPWRST('XXX','BUG ')
7996                WRITE(ICOUT,318)
7997  318           FORMAT('      MAXIMUM LIKELIHOOD ESTIMATION CURRENTLY ',
7998     1                 'NOT SUPPORTED FOR THIS DISTRIBUTION.')
7999                CALL DPWRST('XXX','BUG ')
8000                IERROR='YES'
8001                GOTO9000
8002              ENDIF
8003C
8004              IF(IERROR.EQ.'YES')GOTO2110
8005C
8006CCCCC       ELSEIF(IGOFFS.EQ.'OFF' .AND.
8007CCCCC1            (ICASP2.EQ.'PPCC' .OR. IGOFFM.EQ.'PPCC'))THEN
8008            ELSEIF(IGOFFS.EQ.'OFF' .AND. IGOFF2.EQ.'PPCC')THEN
8009              NCURVE=1
8010              IFLAGF='OFF'
8011              PPLOC=0.0
8012              PPSCAL=1.0
8013              NHIGH=0
8014              NJUNK1=0
8015              NJUNK2=0
8016              IF(NUMSHA.EQ.0)THEN
8017                CALL DPPP2(YTEMP,CENSOR,XLEVEL,NTEMP,ICASPL,NHIGH,
8018     1                     ZTEMP1,ZTEMP2,ZTEMP3,
8019     1                     YLOWLM,YUPPLM,A,B,MINMAX,
8020     1                     SHAPE1,SHAPE2,SHAPE3,SHAPE4,
8021     1                     SHAPE5,SHAPE6,SHAPE7,
8022     1                     IADEDF,IGEPDF,IMAKDF,IBEIDF,
8023     1                     ILGADF,ISKNDF,IGLDDF,IBGEDF,
8024     1                     IGETDF,ICONDF,IGOMDF,IKATDF,
8025     1                     IGIGDF,IGEODF,
8026     1                     IPPLDP,MAXOBV,ICENSO,IMETHD,ILEVEL,
8027     1                     PPLOC,PPSCAL,
8028     1                     PPA0,PPA1,PPCC,SDPPA0,SDPPA1,XRESSD,XRESDF,
8029     1                     CCALBE,PPA0BW,PPA1BW,
8030     1                     ZTEMP4,ZTEMP5,
8031     1                     TEMP1,TEMP2,TEMP3,NJUNK1,NJUNK2,NCURVE,
8032     1                     IBUGA3,ISUBRO,IERROR)
8033              ELSEIF(NUMSHA.EQ.1 .OR. NUMSHA.EQ.2)THEN
8034                PPLOC=0.0
8035                PPSCAL=1.0
8036                SHAP1Z=SHAPE1
8037                SHAP2Z=SHAPE2
8038                ICASP9='PPCC'
8039                CALL DPPPC2(YTEMP,CENSOR,XLEVEL,NTEMP,MAXOBV,
8040     1                      ICASP9,ICASPL,
8041     1                      SHAP11,SHAP12,SHAP21,SHAP22,
8042     1                      SHAP1Z,SHAP2Z,SHAPE3,SHAPE4,SHAPE5,
8043     1                      YLOWLM,YUPPLM,A,B,MINMAX,
8044     1                      TEMP1(1),TEMP1(20001),TEMP1(40001),
8045     1                      TEMP1(60001),NUMSHA,
8046     1                      ZTEMP1,ZTEMP2,ZTEMP3,ZTEMP4,TEMP1(80001),
8047     1                      ZTEMP5,ZTEMP6,ZTEMP7,ZTEMP8,ZTEMP9,IPPCBW,
8048     1                      IADEDF,IGEPDF,IMAKDF,IBEIDF,
8049     1                      ILGADF,ISKNDF,IGLDDF,IBGEDF,
8050     1                      IGETDF,ICONDF,IGOMDF,IKATDF,
8051     1                      IGIGDF,IGEODF,
8052     1                      IPPCCC,IPPCFO,IPPLDP,PPLOC,PPSCAL,
8053     1                      IPPCDP,IPPCAP,IPPCAO,IMETHD,ICENSO,
8054     1                      IFLAGF,NCURVE,
8055     1                      PCHSLM,ILEVEL,
8056     1                      ZTMP10,ZTMP11,TEMP2,TEMP3,NJUNK1,NJUNK2,
8057     1                      PPCC,SHA1MX,SHA2MX,PPA0,PPA1,
8058     1                      PPA0BW,PPA1BW,
8059     1                      IBUGA3,ISUBRO,IERROR)
8060                SH1NEW=SHA1MX
8061                SH2NEW=0.0
8062                IF(NUMSHA.GE.2)SH2NEW=SHA2MX
8063                IF(ICASPL.EQ.'BFWE')SH2NEW=SHAPE2
8064C
8065              ELSE
8066                WRITE(ICOUT,31)
8067                CALL DPWRST('XXX','BUG ')
8068                WRITE(ICOUT,319)
8069  319           FORMAT('      PPCC ESTIMATION CURRENTLY NOT SUPPORTED ',
8070     1                 'FOR MORE THAN 2 SHAPE PARAMETERS.')
8071                CALL DPWRST('XXX','BUG ')
8072                IERROR='YES'
8073                GOTO9000
8074              ENDIF
8075C
8076C             NOTE: SINCE WE ALREADY HAVE VALUE OF TEST STATISTIC,
8077C                   NO NEED TO CALL DPGOF9 FOR PPCC GOODNESS OF FIT
8078C
8079              IF(IERROR.EQ.'YES')GOTO2110
8080              ALOC=PPA0
8081              ASCALE=PPA1
8082              SH1=SH1NEW
8083              SH2=SH2NEW
8084              IF(ICASP2.EQ.'PPCC')THEN
8085                NCNT=NCNT+1
8086                YSTAT(NCNT)=PPCC
8087                GOTO2110
8088              ENDIF
8089            ELSE
8090              ALOC=KSLOC
8091              ASCALE=KSSCAL
8092              SH1=SHAPE1
8093              SH2=SHAPE2
8094              SH3=SHAPE3
8095              SH4=SHAPE4
8096              SH5=SHAPE5
8097              SH6=SHAPE6
8098              SH7=SHAPE7
8099            ENDIF
8100C
8101C           STEP 2: COMPUTE GOODNESS OF FIT STATISTIC (NOT NEEDED
8102C                   FOR PPCC)
8103C
8104C           NEED TO ACCOUNT FOR CASES WHERE LOCATION OR SCALE NOT
8105C           ESTIMATED (I.E., SET TO CPUMIN).
8106C
8107            ALOCT=ALOC
8108            ASCALT=ASCALE
8109            IF(ALOC.EQ.CPUMIN)ALOCT=0.0
8110            IF(ASCALE.EQ.CPUMIN)ASCALT=1.0
8111C
8112            IF(ICASP2.EQ.'PPCC')THEN
8113              PPLOC=0.0
8114              PPSCALE=1.0
8115              IF(IGOFF2.EQ.'ML')THEN
8116                IF(ALOC.NE.CPUMIN)PPLOC=ALOC
8117                IF(ASCALE.NE.CPUMIN)PPSCALE=ASCALE
8118              ENDIF
8119C
8120              IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GOF2')THEN
8121                WRITE(ICOUT,3411)PPLOC,PPSCAL
8122 3411           FORMAT('BEFORE DPPP2: PPLOC,PPSCAL = ',2G15.7)
8123                CALL DPWRST('XXX','BUG ')
8124              ENDIF
8125C
8126              NJUNK1=0
8127              NJUNK2=0
8128              CALL DPPP2(YTEMP,CENSOR,XLEVEL,NTEMP,ICASPL,NHIGH,
8129     1                   ZTEMP1,ZTEMP2,ZTEMP3,
8130     1                   YLOWLM,YUPPLM,A,B,MINMAX,
8131     1                   SH1,SH2,SH3,SH4,
8132     1                   SH5,SH6,SH7,
8133     1                   IADEDF,IGEPDF,IMAKDF,IBEIDF,
8134     1                   ILGADF,ISKNDF,IGLDDF,IBGEDF,
8135     1                   IGETDF,ICONDF,IGOMDF,IKATDF,
8136     1                   IGIGDF,IGEODF,
8137     1                   IPPLDP,MAXOBV,ICENSO,IMETHD,ILEVEL,
8138     1                   PPLOC,PPSCAL,
8139     1                   PPA0,PPA1,PPCC,SDPPA0,SDPPA1,XRESSD,XRESDF,
8140     1                   CCALBE,PPA0BW,PPA1BW,
8141     1                   ZTEMP4,ZTEMP5,
8142     1                   TEMP1,TEMP2,TEMP3,NJUNK1,NJUNK2,NCURVE,
8143     1                   IBUGA3,ISUBRO,IERROR)
8144C
8145              IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GOF2')THEN
8146                WRITE(ICOUT,3412)PPA0,PPA1,PPCC,IERROR
8147 3412           FORMAT('AFTER DPPP2: PPA0,PPA1,PPCC,IERROR = ',
8148     1                 3G15.7,2X,A4)
8149                CALL DPWRST('XXX','BUG ')
8150              ENDIF
8151C
8152              IF(IERROR.EQ.'YES')GOTO2110
8153              NCNT=NCNT+1
8154              YSTAT(NCNT)=PPCC
8155            ELSE
8156CCCCC         IF(IFLAGL.EQ.1 .AND. ICASPL.EQ.'WEIB')THEN
8157CCCCC           ICASP8=ICASPL
8158CCCCC           ICASPL='BFWE'
8159CCCCC           SH2=AL
8160CCCCC         ENDIF
8161C
8162              IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GOF2')THEN
8163                WRITE(ICOUT,3421)
8164 3421           FORMAT('BEFORE DPGOF9:')
8165                CALL DPWRST('XXX','BUG ')
8166              ENDIF
8167C
8168              CALL DPGOF9(YTEMP,NTEMP,ICASPL,ICASP2,
8169     1                    ZTEMP6,ZTEMP7,ZTEMP8,N2,
8170     1                    YLOWLM,YUPPLM,A,B,MINMAX,
8171     1                    SH1,SH2,SH3,SH4,
8172     1                    SH5,SH6,SH7,
8173     1                    IADEDF,IGEPDF,IMAKDF,IBEIDF,
8174     1                    ILGADF,ISKNDF,IGLDDF,IBGEDF,IGETDF,ICONDF,
8175     1                    IGOMDF,IKATDF,IGIGDF,IGEODF,
8176     1                    MAXOBV,
8177     1                    ALOCT,ASCALT,
8178     1                    STATV9,DMTEMP,
8179     1                    IBUGA3,ISUBRO,IERROR,IERRFL)
8180C
8181              IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GOF2')THEN
8182                WRITE(ICOUT,3422)
8183 3422           FORMAT('AFTER DPGOF9:')
8184                CALL DPWRST('XXX','BUG ')
8185              ENDIF
8186C
8187              IF(IFLAGL.EQ.1 .AND. ICASP8.EQ.'WEIB')THEN
8188                ICASPL='WEIB'
8189              ENDIF
8190              IF(IERROR.EQ.'YES')GOTO2110
8191              NCNT=NCNT+1
8192              YSTAT(NCNT)=STATV9
8193            ENDIF
8194C
8195            IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GOF2')THEN
8196              WRITE(ICOUT,317)STATVA
8197  317         FORMAT('AFTER DPGOF9: STATVA = ',G15.7)
8198              CALL DPWRST('XXX','BUG ')
8199            ENDIF
8200C
8201 2110     CONTINUE
8202 2119     CONTINUE
8203          IDIR='UPPE'
8204CCCCC     IF(ICASP2.EQ.'PPCC')IDIR='LOWE'
8205          CALL DPGOF8(YSTAT,NMCSAM,STATVA,PVAL,IDIR,
8206     1                IBUGA3,ISUBRO,IERROR)
8207          STATCD=1.0 - PVAL
8208        ENDIF
8209      ELSE
8210        NMCSAM=0
8211        PVAL=CPUMIN
8212      ENDIF
8213C
8214C               ****************************************************
8215C               **  STEP 3--                                      **
8216C               **  GENERATE THE OUTPUT FOR THE DESIRED STATISTIC **
8217C               **  TO DETERMINE P-VALUES/CONFIDENCE INTERVALS    **
8218C               **  FOR THE STATISTIC.                            **
8219C               ****************************************************
8220C
8221C
8222 3000 CONTINUE
8223C
8224      IF(ICASP2.EQ.'KS  ')THEN
8225CCCCC   IF(IFLAGL.EQ.1 .AND. ICASPL.EQ.'WEIB')THEN
8226CCCCC     KSSCSV=KSSCAL
8227CCCCC     ICASP8=ICASPL
8228CCCCC     ICASPL='BFWE'
8229CCCCC     KSSCAL=AL**(1.0/SHAPE1)*KSSCAL
8230CCCCC   ENDIF
8231C
8232        CALL DP1KS3(ICASPL,IDIST,NUMSHA,IFORSW,IKSCVM,IGOFFS,
8233     1              IGOFF2,PID,IVARID,IVARI2,NREPL,
8234     1              N,XMEAN,XSD,XMIN,XMAX,
8235     1              A,B,MINMAX,
8236     1              SHAPE1,SHAPE2,SHAPE3,SHAPE4,
8237     1              SHAPE5,SHAPE6,SHAPE7,
8238     1              KSLOC,KSSCAL,ICAPSW,ICAPTY,IRTFFF,IRTFFP,
8239     1              STATVA,PVAL,CDF1,CDF2,CDF3,YSTAT,NMCSAM,NCNT,
8240     1              YTEMP,MAXOBV,
8241     1              IBUGA3,ISUBRO,IERROR)
8242C
8243CCCCC     IF(IFLAGL.EQ.1 .AND. ICASP8.EQ.'WEIB')THEN
8244CCCCC       ICASPL=ICASP8
8245CCCCC       KSSCAL=KSSCSV
8246CCCCC     ENDIF
8247      ELSEIF(ICASP2.EQ.'AD  ')THEN
8248CCCCC   IF(IFLAGL.EQ.1 .AND. ICASPL.EQ.'WEIB')THEN
8249CCCCC     KSSCSV=KSSCAL
8250CCCCC     ICASP8=ICASPL
8251CCCCC     ICASPL='BFWE'
8252CCCCC     KSSCAL=AL**(1.0/SHAPE1)*KSSCAL
8253CCCCC   ENDIF
8254C
8255        CALL DPADA3(ICASPL,IDIST,NUMSHA,IFORSW,IADCVM,IGOFFS,
8256     1              IGOFF2,PID,IVARID,IVARI2,NREPL,
8257     1              N,XMEAN,XSD,XMIN,XMAX,
8258     1              A,B,MINMAX,
8259     1              SHAPE1,SHAPE2,SHAPE3,SHAPE4,
8260     1              SHAPE5,SHAPE6,SHAPE7,
8261     1              KSLOC,KSSCAL,ICAPSW,ICAPTY,IRTFFF,IRTFFP,
8262     1              STATVA,STATV2,CDF1,CDF2,CDF3,CDF4,
8263     1              PVAL,YSTAT,NMCSAM,NCNT,
8264     1              YTEMP,MAXOBV,
8265     1              IBUGA3,ISUBRO,IERROR)
8266C
8267CCCCC     IF(IFLAGL.EQ.1 .AND. ICASP8.EQ.'WEIB')THEN
8268CCCCC       ICASPL=ICASP8
8269CCCCC       KSSCAL=KSSCSV
8270CCCCC     ENDIF
8271      ELSEIF(ICASP2.EQ.'PPCC')THEN
8272        CALL DPPPGF(ICASPL,IDIST,NUMSHA,IFORSW,IADCVM,IGOFFS,
8273     1              IGOFF2,PID,IVARID,IVARI2,NREPL,
8274     1              N,XMEAN,XSD,XMIN,XMAX,
8275     1              YLOWLM,YUPPLM,A,B,MINMAX,
8276     1              SHAPE1,SHAPE2,SHAPE3,SHAPE4,
8277     1              SHAPE5,SHAPE6,SHAPE7,
8278     1              KSLOC,KSSCAL,ICAPSW,ICAPTY,IRTFFF,IRTFFP,
8279     1              STATVA,STATV2,CDF1,CDF2,CDF3,CDF4,
8280     1              PVAL,YSTAT,NMCSAM,NCNT,
8281     1              YTEMP,MAXOBV,
8282     1              IBUGA3,ISUBRO,IERROR)
8283      ENDIF
8284C
8285C               *****************
8286C               **  STEP 90--  **
8287C               **  EXIT       **
8288C               *****************
8289C
8290 9000 CONTINUE
8291      IGOFFS=IGOFSV
8292      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GOF2')THEN
8293        WRITE(ICOUT,999)
8294        CALL DPWRST('XXX','BUG ')
8295        WRITE(ICOUT,9011)
8296 9011   FORMAT('***** AT THE END       OF DPGOF2--')
8297        CALL DPWRST('XXX','BUG ')
8298        WRITE(ICOUT,9012)STATVA,NMCSAM,PVAL
8299 9012   FORMAT('STATVA,NMCSAM,PVAL ',G15.7,I8,G15.7)
8300        CALL DPWRST('XXX','BUG ')
8301        IF(NMCSAM.GT.1)THEN
8302          DO9020I=1,MIN(NMCSAM,100)
8303            WRITE(ICOUT,9021)I,YSTAT(I)
8304 9021       FORMAT('I,YSTAT(I) = ',I8,G15.7)
8305            CALL DPWRST('XXX','BUG ')
8306 9020     CONTINUE
8307        ENDIF
8308      ENDIF
8309C
8310      RETURN
8311      END
8312      SUBROUTINE DPGOF3(Y,CENSOR,XLOW,XHIGH,N,ICASPL,ICASP2,IDATSW,
8313     1                  PID,IVARID,IVARI2,NREPL,MINSZ,PCHSLM,
8314     1                  Y2,X2,YTEMP,YSTAT,
8315     1                  TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,
8316     1                  WEIGHH,WEIGHV,D2,
8317     1                  DTEMP,DTEMP2,DTEMP3,ITEMP1,
8318     1                  N2,YLOWLM,YUPPLM,A,B,MINMAX,
8319     1                  SHAPE1,SHAPE2,SHAPE3,SHAPE4,
8320     1                  SHAPE5,SHAPE6,SHAPE7,NUMSHA,
8321     1                  IADEDF,IGEPDF,IMAKDF,IBEIDF,
8322     1                  ILGADF,ISKNDF,IGLDDF,IBGEDF,
8323     1                  IGETDF,ICONDF,IGOMDF,IKATDF,
8324     1                  IGIGDF,IGEODF,IGAUDF,
8325     1                  IEXPBC,IWEIBC,ICENTY,IDFTTY,
8326     1                  IDIST,MAXOBV,ICENSO,NMCSAM,NSAVE,
8327     1                  KSLOC,KSSCAL,ICAPSW,ICAPTY,
8328     1                  IKSCVM,IADCVM,IFORSW,ISEED,IGOFFS,IMETHD,
8329     1                  IRHSTG,IHSTCW,CLWIDT,CLLIMI,IHSTOU,
8330     1                  STATVA,STATCD,PVAL,CDF1,CDF2,CDF3,CDF4,
8331     1                  IBUGA3,ISUBRO,IERROR)
8332C
8333C     PURPOSE--COMPUTE ONE OF THE FOLLOWING GOODNESS OF FIT TESTS FOR
8334C              GROUPED DATA:
8335C
8336C              FOLLOWING ARE CURRENTLY AVAILABLE:
8337C              1) CHI-SQUARE
8338C              2) PPCC
8339C
8340C              FOLLOWING ARE STILL BEING DEVELOPED:
8341C              3) KOLMOGOROV-SMIRNOV
8342C              4) ANDERSON-DARLING
8343C              5) AIC/BIC/BICC
8344C
8345C              THE STEPS ARE:
8346C
8347C              1) CALL DPGOFA TO COMPUTE VALUE OF GOODNESS OF FIT
8348C                 STATISTIC
8349C
8350C              2) COMPUTE CRITICAL VALUES:
8351C
8352C                 THE CHI-SQUARE GOODNESS OF FIT USES AN EXPLICIT
8353C                 CHI-SQUARE APPROXIMATION, SO P-VALUE CAN BE DETERMINED
8354C                 EXPLICITLY.
8355C
8356C                 FOR OTHER METHODS, WE CAN POSSIBLY USE ONE OF THE
8357C                 FOLLOWING:
8358C                 A) MONTE CARLO SIMULATION
8359C                 B) FROM TABLE VALUES
8360C
8361C                 THERE ARE SOME TABLES FOR CRITICAL VALUES FOR THE
8362C                 K-S METHOD.  HAVEN'T SEEN ANY FOR THE A-D.  ALSO,
8363C                 IT IS NOT CLEAR YET HOW TO IMPLEMENT AN APPROPRIATE
8364C                 MONTE CARLO SIMULATION.
8365C
8366C                 AS A FURTHER COMPLICATION, THE SIMULATION DEPENDS
8367C                 ON WHETHER WE ASSUME THE "FULLY SPECIFIED" CASE
8368C                 (I.E., PARAMETERS ASSUMED KNOWN) OR THE PARAMETERS
8369C                 ARE ESTIMATED FROM THE DATA.  FOR THE SECOND CASE,
8370C                 WE HAVE TO ESTIMATE THE PARAMETERS FROM EACH OF THE
8371C                 MONTE CARLO SAMPLES.
8372C
8373C              3) PRINT OUTPUT USING
8374C
8375C                 DP1CS3   - FOR CHI-SQUARE STATISTIC
8376C                 DPPPC9   - FOR PPCC STATISTIC
8377C
8378C              NOTE THAT CENSORING IS CURRENTLY ONLY SUPPORTED FOR THE
8379C              PPCC CASE.  HOWEVER, IT IS ANTICIPATED THAT CENSORING WILL
8380C              BE ADDED FOR ADDITIONAL CASES IN SUBSEQUENT UPDATES.
8381C
8382C              NOTE: PPCC OPTION SUPPORTS CENSORING.
8383C
8384C     WRITTEN BY--ALAN HECKERT
8385C                 STATISTICAL ENGINEERING DIVISION
8386C                 INFORMATION TECHNOLOGY LABORATORY
8387C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
8388C                 GAITHERSBURG, MD 20899-8980
8389C                 PHONE--301-975-2899
8390C         --DATAPLOT IS A REGISTERED TRADEMARK
8391C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
8392C     LANGUAGE--ANSI FORTRAN (1977)
8393C     VERSION NUMBER--2009/12
8394C     ORIGINAL VERSION--DECEMBER  2009.
8395C
8396C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
8397C
8398      CHARACTER*4 ICASPL
8399      CHARACTER*4 ICASP2
8400      CHARACTER*4 ICASP3
8401      CHARACTER*4 IDATSW
8402      CHARACTER*4 ICENSO
8403      CHARACTER*4 IMETHD
8404      CHARACTER*4 IVARID(*)
8405      CHARACTER*4 IVARI2(*)
8406      CHARACTER*4 ICAPSW
8407      CHARACTER*4 ICAPTY
8408      CHARACTER*4 IKSCVM
8409      CHARACTER*4 IADCVM
8410      CHARACTER*4 IFORSW
8411      CHARACTER*4 IGOFFS
8412      CHARACTER*4 IDISFL
8413      CHARACTER*4 IBUGA3
8414      CHARACTER*4 ISUBRO
8415      CHARACTER*4 IERROR
8416      CHARACTER*4 IADEDF
8417      CHARACTER*4 IGEPDF
8418      CHARACTER*4 IMAKDF
8419      CHARACTER*4 IBEIDF
8420      CHARACTER*4 ILGADF
8421      CHARACTER*4 ISKNDF
8422      CHARACTER*4 IGLDDF
8423      CHARACTER*4 IBGEDF
8424      CHARACTER*4 IGETDF
8425      CHARACTER*4 ICONDF
8426      CHARACTER*4 IGOMDF
8427      CHARACTER*4 IKATDF
8428      CHARACTER*4 IGIGDF
8429      CHARACTER*4 IGEODF
8430      CHARACTER*4 IGAUDF
8431      CHARACTER*4 IEXPBC
8432      CHARACTER*4 IWEIBC
8433      CHARACTER*4 ICENTY
8434      CHARACTER*4 IDFTTY
8435      CHARACTER*4 IRELAT
8436      CHARACTER*4 IRHSTG
8437      CHARACTER*4 IHSTCW
8438      CHARACTER*4 IHSTOU
8439C
8440      CHARACTER*60 IDIST
8441C
8442      CHARACTER*4 IDIR
8443      CHARACTER*4 IFOUND
8444      CHARACTER*4 ISUBN1
8445      CHARACTER*4 ISUBN2
8446C
8447      REAL KSLOC
8448      REAL KSSCAL
8449C
8450C---------------------------------------------------------------------
8451C
8452      DIMENSION Y(*)
8453      DIMENSION CENSOR(*)
8454      DIMENSION XLOW(*)
8455      DIMENSION XHIGH(*)
8456      DIMENSION YTEMP(*)
8457      DIMENSION YSTAT(*)
8458      DIMENSION Y2(*)
8459      DIMENSION X2(*)
8460      DIMENSION D2(*)
8461      DIMENSION WEIGHH(*)
8462      DIMENSION WEIGHV(*)
8463C
8464      DIMENSION TEMP1(*)
8465      DIMENSION TEMP2(*)
8466      DIMENSION TEMP3(*)
8467      DIMENSION TEMP4(*)
8468      DIMENSION TEMP5(*)
8469C
8470      DIMENSION PID(*)
8471      DIMENSION CLWIDT(*)
8472      DIMENSION CLLIMI(*)
8473C
8474      DOUBLE PRECISION DTEMP(*)
8475      DOUBLE PRECISION DTEMP2(*)
8476      DOUBLE PRECISION DTEMP3(*)
8477C
8478      INTEGER ITEMP1(*)
8479C
8480C---------------------------------------------------------------------
8481C
8482      INCLUDE 'DPCOP2.INC'
8483C
8484C-----START POINT-----------------------------------------------------
8485C
8486C
8487      ISUBN1='DPGO'
8488      ISUBN2='F3  '
8489      IERROR='NO'
8490      ICASP3=IDATSW
8491C
8492      STATVA=CPUMIN
8493      STATCD=CPUMIN
8494      PVAL=CPUMIN
8495      CDF1=CPUMIN
8496      CDF2=CPUMIN
8497      CDF3=CPUMIN
8498      CDF4=CPUMIN
8499      STATV9=CPUMIN
8500      PVAL=CPUMIN
8501      NMCSAM=0
8502      ITYPE=0
8503C
8504      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GOF3')THEN
8505        WRITE(ICOUT,999)
8506        CALL DPWRST('XXX','BUG ')
8507        WRITE(ICOUT,71)
8508   71   FORMAT('***** AT THE BEGINNING OF DPGOF3--')
8509        CALL DPWRST('XXX','BUG ')
8510        WRITE(ICOUT,72)ICASPL,ICASP2,N,MINMAX
8511   72   FORMAT('ICASPL,ICASP2,N,MINMAX = ',2(A4,2X),2I8)
8512        CALL DPWRST('XXX','BUG ')
8513        WRITE(ICOUT,75)KSLOC,KSSCAL,A,B
8514   75   FORMAT('KSLOC,KSSCAL,A,B = ',4G15.7)
8515        CALL DPWRST('XXX','BUG ')
8516        WRITE(ICOUT,77)MINSZ,PCHSLM
8517   77   FORMAT('MINSZ,PCHSLM = ',2G15.7)
8518        CALL DPWRST('XXX','BUG ')
8519        WRITE(ICOUT,79)IKSCVM,IADCVM
8520   79   FORMAT('IKSCVM,IADCVM = ',A4,2X,A4)
8521        CALL DPWRST('XXX','BUG ')
8522        IF(N.GE.1)THEN
8523          DO85I=1,N
8524            WRITE(ICOUT,86)I,Y(I),CENSOR(I),XLOW(I),XHIGH(I)
8525   86       FORMAT('I,Y(I),CENSOR(I),XLOW(I),XHIGH(I) = ',I8,5G15.7)
8526            CALL DPWRST('XXX','BUG ')
8527   85     CONTINUE
8528        ENDIF
8529      ENDIF
8530C
8531C               ********************************************
8532C               **  STEP 1--                              **
8533C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
8534C               ********************************************
8535C
8536      IF(N.LT.2)THEN
8537        WRITE(ICOUT,999)
8538  999   FORMAT(1X)
8539        CALL DPWRST('XXX','BUG ')
8540        WRITE(ICOUT,31)
8541   31   FORMAT('***** ERROR IN GOODNESS OF FIT--')
8542        CALL DPWRST('XXX','BUG ')
8543        WRITE(ICOUT,32)
8544   32   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 2.')
8545        CALL DPWRST('XXX','BUG ')
8546        WRITE(ICOUT,34)N
8547   34   FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6)
8548        CALL DPWRST('XXX','BUG ')
8549        WRITE(ICOUT,999)
8550        CALL DPWRST('XXX','BUG ')
8551        IERROR='YES'
8552        GOTO9000
8553      ENDIF
8554C
8555C     COMPUTE SUMMARY STATISTICS
8556C
8557      IFLAG1=0
8558      IFLAG2=0
8559      IF(IDATSW.EQ.'RAW ')THEN
8560        CALL SUMRAW(Y,N,IDIST,IFLAG1,
8561     1              XMEAN,XVAR,XSD,XMIN,XMAX,
8562     1              ISUBRO,IBUGA3,IERROR)
8563      ELSEIF(IDATSW.EQ.'FREQ')THEN
8564        CALL SUMGRP(Y,XLOW,N,IDIST,IFLAG1,IFLAG2,
8565     1              TEMP1,TEMP2,TEMP3,MAXOBV,
8566     1              XMEAN,XVAR,XSD,XMIN,XMAX,NTOT,
8567     1              ISUBRO,IBUGA3,IERROR)
8568      ELSEIF(IDATSW.EQ.'FRE2')THEN
8569        CALL SUMGR2(Y,XLOW,XHIGH,N,IDIST,IFLAG1,IFLAG2,
8570     1              TEMP1,TEMP2,TEMP3,MAXOBV,
8571     1              XMEAN,XVAR,XSD,XMIN,XMAX,NTOT,
8572     1              ISUBRO,IBUGA3,IERROR)
8573      ENDIF
8574      IF(IERROR.EQ.'YES')GOTO9000
8575C
8576C               *****************************************
8577C               **  STEP 4--                           **
8578C               **  COMPUTE THE BASIC TEST STATISTIC   **
8579C               *****************************************
8580C
8581      IF(ICENSO.EQ.'ON')THEN
8582        CONTINUE
8583      ELSE
8584        N2=0
8585        IERRFL=0
8586        CALL DPGOFB(Y,XLOW,XHIGH,CENSOR,N,
8587     1              ICASPL,ICASP2,IDATSW,
8588     1              TEMP1,TEMP2,TEMP3,
8589     1              YLOWLM,YUPPLM,A,B,MINMAX,
8590     1              CLWIDT,CLLIMI,IHSTCW,IHSTOU,MINSZ,
8591     1              SHAPE1,SHAPE2,SHAPE3,SHAPE4,
8592     1              SHAPE5,SHAPE6,SHAPE7,
8593     1              IADEDF,IGEPDF,IMAKDF,IBEIDF,
8594     1              ILGADF,ISKNDF,IGLDDF,IBGEDF,
8595     1              IGETDF,ICONDF,IGOMDF,IKATDF,
8596     1              IGIGDF,IGEODF,
8597     1              MAXOBV,NUMSHA,KSLOC,KSSCAL,
8598     1              NCELLS,NTOT,IDISFL,ILOWLM,
8599     1              IBUGA3,ISUBRO,IERROR)
8600        IF(IERROR.EQ.'YES')GOTO9000
8601C
8602        CALL DPGOFA(Y,XLOW,XHIGH,N,ICASPL,ICASP2,IDATSW,
8603     1              TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,
8604     1              WEIGHH,WEIGHV,
8605     1              Y2,X2,D2,N2,
8606     1              YLOWLM,YUPPLM,A,B,MINMAX,
8607     1              PCHSLM,MINSZ,
8608     1              SHAPE1,SHAPE2,SHAPE3,SHAPE4,
8609     1              SHAPE5,SHAPE6,SHAPE7,
8610     1              IADEDF,IGEPDF,IMAKDF,IBEIDF,
8611     1              ILGADF,ISKNDF,IGLDDF,IBGEDF,
8612     1              IGETDF,ICONDF,IGOMDF,IKATDF,
8613     1              IGIGDF,IGEODF,
8614     1              MAXOBV,NUMSHA,KSLOC,KSSCAL,
8615     1              PPA0,PPA1,PPCC,SDPPA0,SDPPA1,XRESSD,XRESDF,
8616     1              CCALBE,PPA0BW,PPA1BW,
8617     1              STATVA,STAT,STATCD,PVAL,IDF,
8618     1              NCELLS,NTOT,IDISFL,ILOWLM,IMETHD,IDIST,
8619     1              IBUGA3,ISUBRO,IERROR)
8620        IF(IERROR.EQ.'YES')GOTO9000
8621      ENDIF
8622C
8623C               ****************************************************
8624C               **  STEP 2--                                      **
8625C               **  IF REQUESTED, PERFORM MONTE CARLO SIMULATIONS **
8626C               **  TO DETERMINE P-VALUES/CONFIDENCE INTERVALS    **
8627C               **  FOR THE STATISTIC.  FOR THE TABLE CASE,       **
8628C               **  APPROPRIATE OUTPUT VALUES WILL BE GIVEN IN    **
8629C               **  ROUTINES THAT PRINT THE RESULTS.              **
8630C               ****************************************************
8631C
8632C     NOTE: FOR "MULTIPLE" AND "REPLICATION" CASES, IF SAMPLE SIZE
8633C           IS THE SAME, NO NEED TO REGENERATE THE MONTE CARLO
8634C           SAMPLES.
8635C
8636      IF(ICASP2.EQ.'KS  ')THEN
8637        ITYPE=0
8638      ELSEIF(ICASP2.EQ.'AD  ')THEN
8639        ITYPE=0
8640      ELSEIF(ICASP2.EQ.'PPCC')THEN
8641        ITYPE=0
8642      ELSEIF(ICASP2.EQ.'CHSQ')THEN
8643        ITYPE=1
8644      ENDIF
8645C
8646      IF(ITYPE.EQ.0)THEN
8647        IF(ICENSO.EQ.'ON')THEN
8648          CONTINUE
8649        ELSE
8650          NMCSAM=10000
8651          NTEMP=N
8652          IF(NSAVE.EQ.NTEMP)GOTO2119
8653          NSAVE=NTEMP
8654          DO2110I=1,NMCSAM
8655C
8656            CALL DPRAN2(ICASPL,ISEED,YTEMP,NTEMP,TEMP5,
8657     1                  A,B,MINMAX,
8658     1                  SHAPE1,SHAPE2,SHAPE3,SHAPE4,
8659     1                  SHAPE5,SHAPE6,SHAPE7,
8660     1                  IADEDF,IGEPDF,IMAKDF,IBEIDF,
8661     1                  ILGADF,ISKNDF,IGLDDF,IBGEDF,IGETDF,ICONDF,
8662     1                  IGOMDF,IKATDF,IGIGDF,IGEODF,
8663     1                  IBUGA3,ISUBRO,IFOUND,IERROR)
8664C
8665C           NOTE: DISTINGUISH BETWEEN FULLY SPECIFIED CASE (I.E.,
8666C                 DISTRIBUTION PARAMETERS ASSUMED KNOWN) AND
8667C                 UNKNOWN CASE (I.E., WE NEED TO ESTIMATE PARAMETERS
8668C                 FROM THE DATA).  ALTHOUGH THIS APPLIES TO THE
8669C                 K-S DISTRIBUTION, IT IS EVEN MORE CRITICAL FOR THE
8670C                 ANDERSON DARLING CASE.
8671C
8672            DO2115JJ=1,NTEMP
8673              YTEMP(JJ)=KSLOC + KSSCAL*YTEMP(JJ)
8674 2115       CONTINUE
8675C
8676            IF(IGOFFS.EQ.'OFF' .AND. ICASPL.NE.'PPCC')THEN
8677              CALL DPML1(YTEMP,CENSOR,NTEMP,ICASPL,IFLAGD,IFLAG9,
8678     1                   TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,YTEMP,
8679     1                   DTEMP,DTEMP2,DTEMP3,ITEMP1,MAXOBV,
8680     1                   ALOC,ASCALE,ALOWLI,AUPPLI,
8681     1                   SH1,SH2,SH3,SH4,
8682     1                   SH5,SH6,S7,
8683     1                   YLOWLM,YUPPLM,A,B,MINMAX,ISEED,
8684     1                   IADEDF,IGEPDF,IMAKDF,IBEIDF,
8685     1                   ILGADF,ISKNDF,IGLDDF,IGOMDF,IGIGDF,
8686     1                   IGEODF,IBGEDF,IGAUDF,
8687     1                   ICENSO,IEXPBC,IWEIBC,ICENTY,IDFTTY,
8688     1                   CLLIMI,CLWIDT,IHSTCW,IHSTOU,IRELAT,IRHSTG,
8689     1                   IBUGA3,ISUBRO,IERROR)
8690              IF(IFLAG9.EQ.-99)THEN
8691                ALOC=KSLOC
8692                ASCALE=KSSCAL
8693                SH1=SHAPE1
8694                SH2=SHAPE2
8695                SH3=SHAPE3
8696                SH4=SHAPE4
8697                SH5=SHAPE5
8698                SH6=SHAPE6
8699                SH7=SHAPE7
8700              ENDIF
8701            ELSEIF(ICASPL.EQ.'PPCC')THEN
8702            ELSE
8703              ALOC=KSLOC
8704              ASCALE=KSSCAL
8705              SH1=SHAPE1
8706              SH2=SHAPE2
8707              SH3=SHAPE3
8708              SH4=SHAPE4
8709              SH5=SHAPE5
8710              SH6=SHAPE6
8711              SH7=SHAPE7
8712            ENDIF
8713C
8714            CALL DPGOFB(YTEMP,XLOW,XHIGH,CENSOR,NTEMP,
8715     1                  ICASPL,ICASP2,IDATSW,
8716     1                  TEMP1,TEMP2,TEMP3,
8717     1                  YLOWLM,YUPPLM,A,B,MINMAX,
8718     1                  CLWIDT,CLLIMI,IHSTCW,IHSTOU,MINSIZ,
8719     1                  SHAPE1,SHAPE2,SHAPE3,SHAPE4,
8720     1                  SHAPE5,SHAPE6,SHAPE7,
8721     1                  IADEDF,IGEPDF,IMAKDF,IBEIDF,
8722     1                  ILGADF,ISKNDF,IGLDDF,IBGEDF,
8723     1                  IGETDF,ICONDF,IGOMDF,IKATDF,
8724     1                  IGIGDF,IGEODF,
8725     1                  MAXOBV,NUMSHA,KSLOC,KSSCAL,
8726     1                  NCELLS,NTOT,IDISFL,ILOWLM,
8727     1                  IBUGA3,ISUBRO,IERROR)
8728            IF(IERROR.EQ.'YES')GOTO9000
8729C
8730            CALL DPGOFA(YTEMP,XLOW,XHIGH,NTEMP,ICASPL,ICASP2,IDATSW,
8731     1                  TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,
8732     1                  WEIGHH,WEIGHV,
8733     1                  Y2,X2,D2,N2,
8734     1                  YLOWLM,YUPPLM,A,B,MINMAX,
8735     1                  PCHSLM,MINSIZ,
8736     1                  SHAPE1,SHAPE2,SHAPE3,SHAPE4,
8737     1                  SHAPE5,SHAPE6,SHAPE7,
8738     1                  IADEDF,IGEPDF,IMAKDF,IBEIDF,
8739     1                  ILGADF,ISKNDF,IGLDDF,IBGEDF,
8740     1                  IGETDF,ICONDF,IGOMDF,IKATDF,
8741     1                  IGIGDF,IGEODF,
8742     1                  MAXOBV,NUMSHA,KSLOC,KSSCAL,
8743     1                  PPA0,PPA1,PPCC,SDPPA0,SDPPA1,XRESSD,XRESDF,
8744     1                  CCALBE,PPA0BW,PPA1BW,
8745     1                  STATVA,STAT,STATCD,PVAL,IDF,
8746     1                  NCELLS,NTOT,IDISFL,ILOWLM,IMETHD,IDIST,
8747     1                  IBUGA3,ISUBRO,IERROR)
8748            IF(IERROR.EQ.'YES')GOTO9000
8749            YSTAT(I)=STATV9
8750 2110     CONTINUE
8751 2119     CONTINUE
8752          IDIR='UPPE'
8753          CALL DPGOF8(YSTAT,NMCSAM,STATVA,PVAL,IDIR,
8754     1                IBUGA3,ISUBRO,IERROR)
8755          STATCD=1.0 - PVAL
8756        ENDIF
8757      ENDIF
8758C
8759C               ****************************************************
8760C               **  STEP 3--                                      **
8761C               **  GENERATE THE OUTPUT FOR THE DESIRED STATISTIC **
8762C               **  TO DETERMINE P-VALUES/CONFIDENCE INTERVALS    **
8763C               **  FOR THE STATISTIC.                            **
8764C               ****************************************************
8765C
8766C
8767      IF(ICASP2.EQ.'CHSQ')THEN
8768        CALL DPCHS3(ICASPL,IDIST,NUMSHA,IFORSW,ICASP3,
8769     1              PID,IVARID,IVARI2,NREPL,
8770     1              NTOT,XMEAN,XSD,XMIN,XMAX,
8771     1              A,B,MINMAX,
8772     1              SHAPE1,SHAPE2,SHAPE3,SHAPE4,
8773     1              SHAPE5,SHAPE6,SHAPE7,
8774     1              KSLOC,KSSCAL,ICAPSW,ICAPTY,
8775     1              STATVA,STATCD,PVAL,NCELLS,IDF,IDISFL,MINSZ,
8776     1              CDF1,CDF2,CDF3,CDF4,
8777     1              IBUGA3,ISUBRO,IERROR)
8778CCCCC ELSEIF(ICASP2.EQ.'KS  ')THEN
8779CCCCC   CALL DP1KS3(ICASPL,IDIST,NUMSHA,IFORSW,IKSCVM,
8780CCCCC1              PID,IVARID,IVARI2,NREPL,
8781CCCCC1              N,XMEAN,XSD,XMIN,XMAX,
8782CCCCC1              A,B,MINMAX,
8783CCCCC1              SHAPE1,SHAPE2,SHAPE3,SHAPE4,
8784CCCCC1              SHAPE5,SHAPE6,SHAPE7,
8785CCCCC1              KSLOC,KSSCAL,ICAPSW,ICAPTY,IRTFFF,IRTFFP,
8786CCCCC1              STATVA,PVAL,CDF1,CDF2,CDF3,YSTAT,NMCSAM,
8787CCCCC1              YTEMP,MAXOBV,
8788CCCCC1              IBUGA3,ISUBRO,IERROR)
8789CCCCC ELSEIF(ICASP2.EQ.'AD  ')THEN
8790CCCCC   CALL DPADA3(ICASPL,IDIST,NUMSHA,IFORSW,IADCVM,
8791CCCCC1              PID,IVARID,IVARI2,NREPL,
8792CCCCC1              N,XMEAN,XSD,XMIN,XMAX,
8793CCCCC1              A,B,MINMAX,
8794CCCCC1              SHAPE1,SHAPE2,SHAPE3,SHAPE4,
8795CCCCC1              SHAPE5,SHAPE6,SHAPE7,
8796CCCCC1              KSLOC,KSSCAL,ICAPSW,ICAPTY,IRTFFF,IRTFFP,
8797CCCCC1              STATVA,STATV2,CDF1,CDF2,CDF3,CDF4,
8798CCCCC1              PVAL,YSTAT,NMCSAM,
8799CCCCC1              YTEMP,MAXOBV,
8800CCCCC1              IBUGA3,ISUBRO,IERROR)
8801      ELSEIF(ICASP2.EQ.'PPCC')THEN
8802CCCCC   CALL DPPPC8(ICASPL,IDIST,NUMSHA,IFORSW,IADCVM,
8803CCCCC1              PID,IVARID,IVARI2,NREPL,
8804CCCCC1              N,XMEAN,XSD,XMIN,XMAX,
8805CCCCC1              YLOWLM,YUPPLM,A,B,MINMAX,
8806CCCCC1              SHAPE1,SHAPE2,SHAPE3,SHAPE4,
8807CCCCC1              SHAPE5,SHAPE6,SHAPE7,
8808CCCCC1              KSLOC,KSSCAL,ICAPSW,ICAPTY,IRTFFF,IRTFFP,
8809CCCCC1              STATVA,STATV2,CDF1,CDF2,CDF3,CDF4,
8810CCCCC1              PVAL,YSTAT,NMCSAM,
8811CCCCC1              YTEMP,MAXOBV,
8812CCCCC1              IBUGA3,ISUBRO,IERROR)
8813      ENDIF
8814C
8815C               *****************
8816C               **  STEP 90--  **
8817C               **  EXIT       **
8818C               *****************
8819C
8820 9000 CONTINUE
8821      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GOF3')THEN
8822        WRITE(ICOUT,999)
8823        CALL DPWRST('XXX','BUG ')
8824        WRITE(ICOUT,9011)
8825 9011   FORMAT('***** AT THE END       OF DPGOF3--')
8826        CALL DPWRST('XXX','BUG ')
8827        WRITE(ICOUT,9012)STATVA,NMCSAM,PVAL
8828 9012   FORMAT('STATVA,NMCSAM,PVAL ',G15.7,I8,G15.7)
8829        CALL DPWRST('XXX','BUG ')
8830        IF(NMCSAM.GT.1)THEN
8831          DO9020I=1,MIN(NMCSAM,100)
8832            WRITE(ICOUT,9021)I,YSTAT(I)
8833 9021       FORMAT('I,YSTAT(I) = ',I8,G15.7)
8834            CALL DPWRST('XXX','BUG ')
8835 9020     CONTINUE
8836        ENDIF
8837      ENDIF
8838C
8839      RETURN
8840      END
8841      SUBROUTINE DPGOF4(STATVA,STATCD,PVAL,CDF1,CDF2,CDF3,CDF4,
8842     1                  IFLAGU,IFRST,ILAST,ICASPL,
8843     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
8844C
8845C     PURPOSE--UTILITY ROUTINE USED BY DPGOFI.  THIS ROUTINE
8846C              UPDATES THE PARAMETERS "STATVAL", "STATCDF", AND
8847C              "PVALUE" AFTER A GOODNESS OF FIT COMPUTATION.
8848C     WRITTEN BY--JAMES J. FILLIBEN
8849C                 STATISTICAL ENGINEERING DIVISION
8850C                 INFORMATION TECHNOLOGY LABORAOTRY
8851C                 NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY
8852C                 GAITHERSBURG, MD 20899-8980
8853C                 PHONE--301-975-2855
8854C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
8855C           OF THE NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY.
8856C     LANGUAGE--ANSI FORTRAN (1977)
8857C     VERSION NUMBER--2009/10
8858C     ORIGINAL VERSION--OCTOBER   2009.
8859C
8860C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
8861C
8862      CHARACTER*4 IFLAGU
8863      CHARACTER*4 ICASPL
8864      CHARACTER*4 IBUGA2
8865      CHARACTER*4 IBUGA3
8866      CHARACTER*4 ISUBRO
8867      CHARACTER*4 IERROR
8868C
8869      LOGICAL IFRST
8870      LOGICAL ILAST
8871C
8872      CHARACTER*4 IH
8873      CHARACTER*4 IH2
8874      CHARACTER*4 ISUBN0
8875      CHARACTER*4 ISUBN1
8876      CHARACTER*4 ISUBN2
8877      CHARACTER*4 ISTEPN
8878      CHARACTER*4 IST1CS
8879      CHARACTER*4 IOP
8880C
8881      SAVE IOUNI1
8882      SAVE IST1CS
8883C
8884C-----COMMON VARIABLES (GENERAL)--------------------------------------
8885C
8886      INCLUDE 'DPCOPA.INC'
8887      INCLUDE 'DPCOHK.INC'
8888      INCLUDE 'DPCOHO.INC'
8889      INCLUDE 'DPCOP2.INC'
8890C
8891C-----START POINT-----------------------------------------------------
8892C
8893      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'GOF4')THEN
8894        ISTEPN='1'
8895        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8896        WRITE(ICOUT,999)
8897  999   FORMAT(1X)
8898        CALL DPWRST('XXX','BUG ')
8899        WRITE(ICOUT,51)
8900   51   FORMAT('***** AT THE BEGINNING OF DPGOF4--')
8901        CALL DPWRST('XXX','BUG ')
8902        WRITE(ICOUT,53)STATVA,STATCD,PVAL
8903   53   FORMAT('STATVA,STATCD,PVAL = ',3G15.7)
8904        CALL DPWRST('XXX','BUG ')
8905      ENDIF
8906C
8907      IF(IFLAGU.EQ.'FILE')THEN
8908C
8909        IF(IFRST)THEN
8910          IOP='OPEN'
8911          IFLAG1=1
8912          IFLAG2=0
8913          IFLAG3=0
8914          IFLAG4=0
8915          IFLAG5=0
8916          CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
8917     1                IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
8918     1                IBUGA3,ISUBRO,IERROR)
8919          IF(IERROR.EQ.'YES')THEN
8920            IST1CS='CLOS'
8921            GOTO9000
8922          ELSE
8923            IST1CS='OPEN'
8924          ENDIF
8925C
8926          IF(ICASPL.EQ.'KS')THEN
8927            WRITE(IOUNI1,295)
8928  295       FORMAT(11X,'STATVAL',8X,'STATCDF',8X,'PVALUE',
8929     1             7X,'CUTUPP90',7X,'CUTUPP95',7X,'CUTUPP99')
8930  299      FORMAT(7E15.7)
8931          ELSEIF(ICASPL.EQ.'AD')THEN
8932            WRITE(IOUNI1,296)
8933  296       FORMAT(11X,'STATVAL',8X,'STATCDF',8X,'PVALUE',
8934     1             7X,'CUTUPP90',7X,'CUTUPP95',7X,'CUTUP975',
8935     1             7X,'CUTUPP99')
8936          ENDIF
8937        ENDIF
8938        IF(IST1CS.EQ.'OPEN')THEN
8939          IF(ICASPL.EQ.'KS')THEN
8940            WRITE(IOUNI1,299)STATVA,STATCD,PVAL,CDF1,CDF2,CDF3
8941          ELSEIF(ICASPL.EQ.'AD')THEN
8942            WRITE(IOUNI1,299)STATVA,STATCD,PVAL,CDF1,CDF2,CDF3,CDF4
8943          ENDIF
8944        ENDIF
8945      ELSEIF(IFLAGU.EQ.'ON')THEN
8946        IH='STAT'
8947        IH2='VAL '
8948        VALUE0=STATVA
8949        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
8950     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
8951     1              IANS,IWIDTH,IBUGA3,IERROR)
8952C
8953        IF(STATCD.NE.CPUMIN)THEN
8954          IH='STAT'
8955          IH2='CDF '
8956          VALUE0=STATCD
8957          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
8958     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
8959     1                IANS,IWIDTH,IBUGA3,IERROR)
8960        ENDIF
8961C
8962        IF(PVAL.NE.CPUMIN)THEN
8963          IH='PVAL'
8964          IH2='UE  '
8965          VALUE0=PVAL
8966          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
8967     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
8968     1                IANS,IWIDTH,IBUGA3,IERROR)
8969        ENDIF
8970C
8971        IF(CDF1.NE.CPUMIN)THEN
8972          IF(ICASPL.EQ.'PPCC')THEN
8973            IH='CUTO'
8974            IH2='FF01'
8975          ELSE
8976            IH='CUTO'
8977            IH2='FF90'
8978          ENDIF
8979          VALUE0=CDF1
8980          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
8981     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
8982     1                IANS,IWIDTH,IBUGA3,IERROR)
8983        ENDIF
8984C
8985        IF(CDF2.NE.CPUMIN)THEN
8986          IF(ICASPL.EQ.'PPCC')THEN
8987            IH='CUTO'
8988            IH2='F025'
8989          ELSE
8990            IH='CUTO'
8991            IH2='FF95'
8992          ENDIF
8993          VALUE0=CDF2
8994          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
8995     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
8996     1                IANS,IWIDTH,IBUGA3,IERROR)
8997        ENDIF
8998C
8999        IF(CDF3.NE.CPUMIN)THEN
9000          IF(ICASPL.EQ.'KS  ')THEN
9001            IH='CUTO'
9002            IH2='FF99'
9003          ELSEIF(ICASPL.EQ.'PPCC')THEN
9004            IH='CUTO'
9005            IH2='FF05'
9006          ELSE
9007            IH='CUTO'
9008            IH2='F975'
9009          ENDIF
9010          VALUE0=CDF3
9011          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
9012     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
9013     1                IANS,IWIDTH,IBUGA3,IERROR)
9014        ENDIF
9015C
9016        IF(CDF4.NE.CPUMIN)THEN
9017          IF(ICASPL.EQ.'PPCC')THEN
9018            IH='CUTO'
9019            IH2='FF10'
9020          ELSE
9021            IH='CUTO'
9022            IH2='FF99'
9023          ENDIF
9024          VALUE0=CDF4
9025          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
9026     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
9027     1                IANS,IWIDTH,IBUGA3,IERROR)
9028        ENDIF
9029C
9030      ENDIF
9031C
9032      IF(ILAST .AND. IFLAGU.EQ.'FILE' .AND. IST1CS.EQ.'OPEN')THEN
9033        IOP='CLOS'
9034        IFLAG1=1
9035        IFLAG2=0
9036        IFLAG3=0
9037        IFLAG4=0
9038        IFLAG5=0
9039        CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
9040     1              IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
9041     1              IBUGA3,ISUBRO,IERROR)
9042        IST1CS='CLOS'
9043      ENDIF
9044C
9045C               *****************
9046C               **  STEP 90--  **
9047C               **  EXIT       **
9048C               *****************
9049C
9050 9000 CONTINUE
9051C
9052      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'GOF4')THEN
9053        WRITE(ICOUT,999)
9054        CALL DPWRST('XXX','BUG ')
9055        WRITE(ICOUT,9011)
9056 9011   FORMAT('***** AT THE END OF DPGOF4--')
9057        CALL DPWRST('XXX','BUG ')
9058      ENDIF
9059C
9060      RETURN
9061      END
9062      SUBROUTINE DPGOF8(Y,N,STAT,PVAL,IDIR,IBUGA3,ISUBRO,IERROR)
9063C
9064C     PURPOSE--BASED ON A MONTE CARLO SIMULATION, RETURN AN
9065C              APPROPRIATE P-VALUE.
9066C     WRITTEN BY--ALAN HECKERT
9067C                 STATISTICAL ENGINEERING DIVISION
9068C                 INFORMATION TECHNOLOGY LABORATORY
9069C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
9070C                 GAITHERSBURG, MD 20899-8980
9071C                 PHONE--301-975-2855
9072C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
9073C           OF THE NATIONAL BUREAU OF STANDARDS.
9074C     LANGUAGE--ANSI FORTRAN (1977)
9075C     VERSION NUMBER--2009/9
9076C     ORIGINAL VERSION--SEPTEMBER 2009.
9077C
9078C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
9079C
9080      CHARACTER*4 IDIR
9081      CHARACTER*4 IBUGA3
9082      CHARACTER*4 ISUBRO
9083      CHARACTER*4 IERROR
9084C
9085C---------------------------------------------------------------------
9086C
9087      DIMENSION Y(*)
9088C
9089C---------------------------------------------------------------------
9090C
9091      INCLUDE 'DPCOP2.INC'
9092C
9093C-----START POINT-----------------------------------------------------
9094C
9095      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GOF8')THEN
9096        WRITE(ICOUT,999)
9097        CALL DPWRST('XXX','BUG ')
9098        WRITE(ICOUT,11)
9099   11   FORMAT('***** AT THE BEGINNING OF DPGOF8--')
9100        CALL DPWRST('XXX','BUG ')
9101        WRITE(ICOUT,12)N,STAT,IDIR
9102   12   FORMAT('N,STAT,IDIR = ',I8,G15.7,2X,A4)
9103        CALL DPWRST('XXX','BUG ')
9104        DO20I=1,N
9105          WRITE(ICOUT,21)I,Y(I)
9106   21     FORMAT('I,Y(I) = ',I8,G15.7)
9107          CALL DPWRST('XXX','BUG ')
9108   20   CONTINUE
9109      ENDIF
9110C
9111      IERROR='NO'
9112C
9113C               ********************************************
9114C               **  STEP 1--                              **
9115C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
9116C               ********************************************
9117C
9118      IF(N.LT.2)THEN
9119        WRITE(ICOUT,999)
9120  999   FORMAT(1X)
9121        CALL DPWRST('XXX','BUG ')
9122        WRITE(ICOUT,51)
9123   51   FORMAT('***** ERROR IN DPGOF8 (P-VALUE COMPUTATION)--')
9124        CALL DPWRST('XXX','BUG ')
9125        WRITE(ICOUT,53)
9126   53   FORMAT('      THE NUMBER OF OBSERVATIONS FOR WHICH A P-VALUE')
9127        CALL DPWRST('XXX','BUG ')
9128        WRITE(ICOUT,55)
9129   55   FORMAT('      IS BEING COMPUTED IS LESS THAN TWO.')
9130        CALL DPWRST('XXX','BUG ')
9131        WRITE(ICOUT,57)N
9132   57   FORMAT('      THE NUMBER OF OBSERVATIONS = ',I5)
9133        CALL DPWRST('XXX','BUG ')
9134        IERROR='YES'
9135        GOTO9000
9136      ENDIF
9137C
9138C               *****************************************
9139C               **  STEP 1--                           **
9140C               **  COMPUTE THE P-VALUE                **
9141C               *****************************************
9142C
9143      CALL SORT(Y,N,Y)
9144C
9145      NBELOW=0
9146      NABOVE=0
9147      NEQUAL=0
9148      DO100I=1,N
9149        IF(Y(I).LT.STAT)THEN
9150          NBELOW=NBELOW+1
9151        ELSE
9152          NSTRT=I
9153          GOTO109
9154        ENDIF
9155  100 CONTINUE
9156      GOTO209
9157  109 CONTINUE
9158C
9159      DO200I=NSTRT,N
9160        IF(Y(I).EQ.STAT)THEN
9161          NEQUAL=NEQUAL+1
9162        ELSE
9163          GOTO209
9164        ENDIF
9165  200 CONTINUE
9166  209 CONTINUE
9167      NABOVE=N-NBELOW-NEQUAL
9168C
9169      IF(IDIR.EQ.'LOWE')THEN
9170        PVAL=REAL(NBELOW)/REAL(N)
9171      ELSE
9172        PVAL=REAL(NABOVE)/REAL(N)
9173      ENDIF
9174C
9175C               *****************
9176C               **  STEP 90--  **
9177C               **  EXIT       **
9178C               *****************
9179C
9180 9000 CONTINUE
9181      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GOF8')THEN
9182        WRITE(ICOUT,999)
9183        CALL DPWRST('XXX','BUG ')
9184        WRITE(ICOUT,9011)
9185 9011   FORMAT('***** AT THE END       OF DPGOF8--')
9186        CALL DPWRST('XXX','BUG ')
9187        WRITE(ICOUT,9012)NBELOW,NEQUAL,NABOVE,PVAL
9188 9012   FORMAT('NBELOW,NEQUAL,NABOVE,PVAL = ',3I8,G15.7)
9189        CALL DPWRST('XXX','BUG ')
9190      ENDIF
9191C
9192      RETURN
9193      END
9194      SUBROUTINE DPGOF9(Y,N,ICASPL,ICASP2,
9195     1                  Y2,X2,YTHEOR,N2,
9196     1                  YLOWLM,YUPPLM,A,B,MINMAX,
9197     1                  SHAPE1,SHAPE2,SHAPE3,SHAPE4,
9198     1                  SHAPE5,SHAPE6,SHAPE7,
9199     1                  IADEDF,IGEPDF,IMAKDF,IBEIDF,
9200     1                  ILGADF,ISKNDF,IGLDDF,IBGEDF,IGETDF,ICONDF,
9201     1                  IGOMDF,IKATDF,IGIGDF,IGEODF,
9202     1                  MAXOBV,
9203     1                  KSLOC,KSSCAL,
9204     1                  STATVA,DM,
9205     1                  IBUGA3,ISUBRO,IERROR,IERRFL)
9206C
9207C     PURPOSE--COMPUTE ONE OF THE FOLLOWING GOODNESS OF FIT TESTS:
9208C
9209C              1) KOLMOGOROV-SMIRNOV
9210C              2) ANDERSON-DARLING
9211C              3) PPCC
9212C              4) AIC/BIC/BICC (TO BE ADDED)
9213C              5) CHI-SQUARE (TO BE ADDED)
9214C
9215C              THIS IS FOR THE UNGROUPED, NO CENSORING CASE.
9216C              THIS ROUTINE SIMPLY CALCULATES THE VALUE OF
9217C              THE STATISTIC.  IT DOES NO PRINTING (THE CALLING
9218C              ROUTINE WILL PRINT OUT ANY ERRORS).  IF AN
9219C              OUTPUT TABLE IS DESIRED, THIS WILL ALSO BE GENERATED
9220C              BY THE CALLING ROUTINE.
9221C
9222C     WRITTEN BY--ALAN HECKERT
9223C                 STATISTICAL ENGINEERING DIVISION
9224C                 INFORMATION TECHNOLOGY LABORATORY
9225C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
9226C                 GAITHERSBURG, MD 20899-8980
9227C                 PHONE--301-975-2899
9228C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
9229C           OF THE NATIONAL BUREAU OF STANDARDS.
9230C     LANGUAGE--ANSI FORTRAN (1977)
9231C     VERSION NUMBER--2009/9
9232C     ORIGINAL VERSION--SEPTEMBER 2009.
9233C     UPDATED         --OCTOBER   2009. ADD PPCC METHOD
9234C
9235C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
9236C
9237      CHARACTER*4 ICASPL
9238      CHARACTER*4 ICASP2
9239      CHARACTER*4 IBUGA3
9240      CHARACTER*4 ISUBRO
9241      CHARACTER*4 IADEDF
9242      CHARACTER*4 IGEPDF
9243      CHARACTER*4 IMAKDF
9244      CHARACTER*4 IBEIDF
9245      CHARACTER*4 ILGADF
9246      CHARACTER*4 ISKNDF
9247      CHARACTER*4 IGLDDF
9248      CHARACTER*4 IBGEDF
9249      CHARACTER*4 IGETDF
9250      CHARACTER*4 ICONDF
9251      CHARACTER*4 IGOMDF
9252      CHARACTER*4 IKATDF
9253      CHARACTER*4 IGIGDF
9254      CHARACTER*4 IGEODF
9255      CHARACTER*4 IERROR
9256C
9257      CHARACTER*4 ISUBN1
9258      CHARACTER*4 ISUBN2
9259      CHARACTER*4 ICAPSW
9260      CHARACTER*4 ICAPTY
9261C
9262      REAL KSLOC
9263      REAL KSSCAL
9264C
9265      DOUBLE PRECISION DM
9266      DOUBLE PRECISION DEPS
9267      DOUBLE PRECISION DSUM1
9268      DOUBLE PRECISION DTEMP1
9269      DOUBLE PRECISION DTEMP2
9270      DOUBLE PRECISION DTERM1
9271      DOUBLE PRECISION DTERM2
9272      DOUBLE PRECISION DN
9273CCCCC DOUBLE PRECISION XPAR(5)
9274C
9275C---------------------------------------------------------------------
9276C
9277      DIMENSION Y(*)
9278      DIMENSION Y2(*)
9279      DIMENSION X2(*)
9280      DIMENSION YTHEOR(*)
9281C
9282C-----COMMON----------------------------------------------------------
9283C
9284      INCLUDE 'DPCOMC.INC'
9285      INCLUDE 'DPCOP2.INC'
9286C
9287C-----START POINT-----------------------------------------------------
9288C
9289C
9290      ISUBN1='DPGO'
9291      ISUBN2='F9  '
9292      IERROR='NO'
9293      IERRFL=0
9294      ICAPSW='NULL'
9295      ICAPTY='NULL'
9296C
9297      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GOF9')THEN
9298        WRITE(ICOUT,999)
9299  999   FORMAT(1X)
9300        CALL DPWRST('XXX','BUG ')
9301        WRITE(ICOUT,71)
9302   71   FORMAT('***** AT THE BEGINNING OF DPGOF9--')
9303        CALL DPWRST('XXX','BUG ')
9304        WRITE(ICOUT,72)ICASPL,ICASP2,N,MINMAX,MAXOBV
9305   72   FORMAT('ICASPL,ICASP2,N,MINMAX,MAXOBV = ',2(A4,2X),3I8)
9306        CALL DPWRST('XXX','BUG ')
9307        WRITE(ICOUT,73)A,B,YLOWLM,YUPPLM
9308   73   FORMAT('A,B,YLOWLM,YUPPLM = ',4G15.7)
9309        CALL DPWRST('XXX','BUG ')
9310        WRITE(ICOUT,74)KSLOC,KSSCAL,SHAPE1,SHAPE2
9311   74   FORMAT('KSLOC,KSSCAL,SHAPE1,SHAPE2 = ',4G15.7)
9312        CALL DPWRST('XXX','BUG ')
9313        IF(N.GE.1)THEN
9314          DO85I=1,N
9315            WRITE(ICOUT,86)I,Y(I)
9316   86       FORMAT('I,Y(I) = ',I8,G15.7)
9317            CALL DPWRST('XXX','BUG ')
9318   85     CONTINUE
9319        ENDIF
9320      ENDIF
9321C
9322C               ********************************************
9323C               **  STEP 1--                              **
9324C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
9325C               ********************************************
9326C
9327      IF(N.LT.2)THEN
9328        IERRFL=0
9329        IERROR='YES'
9330        STATVA=CPUMAX
9331        GOTO9000
9332      ENDIF
9333C
9334      HOLD=Y(1)
9335      DO60I=1,N
9336        IF(Y(I).NE.HOLD)GOTO69
9337   60 CONTINUE
9338      IERROR='YES'
9339      IERRFL=2
9340      GOTO9000
9341   69 CONTINUE
9342C
9343C               **********************************************
9344C               **  STEP 1--                                **
9345C               **  DETERMINE THE ARRAY FOR WHICH THE CDF   **
9346C               **  WILL BE COMPUTED                        **
9347C               **  1) K-S   - EMPIRICRICAL CDF FUNCTION    **
9348C               **  2) A-D   - ORIGINAL DATA ARRAY          **
9349C               **  3) PPCC  - ORIGINAL DATA ARRAY          **
9350C               **********************************************
9351C
9352      IF(ICASP2.EQ.'KS  ')THEN
9353        CALL SORT(Y,N,Y)
9354        J=1
9355        X2(J)=Y(1)
9356        Y2(J)=0.0
9357        J=2
9358        X2(J)=Y(1)
9359        Y2(J)=1.0/REAL(N)
9360        DO1010I=2,N
9361          J=J+1
9362          X2(J)=Y(I)
9363          Y2(J)=REAL(I-1)/REAL(N)
9364          J=J+1
9365          X2(J)=Y(I)
9366          Y2(J)=REAL(I)/REAL(N)
9367 1010   CONTINUE
9368        N2=J
9369      ELSEIF(ICASP2.EQ.'AD  ')THEN
9370        CALL SORT(Y,N,X2)
9371        N2=N
9372      ELSEIF(ICASP2.EQ.'PPCC' .OR. ICASP2.EQ.'AIC ' .OR.
9373     1       ICASP2.EQ.'AICC' .OR. ICASP2.EQ.'BIC ')THEN
9374        DO1020I=1,N
9375          X2(I)=Y(I)
9376 1020   CONTINUE
9377        N2=N
9378      ENDIF
9379C
9380      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GOF9')THEN
9381        WRITE(ICOUT,1081)N2
9382 1081   FORMAT('N2 = ',I8)
9383        CALL DPWRST('XXX','BUG ')
9384        DO1085I=1,N2
9385          WRITE(ICOUT,1086)I,Y2(I),X2(I)
9386 1086     FORMAT('I,Y2(I),X2(I) = ',I8,2E12.5)
9387          CALL DPWRST('XXX','BUG ')
9388 1085   CONTINUE
9389      ENDIF
9390C
9391C               *************************************************
9392C               **  STEP 2--                                   **
9393C               **  COMPUTE THEORETICAL CDF FUNCTION.  FROM    **
9394C               **  ABOVE, Y2 = "PLOTTING POSITIONS" AND       **
9395C               **  X2 = DATA VALUE CORRESPONDING TO           **
9396C               **  "PLOTTING POSITIONS".  WE NEED TO COMPUTE  **
9397C               **  THEORETICAL VALUES AT "PLOTTING POSITIONS" **
9398C               *************************************************
9399C
9400      IF(ICASP2.EQ.'KS  ' .OR. ICASP2.EQ.'AD  ')THEN
9401        IFLAGD=1
9402        CALL DPCDF1(X2,YTHEOR,N2,ICASPL,IFLAGD,
9403     1              SHAPE1,SHAPE2,SHAPE3,SHAPE4,
9404     1              SHAPE5,SHAPE6,SHAPE7,
9405     1              YLOWLM,YUPPLM,A,B,MINMAX,
9406     1              ICAPSW,ICAPTY,
9407     1              IADEDF,IGEPDF,IMAKDF,IBEIDF,
9408     1              ILGADF,ISKNDF,IGLDDF,IBGEDF,
9409     1              IGETDF,ICONDF,IGOMDF,IKATDF,
9410     1              IGIGDF,IGEODF,
9411     1              KSLOC,KSSCAL,
9412     1              IBUGA3,ISUBRO,IERROR)
9413        IF(IFLAGD.EQ.99)THEN
9414          IERRFL=3
9415          GOTO9000
9416        ENDIF
9417C
9418        AN=REAL(N2)
9419        DN=DBLE(N2)
9420        IF(ICASP2.EQ.'KS  ')THEN
9421          DM=0.0D0
9422          DO1110I=1,N2
9423            DTERM1=DBLE(Y2(I)) - DBLE(YTHEOR(I))
9424            DM=MAX(DABS(DTERM1),DM)
9425 1110     CONTINUE
9426          STATVA=REAL(DM)
9427        ELSEIF(ICASP2.EQ.'AD  ')THEN
9428          DSUM1=0.D0
9429          DEPS=1.0D-30
9430          DO1210I=1,N2
9431            DTEMP1=DBLE(YTHEOR(I))
9432            DTEMP2=1.0D0-DBLE(YTHEOR(N+1-I))
9433            IF(DTEMP1.LE.0.0D0)DTEMP1=DEPS
9434            IF(DTEMP2.LE.0.0D0)DTEMP2=DEPS
9435            DTERM1=(2.0D0*DBLE(I)-1.0D0)
9436            DTERM2=DLOG(DTEMP1) + DLOG(DTEMP2)
9437            DSUM1=DSUM1 + DTERM1*DTERM2
9438 1210     CONTINUE
9439          DA2=-DSUM1/DBLE(N) - DBLE(N)
9440          STATVA=REAL(DA2)
9441        ENDIF
9442      ELSEIF(ICASP2.EQ.'PPCC')THEN
9443        IFLAGD=0
9444        PPLOC=0.0
9445        PPSCAL=1.0
9446        NHIGH=0
9447CCCCC   CALL DPPP2(X2,YTHEOR,N2,ICASPL,NHIGH,
9448CCCCC1             TEMP1,TEMP2,TEMP3,
9449CCCCC1             YLOWLM,YUPPLM,A,B,MINMAX,
9450CCCCC1             SHAPE1,SHAPE2,SHAPE3,SHAPE4,
9451CCCCC1             SHAPE5,SHAPE6,SHAPE7,
9452CCCCC1             IADEDF,IGEPDF,IMAKDF,IBEIDF,
9453CCCCC1             ILGADF,ISKNDF,IGLDDF,IBGEDF,
9454CCCCC1             IGETDF,ICONDF,IGOMDF,IKATDF,
9455CCCCC1             IGIGDF,IGEODF,
9456CCCCC1             IPPLDP,MAXOBV,ICENSO,IMETHD,ILEVEL,
9457CCCCC1             PPLOC,PPSCAL,
9458CCCCC1             PPA0,PPA1,PPCC,SDPPA0,SDPPA1,XRESSD,XRESDF,
9459CCCCC1             CCALBE,PPA0Bw,PPA1BW,
9460CCCCC1             WEIGHH,WEIGHV,
9461CCCCC1             Y2,X2,D2,NTEMP,NPLOTV,NCURVE,
9462CCCCC1             IBUGA3,ISUBRO,IERROR)
9463      ELSEIF(ICASP2.EQ.'AIC ' .OR. ICASP2.EQ.'BIC ' .OR.
9464     1       ICASP2.EQ.'AICC')THEN
9465        CALL DPLIK1(X2,YTHEOR,N2,ICASPL,
9466     1              SHAPE1,SHAPE2,SHAPE3,SHAPE4,
9467     1              SHAPE5,SHAPE6,SHAPE7,
9468     1              YLOWLM,YUPPLM,A,B,MINMAX,
9469     1              IADEDF,IGEPDF,IMAKDF,IBEIDF,
9470     1              ILGADF,ISKNDF,IGLDDF,IBGEDF,
9471     1              IGETDF,ICONDF,IGOMDF,IKATDF,
9472     1              IGIGDF,IGEODF,
9473     1              KSLOC,KSSCAL,
9474     1              ALIKE,AIC,AICC,BIC,
9475     1              IBUGA3,ISUBRO,IERROR)
9476        IF(ICASP2.EQ.'AIC ')THEN
9477          STATVA=AIC
9478        ELSEIF(ICASP2.EQ.'AICC')THEN
9479          STATVA=AICC
9480        ELSEIF(ICASP2.EQ.'BIC ')THEN
9481          STATVA=BIC
9482        ENDIF
9483      ENDIF
9484C
9485C               *****************
9486C               **  STEP 90--  **
9487C               **  EXIT       **
9488C               *****************
9489C
9490 9000 CONTINUE
9491      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GOF9')THEN
9492        WRITE(ICOUT,999)
9493        CALL DPWRST('XXX','BUG ')
9494        WRITE(ICOUT,9011)
9495 9011   FORMAT('***** AT THE END       OF DPGOF9--')
9496        CALL DPWRST('XXX','BUG ')
9497        WRITE(ICOUT,9012)ICASPL,ICASP2,IERROR,N,N2,STATVA
9498 9012   FORMAT('ICASPL,ICASP2,IERROR,N,N2,STATVA = ',
9499     1         3(A4,2X),2I8,G15.7)
9500        CALL DPWRST('XXX','BUG ')
9501        DO9020I=1,N2
9502          WRITE(ICOUT,9021)I,Y2(I),X2(I),YTHEOR(I)
9503 9021     FORMAT('I,Y2(I),X2(I),YTHEOR(I) = ',I8,3G15.7)
9504          CALL DPWRST('XXX','BUG ')
9505 9020   CONTINUE
9506      ENDIF
9507C
9508      RETURN
9509      END
9510      SUBROUTINE DPGOFA(Y,XLOW,XHIGH,N,ICASPL,ICASP2,IDATSW,
9511     1                  TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,
9512     1                  WEIGHH,WEIGHV,
9513     1                  Y2,X2,D2,N2,
9514     1                  YLOWLM,YUPPLM,A,B,MINMAX,
9515     1                  PCHSLM,MINSIZ,
9516     1                  SHAPE1,SHAPE2,SHAPE3,SHAPE4,
9517     1                  SHAPE5,SHAPE6,SHAPE7,
9518     1                  IADEDF,IGEPDF,IMAKDF,IBEIDF,
9519     1                  ILGADF,ISKNDF,IGLDDF,IBGEDF,
9520     1                  IGETDF,ICONDF,IGOMDF,IKATDF,
9521     1                  IGIGDF,IGEODF,
9522     1                  MAXOBV,NUMSHA,KSLOC,KSSCAL,
9523     1                  PPA0,PPA1,PPCC,SDPPA0,SDPPA1,XRESSD,XRESDF,
9524     1                  CCALBE,PPA0BW,PPA1BW,
9525     1                  STATVA,STAT,STATCD,PVAL,IDF,
9526     1                  NCELLS,NTOT,IDISFL,ILOWLM,IMETHD,IDIST,
9527     1                  IBUGA3,ISUBRO,IERROR)
9528C
9529C     PURPOSE--COMPUTE ONE OF THE FOLLOWING GOODNESS OF FIT TESTS
9530C              FOR GROUPED DATA:
9531C
9532C              1) CHI-SQUARE
9533C              2) PPCC
9534C
9535C              FOLLOWING MAY BE ADDED LATER
9536C              3) KOLMOGOROV-SMIRNOV
9537C              4) ANDERSON-DARLING
9538C              5) AIC/BIC/BICC (TO BE ADDED)
9539C
9540C              THIS IS FOR THE GROUPED, NO CENSORING CASE.
9541C              THIS ROUTINE SIMPLY CALCULATES THE VALUE OF
9542C              THE STATISTIC.  IT DOES NO PRINTING (THE CALLING
9543C              ROUTINE WILL PRINT OUT ANY ERRORS).  IF AN
9544C              OUTPUT TABLE IS DESIRED, THIS WILL ALSO BE GENERATED
9545C              BY THE CALLING ROUTINE.
9546C
9547C              THIS ROUTINE ASSUMES THAT THE APPROPRIATE BINNING
9548C              HAS ALREADY BEEN PERFORMED.  THIS IS DONE IN THE
9549C              DPGOFB ROUTINE.  SPLIT INTO 2 SEPARATE ROUTINES
9550C              TO MAKE DPGOFA CALLABLE FROM BOTH THE "GOODNESS OF FIT"
9551C              COMMAND AND THE "PPCC PLOT" COMMAND.  SOME OF THE ERROR
9552C              CHECKING IS ALSO PERFORMED IN DPGOFB.
9553C
9554C     WRITTEN BY--ALAN HECKERT
9555C                 STATISTICAL ENGINEERING DIVISION
9556C                 INFORMATION TECHNOLOGY LABORATORY
9557C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
9558C                 GAITHERSBURG, MD 20899-8980
9559C                 PHONE--301-975-2899
9560C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
9561C           OF THE NATIONAL BUREAU OF STANDARDS.
9562C     LANGUAGE--ANSI FORTRAN (1977)
9563C     VERSION NUMBER--2009/11
9564C     ORIGINAL VERSION--NOVEMBER  2009.
9565C     UPDATED         --JANUARY   2010. SPLIT BINNING INTO DPGOFB
9566C                                       ROUTINE
9567C
9568C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
9569C
9570      CHARACTER*4 IDATSW
9571      CHARACTER*4 ICASPL
9572      CHARACTER*4 ICASP2
9573      CHARACTER*4 IMETHD
9574      CHARACTER*4 IBUGA3
9575      CHARACTER*4 ISUBRO
9576      CHARACTER*4 IADEDF
9577      CHARACTER*4 IGEPDF
9578      CHARACTER*4 IMAKDF
9579      CHARACTER*4 IBEIDF
9580      CHARACTER*4 ILGADF
9581      CHARACTER*4 ISKNDF
9582      CHARACTER*4 IGLDDF
9583      CHARACTER*4 IBGEDF
9584      CHARACTER*4 IGETDF
9585      CHARACTER*4 ICONDF
9586      CHARACTER*4 IGOMDF
9587      CHARACTER*4 IKATDF
9588      CHARACTER*4 IGIGDF
9589      CHARACTER*4 IGEODF
9590      CHARACTER*4 IERROR
9591C
9592      CHARACTER*60 IDIST
9593C
9594      CHARACTER*4 ISUBN1
9595      CHARACTER*4 ISUBN2
9596      CHARACTER*4 ISTEPN
9597      CHARACTER*4 ICENSO
9598      CHARACTER*4 IWRITE
9599      CHARACTER*4 IDISFL
9600      CHARACTER*4 ICAPSW
9601      CHARACTER*4 ICAPTY
9602C
9603      REAL PCHSLM
9604      REAL KSLOC
9605      REAL KSSCAL
9606C
9607      DOUBLE PRECISION DOBS
9608      DOUBLE PRECISION DEXPZ
9609      DOUBLE PRECISION DSUM1
9610      DOUBLE PRECISION DN
9611C
9612C---------------------------------------------------------------------
9613C
9614      DIMENSION Y(*)
9615      DIMENSION XLOW(*)
9616      DIMENSION XHIGH(*)
9617      DIMENSION TEMP1(*)
9618      DIMENSION TEMP2(*)
9619      DIMENSION TEMP3(*)
9620      DIMENSION TEMP4(*)
9621      DIMENSION TEMP5(*)
9622      DIMENSION WEIGHH(*)
9623      DIMENSION WEIGHV(*)
9624      DIMENSION Y2(*)
9625      DIMENSION X2(*)
9626      DIMENSION D2(*)
9627C
9628C-----COMMON----------------------------------------------------------
9629C
9630      INCLUDE 'DPCOMC.INC'
9631      INCLUDE 'DPCOP2.INC'
9632C
9633C-----START POINT-----------------------------------------------------
9634C
9635C
9636      ISUBN1='DPGO'
9637      ISUBN2='FA  '
9638      IERROR='NO'
9639      IERRFL=0
9640      ICENSO='OFF'
9641      IWRITE='OFF'
9642      ICAPSW='NULL'
9643      ICAPTY='NULL'
9644C
9645      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GOFA')THEN
9646        ISTEPN='0'
9647        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9648        WRITE(ICOUT,999)
9649  999   FORMAT(1X)
9650        CALL DPWRST('XXX','BUG ')
9651        WRITE(ICOUT,51)
9652   51   FORMAT('***** AT THE BEGINNING OF DPGOFA--')
9653        CALL DPWRST('XXX','BUG ')
9654        WRITE(ICOUT,52)ICASPL,ICASP2,IDATSW,N,MINMAX,ILOWLM
9655   52   FORMAT('ICASPL,ICASP2,IDATSW,N,MINMAX,ILOWLM = ',3(A4,2X),2I8)
9656        CALL DPWRST('XXX','BUG ')
9657        WRITE(ICOUT,53)MINSIZ,NCELLS
9658   53   FORMAT('MINSIZ,NCELLS = ',2I8)
9659        CALL DPWRST('XXX','BUG ')
9660        WRITE(ICOUT,54)A,B,KSLOC,KSSCAL,PCHSLM,IDISFL
9661   54   FORMAT('A,B,KSLOC,KSSCAL,PCHSLM,IDISFL = ',5G15.7,2X,A4)
9662        CALL DPWRST('XXX','BUG ')
9663        WRITE(ICOUT,55)SHAPE1,SHAPE2,SHAPE3,SHAPE4
9664   55   FORMAT('SHAPE1,SHAPE2,SHAPE3,SHAPE4 = ',4G15.7)
9665        CALL DPWRST('XXX','BUG ')
9666        IF(N.GE.1)THEN
9667          DO65I=1,N
9668            WRITE(ICOUT,66)I,Y(I),XLOW(I),XHIGH(I)
9669   66       FORMAT('I,Y(I),XLOW(I),XHIGH(I) = ',I8,3G15.7)
9670            CALL DPWRST('XXX','BUG ')
9671   65     CONTINUE
9672        ENDIF
9673      ENDIF
9674C
9675C               *************************************************
9676C               **  STEP 3--                                   **
9677C               **  COMPUTE THEORETICAL CDF FUNCTION.          **
9678C               *************************************************
9679C
9680      ISTEPN='3'
9681      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GOFA')
9682     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9683C
9684      IF(ICASP2.EQ.'CHSQ')THEN
9685        IVAL1=-99
9686        IVAL2=-99
9687C
9688        DO105I=1,N
9689          TEMP3(I)=Y(I)
9690          TEMP4(I)=XLOW(I)
9691          TEMP5(I)=XHIGH(I)
9692  105   CONTINUE
9693C
9694        IF(IDISFL.EQ.'DISC')THEN
9695          DO110I=1,N
9696            IVALU=INT(XHIGH(I)+0.01)
9697            IF(IVALU.LT.ILOWLM)THEN
9698              WRITE(ICOUT,999)
9699              CALL DPWRST('XXX','BUG ')
9700              WRITE(ICOUT,111)
9701  111         FORMAT('***** ERROR IN CHI-SQUARE GOODNESS OF FIT--')
9702              CALL DPWRST('XXX','BUG ')
9703              WRITE(ICOUT,113)
9704  113         FORMAT('      BIN LIMITS BELOW LOWER BOUND FOR ',
9705     1               'THE SPECIFIED DISTRIBUTION.')
9706              CALL DPWRST('XXX','BUG ')
9707              WRITE(ICOUT,115)IDIST(1:40)
9708  115         FORMAT('      DISTRIBUTION: ',A40)
9709              CALL DPWRST('XXX','BUG ')
9710              WRITE(ICOUT,117)IVALU
9711  117         FORMAT('      UPPER BIN LIMIT FOR BIN 1: ',I8)
9712              CALL DPWRST('XXX','BUG ')
9713              WRITE(ICOUT,119)ILOWLM
9714  119         FORMAT('      LOWER BOUND FOR DISTRIBUTION: ',I8)
9715              CALL DPWRST('XXX','BUG ')
9716              IERROR='YES'
9717              GOTO9000
9718            ENDIF
9719            XHIGH(I)=REAL(IVALU)
9720            IVALL=INT(XLOW(I)-0.01)
9721C
9722            IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GOFA')THEN
9723              WRITE(ICOUT,121)
9724  121         FORMAT('DPGOFA: CHI-SQUARE DISCRETE CASE')
9725              CALL DPWRST('XXX','BUG ')
9726              WRITE(ICOUT,122)I,XLOW(I),XHIGH(I),IVALL,IVALU
9727  122         FORMAT('I,XLOW(I),XHIGH(I),IVALL,IVALU = ',
9728     1               I8,2G15.7,2I8)
9729              CALL DPWRST('XXX','BUG ')
9730            ENDIF
9731C
9732            IF(IVALU.EQ.IVALL)IVALL=IVALU-1
9733            IF(IVALL.LT.ILOWLM)IVALL=ILOWLM
9734            XLOW(I)=REAL(IVALL)
9735  110     CONTINUE
9736          IVAL1=INT(XLOW(1)+0.01)
9737          IVAL2=INT(XHIGH(1)+0.01)
9738        ENDIF
9739        FLAGD=0
9740        CALL DPCDF1(XLOW,TEMP1,N,ICASPL,IFLAGD,
9741     1              SHAPE1,SHAPE2,SHAPE3,SHAPE4,
9742     1              SHAPE5,SHAPE6,SHAPE7,
9743     1              YLOWLM,YUPPLM,A,B,MINMAX,
9744     1              ICAPSW,ICAPTY,
9745     1              IADEDF,IGEPDF,IMAKDF,IBEIDF,
9746     1              ILGADF,ISKNDF,IGLDDF,IBGEDF,
9747     1              IGETDF,ICONDF,IGOMDF,IKATDF,
9748     1              IGIGDF,IGEODF,
9749     1              KSLOC,KSSCAL,
9750     1              IBUGA3,ISUBRO,IERROR)
9751        CALL DPCDF1(XHIGH,TEMP2,N,ICASPL,IFLAGD,
9752     1              SHAPE1,SHAPE2,SHAPE3,SHAPE4,
9753     1              SHAPE5,SHAPE6,SHAPE7,
9754     1              YLOWLM,YUPPLM,A,B,MINMAX,
9755     1              ICAPSW,ICAPTY,
9756     1              IADEDF,IGEPDF,IMAKDF,IBEIDF,
9757     1              ILGADF,ISKNDF,IGLDDF,IBGEDF,
9758     1              IGETDF,ICONDF,IGOMDF,IKATDF,
9759     1              IGIGDF,IGEODF,
9760     1              KSLOC,KSSCAL,
9761     1              IBUGA3,ISUBRO,IERROR)
9762C
9763        IF(IFLAGD.EQ.99)THEN
9764          IERROR='YES'
9765          GOTO9000
9766        ENDIF
9767        IF(IDISFL.EQ.'DISC')THEN
9768          IF(IVAL1.EQ.IVAL2)THEN
9769            TEMP1(1)=0.0
9770          ENDIF
9771        ENDIF
9772C
9773        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GOFA')THEN
9774          WRITE(ICOUT,131)
9775  131     FORMAT('DPGOFA: AFTER CALL TO DPCDF1, DPCDF2')
9776          CALL DPWRST('XXX','BUG ')
9777          DO135I=1,N
9778            WRITE(ICOUT,132)I,XLOW(I),XHIGH(I),TEMP1(I),TEMP2(I)
9779  132       FORMAT('I,XLOW(I),XHIGH(I),TEMP1(I),TEMP2(I) = ',I8,4G15.7)
9780            CALL DPWRST('XXX','BUG ')
9781  135     CONTINUE
9782          WRITE(ICOUT,138)IVAL1,IVAL2
9783  138     FORMAT('IVAL1,IVAL2 = ',2I8)
9784          CALL DPWRST('XXX','BUG ')
9785        ENDIF
9786C
9787C
9788C               *************************************************
9789C               **  STEP 3B--                                  **
9790C               **  NOW COMPUTE CHI-SQUARE STATISTIC           **
9791C               **  CHSQ = SUM[(O(i) - E(i))**2/E(i)           **
9792C               **  WHERE O(i) IS THE OBSERVED FREQUENCY AND   **
9793C               **  E(i) IS THE EXPECTED FREQUENCY:            **
9794C               **       E(i) = N*(CDF(XU) - CDF(XL))          **
9795C               *************************************************
9796C
9797        ISTEPN='3B'
9798        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GOFA')
9799     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9800C
9801        DN=DBLE(NTOT)
9802        DSUM1=0.D0
9803C
9804        DO310I=1,N
9805          DEXPZ=DN*(DBLE(TEMP2(I)) - DBLE(TEMP1(I)))
9806          DOBS=DBLE(Y(I))
9807          DSUM1=DSUM1 + (DOBS - DEXPZ)**2/DEXPZ
9808C
9809          IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GOFA')THEN
9810            WRITE(ICOUT,316)I,TEMP2(I),TEMP1(I),DEXPZ,DOBS,DSUM1
9811  316       FORMAT('I,TEMP2(I),TEMP1(I),DEXPZ,DOBS,DSUM1 = ',
9812     1             I8,5G15.7)
9813            CALL DPWRST('XXX','BUG ')
9814          ENDIF
9815C
9816  310   CONTINUE
9817        STATVA=REAL(DSUM1)
9818        STAT=STATVA
9819        IF(STATVA.GT.PCHSLM)STAT=PCHSLM
9820        IDF=N-NUMSHA-1
9821        IF(IDISFL.NE.'DISC')THEN
9822          IF(KSLOC.NE.0.0 .AND. KSLOC.NE.CPUMIN)IDF=IDF-1
9823          IF(KSSCAL.NE.1.0 .AND. KSSCAL.NE.CPUMIN)IDF=IDF-1
9824        ENDIF
9825        IF(IDF.LT.1)THEN
9826          STATVA=PCHSLM
9827          IDF=1
9828        ENDIF
9829C
9830        CALL CHSCDF(STATVA,IDF,STATCD)
9831        PVAL=1.0 - STATCD
9832C
9833        DO195I=1,N
9834          Y(I)=TEMP3(I)
9835          XLOW(I)=TEMP4(I)
9836          XHIGH(I)=TEMP5(I)
9837  195   CONTINUE
9838C
9839        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GOFA')THEN
9840          WRITE(ICOUT,321)STATVA,IDF,STATCD,PVAL
9841  321     FORMAT('STATVA,IDF,STATCD,PVAL = ',G15.7,I8,3G15.7)
9842          CALL DPWRST('XXX','BUG ')
9843        ENDIF
9844C
9845      ELSEIF(ICASP2.EQ.'PPCC')THEN
9846C
9847C               *************************************************
9848C               **  STEP 3C--GROUPED PROBABILITY PLOT          **
9849C               *************************************************
9850C
9851        ISTEPN='3C'
9852        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GOFA')
9853     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9854C
9855        IFLAGD=0
9856        PPLOC=0.0
9857        PPSCAL=1.0
9858        CALL DPPP3(Y,XLOW,XHIGH,N,ICASPL,IDATSW,
9859     1             TEMP1,TEMP2,
9860     1             TEMP3,TEMP4,TEMP5,
9861     1             YLOWLM,YUPPLM,A,B,MINMAX,
9862     1             SHAPE1,SHAPE2,SHAPE3,SHAPE4,
9863     1             SHAPE5,SHAPE6,SHAPE7,
9864     1             IADEDF,IGEPDF,IMAKDF,IBEIDF,
9865     1             ILGADF,ISKNDF,IGLDDF,IBGEDF,
9866     1             IGETDF,ICONDF,IGOMDF,IKATDF,
9867     1             IGIGDF,IGEODF,
9868     1             IPPLDP,MAXOBV,ICENSO,IMETHD,
9869     1             PPLOC,PPSCAL,
9870     1             PPA0,PPA1,PPCC,SDPPA0,SDPPA1,XRESSD,XRESDF,
9871     1             CCALBE,PPA0BW,PPA1BW,
9872     1             WEIGHH,WEIGHV,
9873     1             Y2,X2,D2,N2,NPLOTV,NCURVE,
9874     1             IBUGA3,ISUBRO,IERROR)
9875C
9876        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GOFA')THEN
9877          WRITE(ICOUT,351)PPA0,PPA1,PPCC
9878  351     FORMAT('PPA0,PPA1,PPCC = ',3G15.7)
9879          CALL DPWRST('XXX','BUG ')
9880        ENDIF
9881C
9882      ENDIF
9883C
9884C               *****************
9885C               **  STEP 90--  **
9886C               **  EXIT       **
9887C               *****************
9888C
9889 9000 CONTINUE
9890      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GOFA')THEN
9891        WRITE(ICOUT,999)
9892        CALL DPWRST('XXX','BUG ')
9893        WRITE(ICOUT,9011)
9894 9011   FORMAT('***** AT THE END       OF DPGOFA--')
9895        CALL DPWRST('XXX','BUG ')
9896        WRITE(ICOUT,9013)STATVA
9897 9013   FORMAT('STATVA = ',G15.7)
9898        CALL DPWRST('XXX','BUG ')
9899      ENDIF
9900C
9901      RETURN
9902      END
9903      SUBROUTINE DPGOFB(Y,XLOW,XHIGH,XCENS,N,
9904     1                  ICASPL,ICASP2,IDATSW,
9905     1                  TEMP1,TEMP2,TEMP3,
9906     1                  YLOWLM,YUPPLM,A,B,MINMAX,
9907     1                  CLWIDT,CLLIMI,IHSTCW,IHSTOU,MINSIZ,
9908     1                  SHAPE1,SHAPE2,SHAPE3,SHAPE4,
9909     1                  SHAPE5,SHAPE6,SHAPE7,
9910     1                  IADEDF,IGEPDF,IMAKDF,IBEIDF,
9911     1                  ILGADF,ISKNDF,IGLDDF,IBGEDF,
9912     1                  IGETDF,ICONDF,IGOMDF,IKATDF,
9913     1                  IGIGDF,IGEODF,
9914     1                  MAXOBV,NUMSHA,KSLOC,KSSCAL,
9915     1                  NCELLS,NTOT,IDISFL,ILOWLM,
9916     1                  IBUGA3,ISUBRO,IERROR)
9917C
9918C     PURPOSE--FOR THE GOODNESS OF FIT CASE, WHEN WE ARE USING A
9919C              TEST STATISTIC THAT REQUIRES GROUPED DATA, THIS
9920C              SUBROUTINE WILL:
9921C
9922C                 1) BIN THE DATA IF NEEDED.  FOR TESTS THAT SUPPORT
9923C                    EITHER RAW DATA OR BINNED DATA (PPCC, K-S),
9924C                    NO ADDITIONAL BINNING WILL BE PERFORMED. HOWEVER,
9925C                    TESTS THAT REQUIRE BINNED DATA (E.G., CHI-SQUARE)
9926C                    WILL BE BINNED.
9927C
9928C                    FOR THE CHI-SQUARE CASE,
9929C                    EQUI-SPACED BINS WILL BE CONVERTED TO HAVE BOTH
9930C                    LOWER AND UPPER BOUNDARIES SPECIFIED AND BINS
9931C                    WILL BE COMBINED SO THAT ALL BIN FREQUENCIES
9932C                    ARE ABOVE A USER-SPECIFIED BIN MINIMUM.
9933C
9934C                 2) PERFORM APPROPRIATE ERROR CHECKING FOR THE BINS
9935C                    AND FOR THE FREQUENCY VALUES.
9936C
9937C                 3) CURRENTLY, ONLY THE PPCC METHOD SUPPORTS CENSORING
9938C                    FOR THE GROUPED CASE.  SINCE THE PPCC METHOD ALSO
9939C                    WORKS ON UNBINNED DATA, CENSORING IS NOT CURRENTLY
9940C                    SUPPORTED IN THIS ROUTINE.  THIS WILL ONLY BE
9941C                    ADDED IF IT BECOMES NECCESSARY AT A LATER DATE.
9942C
9943C     WRITTEN BY--ALAN HECKERT
9944C                 STATISTICAL ENGINEERING DIVISION
9945C                 INFORMATION TECHNOLOGY LABORATORY
9946C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
9947C                 GAITHERSBURG, MD 20899-8980
9948C                 PHONE--301-975-2899
9949C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
9950C           OF THE NATIONAL BUREAU OF STANDARDS.
9951C     LANGUAGE--ANSI FORTRAN (1977)
9952C     VERSION NUMBER--2009/11
9953C     ORIGINAL VERSION--NOVEMBER  2009.
9954C
9955C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
9956C
9957      CHARACTER*4 IDATSW
9958      CHARACTER*4 IHSTCW
9959      CHARACTER*4 IHSTOU
9960      CHARACTER*4 ICASPL
9961      CHARACTER*4 ICASP2
9962      CHARACTER*4 IBUGA3
9963      CHARACTER*4 ISUBRO
9964      CHARACTER*4 IADEDF
9965      CHARACTER*4 IGEPDF
9966      CHARACTER*4 IMAKDF
9967      CHARACTER*4 IBEIDF
9968      CHARACTER*4 ILGADF
9969      CHARACTER*4 ISKNDF
9970      CHARACTER*4 IGLDDF
9971      CHARACTER*4 IBGEDF
9972      CHARACTER*4 IGETDF
9973      CHARACTER*4 ICONDF
9974      CHARACTER*4 IGOMDF
9975      CHARACTER*4 IKATDF
9976      CHARACTER*4 IGIGDF
9977      CHARACTER*4 IGEODF
9978      CHARACTER*4 IERROR
9979C
9980      CHARACTER*4 ISUBN1
9981      CHARACTER*4 ISUBN2
9982      CHARACTER*4 ISTEPN
9983      CHARACTER*4 IRELAT
9984      CHARACTER*4 IRHSTG
9985      CHARACTER*4 ICENSO
9986      CHARACTER*4 IWRITE
9987      CHARACTER*4 IDISFL
9988C
9989      REAL KSLOC
9990      REAL KSSCAL
9991C
9992C---------------------------------------------------------------------
9993C
9994      DIMENSION Y(*)
9995      DIMENSION XLOW(*)
9996      DIMENSION XHIGH(*)
9997      DIMENSION XCENS(*)
9998      DIMENSION TEMP1(*)
9999      DIMENSION TEMP2(*)
10000      DIMENSION TEMP3(*)
10001C
10002      DIMENSION CLWIDT(*)
10003      DIMENSION CLLIMI(*)
10004C
10005C-----COMMON----------------------------------------------------------
10006C
10007      INCLUDE 'DPCOMC.INC'
10008      INCLUDE 'DPCOP2.INC'
10009C
10010C-----START POINT-----------------------------------------------------
10011C
10012C
10013      ISUBN1='DPGO'
10014      ISUBN2='FB  '
10015      IERROR='NO'
10016      IERRFL=0
10017      IRHSTG='NULL'
10018      ICENSO='OFF'
10019      IWRITE='OFF'
10020C
10021      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GOFB')THEN
10022        ISTEPN='0'
10023        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10024        WRITE(ICOUT,999)
10025  999   FORMAT(1X)
10026        CALL DPWRST('XXX','BUG ')
10027        WRITE(ICOUT,51)
10028   51   FORMAT('***** AT THE BEGINNING OF DPGOFB--')
10029        CALL DPWRST('XXX','BUG ')
10030        IF(N.GE.1)THEN
10031          DO65I=1,N
10032            WRITE(ICOUT,66)I,Y(I),XLOW(I),XHIGH(I),XCENS(I)
10033   66       FORMAT('I,Y(I),XLOW(I),XHIGH(I),XCENS(I) = ',I8,4G15.7)
10034            CALL DPWRST('XXX','BUG ')
10035   65     CONTINUE
10036        ENDIF
10037        WRITE(ICOUT,52)ICASPL,ICASP2,IDATSW,N,MINSIZ,MINMAX
10038   52   FORMAT('ICASPL,ICASP2,IDATSW,N,MINSIZ,MINMAX = ',3(A4,2X),3I8)
10039        CALL DPWRST('XXX','BUG ')
10040        WRITE(ICOUT,53)NUMSHA,MAXOBV,A,B,KSLOC,KSSCAL
10041   53   FORMAT('NUMSHA,MAXOBV,A,B,KSLOC,KSSCAL = ',2I8,4G15.7)
10042        CALL DPWRST('XXX','BUG ')
10043        WRITE(ICOUT,55)YLOWLM,YUPPLM
10044   55   FORMAT('YLOWLM,YUPPLM = ',2G15.7)
10045        CALL DPWRST('XXX','BUG ')
10046      ENDIF
10047C
10048C               ********************************************
10049C               **  STEP 1--                              **
10050C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
10051C               ********************************************
10052C
10053      IF(N.LT.2)THEN
10054        WRITE(ICOUT,101)
10055  101   FORMAT('****** ERROR IN GOODNESS OF FIT (GROUPED CASE)--')
10056        CALL DPWRST('XXX','BUG ')
10057        WRITE(ICOUT,103)N
10058  103   FORMAT('       THE NUMBER OF OBSERVATIONS (',I8,') IN THE')
10059        CALL DPWRST('XXX','BUG ')
10060        WRITE(ICOUT,105)
10061  105   FORMAT('       RESPONSE VARIABLE IS LESS THAN 2.')
10062        CALL DPWRST('XXX','BUG ')
10063        IERROR='YES'
10064        GOTO9000
10065      ENDIF
10066C
10067      IF(ICASP2.EQ.'AD  ')THEN
10068        WRITE(ICOUT,101)
10069        CALL DPWRST('XXX','BUG ')
10070        WRITE(ICOUT,113)
10071  113   FORMAT('       THE ANDERSON-DARLING GOODNESS OF FIT IS NOT')
10072        CALL DPWRST('XXX','BUG ')
10073        WRITE(ICOUT,115)
10074  115   FORMAT('       CURRENTLY SUPPORTED FOR GROUPED DATA.')
10075        CALL DPWRST('XXX','BUG ')
10076        IERROR='YES'
10077        GOTO9000
10078      ELSEIF(ICASP2.EQ.'KS  ')THEN
10079        WRITE(ICOUT,101)
10080        CALL DPWRST('XXX','BUG ')
10081        WRITE(ICOUT,123)
10082  123   FORMAT('       THE KOLMOGOROV-SMIRNOV GOODNESS OF FIT IS NOT')
10083        CALL DPWRST('XXX','BUG ')
10084        WRITE(ICOUT,125)
10085  125   FORMAT('       CURRENTLY SUPPORTED FOR GROUPED DATA.')
10086        CALL DPWRST('XXX','BUG ')
10087        IERROR='YES'
10088        GOTO9000
10089      ELSEIF(ICASP2.EQ.'PPCC' .AND. IDATSW.EQ.'RAW ')THEN
10090        WRITE(ICOUT,101)
10091        CALL DPWRST('XXX','BUG ')
10092        WRITE(ICOUT,133)
10093  133   FORMAT('       THE PPCC GOODNESS OF FIT IS NOT EXPECTED')
10094        CALL DPWRST('XXX','BUG ')
10095        WRITE(ICOUT,135)
10096  135   FORMAT('       IN THE GROUPED CASE FOR RAW DATA.')
10097        CALL DPWRST('XXX','BUG ')
10098        IERROR='YES'
10099        GOTO9000
10100      ENDIF
10101C
10102C               ************************************************
10103C               **  STEP 2--                                 **
10104C               **  BIN THE DATA AND CHECK FOR ERRORS.       **
10105C               **  1) FOR PPCC CASE, DATA IS ALREADY BINNED **
10106C               **     SINCE RAW DATA  WILL CALL  A SEPARATE **
10107C               **     SUBROUTINE.  ALSO, PPCC DOES NOT NEED **
10108C               **     A MINIMUM CLASS SIZE.                 **
10109C               **  2) FOR CHI-SQUARE:                       **
10110C               **     A) FIRST, BIN RAW DATA INTO EQUI-SIZED**
10111C               **        BINS AND ELIMINATE ANY EMPTY BINS  **
10112C               **        AT START AND END OF ARRAY.         **
10113C               **     B) BIN INTO UNEQUAL CLASS SIZES SO    **
10114C               **        THAT ANY BINS WITH LESS THAN       **
10115C               **        MINIMUM SIZE ARE COMBINED.         **
10116C               **     C) DISCRETE DISTRIBUTIONS WILL BIN    **
10117C               **        TO INTEGER VALUES, SO A DIFFERENT  **
10118C               **        BINNING ALGORITHM IS USED.         **
10119C               **  3) IF ANDERSON-DARLING AND KS ARE ADDED  **
10120C               **     LATER, THEN THESE WILL ALREADY BE     **
10121C               **     BINNED AS WELL SINCE A SEPARATE       **
10122C               **     ROUTINE IS AVAILABLE FOR THE UNBINNED **
10123C               **     CASE.                                 **
10124C               ***********************************************
10125C
10126      ISTEPN='2'
10127      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GOFB')
10128     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10129C
10130C     DISTINGUISH DISCRETE DISTRIBUTIONS
10131C
10132      CALL EXTDST(ICASPL,IDISFL,ILOWLM,
10133     1            SHAPE1,SHAPE2,SHAPE3,SHAPE4,
10134     1            SHAPE5,SHAPE6,SHAPE7,
10135     1            IADEDF,IGEPDF,IMAKDF,IBEIDF,
10136     1            ILGADF,ISKNDF,IGLDDF,IBGEDF,
10137     1            IGETDF,ICONDF,IGOMDF,IKATDF,
10138     1            IGIGDF,IGEODF)
10139C
10140      ISTEPN='2A'
10141      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GOFB')THEN
10142        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10143        WRITE(ICOUT,211)ICASPL,IDISFL,ILOWLM
10144  211    FORMAT('ICASPL,IDISFL,ILOWLM = ',A4,2X,A4,I8)
10145         CALL DPWRST('XXX','BUG ')
10146      ENDIF
10147C
10148C       ************************************************
10149C       **  STEP 2B--BIN RAW DATA FOR CHI-SQUARE CASE **
10150C       ************************************************
10151C
10152      IF(IDATSW.EQ.'RAW' .AND. ICASP2.EQ.'CHSQ')THEN
10153        NTOT=N
10154        AN=REAL(N)
10155        CALL MAXIM(Y,N,IWRITE,AMAX,IBUGA3,IERROR)
10156        IRELAT='OFF'
10157        CLWID=CLWIDT(1)
10158        XSTART=CLLIMI(1)
10159        XSTOP=CLLIMI(2)
10160        IF(IDISFL.EQ.'CONT')THEN
10161          CALL DPBIN(Y,N,IRELAT,CLWID,XSTART,XSTOP,IRHSTG,
10162     1               TEMP1,MAXOBV,IHSTCW,IHSTOU,
10163     1               TEMP2,TEMP3,N2,IBUGA3,IERROR)
10164          IF(IERROR.EQ.'YES')GOTO9000
10165        ELSE
10166          CALL DPBINI(Y,N,IRELAT,CLWID,XSTART,XSTOP,IRHSTG,
10167     1                TEMP2,TEMP3,N2,IBUGA3,IERROR)
10168          IF(IERROR.EQ.'YES')GOTO9000
10169        ENDIF
10170        DO221I=1,N2
10171          Y(I)=TEMP2(I)
10172          XLOW(I)=TEMP3(I)
10173  221   CONTINUE
10174        N=N2
10175C
10176        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GOFB')THEN
10177          WRITE(ICOUT,223)N2
10178  223     FORMAT('AFTER BIN RAW DATA: N2 = ',I8)
10179          CALL DPWRST('XXX','BUG ')
10180        ENDIF
10181C
10182C         *************************************************
10183C         **  STEP 2C--EQUI-SPACED BINS CASE.            **
10184C         **           1) CHECK THAT ALL RESPONSE VALUES **
10185C         **              ARE NON-NEGATIVE, ROUND TO     **
10186C         **              INTEGER VALUES.                **
10187C         **           2) CHECK THAT CLASS MID-POINTS    **
10188C         **              ARE SORTED.                    **
10189C         **           3) COMBINE BINS THAT ARE TOO SMALL**
10190C         *************************************************
10191C
10192      ELSEIF(IDATSW.EQ.'FREQ')THEN
10193C
10194        ISTEPN='2C'
10195        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GOFB')
10196     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10197C
10198        NTOT=0
10199        DO231I=1,N
10200C
10201          IF(Y(I).LT.0.0)THEN
10202            WRITE(ICOUT,999)
10203            CALL DPWRST('XXX','BUG ')
10204            WRITE(ICOUT,101)
10205            CALL DPWRST('XXX','BUG ')
10206            WRITE(ICOUT,233)INT(Y(I)-0.01)
10207  233       FORMAT('      A NEGATIVE FREQUENCY (',I8,') WAS ',
10208     1             'ENCOUNTERED FOR ROW ',I8)
10209            CALL DPWRST('XXX','BUG ')
10210            IERROR='YES'
10211            GOTO9000
10212          ELSE
10213            IVAL=INT(Y(I)+0.5)
10214            NTOT=NTOT+IVAL
10215            Y(I)=REAL(IVAL)
10216          ENDIF
10217  231   CONTINUE
10218C
10219        CALL DISTIN(XLOW,N,IWRITE,TEMP1,NDIST,IBUGA3,IERROR)
10220        IF(N.NE.NDIST)THEN
10221          WRITE(ICOUT,999)
10222          CALL DPWRST('XXX','BUG ')
10223          WRITE(ICOUT,101)
10224          CALL DPWRST('XXX','BUG ')
10225          WRITE(ICOUT,236)
10226  236     FORMAT('      THE CLASS VARIABLE ELEMENTS ARE NOT ALL ',
10227     1           'DISTINCT.')
10228          CALL DPWRST('XXX','BUG ')
10229          WRITE(ICOUT,999)
10230          CALL DPWRST('XXX','BUG ')
10231          IERROR='YES'
10232          GOTO9000
10233        ENDIF
10234C
10235        ISTEPN='2C1'
10236        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GOFB')
10237     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10238C
10239        DO241I=1,N-1
10240          IF(XLOW(I).GE.XLOW(I+1))THEN
10241            WRITE(ICOUT,999)
10242            CALL DPWRST('XXX','BUG ')
10243            WRITE(ICOUT,101)
10244            CALL DPWRST('XXX','BUG ')
10245            WRITE(ICOUT,243)I
10246  243       FORMAT('      ROW ',I8,' OF THE BIN MID-POINTS ',
10247     1             'VARIABLE IS')
10248            CALL DPWRST('XXX','BUG ')
10249            WRITE(ICOUT,245)I+1
10250  245       FORMAT('      LARGER THAN ROW ',I8,'.')
10251            CALL DPWRST('XXX','BUG ')
10252            WRITE(ICOUT,999)
10253            CALL DPWRST('XXX','BUG ')
10254            IERROR='YES'
10255            GOTO9000
10256          ENDIF
10257  241   CONTINUE
10258C
10259C         *********************************************************
10260C         **  STEP 24--NON-EQUI-SPACED BINS CASE.                **
10261C         **           1) CHECK THAT ALL RESPONSE VALUES ARE     **
10262C         **              NON-NEGATIVE, ROUND TO INTEGER VALUES. **
10263C         **           2) CHECK THAT CLASS BOUNDARIES.           **
10264C         **           NOTE THAT WE DO NOT CHECK FOR MINIMUM     **
10265C         **           FREQUENCY FOR BINS IN THIS CASE.  WE      **
10266C         **           ASSUME USER HAS ALREADY COMBINED THE BINS **
10267C         **           IN THE MANNER THEY WANT.                  **
10268C         *********************************************************
10269C
10270      ELSEIF(IDATSW.EQ.'FRE2')THEN
10271C
10272        ISTEPN='2D'
10273        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GOFB')
10274     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10275C
10276        NTOT=0
10277        DO251I=1,N
10278C
10279          IF(Y(I).LT.0.0)THEN
10280            WRITE(ICOUT,999)
10281            CALL DPWRST('XXX','BUG ')
10282            WRITE(ICOUT,101)
10283            CALL DPWRST('XXX','BUG ')
10284            WRITE(ICOUT,233)INT(Y(I)-0.01)
10285            CALL DPWRST('XXX','BUG ')
10286            IERROR='YES'
10287            GOTO9000
10288          ELSE
10289            IVAL=INT(Y(I)+0.5)
10290            NTOT=NTOT+IVAL
10291            Y(I)=REAL(IVAL)
10292         ENDIF
10293  251   CONTINUE
10294C
10295        CALL DISTIN(XLOW,N,IWRITE,TEMP1,NDIST,IBUGA3,IERROR)
10296        IF(N.NE.NDIST)THEN
10297          WRITE(ICOUT,999)
10298          CALL DPWRST('XXX','BUG ')
10299          WRITE(ICOUT,101)
10300          CALL DPWRST('XXX','BUG ')
10301          WRITE(ICOUT,257)
10302  257     FORMAT('      THE LOWER CLASS BOUNDARIES ARE NOT ALL ',
10303     1           'DISTINCT.')
10304          CALL DPWRST('XXX','BUG ')
10305          WRITE(ICOUT,999)
10306          CALL DPWRST('XXX','BUG ')
10307          IERROR='YES'
10308          GOTO9000
10309        ENDIF
10310C
10311        CALL DISTIN(XHIGH,N,IWRITE,TEMP1,NDIST,IBUGA3,IERROR)
10312        IF(N.NE.NDIST)THEN
10313          WRITE(ICOUT,999)
10314          CALL DPWRST('XXX','BUG ')
10315          WRITE(ICOUT,101)
10316          CALL DPWRST('XXX','BUG ')
10317          WRITE(ICOUT,259)
10318  259     FORMAT('      THE UPPER CLASS BOUNDARIES ARE NOT ALL ',
10319     1           'DISTINCT.')
10320          CALL DPWRST('XXX','BUG ')
10321          WRITE(ICOUT,999)
10322          CALL DPWRST('XXX','BUG ')
10323          IERROR='YES'
10324          GOTO9000
10325        ENDIF
10326C
10327        DO261I=1,N
10328          IF(XLOW(I).GE.XHIGH(I))THEN
10329            WRITE(ICOUT,999)
10330            CALL DPWRST('XXX','BUG ')
10331            WRITE(ICOUT,101)
10332            CALL DPWRST('XXX','BUG ')
10333            WRITE(ICOUT,263)
10334  263       FORMAT('FOR ROW ',I8,', THE LOWER CLASS LIMIT IS ',
10335     1             'GREATER THAN THE UPPER CLASS LIMIT.')
10336            CALL DPWRST('XXX','BUG ')
10337            WRITE(ICOUT,999)
10338            CALL DPWRST('XXX','BUG ')
10339            IERROR='YES'
10340            GOTO9000
10341          ENDIF
10342  261   CONTINUE
10343C
10344        DO266I=1,N-1
10345          IF(XLOW(I).GE.XLOW(I+1))THEN
10346            WRITE(ICOUT,999)
10347            CALL DPWRST('XXX','BUG ')
10348            WRITE(ICOUT,101)
10349            CALL DPWRST('XXX','BUG ')
10350            WRITE(ICOUT,267)I
10351  267       FORMAT('      ROW ',I8,' OF THE LOWER CLASS BOUNDARY IS ',
10352     1             'LARGER THAN')
10353            CALL DPWRST('XXX','BUG ')
10354            WRITE(ICOUT,268)I+1
10355  268       FORMAT('      ROW ',I8,' OF THE LOWER CLASS BOUNDARY.')
10356            CALL DPWRST('XXX','BUG ')
10357            WRITE(ICOUT,999)
10358            CALL DPWRST('XXX','BUG ')
10359            IERROR='YES'
10360            GOTO9000
10361          ENDIF
10362  266   CONTINUE
10363C
10364        DO276I=1,N-1
10365          IF(XHIGH(I).GE.XHIGH(I+1))THEN
10366            WRITE(ICOUT,999)
10367            CALL DPWRST('XXX','BUG ')
10368            WRITE(ICOUT,101)
10369            CALL DPWRST('XXX','BUG ')
10370            WRITE(ICOUT,277)I
10371  277       FORMAT('      ROW ',I8,' OF THE UPPER CLASS BOUNDARY IS ',
10372     1             'LARGER THAN')
10373            CALL DPWRST('XXX','BUG ')
10374            WRITE(ICOUT,278)I+1
10375  278       FORMAT('      ROW ',I8,' OF THE UPPER CLASS BOUNDARY.')
10376            CALL DPWRST('XXX','BUG ')
10377            WRITE(ICOUT,999)
10378            CALL DPWRST('XXX','BUG ')
10379            IERROR='YES'
10380            GOTO9000
10381          ENDIF
10382  276   CONTINUE
10383C
10384      ENDIF
10385C
10386C         *********************************************************
10387C         **  STEP 25--REMOVE ANY EMPTY BINS AT THE START OR     **
10388C         **           END OF THE LIST.  ALSO, COMBINE BINS FOR  **
10389C         **           EQUI-SPACED BINS SO THAT MINIMUM          **
10390C         **           FREQUENCY IS GREATER THAN OR EQUAL TO     **
10391C         **           SOME USER SPECIFIED VALUE.                **
10392C         *********************************************************
10393C
10394      ISTEPN='25'
10395      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GOFB')THEN
10396        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10397        WRITE(ICOUT,280)N
10398  280   FORMAT('BEFORE CHECK FOR EMPTY BINS: N = ',I8)
10399        CALL DPWRST('XXX','BUG ')
10400      ENDIF
10401C
10402      ISTRT=1
10403      DO283I=1,N
10404        IF(Y(I).GT.0.0 .OR. XCENS(I).GT.0.0)THEN
10405          ISTRT=I
10406          GOTO285
10407        ENDIF
10408  283 CONTINUE
10409  285 CONTINUE
10410      ISTOP=N
10411      DO287I=N,1,-1
10412        IF(Y(I).GT.0.0 .OR. XCENS(I).GT.0.0)THEN
10413          ISTOP=I
10414          GOTO288
10415        ENDIF
10416  287 CONTINUE
10417  288 CONTINUE
10418C
10419      ISTEPN='25B'
10420      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GOFB')THEN
10421        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10422        WRITE(ICOUT,290)N,ISTRT,ISTOP
10423  290   FORMAT('AFTER CHECK FOR EMPTY BINS: N,ISTRT,ISTOP = ',3I8)
10424        CALL DPWRST('XXX','BUG ')
10425      ENDIF
10426C
10427      ICNT=0
10428      DO289I=ISTRT,ISTOP
10429        ICNT=ICNT+1
10430        Y(ICNT)=Y(I)
10431        XLOW(ICNT)=XLOW(I)
10432        XHIGH(ICNT)=XHIGH(I)
10433        XCENS(ICNT)=XCENS(I)
10434  289 CONTINUE
10435      N=ICNT
10436C
10437      IF(IDATSW.NE.'FRE2' .AND. ICASP2.EQ.'CHSQ')THEN
10438        CALL DPCOMB(Y,XLOW,N,MINSIZ,
10439     1              TEMP1,TEMP2,TEMP3,NCOMB,
10440     1              IBUGA3,IERROR)
10441        DO291I=1,NCOMB
10442          Y(I)=TEMP1(I)
10443          XLOW(I)=TEMP2(I)
10444          XHIGH(I)=TEMP3(I)
10445  291   CONTINUE
10446        N=NCOMB
10447        IDATSW='FRE2'
10448      ENDIF
10449C
10450      NCELLS=N
10451C
10452      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GOFB')THEN
10453        WRITE(ICOUT,293)N,MINSIZ,NTOT,NCELLS,IDISFL
10454  293   FORMAT('N,MINSIZ,NTOT,NCELLS,IDISFL = ',4I8,2X,A4)
10455        CALL DPWRST('XXX','BUG ')
10456        DO295I=1,N
10457          WRITE(ICOUT,296)I,Y(I),XLOW(I),XHIGH(I)
10458  296     FORMAT('I,Y(I),XLOW(I),XHIGH(I) = ',I8,3G15.7)
10459          CALL DPWRST('XXX','BUG ')
10460  295   CONTINUE
10461      ENDIF
10462C
10463C               *****************
10464C               **  STEP 90--  **
10465C               **  EXIT       **
10466C               *****************
10467C
10468 9000 CONTINUE
10469      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GOFB')THEN
10470        WRITE(ICOUT,999)
10471        CALL DPWRST('XXX','BUG ')
10472        WRITE(ICOUT,9011)
10473 9011   FORMAT('***** AT THE END       OF DPGOFB--')
10474        CALL DPWRST('XXX','BUG ')
10475        WRITE(ICOUT,9013)IDATSW
10476 9013   FORMAT('IDATSW = ',A4)
10477        CALL DPWRST('XXX','BUG ')
10478      ENDIF
10479C
10480      RETURN
10481      END
10482      SUBROUTINE DPGRAP(Y,X,X3D,D,N,NPLOTP,ICASPL,ICONT,IPOWE,NUMHPP,
10483     1                  XMATN,YMATN,XMITN,YMITN,
10484     1                  ISQUAR,
10485     1                  IVGMSW,IHGMSW,
10486     1                  IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,
10487     1                  IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,
10488     1                  YPLOT,XPLOT,X2PLOT,TAGPLO,
10489     1                  IMPSW,IMPNR,IMPNC,IMPCO,IMPCO9,
10490CCCCC                   ADD FOLLOWING LINE AUGUST 1999.
10491     1                  IMPARG,
10492     1                  PMXMIN,PMXMAX,PMYMIN,PMYMAX,
10493     1                  MAXCOL,
10494CCCCC                   AUGUST 1992.  ADD FOLLOWING LINE
10495     1                  DSIZE,DSYMB,DCOLOR,DFILL,
10496     1                  ICAPSW,
10497     1                  IBUGUG,IBUGU2,IBUGU3,IBUGU4,ISUBRO,IERROR)
10498C
10499C     PURPOSE--GENERATE A PLOT ON ONE OF THE FOLLOWING--
10500C                 1) CONTINUOUS DISPLAY TERMINAL
10501C                 2) NARROW-WIDTH DISCRETE TERMINAL
10502C                 3) WIDE-CARRIAGE DISCRETE TERMINAL/HIGH-SPEED PRINTER
10503C     WRITTEN BY--JAMES J. FILLIBEN
10504C                 STATISTICAL ENGINEERING DIVISION
10505C                 INFORMATION TECHNOLOGY LABORATORY
10506C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
10507C                 GAITHERSBURG, MD 20899-8980
10508C                 PHONE--301-975-2855
10509C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
10510C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
10511C     LANGUAGE--ANSI FORTRAN (1977)
10512C     VERSION NUMBER--82/7
10513C     ORIGINAL VERSION--FEBRUARY  1981.
10514C     UPDATED         --MARCH     1981.
10515C     UPDATED         --AUGUST    1981.
10516C     UPDATED         --SEPTEMBER 1981.
10517C     UPDATED         --DECEMBER  1981.
10518C     UPDATED         --FEBRUARY  1982.
10519C     UPDATED         --MARCH     1982.
10520C     UPDATED         --MAY       1982.
10521C     UPDATED         --APRIL     1987.
10522C     UPDATED         --MARCH     1988. TURN OFF FRAME FOR 3D PLOT
10523C     UPDATED         --FEBRUARY  1989. YSAVE (ALAN)
10524C     UPDATED         --FEBRUARY  1989. DELETE 5 ARRAYS (ALAN)
10525C     UPDATED         --FEBRUARY  1989. INITIAL REWRITE FOR NEW 3D
10526C     UPDATED         --NOVEMBER  1991. ADJUST FOR MULTIPLOT FREEZE
10527C     UPDATED         --AUGUST    1992. ADD PARAMETERS TO PLOTGE
10528C                                       ADD PARAMETERS TO DPGRAP
10529C     UPDATED         --SEPTEMBER 1998. ADD IMPSW2
10530C     UPDATED         --AUGUST    1999. MULTIPLOT FIX
10531C     UPDATED         --AUGUST    2001. PPCC PLOTS WITH 2 SHAPE
10532C                                       PARAMETERS
10533C     UPDATED         --SEPTEMBER 2014. DISTRIBUTIONAL FIT PLOT
10534C                                       MODIFIES SOME Y1 AXIS PLOT
10535C                                       ATTRIBUTES.  NEED TO RESTORE
10536C                                       ORIGINAL SETTINGS AFTER PLOT
10537C                                       COMPLETED.
10538C     UPDATED         --AUGUST    2015. SUPPORT FOR EMBEDDED PLOTS
10539C     UPDATED         --APRIL     2018. ADD IPOWE - FOR DISCRET DEVICES,
10540C                                       DON'T PLOT IF POWER IS OFF
10541C
10542C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
10543C
10544C
10545      CHARACTER*4 ISQUAR
10546      CHARACTER*4 ICAPSW
10547      CHARACTER*4 IVGMSW
10548      CHARACTER*4 IHGMSW
10549      CHARACTER*4 IMPSW
10550C
10551      CHARACTER*4 IHNAME
10552      CHARACTER*4 IHNAM2
10553      CHARACTER*4 IUSE
10554      CHARACTER*4 IFUNC
10555      CHARACTER*1 IREPCH
10556      CHARACTER*4 ICASPL
10557      CHARACTER*4 ICONT
10558      CHARACTER*4 IPOWE
10559      CHARACTER*4 IBUGUG
10560      CHARACTER*4 IBUGU2
10561      CHARACTER*4 IBUGU3
10562      CHARACTER*4 IBUGU4
10563      CHARACTER*4 ISUBRO
10564      CHARACTER*4 IERROR
10565C
10566      CHARACTER*4 IMORE
10567      CHARACTER*4 ICAS3D
10568      CHARACTER*4 IFIRST
10569      CHARACTER*4 ILAST
10570      CHARACTER*4 ISUBN1
10571      CHARACTER*4 ISUBN2
10572      CHARACTER*4 ISTEPN
10573C
10574C---------------------------------------------------------------------
10575C
10576      DIMENSION Y(*)
10577      DIMENSION X(*)
10578      DIMENSION X3D(*)
10579      DIMENSION D(*)
10580CCCCC AUGUST 1992.  ADD FOLLOWING BLOCK OF CODE
10581      DIMENSION DSIZE(*)
10582      DIMENSION DSYMB(*)
10583      DIMENSION DCOLOR(*)
10584      DIMENSION DFILL(*)
10585C
10586      DIMENSION IHNAME(*)
10587      DIMENSION IHNAM2(*)
10588      DIMENSION IUSE(*)
10589      DIMENSION IN(*)
10590      DIMENSION IVALUE(*)
10591      DIMENSION VALUE(*)
10592      DIMENSION IVSTAR(*)
10593      DIMENSION IVSTOP(*)
10594      DIMENSION IFUNC(*)
10595C
10596C
10597      DIMENSION YPLOT(*)
10598      DIMENSION XPLOT(*)
10599      DIMENSION X2PLOT(*)
10600      DIMENSION TAGPLO(*)
10601C
10602      DIMENSION XIDC(100)
10603C
10604CCCCC THE FOLLOWING 5 ARRAYS WERE COMMENTED OUT (ALAN) (FEBRUARY 1989)
10605CCCCC DIMENSION XSAVE(5000)
10606CCCCC DIMENSION YSAVE(5000)
10607CCCCC DIMENSION XOUT(5000)
10608CCCCC DIMENSION YOUT(5000)
10609CCCCC DIMENSION TAGOUT(5000)
10610C
10611C-----COMMON----------------------------------------------------------
10612C
10613      INCLUDE 'DPCOPA.INC'
10614      INCLUDE 'DPCOPC.INC'
10615      INCLUDE 'DPCO3D.INC'
10616      INCLUDE 'DPCOST.INC'
10617C
10618      COMMON/IEMBZ/FX1MNE,FX1MXE,FY1MNE,FY1MXE,
10619     1             PXMINE,PXMAXE,PYMINE,PYMAXE
10620C
10621      CHARACTER*4 IY1MNZ
10622      CHARACTER*4 IY1MXZ
10623      CHARACTER*4 IY1JSZ
10624      CHARACTER*4 IY1NSZ
10625      CHARACTER*4 IY1ZFZ
10626      CHARACTER*2048 IY1ZCZ
10627      REAL GY1MNZ
10628      REAL GY1MXZ
10629      INTEGER NMJY1Z
10630      INTEGER NMNY1Z
10631      COMMON/DFP2/GY1MNZ,GY1MXZ,NMJY1Z,NMNY1Z,
10632     1            IY1MNZ,IY1MXZ,IY1JSZ,IY1MNSZ,IY1ZFZ,IY1ZCZ
10633C
10634C-----COMMON VARIABLES (GENERAL)--------------------------------------
10635C
10636      INCLUDE 'DPCOP2.INC'
10637C
10638C-----START POINT-----------------------------------------------------
10639C
10640      IERROR='NO'
10641      ISUBN1='DPGR'
10642      ISUBN2='AP  '
10643C
10644C     FOR DISTRIBUTIONAL FIT PLOT CASE, RESTORE
10645C     Y1 AXIS SETTINGS.
10646C
10647      IY1MNZ=IY1MIN
10648      IY1MXZ=IY1MAX
10649      GY1MNZ=GY1MIN
10650      GY1MXZ=GY1MAX
10651      NMJY1Z=NMJY1T
10652      NMNY1Z=NMNY1T
10653      IY1JSZ=IY1JSW
10654      IY1NSZ=IY1NSW
10655      IY1ZFZ=IY1ZFM
10656      IY1ZCZ=IY1ZCN
10657C
10658CCCCC THE FOLLOWING LINE WAS INSERTED BY ALAN.  FEBRUARY 1989
10659      YSAVE=0.0
10660C
10661CCCCC ADD FOLLOWING LINE  SEPTEMBER 1998.
10662      IMPSW2=IMPSW
10663C
10664      ICONT=IDCONT(1)
10665      NUMHPP=IDNHPP(1)
10666C
10667      IF(IBUGUG.EQ.'ON'.OR.ISUBRO.EQ.'GRAP')THEN
10668        WRITE(ICOUT,999)
10669  999   FORMAT(1X)
10670        CALL DPWRST('XXX','BUG ')
10671        WRITE(ICOUT,51)
10672   51   FORMAT('***** AT THE BEGINNING OF DPGRAP--')
10673        CALL DPWRST('XXX','BUG ')
10674        WRITE(ICOUT,52)N,NPLOTP,MAXCOL,ICASPL,INEGSW,ISQUAR
10675   52   FORMAT('N,NPLOTP,MAXCOL,ICASPL,INEGSW,ISQUAR = ',3I8,3(2X,A4))
10676        CALL DPWRST('XXX','BUG ')
10677        WRITE(ICOUT,53)ICONT,IERASW,MAXCHA,NUMDEV,MAXDEV
10678   53   FORMAT('ICONT,IERASW,MAXCHA,NUMDEV,MAXDEV = ',2(A4,2X),3I8)
10679        CALL DPWRST('XXX','BUG ')
10680        IF(NPLOTP.GT.0)THEN
10681          DO55I=1,NPLOTP
10682            WRITE(ICOUT,56)I,Y(I),X(I),X3D(I),D(I)
10683   56       FORMAT('I,Y(I),X(I),X3D(I),D(I) = ',I8,4G15.7)
10684            CALL DPWRST('XXX','BUG ')
10685   55     CONTINUE
10686        ENDIF
10687        WRITE(ICOUT,61)XMATN,YMATN,XMITN,YMITN
10688   61   FORMAT('XMATN,YMATN,XMITN,YMITN = ',4G15.7)
10689        CALL DPWRST('XXX','BUG ')
10690        WRITE(ICOUT,71)IMPSW,IMPNR,IMPNC,IMPCO
10691   71   FORMAT('IMPSW,IMPNR,IMPNC,IMPCO = ',A4,3I8)
10692        CALL DPWRST('XXX','BUG ')
10693        WRITE(ICOUT,72)PMXMIN,PMXMAX,PMYMIN,PMYMAX
10694   72   FORMAT('PMXMIN,PMXMAX,PMYMIN,PMYMAX = ',4G15.7)
10695        CALL DPWRST('XXX','BUG ')
10696        WRITE(ICOUT,74)PWXMIN,PWXMAX,PWYMIN,PWYMAX
10697   74   FORMAT('PWXMIN,PWXMAX,PWYMIN,PWYMAX = ',4G15.7)
10698        CALL DPWRST('XXX','BUG ')
10699        WRITE(ICOUT,75)PXMIN,PXMAX,PYMIN,PYMAX
10700   75   FORMAT('PXMIN,PXMAX,PYMIN,PYMAX = ',4E15.7)
10701        CALL DPWRST('XXX','BUG ')
10702        WRITE(ICOUT,76)IEMBSW,IEMCNT,PEMXC1,PEMXC2,PEMYC1,PEMYC2
10703   76   FORMAT('IEMBSW,IEMCNT,PEMXC1,PEMXC2,PEMYC1,PEMYC2 = ',
10704     1         A4,I8,4G15.7)
10705        CALL DPWRST('XXX','BUG ')
10706        WRITE(ICOUT,77)FX1MNE,FX1MXE,FY1MNE,FY1MXE
10707   77   FORMAT('FX1MNE,FX1MXE,FY1MNE,FY1MXE = ',4G15.7)
10708        CALL DPWRST('XXX','BUG ')
10709      ENDIF
10710C
10711C               ****************************************
10712C               **  STEP 11--                         **
10713C               **  COPY PLOT COORDINATES             **
10714C               **  OUT TO VARIABLES YPLOT, XPLOT,    **
10715C               **  X2PLOT, AND TAGPLOT               **
10716C               ****************************************
10717C
10718      DO100I=1,NPLOTP
10719        YPLOT(I)=Y(I)
10720        XPLOT(I)=X(I)
10721        X2PLOT(I)=X3D(I)
10722        TAGPLO(I)=D(I)
10723  100 CONTINUE
10724      J4=5
10725      IN(J4)=NPLOTP
10726      J4=6
10727      IN(J4)=NPLOTP
10728      J4=7
10729      IN(J4)=NPLOTP
10730      J4=8
10731      IN(J4)=NPLOTP
10732C
10733C               ****************************************
10734C               **  STEP 12--                         **
10735C               **  IF THE RESPONSE IS TO BE NEGATED  **
10736C               **  (AS IN HANGING HISTOGRAMS),       **
10737C               **  THEN DO SO HERE.                  **
10738C               ****************************************
10739C
10740      IF(INEGSW.EQ.'ON' .AND. NPLOTP.GT.0)THEN
10741        DO200I=1,NPLOTP
10742          Y(I)=-Y(I)
10743  200   CONTINUE
10744      ENDIF
10745C
10746      IF(IMPSW.EQ.'ON' .AND. IEMBSW.EQ.'ON')THEN
10747        WRITE(ICOUT,999)
10748        CALL DPWRST('XXX','BUG ')
10749        WRITE(ICOUT,401)
10750        CALL DPWRST('XXX','BUG ')
10751        WRITE(ICOUT,303)
10752  303   FORMAT('       THE MULTIPLOT AND EMBED OPTIONS CANNOT BOTH')
10753        CALL DPWRST('XXX','BUG ')
10754        WRITE(ICOUT,305)
10755  305   FORMAT('       BE ON WHEN GENERATING A PLOT.')
10756        CALL DPWRST('XXX','BUG ')
10757        IERROR='YES'
10758        GOTO9000
10759      ENDIF
10760C
10761C               *********************************************
10762C               **  STEP 13--                              **
10763C               **  IF THE MULTIPLOTTING SWITCH IS ON,     **
10764C               **  THEN SET THE FRAME CORNER COORDINATES  **
10765C               **  BEFORE THE PLOT IS DRAWN.              **
10766C               *********************************************
10767C
10768      IF(IMPSW.EQ.'ON')THEN
10769C
10770        IF(IMPCO.GE.2)IERASW='OFF'
10771CCCCC   DO NOT ERASE SCREEN FOR 3 AND 4 ARGUMENT FORMS OF MULTIPLOT
10772        IF(IMPCO.EQ.1.AND.IMPARG.GE.3.AND.IMPCO9.GT.1)IERASW='OFF'
10773        IMPCO9=IMPCO9+1
10774C
10775        IPROD=IMPNR*IMPNC
10776        IMPCO2=MOD(IMPCO,IPROD)
10777        IF(IMPCO2.LE.0)IMPCO2=IPROD
10778        ICOL=MOD(IMPCO2,IMPNC)
10779        IF(ICOL.LE.0)ICOL=IMPNC
10780        IROW=((IMPCO2-ICOL)/IMPNC)+1
10781        AIROW=IROW
10782        AICOL=ICOL
10783C
10784        AMPNR=IMPNR
10785        AMPNC=IMPNC
10786C
10787        XDEL=(PMXMAX-PMXMIN)/AMPNC
10788        YDEL=(PMYMAX-PMYMIN)/AMPNR
10789C
10790        X1C=PMXMIN+(AICOL-1.0)*XDEL
10791        X2C=X1C+XDEL
10792        Y1C=PMYMAX-AIROW*YDEL
10793        Y2C=Y1C+YDEL
10794C
10795        PWXMIN=X1C
10796        PWXMAX=X2C
10797        PWYMIN=Y1C
10798        PWYMAX=Y2C
10799C
10800        IF(IBUGUG.EQ.'ON'.OR.ISUBRO.EQ.'GRAP')THEN
10801          WRITE(ICOUT,999)
10802          CALL DPWRST('XXX','BUG ')
10803          WRITE(ICOUT,321)
10804  321     FORMAT('AT END OF STEP 13--')
10805          CALL DPWRST('XXX','BUG ')
10806          WRITE(ICOUT,322)IMPSW,IMPNR,IMPNC,IMPCO
10807  322     FORMAT('IMPSW,IMPNR,IMPNC,IMPCO = ',A4,3I8)
10808          CALL DPWRST('XXX','BUG ')
10809          WRITE(ICOUT,323)IPROD,IMPCO2,IROW,ICOL
10810  323     FORMAT('IPROD,IMPCO2,IROW,ICOL = ',4I8)
10811          CALL DPWRST('XXX','BUG ')
10812          WRITE(ICOUT,324)PMXMIN,PMXMAX,PMYMIN,PMYMAX
10813  324     FORMAT('PMXMIN,PMXMAX,PMYMIN,PMYMAX = ',4G15.7)
10814          CALL DPWRST('XXX','BUG ')
10815          WRITE(ICOUT,326)XDEL,YDEL,X1C,X2C,Y1C,Y2C
10816  326     FORMAT('XDEL,YDEL,X1C,X2C,Y1C,Y2C = ',6G15.7)
10817          CALL DPWRST('XXX','BUG ')
10818          WRITE(ICOUT,327)PWXMIN,PWXMAX,PWYMIN,PWYMAX
10819  327     FORMAT('PWXMIN,PWXMAX,PWYMIN,PWYMAX = ',4E15.7)
10820          CALL DPWRST('XXX','BUG ')
10821        ENDIF
10822C
10823C               *********************************************
10824C               **  STEP 14--                              **
10825C               **  IF THE EMBED SWITCH IS ON, THEN SET    **
10826C               **  THE FRAME CORNER COORDINATES BEFORE    **
10827C               **  THE PLOT IS DRAWN.                     **
10828C               *********************************************
10829C
10830      ELSEIF(IEMBSW.EQ.'ON')THEN
10831C
10832C       IF THIS IS THE FIRST PLOT AFTER EMBED SWITCH, THEN
10833C       PROCEED NORMALLY.  OTHERWISE, ADJUST FRAME CORNER
10834C       COORDINATES.
10835C
10836        IEMCNT=IEMCNT+1
10837        IF(IEMCNT.EQ.1)THEN
10838          FX1MNE=CPUMIN
10839          FX1MXE=CPUMIN
10840          FY1MNE=CPUMIN
10841          FY1MXE=CPUMIN
10842          PXMINE=CPUMIN
10843          PXMAXE=CPUMIN
10844          PYMINE=CPUMIN
10845          PYMAXE=CPUMIN
10846        ELSEIF(IEMCNT.GT.1)THEN
10847C
10848C         FIRST, SET COORDINATES IN TERMS OF CURRENT DATA
10849C         UNITS (FX1MNE,FX1MXE,FY1MNE,FY1MXE).
10850C
10851          IF(FX1MNE.EQ.CPUMIN .OR. FX1MXE.EQ.CPUMIN .OR.
10852     1       FY1MNE.EQ.CPUMIN .OR. FY1MXE.EQ.CPUMIN)THEN
10853            WRITE(ICOUT,999)
10854            CALL DPWRST('XXX','BUG ')
10855            WRITE(ICOUT,401)
10856  401       FORMAT('****** ERROR IN DPGRAP--')
10857            CALL DPWRST('XXX','BUG ')
10858            WRITE(ICOUT,403)
10859  403       FORMAT('       OUTER FRAME CORNER COORDINATES ARE NOT ',
10860     1             'FULLY DEFINED.')
10861            CALL DPWRST('XXX','BUG ')
10862            WRITE(ICOUT,406)FX1MNE
10863  406       FORMAT('       COORDINATE FOR MINIMUM X-COORDINATE: ',
10864     1             G15.7)
10865            CALL DPWRST('XXX','BUG ')
10866            WRITE(ICOUT,407)FX1MXE
10867  407       FORMAT('       COORDINATE FOR MAXIMUM X-COORDINATE: ',
10868     1             G15.7)
10869            CALL DPWRST('XXX','BUG ')
10870            WRITE(ICOUT,408)FY1MNE
10871  408       FORMAT('       COORDINATE FOR MINIMUM Y-COORDINATE: ',
10872     1             G15.7)
10873            CALL DPWRST('XXX','BUG ')
10874            WRITE(ICOUT,409)FY1MXE
10875  409       FORMAT('       COORDINATE FOR MAXIMUM Y-COORDINATE: ',
10876     1             G15.7)
10877            CALL DPWRST('XXX','BUG ')
10878            IERROR='YES'
10879            GOTO9000
10880          ENDIF
10881C
10882          IF(PEMXC1.LT.FX1MNE)THEN
10883            WRITE(ICOUT,999)
10884            CALL DPWRST('XXX','BUG ')
10885            WRITE(ICOUT,401)
10886            CALL DPWRST('XXX','BUG ')
10887            WRITE(ICOUT,411)IEMCNT
10888  411       FORMAT('       FOR EMBEDDED PLOT ',I5,', THE MINIMUM ',
10889     1             'X-COORDINATE IS OUT OF BOUNDS.')
10890            CALL DPWRST('XXX','BUG ')
10891            WRITE(ICOUT,413)FX1MNE
10892  413       FORMAT('       X-COORDINATE MINIMUM FOR OUTER FRAME: ',
10893     1             G15.7)
10894            CALL DPWRST('XXX','BUG ')
10895            WRITE(ICOUT,415)PEMXC1
10896  415       FORMAT('       X-COORDINATE MINIMUM FOR THE ',
10897     1             'EMBEDDED PLOT: ',G15.7)
10898            CALL DPWRST('XXX','BUG ')
10899            IERROR='YES'
10900            GOTO9000
10901          ELSEIF(PEMXC2.GT.FX1MXE)THEN
10902            WRITE(ICOUT,999)
10903            CALL DPWRST('XXX','BUG ')
10904            WRITE(ICOUT,401)
10905            CALL DPWRST('XXX','BUG ')
10906            WRITE(ICOUT,421)IEMCNT
10907  421       FORMAT('       FOR EMBEDDED PLOT ',I5,', THE MAXIMUM ',
10908     1             'X-COORDINATE IS OUT OF BOUNDS.')
10909            CALL DPWRST('XXX','BUG ')
10910            WRITE(ICOUT,423)FX1MXE
10911  423       FORMAT('       X-COORDINATE MAXIMUM FOR OUTER FRAME: ',
10912     1             G15.7)
10913            CALL DPWRST('XXX','BUG ')
10914            WRITE(ICOUT,425)PEMXC2
10915  425       FORMAT('       X-COORDINATE MAXIMUM FOR THE ',
10916     1             'EMBEDDED PLOT: ',G15.7)
10917            CALL DPWRST('XXX','BUG ')
10918            IERROR='YES'
10919            GOTO9000
10920          ELSEIF(PEMYC1.LT.FY1MNE)THEN
10921            WRITE(ICOUT,401)
10922            CALL DPWRST('XXX','BUG ')
10923            WRITE(ICOUT,431)IEMCNT
10924  431       FORMAT('       FOR EMBEDDED PLOT ',I5,', THE MINIMUM ',
10925     1             'Y-COORDINATE IS OUT OF BOUNDS.')
10926            CALL DPWRST('XXX','BUG ')
10927            WRITE(ICOUT,433)FY1MNE
10928  433       FORMAT('       Y-COORDINATE MINIMUM FOR OUTER FRAME: ',
10929     1             G15.7)
10930            CALL DPWRST('XXX','BUG ')
10931            WRITE(ICOUT,435)PEMYC1
10932  435       FORMAT('       Y-COORDINATE MINIMUM FOR THE ',
10933     1             'EMBEDDED PLOT: ',G15.7)
10934            CALL DPWRST('XXX','BUG ')
10935            IERROR='YES'
10936            GOTO9000
10937          ELSEIF(PEMYC2.GT.FY1MXE)THEN
10938            WRITE(ICOUT,999)
10939            CALL DPWRST('XXX','BUG ')
10940            WRITE(ICOUT,401)
10941            CALL DPWRST('XXX','BUG ')
10942            WRITE(ICOUT,441)IEMCNT
10943  441       FORMAT('       FOR EMBEDDED PLOT ',I5,', THE MAXIMUM ',
10944     1             'Y-COORDINATE IS OUT OF BOUNDS.')
10945            CALL DPWRST('XXX','BUG ')
10946            WRITE(ICOUT,443)FY1MXE
10947  443       FORMAT('       Y-COORDINATE MAXIMUM FOR OUTER FRAME: ',
10948     1             G15.7)
10949            CALL DPWRST('XXX','BUG ')
10950            WRITE(ICOUT,445)PEMYC2
10951  445       FORMAT('       Y-COORDINATE MAXIMUM FOR THE ',
10952     1             'EMBEDDED PLOT: ',G15.7)
10953            CALL DPWRST('XXX','BUG ')
10954            IERROR='YES'
10955            GOTO9000
10956          ENDIF
10957C
10958          IERASW='OFF'
10959C
10960C         NOW COMPUTE THE NEW FRAME CORNER COORDINATES
10961C
10962          AFACT1=(PEMXC1-FX1MNE)/(FX1MXE-FX1MNE)
10963          PWXMIN=PXMINE + AFACT1*(PXMAXE-PXMINE)
10964          AFACT1=(PEMXC2-FX1MNE)/(FX1MXE-FX1MNE)
10965          PWXMAX=PXMINE + AFACT1*(PXMAXE-PXMINE)
10966          AFACT1=(PEMYC1-FY1MNE)/(FY1MXE-FY1MNE)
10967          PWYMIN=PYMINE + AFACT1*(PYMAXE-PYMINE)
10968          AFACT1=(PEMYC2-FY1MNE)/(FY1MXE-FY1MNE)
10969          PWYMAX=PYMINE + AFACT1*(PYMAXE-PYMINE)
10970C
10971          IF(IBUGUG.EQ.'ON'.OR.ISUBRO.EQ.'GRAP')THEN
10972            WRITE(ICOUT,999)
10973            CALL DPWRST('XXX','BUG ')
10974            WRITE(ICOUT,451)
10975  451       FORMAT('AFTER COMPUTING NEW FRAME COORDINATES FOR ',
10976     1             'EMBEDDED PLOTS')
10977            CALL DPWRST('XXX','BUG ')
10978            WRITE(ICOUT,452)PEMXC1,PEMXC2,PEMYC1,PEMYC2
10979  452       FORMAT('PEMXC1,PEMXC2,PEMYC1,PEMYC2 = ',4G15.7)
10980            CALL DPWRST('XXX','BUG ')
10981            WRITE(ICOUT,453)PWXMIN,PWXMAX,PWYMIN,PWYMAX
10982  453       FORMAT('PXWMIN,PWXMAX,PWYMIN,PWYMAX = ',4G15.7)
10983            CALL DPWRST('XXX','BUG ')
10984            WRITE(ICOUT,455)FX1MNE,FX1MXE,FY1MNE,FY1MXE
10985  455       FORMAT('FX1MNE,FX1MXE,FY1MNE,FY1MXE = ',4G15.7)
10986            CALL DPWRST('XXX','BUG ')
10987          ENDIF
10988C
10989        ENDIF
10990      ENDIF
10991C
10992C               ********************************************************
10993C               **  STEP 21--                                         **
10994C               **  MONITOR NUMSET = THE NUMBER OF SUBSETS.           **
10995C               **  IF NUMSET EXCEEDS MAXCHA                          **
10996C               **  (THE MAXIMUM NUMBER OF PLOT CHARACTERS),          **
10997C               **  THEN THE ANALYSIS WILL BE SEQUENTIALLY            **
10998C               **  PARTITIONED INTO NUMSET=MAXCHA SUBSETS AT A TIME  **
10999C               **  (THAT IS, LOWER LEVEL SUBROUTINES WILL BE FED     **
11000C               **  ONLY NUMSET=MAXCHA SUBSETS AT A TIME).            **
11001C               **  IMIN IS THAT ELEMENT NUMBER (1 THROUGH NPLOTP)    **
11002C               **  IN THE DATA SET WHERE THE NEXT PARTITION IS TO    **
11003C               **  BEGIN.  THE FOLLOWING LARGE LOOP                  **
11004C               **  (STARTING WITH     1000 CONTINUE)                 **
11005C               **  WILL BE ENTERED ONLY IF MORE PARTITIONS EXIST.    **
11006C               **  IF IMORE = 'YES', THEN MORE PARTITIONS EXIST;     **
11007C               **  IF IMORE = 'NO' , THEN NO MORE PARTITIONS EXIST   **
11008C               **  AND THEREFORE WE ARE DONE.                        **
11009C               ********************************************************
11010C
11011      ISTEPN='21'
11012      IF(IBUGUG.EQ.'ON'.OR.ISUBRO.EQ.'GRAP')
11013     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11014C
11015      IMORE='YES'
11016      IPASS=0
11017      IMIN=1
11018C
11019 1000 CONTINUE
11020      IMORE='NO'
11021      IPASS=IPASS+1
11022      NUMSET=0
11023C
11024C               ******************************************
11025C               **  STEP 22--                           **
11026C               **  IF A PLOT OF NO DATA IS CALLED FOR  **
11027C               **  (AS IN THE GENERATION OF DIAGRAMS,  **
11028C               **  EQUATIONS, AND SLIDES), THEN SKIP   **
11029C               **  IMMEDIATELY TO THE PLOTTING.        **
11030C               ******************************************
11031C
11032      ISTEPN='22'
11033      IF(IBUGUG.EQ.'ON'.OR.ISUBRO.EQ.'GRAP')
11034     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11035C
11036      IF(ICASPL.EQ.'NODA')GOTO1300
11037C
11038C               **************************************************
11039C               **  STEP 23--                                   **
11040C               **  DETERMINE IF A 3DPLOT IS BEING GENERATED    **
11041C               **************************************************
11042C
11043      ISTEPN='23'
11044      IF(IBUGUG.EQ.'ON'.OR.ISUBRO.EQ.'GRAP')
11045     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11046C
11047      ICAS3D='OFF'
11048      IF(ICASPL.EQ.'3DNO')GOTO1210
11049      IF(ICASPL.EQ.'3DEF')GOTO1210
11050      IF(ICASPL.EQ.'3DVS')GOTO1210
11051      IF(ICASPL.EQ.'3DFR')GOTO1210
11052      IF(ICASPL.EQ.'3DHI')GOTO1210
11053      IF(ICASPL.EQ.'YCUB')GOTO1210
11054      IF(IPPCFO.EQ.'3D')THEN
11055        IF(ICASPL.EQ.'PPCC')GOTO1210
11056        IF(ICASPL.EQ.'KS  ')GOTO1210
11057        IF(ICASPL.EQ.'AD  ')GOTO1210
11058        IF(ICASPL.EQ.'CHSQ')GOTO1210
11059      ENDIF
11060      GOTO1290
11061 1210 CONTINUE
11062      ICAS3D='ON'
11063 1290 CONTINUE
11064C
11065C               *******************************************************
11066C               **  STEP 24--                                        **
11067C               **  DETERMINE THE NUMBER OF DISTINCT SUBSETS TO BE   **
11068C               **  TO BE PLOTTED (ON THE BASIS OF THE NUMBER OF     **
11069C               **  DISTINCT LEVELS OF THE SUBSET DEFINITION         **
11070C               **  VARIABLE).  EACH SUBSET DEFINES A POTENTIAL      **
11071C               **  CURVE ON THE FINAL PLOT.  COPY EACH SUBSET       **
11072C               **  IDENTIFIER INTO XIDC(.) AND THEN SORT (AN        **
11073C               **  ASCENDING SORT) XIDC(.).                         **
11074C               *******************************************************
11075C
11076      ISTEPN='24'
11077      IF(IBUGUG.EQ.'ON'.OR.ISUBRO.EQ.'GRAP')
11078     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11079C
11080      DO1110J=1,MAXCHA
11081        XIDC(J)=0.0
11082 1110 CONTINUE
11083C
11084      IMORE='NO'
11085      DO1120I=IMIN,NPLOTP
11086        I2=I
11087        IF(NUMSET.GT.0)THEN
11088          DO1130J=1,NUMSET
11089            IF(D(I).EQ.XIDC(J))GOTO1120
11090 1130     CONTINUE
11091        ENDIF
11092        NUMSET=NUMSET+1
11093        IF(NUMSET.GT.MAXCHA)THEN
11094          IMORE='YES'
11095          IMIN=I2
11096          NUMSET=MAXCHA
11097          GOTO1139
11098        ENDIF
11099        XIDC(NUMSET)=D(I)
11100 1120 CONTINUE
11101 1139 CONTINUE
11102      IF(NUMSET.GE.2)CALL SORT(XIDC,NUMSET,XIDC)
11103C
11104C               *************************
11105C               **  STEP 31--          **
11106C               **  GENERATE THE PLOT  **
11107C               *************************
11108C
11109 1300 CONTINUE
11110C
11111      ISTEPN='31'
11112      IF(IBUGUG.EQ.'ON'.OR.ISUBRO.EQ.'GRAP')
11113     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11114C
11115      IFIRST='NO'
11116      ILAST='NO'
11117      IF(IPASS.EQ.1)IFIRST='YES'
11118      IF(IMORE.EQ.'NO')ILAST='YES'
11119C
11120      IF(IBUGUG.EQ.'ON'.OR.ISUBRO.EQ.'GRAP')THEN
11121        WRITE(ICOUT,999)
11122        CALL DPWRST('XXX','BUG ')
11123        WRITE(ICOUT,1301)
11124 1301   FORMAT('***** FROM THE MIDDLE  OF DPGRAP--')
11125        CALL DPWRST('XXX','BUG ')
11126        WRITE(ICOUT,1302)
11127 1302   FORMAT('      (IMMEDIATELY BEFORE A PLOT IS GENERATED)')
11128        CALL DPWRST('XXX','BUG ')
11129        WRITE(ICOUT,1303)ICONT,NUMHPP,MAXCHA,N,NPLOTP,NUMSET
11130 1303   FORMAT('ICONT,NUMHPP,MAXCHA,N,NPLOTP,NUMSET = ',A4,5I8)
11131        CALL DPWRST('XXX','BUG ')
11132        WRITE(ICOUT,1304)IMIN,IPASS,IMORE,ICASPL,IFIRST,ILAST
11133 1304   FORMAT('IMIN,IPASS,IMORE,ICASPL,IFIRST,ILAST = ',2I8,4(2X,A4))
11134        CALL DPWRST('XXX','BUG ')
11135        DO1305I=1,NUMSET
11136          WRITE(ICOUT,1306)I,XIDC(I),ICHAPA(I),ILINPA(I)
11137 1306     FORMAT('I,XIDC(I),ICHAPA(I),ILINPA(I) =',
11138     1           I6,F15.7,2X,A24,2X,A4)
11139          CALL DPWRST('XXX','BUG ')
11140 1305   CONTINUE
11141        WRITE(ICOUT,1307)Y(1),X(1),D(1)
11142 1307   FORMAT('Y(1),X(1),D(1) = ',3G15.7)
11143        CALL DPWRST('XXX','BUG ')
11144        WRITE(ICOUT,1308)Y(NPLOTP),X(NPLOTP),D(NPLOTP)
11145 1308   FORMAT('Y(NPLOTP),X(NPLOTP),D(NPLOTP) = ',3G15.7)
11146        CALL DPWRST('XXX','BUG ')
11147        WRITE(ICOUT,1311)
11148 1311   FORMAT('A PLOT IS GENERATED AT THIS TIME')
11149        CALL DPWRST('XXX','BUG ')
11150      ENDIF
11151C
11152      IF(ICONT.EQ.'ON' .OR. (ICONT.EQ.'OFF'.AND.NUMDEV.GE.2))THEN
11153        CALL PLOTGE(Y,X,X3D,D,NPLOTP,XIDC,NUMSET,
11154     1              ICASPL,ICAS3D,ISQUAR,YSAVE,
11155     1              IVGMSW,IHGMSW,
11156     1              IFIRST,ILAST,
11157     1              IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,
11158     1              IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,
11159     1              DSIZE,DSYMB,DCOLOR,DFILL,
11160     1              ICAPSW,
11161     1              IBUGU2,IBUGU3,IBUGU4,ISUBRO,IERROR)
11162      ENDIF
11163C
11164C     CHECK IF SCREEN DEVICE IS NON-CONTINUOUS
11165C
11166      IF(ICONT.EQ.'OFF'.AND.NUMHPP.LE.130.AND.NUMSET.LE.1.AND.
11167     1       IPOWE.EQ.'ON')THEN
11168          CALL PLOTN(Y,X,NPLOTP,ICHAPA,MAXCHA,ICASPL,ICAS3D,
11169     1               ITITTE,NCTITL,
11170     1               IX1LTE,NCX1LA,
11171     1               IX2LTE,NCX2LA,
11172     1               IX3LTE,NCX3LA,
11173     1               IY1LTE,NCY1LA,
11174     1               IY2LTE,NCY2LA,
11175     1               GX1MIN,GX1MAX,GY1MIN,GY1MAX,
11176     1               IERASW,IBUGU2,IERROR)
11177C
11178      ELSEIF(ICONT.EQ.'OFF'.AND.NUMHPP.LE.130.AND.NUMSET.GE.2.AND.
11179     1       IPOWE.EQ.'ON')THEN
11180        CALL PLOTCN(Y,X,D,NPLOTP,ICHAPA,MAXCHA,ICASPL,ICAS3D,
11181     1              ITITTE,NCTITL,
11182     1              IX1LTE,NCX1LA,
11183     1              IX2LTE,NCX2LA,
11184     1              IX3LTE,NCX3LA,
11185     1              IY1LTE,NCY1LA,
11186     1              IY2LTE,NCY2LA,
11187     1              GX1MIN,GX1MAX,GY1MIN,GY1MAX,
11188     1              IERASW,IBUGU2,IERROR)
11189C
11190      ELSEIF(ICONT.EQ.'OFF'.AND.NUMHPP.GT.130.AND.NUMSET.LE.1.AND.
11191     1       IPOWE.EQ.'ON')THEN
11192        CALL PLOTW(Y,X,NPLOTP,ICHAPA,MAXCHA,ICASPL,ICAS3D,
11193     1             ITITTE,NCTITL,
11194     1             IX1LTE,NCX1LA,
11195     1             IX2LTE,NCX2LA,
11196     1             IX3LTE,NCX3LA,
11197     1             IY1LTE,NCY1LA,
11198     1             IY2LTE,NCY2LA,
11199     1             GX1MIN,GX1MAX,GY1MIN,GY1MAX,
11200     1             IERASW,IBUGU2,IERROR)
11201C
11202      ELSEIF(ICONT.EQ.'OFF'.AND.NUMHPP.GT.130.AND.NUMSET.GE.2.AND.
11203     1       IPOWE.EQ.'ON')THEN
11204        CALL PLOTCW(Y,X,D,NPLOTP,ICHAPA,MAXCHA,ICASPL,ICAS3D,
11205     1              ITITTE,NCTITL,
11206     1              IX1LTE,NCX1LA,
11207     1              IX2LTE,NCX2LA,
11208     1              IX3LTE,NCX3LA,
11209     1              IY1LTE,NCY1LA,
11210     1              IY2LTE,NCY2LA,
11211     1              GX1MIN,GX1MAX,GY1MIN,GY1MAX,
11212     1              IERASW,IBUGU2,IERROR)
11213      ENDIF
11214C
11215      IF(IMORE.EQ.'YES')GOTO1000
11216C
11217      IF(IEMBSW.EQ.'ON' .AND. IEMCNT.EQ.1)THEN
11218        FX1MNE=FX1MIN
11219        FX1MXE=FX1MAX
11220        FY1MNE=FY1MIN
11221        FY1MXE=FY1MAX
11222        PXMINE=PXMIN
11223        PXMAXE=PXMAX
11224        PYMINE=PYMIN
11225        PYMAXE=PYMAX
11226      ENDIF
11227C
11228C               *********************************************
11229C               **  STEP 32--                              **
11230C               **  IF THE MULTIPLOTTING SWITCH IS ON,     **
11231C               **  AND IF THE LAST PLOT ON THE PAGE       **
11232C               **  HAS JUST BEEN GENERATED,               **
11233C               **  THEN REVERT THE FRAME COORDINATE       **
11234C               **  AND PRE-ERASE SETTINGS BACK TO THEIR   **
11235C               **  PRIOR SETTINGS.                        **
11236C               *********************************************
11237C
11238      IF(IMPSW.EQ.'ON')THEN
11239CCCCC   THE FOLLOWING LINE WAS FIXED NOVEMBER 1991
11240CCCCC   IMPCO=IMPCO+1
11241        IF(IMPSW.EQ.'ON')IMPCO=IMPCO+1
11242CCCCC   IPROD=IMPNR*IMPNC
11243CCCCC   IF(IMPCO.GT.IPROD)GOTO2110
11244CCCCC   GOTO2190
11245C2110   CONTINUE
11246CCCCC   IMPCO=1
11247CCCCC   IERASW=IERASV
11248CCCCC   IX1TSW=IX1TSV
11249CCCCC   IX2TSW=IX2TSV
11250CCCCC   IY1TSW=IY1TSV
11251CCCCC   IY2TSW=IY2TSV
11252CCCCC   PXMIN=PXMISV
11253CCCCC   PXMAX=PXMASV
11254CCCCC   PYMIN=PYMISV
11255CCCCC   PYMAX=PYMASV
11256      ENDIF
11257C
11258C               *****************
11259C               **  STEP 90--  **
11260C               **  EXIT       **
11261C               *****************
11262C
11263 9000 CONTINUE
11264C
11265C     FOR DISTRIBUTIONAL FIT PLOT CASE, RESTORE
11266C     Y1 AXIS SETTINGS.
11267C
11268      IF(ICASPL.EQ.'DFIT')THEN
11269        IY1MIN=IY1MNZ
11270        IY1MAX=IY1MXZ
11271        GY1MIN=GY1MNZ
11272        GY1MAX=GY1MXZ
11273        NMJY1T=NMJY1Z
11274        NMNY1T=NMNY1Z
11275        IY1JSW=IY1JSZ
11276        IY1NSW=IY1NSZ
11277        IY1ZFM=IY1ZFZ
11278        IY1ZCN=IY1ZCZ
11279      ENDIF
11280C
11281      IF(IBUGUG.EQ.'ON'.OR.ISUBRO.EQ.'GRAP')THEN
11282        WRITE(ICOUT,999)
11283        CALL DPWRST('XXX','BUG ')
11284        WRITE(ICOUT,9011)
11285 9011   FORMAT('***** AT THE END       OF DPGRAP--')
11286        CALL DPWRST('XXX','BUG ')
11287        WRITE(ICOUT,9012)IERROR,ICAS3D,I3DPRO
11288 9012   FORMAT('IERROR,ICAS3D,I3DPRO = ',2(A4,2X),A4)
11289        CALL DPWRST('XXX','BUG ')
11290        WRITE(ICOUT,9013)N,NPLOTP,ICASPL,INEGSW
11291 9013   FORMAT('N,NPLOTP,ICASPL,INEGSW = ',2I8,2(2X,A4))
11292        CALL DPWRST('XXX','BUG ')
11293        WRITE(ICOUT,9031)IMPSW,IMPNR,IMPNC,IMPCO
11294 9031   FORMAT('IMPSW,IMPNR,IMPNC,IMPCO = ',A4,3I8)
11295        CALL DPWRST('XXX','BUG ')
11296        WRITE(ICOUT,9032)PMXMIN,PMXMAX,PMYMIN,PMYMAX
11297 9032   FORMAT('PMXMIN,PMXMAX,PMYMIN,PMYMAX = ',4G15.7)
11298        CALL DPWRST('XXX','BUG ')
11299        WRITE(ICOUT,9034)PWXMIN,PWXMAX,PWYMIN,PWYMAX
11300 9034   FORMAT('PWXMIN,PWXMAX,PWYMIN,PWYMAX = ',4G15.7)
11301        CALL DPWRST('XXX','BUG ')
11302        WRITE(ICOUT,9035)PXMIN,PXMAX,PYMIN,PYMAX
11303 9035   FORMAT('PXMIN,PXMAX,PYMIN,PYMAX = ',4G15.7)
11304        CALL DPWRST('XXX','BUG ')
11305      ENDIF
11306C
11307      RETURN
11308      END
11309      SUBROUTINE DPGRAY(NPTS,NLAB,
11310     1                  AMEAN,ASD,N,
11311     1                  XGD,XGDS2,SEGDK1,SEGDK2,
11312     1                  XGDS20,XGDSZ1,XGDSZ2,
11313     1                  DLOWGD,DHIGGD,
11314     1                  IWRITE,IOUNI5,
11315     1                  ICAPSW,ICAPTY,NUMDIG,
11316     1                  ISUBRO,IBUGA3,IERROR)
11317C
11318C     PURPOSE--IMPLEMENT GRAYBILL-DEAL APPROACH TO CONSENSUS MEANS
11319C     PRINTING--YES
11320C     SUBROUTINES NEEDED--NONE
11321C     REFERENCES--SINHA (1985). "UNBIASED ESTIMATION OF THE
11322C                 VARIANCE OF THE GRAYBILL-DEAL ESTIMATOR OF THE
11323C                 COMMON MEAN OF SEVERAL POPULATIONS", CANADIAN
11324C                 JOURNAL OF STATISTICS, 13, PP. 243-247.
11325C               --ZHANG (2006). "THE UNCERTAINTY ASSOCIATED WITH
11326C                 THE WEIGHTED MEAN OF MEASUREMENT DATA",
11327C                 METROLOGIA, 43, PP. 195-204.
11328C     WRITTEN BY--ALAN HECKERT
11329C                 STATISTICAL ENGINEERING DIVISION
11330C                 INFORMATION TECHNOLOGY LABORATORY
11331C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
11332C                 GAITHERSBURG, MD 20899-8980
11333C                 PHONE--301-975-2899
11334C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
11335C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
11336C     LANGUAGE--ANSI FORTRAN (1977)
11337C     VERSION NUMBER--2006/3
11338C     ORIGINAL VERSION--MARCH     2006. EXTRACTED FROM DPMAN2 ROUTINE
11339C     UPDATD          --OCTOBER   2006. CALL LIST TO TPPF
11340C     UPDATED         --FEBRUARY  2010. USE DPDTA1 TO PRINT
11341C     UPDATED         --SEPTEMBER 2012. WRITE TO FILE
11342C     UPDATED         --OCTOBER   2014. SUPPORT CASE WHERE AN
11343C                                       UNCERTAINTY IS GIVEN RATHER
11344C                                       THAN SD AND SAMPLE SIZE
11345C
11346C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES--------------
11347C
11348      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
11349C
11350      CHARACTER*4 ICAPSW
11351      CHARACTER*4 ICAPTY
11352      CHARACTER*4 ISUBRO
11353      CHARACTER*4 IBUGA3
11354      CHARACTER*4 IERROR
11355C
11356      CHARACTER*4 IWRITE
11357      CHARACTER*4 ISUBN1
11358      CHARACTER*4 ISUBN2
11359C
11360      REAL AMEAN(*)
11361      REAL ASD(*)
11362C
11363      REAL APPF
11364      REAL XGD
11365      REAL XGDS2
11366      REAL SEGDK1
11367      REAL SEGDK2
11368C
11369      LOGICAL IFLAG8
11370      LOGICAL IFLAG9
11371C
11372      INTEGER N(*)
11373C
11374C----------------------------------------------------------------
11375C
11376      INCLUDE 'DPCOST.INC'
11377C
11378      PARAMETER (MAXROW=20)
11379      CHARACTER*60 ITITLE
11380      CHARACTER*60 ITITLZ
11381      CHARACTER*60 ITITL9
11382      CHARACTER*60 ITEXT(MAXROW)
11383      REAL         AVALUE(MAXROW)
11384      INTEGER      NCTEXT(MAXROW)
11385      INTEGER      IDIGIT(MAXROW)
11386      INTEGER      NTOT(MAXROW)
11387      LOGICAL IFRST
11388      LOGICAL ILAST
11389C
11390      INCLUDE 'DPCOP2.INC'
11391C
11392C-----START POINT------------------------------------------------
11393C
11394      IERROR='NO'
11395      ISUBN1='DPGR'
11396      ISUBN2='AY  '
11397C
11398      DNI=0.0D0
11399      DVARI=0.0D0
11400      DWI=0.0D0
11401C
11402      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GRAY')THEN
11403        WRITE(ICOUT,999)
11404  999   FORMAT(1X)
11405        CALL DPWRST('XXX','BUG ')
11406        WRITE(ICOUT,51)
11407   51   FORMAT('***** AT THE BEGINNING OF DPGRAY--')
11408        CALL DPWRST('XXX','BUG ')
11409        WRITE(ICOUT,52)IWRITE,NPTS,NLAB
11410   52   FORMAT('IWRITE,NPTS,NLAB = ',A4,2X,2I8)
11411        CALL DPWRST('XXX','BUG ')
11412      ENDIF
11413C
11414C     STEP 1: COMPUTE THE GRAYBILL-DEAL CONSENSUS MEAN
11415C
11416      IFLAG9=.TRUE.
11417      DSUM1=0.0D0
11418      DSUM2=0.0D0
11419      DSUM3=0.0D0
11420C
11421      IF(IOUNI5.GT.0)THEN
11422        WRITE(IOUNI5,912)
11423  912   FORMAT('WEIGHTS FROM GRAYBILL DEAL')
11424      ENDIF
11425C
11426      DO910I=1,NLAB
11427        DMEAN=DBLE(AMEAN(I))
11428        NITEMP=ABS(N(I))
11429        IF(N(I).LE.0)THEN
11430          DVARI=DBLE(ASD(I))**2
11431        ELSE
11432          DNI=DBLE(N(I))
11433          DVARI=DBLE(ASD(I))**2/DNI
11434        ENDIF
11435        DWI=1.0D0/DVARI
11436C
11437        IF(IOUNI5.GT.0)WRITE(IOUNI5,'(E15.7)')DWI
11438C
11439        DSUM1=DSUM1 + DWI*DMEAN
11440        DSUM2=DSUM2 + DWI
11441        IF(NITEMP.GT.3)THEN
11442          DSUM3=DSUM3 + ((DBLE(NITEMP)-3.0D0)/(DBLE(NITEMP)-1.0D0))*DWI
11443        ELSE
11444          IFLAG9=.FALSE.
11445        ENDIF
11446  910 CONTINUE
11447      XGD=REAL(DSUM1/DSUM2)
11448      DTERM3=DSUM2
11449      DTERM4=DSUM3
11450C
11451C     STEP 2: COMPUTE THE GRAYBILL-DEAL VARIANCE.  FOUR METHODS
11452C             FOR COMPUTING THE VARIANCE ARE USED:
11453C
11454C             1) SIMPLE: 1/SUM[i=1 to nlab][1/s(i)'**2]
11455C             2) METHOD PROPOSED BY SINH
11456C             3) METHOD 1 PROPOSED BY ZHANG
11457C             4) METHOD 2 PROPOSED BY ZHANG
11458C
11459      DSUM1=0.0D0
11460      DSUM2=0.0D0
11461      DSUM3=0.0D0
11462      DSUM4=0.0D0
11463C
11464      DO920I=1,NLAB
11465        DMEAN=DBLE(AMEAN(I))
11466        NITEMP=ABS(N(I))
11467        DNI2=DBLE(NITEMP)
11468        IF(N(I).LE.0)THEN
11469          DVARI=DBLE(ASD(I))**2
11470        ELSE
11471          DNI=DBLE(N(I))
11472          DVARI=DBLE(ASD(I))**2/DNI
11473        ENDIF
11474        DWI=1.0D0/DVARI
11475        DWI3=DWI/DTERM3
11476        DSUM2=DSUM2 + DWI
11477        IF(NITEMP.GT.1)THEN
11478          DSUM1=DSUM1 + DWI3*(1.0D0 - DWI3)/(DNI2 - 1.0D0)
11479        ELSE
11480          IFLAG8=.FALSE.
11481        ENDIF
11482        IF(NITEMP.GT.3)THEN
11483          DTERM5=((DNI2-3.0D0)/(DNI2-1.0D0))*DWI
11484          DWI2=DTERM5/DTERM4
11485          DSUM3=DSUM3 + DTERM5
11486          DSUM4=DSUM4 + DWI2*(1.0D0-DWI2)/(DNI2-1.0D0)
11487        ELSE
11488          IFLAG9=.FALSE.
11489        ENDIF
11490  920 CONTINUE
11491      IF(IFLAG8)THEN
11492        DTERM1=(1.0D0 + DSUM1)/DTERM3
11493        XGDS2=REAL((1.0D0/DTERM3)*(1.0D0 + 4.0D0*DSUM1))
11494        SEGDK1=SQRT(XGDS2)
11495        SEGDK2=2.0*SQRT(XGDS2)
11496      ELSE
11497        XGDS2=0.0
11498        SEGDK1=0.0
11499        SEGDK2=0.0
11500      ENDIF
11501      XGDS20=REAL(1.0D0/DSUM2)
11502      IF(SEGDK1.EQ.0.0)THEN
11503        SEGDK1=SQRT(XGDS20)
11504        SEGDK2=2.0*SQRT(XGDS20)
11505      ENDIF
11506      IF(IFLAG9)THEN
11507        XGDSZ1=REAL(1.0D0/DSUM3)
11508        XGDSZ2=REAL((1.0D0/DSUM3)*(1.0D0 + 2.0D0*DSUM4))
11509      ELSE
11510        XGDSZ1=0.0
11511        XGDSZ2=0.0
11512      ENDIF
11513C
11514C     COMPUTE THE RUKHIN CONFIDENCE INTERVALS
11515C
11516      DP=DBLE(NLAB)
11517      DPP=1.0D0/DBLE(NLAB-1)
11518      DRR=DP**(DP*DPP/2.0D0)
11519      IDF=NLAB-1
11520      ALPHA=0.975
11521      CALL TPPF(REAL(ALPHA),REAL(IDF),APPF)
11522      DPH=DBLE(APPF)/DRR/(DSQRT(DP-1.0D0))
11523C
11524      DSUM1=0.0D0
11525      DPROD1=1.0D0
11526      DO930I=1,NLAB
11527        DMEAN=DBLE(AMEAN(I))
11528        IF(N(I).LE.0)THEN
11529          DVARI=DBLE(ASD(I))**2
11530        ELSE
11531          DNI=DBLE(N(I))
11532          DVARI=DBLE(ASD(I))**2/DNI
11533        ENDIF
11534        DWI=DNI/DVARI
11535        DSUM1=DSUM1 + DWI*(DMEAN - DBLE(XGD))**2
11536        DPROD1=DPROD1*DWI
11537  930 CONTINUE
11538      DPROD1=DPROD1**DPP
11539      DRI=DPH*DSQRT(DSUM1)/DSQRT(DPROD1)
11540      DLOWGD=DBLE(XGD) - DRI
11541      DHIGGD=DBLE(XGD) + DRI
11542C
11543      IF(IPRINT.EQ.'OFF')GOTO9000
11544C
11545      ITITLE=' '
11546      NCTITL=0
11547      ITITLZ=' '
11548      NCTITZ=0
11549C
11550      ICNT=1
11551      ITEXT(ICNT)=' 5. Method: Graybill-Deal'
11552      NCTEXT(ICNT)=25
11553      AVALUE(ICNT)=0.0
11554      IDIGIT(ICNT)=-1
11555C
11556      ICNT=ICNT+1
11557      ITEXT(ICNT)='    Estimate of Consensus Mean:'
11558      NCTEXT(ICNT)=31
11559      AVALUE(ICNT)=XGD
11560      IDIGIT(ICNT)=NUMDIG
11561      IF(XGDS2.GT.0.0)THEN
11562        ICNT=ICNT+1
11563        ITEXT(ICNT)='    Estimate of Variance (Sinha):'
11564        NCTEXT(ICNT)=33
11565        AVALUE(ICNT)=XGDS2
11566        IDIGIT(ICNT)=NUMDIG
11567      ENDIF
11568C
11569      ICNT=ICNT+1
11570      ITEXT(ICNT)='    Estimate of Variance (Naive):'
11571      NCTEXT(ICNT)=33
11572      AVALUE(ICNT)=XGDS20
11573      IDIGIT(ICNT)=NUMDIG
11574C
11575      IF(XGDSZ1.GT.0.0)THEN
11576        ICNT=ICNT+1
11577        ITEXT(ICNT)='    Estimate of Variance (Zhang 1):'
11578        NCTEXT(ICNT)=35
11579        AVALUE(ICNT)=XGDSZ1
11580        IDIGIT(ICNT)=NUMDIG
11581      ENDIF
11582      IF(XGDSZ2.GT.0.0)THEN
11583        ICNT=ICNT+1
11584        ITEXT(ICNT)='    Estimate of Variance (Zhang 2):'
11585        NCTEXT(ICNT)=35
11586        AVALUE(ICNT)=XGDSZ2
11587        IDIGIT(ICNT)=NUMDIG
11588      ENDIF
11589C
11590      IF(XGDS2.GT.0.0)THEN
11591        ICNT=ICNT+1
11592        ITEXT(ICNT)='    Standard Uncertainty (Sinha) (k = 1):'
11593        NCTEXT(ICNT)=41
11594        AVALUE(ICNT)=SQRT(XGDS2)
11595        IDIGIT(ICNT)=NUMDIG
11596        ICNT=ICNT+1
11597        ITEXT(ICNT)='    Expanded Uncertainty (Sinha) (k = 2):'
11598        NCTEXT(ICNT)=41
11599        AVALUE(ICNT)=2.0*SQRT(XGDS2)
11600        IDIGIT(ICNT)=NUMDIG
11601      ELSE
11602        ICNT=ICNT+1
11603        ITEXT(ICNT)='    Standard Uncertainty (Naive) (k = 1):'
11604        NCTEXT(ICNT)=41
11605        AVALUE(ICNT)=SEGDK1
11606        IDIGIT(ICNT)=NUMDIG
11607        ICNT=ICNT+1
11608        ITEXT(ICNT)='    Expanded Uncertainty (Naive) (k = 2):'
11609        NCTEXT(ICNT)=41
11610        AVALUE(ICNT)=SEGDK2
11611        IDIGIT(ICNT)=NUMDIG
11612      ENDIF
11613      ICNT=ICNT+1
11614      ITEXT(ICNT)='    Lower 95% (Rukhin) Confidence Limit:'
11615      NCTEXT(ICNT)=41
11616      AVALUE(ICNT)=DLOWGD
11617      IDIGIT(ICNT)=NUMDIG
11618      ICNT=ICNT+1
11619      ITEXT(ICNT)='    Upper 95% (Rukhin) Confidence Limit:'
11620      NCTEXT(ICNT)=41
11621      AVALUE(ICNT)=DHIGGD
11622      IDIGIT(ICNT)=NUMDIG
11623      ICNT=ICNT+1
11624      ITEXT(ICNT)='    Note: Graybill-Deal Best Usage:'
11625      NCTEXT(ICNT)=35
11626      AVALUE(ICNT)=0.0
11627      IDIGIT(ICNT)=-1
11628      ICNT=ICNT+1
11629      ITEXT(ICNT)='          Any Number of Labs,'
11630      NCTEXT(ICNT)=29
11631      AVALUE(ICNT)=0.0
11632      IDIGIT(ICNT)=-1
11633      ICNT=ICNT+1
11634      ITEXT(ICNT)='          but no Between Lab Variance'
11635      NCTEXT(ICNT)=37
11636      AVALUE(ICNT)=0.0
11637      IDIGIT(ICNT)=-1
11638C
11639      NUMROW=ICNT
11640      DO310I=1,NUMROW
11641        NTOT(I)=15
11642  310 CONTINUE
11643C
11644      IFRST=.TRUE.
11645      ILAST=.TRUE.
11646      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
11647     1            AVALUE,IDIGIT,
11648     1            NTOT,NUMROW,
11649     1            ICAPSW,ICAPTY,ILAST,IFRST,
11650     1            ISUBRO,IBUGA3,IERROR)
11651      ITITLE=' '
11652      NCTITL=0
11653      ITITLZ=' '
11654      NCTITZ=0
11655      ITITL9=' '
11656      NCTIT9=0
11657C
11658C               *****************
11659C               **  STEP 90--  **
11660C               **  EXIT       **
11661C               *****************
11662C
11663 9000 CONTINUE
11664      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GRAY')THEN
11665        WRITE(ICOUT,999)
11666        CALL DPWRST('XXX','BUG ')
11667        WRITE(ICOUT,9011)
11668 9011   FORMAT('***** AT THE END       OF DPGRAY--')
11669        CALL DPWRST('XXX','BUG ')
11670        WRITE(ICOUT,9012)IERROR
11671 9012   FORMAT('IERROR = ',A4)
11672        CALL DPWRST('XXX','BUG ')
11673        WRITE(ICOUT,9013)NPTS,NLAB
11674 9013   FORMAT('NPTS,NLAB = ',2I8)
11675        CALL DPWRST('XXX','BUG ')
11676        WRITE(ICOUT,9014)XGD,XGDS2
11677 9014   FORMAT('XGD,XGDS2 = ',2G15.7)
11678        CALL DPWRST('XXX','BUG ')
11679        WRITE(ICOUT,9015)DLOWGD,DHIGGD
11680 9015   FORMAT('DLOWGD,DHIGGD = ',2G15.7)
11681        CALL DPWRST('XXX','BUG ')
11682      ENDIF
11683C
11684      RETURN
11685      END
11686      SUBROUTINE DPGRCL(ICOM,IHARG,NUMARG,
11687     1IDEFCO,
11688     1IVGRCO,IHGRCO,
11689     1IFOUND,IERROR)
11690C
11691C     PURPOSE--DEFINE THE 2 GRID COLOR SWITCHES CONTAINED IN THE
11692C              VARIABLES IVGRCO AND IHGRCO.
11693C              SUCH GRID COLOR SWITCHES DEFINE THE COLOR OF
11694C              THE 2 SETS (ONE VERTICAL AND ONE HORIZONTAL)
11695C              OF GRID LINES ON A PLOT.
11696C     INPUT  ARGUMENTS--ICOM
11697C                     --IHARG  (A  HOLLERITH VECTOR)
11698C                     --NUMARG
11699C                     --IDEFCO
11700C     OUTPUT ARGUMENTS--IVGRCO (A HOLLERITH VARIABLE
11701C                       DENOTING THE COLOR OF THE VERTICAL GRID LINES
11702C                     --IHGRCO (A HOLLERITH VARIABLE
11703C                       DENOTING THE COLOR OF THE HORIZONTAL GRID LINES
11704C                     --IFOUND ('YES' OR 'NO' )
11705C                     --IERROR ('YES' OR 'NO' )
11706C     WRITTEN BY--JAMES J. FILLIBEN
11707C                 STATISTICAL ENGINEERING DIVISION
11708C                 INFORMATION TECHNOLOGY LABORATORY
11709C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
11710C                 GAITHERSBURG, MD 20899-8980
11711C                 PHONE--301-975-2855
11712C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
11713C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
11714C     LANGUAGE--ANSI FORTRAN (1977)
11715C     VERSION NUMBER--82/7
11716C     ORIGINAL VERSION--NOVEMBER  1978.
11717C     UPDATED         --SEPTEMBER 1980.
11718C     UPDATED         --MAY       1982.
11719C
11720C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
11721C
11722      CHARACTER*4 ICOM
11723      CHARACTER*4 IHARG
11724      CHARACTER*4 IDEFCO
11725C
11726      CHARACTER*4 IVGRCO
11727      CHARACTER*4 IHGRCO
11728C
11729      CHARACTER*4 IFOUND
11730      CHARACTER*4 IERROR
11731C
11732      CHARACTER*4 IHOLD
11733C
11734C---------------------------------------------------------------------
11735C
11736      DIMENSION IHARG(*)
11737C
11738C---------------------------------------------------------------------
11739C
11740      INCLUDE 'DPCOP2.INC'
11741C
11742C-----START POINT-----------------------------------------------------
11743C
11744      IFOUND='NO'
11745      IERROR='NO'
11746C
11747      IF(NUMARG.LE.0)GOTO1900
11748C
11749C               *****************************************************
11750C               **  TREAT THE CASE WHEN                            **
11751C               **  THE VERTICAL   GRID LINES  ARE TO BE CHANGED   **
11752C               *****************************************************
11753C
11754      IF(ICOM.EQ.'XGRI')GOTO1100
11755      GOTO1199
11756C
11757 1100 CONTINUE
11758      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
11759      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
11760      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
11761      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
11762      IF(IHARG(NUMARG).EQ.'COLO')GOTO1150
11763      GOTO1160
11764C
11765 1150 CONTINUE
11766      IHOLD=IDEFCO
11767      GOTO1180
11768C
11769 1160 CONTINUE
11770      IHOLD=IHARG(NUMARG)
11771      GOTO1180
11772C
11773 1180 CONTINUE
11774      IFOUND='YES'
11775      IVGRCO=IHOLD
11776C
11777      IF(IFEEDB.EQ.'OFF')GOTO1189
11778      WRITE(ICOUT,999)
11779      CALL DPWRST('XXX','BUG ')
11780      WRITE(ICOUT,1181)
11781 1181 FORMAT('THE GRID COLOR (FOR VERTICAL   ',
11782     1'GRID LINES)')
11783      CALL DPWRST('XXX','BUG ')
11784      WRITE(ICOUT,1182)IHOLD
11785 1182 FORMAT('HAS JUST BEEN SET TO ',A4)
11786      CALL DPWRST('XXX','BUG ')
11787 1189 CONTINUE
11788      GOTO1900
11789C
11790 1199 CONTINUE
11791C
11792C               *****************************************************
11793C               **  TREAT THE CASE WHEN                            **
11794C               **  THE HORIZONTAL GRID LINES  ARE TO BE CHANGED   **
11795C               *****************************************************
11796C
11797      IF(ICOM.EQ.'YGRI')GOTO1200
11798      GOTO1299
11799C
11800 1200 CONTINUE
11801      IF(IHARG(NUMARG).EQ.'ON')GOTO1250
11802      IF(IHARG(NUMARG).EQ.'OFF')GOTO1250
11803      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250
11804      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250
11805      IF(IHARG(NUMARG).EQ.'COLO')GOTO1250
11806      GOTO1260
11807C
11808 1250 CONTINUE
11809      IHOLD=IDEFCO
11810      GOTO1280
11811C
11812 1260 CONTINUE
11813      IHOLD=IHARG(NUMARG)
11814      GOTO1280
11815C
11816 1280 CONTINUE
11817      IFOUND='YES'
11818      IHGRCO=IHOLD
11819C
11820      IF(IFEEDB.EQ.'OFF')GOTO1289
11821      WRITE(ICOUT,999)
11822  999 FORMAT(1X)
11823      CALL DPWRST('XXX','BUG ')
11824      WRITE(ICOUT,1281)
11825 1281 FORMAT('THE GRID COLOR (FOR HORIZONTAL ',
11826     1'GRID LINES)')
11827      CALL DPWRST('XXX','BUG ')
11828      WRITE(ICOUT,1282)IHOLD
11829 1282 FORMAT('HAS JUST BEEN SET TO ',A4)
11830      CALL DPWRST('XXX','BUG ')
11831 1289 CONTINUE
11832      GOTO1900
11833C
11834 1299 CONTINUE
11835C
11836C               *******************************************************
11837C               **  TREAT THE CASE WHEN                              **
11838C               **  GRID LINES IN BOTH DIRECTIONS ARE TO BE CHANGED  **
11839C               *******************************************************
11840C
11841      IF(ICOM.EQ.'GRID')GOTO1300
11842      IF(ICOM.EQ.'XYGR')GOTO1300
11843      IF(ICOM.EQ.'YXGR')GOTO1300
11844      GOTO1399
11845C
11846 1300 CONTINUE
11847      IF(IHARG(NUMARG).EQ.'ON')GOTO1350
11848      IF(IHARG(NUMARG).EQ.'OFF')GOTO1350
11849      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350
11850      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350
11851      IF(IHARG(NUMARG).EQ.'COLO')GOTO1350
11852      GOTO1360
11853C
11854 1350 CONTINUE
11855      IHOLD=IDEFCO
11856      GOTO1380
11857C
11858 1360 CONTINUE
11859      IHOLD=IHARG(NUMARG)
11860      GOTO1380
11861C
11862 1380 CONTINUE
11863      IFOUND='YES'
11864      IHGRCO=IHOLD
11865      IVGRCO=IHOLD
11866C
11867      IF(IFEEDB.EQ.'OFF')GOTO1389
11868      WRITE(ICOUT,999)
11869      CALL DPWRST('XXX','BUG ')
11870      WRITE(ICOUT,1381)
11871 1381 FORMAT('THE GRID COLOR (FOR GRID LINES IN ',
11872     1'BOTH DIRECTIONS)')
11873      CALL DPWRST('XXX','BUG ')
11874      WRITE(ICOUT,1382)IHOLD
11875 1382 FORMAT('HAS JUST BEEN SET TO ',A4)
11876      CALL DPWRST('XXX','BUG ')
11877 1389 CONTINUE
11878      GOTO1900
11879C
11880 1399 CONTINUE
11881C
11882 1900 CONTINUE
11883      RETURN
11884      END
11885      SUBROUTINE DPGRID(ICOM,IHARG,NUMARG,IVGRSW,IHGRSW,IFOUND,IERROR)
11886C
11887C     PURPOSE--DEFINE THE 2 GRID SWITCHES CONTAINED IN THE
11888C              VARIABLES IVGRSW AND IHGRSW.
11889C              SUCH GRID SWITCHES TURN ON OR OFF
11890C              THE 2 SETS (ONE VERTICAL AND ONE HORIZONTAL)
11891C              OF GRID LINES ON A PLOT.
11892C     INPUT  ARGUMENTS--ICOM
11893C                     --IHARG  (A  HOLLERITH VECTOR)
11894C                     --NUMARG
11895C     OUTPUT ARGUMENTS--IVGRSW (A HOLLERITH VARIABLE
11896C                       DENOTING WHETHER THE VERTICAL GRID LINES ARE
11897C                       ON    OR    OFF)
11898C                     --IHGRSW (A HOLLERITH VARIABLE
11899C                       DENOTING WHETHER THE HORIZONTAL GRID LINES ARE
11900C                       ON    OR    OFF)
11901C                     --IFOUND ('YES' OR 'NO' )
11902C                     --IERROR ('YES' OR 'NO' )
11903C     WRITTEN BY--JAMES J. FILLIBEN
11904C                 STATISTICAL ENGINEERING DIVISION
11905C                 INFORMATION TECHNOLOGY LABORATORY
11906C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
11907C                 GAITHERSBURG, MD 20899-8980
11908C                 PHONE--301-975-2855
11909C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
11910C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
11911C     LANGUAGE--ANSI FORTRAN (1977)
11912C     VERSION NUMBER--82/7
11913C     ORIGINAL VERSION--NOVEMBER  1978.
11914C     UPDATED         --SEPTEMBER 1980.
11915C     UPDATED         --MAY       1982.
11916C
11917C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
11918C
11919      CHARACTER*4 ICOM
11920      CHARACTER*4 IHARG
11921C
11922      CHARACTER*4 IVGRSW
11923      CHARACTER*4 IHGRSW
11924C
11925      CHARACTER*4 IFOUND
11926      CHARACTER*4 IERROR
11927C
11928C---------------------------------------------------------------------
11929C
11930      DIMENSION IHARG(*)
11931C
11932C---------------------------------------------------------------------
11933C
11934      INCLUDE 'DPCOP2.INC'
11935C
11936C-----START POINT-----------------------------------------------------
11937C
11938      IFOUND='NO'
11939      IERROR='NO'
11940C
11941C               *******************************************
11942C               **  TREAT THE CASE WHEN                  **
11943C               **  THE VERTICAL GRID LINES ARE DEFINED  **
11944C               *******************************************
11945C
11946      IF(ICOM.EQ.'XGRI')GOTO1100
11947      GOTO1199
11948C
11949 1100 CONTINUE
11950      IF(NUMARG.LE.0)GOTO1110
11951      IF(IHARG(1).EQ.'ON')GOTO1110
11952      IF(IHARG(1).EQ.'OFF')GOTO1120
11953      IF(IHARG(1).EQ.'AUTO')GOTO1110
11954      IF(IHARG(1).EQ.'DEFA')GOTO1120
11955      IERROR='YES'
11956      GOTO1900
11957C
11958 1110 CONTINUE
11959      IFOUND='YES'
11960      IVGRSW='ON'
11961C
11962      IF(IFEEDB.EQ.'OFF')GOTO1119
11963      WRITE(ICOUT,999)
11964  999 FORMAT(1X)
11965      CALL DPWRST('XXX','BUG ')
11966      WRITE(ICOUT,1115)
11967 1115 FORMAT('THE XGRID SWITCH (FOR VERTICAL GRID LINES)')
11968      CALL DPWRST('XXX','BUG ')
11969      WRITE(ICOUT,1116)
11970 1116 FORMAT('HAS JUST BEEN TURNED ON')
11971      CALL DPWRST('XXX','BUG ')
11972 1119 CONTINUE
11973      GOTO1900
11974C
11975 1120 CONTINUE
11976      IFOUND='YES'
11977      IVGRSW='OFF'
11978C
11979      IF(IFEEDB.EQ.'OFF')GOTO1129
11980      WRITE(ICOUT,999)
11981      CALL DPWRST('XXX','BUG ')
11982      WRITE(ICOUT,1125)
11983 1125 FORMAT('THE XGRID SWITCH (FOR VERTICAL GRID LINES)')
11984      CALL DPWRST('XXX','BUG ')
11985      WRITE(ICOUT,1126)
11986 1126 FORMAT('HAS JUST BEEN TURNED OFF')
11987      CALL DPWRST('XXX','BUG ')
11988 1129 CONTINUE
11989      GOTO1900
11990C
11991 1199 CONTINUE
11992C
11993C               *********************************************
11994C               **  TREAT THE CASE WHEN                    **
11995C               **  THE HORIZONTAL GRID LINES ARE DEFINED  **
11996C               *********************************************
11997C
11998      IF(ICOM.EQ.'YGRI')GOTO1200
11999      GOTO1299
12000C
12001 1200 CONTINUE
12002      IF(NUMARG.LE.0)GOTO1210
12003      IF(IHARG(1).EQ.'ON')GOTO1210
12004      IF(IHARG(1).EQ.'OFF')GOTO1220
12005      IF(IHARG(1).EQ.'AUTO')GOTO1210
12006      IF(IHARG(1).EQ.'DEFA')GOTO1220
12007      IERROR='YES'
12008      GOTO1900
12009C
12010 1210 CONTINUE
12011      IFOUND='YES'
12012      IHGRSW='ON'
12013C
12014      IF(IFEEDB.EQ.'OFF')GOTO1219
12015      WRITE(ICOUT,999)
12016      CALL DPWRST('XXX','BUG ')
12017      WRITE(ICOUT,1215)
12018 1215 FORMAT('THE YGRID SWITCH (FOR HORIZONTAL GRID LINES)')
12019      CALL DPWRST('XXX','BUG ')
12020      WRITE(ICOUT,1216)
12021 1216 FORMAT('HAS JUST BEEN TURNED ON')
12022      CALL DPWRST('XXX','BUG ')
12023 1219 CONTINUE
12024      GOTO1900
12025C
12026 1220 CONTINUE
12027      IFOUND='YES'
12028      IHGRSW='OFF'
12029C
12030      IF(IFEEDB.EQ.'OFF')GOTO1229
12031      WRITE(ICOUT,999)
12032      CALL DPWRST('XXX','BUG ')
12033      WRITE(ICOUT,1225)
12034 1225 FORMAT('THE YGRID SWITCH (FOR HORIZONTAL GRID LINES)')
12035      CALL DPWRST('XXX','BUG ')
12036      WRITE(ICOUT,1226)
12037 1226 FORMAT('HAS JUST BEEN TURNED OFF')
12038      CALL DPWRST('XXX','BUG ')
12039 1229 CONTINUE
12040      GOTO1900
12041C
12042 1299 CONTINUE
12043C
12044C               ***********************************
12045C               **  TREAT THE CASE WHEN          **
12046C               **  BOTH GRID LINES ARE DEFINED  **
12047C               ***********************************
12048C
12049      IF(ICOM.EQ.'XYGR')GOTO1300
12050      IF(ICOM.EQ.'YXGR')GOTO1300
12051      IF(ICOM.EQ.'GRID')GOTO1300
12052      IFOUND='NO'
12053      GOTO1900
12054C
12055 1300 CONTINUE
12056      IF(NUMARG.LE.0)GOTO1310
12057      IF(IHARG(1).EQ.'ON')GOTO1310
12058      IF(IHARG(1).EQ.'OFF')GOTO1320
12059      IF(IHARG(1).EQ.'AUTO')GOTO1310
12060      IF(IHARG(1).EQ.'DEFA')GOTO1320
12061      IERROR='YES'
12062      GOTO1399
12063C
12064 1310 CONTINUE
12065      IFOUND='YES'
12066      IVGRSW='ON'
12067      IHGRSW='ON'
12068C
12069      IF(IFEEDB.EQ.'OFF')GOTO1319
12070      WRITE(ICOUT,999)
12071      CALL DPWRST('XXX','BUG ')
12072      WRITE(ICOUT,1315)
12073 1315 FORMAT('THE GRID SWITCH (FOR BOTH HORIZONTAL AND VERTICAL ',
12074     1'GRID LINES)')
12075      CALL DPWRST('XXX','BUG ')
12076      WRITE(ICOUT,1316)
12077 1316 FORMAT('HAS JUST BEEN TURNED ON')
12078      CALL DPWRST('XXX','BUG ')
12079 1319 CONTINUE
12080      GOTO1900
12081C
12082 1320 CONTINUE
12083      IFOUND='YES'
12084      IVGRSW='OFF'
12085      IHGRSW='OFF'
12086C
12087      IF(IFEEDB.EQ.'OFF')GOTO1329
12088      WRITE(ICOUT,999)
12089      CALL DPWRST('XXX','BUG ')
12090      WRITE(ICOUT,1325)
12091 1325 FORMAT('THE GRID SWITCH (FOR BOTH HORIZONTAL AND VERTICAL ',
12092     1'GRID LINES)')
12093      CALL DPWRST('XXX','BUG ')
12094      WRITE(ICOUT,1326)
12095 1326 FORMAT('HAS JUST BEEN TURNED OFF')
12096      CALL DPWRST('XXX','BUG ')
12097 1329 CONTINUE
12098      GOTO1900
12099C
12100 1399 CONTINUE
12101C
12102 1900 CONTINUE
12103      RETURN
12104      END
12105      SUBROUTINE DPGRMN(ICOM,IHARG,NUMARG,IVGMSW,IHGMSW,IFOUND,IERROR)
12106C
12107C     PURPOSE--DEFINE THE 2 MINOR GRID SWITCHES CONTAINED IN THE
12108C              VARIABLES IVGMSW AND IHGMSW.
12109C              SUCH MINOR GRID SWITCHES TURN ON OR OFF
12110C              THE 2 SETS (ONE VERTICAL AND ONE HORIZONTAL)
12111C              OF GRID LINES (AT THE MINOR TIC MARKS) ON A PLOT.
12112C     INPUT  ARGUMENTS--ICOM
12113C                     --IHARG  (A  HOLLERITH VECTOR)
12114C                     --NUMARG
12115C     OUTPUT ARGUMENTS--IVGMSW (A HOLLERITH VARIABLE
12116C                       DENOTING WHETHER THE VERTICAL GRID LINES ARE
12117C                       ON    OR    OFF)
12118C                     --IHGMSW (A HOLLERITH VARIABLE
12119C                       DENOTING WHETHER THE HORIZONTAL GRID LINES ARE
12120C                       ON    OR    OFF)
12121C                     --IFOUND ('YES' OR 'NO' )
12122C                     --IERROR ('YES' OR 'NO' )
12123C     WRITTEN BY--JAMES J. FILLIBEN
12124C                 STATISTICAL ENGINEERING DIVISION
12125C                 INFORMATION TECHNOLOGY LABORATORY
12126C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
12127C                 GAITHERSBURG, MD 20899-8980
12128C                 PHONE--301-975-2855
12129C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
12130C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
12131C     LANGUAGE--ANSI FORTRAN (1977)
12132C     VERSION NUMBER--87/6
12133C     ORIGINAL VERSION--NOVEMBER  1978.
12134C     UPDATED         --SEPTEMBER 1980.
12135C     UPDATED         --MAY       1982.
12136C     UPDATED         --JUNE      1987.
12137C
12138C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
12139C
12140      CHARACTER*4 ICOM
12141      CHARACTER*4 IHARG
12142C
12143      CHARACTER*4 IVGMSW
12144      CHARACTER*4 IHGMSW
12145C
12146      CHARACTER*4 IFOUND
12147      CHARACTER*4 IERROR
12148C
12149      CHARACTER*4 ISUBN1
12150      CHARACTER*4 ISUBN2
12151C
12152C---------------------------------------------------------------------
12153C
12154      DIMENSION IHARG(*)
12155C
12156C---------------------------------------------------------------------
12157C
12158      INCLUDE 'DPCOP2.INC'
12159C
12160C-----START POINT-----------------------------------------------------
12161C
12162      IFOUND='NO'
12163      IERROR='NO'
12164      ISUBN1='DPGR'
12165      ISUBN2='MN  '
12166C
12167C               *******************************************
12168C               **  TREAT THE CASE WHEN                  **
12169C               **  THE VERTICAL GRID LINES ARE DEFINED  **
12170C               *******************************************
12171C
12172      IF(ICOM.EQ.'XGMI')GOTO1100
12173      IF(ICOM.EQ.'MINO'.AND.
12174     1NUMARG.GE.1.AND.IHARG(1).EQ.'XGRI')GOTO1105
12175      GOTO1199
12176C
12177 1100 CONTINUE
12178      IF(NUMARG.LE.0)GOTO1110
12179      IF(IHARG(1).EQ.'ON')GOTO1110
12180      IF(IHARG(1).EQ.'OFF')GOTO1120
12181      IF(IHARG(1).EQ.'AUTO')GOTO1110
12182      IF(IHARG(1).EQ.'DEFA')GOTO1120
12183      IERROR='YES'
12184      GOTO1900
12185C
12186 1105 CONTINUE
12187      IF(NUMARG.LE.1)GOTO1110
12188      IF(IHARG(2).EQ.'ON')GOTO1110
12189      IF(IHARG(2).EQ.'OFF')GOTO1120
12190      IF(IHARG(2).EQ.'AUTO')GOTO1110
12191      IF(IHARG(2).EQ.'DEFA')GOTO1120
12192      IERROR='YES'
12193      GOTO1900
12194C
12195 1110 CONTINUE
12196      IFOUND='YES'
12197      IVGMSW='ON'
12198C
12199      IF(IFEEDB.EQ.'OFF')GOTO1119
12200      WRITE(ICOUT,999)
12201  999 FORMAT(1X)
12202      CALL DPWRST('XXX','BUG ')
12203      WRITE(ICOUT,1115)
12204 1115 FORMAT('THE MINOR XGRID SWITCH (FOR VERTICAL GRID LINES')
12205      CALL DPWRST('XXX','BUG ')
12206      WRITE(ICOUT,1116)
12207 1116 FORMAT('AT MINOR TICS) HAS JUST BEEN TURNED ON')
12208      CALL DPWRST('XXX','BUG ')
12209 1119 CONTINUE
12210      GOTO1900
12211C
12212 1120 CONTINUE
12213      IFOUND='YES'
12214      IVGMSW='OFF'
12215C
12216      IF(IFEEDB.EQ.'OFF')GOTO1129
12217      WRITE(ICOUT,999)
12218      CALL DPWRST('XXX','BUG ')
12219      WRITE(ICOUT,1125)
12220 1125 FORMAT('THE MINOR XGRID SWITCH (FOR VERTICAL GRID LINES')
12221      CALL DPWRST('XXX','BUG ')
12222      WRITE(ICOUT,1126)
12223 1126 FORMAT('AT MINOR TICS) HAS JUST BEEN TURNED OFF')
12224      CALL DPWRST('XXX','BUG ')
12225 1129 CONTINUE
12226      GOTO1900
12227C
12228 1199 CONTINUE
12229C
12230C               *********************************************
12231C               **  TREAT THE CASE WHEN                    **
12232C               **  THE HORIZONTAL GRID LINES ARE DEFINED  **
12233C               *********************************************
12234C
12235      IF(ICOM.EQ.'YGMI')GOTO1200
12236      IF(ICOM.EQ.'MINO'.AND.
12237     1NUMARG.GE.1.AND.IHARG(1).EQ.'YGRI')GOTO1205
12238      GOTO1299
12239C
12240 1200 CONTINUE
12241      IF(NUMARG.LE.0)GOTO1210
12242      IF(IHARG(1).EQ.'ON')GOTO1210
12243      IF(IHARG(1).EQ.'OFF')GOTO1220
12244      IF(IHARG(1).EQ.'AUTO')GOTO1210
12245      IF(IHARG(1).EQ.'DEFA')GOTO1220
12246      IERROR='YES'
12247      GOTO1900
12248C
12249 1205 CONTINUE
12250      IF(NUMARG.LE.1)GOTO1210
12251      IF(IHARG(2).EQ.'ON')GOTO1210
12252      IF(IHARG(2).EQ.'OFF')GOTO1220
12253      IF(IHARG(2).EQ.'AUTO')GOTO1210
12254      IF(IHARG(2).EQ.'DEFA')GOTO1220
12255      IERROR='YES'
12256      GOTO1900
12257C
12258 1210 CONTINUE
12259      IFOUND='YES'
12260      IHGMSW='ON'
12261C
12262      IF(IFEEDB.EQ.'OFF')GOTO1219
12263      WRITE(ICOUT,999)
12264      CALL DPWRST('XXX','BUG ')
12265      WRITE(ICOUT,1215)
12266 1215 FORMAT('THE MINOR YGRID SWITCH (FOR HORIZONTAL GRID LINES')
12267      CALL DPWRST('XXX','BUG ')
12268      WRITE(ICOUT,1216)
12269 1216 FORMAT('AT MINOR TICS) HAS JUST BEEN TURNED ON')
12270      CALL DPWRST('XXX','BUG ')
12271 1219 CONTINUE
12272      GOTO1900
12273C
12274 1220 CONTINUE
12275      IFOUND='YES'
12276      IHGMSW='OFF'
12277C
12278      IF(IFEEDB.EQ.'OFF')GOTO1229
12279      WRITE(ICOUT,999)
12280      CALL DPWRST('XXX','BUG ')
12281      WRITE(ICOUT,1225)
12282 1225 FORMAT('THE MINOR YGRID SWITCH (FOR HORIZONTAL GRID LINES')
12283      CALL DPWRST('XXX','BUG ')
12284      WRITE(ICOUT,1226)
12285 1226 FORMAT('AT MINOR TICS) HAS JUST BEEN TURNED OFF')
12286      CALL DPWRST('XXX','BUG ')
12287 1229 CONTINUE
12288      GOTO1900
12289C
12290 1299 CONTINUE
12291C
12292C               ***********************************
12293C               **  TREAT THE CASE WHEN          **
12294C               **  BOTH GRID LINES ARE DEFINED  **
12295C               ***********************************
12296C
12297      IF(ICOM.EQ.'XYGM')GOTO1300
12298      IF(ICOM.EQ.'YXGM')GOTO1300
12299      IF(ICOM.EQ.'GMIN')GOTO1300
12300      IF(ICOM.EQ.'MINO'.AND.
12301     1NUMARG.GE.1.AND.IHARG(1).EQ.'XYGR')GOTO1305
12302      IF(ICOM.EQ.'MINO'.AND.
12303     1NUMARG.GE.1.AND.IHARG(1).EQ.'YXGR')GOTO1305
12304      IF(ICOM.EQ.'MINO'.AND.
12305     1NUMARG.GE.1.AND.IHARG(1).EQ.'GRID')GOTO1305
12306      IFOUND='NO'
12307      GOTO1900
12308C
12309 1300 CONTINUE
12310      IF(NUMARG.LE.0)GOTO1310
12311      IF(IHARG(1).EQ.'ON')GOTO1310
12312      IF(IHARG(1).EQ.'OFF')GOTO1320
12313      IF(IHARG(1).EQ.'AUTO')GOTO1310
12314      IF(IHARG(1).EQ.'DEFA')GOTO1320
12315      IERROR='YES'
12316      GOTO1399
12317C
12318 1305 CONTINUE
12319      IF(NUMARG.LE.1)GOTO1310
12320      IF(IHARG(2).EQ.'ON')GOTO1310
12321      IF(IHARG(2).EQ.'OFF')GOTO1320
12322      IF(IHARG(2).EQ.'AUTO')GOTO1310
12323      IF(IHARG(2).EQ.'DEFA')GOTO1320
12324      IERROR='YES'
12325      GOTO1399
12326C
12327 1310 CONTINUE
12328      IFOUND='YES'
12329      IVGMSW='ON'
12330      IHGMSW='ON'
12331C
12332      IF(IFEEDB.EQ.'OFF')GOTO1319
12333      WRITE(ICOUT,999)
12334      CALL DPWRST('XXX','BUG ')
12335      WRITE(ICOUT,1315)
12336 1315 FORMAT('THE MINOR XYGRID SWITCH (FOR BOTH HORIZ. AND VERT. ',
12337     1'GRID LINES AT MINOR TICS)')
12338      CALL DPWRST('XXX','BUG ')
12339      WRITE(ICOUT,1316)
12340 1316 FORMAT('HAS JUST BEEN TURNED ON')
12341      CALL DPWRST('XXX','BUG ')
12342 1319 CONTINUE
12343      GOTO1900
12344C
12345 1320 CONTINUE
12346      IFOUND='YES'
12347      IVGMSW='OFF'
12348      IHGMSW='OFF'
12349C
12350      IF(IFEEDB.EQ.'OFF')GOTO1329
12351      WRITE(ICOUT,999)
12352      CALL DPWRST('XXX','BUG ')
12353      WRITE(ICOUT,1325)
12354 1325 FORMAT('THE MINOR XYGRID SWITCH (FOR BOTH HORIZ. AND VERT. ',
12355     1'GRID LINE AT MINOR TICS)')
12356      CALL DPWRST('XXX','BUG ')
12357      WRITE(ICOUT,1326)
12358 1326 FORMAT('HAS JUST BEEN TURNED OFF')
12359      CALL DPWRST('XXX','BUG ')
12360 1329 CONTINUE
12361      GOTO1900
12362C
12363 1399 CONTINUE
12364C
12365 1900 CONTINUE
12366      RETURN
12367      END
12368      SUBROUTINE DPGROL(IWRITE,IBUGA3,ISUBRO,IERROR)
12369C
12370C     PURPOSE--THIS SUBROUTINE READS THE CHARCTER DATA STORED IN
12371C              FILE "DPZCHF.DAT" AND STORES IT IN A GROUP LABEL.
12372C              EXAMPLE:
12373C
12374C                 LET GRPLAB = GROUP LABEL IX
12375C
12376C              IN ADDITION, SUPPORT THE FOLLOWING:
12377C
12378C                 LET GRPLAB = GROUP LABEL ST1 ST2 ...
12379C
12380C              WITH ST1, ST2, ... DENOTING PREVIOUSLY DEFINED
12381C              STRINGS.  THE "TO" SYNTAX IS SUPPORTED FOR THIS
12382C              CASE (E.G., ST1 TO ST10).
12383C
12384C                 LET GRPLAB = GROUP LABEL "label 1"  "label 2" ...
12385C
12386C              I.E., YOU CAN SPECIFY A NUMBER OF LITERAL STRINGS.
12387C              NOTE THAT THESE TWO FORMATS CANNOT BE MIXED (I.E.,
12388C              YOU CAN EITHER SPECIFY A LIST OF PREVIOUSLY DEFINED
12389C              STRING NAMES OR A LIST OF LITERAL STRINGS (ENCLOSED
12390C              IN QUOTES), BUT NOT BOTH TOGETHER.
12391C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
12392C     RESTRICTIONS--THE MAXIMUM NUMBER OF ROWS FOR A GROUP LABEL IS
12393C                   MAXOBV/100.
12394C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
12395C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
12396C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
12397C     LANGUAGE--ANSI FORTRAN (1977)
12398C     REFERENCES--NONE.
12399C     WRITTEN BY--JAMES J. FILLIBEN
12400C                 STATISTICAL ENGINEERING DIVISION
12401C                 INFORMATION TECHNOLOGY LABORATORY
12402C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
12403C                 GAITHERSBURG, MD 20899-8980
12404C                 PHONE--301-975-2899
12405C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
12406C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
12407C     LANGUAGE--ANSI FORTRAN (1977)
12408C     VERSION NUMBER--2004/1
12409C     ORIGINAL VERSION--JANUARY   2004.
12410C     UPDATED         --JANUARY   2006. CREATE GROUP LABELS FROM
12411C                                       PREVIOUSLY DEFINED STRINGS
12412C
12413C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
12414C
12415      CHARACTER*4 IWRITE
12416      CHARACTER*4 IBUGA3
12417      CHARACTER*4 ISUBRO
12418      CHARACTER*4 IERROR
12419C
12420      CHARACTER*4 ISTEPN
12421      CHARACTER*4 ISUBN1
12422      CHARACTER*4 ISUBN2
12423      CHARACTER*4 IFOUND
12424      CHARACTER*4 MESSAG
12425      CHARACTER*4 IH
12426      CHARACTER*4 IH2
12427      CHARACTER*4 IHLEFT
12428      CHARACTER*4 IHLEF2
12429      CHARACTER*4 IHRIGH
12430      CHARACTER*4 IHRIG2
12431C
12432C---------------------------------------------------------------------
12433C
12434      INCLUDE 'DPCOPA.INC'
12435      INCLUDE 'DPCODA.INC'
12436      INCLUDE 'DPCOHK.INC'
12437      INCLUDE 'DPCOF2.INC'
12438C
12439CCCCC CHARACTER*80 IFILE
12440      CHARACTER (LEN=MAXFNC) :: IFILE
12441      CHARACTER*12 ISTAT
12442      CHARACTER*12 IFORM
12443      CHARACTER*12 IACCES
12444      CHARACTER*12 IPROT
12445      CHARACTER*12 ICURST
12446      CHARACTER*4 IENDFI
12447      CHARACTER*4 IREWIN
12448      CHARACTER*4 ISUBN0
12449      CHARACTER*4 IERRFI
12450C
12451      CHARACTER*500 IATEMP
12452      CHARACTER*6 IFRMT
12453      CHARACTER*4 IHTEMP(200)
12454      CHARACTER*130 ISTRIN
12455      CHARACTER*130 ISTRI2
12456C
12457      PARAMETER(MAXIND=100)
12458C
12459      CHARACTER*4 ISTRN1(MAXIND)
12460      CHARACTER*4 ISTRN2(MAXIND)
12461C
12462C---------------------------------------------------------------------
12463C
12464      INCLUDE 'DPCOP2.INC'
12465C
12466C-----START POINT-----------------------------------------------------
12467C
12468      ISUBN1='DPGR'
12469      ISUBN2='OL  '
12470      IERROR='NO'
12471C
12472      IOPFLG=0
12473C
12474      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GROL')THEN
12475        WRITE(ICOUT,999)
12476  999   FORMAT(1X)
12477        CALL DPWRST('XXX','BUG ')
12478        WRITE(ICOUT,51)
12479   51   FORMAT('***** AT THE BEGINNING OF DPGROL--')
12480        CALL DPWRST('XXX','BUG ')
12481        WRITE(ICOUT,53)IBUGA3,MAXGRP,MAXGLA
12482   53   FORMAT('IBUGA3,MAXGRP,MAXGLA = ',A4,2X,2I6)
12483        CALL DPWRST('XXX','BUG ')
12484      ENDIF
12485C
12486C               **************************************************
12487C               **  STEP 1--                                     *
12488C               **  DETERMINE IF ANY MORE GROUP LABEL VARIABLES  *
12489C               **  ARE AVAILABLE (DETERMINED BY MAXGRP).        *
12490C               **  FIRST CHECK IF NAME IS ALREADY DEFINED GROUP *
12491C               **  LABEL (OVERWRITE IF IT IS).                  *
12492C               **************************************************
12493C
12494      ISTEPN='1'
12495      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GROL')
12496     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12497C
12498      IHLEFT=IHARG(1)
12499      IHLEF2=IHARG2(1)
12500C
12501C  DETERMINE IF NAME OF GROUP LABEL ALREADY DEFINED
12502C
12503      DO1005I=1,MAXGRP
12504        IF(IGRPVN(I)(1:4).EQ.IHLEFT .AND.
12505     1     IGRPVN(I)(5:8).EQ.IHLEF2)THEN
12506          IGRP=I
12507          IGRPVN(IGRP)(1:4)=IHLEFT
12508          IGRPVN(IGRP)(5:8)=IHLEF2
12509          DO1008J=1,MAXGLA
12510            IGRPLA(J,I)=' '
12511 1008     CONTINUE
12512          GOTO1099
12513        ENDIF
12514 1005 CONTINUE
12515C
12516      ISTEPN='1B'
12517      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GROL')
12518     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12519C
12520C  CREATE A NEW NAME
12521C
12522      DO1010I=1,MAXGRP
12523        IF(IGRPVN(I)(1:8).EQ.'        ')THEN
12524          IGRP=I
12525          IGRPVN(IGRP)(1:4)=IHLEFT
12526          IGRPVN(IGRP)(5:8)=IHLEF2
12527          GOTO1099
12528        ENDIF
12529 1010 CONTINUE
12530      WRITE(ICOUT,999)
12531      CALL DPWRST('XXX','BUG ')
12532      WRITE(ICOUT,1011)
12533 1011 FORMAT('***** ERROR IN LET .. = GROUP LABELS ...')
12534      CALL DPWRST('XXX','BUG ')
12535      WRITE(ICOUT,1013)MAXGRP
12536 1013 FORMAT('      MAXIMUM NUMBER OF GROUP LABEL VARIABLES (',I6,
12537     1       ') EXCEEDED.')
12538      CALL DPWRST('XXX','BUG ')
12539      WRITE(ICOUT,1015)
12540 1015 FORMAT('      NO GROUP LABELS ASSIGNED.')
12541      CALL DPWRST('XXX','BUG ')
12542      IERROR='YES'
12543      GOTO9000
12544C
12545 1099 CONTINUE
12546C
12547      ISTEPN='1C'
12548      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GROL')
12549     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12550C
12551C
12552C               ********************************************
12553C               **  STEP 2--                              **
12554C               **  OPEN THE DPZCHF.DAT FILE.             **
12555C               ********************************************
12556C
12557      ISTEPN='2'
12558      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GROL')
12559     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12560C
12561      IHRIGH=IHARG(5)
12562      IHRIG2=IHARG2(5)
12563C
12564      IOUNIT=IZCHNU
12565      IFILE=IZCHNA
12566      ISTAT=IZCHST
12567      IFORM=IZCHFO
12568      IACCES=IZCHAC
12569      IPROT=IZCHPR
12570      ICURST=IZCHCS
12571C
12572      ISUBN0='READ'
12573      IERRFI='NO'
12574      CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,
12575     1            ICURST,
12576     1            IREWIN,ISUBN0,IERRFI,IBUGA3,ISUBRO,IERROR)
12577      IOPFLG=1
12578      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GROL')THEN
12579        WRITE(ICOUT,1091)
12580 1091   FORMAT('THE dpzchf.tex FILE OPENED.')
12581        CALL DPWRST('XXX','BUG ')
12582      ENDIF
12583      IF(IERRFI.EQ.'YES')GOTO4000
12584C
12585CCCCC IF(IERRFI.EQ.'YES')THEN
12586CCCCC   IERROR='YES'
12587CCCCC   WRITE(ICOUT,999)
12588CCCCC   CALL DPWRST('XXX','BUG ')
12589CCCCC   WRITE(ICOUT,1011)
12590CCCCC   CALL DPWRST('XXX','BUG ')
12591CCCCC   WRITE(ICOUT,1018)
12592C1018   FORMAT('      UNABLE TO OPEN THE CHARACTER DATA FILE:')
12593CCCCC   CALL DPWRST('XXX','BUG ')
12594CCCCC   WRITE(ICOUT,1019)IFILE
12595C1019   FORMAT('      ',A80)
12596CCCCC   CALL DPWRST('XXX','BUG ')
12597CCCCC   GOTO8000
12598CCCCC ENDIF
12599C
12600      READ(IOUNIT,'(I8)',END=4000,ERR=4000)NUMVAR
12601      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GROL')THEN
12602        WRITE(ICOUT,1093)NUMVAR
12603 1093   FORMAT('NUMVAR = ',I8)
12604        CALL DPWRST('XXX','BUG ')
12605      ENDIF
12606C
12607C     2011/10: NEED TO READ ALL NUMVAR LINES EVEN IF FOUND
12608C              TO GET TO DATA LINES
12609C
12610      IFOUND='NO'
12611      DO1130I=1,NUMVAR
12612        READ(IOUNIT,'(A4,A4)',END=4000,ERR=4000)IH,IH2
12613        IF(IHRIGH.EQ.IH .AND. IHRIG2.EQ.IH2)THEN
12614          IVAR=I
12615          IFOUND='YES'
12616CCCCC     GOTO1199
12617        ENDIF
12618 1130 CONTINUE
12619      IF(IFOUND.EQ.'YES')GOTO1199
12620C
12621C  1/2006: IF VARIABLE NOT FOUND, THEN
12622C          1) SEE IF IT IS A PREVIOUSLY DEFINED STRING
12623C          2) IF NOT A PREVIOUSLY DEFINED CHARACTER VARIABLE
12624C             OR A PREVIOUSLY DEFINED STRING, THEN TREAT AS
12625C             A LITERAL STRING
12626C
12627      GOTO4000
12628C
12629CCCCC WRITE(ICOUT,999)
12630CCCCC CALL DPWRST('XXX','BUG ')
12631CCCCC WRITE(ICOUT,1011)
12632CCCCC CALL DPWRST('XXX','BUG ')
12633CCCCC WRITE(ICOUT,131)IHRIGH,IHRIG2
12634CC131 FORMAT('***** VARIABLE ',A4,A4,' NOT FOUND IN THE CHARACTER ',
12635CCCCC1       'DATA FILE:')
12636CCCCC CALL DPWRST('XXX','BUG ')
12637CCCCC WRITE(ICOUT,119)IFILE
12638CCCCC CALL DPWRST('XXX','BUG ')
12639CCCCC IERROR='YES'
12640CCCCC GOTO8000
12641C
12642CC171 CONTINUE
12643CCCCC WRITE(ICOUT,999)
12644CCCCC CALL DPWRST('XXX','BUG ')
12645CCCCC WRITE(ICOUT,111)
12646CCCCC CALL DPWRST('XXX','BUG ')
12647CCCCC WRITE(ICOUT,173)
12648CC173 FORMAT('      ERROR READING THE NUMBER OF CHARACTER VARIABLES ',
12649CCCCC1       'IN THE CHARACTER DATA FILE:')
12650CCCCC CALL DPWRST('XXX','BUG ')
12651CCCCC WRITE(ICOUT,119)IFILE
12652CCCCC CALL DPWRST('XXX','BUG ')
12653CCCCC IERROR='YES'
12654CCCCC GOTO8000
12655C
12656CC181 CONTINUE
12657CCCCC WRITE(ICOUT,999)
12658CCCCC CALL DPWRST('XXX','BUG ')
12659CCCCC WRITE(ICOUT,111)
12660CCCCC CALL DPWRST('XXX','BUG ')
12661CCCCC WRITE(ICOUT,183)
12662CC183 FORMAT('      ERROR READING THE VARIABLE NAMES ',
12663CCCCC1       'IN THE CHARACTER DATA FILE:')
12664CCCCC CALL DPWRST('XXX','BUG ')
12665CCCCC WRITE(ICOUT,119)IFILE
12666CCCCC CALL DPWRST('XXX','BUG ')
12667CCCCC IERROR='YES'
12668CCCCC GOTO8000
12669C
12670 1199 CONTINUE
12671      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GROL')THEN
12672        WRITE(ICOUT,1193)IVAR
12673 1193   FORMAT('IVAR = ',I8)
12674        CALL DPWRST('XXX','BUG ')
12675      ENDIF
12676C
12677C               *************************************************
12678C               **  STEP 3--                                   **
12679C               **  DEFINE THE GRPOUP LABELS.                  **
12680C               **  STORE UNIQUE VALUES IN IGRPLA.             **
12681C               *************************************************
12682C
12683C  1/2006: THIS IS CASE WHERE WE READ GROUP LABELS FROM
12684C          CHARACTER DATA FILE (DPZCHF.DAT).
12685C
12686      ISTEPN='3'
12687      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GROL')
12688     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12689C
12690      IATEMP=' '
12691      IFRMT='(A   )'
12692      WRITE(IFRMT(3:5),'(I3)')25*IVAR
12693      N=1
12694      IROW=1
12695      READ(IOUNIT,IFRMT,END=2491,ERR=2491)IATEMP
12696      IFRST=(IVAR-1)*25 + 1
12697      ILAST=IVAR*25 - 1
12698      IGRPLA(1,IGRP)=' '
12699      IGRPLA(1,IGRP)=IATEMP(IFRST:ILAST)
12700C
12701      DO2210I=2,MAXOBV
12702        IROW=I
12703        IATEMP=' '
12704        READ(IOUNIT,IFRMT,END=2499,ERR=2491)IATEMP
12705        DO2220J=1,N
12706          IF(IATEMP(IFRST:ILAST).EQ.IGRPLA(J,IGRP)(1:24))GOTO2210
12707 2220   CONTINUE
12708        N=N+1
12709C
12710        IF(N.GT.MAXGLA)THEN
12711          WRITE(ICOUT,999)
12712          CALL DPWRST('XXX','BUG ')
12713          WRITE(ICOUT,2261)
12714 2261     FORMAT('***** WARNING IN LET ... = GROUP LABELS ...')
12715          CALL DPWRST('XXX','BUG ')
12716          WRITE(ICOUT,2263)MAXGLA
12717 2263     FORMAT('      MAXIMUM NUMBER OF ROWS FOR GROUP LABELS (',
12718     1           I6,') ','EXCEEDED.')
12719          CALL DPWRST('XXX','BUG ')
12720          WRITE(ICOUT,2265)
12721 2265     FORMAT('      NO ADDITIONAL GROUP LABELS ASSIGNED.')
12722          CALL DPWRST('XXX','BUG ')
12723          GOTO8000
12724        ENDIF
12725C
12726        IGRPLA(N,IGRP)=' '
12727        IGRPLA(N,IGRP)=IATEMP(IFRST:ILAST)
12728 2210 CONTINUE
12729      GOTO2499
12730C
12731 2491 CONTINUE
12732      WRITE(ICOUT,999)
12733      CALL DPWRST('XXX','BUG ')
12734      WRITE(ICOUT,1011)
12735      CALL DPWRST('XXX','BUG ')
12736      WRITE(ICOUT,2493)IROW
12737 2493 FORMAT('      ERROR READING ROW ',I8,' OF THE CHARACTER ',
12738     1       'VARIABLES IN THE CHARACTER DATA FILE:')
12739      CALL DPWRST('XXX','BUG ')
12740      WRITE(ICOUT,2495)IFILE
12741 2495 FORMAT('      ',A80)
12742      CALL DPWRST('XXX','BUG ')
12743      IERROR='YES'
12744      GOTO8000
12745C
12746C               *************************************************
12747C               **  STEP 4--                                   **
12748C               **  DETERMINE IF VARIABLE IS A PREVIOUSLY      **
12749C               **  DEFINED STRING.  IF NOT, TREAT AS A        **
12750C               **  LITERAL STRING.                            **
12751C               *************************************************
12752C
12753C  1/2006: THIS IS CASE WHERE WE READ GROUP LABELS FROM
12754C
12755 4000 CONTINUE
12756      ISTEPN='4'
12757      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GROL')
12758     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12759C
12760      JMIN=5
12761      JMAX=NUMARG
12762C
12763      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GROL')THEN
12764        WRITE(ICOUT,4001)JMIN,JMAX,MAXIND
12765 4001   FORMAT('JMIN,JMAX,MAXIND = ',3I8)
12766        CALL DPWRST('XXX','BUG ')
12767      ENDIF
12768C
12769      IF(JMAX.LT.JMIN)GOTO8000
12770      IWRITE='OFF'
12771      IERROR='NO'
12772C
12773      CALL EXTSTR(IHARG,IHARG2,NUMARG,JMIN,JMAX,MAXIND,
12774     1IHNAME,IHNAM2,IUSE,NUMNAM,
12775     1ISTRN1,ISTRN2,NUMSTR,
12776     1IWRITE,IBUGA3,ISUBRO,IERROR)
12777C
12778      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GROL')THEN
12779        WRITE(ICOUT,4003)NUMSTR
12780 4003   FORMAT('NUMSTR = ',I8)
12781        CALL DPWRST('XXX','BUG ')
12782      ENDIF
12783C
12784      IF(IERROR.EQ.'NO')THEN
12785C
12786C  CASE WHERE WE ARE EXTRACTING STRINGS
12787C
12788        NUMSTR=MIN(NUMSTR,MAXGLA)
12789        N=NUMSTR
12790        DO4005I=1,MAXGLA
12791          IGRPLA(I,IGRP)=' '
12792 4005   CONTINUE
12793C
12794        DO4010I2=1,NUMSTR
12795          DO4015I=1,NUMNAM
12796            II=I
12797            IF(ISTRN1(I2).EQ.IHNAME(I) .AND. ISTRN2(I2).EQ.IHNAM2(I))
12798     1        GOTO4019
12799 4015     CONTINUE
12800C
12801          WRITE(ICOUT,999)
12802          CALL DPWRST('XXX','BUG ')
12803          WRITE(ICOUT,4021)
12804 4021     FORMAT('****** ERROR FROM DPGROL--')
12805          CALL DPWRST('XXX','BUG ')
12806          WRITE(ICOUT,4023)ISTRN1(I2),ISTRN2(I2)
12807 4023     FORMAT('       STRING ',A4,A4,' NOT MATCHED IN NAME ',
12808     1           'TABLE.')
12809          CALL DPWRST('XXX','BUG ')
12810          IERROR='YES'
12811          GOTO8000
12812C
12813 4019     CONTINUE
12814          IVAL=IVALUE(II)
12815          VAL=VALUE(II)
12816          IL1=IVSTAR(II)
12817          IL2=IVSTOP(II)
12818C
12819          IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GROL')THEN
12820            WRITE(ICOUT,4011)IL1,IL2
12821 4011       FORMAT('II,IL1,IL2 = ',3I8)
12822            CALL DPWRST('XXX','BUG ')
12823          ENDIF
12824C
12825          CALL DPCOFH(IL1,IL2,IFUNC,NUMCHF,IHTEMP,NH,IBUGA3,IERROR)
12826CCCCC     ILAST=MIN(24,NH)
12827          ILAST=MIN(MAXGR2,NH)
12828C
12829          IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GROL')THEN
12830            WRITE(ICOUT,4013)NH,ILAST
12831 4013       FORMAT('NH,ILAST = ',2I8)
12832            CALL DPWRST('XXX','BUG ')
12833          ENDIF
12834C
12835          IF(ILAST.GT.0)THEN
12836            DO4020J=1,ILAST
12837              IGRPLA(I2,IGRP)(J:J)=IHTEMP(J)(1:1)
12838 4020       CONTINUE
12839            IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GROL')THEN
12840              WRITE(ICOUT,4014)I2,IGRPLA(I2,IGRP)
12841 4014         FORMAT('I2,IGRPLA(I2,IGRP) = ',I8,A24)
12842              CALL DPWRST('XXX','BUG ')
12843            ENDIF
12844          ENDIF
12845 4010   CONTINUE
12846      ELSE
12847C
12848C  CASE WHERE WE ARE EXTRACTING LITERALS
12849C
12850        ICNT=0
12851        IFRST=5
12852        MESSAG='OFF'
12853        DO4105I=1,MAXGLA
12854          IGRPLA(I,IGRP)=' '
12855 4105   CONTINUE
12856        DO4108I=1,130
12857          ISTRIN(I:I)=IANSLC(I)(1:1)
12858 4108   CONTINUE
12859C
12860 4100   CONTINUE
12861          IFRST=IFRST+1
12862          ICNT=ICNT+1
12863          ISTART=1
12864          ISTOP=130
12865          IERROR='NO'
12866          ICOL1=1
12867          ICOL2=130
12868          NCOLMX=130
12869          CALL DPEXS1(ISTRIN,NCOLMX,ISTART,ISTOP,IFRST,MESSAG,
12870     1                ICOL1,ICOL2,ISTRI2,NCSTR2,
12871     1                IBUGA3,ISUBRO,IERROR)
12872          IF(NCSTR2.GT.0 .AND. IERROR.NE.'YES')THEN
12873CCCCC       ILAST=MIN(24,NCSTR2)
12874            ILAST=MIN(MAXGR2,NCSTR2)
12875            DO4120J=1,ILAST
12876              IGRPLA(ICNT,IGRP)(J:J)=ISTRI2(J:J)
12877 4120       CONTINUE
12878            GOTO4100
12879          ENDIF
12880          N=ICNT-1
12881      ENDIF
12882C
12883      GOTO2499
12884C
12885C               ******************************
12886C               **  STEP 3--                **
12887C               **  WRITE OUT A FEW LINES   **
12888C               **  OF SUMMARY INFORMATION  **
12889C               **  ABOUT THE CODING.       **
12890C               ******************************
12891C
12892 2499 CONTINUE
12893C
12894      IF(IFEEDB.EQ.'ON')THEN
12895        WRITE(ICOUT,999)
12896        CALL DPWRST('XXX','BUG ')
12897        WRITE(ICOUT,2811)N
12898 2811   FORMAT('NUMBER OF DISTINCT FACTORS DETECTED = ',I8)
12899        CALL DPWRST('XXX','BUG ')
12900        WRITE(ICOUT,999)
12901        CALL DPWRST('XXX','BUG ')
12902        IF(N.GT.1)THEN
12903          WRITE(ICOUT,2821)MIN(N,20)
12904 2821     FORMAT('THE FIRST ',I4,' GROUP LABELS:')
12905          CALL DPWRST('XXX','BUG ')
12906          DO2820I=1,MIN(N,20)
12907            WRITE(ICOUT,2822)I,IGRPLA(I,IGRP)
12908 2822       FORMAT('GROUP LABEL ',I2,' IS: ',A24)
12909            CALL DPWRST('XXX','BUG ')
12910 2820     CONTINUE
12911        ENDIF
12912      ENDIF
12913      GOTO8000
12914C
12915C               ***************************************
12916C               **  STEP 88--                        **
12917C               **  CLOSE THE DPZCHF.DAT FILE.       **
12918C               ***************************************
12919C
12920 8000 CONTINUE
12921C
12922      IF(IOPFLG.EQ.1)THEN
12923        IENDFI='OFF'
12924        IREWIN='ON'
12925        CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
12926     1              IENDFI,IREWIN,ISUBN0,IERRFI,IBUGA3,ISUBRO,IERROR)
12927        IZCHCS='CLOSED'
12928      ENDIF
12929      GOTO9000
12930C
12931C               *****************
12932C               **  STEP 90--  **
12933C               **  EXIT.      **
12934C               *****************
12935C
12936 9000 CONTINUE
12937C
12938      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GROL')THEN
12939        WRITE(ICOUT,999)
12940        CALL DPWRST('XXX','BUG ')
12941        WRITE(ICOUT,9011)
12942 9011   FORMAT('***** AT THE END OF DPGROL--')
12943        CALL DPWRST('XXX','BUG ')
12944        WRITE(ICOUT,9012)IBUGA3,IERROR
12945 9012   FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
12946        CALL DPWRST('XXX','BUG ')
12947        WRITE(ICOUT,9013)N,IGRP
12948 9013   FORMAT('N,IIGRP = ',2I8)
12949        CALL DPWRST('XXX','BUG ')
12950        IF(N.GT.0)THEN
12951          DO9015I=1,N
12952            WRITE(ICOUT,9016)I,IGRPLA(I,IGRP)(1:24)
12953 9016       FORMAT('I,IGRPLA(I,IGRP) = ',I8,A24)
12954            CALL DPWRST('XXX','BUG ')
12955 9015     CONTINUE
12956        ENDIF
12957      ENDIF
12958C
12959      RETURN
12960      END
12961      SUBROUTINE DPGRO2(X1,Y1,X2,Y2,
12962     1IFIG,
12963     1ILINPA,ILINCO,PLINTH,
12964     1AREGBA,
12965     1IREBLI,IREBCO,PREBTH,
12966     1IREFSW,IREFCO,
12967     1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
12968     1PTEXHE,PTEXWI,PTEXVG,PTEXHG)
12969C
12970C     PURPOSE--DRAW A  GROUND
12971C              WITH THE TOP AT (X1,Y1)
12972C              AND THE BOTTOM AT (X2,Y2).
12973C     WRITTEN BY--JAMES J. FILLIBEN
12974C                 STATISTICAL ENGINEERING DIVISION
12975C                 INFORMATION TECHNOLOGY LABORATORY
12976C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
12977C                 GAITHERSBURG, MD 20899-8980
12978C                 PHONE--301-975-2855
12979C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
12980C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
12981C     LANGUAGE--ANSI FORTRAN (1977)
12982C     VERSION NUMBER--82/7
12983C     ORIGINAL VERSION--APRIL     1981.
12984C     UPDATED         --MAY       1982.
12985C     UPDATED         --JANUARY   1989.  CALL TO DPDRPL (ALAN)
12986C
12987C-----NON-COMMON VARIABLES-------------------------------------
12988C
12989      CHARACTER*4 IFIG
12990C
12991      CHARACTER*4 ILINPA
12992      CHARACTER*4 ILINCO
12993C
12994      CHARACTER*4 IREBLI
12995      CHARACTER*4 IREBCO
12996      CHARACTER*4 IREFSW
12997      CHARACTER*4 IREFCO
12998      CHARACTER*4 IREPTY
12999      CHARACTER*4 IREPLI
13000      CHARACTER*4 IREPCO
13001C
13002      CHARACTER*4 IPATT
13003CCCCC CHARACTER*4 ICOLF
13004CCCCC CHARACTER*4 ICOLP
13005      CHARACTER*4 ICOL
13006      CHARACTER*4 IFLAG
13007C
13008      DIMENSION PX(10)
13009      DIMENSION PY(10)
13010CCCCC DIMENSION PX3(10)
13011CCCCC DIMENSION PY3(10)
13012C
13013      DIMENSION ILINPA(*)
13014      DIMENSION ILINCO(*)
13015      DIMENSION PLINTH(*)
13016C
13017      DIMENSION AREGBA(*)
13018      DIMENSION IREBLI(*)
13019      DIMENSION IREBCO(*)
13020      DIMENSION PREBTH(*)
13021      DIMENSION IREFSW(*)
13022      DIMENSION IREFCO(*)
13023      DIMENSION IREPTY(*)
13024      DIMENSION IREPLI(*)
13025      DIMENSION IREPCO(*)
13026      DIMENSION PREPTH(*)
13027      DIMENSION PREPSP(*)
13028C
13029C-----COMMON----------------------------------------------------------
13030C
13031      INCLUDE 'DPCOGR.INC'
13032      INCLUDE 'DPCOBE.INC'
13033      INCLUDE 'DPCOP2.INC'
13034C
13035C-----START POINT-----------------------------------------------------
13036C
13037      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'GRO2')GOTO90
13038      WRITE(ICOUT,999)
13039  999 FORMAT(1X)
13040      CALL DPWRST('XXX','BUG ')
13041      WRITE(ICOUT,51)
13042   51 FORMAT('***** AT THE BEGINNING OF DPGRO2--')
13043      CALL DPWRST('XXX','BUG ')
13044      WRITE(ICOUT,53)X1,Y1
13045   53 FORMAT('X1,Y1 = ',2E15.7)
13046      CALL DPWRST('XXX','BUG ')
13047      WRITE(ICOUT,54)X2,Y2
13048   54 FORMAT('X2,Y2 = ',2E15.7)
13049      CALL DPWRST('XXX','BUG ')
13050      WRITE(ICOUT,59)IFIG
13051   59 FORMAT('IFIG = ',A4)
13052      CALL DPWRST('XXX','BUG ')
13053      WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1)
13054   61 FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',A4,2X,A4,E15.7)
13055      CALL DPWRST('XXX','BUG ')
13056      WRITE(ICOUT,62)AREGBA(1)
13057   62 FORMAT('AREGBA(1) = ',E15.7)
13058      CALL DPWRST('XXX','BUG ')
13059      WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1)
13060   63 FORMAT('IREBLI(1),IREBCO(1),PREBTH(1) = ',A4,2X,A4,E15.7)
13061      CALL DPWRST('XXX','BUG ')
13062      WRITE(ICOUT,64)IREFSW(1),IREFCO(1)
13063   64 FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4)
13064      CALL DPWRST('XXX','BUG ')
13065      WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1)
13066   65 FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ',
13067     1A4,2X,A4,2X,A4,2E15.7)
13068      CALL DPWRST('XXX','BUG ')
13069      WRITE(ICOUT,69)PTEXHE,PTEXWI
13070   69 FORMAT('PTEXHE,PTEXWI= ',2E15.7)
13071      CALL DPWRST('XXX','BUG ')
13072      WRITE(ICOUT,70)PTEXVG,PTEXHG
13073   70 FORMAT('PTEXVG,PTEXHG= ',2E15.6)
13074      CALL DPWRST('XXX','BUG ')
13075      WRITE(ICOUT,79)IBUGG4,ISUBG4,IERRG4
13076   79 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
13077      CALL DPWRST('XXX','BUG ')
13078   90 CONTINUE
13079C
13080C               *********************************
13081C               **  STEP 1--                   **
13082C               **  DETERMINE THE COORDINATES  **
13083C               **  FOR THE GROUND             **
13084C               *********************************
13085C
13086      DELX=X2-X1
13087      DELY=Y2-Y1
13088      LEN=INT(SQRT((X2-X1)**2+(Y2-Y1)**2) + 0.1)
13089      ALEN=REAL(LEN)
13090      IF(ABS(DELX).GE.0.00001)THETA=ATAN(DELY/DELX)
13091      IF(ABS(DELX).LT.0.00001.AND.DELY.GE.0.0)THETA=3.1415926/2.0
13092      IF(ABS(DELX).LT.0.00001.AND.DELY.LT.0.0)THETA=-3.1415926/2.0
13093C
13094      K=0
13095C
13096      X=0
13097      Y=0
13098      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
13099      K=K+1
13100      PX(K)=XP
13101      PY(K)=YP
13102C
13103      X=ALEN
13104      Y=0
13105      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
13106      K=K+1
13107      PX(K)=XP
13108      PY(K)=YP
13109C
13110      NP=K
13111C
13112      IPATT=ILINPA(1)
13113      PTHICK=PLINTH(1)
13114      ICOL=ILINCO(1)
13115      IFLAG='ON'
13116CCCCC CALL DPDRPL(PX,PY,NP,PX3,PY3,NP3,
13117CCCCC1IFIG,IPATT,PTHICK,ICOL)
13118      CALL DPDRPL(PX,PY,NP,
13119     1IFIG,IPATT,PTHICK,ICOL,
13120     1JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
13121C
13122      K=0
13123C
13124      X=ALEN/3.0
13125      Y=ALEN/2.0
13126      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
13127      K=K+1
13128      PX(K)=XP
13129      PY(K)=YP
13130C
13131      X=ALEN/3.0
13132      Y=-ALEN/2.0
13133      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
13134      K=K+1
13135      PX(K)=XP
13136      PY(K)=YP
13137C
13138      NP=K
13139C
13140      IFLAG='ON'
13141CCCCC CALL DPDRPL(PX,PY,NP,PX3,PY3,NP3,
13142CCCCC1IFIG,IPATT,PTHICK,ICOL)
13143      CALL DPDRPL(PX,PY,NP,
13144     1IFIG,IPATT,PTHICK,ICOL,
13145     1JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
13146C
13147      K=0
13148C
13149      X=ALEN*(2.0/3.0)
13150      Y=ALEN/4.0
13151      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
13152      K=K+1
13153      PX(K)=XP
13154      PY(K)=YP
13155C
13156      X=ALEN*(2.0/3.0)
13157      Y=-ALEN/4.0
13158      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
13159      K=K+1
13160      PX(K)=XP
13161      PY(K)=YP
13162C
13163      NP=K
13164C
13165      IFLAG='ON'
13166      CALL DPDRPL(PX,PY,NP,
13167     1            IFIG,IPATT,PTHICK,ICOL,
13168     1            JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
13169C
13170C               *****************
13171C               **  STEP 90--  **
13172C               **  EXIT       **
13173C               *****************
13174C
13175      IF(IBUGG4.EQ.'ON' .OR. ISUBG4.EQ.'GRO2')THEN
13176        WRITE(ICOUT,999)
13177        CALL DPWRST('XXX','BUG ')
13178        WRITE(ICOUT,9011)
13179 9011   FORMAT('***** AT THE END       OF DPGRO2--')
13180        CALL DPWRST('XXX','BUG ')
13181        DO9015I=1,NP
13182          WRITE(ICOUT,9016)I,PX(I),PY(I)
13183 9016     FORMAT('I,PX(I),PY(I) = ',I8,2G15.7)
13184          CALL DPWRST('XXX','BUG ')
13185 9015   CONTINUE
13186        WRITE(ICOUT,9039)IERRG4
13187 9039   FORMAT('IERRG4 = ',A4)
13188        CALL DPWRST('XXX','BUG ')
13189      ENDIF
13190C
13191      RETURN
13192      END
13193      SUBROUTINE DPGROU(IHARG,IARGT,ARG,NUMARG,
13194     1                  PXSTAR,PYSTAR,PXEND,PYEND,
13195     1                  ILINPA,ILINCO,PLINTH,
13196     1                  AREGBA,IREBLI,IREBCO,PREBTH,
13197     1                  IREFSW,IREFCO,
13198     1                  IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
13199     1                  PTEXHE,PTEXWI,PTEXVG,PTEXHG,
13200     1                  IGRASW,IDIASW,
13201     1                  PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
13202     1                  PDIAHE,PDIAWI,PDIAVG,PDIAHG,
13203     1                  NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
13204     1                  IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
13205     1                  IDNVOF,IDNHOF,IDFONT,UNITSW,PDSCAL,
13206     1                  IBUGD2,IFOUND,IERROR)
13207C
13208C     PURPOSE--DRAW ONE OR MORE GROUNDS (DEPENDING ON HOW MANY NUMBERS ARE
13209C              PROVIDED).  THE COORDINATES ARE IN STANDARDIZED UNITS
13210C              OF 0 TO 100.
13211C     NOTE--THE INPUT COORDINATES DEFINE THE TOP AND THE BOTTOM TIP
13212C           OF THE GROUND.
13213C     NOTE-THE USUAL INPUT NUMBER OF COORDINATES IS 2
13214C          AND THEREFORE THE USUAL INPUT NUMBER OF NUMBERS IS 2*2 = 4.
13215C     NOTE--IF 2 NUMBERS ARE PROVIDED, THEN THE DRAWN GROUND WILL GO FROM THE
13216C           LAST CURSOR POSITION TO THE (X,Y) POINT (EITHER ABSOLUTE OR
13217C           RELATIVE) AS DEFINED BY THE 2 NUMBERS.
13218C     NOTE--IF 4 NUMBERS ARE PROVIDED, THEN THE DRAWN GROUND WILL GO FROM THE
13219C           ABSOLUTE (X,Y) POSITION AS DEFINED BY THE FIRST 2 NUMBERS TO THE
13220C           (X,Y) POINT (EITHER ABSOLUTE OR RELATIVE) AS DEFINED BY THE THIRD
13221C           AND FOURTH NUMBERS.
13222C     NOTE--IF 6 NUMBERS ARE PROVIDED, THEN THE DRAWN GROUND WILL GO FROM THE
13223C           (X,Y) POSITION AS RESULTING FROM THE THIRD AND FOURTH NUMBERS TO
13224C           THE (X,Y) POINT (EITHER ABSOLUTE OR RELATIVE)
13225C           AS DEFINED BY THE FIFTH AND SIXTH NUMBERS.
13226C     NOTE--AND SO FORTH FOR 8, 10, 12, ... NUMBERS.
13227C     INPUT  ARGUMENTS--IHARG
13228C                     --IARGT
13229C                     --ARG
13230C                     --NUMARG
13231C                     --PXSTAR
13232C                     --PYSTAR
13233C     OUTPUT ARGUMENTS--PXEND
13234C                     --PYEND
13235C                     --IFOUND ('YES' OR 'NO' )
13236C                     --IERROR ('YES' OR 'NO' )
13237C     WRITTEN BY--JAMES J. FILLIBEN
13238C                 STATISTICAL ENGINEERING DIVISION
13239C                 INFORMATION TECHNOLOGY LABORATORY
13240C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
13241C                 GAITHERSBURG, MD 20899-8980
13242C                 PHONE--301-975-2855
13243C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
13244C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
13245C     LANGUAGE--ANSI FORTRAN (1977)
13246C     VERSION NUMBER--82/7
13247C     ORIGINAL VERSION--APRIL     1981.
13248C     UPDATED         --MARCH     1982.
13249C     UPDATED         --MAY       1982.
13250C     UPDATED         --NOVEMBER  1982.
13251C     UPDATED         --JANUARY   1989. CALL LIST FOR OFFSET VAR (ALAN)
13252C     UPDATED         --MARCH     1997. SUPPORT FOR DEVICE FONT (ALAN)
13253C     UPDATED         --JULY      1997. SUPPORT FOR "DATA" UNITS (ALAN)
13254C     UPDATED         --DECEMBER  2018. CHECK FOR DISCRETE, NULL, OR
13255C                                       NONE DEVICE
13256C     UPDATED         --DECEMBER  2018. SUPPORT FOR "DEVICE ... SCALE"
13257C                                       COMMAND
13258C
13259C-----NON-COMMON VARIABLES-----------------------------------------
13260C
13261      CHARACTER*4 IHARG
13262      CHARACTER*4 IARGT
13263C
13264      CHARACTER*4 ILINPA
13265      CHARACTER*4 ILINCO
13266C
13267      CHARACTER*4 IREBLI
13268      CHARACTER*4 IREBCO
13269      CHARACTER*4 IREFSW
13270      CHARACTER*4 IREFCO
13271      CHARACTER*4 IREPTY
13272      CHARACTER*4 IREPLI
13273      CHARACTER*4 IREPCO
13274C
13275      CHARACTER*4 IGRASW
13276      CHARACTER*4 IDIASW
13277C
13278      CHARACTER*4 IDMANU
13279      CHARACTER*4 IDMODE
13280      CHARACTER*4 IDMOD2
13281      CHARACTER*4 IDMOD3
13282      CHARACTER*4 IDPOWE
13283      CHARACTER*4 IDCONT
13284      CHARACTER*4 IDCOLO
13285CCCCC ADD FOLLOWING LINE MARCH 1997.
13286      CHARACTER*4 IDFONT
13287CCCCC ADD FOLLOWING LINE JULY 1997.
13288      CHARACTER*4 UNITSW
13289C
13290      CHARACTER*4 IFOUND
13291      CHARACTER*4 IBUGD2
13292      CHARACTER*4 IERROR
13293      CHARACTER*4 ISUBRO
13294C
13295      CHARACTER*4 IFIG
13296      CHARACTER*4 IBELSW
13297      CHARACTER*4 IERASW
13298      CHARACTER*4 IBACCO
13299      CHARACTER*4 ICOPSW
13300      CHARACTER*4 ITYPEO
13301C
13302      DIMENSION IHARG(*)
13303      DIMENSION IARGT(*)
13304      DIMENSION ARG(*)
13305C
13306      DIMENSION ILINPA(*)
13307      DIMENSION ILINCO(*)
13308      DIMENSION PLINTH(*)
13309C
13310      DIMENSION AREGBA(*)
13311      DIMENSION IREBLI(*)
13312      DIMENSION IREBCO(*)
13313      DIMENSION PREBTH(*)
13314      DIMENSION IREFSW(*)
13315      DIMENSION IREFCO(*)
13316      DIMENSION IREPTY(*)
13317      DIMENSION IREPLI(*)
13318      DIMENSION IREPCO(*)
13319      DIMENSION PREPTH(*)
13320      DIMENSION PREPSP(*)
13321      DIMENSION PDSCAL(*)
13322C
13323      DIMENSION IDMANU(*)
13324      DIMENSION IDMODE(*)
13325      DIMENSION IDMOD2(*)
13326      DIMENSION IDMOD3(*)
13327      DIMENSION IDPOWE(*)
13328      DIMENSION IDCONT(*)
13329CCCCC ADD FOLLOWING LINE MARCH 1997.
13330      DIMENSION IDFONT(*)
13331      DIMENSION IDCOLO(*)
13332      DIMENSION IDNVPP(*)
13333      DIMENSION IDNHPP(*)
13334      DIMENSION IDUNIT(*)
13335C
13336      DIMENSION IDNVOF(*)
13337      DIMENSION IDNHOF(*)
13338C
13339C-----COMMON----------------------------------------------------------
13340C
13341      INCLUDE 'DPCOGR.INC'
13342      INCLUDE 'DPCOBE.INC'
13343      INCLUDE 'DPCOP2.INC'
13344C
13345C-----START POINT-----------------------------------------------------
13346C
13347      IFOUND='NO'
13348      IERROR='NO'
13349      IERRG4=IERROR
13350CCCCC IBUGG4=IBUGD2
13351CCCCC ISUBG4=ISUBRO
13352C
13353      ILOCFN=0
13354      NUMNUM=0
13355C
13356      X1=0.0
13357      Y1=0.0
13358      X2=0.0
13359      Y2=0.0
13360C
13361      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'GROU')GOTO90
13362      WRITE(ICOUT,999)
13363  999 FORMAT(1X)
13364      CALL DPWRST('XXX','BUG ')
13365      WRITE(ICOUT,51)
13366   51 FORMAT('***** AT THE BEGINNING OF DPGROU--')
13367      CALL DPWRST('XXX','BUG ')
13368      WRITE(ICOUT,53)NUMARG
13369   53 FORMAT('NUMARG = ',I8)
13370      CALL DPWRST('XXX','BUG ')
13371      DO55I=1,NUMARG
13372      WRITE(ICOUT,56)I,IHARG(I),IARGT(I),ARG(I)
13373   56 FORMAT('I,IHARG(I),IARGT(I),ARG(I) = ',I8,2X,A4,2X,A4,E15.7)
13374      CALL DPWRST('XXX','BUG ')
13375   55 CONTINUE
13376      WRITE(ICOUT,57)PXSTAR,PYSTAR
13377   57 FORMAT('PXSTAR,PYSTAR = ',2E15.7)
13378      CALL DPWRST('XXX','BUG ')
13379      WRITE(ICOUT,58)PXEND,PYEND
13380   58 FORMAT('PXEND,PYEND = ',2E15.7)
13381      CALL DPWRST('XXX','BUG ')
13382      WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1)
13383   61 FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',A4,2X,A4,E15.7)
13384      CALL DPWRST('XXX','BUG ')
13385      WRITE(ICOUT,62)AREGBA(1)
13386   62 FORMAT('AREGBA(1) = ',E15.7)
13387      CALL DPWRST('XXX','BUG ')
13388      WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1)
13389   63 FORMAT('IREBLI(1),IREBCO(1),PREBTH(1) = ',A4,2X,A4,E15.7)
13390      CALL DPWRST('XXX','BUG ')
13391      WRITE(ICOUT,64)IREFSW(1),IREFCO(1)
13392   64 FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4)
13393      CALL DPWRST('XXX','BUG ')
13394      WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1)
13395   65 FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ',
13396     1A4,2X,A4,2X,A4,2E15.7)
13397      CALL DPWRST('XXX','BUG ')
13398      WRITE(ICOUT,69)PTEXHE,PTEXWI
13399   69 FORMAT('PTEXHE,PTEXWI= ',2E15.7)
13400      CALL DPWRST('XXX','BUG ')
13401      WRITE(ICOUT,70)PTEXVG,PTEXHG
13402   70 FORMAT('PTEXVG,PTEXHG= ',2E15.6)
13403      CALL DPWRST('XXX','BUG ')
13404      WRITE(ICOUT,76)IGRASW,IDIASW
13405   76 FORMAT('IGRASW,IDIASW = ',A4,2X,A4)
13406      CALL DPWRST('XXX','BUG ')
13407      WRITE(ICOUT,77)PGRAXF,PGRAYF,PDIAXC,PDIAYC
13408   77 FORMAT('PGRAXF,PGRAYF,PDIAXC,PDIAYC = ',4E15.7)
13409      CALL DPWRST('XXX','BUG ')
13410      WRITE(ICOUT,78)PDIAHE,PDIAWI,PDIAVG,PDIAHG
13411   78 FORMAT('PDIAHE,PDIAWI,PDIAVG,PDIAHG = ',4E15.7)
13412      CALL DPWRST('XXX','BUG ')
13413      WRITE(ICOUT,80)NUMDEV
13414   80 FORMAT('NUMDEV= ',I8)
13415      CALL DPWRST('XXX','BUG ')
13416      DO81I=1,NUMDEV
13417      WRITE(ICOUT,82)IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I)
13418   82 FORMAT('IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I) = ',
13419     1A4,2X,A4,2X,A4,2X,A4)
13420      CALL DPWRST('XXX','BUG ')
13421      WRITE(ICOUT,83)IDPOWE(I),IDCONT(I),IDCOLO(I)
13422   83 FORMAT('IDPOWE(I),IDCONT(I),IDCOLO(I) = ',
13423     1A4,2X,A4,2X,A4)
13424      CALL DPWRST('XXX','BUG ')
13425      WRITE(ICOUT,84)IDNVPP(I),IDNHPP(I),IDUNIT(I)
13426   84 FORMAT('IDNVPP(I),IDNHPP(I),IDUNIT(I) = ',
13427     1I8,I8,I8)
13428      CALL DPWRST('XXX','BUG ')
13429   81 CONTINUE
13430      WRITE(ICOUT,87)IFOUND
13431   87 FORMAT('IFOUND= ',A4)
13432      CALL DPWRST('XXX','BUG ')
13433      WRITE(ICOUT,88)IBUGG4,ISUBG4,IERRG4
13434   88 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
13435      CALL DPWRST('XXX','BUG ')
13436      WRITE(ICOUT,89)IBUGD2,IERROR
13437   89 FORMAT('IBUGD2,IERROR= ',A4,2X,A4)
13438      CALL DPWRST('XXX','BUG ')
13439   90 CONTINUE
13440C
13441      IFIG='GROU'
13442      NUMPT=2
13443      NUMPT2=2*NUMPT
13444C
13445C               ********************************
13446C               **  STEP 0--                  **
13447C               **  STEP THROUGH EACH DEVICE  **
13448C               ********************************
13449C
13450      IF(NUMDEV.LE.0)GOTO9000
13451      DO8000IDEVIC=1,NUMDEV
13452C
13453      IF(IDPOWE(IDEVIC).EQ.'OFF')GOTO8000
13454      IF(IDMANU(IDEVIC).EQ.'OFF')GOTO8000
13455      IF(IDMANU(IDEVIC).EQ.'NULL')GOTO8000
13456      IF(IDMANU(IDEVIC).EQ.'NONE')GOTO8000
13457      IF(IDMANU(IDEVIC).EQ.'DISC')GOTO8000
13458C
13459      IMANUF=IDMANU(IDEVIC)
13460      IMODEL=IDMODE(IDEVIC)
13461      IMODE2=IDMOD2(IDEVIC)
13462      IMODE3=IDMOD3(IDEVIC)
13463      IGCONT=IDCONT(IDEVIC)
13464      IGCOLO=IDCOLO(IDEVIC)
13465      IGFONT=IDFONT(IDEVIC)
13466      NUMVPP=IDNVPP(IDEVIC)
13467      NUMHPP=IDNHPP(IDEVIC)
13468      ANUMVP=NUMVPP
13469      ANUMHP=NUMHPP
13470      IOFFSV=IDNVOF(IDEVIC)
13471      IOFFSH=IDNHOF(IDEVIC)
13472      IGUNIT=IDUNIT(IDEVIC)
13473      PCHSCA=PDSCAL(IDEVIC)
13474C
13475C               ************************************
13476C               **  STEP 1--                      **
13477C               **  CARRY OUT OPENING OPERATIONS  **
13478C               **  ON THE GRAPHICS DEVICES       **
13479C               ************************************
13480C
13481      CALL DPOPDE
13482C
13483      IBELSW='OFF'
13484      NUMRIN=0
13485      IERASW='OFF'
13486      IBACCO='JUNK'
13487C
13488      CALL DPOPPL(IGRASW,
13489     1IBELSW,NUMRIN,IERASW,
13490     1IBACCO)
13491C
13492C               *****************************************
13493C               **  STEP 2--                           **
13494C               **  SEARCH FOR COMMAND SPECIFICATIONS  **
13495C               *****************************************
13496C
13497      IF(NUMARG.GE.2.AND.
13498     1IARGT(1).EQ.'NUMB'.AND.IARGT(2).EQ.'NUMB')
13499     1GOTO1111
13500      IF(NUMARG.GE.3.AND.IHARG(1).EQ.'ABSO'.AND.
13501     1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB')
13502     1GOTO1112
13503      IF(NUMARG.GE.3.AND.IHARG(1).EQ.'RELA'.AND.
13504     1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB')
13505     1GOTO1113
13506      GOTO1130
13507C
13508 1111 CONTINUE
13509      ITYPEO='ABSO'
13510      ILOCFN=1
13511      GOTO1119
13512C
13513 1112 CONTINUE
13514      ITYPEO='ABSO'
13515      ILOCFN=2
13516      GOTO1119
13517C
13518 1113 CONTINUE
13519      ITYPEO='RELA'
13520      ILOCFN=2
13521      GOTO1119
13522 1119 CONTINUE
13523C
13524      IF(ILOCFN.GT.NUMARG)GOTO1129
13525      DO1120I=ILOCFN,NUMARG
13526      IF(IARGT(I).EQ.'NUMB')GOTO1120
13527      GOTO1129
13528 1120 CONTINUE
13529      IFOUND='YES'
13530      GOTO1149
13531 1129 CONTINUE
13532      GOTO1130
13533C
13534 1130 CONTINUE
13535      IERRG4='YES'
13536      WRITE(ICOUT,1131)
13537 1131 FORMAT('***** ERROR IN DPGROU--')
13538      CALL DPWRST('XXX','BUG ')
13539      WRITE(ICOUT,1132)
13540 1132 FORMAT('      ILLEGAL FORM FOR DRAW ',
13541     1'COMMAND.')
13542      CALL DPWRST('XXX','BUG ')
13543      WRITE(ICOUT,1134)
13544 1134 FORMAT('      TEST EXAMPLE TO DEMONSTRATE THE ',
13545     1'PROPER FORM--')
13546      CALL DPWRST('XXX','BUG ')
13547      WRITE(ICOUT,1135)
13548 1135 FORMAT('      SUPPOSE IT IS DESIRED TO DRAW A GROUND ')
13549      CALL DPWRST('XXX','BUG ')
13550      WRITE(ICOUT,1136)
13551 1136 FORMAT('      WITH TOP AT THE POINT 20 20 ')
13552      CALL DPWRST('XXX','BUG ')
13553      WRITE(ICOUT,1137)
13554 1137 FORMAT('      AND WITH THE BOTTOM AT THE POINT 20 15')
13555      CALL DPWRST('XXX','BUG ')
13556      WRITE(ICOUT,1141)
13557 1141 FORMAT('      THEN THE ALLOWABLE FORMS ARE--')
13558      CALL DPWRST('XXX','BUG ')
13559      WRITE(ICOUT,1142)
13560 1142 FORMAT('      GROUND 20 20 20 15 ')
13561      CALL DPWRST('XXX','BUG ')
13562      WRITE(ICOUT,1143)
13563 1143 FORMAT('      GROUND ABSOLUTE 20 20 20 15 ')
13564      CALL DPWRST('XXX','BUG ')
13565      GOTO9000
13566 1149 CONTINUE
13567C
13568C               ****************************
13569C               **  STEP 3--              **
13570C               **  DRAW OUT THE LINE(S)  **
13571C               ****************************
13572C
13573      NUMNUM=NUMARG-ILOCFN+1
13574      IF(NUMNUM.LT.NUMPT2)GOTO1151
13575      GOTO1152
13576C
13577 1151 CONTINUE
13578      J=ILOCFN-1
13579      X1=PXSTAR
13580      Y1=PYSTAR
13581      GOTO1159
13582C
13583 1152 CONTINUE
13584      J=ILOCFN
13585      IF(J.GT.NUMARG)GOTO1190
13586      X1=ARG(J)
13587CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997
13588      IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X1,X1,IBUGD2,ISUBRO,IERROR)
13589      J=J+1
13590      IF(J.GT.NUMARG)GOTO1190
13591      Y1=ARG(J)
13592CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997
13593      IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y1,Y1,IBUGD2,ISUBRO,IERROR)
13594      GOTO1159
13595 1159 CONTINUE
13596C
13597 1160 CONTINUE
13598      J=J+1
13599      IF(J.GT.NUMARG)GOTO1190
13600      X2=ARG(J)
13601CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997
13602      IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X2,X2,IBUGD2,ISUBRO,IERROR)
13603      IF(ITYPEO.EQ.'RELA')X2=X1+X2
13604      J=J+1
13605      IF(J.GT.NUMARG)GOTO1190
13606      Y2=ARG(J)
13607CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997
13608      IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y2,Y2,IBUGD2,ISUBRO,IERROR)
13609      IF(ITYPEO.EQ.'RELA')Y2=Y1+Y2
13610C
13611      CALL DPGRO2(X1,Y1,X2,Y2,
13612     1            IFIG,
13613     1            ILINPA,ILINCO,PLINTH,
13614     1            AREGBA,
13615     1            IREBLI,IREBCO,PREBTH,
13616     1            IREFSW,IREFCO,
13617     1            IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
13618     1            PTEXHE,PTEXWI,PTEXVG,PTEXHG)
13619C
13620      X1=X2
13621      Y1=Y2
13622C
13623      GOTO1160
13624 1190 CONTINUE
13625C
13626      PXEND=X2
13627      PYEND=Y2
13628C
13629C               ************************************
13630C               **  STEP 4--                      **
13631C               **  CARRY OUT CLOSING OPERATIONS  **
13632C               **  ON THE GRAPHICS DEVICES       **
13633C               ************************************
13634C
13635      ICOPSW='OFF'
13636      NUMCOP=0
13637      CALL DPCLPL(ICOPSW,NUMCOP,
13638     1PGRAXF,PGRAYF,
13639     1IGRASW,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
13640     1PDIAHE,PDIAWI,PDIAVG,PDIAHG)
13641C
13642      CALL DPCLDE
13643C
13644 8000 CONTINUE
13645C
13646C               *****************
13647C               **  STEP 90--  **
13648C               **  EXIT       **
13649C               *****************
13650C
13651 9000 CONTINUE
13652      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'GROU')GOTO9090
13653      WRITE(ICOUT,999)
13654      CALL DPWRST('XXX','BUG ')
13655      WRITE(ICOUT,9011)
13656 9011 FORMAT('***** AT THE END       OF DPGROU--')
13657      CALL DPWRST('XXX','BUG ')
13658      WRITE(ICOUT,9012)ILOCFN,NUMNUM
13659 9012 FORMAT('ILOCFN,NUMNUM = ',2I8)
13660      CALL DPWRST('XXX','BUG ')
13661      WRITE(ICOUT,9013)X1,Y1,X2,Y2
13662 9013 FORMAT('X1,Y1,X2,Y2 = ',4E15.7)
13663      CALL DPWRST('XXX','BUG ')
13664      WRITE(ICOUT,9015)PXSTAR,PYSTAR
13665 9015 FORMAT('PXSTAR,PYSTAR = ',2E15.7)
13666      CALL DPWRST('XXX','BUG ')
13667      WRITE(ICOUT,9016)PXEND,PYEND
13668 9016 FORMAT('PXEND,PYEND = ',2E15.7)
13669      CALL DPWRST('XXX','BUG ')
13670      WRITE(ICOUT,9017)IFIG
13671 9017 FORMAT('IFIG = ',A4)
13672      CALL DPWRST('XXX','BUG ')
13673      WRITE(ICOUT,9027)IFOUND
13674 9027 FORMAT('IFOUND = ',A4)
13675      CALL DPWRST('XXX','BUG ')
13676      WRITE(ICOUT,9028)IBUGG4,ISUBG4,IERRG4
13677 9028 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4)
13678      CALL DPWRST('XXX','BUG ')
13679      WRITE(ICOUT,9029)IBUGD2,IERROR
13680 9029 FORMAT('IBUGD2,IERROR = ',A4,2X,A4)
13681      CALL DPWRST('XXX','BUG ')
13682 9090 CONTINUE
13683C
13684      RETURN
13685      END
13686      SUBROUTINE DPGRPA(ICOM,IHARG,IHARG2,NUMARG,
13687CCCCC AUGUST 1995.  ADD IHARG2 FOR DASH2, ETC
13688CCCCC SUBROUTINE DPGRPA(ICOM,IHARG,NUMARG,
13689     1IDEFPA,
13690     1IVGRPA,IHGRPA,
13691     1IFOUND,IERROR)
13692C
13693C     PURPOSE--DEFINE THE 2 GRID PATTERN SWITCHES CONTAINED IN THE
13694C              VARIABLES IVGRPA AND IHGRPA.
13695C              SUCH GRID PATTERN SWITCHES DEFINE THE PATTERN OF
13696C              THE 2 SETS (ONE VERTICAL AND ONE HORIZONTAL)
13697C              OF GRID LINES ON A PLOT.
13698C     INPUT  ARGUMENTS--ICOM
13699C                     --IHARG  (A  HOLLERITH VECTOR)
13700C                     --NUMARG
13701C                     --IDEFPA
13702C     OUTPUT ARGUMENTS--IVGRPA (A HOLLERITH VARIABLE
13703C                       DENOTING THE PATTERN OF THE VERTICAL GRID LINES
13704C                     --IHGRPA (A HOLLERITH VARIABLE
13705C                       DENOTING THE PATTERN OF THE HORIZONTAL GRID LINES
13706C                     --IFOUND ('YES' OR 'NO' )
13707C                     --IERROR ('YES' OR 'NO' )
13708C     WRITTEN BY--JAMES J. FILLIBEN
13709C                 STATISTICAL ENGINEERING DIVISION
13710C                 INFORMATION TECHNOLOGY LABORATORY
13711C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
13712C                 GAITHERSBURG, MD 20899-8980
13713C                 PHONE--301-975-2855
13714C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
13715C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
13716C     LANGUAGE--ANSI FORTRAN (1977)
13717C     VERSION NUMBER--82/7
13718C     ORIGINAL VERSION--NOVEMBER  1978.
13719C     UPDATED         --SEPTEMBER 1980.
13720C     UPDATED         --MAY       1982.
13721C     UPDATED         --AUGUST    1995.  DASH2 BUG
13722C
13723C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
13724C
13725      CHARACTER*4 ICOM
13726      CHARACTER*4 IHARG
13727CCCCC AUGUST 1995.  ADD FOLLOWING LINE
13728      CHARACTER*4 IHARG2
13729      CHARACTER*4 IDEFPA
13730C
13731      CHARACTER*4 IVGRPA
13732      CHARACTER*4 IHGRPA
13733C
13734      CHARACTER*4 IFOUND
13735      CHARACTER*4 IERROR
13736C
13737      CHARACTER*4 IHOLD
13738C
13739C---------------------------------------------------------------------
13740C
13741      DIMENSION IHARG(*)
13742CCCCC AUGUST 1995.  ADD FOLLOWING LINE
13743      DIMENSION IHARG2(*)
13744C
13745C---------------------------------------------------------------------
13746C
13747      INCLUDE 'DPCOP2.INC'
13748C
13749C-----START POINT-----------------------------------------------------
13750C
13751      IFOUND='NO'
13752      IERROR='NO'
13753C
13754      IF(NUMARG.LE.0)GOTO1900
13755C
13756C               *****************************************************
13757C               **  TREAT THE CASE WHEN                            **
13758C               **  THE VERTICAL   GRID LINES  ARE TO BE CHANGED   **
13759C               *****************************************************
13760C
13761      IF(ICOM.EQ.'XGRI')GOTO1100
13762      GOTO1199
13763C
13764 1100 CONTINUE
13765      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
13766      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
13767      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
13768      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
13769      IF(IHARG(NUMARG).EQ.'PATT')GOTO1150
13770      GOTO1160
13771C
13772 1150 CONTINUE
13773      IHOLD=IDEFPA
13774      GOTO1180
13775C
13776 1160 CONTINUE
13777      IHOLD=IHARG(NUMARG)
13778      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'2')IHOLD='DA2'
13779      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'3')IHOLD='DA3'
13780      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'4')IHOLD='DA4'
13781      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'5')IHOLD='DA5'
13782      GOTO1180
13783C
13784 1180 CONTINUE
13785      IFOUND='YES'
13786      IVGRPA=IHOLD
13787C
13788      IF(IFEEDB.EQ.'OFF')GOTO1189
13789      WRITE(ICOUT,999)
13790      CALL DPWRST('XXX','BUG ')
13791      WRITE(ICOUT,1181)
13792 1181 FORMAT('THE GRID PATTERN (FOR VERTICAL   ',
13793     1'GRID LINES)')
13794      CALL DPWRST('XXX','BUG ')
13795      WRITE(ICOUT,1182)IHOLD
13796 1182 FORMAT('HAS JUST BEEN SET TO ',A4)
13797      CALL DPWRST('XXX','BUG ')
13798 1189 CONTINUE
13799      GOTO1900
13800C
13801 1199 CONTINUE
13802C
13803C               *****************************************************
13804C               **  TREAT THE CASE WHEN                            **
13805C               **  THE HORIZONTAL GRID LINES  ARE TO BE CHANGED   **
13806C               *****************************************************
13807C
13808      IF(ICOM.EQ.'YGRI')GOTO1200
13809      GOTO1299
13810C
13811 1200 CONTINUE
13812      IF(IHARG(NUMARG).EQ.'ON')GOTO1250
13813      IF(IHARG(NUMARG).EQ.'OFF')GOTO1250
13814      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250
13815      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250
13816      IF(IHARG(NUMARG).EQ.'PATT')GOTO1250
13817      GOTO1260
13818C
13819 1250 CONTINUE
13820      IHOLD=IDEFPA
13821      GOTO1280
13822C
13823 1260 CONTINUE
13824      IHOLD=IHARG(NUMARG)
13825      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'2')IHOLD='DA2'
13826      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'3')IHOLD='DA3'
13827      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'4')IHOLD='DA4'
13828      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'5')IHOLD='DA5'
13829      GOTO1280
13830C
13831 1280 CONTINUE
13832      IFOUND='YES'
13833      IHGRPA=IHOLD
13834C
13835      IF(IFEEDB.EQ.'OFF')GOTO1289
13836      WRITE(ICOUT,999)
13837  999 FORMAT(1X)
13838      CALL DPWRST('XXX','BUG ')
13839      WRITE(ICOUT,1281)
13840 1281 FORMAT('THE GRID PATTERN (FOR HORIZONTAL ',
13841     1'GRID LINES)')
13842      CALL DPWRST('XXX','BUG ')
13843      WRITE(ICOUT,1282)IHOLD
13844 1282 FORMAT('HAS JUST BEEN SET TO ',A4)
13845      CALL DPWRST('XXX','BUG ')
13846 1289 CONTINUE
13847      GOTO1900
13848C
13849 1299 CONTINUE
13850C
13851C               *******************************************************
13852C               **  TREAT THE CASE WHEN                              **
13853C               **  GRID LINES IN BOTH DIRECTIONS ARE TO BE CHANGED  **
13854C               *******************************************************
13855C
13856      IF(ICOM.EQ.'GRID')GOTO1300
13857      IF(ICOM.EQ.'XYGR')GOTO1300
13858      IF(ICOM.EQ.'YXGR')GOTO1300
13859      GOTO1399
13860C
13861 1300 CONTINUE
13862      IF(IHARG(NUMARG).EQ.'ON')GOTO1350
13863      IF(IHARG(NUMARG).EQ.'OFF')GOTO1350
13864      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350
13865      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350
13866      IF(IHARG(NUMARG).EQ.'PATT')GOTO1350
13867      GOTO1360
13868C
13869 1350 CONTINUE
13870      IHOLD=IDEFPA
13871      GOTO1380
13872C
13873 1360 CONTINUE
13874      IHOLD=IHARG(NUMARG)
13875      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'2')IHOLD='DA2'
13876      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'3')IHOLD='DA3'
13877      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'4')IHOLD='DA4'
13878      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'5')IHOLD='DA5'
13879      GOTO1380
13880C
13881 1380 CONTINUE
13882      IFOUND='YES'
13883      IHGRPA=IHOLD
13884      IVGRPA=IHOLD
13885C
13886      IF(IFEEDB.EQ.'OFF')GOTO1389
13887      WRITE(ICOUT,999)
13888      CALL DPWRST('XXX','BUG ')
13889      WRITE(ICOUT,1381)
13890 1381 FORMAT('THE GRID PATTERN (FOR GRID LINES IN ',
13891     1'BOTH DIRECTIONS)')
13892      CALL DPWRST('XXX','BUG ')
13893      WRITE(ICOUT,1382)IHOLD
13894 1382 FORMAT('HAS JUST BEEN SET TO ',A4)
13895      CALL DPWRST('XXX','BUG ')
13896 1389 CONTINUE
13897      GOTO1900
13898C
13899 1399 CONTINUE
13900C
13901 1900 CONTINUE
13902      RETURN
13903      END
13904      SUBROUTINE DPGRTH(ICOM,IHARG,ARG,NUMARG,
13905     1PDEFTH,
13906     1PVGRTH,PHGRTH,
13907     1IFOUND,IERROR)
13908C
13909C     PURPOSE--DEFINE THE 2 GRID THICKNESS SWITCHES CONTAINED IN THE
13910C              VARIABLES PVGRTH AND PHGRTH.
13911C              SUCH GRID THICKNESS SWITCHES DEFINE THE THICKNESS OF
13912C              THE 2 SETS (ONE VERTICAL AND ONE HORIZONTAL)
13913C              OF GRID LINES ON A PLOT.
13914C     INPUT  ARGUMENTS--ICOM
13915C                     --IHARG  (A  HOLLERITH VECTOR)
13916C                     --ARG    (A REAL VECTOR)
13917C                     --NUMARG
13918C                     --PDEFTH
13919C     OUTPUT ARGUMENTS--PVGRTH (A REAL VARIABLE
13920C                       DENOTING THE THICKNESS OF THE VERTICAL GRID LINES
13921C                     --PHGRTH (A REAL VARIABLE
13922C                       DENOTING THE THICKNESS OF THE HORIZONTAL GRID LINES
13923C                     --IFOUND ('YES' OR 'NO' )
13924C                     --IERROR ('YES' OR 'NO' )
13925C     WRITTEN BY--ALAN HECKERT
13926C                 COMPUTER SERVICES DIVISION
13927C                 INFORMATION TECHNOLOGY LABORATORY
13928C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
13929C                 GAITHERSBURG, MD 20899-8980
13930C                 PHONE--301-975-2899
13931C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
13932C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
13933C     LANGUAGE--ANSI FORTRAN (1977)
13934C     VERSION NUMBER--82/7
13935C     ORIGINAL VERSION--NOVEMBER  1978.
13936C     UPDATED         --SEPTEMBER 1980.
13937C     UPDATED         --MAY       1982.
13938C
13939C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
13940C
13941      CHARACTER*4 ICOM
13942      CHARACTER*4 IHARG
13943      REAL        PDEFTH
13944C
13945      REAL        PVGRTH
13946      REAL        PHGRTH
13947C
13948      CHARACTER*4 IFOUND
13949      CHARACTER*4 IERROR
13950C
13951      REAL        PHOLD
13952C
13953C---------------------------------------------------------------------
13954C
13955      DIMENSION IHARG(*)
13956      DIMENSION ARG(*)
13957C
13958C---------------------------------------------------------------------
13959C
13960      INCLUDE 'DPCOP2.INC'
13961C
13962C-----START POINT-----------------------------------------------------
13963C
13964      IFOUND='NO'
13965      IERROR='NO'
13966C
13967      IF(NUMARG.LE.0)GOTO1900
13968C
13969C               *****************************************************
13970C               **  TREAT THE CASE WHEN                            **
13971C               **  THE VERTICAL   GRID LINES  ARE TO BE CHANGED   **
13972C               *****************************************************
13973C
13974      IF(ICOM.EQ.'XGRI')GOTO1100
13975      GOTO1199
13976C
13977 1100 CONTINUE
13978      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
13979      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
13980      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
13981      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
13982      IF(IHARG(NUMARG).EQ.'THIC')GOTO1150
13983      GOTO1160
13984C
13985 1150 CONTINUE
13986      PHOLD=PDEFTH
13987      GOTO1180
13988C
13989 1160 CONTINUE
13990      PHOLD=ARG(NUMARG)
13991      GOTO1180
13992C
13993 1180 CONTINUE
13994      IFOUND='YES'
13995      PVGRTH=PHOLD
13996C
13997      IF(IFEEDB.EQ.'OFF')GOTO1189
13998      WRITE(ICOUT,999)
13999      CALL DPWRST('XXX','BUG ')
14000      WRITE(ICOUT,1181)
14001 1181 FORMAT('THE GRID THICKNESS (FOR VERTICAL   ',
14002     1'GRID LINES)')
14003      CALL DPWRST('XXX','BUG ')
14004      WRITE(ICOUT,1182)PHOLD
14005 1182 FORMAT('HAS JUST BEEN SET TO ',E15.7)
14006      CALL DPWRST('XXX','BUG ')
14007 1189 CONTINUE
14008      GOTO1900
14009C
14010 1199 CONTINUE
14011C
14012C               *****************************************************
14013C               **  TREAT THE CASE WHEN                            **
14014C               **  THE HORIZONTAL GRID LINES  ARE TO BE CHANGED   **
14015C               *****************************************************
14016C
14017      IF(ICOM.EQ.'YGRI')GOTO1200
14018      GOTO1299
14019C
14020 1200 CONTINUE
14021      IF(IHARG(NUMARG).EQ.'ON')GOTO1250
14022      IF(IHARG(NUMARG).EQ.'OFF')GOTO1250
14023      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250
14024      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250
14025      IF(IHARG(NUMARG).EQ.'THIC')GOTO1250
14026      GOTO1260
14027C
14028 1250 CONTINUE
14029      PHOLD=PDEFTH
14030      GOTO1280
14031C
14032 1260 CONTINUE
14033      PHOLD=ARG(NUMARG)
14034      GOTO1280
14035C
14036 1280 CONTINUE
14037      IFOUND='YES'
14038      PHGRTH=PHOLD
14039C
14040      IF(IFEEDB.EQ.'OFF')GOTO1289
14041      WRITE(ICOUT,999)
14042  999 FORMAT(1X)
14043      CALL DPWRST('XXX','BUG ')
14044      WRITE(ICOUT,1281)
14045 1281 FORMAT('THE GRID THICKNESS (FOR HORIZONTAL ',
14046     1'GRID LINES)')
14047      CALL DPWRST('XXX','BUG ')
14048      WRITE(ICOUT,1282)PHOLD
14049 1282 FORMAT('HAS JUST BEEN SET TO ',E15.7)
14050      CALL DPWRST('XXX','BUG ')
14051 1289 CONTINUE
14052      GOTO1900
14053C
14054 1299 CONTINUE
14055C
14056C               *******************************************************
14057C               **  TREAT THE CASE WHEN                              **
14058C               **  GRID LINES IN BOTH DIRECTIONS ARE TO BE CHANGED  **
14059C               *******************************************************
14060C
14061      IF(ICOM.EQ.'GRID')GOTO1300
14062      IF(ICOM.EQ.'XYGR')GOTO1300
14063      IF(ICOM.EQ.'YXGR')GOTO1300
14064      GOTO1399
14065C
14066 1300 CONTINUE
14067      IF(IHARG(NUMARG).EQ.'ON')GOTO1350
14068      IF(IHARG(NUMARG).EQ.'OFF')GOTO1350
14069      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350
14070      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350
14071      IF(IHARG(NUMARG).EQ.'THIC')GOTO1350
14072      GOTO1360
14073C
14074 1350 CONTINUE
14075      PHOLD=PDEFTH
14076      GOTO1380
14077C
14078 1360 CONTINUE
14079      PHOLD=ARG(NUMARG)
14080      GOTO1380
14081C
14082 1380 CONTINUE
14083      IFOUND='YES'
14084      PHGRTH=PHOLD
14085      PVGRTH=PHOLD
14086C
14087      IF(IFEEDB.EQ.'OFF')GOTO1389
14088      WRITE(ICOUT,999)
14089      CALL DPWRST('XXX','BUG ')
14090      WRITE(ICOUT,1381)
14091 1381 FORMAT('THE GRID THICKNESS (FOR GRID LINES IN ',
14092     1'BOTH DIRECTIONS)')
14093      CALL DPWRST('XXX','BUG ')
14094      WRITE(ICOUT,1382)PHOLD
14095 1382 FORMAT('HAS JUST BEEN SET TO ',E15.7)
14096      CALL DPWRST('XXX','BUG ')
14097 1389 CONTINUE
14098      GOTO1900
14099C
14100 1399 CONTINUE
14101C
14102 1900 CONTINUE
14103      RETURN
14104      END
14105      SUBROUTINE DPGRUB(XTEMP1,MAXNXT,
14106     1                  ICAPSW,ICASAN,IFORSW,
14107     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
14108C
14109C     PURPOSE--PERFORM GRUBS TEST FOR UNIVARIATE OUTLIERS (GRUBBS
14110C              TEST LOOKS FOR A SINGLE OUTLIER AND ASSUMES THE
14111C              DATA FOLLOWS AN APPROXIMATELY NORMAL DISRIBUTION).
14112C     WRITTEN BY--JAMES J. FILLIBEN
14113C                 STATISTICAL ENGINEERING DIVISION
14114C                 INFORMATION TECHNOLOGY LABORAOTRY
14115C                 NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY
14116C                 GAITHERSBURG, MD 20899-8980
14117C                 PHONE--301-975-2855
14118C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
14119C           OF THE NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY.
14120C     LANGUAGE--ANSI FORTRAN (1977)
14121C     VERSION NUMBER--97/9
14122C     ORIGINAL VERSION--SEPTEMBER 1997.
14123C     UPDATED         --JANUARY   2004.
14124C     UPDATED         --FEBRUARY  2006. DISTINCT CASES FOR MINIMUM
14125C                                       AND MAXIMUM
14126C     UPDATED         --JULY      2009. USE DPPARS ROUTINE
14127C     UPATED          --OCTOBER   2009. REWRITTEN TO HANDLE MULTIPLE
14128C                                       RESPONSE VARIABLES, GROUP-ID
14129C                                       VARIABLES, OR A LAB-ID VARIABLE
14130C     UPATED          --JULY      2019. TWEAK SCRATCH STORAGE
14131C     UPATED          --OCTOBER   2019. SUPPORT CASE FOR INDEPENDENT OR
14132C                                       KNOWN STANDARD DEVIATION
14133C
14134C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
14135C
14136      CHARACTER*4 ICASAN
14137      CHARACTER*4 ICAPSW
14138      CHARACTER*4 IFORSW
14139      CHARACTER*4 IBUGA2
14140      CHARACTER*4 IBUGA3
14141      CHARACTER*4 IBUGQ
14142      CHARACTER*4 ISUBRO
14143      CHARACTER*4 IFOUND
14144      CHARACTER*4 IERROR
14145C
14146      CHARACTER*4 IWRITE
14147      CHARACTER*4 ICASP2
14148      CHARACTER*4 IDATSW
14149      CHARACTER*4 ISUBN1
14150      CHARACTER*4 ISUBN2
14151      CHARACTER*4 ISTEPN
14152      CHARACTER*4 IFLAGU
14153      CHARACTER*4 IREPL
14154      CHARACTER*4 IMULT
14155      CHARACTER*4 ICTMP1
14156      CHARACTER*4 ICTMP2
14157      CHARACTER*4 ICASE
14158C
14159      LOGICAL IFRST
14160      LOGICAL ILAST
14161C
14162      CHARACTER*40 INAME
14163      PARAMETER (MAXSPN=30)
14164      CHARACTER*4 IVARN1(MAXSPN)
14165      CHARACTER*4 IVARN2(MAXSPN)
14166      CHARACTER*4 IVARTY(MAXSPN)
14167      CHARACTER*4 IVARID(MAXSPN)
14168      CHARACTER*4 IVARI2(MAXSPN)
14169      REAL PVAR(MAXSPN)
14170      REAL PID(MAXSPN)
14171      INTEGER ILIS(MAXSPN)
14172      INTEGER NRIGHT(MAXSPN)
14173      INTEGER ICOLR(MAXSPN)
14174C
14175C---------------------------------------------------------------------
14176C
14177      INCLUDE 'DPCOPA.INC'
14178      INCLUDE 'DPCOZZ.INC'
14179C
14180      DIMENSION Y1(MAXOBV)
14181      DIMENSION X1(MAXOBV)
14182      DIMENSION XTEMP1(MAXOBV)
14183      DIMENSION XTEMP2(MAXOBV)
14184C
14185      DIMENSION XDESGN(MAXOBV,7)
14186      DIMENSION XIDTEM(MAXOBV)
14187      DIMENSION XIDTE2(MAXOBV)
14188      DIMENSION XIDTE3(MAXOBV)
14189      DIMENSION XIDTE4(MAXOBV)
14190      DIMENSION XIDTE5(MAXOBV)
14191      DIMENSION XIDTE6(MAXOBV)
14192C
14193      DIMENSION TEMP1(MAXOBV)
14194      DIMENSION TEMP2(MAXOBV)
14195      DIMENSION TEMP3(MAXOBV)
14196      DIMENSION TEMP4(MAXOBV)
14197C
14198      EQUIVALENCE (GARBAG(IGARB1),Y1(1))
14199      EQUIVALENCE (GARBAG(IGARB2),X1(1))
14200      EQUIVALENCE (GARBAG(IGARB4),XTEMP2(1))
14201      EQUIVALENCE (GARBAG(IGARB5),TEMP1(1))
14202      EQUIVALENCE (GARBAG(IGARB6),TEMP2(1))
14203      EQUIVALENCE (GARBAG(IGARB7),XIDTEM(1))
14204      EQUIVALENCE (GARBAG(IGARB8),XIDTE2(1))
14205      EQUIVALENCE (GARBAG(IGARB9),XIDTE3(1))
14206      EQUIVALENCE (GARBAG(IGAR10),XIDTE4(1))
14207      EQUIVALENCE (GARBAG(JGAR11),XIDTE5(1))
14208      EQUIVALENCE (GARBAG(JGAR12),XIDTE6(1))
14209      EQUIVALENCE (GARBAG(JGAR12),TEMP3(1))
14210      EQUIVALENCE (GARBAG(JGAR14),TEMP4(1))
14211      EQUIVALENCE (GARBAG(JGAR15),XDESGN(1,1))
14212C
14213C-----COMMON----------------------------------------------------------
14214C
14215      INCLUDE 'DPCOHK.INC'
14216      INCLUDE 'DPCODA.INC'
14217      INCLUDE 'DPCOSU.INC'
14218      INCLUDE 'DPCOS2.INC'
14219      INCLUDE 'DPCOHO.INC'
14220      INCLUDE 'DPCOMC.INC'
14221      INCLUDE 'DPCOST.INC'
14222      INCLUDE 'DPCOP2.INC'
14223C
14224C-----START POINT-----------------------------------------------------
14225C
14226      IERROR='NO'
14227      ICASAN='    '
14228      IREPL='OFF'
14229      IMULT='OFF'
14230      ISUBN1='DPGR'
14231      ISUBN2='UB  '
14232C
14233      MAXCP1=MAXCOL+1
14234      MAXCP2=MAXCOL+2
14235      MAXCP3=MAXCOL+3
14236      MAXCP4=MAXCOL+4
14237      MAXCP5=MAXCOL+5
14238      MAXCP6=MAXCOL+6
14239C
14240      MINN2=3
14241C
14242C               ***************************************************
14243C               **  TREAT THE GRUBB TEST                CASE     **
14244C               ***************************************************
14245C
14246      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'GRUB')THEN
14247        WRITE(ICOUT,999)
14248  999   FORMAT(1X)
14249        CALL DPWRST('XXX','BUG ')
14250        WRITE(ICOUT,51)
14251   51   FORMAT('***** AT THE BEGINNING OF DPGRUB--')
14252        CALL DPWRST('XXX','BUG ')
14253        WRITE(ICOUT,52)ICASAN,MAXNXT
14254   52   FORMAT('ICASAN,MAXNXT = ',A4,2X,I8)
14255        CALL DPWRST('XXX','BUG ')
14256        WRITE(ICOUT,53)IBUGA2,IBUGA3,IBUGQ
14257   53   FORMAT('IBUGA2,IBUGA3,IBUGQ = ',A4,2X,A4,2X,A4)
14258        CALL DPWRST('XXX','BUG ')
14259      ENDIF
14260C
14261C               *********************************************************
14262C               **  STEP 1--                                           **
14263C               **  EXTRACT THE COMMAND                                **
14264C               **  LOOK FOR ONE OF THE FOLLOWING COMMANDS:            **
14265C               **    1) GRUBB TEST Y                                  **
14266C               **    2) GRUBB TEST Y LABID                            **
14267C               **    3) GRUBB MULTIPLE TEST Y1 ... YK                 **
14268C               **    4) REPLICATED GRUBB TEST Y X1 ... XK             **
14269C               **    5) REPLICATED GRUBB TEST Y LABID X1 ... XK       **
14270C               **       REPLICATED GRUBB TEST Y X1 ... XK LABID       **
14271C               *********************************************************
14272C
14273      ISTEPN='1'
14274      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GRUB')
14275     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14276C
14277      ILASTC=9999
14278      ILASTZ=9999
14279      IFOUND='NO'
14280      ICASAN='GTES'
14281C
14282      DO100I=0,NUMARG-1
14283C
14284        IF(I.EQ.0)THEN
14285          ICTMP1=ICOM
14286          ICTMP2=IHARG(I+1)
14287        ELSE
14288          ICTMP1=IHARG(I)
14289          ICTMP2=IHARG(I+1)
14290        ENDIF
14291C
14292        IF(ICTMP1.EQ.'GRUB' .AND. ICTMP2.EQ.'TEST')THEN
14293          IFOUND='YES'
14294          ILASTC=I
14295          ILASTZ=I+1
14296        ELSEIF(ICTMP1.EQ.'GRUB')THEN
14297          IFOUND='YES'
14298          ILASTC=I
14299          ILASTZ=I
14300        ELSEIF(ICTMP1.EQ.'MINI')THEN
14301          ICASAN='GTMI'
14302          ILASTC=MIN(ILASTC,I)
14303          ILASTZ=MAX(ILASTZ,I)
14304        ELSEIF(ICTMP1.EQ.'MAXI')THEN
14305          ICASAN='GTMA'
14306          ILASTC=MIN(ILASTC,I)
14307          ILASTZ=MAX(ILASTZ,I)
14308        ELSEIF(ICTMP1.EQ.'REPL')THEN
14309          IREPL='ON'
14310          ILASTC=MIN(ILASTC,I)
14311          ILASTZ=MAX(ILASTZ,I)
14312        ELSEIF(ICTMP1.EQ.'MULT')THEN
14313          IMULT='ON'
14314          ILASTC=MIN(ILASTC,I)
14315          ILASTZ=MAX(ILASTZ,I)
14316        ENDIF
14317  100 CONTINUE
14318C
14319      ISHIFT=ILASTZ
14320      CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
14321     1            IBUGA2,IERROR)
14322C
14323      IF(IFOUND.EQ.'NO')GOTO9000
14324      IF(IMULT.EQ.'ON')THEN
14325        IF(IREPL.EQ.'ON')THEN
14326          WRITE(ICOUT,999)
14327          CALL DPWRST('XXX','BUG ')
14328          WRITE(ICOUT,101)
14329  101     FORMAT('***** ERROR IN GRUBBS TEST--')
14330          CALL DPWRST('XXX','BUG ')
14331          WRITE(ICOUT,102)
14332  102     FORMAT('      YOU CANNOT SPECIFY BOTH "MULTIPLE" AND ',
14333     1           '"REPLICATION" FOR THE GRUBBS TEST COMMAND.')
14334          CALL DPWRST('XXX','BUG ')
14335          IERROR='YES'
14336          GOTO9000
14337        ENDIF
14338      ENDIF
14339C
14340C               *********************************
14341C               **  STEP 4--                   **
14342C               **  EXTRACT THE VARIABLE LIST  **
14343C               *********************************
14344C
14345      ISTEPN='4'
14346      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GRUB')
14347     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14348C
14349      INAME='GRUBB TEST FOR OUTLIERS'
14350      MINNA=1
14351      MAXNA=100
14352      MINN2=2
14353      IFLAGE=1
14354      IF(IMULT.EQ.'ON')IFLAGE=0
14355      IFLAGM=1
14356      IF(IREPL.EQ.'ON')IFLAGM=0
14357      IFLAGP=0
14358      JMIN=1
14359      JMAX=NUMARG
14360      MINNVA=-99
14361      MAXNVA=-99
14362C
14363      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
14364     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
14365     1            JMIN,JMAX,
14366     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
14367     1            IVARN1,IVARN2,IVARTY,PVAR,
14368     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
14369     1            MINNVA,MAXNVA,
14370     1            IFLAGM,IFLAGP,
14371     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
14372      IF(IERROR.EQ.'YES')GOTO9000
14373C
14374      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GRUB')THEN
14375        WRITE(ICOUT,999)
14376        CALL DPWRST('XXX','BUG ')
14377        WRITE(ICOUT,281)
14378  281   FORMAT('***** AFTER CALL DPPARS--')
14379        CALL DPWRST('XXX','BUG ')
14380        WRITE(ICOUT,282)NQ,NUMVAR
14381  282   FORMAT('NQ,NUMVAR = ',2I8)
14382        CALL DPWRST('XXX','BUG ')
14383        IF(NUMVAR.GT.0)THEN
14384          DO285I=1,NUMVAR
14385            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
14386     1                      ICOLR(I)
14387  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
14388     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
14389            CALL DPWRST('XXX','BUG ')
14390  285     CONTINUE
14391        ENDIF
14392      ENDIF
14393C
14394C               ***********************************************
14395C               **  STEP 5--                                 **
14396C               **  DETERMINE:                               **
14397C               **  1) NUMBER OF REPLICATION VARIABLES (0-6) **
14398C               **  2) NUMBER OF RESPONSE    VARIABLES (>= 1)**
14399C               ***********************************************
14400C
14401      ISTEPN='5'
14402      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GRUB')
14403     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14404C
14405      NRESP=0
14406      NREPL=0
14407      NLABID=0
14408      IF(IMULT.EQ.'ON')THEN
14409        NRESP=NUMVAR
14410      ELSEIF(IREPL.EQ.'ON')THEN
14411        NRESP=1
14412        IF(NUMVAR.EQ.2)THEN
14413          NLABID=0
14414          NREPL=1
14415        ELSE
14416          NLABID=1
14417          NREPL=NUMVAR-NRESP-NLABID
14418        ENDIF
14419        IF(NREPL.LT.1 .OR. NREPL.GT.6)THEN
14420          WRITE(ICOUT,999)
14421          CALL DPWRST('XXX','BUG ')
14422          WRITE(ICOUT,101)
14423          CALL DPWRST('XXX','BUG ')
14424          WRITE(ICOUT,511)
14425  511     FORMAT('      FOR THE REPLICATION CASE, THE NUMBER OF ',
14426     1           'REPLICATION VARIABLES')
14427          CALL DPWRST('XXX','BUG ')
14428          WRITE(ICOUT,512)
14429  512     FORMAT('      MUST BE BETWEEN ONE AND SIX.')
14430          CALL DPWRST('XXX','BUG ')
14431          WRITE(ICOUT,513)NREPL
14432  513     FORMAT('      THE NUMBER OF REPLICATION VARIABLES = ',I5)
14433          CALL DPWRST('XXX','BUG ')
14434          IERROR='YES'
14435          GOTO9000
14436        ENDIF
14437      ELSE
14438        NRESP=1
14439        NLABID=NUMVAR-NRESP
14440        IF(NLABID.GT.1)NLABID=1
14441      ENDIF
14442C
14443      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GRUB')THEN
14444        WRITE(ICOUT,521)NRESP,NLABID,NREPL
14445  521   FORMAT('NRESP,NLABID,NREPL = ',3I5)
14446        CALL DPWRST('XXX','BUG ')
14447      ENDIF
14448C
14449C               ******************************************************
14450C               **  STEP 6--                                        **
14451C               **  GENERATE THE GRUBBS TEST FOR THE VARIOUS CASES  **
14452C               ******************************************************
14453C
14454      ISTEPN='6'
14455      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GRUB')
14456     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14457C
14458C               *****************************************
14459C               **  STEP 7A--                          **
14460C               **  CASE 1: SINGLE RESPONSE VARIABLE   **
14461C               **          WITH NO REPLICATION        **
14462C               *****************************************
14463C
14464      IF(NRESP.EQ.1 .AND. NREPL.EQ.0)THEN
14465        ISTEPN='7A'
14466        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GRUB')
14467     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14468C
14469        PID(1)=CPUMIN
14470        IVARID(1)=IVARN1(1)
14471        IVARI2(1)=IVARN2(1)
14472C
14473        ICOL=1
14474        NUMVA2=1
14475        IF(NLABID.GE.1)NUMVA2=2
14476        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
14477     1              INAME,IVARN1,IVARN2,IVARTY,
14478     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
14479     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
14480     1              MAXCP4,MAXCP5,MAXCP6,
14481     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
14482     1              Y1,X1,XTEMP2,NLOCAL,NLOCA2,NLOCA3,ICASE,
14483     1              IBUGA3,ISUBRO,IFOUND,IERROR)
14484        IF(IERROR.EQ.'YES')GOTO9000
14485        IF(NLABID.EQ.0)THEN
14486          DO720I=1,NLOCAL
14487            X1(I)=REAL(I)
14488  720     CONTINUE
14489        ENDIF
14490C
14491C       *****************************************************
14492C       **  STEP 7B--                                      **
14493C       **  CALL DPGRU2 TO PERFORM GRUBBS TEST.            **
14494C       *****************************************************
14495C
14496C
14497        IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'GRUB')THEN
14498          ISTEPN='7B'
14499          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14500          WRITE(ICOUT,999)
14501          CALL DPWRST('XXX','BUG ')
14502          WRITE(ICOUT,711)
14503  711     FORMAT('***** FROM THE MIDDLE  OF DPGRUB--')
14504          CALL DPWRST('XXX','BUG ')
14505          WRITE(ICOUT,712)ICASAN,NUMVAR,IDATSW,NLOCAL
14506  712     FORMAT('ICASAN,NUMVAR,IDATSW,NQ = ',
14507     1           A4,I8,2X,A4,I8)
14508          CALL DPWRST('XXX','BUG ')
14509          IF(NLOCAL.GE.1)THEN
14510            DO715I=1,NLOCAL
14511              WRITE(ICOUT,716)I,Y1(I),X1(I)
14512  716         FORMAT('I,Y1(I),X1(I) = ',I8,2F12.5)
14513              CALL DPWRST('XXX','BUG ')
14514  715       CONTINUE
14515          ENDIF
14516        ENDIF
14517C
14518        NCURVE=1
14519        CALL DPGRU2(Y1,X1,NLOCAL,ICASAN,IGRU1S,MAXOBV,
14520     1              TEMP3,TEMP4,
14521     1              PID,IVARID,IVARI2,NREPL,NLABID,
14522     1              ICAPSW,ICAPTY,IFORSW,
14523     1              PGRUSD,PGRUDF,IGRUTA,
14524     1              STATVA,STATCD,PVAL,
14525     1              CUT0,CUT50,CUT75,CUT90,CUT95,CUT975,CUT99,CUT100,
14526     1              ISUBRO,IBUGA3,IERROR)
14527C
14528C               ***************************************
14529C               **  STEP 7C--                        **
14530C               **  COMPUTE GRUB      STAT           **
14531C               **  UPDATE INTERNAL DATAPLOT TABLES  **
14532C               ***************************************
14533C
14534        ISTEPN='7C'
14535        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GRUB')
14536     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14537C
14538        IFLAGU='ON'
14539        IFRST=.FALSE.
14540        ILAST=.FALSE.
14541        CALL DPGRU4(STATVA,STATCD,PVAL,
14542     1              CUT0,CUT50,CUT75,CUT90,CUT95,CUT975,CUT99,CUT100,
14543     1              IFLAGU,IFRST,ILAST,ICASP2,
14544     1              IBUGA2,IBUGA3,ISUBRO,IERROR)
14545C
14546C               ******************************************
14547C               **  STEP 8A--                           **
14548C               **  CASE 2: MULTIPLE RESPONSE VARIABLES **
14549C               **          NOTE THAT A LABID VARIABLE  **
14550C               **          IS NOT SUPPORTED FOR THIS   **
14551C               **          CASE.                       **
14552C               ******************************************
14553C
14554      ELSEIF(NRESP.GT.1)THEN
14555        ISTEPN='8A'
14556        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GRUB')
14557     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14558C
14559C       LOOP THROUGH EACH OF THE RESPONSE VARIABLES
14560C
14561        NCURVE=0
14562        DO810IRESP=1,NRESP
14563          NCURVE=NCURVE+1
14564C
14565          IINDX=ICOLR(IRESP)
14566          PID(1)=CPUMIN
14567          IVARID(1)=IVARN1(IRESP)
14568          IVARI2(1)=IVARN2(IRESP)
14569C
14570          IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GRUB')THEN
14571            WRITE(ICOUT,999)
14572            CALL DPWRST('XXX','BUG ')
14573            WRITE(ICOUT,811)IRESP,NCURVE
14574  811       FORMAT('IRESP,NCURVE = ',2I5)
14575            CALL DPWRST('XXX','BUG ')
14576          ENDIF
14577C
14578          ICOL=IRESP
14579          NUMVA2=1
14580          CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
14581     1                INAME,IVARN1,IVARN2,IVARTY,
14582     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
14583     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
14584     1                MAXCP4,MAXCP5,MAXCP6,
14585     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
14586     1                Y1,XTEMP1,XTEMP2,NLOCAL,NLOCA2,NLOCA3,ICASE,
14587     1                IBUGA3,ISUBRO,IFOUND,IERROR)
14588          IF(IERROR.EQ.'YES')GOTO9000
14589          DO820I=1,NLOCAL
14590            X1(I)=REAL(I)
14591  820     CONTINUE
14592C
14593C         *****************************************************
14594C         **  STEP 8B--                                      **
14595C         *****************************************************
14596C
14597          IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'GRUB')THEN
14598            ISTEPN='8B'
14599            CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14600            WRITE(ICOUT,999)
14601            CALL DPWRST('XXX','BUG ')
14602            WRITE(ICOUT,822)
14603  822       FORMAT('***** FROM THE MIDDLE  OF DPGRUB--')
14604            CALL DPWRST('XXX','BUG ')
14605            WRITE(ICOUT,823)ICASAN,NUMVAR,IDATSW,NLOCAL
14606  823       FORMAT('ICASAN,NUMVAR,IDATSW,NQ = ',
14607     1             A4,I8,2X,A4,I8)
14608            CALL DPWRST('XXX','BUG ')
14609            IF(NLOCAL.GE.1)THEN
14610              DO825I=1,NLOCAL
14611                WRITE(ICOUT,826)I,Y1(I),X1(I)
14612  826           FORMAT('I,Y1(I),X1(I) = ',I8,2F12.5)
14613                CALL DPWRST('XXX','BUG ')
14614  825         CONTINUE
14615            ENDIF
14616          ENDIF
14617C
14618          CALL DPGRU2(Y1,X1,NLOCAL,ICASAN,IGRU1S,MAXOBV,
14619     1                TEMP3,TEMP4,
14620     1                PID,IVARID,IVARI2,NREPL,NLABID,
14621     1                ICAPSW,ICAPTY,IFORSW,
14622     1                PGRUSD,PGRUDF,IGRUTA,
14623     1                STATVA,STATCD,PVAL,
14624     1                CUT0,CUT50,CUT75,CUT90,CUT95,CUT975,CUT99,CUT100,
14625     1                ISUBRO,IBUGA3,IERROR)
14626C
14627C               ***************************************
14628C               **  STEP 8C--                        **
14629C               **  COMPUTE GRUBB     STAT           **
14630C               **  UPDATE INTERNAL DATAPLOT TABLES  **
14631C               ***************************************
14632C
14633          ISTEPN='8C'
14634          IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GRUB')
14635     1      CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14636C
14637          IFLAGU='FILE'
14638          IFRST=.FALSE.
14639          ILAST=.FALSE.
14640          IF(IRESP.EQ.1)IFRST=.TRUE.
14641          IF(IRESP.EQ.NRESP)ILAST=.TRUE.
14642          CALL DPGRU4(STATVA,STATCD,PVAL,
14643     1                CUT0,CUT50,CUT75,CUT90,CUT95,CUT975,CUT99,CUT100,
14644     1                IFLAGU,IFRST,ILAST,ICASP2,
14645     1                IBUGA2,IBUGA3,ISUBRO,IERROR)
14646C
14647  810   CONTINUE
14648C
14649C               ****************************************************
14650C               **  STEP 9A--                                     **
14651C               **  CASE 3: ONE OR MORE REPLICATION VARIABLES.    **
14652C               **          FOR THIS CASE, THE NUMBER OF RESPONSE **
14653C               **          VARIABLES MUST BE EXACTLY 1.          **
14654C               **          FOR THIS CASE, ALL VARIABLES MUST     **
14655C               **          HAVE THE SAME LENGTH.                 **
14656C               ****************************************************
14657C
14658      ELSEIF(IREPL.EQ.'ON')THEN
14659        ISTEPN='9A'
14660        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GRUB')
14661     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14662C
14663        J=0
14664        IMAX=NRIGHT(1)
14665        IF(NQ.LT.NRIGHT(1))IMAX=NQ
14666        DO910I=1,IMAX
14667          IF(ISUB(I).EQ.0)GOTO910
14668          J=J+1
14669C
14670C         RESPONSE VARIABLE IN Y1
14671C
14672          ICOLC=1
14673          IJ=MAXN*(ICOLR(ICOLC)-1)+I
14674          IF(ICOLR(ICOLC).LE.MAXCOL)Y1(J)=V(IJ)
14675          IF(ICOLR(ICOLC).EQ.MAXCP1)Y1(J)=PRED(I)
14676          IF(ICOLR(ICOLC).EQ.MAXCP2)Y1(J)=RES(I)
14677          IF(ICOLR(ICOLC).EQ.MAXCP3)Y1(J)=YPLOT(I)
14678          IF(ICOLR(ICOLC).EQ.MAXCP4)Y1(J)=XPLOT(I)
14679          IF(ICOLR(ICOLC).EQ.MAXCP5)Y1(J)=X2PLOT(I)
14680          IF(ICOLR(ICOLC).EQ.MAXCP6)Y1(J)=TAGPLO(I)
14681C
14682C         LABID VARIABLE IN X1
14683C
14684          IF(NLABID.GE.1)THEN
14685            ICOLC=ICOLC+1
14686            ICOLT=ICOLR(ICOLC)
14687            IJ=MAXN*(ICOLT-1)+I
14688            IF(ICOLT.LE.MAXCOL)X1(J)=V(IJ)
14689            IF(ICOLT.EQ.MAXCP1)X1(J)=PRED(I)
14690            IF(ICOLT.EQ.MAXCP2)X1(J)=RES(I)
14691            IF(ICOLT.EQ.MAXCP3)X1(J)=YPLOT(I)
14692            IF(ICOLT.EQ.MAXCP4)X1(J)=XPLOT(I)
14693            IF(ICOLT.EQ.MAXCP5)X1(J)=X2PLOT(I)
14694            IF(ICOLT.EQ.MAXCP6)X1(J)=TAGPLO(I)
14695          ELSE
14696            X1(J)=REAL(I)
14697          ENDIF
14698C
14699          IF(NREPL.GE.1)THEN
14700            DO920IR=1,MIN(NREPL,6)
14701              ICOLC=ICOLC+1
14702              ICOLT=ICOLR(ICOLC)
14703              IJ=MAXN*(ICOLT-1)+I
14704              IF(ICOLT.LE.MAXCOL)XDESGN(J,IR)=V(IJ)
14705              IF(ICOLT.EQ.MAXCP1)XDESGN(J,IR)=PRED(I)
14706              IF(ICOLT.EQ.MAXCP2)XDESGN(J,IR)=RES(I)
14707              IF(ICOLT.EQ.MAXCP3)XDESGN(J,IR)=YPLOT(I)
14708              IF(ICOLT.EQ.MAXCP4)XDESGN(J,IR)=XPLOT(I)
14709              IF(ICOLT.EQ.MAXCP5)XDESGN(J,IR)=X2PLOT(I)
14710              IF(ICOLT.EQ.MAXCP6)XDESGN(J,IR)=TAGPLO(I)
14711  920       CONTINUE
14712          ENDIF
14713C
14714  910   CONTINUE
14715        NLOCAL=J
14716C
14717        ISTEPN='9B'
14718        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GRUB')
14719     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14720C
14721C       NOTE: CHECK TO SEE IF X1 HAS ALL UNIQUE ELEMENTS.  IF NOT,
14722C             THEN INTERPRET THIS AS A REPLICATION VARIABLE.
14723C
14724        CALL DISTIN(X1,NLOCAL,IWRITE,XTEMP2,NDIST,IBUGA3,IERROR)
14725        IF(NLOCAL.NE.NDIST)THEN
14726          NLABID=0
14727          IF(NREPL.GT.6)NREPL=6
14728          IF(NREPL.GE.1)THEN
14729            DO930J=1,NREPL-1
14730              DO935I=1,NLOCAL
14731                XDESGN(I,J+1)=XDESGN(I,J)
14732  935         CONTINUE
14733  930       CONTINUE
14734          ENDIF
14735          NREPL=NREPL+1
14736          DO938I=1,NLOCAL
14737            XDESGN(I,1)=X1(I)
14738            X1(I)=REAL(I)
14739  938     CONTINUE
14740        ENDIF
14741C
14742        PID(1)=CPUMIN
14743        IVARID(1)=IVARN1(1)
14744        IVARI2(1)=IVARN2(1)
14745        IF(NLABID.EQ.1)THEN
14746          PID(2)=CPUMIN
14747          IVARID(2)=IVARN1(2)
14748          IVARI2(2)=IVARN2(2)
14749        ENDIF
14750        IADD=NRESP+NLABID
14751        DO940II=1,NREPL
14752          IVARID(II+IADD)=IVARN1(II+IADD)
14753          IVARI2(II+IADD)=IVARN2(II+IADD)
14754  940   CONTINUE
14755C
14756C       *****************************************************
14757C       **  STEP 9B--                                      **
14758C       **  CALL DPGRU2 TO PERFORM GRUBB TEST.             **
14759C       *****************************************************
14760C
14761C
14762        IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'GRUB')THEN
14763          ISTEPN='9C'
14764          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14765          WRITE(ICOUT,999)
14766          CALL DPWRST('XXX','BUG ')
14767          WRITE(ICOUT,941)
14768  941     FORMAT('***** FROM THE MIDDLE  OF DPGRUB--')
14769          CALL DPWRST('XXX','BUG ')
14770          WRITE(ICOUT,942)ICASAN,NUMVAR,IDATSW,NLOCAL,NREPL
14771  942     FORMAT('ICASAN,NUMVAR,IDATSW,NLOCAL,NREPL = ',
14772     1           A4,I8,2X,A4,2I8)
14773          CALL DPWRST('XXX','BUG ')
14774          IF(NLOCAL.GE.1)THEN
14775            DO945I=1,NLOCAL
14776              WRITE(ICOUT,946)I,Y1(I),X1(I),XDESGN(I,1),XDESGN(I,2)
14777  946         FORMAT('I,Y1(I),X1(I),XDESGN(I,1),XDESGN(I,2) = ',
14778     1               I8,4F12.5)
14779              CALL DPWRST('XXX','BUG ')
14780  945       CONTINUE
14781          ENDIF
14782        ENDIF
14783C
14784C       *****************************************************
14785C       **  STEP 9C--                                      **
14786C       **  FIND THE DISTINCT VALUES IN EACH OF THE        **
14787C       **  REPLICATION VARIABLES.                         **
14788C       *****************************************************
14789C
14790        CALL DPPP5(XDESGN(1,1),XDESGN(1,2),XDESGN(1,3),
14791     1             XDESGN(1,4),XDESGN(1,5),XDESGN(1,6),
14792     1             NREPL,NLOCAL,MAXOBV,
14793     1             XIDTEM,XIDTE2,XIDTE3,XIDTE4,XIDTE5,XIDTE6,
14794     1             XTEMP1,XTEMP2,
14795     1             NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,NUMSE6,
14796     1             IBUGA3,ISUBRO,IERROR)
14797C
14798C       *****************************************************
14799C       **  STEP 9D--                                      **
14800C       **  NOW LOOP THROUGH THE VARIOUS REPLICATIONS      **
14801C       *****************************************************
14802C
14803        NPLOTP=0
14804        NCURVE=0
14805        IF(NREPL.EQ.1)THEN
14806          J=0
14807          DO1110ISET1=1,NUMSE1
14808            K=0
14809            PID(IADD+1)=XIDTEM(ISET1)
14810            DO1130I=1,NLOCAL
14811              IF(XIDTEM(ISET1).EQ.XDESGN(I,1))THEN
14812                K=K+1
14813                TEMP1(K)=Y1(I)
14814                TEMP2(K)=X1(I)
14815              ENDIF
14816 1130       CONTINUE
14817            NTEMP=K
14818            NCURVE=NCURVE+1
14819            NPLOT1=NPLOTP
14820            IF(NTEMP.GT.0)THEN
14821              CALL DPGRU2(TEMP1,TEMP2,NTEMP,ICASAN,IGRU1S,MAXOBV,
14822     1                    TEMP3,TEMP4,
14823     1                    PID,IVARID,IVARI2,NREPL,NLABID,
14824     1                    ICAPSW,ICAPTY,IFORSW,
14825     1                    PGRUSD,PGRUDF,IGRUTA,
14826     1                    STATVA,STATCD,PVAL,
14827     1                    CUT0,CUT50,CUT75,CUT90,CUT95,
14828     1                    CUT975,CUT99,CUT100,
14829     1                    ISUBRO,IBUGA3,IERROR)
14830            ENDIF
14831            NPLOT2=NPLOTP
14832            IFLAGU='FILE'
14833            IFRST=.FALSE.
14834            ILAST=.FALSE.
14835            IF(NCURVE.EQ.1)IFRST=.TRUE.
14836            IF(NCURVE.EQ.NUMSE1)ILAST=.TRUE.
14837            NPTEMP=NPLOT2-NPLOT1
14838            CALL DPGRU4(STATVA,STATCD,PVAL,
14839     1                  CUT0,CUT50,CUT75,CUT90,CUT95,
14840     1                  CUT975,CUT99,CUT100,
14841     1                  IFLAGU,IFRST,ILAST,ICASP2,
14842     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
14843 1110     CONTINUE
14844        ELSEIF(NREPL.EQ.2)THEN
14845          J=0
14846          NTOT=NUMSE1*NUMSE2
14847          DO1210ISET1=1,NUMSE1
14848          DO1220ISET2=1,NUMSE2
14849            K=0
14850            PID(1+IADD)=XIDTEM(ISET1)
14851            PID(2+IADD)=XIDTE2(ISET2)
14852            DO1290I=1,NLOCAL
14853              IF(
14854     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
14855     1           XIDTE2(ISET2).EQ.XDESGN(I,2)
14856     1          )THEN
14857                K=K+1
14858                TEMP1(K)=Y1(I)
14859                TEMP2(K)=X1(I)
14860              ENDIF
14861 1290       CONTINUE
14862            NTEMP=K
14863            NCURVE=NCURVE+1
14864            NPLOT1=NPLOTP
14865            IF(NTEMP.GT.0)THEN
14866              CALL DPGRU2(TEMP1,TEMP2,NTEMP,ICASAN,IGRU1S,MAXOBV,
14867     1                    TEMP3,TEMP4,
14868     1                    PID,IVARID,IVARI2,NREPL,NLABID,
14869     1                    ICAPSW,ICAPTY,IFORSW,
14870     1                    PGRUSD,PGRUDF,IGRUTA,
14871     1                    STATVA,STATCD,PVAL,
14872     1                    CUT0,CUT50,CUT75,CUT90,CUT95,
14873     1                    CUT975,CUT99,CUT100,
14874     1                    ISUBRO,IBUGA3,IERROR)
14875            ENDIF
14876            NPLOT2=NPLOTP
14877            IFLAGU='FILE'
14878            IFRST=.FALSE.
14879            ILAST=.FALSE.
14880            IF(NCURVE.EQ.1)IFRST=.TRUE.
14881            IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
14882            NPTEMP=NPLOT2-NPLOT1
14883            CALL DPGRU4(STATVA,STATCD,PVAL,
14884     1                  CUT0,CUT50,CUT75,CUT90,CUT95,
14885     1                  CUT975,CUT99,CUT100,
14886     1                  IFLAGU,IFRST,ILAST,ICASP2,
14887     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
14888 1220     CONTINUE
14889 1210     CONTINUE
14890        ELSEIF(NREPL.EQ.3)THEN
14891          J=0
14892          NTOT=NUMSE1*NUMSE2*NUMSE3
14893          DO1310ISET1=1,NUMSE1
14894          DO1320ISET2=1,NUMSE2
14895          DO1330ISET3=1,NUMSE3
14896            K=0
14897            PID(1+IADD)=XIDTEM(ISET1)
14898            PID(2+IADD)=XIDTE2(ISET2)
14899            PID(3+IADD)=XIDTE3(ISET3)
14900            DO1390I=1,NLOCAL
14901              IF(
14902     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
14903     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
14904     1           XIDTE3(ISET3).EQ.XDESGN(I,3)
14905     1          )THEN
14906                K=K+1
14907                TEMP1(K)=Y1(I)
14908                TEMP2(K)=X1(I)
14909              ENDIF
14910 1390       CONTINUE
14911            NTEMP=K
14912            NCURVE=NCURVE+1
14913            NPLOT1=NPLOTP
14914            IF(NTEMP.GT.0)THEN
14915              CALL DPGRU2(TEMP1,TEMP2,NTEMP,ICASAN,IGRU1S,MAXOBV,
14916     1                    TEMP3,TEMP4,
14917     1                    PID,IVARID,IVARI2,NREPL,NLABID,
14918     1                    ICAPSW,ICAPTY,IFORSW,
14919     1                    PGRUSD,PGRUDF,IGRUTA,
14920     1                    STATVA,STATCD,PVAL,
14921     1                    CUT0,CUT50,CUT75,CUT90,CUT95,
14922     1                    CUT975,CUT99,CUT100,
14923     1                    ISUBRO,IBUGA3,IERROR)
14924            ENDIF
14925            NPLOT2=NPLOTP
14926            IFLAGU='FILE'
14927            IFRST=.FALSE.
14928            ILAST=.FALSE.
14929            IF(NCURVE.EQ.1)IFRST=.TRUE.
14930            IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
14931            NPTEMP=NPLOT2-NPLOT1
14932            CALL DPGRU4(STATVA,STATCD,PVAL,
14933     1                  CUT0,CUT50,CUT75,CUT90,CUT95,
14934     1                  CUT975,CUT99,CUT100,
14935     1                  IFLAGU,IFRST,ILAST,ICASP2,
14936     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
14937 1330     CONTINUE
14938 1320     CONTINUE
14939 1310     CONTINUE
14940        ELSEIF(NREPL.EQ.4)THEN
14941          J=0
14942          NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4
14943          DO1410ISET1=1,NUMSE1
14944          DO1420ISET2=1,NUMSE2
14945          DO1430ISET3=1,NUMSE3
14946          DO1440ISET4=1,NUMSE4
14947            K=0
14948            PID(1+IADD)=XIDTEM(ISET1)
14949            PID(2+IADD)=XIDTE2(ISET2)
14950            PID(3+IADD)=XIDTE3(ISET3)
14951            PID(4+IADD)=XIDTE4(ISET4)
14952            DO1490I=1,NLOCAL
14953              IF(
14954     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
14955     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
14956     1           XIDTE3(ISET3).EQ.XDESGN(I,3) .AND.
14957     1           XIDTE4(ISET4).EQ.XDESGN(I,4)
14958     1          )THEN
14959                K=K+1
14960                TEMP1(K)=Y1(I)
14961                TEMP2(K)=X1(I)
14962              ENDIF
14963 1490       CONTINUE
14964            NTEMP=K
14965            NCURVE=NCURVE+1
14966            NPLOT1=NPLOTP
14967            IF(NTEMP.GT.0)THEN
14968              CALL DPGRU2(TEMP1,TEMP2,NTEMP,ICASAN,IGRU1S,MAXOBV,
14969     1                    TEMP3,TEMP4,
14970     1                    PID,IVARID,IVARI2,NREPL,NLABID,
14971     1                    ICAPSW,ICAPTY,IFORSW,
14972     1                    PGRUSD,PGRUDF,IGRUTA,
14973     1                    STATVA,STATCD,PVAL,
14974     1                    CUT0,CUT50,CUT75,CUT90,CUT95,
14975     1                    CUT975,CUT99,CUT100,
14976     1                    ISUBRO,IBUGA3,IERROR)
14977            ENDIF
14978            NPLOT2=NPLOTP
14979            IFLAGU='FILE'
14980            IFRST=.FALSE.
14981            ILAST=.FALSE.
14982            IF(NCURVE.EQ.1)IFRST=.TRUE.
14983            IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
14984            NPTEMP=NPLOT2-NPLOT1
14985            CALL DPGRU4(STATVA,STATCD,PVAL,
14986     1                  CUT0,CUT50,CUT75,CUT90,CUT95,
14987     1                  CUT975,CUT99,CUT100,
14988     1                  IFLAGU,IFRST,ILAST,ICASP2,
14989     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
14990 1440     CONTINUE
14991 1430     CONTINUE
14992 1420     CONTINUE
14993 1410     CONTINUE
14994        ELSEIF(NREPL.EQ.5)THEN
14995          J=0
14996          NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5
14997          DO1510ISET1=1,NUMSE1
14998          DO1520ISET2=1,NUMSE2
14999          DO1530ISET3=1,NUMSE3
15000          DO1540ISET4=1,NUMSE4
15001          DO1550ISET5=1,NUMSE5
15002            K=0
15003            PID(1+IADD)=XIDTEM(ISET1)
15004            PID(2+IADD)=XIDTE2(ISET2)
15005            PID(3+IADD)=XIDTE3(ISET3)
15006            PID(4+IADD)=XIDTE4(ISET4)
15007            PID(5+IADD)=XIDTE5(ISET4)
15008            DO1590I=1,NLOCAL
15009              IF(
15010     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
15011     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
15012     1           XIDTE3(ISET3).EQ.XDESGN(I,3) .AND.
15013     1           XIDTE4(ISET4).EQ.XDESGN(I,4) .AND.
15014     1           XIDTE5(ISET5).EQ.XDESGN(I,5)
15015     1          )THEN
15016                K=K+1
15017                TEMP1(K)=Y1(I)
15018                TEMP2(K)=X1(I)
15019              ENDIF
15020 1590       CONTINUE
15021            NTEMP=K
15022            NCURVE=NCURVE+1
15023            NPLOT1=NPLOTP
15024            IF(NTEMP.GT.0)THEN
15025              CALL DPGRU2(TEMP1,TEMP2,NTEMP,ICASAN,IGRU1S,MAXOBV,
15026     1                    TEMP3,TEMP4,
15027     1                    PID,IVARID,IVARI2,NREPL,NLABID,
15028     1                    ICAPSW,ICAPTY,IFORSW,
15029     1                    PGRUSD,PGRUDF,IGRUTA,
15030     1                    STATVA,STATCD,PVAL,
15031     1                    CUT0,CUT50,CUT75,CUT90,CUT95,
15032     1                    CUT975,CUT99,CUT100,
15033     1                    ISUBRO,IBUGA3,IERROR)
15034            ENDIF
15035            NPLOT2=NPLOTP
15036            IFLAGU='FILE'
15037            IFRST=.FALSE.
15038            ILAST=.FALSE.
15039            IF(NCURVE.EQ.1)IFRST=.TRUE.
15040            IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
15041            NPTEMP=NPLOT2-NPLOT1
15042            CALL DPGRU4(STATVA,STATCD,PVAL,
15043     1                  CUT0,CUT50,CUT75,CUT90,CUT95,
15044     1                  CUT975,CUT99,CUT100,
15045     1                  IFLAGU,IFRST,ILAST,ICASP2,
15046     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
15047 1550     CONTINUE
15048 1540     CONTINUE
15049 1530     CONTINUE
15050 1520     CONTINUE
15051 1510     CONTINUE
15052        ELSEIF(NREPL.EQ.6)THEN
15053          J=0
15054          NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5*NUMSE6
15055          DO1610ISET1=1,NUMSE1
15056          DO1620ISET2=1,NUMSE2
15057          DO1630ISET3=1,NUMSE3
15058          DO1640ISET4=1,NUMSE4
15059          DO1650ISET5=1,NUMSE5
15060          DO1660ISET6=1,NUMSE6
15061            K=0
15062            PID(1+IADD)=XIDTEM(ISET1)
15063            PID(2+IADD)=XIDTE2(ISET2)
15064            PID(3+IADD)=XIDTE3(ISET3)
15065            PID(4+IADD)=XIDTE4(ISET4)
15066            PID(5+IADD)=XIDTE5(ISET4)
15067            PID(6+IADD)=XIDTE6(ISET4)
15068            DO1690I=1,NLOCAL
15069              IF(
15070     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
15071     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
15072     1           XIDTE3(ISET3).EQ.XDESGN(I,3) .AND.
15073     1           XIDTE4(ISET4).EQ.XDESGN(I,4) .AND.
15074     1           XIDTE5(ISET5).EQ.XDESGN(I,5) .AND.
15075     1           XIDTE6(ISET6).EQ.XDESGN(I,6)
15076     1          )THEN
15077                K=K+1
15078                TEMP1(K)=Y1(I)
15079                TEMP2(K)=X1(I)
15080              ENDIF
15081 1690       CONTINUE
15082            NTEMP=K
15083            NCURVE=NCURVE+1
15084            NPLOT1=NPLOTP
15085            IF(NTEMP.GT.0)THEN
15086              CALL DPGRU2(TEMP1,TEMP2,NTEMP,ICASAN,IGRU1S,MAXOBV,
15087     1                    TEMP3,TEMP4,
15088     1                    PID,IVARID,IVARI2,NREPL,NLABID,
15089     1                    ICAPSW,ICAPTY,IFORSW,
15090     1                    PGRUSD,PGRUDF,IGRUTA,
15091     1                    STATVA,STATCD,PVAL,
15092     1                    CUT0,CUT50,CUT75,CUT90,CUT95,
15093     1                    CUT975,CUT99,CUT100,
15094     1                    ISUBRO,IBUGA3,IERROR)
15095            ENDIF
15096            NPLOT2=NPLOTP
15097            IFLAGU='FILE'
15098            IFRST=.FALSE.
15099            ILAST=.FALSE.
15100            IF(NCURVE.EQ.1)IFRST=.TRUE.
15101            IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
15102            NPTEMP=NPLOT2-NPLOT1
15103            CALL DPGRU4(STATVA,STATCD,PVAL,
15104     1                  CUT0,CUT50,CUT75,CUT90,CUT95,
15105     1                  CUT975,CUT99,CUT100,
15106     1                  IFLAGU,IFRST,ILAST,ICASP2,
15107     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
15108 1660     CONTINUE
15109 1650     CONTINUE
15110 1640     CONTINUE
15111 1630     CONTINUE
15112 1620     CONTINUE
15113 1610     CONTINUE
15114        ENDIF
15115C
15116      ENDIF
15117C
15118C               *****************
15119C               **  STEP 90--  **
15120C               **  EXIT       **
15121C               *****************
15122C
15123 9000 CONTINUE
15124C
15125      IF(IERROR.EQ.'YES')THEN
15126        IF(IWIDTH.GE.1)THEN
15127          WRITE(ICOUT,9001)(IANS(I),I=1,MIN(100,IWIDTH))
15128 9001     FORMAT(100A1)
15129          CALL DPWRST('XXX','BUG ')
15130        ENDIF
15131      ENDIF
15132C
15133      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'GRUB')THEN
15134        WRITE(ICOUT,999)
15135        CALL DPWRST('XXX','BUG ')
15136        WRITE(ICOUT,9011)
15137 9011   FORMAT('***** AT THE END       OF DPGRUB--')
15138        CALL DPWRST('XXX','BUG ')
15139        WRITE(ICOUT,9012)IFOUND,IERROR
15140 9012   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
15141        CALL DPWRST('XXX','BUG ')
15142        WRITE(ICOUT,9013)NPLOTP,NS,ICASAN
15143 9013   FORMAT('NPLOTP,NS,ICASAN = ',I8,I8,2X,A4)
15144        CALL DPWRST('XXX','BUG ')
15145      ENDIF
15146C
15147      RETURN
15148      END
15149      SUBROUTINE DPGRU2(Y,X,N,ICASAN,IGRU1S,MAXNXT,TEMP1,TEMP2,
15150     1                  PID,IVARID,IVARI2,NREPL,NLABID,
15151     1                  ICAPSW,ICAPTY,IFORSW,
15152     1                  PGRUSD,PGRUDF,IGRUTA,
15153     1                  STATVA,STATCD,PVAL,
15154     1                  CUT0,CUT50,CUT75,CUT90,CUT95,
15155     1                  CUT975,CUT99,CUT100,
15156     1                  ISUBRO,IBUGA3,IERROR)
15157C
15158C     PURPOSE--THIS ROUTINE CARRIES OUT THE GRUBB TEST FOR UNIVARIATE
15159C              OUTLIERS (DATA ASSUMED TO FOLLOW AN APPROXIMATELY NORMAL
15160C              DISTRIBUTION).
15161C     EXAMPLE--GRUBB TEST Y
15162C     REFERENCE--GRUBBS, FRANK (FEBRUARY 1969), PROCEDURES FOR DETECTING
15163C                OUTLYING OBSERVATIONS IN SAMPLES, TECHNOMETRICS,
15164C                VOL. 11, NO. 1, PP. 1-21.
15165C              --STEFANSKY, W. (1972), REJECTING OUTLIERS IN FACTORIAL
15166C                DESIGNS, TECHNOMETRICS, VOL. 14, PP. 469-479.
15167C     WRITTEN BY--JAMES J. FILLIBEN
15168C                 STATISTICAL ENGINEERING DIVISION
15169C                 INFORMATION TECHNOLOGY LABORATORY
15170C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
15171C                 GAITHERSBURG, MD 20899-8980
15172C                 PHONE--301-975-2855
15173C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
15174C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
15175C     LANGUAGE--ANSI FORTRAN (1977)
15176C     VERSION NUMBER--97/9
15177C     ORIGINAL VERSION--SEPTEMBER 1997.
15178C     UPDATED         --JANUARY   2004. SUPPORT FOR HTML, LATEX OUTPUT
15179C     UPDATED         --MAY       2005. CORRECT CRITICAL VALUES
15180C                                       (REALLY 2 TESTS - ONE FOR
15181C                                       POSITIVE OUTLIERS AND ONE FOR
15182C                                       NEGATIVE OUTLIERS).  NEED TO
15183C                                       DIVIDE CRITICAL VALUES BY 2.
15184C                                       IN ADDITION, GENERATE THE
15185C                                       ONE TAILED VERSIONS.
15186C     UPDATED         --FEBRUARY  2006. SEPARATE SYNTAX FOR MINIMUM
15187C                                       AND MAXIMUM TESTS
15188C     UPDATED         --OCTOBER   2006. CALL LIST TO TCDF AND TPPF
15189C     UPDATED         --OCTOBER   2009. MODIFY OUTPUT FORMAT TO USE
15190C                                       DPDTA1 AND DPDTA4.  THIS ADDS
15191C                                       SUPPORT FOR RTF.
15192C     UPDATED         --OCTOBER   2009. ADD SUPPORT FOR OPTIONAL
15193C                                       "LAB-ID" VARIABLE (FOR
15194C                                       IDENTIFICATION PURPOSES ONLY)
15195C     UPDATED         --JULY      2014. ADD SKEWNESS AND KURTOSIS TO
15196C                                       SUMMARY STATISTICS
15197C     UPDATED         --OCTOBER   2019. SUPPORT CASE FOR INDEPENDENT OR
15198C                                       KNOWN STANDARD DEVIATION
15199C
15200C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
15201C
15202      DIMENSION Y(*)
15203      DIMENSION X(*)
15204      DIMENSION TEMP1(*)
15205      DIMENSION TEMP2(*)
15206      DIMENSION PID(*)
15207C
15208      CHARACTER*4 ISUBRO
15209      CHARACTER*4 IBUGA3
15210      CHARACTER*4 IERROR
15211      CHARACTER*4 IVARID(*)
15212      CHARACTER*4 IVARI2(*)
15213      CHARACTER*4 ICAPSW
15214      CHARACTER*4 ICAPTY
15215      CHARACTER*4 IFORSW
15216      CHARACTER*4 IGRU1S
15217      CHARACTER*4 IGRUTA
15218      CHARACTER*4 ICASAN
15219C
15220      CHARACTER*4 IWRITE
15221      CHARACTER*4 ICASA2
15222      CHARACTER*4 IGRUT2
15223      CHARACTER*4 IOP
15224      CHARACTER*4 IDIR
15225      CHARACTER*4 ISUBN1
15226      CHARACTER*4 ISUBN2
15227      CHARACTER*4 ISTEPN
15228C
15229      CHARACTER*4 IRTFMD
15230      COMMON/COMRTF/IRTFMD
15231C
15232      PARAMETER (NUMALP=8)
15233      REAL ALPHA(NUMALP)
15234C
15235      PARAMETER(NUMCLI=4)
15236      PARAMETER(MAXLIN=2)
15237      PARAMETER (MAXROW=50)
15238      CHARACTER*60 ITITLE
15239      CHARACTER*60 ITITLZ
15240      CHARACTER*1  ITITL9
15241      CHARACTER*60 ITEXT(MAXROW)
15242      CHARACTER*4  ALIGN(NUMCLI)
15243      CHARACTER*4  VALIGN(NUMCLI)
15244      REAL         AVALUE(MAXROW)
15245      INTEGER      NCTEXT(MAXROW)
15246      INTEGER      IDIGIT(MAXROW)
15247      INTEGER      NTOT(MAXROW)
15248      CHARACTER*60 ITITL2(MAXLIN,NUMCLI)
15249      CHARACTER*15 IVALUE(MAXROW,NUMCLI)
15250      CHARACTER*4  ITYPCO(NUMCLI)
15251      INTEGER      NCTIT2(MAXLIN,NUMCLI)
15252      INTEGER      NCVALU(MAXROW,NUMCLI)
15253      INTEGER      IWHTML(NUMCLI)
15254      INTEGER      IWRTF(NUMCLI)
15255      REAL         AMAT(MAXROW,NUMCLI)
15256      LOGICAL IFRST
15257      LOGICAL ILAST
15258      LOGICAL IFLAGA
15259      LOGICAL IFLAGB
15260C
15261      DOUBLE PRECISION XLOW
15262      DOUBLE PRECISION XUP
15263      DOUBLE PRECISION XMID
15264      DOUBLE PRECISION AE
15265      DOUBLE PRECISION RE
15266      COMMON/GR1COM/AFACTT,STATV2,ANU,NTEMP
15267      DOUBLE PRECISION GR1FUN
15268      DOUBLE PRECISION GR2FUN
15269      EXTERNAL GR1FUN
15270      EXTERNAL GR2FUN
15271C
15272C---------------------------------------------------------------------
15273C
15274      INCLUDE 'DPCOP2.INC'
15275C
15276      DATA ALPHA/
15277     1 0.0, 50.0, 75.0, 90.0, 95.0, 97.5, 99.0, 100.0/
15278C
15279C-----START POINT-----------------------------------------------------
15280C
15281      ISUBN1='DPGR'
15282      ISUBN2='U2  '
15283      IERROR='NO'
15284C
15285      STATVA=CPUMIN
15286      STATCD=CPUMIN
15287      PVAL=CPUMIN
15288      CUT0=CPUMIN
15289      CUT50=CPUMIN
15290      CUT75=CPUMIN
15291      CUT90=CPUMIN
15292      CUT95=CPUMIN
15293      CUT975=CPUMIN
15294      CUT99=CPUMIN
15295      CUT100=CPUMIN
15296      AFACT=1.0
15297      INDOUT=0
15298C
15299      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GRU2')THEN
15300        WRITE(ICOUT,999)
15301  999   FORMAT(1X)
15302        CALL DPWRST('XXX','WRIT')
15303        WRITE(ICOUT,51)
15304   51   FORMAT('**** AT THE BEGINNING OF DPGRU2--')
15305        CALL DPWRST('XXX','WRIT')
15306        WRITE(ICOUT,52)ISUBRO,IBUGA3,ICASAN,IGRU1S,IGRUTA
15307   52   FORMAT('ISUBRO,IBUGA3,ICASAN,IGRU1S,IGRUTA = ',5(A4,2X))
15308        CALL DPWRST('XXX','WRIT')
15309        WRITE(ICOUT,55)N,MAXNXT,PGRUSD,PGRUDF
15310   55   FORMAT('N,MAXNXT,PGRUSD,PGRUDF = ',2I8,2G15.7)
15311        CALL DPWRST('XXX','WRIT')
15312        DO56I=1,N
15313          WRITE(ICOUT,57)I,Y(I),X(I)
15314   57     FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
15315          CALL DPWRST('XXX','WRIT')
15316   56   CONTINUE
15317      ENDIF
15318C
15319C               ********************************************
15320C               **  STEP 11--                             **
15321C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
15322C               ********************************************
15323C
15324      ISTEPN='11'
15325      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GRU2')
15326     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15327C
15328      IF(N.LT.3)THEN
15329        WRITE(ICOUT,999)
15330        CALL DPWRST('XXX','WRIT')
15331        WRITE(ICOUT,1111)
15332 1111   FORMAT('***** ERROR IN GRUBBS TEST--')
15333        CALL DPWRST('XXX','WRIT')
15334        WRITE(ICOUT,1113)
15335 1113   FORMAT('      THE NUMBER OF OBSERVATIONS IS LESS THAN 3.')
15336        CALL DPWRST('XXX','WRIT')
15337        WRITE(ICOUT,1114)N
15338 1114   FORMAT('SAMPLE SIZE = ',I8)
15339        CALL DPWRST('XXX','WRIT')
15340        IERROR='YES'
15341        GOTO9000
15342      ENDIF
15343C
15344      HOLD=Y(1)
15345      DO1135I=2,N
15346        IF(Y(I).NE.HOLD)GOTO1139
15347 1135 CONTINUE
15348      WRITE(ICOUT,999)
15349      CALL DPWRST('XXX','WRIT')
15350      WRITE(ICOUT,1111)
15351      CALL DPWRST('XXX','WRIT')
15352      WRITE(ICOUT,1131)HOLD
15353 1131 FORMAT('      THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7)
15354      CALL DPWRST('XXX','WRIT')
15355      IERROR='YES'
15356      GOTO9000
15357 1139 CONTINUE
15358C
15359C               ******************************
15360C               **  STEP 21--               **
15361C               **  CARRY OUT CALCULATIONS  **
15362C               **  FOR    GRUBB's    TEST  **
15363C               ******************************
15364C
15365      ISTEPN='41'
15366      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15367C
15368      IWRITE='OFF'
15369      NM2=N-2
15370      CALL MINIM(Y,N,IWRITE,YMIN,IBUGA3,IERROR)
15371      CALL MAXIM(Y,N,IWRITE,YMAX,IBUGA3,IERROR)
15372      CALL MEAN(Y,N,IWRITE,YMEAN,IBUGA3,IERROR)
15373      CALL SD(Y,N,IWRITE,YSD,IBUGA3,IERROR)
15374      CALL STMOM3(Y,N,IWRITE,YSKEW,IBUGA3,IERROR)
15375      CALL STMOM4(Y,N,IWRITE,YKURT,IBUGA3,IERROR)
15376C
15377      INDMIN=-99
15378      INDMAX=99
15379      DO2105I=1,N
15380        IF(Y(I).EQ.YMIN)INDMIN=I
15381        IF(Y(I).EQ.YMAX)INDMAX=I
15382 2105 CONTINUE
15383C
15384C     2019/10: CASE FOR INDEPENDENT STANDARD DEVIATION
15385C
15386      IF(PGRUSD.GT.0.0)THEN
15387        YSDT=PGRUSD
15388        ICASA2='INDE'
15389      ELSE
15390        YSDT=YSD
15391        ICASA2='DATA'
15392      ENDIF
15393C
15394      RATIO1=(YMEAN-YMIN)/YSDT
15395      RATIO2=(YMAX-YMEAN)/YSDT
15396      STATV0=MAX(RATIO1,RATIO2)
15397      STATV1=RATIO1
15398      STATV2=RATIO2
15399C
15400      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GRU2')THEN
15401        WRITE(ICOUT,2111)YMEAN,YSD,YMIN,YMAX
15402 2111   FORMAT('YMEAN,YSD,YMIN,YMAX=',4G15.7)
15403        CALL DPWRST('XXX','BUG ')
15404        WRITE(ICOUT,2113)INDMIN,INDMAX,ICASA2
15405 2113   FORMAT('INDMIN,INDMAX,ICASA2=',2I8,2X,A4)
15406        CALL DPWRST('XXX','BUG ')
15407      ENDIF
15408C
15409C  3 CASES:
15410C
15411C  1) TEST BOTH MIN AND MAX
15412C  2) TEST MIN
15413C  3) TEST MAX
15414C
15415      IF(ICASAN.EQ.'GTES')THEN
15416        STATVA=STATV0
15417        AFACT=2.0
15418        APOSS=YMIN
15419        INDOUT=INDMIN
15420        IF(RATIO2.GT.RATIO1)THEN
15421          APOSS=YMAX
15422          INDOUT=INDMAX
15423        ENDIF
15424      ELSEIF(ICASAN.EQ.'GTMI')THEN
15425        STATVA=STATV1
15426        AFACT=1.0
15427        APOSS=YMIN
15428        INDOUT=INDMIN
15429      ELSEIF(ICASAN.EQ.'GTMA')THEN
15430        STATVA=STATV2
15431        AFACT=1.0
15432        APOSS=YMAX
15433        INDOUT=INDMAX
15434      ENDIF
15435C
15436      IF(ICASA2.EQ.'DATA')THEN
15437C
15438CCCCC   AN=REAL(N)
15439CCCCC   Q=STATVA**2
15440CCCCC   ANUM=AN*(AN-2.0)*Q
15441CCCCC   DENOM=(AN-1.0)**2 - AN*Q
15442CCCCC   AVAL=SQRT(ANUM/DENOM)
15443CCCCC   print *,'q,anum,denom,aval=',q,anum,denom,aval
15444CCCCC   CALL TCDF(AVAL,REAL(N-2),STATCD)
15445CCCCC   print *,'statcd=',statcd
15446CCCCC   PVAL=1.0 - STATCD
15447C
15448        IGRUT2=IGRUTA
15449        IF(IGRUT2.EQ.'FORM' .OR. IGRUT2.EQ.'ASTM')THEN
15450          CUT0=0.
15451C
15452C         MAY 2005.  DIVIDE CRITICAL VALUES BY 2.
15453C
15454          ALPHAT=.5
15455          P2=1.0 - (ALPHAT/REAL(N))/AFACT
15456          CALL TPPF(P2,REAL(NM2),T)
15457          CUT50=(REAL(N-1)/SQRT(REAL(N)))*SQRT(T*T/(REAL(NM2)+T*T))
15458C
15459          ALPHAT=.25
15460          P2=1.0 - (ALPHAT/REAL(N))/AFACT
15461          CALL TPPF(P2,REAL(NM2),T)
15462          CUT75=(REAL(N-1)/SQRT(REAL(N)))*SQRT(T*T/(REAL(NM2)+T*T))
15463C
15464          ALPHAT=.10
15465          P2=1.0 - (ALPHAT/REAL(N))/AFACT
15466          CALL TPPF(P2,REAL(NM2),T)
15467          CUT90=(REAL(N-1)/SQRT(REAL(N)))*SQRT(T*T/(REAL(NM2)+T*T))
15468C
15469          ALPHAT=.05
15470          P2=1.0 - (ALPHAT/REAL(N))/AFACT
15471          CALL TPPF(P2,REAL(NM2),T)
15472          CUT95=(REAL(N-1)/SQRT(REAL(N)))*SQRT(T*T/(REAL(NM2)+T*T))
15473C
15474          ALPHAT=.025
15475          P2=1.0 - (ALPHAT/REAL(N))/AFACT
15476          CALL TPPF(P2,REAL(NM2),T)
15477          CUT975=(REAL(N-1)/SQRT(REAL(N)))*SQRT(T*T/(REAL(NM2)+T*T))
15478C
15479          ALPHAT=.01
15480          P2=1.0 - (ALPHAT/REAL(N))/AFACT
15481          CALL TPPF(P2,REAL(NM2),T)
15482          CUT99=(REAL(N-1)/SQRT(REAL(N)))*SQRT(T*T/(REAL(NM2)+T*T))
15483C
15484          ALPHAT=0.0
15485          CUT100=REAL(N-1)/SQRT(REAL(N))
15486C
15487C         DETERMINE CDF AND PVALUE
15488C
15489          XLOW=0.0D0
15490          XUP=DBLE(CUT100)
15491          IF(STATVA.GE.CUT0 .AND. STATVA.LE.CUT50)THEN
15492            XLOW=0.0D0
15493            XUP=0.50D0
15494          ELSEIF(STATVA.GE.CUT50 .AND. STATVA.LE.CUT75)THEN
15495            XLOW=0.50D0
15496            XUP=0.75D0
15497          ELSEIF(STATVA.GE.CUT75 .AND. STATVA.LE.CUT90)THEN
15498            XLOW=0.75D0
15499            XUP=0.90D0
15500          ELSEIF(STATVA.GE.CUT90 .AND. STATVA.LE.CUT95)THEN
15501            XLOW=0.90D0
15502            XUP=0.95D0
15503          ELSEIF(STATVA.GE.CUT95 .AND. STATVA.LE.CUT975)THEN
15504            XLOW=0.95D0
15505            XUP=0.975D0
15506          ELSEIF(STATVA.GE.CUT975 .AND. STATVA.LE.CUT99)THEN
15507            XLOW=0.975D0
15508            XUP=0.99D0
15509          ELSEIF(STATVA.GE.CUT99 .AND. STATVA.LE.CUT100)THEN
15510            XLOW=DBLE(CUT99)
15511            XUP=DBLE(CUT100)
15512          ENDIF
15513C
15514          NTEMP=N
15515          AFACTT=AFACT
15516          STATV2=STATVA
15517          AE=1.D-6
15518          RE=1.D-6
15519          XMID=(XLOW+XUP)/2.0D0
15520          CALL DFZERO(GR1FUN,XLOW,XUP,XMID,RE,AE,IFLAG)
15521          STATCD=REAL(XLOW)
15522          PVAL=1.0 - STATCD
15523        ELSEIF(IGRUT2.EQ.'SIMU')THEN
15524          IOP='OPEN'
15525          IFLG1=0
15526          IFLG2=1
15527          IFLG3=0
15528          IFLG4=0
15529          IFLG5=0
15530          CALL DPAUFI(IOP,IFLG1,IFLG2,IFLG3,IFLG4,IFLG5,
15531     1                IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
15532     1                IBUGA3,ISUBRO,IERROR)
15533          IF(IERROR.EQ.'YES')GOTO9000
15534C
15535          NSIM=50000
15536          DO2200II=1,NSIM
15537            CALL NORRAN(N,ISEED,TEMP2)
15538            CALL MEAN(TEMP2,N,IWRITE,XMEANT,IBUGA3,IERROR)
15539            CALL SD(TEMP2,N,IWRITE,XSDT,IBUGA3,IERROR)
15540            CALL SORT(TEMP2,N,TEMP2)
15541            XMINT=TEMP2(1)
15542            XMAXT=TEMP2(N)
15543            RATIO1=(XMEANT-XMINT)/XSDT
15544            RATIO2=(XMAXT-XMEANT)/XSDT
15545            STATV0=MAX(RATIO1,RATIO2)
15546            STATV1=RATIO1
15547            STATV2=RATIO2
15548            IF(ICASAN.EQ.'GTES')THEN
15549              STATVT=STATV0
15550            ELSEIF(ICASAN.EQ.'GTMI')THEN
15551              STATVT=STATV1
15552            ELSEIF(ICASAN.EQ.'GTMA')THEN
15553              STATVT=STATV2
15554            ENDIF
15555            TEMP1(II)=STATVT
15556            WRITE(IOUNI2,'(E15.7)')STATVT
15557 2200     CONTINUE
15558C
15559          IOP='CLOS'
15560          CALL DPAUFI(IOP,IFLG1,IFLG2,IFLG3,IFLG4,IFLG5,
15561     1                IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
15562     1                IBUGA3,ISUBRO,IERROR)
15563          IF(IERROR.EQ.'YES')GOTO9000
15564C
15565          CALL SORT(TEMP1,NSIM,TEMP1)
15566C
15567          DO2210II=1,NUMALP
15568C
15569            IF(II.EQ.1)THEN
15570              CUT0=0.0
15571              GOTO2210
15572            ELSEIF(II.EQ.8)THEN
15573              CUT100=REAL(N-1)/SQRT(REAL(N))
15574              GOTO2210
15575            ENDIF
15576C
15577            ALPT=ALPHA(II)
15578            IF(ALPT.GT.1.0 .AND. ALPT.LT.100.0)ALPT=ALPT/100.0
15579            IF(ALPT.LE.0.0 .OR. ALPT.GT.1.0)THEN
15580              WRITE(ICOUT,999)
15581              CALL DPWRST('XXX','WRIT')
15582              WRITE(ICOUT,1111)
15583              CALL DPWRST('XXX','WRIT')
15584              WRITE(ICOUT,2211)ALPHA(II)
15585 2211         FORMAT('      INVALID VALUE OF ALPHA (',G15.7,'),')
15586              CALL DPWRST('XXX','WRIT')
15587              IERROR='YES'
15588              GOTO9000
15589            ENDIF
15590            IF(ALPT.LT.0.5)ALPT=1.0 - ALPT
15591            P100=100.0*ALPT
15592            CALL PERCEN(P100,TEMP1,NSIM,IWRITE,TEMP2,MAXNXT,
15593     1                  XPERC,IBUGA3,IERROR)
15594            IF(II.EQ.2)THEN
15595              CUT50=XPERC
15596            ELSEIF(II.EQ.3)THEN
15597              CUT75=XPERC
15598            ELSEIF(II.EQ.4)THEN
15599              CUT90=XPERC
15600            ELSEIF(II.EQ.5)THEN
15601              CUT95=XPERC
15602            ELSEIF(II.EQ.6)THEN
15603              CUT975=XPERC
15604            ELSEIF(II.EQ.7)THEN
15605              CUT99=XPERC
15606            ENDIF
15607 2210     CONTINUE
15608          IDIR='UPPE'
15609          CALL DPGOF8(TEMP1,NSIM,STATVA,PVAL,IDIR,IBUGA3,ISUBRO,IERROR)
15610          STATCD=1.0 - PVAL
15611        ENDIF
15612C
15613      ELSE
15614        IGRUT2=IGRUTA
15615        IF(IGRUT2.EQ.'SIMU' .AND. PGRUDF.LT.120.5)IGRUT2='FORM'
15616        IF(IGRUT2.EQ.'FORM')THEN
15617          IF(PGRUDF.EQ.CPUMAX)THEN
15618            IDF=10000
15619          ELSE
15620            IDF=INT(PGRUDF+0.5)
15621          ENDIF
15622          IF(IDF.GT.10000)IDF=10000
15623          ANU=REAL(PGRUDF)
15624          ACONST=SQRT(1.0 - 1.0/REAL(N))
15625C
15626          CUT0=0.
15627C
15628C         MAY 2005.  DIVIDE CRITICAL VALUES BY 2.
15629C
15630          ALPHAT=.5
15631          P2=1.0 - (ALPHAT/REAL(N))/AFACT
15632          CALL TPPF(P2,ANU,T)
15633          CUT50=T*ACONST
15634C
15635          ALPHAT=.25
15636          P2=1.0 - (ALPHAT/REAL(N))/AFACT
15637          CALL TPPF(P2,ANU,T)
15638          CUT75=T*ACONST
15639C
15640          ALPHAT=.10
15641          P2=1.0 - (ALPHAT/REAL(N))/AFACT
15642          CALL TPPF(P2,ANU,T)
15643          CUT90=T*ACONST
15644C
15645          ALPHAT=.05
15646          P2=1.0 - (ALPHAT/REAL(N))/AFACT
15647          CALL TPPF(P2,ANU,T)
15648          CUT95=T*ACONST
15649C
15650          ALPHAT=.025
15651          P2=1.0 - (ALPHAT/REAL(N))/AFACT
15652          CALL TPPF(P2,ANU,T)
15653          CUT975=T*ACONST
15654C
15655          ALPHAT=.01
15656          P2=1.0 - (ALPHAT/REAL(N))/AFACT
15657          CALL TPPF(P2,ANU,T)
15658          CUT99=T*ACONST
15659C
15660          ALPHAT=0.0
15661          CUT100=REAL(N-1)/SQRT(REAL(N))
15662C
15663C         DETERMINE CDF AND PVALUE
15664C
15665          XLOW=0.0D0
15666          XUP=DBLE(CUT100)
15667          IF(STATVA.GE.CUT0 .AND. STATVA.LE.CUT50)THEN
15668            XLOW=0.0D0
15669            XUP=0.50D0
15670          ELSEIF(STATVA.GE.CUT50 .AND. STATVA.LE.CUT75)THEN
15671            XLOW=0.50D0
15672            XUP=0.75D0
15673          ELSEIF(STATVA.GE.CUT75 .AND. STATVA.LE.CUT90)THEN
15674            XLOW=0.75D0
15675            XUP=0.90D0
15676          ELSEIF(STATVA.GE.CUT90 .AND. STATVA.LE.CUT95)THEN
15677            XLOW=0.90D0
15678            XUP=0.95D0
15679          ELSEIF(STATVA.GE.CUT95 .AND. STATVA.LE.CUT975)THEN
15680            XLOW=0.95D0
15681            XUP=0.975D0
15682          ELSEIF(STATVA.GE.CUT975 .AND. STATVA.LE.CUT99)THEN
15683            XLOW=0.975D0
15684            XUP=0.99D0
15685          ELSEIF(STATVA.GE.CUT99 .AND. STATVA.LE.CUT100)THEN
15686            XLOW=DBLE(CUT99)
15687            XUP=DBLE(CUT100)
15688          ENDIF
15689C
15690          NTEMP=N
15691          AFACTT=AFACT
15692          STATV2=STATVA
15693          AE=1.D-6
15694          RE=1.D-6
15695          XMID=(XLOW+XUP)/2.0D0
15696          CALL DFZERO(GR2FUN,XLOW,XUP,XMID,RE,AE,IFLAG)
15697          STATCD=REAL(XLOW)
15698          PVAL=1.0 - STATCD
15699        ELSEIF(IGRUT2.EQ.'SIMU')THEN
15700          IOP='OPEN'
15701          IFLG1=0
15702          IFLG2=1
15703          IFLG3=0
15704          IFLG4=0
15705          IFLG5=0
15706          CALL DPAUFI(IOP,IFLG1,IFLG2,IFLG3,IFLG4,IFLG5,
15707     1                IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
15708     1                IBUGA3,ISUBRO,IERROR)
15709          IF(IERROR.EQ.'YES')GOTO9000
15710C
15711          NSIM=50000
15712          DO2700II=1,NSIM
15713            CALL NORRAN(N,ISEED,TEMP2)
15714            DO2701JJ=1,N
15715              TEMP2(JJ)=YSDT*TEMP2(JJ)
15716 2701       CONTINUE
15717            CALL MEAN(TEMP2,N,IWRITE,XMEANT,IBUGA3,IERROR)
15718            CALL SORT(TEMP2,N,TEMP2)
15719            XMINT=TEMP2(1)
15720            XMAXT=TEMP2(N)
15721            RATIO1=(XMEANT-XMINT)/YSDT
15722            RATIO2=(XMAXT-XMEANT)/YSDT
15723            STATV0=MAX(RATIO1,RATIO2)
15724            STATV1=RATIO1
15725            STATV2=RATIO2
15726            IF(ICASAN.EQ.'GTES')THEN
15727              STATVT=STATV0
15728            ELSEIF(ICASAN.EQ.'GTMI')THEN
15729              STATVT=STATV1
15730            ELSEIF(ICASAN.EQ.'GTMA')THEN
15731              STATVT=STATV2
15732            ENDIF
15733            TEMP1(II)=STATVT
15734            WRITE(IOUNI2,'(E15.7)')STATVT
15735 2700     CONTINUE
15736C
15737          IOP='CLOS'
15738          CALL DPAUFI(IOP,IFLG1,IFLG2,IFLG3,IFLG4,IFLG5,
15739     1                IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
15740     1                IBUGA3,ISUBRO,IERROR)
15741          IF(IERROR.EQ.'YES')GOTO9000
15742C
15743          CALL SORT(TEMP1,NSIM,TEMP1)
15744C
15745          DO2710II=1,NUMALP
15746C
15747            IF(II.EQ.1)THEN
15748              CUT0=0.0
15749              GOTO2710
15750            ELSEIF(II.EQ.8)THEN
15751              CUT100=REAL(N-1)/SQRT(REAL(N))
15752              GOTO2710
15753            ENDIF
15754C
15755            ALPT=ALPHA(II)
15756            IF(ALPT.GT.1.0 .AND. ALPT.LT.100.0)ALPT=ALPT/100.0
15757            IF(ALPT.LE.0.0 .OR. ALPT.GT.1.0)THEN
15758              WRITE(ICOUT,999)
15759              CALL DPWRST('XXX','WRIT')
15760              WRITE(ICOUT,1111)
15761              CALL DPWRST('XXX','WRIT')
15762              WRITE(ICOUT,2211)ALPHA(II)
15763              CALL DPWRST('XXX','WRIT')
15764              IERROR='YES'
15765              GOTO9000
15766            ENDIF
15767            IF(ALPT.LT.0.5)ALPT=1.0 - ALPT
15768            P100=100.0*ALPT
15769            CALL PERCEN(P100,TEMP1,NSIM,IWRITE,TEMP2,MAXNXT,
15770     1                  XPERC,IBUGA3,IERROR)
15771            IF(II.EQ.2)THEN
15772              CUT50=XPERC
15773            ELSEIF(II.EQ.3)THEN
15774              CUT75=XPERC
15775            ELSEIF(II.EQ.4)THEN
15776              CUT90=XPERC
15777            ELSEIF(II.EQ.5)THEN
15778              CUT95=XPERC
15779            ELSEIF(II.EQ.6)THEN
15780              CUT975=XPERC
15781            ELSEIF(II.EQ.7)THEN
15782              CUT99=XPERC
15783            ENDIF
15784 2710     CONTINUE
15785          IDIR='UPPE'
15786          CALL DPGOF8(TEMP1,NSIM,STATVA,PVAL,IDIR,IBUGA3,ISUBRO,IERROR)
15787          STATCD=1.0 - PVAL
15788        ELSEIF(IGRUT2.EQ.'ASTM')THEN
15789        ENDIF
15790      ENDIF
15791C
15792      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GRU2')THEN
15793        WRITE(ICOUT,2221)STATVA
15794 2221   FORMAT('STATVA = ',G15.7)
15795        CALL DPWRST('XXX','BUG ')
15796        WRITE(ICOUT,2223)CUT0,CUT50,CUT75,CUT90
15797 2223   FORMAT('CUT0,CUT50,CUT75,CUT90=',4G15.7)
15798        CALL DPWRST('XXX','BUG ')
15799        WRITE(ICOUT,2225)CUT95,CUT975,CUT99,CUT100
15800 2225   FORMAT('CUT95,CUT975,CUT99,CUT100=',4G15.7)
15801        CALL DPWRST('XXX','BUG ')
15802      ENDIF
15803C
15804C
15805C               *********************************
15806C               **   STEP 42--                 **
15807C               **   WRITE OUT EVERYTHING      **
15808C               **   FOR GRUBB TEST            **
15809C               *********************************
15810C
15811      ISTEPN='42'
15812      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GRU2')
15813     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15814C
15815      IF(IPRINT.EQ.'OFF')GOTO9000
15816C
15817      NUMDIG=7
15818      IF(IFORSW.EQ.'1')NUMDIG=1
15819      IF(IFORSW.EQ.'2')NUMDIG=2
15820      IF(IFORSW.EQ.'3')NUMDIG=3
15821      IF(IFORSW.EQ.'4')NUMDIG=4
15822      IF(IFORSW.EQ.'5')NUMDIG=5
15823      IF(IFORSW.EQ.'6')NUMDIG=6
15824      IF(IFORSW.EQ.'7')NUMDIG=7
15825      IF(IFORSW.EQ.'8')NUMDIG=8
15826      IF(IFORSW.EQ.'9')NUMDIG=9
15827      IF(IFORSW.EQ.'0')NUMDIG=0
15828      IF(IFORSW.EQ.'E')NUMDIG=-2
15829      IF(IFORSW.EQ.'-2')NUMDIG=-2
15830      IF(IFORSW.EQ.'-3')NUMDIG=-3
15831      IF(IFORSW.EQ.'-4')NUMDIG=-4
15832      IF(IFORSW.EQ.'-5')NUMDIG=-5
15833      IF(IFORSW.EQ.'-6')NUMDIG=-6
15834      IF(IFORSW.EQ.'-7')NUMDIG=-7
15835      IF(IFORSW.EQ.'-8')NUMDIG=-8
15836      IF(IFORSW.EQ.'-9')NUMDIG=-9
15837C
15838      IF(ICASAN.EQ.'GTES')THEN
15839        ITITLE='Grubbs Test for Outliers: Test for Minimum and Maximum'
15840        NCTITL=54
15841      ELSEIF(ICASAN.EQ.'GTMI')THEN
15842        ITITLE='Grubbs Test for Outliers: Test for Minimum'
15843        NCTITL=42
15844      ELSEIF(ICASAN.EQ.'GTMA')THEN
15845        ITITLE='Grubbs Test for Outliers: Test for Maximum'
15846        NCTITL=42
15847      ENDIF
15848      ITITLZ='(Assumption: Normality)'
15849      NCTITZ=23
15850C
15851      ICNT=1
15852      ITEXT(ICNT)=' '
15853      NCTEXT(ICNT)=0
15854      AVALUE(ICNT)=0.0
15855      IDIGIT(ICNT)=-1
15856      ICNT=ICNT+1
15857      ITEXT(ICNT)='Response Variable: '
15858      WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1)(1:4)
15859      WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1)(1:4)
15860      NCTEXT(ICNT)=27
15861      AVALUE(ICNT)=0.0
15862      IDIGIT(ICNT)=-1
15863C
15864      IF(NREPL.GT.0)THEN
15865        NRESP=1
15866        IADD=NLABID+NRESP
15867        DO4101I=1,NREPL
15868          ICNT=ICNT+1
15869          ITEMP=I+IADD
15870          ITEXT(ICNT)='Factor Variable  : '
15871          WRITE(ITEXT(ICNT)(17:17),'(I1)')I
15872          WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(ITEMP)(1:4)
15873          WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(ITEMP)(1:4)
15874          NCTEXT(ICNT)=27
15875          AVALUE(ICNT)=PID(ITEMP)
15876          IDIGIT(ICNT)=NUMDIG
15877 4101   CONTINUE
15878      ENDIF
15879C
15880      ICNT=ICNT+1
15881      ITEXT(ICNT)=' '
15882      NCTEXT(ICNT)=1
15883      AVALUE(ICNT)=0.0
15884      IDIGIT(ICNT)=-1
15885C
15886      ICNT=ICNT+1
15887      ITEXT(ICNT)='H0: There are no outliers'
15888      NCTEXT(ICNT)=25
15889      AVALUE(ICNT)=0.0
15890      IDIGIT(ICNT)=-1
15891      ICNT=ICNT+1
15892      IF(ICASAN.EQ.'GTES')THEN
15893        ITEXT(ICNT)='Ha: The extreme point is an outlier'
15894        NCTEXT(ICNT)=35
15895      ELSEIF(ICASAN.EQ.'GTMI')THEN
15896        ITEXT(ICNT)='Ha: The minimum point is an outlier'
15897        NCTEXT(ICNT)=35
15898      ELSEIF(ICASAN.EQ.'GTMA')THEN
15899        ITEXT(ICNT)='Ha: The maximum point is an outlier'
15900        NCTEXT(ICNT)=35
15901      ENDIF
15902      AVALUE(ICNT)=0.0
15903      IDIGIT(ICNT)=-1
15904C
15905      ICNT=ICNT+1
15906      ITEXT(ICNT)='Potential Outlier Value Tested:'
15907      NCTEXT(ICNT)=31
15908      AVALUE(ICNT)=Y(INDOUT)
15909      IDIGIT(ICNT)=NUMDIG
15910C
15911      ICNT=ICNT+1
15912      ITEXT(ICNT)=' '
15913      NCTEXT(ICNT)=1
15914      AVALUE(ICNT)=0.0
15915      IDIGIT(ICNT)=-1
15916      ICNT=ICNT+1
15917      ITEXT(ICNT)='Summary Statistics:'
15918      NCTEXT(ICNT)=19
15919      AVALUE(ICNT)=0.0
15920      IDIGIT(ICNT)=-1
15921      ICNT=ICNT+1
15922      ITEXT(ICNT)='Number of Observations:'
15923      NCTEXT(ICNT)=23
15924      AVALUE(ICNT)=REAL(N)
15925      IDIGIT(ICNT)=0
15926      ICNT=ICNT+1
15927      ITEXT(ICNT)='Sample Minimum:'
15928      NCTEXT(ICNT)=15
15929      AVALUE(ICNT)=YMIN
15930      IDIGIT(ICNT)=NUMDIG
15931      ICNT=ICNT+1
15932      ITEXT(ICNT)='ID for Sample Minimum:'
15933      NCTEXT(ICNT)=22
15934      AVALUE(ICNT)=X(INDMIN)
15935      IDIGIT(ICNT)=0
15936      ICNT=ICNT+1
15937      ITEXT(ICNT)='Sample Maximum:'
15938      NCTEXT(ICNT)=15
15939      AVALUE(ICNT)=YMAX
15940      IDIGIT(ICNT)=NUMDIG
15941      ICNT=ICNT+1
15942      ITEXT(ICNT)='ID for Sample Maximum:'
15943      NCTEXT(ICNT)=22
15944      AVALUE(ICNT)=X(INDMAX)
15945      IDIGIT(ICNT)=0
15946      ICNT=ICNT+1
15947      ITEXT(ICNT)='Sample Mean:'
15948      NCTEXT(ICNT)=12
15949      AVALUE(ICNT)=YMEAN
15950      IDIGIT(ICNT)=NUMDIG
15951      ICNT=ICNT+1
15952      ITEXT(ICNT)='Sample SD:'
15953      NCTEXT(ICNT)=10
15954      AVALUE(ICNT)=YSD
15955      IDIGIT(ICNT)=NUMDIG
15956      ICNT=ICNT+1
15957      ITEXT(ICNT)='Sample Skewness:'
15958      NCTEXT(ICNT)=16
15959      AVALUE(ICNT)=YSKEW
15960      IDIGIT(ICNT)=NUMDIG
15961      ICNT=ICNT+1
15962      ITEXT(ICNT)='Sample Kurtosis:'
15963      NCTEXT(ICNT)=16
15964      AVALUE(ICNT)=YKURT
15965      IDIGIT(ICNT)=NUMDIG
15966      ICNT=ICNT+1
15967      ITEXT(ICNT)=' '
15968      NCTEXT(ICNT)=1
15969      AVALUE(ICNT)=0.0
15970      IDIGIT(ICNT)=-1
15971      IF(PGRUSD.GT.0.0)THEN
15972        ICNT=ICNT+1
15973        ITEXT(ICNT)='User Specified SD:'
15974        NCTEXT(ICNT)=18
15975        AVALUE(ICNT)=PGRUSD
15976        IDIGIT(ICNT)=NUMDIG
15977        ICNT=ICNT+1
15978        ITEXT(ICNT)='User Specified Degrees of Freedom:'
15979        NCTEXT(ICNT)=34
15980        IF(PGRUDF.EQ.CPUMAX)THEN
15981          IDF=10000
15982        ELSE
15983          IDF=INT(PGRUDF)
15984        ENDIF
15985        AVALUE(ICNT)=REAL(IDF)
15986        IDIGIT(ICNT)=NUMDIG
15987      ENDIF
15988      ICNT=ICNT+1
15989      ITEXT(ICNT)=' '
15990      NCTEXT(ICNT)=1
15991      AVALUE(ICNT)=0.0
15992      IDIGIT(ICNT)=-1
15993      ICNT=ICNT+1
15994      ITEXT(ICNT)='Grubbs Test Statistic Value:'
15995      NCTEXT(ICNT)=28
15996      AVALUE(ICNT)=STATVA
15997      IDIGIT(ICNT)=NUMDIG
15998C
15999      ICNT=ICNT+1
16000      ITEXT(ICNT)='CDF Value:'
16001      NCTEXT(ICNT)=10
16002      AVALUE(ICNT)=STATCD
16003      IDIGIT(ICNT)=NUMDIG
16004      ICNT=ICNT+1
16005      ITEXT(ICNT)='P-Value:'
16006      NCTEXT(ICNT)=7
16007      AVALUE(ICNT)=PVAL
16008      IDIGIT(ICNT)=NUMDIG
16009      ICNT=ICNT+1
16010      ITEXT(ICNT)=' '
16011      NCTEXT(ICNT)=1
16012      AVALUE(ICNT)=0.0
16013      IDIGIT(ICNT)=-1
16014C
16015      NUMROW=ICNT
16016      DO4210I=1,NUMROW
16017        NTOT(I)=15
16018 4210 CONTINUE
16019C
16020      IFRST=.TRUE.
16021      ILAST=.TRUE.
16022C
16023      ISTEPN='42A'
16024      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GRU2')
16025     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16026C
16027      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
16028     1            AVALUE,IDIGIT,
16029     1            NTOT,NUMROW,
16030     1            ICAPSW,ICAPTY,ILAST,IFRST,
16031     1            ISUBRO,IBUGA3,IERROR)
16032C
16033      ISTEPN='42B'
16034      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GRU2')
16035     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16036C
16037      ITITLE=' '
16038      NCTITL=0
16039C
16040      ITITL9=' '
16041      NCTIT9=0
16042      ITITLE(1:44)='Percent Points of the Reference Distribution'
16043      NCTITL=44
16044      NUMLIN=1
16045      NUMROW=8
16046      NUMCOL=3
16047      ITITL2(1,1)='Percent Point'
16048      ITITL2(1,2)=' '
16049      ITITL2(1,3)='Value'
16050      NCTIT2(1,1)=13
16051      NCTIT2(1,2)=1
16052      NCTIT2(1,3)=5
16053C
16054      NMAX=0
16055      DO4221I=1,NUMCOL
16056        VALIGN(I)='b'
16057        ALIGN(I)='r'
16058        NTOT(I)=15
16059        IF(I.EQ.2)NTOT(I)=5
16060        NMAX=NMAX+NTOT(I)
16061        IDIGIT(I)=NUMDIG
16062        ITYPCO(I)='NUME'
16063 4221 CONTINUE
16064      ITYPCO(2)='ALPH'
16065      IDIGIT(1)=1
16066      IDIGIT(3)=3
16067      DO4223I=1,NUMROW
16068        DO4225J=1,NUMCOL
16069          NCVALU(I,J)=0
16070          IVALUE(I,J)=' '
16071          NCVALU(I,J)=0
16072          AMAT(I,J)=0.0
16073          IF(J.EQ.1)THEN
16074            AMAT(I,J)=ALPHA(I)
16075          ELSEIF(J.EQ.2)THEN
16076            IVALUE(I,J)='='
16077            NCVALU(I,J)=1
16078          ELSEIF(J.EQ.3)THEN
16079            IF(I.EQ.1)THEN
16080              AMAT(I,J)=RND(CUT0,IDIGIT(J))
16081            ELSEIF(I.EQ.2)THEN
16082              AMAT(I,J)=RND(CUT50,IDIGIT(J))
16083            ELSEIF(I.EQ.3)THEN
16084              AMAT(I,J)=RND(CUT75,IDIGIT(J))
16085            ELSEIF(I.EQ.4)THEN
16086              AMAT(I,J)=RND(CUT90,IDIGIT(J))
16087            ELSEIF(I.EQ.5)THEN
16088              AMAT(I,J)=RND(CUT95,IDIGIT(J))
16089            ELSEIF(I.EQ.6)THEN
16090              AMAT(I,J)=RND(CUT975,IDIGIT(J))
16091            ELSEIF(I.EQ.7)THEN
16092              AMAT(I,J)=RND(CUT99,IDIGIT(J))
16093            ELSEIF(I.EQ.8)THEN
16094              AMAT(I,J)=RND(CUT100,IDIGIT(J))
16095            ENDIF
16096          ENDIF
16097 4225   CONTINUE
16098 4223 CONTINUE
16099C
16100      IWHTML(1)=150
16101      IWHTML(2)=50
16102      IWHTML(3)=150
16103      IWRTF(1)=2000
16104      IWRTF(2)=IWRTF(1)+500
16105      IWRTF(3)=IWRTF(2)+2000
16106      IFRST=.TRUE.
16107      ILAST=.FALSE.
16108C
16109      ISTEPN='42C'
16110      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GRU2')
16111     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16112C
16113      CALL DPDTA4(ITITL9,NCTIT9,
16114     1            ITITLE,NCTITL,ITITL2,NCTIT2,
16115     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
16116     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW,
16117     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
16118     1            ICAPSW,ICAPTY,IFRST,ILAST,
16119     1            ISUBRO,IBUGA3,IERROR)
16120C
16121      ISTEPN='42D'
16122      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GRU2')
16123     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16124C
16125      CDF1=CUT90
16126      CDF2=CUT95
16127      CDF3=CUT975
16128      CDF4=CUT99
16129C
16130      ITITL9=' '
16131      NCTIT9=0
16132      ITITLE='Conclusions (Upper 1-Tailed Test)'
16133      NCTITL=33
16134      NUMLIN=1
16135      NUMROW=4
16136      NUMCOL=4
16137      ITITL2(1,1)='Alpha'
16138      ITITL2(1,2)='CDF'
16139      ITITL2(1,3)='Critical Value'
16140      ITITL2(1,4)='Conclusion'
16141      NCTIT2(1,1)=5
16142      NCTIT2(1,2)=3
16143      NCTIT2(1,3)=14
16144      NCTIT2(1,4)=10
16145C
16146      NMAX=0
16147      DO4321I=1,NUMCOL
16148        VALIGN(I)='b'
16149        ALIGN(I)='r'
16150        NTOT(I)=15
16151        IF(I.EQ.1 .OR. I.EQ.2)NTOT(I)=7
16152        IF(I.EQ.3)NTOT(I)=17
16153        NMAX=NMAX+NTOT(I)
16154        IDIGIT(I)=3
16155        ITYPCO(I)='ALPH'
16156 4321 CONTINUE
16157      ITYPCO(3)='NUME'
16158      IDIGIT(1)=0
16159      IDIGIT(2)=0
16160      DO4323I=1,NUMROW
16161        DO4325J=1,NUMCOL
16162          NCVALU(I,J)=0
16163          IVALUE(I,J)=' '
16164          NCVALU(I,J)=0
16165          AMAT(I,J)=0.0
16166 4325   CONTINUE
16167 4323 CONTINUE
16168      IVALUE(1,1)='10%'
16169      IVALUE(2,1)='5%'
16170      IVALUE(3,1)='2.5%'
16171      IVALUE(4,1)='1%'
16172      IVALUE(1,2)='90%'
16173      IVALUE(2,2)='95%'
16174      IVALUE(3,2)='97.5%'
16175      IVALUE(4,2)='99%'
16176      NCVALU(1,1)=3
16177      NCVALU(2,1)=2
16178      NCVALU(3,1)=4
16179      NCVALU(4,1)=2
16180      NCVALU(1,2)=3
16181      NCVALU(2,2)=3
16182      NCVALU(3,2)=5
16183      NCVALU(4,2)=3
16184      IVALUE(1,4)='Accept H0'
16185      IVALUE(2,4)='Accept H0'
16186      IVALUE(3,4)='Accept H0'
16187      IVALUE(4,4)='Accept H0'
16188      NCVALU(1,4)=9
16189      NCVALU(2,4)=9
16190      NCVALU(3,4)=9
16191      NCVALU(4,4)=9
16192      IF(STATVA.GT.CDF1)IVALUE(1,4)='Reject H0'
16193      IF(STATVA.GT.CDF2)IVALUE(2,4)='Reject H0'
16194      IF(STATVA.GT.CDF3)IVALUE(3,4)='Reject H0'
16195      IF(STATVA.GT.CDF4)IVALUE(4,4)='Reject H0'
16196      AMAT(1,3)=RND(CDF1,IDIGIT(3))
16197      AMAT(2,3)=RND(CDF2,IDIGIT(3))
16198      AMAT(3,3)=RND(CDF3,IDIGIT(3))
16199      AMAT(4,3)=RND(CDF4,IDIGIT(3))
16200C
16201      IWHTML(1)=150
16202      IWHTML(2)=150
16203      IWHTML(3)=150
16204      IWHTML(4)=150
16205      IWRTF(1)=1500
16206      IWRTF(2)=IWRTF(1)+1500
16207      IWRTF(3)=IWRTF(2)+2000
16208      IWRTF(4)=IWRTF(3)+2000
16209      IFRST=.FALSE.
16210      ILAST=.TRUE.
16211C
16212      ISTEPN='42E'
16213      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GRU2')
16214     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16215C
16216      CALL DPDTA4(ITITL9,NCTIT9,
16217     1            ITITLE,NCTITL,ITITL2,NCTIT2,
16218     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
16219     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW,
16220     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
16221     1            ICAPSW,ICAPTY,IFRST,ILAST,
16222     1            ISUBRO,IBUGA3,IERROR)
16223C
16224      IF(IGRUT2.EQ.'SIMU')THEN
16225        IRTFMD='OFF'
16226        IFNTSZ=-1
16227        IFLAGA=.TRUE.
16228        IFLAGB=.TRUE.
16229        ISIZE=-1
16230        ITITLE='Critical Values Based on 50,000 Simulations'
16231        NCTEMP=43
16232        NTOTAL=NCTEMP
16233        NBLNK1=2
16234        NBLNK2=1
16235        ITYPE=2
16236        AVAL=CPUMIN
16237        CALL DPDTXT(ITITLE,NCTEMP,AVAL,NUMDIG,
16238     1              NTOTAL,NBLNK1,NBLNK2,IFLAGA,IFLAGB,ISIZE,
16239     1              ICAPSW,ICAPTY,ITYPE,
16240     1              ISUBRO,IBUGA3,IERROR)
16241        ISIZE=-99
16242        IFNTSZ=0
16243      ENDIF
16244C
16245      ISTEPN='42F'
16246      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GRU2')
16247     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16248C
16249C               *****************
16250C               **  STEP 90--  **
16251C               **  EXIT       **
16252C               *****************
16253C
16254 9000 CONTINUE
16255      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GRU2')THEN
16256        WRITE(ICOUT,999)
16257        CALL DPWRST('XXX','WRIT')
16258        WRITE(ICOUT,9011)
16259 9011   FORMAT('***** AT THE END       OF DPGRU2--')
16260        CALL DPWRST('XXX','WRIT')
16261        WRITE(ICOUT,9012)N,IERROR
16262 9012   FORMAT('N,IERROR = ',I8,2X,A4)
16263        CALL DPWRST('XXX','WRIT')
16264        WRITE(ICOUT,9013)STATVA,STATCD,PVAL
16265 9013   FORMAT('STATVA,STATCD,PVAL = ',3G15.7)
16266        CALL DPWRST('XXX','WRIT')
16267      ENDIF
16268C
16269      RETURN
16270      END
16271      SUBROUTINE DPGRU3(X,N,IWRITE,PSTAMV,XGRUB,XCDF,XDIR,XIND,
16272     1                  ISUBRO,IBUGA3,IERROR)
16273C
16274C     PURPOSE--THIS SUBROUTINE COMPUTES THE GRUBB STATISTIC (AND
16275C              ALTERNATIVELY THE P-VALUE, THE DIRECTION (MIN OR MAX),
16276C              AND THE INDEX OF THE MOST OUTLYING POINT).
16277C              THE GRUBB STATISTIC IDENTIFIES THE MOST "OUTLYING"
16278C              POINT BASED ON THE UNDERLYING ASSUMPTION OF NORMALITY.
16279C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
16280C                                (UNSORTED OR SORTED) OBSERVATIONS.
16281C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
16282C                                IN THE VECTOR X.
16283C     OUTPUT ARGUMENTS--XGRUB  = THE SINGLE PRECISION VALUE OF THE
16284C                                COMPUTED GRUBB STATISTIC.
16285C                     --XCDF   = THE SINGLE PRECISION VALUE OF THE
16286C                                COMPUTED CDF OF THE TEST STATISTIC.
16287C                     --XIND   = THE SINGLE PRECISION VALUE OF THE
16288C                                COMPUTED INDEX OF THE SAMPLE MINIMUM.
16289C                     --XDIR   = +1 IF MOST OUTLYING POINT IS A
16290C                                MAXIMUM AND -1 IF MOST OUTLYING POINT
16291C                                IS A MINIMUM.
16292C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
16293C             GRUBB STATISTIC.
16294C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
16295C                   OF N FOR THIS SUBROUTINE.
16296C     OTHER DATAPAC   SUBROUTINES NEEDED--MINIM, MAXIM, MEAN, SD.
16297C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
16298C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
16299C     LANGUAGE--ANSI FORTRAN (1977)
16300C     WRITTEN BY--JAMES J. FILLIBEN
16301C                 STATISTICAL ENGINEERING DIVISION
16302C                 INFORMATION TECHNOLOGY LABORATORY
16303C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
16304C                 GAITHERSBURG, MD 20899-8980
16305C                 PHONE--301-975-2855
16306C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
16307C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
16308C     LANGUAGE--ANSI FORTRAN (1977)
16309C     VERSION NUMBER--2009.2
16310C     ORIGINAL VERSION--FEBRUARY  2009.
16311C
16312C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
16313C
16314      CHARACTER*4 IWRITE
16315      CHARACTER*4 IWRTSV
16316      CHARACTER*4 ISUBRO
16317      CHARACTER*4 IBUGA3
16318      CHARACTER*4 IERROR
16319C
16320      CHARACTER*4 ISUBN1
16321      CHARACTER*4 ISUBN2
16322C
16323C---------------------------------------------------------------------
16324C
16325      DIMENSION X(*)
16326C
16327C---------------------------------------------------------------------
16328C
16329      INCLUDE 'DPCOP2.INC'
16330C
16331C-----START POINT-----------------------------------------------------
16332C
16333      ISUBN1='DPGR'
16334      ISUBN2='U3  '
16335      IERROR='NO'
16336      IWRTSV=IWRITE
16337C
16338      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GRU3')THEN
16339        WRITE(ICOUT,999)
16340  999   FORMAT(1X)
16341        CALL DPWRST('XXX','BUG ')
16342        WRITE(ICOUT,51)
16343   51   FORMAT('***** AT THE BEGINNING OF DPGRU3--')
16344        CALL DPWRST('XXX','BUG ')
16345        WRITE(ICOUT,52)IBUGA3
16346   52   FORMAT('IBUGA3 = ',A4)
16347        CALL DPWRST('XXX','BUG ')
16348        WRITE(ICOUT,53)N
16349   53   FORMAT('N = ',I8)
16350        CALL DPWRST('XXX','BUG ')
16351        DO55I=1,N
16352          WRITE(ICOUT,56)I,X(I)
16353   56     FORMAT('I,X(I) = ',I8,G15.7)
16354          CALL DPWRST('XXX','BUG ')
16355   55   CONTINUE
16356      ENDIF
16357C
16358C               *******************************
16359C               **  COMPUTE GRUBB STATISTIC  **
16360C               *******************************
16361C
16362C               ********************************************
16363C               **  STEP 1--                              **
16364C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
16365C               ********************************************
16366C
16367      AN=N
16368C
16369      IF(N.LT.2)THEN
16370        IERROR='YES'
16371        WRITE(ICOUT,999)
16372        CALL DPWRST('XXX','BUG ')
16373        WRITE(ICOUT,111)
16374  111   FORMAT('***** ERROR IN GRUBB STATISTIC--')
16375        CALL DPWRST('XXX','BUG ')
16376        WRITE(ICOUT,112)
16377  112   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS FOR THE ',
16378     1         'RESPONSE')
16379        CALL DPWRST('XXX','BUG ')
16380        WRITE(ICOUT,113)
16381  113   FORMAT('      VARIABLE MUST BE 2 OR LARGER.')
16382        CALL DPWRST('XXX','BUG ')
16383        WRITE(ICOUT,116)
16384  116   FORMAT('      SUCH WAS NOT THE CASE HERE.')
16385        CALL DPWRST('XXX','BUG ')
16386        WRITE(ICOUT,117)N
16387  117   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
16388     1         '.')
16389        CALL DPWRST('XXX','BUG ')
16390        GOTO9000
16391      ENDIF
16392C
16393C               *****************************************
16394C               **  STEP 2--                           **
16395C               **  COMPUTE THE GRUBB STATISTIC.       **
16396C               *****************************************
16397C
16398      IWRITE='OFF'
16399      NM2=N-2
16400      CALL MINIM(X,N,IWRITE,XMIN,IBUGA3,IERROR)
16401      CALL MAXIM(X,N,IWRITE,XMAX,IBUGA3,IERROR)
16402      CALL MEAN(X,N,IWRITE,XMEAN,IBUGA3,IERROR)
16403      CALL SD(X,N,IWRITE,XSD,IBUGA3,IERROR)
16404C
16405      IF(XSD.LE.0.0)THEN
16406        IERROR='YES'
16407        WRITE(ICOUT,999)
16408        CALL DPWRST('XXX','BUG ')
16409        WRITE(ICOUT,111)
16410        CALL DPWRST('XXX','BUG ')
16411        WRITE(ICOUT,212)
16412  212   FORMAT('      THE COMPUTED STANDARD DEVIATION WAS ZERO.')
16413        CALL DPWRST('XXX','BUG ')
16414        XGRUB=0.0
16415        XIND=0.0
16416        XDIR=0.0
16417        PVAL=0.0
16418        GOTO9000
16419      ENDIF
16420C
16421      RATIO1=(XMEAN-XMIN)/XSD
16422      RATIO2=(XMAX-XMEAN)/XSD
16423      IF(RATIO1.GT.RATIO2)THEN
16424        XGRUB=RATIO2
16425        XDIR=1.0
16426        CALL MAXIND(X,N,IWRITE,PSTAMV,XIND,ISUBRO,IBUGA3,IERROR)
16427      ELSE
16428        XGRUB=RATIO1
16429        XDIR=-1.0
16430        CALL MININD(X,N,IWRITE,PSTAMV,XIND,ISUBRO,IBUGA3,IERROR)
16431      ENDIF
16432C
16433      STATVA=XGRUB
16434      AFACT=2.0
16435      Q=(STATVA*SQRT(REAL(N))/REAL(N-1))**2
16436      IF(Q.GE.1.0)THEN
16437        XCDF=1.0
16438      ELSE
16439        T=SQRT((Q/(1.0-Q))*REAL(NM2))
16440        T2=-T
16441        CALL TCDF(T2,REAL(NM2),CDF)
16442        ALPHA=2.0*REAL(N)*CDF
16443        XCDF=1.0-ALPHA
16444      ENDIF
16445C
16446C               *******************************
16447C               **  STEP 3--                 **
16448C               **  WRITE OUT A LINE         **
16449C               **  OF SUMMARY INFORMATION.  **
16450C               *******************************
16451C
16452      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
16453        WRITE(ICOUT,999)
16454        CALL DPWRST('XXX','BUG ')
16455        WRITE(ICOUT,811)N,XGRUB
16456  811   FORMAT('THE VALUE OF THE GRUBB STATISTIC OF THE ',I8,
16457     1         ' OBSERVATIONS = ',G15.7)
16458        CALL DPWRST('XXX','BUG ')
16459      ENDIF
16460C
16461C               *****************
16462C               **  STEP 90--  **
16463C               **  EXIT.      **
16464C               *****************
16465C
16466 9000 CONTINUE
16467C
16468      IWRITE=IWRTSV
16469C
16470      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GRU3')THEN
16471        WRITE(ICOUT,999)
16472        CALL DPWRST('XXX','BUG ')
16473        WRITE(ICOUT,9011)
16474 9011   FORMAT('***** AT THE END       OF DPGRU3--')
16475        CALL DPWRST('XXX','BUG ')
16476        WRITE(ICOUT,9012)IBUGA3,IERROR
16477 9012   FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
16478        CALL DPWRST('XXX','BUG ')
16479        WRITE(ICOUT,9013)N
16480 9013   FORMAT('N = ',I8)
16481        CALL DPWRST('XXX','BUG ')
16482        WRITE(ICOUT,9015)XMIN,XMAX,XMEAN,XSD
16483 9015   FORMAT('XMIN,XMAX,XMEAN,XSD = ',4G15.7)
16484        CALL DPWRST('XXX','BUG ')
16485        WRITE(ICOUT,9016)XGRUB,XCDF,XIND,XDIR
16486 9016   FORMAT('XGRUB,XCDF,XIND,XDIR = ',4G15.7)
16487        CALL DPWRST('XXX','BUG ')
16488      ENDIF
16489C
16490      RETURN
16491      END
16492      SUBROUTINE DPGRU4(STATVA,STATCD,PVAL,
16493     1                  CUT0,CUT50,CUT75,CUT90,CUT95,
16494     1                  CUT975,CUT99,CUT100,
16495     1                  IFLAGU,IFRST,ILAST,ICASPL,
16496     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
16497C
16498C     PURPOSE--UTILITY ROUTINE USED BY DPGRUB.  THIS ROUTINE
16499C              UPDATES THE PARAMETERS "STATVAL", "STATCDF", AND
16500C              "PVALUE" AFTER A GRUBBS TEST.
16501C     WRITTEN BY--ALAN HECKERT
16502C                 STATISTICAL ENGINEERING DIVISION
16503C                 INFORMATION TECHNOLOGY LABORAOTRY
16504C                 NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY
16505C                 GAITHERSBURG, MD 20899-8980
16506C                 PHONE--301-975-2899
16507C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
16508C           OF THE NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY.
16509C     LANGUAGE--ANSI FORTRAN (1977)
16510C     VERSION NUMBER--2009/10
16511C     ORIGINAL VERSION--OCTOBER   2009.
16512C
16513C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
16514C
16515      CHARACTER*4 IFLAGU
16516      CHARACTER*4 ICASPL
16517      CHARACTER*4 IBUGA2
16518      CHARACTER*4 IBUGA3
16519      CHARACTER*4 ISUBRO
16520      CHARACTER*4 IERROR
16521C
16522      LOGICAL IFRST
16523      LOGICAL ILAST
16524C
16525      CHARACTER*4 IH
16526      CHARACTER*4 IH2
16527      CHARACTER*4 ISUBN0
16528      CHARACTER*4 ISUBN1
16529      CHARACTER*4 ISUBN2
16530      CHARACTER*4 ISTEPN
16531      CHARACTER*4 IOP
16532C
16533      SAVE IOUNI1
16534C
16535C-----COMMON VARIABLES (GENERAL)--------------------------------------
16536C
16537      INCLUDE 'DPCOPA.INC'
16538      INCLUDE 'DPCOHK.INC'
16539      INCLUDE 'DPCOHO.INC'
16540      INCLUDE 'DPCOP2.INC'
16541C
16542C-----START POINT-----------------------------------------------------
16543C
16544      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'GRU4')THEN
16545        ISTEPN='1'
16546        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16547        WRITE(ICOUT,999)
16548  999   FORMAT(1X)
16549        CALL DPWRST('XXX','BUG ')
16550        WRITE(ICOUT,51)
16551   51   FORMAT('***** AT THE BEGINNING OF DPGRU4--')
16552        CALL DPWRST('XXX','BUG ')
16553        WRITE(ICOUT,53)ICASPL,STATVA,STATCD,PVAL
16554   53   FORMAT('ICASPL,STATVA,STATCD,PVAL = ',A4,2X,3G15.7)
16555        CALL DPWRST('XXX','BUG ')
16556        WRITE(ICOUT,54)CUT0,CUT50,CUT75,CUT90
16557   54   FORMAT('CUT0,CUT50,CUT75,CUT90 = ',4G15.7)
16558        CALL DPWRST('XXX','BUG ')
16559        WRITE(ICOUT,55)CUT95,CUT975,CUT99,CUT100
16560   55   FORMAT('CUT95,CUT975,CUT99,CUT100 = ',4G15.7)
16561        CALL DPWRST('XXX','BUG ')
16562      ENDIF
16563C
16564      IF(IFLAGU.EQ.'FILE')THEN
16565C
16566        IF(IFRST)THEN
16567          IOP='OPEN'
16568          IFLAG1=1
16569          IFLAG2=0
16570          IFLAG3=0
16571          IFLAG4=0
16572          IFLAG5=0
16573          CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
16574     1                IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
16575     1                IBUGA3,ISUBRO,IERROR)
16576          IF(IERROR.EQ.'YES')GOTO9000
16577C
16578          WRITE(IOUNI1,295)
16579  295     FORMAT(11X,'STATVAL',8X,'STATCDF',8X,'PVALUE',
16580     1           7X,'CUTOFF0',7X,'CUTOFF50',7X,'CUTOFF75',
16581     1           7X,'CUTOFF90',7X,'CUTOFF95',7X,'CUTOF975',
16582     1           7X,'CUTOFF99',7X,'CUTOF100')
16583        ENDIF
16584        WRITE(IOUNI1,299)STATVA,STATCD,PVAL,CUT0,CUT50,CUT75,
16585     1                   CUT90,CUT95,CUT975,CUT99,CUT100
16586  299   FORMAT(11E15.7)
16587      ELSEIF(IFLAGU.EQ.'ON')THEN
16588        IF(STATVA.NE.CPUMIN)THEN
16589          IH='STAT'
16590          IH2='VAL '
16591          VALUE0=STATVA
16592          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
16593     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
16594     1                IANS,IWIDTH,IBUGA3,IERROR)
16595        ENDIF
16596C
16597        IF(STATCD.NE.CPUMIN)THEN
16598          IH='STAT'
16599          IH2='CDF '
16600          VALUE0=STATCD
16601          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
16602     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
16603     1                IANS,IWIDTH,IBUGA3,IERROR)
16604        ENDIF
16605C
16606        IF(PVAL.NE.CPUMIN)THEN
16607          IH='PVAL'
16608          IH2='UE  '
16609          VALUE0=PVAL
16610          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
16611     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
16612     1                IANS,IWIDTH,IBUGA3,IERROR)
16613        ENDIF
16614C
16615        IF(CUT0.NE.CPUMIN)THEN
16616          IH='CUTO'
16617          IH2='FF0'
16618          VALUE0=CUT0
16619          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
16620     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
16621     1                IANS,IWIDTH,IBUGA3,IERROR)
16622        ENDIF
16623C
16624        IF(CUT50.NE.CPUMIN)THEN
16625          IH='CUTO'
16626          IH2='FF50'
16627          VALUE0=CUT50
16628          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
16629     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
16630     1                IANS,IWIDTH,IBUGA3,IERROR)
16631        ENDIF
16632C
16633        IF(CUT75.NE.CPUMIN)THEN
16634          IH='CUTO'
16635          IH2='FF75'
16636          VALUE0=CUT75
16637          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
16638     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
16639     1                IANS,IWIDTH,IBUGA3,IERROR)
16640        ENDIF
16641C
16642        IF(CUT90.NE.CPUMIN)THEN
16643          IH='CUTO'
16644          IH2='FF90'
16645          VALUE0=CUT90
16646          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
16647     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
16648     1                IANS,IWIDTH,IBUGA3,IERROR)
16649        ENDIF
16650C
16651        IF(CUT95.NE.CPUMIN)THEN
16652          IH='CUTO'
16653          IH2='FF95'
16654          VALUE0=CUT95
16655          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
16656     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
16657     1                IANS,IWIDTH,IBUGA3,IERROR)
16658        ENDIF
16659C
16660        IF(CUT975.NE.CPUMIN)THEN
16661          IH='CUTO'
16662          IH2='F975'
16663          VALUE0=CUT975
16664          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
16665     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
16666     1                IANS,IWIDTH,IBUGA3,IERROR)
16667        ENDIF
16668C
16669        IF(CUT99.NE.CPUMIN)THEN
16670          IH='CUTO'
16671          IH2='FF99'
16672          VALUE0=CUT99
16673          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
16674     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
16675     1                IANS,IWIDTH,IBUGA3,IERROR)
16676        ENDIF
16677C
16678        IF(CUT100.NE.CPUMIN)THEN
16679          IH='CUTO'
16680          IH2='F100'
16681          VALUE0=CUT100
16682          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
16683     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
16684     1                IANS,IWIDTH,IBUGA3,IERROR)
16685        ENDIF
16686C
16687      ENDIF
16688C
16689      IF(IFLAGU.EQ.'FILE')THEN
16690        IF(ILAST)THEN
16691          IOP='CLOS'
16692          IFLAG1=1
16693          IFLAG2=0
16694          IFLAG3=0
16695          IFLAG4=0
16696          IFLAG5=0
16697          CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
16698     1                IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
16699     1                IBUGA3,ISUBRO,IERROR)
16700C
16701          IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'GRU4')THEN
16702            ISTEPN='3A'
16703            CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16704            WRITE(ICOUT,999)
16705            CALL DPWRST('XXX','BUG ')
16706            WRITE(ICOUT,301)IERROR
16707  301       FORMAT('AFTER CALL DPCLFI, IERROR = ',A4)
16708            CALL DPWRST('XXX','BUG ')
16709          ENDIF
16710C
16711          IF(IERROR.EQ.'YES')GOTO9000
16712        ENDIF
16713      ENDIF
16714C
16715C               *****************
16716C               **  STEP 90--  **
16717C               **  EXIT       **
16718C               *****************
16719C
16720 9000 CONTINUE
16721C
16722      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'GRU4')THEN
16723        WRITE(ICOUT,999)
16724        CALL DPWRST('XXX','BUG ')
16725        WRITE(ICOUT,9011)
16726 9011   FORMAT('***** AT THE END OF DPGRU4--')
16727        CALL DPWRST('XXX','BUG ')
16728      ENDIF
16729C
16730      RETURN
16731      END
16732      SUBROUTINE DPGSL(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS,
16733     1                 IBUGD2,IFOUND,IERROR)
16734C
16735C     PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES
16736C              FOR GREEK SIMPLEX LOWER CASE.
16737C     WRITTEN BY--JAMES J. FILLIBEN
16738C                 STATISTICAL ENGINEERING DIVISION
16739C                 INFORMATION TECHNOLOGY LABORATORY
16740C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
16741C                 GAITHERSBURG, MD 20899-8980
16742C                 PHONE--301-975-2855
16743C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
16744C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
16745C     LANGUAGE--ANSI FORTRAN (1977)
16746C     VERSION NUMBER--87/4
16747C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH     1981.
16748C     UPDATED         --MAY       1982.
16749C     UPDATED         --MARCH     1987.
16750C
16751C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
16752C
16753      CHARACTER*4 ICHAR2
16754      CHARACTER*4 IOP
16755      CHARACTER*4 IBUGD2
16756      CHARACTER*4 IFOUND
16757      CHARACTER*4 IERROR
16758C
16759C---------------------------------------------------------------------
16760C
16761      DIMENSION IOP(*)
16762      DIMENSION X(*)
16763      DIMENSION Y(*)
16764C
16765C---------------------------------------------------------------------
16766C
16767      INCLUDE 'DPCOP2.INC'
16768C
16769C-----START POINT-----------------------------------------------------
16770C
16771      IFOUND='NO'
16772      IERROR='NO'
16773C
16774      NUMCO=1
16775      ISTART=1
16776      ISTOP=1
16777      NC=1
16778C
16779C               ******************************************
16780C               **  TREAT THE ROMAN SIMPLEX UPPER CASE  **
16781C               **  HERSHEY CHARACTER SET CASE          **
16782C               ******************************************
16783C
16784C
16785      IF(IBUGD2.EQ.'OFF')GOTO90
16786      WRITE(ICOUT,999)
16787  999 FORMAT(1X)
16788      CALL DPWRST('XXX','BUG ')
16789      WRITE(ICOUT,51)
16790   51 FORMAT('***** AT THE BEGINNING OF DPGSL--')
16791      CALL DPWRST('XXX','BUG ')
16792      WRITE(ICOUT,52)ICHAR2
16793   52 FORMAT('ICHAR2 = ',A4)
16794      CALL DPWRST('XXX','BUG ')
16795      WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR
16796   59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
16797      CALL DPWRST('XXX','BUG ')
16798   90 CONTINUE
16799C
16800C               **************************************************
16801C               **  STEP 1--                                    **
16802C               **  SEARCH FOR THE INPUT CHARACTER(S).          **
16803C               **  MAP THE CHARACTER(S) INTO A NUMERIC VALUE.  **
16804C               **************************************************
16805C
16806      CALL DPCHGR(ICHAR2,ICHARN,IBUGD2,IFOUND)
16807      IF(IFOUND.EQ.'NO')GOTO9000
16808C
16809      IF(ICHARN.LE.16)GOTO1010
16810      GOTO1019
16811 1010 CONTINUE
16812      CALL DGSL1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS,
16813     1IBUGD2,IFOUND,IERROR)
16814      GOTO9000
16815 1019 CONTINUE
16816C
16817      IF(ICHARN.GE.17)GOTO1020
16818      GOTO1029
16819 1020 CONTINUE
16820      CALL DGSL2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS,
16821     1IBUGD2,IFOUND,IERROR)
16822      GOTO9000
16823 1029 CONTINUE
16824C
16825      IFOUND='NO'
16826      GOTO9000
16827C
16828C               *****************
16829C               **  STEP 90--  **
16830C               **  EXIT       **
16831C               *****************
16832C
16833 9000 CONTINUE
16834      IF(IBUGD2.EQ.'OFF')GOTO9090
16835      WRITE(ICOUT,999)
16836      CALL DPWRST('XXX','BUG ')
16837      WRITE(ICOUT,9011)
16838 9011 FORMAT('***** AT THE END       OF DPGSL--')
16839      CALL DPWRST('XXX','BUG ')
16840      WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR
16841 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
16842      CALL DPWRST('XXX','BUG ')
16843      WRITE(ICOUT,9013)ICHAR2,ICHARN
16844 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8)
16845      CALL DPWRST('XXX','BUG ')
16846      WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO
16847 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8)
16848      CALL DPWRST('XXX','BUG ')
16849      IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019
16850      DO9015I=1,NUMCO
16851      WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I)
16852 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2)
16853      CALL DPWRST('XXX','BUG ')
16854 9015 CONTINUE
16855 9019 CONTINUE
16856      WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS
16857 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8)
16858      CALL DPWRST('XXX','BUG ')
16859 9090 CONTINUE
16860C
16861      RETURN
16862      END
16863      SUBROUTINE DPGSU(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS,
16864     1IBUGD2,IFOUND,IERROR)
16865C
16866C     PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES
16867C              FOR GREEK SIMPLEX UPPER CASE.
16868C     WRITTEN BY--JAMES J. FILLIBEN
16869C                 STATISTICAL ENGINEERING DIVISION
16870C                 INFORMATION TECHNOLOGY LABORATORY
16871C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
16872C                 GAITHERSBURG, MD 20899-8980
16873C                 PHONE--301-975-2855
16874C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
16875C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
16876C     LANGUAGE--ANSI FORTRAN (1977)
16877C     VERSION NUMBER--87/4
16878C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH     1981.
16879C     UPDATED         --MAY       1982.
16880C     UPDATED         --MARCH     1987.
16881C
16882C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
16883C
16884      CHARACTER*4 ICHAR2
16885      CHARACTER*4 IOP
16886      CHARACTER*4 IBUGD2
16887      CHARACTER*4 IFOUND
16888      CHARACTER*4 IERROR
16889C
16890      CHARACTER*4 IOPERA
16891C
16892C---------------------------------------------------------------------
16893C
16894      DIMENSION IOP(*)
16895      DIMENSION X(*)
16896      DIMENSION Y(*)
16897C
16898      DIMENSION IOPERA(300)
16899      DIMENSION IX(300)
16900      DIMENSION IY(300)
16901C
16902      DIMENSION IXMIND(30)
16903      DIMENSION IXMAXD(30)
16904      DIMENSION IXDELD(30)
16905      DIMENSION ISTARD(30)
16906      DIMENSION NUMCOO(30)
16907C
16908C---------------------------------------------------------------------
16909C
16910      INCLUDE 'DPCOP2.INC'
16911C
16912C-----DATA STATEMENTS-------------------------------------------------
16913C
16914C     DEFINE CHARACTER    527--UPPER CASE ALPH
16915C
16916      DATA IOPERA(   1),IX(   1),IY(   1)/'MOVE',   0,  12/
16917      DATA IOPERA(   2),IX(   2),IY(   2)/'DRAW',  -8,  -9/
16918      DATA IOPERA(   3),IX(   3),IY(   3)/'MOVE',   0,  12/
16919      DATA IOPERA(   4),IX(   4),IY(   4)/'DRAW',   8,  -9/
16920      DATA IOPERA(   5),IX(   5),IY(   5)/'MOVE',  -5,  -2/
16921      DATA IOPERA(   6),IX(   6),IY(   6)/'DRAW',   5,  -2/
16922C
16923      DATA IXMIND(   1)/  -9/
16924      DATA IXMAXD(   1)/   9/
16925      DATA IXDELD(   1)/  18/
16926      DATA ISTARD(   1)/   1/
16927      DATA NUMCOO(   1)/   6/
16928C
16929C     DEFINE CHARACTER    528--UPPER CASE BETA
16930C
16931      DATA IOPERA(   7),IX(   7),IY(   7)/'MOVE',  -7,  12/
16932      DATA IOPERA(   8),IX(   8),IY(   8)/'DRAW',  -7,  -9/
16933      DATA IOPERA(   9),IX(   9),IY(   9)/'MOVE',  -7,  12/
16934      DATA IOPERA(  10),IX(  10),IY(  10)/'DRAW',   2,  12/
16935      DATA IOPERA(  11),IX(  11),IY(  11)/'DRAW',   5,  11/
16936      DATA IOPERA(  12),IX(  12),IY(  12)/'DRAW',   6,  10/
16937      DATA IOPERA(  13),IX(  13),IY(  13)/'DRAW',   7,   8/
16938      DATA IOPERA(  14),IX(  14),IY(  14)/'DRAW',   7,   6/
16939      DATA IOPERA(  15),IX(  15),IY(  15)/'DRAW',   6,   4/
16940      DATA IOPERA(  16),IX(  16),IY(  16)/'DRAW',   5,   3/
16941      DATA IOPERA(  17),IX(  17),IY(  17)/'DRAW',   2,   2/
16942      DATA IOPERA(  18),IX(  18),IY(  18)/'MOVE',  -7,   2/
16943      DATA IOPERA(  19),IX(  19),IY(  19)/'DRAW',   2,   2/
16944      DATA IOPERA(  20),IX(  20),IY(  20)/'DRAW',   5,   1/
16945      DATA IOPERA(  21),IX(  21),IY(  21)/'DRAW',   6,   0/
16946      DATA IOPERA(  22),IX(  22),IY(  22)/'DRAW',   7,  -2/
16947      DATA IOPERA(  23),IX(  23),IY(  23)/'DRAW',   7,  -5/
16948      DATA IOPERA(  24),IX(  24),IY(  24)/'DRAW',   6,  -7/
16949      DATA IOPERA(  25),IX(  25),IY(  25)/'DRAW',   5,  -8/
16950      DATA IOPERA(  26),IX(  26),IY(  26)/'DRAW',   2,  -9/
16951      DATA IOPERA(  27),IX(  27),IY(  27)/'DRAW',  -7,  -9/
16952C
16953      DATA IXMIND(   2)/ -11/
16954      DATA IXMAXD(   2)/  10/
16955      DATA IXDELD(   2)/  21/
16956      DATA ISTARD(   2)/   7/
16957      DATA NUMCOO(   2)/  21/
16958C
16959C     DEFINE CHARACTER    529--UPPER CASE GAMM
16960C
16961      DATA IOPERA(  28),IX(  28),IY(  28)/'MOVE',  -6,  12/
16962      DATA IOPERA(  29),IX(  29),IY(  29)/'DRAW',  -6,  -9/
16963      DATA IOPERA(  30),IX(  30),IY(  30)/'MOVE',  -6,  12/
16964      DATA IOPERA(  31),IX(  31),IY(  31)/'DRAW',   6,  12/
16965C
16966      DATA IXMIND(   3)/ -10/
16967      DATA IXMAXD(   3)/   7/
16968      DATA IXDELD(   3)/  17/
16969      DATA ISTARD(   3)/  28/
16970      DATA NUMCOO(   3)/   4/
16971C
16972C     DEFINE CHARACTER    530--UPPER CASE DELT
16973C
16974      DATA IOPERA(  32),IX(  32),IY(  32)/'MOVE',   0,  12/
16975      DATA IOPERA(  33),IX(  33),IY(  33)/'DRAW',  -8,  -9/
16976      DATA IOPERA(  34),IX(  34),IY(  34)/'MOVE',   0,  12/
16977      DATA IOPERA(  35),IX(  35),IY(  35)/'DRAW',   8,  -9/
16978      DATA IOPERA(  36),IX(  36),IY(  36)/'MOVE',  -8,  -9/
16979      DATA IOPERA(  37),IX(  37),IY(  37)/'DRAW',   8,  -9/
16980C
16981      DATA IXMIND(   4)/  -9/
16982      DATA IXMAXD(   4)/   9/
16983      DATA IXDELD(   4)/  18/
16984      DATA ISTARD(   4)/  32/
16985      DATA NUMCOO(   4)/   6/
16986C
16987C     DEFINE CHARACTER    531--UPPER CASE EPSI
16988C
16989      DATA IOPERA(  38),IX(  38),IY(  38)/'MOVE',  -6,  12/
16990      DATA IOPERA(  39),IX(  39),IY(  39)/'DRAW',  -6,  -9/
16991      DATA IOPERA(  40),IX(  40),IY(  40)/'MOVE',  -6,  12/
16992      DATA IOPERA(  41),IX(  41),IY(  41)/'DRAW',   7,  12/
16993      DATA IOPERA(  42),IX(  42),IY(  42)/'MOVE',  -6,   2/
16994      DATA IOPERA(  43),IX(  43),IY(  43)/'DRAW',   2,   2/
16995      DATA IOPERA(  44),IX(  44),IY(  44)/'MOVE',  -6,  -9/
16996      DATA IOPERA(  45),IX(  45),IY(  45)/'DRAW',   7,  -9/
16997C
16998      DATA IXMIND(   5)/ -10/
16999      DATA IXMAXD(   5)/   9/
17000      DATA IXDELD(   5)/  19/
17001      DATA ISTARD(   5)/  38/
17002      DATA NUMCOO(   5)/   8/
17003C
17004C     DEFINE CHARACTER    532--UPPER CASE ZETA
17005C
17006      DATA IOPERA(  46),IX(  46),IY(  46)/'MOVE',   7,  12/
17007      DATA IOPERA(  47),IX(  47),IY(  47)/'DRAW',  -7,  -9/
17008      DATA IOPERA(  48),IX(  48),IY(  48)/'MOVE',  -7,  12/
17009      DATA IOPERA(  49),IX(  49),IY(  49)/'DRAW',   7,  12/
17010      DATA IOPERA(  50),IX(  50),IY(  50)/'MOVE',  -7,  -9/
17011      DATA IOPERA(  51),IX(  51),IY(  51)/'DRAW',   7,  -9/
17012C
17013      DATA IXMIND(   6)/ -10/
17014      DATA IXMAXD(   6)/  10/
17015      DATA IXDELD(   6)/  20/
17016      DATA ISTARD(   6)/  46/
17017      DATA NUMCOO(   6)/   6/
17018C
17019C     DEFINE CHARACTER    533--UPPER CASE ETA
17020C
17021      DATA IOPERA(  52),IX(  52),IY(  52)/'MOVE',  -7,  12/
17022      DATA IOPERA(  53),IX(  53),IY(  53)/'DRAW',  -7,  -9/
17023      DATA IOPERA(  54),IX(  54),IY(  54)/'MOVE',   7,  12/
17024      DATA IOPERA(  55),IX(  55),IY(  55)/'DRAW',   7,  -9/
17025      DATA IOPERA(  56),IX(  56),IY(  56)/'MOVE',  -7,   2/
17026      DATA IOPERA(  57),IX(  57),IY(  57)/'DRAW',   7,   2/
17027C
17028      DATA IXMIND(   7)/ -11/
17029      DATA IXMAXD(   7)/  11/
17030      DATA IXDELD(   7)/  22/
17031      DATA ISTARD(   7)/  52/
17032      DATA NUMCOO(   7)/   6/
17033C
17034C     DEFINE CHARACTER    534--UPPER CASE THET
17035C
17036      DATA IOPERA(  58),IX(  58),IY(  58)/'MOVE',  -2,  12/
17037      DATA IOPERA(  59),IX(  59),IY(  59)/'DRAW',  -4,  11/
17038      DATA IOPERA(  60),IX(  60),IY(  60)/'DRAW',  -6,   9/
17039      DATA IOPERA(  61),IX(  61),IY(  61)/'DRAW',  -7,   7/
17040      DATA IOPERA(  62),IX(  62),IY(  62)/'DRAW',  -8,   4/
17041      DATA IOPERA(  63),IX(  63),IY(  63)/'DRAW',  -8,  -1/
17042      DATA IOPERA(  64),IX(  64),IY(  64)/'DRAW',  -7,  -4/
17043      DATA IOPERA(  65),IX(  65),IY(  65)/'DRAW',  -6,  -6/
17044      DATA IOPERA(  66),IX(  66),IY(  66)/'DRAW',  -4,  -8/
17045      DATA IOPERA(  67),IX(  67),IY(  67)/'DRAW',  -2,  -9/
17046      DATA IOPERA(  68),IX(  68),IY(  68)/'DRAW',   2,  -9/
17047      DATA IOPERA(  69),IX(  69),IY(  69)/'DRAW',   4,  -8/
17048      DATA IOPERA(  70),IX(  70),IY(  70)/'DRAW',   6,  -6/
17049      DATA IOPERA(  71),IX(  71),IY(  71)/'DRAW',   7,  -4/
17050      DATA IOPERA(  72),IX(  72),IY(  72)/'DRAW',   8,  -1/
17051      DATA IOPERA(  73),IX(  73),IY(  73)/'DRAW',   8,   4/
17052      DATA IOPERA(  74),IX(  74),IY(  74)/'DRAW',   7,   7/
17053      DATA IOPERA(  75),IX(  75),IY(  75)/'DRAW',   6,   9/
17054      DATA IOPERA(  76),IX(  76),IY(  76)/'DRAW',   4,  11/
17055      DATA IOPERA(  77),IX(  77),IY(  77)/'DRAW',   2,  12/
17056      DATA IOPERA(  78),IX(  78),IY(  78)/'DRAW',  -2,  12/
17057      DATA IOPERA(  79),IX(  79),IY(  79)/'MOVE',  -3,   2/
17058      DATA IOPERA(  80),IX(  80),IY(  80)/'DRAW',   3,   2/
17059C
17060      DATA IXMIND(   8)/ -11/
17061      DATA IXMAXD(   8)/  11/
17062      DATA IXDELD(   8)/  22/
17063      DATA ISTARD(   8)/  58/
17064      DATA NUMCOO(   8)/  23/
17065C
17066C     DEFINE CHARACTER    535--UPPER CASE IOTA
17067C
17068      DATA IOPERA(  81),IX(  81),IY(  81)/'MOVE',   0,  12/
17069      DATA IOPERA(  82),IX(  82),IY(  82)/'DRAW',   0,  -9/
17070C
17071      DATA IXMIND(   9)/  -4/
17072      DATA IXMAXD(   9)/   4/
17073      DATA IXDELD(   9)/   8/
17074      DATA ISTARD(   9)/  81/
17075      DATA NUMCOO(   9)/   2/
17076C
17077C     DEFINE CHARACTER    536--UPPER CASE KAPP
17078C
17079      DATA IOPERA(  83),IX(  83),IY(  83)/'MOVE',  -7,  12/
17080      DATA IOPERA(  84),IX(  84),IY(  84)/'DRAW',  -7,  -9/
17081      DATA IOPERA(  85),IX(  85),IY(  85)/'MOVE',   7,  12/
17082      DATA IOPERA(  86),IX(  86),IY(  86)/'DRAW',  -7,  -2/
17083      DATA IOPERA(  87),IX(  87),IY(  87)/'MOVE',  -2,   3/
17084      DATA IOPERA(  88),IX(  88),IY(  88)/'DRAW',   7,  -9/
17085C
17086      DATA IXMIND(  10)/ -11/
17087      DATA IXMAXD(  10)/  10/
17088      DATA IXDELD(  10)/  21/
17089      DATA ISTARD(  10)/  83/
17090      DATA NUMCOO(  10)/   6/
17091C
17092C     DEFINE CHARACTER    537--UPPER CASE LAMB
17093C
17094      DATA IOPERA(  89),IX(  89),IY(  89)/'MOVE',   0,  12/
17095      DATA IOPERA(  90),IX(  90),IY(  90)/'DRAW',  -8,  -9/
17096      DATA IOPERA(  91),IX(  91),IY(  91)/'MOVE',   0,  12/
17097      DATA IOPERA(  92),IX(  92),IY(  92)/'DRAW',   8,  -9/
17098C
17099      DATA IXMIND(  11)/  -9/
17100      DATA IXMAXD(  11)/   9/
17101      DATA IXDELD(  11)/  18/
17102      DATA ISTARD(  11)/  89/
17103      DATA NUMCOO(  11)/   4/
17104C
17105C     DEFINE CHARACTER    538--UPPER CASE MU
17106C
17107      DATA IOPERA(  93),IX(  93),IY(  93)/'MOVE',  -8,  12/
17108      DATA IOPERA(  94),IX(  94),IY(  94)/'DRAW',  -8,  -9/
17109      DATA IOPERA(  95),IX(  95),IY(  95)/'MOVE',  -8,  12/
17110      DATA IOPERA(  96),IX(  96),IY(  96)/'DRAW',   0,  -9/
17111      DATA IOPERA(  97),IX(  97),IY(  97)/'MOVE',   8,  12/
17112      DATA IOPERA(  98),IX(  98),IY(  98)/'DRAW',   0,  -9/
17113      DATA IOPERA(  99),IX(  99),IY(  99)/'MOVE',   8,  12/
17114      DATA IOPERA( 100),IX( 100),IY( 100)/'DRAW',   8,  -9/
17115C
17116      DATA IXMIND(  12)/ -12/
17117      DATA IXMAXD(  12)/  12/
17118      DATA IXDELD(  12)/  24/
17119      DATA ISTARD(  12)/  93/
17120      DATA NUMCOO(  12)/   8/
17121C
17122C     DEFINE CHARACTER    539--UPPER CASE NU
17123C
17124      DATA IOPERA( 101),IX( 101),IY( 101)/'MOVE',  -7,  12/
17125      DATA IOPERA( 102),IX( 102),IY( 102)/'DRAW',  -7,  -9/
17126      DATA IOPERA( 103),IX( 103),IY( 103)/'MOVE',  -7,  12/
17127      DATA IOPERA( 104),IX( 104),IY( 104)/'DRAW',   7,  -9/
17128      DATA IOPERA( 105),IX( 105),IY( 105)/'MOVE',   7,  12/
17129      DATA IOPERA( 106),IX( 106),IY( 106)/'DRAW',   7,  -9/
17130C
17131      DATA IXMIND(  13)/ -11/
17132      DATA IXMAXD(  13)/  11/
17133      DATA IXDELD(  13)/  22/
17134      DATA ISTARD(  13)/ 101/
17135      DATA NUMCOO(  13)/   6/
17136C
17137C     DEFINE CHARACTER    540--UPPER CASE XI
17138C
17139      DATA IOPERA( 107),IX( 107),IY( 107)/'MOVE',  -7,  12/
17140      DATA IOPERA( 108),IX( 108),IY( 108)/'DRAW',   7,  12/
17141      DATA IOPERA( 109),IX( 109),IY( 109)/'MOVE',  -3,   2/
17142      DATA IOPERA( 110),IX( 110),IY( 110)/'DRAW',   3,   2/
17143      DATA IOPERA( 111),IX( 111),IY( 111)/'MOVE',  -7,  -9/
17144      DATA IOPERA( 112),IX( 112),IY( 112)/'DRAW',   7,  -9/
17145C
17146      DATA IXMIND(  14)/  -9/
17147      DATA IXMAXD(  14)/   9/
17148      DATA IXDELD(  14)/  18/
17149      DATA ISTARD(  14)/ 107/
17150      DATA NUMCOO(  14)/   6/
17151C
17152C     DEFINE CHARACTER    541--UPPER CASE OMIC
17153C
17154      DATA IOPERA( 113),IX( 113),IY( 113)/'MOVE',  -2,  12/
17155      DATA IOPERA( 114),IX( 114),IY( 114)/'DRAW',  -4,  11/
17156      DATA IOPERA( 115),IX( 115),IY( 115)/'DRAW',  -6,   9/
17157      DATA IOPERA( 116),IX( 116),IY( 116)/'DRAW',  -7,   7/
17158      DATA IOPERA( 117),IX( 117),IY( 117)/'DRAW',  -8,   4/
17159      DATA IOPERA( 118),IX( 118),IY( 118)/'DRAW',  -8,  -1/
17160      DATA IOPERA( 119),IX( 119),IY( 119)/'DRAW',  -7,  -4/
17161      DATA IOPERA( 120),IX( 120),IY( 120)/'DRAW',  -6,  -6/
17162      DATA IOPERA( 121),IX( 121),IY( 121)/'DRAW',  -4,  -8/
17163      DATA IOPERA( 122),IX( 122),IY( 122)/'DRAW',  -2,  -9/
17164      DATA IOPERA( 123),IX( 123),IY( 123)/'DRAW',   2,  -9/
17165      DATA IOPERA( 124),IX( 124),IY( 124)/'DRAW',   4,  -8/
17166      DATA IOPERA( 125),IX( 125),IY( 125)/'DRAW',   6,  -6/
17167      DATA IOPERA( 126),IX( 126),IY( 126)/'DRAW',   7,  -4/
17168      DATA IOPERA( 127),IX( 127),IY( 127)/'DRAW',   8,  -1/
17169      DATA IOPERA( 128),IX( 128),IY( 128)/'DRAW',   8,   4/
17170      DATA IOPERA( 129),IX( 129),IY( 129)/'DRAW',   7,   7/
17171      DATA IOPERA( 130),IX( 130),IY( 130)/'DRAW',   6,   9/
17172      DATA IOPERA( 131),IX( 131),IY( 131)/'DRAW',   4,  11/
17173      DATA IOPERA( 132),IX( 132),IY( 132)/'DRAW',   2,  12/
17174      DATA IOPERA( 133),IX( 133),IY( 133)/'DRAW',  -2,  12/
17175C
17176      DATA IXMIND(  15)/ -11/
17177      DATA IXMAXD(  15)/  11/
17178      DATA IXDELD(  15)/  22/
17179      DATA ISTARD(  15)/ 113/
17180      DATA NUMCOO(  15)/  21/
17181C
17182C     DEFINE CHARACTER    542--UPPER CASE PI
17183C
17184      DATA IOPERA( 134),IX( 134),IY( 134)/'MOVE',  -7,  12/
17185      DATA IOPERA( 135),IX( 135),IY( 135)/'DRAW',  -7,  -9/
17186      DATA IOPERA( 136),IX( 136),IY( 136)/'MOVE',   7,  12/
17187      DATA IOPERA( 137),IX( 137),IY( 137)/'DRAW',   7,  -9/
17188      DATA IOPERA( 138),IX( 138),IY( 138)/'MOVE',  -7,  12/
17189      DATA IOPERA( 139),IX( 139),IY( 139)/'DRAW',   7,  12/
17190C
17191      DATA IXMIND(  16)/ -11/
17192      DATA IXMAXD(  16)/  11/
17193      DATA IXDELD(  16)/  22/
17194      DATA ISTARD(  16)/ 134/
17195      DATA NUMCOO(  16)/   6/
17196C
17197C     DEFINE CHARACTER    543--UPPER CASE RHO
17198C
17199      DATA IOPERA( 140),IX( 140),IY( 140)/'MOVE',  -7,  12/
17200      DATA IOPERA( 141),IX( 141),IY( 141)/'DRAW',  -7,  -9/
17201      DATA IOPERA( 142),IX( 142),IY( 142)/'MOVE',  -7,  12/
17202      DATA IOPERA( 143),IX( 143),IY( 143)/'DRAW',   2,  12/
17203      DATA IOPERA( 144),IX( 144),IY( 144)/'DRAW',   5,  11/
17204      DATA IOPERA( 145),IX( 145),IY( 145)/'DRAW',   6,  10/
17205      DATA IOPERA( 146),IX( 146),IY( 146)/'DRAW',   7,   8/
17206      DATA IOPERA( 147),IX( 147),IY( 147)/'DRAW',   7,   5/
17207      DATA IOPERA( 148),IX( 148),IY( 148)/'DRAW',   6,   3/
17208      DATA IOPERA( 149),IX( 149),IY( 149)/'DRAW',   5,   2/
17209      DATA IOPERA( 150),IX( 150),IY( 150)/'DRAW',   2,   1/
17210      DATA IOPERA( 151),IX( 151),IY( 151)/'DRAW',  -7,   1/
17211C
17212      DATA IXMIND(  17)/ -11/
17213      DATA IXMAXD(  17)/  10/
17214      DATA IXDELD(  17)/  21/
17215      DATA ISTARD(  17)/ 140/
17216      DATA NUMCOO(  17)/  12/
17217C
17218C     DEFINE CHARACTER    544--UPPER CASE SIGM
17219C
17220      DATA IOPERA( 152),IX( 152),IY( 152)/'MOVE',  -7,  12/
17221      DATA IOPERA( 153),IX( 153),IY( 153)/'DRAW',   0,   2/
17222      DATA IOPERA( 154),IX( 154),IY( 154)/'DRAW',  -7,  -9/
17223      DATA IOPERA( 155),IX( 155),IY( 155)/'MOVE',  -7,  12/
17224      DATA IOPERA( 156),IX( 156),IY( 156)/'DRAW',   7,  12/
17225      DATA IOPERA( 157),IX( 157),IY( 157)/'MOVE',  -7,  -9/
17226      DATA IOPERA( 158),IX( 158),IY( 158)/'DRAW',   7,  -9/
17227C
17228      DATA IXMIND(  18)/  -9/
17229      DATA IXMAXD(  18)/   9/
17230      DATA IXDELD(  18)/  18/
17231      DATA ISTARD(  18)/ 152/
17232      DATA NUMCOO(  18)/   7/
17233C
17234C     DEFINE CHARACTER    545--UPPER CASE TAU
17235C
17236      DATA IOPERA( 159),IX( 159),IY( 159)/'MOVE',   0,  12/
17237      DATA IOPERA( 160),IX( 160),IY( 160)/'DRAW',   0,  -9/
17238      DATA IOPERA( 161),IX( 161),IY( 161)/'MOVE',  -7,  12/
17239      DATA IOPERA( 162),IX( 162),IY( 162)/'DRAW',   7,  12/
17240C
17241      DATA IXMIND(  19)/  -8/
17242      DATA IXMAXD(  19)/   8/
17243      DATA IXDELD(  19)/  16/
17244      DATA ISTARD(  19)/ 159/
17245      DATA NUMCOO(  19)/   4/
17246C
17247C     DEFINE CHARACTER    546--UPPER CASE UPSI
17248C
17249      DATA IOPERA( 163),IX( 163),IY( 163)/'MOVE',  -7,   7/
17250      DATA IOPERA( 164),IX( 164),IY( 164)/'DRAW',  -7,   9/
17251      DATA IOPERA( 165),IX( 165),IY( 165)/'DRAW',  -6,  11/
17252      DATA IOPERA( 166),IX( 166),IY( 166)/'DRAW',  -5,  12/
17253      DATA IOPERA( 167),IX( 167),IY( 167)/'DRAW',  -3,  12/
17254      DATA IOPERA( 168),IX( 168),IY( 168)/'DRAW',  -2,  11/
17255      DATA IOPERA( 169),IX( 169),IY( 169)/'DRAW',  -1,   9/
17256      DATA IOPERA( 170),IX( 170),IY( 170)/'DRAW',   0,   5/
17257      DATA IOPERA( 171),IX( 171),IY( 171)/'DRAW',   0,  -9/
17258      DATA IOPERA( 172),IX( 172),IY( 172)/'MOVE',   7,   7/
17259      DATA IOPERA( 173),IX( 173),IY( 173)/'DRAW',   7,   9/
17260      DATA IOPERA( 174),IX( 174),IY( 174)/'DRAW',   6,  11/
17261      DATA IOPERA( 175),IX( 175),IY( 175)/'DRAW',   5,  12/
17262      DATA IOPERA( 176),IX( 176),IY( 176)/'DRAW',   3,  12/
17263      DATA IOPERA( 177),IX( 177),IY( 177)/'DRAW',   2,  11/
17264      DATA IOPERA( 178),IX( 178),IY( 178)/'DRAW',   1,   9/
17265      DATA IOPERA( 179),IX( 179),IY( 179)/'DRAW',   0,   5/
17266C
17267      DATA IXMIND(  20)/  -9/
17268      DATA IXMAXD(  20)/   9/
17269      DATA IXDELD(  20)/  18/
17270      DATA ISTARD(  20)/ 163/
17271      DATA NUMCOO(  20)/  17/
17272C
17273C     DEFINE CHARACTER    547--UPPER CASE PHI
17274C
17275      DATA IOPERA( 180),IX( 180),IY( 180)/'MOVE',   0,  12/
17276      DATA IOPERA( 181),IX( 181),IY( 181)/'DRAW',   0,  -9/
17277      DATA IOPERA( 182),IX( 182),IY( 182)/'MOVE',  -2,   7/
17278      DATA IOPERA( 183),IX( 183),IY( 183)/'DRAW',  -5,   6/
17279      DATA IOPERA( 184),IX( 184),IY( 184)/'DRAW',  -6,   5/
17280      DATA IOPERA( 185),IX( 185),IY( 185)/'DRAW',  -7,   3/
17281      DATA IOPERA( 186),IX( 186),IY( 186)/'DRAW',  -7,   0/
17282      DATA IOPERA( 187),IX( 187),IY( 187)/'DRAW',  -6,  -2/
17283      DATA IOPERA( 188),IX( 188),IY( 188)/'DRAW',  -5,  -3/
17284      DATA IOPERA( 189),IX( 189),IY( 189)/'DRAW',  -2,  -4/
17285      DATA IOPERA( 190),IX( 190),IY( 190)/'DRAW',   2,  -4/
17286      DATA IOPERA( 191),IX( 191),IY( 191)/'DRAW',   5,  -3/
17287      DATA IOPERA( 192),IX( 192),IY( 192)/'DRAW',   6,  -2/
17288      DATA IOPERA( 193),IX( 193),IY( 193)/'DRAW',   7,   0/
17289      DATA IOPERA( 194),IX( 194),IY( 194)/'DRAW',   7,   3/
17290      DATA IOPERA( 195),IX( 195),IY( 195)/'DRAW',   6,   5/
17291      DATA IOPERA( 196),IX( 196),IY( 196)/'DRAW',   5,   6/
17292      DATA IOPERA( 197),IX( 197),IY( 197)/'DRAW',   2,   7/
17293      DATA IOPERA( 198),IX( 198),IY( 198)/'DRAW',  -2,   7/
17294C
17295      DATA IXMIND(  21)/ -10/
17296      DATA IXMAXD(  21)/  10/
17297      DATA IXDELD(  21)/  20/
17298      DATA ISTARD(  21)/ 180/
17299      DATA NUMCOO(  21)/  19/
17300C
17301C     DEFINE CHARACTER    548--UPPER CASE CHI
17302C
17303      DATA IOPERA( 199),IX( 199),IY( 199)/'MOVE',  -7,  12/
17304      DATA IOPERA( 200),IX( 200),IY( 200)/'DRAW',   7,  -9/
17305      DATA IOPERA( 201),IX( 201),IY( 201)/'MOVE',  -7,  -9/
17306      DATA IOPERA( 202),IX( 202),IY( 202)/'DRAW',   7,  12/
17307C
17308      DATA IXMIND(  22)/ -10/
17309      DATA IXMAXD(  22)/  10/
17310      DATA IXDELD(  22)/  20/
17311      DATA ISTARD(  22)/ 199/
17312      DATA NUMCOO(  22)/   4/
17313C
17314C     DEFINE CHARACTER    549--UPPER CASE PSI
17315C
17316      DATA IOPERA( 203),IX( 203),IY( 203)/'MOVE',   0,  12/
17317      DATA IOPERA( 204),IX( 204),IY( 204)/'DRAW',   0,  -9/
17318      DATA IOPERA( 205),IX( 205),IY( 205)/'MOVE',  -9,   6/
17319      DATA IOPERA( 206),IX( 206),IY( 206)/'DRAW',  -8,   6/
17320      DATA IOPERA( 207),IX( 207),IY( 207)/'DRAW',  -7,   5/
17321      DATA IOPERA( 208),IX( 208),IY( 208)/'DRAW',  -6,   1/
17322      DATA IOPERA( 209),IX( 209),IY( 209)/'DRAW',  -5,  -1/
17323      DATA IOPERA( 210),IX( 210),IY( 210)/'DRAW',  -4,  -2/
17324      DATA IOPERA( 211),IX( 211),IY( 211)/'DRAW',  -1,  -3/
17325      DATA IOPERA( 212),IX( 212),IY( 212)/'DRAW',   1,  -3/
17326      DATA IOPERA( 213),IX( 213),IY( 213)/'DRAW',   4,  -2/
17327      DATA IOPERA( 214),IX( 214),IY( 214)/'DRAW',   5,  -1/
17328      DATA IOPERA( 215),IX( 215),IY( 215)/'DRAW',   6,   1/
17329      DATA IOPERA( 216),IX( 216),IY( 216)/'DRAW',   7,   5/
17330      DATA IOPERA( 217),IX( 217),IY( 217)/'DRAW',   8,   6/
17331      DATA IOPERA( 218),IX( 218),IY( 218)/'DRAW',   9,   6/
17332C
17333      DATA IXMIND(  23)/ -11/
17334      DATA IXMAXD(  23)/  11/
17335      DATA IXDELD(  23)/  22/
17336      DATA ISTARD(  23)/ 203/
17337      DATA NUMCOO(  23)/  16/
17338C
17339C     DEFINE CHARACTER    550--UPPER CASE OMEG
17340C
17341      DATA IOPERA( 219),IX( 219),IY( 219)/'MOVE',  -7,  -9/
17342      DATA IOPERA( 220),IX( 220),IY( 220)/'DRAW',  -3,  -9/
17343      DATA IOPERA( 221),IX( 221),IY( 221)/'DRAW',  -6,  -2/
17344      DATA IOPERA( 222),IX( 222),IY( 222)/'DRAW',  -7,   2/
17345      DATA IOPERA( 223),IX( 223),IY( 223)/'DRAW',  -7,   6/
17346      DATA IOPERA( 224),IX( 224),IY( 224)/'DRAW',  -6,   9/
17347      DATA IOPERA( 225),IX( 225),IY( 225)/'DRAW',  -4,  11/
17348      DATA IOPERA( 226),IX( 226),IY( 226)/'DRAW',  -1,  12/
17349      DATA IOPERA( 227),IX( 227),IY( 227)/'DRAW',   1,  12/
17350      DATA IOPERA( 228),IX( 228),IY( 228)/'DRAW',   4,  11/
17351      DATA IOPERA( 229),IX( 229),IY( 229)/'DRAW',   6,   9/
17352      DATA IOPERA( 230),IX( 230),IY( 230)/'DRAW',   7,   6/
17353      DATA IOPERA( 231),IX( 231),IY( 231)/'DRAW',   7,   2/
17354      DATA IOPERA( 232),IX( 232),IY( 232)/'DRAW',   6,  -2/
17355      DATA IOPERA( 233),IX( 233),IY( 233)/'DRAW',   3,  -9/
17356      DATA IOPERA( 234),IX( 234),IY( 234)/'DRAW',   7,  -9/
17357C
17358      DATA IXMIND(  24)/ -10/
17359      DATA IXMAXD(  24)/  10/
17360      DATA IXDELD(  24)/  20/
17361      DATA ISTARD(  24)/ 219/
17362      DATA NUMCOO(  24)/  16/
17363C
17364C-----START POINT-----------------------------------------------------
17365C
17366      IFOUND='NO'
17367      IERROR='NO'
17368C
17369      NUMCO=1
17370      ISTART=1
17371      ISTOP=1
17372      NC=1
17373C
17374C               ******************************************
17375C               ******************************************
17376C               **  TREAT THE ROMAN SIMPLEX UPPER CASE  **
17377C               **  HERSHEY CHARACTER SET CASE          **
17378C               ******************************************
17379C               ******************************************
17380C
17381C
17382      IF(IBUGD2.EQ.'OFF')GOTO90
17383      WRITE(ICOUT,999)
17384  999 FORMAT(1X)
17385      CALL DPWRST('XXX','BUG ')
17386      WRITE(ICOUT,51)
17387   51 FORMAT('***** AT THE BEGINNING OF DPGSU--')
17388      CALL DPWRST('XXX','BUG ')
17389      WRITE(ICOUT,52)ICHAR2
17390   52 FORMAT('ICHAR2 = ',A4)
17391      CALL DPWRST('XXX','BUG ')
17392      WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR
17393   59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
17394      CALL DPWRST('XXX','BUG ')
17395   90 CONTINUE
17396C
17397C               **************************************************
17398C               **************************************************
17399C               **  STEP 1--                                    **
17400C               **  SEARCH FOR THE INPUT CHARACTER(S).          **
17401C               **  MAP THE CHARACTER(S) INTO A NUMERIC VALUE.  **
17402C               **************************************************
17403C               **************************************************
17404C
17405      CALL DPCHGR(ICHAR2,ICHARN,IBUGD2,IFOUND)
17406      IF(IFOUND.EQ.'NO')GOTO9000
17407      GOTO1000
17408C
17409C               **************************************
17410C               **************************************
17411C               **  STEP 2--                        **
17412C               **  EXTRACT THE COORDINATES         **
17413C               **  FOR THIS PARTICULAR CHARACTER.  **
17414C               **************************************
17415C               **************************************
17416C
17417 1000 CONTINUE
17418      ISTART=ISTARD(ICHARN)
17419      NC=NUMCOO(ICHARN)
17420      ISTOP=ISTART+NC-1
17421      J=0
17422      DO1100I=ISTART,ISTOP
17423      J=J+1
17424      IOP(J)=IOPERA(I)
17425      X(J)=IX(I)
17426      Y(J)=IY(I)
17427 1100 CONTINUE
17428      NUMCO=J
17429      IXMINS=IXMIND(ICHARN)
17430      IXMAXS=IXMAXD(ICHARN)
17431      IXDELS=IXDELD(ICHARN)
17432C
17433      GOTO9000
17434C
17435C               *****************
17436C               *****************
17437C               **  STEP 90--  **
17438C               **  EXIT       **
17439C               *****************
17440C               *****************
17441C
17442 9000 CONTINUE
17443      IF(IBUGD2.EQ.'OFF')GOTO9090
17444      WRITE(ICOUT,999)
17445      CALL DPWRST('XXX','BUG ')
17446      WRITE(ICOUT,9011)
17447 9011 FORMAT('***** AT THE END       OF DPGSU--')
17448      CALL DPWRST('XXX','BUG ')
17449      WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR
17450 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
17451      CALL DPWRST('XXX','BUG ')
17452      WRITE(ICOUT,9013)ICHAR2,ICHARN
17453 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8)
17454      CALL DPWRST('XXX','BUG ')
17455      WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO
17456 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8)
17457      CALL DPWRST('XXX','BUG ')
17458      IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019
17459      DO9015I=1,NUMCO
17460      WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I)
17461 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2)
17462      CALL DPWRST('XXX','BUG ')
17463 9015 CONTINUE
17464 9019 CONTINUE
17465      WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS
17466 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8)
17467      CALL DPWRST('XXX','BUG ')
17468 9090 CONTINUE
17469C
17470      RETURN
17471      END
17472      SUBROUTINE DPHADE(IHARG,IARGT,ARG,NUMARG,DEFHAD,
17473     1HARDDE,IFOUND,IERROR)
17474C
17475C     PURPOSE--DEFINE THE HARDCOPY DELAY FACTOR.
17476C              THE SPECIFIED HARDCOPY DELAY FACTOR WILL BE PLACED
17477C              IN THE FLOATING POINT VARIABLE HARDDE.
17478C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
17479C                     --IARGT  (A  HOLLERITH VECTOR)
17480C                     --ARG    (A  FLOATING POINT VECTOR)
17481C                     --NUMARG (AN INTEGER VARIABLE)
17482C                     --DEFHAD (A  FLOATING POINT VARIABLE)
17483C     OUTPUT ARGUMENTS--HARDDE (A  FLOATING POINT VARIABLE)
17484C                     --IFOUND ('YES' OR 'NO' )
17485C                     --IERROR ('YES' OR 'NO' )
17486C     WRITTEN BY--JAMES J. FILLIBEN
17487C                 STATISTICAL ENGINEERING DIVISION
17488C                 INFORMATION TECHNOLOGY LABORATORY
17489C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
17490C                 GAITHERSBURG, MD 20899-8980
17491C                 PHONE--301-975-2855
17492C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
17493C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
17494C     LANGUAGE--ANSI FORTRAN (1977)
17495C     VERSION NUMBER--82/7
17496C     ORIGINAL VERSION--NOVEMBER 1980.
17497C     UPDATED         --MAY       1982.
17498C
17499C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
17500C
17501      CHARACTER*4 IHARG
17502      CHARACTER*4 IARGT
17503      CHARACTER*4 IFOUND
17504      CHARACTER*4 IERROR
17505C
17506C---------------------------------------------------------------------
17507C
17508      DIMENSION IHARG(*)
17509      DIMENSION IARGT(*)
17510      DIMENSION ARG(*)
17511C
17512C---------------------------------------------------------------------
17513C
17514      INCLUDE 'DPCOP2.INC'
17515C
17516C-----START POINT-----------------------------------------------------
17517C
17518      IFOUND='NO'
17519      IERROR='NO'
17520C
17521      IF(NUMARG.EQ.0)GOTO1199
17522      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'DELA')GOTO1110
17523      GOTO1199
17524C
17525 1110 CONTINUE
17526      IF(IHARG(NUMARG).EQ.'DELA')GOTO1150
17527      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
17528      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
17529      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
17530      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
17531      IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160
17532      GOTO1120
17533C
17534 1120 CONTINUE
17535      IERROR='YES'
17536      WRITE(ICOUT,1121)
17537 1121 FORMAT('***** ERROR IN DPHADE--')
17538      CALL DPWRST('XXX','BUG ')
17539      WRITE(ICOUT,1122)
17540 1122 FORMAT('      ILLEGAL FORM FOR HARDCOPY DELAY ',
17541     1'COMMAND.')
17542      CALL DPWRST('XXX','BUG ')
17543      WRITE(ICOUT,1124)
17544 1124 FORMAT('      TEST EXAMPLE TO DEMONSTRATE THE ',
17545     1'PROPER FORM--')
17546      CALL DPWRST('XXX','BUG ')
17547      WRITE(ICOUT,1125)
17548 1125 FORMAT('      SUPPOSE THE THE ANALYST WISHES TO DOUBLE  ')
17549      CALL DPWRST('XXX','BUG ')
17550      WRITE(ICOUT,1126)
17551 1126 FORMAT('      THE DELAY TIME WHILE HARDCOPIES ')
17552      CALL DPWRST('XXX','BUG ')
17553      WRITE(ICOUT,1127)
17554 1127 FORMAT('      ARE BEING MADE, ')
17555      CALL DPWRST('XXX','BUG ')
17556      WRITE(ICOUT,1130)
17557 1130 FORMAT('      THEN THE ALLOWABLE FORM IS--')
17558      CALL DPWRST('XXX','BUG ')
17559      WRITE(ICOUT,1131)
17560 1131 FORMAT('      HARDCOPY DELAY 2 ')
17561      CALL DPWRST('XXX','BUG ')
17562      GOTO1199
17563C
17564 1150 CONTINUE
17565      HOLD=DEFHAD
17566      GOTO1180
17567C
17568 1160 CONTINUE
17569      HOLD=ARG(NUMARG)
17570      GOTO1180
17571C
17572 1180 CONTINUE
17573      IFOUND='YES'
17574CCCCC HARDDE=HOLD
17575      AIMAX=2**(NUMBPC*NUMCPW-2)
17576      IF(HOLD.LT.AIMAX)HARDDE=HOLD
17577      IF(HOLD.GE.AIMAX)HARDDE=AIMAX
17578C
17579      IF(IFEEDB.EQ.'OFF')GOTO1189
17580      WRITE(ICOUT,999)
17581  999 FORMAT(1X)
17582      CALL DPWRST('XXX','BUG ')
17583      WRITE(ICOUT,1181)HARDDE
17584 1181 FORMAT('THE HARDCOPY DELAY FACTOR HAS JUST BEEN SET TO ',
17585     1E15.7)
17586      CALL DPWRST('XXX','BUG ')
17587 1189 CONTINUE
17588      GOTO1199
17589C
17590 1199 CONTINUE
17591      RETURN
17592      END
17593      SUBROUTINE DPHANW(ICOM,IHARG,IHARG2,IARG,ARG,IARGT,
17594     1                  NUMARG,IANS,IWIDTH,
17595     1                  IBUGS2,ISUBRO,IFOUND,IERROR)
17596C
17597C     PURPOSE--ACCESS THE ON-LINE NIST/SEMATECH ENGINEERING
17598C              STATISTICS HANDBOOK VIA
17599C              A WEB BROWSER (DEFAULTS TO NETSCAPE).
17600C
17601C              THIS COMMAND TAKES THE FOLLOWING FORMS:
17602C                  WEB HANDBOOK       - GO TO MAIN HANDBOOK HOME PAGE
17603C                  WEB HANDBOOK <KEYWORD> - GO TO A PARTICULAR PAGE
17604C                                       IN THE ON-LINE HANDBOOK BASED
17605C                                       ON MATCHING <KEYWORD> TO A
17606C                                       FILE (HANDBOOK.TEX)
17607C     INPUT  ARGUMENTS--IANS    (A  HOLLERITH VECTOR)
17608C                     --IWIDTH (AN INTEGER VARIABLE)
17609C                     --IBROWS  (A CHARACTER VARIABLE THAT IDENTIFIES
17610C                               THE BROWSER TO USE)
17611C                     --IHBURL  (A CHARACTER VARIABLE THAT IDENTIFIES
17612C                               THE WEB URL OF THE DATAPLOT HOME PAGE)
17613C     OUTPUT ARGUMENTS--IFOUND ('YES' OR 'NO' )
17614C                     --IERROR ('YES' OR 'NO' )
17615C     WRITTEN BY--ALAN HECKERT
17616C                 STATISTICAL ENGINEERING DIVISION
17617C                 INFORMATION TECHNOLOGY LABORATORY
17618C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
17619C                 GAITHERSBURG, MD 20899-8980
17620C                 PHONE--301-975-2899
17621C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
17622C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
17623C     LANGUAGE--ANSI FORTRAN (1977)
17624C     VERSION NUMBER--99/3
17625C     ORIGINAL VERSION--MARCH     1999.
17626C     UPDATED         --NOVMBER   2015. COMMENT OUT THE "-h" OPTION
17627C                                       FOR WINDOWS (THIS WAS SPECIFIC
17628C                                       TO NETSCAPE WHICH IS NOW AN
17629C                                       OBSOLETE BROWSER)
17630C     UPDATED         --APRIL     2018. ADD SOME ALIASES FOR
17631C                                       WEB HANDBOOK
17632C     UPDATED         --MARCH     2019. SET SYSTEM PERSIST
17633C                                       SET SYSTEM HIDDEN
17634C     UPDATED         --DECEMBER  2019. SUPPORT FOR EDGE BROWSER
17635C
17636C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
17637C
17638      CHARACTER*4 ICOM
17639      CHARACTER*4 IHARG
17640      CHARACTER*4 IHARG2
17641      CHARACTER*4 IARGT
17642C
17643      CHARACTER*4 IANS
17644      CHARACTER*1 IQUOTE
17645      CHARACTER*40 ILINE1
17646      CHARACTER*40 ILINE2
17647      CHARACTER*500 ICALL
17648      CHARACTER*4 IBUGS2
17649      CHARACTER*4 ISUBRO
17650      CHARACTER*4 IFOUND
17651      CHARACTER*4 IERROR
17652C
17653      INCLUDE 'DPCOPA.INC'
17654C
17655CCCCC CHARACTER*80 IFILE
17656      CHARACTER (LEN=MAXFNC) :: IFILE
17657      CHARACTER*12 ISTAT
17658      CHARACTER*12 IFORM
17659      CHARACTER*12 IACCES
17660      CHARACTER*12 IPROT
17661      CHARACTER*12 ICURST
17662      CHARACTER*4 ISUBN0
17663      CHARACTER*4 IERRFI
17664      CHARACTER*4 IENDFI
17665      CHARACTER*4 IREWIN
17666C
17667      CHARACTER*4 IWORD1
17668      CHARACTER*4 IWORD2
17669      CHARACTER*4 IWORD3
17670      CHARACTER*4 IWORD4
17671      CHARACTER*4 IWOR12
17672      CHARACTER*1 ICHAR1
17673      CHARACTER*4 ICTEST
17674      CHARACTER*4 ICTES2
17675      CHARACTER*4 IZ1
17676      CHARACTER*4 IZ2
17677      CHARACTER*4 IZ3
17678      CHARACTER*4 IZ4
17679      CHARACTER*40 ISTRIN
17680      CHARACTER*4 IERRO2
17681      CHARACTER*4 ISUBN1
17682      CHARACTER*4 ISUBN2
17683      CHARACTER*4 ISTEPN
17684      CHARACTER*4 ISSAV1
17685      CHARACTER*4 ISSAV2
17686      CHARACTER*4 ICLESV
17687C
17688      DIMENSION IHARG(*)
17689      DIMENSION IHARG2(*)
17690      DIMENSION IARG(*)
17691      DIMENSION ARG(*)
17692      DIMENSION IARGT(*)
17693      DIMENSION IANS(*)
17694C
17695C-----COMMON----------------------------------------------------------
17696C
17697      INCLUDE 'DPCOHO.INC'
17698      INCLUDE 'DPCOST.INC'
17699      INCLUDE 'DPCOF2.INC'
17700C
17701      CHARACTER*80 PROFIL
17702      CHARACTER*80 P86FIL
17703      CHARACTER*80 APPDAT
17704      CHARACTER*80 COMNAM
17705      CHARACTER*80 UPROFI
17706      CHARACTER*80 DEFPRI
17707      CHARACTER*20 USRNAM
17708      CHARACTER*20 ISHELL
17709      CHARACTER*4  WINBIT
17710      COMMON/SYSVAR/PROFIL,P86FIL,APPDAT,COMNAM,UPROFI,USRNAM,DEFPRI,
17711     1              WINBIT,ISHELL
17712      COMMON/SYSVA2/NCPROF,NCP86F,NCAPPD,NCCOMP,NCUPRO,NCUSER,NCPRIN,
17713     1              NCSHEL
17714C
17715C-----COMMON VARIABLES (GENERAL)--------------------------------------
17716C
17717      INCLUDE 'DPCOP2.INC'
17718C
17719C-----START POINT-----------------------------------------------------
17720C
17721      NUMLIN=(-999)
17722      NUMSEC=(-999)
17723      ISECNA=(-999)
17724      NUMAR2=(-999)
17725      JCHAR1=(-999)
17726      JSEC=(-999)
17727      JSECP1=(-999)
17728      ISKIP=(-999)
17729      ISTART=(-999)
17730      ISTOP=(-999)
17731      I2=(-999)
17732      NUMWHF=(-999)
17733      ILOC2=(-999)
17734      ILOC3=(-999)
17735      ILOC4=(-999)
17736      ILOC2P=(-999)
17737      ILOC3P=(-999)
17738      ILOC4P=(-999)
17739      NCSTR=0
17740C
17741      ISUBN1='DPHA'
17742      ISUBN2='NW  '
17743      IFOUND='YES'
17744      IERROR='NO'
17745      IWORD1='    '
17746      IWORD2='    '
17747      IWORD3='    '
17748      IWORD4='    '
17749      IWOR12='    '
17750      ICTEST='    '
17751      ICTES2='    '
17752      ICALL=' '
17753      IZ1='    '
17754      IZ2='    '
17755      IZ3='    '
17756      IZ4='    '
17757      ILINE1='                              '
17758      ILINE2='                              '
17759      ISTRIN='                              '
17760C
17761      CALL DPCONA(39,IQUOTE)
17762C
17763      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HANW')THEN
17764        WRITE(ICOUT,999)
17765  999   FORMAT(1X)
17766        CALL DPWRST('XXX','BUG ')
17767        WRITE(ICOUT,51)
17768   51   FORMAT('***** AT THE BEGINNING OF DPHANW--')
17769        CALL DPWRST('XXX','BUG ')
17770        WRITE(ICOUT,53)IBUGS2,ISUBRO,IERROR,ICOM,IWIDTH
17771   53   FORMAT('IBUGS2,ISUBRO,IERROR,ICOM,IWIDTH = ',
17772     1         4(A4,2X),I8)
17773        CALL DPWRST('XXX','BUG ')
17774        WRITE(ICOUT,55)(IANS(I),I=1,MIN(120,IWIDTH))
17775   55   FORMAT('IANS(.) = ',120A1)
17776        CALL DPWRST('XXX','BUG ')
17777        WRITE(ICOUT,86)IBROWS(1:80)
17778   86   FORMAT('IBROWS = ',A80)
17779        CALL DPWRST('XXX','BUG ')
17780        WRITE(ICOUT,88)IHBURL(1:80)
17781   88   FORMAT('IHBURL = ',A80)
17782        CALL DPWRST('XXX','BUG ')
17783      ENDIF
17784C
17785      IF(ICOM.EQ.'????' .OR. ICOM.EQ.'HAND' .OR.
17786     1   ICOM.EQ.'HB  ' .OR. ICOM.EQ.'WHB ')THEN
17787        ISHIFT=0
17788      ELSE
17789        ISHIFT=1
17790      ENDIF
17791      IF(ISHIFT.GE.1)THEN
17792        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
17793     1              IBUGS2,IERROR)
17794      ENDIF
17795C
17796CCCCC IF(
17797CCCCC1       (IHOST1.EQ.'SUN') .OR.
17798CCCCC1       (IHOST1.EQ.'CRAY' .AND. IOPSY1.EQ.'UNIX') .OR.
17799CCCCC1       (IHOST1.EQ.'CONV') .OR.
17800CCCCC1       (IHOST1.EQ.'SGI ') .OR.
17801CCCCC1       (IHOST1.EQ.'HP-9') .OR.
17802CCCCC1       (IHOST1.EQ.'AIX ') .OR.
17803CCCCC1       (IHOST1.EQ.'LINU') .OR.
17804CCCCC1       (IOPSY1.EQ.'UNIX'))GOTO199
17805CCCCC IF(IHOST1.EQ.'IBM-'.AND.ICOMPI.EQ.'MS-F')GOTO199
17806CCCCC IF(IHOST1.EQ.'IBM-'.AND.ICOMPI.EQ.'LAHE')GOTO199
17807CC100 CONTINUE
17808CCCCC WRITE(ICOUT,999)
17809CCCCC CALL DPWRST('XXX','BUG ')
17810CCCCC WRITE(ICOUT,111)
17811CC111 FORMAT('***** FROM DPHANW--WEB HANDBOOK CURRENTLY ONLY ',
17812CCCCC1'SUPPORTED ON UNIX OR PC WINDOWS PLATFORMS.')
17813CC199 CONTINUE
17814C
17815C               ********************************************************
17816C               **  STEP 21--                                         **
17817C               **  COPY OVER THE FIRST 4 WORDS AFTER THE WORDS WEB   **
17818C               **  HANDBOOK                                          **
17819C               ********************************************************
17820C
17821      IPASS=0
17822C1000 CONTINUE
17823      IPASS=IPASS+1
17824C
17825      ISTEPN='21'
17826      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
17827     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17828C
17829      IF(IPASS.LE.1)THEN
17830         IF(NUMARG.GE.1)IWORD1=IHARG(1)
17831         IF(NUMARG.GE.1)IWOR12=IHARG2(1)
17832         IF(NUMARG.GE.2)IWORD2=IHARG(2)
17833         IF(NUMARG.GE.3)IWORD3=IHARG(3)
17834         IF(NUMARG.GE.4)IWORD4=IHARG(4)
17835         NUMAR2=NUMARG
17836      ENDIF
17837C
17838      IF(NUMAR2.LE.0)THEN
17839         NUMAR2=1
17840         IWORD1='HOME'
17841         IWOR12='PAGE'
17842      ENDIF
17843C
17844      IF(IWORD1.EQ.'HOME'.AND.IWOR12.EQ.'PAGE')GOTO5099
17845C
17846C             ********************************************************
17847C             **  STEP 22--                                         **
17848C             **  STRIP OUT THE FIRST CHARACTER OF THE FIRST WORD.  **
17849C             ********************************************************
17850C
17851      ISTEPN='22'
17852      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HANW')
17853     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17854C
17855      ICHAR1=IWORD1(1:1)
17856C
17857C               *******************************
17858C               **  STEP 32--                **
17859C               **  COPY OVER FILE VARIABLES **
17860C               *******************************
17861C
17862      ISTEPN='32'
17863      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
17864     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17865C
17866      IOUNIT=IHHBNU
17867      IFILE=IHHBNA
17868      ISTAT=IHHBST
17869      IFORM=IHHBFO
17870      IACCES=IHHBAC
17871      IPROT=IHHBPR
17872      ICURST=IHHBCS
17873      ISUBN0='HANW'
17874      IERRFI='NO'
17875C
17876      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HANW')THEN
17877        WRITE(ICOUT,3293)IOUNIT
17878 3293   FORMAT('IOUNIT = ',I8)
17879        CALL DPWRST('XXX','BUG ')
17880        WRITE(ICOUT,3294)IFILE
17881 3294   FORMAT('IFILE = ',A80)
17882        CALL DPWRST('XXX','BUG ')
17883        WRITE(ICOUT,3295)ISTAT,IFORM,IACCES,IPROT,ICURST
17884 3295   FORMAT('ISTAT,IFORM,IACCES,IPROT,ICURST = ',
17885     1         4(A12,2X),A12)
17886        CALL DPWRST('XXX','BUG ')
17887        WRITE(ICOUT,3296)IBUGS2,ISUBRO,ISUBN0,IERRFI
17888 3296   FORMAT('IBUGS2,ISUBRO,ISUBN0,IERRFI = ',3(A4,2X),A4)
17889        CALL DPWRST('XXX','BUG ')
17890      ENDIF
17891C
17892C               ****************************************
17893C               **  STEP 33--                         **
17894C               **  CHECK TO SEE IF HELP FILE EXISTS  **
17895C               ****************************************
17896C
17897      ISTEPN='33'
17898      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HANW')
17899     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17900C
17901      IF(ISTAT.EQ.'NONE')THEN
17902        WRITE(ICOUT,999)
17903        CALL DPWRST('XXX','BUG ')
17904        WRITE(ICOUT,3311)
17905 3311   FORMAT('***** ERROR IN WEB HANDBOOK--')
17906        CALL DPWRST('XXX','BUG ')
17907        WRITE(ICOUT,3312)
17908 3312   FORMAT('      THE DESIRED HANDBOOK INFORMATION CANNOT BE')
17909        CALL DPWRST('XXX','BUG ')
17910        WRITE(ICOUT,3314)
17911 3314   FORMAT('      GIVEN BECAUSE THE REQUIRED SYSTEM MASS STORAGE')
17912        CALL DPWRST('XXX','BUG ')
17913        WRITE(ICOUT,3315)
17914 3315   FORMAT('      FILE WHICH STORES SUCH HANDBOOK INFORMATION')
17915        CALL DPWRST('XXX','BUG ')
17916        WRITE(ICOUT,3316)
17917 3316   FORMAT('      IS NOT AVAILABLE AT THIS INSTALLATION.')
17918        CALL DPWRST('XXX','BUG ')
17919        WRITE(ICOUT,3317)ISTAT,IHHBST
17920 3317   FORMAT('ISTAT,IHELST = ',A12,2X,A12)
17921        CALL DPWRST('XXX','BUG ')
17922        WRITE(ICOUT,3318)IFILE(1:50)
17923 3318   FORMAT('IFILE(1:50) = ',A50)
17924        CALL DPWRST('XXX','BUG ')
17925        IERROR='YES'
17926        GOTO9000
17927      ENDIF
17928C
17929C               *********************
17930C               **  STEP 34--      **
17931C               **  OPEN THE FILE  **
17932C               *********************
17933C
17934      ISTEPN='34'
17935      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
17936     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17937C
17938      IREWIN='ON'
17939      CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
17940     1IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
17941      IF(IERRFI.EQ.'YES')GOTO9000
17942C
17943C               ******************************************************
17944C               **  STEP 52.1--                                     **
17945C               **  LOOP THROUGH THE VARIOUS LINES OF THIS SECTION  **
17946C               **  OF THE FILE.                                    **
17947C               ******************************************************
17948C
17949 5099 CONTINUE
17950      ISTEPN='52.1'
17951      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HEL1')
17952     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17953C
17954      ICALL=' '
17955      DO5100I=MAXBRO,1,-1
17956         NUMBRO=I
17957         IF(IBROWS(I:I).NE.' ')GOTO5109
17958 5100 CONTINUE
17959 5109 CONTINUE
17960C
17961      IFLAGE=0
17962      IF(NUMBRO.GE.4 .AND.
17963     1   (IBROWS(NUMBRO-4:NUMBRO-1).EQ.'EDGE' .OR.
17964     1    IBROWS(NUMBRO-4:NUMBRO-1).EQ.'edge'))THEN
17965        IFLAGE=1
17966        ICALL(1:21)='start microsoft-edge:'
17967        NCSTR=21
17968      ELSEIF(NUMBRO.GT.0)THEN
17969        ICALL(1:NUMBRO)=IBROWS(1:NUMBRO)
17970        NCSTR=NUMBRO+1
17971        ICALL(NCSTR:NCSTR)=' '
17972      ELSE
17973        IF(IHOST1.EQ.'IBM-'.AND.ICOMPI.EQ.'MS-F')THEN
17974          ICALL(1:NCPROF)=PROFIL(1:NCPROF)
17975          NCSTR=NCPROF
17976          ICALL(NCSTR+1:32)='\Internet Explorer\iexplore.exe '
17977          NCSTR=NCSTR+32
17978        ELSEIF(IOPSY2.EQ.'MAC')THEN
17979          ICALL(1:4)='open'
17980          NCSTR=4
17981        ELSEIF(IOPSY1.EQ.'UNIX' .OR. IOPSY1.EQ.'LINU')THEN
17982          ICALL(1:8)='xdg-open'
17983          NCSTR=8
17984        ENDIF
17985      ENDIF
17986C
17987CCCCC IBRWFL='FIRE'
17988CCCCC IF(NUMBRO.GE.8)THEN
17989CCCCC   DO5125I=1,NUMBRO-7
17990CCCCC     IF(IBROWS(I:I+7).EQ.'IEXPLORE' .OR.
17991CCCCC1       IBROWS(I:I+7).EQ.'iexplore')THEN
17992CCCCC        IBRWFL='IEXP'
17993CCCCC        GOTO5128
17994CCCCC     ENDIF
17995C5125   CONTINUE
17996C5128   CONTINUE
17997CCCCC ENDIF
17998C
17999      NUMURL=NCHURL
18000C
18001C  IF "SET NETSCAPE OLD" COMMAND WAS ENTERED, THEN USE
18002C  -remote NETSCAPE OPTION.  THIS ONLY APPLIES TO UNIX PLATFORMS.
18003C
18004C  2015/11: COMMENT OUT THIS SECTION AS IT WAS FOR NETSCAPE.
18005C
18006CCCCC IF(IHOST1.EQ.'IBM-')THEN
18007CCCCC   IF(IBRWFL.EQ.'NETS')THEN
18008CCCCC     NCSTR=NCSTR+1
18009CCCCC     NCSTR2=NCSTR+3
18010CCCCC     ICALL(NCSTR:NCSTR2)=' -h '
18011CCCCC     NCSTR=NCSTR2
18012CCCCC   ENDIF
18013CCCCC   GOTO5129
18014CCCCC ENDIF
18015CCCCC IF(INETSW.EQ.'OLD'.AND.IHOST1.NE.'IBM-')THEN
18016CCCCC   NCSTR=NCSTR+1
18017CCCCC   NCSTR2=NCSTR+8
18018CCCCC   ICALL(NCSTR:NCSTR2)=' -remote '
18019CCCCC   NCSTR=NCSTR2+1
18020CCCCC   ICALL(NCSTR:NCSTR)=IQUOTE
18021CCCCC   NCSTR=NCSTR+1
18022CCCCC   NCSTR2=NCSTR+7
18023CCCCC   ICALL(NCSTR:NCSTR2)='openURL('
18024CCCCC   NCSTR=NCSTR2
18025CCCCC ENDIF
18026C
18027      IF(NUMURL.GT.0)THEN
18028        NCSTR=NCSTR+1
18029        NCSTR2=NCSTR+NUMURL-1
18030        ICALL(NCSTR:NCSTR2)=IHBURL(1:NUMURL)
18031        N1URL=NCSTR
18032        N2URL=NCSTR2
18033        NCSTR=NCSTR2
18034      ELSE
18035        NCSTR=NCSTR+1
18036        N1URL=NCSTR
18037        NCSTR2=NCSTR+7
18038        ICALL(NCSTR:NCSTR2)='https://'
18039        NCSTR=NCSTR2
18040        NCSTR=NCSTR+1
18041        NCSTR2=NCSTR+16
18042        ICALL(NCSTR:NCSTR2)='www.itl.nist.gov/'
18043        NCSTR=NCSTR2
18044        NCSTR=NCSTR+1
18045        NCSTR2=NCSTR+19
18046        ICALL(NCSTR:NCSTR2)='itl/div898/handbook/'
18047        NCSTR=NCSTR2
18048        N2URL=NCSTR2
18049      ENDIF
18050C
18051      IF(IWORD1.EQ.'HOME'.AND.IWOR12.EQ.'PAGE')GOTO5300
18052      DO5200I=1,100000
18053      ILINE1=' '
18054      ILINE2=' '
18055      I2=I
18056C
18057C               *****************************************
18058C               **  STEP 52.2--                        **
18059C               **  READ IN SUCCEEDING LINES UNTIL     **
18060C               **  GET A HIT BASED ON THE FIRST WORD  **
18061C               **  OF THE COMMAND.                    **
18062C               *****************************************
18063C
18064      ISTEPN='52.2'
18065      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
18066     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18067C
18068      READ(IOUNIT,5202,END=5280)ILINE1,ILINE2
18069 5202 FORMAT(A40,A40)
18070      IF(ILINE1(1:4).EQ.'    ')GOTO5200
18071C
18072      ICTEST=' '
18073      ICTES2=' '
18074      NBLANK=41
18075      DO5203II=1,40
18076        IF(ILINE1(II:II).EQ.' '.OR.ILINE1(II:II).EQ.'-')THEN
18077          NBLANK=II
18078          GOTO5204
18079        ENDIF
18080 5203 CONTINUE
18081 5204 CONTINUE
18082      IF(NBLANK.LE.5)THEN
18083        ICTEST(1:NBLANK-1)=ILINE1(1:NBLANK-1)
18084      ELSE
18085        NLAST=NBLANK
18086        IF(NLAST.GT.9)NLAST=9
18087        ICTEST(1:4)=ILINE1(1:4)
18088        ICTES2(1:NLAST-5)=ILINE1(5:NLAST-1)
18089      ENDIF
18090C
18091      IF(ICTEST.NE.IWORD1)GOTO5200
18092CCCC  IF(ICTES2.NE.' '.AND.ICTES2.NE.IWOR12)GOTO5200
18093C
18094      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HANW')THEN
18095         WRITE(ICOUT,999)
18096         CALL DPWRST('XXX','BUG ')
18097         WRITE(ICOUT,5206)I,ILINE1(1:40)
18098 5206    FORMAT('I,ILINE1(1:40)=',I8,2X,A40)
18099         CALL DPWRST('XXX','BUG ')
18100         WRITE(ICOUT,5207)I,ILINE2(1:40)
18101 5207    FORMAT('I,ILINE2(1:40)=',I8,2X,A40)
18102         CALL DPWRST('XXX','BUG ')
18103         WRITE(ICOUT,5208)NUMARG,NUMAR2,IWORD1,IWOR12,ICTEST,ICTES2
18104 5208    FORMAT('NUMARG,NUMAR2,IWORD1,IWOR12,ICTEST,ICTES2 = ',
18105     1   I8,I8,2X,A4,2X,A4,2X,A4,2x,A4)
18106         CALL DPWRST('XXX','BUG ')
18107      ENDIF
18108C
18109C               ***********************************************
18110C               **  STEP 52.3--                              **
18111C               **  IF GOT A HIT ON THE FIRST 4-CHAR. WORD,  **
18112C               **  CHECK FOR A HIT ON ALL 4-CHAR WORDS      **
18113C               ***********************************************
18114C
18115CCCCC FIX A FEW SMALL BUGS IN THIS SECTION.  AUGUST 1999.
18116CCCCC 1) TREAT HYPHEN AS SPACE
18117CCCCC 2) VALUES OF ILOCP2, ILOCP3, ILOCP4 IF LESS THAN 3 CHARACTERS
18118C
18119      ISTEPN='52.3'
18120      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HANW')
18121     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18122C
18123      NSTRT=NBLANK
18124      NUMWHF=1
18125      IZ1(1:4)=ICTEST(1:4)
18126      IZ2=' '
18127      IZ3=' '
18128      IZ4=' '
18129C
18130C  LOOK FOR SECOND WORD
18131C
18132      DO5212II=NBLANK,40
18133        IF(ILINE1(II:II).NE.' '.AND.ILINE1(II:II).NE.'-')THEN
18134          NSTRT=II
18135          DO5214J=II,40
18136            IF(ILINE1(J:J).EQ.' '.OR.ILINE1(J:J).EQ.'-')THEN
18137              NLAST=J-1
18138              GOTO5219
18139            ENDIF
18140 5214     CONTINUE
18141        ENDIF
18142 5212 CONTINUE
18143      NLAST=0
18144 5219 CONTINUE
18145      IF(NLAST.LE.0)GOTO5270
18146      NUMWHF=2
18147      NCH=NLAST-NSTRT+1
18148      IF(NCH.GT.4)NCH=4
18149      IZ2(1:NCH)=ILINE1(NSTRT:NSTRT+NCH-1)
18150      NBLANK=NLAST+1
18151      IF(NBLANK.GE.40)GOTO5270
18152C
18153C  LOOK FOR THIRD WORD
18154C
18155      DO5222II=NBLANK,40
18156        IF(ILINE1(II:II).NE.' '.AND.ILINE1(II:II).NE.'-')THEN
18157          NSTRT=II
18158          DO5224J=II,40
18159            IF(ILINE1(J:J).EQ.' '.OR.ILINE1(J:J).EQ.'-')THEN
18160              NLAST=J-1
18161              GOTO5229
18162            ENDIF
18163 5224     CONTINUE
18164        ENDIF
18165 5222 CONTINUE
18166      NLAST=0
18167 5229 CONTINUE
18168      IF(NLAST.LE.0)GOTO5270
18169      NUMWHF=3
18170      NCH=NLAST-NSTRT+1
18171      IF(NCH.GT.4)NCH=4
18172      IZ3(1:NCH)=ILINE1(NSTRT:NSTRT+NCH-1)
18173      NBLANK=NLAST+1
18174      IF(NBLANK.GE.40)GOTO5270
18175C
18176C  LOOK FOR FOURTH WORD
18177C
18178      DO5232II=NBLANK,40
18179        IF(ILINE1(II:II).NE.' '.AND.ILINE1(II:II).NE.'-')THEN
18180          NSTRT=II
18181          DO5234J=II,40
18182            IF(ILINE1(J:J).EQ.' '.OR.ILINE1(J:J).EQ.'-')THEN
18183              NLAST=J-1
18184              GOTO5239
18185            ENDIF
18186 5234     CONTINUE
18187        ENDIF
18188 5232 CONTINUE
18189      NLAST=0
18190 5239 CONTINUE
18191      IF(NLAST.LE.0)GOTO5270
18192      NUMWHF=4
18193      NCH=NLAST-NSTRT+1
18194      IF(NCH.GT.4)NCH=4
18195      IZ4(1:NCH)=ILINE1(NSTRT:NSTRT+NCH-1)
18196      NBLANK=NLAST+1
18197      IF(NBLANK.GE.40)GOTO5270
18198C
18199 5270 CONTINUE
18200C
18201      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HANW')THEN
18202         WRITE(ICOUT,5241)
18203 5241    FORMAT('***** FROM 1731 IN MIDDLE OF DPHANW--')
18204         CALL DPWRST('XXX','BUG ')
18205         WRITE(ICOUT,5242)IWORD1,IWOR12,IWORD2,IWORD3,IWORD4
18206 5242    FORMAT('IWORD1,IWOR12,IWORD2,IWORD3,IWORD4 = ',
18207     1   A4,2X,A4,2X,A4,2X,A4,2X,A4)
18208         CALL DPWRST('XXX','BUG ')
18209         WRITE(ICOUT,5243)ILINE1(1:40)
18210 5243    FORMAT('ILINE1(1:40) = ',A40)
18211         CALL DPWRST('XXX','BUG ')
18212         WRITE(ICOUT,5244)IZ1,IZ2,IZ3,IZ4
18213 5244    FORMAT('IZ1,IZ2,IZ3,IZ4 = ',A4,2X,A4,2X,A4,2X,A4)
18214         CALL DPWRST('XXX','BUG ')
18215         WRITE(ICOUT,5245)ISTRIN
18216 5245    FORMAT('ISTRIN = ',A40)
18217         CALL DPWRST('XXX','BUG ')
18218         WRITE(ICOUT,5246)NUMARG,NUMAR2,NUMWHF
18219 5246    FORMAT('NUMARG,NUMAR2,NUMWHF = ',3I8)
18220         CALL DPWRST('XXX','BUG ')
18221         WRITE(ICOUT,5247)ILOC2,ILOC3,ILOC4
18222 5247    FORMAT('ILOC2,ILOC3,ILOC4 = ',3I8)
18223         CALL DPWRST('XXX','BUG ')
18224         WRITE(ICOUT,5248)ILOC2P,ILOC3P,ILOC4P
18225 5248    FORMAT('ILOC2P,ILOC3P,ILOC4P = ',3I8)
18226         CALL DPWRST('XXX','BUG ')
18227      ENDIF
18228C
18229CCCCC THE FOLLOWING LINE WAS ADDED AUGUST 1994
18230      IF(NUMAR2.NE.NUMWHF)GOTO5200
18231C
18232      IF(NUMAR2.LE.1 .OR. NUMWHF.LE.1)GOTO5290
18233      IF(IZ2.EQ.IWORD2)GOTO5253
18234      GOTO5200
18235C
18236 5253 CONTINUE
18237      IF(NUMAR2.LE.2 .OR. NUMWHF.LE.2)GOTO5290
18238      IF(IZ3.EQ.IWORD3)GOTO5254
18239      GOTO5200
18240C
18241 5254 CONTINUE
18242      IF(NUMAR2.LE.3 .OR. NUMWHF.LE.3)GOTO5290
18243      IF(IZ4.EQ.IWORD4)GOTO5290
18244C
18245 5200 CONTINUE
18246C
18247 5280 CONTINUE
18248      IERROR='YES'
18249CCCCC ONLY ONE PASS MADE.  FEBRUARY 2000.
18250CCCCC IF(IPASS.GE.2)THEN
18251         WRITE(ICOUT,999)
18252         CALL DPWRST('XXX','BUG ')
18253         WRITE(ICOUT,3311)
18254         CALL DPWRST('XXX','BUG ')
18255         WRITE(ICOUT,5282)
18256 5282    FORMAT('      THE SPECIFIED COMMAND FOR WHICH')
18257         CALL DPWRST('XXX','BUG ')
18258         WRITE(ICOUT,5283)
18259 5283    FORMAT('      WEB HANDBOOK WAS DESIRED WAS NOT FOUND')
18260         CALL DPWRST('XXX','BUG ')
18261         WRITE(ICOUT,5284)
18262 5284    FORMAT('      IN THE HELP FILE.')
18263         CALL DPWRST('XXX','BUG ')
18264         WRITE(ICOUT,5285)
18265 5285    FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
18266         CALL DPWRST('XXX','BUG ')
18267         WRITE(ICOUT,5286)(IANS(I),I=1,MIN(120,IWIDTH))
18268 5286    FORMAT('      ',120A1)
18269         CALL DPWRST('XXX','BUG ')
18270CCCCC ENDIF
18271      GOTO6100
18272C
18273 5290 CONTINUE
18274C
18275C               ****************************************************
18276C               **  STEP 53--                                     **
18277C               **  IF HAVE A HIT ON ALL WORDS,                   **
18278C               **  THEN USE DPSYS2 TO MAKE A SYSTEM CALL         **
18279C               **  TO INIATE NETSCAPE.                           **
18280C               **  CHECK IF URL BEGINS WITH http (A FEW SPECIAL  **
18281C               **  CASES GO TO NON-DATAPLOT WEB PAGE             **
18282C               ****************************************************
18283C
18284 5300 CONTINUE
18285      ISTEPN='53'
18286      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HANW')
18287     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18288C
18289      IF(IWORD1.EQ.'HOME'.AND.IWOR12.EQ.'PAGE')THEN
18290        NCSTR=NCSTR+1
18291        NCSTR2=NCSTR+12
18292        ICALL(NCSTR:NCSTR2)='homepage.html'
18293        NCSTR=NCSTR2
18294        GOTO5349
18295      ENDIF
18296C
18297      DO5330J=40,1,-1
18298        NTEMP=J
18299        IF(ILINE2(J:J).NE.' ')GOTO5339
18300 5330 CONTINUE
18301 5339 CONTINUE
18302      IF(NTEMP.LE.0)THEN
18303        WRITE(ICOUT,999)
18304        CALL DPWRST('XXX','BUG ')
18305        WRITE(ICOUT,5351)
18306        CALL DPWRST('XXX','BUG ')
18307        ILINE2(1:13)='homepage.html'
18308        NTEMP=13
18309      ENDIF
18310 5351 FORMAT('***** WARNING: NO MATCH FOUND, DEFAULT TO HANDBOOK ',
18311     1'HOME PAGE.')
18312C
18313C  ABSOLUTE URL ADDRESS FOUND
18314C
18315      IF(ILINE2(1:5).EQ.'http:')THEN
18316        ICALL(N1URL:N2URL)=' '
18317        NCSTR=N1URL-1
18318      ENDIF
18319C
18320      NCSTR=NCSTR+1
18321      NCSTR2=NCSTR+NTEMP-1
18322      ICALL(NCSTR:NCSTR2)=ILINE2(1:NTEMP)
18323      NCSTR=NCSTR2
18324 5349 CONTINUE
18325CCCCC IF(INETSW.EQ.'OLD'.AND.IHOST1.NE.'IBM-')THEN
18326CCCCC   NCSTR=NCSTR+1
18327CCCCC   ICALL(NCSTR:NCSTR)=')'
18328CCCCC   NCSTR=NCSTR+1
18329CCCCC   ICALL(NCSTR:NCSTR)=IQUOTE
18330CCCCC ENDIF
18331      IF(IHOST1.NE.'IBM-')THEN
18332        NCSTR=NCSTR+1
18333        NCSTR2=NCSTR+1
18334        ICALL(NCSTR:NCSTR2)=' &'
18335        NCSTR=NCSTR2
18336      ENDIF
18337C
18338CCCCC IF(INETSW.EQ.'NEW')THEN
18339CCCCC   WRITE(ICOUT,999)
18340CCCCC   CALL DPWRST('XXX','BUG ')
18341CCCCC   WRITE(ICOUT,5411)
18342CCCCC   CALL DPWRST('XXX','BUG ')
18343CCCCC   WRITE(ICOUT,999)
18344CCCCC   CALL DPWRST('XXX','BUG ')
18345C
18346C       NETSCAPE BROWSER IS OBSOLETE, SO SUPPRESS THIS MESSAGE
18347C
18348CCCCC   IF(IHOST1.NE.'IBM-')THEN
18349CCCCC     WRITE(ICOUT,5412)
18350CCCCC     CALL DPWRST('XXX','BUG ')
18351CCCCC     WRITE(ICOUT,5413)
18352CCCCC     CALL DPWRST('XXX','BUG ')
18353CCCCC     WRITE(ICOUT,5414)
18354CCCCC     CALL DPWRST('XXX','BUG ')
18355CCCCC     WRITE(ICOUT,999)
18356CCCCC     CALL DPWRST('XXX','BUG ')
18357CCCCC     WRITE(ICOUT,5415)
18358CCCCC     CALL DPWRST('XXX','BUG ')
18359CCCCC     WRITE(ICOUT,999)
18360CCCCC     CALL DPWRST('XXX','BUG ')
18361CCCCC   ENDIF
18362CCCCC ENDIF
18363C5411 FORMAT('*****NOTE: IT MAY TAKE THE BROWSER A FEW MOMENTS TO ',
18364CCCCC1      'START UP.')
18365C5412 FORMAT('     IF YOU ARE USING THE NETSCAPE BROWSER, YOU CAN ',
18366CCCCC1       'SPEED UP SUBSEQUENT')
18367C5413 FORMAT('     USE OF WEB HANDBOOK BY ENTERING THE FOLLOWING ',
18368CCCCC1       'DATAPLOT COMMAND')
18369C5414 FORMAT('     (LEAVE THE BROWSER OPEN):')
18370C5415 FORMAT('         SET NETSCAPE OLD')
18371C
18372      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HANW')THEN
18373         WRITE(ICOUT,5441)NCSTR
18374 5441    FORMAT('AT CALL DPSYS2, NCSTR = ',I8)
18375         CALL DPWRST('XXX','BUG ')
18376         WRITE(ICOUT,5443)ICALL(1:100)
18377 5443    FORMAT('ICALL(1:100)=',A100)
18378         CALL DPWRST('XXX','BUG ')
18379      ENDIF
18380CCCCC CLOSE FILE BEFORE CALL DPSYS2.  SEEMS TO CAUSE A PROBLEM ON
18381CCCCC RS-6000.  FEBRUARY 2000.
18382      IENDFI='OFF'
18383      IREWIN='ON'
18384      CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
18385     1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERRO2)
18386      IF(IERRFI.EQ.'YES')GOTO9000
18387      ISSAV1=ISYSPE
18388      ISSAV2=ISYSHI
18389      ICLESV=ICLEWT
18390      ISYSPE='OFF'
18391      ISYSHI='ON'
18392      ICLEWT='OFF'
18393      CALL DPSYS2(ICALL,NCSTR,ISUBRO,IERROR)
18394      ISYSPE=ISSAV1
18395      ISYSHI=ISSAV2
18396      ICLEWT=ICLESV
18397      GOTO9000
18398C
18399C               **************************************
18400C               **  STEP 61--                       **
18401C               **  CLOSE           THE HELP FILE.  **
18402C               **************************************
18403C
18404 6100 CONTINUE
18405C
18406      ISTEPN='61'
18407      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
18408     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18409C
18410      IF(IWORD1.EQ.'HOME'.AND.IWOR12.EQ.'PAGE')GOTO6199
18411      IENDFI='OFF'
18412      IREWIN='ON'
18413      CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
18414     1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERRO2)
18415      IF(IERRFI.EQ.'YES')GOTO9000
18416 6199 CONTINUE
18417      GOTO9000
18418C
18419C               ****************
18420C               **  STEP 90-- **
18421C               **  EXIT.     **
18422C               ****************
18423C
18424 9000 CONTINUE
18425      IF(IBUGS2.EQ.'ON' .OR. ISUBRO.EQ.'HANW')THEN
18426        WRITE(ICOUT,999)
18427        CALL DPWRST('XXX','BUG ')
18428        WRITE(ICOUT,9011)
18429 9011   FORMAT('***** AT THE END       OF DPHANW--')
18430        CALL DPWRST('XXX','BUG ')
18431        WRITE(ICOUT,9028)IERRO2,IFOUND,IERROR,ICHAR1,IOUNIT
18432 9028   FORMAT('IERRO2,IFOUND,IERROR,ICHAR1,IOUNIT = ',
18433     1         3(A4,2X),A1,2X,I8)
18434        CALL DPWRST('XXX','BUG ')
18435        WRITE(ICOUT,9032)IFILE
18436 9032   FORMAT('IFILE  = ',A80)
18437        CALL DPWRST('XXX','BUG ')
18438        WRITE(ICOUT,9033)ISTAT,IFORM,IACCES,IPROT
18439 9033   FORMAT('ISTAT,IFORM,IACCES,IPROT  = ',3(A12,2X),A12)
18440        CALL DPWRST('XXX','BUG ')
18441        WRITE(ICOUT,9037)ICURST,IENDFI,IREWIN,IERRFI,ISUBN0
18442 9037   FORMAT('ICURST,IENDFI,IREWIN,IERRFI,ISUBN0 = ',A12,4(2X,A4))
18443        CALL DPWRST('XXX','BUG ')
18444        WRITE(ICOUT,9043)IWORD1,IWORD2,IWORD3,IWORD4,IWOR12,ICHAR1
18445 9043   FORMAT('IWORD1,IWORD2,IWORD3,IWORD4,IWOR12,ICHAR1 = ',
18446     1         5(A4,2X),A4)
18447        CALL DPWRST('XXX','BUG ')
18448        WRITE(ICOUT,9060)ILINE1(1:40),ICTEST
18449 9060   FORMAT('ILINE1(1:40),ICTEST =',A30,2X,A4)
18450        CALL DPWRST('XXX','BUG ')
18451        WRITE(ICOUT,9061)NUMSEC,NUMLIN,ISECNA,NUMWHF
18452 9061   FORMAT('NUMSEC,NUMLIN,ISECNA,NUMWHF = ',4I8)
18453        CALL DPWRST('XXX','BUG ')
18454        WRITE(ICOUT,9064)ILINE1(1:40)
18455 9064   FORMAT('ILINE1(1:40) = ',A40)
18456        CALL DPWRST('XXX','BUG ')
18457        WRITE(ICOUT,9065)IZ1,IZ2,IZ3,IZ4
18458 9065   FORMAT('IZ1,IZ2,IZ3,IZ4 = ',3(A4,2X),A4)
18459        CALL DPWRST('XXX','BUG ')
18460        WRITE(ICOUT,9066)ISTRIN
18461 9066   FORMAT('ISTRIN = ',A40)
18462        CALL DPWRST('XXX','BUG ')
18463        WRITE(ICOUT,9068)ILOC2,ILOC3,ILOC4,IPASS
18464 9068   FORMAT('ILOC2,ILOC3,ILOC4,IPASS = ',4I8)
18465        CALL DPWRST('XXX','BUG ')
18466        WRITE(ICOUT,9069)ILOC2P,ILOC3P,ILOC4P,I2
18467 9069   FORMAT('ILOC2P,ILOC3P,ILOC4P,I2 = ',4I8)
18468        CALL DPWRST('XXX','BUG ')
18469        WRITE(ICOUT,9097)IBROWS(1:80)
18470 9097   FORMAT('IBROWS = ',A80)
18471        CALL DPWRST('XXX','BUG ')
18472        WRITE(ICOUT,9098)IHBURL(1:80)
18473 9098   FORMAT('IHBURL = ',A80)
18474        CALL DPWRST('XXX','BUG ')
18475        WRITE(ICOUT,9099)ICALL(1:256)
18476 9099   FORMAT('ICALL = ',A256)
18477        CALL DPWRST('XXX','BUG ')
18478      ENDIF
18479C
18480      RETURN
18481      END
18482      SUBROUTINE DPHAPW(IHARG,IHARG2,IARGT,IARG,NUMARG,
18483     1                  ICOPSW,NUMCOP,
18484     1                  IBUGO2,ISUBRO,IFOUND,IERROR)
18485C
18486C     PURPOSE--TURN ON THE LOCAL HARDCOPY DEVICE
18487C              AND DEFINE THE NUMBER OF DESIRED COPIES.
18488C              THE POWER STATUS OF THE LOCAL HARDCOPY WILL BE
18489C              PLACED IN THE CHARACTER VARIABLE ICOPSW (ON/OFF).
18490C              THE NUMBER OF COPIES TO BE MADE WILL BE
18491C              PLACED IN THE INTEGER VARIABLE NUMCOP.
18492C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
18493C                     --IHARG2 (A CHARACTER VECTOR)
18494C                     --IARGT  (A CHARACTER VECTOR)
18495C                     --IARG   (A CHARACTER VECTOR)
18496C                     --NUMARG
18497C     OUTPUT ARGUMENTS--ICOPSW (A CHARACTER VECTOR
18498C                              WHICH CONTAINS THE
18499C                              POWER (ON/OFF) FOR THE LOCAL HARDCOPY UNIT.
18500C                     --NUMCOP (AN INTEGER VARIABLE
18501C                              WHICH CONTAINS THE NUMBER OF COPIES
18502C                              TO BE MADE.
18503C                     --IFOUND ('YES' OR 'NO')
18504C                     --IERROR ('YES' OR 'NO' )
18505C     WRITTEN BY--JAMES J. FILLIBEN
18506C                 STATISTICAL ENGINEERING DIVISION
18507C                 INFORMATION TECHNOLOGY LABORATORY
18508C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
18509C                 GAITHERSBURG, MD 20899-8980
18510C                 PHONE--301-975-2855
18511C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
18512C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
18513C     LANGUAGE--ANSI FORTRAN (1977)
18514C     VERSION NUMBER--82/7
18515C     ORIGINAL VERSION--OCTOBER   1978.
18516C     UPDATED         --NOVEMBER  1980.
18517C     UPDATED         --MAY       1982.
18518C
18519C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
18520C
18521      CHARACTER*4 IHARG
18522      CHARACTER*4 IHARG2
18523      CHARACTER*4 IARGT
18524      CHARACTER*4 ICOPSW
18525      CHARACTER*4 IBUGO2
18526      CHARACTER*4 ISUBRO
18527      CHARACTER*4 IFOUND
18528      CHARACTER*4 IERROR
18529C
18530      CHARACTER*4 IDEV
18531      CHARACTER*4 IHOLD1
18532C
18533C---------------------------------------------------------------------
18534C
18535      DIMENSION IHARG(*)
18536      DIMENSION IHARG2(*)
18537      DIMENSION IARGT(*)
18538      DIMENSION IARG(*)
18539C
18540C---------------------------------------------------------------------
18541C
18542      INCLUDE 'DPCOP2.INC'
18543C
18544C-----START POINT-----------------------------------------------------
18545C
18546      IFOUND='NO'
18547      IERROR='NO'
18548      IDEV='HARD'
18549C
18550      IF(IBUGO2.EQ.'ON' .OR. ISUBRO.EQ.'HAPW')THEN
18551        DO55I=1,NUMARG
18552          WRITE(ICOUT,56)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I)
18553   56     FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I) = ',
18554     1           I8,3(2X,A4),2X,I8)
18555          CALL DPWRST('XXX','BUG ')
18556   55   CONTINUE
18557      ENDIF
18558C
18559      IF(NUMARG.LE.0)GOTO1160
18560C
18561      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'ON')GOTO1160
18562      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'OFF')GOTO1161
18563      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'AUTO')GOTO1160
18564      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'DEFA')GOTO1161
18565      IF(NUMARG.EQ.1.AND.IARGT(1).EQ.'NUMB')GOTO1162
18566C
18567      IF(NUMARG.EQ.2.AND.IHARG(1).EQ.'ON'.AND.IARGT(2).EQ.'NUMB')
18568     1GOTO1163
18569      IF(NUMARG.EQ.2.AND.IHARG(1).EQ.'OFF'.AND.IARGT(2).EQ.'NUMB')
18570     1GOTO1161
18571      IF(NUMARG.EQ.2.AND.IHARG(1).EQ.'AUTO'.AND.IARGT(2).EQ.'NUMB')
18572     1GOTO1163
18573      IF(NUMARG.EQ.2.AND.IHARG(1).EQ.'DEFA'.AND.IARGT(2).EQ.'NUMB')
18574     1GOTO1161
18575C
18576      GOTO1199
18577C
18578 1160 CONTINUE
18579      IHOLD1='ON'
18580      IHOLD2=1
18581      GOTO1180
18582C
18583 1161 CONTINUE
18584      IHOLD1='OFF'
18585      IHOLD2=-1
18586      GOTO1180
18587C
18588 1162 CONTINUE
18589      IHOLD1='ON'
18590      IHOLD2=IARG(1)
18591      GOTO1180
18592C
18593 1163 CONTINUE
18594      IHOLD1='ON'
18595      IHOLD2=IARG(2)
18596      GOTO1180
18597C
18598 1180 CONTINUE
18599      IFOUND='YES'
18600      ICOPSW=IHOLD1
18601      NUMCOP=IHOLD2
18602C
18603      IF(IFEEDB.EQ.'OFF')GOTO1189
18604      WRITE(ICOUT,999)
18605  999 FORMAT(1X)
18606      CALL DPWRST('XXX','BUG ')
18607      WRITE(ICOUT,1181)IHOLD1
18608 1181 FORMAT('THE LOCAL HARDCOPY HAS JUST BEEN TURNED ',A4)
18609      CALL DPWRST('XXX','BUG ')
18610      IF(ICOPSW.EQ.'ON'.AND.NUMCOP.EQ.1)WRITE(ICOUT,1182)NUMCOP
18611 1182 FORMAT('    (WITH ',I3,' HARDCOPY   PER PLOT)')
18612      IF(ICOPSW.EQ.'ON'.AND.NUMCOP.EQ.1)CALL DPWRST('XXX','BUG ')
18613      IF(ICOPSW.EQ.'ON'.AND.NUMCOP.GE.2)WRITE(ICOUT,1183)NUMCOP
18614 1183 FORMAT('    (WITH ',I3,' HARDCOPIES PER PLOT)')
18615      IF(ICOPSW.EQ.'ON'.AND.NUMCOP.GE.2)CALL DPWRST('XXX','BUG ')
18616 1189 CONTINUE
18617      GOTO1199
18618C
18619 1199 CONTINUE
18620      RETURN
18621      END
18622      SUBROUTINE DPHAZA(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
18623     1                  IANGLU,MAXNPP,
18624     1                  IX1TSC,IX2TSC,IY1TSC,IY2TSC,
18625     1                  IX1TSV,IX2TSV,IY1TSV,IY2TSV,
18626     1                  IX1ZFM,IX2ZFM,IY1ZFM,IY2ZFM,
18627     1                  IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV,
18628     1                  IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
18629C
18630C     PURPOSE--FORM A NORMAL/LOGNORMAL/EXPONENTIAL/WEIBULL/GUMBEL
18631C              HAZARD PLOT
18632C     EXAMPLE--LOGNORMAL HAZARD PLOT Y
18633C              LOGNORMAL HAZARD PLOT Y TAG
18634C     NOTE--THIS COMMAND CAN HAVE 1 OR 2 ARGUMENTS.  ARGUMENT 1 IS THE
18635C           RESPONSE VARIABLE IF THE HAZARD PLOT COMMAND HAS ONLY
18636C           1 ARGUMENT, THEN IT IS ASSUMED THAT ALL OF THE DATA IS TO
18637C           BE INCLUDED (THAT IS, NO CENSORING).
18638C     NOTE--SOMETIMES THIS COMMAND HAS 2 ARGUMENTS--
18639C           ARGUMENT 1 IS THE RESPONSE VARIABLE
18640C           ARGUMENT 2 IS THE CENSOR-TAG VARIABLE
18641C     WRITTEN BY--JAMES J. FILLIBEN
18642C                 STATISTICAL ENGINEERING DIVISION
18643C                 INFORMATION TECHNOLOGY LABORATORY
18644C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
18645C                 GAITHERSBURG, MD 20899-8980
18646C                 PHONE--301-975-2855
18647C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
18648C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
18649C     LANGUAGE--ANSI FORTRAN (1977)
18650C     VERSION NUMBER--98/5
18651C     ORIGINAL VERSION--MAY       1998. THIS IMPLEMENTATION NOT WORKING
18652C     UPDATED         --JANUARY   2006. CORRECT IMPLEMENTATION
18653C     UPDATED         --JANUARY   2007. CALL LIST TO CUMHAZ
18654C     UPDATED         --FEBRUARY  2012. USE DPPARS, DPPAR3
18655C
18656C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
18657C
18658      CHARACTER*4 ICASPL
18659      CHARACTER*4 IAND1
18660      CHARACTER*4 IAND2
18661C
18662      CHARACTER*4 IX1TSC
18663      CHARACTER*4 IX2TSC
18664      CHARACTER*4 IY1TSC
18665      CHARACTER*4 IY2TSC
18666C
18667      CHARACTER*4 IX1TSV
18668      CHARACTER*4 IX2TSV
18669      CHARACTER*4 IY1TSV
18670      CHARACTER*4 IY2TSV
18671C
18672      CHARACTER*4 IX1ZFM
18673      CHARACTER*4 IX2ZFM
18674      CHARACTER*4 IY1ZFM
18675      CHARACTER*4 IY2ZFM
18676C
18677      CHARACTER*4 IX1ZSV
18678      CHARACTER*4 IX2ZSV
18679      CHARACTER*4 IY1ZSV
18680      CHARACTER*4 IY2ZSV
18681C
18682      CHARACTER*4 IANGLU
18683      CHARACTER*4 IBUGG2
18684      CHARACTER*4 IBUGG3
18685      CHARACTER*4 IBUGQ
18686      CHARACTER*4 ISUBRO
18687      CHARACTER*4 IFOUND
18688      CHARACTER*4 IERROR
18689C
18690      CHARACTER*4 IH
18691      CHARACTER*4 IH2
18692      CHARACTER*4 ISUBN1
18693      CHARACTER*4 ISUBN2
18694      CHARACTER*4 ISTEPN
18695C
18696      CHARACTER*4 IHIGH
18697      CHARACTER*4 ICASE
18698      PARAMETER (MAXSPN=10)
18699      CHARACTER*4 IVARN1(MAXSPN)
18700      CHARACTER*4 IVARN2(MAXSPN)
18701      CHARACTER*4 IVARTY(MAXSPN)
18702      REAL PVAR(MAXSPN)
18703      INTEGER ILIS(MAXSPN)
18704      INTEGER NRIGHT(MAXSPN)
18705      INTEGER ICOLR(MAXSPN)
18706      CHARACTER*40 INAME
18707C
18708C---------------------------------------------------------------------
18709C
18710      INCLUDE 'DPCOPA.INC'
18711      INCLUDE 'DPCOZZ.INC'
18712      INCLUDE 'DPCOZI.INC'
18713      DIMENSION Y1(MAXOBV)
18714      DIMENSION Y2(MAXOBV)
18715      DIMENSION YTEMP1(MAXOBV)
18716      DIMENSION YS(MAXOBV)
18717      DIMENSION XHIGH(MAXOBV)
18718      EQUIVALENCE (GARBAG(IGARB1),Y1(1))
18719      EQUIVALENCE (GARBAG(IGARB2),Y2(1))
18720      EQUIVALENCE (GARBAG(IGARB3),YS(1))
18721      EQUIVALENCE (GARBAG(IGARB4),YTEMP1(1))
18722      EQUIVALENCE (GARBAG(IGARB5),XHIGH(1))
18723C
18724C-----COMMON----------------------------------------------------------
18725C
18726      INCLUDE 'DPCOHO.INC'
18727      INCLUDE 'DPCOHK.INC'
18728      INCLUDE 'DPCODA.INC'
18729      INCLUDE 'DPCOP2.INC'
18730C
18731C-----START POINT-----------------------------------------------------
18732C
18733      ISUBN1='DPHA'
18734      ISUBN2='ZA  '
18735      IFOUND='NO'
18736      IERROR='NO'
18737C
18738      MAXCP1=MAXCOL+1
18739      MAXCP2=MAXCOL+2
18740      MAXCP3=MAXCOL+3
18741      MAXCP4=MAXCOL+4
18742      MAXCP5=MAXCOL+5
18743      MAXCP6=MAXCOL+6
18744      IVAL=0
18745C
18746      SIGMA=(-999.0)
18747      AMU=(-999.0)
18748      SDSIGM=(-999.0)
18749      SDAMU=(-999.0)
18750      BPT1=(-999.0)
18751      BPT5=(-999.0)
18752      B1=(-999.0)
18753      B5=(-999.0)
18754      B10=(-999.0)
18755      B20=(-999.0)
18756      B50=(-999.0)
18757      B80=(-999.0)
18758      B90=(-999.0)
18759      B95=(-999.0)
18760      B99=(-999.0)
18761      B995=(-999.0)
18762      B999=(-999.0)
18763C
18764CCCCC THE FOLLOWING 4 LINES WERE ADDED   APRIL 1992
18765      ICUTMX=NUMBPW
18766      IF(IHOST1.EQ.'CDC '.OR.IHOST1.EQ.'CYBE')ICUTMX=48
18767      IF(IHOST1.EQ.'205 ')ICUTMX=48
18768      CUTOFF=2**(ICUTMX-3)
18769C
18770      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HAZA')THEN
18771        WRITE(ICOUT,999)
18772  999   FORMAT(1X)
18773        CALL DPWRST('XXX','BUG ')
18774        WRITE(ICOUT,51)
18775   51   FORMAT('***** AT THE BEGINNING OF DPHAZA--')
18776        CALL DPWRST('XXX','BUG ')
18777        WRITE(ICOUT,53)ICASPL,IAND1,IAND2,MAXN,MAXNPP
18778   53   FORMAT('ICASPL,IAND1,IAND2,MAXN,MAXNPP = ',3(A4,2X),2I8)
18779        CALL DPWRST('XXX','BUG ')
18780        WRITE(ICOUT,54)IANGLU,IBUGG2,IBUGG3,IBUGQ,ISUBRO
18781   54   FORMAT('IANGLU,IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',4(A4,2X),A4)
18782        CALL DPWRST('XXX','BUG ')
18783        WRITE(ICOUT,61)IX1TSC,IX2TSC,IY1TSC,IY2TSC
18784   61   FORMAT('IX1TSC,IX2TSC,IY1TSC,IY2TSC = ',A4,2X,A4,2X,A4,2X,A4)
18785        CALL DPWRST('XXX','BUG ')
18786        WRITE(ICOUT,62)IX1TSV,IX2TSV,IY1TSV,IY2TSV
18787   62   FORMAT('IX1TSV,IX2TSV,IY1TSV,IY2TSV = ',A4,2X,A4,2X,A4,2X,A4)
18788        CALL DPWRST('XXX','BUG ')
18789      ENDIF
18790C
18791C               ***********************************
18792C               **  TREAT THE HAZARD  PLOT CASE  **
18793C               ***********************************
18794C
18795C               ***************************
18796C               **  STEP 11--            **
18797C               **  EXTRACT THE COMMAND  **
18798C               ***************************
18799C
18800      ISTEPN='11'
18801      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HAZA')
18802     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18803C
18804      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'HAZA'.AND.
18805     1   IHARG(2).EQ.'PLOT')THEN
18806        ILASTC=2
18807        IF(ICOM.EQ.'NORM')THEN
18808          ICASPL='NHAZ'
18809        ELSEIF(ICOM.EQ.'LOGN')THEN
18810          ICASPL='LHAZ'
18811        ELSEIF(ICOM.EQ.'EXPO')THEN
18812          ICASPL='EHAZ'
18813        ELSEIF(ICOM.EQ.'WEIB')THEN
18814          ICASPL='WHAZ'
18815        ELSEIF(ICOM.EQ.'GUMB')THEN
18816          ICASPL='GHAZ'
18817        ENDIF
18818      ELSEIF(NUMARG.GE.3.AND.IHARG(2).EQ.'HAZA'.AND.
18819     1   IHARG(3).EQ.'PLOT')THEN
18820        ILASTC=3
18821        IF(ICOM.EQ.'EXTR'.AND.IHARG(1).EQ.'VALU')THEN
18822          ICASPL='GHAZ'
18823        ELSE
18824          GOTO9000
18825        ENDIF
18826      ELSE
18827        GOTO9000
18828      ENDIF
18829C
18830      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
18831      IFOUND='YES'
18832C
18833C               ****************************************
18834C               **  STEP 2--                          **
18835C               **  EXTRACT THE VARIABLE LIST         **
18836C               ****************************************
18837C
18838      ISTEPN='2'
18839      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HAZA')
18840     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18841C
18842      INAME='HAZARD PLOT'
18843      MINNA=1
18844      MAXNA=100
18845      MINN2=1
18846      IFLAGE=1
18847      IFLAGM=1
18848      IFLAGP=0
18849      JMIN=1
18850      JMAX=NUMARG
18851      MINNVA=1
18852      MAXNVA=2
18853CCCCC IF(IHIGH.EQ.'ON')THEN
18854CCCCC   MINNVA=2
18855CCCCC   MAXNVA=3
18856CCCCC ENDIF
18857C
18858      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
18859     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
18860     1            JMIN,JMAX,
18861     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
18862     1            IVARN1,IVARN2,IVARTY,PVAR,
18863     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
18864     1            MINNVA,MAXNVA,
18865     1            IFLAGM,IFLAGP,
18866     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
18867      IF(IERROR.EQ.'YES')GOTO9000
18868C
18869      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HAZA')THEN
18870        WRITE(ICOUT,999)
18871        CALL DPWRST('XXX','BUG ')
18872        WRITE(ICOUT,281)
18873  281   FORMAT('***** AFTER CALL DPPARS--')
18874        CALL DPWRST('XXX','BUG ')
18875        WRITE(ICOUT,282)NQ,NUMVAR
18876  282   FORMAT('NQ,NUMVAR = ',2I8)
18877        CALL DPWRST('XXX','BUG ')
18878        IF(NUMVAR.GT.0)THEN
18879          DO285I=1,NUMVAR
18880            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
18881     1                      ICOLR(I)
18882  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
18883     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
18884            CALL DPWRST('XXX','BUG ')
18885  285     CONTINUE
18886        ENDIF
18887      ENDIF
18888C
18889      DO290I=1,NRIGHT(1)
18890        Y2(I)=1.0
18891        XHIGH(I)=1.0
18892  290 CONTINUE
18893      ICOL=1
18894      CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
18895     1            INAME,IVARN1,IVARN2,IVARTY,
18896     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
18897     1            MAXCOL,MAXCP1,MAXCP2,MAXCP3,
18898     1            MAXCP4,MAXCP5,MAXCP6,
18899     1            V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
18900     1            Y1,Y2,XHIGH,NS,NLOCA2,NLOCA3,ICASE,
18901     1            IBUGG3,ISUBRO,IFOUND,IERROR)
18902      IF(IERROR.EQ.'YES')GOTO9000
18903C
18904      IF(IHIGH.EQ.'ON' .AND. NUMVAR.EQ.2)THEN
18905        DO299I=1,NS
18906          XHIGH(I)=Y2(I)
18907          Y2(I)=1.0
18908  299   CONTINUE
18909      ENDIF
18910C
18911C               *********************************************
18912C               **  STEP 34--                              **
18913C               **  CHECK TO MAKE SURE THAT THE            **
18914C               **  COMBINATION OF CENSORING AND           **
18915C               **  SUBSETTING DOES NOT RESULT IN          **
18916C               **  TOO FEW DATA POINTS RESULTING          **
18917C               **  (AT LEAST 2)                           **
18918C               **  WITH WHICH TO FORM A NORMAL PLOT.      **
18919C               *********************************************
18920C
18921      ISTEPN='34'
18922      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HAZA')
18923     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18924C
18925      ICOUNT=0
18926      IF(NS.LE.2)THEN
18927        ICOUNT=NS
18928      ELSE
18929        DO3400I=1,NS
18930          IF(Y2(I).LE.-0.0001.OR.Y2(I).GE.0.0001)ICOUNT=ICOUNT+1
18931 3400   CONTINUE
18932      ENDIF
18933C
18934      IF(ICOUNT.LE.MINN2)THEN
18935        WRITE(ICOUT,999)
18936        CALL DPWRST('XXX','BUG ')
18937        WRITE(ICOUT,3451)
18938 3451   FORMAT('***** ERROR IN HAZARD PLOT--')
18939        CALL DPWRST('XXX','BUG ')
18940        WRITE(ICOUT,3452)
18941 3452   FORMAT('      AFTER THE SPECIFIED CENSORING AND SUBSETTING ',
18942     1         'HAS BEEN PERFORMED,')
18943        CALL DPWRST('XXX','BUG ')
18944        WRITE(ICOUT,3454)IHRI11,IHRI12
18945 3454   FORMAT('      THE NUMBER OF OBSERVATIONS REMAINING FROM ',
18946     1         'VARIABLE ',A4,A4)
18947        CALL DPWRST('XXX','BUG ')
18948        WRITE(ICOUT,3455)
18949 3455   FORMAT('      (FOR WHICH A HAZARD PLOT IS TO BE FORMED)')
18950        CALL DPWRST('XXX','BUG ')
18951        WRITE(ICOUT,3457)MINN2
18952 3457   FORMAT('      MUST BE ',I8,' OR LARGER;')
18953        CALL DPWRST('XXX','BUG ')
18954        WRITE(ICOUT,3458)ICOUNT
18955 3458   FORMAT('      SUCH WAS NOT THE CASE HERE (ICOUNT = ',I8,')')
18956        CALL DPWRST('XXX','BUG ')
18957        WRITE(ICOUT,3459)
18958 3459   FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
18959        CALL DPWRST('XXX','BUG ')
18960        IF(IWIDTH.GE.1)THEN
18961          WRITE(ICOUT,3460)(IANS(I),I=1,MIN(80,IWIDTH))
18962 3460     FORMAT('      ',80A1)
18963          CALL DPWRST('XXX','BUG ')
18964        ENDIF
18965        IERROR='YES'
18966        GOTO9000
18967      ENDIF
18968C
18969C               *****************************************************
18970C               **  STEP 41--                                       *
18971C               **  FORM THE VERTICAL AND HORIZONTAL AXIS           *
18972C               **  VARIABLES (Y(.) AND X(.), RESPECTIVELY) FOR THE *
18973C               **  PLOT FORM THE CURVE DESIGNATION VARIABLE D(.) . *
18974C               **  THIS WILL BE BOTH ONES FOR BOTH CASES           *
18975C               **  DEFINE THE NUMBER OF PLOT POINTS    (NPLOTP).   *
18976C               **  DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV).   *
18977C               *****************************************************
18978C
18979      ISTEPN='41'
18980      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HAZA')
18981     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18982C
18983      CALL DPHAZ2(Y1,Y2,NS,YTEMP1,ICASPL,MAXN,MAXNXT,
18984     1            IX1TSC,IX2TSC,IY1TSC,IY2TSC,
18985     1            IX1TSV,IX2TSV,IY1TSV,IY2TSV,
18986     1            IX1ZFM,IX2ZFM,IY1ZFM,IY2ZFM,
18987     1            IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV,
18988     1            SIGMA,AMU,SDSIGM,SDAMU,
18989     1            BPT1,BPT5,B1,B5,B10,B20,B50,B80,B90,B95,B99,B995,B999,
18990     1            Y,X,D,NPLOTP,NPLOTV,
18991     1            YS,
18992     1            IBUGG3,ISUBRO,IERROR)
18993C
18994C               ***************************************
18995C               **  STEP 51--                        **
18996C               **  UPDATE INTERNAL DATAPLOT TABLES  **
18997C               ***************************************
18998C
18999      ISTEPN='51'
19000      IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19001      DO5100IPASS=1,17
19002      IF(IPASS.EQ.1)IH='SIGM'
19003      IF(IPASS.EQ.1)IH2='A   '
19004      IF(IPASS.EQ.2)IH='MU'
19005      IF(IPASS.EQ.2)IH2='    '
19006      IF(IPASS.EQ.3)IH='SDSI'
19007      IF(IPASS.EQ.3)IH2='GMA '
19008      IF(IPASS.EQ.4)IH='SDET'
19009      IF(IPASS.EQ.4)IH2='A   '
19010C
19011      IF(IPASS.EQ.5)IH='BPT1'
19012      IF(IPASS.EQ.5)IH2='    '
19013      IF(IPASS.EQ.6)IH='BPT5'
19014      IF(IPASS.EQ.6)IH2='    '
19015      IF(IPASS.EQ.7)IH='B1  '
19016      IF(IPASS.EQ.7)IH2='    '
19017      IF(IPASS.EQ.8)IH='B5  '
19018      IF(IPASS.EQ.8)IH2='    '
19019      IF(IPASS.EQ.9)IH='B10 '
19020      IF(IPASS.EQ.9)IH2='    '
19021      IF(IPASS.EQ.10)IH='B20 '
19022      IF(IPASS.EQ.10)IH2='    '
19023      IF(IPASS.EQ.11)IH='B50 '
19024      IF(IPASS.EQ.11)IH2='    '
19025      IF(IPASS.EQ.12)IH='B80 '
19026      IF(IPASS.EQ.12)IH2='    '
19027      IF(IPASS.EQ.13)IH='B90 '
19028      IF(IPASS.EQ.13)IH2='    '
19029      IF(IPASS.EQ.14)IH='B95 '
19030      IF(IPASS.EQ.14)IH2='    '
19031      IF(IPASS.EQ.15)IH='B99 '
19032      IF(IPASS.EQ.15)IH2='    '
19033      IF(IPASS.EQ.16)IH='B995'
19034      IF(IPASS.EQ.16)IH2='    '
19035      IF(IPASS.EQ.17)IH='B999'
19036      IF(IPASS.EQ.17)IH2='    '
19037      DO5150I=1,NUMNAM
19038      I2=I
19039      IF(IH.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I).AND.
19040     1IUSE(I).EQ.'P')GOTO5180
19041 5150 CONTINUE
19042      IF(NUMNAM.LT.MAXNAM)GOTO5170
19043      WRITE(ICOUT,5151)
19044 5151 FORMAT('***** ERROR IN DPHAZA--')
19045      CALL DPWRST('XXX','BUG ')
19046      WRITE(ICOUT,5152)
19047 5152 FORMAT('      THE TOTAL NUMBER OF (VARIABLE + PARAMETER)')
19048      CALL DPWRST('XXX','BUG ')
19049      WRITE(ICOUT,5153)MAXNAM
19050 5153 FORMAT('      NAMES MUST BE AT MOST ',I8)
19051      CALL DPWRST('XXX','BUG ')
19052      WRITE(ICOUT,5154)
19053 5154 FORMAT('      SUCH WAS NOT THE CASE HERE--')
19054      CALL DPWRST('XXX','BUG ')
19055      WRITE(ICOUT,5155)
19056 5155 FORMAT('      THE MAXIMUM ALLOWABLE NUMBER OF NAMES')
19057      CALL DPWRST('XXX','BUG ')
19058      WRITE(ICOUT,5156)
19059 5156 FORMAT('      HAS JUST EXCEEDED.')
19060      CALL DPWRST('XXX','BUG ')
19061      WRITE(ICOUT,5157)
19062 5157 FORMAT('      SUGGESTED ACTION--ENTER     STAT')
19063      CALL DPWRST('XXX','BUG ')
19064      WRITE(ICOUT,5158)
19065 5158 FORMAT('      TO DETERMINE THE IMPORTANT')
19066      CALL DPWRST('XXX','BUG ')
19067      WRITE(ICOUT,5159)
19068 5159 FORMAT('      (VERSUS UNIMPORTANT) VARIABLES')
19069      CALL DPWRST('XXX','BUG ')
19070      WRITE(ICOUT,5160)
19071 5160 FORMAT('      AND PARAMETERS, AND THEN REUSE SOME')
19072      CALL DPWRST('XXX','BUG ')
19073      WRITE(ICOUT,5161)
19074 5161 FORMAT('      OF THE NAMES.')
19075      CALL DPWRST('XXX','BUG ')
19076      WRITE(ICOUT,5162)
19077 5162 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
19078      CALL DPWRST('XXX','BUG ')
19079      IF(IWIDTH.GE.1)WRITE(ICOUT,5163)(IANS(I),I=1,IWIDTH)
19080 5163 FORMAT('      ',80A1)
19081      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
19082      IERROR='YES'
19083      GOTO9000
19084C
19085 5170 CONTINUE
19086      NUMNAM=NUMNAM+1
19087      ILOC=NUMNAM
19088      IHNAME(ILOC)=IH
19089      IHNAM2(ILOC)=IH2
19090      IUSE(ILOC)='P'
19091      IF(IPASS.EQ.1)VALUE(ILOC)=SIGMA
19092      IF(IPASS.EQ.2)VALUE(ILOC)=AMU
19093      IF(IPASS.EQ.3)VALUE(ILOC)=SDSIGM
19094      IF(IPASS.EQ.4)VALUE(ILOC)=SDAMU
19095      IF(IPASS.EQ.5)VALUE(ILOC)=BPT1
19096      IF(IPASS.EQ.6)VALUE(ILOC)=BPT5
19097      IF(IPASS.EQ.7)VALUE(ILOC)=B1
19098      IF(IPASS.EQ.8)VALUE(ILOC)=B5
19099      IF(IPASS.EQ.9)VALUE(ILOC)=B10
19100      IF(IPASS.EQ.10)VALUE(ILOC)=B20
19101      IF(IPASS.EQ.11)VALUE(ILOC)=B50
19102      IF(IPASS.EQ.12)VALUE(ILOC)=B80
19103      IF(IPASS.EQ.13)VALUE(ILOC)=B90
19104      IF(IPASS.EQ.14)VALUE(ILOC)=B95
19105      IF(IPASS.EQ.15)VALUE(ILOC)=B99
19106      IF(IPASS.EQ.16)VALUE(ILOC)=B995
19107      IF(IPASS.EQ.17)VALUE(ILOC)=B999
19108      VAL=VALUE(ILOC)
19109      IF((-CUTOFF).LE.VAL.AND.VAL.LE.CUTOFF)IVAL=INT(VAL+0.5)
19110      IF(VAL.GT.CUTOFF)IVAL=INT(CUTOFF)
19111      IF(VAL.LT.(-CUTOFF))IVAL=INT(-CUTOFF)
19112      IVALUE(ILOC)=IVAL
19113      GOTO5100
19114C
19115 5180 CONTINUE
19116      IF(IPASS.EQ.1)VALUE(I2)=SIGMA
19117      IF(IPASS.EQ.2)VALUE(I2)=AMU
19118      IF(IPASS.EQ.3)VALUE(I2)=SDSIGM
19119      IF(IPASS.EQ.4)VALUE(I2)=SDAMU
19120      IF(IPASS.EQ.5)VALUE(I2)=BPT1
19121      IF(IPASS.EQ.6)VALUE(I2)=BPT5
19122      IF(IPASS.EQ.7)VALUE(I2)=B1
19123      IF(IPASS.EQ.8)VALUE(I2)=B5
19124      IF(IPASS.EQ.9)VALUE(I2)=B10
19125      IF(IPASS.EQ.10)VALUE(I2)=B20
19126      IF(IPASS.EQ.11)VALUE(I2)=B50
19127      IF(IPASS.EQ.12)VALUE(I2)=B80
19128      IF(IPASS.EQ.13)VALUE(I2)=B90
19129      IF(IPASS.EQ.14)VALUE(I2)=B95
19130      IF(IPASS.EQ.15)VALUE(I2)=B99
19131      IF(IPASS.EQ.16)VALUE(I2)=B995
19132      IF(IPASS.EQ.17)VALUE(I2)=B999
19133      VAL=VALUE(I2)
19134      IF((-CUTOFF).LE.VAL.AND.VAL.LE.CUTOFF)IVAL=INT(VAL+0.5)
19135      IF(VAL.GT.CUTOFF)IVAL=INT(CUTOFF)
19136      IF(VAL.LT.(-CUTOFF))IVAL=INT(-CUTOFF)
19137      IVALUE(I2)=IVAL
19138      GOTO5100
19139C
19140 5100 CONTINUE
19141C
19142C               *****************
19143C               **  STEP 90--  **
19144C               **  EXIT       **
19145C               *****************
19146C
19147 9000 CONTINUE
19148      IF(IBUGG2.EQ.'ON'.AND.ISUBRO.EQ.'HAZA')THEN
19149        WRITE(ICOUT,999)
19150        CALL DPWRST('XXX','BUG ')
19151        WRITE(ICOUT,9011)
19152 9011   FORMAT('***** AT THE END       OF DPHAZA--')
19153        CALL DPWRST('XXX','BUG ')
19154        WRITE(ICOUT,9012)IFOUND,IERROR,ICOUNT
19155 9012   FORMAT('IFOUND,IERROR,ICOUNT = ',2(A4,2X),I8)
19156        CALL DPWRST('XXX','BUG ')
19157        WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
19158 9013   FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',3I8,3(2X,A4))
19159        CALL DPWRST('XXX','BUG ')
19160        IF(NPLOTP.GT.0)THEN
19161          DO9020I=1,NPLOTP
19162            WRITE(ICOUT,9021)I,Y(I),X(I),D(I)
19163 9021       FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5)
19164            CALL DPWRST('XXX','BUG ')
19165 9020     CONTINUE
19166        ENDIF
19167        WRITE(ICOUT,9041)IX1TSC,IX2TSC,IY1TSC,IY2TSC
19168 9041   FORMAT('IX1TSC,IX2TSC,IY1TSC,IY2TSC = ',A4,2X,A4,2X,A4,2X,A4)
19169        CALL DPWRST('XXX','BUG ')
19170        WRITE(ICOUT,9042)IX1TSV,IX2TSV,IY1TSV,IY2TSV
19171 9042   FORMAT('IX1TSV,IX2TSV,IY1TSV,IY2TSV = ',A4,2X,A4,2X,A4,2X,A4)
19172        CALL DPWRST('XXX','BUG ')
19173        WRITE(ICOUT,9043)SIGMA,AMU,SDSIGM,SDAMU
19174 9043   FORMAT('SIGMA,AMU,SDSIGM,SDAMU = ',4G15.7)
19175        CALL DPWRST('XXX','BUG ')
19176        DO9050I=1,NS
19177          WRITE(ICOUT,9051)I,Y1(I),Y2(I),ISUB(I)
19178 9051     FORMAT('I,Y1(I),Y2(I),ISUB(I) = ',I8,2G15.7,I8)
19179          CALL DPWRST('XXX','BUG ')
19180 9050   CONTINUE
19181      ENDIF
19182C
19183      RETURN
19184      END
19185      SUBROUTINE DPHAZ2(Y,TAGC,N,YTEMP1,ICASPL,MAXN,MAXNXT,
19186     1                  IX1TSC,IX2TSC,IY1TSC,IY2TSC,
19187     1                  IX1TSV,IX2TSV,IY1TSV,IY2TSV,
19188     1                  IX1ZFM,IX2ZFM,IY1ZFM,IY2ZFM,
19189     1                  IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV,
19190     1                  SIGMA,AMU,SDSIGM,SDAMU,
19191     1                  BPT1,BPT5,B1,B5,B10,B20,B50,
19192     1                  B80,B90,B95,B99,B995,B999,
19193     1                  Y2,X2,D2,N2,NPLOTV,
19194     1                  YS,
19195     1                  IBUGG3,ISUBRO,IERROR)
19196C
19197C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
19198C              THAT WILL DEFINE
19199C              A HAZARD PLOT.
19200C              THE PLOT WILL CONSIST OF 6 COMPONENTS--
19201C                  1) THE RAW DATA
19202C                  2) THE FITTED LINE
19203C                  3) THE HORIZONTAL 50% LINE
19204C                  4) THE VERTICAL   50% LINE
19205C                  5) 95% CONFIDENCE LIMITS
19206C                  6) 99% CONFIDENCE LIMITS
19207C     WRITTEN BY--JAMES J. FILLIBEN
19208C                 STATISTICAL ENGINEERING DIVISION
19209C                 INFORMATION TECHNOLOGY LABORATORY
19210C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
19211C                 GAITHERSBURG, MD 20899-8980
19212C                 PHONE--301-975-2855
19213C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
19214C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
19215C     LANGUAGE--ANSI FORTRAN (1977)
19216C     VERSION NUMBER--98/5
19217C     ORIGINAL VERSION--MAY       1998. THIS IMPLEMENTATION REALLY NOT
19218C                                       CORRECT
19219C     UPDATED         --JANUARY   2006. INITIAL CORRECT IMPLEMENTATION
19220C     UPDATED         --JANUARY   2007. CALL LIST TO CUMHAZ
19221C
19222C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
19223C
19224      CHARACTER*4 ICASPL
19225      CHARACTER*4 IWRITE
19226c
19227      CHARACTER*4 IX1TSC
19228      CHARACTER*4 IX2TSC
19229      CHARACTER*4 IY1TSC
19230      CHARACTER*4 IY2TSC
19231C
19232      CHARACTER*4 IX1TSV
19233      CHARACTER*4 IX2TSV
19234      CHARACTER*4 IY1TSV
19235      CHARACTER*4 IY2TSV
19236C
19237      CHARACTER*4 IX1ZFM
19238      CHARACTER*4 IX2ZFM
19239      CHARACTER*4 IY1ZFM
19240      CHARACTER*4 IY2ZFM
19241C
19242      CHARACTER*4 IX1ZSV
19243      CHARACTER*4 IX2ZSV
19244      CHARACTER*4 IY1ZSV
19245      CHARACTER*4 IY2ZSV
19246C
19247      CHARACTER*4 IBUGG3
19248      CHARACTER*4 ISUBRO
19249      CHARACTER*4 IERROR
19250C
19251      CHARACTER*4 ISTEPN
19252      CHARACTER*4 ISUBN1
19253      CHARACTER*4 ISUBN2
19254C
19255      DOUBLE PRECISION DTEMP
19256      DOUBLE PRECISION DPDF
19257      DOUBLE PRECISION DEPS
19258C
19259C---------------------------------------------------------------------
19260C
19261      DIMENSION Y(*)
19262      DIMENSION TAGC(*)
19263C
19264      DIMENSION Y2(*)
19265      DIMENSION X2(*)
19266      DIMENSION D2(*)
19267C
19268      DIMENSION YS(*)
19269      DIMENSION YTEMP1(*)
19270C
19271C---------------------------------------------------------------------
19272C
19273      INCLUDE 'DPCOP2.INC'
19274C
19275      DATA DEPS /1.0D-16/
19276C
19277C-----START POINT-----------------------------------------------------
19278C
19279      ISUBN1='DPHA'
19280      ISUBN2='Z2  '
19281      IERROR='NO'
19282C
19283      J=0
19284      AN=N
19285C
19286      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'HAZ2')THEN
19287        WRITE(ICOUT,999)
19288  999   FORMAT(1X)
19289        CALL DPWRST('XXX','BUG ')
19290        WRITE(ICOUT,51)
19291   51   FORMAT('***** AT THE BEGINNING OF DPHAZ2--')
19292        CALL DPWRST('XXX','BUG ')
19293        WRITE(ICOUT,53)IBUGG3,ISUBRO,ICASPL,MAXN,N
19294   53   FORMAT('IBUGG3,ISUBRO,ICASPL,MAXN,N = ',3(A4,2X),2I8)
19295        CALL DPWRST('XXX','BUG ')
19296        IF(N.GT.0)THEN
19297          DO60I=1,N
19298            WRITE(ICOUT,61)I,Y(I),TAGC(I)
19299   61       FORMAT('I,Y(I),TAGC(I) = ',I8,2G15.7)
19300            CALL DPWRST('XXX','BUG ')
19301   60     CONTINUE
19302        ENDIF
19303        WRITE(ICOUT,71)IX1TSC,IX2TSC,IY1TSC,IY2TSC
19304   71   FORMAT('IX1TSC,IX2TSC,IY1TSC,IY2TSC = ',3(A4,2X),A4)
19305        CALL DPWRST('XXX','BUG ')
19306        WRITE(ICOUT,72)IX1TSV,IX2TSV,IY1TSV,IY2TSV
19307   72   FORMAT('IX1TSV,IX2TSV,IY1TSV,IY2TSV = ',3(A4,2X),A4)
19308        CALL DPWRST('XXX','BUG ')
19309      ENDIF
19310C
19311C               ********************************************
19312C               **  STEP 11--                             **
19313C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
19314C               ********************************************
19315C
19316      ISTEPN='1.1'
19317      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'HAZ2')
19318     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19319C
19320      IF(N.LT.3)THEN
19321        WRITE(ICOUT,999)
19322        CALL DPWRST('XXX','BUG ')
19323        WRITE(ICOUT,1111)
19324 1111   FORMAT('***** ERROR IN HAZARD PLOT--')
19325        CALL DPWRST('XXX','BUG ')
19326        WRITE(ICOUT,1112)
19327 1112   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 3.')
19328        CALL DPWRST('XXX','BUG ')
19329        WRITE(ICOUT,1114)N
19330 1114   FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6)
19331        CALL DPWRST('XXX','BUG ')
19332        IERROR='YES'
19333        GOTO9000
19334      ENDIF
19335C
19336      HOLD=Y(1)
19337      DO1130I=1,N
19338        IF(Y(I).NE.HOLD)GOTO1139
19339 1130 CONTINUE
19340      WRITE(ICOUT,999)
19341      CALL DPWRST('XXX','BUG ')
19342      WRITE(ICOUT,1111)
19343      CALL DPWRST('XXX','BUG ')
19344      WRITE(ICOUT,1132)HOLD
19345 1132 FORMAT('      ALL THE INPUT RESPONSE VARIABLE ELEMENTS ARE ',
19346     1       'IDENTICALLY EQUAL TO ',G15.7)
19347      CALL DPWRST('XXX','BUG ')
19348      WRITE(ICOUT,999)
19349      CALL DPWRST('XXX','BUG ')
19350      IERROR='YES'
19351      GOTO9000
19352 1139 CONTINUE
19353C
19354      DO1140I=1,N
19355        IF(TAGC(I).NE.0.0)GOTO1149
19356 1140 CONTINUE
19357      WRITE(ICOUT,999)
19358      CALL DPWRST('XXX','BUG ')
19359      WRITE(ICOUT,1111)
19360      CALL DPWRST('XXX','BUG ')
19361      WRITE(ICOUT,1142)
19362 1142 FORMAT('      ALL INPUT TAG VARIABLE ELEMENTS ARE ',
19363     1       'IDENTICALLY EQUAL')
19364      CALL DPWRST('XXX','BUG ')
19365      WRITE(ICOUT,1143)
19366 1143 FORMAT('      TO 0.0;  THUS THERE ARE NO RESPONSE VARIABLE ',
19367     1       'VALUES')
19368      CALL DPWRST('XXX','BUG ')
19369      WRITE(ICOUT,1145)
19370 1145 FORMAT('      REMAINING UPON WHICH TO PERFORM A HAZARD ANALYSIS.')
19371      CALL DPWRST('XXX','BUG ')
19372      WRITE(ICOUT,999)
19373      CALL DPWRST('XXX','BUG ')
19374      IERROR='YES'
19375      GOTO9000
19376 1149 CONTINUE
19377C
19378C   THE FOLLOWING IS THE BASIC ALGORITHM FOR THE HAZARD PLOT:
19379C
19380C    1) SORT THE FAILURE AND CENSORING TIMES AND ASSIGN A REVERSE
19381C       RANK, K, TO EACH VALUE
19382C    2) COMPUTE THE CUMULATIVE HAZARD FOR EACH FAILURE TIME
19383C       A) HAZARD = 100/K
19384C       B) CUMULTIVE HAZARD = SUM OF HAZARDS UP TO AND INCLUDING
19385C          THE CURRENT FAILURE
19386C    3) PLOT TIME ON THE VERTICAL AXIS AND THE CUMULATIVE HAZARD
19387C       (OR SOME FUNCTION OF THE CUMULATIVE HAZARD) ON THE HORIZONTAL
19388C       AXIS
19389C    4) DEPENDING ON THE SPECIFIC DISTRIBUTION, DETERMINE WHETHER
19390C       THE TIME AND CUMULATIVE HAZARD SCALES ARE LINEAR OR LOG
19391C
19392C   THE FOLLOWING ARE THE PLOT COORDINATES FOR THE SPECIFIC DISTRIBUTIONS:
19393C
19394C   1) EXPONENTIAL:
19395C      A) TIME IS PLOTTED ON A LINEAR SCALE
19396C      B) CUMULATIVE HAZARD IS PLOTTED ON A LINEAR SCALE
19397C
19398C   2) WEIBULL
19399C      A) TIME IS PLOTTED ON A LOG SCALE
19400C      B) CUMULATIVE HAZARD IS PLOTTED ON A LOG SCALE
19401C
19402C   3) EXTREME VALUE (GUMBEL)
19403C      A) TIME IS PLOTTED ON A LINEAR SCALE
19404C      B) CUMULATIVE HAZARD IS PLOTTED ON A LOG SCALE
19405C
19406C   4) NORMAL
19407C      A) TIME IS PLOTTED ON A LINEAR SCALE
19408C      B) NORPPF(1 - EXP(-H)) IS PLOTTED ON A LINEAR SCALE
19409C         WHERE H IS THE CUMULATIVE HAZARD VALUE
19410C
19411C   5) LOGNORMAL
19412C      A) TIME IS PLOTTED ON A LOG SCALE
19413C      B) NORPPF(1 - EXP(-H)) IS PLOTTED ON A LINEAR SCALE
19414C         WHERE H IS THE CUMULATIVE HAZARD VALUE
19415C
19416C               ***********************************************
19417C               **  STEP 21--                                **
19418C               **  SORT THE DATA AND CARRY ALONG THE TAG    **
19419C               ***********************************************
19420C
19421      ISTEPN='2.1'
19422      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'HAZ2')
19423     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19424C
19425      CALL SORTC(Y,TAGC,N,YS,TAGC)
19426      IWRITE='OFF'
19427C
19428C               ***********************************************
19429C               **  STEP 22--                                **
19430C               **  COMPUTE CUMULATIVE HAZARD                **
19431C               ***********************************************
19432C
19433      ISTEPN='2.2'
19434      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'HAZ2')
19435     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19436C
19437      CALL CUMHAZ(YS,TAGC,N,IWRITE,Y,YTEMP1,MAXNXT,IBUGG3,IERROR)
19438C
19439C               ***********************************************
19440C               **  STEP 23--                                **
19441C               **  COMPUTE PLOT COORDINATES FOR VARIOUS     **
19442C               **  DISTRIBUTIONS                            **
19443C               ***********************************************
19444C
19445      ISTEPN='2.3'
19446      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'HAZ2')
19447     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19448C
19449C
19450      IX1TSV=IX1TSC
19451      IX2TSV=IX2TSC
19452      IY1TSV=IY1TSC
19453      IY2TSV=IY2TSC
19454C
19455      IX1ZSV=IX1ZFM
19456      IX2ZSV=IX2ZFM
19457      IY1ZSV=IY1ZFM
19458      IY2ZSV=IY2ZFM
19459C
19460C  Y   = CUMULATIVE HAZARD
19461C  YS  = SORTED FAILURE/CENSOR TIMES
19462C
19463      IF(ICASPL.EQ.'EHAZ')THEN
19464        J=0
19465        DO2310I=1,N
19466          IF(ABS(TAGC(I)).GE.0.5)THEN
19467            J=J+1
19468            X2(J)=Y(I)
19469            Y2(J)=YS(I)
19470            D2(J)=1.0
19471          ENDIF
19472 2310   CONTINUE
19473        IX1TSC='LINE'
19474        IX2TSC='LINE'
19475        IY1TSC='LINE'
19476        IY2TSC='LINE'
19477      ELSEIF(ICASPL.EQ.'WHAZ')THEN
19478        J=0
19479        DO2320I=1,N
19480          IF(ABS(TAGC(I)).GE.0.5)THEN
19481            J=J+1
19482            X2(J)=Y(I)
19483            Y2(J)=YS(I)
19484            D2(J)=1.0
19485          ENDIF
19486 2320   CONTINUE
19487        IX1TSC='LOG '
19488        IX2TSC='LOG '
19489        IX1ZFM='REAL'
19490        IX2ZFM='REAL'
19491        IY1TSC='LOG '
19492        IY2TSC='LOG '
19493        IY1ZFM='REAL'
19494        IY2ZFM='REAL'
19495      ELSEIF(ICASPL.EQ.'GHAZ')THEN
19496        J=0
19497        DO2330I=1,N
19498          IF(ABS(TAGC(I)).GE.0.5)THEN
19499            J=J+1
19500            X2(J)=Y(I)
19501            Y2(J)=YS(I)
19502            D2(J)=1.0
19503          ENDIF
19504 2330   CONTINUE
19505        IX1TSC='LOG '
19506        IX2TSC='LOG '
19507        IX1ZFM='REAL'
19508        IX2ZFM='REAL'
19509        IY1TSC='LINE'
19510        IY2TSC='LINE'
19511      ELSEIF(ICASPL.EQ.'NHAZ')THEN
19512        J=0
19513        DO2340I=1,N
19514          IF(ABS(TAGC(I)).GE.0.5)THEN
19515            J=J+1
19516CCCCC       DTEMP=DBLE(Y(I))
19517CCCCC       DTEMP=1.0D0 - DEXP(-DTEMP)
19518CCCCC       IF(DTEMP.LE.DEPS)THEN
19519CCCCC         DTEMP=DEPS
19520CCCCC       ELSEIF(DTEMP.GT.1.0D0-DEPS)THEN
19521CCCCC         DTEMP=1.0D0-DEPS
19522CCCCC       ENDIF
19523CCCCC       CALL NODPPF(DTEMP,DPDF)
19524CCCCC       X2(J)=REAL(DPDF)
19525            X2(J)=Y(I)
19526            Y2(J)=YS(I)
19527            D2(J)=1.0
19528          ENDIF
19529 2340   CONTINUE
19530CCCCC   IX1TSC='LOG '
19531CCCCC   IX2TSC='LOG '
19532        IX1TSC='NORM'
19533        IX2TSC='NORM'
19534        IX1ZFM='REAL'
19535        IX2ZFM='REAL'
19536        IY1TSC='LINE'
19537        IY2TSC='LINE'
19538      ELSEIF(ICASPL.EQ.'LHAZ')THEN
19539        J=0
19540        DO2350I=1,N
19541          IF(ABS(TAGC(I)).GE.0.5)THEN
19542            J=J+1
19543            DTEMP=DBLE(Y(I))
19544            DTEMP=1.0D0 - DEXP(-DTEMP)
19545            IF(DTEMP.LE.DEPS)THEN
19546              DTEMP=DEPS
19547            ELSEIF(DTEMP.GT.1.0D0-DEPS)THEN
19548              DTEMP=1.0D0-DEPS
19549            ENDIF
19550            CALL NODPPF(DTEMP,DPDF)
19551            X2(J)=REAL(DPDF)
19552            Y2(J)=YS(I)
19553            D2(J)=1.0
19554          ENDIF
19555 2350   CONTINUE
19556CCCCC   IX1TSC='LOG '
19557CCCCC   IX2TSC='LOG '
19558        IX1TSC='NORM'
19559        IX2TSC='NORM'
19560        IX1ZFM='REAL'
19561        IX2ZFM='REAL'
19562        IY1TSC='LOG '
19563        IY2TSC='LOG '
19564        IY1ZFM='REAL'
19565        IY2ZFM='REAL'
19566      ENDIF
19567      N2=J
19568      NPLOTV=3
19569C
19570      ISUBRO='DPHA'
19571      DO3000I=1,N2
19572       IF(IY1TSC.EQ.'LOG ')Y2(I)=LOG(Y2(I))
19573       IF(IX1TSC.EQ.'LOG ')X2(I)=LOG(X2(I))
19574 3000 CONTINUE
19575      CALL LINFIT(Y2,X2,N2,
19576     1ALPHA,BETA,XRESSD,XRESDF,CCXY,SDALPH,SDBETA,CCALBE,
19577     1ISUBRO,IBUGG3,IERROR)
19578      SIGMA=BETA
19579      AMU=ALPHA
19580      SDSIGM=SDBETA
19581      SDAMU=SDALPH
19582C
19583      NTEMP=N2
19584      N2=N2+1
19585      X2(N2)=X2(1)
19586      Y2(N2)=ALPHA+BETA*X2(1)
19587      D2(N2)=2.0
19588C
19589      N2=N2+1
19590      X2(N2)=X2(NTEMP)
19591      Y2(N2)=ALPHA+BETA*X2(NTEMP)
19592      D2(N2)=2.0
19593C
19594      DO3100I=1,N2
19595       IF(IY1TSC.EQ.'LOG ')Y2(I)=EXP(Y2(I))
19596       IF(IX1TSC.EQ.'LOG ')X2(I)=EXP(X2(I))
19597 3100 CONTINUE
19598C
19599C               ************************************************
19600C               **  STEP 35--                                 **
19601C               **  FORM ESTIMATES FOR                        **
19602C               **     BPT1= .1%   POINT OF BEST-FIT DIST.    **
19603C               **     BPT5= .5%   POINT OF BEST-FIT DIST.    **
19604C               **     B1  =  1%   POINT OF BEST-FIT DIST.    **
19605C               **     B5  =  5%   POINT OF BEST-FIT DIST.    **
19606C               **     B10 = 10%   POINT OF BEST-FIT DIST.    **
19607C               **     B20 = 20%   POINT OF BEST-FIT DIST.    **
19608C               **     B50 = 50%   POINT OF BEST-FIT DIST.    **
19609C               **     B80 = 80%   POINT OF BEST-FIT DIST.    **
19610C               **     B90 = 90%   POINT OF BEST-FIT DIST.    **
19611C               **     B95 = 95%   POINT OF BEST-FIT DIST.    **
19612C               **     B99 = 99%   POINT OF BEST-FIT DIST.    **
19613C               **     B995= 99.5% POINT OF BEST-FIT DIST.    **
19614C               **     B999= 99.9% POINT OF BEST-FIT DIST.    **
19615C               ************************************************
19616C
19617      IF(ICASPL.EQ.'NHAZ')THEN
19618        P=.001
19619        CALL NORPPF(P,XOUT)
19620        BPT1=AMU+XOUT*SIGMA
19621        P=.005
19622        CALL NORPPF(P,XOUT)
19623        BPT5=AMU+XOUT*SIGMA
19624        P=.01
19625        CALL NORPPF(P,XOUT)
19626        B1=AMU+XOUT*SIGMA
19627        P=.05
19628        CALL NORPPF(P,XOUT)
19629        B5=AMU+XOUT*SIGMA
19630        P=.10
19631        CALL NORPPF(P,XOUT)
19632        B10=AMU+XOUT*SIGMA
19633        P=.20
19634        CALL NORPPF(P,XOUT)
19635        B20=AMU+XOUT*SIGMA
19636        P=.50
19637        CALL NORPPF(P,XOUT)
19638        B50=AMU+XOUT*SIGMA
19639        P=.80
19640        CALL NORPPF(P,XOUT)
19641        B80=AMU+XOUT*SIGMA
19642        P=.90
19643        CALL NORPPF(P,XOUT)
19644        B90=AMU+XOUT*SIGMA
19645        P=.95
19646        CALL NORPPF(P,XOUT)
19647        B95=AMU+XOUT*SIGMA
19648        P=.99
19649        CALL NORPPF(P,XOUT)
19650        B99=AMU+XOUT*SIGMA
19651        P=.995
19652        CALL NORPPF(P,XOUT)
19653        B995=AMU+XOUT*SIGMA
19654        P=.999
19655        CALL NORPPF(P,XOUT)
19656        B999=AMU+XOUT*SIGMA
19657      ELSEIF(ICASPL.EQ.'EHAZ')THEN
19658        P=.001
19659        CALL EXPPPF(P,XOUT)
19660        BPT1=AMU+XOUT*SIGMA
19661        P=.005
19662        CALL EXPPPF(P,XOUT)
19663        BPT5=AMU+XOUT*SIGMA
19664        P=.01
19665        CALL EXPPPF(P,XOUT)
19666        B1=AMU+XOUT*SIGMA
19667        P=.05
19668        CALL EXPPPF(P,XOUT)
19669        B5=AMU+XOUT*SIGMA
19670        P=.10
19671        CALL EXPPPF(P,XOUT)
19672        B10=AMU+XOUT*SIGMA
19673        P=.20
19674        CALL EXPPPF(P,XOUT)
19675        B20=AMU+XOUT*SIGMA
19676        P=.50
19677        CALL EXPPPF(P,XOUT)
19678        B50=AMU+XOUT*SIGMA
19679        P=.80
19680        CALL EXPPPF(P,XOUT)
19681        B80=AMU+XOUT*SIGMA
19682        P=.90
19683        CALL EXPPPF(P,XOUT)
19684        B90=AMU+XOUT*SIGMA
19685        P=.95
19686        CALL EXPPPF(P,XOUT)
19687        B95=AMU+XOUT*SIGMA
19688        P=.99
19689        CALL EXPPPF(P,XOUT)
19690        B99=AMU+XOUT*SIGMA
19691        P=.995
19692        CALL EXPPPF(P,XOUT)
19693        B995=AMU+XOUT*SIGMA
19694        P=.999
19695        CALL EXPPPF(P,XOUT)
19696        B999=AMU+XOUT*SIGMA
19697CCCCC ELSEIF(ICASPL.EQ.'LHAZ')THEN
19698CCCCC   SD=1.0
19699CCCCC   P=.001
19700CCCCC   CALL LGNPPF(P,SD,XOUT)
19701CCCCC   BPT1=AMU+XOUT*SIGMA
19702CCCCC   P=.005
19703CCCCC   CALL LGNPPF(P,SD,XOUT)
19704CCCCC   BPT5=AMU+XOUT*SIGMA
19705CCCCC   P=.01
19706CCCCC   CALL LGNPPF(P,SD,XOUT)
19707CCCCC   B1=AMU+XOUT*SIGMA
19708CCCCC   P=.05
19709CCCCC   CALL LGNPPF(P,SD,XOUT)
19710CCCCC   B5=AMU+XOUT*SIGMA
19711CCCCC   P=.10
19712CCCCC   CALL LGNPPF(P,SD,XOUT)
19713CCCCC   B10=AMU+XOUT*SIGMA
19714CCCCC   P=.20
19715CCCCC   CALL LGNPPF(P,SD,XOUT)
19716CCCCC   B20=AMU+XOUT*SIGMA
19717CCCCC   P=.50
19718CCCCC   CALL LGNPPF(P,SD,XOUT)
19719CCCCC   B50=AMU+XOUT*SIGMA
19720CCCCC   P=.80
19721CCCCC   CALL LGNPPF(P,SD,XOUT)
19722CCCCC   B80=AMU+XOUT*SIGMA
19723CCCCC   P=.90
19724CCCCC   CALL LGNPPF(P,SD,XOUT)
19725CCCCC   B90=AMU+XOUT*SIGMA
19726CCCCC   P=.95
19727CCCCC   CALL LGNPPF(P,SD,XOUT)
19728CCCCC   B95=AMU+XOUT*SIGMA
19729CCCCC   P=.99
19730CCCCC   CALL LGNPPF(P,SD,XOUT)
19731CCCCC   B99=AMU+XOUT*SIGMA
19732CCCCC   P=.995
19733CCCCC   CALL LGNPPF(P,SD,XOUT)
19734CCCCC   B995=AMU+XOUT*SIGMA
19735CCCCC   P=.999
19736CCCCC   CALL LGNPPF(P,SD,XOUT)
19737CCCCC   B999=AMU+XOUT*SIGMA
19738CCCCC ELSEIF(ICASPL.EQ.'WHAZ')THEN
19739CCCCC   MINMAX=1
19740CCCCC   GAMMA=1.0
19741CCCCC   P=.001
19742CCCCC   CALL WEIPPF(P,GAMMA,MINMAX,XOUT)
19743CCCCC   BPT1=AMU+XOUT*SIGMA
19744CCCCC   P=.005
19745CCCCC   CALL WEIPPF(P,GAMMA,MINMAX,XOUT)
19746CCCCC   BPT5=AMU+XOUT*SIGMA
19747CCCCC   P=.01
19748CCCCC   CALL WEIPPF(P,GAMMA,MINMAX,XOUT)
19749CCCCC   B1=AMU+XOUT*SIGMA
19750CCCCC   P=.05
19751CCCCC   CALL WEIPPF(P,GAMMA,MINMAX,XOUT)
19752CCCCC   B5=AMU+XOUT*SIGMA
19753CCCCC   P=.10
19754CCCCC   CALL WEIPPF(P,GAMMA,MINMAX,XOUT)
19755CCCCC   B10=AMU+XOUT*SIGMA
19756CCCCC   P=.20
19757CCCCC   CALL WEIPPF(P,GAMMA,MINMAX,XOUT)
19758CCCCC   B20=AMU+XOUT*SIGMA
19759CCCCC   P=.50
19760CCCCC   CALL WEIPPF(P,GAMMA,MINMAX,XOUT)
19761CCCCC   B50=AMU+XOUT*SIGMA
19762CCCCC   P=.80
19763CCCCC   CALL WEIPPF(P,GAMMA,MINMAX,XOUT)
19764CCCCC   B80=AMU+XOUT*SIGMA
19765CCCCC   P=.90
19766CCCCC   CALL WEIPPF(P,GAMMA,MINMAX,XOUT)
19767CCCCC   B90=AMU+XOUT*SIGMA
19768CCCCC   P=.95
19769CCCCC   CALL WEIPPF(P,GAMMA,MINMAX,XOUT)
19770CCCCC   B95=AMU+XOUT*SIGMA
19771CCCCC   P=.99
19772CCCCC   CALL WEIPPF(P,GAMMA,MINMAX,XOUT)
19773CCCCC   B99=AMU+XOUT*SIGMA
19774CCCCC   P=.995
19775CCCCC   CALL WEIPPF(P,GAMMA,MINMAX,XOUT)
19776CCCCC   B995=AMU+XOUT*SIGMA
19777CCCCC   P=.999
19778CCCCC   CALL WEIPPF(P,GAMMA,MINMAX,XOUT)
19779CCCCC   B999=AMU+XOUT*SIGMA
19780      ELSEIF(ICASPL.EQ.'GHAZ')THEN
19781        MINMAX=1
19782        P=.001
19783        CALL EV1PPF(P,MINMAX,XOUT)
19784        BPT1=AMU+XOUT*SIGMA
19785        P=.005
19786        CALL EV1PPF(P,MINMAX,XOUT)
19787        BPT5=AMU+XOUT*SIGMA
19788        P=.01
19789        CALL EV1PPF(P,MINMAX,XOUT)
19790        B1=AMU+XOUT*SIGMA
19791        P=.05
19792        CALL EV1PPF(P,MINMAX,XOUT)
19793        B5=AMU+XOUT*SIGMA
19794        P=.10
19795        CALL EV1PPF(P,MINMAX,XOUT)
19796        B10=AMU+XOUT*SIGMA
19797        P=.20
19798        CALL EV1PPF(P,MINMAX,XOUT)
19799        B20=AMU+XOUT*SIGMA
19800        P=.50
19801        CALL EV1PPF(P,MINMAX,XOUT)
19802        B50=AMU+XOUT*SIGMA
19803        P=.80
19804        CALL EV1PPF(P,MINMAX,XOUT)
19805        B80=AMU+XOUT*SIGMA
19806        P=.90
19807        CALL EV1PPF(P,MINMAX,XOUT)
19808        B90=AMU+XOUT*SIGMA
19809        P=.95
19810        CALL EV1PPF(P,MINMAX,XOUT)
19811        B95=AMU+XOUT*SIGMA
19812        P=.99
19813        CALL EV1PPF(P,MINMAX,XOUT)
19814        B99=AMU+XOUT*SIGMA
19815        P=.995
19816        CALL EV1PPF(P,MINMAX,XOUT)
19817        B995=AMU+XOUT*SIGMA
19818        P=.999
19819        CALL EV1PPF(P,MINMAX,XOUT)
19820        B999=AMU+XOUT*SIGMA
19821      ENDIF
19822C
19823C               *****************
19824C               **  STEP 90--  **
19825C               **  EXIT       **
19826C               *****************
19827C
19828 9000 CONTINUE
19829C
19830      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'HAZ2')THEN
19831        WRITE(ICOUT,999)
19832        CALL DPWRST('XXX','BUG ')
19833        WRITE(ICOUT,9011)
19834 9011   FORMAT('***** AT THE END       OF DPHAZ2--')
19835        CALL DPWRST('XXX','BUG ')
19836        WRITE(ICOUT,9012)N2,IERROR
19837 9012   FORMAT('N2,IERROR = ',I8,2X,A4)
19838        CALL DPWRST('XXX','BUG ')
19839        DO9015I=1,N2
19840          WRITE(ICOUT,9016)I,Y2(I),X2(I),D2(I)
19841 9016     FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2)
19842          CALL DPWRST('XXX','BUG ')
19843 9015   CONTINUE
19844        WRITE(ICOUT,9021)IX1TSC,IX2TSC,IY1TSC,IY2TSC
19845 9021   FORMAT('IX1TSC,IX2TSC,IY1TSC,IY2TSC = ',3(A4,2X),A4)
19846        CALL DPWRST('XXX','BUG ')
19847        WRITE(ICOUT,9022)IX1TSV,IX2TSV,IY1TSV,IY2TSV
19848 9022   FORMAT('IX1TSV,IX2TSV,IY1TSV,IY2TSV = ',3(A4,2X),A4)
19849        CALL DPWRST('XXX','BUG ')
19850        WRITE(ICOUT,73)SIGMA,AMU,SDSIGM,SDAMU
19851   73   FORMAT('SIGMA,AMU,SDSIGM,SDAMU = ',4G15.7)
19852        CALL DPWRST('XXX','BUG ')
19853        WRITE(ICOUT,74)BPT1,BPT5,B1,B5
19854   74   FORMAT('BPT1,BPT5,B1,B5 = ',4E15.7)
19855        CALL DPWRST('XXX','BUG ')
19856        WRITE(ICOUT,75)B10,B20,B50,B80,B90
19857   75   FORMAT(' B10,B20,B50,B80,B90 = ',5E15.7)
19858        CALL DPWRST('XXX','BUG ')
19859        WRITE(ICOUT,76)B95,B99,B995,B999
19860   76   FORMAT('B95,B99,B995,B999 = ',4E15.7)
19861        CALL DPWRST('XXX','BUG ')
19862      ENDIF
19863C
19864      RETURN
19865      END
19866      SUBROUTINE DPHEIG(IHARG,IARGT,ARG,NUMARG,
19867     1PDEFHE,
19868     1PTEXHE,
19869     1IBUGD2,ISUBRO,IFOUND,IERROR)
19870C
19871C     PURPOSE--DEFINE THE HEIGHT FOR TEXT CHARACTERS.
19872C              THE HEIGHT FOR TEXT CHARACTERS WILL BE PLACED
19873C              IN THE FLOATING POINT VARIABLE PTEXHE.
19874C     NOTE--THE HEIGHT IS IN STANDARDIZED UNITS (0.0 TO 100.0).
19875C     NOTE--THE HEIGHT DOES NOT INCLUDE BETWEEN-LINE GAP.
19876C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
19877C                     --IARGT
19878C                     --ARG
19879C                     --NUMARG
19880C                     --PDEFHE
19881C                     --IBUGD2
19882C     OUTPUT ARGUMENTS--PTEXHE
19883C                     --IFOUND ('YES' OR 'NO' )
19884C                     --IERROR ('YES' OR 'NO' )
19885C     WRITTEN BY--JAMES J. FILLIBEN
19886C                 STATISTICAL ENGINEERING DIVISION
19887C                 INFORMATION TECHNOLOGY LABORATORY
19888C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
19889C                 GAITHERSBURG, MD 20899-8980
19890C                 PHONE--301-975-2855
19891C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
19892C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
19893C     LANGUAGE--ANSI FORTRAN (1977)
19894C     VERSION NUMBER--82/7
19895C     ORIGINAL VERSION--APRIL     1981.
19896C     UPDATED         --MAY       1982.
19897C
19898C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
19899C
19900      CHARACTER*4 IHARG
19901      CHARACTER*4 IARGT
19902      CHARACTER*4 IBUGD2
19903      CHARACTER*4 ISUBRO
19904      CHARACTER*4 IFOUND
19905      CHARACTER*4 IERROR
19906C
19907C---------------------------------------------------------------------
19908C
19909      DIMENSION IHARG(*)
19910      DIMENSION IARGT(*)
19911      DIMENSION ARG(*)
19912C
19913C---------------------------------------------------------------------
19914C
19915      INCLUDE 'DPCOP2.INC'
19916C
19917C-----START POINT-----------------------------------------------------
19918C
19919      IFOUND='NO'
19920      IERROR='NO'
19921C
19922      IF(IBUGD2.EQ.'OFF')GOTO90
19923      WRITE(ICOUT,999)
19924  999 FORMAT(1X)
19925      CALL DPWRST('XXX','BUG ')
19926      WRITE(ICOUT,51)
19927   51 FORMAT('***** AT THE BEGINNING OF DPHEIG--')
19928      CALL DPWRST('XXX','BUG ')
19929      WRITE(ICOUT,53)PDEFHE
19930   53 FORMAT('PDEFHE = ',E15.7)
19931      CALL DPWRST('XXX','BUG ')
19932      WRITE(ICOUT,54)NUMARG
19933   54 FORMAT('NUMARG = ',I8)
19934      CALL DPWRST('XXX','BUG ')
19935      DO55I=1,NUMARG
19936      WRITE(ICOUT,56)I,IHARG(I),IARGT(I),ARG(I)
19937   56 FORMAT('I,IHARG(I),IARGT(I),ARG(I) = ',I8,2X,A4,2X,A4,E15.7)
19938      CALL DPWRST('XXX','BUG ')
19939   55 CONTINUE
19940   90 CONTINUE
19941C
19942C               *****************************
19943C               **  TREAT THE HEIGHT CASE  **
19944C               *****************************
19945C
19946      IF(NUMARG.LE.0)GOTO1150
19947      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
19948      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
19949      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
19950      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
19951      IF(IHARG(NUMARG).EQ.'?')GOTO8100
19952C
19953      IF(NUMARG.GE.1.AND.IARGT(NUMARG).EQ.'NUMB')
19954     1GOTO1160
19955C
19956      IERROR='YES'
19957      WRITE(ICOUT,1121)
19958 1121 FORMAT('***** ERROR IN DPHEIG--')
19959      CALL DPWRST('XXX','BUG ')
19960      WRITE(ICOUT,1122)
19961 1122 FORMAT('      ILLEGAL FORM FOR HEIGHT ',
19962     1'COMMAND.')
19963      CALL DPWRST('XXX','BUG ')
19964      WRITE(ICOUT,1124)
19965 1124 FORMAT('      TEST EXAMPLE TO DEMONSTRATE THE ',
19966     1'PROPER FORM--')
19967      CALL DPWRST('XXX','BUG ')
19968      WRITE(ICOUT,1125)
19969 1125 FORMAT('      SUPPOSE IT IS DESIRED THAT ')
19970      CALL DPWRST('XXX','BUG ')
19971      WRITE(ICOUT,1126)
19972 1126 FORMAT('      THE TEXT CHARACTERS HAVE A HEIGHT OF 5')
19973      CALL DPWRST('XXX','BUG ')
19974      WRITE(ICOUT,1127)
19975 1127 FORMAT('      (WHERE THE VERTICAL SCREEN UNITS RANGE')
19976      CALL DPWRST('XXX','BUG ')
19977      WRITE(ICOUT,1128)
19978 1128 FORMAT('      FROM 0 TO 100, AND WHERE ')
19979      CALL DPWRST('XXX','BUG ')
19980      WRITE(ICOUT,1129)
19981 1129 FORMAT('      THE BETWEEN-LINE GAP IS NOT INCLUDED),')
19982      CALL DPWRST('XXX','BUG ')
19983      WRITE(ICOUT,1130)
19984 1130 FORMAT('      THEN THE ALLOWABLE FORM IS--')
19985      CALL DPWRST('XXX','BUG ')
19986      WRITE(ICOUT,1131)
19987 1131 FORMAT('           HEIGHT 5 ')
19988      CALL DPWRST('XXX','BUG ')
19989      GOTO9000
19990C
19991 1150 CONTINUE
19992      PTEXHE=PDEFHE
19993      GOTO1180
19994C
19995 1160 CONTINUE
19996      PTEXHE=ARG(NUMARG)
19997      GOTO1180
19998C
19999 1180 CONTINUE
20000      IFOUND='YES'
20001C
20002      IF(IFEEDB.EQ.'OFF')GOTO1189
20003      WRITE(ICOUT,999)
20004      CALL DPWRST('XXX','BUG ')
20005      WRITE(ICOUT,1181)
20006 1181 FORMAT('THE HEIGHT (FOR TEXT CHARACTERS)  ')
20007      CALL DPWRST('XXX','BUG ')
20008      WRITE(ICOUT,1182)PTEXHE
20009 1182 FORMAT('HAS JUST BEEN SET TO ',E15.7)
20010      CALL DPWRST('XXX','BUG ')
20011 1189 CONTINUE
20012      GOTO9000
20013C
20014C               ********************************************
20015C               **  STEP 81--                             **
20016C               **  TREAT THE    ?    CASE--              **
20017C               **  DUMP OUT CURRENT AND DEFAULT VALUES.  **
20018C               ********************************************
20019C
20020 8100 CONTINUE
20021      IFOUND='YES'
20022      WRITE(ICOUT,999)
20023      CALL DPWRST('XXX','BUG ')
20024      WRITE(ICOUT,8111)PTEXHE
20025 8111 FORMAT('THE CURRENT (TEXT) HEIGHT IS ',E15.7)
20026      CALL DPWRST('XXX','BUG ')
20027      WRITE(ICOUT,8112)PDEFHE
20028 8112 FORMAT('THE DEFAULT (TEXT) HEIGHT IS ',E15.7)
20029      CALL DPWRST('XXX','BUG ')
20030      GOTO9000
20031C
20032C               *****************
20033C               **  STEP 90--  **
20034C               **  EXIT       **
20035C               *****************
20036C
20037 9000 CONTINUE
20038      IF(IBUGD2.EQ.'OFF')GOTO9090
20039      WRITE(ICOUT,999)
20040      CALL DPWRST('XXX','BUG ')
20041      WRITE(ICOUT,9011)
20042 9011 FORMAT('***** AT THE END       OF DPHEIG--')
20043      CALL DPWRST('XXX','BUG ')
20044      WRITE(ICOUT,9012)IBUGD2,ISUBRO,IFOUND,IERROR
20045 9012 FORMAT('IBUGD2,ISUBRO,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
20046      CALL DPWRST('XXX','BUG ')
20047      WRITE(ICOUT,9013)PTEXHE
20048 9013 FORMAT('PTEXHE = ',E15.7)
20049      CALL DPWRST('XXX','BUG ')
20050 9090 CONTINUE
20051C
20052      RETURN
20053      END
20054      SUBROUTINE DPHELP(IHARG,IHARG2,NUMARG,IANS,IWIDTH,
20055     1                  IHELMX,
20056     1                  ICPREH,NCPREH,ICPOSH,NCPOSH,
20057     1                  IBUGS2,ISUBRO,IFOUND,IERROR)
20058C
20059C     PURPOSE--PRINT OUT BRIEF INSTRUCTIONAL INFORMATION
20060C              ABOUT A PARTICULAR COMMAND
20061C              AS CALLED FOR BY THE HELP COMMAND.
20062C     INPUT  ARGUMENTS--IANS    (A  HOLLERITH VECTOR)
20063C                     --IWIDTH (AN INTEGER VARIABLE)
20064C     OUTPUT ARGUMENTS--IFOUND ('YES' OR 'NO' )
20065C                     --IERROR ('YES' OR 'NO' )
20066C     WRITTEN BY--JAMES J. FILLIBEN
20067C                 STATISTICAL ENGINEERING DIVISION
20068C                 INFORMATION TECHNOLOGY LABORATORY
20069C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
20070C                 GAITHERSBURG, MD 20899-8980
20071C                 PHONE--301-975-2855
20072C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
20073C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
20074C     LANGUAGE--ANSI FORTRAN (1977)
20075C     VERSION NUMBER--86/1
20076C     ORIGINAL VERSION--DECEMBER  1977.
20077C     UPDATED         --NOVEMBER  1980.
20078C     UPDATED         --JUNE      1981.
20079C     UPDATED         --OCTOBER   1981.
20080C     UPDATED         --NOVEMBER  1981.
20081C     UPDATED         --MAY       1982.
20082C     UPDATED         --DECEMBER  1985.
20083C     UPDATED         --SEPTEMBER 1987.  MORE/PAUSE
20084C     UPDATED         --JANUARY   1989.  FIX TRUNCATION OF LONG LINES
20085C                                        UNDER CYBER NOS (ALAN)
20086C     UPDATED         --JULY      1989.  MORE/PAUSE IN THE SUBROUTINE DPMORE
20087C     UPDATED         --NOVEMBER  1989.  IERRO TO IERROR--CALL DPMORE
20088C     UPDATED         --JULY      1990.  ALLOW MORE... TO STOP LIST
20089C     UPDATED         --JULY      1990.  SPLIT HELP INTO 6 FILES
20090C     UPDATED         --AUGUST    1990.  EXPLICIT SETTING OF NUMLPR=0
20091C     UPDATED         --APRIL     1992.  IBUGHE/2 TO IBUGS2
20092C     UPDATED         --APRIL     1992.  COMMENT OUT 12 DEBUG STATEMENTS
20093C     UPDATED         --AUGUST    1994.  SEARCH SYNONYM FILE
20094C     UPDATED         --AUGUST    1994.  NUMWOR => NUMWHF
20095C     UPDATED         --DECEMBER  1994.  CORRECTIONS FOR SYNONYM FILE
20096C     UPDATED         --MARCH     1996.  UPDATE SECTIONS FOR MATR OPER
20097C     UPDATED         --APRIL     1997.  CONFLICT BETWEEN STATUS AND
20098C                                        STATISTIC PLOT
20099C     UPDATED         --NOVEMBER  1997.  CONFLICT BETWEEN:
20100C                                           INTERPOLATION - INTEGRAL
20101C                                           ROOTOGRAM     - ROOTS
20102C     UPDATED         --FEBRUARY  2003.  BUG FIX FOR LONGER ENTRIES
20103C     UPDATED         --FEBRUARY  2016.  CONFLICT BETWEEN FUNCTION BLOCK
20104C                                        AND FUNCTION
20105C     UPDATED         --NOVEMBER  2019.  OPTION TO OPEN HELP OUTPUT IN A
20106C                                        SEPARATE WINDOW
20107C
20108C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
20109C
20110      CHARACTER*4 IHARG
20111      CHARACTER*4 IHARG2
20112      CHARACTER*4 IANS
20113C
20114      CHARACTER*40 ICPREH
20115      CHARACTER*40 ICPOSH
20116C
20117      CHARACTER*4 IBUGS2
20118      CHARACTER*4 ISUBRO
20119      CHARACTER*4 IFOUND
20120      CHARACTER*4 IERROR
20121C
20122      INCLUDE 'DPCOPA.INC'
20123C
20124CCCCC CHARACTER*80 IFILE
20125      CHARACTER (LEN=MAXFNC) :: IFILE
20126      CHARACTER*12 ISTAT
20127      CHARACTER*12 IFORM
20128      CHARACTER*12 IACCES
20129      CHARACTER*12 IPROT
20130      CHARACTER*12 ICURST
20131      CHARACTER*4 ISUBN0
20132      CHARACTER*4 IERRFI
20133      CHARACTER*4 IENDFI
20134      CHARACTER*4 IREWIN
20135C
20136      CHARACTER*4 ITABID
20137      CHARACTER*4 IWORD1
20138      CHARACTER*4 IWORD2
20139      CHARACTER*4 IWORD3
20140      CHARACTER*4 IWORD4
20141      CHARACTER*4 IWORD5
20142      CHARACTER*4 IWOR12
20143      CHARACTER*1 ICHAR1
20144      CHARACTER*4 ICTEST
20145      CHARACTER*4 IZ1
20146      CHARACTER*4 IZ2
20147      CHARACTER*4 IZ3
20148      CHARACTER*4 IZ4
20149      CHARACTER*4 IZ5
20150      CHARACTER*4 ICTEXT
20151      CHARACTER*4 IOP
20152      CHARACTER*4 ISSAV1
20153      CHARACTER*4 ISSAV2
20154      CHARACTER*4 ISSAV3
20155      CHARACTER*4 ISSAV4
20156      CHARACTER*4 IRESP
20157      CHARACTER*4 IERRO2
20158      CHARACTER*4 ISUBN1
20159      CHARACTER*4 ISUBN2
20160      CHARACTER*4 ISTEPN
20161      CHARACTER*1 ICJUNK
20162C
20163      CHARACTER*40 ILIN30
20164      CHARACTER*40 ISTRIN
20165      CHARACTER*80 ILINE
20166      CHARACTER*255 ISTR
20167C
20168      DIMENSION IHARG(*)
20169      DIMENSION IHARG2(*)
20170      DIMENSION IANS(*)
20171C
20172      DIMENSION ITABID(100)
20173      DIMENSION ITABLN(100)
20174C
20175      DIMENSION ICTEXT(20)
20176C
20177C-----COMMON----------------------------------------------------------
20178C
20179      INCLUDE 'DPCOF2.INC'
20180      INCLUDE 'DPCOST.INC'
20181      INCLUDE 'DPCOHO.INC'
20182      INCLUDE 'DPCOP2.INC'
20183C
20184C-----START POINT-----------------------------------------------------
20185C
20186      IFOUND='YES'
20187      IERROR='NO'
20188      ISUBN1='DPHE'
20189      ISUBN2='LP  '
20190C
20191      NUMLIN=(-999)
20192      NUMSEC=(-999)
20193      ISECNA=(-999)
20194      NUMAR2=(-999)
20195      JCHAR1=(-999)
20196      JSEC=(-999)
20197      JSECP1=(-999)
20198      ISKIP=(-999)
20199      ISTART=(-999)
20200      ISTOP=(-999)
20201      I2=(-999)
20202      NUMWHF=(-999)
20203      ILOC2=(-999)
20204      ILOC3=(-999)
20205      ILOC4=(-999)
20206      ILOC5=(-999)
20207      ILOC2P=(-999)
20208      ILOC3P=(-999)
20209      ILOC4P=(-999)
20210      ILOC5P=(-999)
20211C
20212      IWORD1='    '
20213      IWORD2='    '
20214      IWORD3='    '
20215      IWORD4='    '
20216      IWORD5='    '
20217      IWOR12='    '
20218      ICTEST='    '
20219      ILIN30='                              '
20220      IZ1='    '
20221      IZ2='    '
20222      IZ3='    '
20223      IZ4='    '
20224      IZ5='    '
20225      ISTRIN='                              '
20226C
20227      IF(IBUGS2.EQ.'ON' .OR. ISUBRO.EQ.'HELP')THEN
20228        WRITE(ICOUT,999)
20229  999   FORMAT(1X)
20230        CALL DPWRST('XXX','BUG ')
20231        WRITE(ICOUT,51)
20232   51   FORMAT('***** AT THE BEGINNING OF DPHELP--')
20233        CALL DPWRST('XXX','BUG ')
20234        WRITE(ICOUT,53)IBUGS2,ISUBRO,IERROR,IWIDTH
20235   53   FORMAT('IBUGS2,ISUBRO,IERROR,IWIDTH = ',3(A4,2X),I8)
20236        CALL DPWRST('XXX','BUG ')
20237        WRITE(ICOUT,55)(IANS(I),I=1,MIN(120,IWIDTH))
20238   55   FORMAT('IANS(.) = ',120A1)
20239        CALL DPWRST('XXX','BUG ')
20240        WRITE(ICOUT,81)NCPREH,NCPOSH
20241   81   FORMAT('NCPREH,NCPOSH = ',2I8)
20242        CALL DPWRST('XXX','BUG ')
20243        IF(NCPREH.GT.0)THEN
20244          DO82I=1,NCPREH
20245            WRITE(ICOUT,83)I,ICPREH(I:I)
20246   83       FORMAT('I,ICPREH(I:I) = ',I8,2X,A1,4X)
20247            CALL DPWRST('XXX','BUG ')
20248   82     CONTINUE
20249        ENDIF
20250        IF(NCPOSH.GT.0)THEN
20251          DO87I=1,NCPOSH
20252            WRITE(ICOUT,88)I,ICPOSH(I:I)
20253   88       FORMAT('I,ICPOSH(I:I) = ',I8,2X,A1,4X)
20254            CALL DPWRST('XXX','BUG ')
20255   87     CONTINUE
20256        ENDIF
20257      ENDIF
20258C
20259C               **********************************************************
20260C               **  STEP 21--                                           **
20261C               **  COPY OVER THE FIRST 4 WORDS AFTER THE WORD   HELP.  **
20262C               **********************************************************
20263C
20264CCCCC THE FOLLOWING 3 LINES WERE ADDED       AUGUST 1994 (JJF)
20265CCCCC TO SEARCH A SYNONYM FILE (DPHE7F.TEX)  AUGUST 1994
20266      IPASS=0
20267 1000 CONTINUE
20268      IPASS=IPASS+1
20269C
20270      ISTEPN='21'
20271      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
20272     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20273C
20274      IF(IPASS.LE.1)THEN
20275         IWORD1=IHARG(1)
20276         IWOR12=IHARG2(1)
20277         IWORD2=IHARG(2)
20278         IWORD3=IHARG(3)
20279         IWORD4=IHARG(4)
20280         IWORD5=IHARG(5)
20281         NUMAR2=NUMARG
20282      ENDIF
20283C
20284      IF(NUMAR2.LE.0)THEN
20285         NUMAR2=1
20286         IWORD1='OVER'
20287         IWOR12='VIEW'
20288      ENDIF
20289C
20290C               ********************************************************
20291C               **  STEP 22--                                         **
20292C               **  STRIP OUT THE FIRST CHARACTER OF THE FIRST WORD.  **
20293C               ********************************************************
20294C
20295      ISTEPN='22'
20296      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
20297     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20298C
20299      ICHAR1=IWORD1(1:1)
20300C
20301C               **************************************************
20302C               **  STEP 31--                                   **
20303C               **  BASED ON THE FIRST WORD OR                  **
20304C               **  THE FIRST CHARACTER OF THE FIRST WORD,      **
20305C               **  DETERMINE WHICH OF THE 6 HELP               **
20306C               **  FILES WILL BE USED.                         **
20307C               **************************************************
20308C
20309      JFILE=6
20310C
20311      IF(IWORD1.EQ.'OVER')GOTO3110
20312      IF(IWORD1.EQ.'GRAP')GOTO3110
20313      IF(IWORD1.EQ.'DIAG')GOTO3110
20314      IF(IWORD1.EQ.'ANAL')GOTO3110
20315      IF(IWORD1.EQ.'PLOT'.AND.IWORD2.EQ.'CONT')GOTO3110
20316      IF(IWORD1.EQ.'SUPP')GOTO3110
20317      IF(IWORD1.EQ.'OUTP')GOTO3110
20318      IF(IWORD1.EQ.'KEYW')GOTO3110
20319      IF(IWORD1.EQ.'FUNC' .AND. IWORD2.NE.'BLOC')GOTO3110
20320      IF(IWORD1.EQ.'MATH'.AND.IWORD2.EQ.'FUNC')GOTO3110
20321      IF(IWORD1.EQ.'TRIG')GOTO3110
20322CCCCC THE FOLLOWING LINE WAS CHANGED     AUGUST 1994
20323CCCCC IF(IWORD1.EQ.'PROB')GOTO3110
20324      IF(IWORD1.EQ.'PROB'.AND.IWORD2.NE.'PLOT')GOTO3110
20325      IF(IWORD1.EQ.'LET '.AND.IWORD2.EQ.'SUBC')GOTO3110
20326      IF(IWORD1.EQ.'LET '.AND.IWORD2.EQ.'SUB-')GOTO3110
20327      IF(IWORD1.EQ.'LET '.AND.IWORD2.EQ.'SUB ')GOTO3110
20328CCCCC APRIL 1997.  STAT CAN MEAN EITHER STATISTICS, STATUS, OR
20329CCCCC STATISTIC PLOT.  FOLLOWING LINE ONLY FOR STATISTICS.
20330CCCCC IF(IWORD1.EQ.'STAT')GOTO3110
20331      IF(IWORD1.EQ.'STAT')THEN
20332        IF(IWORD2.NE.'PLOT' .AND. IWOR12.NE.'US')GOTO3110
20333      ENDIF
20334      IF(IWORD1.EQ.'MATH'.AND.IWORD2.EQ.'OPER')GOTO3110
20335CCCCC MARCH 1996.  ADD FOLLOWING LINE.
20336      IF(IWORD1.EQ.'MATR'.AND.IWORD2.EQ.'OPER')GOTO3110
20337CCCCC MAY 2002: CHECK FOR CONFLICT WITH RANDOM NUMBER GENERATOR
20338CCCCC COMMAND.
20339CCCCC IF(IWORD1.EQ.'RAND')GOTO3110
20340      IF(IWORD1.EQ.'RAND'.AND.IWORD3.NE.'GENE')GOTO3110
20341      IF(IWORD1.EQ.'TEXT'.AND.IWORD2.EQ.'SUBC')GOTO3110
20342      IF(IWORD1.EQ.'TEXT'.AND.IWORD2.EQ.'SUB-')GOTO3110
20343      IF(IWORD1.EQ.'TEXT'.AND.IWORD2.EQ.'SUB ')GOTO3110
20344      IF(IWORD1.EQ.'CAPI')GOTO3110
20345      IF(IWORD1.EQ.'CAPS')GOTO3110
20346      IF(IWORD1.EQ.'CAP ')GOTO3110
20347      IF(IWORD1.EQ.'SUBS'.AND.IWOR12.EQ.'CRIP')GOTO3110
20348      IF(IWORD1.EQ.'SUBS'.AND.IWOR12.EQ.'SET ')GOTO3110
20349      IF(IWORD1.EQ.'GREE')GOTO3110
20350      IF(IWORD1.EQ.'MATH'.AND.IWORD2.EQ.'SYMB')GOTO3110
20351      IF(IWORD1.EQ.'MISC')GOTO3110
20352      IF(IWORD1.EQ.'CHAR'.AND.IWORD2.EQ.'TYPE')GOTO3110
20353      IF(IWORD1.EQ.'LINE'.AND.IWORD2.EQ.'TYPE')GOTO3110
20354      IF(IWORD1.EQ.'COLO'.AND.IWORD2.EQ.'TYPE')GOTO3110
20355      IF(IWORD1.EQ.'ASCI'.AND.IWORD2.EQ.'FILE')GOTO3110
20356      IF(IWORD1.EQ.'SYST'.AND.IWORD2.EQ.'LIMI')GOTO3110
20357      IF(IWORD1.EQ.'PROB'.AND.IWORD2.EQ.'DIST')GOTO3110
20358C
20359      IF(ICHAR1.EQ.'A')GOTO3120
20360      IF(ICHAR1.EQ.'B')GOTO3120
20361      IF(ICHAR1.EQ.'C')GOTO3120
20362C
20363      IF(ICHAR1.EQ.'D')GOTO3130
20364      IF(ICHAR1.EQ.'E')GOTO3130
20365      IF(ICHAR1.EQ.'F')GOTO3130
20366      IF(ICHAR1.EQ.'G')GOTO3130
20367      IF(ICHAR1.EQ.'H')GOTO3130
20368      IF(ICHAR1.EQ.'I')GOTO3130
20369      IF(ICHAR1.EQ.'J')GOTO3130
20370      IF(ICHAR1.EQ.'K')GOTO3130
20371C
20372      IF(ICHAR1.EQ.'L')GOTO3140
20373      IF(ICHAR1.EQ.'M')GOTO3140
20374      IF(ICHAR1.EQ.'N')GOTO3140
20375      IF(ICHAR1.EQ.'O')GOTO3140
20376C
20377      IF(ICHAR1.EQ.'P')GOTO3150
20378      IF(ICHAR1.EQ.'Q')GOTO3150
20379      IF(ICHAR1.EQ.'R')GOTO3150
20380      IF(ICHAR1.EQ.'S')GOTO3150
20381C
20382CCCCC IF(ICHAR1.EQ.'T')GOTO3160
20383CCCCC IF(ICHAR1.EQ.'U')GOTO3160
20384CCCCC IF(ICHAR1.EQ.'V')GOTO3160
20385CCCCC IF(ICHAR1.EQ.'W')GOTO3160
20386CCCCC IF(ICHAR1.EQ.'X')GOTO3160
20387CCCCC IF(ICHAR1.EQ.'Y')GOTO3160
20388CCCCC IF(ICHAR1.EQ.'Z')GOTO3160
20389      GOTO3160
20390
20391 3110 CONTINUE
20392      JFILE=1
20393      GOTO3190
20394 3120 CONTINUE
20395      JFILE=2
20396      GOTO3190
20397 3130 CONTINUE
20398      JFILE=3
20399      GOTO3190
20400 3140 CONTINUE
20401      JFILE=4
20402      GOTO3190
20403 3150 CONTINUE
20404      JFILE=5
20405      GOTO3190
20406 3160 CONTINUE
20407      JFILE=6
20408      GOTO3190
20409C
20410 3190 CONTINUE
20411C
20412C               *******************************
20413C               **  STEP 32--                **
20414C               **  COPY OVER FILE VARIABLES **
20415C               *******************************
20416C
20417      ISTEPN='32'
20418      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
20419     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20420C
20421      IF(JFILE.EQ.1)THEN
20422        IOUNIT=IHE1NU
20423        IFILE=IHE1NA
20424        ISTAT=IHE1ST
20425        IFORM=IHE1FO
20426        IACCES=IHE1AC
20427        IPROT=IHE1PR
20428        ICURST=IHE1CS
20429        ISUBN0='HEL2'
20430        IERRFI='NO'
20431      ELSEIF(JFILE.EQ.2)THEN
20432        IOUNIT=IHE2NU
20433        IFILE=IHE2NA
20434        ISTAT=IHE2ST
20435        IFORM=IHE2FO
20436        IACCES=IHE2AC
20437        IPROT=IHE2PR
20438        ICURST=IHE2CS
20439        ISUBN0='HEL2'
20440        IERRFI='NO'
20441      ELSEIF(JFILE.EQ.3)THEN
20442        IOUNIT=IHE3NU
20443        IFILE=IHE3NA
20444        ISTAT=IHE3ST
20445        IFORM=IHE3FO
20446        IACCES=IHE3AC
20447        IPROT=IHE3PR
20448        ICURST=IHE3CS
20449        ISUBN0='HEL2'
20450        IERRFI='NO'
20451      ELSEIF(JFILE.EQ.4)THEN
20452        IOUNIT=IHE4NU
20453        IFILE=IHE4NA
20454        ISTAT=IHE4ST
20455        IFORM=IHE4FO
20456        IACCES=IHE4AC
20457        IPROT=IHE4PR
20458        ICURST=IHE4CS
20459        ISUBN0='HEL2'
20460        IERRFI='NO'
20461      ELSEIF(JFILE.EQ.5)THEN
20462        IOUNIT=IHE5NU
20463        IFILE=IHE5NA
20464        ISTAT=IHE5ST
20465        IFORM=IHE5FO
20466        IACCES=IHE5AC
20467        IPROT=IHE5PR
20468        ICURST=IHE5CS
20469        ISUBN0='HEL2'
20470        IERRFI='NO'
20471      ELSE
20472        IOUNIT=IHE6NU
20473        IFILE=IHE6NA
20474        ISTAT=IHE6ST
20475        IFORM=IHE6FO
20476        IACCES=IHE6AC
20477        IPROT=IHE6PR
20478        ICURST=IHE6CS
20479        ISUBN0='HEL2'
20480        IERRFI='NO'
20481      ENDIF
20482C
20483      IF(IBUGS2.EQ.'ON' .OR. ISUBRO.EQ.'HELP')THEN
20484        WRITE(ICOUT,3293)IOUNIT,IERRFI
20485 3293   FORMAT('IOUNIT,IERRFI = ',I8,2X,A4)
20486        CALL DPWRST('XXX','BUG ')
20487        WRITE(ICOUT,3294)IFILE
20488 3294   FORMAT('IFILE = ',A80)
20489        CALL DPWRST('XXX','BUG ')
20490        WRITE(ICOUT,3295)ISTAT,IFORM,IACCES,IPROT,ICURST
20491 3295   FORMAT('ISTAT,IFORM,IACCES,IPROT,ICURST = ',4(A12,2X),A12)
20492        CALL DPWRST('XXX','BUG ')
20493      ENDIF
20494C
20495C               ****************************************
20496C               **  STEP 33--                         **
20497C               **  CHECK TO SEE IF HELP FILE EXISTS  **
20498C               ****************************************
20499C
20500      ISTEPN='33'
20501      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
20502     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20503C
20504      IF(ISTAT.EQ.'NONE')THEN
20505        IERROR='YES'
20506        WRITE(ICOUT,999)
20507        CALL DPWRST('XXX','BUG ')
20508        WRITE(ICOUT,3311)
20509 3311   FORMAT('***** ERROR IN DPHELP--')
20510        CALL DPWRST('XXX','BUG ')
20511        WRITE(ICOUT,3312)
20512 3312   FORMAT('      THE DESIRED HELP INFORMATION CANNOT BE GIVEN')
20513        CALL DPWRST('XXX','BUG ')
20514        WRITE(ICOUT,3314)
20515 3314   FORMAT('      BECAUSE THE REQUIRED SYSTEM MASS STORAGE FILE')
20516        CALL DPWRST('XXX','BUG ')
20517        WRITE(ICOUT,3315)
20518 3315   FORMAT('      WHICH STORES SUCH HELP INFORMATION')
20519        CALL DPWRST('XXX','BUG ')
20520        WRITE(ICOUT,3316)
20521 3316   FORMAT('      IS NOT AVAILABLE AT THIS INSTALLATION.')
20522        CALL DPWRST('XXX','BUG ')
20523        WRITE(ICOUT,3317)ISTAT,IHELST
20524 3317   FORMAT('ISTAT,IHELST = ',A12,2X,A12)
20525        CALL DPWRST('XXX','BUG ')
20526        WRITE(ICOUT,3318)IFILE(1:50)
20527 3318   FORMAT('IFILE(1:50) = ',A50)
20528        CALL DPWRST('XXX','BUG ')
20529        GOTO9000
20530      ENDIF
20531C
20532C               *********************
20533C               **  STEP 34--      **
20534C               **  OPEN THE FILE  **
20535C               *********************
20536C
20537      ISTEPN='34'
20538      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
20539     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20540C
20541      IREWIN='ON'
20542      CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
20543     1            IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
20544      IF(IERRFI.EQ.'YES')GOTO9000
20545C
20546      IF(IHLPNW.EQ.'ON')THEN
20547        IOP='OPEN'
20548        IFLG11=1
20549        IFLG21=0
20550        IFLG31=0
20551        IFLAG4=0
20552        IFLAG5=0
20553        CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLAG4,IFLAG5,
20554     1              IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
20555     1              IBUGS2,ISUBRO,IERROR)
20556        IF(IERROR.EQ.'YES')GOTO9000
20557      ENDIF
20558C
20559C               **************************************************
20560C               **  STEP 41--                                   **
20561C               **  BASED ON THE FIRST WORD OR                  **
20562C               **  THE FIRST CHARACTER OF THE FIRST WORD,      **
20563C               **  DETERMINE THE SECTION NUMBER WITHIN A FILE  **
20564C               **  THAT SHOULD BE SEARCHED.                    **
20565C               **************************************************
20566C
20567      ISTEPN='42'
20568C
20569      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
20570     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20571C
20572      CALL DPCOAN(ICHAR1,JCHAR1)
20573C
20574      IF(JFILE.EQ.1)THEN
20575        IF(IWORD1.EQ.'OVER')JSEC=1
20576        IF(IWORD1.EQ.'GRAP')JSEC=2
20577        IF(IWORD1.EQ.'DIAG')JSEC=3
20578        IF(IWORD1.EQ.'ANAL')JSEC=4
20579        IF(IWORD1.EQ.'PLOT'.AND.IWORD2.EQ.'CONT')JSEC=5
20580        IF(IWORD1.EQ.'SUPP')JSEC=6
20581        IF(IWORD1.EQ.'OUTP')JSEC=7
20582        IF(IWORD1.EQ.'KEYW')JSEC=8
20583        IF(IWORD1.EQ.'FUNC')JSEC=9
20584        IF(IWORD1.EQ.'MATH'.AND.IWORD2.EQ.'FUNC')JSEC=10
20585        IF(IWORD1.EQ.'TRIG')JSEC=11
20586        IF(IWORD1.EQ.'PROB')JSEC=12
20587        IF(IWORD1.EQ.'LET '.AND.IWORD2.EQ.'SUBC')JSEC=13
20588        IF(IWORD1.EQ.'LET '.AND.IWORD2.EQ.'SUB-')JSEC=13
20589        IF(IWORD1.EQ.'LET '.AND.IWORD2.EQ.'SUB ')JSEC=13
20590        IF(IWORD1.EQ.'STAT')JSEC=14
20591        IF(IWORD1.EQ.'MATH'.AND.IWORD2.EQ.'OPER')JSEC=15
20592        IF(IWORD1.EQ.'MATR'.AND.IWORD2.EQ.'OPER')JSEC=16
20593        IF(IWORD1.EQ.'RAND')JSEC=17
20594        IF(IWORD1.EQ.'TEXT'.AND.IWORD2.EQ.'SUBC')JSEC=18
20595        IF(IWORD1.EQ.'TEXT'.AND.IWORD2.EQ.'SUB-')JSEC=18
20596        IF(IWORD1.EQ.'TEXT'.AND.IWORD2.EQ.'SUB ')JSEC=18
20597        IF(IWORD1.EQ.'CAPI')JSEC=19
20598        IF(IWORD1.EQ.'CAPS')JSEC=19
20599        IF(IWORD1.EQ.'CAP ')JSEC=19
20600        IF(IWORD1.EQ.'SUBS'.AND.IWOR12.EQ.'CRIP')JSEC=20
20601        IF(IWORD1.EQ.'GREE')JSEC=21
20602        IF(IWORD1.EQ.'MATH'.AND.IWORD2.EQ.'SYMB')JSEC=22
20603        IF(IWORD1.EQ.'MISC')JSEC=23
20604        IF(IWORD1.EQ.'CHAR'.AND.IWORD2.EQ.'TYPE')JSEC=24
20605        IF(IWORD1.EQ.'LINE'.AND.IWORD2.EQ.'TYPE')JSEC=25
20606        IF(IWORD1.EQ.'COLO'.AND.IWORD2.EQ.'TYPE')JSEC=26
20607        IF(IWORD1.EQ.'ASCI'.AND.IWORD2.EQ.'FILE')JSEC=27
20608        IF(IWORD1.EQ.'SYST'.AND.IWORD2.EQ.'LIMI')JSEC=28
20609        IF(IWORD1.EQ.'PROB'.AND.IWORD2.EQ.'DIST')JSEC=29
20610      ELSEIF(JFILE.EQ.2)THEN
20611        IF(ICHAR1.EQ.'A')JSEC=1
20612        IF(ICHAR1.EQ.'B')JSEC=2
20613        IF(ICHAR1.EQ.'C')JSEC=3
20614      ELSEIF(JFILE.EQ.3)THEN
20615        IF(ICHAR1.EQ.'D')JSEC=1
20616        IF(ICHAR1.EQ.'E')JSEC=2
20617        IF(ICHAR1.EQ.'F')JSEC=3
20618        IF(ICHAR1.EQ.'G')JSEC=4
20619        IF(ICHAR1.EQ.'H')JSEC=5
20620        IF(ICHAR1.EQ.'I')JSEC=6
20621        IF(ICHAR1.EQ.'J')JSEC=7
20622        IF(ICHAR1.EQ.'K')JSEC=8
20623      ELSEIF(JFILE.EQ.4)THEN
20624        IF(ICHAR1.EQ.'L')JSEC=1
20625        IF(ICHAR1.EQ.'M')JSEC=2
20626        IF(ICHAR1.EQ.'N')JSEC=3
20627        IF(ICHAR1.EQ.'O')JSEC=4
20628      ELSEIF(JFILE.EQ.5)THEN
20629        IF(ICHAR1.EQ.'P')JSEC=1
20630        IF(ICHAR1.EQ.'Q')JSEC=2
20631        IF(ICHAR1.EQ.'R')JSEC=3
20632        IF(ICHAR1.EQ.'S')JSEC=4
20633      ELSE
20634        JSEC=8
20635        IF(ICHAR1.EQ.'T')JSEC=1
20636        IF(ICHAR1.EQ.'U')JSEC=2
20637        IF(ICHAR1.EQ.'V')JSEC=3
20638        IF(ICHAR1.EQ.'W')JSEC=4
20639        IF(ICHAR1.EQ.'X')JSEC=5
20640        IF(ICHAR1.EQ.'Y')JSEC=6
20641        IF(ICHAR1.EQ.'Z')JSEC=7
20642      ENDIF
20643C
20644      IF(IBUGS2.EQ.'ON' .OR. ISUBRO.EQ.'HELP')THEN
20645        WRITE(ICOUT,4191)
20646 4191   FORMAT('***** FROM 4191 IN MIDDLE OF DPHELP--')
20647        CALL DPWRST('XXX','BUG ')
20648        WRITE(ICOUT,4192)IWORD1,ICHAR1
20649 4192   FORMAT('IWORD1,ICHAR1 = ',A4,2X,A4)
20650        CALL DPWRST('XXX','BUG ')
20651        WRITE(ICOUT,4193)JFILE,JSEC
20652 4193   FORMAT('JFILE,JSEC = ',I8,2X,I8)
20653        CALL DPWRST('XXX','BUG ')
20654      ENDIF
20655C
20656C               ************************************************************
20657C               **  STEP 42--                                             **
20658C               **  READ IN SECTION LOCATION INFORMATION                  **
20659C               **  FROM THE BEGINNING LINES OF THE FILE.                 **
20660C               **  THE FIRST LINE CONTAINS THE                           **
20661C               **  NUMBER OF LINES IN THE FILE (ANUMLI) (F10.0 FORMAT).  **
20662C               **  THE SECOND LINE CONTAINS THE NUMBER OF                **
20663C               **  SECTIONS IN THE FILE (ANUMSE) (F10.0 FORMAT)          **
20664C               **  THE NEXT ANUMSE LINES CONTAIN                         **
20665C               **  THE STARTING LINE NUMBER OF EACH SECTION              **
20666C               **  IN THE FILE (ATABLN)   (F10.0 FORMAT), AND            **
20667C               **  THE IDENTIFIER (IF ANY) FOR EACH SECTION              **
20668C               **  IN THE FILE (ITABID(.) (A4 FORMAT).                   **
20669C               ************************************************************
20670C
20671      ISTEPN='42'
20672      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
20673     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20674C
20675      READ(IOUNIT,4211)ANUMLI
20676 4211 FORMAT(F10.0)
20677      NUMLIN=INT(ANUMLI+0.5)
20678      READ(IOUNIT,4212)ANUMSE
20679 4212 FORMAT(F10.0)
20680      NUMSEC=INT(ANUMSE+0.5)
20681      IF(NUMSEC.GT.0)THEN
20682        DO4220I=1,NUMSEC
20683          READ(IOUNIT,4221)ATABLN,ITABID(I)
20684 4221     FORMAT(F10.0,A4)
20685          ITABLN(I)=INT(ATABLN+0.5)
20686C
20687          IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')THEN
20688            WRITE(ICOUT,4222)I,ITABLN(I),ATABLN,ITABID(I)
20689 4222       FORMAT('I,ITABLN(I),ATABLN,ITABID(I) = ',2I8,G15.7,2X,A4)
20690            CALL DPWRST('XXX','BUG ')
20691          ENDIF
20692C
20693 4220   CONTINUE
20694      ENDIF
20695C
20696C               *******************************************************
20697C               **  STEP 43--                                        **
20698C               **  BASED ON THE FILE, SECTION, & HEADER TABLE INFO, **
20699C               **  DO A TABLE LOOK-UP WHICH WILL SPECIFY            **
20700C               **  THE ABSOLUTE LINE NUMBER IN THE FILE             **
20701C               **  WHERE THE SECTION WITH THAT CODE WORD STARTS     **
20702C               *******************************************************
20703C
20704      ISTEPN='43'
20705      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HEL2')
20706     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20707C
20708      ISTART=ITABLN(JSEC)
20709      JSECP1=JSEC+1
20710      ISTOP=NUMLIN
20711      IF(JSECP1.LE.NUMSEC)ISTOP=ITABLN(JSECP1)
20712      IF(ISTOP.LE.ISTART)ISTOP=NUMLIN
20713
20714      IF(IBUGS2.EQ.'ON' .OR. ISUBRO.EQ.'HELP')THEN
20715        WRITE(ICOUT,4311)
20716 4311   FORMAT('***** FROM 4211 IN MIDDLE OF DPHELP--')
20717        CALL DPWRST('XXX','BUG ')
20718        WRITE(ICOUT,4313)JSEC,ISTART,JSECP1,ISTOP
20719 4313   FORMAT('JSEC,ISTART,JSECP1,ISTOP = ',4I8)
20720        CALL DPWRST('XXX','BUG ')
20721      ENDIF
20722C
20723C               *************************************************
20724C               **  STEP 51--                                  **
20725C               **  READ DOWN IN THE FILE TO                   **
20726C               **  THE LINE BEFORE WHERE THE CHARACTER RESIDES**
20727C               *************************************************
20728C
20729      ISTEPN='51'
20730      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
20731     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20732C
20733      REWIND(IOUNIT)
20734C
20735      ISKIP=ISTART-1
20736      IF(ISKIP.GT.0)THEN
20737        DO5100I=1,ISKIP
20738          READ(IOUNIT,5105,END=5280)
20739 5105     FORMAT()
20740 5100   CONTINUE
20741      ENDIF
20742C
20743C               ******************************************************
20744C               **  STEP 52.1--                                     **
20745C               **  LOOP THROUGH THE VARIOUS LINES OF THIS SECTION  **
20746C               **  OF THE FILE.                                    **
20747C               ******************************************************
20748C
20749      ISTEPN='52.1'
20750      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
20751     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20752C
20753      DO5200I=ISTART,ISTOP
20754        I2=I
20755C
20756CCCCC THE FOLLOWING SECTION WAS FIXED AUGUST 1994
20757C               *****************************************
20758C               **  STEP 52.2--                        **
20759C               **  READ IN SUCCEEDING LINES UNTIL     **
20760C               **  GET A HIT BASED ON THE FIRST WORD  **
20761C               **  OF THE COMMAND.                    **
20762C               *****************************************
20763C
20764CCCCC   FEBRUARY 2003: UP FROM 30 CHARACTERS TO 40 CHARACTERS AND FROM
20765CCCCC                  MAXIMUM OF FOUR WORDS TO MAXIMUM OF FIVE WORDS.
20766C
20767        ILIN30='                                        '
20768        READ(IOUNIT,5202,END=5280)ILIN30
20769 5202   FORMAT(A40)
20770        IF(ILIN30(1:4).EQ.'    ')GOTO5200
20771C
20772CCCCC   COMPARE CHAR. 1 TO 4 OF THE HELP FILE LINE
20773CCCCC   (ILIN30(1:4) AND ICTEST) WITH
20774CCCCC   CHAR. 1 TO 4 OF THE FIRST WORD OF THE HELP COMMAND EXT (IWORD1)
20775C
20776        ICTEST=ILIN30(1:4)
20777        IF(ICTEST(4:4).EQ.' ' .OR. ICTEST(4:4).EQ.'-')ICTEST(4:4)=' '
20778        IF(ICTEST(3:3).EQ.' ' .OR. ICTEST(3:3).EQ.'-')ICTEST(3:4)='  '
20779        IF(ICTEST(2:2).EQ.' ' .OR. ICTEST(4:4).EQ.'-')ICTEST(2:4)='   '
20780C
20781        IF(ICTEST.NE.IWORD1)GOTO5200
20782C
20783        IF(IBUGS2.EQ.'ON' .OR. ISUBRO.EQ.'HELP')THEN
20784          WRITE(ICOUT,999)
20785          CALL DPWRST('XXX','BUG ')
20786          WRITE(ICOUT,5207)I,ILIN30(1:40)
20787 5207     FORMAT('I,ILIN30(1:40)=',I8,2X,A40)
20788          CALL DPWRST('XXX','BUG ')
20789          WRITE(ICOUT,5208)NUMARG,NUMAR2,IWORD1,ILIN30(1:4),ICTEST
20790 5208     FORMAT('NUMARG,NUMAR2,IWORD1,ILIN30(1:4),ICTEST = ',
20791     1           2I8,3(2X,A4))
20792          CALL DPWRST('XXX','BUG ')
20793        ENDIF
20794C
20795CCCCC   COMPARE CHAR. 5 TO 8 OF THE HELP FILE LINE
20796CCCCC   (ILIN30(5:8) AND ICTEST) WITH
20797CCCCC   CHAR. 5 TO 8 OF THE FIRST WORD OF THE HELP COMMAND EXT (IWOR12)
20798C
20799        ICTEST=ILIN30(5:8)
20800        IF(ILIN30(4:4).EQ.' ' .OR. ILIN30(4:4).EQ.'-')ICTEST='    '
20801        IF(ILIN30(3:3).EQ.' ' .OR. ILIN30(3:3).EQ.'-')ICTEST='    '
20802        IF(ILIN30(2:2).EQ.' ' .OR. ILIN30(2:2).EQ.'-')ICTEST='    '
20803        IF(ILIN30(1:1).EQ.' ' .OR. ILIN30(1:1).EQ.'-')ICTEST='    '
20804C
20805        IF(ICTEST(3:3).EQ.' ' .OR. ICTEST(3:3).EQ.'-')ICTEST(3:4)='  '
20806        IF(ICTEST(2:2).EQ.' ' .OR. ICTEST(2:2).EQ.'-')ICTEST(2:4)='   '
20807        IF(ICTEST(1:1).EQ.' ' .OR. ICTEST(1:1).EQ.'-')ICTEST(1:4)='    '
20808C
20809        IF(IBUGS2.EQ.'ON' .OR. ISUBRO.EQ.'HELP')THEN
20810          WRITE(ICOUT,5209)IWOR12,ICTEST
20811 5209     FORMAT('IWOR12,ICTEST = ',A4,2X,A4)
20812          CALL DPWRST('XXX','BUG ')
20813        ENDIF
20814C
20815CCCCC   THE FOLLOWING LINE WAS CHANGED            DECEMBER 1994
20816CCCCC   SO THAT    HELP CHAR    WOULD WORK        DECEMBER 1994
20817CCCCC   IF(ICTEST.EQ.IWOR12)GOTO5210
20818CCCCC   FIX SO THAT TEST DONE IF THERE IS A SECOND    JUNE 1999
20819CCCCC   WORD TO RESOLVE NAME CONFLICTS                JUNE 1999
20820C
20821        IF(ICTEST(1:4).EQ.'    ' .OR. ICTEST.EQ.IWOR12)GOTO5210
20822        GOTO5200
20823C
20824 5210   CONTINUE
20825C
20826        IF(IBUGS2.EQ.'ON' .OR. ISUBRO.EQ.'HELP')THEN
20827          WRITE(ICOUT,5211)NUMARG,NUMAR2,IWOR12,ILIN30(5:8),ICTEST
20828 5211     FORMAT('NUMARG,NUMAR2,IWOR12,ILIN30(5:8),ICTEST = ',
20829     1           2I8,I8,3(2X,A4))
20830          CALL DPWRST('XXX','BUG ')
20831        ENDIF
20832C
20833CCCCC   THE FOLLOWING SECTION WAS FIXED    AUGUST 1994
20834C               ***********************************************
20835C               **  STEP 52.3--                              **
20836C               **  IF GOT A HIT ON THE FIRST 4-CHAR. WORD,  **
20837C               **  CHECK FOR A HIT ON ALL 4-CHAR WORDS      **
20838C               ***********************************************
20839C
20840        ISTEPN='52.3'
20841        IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
20842     1     CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20843C
20844        ISTRIN(1:40)=ILIN30(1:40)
20845C
20846        NUMWHF=1
20847        ILOC2=1
20848        ILOC3=1
20849        ILOC4=1
20850        ILOC5=1
20851        DO5220J=1,39
20852          JP1=J+1
20853          IF((ISTRIN(J:J).EQ.' ' .OR. ISTRIN(J:J).EQ.'-').AND.
20854     1        ISTRIN(JP1:JP1).NE.' ')THEN
20855            NUMWHF=NUMWHF+1
20856            IF(NUMWHF.EQ.2)ILOC2=JP1
20857            IF(NUMWHF.EQ.3)ILOC3=JP1
20858            IF(NUMWHF.EQ.4)ILOC4=JP1
20859            IF(NUMWHF.EQ.5)ILOC5=JP1
20860          ENDIF
20861 5220   CONTINUE
20862        ILOC2P=ILOC2+3
20863        ILOC3P=ILOC3+3
20864        ILOC4P=ILOC4+3
20865        ILOC5P=ILOC5+3
20866C
20867        IZ1=ILIN30(1:4)
20868        IZ2(1:4)='    '
20869        IF(NUMWHF.GE.2)IZ2(1:4)=ISTRIN(ILOC2:ILOC2P)
20870        IZ3(1:4)='    '
20871        IF(NUMWHF.GE.3)IZ3(1:4)=ISTRIN(ILOC3:ILOC3P)
20872        IZ4(1:4)='    '
20873        IF(NUMWHF.GE.4)IZ4(1:4)=ISTRIN(ILOC4:ILOC4P)
20874        IZ5(1:4)='    '
20875        IF(NUMWHF.GE.5)IZ5(1:4)=ISTRIN(ILOC5:ILOC5P)
20876C
20877        DO5225J=2,4
20878          IF(IZ1(J:J).EQ.' '.OR.IZ1(J:J).EQ.'-')IZ1(J:4)=' '
20879          IF(IZ2(J:J).EQ.' '.OR.IZ2(J:J).EQ.'-')IZ2(J:4)=' '
20880          IF(IZ3(J:J).EQ.' '.OR.IZ3(J:J).EQ.'-')IZ3(J:4)=' '
20881          IF(IZ4(J:J).EQ.' '.OR.IZ4(J:J).EQ.'-')IZ4(J:4)=' '
20882          IF(IZ5(J:J).EQ.' '.OR.IZ5(J:J).EQ.'-')IZ5(J:4)=' '
20883 5225   CONTINUE
20884C
20885        IF(IBUGS2.EQ.'ON' .OR. ISUBRO.EQ.'HELP')THEN
20886          WRITE(ICOUT,5231)
20887 5231     FORMAT('***** FROM 1731 IN MIDDLE OF DPHELP--')
20888          CALL DPWRST('XXX','BUG ')
20889          WRITE(ICOUT,5232)IWORD1,IWOR12,IWORD2,IWORD3,IWORD4,IWORD5
20890 5232     FORMAT('IWORD1,IWOR12,IWORD2,IWORD3,IWORD4,IWORD5 = ',
20891     1           5(A4,2X),A4)
20892          CALL DPWRST('XXX','BUG ')
20893          WRITE(ICOUT,5233)ILIN30(1:40)
20894 5233     FORMAT('ILIN30(1:40) = ',A40)
20895          CALL DPWRST('XXX','BUG ')
20896          WRITE(ICOUT,5234)IZ1,IZ2,IZ3,IZ4,IZ5
20897 5234     FORMAT('IZ1,IZ2,IZ3,IZ4 = ',A4,2X,A4,2X,A4,2X,A4,2X,A4)
20898          CALL DPWRST('XXX','BUG ')
20899          WRITE(ICOUT,5235)ISTRIN
20900 5235     FORMAT('ISTRIN = ',A40)
20901          CALL DPWRST('XXX','BUG ')
20902          WRITE(ICOUT,5236)NUMARG,NUMAR2,NUMWHF
20903 5236     FORMAT('NUMARG,NUMAR2,NUMWHF = ',3I8)
20904          CALL DPWRST('XXX','BUG ')
20905          WRITE(ICOUT,5237)ILOC2,ILOC3,ILOC4,ILOC5
20906 5237     FORMAT('ILOC2,ILOC3,ILOC4,ILOC5 = ',4I8)
20907          CALL DPWRST('XXX','BUG ')
20908          WRITE(ICOUT,5238)ILOC2P,ILOC3P,ILOC4P,ILOC5P
20909 5238     FORMAT('ILOC2P,ILOC3P,ILOC4P,ILOC5P = ',4I8)
20910          CALL DPWRST('XXX','BUG ')
20911        ENDIF
20912C
20913CCCCC   THE FOLLOWING LINE WAS ADDED AUGUST 1994
20914        IF(NUMAR2.NE.NUMWHF)GOTO5200
20915C
20916        IF(NUMAR2.LE.1 .OR. NUMWHF.LE.1)GOTO5290
20917        IF(IZ2.EQ.IWORD2)GOTO5253
20918        GOTO5200
20919C
20920 5253   CONTINUE
20921        IF(NUMAR2.LE.2 .OR. NUMWHF.LE.2)GOTO5290
20922        IF(IZ3.EQ.IWORD3)GOTO5254
20923        GOTO5200
20924C
20925 5254   CONTINUE
20926        IF(NUMAR2.LE.3 .OR. NUMWHF.LE.3)GOTO5290
20927        IF(IZ4.EQ.IWORD4)GOTO5255
20928        GOTO5200
20929C
20930 5255   CONTINUE
20931        IF(NUMAR2.LE.4 .OR. NUMWHF.LE.4)GOTO5290
20932        IF(IZ5.EQ.IWORD5)GOTO5290
20933        GOTO5200
20934C
20935 5200 CONTINUE
20936C
20937CCCCC THE FOLLOWING SECTION WAS  CHANGED     AUGUST 1994 (JJF)
20938 5280 CONTINUE
20939      IERROR='YES'
20940      IF(IPASS.GE.2)THEN
20941         WRITE(ICOUT,999)
20942         CALL DPWRST('XXX','BUG ')
20943         WRITE(ICOUT,3311)
20944         CALL DPWRST('XXX','BUG ')
20945         WRITE(ICOUT,5282)
20946 5282    FORMAT('      THE SPECIFIED COMMAND FOR WHICH HELP WAS')
20947         CALL DPWRST('XXX','BUG ')
20948         WRITE(ICOUT,5284)
20949 5284    FORMAT('      DESIRED WAS NOT FOUND IN THE HELP FILE.')
20950         CALL DPWRST('XXX','BUG ')
20951         WRITE(ICOUT,5285)
20952 5285    FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
20953         CALL DPWRST('XXX','BUG ')
20954         WRITE(ICOUT,5286)(IANS(I),I=1,MIN(120,IWIDTH))
20955 5286    FORMAT('      ',120A1)
20956         CALL DPWRST('XXX','BUG ')
20957      ENDIF
20958      GOTO6100
20959C
20960 5290 CONTINUE
20961C
20962C               ****************************************************
20963C               **  STEP 53--                                     **
20964C               **  IF HAVE A HIT ON ALL WORDS,                   **
20965C               **  THEN READ IN AND WRITE OUT                    **
20966C               **  THE ENTIRE TEXT DESCRIPTION ASSOCIATED WITH   **
20967C               **  THE DESIRED COMMAND.                          **
20968C               **  THIS DESCRIPTION WILL START ON THE NEXT LINE  **
20969C               **  AND WILL FINISH WHEN A LINE OF HYPHENS        **
20970C               **  IS ENCOUNTERED.                               **
20971C               ****************************************************
20972C
20973      ISTEPN='53'
20974      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
20975     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20976C
20977      NUMLPR=0
20978      IRESP='YES'
20979      IF(NCPREH.GT.0)THEN
20980        IF(IHLPNW.EQ.'ON')THEN
20981          WRITE(IOUNI1,5311)(ICPREH(J:J),J=1,NCPREH)
20982        ELSE
20983          WRITE(ICOUT,5311)(ICPREH(J:J),J=1,NCPREH)
20984 5311     FORMAT(80A1)
20985          CALL DPWRST('XXX','WRIT')
20986        ENDIF
20987      ENDIF
20988C
20989      WRITE(ICOUT,999)
20990      CALL DPWRST('XXX','WRIT')
20991      IF(IHLPNW.EQ.'ON')THEN
20992        DO55320I=1,100000
20993          READ(IOUNIT,5321,END=5390)(ICTEXT(J),J=1,20)
20994          IF(ICTEXT(1).EQ.'----')GOTO5390
20995          IF(ICTEXT(1).EQ.'....')GOTO5390
20996          DO55330J=1,20
20997            JREV=20-J+1
20998            IF(ICTEXT(JREV).NE.'    ')GOTO55335
2099955330     CONTINUE
2100055335     CONTINUE
21001          JMAX=JREV
21002          WRITE(IOUNI1,5336)(ICTEXT(J),J=1,JMAX)
2100355320   CONTINUE
21004      ELSE
21005        DO5320I=1,100000
21006          READ(IOUNIT,5321,END=5390)(ICTEXT(J),J=1,20)
21007 5321     FORMAT(20A4)
21008          IF(ICTEXT(1).EQ.'----')GOTO5390
21009          IF(ICTEXT(1).EQ.'....')GOTO5390
21010C
21011          IF(NUMLPR.GE.IHELMX)THEN
21012            CALL DPMORE(NUMLPR,NCPREH,ICPREH,IRESP,IBUGS2,IERROR)
21013            NUMLPR=0
21014          ENDIF
21015          IF(IRESP.EQ.'NO')GOTO5390
21016C
21017          DO5330J=1,20
21018            JREV=20-J+1
21019            IF(ICTEXT(JREV).NE.'    ')GOTO5335
21020 5330     CONTINUE
21021 5335     CONTINUE
21022          JMAX=JREV
21023C
21024          WRITE(ICOUT,5336)(ICTEXT(J),J=1,JMAX)
21025 5336     FORMAT(20A4)
21026          CALL DPWRST('XXX','WRIT')
21027          NUMLPR=NUMLPR+1
21028 5320   CONTINUE
21029      ENDIF
21030C
21031 5390 CONTINUE
21032C
21033      IF(IHLPNW.EQ.'ON')THEN
21034        IOP='CLOS'
21035        CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLAG4,IFLAG5,
21036     1              IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
21037     1              IBUGS2,ISUBRO,IERROR)
21038      ELSE
21039        IF(NCPOSH.GT.0)THEN
21040          WRITE(ICOUT,5391)(ICPOSH(J:J),J=1,NCPOSH)
21041 5391     FORMAT(80A1)
21042          CALL DPWRST('XXX','WRIT')
21043        ENDIF
21044      ENDIF
21045C
21046C               **************************************
21047C               **  STEP 61--                       **
21048C               **  CLOSE           THE HELP FILE.  **
21049C               **************************************
21050C
21051 6100 CONTINUE
21052C
21053      ISTEPN='61'
21054      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
21055     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21056C
21057      IENDFI='OFF'
21058      IREWIN='ON'
21059      CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
21060     1            IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERRO2)
21061      IF(IERRFI.EQ.'YES')GOTO9000
21062C
21063CCCCC THE FOLLOWING SECTION WAS ADDED         AUGUST 1994
21064CCCCC TO SEARCH A SYNONYM FILE (DPHE7F.TEX)   AUGUST 1994
21065C               ***********************************************
21066C               **  STEP 62--                                **
21067C               **  IF PASS 1 AND NOT FOUND IN FILES 1 TO 6, **
21068C               **  THEN SCAN SYNONYM FILE FOR MATCH         **
21069C               **  AND TRY AGAIN IN FILES 1 TO 6            **
21070C               ***********************************************
21071C
21072      IF(IPASS.EQ.1.AND.IERROR.EQ.'YES')THEN
21073         IOUNIT=IHE7NU
21074         IFILE=IHE7NA
21075         ISTAT=IHE7ST
21076         IFORM=IHE7FO
21077         IACCES=IHE7AC
21078         IPROT=IHE7PR
21079         ICURST=IHE7CS
21080         ISUBN0='HEL2'
21081         IERRFI='NO'
21082         IREWIN='ON'
21083         CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
21084     1   IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERRO2)
21085         IF(IERRFI.EQ.'YES')GOTO9000
21086C
21087CCCCC CORRECTIONS WERE MADE IN THE FOLLOWING SECTION DECEMBER 1994
21088         IMATCH=0
21089         DO6210I=1,5
21090            READ(IOUNIT,6211)ICJUNK
21091 6211       FORMAT(A1)
21092 6210    CONTINUE
21093         DO6220I=1,10000
21094            READ(IOUNIT,6221,END=6229)ILINE(1:80)
21095 6221       FORMAT(A80)
21096            IF(ILINE(1:4).EQ.IWORD1.AND.ILINE(5:8).EQ.IWOR12)THEN
21097               IF(ILINE(10:13).EQ.IWORD2)THEN
21098                  IF(ILINE(15:18).EQ.IWORD3)THEN
21099                     IF(ILINE(20:23).EQ.IWORD4)THEN
21100                        IF(ILINE(25:28).EQ.IWORD5)THEN
21101                          IMATCH=1
21102                          IWORD1=ILINE(41:44)
21103                          IWOR12=ILINE(45:48)
21104                          IWORD2=ILINE(50:53)
21105                          IWORD3=ILINE(55:58)
21106                          IWORD4=ILINE(60:63)
21107                          IWORD5=ILINE(65:68)
21108                          NUMAR2=5
21109                          IF(IWORD5.EQ.'    ')NUMAR2=4
21110                          IF(IWORD4.EQ.'    ')NUMAR2=3
21111                          IF(IWORD3.EQ.'    ')NUMAR2=2
21112                          IF(IWORD2.EQ.'    ')NUMAR2=1
21113                       ENDIF
21114                     ENDIF
21115                  ENDIF
21116               ENDIF
21117            ENDIF
21118 6220    CONTINUE
21119 6229    CONTINUE
21120C
21121         IENDFI='OFF'
21122         IREWIN='ON'
21123         CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
21124     1   IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERRO2)
21125         IF(IERRFI.EQ.'YES')GOTO9000
21126C
21127CCCCC THE FOLLOWING I/O SECTION WAS ADDED     DECEMBER 1994
21128         IF(IBUGS2.EQ.'ON' .OR. ISUBRO.EQ.'HELP')THEN
21129            WRITE(ICOUT,999)
21130            CALL DPWRST('XXX','BUG ')
21131            WRITE(ICOUT,6231)
21132 6231       FORMAT('FROM DPHELP AT 6231--')
21133            CALL DPWRST('XXX','BUG ')
21134            WRITE(ICOUT,6232)IWORD1,IWOR12,IWORD2,IWORD3,IWORD4
21135 6232       FORMAT(A4,2X,A4,2X,A4,2X,A4,2X,A4)
21136            CALL DPWRST('XXX','BUG ')
21137            WRITE(ICOUT,6233)NUMAR2,IMATCH
21138 6233       FORMAT('NUMAR2,IMATCH = ',2I8)
21139            CALL DPWRST('XXX','BUG ')
21140            WRITE(ICOUT,999)
21141            CALL DPWRST('XXX','BUG ')
21142         ENDIF
21143C
21144         IF(IMATCH.EQ.1)THEN
21145            IERROR='NO'
21146            GOTO1000
21147         ENDIF
21148      ENDIF
21149      GOTO9000
21150C
21151C               ****************
21152C               **  STEP 90-- **
21153C               **  EXIT.     **
21154C               ****************
21155C
21156 9000 CONTINUE
21157C
21158      IF(IHLPNW.EQ.'ON' .AND. IERROR.EQ.'NO')THEN
21159        ISTR=' '
21160        IFLAGQ=0
21161        DO93160II=1,NCLSVW
21162          IF(ILSTVW(II:II).EQ.' ')THEN
21163            IFLAGQ=1
21164            GOTO93169
21165          ENDIF
2116693160   CONTINUE
2116793169   CONTINUE
21168        NCSTR=0
21169        IF(IOPSY1.EQ.'UNIX')THEN
21170C
21171C         NOTE: gnome-terminal AND xterm WANT QUOTES AROUND THE
21172C               THE COMMAND ARGUMENT (WITH -e OPTION).  HOWEVER,
21173C               KONSOLE DOES NOT.
21174C
21175          IF(NCLSLA.GE.1)THEN
21176            NCSTR=NCLSLA
21177            ISTR(1:NCLSLA)=ILSTLA(1:NCLSLA)
21178            IF(NCLSLA.GE.10 .AND.
21179     1         ILSTLA(NCLSLA-9:NCLSLA).EQ.'konsole -e')THEN
21180              ISTR(NCSTR+1:NCSTR+1)=' '
21181              NCSTR=NCSTR+1
21182            ELSE
21183              ISTR(NCSTR+1:NCSTR+2)=' "'
21184              NCSTR=NCSTR+2
21185            ENDIF
21186          ELSE
21187            NCSTR=19
21188            ISTR(1:NCSTR)='gnome-terminal -e "'
21189          ENDIF
21190        ELSEIF(IFLAGQ.EQ.1)THEN
21191          NCSTR=NCSTR+1
21192          ISTR(NCSTR:NCSTR)='"'
21193        ENDIF
21194C
21195C         USE "write.exe" IF WORDPAD IS THE VIEWER
21196C
21197        IF(IOPSY1.NE.'UNIX' .AND.
21198     1    (ILSTVW(1:7).EQ.'WORDPAD' .OR. ILSTVW(1:7).EQ.'wordpad'))THEN
21199          ISTR(NCSTR+1:NCSTR+9)='write.exe'
21200          NCSTR=NCSTR+9
21201        ELSE
21202          ISTR(NCSTR+1:NCSTR+NCLSVW)=ILSTVW(1:NCLSVW)
21203          NCSTR=NCSTR+NCLSVW
21204        ENDIF
21205C
21206        IF(IFLAGQ.EQ.1 .AND. IOPSY1.NE.'UNIX')THEN
21207          NCSTR=NCSTR+1
21208          ISTR(NCSTR:NCSTR)='"'
21209        ENDIF
21210        NCSTR=NCSTR+1
21211        ISTR(NCSTR:NCSTR)=' '
21212C
21213C       FOR NOTEPAD UNDER WINDOWS, FILE NAME NEEDS TO BE QUOTED
21214C       FOR "HIDDEN" MODE EVEN THOUGH IT DOES NOT CONTAIN SPACES.
21215C
21216        IF(IOPSY1.NE.'UNIX')THEN
21217          IF(ILSTVW(1:7).EQ.'notepad'.OR.ILSTVW(1:7).EQ.'NOTEPAD')THEN
21218            IFLGQ2=1
21219          ENDIF
21220        ENDIF
21221C
21222        IF(IFLGQ2.EQ.1)THEN
21223          NCSTR=NCSTR+1
21224          ISTR(NCSTR:NCSTR)='"'
21225        ENDIF
21226        ISTR(NCSTR+1:NCSTR+10)='dpst1f.dat'
21227        NCSTR=NCSTR+10
21228        IF(IFLGQ2.EQ.1)THEN
21229          NCSTR=NCSTR+1
21230          ISTR(NCSTR:NCSTR)='"'
21231        ENDIF
21232        IF(IOPSY1.EQ.'UNIX')THEN
21233          IF(NCLSLA.GE.10 .AND.
21234     1       ILSTLA(NCLSLA-9:NCLSLA).EQ.'konsole -e')THEN
21235          ELSE
21236            NCSTR=NCSTR+1
21237            ISTR(NCSTR:NCSTR)='"'
21238          ENDIF
21239        ENDIF
21240        ISSAV1=ISYSPE
21241        ISSAV2=ISYSHI
21242        ISSAV3=ICLEWT
21243        ISSAV4=ILINSY
21244        IF(IOPSY1.EQ.'UNIX')THEN
21245          ISYSPE='ON'
21246          ICLEWT='ON'
21247          ILINSY='COMM'
21248        ELSE
21249          ISYSPE='OFF'
21250          ISYSHI='ON'
21251          ICLEWT='ON'
21252        ENDIF
21253        CALL DPSYS2(ISTR,NCSTR,ISUBRO,IERROR)
21254        ISYSPE=ISSAV1
21255        ISYSHI=ISSAV2
21256        ICLEWT=ISSAV3
21257        ILINSY=ISSAV4
21258      ENDIF
21259C
21260      IF(IBUGS2.EQ.'ON' .OR. ISUBRO.EQ.'HELP')THEN
21261        WRITE(ICOUT,999)
21262        CALL DPWRST('XXX','BUG ')
21263        WRITE(ICOUT,9011)
21264 9011   FORMAT('***** AT THE END       OF DPHELP--')
21265        CALL DPWRST('XXX','BUG ')
21266        WRITE(ICOUT,9012)IFOUND,IERROR,IERRO2,IERRFI,IOUNIT
21267 9012   FORMAT('IFOUND,IERROR,IERRO2,IERRFI,IOUNIT = ',4(A4,2X),I6)
21268        CALL DPWRST('XXX','BUG ')
21269        WRITE(ICOUT,9037)ICURST,IENDFI,IREWIN
21270 9037   FORMAT('ICURST,IENDFI,IREWIN = ',A12,2(2X,A4))
21271        CALL DPWRST('XXX','BUG ')
21272        WRITE(ICOUT,9043)IWORD1,IWORD2,IWOR12,ICHAR1
21273 9043   FORMAT('IWORD1,IWORD2,IWOR12,ICHAR1 = ',3(A4,2X),A4)
21274        CALL DPWRST('XXX','BUG ')
21275        WRITE(ICOUT,9044)JFILE,ISTART,ISKIP,ISTOP,JMAX
21276 9044   FORMAT('JFILE,ISTART,ISKIP,ISTOP,JMAX = ',5I6)
21277        CALL DPWRST('XXX','BUG ')
21278        WRITE(ICOUT,9060)ILIN30(1:30),ICTEST
21279 9060   FORMAT('ILIN30(1:30),ICTEST =',A30)
21280        CALL DPWRST('XXX','BUG ')
21281        WRITE(ICOUT,9061)NUMSEC,NUMLIN,ISECNA
21282 9061   FORMAT('NUMSEC,NUMLIN,ISECNA = ',3I8)
21283        CALL DPWRST('XXX','BUG ')
21284        WRITE(ICOUT,9063)IWORD1,IWORD2,IWORD3,IWORD4,IWOR12
21285 9063   FORMAT('IWORD1,IWORD2,IWORD3,IWORD4,IWOR12 = ',
21286     1         5(A4,2X),A4)
21287        CALL DPWRST('XXX','BUG ')
21288        WRITE(ICOUT,9065)IZ1,IZ2,IZ3,IZ4,IZ5
21289 9065   FORMAT('IZ1,IZ2,IZ3,IZ4,IZ5 = ',4(A4,2X),A4)
21290        CALL DPWRST('XXX','BUG ')
21291        WRITE(ICOUT,9066)ISTRIN
21292 9066   FORMAT('ISTRIN = ',A40)
21293        CALL DPWRST('XXX','BUG ')
21294        WRITE(ICOUT,9068)NUMWHF,ILOC2,ILOC3,ILOC4,ILOC5
21295 9068   FORMAT('NUMWHF,ILOC2,ILOC3,ILOC4,ILOC5 = ',5I8)
21296        CALL DPWRST('XXX','BUG ')
21297        WRITE(ICOUT,9069)ILOC2P,ILOC3P,ILOC4P,ILOC5P
21298 9069   FORMAT('ILOC2P,ILOC3P,ILOC4P,ILOC5P = ',4I8)
21299        CALL DPWRST('XXX','BUG ')
21300        WRITE(ICOUT,9071)ICHAR1
21301 9071   FORMAT('ICHAR1 = ',A1)
21302        CALL DPWRST('XXX','BUG ')
21303        WRITE(ICOUT,9072)JCHAR1,JSEC,JSECP1,I2
21304 9072   FORMAT('JCHAR1,JSEC,JSECP1,I2 = ',4I8)
21305        CALL DPWRST('XXX','BUG ')
21306        WRITE(ICOUT,9073)ITABLN(JSEC),ITABLN(JSECP1)
21307 9073   FORMAT('ITABLN(JSEC),ITABLN(JSECP1) = ',2I8)
21308        CALL DPWRST('XXX','BUG ')
21309        WRITE(ICOUT,9074)ITABID(JSEC),ITABID(JSECP1)
21310 9074   FORMAT('ITABID(JSEC),ITABID(JSECP1) = ',A4,2X,A4)
21311        CALL DPWRST('XXX','BUG ')
21312        WRITE(ICOUT,9081)IHELMX,IPASS,IMATCH,IRESP
21313 9081   FORMAT('IHELMX,IPASS,IMATCH,IRESP = ',3I8,2X,A4)
21314        CALL DPWRST('XXX','BUG ')
21315        WRITE(ICOUT,9094)ILINE
21316 9094   FORMAT('ILINE = ',A80)
21317        CALL DPWRST('XXX','BUG ')
21318        WRITE(ICOUT,9096)IWORD3,IWORD4
21319 9096   FORMAT('IWORD3,IWORD4 = ',A4,2X,A4)
21320        CALL DPWRST('XXX','BUG ')
21321      ENDIF
21322C
21323      RETURN
21324      END
21325      SUBROUTINE DPHELW(ICOM,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
21326     1                  IANS,IWIDTH,
21327     1                  IBUGS2,ISUBRO,IFOUND,IERROR)
21328C
21329C     PURPOSE--ACCESS THE ON-LINE DATAPLOT REFERENCE MANUAL VIA
21330C              A WEB BROWSER (DEFAULTS TO NETSCAPE).  A PDF READER,
21331C              TYPICALLY THE ADOBE "ACROREAD" IS USED.  CURRENTLY,
21332C              THIS IS ONLY SUPPORTED FOR UNIX SYSTEMS (THE PC
21333C              VERSION IS A LITTLE HARDER TO ACCESS IN COMMAND MODE).
21334C
21335C              THIS COMMAND TAKES THE FOLLOWING FORMS:
21336C                  WEB HELP           - GO TO MAIN DATAPLOT HOME PAGE
21337C                  WEB HELP HOME PAGE - GO TO MAIN DATAPLOT HOME PAGE
21338C                  WEB HELP REFERENCE MANUAL - GO TO MAIN PAGE OF
21339C                                              REFERENCE MANUAL
21340C                  WEB HELP <KEYWORD> - GO TO A PARTICULAR PDF FILE
21341C                                       IN THE ON-LINE MANUAL BASED
21342C                                       ON MATCHING <KEYWORD> TO A
21343C                                       FILE (REFMAN.TEX)
21344C     INPUT  ARGUMENTS--IANS    (A  HOLLERITH VECTOR)
21345C                     --IWIDTH (AN INTEGER VARIABLE)
21346C                     --IBROWS  (A CHARACTER VARIABLE THAT IDENTIFIES
21347C                               THE BROWSER TO USE)
21348C                     --IDPURL  (A CHARACTER VARIABLE THAT IDENTIFIES
21349C                               THE WEB URL OF THE DATAPLOT HOME PAGE)
21350C     OUTPUT ARGUMENTS--IFOUND ('YES' OR 'NO' )
21351C                     --IERROR ('YES' OR 'NO' )
21352C     WRITTEN BY--ALAN HECKERT
21353C                 STATISTICAL ENGINEERING DIVISION
21354C                 INFORMATION TECHNOLOGY LABORATORY
21355C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
21356C                 GAITHERSBURG, MD 20899-8980
21357C                 PHONE--301-975-2899
21358C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
21359C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
21360C     LANGUAGE--ANSI FORTRAN (1977)
21361C     VERSION NUMBER--97/4
21362C     ORIGINAL VERSION--APRIL     1997.
21363C     UPDATED         --NOVEMBER  1997. BETTER CHECKING FOR NAME CONFLICTS
21364C     UPDATED         --FEBRUARY  2003. CHECK FOR 5 WORDS
21365C     UPDATED         --NOVMBER   2015. COMMENT OUT THE "-h" OPTION
21366C                                       FOR WINDOWS (THIS WAS SPECIFIC
21367C                                       TO NETSCAPE WHICH IS NOW AN
21368C                                       OBSOLETE BROWSER)
21369C     UPDATED         --APRIL     2018. ?? AS SYNONYM
21370C     UPDATED         --MARCH     2019. SET SYSTEM PERSIST
21371C                                       SET SYSTEM HIDDEN
21372C     UPDATED         --DECEMBER  2019. SUPPORT FOR EDGE BROWSER
21373C
21374C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
21375C
21376      CHARACTER*4 ICOM
21377      CHARACTER*4 IHARG
21378      CHARACTER*4 IHARG2
21379      CHARACTER*4 IARGT
21380      CHARACTER*4 IANS
21381      CHARACTER*1 IQUOTE
21382      CHARACTER*40 ILINE1
21383      CHARACTER*128 ILINE2
21384      CHARACTER*500 ICALL
21385C
21386      CHARACTER*4 IBUGS2
21387      CHARACTER*4 ISUBRO
21388      CHARACTER*4 IFOUND
21389      CHARACTER*4 IERROR
21390C
21391      INCLUDE 'DPCOPA.INC'
21392C
21393CCCCC CHARACTER*80 IFILE
21394      CHARACTER (LEN=MAXFNC) :: IFILE
21395      CHARACTER*12 ISTAT
21396      CHARACTER*12 IFORM
21397      CHARACTER*12 IACCES
21398      CHARACTER*12 IPROT
21399      CHARACTER*12 ICURST
21400      CHARACTER*4 ISUBN0
21401      CHARACTER*4 IERRFI
21402      CHARACTER*4 IENDFI
21403      CHARACTER*4 IREWIN
21404C
21405      CHARACTER*4 IWORD1
21406      CHARACTER*4 IWORD2
21407      CHARACTER*4 IWORD3
21408      CHARACTER*4 IWORD4
21409      CHARACTER*4 IWORD5
21410      CHARACTER*4 IWOR12
21411      CHARACTER*1 ICHAR1
21412      CHARACTER*4 ICTEST
21413      CHARACTER*4 ICTES2
21414      CHARACTER*4 IZ1
21415      CHARACTER*4 IZ2
21416      CHARACTER*4 IZ3
21417      CHARACTER*4 IZ4
21418      CHARACTER*4 IZ5
21419      CHARACTER*40 ISTRIN
21420      CHARACTER*4 IERRO2
21421      CHARACTER*4 ISUBN1
21422      CHARACTER*4 ISUBN2
21423      CHARACTER*4 ISTEPN
21424      CHARACTER*4 ISSAV1
21425      CHARACTER*4 ISSAV2
21426      CHARACTER*4 ICLESV
21427C
21428      DIMENSION IHARG(*)
21429      DIMENSION IHARG2(*)
21430      DIMENSION IARG(*)
21431      DIMENSION ARG(*)
21432      DIMENSION IARGT(*)
21433      DIMENSION IANS(*)
21434C
21435C-----COMMON----------------------------------------------------------
21436C
21437      INCLUDE 'DPCOHO.INC'
21438      INCLUDE 'DPCOST.INC'
21439      INCLUDE 'DPCOF2.INC'
21440C
21441      CHARACTER*80 PROFIL
21442      CHARACTER*80 P86FIL
21443      CHARACTER*80 APPDAT
21444      CHARACTER*80 COMNAM
21445      CHARACTER*80 UPROFI
21446      CHARACTER*80 DEFPRI
21447      CHARACTER*20 USRNAM
21448      CHARACTER*20 ISHELL
21449      CHARACTER*4  WINBIT
21450      COMMON/SYSVAR/PROFIL,P86FIL,APPDAT,COMNAM,UPROFI,USRNAM,DEFPRI,
21451     1              WINBIT,ISHELL
21452      COMMON/SYSVA2/NCPROF,NCP86F,NCAPPD,NCCOMP,NCUPRO,NCUSER,NCPRIN,
21453     1              NCSHEL
21454C
21455C-----COMMON VARIABLES (GENERAL)--------------------------------------
21456C
21457      INCLUDE 'DPCOP2.INC'
21458C
21459C-----START POINT-----------------------------------------------------
21460C
21461      ISUBN1='DPHE'
21462      ISUBN2='LW  '
21463      NUMLIN=(-999)
21464      NUMSEC=(-999)
21465      ISECNA=(-999)
21466      NUMAR2=(-999)
21467      JCHAR1=(-999)
21468      JSEC=(-999)
21469      JSECP1=(-999)
21470      ISKIP=(-999)
21471      ISTART=(-999)
21472      ISTOP=(-999)
21473      I2=(-999)
21474      NUMWHF=(-999)
21475      ILOC2=(-999)
21476      ILOC3=(-999)
21477      ILOC4=(-999)
21478      ILOC5=(-999)
21479      ILOC2P=(-999)
21480      ILOC3P=(-999)
21481      ILOC4P=(-999)
21482      ILOC5P=(-999)
21483C
21484      IWORD1='    '
21485      IWORD2='    '
21486      IWORD3='    '
21487      IWORD4='    '
21488      IWORD5='    '
21489      IWOR12='    '
21490      ICTEST='    '
21491      ICTES2='    '
21492      ILINE1='                              '
21493      ILINE2=' '
21494      IZ1='    '
21495      IZ2='    '
21496      IZ3='    '
21497      IZ4='    '
21498      IZ5='    '
21499      ISTRIN='                              '
21500      IFOUND='YES'
21501      IERROR='NO'
21502C
21503      CALL DPCONA(39,IQUOTE)
21504C
21505      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELW')THEN
21506        WRITE(ICOUT,999)
21507  999   FORMAT(1X)
21508        CALL DPWRST('XXX','BUG ')
21509        WRITE(ICOUT,51)
21510   51   FORMAT('***** AT THE BEGINNING OF DPHELW--')
21511        CALL DPWRST('XXX','BUG ')
21512        WRITE(ICOUT,53)IBUGS2,ISUBRO,IERROR,ICOM,IWIDTH
21513   53   FORMAT('IBUGS2,ISUBRO,IERROR,ICOM,IWIDTH = ',4(A4,2X),I8)
21514        CALL DPWRST('XXX','BUG ')
21515        WRITE(ICOUT,55)(IANS(I),I=1,IWIDTH)
21516   55   FORMAT('IANS(.) = ',120A1)
21517        CALL DPWRST('XXX','BUG ')
21518        WRITE(ICOUT,86)IBROWS(1:80)
21519   86   FORMAT('IBROWS = ',A80)
21520        CALL DPWRST('XXX','BUG ')
21521        WRITE(ICOUT,88)IDPURL(1:80)
21522   88   FORMAT('IDPURL = ',A80)
21523        CALL DPWRST('XXX','BUG ')
21524      ENDIF
21525C
21526      IF(ICOM.NE.'??  ')THEN
21527        ISHIFT=1
21528        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,
21529     1              NUMARG,IBUGS2,IERROR)
21530      ENDIF
21531C
21532CCCCC IF(
21533CCCCC1       (IHOST1.EQ.'SUN') .OR.
21534CCCCC1       (IHOST1.EQ.'CRAY' .AND. IOPSY1.EQ.'UNIX') .OR.
21535CCCCC1       (IHOST1.EQ.'CONV') .OR.
21536CCCCC1       (IHOST1.EQ.'SGI ') .OR.
21537CCCCC1       (IHOST1.EQ.'HP-9') .OR.
21538CCCCC1       (IHOST1.EQ.'AIX ') .OR.
21539CCCCC1       (IHOST1.EQ.'LINU') .OR.
21540CCCCC1       (IOPSY1.EQ.'UNIX'))GOTO199
21541CCCCC IF(IHOST1.EQ.'IBM-'.AND.ICOMPI.EQ.'MS-F')GOTO199
21542CC100 CONTINUE
21543CCCCC WRITE(ICOUT,999)
21544CCCCC CALL DPWRST('XXX','BUG ')
21545CCCCC WRITE(ICOUT,111)
21546CC111 FORMAT('***** FROM DPHELW--WEB HELP CURRENTLY ONLY SUPPORTED ',
21547CCCCC1'UNIX OR IBM-PC WINDOW 95/NT PLATFORMS.')
21548CC199 CONTINUE
21549C
21550C               *******************************************************
21551C               **  STEP 21--                                        **
21552C               **  COPY OVER THE FIRST 4 WORDS AFTER THE WORDS WEB  **
21553C               **  HELP                                             **
21554C               *******************************************************
21555C
21556      IPASS=0
21557C1000 CONTINUE
21558      IPASS=IPASS+1
21559C
21560      ISTEPN='21'
21561      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
21562     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21563C
21564      IF(IPASS.LE.1)THEN
21565         IWORD1=IHARG(1)
21566         IWOR12=IHARG2(1)
21567         IWORD2=IHARG(2)
21568         IWORD3=IHARG(3)
21569         IWORD4=IHARG(4)
21570         IWORD5=IHARG(5)
21571         NUMAR2=NUMARG
21572      ENDIF
21573C
21574      IF(NUMAR2.LE.0)THEN
21575         NUMAR2=1
21576         IWORD1='HOME'
21577         IWOR12='PAGE'
21578      ENDIF
21579C
21580      IF(IWORD1.EQ.'HOME'.AND.IWOR12.EQ.'PAGE')GOTO5099
21581C
21582C             ********************************************************
21583C             **  STEP 22--                                         **
21584C             **  STRIP OUT THE FIRST CHARACTER OF THE FIRST WORD.  **
21585C             ********************************************************
21586C
21587      ISTEPN='22'
21588      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELW')
21589     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21590C
21591      ICHAR1=IWORD1(1:1)
21592C
21593C               *******************************
21594C               **  STEP 32--                **
21595C               **  COPY OVER FILE VARIABLES **
21596C               *******************************
21597C
21598      ISTEPN='32'
21599      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
21600     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21601C
21602      IOUNIT=IHRMNU
21603      IFILE=IHRMNA
21604      ISTAT=IHRMST
21605      IFORM=IHRMFO
21606      IACCES=IHRMAC
21607      IPROT=IHRMPR
21608      ICURST=IHRMCS
21609      ISUBN0='HELW'
21610      IERRFI='NO'
21611C
21612      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELW')THEN
21613        WRITE(ICOUT,3293)IOUNIT
21614 3293   FORMAT('IOUNIT = ',I8)
21615        CALL DPWRST('XXX','BUG ')
21616        WRITE(ICOUT,3294)IFILE
21617 3294   FORMAT('IFILE = ',A80)
21618        CALL DPWRST('XXX','BUG ')
21619        WRITE(ICOUT,3295)ISTAT,IFORM,IACCES,IPROT,ICURST
21620 3295   FORMAT('ISTAT,IFORM,IACCES,IPROT,ICURST = ',
21621     1         4(A12,2X),A12)
21622        CALL DPWRST('XXX','BUG ')
21623        WRITE(ICOUT,3296)IBUGS2,ISUBRO,ISUBN0,IERRFI
21624 3296   FORMAT('IBUGS2,ISUBRO,ISUBN0,IERRFI = ',3(A4,2X),A4)
21625        CALL DPWRST('XXX','BUG ')
21626      ENDIF
21627C
21628C               ****************************************
21629C               **  STEP 33--                         **
21630C               **  CHECK TO SEE IF HELP FILE EXISTS  **
21631C               ****************************************
21632C
21633      ISTEPN='33'
21634      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELW')
21635     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21636C
21637      IF(ISTAT.NE.'NONE' .AND. ISTAT.NE.'OLD ')THEN
21638        WRITE(ICOUT,999)
21639        CALL DPWRST('XXX','BUG ')
21640        WRITE(ICOUT,3311)
21641 3311   FORMAT('***** ERROR IN WEB HELP--')
21642        CALL DPWRST('XXX','BUG ')
21643        WRITE(ICOUT,3312)
21644 3312   FORMAT('      THE DESIRED HELP INFORMATION CANNOT BE')
21645        CALL DPWRST('XXX','BUG ')
21646        WRITE(ICOUT,3314)
21647 3314   FORMAT('      GIVEN BECAUSE THE REQUIRED SYSTEM MASS STORAGE')
21648        CALL DPWRST('XXX','BUG ')
21649        WRITE(ICOUT,3315)
21650 3315   FORMAT('      FILE WHICH STORES SUCH HELP INFORMATION')
21651        CALL DPWRST('XXX','BUG ')
21652        WRITE(ICOUT,3316)
21653 3316   FORMAT('      IS NOT AVAILABLE AT THIS INSTALLATION.')
21654        CALL DPWRST('XXX','BUG ')
21655        WRITE(ICOUT,3317)ISTAT,IHRMST
21656 3317   FORMAT('ISTAT,IHELST = ',A12,2X,A12)
21657        CALL DPWRST('XXX','BUG ')
21658        WRITE(ICOUT,3318)IFILE(1:50)
21659 3318   FORMAT('IFILE(1:50) = ',A50)
21660        CALL DPWRST('XXX','BUG ')
21661        IERROR='YES'
21662        GOTO9000
21663      ENDIF
21664C
21665C               *********************
21666C               **  STEP 34--      **
21667C               **  OPEN THE FILE  **
21668C               *********************
21669C
21670      ISTEPN='34'
21671      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
21672     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21673C
21674      IREWIN='ON'
21675      CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
21676     1            IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
21677      IF(IERRFI.EQ.'YES')GOTO9000
21678C
21679C               ******************************************************
21680C               **  STEP 52.1--                                     **
21681C               **  LOOP THROUGH THE VARIOUS LINES OF THIS SECTION  **
21682C               **  OF THE FILE.                                    **
21683C               ******************************************************
21684C
21685 5099 CONTINUE
21686      ISTEPN='52.1'
21687      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HEL1')
21688     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21689C
21690      ICALL=' '
21691      NCSTR=0
21692      IFLAGE=0
21693C
21694      DO5100I=MAXBRO,1,-1
21695         NUMBRO=I
21696         IF(IBROWS(I:I).NE.' ')GOTO5109
21697 5100 CONTINUE
21698 5109 CONTINUE
21699C
21700      IF(NUMBRO.GE.4 .AND.
21701     1   (IBROWS(NUMBRO-4:NUMBRO-1).EQ.'EDGE' .OR.
21702     1    IBROWS(NUMBRO-4:NUMBRO-1).EQ.'edge'))THEN
21703        IFLAGE=1
21704        ICALL(1:21)='start microsoft-edge:'
21705        NCSTR=21
21706      ELSEIF(NUMBRO.GT.0)THEN
21707        ICALL(1:NUMBRO)=IBROWS(1:NUMBRO)
21708        NCSTR=NUMBRO+1
21709        ICALL(NCSTR:NCSTR)=' '
21710      ELSE
21711        IF(IHOST1.EQ.'IBM-'.AND.ICOMPI.EQ.'MS-F')THEN
21712          ICALL(1:1)='"'
21713          ICALL(2:NCPROF+1)=PROFIL(1:NCPROF)
21714          NCSTR=NCPROF+1
21715          ICALL(NCSTR+1:32)='\Internet Explorer\iexplore.exe '
21716          NCSTR=NCSTR+33
21717          ICALL(NCSTR:NCSTR)='"'
21718          NCSTR=NCSTR+1
21719          ICALL(NCSTR:NCSTR)=' '
21720        ELSEIF(IOPSY2.EQ.'MAC')THEN
21721          ICALL(1:5)='open '
21722          NCSTR=5
21723        ELSEIF(IOPSY1.EQ.'UNIX' .OR. IOPSY1.EQ.'LINU')THEN
21724          ICALL(1:9)='xdg-open '
21725          NCSTR=9
21726        ENDIF
21727      ENDIF
21728C
21729CCCCC IBRWFL='NETS'
21730CCCCC IF(NUMBRO.GE.8)THEN
21731CCCCC   DO5125I=1,NUMBRO-7
21732CCCCC     IF(IBROWS(I:I+7).EQ.'IEXPLORE' .OR.
21733CCCCC1       IBROWS(I:I+7).EQ.'iexplore')THEN
21734CCCCC        IBRWFL='IEXP'
21735CCCCC        GOTO5128
21736CCCCC     ENDIF
21737C5125   CONTINUE
21738C5128   CONTINUE
21739CCCCC ENDIF
21740C
21741      DO5110I=MAXURL,1,-1
21742         NUMURL=I
21743         IF(IDPURL(I:I).NE.' ')GOTO5119
21744 5110 CONTINUE
21745 5119 CONTINUE
21746C
21747C  IF "SET NETSCAPE OLD" COMMAND WAS ENTERED, THEN USE
21748C  -remote NETSCAPE OPTION.  THIS ONLY APPLIES TO UNIX PLATFORMS.
21749C
21750C  2015/11: COMMENT OUT THIS SECTION AS IT APPLIES TO AN OBSOLETE
21751C           BROWSER.
21752C
21753CCCCC IF(IHOST1.EQ.'IBM-')THEN
21754CCCCC   IF(IBRWFL.EQ.'NETS')THEN
21755CCCCC     NCSTR=NCSTR+1
21756CCCCC     NCSTR2=NCSTR+3
21757CCCCC     ICALL(NCSTR:NCSTR2)=' -h '
21758CCCCC     NCSTR=NCSTR2
21759CCCCC   ENDIF
21760CCCCC   GOTO5129
21761CCCCC ENDIF
21762CCCCC IF(INETSW.EQ.'OLD'.AND.IHOST1.NE.'IBM-')THEN
21763CCCCC   NCSTR=NCSTR+1
21764CCCCC   NCSTR2=NCSTR+8
21765CCCCC   ICALL(NCSTR:NCSTR2)=' -remote '
21766CCCCC   NCSTR=NCSTR2+1
21767CCCCC   ICALL(NCSTR:NCSTR)=IQUOTE
21768CCCCC   NCSTR=NCSTR+1
21769CCCCC   NCSTR2=NCSTR+7
21770CCCCC   ICALL(NCSTR:NCSTR2)='openURL('
21771CCCCC   NCSTR=NCSTR2
21772CCCCC ENDIF
21773C
21774C5129 CONTINUE
21775      IF(NUMURL.GT.0)THEN
21776        NCSTR=NCSTR+1
21777        NCSTR2=NCSTR+NUMURL-1
21778        ICALL(NCSTR:NCSTR2)=IDPURL(1:NUMURL)
21779        N1URL=NCSTR
21780        N2URL=NCSTR2
21781        NCSTR=NCSTR2
21782      ELSE
21783        NCSTR=NCSTR+1
21784        N1URL=NCSTR
21785        NCSTR2=NCSTR+7
21786        ICALL(NCSTR:NCSTR2)='https://'
21787        NCSTR=NCSTR2
21788        NCSTR=NCSTR+1
21789        NCSTR2=NCSTR+16
21790        ICALL(NCSTR:NCSTR2)='www.itl.nist.gov/'
21791        NCSTR=NCSTR2
21792        NCSTR=NCSTR+1
21793        NCSTR2=NCSTR+28
21794        ICALL(NCSTR:NCSTR2)='itl/div898/software/dataplot/'
21795        NCSTR=NCSTR2
21796        N2URL=NCSTR2
21797      ENDIF
21798C
21799      IF(IWORD1.EQ.'HOME'.AND.IWOR12.EQ.'PAGE')GOTO5300
21800      ISTEPN='52.2'
21801      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
21802     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21803C
21804      DO5200I=1,100000
21805        ILINE1=' '
21806        ILINE2=' '
21807        I2=I
21808C
21809C               *****************************************
21810C               **  STEP 52.2--                        **
21811C               **  READ IN SUCCEEDING LINES UNTIL     **
21812C               **  GET A HIT BASED ON THE FIRST WORD  **
21813C               **  OF THE COMMAND.                    **
21814C               *****************************************
21815C
21816CCCCC   ISTEPN='52.2'
21817CCCCC   IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
21818CCCCC1     CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21819C
21820        READ(IOUNIT,5202,END=5280)ILINE1,ILINE2
21821 5202   FORMAT(A40,A128)
21822        IF(ILINE1(1:4).EQ.'    ')GOTO5200
21823C
21824CCCCC   COMPARE CHAR. 1 TO 4 OF THE HELP FILE LINE
21825CCCCC   (ILINE1(1:4) AND ICTEST) WITH
21826CCCCC   CHAR. 1 TO 4 OF THE FIRST WORD OF THE HELP COMMAND EXT (IWORD1)
21827C
21828CCCCC   NOVEMBER 1997.  THIS SECTION REWRITTEN TO SIMPLIFY AND TO
21829CCCCC                   CHECK FOR NAME CONFLICTS (I.E., USE
21830CCCCC                   CHARACTERS 5-8 IF NEEDED).
21831C
21832        ICTEST=' '
21833        ICTES2=' '
21834        NBLANK=9
21835        DO5203II=1,8
21836          IF(ILINE1(II:II).EQ.' ')THEN
21837            NBLANK=II
21838            GOTO5204
21839          ENDIF
21840 5203   CONTINUE
21841 5204   CONTINUE
21842        IF(NBLANK.LE.5)THEN
21843          ICTEST(1:NBLANK-1)=ILINE1(1:NBLANK-1)
21844        ELSE
21845          ICTEST(1:4)=ILINE1(1:4)
21846          ICTES2(1:NBLANK-5)=ILINE1(5:NBLANK-1)
21847        ENDIF
21848C
21849        IF(ICTEST.NE.IWORD1.OR.ICTES2.NE.IWOR12)GOTO5200
21850C
21851        IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELW')THEN
21852          WRITE(ICOUT,999)
21853          CALL DPWRST('XXX','BUG ')
21854          WRITE(ICOUT,5207)I,ILINE1(1:40)
21855 5207     FORMAT('I,ILINE1(1:20)=',I8,2X,A40)
21856          CALL DPWRST('XXX','BUG ')
21857          WRITE(ICOUT,5208)NUMARG,NUMAR2,IWORD1,IWOR12,ICTEST,ICTES2
21858 5208     FORMAT('NUMARG,NUMAR2,IWORD1,IWOR12,ICTEST,ICTES2 = ',
21859     1           2I8,4(2X,A4))
21860          CALL DPWRST('XXX','BUG ')
21861        ENDIF
21862C
21863C               ***********************************************
21864C               **  STEP 52.3--                              **
21865C               **  IF GOT A HIT ON THE FIRST 4-CHAR. WORD,  **
21866C               **  CHECK FOR A HIT ON ALL 4-CHAR WORDS      **
21867C               ***********************************************
21868C
21869        ISTEPN='52.3'
21870        IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELW')
21871     1     CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21872C
21873        ISTRIN(1:40)=ILINE1(1:40)
21874C
21875        NUMWHF=1
21876        ILOC2=1
21877        ILOC3=1
21878        ILOC4=1
21879        ILOC5=1
21880        DO5220J=1,39
21881          JP1=J+1
21882          IF(ISTRIN(J:J).EQ.' '.AND.ISTRIN(JP1:JP1).NE.' ')THEN
21883            NUMWHF=NUMWHF+1
21884            IF(NUMWHF.EQ.2)ILOC2=JP1
21885            IF(NUMWHF.EQ.3)ILOC3=JP1
21886            IF(NUMWHF.EQ.4)ILOC4=JP1
21887            IF(NUMWHF.EQ.5)ILOC5=JP1
21888          ENDIF
21889 5220   CONTINUE
21890        ILOC2P=ILOC2+3
21891        ILOC3P=ILOC3+3
21892        ILOC4P=ILOC4+3
21893        ILOC5P=ILOC5+3
21894C
21895        IZ1=ILINE1(1:4)
21896        IZ2(1:4)='    '
21897        IF(NUMWHF.GE.2)IZ2(1:4)=ISTRIN(ILOC2:ILOC2P)
21898        IZ3(1:4)='    '
21899        IF(NUMWHF.GE.3)IZ3(1:4)=ISTRIN(ILOC3:ILOC3P)
21900        IZ4(1:4)='    '
21901        IF(NUMWHF.GE.4)IZ4(1:4)=ISTRIN(ILOC4:ILOC4P)
21902        IZ5(1:4)='    '
21903        IF(NUMWHF.GE.5)IZ5(1:4)=ISTRIN(ILOC5:ILOC5P)
21904C
21905        DO5225J=2,4
21906          IF(IZ1(J:J).EQ.' ')IZ1(J:4)=' '
21907          IF(IZ2(J:J).EQ.' ')IZ2(J:4)=' '
21908          IF(IZ3(J:J).EQ.' ')IZ3(J:4)=' '
21909          IF(IZ4(J:J).EQ.' ')IZ4(J:4)=' '
21910          IF(IZ5(J:J).EQ.' ')IZ5(J:4)=' '
21911 5225   CONTINUE
21912C
21913        IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELW')THEN
21914          WRITE(ICOUT,5231)
21915 5231     FORMAT('***** FROM 1731 IN MIDDLE OF DPHELW--')
21916          CALL DPWRST('XXX','BUG ')
21917          WRITE(ICOUT,5232)IWORD1,IWOR12,IWORD2,IWORD3,IWORD4,IWORD5
21918 5232     FORMAT('IWORD1,IWOR12,IWORD2,IWORD3,IWORD4,IWORD5 = ',
21919     1           5(A4,2X),A4)
21920          CALL DPWRST('XXX','BUG ')
21921          WRITE(ICOUT,5233)ILINE1(1:40)
21922 5233     FORMAT('ILINE1(1:40) = ',A40)
21923          CALL DPWRST('XXX','BUG ')
21924          WRITE(ICOUT,5234)IZ1,IZ2,IZ3,IZ4,IZ5
21925 5234     FORMAT('IZ1,IZ2,IZ3,IZ4,IZ5 = ',4(A4,2X),A4)
21926          CALL DPWRST('XXX','BUG ')
21927          WRITE(ICOUT,5235)ISTRIN
21928 5235     FORMAT('ISTRIN = ',A40)
21929          CALL DPWRST('XXX','BUG ')
21930          WRITE(ICOUT,5236)NUMARG,NUMAR2,NUMWHF
21931 5236     FORMAT('NUMARG,NUMAR2,NUMWHF = ',3I8)
21932          CALL DPWRST('XXX','BUG ')
21933          WRITE(ICOUT,5237)ILOC2,ILOC3,ILOC4,ILOC5
21934 5237     FORMAT('ILOC2,ILOC3,ILOC4,ILOC5 = ',4I8)
21935          CALL DPWRST('XXX','BUG ')
21936          WRITE(ICOUT,5238)ILOC2P,ILOC3P,ILOC4P,ILOC5P
21937 5238     FORMAT('ILOC2P,ILOC3P,ILOC4P,ILOC5P = ',4I8)
21938          CALL DPWRST('XXX','BUG ')
21939        ENDIF
21940C
21941CCCCC   THE FOLLOWING LINE WAS ADDED AUGUST 1994
21942        IF(NUMAR2.NE.NUMWHF)GOTO5200
21943C
21944        IF(NUMAR2.LE.1 .OR. NUMWHF.LE.1)GOTO5290
21945        IF(IZ2.EQ.IWORD2)GOTO5253
21946        GOTO5200
21947C
21948 5253   CONTINUE
21949        IF(NUMAR2.LE.2 .OR. NUMWHF.LE.2)GOTO5290
21950        IF(IZ3.EQ.IWORD3)GOTO5254
21951        GOTO5200
21952C
21953 5254   CONTINUE
21954        IF(NUMAR2.LE.3 .OR. NUMWHF.LE.3)GOTO5290
21955        IF(IZ4.EQ.IWORD4)THEN
21956          IF(NUMAR2.LE.3 .OR. NUMWHF.LE.3)GOTO5290
21957          IF(IZ5.EQ.IWORD5)GOTO5290
21958        ENDIF
21959C
21960 5200 CONTINUE
21961C
21962 5280 CONTINUE
21963      IERROR='YES'
21964      IF(IPASS.GE.2)THEN
21965        WRITE(ICOUT,999)
21966        CALL DPWRST('XXX','BUG ')
21967        WRITE(ICOUT,5281)
21968 5281   FORMAT('***** WEB HELP--')
21969        CALL DPWRST('XXX','BUG ')
21970        WRITE(ICOUT,5282)
21971 5282   FORMAT('      NO MATCH FOUND IN THE refman.tex FILE.')
21972        CALL DPWRST('XXX','BUG ')
21973        WRITE(ICOUT,5285)
21974 5285   FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
21975        CALL DPWRST('XXX','BUG ')
21976        WRITE(ICOUT,5286)(IANS(I),I=1,MIN(120,IWIDTH))
21977 5286   FORMAT('      ',120A1)
21978        CALL DPWRST('XXX','BUG ')
21979      ENDIF
21980      IENDFI='OFF'
21981      IREWIN='ON'
21982      CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
21983     1            IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERRO2)
21984      GOTO9000
21985C
21986 5290 CONTINUE
21987C
21988C               ****************************************************
21989C               **  STEP 53--                                     **
21990C               **  IF HAVE A HIT ON ALL WORDS,                   **
21991C               **  THEN USE DPSYS2 TO MAKE A SYSTEM CALL         **
21992C               **  TO INIATE NETSCAPE.                           **
21993C               **  CHECK IF URL BEGINS WITH http (A FEW SPECIAL  **
21994C               **  CASES GO TO NON-DATAPLOT WEB PAGE             **
21995C               ****************************************************
21996C
21997 5300 CONTINUE
21998      ISTEPN='53'
21999      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELW')
22000     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22001C
22002      IF(IWORD1.EQ.'HOME'.AND.IWOR12.EQ.'PAGE')THEN
22003        NCSTR=NCSTR+1
22004        NCSTR2=NCSTR+12
22005        ICALL(NCSTR:NCSTR2)='homepage.html'
22006        NCSTR=NCSTR2
22007        GOTO5349
22008      ENDIF
22009C
22010      DO5330J=128,1,-1
22011        NTEMP=J
22012        IF(ILINE2(J:J).NE.' ')GOTO5339
22013 5330 CONTINUE
22014 5339 CONTINUE
22015      IF(NTEMP.LE.0)THEN
22016        WRITE(ICOUT,999)
22017        CALL DPWRST('XXX','BUG ')
22018        WRITE(ICOUT,5351)
22019        CALL DPWRST('XXX','BUG ')
22020        ILINE2(1:13)='homepage.html'
22021        NTEMP=13
22022      ENDIF
22023 5351 FORMAT('***** WARNING: NO MATCH FOUND, DEFAULT TO DATAPLOT ',
22024     1'HOME PAGE.')
22025C
22026C  ABSOLUTE URL ADDRESS FOUND
22027C
22028      IF(ILINE2(1:5).EQ.'http:')THEN
22029        ICALL(N1URL:N2URL)=' '
22030        NCSTR=N1URL-1
22031      ELSEIF(ILINE2(1:6).EQ.'https:')THEN
22032        ICALL(N1URL:N2URL)=' '
22033        NCSTR=N1URL-1
22034      ELSEIF(ILINE2(1:7).EQ.'"https:')THEN
22035        ICALL(N1URL:N2URL)=' '
22036        NCSTR=N1URL-1
22037      ELSEIF(ILINE2(1:6).EQ.'"http:')THEN
22038        ICALL(N1URL:N2URL)=' '
22039        NCSTR=N1URL-1
22040      ENDIF
22041C
22042      NCSTR=NCSTR+1
22043      NCSTR2=NCSTR+NTEMP-1
22044      ICALL(NCSTR:NCSTR2)=ILINE2(1:NTEMP)
22045      NCSTR=NCSTR2
22046 5349 CONTINUE
22047CCCCC IF(INETSW.EQ.'OLD'.AND.IHOST1.NE.'IBM-')THEN
22048CCCCC   NCSTR=NCSTR+1
22049CCCCC   ICALL(NCSTR:NCSTR)=')'
22050CCCCC   NCSTR=NCSTR+1
22051CCCCC   ICALL(NCSTR:NCSTR)=IQUOTE
22052CCCCC ENDIF
22053      IF(IHOST1.NE.'IBM-')THEN
22054        NCSTR=NCSTR+1
22055        NCSTR2=NCSTR+1
22056        ICALL(NCSTR:NCSTR2)=' &'
22057        NCSTR=NCSTR2
22058      ENDIF
22059C
22060CCCCC IF(INETSW.EQ.'NEW')THEN
22061CCCCC   WRITE(ICOUT,999)
22062CCCCC   CALL DPWRST('XXX','BUG ')
22063CCCCC   WRITE(ICOUT,5411)
22064CCCCC   CALL DPWRST('XXX','BUG ')
22065CCCCC   WRITE(ICOUT,999)
22066CCCCC   CALL DPWRST('XXX','BUG ')
22067CCCCC   IF(IHOST1.NE.'IBM-')THEN
22068CCCCC     WRITE(ICOUT,5412)
22069CCCCC     CALL DPWRST('XXX','BUG ')
22070CCCCC     WRITE(ICOUT,5413)
22071CCCCC     CALL DPWRST('XXX','BUG ')
22072CCCCC     WRITE(ICOUT,5414)
22073CCCCC     CALL DPWRST('XXX','BUG ')
22074CCCCC     WRITE(ICOUT,999)
22075CCCCC     CALL DPWRST('XXX','BUG ')
22076CCCCC     WRITE(ICOUT,5415)
22077CCCCC     CALL DPWRST('XXX','BUG ')
22078CCCCC     WRITE(ICOUT,999)
22079CCCCC     CALL DPWRST('XXX','BUG ')
22080CCCCC   ENDIF
22081CCCCC ENDIF
22082C5411 FORMAT('*****NOTE: IT MAY TAKE THE BROWSER A FEW MOMENTS TO ',
22083CCCCC1      'START UP.')
22084C5412 FORMAT('     IF YOU ARE USING THE NETSCAPE BROWSER, YOU CAN ',
22085CCCCC1       'SPEED UP SUBSEQUENT')
22086C5413 FORMAT('     USE OF WEB HELP BY ENTERING THE FOLLOWING DATAPLOT',
22087CCCCC1       ' COMMAND')
22088C5414 FORMAT('     (LEAVE THE BROWSER OPEN):')
22089C5415 FORMAT('         SET NETSCAPE OLD')
22090CCCCC BUG ON RS-6000.  CLOSE FILE BEFORE CALL DPSYS2.  FEBRUARY 2000.
22091      IENDFI='OFF'
22092      IREWIN='ON'
22093      CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
22094     1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERRO2)
22095      ISSAV1=ISYSPE
22096      ISSAV2=ISYSHI
22097      ICLESV=ICLEWT
22098      ISYSPE='OFF'
22099      ISYSHI='ON'
22100      ICLEWT='OFF'
22101      CALL DPSYS2(ICALL,NCSTR,ISUBRO,IERROR)
22102      ISYSPE=ISSAV1
22103      ISYSHI=ISSAV2
22104      ICLEWT=ICLESV
22105      GOTO9000
22106C
22107C               ****************
22108C               **  STEP 90-- **
22109C               **  EXIT.     **
22110C               ****************
22111C
22112 9000 CONTINUE
22113      IF(IBUGS2.EQ.'ON' .OR. ISUBRO.EQ.'HELW')THEN
22114        WRITE(ICOUT,999)
22115        CALL DPWRST('XXX','BUG ')
22116        WRITE(ICOUT,9011)
22117 9011   FORMAT('***** AT THE END       OF DPHELW--')
22118        CALL DPWRST('XXX','BUG ')
22119        WRITE(ICOUT,9012)IBUGS2,ISUBRO,IERROR,IERRO2,IOUNIT
22120 9012   FORMAT('IBUGS2,ISUBRO,IERROR,IERRO2,IOUNIT = ',4(A4,2X),I5)
22121        CALL DPWRST('XXX','BUG ')
22122        WRITE(ICOUT,9032)IFILE
22123 9032   FORMAT('IFILE  = ',A80)
22124        CALL DPWRST('XXX','BUG ')
22125        WRITE(ICOUT,9033)ISTAT,IFORM,IACCES
22126 9033   FORMAT('ISTAT,IFORM,IACCES  = ',2(A12,2X)A12)
22127        CALL DPWRST('XXX','BUG ')
22128        WRITE(ICOUT,9036)IPROT,ICURST
22129 9036   FORMAT('IPROT,ICURST  = ',A12,2X,A12)
22130        CALL DPWRST('XXX','BUG ')
22131        WRITE(ICOUT,9038)IENDFI,IREWIN,ISUBN0,IERRFI
22132 9038   FORMAT('IENDFI,IREWIN,ISUBN0,IERRFI = ',3(A4,2X),A4)
22133        CALL DPWRST('XXX','BUG ')
22134        WRITE(ICOUT,9043)IWORD1,IWORD2,IWOR12,ICTEST,ICHAR1
22135 9043   FORMAT('IWORD1,IWORD2,IWOR12,ICTEST,ICHAR1 = ',4(A4,2X),A4)
22136        CALL DPWRST('XXX','BUG ')
22137        WRITE(ICOUT,9060)ILINE1(1:40)
22138 9060   FORMAT('ILINE1(1:40) =',A40)
22139        CALL DPWRST('XXX','BUG ')
22140        WRITE(ICOUT,9061)NUMSEC,NUMLIN,ISECNA,NUMARG,NUMAR2
22141 9061   FORMAT('NUMSEC,NUMLIN,ISECNA,NUMARG,NUMAR2 = ',5I8)
22142        CALL DPWRST('XXX','BUG ')
22143        WRITE(ICOUT,9063)IWORD3,IWORD4,IWORD5
22144 9063   FORMAT('IWORD3,IWORD4,IWORD5 = ',2(A4,2X),A4)
22145        CALL DPWRST('XXX','BUG ')
22146        WRITE(ICOUT,9065)IZ1,IZ2,IZ3,IZ4
22147 9065   FORMAT('IZ1,IZ2,IZ3,IZ4 = ',3(A4,2X),A4)
22148        CALL DPWRST('XXX','BUG ')
22149        WRITE(ICOUT,9066)ISTRIN
22150 9066   FORMAT('ISTRIN = ',A40)
22151        CALL DPWRST('XXX','BUG ')
22152        WRITE(ICOUT,9068)NUMWHF,ILOC2,ILOC3,ILOC4
22153 9068   FORMAT('NUMWHF,ILOC2,ILOC3,ILOC4 = ',4I8)
22154        CALL DPWRST('XXX','BUG ')
22155        WRITE(ICOUT,9069)ILOC2P,ILOC3P,ILOC4P,I2,IPASS
22156 9069   FORMAT('ILOC2P,ILOC3P,ILOC4P,I2 = ',5I6)
22157        CALL DPWRST('XXX','BUG ')
22158        WRITE(ICOUT,9071)ICHAR1
22159 9071   FORMAT('ICHAR1 = ',A1)
22160        CALL DPWRST('XXX','BUG ')
22161        WRITE(ICOUT,9099)ICALL(1:80)
22162 9099   FORMAT('ICALL(1:80) = ',A80)
22163        CALL DPWRST('XXX','BUG ')
22164        WRITE(ICOUT,9101)ICALL(81:160)
22165 9101   FORMAT('ICALL(81:160) = ',A80)
22166        CALL DPWRST('XXX','BUG ')
22167        WRITE(ICOUT,9103)ICALL(161:240)
22168 9103   FORMAT('ICALL(161:240) = ',A80)
22169        CALL DPWRST('XXX','BUG ')
22170      ENDIF
22171C
22172      RETURN
22173      END
22174      SUBROUTINE DPHEL1(ICOM,ICOM2,ICOMT,ICOMI,
22175     1                  IHARG,IHARG2,IARGT,IARG,NUMARG,
22176     1                  IHELSW,
22177     1                  IHE1CO,IHE1AL,
22178     1                  IHE2CO,IHE2AL,
22179     1                  IHE3CO,IHE3AL,
22180     1                  IHE4CO,IHE4AL,
22181     1                  IHE5CO,IHE5AL,
22182     1                  IHE6CO,IHE6AL,
22183     1                  IHE7CO,IHE7AL,
22184     1                  IHE8CO,IHE8AL,
22185     1                  IHE9CO,IHE9AL,
22186     1                  IHELCO,IHELAL,
22187     1                  IHELMX,
22188     1                  ICPREH,NCPREH,ICPOSH,NCPOSH,
22189     1                  IANS,IWIDTH,IBUGHE,IBUGH2,
22190     1                  ISUBRO,IFOUND,IERROR)
22191C
22192C     PURPOSE--DETERMINE IF DATAPLOT'S HELP   SYSTEM
22193C              COMMAND IS BEING INVOKED AND/OR
22194C              DETERMINE IF A USER'S MENU DESIGNATION IS VALID.
22195C              THIS SUBROUTINE IN TURN CALLS DPHEL2
22196C              WHICH READS THE DESIGNATED MENU
22197C              FROM (ONE OF) DATAPLOT'S HELP   SUB-SYSTEM FILE(S),
22198C              AND WRITES THE MENU OUT TO SCREEN.
22199C     INPUT  ARGUMENTS--ICOM ETC.
22200C     OUTPUT ARGUMENTS--IHELSW, IHELCO, AND IHELAL
22201C     WRITTEN BY--JAMES J. FILLIBEN
22202C                 STATISTICAL ENGINEERING DIVISION
22203C                 INFORMATION TECHNOLOGY LABORATORY
22204C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
22205C                 GAITHERSBURG, MD 20899-8980
22206C                 PHONE--301-975-2855
22207C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
22208C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
22209C     LANGUAGE--ANSI FORTRAN (1977)
22210C     VERSION NUMBER--86/1
22211C     ORIGINAL VERSION--FEBRUARY  1985.
22212C     UPDATED         --JANUARY   1986.
22213C
22214C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
22215C
22216      CHARACTER*4 ICOM
22217      CHARACTER*4 ICOM2
22218      CHARACTER*4 ICOMT
22219C
22220      CHARACTER*4 IHARG
22221      CHARACTER*4 IHARG2
22222      CHARACTER*4 IARGT
22223C
22224      CHARACTER*4 IHELSW
22225C
22226      CHARACTER*12 IHE1CO
22227      CHARACTER*4 IHE1AL
22228C
22229      CHARACTER*12 IHE2CO
22230      CHARACTER*4 IHE2AL
22231C
22232      CHARACTER*12 IHE3CO
22233      CHARACTER*4 IHE3AL
22234C
22235      CHARACTER*12 IHE4CO
22236      CHARACTER*4 IHE4AL
22237C
22238      CHARACTER*12 IHE5CO
22239      CHARACTER*4 IHE5AL
22240C
22241      CHARACTER*12 IHE6CO
22242      CHARACTER*4 IHE6AL
22243C
22244      CHARACTER*12 IHE7CO
22245      CHARACTER*4 IHE7AL
22246C
22247      CHARACTER*12 IHE8CO
22248      CHARACTER*4 IHE8AL
22249C
22250      CHARACTER*12 IHE9CO
22251      CHARACTER*4 IHE9AL
22252C
22253      CHARACTER*12 IHELCO
22254      CHARACTER*4 IHELAL
22255C
22256      CHARACTER*40 ICPREH
22257      CHARACTER*40 ICPOSH
22258C
22259      CHARACTER*4 IANS
22260      CHARACTER*4 IBUGHE
22261      CHARACTER*4 IBUGH2
22262      CHARACTER*4 ISUBRO
22263      CHARACTER*4 IFOUND
22264      CHARACTER*4 IERROR
22265C
22266      CHARACTER*4 IH11
22267      CHARACTER*4 IH12
22268      CHARACTER*4 IH21
22269      CHARACTER*4 IH22
22270C
22271      CHARACTER*4 IFOSEC
22272      CHARACTER*4 IHELSV
22273C
22274      CHARACTER*4 ISUBN1
22275      CHARACTER*4 ISUBN2
22276      CHARACTER*4 ISTEPN
22277C
22278      DIMENSION IHARG(*)
22279      DIMENSION IHARG2(*)
22280      DIMENSION IARGT(*)
22281      DIMENSION IARG(*)
22282C
22283      DIMENSION IANS(*)
22284C
22285C-----COMMON----------------------------------------------------------
22286C
22287CCCCC INCLUDE 'DPCOFO.INC'
22288      INCLUDE 'DPCONP.INC'
22289      INCLUDE 'DPCOP2.INC'
22290C
22291C-----START POINT-----------------------------------------------------
22292C
22293      ISUBN1='DPHE'
22294      ISUBN2='L1  '
22295      IFOUND='NO'
22296      IERROR='NO'
22297      IHELAL='OFF'
22298C
22299      MAXCPS=12
22300      I2=(-999)
22301C
22302      IF(IBUGHE.EQ.'ON' .OR. ISUBRO.EQ.'HEL1')THEN
22303        WRITE(ICOUT,999)
22304  999   FORMAT(1X)
22305        CALL DPWRST('XXX','BUG ')
22306        WRITE(ICOUT,51)
22307   51   FORMAT('***** AT THE BEGINNING OF DPHEL1--')
22308        CALL DPWRST('XXX','BUG ')
22309        WRITE(ICOUT,52)ICOM2,IHELSW,IHELMX,NCPREH,NCPOSH
22310   52   FORMAT('ICOM2,IHELSW,IHELMX,NCPREH,NCPOSH = ',2(A4,2X),4I8)
22311        CALL DPWRST('XXX','BUG ')
22312        WRITE(ICOUT,61)IHE1CO,IHE1AL
22313   61   FORMAT('IHE1CO,IHE1AL = ',A12,2X,A4)
22314        CALL DPWRST('XXX','BUG ')
22315        WRITE(ICOUT,62)IHE2CO,IHE2AL
22316   62   FORMAT('IHE2CO,IHE2AL = ',A12,2X,A4)
22317        CALL DPWRST('XXX','BUG ')
22318        WRITE(ICOUT,63)IHE3CO,IHE3AL
22319   63   FORMAT('IHE3CO,IHE3AL = ',A12,2X,A4)
22320        CALL DPWRST('XXX','BUG ')
22321        WRITE(ICOUT,64)IHE4CO,IHE4AL
22322   64   FORMAT('IHE4CO,IHE4AL = ',A12,2X,A4)
22323        CALL DPWRST('XXX','BUG ')
22324        WRITE(ICOUT,65)IHE5CO,IHE5AL
22325   65   FORMAT('IHE5CO,IHE5AL = ',A12,2X,A4)
22326        CALL DPWRST('XXX','BUG ')
22327        WRITE(ICOUT,66)IHE6CO,IHE6AL
22328   66   FORMAT('IHE6CO,IHE6AL = ',A12,2X,A4)
22329        CALL DPWRST('XXX','BUG ')
22330        WRITE(ICOUT,67)IHE7CO,IHE7AL
22331   67   FORMAT('IHE7CO,IHE7AL = ',A12,2X,A4)
22332        CALL DPWRST('XXX','BUG ')
22333        WRITE(ICOUT,68)IHE8CO,IHE8AL
22334   68   FORMAT('IHE8CO,IHE8AL = ',A12,2X,A4)
22335        CALL DPWRST('XXX','BUG ')
22336        WRITE(ICOUT,69)IHE9CO,IHE9AL
22337   69   FORMAT('IHE9CO,IHE9AL = ',A12,2X,A4)
22338        CALL DPWRST('XXX','BUG ')
22339        WRITE(ICOUT,70)IHELCO,IHELAL
22340   70   FORMAT('IHELCO,IHELAL = ',A12,2X,A4)
22341        CALL DPWRST('XXX','BUG ')
22342        WRITE(ICOUT,71)IWIDTH
22343   71   FORMAT('IWIDTH = ',I8)
22344        CALL DPWRST('XXX','BUG ')
22345        WRITE(ICOUT,72)(IANS(I),I=1,MIN(IWIDTH,80))
22346   72   FORMAT('(IANS(I),I=1,80) = ',80A1)
22347        CALL DPWRST('XXX','BUG ')
22348        WRITE(ICOUT,73)IBUGHE,IBUGH2,IERROR
22349   73   FORMAT('IBUGHE,IBUGH2,IERROR = ',A4,2X,A4,2X,A4)
22350        CALL DPWRST('XXX','BUG ')
22351        IF(NCPREH.GE.1)THEN
22352          DO82I=1,NCPREH
22353            WRITE(ICOUT,83)I,ICPREH(I:I)
22354   83       FORMAT('I,ICPREH(I:I) = ',I8,2X,A1,4X)
22355            CALL DPWRST('XXX','BUG ')
22356   82     CONTINUE
22357        ENDIF
22358        IF(NCPOSH.GE.1)THEN
22359          DO87I=1,NCPOSH
22360            WRITE(ICOUT,88)I,ICPOSH(I:I)
22361   88       FORMAT('I,ICPOSH(I:I) = ',I8,2X,A1,4X)
22362            CALL DPWRST('XXX','BUG ')
22363   87     CONTINUE
22364        ENDIF
22365      ENDIF
22366C
22367C               ******************************************************
22368C               **  STEP 11--                                       **
22369C               **  DETERMINE IF HAVE AN HELP   COMMAND, OR IF HAVE **
22370C               **            A MENU RESPONSE NUMBER TO A MENU, OR  **
22371C               **            IF HAVE NEITHER.                      **
22372C               ******************************************************
22373C
22374      ISTEPN='11'
22375      IF(IBUGHE.EQ.'ON'.OR.ISUBRO.EQ.'HEL1')
22376     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22377C
22378      IF(ICOM.EQ.'HELQ')GOTO1200
22379      IF(ICOM.EQ.'.')GOTO9000
22380      IF(ICOM.EQ.' ')GOTO9000
22381CCCCC IF(NUMARG.LE.0.AND.ICOM.EQ.' ')GOTO2100
22382      IF(NUMARG.LE.0.AND.ICOMT.EQ.'NUMB'.AND.ICOMI.EQ.0)GOTO2300
22383      IF(NUMARG.LE.0.AND.ICOMT.EQ.'NUMB'.AND.ICOMI.GT.0)GOTO1500
22384      IF(NUMARG.LE.0.AND.ICOMT.EQ.'NUMB'.AND.ICOMI.LT.0)GOTO1600
22385      GOTO9000
22386C
22387C               ***************************************
22388C               **  STEP 12--                        **
22389C               **  TREAT THE CASE WHEN HAVE         **
22390C               **  AN EXPLICIT    HELP     COMMAND  **
22391C               ***************************************
22392C
22393 1200 CONTINUE
22394      ISTEPN='12'
22395      IF(IBUGHE.EQ.'ON'.OR.ISUBRO.EQ.'HEL1')
22396     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22397C
22398      IF(NUMARG.LE.0)GOTO2100
22399      IF(IHARG(1).EQ.'LAST')GOTO2100
22400      IF(IHARG(1).EQ.'?')GOTO2100
22401      IF(IHARG(1).EQ.'ALL')IHELAL='ON'
22402      IF(IHARG(1).EQ.'ALL')GOTO2100
22403C
22404      IF(IHARG(1).EQ.'UP')GOTO1300
22405      IF(IHARG(1).EQ.'PRIO')GOTO1300
22406      IF(IHARG(1).EQ.'PREV')GOTO1300
22407      IF(IHARG(1).EQ.'BEFO')GOTO1300
22408C
22409      GOTO1400
22410C
22411C               ****************************************
22412C               **  STEP 13  --                       **
22413C               **  TREAT THE    HELP   UP #    CASE  **
22414C               ****************************************
22415C
22416 1300 CONTINUE
22417      ISTEPN='13'
22418      IF(IBUGHE.EQ.'ON'.OR.ISUBRO.EQ.'HEL1')
22419     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22420C
22421      IF(IHELCO.EQ.'0           ')IHELSW='TOP'
22422      IF(IHELCO.EQ.'0           ')GOTO2100
22423      IF(IHELCO.EQ.'            ')IHELSW='TOP'
22424      IF(IHELCO.EQ.'            ')GOTO2100
22425C
22426      NLOOP=1
22427      IF(NUMARG.GE.2.AND.IARGT(2).EQ.'NUMB')NLOOP=IARG(2)
22428      IF(NLOOP.LE.1)NLOOP=1
22429C
22430      DO1310ILOOP=1,NLOOP
22431C
22432      DO1320I=1,MAXCPS
22433      IREV=MAXCPS-I+1
22434      IF(IHELCO(IREV:IREV).EQ.'.')GOTO1325
22435      IHELCO(IREV:IREV)=' '
22436 1320 CONTINUE
22437      GOTO1310
22438 1325 CONTINUE
22439      IHELCO(IREV:IREV)=' '
22440      GOTO1310
22441C
22442 1310 CONTINUE
22443      GOTO2100
22444C
22445C               *************************************
22446C               **  STEP 14--                      **
22447C               **  TREAT THE    HELP   #    CASE  **
22448C               *************************************
22449C
22450 1400 CONTINUE
22451      ISTEPN='14'
22452      IF(IBUGHE.EQ.'ON'.OR.ISUBRO.EQ.'HEL1')
22453     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22454C
22455      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'DATA')GOTO1490
22456      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'GRAP')GOTO1490
22457      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MATH')GOTO1490
22458      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'STAT')GOTO1490
22459      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'ENGI')GOTO1490
22460      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'BUSI')GOTO1490
22461      IF(NUMARG.LE.0)GOTO1490
22462C
22463      IH11=IHARG(1)
22464      IH12=IHARG2(1)
22465      IHELCO(1:4)=IH11(1:4)
22466      IHELCO(5:8)=IH12(1:4)
22467      IHELCO(9:12)='    '
22468C
22469 1490 CONTINUE
22470      GOTO2100
22471C
22472C               *****************************************
22473C               **  STEP 15--                          **
22474C               **  TREAT THE    #    CASE             **
22475C               **  (AS IN RESPONDING TO A MENU        **
22476C               **  BY SPECIFYING A MENU ITEM CHOICE)  **
22477C               *****************************************
22478C
22479 1500 CONTINUE
22480      ISTEPN='15'
22481      IF(IBUGHE.EQ.'ON'.OR.ISUBRO.EQ.'HEL1')
22482     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22483C
22484      IF(IHELSW.EQ.'TOP')IHELCO='0           '
22485      IF(IHELSW.EQ.'TOP')GOTO2100
22486C
22487      IF(IHELCO(1:1).EQ.'0')GOTO1510
22488      GOTO1520
22489C
22490 1510 CONTINUE
22491      I2=0
22492      GOTO1530
22493C
22494 1520 CONTINUE
22495      DO1525I=1,MAXCPS
22496      I2=I
22497      IF(IHELCO(I2:I2).EQ.' ')GOTO1526
22498 1525 CONTINUE
22499      GOTO1539
22500 1526 CONTINUE
22501      IHELCO(I2:I2)='.'
22502      GOTO1530
22503C
22504 1530 CONTINUE
22505      DO1535J=1,4
22506      I2=I2+1
22507      IF(I2.GT.MAXCPS)GOTO1539
22508      IHELCO(I2:I2)=ICOM(J:J)
22509 1535 CONTINUE
22510 1539 CONTINUE
22511      GOTO2100
22512C
22513C               *****************************************
22514C               **  STEP 16--                          **
22515C               **  TREAT THE   -#    CASE             **
22516C               **  (AS IN CALLING FOR PRIOR MENUS     **
22517C               *****************************************
22518C
22519 1600 CONTINUE
22520      ISTEPN='16'
22521      IF(IBUGHE.EQ.'ON'.OR.ISUBRO.EQ.'HEL1')
22522     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22523C
22524      IF(IHELCO.EQ.'0           ')IHELSW='TOP'
22525      IF(IHELCO.EQ.'0           ')GOTO2100
22526      IF(IHELCO.EQ.'            ')IHELSW='TOP'
22527      IF(IHELCO.EQ.'            ')GOTO2100
22528C
22529      NLOOP=1
22530      IF(ICOMT.EQ.'NUMB')NLOOP=(-ICOMI)
22531C
22532      IF(NLOOP.LE.0)GOTO1619
22533      DO1610ILOOP=1,NLOOP
22534C
22535      DO1620I=1,MAXCPS
22536      IREV=MAXCPS-I+1
22537      IF(IHELCO(IREV:IREV).EQ.'.')GOTO1621
22538      IHELCO(IREV:IREV)=' '
22539 1620 CONTINUE
22540      GOTO1610
22541 1621 CONTINUE
22542      IHELCO(IREV:IREV)=' '
22543      GOTO1610
22544C
22545 1610 CONTINUE
22546C
22547 1619 CONTINUE
22548      GOTO2100
22549C
22550C               *************************************************
22551C               **  STEP 17--                                  **
22552C               **  STRIP OFF TRAILING PERIOD (IF ONE EXISTS)  **
22553C               *************************************************
22554C
22555      ISTEPN='17'
22556      IF(IBUGHE.EQ.'ON'.OR.ISUBRO.EQ.'HEL1')
22557     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22558C
22559      DO1710I=1,MAXCPS
22560      IREV=MAXCPS-I+1
22561      IF(IHELCO(IREV:IREV).NE.' ')GOTO1711
22562 1710 CONTINUE
22563      GOTO1790
22564 1711 CONTINUE
22565      IF(IHELCO(IREV:IREV).EQ.'.')IHELCO(IREV:IREV)=' '
22566      GOTO1790
22567 1790 CONTINUE
22568C
22569C               *********************************************
22570C               **  STEP 21--                              **
22571C               **  BRANCH BETWEEN THE OVERALL MENU        **
22572C               **  OR THE GENERAL MENU WITHIN EACH AREA.  **
22573C               *********************************************
22574C
22575 2100 CONTINUE
22576      ISTEPN='21'
22577      IF(IBUGHE.EQ.'ON'.OR.ISUBRO.EQ.'HEL1')
22578     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22579C
22580      IFOUND='YES'
22581      IF(IHELCO.EQ.'            ')IHELCO='0           '
22582CCCCC IF(ICOM.EQ.'HELQ'.AND.NUMARG.LE.0)GOTO2200
22583      IF(ICOM.EQ.'HELQ'.AND.NUMARG.LE.0)GOTO2300
22584      IF(IHELSW.EQ.'TOP'.AND.NUMARG.LE.0.AND.
22585     1ICOM.EQ.' ')GOTO2200
22586      IF(IHELSW.EQ.'TOP'.AND.NUMARG.LE.0.AND.
22587     1ICOMT.EQ.'NUMB'.AND.ICOMI.LE.0)GOTO2200
22588      GOTO2300
22589C
22590C               **********************************************
22591C               **  STEP 22--                               **
22592C               **  WRITE (TO THE SCREEN) THE OVERALL MENU  **
22593C               **********************************************
22594C
22595 2200 CONTINUE
22596      ISTEPN='22'
22597      IF(IBUGHE.EQ.'ON'.OR.ISUBRO.EQ.'HEL1')
22598     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22599C
22600      IHELSW='TOP'
22601C
22602      WRITE(ICOUT,2211)IESCC,IFFC
22603 2211 FORMAT(2A1)
22604      CALL DPWRST('XXX','BUG ')
22605      WRITE(ICOUT,2212)IESCC
22606 2212 FORMAT(A1,'8')
22607      CALL DPWRST('XXX','BUG ')
22608C
22609      WRITE(ICOUT,2221)
22610 2221 FORMAT('Enter     HELP HELP       ')
22611      CALL DPWRST('XXX','BUG ')
22612      WRITE(ICOUT,2222)
22613 2222 FORMAT('for a brief description of DATAPLOT')
22614      CALL DPWRST('XXX','BUG ')
22615      WRITE(ICOUT,2223)
22616 2223 FORMAT('Help Subsystem scope and conventions.')
22617      CALL DPWRST('XXX','BUG ')
22618      WRITE(ICOUT,999)
22619      CALL DPWRST('XXX','BUG ')
22620      WRITE(ICOUT,999)
22621      CALL DPWRST('XXX','BUG ')
22622      WRITE(ICOUT,2230)
22623 2230 FORMAT('     GENERAL TOPIC AREAS')
22624      CALL DPWRST('XXX','BUG ')
22625      WRITE(ICOUT,999)
22626      CALL DPWRST('XXX','BUG ')
22627      WRITE(ICOUT,2231)
22628 2231 FORMAT('      1. Data Analysis (partially implemented)')
22629      CALL DPWRST('XXX','BUG ')
22630      WRITE(ICOUT,2232)
22631 2232 FORMAT('      2. Mathematics   (not yet   implemented)')
22632      CALL DPWRST('XXX','BUG ')
22633      WRITE(ICOUT,2233)
22634 2233 FORMAT('      3. Graphics      (not yet   implemented)')
22635      CALL DPWRST('XXX','BUG ')
22636      WRITE(ICOUT,2234)
22637 2234 FORMAT('      4. DATAPLOT      (not yet   implemented)')
22638      CALL DPWRST('XXX','BUG ')
22639      WRITE(ICOUT,999)
22640      CALL DPWRST('XXX','BUG ')
22641      WRITE(ICOUT,2241)
22642 2241 FORMAT('To select a menu item, enter 1 through 4.')
22643      CALL DPWRST('XXX','BUG ')
22644      WRITE(ICOUT,999)
22645      CALL DPWRST('XXX','BUG ')
22646      GOTO9000
22647C
22648C               ****************************************
22649C               **  STEP 23--                         **
22650C               **  READ THE HELP   FILE              **
22651C               **  AND WRITE (TO THE SCREEN) A MENU  **
22652C               ****************************************
22653C
22654 2300 CONTINUE
22655      ISTEPN='23'
22656      IF(IBUGHE.EQ.'ON'.OR.ISUBRO.EQ.'HEL1')
22657     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22658C
22659      IF(NUMARG.LE.0)GOTO2310
22660C
22661      IF(NUMARG.EQ.1.AND.IARGT(1).EQ.'NUMB')GOTO2320
22662      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'DATA')GOTO2331
22663      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'GRAP')GOTO2332
22664      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'MATH')GOTO2333
22665      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'STAT')GOTO2334
22666      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'ENGI')GOTO2335
22667      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'BUSI')GOTO2336
22668C
22669      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'DATA')GOTO2341
22670      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'GRAP')GOTO2342
22671      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MATH')GOTO2343
22672      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'STAT')GOTO2344
22673      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'ENGI')GOTO2345
22674      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'BUSI')GOTO2346
22675C
22676      GOTO2360
22677C
22678C     TREAT THE CASE    HELP
22679C     WITH NO ARGUMENTS
22680C
22681 2310 CONTINUE
22682      IHELSW='DATA'
22683      IF(NUMARG.EQ.0)IHELCO='TOPALL      '
22684      GOTO2400
22685C
22686C     TREAT THE CASE LIKE    HELP 4
22687C
22688 2320 CONTINUE
22689CCCCC IF(IHELSW.NE.'TOP')GOTO2360
22690      IF(IHELCO.NE.'TOP')GOTO2360
22691      IF(IARG(1).EQ.1)GOTO2331
22692      IF(IARG(1).EQ.2)GOTO2332
22693      IF(IARG(1).EQ.3)GOTO2333
22694      IF(IARG(1).EQ.4)GOTO2334
22695      IF(IARG(1).EQ.5)GOTO2335
22696      IF(IARG(1).EQ.6)GOTO2336
22697      GOTO2360
22698C
22699C     TREAT THE 6 CASES WHERE THERE IS ONLY 1 ARGUMENT
22700C     AND THAT ARGUMENT IS EXPLICTLY ONE OF THE 6--
22701C     DATA, GRAP, MATH, STAT, ENGI, BUSI
22702C     (E.G, HELP MATH, HELP ENGINEERING)
22703C
22704 2331 CONTINUE
22705      IHELSW='DATA'
22706      IHELCO='TOP         '
22707      GOTO2400
22708 2332 CONTINUE
22709      IHELSW='GRAP'
22710      IHELCO='TOP         '
22711      GOTO2400
22712 2333 CONTINUE
22713      IHELSW='MATH'
22714      IHELCO='TOP         '
22715      GOTO2400
22716 2334 CONTINUE
22717      IHELSW='STAT'
22718      IHELCO='TOP         '
22719      GOTO2400
22720 2335 CONTINUE
22721      IHELSW='ENGI'
22722      IHELCO='TOP         '
22723      GOTO2400
22724 2336 CONTINUE
22725      IHELSW='BUSI'
22726      IHELCO='TOP         '
22727      GOTO2400
22728C
22729C     TREAT THE 6 CASES WHERE THERE ARE 2 OR MORE ARGUMENT
22730C     AND THE FIRST ARGUMENT IS EXPLICTLY ONE OF THE 6--
22731C     DATA, GRAP, MATH, STAT, ENGI, BUSI
22732C     (E.G, HELP MATH GOODIES, HELP ENGINEERING TOPICS)
22733C
22734 2341 CONTINUE
22735      IHELSW='DATA'
22736      GOTO2349
22737 2342 CONTINUE
22738      IHELSW='GRAP'
22739      GOTO2349
22740 2343 CONTINUE
22741      IHELSW='MATH'
22742      GOTO2349
22743 2344 CONTINUE
22744      IHELSW='STAT'
22745      GOTO2349
22746 2345 CONTINUE
22747      IHELSW='ENGI'
22748      GOTO2349
22749 2346 CONTINUE
22750      IHELSW='BUSI'
22751      GOTO2349
22752 2349 CONTINUE
22753      IH21=IHARG(2)
22754      IH22=IHARG2(2)
22755      IHELCO(1:4)=IH21(1:4)
22756      IHELCO(5:8)=IH22(1:4)
22757      GOTO2400
22758C
22759 2360 CONTINUE
22760      IH11=IHARG(1)
22761      IH12=IHARG2(1)
22762      IHELCO(1:4)=IH11(1:4)
22763      IHELCO(5:8)=IH12(1:4)
22764      GOTO2400
22765C
22766 2400 CONTINUE
22767C
22768      CALL DPHEL2(IHELSW,
22769     1IHELCO,IHELAL,
22770     1IHELMX,
22771     1ICPREH,NCPREH,ICPOSH,NCPOSH,
22772     1IFOSEC,
22773     1IANS,IWIDTH,IBUGH2,ISUBRO,IFOUND,IERROR)
22774      IF(IFOSEC.EQ.'NO')GOTO2410
22775      IF(IHELSW.EQ.'DATA')IHE1CO=IHELCO
22776      IF(IHELSW.EQ.'MATH')IHE2CO=IHELCO
22777      IF(IHELSW.EQ.'GRAP')IHE3CO=IHELCO
22778      IF(IHELSW.EQ.'STAT')IHE4CO=IHELCO
22779      IF(IHELSW.EQ.'ENGI')IHE5CO=IHELCO
22780      IF(IHELSW.EQ.'BUSI')IHE6CO=IHELCO
22781      IF(IHELSW.EQ.'XXXX')IHE7CO=IHELCO
22782      IF(IHELSW.EQ.'XXXX')IHE8CO=IHELCO
22783      IF(IHELSW.EQ.'XXXX')IHE9CO=IHELCO
22784      GOTO9000
22785C
22786C     THE FOLLOWING SECTION IS EXECUTED ONLY IF
22787C     THE KEYWORD WAS NOT FOUND IN THE
22788C     CURRENT PRIMARY FILE.
22789C     IN SUCH CASE, LOOK IN OTHER FILES FOR
22790C     THE KEYWORD.
22791C
22792 2410 CONTINUE
22793      IHELSV=IHELSW
22794      DO2420I=1,6
22795      IF(I.EQ.1)IHELSW='DATA'
22796      IF(I.EQ.2)IHELSW='GRAP'
22797      IF(I.EQ.3)IHELSW='MATH'
22798      IF(I.EQ.4)IHELSW='STAT'
22799      IF(I.EQ.5)IHELSW='ENGI'
22800      IF(I.EQ.6)IHELSW='BUSI'
22801      CALL DPHEL2(IHELSW,
22802     1IHELCO,IHELAL,
22803     1IHELMX,
22804     1ICPREH,NCPREH,ICPOSH,NCPOSH,
22805     1IFOSEC,
22806     1IANS,IWIDTH,IBUGH2,ISUBRO,IFOUND,IERROR)
22807      IF(IFOSEC.EQ.'NO')GOTO2420
22808      IF(IHELSW.EQ.'DATA')IHE1CO=IHELCO
22809      IF(IHELSW.EQ.'MATH')IHE2CO=IHELCO
22810      IF(IHELSW.EQ.'GRAP')IHE3CO=IHELCO
22811      IF(IHELSW.EQ.'STAT')IHE4CO=IHELCO
22812      IF(IHELSW.EQ.'ENGI')IHE5CO=IHELCO
22813      IF(IHELSW.EQ.'BUSI')IHE6CO=IHELCO
22814      IF(IHELSW.EQ.'XXXX')IHE7CO=IHELCO
22815      IF(IHELSW.EQ.'XXXX')IHE8CO=IHELCO
22816      IF(IHELSW.EQ.'XXXX')IHE9CO=IHELCO
22817      GOTO9000
22818 2420 CONTINUE
22819      IHELSW=IHELSV
22820      IF(IHELSW.EQ.'DATA')IHE1CO=IHELCO
22821      IF(IHELSW.EQ.'MATH')IHE2CO=IHELCO
22822      IF(IHELSW.EQ.'GRAP')IHE3CO=IHELCO
22823      IF(IHELSW.EQ.'STAT')IHE4CO=IHELCO
22824      IF(IHELSW.EQ.'ENGI')IHE5CO=IHELCO
22825      IF(IHELSW.EQ.'BUSI')IHE6CO=IHELCO
22826      IF(IHELSW.EQ.'XXXX')IHE7CO=IHELCO
22827      IF(IHELSW.EQ.'XXXX')IHE8CO=IHELCO
22828      IF(IHELSW.EQ.'XXXX')IHE9CO=IHELCO
22829      WRITE(ICOUT,999)
22830      CALL DPWRST('XXX','BUG ')
22831      WRITE(ICOUT,2421)
22832 2421 FORMAT('***** ERROR IN DPHEL1--')
22833      CALL DPWRST('XXX','BUG ')
22834      WRITE(ICOUT,2422)IHELCO(1:4),IHELCO(5:8)
22835 2422 FORMAT('      NO HELP INFORMATION FOUND FOR ',A4,A4)
22836      CALL DPWRST('XXX','BUG ')
22837      WRITE(ICOUT,2423)
22838 2423 FORMAT('      ANYWHERE UNDER THE 6 HELP CATEGORIES.')
22839      CALL DPWRST('XXX','BUG ')
22840      IF(IHELSW.EQ.'TOP')WRITE(ICOUT,2430)
22841 2430 FORMAT('      CURRENT CATEGORY = ABOVE ALL 6')
22842      IF(IHELSW.EQ.'TOP')CALL DPWRST('XXX','BUG ')
22843      IF(IHELSW.EQ.'DATA')WRITE(ICOUT,2431)
22844 2431 FORMAT('      CURRENT CATEGORY = DATAPLOT')
22845      IF(IHELSW.EQ.'DATA')CALL DPWRST('XXX','BUG ')
22846      IF(IHELSW.EQ.'GRAP')WRITE(ICOUT,2432)
22847 2432 FORMAT('      CURRENT CATEGORY = GRAPHICS')
22848      IF(IHELSW.EQ.'GRAP')CALL DPWRST('XXX','BUG ')
22849      IF(IHELSW.EQ.'MATH')WRITE(ICOUT,2433)
22850 2433 FORMAT('      CURRENT CATEGORY = MATHEMATICS')
22851      IF(IHELSW.EQ.'MATH')CALL DPWRST('XXX','BUG ')
22852      IF(IHELSW.EQ.'STAT')WRITE(ICOUT,2434)
22853 2434 FORMAT('      CURRENT CATEGORY = STATISTICS/PROBABILITY')
22854      IF(IHELSW.EQ.'STAT')CALL DPWRST('XXX','BUG ')
22855      IF(IHELSW.EQ.'ENGI')WRITE(ICOUT,2435)
22856 2435 FORMAT('      CURRENT CATEGORY = ENGINEERING/SCIENCE')
22857      IF(IHELSW.EQ.'ENGI')CALL DPWRST('XXX','BUG ')
22858      IF(IHELSW.EQ.'BUSI')WRITE(ICOUT,2436)
22859 2436 FORMAT('      CURRENT CATEGORY = BUSINESS/ECONOMICS')
22860      IF(IHELSW.EQ.'BUSI')CALL DPWRST('XXX','BUG ')
22861      IERROR='YES'
22862      GOTO9000
22863C
22864C               ****************
22865C               **  STEP 90-- **
22866C               **  EXIT.     **
22867C               ****************
22868C
22869 9000 CONTINUE
22870      IF(IBUGHE.EQ.'OFF'.AND.ISUBRO.NE.'HEL1')GOTO9090
22871      WRITE(ICOUT,999)
22872      CALL DPWRST('XXX','BUG ')
22873      WRITE(ICOUT,9011)
22874 9011 FORMAT('***** AT THE END       OF DPHEL1--')
22875      CALL DPWRST('XXX','BUG ')
22876      WRITE(ICOUT,9012)IHELSW
22877 9012 FORMAT('IHELSW = ',A4)
22878      CALL DPWRST('XXX','BUG ')
22879      WRITE(ICOUT,9031)IHE1CO,IHE1AL
22880 9031 FORMAT('IHE1CO,IHE1AL = ',A12,2X,A4)
22881      CALL DPWRST('XXX','BUG ')
22882      WRITE(ICOUT,9032)IHE2CO,IHE2AL
22883 9032 FORMAT('IHE2CO,IHE2AL = ',A12,2X,A4)
22884      CALL DPWRST('XXX','BUG ')
22885      WRITE(ICOUT,9033)IHE3CO,IHE3AL
22886 9033 FORMAT('IHE3CO,IHE3AL = ',A12,2X,A4)
22887      CALL DPWRST('XXX','BUG ')
22888      WRITE(ICOUT,9034)IHE4CO,IHE4AL
22889 9034 FORMAT('IHE4CO,IHE4AL = ',A12,2X,A4)
22890      CALL DPWRST('XXX','BUG ')
22891      WRITE(ICOUT,9035)IHE5CO,IHE5AL
22892 9035 FORMAT('IHE5CO,IHE5AL = ',A12,2X,A4)
22893      CALL DPWRST('XXX','BUG ')
22894      WRITE(ICOUT,9036)IHE6CO,IHE6AL
22895 9036 FORMAT('IHE6CO,IHE6AL = ',A12,2X,A4)
22896      CALL DPWRST('XXX','BUG ')
22897      WRITE(ICOUT,9037)IHE7CO,IHE7AL
22898 9037 FORMAT('IHE7CO,IHE7AL = ',A12,2X,A4)
22899      CALL DPWRST('XXX','BUG ')
22900      WRITE(ICOUT,9038)IHE8CO,IHE8AL
22901 9038 FORMAT('IHE8CO,IHE8AL = ',A12,2X,A4)
22902      CALL DPWRST('XXX','BUG ')
22903      WRITE(ICOUT,9039)IHE9CO,IHE9AL
22904 9039 FORMAT('IHE9CO,IHE9AL = ',A12,2X,A4)
22905      CALL DPWRST('XXX','BUG ')
22906      WRITE(ICOUT,9040)IHELCO,IHELAL
22907 9040 FORMAT('IHELCO,IHELAL = ',A12,2X,A4)
22908      CALL DPWRST('XXX','BUG ')
22909      WRITE(ICOUT,9049)IBUGHE,IBUGH2,IFOUND,IERROR
22910 9049 FORMAT('IBUGHE,IBUGH2,IFOUND,IERROR = ',A4,2X,A4,2X,A4,2X,A4)
22911      CALL DPWRST('XXX','BUG ')
22912      WRITE(ICOUT,9054)IHELMX
22913 9054 FORMAT('IHELMX = ',I8)
22914      CALL DPWRST('XXX','BUG ')
22915      WRITE(ICOUT,9055)IFOSEC
22916 9055 FORMAT('IFOSEC = ',A4)
22917      CALL DPWRST('XXX','BUG ')
22918      WRITE(ICOUT,9081)NCPREH
22919 9081 FORMAT('NCPREH = ',I8)
22920      CALL DPWRST('XXX','BUG ')
22921      IF(NCPREH.LE.0)GOTO9084
22922      DO9082I=1,NCPREH
22923      WRITE(ICOUT,9083)I,ICPREH(I:I)
22924 9083 FORMAT('I,ICPREH(I:I) = ',I8,2X,A1,4X)
22925      CALL DPWRST('XXX','BUG ')
22926 9082 CONTINUE
22927 9084 CONTINUE
22928      WRITE(ICOUT,9086)NCPOSH
22929 9086 FORMAT('NCPOSH = ',I8)
22930      CALL DPWRST('XXX','BUG ')
22931      IF(NCPOSH.LE.0)GOTO9089
22932      DO9087I=1,NCPOSH
22933      WRITE(ICOUT,9088)I,ICPOSH(I:I)
22934 9088 FORMAT('I,ICPOSH(I:I) = ',I8,2X,A1,4X)
22935      CALL DPWRST('XXX','BUG ')
22936 9087 CONTINUE
22937 9089 CONTINUE
22938 9090 CONTINUE
22939C
22940      RETURN
22941      END
22942      SUBROUTINE DPHEL2(IHELSW,
22943     1                  IHELCO,IHELAL,
22944     1                  IHELMX,
22945     1                  ICPREH,NCPREH,ICPOSH,NCPOSH,
22946     1                  IFOSEC,
22947     1                  IANS,IWIDTH,IBUGH3,ISUBRO,IFOUND,IERROR)
22948C
22949C     PURPOSE--READ THE DESIGNATED SECTION
22950C              FROM (ONE OF) DATAPLOT'S HELP SUB-SYSTEM FILE(S),
22951C              AND WRITE THE SECTION CONTENTS OUT TO SCREEN.
22952C     INPUT  ARGUMENTS--IHELSW (A HOLLARITH VARIABLE
22953C                       IDENTIFYING WHICH SUB-SYSTEM.
22954C                     --IHELCO (A HOLLARITH VARIABLE
22955C                       CONTAINING A SECTION IDENTIFICATION STRING.
22956C                     --IHELAL (A HOLLARITH VARIABLE (ON/OFF)
22957C                       CONTAINING A SWITCH SETTING AS TO WHETHER
22958C                       ALL OF THE TOPIC SECTION SHOULD BE PRINTED OUT.
22959C     OUTPUT ARGUMENTS--IFOUND ('YES' OR 'NO' )
22960C                     --IERROR ('YES' OR 'NO' )
22961C     WRITTEN BY--JAMES J. FILLIBEN
22962C                 STATISTICAL ENGINEERING DIVISION
22963C                 INFORMATION TECHNOLOGY LABORATORY
22964C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
22965C                 GAITHERSBURG, MD 20899-8980
22966C                 PHONE--301-975-2855
22967C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
22968C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
22969C     LANGUAGE--ANSI FORTRAN (1977)
22970C     VERSION NUMBER--86/1
22971C     ORIGINAL VERSION--FEBRAURY  1985.
22972C     UPDATED         --JANUARY   1986.
22973C
22974C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
22975C
22976      CHARACTER*4 IHELSW
22977      CHARACTER*12 IHELCO
22978      CHARACTER*4 IHELAL
22979      CHARACTER*40 ICPREH
22980      CHARACTER*40 ICPOSH
22981C
22982      CHARACTER*4 IFOSEC
22983      CHARACTER*4 IANS
22984      CHARACTER*4 IBUGH3
22985      CHARACTER*4 ISUBRO
22986      CHARACTER*4 IFOUND
22987      CHARACTER*4 IERROR
22988C
22989      INCLUDE 'DPCOPA.INC'
22990C
22991CCCCC CHARACTER*80 IFILE
22992      CHARACTER (LEN=MAXFNC) :: IFILE
22993      CHARACTER*12 ISTAT
22994      CHARACTER*12 IFORM
22995      CHARACTER*12 IACCES
22996      CHARACTER*12 IPROT
22997      CHARACTER*12 ICURST
22998      CHARACTER*4 ISUBN0
22999      CHARACTER*4 IERRFI
23000      CHARACTER*4 IENDFI
23001      CHARACTER*4 IREWIN
23002C
23003      CHARACTER*12 ITABID
23004      CHARACTER*12 ITABII
23005C
23006      CHARACTER*80 ICTEXT
23007C
23008      CHARACTER*4 ISUBN1
23009      CHARACTER*4 ISUBN2
23010      CHARACTER*4 ISTEPN
23011      CHARACTER*4 ICRESP
23012C
23013      DIMENSION ITABID(500)
23014      DIMENSION ITABLN(500)
23015C
23016      DIMENSION IANS(*)
23017C
23018C-----COMMON----------------------------------------------------------
23019C
23020CCCCC INCLUDE 'DPCOFO.INC'
23021      INCLUDE 'DPCOF2.INC'
23022      INCLUDE 'DPCONP.INC'
23023CCCCC TEH FOLLOWING LINE WAS ADDED   JUNE 1993
23024      INCLUDE 'DPCODV.INC'
23025      INCLUDE 'DPCOP2.INC'
23026C
23027C-----START POINT-----------------------------------------------------
23028C
23029      IFOUND='YES'
23030      IERROR='NO'
23031      ISUBN1='DPHE'
23032      ISUBN2='L2  '
23033C
23034      NUMSEC=(-999)
23035      JSEC=(-999)
23036      ISKIP=(-999)
23037      ISTART=(-999)
23038      I2=(-999)
23039      ITABII='-99999999999'
23040C
23041      IFOSEC='-999'
23042      ICRESP='-999'
23043C
23044      IF(IBUGH3.EQ.'ON' .OR. ISUBRO.EQ.'HEL2')THEN
23045        WRITE(ICOUT,999)
23046  999   FORMAT(1X)
23047        CALL DPWRST('XXX','BUG ')
23048        WRITE(ICOUT,51)
23049   51   FORMAT('***** AT THE BEGINNING OF DPHEL2--')
23050        CALL DPWRST('XXX','BUG ')
23051        WRITE(ICOUT,53)IHELCO,IHELAL,IHELSW,IFOSEC
23052   53   FORMAT('IHELCO,IHELAL,IHELSW,IFOSEC = ',A12,3(2X,A4))
23053        CALL DPWRST('XXX','BUG ')
23054        WRITE(ICOUT,55)IBUGH3,ISUBRO,IERROR
23055   55   FORMAT('IBUGH3,ISUBRO,IERROR) = ',2(A4,2X),A4)
23056        CALL DPWRST('XXX','BUG ')
23057        WRITE(ICOUT,58)(IANS(I),I=1,MIN(80,IWIDTH))
23058   58   FORMAT(A80)
23059        CALL DPWRST('XXX','BUG ')
23060        WRITE(ICOUT,81)NCPREH,NCPOSH,IHELMX
23061   81   FORMAT('NCPREH,NCPOSH,IHELMX = ',3I8)
23062        CALL DPWRST('XXX','BUG ')
23063        IF(NCPREH.GE.1)THEN
23064          DO82I=1,NCPREH
23065            WRITE(ICOUT,83)I,ICPREH(I:I)
23066   83       FORMAT('I,ICPREH(I:I) = ',I8,2X,A1,4X)
23067            CALL DPWRST('XXX','BUG ')
23068   82     CONTINUE
23069        ENDIF
23070        IF(NCPOSH.GE.1)THEN
23071          DO87I=1,NCPOSH
23072           WRITE(ICOUT,88)I,ICPOSH(I:I)
23073   88      FORMAT('I,ICPOSH(I:I) = ',I8,2X,A1,4X)
23074           CALL DPWRST('XXX','BUG ')
23075   87     CONTINUE
23076        ENDIF
23077      ENDIF
23078C
23079C               **************************
23080C               **  STEP 11--           **
23081C               **  COPY OVER VARIABLES **
23082C               **************************
23083C
23084      ISTEPN='11'
23085      IF(IBUGH3.EQ.'ON'.OR.ISUBRO.EQ.'HEL2')
23086     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23087C
23088      IF(IHELSW.EQ.'TOP')GOTO1110
23089      IF(IHELSW.EQ.'DATA')GOTO1110
23090      IF(IHELSW.EQ.'GRAP')GOTO1120
23091      IF(IHELSW.EQ.'MATH')GOTO1130
23092      IF(IHELSW.EQ.'STAT')GOTO1140
23093      IF(IHELSW.EQ.'ENGI')GOTO1150
23094      IF(IHELSW.EQ.'BUSI')GOTO1160
23095      IF(IHELSW.EQ.'XXXX')GOTO1170
23096      IF(IHELSW.EQ.'XXXX')GOTO1180
23097      IF(IHELSW.EQ.'XXXX')GOTO1190
23098C
23099      WRITE(ICOUT,999)
23100      CALL DPWRST('XXX','BUG ')
23101      WRITE(ICOUT,1101)
23102 1101 FORMAT('***** INTERNAL ERROR IN DPHEL2 ',
23103     1'AT BRANCH POINT 1101--')
23104      CALL DPWRST('XXX','BUG ')
23105      WRITE(ICOUT,1102)
23106 1102 FORMAT('      IHELSW SHOULD BE ')
23107      CALL DPWRST('XXX','BUG ')
23108      WRITE(ICOUT,1103)
23109 1103 FORMAT('      DATA, GRAP, MATH, STAT, ENGI, OR BUSI, ')
23110      CALL DPWRST('XXX','BUG ')
23111      WRITE(ICOUT,1104)
23112 1104 FORMAT('      BUT IS NOT.')
23113      CALL DPWRST('XXX','BUG ')
23114      WRITE(ICOUT,1105)IHELSW
23115 1105 FORMAT('      IHELSW = ',A4)
23116      CALL DPWRST('XXX','BUG ')
23117      IERROR='YES'
23118      GOTO9000
23119C
23120 1110 CONTINUE
23121      IOUNIT=IHE1NU
23122      IFILE=IHE1NA
23123      ISTAT=IHE1ST
23124      IFORM=IHE1FO
23125      IACCES=IHE1AC
23126      IPROT=IHE1PR
23127      ICURST=IHE1CS
23128      ISUBN0='HEL2'
23129      IERRFI='NO'
23130      GOTO1191
23131C
23132 1120 CONTINUE
23133      IOUNIT=IHE2NU
23134      IFILE=IHE2NA
23135      ISTAT=IHE2ST
23136      IFORM=IHE2FO
23137      IACCES=IHE2AC
23138      IPROT=IHE2PR
23139      ICURST=IHE2CS
23140      ISUBN0='HEL2'
23141      IERRFI='NO'
23142      GOTO1191
23143C
23144 1130 CONTINUE
23145      IOUNIT=IHE3NU
23146      IFILE=IHE3NA
23147      ISTAT=IHE3ST
23148      IFORM=IHE3FO
23149      IACCES=IHE3AC
23150      IPROT=IHE3PR
23151      ICURST=IHE3CS
23152      ISUBN0='HEL2'
23153      IERRFI='NO'
23154      GOTO1191
23155C
23156 1140 CONTINUE
23157      IOUNIT=IHE4NU
23158      IFILE=IHE4NA
23159      ISTAT=IHE4ST
23160      IFORM=IHE4FO
23161      IACCES=IHE4AC
23162      IPROT=IHE4PR
23163      ICURST=IHE4CS
23164      ISUBN0='HEL2'
23165      IERRFI='NO'
23166      GOTO1191
23167C
23168 1150 CONTINUE
23169      IOUNIT=IHE5NU
23170      IFILE=IHE5NA
23171      ISTAT=IHE5ST
23172      IFORM=IHE5FO
23173      IACCES=IHE5AC
23174      IPROT=IHE5PR
23175      ICURST=IHE5CS
23176      ISUBN0='HEL2'
23177      IERRFI='NO'
23178      GOTO1191
23179C
23180 1160 CONTINUE
23181      IOUNIT=IHE6NU
23182      IFILE=IHE6NA
23183      ISTAT=IHE6ST
23184      IFORM=IHE6FO
23185      IACCES=IHE6AC
23186      IPROT=IHE6PR
23187      ICURST=IHE6CS
23188      ISUBN0='HEL2'
23189      IERRFI='NO'
23190      GOTO1191
23191C
23192 1170 CONTINUE
23193      IOUNIT=IHE7NU
23194      IFILE=IHE7NA
23195      ISTAT=IHE7ST
23196      IFORM=IHE7FO
23197      IACCES=IHE7AC
23198      IPROT=IHE7PR
23199      ICURST=IHE7CS
23200      ISUBN0='HEL2'
23201      IERRFI='NO'
23202      GOTO1191
23203C
23204 1180 CONTINUE
23205      IOUNIT=IHE8NU
23206      IFILE=IHE8NA
23207      ISTAT=IHE8ST
23208      IFORM=IHE8FO
23209      IACCES=IHE8AC
23210      IPROT=IHE8PR
23211      ICURST=IHE8CS
23212      ISUBN0='HEL2'
23213      IERRFI='NO'
23214      GOTO1191
23215C
23216 1190 CONTINUE
23217      IOUNIT=IHE9NU
23218      IFILE=IHE9NA
23219      ISTAT=IHE9ST
23220      IFORM=IHE9FO
23221      IACCES=IHE9AC
23222      IPROT=IHE9PR
23223      ICURST=IHE9CS
23224      ISUBN0='HEL2'
23225      IERRFI='NO'
23226      GOTO1191
23227C
23228 1191 CONTINUE
23229      IF(IBUGH3.EQ.'OFF'.AND.ISUBRO.NE.'HEL2')GOTO1199
23230      WRITE(ICOUT,1193)IOUNIT
23231 1193 FORMAT('IOUNIT = ',I8)
23232      CALL DPWRST('XXX','BUG ')
23233      WRITE(ICOUT,1194)IFILE
23234 1194 FORMAT('IFILE = ',A80)
23235      CALL DPWRST('XXX','BUG ')
23236      WRITE(ICOUT,1195)ISTAT,IFORM,IACCES,IPROT,ICURST
23237 1195 FORMAT('ISTAT,IFORM,IACCES,IPROT,ICURST = ',
23238     1A12,2X,A12,2X,A12,2X,A12,2X,A12)
23239      CALL DPWRST('XXX','BUG ')
23240      WRITE(ICOUT,1196)IBUGH3,ISUBRO,ISUBN0,IERRFI
23241 1196 FORMAT('IBUGH3,ISUBRO,ISUBN0,IERRFI = ',A4,2X,A4,2X,A4,2X,A4)
23242      CALL DPWRST('XXX','BUG ')
23243 1199 CONTINUE
23244C
23245C               ***********************************************
23246C               **  STEP 12--                                **
23247C               **  CHECK TO SEE IF THIS HELP   FILE EXISTS  **
23248C               ***********************************************
23249C
23250      ISTEPN='12'
23251      IF(IBUGH3.EQ.'ON'.OR.ISUBRO.EQ.'HEL2')
23252     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23253C
23254      IF(ISTAT.EQ.'NONE')GOTO1200
23255      GOTO1290
23256 1200 CONTINUE
23257      IERROR='YES'
23258      WRITE(ICOUT,999)
23259      CALL DPWRST('XXX','BUG ')
23260      WRITE(ICOUT,1211)
23261 1211 FORMAT('***** ERROR IN DPHEL2--')
23262      CALL DPWRST('XXX','BUG ')
23263      WRITE(ICOUT,1212)
23264 1212 FORMAT('      THE HELP SUB-SYSTEM')
23265      CALL DPWRST('XXX','BUG ')
23266      WRITE(ICOUT,1213)
23267 1213 FORMAT('      CANNOT BE ENTERED FOR THIS TOPIC BECAUSE')
23268      CALL DPWRST('XXX','BUG ')
23269      WRITE(ICOUT,1214)
23270 1214 FORMAT('      THE REQUIRED SYSTEM MASS STORAGE FILE')
23271      CALL DPWRST('XXX','BUG ')
23272      WRITE(ICOUT,1215)
23273 1215 FORMAT('      WHICH STORES HELP INFORMATION')
23274      CALL DPWRST('XXX','BUG ')
23275      WRITE(ICOUT,1216)
23276 1216 FORMAT('      IS NOT YET AVAILABLE FOR THIS TOPIC.')
23277      CALL DPWRST('XXX','BUG ')
23278      WRITE(ICOUT,1217)ISTAT,IHELSW
23279 1217 FORMAT('ISTAT,IHELSW = ',A12,2X,A12)
23280      CALL DPWRST('XXX','BUG ')
23281      GOTO9000
23282 1290 CONTINUE
23283C
23284C               *********************
23285C               **  STEP 20--      **
23286C               **  OPEN THE FILE  **
23287C               *********************
23288C
23289      ISTEPN='20'
23290      IF(IBUGH3.EQ.'ON'.OR.ISUBRO.EQ.'HEL2')
23291     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23292C
23293      IREWIN='ON'
23294      CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
23295     1IREWIN,ISUBN0,IERRFI,IBUGH3,ISUBRO,IERROR)
23296      IF(IERRFI.EQ.'YES')GOTO9000
23297C
23298C               ************************************************************
23299C               **  STEP 41--                                             **
23300C               **  READ IN FILE INFORMATION                              **
23301C               **  FROM THE BEGINNING LINES OF THE FILE.                 **
23302C               **  THESE LEAD LINES CONTAIN                              **
23303C               **  THE STARTING LINE NUMBER OF EACH SECTION              **
23304C               **  IN THE FILE (ATABLN)   (F10.0 FORMAT), AND            **
23305C               **  THE IDENTIFIER          FOR EACH SECTION              **
23306C               **  IN THE FILE (ITABID(.) (A12 FORMAT).                  **
23307C               ************************************************************
23308C
23309      READ(IOUNIT,4101,END=4110)
23310 4101 FORMAT()
23311      READ(IOUNIT,4101,END=4110)
23312      GOTO4119
23313 4110 CONTINUE
23314      WRITE(ICOUT,999)
23315      CALL DPWRST('XXX','BUG ')
23316      WRITE(ICOUT,4111)
23317 4111 FORMAT('***** INTERNAL ERROR IN DPHEL2 ',
23318     1'AT BRANCH POINT 4111--')
23319      CALL DPWRST('XXX','BUG ')
23320      WRITE(ICOUT,4112)
23321 4112 FORMAT('      AN UNEXPECTED END OF FILE WAS ENCOUNTERED')
23322      CALL DPWRST('XXX','BUG ')
23323      WRITE(ICOUT,4113)
23324 4113 FORMAT('      WHILE CARRYING OUT THE SKIP OF 2 LINES AT THE')
23325      CALL DPWRST('XXX','BUG ')
23326      WRITE(ICOUT,4114)
23327 4114 FORMAT('      BEGINNING OF ONE OF THE DATAPLOT HELP FILES.')
23328      CALL DPWRST('XXX','BUG ')
23329      WRITE(ICOUT,4115)IFILE
23330 4115 FORMAT('      IFILE = ',A80)
23331      CALL DPWRST('XXX','BUG ')
23332      IERROR='YES'
23333      GOTO9000
23334 4119 CONTINUE
23335C
23336      NUMSEC=0
23337      DO4120I=1,100000
23338        READ(IOUNIT,4121,END=4180)ATABLN,ITABID(I)
23339 4121   FORMAT(F10.0,A12)
23340        IF(ITABID(I).EQ.'            ')GOTO4129
23341        NUMSEC=NUMSEC+1
23342        ITABLN(I)=INT(ATABLN+0.5)
23343C
23344        IF(IBUGH3.EQ.'ON'.OR.ISUBRO.EQ.'HEL2')THEN
23345          WRITE(ICOUT,4122)I,ITABLN(I),ATABLN,ITABID(I)
23346 4122     FORMAT('I,ITABLN(I),ATABLN,ITABID(I) = ',2I8,G15.7,2X,A12)
23347          CALL DPWRST('XXX','BUG ')
23348        ENDIF
23349C
23350 4120 CONTINUE
23351 4129 CONTINUE
23352      ANUMSE=NUMSEC
23353      GOTO4190
23354C
23355 4180 CONTINUE
23356      WRITE(ICOUT,999)
23357      CALL DPWRST('XXX','BUG ')
23358      WRITE(ICOUT,4181)
23359 4181 FORMAT('***** INTERNAL ERROR IN DPHEL2 ',
23360     1'AT BRANCH POINT 4181--')
23361      CALL DPWRST('XXX','BUG ')
23362      WRITE(ICOUT,4182)
23363 4182 FORMAT('      AN UNEXPECTED END OF FILE WAS ENCOUNTERED')
23364      CALL DPWRST('XXX','BUG ')
23365      WRITE(ICOUT,4183)
23366 4183 FORMAT('      WHILE READING THE LOOK-UP TABLE')
23367      CALL DPWRST('XXX','BUG ')
23368      WRITE(ICOUT,4184)
23369 4184 FORMAT('      WITHIN ONE OF THE DATAPLOT HELP FILES.')
23370      CALL DPWRST('XXX','BUG ')
23371      WRITE(ICOUT,4185)IFILE
23372 4185 FORMAT('      IFILE = ',A80)
23373      CALL DPWRST('XXX','BUG ')
23374      IERROR='YES'
23375      GOTO9000
23376C
23377 4190 CONTINUE
23378C
23379C               *******************************************************
23380C               **  STEP 42--                                        **
23381C               **  BASED ON THE CODE STRING IN IHELCO               **
23382C               **  DO A TABLE LOOK-UP WHICH WILL SPECIFY            **
23383C               **  THE ABSOLUTE LINE NUMBER IN THE FILE             **
23384C               **  WHERE THE SECTION WITH THAT CODE WORD STARTS     **
23385C               *******************************************************
23386C
23387      ISTEPN='42'
23388      IF(IBUGH3.EQ.'ON'.OR.ISUBRO.EQ.'HEL2')
23389     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23390C
23391      DO4200I=1,NUMSEC
23392      I2=I
23393      ITABII=ITABID(I)
23394      IF(IHELCO(1:4).EQ.ITABII(1:4))GOTO4210
23395 4200 CONTINUE
23396CCCCC JSEC=1
23397      IFOSEC='NO'
23398      GOTO9000
23399 4210 CONTINUE
23400      IFOSEC='YES'
23401      JSEC=I2
23402C
23403      ISTART=ITABLN(JSEC)
23404C
23405      IF(IBUGH3.EQ.'OFF'.AND.ISUBRO.NE.'HEL2')GOTO4290
23406      WRITE(ICOUT,4211)
23407 4211 FORMAT('***** FROM 4211 IN MIDDLE OF DPHEL2--')
23408      CALL DPWRST('XXX','BUG ')
23409      WRITE(ICOUT,4213)JSEC,ISTART
23410 4213 FORMAT('JSEC,ISTART = ',2I8)
23411      CALL DPWRST('XXX','BUG ')
23412 4290 CONTINUE
23413C
23414C               *************************************************
23415C               **  STEP 43--                                  **
23416C               **  READ DOWN IN THE FILE TO                   **
23417C               **  THE LINE BEFORE WHERE THE SECTION STARTS   **
23418C               *************************************************
23419C
23420      ISTEPN='43'
23421      IF(IBUGH3.EQ.'ON'.OR.ISUBRO.EQ.'HEL2')
23422     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23423C
23424      REWIND(IOUNIT)
23425C
23426      ISKIP=ISTART-1
23427      IF(ISKIP.LE.0)GOTO4319
23428      DO4310I=1,ISKIP
23429      READ(IOUNIT,4315,END=4380)
23430 4315 FORMAT()
23431 4310 CONTINUE
23432 4319 CONTINUE
23433      GOTO4390
23434C
23435 4380 CONTINUE
23436      WRITE(ICOUT,999)
23437      CALL DPWRST('XXX','BUG ')
23438      WRITE(ICOUT,4381)
23439 4381 FORMAT('***** INTERNAL ERROR IN DPHEL2 ',
23440     1'AT BRANCH POINT 4381--')
23441      CALL DPWRST('XXX','BUG ')
23442      WRITE(ICOUT,4382)
23443 4382 FORMAT('      AN UNEXPECTED END OF FILE WAS ENCOUNTERED')
23444      CALL DPWRST('XXX','BUG ')
23445      WRITE(ICOUT,4383)
23446 4383 FORMAT('      WHILE CARRYING OUT SKIPS')
23447      CALL DPWRST('XXX','BUG ')
23448      WRITE(ICOUT,4384)
23449 4384 FORMAT('      WITHIN ONE OF THE DATAPLOT HELP FILES.')
23450      CALL DPWRST('XXX','BUG ')
23451      WRITE(ICOUT,4385)IFILE
23452 4385 FORMAT('      IFILE = ',A80)
23453      CALL DPWRST('XXX','BUG ')
23454      IERROR='YES'
23455      GOTO9000
23456C
23457 4390 CONTINUE
23458C
23459C               ***************************************************
23460C               **  STEP 45--                                    **
23461C               **  FOR THIS TARGET SECTION--                    **
23462C               **     1) SKIP OVER 2 HEADER LINES               **
23463C               **     2) READ IN (AND WRITE OUT) THE TEXT       **
23464C               **        FOR THE SECTION--                      **
23465C               **        (THIS IS WHAT THE ANALYST WILL SEE     **
23466C               **        ON THE SCREEN).                        **
23467C               **        THE LAST LINE OF THE TEXT IS           **
23468C               **        A LINE OF HYPHENS (THIS LINE IS        **
23469C               **        NOT PRINTED OUT).                      **
23470C               **     3) READ IN (AND STORE) THE NUMBER OF      **
23471C               **        MENU ITEMS THAT WERE OFFERED           **
23472C               **     4) READ IN (AND STORE) THE CODE WORD      **
23473C               **        (= SUBSEQUENT BRANCH POINT)            **
23474C               **        FOR EACH MENU ITEM                     **
23475C               ***************************************************
23476C
23477      ISTEPN='45'
23478      IF(IBUGH3.EQ.'ON'.OR.ISUBRO.EQ.'HEL2')
23479     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23480C
23481      READ(IOUNIT,4505,END=4580)
23482 4505 FORMAT()
23483      READ(IOUNIT,4505,END=4580)
23484C
23485CCCCC WRITE(ICOUT,4511)IESCC,IFFC
23486C4511 FORMAT(2A1)
23487CCCCC CALL DPWRST('XXX','BUG ')
23488CCCCC WRITE(ICOUT,4512)IESCC
23489C4512 FORMAT(A1,'8')
23490CCCCC CALL DPWRST('XXX','BUG ')
23491C
23492CCCCC WRITE(ICOUT,4513)IHELCO
23493C4513 FORMAT(58X,A12)
23494CCCCC CALL DPWRST('XXX','BUG ')
23495C
23496      NUMLPR=0
23497      IF(NCPREH.LE.0)GOTO4519
23498      WRITE(ICOUT,4511)(ICPREH(J:J),J=1,NCPREH)
23499 4511 FORMAT(80A1)
23500      CALL DPWRST('XXX','BUG ')
23501 4519 CONTINUE
23502C
23503      DO4520I=1,100000
23504C
23505      READ(IOUNIT,4521,END=4580)ICTEXT
23506 4521 FORMAT(A80)
23507CCCCC IF(ICTEXT(1:5).EQ.'SSSSS')GOTO4590   DECEMBER 1986
23508CCCCC IF(ICTEXT(1:5).EQ.'EEEEE')GOTO4590   DECEMBER 1986
23509      IF(ICTEXT(1:5).EQ.'-----')GOTO4590
23510      IF(ICTEXT(1:5).EQ.'.....')GOTO4590
23511C
23512      IF(NUMLPR.LT.IHELMX)GOTO4529
23513CCCCC THE FOLLOWING LINE WAS ADDED  JUNE 1993
23514      IF(TCMENU.EQ.'ON')GOTO4529
23515      WRITE(ICOUT,4522)
23516 4522 FORMAT('                                      MORE...')
23517      CALL DPWRST('XXX','BUG ')
23518      READ(IRD,4523)ICRESP
23519 4523 FORMAT(A4)
23520      IF(ICRESP.EQ.'STOP')GOTO4590
23521      IF(ICRESP.EQ.'stop')GOTO4590
23522      IF(ICRESP.EQ.'HALT')GOTO4590
23523      IF(ICRESP.EQ.'halt')GOTO4590
23524      IF(ICRESP.EQ.'EXIT')GOTO4590
23525      IF(ICRESP.EQ.'exit')GOTO4590
23526      IF(ICRESP.EQ.'END')GOTO4590
23527      IF(ICRESP.EQ.'end')GOTO4590
23528      IF(ICRESP.EQ.'QUIT')GOTO4590
23529      IF(ICRESP.EQ.'quit')GOTO4590
23530      IF(ICRESP.EQ.'BYE')GOTO4590
23531      IF(ICRESP.EQ.'bye')GOTO4590
23532      IF(ICRESP.EQ.'NO')GOTO4590
23533      IF(ICRESP.EQ.'no')GOTO4590
23534      NUMLPR=0
23535      IF(NCPREH.LE.0)GOTO4527
23536      WRITE(ICOUT,4526)(ICPREH(J:J),J=1,NCPREH)
23537 4526 FORMAT(80A1)
23538      CALL DPWRST('XXX','BUG ')
23539 4527 CONTINUE
23540 4529 CONTINUE
23541C
23542      DO4530J=1,80
23543      JREV=80-J+1
23544      IF(ICTEXT(JREV:JREV).NE.' ')GOTO4535
23545 4530 CONTINUE
23546      JREV=1
23547 4535 CONTINUE
23548      IF(JREV.LE.0)WRITE(ICOUT,999)
23549      IF(JREV.LE.0)CALL DPWRST('XXX','BUG ')
23550      IF(JREV.GE.1)WRITE(ICOUT,4536)(ICTEXT(K:K),K=1,JREV)
23551C4536 FORMAT(80A1)
23552      IF(JREV.GE.1)CALL DPWRST('XXX','BUG ')
23553 4536 FORMAT(1H ,80A1)
23554      NUMLPR=NUMLPR+1
23555C
23556 4520 CONTINUE
23557C
23558 4580 CONTINUE
23559      WRITE(ICOUT,999)
23560      CALL DPWRST('XXX','BUG ')
23561      WRITE(ICOUT,4581)
23562 4581 FORMAT('***** INTERNAL ERROR IN DPHEL2 ',
23563     1'AT BRANCH POINT 4581--')
23564      CALL DPWRST('XXX','BUG ')
23565      WRITE(ICOUT,4582)
23566 4582 FORMAT('      AN UNEXPECTED END OF FILE WAS ENCOUNTERED')
23567      CALL DPWRST('XXX','BUG ')
23568      WRITE(ICOUT,4583)
23569 4583 FORMAT('      WHILE READING WITHIN THE TARGET SECTION')
23570      CALL DPWRST('XXX','BUG ')
23571      WRITE(ICOUT,4584)
23572 4584 FORMAT('      WITHIN ONE OF THE DATAPLOT HELP FILES.')
23573      CALL DPWRST('XXX','BUG ')
23574      WRITE(ICOUT,4585)IFILE
23575 4585 FORMAT('      IFILE = ',A80)
23576      CALL DPWRST('XXX','BUG ')
23577      WRITE(ICOUT,4586)JSEC,ISTART
23578 4586 FORMAT('JSEC,ISTART = ',2I8)
23579      CALL DPWRST('XXX','BUG ')
23580      IERROR='YES'
23581      GOTO5000
23582C
23583 4590 CONTINUE
23584C
23585      IF(NCPOSH.LE.0)GOTO4599
23586      WRITE(ICOUT,4591)(ICPOSH(J:J),J=1,NCPOSH)
23587 4591 FORMAT(80A1)
23588      CALL DPWRST('XXX','BUG ')
23589 4599 CONTINUE
23590C
23591C               **************************************
23592C               **  STEP 50--                       **
23593C               **  CLOSE        THIS HELP   FILE.  **
23594C               **************************************
23595C
23596 5000 CONTINUE
23597C
23598      ISTEPN='50'
23599      IF(IBUGH3.EQ.'ON'.OR.ISUBRO.EQ.'HEL2')
23600     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23601C
23602      IENDFI='OFF'
23603      IREWIN='ON'
23604      CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
23605     1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGH3,ISUBRO,IERROR)
23606      IF(IERRFI.EQ.'YES')GOTO9000
23607C
23608C               ****************
23609C               **  STEP 90-- **
23610C               **  EXIT.     **
23611C               ****************
23612C
23613 9000 CONTINUE
23614      IF(IBUGH3.EQ.'OFF'.AND.ISUBRO.NE.'HEL2')GOTO9090
23615      WRITE(ICOUT,999)
23616      CALL DPWRST('XXX','BUG ')
23617      WRITE(ICOUT,9011)
23618 9011 FORMAT('***** AT THE END       OF DPHEL2--')
23619      CALL DPWRST('XXX','BUG ')
23620      WRITE(ICOUT,9012)IBUGH3,ISUBRO,IERROR
23621 9012 FORMAT('IBUGH3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
23622      CALL DPWRST('XXX','BUG ')
23623      WRITE(ICOUT,9013)IFOSEC
23624 9013 FORMAT('IFOSEC = ',A4)
23625      CALL DPWRST('XXX','BUG ')
23626      WRITE(ICOUT,9014)IHELMX,NUMLPR
23627 9014 FORMAT('IHELMX,NUMLPR = ',2I8)
23628      CALL DPWRST('XXX','BUG ')
23629      WRITE(ICOUT,9015)ICRESP
23630 9015 FORMAT('ICRESP = ',A4)
23631      CALL DPWRST('XXX','BUG ')
23632      WRITE(ICOUT,9021)IOUNIT
23633 9021 FORMAT('IOUNIT = ',I8)
23634      CALL DPWRST('XXX','BUG ')
23635      WRITE(ICOUT,9022)IFILE
23636 9022 FORMAT('IFILE  = ',A80)
23637      CALL DPWRST('XXX','BUG ')
23638      WRITE(ICOUT,9023)ISTAT
23639 9023 FORMAT('ISTAT  = ',A12)
23640      CALL DPWRST('XXX','BUG ')
23641      WRITE(ICOUT,9024)IFORM
23642 9024 FORMAT('IFORM  = ',A12)
23643      CALL DPWRST('XXX','BUG ')
23644      WRITE(ICOUT,9025)IACCES
23645 9025 FORMAT('IACCES = ',A12)
23646      CALL DPWRST('XXX','BUG ')
23647      WRITE(ICOUT,9026)IPROT
23648 9026 FORMAT('IPROT  = ',A12)
23649      CALL DPWRST('XXX','BUG ')
23650      WRITE(ICOUT,9027)ICURST
23651 9027 FORMAT('ICURST = ',A12)
23652      CALL DPWRST('XXX','BUG ')
23653      WRITE(ICOUT,9028)IENDFI
23654 9028 FORMAT('IENDFI = ',A4)
23655      CALL DPWRST('XXX','BUG ')
23656      WRITE(ICOUT,9029)IREWIN
23657 9029 FORMAT('IREWIN = ',A4)
23658      CALL DPWRST('XXX','BUG ')
23659      WRITE(ICOUT,9031)ISUBN0
23660 9031 FORMAT('ISUBN0 = ',A12)
23661      CALL DPWRST('XXX','BUG ')
23662      WRITE(ICOUT,9032)IERRFI
23663 9032 FORMAT('IERRFI = ',A12)
23664      CALL DPWRST('XXX','BUG ')
23665      WRITE(ICOUT,9051)ISKIP,ISTART,I2
23666 9051 FORMAT('ISKIP,ISTART,I2 = ',3I8)
23667      CALL DPWRST('XXX','BUG ')
23668      WRITE(ICOUT,9052)IHELSW
23669 9052 FORMAT('IHELSW = ',A4)
23670      CALL DPWRST('XXX','BUG ')
23671      WRITE(ICOUT,9054)IHELCO,IHELAL
23672 9054 FORMAT('IHELCO,IHELAL = ',A12,2X,A4)
23673      CALL DPWRST('XXX','BUG ')
23674      WRITE(ICOUT,9061)NUMSEC
23675 9061 FORMAT('NUMSEC = ',I8)
23676      CALL DPWRST('XXX','BUG ')
23677      WRITE(ICOUT,9062)JSEC,ITABLN(JSEC),ITABID(JSEC)
23678 9062 FORMAT('JSEC,ITABLN(JSEC),ITABID(JSEC) = ',2I8,2X,A12)
23679      CALL DPWRST('XXX','BUG ')
23680      WRITE(ICOUT,9063)ITABII
23681 9063 FORMAT('ITABII = ',A12)
23682      CALL DPWRST('XXX','BUG ')
23683      WRITE(ICOUT,9081)NCPREH
23684 9081 FORMAT('NCPREH = ',I8)
23685      CALL DPWRST('XXX','BUG ')
23686      IF(NCPREH.LE.0)GOTO9084
23687      DO9082I=1,NCPREH
23688      WRITE(ICOUT,9083)I,ICPREH(I:I)
23689 9083 FORMAT('I,ICPREH(I:I) = ',I8,2X,A1,4X)
23690      CALL DPWRST('XXX','BUG ')
23691 9082 CONTINUE
23692 9084 CONTINUE
23693      WRITE(ICOUT,9086)NCPOSH
23694 9086 FORMAT('NCPOSH = ',I8)
23695      CALL DPWRST('XXX','BUG ')
23696      IF(NCPOSH.LE.0)GOTO9089
23697      DO9087I=1,NCPOSH
23698      WRITE(ICOUT,9088)I,ICPOSH(I:I)
23699 9088 FORMAT('I,ICPOSH(I:I) = ',I8,2X,A1,4X)
23700      CALL DPWRST('XXX','BUG ')
23701 9087 CONTINUE
23702 9089 CONTINUE
23703 9090 CONTINUE
23704C
23705      RETURN
23706      END
23707      SUBROUTINE DPHEX2(X1,Y1,X2,Y2,
23708     1IFIG,
23709     1ILINPA,ILINCO,PLINTH,
23710     1AREGBA,
23711     1IREBLI,IREBCO,PREBTH,
23712     1IREFSW,IREFCO,
23713     1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
23714     1PTEXHE,PTEXWI,PTEXVG,PTEXHG)
23715C
23716C     PURPOSE--DRAW A HEXAGON
23717C              WITH ONE END OF THE DIAGONAL AT (X1,Y1)
23718C              AND THE OTHER END AT (X2,Y2).
23719C     WRITTEN BY--JAMES J. FILLIBEN
23720C                 STATISTICAL ENGINEERING DIVISION
23721C                 INFORMATION TECHNOLOGY LABORATORY
23722C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
23723C                 GAITHERSBURG, MD 20899-8980
23724C                 PHONE--301-975-2855
23725C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
23726C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
23727C     LANGUAGE--ANSI FORTRAN (1977)
23728C     VERSION NUMBER--82/7
23729C     ORIGINAL VERSION--APRIL     1981.
23730C     UPDATED         --MAY       1982.
23731C     UPDATED         --JANUARY   1989.  MODIFY CALLS TO DPDRPL (ALAN)
23732C     UPDATED         --JANUARY   1989.  MODIFY CALL  TO DPFIRE (ALAN)
23733C
23734C-----NON-COMMON VARIABLES-------------------------------------
23735C
23736      CHARACTER*4 IFIG
23737      CHARACTER*4 IPATT2
23738C
23739      CHARACTER*4 ILINPA
23740      CHARACTER*4 ILINCO
23741C
23742      CHARACTER*4 IREBLI
23743      CHARACTER*4 IREBCO
23744      CHARACTER*4 IREFSW
23745      CHARACTER*4 IREFCO
23746      CHARACTER*4 IREPTY
23747      CHARACTER*4 IREPLI
23748      CHARACTER*4 IREPCO
23749C
23750      CHARACTER*4 IPATT
23751      CHARACTER*4 ICOLF
23752      CHARACTER*4 ICOLP
23753      CHARACTER*4 ICOL
23754      CHARACTER*4 IFLAG
23755C
23756      DIMENSION PX(10)
23757      DIMENSION PY(10)
23758CCCCC DIMENSION PX3(10)
23759CCCCC DIMENSION PY3(10)
23760C
23761      DIMENSION ILINPA(*)
23762      DIMENSION ILINCO(*)
23763      DIMENSION PLINTH(*)
23764C
23765      DIMENSION AREGBA(*)
23766      DIMENSION IREBLI(*)
23767      DIMENSION IREBCO(*)
23768      DIMENSION PREBTH(*)
23769      DIMENSION IREFSW(*)
23770      DIMENSION IREFCO(*)
23771      DIMENSION IREPTY(*)
23772      DIMENSION IREPLI(*)
23773      DIMENSION IREPCO(*)
23774      DIMENSION PREPTH(*)
23775      DIMENSION PREPSP(*)
23776C
23777C-----COMMON----------------------------------------------------------
23778C
23779      INCLUDE 'DPCOGR.INC'
23780      INCLUDE 'DPCOBE.INC'
23781      INCLUDE 'DPCOP2.INC'
23782C
23783C-----START POINT-----------------------------------------------------
23784C
23785      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'HEX2')GOTO90
23786      WRITE(ICOUT,999)
23787  999 FORMAT(1X)
23788      CALL DPWRST('XXX','BUG ')
23789      WRITE(ICOUT,51)
23790   51 FORMAT('***** AT THE BEGINNING OF DPHEX2--')
23791      CALL DPWRST('XXX','BUG ')
23792      WRITE(ICOUT,53)X1,Y1
23793   53 FORMAT('X1,Y1 = ',2E15.7)
23794      CALL DPWRST('XXX','BUG ')
23795      WRITE(ICOUT,54)X2,Y2
23796   54 FORMAT('X2,Y2 = ',2E15.7)
23797      CALL DPWRST('XXX','BUG ')
23798      WRITE(ICOUT,59)IFIG
23799   59 FORMAT('IFIG = ',A4)
23800      CALL DPWRST('XXX','BUG ')
23801      WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1)
23802   61 FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',A4,2X,A4,E15.7)
23803      CALL DPWRST('XXX','BUG ')
23804      WRITE(ICOUT,62)AREGBA(1)
23805   62 FORMAT('AREGBA(1) = ',E15.7)
23806      CALL DPWRST('XXX','BUG ')
23807      WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1)
23808   63 FORMAT('IREBLI(1),IREBCO(1),PREBTH(1) = ',A4,2X,A4,E15.7)
23809      CALL DPWRST('XXX','BUG ')
23810      WRITE(ICOUT,64)IREFSW(1),IREFCO(1)
23811   64 FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4)
23812      CALL DPWRST('XXX','BUG ')
23813      WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1)
23814   65 FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ',
23815     1A4,2X,A4,2X,A4,2E15.7)
23816      CALL DPWRST('XXX','BUG ')
23817      WRITE(ICOUT,69)PTEXHE,PTEXWI
23818   69 FORMAT('PTEXHE,PTEXWI= ',2E15.7)
23819      CALL DPWRST('XXX','BUG ')
23820      WRITE(ICOUT,70)PTEXVG,PTEXHG
23821   70 FORMAT('PTEXVG,PTEXHG= ',2E15.6)
23822      CALL DPWRST('XXX','BUG ')
23823      WRITE(ICOUT,79)IBUGG4,ISUBG4,IERRG4
23824   79 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
23825      CALL DPWRST('XXX','BUG ')
23826   90 CONTINUE
23827C
23828C               *********************************
23829C               **  STEP 1--                   **
23830C               **  DETERMINE THE COORDINATES  **
23831C               **  FOR THE HEXAGON            **
23832C               *********************************
23833C
23834      DELX=X2-X1
23835      DELY=Y2-Y1
23836      LEN=INT(SQRT((X2-X1)**2+(Y2-Y1)**2) + 0.1)
23837      ALEN=LEN
23838      R=ALEN/2.0
23839      IF(ABS(DELX).GE.0.00001)THETA=ATAN(DELY/DELX)
23840      IF(ABS(DELX).LT.0.00001.AND.DELY.GE.0.0)THETA=3.1415926/2.0
23841      IF(ABS(DELX).LT.0.00001.AND.DELY.LT.0.0)THETA=-3.1415926/2.0
23842C
23843      K=0
23844C
23845      X=0.0
23846      Y=0.0
23847      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
23848      K=K+1
23849      PX(K)=XP
23850      PY(K)=YP
23851C
23852      DO3010I=181,541,60
23853      IREV=541-I+181
23854      PHI2=IREV-1
23855      PHI2=PHI2*(2.0*3.1415926)/360.0
23856      X=R*COS(PHI2)+R
23857      Y=R*SIN(PHI2)
23858      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
23859      K=K+1
23860      PX(K)=XP
23861      PY(K)=YP
23862 3010 CONTINUE
23863C
23864      NP=K
23865C
23866C               ***********************
23867C               **  STEP 2--         **
23868C               **  FILL THE FIGURE  **
23869C               **  (IF CALLED FOR)  **
23870C               ***********************
23871C
23872      IF(IREFSW(1).EQ.'OFF')GOTO2190
23873      IPATT=IREPTY(1)
23874      IPATT2='SOLI'
23875      PTHICK=PREPTH(1)
23876      PXGAP=PREPSP(1)
23877      PYGAP=PREPSP(1)
23878      ICOLF=IREFCO(1)
23879      ICOLP=IREPCO(1)
23880      CALL DPFIRE(PX,PY,NP,
23881     1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,IPATT2)
23882 2190 CONTINUE
23883C
23884C               ***************************
23885C               **  STEP 3--             **
23886C               **  DRAW OUT THE FIGURE  **
23887C               ***************************
23888C
23889      IPATT=ILINPA(1)
23890      PTHICK=PLINTH(1)
23891      ICOL=ILINCO(1)
23892      IFLAG='ON'
23893      CALL DPDRPL(PX,PY,NP,
23894     1            IFIG,IPATT,PTHICK,ICOL,
23895     1            JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
23896C
23897C               *****************
23898C               **  STEP 90--  **
23899C               **  EXIT       **
23900C               *****************
23901C
23902      IF(IBUGG4.EQ.'ON' .OR. ISUBG4.EQ.'HEX2')THEN
23903        WRITE(ICOUT,999)
23904        CALL DPWRST('XXX','BUG ')
23905        WRITE(ICOUT,9011)
23906 9011   FORMAT('***** AT THE END       OF DPHEX2--')
23907        CALL DPWRST('XXX','BUG ')
23908        DO9015I=1,NP
23909          WRITE(ICOUT,9016)I,PX(I),PY(I)
23910 9016     FORMAT('I,PX(I),PY(I) = ',I8,2G15.7)
23911          CALL DPWRST('XXX','BUG ')
23912 9015   CONTINUE
23913        WRITE(ICOUT,9039)IERRG4
23914 9039   FORMAT('IERRG4 = ',A4)
23915        CALL DPWRST('XXX','BUG ')
23916      ENDIF
23917C
23918      RETURN
23919      END
23920      SUBROUTINE DPHEXA(IHARG,IARGT,ARG,NUMARG,
23921     1                  PXSTAR,PYSTAR,PXEND,PYEND,
23922     1                  ILINPA,ILINCO,PLINTH,
23923     1                  AREGBA,IREBLI,IREBCO,PREBTH,
23924     1                  IREFSW,IREFCO,
23925     1                  IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
23926     1                  PTEXHE,PTEXWI,PTEXVG,PTEXHG,
23927     1                  IGRASW,IDIASW,
23928     1                  PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
23929     1                  PDIAHE,PDIAWI,PDIAVG,PDIAHG,
23930     1                  NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
23931     1                  IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
23932     1                  IDNVOF,IDNHOF,IDFONT,UNITSW,PDSCAL,
23933     1                  IBUGD2,IFOUND,IERROR)
23934C
23935C     PURPOSE--DRAW ONE OR MORE HEXAGONS (DEPENDING ON HOW MANY NUMBERS ARE
23936C              PROVIDED).  THE COORDINATES ARE IN STANDARDIZED UNITS
23937C              OF 0 TO 100.
23938C     NOTE--THE INPUT COORDINATES DEFINE THE OPPOSING DIAGONAL ENDS
23939C           OF THE HEXAGON.
23940C     NOTE-THE USUAL INPUT NUMBER OF COORDINATES IS 2
23941C          AND THEREFORE THE USUAL INPUT NUMBER OF NUMBERS IS 2*2 = 4.
23942C     NOTE--IF 2 NUMBERS ARE PROVIDED, THEN THE DRAWN HEXAGON WILL GO FROM THE
23943C           LAST CURSOR POSITION TO THE (X,Y) POINT (EITHER ABSOLUTE OR
23944C           RELATIVE) AS DEFINED BY THE 2 NUMBERS.
23945C     NOTE--IF 4 NUMBERS ARE PROVIDED, THEN THE DRAWN HEXAGON WILL GO FROM THE
23946C           ABSOLUTE (X,Y) POSITION AS DEFINED BY THE FIRST 2 NUMBERS TO THE
23947C           (X,Y) POINT (EITHER ABSOLUTE OR RELATIVE) AS DEFINED BY THE THIRD
23948C           AND FOURTH NUMBERS.
23949C     NOTE--IF 6 NUMBERS ARE PROVIDED, THEN THE DRAWN HEXAGON WILL GO FROM THE
23950C           (X,Y) POSITION AS RESULTING FROM THE THIRD AND FOURTH NUMBERS
23951C           TO THE (X,Y) POINT (EITHER ABSOLUTE OR RELATIVE) AS DEFINED BY THE
23952C           FIFTH AND SIXTH NUMBERS.
23953C     NOTE--AND SO FORTH FOR 8, 10, 12, ... NUMBERS.
23954C     INPUT  ARGUMENTS--IHARG
23955C                     --IARGT
23956C                     --ARG
23957C                     --NUMARG
23958C                     --PXSTAR
23959C                     --PYSTAR
23960C     OUTPUT ARGUMENTS--PXEND
23961C                     --PYEND
23962C                     --IFOUND ('YES' OR 'NO' )
23963C                     --IERROR ('YES' OR 'NO' )
23964C     WRITTEN BY--JAMES J. FILLIBEN
23965C                 STATISTICAL ENGINEERING DIVISION
23966C                 INFORMATION TECHNOLOGY LABORATORY
23967C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
23968C                 GAITHERSBURG, MD 20899-8980
23969C                 PHONE--301-975-2855
23970C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
23971C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
23972C     LANGUAGE--ANSI FORTRAN (1977)
23973C     VERSION NUMBER--82/7
23974C     ORIGINAL VERSION--APRIL     1981.
23975C     UPDATED         --MARCH     1982.
23976C     UPDATED         --MAY       1982.
23977C     UPDATED         --NOVEMBER  1982.
23978C     UPDATED         --JANUARY   1989. CALL LIST FOR OFFSET VAR (ALAN)
23979C     UPDATED         --MARCH     1997. SUPPORT FOR DEVICE FONT (ALAN)
23980C     UPDATED         --JULY      1997. SUPPORT FOR "DATA" UNITS (ALAN)
23981C     UPDATED         --DECEMBER  2018. CHECK FOR DISCRETE, NULL, OR
23982C                                       NONE DEVICE
23983C     UPDATED         --DECEMBER  2018. SUPPORT FOR "DEVICE ... SCALE"
23984C                                       COMMAND
23985C
23986C-----NON-COMMON VARIABLES-----------------------------------------
23987C
23988      CHARACTER*4 IHARG
23989      CHARACTER*4 IARGT
23990C
23991      CHARACTER*4 ILINPA
23992      CHARACTER*4 ILINCO
23993C
23994      CHARACTER*4 IREBLI
23995      CHARACTER*4 IREBCO
23996      CHARACTER*4 IREFSW
23997      CHARACTER*4 IREFCO
23998      CHARACTER*4 IREPTY
23999      CHARACTER*4 IREPLI
24000      CHARACTER*4 IREPCO
24001C
24002      CHARACTER*4 IGRASW
24003      CHARACTER*4 IDIASW
24004C
24005      CHARACTER*4 IDMANU
24006      CHARACTER*4 IDMODE
24007      CHARACTER*4 IDMOD2
24008      CHARACTER*4 IDMOD3
24009      CHARACTER*4 IDPOWE
24010      CHARACTER*4 IDCONT
24011      CHARACTER*4 IDCOLO
24012CCCCC ADD FOLLOWING LINE MARCH 1997.
24013      CHARACTER*4 IDFONT
24014CCCCC ADD FOLLOWING LINE JULY 1997.
24015      CHARACTER*4 UNITSW
24016C
24017      CHARACTER*4 IFOUND
24018      CHARACTER*4 IBUGD2
24019      CHARACTER*4 IERROR
24020      CHARACTER*4 ISUBRO
24021C
24022      CHARACTER*4 IFIG
24023      CHARACTER*4 IBELSW
24024      CHARACTER*4 IERASW
24025      CHARACTER*4 IBACCO
24026      CHARACTER*4 ICOPSW
24027      CHARACTER*4 ITYPEO
24028C
24029      DIMENSION IHARG(*)
24030      DIMENSION IARGT(*)
24031      DIMENSION ARG(*)
24032C
24033      DIMENSION ILINPA(*)
24034      DIMENSION ILINCO(*)
24035      DIMENSION PLINTH(*)
24036C
24037      DIMENSION AREGBA(*)
24038      DIMENSION IREBLI(*)
24039      DIMENSION IREBCO(*)
24040      DIMENSION PREBTH(*)
24041      DIMENSION IREFSW(*)
24042      DIMENSION IREFCO(*)
24043      DIMENSION IREPTY(*)
24044      DIMENSION IREPLI(*)
24045      DIMENSION IREPCO(*)
24046      DIMENSION PREPTH(*)
24047      DIMENSION PREPSP(*)
24048      DIMENSION PDSCAL(*)
24049C
24050      DIMENSION IDMANU(*)
24051      DIMENSION IDMODE(*)
24052      DIMENSION IDMOD2(*)
24053      DIMENSION IDMOD3(*)
24054      DIMENSION IDPOWE(*)
24055      DIMENSION IDCONT(*)
24056      DIMENSION IDCOLO(*)
24057CCCCC ADD FOLLOWING LINE MARCH 1997.
24058      DIMENSION IDFONT(*)
24059      DIMENSION IDNVPP(*)
24060      DIMENSION IDNHPP(*)
24061      DIMENSION IDUNIT(*)
24062C
24063      DIMENSION IDNVOF(*)
24064      DIMENSION IDNHOF(*)
24065C
24066C-----COMMON----------------------------------------------------------
24067C
24068      INCLUDE 'DPCOGR.INC'
24069      INCLUDE 'DPCOBE.INC'
24070      INCLUDE 'DPCOP2.INC'
24071C
24072C-----START POINT-----------------------------------------------------
24073C
24074      IFOUND='NO'
24075      IERROR='NO'
24076      IERRG4=IERROR
24077CCCCC IBUGG4=IBUGD2
24078CCCCC ISUBG4=ISUBRO
24079C
24080      ILOCFN=0
24081      NUMNUM=0
24082C
24083      X1=0.0
24084      Y1=0.0
24085      X2=0.0
24086      Y2=0.0
24087C
24088      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'HEXA')GOTO90
24089      WRITE(ICOUT,999)
24090  999 FORMAT(1X)
24091      CALL DPWRST('XXX','BUG ')
24092      WRITE(ICOUT,51)
24093   51 FORMAT('***** AT THE BEGINNING OF DPHEXA--')
24094      CALL DPWRST('XXX','BUG ')
24095      WRITE(ICOUT,53)NUMARG
24096   53 FORMAT('NUMARG = ',I8)
24097      CALL DPWRST('XXX','BUG ')
24098      DO55I=1,NUMARG
24099      WRITE(ICOUT,56)I,IHARG(I),IARGT(I),ARG(I)
24100   56 FORMAT('I,IHARG(I),IARGT(I),ARG(I) = ',I8,2X,A4,2X,A4,E15.7)
24101      CALL DPWRST('XXX','BUG ')
24102   55 CONTINUE
24103      WRITE(ICOUT,57)PXSTAR,PYSTAR
24104   57 FORMAT('PXSTAR,PYSTAR = ',2E15.7)
24105      CALL DPWRST('XXX','BUG ')
24106      WRITE(ICOUT,58)PXEND,PYEND
24107   58 FORMAT('PXEND,PYEND = ',2E15.7)
24108      CALL DPWRST('XXX','BUG ')
24109      WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1)
24110   61 FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',A4,2X,A4,E15.7)
24111      CALL DPWRST('XXX','BUG ')
24112      WRITE(ICOUT,62)AREGBA(1)
24113   62 FORMAT('AREGBA(1) = ',E15.7)
24114      CALL DPWRST('XXX','BUG ')
24115      WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1)
24116   63 FORMAT('IREBLI(1),IREBCO(1),PREBTH(1) = ',A4,2X,A4,E15.7)
24117      CALL DPWRST('XXX','BUG ')
24118      WRITE(ICOUT,64)IREFSW(1),IREFCO(1)
24119   64 FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4)
24120      CALL DPWRST('XXX','BUG ')
24121      WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1)
24122   65 FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ',
24123     1A4,2X,A4,2X,A4,2E15.7)
24124      CALL DPWRST('XXX','BUG ')
24125      WRITE(ICOUT,69)PTEXHE,PTEXWI
24126   69 FORMAT('PTEXHE,PTEXWI= ',2E15.7)
24127      CALL DPWRST('XXX','BUG ')
24128      WRITE(ICOUT,70)PTEXVG,PTEXHG
24129   70 FORMAT('PTEXVG,PTEXHG= ',2E15.6)
24130      CALL DPWRST('XXX','BUG ')
24131      WRITE(ICOUT,76)IGRASW,IDIASW
24132   76 FORMAT('IGRASW,IDIASW = ',A4,2X,A4)
24133      CALL DPWRST('XXX','BUG ')
24134      WRITE(ICOUT,77)PGRAXF,PGRAYF,PDIAXC,PDIAYC
24135   77 FORMAT('PGRAXF,PGRAYF,PDIAXC,PDIAYC = ',4E15.7)
24136      CALL DPWRST('XXX','BUG ')
24137      WRITE(ICOUT,78)PDIAHE,PDIAWI,PDIAVG,PDIAHG
24138   78 FORMAT('PDIAHE,PDIAWI,PDIAVG,PDIAHG = ',4E15.7)
24139      CALL DPWRST('XXX','BUG ')
24140      WRITE(ICOUT,80)NUMDEV
24141   80 FORMAT('NUMDEV= ',I8)
24142      CALL DPWRST('XXX','BUG ')
24143      DO81I=1,NUMDEV
24144      WRITE(ICOUT,82)IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I)
24145   82 FORMAT('IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I) = ',
24146     1A4,2X,A4,2X,A4,2X,A4)
24147      CALL DPWRST('XXX','BUG ')
24148      WRITE(ICOUT,83)IDPOWE(I),IDCONT(I),IDCOLO(I)
24149   83 FORMAT('IDPOWE(I),IDCONT(I),IDCOLO(I) = ',
24150     1A4,2X,A4,2X,A4)
24151      CALL DPWRST('XXX','BUG ')
24152      WRITE(ICOUT,84)IDNVPP(I),IDNHPP(I),IDUNIT(I)
24153   84 FORMAT('IDNVPP(I),IDNHPP(I),IDUNIT(I) = ',
24154     1I8,I8,I8)
24155      CALL DPWRST('XXX','BUG ')
24156   81 CONTINUE
24157      WRITE(ICOUT,87)IFOUND
24158   87 FORMAT('IFOUND= ',A4)
24159      CALL DPWRST('XXX','BUG ')
24160      WRITE(ICOUT,88)IBUGG4,ISUBG4,IERRG4
24161   88 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
24162      CALL DPWRST('XXX','BUG ')
24163      WRITE(ICOUT,89)IBUGD2,IERROR
24164   89 FORMAT('IBUGD2,IERROR= ',A4,2X,A4)
24165      CALL DPWRST('XXX','BUG ')
24166   90 CONTINUE
24167C
24168      IFIG='HEXA'
24169      NUMPT=2
24170      NUMPT2=2*NUMPT
24171C
24172C               ********************************
24173C               **  STEP 0--                  **
24174C               **  STEP THROUGH EACH DEVICE  **
24175C               ********************************
24176C
24177      IF(NUMDEV.LE.0)GOTO9000
24178      DO8000IDEVIC=1,NUMDEV
24179C
24180      IF(IDPOWE(IDEVIC).EQ.'OFF')GOTO8000
24181      IF(IDMANU(IDEVIC).EQ.'OFF')GOTO8000
24182      IF(IDMANU(IDEVIC).EQ.'NULL')GOTO8000
24183      IF(IDMANU(IDEVIC).EQ.'NONE')GOTO8000
24184      IF(IDMANU(IDEVIC).EQ.'DISC')GOTO8000
24185C
24186      IMANUF=IDMANU(IDEVIC)
24187      IMODEL=IDMODE(IDEVIC)
24188      IMODE2=IDMOD2(IDEVIC)
24189      IMODE3=IDMOD3(IDEVIC)
24190      IGCONT=IDCONT(IDEVIC)
24191      IGCOLO=IDCOLO(IDEVIC)
24192      IGFONT=IDFONT(IDEVIC)
24193      NUMVPP=IDNVPP(IDEVIC)
24194      NUMHPP=IDNHPP(IDEVIC)
24195      ANUMVP=NUMVPP
24196      ANUMHP=NUMHPP
24197      IOFFSV=IDNVOF(IDEVIC)
24198      IOFFSH=IDNHOF(IDEVIC)
24199      IGUNIT=IDUNIT(IDEVIC)
24200      PCHSCA=PDSCAL(IDEVIC)
24201C
24202C               ************************************
24203C               **  STEP 1--                      **
24204C               **  CARRY OUT OPENING OPERATIONS  **
24205C               **  ON THE GRAPHICS DEVICES       **
24206C               ************************************
24207C
24208      CALL DPOPDE
24209C
24210      IBELSW='OFF'
24211      NUMRIN=0
24212      IERASW='OFF'
24213      IBACCO='JUNK'
24214C
24215      CALL DPOPPL(IGRASW,
24216     1IBELSW,NUMRIN,IERASW,
24217     1IBACCO)
24218C
24219C               *****************************************
24220C               **  STEP 2--                           **
24221C               **  SEARCH FOR COMMAND SPECIFICATIONS  **
24222C               *****************************************
24223C
24224      IF(NUMARG.GE.2.AND.
24225     1IARGT(1).EQ.'NUMB'.AND.IARGT(2).EQ.'NUMB')
24226     1GOTO1111
24227      IF(NUMARG.GE.3.AND.IHARG(1).EQ.'ABSO'.AND.
24228     1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB')
24229     1GOTO1112
24230      IF(NUMARG.GE.3.AND.IHARG(1).EQ.'RELA'.AND.
24231     1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB')
24232     1GOTO1113
24233      GOTO1130
24234C
24235 1111 CONTINUE
24236      ITYPEO='ABSO'
24237      ILOCFN=1
24238      GOTO1119
24239C
24240 1112 CONTINUE
24241      ITYPEO='ABSO'
24242      ILOCFN=2
24243      GOTO1119
24244C
24245 1113 CONTINUE
24246      ITYPEO='RELA'
24247      ILOCFN=2
24248      GOTO1119
24249 1119 CONTINUE
24250C
24251      IF(ILOCFN.GT.NUMARG)GOTO1129
24252      DO1120I=ILOCFN,NUMARG
24253      IF(IARGT(I).EQ.'NUMB')GOTO1120
24254      GOTO1129
24255 1120 CONTINUE
24256      IFOUND='YES'
24257      GOTO1149
24258 1129 CONTINUE
24259      GOTO1130
24260C
24261 1130 CONTINUE
24262      IERRG4='YES'
24263      WRITE(ICOUT,1131)
24264 1131 FORMAT('***** ERROR IN DPHEXA--')
24265      CALL DPWRST('XXX','BUG ')
24266      WRITE(ICOUT,1132)
24267 1132 FORMAT('      ILLEGAL FORM FOR DRAW ',
24268     1'COMMAND.')
24269      CALL DPWRST('XXX','BUG ')
24270      WRITE(ICOUT,1134)
24271 1134 FORMAT('      TEST EXAMPLE TO DEMONSTRATE THE ',
24272     1'PROPER FORM--')
24273      CALL DPWRST('XXX','BUG ')
24274      WRITE(ICOUT,1135)
24275 1135 FORMAT('      SUPPOSE IT IS DESIRED TO DRAW A HEXAGON ')
24276      CALL DPWRST('XXX','BUG ')
24277      WRITE(ICOUT,1136)
24278 1136 FORMAT('      WITH ONE POINT AT THE POINT 20 20 ')
24279      CALL DPWRST('XXX','BUG ')
24280      WRITE(ICOUT,1137)
24281 1137 FORMAT('      AND WITH OPPOSITE POINT AT THE POINT 40 60')
24282      CALL DPWRST('XXX','BUG ')
24283      WRITE(ICOUT,1141)
24284 1141 FORMAT('      THEN THE ALLOWABLE FORMS ARE--')
24285      CALL DPWRST('XXX','BUG ')
24286      WRITE(ICOUT,1142)
24287 1142 FORMAT('      HEXAGON 20 20 40 60 ')
24288      CALL DPWRST('XXX','BUG ')
24289      WRITE(ICOUT,1143)
24290 1143 FORMAT('      HEXAGON ABSOLUTE 20 20 40 60 ')
24291      CALL DPWRST('XXX','BUG ')
24292      GOTO9000
24293 1149 CONTINUE
24294C
24295C               ****************************
24296C               **  STEP 3--              **
24297C               **  DRAW OUT THE LINE(S)  **
24298C               ****************************
24299C
24300      NUMNUM=NUMARG-ILOCFN+1
24301      IF(NUMNUM.LT.NUMPT2)GOTO1151
24302      GOTO1152
24303C
24304 1151 CONTINUE
24305      J=ILOCFN-1
24306      X1=PXSTAR
24307      Y1=PYSTAR
24308      GOTO1159
24309C
24310 1152 CONTINUE
24311      J=ILOCFN
24312      IF(J.GT.NUMARG)GOTO1190
24313      X1=ARG(J)
24314CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997
24315      IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X1,X1,IBUGD2,ISUBRO,IERROR)
24316      J=J+1
24317      IF(J.GT.NUMARG)GOTO1190
24318      Y1=ARG(J)
24319CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997
24320      IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y1,Y1,IBUGD2,ISUBRO,IERROR)
24321      GOTO1159
24322 1159 CONTINUE
24323C
24324 1160 CONTINUE
24325      J=J+1
24326      IF(J.GT.NUMARG)GOTO1190
24327      X2=ARG(J)
24328CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997
24329      IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X2,X2,IBUGD2,ISUBRO,IERROR)
24330      IF(ITYPEO.EQ.'RELA')X2=X1+X2
24331      J=J+1
24332      IF(J.GT.NUMARG)GOTO1190
24333      Y2=ARG(J)
24334CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997
24335      IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y2,Y2,IBUGD2,ISUBRO,IERROR)
24336      IF(ITYPEO.EQ.'RELA')Y2=Y1+Y2
24337C
24338      CALL DPHEX2(X1,Y1,X2,Y2,
24339     1            IFIG,
24340     1            ILINPA,ILINCO,PLINTH,
24341     1            AREGBA,
24342     1            IREBLI,IREBCO,PREBTH,
24343     1            IREFSW,IREFCO,
24344     1            IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
24345     1            PTEXHE,PTEXWI,PTEXVG,PTEXHG)
24346C
24347      X1=X2
24348      Y1=Y2
24349C
24350      GOTO1160
24351 1190 CONTINUE
24352C
24353      PXEND=X2
24354      PYEND=Y2
24355C
24356C               ************************************
24357C               **  STEP 4--                      **
24358C               **  CARRY OUT CLOSING OPERATIONS  **
24359C               **  ON THE GRAPHICS DEVICES       **
24360C               ************************************
24361C
24362      ICOPSW='OFF'
24363      NUMCOP=0
24364      CALL DPCLPL(ICOPSW,NUMCOP,
24365     1PGRAXF,PGRAYF,
24366     1IGRASW,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
24367     1PDIAHE,PDIAWI,PDIAVG,PDIAHG)
24368C
24369      CALL DPCLDE
24370C
24371 8000 CONTINUE
24372C
24373C               *****************
24374C               **  STEP 90--  **
24375C               **  EXIT       **
24376C               *****************
24377C
24378 9000 CONTINUE
24379      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'HEXA')GOTO9090
24380      WRITE(ICOUT,999)
24381      CALL DPWRST('XXX','BUG ')
24382      WRITE(ICOUT,9011)
24383 9011 FORMAT('***** AT THE END       OF DPHEXA--')
24384      CALL DPWRST('XXX','BUG ')
24385      WRITE(ICOUT,9012)ILOCFN,NUMNUM
24386 9012 FORMAT('ILOCFN,NUMNUM = ',2I8)
24387      CALL DPWRST('XXX','BUG ')
24388      WRITE(ICOUT,9013)X1,Y1,X2,Y2
24389 9013 FORMAT('X1,Y1,X2,Y2 = ',4E15.7)
24390      CALL DPWRST('XXX','BUG ')
24391      WRITE(ICOUT,9015)PXSTAR,PYSTAR
24392 9015 FORMAT('PXSTAR,PYSTAR = ',2E15.7)
24393      CALL DPWRST('XXX','BUG ')
24394      WRITE(ICOUT,9016)PXEND,PYEND
24395 9016 FORMAT('PXEND,PYEND = ',2E15.7)
24396      CALL DPWRST('XXX','BUG ')
24397      WRITE(ICOUT,9017)IFIG
24398 9017 FORMAT('IFIG = ',A4)
24399      CALL DPWRST('XXX','BUG ')
24400      WRITE(ICOUT,9027)IFOUND
24401 9027 FORMAT('IFOUND = ',A4)
24402      CALL DPWRST('XXX','BUG ')
24403      WRITE(ICOUT,9028)IBUGG4,ISUBG4,IERRG4
24404 9028 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4)
24405      CALL DPWRST('XXX','BUG ')
24406      WRITE(ICOUT,9029)IBUGD2,IERROR
24407 9029 FORMAT('IBUGD2,IERROR = ',A4,2X,A4)
24408      CALL DPWRST('XXX','BUG ')
24409 9090 CONTINUE
24410C
24411      RETURN
24412      END
24413      SUBROUTINE DPHGCI(MAXNXT,ICAPSW,IFORSW,
24414     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
24415C
24416C     PURPOSE--GENERATE CONFIDENCE LIMITS FOR THE HEDGE'S G STATISTIC
24417C     EXAMPLE--HEDGES G CONFIDENCE LIMTIS Y1 Y2
24418C     WRITTEN BY--ALAN HECKERT
24419C                 STATISTICAL ENGINEERING DIVISION
24420C                 INFORMATION TECHNOLOGY LABORATORY
24421C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
24422C                 GAITHERSBURG, MD 20899-8980
24423C                 PHONE--301-975-2899
24424C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
24425C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
24426C     LANGUAGE--ANSI FORTRAN (1977)
24427C     VERSION NUMBER--2018/08
24428C     ORIGINAL VERSION--AUGUST    2018.
24429C
24430C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
24431C
24432      CHARACTER*4 ICAPSW
24433      CHARACTER*4 IFORSW
24434      CHARACTER*4 IBUGA2
24435      CHARACTER*4 IBUGA3
24436      CHARACTER*4 IBUGQ
24437      CHARACTER*4 ISUBRO
24438      CHARACTER*4 IFOUND
24439      CHARACTER*4 IERROR
24440C
24441      CHARACTER*4 ISUBN1
24442      CHARACTER*4 ISUBN2
24443      CHARACTER*4 ISTEPN
24444      CHARACTER*4 ICASE
24445      CHARACTER*4 IVARID
24446      CHARACTER*4 IVARI2
24447      CHARACTER*4 IVARI3
24448      CHARACTER*4 IVARI4
24449      CHARACTER*40 INAME
24450      PARAMETER (MAXSPN=30)
24451      CHARACTER*4 IVARN1(MAXSPN)
24452      CHARACTER*4 IVARN2(MAXSPN)
24453      CHARACTER*4 IVARTY(MAXSPN)
24454      REAL PVAR(MAXSPN)
24455      INTEGER ILIS(MAXSPN)
24456      INTEGER NRIGHT(MAXSPN)
24457      INTEGER ICOLR(MAXSPN)
24458C
24459      CHARACTER*4 IFLAGU
24460      LOGICAL IFRST
24461      LOGICAL ILAST
24462C
24463C-----COMMON----------------------------------------------------------
24464C
24465      INCLUDE 'DPCOPA.INC'
24466      INCLUDE 'DPCOHK.INC'
24467      INCLUDE 'DPCOSU.INC'
24468      INCLUDE 'DPCODA.INC'
24469      INCLUDE 'DPCOST.INC'
24470      INCLUDE 'DPCOP2.INC'
24471C
24472C-----START POINT-----------------------------------------------------
24473C
24474      ISUBN1='DPHG'
24475      ISUBN2='CI  '
24476      IFOUND='YES'
24477      IERROR='NO'
24478C
24479      MAXCP1=MAXCOL+1
24480      MAXCP2=MAXCOL+2
24481      MAXCP3=MAXCOL+3
24482      MAXCP4=MAXCOL+4
24483      MAXCP5=MAXCOL+5
24484      MAXCP6=MAXCOL+6
24485C
24486C               *******************************************************
24487C               **  TREAT THE HEDGES G    CONFIDENCE LIMITS CASE     **
24488C               *******************************************************
24489C
24490      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'HGCI')THEN
24491        WRITE(ICOUT,999)
24492  999   FORMAT(1X)
24493        CALL DPWRST('XXX','BUG ')
24494        WRITE(ICOUT,51)
24495   51   FORMAT('***** AT THE BEGINNING OF DPHGCI--')
24496        CALL DPWRST('XXX','BUG ')
24497        WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ,ISUBRO,MAXNXT
24498   52   FORMAT('IBUGA2,IBUGA3,IBUGQ,ISUBRO,MAXNXT = ',4(A4,2X),I8)
24499        CALL DPWRST('XXX','BUG ')
24500      ENDIF
24501C
24502C               ****************************************
24503C               **  STEP 2--                          **
24504C               **  EXTRACT THE VARIABLE LIST         **
24505C               ****************************************
24506C
24507      ISTEPN='2'
24508      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'HGCI')
24509     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24510C
24511      INAME='HEDGES G CONFIDENCE LIMITS'
24512      MINNA=1
24513      MAXNA=100
24514      MINN2=4
24515      IFLAGE=0
24516      IFLAGM=1
24517      MINNVA=2
24518      MAXNVA=MAXSPN
24519      IFLAGP=0
24520      JMIN=1
24521      JMAX=NUMARG
24522C
24523      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
24524     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
24525     1            JMIN,JMAX,
24526     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
24527     1            IVARN1,IVARN2,IVARTY,PVAR,
24528     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
24529     1            MINNVA,MAXNVA,
24530     1            IFLAGM,IFLAGP,
24531     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
24532      IF(IERROR.EQ.'YES')GOTO9000
24533C
24534      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'HGCI')THEN
24535        WRITE(ICOUT,999)
24536        CALL DPWRST('XXX','BUG ')
24537        WRITE(ICOUT,281)
24538  281   FORMAT('***** AFTER CALL DPPARS--')
24539        CALL DPWRST('XXX','BUG ')
24540        WRITE(ICOUT,282)NQ,NUMVAR
24541  282   FORMAT('NQ,NUMVAR = ',2I8)
24542        CALL DPWRST('XXX','BUG ')
24543        IF(NUMVAR.GT.0)THEN
24544          DO285I=1,NUMVAR
24545            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
24546     1                      ICOLR(I)
24547  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
24548     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
24549            CALL DPWRST('XXX','BUG ')
24550  285     CONTINUE
24551        ENDIF
24552      ENDIF
24553C
24554C               *****************************************
24555C               **  STEP 3A--                          **
24556C               **  CASE 1: TWO RESPONSE VARIABLES     **
24557C               **          WITH NO REPLICATION        **
24558C               *****************************************
24559C
24560      ISTEPN='3A'
24561      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'HGCI')
24562     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24563C
24564      NUMVA2=1
24565      DO5210I=1,NUMVAR
24566        DO5220J=I+1,NUMVAR
24567          ICOL=I
24568          CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
24569     1                INAME,IVARN1,IVARN2,IVARTY,
24570     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
24571     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
24572     1                MAXCP4,MAXCP5,MAXCP6,
24573     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
24574     1                Y,Y,Y,NS1,NLOCA2,NLOCA3,ICASE,
24575     1                IBUGA3,ISUBRO,IFOUND,IERROR)
24576          IF(IERROR.EQ.'YES')GOTO9000
24577C
24578          ICOL=J
24579          CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
24580     1                INAME,IVARN1,IVARN2,IVARTY,
24581     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
24582     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
24583     1                MAXCP4,MAXCP5,MAXCP6,
24584     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
24585     1                X,X,X,NS2,NLOCA2,NLOCA3,ICASE,
24586     1                IBUGA3,ISUBRO,IFOUND,IERROR)
24587          IF(IERROR.EQ.'YES')GOTO9000
24588C
24589C               ***********************************************
24590C               **  STEP 52--                                **
24591C               **  GENERATE HEDGES G    CONFIDENCE LIMITS   **
24592C               ***********************************************
24593C
24594          ISTEPN='52'
24595          IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'HGCI')THEN
24596            CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24597            WRITE(ICOUT,999)
24598            CALL DPWRST('XXX','BUG ')
24599            WRITE(ICOUT,5211)
24600 5211       FORMAT('***** FROM DPHGCI, BEFORE CALL DPHGC2--')
24601            CALL DPWRST('XXX','BUG ')
24602            WRITE(ICOUT,5212)I,J,NS1,NS2,MAXN
24603 5212       FORMAT('I,J,NS1,NS2,MAXN = ',5I8)
24604            CALL DPWRST('XXX','BUG ')
24605            DO5215II=1,MAX(NS1,NS2)
24606              WRITE(ICOUT,5216)II,Y(II),X(II)
24607 5216         FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
24608              CALL DPWRST('XXX','BUG ')
24609 5215       CONTINUE
24610          ENDIF
24611C
24612          IVARID=IVARN1(I)
24613          IVARI2=IVARN2(I)
24614          IVARI3=IVARN1(J)
24615          IVARI4=IVARN2(J)
24616          CALL DPHGC2(Y,NS1,X,NS2,
24617     1                ICAPSW,ICAPTY,IFORSW,
24618     1                IVARID,IVARI2,IVARI3,IVARI4,
24619     1                CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
24620     1                IBUGA3,ISUBRO,IERROR)
24621          IF(IERROR.EQ.'YES')GOTO9000
24622C
24623C               ***************************************
24624C               **  STEP 8C--                        **
24625C               **  UPDATE INTERNAL DATAPLOT TABLES  **
24626C               ***************************************
24627C
24628          ISTEPN='8C'
24629          IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'HGCI')
24630     1      CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24631C
24632          IF(NUMVAR.GT.2)THEN
24633            IFLAGU='FILE'
24634          ELSE
24635            IFLAGU='ON'
24636          ENDIF
24637          IFRST=.FALSE.
24638          ILAST=.FALSE.
24639          IF(I.EQ.1 .AND. J.EQ.2)IFRST=.TRUE.
24640          IF(I.EQ.NUMVAR .AND. J.EQ.NUMVAR)ILAST=.TRUE.
24641          CALL DPCRC5(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
24642     1                IFLAGU,IFRST,ILAST,
24643     1                IBUGA2,IBUGA3,ISUBRO,IERROR)
24644C
24645 5220   CONTINUE
24646 5210 CONTINUE
24647C
24648C               *****************
24649C               **  STEP 90--  **
24650C               **  EXIT       **
24651C               *****************
24652C
24653 9000 CONTINUE
24654      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'HGCI')THEN
24655        WRITE(ICOUT,999)
24656        CALL DPWRST('XXX','BUG ')
24657        WRITE(ICOUT,9011)
24658 9011   FORMAT('***** AT THE END       OF DPHGCI--')
24659        CALL DPWRST('XXX','BUG ')
24660        WRITE(ICOUT,9016)IFOUND,IERROR
24661 9016   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
24662        CALL DPWRST('XXX','BUG ')
24663      ENDIF
24664C
24665      RETURN
24666      END
24667      SUBROUTINE DPHGC2(Y1,N1,Y2,N2,
24668     1                  ICAPSW,ICAPTY,IFORSW,
24669     1                  IVARID,IVARI2,IVARI3,IVARI4,
24670     1                  CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
24671     1                  IBUGA3,ISUBRO,IERROR)
24672C
24673C     PURPOSE--THIS ROUTINE GENERATES A CONFIDENCE LIMITS FOR THE
24674C              HEDGES G STATISTIC
24675C
24676C              THE FORMULA IS
24677C
24678C                  G +/- NORPPF(1-(ALPHA/2))*G(se)
24679C
24680C               WHERE
24681C
24682C                  G(se) = SQRT((N1+N2)/(N1*N2) + G**2/(2*(N1+N2))
24683C
24684C     EXAMPLE--HEDGES G COEFICIENT Y1 Y2
24685C              SAMPLE 1 IS IN INPUT VECTOR Y1 (WITH N1 OBSERVATIONS).
24686C              SAMPLE 2 IS IN INPUT VECTOR Y2 (WITH N2 OBSERVATIONS).
24687C     WRITTEN BY--ALAN HECKERT
24688C                 STATISTICAL ENGINEERING DIVISION
24689C                 INFORMATION TECHNOLOGY LABORATORY
24690C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
24691C                 GAITHERSBURG, MD 20899-8980
24692C                 PHONE--301-975-2899
24693C     REFERENCES--DURLAK (2009), "HOW TO SELECT, CALCULATE, AND
24694C                 INTERPRET EFFECT SIZES", JOURNAL OF PEDIATRIC
24695C                 PSYCHOLOGY, VOL. 34, NO. 9, PP. 917-928.
24696C               --HEDGES AND OLKIN (1985), "STATISTICAL METHODS FOR
24697C                 META-ANALYSIS", NEW YORK: ACADEMIC PRESS.
24698C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
24699C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
24700C     LANGUAGE--ANSI FORTRAN (1977)
24701C     VERSION NUMBER--2018/08
24702C     ORIGINAL VERSION--AUGUST    2018.
24703C
24704C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
24705C
24706      CHARACTER*4 ICAPSW
24707      CHARACTER*4 ICAPTY
24708      CHARACTER*4 IFORSW
24709      CHARACTER*4 IVARID
24710      CHARACTER*4 IVARI2
24711      CHARACTER*4 IVARI3
24712      CHARACTER*4 IVARI4
24713      CHARACTER*4 IBUGA3
24714      CHARACTER*4 ISUBRO
24715      CHARACTER*4 IERROR
24716C
24717      CHARACTER*4 IWRITE
24718      CHARACTER*4 ICASE
24719      CHARACTER*4 ICASA2
24720      CHARACTER*4 ISUBN1
24721      CHARACTER*4 ISUBN2
24722      CHARACTER*4 ISTEPN
24723C
24724C---------------------------------------------------------------------
24725C
24726      DIMENSION Y1(*)
24727      DIMENSION Y2(*)
24728C
24729      PARAMETER (NUMALP=7)
24730      REAL ALPHA(NUMALP)
24731      REAL ALPHSV(NUMALP)
24732      REAL LOWLIM(NUMALP)
24733      REAL UPPLIM(NUMALP)
24734      REAL GVAL(NUMALP)
24735      REAL GSE(NUMALP)
24736C
24737      PARAMETER(NUMCLI=4)
24738      PARAMETER(MAXLIN=2)
24739      PARAMETER (MAXROW=30)
24740      CHARACTER*60 ITITLE
24741      CHARACTER*60 ITITLZ
24742      CHARACTER*60 ITEXT(MAXROW)
24743      REAL         AVALUE(MAXROW)
24744      INTEGER      NCTEXT(MAXROW)
24745      INTEGER      IDIGIT(MAXROW)
24746      INTEGER      NTOT(MAXROW)
24747      LOGICAL IFRST
24748      LOGICAL ILAST
24749C
24750C---------------------------------------------------------------------
24751C
24752      INCLUDE 'DPCOP2.INC'
24753C
24754      DATA ALPHA/0.50, 0.75, 0.80, 0.90, 0.95, 0.99, 0.999/
24755C
24756C-----START POINT-----------------------------------------------------
24757C
24758      ISUBN1='DPHG'
24759      ISUBN2='C2  '
24760      IERROR='NO'
24761C
24762      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'HGC2')THEN
24763        WRITE(ICOUT,999)
24764  999   FORMAT(1X)
24765        CALL DPWRST('XXX','WRIT')
24766        WRITE(ICOUT,51)
24767   51   FORMAT('**** AT THE BEGINNING OF DPHGC2--')
24768        CALL DPWRST('XXX','WRIT')
24769        WRITE(ICOUT,52)IBUGA3,ISUBRO,N1,N2
24770   52   FORMAT('IBUGA3,ISUBRO,N1,N2 = ',2(A4,2X),2I8)
24771        CALL DPWRST('XXX','WRIT')
24772        DO56I=1,MAX(N1,N2)
24773          WRITE(ICOUT,57)I,Y1(I),Y2(I)
24774   57     FORMAT('I,Y1(I),Y2(I) = ',I8,2G15.7)
24775          CALL DPWRST('XXX','WRIT')
24776   56   CONTINUE
24777      ENDIF
24778C
24779C               ******************************
24780C               **  STEP 1--                **
24781C               **  ERROR CHECK             **
24782C               ******************************
24783C
24784      IF(N1.LT.2)THEN
24785        WRITE(ICOUT,999)
24786        CALL DPWRST('XXX','WRIT')
24787        WRITE(ICOUT,101)
24788  101   FORMAT('****** ERROR IN HEDGES G CONFIDENCE LIMITS--')
24789        CALL DPWRST('XXX','WRIT')
24790        WRITE(ICOUT,113)
24791  113   FORMAT('     THE NUMBER OF OBSERVATIONS FOR SAMPLE ONE IS ',
24792     1         'LESS THAN 2.')
24793        CALL DPWRST('XXX','WRIT')
24794        WRITE(ICOUT,115)N1
24795  115   FORMAT('     THE NUMBER OF OBSERVATIONS FOR SAMPLE ONE= ',I8)
24796        CALL DPWRST('XXX','WRIT')
24797        IERROR='YES'
24798        GOTO9000
24799      ELSEIF(N2.LT.2)THEN
24800        WRITE(ICOUT,999)
24801        CALL DPWRST('XXX','WRIT')
24802        WRITE(ICOUT,101)
24803        CALL DPWRST('XXX','WRIT')
24804        WRITE(ICOUT,123)
24805  123   FORMAT('     THE NUMBER OF OBSERVATIONS FOR SAMPLE TWO IS ',
24806     1         'LESS THAN 2.')
24807        CALL DPWRST('XXX','WRIT')
24808        WRITE(ICOUT,125)N2
24809  125   FORMAT('     THE NUMBER OF OBSERVATIONS FOR SAMPLE TWO= ',I8)
24810        CALL DPWRST('XXX','WRIT')
24811        IERROR='YES'
24812        GOTO9000
24813      ENDIF
24814C
24815C
24816C               *****************************************
24817C               **  STEP 2--                           **
24818C               **  CARRY OUT CALCULATIONS             **
24819C               **  FOR CORRELATION CONFIDENCE LIMITS  **
24820C               *****************************************
24821C
24822      ISTEPN='2'
24823      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'HGC2')
24824     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24825C
24826      IWRITE='OFF'
24827      ICASE='HEDG'
24828      ALPHT=0.95
24829      CALL HEDGEG(Y1,Y2,N1,N2,IWRITE,STATVA,STATBC,STATSE,
24830     1            ALPHT,ALCL,AUCL,
24831     1            YMEAN1,YSD1,YMEAN2,YSD2,SPOOL,
24832     1            ICASE,ISUBRO,IBUGA3,IERROR)
24833      IF(IERROR.EQ.'YES')GOTO9000
24834C
24835      DO200I=1,NUMALP
24836        ALPHT=ALPHA(I)
24837        ALPHT=(1.0 - ALPHT)/2.0
24838        ALPHT=1.0 - ALPHT
24839        CALL NORPPF(ALPHT,PPF)
24840        LOWLIM(I)=STATVA - PPF*STATSE
24841        UPPLIM(I)=STATVA + PPF*STATSE
24842        GVAL(I)=PPF
24843        GSE(I)=PPF*STATSE
24844  200 CONTINUE
24845C
24846      CUTL90=LOWLIM(5)
24847      CUTL95=LOWLIM(6)
24848      CUTL99=LOWLIM(7)
24849      CUTU90=UPPLIM(5)
24850      CUTU95=UPPLIM(6)
24851      CUTU99=UPPLIM(7)
24852C
24853C               ******************************
24854C               **   STEP 3-                **
24855C               **   WRITE OUT EVERYTHING   **
24856C               ******************************
24857C
24858      ISTEPN='3'
24859      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'HGC2')
24860     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24861C
24862      IF(IPRINT.EQ.'OFF')GOTO9000
24863C
24864      NUMDIG=7
24865      IF(IFORSW.EQ.'1')NUMDIG=1
24866      IF(IFORSW.EQ.'2')NUMDIG=2
24867      IF(IFORSW.EQ.'3')NUMDIG=3
24868      IF(IFORSW.EQ.'4')NUMDIG=4
24869      IF(IFORSW.EQ.'5')NUMDIG=5
24870      IF(IFORSW.EQ.'6')NUMDIG=6
24871      IF(IFORSW.EQ.'7')NUMDIG=7
24872      IF(IFORSW.EQ.'8')NUMDIG=8
24873      IF(IFORSW.EQ.'9')NUMDIG=9
24874      IF(IFORSW.EQ.'0')NUMDIG=0
24875      IF(IFORSW.EQ.'E')NUMDIG=-2
24876      IF(IFORSW.EQ.'-2')NUMDIG=-2
24877      IF(IFORSW.EQ.'-3')NUMDIG=-3
24878      IF(IFORSW.EQ.'-4')NUMDIG=-4
24879      IF(IFORSW.EQ.'-5')NUMDIG=-5
24880      IF(IFORSW.EQ.'-6')NUMDIG=-6
24881      IF(IFORSW.EQ.'-7')NUMDIG=-7
24882      IF(IFORSW.EQ.'-8')NUMDIG=-8
24883      IF(IFORSW.EQ.'-9')NUMDIG=-9
24884C
24885      ITITLE='Confidence Limits for the Hedges G Statistic'
24886      NCTITL=44
24887      ITITLZ=' '
24888      NCTITZ=0
24889C
24890      ICNT=1
24891      ITEXT(ICNT)=' '
24892      NCTEXT(ICNT)=0
24893      AVALUE(ICNT)=0.0
24894      IDIGIT(ICNT)=-1
24895      ICNT=ICNT+1
24896      ITEXT(ICNT)='Response Variable 1: '
24897      WRITE(ITEXT(ICNT)(22:25),'(A4)')IVARID(1:4)
24898      WRITE(ITEXT(ICNT)(26:29),'(A4)')IVARI2(1:4)
24899      NCTEXT(ICNT)=29
24900      AVALUE(ICNT)=0.0
24901      IDIGIT(ICNT)=-1
24902      ICNT=ICNT+1
24903      ITEXT(ICNT)='Response Variable 2: '
24904      WRITE(ITEXT(ICNT)(22:25),'(A4)')IVARI3(1:4)
24905      WRITE(ITEXT(ICNT)(26:29),'(A4)')IVARI4(1:4)
24906      NCTEXT(ICNT)=29
24907      AVALUE(ICNT)=0.0
24908      IDIGIT(ICNT)=-1
24909C
24910      ICNT=ICNT+1
24911      ITEXT(ICNT)=' '
24912      NCTEXT(ICNT)=1
24913      AVALUE(ICNT)=0.0
24914      IDIGIT(ICNT)=-1
24915C
24916      ICNT=ICNT+1
24917      ITEXT(ICNT)=' '
24918      NCTEXT(ICNT)=1
24919      AVALUE(ICNT)=0.0
24920      IDIGIT(ICNT)=-1
24921      ICNT=ICNT+1
24922      ITEXT(ICNT)='Summary Statistics for Variable 1:'
24923      NCTEXT(ICNT)=34
24924      AVALUE(ICNT)=0.0
24925      IDIGIT(ICNT)=-1
24926      ICNT=ICNT+1
24927      ITEXT(ICNT)='Number of Observations:'
24928      NCTEXT(ICNT)=23
24929      AVALUE(ICNT)=REAL(N1)
24930      IDIGIT(ICNT)=0
24931      ICNT=ICNT+1
24932      ITEXT(ICNT)='Sample Mean:'
24933      NCTEXT(ICNT)=12
24934      AVALUE(ICNT)=YMEAN1
24935      IDIGIT(ICNT)=NUMDIG
24936      ICNT=ICNT+1
24937      ITEXT(ICNT)='Sample Standard Deviation:'
24938      NCTEXT(ICNT)=26
24939      AVALUE(ICNT)=YSD1
24940      IDIGIT(ICNT)=NUMDIG
24941      ICNT=ICNT+1
24942      ITEXT(ICNT)=' '
24943      NCTEXT(ICNT)=1
24944      AVALUE(ICNT)=0.0
24945      IDIGIT(ICNT)=-1
24946      ICNT=ICNT+1
24947      ITEXT(ICNT)='Summary Statistics for Variable 2:'
24948      NCTEXT(ICNT)=34
24949      AVALUE(ICNT)=0.0
24950      IDIGIT(ICNT)=-1
24951      ICNT=ICNT+1
24952      ITEXT(ICNT)='Number of Observations:'
24953      NCTEXT(ICNT)=23
24954      AVALUE(ICNT)=REAL(N2)
24955      IDIGIT(ICNT)=0
24956      ICNT=ICNT+1
24957      ITEXT(ICNT)='Sample Mean:'
24958      NCTEXT(ICNT)=12
24959      AVALUE(ICNT)=YMEAN2
24960      IDIGIT(ICNT)=NUMDIG
24961      ICNT=ICNT+1
24962      ITEXT(ICNT)='Sample Standard Deviation:'
24963      NCTEXT(ICNT)=26
24964      AVALUE(ICNT)=YSD2
24965      IDIGIT(ICNT)=NUMDIG
24966      ICNT=ICNT+1
24967      ITEXT(ICNT)=' '
24968      NCTEXT(ICNT)=1
24969      AVALUE(ICNT)=0.0
24970      IDIGIT(ICNT)=-1
24971      ICNT=ICNT+1
24972      ITEXT(ICNT)='Pooled Standard Deviation'
24973      NCTEXT(ICNT)=25
24974      AVALUE(ICNT)=SPOOL
24975      IDIGIT(ICNT)=NUMDIG
24976      ICNT=ICNT+1
24977      ITEXT(ICNT)='Hedges G:'
24978      NCTEXT(ICNT)=9
24979      AVALUE(ICNT)=STATVA
24980      IDIGIT(ICNT)=NUMDIG
24981      ICNT=ICNT+1
24982      ITEXT(ICNT)='Bias Corrected Hedges G:'
24983      NCTEXT(ICNT)=24
24984      AVALUE(ICNT)=STATBC
24985      IDIGIT(ICNT)=NUMDIG
24986      ICNT=ICNT+1
24987      ITEXT(ICNT)='Standard Error for Hedges G:'
24988      NCTEXT(ICNT)=28
24989      AVALUE(ICNT)=STATSE
24990      IDIGIT(ICNT)=NUMDIG
24991      ICNT=ICNT+1
24992      ITEXT(ICNT)=' '
24993      NCTEXT(ICNT)=1
24994      AVALUE(ICNT)=0.0
24995      IDIGIT(ICNT)=-1
24996C
24997      NUMROW=ICNT
24998      DO5210I=1,NUMROW
24999        NTOT(I)=15
25000 5210 CONTINUE
25001C
25002      IFRST=.TRUE.
25003      ILAST=.TRUE.
25004C
25005      ISTEPN='9A'
25006      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CNF2')
25007     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25008C
25009      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
25010     1            AVALUE,IDIGIT,
25011     1            NTOT,NUMROW,
25012     1            ICAPSW,ICAPTY,ILAST,IFRST,
25013     1            ISUBRO,IBUGA3,IERROR)
25014C
25015      ISTEPN='9B'
25016      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CNF2')
25017     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25018C
25019      ICASA2='HEDG'
25020      DO4210I=1,NUMALP
25021        ALPHSV(I)=100.*ALPHA(I)
25022 4210 CONTINUE
25023      CALL DPDT11(ALPHSV,GVAL,GSE,LOWLIM,UPPLIM,
25024     1            ICASA2,ICAPSW,ICAPTY,NUMDIG,
25025     1            ISUBRO,IBUGA3,IERROR)
25026C
25027C
25028C               *****************
25029C               **  STEP 90--  **
25030C               **  EXIT       **
25031C               *****************
25032C
25033 9000 CONTINUE
25034      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'HGC2')THEN
25035        WRITE(ICOUT,999)
25036        CALL DPWRST('XXX','WRIT')
25037        WRITE(ICOUT,9011)
25038 9011   FORMAT('***** AT THE END       OF DPHGC2--')
25039        CALL DPWRST('XXX','WRIT')
25040        WRITE(ICOUT,9012)IERROR
25041 9012   FORMAT('IERROR = ',A4)
25042        CALL DPWRST('XXX','WRIT')
25043      ENDIF
25044C
25045      RETURN
25046      END
25047      SUBROUTINE DPHIS2(Y,X,XHIGH,N,
25048     1                  ICASPL,IRELAT,IHIGH,IDATSW,CLWID,XSTART,XSTOP,
25049CCCCC                   MARCH 1996.  ADD FOLLOWING LINE
25050     1                  XTEMP1,XTEMP2,XTEMP3,XIDTEM,MAXOBV,
25051     1                  IRHSTG,IHSTCW,IHSTEB,IHSTOU,IASHWT,M,
25052     1                  IHSTMC,IHSTOP,
25053     1                  Y2,X2,X3D,D2,N2,NPLOTV,IBUGG3,ISUBRO,IERROR)
25054C
25055C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
25056C              THAT WILL DEFINE
25057C                   1) A HISTOGRAM,
25058C                   2) A RELATIVE HISTOGRAM
25059C                      (THAT IS, WITH AREA = 1).
25060C                   3) A CUMULATIVE HISTOGRAM
25061C                   4) A RELATIVE CUMULATIVE HISTOGRAM
25062C                      (THAT IS, WITH MAX BAR HEIGHT = 1).
25063C     WRITTEN BY--JAMES J. FILLIBEN
25064C                 STATISTICAL ENGINEERING DIVISION
25065C                 INFORMATION TECHNOLOGY LABORATORY
25066C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
25067C                 GAITHERSBURG, MD 20899-8980
25068C                 PHONE--301-975-2855
25069C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
25070C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
25071C     LANGUAGE--ANSI FORTRAN (1977)
25072C     VERSION NUMBER--82/7
25073C     ORIGINAL VERSION--APRIL     1978.
25074C     UPDATED         --MAY       1978.
25075C     UPDATED         --JUNE      1978.
25076C     UPDATED         --OCTOBER   1978.
25077C     UPDATED         --MARCH     1979.
25078C     UPDATED         --APRIL     1979.
25079C     UPDATED         --JANUARY   1981.
25080C     UPDATED         --AUGUST    1981.
25081C     UPDATED         --OCTOBER   1981.
25082C     UPDATED         --DECEMBER  1981.
25083C     UPDATED         --APRIL     1982.
25084C     UPDATED         --MAY       1982.
25085C     UPDATED         --FEBRUARY  1988.  (RELATIVE HISTOGRAM AREA CORRECTION)
25086C     UPDATED         --JANUARY   1989.  DOUBLE PRECISION (MANY PLACES)
25087C     UPDATED         --JUNE      1994.  FIX RELATIVE HIST AREA
25088C     UPDATED         --MARCH     1996.  FIX RELATIVE HIST AREA BASED
25089C                                        ON IRHSTG SWITCH.
25090C     UPDATED         --DECEMBER  1999.  CHECK FOR POINTS OUTSIDE INTERVAL
25091C     UPDATED         --SEPTEMBER 2004.  SUPPORT FOR ALTERNATIVE
25092C                                        CLASS WIDTH ALGORITHMS
25093C                                        (IHSTCW)
25094C     UPDATED         --SEPTEMBER 2004.  SUPPORT FOR "AVERAGE SHIFTED
25095C                                        HISTOGRAM" (IASHWT)
25096C     UPDATED         --SEPTEMBER 2005.  NO ERROR IF ALL ELEMENTS THE
25097C                                        SAME
25098C     UPDATED         --NOVEMBER  2005.  FIX BUG INTRODUCED BY 9/2005
25099C                                        UPDATE
25100C     UPDATED         --JANUARY   2010.  FOR "RAW" CASE, PUT RESPONSE
25101C                                        IN Y RATHER THAN X
25102C     UPDATED         --JANUARY   2010.  SUPPORT FOR "HIGHLIGHTED" OPTION
25103C     UPDATED         --JANUARY   2010.  SUPPORT FOR NON-EQUISPACED
25104C                                        HISTOGRAMS
25105C     UPDATED         --JANUARY   2010.  OPTION TO SUPPRESS EMPTY BINS
25106C     UPDATED         --JANUARY   2010.  OPTION TO INCLUDE OUTLIERS
25107C     UPDATED         --JANUARY   2010.  CALL DPBINZ TO HANDLE BINNING
25108C     UPDATED         --FEBRUARY  2010.  HANDLE ROOTOGRAM CASE
25109C     UPDATED         --JUNE      2016.  SUPPORT FOR IHSTMC
25110C     UPDATED         --JUNE      2016.  SUPPORT FOR IHSTOP
25111C
25112C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
25113C
25114      CHARACTER*4 ICASPL
25115      CHARACTER*4 IRELAT
25116      CHARACTER*4 IHIGH
25117      CHARACTER*4 IDATSW
25118      CHARACTER*4 IBUGG3
25119      CHARACTER*4 ISUBRO
25120      CHARACTER*4 IERROR
25121C
25122      CHARACTER*4 IWRIT2
25123CCCCC MARCH 1996.  ADD FOLLOWING LINE
25124      CHARACTER*4 IRHSTG
25125      CHARACTER*4 IHSTCW
25126      CHARACTER*4 IHSTEB
25127      CHARACTER*4 IHSTOU
25128      CHARACTER*4 IHSTOP
25129      CHARACTER*4 IASHWT
25130C
25131      CHARACTER*4 ISUBN1
25132      CHARACTER*4 ISUBN2
25133C
25134C---------------------------------------------------------------------
25135
25136      DOUBLE PRECISION DCLWID
25137      DOUBLE PRECISION DXSTAR
25138      DOUBLE PRECISION DXSTOP
25139      DOUBLE PRECISION DCLMNJ
25140      DOUBLE PRECISION DCLMDJ
25141      DOUBLE PRECISION DCLMXJ
25142      DOUBLE PRECISION DJ
25143      DOUBLE PRECISION DXI
25144      DOUBLE PRECISION DXI2
25145      DOUBLE PRECISION DDELI
25146      DOUBLE PRECISION DABSDE
25147      DOUBLE PRECISION DTOTWI
25148      DOUBLE PRECISION DD21
25149      DOUBLE PRECISION DD2N
25150      DOUBLE PRECISION DN3
25151      DOUBLE PRECISION DN4
25152      DOUBLE PRECISION DSUM
25153C
25154C---------------------------------------------------------------------
25155C
25156      DIMENSION Y(*)
25157      DIMENSION X(*)
25158      DIMENSION XHIGH(*)
25159      DIMENSION Y2(*)
25160      DIMENSION X2(*)
25161      DIMENSION X3D(*)
25162      DIMENSION D2(*)
25163      DIMENSION XTEMP1(*)
25164      DIMENSION XTEMP2(*)
25165      DIMENSION XTEMP3(*)
25166      DIMENSION XIDTEM(*)
25167C
25168C---------------------------------------------------------------------
25169C
25170      INCLUDE 'DPCOP2.INC'
25171C
25172C-----START POINT-----------------------------------------------------
25173C
25174      ISUBN1='DPHI'
25175      ISUBN2='S2  '
25176      IERROR='NO'
25177      IWRIT2='OFF'
25178C
25179      DCLMDJ=(-999.0D0)
25180      AN3=0.0
25181      DENOM=0.0
25182      DCLWID=CLWID
25183      DXSTAR=XSTART
25184      DXSTOP=XSTOP
25185      DN3=0.0D0
25186      DN4=0.0D0
25187C
25188      K=(-999)
25189      KP3=0
25190      IBELOW=0
25191      IABOVE=0
25192      IBELAB=0
25193C
25194      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'HIS2')THEN
25195        WRITE(ICOUT,999)
25196        CALL DPWRST('XXX','BUG ')
25197        WRITE(ICOUT,70)
25198   70   FORMAT('***** AT THE BEGINNING OF DPHIS2--')
25199        CALL DPWRST('XXX','BUG ')
25200        WRITE(ICOUT,71)IDATSW,IHIGH,IHSTCW,IHSTOU,IHSTMC
25201   71   FORMAT('IDATSW,IHIGH,IHSTCW,IHSTOU,IHSTMC = ',4(A4,2X),I8)
25202        CALL DPWRST('XXX','BUG ')
25203        WRITE(ICOUT,72)N,CLWID,XSTART,XSTOP
25204   72   FORMAT('N,CLWID,XSTART,XSTOP = ',I6,3E15.7)
25205        CALL DPWRST('XXX','BUG ')
25206        DO73I=1,N
25207          WRITE(ICOUT,74)I,Y(I),X(I)
25208   74     FORMAT('I, Y(I), X(I) = ',I8,2E15.7)
25209          CALL DPWRST('XXX','BUG ')
25210   73   CONTINUE
25211      ENDIF
25212C
25213C               ********************************************
25214C               **  STEP 1--                              **
25215C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
25216C               ********************************************
25217C
25218      IF(N.LT.1)THEN
25219        WRITE(ICOUT,999)
25220  999   FORMAT(1X)
25221        CALL DPWRST('XXX','BUG ')
25222        WRITE(ICOUT,31)
25223   31   FORMAT('***** ERROR IN DPHIS2--')
25224        CALL DPWRST('XXX','BUG ')
25225        WRITE(ICOUT,32)
25226   32   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 1;')
25227        CALL DPWRST('XXX','BUG ')
25228        WRITE(ICOUT,34)N
25229   34   FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6)
25230        CALL DPWRST('XXX','BUG ')
25231        WRITE(ICOUT,999)
25232        CALL DPWRST('XXX','BUG ')
25233        IERROR='YES'
25234        GOTO9000
25235      ENDIF
25236C
25237CCCCC SEPTEMBER 2005.  IF ALL ELEMENTS THE SAME, THEN PRINT WARNING
25238CCCCC                  AND HANDLE AS A SPECIAL CASE.
25239C
25240      IF(IDATSW.EQ.'RAW')THEN
25241        HOLD=Y(1)
25242        DO60I=1,N
25243          IF(Y(I).NE.HOLD)GOTO69
25244   60   CONTINUE
25245        WRITE(ICOUT,999)
25246        CALL DPWRST('XXX','BUG ')
25247        WRITE(ICOUT,61)
25248   61   FORMAT('***** WARNING IN HISTOGRAM--')
25249        CALL DPWRST('XXX','BUG ')
25250        WRITE(ICOUT,62)
25251   62   FORMAT('      ALL INPUT HORIZONTAL AXIS ELEMENTS')
25252        CALL DPWRST('XXX','BUG ')
25253        WRITE(ICOUT,63)HOLD
25254   63   FORMAT('      ARE IDENTICALLY EQUAL TO ',G15.7)
25255        CALL DPWRST('XXX','BUG ')
25256        WRITE(ICOUT,999)
25257        CALL DPWRST('XXX','BUG ')
25258C
25259CCCCC   NOVEMBER 2005.  MOVE THIS LINE SINCE SECTION BELOW IS
25260CCCCC                    SPECIFICALLY FOR CASE WHERE ALL ELEMENTS
25261CCCCC                   ARE IDENTICAL.
25262CCC69   CONTINUE
25263C
25264        N2=3
25265        X2(1)=HOLD-1.0
25266        X2(2)=HOLD
25267        X2(3)=HOLD+1.0
25268        IF(IRELAT.EQ.'ON')THEN
25269          Y2(1)=0.0
25270          Y2(2)=1.0
25271          Y2(3)=0.0
25272        ELSE
25273          Y2(1)=0.0
25274          Y2(2)=REAL(N)
25275          Y2(3)=0.0
25276        ENDIF
25277        D2(1)=1.0
25278        D2(2)=1.0
25279        D2(3)=1.0
25280        NPLOTV=2
25281        GOTO9000
25282      ENDIF
25283C
25284   69 CONTINUE
25285C
25286C               **********************************************
25287C               **  STEP 2--                                **
25288C               **  IF NECESSARY,                           **
25289C               **  DETERMINE CLASS WIDTH,                  **
25290C               **  START VALUE, STOP VALUE,                **
25291C               **  AND NUMBER OF CLASSES.                  **
25292C               **********************************************
25293C
25294      IF(IDATSW.EQ.'RAW')THEN
25295        IF(ICASPL.EQ.'ASHR')THEN
25296          CALL DPBINA(Y,N,CLWID,XSTART,XSTOP,M,
25297     1                XTEMP1,MAXOBV,
25298     1                IRELAT,IASHWT,IHSTCW,
25299     1                Y2,X2,N2,IBUGG3,IERROR)
25300          DO112I=1,N2
25301            D2(I)=1.0
25302  112     CONTINUE
25303          GOTO9000
25304        ELSE
25305          CALL DPBINZ(Y,N,CLWID,XSTART,XSTOP,
25306     1                XTEMP1,MAXOBV,IHSTCW,IHSTOU,
25307     1                DCLWID,DXSTAR,DXSTOP,
25308     1                ISUBRO,IBUGG3,IERROR)
25309        ENDIF
25310C
25311      ELSEIF(IDATSW.EQ.'FREQ')THEN
25312        CALL SORT(X,N,D2)
25313        NM1=N-1
25314        DCLWID=D2(2)-D2(1)
25315        DO160I=1,NM1
25316          IP1=I+1
25317          DDELI=D2(IP1)-D2(I)
25318          IF(DDELI.LT.DCLWID)DCLWID=DDELI
25319  160   CONTINUE
25320        DD21=D2(1)
25321        DD2N=D2(N)
25322        DXSTAR=DD21-(DCLWID/2.0D0)
25323        DXSTOP=DD2N+(DCLWID/2.0D0)
25324C
25325      ELSEIF(IDATSW.EQ.'FRE2')THEN
25326        DXSTAR=X(1)
25327        DXSTOP=XHIGH(N)
25328      ENDIF
25329C
25330      IF(IDATSW.EQ.'FRE2')THEN
25331        NUMCLA=N
25332      ELSE
25333        DTOTWI=DXSTOP-DXSTAR
25334        ANUMCL=DTOTWI/DCLWID
25335        NUMCLA=INT(ANUMCL+1.0)
25336C
25337        J=NUMCLA-1
25338        DJ=J
25339        DCLMXJ=DXSTAR+DJ*DCLWID
25340        DABSDE=DABS(DCLMXJ-DXSTOP)
25341        IF(DABSDE.LE.0.0001D0)NUMCLA=NUMCLA-1
25342        IMAXCL=IHSTMC
25343        IF(IHSTMC.EQ.0)IMAXCL=10000
25344        IF(NUMCLA.GT.IMAXCL)THEN
25345          NUMCLA=IMAXCL
25346          ANUMCL=NUMCLA
25347          DCLWID=(DXSTOP-DXSTAR)/ANUMCL
25348        ENDIF
25349      ENDIF
25350C
25351C               *******************************************************
25352C               **  STEP 3--                                         **
25353C               **  DETERMINE THE FREQUENCY (COUNTS) FOR EACH CLASS  **
25354C               *******************************************************
25355C
25356      IF(IDATSW.EQ.'RAW' .AND. IHIGH.EQ.'ON')THEN
25357        CALL DISTIN(X,N,IWRIT2,XIDTEM,NDIST,IBUGG3,IERROR)
25358        CALL SORT(XIDTEM,NDIST,XIDTEM)
25359      ELSE
25360        NDIST=1
25361      ENDIF
25362      NPOINT=0
25363C
25364      DO300IREPL=1,NDIST
25365C
25366        IF(IREPL.EQ.1)THEN
25367          DO301ISET=1,N
25368            XTEMP2(ISET)=Y(ISET)
25369  301     CONTINUE
25370          NTEMP=N
25371          ATAG=1.0
25372        ELSE
25373          ICNT=0
25374          AHOLD=XIDTEM(IREPL-1)
25375          DO306ISET=1,N
25376            IF(X(ISET).EQ.AHOLD)THEN
25377              ICNT=ICNT+1
25378              XTEMP2(ICNT)=Y(ISET)
25379            ENDIF
25380  306     CONTINUE
25381          NTEMP=ICNT
25382          ATAG=REAL(NDIST - IREPL + 2)
25383        ENDIF
25384C
25385        DO310J=1,NUMCLA
25386          XTEMP1(J)=0.0
25387  310   CONTINUE
25388C
25389C       2016/06: MODIFY ALGORITHM FOR BETTER EFFICIENCY TO SPEED UP FOR
25390C                LARGE DATA SETS.
25391C
25392C                1. SORT THE DATA FIRST
25393C                2. KEEP TRACK OF THE "MINIMUM" CLASS WHEN SORT THROUGH
25394C                   THE AVAILABLE CLASSES.
25395C                3. IF IHSTOP IS ON, HAVE THE OUTLIERS DRAWN AS POINTS
25396C                   RATHER THAN BARS.  THIS CAN BE USEFUL FOR CASES
25397C                   WHERE THERE ARE EXTREME OUTLIERS.
25398C
25399        IF(IDATSW.EQ.'RAW')THEN
25400          IBELOW=0
25401          IABOVE=0
25402          IBELAB=0
25403          CALL SORT(XTEMP2,NTEMP,XTEMP2)
25404          JLOW=1
25405C
25406          DO420I=1,NTEMP
25407            DXI=XTEMP2(I)
25408            IF(DXI.LT.DXSTAR)THEN
25409              IBELOW=IBELOW+1
25410              IBELAB=IBELAB+1
25411              XTEMP3(IBELAB)=DXI
25412              GOTO420
25413            ELSEIF(DXI.GT.DXSTOP)THEN
25414              IABOVE=IABOVE+1
25415              IBELAB=IBELAB+1
25416              XTEMP3(IBELAB)=DXI
25417              GOTO420
25418            ELSE
25419              DO430J=JLOW,NUMCLA
25420                J2=J
25421                DJ=J
25422                DCLMNJ=DXSTAR+(DJ-1.0D0)*DCLWID
25423                DCLMXJ=DXSTAR+DJ*DCLWID
25424                IF(DCLMXJ.GT.DXSTOP)DCLMXJ=DXSTOP
25425                IF(DCLMNJ.LE.DXI.AND.DXI.LT.DCLMXJ)THEN
25426                  XTEMP1(J2)=XTEMP1(J2)+1.0
25427                  JLOW=J2
25428                  GOTO420
25429                ENDIF
25430  430         CONTINUE
25431            ENDIF
25432C
25433  420     CONTINUE
25434C
25435C         FOR THIS RAW DATA CASE,
25436C         TREAT THE SPECIAL CASE OF EQUALITY
25437C         WITH THE UPPER LIMIT OF THE LAST (RIGHT-MOST) CLASS
25438C
25439          J=NUMCLA
25440          DO450I=1,NTEMP
25441            DJ=J
25442            DCLMXJ=DXSTAR+DJ*DCLWID
25443            IF(DCLMXJ.GT.DXSTOP)DCLMXJ=DXSTOP
25444            DXI=XTEMP2(I)
25445            IF(DXI.EQ.DCLMXJ)XTEMP1(J)=XTEMP1(J)+1.0
25446  450     CONTINUE
25447        ELSEIF(IDATSW.EQ.'FREQ')THEN
25448          IBELOW=0
25449          IABOVE=0
25450          DO520I=1,N
25451            DXI=X(I)
25452            IF(DXI.LT.DXSTAR)THEN
25453              IBELOW=IBELOW+1
25454              GOTO520
25455            ELSEIF(DXI.GT.DXSTOP)THEN
25456              IABOVE=IABOVE+1
25457              GOTO520
25458            ENDIF
25459            DO530J=1,NUMCLA
25460              J2=J
25461              DJ=J
25462              DCLMNJ=DXSTAR+(DJ-1.0D0)*DCLWID
25463              DCLMXJ=DXSTAR+DJ*DCLWID
25464              IF(DCLMXJ.GT.DXSTOP)DCLMXJ=DXSTOP
25465              IF(DCLMNJ.LE.DXI.AND.DXI.LT.DCLMXJ)GOTO540
25466  530       CONTINUE
25467            GOTO520
25468  540       CONTINUE
25469            XTEMP1(J2)=XTEMP1(J2)+Y(I)
25470  520     CONTINUE
25471C
25472C         FOR THIS FREQUENCY DATA CASE, TREAT THE SPECIAL CASE OF
25473C         EQUALITY WITH THE UPPER LIMIT OF THE LAST (RIGHT-MOST) CLASS
25474C         (ALTHOUGH THIS SHOULD NOT HAPPEN WITH THE IDATSW = 'FREQ'
25475C         CASE.)
25476C
25477          J=NUMCLA
25478          DO550I=1,N
25479            DJ=J
25480            DCLMXJ=DXSTAR+DJ*DCLWID
25481            IF(DCLMXJ.GT.DXSTOP)DCLMXJ=DXSTOP
25482            DXI=X(I)
25483            IF(DXI.EQ.DCLMXJ)XTEMP1(J)=XTEMP1(J)+Y(I)
25484  550     CONTINUE
25485        ELSEIF(IDATSW.EQ.'FRE2')THEN
25486          IBELOW=0
25487          IABOVE=0
25488          DO570J=1,NUMCLA
25489            J2=J
25490            DXI=X(J)
25491            DXI2=XHIGH(J)
25492            IF(DXI.LT.DXSTAR)THEN
25493              IBELOW=IBELOW+1
25494              GOTO570
25495            ELSEIF(DXI2.GT.DXSTOP)THEN
25496              IABOVE=IABOVE+1
25497              GOTO570
25498             ELSE
25499                XTEMP1(J2)=Y(J)
25500            ENDIF
25501  570     CONTINUE
25502        ENDIF
25503C
25504        IF(IBELOW.GE.1)THEN
25505          WRITE(ICOUT,999)
25506          CALL DPWRST('XXX','BUG ')
25507          WRITE(ICOUT,1591)IBELOW,DXSTAR
25508 1591     FORMAT('***** WARNING: ',I8,' DATA POINTS ARE BELOW THE ',
25509     1           'MINIMUM CLASS VALUE OF ',G15.7)
25510          CALL DPWRST('XXX','BUG ')
25511        ENDIF
25512        IF(IABOVE.GE.1)THEN
25513          WRITE(ICOUT,999)
25514          CALL DPWRST('XXX','BUG ')
25515          WRITE(ICOUT,1691)IABOVE,DXSTOP
25516 1691     FORMAT('***** WARNING: ',I8,' DATA POINTS ARE ABOVE THE ',
25517     1           'MAXIMUM CLASS VALUE OF ',G15.7)
25518          CALL DPWRST('XXX','BUG ')
25519        ENDIF
25520C
25521        IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'HIS2')THEN
25522          WRITE(ICOUT,999)
25523          CALL DPWRST('XXX','BUG ')
25524          WRITE(ICOUT,591)
25525  591     FORMAT('***** IN THE MIDDLE    OF DPHIS2--')
25526          CALL DPWRST('XXX','BUG ')
25527          WRITE(ICOUT,592)DCLWID,DXSTAR,DXSTOP,DTOTWI,ANUMCL,NUMCLA
25528  592     FORMAT('DCLWID,DXSTAR,DXSTOP,DTOTWI,ANUMCL,NUMCLA= ',
25529     1           4D11.4,F10.0,I8)
25530          CALL DPWRST('XXX','BUG ')
25531          DO593J=1,NUMCLA
25532            DJ=J
25533            IF(IDATSW.EQ.'FRE2')THEN
25534              DCLMNJ=DBLE(X(J))
25535              DCLMXJ=DBLE(XHIGH(J))
25536            ELSE
25537              DCLMNJ=DXSTAR+(DJ-1.0D0)*DCLWID
25538              DCLMXJ=DXSTAR+DJ*DCLWID
25539            ENDIF
25540            IF(DCLMXJ.GT.DXSTOP)DCLMXJ=DXSTOP
25541            FJ=XTEMP1(J)
25542            WRITE(ICOUT,594)J,DCLMNJ,DCLMXJ,FJ
25543  594       FORMAT('J,DCLMNJ,DCLMXJ,FJ = ',I8,3G15.7)
25544            CALL DPWRST('XXX','BUG ')
25545  593     CONTINUE
25546        ENDIF
25547C
25548C               **********************************
25549C               **  STEP 4--                    **
25550C               **  DETERMINE PLOT COORDINATES  **
25551C               **********************************
25552C
25553        DSUM=0.0D0
25554        IF(ICASPL.EQ.'ROOT' .OR. ICASPL.EQ.'CUMR')THEN
25555          DO1108J=1,NUMCLA
25556            FJ=SQRT(XTEMP1(J))
25557            DSUM=DSUM+DBLE(FJ)
25558 1108     CONTINUE
25559        ELSE
25560          DO1110J=1,NUMCLA
25561            FJ=XTEMP1(J)
25562            DSUM=DSUM+DBLE(FJ)
25563 1110     CONTINUE
25564        ENDIF
25565        DN3=DSUM
25566        AN3=DN3
25567C
25568        IF(IDATSW.EQ.'FRE2')THEN
25569          DSUM=0.0D0
25570          DO1112J=1,NUMCLA
25571            FJ=XTEMP1(J)*(XHIGH(J) - X(J))
25572            IF(ICASPL.EQ.'ROOT' .OR. ICASPL.EQ.'CUMR')FJ=SQRT(FJ)
25573            DSUM=DSUM+FJ
25574 1112     CONTINUE
25575          DN4=DSUM
25576        ENDIF
25577C
25578CCCCC   RELATIVE HISTOGRAM CORRECTION MADE FEBRUARY 26, 1988
25579CCCCC   IF(IRELAT.EQ.'ON')DENOM=AN3         COMMENTED OUT JUNE 1994
25580CCCCC   IF(IRELAT.EQ.'ON')DENOM=AN3*DCLWID  COMMENTED OUT FEB 1988
25581CCCCC   THE FOLLOWING LINE FIXES THE RELATIVE HISTOGRAM AREA JUNE 1994
25582CCCCC   IF(IRELAT.EQ.'ON')DENOM=AN3*DCLWID
25583CCCCC   IF(IRELAT.EQ.'ON')DENOM=AN3
25584CCCCC   MARCH 1996.  ABOVE LINE COMMENTED OUT.  NOTE THAT THERE ARE 2
25585CCCCC   WAYS TO DEFINE HEIGHT FOR RELATIVE HISTOGRAM.  ONE WAY DEFINES
25586CCCCC   THE AREA SO THAT THE AREA SUMS TO 1 (I.E., THE INTEGRAL) AS IN
25587CCCCC   A PROBABILITY DENSITY FUNCTION.  THE OTHER WAY IS SO THAT THE
25588CCCCC   THE HEIGHTS SUM TO 1, I.E., THE HEIGHT IS THE PERCENT OF THE
25589CCCCC   TOTAL.  THE IRHSTG SWITCH NOW DETERMINES WHICH METHOD IS USED.
25590C
25591        DENOM=1.0
25592        IF(IRELAT.EQ.'ON')THEN
25593          IF(IRHSTG.EQ.'PERC')THEN
25594            DENOM=DN3
25595          ELSE
25596            IF(IDATSW.EQ.'FRE2')THEN
25597              DENOM=DN4
25598            ELSE
25599              DENOM=DN3*DCLWID
25600            ENDIF
25601          ENDIF
25602        ENDIF
25603C
25604        NSTRT=NPOINT+1
25605        DSUM=0.0D0
25606        DO1120J=1,NUMCLA
25607          K=J
25608          NPOINT=NPOINT+1
25609          D2(NPOINT)=ATAG
25610          IF(IDATSW.EQ.'FRE2')THEN
25611            X2(NPOINT)=X(K)
25612            X3D(NPOINT)=XHIGH(K)
25613          ELSE
25614            DJ=J
25615            DCLMDJ=DXSTAR+(DJ-0.5D0)*DCLWID
25616            X2(NPOINT)=DCLMDJ
25617          ENDIF
25618          FJ=XTEMP1(J)
25619          IF(ICASPL.EQ.'ROOT')FJ=SQRT(FJ)
25620C
25621          IF(IREPL.GT.2)THEN
25622            ABASE=Y2(NPOINT-NUMCLA)
25623          ELSE
25624            ABASE=0.0
25625          ENDIF
25626C
25627          IF(ICASPL.EQ.'HIST' .OR. ICASPL.EQ.'ROOT')THEN
25628            Y2(NPOINT)=(FJ/DENOM) + ABASE
25629          ELSEIF(ICASPL.EQ.'CUMH')THEN
25630            IF(IRELAT.EQ.'ON' .AND. IRHSTG.EQ.'AREA')THEN
25631              Y2(NPOINT)=(FJ/DENOM) + ABASE
25632            ELSE
25633              DSUM=DSUM+FJ
25634              CUMFJ=(DSUM/DENOM)
25635              Y2(NPOINT)=CUMFJ + ABASE
25636            ENDIF
25637          ELSEIF(ICASPL.EQ.'CUMR')THEN
25638            IF(IRELAT.EQ.'ON' .AND. IRHSTG.EQ.'AREA')THEN
25639              Y2(NPOINT)=(SQRT(FJ)/DENOM) + ABASE
25640            ELSE
25641              DSUM=DSUM+FJ
25642              CUMFJ=(DSQRT(DSUM)/DENOM)
25643              Y2(NPOINT)=CUMFJ + ABASE
25644            ENDIF
25645          ENDIF
25646 1120   CONTINUE
25647C
25648C       FOR CUMULATIVE RELATIVE HISTOGRAM (AREA CASE), COMPUTE
25649C       CUMULATIVE INTEGRAL OF POINTS.
25650C
25651        IF((ICASPL.EQ.'CUMH' .OR. ICASPL.EQ.'CUMR') .AND.
25652     1    IRELAT.EQ.'ON' .AND. IRHSTG.EQ.'AREA')THEN
25653          NSTOP=NPOINT
25654          NTOT=NSTOP-NSTRT+1
25655          NJUNK=2
25656          IWRIT2='OFF'
25657          CALL CUMINT(Y2(NSTRT),X2(NSTRT),NTOT,NJUNK,IWRIT2,XTEMP1,
25658     1                IBUGG3,IERROR)
25659          IF(ICASPL.EQ.'CUMH')THEN
25660            DO1129II=NSTRT,NSTOP
25661              Y2(II)=XTEMP1(II)
25662 1129       CONTINUE
25663          ELSEIF(ICASPL.EQ.'CUMR')THEN
25664            DO1139II=NSTRT,NSTOP
25665              Y2(II)=SQRT(XTEMP1(II))
25666 1139       CONTINUE
25667          ENDIF
25668        ENDIF
25669C
25670  300 CONTINUE
25671C
25672      N2=NPOINT
25673      NPLOTV=2
25674C
25675C     JANUARY 2010: SUPPRESS EMPTY BINS
25676C
25677      IF(IHSTEB.EQ.'OFF')THEN
25678        ICNT=0
25679        DO1140J=1,N2
25680          IF(Y2(J).GT.0.0)THEN
25681            ICNT=ICNT+1
25682            X2(ICNT)=X2(J)
25683            Y2(ICNT)=Y2(J)
25684            X3D(ICNT)=X3D(J)
25685            D2(ICNT)=D2(J)
25686          ENDIF
25687 1140   CONTINUE
25688        N2=ICNT
25689      ENDIF
25690C
25691C     JUNE 2016: OPTION TO PLOT POINTS OUTSIDE OF MIN AND MAX CLASS
25692C                LIMITS AS INDIVIDUAL POINTS.  THIS OPTION NOT SUPPORTED
25693C                FOR "HIGHLIGHTED" CASE.
25694C
25695      IF(IHSTOP.EQ.'ON' .AND. IHIGH.EQ.'OFF' .AND. IDATSW.EQ.'RAW')THEN
25696        IF(IBELAB.GT.0)THEN
25697          ICNT=N2
25698          DO1240J=1,IBELAB
25699            ICNT=ICNT+1
25700            X2(ICNT)=XTEMP3(J)
25701            Y2(ICNT)=0.0
25702            X3D(ICNT)=0.0
25703            D2(ICNT)=2.0
25704 1240     CONTINUE
25705          N2=ICNT
25706          ICASPL='HISO'
25707        ENDIF
25708      ENDIF
25709C
25710C               ******************
25711C               **   STEP 90--  **
25712C               **   EXIT       **
25713C               ******************
25714C
25715 9000 CONTINUE
25716      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'HIS2')THEN
25717        WRITE(ICOUT,999)
25718        CALL DPWRST('XXX','BUG ')
25719        WRITE(ICOUT,9011)
25720 9011   FORMAT('***** AT THE END       OF DPHIS2--')
25721        CALL DPWRST('XXX','BUG ')
25722        WRITE(ICOUT,9012)ICASPL,IRELAT,IERROR,N2
25723 9012   FORMAT('ICASPL,IRELAT,IERROR,N2 = ',A4,2X,A4,2X,A4,2X,I8)
25724        CALL DPWRST('XXX','BUG ')
25725        WRITE(ICOUT,9013)IDATSW,AN3,DENOM
25726 9013   FORMAT('IDATSW,AN3,DENOM = ',A4,2X,E15.8,E15.8)
25727        CALL DPWRST('XXX','BUG ')
25728        DO9015I=1,N2
25729          WRITE(ICOUT,9016)I,Y2(I),X2(I),D2(I)
25730 9016     FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2)
25731          CALL DPWRST('XXX','BUG ')
25732 9015   CONTINUE
25733        WRITE(ICOUT,9017)N,DCLWID,DXSTAR,DXSTOP
25734 9017   FORMAT('N,DCLWID,DXSTAR,DXSTOP = ',I6,3D15.7)
25735        CALL DPWRST('XXX','BUG ')
25736      ENDIF
25737C
25738      RETURN
25739      END
25740      SUBROUTINE DPHIST(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
25741     1                  CLLIMI,CLWIDT,
25742CCCCC                   MARCH 1996.  ADD FOLLOWING LINE
25743     1                  IRHSTG,IHSTCW,IASHWT,IHSTEB,IHSTOU,
25744     1                  IHSTMC,IHSTOP,
25745     1                  IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
25746C
25747C     PURPOSE--GENERATE ONE OF THE FOLLOWING 4 PLOTS--
25748C              1) HISTOGRAM;
25749C              2) RELATIVE HISTOGRAM;
25750C              3) CUMULATIVE HISTOGRAM;
25751C              4) RELATIVE CUMULATIVE HISTOGRAM;
25752C              5) HIGHLIGHTED HISTOGRAM;
25753C
25754C              NOTE: INCLUDE ROOTOGRAM  AND ASH IN THIS CODE
25755C
25756C     WRITTEN BY--JAMES J. FILLIBEN
25757C                 STATISTICAL ENGINEERING DIVISION
25758C                 INFORMATION TECHNOLOGY LABORATORY
25759C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
25760C                 GAITHERSBURG, MD 20899-8980
25761C                 PHONE--301-975-2855
25762C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
25763C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
25764C     LANGUAGE--ANSI FORTRAN (1977)
25765C     VERSION NUMBER--82/7
25766C     ORIGINAL VERSION--APRIL     1978.
25767C     UPDATED         --JUNE      1978.
25768C     UPDATED         --JULY      1978.
25769C     UPDATED         --OCTOBER   1978.
25770C     UPDATED         --APRIL     1979.
25771C     UPDATED         --JANUARY   1981.
25772C     UPDATED         --OCTOBER   1981.
25773C     UPDATED         --MAY       1982.
25774C     UPDATED         --JUNE      1990. TEMPORARY ARRAYS TO GARBAGE COMMON
25775C     UPDATED         --MARCH     1996. ADD IRHSTG
25776C     UPDATED         --MARCH     2007. ADD OPTION TO COMPUTE
25777C                                       HISTOGRAM FOR ENTIRE MATRIX
25778C     UPDATED         --JANUARY   2010. USE DPPARS
25779C     UPDATED         --JANUARY   2010. SUPPORT FOR "HIGHLIGHTED" OPTION
25780C     UPDATED         --JANUARY   2010. SUPPORT FOR NON-EQUISPACED
25781C                                       HISTOGRAMS
25782C     UPDATED         --JANUARY   2010. OPTION TO SUPPRESS EMPTY BINS
25783C     UPDATED         --JANUARY   2010. OPTION TO INCLUDE OUTLIERS
25784C     UPDATED         --FEBRUARY  2010. PLOT ROOTOGRAM WITH THIS
25785C                                       ROUTINE
25786C     UPDATED         --MARCH     2010. USE DPPAR3 FOR SINGLE RESPONSE
25787C                                       VARIABLE
25788C     UPDATED         --JULY      2019. TWEAK SCRATCH SPACE
25789C
25790C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
25791C
25792C
25793      CHARACTER*4 ICASPL
25794      CHARACTER*4 IAND1
25795      CHARACTER*4 IAND2
25796      CHARACTER*4 IBUGG2
25797      CHARACTER*4 IBUGG3
25798      CHARACTER*4 IBUGQ
25799      CHARACTER*4 ISUBRO
25800      CHARACTER*4 IFOUND
25801      CHARACTER*4 IERROR
25802C
25803      CHARACTER*4 IRELAT
25804      CHARACTER*4 ICUMUL
25805      CHARACTER*4 IHWUSE
25806      CHARACTER*4 MESSAG
25807      CHARACTER*4 IDATSW
25808      CHARACTER*4 IHP
25809      CHARACTER*4 IHP2
25810      CHARACTER*4 ISUBN1
25811      CHARACTER*4 ISUBN2
25812      CHARACTER*4 ISTEPN
25813CCCCC MARCH 1996.  ADD FOLLOWING LINE
25814      CHARACTER*4 IRHSTG
25815CCCCC SEPTEMBER 2004.  ADD FOLLOWING LINE
25816      CHARACTER*4 IHSTCW
25817      CHARACTER*4 IASHWT
25818      CHARACTER*4 IHSTEB
25819      CHARACTER*4 IHSTOU
25820      CHARACTER*4 IHSTOP
25821      CHARACTER*4 ICASE
25822      CHARACTER*4 IHIGH
25823C
25824      PARAMETER (MAXSPN=10)
25825      CHARACTER*4 IVARN1(MAXSPN)
25826      CHARACTER*4 IVARN2(MAXSPN)
25827      CHARACTER*4 IVARTY(MAXSPN)
25828      REAL PVAR(MAXSPN)
25829      INTEGER ILIS(MAXSPN)
25830      INTEGER NRIGHT(MAXSPN)
25831      INTEGER ICOLR(MAXSPN)
25832      CHARACTER*40 INAME
25833C
25834C---------------------------------------------------------------------
25835C
25836      DIMENSION CLLIMI(*)
25837      DIMENSION CLWIDT(*)
25838CCCCC DIMENSION BAWIDT(*)
25839C
25840      INCLUDE 'DPCOPA.INC'
25841CCCCC DIMENSION Y1(MAXOBV)
25842      DIMENSION Y1(20*MAXOBV)
25843      DIMENSION X1(MAXOBV)
25844      DIMENSION XHIGH(MAXOBV)
25845      DIMENSION XIDTEM(MAXOBV)
25846      DIMENSION XTEMP1(MAXOBV)
25847      DIMENSION XTEMP2(MAXOBV)
25848      DIMENSION XTEMP3(MAXOBV)
25849C
25850CCCCC FOLLOWING LINES ADDED JUNE, 1990
25851CCCCC MARCH 2007.  TO ACCOMODATE MATRIX HISTOGRAMS, MAKE DIMENSION
25852CCCCC              OF Y1 LARGE (20*MAXIMUM NUMBER OF ROWS) AND
25853CCCCC              CHANGE STORAGE ACCORDINGLY.
25854C
25855      INCLUDE 'DPCOZZ.INC'
25856      EQUIVALENCE (GARBAG(IGARB1),X1(1))
25857      EQUIVALENCE (GARBAG(IGARB2),XHIGH(1))
25858      EQUIVALENCE (GARBAG(IGARB3),XTEMP1(1))
25859      EQUIVALENCE (GARBAG(IGARB4),XTEMP2(1))
25860      EQUIVALENCE (GARBAG(IGARB5),XIDTEM(1))
25861      EQUIVALENCE (GARBAG(IGARB6),XTEMP3(1))
25862      EQUIVALENCE (GARBAG(IGARB7),Y1(1))
25863C
25864C-----COMMON----------------------------------------------------------
25865C
25866      INCLUDE 'DPCOHK.INC'
25867      INCLUDE 'DPCODA.INC'
25868      INCLUDE 'DPCOP2.INC'
25869C
25870C-----START POINT-----------------------------------------------------
25871C
25872      IFOUND='NO'
25873      IERROR='NO'
25874      ISUBN1='DPHI'
25875      ISUBN2='ST  '
25876C
25877      MAXCP1=MAXCOL+1
25878      MAXCP2=MAXCOL+2
25879      MAXCP3=MAXCOL+3
25880      MAXCP4=MAXCOL+4
25881      MAXCP5=MAXCOL+5
25882      MAXCP6=MAXCOL+6
25883C
25884C               *******************************************
25885C               **  TREAT THE HISTOGRAM AND RELATED      **
25886C               **  STATISTICAL DISTRIBUTION PLOTS CASE  **
25887C               *******************************************
25888C
25889      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'HIST')THEN
25890        WRITE(ICOUT,999)
25891  999   FORMAT(1X)
25892        CALL DPWRST('XXX','BUG ')
25893        WRITE(ICOUT,51)
25894   51   FORMAT('***** AT THE BEGINNING OF DPHIST--')
25895        CALL DPWRST('XXX','BUG ')
25896        WRITE(ICOUT,52)ICASPL,IAND1,IAND2
25897   52   FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4)
25898        CALL DPWRST('XXX','BUG ')
25899        WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ
25900   53   FORMAT('IBUGG2,IBUGG3,IBUGQ = ',A4,2X,A4,2X,A4)
25901        CALL DPWRST('XXX','BUG ')
25902      ENDIF
25903C
25904C               ***************************
25905C               **  STEP 1--             **
25906C               **  EXTRACT THE COMMAND  **
25907C               ***************************
25908C
25909      ISTEPN='1'
25910      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HIST')
25911     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25912C
25913
25914      IF(ICOM.EQ.'HIST')GOTO99
25915      IF(ICOM.EQ.'RELA')GOTO99
25916      IF(ICOM.EQ.'CUMU')GOTO99
25917      IF(ICOM.EQ.'HIGH')GOTO99
25918      IF(ICOM.EQ.'SUBS')GOTO99
25919      IF(ICOM.EQ.'ROOT')GOTO99
25920      IF(ICOM.EQ.'ASH ')GOTO99
25921      IF(ICOM.EQ.'AVER')GOTO99
25922      GOTO9000
25923C
25924   99 CONTINUE
25925      IRELAT='OFF'
25926      IHIGH='OFF'
25927      ICUMUL='OFF'
25928      ICASPL='    '
25929      ILASTC=0
25930C
25931      IF(NUMARG.GE.2.AND.ICOM.EQ.'AVER'.AND.
25932     1       IHARG(1).EQ.'SHIF'.AND.IHARG(2).EQ.'HIST')THEN
25933        IFOUND='YES'
25934        ICASPL='ASHR'
25935        IRELAT='ON'
25936        ILASTC=2
25937        GOTO119
25938      ELSEIF(NUMARG.GE.1.AND.ICOM.EQ.'ASH '.AND.
25939     1       IHARG(1).EQ.'HIST')THEN
25940        IFOUND='YES'
25941        ICASPL='ASHR'
25942        IRELAT='ON'
25943        ILASTC=1
25944        GOTO119
25945      ELSEIF(ICOM.EQ.'ASH ')THEN
25946        IFOUND='YES'
25947        ICASPL='ASHR'
25948        IRELAT='ON'
25949        GOTO119
25950      ENDIF
25951C
25952      IF(ICOM.EQ.'HIST')THEN
25953        ICASPL='HIST'
25954        IFOUND='YES'
25955        IPOSH=0
25956      ELSEIF(ICOM.EQ.'ROOT')THEN
25957        ICASPL='ROOT'
25958        IFOUND='YES'
25959      ELSEIF(ICOM.EQ.'RELA')THEN
25960        IRELAT='ON'
25961      ELSEIF(ICOM.EQ.'CUMU')THEN
25962        ICUMUL='ON'
25963      ELSEIF(ICOM.EQ.'HIGH' .OR. ICOM.EQ.'SUBS')THEN
25964        IHIGH='ON'
25965      ENDIF
25966C
25967C     NOTE: "SUBSET" AND "=" CAN APPEAR AS PART OF SUBSET
25968C           CLAUSE, SO NEED TO BE CAREFUL WHERE IT OCCURS
25969C           IN THE COMMAND.  HANDLE THIS BY REQUIRING THAT
25970C           THEY APPEAR BEFORE THE "HISTOGRAM" CLAUSE.
25971C
25972      DO110I=1,NUMARG
25973        IF(IHARG(I).EQ.'=' .AND. I.LT.IPOSH)THEN
25974          IFOUND='NO'
25975          GOTO9000
25976        ELSEIF(IHARG(I).EQ.'HIST')THEN
25977          ICASPL='HIST'
25978          ILASTC=I
25979          IFOUND='YES'
25980          IPOSH=I
25981        ELSEIF(IHARG(I).EQ.'ROOT')THEN
25982          ICASPL='ROOT'
25983          ILASTC=I
25984          IFOUND='YES'
25985        ELSEIF(IHARG(I).EQ.'RELA')THEN
25986          ILASTC=I
25987          IRELAT='ON'
25988        ELSEIF(IHARG(I).EQ.'CUMU')THEN
25989          ILASTC=I
25990          ICUMUL='ON'
25991        ELSEIF(IHARG(I).EQ.'HIGH' .OR. IHARG(I).EQ.'SUBS')THEN
25992          IF(I.LT.IPOSH)THEN
25993            ILASTC=I
25994            IHIGH='ON'
25995          ENDIF
25996        ENDIF
25997  110 CONTINUE
25998      IF(ICASPL.EQ.'HIST' .AND. ICUMUL.EQ.'ON')THEN
25999        ICASPL='CUMH'
26000      ELSEIF(ICASPL.EQ.'ROOT' .AND. ICUMUL.EQ.'ON')THEN
26001        ICASPL='CUMR'
26002      ENDIF
26003C
26004      IF((ICASPL.EQ.'ROOT' .OR. ICASPL.EQ.'CUMR') .AND.
26005     1   IRELAT.EQ.'ON')THEN
26006        WRITE(ICOUT,999)
26007        CALL DPWRST('XXX','BUG ')
26008        WRITE(ICOUT,5451)
26009 5451   FORMAT('****** ERROR IN ROOTOGRAM--')
26010        CALL DPWRST('XXX','BUG ')
26011        WRITE(ICOUT,131)
26012  131   FORMAT('      RELATIVE OPTION NOT CURRENTLY SUPPORTED FOR ',
26013     1         'THE ROOTOGRAM COMMAND.')
26014        CALL DPWRST('XXX','BUG ')
26015        IERROR='YES'
26016        GOTO9000
26017      ENDIF
26018C
26019  119 CONTINUE
26020      IF(ILASTC.GE.1)THEN
26021        CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
26022        ILASTC=0
26023      ENDIF
26024C
26025      IF(IFOUND.EQ.'NO')GOTO9000
26026C
26027      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'HIST')THEN
26028        WRITE(ICOUT,112)ICASPL,IRELAT,IHIGH
26029  112   FORMAT('ICASPL,IRELAT,IHIGH = ',A4,2X,A4,2X,A4)
26030        CALL DPWRST('XXX','BUG ')
26031      ENDIF
26032C
26033C               ****************************************
26034C               **  STEP 2--                          **
26035C               **  EXTRACT THE VARIABLE LIST         **
26036C               ****************************************
26037C
26038      ISTEPN='2'
26039      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HIST')
26040     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26041C
26042      INAME='HISTOGRAM'
26043      MINNA=1
26044      MAXNA=100
26045      MINN2=1
26046      IFLAGE=1
26047      IFLAGM=1
26048      IFLAGP=0
26049      JMIN=1
26050      JMAX=NUMARG
26051      MINNVA=1
26052      MAXNVA=3
26053      IF(IHIGH.EQ.'ON')THEN
26054        MINNVA=2
26055        MAXNVA=2
26056      ELSEIF(ICASPL.EQ.'ASHR')THEN
26057        MINNVA=1
26058        MAXNVA=1
26059      ENDIF
26060C
26061      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
26062     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
26063     1            JMIN,JMAX,
26064     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
26065     1            IVARN1,IVARN2,IVARTY,PVAR,
26066     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
26067     1            MINNVA,MAXNVA,
26068     1            IFLAGM,IFLAGP,
26069     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
26070      IF(IERROR.EQ.'YES')GOTO9000
26071C
26072      IF(IVARTY(1).EQ.'MATR')THEN
26073        ICASE='MATR'
26074        IDATSW='RAW'
26075        ILISR=ILIS(1)
26076        ICOL1=IVALUE(ILISR)
26077        ICOL2=IVALU2(ILISR)
26078        N1=IN(ILISR)
26079        NCOL=(ICOL2 - ICOL1) + 1
26080      ELSE
26081        ICASE='VARI'
26082        IF(NUMVAR.EQ.1 .OR. IHIGH.EQ.'ON')THEN
26083          IDATSW='RAW'
26084        ELSEIF(NUMVAR.EQ.2)THEN
26085          IDATSW='FREQ'
26086        ELSEIF(NUMVAR.EQ.3)THEN
26087          IDATSW='FRE2'
26088        ENDIF
26089      ENDIF
26090C
26091      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HIST')THEN
26092        WRITE(ICOUT,999)
26093        CALL DPWRST('XXX','BUG ')
26094        WRITE(ICOUT,281)
26095  281   FORMAT('***** AFTER CALL DPPARS--')
26096        CALL DPWRST('XXX','BUG ')
26097        WRITE(ICOUT,282)NQ,NUMVAR
26098  282   FORMAT('NQ,NUMVAR = ',2I8)
26099        CALL DPWRST('XXX','BUG ')
26100        IF(NUMVAR.GT.0)THEN
26101          DO285I=1,NUMVAR
26102            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
26103     1                      ICOLR(I)
26104  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
26105     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
26106            CALL DPWRST('XXX','BUG ')
26107  285     CONTINUE
26108        ENDIF
26109      ENDIF
26110C
26111      ICOL=1
26112      CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
26113     1            INAME,IVARN1,IVARN2,IVARTY,
26114     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
26115     1            MAXCOL,MAXCP1,MAXCP2,MAXCP3,
26116     1            MAXCP4,MAXCP5,MAXCP6,
26117     1            V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
26118     1            Y1,X1,XHIGH,NLOCAL,NLOCA2,NLOCA3,ICASE,
26119     1            IBUGG3,ISUBRO,IFOUND,IERROR)
26120      IF(IERROR.EQ.'YES')GOTO9000
26121C
26122C          ************************************************************
26123C          **  STEP 7--                                              **
26124C          **  DETERMINE IF THE ANALYST                              **
26125C          **  HAS SPECIFIED    1)  THE CLASS WIDTH,                 **
26126C          **                   2)  THE MIN POINT OF THE FIRST CELL, **
26127C          **                   3)  THE MAX POINT OF THE LAST  CELL, **
26128C          **  FOR THE DISTRIBUTIONAL ANALYSIS.                      **
26129C          **  IF NON-DEFAULT, USE THE SPECIFIED VALUES.             **
26130C          **  IF DEFAULT, USE THE DEFAULT VALUES--                  **
26131C          **     1)  CLASS WIDTH = .3 OF A SAMPLE STANDARD DEVIATION;*
26132C          **     2)  START = SAMPLE MEAN - 6*(SAMPLE STANDARD       **
26133C          **                 DEVIATION);                            **
26134C          **     3)  STOP  = SAMPLE MEAN + 6*(SAMPLE STANDARD       **
26135C          **                 DEVIATION);                            **
26136C          **  NOTE THAT THE DEFAULT SETTINGS ARE IN FACT            **
26137C          ************************************************************
26138C
26139      ISTEPN='7'
26140      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HIST')
26141     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26142C
26143      CLWID=CLWIDT(1)
26144      XSTART=CLLIMI(1)
26145      XSTOP=CLLIMI(2)
26146C
26147C     PARAMETER FOR ASH HISTROGRAM
26148C
26149      IHP='M   '
26150      IHP2='    '
26151      IHWUSE='P'
26152      MESSAG='NO'
26153      CALL CHECKN(IHP,IHP2,IHWUSE,
26154     1            IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
26155     1            ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
26156      IF(IERROR.EQ.'YES')THEN
26157        IF(NLOCAL.LE.100)THEN
26158          M=4
26159        ELSEIF(NLOCAL.LE.1000)THEN
26160          M=8
26161        ELSE
26162          M=16
26163        ENDIF
26164      ELSE
26165        M=INT(VALUE(ILOCP)+0.5)
26166        IF(M.LE.0)M=1
26167        IF(M.GT.64)M=64
26168      ENDIF
26169C
26170      DO5810I=1,MAXOBV
26171        X3D(I)=CPUMIN
26172 5810 CONTINUE
26173C
26174C               *****************************************************
26175C               **  STEP 8--                                       **
26176C               **  FORM THE VERTICAL AND HORIZONTAL AXIS          **
26177C               **  VALUES Y(.) AND X(.) FOR THE PLOT.             **
26178C               **  RESET THE VECTOR D(.) TO ALL ONES.             **
26179C               **  DEFINE THE NUMBER OF PLOT POINTS    (NPLOTP).  **
26180C               **  DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV).  **
26181C               *****************************************************
26182C
26183      CALL DPHIS2(Y1,X1,XHIGH,NLOCAL,
26184     1            ICASPL,IRELAT,IHIGH,IDATSW,CLWID,XSTART,XSTOP,
26185CCCCC             MARCH 1996.  ADD FOLLOWING LINE
26186     1            XTEMP1,XTEMP2,XTEMP3,XIDTEM,MAXOBV,
26187     1            IRHSTG,IHSTCW,IHSTEB,IHSTOU,IASHWT,M,IHSTMC,IHSTOP,
26188     1            Y,X,X3D,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR)
26189C
26190C               *****************
26191C               **  STEP 90--  **
26192C               **  EXIT       **
26193C               *****************
26194C
26195 9000 CONTINUE
26196      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'HIST')THEN
26197        WRITE(ICOUT,999)
26198        CALL DPWRST('XXX','BUG ')
26199        WRITE(ICOUT,9011)
26200 9011   FORMAT('***** AT THE END       OF DPHIST--')
26201        CALL DPWRST('XXX','BUG ')
26202        WRITE(ICOUT,9012)IFOUND,IERROR
26203 9012   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
26204        CALL DPWRST('XXX','BUG ')
26205        WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
26206 9013   FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',
26207     1         I8,I8,I8,2X,A4,2X,A4,2X,A4)
26208        CALL DPWRST('XXX','BUG ')
26209        WRITE(ICOUT,9014)IRELAT,CLWID,XSTART,XSTOP
26210 9014   FORMAT('IRELAT,CLWID,XSTART,XSTOP = ',A4,2X,3E15.7)
26211        CALL DPWRST('XXX','BUG ')
26212        IF(NPLOTP.GE.1)THEN
26213          DO9015I=1,NPLOTP
26214            WRITE(ICOUT,9016)I,Y(I),X(I),D(I)
26215 9016       FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5)
26216            CALL DPWRST('XXX','BUG ')
26217 9015     CONTINUE
26218        ENDIF
26219      ENDIF
26220C
26221      RETURN
26222      END
26223      SUBROUTINE DPHKCP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
26224     1                  IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
26225C
26226C     PURPOSE--GIVEN DATA OF THE FORM
26227C
26228C                 RESPONSE   LAB-ID  MAT-ID
26229C
26230C              GENERATE ONE OF THE FOLLOWING TYPES OF PLOTS
26231C
26232C                 H CONSISTENCY    PLOT Y LABID MATID
26233C                 K CONSISTENCY    PLOT Y LABID MATID
26234C                 COCHRAN VARIANCE PLOT Y LABID MATID
26235C
26236C                 H CONSISTENCY    PLOT Y MATID LABID
26237C                 K CONSISTENCY    PLOT Y MATID LABID
26238C                 COCHRAN VARIANCE PLOT Y MATID LABID
26239C
26240C              H AND K CONSISTENCY PLOTS ARE DISCUSSED IN THE
26241C              ASTM E-691 STANDARD.  THE ISO 5725 STANDARD
26242C              SUGGESTS COCHRAN'S VARIANCE OUTLIER TEST AS
26243C              AN ALTERNATIVE TO THE K CONSISTENCY STATISTIC.
26244C
26245C              YOU CAN REQUEST "LABORATORIES WITHIN MATERIALS" OR
26246C              "MATERIALS WITHIN LABORATORIES".  THIS IS DETERMINED
26247C              BY THE ORDER THE LAB AND MATERIAL VARIABLES ARE GIVEN.
26248C
26249C              THERE ARE TWO FORMATS FOR THE PLOT:
26250C
26251C              1) THE VALUES ARE PLOTTED LINEARLY.  THAT IS,
26252C
26253C                 LAB:  1  2  3  1  2  3  1  2  3
26254C                 MAT:  1  1  1  2  2  2  3  3  3
26255C
26256C              2) YOU CAN STACK THE LAB VALUES VERTICALLY
26257C
26258C                 LAB:  1  1  1
26259C                       2  2  2
26260C                       3  3  3
26261C                 MAT:  1  2  3
26262C
26263C              MULTIPLE AND REPLICATION OPTIONS ARE NOT SUPPORTED
26264C              FOR THIS PLOT.
26265C
26266C     EXAMPLE--H CONSISTENCY PLOT Y LABID MATID
26267C              K CONSISTENCY PLOT Y LABID MATID
26268C     WRITTEN BY--ALAN HECKERT
26269C                 STATISTICAL ENGINEERING DIVISION
26270C                 INFORMATION TECHNOLOGY LABORATORY
26271C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
26272C                 GAITHERSBURG, MD 20899-8980
26273C                 PHONE--301-975-2899
26274C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
26275C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
26276C     LANGUAGE--ANSI FORTRAN (1977)
26277C     VERSION NUMBER--2015/5
26278C     ORIGINAL VERSION--MAY        2015.
26279C
26280C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
26281C
26282      CHARACTER*4 ICASPL
26283      CHARACTER*4 IAND1
26284      CHARACTER*4 IAND2
26285      CHARACTER*4 IBUGG2
26286      CHARACTER*4 IBUGG3
26287      CHARACTER*4 IBUGQ
26288      CHARACTER*4 ISUBRO
26289      CHARACTER*4 IFOUND
26290      CHARACTER*4 IERROR
26291C
26292      CHARACTER*4 IH
26293      CHARACTER*4 IH2
26294      CHARACTER*4 ISUBN0
26295      CHARACTER*4 ISUBN1
26296      CHARACTER*4 ISUBN2
26297      CHARACTER*4 ISTEPN
26298C
26299      CHARACTER*40 INAME
26300      PARAMETER (MAXSPN=10)
26301      CHARACTER*4 IVARN1(MAXSPN)
26302      CHARACTER*4 IVARN2(MAXSPN)
26303      CHARACTER*4 IVARTY(MAXSPN)
26304      REAL PVAR(MAXSPN)
26305      INTEGER ILIS(MAXSPN)
26306      INTEGER NRIGHT(MAXSPN)
26307      INTEGER ICOLR(MAXSPN)
26308C
26309C---------------------------------------------------------------------
26310C
26311      INCLUDE 'DPCOPA.INC'
26312      INCLUDE 'DPCOZZ.INC'
26313      INCLUDE 'DPCOZI.INC'
26314C
26315      REAL Y1(MAXOBV)
26316      REAL MATID(MAXOBV)
26317      REAL LABID(MAXOBV)
26318      REAL XIDTEM(MAXOBV)
26319      REAL XIDTE2(MAXOBV)
26320      REAL TEMP1(MAXOBV)
26321      REAL TEMP2(MAXOBV)
26322      REAL TEMP3(MAXOBV)
26323      REAL TEMP4(MAXOBV)
26324      REAL TEMP5(MAXOBV)
26325      REAL TEMP6(MAXOBV)
26326      REAL TEMP7(MAXOBV)
26327      REAL TEMP8(MAXOBV)
26328C
26329      INTEGER ITEMP1(MAXOBV)
26330C
26331      EQUIVALENCE (GARBAG(IGARB1),Y1(1))
26332      EQUIVALENCE (GARBAG(IGARB2),MATID(1))
26333      EQUIVALENCE (GARBAG(IGARB3),LABID(1))
26334      EQUIVALENCE (GARBAG(IGARB4),XIDTEM(1))
26335      EQUIVALENCE (GARBAG(IGARB5),XIDTE2(1))
26336      EQUIVALENCE (GARBAG(IGARB6),TEMP1(1))
26337      EQUIVALENCE (GARBAG(IGARB7),TEMP2(1))
26338      EQUIVALENCE (GARBAG(IGARB8),TEMP3(1))
26339      EQUIVALENCE (GARBAG(IGARB9),TEMP4(1))
26340      EQUIVALENCE (GARBAG(IGAR10),TEMP5(1))
26341      EQUIVALENCE (GARBAG(JGAR11),TEMP6(1))
26342      EQUIVALENCE (GARBAG(JGAR12),TEMP7(1))
26343      EQUIVALENCE (GARBAG(JGAR13),TEMP8(1))
26344      EQUIVALENCE (IGARBG(IIGAR1),ITEMP1(1))
26345C
26346C-----COMMON----------------------------------------------------------
26347C
26348      INCLUDE 'DPCOST.INC'
26349      INCLUDE 'DPCOHO.INC'
26350      INCLUDE 'DPCOHK.INC'
26351      INCLUDE 'DPCODA.INC'
26352      INCLUDE 'DPCOP2.INC'
26353C
26354C-----START POINT-----------------------------------------------------
26355C
26356      IERROR='NO'
26357      IFOUND='NO'
26358      ISUBN1='DPHK'
26359      ISUBN2='CP  '
26360C
26361      MAXCP1=MAXCOL+1
26362      MAXCP2=MAXCOL+2
26363      MAXCP3=MAXCOL+3
26364      MAXCP4=MAXCOL+4
26365      MAXCP5=MAXCOL+5
26366      MAXCP6=MAXCOL+6
26367C
26368C               ****************************************
26369C               **  TREAT THE H CONSISTENCY PLOT CASE **
26370C               ****************************************
26371C
26372      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HKCP')THEN
26373        WRITE(ICOUT,999)
26374  999   FORMAT(1X)
26375        CALL DPWRST('XXX','BUG ')
26376        WRITE(ICOUT,51)
26377   51   FORMAT('***** AT THE BEGINNING OF DPHKCP--')
26378        CALL DPWRST('XXX','BUG ')
26379        WRITE(ICOUT,52)IBUGG2,IBUGG3,IBUGQ,ISUBRO
26380   52   FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',3(A4,2X),A4)
26381        CALL DPWRST('XXX','BUG ')
26382        WRITE(ICOUT,53)ICASPL,IAND1,IAND2,MAXN
26383   53   FORMAT('ICASPL,IAND1,IAND2,MAXN = ',3(A4,2X),I8)
26384        CALL DPWRST('XXX','BUG ')
26385      ENDIF
26386C
26387C               ***************************
26388C               **  STEP 1--             **
26389C               **  EXTRACT THE COMMAND  **
26390C               ***************************
26391C
26392      ISTEPN='11'
26393      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HKCP')
26394     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26395C
26396      IF(NUMARG.GE.2.AND.ICOM.EQ.'H   '.AND.IHARG(1).EQ.'CONS'.AND.
26397     1  IHARG(2).EQ.'PLOT')THEN
26398        ILASTC=2
26399        ICASPL='HCON'
26400      ELSEIF(NUMARG.GE.2.AND.ICOM.EQ.'K   '.AND.IHARG(1).EQ.'CONS'.AND.
26401     1  IHARG(2).EQ.'PLOT')THEN
26402        ILASTC=2
26403        ICASPL='KCON'
26404      ELSEIF(NUMARG.GE.2.AND.ICOM.EQ.'COCH'.AND.IHARG(1).EQ.'VARI'.AND.
26405     1  IHARG(2).EQ.'PLOT')THEN
26406        ILASTC=2
26407        ICASPL='CVOT'
26408      ELSE
26409        GOTO9000
26410      ENDIF
26411C
26412      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
26413      IFOUND='YES'
26414C
26415C               ****************************************
26416C               **  STEP 2--                          **
26417C               **  EXTRACT THE VARIABLE LIST         **
26418C               ****************************************
26419C
26420      ISTEPN='2'
26421      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HKCP')
26422     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26423C
26424      INAME='H CONSISTENCY PLOT'
26425      IF(ICASPL.EQ.'KCON')INAME='K CONSISTENCY PLOT'
26426      IF(ICASPL.EQ.'CVOT')INAME='COCHRAN VARIANCE PLOT'
26427      MINNA=3
26428      MAXNA=100
26429      MINN2=5
26430      IFLAGE=1
26431      IFLAGM=0
26432      IFLAGP=0
26433      JMIN=1
26434      JMAX=NUMARG
26435      MINNVA=3
26436      MAXNVA=3
26437C
26438      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
26439     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
26440     1            JMIN,JMAX,
26441     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
26442     1            IVARN1,IVARN2,IVARTY,PVAR,
26443     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
26444     1            MINNVA,MAXNVA,
26445     1            IFLAGM,IFLAGP,
26446     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
26447      IF(IERROR.EQ.'YES')GOTO9000
26448C
26449      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HKCP')THEN
26450        WRITE(ICOUT,999)
26451        CALL DPWRST('XXX','BUG ')
26452        WRITE(ICOUT,281)
26453  281   FORMAT('***** AFTER CALL DPPARS--')
26454        CALL DPWRST('XXX','BUG ')
26455        WRITE(ICOUT,282)NQ,NUMVAR
26456  282   FORMAT('NQ,NUMVAR = ',2I8)
26457        CALL DPWRST('XXX','BUG ')
26458        IF(NUMVAR.GT.0)THEN
26459          DO285I=1,NUMVAR
26460            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
26461     1                      ICOLR(I),IVARTY(I)
26462  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
26463     1             'ICOLR(I),IVARTY(I) = ',I8,2X,A4,A4,2X,3I8,2X,A4)
26464            CALL DPWRST('XXX','BUG ')
26465  285     CONTINUE
26466        ENDIF
26467      ENDIF
26468C
26469C               **********************************************
26470C               **  STEP 33--                               **
26471C               **  FORM THE SUBSETTED VARIABLES            **
26472C               **       Y(.)                               **
26473C               **       LABID(.)                           **
26474C               **       MATID(.)                           **
26475C               **********************************************
26476C
26477      ISTEPN='33'
26478      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HKCP')
26479     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26480C
26481      ICOL=1
26482      CALL DPPAR5(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
26483     1            INAME,IVARN1,IVARN2,IVARTY,
26484     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
26485     1            MAXCOL,MAXCP1,MAXCP2,MAXCP3,
26486     1            MAXCP4,MAXCP5,MAXCP6,
26487     1            V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
26488     1            Y1,LABID,MATID,XIDTEM,XIDTEM,XIDTEM,XIDTEM,NS,
26489     1            IBUGG3,ISUBRO,IFOUND,IERROR)
26490      IF(IERROR.EQ.'YES')GOTO9000
26491C
26492C               *******************************************************
26493C               **  STEP 8--                                         **
26494C               **  FORM THE VERTICAL AND HORIZONTAL AXIS            **
26495C               **  VALUES Y(.) AND X(.) FOR THE PLOT.               **
26496C               **  DEFINE THE NUMBER OF PLOT POINTS    (NPLOTP).    **
26497C               **  DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV).    **
26498C               *******************************************************
26499C
26500      ISTEPN='5'
26501      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HKCP')
26502     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26503C
26504      CALL DPHKC2(Y1,LABID,MATID,NS,NUMVAR,ICASPL,
26505     1            IHKCPT,IHKCGP,IHKCLM,
26506     1            IHKCM1,IHKCM2,IHKCL1,IHKCL2,
26507     1            XIDTEM,XIDTE2,TEMP1,TEMP2,
26508     1            TEMP3,TEMP4,TEMP5,ITEMP1,
26509     1            TEMP6,TEMP7,TEMP8,
26510     1            Y,X,D,HCV,AKCV,ACV,
26511     1            NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR)
26512C
26513      IF(ICASPL.EQ.'HCON')THEN
26514        IH='HCV '
26515        IH2='    '
26516        VALUE0=HCV
26517        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
26518     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
26519     1              IANS,IWIDTH,IBUGG3,IERROR)
26520      ELSEIF(ICASPL.EQ.'KCON')THEN
26521        IH='KCV '
26522        IH2='    '
26523        VALUE0=AKCV
26524        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
26525     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
26526     1              IANS,IWIDTH,IBUGG3,IERROR)
26527      ELSEIF(ICASPL.EQ.'CVOT')THEN
26528        IH='CVOT'
26529        IH2='CV  '
26530        VALUE0=ACV
26531        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
26532     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
26533     1              IANS,IWIDTH,IBUGG3,IERROR)
26534      ENDIF
26535C
26536C               *****************
26537C               **  STEP 9--   **
26538C               **  EXIT       **
26539C               *****************
26540C
26541 9000 CONTINUE
26542      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HKCP')THEN
26543        WRITE(ICOUT,999)
26544        CALL DPWRST('XXX','BUG ')
26545        WRITE(ICOUT,9011)
26546 9011   FORMAT('***** AT THE END       OF DPHKCP--')
26547        CALL DPWRST('XXX','BUG ')
26548        WRITE(ICOUT,9013)IFOUND,IERROR
26549 9013   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
26550        CALL DPWRST('XXX','BUG ')
26551        WRITE(ICOUT,9014)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
26552 9014   FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',3I8,3(2X,A4))
26553        CALL DPWRST('XXX','BUG ')
26554      ENDIF
26555C
26556      RETURN
26557      END
26558      SUBROUTINE DPHKC2(Y1,LABID,MATID,N,NUMVAR,ICASPL,
26559     1                  IHKCPT,IHKCGP,IHKCLM,
26560     1                  IHKCM1,IHKCM2,IHKCL1,IHKCL2,
26561     1                  XIDTEM,XIDTE2,TEMP1,TEMP2,
26562     1                  XTEMP1,G,V,ITEMP1,
26563     1                  YOUT,TAGLAB,TAGMAT,
26564     1                  Y,X,D,HCV,AKCV,ACV,
26565     1                  NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR)
26566C
26567C     PURPOSE--GIVEN DATA OF THE FORM
26568C
26569C                 RESPONSE   LAB-ID  MAT-ID
26570C
26571C              GENERATE ONE OF THE FOLLOWING TYPES OF PLOTS
26572C
26573C                 H CONSISTENCY    PLOT Y LABID MATID
26574C                 K CONSISTENCY    PLOT Y LABID MATID
26575C                 COCHRAN VARIANCE PLOT Y LABID MATID
26576C
26577C                 H CONSISTENCY    PLOT Y MATID LABID
26578C                 K CONSISTENCY    PLOT Y MATID LABID
26579C                 COCHRAN VARIANCE PLOT Y MATID LABID
26580C
26581C              H AND K CONSISTENCY PLOTS ARE DISCUSSED IN THE
26582C              ASTM E-691 STANDARD.  THE ISO 5725 STANDARD
26583C              SUGGESTS COCHRAN'S VARIANCE OUTLIER TEST AS
26584C              AN ALTERNATIVE TO THE K CONSISTENCY STATISTIC.
26585C
26586C              YOU CAN REQUEST "LABORATORIES WITHIN MATERIALS" OR
26587C              "MATERIALS WITHIN LABORATORIES".  THIS IS DETERMINED
26588C              BY THE ORDER THE LAB AND MATERIAL VARIABLES ARE GIVEN.
26589C
26590C              THERE ARE TWO FORMATS FOR THE PLOT:
26591C
26592C              1) THE VALUES ARE PLOTTED LINEARLY.  THAT IS,
26593C
26594C                 LAB:  1  2  3  1  2  3  1  2  3
26595C                 MAT:  1  1  1  2  2  2  3  3  3
26596C
26597C              2) YOU CAN STACK THE LAB VALUES VERTICALLY
26598C
26599C                 LAB:  1  1  1
26600C                       2  2  2
26601C                       3  3  3
26602C                 MAT:  1  2  3
26603C
26604C              MULTIPLE AND REPLICATION OPTIONS ARE NOT SUPPORTED
26605C              FOR THIS PLOT.
26606C
26607C     REFERENCES--"Standard Practice for Conducting an Interlaboratory
26608C                 Study to Determine the Precision of a Test Method",
26609C                 ASTM International, 100 Barr Harbor Drive, PO BOX C700,
26610C                 West Conshohoceken, PA 19428-2959, USA.
26611C               --ISO Standard 5725–2:1994, “Accuracy (trueness and
26612C                 precision) of measurement methods and results – Part 2:
26613C                 Basic method for the determination of repeatability and
26614C                 reproducibility of a standard measurement method”,
26615C                 International Organization for Standardization,
26616C                 Geneva, Switzerland, 1994;
26617C               --Mandel (1994), "Analyzing Interlaboratory Data
26618C                 According to ASTM Standard E691", Quality and
26619C                 Statistics: Total Quality Management,ASTM STP 1209,
26620C                 Kowalewski, Ed., American Society for Testing and
26621C                 Materials, Philadelphia, PA 1994, pp. 59-70.
26622C               --Mandel (1995), "Structure and Outliers in
26623C                 Interlaboratory Studies", Journal of Testing and
26624C                 Evaluation, Vol. 23, No. 5, pp. 364-369.
26625C               --Mandel (1991), "Evaluation and Control of
26626C                 Measurements", Marcel Dekker, Inc., chapter 7.
26627C     WRITTEN BY--ALAN HECKERT
26628C                 STATISTICAL ENGINEERING DIVISION
26629C                 INFORMATION TECHNOLOGY LABORATORY
26630C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
26631C                 GAITHERSBURG, MD 20899-8980
26632C                 PHONE--301-975-2899
26633C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
26634C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
26635C     LANGUAGE--ANSI FORTRAN (1977)
26636C     VERSION NUMBER--2015/5
26637C     ORIGINAL VERSION--MAY       2015.
26638C
26639C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
26640C
26641      CHARACTER*4 ICASPL
26642      CHARACTER*4 IHKCPT
26643      CHARACTER*4 IHKCLM
26644      CHARACTER*4 IBUGG3
26645      CHARACTER*4 ISUBRO
26646      CHARACTER*4 IERROR
26647C
26648      CHARACTER*4 IWRITE
26649      CHARACTER*4 ISUBN1
26650      CHARACTER*4 ISUBN2
26651      CHARACTER*4 ICASAN
26652C
26653C---------------------------------------------------------------------
26654C
26655      REAL Y1(*)
26656      REAL MATID(*)
26657      REAL LABID(*)
26658      REAL XIDTEM(*)
26659      REAL XIDTE2(*)
26660      REAL TEMP1(*)
26661      REAL TEMP2(*)
26662      REAL YOUT(*)
26663      REAL TAGLAB(*)
26664      REAL TAGMAT(*)
26665      REAL XTEMP1(*)
26666      REAL G(*)
26667      REAL V(*)
26668C
26669      REAL Y(*)
26670      REAL X(*)
26671      REAL D(*)
26672C
26673      INTEGER ITEMP1(*)
26674C
26675      PARAMETER(NUMALP=15)
26676      DIMENSION ALPHAV(NUMALP)
26677      DIMENSION CV(NUMALP)
26678C
26679C---------------------------------------------------------------------
26680C
26681      INCLUDE 'DPCOP2.INC'
26682C
26683      DATA ALPHAV/
26684     1 0.1, 0.5, 1.0, 2.5, 5.0, 10.0, 25.0,
26685     1 50.0,
26686     1 75.0, 90.0, 95.0, 97.5, 99.0, 99.5, 99.9/
26687C
26688C-----START POINT-----------------------------------------------------
26689C
26690      ISUBN1='DPHK'
26691      ISUBN2='C2  '
26692      IWRITE='OFF'
26693      IERROR='NO'
26694      NPLOTP=0
26695      NPLOTV=3
26696      HCV=CPUMIN
26697      AKCV=CPUMIN
26698      ACV=CPUMIN
26699C
26700      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'HKC2')THEN
26701        WRITE(ICOUT,999)
26702        CALL DPWRST('XXX','BUG ')
26703        WRITE(ICOUT,71)
26704   71   FORMAT('***** AT THE BEGINNING OF DPHKC2--')
26705        CALL DPWRST('XXX','BUG ')
26706        WRITE(ICOUT,72)IBUGG3,ISUBRO,ICASPL,N,NUMVAR
26707   72   FORMAT('IBUGG3,ISUBRO,ICASPL,N,NUMVAR = ',3(A4,2X),2I8)
26708        CALL DPWRST('XXX','BUG ')
26709        IF(N.GT.0)THEN
26710          DO81I=1,N
26711            WRITE(ICOUT,82)I,Y1(I),MATID(I),LABID(I)
26712   82       FORMAT('I,Y1(I),MATID(I),LABID(I) = ',I8,3G15.7)
26713            CALL DPWRST('XXX','BUG ')
26714   81     CONTINUE
26715        ENDIF
26716      ENDIF
26717C
26718C               ********************************************
26719C               **  STEP 1--                              **
26720C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
26721C               ********************************************
26722C
26723      IF(N.LT.5)THEN
26724        WRITE(ICOUT,999)
26725  999   FORMAT(1X)
26726        CALL DPWRST('XXX','BUG ')
26727        WRITE(ICOUT,31)
26728   31   FORMAT('***** ERROR IN H/K CONSISTENCY PLOT--')
26729        CALL DPWRST('XXX','BUG ')
26730        WRITE(ICOUT,32)
26731   32   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 5.')
26732        CALL DPWRST('XXX','BUG ')
26733        WRITE(ICOUT,34)N
26734   34   FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6)
26735        CALL DPWRST('XXX','BUG ')
26736        WRITE(ICOUT,999)
26737        CALL DPWRST('XXX','BUG ')
26738        IERROR='YES'
26739        GOTO9000
26740      ENDIF
26741C
26742C
26743C               ********************************************
26744C               **  STEP 2--                              **
26745C               **  GENERATE THE PLOT COORDINATES.        **
26746C               ********************************************
26747C
26748C       NOTE: TYPICALLY, WE WANT TO COMPUTE THE H AND K CONSISTENCY
26749C             STATISTICS BASED ON ALL LAB's AND MATERIALS.  HOWEVER,
26750C             WE SOMETIMES WANT TO RESTRICT THE PLOT TO A SUBSET
26751C             OF MATERIALS OR LABORATORIES FOR BETTER PLOT
26752C             RESOLUTION.
26753C
26754C             TO ADDRESS THIS, THE FOLLOWING COMMANDS WERE ADDED:
26755C
26756C                 SET H CONSISTENCY PLOT MATERIAL   FIRST <value>
26757C                 SET H CONSISTENCY PLOT MATERIAL   LAST  <value>
26758C                 SET H CONSISTENCY PLOT LABOTATORY FIRST <value>
26759C                 SET H CONSISTENCY PLOT LABORATORY LAST  <value>
26760C
26761C              SO A SUBSET CLAUSE ON THE PLOT COMMAND WILL LIMIT
26762C              WHAT MATERIALS AND LAB's ARE USED TO COMPUTE THE
26763C              H/K CONSISTENCY STATISTICS.  THE ABOVE SET COMMANDS
26764C              DO NOT RESTRICT WHICH MATERIALS AND LAB's ARE USED
26765C              IN COMPUTING THE STATISTICS.  HOWEVER, IT DOES LIMIT
26766C              WHICH MATERIALS AND LAB's ARE ACTUALLY DISPLAYED.
26767C
26768      IWRITE='OFF'
26769      IF(ICASPL.EQ.'HCON')THEN
26770        CALL HCONS2(Y1,LABID,MATID,XIDTEM,XIDTE2,TEMP1,TEMP2,N,IWRITE,
26771     1              YOUT,TAGMAT,TAGLAB,NTOT,
26772     1              ISUBRO,IBUGG3,IERROR)
26773        CALL DISTIN(TAGLAB,NTOT,IWRITE,XIDTEM,NLAB,IBUGG3,IERROR)
26774        CALL DISTIN(TAGMAT,NTOT,IWRITE,XIDTE2,NMAT,IBUGG3,IERROR)
26775        NTOT=NLAB*NMAT
26776        IMAT1=IHKCM1
26777        IF(IMAT1.LT.1 .OR. IMAT1.GT.NMAT)IMAT1=1
26778        IMAT2=IHKCM2
26779        IF(IMAT2.LT.1 .OR. IMAT2.GT.NMAT)IMAT2=NMAT
26780        ILAB1=IHKCL1
26781        IF(ILAB1.LT.1 .OR. ILAB1.GT.NLAB)ILAB1=1
26782        ILAB2=IHKCL2
26783        IF(ILAB2.LT.1 .OR. ILAB2.GT.NLAB)ILAB2=NLAB
26784        IF(IMAT1.GT.IMAT2)IMAT1=IMAT2
26785        IF(ILAB1.GT.ILAB2)ILAB1=ILAB2
26786C
26787        NPLOTP=0
26788C
26789        IF(IHKCPT.EQ.'DEFA')THEN
26790          IXCNT=0
26791          IXCNT2=0
26792          IF(IHKCLM.EQ.'LABO')THEN
26793            DO1010J=1,NMAT
26794              DO1020I=1,NLAB
26795                IXCNT=IXCNT+1
26796                IF(J.LT.IMAT1 .OR. J.GT.IMAT2)GOTO1020
26797                IF(I.LT.ILAB1 .OR. I.GT.ILAB2)GOTO1020
26798                IXCNT2=IXCNT2+1
26799                NPLOTP=NPLOTP+1
26800                Y(NPLOTP)=YOUT(IXCNT)
26801                X(NPLOTP)=REAL(IXCNT2)
26802                D(NPLOTP)=1.0
26803 1020         CONTINUE
26804              IF(IHKCGP.GT.0 .AND. J.LT.NMAT)IXCNT2=IXCNT2+IHKCGP
26805 1010       CONTINUE
26806            ITAG=1
26807            NLAST=IXCNT2
26808          ELSE
26809            DO1030J=1,NLAB
26810              DO1040I=1,NMAT
26811                IF(J.LT.ILAB1 .OR. J.GT.ILAB2)GOTO1040
26812                IF(I.LT.IMAT1 .OR. I.GT.IMAT2)GOTO1040
26813                IXCNT=IXCNT+1
26814                IXCNT2=IXCNT2+1
26815                IXCNT3=(I-1)*NLAB + J
26816                NPLOTP=NPLOTP+1
26817                Y(NPLOTP)=YOUT(IXCNT3)
26818                X(NPLOTP)=REAL(IXCNT2)
26819                D(NPLOTP)=1.0
26820 1040         CONTINUE
26821              IF(IHKCGP.GT.0 .AND. J.LT.NMAT)IXCNT2=IXCNT2+IHKCGP
26822 1030       CONTINUE
26823            ITAG=1
26824            NLAST=IXCNT2
26825          ENDIF
26826        ELSE
26827          IXCNT=0
26828          IF(IHKCLM.EQ.'LABO')THEN
26829            DO1110J=1,NMAT
26830              DO1120I=1,NLAB
26831                IXCNT=IXCNT+1
26832                IF(J.LT.IMAT1 .OR. J.GT.IMAT2)GOTO1120
26833                IF(I.LT.ILAB1 .OR. I.GT.ILAB2)GOTO1120
26834                NPLOTP=NPLOTP+1
26835                Y(NPLOTP)=YOUT(IXCNT)
26836                X(NPLOTP)=REAL(J)
26837                D(NPLOTP)=REAL(I)
26838 1120         CONTINUE
26839 1110       CONTINUE
26840            ITAG=NLAB
26841            NLAST=NMAT
26842          ELSE
26843            DO1130J=1,NLAB
26844              DO1140I=1,NMAT
26845                IF(J.LT.ILAB1 .OR. J.GT.ILAB2)GOTO1140
26846                IF(I.LT.IMAT1 .OR. I.GT.IMAT2)GOTO1140
26847                IXCNT=IXCNT+1
26848                NPLOTP=NPLOTP+1
26849                IXCNT3=(I-1)*NLAB + J
26850                Y(NPLOTP)=YOUT(IXCNT3)
26851                X(NPLOTP)=REAL(J)
26852                D(NPLOTP)=REAL(I)
26853 1140         CONTINUE
26854 1130       CONTINUE
26855            ITAG=NMAT
26856            NLAST=NLAB
26857          ENDIF
26858        ENDIF
26859C
26860C       NOW ADD CRITICAL VALUES TO PLOT
26861C
26862        ITAG=ITAG+1
26863        NPLOTP=NPLOTP+1
26864        Y(NPLOTP)=0
26865        X(NPLOTP)=1.0
26866        D(NPLOTP)=REAL(ITAG)
26867        NPLOTP=NPLOTP+1
26868        Y(NPLOTP)=0
26869        X(NPLOTP)=REAL(NLAST)
26870        D(NPLOTP)=REAL(ITAG)
26871        ITAG=ITAG+1
26872        DF=REAL(NLAB-2)
26873        ALPHA=1.0 - (0.005/2)
26874        CALL TPPF(ALPHA,DF,TVAL)
26875        TERM1=REAL(NLAB)*(TVAL**2 + REAL(NLAB) - 2.0)
26876        HCV=REAL(NLAB-1)*TVAL/SQRT(TERM1)
26877        IDIGIT=2
26878        HCV=RND(HCV,IDIGIT)
26879        NPLOTP=NPLOTP+1
26880        Y(NPLOTP)=HCV
26881        X(NPLOTP)=1.0
26882        D(NPLOTP)=REAL(ITAG)
26883        NPLOTP=NPLOTP+1
26884        Y(NPLOTP)=HCV
26885        X(NPLOTP)=REAL(NLAST)
26886        D(NPLOTP)=REAL(ITAG)
26887        ITAG=ITAG+1
26888        NPLOTP=NPLOTP+1
26889        Y(NPLOTP)=-HCV
26890        X(NPLOTP)=1.0
26891        D(NPLOTP)=REAL(ITAG)
26892        NPLOTP=NPLOTP+1
26893        Y(NPLOTP)=-HCV
26894        X(NPLOTP)=REAL(NLAST)
26895        D(NPLOTP)=REAL(ITAG)
26896C
26897      ELSEIF(ICASPL.EQ.'KCON')THEN
26898        CALL KCONS2(Y1,LABID,MATID,XIDTEM,XIDTE2,TEMP1,N,
26899     1              IWRITE,YOUT,TAGMAT,TAGLAB,NTOT,
26900     1              ISUBRO,IBUGG3,IERROR)
26901        CALL DISTIN(TAGLAB,NTOT,IWRITE,XIDTEM,NLAB,IBUGG3,IERROR)
26902        CALL DISTIN(TAGMAT,NTOT,IWRITE,XIDTE2,NMAT,IBUGG3,IERROR)
26903        NTOT=NLAB*NMAT
26904        IMAT1=IHKCM1
26905        IF(IMAT1.LT.1 .OR. IMAT1.GT.NMAT)IMAT1=1
26906        IMAT2=IHKCM2
26907        IF(IMAT2.LT.1 .OR. IMAT2.GT.NMAT)IMAT2=NMAT
26908        ILAB1=IHKCL1
26909        IF(ILAB1.LT.1 .OR. ILAB1.GT.NLAB)ILAB1=1
26910        ILAB2=IHKCL2
26911        IF(ILAB2.LT.1 .OR. ILAB2.GT.NLAB)ILAB2=NLAB
26912        IF(IMAT1.GT.IMAT2)IMAT1=IMAT2
26913        IF(ILAB1.GT.ILAB2)ILAB1=ILAB2
26914C
26915        NPLOTP=0
26916C
26917        IF(IHKCPT.EQ.'DEFA')THEN
26918          IXCNT=0
26919          IXCNT2=0
26920          IF(IHKCLM.EQ.'LABO')THEN
26921            DO2010J=1,NMAT
26922              DO2020I=1,NLAB
26923                IXCNT=IXCNT+1
26924                IF(J.LT.IMAT1 .OR. J.GT.IMAT2)GOTO2020
26925                IF(I.LT.ILAB1 .OR. I.GT.ILAB2)GOTO2020
26926                IXCNT2=IXCNT2+1
26927                NPLOTP=NPLOTP+1
26928                Y(NPLOTP)=YOUT(IXCNT)
26929                X(NPLOTP)=REAL(IXCNT2)
26930                D(NPLOTP)=1.0
26931 2020         CONTINUE
26932              IF(IHKCGP.GT.0 .AND. J.LT.NMAT)IXCNT2=IXCNT2+IHKCGP
26933 2010       CONTINUE
26934            ITAG=1
26935            NLAST=IXCNT2
26936          ELSE
26937            DO2030J=1,NLAB
26938              DO2040I=1,NMAT
26939                IF(J.LT.ILAB1 .OR. J.GT.ILAB2)GOTO2040
26940                IF(I.LT.IMAT1 .OR. I.GT.IMAT2)GOTO2040
26941                IXCNT=IXCNT+1
26942                IXCNT2=IXCNT2+1
26943                IXCNT3=(I-1)*NLAB + J
26944                NPLOTP=NPLOTP+1
26945                Y(NPLOTP)=YOUT(IXCNT3)
26946                X(NPLOTP)=REAL(IXCNT2)
26947                D(NPLOTP)=1.0
26948 2040         CONTINUE
26949              IF(IHKCGP.GT.0 .AND. J.LT.NMAT)IXCNT2=IXCNT2+IHKCGP
26950 2030       CONTINUE
26951            ITAG=1
26952            NLAST=IXCNT2
26953          ENDIF
26954        ELSE
26955          IXCNT=0
26956          IF(IHKCLM.EQ.'LABO')THEN
26957            DO2110J=1,NMAT
26958              DO2120I=1,NLAB
26959                IXCNT=IXCNT+1
26960                IF(J.LT.IMAT1 .OR. J.GT.IMAT2)GOTO2120
26961                IF(I.LT.ILAB1 .OR. I.GT.ILAB2)GOTO2120
26962                NPLOTP=NPLOTP+1
26963                Y(NPLOTP)=YOUT(IXCNT)
26964                X(NPLOTP)=REAL(J)
26965                D(NPLOTP)=REAL(I)
26966 2120         CONTINUE
26967 2110       CONTINUE
26968            ITAG=NLAB
26969            NLAST=NMAT
26970          ELSE
26971            DO2130J=1,NLAB
26972              DO2140I=1,NMAT
26973                IF(J.LT.ILAB1 .OR. J.GT.ILAB2)GOTO2140
26974                IF(I.LT.IMAT1 .OR. I.GT.IMAT2)GOTO2140
26975                IXCNT=IXCNT+1
26976                NPLOTP=NPLOTP+1
26977                IXCNT3=(I-1)*NLAB + J
26978                Y(NPLOTP)=YOUT(IXCNT3)
26979                X(NPLOTP)=REAL(J)
26980                D(NPLOTP)=REAL(I)
26981 2140         CONTINUE
26982 2130       CONTINUE
26983            ITAG=NMAT
26984            NLAST=NLAB
26985          ENDIF
26986        ENDIF
26987C
26988C       NOW ADD CRITICAL VALUES TO PLOT
26989C
26990        ITAG=ITAG+1
26991        NPLOTP=NPLOTP+1
26992        Y(NPLOTP)=0
26993        X(NPLOTP)=1.0
26994        D(NPLOTP)=REAL(ITAG)
26995        ITAG=ITAG+1
26996        NPLOTP=NPLOTP+1
26997        Y(NPLOTP)=0
26998        X(NPLOTP)=REAL(NLAST)
26999        D(NPLOTP)=REAL(ITAG)
27000        ITAG=ITAG+1
27001        NCELL=N/NTOT
27002        IDF1=NCELL - 1
27003        IDF2=(NCELL - 1)*(NLAB-1)
27004        ALPHA=1.0 - 0.005
27005        CALL FPPF(ALPHA,IDF1,IDF2,FVAL)
27006        ANUM=REAL(NLAB)
27007        DENOM=1.0 + REAL(NLAB-1)/FVAL
27008        AKCV=SQRT(ANUM/DENOM)
27009        IDIGIT=2
27010        AKCV=RND(AKCV,IDIGIT)
27011        NPLOTP=NPLOTP+1
27012        Y(NPLOTP)=AKCV
27013        X(NPLOTP)=1.0
27014        D(NPLOTP)=REAL(ITAG)
27015        NPLOTP=NPLOTP+1
27016        Y(NPLOTP)=AKCV
27017        X(NPLOTP)=REAL(NLAST)
27018        D(NPLOTP)=REAL(ITAG)
27019C
27020      ELSEIF(ICASPL.EQ.'CVOT')THEN
27021C
27022C       THE DPCVO3 ROUTINE COMPUTES THE COCHRAN VARIANCE
27023C       OUTLIER TEST FOR A SINGLE MATERIAL.  SO NEED TO
27024C       PROCESS EACH MATERIAL SEPARATELY.
27025C
27026C       DUE TO ABOVE, THIS VARIANT DOES NOT SUPPORT THE
27027C       "MATERIALS WITHIN LABORATORIES" OPTION.
27028C
27029        ICASAN='UPPE'
27030        CALL DISTIN(MATID,N,IWRITE,XIDTE2,NMAT,IBUGG3,IERROR)
27031        CALL SORT(XIDTE2,NMAT,XIDTE2)
27032        CALL DISTIN(LABID,N,IWRITE,XIDTEM,NLAB,IBUGG3,IERROR)
27033        IMAT1=IHKCM1
27034        IF(IMAT1.LT.1 .OR. IMAT1.GT.NMAT)IMAT1=1
27035        IMAT2=IHKCM2
27036        IF(IMAT2.LT.1 .OR. IMAT2.GT.NMAT)IMAT2=NMAT
27037        ILAB1=IHKCL1
27038        IF(ILAB1.LT.1 .OR. ILAB1.GT.NLAB)ILAB1=1
27039        ILAB2=IHKCL2
27040        IF(ILAB2.LT.1 .OR. ILAB2.GT.NLAB)ILAB2=NLAB
27041        IF(IMAT1.GT.IMAT2)IMAT1=IMAT2
27042        IF(ILAB1.GT.ILAB2)ILAB1=ILAB2
27043        NPLOTP=0
27044        IXCNT=0
27045        ITAG=1
27046C
27047        DO2210J=1,NMAT
27048          HOLD=XIDTE2(J)
27049          ICNT=0
27050          DO2220I=1,N
27051            IF(MATID(I).EQ.HOLD)THEN
27052              ICNT=ICNT+1
27053              TEMP1(ICNT)=Y1(I)
27054              TEMP2(ICNT)=LABID(I)
27055            ENDIF
27056 2220     CONTINUE
27057          CALL SORTC(TEMP2,TEMP1,ICNT,TEMP2,XTEMP1)
27058          DO2225I=1,ICNT
27059            TEMP1(I)=XTEMP1(I)
27060 2225     CONTINUE
27061C
27062C         COMPUTE COCHRAN STATISTIC FOR CURRENT MAT-ID.
27063C
27064          CALL DPCVO3(TEMP1,TEMP2,ICNT,ICASAN,
27065     1                XTEMP1,XIDTEM,G,V,ITEMP1,
27066     1                STATVA,STATV2,STATCU,STATCL,PVALU,PVALL,
27067     1                ALPHAV,CV,NUMALP,
27068     1                IDF1,IDF2,ILABMX,ILABMN,NUMDIS,NGROUP,
27069     1                DVARTO,VARMAX,VARMIN,
27070     1                IBUGG3,ISUBRO,IERROR)
27071C
27072          IF(IHKCPT.EQ.'DEFA')THEN
27073            NSTRT=IXCNT
27074            DO2230K=1,NUMDIS
27075              IF(J.LT.IMAT1 .OR. J.GT.IMAT2)GOTO2230
27076              IF(K.LT.ILAB1 .OR. K.GT.ILAB2)GOTO2230
27077              NPLOTP=NPLOTP+1
27078              IXCNT=IXCNT+1
27079              Y(NPLOTP)=G(K)
27080              X(NPLOTP)=REAL(IXCNT)
27081              D(NPLOTP)=1.0
27082 2230       CONTINUE
27083            IF(IHKCGP.GT.0 .AND. J.LT.NMAT)IXCNT=IXCNT+IHKCGP
27084            ILAST=IXCNT
27085            ITAG=1
27086          ELSE
27087            DO2240K=1,NUMDIS
27088              IF(J.LT.IMAT1 .OR. J.GT.IMAT2)GOTO2240
27089              IF(K.LT.ILAB1 .OR. K.GT.ILAB2)GOTO2240
27090              NPLOTP=NPLOTP+1
27091              Y(NPLOTP)=G(K)
27092              X(NPLOTP)=REAL(J)
27093              D(NPLOTP)=REAL(K)
27094 2240       CONTINUE
27095            NSTRT=J
27096            ILAST=J
27097            ITAG=NLAB
27098          ENDIF
27099C
27100          IF(NSTRT.EQ.0)NSTRT=1
27101          ITAG=ITAG+1
27102          NPLOTP=NPLOTP+1
27103          Y(NPLOTP)=CV(11)
27104          X(NPLOTP)=REAL(NSTRT)
27105          D(NPLOTP)=REAL(ITAG)
27106          IF(IHKCPT.EQ.'DEFA')THEN
27107            NPLOTP=NPLOTP+1
27108            Y(NPLOTP)=CV(11)
27109            X(NPLOTP)=REAL(ILAST)
27110            D(NPLOTP)=REAL(ITAG)
27111          ENDIF
27112          ITAG=ITAG+1
27113          NPLOTP=NPLOTP+1
27114          ACV=CV(13)
27115          Y(NPLOTP)=ACV
27116          X(NPLOTP)=REAL(NSTRT)
27117          D(NPLOTP)=REAL(ITAG)
27118          IF(IHKCPT.EQ.'DEFA')THEN
27119            NPLOTP=NPLOTP+1
27120            Y(NPLOTP)=CV(13)
27121            X(NPLOTP)=REAL(ILAST)
27122            D(NPLOTP)=REAL(ITAG)
27123          ENDIF
27124C
27125 2210   CONTINUE
27126      ENDIF
27127C
27128C               *****************
27129C               **  STEP 90--  **
27130C               **  EXIT       **
27131C               *****************
27132C
27133 9000 CONTINUE
27134      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'HKC2')THEN
27135        WRITE(ICOUT,999)
27136        CALL DPWRST('XXX','BUG ')
27137        WRITE(ICOUT,9011)
27138 9011   FORMAT('***** AT THE END       OF DPHKC2--')
27139        CALL DPWRST('XXX','BUG ')
27140        WRITE(ICOUT,9013)IERROR,NPLOTP,NPLOTV
27141 9013   FORMAT('IERROR,NPLOTP,NPLOTV = ',A4,2X,2I8)
27142        CALL DPWRST('XXX','BUG ')
27143        IF(NPLOTP.GT.0)THEN
27144          DO9035I=1,NPLOTP
27145            WRITE(ICOUT,9036)I,Y(I),X(I),D(I)
27146 9036       FORMAT('I,Y(I),X(I),D(I) = ',I8,2G15.7,F9.2)
27147            CALL DPWRST('XXX','BUG ')
27148 9035     CONTINUE
27149        ENDIF
27150      ENDIF
27151C
27152      RETURN
27153      END
27154      SUBROUTINE DPHMEA(NLAB,AMEAN,ASD,TEMP1,TEMP2,
27155     1                  IWRITE,ICAPSW,ICAPTY,NUMDIG,MAXNXT,
27156     1                  XH15,SEHMK1,SEHMK2,ALOWCL,AUPPCL,
27157     1                  ISUBRO,IBUGA3,IERROR)
27158C
27159C     PURPOSE--COMPUTE A CONSENSUS VALUE BASED ON THE HUBER H15 MEAN OF
27160C              THE MEANS.  THIS IS A MORE ROBUST VERSION OF THE MEAN OF
27161C              MEANS METHOD (I.E., PROTECTS AGAINST OUTLIER LABS).
27162C              THE ASSOCIATED UNCERTAINTY IS:
27163C
27164C                u(uhat(H15)) = SQRT(1/e)*sigmahat(h15)
27165C
27166C              WHERE e IS DEPENDENT ON THE TUNING CONSTANT USED BY THE
27167C              H15 ROUTINE.  WE USE e = 0.95 HERE.
27168C
27169C              THE ADVANTAGE OF THIS METHOD IS THAT IT PROTECTS AGAINST
27170C              OUTLYING LAB MEANS.  AS WITH MEAN OF MEANS METHOD, THE
27171C              DISADVANTAGE OF THIS METHOD IS THAT IT DOES NOT TAKE
27172C              WITHIN-LAB VARIANCE INTO ACCOUNT.
27173C
27174C     REFERENCE--CCQM GUIDANCE note: Estimation of a consensus KCRV and
27175C                associated Degrees of Equivalence", Version: 10,
27176C                2013-04-12, pp. 30-31.
27177C     PRINTING--YES
27178C     SUBROUTINES NEEDED--MEDIAN, MAD
27179C     WRITTEN BY--ALAN HECKERT
27180C                 STATISTICAL ENGINEERING DIVISION
27181C                 INFORMATION TECHNOLOGY LABORATORY
27182C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
27183C                 GAITHERSBURG, MD 20899-8980
27184C                 PHONE--301-975-2899
27185C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
27186C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
27187C     LANGUAGE--ANSI FORTRAN (1977)
27188C     VERSION NUMBER--2017/03
27189C     ORIGINAL VERSION--MARCH     2017.
27190C
27191C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES--------------
27192C
27193      DIMENSION AMEAN(*)
27194      DIMENSION ASD(*)
27195      DIMENSION TEMP1(*)
27196      DIMENSION TEMP2(*)
27197C
27198      CHARACTER*4 ICAPSW
27199      CHARACTER*4 ICAPTY
27200      CHARACTER*4 ISUBRO
27201      CHARACTER*4 IBUGA3
27202      CHARACTER*4 IERROR
27203      CHARACTER*4 IWRITE
27204      CHARACTER*4 ISUBN1
27205      CHARACTER*4 ISUBN2
27206C
27207C----------------------------------------------------------------
27208C
27209      INCLUDE 'DPCOST.INC'
27210C
27211      PARAMETER (MAXROW=20)
27212      CHARACTER*60 ITITLE
27213      CHARACTER*60 ITITLZ
27214      CHARACTER*60 ITITL9
27215      CHARACTER*60 ITEXT(MAXROW)
27216      REAL         AVALUE(MAXROW)
27217      INTEGER      NCTEXT(MAXROW)
27218      INTEGER      IDIGIT(MAXROW)
27219      INTEGER      NTOT(MAXROW)
27220      LOGICAL IFRST
27221      LOGICAL ILAST
27222C
27223      INCLUDE 'DPCOP2.INC'
27224C
27225C-----START POINT------------------------------------------------
27226C
27227      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'HMEA')THEN
27228        WRITE(ICOUT,999)
27229  999   FORMAT(1X)
27230        CALL DPWRST('XXX','BUG ')
27231        WRITE(ICOUT,51)
27232   51   FORMAT('***** AT THE BEGINNING OF DPHMEA--')
27233        CALL DPWRST('XXX','BUG ')
27234        WRITE(ICOUT,52)IWRITE,NLAB
27235   52   FORMAT('IWRITE,NLAB = ',A4,2X,I8)
27236        CALL DPWRST('XXX','BUG ')
27237        DO60I=1,NLAB
27238          WRITE(ICOUT,62)I,AMEAN(I),ASD(I)
27239   62     FORMAT('I,AMEAN(I),ASD(I) = ',I8,2G15.7)
27240          CALL DPWRST('XXX','BUG ')
27241   60   CONTINUE
27242      ENDIF
27243C
27244      IERROR='NO'
27245      ISUBN1='DPHM'
27246      ISUBN2='EA  '
27247C
27248C     STEP 1: COMPUTE THE HUBER 15 LOCATION AND SCALE ESTIMATES OF
27249C             THE LAB MEANS
27250C
27251      E=0.95
27252      C=1.5
27253      NCUT=0
27254      CALL H15(AMEAN,NLAB,C,NCUT,XH15,XH15SC,TEMP1,TEMP2,MAXNXT,
27255     1         ISUBRO,IBUGA3)
27256
27257      SEHMK1=SQRT(1.0/E)*XH15SC
27258      SEHMK2=2.0*SEHMK1
27259C
27260C     STEP 3: COMPUTE 95% CONFIDENCE INTERVAL
27261C
27262      ALPHA=0.975
27263      CALL NORPPF(ALPHA,TVAL)
27264      ALOWCL=XH15 - TVAL*SEHMK1
27265      AUPPCL=XH15 + TVAL*SEHMK1
27266C
27267      IF(IPRINT.EQ.'OFF')GOTO9000
27268C
27269      ITITLE=' '
27270      NCTITL=0
27271      ITITLZ=' '
27272      NCTITZ=0
27273C
27274      ICNT=1
27275      ITEXT(ICNT)='15. Method: Huber H15 Mean of Means'
27276      NCTEXT(ICNT)=35
27277      AVALUE(ICNT)=0.0
27278      IDIGIT(ICNT)=-1
27279C
27280      ICNT=ICNT+1
27281      ITEXT(ICNT)='    H15 Mean of Lab Means:'
27282      NCTEXT(ICNT)=26
27283      AVALUE(ICNT)=XH15
27284      IDIGIT(ICNT)=NUMDIG
27285      ICNT=ICNT+1
27286      ITEXT(ICNT)='    H15 Scale Estimate of Lab Means:'
27287      NCTEXT(ICNT)=36
27288      AVALUE(ICNT)=XH15SC
27289      IDIGIT(ICNT)=NUMDIG
27290      ICNT=ICNT+1
27291      ITEXT(ICNT)='    Standard Uncertainty (k = 1):'
27292      NCTEXT(ICNT)=33
27293      AVALUE(ICNT)=SEHMK1
27294      IDIGIT(ICNT)=NUMDIG
27295      ICNT=ICNT+1
27296      ITEXT(ICNT)='    Expanded Uncertainty (k = 2):'
27297      NCTEXT(ICNT)=33
27298      AVALUE(ICNT)=SEHMK2
27299      IDIGIT(ICNT)=NUMDIG
27300      ICNT=ICNT+1
27301      ITEXT(ICNT)='    Lower 95% (normal) Confidence Limit:'
27302      NCTEXT(ICNT)=40
27303      AVALUE(ICNT)=ALOWCL
27304      IDIGIT(ICNT)=NUMDIG
27305      ICNT=ICNT+1
27306      ITEXT(ICNT)='    Upper 95% (normal) Confidence Limit:'
27307      NCTEXT(ICNT)=40
27308      AVALUE(ICNT)=AUPPCL
27309      IDIGIT(ICNT)=NUMDIG
27310C
27311      NUMROW=ICNT
27312      DO310I=1,NUMROW
27313        NTOT(I)=15
27314  310 CONTINUE
27315C
27316      IFRST=.TRUE.
27317      ILAST=.TRUE.
27318      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
27319     1            AVALUE,IDIGIT,
27320     1            NTOT,NUMROW,
27321     1            ICAPSW,ICAPTY,ILAST,IFRST,
27322     1            ISUBRO,IBUGA3,IERROR)
27323      ITITLE=' '
27324      NCTITL=0
27325      ITITLZ=' '
27326      NCTITZ=0
27327      ITITL9=' '
27328      NCTIT9=0
27329C
27330C               *****************
27331C               **  STEP 90--  **
27332C               **  EXIT       **
27333C               *****************
27334C
27335 9000 CONTINUE
27336      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'HMEA')THEN
27337        WRITE(ICOUT,999)
27338        CALL DPWRST('XXX','BUG ')
27339        WRITE(ICOUT,9011)
27340 9011   FORMAT('***** AT THE END       OF DPHMEA--')
27341        CALL DPWRST('XXX','BUG ')
27342        WRITE(ICOUT,9015)XMEDME,SEMEK1,SEMEK2,ALOWCL,AUPPCL
27343 9015   FORMAT('XMEDME,SEMEK1,SEMEK2,ALOWCL,AUPPCL = ',5G15.7)
27344        CALL DPWRST('XXX','BUG ')
27345      ENDIF
27346C
27347      RETURN
27348      END
27349      SUBROUTINE DPHOCO(IANS2,N2,IVALID,VALCON,IBUGA3,IERROR)
27350C
27351C     PURPOSE--DETERMINE IF THE STRING DEFINED IN IANS2(.)
27352C              IS A VALID NUMBER REPRESENTATION
27353C              AND IF SO, COMPUTE THE VALUE OF THE NUMBER.
27354C
27355C     WRITTEN BY--JAMES J. FILLIBEN
27356C                 STATISTICAL ENGINEERING DIVISION
27357C                 INFORMATION TECHNOLOGY LABORATORY
27358C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
27359C                 GAITHERSBURG, MD 20899-8980
27360C                 PHONE--301-975-2855
27361C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
27362C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
27363C     LANGUAGE--ANSI FORTRAN (1977)
27364C     VERSION NUMBER--82/7
27365C     ORIGINAL VERSION--JANUARY   1979.
27366C     UPDATED         --JULY      1981.
27367C     UPDATED         --MAY       1982.
27368C
27369C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
27370C
27371      CHARACTER*4 IANS2
27372      CHARACTER*4 IVALID
27373      CHARACTER*4 IBUGA3
27374      CHARACTER*4 IERROR
27375C
27376      CHARACTER*4 IFLUNK
27377      CHARACTER*4 ITYPE2
27378C
27379      CHARACTER*4 ISUBN1
27380      CHARACTER*4 ISUBN2
27381      CHARACTER*4 ISTEPN
27382C
27383C---------------------------------------------------------------------
27384C
27385      DIMENSION IANS2(*)
27386C
27387C---------------------------------------------------------------------
27388C
27389      INCLUDE 'DPCOP2.INC'
27390C
27391C-----START POINT-----------------------------------------------------
27392C
27393      ISUBN1='DPHO'
27394      ISUBN2='CO  '
27395      IERROR='NO'
27396C
27397      IF(IBUGA3.EQ.'OFF')GOTO90
27398      WRITE(ICOUT,999)
27399  999 FORMAT(1X)
27400      CALL DPWRST('XXX','BUG ')
27401      WRITE(ICOUT,51)
27402   51 FORMAT('***** AT THE BEGINNING OF DPHOCO--')
27403      CALL DPWRST('XXX','BUG ')
27404      WRITE(ICOUT,52)N2
27405   52 FORMAT('N2 = ',I8)
27406      CALL DPWRST('XXX','BUG ')
27407      WRITE(ICOUT,53)(IANS2(I),I=1,N2)
27408   53 FORMAT('IANS2(.) = ',115A1)
27409      CALL DPWRST('XXX','BUG ')
27410   90 CONTINUE
27411C
27412C               **********************************
27413C               **  STEP 1--                    **
27414C               **  INITIALIZE SOME VARIABLES.  **
27415C               **********************************
27416C
27417      ISTEPN='1'
27418      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
27419C
27420      IVALID='NO'
27421C
27422C               ********************************************************
27423C               **  STEP 7--                                          **
27424C               **  CONVERT (IF POSSIBLE) THE STRING INTO A FLOATING  **
27425C               **  POINT ARGUMENT.                                   **
27426C               **  OUTPUT THIS FLOATING POINT VALUE IN FLOAT.        **
27427C               ********************************************************
27428C
27429      ISTEPN='7'
27430      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
27431      AMIN=-1000000.
27432      AMAX=+1000000.
27433      IFLUNK='NO'
27434      IVALID='YES'
27435      ITYPE2='NUMB'
27436      VALCON=CPUMIN
27437C
27438      ISTAR2=1
27439      ISTOP2=N2
27440C
27441      ILOC=0
27442      IDECPT=0
27443      DO3060I=ISTAR2,ISTOP2
27444      IF(IANS2(I).EQ.'.')ILOC=I
27445      IF(IANS2(I).EQ.'.')IDECPT=IDECPT+1
27446 3060 CONTINUE
27447      IF(IDECPT.GE.2)GOTO3900
27448      IF(IDECPT.EQ.1)GOTO3150
27449      DO3100I=ISTAR2,ISTOP2
27450      IREV=ISTOP2-(I-ISTAR2)
27451      IF(IANS2(IREV).EQ.' ')GOTO3100
27452      IF(IANS2(IREV).EQ.'0')GOTO3110
27453      IF(IANS2(IREV).EQ.'1')GOTO3110
27454      IF(IANS2(IREV).EQ.'2')GOTO3110
27455      IF(IANS2(IREV).EQ.'3')GOTO3110
27456      IF(IANS2(IREV).EQ.'4')GOTO3110
27457      IF(IANS2(IREV).EQ.'5')GOTO3110
27458      IF(IANS2(IREV).EQ.'6')GOTO3110
27459      IF(IANS2(IREV).EQ.'7')GOTO3110
27460      IF(IANS2(IREV).EQ.'8')GOTO3110
27461      IF(IANS2(IREV).EQ.'9')GOTO3110
27462      IFLUNK='YES'
27463      IF(IANS2(IREV).EQ.'+')GOTO3900
27464      IF(IANS2(IREV).EQ.'-')GOTO3900
27465      GOTO3900
27466 3100 CONTINUE
27467      IFLUNK='YES'
27468      GOTO3900
27469 3110 ILOC=IREV+1
27470 3150 CONTINUE
27471      IF(IBUGA3.EQ.'ON')WRITE(ICOUT,3111)ILOC,IDECPT
27472 3111 FORMAT('ILOC = ',I8,'    IDECPT = ',I8)
27473      IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ')
27474C
27475C     SECONDLY, COMPUTE THE INTEGER PART OF THE VALUE
27476C
27477      SIGN=1.0
27478      IDIGI=0
27479      ISIGN=0
27480      SUMI=0
27481      ILOCM1=ILOC-1
27482      IF(ILOCM1.LT.ISTAR2)GOTO3250
27483      DO3200I=ISTAR2,ILOCM1
27484      IREV=ILOCM1-(I-ISTAR2)
27485      IF(IANS2(IREV).EQ.' ')GOTO3200
27486      IF(IANS2(IREV).EQ.'0')GOTO3210
27487      IF(IANS2(IREV).EQ.'1')GOTO3211
27488      IF(IANS2(IREV).EQ.'2')GOTO3232
27489      IF(IANS2(IREV).EQ.'3')GOTO3213
27490      IF(IANS2(IREV).EQ.'4')GOTO3214
27491      IF(IANS2(IREV).EQ.'5')GOTO3215
27492      IF(IANS2(IREV).EQ.'6')GOTO3216
27493      IF(IANS2(IREV).EQ.'7')GOTO3217
27494      IF(IANS2(IREV).EQ.'8')GOTO3218
27495      IF(IANS2(IREV).EQ.'9')GOTO3219
27496      IF(IANS2(IREV).EQ.'+')GOTO3220
27497      IF(IANS2(IREV).EQ.'-')GOTO3221
27498      IFLUNK='YES'
27499      GOTO3900
27500 3210 ITERM=0
27501      GOTO3225
27502 3211 ITERM=1
27503      GOTO3225
27504 3232 ITERM=2
27505      GOTO3225
27506 3213 ITERM=3
27507      GOTO3225
27508 3214 ITERM=4
27509      GOTO3225
27510 3215 ITERM=5
27511      GOTO3225
27512 3216 ITERM=6
27513      GOTO3225
27514 3217 ITERM=7
27515      GOTO3225
27516 3218 ITERM=8
27517      GOTO3225
27518 3219 ITERM=9
27519      GOTO3225
27520 3220 ISIGN=ISIGN+1
27521      GOTO3200
27522 3221 ISIGN=ISIGN+1
27523      SIGN=-SIGN
27524      GOTO3200
27525 3225 IDIGI=IDIGI+1
27526      TERM=ITERM
27527      IEXP=IDIGI-1
27528      SUMI=SUMI+TERM*(10.0**IEXP)
27529 3200 CONTINUE
27530 3250 CONTINUE
27531      IF(ISIGN.GE.2)GOTO3900
27532      IF(IBUGA3.EQ.'ON')WRITE(ICOUT,3255)IDIGI,SUMI
27533 3255 FORMAT('IDIGI = ',I8,'    SUMI = ',F20.10)
27534      IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ')
27535C
27536C     THIRDLY, COMPUTE THE DECIMAL PART OF THE VALUE
27537C
27538      IDIGD=0
27539      SUMD=0.0
27540      ILOCP1=ILOC+1
27541      IF(ILOCP1.GT.ISTOP2)GOTO3350
27542      DO3300I=ILOCP1,ISTOP2
27543      IF(IANS2(I).EQ.' ')GOTO3300
27544      IF(IANS2(I).EQ.'0')GOTO3310
27545      IF(IANS2(I).EQ.'1')GOTO3311
27546      IF(IANS2(I).EQ.'2')GOTO3312
27547      IF(IANS2(I).EQ.'3')GOTO3333
27548      IF(IANS2(I).EQ.'4')GOTO3314
27549      IF(IANS2(I).EQ.'5')GOTO3315
27550      IF(IANS2(I).EQ.'6')GOTO3316
27551      IF(IANS2(I).EQ.'7')GOTO3317
27552      IF(IANS2(I).EQ.'8')GOTO3318
27553      IF(IANS2(I).EQ.'9')GOTO3319
27554      IFLUNK='YES'
27555      GOTO3900
27556 3310 ITERM=0
27557      GOTO3325
27558 3311 ITERM=1
27559      GOTO3325
27560 3312 ITERM=2
27561      GOTO3325
27562 3333 ITERM=3
27563      GOTO3325
27564 3314 ITERM=4
27565      GOTO3325
27566 3315 ITERM=5
27567      GOTO3325
27568 3316 ITERM=6
27569      GOTO3325
27570 3317 ITERM=7
27571      GOTO3325
27572 3318 ITERM=8
27573      GOTO3325
27574 3319 ITERM=9
27575      GOTO3325
27576 3325 IDIGD=IDIGD+1
27577      TERM=ITERM
27578      SUMD=SUMD+TERM/(10.0**IDIGD)
27579 3300 CONTINUE
27580 3350 CONTINUE
27581      IF(IBUGA3.EQ.'ON')WRITE(ICOUT,3355)IDIGD,SUMD
27582 3355 FORMAT('IDIGD = ',I8,'    SUMD = ',F20.10)
27583      IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ')
27584      IDIGT=IDIGI+IDIGD
27585      IF(IDIGT.LE.0)GOTO3900
27586      VALCON=SUMI+SUMD
27587      IF(SIGN.LT.0.0)VALCON=-VALCON
27588      IF(AMIN.LE.VALCON.AND.VALCON.LE.AMAX)GOTO3000
27589      GOTO3900
27590C
27591 3900 CONTINUE
27592      IF(IFLUNK.EQ.'YES')ITYPE2='WORD'
27593 3000 CONTINUE
27594      GOTO8000
27595C
27596C               ******************************
27597C               **  STEP 7--                **
27598C               **  DEFINE IF VALID OR NOT  **
27599C               ******************************
27600C
27601 8000 CONTINUE
27602      IF(IFLUNK.EQ.'YES')IVALID='NO'
27603      IF(IFLUNK.EQ.'NO')IVALID='YES'
27604      GOTO9000
27605C
27606C               ****************
27607C               **  STEP 90-- **
27608C               **  EXIT.     **
27609C               ****************
27610C
27611 9000 CONTINUE
27612      IF(IBUGA3.EQ.'OFF')GOTO9090
27613      WRITE(ICOUT,999)
27614      CALL DPWRST('XXX','BUG ')
27615      WRITE(ICOUT,9011)
27616 9011 FORMAT('***** AT THE END       OF DPHOCO--')
27617      CALL DPWRST('XXX','BUG ')
27618      WRITE(ICOUT,9012)IVALID,VALCON
27619 9012 FORMAT('IVALID,VALCON = ',A4,2X,E15.7)
27620      CALL DPWRST('XXX','BUG ')
27621      WRITE(ICOUT,9013)IFLUNK,ITYPE2
27622 9013 FORMAT('IFLUNK,ITYPE2 = ',A4,2X,A4)
27623      CALL DPWRST('XXX','BUG ')
27624      WRITE(ICOUT,9015)IERROR
27625 9015 FORMAT('IERROR = ',A4)
27626      CALL DPWRST('XXX','BUG ')
27627 9090 CONTINUE
27628C
27629      RETURN
27630      END
27631      SUBROUTINE DPHOMO(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
27632     1                  ISEED,
27633     1                  IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
27634C
27635C     PURPOSE--GENERATE A HOMOGENEITY PLOT--
27636C              A PLOT OF SUBSET STANDARD DEVIATION VERSUS SUBSET MEAN
27637C     WRITTEN BY--JAMES J. FILLIBEN
27638C                 STATISTICAL ENGINEERING DIVISION
27639C                 INFORMATION TECHNOLOGY LABORATORY
27640C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
27641C                 GAITHERSBURG, MD 20899-8980
27642C                 PHONE--301-975-2855
27643C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
27644C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
27645C     LANGUAGE--ANSI FORTRAN (1977)
27646C     VERSION NUMBER--86/7
27647C     ORIGINAL VERSION--MARCH     1986.
27648C     UPDATED         --JUNE      1990. TEMPORARY ARRAYS TO GARBAGE COMMON
27649C     UPDATED         --DECEMBER  2010. SUPPORT FOR "MULTIPLE" AND
27650C                                       "HIGHLIGHT/SUBSET"
27651C     UPDATED         --DECEMBER  2010. ALLOW MORE THAN ONE REPLICATION
27652C                                       VARIABLE
27653C     UPDATED         --DECEMBER  2010. USE DPPARS AND DPPAR3 TO PERFORM
27654C                                       THE COMMAND PARSING
27655C     UPDATED         --DECEMBER  2010. ALLOW ALTERNATE LOCATION/SCALE
27656C                                       MEASURES
27657C     UPDATED         --DECEMBER  2010. "CIRCLE TECHNIQUE" FOR IDENTIFYING
27658C                                       NON-HOMOGENOUS LABS (FOR CERTAIN
27659C                                       LOCATION/SCALE MEASURES)
27660C     UPDATED         --DECEMBER  2010. SUPPORT FOR "SUMMARY" OPTION
27661C                                       (ENTER MEAN/SD VALUES RATHER
27662C     UPDATED         --MAY       2012. IF CIRCLE TECHNIQUE TURNED ON,
27663C                                       SAVE XBAR AND SBAR AS INTERNAL
27664C                                       PARAMETERS (BUT NOT FOR REPLICATED
27665C                                       CASE)
27666C     UPDATED         --AUGUST    2012. CORRECT CASE FOR SUMMARY DATA
27667C                                       WITH NO HIGHLIGHTING BUT WITH
27668C                                       CIRCLE TECHNIQUE
27669C
27670C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
27671C
27672      CHARACTER*4 ICASPL
27673      CHARACTER*4 IAND1
27674      CHARACTER*4 IAND2
27675      CHARACTER*4 IBUGG2
27676      CHARACTER*4 IBUGG3
27677      CHARACTER*4 IBUGQ
27678      CHARACTER*4 ISUBRO
27679      CHARACTER*4 IFOUND
27680      CHARACTER*4 IERROR
27681C
27682      CHARACTER*4 IHIGH
27683      CHARACTER*4 IMULT
27684      CHARACTER*4 ISUMM
27685C
27686      CHARACTER*40 INAME
27687      PARAMETER (MAXSPN=30)
27688      CHARACTER*4 IVARN1(MAXSPN)
27689      CHARACTER*4 IVARN2(MAXSPN)
27690      CHARACTER*4 IVARTY(MAXSPN)
27691      REAL PVAR(MAXSPN)
27692      INTEGER ILIS(MAXSPN)
27693      INTEGER NRIGHT(MAXSPN)
27694      INTEGER ICOLR(MAXSPN)
27695C
27696      CHARACTER*4 IHP
27697      CHARACTER*4 IHP2
27698      CHARACTER*4 IHWUSE
27699      CHARACTER*4 MESSAG
27700      CHARACTER*4 ICASE
27701      CHARACTER*4 ISUBN0
27702      CHARACTER*4 ISUBN1
27703      CHARACTER*4 ISUBN2
27704      CHARACTER*4 ISTEPN
27705C
27706C---------------------------------------------------------------------
27707C
27708      INCLUDE 'DPCOPA.INC'
27709C
27710      DIMENSION Y1(MAXOBV)
27711      DIMENSION X1(MAXOBV)
27712      DIMENSION X2(MAXOBV)
27713      DIMENSION X3(MAXOBV)
27714      DIMENSION X4(MAXOBV)
27715      DIMENSION X5(MAXOBV)
27716      DIMENSION X6(MAXOBV)
27717C
27718      DIMENSION XIDTEM(MAXOBV)
27719      DIMENSION XIDTE2(MAXOBV)
27720      DIMENSION XIDTE3(MAXOBV)
27721      DIMENSION XIDTE4(MAXOBV)
27722      DIMENSION XIDTE5(MAXOBV)
27723      DIMENSION XIDTE6(MAXOBV)
27724      DIMENSION TEMP(MAXOBV)
27725      DIMENSION XTEMP1(MAXOBV)
27726      DIMENSION XTEMP2(MAXOBV)
27727      DIMENSION XTEMP3(MAXOBV)
27728      DIMENSION XREPL(MAXOBV)
27729C
27730      DOUBLE PRECISION DTEMP1(MAXOBV)
27731      INTEGER ITEMP1(MAXOBV)
27732      INTEGER ITEMP2(MAXOBV)
27733      INTEGER ITEMP3(MAXOBV)
27734      INTEGER ITEMP4(MAXOBV)
27735      INTEGER ITEMP5(MAXOBV)
27736      INTEGER ITEMP6(MAXOBV)
27737C
27738      INCLUDE 'DPCOZZ.INC'
27739      INCLUDE 'DPCOZD.INC'
27740      INCLUDE 'DPCOZI.INC'
27741C
27742      EQUIVALENCE (GARBAG(IGARB1),Y1(1))
27743      EQUIVALENCE (GARBAG(IGARB2),X1(1))
27744      EQUIVALENCE (GARBAG(IGARB3),X2(1))
27745      EQUIVALENCE (GARBAG(IGARB4),X3(1))
27746      EQUIVALENCE (GARBAG(IGARB5),X4(1))
27747      EQUIVALENCE (GARBAG(IGARB6),X5(1))
27748      EQUIVALENCE (GARBAG(IGARB7),X6(1))
27749      EQUIVALENCE (GARBAG(IGARB8),TEMP(1))
27750      EQUIVALENCE (GARBAG(IGARB9),XIDTEM(1))
27751      EQUIVALENCE (GARBAG(IGAR10),XIDTE2(1))
27752      EQUIVALENCE (GARBAG(JGAR11),XIDTE3(1))
27753      EQUIVALENCE (GARBAG(JGAR12),XIDTE4(1))
27754      EQUIVALENCE (GARBAG(JGAR13),XIDTE5(1))
27755      EQUIVALENCE (GARBAG(JGAR14),XIDTE6(1))
27756      EQUIVALENCE (GARBAG(JGAR15),XTEMP1(1))
27757      EQUIVALENCE (GARBAG(JGAR16),XTEMP2(1))
27758      EQUIVALENCE (GARBAG(JGAR17),XTEMP3(1))
27759      EQUIVALENCE (GARBAG(JGAR18),XREPL(1))
27760C
27761      EQUIVALENCE (DGARBG(IDGAR1),DTEMP1(1))
27762      EQUIVALENCE (IGARBG(IIGAR1),ITEMP1(1))
27763      EQUIVALENCE (IGARBG(IIGAR2),ITEMP2(1))
27764      EQUIVALENCE (IGARBG(IIGAR3),ITEMP3(1))
27765      EQUIVALENCE (IGARBG(IIGAR4),ITEMP4(1))
27766      EQUIVALENCE (IGARBG(IIGAR5),ITEMP5(1))
27767      EQUIVALENCE (IGARBG(IIGAR6),ITEMP6(1))
27768C
27769C-----COMMON----------------------------------------------------------
27770C
27771      INCLUDE 'DPCOHK.INC'
27772      INCLUDE 'DPCODA.INC'
27773      INCLUDE 'DPCOST.INC'
27774      INCLUDE 'DPCOHO.INC'
27775      INCLUDE 'DPCOP2.INC'
27776C
27777C-----START POINT-----------------------------------------------------
27778C
27779      IERROR='NO'
27780      IFOUND='NO'
27781      ISUBN1='DPHO'
27782      ISUBN2='MO  '
27783C
27784      MAXCP1=MAXCOL+1
27785      MAXCP2=MAXCOL+2
27786      MAXCP3=MAXCOL+3
27787      MAXCP4=MAXCOL+4
27788      MAXCP5=MAXCOL+5
27789      MAXCP6=MAXCOL+6
27790C
27791C               ***************************************
27792C               **  TREAT THE HOMOGENEITY PLOT CASE  **
27793C               ***************************************
27794C
27795      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'HOMO')THEN
27796        WRITE(ICOUT,999)
27797  999   FORMAT(1X)
27798        CALL DPWRST('XXX','BUG ')
27799        WRITE(ICOUT,51)
27800   51   FORMAT('***** AT THE BEGINNING OF DPHOMO--')
27801        CALL DPWRST('XXX','BUG ')
27802        WRITE(ICOUT,52)ICASPL,IAND1,IAND2
27803   52   FORMAT('ICASPL,IAND1,IAND2 = ',2(A4,2X),A4)
27804        CALL DPWRST('XXX','BUG ')
27805        WRITE(ICOUT,53)ICONT,IBUGG2,IBUGG3,IBUGQ
27806   53   FORMAT('ICONT,IBUGG2,IBUGG3,IBUGQ = ',3(A4,2X),A4)
27807        CALL DPWRST('XXX','BUG ')
27808      ENDIF
27809C
27810C               ***************************
27811C               **  STEP 1--             **
27812C               **  EXTRACT THE COMMAND  **
27813C               ***************************
27814C
27815      ISTEPN='1'
27816      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HOMO')
27817     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
27818C
27819      ICASPL='HOMO'
27820      IHIGH='OFF'
27821      IMULT='OFF'
27822      ISUMM='OFF'
27823C
27824      IF(NUMARG.GE.1.AND.ICOM.EQ.'HOMO'.AND.IHARG(1).EQ.'PLOT')THEN
27825        ILASTC=1
27826      ELSEIF(NUMARG.GE.2.AND.ICOM.EQ.'HOMO'.AND.IHARG(1).EQ.'MULT'.AND.
27827     1       IHARG(2).EQ.'PLOT')THEN
27828        ILASTC=2
27829        IMULT='ON'
27830      ELSEIF(NUMARG.GE.2.AND.ICOM.EQ.'MULT'.AND.IHARG(1).EQ.'HOMO'.AND.
27831     1       IHARG(2).EQ.'PLOT')THEN
27832        ILASTC=2
27833        IMULT='ON'
27834      ELSEIF(NUMARG.GE.2.AND.ICOM.EQ.'HOMO'.AND.IHARG(1).EQ.'HIGH'.AND.
27835     1       IHARG(2).EQ.'PLOT')THEN
27836        ILASTC=2
27837        IHIGH='ON'
27838      ELSEIF(NUMARG.GE.2.AND.ICOM.EQ.'HIGH'.AND.IHARG(1).EQ.'HOMO'.AND.
27839     1       IHARG(2).EQ.'PLOT')THEN
27840        ILASTC=2
27841        IHIGH='ON'
27842      ELSEIF(NUMARG.GE.2.AND.ICOM.EQ.'HOMO'.AND.IHARG(1).EQ.'SUBS'.AND.
27843     1       IHARG(2).EQ.'PLOT')THEN
27844        ILASTC=2
27845        IHIGH='ON'
27846      ELSEIF(NUMARG.GE.2.AND.ICOM.EQ.'SUBS'.AND.IHARG(1).EQ.'HOMO'.AND.
27847     1       IHARG(2).EQ.'PLOT')THEN
27848        ILASTC=2
27849        IHIGH='ON'
27850      ELSEIF(NUMARG.GE.2.AND.ICOM.EQ.'HOMO'.AND.IHARG(1).EQ.'SUMM'.AND.
27851     1       IHARG(2).EQ.'PLOT')THEN
27852        ILASTC=2
27853        ISUMM='ON'
27854      ELSEIF(NUMARG.GE.2.AND.ICOM.EQ.'SUMM'.AND.IHARG(1).EQ.'HOMO'.AND.
27855     1       IHARG(2).EQ.'PLOT')THEN
27856        ILASTC=2
27857        ISUMM='ON'
27858      ELSEIF(NUMARG.GE.3.AND.ICOM.EQ.'HOMO'.AND.IHARG(1).EQ.'SUMM'.AND.
27859     1      (IHARG(2).EQ.'SUBS'.OR.IHARG(2).EQ.'HIGH').AND.
27860     1      IHARG(3).EQ.'PLOT')THEN
27861        ILASTC=3
27862        ISUMM='ON'
27863        IHIGH='ON'
27864      ELSEIF(NUMARG.GE.3.AND.ICOM.EQ.'SUMM'.AND.IHARG(1).EQ.'HOMO'.AND.
27865     1      (IHARG(2).EQ.'SUBS'.OR.IHARG(2).EQ.'HIGH').AND.
27866     1      IHARG(3).EQ.'PLOT')THEN
27867        ILASTC=3
27868        ISUMM='ON'
27869        IHIGH='ON'
27870      ELSEIF(NUMARG.GE.3.AND.ICOM.EQ.'SUMM'.AND.
27871     1      (IHARG(1).EQ.'SUBS'.OR.IHARG(1).EQ.'HIGH').AND.
27872     1      IHARG(2).EQ.'HOMO'.AND.IHARG(3).EQ.'PLOT')THEN
27873        ILASTC=3
27874        ISUMM='ON'
27875        IHIGH='ON'
27876      ELSEIF(NUMARG.GE.3.AND.
27877     1      (ICOM.EQ.'SUBS'.OR.ICOM.EQ.'HIGH').AND.
27878     1      IHARG(1).EQ.'SUMM'.AND.
27879     1      IHARG(2).EQ.'HOMO'.AND.IHARG(3).EQ.'PLOT')THEN
27880        ILASTC=3
27881        ISUMM='ON'
27882        IHIGH='ON'
27883      ELSE
27884        GOTO9000
27885      ENDIF
27886C
27887      IF(ISUMM.EQ.'ON' .AND. IMULT.EQ.'ON')THEN
27888        WRITE(ICOUT,999)
27889        CALL DPWRST('XXX','BUG ')
27890        WRITE(ICOUT,101)
27891        CALL DPWRST('XXX','BUG ')
27892        WRITE(ICOUT,103)
27893  103   FORMAT('      THE SUMMARY AND MULTIPLE OPTIONS CANNOT BOTH ',
27894     1         'BE GIVEN.')
27895        CALL DPWRST('XXX','BUG ')
27896        IERROR='YES'
27897        GOTO9000
27898      ENDIF
27899C
27900      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
27901      IFOUND='YES'
27902C
27903      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'HOMO')THEN
27904        WRITE(ICOUT,112)ICASPL,IMULT,IHIGH
27905  112   FORMAT('ICASPL,IMULT,IHIGH = ',2(A4,2X),A4)
27906        CALL DPWRST('XXX','BUG ')
27907      ENDIF
27908C
27909C               ****************************************
27910C               **  STEP 2--                          **
27911C               **  EXTRACT THE VARIABLE LIST         **
27912C               ****************************************
27913C
27914      ISTEPN='2'
27915      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HOMO')
27916     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
27917C
27918C     NUMBER OF VARIABLES:
27919C       1) IF "HIGHLIGHT/SUBSET", EXPECT EXACTLY 2 VARIABLES UNLESS
27920C          CIRCLE TECHNIQUE IS ON FOR SUMMARY DATA (IN WHICH CASE WE
27921C          EXPECT EXACTLY 3 VARIABLES FOR SUMMARY DATA).
27922C       2) IF "MULTIPLE", CAN HAVE AN ARBITRARY NUMBER OF
27923C          RESPONSE VARIABLES UP TO 30
27924C       3) IF HIGHLIGHT AND MULTIPLE BOTH OFF, HAVE ONE RESPONSE
27925C          AND FROM 1 TO 6 REPLICATION VARIABLES
27926C
27927      INAME='HOMOSCEDASTICITY PLOT'
27928      MINNA=1
27929      MAXNA=100
27930      MINN2=2
27931      IFLAGE=1
27932      IF(IMULT.EQ.'ON')THEN
27933        IFLAGE=0
27934      ENDIF
27935      IFLAGM=0
27936      IFLAGP=0
27937      JMIN=1
27938      JMAX=NUMARG
27939C
27940      IF(IMULT.EQ.'ON')THEN
27941        MINNVA=1
27942        MAXNVA=30
27943      ELSEIF(IHIGH.EQ.'ON')THEN
27944        IF(ISUMM.EQ.'OFF')THEN
27945          MINNVA=2
27946          MAXNVA=2
27947        ELSE
27948          MINNVA=2
27949          MAXNVA=3
27950          IF(IHOMCT.EQ.'ON')THEN
27951            MINNVA=3
27952            MAXNVA=3
27953          ENDIF
27954        ENDIF
27955      ELSE
27956        IF(ISUMM.EQ.'OFF')THEN
27957          MINNVA=2
27958          MAXNVA=MINNVA+5
27959        ELSE
27960          MINNVA=2
27961          IF(IHOMCT.EQ.'ON')MINNVA=3
27962          MAXNVA=MINNVA
27963        ENDIF
27964      ENDIF
27965C
27966      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
27967     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
27968     1            JMIN,JMAX,
27969     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
27970     1            IVARN1,IVARN2,IVARTY,PVAR,
27971     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
27972     1            MINNVA,MAXNVA,
27973     1            IFLAGM,IFLAGP,
27974     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
27975      IF(IERROR.EQ.'YES')GOTO9000
27976C
27977      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HOMO')THEN
27978        WRITE(ICOUT,999)
27979        CALL DPWRST('XXX','BUG ')
27980        WRITE(ICOUT,281)
27981  281   FORMAT('***** AFTER CALL DPPARS--')
27982        CALL DPWRST('XXX','BUG ')
27983        WRITE(ICOUT,282)NQ,NUMVAR
27984  282   FORMAT('NQ,NUMVAR = ',2I8)
27985        CALL DPWRST('XXX','BUG ')
27986        IF(NUMVAR.GT.0)THEN
27987          DO285I=1,NUMVAR
27988            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
27989     1                      ICOLR(I),IVARTY(I)
27990  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
27991     1             'ICOLR(I),IVARTY(I) = ',I8,2X,A4,A4,2X,3I8,2X,A4)
27992            CALL DPWRST('XXX','BUG ')
27993  285     CONTINUE
27994        ENDIF
27995      ENDIF
27996C
27997C     EXTRACT ANY NEEDED PARAMETERS
27998C
27999      ISTEPN='2.1'
28000      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HOMO')
28001     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28002C
28003      IF(IHOMLO.EQ.'LPL')THEN
28004        IHP='P   '
28005        IHP2='    '
28006        IHWUSE='P'
28007        MESSAG='NO'
28008        CALL CHECKN(IHP,IHP2,IHWUSE,
28009     1               IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
28010     1               ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
28011        IF(IERROR.EQ.'YES')THEN
28012          P=1.5
28013        ELSE
28014          P=VALUE(ILOCP)
28015        ENDIF
28016C
28017      ELSEIF(IHOMLO.EQ.'WIME' .OR. IHOMSC.EQ.'WISD' .OR.
28018     1       IHOMLO.EQ.'TRIM' .OR. IHOMSC.EQ.'TMSD')THEN
28019C
28020C        2012/10: FOR TRIMMED OR WINSORIZED STATISTICS, WE CAN SPECIFY
28021C                 EITHER A SPECIFIC NUMBER TO TRIM OR A PERCENTAGE TO
28022C                 TRIM.  CHECK FOR SPECIFIC NUMBER FIRST AND IF NOT
28023C                 SPECIFIED, CHECK FOR A PERCENTAGE.
28024C
28025        NTRIM1=-1
28026        NTRIM2=-1
28027        P1=-99.0
28028        P2=-99.0
28029C
28030        IHP='NTRI'
28031        IHP2='M1  '
28032        IHWUSE='P'
28033        MESSAG='NO'
28034        CALL CHECKN(IHP,IHP2,IHWUSE,
28035     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
28036     1              ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
28037        IF(IERROR.EQ.'NO')THEN
28038          NTRIM1=INT(VALUE(ILOCP)+0.1)
28039          IF(NTRIM1.LT.0)NTRIM1=0
28040        ENDIF
28041C
28042        IHP='NTRI'
28043        IHP2='M2  '
28044        IHWUSE='P'
28045        MESSAG='NO'
28046        CALL CHECKN(IHP,IHP2,IHWUSE,
28047     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
28048     1              ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
28049        IF(IERROR.EQ.'NO')THEN
28050          NTRIM2=INT(VALUE(ILOCP)+0.1)
28051          IF(NTRIM2.LT.0)NTRIM2=0
28052        ENDIF
28053C
28054        IF(NTRIM1.LE.0)THEN
28055          IHP='P1  '
28056          IHP2='    '
28057          IHWUSE='P'
28058          MESSAG='YES'
28059          CALL CHECKN(IHP,IHP2,IHWUSE,
28060     1                IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
28061     1                ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
28062          IF(IERROR.EQ.'YES')GOTO9000
28063          IF(PROP1.LT.0.0 .OR. PROP1.GT.100.0)THEN
28064            WRITE(ICOUT,999)
28065            CALL DPWRST('XXX','BUG ')
28066            WRITE(ICOUT,11581)
2806711581       FORMAT('***** ERROR IN HOMOGENEITY PLOT--')
28068            CALL DPWRST('XXX','BUG ')
28069            WRITE(ICOUT,11582)
2807011582       FORMAT('      THE PROPORTION FOR TRIMMING/WINSORIZING ',
28071     1             'BELOW')
28072            CALL DPWRST('XXX','BUG ')
28073            WRITE(ICOUT,11583)
2807411583       FORMAT('      MUST BE BETWEEN 0 AND 100, BUT WAS NOT.')
28075            CALL DPWRST('XXX','BUG ')
28076            WRITE(ICOUT,11584)PROP1
2807711584       FORMAT('      PARAMETER P1 = LOWER PROPORTION = ',G15.7)
28078            CALL DPWRST('XXX','BUG ')
28079            WRITE(ICOUT,11586)
2808011586       FORMAT('      USE THE LET COMMAND TO PRE-DEFINE P1 AS IN')
28081            CALL DPWRST('XXX','BUG ')
28082            WRITE(ICOUT,11587)
2808311587       FORMAT('      LET P1 = 25')
28084            CALL DPWRST('XXX','BUG ')
28085            IERROR='YES'
28086            GOTO9000
28087          ELSE
28088            PROP1=VALUE(ILOCP)
28089          ENDIF
28090        ENDIF
28091C
28092        IF(NTRIM2.LE.0)THEN
28093          IHP='P2  '
28094          IHP2='    '
28095          IHWUSE='P'
28096          MESSAG='YES'
28097          CALL CHECKN(IHP,IHP2,IHWUSE,
28098     1                IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
28099     1                ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
28100          IF(IERROR.EQ.'YES')GOTO9000
28101          IF(PROP2.LT.0.0 .OR. PROP2.GT.100.0)THEN
28102            WRITE(ICOUT,999)
28103            CALL DPWRST('XXX','BUG ')
28104            WRITE(ICOUT,11581)
28105            CALL DPWRST('XXX','BUG ')
28106            WRITE(ICOUT,11592)
2810711592       FORMAT('      THE PROPORTION FOR TRIMMING/WINSORIZING ',
28108     1             'ABOVE')
28109            CALL DPWRST('XXX','BUG ')
28110            WRITE(ICOUT,11583)
28111            CALL DPWRST('XXX','BUG ')
28112            WRITE(ICOUT,11594)PROP2
2811311594       FORMAT('      PARAMETER P2 = LOWER PROPORTION = ',G15.7)
28114            CALL DPWRST('XXX','BUG ')
28115            WRITE(ICOUT,11596)
2811611596       FORMAT('      USE THE LET COMMAND TO PRE-DEFINE P2 AS IN')
28117            CALL DPWRST('XXX','BUG ')
28118            WRITE(ICOUT,11597)
2811911597       FORMAT('      LET P2 = 25')
28120            CALL DPWRST('XXX','BUG ')
28121            IERROR='YES'
28122            GOTO9000
28123          ELSE
28124            PROP2=VALUE(ILOCP)
28125          ENDIF
28126        ENDIF
28127C
28128      ENDIF
28129C
28130C     3 CASES:
28131C
28132C       1) HIGHLIGHT - HAVE 3 VARIABLES OF EQUAL LENGTH
28133C       2) MULTIPLE  - ALL VARIABLES ARE RESPONSE VARIABLES,
28134C                      CREATE "Y X" FROM THESE.
28135C       3) DEFAULT   - ONE RESPONSE VARIABLE, REST ARE REPLICATION
28136C                      VARIABLES
28137C
28138C     CASE 1: HIGHLIGHT/SUBSET OPTION, EXACTLY 2 VARIABLES
28139C             (EXACTLY 3 VARIABLES FOR SUMMARY CASE WITH
28140C             CIRCLE TECHNIQUE)
28141C
28142      JSTRT=0
28143C
28144C     FOR SUMMARY DATA, NEED THE NUMBER OF REPLICATIONS TO IMPLEMENT
28145C     THE CIRCLE TECHNIQUE
28146C
28147      IF(IHIGH.EQ.'ON')THEN
28148        NRESP=1
28149        NREPL=1
28150        NHIGH=1
28151        NCURVE=1
28152        ICOL=1
28153        NUMVAR=2
28154        IF(ISUMM.EQ.'ON' .AND. IHOMCT.EQ.'ON')NUMVAR=3
28155        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
28156     1              INAME,IVARN1,IVARN2,IVARTY,
28157     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
28158     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
28159     1              MAXCP4,MAXCP5,MAXCP6,
28160     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
28161     1              Y1,X1,XREPL,NLOCAL,NLOCA2,NLOCA3,ICASE,
28162     1              IBUGG3,ISUBRO,IFOUND,IERROR)
28163C
28164        CALL DPHOM2(Y1,X1,X2,X3,X4,X5,X6,XREPL,
28165     1              NLOCAL,NRESP,NREPL,NHIGH,
28166     1              XIDTEM,XIDTE2,XIDTE3,XIDTE4,XIDTE5,XIDTE6,TEMP,
28167     1              XTEMP1,XTEMP2,XTEMP3,DTEMP1,
28168     1              ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
28169     1              MAXOBV,JSTRT,NCURVE,
28170     1              IHOMLO,IHOMSC,IHOMCT,IMULT,ISUMM,
28171     1              P,PROP1,PROP2,NTRIM1,NTRIM2,IQUASE,ISEED,
28172     1              XBAR,SBAR,
28173     1              Y,X,D,NPLOTP,NPLOTV,
28174     1              IBUGG3,ISUBRO,IERROR)
28175C
28176        IF(IHOMCT.EQ.'ON')THEN
28177          IHP='XBAR'
28178          IHP2='    '
28179          VALUE0=XBAR
28180          CALL DPADDP(IHP,IHP2,VALUE0,IHOST1,ISUBN0,
28181     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
28182     1                IANS,IWIDTH,IBUGG3,IERROR)
28183          IHP='SBAR'
28184          IHP2='    '
28185          VALUE0=SBAR
28186          CALL DPADDP(IHP,IHP2,VALUE0,IHOST1,ISUBN0,
28187     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
28188     1                IANS,IWIDTH,IBUGG3,IERROR)
28189        ENDIF
28190C
28191C     CASE 2: SUMMARY DATA WITH NO HIGHLIGHT OPTION
28192C             EXACTLY 2 VARIABLES W
28193C             CIRCLE TECHNIQUE)
28194C
28195      ELSEIF(IHIGH.EQ.'OFF' .AND. ISUMM.EQ.'ON')THEN
28196        NRESP=1
28197        NREPL=1
28198        NHIGH=0
28199        NCURVE=1
28200        ICOL=1
28201        NUMVAR=2
28202        IF(IHOMCT.EQ.'ON')NUMVAR=3
28203        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
28204     1              INAME,IVARN1,IVARN2,IVARTY,
28205     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
28206     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
28207     1              MAXCP4,MAXCP5,MAXCP6,
28208     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
28209     1              Y1,X1,XREPL,NLOCAL,NLOCA2,NLOCA3,ICASE,
28210     1              IBUGG3,ISUBRO,IFOUND,IERROR)
28211C
28212        CALL DPHOM2(Y1,X1,X2,X3,X4,X5,X6,XREPL,
28213     1              NLOCAL,NRESP,NREPL,NHIGH,
28214     1              XIDTEM,XIDTE2,XIDTE3,XIDTE4,XIDTE5,XIDTE6,TEMP,
28215     1              XTEMP1,XTEMP2,XTEMP3,DTEMP1,
28216     1              ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
28217     1              MAXOBV,JSTRT,NCURVE,
28218     1              IHOMLO,IHOMSC,IHOMCT,IMULT,ISUMM,
28219     1              P,PROP1,PROP2,NTRIM1,NTRIM2,IQUASE,ISEED,
28220     1              XBAR,SBAR,
28221     1              Y,X,D,NPLOTP,NPLOTV,
28222     1              IBUGG3,ISUBRO,IERROR)
28223C
28224        IF(IHOMCT.EQ.'ON')THEN
28225          IHP='XBAR'
28226          IHP2='    '
28227          VALUE0=XBAR
28228          CALL DPADDP(IHP,IHP2,VALUE0,IHOST1,ISUBN0,
28229     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
28230     1                IANS,IWIDTH,IBUGG3,IERROR)
28231          IHP='SBAR'
28232          IHP2='    '
28233          VALUE0=SBAR
28234          CALL DPADDP(IHP,IHP2,VALUE0,IHOST1,ISUBN0,
28235     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
28236     1                IANS,IWIDTH,IBUGG3,IERROR)
28237        ENDIF
28238C
28239C     CASE 3: MULTIPLE OPTION
28240C
28241      ELSEIF(IMULT.EQ.'ON')THEN
28242        NRESP=NUMVAR
28243        NHIGH=0
28244        NREPL=0
28245C
28246        NPLOTP=0
28247        DO810IRESP=1,NRESP
28248          NCURVE=IRESP
28249C
28250          ICOL=IRESP
28251          NUMVA2=1
28252          CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
28253     1                INAME,IVARN1,IVARN2,IVARTY,
28254     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
28255     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
28256     1                MAXCP4,MAXCP5,MAXCP6,
28257     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
28258     1                Y1,XTEMP1,XTEMP2,NLOCAL,NLOCA2,NLOCA3,ICASE,
28259     1                IBUGG3,ISUBRO,IFOUND,IERROR)
28260          IF(IERROR.EQ.'YES')GOTO9000
28261C
28262          IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HOMO')THEN
28263            WRITE(ICOUT,999)
28264            CALL DPWRST('XXX','BUG ')
28265            WRITE(ICOUT,811)IRESP,NCURVE,NLOCAL
28266  811       FORMAT('MULTIPLE CASE: IRESP,NCURVE,NLOCAL = ',3I5)
28267            CALL DPWRST('XXX','BUG ')
28268          ENDIF
28269C
28270C               *****************************************************
28271C               **  STEP 8B--                                      **
28272C               **  FORM THE VERTICAL AND HORIZONTAL AXIS          **
28273C               **  VALUES Y(.) AND X(.) FOR THE PLOT.             **
28274C               *****************************************************
28275C
28276          CALL DPHOM2(Y1,X1,X2,X3,X4,X5,X6,XREPL,
28277     1                NLOCAL,NRESP,NREPL,NHIGH,
28278     1                XIDTEM,XIDTE2,XIDTE3,XIDTE4,XIDTE5,XIDTE6,TEMP,
28279     1                XTEMP1,XTEMP2,XTEMP3,DTEMP1,
28280     1                ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
28281     1                MAXOBV,JSTRT,NCURVE,
28282     1                IHOMLO,IHOMSC,IHOMCT,IMULT,ISUMM,
28283     1                P,PROP1,PROP2,NTRIM1,NTRIM2,IQUASE,ISEED,
28284     1                XBAR,SBAR,
28285     1                Y,X,D,NPLOTP,NPLOTV,
28286     1                IBUGG3,ISUBRO,IERROR)
28287          IF(IHOMCT.EQ.'ON')THEN
28288            IHP='XBAR'
28289            IHP2='    '
28290            VALUE0=XBAR
28291            CALL DPADDP(IHP,IHP2,VALUE0,IHOST1,ISUBN0,
28292     1                  IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
28293     1                  IANS,IWIDTH,IBUGG3,IERROR)
28294            IHP='SBAR'
28295            IHP2='    '
28296            VALUE0=SBAR
28297            CALL DPADDP(IHP,IHP2,VALUE0,IHOST1,ISUBN0,
28298     1                  IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
28299     1                  IANS,IWIDTH,IBUGG3,IERROR)
28300          ENDIF
28301C
28302  810   CONTINUE
28303C
28304C     CASE 4: REPLICATION
28305C
28306      ELSE
28307        NRESP=1
28308        NREPL=NUMVAR - NRESP
28309        NHIGH=0
28310        NCURVE=1
28311C
28312        IF(NREPL.LT.1 .OR. NREPL.GT.6)THEN
28313          WRITE(ICOUT,999)
28314          CALL DPWRST('XXX','BUG ')
28315          WRITE(ICOUT,101)
28316  101     FORMAT('***** ERROR IN HOMOSCEDASTICITY PLOT--')
28317          CALL DPWRST('XXX','BUG ')
28318          WRITE(ICOUT,511)
28319  511     FORMAT('      THE NUMBER OF REPLICATION VARIABLES MUST BE')
28320          CALL DPWRST('XXX','BUG ')
28321          WRITE(ICOUT,512)
28322  512     FORMAT('      BETWEEN 1 AND 6;  SUCH WAS NOT THE CASE HERE.')
28323          CALL DPWRST('XXX','BUG ')
28324          WRITE(ICOUT,513)NREPL
28325  513     FORMAT('      THE NUMBER OF REPLICATION VARIABLES = ',I5)
28326          CALL DPWRST('XXX','BUG ')
28327          IERROR='YES'
28328          GOTO9000
28329        ENDIF
28330C
28331C               *****************************************************
28332C               **  STEP 9A--                                      **
28333C               **  CASE 3: ONE TO SIX  REPLICATION VARIABLES.     **
28334C               *****************************************************
28335C
28336        ISTEPN='9A'
28337        IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HOMO')
28338     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28339C
28340        J=0
28341        IMAX=NRIGHT(1)
28342        IF(NQ.LT.NRIGHT(1))IMAX=NQ
28343        DO910I=1,IMAX
28344          IF(ISUB(I).EQ.0)GOTO910
28345          J=J+1
28346C
28347C         RESPONSE VARIABLE IN Y1
28348C
28349          IJ=MAXN*(ICOLR(1)-1)+I
28350          IF(ICOLR(1).LE.MAXCOL)Y1(J)=V(IJ)
28351          IF(ICOLR(1).EQ.MAXCP1)Y1(J)=PRED(I)
28352          IF(ICOLR(1).EQ.MAXCP2)Y1(J)=RES(I)
28353          IF(ICOLR(1).EQ.MAXCP3)Y1(J)=YPLOT(I)
28354          IF(ICOLR(1).EQ.MAXCP4)Y1(J)=XPLOT(I)
28355          IF(ICOLR(1).EQ.MAXCP5)Y1(J)=X2PLOT(I)
28356          IF(ICOLR(1).EQ.MAXCP6)Y1(J)=TAGPLO(I)
28357C
28358          IF(NREPL.GE.1)THEN
28359            IJ=MAXN*(ICOLR(2)-1)+I
28360            IF(ICOLR(2).LE.MAXCOL)X1(J)=V(IJ)
28361            IF(ICOLR(2).EQ.MAXCP1)X1(J)=PRED(I)
28362            IF(ICOLR(2).EQ.MAXCP2)X1(J)=RES(I)
28363            IF(ICOLR(2).EQ.MAXCP3)X1(J)=YPLOT(I)
28364            IF(ICOLR(2).EQ.MAXCP4)X1(J)=XPLOT(I)
28365            IF(ICOLR(2).EQ.MAXCP5)X1(J)=X2PLOT(I)
28366            IF(ICOLR(2).EQ.MAXCP6)X1(J)=TAGPLO(I)
28367          ENDIF
28368C
28369          IF(NREPL.GE.2)THEN
28370            IJ=MAXN*(ICOLR(3)-1)+I
28371            IF(ICOLR(3).LE.MAXCOL)X2(J)=V(IJ)
28372            IF(ICOLR(3).EQ.MAXCP1)X2(J)=PRED(I)
28373            IF(ICOLR(3).EQ.MAXCP2)X2(J)=RES(I)
28374            IF(ICOLR(3).EQ.MAXCP3)X2(J)=YPLOT(I)
28375            IF(ICOLR(3).EQ.MAXCP4)X2(J)=XPLOT(I)
28376            IF(ICOLR(3).EQ.MAXCP5)X2(J)=X2PLOT(I)
28377            IF(ICOLR(3).EQ.MAXCP6)X2(J)=TAGPLO(I)
28378          ENDIF
28379C
28380          IF(NREPL.GE.3)THEN
28381            IJ=MAXN*(ICOLR(4)-1)+I
28382            IF(ICOLR(4).LE.MAXCOL)X3(J)=V(IJ)
28383            IF(ICOLR(4).EQ.MAXCP1)X3(J)=PRED(I)
28384            IF(ICOLR(4).EQ.MAXCP2)X3(J)=RES(I)
28385            IF(ICOLR(4).EQ.MAXCP3)X3(J)=YPLOT(I)
28386            IF(ICOLR(4).EQ.MAXCP4)X3(J)=XPLOT(I)
28387            IF(ICOLR(4).EQ.MAXCP5)X3(J)=X2PLOT(I)
28388            IF(ICOLR(4).EQ.MAXCP6)X3(J)=TAGPLO(I)
28389          ENDIF
28390C
28391          IF(NREPL.GE.4)THEN
28392            IJ=MAXN*(ICOLR(5)-1)+I
28393            IF(ICOLR(5).LE.MAXCOL)X4(J)=V(IJ)
28394            IF(ICOLR(5).EQ.MAXCP1)X4(J)=PRED(I)
28395            IF(ICOLR(5).EQ.MAXCP2)X4(J)=RES(I)
28396            IF(ICOLR(5).EQ.MAXCP3)X4(J)=YPLOT(I)
28397            IF(ICOLR(5).EQ.MAXCP4)X4(J)=XPLOT(I)
28398            IF(ICOLR(5).EQ.MAXCP5)X4(J)=X2PLOT(I)
28399            IF(ICOLR(5).EQ.MAXCP6)X4(J)=TAGPLO(I)
28400          ENDIF
28401C
28402          IF(NREPL.GE.5)THEN
28403            IJ=MAXN*(ICOLR(6)-1)+I
28404            IF(ICOLR(6).LE.MAXCOL)X5(J)=V(IJ)
28405            IF(ICOLR(6).EQ.MAXCP1)X5(J)=PRED(I)
28406            IF(ICOLR(6).EQ.MAXCP2)X5(J)=RES(I)
28407            IF(ICOLR(6).EQ.MAXCP3)X5(J)=YPLOT(I)
28408            IF(ICOLR(6).EQ.MAXCP4)X5(J)=XPLOT(I)
28409            IF(ICOLR(6).EQ.MAXCP5)X5(J)=X2PLOT(I)
28410            IF(ICOLR(6).EQ.MAXCP6)X5(J)=TAGPLO(I)
28411          ENDIF
28412C
28413          IF(NREPL.GE.6)THEN
28414            IJ=MAXN*(ICOLR(7)-1)+I
28415            IF(ICOLR(7).LE.MAXCOL)X6(J)=V(IJ)
28416            IF(ICOLR(7).EQ.MAXCP1)X6(J)=PRED(I)
28417            IF(ICOLR(7).EQ.MAXCP2)X6(J)=RES(I)
28418            IF(ICOLR(7).EQ.MAXCP3)X6(J)=YPLOT(I)
28419            IF(ICOLR(7).EQ.MAXCP4)X6(J)=XPLOT(I)
28420            IF(ICOLR(7).EQ.MAXCP5)X6(J)=X2PLOT(I)
28421            IF(ICOLR(7).EQ.MAXCP6)X6(J)=TAGPLO(I)
28422          ENDIF
28423C
28424  910   CONTINUE
28425        NLOCAL=J
28426        CALL DPHOM2(Y1,X1,X2,X3,X4,X5,X6,XREPL,
28427     1              NLOCAL,NRESP,NREPL,NHIGH,
28428     1              XIDTEM,XIDTE2,XIDTE3,XIDTE4,XIDTE5,XIDTE6,TEMP,
28429     1              XTEMP1,XTEMP2,XTEMP3,DTEMP1,
28430     1              ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
28431     1              MAXOBV,JSTRT,NCURVE,
28432     1              IHOMLO,IHOMSC,IHOMCT,IMULT,ISUMM,
28433     1              P,PROP1,PROP2,NTRIM1,NTRIM2,IQUASE,ISEED,
28434     1              XBAR,SBAR,
28435     1              Y,X,D,NPLOTP,NPLOTV,
28436     1              IBUGG3,ISUBRO,IERROR)
28437      ENDIF
28438C
28439C               *****************
28440C               **  STEP 90--  **
28441C               **  EXIT       **
28442C               *****************
28443C
28444 9000 CONTINUE
28445      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'HOMO')THEN
28446        WRITE(ICOUT,999)
28447        CALL DPWRST('XXX','BUG ')
28448        WRITE(ICOUT,9011)
28449 9011   FORMAT('***** AT THE END       OF DPHOMO--')
28450        CALL DPWRST('XXX','BUG ')
28451        WRITE(ICOUT,9012)IFOUND,IERROR
28452 9012   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
28453        CALL DPWRST('XXX','BUG ')
28454        WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
28455 9013   FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',
28456     1         I8,I8,I8,2X,A4,2X,A4,2X,A4)
28457        CALL DPWRST('XXX','BUG ')
28458        WRITE(ICOUT,9014)ISIZE
28459 9014   FORMAT('ISIZE = ',I8)
28460        CALL DPWRST('XXX','BUG ')
28461        IF(NPLOTP.GE.1)THEN
28462          DO9015I=1,NPLOTP
28463            WRITE(ICOUT,9016)I,Y(I),X1(I),D(I)
28464 9016       FORMAT('I,Y(I),X1(I),D(I) = ',I8,3F12.5)
28465            CALL DPWRST('XXX','BUG ')
28466 9015     CONTINUE
28467        ENDIF
28468      ENDIF
28469C
28470      RETURN
28471      END
28472      SUBROUTINE DPHOM2(Y,X1,X2T,X3,X4,X5,X6,XREPL,
28473     1                  N,NRESP,NREPL,NHIGH,
28474     1                  XIDTEM,XIDTE2,XIDTE3,XIDTE4,XIDTE5,XIDTE6,TEMP,
28475     1                  XTEMP1,XTEMP2,XTEMP3,DTEMP1,
28476     1                  ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
28477     1                  MAXOBV,JSTRT,NCURVE,
28478     1                  IHOMLO,IHOMSC,IHOMCT,IMULT,ISUMM,
28479     1                  P,PROP1,PROP2,NTRIM1,NTRIM2,IQUASE,ISEED,
28480     1                  XBAR,SBAR,
28481     1                  Y2,X2,D2,N2,NPLOTV,
28482     1                  IBUGG3,ISUBRO,IERROR)
28483C
28484C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
28485C              THAT WILL DEFINE AN HOMOGENEITY PLOT
28486C     WRITTEN BY--JAMES J. FILLIBEN
28487C                 STATISTICAL ENGINEERING DIVISION
28488C                 INFORMATION TECHNOLOGY LABORATORY
28489C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
28490C                 GAITHERSBURG, MD 20899-8980
28491C                 PHONE--301-975-2855
28492C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
28493C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
28494C     LANGUAGE--ANSI FORTRAN (1977)
28495C     VERSION NUMBER--82/7
28496C     ORIGINAL VERSION--MARCH     1986.
28497C     UPDATED         --DECEMBER  2010. SUPPORT FOR "MULTIPLE" AND
28498C                                       "HIGHLIGHT/SUBSET"
28499C     UPDATED         --DECEMBER  2010. ALLOW MORE THAN ONE REPLICATION
28500C                                       VARIABLE
28501C     UPDATED         --DECEMBER  2010. ALLOW ALTERNATE LOCATION/SCALE
28502C                                       MEASURES
28503C     UPDATED         --DECEMBER  2010. "CIRCLE TECHNIQUE" FOR IDENTIFYING
28504C                                       NON-HOMOGENOUS LABS (FOR CERTAIN
28505C                                       LOCATION/SCALE MEASURES)
28506C     UPDATED         --DECEMBER  2010. SUPPORT FOR SUMMARY DATA
28507C
28508C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
28509C
28510      CHARACTER*4 IHOMLO
28511      CHARACTER*4 IHOMSC
28512      CHARACTER*4 IHOMCT
28513      CHARACTER*4 IMULT
28514      CHARACTER*4 ISUMM
28515      CHARACTER*4 IQUASE
28516      CHARACTER*4 IBUGG3
28517      CHARACTER*4 ISUBRO
28518      CHARACTER*4 IERROR
28519C
28520      CHARACTER*4 IWRITE
28521      CHARACTER*4 IHOML2
28522      CHARACTER*4 IHOMS2
28523      CHARACTER*4 ICASE
28524C
28525      CHARACTER*4 ISUBN1
28526      CHARACTER*4 ISUBN2
28527      CHARACTER*4 ISTEPN
28528C
28529C---------------------------------------------------------------------
28530C
28531      DIMENSION Y(*)
28532      DIMENSION X1(*)
28533      DIMENSION X2T(*)
28534      DIMENSION X3(*)
28535      DIMENSION X4(*)
28536      DIMENSION X5(*)
28537      DIMENSION X6(*)
28538      DIMENSION XREPL(*)
28539      DIMENSION Y2(*)
28540      DIMENSION X2(*)
28541      DIMENSION D2(*)
28542C
28543      DIMENSION XIDTEM(*)
28544      DIMENSION XIDTE2(*)
28545      DIMENSION XIDTE3(*)
28546      DIMENSION XIDTE4(*)
28547      DIMENSION XIDTE5(*)
28548      DIMENSION XIDTE6(*)
28549      DIMENSION TEMP(*)
28550      DIMENSION XTEMP1(*)
28551      DIMENSION XTEMP2(*)
28552      DIMENSION XTEMP3(*)
28553C
28554      DOUBLE PRECISION DTEMP1(*)
28555C
28556      INTEGER ITEMP1(*)
28557      INTEGER ITEMP2(*)
28558      INTEGER ITEMP3(*)
28559      INTEGER ITEMP4(*)
28560      INTEGER ITEMP5(*)
28561      INTEGER ITEMP6(*)
28562C
28563C---------------------------------------------------------------------
28564C
28565      INCLUDE 'DPCOP2.INC'
28566C
28567C-----START POINT-----------------------------------------------------
28568C
28569      ISUBN1='DPHO'
28570      ISUBN2='M2  '
28571      IWRITE='OFF'
28572C
28573      IHOML2=IHOMLO
28574      IHOMS2=IHOMSC
28575      IF(IHOMCT.EQ.'ON' .AND. IMULT.EQ.'OFF' .AND. NREPL.EQ.1)THEN
28576        IHOMLO='MEAN'
28577        IHOMSC='SD'
28578      ENDIF
28579C
28580      I2=0
28581      AN=0.0
28582C
28583      N50=1
28584C
28585C     CHECK THE INPUT ARGUMENTS FOR ERRORS
28586C
28587      IF(N.LT.3)THEN
28588        WRITE(ICOUT,999)
28589  999   FORMAT(1X)
28590        CALL DPWRST('XXX','BUG ')
28591        WRITE(ICOUT,31)
28592   31   FORMAT('***** ERROR IN HOMOGENEITY PLOT--')
28593        CALL DPWRST('XXX','BUG ')
28594        WRITE(ICOUT,32)
28595   32   FORMAT('      THE NUMBER OF OBSERVATIONS WAS LESS THAN THREE.')
28596        CALL DPWRST('XXX','BUG ')
28597        WRITE(ICOUT,34)N
28598   34   FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS  = ',I6)
28599        CALL DPWRST('XXX','BUG ')
28600        WRITE(ICOUT,999)
28601        CALL DPWRST('XXX','BUG ')
28602        IERROR='YES'
28603        GOTO9000
28604      ENDIF
28605C
28606      HOLD=Y(1)
28607      DO60I=1,N
28608        IF(Y(I).NE.HOLD)GOTO69
28609   60 CONTINUE
28610      WRITE(ICOUT,999)
28611      CALL DPWRST('XXX','BUG ')
28612      WRITE(ICOUT,31)
28613      CALL DPWRST('XXX','BUG ')
28614      WRITE(ICOUT,62)
28615   62 FORMAT('      ALL RESPONSE VARIABLE ELEMENTS')
28616      CALL DPWRST('XXX','BUG ')
28617      WRITE(ICOUT,63)HOLD
28618   63 FORMAT('      ARE IDENTICALLY EQUAL TO ',G15.7)
28619      CALL DPWRST('XXX','BUG ')
28620      WRITE(ICOUT,999)
28621      CALL DPWRST('XXX','BUG ')
28622      IERROR='YES'
28623      GOTO9000
28624   69 CONTINUE
28625C
28626      IF(ISUMM.EQ.'ON' .AND. IHOMCT.EQ.'ON')THEN
28627        DO70I=1,N
28628          ITEMP=INT(XREPL(I)+0.5)
28629          IF(ITEMP.LT.1)THEN
28630            WRITE(ICOUT,999)
28631            CALL DPWRST('XXX','BUG ')
28632            WRITE(ICOUT,31)
28633            CALL DPWRST('XXX','BUG ')
28634            WRITE(ICOUT,72)I
28635   72       FORMAT('      THE NUMBER OF REPLICATIONS FOR LAB ',I8,
28636     1             'IS LESS THAN ONE.')
28637            CALL DPWRST('XXX','BUG ')
28638            WRITE(ICOUT,74)ITEMP
28639   74       FORMAT('      THE NUMBER OF REPLICATIONS   = ',I8)
28640            CALL DPWRST('XXX','BUG ')
28641            IERROR='YES'
28642            GOTO9000
28643          ELSE
28644            XREPL(I)=REAL(ITEMP)
28645          ENDIF
28646   70   CONTINUE
28647      ENDIF
28648C
28649      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'HOM2')THEN
28650        WRITE(ICOUT,80)
28651   80   FORMAT('AT THE BEGINNING OF DPHOM2--')
28652        CALL DPWRST('XXX','BUG ')
28653        WRITE(ICOUT,81)N,NRESP,NREPL,NHIGH
28654   81   FORMAT('N,NRESP,NREPL,NHIGH = ',4I8)
28655        CALL DPWRST('XXX','BUG ')
28656        WRITE(ICOUT,82)IMULT,ISUMM,IMULT
28657   82   FORMAT('IHIGH,ISUMM,IMULT = ',2(A4,2X),A4)
28658        CALL DPWRST('XXX','BUG ')
28659        DO85I=1,N
28660          WRITE(ICOUT,83)I,Y(I),X1(I),X2(I),X3(I)
28661   83     FORMAT('I,Y(I),X1(I),X2(I),X3(I) = ',I8,4G15.7)
28662          CALL DPWRST('XXX','BUG ')
28663   85   CONTINUE
28664      ENDIF
28665C
28666C     CASES:
28667C
28668C        1) ONE RESPONSE, ONE REPLICATION, WITH OR WITHOUT
28669C           HIGHLIGHTING VARIABLE
28670C
28671C        2) MULTIPLE RESPONSE VARIABLES, NO REPLICATION VARIABLE
28672C
28673C        3) ONE RESPONSE, TWO OR MORE REPLICATION VARIABLES
28674C
28675C
28676C               ********************************************************
28677C               **  STEP 1--                                          **
28678C               **  DETERMINE THE NUMBER OF DISTINCT VALUES FOR THE   **
28679C               **  GROUP-ID (REPLICATION) GROUP VARIABLES).          **
28680C               **  IF ALL VALUES ARE DISTINCT, THEN THIS IMPLIES WE  **
28681C               **  HAVE THE NO REPLICATION CASE WHICH IS AN          **
28682C               **  ERROR CONDITION FOR A HOMOGENEITY PLOT.           **
28683C               ********************************************************
28684C
28685      ISTEPN='1'
28686      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'HOM2')
28687     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28688C
28689      NUMSET=1
28690      NUMSE1=1
28691      NUMSE2=1
28692      NUMSE3=1
28693      NUMSE4=1
28694      NUMSE5=1
28695      NUMSE6=1
28696C
28697      IF(IMULT.EQ.'OFF' .AND. ISUMM.EQ.'OFF')THEN
28698        CALL DISTIN(X1,N,IWRITE,XIDTEM,NUMSE1,IBUGG3,IERROR)
28699        CALL SORT(XIDTEM,NUMSE1,XIDTEM)
28700        IF(NUMSE1.EQ.N)THEN
28701          WRITE(ICOUT,999)
28702          CALL DPWRST('XXX','BUG ')
28703          WRITE(ICOUT,31)
28704          CALL DPWRST('XXX','BUG ')
28705          WRITE(ICOUT,102)
28706  102     FORMAT('      FOR THE FIRST REPLICATION VARIABLE, THE NUMBER')
28707          CALL DPWRST('XXX','BUG ')
28708          WRITE(ICOUT,104)
28709  104     FORMAT('      OF SETS EQUAL THE NUMBER OF RESPONSE VALUES.')
28710          CALL DPWRST('XXX','BUG ')
28711          IERROR='YES'
28712          GOTO9000
28713        ENDIF
28714      ENDIF
28715C
28716      IF(NREPL.GE.2)THEN
28717        CALL DISTIN(X2T,N,IWRITE,XIDTE2,NUMSE2,IBUGG3,IERROR)
28718        CALL SORT(XIDTE2,NUMSE2,XIDTE2)
28719        IF(NUMSE2.EQ.N)THEN
28720          WRITE(ICOUT,999)
28721          CALL DPWRST('XXX','BUG ')
28722          WRITE(ICOUT,31)
28723          CALL DPWRST('XXX','BUG ')
28724          WRITE(ICOUT,112)
28725  112     FORMAT('      FOR THE SECOND REPLICATION VARIABLE, THE ',
28726     1           'NUMBER')
28727          CALL DPWRST('XXX','BUG ')
28728          WRITE(ICOUT,104)
28729          CALL DPWRST('XXX','BUG ')
28730          IERROR='YES'
28731          GOTO9000
28732        ENDIF
28733      ENDIF
28734C
28735      IF(NREPL.GE.3)THEN
28736        CALL DISTIN(X3,N,IWRITE,XIDTE3,NUMSE3,IBUGG3,IERROR)
28737        CALL SORT(XIDTE3,NUMSE3,XIDTE3)
28738        IF(NUMSE3.EQ.N)THEN
28739          WRITE(ICOUT,999)
28740          CALL DPWRST('XXX','BUG ')
28741          WRITE(ICOUT,31)
28742          CALL DPWRST('XXX','BUG ')
28743          WRITE(ICOUT,122)
28744  122     FORMAT('      FOR THE THIRD REPLICATION VARIABLE, THE ',
28745     1           'NUMBER')
28746          CALL DPWRST('XXX','BUG ')
28747          WRITE(ICOUT,104)
28748          CALL DPWRST('XXX','BUG ')
28749          IERROR='YES'
28750          GOTO9000
28751        ENDIF
28752      ENDIF
28753C
28754      IF(NREPL.GE.4)THEN
28755        CALL DISTIN(X4,N,IWRITE,XIDTE4,NUMSE4,IBUGG3,IERROR)
28756        CALL SORT(XIDTE4,NUMSE4,XIDTE4)
28757        IF(NUMSE4.EQ.N)THEN
28758          WRITE(ICOUT,999)
28759          CALL DPWRST('XXX','BUG ')
28760          WRITE(ICOUT,31)
28761          CALL DPWRST('XXX','BUG ')
28762          WRITE(ICOUT,142)
28763  142     FORMAT('      FOR THE FOURTH REPLICATION VARIABLE, THE ',
28764     1           'NUMBER')
28765          CALL DPWRST('XXX','BUG ')
28766          WRITE(ICOUT,104)
28767          CALL DPWRST('XXX','BUG ')
28768          IERROR='YES'
28769          GOTO9000
28770        ENDIF
28771      ENDIF
28772C
28773      IF(NREPL.GE.5)THEN
28774        CALL DISTIN(X5,N,IWRITE,XIDTE5,NUMSE5,IBUGG3,IERROR)
28775        CALL SORT(XIDTE5,NUMSE5,XIDTE5)
28776        IF(NUMSE5.EQ.N)THEN
28777          WRITE(ICOUT,999)
28778          CALL DPWRST('XXX','BUG ')
28779          WRITE(ICOUT,31)
28780          CALL DPWRST('XXX','BUG ')
28781          WRITE(ICOUT,152)
28782  152     FORMAT('      FOR THE FIFTH REPLICATION VARIABLE, THE ',
28783     1           'NUMBER')
28784          CALL DPWRST('XXX','BUG ')
28785          WRITE(ICOUT,104)
28786          CALL DPWRST('XXX','BUG ')
28787          IERROR='YES'
28788          GOTO9000
28789        ENDIF
28790      ENDIF
28791C
28792      IF(NREPL.GE.6)THEN
28793        CALL DISTIN(X6,N,IWRITE,XIDTE6,NUMSE6,IBUGG3,IERROR)
28794        CALL SORT(XIDTE6,NUMSE6,XIDTE6)
28795        IF(NUMSE6.EQ.N)THEN
28796          WRITE(ICOUT,999)
28797          CALL DPWRST('XXX','BUG ')
28798          WRITE(ICOUT,31)
28799          CALL DPWRST('XXX','BUG ')
28800          WRITE(ICOUT,162)
28801  162     FORMAT('      FOR THE SIXTH REPLICATION VARIABLE, THE ',
28802     1           'NUMBER')
28803          CALL DPWRST('XXX','BUG ')
28804          WRITE(ICOUT,104)
28805          CALL DPWRST('XXX','BUG ')
28806          IERROR='YES'
28807          GOTO9000
28808        ENDIF
28809      ENDIF
28810C
28811      NUMSET=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5*NUMSE6
28812      IF(ISUMM.EQ.'ON')THEN
28813        NUMSE1=N
28814        NUMSET=N
28815      ENDIF
28816C
28817C               ***************************************************
28818C               **  STEP 4--                                     **
28819C               **  DETERMINE PLOT COORDINATES                   **
28820C               ***************************************************
28821C
28822      ISTEPN='4'
28823      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'HOM2')
28824     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28825C
28826      J=JSTRT
28827C
28828      IF(NREPL.LE.1)THEN
28829        DO1110ISET=1,NUMSET
28830C
28831          IF(IMULT.EQ.'ON')THEN
28832            DO1010I=1,N
28833              TEMP(I)=Y(I)
28834 1010       CONTINUE
28835            NI=N
28836          ELSEIF(ISUMM.EQ.'ON')THEN
28837            XMEAN=Y(ISET)
28838            XSD=X1(ISET)
28839          ELSE
28840            K=0
28841            DO1120I=1,N
28842              IF(X1(I).EQ.XIDTEM(ISET))THEN
28843                K=K+1
28844                TEMP(K)=Y(I)
28845              ENDIF
28846 1120       CONTINUE
28847            NI=K
28848            XREPL(ISET)=REAL(NI)
28849          ENDIF
28850C
28851          IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'HOM2')THEN
28852            WRITE(ICOUT,1121)ISET,XIDTEM(ISET),NI
28853 1121       FORMAT('ISET,XIDTEM(ISET),NI = ',I8,G15.7,I8)
28854            CALL DPWRST('XXX','BUG ')
28855          ENDIF
28856C
28857          IF(ISUMM.EQ.'OFF')THEN
28858            CALL DPHOM3(TEMP,NI,IHOMLO,IHOMSC,
28859     1                  P,PROP1,PROP2,NTRIM1,NTRIM2,
28860     1                  XTEMP1,XTEMP2,XTEMP3,DTEMP1,
28861     1                  ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
28862     1                  MAXOBV,ISEED,IQUASE,
28863     1                  XMEAN,XSD,
28864     1                  IBUGG3,ISUBRO,IERROR)
28865          ENDIF
28866          J=J+1
28867          Y2(J)=XSD
28868          X2(J)=XMEAN
28869          IF(NHIGH.GT.0)THEN
28870            D2(J)=REAL(J)
28871          ELSEIF(IMULT.EQ.'ON')THEN
28872            D2(J)=REAL(NCURVE)
28873          ELSE
28874            D2(J)=1.0
28875          ENDIF
28876C
28877 1110   CONTINUE
28878C
28879      ELSEIF(NREPL.EQ.2)THEN
28880        DO1210ISET1=1,NUMSE1
28881        DO1220ISET2=1,NUMSE2
28882C
28883          K=0
28884          DO1280I=1,N
28885            IF(X1(I).EQ.XIDTEM(ISET1) .AND. X2T(I).EQ.XIDTE2(ISET2))THEN
28886              K=K+1
28887              TEMP(K)=Y(I)
28888            ENDIF
28889 1280     CONTINUE
28890          NI=K
28891C
28892          IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'HOM2')THEN
28893            WRITE(ICOUT,1221)ISET1,ISET2,NI,XIDTEM(ISET1),XIDTE2(ISET2)
28894 1221       FORMAT('ISET1,ISET2,NI,XIDTEM(ISET1),XIDTE2(ISET2) = ',
28895     1             3I8,2G15.7)
28896            CALL DPWRST('XXX','BUG ')
28897          ENDIF
28898C
28899          CALL DPHOM3(TEMP,NI,IHOMLO,IHOMSC,
28900     1                P,PROP1,PROP2,NTRIM1,NTRIM2,
28901     1                XTEMP1,XTEMP2,XTEMP3,DTEMP1,
28902     1                ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
28903     1                MAXOBV,ISEED,IQUASE,
28904     1                XMEAN,XSD,
28905     1                IBUGG3,ISUBRO,IERROR)
28906          J=J+1
28907          Y2(J)=XSD
28908          X2(J)=XMEAN
28909          D2(J)=REAL(J)
28910C
28911 1220   CONTINUE
28912 1210   CONTINUE
28913C
28914      ELSEIF(NREPL.EQ.3)THEN
28915        DO1310ISET1=1,NUMSE1
28916        DO1320ISET2=1,NUMSE2
28917        DO1330ISET3=1,NUMSE3
28918C
28919          K=0
28920          DO1380I=1,N
28921            IF(X1(I).EQ.XIDTEM(ISET1).AND.X2T(I).EQ.XIDTE2(ISET2).AND.
28922     1         X3(I).EQ.XIDTE3(ISET3)
28923     1        )THEN
28924              K=K+1
28925              TEMP(K)=Y(I)
28926            ENDIF
28927 1380     CONTINUE
28928          NI=K
28929C
28930          IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'HOM2')THEN
28931            WRITE(ICOUT,1321)ISET1,ISET2,ISET3,NI,
28932     1                       XIDTEM(ISET1),XIDTE2(ISET2),XIDTE3(ISET3)
28933 1321       FORMAT('ISET1,ISET2,SET3,NI,XIDTEM(ISET1),XIDTE2(ISET2),',
28934     `             'XIDTE3(ISET3) = ',4I8,3G15.7)
28935            CALL DPWRST('XXX','BUG ')
28936          ENDIF
28937C
28938          CALL DPHOM3(TEMP,NI,IHOMLO,IHOMSC,
28939     1                P,PROP1,PROP2,NTRIM1,NTRIM2,
28940     1                XTEMP1,XTEMP2,XTEMP3,DTEMP1,
28941     1                ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
28942     1                MAXOBV,ISEED,IQUASE,
28943     1                XMEAN,XSD,
28944     1                IBUGG3,ISUBRO,IERROR)
28945          J=J+1
28946          Y2(J)=XSD
28947          X2(J)=XMEAN
28948          D2(J)=REAL(J)
28949C
28950 1330   CONTINUE
28951 1320   CONTINUE
28952 1310   CONTINUE
28953C
28954      ELSEIF(NREPL.EQ.4)THEN
28955        DO1410ISET1=1,NUMSE1
28956        DO1420ISET2=1,NUMSE2
28957        DO1430ISET3=1,NUMSE3
28958        DO1440ISET4=1,NUMSE4
28959C
28960          K=0
28961          DO1480I=1,N
28962            IF(X1(I).EQ.XIDTEM(ISET1).AND.X2T(I).EQ.XIDTE2(ISET2).AND.
28963     1         X3(I).EQ.XIDTE3(ISET3).AND.X4(I).EQ.XIDTE4(ISET4)
28964     1        )THEN
28965              K=K+1
28966              TEMP(K)=Y(I)
28967            ENDIF
28968 1480     CONTINUE
28969          NI=K
28970C
28971          IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'HOM2')THEN
28972            WRITE(ICOUT,1421)ISET1,ISET2,ISET3,ISET4,NI
28973 1421       FORMAT('ISET1,ISET2,SET3,ISET4,NI = ',4I8)
28974            CALL DPWRST('XXX','BUG ')
28975            WRITE(ICOUT,1423)XIDTEM(ISET1),XIDTE2(ISET2),XIDTE3(ISET3),
28976     1                       XIDTE4(ISET4)
28977 1423       FORMAT('XIDTEM(ISET1),XIDTE2(ISET2),XIDTE3(ISET3),',
28978     1             'XIDTE4(ISET4) = ',4G15.7)
28979            CALL DPWRST('XXX','BUG ')
28980          ENDIF
28981C
28982          CALL DPHOM3(TEMP,NI,IHOMLO,IHOMSC,
28983     1                P,PROP1,PROP2,NTRIM1,NTRIM2,
28984     1                XTEMP1,XTEMP2,XTEMP3,DTEMP1,
28985     1                ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
28986     1                MAXOBV,ISEED,IQUASE,
28987     1                XMEAN,XSD,
28988     1                IBUGG3,ISUBRO,IERROR)
28989          J=J+1
28990          Y2(J)=XSD
28991          X2(J)=XMEAN
28992          D2(J)=REAL(J)
28993C
28994 1440   CONTINUE
28995 1430   CONTINUE
28996 1420   CONTINUE
28997 1410   CONTINUE
28998C
28999      ELSEIF(NREPL.EQ.5)THEN
29000        DO1510ISET1=1,NUMSE1
29001        DO1520ISET2=1,NUMSE2
29002        DO1530ISET3=1,NUMSE3
29003        DO1540ISET4=1,NUMSE4
29004        DO1550ISET5=1,NUMSE5
29005C
29006          K=0
29007          DO1580I=1,N
29008            IF(X1(I).EQ.XIDTEM(ISET1).AND.X2T(I).EQ.XIDTE2(ISET2).AND.
29009     1         X3(I).EQ.XIDTE3(ISET3).AND.X4(I).EQ.XIDTE4(ISET4).AND.
29010     1         X5(I).EQ.XIDTE5(ISET5)
29011     1        )THEN
29012              K=K+1
29013              TEMP(K)=Y(I)
29014            ENDIF
29015 1580     CONTINUE
29016          NI=K
29017C
29018          IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'HOM2')THEN
29019            WRITE(ICOUT,1521)ISET1,ISET2,ISET3,ISET4,ISET5,NI
29020 1521       FORMAT('ISET1,ISET2,SET3,ISET4,ISET5,NI = ',5I8)
29021            CALL DPWRST('XXX','BUG ')
29022            WRITE(ICOUT,1523)XIDTEM(ISET1),XIDTE2(ISET2),XIDTE3(ISET3),
29023     1                       XIDTE4(ISET4),XIDTE5(ISET5)
29024 1523       FORMAT('XIDTEM(ISET1),XIDTE2(ISET2),XIDTE3(ISET3),',
29025     1             'XIDTE4(ISET4),XIDTE5(ISET5) = ',5G15.7)
29026            CALL DPWRST('XXX','BUG ')
29027          ENDIF
29028C
29029          CALL DPHOM3(TEMP,NI,IHOMLO,IHOMSC,
29030     1                P,PROP1,PROP2,NTRIM1,NTRIM2,
29031     1                XTEMP1,XTEMP2,XTEMP3,DTEMP1,
29032     1                ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
29033     1                MAXOBV,ISEED,IQUASE,
29034     1                XMEAN,XSD,
29035     1                IBUGG3,ISUBRO,IERROR)
29036          J=J+1
29037          Y2(J)=XSD
29038          X2(J)=XMEAN
29039          D2(J)=REAL(J)
29040C
29041 1550   CONTINUE
29042 1540   CONTINUE
29043 1530   CONTINUE
29044 1520   CONTINUE
29045 1510   CONTINUE
29046C
29047      ELSEIF(NREPL.EQ.6)THEN
29048        DO1610ISET1=1,NUMSE1
29049        DO1620ISET2=1,NUMSE2
29050        DO1630ISET3=1,NUMSE3
29051        DO1640ISET4=1,NUMSE4
29052        DO1650ISET5=1,NUMSE5
29053        DO1660ISET6=1,NUMSE6
29054C
29055          K=0
29056          DO1680I=1,N
29057            IF(X1(I).EQ.XIDTEM(ISET1).AND.X2T(I).EQ.XIDTE2(ISET2).AND.
29058     1         X3(I).EQ.XIDTE3(ISET3).AND.X4(I).EQ.XIDTE4(ISET4).AND.
29059     1         X5(I).EQ.XIDTE5(ISET5)
29060     1        )THEN
29061              K=K+1
29062              TEMP(K)=Y(I)
29063            ENDIF
29064 1680     CONTINUE
29065          NI=K
29066C
29067          IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'HOM2')THEN
29068            WRITE(ICOUT,1621)ISET1,ISET2,ISET3,ISET4,ISET5,NI
29069 1621       FORMAT('ISET1,ISET2,SET3,ISET4,ISET5,NI = ',5I8)
29070            CALL DPWRST('XXX','BUG ')
29071            WRITE(ICOUT,1623)XIDTEM(ISET1),XIDTE2(ISET2),XIDTE3(ISET3),
29072     1                       XIDTE4(ISET4),XIDTE5(ISET5)
29073 1623       FORMAT('XIDTEM(ISET1),XIDTE2(ISET2),XIDTE3(ISET3),',
29074     1             'XIDTE4(ISET4),XIDTE5(ISET5) = ',5G16.7)
29075            CALL DPWRST('XXX','BUG ')
29076          ENDIF
29077C
29078          CALL DPHOM3(TEMP,NI,IHOMLO,IHOMSC,
29079     1                P,PROP1,PROP2,NTRIM1,NTRIM2,
29080     1                XTEMP1,XTEMP2,XTEMP3,DTEMP1,
29081     1                ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
29082     1                MAXOBV,ISEED,IQUASE,
29083     1                XMEAN,XSD,
29084     1                IBUGG3,ISUBRO,IERROR)
29085          J=J+1
29086          Y2(J)=XSD
29087          X2(J)=XMEAN
29088          D2(J)=REAL(J)
29089C
29090 1660   CONTINUE
29091 1650   CONTINUE
29092 1640   CONTINUE
29093 1630   CONTINUE
29094 1620   CONTINUE
29095 1610   CONTINUE
29096C
29097      ENDIF
29098C
29099      N2=J
29100C
29101C     IMPLEMENT "CIRCLE TECHNIQUE" IF REQUESTED.  NOTE THAT "X2"
29102C     CONTAINS THE MEAN VALUES AND "Y2" CONTAINS THE STANDARD DEVIATION
29103C     VALUES.
29104C
29105C     CONTOURS WILL BE DRAW AT ALPHA = 0.05, 0.01, 0.001
29106C
29107      IF(IHOMCT.EQ.'ON' .AND. IMULT.EQ.'OFF' .AND. NREPL.EQ.1)THEN
29108C
29109C       DETERMINE AN "AVERAGE" NUMBER OF REPLICATIONS.  THE NUMBER
29110C       OF REPLICATIONS SHOULD REALLY BE THE SAME FOR ALL LABS, BUT
29111C       COMPUTE AN AVERAGE NUMBER OF REPLICATIONS IN CASE THEY ARE
29112C       NOT.
29113C
29114        IF(IHOMSC.EQ.'RANG')THEN
29115          ICASE='RANG'
29116        ELSEIF(IHOMSC.EQ.'SD  ')THEN
29117          ICASE='SD'
29118        ELSE
29119            WRITE(ICOUT,999)
29120            CALL DPWRST('XXX','BUG ')
29121            WRITE(ICOUT,31)
29122            CALL DPWRST('XXX','BUG ')
29123            WRITE(ICOUT,1993)
29124 1993       FORMAT('      THE CIRCLE TECHNIQUE CONTOUR LINES ARE ',
29125     1             'ONLY SUPPORTED')
29126            CALL DPWRST('XXX','BUG ')
29127            WRITE(ICOUT,1995)
29128 1995       FORMAT('      FOR THE STANDARD DEVIATION AND RANGE SCALE ',
29129     1             'STATISTICS')
29130            CALL DPWRST('XXX','BUG ')
29131            IERROR='YES'
29132            GOTO9000
29133        ENDIF
29134C
29135        CALL MEAN(XREPL,N2,IWRITE,AN,IBUGG3,IERROR)
29136        NCUT=0
29137        C=1.5
29138        CALL H15(X2,N2,C,NCUT,XBAR,XSCAL,XTEMP1,XTEMP2,MAXOBV,
29139     1           ISUBRO,IBUGG3)
29140        IF(IERROR.EQ.'YES')GOTO9000
29141        CALL ROBPSD(Y2,N2,INT(AN+0.5),XTEMP1,ICASE,IWRITE,MAXOBV,
29142     1              SBAR,IERROR,ISUBRO,IBUGG3)
29143        IF(IERROR.EQ.'YES')GOTO9000
29144C
29145        IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'HOM2')THEN
29146          WRITE(ICOUT,2001)N2,AN,XBAR,SBAR
29147 2001     FORMAT('AT START OF CONTOUR LINES: N2,AN,XBAR,SBAR = ',
29148     1           I8,3G15.7)
29149          CALL DPWRST('XXX','BUG ')
29150          DO2003I=1,N2
29151            WRITE(ICOUT,2005)I,X2(I),Y2(I),D2(I),XREPL(I)
29152 2005       FORMAT('I,X2(I),Y2(I),D2(I),XREPL(I) = ',I8,4G15.7)
29153            CALL DPWRST('XXX','BUG ')
29154 2003     CONTINUE
29155        ENDIF
29156C
29157C       ADD 3 TO D2 (CONTOUR LINES WILL COME FIRST), THEN
29158C       SHIFT 2*3*NINC DOWN TO ACCOMODATE CONTOUR LINES AT
29159C       START OF ARRAY (THERE ARE 3 CONTOUR LINES WITH 2*NINC
29160C       POINTS EACH).
29161C
29162        NINC=100
29163        NSHIFT=2*3*NINC
29164        DO2010I=1,N2
29165          D2(I)=D2(I)+3.0
29166 2010   CONTINUE
29167        DO2015I=1,MAXOBV
29168          XTEMP1(I)=0.0
29169 2015   CONTINUE
29170C
29171        CALL SHIFTZ(Y2,N2,NSHIFT,MAXOBV,XTEMP1,NOUT,
29172     1              ISUBRO,IBUGG3,IERROR)
29173        DO2020I=1,NOUT
29174         Y2(I)=XTEMP1(I)
29175 2020   CONTINUE
29176        CALL SHIFTZ(X2,N2,NSHIFT,MAXOBV,XTEMP1,NOUT,
29177     1              ISUBRO,IBUGG3,IERROR)
29178        DO2030I=1,NOUT
29179         X2(I)=XTEMP1(I)
29180 2030   CONTINUE
29181        CALL SHIFTZ(D2,N2,NSHIFT,MAXOBV,XTEMP1,NOUT,
29182     1              ISUBRO,IBUGG3,IERROR)
29183        DO2040I=1,NOUT
29184         D2(I)=XTEMP1(I)
29185 2040   CONTINUE
29186C
29187        IDF=2
29188        CALL CHSPPF(0.999,IDF,CHS999)
29189        CALL CHSPPF(0.99,IDF,CHS99)
29190        CALL CHSPPF(0.95,IDF,CHS95)
29191CCCCC   CALL CHSPPF(0.01,IDF,CHS01)
29192CCCCC   CALL CHSPPF(0.05,IDF,CHS05)
29193CCCCC   CALL CHSPPF(0.001,IDF,CHS001)
29194C
29195        TERM1=1.0/SQRT(2.0*(AN-1.0))
29196        ICNT=0
29197C
29198C       TO HAVE CONTOUR LINES DRAWN IN PROPER SEQUENCE (WITH
29199C       PRE-SORT OFF), DO LOWER AND UPPER HALVES SEPARATELY.
29200C
29201        XMIN=XBAR - SBAR*SQRT(CHS999/AN)
29202        XMAX=XBAR + SBAR*SQRT(CHS999/AN)
29203C
29204        IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'HOM2')THEN
29205          WRITE(ICOUT,2101)XBAR,SBAR,CHS999,AN
29206 2101     FORMAT('XBAR,SBAR,CHS999,AN = ',4G15.7)
29207          CALL DPWRST('XXX','BUG ')
29208          WRITE(ICOUT,2103)XMIN,XMAX
29209 2103     FORMAT('XMIN,XMAX = ',2G15.7)
29210          CALL DPWRST('XXX','BUG ')
29211        ENDIF
29212C
29213        XINC=(XMAX - XMIN)/REAL(NINC-1)
29214        XCOOR=XMIN - XINC
29215        DO2110I=1,NINC
29216          XCOOR=XCOOR + XINC
29217          IF(I.EQ.1 .OR. I.EQ.NINC)THEN
29218            TERM2=0.0
29219          ELSE
29220            TERM2=SQRT(CHS999 - (SQRT(AN)*(XCOOR - XBAR)/SBAR)**2)
29221          ENDIF
29222          YCOOR=SBAR*EXP(-TERM1*TERM2)
29223          ICNT=ICNT+1
29224          X2(ICNT)=XCOOR
29225          Y2(ICNT)=YCOOR
29226          D2(ICNT)=1.0
29227 2110   CONTINUE
29228        XCOOR=XMAX + XINC
29229        DO2115I=NINC,1,-1
29230          XCOOR=XCOOR - XINC
29231          IF(I.EQ.1 .OR. I.EQ.NINC)THEN
29232            TERM2=0.0
29233          ELSE
29234            TERM2=SQRT(CHS999 - (SQRT(AN)*(XCOOR - XBAR)/SBAR)**2)
29235          ENDIF
29236          YCOOR=SBAR*EXP(TERM1*TERM2)
29237          ICNT=ICNT+1
29238          X2(ICNT)=XCOOR
29239          Y2(ICNT)=YCOOR
29240          D2(ICNT)=1.0
29241 2115   CONTINUE
29242C
29243        XMIN=XBAR - SBAR*SQRT(CHS99/AN)
29244        XMAX=XBAR + SBAR*SQRT(CHS99/AN)
29245        XINC=(XMAX - XMIN)/REAL(NINC-1)
29246        XCOOR=XMIN - XINC
29247        DO2120I=1,NINC
29248          XCOOR=XCOOR + XINC
29249          IF(I.EQ.1 .OR. I.EQ.NINC)THEN
29250            TERM2=0.0
29251          ELSE
29252            TERM2=SQRT(CHS99 - (SQRT(AN)*(XCOOR - XBAR)/SBAR)**2)
29253          ENDIF
29254          YCOOR=SBAR*EXP(-TERM1*TERM2)
29255          ICNT=ICNT+1
29256          X2(ICNT)=XCOOR
29257          Y2(ICNT)=YCOOR
29258          D2(ICNT)=2.0
29259 2120   CONTINUE
29260        XCOOR=XMAX + XINC
29261        DO2125I=NINC,1,-1
29262          XCOOR=XCOOR - XINC
29263          IF(I.EQ.1 .OR. I.EQ.NINC)THEN
29264            TERM2=0.0
29265          ELSE
29266            TERM2=SQRT(CHS99 - (SQRT(AN)*(XCOOR - XBAR)/SBAR)**2)
29267          ENDIF
29268          YCOOR=SBAR*EXP(TERM1*TERM2)
29269          ICNT=ICNT+1
29270          X2(ICNT)=XCOOR
29271          Y2(ICNT)=YCOOR
29272          D2(ICNT)=2.0
29273 2125   CONTINUE
29274C
29275        XMIN=XBAR - SBAR*SQRT(CHS95/AN)
29276        XMAX=XBAR + SBAR*SQRT(CHS95/AN)
29277        XINC=(XMAX - XMIN)/REAL(NINC-1)
29278        XCOOR=XMIN - XINC
29279        DO2130I=1,NINC
29280          XCOOR=XCOOR + XINC
29281          IF(I.EQ.1 .OR. I.EQ.NINC)THEN
29282            TERM2=0.0
29283          ELSE
29284            TERM2=SQRT(CHS95 - (SQRT(AN)*(XCOOR - XBAR)/SBAR)**2)
29285          ENDIF
29286          YCOOR=SBAR*EXP(-TERM1*TERM2)
29287          ICNT=ICNT+1
29288          X2(ICNT)=XCOOR
29289          Y2(ICNT)=YCOOR
29290          D2(ICNT)=3.0
29291 2130   CONTINUE
29292        XCOOR=XMAX + XINC
29293        DO2135I=NINC,1,-1
29294          XCOOR=XCOOR - XINC
29295          IF(I.EQ.1 .OR. I.EQ.NINC)THEN
29296            TERM2=0.0
29297          ELSE
29298            TERM2=SQRT(CHS95 - (SQRT(AN)*(XCOOR - XBAR)/SBAR)**2)
29299          ENDIF
29300          YCOOR=SBAR*EXP(TERM1*TERM2)
29301          ICNT=ICNT+1
29302          X2(ICNT)=XCOOR
29303          Y2(ICNT)=YCOOR
29304          D2(ICNT)=3.0
29305 2135   CONTINUE
29306C
29307        N2=NOUT
29308      ENDIF
29309C
29310      JSTRT=N2
29311      NPLOTV=2
29312C
29313C               ******************
29314C               **   STEP 90--  **
29315C               **   EXIT       **
29316C               ******************
29317C
29318 9000 CONTINUE
29319C
29320      IHOMLO=IHOML2
29321      IHOMSC=IHOMS2
29322C
29323      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'HOM2')THEN
29324        WRITE(ICOUT,999)
29325        CALL DPWRST('XXX','BUG ')
29326        WRITE(ICOUT,9011)
29327 9011   FORMAT('***** AT THE END       OF DPHOM2--')
29328        CALL DPWRST('XXX','BUG ')
29329        WRITE(ICOUT,9012)N,NUMSET,N2,IERROR
29330 9012   FORMAT('N,NUMSET,N2,IERROR = ',3I8,2X,A4)
29331        CALL DPWRST('XXX','BUG ')
29332        WRITE(ICOUT,9014)AN,NI
29333 9014   FORMAT('AN,NI = ',E15.7,I8)
29334        CALL DPWRST('XXX','BUG ')
29335        DO9015I=1,N2
29336          WRITE(ICOUT,9016)I,Y2(I),X2(I),D2(I)
29337 9016     FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2)
29338          CALL DPWRST('XXX','BUG ')
29339 9015   CONTINUE
29340      ENDIF
29341C
29342      RETURN
29343      END
29344      SUBROUTINE DPHOM3(TEMP,N,IHOMLO,IHOMSC,
29345     1                  P,PROP1,PROP2,NTRIM1,NTRIM2,
29346     1                  XTEMP1,XTEMP2,XTEMP3,DTEMP1,
29347     1                  ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
29348     1                  MAXNXT,ISEED,IQUASE,
29349     1                  XMEAN,XSD,
29350     1                  IBUGG3,ISUBRO,IERROR)
29351C
29352C     PURPOSE--FOR HOMOSCEDASTICITY PLOT, RETURN ESTIMATES OF
29353C              LOCATION AND SCALE FOR A SINGLE GROUP.
29354C     WRITTEN BY--JAMES J. FILLIBEN
29355C                 STATISTICAL ENGINEERING DIVISION
29356C                 INFORMATION TECHNOLOGY LABORATORY
29357C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
29358C                 GAITHERSBURG, MD 20899-8980
29359C                 PHONE--301-975-2855
29360C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
29361C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
29362C     LANGUAGE--ANSI FORTRAN (1977)
29363C     VERSION NUMBER--2010/12
29364C     ORIGINAL VERSION--DECEMBER  2010. EXTRACTED FROM DPHOM2
29365C
29366C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
29367C
29368      CHARACTER*4 IHOMLO
29369      CHARACTER*4 IHOMSC
29370      CHARACTER*4 IQUASE
29371      CHARACTER*4 IBUGG3
29372      CHARACTER*4 ISUBRO
29373      CHARACTER*4 IERROR
29374C
29375      CHARACTER*4 IWRITE
29376      CHARACTER*4 ICASE
29377C
29378C---------------------------------------------------------------------
29379C
29380      DIMENSION TEMP(*)
29381      DIMENSION XTEMP1(*)
29382      DIMENSION XTEMP2(*)
29383      DIMENSION XTEMP3(*)
29384C
29385      DOUBLE PRECISION DTEMP1(*)
29386C
29387      INTEGER ITEMP1(*)
29388      INTEGER ITEMP2(*)
29389      INTEGER ITEMP3(*)
29390      INTEGER ITEMP4(*)
29391      INTEGER ITEMP5(*)
29392      INTEGER ITEMP6(*)
29393C
29394C---------------------------------------------------------------------
29395C
29396      INCLUDE 'DPCOP2.INC'
29397C
29398C-----START POINT-----------------------------------------------------
29399C
29400      IWRITE='OFF'
29401C
29402      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'HOM3')THEN
29403        WRITE(ICOUT,70)
29404   70   FORMAT('AT THE BEGINNING OF DPHOM3--')
29405        CALL DPWRST('XXX','BUG ')
29406        WRITE(ICOUT,71)N
29407   71   FORMAT('N = ',I8)
29408        CALL DPWRST('XXX','BUG ')
29409        DO72I=1,N
29410          WRITE(ICOUT,73)I,TEMP(I)
29411   73     FORMAT('I, Y(I) = ',I8,G15.7)
29412          CALL DPWRST('XXX','BUG ')
29413   72   CONTINUE
29414      ENDIF
29415C
29416      NI=N
29417      IF(NI.LE.1)THEN
29418        XMEAN=TEMP(1)
29419        XSD=0.0
29420        GOTO9000
29421      ENDIF
29422C
29423C     FIRST THE LOCATION STATISTIC
29424C
29425      IF(IHOMLO.EQ.'MEAN')THEN
29426        CALL MEAN(TEMP,NI,IWRITE,XMEAN,IBUGG3,IERROR)
29427      ELSEIF(IHOMLO.EQ.'BILO')THEN
29428        CALL BIWLOC(TEMP,NI,IWRITE,XTEMP1,XTEMP2,MAXNXT,XMEAN,
29429     1              IBUGG3,IERROR)
29430      ELSEIF(IHOMLO.EQ.'H15L')THEN
29431        NCUT=0
29432        C=1.5
29433        CALL H15(TEMP,NI,C,NCUT,XMEAN,XSC,XTEMP1,XTEMP2,MAXNXT,
29434     1           ISUBRO,IBUGG3)
29435      ELSEIF(IHOMLO.EQ.'H10L')THEN
29436        NCUT=0
29437        C=1.0
29438        CALL H15(TEMP,NI,C,NCUT,XMEAN,XSC,XTEMP1,XTEMP2,MAXNXT,
29439     1           ISUBRO,IBUGG3)
29440      ELSEIF(IHOMLO.EQ.'H12L')THEN
29441        NCUT=0
29442        C=1.2
29443        CALL H15(TEMP,NI,C,NCUT,XMEAN,XSC,XTEMP1,XTEMP2,MAXNXT,
29444     1           ISUBRO,IBUGG3)
29445      ELSEIF(IHOMLO.EQ.'H17L')THEN
29446        NCUT=0
29447        C=1.7
29448        CALL H15(TEMP,NI,C,NCUT,XMEAN,XSC,XTEMP1,XTEMP2,MAXNXT,
29449     1           ISUBRO,IBUGG3)
29450      ELSEIF(IHOMLO.EQ.'H20L')THEN
29451        NCUT=0
29452        C=2.0
29453        CALL H15(TEMP,NI,C,NCUT,XMEAN,XSC,XTEMP1,XTEMP2,MAXNXT,
29454     1           ISUBRO,IBUGG3)
29455      ELSEIF(IHOMLO.EQ.'LPL')THEN
29456        CALL LPLOC(TEMP,NI,P,IWRITE,XTEMP1,DTEMP1,MAXNXT,XMEAN,
29457     1             IBUGG3,IERROR)
29458      ELSEIF(IHOMLO.EQ.'HODG')THEN
29459        DO12122I=1,NI
29460          ITEMP1(I)=0
29461          ITEMP2(I)=0
29462          ITEMP3(I)=0
2946312122   CONTINUE
29464        CALL HLQEST(TEMP,I,XTEMP1,ITEMP1,ITEMP2,ITEMP3,ISEED,XMEAN)
29465      ELSEIF(IHOMLO.EQ.'MEDI')THEN
29466        CALL MEDIAN(TEMP,NI,IWRITE,XTEMP1,MAXNXT,XMEAN,IBUGG3,IERROR)
29467      ELSEIF(IHOMLO.EQ.'MIDM')THEN
29468        CALL MIDMEA(TEMP,NI,IWRITE,XTEMP1,MAXNXT,XMEAN,IBUGG3,IERROR)
29469      ELSEIF(IHOMLO.EQ.'MIDR')THEN
29470        CALL MIDRAN(TEMP,NI,IWRITE,XMEAN,IBUGG3,IERROR)
29471      ELSEIF(IHOMLO.EQ.'TRIM')THEN
29472        CALL TRIMME(TEMP,NI,PROP1,PROP2,NTRIM1,NTRIM2,IWRITE,
29473     1              XTEMP1,MAXNXT,XMEAN,
29474     1              IBUGG3,ISUBRO,IERROR)
29475      ELSEIF(IHOMLO.EQ.'WIMN')THEN
29476        CALL WINDME(TEMP,NI,PROP1,PROP2,NTRIM1,NTRIM2,IWRITE,
29477     1              XTEMP1,MAXNXT,XMEAN,
29478     1              IBUGG3,ISUBRO,IERROR)
29479      ELSE
29480        CALL MEAN(TEMP,NI,IWRITE,XMEAN,IBUGG3,IERROR)
29481      ENDIF
29482C
29483C     NOW THE SCALE STATISTIC
29484C
29485      IF(IHOMSC.EQ.'SD')THEN
29486        CALL SD(TEMP,NI,IWRITE,XSD,IBUGG3,IERROR)
29487      ELSEIF(IHOMSC.EQ.'BISC')THEN
29488        CALL BIWSCA(TEMP,NI,IWRITE,XTEMP1,XTEMP2,MAXNXT,XSD,
29489     1              IBUGG3,IERROR)
29490      ELSEIF(IHOMSC.EQ.'H15S')THEN
29491        NCUT=0
29492        C=1.5
29493        CALL H15(TEMP,NI,C,NCUT,AH15,XSD,XTEMP1,XTEMP2,MAXNXT,
29494     1           ISUBRO,IBUGG3)
29495      ELSEIF(IHOMSC.EQ.'H10S')THEN
29496        NCUT=0
29497        C=1.0
29498        CALL H15(TEMP,NI,C,NCUT,AH15,XSD,XTEMP1,XTEMP2,MAXNXT,
29499     1           ISUBRO,IBUGG3)
29500      ELSEIF(IHOMSC.EQ.'H12S')THEN
29501        NCUT=0
29502        C=1.2
29503        CALL H15(TEMP,NI,C,NCUT,AH15,XSD,XTEMP1,XTEMP2,MAXNXT,
29504     1           ISUBRO,IBUGG3)
29505      ELSEIF(IHOMSC.EQ.'H17S')THEN
29506        NCUT=0
29507        C=1.7
29508        CALL H15(TEMP,NI,C,NCUT,AH15,XSD,XTEMP1,XTEMP2,MAXNXT,
29509     1           ISUBRO,IBUGG3)
29510      ELSEIF(IHOMSC.EQ.'H20S')THEN
29511        NCUT=0
29512        C=2.0
29513        CALL H15(TEMP,NI,C,NCUT,AH15,XSD,XTEMP1,XTEMP2,MAXNXT,
29514     1           ISUBRO,IBUGG3)
29515      ELSEIF(IHOMSC.EQ.'LPSD')THEN
29516        CALL LPVARI(TEMP,NI,P,IWRITE,XTEMP1,DTEMP1,MAXNXT,RIGHT,
29517     1              IQUASE,IBUGG3,IERROR)
29518        XSD=SQRT(RIGHT)
29519      ELSEIF(IHOMSC.EQ.'AAD')THEN
29520        ICASE='MEAN'
29521        CALL AAD(TEMP,NI,IWRITE,XTEMP1,MAXNXT,XSD,ICASE,IBUGG3,IERROR)
29522      ELSEIF(IHOMSC.EQ.'MAD')THEN
29523        CALL MAD(TEMP,NI,IWRITE,XTEMP1,XTEMP2,MAXNXT,XSD,IBUGG3,IERROR)
29524      ELSEIF(IHOMSC.EQ.'RANG')THEN
29525        CALL RANGDP(TEMP,NI,IWRITE,XSD,IBUGG3,IERROR)
29526      ELSEIF(IHOMSC.EQ.'SN')THEN
29527        XSD=SN(TEMP,NI,XTEMP1,XTEMP2,XTEMP3)
29528      ELSEIF(IHOMSC.EQ.'QN')THEN
29529        XSD=QN(TEMP,NI,XTEMP1,XTEMP2,XTEMP3,
29530     1         ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6)
29531      ELSEIF(IHOMSC.EQ.'TRSD')THEN
29532        CALL TRIMSD(TEMP,NI,PROP1,PROP2,NTRIM1,NTRIM2,IWRITE,MAXNXT,
29533     1              XTEMP1,XSD,
29534     1              IBUGG3,ISUBRO,IERROR)
29535      ELSEIF(IHOMSC.EQ.'WISD')THEN
29536        CALL WINSOR(TEMP,NI,PROP1,PROP2,NTRIM1,NTRIM2,IWRITE,
29537     1              XTEMP1,MAXNXT,XTEMP2,
29538     1              IBUGG3,ISUBRO,IERROR)
29539        CALL SD(XTEMP2,NI,IWRITE,XSD,IBUGG3,IERROR)
29540      ELSE
29541        CALL SD(TEMP,NI,IWRITE,XSD,IBUGG3,IERROR)
29542      ENDIF
29543C
29544C               ******************
29545C               **   STEP 90--  **
29546C               **   EXIT       **
29547C               ******************
29548C
29549 9000 CONTINUE
29550      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'HOM3')THEN
29551        WRITE(ICOUT,999)
29552  999   FORMAT(1X)
29553        CALL DPWRST('XXX','BUG ')
29554        WRITE(ICOUT,9011)
29555 9011   FORMAT('***** AT THE END       OF DPHOM3--')
29556        CALL DPWRST('XXX','BUG ')
29557        WRITE(ICOUT,9012)XMEAN,XSD
29558 9012   FORMAT('XMEAN,XSD = ',2G15.7)
29559        CALL DPWRST('XXX','BUG ')
29560      ENDIF
29561C
29562      RETURN
29563      END
29564      SUBROUTINE DPHORI(IHARG,IARGT,ARG,NUMARG,
29565     1PDEFHG,
29566     1PTEXHG,
29567     1IBUGD2,ISUBRO,IFOUND,IERROR)
29568C
29569C     PURPOSE--DEFINE THE HORIZONTAL GAP FOR TEXT CHARACTERS.
29570C              THE HORIZONTAL GAP FOR TEXT CHARACTERS WILL BE PLACED
29571C              IN THE FLOATING POINT VARIABLE PTEXHG.
29572C     NOTE--THE HORIZONTAL GAP IS IN STANDARDIZED UNITS (0.0 TO 100.0).
29573C     NOTE--THE HORIZONTAL GAP IS THE BETWEEN-CHARACTER SPACING (DISTANCE)
29574C           FROM THE END OF ONE CHARACTER
29575C           TO THE BEGINNING OF THE NEXT CHARACTER.
29576C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
29577C                     --IARGT
29578C                     --ARG
29579C                     --NUMARG
29580C                     --PDEFHG
29581C                     --IBUGD2
29582C     OUTPUT ARGUMENTS--PTEXHG
29583C                     --IFOUND ('YES' OR 'NO' )
29584C                     --IERROR ('YES' OR 'NO' )
29585C     WRITTEN BY--JAMES J. FILLIBEN
29586C                 STATISTICAL ENGINEERING DIVISION
29587C                 INFORMATION TECHNOLOGY LABORATORY
29588C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
29589C                 GAITHERSBURG, MD 20899-8980
29590C                 PHONE--301-975-2855
29591C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
29592C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
29593C     LANGUAGE--ANSI FORTRAN (1977)
29594C     VERSION NUMBER--82/7
29595C     ORIGINAL VERSION--APRIL     1981.
29596C     UPDATED         --MAY       1982.
29597C
29598C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
29599C
29600      CHARACTER*4 IHARG
29601      CHARACTER*4 IARGT
29602      CHARACTER*4 IBUGD2
29603      CHARACTER*4 ISUBRO
29604      CHARACTER*4 IFOUND
29605      CHARACTER*4 IERROR
29606C
29607C---------------------------------------------------------------------
29608C
29609      DIMENSION IHARG(*)
29610      DIMENSION IARGT(*)
29611      DIMENSION ARG(*)
29612C
29613C---------------------------------------------------------------------
29614C
29615      INCLUDE 'DPCOP2.INC'
29616C
29617C-----START POINT-----------------------------------------------------
29618C
29619      IFOUND='NO'
29620      IERROR='NO'
29621C
29622      IF(IBUGD2.EQ.'OFF')GOTO90
29623      WRITE(ICOUT,999)
29624  999 FORMAT(1X)
29625      CALL DPWRST('XXX','BUG ')
29626      WRITE(ICOUT,51)
29627   51 FORMAT('***** AT THE BEGINNING OF DPHORI--')
29628      CALL DPWRST('XXX','BUG ')
29629      WRITE(ICOUT,53)PDEFHG
29630   53 FORMAT('PDEFHG = ',E15.7)
29631      CALL DPWRST('XXX','BUG ')
29632      WRITE(ICOUT,54)NUMARG
29633   54 FORMAT('NUMARG = ',I8)
29634      CALL DPWRST('XXX','BUG ')
29635      DO55I=1,NUMARG
29636      WRITE(ICOUT,56)I,IHARG(I),IARGT(I),ARG(I)
29637   56 FORMAT('I,IHARG(I),IARGT(I),ARG(I) = ',I8,2X,A4,2X,A4,E15.7)
29638      CALL DPWRST('XXX','BUG ')
29639   55 CONTINUE
29640   90 CONTINUE
29641C
29642C               *************************************
29643C               **  TREAT THE HORIZONTAL GAP CASE  **
29644C               *************************************
29645C
29646      IF(NUMARG.LE.0)GOTO1150
29647      IF(NUMARG.EQ.1.AND.IHARG(NUMARG).EQ.'GAP')GOTO1150
29648      IF(NUMARG.EQ.1.AND.IHARG(NUMARG).EQ.'SPAC')GOTO1150
29649      IF(NUMARG.EQ.1.AND.IHARG(NUMARG).EQ.'DIST')GOTO1150
29650      IF(NUMARG.EQ.1.AND.IHARG(NUMARG).EQ.'LENG')GOTO1150
29651      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
29652      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
29653      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
29654      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
29655C
29656      IF(NUMARG.GE.1.AND.IARGT(NUMARG).EQ.'NUMB')
29657     1GOTO1160
29658C
29659      IERROR='YES'
29660      WRITE(ICOUT,1121)
29661 1121 FORMAT('***** ERROR IN DPHORI--')
29662      CALL DPWRST('XXX','BUG ')
29663      WRITE(ICOUT,1122)
29664 1122 FORMAT('      ILLEGAL FORM FOR HORIZONTAL GAP ',
29665     1'COMMAND.')
29666      CALL DPWRST('XXX','BUG ')
29667      WRITE(ICOUT,1124)
29668 1124 FORMAT('      TEST EXAMPLE TO DEMONSTRATE THE ',
29669     1'PROPER FORM--')
29670      CALL DPWRST('XXX','BUG ')
29671      WRITE(ICOUT,1125)
29672 1125 FORMAT('      SUPPOSE IT IS DESIRED THAT ')
29673      CALL DPWRST('XXX','BUG ')
29674      WRITE(ICOUT,1126)
29675 1126 FORMAT('      THE TEXT CHARACTERS HAVE A HORIZONTAL SPACING ')
29676      CALL DPWRST('XXX','BUG ')
29677      WRITE(ICOUT,1127)
29678 1127 FORMAT('      OF 2 (WHERE THE HORIZONTAL SCREEN UNITS RANGE')
29679      CALL DPWRST('XXX','BUG ')
29680      WRITE(ICOUT,1128)
29681 1128 FORMAT('      FROM 0 TO 100,')
29682      CALL DPWRST('XXX','BUG ')
29683      WRITE(ICOUT,1130)
29684 1130 FORMAT('      THEN THE ALLOWABLE FORM IS--')
29685      CALL DPWRST('XXX','BUG ')
29686      WRITE(ICOUT,1131)
29687 1131 FORMAT('           HORIZONTAL SPACING 5 ')
29688      CALL DPWRST('XXX','BUG ')
29689      GOTO9000
29690C
29691 1150 CONTINUE
29692      PTEXHG=PDEFHG
29693      GOTO1180
29694C
29695 1160 CONTINUE
29696      PTEXHG=ARG(NUMARG)
29697      GOTO1180
29698C
29699 1180 CONTINUE
29700      IFOUND='YES'
29701C
29702      IF(IFEEDB.EQ.'OFF')GOTO1189
29703      WRITE(ICOUT,999)
29704      CALL DPWRST('XXX','BUG ')
29705      WRITE(ICOUT,1181)
29706 1181 FORMAT('THE HORIZONTAL SPACING (FOR TEXT CHARACTERS)  ')
29707      CALL DPWRST('XXX','BUG ')
29708      WRITE(ICOUT,1182)PTEXHG
29709 1182 FORMAT('HAS JUST BEEN SET TO ',E15.7)
29710      CALL DPWRST('XXX','BUG ')
29711 1189 CONTINUE
29712      GOTO9000
29713C
29714C               *****************
29715C               **  STEP 90--  **
29716C               **  EXIT       **
29717C               *****************
29718C
29719 9000 CONTINUE
29720      IF(IBUGD2.EQ.'OFF')GOTO9090
29721      WRITE(ICOUT,999)
29722      CALL DPWRST('XXX','BUG ')
29723      WRITE(ICOUT,9011)
29724 9011 FORMAT('***** AT THE END       OF DPHORI--')
29725      CALL DPWRST('XXX','BUG ')
29726      WRITE(ICOUT,9012)IBUGD2,ISUBRO,IFOUND,IERROR
29727 9012 FORMAT('IBUGD2,ISUBRO,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
29728      CALL DPWRST('XXX','BUG ')
29729      WRITE(ICOUT,9013)PTEXHG
29730 9013 FORMAT('PTEXHG = ',E15.7)
29731      CALL DPWRST('XXX','BUG ')
29732 9090 CONTINUE
29733C
29734      RETURN
29735      END
29736      SUBROUTINE DPHOSL(IHARG,NUMARG,IDEFHL,
29737     1                  IHOSLI,IFOUND,IERROR)
29738C
29739C     PURPOSE--DEFINE THE TYPE OF COMMUNICATIONS LINK
29740C              (E.G., NBS NETWORK, PHONE LINES, ETC.)
29741C              BETWEEN HOST AND TERMINAL.
29742C              THE HOST LINK INFORMATION
29743C              WILL BE PLACED IN THE VARIOUS ELEMENTS OF THE
29744C              IHOSLI(.) VECTOR.
29745C              AS MUCH DETAIL AS NECESSARY
29746C              MAY BE USED TO DESCRIBE
29747C              THE HOST LINK.
29748C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
29749C                     --NUMARG (AN INTEGER VARIABLE)
29750C                     --IDEFHL (A  HOLLERITH VECTOR)
29751C     OUTPUT ARGUMENTS--IHOSLI (A HOLLERITH VECTOR
29752C                              WHICH CONTAINS THE HOST
29753C                              SPECIFICATIONS.
29754C                     --IFOUND ('YES' OR 'NO' )
29755C                     --IERROR ('YES' OR 'NO' )
29756C     WRITTEN BY--JAMES J. FILLIBEN
29757C                 STATISTICAL ENGINEERING DIVISION
29758C                 INFORMATION TECHNOLOGY LABORATORY
29759C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
29760C                 GAITHERSBURG, MD 20899-8980
29761C                 PHONE--301-975-2855
29762C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
29763C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
29764C     LANGUAGE--ANSI FORTRAN (1977)
29765C     VERSION NUMBER--82/7
29766C     ORIGINAL VERSION--NOVEMBER  1980.
29767C     UPDATED         --MAY       1982.
29768C
29769C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
29770C
29771      CHARACTER*4 IHARG
29772      CHARACTER*4 IDEFHL
29773      CHARACTER*4 IHOSLI
29774      CHARACTER*4 IFOUND
29775      CHARACTER*4 IERROR
29776C
29777C---------------------------------------------------------------------
29778C
29779      DIMENSION IHARG(*)
29780      DIMENSION IDEFHL(*)
29781      DIMENSION IHOSLI(*)
29782C
29783C---------------------------------------------------------------------
29784C
29785      INCLUDE 'DPCOP2.INC'
29786C
29787C-----START POINT-----------------------------------------------------
29788C
29789      IFOUND='NO'
29790      IERROR='NO'
29791C
29792      IF(NUMARG.LE.1)THEN
29793        DO1135I=1,10
29794          IHOSLI(I)=IDEFHL(I)
29795 1135   CONTINUE
29796      ELSE
29797        IF(IHARG(2).EQ.'OFF' .OR.  IHARG(2).EQ.'AUTO' .OR.
29798     1     IHARG(2).EQ.'DEFA')THEN
29799          DO1165I=1,10
29800            IHOSLI(I)=IDEFHL(I)
29801 1165     CONTINUE
29802        ELSE
29803          K=1
29804          DO1175I=1,10
29805            K=K+1
29806            IF(K.LE.NUMARG)IHOSLI(I)=IHARG(K)
29807            IF(K.GT.NUMARG)IHOSLI(I)=' '
29808 1175     CONTINUE
29809        ENDIF
29810      ENDIF
29811C
29812      IFOUND='YES'
29813      IF(IFEEDB.EQ.'ON')THEN
29814        WRITE(ICOUT,999)
29815  999   FORMAT(1X)
29816        CALL DPWRST('XXX','BUG ')
29817        WRITE(ICOUT,1185)
29818 1185   FORMAT('THE HOST LINK (= COMMUNICATIONS LINK) ')
29819        CALL DPWRST('XXX','BUG ')
29820        WRITE(ICOUT,1186)(IHOSLI(I),I=1,10)
29821 1186   FORMAT('HAS JUST BEEN SET TO ',9(A4,1X),A4)
29822        CALL DPWRST('XXX','BUG ')
29823      ENDIF
29824C
29825      RETURN
29826      END
29827      SUBROUTINE DPHOST(IHARG,NUMARG,IDEFHO,
29828     1IHOST,IHOST1,IHOST2,IFOUND,IERROR)
29829C
29830C     PURPOSE--DEFINE THE MANUFACTURER, MODEL, ETC. FOR THE
29831C              HOST COMPUTER.
29832C              THE HOST INFORMATION
29833C              WILL BE PLACED IN THE VARIOUS ELEMENTS OF THE
29834C              IHOST(.) VECTOR.
29835C              AS MUCH DETAIL (FOR EXAMPLE, MODEL NUMBER,
29836C              OPERATING SYSTEM, ETC.) MAY BE USED TO DESCRIBE
29837C              THE HOST COMPUTER.
29838C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
29839C                     --NUMARG (AN INTEGER VARIABLE)
29840C                     --IDEFHO (A  HOLLERITH VECTOR)
29841C     OUTPUT ARGUMENTS--IHOST  (A HOLLERITH VECTOR
29842C                              WHICH CONTAINS THE HOST
29843C                              SPECIFICATIONS.
29844C                     --IFOUND ('YES' OR 'NO' )
29845C                     --IERROR ('YES' OR 'NO' )
29846C     WRITTEN BY--JAMES J. FILLIBEN
29847C                 STATISTICAL ENGINEERING DIVISION
29848C                 INFORMATION TECHNOLOGY LABORATORY
29849C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
29850C                 GAITHERSBURG, MD 20899-8980
29851C                 PHONE--301-975-2855
29852C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
29853C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
29854C     LANGUAGE--ANSI FORTRAN (1977)
29855C     VERSION NUMBER--82/7
29856C     ORIGINAL VERSION--NOVEMBER  1980.
29857C     UPDATED         --MAY       1982.
29858C
29859C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
29860C
29861      CHARACTER*4 IHARG
29862      CHARACTER*4 IDEFHO
29863      CHARACTER*4 IHOST
29864      CHARACTER*4 IHOST1
29865      CHARACTER*4 IHOST2
29866      CHARACTER*4 IFOUND
29867      CHARACTER*4 IERROR
29868C
29869C---------------------------------------------------------------------
29870C
29871      DIMENSION IHARG(*)
29872      DIMENSION IDEFHO(*)
29873C
29874      DIMENSION IHOST(*)
29875C
29876C---------------------------------------------------------------------
29877C
29878      INCLUDE 'DPCOP2.INC'
29879C
29880C-----START POINT-----------------------------------------------------
29881C
29882      IFOUND='NO'
29883      IERROR='NO'
29884C
29885      IF(NUMARG.LE.0)GOTO1130
29886      IF(IHARG(1).NE.'MANU')GOTO1120
29887      IF(IHARG(1).EQ.'MANU')GOTO1150
29888C
29889 1120 CONTINUE
29890      IF(IHARG(1).EQ.'ON')GOTO1130
29891      IF(IHARG(1).EQ.'OFF')GOTO1130
29892      IF(IHARG(1).EQ.'AUTO')GOTO1130
29893      IF(IHARG(1).EQ.'DEFA')GOTO1130
29894      GOTO1140
29895C
29896 1130 CONTINUE
29897      DO1135I=1,10
29898      IHOST(I)=IDEFHO(I)
29899 1135 CONTINUE
29900      GOTO1180
29901C
29902 1140 CONTINUE
29903      K=0
29904      DO1145I=1,10
29905      K=K+1
29906      IF(K.LE.NUMARG)IHOST(I)=IHARG(K)
29907      IF(K.GT.NUMARG)IHOST(I)=' '
29908 1145 CONTINUE
29909      GOTO1180
29910C
29911 1150 CONTINUE
29912      IF(IHARG(2).EQ.'ON')GOTO1160
29913      IF(IHARG(2).EQ.'OFF')GOTO1160
29914      IF(IHARG(2).EQ.'AUTO')GOTO1160
29915      IF(IHARG(2).EQ.'DEFA')GOTO1160
29916      GOTO1170
29917C
29918 1160 CONTINUE
29919      DO1165I=1,10
29920      IHOST(I)=IDEFHO(I)
29921 1165 CONTINUE
29922      GOTO1180
29923C
29924 1170 CONTINUE
29925      K=1
29926      DO1175I=1,10
29927      K=K+1
29928      IF(K.LE.NUMARG)IHOST(I)=IHARG(K)
29929      IF(K.GT.NUMARG)IHOST(I)=' '
29930 1175 CONTINUE
29931      GOTO1180
29932C
29933 1180 CONTINUE
29934      IHOST1=IHOST(1)
29935      IHOST2=IHOST(2)
29936      IFOUND='YES'
29937C
29938      IF(IFEEDB.EQ.'OFF')GOTO1189
29939      WRITE(ICOUT,999)
29940  999 FORMAT(1X)
29941      CALL DPWRST('XXX','BUG ')
29942      WRITE(ICOUT,1185)(IHOST(I),I=1,10)
29943 1185 FORMAT('THE HOST HAS JUST BEEN SET TO ',
29944     1A4,1X,A4,1X,A4,1X,A4,1X,A4,1X,A4,1X,A4,1X,A4,1X,A4,1X,A4)
29945      CALL DPWRST('XXX','BUG ')
29946 1189 CONTINUE
29947      GOTO1199
29948C
29949 1199 CONTINUE
29950      RETURN
29951      END
29952      SUBROUTINE DPHRIZ(IHARG,NUMARG,IHORSW,IFOUND,IERROR)
29953C
29954C     PURPOSE--DEFINE THE HORIZONTAL SWITCH IHORSW
29955C              (DETERMINES WHETHER PLOTS DRAWN HORIZONTALLY OR
29956C              VERTICALLY.  USEFUL FOR SPIKES (TO DO DOT CHARTS
29957C              SUGGESTED BY CLEVLEAND), BAR CHARTS, DOING CHARTS
29958C              IN "PORTRAIT" MODE).
29959C              HANGING HISTOGRAMS).
29960C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
29961C                     --NUMARG
29962C     OUTPUT ARGUMENTS--IHORSW  ('ON'  OR 'OFF')
29963C                     --IFOUND ('YES' OR 'NO' )
29964C                     --IERROR ('YES' OR 'NO' )
29965C     WRITTEN BY--ALAN HECKERT
29966C                 COMPUTER SERVICES DIVISION
29967C                 INFORMATION TECHNOLOGY LABORATORY
29968C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
29969C                 GAITHERSBURG, MD 20899-8980
29970C                 PHONE--301-975-2899
29971C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
29972C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
29973C     LANGUAGE--ANSI FORTRAN (1977)
29974C     VERSION NUMBER--82/7
29975C     ORIGINAL VERSION--NOVEMBER  1978.
29976C     UPDATED         --SEPTEMBER 1980.
29977C     UPDATED         --MAY       1982.
29978C
29979C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
29980C
29981      CHARACTER*4 IHARG
29982      CHARACTER*4 IHORSW
29983      CHARACTER*4 IFOUND
29984      CHARACTER*4 IERROR
29985C
29986C---------------------------------------------------------------------
29987C
29988      DIMENSION IHARG(*)
29989C
29990C---------------------------------------------------------------------
29991C
29992      INCLUDE 'DPCOP2.INC'
29993C
29994C-----START POINT-----------------------------------------------------
29995C
29996      IFOUND='NO'
29997      IERROR='NO'
29998C
29999      IF(NUMARG.LE.1)GOTO1199
30000      IF(NUMARG.GE.2)GOTO1110
30001      GOTO1199
30002C
30003 1110 CONTINUE
30004      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
30005      IF(IHARG(NUMARG).EQ.'OFF')GOTO1160
30006      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
30007      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1160
30008      GOTO1199
30009C
30010 1150 CONTINUE
30011      IHORSW='ON'
30012      GOTO1180
30013C
30014 1160 CONTINUE
30015      IHORSW='OFF'
30016      GOTO1180
30017C
30018 1180 CONTINUE
30019      IFOUND='YES'
30020C
30021      IF(IFEEDB.EQ.'OFF')GOTO1189
30022      WRITE(ICOUT,999)
30023  999 FORMAT(1X)
30024      CALL DPWRST('XXX','BUG ')
30025      WRITE(ICOUT,1181)IHORSW
30026 1181 FORMAT('THE HORIZONTAL SWITCH HAS JUST BEEN TURNED ',
30027     1A4)
30028      CALL DPWRST('XXX','BUG ')
30029 1189 CONTINUE
30030      GOTO1199
30031C
30032 1199 CONTINUE
30033      RETURN
30034      END
30035      SUBROUTINE DPHTCC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
30036     1                  ICONT,IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
30037C
30038C     PURPOSE--GENERATE A HOTELLING MULTIVARIATE CONTROL CHART --
30039C              ESSENTIALLY COMPUTES A HOTELLING T-SQUARE (1-SAMPLE)
30040C              STATISTIC FOR EACH SUBGROUP.  THESE HOTELLING VALUES
30041C              ARE PLOTTTED AS A CONTROL CHART.
30042C     FEBRUARY 2003:
30043C     SUPPORT FOUR DISTINCT CASES FOR HOTELLING CONTROL CHARTS.
30044C       1) PHASE I HOTELLING CONTROL CHART Y1 ... YK GROUP
30045C       2) PHASE I HOTELLING INDIVIDUAL CONTROL CHART Y1 ... YK
30046C       3) PHASE II HOTELLING CONTROL CHART Y1 ... YK GROUP HIST
30047C       4) PHASE II HOTELLING INDIVIDUAL CONTROL CHART Y1 ... YK GROUP
30048C     IF PHASE <I/II> OMITTED, ASSUME A PHASE I CHART.
30049C     WRITTEN BY--ALAN HECKERT
30050C                 INFORMATION TECHNOLOGY LABORATORY
30051C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
30052C                 GAITHERSBURG, MD 20899-8980
30053C                 PHONE--301-975-2899
30054C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
30055C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
30056C     LANGUAGE--ANSI FORTRAN (1977)
30057C     VERSION NUMBER--98/9
30058C     ORIGINAL VERSION--SEPTEMBER 1998.
30059C     UPDATED         --MARCH     2003. SUPPORT FOR 4 TYPES OF CHARTS
30060C     UPDATED         --JULY      2019. MODIFY USE OF SCRATCH SPACE,
30061C                                       IN PARTICULAR SET LIMITS BASED
30062C                                       ON TOTAL DATA SIZE (I.E., ROWS
30063C                                       TIMES COLUMNS) RATHER THAN FIXED
30064C                                       MAXIMUM NUMBER OF COLUMNS AND
30065C                                       FIXED MAXIMUM NUMBER OF ROWS.
30066C
30067C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
30068C
30069      CHARACTER*4 ICASPL
30070      CHARACTER*4 IAND1
30071      CHARACTER*4 IAND2
30072      CHARACTER*4 ICONT
30073      CHARACTER*4 IBUGG2
30074      CHARACTER*4 IBUGG3
30075      CHARACTER*4 IBUGQ
30076      CHARACTER*4 ISUBRO
30077      CHARACTER*4 IFOUND
30078      CHARACTER*4 IERROR
30079C
30080      CHARACTER*4 IH
30081      CHARACTER*4 IH2
30082      CHARACTER*4 IHWUSE
30083      CHARACTER*4 MESSAG
30084      CHARACTER*4 IHRIGH
30085      CHARACTER*4 IHRIG2
30086      CHARACTER*4 IFLGGR
30087      CHARACTER*4 IFLGHI
30088C
30089      CHARACTER*4 ISUBN1
30090      CHARACTER*4 ISUBN2
30091      CHARACTER*4 ISTEPN
30092C
30093C---------------------------------------------------------------------
30094C
30095      INCLUDE 'DPCOPA.INC'
30096      INCLUDE 'DPCOZZ.INC'
30097      INCLUDE 'DPCOZD.INC'
30098      INCLUDE 'DPCOZI.INC'
30099C
30100C  MAXHOT IS THE MAXIMUM NUMBER OF VARIABLES TO USE IN CREATING THE
30101C  HOTELLING CHART.
30102C
30103      PARAMETER(MAXHOT=30)
30104C
30105      CHARACTER*4 IHIGH
30106      CHARACTER*40 INAME
30107      PARAMETER (MAXSPN=32)
30108      CHARACTER*4 IVARN1(MAXSPN)
30109      CHARACTER*4 IVARN2(MAXSPN)
30110      CHARACTER*4 IVARTY(MAXSPN)
30111      REAL PVAR(MAXSPN)
30112      INTEGER ILIS(MAXSPN)
30113      INTEGER NRIGHT(MAXSPN)
30114      INTEGER ICOLR(MAXSPN)
30115C
30116      DIMENSION X1(MAXOBV)
30117      DIMENSION XHIST(MAXOBV)
30118      DIMENSION XIDTEM(MAXOBV)
30119      DIMENSION TEMP(MAXOBV)
30120      DIMENSION XMEANS(MAXOBV)
30121      DIMENSION XGROUP(MAXOBV)
30122      DIMENSION S(MAXHOT,MAXHOT)
30123C
30124      DIMENSION INDEX(MAXOBV)
30125      DIMENSION NIJUNK(MAXOBV)
30126      DIMENSION IGRPST(MAXOBV)
30127C
30128      DOUBLE PRECISION DMEAN(MAXOBV)
30129C
30130CCCCC DIMENSION Z(MAXOBV,MAXHOT)
30131CCCCC DIMENSION ZHIST(MAXOBV,MAXHOT)
30132CCCCC DIMENSION ZMEANS(MAXOBV,MAXHOT)
30133      DIMENSION Z(6*MAXOBV)
30134      DIMENSION ZHIST(6*MAXOBV)
30135      DIMENSION ZMEANS(6*MAXOBV)
30136C
30137      EQUIVALENCE (GARBAG(IGARB1),X1(1))
30138      EQUIVALENCE (GARBAG(IGARB2),XHIST(1))
30139      EQUIVALENCE (GARBAG(IGARB3),XIDTEM(1))
30140      EQUIVALENCE (GARBAG(IGARB4),TEMP(1))
30141      EQUIVALENCE (GARBAG(IGARB5),XMEANS(1))
30142      EQUIVALENCE (GARBAG(IGARB6),XGROUP(1))
30143      EQUIVALENCE (GARBAG(IGARB7),S(1,1))
30144      EQUIVALENCE (GARBAG(IGARB8),Z(1))
30145      EQUIVALENCE (GARBAG(JGAR13),ZHIST(1))
30146      EQUIVALENCE (GARBAG(JGAR20),ZMEANS(1))
30147C
30148      EQUIVALENCE (DGARBG(IDGAR1),DMEAN(1))
30149C
30150      EQUIVALENCE (IGARBG(IIGAR1),INDEX(1))
30151      EQUIVALENCE (IGARBG(IIGAR2),NIJUNK(1))
30152      EQUIVALENCE (IGARBG(IIGAR3),IGRPST(1))
30153C
30154C-----COMMON----------------------------------------------------------
30155C
30156      INCLUDE 'DPCOHK.INC'
30157      INCLUDE 'DPCODA.INC'
30158      INCLUDE 'DPCOP2.INC'
30159C
30160C-----START POINT-----------------------------------------------------
30161C
30162      IERROR='NO'
30163      ISUBN1='DPHT'
30164      ISUBN2='CC  '
30165      IFLGGR='ON'
30166      IFLGHI='OFF'
30167C
30168      MAXCP1=MAXCOL+1
30169      MAXCP2=MAXCOL+2
30170      MAXCP3=MAXCOL+3
30171      MAXCP4=MAXCOL+4
30172      MAXCP5=MAXCOL+5
30173      MAXCP6=MAXCOL+6
30174C
30175      ICOLH=0
30176      MAXLEN=6*MAXOBV
30177C
30178C               **********************************************
30179C               **  TREAT THE HOTELLING CONTROL CHART CASE  **
30180C               **********************************************
30181C
30182      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HTCC')THEN
30183        WRITE(ICOUT,999)
30184  999   FORMAT(1X)
30185        CALL DPWRST('XXX','BUG ')
30186        WRITE(ICOUT,51)
30187   51   FORMAT('***** AT THE BEGINNING OF DPHTCC--')
30188        CALL DPWRST('XXX','BUG ')
30189        WRITE(ICOUT,52)IBUGG2,IBUGG3,IBUGQ,ISUBRO
30190   52   FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',3(A4,2X),A4)
30191        CALL DPWRST('XXX','BUG ')
30192        WRITE(ICOUT,53)ICASPL,IAND1,IAND2
30193   53   FORMAT('ICASPL,IAND1,IAND2 = ',2(A4,2X),A4)
30194        CALL DPWRST('XXX','BUG ')
30195      ENDIF
30196C
30197C               ***************************
30198C               **  STEP 1--             **
30199C               **  EXTRACT THE COMMAND  **
30200C               ***************************
30201C
30202      ISTEPN='11'
30203      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HTCC')
30204     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30205C
30206      ICASPL='HTCC'
30207C
30208CCCCC FEBRUARY 2003: CHECK FOR THE FOLLOWING:
30209CCCCC     HOTELLING CONTROL CHART (= PHASE I, GROUP)
30210CCCCC     MULTIVARIATE CONTROL CHART (= PHASE I, GROUP)
30211CCCCC     PHASE <I/ONE/1> HOTELLING CONTROL CHART
30212CCCCC     PHASE <II/TWO/2> HOTELLING CONTROL CHART
30213CCCCC     PHASE <I/ONE/1> HOTELLING INDIVIDUAL CONTROL CHART
30214CCCCC     PHASE <II/TWO/2> HOTELLING INDIVIDUAL CONTROL CHART
30215CCCCC THE WORDS "CONTROL" AND "CHART" ARE OPTIONAL.
30216C
30217      IF(ICOM.EQ.'PHAS')THEN
30218        IF(IHARG(1).EQ.'I'.OR.IHARG(1).EQ.'ONE'.OR.IHARG(1).EQ.'1')THEN
30219          ICASPL='HT1G'
30220          ILASTC=1
30221          IF(IHARG(2).EQ.'HOTE' .OR. IHARG(2).EQ.'MULT')ILASTC=2
30222          CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
30223        ELSEIF(IHARG(1).EQ.'II'.OR.IHARG(1).EQ.'TWO'.OR.
30224     1         IHARG(1).EQ.'2')THEN
30225          ICASPL='HT2G'
30226          ILASTC=1
30227          IF(IHARG(2).EQ.'HOTE' .OR. IHARG(2).EQ.'MULT')ILASTC=2
30228          CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
30229        ENDIF
30230      ELSEIF(ICOM.EQ.'HOTE' .OR. ICOM.EQ.'MULT')THEN
30231        IF(IHARG(1).EQ.'PHAS' .AND. (IHARG(2).EQ.'I' .OR.
30232     1     IHARG(2).EQ.'ONE' .OR. IHARG(2).EQ.'1'))THEN
30233          ILASTC=2
30234          CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
30235          ICASPL='HT1G'
30236        ELSEIF(IHARG(1).EQ.'PHAS' .AND. (IHARG(2).EQ.'II' .OR.
30237     1     IHARG(2).EQ.'TWO' .OR. IHARG(2).EQ.'2'))THEN
30238          ILASTC=2
30239          CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
30240          ICASPL='HT2G'
30241        ELSE
30242          ICASPL='HT1G'
30243        ENDIF
30244      ELSE
30245        IFOUND='NO'
30246        GOTO9000
30247      ENDIF
30248C
30249C  NOW CHECK FOR WORD "INDIVIDUAL"
30250C
30251      IF(IHARG(1).EQ.'INDI')THEN
30252        IF(ICASPL.EQ.'HT1G')ICASPL='HT1I'
30253        IF(ICASPL.EQ.'HT2G')ICASPL='HT2I'
30254        ILASTC=1
30255        CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
30256      ENDIF
30257C
30258C  NOW CHECK FOR WORD "CONTROL" OR WORD "CHART"
30259C
30260      IF(IHARG(1).EQ.'CONT')THEN
30261        ILASTC=1
30262        CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
30263      ENDIF
30264C
30265      IF(IHARG(1).EQ.'CHAR')THEN
30266        ILASTC=1
30267        CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
30268      ENDIF
30269C
30270      IFOUND='YES'
30271      IFLGGR='OFF'
30272      IF(ICASPL.EQ.'HT1G' .OR. ICASPL.EQ.'HT2G')IFLGGR='ON'
30273      IFLGHI='OFF'
30274      IF(ICASPL.EQ.'HT2I' .OR. ICASPL.EQ.'HT2G')IFLGHI='ON'
30275C
30276C
30277C               ****************************************
30278C               **  STEP 2--                          **
30279C               **  EXTRACT THE VARIABLE LIST         **
30280C               ****************************************
30281C
30282      ISTEPN='2'
30283      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HTCC')
30284     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30285C
30286      INAME='HOTELLING CONTROL CHART'
30287      MINNA=2
30288      MAXNA=100
30289      MINN2=5
30290      IFLAGE=1
30291      IFLAGM=0
30292      IFLAGP=0
30293      JMIN=1
30294      JMAX=NUMARG
30295      MINNVA=2
30296      MAXNVA=30
30297      IF(IFLGGR.EQ.'ON')THEN
30298        MINNVA=MINNVA+1
30299        MAXNVA=MAXNVA+1
30300      ENDIF
30301      IF(IFLGHI.EQ.'ON')THEN
30302        MINNVA=MINNVA+1
30303        MAXNVA=MAXNVA+1
30304      ENDIF
30305C
30306      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
30307     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
30308     1            JMIN,JMAX,
30309     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
30310     1            IVARN1,IVARN2,IVARTY,PVAR,
30311     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
30312     1            MINNVA,MAXNVA,
30313     1            IFLAGM,IFLAGP,
30314     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
30315      IF(IERROR.EQ.'YES')GOTO9000
30316C
30317C     CHECK FOR MAXIMUM PROBLEM SIZE.
30318C
30319      NROW=0
30320      DO270II=1,NRIGHT(1)
30321        IF(ISUB(II).EQ.1)NROW=NROW+1
30322  270 CONTINUE
30323      IREQ=NROW*NUMVAR
30324      IF(IREQ.GT.MAXLEN)THEN
30325        WRITE(ICOUT,999)
30326        CALL DPWRST('XXX','BUG ')
30327        WRITE(ICOUT,271)
30328  271   FORMAT('***** ERROR IN HOTELLING CONTROL CHART (DPHTCC)--')
30329        CALL DPWRST('XXX','BUG ')
30330        WRITE(ICOUT,273)
30331  273   FORMAT('      INSUFFICIENT SCRATCH SPACE AVAILABLE.')
30332        CALL DPWRST('XXX','BUG ')
30333        WRITE(ICOUT,274)NROW
30334  274   FORMAT('      NUMBER OF ROWS OF DATA          = ',I10)
30335        CALL DPWRST('XXX','BUG ')
30336        WRITE(ICOUT,275)NUMVAR
30337  275   FORMAT('      NUMBER OF VARIABLES             = ',I10)
30338        CALL DPWRST('XXX','BUG ')
30339        WRITE(ICOUT,276)IREQ
30340  276   FORMAT('      ROWS TIMES COLUMNS              = ',I10)
30341        CALL DPWRST('XXX','BUG ')
30342        WRITE(ICOUT,277)MAXLEN
30343  277   FORMAT('      MAXIMUM FOR ROWS TIMES COLUMNS  = ',I10)
30344        CALL DPWRST('XXX','BUG ')
30345        IERROR='YES'
30346        GOTO9000
30347      ENDIF
30348C
30349      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HTCC')THEN
30350        WRITE(ICOUT,999)
30351        CALL DPWRST('XXX','BUG ')
30352        WRITE(ICOUT,281)
30353  281   FORMAT('***** AFTER CALL DPPARS--')
30354        CALL DPWRST('XXX','BUG ')
30355        WRITE(ICOUT,282)NQ,NUMVAR,IHIGH,ICASPL
30356  282   FORMAT('NQ,NUMVAR,IHIGH,ICASPL = ',2I8,2(2X,A4))
30357        CALL DPWRST('XXX','BUG ')
30358        IF(NUMVAR.GT.0)THEN
30359          DO285I=1,NUMVAR
30360            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
30361     1                      ICOLR(I),IVARTY(I)
30362  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
30363     1             'ICOLR(I),IVARTY(I) = ',I8,2X,A4,A4,2X,3I8,2X,A4)
30364            CALL DPWRST('XXX','BUG ')
30365  285     CONTINUE
30366        ENDIF
30367      ENDIF
30368C
30369C               *************************************************
30370C               **  STEP 22--                                  **
30371C               **  FOR EACH OF THE RESPONSE VARIABLES,        **
30372C               **  EXTRACT THE DATA SUBSET                    **
30373C               **  (FREQUENTLY ONLY 1 OBSERVATION)            **
30374C               **  AND ALSO EXTRACT THE                       **
30375C               **  MIN AND MAX FOR THE FULL VARIABLE          **
30376C               *************************************************
30377C
30378      ISTEPN='22'
30379      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HTCC')
30380     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30381C
30382      NUMRSP=NUMVAR
30383      IF(IFLGGR.EQ.'ON')NUMRSP=NUMRSP-1
30384      IF(IFLGHI.EQ.'ON')NUMRSP=NUMRSP-1
30385      NGROUP=0
30386      IF(IFLGGR.EQ.'ON')NGROUP=NUMRSP+1
30387      NHIST=0
30388      IF(IFLGHI.EQ.'ON')THEN
30389        NHIST=NUMRSP+1
30390        IF(IFLGGR.EQ.'ON')NHIST=NHIST+1
30391      ENDIF
30392C
30393      DO2200K=1,NUMVAR
30394        IHRIGH=IVARN1(K)
30395        IHRIG2=IVARN2(K)
30396C
30397        DO2210I=1,NUMNAM
30398          I2=I
30399          IF(IHRIGH.EQ.IHNAME(I).AND.IHRIG2.EQ.IHNAM2(I).AND.
30400     1       IUSE(I).EQ.'V')GOTO2219
30401 2210   CONTINUE
30402C
30403        WRITE(ICOUT,2211)
30404 2211   FORMAT('***** INTERNAL ERROR IN DPHTCC AT POINT 2210--')
30405        CALL DPWRST('XXX','BUG ')
30406        WRITE(ICOUT,2212)IHRIGH,IHRIG2
30407 2212   FORMAT('      THE VARIABLE ',A4,A4,' WAS NOT FOUND IN THE')
30408        CALL DPWRST('XXX','BUG ')
30409        WRITE(ICOUT,2214)
30410 2214   FORMAT('      INTERNAL NAME LIST ALTHOUGH IT WAS FOUND ',
30411     1         'EARLIER.')
30412        CALL DPWRST('XXX','BUG ')
30413        WRITE(ICOUT,2215)
30414 2215   FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
30415        CALL DPWRST('XXX','BUG ')
30416        IF(IWIDTH.GE.1)THEN
30417          WRITE(ICOUT,1329)(IANS(I),I=1,MIN(80,IWIDTH))
30418 1329     FORMAT(A80)
30419          CALL DPWRST('XXX','BUG ')
30420        ENDIF
30421        IERROR='YES'
30422        GOTO9000
30423C
30424 2219   CONTINUE
30425C
30426        ILISTR=I2
30427C
30428        J=0
30429        IMAX=NRIGHT(K)
30430        IF(NQ.LT.IMAX)IMAX=NQ
30431        IF(K.LE.NUMRSP)THEN
30432          DO2240I=1,IMAX
30433            IF(ISUB(I).EQ.0)GOTO2240
30434            J=J+1
30435            IJ=MAXN*(ICOLR(K)-1)+I
30436            IINDX=(K-1)*NROW
30437C
30438            IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HTCC')THEN
30439              WRITE(ICOUT,2241)I,J,MAXN,ICOLR(K),IJ,NQ,IMAX
30440 2241         FORMAT('I,J,MAXN,ICOLR(K),IJ,NQ,IMAX = ',7I8)
30441              CALL DPWRST('XXX','BUG ')
30442            ENDIF
30443C
30444            IF(ICOLR(K).LE.MAXCOL)Z(IINDX+J)=V(IJ)
30445            IF(ICOLR(K).EQ.MAXCP1)Z(IINDX+J)=PRED(I)
30446            IF(ICOLR(K).EQ.MAXCP2)Z(IINDX+J)=RES(I)
30447            IF(ICOLR(K).EQ.MAXCP3)Z(IINDX+J)=YPLOT(I)
30448            IF(ICOLR(K).EQ.MAXCP4)Z(IINDX+J)=XPLOT(I)
30449            IF(ICOLR(K).EQ.MAXCP5)Z(IINDX+J)=X2PLOT(I)
30450            IF(ICOLR(K).EQ.MAXCP6)Z(IINDX+J)=TAGPLO(I)
30451 2240     CONTINUE
30452        ELSEIF(K.EQ.NGROUP)THEN
30453          DO2250I=1,IMAX
30454            IF(ISUB(I).EQ.0)GOTO2250
30455            J=J+1
30456            IJ=MAXN*(ICOLR(K)-1)+I
30457C
30458            IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HTCC')THEN
30459              WRITE(ICOUT,2251)I,J,MAXN,ICOLR(K),IJ,NQ,IMAX
30460 2251         FORMAT('I,J,MAXN,ICOLR(K),IJ,NQ,IMAX = ',7I8)
30461              CALL DPWRST('XXX','BUG ')
30462            ENDIF
30463C
30464            IF(ICOLR(K).LE.MAXCOL)X1(J)=V(IJ)
30465            IF(ICOLR(K).EQ.MAXCP1)X1(J)=PRED(I)
30466            IF(ICOLR(K).EQ.MAXCP2)X1(J)=RES(I)
30467            IF(ICOLR(K).EQ.MAXCP3)X1(J)=YPLOT(I)
30468            IF(ICOLR(K).EQ.MAXCP4)X1(J)=XPLOT(I)
30469            IF(ICOLR(K).EQ.MAXCP5)X1(J)=X2PLOT(I)
30470            IF(ICOLR(K).EQ.MAXCP6)X1(J)=TAGPLO(I)
30471 2250     CONTINUE
30472        ELSEIF(K.EQ.NHIST)THEN
30473          DO2260I=1,IMAX
30474            IF(ISUB(I).EQ.0)GOTO2260
30475            J=J+1
30476            IJ=MAXN*(ICOLR(K)-1)+I
30477C
30478            IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HTCC')THEN
30479              WRITE(ICOUT,2261)I,J,MAXN,ICOLR(K),IJ,NQ,IMAX
30480 2261         FORMAT('I,J,MAXN,ICOLR(K),IJ,NQ,IMAX = ',7I8)
30481              CALL DPWRST('XXX','BUG ')
30482            ENDIF
30483C
30484            IF(ICOLR(K).LE.MAXCOL)XHIST(J)=V(IJ)
30485            IF(ICOLR(K).EQ.MAXCP1)XHIST(J)=PRED(I)
30486            IF(ICOLR(K).EQ.MAXCP2)XHIST(J)=RES(I)
30487            IF(ICOLR(K).EQ.MAXCP3)XHIST(J)=YPLOT(I)
30488            IF(ICOLR(K).EQ.MAXCP4)XHIST(J)=XPLOT(I)
30489            IF(ICOLR(K).EQ.MAXCP5)XHIST(J)=X2PLOT(I)
30490            IF(ICOLR(K).EQ.MAXCP6)XHIST(J)=TAGPLO(I)
30491 2260     CONTINUE
30492        ENDIF
30493        NLOCAL=J
30494        NSUB=NLOCAL
30495C
30496 2200 CONTINUE
30497      NZ=NUMVAR
30498C
30499      CCUSL=CPUMIN
30500      IH='USL '
30501      IH2='    '
30502      IHWUSE='P'
30503      MESSAG='NO'
30504      CALL CHECKN(IH,IH2,IHWUSE,
30505     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
30506     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
30507      IF(IERROR.EQ.'NO')CCUSL=VALUE(ILOCP)
30508      IERROR='NO'
30509C
30510      CCLSL=CPUMAX
30511      IH='LSL '
30512      IH2='    '
30513      IHWUSE='P'
30514      MESSAG='NO'
30515      CALL CHECKN(IH,IH2,IHWUSE,
30516     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
30517     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
30518      IF(IERROR.EQ.'NO')CCLSL=VALUE(ILOCP)
30519      IERROR='NO'
30520C
30521      ALPHA=0.05
30522      IH='ALPH'
30523      IH2='A   '
30524      IHWUSE='P'
30525      MESSAG='NO'
30526      CALL CHECKN(IH,IH2,IHWUSE,
30527     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
30528     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
30529      IF(IERROR.EQ.'NO')THEN
30530        IF(VALUE(ILOCP).GT.0.0 .AND. VALUE(ILOCP).LT.0.50)
30531     1     ALPHA=VALUE(ILOCP)
30532      ENDIF
30533      IERROR='NO'
30534C
30535C               *******************************************************
30536C               **  STEP 31--                                        **
30537C               **  FORM THE VERTICAL AND HORIZONTAL AXIS            **
30538C               **  VALUES Y(.) AND X(.) FOR THE PLOT.               **
30539C               **  DEFINE THE VECTOR D(.) SO THAT EACH ANDREW'S     **
30540C               **  CURVE HAS ITS OWNS TAG NUMBER.                   **
30541C               **  DEFINE THE NUMBER OF PLOT POINTS    (NPLOTP).    **
30542C               **  DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV).    **
30543C               *******************************************************
30544C
30545      ISTEPN='8'
30546      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HTCC')
30547     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30548C
30549      NUMVA2=NUMVAR
30550      IF(IFLGGR.EQ.'ON')NUMVA2=NUMVA2-1
30551      IF(IFLGHI.EQ.'ON')NUMVA2=NUMVA2-1
30552      CALL DPHTC2(Z,ZHIST,ZMEANS,S,
30553     1            MAXOBV,MAXHOT,NLOCAL,NUMVAR,NUMVA2,
30554     1            X1,XHIST,XIDTEM,TEMP,XMEANS,DMEAN,INDEX,NIJUNK,
30555     1            IGRPST,XGROUP,
30556     1            ICASPL,ICONT,CCUSL,CCLSL,ALPHA,
30557     1            Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR)
30558C
30559C               *****************
30560C               **  STEP 90--  **
30561C               **  EXIT       **
30562C               *****************
30563C
30564 9000 CONTINUE
30565      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HTCC')THEN
30566        WRITE(ICOUT,999)
30567        CALL DPWRST('XXX','BUG ')
30568        WRITE(ICOUT,9011)
30569 9011   FORMAT('***** AT THE END       OF DPHTCC--')
30570        CALL DPWRST('XXX','BUG ')
30571        WRITE(ICOUT,9013)IFOUND,IERROR,NSUB,NZ
30572 9013   FORMAT('IFOUND,IERROR,NSUB,NZ = ',2(A4,2X),2I8)
30573        CALL DPWRST('XXX','BUG ')
30574        WRITE(ICOUT,9014)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
30575 9014   FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',3I8,3(2X,A4))
30576        CALL DPWRST('XXX','BUG ')
30577        IF(NPLOTP.GT.0)THEN
30578          DO9052I=1,NPLOTP
30579            WRITE(ICOUT,9053)I,Y(I),X(I),D(I)
30580 9053       FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5)
30581            CALL DPWRST('XXX','BUG ')
30582 9052     CONTINUE
30583        ENDIF
30584      ENDIF
30585C
30586      RETURN
30587      END
30588      SUBROUTINE DPHTC2(Z,ZHIST,ZMEANS,SPOOL,
30589     1                  MAXROM,MAXHOT,N,NUMVAR,NUMVA2,
30590     1                  X,XHIST,XIDTEM,TEMP,XMEANS,DMEAN,
30591     1                  INDEX,NIJUNK,
30592     1                  IGRPST,XGROUP,
30593     1                  ICASPL,ICONT,CCUSL,CCLSL,ALPHA,
30594     1                  Y2,X2,D2,N2,NPLOTV,IBUGG3,ISUBRO,IERROR)
30595C
30596C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
30597C              THAT WILL DEFINE A HOTELLING MULTIVARIATE CONTROL CHART
30598C     WRITTEN BY--ALAN HECKERT
30599C                 STATISTICAL ENGINEERING DIVISION
30600C                 INFORMATION TECHNOLOGY LABORATORY
30601C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
30602C                 GAITHERSBURG, MD 20899-8980
30603C                 PHONE--301-975-2899
30604C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
30605C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
30606C     REFERENCE--RYAN, "STATISTICAL METHODS FOR QUALITY CONTROL"
30607C     LANGUAGE--ANSI FORTRAN (1977)
30608C     VERSION NUMBER--98/9
30609C     ORIGINAL VERSION--SEPTEMBER 1998.
30610C     UPDATED         --MARCH     2003. SUPPORT EXTENDED TO FOUR CASES:
30611C                                       PHASE I GROUP
30612C                                       PHASE I INDIVIDUAL
30613C                                       PHASE II GROUP
30614C                                       PHASE II INDIVIDUAL
30615C     UPDATED         --JULY      2019. MODIFY HOW DATA STORED
30616C
30617C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
30618C
30619      CHARACTER*4 ICASPL
30620      CHARACTER*4 ICONT
30621      CHARACTER*4 IWRITE
30622      CHARACTER*4 IBUGG3
30623      CHARACTER*4 ISUBRO
30624      CHARACTER*4 IERROR
30625C
30626      CHARACTER*4 ISUBN1
30627      CHARACTER*4 ISUBN2
30628      CHARACTER*4 ISTEPN
30629C
30630C---------------------------------------------------------------------
30631C
30632      DIMENSION Z(N,NUMVA2)
30633      DIMENSION ZHIST(N,NUMVA2)
30634      DIMENSION ZMEANS(N,NUMVA2)
30635      DIMENSION X(*)
30636      DIMENSION XHIST(*)
30637      DIMENSION XGROUP(*)
30638      DIMENSION XIDTEM(*)
30639      DIMENSION XMEANS(*)
30640      DIMENSION TEMP(*)
30641      DIMENSION INDEX(*)
30642      DIMENSION NIJUNK(*)
30643      DIMENSION Y2(*)
30644      DIMENSION X2(*)
30645      DIMENSION D2(*)
30646      DIMENSION IGRPST(*)
30647      DIMENSION SPOOL(MAXHOT,MAXHOT)
30648      DOUBLE PRECISION DMEAN(*)
30649C
30650C---------------------------------------------------------------------
30651C
30652      INCLUDE 'DPCOP2.INC'
30653C
30654C-----START POINT-----------------------------------------------------
30655C
30656      ISUBN1='DPHT'
30657      ISUBN2='C2  '
30658      IWRITE='OFF '
30659C
30660C     CHECK THE INPUT ARGUMENTS FOR ERRORS
30661C
30662      IF(N.LT.2)THEN
30663        WRITE(ICOUT,999)
30664  999   FORMAT(1X)
30665        CALL DPWRST('XXX','BUG ')
30666        WRITE(ICOUT,31)
30667   31   FORMAT('***** ERROR IN HOTELLING CONTROL CHART (DPHTC2)--')
30668        CALL DPWRST('XXX','BUG ')
30669        WRITE(ICOUT,32)
30670   32   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST TWO;')
30671        CALL DPWRST('XXX','BUG ')
30672        WRITE(ICOUT,34)N
30673   34   FORMAT('      THE NUMBER OF OBSERVATIONS = ',I6)
30674        CALL DPWRST('XXX','BUG ')
30675        WRITE(ICOUT,999)
30676        CALL DPWRST('XXX','BUG ')
30677        IERROR='YES'
30678        GOTO9000
30679      ENDIF
30680C
30681      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'HTC2')THEN
30682        WRITE(ICOUT,70)
30683   70   FORMAT('AT THE BEGINNING OF DPHTC2--')
30684        CALL DPWRST('XXX','BUG ')
30685        WRITE(ICOUT,71)N,NUMVAR,MAXROM,ICASPL,ICONT
30686   71   FORMAT('N,NUMVAR,MAXROM,ICASPL,ICONT = ',3I8,2(2X,A4))
30687        CALL DPWRST('XXX','BUG ')
30688        DO79I=1,N
30689          WRITE(ICOUT,73)I,X(I),XHIST(I),(Z(I,J),J=1,3)
30690   73     FORMAT('X(I),XHIST(I),Z(I,J=1,3) = ',I8,5F12.5)
30691          CALL DPWRST('XXX','BUG ')
30692   79   CONTINUE
30693      ENDIF
30694C
30695C               *******************************************
30696C               **  STEP 3.0--                           **
30697C               **  DETERMINE STATISTICS FOR THE ENTIRE  **
30698C               **  DATA SET                             **
30699C               *******************************************
30700C
30701      ISTEPN='3.0'
30702      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'HTC2')
30703     1   CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30704C
30705      NC1=NUMVAR
30706      IF(ICASPL.EQ.'HT1G' .OR. ICASPL.EQ.'HT2G')NC1=NC1-1
30707      IF(ICASPL.EQ.'HT2G' .OR. ICASPL.EQ.'HT2I')NC1=NC1-1
30708      NR1=N
30709      N2=N
30710C
30711      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'HTC2')THEN
30712        WRITE(ICOUT,80)
30713   80   FORMAT('AT THE BEGINNING OF DPHTC2--')
30714        CALL DPWRST('XXX','BUG ')
30715        WRITE(ICOUT,81)NR1,NC1,N2
30716   81   FORMAT('NR1,NC1,N2 = ',3I8)
30717        CALL DPWRST('XXX','BUG ')
30718      ENDIF
30719C
30720C               **********************************************
30721C               **  STEP 5.1--                              **
30722C               **  TREAT THE PHASE I (GROUP) HOTELLING     **
30723C               **  CONTROL CHART CASE                      **
30724C               **********************************************
30725C
30726      IF(ICASPL.EQ.'HT1G')THEN
30727        ISTEPN='5.1'
30728        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'HTC2')
30729     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30730C
30731        CALL VARPO2(Z,ZMEANS,SPOOL,NR1,MAXHOT,NR1,NC1,MAXHOT,
30732     1              X,XIDTEM,NIJUNK,NGROUP,DMEAN,IBUGG3,IERROR)
30733C
30734        IF(IFEEDB.EQ.'ON')THEN
30735          WRITE(ICOUT,999)
30736          CALL DPWRST('XXX','BUG ')
30737          WRITE(ICOUT,5161)
30738 5161     FORMAT('**** HOTELLING PHASE I CONTROL CHART ',
30739     1           'FOR SUBGROUPS')
30740          CALL DPWRST('XXX','BUG ')
30741          WRITE(ICOUT,5164)
30742 5164     FORMAT('     COVARIANCE MATRIX MAXIMUM OF 5 COLUMNS ',
30743     1           'PRINTED)')
30744          CALL DPWRST('XXX','BUG ')
30745          DO5166J=1,NC1
30746            WRITE(ICOUT,5168)(SPOOL(J,L),L=1,MIN(NC1,5))
30747            CALL DPWRST('XXX','BUG ')
30748 5166     CONTINUE
30749 5168     FORMAT(6X,5E15.7)
30750          WRITE(ICOUT,999)
30751          CALL DPWRST('XXX','BUG ')
30752          WRITE(ICOUT,999)
30753          CALL DPWRST('XXX','BUG ')
30754        ENDIF
30755        CALL SGECO(SPOOL,MAXHOT,NC1,INDEX,RCOND,TEMP)
30756C
30757        IF(1.0+RCOND.EQ.1.0)THEN
30758          WRITE(ICOUT,999)
30759          CALL DPWRST('XXX','BUG ')
30760          WRITE(ICOUT,5101)
30761          CALL DPWRST('XXX','ERRO ')
30762          WRITE(ICOUT,5102)
30763          CALL DPWRST('XXX','ERRO ')
30764          WRITE(ICOUT,5103)
30765          CALL DPWRST('XXX','ERRO ')
30766          IERROR='YES'
30767          GOTO9000
30768        ENDIF
30769 5101   FORMAT('*** ERROR FROM DPHTC2: UNABLE TO COMPUTE THE INVERSE ',
30770     1         'OF THE POOLED COVARIANCE MATRIX.')
30771 5102   FORMAT('    PROBLEM: SOME COLUMNS ARE LINEARLY DEPDENDENT ON ',
30772     1         ' OTHER COLUMNS.')
30773 5103   FORMAT('    SUGGESTED SOLUTION: WORK WITH A SUBSET OF THE ',
30774     1       'ORIGINAL COLUMNS.')
30775C
30776        IJOB=1
30777        CALL SGEDI(SPOOL,MAXHOT,NC1,INDEX,TEMP,XMEANS,IJOB)
30778C
30779        CALL GRPMEA(Z,ZMEANS,NR1,MAXHOT,NR1,NC1,
30780     1            X,XIDTEM,NIJUNK,N2,NGROUP,XMEANS,IBUGG3,IERROR)
30781C
30782        IF(IFEEDB.EQ.'ON')THEN
30783          WRITE(ICOUT,999)
30784          CALL DPWRST('XXX','BUG ')
30785          DO5151J=1,NC1
30786            WRITE(ICOUT,5153)J,XMEANS(J)
30787 5153       FORMAT('     MEAN FOR VARIABLE ',I8,' = ',E15.7)
30788          CALL DPWRST('XXX','BUG  ')
30789 5151     CONTINUE
30790          WRITE(ICOUT,999)
30791          CALL DPWRST('XXX','BUG ')
30792        ENDIF
30793        ISTEPN='51A'
30794        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'HTC2')
30795     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30796C
30797        NP=NUMVAR-1
30798        NK=NGROUP
30799        J=0
30800        DO5110ISET=1,NGROUP
30801c
30802          DO5120L=1,NC1
30803            TEMP(L)=ZMEANS(ISET,L) - XMEANS(L)
30804 5120     CONTINUE
30805          CALL QUAFRM(SPOOL,MAXHOT,MAXHOT,NC1,NC1,TEMP,IWRITE,
30806     1                XQUAD,IBUGG3,IERROR)
30807          NI=NIJUNK(ISET)
30808          ANI=REAL(NI)
30809C
30810          C=REAL(NK*NI*NP - NK*NP - NI*NP + NP)/
30811     1      REAL(NK*NI - NK - NP + 1)
30812          ALPHA=2.0*0.00135*REAL(NP)
30813          IDEG2=NK*NI-NK-NP+1
30814C
30815          IF(NI.LE.0)THEN
30816            WRITE(ICOUT,999)
30817            CALL DPWRST('XXX','BUG ')
30818            WRITE(ICOUT,5131)
30819 5131       FORMAT('***** INTERNAL ERROR IN DPHTC2--')
30820            CALL DPWRST('XXX','BUG ')
30821            WRITE(ICOUT,5132)
30822 5132       FORMAT('NI FOR SOME CLASS = 0')
30823            CALL DPWRST('XXX','BUG ')
30824            WRITE(ICOUT,5133)ISET,XIDTEM(ISET),NI
30825 5133       FORMAT('ISET,XIDTEM(ISET),NI = ',I8,E15.7,I8)
30826            CALL DPWRST('XXX','BUG ')
30827            IERROR='YES'
30828            GOTO9000
30829          ELSEIF(IDEG2.LE.0)THEN
30830            WRITE(ICOUT,999)
30831            CALL DPWRST('XXX','BUG ')
30832            WRITE(ICOUT,5136)
30833 5136       FORMAT('***** ERROR IN DPHTC2--')
30834            CALL DPWRST('XXX','BUG ')
30835            WRITE(ICOUT,5137)ISET
30836 5137       FORMAT('      ZERO OR NEGATIVE DEGREES OF FREEDOM FOR THE ',
30837     1             'F-CDF VALUE FOR SET ',I8)
30838            CALL DPWRST('XXX','BUG ')
30839            WRITE(ICOUT,5138)NI
30840 5138       FORMAT('      GROUP SIZE (NI)          = ',I8)
30841            CALL DPWRST('XXX','BUG ')
30842            WRITE(ICOUT,5139)NK
30843 5139       FORMAT('      NUMBER OF SETS (NK)      = ',I8)
30844            CALL DPWRST('XXX','BUG ')
30845            WRITE(ICOUT,5141)NP
30846 5141       FORMAT('      NUMBER OF VARIABLES (NP) = ',I8)
30847            CALL DPWRST('XXX','BUG ')
30848            WRITE(ICOUT,5143)IDEG2
30849 5143       FORMAT('      DEGREES OF FREEDOM = NK*NI-NK-NP+1 = ',I8)
30850            CALL DPWRST('XXX','BUG ')
30851            IERROR='YES'
30852            GOTO9000
30853          ENDIF
30854C
30855          ALPHA2=1.0-ALPHA
30856          CALL FPPF(ALPHA2,NP,IDEG2,PPF)
30857C
30858          YTEMP=ANI*XQUAD
30859          YUPPER=C*PPF
30860C
30861          J=J+1
30862          Y2(J)=YTEMP
30863          X2(J)=XIDTEM(ISET)
30864          D2(J)=1.0
30865C
30866CCCCC     J=J+1
30867CCCCC     Y2(J)=0.0
30868CCCCC     X2(J)=XIDTEM(ISET)
30869CCCCC     D2(J)=2.0
30870C
30871          J=J+1
30872          Y2(J)=YUPPER
30873          X2(J)=XIDTEM(ISET)
30874          D2(J)=2.0
30875C
30876          IF(CCUSL.EQ.CPUMIN)GOTO5172
30877          J=J+1
30878          Y2(J)=CCUSL
30879          X2(J)=XIDTEM(ISET)
30880          D2(J)=3.0
30881 5172     CONTINUE
30882C
30883 5110   CONTINUE
30884        N2=J
30885        NPLOTV=3
30886C
30887C               **********************************************
30888C               **  STEP 5.2--                              **
30889C               **  TREAT THE PHASE II (GROUP) HOTELLING    **
30890C               **  CONTROL CHART CASE                      **
30891C               **********************************************
30892C
30893      ELSEIF(ICASPL.EQ.'HT2G')THEN
30894        ISTEPN='5.2'
30895        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'HTC2')
30896     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30897C
30898CCCCC FIRST STEP: DETERMINE WHICH VALUES REPRESENT "HISTORICAL"
30899CCCCC AND WHICH REPRESENT "FUTURE".  THE ZHIST MATRIX WILL CONSIST
30900CCCCC OF THOSE GROUPS THAT ARE "HISTORICAL" AND ALSO THAT WERE NOT
30901CCCCC DISCARDED.  NOTE THAT IF EVEN ONE VALUE IN A GROUP IS DISCARDED,
30902CCCCC THEN ENTIRE GROUP IS DISCARDED.
30903C
30904        CALL DISTIN(X,NR1,IWRITE,TEMP,NGRP,IBUGG3,IERROR)
30905C
30906        IROW=0
30907        NA=0
30908        DO5209I=1,NGRP
30909          ISTAT=0
30910          AGROUP=TEMP(I)
30911          DO5201J=1,NR1
30912            IF(X(J).EQ.AGROUP)THEN
30913              ATEMP=XHIST(J)
30914              IF(ABS(ATEMP).LE.0.5)THEN
30915                CONTINUE
30916              ELSEIF(ATEMP.GT.0.5)THEN
30917                IF(ISTAT.EQ.0)ISTAT=1
30918              ELSEIF(ATEMP.LT.-0.5)THEN
30919                ISTAT=-1
30920              ENDIF
30921            ENDIF
30922 5201     CONTINUE
30923          IGRPST(I)=ISTAT
30924          IF(ISTAT.LT.0)NA=NA+1
30925          IF(ISTAT.EQ.0)THEN
30926            DO5203J=1,NR1
30927              IF(X(J).EQ.AGROUP)THEN
30928                IROW=IROW+1
30929                DO5205L=1,NC1
30930                  ZHIST(IROW,L)=Z(J,L)
30931                  XGROUP(IROW)=AGROUP
30932 5205           CONTINUE
30933              ENDIF
30934 5203       CONTINUE
30935          ENDIF
30936 5209   CONTINUE
30937        NHIST=IROW
30938C
30939        CALL VARPO2(ZHIST,ZMEANS,SPOOL,NR1,MAXHOT,NHIST,NC1,MAXHOT,
30940     1              XGROUP,XIDTEM,NIJUNK,NGROUP,DMEAN,IBUGG3,IERROR)
30941C
30942        IF(IFEEDB.EQ.'ON')THEN
30943          WRITE(ICOUT,999)
30944          CALL DPWRST('XXX','BUG ')
30945          WRITE(ICOUT,5261)
30946 5261     FORMAT('**** HOTELLING PHASE II CONTROL CHART ',
30947     1           'FOR SUBGROUPS')
30948          CALL DPWRST('XXX','BUG ')
30949          WRITE(ICOUT,5263)NHIST
30950 5263     FORMAT('     NUMBER OF HISTORICAL OBSERVATIONS   = ',I8)
30951          CALL DPWRST('XXX','BUG ')
30952          WRITE(ICOUT,5264)
30953 5264     FORMAT('     COVARIANCE MATRIX (USING HISTORICAL ',
30954     1           'OBSERVATIONS, MAXIMUM OF 5 COLUMNS PRINTED)')
30955          CALL DPWRST('XXX','BUG ')
30956          DO5266J=1,NC1
30957            WRITE(ICOUT,5268)(SPOOL(J,L),L=1,MIN(NC1,5))
30958            CALL DPWRST('XXX','BUG ')
30959 5266     CONTINUE
30960 5268     FORMAT(6X,5E15.7)
30961          WRITE(ICOUT,999)
30962          CALL DPWRST('XXX','BUG ')
30963        ENDIF
30964C
30965        CALL SGECO(SPOOL,MAXHOT,NC1,INDEX,RCOND,TEMP)
30966C
30967        IF(1.0+RCOND.EQ.1.0)THEN
30968          WRITE(ICOUT,999)
30969          CALL DPWRST('XXX','BUG ')
30970          WRITE(ICOUT,5211)
30971          CALL DPWRST('XXX','ERRO ')
30972          WRITE(ICOUT,5212)
30973          CALL DPWRST('XXX','ERRO ')
30974          WRITE(ICOUT,5213)
30975          CALL DPWRST('XXX','ERRO ')
30976          IERROR='YES'
30977          GOTO9000
30978        ENDIF
30979 5211   FORMAT('*** ERROR FROM DPHTC2: UNABLE TO COMPUTE THE INVERSE ',
30980     1         'OF THE POOLED COVARIANCE MATRIX.')
30981 5212   FORMAT('    PROBLEM: SOME COLUMNS ARE LINEARLY DEPDENDENT ON ',
30982     1         ' OTHER COLUMNS.')
30983 5213   FORMAT('    SUGGESTED SOLUTION: WORK WITH A SUBSET OF THE ',
30984     1       'ORIGINAL COLUMNS.')
30985C
30986        IJOB=1
30987        CALL SGEDI(SPOOL,MAXHOT,NC1,INDEX,TEMP,XMEANS,IJOB)
30988C
30989C  CALL GRPMEA TWICE.  FIRST TIME TO GET MEAN OF MEANS
30990C  (XMEANS) BASED ON HISTORICAL DATA ONLY.  SECOND TIME TO GET GROUP
30991C  MEANS (ZMEANS) FOR ALL SUBGROUPS (HISTORICAL AND FUTURE).
30992C
30993        CALL GRPMEA(ZHIST,ZMEANS,NR1,MAXHOT,NHIST,NC1,
30994     1            XGROUP,XIDTEM,NIJUNK,N2,NGROUP,TEMP,IBUGG3,IERROR)
30995C
30996        CALL GRPMEA(Z,ZMEANS,NR1,MAXHOT,NR1,NC1,
30997     1            X,XIDTEM,NIJUNK,N2,NGROUP,XMEANS,IBUGG3,IERROR)
30998        DO5218J=1,NGROUP
30999          XMEANS(J)=TEMP(J)
31000 5218   CONTINUE
31001C
31002        IF(IFEEDB.EQ.'ON')THEN
31003          WRITE(ICOUT,999)
31004          CALL DPWRST('XXX','BUG ')
31005          DO5251J=1,NC1
31006            WRITE(ICOUT,5253)J,XMEANS(J)
31007 5253       FORMAT('     MEAN FOR VARIABLE ',I8,' (USING HISTORICAL ',
31008     1             'OBSERVATIONS) = ',E15.7)
31009          CALL DPWRST('XXX','BUG ')
31010 5251     CONTINUE
31011          WRITE(ICOUT,999)
31012          CALL DPWRST('XXX','BUG ')
31013        ENDIF
31014C
31015        ISTEPN='52A'
31016        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'HTC2')
31017     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31018C
31019        NP=NUMVAR-2
31020        NK=NGROUP
31021        ALPHA=2.0*0.00135*REAL(NP)
31022        ALPHA2=1.0-ALPHA
31023        J=0
31024        DO5290ISET=1,NGROUP
31025C
31026CCCCCC    DON'T PLOT HISTORICAL DATA
31027C
31028          DTAG=1.0
31029          IF(IGRPST(ISET).GT.0)DTAG=2.0
31030          IF(IGRPST(ISET).LT.0)GOTO5290
31031C
31032          DO5220L=1,NC1
31033            TEMP(L)=ZMEANS(ISET,L) - XMEANS(L)
31034 5220     CONTINUE
31035          CALL QUAFRM(SPOOL,MAXHOT,MAXHOT,NC1,NC1,TEMP,IWRITE,
31036     1                XQUAD,IBUGG3,IERROR)
31037          NI=NIJUNK(ISET)
31038          ANI=REAL(NI)
31039C
31040          C=REAL(NP*(NK-NA+1)*(NI-1))/REAL((NK-NA)*NI-NK+NA-NP+1)
31041          IDEG2=(NK-NA)*NI - NK + NA - NP + 1
31042C
31043          IF(NI.LE.0)THEN
31044            WRITE(ICOUT,999)
31045            CALL DPWRST('XXX','BUG ')
31046            WRITE(ICOUT,5231)
31047 5231       FORMAT('***** INTERNAL ERROR IN DPHTC2--')
31048            CALL DPWRST('XXX','BUG ')
31049            WRITE(ICOUT,5232)
31050 5232       FORMAT('NI FOR SOME CLASS = 0')
31051            CALL DPWRST('XXX','BUG ')
31052            WRITE(ICOUT,5233)ISET,XIDTEM(ISET),NI
31053 5233       FORMAT('ISET,XIDTEM(ISET),NI = ',I8,E15.7,I8)
31054            CALL DPWRST('XXX','BUG ')
31055            IERROR='YES'
31056            GOTO9000
31057          ELSEIF(IDEG2.LE.0)THEN
31058            WRITE(ICOUT,999)
31059            CALL DPWRST('XXX','BUG ')
31060            WRITE(ICOUT,5236)
31061 5236       FORMAT('***** ERROR IN DPHTC2--')
31062            CALL DPWRST('XXX','BUG ')
31063            WRITE(ICOUT,5237)ISET
31064 5237       FORMAT('      ZERO OR NEGATIVE DEGREES OF FREEDOM FOR THE ',
31065     1             'F-CDF VALUE FOR SET ',I8)
31066            CALL DPWRST('XXX','BUG ')
31067            WRITE(ICOUT,5238)NI
31068 5238       FORMAT('      GROUP SIZE (NI)          = ',I8)
31069            CALL DPWRST('XXX','BUG ')
31070            WRITE(ICOUT,5239)NK
31071 5239       FORMAT('      NUMBER OF SETS (NK)      = ',I8)
31072            CALL DPWRST('XXX','BUG ')
31073            WRITE(ICOUT,5241)NP
31074 5241       FORMAT('      NUMBER OF VARIABLES (NP) = ',I8)
31075            CALL DPWRST('XXX','BUG ')
31076            WRITE(ICOUT,5243)IDEG2
31077 5243       FORMAT('      DEGREES OF FREEDOM = NK*NI-NK-NP+1 = ',I8)
31078            CALL DPWRST('XXX','BUG ')
31079            IERROR='YES'
31080            GOTO9000
31081          ENDIF
31082C
31083          CALL FPPF(ALPHA2,NP,IDEG2,PPF)
31084C
31085          YTEMP=ANI*XQUAD
31086          YUPPER=C*PPF
31087C
31088          J=J+1
31089          Y2(J)=YTEMP
31090          X2(J)=XIDTEM(ISET)
31091          D2(J)=DTAG
31092C
31093CCCCC     J=J+1
31094CCCCC     Y2(J)=0.0
31095CCCCC     X2(J)=XIDTEM(ISET)
31096CCCCC     D2(J)=3.0
31097C
31098          J=J+1
31099          Y2(J)=YUPPER
31100          X2(J)=XIDTEM(ISET)
31101          D2(J)=3.0
31102C
31103          IF(CCUSL.EQ.CPUMIN)GOTO5272
31104          J=J+1
31105          Y2(J)=CCUSL
31106          X2(J)=XIDTEM(ISET)
31107          D2(J)=4.0
31108 5272     CONTINUE
31109C
31110 5290   CONTINUE
31111        N2=J
31112        NPLOTV=3
31113C
31114C               **********************************************
31115C               **  STEP 5.3--                              **
31116C               **  TREAT THE PHASE I (INDIVIDUAL) HOTELLING**
31117C               **  CONTROL CHART CASE                      **
31118C               **********************************************
31119C
31120      ELSEIF(ICASPL.EQ.'HT1I')THEN
31121        ISTEPN='5.3'
31122        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'HTC2')
31123     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31124C
31125        IWRITE='OFF'
31126C
31127        CALL COVMAT(Z,SPOOL,DMEAN,NR1,NR1,NUMVAR,MAXHOT)
31128        DO5303L=1,NUMVAR
31129          DO5305J=1,NR1
31130            TEMP(J)=Z(J,L)
31131 5305     CONTINUE
31132          CALL MEAN(TEMP,NR1,IWRITE,RIGHT,IBUGG3,IERROR)
31133          XMEANS(L)=RIGHT
31134 5303   CONTINUE
31135C
31136        IF(IFEEDB.EQ.'ON')THEN
31137          WRITE(ICOUT,999)
31138          CALL DPWRST('XXX','BUG ')
31139          WRITE(ICOUT,5361)
31140 5361     FORMAT('**** HOTELLING PHASE I CONTROL CHART ',
31141     1           'FOR INDIVIDUAL OBSERVATIONS')
31142          CALL DPWRST('XXX','BUG ')
31143          WRITE(ICOUT,5364)
31144 5364     FORMAT('     COVARIANCE MATRIX (MAXIMUM OF 5 COLUMNS ',
31145     1           'PRINTED)')
31146          CALL DPWRST('XXX','BUG ')
31147          DO5366J=1,NC1
31148            WRITE(ICOUT,5368)(SPOOL(J,L),L=1,MIN(NC1,5))
31149            CALL DPWRST('XXX','BUG ')
31150 5366     CONTINUE
31151 5368     FORMAT(6X,5E15.7)
31152          WRITE(ICOUT,999)
31153          CALL DPWRST('XXX','BUG ')
31154          DO5351J=1,NC1
31155            WRITE(ICOUT,5353)J,XMEANS(J)
31156 5353       FORMAT('     MEAN FOR VARIABLE ',I8,' = ',E15.7)
31157            CALL DPWRST('XXX','BUG ')
31158 5351     CONTINUE
31159          WRITE(ICOUT,999)
31160          CALL DPWRST('XXX','BUG ')
31161        ENDIF
31162C
31163        CALL SGECO(SPOOL,MAXHOT,NC1,INDEX,RCOND,TEMP)
31164C
31165        IF(1.0+RCOND.EQ.1.0)THEN
31166          WRITE(ICOUT,999)
31167          CALL DPWRST('XXX','BUG ')
31168          WRITE(ICOUT,5371)
31169          CALL DPWRST('XXX','ERRO ')
31170          WRITE(ICOUT,5372)
31171          CALL DPWRST('XXX','ERRO ')
31172          WRITE(ICOUT,5373)
31173          CALL DPWRST('XXX','ERRO ')
31174          IERROR='YES'
31175          GOTO9000
31176        ENDIF
31177 5371   FORMAT('*** ERROR FROM DPHTC2: UNABLE TO COMPUTE THE INVERSE ',
31178     1         'OF THE COVARIANCE MATRIX.')
31179 5372   FORMAT('    PROBLEM: SOME COLUMNS ARE LINEARLY DEPDENDENT ON ',
31180     1         ' OTHER COLUMNS.')
31181 5373   FORMAT('    SUGGESTED SOLUTION: WORK WITH A SUBSET OF THE ',
31182     1       'ORIGINAL COLUMNS.')
31183C
31184        IJOB=1
31185        CALL SGEDI(SPOOL,MAXHOT,NC1,INDEX,TEMP,ZMEANS,IJOB)
31186C
31187        ISTEPN='53A'
31188        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'HTC2')THEN
31189          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31190          DO5381J=1,NC1
31191            WRITE(ICOUT,5383)J,(SPOOL(J,L),L=1,NC1)
31192            CALL DPWRST('XXX','ERRO ')
31193 5381     CONTINUE
31194 5383     FORMAT('SPOOL: ROW ',I8,' = ',15F15.7)
31195        ENDIF
31196C
31197        NP=NC1
31198        AM=REAL(NR1)
31199        AFACT=(AM-1.0)**2/AM
31200        A=REAL(NP)/2.0
31201        B=(AM-REAL(NP)-1.0)/2.0
31202        ALPHA2=ALPHA/2.0
31203        CALL BETPPF(ALPHA2,A,B,YLOWER)
31204        YLOWER=AFACT*YLOWER
31205        ALPHA2=1.0 - ALPHA/2.0
31206        CALL BETPPF(ALPHA2,A,B,YUPPER)
31207        YUPPER=AFACT*YUPPER
31208        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'HTC2')THEN
31209          WRITE(ICOUT,5391)ISET,XQUAD,AM,AFACT,ALPHA
31210 5391     FORMAT('ISET,XQUAD,AM,AFACT = ',I8,4F15.7)
31211          CALL DPWRST('XXX','ERRO ')
31212          WRITE(ICOUT,5393)A,B,YLOWER,YUPPER
31213 5393     FORMAT('A,B,YLOWER,YUPPER = ',4F15.7)
31214          CALL DPWRST('XXX','ERRO ')
31215        ENDIF
31216C
31217        J=0
31218        DO5310ISET=1,NR1
31219C
31220          DO5320L=1,NC1
31221            TEMP(L)=Z(ISET,L) - XMEANS(L)
31222 5320     CONTINUE
31223          CALL QUAFRM(SPOOL,MAXHOT,MAXHOT,NC1,NC1,TEMP,IWRITE,
31224     1                XQUAD,IBUGG3,IERROR)
31225C
31226          YTEMP=XQUAD
31227C
31228          J=J+1
31229          Y2(J)=YTEMP
31230          X2(J)=REAL(ISET)
31231          D2(J)=1.0
31232C
31233CCCCC     J=J+1
31234CCCCC     Y2(J)=0.0
31235CCCCC     X2(J)=REAL(ISET)
31236CCCCC     D2(J)=2.0
31237C
31238          J=J+1
31239          Y2(J)=YUPPER
31240          X2(J)=REAL(ISET)
31241          D2(J)=2.0
31242C
31243          J=J+1
31244          Y2(J)=YLOWER
31245          X2(J)=REAL(ISET)
31246          D2(J)=3.0
31247C
31248          IF(CCUSL.EQ.CPUMIN)GOTO5352
31249          J=J+1
31250          Y2(J)=CCUSL
31251          X2(J)=REAL(ISET)
31252          D2(J)=4.0
31253 5352     CONTINUE
31254C
31255          IF(CCLSL.EQ.CPUMAX)GOTO5354
31256          J=J+1
31257          Y2(J)=CCLSL
31258          X2(J)=REAL(ISET)
31259          D2(J)=5.0
31260 5354     CONTINUE
31261C
31262 5310   CONTINUE
31263        N2=J
31264        NPLOTV=3
31265C
31266C               **********************************************
31267C               **  STEP 5.4--                              **
31268C               **  TREAT THE PHASE II (INDIVIDUAL) HOTELLING*
31269C               **  CONTROL CHART CASE                      **
31270C               **********************************************
31271C
31272      ELSEIF(ICASPL.EQ.'HT2I')THEN
31273        ISTEPN='5.4'
31274        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'HTC2')
31275     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31276C
31277        IWRITE='OFF'
31278C
31279C  USE X2 TO DETERMINE WHICH DATA POINTS ARE HISTORICAL AND
31280C  WHICH ARE FUTURE
31281C
31282        IROW=0
31283        DO5401I=1,NR1
31284          IF(ABS(XHIST(I)).LE.0.5)THEN
31285            IROW=IROW+1
31286            DO5402J=1,NC1
31287              ZHIST(IROW,J)=Z(I,J)
31288 5402       CONTINUE
31289          ENDIF
31290 5401   CONTINUE
31291        NHIST=IROW
31292C
31293        IF(NHIST.LE.2)THEN
31294          WRITE(ICOUT,5421)
31295 5421     FORMAT('**** ERROR FROM PHASE II HOTELLING INDIVIDUAL ',
31296     1           'CONTROL CHART')
31297          CALL DPWRST('XXX','ERRO ')
31298          WRITE(ICOUT,5423)NHIST
31299 5423     FORMAT('     INSUFFICIENT NUMBER OF HISTORICAL VALUES FOUND ',
31300     1           '(',I8,' FOUND)')
31301          CALL DPWRST('XXX','ERRO ')
31302          IERROR='YES'
31303          GOTO9000
31304        ENDIF
31305C
31306        CALL COVMAT(ZHIST,SPOOL,DMEAN,NR1,NHIST,NC1,MAXHOT)
31307C
31308        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'HTC2')THEN
31309          ISTEPN='54A'
31310          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31311          WRITE(ICOUT,5487)NHIST
31312 5487     FORMAT('NHIST = ',I8)
31313          CALL DPWRST('XXX','ERRO ')
31314          DO5486J=1,NC1
31315            WRITE(ICOUT,5488)J,(SPOOL(J,L),L=1,MIN(NC1,15))
31316            CALL DPWRST('XXX','ERRO ')
31317 5486     CONTINUE
31318 5488     FORMAT('COV: ROW ',I8,' = ',15F15.7)
31319        ENDIF
31320C
31321        DO5403L=1,NC1
31322          DO5405J=1,NHIST
31323            TEMP(J)=ZHIST(J,L)
31324 5405     CONTINUE
31325          CALL MEAN(TEMP,NHIST,IWRITE,RIGHT,IBUGG3,IERROR)
31326          XMEANS(L)=RIGHT
31327 5403   CONTINUE
31328C
31329        IF(IFEEDB.EQ.'ON')THEN
31330          WRITE(ICOUT,999)
31331          CALL DPWRST('XXX','BUG ')
31332          WRITE(ICOUT,5461)
31333 5461     FORMAT('**** HOTELLING PHASE II CONTROL CHART ',
31334     1           'FOR INDIVIDUAL OBSERVATIONS')
31335          CALL DPWRST('XXX','BUG ')
31336          WRITE(ICOUT,5463)NHIST
31337 5463     FORMAT('     NUMBER OF HISTORICAL OBSERVATIONS   = ',I8)
31338          CALL DPWRST('XXX','BUG ')
31339          WRITE(ICOUT,5464)
31340 5464     FORMAT('     COVARIANCE MATRIX (USING HISTORICAL ',
31341     1           'OBSERVATIONS, MAXIMUM OF 5 COLUMNS PRINTED)')
31342          CALL DPWRST('XXX','BUG ')
31343          WRITE(ICOUT,999)
31344          CALL DPWRST('XXX','BUG ')
31345          DO5466J=1,NC1
31346            WRITE(ICOUT,5468)(SPOOL(J,L),L=1,MIN(NC1,5))
31347            CALL DPWRST('XXX','BUG ')
31348 5466     CONTINUE
31349 5468     FORMAT(6X,5E15.7)
31350          DO5451J=1,NC1
31351            WRITE(ICOUT,5453)J,XMEANS(J)
31352 5453       FORMAT('     MEAN FOR VARIABLE ',I8,' (USING HISTORICAL ',
31353     1             'OBSERVATIONS) = ',E15.7)
31354          CALL DPWRST('XXX','BUG ')
31355 5451     CONTINUE
31356          WRITE(ICOUT,999)
31357          CALL DPWRST('XXX','BUG ')
31358        ENDIF
31359C
31360        CALL SGECO(SPOOL,MAXHOT,NC1,INDEX,RCOND,TEMP)
31361C
31362        IF(1.0+RCOND.EQ.1.0)THEN
31363          WRITE(ICOUT,999)
31364          CALL DPWRST('XXX','BUG ')
31365          WRITE(ICOUT,5471)
31366          CALL DPWRST('XXX','ERRO ')
31367          WRITE(ICOUT,5472)
31368          CALL DPWRST('XXX','ERRO ')
31369          WRITE(ICOUT,5473)
31370          CALL DPWRST('XXX','ERRO ')
31371          IERROR='YES'
31372          GOTO9000
31373        ENDIF
31374 5471   FORMAT('*** ERROR FROM DPHTC2: UNABLE TO COMPUTE THE INVERSE ',
31375     1         'OF THE COVARIANCE MATRIX.')
31376 5472   FORMAT('    PROBLEM: SOME COLUMNS ARE LINEARLY DEPDENDENT ON ',
31377     1         ' OTHER COLUMNS.')
31378 5473   FORMAT('    SUGGESTED SOLUTION: WORK WITH A SUBSET OF THE ',
31379     1       'ORIGINAL COLUMNS.')
31380C
31381        IJOB=1
31382        CALL SGEDI(SPOOL,MAXHOT,NC1,INDEX,TEMP,ZMEANS,IJOB)
31383C
31384        ISTEPN='54B'
31385        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'HTC2')THEN
31386          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31387          DO5481J=1,NC1
31388            WRITE(ICOUT,5483)J,(SPOOL(J,L),L=1,MIN(15,NC1))
31389            CALL DPWRST('XXX','ERRO ')
31390 5481     CONTINUE
31391 5483     FORMAT('SPOOL: ROW ',I8,' = ',15F15.7)
31392        ENDIF
31393C
31394C
31395        NP=NC1
31396        AM=REAL(NHIST)
31397        AFACT=REAL(NP)*(AM+1.0)*(AM-1.0)/(AM*AM - AM*REAL(NP))
31398        IDF1=NP
31399        IDF2=NHIST-NP
31400        ALPHA2=ALPHA/2.0
31401        CALL FPPF(ALPHA2,IDF1,IDF2,YLOWER)
31402        YLOWER=AFACT*YLOWER
31403        ALPHA2=1.0-ALPHA/2.0
31404        CALL FPPF(ALPHA2,IDF1,IDF2,YUPPER)
31405        YUPPER=AFACT*YUPPER
31406C
31407        J=0
31408        DO5410ISET=1,NR1
31409C
31410          DTAG=2.0
31411          IF(XHIST(ISET).LE.0.5)DTAG=1.0
31412          IF(XHIST(ISET).LT.-0.5)GOTO5410
31413C
31414          DO5420L=1,NC1
31415            TEMP(L)=Z(ISET,L) - XMEANS(L)
31416 5420     CONTINUE
31417          CALL QUAFRM(SPOOL,MAXHOT,MAXHOT,NC1,NC1,TEMP,IWRITE,
31418     1                XQUAD,IBUGG3,IERROR)
31419C
31420          YTEMP=XQUAD
31421C
31422          J=J+1
31423          Y2(J)=YTEMP
31424          X2(J)=REAL(ISET)
31425          D2(J)=DTAG
31426C
31427CCCCC     J=J+1
31428CCCCC     Y2(J)=0.0
31429CCCCC     X2(J)=REAL(ISET)
31430CCCCC     D2(J)=2.0
31431C
31432          J=J+1
31433          Y2(J)=YUPPER
31434          X2(J)=REAL(ISET)
31435          D2(J)=3.0
31436C
31437          J=J+1
31438          Y2(J)=YLOWER
31439          X2(J)=REAL(ISET)
31440          D2(J)=4.0
31441C
31442          IF(CCUSL.EQ.CPUMIN)GOTO5452
31443          J=J+1
31444          Y2(J)=CCUSL
31445          X2(J)=REAL(ISET)
31446          D2(J)=5.0
31447 5452     CONTINUE
31448C
31449          IF(CCLSL.EQ.CPUMAX)GOTO5454
31450          J=J+1
31451          Y2(J)=CCLSL
31452          X2(J)=REAL(ISET)
31453          D2(J)=6.0
31454 5454     CONTINUE
31455C
31456 5410   CONTINUE
31457        N2=J
31458        NPLOTV=3
31459C
31460      ENDIF
31461C
31462      GOTO9000
31463C
31464C               ******************
31465C               **   STEP 90--  **
31466C               **   EXIT       **
31467C               ******************
31468C
31469 9000 CONTINUE
31470      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'HTC2')THEN
31471        WRITE(ICOUT,999)
31472        CALL DPWRST('XXX','BUG ')
31473        WRITE(ICOUT,9011)
31474 9011   FORMAT('***** AT THE END       OF DPHTC2--')
31475        CALL DPWRST('XXX','BUG ')
31476      ENDIF
31477C
31478      RETURN
31479      END
31480      SUBROUTINE DPHTM1(CAPTN,NCAP,IFLAG1,IFLAG2)
31481C
31482C     PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING
31483C              HTML OUTPUT.  THIS ROUTINE IS USED TO INITIATE
31484C              THE HTML OUTPUT AND STARTS THE FIRST TABLE.
31485C              THE ONLY OPTIONAL ELEMENT IS THE CAPTION.
31486C     INPUT  ARGUMENTS--CAPTN  = THE CHARACTER STRING CONTAINING
31487C                                THE CAPTION.
31488C                     --NCAP   = THE INTEGER NUMBER THAT SPECIFIES
31489C                                THE NUMBER OF CHARACTERS IN THE
31490C                                CAPTION.
31491C     WRITTEN BY--ALAN HECKERT
31492C                 STATISTICAL ENGINEERING DIVISION
31493C                 INFORMATION TECHNOLOGY LABORATORY
31494C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
31495C                 GAITHERSBURG, MD 20899
31496C                 PHONE--301-975-2899
31497C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
31498C           OF THE NATIONAL BUREAU OF STANDARDS.
31499C     LANGUAGE--ANSI FORTRAN (1977)
31500C     VERSION NUMBER--2005/2
31501C     ORIGINAL VERSION--FEBRUARY  2005.
31502C
31503C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
31504C
31505      LOGICAL IFLAG1
31506      LOGICAL IFLAG2
31507C
31508      CHARACTER*(*) CAPTN
31509C
31510      CHARACTER*10 IFORMT
31511C
31512      CHARACTER*40 IHTMFZ
31513      COMMON/HTMC1/IHTMFZ,NCFON1
31514C---------------------------------------------------------------------
31515C
31516      INCLUDE 'DPCOP2.INC'
31517C
31518C-----START POINT-----------------------------------------------------
31519C
31520C  STEP 1: END ASIS MODE AND WRITE A HEADER
31521C
31522  999 FORMAT(1X)
31523 5001 FORMAT('</PRE>')
31524      IF(IFLAG1)THEN
31525        WRITE(ICOUT,5001)
31526        CALL DPWRST('XXX','WRIT')
31527        WRITE(ICOUT,999)
31528        CALL DPWRST('XXX','WRIT')
31529      ENDIF
31530C
31531C  STEP 2: START TABLE AND DEFINE A CAPTION
31532C
31533 5011 FORMAT('<UL>')
31534 5012 FORMAT('<FONT FACE="',A40,'">')
31535 5013 FORMAT('<TABLE NOBORDER>')
31536 5015 FORMAT('   <CAPTION ALIGN=CENTER> <B>')
31537 5019 FORMAT('   </B> </CAPTION>')
31538      IF(IFLAG2)THEN
31539        IFORMT=' '
31540        IF(NCAP.LE.99)THEN
31541          IFORMT(1:8)='(6X,A  )'
31542          WRITE(IFORMT(6:7),'(I2)')NCAP
31543        ELSEIF(NCAP.LE.999)THEN
31544          IFORMT(1:9)='(6X,A   )'
31545          WRITE(IFORMT(6:8),'(I3)')NCAP
31546        ENDIF
31547        WRITE(ICOUT,5011)
31548        CALL DPWRST('XXX','WRIT')
31549        IF(IHTMFZ.NE.'NONE')THEN
31550          WRITE(ICOUT,5012)IHTMFZ
31551          CALL DPWRST('XXX','WRIT')
31552        ENDIF
31553        WRITE(ICOUT,5013)
31554        CALL DPWRST('XXX','WRIT')
31555        IF(NCAP.GT.0)THEN
31556          WRITE(ICOUT,5015)
31557          CALL DPWRST('XXX','WRIT')
31558          WRITE(ICOUT,IFORMT)CAPTN(1:NCAP)
31559          CALL DPWRST('XXX','WRIT')
31560          WRITE(ICOUT,5019)
31561          CALL DPWRST('XXX','WRIT')
31562        ENDIF
31563      ENDIF
31564C
31565      RETURN
31566      END
31567      SUBROUTINE DPHTMA(ITITLE,NTITLE,CAPTN,NCAP,IFLAG1,IFLAG2)
31568C
31569C     PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING
31570C              HTML OUTPUT.  THIS ROUTINE IS USED TO INITIATE
31571C              THE HTML OUTPUT AND STARTS THE FIRST TABLE.
31572C              THIS IS A VARIATION OF DPHTM1.  IN ADDITION TO THE
31573C              TABLE CAPTION, IT ALLOWS YOU TO PRINT AN OVERALL
31574C              TITLE (TYPICALLY FOR THE FIRST TABLE OF A SET OF
31575C              TABLES).
31576C     INPUT  ARGUMENTS--ITITLE = THE CHARACTER STRING CONTAINING
31577C                                THE OVERALL TITLE.
31578C                     --NCAP   = THE INTEGER NUMBER THAT SPECIFIES
31579C                                THE NUMBER OF CHARACTERS IN THE
31580C                                CAPTION.
31581C                     --CAPTN  = THE CHARACTER STRING CONTAINING
31582C                                THE CAPTION.
31583C                     --NCAP   = THE INTEGER NUMBER THAT SPECIFIES
31584C                                THE NUMBER OF CHARACTERS IN THE
31585C                                CAPTION.
31586C     WRITTEN BY--ALAN HECKERT
31587C                 STATISTICAL ENGINEERING DIVISION
31588C                 INFORMATION TECHNOLOGY LABORATORY
31589C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
31590C                 GAITHERSBURG, MD 20899-8980
31591C                 PHONE--301-975-2899
31592C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
31593C           OF THE NATIONAL BUREAU OF STANDARDS.
31594C     LANGUAGE--ANSI FORTRAN (1977)
31595C     VERSION NUMBER--2009/4
31596C     ORIGINAL VERSION--APRIL     2009.
31597C
31598C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
31599C
31600      LOGICAL IFLAG1
31601      LOGICAL IFLAG2
31602C
31603      CHARACTER*(*) ITITLE
31604      CHARACTER*(*) CAPTN
31605C
31606      CHARACTER*10 IFORMT
31607C
31608C---------------------------------------------------------------------
31609C
31610      INCLUDE 'DPCOP2.INC'
31611C
31612C-----START POINT-----------------------------------------------------
31613C
31614C  STEP 1: END ASIS MODE AND WRITE A HEADER
31615C
31616  999 FORMAT(1X)
31617 5001 FORMAT('</PRE>')
31618      IF(IFLAG1)THEN
31619        WRITE(ICOUT,5001)
31620        CALL DPWRST('XXX','WRIT')
31621        WRITE(ICOUT,999)
31622        CALL DPWRST('XXX','WRIT')
31623      ENDIF
31624C
31625C  STEP 2: PRINT AN OVERALL TITLE BEFORE STARTING THE TABLE
31626C
31627 5006 FORMAT('<UL><UL><B>')
31628 5008 FORMAT('</B></UL></UL>')
31629      IF(NTITLE.GT.0)THEN
31630        WRITE(ICOUT,5006)
31631        CALL DPWRST('XXX','WRIT')
31632        IFORMT=' '
31633        IFORMT(1:8)='(6X,A  )'
31634        WRITE(IFORMT(6:7),'(I2)')NTITLE
31635        WRITE(ICOUT,IFORMT)ITITLE(1:NTITLE)
31636        CALL DPWRST('XXX','WRIT')
31637        WRITE(ICOUT,5008)
31638        CALL DPWRST('XXX','WRIT')
31639      ENDIF
31640C
31641C
31642C  STEP 3: START TABLE AND DEFINE A CAPTION
31643C
31644 5011 FORMAT('<UL>')
31645 5013 FORMAT('<TABLE NOBORDER>')
31646 5015 FORMAT('<B>')
31647 5019 FORMAT('</B>')
31648      IF(IFLAG2)THEN
31649        IFORMT=' '
31650        IFORMT(1:8)='(6X,A  )'
31651        WRITE(IFORMT(6:7),'(I2)')NCAP
31652        WRITE(ICOUT,5011)
31653        CALL DPWRST('XXX','WRIT')
31654        IF(NCAP.GT.0)THEN
31655          WRITE(ICOUT,5015)
31656          CALL DPWRST('XXX','WRIT')
31657          WRITE(ICOUT,IFORMT)CAPTN(1:NCAP)
31658          CALL DPWRST('XXX','WRIT')
31659          WRITE(ICOUT,5019)
31660          CALL DPWRST('XXX','WRIT')
31661        ENDIF
31662        WRITE(ICOUT,5013)
31663        CALL DPWRST('XXX','WRIT')
31664      ENDIF
31665C
31666      RETURN
31667      END
31668      SUBROUTINE DPHTM2(IFLAG1,IFLAG2,NHEAD)
31669C
31670C     PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING
31671C              HTML OUTPUT.  THIS ROUTINE IS USED TO CLOSE THE
31672C              CURRENT TABLE AND TERMINATE THE HTML OUTPUT.
31673C     WRITTEN BY--ALANN HECKERT
31674C                 STATISTICAL ENGINEERING DIVISION
31675C                 INFORMATION TECHNOLOGY LABORATORY
31676C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
31677C                 GAITHERSBURG, MD 20899
31678C                 PHONE--301-975-2899
31679C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
31680C           OF THE NATIONAL BUREAU OF STANDARDS.
31681C     LANGUAGE--ANSI FORTRAN (1977)
31682C     VERSION NUMBER--2005/2
31683C     ORIGINAL VERSION--FEBRUARY  2005.
31684C
31685C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
31686C
31687      LOGICAL IFLAG1
31688      LOGICAL IFLAG2
31689C
31690      CHARACTER*40 IHTMFZ
31691      COMMON/HTMC1/IHTMFZ,NCFON1
31692C
31693C-----COMMON----------------------------------------------------------
31694C
31695      INCLUDE 'DPCOBE.INC'
31696      INCLUDE 'DPCOP2.INC'
31697C
31698C-----START POINT-----------------------------------------------------
31699C
31700      IF(ISUBG4.EQ.'HTM2')THEN
31701        WRITE(ICOUT,52)IFLAG1,IFLAG2,NHEAD
31702   52   FORMAT('IFLAG1,IFLAG2,NHEAD = ',2L5,I5)
31703        CALL DPWRST('XXX','BUG ')
31704      ENDIF
31705C
31706C  STEP 1: END THE CURRENT TABLE
31707C
31708  999 FORMAT(1X)
31709 5191 FORMAT('</TABLE>')
31710 5192 FORMAT('</FONT>')
31711 5193 FORMAT('</UL>')
31712      IF(IFLAG1)THEN
31713        WRITE(ICOUT,5191)
31714        CALL DPWRST('XXX','WRIT')
31715        IF(IHTMFZ.NE.'NONE')THEN
31716          WRITE(ICOUT,5192)
31717          CALL DPWRST('XXX','WRIT')
31718        ENDIF
31719        WRITE(ICOUT,5193)
31720        CALL DPWRST('XXX','WRIT')
31721      ENDIF
31722C
31723C  STEP 2: RESET "ASIS" MODE
31724C
31725 5199 FORMAT('<PRE>')
31726      IF(IFLAG2)THEN
31727        WRITE(ICOUT,999)
31728        CALL DPWRST('XXX','WRIT')
31729        WRITE(ICOUT,5199)
31730        CALL DPWRST('XXX','WRIT')
31731      ENDIF
31732C
31733      RETURN
31734      END
31735      SUBROUTINE DPHTM3(IVALUE,NCHAR,AVALUE,NUMDIG,IWIDT1,IWIDT2)
31736C
31737C     PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING
31738C              HTML OUTPUT.  THIS ROUTINE IS USED TO GENERATE
31739C              ONE ROW OF A TABLE WHERE:
31740C
31741C                 COLUMN 1: A TEXT STRING
31742C                 COLUMN 2: A NUMERIC VALUE
31743C
31744C              IF NCHAR = 0, A SINGLE SPACE WILL BE INSERTED,
31745C              IF NUMDIG = 0, AN INTEGER FORMAT WILL BE USED,
31746C              IF NUMDIG = -1, A SINGLE SPACE WILL BE INSERTED,
31747C              IF NUMDIG = -2, A DEFAULT FORMAT WILL BE USED.
31748C
31749C     INPUT  ARGUMENTS--IVALUE  = THE CHARACTER STRING CONTAINING
31750C                                 THE CHARACTER VALUE.
31751C                     --NCHAR   = THE INTEGER NUMBER THAT SPECIFIES
31752C                                 THE NUMBER OF CHARACTERS IN THE
31753C                                 CHARACTER STRING.
31754C                     --AVALUE  = THE NUMERIC VALUE TO BE PRINTED.
31755C     WRITTEN BY--ALAN HECKERT
31756C                 STATISTICAL ENGINEERING DIVISION
31757C                 INFORMATION TECHNOLOGY LABORATORY
31758C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
31759C                 GAITHERSBURG, MD 20899
31760C                 PHONE--301-975-2899
31761C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
31762C           OF THE NATIONAL BUREAU OF STANDARDS.
31763C     LANGUAGE--ANSI FORTRAN (1977)
31764C     VERSION NUMBER--2005/2
31765C     ORIGINAL VERSION--FEBRUARY  2005.
31766C
31767C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
31768C
31769      CHARACTER*(*) IVALUE
31770C
31771      CHARACTER*10 IFORMT
31772C
31773C---------------------------------------------------------------------
31774C
31775      INCLUDE 'DPCOP2.INC'
31776C
31777C-----START POINT-----------------------------------------------------
31778C
31779C  STEP 3: DEFINE A DATA ROW
31780C
31781CC999 FORMAT(1X)
31782 5041 FORMAT('   <TR>')
31783 5043 FORMAT('      <TD ALIGN=LEFT VALIGN=BOTTOM WIDTH=',I5,'>')
31784 5047 FORMAT('      </TD>')
31785 5049 FORMAT('      <TD ALIGN=RIGHT VALIGN=BOTTOM WIDTH=',I5,'>')
31786 5031 FORMAT('         ',G15.7)
31787 5033 FORMAT('         ',I8)
31788 5035 FORMAT('         &nbsp;')
31789 5039 FORMAT('   </TR>')
31790C
31791      WRITE(ICOUT,5041)
31792      CALL DPWRST('XXX','WRIT')
31793      WRITE(ICOUT,5043)IWIDT1
31794      CALL DPWRST('XXX','WRIT')
31795      IF(NCHAR.GT.0)THEN
31796        IFORMT=' '
31797        IFORMT(1:8)='(9X,A  )'
31798        WRITE(IFORMT(6:7),'(I2)')NCHAR
31799        WRITE(ICOUT,IFORMT)IVALUE(1:NCHAR)
31800        CALL DPWRST('XXX','WRIT')
31801      ELSE
31802        WRITE(ICOUT,5035)
31803        CALL DPWRST('XXX','WRIT')
31804      ENDIF
31805      WRITE(ICOUT,5047)
31806      CALL DPWRST('XXX','WRIT')
31807      WRITE(ICOUT,5049)IWIDT2
31808      CALL DPWRST('XXX','WRIT')
31809      IF(NUMDIG.GT.0)THEN
31810        IFORMT=' '
31811        IFORMT(1:10)='(9X,F15. )'
31812        WRITE(IFORMT(9:9),'(I1)')MIN(NUMDIG,9)
31813        WRITE(ICOUT,IFORMT)AVALUE
31814        CALL DPWRST('XXX','WRIT')
31815      ELSEIF(NUMDIG.EQ.0)THEN
31816        IF(AVALUE.GE.0.0)THEN
31817          WRITE(ICOUT,5033)INT(AVALUE+0.5)
31818        ELSE
31819          WRITE(ICOUT,5033)INT(AVALUE-0.5)
31820        ENDIF
31821        CALL DPWRST('XXX','WRIT')
31822      ELSEIF(NUMDIG.EQ.-1)THEN
31823        WRITE(ICOUT,5035)
31824        CALL DPWRST('XXX','WRIT')
31825      ELSEIF(NUMDIG.EQ.-2)THEN
31826        WRITE(ICOUT,5031)AVALUE
31827        CALL DPWRST('XXX','WRIT')
31828      ENDIF
31829      WRITE(ICOUT,5047)
31830      CALL DPWRST('XXX','WRIT')
31831      WRITE(ICOUT,5039)
31832      CALL DPWRST('XXX','WRIT')
31833C
31834      RETURN
31835      END
31836      SUBROUTINE DPHTM4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2)
31837C
31838C     PURPOSE--THIS ROUTINE IS A UTILITY ROUTINE FOR CREATING
31839C              HTML OUTPUT.  THIS ROUTINE IS USED TO GENERATE
31840C              A HEADER ROW FOR A TABLE.  YOU CAN ALSO OPTIONALLY
31841C              ADD A RULE LINE BEFORE OR AFTER THE HEADER.
31842C
31843C     INPUT  ARGUMENTS--IVALUE  = THE CHARACTER STRING ARRAY
31844C                                 CONTAINING THE TEXT FOR THE
31845C                                 HEADER VALUES.
31846C                     --NCHAR   = THE INTEGER ARRAY THAT SPECIFIES
31847C                                 THE NUMBER OF CHARACTERS IN THE
31848C                                 HEADER VALUES.
31849C                     --NHEAD   = THE INTEGER VALUE THAT SPECIFIES
31850C                                 THE NUMBER OF HEADER VALUES.
31851C                     --IFLAG1  = A LOGICAL VALUE THAT SPECIFIES
31852C                                 WHETHER A RULE LINE IS DRAWN BEFORE
31853C                                 THE HHEADER.
31854C                     --IFLAG2  = A LOGICAL VALUE THAT SPECIFIES
31855C                                 WHETHER A RULE LINE IS DRAWN AFTER
31856C                                 THE HHEADER.
31857C     WRITTEN BY--ALAN HECKERT
31858C                 STATISTICAL ENGINEERING DIVISION
31859C                 INFORMATION TECHNOLOGY LABORATORY
31860C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
31861C                 GAITHERSBURG, MD 20899
31862C                 PHONE--301-975-2899
31863C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
31864C           OF THE NATIONAL BUREAU OF STANDARDS.
31865C     LANGUAGE--ANSI FORTRAN (1977)
31866C     VERSION NUMBER--2005/2
31867C     ORIGINAL VERSION--FEBRUARY  2005.
31868C     UPDATED         --NOVEMBER  2008. SUPPORT FOR FONT SIZES
31869C
31870C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
31871C
31872      CHARACTER*(*) IVALUE(NHEAD)
31873      INTEGER NCHAR(NHEAD)
31874C
31875      PARAMETER (MAXHED=1024)
31876      INTEGER IWIDTH(MAXHED)
31877      INTEGER NUMDIG(MAXHED)
31878      CHARACTER*8 ALIGN(MAXHED)
31879      CHARACTER*8 VALIGN(MAXHED)
31880      COMMON/HTML4/IWIDTH,NUMDIG,ALIGN,VALIGN
31881      COMMON/HTML44/IFNTSZ
31882C
31883      LOGICAL IFLAG1
31884      LOGICAL IFLAG2
31885C
31886      CHARACTER*10 IFORMT
31887C
31888C---------------------------------------------------------------------
31889C
31890      INCLUDE 'DPCOP2.INC'
31891C
31892C-----START POINT-----------------------------------------------------
31893C
31894C  STEP 3: DEFINE A DATA ROW
31895C
31896CC999 FORMAT(1X)
31897C
31898C  FOLLOWING ADDS A RULE LINE BEFORE THE HEADER LINE
31899C
31900 5021 FORMAT('   <TR>')
31901 5061 FORMAT('      <TD COLSPAN=',I5,'>')
31902 5062 FORMAT('          <HR>')
31903 5047 FORMAT('      </TD>')
31904 5039 FORMAT('   </TR>')
31905 5141 FORMAT('         <FONT SIZE="+1">')
31906 5142 FORMAT('         <FONT SIZE="+2">')
31907 5146 FORMAT('         <FONT SIZE="-1">')
31908 5147 FORMAT('         <FONT SIZE="-2">')
31909 5149 FORMAT('         </FONT>')
31910      IF(IFLAG1)THEN
31911        WRITE(ICOUT,5021)
31912        CALL DPWRST('XXX','WRIT')
31913        WRITE(ICOUT,5061)NHEAD
31914        CALL DPWRST('XXX','WRIT')
31915C
31916        IF(IFNTSZ.EQ.1)THEN
31917          WRITE(ICOUT,5141)
31918          CALL DPWRST('XXX','WRIT')
31919        ELSEIF(IFNTSZ.EQ.2)THEN
31920          WRITE(ICOUT,5142)
31921          CALL DPWRST('XXX','WRIT')
31922        ELSEIF(IFNTSZ.EQ.-1)THEN
31923          WRITE(ICOUT,5146)
31924          CALL DPWRST('XXX','WRIT')
31925        ELSEIF(IFNTSZ.EQ.-2)THEN
31926          WRITE(ICOUT,5147)
31927          CALL DPWRST('XXX','WRIT')
31928        ENDIF
31929C
31930        WRITE(ICOUT,5062)
31931        CALL DPWRST('XXX','WRIT')
31932C
31933        IF(IFNTSZ.EQ.1 .OR. IFNTSZ.EQ.2 .OR.
31934     1     IFNTSZ.EQ.-1 .OR. IFNTSZ.EQ.-2) THEN
31935           WRITE(ICOUT,5149)
31936           CALL DPWRST('XXX','WRIT')
31937        ENDIF
31938C
31939        WRITE(ICOUT,5047)
31940        CALL DPWRST('XXX','WRIT')
31941        WRITE(ICOUT,5039)
31942        CALL DPWRST('XXX','WRIT')
31943      ENDIF
31944C
31945C  GENERATE A HEADER LINE
31946C
31947 5023 FORMAT('      <TH ALIGN=',A8,' VALIGN=',A8,' WIDTH=',I8,'>')
31948 5027 FORMAT('      </TH>')
31949C5029 FORMAT('      <TH ALIGN=RIGHT VALIGN=BOTTOM>')
31950 5031 FORMAT('         &nbsp;')
31951      IF(NHEAD.GE.1)THEN
31952        WRITE(ICOUT,5021)
31953        CALL DPWRST('XXX','WRIT')
31954        DO100I=1,NHEAD
31955          WRITE(ICOUT,5023)ALIGN(I),VALIGN(I),IWIDTH(I)
31956          CALL DPWRST('XXX','WRIT')
31957C
31958          IF(IFNTSZ.EQ.1)THEN
31959            WRITE(ICOUT,5141)
31960            CALL DPWRST('XXX','WRIT')
31961          ELSEIF(IFNTSZ.EQ.2)THEN
31962            WRITE(ICOUT,5142)
31963            CALL DPWRST('XXX','WRIT')
31964          ELSEIF(IFNTSZ.EQ.-1)THEN
31965            WRITE(ICOUT,5146)
31966            CALL DPWRST('XXX','WRIT')
31967          ELSEIF(IFNTSZ.EQ.-2)THEN
31968            WRITE(ICOUT,5147)
31969            CALL DPWRST('XXX','WRIT')
31970          ENDIF
31971C
31972          IF(NCHAR(I).GT.0)THEN
31973            IFORMT=' '
31974            IFORMT(1:8)='(9X,A  )'
31975            WRITE(IFORMT(6:7),'(I2)')NCHAR(I)
31976            WRITE(ICOUT,IFORMT)IVALUE(I)(1:NCHAR(I))
31977            CALL DPWRST('XXX','WRIT')
31978          ELSE
31979            WRITE(ICOUT,5031)
31980            CALL DPWRST('XXX','WRIT')
31981          ENDIF
31982C
31983          IF(IFNTSZ.EQ.1 .OR. IFNTSZ.EQ.2 .OR.
31984     1       IFNTSZ.EQ.-1 .OR. IFNTSZ.EQ.-2) THEN
31985             WRITE(ICOUT,5149)
31986             CALL DPWRST('XXX','WRIT')
31987          ENDIF
31988C
31989          WRITE(ICOUT,5027)
31990          CALL DPWRST('XXX','WRIT')
31991  100   CONTINUE
31992        WRITE(ICOUT,5039)
31993        CALL DPWRST('XXX','WRIT')
31994      ENDIF
31995C
31996C  FOLLOWING ADDS A RULE LINE AFTER THE HEADER LINE
31997C
31998      IF(IFLAG2)THEN
31999        WRITE(ICOUT,5021)
32000        CALL DPWRST('XXX','WRIT')
32001        WRITE(ICOUT,5061)NHEAD
32002        CALL DPWRST('XXX','WRIT')
32003        WRITE(ICOUT,5062)
32004        CALL DPWRST('XXX','WRIT')
32005        WRITE(ICOUT,5047)
32006        CALL DPWRST('XXX','WRIT')
32007        WRITE(ICOUT,5039)
32008        CALL DPWRST('XXX','WRIT')
32009      ENDIF
32010C
32011      RETURN
32012      END
32013      SUBROUTINE DPHT4B(IVALUE,NCHAR,NHEAD,NCOLSP,IFLAG1,IFLAG2)
32014C
32015C     PURPOSE--THIS ROUTINE IS A UTILITY ROUTINE FOR CREATING
32016C              HTML OUTPUT.  THIS ROUTINE IS USED TO GENERATE
32017C              A HEADER ROW FOR A TABLE.  YOU CAN ALSO OPTIONALLY
32018C              ADD A RULE LINE BEFORE OR AFTER THE HEADER.
32019C
32020C              THIS IS A MODIFIED VERSION OF DPHTM4 THAT ALLOWS
32021C              MULTIPLE COLUMN SPANS.
32022C
32023C     INPUT  ARGUMENTS--IVALUE  = THE CHARACTER STRING ARRAY
32024C                                 CONTAINING THE TEXT FOR THE
32025C                                 HEADER VALUES.
32026C                     --NCHAR   = THE INTEGER ARRAY THAT SPECIFIES
32027C                                 THE NUMBER OF CHARACTERS IN THE
32028C                                 HEADER VALUES.
32029C                     --NHEAD   = THE INTEGER VALUE THAT SPECIFIES
32030C                                 THE NUMBER OF HEADER VALUES.
32031C                     --NCOLSP  = THE INTEGER ARRAY THAT SPECIFIES
32032C                                 THE COLUMN SPAN FOR THE GIVEN
32033C                                 COLUMN.
32034C                     --IFLAG1  = A LOGICAL VALUE THAT SPECIFIES
32035C                                 WHETHER A RULE LINE IS DRAWN BEFORE
32036C                                 THE HHEADER.
32037C                     --IFLAG2  = A LOGICAL VALUE THAT SPECIFIES
32038C                                 WHETHER A RULE LINE IS DRAWN AFTER
32039C                                 THE HHEADER.
32040C     WRITTEN BY--ALAN HECKERT
32041C                 STATISTICAL ENGINEERING DIVISION
32042C                 INFORMATION TECHNOLOGY LABORATORY
32043C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
32044C                 GAITHERSBURG, MD 20899-8980
32045C                 PHONE--301-975-2899
32046C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
32047C           OF THE NATIONAL BUREAU OF STANDARDS.
32048C     LANGUAGE--ANSI FORTRAN (1977)
32049C     VERSION NUMBER--2011/1
32050C     ORIGINAL VERSION--JANUARYY  2011.
32051C
32052C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
32053C
32054      CHARACTER*(*) IVALUE(NHEAD)
32055      INTEGER NCHAR(NHEAD)
32056      INTEGER NCOLSP(NHEAD)
32057C
32058      PARAMETER (MAXHED=1024)
32059      INTEGER IWIDTH(MAXHED)
32060      INTEGER NUMDIG(MAXHED)
32061      CHARACTER*8 ALIGN(MAXHED)
32062      CHARACTER*8 VALIGN(MAXHED)
32063      COMMON/HTML4/IWIDTH,NUMDIG,ALIGN,VALIGN
32064      COMMON/HTML44/IFNTSZ
32065C
32066      LOGICAL IFLAG1
32067      LOGICAL IFLAG2
32068C
32069      CHARACTER*10 IFORMT
32070C
32071C---------------------------------------------------------------------
32072C
32073      INCLUDE 'DPCOP2.INC'
32074C
32075C-----START POINT-----------------------------------------------------
32076C
32077C  STEP 3: DEFINE A DATA ROW
32078C
32079CC999 FORMAT(1X)
32080C
32081C  FOLLOWING ADDS A RULE LINE BEFORE THE HEADER LINE
32082C
32083 5021 FORMAT('   <TR>')
32084 5061 FORMAT('      <TD COLSPAN=',I5,'>')
32085 5062 FORMAT('          <HR>')
32086 5047 FORMAT('      </TD>')
32087 5039 FORMAT('   </TR>')
32088 5141 FORMAT('         <FONT SIZE="+1">')
32089 5142 FORMAT('         <FONT SIZE="+2">')
32090 5146 FORMAT('         <FONT SIZE="-1">')
32091 5147 FORMAT('         <FONT SIZE="-2">')
32092 5149 FORMAT('         </FONT>')
32093      IF(IFLAG1)THEN
32094        WRITE(ICOUT,5021)
32095        CALL DPWRST('XXX','WRIT')
32096        WRITE(ICOUT,5061)NHEAD
32097        CALL DPWRST('XXX','WRIT')
32098C
32099        IF(IFNTSZ.EQ.1)THEN
32100          WRITE(ICOUT,5141)
32101          CALL DPWRST('XXX','WRIT')
32102        ELSEIF(IFNTSZ.EQ.2)THEN
32103          WRITE(ICOUT,5142)
32104          CALL DPWRST('XXX','WRIT')
32105        ELSEIF(IFNTSZ.EQ.-1)THEN
32106          WRITE(ICOUT,5146)
32107          CALL DPWRST('XXX','WRIT')
32108        ELSEIF(IFNTSZ.EQ.-2)THEN
32109          WRITE(ICOUT,5147)
32110          CALL DPWRST('XXX','WRIT')
32111        ENDIF
32112C
32113        WRITE(ICOUT,5062)
32114        CALL DPWRST('XXX','WRIT')
32115C
32116        IF(IFNTSZ.EQ.1 .OR. IFNTSZ.EQ.2 .OR.
32117     1     IFNTSZ.EQ.-1 .OR. IFNTSZ.EQ.-2) THEN
32118           WRITE(ICOUT,5149)
32119           CALL DPWRST('XXX','WRIT')
32120        ENDIF
32121C
32122        WRITE(ICOUT,5047)
32123        CALL DPWRST('XXX','WRIT')
32124        WRITE(ICOUT,5039)
32125        CALL DPWRST('XXX','WRIT')
32126      ENDIF
32127C
32128C  GENERATE A HEADER LINE
32129C
32130 5023 FORMAT('      <TH ALIGN=',A8,' VALIGN=',A8,' WIDTH=',I8,
32131     1       ' COLSPAN=',I2,'>')
32132 5123 FORMAT('      <TH ALIGN=CENTER  VALIGN=',A8,' WIDTH=',I8,
32133     1       ' COLSPAN=',I2,'>')
32134 5027 FORMAT('      </TH>')
32135C5029 FORMAT('      <TH ALIGN=RIGHT VALIGN=BOTTOM>')
32136 5031 FORMAT('         &nbsp;')
32137      IF(NHEAD.GE.1)THEN
32138        WRITE(ICOUT,5021)
32139        CALL DPWRST('XXX','WRIT')
32140        DO100I=1,NHEAD
32141          IF(NCOLSP(I).LE.0)GOTO100
32142          IF(NCOLSP(I).EQ.1)THEN
32143            WRITE(ICOUT,5023)ALIGN(I),VALIGN(I),IWIDTH(I),NCOLSP(I)
32144            CALL DPWRST('XXX','WRIT')
32145          ELSE
32146            WRITE(ICOUT,5123)VALIGN(I),IWIDTH(I),NCOLSP(I)
32147            CALL DPWRST('XXX','WRIT')
32148          ENDIF
32149C
32150          IF(IFNTSZ.EQ.1)THEN
32151            WRITE(ICOUT,5141)
32152            CALL DPWRST('XXX','WRIT')
32153          ELSEIF(IFNTSZ.EQ.2)THEN
32154            WRITE(ICOUT,5142)
32155            CALL DPWRST('XXX','WRIT')
32156          ELSEIF(IFNTSZ.EQ.-1)THEN
32157            WRITE(ICOUT,5146)
32158            CALL DPWRST('XXX','WRIT')
32159          ELSEIF(IFNTSZ.EQ.-2)THEN
32160            WRITE(ICOUT,5147)
32161            CALL DPWRST('XXX','WRIT')
32162          ENDIF
32163C
32164          IF(NCHAR(I).GT.0)THEN
32165            IFORMT=' '
32166            IFORMT(1:8)='(9X,A  )'
32167            WRITE(IFORMT(6:7),'(I2)')NCHAR(I)
32168            WRITE(ICOUT,IFORMT)IVALUE(I)(1:NCHAR(I))
32169            CALL DPWRST('XXX','WRIT')
32170          ELSE
32171            WRITE(ICOUT,5031)
32172            CALL DPWRST('XXX','WRIT')
32173          ENDIF
32174C
32175          IF(IFNTSZ.EQ.1 .OR. IFNTSZ.EQ.2 .OR.
32176     1       IFNTSZ.EQ.-1 .OR. IFNTSZ.EQ.-2) THEN
32177             WRITE(ICOUT,5149)
32178             CALL DPWRST('XXX','WRIT')
32179          ENDIF
32180C
32181          WRITE(ICOUT,5027)
32182          CALL DPWRST('XXX','WRIT')
32183  100   CONTINUE
32184        WRITE(ICOUT,5039)
32185        CALL DPWRST('XXX','WRIT')
32186      ENDIF
32187C
32188C  FOLLOWING ADDS A RULE LINE AFTER THE HEADER LINE
32189C
32190      IF(IFLAG2)THEN
32191        WRITE(ICOUT,5021)
32192        CALL DPWRST('XXX','WRIT')
32193        WRITE(ICOUT,5061)NHEAD
32194        CALL DPWRST('XXX','WRIT')
32195        WRITE(ICOUT,5062)
32196        CALL DPWRST('XXX','WRIT')
32197        WRITE(ICOUT,5047)
32198        CALL DPWRST('XXX','WRIT')
32199        WRITE(ICOUT,5039)
32200        CALL DPWRST('XXX','WRIT')
32201      ENDIF
32202C
32203      RETURN
32204      END
32205      SUBROUTINE DPHTM5(IVALUE,NCHAR,AVALUE,NHEAD,IBOLD)
32206C
32207C     PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING
32208C              HTML OUTPUT.  THIS ROUTINE IS USED TO GENERATE
32209C              A DATA ROW FOR A TABLE.  THE FIRST FIELD CAN
32210C              BE A TEXT VALUE (FOR A ROW LABEL).
32211C
32212C     INPUT  ARGUMENTS--IVALUE  = THE CHARACTER STRING CONTAINING
32213C                                 THE TEXT FOR THE FIRST COLUMN.
32214C                     --NCHAR   = THE INTEGER ARRAY THAT SPECIFIES
32215C                                 THE NUMBER OF CHARACTERS IN THE
32216C                                 FIRST TEXT FIELD.
32217C                     --AVALUE  = A REAL ARRAY CONTAINING THE DATA
32218C                                 TO BE GENERATED.
32219C                     --NHEAD   = THE INTEGER VALUE THAT SPECIFIES
32220C                                 THE NUMBER OF NUMERIC VALUES.
32221C                     --IBOLD   = THE LOGICAL VALUE THAT SPECIFIES
32222C                                 WHETHER THE HEADER COLUMN WILL BE
32223C                                 BOLD OR NOT.
32224C     WRITTEN BY--ALAN HECKERT
32225C                 STATISTICAL ENGINEERING DIVISION
32226C                 INFORMATION TECHNOLOGY LABORATORY
32227C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
32228C                 GAITHERSBURG, MD 20899
32229C                 PHONE--301-975-2899
32230C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
32231C           OF THE NATIONAL BUREAU OF STANDARDS.
32232C     LANGUAGE--ANSI FORTRAN (1977)
32233C     VERSION NUMBER--2005/2
32234C     ORIGINAL VERSION--FEBRUARY  2005.
32235C     UPDATED         --MARCH     2009. MAKE BOLD FOR HEADER
32236C                                       COLUMN OPTIONAL
32237C     UPDATED         --APRIL     2009. ADDITIONAL FORMATTING OPTIONS
32238C                                       FOR NUMBERS
32239C
32240C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
32241C
32242      CHARACTER*(*) IVALUE
32243      REAL AVALUE(NHEAD)
32244      INTEGER NCHAR
32245C
32246      PARAMETER (MAXHED=1024)
32247      INTEGER IWIDTH(MAXHED)
32248      INTEGER NUMDIG(MAXHED)
32249      CHARACTER*8 ALIGN(MAXHED)
32250      CHARACTER*8 VALIGN(MAXHED)
32251      COMMON/HTML4/IWIDTH,NUMDIG,ALIGN,VALIGN
32252C
32253      CHARACTER*40 IFORMT
32254      LOGICAL IBOLD
32255C
32256C---------------------------------------------------------------------
32257C
32258      INCLUDE 'DPCOP2.INC'
32259C
32260C-----START POINT-----------------------------------------------------
32261C
32262C  STEP 3: DEFINE A DATA ROW
32263C
32264CC999 FORMAT(1X)
32265C
32266C  GENERATE A DATA LINE
32267C
32268 5021 FORMAT('   <TR>')
32269 5039 FORMAT('   </TR>')
32270 5023 FORMAT('      <TD ALIGN=',A8,' VALIGN=',A8,' WIDTH=',I5,'>')
32271 5024 FORMAT('         <B>')
32272 5025 FORMAT('         </B>')
32273 5027 FORMAT('      </TD>')
32274C5029 FORMAT('      <TD ALIGN=RIGHT VALIGN=BOTTOM>')
32275C
32276      WRITE(ICOUT,5021)
32277      CALL DPWRST('XXX','WRIT')
32278C
32279      IF(NCHAR.GT.0)THEN
32280        WRITE(ICOUT,5023)ALIGN(1),VALIGN(1),IWIDTH(1)
32281        CALL DPWRST('XXX','WRIT')
32282        IF(IBOLD)THEN
32283          WRITE(ICOUT,5024)
32284          CALL DPWRST('XXX','WRIT')
32285        ENDIF
32286        IFORMT=' '
32287        IFORMT(1:8)='(9X,A  )'
32288        WRITE(IFORMT(6:7),'(I2)')NCHAR
32289        WRITE(ICOUT,IFORMT)IVALUE(1:NCHAR)
32290        CALL DPWRST('XXX','WRIT')
32291        IF(IBOLD)THEN
32292          WRITE(ICOUT,5025)
32293          CALL DPWRST('XXX','WRIT')
32294        ENDIF
32295        WRITE(ICOUT,5027)
32296        CALL DPWRST('XXX','WRIT')
32297      ENDIF
32298C
32299C     APRIL 2009: SUPPORT THE FOLLOWING FORMATTING OPTIONS
32300C
32301C                  NUMDIG(I) > 0          => Fyy.xx FORMAT
32302C                  NUMDIG(I) = 0          => I12 FORMAT
32303C                  NUMDIG(I) = -1         => BLANK
32304C                  NUMDIG(I) = -2         => G15.7
32305C                  NUMDIG(I) = -3 to -20  => Eyy.xx
32306C                  NUMDIG(I) = -99        => '**'
32307C
32308 5031 FORMAT('         ',G15.7)
32309 5033 FORMAT('         ',I12)
32310 5035 FORMAT('         &nbsp;')
32311 5037 FORMAT('         **')
32312      IF(NHEAD.GE.1)THEN
32313        DO100I=1,NHEAD
32314          WRITE(ICOUT,5023)ALIGN(I+1),VALIGN(I+1),IWIDTH(I+1)
32315          CALL DPWRST('XXX','WRIT')
32316          IF(NUMDIG(I).GT.0)THEN
32317            IXX=MIN(NUMDIG(I),20)
32318            IYY=NUMDIG(I)+10
32319            IFORMT=' '
32320            IFORMT(1:11)='(9X,F  .  )'
32321            WRITE(IFORMT(9:10),'(I2)')IXX
32322            WRITE(IFORMT(6:7),'(I2)')IYY
32323            WRITE(ICOUT,IFORMT)AVALUE(I)
32324            CALL DPWRST('XXX','WRIT')
32325          ELSEIF(NUMDIG(I).EQ.0)THEN
32326            IF(AVALUE(I).GE.0.0)THEN
32327              WRITE(ICOUT,5033)INT(AVALUE(I)+0.5)
32328            ELSE
32329              WRITE(ICOUT,5033)INT(AVALUE(I)-0.5)
32330            ENDIF
32331            CALL DPWRST('XXX','WRIT')
32332          ELSEIF(NUMDIG(I).EQ.-1)THEN
32333            WRITE(ICOUT,5035)
32334            CALL DPWRST('XXX','WRIT')
32335          ELSEIF(NUMDIG(I).EQ.-2)THEN
32336            WRITE(ICOUT,5031)AVALUE(I)
32337            CALL DPWRST('XXX','WRIT')
32338          ELSEIF(NUMDIG(I).EQ.-99)THEN
32339            WRITE(ICOUT,5037)
32340            CALL DPWRST('XXX','WRIT')
32341          ELSEIF(NUMDIG(I).LT.-2 .AND. NUMDIG(I).GT.-20)THEN
32342            IXX=ABS(NUMDIG(I))
32343            IYY=IXX+8
32344            IFORMT=' '
32345            IFORMT(1:11)='(9X,E  .  )'
32346            WRITE(IFORMT(9:10),'(I2)')IXX
32347            WRITE(IFORMT(6:7),'(I2)')IYY
32348            WRITE(ICOUT,IFORMT)AVALUE(I)
32349            CALL DPWRST('XXX','WRIT')
32350          ENDIF
32351          WRITE(ICOUT,5027)
32352          CALL DPWRST('XXX','WRIT')
32353  100   CONTINUE
32354      ENDIF
32355C
32356      WRITE(ICOUT,5039)
32357      CALL DPWRST('XXX','WRIT')
32358C
32359      RETURN
32360      END
32361      SUBROUTINE DPHTM6(NHEAD)
32362C
32363C     PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING
32364C              HTML OUTPUT.  THIS ROUTINE IS USED TO DRAW A RULE
32365C              LINE SPANNING NHEAD COLUMNS.
32366C     WRITTEN BY--ALAN HECKERT
32367C                 STATISTICAL ENGINEERING DIVISION
32368C                 INFORMATION TECHNOLOGY LABORATORY
32369C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
32370C                 GAITHERSBURG, MD 20899
32371C                 PHONE--301-975-2899
32372C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
32373C           OF THE NATIONAL BUREAU OF STANDARDS.
32374C     LANGUAGE--ANSI FORTRAN (1977)
32375C     VERSION NUMBER--2005/2
32376C     ORIGINAL VERSION--FEBRUARY  2005.
32377C
32378C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
32379C
32380C---------------------------------------------------------------------
32381C
32382      INCLUDE 'DPCOP2.INC'
32383C
32384C-----START POINT-----------------------------------------------------
32385C
32386C  FOLLOWING ADDS A RULE LINE
32387C
32388 5021 FORMAT('   <TR>')
32389 5061 FORMAT('      <TD COLSPAN=',I5,'>')
32390 5062 FORMAT('          <HR>')
32391 5047 FORMAT('      </TD>')
32392 5039 FORMAT('   </TR>')
32393      WRITE(ICOUT,5021)
32394      CALL DPWRST('XXX','WRIT')
32395      WRITE(ICOUT,5061)NHEAD
32396      CALL DPWRST('XXX','WRIT')
32397      WRITE(ICOUT,5062)
32398      CALL DPWRST('XXX','WRIT')
32399      WRITE(ICOUT,5047)
32400      CALL DPWRST('XXX','WRIT')
32401      WRITE(ICOUT,5039)
32402      CALL DPWRST('XXX','WRIT')
32403      RETURN
32404      END
32405      SUBROUTINE DPHTM7(IVALUE,NCHAR,AVALUE,NHEAD,IVAL2,NCHAR2)
32406C
32407C     PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING
32408C              HTML OUTPUT.  THIS ROUTINE IS USED TO GENERATE
32409C              A DATA ROW FOR A TABLE.  THE FIRST AND LAST FIELDS
32410C              CAN BE A TEXT VALUE (FOR A ROW LABEL).
32411C
32412C     INPUT  ARGUMENTS--IVALUE  = THE CHARACTER STRING CONTAINING
32413C                                 THE TEXT FOR THE FIRST COLUMN.
32414C                     --NCHAR   = THE INTEGER ARRAY THAT SPECIFIES
32415C                                 THE NUMBER OF CHARACTERS IN THE
32416C                                 FIRST TEXT FIELD.
32417C                     --AVALUE  = A REAL ARRAY CONTAINING THE DATA
32418C                                 TO BE GENERATED.
32419C                     --NHEAD   = THE INTEGER VALUE THAT SPECIFIES
32420C                                 THE NUMBER OF NUMERIC VALUES.
32421C                     --IVAL2   = THE CHARACTER STRING CONTAINING
32422C                                 THE TEXT FOR THE LAST COLUMN.
32423C                     --NCHAR2  = THE INTEGER ARRAY THAT SPECIFIES
32424C                                 THE NUMBER OF CHARACTERS IN THE
32425C                                 LAST TEXT FIELD.
32426C     WRITTEN BY--ALAN HECKERT
32427C                 STATISTICAL ENGINEERING DIVISION
32428C                 INFORMATION TECHNOLOGY LABORATORY
32429C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
32430C                 GAITHERSBURG, MD 20899-8980
32431C                 PHONE--301-975-2899
32432C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
32433C           OF THE NATIONAL BUREAU OF STANDARDS.
32434C     LANGUAGE--ANSI FORTRAN (1977)
32435C     VERSION NUMBER--2006/11
32436C     ORIGINAL VERSION--NOVEMBER  2006.
32437C
32438C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
32439C
32440      CHARACTER*(*) IVALUE
32441      CHARACTER*(*) IVAL2
32442      REAL AVALUE(NHEAD)
32443      INTEGER NCHAR
32444C
32445      PARAMETER (MAXHED=1024)
32446      INTEGER IWIDTH(MAXHED)
32447      INTEGER NUMDIG(MAXHED)
32448      CHARACTER*8 ALIGN(MAXHED)
32449      CHARACTER*8 VALIGN(MAXHED)
32450      COMMON/HTML4/IWIDTH,NUMDIG,ALIGN,VALIGN
32451C
32452      CHARACTER*10 IFORMT
32453C
32454C---------------------------------------------------------------------
32455C
32456      INCLUDE 'DPCOP2.INC'
32457C
32458C-----START POINT-----------------------------------------------------
32459C
32460C  STEP 3: DEFINE A DATA ROW
32461C
32462CC999 FORMAT(1X)
32463C
32464C  GENERATE A DATA LINE
32465C
32466 5021 FORMAT('   <TR>')
32467 5039 FORMAT('   </TR>')
32468 5023 FORMAT('      <TD ALIGN=',A8,' VALIGN=',A8,' WIDTH=',I5,'>')
32469 5024 FORMAT('         <B>')
32470 5025 FORMAT('         </B>')
32471 5027 FORMAT('      </TD>')
32472C5029 FORMAT('      <TD ALIGN=RIGHT VALIGN=BOTTOM>')
32473C
32474      WRITE(ICOUT,5021)
32475      CALL DPWRST('XXX','WRIT')
32476C
32477      IF(NCHAR.GT.0)THEN
32478        WRITE(ICOUT,5023)ALIGN(1),VALIGN(1),IWIDTH(1)
32479        CALL DPWRST('XXX','WRIT')
32480        WRITE(ICOUT,5024)
32481        CALL DPWRST('XXX','WRIT')
32482        IFORMT=' '
32483        IFORMT(1:8)='(9X,A  )'
32484        WRITE(IFORMT(6:7),'(I2)')NCHAR
32485        WRITE(ICOUT,IFORMT)IVALUE(1:NCHAR)
32486        CALL DPWRST('XXX','WRIT')
32487        WRITE(ICOUT,5025)
32488        CALL DPWRST('XXX','WRIT')
32489        WRITE(ICOUT,5027)
32490        CALL DPWRST('XXX','WRIT')
32491      ENDIF
32492C
32493 5031 FORMAT('         ',G15.7)
32494 5033 FORMAT('         ',I8)
32495 5035 FORMAT('         &nbsp;')
32496      IF(NHEAD.GE.1)THEN
32497        DO100I=1,NHEAD
32498          WRITE(ICOUT,5023)ALIGN(I+1),VALIGN(I+1),IWIDTH(I+1)
32499          CALL DPWRST('XXX','WRIT')
32500          IF(NUMDIG(I).GT.0)THEN
32501            IFORMT=' '
32502            IFORMT(1:10)='(9X,F15. )'
32503            WRITE(IFORMT(9:9),'(I1)')MIN(NUMDIG(I),9)
32504            WRITE(ICOUT,IFORMT)AVALUE(I)
32505            CALL DPWRST('XXX','WRIT')
32506          ELSEIF(NUMDIG(I).EQ.0)THEN
32507            WRITE(ICOUT,5033)INT(AVALUE(I)+0.5)
32508            CALL DPWRST('XXX','WRIT')
32509          ELSEIF(NUMDIG(I).EQ.-1)THEN
32510            WRITE(ICOUT,5035)
32511            CALL DPWRST('XXX','WRIT')
32512          ELSEIF(NUMDIG(I).EQ.-2)THEN
32513            WRITE(ICOUT,5031)AVALUE(I)
32514            CALL DPWRST('XXX','WRIT')
32515          ENDIF
32516          WRITE(ICOUT,5027)
32517          CALL DPWRST('XXX','WRIT')
32518  100   CONTINUE
32519      ENDIF
32520C
32521      IF(NCHAR2.GT.0)THEN
32522        WRITE(ICOUT,5023)ALIGN(NHEAD+2),VALIGN(NHEAD+2),
32523     1                   IWIDTH(NHEAD+2)
32524        CALL DPWRST('XXX','WRIT')
32525        WRITE(ICOUT,5024)
32526        CALL DPWRST('XXX','WRIT')
32527        IFORMT=' '
32528        IFORMT(1:8)='(9X,A  )'
32529        WRITE(IFORMT(6:7),'(I2)')NCHAR2
32530        WRITE(ICOUT,IFORMT)IVAL2(1:NCHAR2)
32531        CALL DPWRST('XXX','WRIT')
32532        WRITE(ICOUT,5025)
32533        CALL DPWRST('XXX','WRIT')
32534        WRITE(ICOUT,5027)
32535        CALL DPWRST('XXX','WRIT')
32536      ENDIF
32537C
32538      WRITE(ICOUT,5039)
32539      CALL DPWRST('XXX','WRIT')
32540C
32541      RETURN
32542      END
32543      SUBROUTINE DPHTM8(IVALUE,NCHAR,AVALUE,NHEAD,ITYPE,
32544     1                  IFLAGA,IFLAGB)
32545C
32546C     PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING
32547C              HTML OUTPUT.  THIS ROUTINE IS USED TO GENERATE
32548C              A DATA ROW THAT MAY CONTAIN A MIXTURE OF NUMERIC
32549C              AND CHARACTER VALUES.
32550C
32551C     INPUT  ARGUMENTS--IVALUE  = AN ARRAY OF CHARACTER STRINGS.
32552C                     --NCHAR   = THE INTEGER ARRAY THAT SPECIFIES
32553C                                 THE NUMBER OF CHARACTERS IN THE
32554C                                 CHARACTER FIELDS.
32555C                     --AVALUE  = A REAL ARRAY CONTAINING THE NUMERIC
32556C                                 FIELDS..
32557C                     --NHEAD   = THE INTEGER VALUE THAT SPECIFIES
32558C                                 THE NUMBER OF FIELDS.
32559C                     --ITYPE   = A CHARACTER ARRAY THAT SPECIFIES
32560C                                 WHICH FIELDS ARE NUMERIC AND
32561C                                 WHICH ARE CHARACTER.
32562C     WRITTEN BY--ALAN HECKERT
32563C                 STATISTICAL ENGINEERING DIVISION
32564C                 INFORMATION TECHNOLOGY LABORATORY
32565C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
32566C                 GAITHERSBURG, MD 20899-8980
32567C                 PHONE--301-975-2899
32568C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
32569C           OF THE NATIONAL BUREAU OF STANDARDS.
32570C     LANGUAGE--ANSI FORTRAN (1977)
32571C     VERSION NUMBER--2008/10
32572C     ORIGINAL VERSION--OCTOBER   2008.
32573C
32574C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
32575C
32576      CHARACTER*(*) IVALUE(*)
32577      CHARACTER*4 ITYPE(*)
32578      REAL AVALUE(*)
32579      INTEGER NCHAR(*)
32580C
32581      LOGICAL IFLAGA
32582      LOGICAL IFLAGB
32583C
32584      PARAMETER (MAXHED=1024)
32585      INTEGER IWIDTH(MAXHED)
32586      INTEGER NUMDIG(MAXHED)
32587      CHARACTER*8 ALIGN(MAXHED)
32588      CHARACTER*8 VALIGN(MAXHED)
32589      COMMON/HTML4/IWIDTH,NUMDIG,ALIGN,VALIGN
32590      COMMON/HTML44/IFNTSZ
32591C
32592      CHARACTER*10 IFORMT
32593C
32594C---------------------------------------------------------------------
32595C
32596      INCLUDE 'DPCOP2.INC'
32597C
32598C-----START POINT-----------------------------------------------------
32599C
32600C  STEP 3: DEFINE A DATA ROW
32601C
32602CC999 FORMAT(1X)
32603C
32604C  GENERATE A DATA LINE
32605C
32606 5021 FORMAT('   <TR>')
32607 5039 FORMAT('   </TR>')
32608 5023 FORMAT('      <TD ALIGN=',A8,' VALIGN=',A8,' WIDTH=',I5,'>')
32609C5024 FORMAT('         <B>')
32610C5025 FORMAT('         </B>')
32611 5027 FORMAT('      </TD>')
32612C5029 FORMAT('      <TD ALIGN=RIGHT VALIGN=BOTTOM>')
32613 5031 FORMAT('         ',G15.7)
32614 5033 FORMAT('         ',I8)
32615 5035 FORMAT('         &nbsp;')
32616 5141 FORMAT('         <FONT SIZE="+1">')
32617 5142 FORMAT('         <FONT SIZE="+2">')
32618 5146 FORMAT('         <FONT SIZE="-1">')
32619 5147 FORMAT('         <FONT SIZE="-2">')
32620 5149 FORMAT('         </FONT>')
32621C
32622      IF(IFLAGA)THEN
32623        WRITE(ICOUT,5021)
32624        CALL DPWRST('XXX','WRIT')
32625        WRITE(ICOUT,5041)NHEAD
32626 5041   FORMAT('   <TD COLSPAN=',I1,'>')
32627        CALL DPWRST('XXX','WRIT')
32628        WRITE(ICOUT,5043)
32629 5043   FORMAT('   <HR>')
32630        CALL DPWRST('XXX','WRIT')
32631        WRITE(ICOUT,5027)
32632        CALL DPWRST('XXX','WRIT')
32633        WRITE(ICOUT,5039)
32634        CALL DPWRST('XXX','WRIT')
32635      ENDIF
32636C
32637      IF(NHEAD.GE.1)THEN
32638        WRITE(ICOUT,5021)
32639        CALL DPWRST('XXX','WRIT')
32640        ICNTR=0
32641        ICNTA=0
32642        DO100I=1,NHEAD
32643          WRITE(ICOUT,5023)ALIGN(I),VALIGN(I),IWIDTH(I)
32644          CALL DPWRST('XXX','WRIT')
32645C
32646          IF(IFNTSZ.EQ.1)THEN
32647            WRITE(ICOUT,5141)
32648            CALL DPWRST('XXX','WRIT')
32649          ELSEIF(IFNTSZ.EQ.2)THEN
32650            WRITE(ICOUT,5142)
32651            CALL DPWRST('XXX','WRIT')
32652          ELSEIF(IFNTSZ.EQ.-1)THEN
32653            WRITE(ICOUT,5146)
32654            CALL DPWRST('XXX','WRIT')
32655          ELSEIF(IFNTSZ.EQ.-2)THEN
32656            WRITE(ICOUT,5147)
32657            CALL DPWRST('XXX','WRIT')
32658          ENDIF
32659C
32660          IF(ITYPE(I).EQ.'ALPH')THEN
32661            ICNTA=ICNTA+1
32662            NC=NCHAR(ICNTA)
32663            IFORMT='(9X,A  )'
32664            WRITE(IFORMT(6:7),'(I2)')NC
32665            WRITE(ICOUT,IFORMT)IVALUE(ICNTA)(1:NC)
32666            CALL DPWRST('XXX','WRIT')
32667          ELSE
32668            ICNTR=ICNTR+1
32669            IF(NUMDIG(I).GT.0)THEN
32670              IFORMT=' '
32671              IFORMT(1:10)='(9X,F15. )'
32672              WRITE(IFORMT(9:9),'(I1)')MIN(NUMDIG(I),9)
32673              WRITE(ICOUT,IFORMT)AVALUE(ICNTR)
32674              CALL DPWRST('XXX','WRIT')
32675            ELSEIF(NUMDIG(I).EQ.0)THEN
32676              IF(AVALUE(ICNTR).GE.0.0)THEN
32677                WRITE(ICOUT,5033)INT(AVALUE(ICNTR)+0.5)
32678              ELSE
32679                WRITE(ICOUT,5033)INT(AVALUE(ICNTR)-0.5)
32680              ENDIF
32681              CALL DPWRST('XXX','WRIT')
32682            ELSEIF(NUMDIG(I).EQ.-1)THEN
32683              WRITE(ICOUT,5035)
32684              CALL DPWRST('XXX','WRIT')
32685            ELSEIF(NUMDIG(I).EQ.-2)THEN
32686              WRITE(ICOUT,5031)AVALUE(ICNTR)
32687              CALL DPWRST('XXX','WRIT')
32688            ENDIF
32689          ENDIF
32690C
32691          IF(IFNTSZ.EQ.1 .OR. IFNTSZ.EQ.2 .OR.
32692     1       IFNTSZ.EQ.-1 .OR. IFNTSZ.EQ.-2) THEN
32693             WRITE(ICOUT,5149)
32694             CALL DPWRST('XXX','WRIT')
32695          ENDIF
32696C
32697          WRITE(ICOUT,5027)
32698          CALL DPWRST('XXX','WRIT')
32699C
32700  100   CONTINUE
32701        WRITE(ICOUT,5039)
32702        CALL DPWRST('XXX','WRIT')
32703      ENDIF
32704C
32705      IF(IFLAGB)THEN
32706        WRITE(ICOUT,5021)
32707        CALL DPWRST('XXX','WRIT')
32708        WRITE(ICOUT,5041)NHEAD
32709        CALL DPWRST('XXX','WRIT')
32710        WRITE(ICOUT,5043)
32711        CALL DPWRST('XXX','WRIT')
32712        WRITE(ICOUT,5027)
32713        CALL DPWRST('XXX','WRIT')
32714        WRITE(ICOUT,5039)
32715        CALL DPWRST('XXX','WRIT')
32716      ENDIF
32717C
32718      RETURN
32719      END
32720      SUBROUTINE DPHTMV(IHEAD,NHEAD,AVAL,NUMDIG)
32721C
32722C     PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING
32723C              HTML OUTPUT.  THIS ROUTINE IS USED TO WRITE A
32724C              A SINGLE LINE OF OUTPUT.
32725C     INPUT  ARGUMENTS--IHEAD  = THE CHARACTER STRING CONTAINING
32726C                                THE TEXT FOR THE LINE
32727C                     --NHEAD  = THE INTEGER NUMBER THAT SPECIFIES
32728C                                THE NUMBER OF CHARACTERS IN THE
32729C                                LINE.
32730C                     --AVAL   = NUMERIC VALUE TO PRINT.
32731C                     --NUMDIG = NUMBER OF DIGITS TO THE RIGHT OF THE
32732C                                DECIMAL POINT
32733C     WRITTEN BY--ALAN HECKERT
32734C                 STATISTICAL ENGINEERING DIVISION
32735C                 INFORMATION TECHNOLOGY LABOARATORY
32736C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
32737C                 GAITHERSBURG, MD 20899-8980
32738C                 PHONE--301-975-2899
32739C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
32740C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
32741C     LANGUAGE--ANSI FORTRAN (1977)
32742C     VERSION NUMBER--2009/4
32743C     ORIGINAL VERSION--APRIL     2009.
32744C
32745C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
32746C
32747      CHARACTER*(*) IHEAD
32748C
32749      CHARACTER*6  ISTRT
32750      CHARACTER*9  IEND
32751      CHARACTER*30 IFORMT
32752C
32753C---------------------------------------------------------------------
32754C
32755      INCLUDE 'DPCOP2.INC'
32756C
32757C-----START POINT-----------------------------------------------------
32758C
32759      ISTRT='</PRE>'
32760C
32761      IF(NHEAD.GE.1)THEN
32762        IFORMT=' '
32763        IF(AVAL.NE.CPUMIN)THEN
32764          IEND='<BR><PRE>'
32765          IXX=NUMDIG
32766          IYY=IXX+8
32767          IFORMT(1:21)='(A6,A  ,2X,Gyy.xx,A9)'
32768          WRITE(IFORMT(6:7),'(I2)')NHEAD
32769          WRITE(IFORMT(13:14),'(I2)')IYY
32770          WRITE(IFORMT(16:17),'(I2)')IXX
32771          WRITE(ICOUT,IFORMT)ISTRT,IHEAD(1:NHEAD),AVAL,IEND
32772          CALL DPWRST('XXX','WRIT')
32773        ELSE
32774          IEND='<BR><PRE>'
32775          IFORMT(1:11)='(A6,A  ,A9)'
32776          WRITE(IFORMT(6:7),'(I2)')NHEAD
32777          WRITE(ICOUT,IFORMT)ISTRT,IHEAD(1:NHEAD),IEND
32778          CALL DPWRST('XXX','WRIT')
32779        ENDIF
32780      ENDIF
32781C
32782      RETURN
32783      END
32784      SUBROUTINE DPHTMW(IHEAD,NHEAD,AVAL,NUMDIG)
32785C
32786C     PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING
32787C              HTML OUTPUT.  THIS ROUTINE IS USED TO WRITE A
32788C              A SINGLE LINE OF OUTPUT.
32789C
32790C              IT IS SIMILAR TO DPHTMV.  HOWEVER, THE LEADING/TRAILING
32791C              </PRE>/<PRE> CLAUSES ARE NOT INCLUDED (THIS ROUTINE IS
32792C              INTENDED FOR MULTI_LINE TEXT WHERE DPDTXT GENERATES THESE
32793C              ONLY ONCE AT THE BEGINNING AND END OF THE BLOCKS.
32794C
32795C     INPUT  ARGUMENTS--IHEAD  = THE CHARACTER STRING CONTAINING
32796C                                THE TEXT FOR THE LINE
32797C                     --NHEAD  = THE INTEGER NUMBER THAT SPECIFIES
32798C                                THE NUMBER OF CHARACTERS IN THE
32799C                                LINE.
32800C                     --AVAL   = NUMERIC VALUE TO PRINT.
32801C                     --NUMDIG = NUMBER OF DIGITS TO THE RIGHT OF THE
32802C                                DECIMAL POINT
32803C     WRITTEN BY--ALAN HECKERT
32804C                 STATISTICAL ENGINEERING DIVISION
32805C                 INFORMATION TECHNOLOGY LABOARATORY
32806C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
32807C                 GAITHERSBURG, MD 20899-8980
32808C                 PHONE--301-975-2899
32809C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
32810C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
32811C     LANGUAGE--ANSI FORTRAN (1977)
32812C     VERSION NUMBER--2012/1
32813C     ORIGINAL VERSION--JANUARY   2012.
32814C
32815C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
32816C
32817      CHARACTER*(*) IHEAD
32818C
32819      CHARACTER*4  IEND
32820      CHARACTER*30 IFORMT
32821C
32822C---------------------------------------------------------------------
32823C
32824      INCLUDE 'DPCOP2.INC'
32825C
32826C-----START POINT-----------------------------------------------------
32827C
32828      IEND='<BR>'
32829      IF(NHEAD.GE.1)THEN
32830        IFORMT=' '
32831        IF(AVAL.NE.CPUMIN)THEN
32832          IF(NUMDIG.GT.0)THEN
32833            AVALT=RND(AVAL,NUMDIG)
32834            IXX=NUMDIG
32835            IYY=IXX+8
32836            IFORMT(1:18)='(A  ,2X,F  .  ,A4)'
32837            WRITE(IFORMT(3:4),'(I2)')NHEAD
32838            WRITE(IFORMT(10:11),'(I2)')IYY
32839            WRITE(IFORMT(13:14),'(I2)')IXX
32840            WRITE(ICOUT,IFORMT)IHEAD(1:NHEAD),AVALT,IEND
32841            CALL DPWRST('XXX','WRIT')
32842          ELSEIF(NUMDIG.EQ.0)THEN
32843            IF(AVAL.GE.0.0)THEN
32844              IVALT=INT(AVAL + 0.5)
32845            ELSE
32846              IVALT=INT(AVAL - 0.5)
32847            ENDIF
32848            IFORMT(1:15)='(A  ,2X,I10,A4)'
32849            WRITE(IFORMT(3:4),'(I2)')NHEAD
32850            WRITE(ICOUT,IFORMT)IHEAD(1:NHEAD),IVALT,IEND
32851            CALL DPWRST('XXX','WRIT')
32852          ELSEIF(NUMDIG.EQ.-99)THEN
32853            IFORMT(1:14)='(A  ,2X,A2,A4)'
32854            WRITE(IFORMT(3:4),'(I2)')NHEAD
32855            WRITE(ICOUT,IFORMT)IHEAD(1:NHEAD),'**',IEND
32856            CALL DPWRST('XXX','WRIT')
32857          ELSEIF(NUMDIG.EQ.-1)THEN
32858            IFORMT(1:14)='(A  ,2X,A6,A4)'
32859            WRITE(IFORMT(3:4),'(I2)')NHEAD
32860            WRITE(ICOUT,IFORMT)IHEAD(1:NHEAD),'&nbsp;',IEND
32861            CALL DPWRST('XXX','WRIT')
32862          ELSEIF(NUMDIG.LT.-2 .AND. NUMDIG.GT.-20)THEN
32863            NUMDI2=-NUMDIG
32864            AVALT=RND(AVAL,NUMDI2)
32865            IXX=-NUMDIG
32866            IYY=IXX+8
32867            IFORMT(1:18)='(A  ,2X,E  .  ,A4)'
32868            WRITE(IFORMT(3:4),'(I2)')NHEAD
32869            WRITE(IFORMT(10:11),'(I2)')IYY
32870            WRITE(IFORMT(13:14),'(I2)')IXX
32871            WRITE(ICOUT,IFORMT)IHEAD(1:NHEAD),AVALT,IEND
32872            CALL DPWRST('XXX','WRIT')
32873          ENDIF
32874        ELSE
32875          IFORMT(1:8)='(A  ,A4)'
32876          WRITE(IFORMT(3:4),'(I2)')NHEAD
32877          WRITE(ICOUT,IFORMT)IHEAD(1:NHEAD),IEND
32878          CALL DPWRST('XXX','WRIT')
32879        ENDIF
32880      ENDIF
32881C
32882      RETURN
32883      END
32884      SUBROUTINE DPHTMY(IVALUE,NCHAR,AVALUE,NHEAD,ITYPE,
32885     1                  IFLAGA,IFLAGB)
32886C
32887C     PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING
32888C              HTML OUTPUT.  THIS ROUTINE IS USED TO GENERATE
32889C              A DATA ROW THAT MAY CONTAIN A MIXTURE OF NUMERIC
32890C              AND CHARACTER VALUES.
32891C
32892C     INPUT  ARGUMENTS--IVALUE  = AN ARRAY OF CHARACTER STRINGS.
32893C                     --NCHAR   = THE INTEGER ARRAY THAT SPECIFIES
32894C                                 THE NUMBER OF CHARACTERS IN THE
32895C                                 CHARACTER FIELDS.
32896C                     --AVALUE  = A REAL ARRAY CONTAINING THE NUMERIC
32897C                                 FIELDS..
32898C                     --NHEAD   = THE INTEGER VALUE THAT SPECIFIES
32899C                                 THE NUMBER OF FIELDS.
32900C                     --ITYPE   = A CHARACTER ARRAY THAT SPECIFIES
32901C                                 WHICH FIELDS ARE NUMERIC AND
32902C                                 WHICH ARE CHARACTER.
32903C     WRITTEN BY--ALAN HECKERT
32904C                 STATISTICAL ENGINEERING DIVISION
32905C                 INFORMATION TECHNOLOGY LABORATORY
32906C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
32907C                 GAITHERSBURG, MD 20899-8980
32908C                 PHONE--301-975-2899
32909C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
32910C           OF THE NATIONAL BUREAU OF STANDARDS.
32911C     LANGUAGE--ANSI FORTRAN (1977)
32912C     VERSION NUMBER--2009/10
32913C     ORIGINAL VERSION--OCTOBER   2009.
32914C
32915C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
32916C
32917      CHARACTER*(*) IVALUE(*)
32918      CHARACTER*4 ITYPE(*)
32919      REAL AVALUE(*)
32920      INTEGER NCHAR(*)
32921C
32922      LOGICAL IFLAGA
32923      LOGICAL IFLAGB
32924C
32925      PARAMETER (MAXHED=1024)
32926      INTEGER IWIDTH(MAXHED)
32927      INTEGER NUMDIG(MAXHED)
32928      CHARACTER*8 ALIGN(MAXHED)
32929      CHARACTER*8 VALIGN(MAXHED)
32930      COMMON/HTML4/IWIDTH,NUMDIG,ALIGN,VALIGN
32931      COMMON/HTML44/IFNTSZ
32932C
32933      CHARACTER*10 IFORMT
32934C
32935C---------------------------------------------------------------------
32936C
32937      INCLUDE 'DPCOP2.INC'
32938C
32939C-----START POINT-----------------------------------------------------
32940C
32941C  STEP 3: DEFINE A DATA ROW
32942C
32943CC999 FORMAT(1X)
32944C
32945C  GENERATE A DATA LINE
32946C
32947 5021 FORMAT('   <TR>')
32948 5039 FORMAT('   </TR>')
32949 5023 FORMAT('      <TD ALIGN=',A8,' VALIGN=',A8,' WIDTH=',I5,'>')
32950C5024 FORMAT('         <B>')
32951C5025 FORMAT('         </B>')
32952 5027 FORMAT('      </TD>')
32953C5029 FORMAT('      <TD ALIGN=RIGHT VALIGN=BOTTOM>')
32954 5031 FORMAT('         ',G15.7)
32955 5032 FORMAT('         **')
32956 5033 FORMAT('         ',I8)
32957 5035 FORMAT('         &nbsp;')
32958 5141 FORMAT('         <FONT SIZE="+1">')
32959 5142 FORMAT('         <FONT SIZE="+2">')
32960 5146 FORMAT('         <FONT SIZE="-1">')
32961 5147 FORMAT('         <FONT SIZE="-2">')
32962 5149 FORMAT('         </FONT>')
32963C
32964      IF(IFLAGB)THEN
32965        WRITE(ICOUT,5021)
32966        CALL DPWRST('XXX','WRIT')
32967        WRITE(ICOUT,5041)NHEAD
32968 5041   FORMAT('   <TD COLSPAN=',I1,'>')
32969        CALL DPWRST('XXX','WRIT')
32970        WRITE(ICOUT,5043)
32971 5043   FORMAT('   <HR>')
32972        CALL DPWRST('XXX','WRIT')
32973        WRITE(ICOUT,5027)
32974        CALL DPWRST('XXX','WRIT')
32975        WRITE(ICOUT,5039)
32976        CALL DPWRST('XXX','WRIT')
32977      ENDIF
32978C
32979      IF(NHEAD.GE.1)THEN
32980        WRITE(ICOUT,5021)
32981        CALL DPWRST('XXX','WRIT')
32982        ICNT=0
32983        DO100I=1,NHEAD
32984          WRITE(ICOUT,5023)ALIGN(I),VALIGN(I),IWIDTH(I)
32985          CALL DPWRST('XXX','WRIT')
32986C
32987          IF(IFNTSZ.EQ.1)THEN
32988            WRITE(ICOUT,5141)
32989            CALL DPWRST('XXX','WRIT')
32990          ELSEIF(IFNTSZ.EQ.2)THEN
32991            WRITE(ICOUT,5142)
32992            CALL DPWRST('XXX','WRIT')
32993          ELSEIF(IFNTSZ.EQ.-1)THEN
32994            WRITE(ICOUT,5146)
32995            CALL DPWRST('XXX','WRIT')
32996          ELSEIF(IFNTSZ.EQ.-2)THEN
32997            WRITE(ICOUT,5147)
32998            CALL DPWRST('XXX','WRIT')
32999          ENDIF
33000C
33001          IF(ITYPE(I).EQ.'ALPH')THEN
33002            ICNT=ICNT+1
33003            NC=NCHAR(ICNT)
33004            IF(NC.LE.0)THEN
33005              WRITE(ICOUT,5035)
33006              CALL DPWRST('XXX','WRIT')
33007            ELSE
33008              IFORMT='(9X,A  )'
33009              WRITE(IFORMT(6:7),'(I2)')NC
33010              WRITE(ICOUT,IFORMT)IVALUE(ICNT)(1:NC)
33011              CALL DPWRST('XXX','WRIT')
33012            ENDIF
33013          ELSE
33014            ICNT=ICNT+1
33015            IF(NUMDIG(I).GT.0)THEN
33016              IFORMT=' '
33017              IFORMT(1:10)='(9X,F15. )'
33018              WRITE(IFORMT(9:9),'(I1)')MIN(NUMDIG(I),9)
33019              WRITE(ICOUT,IFORMT)AVALUE(ICNT)
33020              CALL DPWRST('XXX','WRIT')
33021            ELSEIF(NUMDIG(I).EQ.0)THEN
33022              IF(AVALUE(ICNT).GE.0.0)THEN
33023                WRITE(ICOUT,5033)INT(AVALUE(ICNT)+0.5)
33024              ELSE
33025                WRITE(ICOUT,5033)INT(AVALUE(ICNT)-0.5)
33026              ENDIF
33027              CALL DPWRST('XXX','WRIT')
33028            ELSEIF(NUMDIG(I).EQ.-1)THEN
33029              WRITE(ICOUT,5035)
33030              CALL DPWRST('XXX','WRIT')
33031            ELSEIF(NUMDIG(I).EQ.-2)THEN
33032              WRITE(ICOUT,5031)AVALUE(ICNT)
33033              CALL DPWRST('XXX','WRIT')
33034            ELSEIF(NUMDIG(I).EQ.-99)THEN
33035              WRITE(ICOUT,5032)
33036              CALL DPWRST('XXX','WRIT')
33037            ELSEIF(NUMDIG(I).LT.-2 .AND. NUMDIG(I).GT.-20)THEN
33038              IFORMT=' '
33039              IFORMT(1:10)='(9X,E15. )'
33040              IVALT=ABS(NUMDIG(I))
33041              IF(IVALT.GT.9)IVALT=9
33042              WRITE(IFORMT(9:9),'(I1)')IVALT
33043              WRITE(ICOUT,IFORMT)AVALUE(ICNT)
33044              CALL DPWRST('XXX','WRIT')
33045            ENDIF
33046          ENDIF
33047C
33048          IF(IFNTSZ.EQ.1 .OR. IFNTSZ.EQ.2 .OR.
33049     1       IFNTSZ.EQ.-1 .OR. IFNTSZ.EQ.-2) THEN
33050             WRITE(ICOUT,5149)
33051             CALL DPWRST('XXX','WRIT')
33052          ENDIF
33053C
33054          WRITE(ICOUT,5027)
33055          CALL DPWRST('XXX','WRIT')
33056C
33057  100   CONTINUE
33058        WRITE(ICOUT,5039)
33059        CALL DPWRST('XXX','WRIT')
33060      ENDIF
33061C
33062      IF(IFLAGA)THEN
33063        WRITE(ICOUT,5021)
33064        CALL DPWRST('XXX','WRIT')
33065        WRITE(ICOUT,5041)NHEAD
33066        CALL DPWRST('XXX','WRIT')
33067        WRITE(ICOUT,5043)
33068        CALL DPWRST('XXX','WRIT')
33069        WRITE(ICOUT,5027)
33070        CALL DPWRST('XXX','WRIT')
33071        WRITE(ICOUT,5039)
33072        CALL DPWRST('XXX','WRIT')
33073      ENDIF
33074C
33075      RETURN
33076      END
33077      SUBROUTINE DPHW(ICOM,IHARG,IARGT,ARG,NUMARG,
33078     1PDEFHE,PDEFWI,
33079     1PTEXHE,PTEXWI,
33080     1IBUGD2,ISUBRO,IFOUND,IERROR)
33081C
33082C     PURPOSE--DEFINE THE HEIGHT AND WIDTH FOR TEXT CHARACTERS.
33083C              THE HEIGHT FOR TEXT CHARACTERS WILL BE PLACED
33084C              IN THE FLOATING POINT VARIABLE HEIGHT.
33085C              THE WIDTH FOR TEXT CHARACTERS WILL BE PLACED
33086C              IN THE FLOATING POINT VARIABLE WIDTH.
33087C     INPUT  ARGUMENTS--ICOM (A CHARACTER VARIABLE).
33088C                     --IHARG  (A  CHARACTER VECTOR)
33089C                     --IARGT
33090C                     --ARG
33091C                     --NUMARG
33092C                     --PDEFHE
33093C                     --PDEFWI
33094C                     --IBUGD2
33095C     OUTPUT ARGUMENTS--PTEXHE
33096C                     --PTEXWI
33097C                     --IFOUND ('YES' OR 'NO' )
33098C                     --IERROR ('YES' OR 'NO' )
33099C     WRITTEN BY--JAMES J. FILLIBEN
33100C                 STATISTICAL ENGINEERING DIVISION
33101C                 INFORMATION TECHNOLOGY LABORATORY
33102C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
33103C                 GAITHERSBURG, MD 20899-8980
33104C                 PHONE--301-975-2855
33105C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
33106C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
33107C     LANGUAGE--ANSI FORTRAN (1977)
33108C     VERSION NUMBER--82/7
33109C     ORIGINAL VERSION--APRIL     1981.
33110C     UPDATED         --MAY       1982.
33111C
33112C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
33113C
33114      CHARACTER*4 ICOM
33115      CHARACTER*4 IHARG
33116      CHARACTER*4 IARGT
33117      CHARACTER*4 IBUGD2
33118      CHARACTER*4 ISUBRO
33119      CHARACTER*4 IFOUND
33120      CHARACTER*4 IERROR
33121C
33122C---------------------------------------------------------------------
33123C
33124      DIMENSION IHARG(*)
33125      DIMENSION IARGT(*)
33126      DIMENSION ARG(*)
33127C
33128C---------------------------------------------------------------------
33129C
33130      INCLUDE 'DPCOP2.INC'
33131C
33132C-----START POINT-----------------------------------------------------
33133C
33134      IFOUND='NO'
33135      IERROR='NO'
33136C
33137      IF(IBUGD2.EQ.'OFF')GOTO90
33138      WRITE(ICOUT,999)
33139  999 FORMAT(1X)
33140      CALL DPWRST('XXX','BUG ')
33141      WRITE(ICOUT,51)
33142   51 FORMAT('***** AT THE BEGINNING OF DPHW--')
33143      CALL DPWRST('XXX','BUG ')
33144      WRITE(ICOUT,52)ICOM
33145   52 FORMAT('ICOM = ',A4)
33146      CALL DPWRST('XXX','BUG ')
33147      WRITE(ICOUT,53)NUMARG,PDEFHE,PDEFWI
33148   53 FORMAT('NUMARG,PDEFHE,PDEFWI = ',I8,2E15.7)
33149      CALL DPWRST('XXX','BUG ')
33150      WRITE(ICOUT,54)PTEXHE,PTEXWI
33151   54 FORMAT('PTEXHE,PTEXWI = ',2E15.7)
33152      CALL DPWRST('XXX','BUG ')
33153      DO55I=1,NUMARG
33154      WRITE(ICOUT,56)I,IHARG(I),IARGT(I),ARG(I)
33155   56 FORMAT('I,IHARG(I),IARGT(I),ARG(I) = ',I8,2X,A4,2X,A4,E15.7)
33156      CALL DPWRST('XXX','BUG ')
33157   55 CONTINUE
33158   90 CONTINUE
33159C
33160C               ***************************************
33161C               **  TREAT THE HEIGHT AND WIDTH CASE  **
33162C               ***************************************
33163C
33164      IF(NUMARG.LE.0)GOTO1150
33165      IF(IHARG(1).EQ.'ON')GOTO1150
33166      IF(IHARG(1).EQ.'OFF')GOTO1150
33167      IF(IHARG(1).EQ.'AUTO')GOTO1150
33168      IF(IHARG(1).EQ.'DEFA')GOTO1150
33169      IF(IHARG(NUMARG).EQ.'?')GOTO8100
33170C
33171      IF(NUMARG.GE.2.AND.
33172     1IARGT(1).EQ.'NUMB'.AND.IARGT(2).EQ.'NUMB')
33173     1GOTO1160
33174C
33175      IERROR='YES'
33176      WRITE(ICOUT,1121)
33177 1121 FORMAT('***** ERROR IN DPHW--')
33178      CALL DPWRST('XXX','BUG ')
33179      WRITE(ICOUT,1122)
33180 1122 FORMAT('      ILLEGAL FORM FOR HW OR WH ',
33181     1'COMMAND.')
33182      CALL DPWRST('XXX','BUG ')
33183      WRITE(ICOUT,1124)
33184 1124 FORMAT('      TEST EXAMPLE TO DEMONSTRATE THE ',
33185     1'PROPER FORM--')
33186      CALL DPWRST('XXX','BUG ')
33187      WRITE(ICOUT,1125)
33188 1125 FORMAT('      SUPPOSE IT IS DESIRED THAT ')
33189      CALL DPWRST('XXX','BUG ')
33190      WRITE(ICOUT,1126)
33191 1126 FORMAT('      THE TEXT CHARACTERS HAVE A HEIGHT OF 5')
33192      CALL DPWRST('XXX','BUG ')
33193      WRITE(ICOUT,1127)
33194 1127 FORMAT('      AND A WIDTH OF 3')
33195      CALL DPWRST('XXX','BUG ')
33196      WRITE(ICOUT,1128)
33197 1128 FORMAT('      (WHERE THE SCREEN UNITS RANGE')
33198      CALL DPWRST('XXX','BUG ')
33199      WRITE(ICOUT,1129)
33200 1129 FORMAT('      FROM 0 TO 100, AND WHERE THE HEIGHT AND WIDTH ')
33201      CALL DPWRST('XXX','BUG ')
33202      WRITE(ICOUT,1130)
33203 1130 FORMAT('      EXCLUDES THE BETWEEN-LINE ')
33204      CALL DPWRST('XXX','BUG ')
33205      WRITE(ICOUT,1131)
33206 1131 FORMAT('     AND BETWEEN-CHARACTER GAP),')
33207      CALL DPWRST('XXX','BUG ')
33208      WRITE(ICOUT,1132)
33209 1132 FORMAT('      THEN THE ALLOWABLE FORMS ARE--')
33210      CALL DPWRST('XXX','BUG ')
33211      WRITE(ICOUT,1133)
33212 1133 FORMAT('      HW 5 3 ')
33213      CALL DPWRST('XXX','BUG ')
33214      WRITE(ICOUT,1134)
33215 1134 FORMAT('      WH 3 5 ')
33216      CALL DPWRST('XXX','BUG ')
33217      GOTO9000
33218C
33219 1150 CONTINUE
33220      PTEXHE=PDEFHE
33221      PTEXWI=PDEFWI
33222      GOTO1180
33223C
33224 1160 CONTINUE
33225      IF(ICOM.EQ.'HW')PTEXHE=ARG(1)
33226      IF(ICOM.EQ.'HW')PTEXWI=ARG(2)
33227      IF(ICOM.EQ.'WH')PTEXWI=ARG(1)
33228      IF(ICOM.EQ.'WH')PTEXHE=ARG(2)
33229      GOTO1180
33230C
33231 1180 CONTINUE
33232      IFOUND='YES'
33233C
33234      IF(IFEEDB.EQ.'OFF')GOTO1189
33235      WRITE(ICOUT,999)
33236      CALL DPWRST('XXX','BUG ')
33237      WRITE(ICOUT,1181)
33238 1181 FORMAT('THE HEIGHT (FOR TEXT CHARACTERS)  ')
33239      CALL DPWRST('XXX','BUG ')
33240      WRITE(ICOUT,1182)PTEXHE
33241 1182 FORMAT('HAS JUST BEEN SET TO ',E15.7)
33242      CALL DPWRST('XXX','BUG ')
33243      WRITE(ICOUT,1183)
33244 1183 FORMAT('THE WIDTH  (FOR TEXT CHARACTERS)  ')
33245      CALL DPWRST('XXX','BUG ')
33246      WRITE(ICOUT,1184)PTEXWI
33247 1184 FORMAT('HAS JUST BEEN SET TO ',E15.7)
33248      CALL DPWRST('XXX','BUG ')
33249 1189 CONTINUE
33250      GOTO9000
33251C
33252C               ********************************************
33253C               **  STEP 81--                             **
33254C               **  TREAT THE    ?    CASE--              **
33255C               **  DUMP OUT CURRENT AND DEFAULT VALUES.  **
33256C               ********************************************
33257C
33258 8100 CONTINUE
33259      IFOUND='YES'
33260      WRITE(ICOUT,999)
33261      CALL DPWRST('XXX','BUG ')
33262      WRITE(ICOUT,8111)PTEXHE
33263 8111 FORMAT('THE CURRENT (TEXT) HEIGHT IS ',E15.7)
33264      CALL DPWRST('XXX','BUG ')
33265      WRITE(ICOUT,8112)PTEXWI
33266 8112 FORMAT('THE CURRENT (TEXT) WIDTH  IS ',E15.7)
33267      CALL DPWRST('XXX','BUG ')
33268      WRITE(ICOUT,999)
33269      CALL DPWRST('XXX','BUG ')
33270      WRITE(ICOUT,8121)PDEFHE
33271 8121 FORMAT('THE DEFAULT (TEXT) HEIGHT IS ',E15.7)
33272      CALL DPWRST('XXX','BUG ')
33273      WRITE(ICOUT,8122)PDEFWI
33274 8122 FORMAT('THE DEFAULT (TEXT) WIDTH  IS ',E15.7)
33275      CALL DPWRST('XXX','BUG ')
33276      GOTO9000
33277C
33278C               *****************
33279C               **  STEP 90--  **
33280C               **  EXIT       **
33281C               *****************
33282C
33283 9000 CONTINUE
33284      IF(IBUGD2.EQ.'OFF')GOTO9090
33285      WRITE(ICOUT,999)
33286      CALL DPWRST('XXX','BUG ')
33287      WRITE(ICOUT,9011)
33288 9011 FORMAT('***** AT THE END       OF DPHW--')
33289      CALL DPWRST('XXX','BUG ')
33290      WRITE(ICOUT,9012)IBUGD2,ISUBRO,IFOUND,IERROR
33291 9012 FORMAT('IBUGD2,ISUBRO,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
33292      CALL DPWRST('XXX','BUG ')
33293      WRITE(ICOUT,9013)PTEXHE,PTEXWI
33294 9013 FORMAT('PTEXHE,PTEXWI = ',2E15.7)
33295      CALL DPWRST('XXX','BUG ')
33296 9090 CONTINUE
33297C
33298      RETURN
33299      END
33300