1      SUBROUTINE DPCIR2(X1,Y1,X2,Y2,
2     1                  IFIG,
3     1                  ILINPA,ILINCO,PLINTH,
4     1                  AREGBA,
5     1                  IREBLI,IREBCO,PREBTH,
6     1                  IREFSW,IREFCO,
7     1                  IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
8     1                  PTEXHE,PTEXWI,PTEXVG,PTEXHG)
9C
10C     PURPOSE--DRAW A CIRCLE WITH ONE END OF THE DIAGONAL AT (X1,Y1)
11C              AND THE OTHER END AT (X2,Y2).
12C     WRITTEN BY--JAMES J. FILLIBEN
13C                 STATISTICAL ENGINEERING DIVISION
14C                 INFORMATION TECHNOLOGY LABORATORY
15C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
16C                 GAITHERSBURG, MD 20899-8980
17C                 PHONE--301-975-2855
18C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
19C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
20C     LANGUAGE--ANSI FORTRAN (1977)
21C     VERSION NUMBER--82/7
22C     ORIGINAL VERSION--APRIL     1981.
23C     UPDATED         --MAY       1982.
24C     UPDATED         --JANUARY   1989. MODIFY CALLS TO DPDRPL (ALAN)
25C     UPDATED         --JANUARY   1989. MODIFY CALL  TO DPFIRE (ALAN)
26C     UPDATED         --FEBRAUARY 1993. USE EQUIVALENCE
27C     UPDATED         --SEPTEMBER 2014. SET CIRCLE CORRECTION <ON/OFF>
28C
29C-----NON-COMMON VARIABLES-------------------------------------
30C
31      CHARACTER*4 IFIG
32      CHARACTER*4 IPATT2
33C
34      CHARACTER*4 ILINPA
35      CHARACTER*4 ILINCO
36C
37      CHARACTER*4 IREBLI
38      CHARACTER*4 IREBCO
39      CHARACTER*4 IREFSW
40      CHARACTER*4 IREFCO
41      CHARACTER*4 IREPTY
42      CHARACTER*4 IREPLI
43      CHARACTER*4 IREPCO
44C
45      CHARACTER*4 IPATT
46      CHARACTER*4 ICOLF
47      CHARACTER*4 ICOLP
48      CHARACTER*4 ICOL
49      CHARACTER*4 IFLAG
50C
51      DIMENSION PX(1000)
52      DIMENSION PY(1000)
53CCCCC DIMENSION PX3(1000)
54CCCCC DIMENSION PY3(1000)
55CCCCC FOLLOWING LINES ADDED FEBRUARY 1994
56      INCLUDE 'DPCOPA.INC'
57      INCLUDE 'DPCOZZ.INC'
58      EQUIVALENCE (GARBAG(1),PX(1))
59      EQUIVALENCE (GARBAG(1001),PY(1))
60CCCCC END CHANGE
61C
62      DIMENSION ILINPA(*)
63      DIMENSION ILINCO(*)
64      DIMENSION PLINTH(*)
65C
66      DIMENSION AREGBA(*)
67      DIMENSION IREBLI(*)
68      DIMENSION IREBCO(*)
69      DIMENSION PREBTH(*)
70      DIMENSION IREFSW(*)
71      DIMENSION IREFCO(*)
72      DIMENSION IREPTY(*)
73      DIMENSION IREPLI(*)
74      DIMENSION IREPCO(*)
75      DIMENSION PREPTH(*)
76      DIMENSION PREPSP(*)
77C
78C-----COMMON----------------------------------------------------------
79C
80      INCLUDE 'DPCOGR.INC'
81      INCLUDE 'DPCOBE.INC'
82      INCLUDE 'DPCOST.INC'
83      INCLUDE 'DPCOP2.INC'
84C
85C-----START POINT-----------------------------------------------------
86C
87      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CIR2')THEN
88        WRITE(ICOUT,999)
89  999   FORMAT(1X)
90        CALL DPWRST('XXX','BUG ')
91        WRITE(ICOUT,51)
92   51   FORMAT('***** AT THE BEGINNING OF DPCIR2--')
93        CALL DPWRST('XXX','BUG ')
94        WRITE(ICOUT,53)X1,Y1,X2,Y2
95   53   FORMAT('X1,Y1,X2,Y2 = ',4G15.7)
96        CALL DPWRST('XXX','BUG ')
97        WRITE(ICOUT,59)IBUGG4,ISUBG4,IERRG4,IFIG
98   59   FORMAT('IBUGG4,ISUBG4,IERRG4,IFIG = ',3(A4,2X),A4)
99        CALL DPWRST('XXX','BUG ')
100        WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1)
101   61   FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',A4,2X,A4,E15.7)
102        CALL DPWRST('XXX','BUG ')
103        WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1),AREGBA(1)
104   63   FORMAT('IREBLI(1),IREBCO(1),PREBTH(1),AREGBA(1) = ',
105     1         2(A4,2X),2G15.7)
106        CALL DPWRST('XXX','BUG ')
107        WRITE(ICOUT,64)IREFSW(1),IREFCO(1)
108   64   FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4)
109        CALL DPWRST('XXX','BUG ')
110        WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1)
111   65   FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ',
112     1         3(A4,2X),2G15.7)
113        CALL DPWRST('XXX','BUG ')
114        WRITE(ICOUT,69)PTEXHE,PTEXWI,PTEXVG,PTEXHG
115   69   FORMAT('PTEXHE,PTEXWI,PTEXVG,PTEXHG= ',4G15.7)
116        CALL DPWRST('XXX','BUG ')
117      ENDIF
118C
119C               *********************************
120C               **  STEP 1--                   **
121C               **  DETERMINE THE COORDINATES  **
122C               **  FOR THE CIRCLE             **
123C               *********************************
124C
125      RATIHV=ANUMHP/ANUMVP
126      IF(ICIRCR.EQ.'OFF')THEN
127        RATIHV=1.0
128      ENDIF
129C
130      DELX=X2-X1
131      DELY=Y2-Y1
132      DELX=ABS(DELX)
133      DELY=ABS(DELY)
134C
135      ALEN=0.0
136      TERM=DELX**2+DELY**2
137      IF(TERM.GT.0.0)ALEN=SQRT(TERM)
138      RADIUS=ALEN/2.0
139C
140      IF(ABS(DELX).GE.0.00001)THETA=ATAN(DELY/DELX)
141      IF(ABS(DELX).LT.0.00001.AND.DELY.GE.0.0)THETA=3.1415926/2.0
142      IF(ABS(DELX).LT.0.00001.AND.DELY.LT.0.0)THETA=-3.1415926/2.0
143      THETA=0.0
144C
145      XCENT=(X1+X2)/2.0
146      YCENT=(Y1+Y2)/2.0
147      X3=XCENT-RADIUS
148      Y3=YCENT
149C
150      K=0
151C
152      X=0.0
153      Y=0.0
154      Y=Y*RATIHV
155      CALL TRANS(X,Y,X3,Y3,THETA,DELX,DELY,XP,YP,KXP,KYP)
156      K=K+1
157      PX(K)=XP
158      PY(K)=YP
159C
160      DO3010I=181,541,5
161        IREV=541-I+181
162        PHI2=IREV-1
163        PHI2=PHI2*(2.0*3.1415926)/360.0
164        X=RADIUS*COS(PHI2)+RADIUS
165        Y=RADIUS*SIN(PHI2)
166        Y=Y*RATIHV
167        CALL TRANS(X,Y,X3,Y3,THETA,DELX,DELY,XP,YP,KXP,KYP)
168        K=K+1
169        PX(K)=XP
170        PY(K)=YP
171 3010 CONTINUE
172C
173      NP=K
174C
175C               ***********************
176C               **  STEP 2--         **
177C               **  FILL THE FIGURE  **
178C               **  (IF CALLED FOR)  **
179C               ***********************
180C
181      IF(IREFSW(1).EQ.'ON')THEN
182        IPATT=IREPTY(1)
183        IPATT2='SOLI'
184        PTHICK=PREPTH(1)
185        PXGAP=PREPSP(1)
186        PYGAP=PREPSP(1)
187        ICOLF=IREFCO(1)
188        ICOLP=IREPCO(1)
189        CALL DPFIRE(PX,PY,NP,
190     1              IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,IPATT2)
191      ENDIF
192C
193C               ***************************
194C               **  STEP 3--             **
195C               **  DRAW OUT THE FIGURE  **
196C               ***************************
197C
198      IPATT=ILINPA(1)
199      PTHICK=PLINTH(1)
200      ICOL=ILINCO(1)
201      IFLAG='ON'
202CCCCC CALL DPDRPL(PX,PY,NP,PX3,PY3,NP3,
203CCCCC1IFIG,IPATT,PTHICK,ICOL)
204      CALL DPDRPL(PX,PY,NP,
205     1            IFIG,IPATT,PTHICK,ICOL,
206     1            JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
207C
208C               *****************
209C               **  STEP 90--  **
210C               **  EXIT       **
211C               *****************
212C
213      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CIR2')THEN
214        WRITE(ICOUT,999)
215        CALL DPWRST('XXX','BUG ')
216        WRITE(ICOUT,9011)
217 9011   FORMAT('***** AT THE END       OF DPCIR2--')
218        CALL DPWRST('XXX','BUG ')
219        WRITE(ICOUT,9012)DELX,DELY,NP
220 9012   FORMAT('DELX,DELY,NP = ',2G15.7,I8)
221        CALL DPWRST('XXX','BUG ')
222        WRITE(ICOUT,9013)XCENT,YCENT,RADIUS,THETA
223 9013   FORMAT('XCENT,YCENT,RADIUS,THETA = ',4G15.7)
224        CALL DPWRST('XXX','BUG ')
225        DO9015I=1,NP
226          WRITE(ICOUT,9016)I,PX(I),PY(I)
227 9016     FORMAT('I,PX(I),PY(I) = ',I8,2G15.7)
228          CALL DPWRST('XXX','BUG ')
229 9015   CONTINUE
230      ENDIF
231C
232      RETURN
233      END
234      SUBROUTINE DPCIRC(IHARG,IARGT,ARG,NUMARG,
235     1                  PXSTAR,PYSTAR,PXEND,PYEND,
236     1                  ILINPA,ILINCO,PLINTH,
237     1                  AREGBA,IREBLI,IREBCO,PREBTH,
238     1                  IREFSW,IREFCO,
239     1                  IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
240     1                  PTEXHE,PTEXWI,PTEXVG,PTEXHG,
241     1                  IGRASW,IDIASW,
242     1                  PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
243     1                  PDIAHE,PDIAWI,PDIAVG,PDIAHG,
244     1                  NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
245     1                  IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
246     1                  IDNVOF,IDNHOF,IDFONT,UNITSW,PDSCAL,
247     1                  IBUGD2,IFOUND,IERROR)
248C
249C     PURPOSE--DRAW ONE OR MORE CIRCLES (DEPENDING ON HOW MANY NUMBERS ARE
250C              PROVIDED).  THE COORDINATES ARE IN STANDARDIZED UNITS
251C              OF 0 TO 100.
252C     NOTE--THE INPUT COORDINATES DEFINE THE ENDS OF THE DIAMETER
253C           OF THE CIRCLE.
254C     NOTE-THE USUAL INPUT NUMBER OF COORDINATES IS 2
255C          AND THEREFORE THE USUAL INPUT NUMBER OF NUMBERS IS 2*2 = 4.
256C     NOTE--IF 2 NUMBERS ARE PROVIDED, THEN THE DRAWN CIRCLE WILL GO
257C           FROM THE LAST CURSOR POSITION TO THE (X,Y) POINT (EITHER ABSOLUTE
258C           OR RELATIVE) AS DEFINED BY THE 2 NUMBERS.
259C     NOTE--IF 4 NUMBERS ARE PROVIDED, THEN THE DRAWN CIRCLE WILL GO
260C           FROM THE ABSOLUTE (X,Y) POSITION AS DEFINED BY THE FIRST 2 NUMBERS
261C           TO THE (X,Y) POINT (EITHER ABSOLUTE OR RELATIVE) AS DEFINED BY
262C           THE THIRD AND FOURTH NUMBERS.
263C     NOTE--IF 6 NUMBERS ARE PROVIDED, THEN THE DRAWN CIRCLE WILL GO
264C           FROM THE (X,Y) POSITION AS RESULTING FROM THE THIRD AND FOURTH
265C           NUMBERS TO THE (X,Y) POINT (EITHER ABSOLUTE OR RELATIVE)
266C           AS DEFINED BY THE FIFTH AND SIXTH NUMBERS.
267C     NOTE--AND SO FORTH FOR 8, 10, 12, ... NUMBERS.
268C     INPUT  ARGUMENTS--IHARG
269C                     --IARGT
270C                     --ARG
271C                     --NUMARG
272C                     --PXSTAR
273C                     --PYSTAR
274C     OUTPUT ARGUMENTS--PXEND
275C                     --PYEND
276C                     --IFOUND ('YES' OR 'NO' )
277C                     --IERROR ('YES' OR 'NO' )
278C     WRITTEN BY--JAMES J. FILLIBEN
279C                 STATISTICAL ENGINEERING DIVISION
280C                 INFORMATION TECHNOLOGY LABORATORY
281C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
282C                 GAITHERSBURG, MD 20899-8980
283C                 PHONE--301-975-2855
284C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
285C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
286C     LANGUAGE--ANSI FORTRAN (1977)
287C     VERSION NUMBER--82/7
288C     ORIGINAL VERSION--APRIL     1981.
289C     UPDATED         --MARCH     1982.
290C     UPDATED         --MAY       1982.
291C     UPDATED         --NOVEMBER  1982.
292C     UPDATED         --JANUARY   1989. CALL LIST FOR OFFSET VAR (ALAN)
293C     UPDATED         --MARCH     1997. SUPPORT FOR DEVICE FONT (ALAN)
294C     UPDATED         --JULY      1997. SUPPORT FOR "DATA" UNITS (ALAN)
295C     UPDATED         --DECEMBER  2018. CHECK FOR DISCRETE, NULL, OR
296C                                       NONE DEVICE
297C     UPDATED         --DECEMBER  2018. SUPPORT FOR "DEVICE ... SCALE"
298C                                       COMMAND
299C
300C-----NON-COMMON VARIABLES-----------------------------------------
301C
302      CHARACTER*4 IHARG
303      CHARACTER*4 IARGT
304C
305      CHARACTER*4 ILINPA
306      CHARACTER*4 ILINCO
307C
308      CHARACTER*4 IREBLI
309      CHARACTER*4 IREBCO
310      CHARACTER*4 IREFSW
311      CHARACTER*4 IREFCO
312      CHARACTER*4 IREPTY
313      CHARACTER*4 IREPLI
314      CHARACTER*4 IREPCO
315C
316      CHARACTER*4 IGRASW
317      CHARACTER*4 IDIASW
318C
319      CHARACTER*4 IDMANU
320      CHARACTER*4 IDMODE
321      CHARACTER*4 IDMOD2
322      CHARACTER*4 IDMOD3
323      CHARACTER*4 IDPOWE
324      CHARACTER*4 IDCONT
325      CHARACTER*4 IDCOLO
326CCCCC ADD FOLLOWING LINE MARCH 1997.
327      CHARACTER*4 IDFONT
328CCCCC ADD FOLLOWING LINE JULY 1997.
329      CHARACTER*4 UNITSW
330C
331      CHARACTER*4 IFOUND
332      CHARACTER*4 IBUGD2
333      CHARACTER*4 IERROR
334      CHARACTER*4 ISUBRO
335C
336      CHARACTER*4 IFIG
337      CHARACTER*4 IBELSW
338      CHARACTER*4 IERASW
339      CHARACTER*4 IBACCO
340      CHARACTER*4 ICOPSW
341      CHARACTER*4 ITYPEO
342C
343      DIMENSION IHARG(*)
344      DIMENSION IARGT(*)
345      DIMENSION ARG(*)
346C
347      DIMENSION ILINPA(*)
348      DIMENSION ILINCO(*)
349      DIMENSION PLINTH(*)
350C
351      DIMENSION AREGBA(*)
352      DIMENSION IREBLI(*)
353      DIMENSION IREBCO(*)
354      DIMENSION PREBTH(*)
355      DIMENSION IREFSW(*)
356      DIMENSION IREFCO(*)
357      DIMENSION IREPTY(*)
358      DIMENSION IREPLI(*)
359      DIMENSION IREPCO(*)
360      DIMENSION PREPTH(*)
361      DIMENSION PREPSP(*)
362      DIMENSION PDSCAL(*)
363C
364      DIMENSION IDMANU(*)
365      DIMENSION IDMODE(*)
366      DIMENSION IDMOD2(*)
367      DIMENSION IDMOD3(*)
368      DIMENSION IDPOWE(*)
369      DIMENSION IDCONT(*)
370      DIMENSION IDCOLO(*)
371CCCCC ADD FOLLOWING LINE MARCH 1997.
372      DIMENSION IDFONT(*)
373      DIMENSION IDNVPP(*)
374      DIMENSION IDNHPP(*)
375      DIMENSION IDUNIT(*)
376C
377      DIMENSION IDNVOF(*)
378      DIMENSION IDNHOF(*)
379C
380C-----COMMON----------------------------------------------------------
381C
382      INCLUDE 'DPCOGR.INC'
383      INCLUDE 'DPCOBE.INC'
384      INCLUDE 'DPCOP2.INC'
385C
386C-----START POINT-----------------------------------------------------
387C
388      IFOUND='NO'
389      IERROR='NO'
390      IERRG4=IERROR
391C
392      ILOCFN=0
393      NUMNUM=0
394C
395      X1=0.0
396      Y1=0.0
397      X2=0.0
398      Y2=0.0
399C
400      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CIRC')GOTO90
401      WRITE(ICOUT,999)
402  999 FORMAT(1X)
403      CALL DPWRST('XXX','BUG ')
404      WRITE(ICOUT,51)
405   51 FORMAT('***** AT THE BEGINNING OF DPCIRC--')
406      CALL DPWRST('XXX','BUG ')
407      WRITE(ICOUT,53)NUMARG
408   53 FORMAT('NUMARG = ',I8)
409      CALL DPWRST('XXX','BUG ')
410      DO55I=1,NUMARG
411      WRITE(ICOUT,56)I,IHARG(I),IARGT(I),ARG(I)
412   56 FORMAT('I,IHARG(I),IARGT(I),ARG(I) = ',I8,2X,A4,2X,A4,E15.7)
413      CALL DPWRST('XXX','BUG ')
414   55 CONTINUE
415      WRITE(ICOUT,57)PXSTAR,PYSTAR
416   57 FORMAT('PXSTAR,PYSTAR = ',2E15.7)
417      CALL DPWRST('XXX','BUG ')
418      WRITE(ICOUT,58)PXEND,PYEND
419   58 FORMAT('PXEND,PYEND = ',2E15.7)
420      CALL DPWRST('XXX','BUG ')
421      WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1)
422   61 FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',A4,2X,A4,E15.7)
423      CALL DPWRST('XXX','BUG ')
424      WRITE(ICOUT,62)AREGBA(1)
425   62 FORMAT('AREGBA(1) = ',E15.7)
426      CALL DPWRST('XXX','BUG ')
427      WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1)
428   63 FORMAT('IREBLI(1),IREBCO(1),PREBTH(1) = ',A4,2X,A4,E15.7)
429      CALL DPWRST('XXX','BUG ')
430      WRITE(ICOUT,64)IREFSW(1),IREFCO(1)
431   64 FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4)
432      CALL DPWRST('XXX','BUG ')
433      WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1)
434   65 FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ',
435     1A4,2X,A4,2X,A4,2E15.7)
436      CALL DPWRST('XXX','BUG ')
437      WRITE(ICOUT,69)PTEXHE,PTEXWI
438   69 FORMAT('PTEXHE,PTEXWI= ',2E15.7)
439      CALL DPWRST('XXX','BUG ')
440      WRITE(ICOUT,70)PTEXVG,PTEXHG
441   70 FORMAT('PTEXVG,PTEXHG= ',2E15.6)
442      CALL DPWRST('XXX','BUG ')
443      WRITE(ICOUT,76)IGRASW,IDIASW
444   76 FORMAT('IGRASW,IDIASW = ',A4,2X,A4)
445      CALL DPWRST('XXX','BUG ')
446      WRITE(ICOUT,77)PGRAXF,PGRAYF,PDIAXC,PDIAYC
447   77 FORMAT('PGRAXF,PGRAYF,PDIAXC,PDIAYC = ',4E15.7)
448      CALL DPWRST('XXX','BUG ')
449      WRITE(ICOUT,78)PDIAHE,PDIAWI,PDIAVG,PDIAHG
450   78 FORMAT('PDIAHE,PDIAWI,PDIAVG,PDIAHG = ',4E15.7)
451      CALL DPWRST('XXX','BUG ')
452      WRITE(ICOUT,80)NUMDEV
453   80 FORMAT('NUMDEV= ',I8)
454      CALL DPWRST('XXX','BUG ')
455      DO81I=1,NUMDEV
456      WRITE(ICOUT,82)IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I)
457   82 FORMAT('IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I) = ',
458     1A4,2X,A4,2X,A4,2X,A4)
459      CALL DPWRST('XXX','BUG ')
460      WRITE(ICOUT,83)IDPOWE(I),IDCONT(I),IDCOLO(I)
461   83 FORMAT('IDPOWE(I),IDCONT(I),IDCOLO(I) = ',
462     1A4,2X,A4,2X,A4)
463      CALL DPWRST('XXX','BUG ')
464      WRITE(ICOUT,84)IDNVPP(I),IDNHPP(I),IDUNIT(I)
465   84 FORMAT('IDNVPP(I),IDNHPP(I),IDUNIT(I) = ',
466     1I8,I8,I8)
467      CALL DPWRST('XXX','BUG ')
468   81 CONTINUE
469      WRITE(ICOUT,87)IFOUND
470   87 FORMAT('IFOUND= ',A4)
471      CALL DPWRST('XXX','BUG ')
472      WRITE(ICOUT,88)IBUGG4,ISUBG4,IERRG4
473   88 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
474      CALL DPWRST('XXX','BUG ')
475      WRITE(ICOUT,89)IBUGD2,IERROR
476   89 FORMAT('IBUGD2,IERROR= ',A4,2X,A4)
477      CALL DPWRST('XXX','BUG ')
478   90 CONTINUE
479C
480      IFIG='CIRC'
481      NUMPT=2
482      NUMPT2=2*NUMPT
483C
484C               ********************************
485C               **  STEP 0--                  **
486C               **  STEP THROUGH EACH DEVICE  **
487C               ********************************
488C
489      IF(NUMDEV.LE.0)GOTO9000
490      DO8000IDEVIC=1,NUMDEV
491C
492      IF(IDPOWE(IDEVIC).EQ.'OFF')GOTO8000
493      IF(IDMANU(IDEVIC).EQ.'OFF')GOTO8000
494      IF(IDMANU(IDEVIC).EQ.'NULL')GOTO8000
495      IF(IDMANU(IDEVIC).EQ.'NONE')GOTO8000
496      IF(IDMANU(IDEVIC).EQ.'DISC')GOTO8000
497C
498      IMANUF=IDMANU(IDEVIC)
499      IMODEL=IDMODE(IDEVIC)
500      IMODE2=IDMOD2(IDEVIC)
501      IMODE3=IDMOD3(IDEVIC)
502      IGCONT=IDCONT(IDEVIC)
503      IGCOLO=IDCOLO(IDEVIC)
504      IGFONT=IDFONT(IDEVIC)
505      NUMVPP=IDNVPP(IDEVIC)
506      NUMHPP=IDNHPP(IDEVIC)
507      ANUMVP=NUMVPP
508      ANUMHP=NUMHPP
509      IOFFSV=IDNVOF(IDEVIC)
510      IOFFSH=IDNHOF(IDEVIC)
511      IGUNIT=IDUNIT(IDEVIC)
512      PCHSCA=PDSCAL(IDEVIC)
513C
514C               ************************************
515C               **  STEP 1--                      **
516C               **  CARRY OUT OPENING OPERATIONS  **
517C               **  ON THE GRAPHICS DEVICES       **
518C               ************************************
519C
520      CALL DPOPDE
521C
522      IBELSW='OFF'
523      NUMRIN=0
524      IERASW='OFF'
525      IBACCO='JUNK'
526C
527      CALL DPOPPL(IGRASW,
528     1IBELSW,NUMRIN,IERASW,
529     1IBACCO)
530C
531C               *****************************************
532C               **  STEP 2--                           **
533C               **  SEARCH FOR COMMAND SPECIFICATIONS  **
534C               *****************************************
535C
536      IF(NUMARG.GE.2.AND.
537     1IARGT(1).EQ.'NUMB'.AND.IARGT(2).EQ.'NUMB')
538     1GOTO1111
539      IF(NUMARG.GE.3.AND.IHARG(1).EQ.'ABSO'.AND.
540     1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB')
541     1GOTO1112
542      IF(NUMARG.GE.3.AND.IHARG(1).EQ.'RELA'.AND.
543     1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB')
544     1GOTO1113
545      GOTO1130
546C
547 1111 CONTINUE
548      ITYPEO='ABSO'
549      ILOCFN=1
550      GOTO1119
551C
552 1112 CONTINUE
553      ITYPEO='ABSO'
554      ILOCFN=2
555      GOTO1119
556C
557 1113 CONTINUE
558      ITYPEO='RELA'
559      ILOCFN=2
560      GOTO1119
561 1119 CONTINUE
562C
563      IF(ILOCFN.GT.NUMARG)GOTO1129
564      DO1120I=ILOCFN,NUMARG
565      IF(IARGT(I).EQ.'NUMB')GOTO1120
566      GOTO1129
567 1120 CONTINUE
568      IFOUND='YES'
569      GOTO1149
570 1129 CONTINUE
571      GOTO1130
572C
573 1130 CONTINUE
574      IERRG4='YES'
575      WRITE(ICOUT,1131)
576 1131 FORMAT('***** ERROR IN DPCIRC--')
577      CALL DPWRST('XXX','BUG ')
578      WRITE(ICOUT,1132)
579 1132 FORMAT('      ILLEGAL FORM FOR CIRCLE ',
580     1'COMMAND.')
581      CALL DPWRST('XXX','BUG ')
582      WRITE(ICOUT,1134)
583 1134 FORMAT('      TEST EXAMPLE TO DEMONSTRATE THE ',
584     1'PROPER FORM--')
585      CALL DPWRST('XXX','BUG ')
586      WRITE(ICOUT,1135)
587 1135 FORMAT('      SUPPOSE IT IS DESIRED TO DRAW A CIRCLE ')
588      CALL DPWRST('XXX','BUG ')
589      WRITE(ICOUT,1136)
590 1136 FORMAT('      WITH ONE END OF A DIAGONAL AT 20 20 ')
591      CALL DPWRST('XXX','BUG ')
592      WRITE(ICOUT,1137)
593 1137 FORMAT('      AND THE OTHER END OF THE DIAGONAL AT 40 60,')
594      CALL DPWRST('XXX','BUG ')
595      WRITE(ICOUT,1141)
596 1141 FORMAT('      THEN ALLOWABLE FORMS ARE--')
597      CALL DPWRST('XXX','BUG ')
598      WRITE(ICOUT,1142)
599 1142 FORMAT('      CIRCLE 20 20 40 60')
600      CALL DPWRST('XXX','BUG ')
601      WRITE(ICOUT,1143)
602 1143 FORMAT('      CIRCLE ABSOLUTE 20 20 40 60')
603      CALL DPWRST('XXX','BUG ')
604      GOTO9000
605 1149 CONTINUE
606C
607C               ****************************
608C               **  STEP 3--              **
609C               **  DRAW OUT THE LINE(S)  **
610C               ****************************
611C
612      NUMNUM=NUMARG-ILOCFN+1
613      IF(NUMNUM.LT.NUMPT2)GOTO1151
614      GOTO1152
615C
616 1151 CONTINUE
617      J=ILOCFN-1
618      X1=PXSTAR
619      Y1=PYSTAR
620      GOTO1159
621C
622 1152 CONTINUE
623      J=ILOCFN
624      IF(J.GT.NUMARG)GOTO1190
625      X1=ARG(J)
626CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997
627      IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X1,X1,IBUGD2,ISUBRO,IERROR)
628      J=J+1
629      IF(J.GT.NUMARG)GOTO1190
630      Y1=ARG(J)
631CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997
632      IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y1,Y1,IBUGD2,ISUBRO,IERROR)
633      GOTO1159
634C
635 1159 CONTINUE
636C
637 1160 CONTINUE
638      J=J+1
639      IF(J.GT.NUMARG)GOTO1190
640      X2=ARG(J)
641CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997
642      IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X2,X2,IBUGD2,ISUBRO,IERROR)
643      IF(ITYPEO.EQ.'RELA')X2=X1+X2
644      J=J+1
645      IF(J.GT.NUMARG)GOTO1190
646      Y2=ARG(J)
647CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997
648      IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y2,Y2,IBUGD2,ISUBRO,IERROR)
649      IF(ITYPEO.EQ.'RELA')Y2=Y1+Y2
650C
651      CALL DPCIR2(X1,Y1,X2,Y2,
652     1IFIG,
653     1ILINPA,ILINCO,PLINTH,
654     1AREGBA,
655     1IREBLI,IREBCO,PREBTH,
656     1IREFSW,IREFCO,
657     1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
658     1PTEXHE,PTEXWI,PTEXVG,PTEXHG)
659C
660      X1=X2
661      Y1=Y2
662C
663      GOTO1160
664 1190 CONTINUE
665C
666      PXEND=X2
667      PYEND=Y2
668C
669C               ************************************
670C               **  STEP 4--                      **
671C               **  CARRY OUT CLOSING OPERATIONS  **
672C               **  ON THE GRAPHICS DEVICES       **
673C               ************************************
674C
675      ICOPSW='OFF'
676      NUMCOP=0
677      CALL DPCLPL(ICOPSW,NUMCOP,
678     1PGRAXF,PGRAYF,
679     1IGRASW,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
680     1PDIAHE,PDIAWI,PDIAVG,PDIAHG)
681C
682      CALL DPCLDE
683C
684 8000 CONTINUE
685C
686C               *****************
687C               **  STEP 90--  **
688C               **  EXIT       **
689C               *****************
690C
691 9000 CONTINUE
692      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CIRC')GOTO9090
693      WRITE(ICOUT,999)
694      CALL DPWRST('XXX','BUG ')
695      WRITE(ICOUT,9011)
696 9011 FORMAT('***** AT THE END       OF DPCIRC--')
697      CALL DPWRST('XXX','BUG ')
698      WRITE(ICOUT,9012)ILOCFN,NUMNUM
699 9012 FORMAT('ILOCFN,NUMNUM = ',2I8)
700      CALL DPWRST('XXX','BUG ')
701      WRITE(ICOUT,9013)X1,Y1,X2,Y2
702 9013 FORMAT('X1,Y1,X2,Y2 = ',4E15.7)
703      CALL DPWRST('XXX','BUG ')
704      WRITE(ICOUT,9015)PXSTAR,PYSTAR
705 9015 FORMAT('PXSTAR,PYSTAR = ',2E15.7)
706      CALL DPWRST('XXX','BUG ')
707      WRITE(ICOUT,9016)PXEND,PYEND
708 9016 FORMAT('PXEND,PYEND = ',2E15.7)
709      CALL DPWRST('XXX','BUG ')
710      WRITE(ICOUT,9017)IFIG
711 9017 FORMAT('IFIG = ',A4)
712      CALL DPWRST('XXX','BUG ')
713      WRITE(ICOUT,9027)IFOUND
714 9027 FORMAT('IFOUND = ',A4)
715      CALL DPWRST('XXX','BUG ')
716      WRITE(ICOUT,9028)IBUGG4,ISUBG4,IERRG4
717 9028 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4)
718      CALL DPWRST('XXX','BUG ')
719      WRITE(ICOUT,9029)IBUGD2,IERROR
720 9029 FORMAT('IBUGD2,IERROR = ',A4,2X,A4)
721      CALL DPWRST('XXX','BUG ')
722 9090 CONTINUE
723C
724      RETURN
725      END
726      SUBROUTINE DPCKEL(ISUBRO,IBUGA3,IERROR)
727C
728C     PURPOSE--CHECK IF THE ARGUMENTS SPECIFIED ON THE COMMAND ARE
729C              ALL VARIABLES OF EQUAL LENGTH.
730C     EXAMPLE--LET IFLAG = CHECK EQUAL LENGTH S1 S2 S3
731C     WRITTEN BY--ALAN HECKERT
732C                 STATISTICAL ENGINEERING DIVISION
733C                 INFORMATION TECHNOLOGY LABORATORY
734C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
735C                 GAITHERSBURG, MD 20899-8980
736C                 PHONE--301-975-2899
737C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
738C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
739C     LANGUAGE--ANSI FORTRAN (1977)
740C     VERSION NUMBER--2015/03
741C     ORIGINAL VERSION--MARCH     2015.
742C     UPDATED         --FEBRUARY  2018. CHECK LENGTH OUTPUT
743C                                             <FILLIBEN/DEFAULT>
744C
745C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
746C
747      CHARACTER*4 ISUBRO
748      CHARACTER*4 IBUGA3
749      CHARACTER*4 IERROR
750C
751      CHARACTER*4 NEWNAM
752      CHARACTER*4 NEWCOL
753      CHARACTER*4 ICASEL
754      CHARACTER*4 IHLEFT
755      CHARACTER*4 IHLEF2
756      CHARACTER*4 IHRIGH
757      CHARACTER*4 IHRIG2
758C
759      CHARACTER*4 IFOUND
760      CHARACTER*4 ISUBN1
761      CHARACTER*4 ISUBN2
762      CHARACTER*4 ISTEPN
763C
764      CHARACTER*8 ISTR
765      CHARACTER*1 IQUOTE
766C
767      CHARACTER*4 ICASTO
768      CHARACTER*4 IHP
769      CHARACTER*4 IHP2
770      CHARACTER*4 IHWUSE
771      CHARACTER*4 MESSAG
772C
773      PARAMETER(MAXIND=100)
774      CHARACTER*4 IVARN1(MAXIND)
775      CHARACTER*4 IVARN2(MAXIND)
776C
777C---------------------------------------------------------------------
778C
779C-----COMMON----------------------------------------------------------
780C
781      INCLUDE 'DPCOPA.INC'
782      INCLUDE 'DPCOHK.INC'
783      INCLUDE 'DPCODA.INC'
784      INCLUDE 'DPCOST.INC'
785C
786      CHARACTER (LEN=MAXFNC) :: IMANAM(10)
787      COMMON/IMAC/IMACNU,IMALEV,IMANAM
788C
789C-----COMMON VARIABLES (GENERAL)--------------------------------------
790C
791      INCLUDE 'DPCOP2.INC'
792C
793C-----START POINT-----------------------------------------------------
794C
795      ISUBN1='DPCK'
796      ISUBN2='EL  '
797      IERROR='NO'
798      ICASTO='OFF'
799      IQUOTE="'"
800      ILOC3=0
801      ICOLL=0
802      ILISTL=0
803      NIOLD=0
804C
805      MAXCP1=MAXCOL+1
806      MAXCP2=MAXCOL+2
807      MAXCP3=MAXCOL+3
808      MAXCP4=MAXCOL+4
809      MAXCP5=MAXCOL+5
810      MAXCP6=MAXCOL+6
811C
812C
813      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CKEL')THEN
814        WRITE(ICOUT,999)
815        CALL DPWRST('XXX','BUG ')
816        WRITE(ICOUT,51)
817   51   FORMAT('***** AT THE BEGINNING OF DPCKEL--')
818        CALL DPWRST('XXX','BUG ')
819        WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMNAM,NUMCHF,MAXCHF
820   52   FORMAT('IBUGA3,ISUBRO,NUMNAM,NUMCHF,MAXCHF = ',2(A4,2X),3I8)
821        CALL DPWRST('XXX','BUG ')
822        DO55I=1,NUMNAM
823          WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),
824     1                   IVSTOP(I)
825   56     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
826     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
827          CALL DPWRST('XXX','BUG ')
828   55   CONTINUE
829      ENDIF
830C
831C               **********************************
832C               **  STEP 1--                    **
833C               **  INITIALIZE SOME VARIABLES.  **
834C               **********************************
835C
836      ISTEPN='1'
837      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CKEL')
838     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
839C
840      NEWNAM='NO'
841      NEWCOL='NO'
842      ICASEL='UNKN'
843C
844C               ******************************************************
845C               **  STEP 2--                                         *
846C               **  EXAMINE THE LEFT-HAND SIDE--                     *
847C               **  IF THIS IS A PREVIOUSLY DEFINED NAME, IT SHOULD  *
848C               **  BE A PARAMETER (IF NOT, REPORT AN ERROR).        *
849C               ******************************************************
850C
851      ISTEPN='2'
852      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CKEL')
853     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
854C
855      IHLEFT=IHARG(1)
856      IHLEF2=IHARG2(1)
857C
858      DO1910I=1,4
859        IF(IHLEFT(I:I).EQ.'(')THEN
860          IHLEFT(I:4)=' '
861          IHLEF2=' '
862          ICASEL='ELEM'
863          GOTO1999
864        ENDIF
865 1910 CONTINUE
866      DO1920I=1,4
867        IF(IHLEF2(I:I).EQ.'(')THEN
868          IHLEF2(I:4)=' '
869          ICASEL='ELEM'
870          GOTO1999
871        ENDIF
872 1920 CONTINUE
873 1999 CONTINUE
874C
875      DO2000I=1,NUMNAM
876        I2=I
877        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
878          IF(IUSE(I2).EQ.'P')THEN
879            ICASEL='PARA'
880            ILISTL=I2
881            GOTO2900
882          ELSEIF(IUSE(I2).EQ.'V')THEN
883            ICASEL='ELEM'
884            ILISTL=I2
885            ICOLL=IVALUE(ILISTL)
886            NIOLD=IN(ILISTL)
887            GOTO2900
888          ELSE
889            WRITE(ICOUT,999)
890  999       FORMAT(1X)
891            CALL DPWRST('XXX','BUG ')
892            WRITE(ICOUT,2001)
893 2001       FORMAT('***** ERROR IN CHECK EQUAL NAME--')
894            CALL DPWRST('XXX','BUG ')
895            WRITE(ICOUT,2003)IHLEFT,IHLEF2
896 2003       FORMAT('      THE NAME ON THE LEFT HAND SIDE (',
897     1             A4,A4,')')
898            CALL DPWRST('XXX','BUG ')
899            WRITE(ICOUT,2005)
900 2005       FORMAT('      ALREADY EXISTS, BUT NOT AS A PARAMETER.')
901            CALL DPWRST('XXX','BUG ')
902            IERROR='YES'
903            GOTO9000
904          ENDIF
905        ENDIF
906 2000 CONTINUE
907C
908      NEWNAM='YES'
909      IF(ICASEL.EQ.'UNKN')ICASEL='PARA'
910C
911      ILISTL=NUMNAM+1
912      IF(ILISTL.GT.MAXNAM)THEN
913        WRITE(ICOUT,999)
914        CALL DPWRST('XXX','BUG ')
915        WRITE(ICOUT,2001)
916        CALL DPWRST('XXX','BUG ')
917        WRITE(ICOUT,2202)
918 2202   FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND ',
919     1         'FUNCTION')
920        CALL DPWRST('XXX','BUG ')
921        WRITE(ICOUT,2203)MAXNAM
922 2203   FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
923        CALL DPWRST('XXX','BUG ')
924        WRITE(ICOUT,2204)
925 2204   FORMAT('      ENTER      STATUS')
926        CALL DPWRST('XXX','BUG ')
927        WRITE(ICOUT,2205)
928 2205   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES, AND')
929        CALL DPWRST('XXX','BUG ')
930        WRITE(ICOUT,2206)
931 2206   FORMAT('      THEN REDEFINE OR DELETE SOME OF THE ALREADY ',
932     1         'USED NAMES.')
933        CALL DPWRST('XXX','BUG ')
934        IERROR='YES'
935        GOTO9000
936      ENDIF
937C
938 2900 CONTINUE
939C
940C               *****************************************************
941C               **  STEP 3--                                       **
942C               **  EXTRACT THE NAMES ON THE RIGHT HAND SIDE       **
943C               *****************************************************
944C
945      ISTEPN='3'
946      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CKEL')
947     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
948C
949      IFRST=6
950      IF(NUMARG.LT.IFRST)THEN
951        IFLAG=-1
952        GOTO3900
953      ENDIF
954      IFLAG=1
955C
956      JMIN=IFRST
957      JMAX=NUMARG
958      CALL EXTVA3(IHARG,IHARG2,NUMARG,JMIN,JMAX,MAXIND,
959     1            IHNAME,IHNAM2,NUMNAM,
960     1            IVARN1,IVARN2,NUMIND,
961     1            IBUGA3,ISUBRO,IERROR)
962      IERROR='NO'
963C
964      DO3010II=1,NUMIND
965        IHRIGH=IVARN1(II)
966        IHRIG2=IVARN2(II)
967C
968        DO3020I=1,NUMNAM
969          I4=I
970          IF(IHRIGH.EQ.IHNAME(I).AND.IHRIG2.EQ.IHNAM2(I))THEN
971            IF(IUSE(I4).NE.'V')THEN
972              WRITE(ICOUT,999)
973              CALL DPWRST('XXX','BUG ')
974              WRITE(ICOUT,2001)
975              CALL DPWRST('XXX','BUG ')
976              WRITE(ICOUT,3003)IHRIGH,IHRIG2
977 3003         FORMAT('      THE NAME ON THE RIGHT HAND SIDE (',
978     1               A4,A4,')')
979              CALL DPWRST('XXX','BUG ')
980              WRITE(ICOUT,3005)
981 3005         FORMAT('      ALREADY EXISTS, BUT NOT AS A VARIABLE.')
982              CALL DPWRST('XXX','BUG ')
983              IFLAG=0
984            ELSE
985              IF(II.EQ.1)THEN
986                NSIZE=IN(I4)
987              ELSE
988                NTEMP=IN(I4)
989                IF(NTEMP.NE.NSIZE)THEN
990                  IFLAG=0
991                  WRITE(ICOUT,999)
992                  CALL DPWRST('XXX','BUG ')
993                  WRITE(ICOUT,2001)
994                  CALL DPWRST('XXX','BUG ')
995                  IF(ICHKLE.EQ.'DEFA')THEN
996                    WRITE(ICOUT,3013)IVARN1(II),IVARN2(II),
997     1                               IVARN1(1),IVARN2(1)
998 3013               FORMAT('      VARIABLE ',2A4,' IS NOT OF THE ',
999     1                     'SAME LENGTH AS ',2A4)
1000                    CALL DPWRST('XXX','BUG ')
1001                  ELSE
1002C
1003C                   CHECK FOR "HTMLSW" PARAMETER
1004C                   CHECK FOR "IBATCH" PARAMETER
1005C
1006C                   IF THIS IS SET TO 1, JIM HAS SOME SPECIAL CODE
1007C                   FOR PYTHON BASED INTERFACE.  SO HERE, JUST SET
1008C                   IFLAG TO -1.
1009C
1010                    IHP='HTML'
1011                    IHP2='SW  '
1012                    IHWUSE='P'
1013                    MESSAG='NO'
1014                    CALL CHECKN(IHP,IHP2,IHWUSE,
1015     1                          IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,
1016     1                          NUMNAM,MAXNAM,
1017     1                          ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,
1018     1                          ILOCP,IERROR)
1019                    IHTML=0
1020                    IF(IERROR.EQ.'NO')IHTML=INT(VALUE(ILOCP)+0.5)
1021                    IF(IHTML.NE.1)IHTML=0
1022C
1023                    IHP='IBAT'
1024                    IHP2='CH  '
1025                    IHWUSE='P'
1026                    MESSAG='NO'
1027                    CALL CHECKN(IHP,IHP2,IHWUSE,
1028     1                          IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,
1029     1                          NUMNAM,MAXNAM,
1030     1                          ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,
1031     1                          ILOCP,IERROR)
1032                    IBATCH=0
1033                    IF(IERROR.EQ.'NO')IBATCH=INT(VALUE(ILOCP)+0.5)
1034                    IF(IBATCH.NE.1)IBATCH=0
1035                    IERROR='NO'
1036C
1037                    IF(IHTML.EQ.1)THEN
1038                      IFLAG=-1
1039                      WRITE(ICOUT,999)
1040                      CALL DPWRST('XXX','BUG ')
1041                      WRITE(ICOUT,3026)
1042                      CALL DPWRST('XXX','BUG ')
1043C
1044                      IF(IMACNU.NE.5)THEN
1045                        WRITE(ICOUT,3031)IMANAM(IMALEV)
1046                        CALL DPWRST('XXX','BUG ')
1047                      ELSE
1048                        WRITE(ICOUT,3032)
1049                        CALL DPWRST('XXX','BUG ')
1050                      ENDIF
1051                      WRITE(ICOUT,3013)IVARN1(II),IVARN2(II),
1052     1                                 IVARN1(1),IVARN2(1)
1053                      CALL DPWRST('XXX','BUG ')
1054                      WRITE(ICOUT,999)
1055                      CALL DPWRST('XXX','BUG ')
1056                      WRITE(ICOUT,3120)
1057 3120                 FORMAT('       1. Close this error-message ',
1058     1                       'window (via X-out)')
1059                      CALL DPWRST('XXX','BUG ')
1060                      WRITE(ICOUT,3122)
1061 3122                 FORMAT('       2. Terminate the Dataplot run ',
1062     1                       '(via Ctrl-C)')
1063                      CALL DPWRST('XXX','BUG ')
1064                      WRITE(ICOUT,3124)IQUOTE
1065 3124                 FORMAT('       3. Edit Dataplot',A1,
1066     1                       's main routine to correctly define ',
1067     1                       'the variable.')
1068                      CALL DPWRST('XXX','BUG ')
1069                      WRITE(ICOUT,3128)
1070 3128                 FORMAT('       4. Rerun Dataplot')
1071                      CALL DPWRST('XXX','BUG ')
1072                      WRITE(ICOUT,3026)
1073                      CALL DPWRST('XXX','BUG ')
1074                      CALL DPPAUS(IBUGA3,IFOUND,IERROR)
1075C
1076                    ELSE
1077C
1078                      WRITE(ICOUT,999)
1079                      CALL DPWRST('XXX','BUG ')
1080                      WRITE(ICOUT,3026)
1081 3026                 FORMAT('===============================',
1082     1                       '=========')
1083                      CALL DPWRST('XXX','BUG ')
1084C
1085                      IF(IMACNU.NE.5)THEN
1086                        WRITE(ICOUT,3031)IMANAM(IMALEV)
1087 3031                   FORMAT('Error--Macro ',A80)
1088                        CALL DPWRST('XXX','BUG ')
1089                      ELSE
1090                        WRITE(ICOUT,3032)
1091 3032                   FORMAT('Error--From terminal')
1092                        CALL DPWRST('XXX','BUG ')
1093                      ENDIF
1094                      WRITE(ICOUT,3013)IVARN1(II),IVARN2(II),
1095     1                                IVARN1(1),IVARN2(1)
1096                      CALL DPWRST('XXX','BUG ')
1097                    ENDIF
1098                    IF(IBATCH.EQ.0)THEN
1099                      WRITE(ICOUT,3058)
1100 3058                 FORMAT('        Click  Enter  to continue ...')
1101                      CALL DPWRST('XXX','BUG ')
1102                      WRITE(ICOUT,3026)
1103                      CALL DPWRST('XXX','BUG ')
1104                      WRITE(ICOUT,999)
1105                      CALL DPWRST('XXX','BUG ')
1106                      CALL DPPAUS(IBUGA3,IFOUND,IERROR)
1107                    ELSE
1108                      WRITE(ICOUT,3026)
1109                      CALL DPWRST('XXX','BUG ')
1110                      WRITE(ICOUT,999)
1111                      CALL DPWRST('XXX','BUG ')
1112                    ENDIF
1113                  ENDIF
1114                ENDIF
1115              ENDIF
1116            ENDIF
1117            GOTO3029
1118          ENDIF
1119 3020   CONTINUE
1120C
1121        IFLAG=0
1122        WRITE(ICOUT,999)
1123        CALL DPWRST('XXX','BUG ')
1124        WRITE(ICOUT,2001)
1125        CALL DPWRST('XXX','BUG ')
1126        WRITE(ICOUT,3023)IHRIGH,IHRIG2
1127 3023   FORMAT('      NAME ',2A4,' WAS NOT FOUND IN THE CURRENT NAME ',
1128     1         'LIST.')
1129        CALL DPWRST('XXX','BUG ')
1130C
1131 3029   CONTINUE
1132 3010 CONTINUE
1133C
1134 3900 CONTINUE
1135C
1136C               *****************************************************
1137C               **  STEP 4--                                       **
1138C               **  SAVE PARAMETER                                 **
1139C               *****************************************************
1140C
1141      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CKEL')THEN
1142        ISTEPN='4'
1143        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1144        WRITE(ICOUT,4013)ICASEL
1145 4013   FORMAT('ICASEL = ',A4)
1146        CALL DPWRST('XXX','BUG ')
1147      ENDIF
1148C
1149      IF(ICASEL.EQ.'PARA')THEN
1150C
1151        ISTEPN='4A'
1152        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CKEL')
1153     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1154C
1155        IHNAME(ILISTL)=IHLEFT
1156        IHNAM2(ILISTL)=IHLEF2
1157        IUSE(ILISTL)='P'
1158        VALUE(ILISTL)=REAL(IFLAG)
1159        IVALUE(ILISTL)=IFLAG
1160        IN(ILISTL)=1
1161        IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1
1162      ELSEIF(ICASEL.EQ.'ELEM')THEN
1163C
1164C       SEARCH IANS STRING FOR "(xx) =".  IF NO PARENTHESIS
1165C       FOUND BEFORE "=", THEN DO NOT KNOW WHAT ROW OF THE
1166C       VARIABLE TO SAVE.  TREAT THIS AS AN ERROR.
1167C
1168        NLEFT=-1
1169        NRIGHT=-1
1170        NEQUAL=-1
1171        DO4201I=1,IWIDTH
1172          IF(IANS(I)(1:1).EQ.'(' .AND. NLEFT.LT.0)THEN
1173            NLEFT=I
1174          ELSEIF(IANS(I)(1:1).EQ.')' .AND. NRIGHT.LT.0)THEN
1175            NRIGHT=I
1176          ELSEIF(IANS(I)(1:1).EQ.'=' .AND. NEQUAL.LT.0)THEN
1177            NEQUAL=I
1178          ENDIF
1179 4201   CONTINUE
1180C
1181C       NEED  NLEFT < NRIGHT < NEQUAL
1182C
1183        NSTRT=NLEFT+1
1184        NSTOP=NRIGHT-1
1185        NLEN=NSTOP-NSTRT+1
1186        IF(NLEFT.GT.NRIGHT .OR. NRIGHT.GT.NEQUAL .OR.
1187     1     NSTRT.GT.NSTOP .OR. NLEN.GT.8) THEN
1188          WRITE(ICOUT,999)
1189          CALL DPWRST('XXX','BUG ')
1190          WRITE(ICOUT,2001)
1191          CALL DPWRST('XXX','BUG ')
1192          WRITE(ICOUT,4211)
1193 4211     FORMAT('      UNRECOGNIZED SYNTAX FOR VARIABLE ELEMENT ON ',
1194     1           'LEFT HAND SIDE EQUAL SIGN.')
1195          CALL DPWRST('XXX','BUG ')
1196          IERROR='YES'
1197          GOTO9000
1198        ELSE
1199          ISTR=' '
1200          DO4216I=1,NLEN
1201            ISTR(I:I)=IANS(NSTRT+I-1)(1:1)
1202 4216     CONTINUE
1203          READ(ISTR,'(I8)',ERR=4218)IARGL
1204          GOTO4219
1205C
1206 4218     CONTINUE
1207          WRITE(ICOUT,999)
1208          CALL DPWRST('XXX','BUG ')
1209          WRITE(ICOUT,2001)
1210          CALL DPWRST('XXX','BUG ')
1211          WRITE(ICOUT,4211)
1212          CALL DPWRST('XXX','BUG ')
1213          IERROR='YES'
1214          GOTO9000
1215C
1216 4219     CONTINUE
1217        ENDIF
1218C
1219        IF(IARGL.LT.1 .OR. IARGL.GT.MAXN)THEN
1220          WRITE(ICOUT,999)
1221          CALL DPWRST('XXX','BUG ')
1222          WRITE(ICOUT,2001)
1223          CALL DPWRST('XXX','BUG ')
1224          WRITE(ICOUT,4231)IARGL,ILEFT
1225 4231     FORMAT('      THE SPECIFIED ROW (',I8,') OF VARIABLE ',A4,A4)
1226          CALL DPWRST('XXX','BUG ')
1227          WRITE(ICOUT,4233)
1228 4233     FORMAT('      WAS LESS THAN 1 OR GREATER THAN THE')
1229          CALL DPWRST('XXX','BUG ')
1230          WRITE(ICOUT,4235)MAXN
1231 4235     FORMAT('      MAXIMUM ALLOWABLE ',I8)
1232          CALL DPWRST('XXX','BUG ')
1233          IERROR='YES'
1234          GOTO9000
1235        ENDIF
1236C
1237        IF(NEWNAM.EQ.'YES')THEN
1238          NIOLD=1
1239        ENDIF
1240        NINEW=NIOLD
1241        IF(IARGL.GT.NINEW)NINEW=IARGL
1242        NS2=1
1243C
1244        RIGHT=REAL(IFLAG)
1245        IJ=MAXN*(ICOLL-1)+IARGL
1246        IF(ICOLL.LE.MAXCOL)V(IJ)=RIGHT
1247        IF(ICOLL.EQ.MAXCP1)PRED(IARGL)=RIGHT
1248        IF(ICOLL.EQ.MAXCP2)RES(IARGL)=RIGHT
1249        IF(ICOLL.EQ.MAXCP3)YPLOT(IARGL)=RIGHT
1250        IF(ICOLL.EQ.MAXCP4)XPLOT(IARGL)=RIGHT
1251        IF(ICOLL.EQ.MAXCP5)X2PLOT(IARGL)=RIGHT
1252        IF(ICOLL.EQ.MAXCP6)TAGPLO(IARGL)=RIGHT
1253C
1254        IHNAME(ILISTL)=IHLEFT
1255        IHNAM2(ILISTL)=IHLEF2
1256        IUSE(ILISTL)='V'
1257        IVALUE(ILISTL)=ICOLL
1258        VALUE(ILISTL)=ICOLL
1259        IN(ILISTL)=NINEW
1260C
1261        IF(NEWNAM.EQ.'YES')THEN
1262          NUMNAM=NUMNAM+1
1263          NUMCOL=NUMCOL+1
1264        ENDIF
1265C
1266        DO4290J4=1,NUMNAM
1267          IF(IUSE(J4).EQ.'V'.AND.IVALUE(J4).EQ.ICOLL)THEN
1268            IUSE(J4)='V'
1269            IVALUE(J4)=ICOLL
1270            VALUE(J4)=ICOLL
1271            IN(J4)=NINEW
1272            GOTO4299
1273          ENDIF
1274 4290   CONTINUE
1275 4299   CONTINUE
1276C
1277      ENDIF
1278C
1279      IF(IPRINT.EQ.'ON' .AND. IFEEDB.EQ.'ON')THEN
1280        WRITE(ICOUT,999)
1281        CALL DPWRST('XXX','BUG ')
1282        WRITE(ICOUT,8011)IFLAG
1283 8011   FORMAT('THE STATUS FLAG FOR CHECK EQUAL LENGTH = ',I8)
1284        CALL DPWRST('XXX','BUG ')
1285        WRITE(ICOUT,999)
1286        CALL DPWRST('XXX','BUG ')
1287      ENDIF
1288      GOTO9000
1289C
1290C
1291C               ****************
1292C               **  STEP 90-- **
1293C               **  EXIT.     **
1294C               ****************
1295C
1296 9000 CONTINUE
1297      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CKEL')THEN
1298        WRITE(ICOUT,999)
1299        CALL DPWRST('XXX','BUG ')
1300        WRITE(ICOUT,9011)
1301 9011   FORMAT('***** AT THE END       OF DPCKEL--')
1302        CALL DPWRST('XXX','BUG ')
1303        WRITE(ICOUT,9013)NUMNAM
1304 9013   FORMAT('NUMNAM,IVALUE = ',2I8)
1305        CALL DPWRST('XXX','BUG ')
1306        DO9015I=1,NUMNAM
1307          WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I)
1308 9016     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I)='
1309     1           I8,2X,2A4,2X,A4,2I8)
1310          CALL DPWRST('XXX','BUG ')
1311 9015   CONTINUE
1312      ENDIF
1313C
1314      RETURN
1315      END
1316      SUBROUTINE DPCLA2(X,NROW,NCOL,NCLUST,IVARN1,IVARN2,
1317     1                  DYS,DYSMA,DYSMB,BETER,
1318     1                  TTD,RADUS,RATT,
1319     1                  TTBES,RDBES,
1320     1                  RABES,TTNEW,RDNEW,
1321     1                  NR,NRX,NSEL,NBEST,
1322     1                  NREPR,NRNEW,NSNEW,
1323     1                  NPNEW,NS,NP,
1324     1                  NEW,
1325     1                  XSAVE,IC1,
1326     1                  ICAPSW,ICAPTY,IFORSW,MAXNXT,ISEED,
1327     1                  ISUBRO,IBUGA3,IERROR)
1328C
1329C     PURPOSE--PERFORM A K-MEDIODS CLUSTER ANALYSIS FOR > 100 ROWS USING
1330C              KAUFFMAN AND ROUSSEEUW "CLARA" ALGORITHM (FOR <= 100
1331C              ROWS, USE THE "PAM" ALGORITHM.
1332C     REFERENCES--KAUFMAN AND ROUSSEEUW (1990), "FINDING GROUPS IN DATA:
1333C                 AN INTRODUCTION TO CLUSTER ANALYSIS", WILEY.
1334C               --ROUSSEEUW (1987), "SILHOUETTES: A GRAPHICAL AID TO THE
1335C                 INTERPRETATION AND VALIDATION OF CLUSTER ANALYSIS",
1336C                 JOURNAL OF COMPUTATIONAL AND APPLIED MATHEMATICS,
1337C                 VOL. 20, PP. 53-65, NORTH HOLLAND.
1338C     WRITTEN BY--ALAN HECKERT
1339C                 STATISTICAL ENGINEERING DIVISION
1340C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
1341C                 GAITHERSBURG, MD 20899-8980
1342C                 PHONE--301-975-2899
1343C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
1344C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
1345C     REFERENCE--ASTM MANUAL STP-15D, PAGES 78-84, 100-105
1346C     LANGUAGE--ANSI FORTRAN (1977)
1347C     VERSION NUMBER--2017/08
1348C     ORIGINAL VERSION--AUGUST      2017.
1349C
1350C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
1351C
1352      DIMENSION X(*)
1353      DIMENSION DYS(*)
1354      DIMENSION TTD(*)
1355      DIMENSION RADUS(*)
1356      DIMENSION RATT(*)
1357      DIMENSION TTBES(*)
1358      DIMENSION RDBES(*)
1359      DIMENSION RABES(*)
1360      DIMENSION DYSMA(*)
1361      DIMENSION DYSMB(*)
1362      DIMENSION BETER(*)
1363      DIMENSION TTNEW(*)
1364      DIMENSION RDNEW(*)
1365      DIMENSION XSAVE(NROW,NCOL)
1366C
1367      INTEGER NR(*)
1368      INTEGER NRX(*)
1369      INTEGER NSEL(*)
1370      INTEGER NBEST(*)
1371      INTEGER NREPR(*)
1372      INTEGER NRNEW(*)
1373      INTEGER NSNEW(*)
1374      INTEGER NPNEW(*)
1375      INTEGER NS(*)
1376      INTEGER NP(*)
1377      INTEGER NEW(*)
1378      INTEGER IC1(*)
1379C
1380      CHARACTER*4 IVARN1(*)
1381      CHARACTER*4 IVARN2(*)
1382      CHARACTER*4 ICAPSW
1383      CHARACTER*4 ICAPTY
1384      CHARACTER*4 IFORSW
1385      CHARACTER*4 ISUBRO
1386      CHARACTER*4 IBUGA3
1387      CHARACTER*4 IERROR
1388C
1389      REAL RAN(1)
1390C
1391      CHARACTER*4 IWRITE
1392      CHARACTER*4 IFLAG
1393      CHARACTER*4 ISUBN1
1394      CHARACTER*4 ISUBN2
1395      CHARACTER*4 ISTEPN
1396      CHARACTER*4 ICASPL
1397      CHARACTER*4 ITYP3
1398      CHARACTER*4 IOP
1399C
1400      INCLUDE 'DPCOST.INC'
1401      INCLUDE 'DPCOP2.INC'
1402C
1403C-----START POINT-----------------------------------------------------
1404C
1405      ISUBN1='DPCL'
1406      ISUBN2='A2  '
1407      IWRITE='OFF'
1408C
1409      ZBA=0.0
1410C
1411      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CLA2')THEN
1412        WRITE(ICOUT,999)
1413  999   FORMAT(1X)
1414        CALL DPWRST('XXX','BUG ')
1415        WRITE(ICOUT,70)
1416   70   FORMAT('AT THE BEGINNING OF DPCLA2--')
1417        CALL DPWRST('XXX','BUG ')
1418        WRITE(ICOUT,72)NROW,NCOL,NCLUST,IKMDSC,IKMDDI
1419   72   FORMAT('NROW,NCOL,NCLUST,IKMDSC,IKMDDI = ',3I8,2(2X,A4))
1420        CALL DPWRST('XXX','BUG ')
1421        DO75I=1,NROW*NCOL
1422          WRITE(ICOUT,77)I,X(I)
1423   77     FORMAT('I,X(I) = ',I8,2X,G15.7)
1424          CALL DPWRST('XXX','BUG ')
1425   75   CONTINUE
1426        WRITE(ICOUT,79)ICAPSW,ICAPTY,IFORSW
1427   79   FORMAT('ICAPSW,ICAPTY,IFORSW = ',2(A4,2X),A4)
1428        CALL DPWRST('XXX','BUG ')
1429      ENDIF
1430C
1431C               ********************************
1432C               **   STEP 1--                 **
1433C               **   CHECK FOR MISSING VALUES **
1434C               ********************************
1435C
1436      ISTEPN='1'
1437      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CLA2')
1438     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1439C
1440C     NOTE THAT CLARA EXPECTS DATA TO BE IN "ROW ORDER", THAT IS
1441C     (ROW = OBSERVATION NUMBER, COLUMN = VARIABLE NUMBER):
1442C
1443C          X(1)       =  ROW 1, COLUMN 1
1444C          X(2)       =  ROW 1, COLUMN 2
1445C              ...
1446C          X(NCOL)    = ROW 1, COLUMN NCOL
1447C          X(NCOL+1)  = ROW 2, COLUMN 1
1448C               ...
1449C
1450C
1451C     THE X ARRAY ON INPUT IS IN COLUMN ORDER.  SO FIRST
1452C     STEP IS TO CONVERT TO ROW ORDER.
1453C
1454      DO101I=1,NROW*NCOL
1455        DYS(I)=-9999.0
1456 101  CONTINUE
1457C
1458      DO102IROW=1,NROW
1459        DO103ICOL=1,NCOL
1460          INDX1=(ICOL-1)*NROW + IROW
1461          INDX2=(IROW-1)*NCOL + ICOL
1462          DYS(INDX2)=X(INDX1)
1463  103   CONTINUE
1464  102 CONTINUE
1465C
1466      DO104I=1,NROW*NCOL
1467        X(I)=DYS(I)
1468 104  CONTINUE
1469C
1470      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CLA2')THEN
1471        DO105I=1,NROW*NCOL
1472          WRITE(ICOUT,77)I,X(I)
1473          CALL DPWRST('XXX','BUG ')
1474  105   CONTINUE
1475      ENDIF
1476C
1477C     FIRST CHECK WHETHER ANY ROWS OR COLUMNS CONTAIN ONLY
1478C     MISSING DATA.  THIS WILL BE TREATED AS AN ERROR CONDITION.
1479C
1480C     CHECK ROWS FIRST
1481C
1482      DO110I=1,NROW
1483        DO120J=1,NCOL
1484          INDX=(I-1)*NCOL + J
1485          IF(X(INDX).NE.PSTAMV)GOTO129
1486  120   CONTINUE
1487        WRITE(ICOUT,999)
1488        CALL DPWRST('XXX','BUG ')
1489        WRITE(ICOUT,121)
1490  121   FORMAT('****** ERROR IN CLARA CLUSTERING--')
1491        CALL DPWRST('XXX','BUG ')
1492        WRITE(ICOUT,123)I
1493  123   FORMAT('       ROW (OBSERVATION) ',I8,' CONTAINS ONLY ',
1494     1         'MISSING DATA.')
1495        CALL DPWRST('XXX','BUG ')
1496        IERROR='YES'
1497        GOTO9000
1498  129   CONTINUE
1499  110 CONTINUE
1500C
1501C     NOW CHECK COLUMNS
1502C
1503      NMISS=0
1504      NMAT=0
1505C
1506      DO130J=1,NCOL
1507        NMISSV=0
1508        DO140I=1,NROW
1509          INDX=(I-1)*NCOL + J
1510          IF(X(INDX).EQ.PSTAMV)THEN
1511            NMISSV=NMISSV + 1
1512          ENDIF
1513  140   CONTINUE
1514        IF(NMISSV.EQ.NROW)THEN
1515          WRITE(ICOUT,999)
1516          CALL DPWRST('XXX','BUG ')
1517          WRITE(ICOUT,121)
1518          CALL DPWRST('XXX','BUG ')
1519          WRITE(ICOUT,143)J
1520  143     FORMAT('       COLUMN (VARIABLE) ',I8,' CONTAINS ONLY ',
1521     1           'MISSING DATA.')
1522          CALL DPWRST('XXX','BUG ')
1523          IERROR='YES'
1524          GOTO9000
1525        ELSEIF(NMISSV.EQ.0)THEN
1526          NMAT=1
1527        ELSE
1528          WRITE(ICOUT,999)
1529          CALL DPWRST('XXX','BUG ')
1530          WRITE(ICOUT,146)IVARN1(J),IVARN2(J),NMISSV
1531  146     FORMAT('VARIABLE ',2A4,' CONTAINS ',I8,' MISSING VALUES.')
1532          CALL DPWRST('XXX','BUG ')
1533          WRITE(ICOUT,143)J
1534        ENDIF
1535        NMISS=NMISS + NMISSV
1536  130 CONTINUE
1537C
1538      IF(NMISS.GT.0)THEN
1539        WRITE(ICOUT,999)
1540        CALL DPWRST('XXX','BUG ')
1541        WRITE(ICOUT,163)
1542  163   FORMAT('THE TOTAL NUMBER OF MISSING VALUES IS ',I8)
1543        CALL DPWRST('XXX','BUG ')
1544        IF(NMAT.EQ.0)THEN
1545          WRITE(ICOUT,999)
1546          CALL DPWRST('XXX','BUG ')
1547          WRITE(ICOUT,165)
1548  165     FORMAT('****** WARNING IN CLARA CLUSTERING--')
1549          CALL DPWRST('XXX','BUG ')
1550          WRITE(ICOUT,167)
1551  167     FORMAT('       NO VARIABLES ARE DEFINED FOR ALL ',
1552     1           'OBSERVATIONS.')
1553          CALL DPWRST('XXX','BUG ')
1554        ENDIF
1555      ENDIF
1556C
1557C               ******************************
1558C               **   STEP 2--               **
1559C               **   SCALE IF REQUESTED     **
1560C               ******************************
1561C
1562      ISTEPN='1'
1563      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CLA2')THEN
1564        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1565        WRITE(ICOUT,168)NMISS,PSTAMV
1566  168   FORMAT('NMISS,PSTAMV = ',I8,2X,G15.7)
1567        CALL DPWRST('XXX','BUG ')
1568      ENDIF
1569C
1570      NSTAN=0
1571      IF(IKMDSC.EQ.'OFF')GOTO299
1572C
1573      NSTAN=1
1574      DO201JJ=1,NCOL
1575        NROWT=0
1576        DO203II=1,NROW
1577          INDX=(II-1)*NCOL + JJ
1578          IF(X(INDX).NE.PSTAMV)THEN
1579            NROWT=NROWT+1
1580            DYS(NROWT)=X(INDX)
1581          ENDIF
1582  203   CONTINUE
1583        IF(ISTALO.EQ.'MEAN')THEN
1584          CALL MEAN(DYS,NROWT,IWRITE,XMEAN,IBUGA3,IERROR)
1585        ELSEIF(ISTALO.EQ.'MEDI')THEN
1586          CALL MEDIAN(DYS,NROWT,IWRITE,DYSMB,MAXNXT,XMEAN,
1587     1                IBUGA3,IERROR)
1588        ELSEIF(ISTALO.EQ.'MIDM')THEN
1589          CALL MIDMEA(DYS,NROWT,IWRITE,DYSMB,MAXNXT,XMEAN,
1590     1                IBUGA3,IERROR)
1591        ELSEIF(ISTALO.EQ.'HARM')THEN
1592          CALL HARMEA(DYS,NROWT,IWRITE,XMEAN,IBUGA3,IERROR)
1593        ELSEIF(ISTALO.EQ.'MINI')THEN
1594          CALL MINIM(DYS,NROWT,IWRITE,XMEAN,IBUGA3,IERROR)
1595        ELSEIF(ISTALO.EQ.'GEOM')THEN
1596          CALL GEOMEA(DYS,NROWT,IWRITE,XMEAN,IBUGA3,IERROR)
1597        ELSEIF(ISTALO.EQ.'BILO')THEN
1598          CALL BIWLOC(DYS,NROWT,IWRITE,DYSMA,DYSMB,MAXNXT,XMEAN,
1599     1                IBUGA3,IERROR)
1600        ELSEIF(ISTALO.EQ.'H15 ')THEN
1601          NCUT=0
1602          C=1.5
1603          CALL H15(DYS,NROWT,C,NCUT,XMEAN,XSC,DYSMA,DYSMB,MAXNXT,
1604     1                IBUGA3,IERROR)
1605        ELSEIF(ISTALO.EQ.'H10 ')THEN
1606          NCUT=0
1607          C=1.0
1608          CALL H15(DYS,NROWT,C,NCUT,XMEAN,XSC,DYSMA,DYSMB,MAXNXT,
1609     1                IBUGA3,IERROR)
1610        ELSEIF(ISTALO.EQ.'H12 ')THEN
1611          NCUT=0
1612          C=1.2
1613          CALL H15(DYS,NROWT,C,NCUT,XMEAN,XSC,DYSMA,DYSMB,MAXNXT,
1614     1                IBUGA3,IERROR)
1615        ELSEIF(ISTALO.EQ.'H17 ')THEN
1616          NCUT=0
1617          C=1.7
1618          CALL H15(DYS,NROWT,C,NCUT,XMEAN,XSC,DYSMA,DYSMB,MAXNXT,
1619     1                IBUGA3,IERROR)
1620        ELSEIF(ISTALO.EQ.'H20 ')THEN
1621          NCUT=0
1622          C=2.0
1623          CALL H15(DYS,NROWT,C,NCUT,XMEAN,XSC,DYSMA,DYSMB,MAXNXT,
1624     1                IBUGA3,IERROR)
1625        ELSE
1626          CALL MEAN(DYS,NROWT,IWRITE,XMEAN,IBUGA3,IERROR)
1627        ENDIF
1628C
1629        IF(ISTASC.EQ.'SD  ')THEN
1630          CALL SD(DYS,NROWT,IWRITE,XSD,IBUGA3,IERROR)
1631        ELSEIF(ISTASC.EQ.'H15S')THEN
1632          NCUT=0
1633          C=1.5
1634          CALL H15(DYS,NROWT,C,NCUT,XLOC,XSD,DYSMA,DYSMB,MAXNXT,
1635     1                IBUGA3,IERROR)
1636        ELSEIF(ISTASC.EQ.'H10S')THEN
1637          NCUT=0
1638          C=1.0
1639          CALL H15(DYS,NROWT,C,NCUT,XLOC,XSD,DYSMA,DYSMB,MAXNXT,
1640     1                IBUGA3,IERROR)
1641        ELSEIF(ISTASC.EQ.'H12S')THEN
1642          NCUT=0
1643          C=1.2
1644          CALL H15(DYS,NROWT,C,NCUT,XLOC,XSD,DYSMA,DYSMB,MAXNXT,
1645     1                IBUGA3,IERROR)
1646        ELSEIF(ISTASC.EQ.'H17S')THEN
1647          NCUT=0
1648          C=1.7
1649          CALL H15(DYS,NROWT,C,NCUT,XLOC,XSD,DYSMA,DYSMB,MAXNXT,
1650     1                IBUGA3,IERROR)
1651        ELSEIF(ISTASC.EQ.'H20S')THEN
1652          NCUT=0
1653          C=2.0
1654          CALL H15(DYS,NROWT,C,NCUT,XLOC,XSD,DYSMA,DYSMB,MAXNXT,
1655     1                IBUGA3,IERROR)
1656        ELSEIF(ISTASC.EQ.'BISC')THEN
1657          CALL BIWSCA(DYS,NROWT,IWRITE,DYSMA,DYSMB,MAXNXT,XSD,
1658     1                IBUGA3,IERROR)
1659        ELSEIF(ISTASC.EQ.'MAD ')THEN
1660          CALL MAD(DYS,NROWT,IWRITE,DYSMA,DYSMB,MAXNXT,XSD,
1661     1             IBUGA3,IERROR)
1662        ELSEIF(ISTASC.EQ.'MADN')THEN
1663          CALL MAD(DYS,NROWT,IWRITE,DYSMA,DYSMB,MAXNXT,XSD,
1664     1             IBUGA3,IERROR)
1665          XSD=XSD/0.67449
1666        ELSEIF(ISTASC.EQ.'AAD ')THEN
1667          CALL AAD(DYS,NROWT,IWRITE,DYSMA,MAXNXT,XSD,'MEAN',
1668     1             IBUGA3,IERROR)
1669        ELSEIF(ISTASC.EQ.'IQRA')THEN
1670          CALL LOWQUA(DYS,NROWT,IWRITE,DYSMA,MAXNXT,RIGH1,
1671     1                IBUGA3,IERROR)
1672          CALL UPPQUA(DYS,NROWT,IWRITE,DYSMA,MAXNXT,RIGH2,
1673     1                IBUGA3,IERROR)
1674          XSD=RIGH2-RIGH1
1675        ELSEIF(ISTASC.EQ.'NIQR')THEN
1676          CALL LOWQUA(DYS,NROWT,IWRITE,DYSMA,MAXNXT,RIGH1,
1677     1                IBUGA3,IERROR)
1678          CALL UPPQUA(DYS,NROWT,IWRITE,DYSMA,MAXNXT,RIGH2,
1679     1                IBUGA3,IERROR)
1680          XSD=0.7413*(RIGH2-RIGH1)
1681        ELSEIF(ISTASC.EQ.'SNSC')THEN
1682          XSD=SN(DYS,NROWT,DYSMA,DYSMB,BETER)
1683        ELSEIF(ISTASC.EQ.'MAXI')THEN
1684          CALL MINIM(DYS,NROWT,IWRITE,XMIN,IBUGA3,IERROR)
1685          CALL MAXIM(DYS,NROWT,IWRITE,XMAX,IBUGA3,IERROR)
1686          XSD=XMAX - XMIN
1687        ELSE
1688          CALL SD(DYS,NROWT,IWRITE,XMEAN,IBUGA3,IERROR)
1689        ENDIF
1690C
1691        IF(XSD.LE.0.0)THEN
1692          WRITE(ICOUT,121)
1693          CALL DPWRST('XXX','BUG ')
1694          WRITE(ICOUT,206)JJ
1695  206     FORMAT('       VARIABLE ',I4,' HAS ZERO STANDARD DEVIATION ',
1696     1           'WHEN SCALING REQUESTED.')
1697          CALL DPWRST('XXX','BUG ')
1698          IERROR='YES'
1699          GOTO9000
1700        ENDIF
1701        DO205II=1,NROW
1702          INDX=(II-1)*NCOL + JJ
1703          IF(X(INDX).NE.PSTAMV)THEN
1704            AVAL=(X(INDX)-XMEAN)/XSD
1705            X(INDX)=AVAL
1706          ENDIF
1707  205   CONTINUE
1708  201 CONTINUE
1709C
1710  299 CONTINUE
1711C
1712C     SAVE X ARRAY IN ROW/COLUMN FORMAT FOR SILHOUEETE PLOT POINTS
1713C     (BUT ONLY IF NROW*NCOL <= 2*MAXNXT)
1714C
1715      IF(NROW*NCOL.LE.2*MAXNXT)THEN
1716        ICNT=0
1717        DO211II=1,NROW
1718          DO213JJ=1,NCOL
1719            ICNT=ICNT+1
1720            XSAVE(II,JJ)=X(ICNT)
1721            IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CLA2')THEN
1722              WRITE(ICOUT,215)II,JJ,XSAVE(II,JJ)
1723  215         FORMAT('II,JJ,XSAVE(II,JJ) = ',2I8,G15.7)
1724              CALL DPWRST('XXX','BUG ')
1725            ENDIF
1726  213     CONTINUE
1727  211   CONTINUE
1728      ENDIF
1729C
1730C     OPEN THE AUXILLARY FILES
1731C
1732      IOP='OPEN'
1733      IFLG11=1
1734      IFLG21=1
1735      IFLG31=1
1736      IFLAG4=1
1737      IFLAG5=0
1738      CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLAG4,IFLAG5,
1739     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
1740     1            IBUGA3,ISUBRO,IERROR)
1741      IF(IERROR.EQ.'YES')GOTO9000
1742C
1743C               ************************************
1744C               **   STEP 3--                     **
1745C               **   PERFORM THE CLUSTER ANALYSIS **
1746C               ************************************
1747C
1748C      THIS CODE IS A SOMEWHAT MODIFED VERSION OF CODE IN THE
1749C      CLARA MAIN ROUTINE.
1750C
1751C      IN THE DO 400 LOOP, RANDOM SUBSAMPLES ARE DRAWN AND PARTITIONED
1752C      INTO KK CLUSTERS
1753C
1754      KK=NCLUST
1755      IF(IKMDNS.GE.1 .AND. IKMDNS.LE.NROW)THEN
1756        NRAN=IKMDNS
1757      ELSE
1758        NRAN=5
1759      ENDIF
1760      NN=NROW
1761      JPP=NCOL
1762      RNN=REAL(NN)
1763      IF(IKMDSS.GE.10+2*KK .AND. IKMDSS.LE.NROW)THEN
1764        NSAM=IKMDSS
1765      ELSE
1766        NSAM=40 + 2*KK
1767      ENDIF
1768      NNEQ=0
1769      IF(NN.EQ.NSAM)NNEQ=1
1770      NHALF=NSAM*(NSAM-1)/2 + 1
1771      NSAMB=2*NSAM
1772      NNPP=NROW*NCOL
1773      IFLAG='CLAR'
1774      NDYST=2
1775      IF(IKMDDI.EQ.'EUCL')NDYST=1
1776C
1777      IF(IKMDPR.EQ.'ALL')THEN
1778        LARGE=2
1779      ELSEIF(IKMDPR.EQ.'FINA')THEN
1780        LARGE=1
1781      ELSEIF(IKMDPR.EQ.'MINI')THEN
1782        LARGE=0
1783      ELSE
1784        LARGE=2
1785      ENDIF
1786C
1787      ISTEPN='2'
1788      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CLA2')THEN
1789        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1790        WRITE(ICOUT,169)KK,NRAN,NSAM,NNPP,NDYST
1791  169   FORMAT('KK,NRAN,NSAM,NNPP,NDYST = ',5I8)
1792        CALL DPWRST('XXX','BUG ')
1793      ENDIF
1794C
1795      IF(IPRINT.EQ.'ON')THEN
1796        WRITE(ICOUT,999)
1797        CALL DPWRST('XXX','BUG ')
1798        WRITE(ICOUT,999)
1799        CALL DPWRST('XXX','BUG ')
1800        WRITE(ICOUT,301)
1801  301   FORMAT(10X,'**********************************************')
1802        CALL DPWRST('XXX','BUG ')
1803        WRITE(ICOUT,302)
1804  302   FORMAT(10X,'*                                            *')
1805        CALL DPWRST('XXX','BUG ')
1806        WRITE(ICOUT,303)
1807  303   FORMAT(10X,'*  ROUSSEEUW/KAUFFMAN K-MEDOID CLUSTERING    *')
1808        CALL DPWRST('XXX','BUG ')
1809        WRITE(ICOUT,304)
1810  304   FORMAT(10X,'*  (USING THE CLARA ROUTINE).                *')
1811        CALL DPWRST('XXX','BUG ')
1812        WRITE(ICOUT,302)
1813        CALL DPWRST('XXX','BUG ')
1814        WRITE(ICOUT,301)
1815        CALL DPWRST('XXX','BUG ')
1816        WRITE(ICOUT,999)
1817        CALL DPWRST('XXX','BUG ')
1818C
1819        WRITE(ICOUT,999)
1820        CALL DPWRST('XXX','BUG ')
1821        WRITE(ICOUT,401)
1822  401   FORMAT('**********************************************')
1823        CALL DPWRST('XXX','BUG ')
1824        WRITE(ICOUT,402)
1825  402   FORMAT('*                                            *')
1826        CALL DPWRST('XXX','BUG ')
1827        WRITE(ICOUT,403)KK
1828  403   FORMAT('*  NUMBER OF REPRESENTATIVE OBJECTS ',I5,4X,'*')
1829        CALL DPWRST('XXX','BUG ')
1830        WRITE(ICOUT,402)
1831        CALL DPWRST('XXX','BUG ')
1832        WRITE(ICOUT,401)
1833        CALL DPWRST('XXX','BUG ')
1834        WRITE(ICOUT,999)
1835        CALL DPWRST('XXX','BUG ')
1836        WRITE(ICOUT,406)NRAN,NSAM
1837  406   FORMAT(I4,' SAMPLES OF ',I5,' OBJECTS WILL NOW BE DRAWN.')
1838        CALL DPWRST('XXX','BUG ')
1839      ENDIF
1840C
1841      NUNFS=0
1842      LESS=NSAM
1843      IF(NN.LT.NSAMB)LESS=NN-NSAM
1844      KALL=0
1845      NRUN=0
1846C
1847      DO 400 JRAN=1,NRAN
1848C
1849         IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CLA2')THEN
1850           ISTEPN='3A'
1851           CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1852           WRITE(ICOUT,29)JRAN
1853   29      FORMAT('JRAN = ',I6)
1854           CALL DPWRST('XXX','BUG ')
1855        ENDIF
1856C
1857        JHALT=0
1858        IF(NNEQ.EQ.2)GO TO 400
1859C
1860        IF(NNEQ.NE.0)THEN
1861          NNEQ=2
1862          DO 411 J=1,NSAM
1863            NSEL(J)=J
1864  411     CONTINUE
1865          WRITE(ICOUT,9255)
1866 9255     FORMAT('THE SIZE OF THE SAMPLE EQUALS THE NUMBER OF OBJECTS ',
1867     1           'IN THE DATA SET.')
1868          CALL DPWRST('XXX','BUG ')
1869          WRITE(ICOUT,9256)
1870 9256     FORMAT('IN THIS CASE THE ENTIRE DATA SET IS CLUSTERED.')
1871          CALL DPWRST('XXX','BUG ')
1872          GO TO 330
1873        ENDIF
1874C
1875        IF(IPRINT.EQ.'ON' .AND. LARGE.EQ.2)THEN
1876          WRITE(ICOUT,999)
1877          CALL DPWRST('XXX','BUG ')
1878          WRITE(ICOUT,9265)JRAN
1879 9265     FORMAT('SAMPLE NUMBER ',I4)
1880          CALL DPWRST('XXX','BUG ')
1881          WRITE(ICOUT,9266)
1882 9266     FORMAT('******************')
1883          CALL DPWRST('XXX','BUG ')
1884        ENDIF
1885C
1886        NTT=0
1887        IF(JRAN.EQ.1 .OR. NUNFS.EQ.JRAN .OR. NN.LT.NSAMB)THEN
1888  180     CONTINUE
1889CNIST     CALL RANDM(NRUN,RAN)
1890          IF(IKMDRN.EQ.'DATA')THEN
1891            NTEMP=1
1892            CALL UNIRAN(NTEMP,ISEED,RAN)
1893          ELSE
1894            NRUN=NRUN*5761+999
1895            KTEMP=NRUN/65536
1896            NRUN=NRUN-KTEMP*65536
1897            RY=NRUN
1898            RAN(1)=RY/65536.0
1899          ENDIF
1900C
1901          KRAN=INT(RNN*RAN(1)+1.)
1902          IF(KRAN.GT.NN)KRAN=NN
1903          IF(JRAN.GT.1)THEN
1904            DO 190 JK=1,KK
1905              IF(KRAN.EQ.NRX(JK))GO TO 180
1906  190       CONTINUE
1907          ENDIF
1908          NTT=NTT+1
1909          NSEL(NTT)=KRAN
1910        ELSE
1911          DO 150 JK=1,KK
1912            NSEL(JK)=NRX(JK)
1913  150     CONTINUE
1914          KKM=KK-1
1915          DO 170 JK=1,KKM
1916            NSM=NSEL(JK)
1917            KKP=JK+1
1918            JSM=JK
1919            DO 160 JKK=KKP,KK
1920              IF(NSEL(JKK).GE.NSM)GO TO 160
1921              NSM=NSEL(JKK)
1922              JSM=JKK
1923  160       CONTINUE
1924            NSEL(JSM)=NSEL(JK)
1925            NSEL(JK)=NSM
1926  170     CONTINUE
1927          NTT=KK
1928        ENDIF
1929C
1930  210   CONTINUE
1931C
1932        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CLA2')THEN
1933          ISTEPN='3B'
1934          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1935          WRITE(ICOUT,31)
1936   31     FORMAT('AT 210')
1937          CALL DPWRST('XXX','BUG ')
1938          DO33II=1,NTT
1939            WRITE(ICOUT,32)II,NSEL(II)
1940   32       FORMAT('II,NSEL(II) = ',2I8)
1941            CALL DPWRST('XXX','BUG ')
1942   33     CONTINUE
1943        ENDIF
1944C
1945CNIST   CALL RANDM(NRUN,RAN)
1946        IF(IKMDRN.EQ.'DATA')THEN
1947          NTEMP=1
1948          CALL UNIRAN(NTEMP,ISEED,RAN)
1949        ELSE
1950          NRUN=NRUN*5761+999
1951          KTEMP=NRUN/65536
1952          NRUN=NRUN-KTEMP*65536
1953          RY=NRUN
1954          RAN(1)=RY/65536.0
1955        ENDIF
1956        KRAN=INT(RNN*RAN(1)+1.)
1957        IF(KRAN.GT.NN)KRAN=NN
1958        IF(JRAN.GT.1 .AND. NN.LT.NSAMB)THEN
1959          DO 220 JK=1,KK
1960            IF(KRAN.EQ.NRX(JK))GO TO 210
1961  220     CONTINUE
1962        ENDIF
1963C
1964        DO 260 KANS=1,NTT
1965          IF(NSEL(KANS).LT.KRAN)GO TO 260
1966          IF(NSEL(KANS).EQ.KRAN)GO TO 210
1967          DO 280 NAD=KANS,NTT
1968            NADV=NTT-NAD+KANS
1969            NADVP=NADV+1
1970            NSEL(NADVP)=NSEL(NADV)
1971  280     CONTINUE
1972          NTT=NTT+1
1973          NSEL(KANS)=KRAN
1974          GOTO290
1975  260   CONTINUE
1976        NTT=NTT+1
1977        NSEL(NTT)=KRAN
1978C
1979  290   CONTINUE
1980        IF(NTT.LT.LESS)GO TO 210
1981        IF(NN.LT.NSAMB)THEN
1982          NEXAP=1
1983          NEXBP=1
1984          JN=0
1985  300     CONTINUE
1986          JN=JN+1
1987          IF(NSEL(NEXAP).EQ.JN)THEN
1988            NEXAP=NEXAP+1
1989          ELSE
1990            NREPR(NEXBP)=JN
1991            NEXBP=NEXBP+1
1992          ENDIF
1993          IF(JN.LT.NN)GO TO 300
1994          DO 310 NSUB=1,NSAM
1995            NSEL(NSUB)=NREPR(NSUB)
1996  310     CONTINUE
1997        ENDIF
1998C
1999        IF(IPRINT.EQ.'ON' .AND. LARGE.EQ.2)THEN
2000          WRITE(ICOUT,999)
2001          CALL DPWRST('XXX','BUG ')
2002          WRITE(ICOUT,9270)
2003 9270     FORMAT('RANDOM SAMPLE =')
2004          CALL DPWRST('XXX','BUG ')
2005          ILINE=NSAM/10
2006          IREM=MOD(NSAM,10)
2007          IF(IREM.GE.1)ILINE=ILINE+1
2008          DO9271II=1,ILINE
2009            ISTRT=(II-1)*10 + 1
2010            ISTOP=II*10
2011            IF(ISTOP.GT.NSAM)ISTOP=NSAM
2012            WRITE(ICOUT,9280)(NSEL(JJ),JJ=ISTRT,ISTOP)
2013 9280       FORMAT(5X,10I7)
2014            CALL DPWRST('XXX','BUG ')
2015 9271     CONTINUE
2016        ENDIF
2017C
2018  330   CONTINUE
2019C
2020C       NDYST = 1 => EUCLIDEAN DISTANCES
2021C             = 2 => MANHATTAN DISTANCES
2022C
2023        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CLA2')THEN
2024          ISTEPN='3C'
2025          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2026          WRITE(ICOUT,9931)
2027 9931     FORMAT('BEFORE CALL DYSTA')
2028          CALL DPWRST('XXX','BUG ')
2029          DO9933II=1,NSAM
2030            WRITE(ICOUT,9932)II,NSEL(II),NREPR(II)
2031 9932       FORMAT('II,NSEL(II),NREPR(II) = ',3I8)
2032            CALL DPWRST('XXX','BUG ')
2033 9933     CONTINUE
2034        ENDIF
2035C
2036        CALL DYSTA(NSAM,NCOL,NSEL,X,DYS,NDYST,PSTAMV,JHALT,
2037     1             ISUBRO,IBUGA3)
2038C
2039        ISTEPN='3D'
2040        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CLA2')
2041     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2042C
2043        IF(JHALT.EQ.1)GO TO 400
2044        KALL=1
2045        S=0.0
2046        L=1
2047C
2048  340   CONTINUE
2049        L=L+1
2050        IF(DYS(L).GT.S)S=DYS(L)
2051        IF(L.LT.NHALF)GO TO 340
2052C
2053        ISTEPN='3E'
2054        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CLA2')
2055     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2056C
2057        CALL BSWAP(KK,NSAM,NREPR,DYSMA,DYSMB,BETER,DYS,Z,S,IFLAG,
2058     1             LARGE,ISUBRO,IBUGA3)
2059C
2060        ISTEPN='3F'
2061        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CLA2')
2062     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2063C
2064        RSAM=NSAM
2065        AZ=Z/RSAM
2066C
2067        IF(NNEQ.EQ.0)THEN
2068          IF(IPRINT.EQ.'ON' .AND. LARGE.EQ.2)THEN
2069            WRITE(ICOUT,999)
2070            CALL DPWRST('XXX','BUG ')
2071            WRITE(ICOUT,9320)
2072 9320       FORMAT('FINAL RESULT FOR THIS SAMPLE')
2073            CALL DPWRST('XXX','BUG ')
2074          ENDIF
2075        ELSEIF(NNEQ.GE.1)THEN
2076          IF(IPRINT.EQ.'ON')THEN
2077            WRITE(ICOUT,999)
2078            CALL DPWRST('XXX','BUG ')
2079            WRITE(ICOUT,9325)
2080 9325       FORMAT('FINAL RESULT')
2081            CALL DPWRST('XXX','BUG ')
2082          ENDIF
2083        ENDIF
2084        IF(IPRINT.EQ.'ON')THEN
2085          IF(LARGE.EQ.2 .OR. NNEQ.GE.1)THEN
2086            WRITE(ICOUT,9330)AZ
2087 9330       FORMAT('  AVERAGE DISTANCE  =   ',F12.3)
2088            CALL DPWRST('XXX','BUG ')
2089            WRITE(ICOUT,999)
2090            CALL DPWRST('XXX','BUG ')
2091          ENDIF
2092        ENDIF
2093C
2094        ISTEPN='3G'
2095        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CLA2')
2096     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2097C
2098        MDATA=0
2099        IF(NMISS.GE.1)MDATA=1
2100        CALL SELEC(KK,NN,JPP,NSTAN,NDYST,ZB,NSAM,MDATA,
2101     1             PSTAMV,NREPR,NSEL,DYS,X,NR,NAFS,
2102     1             TTD,RADUS,RATT,
2103     1             TTNEW,RDNEW,
2104     1             NRNEW,NSNEW,NPNEW,NS,NP,NEW,
2105     1             LARGE,ISUBRO,IBUGA3)
2106C
2107        ISTEPN='3H'
2108        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CLA2')
2109     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2110C
2111        NUNFS=NUNFS+NAFS
2112        IF(NAFS.EQ.1)GO TO 400
2113        IF(JRAN.EQ.1)GO TO 350
2114        IF(ZB.GE.ZBA)GO TO 400
2115C
2116  350   CONTINUE
2117        ZBA=ZB
2118        DO 345 JJB=1,30
2119          TTBES(JJB)=TTD(JJB)
2120          RDBES(JJB)=RADUS(JJB)
2121          RABES(JJB)=RATT(JJB)
2122  345   CONTINUE
2123        DO 360 JK=1,KK
2124          NRX(JK)=NR(JK)
2125  360   CONTINUE
2126        DO 370 JS=1,NSAM
2127          NBEST(JS)=NSEL(JS)
2128  370   CONTINUE
2129        JRSKY=JRAN
2130
2131  400 CONTINUE
2132C
2133      IF(NUNFS.GE.NRAN)THEN
2134        WRITE(ICOUT,9335)
2135        WRITE(ICOUT,9335)
2136 9335   FORMAT('FOR EACH SAMPLE AT LEAST ONE OBJECT WAS FOUND',
2137     1         ' WHICH COULD NOT')
2138        CALL DPWRST('XXX','BUG ')
2139        WRITE(ICOUT,9336)
2140 9336   FORMAT('BE ASSIGNED TO A CLUSTER (BECAUSE OF',
2141     1         ' MISSING VALUES).')
2142        CALL DPWRST('XXX','BUG ')
2143        WRITE(ICOUT,9337)
2144 9337   FORMAT(' NO CLUSTERING PERFORMED.')
2145        CALL DPWRST('XXX','BUG ')
2146        IERROR='YES'
2147        GOTO9000
2148      ENDIF
2149CC
2150CC    FOR THE BEST SUBSAMPLE, THE OBJECTS OF THE ENTIRE DATA SET
2151CC    ARE ASSIGNED TO THEIR CLUSTERS
2152CC
2153      IF(KALL.NE.1)THEN
2154        WRITE(ICOUT,999)
2155        CALL DPWRST('XXX','BUG ')
2156        WRITE(ICOUT,999)
2157        CALL DPWRST('XXX','BUG ')
2158        WRITE(ICOUT,999)
2159        CALL DPWRST('XXX','BUG ')
2160        WRITE(ICOUT,9340)NRAN
2161 9340   FORMAT('EACH OF THE ',I5,' RANDOM SAMPLES CONTAINS')
2162        CALL DPWRST('XXX','BUG ')
2163        WRITE(ICOUT,9341)
2164 9341   FORMAT(' OBJECTS BETWEEN WHICH NO DISTANCE CAN BE COMPUTED.')
2165        CALL DPWRST('XXX','BUG ')
2166        GO TO 510
2167      ENDIF
2168C
2169      AZBA=ZBA/RNN
2170      IF(KK.EQ.1)THEN
2171        IF(IPRINT.EQ.'ON')THEN
2172          IF(NNEQ.EQ.0)THEN
2173            WRITE(ICOUT,999)
2174            CALL DPWRST('XXX','BUG ')
2175            WRITE(ICOUT,999)
2176            CALL DPWRST('XXX','BUG ')
2177            WRITE(ICOUT,999)
2178            CALL DPWRST('XXX','BUG ')
2179            WRITE(ICOUT,9350)JRSKY,NRX(1)
2180 9350       FORMAT('SAMPLE NUMBER',I4,' WAS SELECTED ITS MEDOID IS',
2181     1             'OBJECT ',I7,' .')
2182            CALL DPWRST('XXX','BUG ')
2183          ELSEIF(NNEQ.GE.1)THEN
2184            WRITE(ICOUT,999)
2185            CALL DPWRST('XXX','BUG ')
2186            WRITE(ICOUT,999)
2187            CALL DPWRST('XXX','BUG ')
2188            WRITE(ICOUT,999)
2189            CALL DPWRST('XXX','BUG ')
2190            WRITE(ICOUT,9355)NRX(1)
2191 9355       FORMAT('THE MEDOID IS OBJECT NUMBER ',I7,'.')
2192            CALL DPWRST('XXX','BUG ')
2193            WRITE(ICOUT,999)
2194            CALL DPWRST('XXX','BUG ')
2195            WRITE(ICOUT,999)
2196            CALL DPWRST('XXX','BUG ')
2197            WRITE(ICOUT,9360)AZBA
2198 9360       FORMAT('   AVERAGE DISTANCE FOR THE ENTIRE DATA SET = ',
2199     1             F12.3)
2200            CALL DPWRST('XXX','BUG ')
2201          ENDIF
2202        ENDIF
2203        GO TO 500
2204      ENDIF
2205C
2206      IF(NNEQ.LT.1)THEN
2207        IF(IPRINT.EQ.'ON')THEN
2208          WRITE(ICOUT,999)
2209          CALL DPWRST('XXX','BUG ')
2210          WRITE(ICOUT,999)
2211          CALL DPWRST('XXX','BUG ')
2212          WRITE(ICOUT,999)
2213          CALL DPWRST('XXX','BUG ')
2214          WRITE(ICOUT,9370)
2215 9370     FORMAT('FINAL RESULTS')
2216          CALL DPWRST('XXX','BUG ')
2217          WRITE(ICOUT,9371)
2218 9371     FORMAT(13('*'))
2219          CALL DPWRST('XXX','BUG ')
2220          WRITE(ICOUT,999)
2221          CALL DPWRST('XXX','BUG ')
2222          WRITE(ICOUT,9372)JRSKY
2223 9372     FORMAT('SAMPLE NUMBER ',I3,' WAS SELECTED, WITH OBJECTS =')
2224          CALL DPWRST('XXX','BUG ')
2225C
2226          ILOOP=NSAM/10
2227          IREM=MOD(NSAM,10)
2228          IF(IREM.GT.0)ILOOP=ILOOP+1
2229          DO9283II=1,ILOOP
2230            ISTRT=(II-1)*10+1
2231            ISTOP=II*10
2232            IF(ISTOP.GT.NSAM)ISTOP=NSAM
2233            WRITE(ICOUT,9281)(NBEST(JJ),JJ=ISTRT,ISTOP)
2234 9281       FORMAT(10I7)
2235            CALL DPWRST('XXX','BUG ')
2236 9283     CONTINUE
2237C
2238          WRITE(ICOUT,999)
2239          CALL DPWRST('XXX','BUG ')
2240          WRITE(ICOUT,9360)AZBA
2241          CALL DPWRST('XXX','BUG ')
2242C
2243        ENDIF
2244C
2245        CALL DYSTA(NSAM,NCOL,NBEST,X,DYS,NDYST,PSTAMV,JHALT,
2246     1             ISUBRO,IBUGA3)
2247        CALL RESUL(KK,NN,NCOL,LARGE,NDYST,X,NRX,PSTAMV,IC1,IOUNI1)
2248C
2249        IF(IPRINT.EQ.'ON')THEN
2250          WRITE(ICOUT,999)
2251          CALL DPWRST('XXX','BUG ')
2252          WRITE(ICOUT,999)
2253          CALL DPWRST('XXX','BUG ')
2254          WRITE(ICOUT,9400)
2255 9400     FORMAT('    AVERAGE DISTANCE TO EACH MEDOID')
2256          CALL DPWRST('XXX','BUG ')
2257          WRITE(ICOUT,9401)(TTBES(J),J=1,KK)
2258 9401     FORMAT(2X,5F12.3)
2259          CALL DPWRST('XXX','BUG ')
2260          WRITE(ICOUT,999)
2261          CALL DPWRST('XXX','BUG ')
2262          WRITE(ICOUT,9410)
2263 9410     FORMAT('    MAXIMUM DISTANCE TO EACH MEDOID')
2264          CALL DPWRST('XXX','BUG ')
2265          WRITE(ICOUT,9411)(RDBES(J),J=1,KK)
2266 9411     FORMAT(2X,5F12.3)
2267          CALL DPWRST('XXX','BUG ')
2268          WRITE(ICOUT,999)
2269          CALL DPWRST('XXX','BUG ')
2270          WRITE(ICOUT,9420)
2271 9420     FORMAT('    MAXIMUM DISTANCE TO A MEDOID DIVIDED BY MINIMUM')
2272          CALL DPWRST('XXX','BUG ')
2273          WRITE(ICOUT,9421)(RABES(J),J=1,KK)
2274 9421     FORMAT(2X,5F12.3)
2275          CALL DPWRST('XXX','BUG ')
2276        ENDIF
2277      ENDIF
2278C
2279  500 CONTINUE
2280      IF(IFEEDB.EQ.'ON')THEN
2281        WRITE(ICOUT,999)
2282        CALL DPWRST('XXX','BUG ')
2283        WRITE(ICOUT,9450)
2284 9450   FORMAT('THIS RUN HAS BEEN SUCCESSFULLY COMPLETED.')
2285        CALL DPWRST('XXX','BUG ')
2286        WRITE(ICOUT,999)
2287        CALL DPWRST('XXX','BUG ')
2288      ENDIF
2289C
2290  510 CONTINUE
2291C
2292C               *****************************************
2293C               **   STEP 4B--                         **
2294C               **   CREATE VALUES FOR SILHOUETTE PLOT **
2295C               *****************************************
2296C
2297      ISTEPN='4B'
2298      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CLA2')
2299     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2300C
2301C     ONLY GENERATE SILHOUETTE PLOT POINTS IF NROW*NCOL <= 2*MAXNXT
2302C
2303      IF(NROW*NCOL.GT.2*MAXNXT)GOTO8190
2304C
2305C     COMPUTE THE s(i) VALUE AS
2306C
2307C        s(i) = (b(i) - a(i))/max{a(i),b(i)}
2308C
2309C     WHERE
2310C
2311C        a(i)   = AVERAGE DISSIMILARITY OF THE i-TH POINT WITH
2312C                 ALL OTHER POINTS IN THE CLUSTER TO WHICH IT
2313C                 BELONGS
2314C
2315C        b(i)   = LOWEST AVERAGE DISSIMILARITY OF THE i-TH POINT
2316C                 WITH ALL OTHER CLUSTERS.
2317C
2318C     USE ONE-PASS MEAN ALGORITHMS TO KEEP TRACK OF AVERAGE
2319C     DISSIMILARITY OF ALL CLUSTERS.  THE ONE-PASS FORMULA IS
2320C
2321C         M(K)=X1                            K = 1
2322C             =M(K-1) + (X(K) - M(K-1))/K    K = 2, ...., N
2323C
2324      WRITE(IOUNI4,8001)
2325 8001 FORMAT(8X,'CLUSTER',5X,'SILHOUETTE',7X,'NEIGHBOR')
2326C
2327      DO8110II=1,NROW
2328        ICLUS1=IC1(II)
2329        DO8112JJ=1,NCOL
2330          DYSMA(JJ)=XSAVE(II,JJ)
2331 8112   CONTINUE
2332        ICASPL='VEDI'
2333        DO8114KK=1,NCLUST
2334          RDNEW(KK)=CPUMIN
2335          NEW(KK)=0
2336 8114   CONTINUE
2337C
2338        DO8120JJ=1,NROW
2339          IF(II.EQ.JJ)GOTO8120
2340          ICLUS2=IC1(JJ)
2341          DO8122KK=1,NCOL
2342            DYSMB(KK)=XSAVE(JJ,KK)
2343 8122     CONTINUE
2344          CALL VECARI(DYSMA,DYSMB,NCOL,ICASPL,IWRITE,
2345     1                BETER,N3,ADIST,ITYP3,
2346     1                IBUGA3,ISUBRO,IERROR)
2347          IF(ICLUS1.EQ.ICLUS2)THEN
2348            NEW(ICLUS1)=NEW(ICLUS1)+1
2349            IF(NEW(ICLUS1).EQ.1)THEN
2350              RDNEW(ICLUS1)=ADIST
2351            ELSE
2352              TERM1=(ADIST - RDNEW(ICLUS1))/REAL(NEW(ICLUS1))
2353              RDNEW(ICLUS1)=RDNEW(ICLUS1) + TERM1
2354            ENDIF
2355          ELSE
2356            NEW(ICLUS2)=NEW(ICLUS2)+1
2357            IF(NEW(ICLUS2).EQ.1)THEN
2358              RDNEW(ICLUS2)=ADIST
2359            ELSE
2360              TERM1=(ADIST - RDNEW(ICLUS2))/REAL(NEW(ICLUS2))
2361              RDNEW(ICLUS2)=RDNEW(ICLUS2) + TERM1
2362            ENDIF
2363          ENDIF
2364 8120   CONTINUE
2365C
2366        AI=RDNEW(ICLUS1)
2367        BI=CPUMAX
2368        NEIGH=-1
2369        DO8130JJ=1,NCLUST
2370          IF(JJ.EQ.ICLUS1)GOTO8130
2371          IF(RDNEW(JJ).LT.BI)THEN
2372            BI=RDNEW(JJ)
2373            NEIGH=JJ
2374          ENDIF
2375 8130   CONTINUE
2376        SYL=(BI - AI)/MAX(AI,BI)
2377        WRITE(IOUNI4,'(3E15.7)')REAL(IC1(II)),SYL,REAL(NEIGH)
2378C
2379 8110 CONTINUE
2380 8190 CONTINUE
2381C
2382      IOP='CLOS'
2383      CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLAG4,IFLAG5,
2384     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
2385     1            IBUGA3,ISUBRO,IERROR)
2386C
2387      IF(IFEEDB.EQ.'ON')THEN
2388        WRITE(ICOUT,999)
2389        CALL DPWRST('XXX','BUG ')
2390        WRITE(ICOUT,8091)
2391 8091   FORMAT('THE CLUSTER ID VALUES ARE WRITTEN TO dpst1f.dat')
2392        CALL DPWRST('XXX','BUG ')
2393CNIST   WRITE(ICOUT,8093)
2394C8093   FORMAT('THE WITHIN-CLUSTER SUM OF SQUARES AND ',
2395CNIST1         'THE NUMBER OF POINTS')
2396CNIST   CALL DPWRST('XXX','BUG ')
2397CNIST   WRITE(ICOUT,8095)
2398C8095   FORMAT('FOR EACH CLUSTER ARE WRITTEN TO dpst2f.dat')
2399CNIST   CALL DPWRST('XXX','BUG ')
2400CNIST   WRITE(ICOUT,8097)
2401C8097   FORMAT('THE CLUSTER CENTERS ARE WRITTEN TO dpst3f.dat')
2402CNIST   CALL DPWRST('XXX','BUG ')
2403        IF(NROW*NCOL.LE.2*MAXNXT)THEN
2404          WRITE(ICOUT,8099)
2405 8099     FORMAT('THE SILHOUETTE VALUES ARE WRITTEN TO dpst4f.dat')
2406          CALL DPWRST('XXX','BUG ')
2407        ENDIF
2408      ENDIF
2409C
2410C               ******************
2411C               **   STEP 90--  **
2412C               **   EXIT       **
2413C               ******************
2414C
2415 9000 CONTINUE
2416      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CLA2')THEN
2417        WRITE(ICOUT,999)
2418        CALL DPWRST('XXX','BUG ')
2419        WRITE(ICOUT,9011)
2420 9011   FORMAT('***** AT THE END       OF DPCLA2--')
2421        CALL DPWRST('XXX','BUG ')
2422      ENDIF
2423C
2424      RETURN
2425      END
2426      SUBROUTINE DPCLCH(PX,PY,NP,PX2,PY2,NP2,X3D2,
2427     1                  PXMIN,PXMAX,PYMIN,PYMAX,
2428     1                  ISORSW,
2429     1                  IFIG,IPATT,IFONT,ICASE,IJUST,IDIR,
2430     1                  ANGLE,IFILL,ICOL,
2431     1                  PHEIGH,PWIDTH,PVEGAP,PHOGAP,PTHICK,
2432     1                  IMPSW2,AMPSCH,AMPSCW,
2433     1                  ISYMBL,ISPAC)
2434C
2435C     PURPOSE--CARRY OUT CLIPPING (IF NECESSARY) AND DRAW THE
2436C              POLYMARKERS (OR SERIES OF CLIPPED TRACES)
2437C              BASED ON THE DATA IN (PX,PY).
2438C     DANGER--THE INPUT VARIABLES PX(.) AND PY(.) MAY BE
2439C             CHANGED IN THIS SUBROUTINE (SEE STEP 0 BELOW)
2440C
2441C     WRITTEN BY--JAMES J. FILLIBEN
2442C                 STATISTICAL ENGINEERING DIVISION
2443C                 INFORMATION TECHNOLOGY LABORATORY
2444C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
2445C                 GAITHERSBURG, MD 20899-8980
2446C                 PHONE--301-975-2855
2447C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
2448C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
2449C     LANGUAGE--ANSI FORTRAN (1977)
2450C     VERSION NUMBER--83.6
2451C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY       1983.
2452C     UPDATED       --DECEMBER  1999.  SUPPORT FOR ROWID AND ROW LABEL
2453C                                      AS CHARACTERS.
2454C     UPDATED       --JANUARY   2000.  USE ISUB TO GET CORRECT VALUE
2455C                                      FOR ROWID AND ROW LABEL
2456C     UPDATED       --JANUARY   2000.  ADD X3D2 TO CALL LIST
2457C
2458C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
2459C
2460      CHARACTER*4 ISORSW
2461C
2462      CHARACTER*4 IFIG
2463      CHARACTER*24 IPATT
2464      CHARACTER*4 IFONT
2465      CHARACTER*4 ICASE
2466      CHARACTER*4 IJUST
2467      CHARACTER*4 IDIR
2468      CHARACTER*4 IFILL
2469      CHARACTER*4 ICOL
2470C
2471      CHARACTER*24 ISYMBL
2472      CHARACTER*4 ISPAC
2473      CHARACTER*4 IMPSW2
2474C
2475      CHARACTER*4 ISUBN1
2476      CHARACTER*4 ISUBN2
2477      CHARACTER*4 ISTEPN
2478C
2479C---------------------------------------------------------------------
2480C
2481      INCLUDE 'DPCOPA.INC'
2482      INCLUDE 'DPCOZI.INC'
2483      DIMENSION IROWID(MAXOBV)
2484      DIMENSION IJUNK(MAXOBV)
2485      DIMENSION IJUNK2(MAXOBV)
2486      EQUIVALENCE (IGARBG(IIGAR1),IROWID(1))
2487      EQUIVALENCE (IGARBG(IIGAR2),IJUNK(1))
2488      EQUIVALENCE (IGARBG(IIGAR3),IJUNK2(1))
2489C
2490      DIMENSION PX(*)
2491      DIMENSION PY(*)
2492C
2493      DIMENSION X3D2(*)
2494C
2495      DIMENSION PX2(*)
2496      DIMENSION PY2(*)
2497C
2498C-----COMMON----------------------------------------------------------
2499C
2500      INCLUDE 'DPCOHK.INC'
2501      INCLUDE 'DPCODA.INC'
2502      INCLUDE 'DPCOBE.INC'
2503      INCLUDE 'DPCOP2.INC'
2504C
2505C-----START POINT-----------------------------------------------------
2506C
2507      ISUBN1='DPCL'
2508      ISUBN2='CH  '
2509C
2510      XMIN=CPUMAX
2511      YMIN=CPUMAX
2512      XMAX=CPUMIN
2513      YMAX=CPUMIN
2514      J=(-999)
2515C
2516      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CLCH')THEN
2517        WRITE(ICOUT,999)
2518  999   FORMAT(1X)
2519        CALL DPWRST('XXX','BUG ')
2520        WRITE(ICOUT,51)
2521   51   FORMAT('***** AT THE BEGINNING OF DPCLCH--')
2522        CALL DPWRST('XXX','BUG ')
2523        WRITE(ICOUT,53)PXMIN,PXMAX,PYMIN,PYMAX
2524   53   FORMAT('PXMIN,PXMAX,PYMIN,PYMAX = ',4F10.5)
2525        CALL DPWRST('XXX','BUG ')
2526        WRITE(ICOUT,54)IBUGG4,ISUBG4,IERRG4,ISORSW,NP
2527   54   FORMAT('IBUGG4,ISUBG4,IERRG4,ISORSW,NP = ',4(A4,2X),I8)
2528        CALL DPWRST('XXX','BUG ')
2529        DO62I=1,NP
2530          DEL1=PX(I)-PXMIN
2531          DEL2=PX(I)-PXMAX
2532          DEL3=PY(I)-PYMIN
2533          DEL4=PY(I)-PYMAX
2534          WRITE(ICOUT,63)I,PX(I),PY(I)
2535   63     FORMAT('I,PX(I),PY(I)         = ',I8,2G15.7)
2536          CALL DPWRST('XXX','BUG ')
2537          WRITE(ICOUT,64)I,DEL1,DEL2,DEL3,DEL4
2538   64     FORMAT('I,DEL1,DEL2,DEL3,DEL4 = ',I8,4E15.7)
2539          CALL DPWRST('XXX','BUG ')
2540   62   CONTINUE
2541      ENDIF
2542C
2543C               ******************************************************
2544C               **  STEP 0B--                                        *
2545C               **  SET VALUES OF IJUNK TO VALUES OF ISUB = 1.       *
2546C               **  USED TO GET PROPER INDEX FOR ROWID               *
2547C               ******************************************************
2548C
2549      DO81I=1,MAXOBV
2550        IJUNK(I)=0
2551        IJUNK2(I)=0
2552        IROWID(I)=I
2553   81 CONTINUE
2554      J=0
2555      DO83I=1,MAXOBV
2556        IF(ISUB(I).EQ.1)THEN
2557          J=J+1
2558          IJUNK(J)=I
2559          IF(J.GE.NP)GOTO89
2560        ENDIF
2561   83 CONTINUE
2562   89 CONTINUE
2563C
2564C               ********************************************************
2565C               **  STEP 0--                                           *
2566C               **  IF NECESSARY, ADJUST (= CHANGE) THE PX(.) AND      *
2567C               **  PY(.) VALUES TO ALLOW FOR POSSIBLE ROUNDOFF NEAR   *
2568C               **  THE LIMITS (PXMIN,PXMAX) AND (PYMIN,PYMAX) WHICH   *
2569C               **  WOULD SHOW UP AS A DATA POINT NOT BEING PLOTTED    *
2570C               **  WHEN IT SHOULD HAVE BEEN                           *
2571C               ********************************************************
2572C
2573      CALL DPSQUE(PX,PY,NP,
2574     1PXMIN,PXMAX,PYMIN,PYMAX)
2575C
2576C               *************************************************
2577C               **  STEP 1--                                   **
2578C               **  DETERMINE THE FIRST AND LAST ELEMENTS OF   **
2579C               **  THE (PX,PY) VECTORS WHICH MUST BE SCANNED  **
2580C               **  BASED ON WHETHER PX(.) IS SORTED           **
2581C               **  OR NOT.                                    **
2582C               *************************************************
2583C
2584      ISTEPN='1'
2585      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CLCH')
2586     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2587C
2588      IF(ISORSW.EQ.'ON')THEN
2589        DO1110I=1,NP
2590          I2=I
2591          IF(PX(I).GE.PXMIN)THEN
2592            IMIN=I2
2593            GOTO1119
2594          ENDIF
2595 1110   CONTINUE
2596        IMIN=NP+1
2597 1119   CONTINUE
2598C
2599        DO1120I=1,NP
2600          IREV=NP-I+1
2601          IF(PX(IREV).LE.PXMAX)THEN
2602            IMAX=IREV
2603            GOTO1129
2604          ENDIF
2605 1120   CONTINUE
2606        IMAX=0
2607 1129   CONTINUE
2608C
2609      ELSE
2610        IMIN=1
2611        IMAX=NP
2612      ENDIF
2613C
2614      IF(IMIN.GT.IMAX)GOTO9000
2615C
2616C               ********************************************************
2617C               **  STEP 2--                                          **
2618C               **  COMPUTE THE HORIZONTAL AXIS VARIABLE MIN AND MAX  **
2619C               **  FOR THE DATA WITHIN THE SUBSET                    **
2620C               ********************************************************
2621C
2622      ISTEPN='2'
2623      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CLCH')
2624     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2625C
2626      IF(ISORSW.EQ.'ON')THEN
2627        XMIN=PX(IMIN)
2628        XMAX=PX(IMAX)
2629      ELSE
2630        XMIN=CPUMAX
2631        XMAX=CPUMIN
2632        DO1260I=IMIN,IMAX
2633          IF(PX(I).LT.XMIN)XMIN=PX(I)
2634          IF(PX(I).GT.XMAX)XMAX=PX(I)
2635 1260   CONTINUE
2636      ENDIF
2637C
2638C               ******************************************************
2639C               **  STEP 3--                                        **
2640C               **  COMPUTE THE VERTICAL AXIS VARIABLE MIN AND MAX  **
2641C               **  FOR THE DATA WITHIN THE SUBSET                  **
2642C               ******************************************************
2643C
2644      ISTEPN='3'
2645      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CLCH')
2646     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2647C
2648      YMIN=CPUMAX
2649      YMAX=CPUMIN
2650      DO1300I=IMIN,IMAX
2651        IF(PY(I).LT.YMIN)YMIN=PY(I)
2652        IF(PY(I).GT.YMAX)YMAX=PY(I)
2653 1300 CONTINUE
2654C
2655C               *******************************************************
2656C               **  STEP 21--                                        **
2657C               **  TREAT THE MOST COMMON AND MOST IMPORTANT CASE--  **
2658C               **  ALL NP OBSERVATIONS ARE TO BE USED;              **
2659C               **  ALL X DATA ARE WITHIN THE FRAME;                 **
2660C               **  ALL Y DATA ARE WITHIN THE FRAME.                 **
2661C               *******************************************************
2662C
2663      IF(IMIN.EQ.1.AND.IMAX.EQ.NP.AND.
2664     1XMIN.GE.PXMIN.AND.XMAX.LE.PXMAX.AND.
2665     1YMIN.GE.PYMIN.AND.YMAX.LE.PYMAX)THEN
2666        ISTEPN='21'
2667        DO2101I=1,NP
2668          IROWID(I)=IJUNK(I)
2669          IJUNK2(I)=1
2670 2101   CONTINUE
2671C
2672        IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CLCH')
2673     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2674C
2675        CALL DPDRPM(PX,PY,NP,X3D2,IJUNK2,IROWID,IROWLB,
2676     1              IFIG,IPATT,IFONT,ICASE,IJUST,IDIR,ANGLE,IFILL,ICOL,
2677     1              PHEIGH,PWIDTH,PVEGAP,PHOGAP,PTHICK,
2678     1              IMPSW2,AMPSCH,AMPSCW,
2679     1              ISYMBL,ISPAC)
2680        NP2=0
2681        GOTO9000
2682      ENDIF
2683C
2684C               *******************************************************
2685C               **  STEP 22--                                        **
2686C               **  TREAT THE NEXT MOST COMMON AND MOST IMPORTANT CASE--  **
2687C               **  A SUBSET OF THE NP OBSERVATIONS ARE TO BE USED;  **
2688C               **  ALL X DATA ARE WITHIN THE FRAME;                 **
2689C               **  ALL Y DATA ARE WITHIN THE FRAME.                 **
2690C               *******************************************************
2691C
2692      IF(XMIN.GE.PXMIN.AND.XMAX.LE.PXMAX.AND.
2693     1YMIN.GE.PYMIN.AND.YMAX.LE.PYMAX)THEN
2694        ISTEPN='22'
2695C
2696        IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CLCH')
2697     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2698C
2699        J=0
2700        DO2210I=IMIN,IMAX
2701          J=J+1
2702          PX2(J)=PX(I)
2703          PY2(J)=PY(I)
2704          IROWID(J)=IJUNK(I)
2705          IJUNK2(I)=1
2706 2210   CONTINUE
2707        NP2=J
2708        IF(NP2.GE.1)
2709     1    CALL DPDRPM(PX2,PY2,NP2,X3D2,IJUNK2,IROWID,IROWLB,
2710     1                IFIG,IPATT,IFONT,ICASE,IJUST,IDIR,ANGLE,
2711     1                IFILL,ICOL,
2712     1                PHEIGH,PWIDTH,PVEGAP,PHOGAP,PTHICK,
2713     1                IMPSW2,AMPSCH,AMPSCW,
2714     1                ISYMBL,ISPAC)
2715        GOTO9000
2716      ENDIF
2717C
2718C               ****************************************************
2719C               **  STEP 23--                                     **
2720C               **  TREAT THE CASE WHERE THE SUBSET IS SUCH THAT  **
2721C               **  ALL X'S ARE INSIDE THE FRAME,                 **
2722C               **  BUT SOME Y'S ARE OUTSIDE THE FRAME.           **
2723C               ****************************************************
2724C
2725      IF(XMIN.GE.PXMIN.AND.XMAX.LE.PXMAX)THEN
2726C
2727        ISTEPN='23'
2728        IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CLCH')
2729     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2730C
2731        J=0
2732        DO2310I=IMIN,IMAX
2733          IM1=I-1
2734          IF(PY(I).GE.PYMIN.AND.PY(I).LE.PYMAX)THEN
2735            J=J+1
2736            PX2(J)=PX(I)
2737            PY2(J)=PY(I)
2738            IROWID(J)=IJUNK(I)
2739            IJUNK2(I)=1
2740          ELSE
2741            NP2=J
2742            IF(NP2.GE.1)
2743     1        CALL DPDRPM(PX2,PY2,NP2,X3D2,IJUNK2,IROWID,IROWLB,
2744     1                    IFIG,IPATT,IFONT,ICASE,IJUST,IDIR,ANGLE,
2745     1                    IFILL,ICOL,
2746     1                    PHEIGH,PWIDTH,PVEGAP,PHOGAP,PTHICK,
2747     1                    IMPSW2,AMPSCH,AMPSCW,
2748     1                    ISYMBL,ISPAC)
2749            J=0
2750          ENDIF
2751 2310   CONTINUE
2752C
2753        NP2=J
2754        IF(NP2.GE.1)
2755     1    CALL DPDRPM(PX2,PY2,NP2,X3D2,IJUNK2,IROWID,IROWLB,
2756     1                IFIG,IPATT,IFONT,ICASE,IJUST,IDIR,ANGLE,
2757     1                IFILL,ICOL,
2758     1                PHEIGH,PWIDTH,PVEGAP,PHOGAP,PTHICK,
2759     1                IMPSW2,AMPSCH,AMPSCW,
2760     1                ISYMBL,ISPAC)
2761        GOTO9000
2762C
2763      ENDIF
2764C
2765C               ****************************************************
2766C               **  STEP 24--                                     **
2767C               **  TREAT THE CASE WHERE THE SUBSET IS SUCH THAT  **
2768C               **  ALL Y'S ARE INSIDE THE FRAME,                 **
2769C               **  BUT SOME X'S ARE OUTSIDE THE FRAME            **
2770C               **  (AS IN THE CONSTRUCTION OF MAPS)              **
2771C               ****************************************************
2772C
2773      IF(YMIN.GE.PYMIN.AND.YMAX.LE.PYMAX)THEN
2774C
2775        ISTEPN='24'
2776        IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CLCH')
2777     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2778C
2779        J=0
2780        DO2410I=IMIN,IMAX
2781          IM1=I-1
2782          IF(PX(I).GE.PXMIN.AND.PX(I).LE.PXMAX)THEN
2783            J=J+1
2784            PX2(J)=PX(I)
2785            PY2(J)=PY(I)
2786            IROWID(J)=IJUNK(I)
2787            IJUNK2(I)=1
2788          ELSE
2789            NP2=J
2790            IF(NP2.GE.1)
2791     1        CALL DPDRPM(PX2,PY2,NP2,X3D2,IJUNK2,IROWID,IROWLB,
2792     1                    IFIG,IPATT,IFONT,ICASE,IJUST,IDIR,ANGLE,
2793     1                    IFILL,ICOL,
2794     1                    PHEIGH,PWIDTH,PVEGAP,PHOGAP,PTHICK,
2795     1                    IMPSW2,AMPSCH,AMPSCW,
2796     1                    ISYMBL,ISPAC)
2797            J=0
2798          ENDIF
2799C
2800 2410   CONTINUE
2801C
2802        NP2=J
2803        IF(NP2.GE.1)
2804     1    CALL DPDRPM(PX2,PY2,NP2,X3D2,IJUNK2,IROWID,IROWLB,
2805     1                IFIG,IPATT,IFONT,ICASE,IJUST,IDIR,ANGLE,
2806     1                IFILL,ICOL,
2807     1                PHEIGH,PWIDTH,PVEGAP,PHOGAP,PTHICK,
2808     1                IMPSW2,AMPSCH,AMPSCW,
2809     1                ISYMBL,ISPAC)
2810        GOTO9000
2811C
2812      ENDIF
2813C
2814C               ****************************************************
2815C               **  STEP 25--                                     **
2816C               **  TREAT THE GENERAL CASE WHERE THE SUBSET IS SUCH THAT  **
2817C               **  SOME  X'S MAY BE OUTSIDE THE FRAME, AND/OR    **
2818C               **  SOME  Y'S MAY BE OUTSIDE THE FRAME            **
2819C               **  (AS IN THE CONSTRUCTION OF MAPS)              **
2820C               ****************************************************
2821C
2822      ISTEPN='25'
2823      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CLCH')
2824     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2825C
2826      J=0
2827      DO2510I=IMIN,IMAX
2828        IM1=I-1
2829        IF(PX(I).GE.PXMIN.AND.PX(I).LE.PXMAX.AND.
2830     1     PY(I).GE.PYMIN.AND.PY(I).LE.PYMAX)THEN
2831          J=J+1
2832          PX2(J)=PX(I)
2833          PY2(J)=PY(I)
2834          IROWID(J)=IJUNK(I)
2835          IJUNK2(I)=1
2836        ELSE
2837          NP2=J
2838          IF(NP2.GE.1)
2839     1      CALL DPDRPM(PX2,PY2,NP2,X3D2,IJUNK2,IROWID,IROWLB,
2840     1                  IFIG,IPATT,IFONT,ICASE,IJUST,IDIR,ANGLE,
2841     1                  IFILL,ICOL,
2842     1                  PHEIGH,PWIDTH,PVEGAP,PHOGAP,PTHICK,
2843     1                  IMPSW2,AMPSCH,AMPSCW,
2844     1                  ISYMBL,ISPAC)
2845          J=0
2846        ENDIF
2847 2510 CONTINUE
2848C
2849      NP2=J
2850      IF(NP2.GE.1)
2851     1  CALL DPDRPM(PX2,PY2,NP2,X3D2,IJUNK2,IROWID,IROWLB,
2852     1              IFIG,IPATT,IFONT,ICASE,IJUST,IDIR,ANGLE,
2853     1              IFILL,ICOL,
2854     1              PHEIGH,PWIDTH,PVEGAP,PHOGAP,PTHICK,
2855     1              IMPSW2,AMPSCH,AMPSCW,
2856     1              ISYMBL,ISPAC)
2857      GOTO9000
2858C
2859C               *****************
2860C               **  STEP 90--  **
2861C               **  EXIT.      **
2862C               *****************
2863C
2864 9000 CONTINUE
2865      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CLCH')THEN
2866        WRITE(ICOUT,999)
2867        CALL DPWRST('XXX','BUG ')
2868        WRITE(ICOUT,9011)
2869 9011   FORMAT('***** AT THE END       OF DPCLCH--')
2870        CALL DPWRST('XXX','BUG ')
2871        WRITE(ICOUT,9013)PXMIN,PXMAX,PYMIN,PYMAX
2872 9013   FORMAT('PXMIN,PXMAX,PYMIN,PYMAX = ',4F10.5)
2873        CALL DPWRST('XXX','BUG ')
2874        WRITE(ICOUT,9017)IMIN,IMAX,J,NP,NP2
2875 9017   FORMAT('IMIN,IMAX,J,NP,NP2 = ',5I8)
2876        CALL DPWRST('XXX','BUG ')
2877        WRITE(ICOUT,9018)XMIN,XMAX,YMIN,YMAX
2878 9018   FORMAT('XMIN,XMAX,YMIN,YMAX = ',4G15.7)
2879        CALL DPWRST('XXX','BUG ')
2880        DO9022I=1,NP
2881          DEL1=PX(I)-PXMIN
2882          DEL2=PX(I)-PXMAX
2883          DEL3=PY(I)-PYMIN
2884          DEL4=PY(I)-PYMAX
2885          WRITE(ICOUT,9023)I,PX(I),PY(I)
2886 9023     FORMAT('I,PX(I),PY(I)         = ',I8,2G15.7)
2887          CALL DPWRST('XXX','BUG ')
2888          WRITE(ICOUT,9024)I,DEL1,DEL2,DEL3,DEL4
2889 9024     FORMAT('I,DEL1,DEL2,DEL3,DEL4 = ',I8,4E15.7)
2890          CALL DPWRST('XXX','BUG ')
2891 9022   CONTINUE
2892        IF(NP2.GT.0)THEN
2893          DO9032I=1,NP2
2894            WRITE(ICOUT,9033)I,PX2(I),PY2(I)
2895 9033       FORMAT('I,PX2(I),YP2(I) = ',I8,2G15.7)
2896            CALL DPWRST('XXX','BUG ')
2897 9032     CONTINUE
2898        ENDIF
2899        WRITE(ICOUT,9039)IBUGG4,ISUBG4,IERRG4
2900 9039   FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
2901        CALL DPWRST('XXX','BUG ')
2902      ENDIF
2903C
2904      RETURN
2905      END
2906      SUBROUTINE DPCLDE
2907C
2908C     PURPOSE--CLOSE A GRAPHICS DEVICE
2909C
2910C
2911C     WRITTEN BY--JAMES J. FILLIBEN
2912C                 STATISTICAL ENGINEERING DIVISION
2913C                 INFORMATION TECHNOLOGY LABORATORY
2914C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
2915C                 GAITHERSBURG, MD 20899-8980
2916C                 PHONE--301-975-2855
2917C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
2918C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
2919C     LANGUAGE--ANSI FORTRAN (1977)
2920C     VERSION NUMBER--83.6
2921C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY       1983.
2922C
2923C-----COMMON----------------------------------------------------------
2924C
2925      INCLUDE 'DPCOGR.INC'
2926      INCLUDE 'DPCOBE.INC'
2927      INCLUDE 'DPCOP2.INC'
2928C
2929C-----START POINT-----------------------------------------------------
2930C
2931      IERRG4='NO'
2932C
2933      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CLDE')GOTO90
2934      WRITE(ICOUT,999)
2935  999 FORMAT(1X)
2936      CALL DPWRST('XXX','BUG ')
2937      WRITE(ICOUT,51)
2938   51 FORMAT('***** AT THE BEGINNING OF DPCLDE--')
2939      CALL DPWRST('XXX','BUG ')
2940      WRITE(ICOUT,52)IMANUF,IMODEL,IMODE2,IMODE3
2941   52 FORMAT('IMANUF,IMODEL,IMODE2,IMODE3 = ',A4,2X,A4,2X,A4,2X,A4)
2942      CALL DPWRST('XXX','BUG ')
2943      WRITE(ICOUT,53)IGUNIT,IGCODE
2944   53 FORMAT('IGUNIT,IGCODE = ',I8,2X,A4)
2945      CALL DPWRST('XXX','BUG ')
2946      WRITE(ICOUT,54)ISOFT,ISOFT2,ISOFT3
2947   54 FORMAT('ISOFT,ISOFT2,ISOFT3 = ',A4,2X,A4,2X,A4)
2948      CALL DPWRST('XXX','BUG ')
2949      WRITE(ICOUT,55)IGBAUD
2950   55 FORMAT('IGBAUD = ',I8)
2951      CALL DPWRST('XXX','BUG ')
2952      WRITE(ICOUT,56)IBUGG4,ISUBG4,IERRG4
2953   56 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
2954      CALL DPWRST('XXX','BUG ')
2955   90 CONTINUE
2956C
2957C               ******************************
2958C               **  STEP 1--                **
2959C               **  CLOSE GRAPHICS SOFTWARE **
2960C               ******************************
2961C
2962CCCCC CALL GRCLSO
2963C
2964C               *****************************
2965C               **  STEP 2--               **
2966C               **  CLOSE GRAPHICS DEVICES  **
2967C               *****************************
2968C
2969      CALL GRCLDE
2970C
2971C               *****************
2972C               **  STEP 90--  **
2973C               **  EXIT       **
2974C               *****************
2975C
2976      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CLDE')GOTO9090
2977      WRITE(ICOUT,999)
2978      CALL DPWRST('XXX','BUG ')
2979      WRITE(ICOUT,9011)
2980 9011 FORMAT('***** AT THE END       OF DPCLDE--')
2981      CALL DPWRST('XXX','BUG ')
2982      WRITE(ICOUT,9012)IMANUF,IMODEL,IMODE2,IMODE3
2983 9012 FORMAT('IMANUF,IMODEL,IMODE2,IMODE3 = ',A4,2X,A4,2X,A4,2X,A4)
2984      CALL DPWRST('XXX','BUG ')
2985      WRITE(ICOUT,9013)IGUNIT,IGCODE
2986 9013 FORMAT('IGUNIT,IGCODE = ',I8,2X,A4)
2987      CALL DPWRST('XXX','BUG ')
2988      WRITE(ICOUT,9014)ISOFT,ISOFT2,ISOFT3
2989 9014 FORMAT('ISOFT,ISOFT2,ISOFT3 = ',A4,2X,A4,2X,A4)
2990      CALL DPWRST('XXX','BUG ')
2991      WRITE(ICOUT,9015)IGBAUD
2992 9015 FORMAT('IGBAUD = ',I8)
2993      CALL DPWRST('XXX','BUG ')
2994      WRITE(ICOUT,9016)IBUGG4,ISUBG4,IERRG4
2995 9016 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
2996      CALL DPWRST('XXX','BUG ')
2997 9090 CONTINUE
2998C
2999      RETURN
3000      END
3001      SUBROUTINE DPCLLO(IHARG,IARGT,ARG,NUMARG,
3002     1CLLIMI,IFOUND,IERROR)
3003C
3004C     PURPOSE--DEFINE THE LOWER BOUND OF THE LEFT-MOST CLASS
3005C              FOR HORIZONTAL VARIABLE OR VERTICAL VARIABLE OR BOTH
3006C              FOR DISTRIBUTIONAL PLOTS (E.G., HISTOGRAMS).
3007C              THE 2 LOWER LIMITS (ONE FOR THE X AXIS VARIABLE
3008C              AND ONE FOR THE Y AXIS VARIABLE)
3009C              ARE CONTAINED IN THE FIRST AND THIRD ELEMENTS OF THE
3010C              4-ELEMENT VECTOR CLLIMI(.).
3011C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
3012C                     --IARGT  (A  HOLLERITH VECTOR)
3013C                     --ARG    (A  FLOATING POINT VECTOR)
3014C                     --NUMARG
3015C     OUTPUT ARGUMENTS--CLLIMI (A 4-ELEMENT FLOATING POINT VECTOR
3016C                              IN WHICH EACH ELEMENT IS AS FOLLOWS--
3017C                                 1) LOWER BOUND FOR HORIZONTAL VARIABLE
3018C                                 2) UPPER BOUND FOR HORIZONTAL VARIABLE
3019C                                    (NOT AFFECTED)
3020C                                 3) LOWER BOUND FOR VERTICAL   VARIABLE
3021C                                 4) UPPER BOUND FOR VERTICAL   VARIABLE
3022C                                    (NOT AFFECTED)
3023C                     --IFOUND ('YES' OR 'NO' )
3024C                     --IERROR ('YES' OR 'NO' )
3025C     WRITTEN BY--JAMES J. FILLIBEN
3026C                 STATISTICAL ENGINEERING DIVISION
3027C                 INFORMATION TECHNOLOGY LABORATORY
3028C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
3029C                 GAITHERSBURG, MD 20899-8980
3030C                 PHONE--301-975-2855
3031C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
3032C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
3033C     LANGUAGE--ANSI FORTRAN (1977)
3034C     VERSION NUMBER--82/7
3035C     ORIGINAL VERSION--NOVEMBER  1978.
3036C     UPDATED         --SEPTEMBER 1980.
3037C     UPDATED         --MAY       1981.
3038C     UPDATED         --MAY       1982.
3039C
3040C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
3041C
3042      CHARACTER*4 IHARG
3043      CHARACTER*4 IARGT
3044      CHARACTER*4 IFOUND
3045      CHARACTER*4 IERROR
3046C
3047C---------------------------------------------------------------------
3048C
3049      DIMENSION IHARG(*)
3050      DIMENSION IARGT(*)
3051      DIMENSION ARG(*)
3052C
3053      DIMENSION CLLIMI(4)
3054C
3055C---------------------------------------------------------------------
3056C
3057      INCLUDE 'DPCOP2.INC'
3058C
3059C-----START POINT-----------------------------------------------------
3060C
3061      IFOUND='NO'
3062      IERROR='NO'
3063C
3064C               ************************************************************
3065C               **  TREAT THE CASE WHEN                                   **
3066C               **  THE HORIZONTAL VARIABLE LOWER BOUND IS TO BE CHANGED  **
3067C               ************************************************************
3068C
3069      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'XLOW')GOTO1100
3070      GOTO1199
3071C
3072 1100 CONTINUE
3073      IF(NUMARG.EQ.1)GOTO1110
3074      IF(IARGT(NUMARG).EQ.'NUMB')GOTO1120
3075      GOTO1110
3076C
3077 1110 CONTINUE
3078      IFOUND='YES'
3079      CLLIMI(1)=CPUMIN
3080C
3081      IF(IFEEDB.EQ.'OFF')GOTO1119
3082      WRITE(ICOUT,999)
3083  999 FORMAT(1X)
3084      CALL DPWRST('XXX','BUG ')
3085      WRITE(ICOUT,1115)
3086 1115 FORMAT('THE HORIZONTAL AXIS VARIABLE LOWER BOUND ')
3087      CALL DPWRST('XXX','BUG ')
3088      WRITE(ICOUT,1116)
3089 1116 FORMAT('(FOR DISTRIBUTIONAL PLOTS) HAS JUST BEEN SET')
3090      CALL DPWRST('XXX','BUG ')
3091      WRITE(ICOUT,1117)
3092 1117 FORMAT('SO THAT IT WILL BE    XBAR - 6*XSD')
3093      CALL DPWRST('XXX','BUG ')
3094 1119 CONTINUE
3095      GOTO1900
3096C
3097 1120 CONTINUE
3098      IFOUND='YES'
3099      CLLIMI(1)=ARG(NUMARG)
3100C
3101      IF(IFEEDB.EQ.'OFF')GOTO1129
3102      WRITE(ICOUT,999)
3103      CALL DPWRST('XXX','BUG ')
3104      WRITE(ICOUT,1125)
3105 1125 FORMAT('THE HORIZONTAL AXIS VARIABLE LOWER BOUND ')
3106      CALL DPWRST('XXX','BUG ')
3107      WRITE(ICOUT,1126)
3108 1126 FORMAT('(FOR DISTRIBUTIONAL PLOTS) HAS JUST BEEN SET')
3109      CALL DPWRST('XXX','BUG ')
3110      WRITE(ICOUT,1127)CLLIMI(1)
3111 1127 FORMAT('TO ',E15.7)
3112      CALL DPWRST('XXX','BUG ')
3113 1129 CONTINUE
3114      GOTO1900
3115C
3116 1199 CONTINUE
3117C
3118C               ************************************************************
3119C               **  TREAT THE CASE WHEN                                   **
3120C               **  THE VERTICAL   VARIABLE LOWER BOUND IS TO BE CHANGED  **
3121C               ************************************************************
3122C
3123      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'YLOW')GOTO1200
3124      GOTO1299
3125C
3126 1200 CONTINUE
3127      IF(NUMARG.EQ.1)GOTO1210
3128      IF(IARGT(NUMARG).EQ.'NUMB')GOTO1220
3129      GOTO1210
3130C
3131 1210 CONTINUE
3132      IFOUND='YES'
3133      CLLIMI(3)=CPUMIN
3134C
3135      IF(IFEEDB.EQ.'OFF')GOTO1219
3136      WRITE(ICOUT,999)
3137      CALL DPWRST('XXX','BUG ')
3138      WRITE(ICOUT,1215)
3139 1215 FORMAT('THE VERTICAL AXIS VARIABLE LOWER BOUND ')
3140      CALL DPWRST('XXX','BUG ')
3141      WRITE(ICOUT,1216)
3142 1216 FORMAT('(FOR DISTRIBUTIONAL PLOTS) HAS JUST BEEN SET')
3143      CALL DPWRST('XXX','BUG ')
3144      WRITE(ICOUT,1217)
3145 1217 FORMAT('SO THAT IT WILL BE    YBAR - 6*YSD')
3146      CALL DPWRST('XXX','BUG ')
3147 1219 CONTINUE
3148      GOTO1900
3149C
3150 1220 CONTINUE
3151      IFOUND='YES'
3152      CLLIMI(3)=ARG(NUMARG)
3153C
3154      IF(IFEEDB.EQ.'OFF')GOTO1229
3155      WRITE(ICOUT,999)
3156      CALL DPWRST('XXX','BUG ')
3157      WRITE(ICOUT,1225)
3158 1225 FORMAT('THE VERTICAL AXIS VARIABLE LOWER BOUND ')
3159      CALL DPWRST('XXX','BUG ')
3160      WRITE(ICOUT,1226)
3161 1226 FORMAT('(FOR DISTRIBUTIONAL PLOTS) HAS JUST BEEN SET')
3162      CALL DPWRST('XXX','BUG ')
3163      WRITE(ICOUT,1227)CLLIMI(3)
3164 1227 FORMAT('TO ',E15.7)
3165      CALL DPWRST('XXX','BUG ')
3166 1229 CONTINUE
3167      GOTO1900
3168C
3169 1299 CONTINUE
3170C
3171C               ************************************************************
3172C               **  TREAT THE CASE WHEN                                   **
3173C               **  THE LOWER BOUNDS FOR BOTH VARIABLES ARE TO BE CHANGED **
3174C               ************************************************************
3175C
3176      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'XYLO')GOTO1300
3177      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'YXLO')GOTO1300
3178      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'LOWE')GOTO1300
3179      GOTO1399
3180C
3181 1300 CONTINUE
3182      IF(NUMARG.EQ.1)GOTO1310
3183      IF(IARGT(NUMARG).EQ.'NUMB')GOTO1320
3184      GOTO1310
3185C
3186 1310 CONTINUE
3187      IFOUND='YES'
3188      CLLIMI(1)=CPUMIN
3189      CLLIMI(3)=CPUMIN
3190C
3191      IF(IFEEDB.EQ.'OFF')GOTO1319
3192      WRITE(ICOUT,999)
3193      CALL DPWRST('XXX','BUG ')
3194      WRITE(ICOUT,1315)
3195 1315 FORMAT('THE LOWER BOUNDS (FOR DISTRIBUTIONAL PLOTS) ')
3196      CALL DPWRST('XXX','BUG ')
3197      WRITE(ICOUT,1316)
3198 1316 FORMAT('FOR BOTH VARIABLES HAVE JUST BEEN SET')
3199      CALL DPWRST('XXX','BUG ')
3200      WRITE(ICOUT,1317)
3201 1317 FORMAT('SO THAT THEY WILL BE    AVERAGE - 6*SD')
3202      CALL DPWRST('XXX','BUG ')
3203 1319 CONTINUE
3204      GOTO1900
3205C
3206 1320 CONTINUE
3207      IFOUND='YES'
3208      CLLIMI(1)=ARG(NUMARG)
3209      CLLIMI(3)=ARG(NUMARG)
3210C
3211      IF(IFEEDB.EQ.'OFF')GOTO1329
3212      WRITE(ICOUT,999)
3213      CALL DPWRST('XXX','BUG ')
3214      WRITE(ICOUT,1325)
3215 1325 FORMAT('THE LOWER BOUNDS (FOR DISTRIBUTIONAL PLOTS) ')
3216      CALL DPWRST('XXX','BUG ')
3217      WRITE(ICOUT,1326)
3218 1326 FORMAT('FOR BOTH VARIABLES HAVE JUST BEEN SET')
3219      CALL DPWRST('XXX','BUG ')
3220      WRITE(ICOUT,1327)CLLIMI(1)
3221 1327 FORMAT('TO ',E15.7)
3222      CALL DPWRST('XXX','BUG ')
3223 1329 CONTINUE
3224      GOTO1900
3225C
3226 1399 CONTINUE
3227C
3228 1900 CONTINUE
3229      RETURN
3230      END
3231      SUBROUTINE DPCLOS(IBUGA3,ISUBRO,IFOUND,IERROR)
3232C
3233C     PURPOSE--SUPPORTS THE FOLLOWING COMMAND:
3234C
3235C                 LET IFLAG = CLOSE <UNIT>
3236C                 LET IFLAG = CLOSE DELETE <UNIT>
3237C
3238C              WHERE IFLAG IS SET TO THE STATUS VALUE FROM THE CLOSE.
3239C     WRITTEN BY--ALAN HECKERT
3240C                 STATISTICAL ENGINEERING DIVISION
3241C                 INFORMATION TECHNOLOGY LABORATORY
3242C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
3243C                 GAITHERSBURG, MD 20899-8980
3244C                 PHONE--301-975-2899
3245C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
3246C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
3247C     LANGUAGE--ANSI FORTRAN (1977)
3248C     VERSION NUMBER--2016/06
3249C     ORIGINAL VERSION--JUNE      2016.
3250C
3251C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
3252C
3253      CHARACTER*4 IBUGA3
3254      CHARACTER*4 ISUBRO
3255      CHARACTER*4 IFOUND
3256      CHARACTER*4 IERROR
3257C
3258      CHARACTER*4 IHLEFT
3259      CHARACTER*4 IHLEF2
3260      CHARACTER*4 NEWNAM
3261      CHARACTER*4 NEWCOL
3262      CHARACTER*4 ISUBN0
3263      CHARACTER*4 ISUBN1
3264      CHARACTER*4 ISUBN2
3265      CHARACTER*4 ISTEPN
3266      CHARACTER*4 IEXIST
3267      CHARACTER*4 IFILSV
3268C
3269C ---------------------------------------------------------------------
3270C
3271C
3272      INCLUDE 'DPCOPA.INC'
3273      INCLUDE 'DPCOHK.INC'
3274      INCLUDE 'DPCODA.INC'
3275      INCLUDE 'DPCOST.INC'
3276C
3277C-----COMMON VARIABLES (GENERAL)--------------------------------------
3278C
3279      INCLUDE 'DPCOP2.INC'
3280C
3281C-----START POINT-----------------------------------------------------
3282C
3283      ISUBN0='CLOS'
3284      ISUBN1='DPCL'
3285      ISUBN2='OS  '
3286      IFOUND='YES'
3287      IERROR='NO'
3288      IEXIST='NO'
3289      IFILSV=IFILQU
3290      IFILQU='ON'
3291C
3292      IVAL=0
3293C
3294      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CLOS')THEN
3295        WRITE(ICOUT,999)
3296  999   FORMAT(1X)
3297        CALL DPWRST('XXX','BUG ')
3298        WRITE(ICOUT,51)
3299   51   FORMAT('***** AT THE BEGINNING OF DPCLOS--')
3300        CALL DPWRST('XXX','BUG ')
3301      ENDIF
3302C
3303C               ****************************************************
3304C               **  STEP 1--                                      **
3305C               **  CHECK FOR VALID COMMAND.                      **
3306C               ****************************************************
3307C
3308      ISTEPN='1'
3309      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CLOS')
3310     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3311C
3312      IF(IHARG(2).NE.'=' .OR. IHARG(3).NE.'CLOS')THEN
3313        WRITE(ICOUT,999)
3314        CALL DPWRST('XXX','BUG ')
3315        WRITE(ICOUT,101)
3316  101   FORMAT('***** ERROR IN CLOSE COMMAND--')
3317        CALL DPWRST('XXX','BUG ')
3318        WRITE(ICOUT,103)
3319  103   FORMAT('      INVALID FORM FOR THE COMMAND.')
3320        CALL DPWRST('XXX','BUG ')
3321        IERROR='YES'
3322        GOTO9000
3323      ENDIF
3324C
3325C               *********************************************************
3326C               **  STEP 2--                                            *
3327C               **  EXAMINE THE LEFT-HAND SIDE--                        *
3328C               **  IS THE PARAMETER NAME TO LEFT OF = SIGN             *
3329C               **  ALREADY IN THE NAME LIST?                           *
3330C               **  NOTE THAT     IHLEFT    IS THE NAME OF THE VARIABLE *
3331C               **  ON THE LEFT.                                        *
3332C               **  NOTE THAT     ILISTL    IS THE LINE IN THE TABLE    *
3333C               **  OF THE NAME ON THE LEFT.                            *
3334C               **  NOTE THAT     ICOLL    IS THE DATA COLUMN (1 TO 12) *
3335C               **  FOR THE NAME OF THE LEFT.                           *
3336C               *********************************************************
3337C
3338      ISTEPN='2'
3339      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CLOS')
3340     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3341C
3342      NEWNAM='NO'
3343      NEWCOL='NO'
3344      IHLEFT=IHARG(1)
3345      IHLEF2=IHARG2(1)
3346      DO200I=1,NUMNAM
3347        I2=I
3348        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
3349          IF(IUSE(I).EQ.'P')THEN
3350            ILISTL=I2
3351            GOTO290
3352          ELSE
3353            WRITE(ICOUT,999)
3354            CALL DPWRST('XXX','BUG ')
3355            WRITE(ICOUT,101)
3356            CALL DPWRST('XXX','BUG ')
3357            WRITE(ICOUT,201)
3358  201       FORMAT('      THE NAME ON THE LEFT HAND SIDE WAS FOUND IN')
3359            CALL DPWRST('XXX','BUG ')
3360            WRITE(ICOUT,202)
3361  202       FORMAT('      THE NAME TABLE, BUT NOT AS A PARAMETER.')
3362            CALL DPWRST('XXX','BUG ')
3363            IERROR='YES'
3364            GOTO9000
3365          ENDIF
3366        ENDIF
3367  200 CONTINUE
3368C
3369      ISTEPN='2B'
3370      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CLOS')
3371     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3372C
3373      NEWNAM='YES'
3374      ILISTL=NUMNAM+1
3375      IF(ILISTL.GT.MAXNAM)THEN
3376        WRITE(ICOUT,999)
3377        CALL DPWRST('XXX','BUG ')
3378        WRITE(ICOUT,101)
3379        CALL DPWRST('XXX','BUG ')
3380        WRITE(ICOUT,222)
3381  222   FORMAT('      THE NUMBER OF VARIABLE AND/OR PARAMETER NAMES ',
3382     1         'HAS JUST')
3383        CALL DPWRST('XXX','BUG ')
3384        WRITE(ICOUT,223)MAXNAM
3385  223   FORMAT('      EXCEEDED THE MAX ALLOWABLE ',I8,'  .  ')
3386        CALL DPWRST('XXX','BUG ')
3387        IERROR='YES'
3388        GOTO9000
3389      ENDIF
3390C
3391  290 CONTINUE
3392C               ********************************************************
3393C               **  STEP 3--                                          **
3394C               **  EXTRACT THE UNIT NUMBER                           **
3395C               ********************************************************
3396C
3397      ISTEPN='3'
3398      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CLOS')
3399     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3400C
3401      IF(IHARG(4).EQ.'DELE')THEN
3402        IWORD=5
3403        IFLAG=1
3404      ELSE
3405        IWORD=4
3406        IFLAG=0
3407      ENDIF
3408C
3409      IF(IARGT(IWORD).EQ.'NUMB')THEN
3410        IUNIT=INT(ARG(IWORD)+0.1)
3411        IF(IUNIT.LT.1 .OR. IUNIT.GT.99)THEN
3412          IVAL=-1
3413        ELSE
3414          IF(IFLAG.EQ.1)THEN
3415            CLOSE(UNIT=IUNIT,STATUS='DELETE',IOSTAT=IVAL)
3416          ELSE
3417            CLOSE(UNIT=IUNIT,IOSTAT=IVAL)
3418          ENDIF
3419        ENDIF
3420      ELSE
3421        WRITE(ICOUT,999)
3422        CALL DPWRST('XXX','BUG ')
3423        WRITE(ICOUT,101)
3424        CALL DPWRST('XXX','BUG ')
3425        WRITE(ICOUT,301)
3426  301   FORMAT('      THE EXPECTED ARGUEMNT FOR THE UNIT NUMBER WAS ',
3427     1         'NOT A NUMERIC VALUE.')
3428        CALL DPWRST('XXX','BUG ')
3429        WRITE(ICOUT,303)IHARG(IWORD),IHARG2(IWORD)
3430  303   FORMAT('      THE ARGUEMNT = ',A4,A4)
3431        CALL DPWRST('XXX','BUG ')
3432      ENDIF
3433C
3434C               *******************************************
3435C               **  STEP 4--                             **
3436C               **  UPDATE THE LHS PARAMETER             **
3437C               *******************************************
3438C
3439      ISTEPN='4'
3440      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CLOS')
3441     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3442C
3443      IHNAME(ILISTL)=IHLEFT
3444      IHNAM2(ILISTL)=IHLEF2
3445      IUSE(ILISTL)='P'
3446      VALUE(ILISTL)=REAL(IVAL)
3447      IVALUE(ILISTL)=INT(VALUE(ILISTL)+0.5)
3448      IN(ILISTL)=1
3449      IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1
3450C
3451C
3452      IF(IPRINT.EQ.'ON' .AND. IFEEDB.EQ.'ON')THEN
3453        WRITE(ICOUT,999)
3454        CALL DPWRST('XXX','BUG ')
3455        WRITE(ICOUT,601)IUNIT,IHLEFT,IHLEF2,IVALUE(ILISTL)
3456  601   FORMAT('UNIT ',I8,' WAS CLOSED, THE PARAMETER ',
3457     1           A4,A4,' = ',I8)
3458        CALL DPWRST('XXX','BUG ')
3459        WRITE(ICOUT,999)
3460        CALL DPWRST('XXX','BUG ')
3461      ENDIF
3462C
3463C               ****************
3464C               **  STEP 90-- **
3465C               **  EXIT.     **
3466C               ****************
3467C
3468 9000 CONTINUE
3469C
3470      IFILQU=IFILSV
3471C
3472      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CLOS')THEN
3473        WRITE(ICOUT,999)
3474        CALL DPWRST('XXX','BUG ')
3475        WRITE(ICOUT,9011)
3476 9011   FORMAT('***** AT THE END       OF DPCLOS--')
3477        CALL DPWRST('XXX','BUG ')
3478        WRITE(ICOUT,9013)IFOUND,IERROR,IVAL
3479 9013   FORMAT('IFOUND,IERROR,IVAL = ',2(A4,2X),I8)
3480        CALL DPWRST('XXX','BUG ')
3481      ENDIF
3482C
3483      RETURN
3484      END
3485      SUBROUTINE DPCLPL(ICOPSW,NUMCOP,
3486     1PGRAXF,PGRAYF,
3487     1IGRASW,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
3488     1PDIAHE,PDIAWI,PDIAVG,PDIAHG)
3489C
3490C     PURPOSE--CARRY OUT CLOSING OPERATIONS
3491C              SUBSEQUENT TO THE GENERATION OF A PLOT.
3492C
3493C     WRITTEN BY--JAMES J. FILLIBEN
3494C                 STATISTICAL ENGINEERING DIVISION
3495C                 INFORMATION TECHNOLOGY LABORATORY
3496C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
3497C                 GAITHERSBURG, MD 20899-8980
3498C                 PHONE--301-975-2855
3499C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
3500C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
3501C     LANGUAGE--ANSI FORTRAN (1977)
3502C     VERSION NUMBER--83.6
3503C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY       1983.
3504C
3505C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
3506C
3507      CHARACTER*4 IFONT
3508C
3509      CHARACTER*4 IGRASW
3510      CHARACTER*4 ICOPSW
3511C
3512      CHARACTER*4 ICASE
3513C
3514C
3515C-----COMMON----------------------------------------------------------
3516C
3517      INCLUDE 'DPCOGR.INC'
3518      INCLUDE 'DPCOBE.INC'
3519      INCLUDE 'DPCOP2.INC'
3520C
3521C-----START POINT-----------------------------------------------------
3522C
3523      IFONT=IMANUF
3524C
3525      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CLPL')GOTO90
3526      WRITE(ICOUT,999)
3527  999 FORMAT(1X)
3528      CALL DPWRST('XXX','BUG ')
3529      WRITE(ICOUT,51)
3530   51 FORMAT('***** AT THE BEGINNING OF DPCLPL--')
3531      CALL DPWRST('XXX','BUG ')
3532      WRITE(ICOUT,52)IMANUF,IMODEL,IMODE2,IMODE3
3533   52 FORMAT('IMANUF,IMODEL,IMODE2,IMODE3 = ',A4,2X,A4,2X,A4,2X,A4)
3534      CALL DPWRST('XXX','BUG ')
3535      WRITE(ICOUT,53)IGUNIT,IGCODE
3536   53 FORMAT('IGUNIT,IGCODE = ',I8,2X,A4)
3537      CALL DPWRST('XXX','BUG ')
3538      WRITE(ICOUT,54)ISOFT,ISOFT2,ISOFT3
3539   54 FORMAT('ISOFT,ISOFT2,ISOFT3 = ',A4,2X,A4,2X,A4)
3540      CALL DPWRST('XXX','BUG ')
3541      WRITE(ICOUT,55)IGBAUD
3542   55 FORMAT('IGBAUD = ',I8)
3543      CALL DPWRST('XXX','BUG ')
3544      WRITE(ICOUT,56)IFONT
3545   56 FORMAT('IFONT = ',A4)
3546      CALL DPWRST('XXX','BUG ')
3547      WRITE(ICOUT,61)ICOPSW
3548   61 FORMAT('ICOPSW= ',A4)
3549      CALL DPWRST('XXX','BUG ')
3550      WRITE(ICOUT,62)NUMCOP
3551   62 FORMAT('NUMCOP= ',A4)
3552      CALL DPWRST('XXX','BUG ')
3553      WRITE(ICOUT,63)PGRAXF,PGRAYF
3554   63 FORMAT('PGRAXF,PGRAYF = ',2E15.7)
3555      CALL DPWRST('XXX','BUG ')
3556      WRITE(ICOUT,64)IGRASW
3557   64 FORMAT('IGRASW= ',A4)
3558      CALL DPWRST('XXX','BUG ')
3559      WRITE(ICOUT,65)PDIAXC,PDIAYC,PDIAX2,PDIAY2
3560   65 FORMAT('PDIAXC,PDIAYC,PDIAX2,PDIAY2 = ',4E15.7)
3561      CALL DPWRST('XXX','BUG ')
3562      WRITE(ICOUT,66)PDIAHE,PDIAWI
3563   66 FORMAT('PDIAHE,PDIAWI = ',2E15.7)
3564      CALL DPWRST('XXX','BUG ')
3565      WRITE(ICOUT,67)PDIAVG,PDIAHG
3566   67 FORMAT('PDIAVG,PDIAHG = ',2E15.7)
3567      CALL DPWRST('XXX','BUG ')
3568      WRITE(ICOUT,69)IBUGG4,ISUBG4,IERRG4
3569   69 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
3570      CALL DPWRST('XXX','BUG ')
3571   90 CONTINUE
3572C
3573C               ************************
3574C               **  STEP 1--          **
3575C               **  COPY THE SCREEN,  **
3576C               **  IF CALLED FOR     **
3577C               ************************
3578C
3579      IF(ICOPSW.EQ.'OFF')GOTO1190
3580      IF(NUMCOP.LE.0)GOTO1190
3581      DO1100I=1,NUMCOP
3582      CALL GRCOSC
3583 1100 CONTINUE
3584 1190 CONTINUE
3585C
3586C               *************************************************
3587C               **  STEP 2--                                   **
3588C               **  MOVE THE BEAM TO THE BOTTOM LEFT VICINITY  **
3589C               **  OF THE GRAPHICS REGION.                    **
3590C               *************************************************
3591C
3592      CALL GRMOBE(PGRAXF,PGRAYF)
3593C
3594C               **********************************************
3595C               **  STEP 4--                                **
3596C               **  TRANSLATE THE CHARACTER REPRESENTATION  **
3597C               **  OF THE DIALOGUE MODE BEAM SIZE          **
3598C               **  INTO A NUMERIC REPRESENTATION           **
3599C               **  WHICH CAN BE UNDERSTOOD BY THE          **
3600C               **  GRAPHICS DEVICE.                        **
3601C               **********************************************
3602C
3603      ICASE='MARK'
3604C
3605      PHEIGH=PDIAHE
3606      PWIDTH=PDIAWI
3607      PVEGAP=PDIAVG
3608      PHOGAP=PDIAHG
3609      CALL GRTRSI(ICASE,IFONT,PHEIGH,PWIDTH,PVEGAP,PHOGAP,
3610     1JSIZE,
3611     1JHEIG2,JWIDT2,JVEGA2,JHOGA2,
3612     1PHEIG2,PWIDT2,PVEGA2,PHOGA2)
3613C
3614C               ************************************
3615C               **  STEP 5--                      **
3616C               **  SET THE DIALOGUE MODE SIZE    **
3617C               **  ON THE GRAPHICS DEVICE.       **
3618C               ************************************
3619C
3620      CALL GRSESI(ICASE,IFONT,PHEIGH,PWIDTH,PVEGAP,PHOGAP,
3621     1JSIZE,
3622     1JHEIG2,JWIDT2,JVEGA2,JHOGA2,
3623     1PHEIG2,PWIDT2,PVEGA2,PHOGA2)
3624C
3625C               *************************************************
3626C               **  STEP 6--                                   **
3627C               **  MOVE THE BEAM TO THE PROPER POINT          **
3628C               **  (USUALLY IN THE LOWER LEFT)                **
3629C               **  ON THE SCREEN.                             **
3630C               *************************************************
3631C
3632      CALL GRMOBE(PDIAX2,PDIAY2)
3633      PSUM=PDIAHE+PDIAVG
3634      PDIAY2=PDIAY2-PSUM
3635      IF(PDIAY2.LE.PSUM)PDIAY2=PDIAYC
3636      IF(PDIAY2.GE.100.0)PDIAY2=PDIAYC
3637C
3638C               ***********************************************************
3639C               **  STEP 11--                                            **
3640C               **  EXIT OUT OF GRAPHICS MODE AND                        **
3641C               **  AND MOVE TO DIALOGUE (= MONITOR) MODE.               **
3642C               **  THE DIALOGUE MODE ON VARIOUS TERMINALS               **
3643C               **  IS USUALLY OF 3 TYPES--                              **
3644C               **  1. FOR TERMINALS WITH NO FORMAL DIALOGUE REGION AND  **
3645C               **     NO BACKGROUND DIALOGUE PLANE                      **
3646C               **     (AND THUS SUCCEDING NON-GRAPHICS TEXT WILL        **
3647C               **     OVERWRITE THE GRAPHICS ON THE SCREEN),            **
3648C               **     THEN DO NOTHING.                                  **
3649C               **  2. FOR THOSE TERMINALS IN WHICH THE SCREEN           **
3650C               **     IS SHARED BETWEEN A GRAPHICS REGION AND           **
3651C               **     A MONITOR REGION (USUALLY AT THE BOTTOM),         **
3652C               **     THEN GO TO THE MONITOR REGION.                    **
3653C               **  3. FOR TERMINALS WITH A FULL-SCREEN BACKGROUND       **
3654C               **     DIALOGUE PLANE THAT THE USER CAN FLIP-FLOP TO     **
3655C               **     AND WHICH IS INDEPENDENT OF THE GRAPHICS PLANE,   **
3656C               **     THEN GO TO THE DIALOGUE PLANE.                    **
3657C               ***********************************************************
3658C
3659C     THE FOLLOWING WAS A SIGGRAPH PATCH FOR THE 4129 (DALLAS) AUG. 19, 1986
3660CCCCC IGRASW='OFF'
3661      IGRASW='OFF'
3662      CALL GRSEMO(IGRASW,PDIAXC,PDIAYC)
3663C
3664C               *********************
3665C               **  STEP 6--       **
3666C               **  REVIVE PROMPT  **
3667C               *********************
3668C
3669CCCCC CALL GRREPR
3670C
3671C               *****************
3672C               **  STEP 90--  **
3673C               **  EXIT       **
3674C               *****************
3675C
3676      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CLPL')GOTO9090
3677      WRITE(ICOUT,999)
3678      CALL DPWRST('XXX','BUG ')
3679      WRITE(ICOUT,9011)
3680 9011 FORMAT('***** AT THE END       OF DPCLPL--')
3681      CALL DPWRST('XXX','BUG ')
3682      WRITE(ICOUT,9012)IMANUF,IMODEL,IMODE2,IMODE3
3683 9012 FORMAT('IMANUF,IMODEL,IMODE2,IMODE3 = ',A4,2X,A4,2X,A4,2X,A4)
3684      CALL DPWRST('XXX','BUG ')
3685      WRITE(ICOUT,9013)IGUNIT,IGCODE
3686 9013 FORMAT('IGUNIT,IGCODE = ',I8,2X,A4)
3687      CALL DPWRST('XXX','BUG ')
3688      WRITE(ICOUT,9014)ISOFT,ISOFT2,ISOFT3
3689 9014 FORMAT('ISOFT,ISOFT2,ISOFT3 = ',A4,2X,A4,2X,A4)
3690      CALL DPWRST('XXX','BUG ')
3691      WRITE(ICOUT,9015)IGBAUD
3692 9015 FORMAT('IGBAUD = ',I8)
3693      CALL DPWRST('XXX','BUG ')
3694      WRITE(ICOUT,9021)ICOPSW
3695 9021 FORMAT('ICOPSW= ',A4)
3696      CALL DPWRST('XXX','BUG ')
3697      WRITE(ICOUT,9022)NUMCOP
3698 9022 FORMAT('NUMCOP= ',A4)
3699      CALL DPWRST('XXX','BUG ')
3700      WRITE(ICOUT,9023)PGRAXF,PGRAYF
3701 9023 FORMAT('PGRAXF,PGRAYF = ',2E15.7)
3702      CALL DPWRST('XXX','BUG ')
3703      WRITE(ICOUT,9024)IGRASW
3704 9024 FORMAT('IGRASW= ',A4)
3705      CALL DPWRST('XXX','BUG ')
3706      WRITE(ICOUT,9025)PDIAXC,PDIAYC,PDIAX2,PDIAY2
3707 9025 FORMAT('PDIAXC,PDIAYC,PDIAX2,PDIAY2 = ',4E15.7)
3708      CALL DPWRST('XXX','BUG ')
3709      WRITE(ICOUT,9026)PDIAHE,PDIAWI
3710 9026 FORMAT('PDIAHE,PDIAWI = ',2E15.7)
3711      CALL DPWRST('XXX','BUG ')
3712      WRITE(ICOUT,9027)PDIAVG,PDIAHG
3713 9027 FORMAT('PDIAVG,PDIAHG = ',2E15.7)
3714      CALL DPWRST('XXX','BUG ')
3715      WRITE(ICOUT,9029)IBUGG4,ISUBG4,IERRG4
3716 9029 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
3717      CALL DPWRST('XXX','BUG ')
3718 9090 CONTINUE
3719C
3720      RETURN
3721      END
3722      SUBROUTINE DPCLT2(PXOLD,PYOLD,PXCUR,PYCUR,
3723     1PXMIN,PXMAX,PYMIN,PYMAX,
3724     1PXNEW,PYNEW)
3725C
3726C      PURPOSE--GIVEN THE 2 POINTS (PXOLD,PYOLD) AND (PXNEW,PYNEW)
3727C               (ONE OF WHICH IS DEFINITELY IN THE FRAME
3728C               DEFINED BY (PXMIN,PYMIN) AND (PXMAX,PYMAX)
3729C               AND THE OTHER OF WHICH IS OUTSIDE THAT FRAME,
3730C               COMPUTE THE POINT (PXNEW,PYNEW) WHICH
3731C               IS THAT VALUE ON THE FRAME IN WHICH THE LINE SEGMENT
3732C               INTERSECTS THE FRAME.
3733C               THIS ALLOWS THE SUBROUTINE DPCLIP
3734C               TO CARRY OUT CLIPPING.
3735C
3736C     WRITTEN BY--JAMES J. FILLIBEN
3737C                 STATISTICAL ENGINEERING DIVISION
3738C                 INFORMATION TECHNOLOGY LABORATORY
3739C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
3740C                 GAITHERSBURG, MD 20899-8980
3741C                 PHONE--301-975-2855
3742C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
3743C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
3744C     LANGUAGE--ANSI FORTRAN (1977)
3745C     VERSION NUMBER--83.6
3746C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY       1983.
3747C
3748C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
3749C
3750      CHARACTER*4 ISUBN1
3751      CHARACTER*4 ISUBN2
3752      CHARACTER*4 ISTEPN
3753C
3754C-----COMMON----------------------------------------------------------
3755C
3756      INCLUDE 'DPCOBE.INC'
3757      INCLUDE 'DPCOP2.INC'
3758C
3759C-----START POINT-----------------------------------------------------
3760C
3761      ISUBN1='DPCL'
3762      ISUBN2='P2  '
3763C
3764      PX1=PXOLD
3765      PY1=PYOLD
3766      PX2=PXCUR
3767      PY2=PYCUR
3768      PX3=PXCUR
3769      PY3=PYCUR
3770C
3771      SLOPE=0.0
3772      AINT=0.0
3773C
3774      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CLT2')GOTO90
3775      WRITE(ICOUT,999)
3776  999 FORMAT(1X)
3777      CALL DPWRST('XXX','BUG ')
3778      WRITE(ICOUT,51)
3779   51 FORMAT('***** AT THE BEGINNING OF DPCLT2--')
3780      CALL DPWRST('XXX','BUG ')
3781      WRITE(ICOUT,52)PXOLD,PYOLD
3782   52 FORMAT('PXOLD,PYOLD = ',2E15.7)
3783      CALL DPWRST('XXX','BUG ')
3784      WRITE(ICOUT,53)PXCUR,PYCUR
3785   53 FORMAT('PXCUR,PYCUR = ',2E15.7)
3786      CALL DPWRST('XXX','BUG ')
3787      WRITE(ICOUT,54)PXMIN,PYMIN,PXMAX,PYMAX
3788   54 FORMAT('PXMIN,PYMIN,PXMAX,PYMAX = ',4F10.5)
3789      CALL DPWRST('XXX','BUG ')
3790      WRITE(ICOUT,59)IBUGG4,ISUBG4,IERRG4
3791   59 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
3792      CALL DPWRST('XXX','BUG ')
3793   90 CONTINUE
3794C
3795C               ************************************************************
3796C               **  STEP 1--                                              **
3797C               **  EITHER (PXOLD,PYOLD) OR (PXCUR,PYCUR)                 **
3798C               **  MUST BE WITHIN THE FRAME.                             **
3799C               **  DETERMINE WHICH ONE IS.                               **
3800C               **  (PX1,PY1) WILL REFER TO THE POINT INSIDE  THE FRAME.  **
3801C               **  (PX2,PY2) WILL REFER TO THE POINT OUTSIDE THE FRAME.  **
3802C               ************************************************************
3803C
3804      ISTEPN='1'
3805      IF(IBUGG4.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3806C
3807      IF(PXOLD.GE.PXMIN.AND.PXOLD.LE.PXMAX.AND.
3808     1   PYOLD.GE.PYMIN.AND.PYOLD.LE.PYMAX)GOTO1110
3809      IF(PXCUR.GE.PXMIN.AND.PXCUR.LE.PXMAX.AND.
3810     1   PYCUR.GE.PYMIN.AND.PYCUR.LE.PYMAX)GOTO1120
3811      GOTO1130
3812C
3813 1110 CONTINUE
3814      PX1=PXOLD
3815      PY1=PYOLD
3816      PX2=PXCUR
3817      PY2=PYCUR
3818      GOTO1190
3819C
3820 1120 CONTINUE
3821      PX1=PXCUR
3822      PY1=PYCUR
3823      PX2=PXOLD
3824      PY2=PYOLD
3825      GOTO1190
3826C
3827 1130 CONTINUE
3828      IERRG4='YES'
3829      WRITE(ICOUT,999)
3830      CALL DPWRST('XXX','BUG ')
3831      WRITE(ICOUT,1131)
3832 1131 FORMAT('***** INTERNAL ERROR IN DPCLT2--')
3833      CALL DPWRST('XXX','BUG ')
3834      WRITE(ICOUT,1132)
3835 1132 FORMAT('      UPON INPUT TO THIS SUBROUTINE,')
3836      CALL DPWRST('XXX','BUG ')
3837      WRITE(ICOUT,1133)
3838 1133 FORMAT('      AT LEAST ONE POINT MUST BE')
3839      CALL DPWRST('XXX','BUG ')
3840      WRITE(ICOUT,1134)
3841 1134 FORMAT('      WITHIN THE FRAME--BUT WAS NOT.')
3842      CALL DPWRST('XXX','BUG ')
3843      WRITE(ICOUT,1135)PXMIN,PXMAX,PYMIN,PYMAX
3844 1135 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX = ',4E15.7)
3845      CALL DPWRST('XXX','BUG ')
3846      WRITE(ICOUT,1136)PXOLD,PYOLD,PXCUR,PYCUR
3847 1136 FORMAT('PXOLD,PYOLD,PXCUR,PYCUR = ',4E15.7)
3848      CALL DPWRST('XXX','BUG ')
3849      GOTO9000
3850C
3851 1190 CONTINUE
3852C
3853C               **********************************
3854C               **  STEP 2--                    **
3855C               **  DETERMINE THE FRAME POINT.  **
3856C               **  THIS WILL BE (PX3,PY3).     **
3857C               **********************************
3858C
3859      ISTEPN='2'
3860      IF(IBUGG4.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3861C
3862      IF(PX1.EQ.PX2)GOTO1200
3863      GOTO1250
3864C
3865C               **************************************
3866C               **  STEP 2.1--                      **
3867C               **  TREAT THE SUBCASE WHEN PX1 = PX2**
3868C               **************************************
3869C
3870 1200 CONTINUE
3871      ISTEPN='2.1'
3872      IF(IBUGG4.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3873C
3874      PX3=PX2
3875C
3876      PY3=PY2
3877      IF(PY2.LT.PYMIN)PY3=PYMIN
3878      IF(PY2.GT.PYMAX)PY3=PYMAX
3879C
3880      GOTO1290
3881C
3882C               ***************************************************
3883C               **  STEP 2.2--                                   **
3884C               **  TREAT THE SUBCASE WHEN PX1 DOES NOT EQUAL PX2**
3885C               ***************************************************
3886C
3887 1250 CONTINUE
3888      ISTEPN='2.2'
3889      IF(IBUGG4.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3890C
3891      SLOPE=(PY2-PY1)/(PX2-PX1)
3892      AINT=PY2-SLOPE*PX2
3893C
3894      PX3=PX2
3895      IF(PX2.LT.PXMIN)PX3=PXMIN
3896      IF(PX2.GT.PXMAX)PX3=PXMAX
3897C
3898      PY3=SLOPE*PX3+AINT
3899      IF(PY3.LT.PYMIN)GOTO1260
3900      IF(PY3.GT.PYMAX)GOTO1270
3901      GOTO1290
3902C
3903 1260 CONTINUE
3904      PY3=PYMIN
3905      PX3=0.0
3906      IF(SLOPE.NE.0.0)PX3=(PY3-AINT)/SLOPE
3907      GOTO1290
3908C
3909 1270 CONTINUE
3910      PY3=PYMAX
3911      PX3=0.0
3912      IF(SLOPE.NE.0.0)PX3=(PY3-AINT)/SLOPE
3913      GOTO1290
3914C
3915 1290 CONTINUE
3916      PXNEW=PX3
3917      PYNEW=PY3
3918      GOTO9000
3919C
3920C               *****************
3921C               **  STEP 90--  **
3922C               **  EXIT       **
3923C               *****************
3924C
3925 9000 CONTINUE
3926      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CLT2')GOTO9090
3927      WRITE(ICOUT,999)
3928      CALL DPWRST('XXX','BUG ')
3929      WRITE(ICOUT,9011)
3930 9011 FORMAT('***** AT THE END       OF DPCLT2--')
3931      CALL DPWRST('XXX','BUG ')
3932      WRITE(ICOUT,9012)PXOLD,PYOLD
3933 9012 FORMAT('PXOLD,PYOLD = ',2E15.7)
3934      CALL DPWRST('XXX','BUG ')
3935      WRITE(ICOUT,9013)PXCUR,PYCUR
3936 9013 FORMAT('PXCUR,PYCUR = ',2E15.7)
3937      CALL DPWRST('XXX','BUG ')
3938      WRITE(ICOUT,9014)PXMIN,PYMIN,PXMAX,PYMAX
3939 9014 FORMAT('PXMIN,PYMIN,PXMAX,PYMAX = ',4F10.5)
3940      CALL DPWRST('XXX','BUG ')
3941      WRITE(ICOUT,9021)PX1,PY1
3942 9021 FORMAT('PX1,PY1 = ',2E15.7)
3943      CALL DPWRST('XXX','BUG ')
3944      WRITE(ICOUT,9022)PX2,PY2
3945 9022 FORMAT('PX2,PY2 = ',2E15.7)
3946      CALL DPWRST('XXX','BUG ')
3947      WRITE(ICOUT,9023)PX3,PY3
3948 9023 FORMAT('PX3,PY3 = ',2E15.7)
3949      CALL DPWRST('XXX','BUG ')
3950      WRITE(ICOUT,9025)SLOPE,AINT
3951 9025 FORMAT('SLOPE,AINT = ',2E15.7)
3952      CALL DPWRST('XXX','BUG ')
3953      WRITE(ICOUT,9026)PXNEW,PYNEW
3954 9026 FORMAT('PXNEW,PYNEW = ',2E15.7)
3955      CALL DPWRST('XXX','BUG ')
3956      WRITE(ICOUT,9029)IBUGG4,ISUBG4,IERRG4
3957 9029 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
3958      CALL DPWRST('XXX','BUG ')
3959 9090 CONTINUE
3960C
3961      RETURN
3962      END
3963      SUBROUTINE DPCLTR(PX,PY,NP,PX2,PY2,NP2,
3964     1                  PXMIN,PXMAX,PYMIN,PYMAX,
3965     1                  ISORSW,
3966     1                  IFIG,IPATT,PTHICK,ICOL)
3967C
3968C     PURPOSE--CARRY OUT CLIPPING (IF NECESSARY) AND DRAW A TRACE (OR
3969C              SERIES OF CLIPPED TRACES) BASED ON THE DATA IN (PX,PY).
3970C     DANGER--THE INPUT VARIABLES PX(.) AND PY(.) MAY BE
3971C             CHANGED IN THIS SUBROUTINE (SEE STEP 0 BELOW)
3972C     WRITTEN BY--JAMES J. FILLIBEN
3973C                 STATISTICAL ENGINEERING DIVISION
3974C                 INFORMATION TECHNOLOGY LABORATORY
3975C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
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 TECHNOLOGY.
3980C     LANGUAGE--ANSI FORTRAN (1977)
3981C     VERSION NUMBER--83.6
3982C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY       1983.
3983C     UPDATED         --JANUARY   1989.  MODIFY CALLS TO DPDRPL (ALAN)
3984C
3985C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
3986C
3987      CHARACTER*4 ISORSW
3988C
3989      CHARACTER*4 IFIG
3990      CHARACTER*4 IPATT
3991      CHARACTER*4 ICOL
3992      CHARACTER*4 IFLAG
3993C
3994      CHARACTER*4 ISUBN1
3995      CHARACTER*4 ISUBN2
3996      CHARACTER*4 ISTEPN
3997C
3998C---------------------------------------------------------------------
3999C
4000      DIMENSION PX(*)
4001      DIMENSION PY(*)
4002C
4003      DIMENSION PX2(*)
4004      DIMENSION PY2(*)
4005C
4006C-----COMMON----------------------------------------------------------
4007C
4008      INCLUDE 'DPCOBE.INC'
4009      INCLUDE 'DPCOP2.INC'
4010C
4011C-----START POINT-----------------------------------------------------
4012C
4013      ISUBN1='DPCL'
4014      ISUBN2='PL  '
4015C
4016      XMIN=CPUMAX
4017      YMIN=CPUMAX
4018      XMAX=CPUMIN
4019      YMAX=CPUMIN
4020      J=(-999)
4021C
4022      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CLTR')GOTO90
4023      WRITE(ICOUT,999)
4024  999 FORMAT(1X)
4025      CALL DPWRST('XXX','BUG ')
4026      WRITE(ICOUT,51)
4027   51 FORMAT('***** AT THE BEGINNING OF DPCLTR--')
4028      CALL DPWRST('XXX','BUG ')
4029      WRITE(ICOUT,53)PXMIN,PXMAX,PYMIN,PYMAX
4030   53 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX = ',4E15.7)
4031      CALL DPWRST('XXX','BUG ')
4032      WRITE(ICOUT,54)ISORSW
4033   54 FORMAT('ISORSW = ',A4)
4034      CALL DPWRST('XXX','BUG ')
4035      WRITE(ICOUT,56)IFIG,IPATT,PTHICK,ICOL
4036   56 FORMAT('IFIG,IPATT,PTHICK,ICOL = ',A4,2X,A4,E15.7,2X,A4)
4037      CALL DPWRST('XXX','BUG ')
4038      WRITE(ICOUT,61)NP
4039   61 FORMAT('NP = ',I8)
4040      CALL DPWRST('XXX','BUG ')
4041      DO62I=1,NP
4042      DEL1=PX(I)-PXMIN
4043      DEL2=PX(I)-PXMAX
4044      DEL3=PY(I)-PYMIN
4045      DEL4=PY(I)-PYMAX
4046      WRITE(ICOUT,63)I,PX(I),PY(I)
4047   63 FORMAT('I,PX(I),PY(I)         = ',I8,2E15.7)
4048      CALL DPWRST('XXX','BUG ')
4049      WRITE(ICOUT,64)I,DEL1,DEL2,DEL3,DEL4
4050   64 FORMAT('I,DEL1,DEL2,DEL3,DEL4 = ',I8,4E15.7)
4051      CALL DPWRST('XXX','BUG ')
4052   62 CONTINUE
4053      WRITE(ICOUT,69)IBUGG4,ISUBG4,IERRG4
4054   69 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
4055      CALL DPWRST('XXX','BUG ')
4056   90 CONTINUE
4057C
4058C               ****************************************************************
4059C               **  STEP 0--                                                   *
4060C               **  IF NECESSARY,                                              *
4061C               **  ADJUST (= CHANGE) THE PX(.) AND PY(.) VALUES TO ALLOW FOR  *
4062C               **  POSSIBLE ROUNDOFF NEAR THE LIMITS (PXMIN,PXMAX)            *
4063C               **  AND (PYMIN,PYMAX) WHICH WOULD SHOW UP AS A DATA            *
4064C               **  POINT NOT BEING PLOTTED WHEN IT SHOULD HAVE BEEN           *
4065C               ****************************************************************
4066C
4067      CALL DPSQUE(PX,PY,NP,
4068     1PXMIN,PXMAX,PYMIN,PYMAX)
4069C
4070C               *************************************************
4071C               **  STEP 1--                                   **
4072C               **  DETERMINE THE FIRST AND LAST ELEMENTS OF   **
4073C               **  THE (PX,PY) VECTORS WHICH MUST BE SCANNED  **
4074C               **  BASED ON WHETHER PX(.) IS SORTED           **
4075C               **  OR NOT.                                    **
4076C               *************************************************
4077C
4078      ISTEPN='1'
4079      IF(IBUGG4.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4080C
4081      IF(ISORSW.EQ.'ON')GOTO1100
4082      GOTO1150
4083C
4084 1100 CONTINUE
4085      DO1110I=1,NP
4086      I2=I
4087      IF(PX(I).GE.PXMIN)GOTO1115
4088 1110 CONTINUE
4089      IMIN=NP+1
4090      GOTO1119
4091 1115 CONTINUE
4092      IMIN=I2
4093 1119 CONTINUE
4094C
4095      DO1120I=1,NP
4096      IREV=NP-I+1
4097      IF(PX(IREV).LE.PXMAX)GOTO1125
4098 1120 CONTINUE
4099      IMAX=0
4100      GOTO1129
4101 1125 CONTINUE
4102      IMAX=IREV
4103 1129 CONTINUE
4104      GOTO1190
4105C
4106 1150 CONTINUE
4107      IMIN=1
4108      IMAX=NP
4109      GOTO1190
4110C
4111 1190 CONTINUE
4112      IF(IMIN.GT.IMAX)GOTO9000
4113C
4114C               ********************************************************
4115C               **  STEP 2--                                          **
4116C               **  COMPUTE THE HORIZONTAL AXIS VARIABLE MIN AND MAX  **
4117C               **  FOR THE DATA WITHIN THE SUBSET                    **
4118C               ********************************************************
4119C
4120      ISTEPN='2'
4121      IF(IBUGG4.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4122C
4123      IF(ISORSW.EQ.'ON')GOTO1210
4124      GOTO1250
4125C
4126 1210 CONTINUE
4127      XMIN=PX(IMIN)
4128      XMAX=PX(IMAX)
4129      GOTO1290
4130C
4131 1250 CONTINUE
4132      XMIN=CPUMAX
4133      XMAX=CPUMIN
4134      DO1260I=IMIN,IMAX
4135      IF(PX(I).LT.XMIN)XMIN=PX(I)
4136      IF(PX(I).GT.XMAX)XMAX=PX(I)
4137 1260 CONTINUE
4138      GOTO1290
4139C
4140 1290 CONTINUE
4141C
4142C               ******************************************************
4143C               **  STEP 3--                                        **
4144C               **  COMPUTE THE VERTICAL AXIS VARIABLE MIN AND MAX  **
4145C               **  FOR THE DATA WITHIN THE SUBSET                  **
4146C               ******************************************************
4147C
4148      ISTEPN='3'
4149      IF(IBUGG4.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4150C
4151      YMIN=CPUMAX
4152      YMAX=CPUMIN
4153      DO1300I=IMIN,IMAX
4154      IF(PY(I).LT.YMIN)YMIN=PY(I)
4155      IF(PY(I).GT.YMAX)YMAX=PY(I)
4156 1300 CONTINUE
4157C
4158C               *******************************************************
4159C               **  STEP 21--                                        **
4160C               **  TREAT THE MOST COMMON AND MOST IMPORTANT CASE--  **
4161C               **  ALL NP OBSERVATIONS ARE TO BE USED;              **
4162C               **  ALL X DATA ARE WITHIN THE FRAME;                 **
4163C               **  ALL Y DATA ARE WITHIN THE FRAME.                 **
4164C               *******************************************************
4165C
4166      IF(IMIN.EQ.1.AND.IMAX.EQ.NP.AND.
4167     1XMIN.GE.PXMIN.AND.XMAX.LE.PXMAX.AND.
4168     1YMIN.GE.PYMIN.AND.YMAX.LE.PYMAX)GOTO2100
4169      GOTO2190
4170C
4171 2100 CONTINUE
4172      ISTEPN='21'
4173      IF(IBUGG4.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4174      IFLAG='ON'
4175CCCCC CALL DPDRPL(PX,PY,NP,PX3,PY3,NP3,
4176CCCCC1IFIG,IPATT,PTHICK,ICOL)
4177      CALL DPDRPL(PX,PY,NP,
4178     1IFIG,IPATT,PTHICK,ICOL,
4179     1JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
4180      GOTO9000
4181C
4182 2190 CONTINUE
4183C
4184C               *******************************************************
4185C               **  STEP 22--                                        **
4186C               **  TREAT THE NEXT MOST COMMON AND MOST IMPORTANT CASE--  **
4187C               **  A SUBSET OF THE NP OBSERVATIONS ARE TO BE USED;  **
4188C               **  ALL X DATA ARE WITHIN THE FRAME;                 **
4189C               **  ALL Y DATA ARE WITHIN THE FRAME.                 **
4190C               *******************************************************
4191C
4192      IF(XMIN.GE.PXMIN.AND.XMAX.LE.PXMAX.AND.
4193     1YMIN.GE.PYMIN.AND.YMAX.LE.PYMAX)GOTO2200
4194      GOTO2290
4195C
4196 2200 CONTINUE
4197      ISTEPN='22'
4198      IF(IBUGG4.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4199      J=0
4200      DO2210I=IMIN,IMAX
4201      J=J+1
4202      PX2(J)=PX(I)
4203      PY2(J)=PY(I)
4204 2210 CONTINUE
4205      NP2=J
4206      IFLAG='ON'
4207CCCCC CALL DPDRPL(PX2,PY2,NP2,PX3,PY3,NP3,
4208CCCCC1IFIG,IPATT,PTHICK,ICOL)
4209      CALL DPDRPL(PX2,PY2,NP2,
4210     1IFIG,IPATT,PTHICK,ICOL,
4211     1JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
4212      GOTO9000
4213C
4214 2290 CONTINUE
4215C
4216C               ****************************************************
4217C               **  STEP 23--                                     **
4218C               **  TREAT THE CASE WHERE THE SUBSET IS SUCH THAT  **
4219C               **  ALL X'S ARE INSIDE THE FRAME,                 **
4220C               **  BUT SOME Y'S ARE OUTSIDE THE FRAME.           **
4221C               ****************************************************
4222C
4223      IF(XMIN.GE.PXMIN.AND.XMAX.LE.PXMAX)GOTO2300
4224      GOTO2390
4225C
4226 2300 CONTINUE
4227      ISTEPN='23'
4228      IF(IBUGG4.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4229      J=0
4230      DO2310I=IMIN,IMAX
4231      IM1=I-1
4232      IF(PY(I).GE.PYMIN.AND.PY(I).LE.PYMAX)GOTO2320
4233      GOTO2330
4234C
4235 2320 CONTINUE
4236      IF(IM1.LT.IMIN)GOTO2325
4237      PXOLD=PX(IM1)
4238      PYOLD=PY(IM1)
4239      PXCUR=PX(I)
4240      PYCUR=PY(I)
4241      IF(PYOLD.GE.PYMIN.AND.PYOLD.LE.PYMAX)GOTO2325
4242      CALL DPCLT2(PXOLD,PYOLD,PXCUR,PYCUR,
4243     1PXMIN,PXMAX,PYMIN,PYMAX,
4244     1PXNEW,PYNEW)
4245      J=J+1
4246      PX2(J)=PXNEW
4247      PY2(J)=PYNEW
4248C
4249 2325 CONTINUE
4250      J=J+1
4251      PX2(J)=PX(I)
4252      PY2(J)=PY(I)
4253      GOTO2310
4254C
4255 2330 CONTINUE
4256      IF(IM1.LT.IMIN)GOTO2335
4257      PXOLD=PX(IM1)
4258      PYOLD=PY(IM1)
4259      PXCUR=PX(I)
4260      PYCUR=PY(I)
4261      IF(PYOLD.GE.PYMIN.AND.PYOLD.LE.PYMAX)GOTO2333
4262      GOTO2335
4263C
4264 2333 CONTINUE
4265      CALL DPCLT2(PXOLD,PYOLD,PXCUR,PYCUR,
4266     1PXMIN,PXMAX,PYMIN,PYMAX,
4267     1PXNEW,PYNEW)
4268      J=J+1
4269      PX2(J)=PXNEW
4270      PY2(J)=PYNEW
4271      NP2=J
4272      IFLAG='ON'
4273CCCCC CALL DPDRPL(PX2,PY2,NP2,PX3,PY3,NP3,
4274CCCCC1IFIG,IPATT,PTHICK,ICOL)
4275      CALL DPDRPL(PX2,PY2,NP2,
4276     1IFIG,IPATT,PTHICK,ICOL,
4277     1JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
4278C
4279 2335 CONTINUE
4280      J=0
4281      GOTO2310
4282C
4283 2310 CONTINUE
4284      NP2=J
4285      IFLAG='ON'
4286      IF(NP2.GE.1)
4287CCCCC1CALL DPDRPL(PX2,PY2,NP2,PX3,PY3,NP3,
4288CCCCC1IFIG,IPATT,PTHICK,ICOL)
4289     1CALL DPDRPL(PX2,PY2,NP2,
4290     1IFIG,IPATT,PTHICK,ICOL,
4291     1JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
4292      GOTO9000
4293C
4294 2390 CONTINUE
4295C
4296C               ****************************************************
4297C               **  STEP 24--                                     **
4298C               **  TREAT THE CASE WHERE THE SUBSET IS SUCH THAT  **
4299C               **  ALL Y'S ARE INSIDE THE FRAME,                 **
4300C               **  BUT SOME X'S ARE OUTSIDE THE FRAME            **
4301C               **  (AS IN THE CONSTRUCTION OF MAPS)              **
4302C               ****************************************************
4303C
4304      IF(YMIN.GE.PYMIN.AND.YMAX.LE.PYMAX)GOTO2400
4305      GOTO2490
4306C
4307 2400 CONTINUE
4308      ISTEPN='24'
4309      IF(IBUGG4.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4310      J=0
4311      DO2410I=IMIN,IMAX
4312      IM1=I-1
4313      IF(PX(I).GE.PXMIN.AND.PX(I).LE.PXMAX)GOTO2420
4314      GOTO2430
4315C
4316 2420 CONTINUE
4317      IF(IM1.LT.IMIN)GOTO2425
4318      PXOLD=PX(IM1)
4319      PYOLD=PY(IM1)
4320      PXCUR=PX(I)
4321      PYCUR=PY(I)
4322      IF(PXOLD.GE.PXMIN.AND.PXOLD.LE.PXMAX)GOTO2425
4323      CALL DPCLT2(PXOLD,PYOLD,PXCUR,PYCUR,
4324     1PXMIN,PXMAX,PYMIN,PYMAX,
4325     1PXNEW,PYNEW)
4326      J=J+1
4327      PX2(J)=PXNEW
4328      PY2(J)=PYNEW
4329 2425 CONTINUE
4330      J=J+1
4331      PX2(J)=PX(I)
4332      PY2(J)=PY(I)
4333      GOTO2410
4334C
4335 2430 CONTINUE
4336      IF(IM1.LT.IMIN)GOTO2435
4337      PXOLD=PX(IM1)
4338      PYOLD=PY(IM1)
4339      PXCUR=PX(I)
4340      PYCUR=PY(I)
4341      IF(PXOLD.GE.PXMIN.AND.PXOLD.LE.PXMAX)GOTO2433
4342      GOTO2435
4343 2433 CONTINUE
4344      CALL DPCLT2(PXOLD,PYOLD,PXCUR,PYCUR,
4345     1PXMIN,PXMAX,PYMIN,PYMAX,
4346     1PXNEW,PYNEW)
4347      J=J+1
4348      PX2(J)=PXNEW
4349      PY2(J)=PYNEW
4350      NP2=J
4351      IFLAG='ON'
4352CCCCC CALL DPDRPL(PX2,PY2,NP2,PX3,PY3,NP3,
4353CCCCC1IFIG,IPATT,PTHICK,ICOL)
4354      CALL DPDRPL(PX2,PY2,NP2,
4355     1IFIG,IPATT,PTHICK,ICOL,
4356     1JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
4357 2435 CONTINUE
4358      J=0
4359      GOTO2410
4360C
4361 2410 CONTINUE
4362      NP2=J
4363      IFLAG='ON'
4364      IF(NP2.GE.1)
4365CCCCC1CALL DPDRPL(PX2,PY2,NP2,PX3,PY3,NP3,
4366CCCCC1IFIG,IPATT,PTHICK,ICOL)
4367     1CALL DPDRPL(PX2,PY2,NP2,
4368     1IFIG,IPATT,PTHICK,ICOL,
4369     1JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
4370      GOTO9000
4371C
4372 2490 CONTINUE
4373C
4374C               ****************************************************
4375C               **  STEP 25--                                     **
4376C               **  TREAT THE GENERAL CASE WHERE THE SUBSET IS SUCH THAT  **
4377C               **  SOME  X'S MAY BE OUTSIDE THE FRAME, AND/OR    **
4378C               **  SOME  Y'S MAY BE OUTSIDE THE FRAME            **
4379C               **  (AS IN THE CONSTRUCTION OF MAPS)              **
4380C               ****************************************************
4381C
4382      ISTEPN='25'
4383      IF(IBUGG4.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4384      J=0
4385      DO2510I=IMIN,IMAX
4386      IM1=I-1
4387      IF(PX(I).GE.PXMIN.AND.PX(I).LE.PXMAX.AND.
4388     1   PY(I).GE.PYMIN.AND.PY(I).LE.PYMAX)GOTO2520
4389      GOTO2530
4390C
4391 2520 CONTINUE
4392      IF(IM1.LT.IMIN)GOTO2525
4393      PXOLD=PX(IM1)
4394      PYOLD=PY(IM1)
4395      PXCUR=PX(I)
4396      PYCUR=PY(I)
4397      IF(PXOLD.GE.PXMIN.AND.PXOLD.LE.PXMAX.AND.
4398     1   PYOLD.GE.PYMIN.AND.PYOLD.LE.PYMAX)GOTO2525
4399      CALL DPCLT2(PXOLD,PYOLD,PXCUR,PYCUR,
4400     1PXMIN,PXMAX,PYMIN,PYMAX,
4401     1PXNEW,PYNEW)
4402      J=J+1
4403      PX2(J)=PXNEW
4404      PY2(J)=PYNEW
4405 2525 CONTINUE
4406      J=J+1
4407      PX2(J)=PX(I)
4408      PY2(J)=PY(I)
4409      GOTO2510
4410C
4411 2530 CONTINUE
4412      IF(IM1.LT.IMIN)GOTO2535
4413      PXOLD=PX(IM1)
4414      PYOLD=PY(IM1)
4415      PXCUR=PX(I)
4416      PYCUR=PY(I)
4417      IF(PXOLD.GE.PXMIN.AND.PXOLD.LE.PXMAX.AND.
4418     1   PYOLD.GE.PYMIN.AND.PYOLD.LE.PYMAX)GOTO2533
4419      GOTO2535
4420 2533 CONTINUE
4421      CALL DPCLT2(PXOLD,PYOLD,PXCUR,PYCUR,
4422     1PXMIN,PXMAX,PYMIN,PYMAX,
4423     1PXNEW,PYNEW)
4424      J=J+1
4425      PX2(J)=PXNEW
4426      PY2(J)=PYNEW
4427      NP2=J
4428      IFLAG='ON'
4429CCCCC CALL DPDRPL(PX2,PY2,NP2,PX3,PY3,NP3,
4430CCCCC1IFIG,IPATT,PTHICK,ICOL)
4431      CALL DPDRPL(PX2,PY2,NP2,
4432     1IFIG,IPATT,PTHICK,ICOL,
4433     1JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
4434 2535 CONTINUE
4435      J=0
4436      GOTO2510
4437C
4438 2510 CONTINUE
4439      NP2=J
4440      IFLAG='ON'
4441      IF(NP2.GE.1)
4442CCCCC1CALL DPDRPL(PX2,PY2,NP2,PX3,PY3,NP3,
4443CCCCC1IFIG,IPATT,PTHICK,ICOL)
4444     1CALL DPDRPL(PX2,PY2,NP2,
4445     1IFIG,IPATT,PTHICK,ICOL,
4446     1JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
4447      GOTO9000
4448C
4449C               *****************
4450C               **  STEP 90--  **
4451C               **  EXIT.      **
4452C               *****************
4453C
4454 9000 CONTINUE
4455      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CLTR')GOTO9090
4456      WRITE(ICOUT,999)
4457      CALL DPWRST('XXX','BUG ')
4458      WRITE(ICOUT,9011)
4459 9011 FORMAT('***** AT THE END       OF DPCLTR--')
4460      CALL DPWRST('XXX','BUG ')
4461      WRITE(ICOUT,9013)PXMIN,PXMAX,PYMIN,PYMAX
4462 9013 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX = ',4E15.7)
4463      CALL DPWRST('XXX','BUG ')
4464      WRITE(ICOUT,9014)ISORSW
4465 9014 FORMAT('ISORSW = ',A4)
4466      CALL DPWRST('XXX','BUG ')
4467      WRITE(ICOUT,9016)IFIG,IPATT,PTHICK,ICOL
4468 9016 FORMAT('IFIG,IPATT,PTHICK,ICOL = ',A4,2X,A4,E15.7,2X,A4)
4469      CALL DPWRST('XXX','BUG ')
4470      WRITE(ICOUT,9017)IMIN,IMAX,J
4471 9017 FORMAT('IMIN,IMAX,J = ',3I8)
4472      CALL DPWRST('XXX','BUG ')
4473      WRITE(ICOUT,9018)XMIN,XMAX,YMIN,YMAX
4474 9018 FORMAT('XMIN,XMAX,YMIN,YMAX = ',4E15.7)
4475      CALL DPWRST('XXX','BUG ')
4476      WRITE(ICOUT,9021)NP
4477 9021 FORMAT('NP = ',I8)
4478      CALL DPWRST('XXX','BUG ')
4479      DO9022I=1,NP
4480      DEL1=PX(I)-PXMIN
4481      DEL2=PX(I)-PXMAX
4482      DEL3=PY(I)-PYMIN
4483      DEL4=PY(I)-PYMAX
4484      WRITE(ICOUT,9023)I,PX(I),PY(I)
4485 9023 FORMAT('I,PX(I),PY(I)         = ',I8,2E15.7)
4486      CALL DPWRST('XXX','BUG ')
4487      WRITE(ICOUT,9024)I,DEL1,DEL2,DEL3,DEL4
4488 9024 FORMAT('I,DEL1,DEL2,DEL3,DEL4 = ',I8,4E15.7)
4489      CALL DPWRST('XXX','BUG ')
4490 9022 CONTINUE
4491      WRITE(ICOUT,9031)NP2
4492 9031 FORMAT('NP2 = ',I8)
4493      CALL DPWRST('XXX','BUG ')
4494CCCCC DO9032I=1,NP2
4495      DO9032I=1,NP
4496      WRITE(ICOUT,9033)I,PX2(I),PY2(I)
4497 9033 FORMAT('I,PX2(I),YP2(I) = ',I8,2E15.7)
4498      CALL DPWRST('XXX','BUG ')
4499 9032 CONTINUE
4500      WRITE(ICOUT,9039)IBUGG4,ISUBG4,IERRG4
4501 9039 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
4502      CALL DPWRST('XXX','BUG ')
4503 9090 CONTINUE
4504C
4505      RETURN
4506      END
4507      SUBROUTINE DPCLUP(IHARG,IARGT,ARG,NUMARG,
4508     1CLLIMI,IFOUND,IERROR)
4509C
4510C     PURPOSE--DEFINE THE UPPER BOUND OF THE LEFT-MOST CLASS
4511C              FOR HORIZONTAL VARIABLE OR VERTICAL VARIABLE OR BOTH
4512C              FOR DISTRIBUTIONAL PLOTS (E.G., HISTOGRAMS).
4513C              THE 2 UPPER LIMITS (ONE FOR THE X AXIS VARIABLE
4514C              AND ONE FOR THE Y AXIS VARIABLE)
4515C              ARE CONTAINED IN THE SECOND AND FOURTH ELEMENTS OF THE
4516C              4-ELEMENT VECTOR CLLIMI(.).
4517C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
4518C                     --IARGT  (A  HOLLERITH VECTOR)
4519C                     --ARG    (A  FLOATING POINT VECTOR)
4520C                     --NUMARG
4521C     OUTPUT ARGUMENTS--CLLIMI (A 4-ELEMENT FLOATING POINT VECTOR
4522C                              IN WHICH EACH ELEMENT IS AS FOLLOWS--
4523C                                 1) LOWER BOUND FOR HORIZONTAL VARIABLE
4524C                                    (NOT AFFECTED)
4525C                                 2) UPPER BOUND FOR HORIZONTAL VARIABLE
4526C                                 3) LOWER BOUND FOR VERTICAL   VARIABLE
4527C                                    (NOT AFFECTED)
4528C                                 4) UPPER BOUND FOR VERTICAL   VARIABLE
4529C                     --IFOUND ('YES' OR 'NO' )
4530C                     --IERROR ('YES' OR 'NO' )
4531C     WRITTEN BY--JAMES J. FILLIBEN
4532C                 STATISTICAL ENGINEERING DIVISION
4533C                 INFORMATION TECHNOLOGY LABORATORY
4534C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
4535C                 GAITHERSBURG, MD 20899-8980
4536C                 PHONE--301-975-2855
4537C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
4538C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
4539C     LANGUAGE--ANSI FORTRAN (1977)
4540C     VERSION NUMBER--82/7
4541C     ORIGINAL VERSION--NOVEMBER  1978.
4542C     UPDATED         --SEPTEMBER 1980.
4543C     UPDATED         --MAY       1981.
4544C     UPDATED         --OCTOBER   1981.
4545C     UPDATED         --MAY       1982.
4546C
4547C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
4548C
4549      CHARACTER*4 IHARG
4550      CHARACTER*4 IARGT
4551      CHARACTER*4 IFOUND
4552      CHARACTER*4 IERROR
4553C
4554C---------------------------------------------------------------------
4555C
4556      DIMENSION IHARG(*)
4557      DIMENSION IARGT(*)
4558      DIMENSION ARG(*)
4559C
4560      DIMENSION CLLIMI(4)
4561C
4562C---------------------------------------------------------------------
4563C
4564      INCLUDE 'DPCOP2.INC'
4565C
4566C-----START POINT-----------------------------------------------------
4567C
4568      IFOUND='NO'
4569      IERROR='NO'
4570C
4571C               ************************************************************
4572C               **  TREAT THE CASE WHEN                                   **
4573C               **  THE HORIZONTAL VARIABLE UPPER BOUND IS TO BE CHANGED  **
4574C               ************************************************************
4575C
4576      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'XUPP')GOTO1100
4577      GOTO1199
4578C
4579 1100 CONTINUE
4580      IF(NUMARG.EQ.1)GOTO1110
4581      IF(IARGT(NUMARG).EQ.'NUMB')GOTO1120
4582      GOTO1110
4583C
4584 1110 CONTINUE
4585      IFOUND='YES'
4586      CLLIMI(2)=CPUMAX
4587C
4588      IF(IFEEDB.EQ.'OFF')GOTO1119
4589      WRITE(ICOUT,999)
4590  999 FORMAT(1X)
4591      CALL DPWRST('XXX','BUG ')
4592      WRITE(ICOUT,1115)
4593 1115 FORMAT('THE HORIZONTAL AXIS VARIABLE UPPER BOUND ')
4594      CALL DPWRST('XXX','BUG ')
4595      WRITE(ICOUT,1116)
4596 1116 FORMAT('(FOR DISTRIBUTIONAL PLOTS) HAS JUST BEEN SET')
4597      CALL DPWRST('XXX','BUG ')
4598      WRITE(ICOUT,1117)
4599 1117 FORMAT('SO THAT IT WILL BE    XBAR + 6*XSD')
4600      CALL DPWRST('XXX','BUG ')
4601 1119 CONTINUE
4602      GOTO1900
4603C
4604 1120 CONTINUE
4605      IFOUND='YES'
4606      CLLIMI(2)=ARG(NUMARG)
4607C
4608      IF(IFEEDB.EQ.'OFF')GOTO1129
4609      WRITE(ICOUT,999)
4610      CALL DPWRST('XXX','BUG ')
4611      WRITE(ICOUT,1125)
4612 1125 FORMAT('THE HORIZONTAL AXIS VARIABLE UPPER BOUND ')
4613      CALL DPWRST('XXX','BUG ')
4614      WRITE(ICOUT,1126)
4615 1126 FORMAT('(FOR DISTRIBUTIONAL PLOTS) HAS JUST BEEN SET')
4616      CALL DPWRST('XXX','BUG ')
4617      WRITE(ICOUT,1127)CLLIMI(1)
4618 1127 FORMAT('TO ',E15.7)
4619      CALL DPWRST('XXX','BUG ')
4620 1129 CONTINUE
4621      GOTO1900
4622C
4623 1199 CONTINUE
4624C
4625C               ************************************************************
4626C               **  TREAT THE CASE WHEN                                   **
4627C               **  THE VERTICAL   VARIABLE UPPER BOUND IS TO BE CHANGED  **
4628C               ************************************************************
4629C
4630      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'YUPP')GOTO1200
4631      GOTO1299
4632C
4633 1200 CONTINUE
4634      IF(NUMARG.EQ.1)GOTO1210
4635      IF(IARGT(NUMARG).EQ.'NUMB')GOTO1220
4636      GOTO1210
4637C
4638 1210 CONTINUE
4639      IFOUND='YES'
4640      CLLIMI(4)=CPUMAX
4641C
4642      IF(IFEEDB.EQ.'OFF')GOTO1219
4643      WRITE(ICOUT,999)
4644      CALL DPWRST('XXX','BUG ')
4645      WRITE(ICOUT,1215)
4646 1215 FORMAT('THE VERTICAL AXIS VARIABLE UPPER BOUND ')
4647      CALL DPWRST('XXX','BUG ')
4648      WRITE(ICOUT,1216)
4649 1216 FORMAT('(FOR DISTRIBUTIONAL PLOTS) HAS JUST BEEN SET')
4650      CALL DPWRST('XXX','BUG ')
4651      WRITE(ICOUT,1217)
4652 1217 FORMAT('SO THAT IT WILL BE    YBAR + 6*YSD')
4653      CALL DPWRST('XXX','BUG ')
4654 1219 CONTINUE
4655      GOTO1900
4656C
4657 1220 CONTINUE
4658      IFOUND='YES'
4659      CLLIMI(4)=ARG(NUMARG)
4660C
4661      IF(IFEEDB.EQ.'OFF')GOTO1229
4662      WRITE(ICOUT,999)
4663      CALL DPWRST('XXX','BUG ')
4664      WRITE(ICOUT,1225)
4665 1225 FORMAT('THE VERTICAL AXIS VARIABLE UPPER BOUND ')
4666      CALL DPWRST('XXX','BUG ')
4667      WRITE(ICOUT,1226)
4668 1226 FORMAT('(FOR DISTRIBUTIONAL PLOTS) HAS JUST BEEN SET')
4669      CALL DPWRST('XXX','BUG ')
4670      WRITE(ICOUT,1227)CLLIMI(4)
4671 1227 FORMAT('TO ',E15.7)
4672      CALL DPWRST('XXX','BUG ')
4673 1229 CONTINUE
4674      GOTO1900
4675C
4676 1299 CONTINUE
4677C
4678C               ************************************************************
4679C               **  TREAT THE CASE WHEN                                   **
4680C               **  THE UPPER BOUNDS FOR BOTH VARIABLES ARE TO BE CHANGED **
4681C               ************************************************************
4682C
4683      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'XYUP')GOTO1300
4684      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'YXUP')GOTO1300
4685      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'UPPE')GOTO1300
4686      GOTO1399
4687C
4688 1300 CONTINUE
4689      IF(NUMARG.EQ.1)GOTO1310
4690      IF(IARGT(NUMARG).EQ.'NUMB')GOTO1320
4691      GOTO1310
4692C
4693 1310 CONTINUE
4694      IFOUND='YES'
4695      CLLIMI(2)=CPUMAX
4696      CLLIMI(4)=CPUMAX
4697C
4698      IF(IFEEDB.EQ.'OFF')GOTO1319
4699      WRITE(ICOUT,999)
4700      CALL DPWRST('XXX','BUG ')
4701      WRITE(ICOUT,1315)
4702 1315 FORMAT('THE UPPER BOUNDS (FOR DISTRIBUTIONAL PLOTS) ')
4703      CALL DPWRST('XXX','BUG ')
4704      WRITE(ICOUT,1316)
4705 1316 FORMAT('FOR BOTH VARIABLES HAVE JUST BEEN SET')
4706      CALL DPWRST('XXX','BUG ')
4707      WRITE(ICOUT,1317)
4708 1317 FORMAT('SO THAT THEY WILL BE    AVERAGE + 6*SD')
4709      CALL DPWRST('XXX','BUG ')
4710 1319 CONTINUE
4711      GOTO1900
4712C
4713 1320 CONTINUE
4714      IFOUND='YES'
4715      CLLIMI(2)=ARG(NUMARG)
4716      CLLIMI(4)=ARG(NUMARG)
4717C
4718      IF(IFEEDB.EQ.'OFF')GOTO1329
4719      WRITE(ICOUT,999)
4720      CALL DPWRST('XXX','BUG ')
4721      WRITE(ICOUT,1325)
4722 1325 FORMAT('THE UPPER BOUNDS (FOR DISTRIBUTIONAL PLOTS) ')
4723      CALL DPWRST('XXX','BUG ')
4724      WRITE(ICOUT,1326)
4725 1326 FORMAT('FOR BOTH VARIABLES HAVE JUST BEEN SET')
4726      CALL DPWRST('XXX','BUG ')
4727      WRITE(ICOUT,1327)CLLIMI(2)
4728 1327 FORMAT('TO ',E15.7)
4729      CALL DPWRST('XXX','BUG ')
4730 1329 CONTINUE
4731      GOTO1900
4732C
4733 1399 CONTINUE
4734C
4735 1900 CONTINUE
4736      RETURN
4737      END
4738      SUBROUTINE DPCLWI(IHARG,IARGT,ARG,NUMARG,
4739     1CLWIDT,IFOUND,IERROR)
4740C
4741C     PURPOSE--DEFINE THE CLASS WIDTH
4742C              FOR HORIZONTAL VARIABLE OR VERTICAL VARIABLE OR BOTH
4743C              FOR DISTRIBUTIONAL PLOTS (E.G., HISTOGRAMS).
4744C              THE 2 CLASS WIDTHS (ONE FOR THE X AXIS VARIABLE
4745C              AND ONE FOR THE Y AXIS VARIABLE)
4746C              ARE CONTAINED IN THE FIRST AND SECOND ELEMENTS OF THE
4747C              2-ELEMENT VECTOR CLWIDT(.).
4748C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
4749C                     --IARGT  (A  HOLLERITH VECTOR)
4750C                     --ARG    (A  FLOATING POINT VECTOR)
4751C                     --NUMARG
4752C     OUTPUT ARGUMENTS--CLWIDT (A 2-ELEMENT FLOATING POINT VECTOR
4753C                              IN WHICH EACH ELEMENT IS AS FOLLOWS--
4754C                                 1) CLASS WIDTH FOR HORIZONTAL VARIABLE
4755C                                 2) CLASS WIDTH FOR VERTICAL VARIABLE
4756C                     --IFOUND ('YES' OR 'NO' )
4757C                     --IERROR ('YES' OR 'NO' )
4758C     WRITTEN BY--JAMES J. FILLIBEN
4759C                 STATISTICAL ENGINEERING DIVISION
4760C                 INFORMATION TECHNOLOGY LABORATORY
4761C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
4762C                 GAITHERSBURG, MD 20899-8980
4763C                 PHONE--301-975-2855
4764C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
4765C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
4766C     LANGUAGE--ANSI FORTRAN (1977)
4767C     VERSION NUMBER--82/7
4768C     ORIGINAL VERSION--NOVEMBER  1978.
4769C     UPDATED         --SEPTEMBER 1980.
4770C     UPDATED         --MAY       1981.
4771C     UPDATED         --MAY       1982.
4772C
4773C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
4774C
4775      CHARACTER*4 IHARG
4776      CHARACTER*4 IARGT
4777      CHARACTER*4 IFOUND
4778      CHARACTER*4 IERROR
4779C
4780C---------------------------------------------------------------------
4781C
4782      DIMENSION IHARG(*)
4783      DIMENSION IARGT(*)
4784      DIMENSION ARG(*)
4785C
4786      DIMENSION CLWIDT(2)
4787C
4788C---------------------------------------------------------------------
4789C
4790      INCLUDE 'DPCOP2.INC'
4791C
4792C-----START POINT-----------------------------------------------------
4793C
4794      IFOUND='NO'
4795      IERROR='NO'
4796C
4797C               ************************************************************
4798C               **  TREAT THE CASE WHEN                                   **
4799C               **  THE HORIZONTAL VARIABLE CLASS WIDTH IS TO BE CHANGED  **
4800C               ************************************************************
4801C
4802      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'XWID')GOTO1100
4803      GOTO1199
4804C
4805 1100 CONTINUE
4806      IF(NUMARG.EQ.1)GOTO1110
4807      IF(IARGT(NUMARG).EQ.'NUMB')GOTO1120
4808      GOTO1110
4809C
4810 1110 CONTINUE
4811      IFOUND='YES'
4812      CLWIDT(1)=CPUMIN
4813C
4814      IF(IFEEDB.EQ.'OFF')GOTO1119
4815      WRITE(ICOUT,999)
4816  999 FORMAT(1X)
4817      CALL DPWRST('XXX','BUG ')
4818      WRITE(ICOUT,1115)
4819 1115 FORMAT('THE HORIZONTAL AXIS VARIABLE CLASS WIDTH ')
4820      CALL DPWRST('XXX','BUG ')
4821      WRITE(ICOUT,1116)
4822 1116 FORMAT('(FOR DISTRIBUTIONAL PLOTS) HAS JUST BEEN SET')
4823      CALL DPWRST('XXX','BUG ')
4824      WRITE(ICOUT,1117)
4825 1117 FORMAT('SO THAT IT WILL BE    0.3*XSD')
4826      CALL DPWRST('XXX','BUG ')
4827 1119 CONTINUE
4828      GOTO1900
4829C
4830 1120 CONTINUE
4831      IFOUND='YES'
4832      CLWIDT(1)=ARG(NUMARG)
4833C
4834      IF(IFEEDB.EQ.'OFF')GOTO1129
4835      WRITE(ICOUT,999)
4836      CALL DPWRST('XXX','BUG ')
4837      WRITE(ICOUT,1125)
4838 1125 FORMAT('THE HORIZONTAL AXIS VARIABLE CLASS WIDTH ')
4839      CALL DPWRST('XXX','BUG ')
4840      WRITE(ICOUT,1126)
4841 1126 FORMAT('(FOR DISTRIBUTIONAL PLOTS) HAS JUST BEEN SET')
4842      CALL DPWRST('XXX','BUG ')
4843      WRITE(ICOUT,1127)CLWIDT(1)
4844 1127 FORMAT('TO ',E15.7)
4845      CALL DPWRST('XXX','BUG ')
4846 1129 CONTINUE
4847      GOTO1900
4848C
4849 1199 CONTINUE
4850C
4851C               ************************************************************
4852C               **  TREAT THE CASE WHEN                                   **
4853C               **  THE VERTICAL   VARIABLE CLASS WIDTH IS TO BE CHANGED  **
4854C               ************************************************************
4855C
4856      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'YWID')GOTO1200
4857      GOTO1299
4858C
4859 1200 CONTINUE
4860      IF(NUMARG.EQ.1)GOTO1210
4861      IF(IARGT(NUMARG).EQ.'NUMB')GOTO1220
4862      GOTO1210
4863C
4864 1210 CONTINUE
4865      IFOUND='YES'
4866      CLWIDT(2)=CPUMIN
4867C
4868      IF(IFEEDB.EQ.'OFF')GOTO1219
4869      WRITE(ICOUT,999)
4870      CALL DPWRST('XXX','BUG ')
4871      WRITE(ICOUT,1215)
4872 1215 FORMAT('THE VERTICAL AXIS VARIABLE CLASS WIDTH ')
4873      CALL DPWRST('XXX','BUG ')
4874      WRITE(ICOUT,1216)
4875 1216 FORMAT('(FOR DISTRIBUTIONAL PLOTS) HAS JUST BEEN SET')
4876      CALL DPWRST('XXX','BUG ')
4877      WRITE(ICOUT,1217)
4878 1217 FORMAT('SO THAT IT WILL BE    0.3*YSD')
4879      CALL DPWRST('XXX','BUG ')
4880 1219 CONTINUE
4881      GOTO1900
4882C
4883 1220 CONTINUE
4884      IFOUND='YES'
4885      CLWIDT(2)=ARG(NUMARG)
4886C
4887      IF(IFEEDB.EQ.'OFF')GOTO1229
4888      WRITE(ICOUT,999)
4889      CALL DPWRST('XXX','BUG ')
4890      WRITE(ICOUT,1225)
4891 1225 FORMAT('THE VERTICAL AXIS VARIABLE CLASS WIDTH ')
4892      CALL DPWRST('XXX','BUG ')
4893      WRITE(ICOUT,1226)
4894 1226 FORMAT('(FOR DISTRIBUTIONAL PLOTS) HAS JUST BEEN SET')
4895      CALL DPWRST('XXX','BUG ')
4896      WRITE(ICOUT,1227)CLWIDT(2)
4897 1227 FORMAT('TO ',E15.7)
4898      CALL DPWRST('XXX','BUG ')
4899 1229 CONTINUE
4900      GOTO1900
4901C
4902 1299 CONTINUE
4903C
4904C               ************************************************************
4905C               **  TREAT THE CASE WHEN                                   **
4906C               **  THE CLASS WIDTHS FOR BOTH VARIABLES ARE TO BE CHANGED **
4907C               ************************************************************
4908C
4909      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'XYWI')GOTO1300
4910      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'YXWI')GOTO1300
4911      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'WIDT')GOTO1300
4912      GOTO1399
4913C
4914 1300 CONTINUE
4915      IF(NUMARG.EQ.1)GOTO1310
4916      IF(IARGT(NUMARG).EQ.'NUMB')GOTO1320
4917      GOTO1310
4918C
4919 1310 CONTINUE
4920      IFOUND='YES'
4921      CLWIDT(1)=CPUMIN
4922      CLWIDT(2)=CPUMIN
4923C
4924      IF(IFEEDB.EQ.'OFF')GOTO1319
4925      WRITE(ICOUT,999)
4926      CALL DPWRST('XXX','BUG ')
4927      WRITE(ICOUT,1315)
4928 1315 FORMAT('THE CLASS WIDTHS (FOR DISTRIBUTIONAL PLOTS) ')
4929      CALL DPWRST('XXX','BUG ')
4930      WRITE(ICOUT,1316)
4931 1316 FORMAT('FOR BOTH VARIABLES HAVE JUST BEEN SET')
4932      CALL DPWRST('XXX','BUG ')
4933      WRITE(ICOUT,1317)
4934 1317 FORMAT('SO THAT THEY WILL BE    0.3*SD')
4935      CALL DPWRST('XXX','BUG ')
4936 1319 CONTINUE
4937      GOTO1900
4938C
4939 1320 CONTINUE
4940      IFOUND='YES'
4941      CLWIDT(1)=ARG(NUMARG)
4942      CLWIDT(2)=ARG(NUMARG)
4943C
4944      IF(IFEEDB.EQ.'OFF')GOTO1329
4945      WRITE(ICOUT,999)
4946      CALL DPWRST('XXX','BUG ')
4947      WRITE(ICOUT,1325)
4948 1325 FORMAT('THE CLASS WIDTHS (FOR DISTRIBUTIONAL PLOTS) ')
4949      CALL DPWRST('XXX','BUG ')
4950      WRITE(ICOUT,1326)
4951 1326 FORMAT('FOR BOTH VARIABLES HAVE JUST BEEN SET')
4952      CALL DPWRST('XXX','BUG ')
4953      WRITE(ICOUT,1327)CLWIDT(1)
4954 1327 FORMAT('TO ',E15.7)
4955      CALL DPWRST('XXX','BUG ')
4956 1329 CONTINUE
4957      GOTO1900
4958C
4959 1399 CONTINUE
4960C
4961 1900 CONTINUE
4962      RETURN
4963      END
4964      SUBROUTINE DPCMGP(Y,N,
4965     1                  GAMMA,A,GAMMSD,THRESH,
4966     1                  TEMP1,TEMP2,TEMP3,ITEMP1,
4967     1                  ALIKE,AIC,AICC,BIC,
4968     1                  ICAPSW,ICAPTY,IFORSW,
4969     1                  ISUBRO,IBUGA3,IERROR)
4970C
4971C     PURPOSE--THIS ROUTINE COMPUTES THE CME
4972C              ESTIMATES FOR THE GENERALIZED PARETO DISTRIBUTION.
4973C              THIS IS USED IN EXTREME VALUE APPLICATIONS.
4974C     EXAMPLE--CME Y
4975C     REFERENCE: GROSS, HECKERT, LECHNER, AND SIMIU (1995).  "EXTREME
4976C                WIND ESTIMATES BY THE CONDITIONAL MEAN EXCEEDANCE
4977C                PROCEDURE", NISTIT 5531.
4978C     WRITTEN BY--ALAN HECKERT
4979C                 STATISTICAL ENGINEERING DIVISION
4980C                 INFORMATION TECHNOLOGY LABORATORY
4981C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
4982C                 GAITHERSBURG, MD 20899-8980
4983C                 PHONE--301-975-2899
4984C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
4985C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
4986C     LANGUAGE--ANSI FORTRAN (1977)
4987C     VERSION NUMBER--98/5
4988C     ORIGINAL VERSION--MAY       1998.
4989C     UPDATED         --JUNE      2004. SUPPORT FOR IGEPDF
4990C     UPDATED         --APRIL     2005. A NUMBER OF ENHANCEMENTS
4991C     UPDATED         --OCTOBER   2010. SLIGHT TWEAK TO ALGORITHM
4992C                                       IN REGARD TO THE THRESHOLD
4993C     UPDATED         --OCTOBER   2010. CALL GEPLI1 TO OBTAIN
4994C                                       LIKELIHOOD, AIC VALUES
4995C     UPDATED         --OCTOBER   2010. USE DPDTA1 TO PRINT
4996C
4997C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
4998C
4999      CHARACTER*4 ICAPSW
5000      CHARACTER*4 ICAPTY
5001      CHARACTER*4 IFORSW
5002      CHARACTER*4 ISUBRO
5003      CHARACTER*4 IBUGA3
5004      CHARACTER*4 IERROR
5005C
5006      CHARACTER*4 ISUBN1
5007      CHARACTER*4 ISUBN2
5008      CHARACTER*4 ISTEPN
5009      CHARACTER*4 IWRITE
5010      CHARACTER*8 ISIGN1
5011      CHARACTER*8 ISIGN2
5012C
5013C---------------------------------------------------------------------
5014C
5015      DIMENSION Y(*)
5016C
5017      DIMENSION TEMP1(*)
5018      DIMENSION TEMP2(*)
5019      DIMENSION TEMP3(*)
5020      DIMENSION ITEMP1(*)
5021C
5022      DOUBLE PRECISION DGAMMA
5023      DOUBLE PRECISION DA
5024      DOUBLE PRECISION DB
5025      EXTERNAL DGAMMA
5026C
5027      INCLUDE 'DPCOST.INC'
5028C
5029      PARAMETER (MAXROW=40)
5030      CHARACTER*60 ITITLE
5031      CHARACTER*60 ITITLZ
5032      CHARACTER*60 ITEXT(MAXROW)
5033      REAL         AVALUE(MAXROW)
5034      INTEGER      NCTEXT(MAXROW)
5035      INTEGER      IDIGIT(MAXROW)
5036      INTEGER      NTOT(MAXROW)
5037      LOGICAL IFIRST
5038      LOGICAL ILAST
5039C
5040      CHARACTER*40 IDIST
5041C
5042      DIMENSION QP(1)
5043C
5044C---------------------------------------------------------------------
5045C
5046      INCLUDE 'DPCOP2.INC'
5047C
5048      DATA PI / 3.1415926535/
5049      DATA MINSIZ /5/
5050C
5051C-----START POINT-----------------------------------------------------
5052C
5053      ISUBN1='DPCM'
5054      ISUBN2='GP  '
5055      IERROR='NO'
5056C
5057      GAMMA=CPUMIN
5058      GAMMSD=CPUMIN
5059      A=CPUMIN
5060      SCALE=-99.0
5061      GAMMA2=-99.0
5062C
5063      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CMGP')THEN
5064        WRITE(ICOUT,999)
5065  999   FORMAT(1X)
5066        CALL DPWRST('XXX','WRIT')
5067        WRITE(ICOUT,51)
5068   51   FORMAT('**** AT THE BEGINNING OF DPCMGP--')
5069        CALL DPWRST('XXX','WRIT')
5070        WRITE(ICOUT,53)IBUGA3,ISUBRO,MAXNXT
5071   53   FORMAT('IBUGA3,ISUBRO,MAXNXT = ',2(A4,2X),I8)
5072        CALL DPWRST('XXX','WRIT')
5073        WRITE(ICOUT,55)N,MINSIZ,PPOTTO,THRESH
5074   55   FORMAT('N,MINSIZ,PPOTTO,THRESH = ',2I8,2G15.7)
5075        CALL DPWRST('XXX','WRIT')
5076        DO56I=1,N
5077          WRITE(ICOUT,57)I,Y(I)
5078   57     FORMAT('I,Y(I) = ',I8,G15.7)
5079          CALL DPWRST('XXX','WRIT')
5080   56   CONTINUE
5081       ENDIF
5082C
5083C               ********************************************
5084C               **  STEP 11--                             **
5085C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
5086C               ********************************************
5087C
5088      ISTEPN='11'
5089      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CMGP')
5090     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5091C
5092      NPERC=0
5093      NTEMP=MINSIZ-1
5094      CALL CKDIST(Y,N,NTEMP,QP,NPERC,ISUBRO,IBUGA3,IERROR)
5095      IF(IERROR.EQ.'YES')GOTO9000
5096C
5097      IDIST='GENERALIZED PARETO (CME)'
5098      IFLAG=0
5099C
5100      CALL SUMRAW(Y,N,IDIST,IFLAG,
5101     1            XMEAN,XVAR,XSD,XMIN,XMAX,
5102     1            ISUBRO,IBUGA3,IERROR)
5103C
5104C
5105C               ********************************************
5106C               **  STEP 21--                             **
5107C               **  CARRY OUT CALCULATIONS                **
5108C               **  FOR CME    ESTIMATE                   **
5109C               **  SORT THE DATA                         **
5110C               **  AND IDENTIFY POINTS ABOVE THE THRESHOLD*
5111C               ********************************************
5112C
5113      ISTEPN='21'
5114      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CMGP')
5115     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5116C
5117C     NOTE 10/2010: DEFINE THRESHOLD AS MINIMUM VALUE, NOT
5118C     MINIMUM MINUS EPSILON.
5119C
5120      CALL SORT(Y,N,Y)
5121      EPS=0.0001
5122CCCCC IF(THRESH.LE.0.0)THRESH=Y(1)-EPS
5123      IF(THRESH.LE.0.0)THRESH=Y(1)
5124      DO2110I=1,N
5125        IF(Y(I).GT.THRESH)THEN
5126          IFRST=I
5127          GOTO2119
5128        ENDIF
5129 2110 CONTINUE
5130      IFRST=N+1
5131 2119 CONTINUE
5132C
5133      NUSE=N-IFRST+1
5134      IF(NUSE.LT.2)THEN
5135        WRITE(ICOUT,999)
5136        CALL DPWRST('XXX','WRIT')
5137        WRITE(ICOUT,1111)
5138 1111   FORMAT('****** ERROR IN GENERALIZED PARETO CME ESTIMATION--')
5139        CALL DPWRST('XXX','WRIT')
5140        WRITE(ICOUT,2121)
5141 2121   FORMAT('      NO POINTS ARE ABOVE THE THRESHOLD.')
5142        CALL DPWRST('XXX','WRIT')
5143        WRITE(ICOUT,2123)THRESH
5144 2123   FORMAT('      THRESHOLD          = ',G15.7)
5145        CALL DPWRST('XXX','WRIT')
5146        WRITE(ICOUT,2125)Y(N)
5147 2125   FORMAT('      MAXIMUM DATA POINT = ',G15.7)
5148        CALL DPWRST('XXX','WRIT')
5149        IERROR='YES'
5150        GOTO9000
5151      ENDIF
5152C
5153      IF(Y(IFRST).LT.0.0)THEN
5154        WRITE(ICOUT,999)
5155        CALL DPWRST('XXX','WRIT')
5156        WRITE(ICOUT,1111)
5157        CALL DPWRST('XXX','WRIT')
5158        WRITE(ICOUT,2131)
5159 2131   FORMAT('      NEGATIVE VALUES ENCOUNTERED IN THE INPUT DATA.')
5160        CALL DPWRST('XXX','WRIT')
5161        IERROR='YES'
5162        GOTO9000
5163      ENDIF
5164C
5165      CALL CMESUB(Y(IFRST),NUSE,THRESH,SLOPE,R1,
5166     1            TEMP1,TEMP2,TEMP3,ITEMP1,GAMMSD)
5167      IF(SLOPE.EQ.CPUMIN)THEN
5168        WRITE(ICOUT,999)
5169        CALL DPWRST('XXX','WRIT')
5170        WRITE(ICOUT,1111)
5171        CALL DPWRST('XXX','WRIT')
5172        WRITE(ICOUT,2141)
5173 2141   FORMAT('      UNABLE TO COMPUTE CME ESTIMATES.')
5174        CALL DPWRST('XXX','WRIT')
5175        IERROR='YES'
5176        GOTO9000
5177      ENDIF
5178C
5179      GAMMA=SLOPE/(1.0+SLOPE)
5180      A=R1*(1.0-GAMMA)
5181C
5182      IWRITE='OFF'
5183      CALL MEAN(Y(IFRST),NUSE,IWRITE,ZMEAN,IBUGA3,IERROR)
5184      CALL VAR(Y(IFRST),NUSE,IWRITE,ZVAR,IBUGA3,IERROR)
5185      ZSD=SQRT(ZVAR)
5186      IF(ABS(GAMMA).LE.PPOTTO)THEN
5187        SCALE=ZSD*SQRT(6.0)/PI
5188        ALOC=ZMEAN - 0.57722*SCALE
5189      ELSEIF(GAMMA.LT.0.0)THEN
5190        GAMMA2=-1.0/GAMMA
5191        DA=DGAMMA(DBLE((GAMMA2+1.0)/GAMMA2))
5192        DB=DGAMMA(DBLE((GAMMA2+2.0)/GAMMA2)) - DA*DA
5193        IF(DB.GT.0.0D0)THEN
5194          SCALE=ZSD/REAL(DSQRT(DB))
5195          ALOC=ZMEAN + SCALE*REAL(DA)
5196        ELSE
5197          SCALE=0.0
5198          ALOC=0.0
5199        ENDIF
5200      ELSE
5201      ENDIF
5202C
5203C  DEPENDING ON WHAT DEFINITION OF GENERALIZED PARETO PREFERRED,
5204C  REVERSE SIGN OF GAMMA.
5205C
5206      IF(IGEPDF.EQ.'SIMI')THEN
5207        GAMMSV=GAMMA
5208        ISIGN1='negative'
5209        ISIGN2='positive'
5210      ELSE
5211        GAMMSV=-GAMMA
5212        ISIGN1='positive'
5213        ISIGN2='negative'
5214      ENDIF
5215C
5216C     NOTE THAT LIKELIHOOD IS NOT ALWAYS DEFINED (CAN GET LOG OF
5217C     NEGATIVE NUMBER).  SO PRINTING IS CONDITIONAL ON THESE VALUES
5218C     ACTUALLY BEING COMPUTED.
5219C
5220      ALIKE=CPUMIN
5221      AIC=CPUMIN
5222      AICC=CPUMIN
5223      BIC=CPUMIN
5224      MINMXZ=2
5225      CALL GEPLI1(Y(IFRST),NUSE,MINMXZ,IGEPDF,
5226     1            ALOC,A,GAMMSV,
5227     1            ALIKE,AIC,AICC,BIC,
5228     1            ISUBRO,IBUGA3,IERROR)
5229C
5230C               *********************************
5231C               **   STEP 42--                 **
5232C               **   WRITE OUT EVERYTHING      **
5233C               **   FOR CME         ESTIMATE  **
5234C               *********************************
5235C
5236      ISTEPN='42'
5237      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CMGP')
5238     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5239C
5240      IF(IPRINT.EQ.'OFF')GOTO9000
5241C
5242      NUMDIG=7
5243      IF(IFORSW.EQ.'1')NUMDIG=1
5244      IF(IFORSW.EQ.'2')NUMDIG=2
5245      IF(IFORSW.EQ.'3')NUMDIG=3
5246      IF(IFORSW.EQ.'4')NUMDIG=4
5247      IF(IFORSW.EQ.'5')NUMDIG=5
5248      IF(IFORSW.EQ.'6')NUMDIG=6
5249      IF(IFORSW.EQ.'7')NUMDIG=7
5250      IF(IFORSW.EQ.'8')NUMDIG=8
5251      IF(IFORSW.EQ.'9')NUMDIG=9
5252      IF(IFORSW.EQ.'0')NUMDIG=0
5253      IF(IFORSW.EQ.'E')NUMDIG=-2
5254      IF(IFORSW.EQ.'-2')NUMDIG=-2
5255      IF(IFORSW.EQ.'-3')NUMDIG=-3
5256      IF(IFORSW.EQ.'-4')NUMDIG=-4
5257      IF(IFORSW.EQ.'-5')NUMDIG=-5
5258      IF(IFORSW.EQ.'-6')NUMDIG=-6
5259      IF(IFORSW.EQ.'-7')NUMDIG=-7
5260      IF(IFORSW.EQ.'-8')NUMDIG=-8
5261      IF(IFORSW.EQ.'-9')NUMDIG=-9
5262C
5263      ITITLE='Generalized Pareto Parameter Estimation (CME)'
5264      NCTITL=45
5265      ITITLZ='(Maximum Case)'
5266      NCTITZ=14
5267      ICNT=1
5268      ITEXT(ICNT)='Summary Statistics (Full Data Set):'
5269      NCTEXT(ICNT)=35
5270      AVALUE(ICNT)=0.0
5271      IDIGIT(ICNT)=-1
5272      ICNT=ICNT+1
5273      ITEXT(ICNT)='Number of Observations:'
5274      NCTEXT(ICNT)=23
5275      AVALUE(ICNT)=REAL(N)
5276      IDIGIT(ICNT)=0
5277      ICNT=ICNT+1
5278      ITEXT(ICNT)='Sample Mean:'
5279      NCTEXT(ICNT)=12
5280      AVALUE(ICNT)=XMEAN
5281      IDIGIT(ICNT)=NUMDIG
5282      ICNT=ICNT+1
5283      ITEXT(ICNT)='Sample Standard Deviation:'
5284      NCTEXT(ICNT)=26
5285      AVALUE(ICNT)=XSD
5286      IDIGIT(ICNT)=NUMDIG
5287      ICNT=ICNT+1
5288      ITEXT(ICNT)='Sample Minimum:'
5289      NCTEXT(ICNT)=15
5290      AVALUE(ICNT)=XMIN
5291      IDIGIT(ICNT)=NUMDIG
5292      ICNT=ICNT+1
5293      ITEXT(ICNT)='Sample Maximum:'
5294      NCTEXT(ICNT)=15
5295      AVALUE(ICNT)=XMAX
5296      IDIGIT(ICNT)=NUMDIG
5297      ICNT=ICNT+1
5298      ITEXT(ICNT)=' '
5299      NCTEXT(ICNT)=0
5300      AVALUE(ICNT)=0.0
5301      IDIGIT(ICNT)=-1
5302C
5303      ICNT=ICNT+1
5304      ITEXT(ICNT)='Summary Statistics for'
5305      NCTEXT(ICNT)=22
5306      AVALUE(ICNT)=0.0
5307      IDIGIT(ICNT)=-1
5308      ICNT=ICNT+1
5309      ITEXT(ICNT)='Observations Above Threshold:'
5310      NCTEXT(ICNT)=29
5311      AVALUE(ICNT)=0.0
5312      IDIGIT(ICNT)=-1
5313      ICNT=ICNT+1
5314      ITEXT(ICNT)='Threshold:'
5315      NCTEXT(ICNT)=10
5316      AVALUE(ICNT)=THRESH
5317      IDIGIT(ICNT)=NUMDIG
5318      ICNT=ICNT+1
5319      ITEXT(ICNT)='Number of Observations Above Threshold:'
5320      NCTEXT(ICNT)=39
5321      AVALUE(ICNT)=REAL(NUSE)
5322      IDIGIT(ICNT)=0
5323      ICNT=ICNT+1
5324      ITEXT(ICNT)='Sample Mean:'
5325      NCTEXT(ICNT)=12
5326      AVALUE(ICNT)=ZMEAN
5327      IDIGIT(ICNT)=NUMDIG
5328      ICNT=ICNT+1
5329      ITEXT(ICNT)='Sample Standard Deviation:'
5330      NCTEXT(ICNT)=26
5331      AVALUE(ICNT)=ZSD
5332      IDIGIT(ICNT)=NUMDIG
5333C
5334      ICNT=ICNT+1
5335      ITEXT(ICNT)=' '
5336      NCTEXT(ICNT)=0
5337      AVALUE(ICNT)=0.0
5338      IDIGIT(ICNT)=-1
5339      ICNT=ICNT+1
5340      ITEXT(ICNT)='CME Parameter Estimates:'
5341      NCTEXT(ICNT)=24
5342      AVALUE(ICNT)=0.0
5343      IDIGIT(ICNT)=-1
5344      ICNT=ICNT+1
5345      ITEXT(ICNT)='Location Parameter:'
5346      NCTEXT(ICNT)=19
5347      AVALUE(ICNT)=THRESH
5348      IDIGIT(ICNT)=NUMDIG
5349      ICNT=ICNT+1
5350      ITEXT(ICNT)='Scale Parameter:'
5351      NCTEXT(ICNT)=16
5352      AVALUE(ICNT)=A
5353      IDIGIT(ICNT)=NUMDIG
5354      ICNT=ICNT+1
5355      ITEXT(ICNT)='Shape Parameter (Gamma):'
5356      NCTEXT(ICNT)=24
5357      AVALUE(ICNT)=GAMMSV
5358      IDIGIT(ICNT)=NUMDIG
5359      ICNT=ICNT+1
5360      ITEXT(ICNT)='Standard Deviation of Gamma:'
5361      NCTEXT(ICNT)=28
5362      AVALUE(ICNT)=GAMMSD
5363      IDIGIT(ICNT)=NUMDIG
5364      IF(ALIKE.NE.CPUMIN)THEN
5365        ICNT=ICNT+1
5366        ITEXT(ICNT)='Log-likelihood:'
5367        NCTEXT(ICNT)=15
5368        AVALUE(ICNT)=ALIKE
5369        IDIGIT(ICNT)=-7
5370        ICNT=ICNT+1
5371        ITEXT(ICNT)='AIC:'
5372        NCTEXT(ICNT)=4
5373        AVALUE(ICNT)=AIC
5374        IDIGIT(ICNT)=-7
5375        ICNT=ICNT+1
5376        ITEXT(ICNT)='AICc:'
5377        NCTEXT(ICNT)=5
5378        AVALUE(ICNT)=AICC
5379        IDIGIT(ICNT)=-7
5380        ICNT=ICNT+1
5381        ITEXT(ICNT)='BIC:'
5382        NCTEXT(ICNT)=4
5383        AVALUE(ICNT)=BIC
5384        IDIGIT(ICNT)=-7
5385      ENDIF
5386C
5387      ICNT=ICNT+1
5388      ITEXT(ICNT)=' '
5389      NCTEXT(ICNT)=0
5390      AVALUE(ICNT)=0.0
5391      IDIGIT(ICNT)=-1
5392C
5393      IF(GAMMA.LT.-PPOTTO)THEN
5394        ICNT=ICNT+1
5395        ITEXT(ICNT)(1:4)='For '
5396        WRITE(ITEXT(ICNT)(5:12),'(A8)')ISIGN1
5397        ITEXT(ICNT)(13:42)=' Gamma, the generalized Pareto'
5398        NCTEXT(ICNT)=42
5399        AVALUE(ICNT)=0.0
5400        IDIGIT(ICNT)=-1
5401        ICNT=ICNT+1
5402        ITEXT(ICNT)(1:34)='is equivalent to a reverse Weibull'
5403        NCTEXT(ICNT)=34
5404        AVALUE(ICNT)=0.0
5405        IDIGIT(ICNT)=-1
5406        ICNT=ICNT+1
5407        ITEXT(ICNT)(1:22)='(SET MINMAX MAX) with:'
5408        NCTEXT(ICNT)=22
5409        AVALUE(ICNT)=0.0
5410        IDIGIT(ICNT)=-1
5411        ICNT=ICNT+1
5412        ITEXT(ICNT)='Shape Parameter (Gamma):'
5413        NCTEXT(ICNT)=24
5414        AVALUE(ICNT)=GAMMA2
5415        IDIGIT(ICNT)=NUMDIG
5416        ICNT=ICNT+1
5417        ITEXT(ICNT)='Location Parameter:'
5418        NCTEXT(ICNT)=19
5419        AVALUE(ICNT)=ALOC
5420        IDIGIT(ICNT)=NUMDIG
5421        ICNT=ICNT+1
5422        ITEXT(ICNT)='Scale Parameter:'
5423        NCTEXT(ICNT)=16
5424        AVALUE(ICNT)=SCALE
5425        IDIGIT(ICNT)=NUMDIG
5426      ELSEIF(ABS(GAMMA).LE.PPOTTO)THEN
5427        ICNT=ICNT+1
5428        ITEXT(ICNT)(1:40)='For Gamma = zero, the generalized Pareto'
5429        NCTEXT(ICNT)=40
5430        AVALUE(ICNT)=0.0
5431        IDIGIT(ICNT)=-1
5432        ICNT=ICNT+1
5433        ITEXT(ICNT)(1:40)='is equivalent to an extreme value type I'
5434        NCTEXT(ICNT)=34
5435        AVALUE(ICNT)=0.0
5436        IDIGIT(ICNT)=-1
5437        ICNT=ICNT+1
5438        ITEXT(ICNT)(1:14)='(Gumbel) with:'
5439        NCTEXT(ICNT)=14
5440        AVALUE(ICNT)=0.0
5441        IDIGIT(ICNT)=-1
5442        ICNT=ICNT+1
5443        ITEXT(ICNT)='Location Parameter:'
5444        NCTEXT(ICNT)=19
5445        AVALUE(ICNT)=ALOC
5446        IDIGIT(ICNT)=NUMDIG
5447        ICNT=ICNT+1
5448        ITEXT(ICNT)='Scale Parameter:'
5449        NCTEXT(ICNT)=16
5450        AVALUE(ICNT)=SCALE
5451        IDIGIT(ICNT)=NUMDIG
5452      ELSE
5453        ICNT=ICNT+1
5454        ITEXT(ICNT)(1:4)='For '
5455        WRITE(ITEXT(ICNT)(5:12),'(A8)')ISIGN2
5456        ITEXT(ICNT)(13:42)=' Gamma, the generalized Pareto'
5457        NCTEXT(ICNT)=42
5458        AVALUE(ICNT)=0.0
5459        IDIGIT(ICNT)=-1
5460        ICNT=ICNT+1
5461        ITEXT(ICNT)(1:28)='is equivalent to a (maximum)'
5462        NCTEXT(ICNT)=28
5463        AVALUE(ICNT)=0.0
5464        IDIGIT(ICNT)=-1
5465        ICNT=ICNT+1
5466        ITEXT(ICNT)(1:31)='extreme value type II (Frechet)'
5467        NCTEXT(ICNT)=31
5468        AVALUE(ICNT)=0.0
5469        IDIGIT(ICNT)=-1
5470        ICNT=ICNT+1
5471        ITEXT(ICNT)='Shape Parameter (Gamma):'
5472        NCTEXT(ICNT)=24
5473        AVALUE(ICNT)=GAMMA2
5474        IDIGIT(ICNT)=NUMDIG
5475        ICNT=ICNT+1
5476        ITEXT(ICNT)='Location Parameter:'
5477        NCTEXT(ICNT)=19
5478        AVALUE(ICNT)=ALOC
5479        IDIGIT(ICNT)=NUMDIG
5480        ICNT=ICNT+1
5481        ITEXT(ICNT)='Scale Parameter:'
5482        NCTEXT(ICNT)=16
5483        AVALUE(ICNT)=SCALE
5484        IDIGIT(ICNT)=NUMDIG
5485      ENDIF
5486C
5487      NUMROW=ICNT
5488      DO2320I=1,NUMROW
5489        NTOT(I)=15
5490 2320 CONTINUE
5491C
5492      IFIRST=.TRUE.
5493      ILAST=.TRUE.
5494      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
5495     1            AVALUE,IDIGIT,
5496     1            NTOT,NUMROW,
5497     1            ICAPSW,ICAPTY,ILAST,IFIRST,
5498     1            ISUBRO,IBUGA3,IERROR)
5499C
5500      IF(ICAPSW.EQ.'OFF' .AND. ICAPTY.EQ.'TEXT')THEN
5501      IF(IFEEDB.EQ.'ON')THEN
5502        WRITE(ICOUT,999)
5503        CALL DPWRST('XXX','BUG ')
5504        WRITE(ICOUT,4941)
5505 4941   FORMAT('GAMMA, SDGAMMA, AND A WILL BE SAVED AS INTERNAL ',
5506     1         'PARAMETERS.')
5507        CALL DPWRST('XXX','BUG ')
5508        IF(GAMMA.LT.-PPOTTO)THEN
5509          WRITE(ICOUT,4951)
5510 4951     FORMAT('THE REVERSE WEIBULL PARAMETERS WILL BE SAVED AS')
5511          CALL DPWRST('XXX','WRIT')
5512          WRITE(ICOUT,4953)
5513 4953     FORMAT('THE INTERNAL PARAMETERS GAMMA2, LOC, AND SCALE, ',
5514     1           ' RESPECTIVELY.')
5515          CALL DPWRST('XXX','WRIT')
5516        ELSEIF(ABS(GAMMA).LT.PPOTTO)THEN
5517          WRITE(ICOUT,4961)
5518 4961     FORMAT('THE GUMBEL PARAMETERS WILL BE SAVED AS THE ',
5519     1           'INTERNAL PARAMETERS LOC AND SCALE, RESPECTIVELY.')
5520          CALL DPWRST('XXX','BUG ')
5521        ENDIF
5522        WRITE(ICOUT,999)
5523        CALL DPWRST('XXX','BUG ')
5524      ENDIF
5525      ENDIF
5526C
5527C
5528C               *****************
5529C               **  STEP 90--  **
5530C               **  EXIT       **
5531C               *****************
5532C
5533 9000 CONTINUE
5534      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CMGP')THEN
5535        WRITE(ICOUT,999)
5536        CALL DPWRST('XXX','WRIT')
5537        WRITE(ICOUT,9011)
5538 9011   FORMAT('***** AT THE END       OF DPCMGP--')
5539        CALL DPWRST('XXX','WRIT')
5540        WRITE(ICOUT,9012)N,IBUGA3,IERROR
5541 9012   FORMAT('N,IBUGA3,IERROR = ',I8,2X,A4,2X,A4)
5542        CALL DPWRST('XXX','WRIT')
5543      ENDIF
5544C
5545      RETURN
5546      END
5547      SUBROUTINE DPCME(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
5548     1                 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
5549C
5550C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
5551C              THAT WILL DEFINE ONE OF THE FOLLOWING 4
5552C              CONDITIONAL EXCEEDANCE PLOTS--
5553C                 CONDITIONAL EXCEEDANCE PLOT Y
5554C                 CONDITIONAL MEAN EXCEEDANCE PLOT Y (= CME PLOT Y)
5555C                 CONDITIONAL MEDIAN EXCEEDANCE PLOT Y
5556C                 CONDITIONAL MIDMEAN EXCEEDANCE PLOT Y
5557C     NOTE--THERE ARE MANY SYNONYMS FOR THE CME PLOT--
5558C              YANG PLOT
5559C              MEAN RESIDUAL LIFE PLOT
5560C              LIFE EXPECTANCY PLOT
5561C              MEAN LIFE EXPECTANCY PLOT
5562C     WRITTEN BY--JAMES J. FILLIBEN
5563C                 STATISTICAL ENGINEERING DIVISION
5564C                 INFORMATION TECHNOLOGY LABORATORY
5565C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
5566C                 GAITHERSBURG, MD 20899-8980
5567C                 PHONE--301-975-2855
5568C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
5569C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
5570C     LANGUAGE--ANSI FORTRAN (1977)
5571C     VERSION NUMBER--93/12
5572C     ORIGINAL VERSION--DECEMBER  1993.
5573C     UPDATED         --DECEMBER  1993. LINFIT ARGS: PROTECT RESSD/DF
5574C     UPDATED         --JANUARY   2012. USE DPPARS
5575C
5576C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
5577C
5578      CHARACTER*4 ICASPL
5579      CHARACTER*4 IAND1
5580      CHARACTER*4 IAND2
5581      CHARACTER*4 IBUGG2
5582      CHARACTER*4 IBUGG3
5583      CHARACTER*4 IBUGQ
5584      CHARACTER*4 ISUBRO
5585      CHARACTER*4 IFOUND
5586      CHARACTER*4 IERROR
5587C
5588      CHARACTER*4 IH
5589      CHARACTER*4 IH2
5590      CHARACTER*4 ISUBN0
5591      CHARACTER*4 ISUBN1
5592      CHARACTER*4 ISUBN2
5593      CHARACTER*4 ISTEPN
5594      CHARACTER*4 IWRITE
5595C
5596      CHARACTER*4 ICASE
5597      CHARACTER*40 INAME
5598      PARAMETER (MAXSPN=10)
5599      CHARACTER*4 IVARN1(MAXSPN)
5600      CHARACTER*4 IVARN2(MAXSPN)
5601      CHARACTER*4 IVARTY(MAXSPN)
5602      REAL PVAR(MAXSPN)
5603      INTEGER ILIS(MAXSPN)
5604      INTEGER NRIGHT(MAXSPN)
5605      INTEGER ICOLR(MAXSPN)
5606C
5607C---------------------------------------------------------------------
5608C
5609      INCLUDE 'DPCOPA.INC'
5610      INCLUDE 'DPCOZZ.INC'
5611C
5612      DIMENSION Y1(MAXOBV)
5613      DIMENSION XTEMP1(MAXOBV)
5614      DIMENSION XTEMP2(MAXOBV)
5615      DIMENSION XTEMP3(MAXOBV)
5616      DIMENSION XTEMP4(MAXOBV)
5617      EQUIVALENCE (GARBAG(IGARB1),Y1(1))
5618      EQUIVALENCE (GARBAG(IGARB2),XTEMP1(1))
5619      EQUIVALENCE (GARBAG(IGARB3),XTEMP2(1))
5620      EQUIVALENCE (GARBAG(IGARB4),XTEMP3(1))
5621      EQUIVALENCE (GARBAG(IGARB5),XTEMP4(1))
5622C
5623C-----COMMON----------------------------------------------------------
5624C
5625      INCLUDE 'DPCOHK.INC'
5626      INCLUDE 'DPCODA.INC'
5627      INCLUDE 'DPCOHO.INC'
5628C
5629C-----COMMON VARIABLES (GENERAL)--------------------------------------
5630C
5631      INCLUDE 'DPCOP2.INC'
5632C
5633C-----START POINT-----------------------------------------------------
5634C
5635      IFOUND='NO'
5636      IERROR='NO'
5637      ISUBN1='DPCM'
5638      ISUBN2='E   '
5639C
5640      MAXCP1=MAXCOL+1
5641      MAXCP2=MAXCOL+2
5642      MAXCP3=MAXCOL+3
5643      MAXCP4=MAXCOL+4
5644      MAXCP5=MAXCOL+5
5645      MAXCP6=MAXCOL+6
5646C
5647C               **************************************************
5648C               **  TREAT THE COND. ... EXCEEDANCE    PLOT CASE **
5649C               **************************************************
5650C
5651      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'CME')THEN
5652        WRITE(ICOUT,999)
5653  999   FORMAT(1X)
5654        CALL DPWRST('XXX','BUG ')
5655        WRITE(ICOUT,51)
5656   51   FORMAT('***** AT THE BEGINNING OF DPCME--')
5657        CALL DPWRST('XXX','BUG ')
5658        WRITE(ICOUT,52)ICASPL,IAND1,IAND2,MAXCOL
5659   52   FORMAT('ICASPL,IAND1,IAND2,MAXCOL = ',3(A4,2X),I8)
5660        CALL DPWRST('XXX','BUG ')
5661        WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ,ISUBRO
5662   53   FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',3(A4,2X),A4)
5663        CALL DPWRST('XXX','BUG ')
5664      ENDIF
5665C
5666C               ***************************
5667C               **  STEP 1--             **
5668C               **  EXTRACT THE COMMAND  **
5669C               ***************************
5670C
5671      ISTEPN='1'
5672      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'CME')
5673     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5674C
5675      ICASPL='CME'
5676C
5677      IF(ICOM.EQ.'CME')THEN
5678         IF(NUMARG.GE.1)THEN
5679            IF(IHARG(1).EQ.'PLOT')THEN
5680               ICASPL='MEAN'
5681               ILASTC=1
5682               GOTO111
5683            ENDIF
5684         ENDIF
5685      ENDIF
5686C
5687      IF(ICOM.EQ.'COND')THEN
5688         IF(NUMARG.GE.2)THEN
5689            IF(IHARG(1).EQ.'EXCE'.AND.IHARG(2).EQ.'PLOT')THEN
5690               ICASPL='SCAT'
5691               ILASTC=2
5692               GOTO111
5693            ENDIF
5694         ENDIF
5695C
5696         IF(NUMARG.GE.3)THEN
5697            IF(IHARG(1).EQ.'SCAT'.AND.IHARG(2).EQ.'EXCE'.AND.
5698     1      IHARG(3).EQ.'PLOT')THEN
5699               ICASPL='SCAT'
5700               ILASTC=3
5701               GOTO111
5702            ENDIF
5703         ENDIF
5704         IF(NUMARG.GE.3)THEN
5705            IF(IHARG(1).EQ.'MEAN'.AND.IHARG(2).EQ.'EXCE'.AND.
5706     1      IHARG(3).EQ.'PLOT')THEN
5707               ICASPL='MEAN'
5708               ILASTC=3
5709               GOTO111
5710            ENDIF
5711         ENDIF
5712         IF(NUMARG.GE.3)THEN
5713            IF(IHARG(1).EQ.'MEDI'.AND.IHARG(2).EQ.'EXCE'.AND.
5714     1      IHARG(3).EQ.'PLOT')THEN
5715               ICASPL='MEDI'
5716               ILASTC=3
5717               GOTO111
5718            ENDIF
5719         ENDIF
5720         IF(NUMARG.GE.3)THEN
5721            IF(IHARG(1).EQ.'MIDM'.AND.IHARG(2).EQ.'EXCE'.AND.
5722     1      IHARG(3).EQ.'PLOT')THEN
5723               ICASPL='MIDM'
5724               ILASTC=3
5725               GOTO111
5726            ENDIF
5727         ENDIF
5728      ENDIF
5729C
5730      IF(ICOM.EQ.'YANG')THEN
5731         IF(NUMARG.GE.1)THEN
5732            IF(IHARG(1).EQ.'PLOT')THEN
5733               ICASPL='MEAN'
5734               ILASTC=1
5735               GOTO111
5736            ENDIF
5737         ENDIF
5738      ENDIF
5739C
5740      IF(ICOM.EQ.'LIFE')THEN
5741         IF(NUMARG.GE.2)THEN
5742            IF(IHARG(1).EQ.'EXPE'.AND.IHARG(2).EQ.'PLOT')THEN
5743               ICASPL='MEAN'
5744               ILASTC=2
5745               GOTO111
5746            ENDIF
5747         ENDIF
5748      ENDIF
5749C
5750      IF(ICOM.EQ.'MEAN')THEN
5751         IF(NUMARG.GE.3)THEN
5752            IF(IHARG(1).EQ.'LIFE'.AND.IHARG(2).EQ.'EXPE'.AND.
5753     1      IHARG(3).EQ.'PLOT')THEN
5754               ICASPL='MEAN'
5755               ILASTC=3
5756               GOTO111
5757            ENDIF
5758         ENDIF
5759      ENDIF
5760C
5761      IF(ICOM.EQ.'MEAN')THEN
5762         IF(NUMARG.GE.3)THEN
5763            IF(IHARG(1).EQ.'RESI'.AND.IHARG(2).EQ.'LIFE'.AND.
5764     1      IHARG(3).EQ.'PLOT')THEN
5765               ICASPL='MEAN'
5766               ILASTC=3
5767               GOTO111
5768            ENDIF
5769         ENDIF
5770      ENDIF
5771C
5772      GOTO9000
5773C
5774  111 CONTINUE
5775      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
5776      IFOUND='YES'
5777C
5778C               ****************************************
5779C               **  STEP 2--                          **
5780C               **  EXTRACT THE VARIABLE LIST         **
5781C               ****************************************
5782C
5783      ISTEPN='2'
5784      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'CME')
5785     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5786C
5787      INAME='CME PLOT'
5788      MINNA=1
5789      MAXNA=100
5790      MINN2=1
5791      IFLAGE=1
5792      IFLAGM=1
5793      IFLAGP=0
5794      JMIN=1
5795      JMAX=NUMARG
5796      MINNVA=1
5797      MAXNVA=1
5798C
5799      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
5800     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
5801     1            JMIN,JMAX,
5802     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
5803     1            IVARN1,IVARN2,IVARTY,PVAR,
5804     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
5805     1            MINNVA,MAXNVA,
5806     1            IFLAGM,IFLAGP,
5807     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
5808      IF(IERROR.EQ.'YES')GOTO9000
5809C
5810      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'CME')THEN
5811        WRITE(ICOUT,999)
5812        CALL DPWRST('XXX','BUG ')
5813        WRITE(ICOUT,281)
5814  281   FORMAT('***** AFTER CALL DPPARS--')
5815        CALL DPWRST('XXX','BUG ')
5816        WRITE(ICOUT,282)NQ,NUMVAR
5817  282   FORMAT('NQ,NUMVAR = ',2I8)
5818        CALL DPWRST('XXX','BUG ')
5819        IF(NUMVAR.GT.0)THEN
5820          DO285I=1,NUMVAR
5821            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
5822     1                      ICOLR(I)
5823  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
5824     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
5825            CALL DPWRST('XXX','BUG ')
5826  285     CONTINUE
5827        ENDIF
5828      ENDIF
5829C
5830C               *****************************************************
5831C               **  STEP 9--                                       **
5832C               **  FORM THE VERTICAL AND HORIZONTAL AXIS          **
5833C               **  VALUES Y(.) AND X(.) FOR THE PLOT.             **
5834C               **  RESET THE VECTOR D(.) TO ALL ONES.             **
5835C               **  DEFINE THE NUMBER OF PLOT POINTS    (NPLOTP).  **
5836C               **  DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV).  **
5837C               *****************************************************
5838C
5839      ISTEPN='9'
5840      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'CME')
5841     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5842C
5843      ICOL=1
5844      CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
5845     1            INAME,IVARN1,IVARN2,IVARTY,
5846     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
5847     1            MAXCOL,MAXCP1,MAXCP2,MAXCP3,
5848     1            MAXCP4,MAXCP5,MAXCP6,
5849     1            V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
5850     1            Y1,Y1,Y1,NLOCAL,NLOCAL,NLOCAL,ICASE,
5851     1            IBUGG3,ISUBRO,IFOUND,IERROR)
5852      IF(IERROR.EQ.'YES')GOTO9000
5853C
5854      CALL DPCME2(Y1,NLOCAL,ICASPL,XTEMP1,XTEMP2,
5855     1            XTEMP3,XTEMP4,
5856     1            Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR)
5857C
5858C               ****************************************
5859C               **  STEP 10--                         **
5860C               **  COMPUTE SLOPE ESTIMATES OF THE    **
5861C               **  RESULTING TRACE                   **
5862C               ****************************************
5863C
5864      IWRITE='OFF'
5865      ISUBN0='DPPP'
5866      CALL LINFIT(Y,X,NPLOTP,
5867     1ALPHA,BETA,XRESSD,XRESDF,CCXY,SDALPH,SDBETA,CCALBE,
5868     1ISUBRO,IBUGG3,IERROR)
5869C
5870      IH='CMEC'
5871      IH2='C   '
5872      VALUE0=CCXY
5873      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
5874     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
5875     1IANS,IWIDTH,IBUGG3,IERROR)
5876C
5877      IH='CMEA'
5878      IH2='0   '
5879      VALUE0=ALPHA
5880      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
5881     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
5882     1IANS,IWIDTH,IBUGG3,IERROR)
5883C
5884      IH='CMEA'
5885      IH2='1   '
5886      VALUE0=BETA
5887      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
5888     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
5889     1IANS,IWIDTH,IBUGG3,IERROR)
5890C
5891      IH='SDCM'
5892      IH2='EA0 '
5893      VALUE0=SDALPH
5894      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
5895     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
5896     1IANS,IWIDTH,IBUGG3,IERROR)
5897C
5898      IH='SDCM'
5899      IH2='EA1 '
5900      VALUE0=SDBETA
5901      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
5902     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
5903     1IANS,IWIDTH,IBUGG3,IERROR)
5904C
5905      IH='CMER'
5906      IH2='ESSD'
5907      VALUE0=XRESSD
5908      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
5909     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
5910     1IANS,IWIDTH,IBUGG3,IERROR)
5911C
5912      IH='CMER'
5913      IH2='ESDF'
5914      VALUE0=XRESDF
5915      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
5916     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
5917     1IANS,IWIDTH,IBUGG3,IERROR)
5918C
5919C               *****************
5920C               **  STEP 90--  **
5921C               **  EXIT       **
5922C               *****************
5923C
5924 9000 CONTINUE
5925      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'CME')THEN
5926        WRITE(ICOUT,999)
5927        CALL DPWRST('XXX','BUG ')
5928        WRITE(ICOUT,9011)
5929 9011   FORMAT('***** AT THE END       OF DPCME--')
5930        CALL DPWRST('XXX','BUG ')
5931        WRITE(ICOUT,9012)IFOUND,IERROR
5932 9012   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
5933        CALL DPWRST('XXX','BUG ')
5934        WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
5935 9013   FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',3I8,3(2X,A4))
5936        CALL DPWRST('XXX','BUG ')
5937        IF(NPLOTP.GT.0)THEN
5938          DO9020I=1,NPLOTP
5939            WRITE(ICOUT,9021)I,Y(I),X(I),D(I)
5940 9021       FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5)
5941            CALL DPWRST('XXX','BUG ')
5942 9020     CONTINUE
5943        ENDIF
5944      ENDIF
5945C
5946      RETURN
5947      END
5948      SUBROUTINE DPCME2(Y,N,ICASPL,XTEMP1,XTEMP2,
5949     1                  Z,ZITEMS,
5950     1                  Y2,X2,D2,N2,NPLOTV,IBUGG3,ISUBRO,IERROR)
5951C
5952C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
5953C              THAT WILL DEFINE ONE OF THE FOLLOWING 4
5954C              CONDITIONAL EXCEEDANCE PLOTS--
5955C                 CONDITIONAL EXCEEDANCE PLOT Y
5956C                 CONDITIONAL MEAN EXCEEDANCE PLOT Y (= CME PLOT Y)
5957C                 CONDITIONAL MEDIAN EXCEEDANCE PLOT Y
5958C                 CONDITIONAL MIDMEAN EXCEEDANCE PLOT Y
5959C     WRITTEN BY--JAMES J. FILLIBEN
5960C                 STATISTICAL ENGINEERING DIVISION
5961C                 INFORMATION TECHNOLOGY LABORATORY
5962C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
5963C                 GAITHERSBURG, MD 20899-8980
5964C                 PHONE--301-975-2855
5965C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
5966C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
5967C     LANGUAGE--ANSI FORTRAN (1977)
5968C     VERSION NUMBER--93/12
5969C     ORIGINAL VERSION--DECEMBER   1993.
5970C     UPDATED         --FEBRUARY   1994. HANDLE TIES CORRECTLY
5971C
5972C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
5973C
5974      CHARACTER*4 ICASPL
5975      CHARACTER*4 IBUGG3
5976      CHARACTER*4 ISUBRO
5977      CHARACTER*4 IERROR
5978C
5979      CHARACTER*4 IWRITE
5980      CHARACTER*4 ISUBN1
5981      CHARACTER*4 ISUBN2
5982C
5983C---------------------------------------------------------------------
5984C
5985      DIMENSION Y(*)
5986      DIMENSION XTEMP1(*)
5987      DIMENSION XTEMP2(*)
5988      DIMENSION Y2(*)
5989      DIMENSION X2(*)
5990      DIMENSION D2(*)
5991CCCCC FEBRUARY 1994.  ADD FOLLOWING 2 LINES
5992      DIMENSION Z(*)
5993      DIMENSION ZITEMS(*)
5994C
5995C---------------------------------------------------------------------
5996C
5997      INCLUDE 'DPCOP2.INC'
5998C
5999C-----START POINT-----------------------------------------------------
6000C
6001      ISUBN1='DPCM'
6002      ISUBN2='E2  '
6003      IERROR='NO'
6004C
6005      J=0
6006C
6007      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'CME2')THEN
6008        WRITE(ICOUT,999)
6009  999   FORMAT(1X)
6010        CALL DPWRST('XXX','BUG ')
6011        WRITE(ICOUT,71)
6012   71   FORMAT('***** AT THE BEGINNING OF DPCME2--')
6013        CALL DPWRST('XXX','BUG ')
6014        WRITE(ICOUT,72)ICASPL,N,NPLOTV
6015   72   FORMAT('ICASPL,N,NPLOTV = ',A4,2X,I8,I8)
6016        CALL DPWRST('XXX','BUG ')
6017        IF(N.GT.0)THEN
6018          DO85I=1,N
6019            WRITE(ICOUT,86)I,Y(I)
6020   86       FORMAT('I,Y(I) = ',I8,G15.7)
6021            CALL DPWRST('XXX','BUG ')
6022   85     CONTINUE
6023        ENDIF
6024      ENDIF
6025C               ********************************************
6026C               **  STEP 1--                              **
6027C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
6028C               ********************************************
6029C
6030      IF(N.LT.2)THEN
6031        WRITE(ICOUT,999)
6032        CALL DPWRST('XXX','BUG ')
6033        WRITE(ICOUT,111)
6034  111   FORMAT('***** ERROR IN CME PLOT--')
6035        CALL DPWRST('XXX','BUG ')
6036        WRITE(ICOUT,112)
6037  112   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 2.')
6038        CALL DPWRST('XXX','BUG ')
6039        WRITE(ICOUT,114)N
6040  114   FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6)
6041        CALL DPWRST('XXX','BUG ')
6042        WRITE(ICOUT,999)
6043        CALL DPWRST('XXX','BUG ')
6044        IERROR='YES'
6045        GOTO9000
6046      ENDIF
6047C
6048CCCCC FOLLOWING ALGORITHM UPDATED TO HANDLE TIES CORRECTLY.
6049CCCCC FIRST,, DETERMINE IF TIES EXIST AND BRANCH TO DISTINCT SECTION
6050CCCCC IF THEY DO.  FEBRUARY 1994.
6051C
6052C               ****************************************
6053C               **  STEP 1A--                         **
6054C               **  DETERMINE IF TIES EXIST.          **
6055C               ****************************************
6056C
6057      DO99I=1,N
6058      ZITEMS(I)=0.0
6059 99   CONTINUE
6060      NZ=0
6061      DO100I=1,N
6062        IF(I.EQ.1)GOTO130
6063        DO120J=1,NZ
6064          IF(Y(I).EQ.Z(J))THEN
6065            ZITEMS(J)=ZITEMS(J)+1.0
6066            GOTO100
6067          ENDIF
6068 120   CONTINUE
6069 130   CONTINUE
6070       NZ=NZ+1
6071       Z(NZ)=Y(I)
6072       ZITEMS(J)=1.0
6073 100  CONTINUE
6074C
6075      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'CME2')THEN
6076        WRITE(ICOUT,999)
6077        CALL DPWRST('XXX','BUG ')
6078        WRITE(ICOUT,171)
6079  171   FORMAT('***** AFTER CHECKING FOR TIES--')
6080        CALL DPWRST('XXX','BUG ')
6081        WRITE(ICOUT,172)N,NZ
6082  172   FORMAT('N,NZ = ',2I8)
6083        CALL DPWRST('XXX','BUG ')
6084        IF(NZ.GT.0)THEN
6085          DO185I=1,NZ
6086            WRITE(ICOUT,186)I,Z(I)
6087  186       FORMAT('I,Z(I) = ',I8,G15.7)
6088            CALL DPWRST('XXX','BUG ')
6089  185     CONTINUE
6090        ENDIF
6091      ENDIF
6092C
6093      IF(NZ.LT.N)GOTO2000
6094C
6095C               ****************************************
6096C               **  CASE WITH NO TIES                 **
6097C               ****************************************
6098C
6099C               ****************************************
6100C               **  STEP 1--                          **
6101C               **  DETERMINE PLOT COORDINATES        **
6102C               ****************************************
6103C
6104      CALL SORT(Y,N,Y)
6105C
6106      IWRITE='OFF'
6107      J=0
6108      NM1=N-1
6109      DO1100I=1,NM1
6110         Y0=Y(I)
6111         IP1=I+1
6112C
6113         NTEMP1=0
6114         DO1200K=IP1,N
6115            NTEMP1=NTEMP1+1
6116            XTEMP1(NTEMP1)=Y(K)-Y0
6117 1200    CONTINUE
6118C
6119         IF(ICASPL.EQ.'SCAT')THEN
6120            DO1210L=1,NTEMP1
6121               J=J+1
6122               Y2(J)=XTEMP1(L)
6123               X2(J)=Y0
6124               D2(J)=I
6125 1210    CONTINUE
6126C
6127         ELSEIF(ICASPL.EQ.'MEAN')THEN
6128            CALL MEAN(XTEMP1,NTEMP1,IWRITE,XMEAN,IBUGG3,IERROR)
6129            J=J+1
6130            Y2(J)=XMEAN
6131            X2(J)=Y0
6132            D2(J)=1.0
6133C
6134         ELSEIF(ICASPL.EQ.'MEDI')THEN
6135            CALL MEDIAN(XTEMP1,NTEMP1,IWRITE,XTEMP2,MAXNT2,XMED,
6136     1                  IBUGG3,IERROR)
6137            J=J+1
6138            Y2(J)=XMED
6139            X2(J)=Y0
6140            D2(J)=1.0
6141C
6142         ELSEIF(ICASPL.EQ.'MIDM')THEN
6143            IF(NTEMP1.EQ.1)THEN
6144              XMIDM=XTEMP1(1)
6145            ELSE
6146              CALL MIDMEA(XTEMP1,NTEMP1,IWRITE,XTEMP2,MAXNT2,XMIDM,
6147     1                  IBUGG3,IERROR)
6148            ENDIF
6149            J=J+1
6150            Y2(J)=XMIDM
6151            X2(J)=Y0
6152            D2(J)=1.0
6153         ENDIF
6154C
6155 1100 CONTINUE
6156      N2=J
6157      NPLOTV=2
6158      GOTO9000
6159C
6160 2000 CONTINUE
6161C
6162C               ****************************************
6163C               **  CASE WITH TIES                    **
6164C               ****************************************
6165C
6166C               ****************************************
6167C               **  STEP 1--                          **
6168C               **  DETERMINE PLOT COORDINATES        **
6169C               ****************************************
6170C
6171      CALL SORTC(Z,ZITEMS,NZ,Z,ZITEMS)
6172C
6173      IWRITE='OFF'
6174      J=0
6175      NM1=NZ-1
6176      DO2100I=1,NM1
6177         Z0=Z(I)
6178         IP1=I+1
6179C
6180         NTEMP1=0
6181         IF(ICASPL.EQ.'SCAT')THEN
6182           DO2200K=IP1,NZ
6183             NTEMP1=NTEMP1+1
6184             XTEMP1(NTEMP1)=Z(K)-Z0
6185 2200      CONTINUE
6186         ELSEIF(ICASPL.EQ.'MEAN')THEN
6187           ATEMP=0.0
6188           DO2210K=IP1,NZ
6189             NTEMP1=NTEMP1+1
6190             XTEMP1(NTEMP1)=Z(K)-Z0
6191             XTEMP2(NTEMP1)=ZITEMS(K)
6192 2210      CONTINUE
6193         ELSEIF(ICASPL.EQ.'MEDI'.OR.ICASPL.EQ.'MIDM')THEN
6194           DO2220K=IP1,NZ
6195             NITEMS=INT(ZITEMS(K)+0.5)
6196             DO2225KK=1,NITEMS
6197               NTEMP1=NTEMP1+1
6198               XTEMP1(NTEMP1)=Z(K)-Z0
6199 2225        CONTINUE
6200 2220      CONTINUE
6201         ENDIF
6202C
6203         IF(ICASPL.EQ.'SCAT')THEN
6204            DO2310L=1,NTEMP1
6205               J=J+1
6206               Y2(J)=XTEMP1(L)
6207               X2(J)=Z0
6208               D2(J)=I
6209 2310      CONTINUE
6210C
6211         ELSEIF(ICASPL.EQ.'MEAN')THEN
6212            IF(NTEMP1.EQ.1)THEN
6213              XMEAN=XTEMP1(1)
6214            ELSE
6215              CALL WEMEAN(XTEMP1,XTEMP2,NTEMP1,IWRITE,XMEAN,
6216     1                  IBUGG3,IERROR)
6217            ENDIF
6218            J=J+1
6219            Y2(J)=XMEAN
6220            X2(J)=Z0
6221            D2(J)=1.0
6222C
6223         ELSEIF(ICASPL.EQ.'MEDI')THEN
6224            CALL MEDIAN(XTEMP1,NTEMP1,IWRITE,XTEMP2,MAXNT2,XMED,
6225     1                  IBUGG3,IERROR)
6226            J=J+1
6227            Y2(J)=XMED
6228            X2(J)=Z0
6229            D2(J)=1.0
6230C
6231         ELSEIF(ICASPL.EQ.'MIDM')THEN
6232            IF(NTEMP1.EQ.1)THEN
6233              XMIDM=XTEMP1(1)
6234            ELSE
6235              CALL MIDMEA(XTEMP1,NTEMP1,IWRITE,XTEMP2,MAXNT2,XMIDM,
6236     1                  IBUGG3,IERROR)
6237            ENDIF
6238            J=J+1
6239            Y2(J)=XMIDM
6240            X2(J)=Z0
6241            D2(J)=1.0
6242         ENDIF
6243C
6244 2100 CONTINUE
6245      N2=J
6246      NPLOTV=2
6247      GOTO9000
6248C
6249C
6250C               *****************
6251C               **  STEP 90--  **
6252C               **  EXIT       **
6253C               *****************
6254C
6255 9000 CONTINUE
6256      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'CME2')THEN
6257        WRITE(ICOUT,999)
6258        CALL DPWRST('XXX','BUG ')
6259        WRITE(ICOUT,9011)
6260 9011   FORMAT('***** AT THE END       OF DPCME2--')
6261        CALL DPWRST('XXX','BUG ')
6262        WRITE(ICOUT,9012)ICASPL,IERROR,N,N2,NPLOTV
6263 9012   FORMAT('ICASPL,IERROR,N,N2,NPLOTV = ',2(A4,2X),3I8)
6264        CALL DPWRST('XXX','BUG ')
6265        DO9015I=1,N2
6266          WRITE(ICOUT,9016)I,Y2(I),X2(I),D2(I)
6267 9016     FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,3G15.7)
6268          CALL DPWRST('XXX','BUG ')
6269 9015   CONTINUE
6270      ENDIF
6271C
6272      RETURN
6273      END
6274      SUBROUTINE DPCMPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
6275     1                  ICAPSW,ICAPTY,
6276     1                  IFORSW,ISEED,IBOOSS,
6277     1                  ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
6278C
6279C     PURPOSE--GENERATE A CONSENSUS MEAN PLOT--
6280C              THE COMMAND HAS THE FOLLOWING FORMAT:
6281C                  CONSENSUS MEAN PLOT Y X LABID
6282C              OR
6283C                  CONSENSUS MEAN PLOT YMEAN YSD NI LABID
6284C              THIS PLOT DISPLAYS THE RESULTS OF A CONSENSUS MEAN ANALYSIS.
6285C              IT IS USEFUL FOR PROVIDING A COMPARISON OF THE VARIOUS
6286C              METHODS OF COMPUTING CONSENSUS MEANS.
6287C     EXAMPLE--CONSENSUS MEAN PLOT Y X
6288C     WRITTEN BY--ALAN HECKERT
6289C                 STATISTICAL ENGINEERING DIVISION
6290C                 INFORMATION TECHNOLOGY LABORATORY
6291C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
6292C                 GAITHERSBURG, MD 20899-8980
6293C                 PHONE--301-975-2899
6294C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
6295C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
6296C     LANGUAGE--ANSI FORTRAN (1977)
6297C     VERSION NUMBER--2001/8
6298C     ORIGINAL VERSION--AUGUST    2001.
6299C     UPDATED         --OCTOBER   2002. ADD ICAPSW, ICAPTY TO CALL
6300C                                       LIST (PASS TO DPCMP2)
6301C     UPDATED         --MARCH     2006. ADD IFORSW TO CALL LIST
6302C     UPDATED         --MAY       2010. UPDATE LIST OF SUPPORTED
6303C                                       METHODS
6304C     UPDATED         --MAY       2010. USE DPPARS
6305C     UPDATED         --OCTOBER   2011. ADD LAB DATA TO PLOT
6306C     UPDATED         --OCTOBER   2011. OPTION TO SORT METHODS BASED
6307C                                       ON INTERVAL WIDTH
6308C     UPDATED         --JUNE      2012. ADD "IBOOSS" TO CALL LIST (FOR
6309C                                       BOOTSTRAP COMPUTATIONS)
6310C     UPDATED         --OCTOBER   2014. FOR SUMMARY DATA, OPTION TO
6311C                                       INPUT MEAN AND UNCERTAINTY
6312C                                       (I.E., S/SQRT(N) INSTEAD OF
6313C                                       S AND N).  IN SOME CASES, DATA
6314C                                       IS AVAILABLE IN THIS FORM.
6315C     UPDATED         --NOVEMBER  2016. OPTION TO OMIT ONE OR MORE LABS
6316C                                       FROM THE PLOT (BUT NOT THE
6317C                                       ANALYSIS), USEFUL FOR INCREASING
6318C                                       VISUAL RESOLUTION OF BULK OF
6319C                                       LABS
6320C     UPDATED         --APRIL     2017. ADD ICMPM1, ICMPM2, ICMPM3 TO
6321C                                       CALL LIST TO DPCMP2
6322C     UPDATED         --JULY      2019. TWEAK SCRATCH STORAGE
6323C
6324C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
6325C
6326      CHARACTER*4 ICAPSW
6327      CHARACTER*4 ICAPTY
6328      CHARACTER*4 IFORSW
6329      CHARACTER*4 ICASPL
6330      CHARACTER*4 IAND1
6331      CHARACTER*4 IAND2
6332      CHARACTER*4 IBUGG2
6333      CHARACTER*4 IBUGG3
6334      CHARACTER*4 IBUGQ
6335      CHARACTER*4 ISUBRO
6336      CHARACTER*4 IFOUND
6337      CHARACTER*4 IERROR
6338C
6339      CHARACTER*4 IH
6340      CHARACTER*4 IH2
6341      CHARACTER*4 IHWUSE
6342      CHARACTER*4 MESSAG
6343C
6344      DOUBLE PRECISION SEBOK1
6345      DOUBLE PRECISION SEBOK2
6346C
6347      DOUBLE PRECISION YDL
6348      DOUBLE PRECISION DLOWD2
6349      DOUBLE PRECISION DHIGD2
6350      DOUBLE PRECISION DLOWD3
6351      DOUBLE PRECISION DHIGD3
6352      DOUBLE PRECISION DLOWD4
6353      DOUBLE PRECISION DHIGD4
6354      DOUBLE PRECISION DLOWD5
6355      DOUBLE PRECISION DHIGD5
6356      DOUBLE PRECISION DLOWD6
6357      DOUBLE PRECISION DHIGD6
6358C
6359      CHARACTER*40 INAME
6360      PARAMETER (MAXSPN=10)
6361      CHARACTER*4 IVARN1(MAXSPN)
6362      CHARACTER*4 IVARN2(MAXSPN)
6363      CHARACTER*4 IVARTY(MAXSPN)
6364      REAL PVAR(MAXSPN)
6365      INTEGER ILIS(MAXSPN)
6366      INTEGER NRIGHT(MAXSPN)
6367      INTEGER ICOLR(MAXSPN)
6368C
6369      CHARACTER*4 ISUBN0
6370      CHARACTER*4 ISUBN1
6371      CHARACTER*4 ISUBN2
6372      CHARACTER*4 ISTEPN
6373C
6374C---------------------------------------------------------------------
6375C
6376      INCLUDE 'DPCOPA.INC'
6377      INCLUDE 'DPCOZZ.INC'
6378      INCLUDE 'DPCOZD.INC'
6379      INCLUDE 'DPCOZI.INC'
6380C
6381      DIMENSION Y1(MAXOBV)
6382      DIMENSION Y2(MAXOBV)
6383      DIMENSION Y3(MAXOBV)
6384C
6385      DIMENSION Z1(MAXOBV)
6386      DIMENSION Z6(MAXOBV)
6387      DIMENSION Z7(MAXOBV)
6388      DIMENSION Z8(MAXOBV)
6389      DIMENSION Z9(MAXOBV)
6390      DIMENSION PLABID(MAXOBV)
6391      DIMENSION XTEMP1(MAXOBV)
6392      DIMENSION XTEMP2(MAXOBV)
6393      DIMENSION XTEMP3(MAXOBV)
6394      DIMENSION XTEMP4(MAXOBV)
6395      DIMENSION XPLOTZ(MAXOBV)
6396      DIMENSION YPLOTZ(MAXOBV)
6397C
6398      INTEGER IZ(MAXOBV)
6399      INTEGER IZ2(MAXOBV)
6400      INTEGER ITEMP1(MAXOBV)
6401      INTEGER IZFULL(MAXOBV)
6402C
6403      DOUBLE PRECISION Z2(MAXOBV)
6404      DOUBLE PRECISION Z3(MAXOBV)
6405      DOUBLE PRECISION Z4(MAXOBV)
6406      DOUBLE PRECISION DTEMP1(MAXOBV)
6407      DOUBLE PRECISION DTEMP2(MAXOBV)
6408      DOUBLE PRECISION DTEMP3(MAXOBV)
6409C
6410      EQUIVALENCE (GARBAG(IGARB1),Y1(1))
6411      EQUIVALENCE (GARBAG(IGARB2),Y2(1))
6412      EQUIVALENCE (GARBAG(IGARB3),Y3(1))
6413      EQUIVALENCE (GARBAG(IGARB4),Z1(1))
6414      EQUIVALENCE (GARBAG(IGARB5),Z6(1))
6415      EQUIVALENCE (GARBAG(IGARB6),Z7(1))
6416      EQUIVALENCE (GARBAG(IGARB7),Z8(1))
6417      EQUIVALENCE (GARBAG(IGARB8),Z9(1))
6418      EQUIVALENCE (GARBAG(IGARB9),PLABID(1))
6419      EQUIVALENCE (GARBAG(IGAR10),XTEMP1(1))
6420      EQUIVALENCE (GARBAG(JGAR11),XTEMP2(1))
6421      EQUIVALENCE (GARBAG(JGAR12),XTEMP3(1))
6422      EQUIVALENCE (GARBAG(JGAR13),XTEMP4(1))
6423      EQUIVALENCE (GARBAG(JGAR14),XPLOTZ(1))
6424      EQUIVALENCE (GARBAG(JGAR15),YPLOTZ(1))
6425C
6426      EQUIVALENCE (DGARBG(IDGAR1),Z2(1))
6427      EQUIVALENCE (DGARBG(IDGAR2),Z3(1))
6428      EQUIVALENCE (DGARBG(IDGAR3),Z4(1))
6429      EQUIVALENCE (DGARBG(IDGAR4),DTEMP1(1))
6430      EQUIVALENCE (DGARBG(IDGAR5),DTEMP2(1))
6431      EQUIVALENCE (DGARBG(IDGAR6),DTEMP3(1))
6432C
6433      EQUIVALENCE (IGARBG(IIGAR1),IZ(1))
6434      EQUIVALENCE (IGARBG(IIGAR2),IZ2(1))
6435      EQUIVALENCE (IGARBG(IIGAR3),ITEMP1(1))
6436      EQUIVALENCE (IGARBG(IIGAR4),IZFULL(1))
6437C
6438C-----COMMON----------------------------------------------------------
6439C
6440      INCLUDE 'DPCOHO.INC'
6441      INCLUDE 'DPCOHK.INC'
6442      INCLUDE 'DPCODA.INC'
6443      INCLUDE 'DPCOST.INC'
6444C
6445C-----COMMON VARIABLES (GENERAL)--------------------------------------
6446C
6447      INCLUDE 'DPCOP2.INC'
6448C
6449C-----START POINT-----------------------------------------------------
6450C
6451      IERROR='NO'
6452      IFOUND='NO'
6453      ISUBN1='DPCM'
6454      ISUBN2='PL  '
6455      ICASPL='CMPL'
6456C
6457      MAXCP1=MAXCOL+1
6458      MAXCP2=MAXCOL+2
6459      MAXCP3=MAXCOL+3
6460      MAXCP4=MAXCOL+4
6461      MAXCP5=MAXCOL+5
6462      MAXCP6=MAXCOL+6
6463C
6464C               *******************************************
6465C               **  TREAT THE CONSENSUS MEAN PLOT CASE   **
6466C               *******************************************
6467C
6468      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'CMPL')THEN
6469        WRITE(ICOUT,999)
6470  999   FORMAT(1X)
6471        CALL DPWRST('XXX','BUG ')
6472        WRITE(ICOUT,51)
6473   51   FORMAT('***** AT THE BEGINNING OF DPCMPL--')
6474        CALL DPWRST('XXX','BUG ')
6475        WRITE(ICOUT,52)IBUGG2,IBUGG3,IBUGQ,ISUBRO
6476   52   FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',3(A4,2X),A4)
6477        CALL DPWRST('XXX','BUG ')
6478        WRITE(ICOUT,53)ICASPL,IAND1,IAND2,MAXN
6479   53   FORMAT('ICASPL,IAND1,IAND2,MAXN = ',3(A4,2X),I8)
6480        CALL DPWRST('XXX','BUG ')
6481      ENDIF
6482C
6483C               ***************************
6484C               **  STEP 1--             **
6485C               **  EXTRACT THE COMMAND  **
6486C               ***************************
6487C
6488      ISTEPN='11'
6489      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'CMPL')
6490     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6491C
6492      IF(NUMARG.GE.2.AND.ICOM.EQ.'CONS'.AND.IHARG(1).EQ.'MEAN'.AND.
6493     1   IHARG(2).EQ.'PLOT')THEN
6494         ILASTC=2
6495         CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
6496         IFOUND='YES'
6497      ELSEIF(NUMARG.GE.3.AND.ICOM.EQ.'SUMM'.AND.IHARG(1).EQ.'CONS'.AND.
6498     1   IHARG(2).EQ.'MEAN'.AND.IHARG(3).EQ.'PLOT')THEN
6499         ILASTC=3
6500         CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
6501         IFOUND='YES'
6502      ELSE
6503         IFOUND='NO'
6504         GOTO9000
6505      ENDIF
6506C
6507C               ****************************************
6508C               **  STEP 2--                          **
6509C               **  EXTRACT THE VARIABLE LIST         **
6510C               ****************************************
6511C
6512      ISTEPN='2'
6513      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'CMPL')
6514     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6515C
6516      INAME='CONSENSUS MEAN PLOT'
6517      MINNA=2
6518      MAXNA=100
6519      MINN2=2
6520      IFLAGE=1
6521      IFLAGM=0
6522      IFLAGP=0
6523      JMIN=1
6524      JMAX=NUMARG
6525      MINNVA=2
6526      MAXNVA=4
6527C
6528      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
6529     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
6530     1            JMIN,JMAX,
6531     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
6532     1            IVARN1,IVARN2,IVARTY,PVAR,
6533     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
6534     1            MINNVA,MAXNVA,
6535     1            IFLAGM,IFLAGP,
6536     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
6537      IF(IERROR.EQ.'YES')GOTO9000
6538C
6539      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'CMPL')THEN
6540        WRITE(ICOUT,999)
6541        CALL DPWRST('XXX','BUG ')
6542        WRITE(ICOUT,281)
6543  281   FORMAT('***** AFTER CALL DPPARS--')
6544        CALL DPWRST('XXX','BUG ')
6545        WRITE(ICOUT,282)NQ,NUMVAR
6546  282   FORMAT('NQ,NUMVAR = ',2I8)
6547        CALL DPWRST('XXX','BUG ')
6548        IF(NUMVAR.GT.0)THEN
6549          DO285I=1,NUMVAR
6550            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
6551     1                      ICOLR(I)
6552  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
6553     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
6554            CALL DPWRST('XXX','BUG ')
6555  285     CONTINUE
6556        ENDIF
6557      ENDIF
6558C
6559C               ****************************************
6560C               **  STEP 3--                          **
6561C               **  EXTRACT THE DATA                  **
6562C               ****************************************
6563C
6564C     THE FOLLOWING CASES ARE SUPPORTED:
6565C
6566C       1) NUMVAR = 2
6567C
6568C          RAW DATA CASE, THE "X" VARIABLE IS ALSO THE LAB-ID
6569C
6570C       2) NUMVAR = 3
6571C
6572C          SUMMARY DATA CASE, NO LAB-ID VARIABLE GIVEN
6573C
6574C       2) NUMVAR = 4
6575C
6576C          SUMMARY DATA CASE, LAB-ID VARIABLE GIVEN
6577C
6578      ICOL=1
6579      CALL DPPAR5(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
6580     1            INAME,IVARN1,IVARN2,IVARTY,
6581     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
6582     1            MAXCOL,MAXCP1,MAXCP2,MAXCP3,
6583     1            MAXCP4,MAXCP5,MAXCP6,
6584     1            V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
6585     1            Y1,Y2,Y3,PLABID,Z9,Z9,Z9,NLOCAL,
6586     1            IBUGG3,ISUBRO,IFOUND,IERROR)
6587      IF(IERROR.EQ.'YES')GOTO9000
6588C
6589      IF(NUMVAR.EQ.3)THEN
6590        DO310I=1,NS
6591          PLABID(I)=REAL(I)
6592  310   CONTINUE
6593      ENDIF
6594C
6595C               *******************************************************
6596C               **  STEP 8--                                         **
6597C               **  FORM THE VERTICAL AND HORIZONTAL AXIS            **
6598C               **  VALUES Y(.) AND X(.) FOR THE PLOT.               **
6599C               **  DEFINE THE NUMBER OF PLOT POINTS    (NPLOTP).    **
6600C               **  DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV).    **
6601C               *******************************************************
6602C
6603      ISTEPN='5'
6604      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'CMPL')THEN
6605        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6606        WRITE(ICOUT,5001)NLOCAL,ICASPL
6607 5001   FORMAT('NLOCAL,ICASPL=',I5,1X,A4)
6608        CALL DPWRST('XXX','BUG ')
6609      ENDIF
6610C
6611      IH='SIGM'
6612      IH2='AH  '
6613      IHWUSE='P'
6614      MESSAG='NO'
6615      CALL CHECKN(IH,IH2,IHWUSE,
6616     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
6617     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
6618      IF(IERROR.EQ.'YES')THEN
6619        SIGMAH=0.0
6620      ELSE
6621        SIGMAH=VALUE(ILOCP)
6622        IF(SIGMAH.LT.0.0)SIGMAH=0.0
6623      ENDIF
6624      IH='DFH '
6625      IH2='    '
6626      IHWUSE='P'
6627      MESSAG='NO'
6628      CALL CHECKN(IH,IH2,IHWUSE,
6629     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
6630     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
6631      IF(IERROR.EQ.'YES')THEN
6632        IDFH=1
6633      ELSE
6634        IDFH=INT(VALUE(ILOCP)+ 0.5)
6635      ENDIF
6636      IF(IDFH.LE.0)IDFH=1
6637C
6638C     MARCH 2006.  ADD IFORSW TO CALL LIST.
6639C
6640      MAXNXT=MAXOBV
6641      CALL DPCMP2(Y1,Y2,Y3,PLABID,NLOCAL,ICASPL,NUMVAR,MAXNXT,
6642     1            Z1,Z2,Z3,Z4,
6643     1            Z6,Z7,IZ,
6644     1            Z8,Z9,IZFULL,
6645     1            XTEMP1,XTEMP2,XTEMP3,XTEMP4,ITEMP1,
6646     1            DTEMP1,DTEMP2,DTEMP3,
6647     1            XPLOTZ,YPLOTZ,NPLOT,
6648     1            IVARN1(1),IVARN2(1),IVARN1(2),IVARN2(2),
6649     1            IVARN1(3),IVARN2(3),
6650     1            SIGMAH,IDFH,
6651     1            XGRAND,S2WPOO,SW,ASD2,ASD3,
6652     1            SET1,SET2,
6653     1            XMPS,S2BMPS,SEMP,
6654     1            XMMPS,S2BMMP,SEMMP,
6655     1            XMLS,S2BMLS,SEML,
6656     1            XSE,XSES2,ABIAS,ISEDF,
6657     1            ASM,ASB,AKU,
6658CCCCC             MARCH   2006.  ADD FOLLOWING 2 LINES TO CALL LIST
6659     1            XGD,XGDS2,
6660     1            XGCI,XDL,XDLS2,YDL,SEDLK1,SEHDK1,SERUK1,
6661     1            XDLK2,XDLK3,DLOWD2,DHIGD2,DLOWD3,DHIGD3,
6662     1            SEBOK1,SEBOK2,DLOWD4,DHIGD4,
6663     1            DLOWD5,DHIGD5,DLOWD6,DHIGD6,
6664     1            SEGCI,XFW,SEFWK1,SEFWK2,
6665     1            XBCP,XBCPSE,XBCPK1,XBCPK2,XMEDME,SEMEK1,
6666     1            XH15,SEHMK1,SEHMK2,H15LCL,H15UCL,
6667     1            Y,X,D,
6668CCCCC             OCTOBER 2002. ADD ICAPSW, ICAPTY TO CALL LIST
6669     1            ICAPSW,ICAPTY,IFORSW,ISEED,IBOOSS,
6670     1            ICMPSO,ICMPDA,ICMPER,ICMPLL,ICMPNL,
6671     1            ICMPM1,ICMPM2,ICMPM3,
6672     1            NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR)
6673C
6674C               ***************************************
6675C               **  STEP 10--                        **
6676C               **  UPDATE INTERNAL DATAPLOT TABLES  **
6677C               ***************************************
6678C
6679      ISTEPN='10'
6680      IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6681C
6682      IH='XGRA'
6683      IH2='ND  '
6684      VALUE0=XGRAND
6685      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6686     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6687     1IANS,IWIDTH,IBUGG3,IERROR)
6688C
6689      IH='S2PO'
6690      IH2='OOL '
6691      VALUE0=S2WPOO
6692      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6693     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6694     1IANS,IWIDTH,IBUGG3,IERROR)
6695C
6696      IH='YBAR'
6697      IH2='SD1 '
6698      VALUE0=ASD2
6699      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6700     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6701     1IANS,IWIDTH,IBUGG3,IERROR)
6702C
6703      IH='YBAR'
6704      IH2='SD2 '
6705      VALUE0=ASD3
6706      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6707     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6708     1IANS,IWIDTH,IBUGG3,IERROR)
6709C
6710      IH='T1ST'
6711      IH2='DERR'
6712      VALUE0=SET1
6713      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6714     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6715     1IANS,IWIDTH,IBUGG3,IERROR)
6716C
6717      IH='T2ST'
6718      IH2='DERR'
6719      VALUE0=SET2
6720      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6721     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6722     1IANS,IWIDTH,IBUGG3,IERROR)
6723C
6724      IH='SEME'
6725      IH2='AN  '
6726      VALUE0=XSE
6727      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6728     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6729     1IANS,IWIDTH,IBUGG3,IERROR)
6730C
6731      IH='SES2'
6732      IH2='    '
6733      VALUE0=XSES2
6734      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6735     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6736     1IANS,IWIDTH,IBUGG3,IERROR)
6737C
6738      IH='BIAS'
6739      IH2='ALLO'
6740      VALUE0=ABIAS
6741      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6742     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6743     1IANS,IWIDTH,IBUGG3,IERROR)
6744C
6745      IH='SEDF'
6746      IH2='    '
6747      VALUE0=REAL(ISEDF)
6748      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6749     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6750     1IANS,IWIDTH,IBUGG3,IERROR)
6751C
6752      IH='MPME'
6753      IH2='AN  '
6754      VALUE0=XMPS
6755      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6756     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6757     1IANS,IWIDTH,IBUGG3,IERROR)
6758C
6759      IH='MPS2'
6760      IH2='    '
6761      VALUE0=S2BMPS
6762      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6763     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6764     1IANS,IWIDTH,IBUGG3,IERROR)
6765C
6766      IH='SEMP'
6767      IH2='    '
6768      VALUE0=SEMP
6769      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6770     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6771     1IANS,IWIDTH,IBUGG3,IERROR)
6772C
6773      IH='MMPM'
6774      IH2='EAN '
6775      VALUE0=XMMPS
6776      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6777     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6778     1IANS,IWIDTH,IBUGG3,IERROR)
6779C
6780      IH='MMPS'
6781      IH2='2   '
6782      VALUE0=S2BMMP
6783      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6784     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6785     1IANS,IWIDTH,IBUGG3,IERROR)
6786C
6787      IH='SEMM'
6788      IH2='P   '
6789      VALUE0=SEMMP
6790      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6791     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6792     1IANS,IWIDTH,IBUGG3,IERROR)
6793C
6794      IH='MLME'
6795      IH2='AN  '
6796      VALUE0=XMLS
6797      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6798     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6799     1IANS,IWIDTH,IBUGG3,IERROR)
6800C
6801      IH='MLS2'
6802      IH2='    '
6803      VALUE0=S2BMLS
6804      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6805     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6806     1IANS,IWIDTH,IBUGG3,IERROR)
6807C
6808      IH='SEML'
6809      IH2='    '
6810      VALUE0=SEML
6811      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6812     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6813     1IANS,IWIDTH,IBUGG3,IERROR)
6814C
6815      IH='BOBM'
6816      IH2='EAN '
6817      VALUE0=ASM
6818      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6819     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6820     1IANS,IWIDTH,IBUGG3,IERROR)
6821C
6822      IH='BOBS'
6823      IH2='2   '
6824      VALUE0=ASB
6825      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6826     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6827     1IANS,IWIDTH,IBUGG3,IERROR)
6828C
6829      IH='BOBS'
6830      IH2='2W  '
6831      VALUE0=SW
6832      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6833     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6834     1IANS,IWIDTH,IBUGG3,IERROR)
6835C
6836      IH='BOBK'
6837      IH2='U   '
6838      VALUE0=AKU
6839      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6840     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6841     1IANS,IWIDTH,IBUGG3,IERROR)
6842C
6843      IH='GDME'
6844      IH2='AN  '
6845      VALUE0=XGD
6846      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6847     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6848     1IANS,IWIDTH,IBUGG3,IERROR)
6849C
6850      IH='GDS2'
6851      IH2='    '
6852      VALUE0=XGDS2
6853      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6854     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6855     1IANS,IWIDTH,IBUGG3,IERROR)
6856C
6857      IH='GCIM'
6858      IH2='EAN '
6859      VALUE0=XGCI
6860      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6861     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6862     1IANS,IWIDTH,IBUGG3,IERROR)
6863C
6864      IH='GCIS'
6865      IH2='E   '
6866      VALUE0=SEGCI
6867      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6868     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6869     1IANS,IWIDTH,IBUGG3,IERROR)
6870C
6871      IH='DERS'
6872      IH2='MEAN'
6873      VALUE0=XDL
6874      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6875     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6876     1IANS,IWIDTH,IBUGG3,IERROR)
6877C
6878      IH='YDL '
6879      IH2='    '
6880      VALUE0=YDL
6881      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6882     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6883     1IANS,IWIDTH,IBUGG3,IERROR)
6884C
6885      IH='DERS'
6886      IH2='VARI'
6887      VALUE0=XDLS2
6888      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6889     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6890     1IANS,IWIDTH,IBUGG3,IERROR)
6891C
6892      IH='DERS'
6893      IH2='SE  '
6894      VALUE0=SEDLK1
6895      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6896     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6897     1IANS,IWIDTH,IBUGG3,IERROR)
6898C
6899      IH='DERS'
6900      IH2='SEHD'
6901      VALUE0=SEHDK1
6902      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6903     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6904     1IANS,IWIDTH,IBUGG3,IERROR)
6905C
6906      IH='DERS'
6907      IH2='95LL'
6908      VALUE0=DLOWD2
6909      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6910     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6911     1IANS,IWIDTH,IBUGG3,IERROR)
6912C
6913      IH='DERS'
6914      IH2='95UL'
6915      VALUE0=DHIGD2
6916      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6917     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6918     1IANS,IWIDTH,IBUGG3,IERROR)
6919C
6920      IH='DHHD'
6921      IH2='95LL'
6922      VALUE0=DLOWD3
6923      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6924     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6925     1IANS,IWIDTH,IBUGG3,IERROR)
6926C
6927      IH='DHHD'
6928      IH2='95UL'
6929      VALUE0=DHIGD3
6930      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6931     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6932     1IANS,IWIDTH,IBUGG3,IERROR)
6933C
6934      IH='DERS'
6935      IH2='SERU'
6936      VALUE0=SERUK1
6937      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6938     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6939     1IANS,IWIDTH,IBUGG3,IERROR)
6940C
6941      IH='DERS'
6942      IH2='SEBS'
6943      VALUE0=SEBOK1
6944      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6945     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6946     1IANS,IWIDTH,IBUGG3,IERROR)
6947C
6948      IH='DERS'
6949      IH2='BOK2'
6950      VALUE0=XDLK2
6951      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6952     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6953     1IANS,IWIDTH,IBUGG3,IERROR)
6954C
6955      IH='DERS'
6956      IH2='BOK3'
6957      VALUE0=XDLK3
6958      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6959     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6960     1IANS,IWIDTH,IBUGG3,IERROR)
6961C
6962      IH='FAIR'
6963      IH2='MEAN'
6964      VALUE0=XFW
6965      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6966     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6967     1IANS,IWIDTH,IBUGG3,IERROR)
6968C
6969      IH='FAIR'
6970      IH2='SE  '
6971      VALUE0=SEFWK1
6972      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6973     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6974     1IANS,IWIDTH,IBUGG3,IERROR)
6975C
6976      IH='BCPM'
6977      IH2='EAN '
6978      VALUE0=XBCP
6979      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6980     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6981     1IANS,IWIDTH,IBUGG3,IERROR)
6982C
6983      IH='BCPS'
6984      IH2='E   '
6985      VALUE0=XBCPSE
6986      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6987     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6988     1IANS,IWIDTH,IBUGG3,IERROR)
6989C
6990      IH='MEDO'
6991      IH2='FMEA'
6992      VALUE0=XMEDME
6993      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6994     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6995     1IANS,IWIDTH,IBUGG3,IERROR)
6996C
6997      IH='MEDM'
6998      IH2='EASE'
6999      VALUE0=SEMEK1
7000      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
7001     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
7002     1IANS,IWIDTH,IBUGG3,IERROR)
7003C
7004      IH='H15O'
7005      IH2='FMEA'
7006      VALUE0=XH15
7007      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
7008     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
7009     1IANS,IWIDTH,IBUGG3,IERROR)
7010C
7011      IH='H15M'
7012      IH2='EASE'
7013      VALUE0=SEHMK1
7014      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
7015     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
7016     1IANS,IWIDTH,IBUGG3,IERROR)
7017C
7018C               *****************
7019C               **  STEP 9--   **
7020C               **  EXIT       **
7021C               *****************
7022C
7023 9000 CONTINUE
7024      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'CMPL')THEN
7025        WRITE(ICOUT,999)
7026        CALL DPWRST('XXX','BUG ')
7027        WRITE(ICOUT,9011)
7028 9011   FORMAT('***** AT THE END       OF DPCMPL--')
7029        CALL DPWRST('XXX','BUG ')
7030        WRITE(ICOUT,9012)IBUGG2,IBUGG3,IBUGQ,ISUBRO
7031 9012   FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',3(A4,2X),A4)
7032        CALL DPWRST('XXX','BUG ')
7033        WRITE(ICOUT,9013)IFOUND,IERROR,NLOCAL,NPLOTP
7034 9013   FORMAT('IFOUND,IERROR,NLOCAL,NPLOTP = ',A4,2X,A4,2X,2I8)
7035        CALL DPWRST('XXX','BUG ')
7036        WRITE(ICOUT,9014)NPLOTV,NPLOTP,NLOCAL,ICASPL,IAND1,IAND2
7037 9014   FORMAT('NPLOTV,NPLOTP,NLOCAL,ICASPL,IAND1,IAND2 = ',
7038     1         I8,I8,I8,2X,A4,2X,A4,2X,A4)
7039        CALL DPWRST('XXX','BUG ')
7040        IF(NPLOTP.GT.0)THEN
7041          DO9052I=1,NPLOTP
7042            WRITE(ICOUT,9053)I,Y(I),X(I),D(I)
7043 9053       FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5)
7044            CALL DPWRST('XXX','BUG ')
7045 9052     CONTINUE
7046        ENDIF
7047      ENDIF
7048C
7049      RETURN
7050      END
7051      SUBROUTINE DPCMP2(Y1,Y2,Y3,PLABID,NZ,ICASPL,NUMV2,MAXNXT,
7052     1                  DAT,DX,T,W,
7053     1                  AMEAN,ASD,N,
7054     1                  AMEANF,ASDF,NFULL,
7055     1                  XTEMP1,XTEMP2,XTEMP3,XTEMP4,ITEMP1,
7056     1                  DTEMP1,DTEMP2,DTEMP3,
7057     1                  XPLOT,YPLOT,NPLOT,
7058     1                  IHLEFT,IHLEF2,IHRIGH,IHRIG2,IHRI21,IHRI22,
7059     1                  SIGMAH,IDFH,
7060     1                  XGRAND,S2WPOO,SW,ASD2,ASD3,
7061     1                  SET1,SET2,
7062     1                  XMPS,S2BMPS,SEMP,
7063     1                  XMMPS,S2BMMP,SEMMP,
7064     1                  XMLS,S2BMLS,SEML,
7065     1                  XSE,XSES2,ABIAS,ISEDF,
7066     1                  ASM,ASB,AKU,
7067     1                  XGD,XGDS2,
7068     1                  XGCI,XDL,XDLS2,YDL,SEDLK1,SEHDK1,SERUK1,
7069     1                  XDLK2,XDLK3,DLOWD2,DHIGD2,DLOWD3,DHIGD3,
7070     1                  SEBOK1,SEBOK2,DLOWD4,DHIGD4,
7071     1                  DLOWD5,DHIGD5,DLOWD6,DHIGD6,
7072     1                  SEGCI,XFW,SEFWK1,SEFWK2,
7073     1                  XBCP,XBCPSE,XBCPK1,XBCPK2,XMEDME,SEMEK1,
7074     1                  XH15,SEHMK1,SEHMK2,H15LCL,H15UCL,
7075     1                  Y,X,D,
7076CCCCC                   OCTOBER 2002. ADD ICAPSW, ICAPTY TO CALL LIST
7077CCCCC                   MARCH   2006. ADD IFORSW TO CALL LIST
7078     1                  ICAPSW,ICAPTY,IFORSW,ISEED,IBOOSS,
7079     1                  ICMPSO,ICMPDA,ICMPER,ICMPLL,ICMPNL,
7080     1                  ICMPM1,ICMPM2,ICMPM3,
7081     1                  N2,NPLOTV,IBUGG3,ISUBRO,IERROR)
7082C
7083C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS THAT WILL DEFINE A
7084C              CONSENSUS MEAN PLOT
7085C     WRITTEN BY--ALAN HECKERT
7086C                 STATISTICAL ENGINEERING DIVISION
7087C                 INFORMATION TECHNOLOGY LABORATORY
7088C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
7089C                 GAITHERSBURG, MD 20899-8980
7090C                 PHONE--301-975-2899
7091C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
7092C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
7093C     LANGUAGE--ANSI FORTRAN (1977)
7094C     VERSION NUMBER--2001/8
7095C     ORIGINAL VERSION--AUGUST    2001.
7096C     UPDATED  VERSION--APRIL     2002. PRINT OUT ORDER OF METHODS ON
7097C                                       PLOT
7098C     UPDATED  VERSION--OCTOBER   2002. ADD ICAPSW, ICAPTY TO CALL
7099C                                       LIST (PASS TO DPMAN2)
7100C     UPDATED  VERSION--MAY       2010. UPDATE LIST OF METHODS
7101C     UPDATED  VERSION--OCTOBER   2011. LABID VARIABLE (PLABID)
7102C     UPDATED  VERSION--OCTOBER   2011. ADD LABS TO THE PLOT
7103C     UPDATED  VERSION--NOVEMBER  2016. OPTION TO OMIT LABS FROM PLOT
7104C                                       (BUT NOT FROM THE ANALYSIS)
7105C     UPDATED  VERSION--FEBRUARY  2017. FIX BUG FOR SAMPLE SIZE = 0
7106C     UPDATED  VERSION--MAY       2019. OPTION TO PUT DATA ON LEFT
7107C                                       AND CONSENSUS OPTIONS ON
7108C                                       RIGHT
7109C
7110C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
7111C
7112      CHARACTER*4 ICAPSW
7113      CHARACTER*4 ICAPTY
7114      CHARACTER*4 IWRITE
7115      CHARACTER*4 ICASPL
7116      CHARACTER*4 IFORSW
7117      CHARACTER*4 ICMPDA
7118      CHARACTER*4 ICMPSO
7119      CHARACTER*4 ICMPER
7120      CHARACTER*4 ICMPM1
7121      CHARACTER*4 ICMPM2
7122      CHARACTER*4 ICMPM3
7123      CHARACTER*4 IBUGG3
7124      CHARACTER*4 ISUBRO
7125      CHARACTER*4 IERROR
7126C
7127      CHARACTER*4 IHLEFT
7128      CHARACTER*4 IHLEF2
7129      CHARACTER*4 IHRIGH
7130      CHARACTER*4 IHRIG2
7131      CHARACTER*4 IHRI21
7132      CHARACTER*4 IHRI22
7133C
7134      CHARACTER*4 ISUBN0
7135      CHARACTER*4 ISUBN1
7136      CHARACTER*4 ISUBN2
7137C
7138      DOUBLE PRECISION YDL
7139      DOUBLE PRECISION DLOWD2
7140      DOUBLE PRECISION DHIGD2
7141      DOUBLE PRECISION DLOWD3
7142      DOUBLE PRECISION DHIGD3
7143      DOUBLE PRECISION DLOWD4
7144      DOUBLE PRECISION DHIGD4
7145      DOUBLE PRECISION DLOWD5
7146      DOUBLE PRECISION DHIGD5
7147      DOUBLE PRECISION DLOWD6
7148      DOUBLE PRECISION DHIGD6
7149      DOUBLE PRECISION SEBOK1
7150      DOUBLE PRECISION SEBOK2
7151C
7152C---------------------------------------------------------------------
7153C
7154      DIMENSION XMID(20)
7155      DOUBLE PRECISION DXLOW(20)
7156      DOUBLE PRECISION DXHIGH(20)
7157      CHARACTER*30 ILAB(20)
7158C
7159      DIMENSION Y1(*)
7160      DIMENSION Y2(*)
7161      DIMENSION Y3(*)
7162      DIMENSION PLABID(*)
7163      DIMENSION AMEAN(*)
7164      DIMENSION ASD(*)
7165      DIMENSION AMEANF(*)
7166      DIMENSION ASDF(*)
7167      DIMENSION DAT(*)
7168      DIMENSION XTEMP1(*)
7169      DIMENSION XTEMP2(*)
7170      DIMENSION XTEMP3(*)
7171      DIMENSION XTEMP4(*)
7172      DIMENSION XPLOT(*)
7173      DIMENSION YPLOT(*)
7174C
7175      DIMENSION Y(*)
7176      DIMENSION X(*)
7177      DIMENSION D(*)
7178C
7179      DOUBLE PRECISION DX(*)
7180      DOUBLE PRECISION T(*)
7181      DOUBLE PRECISION W(*)
7182      DOUBLE PRECISION DTEMP1(*)
7183      DOUBLE PRECISION DTEMP2(*)
7184      DOUBLE PRECISION DTEMP3(*)
7185C
7186      INTEGER N(*)
7187      INTEGER NFULL(*)
7188      INTEGER ITEMP1(*)
7189      INTEGER ICMPLL(*)
7190C
7191      INTEGER METHIN(20)
7192C
7193      CHARACTER*4 IOP
7194      CHARACTER*15 IA
7195C
7196C---------------------------------------------------------------------
7197C
7198      INCLUDE 'DPCOP2.INC'
7199C
7200C-----START POINT-----------------------------------------------------
7201C
7202      ISUBN1='DPCM'
7203      ISUBN2='P2  '
7204      IERROR='NO'
7205      ISUBN0='CMP2'
7206C
7207      DO10I=1,20
7208        METHIN(I)=1
7209   10 CONTINUE
7210      ICNT3=0
7211C
7212      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'CMP2')THEN
7213        WRITE(ICOUT,999)
7214        CALL DPWRST('XXX','BUG ')
7215        WRITE(ICOUT,71)
7216   71   FORMAT('***** AT THE BEGINNING OF DPCMP2--')
7217        CALL DPWRST('XXX','BUG ')
7218        WRITE(ICOUT,72)ICASPL,NZ,N2,NPLOTV,NUMV2
7219   72   FORMAT('ICASPL,NZ,N2,NPLOTV,NUMV2 = ',A4,2X,4I8)
7220        CALL DPWRST('XXX','BUG ')
7221        IF(NZ.GT.0)THEN
7222          DO81I=1,NZ
7223            WRITE(ICOUT,82)I,Y1(I),Y2(I),Y3(I),PLABID(I)
7224   82       FORMAT('I,Y1(I),Y2(I),Y3(I),PLABID(I) = ',I8,4G15.7)
7225   81     CONTINUE
7226        ENDIF
7227      ENDIF
7228C
7229C               ********************************************
7230C               **  STEP 1--                              **
7231C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
7232C               ********************************************
7233C
7234      IF(NZ.LT.2)THEN
7235        WRITE(ICOUT,999)
7236  999   FORMAT(1X)
7237        CALL DPWRST('XXX','BUG ')
7238        WRITE(ICOUT,31)
7239   31   FORMAT('***** ERROR IN CONSENSUS MEAN PLOT--')
7240        CALL DPWRST('XXX','BUG ')
7241        WRITE(ICOUT,32)
7242   32   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST TWO;')
7243        CALL DPWRST('XXX','BUG ')
7244        WRITE(ICOUT,34)NZ
7245   34   FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I8)
7246        CALL DPWRST('XXX','BUG ')
7247        WRITE(ICOUT,999)
7248        CALL DPWRST('XXX','BUG ')
7249        IERROR='YES'
7250        GOTO9000
7251      ENDIF
7252C
7253C               ****************************************
7254C               **  STEP 1--                          **
7255C               **  CALL DPMAN2 TO OBTAIN CONSENSUS   **
7256C               **  MEAN ESTIMATES.                   **
7257C               ****************************************
7258C
7259      IWRITE='OFF'
7260CCCCC IWRITE='ON'
7261      CALL DPMAN2(Y1,Y2,Y3,PLABID,NZ,NUMV2,MAXNXT,
7262     1            DAT,DX,T,W,
7263     1            AMEAN,ASD,N,
7264     1            AMEANF,ASDF,NFULL,
7265     1            XTEMP1,XTEMP2,XTEMP3,XTEMP4,ITEMP1,
7266     1            DTEMP1,DTEMP2,DTEMP3,
7267     1            XPLOT,YPLOT,NPLOT,
7268     1            IHLEFT,IHLEF2,IHRIGH,IHRIG2,IHRI21,IHRI22,
7269     1            SIGMAH,IDFH,
7270     1            XGRAND,S2WPOO,SW,ASD2,ASD3,
7271     1            SET1,SET2,
7272     1            XMPS,S2BMPS,SEMP,
7273     1            XMMPS,S2BMMP,SEMMP,
7274     1            XMLS,S2BMLS,SEML,
7275     1            XSE,XSES2,ABIAS,ISEDF,
7276     1            ASM,ASB,AKU,
7277     1            XGD,XGDS2,
7278     1            XGCI,XDL,XDLS2,YDL,SEDLK1,SEHDK1,SERUK1,
7279     1            XDLK2,XDLK3,DLOWD2,DHIGD2,DLOWD3,DHIGD3,
7280     1            SEBOK1,SEBOK2,DLOWD4,DHIGD4,
7281     1            DLOWD5,DHIGD5,DLOWD6,DHIGD6,
7282     1            SEGCI,XFW,SEFWK1,SEFWK2,
7283     1            XBCP,XBCPSE,XBCPK1,XBCPK2,XMEDME,SEMEK1,
7284     1            XH15,SEHMK1,SEHMK2,H15LCL,H15UCL,
7285     1            IWRITE,
7286     1            ICAPSW,ICAPTY,IFORSW,ISEED,IBOOSS,
7287     1            ISUBRO,IBUGG3,IERROR)
7288C
7289C               ****************************************
7290C               **  STEP 2--                          **
7291C               **  READ VALUES BACK FROM FILE        **
7292C               ****************************************
7293C
7294      IOP='OPEN'
7295      IFLAG1=1
7296      IFLAG2=1
7297      IFLAG3=1
7298      IFLAG4=1
7299      IFLAG5=0
7300      CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
7301     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
7302     1            IBUGG3,ISUBRO,IERROR)
7303      IF(IERROR.EQ.'YES')GOTO9000
7304C
7305      IROW=0
7306      DO200I=1,20
7307        IF(ICMPER.EQ.'CONF')THEN
7308          READ(IOUNI2,'(3E15.7,15X,A30)',END=209,ERR=205)
7309     1        XMID(I),DXLOW(I),DXHIGH(I),ILAB(I)
7310        ELSE
7311          READ(IOUNI3,'(3E15.7,15X,A30)',END=209,ERR=205)
7312     1         XMID(I),AJUNK2
7313          IF(ICMPER.EQ.'1SE')THEN
7314            DXLOW(I)=XMID(I) - AJUNK2
7315            DXHIGH(I)=XMID(I) + AJUNK2
7316          ELSEIF(ICMPER.EQ.'2SE')THEN
7317            DXLOW(I) =XMID(I) - 2.0*AJUNK2
7318            DXHIGH(I)=XMID(I) + 2.0*AJUNK2
7319          ENDIF
7320        ENDIF
7321        IROW=IROW+1
7322  200 CONTINUE
7323      GOTO209
7324C
7325  205 CONTINUE
7326      WRITE(ICOUT,999)
7327      CALL DPWRST('XXX','BUG ')
7328      WRITE(ICOUT,31)
7329      CALL DPWRST('XXX','BUG ')
7330      WRITE(ICOUT,206)
7331  206 FORMAT('      UNABLE TO READ VALUES FROM DPST2F.DAT FILE.')
7332      CALL DPWRST('XXX','BUG ')
7333      IERROR='YES'
7334      GOTO9000
7335C
7336  209 CONTINUE
7337      NMETH=IROW
7338C
7339C     CHECK TO SEE IF ANY METHODS WILL BE SUPPRESSED ON THE PLOT
7340C
7341      IF(ICMPM1.NE.'NULL')THEN
7342        REWIND(IOUNI3)
7343        DO211II=1,NMETH
7344          READ(IOUNI4,'(60X,A15)')IA(1:15)
7345          IF(ICMPM1.EQ.'MP  '.AND.IA(1:12).EQ.'Mandel-Paule')THEN
7346            METHIN(II)=0
7347          ELSEIF(ICMPM1.EQ.'MMP '.AND.IA(1:15).EQ.'Modified Mandel')THEN
7348            METHIN(II)=0
7349          ELSEIF(ICMPM1.EQ.'VR  '.AND.IA(1:13).EQ.'Vangel-Rukhin')THEN
7350            METHIN(II)=0
7351          ELSEIF(ICMPM1.EQ.'DSL '.AND.IA(1:15).EQ.'DerSionian-Lair')THEN
7352            METHIN(II)=0
7353          ELSEIF(ICMPM1.EQ.'GRAY'.AND.IA(1:13).EQ.'Graybill-Deal')THEN
7354            METHIN(II)=0
7355          ELSEIF(ICMPM1.EQ.'FAIR'.AND.IA(1:11).EQ.'Fairweather')THEN
7356            METHIN(II)=0
7357          ELSEIF(ICMPM1.EQ.'GCI '.AND.IA(1:14).EQ.'Generalized CI')THEN
7358            METHIN(II)=0
7359          ELSEIF(ICMPM1.EQ.'GMEA'.AND.IA(1:10).EQ.'Grand Mean')THEN
7360            METHIN(II)=0
7361          ELSEIF(ICMPM1.EQ.'MOM '.AND.IA(1:13).EQ.'Mean of Means')THEN
7362            METHIN(II)=0
7363          ELSEIF(ICMPM1.EQ.'MEDM'.AND.IA(1:15).EQ.'Median of Means')THEN
7364            METHIN(II)=0
7365          ELSEIF(ICMPM1.EQ.'BOB '.AND.IA(1:3).EQ.'Bob')THEN
7366            METHIN(II)=0
7367          ELSEIF(ICMPM1.EQ.'SE  '.AND.IA(1:7).EQ.'Schiller')THEN
7368            METHIN(II)=0
7369          ELSEIF(ICMPM1.EQ.'BCP '.AND.IA(1:3).EQ.'BCP')THEN
7370            METHIN(II)=0
7371          ELSEIF(ICMPM1.EQ.'HUBE'.AND.IA(1:5).EQ.'Huber')THEN
7372            METHIN(II)=0
7373          ENDIF
7374  211   CONTINUE
7375        REWIND(IOUNI4)
7376      ENDIF
7377C
7378      IF(ICMPM2.NE.'NULL')THEN
7379        REWIND(IOUNI4)
7380        DO213II=1,NMETH
7381          READ(IOUNI4,'(60X,A15)')IA(1:15)
7382          IF(ICMPM2.EQ.'MP  '.AND.IA(1:12).EQ.'Mandel-Paule')THEN
7383            METHIN(II)=0
7384          ELSEIF(ICMPM2.EQ.'MMP '.AND.IA(1:15).EQ.'Modified Mandel')THEN
7385            METHIN(II)=0
7386          ELSEIF(ICMPM2.EQ.'VR  '.AND.IA(1:13).EQ.'Vangel-Rukhin')THEN
7387            METHIN(II)=0
7388          ELSEIF(ICMPM2.EQ.'DSL '.AND.IA(1:15).EQ.'DerSionian-Lair')THEN
7389            METHIN(II)=0
7390          ELSEIF(ICMPM2.EQ.'GRAY'.AND.IA(1:13).EQ.'Graybill-Deal')THEN
7391            METHIN(II)=0
7392          ELSEIF(ICMPM2.EQ.'FAIR'.AND.IA(1:11).EQ.'Fairweather')THEN
7393            METHIN(II)=0
7394          ELSEIF(ICMPM2.EQ.'GCI '.AND.IA(1:14).EQ.'Generalized CI')THEN
7395            METHIN(II)=0
7396          ELSEIF(ICMPM2.EQ.'GMEA'.AND.IA(1:10).EQ.'Grand Mean')THEN
7397            METHIN(II)=0
7398          ELSEIF(ICMPM2.EQ.'MOM '.AND.IA(1:13).EQ.'Mean of Means')THEN
7399            METHIN(II)=0
7400          ELSEIF(ICMPM2.EQ.'MEDM'.AND.IA(1:15).EQ.'Median of Means')THEN
7401            METHIN(II)=0
7402          ELSEIF(ICMPM2.EQ.'BOB '.AND.IA(1:3).EQ.'Bob')THEN
7403            METHIN(II)=0
7404          ELSEIF(ICMPM2.EQ.'SE  '.AND.IA(1:7).EQ.'Schiller')THEN
7405            METHIN(II)=0
7406          ELSEIF(ICMPM2.EQ.'BCP '.AND.IA(1:3).EQ.'BCP')THEN
7407            METHIN(II)=0
7408          ELSEIF(ICMPM2.EQ.'HUBE'.AND.IA(1:5).EQ.'Huber')THEN
7409            METHIN(II)=0
7410          ENDIF
7411  213   CONTINUE
7412        REWIND(IOUNI4)
7413      ENDIF
7414C
7415      IF(ICMPM3.NE.'NULL')THEN
7416        REWIND(IOUNI4)
7417        DO215II=1,NMETH
7418          READ(IOUNI3,'(60X,A15)')IA(1:15)
7419          IF(ICMPM3.EQ.'MP  '.AND.IA(1:12).EQ.'Mandel-Paule')THEN
7420            METHIN(II)=0
7421          ELSEIF(ICMPM3.EQ.'MMP '.AND.IA(1:15).EQ.'Modified Mandel')THEN
7422            METHIN(II)=0
7423          ELSEIF(ICMPM3.EQ.'VR  '.AND.IA(1:13).EQ.'Vangel-Rukhin')THEN
7424            METHIN(II)=0
7425          ELSEIF(ICMPM3.EQ.'DSL '.AND.IA(1:15).EQ.'DerSionian-Lair')THEN
7426            METHIN(II)=0
7427          ELSEIF(ICMPM3.EQ.'GRAY'.AND.IA(1:13).EQ.'Graybill-Deal')THEN
7428            METHIN(II)=0
7429          ELSEIF(ICMPM3.EQ.'FAIR'.AND.IA(1:11).EQ.'Fairweather')THEN
7430            METHIN(II)=0
7431          ELSEIF(ICMPM3.EQ.'GCI '.AND.IA(1:14).EQ.'Generalized CI')THEN
7432            METHIN(II)=0
7433          ELSEIF(ICMPM3.EQ.'GMEA'.AND.IA(1:10).EQ.'Grand Mean')THEN
7434            METHIN(II)=0
7435          ELSEIF(ICMPM3.EQ.'MOM '.AND.IA(1:13).EQ.'Mean of Means')THEN
7436            METHIN(II)=0
7437          ELSEIF(ICMPM3.EQ.'MEDM'.AND.IA(1:15).EQ.'Median of Means')THEN
7438            METHIN(II)=0
7439          ELSEIF(ICMPM3.EQ.'BOB '.AND.IA(1:3).EQ.'Bob')THEN
7440            METHIN(II)=0
7441          ELSEIF(ICMPM3.EQ.'SE  '.AND.IA(1:7).EQ.'Schiller')THEN
7442            METHIN(II)=0
7443          ELSEIF(ICMPM3.EQ.'BCP '.AND.IA(1:3).EQ.'BCP')THEN
7444            METHIN(II)=0
7445          ELSEIF(ICMPM3.EQ.'HUBE'.AND.IA(1:5).EQ.'Huber')THEN
7446            METHIN(II)=0
7447          ENDIF
7448  215   CONTINUE
7449        REWIND(IOUNI4)
7450      ENDIF
7451C
7452C     IF SORT OPTION REQUESTED, SORT BY WIDTH OF INTERVAL
7453C
7454C     AFTER SORTC, Y3 WILL CONTAIN THE INDEX
7455C
7456      IF(ICMPSO.EQ.'ON')THEN
7457        DO220I=1,NMETH
7458          Y1(I)=DXHIGH(I) - DXLOW(I)
7459          Y2(I)=REAL(I)
7460  220   CONTINUE
7461        CALL SORTC(Y1,Y2,NMETH,Y1,Y3)
7462      ENDIF
7463C
7464      IROW=0
7465      DO250I=1,1000
7466        READ(IOUNI1,'(F6.0,F8.0,2X,3E15.7)',END=259,ERR=255)
7467     1      PLABID(I),AMEANF(I),AMEAN(I),AJUNK,ASD(I)
7468        IROW=IROW+1
7469  250 CONTINUE
7470      GOTO259
7471C
7472  255 CONTINUE
7473      WRITE(ICOUT,999)
7474      CALL DPWRST('XXX','BUG ')
7475      WRITE(ICOUT,31)
7476      CALL DPWRST('XXX','BUG ')
7477      WRITE(ICOUT,256)
7478  256 FORMAT('      UNABLE TO READ VALUES FROM DPST1F.DAT FILE.')
7479      CALL DPWRST('XXX','BUG ')
7480      IERROR='YES'
7481      GOTO9000
7482C
7483  259 CONTINUE
7484      NLABID=IROW
7485C
7486      IOP='CLOS'
7487      CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
7488     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
7489     1            IBUGG3,ISUBRO,IERROR)
7490      IF(IERROR.EQ.'YES')GOTO9000
7491C
7492      IOP='OPEN'
7493      IFLAG1=0
7494      IFLAG2=0
7495      IFLAG3=1
7496      CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
7497     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
7498     1            IBUGG3,ISUBRO,IERROR)
7499      IF(IERROR.EQ.'YES')GOTO9000
7500C
7501C               ****************************************
7502C               **  STEP 3--                          **
7503C               **  CREATE THE X, Y, D ARRAYS FOR     **
7504C               **  PLOTTING                          **
7505C               ****************************************
7506C
7507CCCCC IBOB=1
7508CCCCC IF(IROW.LT.8)IBOB=0
7509C
7510      N2=0
7511C
7512      IF(ICMPDA.NE.'LEFT')THEN
7513        DO300I=1,NMETH
7514          IINDX=I
7515          IF(ICMPSO.EQ.'ON')IINDX=INT(Y3(I)+0.5)
7516          IF(METHIN(IINDX).EQ.0)GOTO300
7517          N2=N2+1
7518          X(N2)=REAL(I)
7519          Y(N2)=XMID(IINDX)
7520          D(N2)=1.0
7521  300   CONTINUE
7522      ENDIF
7523C
7524      IF(ICMPDA.EQ.'ON' .OR. ICMPDA.EQ.'LEFT')THEN
7525        IF(ICMPNL.GT.0)THEN
7526          DO303IINDX=1,NLABID
7527            DO304JJ=1,ICMPNL
7528              IF(PLABID(IINDX).EQ.ICMPLL(JJ))GOTO303
7529  304       CONTINUE
7530            N2=N2+1
7531            IF(ICMPDA.EQ.'ON')THEN
7532              ICNT3=NMETH+INT(PLABID(IINDX)+0.5)
7533            ELSEIF(ICMPDA.EQ.'LEFT')THEN
7534              ICNT3=INT(PLABID(IINDX)+0.5)
7535            ENDIF
7536            X(N2)=REAL(ICNT3)
7537            Y(N2)=AMEAN(IINDX)
7538            D(N2)=1.0
7539  303     CONTINUE
7540        ELSE
7541          DO305IINDX=1,NLABID
7542            N2=N2+1
7543            IF(ICMPDA.EQ.'ON')THEN
7544              ICNT3=NMETH+INT(PLABID(IINDX)+0.5)
7545            ELSEIF(ICMPDA.EQ.'LEFT')THEN
7546              ICNT3=INT(PLABID(IINDX)+0.5)
7547            ENDIF
7548            X(N2)=REAL(ICNT3)
7549            Y(N2)=AMEAN(IINDX)
7550            D(N2)=1.0
7551  305     CONTINUE
7552        ENDIF
7553      ENDIF
7554C
7555      IF(ICMPDA.EQ.'LEFT')THEN
7556        DO307I=1,NMETH
7557          IINDX=I
7558          IF(ICMPSO.EQ.'ON')IINDX=INT(Y3(I)+0.5)
7559          IF(METHIN(IINDX).EQ.0)GOTO307
7560          N2=N2+1
7561          X(N2)=REAL(I+NLABID)
7562          Y(N2)=XMID(IINDX)
7563          D(N2)=1.0
7564  307   CONTINUE
7565      ENDIF
7566C
7567      ICNT2=1
7568      IF(ICMPDA.NE.'LEFT')THEN
7569        DO310I=1,NMETH
7570          IINDX=I
7571          IF(ICMPSO.EQ.'ON')IINDX=INT(Y3(I)+0.5)
7572          IF(METHIN(IINDX).EQ.0)GOTO310
7573          N2=N2+1
7574          ICNT2=ICNT2+1
7575          X(N2)=REAL(I)
7576          Y(N2)=DXLOW(IINDX)
7577          D(N2)=REAL(ICNT2)
7578C
7579          N2=N2+1
7580          X(N2)=REAL(I)
7581          Y(N2)=DXHIGH(IINDX)
7582          D(N2)=REAL(ICNT2)
7583  310   CONTINUE
7584      ENDIF
7585C
7586C     2015/01: IF DATA REPORTED AS AN UNCERTAINTY (I.E.,
7587C              N(I) < 0), THEN ASD IS ACTUALLY INTERPRETED
7588C              AS   S(i)/SQRT(N(i)) WHERE N(i) IS THE EFFECTIVE
7589C              DEGREES OF FREEDOM.  SO FOR +/- 2*S(i), DO NOT
7590C              DIVIDE BY SQRT(N(i)) AS THIS IS ALREADY INCORPORATED
7591C              IN ASD.
7592C
7593C              ALSO, IF N(I) = 0, THEN ASD INTERPRETED AS
7594C              S(i)/SQRT(N(i)).
7595C
7596      IF(ICMPDA.EQ.'ON' .OR. ICMPDA.EQ.'LEFT')THEN
7597        AFACT=2.0
7598        IF(ICMPER.EQ.'1SE ')AFACT=1.0
7599        IF(ICMPNL.GT.0)THEN
7600          DO325IINDX=1,NLABID
7601            DO328JJ=1,ICMPNL
7602              IF(PLABID(IINDX).EQ.ICMPLL(JJ))GOTO325
7603  328       CONTINUE
7604            ICNT2=ICNT2+1
7605            IF(ICMPDA.EQ.'ON')THEN
7606              ICNT3=NMETH+INT(PLABID(IINDX)+0.5)
7607            ELSEIF(ICMPDA.EQ.'LEFT')THEN
7608              ICNT3=INT(PLABID(IINDX)+0.5)
7609            ENDIF
7610C
7611            N2=N2+1
7612            X(N2)=REAL(ICNT3)
7613            IF(AMEANF(IINDX).LE.0.0)THEN
7614              ALOWT=AMEAN(IINDX) - AFACT*ASD(IINDX)
7615            ELSE
7616              ALOWT=AMEAN(IINDX) - AFACT*ASD(IINDX)/SQRT(AMEANF(IINDX))
7617            ENDIF
7618            Y(N2)=ALOWT
7619            D(N2)=REAL(ICNT2)
7620C
7621            N2=N2+1
7622            IF(AMEANF(IINDX).LE.0.0)THEN
7623              AHIGT=AMEAN(IINDX) + AFACT*ASD(IINDX)
7624            ELSE
7625              AHIGT=AMEAN(IINDX) + AFACT*ASD(IINDX)/SQRT(AMEANF(IINDX))
7626            ENDIF
7627            IF(ICMPDA.EQ.'ON')THEN
7628              ICNT3=NMETH+INT(PLABID(IINDX)+0.5)
7629            ELSEIF(ICMPDA.EQ.'LEFT')THEN
7630              ICNT3=INT(PLABID(IINDX)+0.5)
7631            ENDIF
7632            X(N2)=REAL(ICNT3)
7633            Y(N2)=AHIGT
7634            D(N2)=REAL(ICNT2)
7635  325     CONTINUE
7636        ELSE
7637          DO315IINDX=1,NLABID
7638            ICNT2=ICNT2+1
7639            IF(ICMPDA.EQ.'ON')THEN
7640              ICNT3=NMETH+INT(PLABID(IINDX)+0.5)
7641            ELSEIF(ICMPDA.EQ.'LEFT')THEN
7642              ICNT3=INT(PLABID(IINDX)+0.5)
7643            ENDIF
7644C
7645            N2=N2+1
7646            X(N2)=REAL(ICNT3)
7647            IF(AMEANF(IINDX).LE.0.0)THEN
7648              ALOWT=AMEAN(IINDX) - AFACT*ASD(IINDX)
7649            ELSE
7650              ALOWT=AMEAN(IINDX) - AFACT*ASD(IINDX)/SQRT(AMEANF(IINDX))
7651            ENDIF
7652            Y(N2)=ALOWT
7653            D(N2)=REAL(ICNT2)
7654C
7655            N2=N2+1
7656            IF(AMEANF(IINDX).LE.0.0)THEN
7657              AHIGT=AMEAN(IINDX) + AFACT*ASD(IINDX)
7658            ELSE
7659              AHIGT=AMEAN(IINDX) + AFACT*ASD(IINDX)/SQRT(AMEANF(IINDX))
7660            ENDIF
7661            X(N2)=REAL(ICNT3)
7662            Y(N2)=AHIGT
7663            D(N2)=REAL(ICNT2)
7664  315     CONTINUE
7665        ENDIF
7666      ENDIF
7667C
7668      IF(ICMPDA.EQ.'LEFT')THEN
7669        DO330I=1,NMETH
7670          IINDX=I
7671          IF(ICMPSO.EQ.'ON')IINDX=INT(Y3(I)+0.5)
7672          IF(METHIN(IINDX).EQ.0)GOTO330
7673          N2=N2+1
7674          ICNT2=ICNT2+1
7675          X(N2)=REAL(I+NLABID)
7676          Y(N2)=DXLOW(IINDX)
7677          D(N2)=REAL(ICNT2)
7678C
7679          N2=N2+1
7680          X(N2)=REAL(I+NLABID)
7681          Y(N2)=DXHIGH(IINDX)
7682          D(N2)=REAL(ICNT2)
7683  330   CONTINUE
7684      ENDIF
7685C
7686      NPLOTV=3
7687      DO8010I=1,NMETH
7688        IINDX=I
7689        IF(ICMPSO.EQ.'ON')IINDX=INT(Y3(I)+0.5)
7690        WRITE(ICOUT,8011)I,ILAB(IINDX)
7691 8011   FORMAT(I2,'. ',A30)
7692        CALL DPWRST('XXX','BUG ')
7693        WRITE(IOUNI3,'(I5)')IINDX
7694 8010 CONTINUE
7695C
7696      IF(IFEEDB.EQ.'ON')THEN
7697        WRITE(ICOUT,999)
7698        CALL DPWRST('XXX','BUG ')
7699        WRITE(ICOUT,8001)
7700 8001   FORMAT('The accompying plot has the consensus value and ',
7701     1         'confidence limits.')
7702        CALL DPWRST('XXX','BUG ')
7703        WRITE(ICOUT,8003)
7704 8003   FORMAT('The ordering of methods on the accompaning consensus ',
7705     1         'mean plot is:')
7706        CALL DPWRST('XXX','BUG ')
7707        WRITE(ICOUT,999)
7708        CALL DPWRST('XXX','BUG ')
7709      ENDIF
7710C
7711C               *****************
7712C               **  STEP 90--  **
7713C               **  EXIT       **
7714C               *****************
7715C
7716 9000 CONTINUE
7717C
7718      IOP='CLOS'
7719      CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
7720     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
7721     1            IBUGG3,ISUBRO,IERROR)
7722C
7723      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'CMP2')THEN
7724        WRITE(ICOUT,999)
7725        CALL DPWRST('XXX','BUG ')
7726        WRITE(ICOUT,9011)
7727 9011   FORMAT('***** AT THE END       OF DPCMP2--')
7728        CALL DPWRST('XXX','BUG ')
7729        WRITE(ICOUT,9012)ICASPL,NZ,N2,NPLOTV,IERROR
7730 9012   FORMAT('ICASPL,NZ,N2,NPLOTV,IERROR = ',A4,3I8,2X,A4)
7731        CALL DPWRST('XXX','BUG ')
7732        DO9035I=1,N2
7733          WRITE(ICOUT,9036)I,Y(I),X(I),D(I)
7734 9036     FORMAT('I,Y(I),X(I),D(I) = ',I8,2E15.7,F9.2)
7735          CALL DPWRST('XXX','BUG ')
7736 9035   CONTINUE
7737      ENDIF
7738C
7739      RETURN
7740      END
7741      SUBROUTINE DPCNF2(Y,N,X,N2,
7742     1                  PID,IVARID,IVARI2,NREPL,
7743     1                  CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
7744     1                  CTL999,CTU999,
7745     1                  ICAPSW,ICAPTY,IFORSW,ICASAN,ICASAT,
7746     1                  ISUBRO,IBUGA3,IERROR)
7747C
7748C     PURPOSE--THIS ROUTINE GENERATES CONFIDENCE LIMITS
7749C              FOR THE MEAN
7750C              FOR THE DATA IN THE INPUT VECTOR Y.
7751C     NOTE--ASSUMPTION--MODEL IS   RESPONSE = CONSTANT + ERROR.
7752C     INPUT  ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR
7753C                                OF EQUALLY-SPACED OBSERVATIONS
7754C                                TO BE SMOOTHED.
7755C                       N      = THE INTEGER NUMBER OF
7756C                                OBSERVATIONS IN THE VECTOR Y.
7757C     WRITTEN BY--JAMES J. FILLIBEN
7758C                 STATISTICAL ENGINEERING DIVISION
7759C                 INFORMATION TECHNOLOGY LABORATORY
7760C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
7761C                 GAITHERSBURG, MD 20899-8980
7762C                 PHONE--301-975-2855
7763C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
7764C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
7765C     LANGUAGE--ANSI FORTRAN (1977)
7766C     VERSION NUMBER--82/7
7767C     ORIGINAL VERSION--JULY      1981.
7768C     UPDATED         --NOVEMBER  1981.
7769C     UPDATED         --FEBRUARY  1982.
7770C     UPDATED         --MAY       1982.
7771C     UPDATED         --FEBRUARY  1994. DPWRST: 'BUG ' => 'WRIT'
7772C     UPDATED         --FEBRUARY  1994. E FORMAT => G FORMAT
7773C     UPDATED         --MARCH     1999. DIFFERENCE OF MEANS CASE
7774C     UPDATED         --FEBRUARY  2003. SUPPORT FOR CUTL..,CUTH..
7775C     UPDATED         --OCTOBER   2003. SUPPORT FOR HTML, LATEX OUTPUT
7776C     UPDATED         --AUGUST    2005. FOR DIFF OF MEANS CASE:
7777C                                       A) HTML PRINTED OUT WRONG
7778C                                          VALUES FOR SECOND VARIABLE
7779C                                       B) ADDED AN ELSE STATEMENT TO
7780C                                          ACTIVATE THE ASCII OUTPUT
7781C     UPDATED         --OCTOBER   2006. CALL LIST TO TPPF
7782C     UPDATED         --MARCH     2010. USE DPDTA2 AND DPDTA4 TO
7783C                                       GENERATE OUTPUT (ADDS RTF
7784C                                       SUPPORT)
7785C     UPDATED         --MARCH     2010. SOME MODIFICATIONS TO THE
7786C                                       OUTPUT (AESTHETIC, NOT
7787C                                       SUBSTANTIVE)
7788C     UPDATED         --APRIL     2013. SUPPORT FOR ONE-SIDED INTERVALS
7789C     UPDATED         --AUGUST    2017. SUPPORT FOR LOGNORMAL
7790C
7791C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
7792C
7793      CHARACTER*4 ISUBRO
7794      CHARACTER*4 IBUGA3
7795      CHARACTER*4 IERROR
7796C
7797      CHARACTER*4 IWRITE
7798      CHARACTER*4 ICASAN
7799      CHARACTER*4 ICASAT
7800      CHARACTER*4 ICASA2
7801      CHARACTER*4 ICAPSW
7802      CHARACTER*4 ICAPTY
7803      CHARACTER*4 IFORSW
7804C
7805      CHARACTER*4 IVARID(*)
7806      CHARACTER*4 IVARI2(*)
7807C
7808      CHARACTER*4 ISUBN1
7809      CHARACTER*4 ISUBN2
7810      CHARACTER*4 ISTEPN
7811C
7812C---------------------------------------------------------------------
7813C
7814      DIMENSION Y(*)
7815      DIMENSION X(*)
7816      DIMENSION PID(*)
7817C
7818      PARAMETER (NUMALP=8)
7819C
7820      DIMENSION CONF(NUMALP)
7821      DIMENSION T(NUMALP)
7822      DIMENSION TSDM(NUMALP)
7823      DIMENSION ALOWER(NUMALP)
7824      DIMENSION AUPPER(NUMALP)
7825C
7826      PARAMETER(NUMCLI=5)
7827      PARAMETER(MAXLIN=2)
7828      PARAMETER (MAXROW=20)
7829      CHARACTER*60 ITITLE
7830      CHARACTER*60 ITITLZ
7831      CHARACTER*60 ITEXT(MAXROW)
7832      REAL         AVALUE(MAXROW)
7833      INTEGER      NCTEXT(MAXROW)
7834      INTEGER      IDIGIT(MAXROW)
7835      INTEGER      NTOT(MAXROW)
7836      LOGICAL IFRST
7837      LOGICAL ILAST
7838C
7839C---------------------------------------------------------------------
7840C
7841      INCLUDE 'DPCOP2.INC'
7842C
7843C-----START POINT-----------------------------------------------------
7844C
7845      ISUBN1='DPCN'
7846      ISUBN2='F2  '
7847C
7848      IERROR='NO'
7849      IWRITE='OFF'
7850      ICASA2='CONF'
7851C
7852      NUMDIG=7
7853      IF(IFORSW.EQ.'1')NUMDIG=1
7854      IF(IFORSW.EQ.'2')NUMDIG=2
7855      IF(IFORSW.EQ.'3')NUMDIG=3
7856      IF(IFORSW.EQ.'4')NUMDIG=4
7857      IF(IFORSW.EQ.'5')NUMDIG=5
7858      IF(IFORSW.EQ.'6')NUMDIG=6
7859      IF(IFORSW.EQ.'7')NUMDIG=7
7860      IF(IFORSW.EQ.'8')NUMDIG=8
7861      IF(IFORSW.EQ.'9')NUMDIG=9
7862      IF(IFORSW.EQ.'0')NUMDIG=0
7863      IF(IFORSW.EQ.'E')NUMDIG=-2
7864      IF(IFORSW.EQ.'-2')NUMDIG=-2
7865      IF(IFORSW.EQ.'-3')NUMDIG=-3
7866      IF(IFORSW.EQ.'-4')NUMDIG=-4
7867      IF(IFORSW.EQ.'-5')NUMDIG=-5
7868      IF(IFORSW.EQ.'-6')NUMDIG=-6
7869      IF(IFORSW.EQ.'-7')NUMDIG=-7
7870      IF(IFORSW.EQ.'-8')NUMDIG=-8
7871      IF(IFORSW.EQ.'-9')NUMDIG=-9
7872C
7873      CONF(1)=50.0
7874      CONF(2)=75.0
7875      CONF(3)=90.0
7876      CONF(4)=95.0
7877      CONF(5)=99.0
7878      CONF(6)=99.9
7879      CONF(7)=99.99
7880      CONF(8)=99.999
7881C
7882      CUTL90=CPUMIN
7883      CUTU90=CPUMIN
7884      CUTL95=CPUMIN
7885      CUTU95=CPUMIN
7886      CUTL99=CPUMIN
7887      CUTU99=CPUMIN
7888C
7889      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CNF2')THEN
7890        WRITE(ICOUT,999)
7891  999   FORMAT(1X)
7892        CALL DPWRST('XXX','WRIT')
7893        WRITE(ICOUT,51)
7894   51   FORMAT('**** AT THE BEGINNING OF DPCNF2--')
7895        CALL DPWRST('XXX','WRIT')
7896        WRITE(ICOUT,52)N,MAXNXT,IBUGA3
7897   52   FORMAT('N,IBUGA3 = ',I8,2X,A4)
7898        CALL DPWRST('XXX','WRIT')
7899        DO56I=1,N
7900          WRITE(ICOUT,57)I,Y(I),X(I)
7901   57     FORMAT('I,Y(I),X(I) = ',I8,3E15.7)
7902          CALL DPWRST('XXX','WRIT')
7903   56   CONTINUE
7904        WRITE(ICOUT,58)ICASAN
7905   58   FORMAT('ICASAN   = ',A4)
7906        CALL DPWRST('XXX','WRIT')
7907      ENDIF
7908C
7909      IF(ICASAN.EQ.'TWOV')GOTO2000
7910      IF(ICASAN.EQ.'LOGN')GOTO3000
7911C
7912C               ********************************************
7913C               **  STEP 1--                              **
7914C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
7915C               ********************************************
7916C
7917      ISTEPN='1'
7918      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CNF2')
7919     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7920C
7921      IF(N.LE.1)THEN
7922        WRITE(ICOUT,999)
7923        CALL DPWRST('XXX','WRIT')
7924        WRITE(ICOUT,101)
7925  101   FORMAT('***** ERROR IN CONFIDENCE LIMITS FOR THE MEAN--')
7926        CALL DPWRST('XXX','WRIT')
7927        WRITE(ICOUT,103)
7928  103   FORMAT('      THE NUMBER OF OBSERVATIONS IN THE RESPONSE ',
7929     1         'VARIABLE IS LESS THAN TWO.')
7930        CALL DPWRST('XXX','WRIT')
7931        WRITE(ICOUT,105)N
7932  105   FORMAT('SAMPLE SIZE = ',I8)
7933        CALL DPWRST('XXX','WRIT')
7934        IERROR='YES'
7935        GOTO9000
7936      ENDIF
7937C
7938      HOLD=Y(1)
7939      DO135I=2,N
7940        IF(Y(I).NE.HOLD)GOTO139
7941  135 CONTINUE
7942      WRITE(ICOUT,999)
7943      CALL DPWRST('XXX','WRIT')
7944      WRITE(ICOUT,101)
7945      CALL DPWRST('XXX','WRIT')
7946      WRITE(ICOUT,131)HOLD
7947  131 FORMAT('      THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7)
7948      CALL DPWRST('XXX','WRIT')
7949      GOTO9000
7950      IERROR='YES'
7951  139 CONTINUE
7952C
7953C               ***************************************************
7954C               **  STEP 3--                                     **
7955C               **  COMPUTE THE MEAN.                            **
7956C               **  COMPUTE THE STANDARD DEVIATION.              **
7957C               **  COMPUTE THE STANDARD DEVIATION OF THE MEAN.  **
7958C               ***************************************************
7959C
7960C
7961      ISTEPN='3'
7962      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CNF2')
7963     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7964C
7965      CALL MEAN(Y,N,IWRITE,YMEAN,IBUGA3,IERROR)
7966      CALL SD(Y,N,IWRITE,YSD,IBUGA3,IERROR)
7967      AN=N
7968      YSDMEA=YSD/SQRT(AN)
7969C
7970C               ***************************************
7971C               **  STEP 4--                         **
7972C               **  COMPUTE CONFIDENCE LIMITS        **
7973C               **  FOR VARIOUS PROBABILITY VALUES.  **
7974C               ***************************************
7975C
7976      ISTEPN='4'
7977      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CNF2')
7978     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7979C
7980      DO1400I=1,8
7981        PCONF=CONF(I)/100.0
7982        CDF=PCONF
7983        IF(ICASAT.EQ.'TWOS')CDF=0.5+PCONF/2.0
7984        NM1=N-1
7985        CALL TPPF(CDF,REAL(NM1),T(I))
7986        TSDM(I)=T(I)*YSDMEA
7987        IF(ICASAT.EQ.'TWOS')THEN
7988          ALOWER(I)=YMEAN-TSDM(I)
7989          AUPPER(I)=YMEAN+TSDM(I)
7990        ELSEIF(ICASAT.EQ.'LOWE')THEN
7991          ALOWER(I)=YMEAN-TSDM(I)
7992          AUPPER(I)=CPUMIN
7993        ELSEIF(ICASAT.EQ.'UPPE')THEN
7994          ALOWER(I)=CPUMIN
7995          AUPPER(I)=YMEAN+TSDM(I)
7996        ENDIF
7997 1400 CONTINUE
7998      CUTL90=ALOWER(3)
7999      CUTU90=AUPPER(3)
8000      CUTL95=ALOWER(4)
8001      CUTU95=AUPPER(4)
8002      CUTL99=ALOWER(5)
8003      CUTU99=AUPPER(5)
8004      CTL999=ALOWER(6)
8005      CTU999=AUPPER(6)
8006C
8007C     ADD A FUDGE FACTOR SO THAT CONFIDENCE LEVEL WILL
8008C     BE PRINTED CORRECTLY TO 3 DECIMAL PLACES.
8009C
8010      CONF(1)=50.0001
8011      CONF(2)=75.0001
8012      CONF(3)=90.0001
8013      CONF(4)=95.0001
8014      CONF(5)=99.0001
8015      CONF(6)=99.9001
8016      CONF(7)=99.9901
8017      CONF(8)=99.9991
8018C
8019C               ****************************
8020C               **  STEP 5--              **
8021C               **  WRITE EVERYTHING OUT  **
8022C               ****************************
8023C
8024      ISTEPN='5'
8025      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CNF2')
8026     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8027C
8028      IF(IPRINT.EQ.'OFF')GOTO9000
8029C
8030      ITITLE='Confidence Limits for the Mean'
8031      NCTITL=30
8032      IF(ICASAT.EQ.'TWOS')THEN
8033        ITITLZ='(Two-Sided)'
8034        NCTITZ=11
8035      ELSEIF(ICASAT.EQ.'LOWE')THEN
8036        ITITLZ='(Lower One-Sided)'
8037        NCTITZ=17
8038      ELSEIF(ICASAT.EQ.'UPPE')THEN
8039        ITITLZ='(Upper One-Sided)'
8040        NCTITZ=17
8041      ENDIF
8042C
8043      ICNT=1
8044      ITEXT(ICNT)=' '
8045      NCTEXT(ICNT)=0
8046      AVALUE(ICNT)=0.0
8047      IDIGIT(ICNT)=-1
8048      ICNT=ICNT+1
8049      ITEXT(ICNT)='Response Variable: '
8050      WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1)(1:4)
8051      WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1)(1:4)
8052      NCTEXT(ICNT)=27
8053      AVALUE(ICNT)=0.0
8054      IDIGIT(ICNT)=-1
8055C
8056      IF(NREPL.GT.0)THEN
8057        NRESP=1
8058        DO4101I=1,NREPL
8059          ICNT=ICNT+1
8060          ITEMP=I+NRESP
8061          ITEXT(ICNT)='Factor Variable  : '
8062          WRITE(ITEXT(ICNT)(17:17),'(I1)')I
8063          WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(ITEMP)(1:4)
8064          WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(ITEMP)(1:4)
8065          NCTEXT(ICNT)=27
8066          AVALUE(ICNT)=PID(ITEMP)
8067          IDIGIT(ICNT)=NUMDIG
8068 4101   CONTINUE
8069      ENDIF
8070C
8071      ICNT=ICNT+1
8072      ITEXT(ICNT)=' '
8073      NCTEXT(ICNT)=1
8074      AVALUE(ICNT)=0.0
8075      IDIGIT(ICNT)=-1
8076C
8077      ICNT=ICNT+1
8078      ITEXT(ICNT)='Summary Statistics:'
8079      NCTEXT(ICNT)=19
8080      AVALUE(ICNT)=0.0
8081      IDIGIT(ICNT)=-1
8082      ICNT=ICNT+1
8083      ITEXT(ICNT)='Number of Observations:'
8084      NCTEXT(ICNT)=23
8085      AVALUE(ICNT)=REAL(N)
8086      IDIGIT(ICNT)=0
8087      ICNT=ICNT+1
8088      ITEXT(ICNT)='Sample Mean:'
8089      NCTEXT(ICNT)=12
8090      AVALUE(ICNT)=YMEAN
8091      IDIGIT(ICNT)=NUMDIG
8092      ICNT=ICNT+1
8093      ITEXT(ICNT)='Sample Standard Deviation:'
8094      NCTEXT(ICNT)=26
8095      AVALUE(ICNT)=YSD
8096      IDIGIT(ICNT)=NUMDIG
8097      ICNT=ICNT+1
8098      ITEXT(ICNT)='Sample Standard Deviation of the Mean:'
8099      NCTEXT(ICNT)=38
8100      AVALUE(ICNT)=YSDMEA
8101      IDIGIT(ICNT)=NUMDIG
8102      ICNT=ICNT+1
8103      ITEXT(ICNT)=' '
8104      NCTEXT(ICNT)=1
8105      AVALUE(ICNT)=0.0
8106      IDIGIT(ICNT)=-1
8107C
8108      NUMROW=ICNT
8109      DO4210I=1,NUMROW
8110        NTOT(I)=15
8111 4210 CONTINUE
8112C
8113      IFRST=.TRUE.
8114      ILAST=.TRUE.
8115C
8116      ISTEPN='5A'
8117      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CNF2')
8118     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8119C
8120      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
8121     1            AVALUE,IDIGIT,
8122     1            NTOT,NUMROW,
8123     1            ICAPSW,ICAPTY,ILAST,IFRST,
8124     1            ISUBRO,IBUGA3,IERROR)
8125C
8126      ISTEPN='5B'
8127      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CNF2')
8128     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8129C
8130      CALL DPDT11(CONF,T,TSDM,ALOWER,AUPPER,
8131     1            ICASA2,ICAPSW,ICAPTY,NUMDIG,
8132     1            ISUBRO,IBUGA3,IERROR)
8133C
8134      GOTO9000
8135C
8136 2000 CONTINUE
8137C
8138C               ********************************************
8139C               **  STEP 6--                              **
8140C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
8141C               ********************************************
8142C
8143      ISTEPN='6'
8144      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CNF2')
8145     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8146C
8147      IF(N.LE.1.OR.N2.LE.1)THEN
8148        WRITE(ICOUT,999)
8149        CALL DPWRST('XXX','WRIT')
8150        WRITE(ICOUT,2111)
8151 2111   FORMAT('***** ERROR IN DIIFERENCE OF MEANS CONFIDENCE LIMITS--')
8152        CALL DPWRST('XXX','WRIT')
8153        WRITE(ICOUT,2112)
8154 2112   FORMAT('      BOTH VARIABLES MUST HAVE AT LEAST TWO ',
8155     1         'OBSERVATIONS.')
8156        CALL DPWRST('XXX','WRIT')
8157        WRITE(ICOUT,2113)IVARID(1),IVARI2(1),N
8158 2113   FORMAT('      SAMPLE SIZE FOR ',A4,A4,' = ',I8)
8159        CALL DPWRST('XXX','WRIT')
8160        WRITE(ICOUT,2114)IVARID(2),IVARI2(2),N2
8161 2114   FORMAT('      SAMPLE SIZE FOR ',A4,A4,' = ',I8)
8162        CALL DPWRST('XXX','WRIT')
8163        IERROR='YES'
8164        GOTO9000
8165      ENDIF
8166C
8167C               ***************************************************
8168C               **  STEP 7--                                     **
8169C               **  COMPUTE THE MEAN.                            **
8170C               **  COMPUTE THE STANDARD DEVIATION.              **
8171C               **  COMPUTE THE STANDARD DEVIATION OF THE MEAN.  **
8172C               ***************************************************
8173C
8174C
8175      ISTEPN='7'
8176      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CNF2')
8177     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8178C
8179      CALL MEAN(Y,N,IWRITE,YMEAN1,IBUGA3,IERROR)
8180      CALL SD(Y,N,IWRITE,YSD1,IBUGA3,IERROR)
8181      AN1=N
8182      YTEMP1=YSD1**2/AN1
8183C
8184      CALL MEAN(X,N2,IWRITE,YMEAN2,IBUGA3,IERROR)
8185      CALL SD(X,N2,IWRITE,YSD2,IBUGA3,IERROR)
8186      AN2=N2
8187      YTEMP2=YSD2**2/AN2
8188C
8189      YDIFF=YMEAN1-YMEAN2
8190      YSTERR=SQRT(YTEMP1 + YTEMP2)
8191      TERM1=(YTEMP1 + YTEMP2)**2
8192      TERM2=YTEMP1*YTEMP1/(AN1-1.0) + YTEMP2*YTEMP2/(AN2-1.0)
8193      V=TERM1/TERM2
8194      IV=INT(V+0.5)
8195C
8196C               ***************************************
8197C               **  STEP 8--                         **
8198C               **  COMPUTE CONFIDENCE LIMITS        **
8199C               **  FOR VARIOUS PROBABILITY VALUES.  **
8200C               ***************************************
8201C
8202      ISTEPN='8'
8203      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CNF2')
8204     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8205C
8206      DO2400I=1,8
8207        PCONF=CONF(I)/100.0
8208        CDF=PCONF
8209        IF(ICASAT.EQ.'TWOS')CDF=0.5+PCONF/2.0
8210        CALL TPPF(CDF,REAL(IV),T(I))
8211        TSDM(I)=T(I)*YSTERR
8212        IF(ICASAT.EQ.'TWOS')THEN
8213          ALOWER(I)=YDIFF-TSDM(I)
8214          AUPPER(I)=YDIFF+TSDM(I)
8215        ELSEIF(ICASAT.EQ.'LOWE')THEN
8216          ALOWER(I)=YDIFF-TSDM(I)
8217          AUPPER(I)=CPUMIN
8218        ELSEIF(ICASAT.EQ.'UPPE')THEN
8219          ALOWER(I)=CPUMIN
8220          AUPPER(I)=YDIFF+TSDM(I)
8221        ENDIF
8222 2400 CONTINUE
8223      CUTL90=ALOWER(3)
8224      CUTU90=AUPPER(3)
8225      CUTL95=ALOWER(4)
8226      CUTU95=AUPPER(4)
8227      CUTL99=ALOWER(5)
8228      CUTU99=AUPPER(5)
8229      CTL999=ALOWER(6)
8230      CTU999=AUPPER(6)
8231C
8232C               ****************************
8233C               **  STEP 9--              **
8234C               **  WRITE EVERYTHING OUT  **
8235C               ****************************
8236C
8237      ISTEPN='9'
8238      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CNF2')
8239     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8240C
8241      IF(IPRINT.EQ.'OFF')GOTO9000
8242C
8243      ITITLE='Confidence Limits for the Difference Between Means'
8244      NCTITL=50
8245      IF(ICASAT.EQ.'TWOS')THEN
8246        ITITLZ='(Two-Sided)'
8247        NCTITZ=11
8248      ELSEIF(ICASAT.EQ.'LOWE')THEN
8249        ITITLZ='(Lower One-Sided)'
8250        NCTITZ=17
8251      ELSEIF(ICASAT.EQ.'UPPE')THEN
8252        ITITLZ='(Upper One-Sided)'
8253        NCTITZ=17
8254      ENDIF
8255C
8256      ICNT=1
8257      ITEXT(ICNT)=' '
8258      NCTEXT(ICNT)=0
8259      AVALUE(ICNT)=0.0
8260      IDIGIT(ICNT)=-1
8261      ICNT=ICNT+1
8262      ITEXT(ICNT)='Response Variable 1: '
8263      WRITE(ITEXT(ICNT)(22:25),'(A4)')IVARID(1)(1:4)
8264      WRITE(ITEXT(ICNT)(26:29),'(A4)')IVARI2(1)(1:4)
8265      NCTEXT(ICNT)=29
8266      AVALUE(ICNT)=0.0
8267      IDIGIT(ICNT)=-1
8268      ICNT=ICNT+1
8269      ITEXT(ICNT)='Response Variable 2: '
8270      WRITE(ITEXT(ICNT)(22:25),'(A4)')IVARID(2)(1:4)
8271      WRITE(ITEXT(ICNT)(26:29),'(A4)')IVARI2(2)(1:4)
8272      NCTEXT(ICNT)=29
8273      AVALUE(ICNT)=0.0
8274      IDIGIT(ICNT)=-1
8275C
8276      IF(NREPL.GT.0)THEN
8277        NRESP=2
8278        DO5101I=1,NREPL
8279          ICNT=ICNT+1
8280          ITEMP=I+NRESP
8281          ITEXT(ICNT)='Factor Variable  : '
8282          WRITE(ITEXT(ICNT)(17:17),'(I1)')I
8283          WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(ITEMP)(1:4)
8284          WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(ITEMP)(1:4)
8285          NCTEXT(ICNT)=27
8286          AVALUE(ICNT)=PID(ITEMP)
8287          IDIGIT(ICNT)=NUMDIG
8288 5101   CONTINUE
8289      ENDIF
8290C
8291      ICNT=ICNT+1
8292      ITEXT(ICNT)=' '
8293      NCTEXT(ICNT)=1
8294      AVALUE(ICNT)=0.0
8295      IDIGIT(ICNT)=-1
8296C
8297      ICNT=ICNT+1
8298      ITEXT(ICNT)=' '
8299      NCTEXT(ICNT)=1
8300      AVALUE(ICNT)=0.0
8301      IDIGIT(ICNT)=-1
8302      ICNT=ICNT+1
8303      ITEXT(ICNT)='Summary Statistics for Variable 1:'
8304      NCTEXT(ICNT)=34
8305      AVALUE(ICNT)=0.0
8306      IDIGIT(ICNT)=-1
8307      ICNT=ICNT+1
8308      ITEXT(ICNT)='Number of Observations:'
8309      NCTEXT(ICNT)=23
8310      AVALUE(ICNT)=REAL(N)
8311      IDIGIT(ICNT)=0
8312      ICNT=ICNT+1
8313      ITEXT(ICNT)='Sample Mean:'
8314      NCTEXT(ICNT)=12
8315      AVALUE(ICNT)=YMEAN1
8316      IDIGIT(ICNT)=NUMDIG
8317      ICNT=ICNT+1
8318      ITEXT(ICNT)='Sample Standard Deviation:'
8319      NCTEXT(ICNT)=26
8320      AVALUE(ICNT)=YSD1
8321      IDIGIT(ICNT)=NUMDIG
8322      ICNT=ICNT+1
8323      ITEXT(ICNT)=' '
8324      NCTEXT(ICNT)=1
8325      AVALUE(ICNT)=0.0
8326      IDIGIT(ICNT)=-1
8327      ICNT=ICNT+1
8328      ITEXT(ICNT)='Summary Statistics for Variable 2:'
8329      NCTEXT(ICNT)=34
8330      AVALUE(ICNT)=0.0
8331      IDIGIT(ICNT)=-1
8332      ICNT=ICNT+1
8333      ITEXT(ICNT)='Number of Observations:'
8334      NCTEXT(ICNT)=23
8335      AVALUE(ICNT)=REAL(N2)
8336      IDIGIT(ICNT)=0
8337      ICNT=ICNT+1
8338      ITEXT(ICNT)='Sample Mean:'
8339      NCTEXT(ICNT)=12
8340      AVALUE(ICNT)=YMEAN2
8341      IDIGIT(ICNT)=NUMDIG
8342      ICNT=ICNT+1
8343      ITEXT(ICNT)='Sample Standard Deviation:'
8344      NCTEXT(ICNT)=26
8345      AVALUE(ICNT)=YSD2
8346      IDIGIT(ICNT)=NUMDIG
8347      ICNT=ICNT+1
8348      ITEXT(ICNT)=' '
8349      NCTEXT(ICNT)=1
8350      AVALUE(ICNT)=0.0
8351      IDIGIT(ICNT)=-1
8352      ICNT=ICNT+1
8353      ITEXT(ICNT)='Difference Between Sample Means:'
8354      NCTEXT(ICNT)=32
8355      AVALUE(ICNT)=YDIFF
8356      IDIGIT(ICNT)=NUMDIG
8357      ICNT=ICNT+1
8358      ITEXT(ICNT)='Standard Error:'
8359      NCTEXT(ICNT)=15
8360      AVALUE(ICNT)=YSTERR
8361      IDIGIT(ICNT)=NUMDIG
8362      ICNT=ICNT+1
8363      ITEXT(ICNT)=' '
8364      NCTEXT(ICNT)=1
8365      AVALUE(ICNT)=0.0
8366      IDIGIT(ICNT)=-1
8367C
8368      NUMROW=ICNT
8369      DO5210I=1,NUMROW
8370        NTOT(I)=15
8371 5210 CONTINUE
8372C
8373      IFRST=.TRUE.
8374      ILAST=.TRUE.
8375C
8376      ISTEPN='9A'
8377      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CNF2')
8378     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8379C
8380      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
8381     1            AVALUE,IDIGIT,
8382     1            NTOT,NUMROW,
8383     1            ICAPSW,ICAPTY,ILAST,IFRST,
8384     1            ISUBRO,IBUGA3,IERROR)
8385C
8386      ISTEPN='9B'
8387      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CNF2')
8388     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8389C
8390      ICASA2='CON2'
8391      CALL DPDT11(CONF,T,TSDM,ALOWER,AUPPER,
8392     1            ICASA2,ICAPSW,ICAPTY,NUMDIG,
8393     1            ISUBRO,IBUGA3,IERROR)
8394C
8395      GOTO9000
8396C
8397C               ********************************************
8398C               **  STEP 10--                             **
8399C               **  LOGNORMAL CONFIDENCE LIMITS CASE      **
8400C               ********************************************
8401C
8402 3000 CONTINUE
8403C
8404      ISTEPN='10'
8405      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CNF2')
8406     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8407C
8408      IF(N.LE.1)THEN
8409        WRITE(ICOUT,999)
8410        CALL DPWRST('XXX','WRIT')
8411        WRITE(ICOUT,3001)
8412 3001   FORMAT('***** ERROR IN LOGNORMAL CONFIDENCE LIMITS FOR ',
8413     1         'THE MEAN--')
8414        CALL DPWRST('XXX','WRIT')
8415        WRITE(ICOUT,103)
8416        CALL DPWRST('XXX','WRIT')
8417        WRITE(ICOUT,105)N
8418        CALL DPWRST('XXX','WRIT')
8419        IERROR='YES'
8420        GOTO9000
8421      ENDIF
8422C
8423      HOLD=Y(1)
8424      DO3005I=2,N
8425        IF(Y(I).NE.HOLD)GOTO3009
8426 3005 CONTINUE
8427      WRITE(ICOUT,999)
8428      CALL DPWRST('XXX','WRIT')
8429      WRITE(ICOUT,3001)
8430      CALL DPWRST('XXX','WRIT')
8431      WRITE(ICOUT,131)HOLD
8432      CALL DPWRST('XXX','WRIT')
8433      GOTO9000
8434      IERROR='YES'
8435 3009 CONTINUE
8436C
8437C               ***************************************************
8438C               **  STEP 11--                                    **
8439C               **  TAKE THE LOGS OF THE DATA.                   **
8440C               **  COMPUTE THE MEAN.                            **
8441C               **  COMPUTE THE STANDARD DEVIATION.              **
8442C               **  COMPUTE THE STANDARD DEVIATION OF THE MEAN.  **
8443C               ***************************************************
8444C
8445C
8446      ISTEPN='3'
8447      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CNF2')
8448     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8449C
8450      CALL MEAN(Y,N,IWRITE,YMEAN,IBUGA3,IERROR)
8451      CALL SD(Y,N,IWRITE,YSD,IBUGA3,IERROR)
8452C
8453      DO3010I=1,N
8454        IF(Y(I).GT.0.0)THEN
8455          Y(I)=LOG(Y(I))
8456        ELSE
8457          WRITE(ICOUT,999)
8458          CALL DPWRST('XXX','WRIT')
8459          WRITE(ICOUT,3001)
8460          CALL DPWRST('XXX','WRIT')
8461          WRITE(ICOUT,3013)I
8462 3013     FORMAT('     ROW ',I8,' HAS A NON-POSITIVE VALUE.')
8463          CALL DPWRST('XXX','WRIT')
8464          WRITE(ICOUT,3015)Y(I)
8465 3015     FORMAT('     THE VALUE IS ',G15.7)
8466          CALL DPWRST('XXX','WRIT')
8467          IERROR='YES'
8468          GOTO9000
8469        ENDIF
8470 3010 CONTINUE
8471C
8472      AN=N
8473      CALL MEAN(Y,N,IWRITE,YMNLOG,IBUGA3,IERROR)
8474      CALL SD(Y,N,IWRITE,YSDLOG,IBUGA3,IERROR)
8475      S2=YSDLOG**2
8476      TERM1=S2/2.0
8477      YSDMEA=SQRT((S2/AN) + (S2**2/(2.0*(AN-1.0))))
8478C
8479C               ***************************************
8480C               **  STEP 4--                         **
8481C               **  COMPUTE CONFIDENCE LIMITS        **
8482C               **  FOR VARIOUS PROBABILITY VALUES.  **
8483C               ***************************************
8484C
8485      ISTEPN='4'
8486      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CNF2')
8487     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8488C
8489      YMEANC=YMNLOG + TERM1
8490      DO3400I=1,8
8491        PCONF=CONF(I)/100.0
8492        CDF=PCONF
8493        IF(ICASAT.EQ.'TWOS')CDF=0.5+PCONF/2.0
8494        NM1=N-1
8495        CALL TPPF(CDF,REAL(NM1),T(I))
8496        TSDM(I)=T(I)*YSDMEA
8497        IF(ICASAT.EQ.'TWOS')THEN
8498          ALOWER(I)=EXP(YMEANC-TSDM(I))
8499          AUPPER(I)=EXP(YMEANC+TSDM(I))
8500        ELSEIF(ICASAT.EQ.'LOWE')THEN
8501          ALOWER(I)=EXP(YMEANC-TSDM(I))
8502          AUPPER(I)=CPUMIN
8503        ELSEIF(ICASAT.EQ.'UPPE')THEN
8504          ALOWER(I)=CPUMIN
8505          AUPPER(I)=EXP(YMEANC+TSDM(I))
8506        ENDIF
8507 3400 CONTINUE
8508      CUTL90=ALOWER(3)
8509      CUTU90=AUPPER(3)
8510      CUTL95=ALOWER(4)
8511      CUTU95=AUPPER(4)
8512      CUTL99=ALOWER(5)
8513      CUTU99=AUPPER(5)
8514      CTL999=ALOWER(6)
8515      CTU999=AUPPER(6)
8516C
8517C     ADD A FUDGE FACTOR SO THAT CONFIDENCE LEVEL WILL
8518C     BE PRINTED CORRECTLY TO 3 DECIMAL PLACES.
8519C
8520      CONF(1)=50.0001
8521      CONF(2)=75.0001
8522      CONF(3)=90.0001
8523      CONF(4)=95.0001
8524      CONF(5)=99.0001
8525      CONF(6)=99.9001
8526      CONF(7)=99.9901
8527      CONF(8)=99.9991
8528C
8529C               ****************************
8530C               **  STEP 5--              **
8531C               **  WRITE EVERYTHING OUT  **
8532C               ****************************
8533C
8534      ISTEPN='5'
8535      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CNF2')
8536     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8537C
8538      IF(IPRINT.EQ.'OFF')GOTO9000
8539C
8540      IF(ICASAT.EQ.'TWOS')THEN
8541        ITITLE='Two-Sided Confidence Limits for the Mean'
8542        NCTITL=40
8543        ITITLZ='(Log-Normal, Modified Cox Method)'
8544        NCTITZ=33
8545      ELSEIF(ICASAT.EQ.'LOWE')THEN
8546        ITITLE='Lower One-Sided Confidence Limits for the Mean'
8547        NCTITL=46
8548        ITITLZ='(Log-Normal, Modified Cox Method)'
8549        NCTITZ=33
8550      ELSEIF(ICASAT.EQ.'UPPE')THEN
8551        ITITLE='Upper One-Sided Confidence Limits for the Mean'
8552        NCTITL=46
8553        ITITLZ='(Log-Normal, Modified Cox Method)'
8554        NCTITZ=33
8555      ENDIF
8556C
8557      ICNT=1
8558      ITEXT(ICNT)=' '
8559      NCTEXT(ICNT)=0
8560      AVALUE(ICNT)=0.0
8561      IDIGIT(ICNT)=-1
8562      ICNT=ICNT+1
8563      ITEXT(ICNT)='Response Variable: '
8564      WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1)(1:4)
8565      WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1)(1:4)
8566      NCTEXT(ICNT)=27
8567      AVALUE(ICNT)=0.0
8568      IDIGIT(ICNT)=-1
8569C
8570      IF(NREPL.GT.0)THEN
8571        NRESP=1
8572        DO3491I=1,NREPL
8573          ICNT=ICNT+1
8574          ITEMP=I+NRESP
8575          ITEXT(ICNT)='Factor Variable  : '
8576          WRITE(ITEXT(ICNT)(17:17),'(I1)')I
8577          WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(ITEMP)(1:4)
8578          WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(ITEMP)(1:4)
8579          NCTEXT(ICNT)=27
8580          AVALUE(ICNT)=PID(ITEMP)
8581          IDIGIT(ICNT)=NUMDIG
8582 3491   CONTINUE
8583      ENDIF
8584C
8585      ICNT=ICNT+1
8586      ITEXT(ICNT)=' '
8587      NCTEXT(ICNT)=1
8588      AVALUE(ICNT)=0.0
8589      IDIGIT(ICNT)=-1
8590C
8591      ICNT=ICNT+1
8592      ITEXT(ICNT)='Summary Statistics:'
8593      NCTEXT(ICNT)=19
8594      AVALUE(ICNT)=0.0
8595      IDIGIT(ICNT)=-1
8596      ICNT=ICNT+1
8597      ITEXT(ICNT)='Number of Observations:'
8598      NCTEXT(ICNT)=23
8599      AVALUE(ICNT)=REAL(N)
8600      IDIGIT(ICNT)=0
8601      ICNT=ICNT+1
8602      ITEXT(ICNT)='Sample Mean (Raw Data):'
8603      NCTEXT(ICNT)=23
8604      AVALUE(ICNT)=YMEAN
8605      IDIGIT(ICNT)=NUMDIG
8606      ICNT=ICNT+1
8607      ITEXT(ICNT)='Sample Standard Deviation (Raw Data):'
8608      NCTEXT(ICNT)=37
8609      AVALUE(ICNT)=YSD
8610      IDIGIT(ICNT)=NUMDIG
8611      ICNT=ICNT+1
8612      ITEXT(ICNT)='Sample Mean (Log Data):'
8613      NCTEXT(ICNT)=23
8614      AVALUE(ICNT)=YMNLOG
8615      IDIGIT(ICNT)=NUMDIG
8616      ICNT=ICNT+1
8617      ITEXT(ICNT)='Correction Term (s*2/2):'
8618      NCTEXT(ICNT)=23
8619      AVALUE(ICNT)=TERM1
8620      IDIGIT(ICNT)=NUMDIG
8621      ICNT=ICNT+1
8622      ITEXT(ICNT)='Sample Standard Deviation (Log Data):'
8623      NCTEXT(ICNT)=37
8624      AVALUE(ICNT)=YSDLOG
8625      IDIGIT(ICNT)=NUMDIG
8626      ICNT=ICNT+1
8627      ITEXT(ICNT)='Sample Standard Deviation of the Mean:'
8628      NCTEXT(ICNT)=38
8629      AVALUE(ICNT)=YSDMEA
8630      IDIGIT(ICNT)=NUMDIG
8631      ICNT=ICNT+1
8632      ITEXT(ICNT)=' '
8633      NCTEXT(ICNT)=1
8634      AVALUE(ICNT)=0.0
8635      IDIGIT(ICNT)=-1
8636C
8637      NUMROW=ICNT
8638      DO3493I=1,NUMROW
8639        NTOT(I)=15
8640 3493 CONTINUE
8641C
8642      IFRST=.TRUE.
8643      ILAST=.TRUE.
8644C
8645      ISTEPN='5A'
8646      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CNF2')
8647     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8648C
8649      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
8650     1            AVALUE,IDIGIT,
8651     1            NTOT,NUMROW,
8652     1            ICAPSW,ICAPTY,ILAST,IFRST,
8653     1            ISUBRO,IBUGA3,IERROR)
8654C
8655      ISTEPN='5B'
8656      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CNF2')
8657     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8658C
8659      CALL DPDT11(CONF,T,TSDM,ALOWER,AUPPER,
8660     1            ICASA2,ICAPSW,ICAPTY,NUMDIG,
8661     1            ISUBRO,IBUGA3,IERROR)
8662C
8663      GOTO9000
8664C
8665C
8666C               *****************
8667C               **  STEP 90--  **
8668C               **  EXIT       **
8669C               *****************
8670C
8671 9000 CONTINUE
8672      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CNF2')THEN
8673        WRITE(ICOUT,999)
8674        CALL DPWRST('XXX','WRIT')
8675        WRITE(ICOUT,9011)
8676 9011   FORMAT('***** AT THE END       OF DPCNF2--')
8677        CALL DPWRST('XXX','WRIT')
8678        WRITE(ICOUT,9012)N,N2,IBUGA3,IERROR
8679 9012   FORMAT('N,N2,IBUGA3,IERROR = ',2I8,2X,A4,2X,A4)
8680        CALL DPWRST('XXX','WRIT')
8681        DO9016I=1,N
8682          WRITE(ICOUT,9017)I,Y(I)
8683 9017     FORMAT('I,Y(I) = ',I8,G15.7)
8684          CALL DPWRST('XXX','WRIT')
8685 9016   CONTINUE
8686        IF(ICASAN.EQ.'TWOV')THEN
8687          DO9026I=1,N2
8688            WRITE(ICOUT,9027)I,X(I)
8689 9027       FORMAT('I,Y2(I) = ',I8,G15.7)
8690            CALL DPWRST('XXX','WRIT')
8691 9026     CONTINUE
8692        ENDIF
8693      ENDIF
8694C
8695      RETURN
8696      END
8697      SUBROUTINE DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
8698     1                  CTL999,CTU999,
8699     1                  IFLAGU,IFRST,ILAST,ICASPL,
8700     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
8701C
8702C     PURPOSE--UTILITY ROUTINE USED BY DPCONF.  THIS ROUTINE
8703C              UPDATES THE PARAMETERS "CUTLOW90", CUTUPP90",
8704C              "CUTLOW95", CUTUPP95", "CUTLOW99", AND "CUTUPP99"
8705C              AFTER COMPUTING THE CONFIDENCE LIMITS FOR THE MEAN
8706C              (OR FOR THE DIFFERENCE OF THE MEANS).
8707C     WRITTEN BY--ALAN HECKERT
8708C                 STATISTICAL ENGINEERING DIVISION
8709C                 INFORMATION TECHNOLOGY LABORAOTRY
8710C                 NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY
8711C                 GAITHERSBURG, MD 20899-8980
8712C                 PHONE--301-975-2899
8713C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
8714C           OF THE NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY.
8715C     LANGUAGE--ANSI FORTRAN (1977)
8716C     VERSION NUMBER--2010/03
8717C     ORIGINAL VERSION--MARCH     2010.
8718C     UPDATED         --AUGUST    2019. ADD CTL999, CTU999
8719C
8720C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
8721C
8722      CHARACTER*4 IFLAGU
8723      CHARACTER*4 ICASPL
8724      CHARACTER*4 IBUGA2
8725      CHARACTER*4 IBUGA3
8726      CHARACTER*4 ISUBRO
8727      CHARACTER*4 IERROR
8728C
8729      LOGICAL IFRST
8730      LOGICAL ILAST
8731C
8732      CHARACTER*4 IH
8733      CHARACTER*4 IH2
8734      CHARACTER*4 ISUBN0
8735      CHARACTER*4 ISUBN1
8736      CHARACTER*4 ISUBN2
8737      CHARACTER*4 ISTEPN
8738      CHARACTER*4 IOP
8739C
8740      SAVE IOUNI1
8741C
8742C---------------------------------------------------------------------
8743C
8744      INCLUDE 'DPCOPA.INC'
8745      INCLUDE 'DPCOHK.INC'
8746      INCLUDE 'DPCOHO.INC'
8747      INCLUDE 'DPCOF2.INC'
8748C
8749C-----COMMON VARIABLES (GENERAL)--------------------------------------
8750C
8751      INCLUDE 'DPCOP2.INC'
8752C
8753C-----START POINT-----------------------------------------------------
8754C
8755      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CNF3')THEN
8756        ISTEPN='1'
8757        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8758        WRITE(ICOUT,999)
8759  999   FORMAT(1X)
8760        CALL DPWRST('XXX','BUG ')
8761        WRITE(ICOUT,51)
8762   51   FORMAT('***** AT THE BEGINNING OF DPCNF3--')
8763        CALL DPWRST('XXX','BUG ')
8764        WRITE(ICOUT,54)CUTL90,CUTL95,CUTL99
8765   54   FORMAT('CUTL90,CUTL95,CUTL99 = ',3G15.7)
8766        CALL DPWRST('XXX','BUG ')
8767        WRITE(ICOUT,56)CUTU90,CUTU95,CUTU99
8768   56   FORMAT('CUTU90,CUTU95,CUTU99 = ',3G15.7)
8769        CALL DPWRST('XXX','BUG ')
8770        WRITE(ICOUT,58)ICASPL
8771   58   FORMAT('ICASPL = ',A4)
8772        CALL DPWRST('XXX','BUG ')
8773      ENDIF
8774C
8775      IF(IFLAGU.EQ.'FILE')THEN
8776        IF(IFRST)THEN
8777          IOP='OPEN'
8778          IFLAG1=1
8779          IFLAG2=0
8780          IFLAG3=0
8781          IFLAG4=0
8782          IFLAG5=0
8783          CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
8784     1                IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
8785     1                IBUGA3,ISUBRO,IERROR)
8786          IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CNF3')THEN
8787            ISTEPN='2A'
8788            CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8789            WRITE(ICOUT,999)
8790            CALL DPWRST('XXX','BUG ')
8791            WRITE(ICOUT,201)IOUNI1
8792  201       FORMAT('AFTER CALL DPOPFI, IOUNI1 = ',I5)
8793            CALL DPWRST('XXX','BUG ')
8794          ENDIF
8795C
8796          IF(IERROR.EQ.'YES')GOTO9000
8797C
8798          WRITE(IOUNI1,295)
8799  295     FORMAT(7X,'CUTLOW90',7X,'CUTUPP90',7X,'CUTLOW95',
8800     1           7X,'CUTUPP95',7X,'CUTLOW99',7X,'CUTUPP99')
8801        ENDIF
8802        WRITE(IOUNI1,299)CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
8803     1                   CTL999,CTU999
8804  299   FORMAT(9E15.7)
8805      ELSEIF(IFLAGU.EQ.'ON')THEN
8806C
8807        IF(CUTL90.NE.CPUMIN)THEN
8808          IH='CUTL'
8809          IH2='OW90'
8810          VALUE0=CUTL90
8811          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
8812     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
8813     1                IANS,IWIDTH,IBUGA3,IERROR)
8814        ENDIF
8815C
8816        IF(CUTU90.NE.CPUMIN)THEN
8817          IH='CUTU'
8818          IH2='PP90'
8819          VALUE0=CUTU90
8820          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
8821     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
8822     1                IANS,IWIDTH,IBUGA3,IERROR)
8823        ENDIF
8824C
8825        IF(CUTL95.NE.CPUMIN)THEN
8826          IH='CUTL'
8827          IH2='OW95'
8828          VALUE0=CUTL95
8829          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
8830     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
8831     1                IANS,IWIDTH,IBUGA3,IERROR)
8832        ENDIF
8833C
8834        IF(CUTU95.NE.CPUMIN)THEN
8835          IH='CUTU'
8836          IH2='PP95'
8837          VALUE0=CUTU95
8838          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
8839     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
8840     1                IANS,IWIDTH,IBUGA3,IERROR)
8841        ENDIF
8842C
8843        IF(CUTL99.NE.CPUMIN)THEN
8844          IH='CUTL'
8845          IH2='OW99'
8846          VALUE0=CUTL99
8847          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
8848     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
8849     1                IANS,IWIDTH,IBUGA3,IERROR)
8850        ENDIF
8851C
8852        IF(CUTU99.NE.CPUMIN)THEN
8853          IH='CUTU'
8854          IH2='PP99'
8855          VALUE0=CUTU99
8856          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
8857     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
8858     1                IANS,IWIDTH,IBUGA3,IERROR)
8859        ENDIF
8860C
8861        IF(CTL999.NE.CPUMIN)THEN
8862          IH='CTLO'
8863          IH2='W999'
8864          VALUE0=CTL999
8865          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
8866     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
8867     1                IANS,IWIDTH,IBUGA3,IERROR)
8868        ENDIF
8869C
8870        IF(CTU999.NE.CPUMIN)THEN
8871          IH='CTUP'
8872          IH2='P999'
8873          VALUE0=CTU999
8874          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
8875     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
8876     1                IANS,IWIDTH,IBUGA3,IERROR)
8877        ENDIF
8878C
8879      ENDIF
8880C
8881      IF(IFLAGU.EQ.'FILE')THEN
8882        IF(ILAST)THEN
8883          IOP='CLOS'
8884          IFLAG1=1
8885          IFLAG2=0
8886          IFLAG3=0
8887          IFLAG4=0
8888          IFLAG5=0
8889          CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
8890     1                IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
8891     1                IBUGA3,ISUBRO,IERROR)
8892C
8893          IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CNF3')THEN
8894            ISTEPN='3A'
8895            CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8896            WRITE(ICOUT,999)
8897            CALL DPWRST('XXX','BUG ')
8898            WRITE(ICOUT,301)IOUNI1
8899  301       FORMAT('AFTER CALL DPCLFI, IOUNI1 = ',I8)
8900            CALL DPWRST('XXX','BUG ')
8901          ENDIF
8902C
8903          IF(IERROR.EQ.'YES')GOTO9000
8904        ENDIF
8905      ENDIF
8906C
8907C               *****************
8908C               **  STEP 90--  **
8909C               **  EXIT       **
8910C               *****************
8911C
8912 9000 CONTINUE
8913C
8914      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CNF3')THEN
8915        WRITE(ICOUT,999)
8916        CALL DPWRST('XXX','BUG ')
8917        WRITE(ICOUT,9011)
8918 9011   FORMAT('***** AT THE END OF DPCNF3--')
8919        CALL DPWRST('XXX','BUG ')
8920      ENDIF
8921C
8922      RETURN
8923      END
8924      SUBROUTINE DPCOCH(MAXNXT,ICAPSW,IFORSW,
8925     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
8926C
8927C     PURPOSE--CARRY OUT COCHRAN TEST ANALYSIS OF A RANDOMIZED COMPLETE
8928C              BLOCK DESIGN WHERE THE OUTCOME CAN BE EITHER "SUCCESS" OR
8929C              "FAILURE" (OR ANY TWO MUTUALLY EXCLUSIVE OUTCOMES).
8930C              THESE ARE CODED AS ZERO AND ONE.  IN DATAPLOT, THE COLUMNS
8931C              REPRESENT TREATMENTS AND THE ROWS REPRESENT SUBJECTS.
8932C     EXAMPLE--COCHRAN TEST Y X1 X2
8933C     REFERENCE--W. J. CONOVER, 1999, "PRACTICAL NONPARAMETRIC
8934C                STATISTICS", THIRD EDITION, WILEY, PP. 251-256.
8935C     WRITTEN BY--ALAN HECKERT
8936C                 STATISTICAL ENGINEERING DIVISION
8937C                 INFORMATION TECHNOLOGY LABORATORY
8938C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
8939C                 GAITHERSBURG, MD 20899-8980
8940C                 PHONE--301-975-2899
8941C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
8942C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
8943C     LANGUAGE--ANSI FORTRAN (1977)
8944C     VERSION NUMBER--2004/10
8945C     ORIGINAL VERSION--OCTOBER   2004.
8946C     UPDATED         --DECEMBER  2005. RECODE TO USE
8947C                                         COCHRAN TEST Y X1 X2
8948C                                       INSTEAD OF
8949C                                         COCHRAN TEST Y X1 ... XK
8950C                                       IN ORDER TO BE CONSISTENT
8951C                                       WITH OTHER DATAPLOT COMMANDS.
8952C     UPDATED         --APRIL     2011. USE DPPARS AND DPPAR3
8953C     UPDATED         --JULY      2019. TWEAK USE OF SCRATCH SPACE
8954C
8955C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
8956C
8957      CHARACTER*4 ICAPSW
8958      CHARACTER*4 IFORSW
8959      CHARACTER*4 IBUGA2
8960      CHARACTER*4 IBUGA3
8961      CHARACTER*4 IBUGQ
8962      CHARACTER*4 ISUBRO
8963      CHARACTER*4 IFOUND
8964      CHARACTER*4 IERROR
8965C
8966      CHARACTER*4 ISUBN1
8967      CHARACTER*4 ISUBN2
8968      CHARACTER*4 ISTEPN
8969C
8970      LOGICAL IFRST
8971      LOGICAL ILAST
8972      CHARACTER*4 IFLAGU
8973      CHARACTER*4 ICASE
8974      CHARACTER*40 INAME
8975      PARAMETER (MAXSPN=30)
8976      CHARACTER*4 IVARN1(MAXSPN)
8977      CHARACTER*4 IVARN2(MAXSPN)
8978      CHARACTER*4 IVARTY(MAXSPN)
8979      REAL PVAR(MAXSPN)
8980      INTEGER ILIS(MAXSPN)
8981      INTEGER NRIGHT(MAXSPN)
8982      INTEGER ICOLR(MAXSPN)
8983C
8984C-----COMMON----------------------------------------------------------
8985C
8986      INCLUDE 'DPCOPA.INC'
8987      INCLUDE 'DPCOZZ.INC'
8988C
8989      PARAMETER(MAXCOC=20)
8990C
8991      DIMENSION Z(MAXOBV,MAXCOC)
8992      DIMENSION XTEMP1(MAXOBV)
8993      DIMENSION XTEMP2(MAXOBV)
8994      DIMENSION XTEMP3(MAXOBV)
8995      DIMENSION XTEMP4(MAXOBV)
8996      DIMENSION XTEMP5(MAXOBV)
8997C
8998      EQUIVALENCE(GARBAG(IGARB1),XTEMP1(1))
8999      EQUIVALENCE(GARBAG(IGARB2),XTEMP2(1))
9000      EQUIVALENCE(GARBAG(IGARB3),XTEMP3(1))
9001      EQUIVALENCE(GARBAG(IGARB4),XTEMP4(1))
9002      EQUIVALENCE(GARBAG(IGARB5),XTEMP5(1))
9003      EQUIVALENCE(GARBAG(IGARB6),Z(1,1))
9004C
9005      INCLUDE 'DPCOHK.INC'
9006      INCLUDE 'DPCOSU.INC'
9007      INCLUDE 'DPCODA.INC'
9008C
9009C-----COMMON VARIABLES (GENERAL)--------------------------------------
9010C
9011      INCLUDE 'DPCOP2.INC'
9012C
9013C-----START POINT-----------------------------------------------------
9014C
9015      ISUBN1='DPCO'
9016      ISUBN2='CH  '
9017      IFOUND='YES'
9018      IERROR='NO'
9019C
9020      MAXCP1=MAXCOL+1
9021      MAXCP2=MAXCOL+2
9022      MAXCP3=MAXCOL+3
9023      MAXCP4=MAXCOL+4
9024      MAXCP5=MAXCOL+5
9025      MAXCP6=MAXCOL+6
9026C
9027C               ******************************************
9028C               **  TREAT THE COCHRAN TEST CASE         **
9029C               ******************************************
9030C
9031      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'COCH')THEN
9032        WRITE(ICOUT,999)
9033  999   FORMAT(1X)
9034        CALL DPWRST('XXX','BUG ')
9035        WRITE(ICOUT,51)
9036   51   FORMAT('***** AT THE BEGINNING OF DPCOCH--')
9037        CALL DPWRST('XXX','BUG ')
9038        WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ,ISUBRO,MAXNXT
9039   52   FORMAT('IBUGA2,IBUGA3,IBUBQ,ISUBRO,MAXNXT = ',4(A4,2X),I8)
9040        CALL DPWRST('XXX','BUG ')
9041        WRITE(ICOUT,53)ICAPSW,ICAPTY,IFORSW
9042   53   FORMAT('ICAPSW,ICAPTY,IFORSW = ',2(A4,2X),A4)
9043        CALL DPWRST('XXX','BUG ')
9044      ENDIF
9045C
9046C               *********************************
9047C               **  STEP 1--                   **
9048C               **  EXTRACT THE VARIABLE LIST  **
9049C               *********************************
9050C
9051      ISTEPN='1'
9052      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'COCH')
9053     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9054C
9055      INAME='COCHRAN TEST'
9056      MINNA=3
9057      MAXNA=100
9058      MINNVA=3
9059      MAXNVA=3
9060      IFLAGE=1
9061      IFLAGM=0
9062      MINN2=2
9063      IFLAGP=0
9064      JMIN=1
9065      JMAX=NUMARG
9066C
9067      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
9068     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
9069     1            JMIN,JMAX,
9070     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
9071     1            IVARN1,IVARN2,IVARTY,PVAR,
9072     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
9073     1            MINNVA,MAXNVA,
9074     1            IFLAGM,IFLAGP,
9075     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
9076      IF(IERROR.EQ.'YES')GOTO9000
9077C
9078      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'COCH')THEN
9079        WRITE(ICOUT,999)
9080        CALL DPWRST('XXX','BUG ')
9081        WRITE(ICOUT,181)
9082  181   FORMAT('***** AFTER CALL DPPARS--')
9083        CALL DPWRST('XXX','BUG ')
9084        WRITE(ICOUT,182)NQ,NUMVAR,IMULT
9085  182   FORMAT('NQ,NUMVAR,IMULT = ',2I8,2X,A4)
9086        CALL DPWRST('XXX','BUG ')
9087        IF(NUMVAR.GT.0)THEN
9088          DO185I=1,NUMVAR
9089            WRITE(ICOUT,187)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
9090     1                      ICOLR(I)
9091  187       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
9092     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
9093            CALL DPWRST('XXX','BUG ')
9094  185     CONTINUE
9095        ENDIF
9096      ENDIF
9097C
9098C               **********************************
9099C               **  STEP 52--                   **
9100C               **  CARRY OUT THE DURBIN TEST   **
9101C               **********************************
9102C
9103      ISTEPN='52'
9104      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'DURB')
9105     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9106C
9107      ICOL=1
9108      NUMVA2=3
9109      CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
9110     1            INAME,IVARN1,IVARN2,IVARTY,
9111     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
9112     1            MAXCOL,MAXCP1,MAXCP2,MAXCP3,
9113     1            MAXCP4,MAXCP5,MAXCP6,
9114     1            V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
9115     1            Y,X,XTEMP2,NS1,NS1,NS1,ICASE,
9116     1            IBUGA3,ISUBRO,IFOUND,IERROR)
9117      IF(IERROR.EQ.'YES')GOTO9000
9118C
9119      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'COCH')THEN
9120        WRITE(ICOUT,999)
9121        CALL DPWRST('XXX','BUG ')
9122        WRITE(ICOUT,5211)
9123 5211   FORMAT('***** FROM DPDURB, AS WE ARE ABOUT TO CALL DPCOC2--')
9124        CALL DPWRST('XXX','BUG ')
9125        WRITE(ICOUT,5212)NS1
9126 5212   FORMAT('NS1 = ',I8)
9127        CALL DPWRST('XXX','BUG ')
9128        DO5215I=1,NS1
9129          WRITE(ICOUT,5216)I,Y(I),X(I),XTEMP2(I)
9130 5216     FORMAT('I,Y(I),X(I),XTEMP2(I) = ',I8,3G15.7)
9131          CALL DPWRST('XXX','BUG ')
9132 5215   CONTINUE
9133      ENDIF
9134C
9135      CALL DPCOC2(Y,X,XTEMP2,NS1,IVARN1,IVARN2,
9136     1            Z,XTEMP1,XTEMP3,XTEMP4,XTEMP5,
9137     1            MAXNXT,MAXCOC,
9138     1            STATVA,STATCD,PVAL,
9139     1            CUT0,CUT50,CUT75,CUT90,CUT95,CUT975,
9140     1            CUT99,CUT999,
9141     1            ICAPSW,ICAPTY,IFORSW,
9142     1            IBUGA3,ISUBRO,IERROR)
9143C
9144      IFLAGU='ON'
9145      IFRST=.TRUE.
9146      ILAST=.TRUE.
9147      CALL DPFRT5(STATVA,STATCD,PVAL,
9148     1            CUT0,CUT50,CUT75,CUT90,CUT95,
9149     1            CUT975,CUT99,CUT999,
9150     1            IFLAGU,IFRST,ILAST,
9151     1            IBUGA2,IBUGA3,ISUBRO,IERROR)
9152C
9153C
9154C               *****************
9155C               **  STEP 90--  **
9156C               **  EXIT       **
9157C               *****************
9158C
9159 9000 CONTINUE
9160      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'COCH')THEN
9161        WRITE(ICOUT,999)
9162        CALL DPWRST('XXX','BUG ')
9163        WRITE(ICOUT,9011)
9164 9011   FORMAT('***** AT THE END       OF DPCOCH--')
9165        CALL DPWRST('XXX','BUG ')
9166        WRITE(ICOUT,9016)IFOUND,IERROR
9167 9016   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
9168        CALL DPWRST('XXX','BUG ')
9169      ENDIF
9170C
9171      RETURN
9172      END
9173      SUBROUTINE DPCOC2(Y,BLOCK,TREAT,N,IVARID,IVARI2,
9174     1                  Z,C,R,TEMP1,TEMP2,
9175     1                  MAXNXT,MAXCOC,
9176     1                  STATVA,STATCD,PVAL,
9177     1                  CUT0,CUT50,CUT75,CUT90,CUT95,CUT975,
9178     1                  CUT99,CUT999,
9179     1                  ICAPSW,ICAPTY,IFORSW,
9180     1                  IBUGA3,ISUBRO,IERROR)
9181C
9182C     PURPOSE--THIS ROUTINE CARRIES OUT COCHRAN'S TEST
9183C              ANALYSIS OF A RANDOMIZED COMPLETE BLOCK DESIGN
9184C              WHERE THE OUTCOME CAN BE EITHER "SUCCESS" OR
9185C              "FAILURE" (OR ANY TWO MUTUALLY EXCLUSIVE OUTCOMES).
9186C              THESE ARE CODED AS ZERO AND ONE.
9187C              IN DATAPLOT, THE COLUMNS REPRESENT TREATMENTS AND
9188C              THE ROWS REPRESENT SUBJECTS.
9189C
9190C              THE TEST STATISTIC IS:
9191C
9192C                 T = c*(c-1)*SUM[J=1 to c][(C(j) - N/c)**2]/
9193C                     SUM[i=1 to r][R(i)*(c - R(i))]
9194C
9195C              WITH c, r, C(j), R(i) AND N denoting the
9196C              NUMBER OF COLUMNS, NUMBER OF ROWS, COLUMN TOTALS,
9197C              ROW TOTALS, AND GRAND TOTAL RESPECTIVELY.
9198C
9199C              THE CRITICAL VALUE IS:
9200C
9201C                 CHSPPF(c-1,ALPHA)
9202C
9203C     EXAMPLE--COCHRAN TEST Y X1 X2
9204C     REFERENCE--W. J., CONOVER, 1999, "PRACTICAL NON-PARAMETRIC
9205C                STATSTICS", THIRD EDITION, WILEY, PP. 251-256.
9206C     WRITTEN BY--ALAN HECKERT
9207C                 STATISTICAL ENGINEERING DIVISION
9208C                 INFORMATION TECHNOLOGY LABORATORY
9209C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
9210C                 GAITHERSBURG, MD 20899-8980
9211C                 PHONE--301-975-2899
9212C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
9213C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
9214C     LANGUAGE--ANSI FORTRAN (1977)
9215C     VERSION NUMBER--2004/10
9216C     ORIGINAL VERSION--OCTOBER   2004.
9217C     UPDATED         --DECEMBER  2005. RECODE TO USE
9218C                                         COCHRAN TEST Y X1 X2
9219C                                       INSTEAD OF
9220C                                         COCHRAN TEST Y X1 ... XK
9221C                                       IN ORDER TO BE CONSISTENT
9222C                                       WITH OTHER DATAPLOT COMMANDS.
9223C     UPDATED         --APRIL     2011. USE DPDTA1 AND DPDTA4 TO PRINT
9224C                                       TABLES.  THIS ADDS RTF SUPPORT
9225C                                       AND SPECIFICATION OF THE NUMBER
9226C                                       OF DIGITS.
9227C
9228C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
9229C
9230      CHARACTER*4 ICAPSW
9231      CHARACTER*4 ICAPTY
9232      CHARACTER*4 IFORSW
9233      CHARACTER*4 IBUGA3
9234      CHARACTER*4 ISUBRO
9235      CHARACTER*4 IERROR
9236      CHARACTER*4 IVARID(*)
9237      CHARACTER*4 IVARI2(*)
9238C
9239      CHARACTER*4 IWRITE
9240      CHARACTER*4 ISUBN1
9241      CHARACTER*4 ISUBN2
9242      CHARACTER*4 ISTEPN
9243C
9244C---------------------------------------------------------------------
9245C
9246      DIMENSION Y(*)
9247      DIMENSION BLOCK(*)
9248      DIMENSION TREAT(*)
9249      DIMENSION C(*)
9250      DIMENSION R(*)
9251      DIMENSION TEMP1(*)
9252      DIMENSION TEMP2(*)
9253      DIMENSION Z(MAXNXT,MAXCOC)
9254C
9255      PARAMETER (NUMALP=8)
9256      REAL ALPHA(NUMALP)
9257C
9258      PARAMETER(NUMCLI=6)
9259      PARAMETER(MAXLIN=2)
9260      PARAMETER (MAXROW=50)
9261      CHARACTER*60 ITITLE
9262      CHARACTER*60 ITITLZ
9263      CHARACTER*1  ITITL9
9264      CHARACTER*60 ITEXT(MAXROW)
9265      CHARACTER*4  ALIGN(NUMCLI)
9266      CHARACTER*4  VALIGN(NUMCLI)
9267      REAL         AVALUE(MAXROW)
9268      INTEGER      NCTEXT(MAXROW)
9269      INTEGER      IDIGIT(MAXROW)
9270      INTEGER      NTOT(MAXROW)
9271      CHARACTER*60 ITITL2(MAXLIN,NUMCLI)
9272      CHARACTER*15 IVALUE(MAXROW,NUMCLI)
9273      CHARACTER*4  ITYPCO(NUMCLI)
9274      INTEGER      NCTIT2(MAXLIN,NUMCLI)
9275      INTEGER      NCVALU(MAXROW,NUMCLI)
9276      INTEGER      IWHTML(NUMCLI)
9277      INTEGER      IWRTF(NUMCLI)
9278      REAL         AMAT(MAXROW,NUMCLI)
9279      LOGICAL IFRST
9280      LOGICAL ILAST
9281C
9282C---------------------------------------------------------------------
9283C
9284      INCLUDE 'DPCOP2.INC'
9285C
9286C-----START POINT-----------------------------------------------------
9287C
9288      DATA ALPHA/
9289     1 0.0, 50.0, 75.0, 90.0, 95.0, 97.5, 99.0, 99.9/
9290C
9291      ISUBN1='DPCO'
9292      ISUBN2='C2  '
9293C
9294      IERROR='NO'
9295C
9296      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'COC2')THEN
9297        WRITE(ICOUT,999)
9298  999   FORMAT(1X)
9299        CALL DPWRST('XXX','WRIT')
9300        WRITE(ICOUT,51)
9301   51   FORMAT('**** AT THE BEGINNING OF DPCOC2--')
9302        CALL DPWRST('XXX','WRIT')
9303        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
9304   52   FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8)
9305        CALL DPWRST('XXX','WRIT')
9306        DO56I=1,N
9307          WRITE(ICOUT,57)I,Y(I),BLOCK(I),TREAT(I)
9308   57     FORMAT('I,Y(I),BLOCK(I),TREAT(I) = ',I8,3G15.7)
9309          CALL DPWRST('XXX','WRIT')
9310   56   CONTINUE
9311      ENDIF
9312C
9313C               ********************************************
9314C               **  STEP 11--                             **
9315C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
9316C               ********************************************
9317C
9318      ISTEPN='11'
9319      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'COC2')
9320     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9321C
9322      ALOW=Y(1)
9323      AHIGH=CPUMAX
9324      IDIST=1
9325C
9326      DO110I=1,N
9327        ATEMP=Y(I)
9328        IF(IDIST.EQ.1)THEN
9329          IF(ATEMP.EQ.ALOW)THEN
9330            GOTO110
9331          ELSE
9332            IDIST=IDIST+1
9333            AHIGH=ATEMP
9334            GOTO110
9335          ENDIF
9336        ELSEIF(IDIST.EQ.2)THEN
9337          IF(ATEMP.EQ.ALOW .OR. ATEMP.EQ.AHIGH)THEN
9338            GOTO110
9339          ELSE
9340            IDIST=IDIST+1
9341            GOTO129
9342          ENDIF
9343        ELSE
9344          GOTO129
9345        ENDIF
9346  110 CONTINUE
9347C
9348  129 CONTINUE
9349C
9350      IF(IDIST.GT.2)THEN
9351        WRITE(ICOUT,999)
9352        CALL DPWRST('XXX','WRIT')
9353        WRITE(ICOUT,161)
9354  161   FORMAT('***** ERROR FROM COCHRAN TEST--')
9355        CALL DPWRST('XXX','WRIT')
9356        WRITE(ICOUT,163)
9357  163   FORMAT('      MORE THAN TWO DISTINCT VALUES DETECTED IN')
9358        CALL DPWRST('XXX','WRIT')
9359        WRITE(ICOUT,165)
9360  165   FORMAT('      INPUT DATA.  THE COCHRAN TEST IS FOR')
9361        CALL DPWRST('XXX','WRIT')
9362        WRITE(ICOUT,167)
9363  167   FORMAT('      DICHOTOMOUS DATA.  NOTHING DONE.')
9364        CALL DPWRST('XXX','WRIT')
9365        IERROR='YES'
9366        GOTO9000
9367      ENDIF
9368C
9369      IF(ALOW.GT.AHIGH)THEN
9370        ATEMP=ALOW
9371        ALOW=AHIGH
9372        AHIGH=ATEMP
9373      ENDIF
9374C
9375      DO220I=1,N
9376        IF(Y(I).EQ.ALOW)Y(I)=0.0
9377        IF(Y(I).EQ.AHIGH)Y(I)=1.0
9378  220 CONTINUE
9379C
9380C               ******************************************
9381C               **  STEP 31--                          **
9382C               **  COMPUTE DISTINCT ROWS AND COLUMNS. **
9383C               **  INITIALIZE Z MATRIX TO -99 SO WE   **
9384C               **  CAN DETECT EMPTY CELLS (COCHRAN    **
9385C               **  TEST ASSUMES COMPLETE BLOCKS)      **
9386C               *****************************************
9387C
9388      ISTEPN='31'
9389      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'COC2')
9390     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9391C
9392      IWRITE='OFF'
9393      CALL CODE(BLOCK,N,IWRITE,TEMP1,TEMP2,MAXNXT,IBUGA3,IERROR)
9394      DO301I=1,N
9395        BLOCK(I)=TEMP1(I)
9396  301 CONTINUE
9397      CALL MAXIM(BLOCK,N,IWRITE,XMAX,IBUGA3,IERROR)
9398      NROW=INT(XMAX+0.5)
9399C
9400      CALL CODE(TREAT,N,IWRITE,TEMP1,TEMP2,MAXNXT,IBUGA3,IERROR)
9401      DO303I=1,N
9402        TREAT(I)=TEMP1(I)
9403  303 CONTINUE
9404      CALL MAXIM(TREAT,N,IWRITE,XMAX,IBUGA3,IERROR)
9405      NCOL=INT(XMAX+0.5)
9406C
9407      DO310J=1,NCOL
9408        DO320I=1,NROW
9409          Z(I,J)=-99.0
9410  320   CONTINUE
9411  310 CONTINUE
9412C
9413      DO330I=1,N
9414        IROW=INT(BLOCK(I)+0.5)
9415        ICOL=INT(TREAT(I)+0.5)
9416        Z(IROW,ICOL)=Y(I)
9417  330 CONTINUE
9418C
9419      DO340J=1,NCOL
9420        DO350I=1,NROW
9421          IF(Z(I,J).LT.-0.5)THEN
9422            WRITE(ICOUT,999)
9423            CALL DPWRST('XXX','WRIT')
9424            WRITE(ICOUT,161)
9425            CALL DPWRST('XXX','WRIT')
9426            WRITE(ICOUT,363)
9427  363       FORMAT('      AN INCOMPLETE BLOCK DESIGN WAS DETECTED.')
9428            CALL DPWRST('XXX','WRIT')
9429            WRITE(ICOUT,365)IROW,ICOL
9430  365       FORMAT('      ROW ',I8,' AND COLUMM ',I8,' WAS EMPTY.')
9431            CALL DPWRST('XXX','WRIT')
9432            IERROR='YES'
9433            GOTO9000
9434          ENDIF
9435  350   CONTINUE
9436  340 CONTINUE
9437      IF(NROW*NCOL.NE.N)THEN
9438        WRITE(ICOUT,999)
9439        CALL DPWRST('XXX','WRIT')
9440        WRITE(ICOUT,161)
9441        CALL DPWRST('XXX','WRIT')
9442        WRITE(ICOUT,363)
9443        CALL DPWRST('XXX','WRIT')
9444        WRITE(ICOUT,367)NROW,NCOL
9445  367   FORMAT('      THE NUMBER OF ROWS (',I8,') TIMES THE ',
9446     1         'NUMBER OF COLUMMS ( ',I8,')')
9447        CALL DPWRST('XXX','WRIT')
9448        WRITE(ICOUT,369)N
9449  369   FORMAT('      DOES NOT EQUAL THE SAMPLE SIZE (',I8,').')
9450        CALL DPWRST('XXX','WRIT')
9451        IERROR='YES'
9452        GOTO9000
9453      ENDIF
9454C
9455C
9456C               ******************************
9457C               **  STEP 41--               **
9458C               **  CARRY OUT CALCULATIONS  **
9459C               **  FOR COCHRAN TEST        **
9460C               ******************************
9461C
9462      ISTEPN='41'
9463      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'COC2')
9464     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9465C
9466      IWRITE='OFF'
9467C
9468C  STEP 1: COMPUTE ROW AND COLUMN TOTALS
9469C
9470      AN=0.0
9471      DO410J=1,NCOL
9472        SUM1=0.0
9473        DO420I=1,NROW
9474          SUM1=SUM1 + Z(I,J)
9475  420   CONTINUE
9476        C(J)=SUM1
9477        AN=AN + SUM1
9478  410 CONTINUE
9479C
9480      DO460I=1,NROW
9481        SUM1=0.0
9482        DO470J=1,NCOL
9483          SUM1=SUM1 + Z(I,J)
9484  470   CONTINUE
9485        R(I)=SUM1
9486  460 CONTINUE
9487C
9488C  STEP 2: COMPUTE TEST STATISTIC
9489C
9490      ANCOL=REAL(NCOL)
9491      ANROW=REAL(NROW)
9492C
9493      ANUM=0.0
9494      DO510J=1,NCOL
9495        ANUM=ANUM + (C(J) - AN/ANCOL)**2
9496  510 CONTINUE
9497C
9498      ADEN=0.0
9499      DO520I=1,NROW
9500        ADEN=ADEN + R(I)*(ANCOL - R(I))
9501  520 CONTINUE
9502C
9503      STATVA=ANCOL*(ANCOL-1.0)*ANUM/ADEN
9504
9505      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'COC2')THEN
9506        WRITE(ICOUT,531)ANUM,ADEN,STATVA
9507  531   FORMAT('ANUM,ADEN,STATVA = ',3G15.7)
9508        CALL DPWRST('XXX','BUG ')
9509        DO541J=1,NCOL
9510          WRITE(ICOUT,543)J,C(J)
9511  543     FORMAT('J,C(J) = ',I8,G15.7)
9512          CALL DPWRST('XXX','BUG ')
9513  541   CONTINUE
9514        DO551I=1,NROW
9515          WRITE(ICOUT,553)I,R(I)
9516  553     FORMAT('I,R(I) = ',I8,G15.7)
9517          CALL DPWRST('XXX','BUG ')
9518  551   CONTINUE
9519      ENDIF
9520C
9521      NUMDF1=NCOL-1
9522      CALL CHSCDF(STATVA,NUMDF1,STATCD)
9523      PVAL=1.0 - STATCD
9524C
9525      CUT0=0.0
9526      CALL CHSPPF(.50,NUMDF1,CUT50)
9527      CALL CHSPPF(.75,NUMDF1,CUT75)
9528      CALL CHSPPF(.90,NUMDF1,CUT90)
9529      CALL CHSPPF(.95,NUMDF1,CUT95)
9530      CALL CHSPPF(.975,NUMDF1,CUT975)
9531      CALL CHSPPF(.99,NUMDF1,CUT99)
9532      CALL CHSPPF(.999,NUMDF1,CUT999)
9533C
9534C               ******************************
9535C               **   STEP 43--              **
9536C               **   WRITE OUT EVERYTHING   **
9537C               **   FOR COCHRAN  TEST      **
9538C               ******************************
9539C
9540      ISTEPN='43'
9541      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'COC2')
9542     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9543C
9544      IF(IPRINT.EQ.'OFF')GOTO9000
9545C
9546      NUMDIG=7
9547      IF(IFORSW.EQ.'1')NUMDIG=1
9548      IF(IFORSW.EQ.'2')NUMDIG=2
9549      IF(IFORSW.EQ.'3')NUMDIG=3
9550      IF(IFORSW.EQ.'4')NUMDIG=4
9551      IF(IFORSW.EQ.'5')NUMDIG=5
9552      IF(IFORSW.EQ.'6')NUMDIG=6
9553      IF(IFORSW.EQ.'7')NUMDIG=7
9554      IF(IFORSW.EQ.'8')NUMDIG=8
9555      IF(IFORSW.EQ.'9')NUMDIG=9
9556      IF(IFORSW.EQ.'0')NUMDIG=0
9557      IF(IFORSW.EQ.'E')NUMDIG=-2
9558      IF(IFORSW.EQ.'-2')NUMDIG=-2
9559      IF(IFORSW.EQ.'-3')NUMDIG=-3
9560      IF(IFORSW.EQ.'-4')NUMDIG=-4
9561      IF(IFORSW.EQ.'-5')NUMDIG=-5
9562      IF(IFORSW.EQ.'-6')NUMDIG=-6
9563      IF(IFORSW.EQ.'-7')NUMDIG=-7
9564      IF(IFORSW.EQ.'-8')NUMDIG=-8
9565      IF(IFORSW.EQ.'-9')NUMDIG=-9
9566C
9567      ITITLE=
9568     1 'Cochran Test for Two-Way Randomized Complete Block Designs'
9569      NCTITL=58
9570      ITITLZ='(Dichotomous Data)'
9571      NCTITZ=28
9572C
9573      ICNT=1
9574      ITEXT(ICNT)=' '
9575      NCTEXT(ICNT)=0
9576      AVALUE(ICNT)=0.0
9577      IDIGIT(ICNT)=-1
9578      ICNT=ICNT+1
9579      ITEXT(ICNT)='Response Variable: '
9580      WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1)(1:4)
9581      WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1)(1:4)
9582      NCTEXT(ICNT)=27
9583      AVALUE(ICNT)=0.0
9584      IDIGIT(ICNT)=-1
9585C
9586      ICNT=ICNT+1
9587      ITEXT(ICNT)='First Group-ID Variable: '
9588      WRITE(ITEXT(ICNT)(26:29),'(A4)')IVARID(2)(1:4)
9589      WRITE(ITEXT(ICNT)(30:33),'(A4)')IVARI2(2)(1:4)
9590      NCTEXT(ICNT)=33
9591      AVALUE(ICNT)=0.0
9592      IDIGIT(ICNT)=-1
9593C
9594      ICNT=ICNT+1
9595      ITEXT(ICNT)='Second Group-ID Variable: '
9596      WRITE(ITEXT(ICNT)(27:30),'(A4)')IVARID(3)(1:4)
9597      WRITE(ITEXT(ICNT)(31:34),'(A4)')IVARI2(3)(1:4)
9598      NCTEXT(ICNT)=34
9599      AVALUE(ICNT)=0.0
9600      IDIGIT(ICNT)=-1
9601C
9602      ICNT=ICNT+1
9603      ITEXT(ICNT)=' '
9604      NCTEXT(ICNT)=1
9605      AVALUE(ICNT)=0.0
9606      IDIGIT(ICNT)=-1
9607C
9608      ICNT=ICNT+1
9609      ITEXT(ICNT)='H0: Treatments Have Identical Effects'
9610      NCTEXT(ICNT)=37
9611      AVALUE(ICNT)=0.0
9612      IDIGIT(ICNT)=-1
9613      ICNT=ICNT+1
9614      ITEXT(ICNT)='Ha: Treatments Do Not Have Identical Effects'
9615      NCTEXT(ICNT)=44
9616      AVALUE(ICNT)=0.0
9617      IDIGIT(ICNT)=-1
9618C
9619      ICNT=ICNT+1
9620      ITEXT(ICNT)=' '
9621      NCTEXT(ICNT)=1
9622      AVALUE(ICNT)=0.0
9623      IDIGIT(ICNT)=-1
9624C
9625      ICNT=ICNT+1
9626      ITEXT(ICNT)='Summary Statistics:'
9627      NCTEXT(ICNT)=19
9628      AVALUE(ICNT)=0.0
9629      IDIGIT(ICNT)=-1
9630      ICNT=ICNT+1
9631      ITEXT(ICNT)='Total Number of Observations:'
9632      NCTEXT(ICNT)=29
9633      AVALUE(ICNT)=REAL(N)
9634      IDIGIT(ICNT)=0
9635      ICNT=ICNT+1
9636      ITEXT(ICNT)='Number of Blocks:'
9637      NCTEXT(ICNT)=17
9638      AVALUE(ICNT)=REAL(NROW)
9639      IDIGIT(ICNT)=0
9640      ICNT=ICNT+1
9641      ITEXT(ICNT)='Number of Treatments:'
9642      NCTEXT(ICNT)=21
9643      AVALUE(ICNT)=REAL(NCOL)
9644      IDIGIT(ICNT)=0
9645      ICNT=ICNT+1
9646      ITEXT(ICNT)=' '
9647      NCTEXT(ICNT)=1
9648      AVALUE(ICNT)=0.0
9649      IDIGIT(ICNT)=-1
9650C
9651      ICNT=ICNT+1
9652      ITEXT(ICNT)='Test:'
9653      NCTEXT(ICNT)=5
9654      AVALUE(ICNT)=0.0
9655      IDIGIT(ICNT)=-1
9656      ICNT=ICNT+1
9657      ITEXT(ICNT)='Cochran Test Statistic:'
9658      NCTEXT(ICNT)=23
9659      AVALUE(ICNT)=STATVA
9660      IDIGIT(ICNT)=NUMDIG
9661      ICNT=ICNT+1
9662      ITEXT(ICNT)='CDF of Test Statistic:'
9663      NCTEXT(ICNT)=22
9664      AVALUE(ICNT)=STATCD
9665      IDIGIT(ICNT)=NUMDIG
9666      ICNT=ICNT+1
9667      ITEXT(ICNT)='P-Value:'
9668      NCTEXT(ICNT)=8
9669      AVALUE(ICNT)=PVAL
9670      IDIGIT(ICNT)=NUMDIG
9671C
9672      NUMROW=ICNT
9673      DO4210I=1,NUMROW
9674        NTOT(I)=15
9675 4210 CONTINUE
9676C
9677      IFRST=.TRUE.
9678      ILAST=.TRUE.
9679C
9680      ISTEPN='42A'
9681      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DUR2')
9682     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9683C
9684      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
9685     1            AVALUE,IDIGIT,
9686     1            NTOT,NUMROW,
9687     1            ICAPSW,ICAPTY,ILAST,IFRST,
9688     1            ISUBRO,IBUGA3,IERROR)
9689C
9690      ITITLE=' '
9691      NCTITL=0
9692      ITITL9=' '
9693      NCTIT9=0
9694      ITITLE='Percent Points of the Chi-Square Reference Distribution'
9695      NCTITL=55
9696      NUMLIN=1
9697      NUMROW=8
9698      NUMCOL=3
9699      ITITL2(1,1)='Percent Point'
9700      ITITL2(1,2)=' '
9701      ITITL2(1,3)='Value'
9702      NCTIT2(1,1)=13
9703      NCTIT2(1,2)=1
9704      NCTIT2(1,3)=5
9705C
9706      NMAX=0
9707      DO4221I=1,NUMCOL
9708        VALIGN(I)='b'
9709        ALIGN(I)='r'
9710        NTOT(I)=15
9711        IF(I.EQ.2)NTOT(I)=5
9712        NMAX=NMAX+NTOT(I)
9713        IDIGIT(I)=NUMDIG
9714        ITYPCO(I)='NUME'
9715 4221 CONTINUE
9716      ITYPCO(2)='ALPH'
9717      IDIGIT(1)=1
9718      IDIGIT(3)=3
9719      DO4223I=1,NUMROW
9720        DO4225J=1,NUMCOL
9721          NCVALU(I,J)=0
9722          IVALUE(I,J)=' '
9723          NCVALU(I,J)=0
9724          AMAT(I,J)=0.0
9725          IF(J.EQ.1)THEN
9726            AMAT(I,J)=ALPHA(I)
9727          ELSEIF(J.EQ.2)THEN
9728            IVALUE(I,J)='='
9729            NCVALU(I,J)=1
9730          ELSEIF(J.EQ.3)THEN
9731            IF(I.EQ.1)THEN
9732              AMAT(I,J)=RND(CUT0,IDIGIT(J))
9733            ELSEIF(I.EQ.2)THEN
9734              AMAT(I,J)=RND(CUT50,IDIGIT(J))
9735            ELSEIF(I.EQ.3)THEN
9736              AMAT(I,J)=RND(CUT75,IDIGIT(J))
9737            ELSEIF(I.EQ.4)THEN
9738              AMAT(I,J)=RND(CUT90,IDIGIT(J))
9739            ELSEIF(I.EQ.5)THEN
9740              AMAT(I,J)=RND(CUT95,IDIGIT(J))
9741            ELSEIF(I.EQ.6)THEN
9742              AMAT(I,J)=RND(CUT975,IDIGIT(J))
9743            ELSEIF(I.EQ.7)THEN
9744              AMAT(I,J)=RND(CUT99,IDIGIT(J))
9745            ELSEIF(I.EQ.8)THEN
9746              AMAT(I,J)=RND(CUT999,IDIGIT(J))
9747            ENDIF
9748          ENDIF
9749 4225   CONTINUE
9750 4223 CONTINUE
9751C
9752      IWHTML(1)=150
9753      IWHTML(2)=50
9754      IWHTML(3)=150
9755      IWRTF(1)=2000
9756      IWRTF(2)=IWRTF(1)+500
9757      IWRTF(3)=IWRTF(2)+2000
9758      IFRST=.TRUE.
9759      ILAST=.TRUE.
9760C
9761      ISTEPN='42C'
9762      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DUR2')
9763     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9764C
9765      CALL DPDTA4(ITITL9,NCTIT9,
9766     1            ITITLE,NCTITL,ITITL2,NCTIT2,
9767     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
9768     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW,
9769     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
9770     1            ICAPSW,ICAPTY,IFRST,ILAST,
9771     1            ISUBRO,IBUGA3,IERROR)
9772C
9773      CDF1=CUT90
9774      CDF2=CUT95
9775      CDF3=CUT975
9776      CDF4=CUT99
9777C
9778      ITITL9=' '
9779      NCTIT9=0
9780      ITITLE='Conclusions (Upper 1-Tailed Test)'
9781      NCTITL=33
9782      NUMLIN=1
9783      NUMROW=4
9784      NUMCOL=4
9785      ITITL2(1,1)='Alpha'
9786      ITITL2(1,2)='CDF'
9787      ITITL2(1,3)='Critical Value'
9788      ITITL2(1,4)='Conclusion'
9789      NCTIT2(1,1)=5
9790      NCTIT2(1,2)=3
9791      NCTIT2(1,3)=14
9792      NCTIT2(1,4)=10
9793C
9794      NMAX=0
9795      DO4321I=1,NUMCOL
9796        VALIGN(I)='b'
9797        ALIGN(I)='r'
9798        NTOT(I)=15
9799        IF(I.EQ.1 .OR. I.EQ.2)NTOT(I)=7
9800        IF(I.EQ.3)NTOT(I)=17
9801        NMAX=NMAX+NTOT(I)
9802        IDIGIT(I)=3
9803        ITYPCO(I)='ALPH'
9804 4321 CONTINUE
9805      ITYPCO(3)='NUME'
9806      IDIGIT(1)=0
9807      IDIGIT(2)=0
9808      DO4323I=1,NUMROW
9809        DO4325J=1,NUMCOL
9810          NCVALU(I,J)=0
9811          IVALUE(I,J)=' '
9812          NCVALU(I,J)=0
9813          AMAT(I,J)=0.0
9814 4325   CONTINUE
9815 4323 CONTINUE
9816      IVALUE(1,1)='10%'
9817      IVALUE(2,1)='5%'
9818      IVALUE(3,1)='2.5%'
9819      IVALUE(4,1)='1%'
9820      IVALUE(1,2)='90%'
9821      IVALUE(2,2)='95%'
9822      IVALUE(3,2)='97.5%'
9823      IVALUE(4,2)='99%'
9824      NCVALU(1,1)=3
9825      NCVALU(2,1)=2
9826      NCVALU(3,1)=4
9827      NCVALU(4,1)=2
9828      NCVALU(1,2)=3
9829      NCVALU(2,2)=3
9830      NCVALU(3,2)=5
9831      NCVALU(4,2)=3
9832      IVALUE(1,4)='Accept H0'
9833      IVALUE(2,4)='Accept H0'
9834      IVALUE(3,4)='Accept H0'
9835      IVALUE(4,4)='Accept H0'
9836      NCVALU(1,4)=9
9837      NCVALU(2,4)=9
9838      NCVALU(3,4)=9
9839      NCVALU(4,4)=9
9840      IF(STATVA.GT.CUT90)IVALUE(1,4)='Reject H0'
9841      IF(STATVA.GT.CUT95)IVALUE(2,4)='Reject H0'
9842      IF(STATVA.GT.CUT975)IVALUE(3,4)='Reject H0'
9843      IF(STATVA.GT.CUT99)IVALUE(4,4)='Reject H0'
9844      AMAT(1,3)=RND(CUT90,IDIGIT(3))
9845      AMAT(2,3)=RND(CUT95,IDIGIT(3))
9846      AMAT(3,3)=RND(CUT975,IDIGIT(3))
9847      AMAT(4,3)=RND(CUT99,IDIGIT(3))
9848C
9849      IWHTML(1)=150
9850      IWHTML(2)=150
9851      IWHTML(3)=150
9852      IWHTML(4)=150
9853      IWRTF(1)=1500
9854      IWRTF(2)=IWRTF(1)+1500
9855      IWRTF(3)=IWRTF(2)+2000
9856      IWRTF(4)=IWRTF(3)+2000
9857      IFRST=.FALSE.
9858      ILAST=.TRUE.
9859C
9860      ISTEPN='42E'
9861      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'COC2')
9862     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9863C
9864      CALL DPDTA4(ITITL9,NCTIT9,
9865     1            ITITLE,NCTITL,ITITL2,NCTIT2,
9866     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
9867     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW,
9868     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
9869     1            ICAPSW,ICAPTY,IFRST,ILAST,
9870     1            ISUBRO,IBUGA3,IERROR)
9871C
9872C               *****************
9873C               **  STEP 90--  **
9874C               **  EXIT       **
9875C               *****************
9876C
9877 9000 CONTINUE
9878      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'COC2')THEN
9879        WRITE(ICOUT,999)
9880        CALL DPWRST('XXX','WRIT')
9881        WRITE(ICOUT,9011)
9882 9011   FORMAT('***** AT THE END       OF DPCOC2--')
9883        CALL DPWRST('XXX','WRIT')
9884        WRITE(ICOUT,9012)NROW,NCOL,IBUGA3,IERROR
9885 9012   FORMAT('NROW,NCOL,IBUGA3,IERROR = ',2I8,2X,A4,2X,A4)
9886        CALL DPWRST('XXX','WRIT')
9887        WRITE(ICOUT,9014)STATVA,STATCD,PVAL
9888 9014   FORMAT('STATVA,STATCD,PVAL = ',3G15.7)
9889        CALL DPWRST('XXX','WRIT')
9890      ENDIF
9891C
9892      RETURN
9893      END
9894      SUBROUTINE DPCOD2(IDIG,IHDIG,IBUGD3,IERROR)
9895C
9896C     NOTE--THIS SUBROUTINE IS IDENTICAL TO DPCODH.
9897C           IT HAS BEEN DUPLICATED AND PLACED
9898C           ON THIS BRANCH OF THE OVERLAY/SEGMENTATION
9899C           TREE STRUCTURE IN ORDER TO ACHIEVE
9900C           FASTER EXECUTION TIME.
9901C
9902C     PURPOSE--CONVERT NUMERIC DIGIT INTO CORRESPONDING
9903C              CHARACTER.
9904C
9905C     WRITTEN BY--JAMES J. FILLIBEN
9906C                 STATISTICAL ENGINEERING DIVISION
9907C                 INFORMATION TECHNOLOGY LABORATORY
9908C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
9909C                 GAITHERSBURG, MD 20899-8980
9910C                 PHONE--301-975-2855
9911C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
9912C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
9913C     LANGUAGE--ANSI FORTRAN (1977)
9914C     VERSION NUMBER--82/7
9915C     ORIGINAL VERSION--MARCH   1983.
9916C
9917C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
9918C
9919      CHARACTER*4 IHDIG
9920      CHARACTER*4 IBUGD3
9921      CHARACTER*4 IERROR
9922C
9923C---------------------------------------------------------------------
9924C
9925      INCLUDE 'DPCOP2.INC'
9926C
9927C-----START POINT---------------------------------------------------------
9928C
9929      IHDIG='-999'
9930      IF(IDIG.EQ.1)IHDIG='1'
9931      IF(IDIG.EQ.2)IHDIG='2'
9932      IF(IDIG.EQ.3)IHDIG='3'
9933      IF(IDIG.EQ.4)IHDIG='4'
9934      IF(IDIG.EQ.5)IHDIG='5'
9935      IF(IDIG.EQ.6)IHDIG='6'
9936      IF(IDIG.EQ.7)IHDIG='7'
9937      IF(IDIG.EQ.8)IHDIG='8'
9938      IF(IDIG.EQ.9)IHDIG='9'
9939      IF(IDIG.EQ.0)IHDIG='0'
9940      GOTO9000
9941C
9942C               *****************
9943C               **  STEP 90--  **
9944C               **  EXIT       **
9945C               *****************
9946C
9947 9000 CONTINUE
9948      IF(IBUGD3.EQ.'OFF')GOTO9090
9949      WRITE(ICOUT,999)
9950  999 FORMAT(1X)
9951      CALL DPWRST('XXX','BUG ')
9952      WRITE(ICOUT,9011)
9953 9011 FORMAT('***** AT THE END OF DPCOD2--')
9954      CALL DPWRST('XXX','BUG ')
9955      WRITE(ICOUT,9012)IDIG,IHDIG
9956 9012 FORMAT('IDIG,IHDIG = ',I8,2X,A4)
9957      CALL DPWRST('XXX','BUG ')
9958      WRITE(ICOUT,9013)IBUGD3,IERROR
9959 9013 FORMAT('IBUGD3,IERROR = ',A4,2X,A4)
9960      CALL DPWRST('XXX','BUG ')
9961 9090 CONTINUE
9962C
9963      RETURN
9964      END
9965      SUBROUTINE DPCODH(IDIG,IHDIG,IBUGD3,IERROR)
9966C
9967C     PURPOSE--CONVERT NUMERIC DIGIT INTO CORRESPONDING
9968C              CHARACTER.
9969C
9970C     WRITTEN BY--JAMES J. FILLIBEN
9971C                 STATISTICAL ENGINEERING DIVISION
9972C                 INFORMATION TECHNOLOGY LABORATORY
9973C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
9974C                 GAITHERSBURG, MD 20899-8980
9975C                 PHONE--301-975-2855
9976C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
9977C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
9978C     LANGUAGE--ANSI FORTRAN (1977)
9979C     VERSION NUMBER--82/7
9980C     ORIGINAL VERSION--MARCH   1983.
9981C
9982C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
9983C
9984      CHARACTER*4 IHDIG
9985      CHARACTER*4 IBUGD3
9986      CHARACTER*4 IERROR
9987C
9988C---------------------------------------------------------------------
9989C
9990      INCLUDE 'DPCOP2.INC'
9991C
9992C-----START POINT---------------------------------------------------------
9993C
9994      IHDIG='-999'
9995      IF(IDIG.EQ.1)IHDIG='1'
9996      IF(IDIG.EQ.2)IHDIG='2'
9997      IF(IDIG.EQ.3)IHDIG='3'
9998      IF(IDIG.EQ.4)IHDIG='4'
9999      IF(IDIG.EQ.5)IHDIG='5'
10000      IF(IDIG.EQ.6)IHDIG='6'
10001      IF(IDIG.EQ.7)IHDIG='7'
10002      IF(IDIG.EQ.8)IHDIG='8'
10003      IF(IDIG.EQ.9)IHDIG='9'
10004      IF(IDIG.EQ.0)IHDIG='0'
10005      GOTO9000
10006C
10007C               *****************
10008C               **  STEP 90--  **
10009C               **  EXIT       **
10010C               *****************
10011C
10012 9000 CONTINUE
10013      IF(IBUGD3.EQ.'OFF')GOTO9090
10014      WRITE(ICOUT,999)
10015  999 FORMAT(1X)
10016      CALL DPWRST('XXX','BUG ')
10017      WRITE(ICOUT,9011)
10018 9011 FORMAT('***** AT THE END OF DPCODH--')
10019      CALL DPWRST('XXX','BUG ')
10020      WRITE(ICOUT,9012)IDIG,IHDIG
10021 9012 FORMAT('IDIG,IHDIG = ',I8,2X,A4)
10022      CALL DPWRST('XXX','BUG ')
10023      WRITE(ICOUT,9013)IBUGD3,IERROR
10024 9013 FORMAT('IBUGD3,IERROR = ',A4,2X,A4)
10025      CALL DPWRST('XXX','BUG ')
10026 9090 CONTINUE
10027C
10028      RETURN
10029      END
10030      SUBROUTINE DPCODS(ICASE,D,P,IBUGD2,ISUBRO,IERROR)
10031C
10032C     PURPOSE--CONVERT AN INPUT X OR Y VALUE (IN DATA UNITS)
10033C              (RELATIVE TO THE LAST PLOT THAT APPEARED)
10034C              INTO ABSOLUTE (0. TO 100.) X OR Y SCREEN UNITS.
10035C     NOTE--CHARACTER*1 ICASE WILL BE EITHER 'X' OR 'Y'
10036C     ORIGINAL VERSION--NOVEMBER 1992
10037C     UPDATED         --MARCH    2001 SUPPORT FOR LOG SCALES (BUT NOT
10038C                                     WEIBULL AND NORMAL)
10039C     UPDATED         --APRIL    2010 USE "FX1MAX" AND "FY1MAX" INSTEAD
10040C                                     OF "FX2MAX" AND "FY2MAX".  BUG
10041C                                     IF "X1TIC MARK OFFSET" USED
10042C                                     INSTEAD OF "XTIC MARK OFFSET
10043C                                     (UPPER LIMIT WILL NOT INCORPORATE
10044C                                     THE OFFSET).
10045C
10046C
10047C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
10048C
10049      CHARACTER*1 ICASE
10050      CHARACTER*4 IBUGD2
10051      CHARACTER*4 ISUBRO
10052      CHARACTER*4 IERROR
10053C
10054C-----COMMON----------------------------------------------------------
10055C
10056      INCLUDE 'DPCOPA.INC'
10057      INCLUDE 'DPCOPC.INC'
10058C
10059C-----COMMON VARIABLES (GENERAL)-----------------------------------------------
10060C
10061      INCLUDE 'DPCOP2.INC'
10062C
10063C-----START POINT-----------------------------------------------------
10064C
10065      IERROR='NO'
10066C
10067      IF(IBUGD2.NE.'ON'.AND.ISUBRO.NE.'CODS')GOTO90
10068      WRITE(ICOUT,999)
10069  999 FORMAT(1X)
10070      CALL DPWRST('XXX','BUG ')
10071      WRITE(ICOUT,51)
10072   51 FORMAT('***** AT THE BEGINNING OF DPCODS--')
10073      CALL DPWRST('XXX','BUG ')
10074      WRITE(ICOUT,53)IBUGD2,ISUBRO,IERROR
10075   53 FORMAT('IBUGD2,ISUBRO,IERROR = ',2(A4,2X),A4)
10076      CALL DPWRST('XXX','BUG ')
10077      WRITE(ICOUT,54)ICASE,D,P
10078   54 FORMAT('ICASE,D,P = ',A1,2E15.7)
10079      CALL DPWRST('XXX','BUG ')
10080      WRITE(ICOUT,61)PXMIN,PXMAX,PYMIN,PYMAX
10081   61 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX = ',4G15.7)
10082      CALL DPWRST('XXX','BUG ')
10083      WRITE(ICOUT,62)FX1MIN,FX1MAX,FY1MIN,FY2MAX
10084   62 FORMAT('FX1MIN,FX2MAX,FY1MIN,FY2MAX = ',4G15.7)
10085      CALL DPWRST('XXX','BUG ')
10086      WRITE(ICOUT,63)GX1MIN,GX2MAX,GY1MIN,GY2MAX
10087   63 FORMAT('GX1MIN,GX2MAX,GY1MIN,GY2MAX = ',4G15.7)
10088      CALL DPWRST('XXX','BUG ')
10089      WRITE(ICOUT,64)IX1TSC,IY1TSC
10090   64 FORMAT('IX1TSC,IY1TSC = ',2(A4,2X))
10091      CALL DPWRST('XXX','BUG ')
10092   90 CONTINUE
10093C
10094      IF(ICASE.EQ.'X')THEN
10095        IF(IX1TSC.EQ.'LOG')THEN
10096          IF(FX1MIN.LE.0.0 .OR. D.LE.0.0)THEN
10097            WRITE(ICOUT,999)
10098            CALL DPWRST('XXX','BUG ')
10099            WRITE(ICOUT,121)
10100  121 FORMAT('***** FROM DPCODS: NEGATIVE NUMBER ENCOUNTERED FOR')
10101            CALL DPWRST('XXX','BUG ')
10102            WRITE(ICOUT,123)
10103  123 FORMAT('      EITHER THE AXIS MINIMUM OR THE X COORDINATE')
10104            CALL DPWRST('XXX','BUG ')
10105            XFRACT=(D-FX1MIN)/(FX1MAX-FX1MIN)
10106            P=PXMIN+XFRACT*(PXMAX-PXMIN)
10107            GOTO299
10108          ENDIF
10109          ARG1=LOG10(FX1MIN)
10110          ARG2=LOG10(FX1MAX)
10111          ARG3=LOG10(D)
10112          XFRACT=(ARG3-ARG1)/(ARG2-ARG1)
10113          P=PXMIN+XFRACT*(PXMAX-PXMIN)
10114        ELSEIF(IX1TSC.EQ.'WEIB')THEN
10115          WRITE(ICOUT,999)
10116          CALL DPWRST('XXX','BUG ')
10117          WRITE(ICOUT,111)
10118  111 FORMAT('***** FROM DPCODS: WEIBULL SCALE NOT SUPPORTED FOR ',
10119     1       'X AXIS')
10120          XFRACT=(D-FX1MIN)/(FX1MAX-FX1MIN)
10121          P=PXMIN+XFRACT*(PXMAX-PXMIN)
10122        ELSEIF(IX1TSC.EQ.'NORM')THEN
10123          WRITE(ICOUT,999)
10124          CALL DPWRST('XXX','BUG ')
10125          WRITE(ICOUT,101)
10126  101 FORMAT('***** FROM DPCODS: NORMAL SCALE NOT SUPPORTED FOR ',
10127     1       'X AXIS')
10128          CALL DPWRST('XXX','BUG ')
10129          XFRACT=(D-FX1MIN)/(FX1MAX-FX1MIN)
10130          P=PXMIN+XFRACT*(PXMAX-PXMIN)
10131        ELSE
10132          XFRACT=(D-FX1MIN)/(FX1MAX-FX1MIN)
10133          P=PXMIN+XFRACT*(PXMAX-PXMIN)
10134        ENDIF
10135      ELSE
10136        IF(IY1TSC.EQ.'LOG')THEN
10137          IF(FY1MIN.LE.0.0 .OR. D.LE.0.0)THEN
10138            WRITE(ICOUT,999)
10139            CALL DPWRST('XXX','BUG ')
10140            WRITE(ICOUT,221)
10141  221 FORMAT('***** FROM DPCODS: NEGATIVE NUMBER ENCOUNTERED FOR')
10142            CALL DPWRST('XXX','BUG ')
10143            WRITE(ICOUT,223)
10144  223 FORMAT('      EITHER THE AXIS MINIMUM OR THE Y COORDINATE')
10145            CALL DPWRST('XXX','BUG ')
10146            YFRACT=(D-FY1MIN)/(FY1MAX-FY1MIN)
10147            P=PYMIN+YFRACT*(PYMAX-PYMIN)
10148            GOTO299
10149          ENDIF
10150          ARG1=LOG10(FY1MIN)
10151          ARG2=LOG10(FY1MAX)
10152          ARG3=LOG10(D)
10153          YFRACT=(ARG3-ARG1)/(ARG2-ARG1)
10154          P=PYMIN+YFRACT*(PYMAX-PYMIN)
10155        ELSEIF(IY1TSC.EQ.'WEIB')THEN
10156          WRITE(ICOUT,999)
10157          CALL DPWRST('XXX','BUG ')
10158          WRITE(ICOUT,211)
10159  211 FORMAT('***** FROM DPCODS: WEIBULL SCALE NOT SUPPORTED FOR ',
10160     1       'Y AXIS')
10161          YFRACT=(D-FY1MIN)/(FY1MAX-FY1MIN)
10162          P=PYMIN+YFRACT*(PYMAX-PYMIN)
10163        ELSEIF(IY1TSC.EQ.'NORM')THEN
10164          WRITE(ICOUT,999)
10165          CALL DPWRST('XXX','BUG ')
10166          WRITE(ICOUT,201)
10167  201 FORMAT('***** FROM DPCODS: NORMAL SCALE NOT SUPPORTED FOR ',
10168     1       'Y AXIS')
10169          YFRACT=(D-FY1MIN)/(FY1MAX-FY1MIN)
10170          P=PYMIN+YFRACT*(PYMAX-PYMIN)
10171        ELSE
10172          YFRACT=(D-FY1MIN)/(FY1MAX-FY1MIN)
10173          P=PYMIN+YFRACT*(PYMAX-PYMIN)
10174        ENDIF
10175      ENDIF
10176  299 CONTINUE
10177C
10178C               ****************
10179C               **  STEP 90-- **
10180C               **  EXIT.     **
10181C               ****************
10182C
10183      IF(IBUGD2.NE.'ON'.AND.ISUBRO.NE.'CODS')GOTO9090
10184      WRITE(ICOUT,9011)
10185 9011 FORMAT('***** AT THE BEGINNING OF DPCODS--')
10186      CALL DPWRST('XXX','BUG ')
10187      WRITE(ICOUT,9013)IBUGD2,ISUBRO,IERROR
10188 9013 FORMAT('IBUGD2,ISUBRO,IERROR = ',2(A4,2X),A4)
10189      CALL DPWRST('XXX','BUG ')
10190      WRITE(ICOUT,9014)ICASE,D,P
10191 9014 FORMAT('ICASE,D,P = ',A1,2E15.7)
10192      CALL DPWRST('XXX','BUG ')
10193      WRITE(ICOUT,9021)PXMIN,PXMAX,PYMIN,PYMAX
10194 9021 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX = ',4E15.7)
10195      CALL DPWRST('XXX','BUG ')
10196      WRITE(ICOUT,9022)FX1MIN,FX2MAX,FY1MIN,FY2MAX
10197 9022 FORMAT('FX1MIN,FX2MAX,FY1MIN,FY2MAX = ',4E15.7)
10198      CALL DPWRST('XXX','BUG ')
10199 9090 CONTINUE
10200C
10201      RETURN
10202      END
10203      SUBROUTINE DPCOFH(IL1,IL2,IFUNC,NUMCHF,IH,NH,IBUGD2,IERROR)
10204C
10205C     PURPOSE--COPY OVER THE FUNCTION STRING IN LOCATIONS
10206C              IL1 TO IL2 OF IFUNC(.) AND PLACE IT IN
10207C              LOCATIONS 1 TO NH (= ILOC2-ILOC1+1)
10208C              OF THE ARRAY IH(.)
10209C
10210C     WRITTEN BY--JAMES J. FILLIBEN
10211C                 STATISTICAL ENGINEERING DIVISION
10212C                 INFORMATION TECHNOLOGY LABORATORY
10213C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
10214C                 GAITHERSBURG, MD 20899-8980
10215C                 PHONE--301-975-2855
10216C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
10217C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
10218C     LANGUAGE--ANSI FORTRAN (1977)
10219C     VERSION NUMBER--86/7
10220C     ORIGINAL VERSION--JUNE  1986.
10221C
10222C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
10223C
10224      CHARACTER*4 IFUNC
10225      CHARACTER*4 IH
10226      CHARACTER*4 IBUGD2
10227      CHARACTER*4 IERROR
10228C
10229      DIMENSION IFUNC(*)
10230      DIMENSION IH(*)
10231C
10232      CHARACTER*4 ISUBN1
10233      CHARACTER*4 ISUBN2
10234CCCCC CHARACTER*4 ISTEPN
10235C
10236C---------------------------------------------------------------------
10237C
10238      INCLUDE 'DPCOP2.INC'
10239C
10240C-----START POINT-----------------------------------------------------
10241C
10242      ISUBN1='DPCO'
10243      ISUBN2='FH  '
10244      IERROR='NO'
10245C
10246      IF(IBUGD2.EQ.'ON')THEN
10247        WRITE(ICOUT,999)
10248  999   FORMAT(1X)
10249        CALL DPWRST('XXX','BUG ')
10250        WRITE(ICOUT,51)
10251   51   FORMAT('***** AT THE BEGINNING OF DPCOFH--')
10252        CALL DPWRST('XXX','BUG ')
10253        WRITE(ICOUT,52)IL1,IL2,NUMCHF
10254   52   FORMAT('IL1,IL2,NUMCHF = ',3I8)
10255        CALL DPWRST('XXX','BUG ')
10256        WRITE(ICOUT,55)(IFUNC(I),I=1,MIN(100,NUMCHF))
10257   55   FORMAT('IFUNC(.) = ',100A1)
10258        CALL DPWRST('XXX','BUG ')
10259      ENDIF
10260C
10261C               *********************************
10262C               **  STEP 11--                  **
10263C               **  COPY OVER THE STRING       **
10264C               *********************************
10265      J=0
10266      IF(IL1.GT.IL2)GOTO1150
10267      DO1100I=IL1,IL2
10268        J=J+1
10269        IH(J)=IFUNC(I)
10270 1100 CONTINUE
10271 1150 CONTINUE
10272      NH=J
10273C
10274C               *****************
10275C               **  STEP 90--  **
10276C               **  EXIT       **
10277C               *****************
10278C
10279      IF(IBUGD2.EQ.'ON')THEN
10280        WRITE(ICOUT,999)
10281        CALL DPWRST('XXX','BUG ')
10282        WRITE(ICOUT,9011)
10283 9011   FORMAT('***** AT THE END       OF DPCOFH--')
10284        CALL DPWRST('XXX','BUG ')
10285        WRITE(ICOUT,9024)NH
10286 9024   FORMAT('NH = ',I8)
10287        CALL DPWRST('XXX','BUG ')
10288        WRITE(ICOUT,9025)(IH(I),I=1,MIN(100,NH))
10289 9025   FORMAT('IH(.) = ',100A1)
10290        CALL DPWRST('XXX','BUG ')
10291      ENDIF
10292C
10293      RETURN
10294      END
10295      SUBROUTINE DPCOFI(ICOM,IANSLC,IWIDTH,IHARG,IHARG2,NUMARG,
10296     1                  IBUGS2,IBUGQ,ISUBRO,IFOUND,IERROR)
10297C
10298C     PURPOSE--COPY AN INPUT FILE TO AN OUTPUT FILE.
10299C     WRITTEN BY--JAMES J. FILLIBEN
10300C                 STATISTICAL ENGINEERING DIVISION
10301C                 INFORMATION TECHNOLOGY LABORATORY
10302C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
10303C                 GAITHERSBURG, MD 20899-8980
10304C                 PHONE--301-975-2855
10305C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
10306C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
10307C     LANGUAGE--ANSI FORTRAN (1977)
10308C     VERSION NUMBER--94/1
10309C     ORIGINAL VERSION--MAY       1994.
10310C     UPDATED  VERSION--NOVEMBER  2014. COPY CLIPBOARD TO FILE
10311C     UPDATED  VERSION--DECEMBER  2014. COPY FILE TO CLIPBOARD
10312C     UPDATED  VERSION--MARCH     2019. COPY SYSTEM TO USE OPERATING
10313C                                       SYSTEM DEPENDENT COPY
10314C     UPDATED  VERSION--DECEMBER  2019. INCREASE MAX NUMBER OF
10315C                                       CHARACTERS TO 255
10316C     UPDATED  VERSION--FEBRUARY  2020. FOR "CLIPBOARD", CHECK TO SEE
10317C                                       IF ARGUMENT IS ACTUALLY A FILE
10318C                                       NAME
10319C
10320C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
10321C
10322      CHARACTER*4 ICOM
10323      CHARACTER*4 IANSLC
10324      CHARACTER*4 IHARG
10325      CHARACTER*4 IHARG2
10326      CHARACTER*4 IBUGS2
10327      CHARACTER*4 IBUGQ
10328      CHARACTER*4 ISUBRO
10329      CHARACTER*4 IFOUND
10330      CHARACTER*4 IERROR
10331C
10332      INCLUDE 'DPCOPA.INC'
10333C
10334CCCCC CHARACTER*80 IFILE1
10335      CHARACTER (LEN=MAXFNC) :: IFILE1
10336      CHARACTER*12 ISTAT1
10337      CHARACTER*12 IFORM1
10338      CHARACTER*12 IACCE1
10339      CHARACTER*12 IPROT1
10340      CHARACTER*12 ICURS1
10341C
10342CCCCC CHARACTER*80 IFILE2
10343      CHARACTER (LEN=MAXFNC) :: IFILE2
10344      CHARACTER*12 ISTAT2
10345      CHARACTER*12 IFORM2
10346      CHARACTER*12 IACCE2
10347      CHARACTER*12 IPROT2
10348      CHARACTER*12 ICURS2
10349C
10350      CHARACTER*4 IENDFI
10351      CHARACTER*4 IREWIN
10352      CHARACTER*4 ISUBN0
10353      CHARACTER*4 IERRFI
10354C
10355C
10356      CHARACTER*4 ISUBN1
10357      CHARACTER*4 ISUBN2
10358      CHARACTER*4 ISTEPN
10359      CHARACTER*4 ICASE
10360      CHARACTER*4 ICASE2
10361      CHARACTER*4 ITYPE
10362      CHARACTER*4 IOFILE
10363      CHARACTER*4 ICASEQ
10364      CHARACTER*9 ICLIZZ
10365      CHARACTER*10 IFORMT
10366C
10367      CHARACTER*4 IANSI
10368      CHARACTER (LEN=MAXSTR) :: ICANS
10369      CHARACTER (LEN=MAXSTR) :: ISTRIN
10370C
10371      DIMENSION IANSLC(*)
10372      DIMENSION IHARG(*)
10373      DIMENSION IHARG2(*)
10374C
10375C-----COMMON----------------------------------------------------------
10376C
10377      INCLUDE 'DPCODA.INC'
10378      INCLUDE 'DPCOF2.INC'
10379      INCLUDE 'DPCOZC.INC'
10380C
10381      CHARACTER*2000000 ISTR
10382      EQUIVALENCE (CGARBG(1),ISTR)
10383C
10384C-----COMMON VARIABLES (GENERAL)--------------------------------------
10385C
10386      INCLUDE 'DPCOP2.INC'
10387C
10388C-----START POINT-----------------------------------------------------
10389C
10390      ISUBN1='DPCO'
10391      ISUBN2='FI  '
10392      IFOUND='YES'
10393      IERROR='NO'
10394      ICASE='FILE'
10395C
10396      ICASE2='FILE'
10397      IF(IHARG(1).EQ.'SYST' .AND. IHARG2(1).EQ.'EM  ')THEN
10398        ICASE2='SYST'
10399      ENDIF
10400C
10401      MINN2=1
10402      NCSTRI=(-999)
10403C
10404      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'COFI')THEN
10405        WRITE(ICOUT,999)
10406  999   FORMAT(1X)
10407        CALL DPWRST('XXX','BUG ')
10408        WRITE(ICOUT,51)
10409   51   FORMAT('***** AT THE BEGINNING OF DPCOFI--')
10410        CALL DPWRST('XXX','BUG ')
10411        WRITE(ICOUT,53)ICOM,IBUGS2,ISUBRO,IERROR,ICASE2
10412   53   FORMAT('ICOM,IBUGS2,ISUBRO,IERROR,ICASE2 = ',4(A4,2X),A4)
10413        CALL DPWRST('XXX','BUG ')
10414        WRITE(ICOUT,54)IWIDTH,ILISNU,ICONNU,IDIRNU
10415   54   FORMAT('IWIDTH,ILISNU,ICONNU,IDIRNU = ',5I8)
10416        CALL DPWRST('XXX','BUG ')
10417        IF(IWIDTH.GE.1)THEN
10418          WRITE(ICOUT,55)(IANSLC(I),I=1,MIN(80,IWIDTH))
10419   55     FORMAT('(IANSLC(I),I=1,IWIDTH) = ',80A1)
10420          CALL DPWRST('XXX','BUG ')
10421        ENDIF
10422        WRITE(ICOUT,61)IHARG(1),IHARG2(1),IHARG(2),IHARG2(2),
10423     1                 IHARG(3),IHARG2(3)
10424   61   FORMAT('IHARG(1),IHARG2(1),IHARG(2),IHARG2(2),',
10425     1         'IHARG(3),IHARG2(3) = ',3(2A4,2X))
10426        CALL DPWRST('XXX','BUG ')
10427        WRITE(ICOUT,62)ILISNA
10428   62   FORMAT('ILISNA = ',A80)
10429        CALL DPWRST('XXX','BUG ')
10430        WRITE(ICOUT,63)ILISST,ILISFO,ILISAC,ILISFO,ILISCS
10431   63   FORMAT('ILISST,ILISFO,ILISAC,ILISFO,ILISCS = ',
10432     1         4(A12,2X),A12)
10433        CALL DPWRST('XXX','BUG ')
10434        WRITE(ICOUT,72)ICONNA
10435   72   FORMAT('ICONNA = ',A80)
10436        CALL DPWRST('XXX','BUG ')
10437        WRITE(ICOUT,73)ICONST,ICONFO,ICONAC,ICONFO,ICONCS
10438   73   FORMAT('ICONST,ICONFO,ICONAC,ICONFO,ICONCS = ',
10439     1         4(A12,2X),A12)
10440        CALL DPWRST('XXX','BUG ')
10441        WRITE(ICOUT,82)IDIRNA
10442   82   FORMAT('IDIRNA = ',A80)
10443        CALL DPWRST('XXX','BUG ')
10444        WRITE(ICOUT,83)IDIRST,IDIRFO,IDIRAC,IDIRFO,IDIRCS
10445   83   FORMAT('IDIRST,IDIRFO,IDIRAC,IDIRFO,IDIRCS = ',
10446     1         4(A12,2X),A12)
10447        CALL DPWRST('XXX','BUG ')
10448      ENDIF
10449C
10450C               **************************
10451C               **  STEP 11--           **
10452C               **  COPY OVER VARIABLES **
10453C               **************************
10454C
10455      ISTEPN='11'
10456      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'COFI')
10457     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10458C
10459      IOUNI1=ILISNU
10460      IFILE1=ILISNA
10461      ISTAT1=ILISST
10462      IFORM1=ILISFO
10463      IACCE1=ILISAC
10464      IPROT1=ILISPR
10465      ICURS1=ILISCS
10466C
10467      IOUNI2=IWRINU
10468      IFILE2=IWRINA
10469      ISTAT2=IWRIST
10470      IFORM2=IWRIFO
10471      IACCE2=IWRIAC
10472      IPROT2=IWRIPR
10473      ICURS2=IWRICS
10474C
10475      ISUBN0='COFI'
10476      IERRFI='NO'
10477C
10478      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'COFI')THEN
10479        WRITE(ICOUT,1181)IOUNI1
10480 1181   FORMAT('IOUNI1 = ',I8)
10481        CALL DPWRST('XXX','BUG ')
10482        WRITE(ICOUT,1182)IFILE1
10483 1182   FORMAT('IFILE1 = ',A80)
10484        CALL DPWRST('XXX','BUG ')
10485        WRITE(ICOUT,1183)ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2
10486 1183   FORMAT('ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2 = ',
10487     1         4(A12,2X),A12)
10488        CALL DPWRST('XXX','BUG ')
10489C
10490        WRITE(ICOUT,1191)IOUNI2
10491 1191   FORMAT('IOUNI2 = ',I8)
10492        CALL DPWRST('XXX','BUG ')
10493        WRITE(ICOUT,1192)IFILE2
10494 1192   FORMAT('IFILE2 = ',A80)
10495        CALL DPWRST('XXX','BUG ')
10496        WRITE(ICOUT,1193)ISTAT1,IFORM1,IACCE1,IPROT1,ICURS1
10497 1193   FORMAT('ISTAT1,IFORM1,IACCE1,IPROT1,ICURS1 = ',
10498     1         4(A12,2X),A12)
10499        CALL DPWRST('XXX','BUG ')
10500C
10501        WRITE(ICOUT,1198)ISUBN0,IERRFI
10502 1198   FORMAT('ISUBN0,IERRFI = ',A4,2X,A4)
10503        CALL DPWRST('XXX','BUG ')
10504      ENDIF
10505C
10506C               ***********************************************
10507C               **  STEP 12--                                **
10508C               **  CHECK TO SEE IF THE COPY FILE MAY EXIST  **
10509C               ***********************************************
10510C
10511      ISTEPN='12'
10512      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'COFI')
10513     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10514C
10515      IF(ISTAT1.EQ.'NONE' .AND. ICASE.EQ.'FILE')THEN
10516        WRITE(ICOUT,999)
10517        CALL DPWRST('XXX','BUG ')
10518        WRITE(ICOUT,1211)
10519 1211   FORMAT('***** ERROR IN COPY FILE (DPCOFI)--')
10520        CALL DPWRST('XXX','BUG ')
10521        WRITE(ICOUT,1212)
10522 1212   FORMAT('      THE DESIRED COPYING CANNOT BE CARRIED OUT')
10523        CALL DPWRST('XXX','BUG ')
10524        WRITE(ICOUT,1214)
10525 1214   FORMAT('      BECAUSE THE INTERNAL VARIABLE    ILISST ')
10526        CALL DPWRST('XXX','BUG ')
10527        WRITE(ICOUT,1215)
10528 1215   FORMAT('      WHICH ALLOWS SUCH LISTING HAS BEEN SET TO ',
10529     1         '  NONE.')
10530        CALL DPWRST('XXX','BUG ')
10531        WRITE(ICOUT,1217)ISTAT1,ILISST
10532 1217   FORMAT('ISTAT1,ILISST = ',A12,2X,A12)
10533        CALL DPWRST('XXX','BUG ')
10534        IERROR='YES'
10535        GOTO9000
10536      ENDIF
10537C
10538C               ***************************************
10539C               **  STEP 13--                        **
10540C               **  EXTRACT THE INPUT  FILE NAME.    **
10541C               ***************************************
10542C
10543      ISTEPN='13'
10544      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'COFI')
10545     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10546C
10547      DO1310I=1,MAXSTR
10548        IANSI=IANSLC(I)
10549        ICANS(I:I)=IANSI(1:1)
10550 1310 CONTINUE
10551C
10552      ISTART=1
10553      ISTOP=IWIDTH
10554      IWORD=2
10555      IF(ICASE2.EQ.'SYST')IWORD=3
10556      CALL DPEXWO(ICANS,ISTART,ISTOP,IWORD,
10557     1            ICOL1,ICOL2,IFILE1,NCFIL1,
10558     1            IBUGS2,ISUBRO,IERROR)
10559C
10560      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'COFI')THEN
10561        WRITE(ICOUT,1321)NCFIL1,IFILE1
10562 1321   FORMAT('NCFIL1,IFILE1 = ',I8,2X,A80)
10563        CALL DPWRST('XXX','BUG ')
10564      ENDIF
10565C
10566      IF(NCFIL1.EQ.9)THEN
10567        CALL DPUPPE(IFILE1,NCFIL1,ICLIZZ,IBUGS2,IERROR)
10568        IF(ICLIZZ(1:9).EQ.'CLIPBOARD')THEN
10569C
10570C         CHECK IF ARGUMENT IS A FILE NAME STARTING WITH
10571C         "CLIPBOARD.
10572C
10573          IWORD=2
10574          IF(ICASE2.EQ.'SYST')IWORD=3
10575          IOFILE='NO'
10576          CALL DPFILE(IANSLC,IWIDTH,IWORD,IOFILE,IBUGS2,ISUBRO,IERROR)
10577          IF(IOFILE.EQ.'NO')ICASE='CLIP'
10578        ENDIF
10579      ENDIF
10580C
10581      IF(NCFIL1.LT.1)THEN
10582        WRITE(ICOUT,999)
10583        CALL DPWRST('XXX','BUG ')
10584        WRITE(ICOUT,1211)
10585        CALL DPWRST('XXX','BUG ')
10586        WRITE(ICOUT,1372)
10587 1372   FORMAT('      TWO FILE NAMES--AN INPUT AND AN OUTPUT--')
10588        CALL DPWRST('XXX','BUG ')
10589        WRITE(ICOUT,1373)
10590 1373   FORMAT('      ARE REQUIRED IN THE COPY COMMAND')
10591        CALL DPWRST('XXX','BUG ')
10592        WRITE(ICOUT,1374)
10593 1374   FORMAT('      (FOR EXAMPLE,    COPY BOXSPRIN.DAT TEMP.)')
10594        CALL DPWRST('XXX','BUG ')
10595        WRITE(ICOUT,1375)
10596 1375   FORMAT('      BUT TWO NAMES WERE NOT GIVEN HERE.')
10597        CALL DPWRST('XXX','BUG ')
10598        WRITE(ICOUT,1382)
10599 1382   FORMAT('   INPUT  FILE--')
10600        CALL DPWRST('XXX','BUG ')
10601        IERROR='YES'
10602        GOTO9000
10603      ENDIF
10604C
10605      ISTART=1
10606      ISTOP=IWIDTH
10607      IWORD=IWORD+1
10608      CALL DPEXWO(ICANS,ISTART,ISTOP,IWORD,
10609     1            ICOL1,ICOL2,IFILE2,NCFIL2,
10610     1            IBUGS2,ISUBRO,IERROR)
10611C
10612      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'COFI')THEN
10613        WRITE(ICOUT,1323)NCFIL2,IFILE2
10614 1323   FORMAT('NCFIL2,IFILE2 = ',I8,2X,A80)
10615        CALL DPWRST('XXX','BUG ')
10616      ENDIF
10617C
10618      IF(NCFIL2.EQ.9)THEN
10619        CALL DPUPPE(IFILE2,NCFIL2,ICLIZZ,IBUGS2,IERROR)
10620        IF(ICLIZZ(1:9).EQ.'CLIPBOARD')THEN
10621C
10622C         CHECK IF ARGUMENT IS A FILE NAME STARTING WITH
10623C         "CLIPBOARD.
10624C
10625          IWORD=3
10626          IF(ICASE2.EQ.'SYST')IWORD=4
10627          IOFILE='NO'
10628          CALL DPFILE(IANSLC,IWIDTH,IWORD,IOFILE,IBUGS2,ISUBRO,IERROR)
10629          IF(IOFILE.EQ.'NO')ICASE='CLI2'
10630        ENDIF
10631      ENDIF
10632C
10633      IF(NCFIL2.LT.1)THEN
10634        WRITE(ICOUT,999)
10635        CALL DPWRST('XXX','BUG ')
10636        WRITE(ICOUT,1211)
10637        CALL DPWRST('XXX','BUG ')
10638        WRITE(ICOUT,1372)
10639        CALL DPWRST('XXX','BUG ')
10640        WRITE(ICOUT,1373)
10641        CALL DPWRST('XXX','BUG ')
10642        WRITE(ICOUT,1374)
10643        CALL DPWRST('XXX','BUG ')
10644        WRITE(ICOUT,1375)
10645        CALL DPWRST('XXX','BUG ')
10646C
10647        IF(NCFIL1.GE.1 .AND. ICASE.NE.'CLIP')THEN
10648           WRITE(ICOUT,1381)(IFILE1(I:I),I=1,NCFIL1)
10649 1381      FORMAT('   INPUT  FILE--',80A1)
10650           CALL DPWRST('XXX','BUG ')
10651        ENDIF
10652C
10653        IF(NCFIL2.GE.1)THEN
10654          WRITE(ICOUT,1383)(IFILE2(I:I),I=1,NCFIL2)
10655 1383     FORMAT('   OUTPUT FILE--',80A1)
10656          CALL DPWRST('XXX','BUG ')
10657        ELSE
10658           WRITE(ICOUT,1384)
10659 1384      FORMAT('   OUTPUT FILE--')
10660           CALL DPWRST('XXX','BUG ')
10661        ENDIF
10662C
10663        WRITE(ICOUT,1386)
10664 1386   FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
10665        CALL DPWRST('XXX','BUG ')
10666        IF(IWIDTH.GE.1)THEN
10667          WRITE(ICOUT,1387)(IANSLC(I),I=1,MIN(80,IWIDTH))
10668 1387     FORMAT('      ',80A1)
10669          CALL DPWRST('XXX','BUG ')
10670        ELSE
10671          WRITE(ICOUT,999)
10672          CALL DPWRST('XXX','BUG ')
10673        ENDIF
10674        IERROR='YES'
10675        GOTO9000
10676      ENDIF
10677C
10678C
10679C               *****************************************
10680C               **  STEP 20--                          **
10681C               **  IMPLEMENT OPERATING SYSTEM COPY    **
10682C               **  IF REQUESTED.                      **
10683C               *****************************************
10684C
10685      ISTEPN='20'
10686      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'COFI')
10687     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10688C
10689      IF(ICASE2.EQ.'SYST')THEN
10690        CALL COPYFI(IFILE1,IFILE2,IBUGS2,ISUBRO,IERROR)
10691        GOTO9000
10692      ENDIF
10693C
10694      ICASEQ='FULL'
10695C
10696C               *****************************************
10697C               **  STEP 21--                          **
10698C               **  CHECK TO SEE THE TYPE CASE--       **
10699C               **    1) UNQUALIFIED (THAT IS, FULL);  **
10700C               **    2) SUBSET/EXCEPT; OR             **
10701C               **    3) FOR.                          **
10702C               *****************************************
10703C
10704      ISTEPN='21'
10705      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'COFI')
10706     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10707C
10708      ICASEQ='FULL'
10709      ILOCQ=NUMARG+1
10710      IF(NUMARG.LT.1)GOTO2190
10711      DO2100J=1,NUMARG
10712        J1=J
10713        IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET  ') GOTO2110
10714        IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT  ') GOTO2110
10715        IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.'    ') GOTO2120
10716 2100 CONTINUE
10717      GOTO2190
10718 2110 CONTINUE
10719      ICASEQ='SUBS'
10720      ILOCQ=J1
10721      GOTO2190
10722 2120 CONTINUE
10723      ICASEQ='FOR'
10724      ILOCQ=J1
10725      GOTO2190
10726 2190 CONTINUE
10727C
10728      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'COFI')THEN
10729        WRITE(ICOUT,2191)NUMARG,ILOCQ
10730 2191   FORMAT('NUMARG,ILOCQ = ',2I8)
10731        CALL DPWRST('XXX','BUG ')
10732      ENDIF
10733C
10734C               *********************************************
10735C               **  STEP 22--                              **
10736C               **  BRANCH    TO THE APPROPRIATE SUBCASE   **
10737C               **  (FULL, SUBSET, OR FOR).                **
10738C               *********************************************
10739C
10740      ISTEPN='22'
10741      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'COFI')
10742     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10743C
10744      IF(ICASE.EQ.'CLIP')THEN
10745C
10746        ISTEPN='22A'
10747        IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'COFI')
10748     1     CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10749C
10750        IF(IFILE2.NE.ICONNA)THEN
10751          IREWIN='ON'
10752          CALL DPOPFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,
10753     1                IPROT2,ICURS2,
10754     1                IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
10755          IF(IERRFI.EQ.'YES')GOTO9000
10756        ENDIF
10757        ITYPE='COPY'
10758        IHELMX=-99
10759        CALL DPCLI2(ITYPE,IOUNI2,IHELMX,ILINRD,IBUGS2,ISUBRO,IERROR)
10760C
10761        IENDFI='OFF'
10762        IREWIN='ON'
10763        CALL DPCLFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2,
10764     1              IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
10765C
10766        GOTO9000
10767      ELSEIF(ICASE.EQ.'CLI2')THEN
10768C
10769        ISTEPN='22B'
10770        IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'COFI')
10771     1     CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10772C
10773        IF(IFILE1.NE.ICONNA)THEN
10774          IREWIN='ON'
10775          CALL DPOPFI(IOUNI1,IFILE1,ISTAT1,IFORM1,IACCE1,
10776     1                IPROT1,ICURS1,
10777     1                IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
10778          IF(IERRFI.EQ.'YES')GOTO9000
10779        ENDIF
10780        MAXCHR=2000000
10781        CALL DPCLI6(IOUNI1,ISTR,MAXCHR,IBUGS2,ISUBRO,IERROR)
10782C
10783        IENDFI='OFF'
10784        IREWIN='ON'
10785        CALL DPCLFI(IOUNI1,IFILE1,ISTAT1,IFORM1,IACCE1,IPROT1,ICURS1,
10786     1              IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
10787C
10788        GOTO9000
10789      ENDIF
10790C
10791      IF(ICASEQ.EQ.'FULL')GOTO2210
10792      IF(ICASEQ.EQ.'SUBS')GOTO2220
10793      IF(ICASEQ.EQ.'FOR')GOTO2230
10794C
10795 2210 CONTINUE
10796      DO2215I=1,MAXN
10797      ISUB(I)=1
10798 2215 CONTINUE
10799      NQ=MAXN
10800      GOTO2270
10801C
10802 2220 CONTINUE
10803      NIOLD=MAXN
10804      CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR)
10805      NQ=NIOLD
10806      GOTO2270
10807C
10808 2230 CONTINUE
10809      NIOLD=MAXN
10810      CALL DPFOR(NIOLD,NFOR,IROW1,IROWN,
10811     1NLOCAL,ILOCS,NS,IBUGQ,IERROR)
10812      NQ=NFOR
10813      NMXFOR=IROWN
10814      GOTO2270
10815C
10816 2270 CONTINUE
10817      IF(NQ.LT.MINN2)THEN
10818        WRITE(ICOUT,999)
10819        CALL DPWRST('XXX','BUG ')
10820        WRITE(ICOUT,1211)
10821        CALL DPWRST('XXX','BUG ')
10822        WRITE(ICOUT,2272)
10823 2272   FORMAT('      AFTER THE APPROPRIATE SUBSET HAS BEEN ',
10824     1         'EXTRACTED,')
10825        CALL DPWRST('XXX','BUG ')
10826        WRITE(ICOUT,2273)
10827 2273   FORMAT('      THE NUMBER OF SPECIFIED FILE LINES TO BE')
10828        CALL DPWRST('XXX','BUG ')
10829        WRITE(ICOUT,2276)MINN2
10830 2276   FORMAT('      LISTED MUST BE ',I8,' OR LARGER;')
10831        CALL DPWRST('XXX','BUG ')
10832        WRITE(ICOUT,2277)
10833 2277   FORMAT('      SUCH WAS NOT THE CASE HERE.')
10834        CALL DPWRST('XXX','BUG ')
10835        WRITE(ICOUT,1386)
10836        CALL DPWRST('XXX','BUG ')
10837        IF(IWIDTH.GE.1)THEN
10838          WRITE(ICOUT,1387)(IANSLC(I),I=1,MIN(80,IWIDTH))
10839          CALL DPWRST('XXX','BUG ')
10840        ELSE
10841          WRITE(ICOUT,999)
10842          CALL DPWRST('XXX','BUG ')
10843        ENDIF
10844        IERROR='YES'
10845      ENDIF
10846C
10847      NS=NQ
10848C
10849C               ****************************************
10850C               **  STEP 51--                         **
10851C               **  OPEN  THE INPUT AND OUTPUT FILES  **
10852C               **  (UNLESS ITS THE                   **
10853C               **  CONCLUSIONS FILE).                **
10854C               ****************************************
10855C
10856      ISTEPN='31'
10857      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'COFI')THEN
10858        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10859        WRITE(ICOUT,3111)IFILE1
10860 3111   FORMAT('IFILE1 = ',A80)
10861        CALL DPWRST('XXX','BUG ')
10862        WRITE(ICOUT,3112)IFILE2
10863 3112   FORMAT('IFILE2 = ',A80)
10864        CALL DPWRST('XXX','BUG ')
10865      ENDIF
10866C
10867      IF(IFILE2.NE.ICONNA)THEN
10868        IREWIN='ON'
10869        CALL DPOPFI(IOUNI1,IFILE1,ISTAT1,IFORM1,IACCE1,IPROT1,ICURS1,
10870     1              IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
10871        IF(IERRFI.EQ.'YES')GOTO9000
10872        CALL DPOPFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2,
10873     1              IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
10874        IF(IERRFI.EQ.'YES')GOTO9000
10875      ENDIF
10876C
10877C               ***********************************
10878C               **  STEP 41--                    **
10879C               **  READ IN THE INPUT FILE.      **
10880C               **  WRITE OUT THE OUTPUT FILE.   **
10881C               ***********************************
10882C
10883      ISTEPN='41'
10884      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'COFI')
10885     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10886C
10887      IMAX=1000000
10888      IF(ICASEQ.EQ.'SUBS')IMAX=MAXN
10889      IF(ICASEQ.EQ.'FOR')IMAX=IROWN
10890C
10891      NMAX=512
10892      IFORMT=' '
10893      IFORMT='(    A1)'
10894      WRITE(IFORMT(2:4),'(I4)')NMAX
10895      DO4110I=1,IMAX
10896C
10897        READ(IOUNI1,IFORMT,END=4190)(ISTRIN(J:J),J=1,NMAX)
10898C
10899        IF(ISUB(I).EQ.1)THEN
10900          CALL DPDB80(ISTRIN,JMAX,NMAX,IBUGS2,ISUBRO,IERROR)
10901          NCSTRI=JMAX
10902          WRITE(IOUNI2,IFORMT)(ISTRIN(J:J),J=1,NCSTRI)
10903        ENDIF
10904C
10905 4110 CONTINUE
10906 4190 CONTINUE
10907C
10908C               **************************
10909C               **  STEP 51--           **
10910C               **  CLOSE THE 2 FILES   **
10911C               **  (UNLESS ITS THE     **
10912C               **  CONCLUSIONS FILE).  **
10913C               **************************
10914C
10915      ISTEPN='51'
10916      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'COFI')
10917     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10918C
10919      IF(IFILE2.EQ.ICONNA)GOTO5190
10920C
10921      IENDFI='OFF'
10922      IREWIN='ON'
10923      CALL DPCLFI(IOUNI1,IFILE1,ISTAT1,IFORM1,IACCE1,IPROT1,ICURS1,
10924     1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
10925      CALL DPCLFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2,
10926     1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
10927C
10928 5190 CONTINUE
10929C
10930C               ****************
10931C               **  STEP 90-- **
10932C               **  EXIT.     **
10933C               ****************
10934C
10935 9000 CONTINUE
10936      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'COFI')THEN
10937        WRITE(ICOUT,999)
10938        CALL DPWRST('XXX','BUG ')
10939        WRITE(ICOUT,9011)
10940 9011   FORMAT('***** AT THE END       OF DPCOFI--')
10941        CALL DPWRST('XXX','BUG ')
10942        WRITE(ICOUT,9012)IERROR
10943 9012   FORMAT('IERROR = ',A4)
10944        CALL DPWRST('XXX','BUG ')
10945        WRITE(ICOUT,9041)ICASEQ,NQ,NS,JMAX,NCSTRI
10946 9041   FORMAT('ICASEQ,NQ,NS,JMAX,NCSTRI = ',A4,4I8)
10947        CALL DPWRST('XXX','BUG ')
10948      ENDIF
10949C
10950      RETURN
10951      END
10952      SUBROUTINE DPCOHI(ISTART,ISTOP,IANS2,N2,IVALID,VALCON,IVALCO,
10953     1                  IBUGA3,IERROR)
10954C
10955C     PURPOSE--DETERMINE IF THE STRING DEFINED
10956C              IN LOCATIONS ISTART THROUGH ISTOP (INCLUSIVE) IN IANS2(.).
10957C              IS A VALID NUMBER REPRESENTATION
10958C              AND IF SO, COMPUTE THE VALUE OF THE NUMBER.
10959C     NOTE--THIS SUBROUTINE IS IDENTICAL TO DPHOCO EXCEPT
10960C           FOR THE FACT THAT DPHOCO HAS THE INPUT STRING
10961C           IN LOCATIONS 1 THROUGH N2 OF IANS2(.)
10962C           WHEREAS DPCOHI HAS THE INPUT STRING
10963C           IN LOCATIONS ISTART THROUGH ISTOP OF IANS(.).
10964C
10965C     ORIGINAL VERSION--JANUARY   1979.
10966C     UPDATED         --JANUARY   1981.
10967C     UPDATED         --NOVEMBER  1989.  ITYPE2='NUMBER' BUG
10968C
10969C---------------------------------------------------------------------
10970C
10971      CHARACTER*4 IANS2
10972      CHARACTER*4 IVALID
10973      CHARACTER*4 IBUGA3
10974      CHARACTER*4 IERROR
10975C
10976      CHARACTER*4 ITYPE2
10977C
10978      CHARACTER*4 ISTEPN
10979      CHARACTER*4 ISUBN1
10980      CHARACTER*4 ISUBN2
10981C
10982      DIMENSION IANS2(*)
10983C
10984C-----COMMON VARIABLES (GENERAL)-----------------------------------------------
10985C
10986      INCLUDE 'DPCOP2.INC'
10987C
10988C-----START POINT-----------------------------------------------------
10989C
10990      ISUBN1='DPCO'
10991      ISUBN2='HI  '
10992      IERROR='NO'
10993C
10994      IF(IBUGA3.EQ.'ON')THEN
10995        WRITE(ICOUT,999)
10996  999   FORMAT(1X)
10997        CALL DPWRST('XXX','BUG ')
10998        WRITE(ICOUT,81)
10999   81   FORMAT('***** AT THE BEGINNING OF DPCOHI--')
11000        CALL DPWRST('XXX','BUG ')
11001        WRITE(ICOUT,82)N2,ISTART,ISTOP
11002   82   FORMAT('N2,ISTART,ISTOP = ',3I8)
11003        CALL DPWRST('XXX','BUG ')
11004        WRITE(ICOUT,83)(IANS2(I),I=1,MIN(N2,115))
11005   83   FORMAT('IANS2(.) = ',115A1)
11006        CALL DPWRST('XXX','BUG ')
11007      ENDIF
11008C
11009C               **********************************
11010C               **  STEP 1--                    **
11011C               **  INITIALIZE SOME VARIABLES.  **
11012C               **********************************
11013C
11014      ISTEPN='1'
11015      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11016C
11017      IVALID='NO'
11018C
11019C               ********************************************************
11020C               **  STEP 2--                                          **
11021C               **  CONVERT (IF POSSIBLE) THE STRING INTO A FLOATING  **
11022C               **  POINT ARGUMENT.                                   **
11023C               **  OUTPUT THIS FLOATING POINT VALUE IN FLOAT.        **
11024C               ********************************************************
11025C
11026      ISTEPN='2'
11027      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11028C
11029      AMIN=-1000000.
11030      AMAX=+1000000.
11031      IERROR='NO'
11032      IVALID='YES'
11033      ITYPE2='NUMB'
11034      VALCON=-999.0
11035      IVALCO=-999
11036C
11037      ISTAR2=ISTART
11038      ISTOP2=ISTOP
11039C
11040      ILOC=0
11041      IDECPT=0
11042      DO3060I=ISTAR2,ISTOP2
11043        IF(IANS2(I).EQ.'.')ILOC=I
11044        IF(IANS2(I).EQ.'.')IDECPT=IDECPT+1
11045 3060 CONTINUE
11046      IF(IDECPT.GE.2)GOTO3900
11047      IF(IDECPT.EQ.1)GOTO3150
11048      DO3100I=ISTAR2,ISTOP2
11049        IREV=ISTOP2-(I-ISTAR2)
11050        IF(IANS2(IREV).EQ.' ')GOTO3100
11051        IF(IANS2(IREV).EQ.'0')GOTO3110
11052        IF(IANS2(IREV).EQ.'1')GOTO3110
11053        IF(IANS2(IREV).EQ.'2')GOTO3110
11054        IF(IANS2(IREV).EQ.'3')GOTO3110
11055        IF(IANS2(IREV).EQ.'4')GOTO3110
11056        IF(IANS2(IREV).EQ.'5')GOTO3110
11057        IF(IANS2(IREV).EQ.'6')GOTO3110
11058        IF(IANS2(IREV).EQ.'7')GOTO3110
11059        IF(IANS2(IREV).EQ.'8')GOTO3110
11060        IF(IANS2(IREV).EQ.'9')GOTO3110
11061        IERROR='YES'
11062        IF(IANS2(IREV).EQ.'+')GOTO3900
11063        IF(IANS2(IREV).EQ.'-')GOTO3900
11064        GOTO3900
11065 3100 CONTINUE
11066      IERROR='YES'
11067      GOTO3900
11068 3110 CONTINUE
11069      ILOC=IREV+1
11070 3150 CONTINUE
11071C
11072      IF(IBUGA3.EQ.'ON')THEN
11073        WRITE(ICOUT,3111)ILOC,IDECPT
11074 3111   FORMAT('ILOC = ',I8,'    IDECPT = ',I8)
11075        CALL DPWRST('XXX','BUG ')
11076      ENDIF
11077C
11078C     SECONDLY, COMPUTE THE INTEGER PART OF THE VALUE
11079C
11080      SIGN=1.0
11081      IDIGI=0
11082      ISIGN=0
11083      SUMI=0
11084      ILOCM1=ILOC-1
11085      IF(ILOCM1.LT.ISTAR2)GOTO3250
11086      DO3200I=ISTAR2,ILOCM1
11087        IREV=ILOCM1-(I-ISTAR2)
11088        IF(IANS2(IREV).EQ.' ')GOTO3200
11089        IF(IANS2(IREV).EQ.'0')THEN
11090          ITERM=0
11091        ELSEIF(IANS2(IREV).EQ.'1')THEN
11092          ITERM=1
11093        ELSEIF(IANS2(IREV).EQ.'2')THEN
11094          ITERM=2
11095        ELSEIF(IANS2(IREV).EQ.'3')THEN
11096          ITERM=3
11097        ELSEIF(IANS2(IREV).EQ.'4')THEN
11098          ITERM=4
11099        ELSEIF(IANS2(IREV).EQ.'5')THEN
11100          ITERM=5
11101        ELSEIF(IANS2(IREV).EQ.'6')THEN
11102          ITERM=6
11103        ELSEIF(IANS2(IREV).EQ.'7')THEN
11104          ITERM=7
11105        ELSEIF(IANS2(IREV).EQ.'8')THEN
11106          ITERM=8
11107        ELSEIF(IANS2(IREV).EQ.'9')THEN
11108          ITERM=9
11109        ELSEIF(IANS2(IREV).EQ.'+')THEN
11110          ISIGN=ISIGN+1
11111          GOTO3200
11112        ELSEIF(IANS2(IREV).EQ.'-')THEN
11113          ISIGN=ISIGN+1
11114          SIGN=-SIGN
11115          GOTO3200
11116        ELSE
11117          IERROR='YES'
11118          GOTO3900
11119        ENDIF
11120C
11121        IDIGI=IDIGI+1
11122        TERM=ITERM
11123        IEXP=IDIGI-1
11124        SUMI=SUMI+TERM*(10.0**IEXP)
11125 3200 CONTINUE
11126 3250 CONTINUE
11127      IF(ISIGN.GE.2)GOTO3900
11128C
11129      IF(IBUGA3.EQ.'ON')THEN
11130         WRITE(ICOUT,3255)IDIGI,SUMI
11131 3255    FORMAT('IDIGI = ',I8,'    SUMI = ',E15.7)
11132         CALL DPWRST('XXX','BUG ')
11133      ENDIF
11134C
11135C     THIRDLY, COMPUTE THE DECIMAL PART OF THE VALUE
11136C
11137      IDIGD=0
11138      SUMD=0.0
11139      ILOCP1=ILOC+1
11140      IF(ILOCP1.GT.ISTOP2)GOTO3350
11141      DO3300I=ILOCP1,ISTOP2
11142        IF(IANS2(I).EQ.' ')GOTO3300
11143        IF(IANS2(I).EQ.'0')THEN
11144          ITERM=0
11145        ELSEIF(IANS2(I).EQ.'1')THEN
11146          ITERM=1
11147        ELSEIF(IANS2(I).EQ.'2')THEN
11148          ITERM=2
11149        ELSEIF(IANS2(I).EQ.'3')THEN
11150          ITERM=3
11151        ELSEIF(IANS2(I).EQ.'4')THEN
11152          ITERM=4
11153        ELSEIF(IANS2(I).EQ.'5')THEN
11154          ITERM=5
11155        ELSEIF(IANS2(I).EQ.'6')THEN
11156          ITERM=6
11157        ELSEIF(IANS2(I).EQ.'7')THEN
11158          ITERM=7
11159        ELSEIF(IANS2(I).EQ.'8')THEN
11160          ITERM=8
11161        ELSEIF(IANS2(I).EQ.'9')THEN
11162          ITERM=9
11163        ELSE
11164          IERROR='YES'
11165          GOTO3900
11166        ENDIF
11167        IDIGD=IDIGD+1
11168        TERM=ITERM
11169        SUMD=SUMD+TERM/(10.0**IDIGD)
11170 3300 CONTINUE
11171 3350 CONTINUE
11172C
11173      IF(IBUGA3.EQ.'ON')THEN
11174        WRITE(ICOUT,3355)IDIGD,SUMD
11175 3355   FORMAT('IDIGD = ',I8,'    SUMD = ',E15.7)
11176        CALL DPWRST('XXX','BUG ')
11177      ENDIF
11178C
11179      IDIGT=IDIGI+IDIGD
11180      IF(IDIGT.LE.0)GOTO3900
11181      VALCON=SUMI+SUMD
11182      IVALCO=INT(VALCON+0.00001)
11183      IF(SIGN.LT.0.0)VALCON=-VALCON
11184      IF(SIGN.LT.0.0)IVALCO=-IVALCO
11185      IF(AMIN.LE.VALCON.AND.VALCON.LE.AMAX)GOTO3000
11186      GOTO3900
11187C
11188 3900 CONTINUE
11189      IF(IERROR.EQ.'YES')ITYPE2='WORD'
11190 3000 CONTINUE
11191      GOTO9000
11192C
11193 9000 CONTINUE
11194C
11195      ISTEPN='8'
11196      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11197C
11198      IF(IERROR.EQ.'YES')IVALID='NO'
11199      IF(IERROR.EQ.'NO')IVALID='YES'
11200C
11201C               ****************
11202C               **  STEP 90-- **
11203C               **  EXIT.     **
11204C               ****************
11205C
11206      IF(IBUGA3.EQ.'ON')THEN
11207        WRITE(ICOUT,999)
11208        CALL DPWRST('XXX','BUG ')
11209        WRITE(ICOUT,9001)
11210 9001   FORMAT('***** AT THE END       OF DPCOHI--')
11211        CALL DPWRST('XXX','BUG ')
11212        WRITE(ICOUT,9002)VALCON,IVALCO
11213 9002   FORMAT('VALCON,IVALCO = ',G15.7,I8)
11214        CALL DPWRST('XXX','BUG ')
11215        WRITE(ICOUT,9005)IVALID,IERROR
11216 9005   FORMAT('IVALID,IERROR = ',A4,2X,A4)
11217        CALL DPWRST('XXX','BUG ')
11218      ENDIF
11219C
11220      RETURN
11221      END
11222      SUBROUTINE DPCOIH(IVAL,IHOUT,NOUT,IVALID,IBUGA3,ISUBRO,IERROR)
11223C
11224C     PURPOSE--CONVERT AN INTEGER VARIABLE
11225C              TO A 1-CHARACTER-PER-WORD HOLLARITH STRING.
11226C
11227C     ORIGINAL VERSION--JANUARY  1979.
11228C     UPDATED         --MAY      1986.
11229C
11230C---------------------------------------------------------------------
11231C
11232      CHARACTER*4 IHOUT
11233      CHARACTER*4 IVALID
11234      CHARACTER*4 IBUGA3
11235      CHARACTER*4 ISUBRO
11236      CHARACTER*4 IERROR
11237C
11238      CHARACTER*4 ISIGN
11239      CHARACTER*4 IHDIG
11240C
11241      DIMENSION IHOUT(*)
11242C
11243C-----COMMON VARIABLES (GENERAL)-----------------------------------------------
11244C
11245      INCLUDE 'DPCOP2.INC'
11246C
11247C-----START POINT-----------------------------------------------------
11248C
11249C     MAXDIG IS THE MAXIMUM NUMBER OF DIGITS
11250C     FOR AN INTEGER VARIABLE.
11251C     THIS WILL VARY FROM ONE COMPUTER TO THE NEXT
11252C     DEPENDING ON THE NUMBER OF BITS FOR A WORD.
11253C     THE FOLLOWING DEFINED VALUE (= 10)
11254C     HAS BEEN SET FOR THE VAX 11/780.
11255C
11256CCCCC MAXDIG=11
11257      MAXDIG=9
11258      NUMDIG=(-999)
11259C
11260      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'COIH')GOTO90
11261      WRITE(ICOUT,999)
11262  999 FORMAT(1X)
11263      CALL DPWRST('XXX','BUG ')
11264      WRITE(ICOUT,51)
11265   51 FORMAT('***** AT THE BEGINNING OF DPCOIH--')
11266      CALL DPWRST('XXX','BUG ')
11267      WRITE(ICOUT,52)IBUGA3,ISUBRO,IERROR
11268   52 FORMAT('IBUGA3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
11269      CALL DPWRST('XXX','BUG ')
11270      WRITE(ICOUT,53)IVAL
11271   53 FORMAT('IVAL = ',I11)
11272      CALL DPWRST('XXX','BUG ')
11273      WRITE(ICOUT,54)NUMDIG
11274   54 FORMAT('NUMDIG = ',I8)
11275      CALL DPWRST('XXX','BUG ')
11276   90 CONTINUE
11277C
11278C               **********************************
11279C               **  STEP 1--                    **
11280C               **  INITIALIZE SOME VARIABLES.  **
11281C               **********************************
11282C
11283      IERROR='NO'
11284      IVALID='YES'
11285      IVAL2=IVAL
11286C
11287C               ***********************
11288C               **  STEP 2--         **
11289C               **  DETERMINE SIGN.  **
11290C               ***********************
11291C
11292      ISIGN='+'
11293      IF(IVAL2.LT.0)ISIGN='-'
11294      IVAL2=IABS(IVAL2)
11295C
11296C               ***********************************
11297C               **  STEP 3--                     **
11298C               **  DETERMINE NUMBER OF DIGITS.  **
11299C               ***********************************
11300C
11301      IMIN=1
11302      IMAX=MAXDIG
11303      DO300I=IMIN,IMAX
11304      IREV=IMAX-I+IMIN
11305      IDIV=INT(10.0**(IREV-1) + 0.01)
11306      IDIG=IVAL2/IDIV
11307      IF(IDIG.NE.0)GOTO350
11308  300 CONTINUE
11309      NUMDIG=1
11310      GOTO390
11311  350 CONTINUE
11312      NUMDIG=IREV
11313  390 CONTINUE
11314C
11315C               ***************************************
11316C               **  STEP 4--                         **
11317C               **  IF NEGATIVE,                     **
11318C               **  INSERT SIGN INTO OUTPUT VECTOR.  **
11319C               ***************************************
11320C
11321      J=0
11322      IF(ISIGN.EQ.'-')J=J+1
11323      IF(ISIGN.EQ.'-')IHOUT(J)='-'
11324C
11325C               **************************
11326C               **  STEP 5--            **
11327C               **  INSERT DIGITS INTO  **
11328C               **  OUTPUT VECTOR.      **
11329C               **************************
11330C
11331      IMIN=1
11332      IMAX=NUMDIG
11333      DO500I=IMIN,IMAX
11334      IREV=IMAX-I+IMIN
11335      IDIV=INT(10.0**(IREV-1) + 0.01)
11336      IDIG=IVAL2/IDIV
11337C
11338      IF(IDIG.EQ.0)GOTO510
11339      IF(IDIG.EQ.1)GOTO511
11340      IF(IDIG.EQ.2)GOTO512
11341      IF(IDIG.EQ.3)GOTO513
11342      IF(IDIG.EQ.4)GOTO514
11343      IF(IDIG.EQ.5)GOTO515
11344      IF(IDIG.EQ.6)GOTO516
11345      IF(IDIG.EQ.7)GOTO517
11346      IF(IDIG.EQ.8)GOTO518
11347      IF(IDIG.EQ.9)GOTO519
11348  510 CONTINUE
11349      IHDIG='0'
11350      GOTO529
11351  511 CONTINUE
11352      IHDIG='1'
11353      GOTO529
11354  512 CONTINUE
11355      IHDIG='2'
11356      GOTO529
11357  513 CONTINUE
11358      IHDIG='3'
11359      GOTO529
11360  514 CONTINUE
11361      IHDIG='4'
11362      GOTO529
11363  515 CONTINUE
11364      IHDIG='5'
11365      GOTO529
11366  516 CONTINUE
11367      IHDIG='6'
11368      GOTO529
11369  517 CONTINUE
11370      IHDIG='7'
11371      GOTO529
11372  518 CONTINUE
11373      IHDIG='8'
11374      GOTO529
11375  519 CONTINUE
11376      IHDIG='9'
11377      GOTO529
11378  529 CONTINUE
11379C
11380      J=J+1
11381      IHOUT(J)=IHDIG
11382      IVAL2=IVAL2-IDIG*IDIV
11383  500 CONTINUE
11384      NOUT=J
11385C
11386C               ****************
11387C               **  STEP 6--  **
11388C               **  EXIT.     **
11389C               ****************
11390C
11391      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'COIH')GOTO9090
11392      WRITE(ICOUT,9011)
11393 9011 FORMAT('***** AT THE END       OF DPCOIH--')
11394      CALL DPWRST('XXX','BUG ')
11395      WRITE(ICOUT,9012)IBUGA3,ISUBRO,IERROR
11396 9012 FORMAT('IBUGA3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
11397      CALL DPWRST('XXX','BUG ')
11398      WRITE(ICOUT,9013)IVAL
11399 9013 FORMAT('IVAL = ',I11)
11400      CALL DPWRST('XXX','BUG ')
11401      WRITE(ICOUT,9014)NOUT
11402 9014 FORMAT('NOUT = ',I11)
11403      CALL DPWRST('XXX','BUG ')
11404      WRITE(ICOUT,9015)(IHOUT(I),I=1,NOUT)
11405 9015 FORMAT('IHOUT(.) = ',80A1)
11406      CALL DPWRST('XXX','BUG ')
11407 9090 CONTINUE
11408C
11409      RETURN
11410      END
11411      SUBROUTINE DPCOIP(XP,YP,XC,YC,SLOPE,ABSSLO,SLOEPS,
11412     1XHORIZ,AUPPER,ALOWER,NHORP,IPHORI,ICHORI,
11413     1ISTART,ICASHO,ICASIN,
11414     1XMIN,XMAX,
11415     1XTEMP2,YTEMP2,ITHORI,
11416     1IBUGU2,ISUBRO,IERROR)
11417C
11418C     PURPOSE--GIVEN THAT THE DATA LINE (XP,YP) TO (XC,YC)
11419C              IS SUCH THAT (XP,YP) IS TO THE
11420C              IMMEDIATE LEFT OF THE ISTART-TH ELEMENT
11421C              OF THE HORIZON TABLE,
11422C              DETERMINE THE INTERSECTION POINT
11423C              (XTEMP2,YTEMP2) WHERE THE DATA LINE
11424C              INTERSECTS THE HORIZON LINE.
11425C     ORIGINAL VERSION--SEPTEMBER 1988
11426C
11427C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
11428C
11429      CHARACTER*4 ICASHO
11430      CHARACTER*4 ICASIN
11431C
11432      CHARACTER*4 IBUGU2
11433      CHARACTER*4 ISUBRO
11434      CHARACTER*4 IERROR
11435C
11436      CHARACTER*4 ISUBN1
11437      CHARACTER*4 ISUBN2
11438CCCCC CHARACTER*4 ISTEPN
11439C
11440C---------------------------------------------------------------------
11441C
11442      DIMENSION XHORIZ(*)
11443      DIMENSION AUPPER(*)
11444      DIMENSION ALOWER(*)
11445C
11446C-----COMMON VARIABLES (GENERAL)--------------------------------------
11447C
11448      INCLUDE 'DPCOP2.INC'
11449C
11450C-----START POINT-----------------------------------------------------
11451C
11452      ISUBN1='DPCO'
11453      ISUBN2='IP  '
11454C
11455      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'COIP')GOTO50
11456      GOTO90
11457   50 CONTINUE
11458      WRITE(ICOUT,999)
11459  999 FORMAT(1X)
11460      CALL DPWRST('XXX','BUG ')
11461      WRITE(ICOUT,51)
11462   51 FORMAT('***** AT THE BEGINNING OF DPCOIP--')
11463      CALL DPWRST('XXX','BUG ')
11464      WRITE(ICOUT,52)IBUGU2,ISUBRO,IERROR
11465   52 FORMAT('IBUGU2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
11466      CALL DPWRST('XXX','BUG ')
11467      WRITE(ICOUT,53)XP,YP,XC,YC
11468   53 FORMAT('XP,YP,XC,YC = ',4E15.7)
11469      CALL DPWRST('XXX','BUG ')
11470      WRITE(ICOUT,54)SLOPE,ABSSLO,SLOEPS
11471   54 FORMAT('SLOPE,ABSSLO,SLOEPS = ',3E15.7)
11472      CALL DPWRST('XXX','BUG ')
11473      WRITE(ICOUT,61)NHORP,IPHORI,ICHORI
11474   61 FORMAT('NHORP,IPHORI,ICHORI = ',3I8)
11475      CALL DPWRST('XXX','BUG ')
11476      DO63I=IPHORI,ICHORI
11477      WRITE(ICOUT,64)I,XHORIZ(I),AUPPER(I),ALOWER(I)
11478   64 FORMAT('I,XHORIZ(I),AUPPER(I),ALOWER(I) = ',I8,3E15.7)
11479      CALL DPWRST('XXX','BUG ')
11480   63 CONTINUE
11481      DO65I=IPHORI,ICHORI
11482      WRITE(ICOUT,66)I,AUPPER(I),ALOWER(I),XHORIZ(I)
11483   66 FORMAT('I,AUPPER(I),ALOWER(I),XHORIZ(I) = ',I8,3E15.7)
11484      CALL DPWRST('XXX','BUG ')
11485   65 CONTINUE
11486      WRITE(ICOUT,67)ISTART,ICASHO,ICASIN
11487   67 FORMAT('ISTART,ICASHO,ICASIN = ',I8,2X,A4,2X,A4)
11488      CALL DPWRST('XXX','BUG ')
11489      WRITE(ICOUT,68)XMIN,XMAX
11490   68 FORMAT('XMIN,XMAX = ',2E15.7)
11491      CALL DPWRST('XXX','BUG ')
11492      WRITE(ICOUT,72)ITHORI
11493   72 FORMAT('ITHORI = ',I8)
11494      CALL DPWRST('XXX','BUG ')
11495   90 CONTINUE
11496C
11497      I=ISTART-1
11498      IF(I.LE.0)I=1
11499      XTEMPO=XHORIZ(I)
11500      YTEMPO=YP+(XTEMPO-XP)*SLOPE
11501      YCUTOL=ALOWER(I)
11502      IF(ICASHO.EQ.'UPPE')YCUTOL=AUPPER(I)
11503C
11504      DO1100I=ISTART,ICHORI
11505      I2=I
11506      XTEMP=XHORIZ(I)
11507      YTEMP=YP+(XTEMP-XP)*SLOPE
11508      YCUT=ALOWER(I)
11509      IF(ICASHO.EQ.'UPPE')YCUT=AUPPER(I)
11510      IF(ICASIN.EQ.'LE'.AND.YTEMP.LE.YCUT)GOTO1150
11511      IF(ICASIN.EQ.'GE'.AND.YTEMP.GE.YCUT)GOTO1150
11512      XTEMPO=XTEMP
11513      YTEMPO=YTEMP
11514      YCUTOL=YCUT
11515 1100 CONTINUE
11516C
11517      XTEMP2=XC
11518      YTEMP2=YC
11519      ITHORI=ICHORI
11520      GOTO1190
11521C
11522 1150 CONTINUE
11523      IF(ABSSLO.LE.SLOEPS)GOTO1160
11524      GOTO1170
11525C
11526 1160 CONTINUE
11527      XTEMP2=XTEMP
11528      YTEMP2=YCUT
11529      ITHORI=I2
11530      GOTO1190
11531C
11532 1170 CONTINUE
11533      CALL DPCOI2(XTEMPO,YTEMPO,YCUTOL,XTEMP,YTEMP,YCUT,
11534     1XTEMP2,YTEMP2,IBUGU2,ISUBRO,IERROR)
11535      CALL HORIND(XTEMP2,XMIN,XMAX,1,NHORP,ITHORI,IBUGU2,ISUBRO,IERROR)
11536      GOTO1190
11537C
11538 1190 CONTINUE
11539      IF(ICASHO.EQ.'LOWE'.AND.YCUT.LT.ALOWER(ITHORI))ALOWER(ITHORI)=YCUT
11540      IF(ICASHO.EQ.'UPPE'.AND.YCUT.GT.AUPPER(ITHORI))AUPPER(ITHORI)=YCUT
11541C
11542C               *****************
11543C               **  STEP 90--  **
11544C               **  EXIT.      **
11545C               *****************
11546C
11547      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'COIP')GOTO9010
11548      GOTO9090
11549 9010 CONTINUE
11550      WRITE(ICOUT,999)
11551      CALL DPWRST('XXX','BUG ')
11552      WRITE(ICOUT,9011)
11553 9011 FORMAT('***** AT THE END        OF DPCOIP--')
11554      CALL DPWRST('XXX','BUG ')
11555      WRITE(ICOUT,9012)IBUGU2,ISUBRO,IERROR
11556 9012 FORMAT('IBUGU2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
11557      CALL DPWRST('XXX','BUG ')
11558      WRITE(ICOUT,9013)XP,YP,XC,YC
11559 9013 FORMAT('XP,YP,XC,YC = ',4E15.7)
11560      CALL DPWRST('XXX','BUG ')
11561      WRITE(ICOUT,9014)SLOPE,ABSSLO,SLOEPS
11562 9014 FORMAT('SLOPE,ABSSLO,SLOEPS = ',3E15.7)
11563      CALL DPWRST('XXX','BUG ')
11564      WRITE(ICOUT,9021)NHORP,IPHORI,ICHORI
11565 9021 FORMAT('NHORP,IPHORI,ICHORI = ',3I8)
11566      CALL DPWRST('XXX','BUG ')
11567      DO9023I=IPHORI,ICHORI
11568      WRITE(ICOUT,9024)I,XHORIZ(I),AUPPER(I),ALOWER(I)
11569 9024 FORMAT('I,XHORIZ(I),AUPPER(I),ALOWER(I) = ',I8,3E15.7)
11570      CALL DPWRST('XXX','BUG ')
11571 9023 CONTINUE
11572      WRITE(ICOUT,9027)ISTART,ICASHO,ICASIN
11573 9027 FORMAT('ISTART,ICASHO,ICASIN = ',I8,2X,A4,2X,A4)
11574      CALL DPWRST('XXX','BUG ')
11575      WRITE(ICOUT,9028)XMIN,XMAX
11576 9028 FORMAT('XMIN,XMAX = ',2E15.7)
11577      CALL DPWRST('XXX','BUG ')
11578      WRITE(ICOUT,9031)XTEMP2,YTEMP2
11579 9031 FORMAT('XTEMP2,YTEMP2 = ',2E15.7)
11580      CALL DPWRST('XXX','BUG ')
11581      WRITE(ICOUT,9032)ITHORI
11582 9032 FORMAT('ITHORI = ',I8)
11583      CALL DPWRST('XXX','BUG ')
11584 9090 CONTINUE
11585C
11586      RETURN
11587      END
11588      SUBROUTINE DPCOI2(X1,Y11,Y12,X2,Y21,Y22,
11589     1X3,Y3,IBUGU2,ISUBRO,IERROR)
11590C
11591C     PURPOSE--COMPUTE THE INTERSECTION POINT (X3,Y3) OF 2 LINES
11592C              FOR THE SPECIAL CASE WHEN ONLY HAVE
11593C              2 DISTINCT X VALUES  (RATHER THAN 4)
11594C              FOR THE 4 Y VALUES.
11595C              THUS ONE X VALUE HAS 2 Y VALUES,
11596C              AND THE OTHER X VALUE HAS 2 Y VALUES.
11597C     ASSUMPTION--THE 2 LINES DO IN FACT INTERSECT.
11598C     METHOD--FOR THIS SPECIAL CASE WHEN HAVE A COMMON
11599C             X VALUE FOR THE LEFT DATA AND ANOTHER COMMON
11600C             X VALUE FOR THE RIGHT DATA, THEN THE
11601C             SOLUTION FOR THE INTERSECTION POINT
11602C             IS GEOMETRICALLY QUITE SIMPLE--THE X VALUE IS
11603C             A CERTAIN PROPORTION P ACROSS AND
11604C             THE Y VALUE IS THE SAME PROPORTION P
11605C             BETWEEN THE Y VALUES ON A GIVEN LINE.
11606C             THAT PROPORTION IS
11607C                P = DEL1 /(DEL1 + DEL2)
11608C             WHERE DEL1 = DIFFERENCE OF Y VALUES ON LEFT,
11609C             AND   DEL2 = DIFFERENCE OF Y VALUES ON RIGHT.
11610C     ORIGINAL VERSION--SEPTEMBER 1988
11611C
11612C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
11613C
11614      CHARACTER*4 IBUGU2
11615      CHARACTER*4 ISUBRO
11616      CHARACTER*4 IERROR
11617C
11618      CHARACTER*4 ISUBN1
11619      CHARACTER*4 ISUBN2
11620CCCCC CHARACTER*4 ISTEPN
11621C
11622C-----COMMON VARIABLES (GENERAL)--------------------------------------
11623C
11624      INCLUDE 'DPCOP2.INC'
11625C
11626C-----START POINT-----------------------------------------------------
11627C
11628      ISUBN1='DPCO'
11629      ISUBN2='I2  '
11630C
11631      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'COI2')GOTO50
11632      GOTO90
11633   50 CONTINUE
11634      WRITE(ICOUT,999)
11635  999 FORMAT(1X)
11636      CALL DPWRST('XXX','BUG ')
11637      WRITE(ICOUT,51)
11638   51 FORMAT('***** AT THE BEGINNING OF DPCOI2--')
11639      CALL DPWRST('XXX','BUG ')
11640      WRITE(ICOUT,52)IBUGU2,ISUBRO,IERROR
11641   52 FORMAT('IBUGU2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
11642      CALL DPWRST('XXX','BUG ')
11643      WRITE(ICOUT,53)X1,Y11,Y12
11644   53 FORMAT('X1,Y11,Y12 = ',3E15.7)
11645      CALL DPWRST('XXX','BUG ')
11646      WRITE(ICOUT,54)X2,Y21,Y22
11647   54 FORMAT('X2,Y21,Y22 = ',3E15.7)
11648      CALL DPWRST('XXX','BUG ')
11649   90 CONTINUE
11650C
11651C               **************************************************
11652C               **  STEP 10--                                   **
11653C               **  COMPUTE THE INTERSECTION POINT              **
11654C               **************************************************
11655C
11656      YDEL1=Y12-Y11
11657      YDEL2=Y22-Y21
11658      YDEL2=(-YDEL2)
11659      YDEL12=YDEL1+YDEL2
11660      P=YDEL1/YDEL12
11661      X3=X1+P*(X2-X1)
11662      Y3=Y11+P*(Y21-Y11)
11663C
11664C               *****************
11665C               **  STEP 90--  **
11666C               **  EXIT       **
11667C               *****************
11668C
11669      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'COI2')GOTO9010
11670      GOTO9090
11671 9010 CONTINUE
11672      WRITE(ICOUT,999)
11673      CALL DPWRST('XXX','BUG ')
11674      WRITE(ICOUT,9011)
11675 9011 FORMAT('***** AT THE END       OF DPCOI2--')
11676      CALL DPWRST('XXX','BUG ')
11677      WRITE(ICOUT,9012)IBUGU2,ISUBRO,IERROR
11678 9012 FORMAT('IBUGU2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
11679      CALL DPWRST('XXX','BUG ')
11680      WRITE(ICOUT,9013)X1,Y11,Y12
11681 9013 FORMAT('X1,Y11,Y12 = ',3E15.7)
11682      CALL DPWRST('XXX','BUG ')
11683      WRITE(ICOUT,9014)X2,Y21,Y22
11684 9014 FORMAT('X2,Y21,Y22 = ',3E15.7)
11685      CALL DPWRST('XXX','BUG ')
11686      WRITE(ICOUT,9021)YDEL1,YDEL2,YDEL12,P
11687 9021 FORMAT('YDEL1,YDEL2,YDEL12,P = ',4E15.7)
11688      CALL DPWRST('XXX','BUG ')
11689      WRITE(ICOUT,9022)X3,Y3
11690 9022 FORMAT('X3,Y3 = ',2E15.7)
11691      CALL DPWRST('XXX','BUG ')
11692 9090 CONTINUE
11693      RETURN
11694      END
11695      SUBROUTINE DPCOLL(IDEFC1,IDEFC2,IFCOL1,IFCOL2,NUMRCM,
11696     1IFCOLL,IFCOLU,
11697     1IFOUND,IERROR)
11698C
11699C     PURPOSE--DEFINE COLUMN LIMITS
11700C              WHICH WILL DEFINE THE EXTREME
11701C              COLUMNS (WITHIN A FILE) TO BE SCANNED IN CARRYING
11702C              OUT THE READ AND SERIAL READ COMMANDS.
11703C              THE 2 LIMITS ARE CONTAINED IN THE
11704C              2 ARGUMENTS IFCOL1 AND IFCOL2, RESPECTIVELY.
11705C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
11706C                     --IARGT  (A  HOLLERITH VECTOR)
11707C                     --IARG   (AN INTEGER VECTOR)
11708C                     --NUMARG
11709C                     --IDEFC1
11710C                     --IDEFC2
11711C     OUTPUT ARGUMENTS--IFCOL1 (AN INTEGER VARIABLE
11712C                       CONTAINING THE MINIMUM COLUMN
11713C                       IN THE DATA FILE TO BE SCANNED
11714C                       DURING A    READ    OR A    SERIAL READ.
11715C                     --IFCOL2 (AN INTEGER VARIABLE
11716C                       CONTAINING THE MAXIMUM COLUMN
11717C                       IN THE DATA FILE TO BE SCANNED
11718C                       DURING A    READ    OR A    SERIAL READ.
11719C                     --IFOUND ('YES' OR 'NO' )
11720C                     --IERROR ('YES' OR 'NO' )
11721C     WRITTEN BY--JAMES J. FILLIBEN
11722C                 STATISTICAL ENGINEERING DIVISION
11723C                 INFORMATION TECHNOLOGY LABORATORY
11724C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
11725C                 GAITHERSBURG, MD 20899-8980
11726C                 PHONE--301-975-2855
11727C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
11728C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
11729C     LANGUAGE--ANSI FORTRAN (1977)
11730C     VERSION NUMBER--82/7
11731C     ORIGINAL VERSION--NOVEMBER  1980.
11732C     UPDATED         --MAY       1982.
11733C     UPDATED         --FEBRUARY  2003. TEST AGAINST MAXIMUM RECORD
11734C                                       LENGTH FOR DATA FILE (NUMRCM)
11735C     UPDATED         --JANUARY   2004. IFCOLL, IFCOLU FOR ARRAYS OF
11736C                                       COLUMN LIMITS
11737C
11738C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
11739C
11740      CHARACTER*4 IFOUND
11741      CHARACTER*4 IERROR
11742C
11743      CHARACTER*4 IHWUSE
11744      CHARACTER*4 IH11
11745      CHARACTER*4 IH12
11746      CHARACTER*4 MESSAG
11747      CHARACTER*4 ISUBN1
11748      CHARACTER*4 ISUBN2
11749C
11750      INTEGER IFCOL3(50)
11751      INTEGER AINDEX(50)
11752C
11753C---------------------------------------------------------------------
11754C
11755      INCLUDE 'DPCOPA.INC'
11756      INCLUDE 'DPCODA.INC'
11757      INCLUDE 'DPCOHK.INC'
11758      INCLUDE 'DPCOM2.INC'
11759C
11760      DIMENSION IFCOLL(*)
11761      DIMENSION IFCOLU(*)
11762C
11763C---------------------------------------------------------------------
11764C
11765      INCLUDE 'DPCOP2.INC'
11766C
11767C-----START POINT-----------------------------------------------------
11768C
11769      IFOUND='NO'
11770      IERROR='NO'
11771C
11772      IHOLD1=0
11773      IHOLD2=0
11774C
11775C               ****************************************************
11776C               **  TREAT THE CASE WHEN                           **
11777C               **  THE COLUMN LIMITS ARE TO BE CHANGED           **
11778C               ****************************************************
11779C
11780      IF(NUMARG.LE.0)GOTO9000
11781      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'LIMI')GOTO1110
11782      GOTO1190
11783C
11784 1110 CONTINUE
11785      IF(NUMARG.EQ.1)GOTO1120
11786      IF(IHARG(NUMARG).EQ.'ON')GOTO1120
11787      IF(IHARG(NUMARG).EQ.'OFF')GOTO1120
11788      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1120
11789      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1120
11790      IF(IHARG(NUMARG).EQ.'?')GOTO8100
11791      IF(NUMARG.GE.3.AND.IARGT(2).EQ.'NUMB'.AND.
11792     1IARGT(3).EQ.'NUMB')GOTO1130
11793      IF(NUMARG.GE.3.AND.IARGT(2).EQ.'WORD'.AND.
11794     1IARGT(3).EQ.'WORD')GOTO3140
11795      GOTO1190
11796C
11797 1120 CONTINUE
11798      I1=IDEFC1
11799      I2=IDEFC2
11800      IF(I1.LE.I2)IHOLD1=I1
11801      IF(I1.LE.I2)IHOLD2=I2
11802      IF(I1.GT.I2)IHOLD1=I2
11803      IF(I1.GT.I2)IHOLD2=I1
11804      DO1122I=1,50
11805        IFCOLL(I)=0
11806        IFCOLU(I)=0
11807 1122 CONTINUE
11808      GOTO1180
11809C
11810 1130 CONTINUE
11811      I1=IARG(2)
11812      I2=IARG(3)
11813      IF(I1.LE.I2)IHOLD1=I1
11814      IF(I1.LE.I2)IHOLD2=I2
11815      IF(I1.GT.I2)IHOLD1=I2
11816      IF(I1.GT.I2)IHOLD2=I1
11817      GOTO1180
11818C
11819 1180 CONTINUE
11820      IFOUND='YES'
11821      IFCOL1=IHOLD1
11822      IFCOL2=IHOLD2
11823C
11824CCCCC FEBRAURY 2003: CHECK AGAINST MAXIMUM RECORD LENGTH
11825C
11826      IF(IFCOL2.GT.NUMRCM)IFCOL2=NUMRCM
11827C
11828      IF(IFEEDB.EQ.'ON')THEN
11829        WRITE(ICOUT,999)
11830  999   FORMAT(1X)
11831        CALL DPWRST('XXX','BUG ')
11832        WRITE(ICOUT,1185)
11833 1185   FORMAT('THE COLUMN LIMITS (FOR READ AND SERIAL READ)')
11834        CALL DPWRST('XXX','BUG ')
11835        WRITE(ICOUT,1186)IFCOL1,IFCOL2
11836 1186   FORMAT('HAVE JUST BEEN SET TO ',I8,I8)
11837        CALL DPWRST('XXX','BUG ')
11838      ENDIF
11839      GOTO9000
11840C
11841 1190 CONTINUE
11842C
11843C               ****************************************************
11844C               **  TREAT THE CASE WHEN                           **
11845C               **  THE COLUMN MINIMUM IS TO BE CHANGED           **
11846C               ****************************************************
11847C
11848      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MINI')GOTO1210
11849      GOTO1290
11850C
11851 1210 CONTINUE
11852      IF(NUMARG.EQ.1)GOTO1220
11853      IF(IHARG(NUMARG).EQ.'ON')GOTO1220
11854      IF(IHARG(NUMARG).EQ.'OFF')GOTO1220
11855      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1220
11856      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1220
11857      IF(NUMARG.GE.2.AND.IARGT(2).EQ.'NUMB')GOTO1230
11858      GOTO1290
11859C
11860 1220 CONTINUE
11861      IHOLD1=IDEFC1
11862      DO1222I=1,50
11863        IFCOLL(I)=0
11864        IFCOLU(I)=0
11865 1222 CONTINUE
11866      GOTO1280
11867C
11868 1230 CONTINUE
11869      IHOLD1=IARG(2)
11870      GOTO1280
11871C
11872 1280 CONTINUE
11873      IFOUND='YES'
11874      IFCOL1=IHOLD1
11875C
11876      IF(IFEEDB.EQ.'OFF')GOTO1289
11877      WRITE(ICOUT,999)
11878      CALL DPWRST('XXX','BUG ')
11879      WRITE(ICOUT,1285)
11880 1285 FORMAT('THE COLUMN MINIMUM (FOR READ AND SERIAL READ)')
11881      CALL DPWRST('XXX','BUG ')
11882      WRITE(ICOUT,1286)IFCOL1
11883 1286 FORMAT('HAS JUST BEEN SET TO ',I8)
11884      CALL DPWRST('XXX','BUG ')
11885 1289 CONTINUE
11886      GOTO9000
11887C
11888 1290 CONTINUE
11889C
11890C               ****************************************************
11891C               **  TREAT THE CASE WHEN                           **
11892C               **  THE COLUMN MAXIMUM IS TO BE CHANGED           **
11893C               ****************************************************
11894C
11895      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MAXI')GOTO1310
11896      GOTO1390
11897C
11898 1310 CONTINUE
11899      IF(NUMARG.EQ.1)GOTO1320
11900      IF(IHARG(NUMARG).EQ.'ON')GOTO1320
11901      IF(IHARG(NUMARG).EQ.'OFF')GOTO1320
11902      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1320
11903      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1320
11904      IF(NUMARG.GE.2.AND.IARGT(2).EQ.'NUMB')GOTO1330
11905      GOTO1390
11906C
11907 1320 CONTINUE
11908      IHOLD2=IDEFC2
11909      DO1322I=1,50
11910        IFCOLL(I)=0
11911        IFCOLU(I)=0
11912 1322 CONTINUE
11913      GOTO1380
11914C
11915 1330 CONTINUE
11916      IHOLD2=IARG(2)
11917      GOTO1380
11918C
11919 1380 CONTINUE
11920      IFOUND='YES'
11921      IFCOL2=IHOLD2
11922C
11923CCCCC FEBRAURY 2003: CHECK AGAINST MAXIMUM RECORD LENGTH
11924C
11925      IF(IFCOL2.GT.NUMRCM)IFCOL2=NUMRCM
11926C
11927      IF(IFEEDB.EQ.'OFF')GOTO1389
11928      WRITE(ICOUT,999)
11929      CALL DPWRST('XXX','BUG ')
11930      WRITE(ICOUT,1385)
11931 1385 FORMAT('THE COLUMN MAXIMUM (FOR READ AND SERIAL READ)')
11932      CALL DPWRST('XXX','BUG ')
11933      WRITE(ICOUT,1386)IFCOL1
11934 1386 FORMAT('HAS JUST BEEN SET TO ',I8)
11935      CALL DPWRST('XXX','BUG ')
11936 1389 CONTINUE
11937      GOTO9000
11938C
11939 1390 CONTINUE
11940C
11941C               ********************************************
11942C               **  STEP 81--                             **
11943C               **  TREAT THE    ?    CASE--              **
11944C               **  DUMP OUT CURRENT AND DEFAULT VALUES.  **
11945C               ********************************************
11946C
11947 8100 CONTINUE
11948      IFOUND='YES'
11949      WRITE(ICOUT,999)
11950      CALL DPWRST('XXX','BUG ')
11951      WRITE(ICOUT,8111)IFCOL1,IFCOL2
11952 8111 FORMAT('THE CURRENT COLUMN LIMITS ARE ',I8,I8)
11953      CALL DPWRST('XXX','BUG ')
11954      WRITE(ICOUT,8112)IDEFC1,IDEFC2
11955 8112 FORMAT('THE DEFAULT COLUMN LIMITS ARE ',I8,I8)
11956      CALL DPWRST('XXX','BUG ')
11957      GOTO9000
11958C
11959 3140 CONTINUE
11960C
11961      IH11=IHARG(2)
11962      IH12=IHARG2(2)
11963      IHWUSE='V'
11964      MESSAG='YES'
11965      CALL CHECKN(IH11,IH12,IHWUSE,
11966     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
11967     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
11968      IF(IERROR.EQ.'NO')THEN
11969        ICOL1=IVALUE(ILOCV)
11970        N1=IN(ILOCV)
11971      ELSE
11972        GOTO9000
11973      ENDIF
11974C
11975      IH11=IHARG(3)
11976      IH12=IHARG2(3)
11977      IHWUSE='V'
11978      MESSAG='YES'
11979      CALL CHECKN(IH11,IH12,IHWUSE,
11980     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
11981     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
11982      IF(IERROR.EQ.'NO')THEN
11983        ICOL2=IVALUE(ILOCV)
11984        N2=IN(ILOCV)
11985      ELSE
11986        GOTO9000
11987      ENDIF
11988C
11989      IF(N1.NE.N2)THEN
11990        WRITE(ICOUT,999)
11991        CALL DPWRST('XXX','BUG ')
11992        WRITE(ICOUT,3411)
11993 3411   FORMAT('***** ERROR: FOR THE VECTOR FORM OF THE COLUMN LIMITS')
11994        CALL DPWRST('XXX','BUG ')
11995        WRITE(ICOUT,3413)
11996 3413   FORMAT('      COMMAND, THE NUMBER OF COLUMNS IS NOT EQUAL.')
11997        CALL DPWRST('XXX','BUG ')
11998        WRITE(ICOUT,3415)IHARG(2),IHARG2(2),N1
11999 3415   FORMAT('      VARIABLE ',A4,A4,' HAS ',I8,' ELEMENTS.')
12000        CALL DPWRST('XXX','BUG ')
12001        WRITE(ICOUT,3415)IHARG(3),IHARG2(3),N2
12002        CALL DPWRST('XXX','BUG ')
12003        IERROR='YES'
12004        GOTO9000
12005      ENDIF
12006      J=0
12007      IMAX=MIN(50,N1)
12008      DO3160I=1,50
12009        J=J+1
12010        IFCOLL(J)=0
12011        IFCOLU(J)=0
12012        IF(I.GT.IMAX)GOTO3160
12013C
12014        IJ=MAXN*(ICOL1-1)+I
12015        IF(ICOL1.LE.MAXCOL)IFCOLL(J)=INT(V(IJ) + 0.5)
12016        IF(ICOL1.EQ.MAXCP1)IFCOLL(J)=INT(PRED(I) + 0.5)
12017        IF(ICOL1.EQ.MAXCP2)IFCOLL(J)=INT(RES(I) + 0.5)
12018        IF(ICOL1.EQ.MAXCP3)IFCOLL(J)=INT(YPLOT(I) + 0.5)
12019        IF(ICOL1.EQ.MAXCP4)IFCOLL(J)=INT(XPLOT(I) + 0.5)
12020        IF(ICOL1.EQ.MAXCP5)IFCOLL(J)=INT(X2PLOT(I) + 0.5)
12021        IF(ICOL1.EQ.MAXCP6)IFCOLL(J)=INT(TAGPLO(I) + 0.5)
12022C
12023        IJ=MAXN*(ICOL2-1)+I
12024        IF(ICOL2.LE.MAXCOL)IFCOLU(J)=INT(V(IJ) + 0.5)
12025        IF(ICOL2.EQ.MAXCP1)IFCOLU(J)=INT(PRED(I) + 0.5)
12026        IF(ICOL2.EQ.MAXCP2)IFCOLU(J)=INT(RES(I) + 0.5)
12027        IF(ICOL2.EQ.MAXCP3)IFCOLU(J)=INT(YPLOT(I) + 0.5)
12028        IF(ICOL2.EQ.MAXCP4)IFCOLU(J)=INT(XPLOT(I) + 0.5)
12029        IF(ICOL2.EQ.MAXCP5)IFCOLU(J)=INT(X2PLOT(I) + 0.5)
12030        IF(ICOL2.EQ.MAXCP6)IFCOLU(J)=INT(TAGPLO(I) + 0.5)
12031C
12032 3160 CONTINUE
12033C
12034      DO3180I=1,IMAX
12035        IF(IFCOLL(I).GT.IFCOLU(I))THEN
12036          ITEMP=IFCOLL(I)
12037          IFCOLL(I)=IFCOLU(I)
12038          IFCOLU(I)=ITEMP
12039        ENDIF
12040 3180 CONTINUE
12041C
12042C  SORT THE COLUMNS (FROM SMALLEST TO LARGEST VALUE OF IFCOLL)
12043C
12044      CALL SORTII(IFCOLL,IMAX,IFCOL3,AINDEX)
12045      DO3187I=1,IMAX
12046        IFCOLL(I)=IFCOL3(I)
12047 3187 CONTINUE
12048C
12049      DO3188I=1,IMAX
12050        J=AINDEX(I)
12051        IFCOL3(I)=IFCOLU(J)
12052 3188 CONTINUE
12053C
12054      DO3189I=1,IMAX
12055        IFCOLU(I)=IFCOL3(I)
12056 3189 CONTINUE
12057C
12058      IFCOL1=IFCOLL(1)
12059      IFCOL2=IFCOLU(IMAX)
12060C
12061      WRITE(ICOUT,999)
12062      CALL DPWRST('XXX','BUG ')
12063      WRITE(ICOUT,3191)
12064 3191 FORMAT('THE FOLLOWING COLUMN LIMITS HAVE BEEN SET:')
12065      CALL DPWRST('XXX','BUG ')
12066      WRITE(ICOUT,999)
12067      CALL DPWRST('XXX','BUG ')
12068      WRITE(ICOUT,3193)
12069 3193 FORMAT('VARIABLE         LOWER LIMIT      UPPER LIMIT')
12070      CALL DPWRST('XXX','BUG ')
12071      WRITE(ICOUT,3195)
12072 3195 FORMAT('---------------------------------------------')
12073      CALL DPWRST('XXX','BUG ')
12074      DO3199I=1,IMAX
12075        WRITE(ICOUT,3197)I,IFCOLL(I),IFCOLU(I)
12076        CALL DPWRST('XXX','BUG ')
12077 3199 CONTINUE
12078 3197 FORMAT(I8,12X,I8,9X,I8)
12079C
12080      IFOUND='YES'
12081      GOTO9000
12082C
12083C               *****************
12084C               **  STEP 90--  **
12085C               **  EXIT       **
12086C               *****************
12087C
12088 9000 CONTINUE
12089      RETURN
12090      END
12091      SUBROUTINE DPCOLO(IHARG,NUMARG,
12092     1IDEFCO,
12093     1ITEXCO,
12094     1IBUGD2,ISUBRO,IFOUND,IERROR)
12095C
12096C     PURPOSE--DEFINE THE COLOR FOR THE LINES
12097C              IN TEXT AND FIGURES.
12098C              THE COLOR WILL BE PLACED
12099C              IN THE CHARACTER VARIABLE ITEXCO.
12100C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
12101C                     --NUMARG
12102C                     --IDEFCO
12103C     OUTPUT ARGUMENTS--ITEXCO
12104C                     --IBUGD2
12105C                     --IFOUND ('YES' OR 'NO' )
12106C                     --IERROR ('YES' OR 'NO' )
12107C     WRITTEN BY--JAMES J. FILLIBEN
12108C                 STATISTICAL ENGINEERING DIVISION
12109C                 INFORMATION TECHNOLOGY LABORATORY
12110C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
12111C                 GAITHERSBURG, MD 20899-8980
12112C                 PHONE--301-975-2855
12113C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
12114C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
12115C     LANGUAGE--ANSI FORTRAN (1977)
12116C     VERSION NUMBER--82/7
12117C     ORIGINAL VERSION--DECEMBER  1982.
12118C     UPDATED         --OCTOBER   2011. SUPPORT FOR "?"
12119C
12120C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
12121C
12122      CHARACTER*4 IHARG
12123      CHARACTER*4 IDEFCO
12124      CHARACTER*4 ITEXCO
12125      CHARACTER*4 IBUGD2
12126      CHARACTER*4 ISUBRO
12127      CHARACTER*4 IFOUND
12128      CHARACTER*4 IERROR
12129C
12130C---------------------------------------------------------------------
12131C
12132      DIMENSION IHARG(*)
12133C
12134C---------------------------------------------------------------------
12135C
12136      INCLUDE 'DPCOP2.INC'
12137C
12138C-----START POINT-----------------------------------------------------
12139C
12140      IFOUND='NO'
12141      IERROR='NO'
12142C
12143      IF(IBUGD2.EQ.'ON')THEN
12144        WRITE(ICOUT,999)
12145  999   FORMAT(1X)
12146        CALL DPWRST('XXX','BUG ')
12147        WRITE(ICOUT,51)
12148   51   FORMAT('***** AT THE BEGINNING OF DPCOLO--')
12149        CALL DPWRST('XXX','BUG ')
12150        WRITE(ICOUT,53)IDEFCO,NUMARG
12151   53   FORMAT('IDEFCO,NUMARG = ',A4,2X,I8)
12152        CALL DPWRST('XXX','BUG ')
12153        DO55I=1,NUMARG
12154          WRITE(ICOUT,56)I,IHARG(I)
12155   56     FORMAT('I,IHARG(I) = ',I8,2X,A4)
12156          CALL DPWRST('XXX','BUG ')
12157   55   CONTINUE
12158      ENDIF
12159C
12160C     THE FOLLOWING LINES HAVE BEEN COMMENTED OUT (NOV. 1983)
12161C     DUE TO CONFLICTS WITH THE DPDECL SUBROUTINE
12162C     WHICH SPECIFIES WHETHER OR NOT THE TERMINAL
12163C     IS A COLOR DEVICE OR NOT.
12164C
12165CCCCC IF(NUMARG.EQ.0)GOTO1160
12166CCCCC IF(IHARG(NUMARG).EQ.'ON')GOTO1160
12167CCCCC IF(IHARG(NUMARG).EQ.'OFF')GOTO1160
12168      IF(NUMARG.EQ.0)GOTO9000
12169      IF(IHARG(NUMARG).EQ.'ON')GOTO9000
12170      IF(IHARG(NUMARG).EQ.'OFF')GOTO9000
12171      IF(IHARG(NUMARG).EQ.'AUTO' .OR. IHARG(NUMARG).EQ.'DEFA')THEN
12172        ITEXCO=IDEFCO
12173      ELSEIF(IHARG(NUMARG).EQ.'?')THEN
12174        IFOUND='YES'
12175        WRITE(ICOUT,999)
12176        CALL DPWRST('XXX','BUG ')
12177        WRITE(ICOUT,1191)ITEXCO
12178 1191   FORMAT('THE CURRENT COLOR IS ',A4)
12179        CALL DPWRST('XXX','BUG ')
12180        WRITE(ICOUT,1193)IDEFCO
12181 1193   FORMAT('THE DEFAULT COLOR IS ',A4)
12182        CALL DPWRST('XXX','BUG ')
12183        GOTO9000
12184      ELSE
12185        ITEXCO=IHARG(NUMARG)
12186      ENDIF
12187C
12188      IFOUND='YES'
12189      IF(IFEEDB.EQ.'ON')THEN
12190        WRITE(ICOUT,999)
12191        CALL DPWRST('XXX','BUG ')
12192        WRITE(ICOUT,1181)
12193 1181   FORMAT('THE COLOR (FOR LINES IN TEXT AND FIGURES)')
12194        CALL DPWRST('XXX','BUG ')
12195        WRITE(ICOUT,1182)ITEXCO
12196 1182   FORMAT('HAS JUST BEEN SET TO ',A4)
12197        CALL DPWRST('XXX','BUG ')
12198      ENDIF
12199C
12200 9000 CONTINUE
12201      IF(IBUGD2.EQ.'ON')THEN
12202        WRITE(ICOUT,999)
12203        CALL DPWRST('XXX','BUG ')
12204        WRITE(ICOUT,9011)
12205 9011   FORMAT('***** AT THE END       OF DPCOLO--')
12206        CALL DPWRST('XXX','BUG ')
12207        WRITE(ICOUT,9012)IBUGD2,ISUBRO,IFOUND,IERROR
12208 9012   FORMAT('IBUGD2,ISUBRO,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
12209        CALL DPWRST('XXX','BUG ')
12210        WRITE(ICOUT,9013)IDEFCO,ITEXCO
12211 9013   FORMAT('IDEFCO,ITEXCO = ',A4,2X,A4)
12212        CALL DPWRST('XXX','BUG ')
12213      ENDIF
12214C
12215      RETURN
12216      END
12217      SUBROUTINE DPCOMB(Y,X,N,MINSIZ,
12218     1Y2,XLOW,XUPP,N2,IBUGA3,IERROR)
12219C
12220C     PURPOSE--FOR THE CHI-SQUARE GOODNESS OF FIT, IT IS RECOMMENDED
12221C              THAT CLASSES WITH LESS THAN 5 OBSERVATIONS BE COMBINED
12222C              IN ORDER FOR THE CHI-SQUARE GOODNESS OF FIT TES TO BE
12223C              VALID.  THE COMMAND IS:
12224C
12225C                 LET Y2 XLOW XHIGH = COMBINE FREQUENCY TABLE YCOUNT XMID
12226C
12227C              IT IS ASSUMED THAT THE INPUT CLASSES HAVE EQUAL WIDTH
12228C              AND THERE ARE NO MISSING CLASSES.
12229C     WRITTEN BY--JAMES J. FILLIBEN
12230C                 STATISTICAL ENGINEERING DIVISION
12231C                 INFORMATION TECHNOLOGY LABORATORY
12232C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
12233C                 GAITHERSBURG, MD 20899-8980
12234C                 PHONE--301-975-2855
12235C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
12236C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
12237C     LANGUAGE--ANSI FORTRAN (1977)
12238C     VERSION NUMBER--2004/10
12239C     ORIGINAL VERSION--OCTOBER   2004.
12240C     UPDATED         --FEBRUARY  2006. MODIFY ALGORITHM.
12241C                                       ORIGINAL ALGORITHM JUST WENT
12242C                                       FROM LEFT TO RIGHT.  REVISE
12243C                                       TO GO FROM LEFT TO CENTER
12244C                                       AND THEN FROM RIGHT TO
12245C                                       CENTER.  DO THIS SINCE WE
12246C                                       TYPICALLY WANT TO COMBINE
12247C                                       BINS WITH SMALL COUNTS IN
12248C                                       THE TAILS.
12249C     UPDATED         --JANUARY   2010. CASE WHERE THERE ARE MANY
12250C                                       EMPTY BINS CAN CAUSE PROBLEMS.
12251C                                       TO DEAL WITH THIS, REMOVE
12252C                                       EMPTY BINS FIRST (BUT COMPUTE
12253C                                       BIN WIDTH FIRST)
12254C
12255C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
12256C
12257      CHARACTER*4 IBUGA3
12258      CHARACTER*4 IERROR
12259C
12260      CHARACTER*4 ISUBN1
12261      CHARACTER*4 ISUBN2
12262C
12263C---------------------------------------------------------------------
12264C
12265      DIMENSION Y(*)
12266      DIMENSION X(*)
12267      DIMENSION Y2(*)
12268      DIMENSION XLOW(*)
12269      DIMENSION XUPP(*)
12270C
12271C---------------------------------------------------------------------
12272C
12273      INCLUDE 'DPCOP2.INC'
12274C
12275C-----START POINT-----------------------------------------------------
12276C
12277      ISUBN1='DPCO'
12278      ISUBN2='MB  '
12279      IERROR='NO'
12280C
12281      ASUM=0.0
12282C
12283      CALL SORTC(X,Y,N,X,Y)
12284C
12285      N2=0
12286      IFLAG=0
12287      ISTRT=1
12288C
12289C               ********************************************
12290C               **  STEP 1--                              **
12291C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
12292C               ********************************************
12293C
12294      IF(N.LT.2)THEN
12295        WRITE(ICOUT,999)
12296  999   FORMAT(1X)
12297        CALL DPWRST('XXX','BUG ')
12298        WRITE(ICOUT,31)
12299   31   FORMAT('***** ERROR IN COMBINE FREQUENCY TABLE--')
12300        CALL DPWRST('XXX','BUG ')
12301        WRITE(ICOUT,32)
12302   32   FORMAT('      THE NUMBER OF INPUT CLASSES IS LESS THAN TWO.')
12303        CALL DPWRST('XXX','BUG ')
12304        WRITE(ICOUT,34)N
12305   34   FORMAT('      THE ENTERED NUMBER OF INPUT CLASSES HERE = ',I6)
12306        CALL DPWRST('XXX','BUG ')
12307        WRITE(ICOUT,999)
12308        CALL DPWRST('XXX','BUG ')
12309        IERROR='YES'
12310        GOTO9000
12311      ENDIF
12312C
12313      DO60I=1,N
12314        IF(Y(I).LT.0.0)THEN
12315          WRITE(ICOUT,999)
12316          CALL DPWRST('XXX','BUG ')
12317          WRITE(ICOUT,31)
12318          CALL DPWRST('XXX','BUG ')
12319          WRITE(ICOUT,62)
12320   62     FORMAT('      A NEGATIVE FREQUENCY WAS ENCOUNTERED.')
12321          CALL DPWRST('XXX','BUG ')
12322          WRITE(ICOUT,63)I,Y(I)
12323   63     FORMAT('      ROW ',I8,' = ',G15.7)
12324          CALL DPWRST('XXX','BUG ')
12325          WRITE(ICOUT,999)
12326          CALL DPWRST('XXX','BUG ')
12327          IERROR='YES'
12328          GOTO9000
12329        ENDIF
12330   60 CONTINUE
12331C
12332      IF(IBUGA3.EQ.'ON')THEN
12333        WRITE(ICOUT,999)
12334        CALL DPWRST('XXX','BUG ')
12335        WRITE(ICOUT,70)
12336   70   FORMAT('***** AT THE BEGINNING OF DPCOMB--')
12337        CALL DPWRST('XXX','BUG ')
12338        WRITE(ICOUT,72)N,MINSIZ
12339   72   FORMAT('N,MINSIZ = ',2I8)
12340        CALL DPWRST('XXX','BUG ')
12341        DO73I=1,N
12342          WRITE(ICOUT,74)I,X(I),Y(I)
12343   74     FORMAT('I,X(I),Y(I) = ',I8,2G15.7)
12344          CALL DPWRST('XXX','BUG ')
12345   73   CONTINUE
12346      ENDIF
12347C
12348C               **********************************************
12349C               **  STEP 2--                                **
12350C               **  COMBINE CLASSES WITH A FREQUECNY LESS   **
12351C               **  THAN MINSIZ.                            **
12352C               **********************************************
12353C
12354      DELTA=X(2) - X(1)
12355      DO100I=2,N
12356        ATEMP=X(I) - X(I-1)
12357        IF(ATEMP.LT.DELTA)DELTA=ATEMP
12358  100 CONTINUE
12359      AINC=DELTA/2.0
12360C
12361      ICNT=0
12362      DO105I=1,N
12363        IF(Y(I).GT.0.5)THEN
12364          ICNT=ICNT+1
12365          Y(ICNT)=Y(I)
12366          X(ICNT)=X(I)
12367        ENDIF
12368  105 CONTINUE
12369      N=ICNT
12370C
12371      AMINSZ=REAL(MINSIZ)
12372      IFLAG=0
12373      ICNT=0
12374      ISTRT=-1
12375      EPS=1.0E-10
12376C
12377C  FEBRUARY 2006:  SINCE SMALL FREQUENCIES TEND TO OCCUR IN THE
12378C                  TAILS, MODIFY THE ALGORITHM TO WORK FROM THE
12379C                  LEFT TAIL TO THE CENTER AND THEN THE RIGHT
12380C                  TAIL TO THE CENTER (ORIGINAL IMPLEMENTATION
12381C                  WENT FROM LEFT TAIL TO RIGHT TAIL).
12382C
12383CCCCC DO200I=1,N
12384CCCCC   AMID=X(I)
12385CCCCC   ATEMP=REAL(INT(Y(I)+0.5))
12386CCCCC   IF(IFLAG.EQ.0)THEN
12387CCCCC     IF(ATEMP+EPS.GE.AMINSZ)THEN
12388CCCCC       ICNT=ICNT+1
12389CCCCC       XLOW(ICNT)=AMID - AINC
12390CCCCC       XUPP(ICNT)=AMID + AINC
12391CCCCC       Y2(ICNT)=ATEMP
12392CCCCC     ELSE
12393CCCCC       IFLAG=1
12394CCCCC       ASUM=ATEMP
12395CCCCC       ISTRT=I
12396CCCCC     ENDIF
12397CCCCC   ELSE
12398CCCCC     ASUM=ASUM + ATEMP
12399CCCCC     IF(ASUM+EPS.GE.AMINSZ)THEN
12400CCCCC       ICNT=ICNT + 1
12401CCCCC       XLOW(ICNT)=X(ISTRT) - AINC
12402CCCCC       XUPP(ICNT)=AMID + AINC
12403CCCCC       Y2(ICNT)=ASUM
12404CCCCC       ISTRT=-1
12405CCCCC       IFLAG=0
12406CCCCC     ENDIF
12407CCCCC   ENDIF
12408CC200 CONTINUE
12409C
12410CCCCC IF(IFLAG.EQ.1 .AND. ASUM.GT.0.0)THEN
12411CCCCC   XUPP(ICNT)=X(N) + AINC
12412CCCCC   Y2(ICNT)=Y2(ICNT) + ASUM
12413CCCCC ENDIF
12414CCCCC N2=ICNT
12415C
12416       IMID=N/2
12417C
12418C  LEFT TAIL TO CENTER
12419C
12420      DO200I=1,IMID
12421        AMID=X(I)
12422        ATEMP=REAL(INT(Y(I)+0.5))
12423        IF(IFLAG.EQ.0)THEN
12424          IF(ATEMP+EPS.GE.AMINSZ)THEN
12425            ICNT=ICNT+1
12426            XLOW(ICNT)=AMID - AINC
12427            XUPP(ICNT)=AMID + AINC
12428            Y2(ICNT)=ATEMP
12429          ELSE
12430            IFLAG=1
12431            ASUM=ATEMP
12432            ISTRT=I
12433          ENDIF
12434        ELSE
12435          ASUM=ASUM + ATEMP
12436          IF(ASUM+EPS.GE.AMINSZ)THEN
12437            ICNT=ICNT + 1
12438            XLOW(ICNT)=X(ISTRT) - AINC
12439            XUPP(ICNT)=AMID + AINC
12440            Y2(ICNT)=ASUM
12441            ISTRT=-1
12442            IFLAG=0
12443          ENDIF
12444        ENDIF
12445  200 CONTINUE
12446C
12447      IF(IFLAG.EQ.1 .AND. ASUM.GT.0.0)THEN
12448        XUPP(ICNT)=X(IMID) + AINC
12449        Y2(ICNT)=Y2(ICNT) + ASUM
12450      ENDIF
12451      IFLAG=0
12452      N2LEFT=ICNT
12453C
12454      IF(IBUGA3.EQ.'ON')THEN
12455        WRITE(ICOUT,999)
12456        CALL DPWRST('XXX','BUG ')
12457        WRITE(ICOUT,270)
12458  270   FORMAT('***** DPCOMB--AFTER LEFT TAIL FREQUENCIES')
12459        CALL DPWRST('XXX','BUG ')
12460        WRITE(ICOUT,272)IMID,ICNT
12461  272   FORMAT('IMID,ICNT = ',2I8)
12462        CALL DPWRST('XXX','BUG ')
12463        DO273I=1,ICNT
12464          WRITE(ICOUT,274)I,XLOW(I),XUPP(I),Y2(I)
12465  274     FORMAT('I,XLOW(I),XUPP(I),Y2(I) = ',I8,3G15.7)
12466          CALL DPWRST('XXX','BUG ')
12467  273   CONTINUE
12468      ENDIF
12469C
12470C
12471C  RIGHT TAIL TO CENTER.  TEMPORARILY STORE IN UPPER PART OF
12472C  XLOW, XUPP, AND Y2 ARRARYS, WILL THEN FLIP THE SORT AT THE
12473C  END.
12474C
12475      ICNT2=N
12476      IMID2=IMID+1
12477      IF(IMID2.GT.N)THEN
12478        N2=ICNT
12479        GOTO9000
12480      ENDIF
12481C
12482      DO300I=N,IMID2,-1
12483        AMID=X(I)
12484        ATEMP=REAL(INT(Y(I)+0.5))
12485        IF(IFLAG.EQ.0)THEN
12486          IF(ATEMP+EPS.GE.AMINSZ)THEN
12487            ICNT2=ICNT2+1
12488            XLOW(ICNT2)=AMID - AINC
12489            XUPP(ICNT2)=AMID + AINC
12490            Y2(ICNT2)=ATEMP
12491          ELSE
12492            IFLAG=1
12493            ASUM=ATEMP
12494            ISTOP=I
12495          ENDIF
12496        ELSE
12497          ASUM=ASUM + ATEMP
12498          IF(ASUM+EPS.GE.AMINSZ)THEN
12499            ICNT2=ICNT2 + 1
12500            XLOW(ICNT2)=AMID - AINC
12501            XUPP(ICNT2)=X(ISTOP) + AINC
12502            Y2(ICNT2)=ASUM
12503            ISTOP=-1
12504            IFLAG=0
12505          ENDIF
12506        ENDIF
12507  300 CONTINUE
12508C
12509      IF(IFLAG.EQ.1 .AND. ASUM.GT.0.0)THEN
12510        XLOW(ICNT2)=X(IMID2) - AINC
12511        Y2(ICNT2)=Y2(ICNT2) + ASUM
12512      ENDIF
12513      N2RGHT=ICNT2
12514C
12515C  NOW COPY REVERSE ORDER RIGHT TAIL ENTRIES
12516C
12517      DO400I=ICNT2,N+1,-1
12518        ICNT=ICNT+1
12519        Y2(ICNT)=Y2(I)
12520        XLOW(ICNT)=XLOW(I)
12521        XUPP(ICNT)=XUPP(I)
12522  400 CONTINUE
12523      N2=ICNT
12524C
12525C               ******************
12526C               **   STEP 90--  **
12527C               **   EXIT       **
12528C               ******************
12529C
12530 9000 CONTINUE
12531      IF(IBUGA3.EQ.'ON')THEN
12532        WRITE(ICOUT,999)
12533        CALL DPWRST('XXX','BUG ')
12534        WRITE(ICOUT,9011)
12535 9011   FORMAT('***** AT THE END OF DPCOMB--')
12536        CALL DPWRST('XXX','BUG ')
12537        WRITE(ICOUT,9012)IERROR,N2
12538 9012   FORMAT('IERROR,N2 = ',A4,2X,I8)
12539        CALL DPWRST('XXX','BUG ')
12540        DO9015I=1,N2
12541          WRITE(ICOUT,9016)I,Y2(I),XLOW(I),XUPP(I)
12542 9016     FORMAT('I,Y2(I),XLOW(I),XUPP(I) = ',I8,3G15.7)
12543          CALL DPWRST('XXX','BUG ')
12544 9015   CONTINUE
12545      ENDIF
12546C
12547      RETURN
12548      END
12549      SUBROUTINE DPCOMM(IHARG,NUMARG,
12550     1IDEFCZ,
12551     1ICOMCH,
12552     1ICOMFL,
12553     1IBUGS2,IFOUND,IERROR)
12554C
12555C     PURPOSE--DEFINE THE COMMENT CHARACTOR (DEFAULT IS ".").
12556C              ALSO CHECK FOR "COMMENT CHECK ON/OFF" COMMAND).
12557C
12558C              THE COMMENT CHARACTER IS STORED IN 4 CHARACTERS,
12559C              BUT ONLY THE FIRST CHARACTER IS USED.
12560C
12561C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
12562C                     --NUMARG (AN INTEGER VARIABLE)
12563C                     --IDEFCZ (A  CHARACTER VARIABLE)
12564C                     --IBUGS2 (A  CHARACTER VARIABLE)
12565C     OUTPUT ARGUMENTS--ICOMCH (A CHARACTER VARIABLE)
12566C                     --ICOMFL (A CHARACTER VARIABLE)
12567C                     --IFOUND ('YES' OR 'NO' )
12568C                     --IERROR ('YES' OR 'NO' )
12569C     WRITTEN BY--JAMES J. FILLIBEN
12570C                 STATISTICAL ENGINEERING DIVISION
12571C                 INFORMATION TECHNOLOGY LABORATORY
12572C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
12573C                 GAITHERSBURG, MD 20899-8980
12574C                 PHONE--301-975-2855
12575C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
12576C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
12577C     LANGUAGE--ANSI FORTRAN (1977)
12578C     VERSION NUMBER--82/7
12579C     ORIGINAL VERSION--MAY      1990.
12580C
12581C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
12582C
12583      CHARACTER*4 IHARG
12584      CHARACTER*4 IDEFCZ
12585      CHARACTER*4 ICOMCH
12586      CHARACTER*4 ICOMFL
12587      CHARACTER*4 IBUGS2
12588      CHARACTER*4 IFOUND
12589      CHARACTER*4 IERROR
12590C
12591      CHARACTER*4 IHOLD
12592C
12593C---------------------------------------------------------------------
12594C
12595      DIMENSION IHARG(*)
12596C
12597C---------------------------------------------------------------------
12598C
12599      INCLUDE 'DPCOP2.INC'
12600C
12601C-----START POINT-----------------------------------------------------
12602C
12603      IF(IBUGS2.EQ.'OFF')GOTO90
12604      WRITE(ICOUT,999)
12605  999 FORMAT(1X)
12606      CALL DPWRST('XXX','BUG ')
12607      WRITE(ICOUT,51)
12608   51 FORMAT('***** AT THE BEGINNING OF DPCOMM--')
12609      CALL DPWRST('XXX','BUG ')
12610      WRITE(ICOUT,53)IDEFCZ
12611   53 FORMAT('IDEFCZ = ',A4)
12612      CALL DPWRST('XXX','BUG ')
12613      WRITE(ICOUT,54)NUMARG
12614   54 FORMAT('NUMARG = ',I8)
12615      CALL DPWRST('XXX','BUG ')
12616      DO55I=1,NUMARG
12617      WRITE(ICOUT,56)I,IHARG(I)
12618   56 FORMAT('I,IHARG(I) = ',I8,2X,A4)
12619      CALL DPWRST('XXX','BUG ')
12620   55 CONTINUE
12621   90 CONTINUE
12622C
12623      IFOUND='NO'
12624      IERROR='NO'
12625C
12626      IF(NUMARG.LE.1.OR.NUMARG.GE.3)GOTO9000
12627      GOTO1110
12628C
12629 1110 CONTINUE
12630      IF(IHARG(1).EQ.'CHAR')GOTO1120
12631      IF(IHARG(1).EQ.'CHEC')GOTO2120
12632      GOTO2120
12633C
12634 1120 CONTINUE
12635      IF(IHARG(2).EQ.'AUTO')GOTO1150
12636      IF(IHARG(2).EQ.'DEFA')GOTO1150
12637      GOTO1160
12638C
12639 1150 CONTINUE
12640      IHOLD=IDEFCZ
12641      GOTO1180
12642C
12643 1160 CONTINUE
12644      IHOLD=IHARG(2)
12645      GOTO1180
12646C
12647 1180 CONTINUE
12648      IFOUND='YES'
12649      ICOMCH=IHOLD
12650C
12651      IF(IFEEDB.EQ.'OFF')GOTO1189
12652      WRITE(ICOUT,999)
12653      CALL DPWRST('XXX','BUG ')
12654      WRITE(ICOUT,1181)ICOMCH(1:1)
12655 1181 FORMAT('THE COMMENT CHARACTER HAS JUST BEEN SET TO ',
12656     1A1)
12657      CALL DPWRST('XXX','BUG ')
12658 1189 CONTINUE
12659      GOTO9000
12660C
12661 2120 CONTINUE
12662      IF(IHARG(2).EQ.'ON')GOTO2150
12663      IF(IHARG(2).EQ.'OFF')GOTO2160
12664      IF(IHARG(2).EQ.'AUTO')GOTO2150
12665      IF(IHARG(2).EQ.'DEFA')GOTO2150
12666      GOTO2160
12667C
12668 2150 CONTINUE
12669      IHOLD='ON'
12670      GOTO2180
12671C
12672 2160 CONTINUE
12673      IHOLD='OFF'
12674      GOTO2180
12675C
12676 2180 CONTINUE
12677      IFOUND='YES'
12678      ICOMFL=IHOLD
12679C
12680      IF(IFEEDB.EQ.'OFF')GOTO2189
12681      WRITE(ICOUT,999)
12682      CALL DPWRST('XXX','BUG ')
12683      IF(ICOMFL.EQ.'ON')WRITE(ICOUT,2181)
12684 2181 FORMAT('THE FIRST CHARACTER OF DATA FILES WILL BE CHECKED ',
12685     1'FOR THE COMMENT CHARACTER.')
12686      IF(ICOMFL.EQ.'ON')CALL DPWRST('XXX','BUG ')
12687      IF(ICOMFL.EQ.'OFF')WRITE(ICOUT,2182)
12688 2182 FORMAT('THE FIRST CHARACTER OF DATA FILES WILL NOT BE ',
12689     1'CHECKED FOR THE COMMENT CHARACTER.')
12690      IF(ICOMFL.EQ.'OFF')CALL DPWRST('XXX','BUG ')
12691 2189 CONTINUE
12692      GOTO9000
12693C
12694 9000 CONTINUE
12695      IF(IBUGS2.EQ.'OFF')GOTO9090
12696      WRITE(ICOUT,999)
12697      CALL DPWRST('XXX','BUG ')
12698      WRITE(ICOUT,9011)
12699 9011 FORMAT('***** AT THE END       OF DPCOMM-')
12700      CALL DPWRST('XXX','BUG ')
12701      WRITE(ICOUT,9012)IBUGS2,IFOUND,IERROR
12702 9012 FORMAT('IBUGS2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
12703      CALL DPWRST('XXX','BUG ')
12704      WRITE(ICOUT,9013)IDEFCZ,ICOMCH
12705 9013 FORMAT('IDEFCZ,ICOMCH = ',A4,2X,A4)
12706      CALL DPWRST('XXX','BUG ')
12707 9090 CONTINUE
12708C
12709      RETURN
12710      END
12711      SUBROUTINE DPCON2(IVAL,VAL,IH,NH,NMDID0,IBUGD2,IERROR)
12712C
12713C     NOTE--EXCEPT FOR THE NMDID0 ARGUMENT
12714C           (AND SOME BUG WRITE STATEMENTS),
12715C           THIS SUBROUTINE IS IDENTICAL TO DPCONH.
12716C           IT HAS BEEN DUPLICATED AND PLACED
12717C           ON THIS BRANCH OF THE OVERLAY/SEGMENTATION
12718C           TREE STRUCTURE IN ORDER TO ACHIEVE
12719C           FASTER EXECUTION TIME.
12720C
12721C     NOTE--UPON INPUT, IVALUE IS USUALLY INT(VALUE+0.5), BUT
12722C           FOR NEGATIVE VALUE, IVALUE SHOULD BE INT(VALUE-0.5)
12723C
12724C     NOTE--NMDID0 = THE NUMBER OF DECIMAL
12725C           PLACES DESIRED A PRIORI.
12726C           IF NMDID0 IS NEGATIVE, THEN THIS IMPLIES
12727C           THAT THE ACTUAL NUMBER OF DECIMAL PLACES
12728C           DESIRED IS NOT SET A PRIORI AND SO SHOULD
12729C           FLOAT WITH THE DATA VALUE.
12730C
12731C     PURPOSE--CONVERT NUMERIC VALUE INTO CORRESPONDING
12732C              CHARACTER STRING.
12733C
12734C     WRITTEN BY--JAMES J. FILLIBEN
12735C                 STATISTICAL ENGINEERING DIVISION
12736C                 INFORMATION TECHNOLOGY LABORATORY
12737C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
12738C                 GAITHERSBURG, MD 20899-8980
12739C                 PHONE--301-975-2855
12740C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
12741C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
12742C     LANGUAGE--ANSI FORTRAN (1977)
12743C     VERSION NUMBER--82/7
12744C     ORIGINAL VERSION--MARCH     1983.
12745C     UPDATED         --FEBRUARY  2011. FIX TO EXTEND THE PRECISION
12746C                                       A FEW EXTRA PLACES
12747C
12748C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
12749C
12750      CHARACTER*4 IH
12751      CHARACTER*4 IBUGD2
12752      CHARACTER*4 IERROR
12753C
12754      CHARACTER*4 IHREM
12755      CHARACTER*4 IHNUM
12756      CHARACTER*4 IHTEMI
12757      CHARACTER*4 IHTEMD
12758C
12759      DIMENSION IH(*)
12760      DIMENSION IHTEMI(10)
12761      DIMENSION IHTEMD(10)
12762C
12763C
12764C-----COMMON----------------------------------------------------------
12765C
12766      INCLUDE 'DPCOBE.INC'
12767C
12768C-----COMMON VARIABLES (GENERAL)--------------------------------------
12769C
12770      INCLUDE 'DPCOP2.INC'
12771C
12772C-----DATA STATEMENTS-------------------------------------------------
12773C
12774C-----START POINT---------------------------------------------------------
12775C
12776      AINUM=0.0
12777      FRACT=0.0
12778      NUMDID=0
12779      IMAX=0
12780C
12781CCCCC IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CON2')GOTO90
12782      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CON2'.AND.IBUGD2.EQ.'OFF')
12783     1GOTO90
12784      WRITE(ICOUT,999)
12785      CALL DPWRST('XXX','BUG ')
12786      WRITE(ICOUT,51)
12787   51 FORMAT('***** AT THE BEGINNING OF DPCON2--')
12788      CALL DPWRST('XXX','BUG ')
12789      WRITE(ICOUT,52)IVAL,VAL
12790   52 FORMAT('IVAL,VAL = ',I8,E15.7)
12791      CALL DPWRST('XXX','BUG ')
12792      WRITE(ICOUT,53)NMDID0
12793   53 FORMAT('NMDID0 = ',I8)
12794      CALL DPWRST('XXX','BUG ')
12795      WRITE(ICOUT,59)IBUGG4,ISUBG4,IERRG4
12796   59 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
12797      CALL DPWRST('XXX','BUG ')
12798   90 CONTINUE
12799C
12800      ABSVAL=ABS(VAL)
12801C
12802      AIVAL=IVAL
12803      DEL=AIVAL-VAL
12804      ABSDEL=ABS(DEL)
12805C
12806      ABSRAT=ABSDEL
12807      IF(ABSVAL.GE.1.0)ABSRAT=ABSDEL/ABSVAL
12808C
12809CCCCC CUTDEL=10.0**(-16)
12810C
12811      CUTDEL=10.0**(-6)
12812      CUTRAT=10.0**(-6)
12813C
12814CCCCC IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CON2')GOTO919
12815      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CON2'.AND.IBUGD2.EQ.'OFF')
12816     1GOTO919
12817      WRITE(ICOUT,999)
12818      CALL DPWRST('XXX','BUG ')
12819      WRITE(ICOUT,911)
12820  911 FORMAT('***** FROM THE MIDDLE OF DPCON2--')
12821      CALL DPWRST('XXX','BUG ')
12822      WRITE(ICOUT,912)ABSVAL
12823  912 FORMAT('ABSVAL = ',E15.7)
12824      CALL DPWRST('XXX','BUG ')
12825      WRITE(ICOUT,913)VAL,IVAL,AIVAL,DEL,ABSDEL
12826  913 FORMAT('VAL,IVAL,AIVAL,DEL,ABSDEL = ',E15.7,I8,3E15.7)
12827      CALL DPWRST('XXX','BUG ')
12828      WRITE(ICOUT,914)ABSDEL,CUTDEL
12829  914 FORMAT('ABSDEL,CUTDEL = ',2E15.7)
12830      CALL DPWRST('XXX','BUG ')
12831      WRITE(ICOUT,915)ABSRAT,CUTRAT
12832  915 FORMAT('ABSRAT,CUTRAT = ',2E15.7)
12833      CALL DPWRST('XXX','BUG ')
12834  919 CONTINUE
12835C
12836      IF(ABSVAL.LT.1.0.AND.ABSDEL.LE.CUTDEL)GOTO1000
12837      IF(ABSVAL.GE.1.0.AND.ABSRAT.LE.CUTRAT)GOTO1000
12838      GOTO2000
12839C
12840C               ******************************
12841C               **  STEP XX--               **
12842C               **  TREAT THE INTEGER CASE  **
12843C               ******************************
12844C
12845 1000 CONTINUE
12846C
12847CCCCC IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CON2')WRITE(ICOUT,1005)
12848CCCCC IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CON2')CALL DPWRST('XXX','BUG ')
12849      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CON2'.OR.IBUGD2.EQ.'ON')
12850     1WRITE(ICOUT,1005)
12851 1005 FORMAT('*****INTEGER CASE*****')
12852      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CON2'.OR.IBUGD2.EQ.'ON')
12853     1CALL DPWRST('XXX','BUG ')
12854C
12855      INUM=IABS(IVAL)
12856      NUMDII=0
12857      IF(INUM.EQ.0)NUMDII=NUMDII+1
12858      IF(INUM.EQ.0)IHTEMI(NUMDII)='0'
12859      IF(INUM.EQ.0)GOTO1190
12860C
12861      DO1100I=1,10
12862      IF(INUM.LE.0)GOTO1190
12863      IRATIO=INUM/10
12864      IREM=INUM-10*IRATIO
12865      INUM=IRATIO
12866      NUMDII=NUMDII+1
12867      CALL DPCOD2(IREM,IHREM,IBUGD2,IERROR)
12868      IHTEMI(NUMDII)=IHREM
12869 1100 CONTINUE
12870 1190 CONTINUE
12871      IF(IVAL.LT.0)NUMDII=NUMDII+1
12872      IF(IVAL.LT.0)IHTEMI(NUMDII)='-'
12873C
12874      NH=NUMDII
12875      IF(NUMDII.LE.0)GOTO1290
12876      DO1200I=1,NUMDII
12877      IREV=NUMDII-I+1
12878      IH(I)=IHTEMI(IREV)
12879 1200 CONTINUE
12880 1290 CONTINUE
12881C
12882      IF(NMDID0.GE.1)GOTO2500
12883      GOTO9000
12884C
12885C               **********************************
12886C               **  STEP XX--                   **
12887C               **  TREAT THE NON-INTEGER CASE  **
12888C               **********************************
12889C
12890 2000 CONTINUE
12891C
12892CCCCC IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CON2')WRITE(ICOUT,2005)
12893CCCCC IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CON2')CALL DPWRST('XXX','BUG ')
12894      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CON2'.OR.IBUGD2.EQ.'ON')
12895     1WRITE(ICOUT,2005)
12896 2005 FORMAT('*****NON-INTEGER CASE*****')
12897      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CON2'.OR.IBUGD2.EQ.'ON')
12898     1CALL DPWRST('XXX','BUG ')
12899C
12900      INUM=INT(ABSVAL)
12901      AINUM=REAL(INUM)
12902      FRACT=ABSVAL-AINUM
12903C
12904      NUMDII=0
12905      IF(INUM.EQ.0)NUMDII=NUMDII+1
12906      IF(INUM.EQ.0)IHTEMI(NUMDII)='0'
12907      IF(INUM.EQ.0)GOTO2190
12908C
12909      DO2100I=1,10
12910        IF(INUM.LE.0)GOTO2190
12911        IRATIO=INUM/10
12912        IREM=INUM-10*IRATIO
12913        INUM=IRATIO
12914        NUMDII=NUMDII+1
12915        CALL DPCOD2(IREM,IHREM,IBUGD2,IERROR)
12916        IHTEMI(NUMDII)=IHREM
12917 2100 CONTINUE
12918 2190 CONTINUE
12919      IF(VAL.LT.0)NUMDII=NUMDII+1
12920      IF(VAL.LT.0)IHTEMI(NUMDII)='-'
12921C
12922      NUMDID=0
12923      IF(FRACT.EQ.0.0)NUMDID=0
12924      IF(FRACT.EQ.0.0)GOTO2390
12925C
12926      ANUM=FRACT
12927CCCCC NOTE 2011/2: LOSING ACCURACY AT ABOUT 6 DECIMAL PLACES.
12928CCCCC              INCREASE VALUE OF NLOOP SO THAT WE OBTAIN
12929CCCCC              A FEW EXTRA DIGITS OF ACCURACY.
12930CCCCC NLOOP=8-NUMDII
12931      NLOOP=12-NUMDII
12932CCCCC CUTOF2=10.0**(-NLOOP+1)
12933CCCCC CUTOF3=1.0-CUTOF2
12934      IF(NLOOP.LE.0)GOTO2390
12935      DO2300I=1,NLOOP
12936      CUTOF2=10.0**(-NLOOP+I+1)
12937      CUTOF3=1.0-CUTOF2
12938      ANUM=ANUM*10.0
12939      INUM=INT(ANUM)
12940      AINUM=REAL(INUM)
12941      DEL3=ANUM-AINUM
12942CCCCC IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CON2')WRITE(ICOUT,2311)
12943CCCCC IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CON2')CALL DPWRST('XXX','BUG ')
12944      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CON2'.OR.IBUGD2.EQ.'ON')
12945     1WRITE(ICOUT,2311)
12946     1NLOOP,I,CUTOF3,CUTOF2
12947 2311 FORMAT('NLOOP,I,CUTOF3,CUTOF2 = ',I8,I8,2E15.7)
12948      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CON2'.OR.IBUGD2.EQ.'ON')
12949     1CALL DPWRST('XXX','BUG ')
12950CCCCC IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CON2')WRITE(ICOUT,2312)
12951CCCCC IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CON2')CALL DPWRST('XXX','BUG ')
12952      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CON2'.OR.IBUGD2.EQ.'ON')
12953     1WRITE(ICOUT,2312)
12954     1ANUM,AINUM,DEL3,CUTOF3
12955 2312 FORMAT('ANUM,AINUM,DEL3,CUTOF3 = ',4E15.7)
12956      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CON2'.OR.IBUGD2.EQ.'ON')
12957     1CALL DPWRST('XXX','BUG ')
12958      IF(DEL3.GE.CUTOF3)INUM=INUM+1
12959      IF(DEL3.GE.CUTOF3)ANUM=INUM
12960      NUMDID=NUMDID+1
12961      CALL DPCOD2(INUM,IHNUM,IBUGD2,IERROR)
12962      IHTEMD(NUMDID)=IHNUM
12963      AINUM=INUM
12964      DEL2=ANUM-AINUM
12965      ANUM=DEL2
12966CCCCC IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CON2')WRITE(ICOUT,2313)
12967CCCCC IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CON2')CALL DPWRST('XXX','BUG ')
12968      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CON2'.OR.IBUGD2.EQ.'ON')
12969     1WRITE(ICOUT,2313)
12970     1ANUM,AINUM,DEL2,CUTOF2
12971 2313 FORMAT('ANUM,AINUM,DEL2,CUTOF2 = ',4E15.7)
12972      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CON2'.OR.IBUGD2.EQ.'ON')
12973     1CALL DPWRST('XXX','BUG ')
12974      IF(DEL2.LE.CUTOF2)GOTO2390
12975 2300 CONTINUE
12976 2390 CONTINUE
12977C
12978      NH=0
12979      IF(NUMDII.LE.0)GOTO2490
12980      DO2400I=1,NUMDII
12981      NH=NH+1
12982      IREV=NUMDII-I+1
12983      IH(NH)=IHTEMI(IREV)
12984 2400 CONTINUE
12985 2490 CONTINUE
12986C
12987 2500 CONTINUE
12988      NH=NH+1
12989      IH(NH)='.'
12990C
12991      IMAX=NMDID0
12992      IF(NMDID0.LT.0)IMAX=NUMDID
12993C
12994      IF(IMAX.LE.0)GOTO2690
12995      DO2600I=1,IMAX
12996      NH=NH+1
12997      IF(NMDID0.LT.0)IH(NH)=IHTEMD(I)
12998      IF(NMDID0.GE.0.AND.I.LE.NUMDID)IH(NH)=IHTEMD(I)
12999      IF(NMDID0.GE.0.AND.I.GT.NUMDID)IH(NH)='0'
13000 2600 CONTINUE
13001 2690 CONTINUE
13002C
13003C               *****************
13004C               **  STEP 90--  **
13005C               **  EXIT       **
13006C               *****************
13007C
13008 9000 CONTINUE
13009CCCCC IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CON2')GOTO9090
13010      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CON2'.AND.IBUGD2.EQ.'OFF')
13011     1GOTO9090
13012      WRITE(ICOUT,999)
13013  999 FORMAT(1X)
13014      CALL DPWRST('XXX','BUG ')
13015      WRITE(ICOUT,9011)
13016 9011 FORMAT('***** AT THE END       OF DPCON2--')
13017      CALL DPWRST('XXX','BUG ')
13018      WRITE(ICOUT,9012)IVAL,VAL
13019 9012 FORMAT('IVAL,VAL = ',I8,E15.7)
13020      CALL DPWRST('XXX','BUG ')
13021      WRITE(ICOUT,9013)AIVAL,VAL,DEL,ABSDEL,CUTDEL
13022 9013 FORMAT('AIVAL,VAL,DEL,ABSDEL,CUTDEL = ',5E15.7)
13023      CALL DPWRST('XXX','BUG ')
13024      WRITE(ICOUT,9014)ABSVAL,INUM,AINUM,FRACT
13025 9014 FORMAT('ABSVAL,INUM,AINUM,FRACT = ',E15.7,2X,I8,2E15.7)
13026      CALL DPWRST('XXX','BUG ')
13027      WRITE(ICOUT,9015)NUMDII
13028 9015 FORMAT('NUMDII = ',I8)
13029      CALL DPWRST('XXX','BUG ')
13030      WRITE(ICOUT,9016)(IHTEMI(I),I=1,NUMDII)
13031 9016 FORMAT('(IHTEMI(I),I=1,NUMDII) = ',20A1)
13032      CALL DPWRST('XXX','BUG ')
13033      WRITE(ICOUT,9025)NMDID0,NUMDID,IMAX
13034 9025 FORMAT('NMDID0,NUMDID,IMAX = ',3I8)
13035      CALL DPWRST('XXX','BUG ')
13036      WRITE(ICOUT,9026)(IHTEMD(I),I=1,NUMDID)
13037 9026 FORMAT('(IHTEMD(I),I=1,NUMDID) = ',20A1)
13038      CALL DPWRST('XXX','BUG ')
13039      WRITE(ICOUT,9031)NH
13040 9031 FORMAT('NH = ',I8)
13041      CALL DPWRST('XXX','BUG ')
13042      WRITE(ICOUT,9032)(IH(I),I=1,NH)
13043 9032 FORMAT('(IH(I),I=1,NH) = ',20A1)
13044      CALL DPWRST('XXX','BUG ')
13045      WRITE(ICOUT,9039)IBUGG4,ISUBG4,IERRG4
13046 9039 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
13047      CALL DPWRST('XXX','BUG ')
13048 9090 CONTINUE
13049C
13050      RETURN
13051      END
13052      SUBROUTINE DPCOND(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
13053     1                  IANGLU,MAXNPP,
13054     1                  CLLIMI,CLWIDT,
13055     1                  ICONT,NUMHPP,NUMVPP,IMANUF,
13056     1                  XMATN,YMATN,XMITN,YMITN,
13057     1                  ISQUAR,
13058     1                  IVGMSW,IHGMSW,
13059     1                  IMPSW,IMPNR,IMPNC,IMPCO,
13060     1                  PMXMIN,PMXMAX,PMYMIN,PMYMAX,
13061     1                  MAXNXT,
13062     1                  ALOWFR,ALOWDG,
13063     1                  IFORSW,
13064     1                  ANOPL1,ANOPL2,ISEED,IBOOSS,BARHEF,BARWEF,
13065     1                  ICAPSW,
13066     1                  IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ,
13067     1                  IBUGUG,IBUGU2,IBUGU3,IBUGU4,ISUBRO,
13068     1                  IFOUND,IERROR)
13069C
13070C     PURPOSE--GENERATE A CONDITIONING PLOT (COPLOT)
13071C            --ALLOWABLE SYNTAXES:
13072C                CONDITIONING PLOT Y COND
13073C                CONDITIONING PLOT Y X COND
13074C                CONDITIONING PLOT Y X COND TAG
13075C                CONDITIONING PLOT Y X COND1 COND2
13076C                CONDITIONING PLOT Y X COND1 COND2 TAG
13077C                CONDITIONING PLOT Y1 ... YK X COND TAG
13078C             --THAT IS, THERE ARE:
13079C               1) ONE OR MORE RESPONSE VARIABLES (DETERMINED BY
13080C                  SET COND PLOT RESPONSE VARIABLES <VALUE>
13081C               2) AN OPTIONAL INDEPENDENT VARIABLE.  THIS IS
13082C                  DETERMINED BT THE PLOT TYPE.
13083C                  NOTE: 3D PLOT TYPES WILL HAVE EITHER 2 OR 3
13084C                  INDEPENDENT VARIABLES.
13085C               3) EITHER ONE OR TWO CONDITIONING VARIABLES (DETERMINED
13086C                  BY: SET COND PLOT CONDITION VARIABLES <1/2>)
13087C               4) AN OPTIONAL TAG VARIABLE (DETERMINED BY
13088C                  SET COND PLOT TAG <ON/OFF>)
13089C     WRITTEN BY--ALAN HECKERT
13090C                 STATISTICAL ENGINEERING DIVISION
13091C                 INFORMATION TECHNOLOGY LABORATORY
13092C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
13093C                 GAITHERSBURG, MD 20899-8980
13094C                 PHONE--301-975-2899
13095C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
13096C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
13097C     LANGUAGE--ANSI FORTRAN (1977)
13098C     VERSION NUMBER--99/9
13099C     ORIGINAL VERSION --SEPTEMBER 1999.
13100C     UPDATED          --APRIL     2007. ADD ROSE PLOT
13101C     UPDATED          --AUGUST    2007. CALL LIST TO MAINGR
13102C     UPDATED          --JUNE      2014. WRITE YPLOT, XPLOT, TAGPLOT TO
13103C                                        DPST5F.DAT
13104C
13105C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES---------------
13106C
13107      REAL CLLIMI(*)
13108      REAL CLWIDT(*)
13109C
13110      INCLUDE 'DPCOPA.INC'
13111C
13112      CHARACTER*4 ICASPL
13113      CHARACTER*4 ICAPSW
13114      CHARACTER*4 ICONT
13115      CHARACTER*4 IPOWE
13116      CHARACTER*4 IAND1
13117      CHARACTER*4 IAND2
13118      CHARACTER*4 IANGLU
13119      CHARACTER*4 IFORSW
13120C
13121      CHARACTER*4 IBUGG2
13122      CHARACTER*4 IBUGG3
13123      CHARACTER*4 IBUGUG
13124      CHARACTER*4 IBUGU2
13125      CHARACTER*4 IBUGU3
13126      CHARACTER*4 IBUGU4
13127      CHARACTER*4 IBUGCO
13128      CHARACTER*4 IBUGEV
13129      CHARACTER*4 IBUGQ
13130C
13131      CHARACTER*4 ISUBRO
13132      CHARACTER*4 IFOUND
13133      CHARACTER*4 IERROR
13134C
13135      CHARACTER*4 ISQUAR
13136      CHARACTER*4 IVGMSW
13137      CHARACTER*4 IHGMSW
13138      CHARACTER*4 IREPCH
13139      CHARACTER*4 IMPSW
13140C
13141      CHARACTER*4 ICPLLD
13142      CHARACTER*4 ICPLDI
13143      CHARACTER*4 IEMPTY
13144      CHARACTER*4 IFEED9
13145      CHARACTER*4 ICPLFZ
13146      CHARACTER*4 ICPLPZ
13147      CHARACTER*4 ICPLLZ
13148      CHARACTER*4 ICPLTZ
13149      CHARACTER*4 ICPLL2
13150      CHARACTER*4 ICPLXZ
13151      CHARACTER*4 ICPLYZ
13152      CHARACTER*4 ICPLDZ
13153      CHARACTER*4 ICPLZT
13154      CHARACTER*4 ICPLZ2
13155      CHARACTER*4 ICPLZ3
13156      CHARACTER*4 ICPLZ4
13157      CHARACTER*4 ILFLAX
13158      CHARACTER*4 ILFLAY
13159C
13160      CHARACTER*4 IMANUF
13161      CHARACTER*4 IPLTTY
13162      CHARACTER*4 IPLOTT
13163      CHARACTER*4 IFLGIN
13164      CHARACTER*4 IFLGX
13165      CHARACTER*4 IFLGY
13166      CHARACTER*4 IWRITE
13167      CHARACTER*4 ISUBSZ
13168C
13169      CHARACTER*4 IFITA2
13170      CHARACTER*4 IOP
13171C
13172      CHARACTER*4 ICT
13173      CHARACTER*4 IC2T
13174      CHARACTER*4 IHT(25)
13175      CHARACTER*4 IH2T(25)
13176      CHARACTER*4 IARGTT(25)
13177      REAL ARGT(25)
13178C
13179C  MAXY IS THE MAXIMUM NUMBER OF VARIABLES TO USE IN CREATING THE
13180C  CONDITIONING PLOT   CURVE
13181C
13182      PARAMETER(MAXY=50)
13183      CHARACTER*40 INAME
13184      CHARACTER*4 IVARN1(MAXY)
13185      CHARACTER*4 IVARN2(MAXY)
13186      CHARACTER*4 IVARTY(MAXY)
13187      DIMENSION ILIS(MAXY)
13188      DIMENSION PVAR(MAXY)
13189      DIMENSION NRIGHT(MAXY)
13190      DIMENSION ICOLL(MAXY)
13191C
13192      CHARACTER*4 IHRIGH
13193      CHARACTER*4 IHRIG2
13194      CHARACTER*4 IHWUSE
13195      CHARACTER*4 MESSAG
13196      CHARACTER*4 ISTEPN
13197      CHARACTER*4 ISUBN1
13198      CHARACTER*4 ISUBN2
13199C
13200      DIMENSION TEMP(MAXOBV)
13201      DIMENSION TEMP2(MAXOBV)
13202      DIMENSION TEMP3(MAXOBV)
13203      DIMENSION XTEMP1(MAXOBV)
13204      DIMENSION XTEMP2(MAXOBV)
13205C
13206C-----COMMON------------------------------------------------------
13207C
13208      DIMENSION ADIST1(MAXY)
13209      DIMENSION ADIST2(MAXY)
13210C
13211      INCLUDE 'DPCOZ3.INC'
13212      INCLUDE 'DPCOPC.INC'
13213      INCLUDE 'DPCOHK.INC'
13214      INCLUDE 'DPCODA.INC'
13215      INCLUDE 'DPCOST.INC'
13216      INCLUDE 'DPCOSP.INC'
13217C
13218      EQUIVALENCE (G3RBAG(KGARB1),TEMP(1))
13219      EQUIVALENCE (G3RBAG(KGARB2),TEMP2(1))
13220      EQUIVALENCE (G3RBAG(KGARB3),TEMP3(1))
13221      EQUIVALENCE (G3RBAG(KGARB4),XTEMP1(1))
13222      EQUIVALENCE (G3RBAG(KGARB5),XTEMP2(1))
13223C
13224C
13225C-----COMMON VARIABLES (GENERAL)----------------------------------
13226C
13227      INCLUDE 'DPCOP2.INC'
13228C
13229C-----START POINT-------------------------------------------------
13230C
13231      IFOUND='YES'
13232      IERROR='NO'
13233      ISUBN1='DPCO'
13234      ISUBN2='ND  '
13235      ICASPL='COND'
13236      ICPLLD='ON'
13237      ICPLDI='BLAN'
13238C
13239      IXC2=0
13240      IXC3=0
13241      NPOS2=0
13242C
13243      IPLTTY='BIVA'
13244      IF(ICPLPT.EQ.'HIST')IPLTTY='UNIV'
13245      IF(ICPLPT.EQ.'RUNS')IPLTTY='UNIV'
13246      IF(ICPLPT.EQ.'PERC')IPLTTY='UNIV'
13247      IF(ICPLPT.EQ.'AUTO')IPLTTY='UNIV'
13248      IF(ICPLPT.EQ.'LAG ')IPLTTY='UNIV'
13249      IF(ICPLPT.EQ.'PROB')IPLTTY='UNIV'
13250      IF(ICPLPT.EQ.'PPCC')IPLTTY='UNIV'
13251      IF(ICPLPT.EQ.'DENS')IPLTTY='UNIV'
13252      IF(ICPLPT.EQ.'ROSE')IPLTTY='UNIV'
13253      ICPLXV=1
13254      IF(IPLTTY.EQ.'UNIV')ICPLXV=0
13255      IF(ICPLPT.EQ.'YACU')ICPLXV=3
13256      IF(ICPLPT.EQ.'3DPL')ICPLXV=2
13257C
13258      ICPLRV=INT(PCPLRV+0.5)
13259      IF(ICPLRV.LT.1)ICPLRV=1
13260      ITAG=0
13261      IF(ICPLTA.EQ.'ON'.AND.ICPLPT.EQ.'PLOT')ITAG=1
13262      ICPLTV=INT(PCPLTV+0.5)
13263      IF(ICPLTV.LT.1)ICPLTV=1
13264      IF(ICPLTV.GT.2)ICPLTV=2
13265C
13266      IFLAGV=ICPLRV+ICPLXV+ICPLTV+ITAG
13267C
13268      IRC1=1
13269      IRC2=ICPLRV
13270      ICOL=IRC2
13271      IF(ICPLXV.GE.1)ICOL=ICOL+1
13272      IXC1=ICOL
13273      IF(ICPLXV.GE.2)THEN
13274        ICOL=ICOL+1
13275        IXC2=ICOL
13276      ENDIF
13277      IF(ICPLXV.GE.3)THEN
13278        ICOL=ICOL+1
13279        IXC3=ICOL
13280      ENDIF
13281      ICOL=ICOL+1
13282      ICC1=ICOL
13283      IF(ICPLTV.EQ.2)ICOL=ICOL+1
13284      ICC2=ICOL
13285      IF(ITAG.GT.0)ICOL=ICOL+1
13286      ITC1=ICOL
13287C
13288C     WRITE XPLOT, YPLOT, TAGPLOT TO "dpst5f.dat"
13289C
13290      IOP='OPEN'
13291      IFLG11=0
13292      IFLG21=0
13293      IFLG31=0
13294      IFLAG4=0
13295      IFLAG5=1
13296      CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLAG4,IFLAG5,
13297     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
13298     1            IBUGG2,ISUBRO,IERROR)
13299      ICNTPL=0
13300      IFITA2=IFITAU
13301      IFITAU='OFF'
13302      IF(IERROR.EQ.'YES')GOTO9000
13303C
13304C               *****************************************
13305C               **  TREAT THE CONDITIONING PLOT   CASE **
13306C               *****************************************
13307C
13308      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'COND')THEN
13309        WRITE(ICOUT,999)
13310  999   FORMAT(1X)
13311        CALL DPWRST('XXX','BUG ')
13312        WRITE(ICOUT,51)
13313   51   FORMAT('***** AT THE BEGINNING OF DPCOND--')
13314        CALL DPWRST('XXX','BUG ')
13315        WRITE(ICOUT,52)ICASPL,IAND1,IAND2,NUMARG
13316   52   FORMAT('ICASPL,IAND1,IAND2,NUMARG = ',3(A4,2X),I8)
13317        CALL DPWRST('XXX','BUG ')
13318        WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ,ISUBRO
13319   53   FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',3(A4,2X),A4)
13320        CALL DPWRST('XXX','BUG ')
13321        IF(NUMARG.GT.0)THEN
13322          DO61I=1,NUMARG
13323            WRITE(ICOUT,62)I,IHARG(I),IARGT(I)
13324   62       FORMAT('I,IHARG(I),IARGT(I) = ',I8,2X,A4,2X,A4)
13325            CALL DPWRST('XXX','BUG ')
13326   61     CONTINUE
13327        ENDIF
13328        WRITE(ICOUT,71)ICPLLA,ICPLTA,ICPLPT,ICPLFI,ICPLFR
13329   71   FORMAT('ICPLLA,ICPLTA,ICPLPT,ICPLFI,ICPLFR = ',4(A4,2X),A4)
13330        CALL DPWRST('XXX','BUG ')
13331        WRITE(ICOUT,73)CLLIMI(1),CLLIMI(2),CLWIDT(1),CLWIDT(2)
13332   73   FORMAT('CLLIMI(1),CLLIMI(2),CLWIDT(1),CLWIDT(2) = ',4G15.7)
13333        CALL DPWRST('XXX','BUG ')
13334      ENDIF
13335C
13336C               ******************************************************
13337C               **  STEP 1--                                        **
13338C               **  SHIFT COMMAND LINE ARGMENTS                     **
13339C               ******************************************************
13340C
13341      ISTEPN='1'
13342      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'COND')
13343     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
13344C
13345      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')THEN
13346        ISHIFT=1
13347        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
13348     1              IBUGG2,IERROR)
13349        IF(IERROR.EQ.'YES')GOTO9000
13350      ENDIF
13351      ICOM='PLOT'
13352      ICOM2='    '
13353      IFOUND='YES'
13354C
13355C               *******************************************************
13356C               **  STEP 2--                                         **
13357C               **  CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS.  **
13358C               *******************************************************
13359C
13360      ISTEPN='2'
13361      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'COND')
13362     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
13363C
13364      INAME='CONDITION PLOT'
13365      MINNA=1
13366      MAXNA=100
13367      MINN2=2
13368      IFLAGE=1
13369      IF(IFPLPT.EQ.'HIST')IFLAGE=0
13370      IFLAGM=1
13371      IFLAGP=0
13372      JMIN=1
13373      JMAX=NUMARG
13374      MINNVA=1
13375      MAXNVA=MAXY
13376C
13377      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
13378     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
13379     1            JMIN,JMAX,
13380     1            MINN2,MINNA,MAXNA,MAXY,IFLAGE,INAME,
13381     1            IVARN1,IVARN2,IVARTY,PVAR,
13382     1            ILIS,NRIGHT,ICOLL,ISUB,NQ,ILOCQ,NUMVAR,
13383     1            MINNVA,MAXNVA,
13384     1            IFLAGM,IFLAGP,
13385     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
13386      IF(IERROR.EQ.'YES')GOTO9000
13387C
13388      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'COND')THEN
13389        WRITE(ICOUT,999)
13390        CALL DPWRST('XXX','BUG ')
13391        WRITE(ICOUT,281)
13392  281   FORMAT('***** AFTER CALL DPPARS--')
13393        CALL DPWRST('XXX','BUG ')
13394        WRITE(ICOUT,282)NQ,NUMVAR
13395  282   FORMAT('NQ,NUMVAR = ',2I8)
13396        CALL DPWRST('XXX','BUG ')
13397        IF(NUMVAR.GT.0)THEN
13398          DO285I=1,NUMVAR
13399            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
13400     1                      ICOLL(I)
13401  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
13402     1             'ICOLL(I) = ',I8,2X,A4,A4,2X,3I8)
13403            CALL DPWRST('XXX','BUG ')
13404  285     CONTINUE
13405        ENDIF
13406      ENDIF
13407C
13408C               **************************************************
13409C               **  STEP 12B-                                   **
13410C               **  NUMBER OF VARIABLES MUST EQUAL IFLAGV       **
13411C               **************************************************
13412C
13413      ISTEPN='12B'
13414      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'COND')
13415     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
13416C
13417      IF(NUMVAR.NE.IFLAGV)THEN
13418        WRITE(ICOUT,999)
13419        CALL DPWRST('XXX','BUG ')
13420        WRITE(ICOUT,1291)
13421        CALL DPWRST('XXX','BUG ')
13422        WRITE(ICOUT,1293)ICPLRV
13423        CALL DPWRST('XXX','BUG ')
13424        WRITE(ICOUT,1294)ICPLXV
13425        CALL DPWRST('XXX','BUG ')
13426        WRITE(ICOUT,1295)ICPLTV
13427        CALL DPWRST('XXX','BUG ')
13428        WRITE(ICOUT,1296)ITAG
13429        CALL DPWRST('XXX','BUG ')
13430        WRITE(ICOUT,1297)NUMVAR
13431        CALL DPWRST('XXX','BUG ')
13432        WRITE(ICOUT,1328)
13433 1328   FORMAT('THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
13434        CALL DPWRST('XXX','BUG ')
13435        IF(IWIDTH.GE.1)THEN
13436          WRITE(ICOUT,1329)(IANS(J),J=1,MIN(IWIDTH,100))
13437 1329     FORMAT('    ',100A1)
13438          CALL DPWRST('XXX','BUG ')
13439        ENDIF
13440        IERROR='YES'
13441        GOTO9000
13442      ENDIF
13443 1291 FORMAT('***** ERROR IN DPCOND--EXPECTED')
13444 1293 FORMAT('         ',I8,'RESPONSE VARIABLES')
13445 1294 FORMAT('         ',I8,'INDEPENDENT VARIABLES')
13446 1295 FORMAT('         ',I8,'CONDITIONING VARIABLES')
13447 1296 FORMAT('         ',I8,'TAG VARIABLES')
13448 1297 FORMAT('      DETECTED ',I8,' VARIABLES.')
13449C
13450C               ***************************************
13451C               **  STEP 13--                        **
13452C               **  CHECK THE VALIDITY OF EACH       **
13453C               **  OF THE VARIABLES.                **
13454C               **  ALSO CHECK TO ASSURE THAT EACH   **
13455C               **  OF THE VARIABLES HAS AT LEAST    **
13456C               **  2 OBSERVATIONS.                  **
13457C               ***************************************
13458C
13459      ISTEPN='13'
13460      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'COND')
13461     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
13462C
13463      MAXCP1=MAXCOL+1
13464      MAXCP2=MAXCOL+2
13465      MAXCP3=MAXCOL+3
13466      MAXCP4=MAXCOL+4
13467      MAXCP5=MAXCOL+5
13468      MAXCP6=MAXCOL+6
13469C
13470      IFLAG=0
13471      IFLAG2=0
13472      DO1300I=1,NUMVAR
13473C
13474        IF(I.EQ.ICC1)THEN
13475          ICOL=ICOLL(I)
13476          J=0
13477          DO1261ITEMP=1,NRIGHT(I)
13478            J=J+1
13479            NIN=J
13480            IJ=MAXN*(ICOL-1)+ITEMP
13481            IF(ICOL.LE.MAXCOL)TEMP(J)=V(IJ)
13482            IF(ICOL.EQ.MAXCP1)TEMP(J)=PRED(ITEMP)
13483            IF(ICOL.EQ.MAXCP2)TEMP(J)=RES(ITEMP)
13484            IF(ICOL.EQ.MAXCP3)TEMP(J)=YPLOT(ITEMP)
13485            IF(ICOL.EQ.MAXCP4)TEMP(J)=XPLOT(ITEMP)
13486            IF(ICOL.EQ.MAXCP5)TEMP(J)=X2PLOT(ITEMP)
13487            IF(ICOL.EQ.MAXCP6)TEMP(J)=TAGPLO(ITEMP)
13488 1261     CONTINUE
13489          IWRITE='OFF'
13490          CALL DISTIN(TEMP,NIN,IWRITE,XTEMP1,NOUT,IBUGG3,IERROR)
13491          IF(NOUT.GT.MAXY)THEN
13492            WRITE(ICOUT,999)
13493            CALL DPWRST('XXX','BUG ')
13494            WRITE(ICOUT,1266)
13495 1266       FORMAT('***** ERROR IN CONDITIONING PLOT--')
13496            CALL DPWRST('XXX','BUG ')
13497            WRITE(ICOUT,1267)NOUT
13498 1267       FORMAT('      NUMBER OF DISTINCT SUBSETS, ',I8,
13499     1             ' EXCEEDS THE ')
13500            CALL DPWRST('XXX','BUG ')
13501            WRITE(ICOUT,1268)MAXY
13502 1268       FORMAT('      MAXIMUM ALLOWABLE OF ',I8)
13503            CALL DPWRST('XXX','BUG ')
13504            IERROR='YES'
13505            GOTO9000
13506          ELSE
13507            DO1269KK=1,NOUT
13508              ADIST1(KK)=XTEMP1(KK)
13509 1269       CONTINUE
13510          ENDIF
13511        ENDIF
13512C
13513        IF(ICPLTV.EQ.2.AND.I.EQ.ICC2)THEN
13514          ICOL=ICOLL(I)
13515          J=0
13516          DO1271ITEMP=1,NRIGHT(I)
13517            J=J+1
13518            NIN2=J
13519            IJ=MAXN*(ICOL-1)+ITEMP
13520            IF(ICOL.LE.MAXCOL)TEMP2(J)=V(IJ)
13521            IF(ICOL.EQ.MAXCP1)TEMP2(J)=PRED(ITEMP)
13522            IF(ICOL.EQ.MAXCP2)TEMP2(J)=RES(ITEMP)
13523            IF(ICOL.EQ.MAXCP3)TEMP2(J)=YPLOT(ITEMP)
13524            IF(ICOL.EQ.MAXCP4)TEMP2(J)=XPLOT(ITEMP)
13525            IF(ICOL.EQ.MAXCP5)TEMP2(J)=X2PLOT(ITEMP)
13526            IF(ICOL.EQ.MAXCP6)TEMP2(J)=TAGPLO(ITEMP)
13527 1271     CONTINUE
13528          IWRITE='OFF'
13529          CALL DISTIN(TEMP2,NIN2,IWRITE,XTEMP1,NOUT2,IBUGG3,IERROR)
13530          IF(NOUT2.GT.MAXY)THEN
13531            WRITE(ICOUT,999)
13532            CALL DPWRST('XXX','BUG ')
13533            WRITE(ICOUT,1276)
13534            CALL DPWRST('XXX','BUG ')
13535            WRITE(ICOUT,1277)NOUT2
13536            CALL DPWRST('XXX','BUG ')
13537            WRITE(ICOUT,1278)MAXY
13538            CALL DPWRST('XXX','BUG ')
13539            IERROR='YES'
13540            GOTO9000
13541          ELSE
13542            DO1279KK=1,NOUT
13543              ADIST2(KK)=XTEMP1(KK)
13544 1279       CONTINUE
13545          ENDIF
13546        ENDIF
13547 1276 FORMAT('***** ERROR IN CONDITIONING PLOT--')
13548 1277 FORMAT('      NUMBER OF DISTINCT SUBSETS, ',I8,' EXCEEDS THE ')
13549 1278 FORMAT('      MAXIMUM ALLOWABLE OF ',I8)
13550C
13551 1300 CONTINUE
13552C
13553C               **************************************************
13554C               **   STEP 1--                                   **
13555C               **   SAVE INITIAL SETTINGS                      **
13556C               **************************************************
13557C
13558      ISTEPN='1'
13559      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'COND')
13560     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
13561C
13562      IFLAG=1
13563      CALL DPSPM5(IFLAG,IMPSW,IMPCO,IMPNR,IMPNC,
13564     1            IBUGG2,ISUBRO,IFOUND,IERROR)
13565C
13566      ICPLFZ=ICPLFR
13567      ICPLL2=ICPLLA
13568      IF(ICPLFR.EQ.'CONN')ICPLFR='DEFA'
13569      IF(ICPLFR.EQ.'USER'.AND.ICPLLA.EQ.'BOX')ICPLLA='ON'
13570      IF(ICPLLA.EQ.'BOX ')THEN
13571        ICPLLD='ON'
13572      ENDIF
13573      ICPLTZ=ICPLTA
13574      ICPLPZ=ICPLPT
13575      ICPLLZ=ICPLLD
13576      ICPLZT=ICPLST
13577      ICPLZ2=ICPLS2
13578      ICPLZ3=ICPLS3
13579      ICPLZ4=ICPLS4
13580      ICPLXZ=ICPLXA
13581      ICPLYZ=ICPLYA
13582      ICPLDZ=ICPLDI
13583C
13584      ILFLAX='OFF'
13585      ILFLAY='OFF'
13586      IF(IY1MIN.EQ.'FIXE'.AND.IY1MAX.EQ.'FIXE')THEN
13587        ILFLAY='ON'
13588      ENDIF
13589      IF(IX1MIN.EQ.'FIXE'.AND.IX2MAX.EQ.'FIXE')THEN
13590        ILFLAX='ON'
13591      ENDIF
13592C
13593      IFEED9=IFEEDB
13594      IFLGIN='OFF'
13595      IFLGY='OFF'
13596      IFLGX='OFF'
13597C
13598      IF(ICPLTA.EQ.'ON'.AND.ICPLPT.EQ.'PLOT')THEN
13599        ISHIFT=ILOCQ-1
13600        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
13601     1              IBUGG2,IERROR)
13602        IF(IERROR.EQ.'YES')GOTO9000
13603        ISHIFT=NUMVAR-1
13604        CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
13605     1              IBUGG2,IERROR)
13606        IF(IERROR.EQ.'YES')GOTO9000
13607        DO1509I=1,ISHIFT
13608          IHARG(I)=IVARN1(I)
13609          IHARG2(I)=IVARN2(I)
13610 1509   CONTINUE
13611        NUMVAR=NUMVAR-1
13612        IF(IPLTTY.EQ.'UNIV')THEN
13613          IF(NUMVAR.LT.1)GOTO9000
13614        ELSEIF(IPLTTY.EQ.'BIVA')THEN
13615          IF(NUMVAR.LT.2)GOTO9000
13616        ENDIF
13617        ILOCQ=ISHIFT+1
13618      ENDIF
13619C
13620      IMPSW3=IMPSW
13621      IMPCO2=IMPCO
13622      IMPNR2=IMPNR
13623      IMPNC2=IMPNC
13624      IMPSW='ON'
13625      IMPCO=1
13626      IMPCO9=IMPCO
13627C
13628C  DETERMINE NUMBER OF ROWS AND COLUMNS FOR PLOT.  BASED ON
13629C  BOTH THE NUMBER OF RESPONSE VARIABLES AND NUMBER OF DISTINCT
13630C  VALUES IN THE CONDITIONING VARIABLES.
13631C
13632      IF(ICPLRV.EQ.1)THEN
13633        IF(ICPLTV.EQ.1)THEN
13634          NPLOTS=NOUT
13635          IF(IMPNR*IMPNC.LT.NPLOTS)THEN
13636            IMPNC=INT(SQRT(REAL(NPLOTS-1)))+1
13637            IMPNR=1
13638            IF(NPLOTS.GE.11)THEN
13639              IMPNR=INT(NPLOTS/IMPNC)+1
13640            ELSEIF(NPLOTS.GE.7)THEN
13641              IMPNR=3
13642            ELSEIF(NPLOTS.GE.3)THEN
13643              IMPNR=2
13644            ENDIF
13645          ENDIF
13646          IFACTV=NPLOTS
13647        ELSE
13648          NPLOTS=NOUT*NOUT2
13649          IMPNR=NOUT
13650          IMPNC=NOUT2
13651          IFACTV=NPLOTS
13652        ENDIF
13653      ELSE
13654        IF(ICPLTV.EQ.1)THEN
13655          IMPNR=ICPLRV
13656          IMPNC=NOUT
13657          NPLOTS=IMPNR*IMPNC
13658          IFACTV=NOUT
13659        ELSE
13660          IMPNR=ICPLRV*NOUT
13661          IMPNC=NOUT2
13662          NPLOTS=IMPNR*IMPNC
13663          IFACTV=NOUT*NOUT2
13664        ENDIF
13665      ENDIF
13666C
13667      IROWT=ICPLRV
13668      ICOLT=IFACTV
13669      IF(ICPLLA.EQ.'BOX')THEN
13670        IMPNR=IMPNR+1
13671        IMPNC=IMPNC+1
13672        IROWT=ICPLRV+1
13673        ICOLT=IFACTV+1
13674      ENDIF
13675C
13676      IXAXIS=0
13677      IYAXIS=0
13678C
13679C  2-VARIABLE PLOTS
13680C
13681      IF(ICPLPT.EQ.'PLOT')THEN
13682        ICT='PLOT'
13683        IC2T='    '
13684        NCCOMM=0
13685        IPLOTT='PLOT'
13686        IFLGIN='NO'
13687        IF((IY1MIN.EQ.'FLOA'.AND.IY1MAX.EQ.'FLOA').OR.
13688     1     (IX1MIN.EQ.'FLOA'.AND.IX1MAX.EQ.'FLOA'))THEN
13689          IF((PCPYLL(1).EQ.CPUMIN.AND.PCPYUL(1).EQ.CPUMIN).OR.
13690     1       (PCPXLL(1).EQ.CPUMIN.AND.PCPYUL(1).EQ.CPUMIN))THEN
13691            IFLGIN='YES'
13692            IFLGY='ON'
13693            IFLGX='ON'
13694          ENDIF
13695        ENDIF
13696        GOTO6999
13697      ENDIF
13698      IF(ICPLPT.EQ.'STAT')THEN
13699        ICT=ICPLST
13700        IC2T=ICPLS2
13701        NCCOMM=0
13702        IF(ICPLS3.NE.'    ')THEN
13703          NCCOMM=NCCOMM+1
13704          IHT(NCCOMM)=ICPLS3
13705          IH2T(NCCOMM)=ICPLS4
13706        ENDIF
13707        NCCOMM=NCCOMM+1
13708        IHT(NCCOMM)='PLOT'
13709        IH2T(NCCOMM)='    '
13710        IPLOTT='STAT'
13711        IFLGIN='NO'
13712        GOTO6999
13713      ENDIF
13714      IF(ICPLPT.EQ.'BIHI')THEN
13715        ICT='RELA'
13716        IC2T='TIVE'
13717        IHT(1)='BIHI'
13718        IH2T(1)='STOG'
13719        NCCOMM=1
13720        IPLOTT='BIHI'
13721        IFLGIN='NO'
13722        IF(IY1MIN.EQ.'FLOA'.AND.IY1MAX.EQ.'FLOA')THEN
13723          IF(PCPYLL(1).EQ.CPUMIN.AND.PCPYUL(1).EQ.CPUMIN)THEN
13724            IRHSTG='PERC'
13725            GY1MIN=-0.6
13726            GY1MAX=0.6
13727            GY2MIN=-0.6
13728            GY2MAX=0.6
13729            IY1MIN='FIXE'
13730            IY1MAX='FIXE'
13731            IY2MIN='FIXE'
13732            IY2MAX='FIXE'
13733            IYAXIS=1
13734          ENDIF
13735        ENDIF
13736        GOTO6999
13737      ENDIF
13738C
13739      IF(ICPLPT.EQ.'BOXC')THEN
13740        ICT='BOX '
13741        IC2T='    '
13742        IHT(1)='COX '
13743        IH2T(1)='    '
13744        IHT(2)='LINE'
13745        IH2T(2)='ARIT'
13746        IHT(3)='PLOT'
13747        IH2T(3)='    '
13748        NCCOMM=3
13749        IPLOTT='CBXC'
13750        IFLGIN='NO'
13751        IF(IY1MIN.EQ.'FLOA'.AND.IY1MAX.EQ.'FLOA')THEN
13752          IF(PCPYLL(1).EQ.CPUMIN.AND.PCPYUL(1).EQ.CPUMIN)THEN
13753            GY1MIN=-1.0
13754            GY1MAX=1.0
13755            GY2MIN=-1.0
13756            GY2MAX=1.0
13757            IY1MIN='FIXE'
13758            IY1MAX='FIXE'
13759            IY2MIN='FIXE'
13760            IY2MAX='FIXE'
13761            IYAXIS=1
13762          ENDIF
13763        ENDIF
13764        GOTO6999
13765      ENDIF
13766      IF(ICPLPT.EQ.'QQPL')THEN
13767        ICT='QUAN'
13768        IC2T='TILE'
13769        IHT(1)='QUAN'
13770        IH2T(1)='TILE'
13771        IHT(2)='PLOT'
13772        IH2T(2)='    '
13773        NCCOMM=2
13774        IPLOTT='QQSP'
13775        IFLGIN='NO'
13776        IF((IY1MIN.EQ.'FLOA'.AND.IY1MAX.EQ.'FLOA').OR.
13777     1     (IX1MIN.EQ.'FLOA'.AND.IX1MAX.EQ.'FLOA'))THEN
13778          IF((PCPYLL(1).EQ.CPUMIN.AND.PCPYUL(1).EQ.CPUMIN).OR.
13779     1       (PCPXLL(1).EQ.CPUMIN.AND.PCPYUL(1).EQ.CPUMIN))THEN
13780            IFLGIN='YES'
13781            IFLGY='ON'
13782            IFLGX='ON'
13783          ENDIF
13784        ENDIF
13785        GOTO6999
13786      ENDIF
13787      IF(ICPLPT.EQ.'ROS2')THEN
13788        ICT='ROSE'
13789        IC2T='    '
13790        IHT(1)='PLOT'
13791        IH2T(1)='    '
13792        NCCOMM=1
13793        IPLOTT='ROSE'
13794        IFLGIN='NO'
13795        IFLGY='OFF'
13796        IFLGX='OFF'
13797        GOTO6999
13798      ENDIF
13799CCCCC IF(ICPLPT.EQ.'CROS')THEN
13800CCCCC   GOTO7999
13801CCCCC ENDIF
13802C
13803C 3-D PLOTS
13804C
13805      IF(ICPLPT.EQ.'YACU')THEN
13806        ICT='YATE'
13807        IC2T='S   '
13808        IHT(1)='CUBE'
13809        IH2T(1)='    '
13810        IHT(2)='PLOT'
13811        IH2T(2)='    '
13812        NCCOMM=2
13813        IPLOTT='YACU'
13814        IFLGIN='NO'
13815        GOTO7499
13816      ENDIF
13817      IF(ICPLPT.EQ.'3DPL')THEN
13818        ICT='3D  '
13819        IC2T='    '
13820        IHT(1)='PLOT'
13821        IH2T(1)='    '
13822        NCCOMM=1
13823        IPLOTT='3DPL'
13824        IFLGIN='NO'
13825        GOTO7499
13826      ENDIF
13827C
13828C
13829C  1-VARIABLE PLOTS
13830C
13831      IF(ICPLPT.EQ.'HIST')THEN
13832        ICT='RELA'
13833        IC2T='TIVE'
13834        IHT(1)='HIST'
13835        IH2T(1)='OGRA'
13836        NCCOMM=1
13837        IPLOTT='HIST'
13838        IFLGIN='NO'
13839        IF(IY1MIN.EQ.'FLOA'.AND.IY1MAX.EQ.'FLOA')THEN
13840          IF(PCPYLL(1).EQ.CPUMIN.AND.PCPYUL(1).EQ.CPUMIN)THEN
13841            IRHSTG='PERC'
13842            GY1MIN=0.0
13843            GY1MAX=0.6
13844            GY2MIN=0.0
13845            GY2MAX=0.6
13846            IY1MIN='FIXE'
13847            IY1MAX='FIXE'
13848            IY2MIN='FIXE'
13849            IY2MAX='FIXE'
13850            IYAXIS=1
13851          ENDIF
13852        ENDIF
13853        GOTO5999
13854      ENDIF
13855      IF(ICPLPT.EQ.'DENS')THEN
13856        ICT='KERN'
13857        IC2T='EL  '
13858        IHT(1)='DENS'
13859        IH2T(1)='ITY '
13860        IHT(2)='PLOT'
13861        IH2T(2)='    '
13862        NCCOMM=2
13863        IPLOTT='CDEN'
13864        IFLGIN='NO'
13865        IF(IY1MIN.EQ.'FLOA'.AND.IY1MAX.EQ.'FLOA')THEN
13866          IF(PCPYLL(1).EQ.CPUMIN.AND.PCPYUL(1).EQ.CPUMIN)THEN
13867            IRHSTG='PERC'
13868            GY1MIN=0.0
13869            GY1MAX=0.6
13870            GY2MIN=0.0
13871            GY2MAX=0.6
13872            IY1MIN='FIXE'
13873            IY1MAX='FIXE'
13874            IY2MIN='FIXE'
13875            IY2MAX='FIXE'
13876            IYAXIS=1
13877          ENDIF
13878        ENDIF
13879        GOTO5999
13880      ENDIF
13881      IF(ICPLPT.EQ.'RUNS')THEN
13882        ICT='RUN '
13883        IC2T='    '
13884        IHT(1)='SEQU'
13885        IH2T(1)='ENCE'
13886        IHT(2)='PLOT'
13887        IH2T(2)='    '
13888        NCCOMM=2
13889        IPLOTT='CRUN'
13890        IFLGIN='NO'
13891        IF(IY1MIN.EQ.'FLOA'.AND.IY1MAX.EQ.'FLOA')THEN
13892          IF(PCPYLL(1).EQ.CPUMIN.AND.PCPYUL(1).EQ.CPUMIN)THEN
13893            IFLGIN='YES'
13894            IFLGY='ON'
13895            IFLGX='OFF'
13896          ENDIF
13897        ENDIF
13898        GOTO5999
13899      ENDIF
13900      IF(ICPLPT.EQ.'PERC')THEN
13901        ICT='PERC'
13902        IC2T='ENT '
13903        IHT(1)='POIN'
13904        IH2T(1)='T   '
13905        IHT(2)='PLOT'
13906        IH2T(2)='    '
13907        NCCOMM=2
13908        IPLOTT='CPER'
13909        IFLGIN='NO'
13910        IF(IY1MIN.EQ.'FLOA'.AND.IY1MAX.EQ.'FLOA')THEN
13911          IF(PCPYLL(1).EQ.CPUMIN.AND.PCPYUL(1).EQ.CPUMIN)THEN
13912            IFLGIN='YES'
13913            IFLGY='ON'
13914            IFLGX='OFF'
13915          ENDIF
13916        ENDIF
13917        GOTO5999
13918      ENDIF
13919      IF(ICPLPT.EQ.'AUTO')THEN
13920        ICT='AUTO'
13921        IC2T='CORR'
13922        IHT(1)='PLOT'
13923        IH2T(1)='    '
13924        NCCOMM=1
13925        IPLOTT='CRUN'
13926        IFLGIN='NO'
13927        IF(IY1MIN.EQ.'FLOA'.AND.IY1MAX.EQ.'FLOA')THEN
13928          IF(PCPYLL(1).EQ.CPUMIN.AND.PCPYUL(1).EQ.CPUMIN)THEN
13929            GY1MIN=-1.0
13930            GY1MAX=1.0
13931            GY2MIN=-1.0
13932            GY2MAX=1.0
13933            IY1MIN='FIXE'
13934            IY1MAX='FIXE'
13935            IY2MIN='FIXE'
13936            IY2MAX='FIXE'
13937            IYAXIS=1
13938          ENDIF
13939        ENDIF
13940        GOTO5999
13941      ENDIF
13942      IF(ICPLPT.EQ.'SPEC')THEN
13943        ICT='SPEC'
13944        IC2T='TRAL'
13945        IHT(1)='PLOT'
13946        IH2T(1)='    '
13947        NCCOMM=1
13948        IPLOTT='SPEC'
13949        IFLGIN='NO'
13950        GOTO5999
13951      ENDIF
13952      IF(ICPLPT.EQ.'ROSE')THEN
13953        ICT='ROSE'
13954        IC2T='    '
13955        IHT(1)='PLOT'
13956        IH2T(1)='    '
13957        NCCOMM=1
13958        IPLOTT='ROSE'
13959        IFLGIN='NO'
13960        GOTO5999
13961      ENDIF
13962      IF(ICPLPT.EQ.'LAG ')THEN
13963        ICT='LAG '
13964        IC2T='    '
13965        IHT(1)='PLOT'
13966        IH2T(1)='    '
13967        NCCOMM=1
13968        IPLOTT='LAG '
13969        IFLGIN='NO'
13970        IF((IY1MIN.EQ.'FLOA'.AND.IY1MAX.EQ.'FLOA').OR.
13971     1     (IX1MIN.EQ.'FLOA'.AND.IX1MAX.EQ.'FLOA'))THEN
13972          IF((PCPYLL(1).EQ.CPUMIN.AND.PCPYUL(1).EQ.CPUMIN).OR.
13973     1       (PCPXLL(1).EQ.CPUMIN.AND.PCPYUL(1).EQ.CPUMIN))THEN
13974            IFLGIN='YES'
13975            IFLGY='ON'
13976            IFLGX='ON'
13977          ENDIF
13978        ENDIF
13979        GOTO5999
13980      ENDIF
13981      IF(ICPLPT.EQ.'PROB')THEN
13982        ICT=ICPLP1
13983        IC2T='    '
13984        NCCOMM=0
13985        IF(ICPLP2.NE.'    ')THEN
13986          NCCOMM=NCCOMM+1
13987          IHT(NCCOMM)=ICPLP2
13988          IH2T(NCCOMM)='    '
13989        ENDIF
13990        IF(ICPLP3.NE.'    ')THEN
13991          NCCOMM=NCCOMM+1
13992          IHT(NCCOMM)=ICPLP3
13993          IH2T(NCCOMM)='    '
13994        ENDIF
13995        IF(ICPLP4.NE.'    ')THEN
13996          NCCOMM=NCCOMM+1
13997          IHT(NCCOMM)=ICPLP4
13998          IH2T(NCCOMM)='    '
13999        ENDIF
14000        IF(ICPLP5.NE.'    ')THEN
14001          NCCOMM=NCCOMM+1
14002          IHT(NCCOMM)=ICPLP5
14003          IH2T(NCCOMM)='    '
14004        ENDIF
14005        NCCOMM=NCCOMM+1
14006        IHT(NCCOMM)='PROB'
14007        IH2T(NCCOMM)='ABIL'
14008        NCCOMM=NCCOMM+1
14009        IHT(NCCOMM)='PLOT'
14010        IH2T(NCCOMM)='    '
14011        IPLOTT='PROB'
14012        IFLGIN='NO'
14013        IF((IY1MIN.EQ.'FLOA'.AND.IY1MAX.EQ.'FLOA').OR.
14014     1     (IX1MIN.EQ.'FLOA'.AND.IX1MAX.EQ.'FLOA'))THEN
14015          IF((PCPYLL(1).EQ.CPUMIN.AND.PCPYUL(1).EQ.CPUMIN).OR.
14016     1       (PCPXLL(1).EQ.CPUMIN.AND.PCPYUL(1).EQ.CPUMIN))THEN
14017            IFLGIN='YES'
14018            IFLGY='ON'
14019            IFLGX='ON'
14020          ENDIF
14021        ENDIF
14022        GOTO5999
14023      ENDIF
14024      IF(ICPLPT.EQ.'PPCC')THEN
14025        ICT=ICPLC1
14026        IC2T='    '
14027        NCCOMM=0
14028        IF(ICPLC2.NE.'    ')THEN
14029          NCCOMM=NCCOMM+1
14030          IHT(NCCOMM)=ICPLC2
14031          IH2T(NCCOMM)='    '
14032        ENDIF
14033        IF(ICPLC3.NE.'    ')THEN
14034          NCCOMM=NCCOMM+1
14035          IHT(NCCOMM)=ICPLC3
14036          IH2T(NCCOMM)='    '
14037        ENDIF
14038        IF(ICPLC4.NE.'    ')THEN
14039          NCCOMM=NCCOMM+1
14040          IHT(NCCOMM)=ICPLC4
14041          IH2T(NCCOMM)='    '
14042        ENDIF
14043        IF(ICPLC5.NE.'    ')THEN
14044          NCCOMM=NCCOMM+1
14045          IHT(NCCOMM)=ICPLC5
14046          IH2T(NCCOMM)='    '
14047        ENDIF
14048        NCCOMM=NCCOMM+1
14049        IHT(NCCOMM)='PPCC'
14050        IH2T(NCCOMM)='    '
14051        NCCOMM=NCCOMM+1
14052        IHT(NCCOMM)='PLOT'
14053        IH2T(NCCOMM)='    '
14054        IPLOTT='PPCC'
14055        IFLGIN='NO'
14056        GOTO5999
14057      ENDIF
14058      GOTO8000
14059C
14060C               *******************************************
14061C               **   STEP 21--                           **
14062C               **   GENERATE THE RUN SEQUENCE    PLOTS  **
14063C               **   GENERATE THE HISTOGRAM       PLOTS  **
14064C               **   GENERATE THE PERCENTILE      PLOTS  **
14065C               **   GENERATE THE AUTOCORRELATION PLOTS  **
14066C               **   GENERATE THE SPECTRAL        PLOTS  **
14067C               **   GENERATE THE LAG             PLOTS  **
14068C               **   GENERATE THE PROBABILITY     PLOTS  **
14069C               **   GENERATE THE PPCC            PLOTS  **
14070C               **   GENERATE THE KERNEL DENSITY  PLOTS  **
14071C               *******************************************
14072C
14073 5999 CONTINUE
14074C
14075C  IF NO PRIOR LIMITS SET FOR Y AXIS, USE 0 TO 0.6 (THIS MAY NOT
14076C  BE OPTIMAL, BUT IT WILL ALWAYS SHOW ALL THE DATA).
14077C
14078      IF(NPLOTS.LT.1)GOTO8000
14079C
14080      ISHIFT=ILOCQ-1
14081      CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
14082     1IBUGG2,IERROR)
14083      IF(IERROR.EQ.'YES')GOTO8000
14084C
14085C  CREATE BASIC COMMAND LINE, FOR EXAMPLE:
14086C    RELATIVE HISTOGRAM Y SUBSET COND1 = <VAL> SUBSET COND2 = <VAL>
14087C  WHERE COND2 IS OPTIONAL
14088C
14089C  FOR SOME PLOT TYPES, NEED TO DO AN INITIAL PLOT TO SET PLOT LIMITS
14090C
14091      ISHIFT=NCCOMM+1
14092      IF(ICPLTV.GE.1)ISHIFT=ISHIFT+4
14093      IF(ICPLTV.GE.2)ISHIFT=ISHIFT+4
14094      CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
14095     1            IBUGG2,IERROR)
14096      ICOM=ICT
14097      ICOM2=IC2T
14098      DO6006II=1,NCCOMM
14099        IHARG(II)=IHT(II)
14100        IHARG2(II)=IH2T(II)
14101        IARGT(II)='WORD'
14102 6006 CONTINUE
14103      NWORD=NCCOMM+1
14104      NPOS=NWORD
14105      IHARG(NWORD)=IVARN1(1)
14106      IHARG2(NWORD)=IVARN2(1)
14107      IARGT(NWORD)='WORD'
14108C
14109      NWORD=NWORD+1
14110      IHARG(NWORD)='SUBS'
14111      IHARG2(NWORD)='ET  '
14112      IARGT(NWORD)='WORD'
14113C
14114      NWORD=NWORD+1
14115      IHARG(NWORD)=IVARN1(ICC1)
14116      IHARG2(NWORD)=IVARN2(ICC1)
14117      IARGT(NWORD)='WORD'
14118C
14119      NWORD=NWORD+1
14120      IHARG(NWORD)='=   '
14121      IHARG2(NWORD)='    '
14122      IARGT(NWORD)='WORD'
14123C
14124      NWORD=NWORD+1
14125      IHARG(NWORD)='0  '
14126      IHARG2(NWORD)='    '
14127      IARGT(NWORD)='NUMB'
14128      NPOS1=NWORD
14129C
14130      IF(ICPLTV.EQ.2)THEN
14131        NWORD=NWORD+1
14132        IHARG(NWORD)='SUBS'
14133        IHARG2(NWORD)='ET  '
14134        IARGT(NWORD)='WORD'
14135C
14136        NWORD=NWORD+1
14137        IHARG(NWORD)=IVARN1(ICC2)
14138        IHARG2(NWORD)=IVARN2(ICC2)
14139        IARGT(NWORD)='WORD'
14140C
14141        NWORD=NWORD+1
14142        IHARG(NWORD)='=   '
14143        IHARG2(NWORD)='    '
14144        IARGT(NWORD)='WORD'
14145C
14146        NWORD=NWORD+1
14147        IHARG(NWORD)='0  '
14148        IHARG2(NWORD)='    '
14149        IARGT(NWORD)='NUMB'
14150        NPOS2=NWORD
14151      ENDIF
14152      NARGT=NUMARG
14153C
14154      DO6020I=1,NARGT
14155        IHT(I)=IHARG(I)
14156        IH2T(I)=IHARG2(I)
14157        IARGTT(I)=IARGT(I)
14158        ARGT(I)=ARG(I)
14159 6020 CONTINUE
14160C
14161      IPLOT=0
14162      DO6200IRES=1,IROWT
14163C
14164C  CREATE INITIAL PLOT TO DETERMINE SCALE
14165C
14166      IF(IFLGIN.EQ.'YES')THEN
14167        ISHIFT=NWORD
14168        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
14169     1              IBUGG2,IERROR)
14170        ISHIFT=NCCOMM+1
14171        CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
14172     1              IBUGG2,IERROR)
14173        ICOM=ICT
14174        ICOM2=IC2T
14175        DO6210II=1,NCCOMM
14176          IHARG(II)=IHT(II)
14177          IHARG2(II)=IH2T(II)
14178          IARGT(II)='WORD'
14179 6210   CONTINUE
14180        NTEMP=NCCOMM+1
14181        IHARG(NTEMP)=IVARN1(IRES)
14182        IHARG2(NTEMP)=IVARN2(IRES)
14183        IARGT(NTEMP)='WORD'
14184C
14185C  GENERATE THE DUMMY PLOT
14186C
14187        ICHAPA(1)='BLAN'
14188        ILINPA(1)='BLAN'
14189        IBARSW(1)='OFF'
14190        ISPISW(1)='OFF'
14191C
14192        GY1MIN=CPUMIN
14193        GY1MAX=CPUMAX
14194        GY2MIN=CPUMIN
14195        GY2MAX=CPUMAX
14196        GX1MIN=CPUMIN
14197        GX1MAX=CPUMAX
14198        GX2MIN=CPUMIN
14199        GX2MAX=CPUMAX
14200        IY1MIN='FLOA'
14201        IY1MAX='FLOA'
14202        IY2MIN='FLOA'
14203        IY2MAX='FLOA'
14204        IX1MIN='FLOA'
14205        IX1MAX='FLOA'
14206        IX2MIN='FLOA'
14207        IX2MAX='FLOA'
14208        CALL MAINGR(ANOPL1,ANOPL2,NPLOTV,NPLOTP,NS,ICASPL,
14209     1              MAXNPP,ISEED,IBOOSS,
14210     1              IX1TSV,IX2TSV,IY1TSV,IY2TSV,
14211     1              IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV,
14212     1              BARHEF,BARWEF,
14213     1              IRHSTG,IHSTCW,IHSTEB,IHSTOU,IASHWT,IHSTMC,IHSTOP,
14214     1              ICAPSW,IFORSW,
14215     1              IGUIFL,IERRFA,
14216     1              IAND1,IAND2,ICONT,NUMHPP,NUMVPP,
14217CCCCC1              TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT,
14218     1              MAXNXT,
14219     1              ISUBRO,IFOUND,IERROR)
14220C
14221        IX1TSW='OFF'
14222        IX1ZSW='OFF'
14223        IX2TSW='OFF'
14224        IX2ZSW='OFF'
14225        IY1TSW='OFF'
14226        IY1ZSW='OFF'
14227        IY2TSW='OFF'
14228        IY2ZSW='OFF'
14229        IX1FSW='OFF'
14230        IX2FSW='OFF'
14231        IY1FSW='OFF'
14232        IY2FSW='OFF'
14233        IERASW='ON'
14234        DO6250I=1,MAXCH
14235          IX1LTE(I)='    '
14236          IX2LTE(I)='    '
14237          IY1LTE(I)='    '
14238          IY2LTE(I)='    '
14239 6250   CONTINUE
14240        NCX1LA=0
14241        NCX2LA=0
14242        NCY1LA=0
14243        NCY2LA=0
14244        NCTITL=0
14245        ICONT=IDCONT(1)
14246        NUMHPP=IDNHPP(1)
14247        IPOWE=IDPOWE(1)
14248        IMPARG=2
14249        CALL DPGRAP(Y,X,X3D,D,N,NPLOTP,ICASPL,ICONT,IPOWE,NUMHPP,
14250     1              XMATN,YMATN,XMITN,YMITN,
14251     1              ISQUAR,
14252     1              IVGMSW,IHGMSW,
14253     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,
14254     1              IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,
14255     1              YPLOT,XPLOT,X2PLOT,TAGPLO,
14256     1              IMPSW,IMPNR,IMPNC,IMPCO,IMPCO9,
14257     1              IMPARG,
14258     1              PMXMIN,PMXMAX,PMYMIN,PMYMAX,
14259     1              MAXCOL,
14260     1              DSIZE,DSYMB,DCOLOR,DFILL,
14261     1              ICAPSW,
14262     1              IBUGUG,IBUGU2,IBUGU3,IBUGU4,ISUBRO,
14263     1              IERROR)
14264C
14265        ICNTPL=ICNTPL+1
14266        IF(NPLOTP.GT.0)THEN
14267          DO3115II=1,NPLOTP
14268            WRITE(IOUNI5,3118)ICNTPL,Y(II),X(II),D(II)
14269 3115     CONTINUE
14270 3118     FORMAT(I12,3E15.7)
14271        ENDIF
14272C
14273        IF(IERROR.EQ.'NO')IAND1=IAND2
14274        IMPCO=IMPCO-1
14275        IF(IFLGY.EQ.'ON')THEN
14276          GY1MIN=FY1MNZ
14277          GY1MAX=FY1MXZ
14278          GY2MIN=FY2MNZ
14279          GY2MAX=FY2MXZ
14280          IY1MIN='FIXE'
14281          IY1MAX='FIXE'
14282          IY2MIN='FIXE'
14283          IY2MAX='FIXE'
14284        ELSE
14285          GY1MIN=GY1MNS
14286          GY1MAX=GY1MXS
14287          GY2MIN=GY2MNS
14288          GY2MAX=GY2MXS
14289          IY1MIN=IY1MNS
14290          IY1MAX=IY1MXS
14291          IY2MIN=IY2MNS
14292          IY2MAX=IY2MXS
14293        ENDIF
14294        IF(IFLGX.EQ.'ON')THEN
14295          GX1MIN=FX1MNZ
14296          GX1MAX=FX1MXZ
14297          GX2MIN=FX2MNZ
14298          GX2MAX=FX2MXZ
14299          IX1MIN='FIXE'
14300          IX1MAX='FIXE'
14301          IX2MIN='FIXE'
14302          IX2MAX='FIXE'
14303        ELSE
14304          GX1MIN=GX1MNS
14305          GX1MAX=GX1MXS
14306          GX2MIN=GX2MNS
14307          GX2MAX=GX2MXS
14308          IX1MIN=IX1MNS
14309          IX1MAX=IX1MXS
14310          IX2MIN=IX2MNS
14311          IX2MAX=IX2MXS
14312        ENDIF
14313C
14314        IX1TSW=IX1TSV
14315        IX1ZSW=IX1ZSV
14316        IX2TSW=IX2TSV
14317        IX2ZSW=IX2ZSV
14318        IY1TSW=IY1TSV
14319        IY1ZSW=IY1ZSV
14320        IY2TSW=IY2TSV
14321        IY2ZSW=IY2ZSV
14322        IX1FSW=IX1FSV
14323        IX2FSW=IX2FSV
14324        IY1FSW=IY1FSV
14325        IY2FSW=IY2FSV
14326        IERASW='OFF'
14327C
14328C  RESTORE COMMAND LINE
14329C
14330        ISHIFT=NARGT-NUMARG
14331        IF(ISHIFT.GT.0)THEN
14332          CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
14333     1                IBUGG2,IERROR)
14334        ELSEIF(ISHIFT.LT.0)THEN
14335          ISHIFT=-ISHIFT
14336          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
14337     1                IBUGG2,IERROR)
14338        ENDIF
14339        DO6220II=1,NARGT
14340          IHARG(II)=IHT(II)
14341          IHARG2(II)=IH2T(II)
14342          IARGT(II)=IARGTT(II)
14343          ARG(II)=ARGT(II)
14344 6220   CONTINUE
14345      ENDIF
14346C
14347      DO6100IFAC=1,ICOLT
14348C
14349        IPLOT=IPLOT+1
14350        IX=IXC1
14351        IXLIST=1
14352        IROW=INT(IPLOT/IMPNC)+1
14353        IF(MOD(IPLOT,IMPNC).EQ.0)IROW=IROW-1
14354        ICOL=MOD(IPLOT,IMPNC)
14355        IF(ICOL.EQ.0)ICOL=IMPNC
14356C
14357        IHARG(NPOS)=IVARN1(IRES)
14358        IHARG2(NPOS)=IVARN2(IRES)
14359C
14360        IEMPTY='NO'
14361        IF(ICPLLA.EQ.'BOX')THEN
14362          ICOL=ICOL-1
14363          IF(ICOL.EQ.0)IEMPTY='YES'
14364          IF(IROW.EQ.IMPNR)IEMPTY='YES'
14365        ENDIF
14366C
14367        IF(ICPLRV.EQ.1)THEN
14368          IF(ICPLTV.EQ.1)THEN
14369            ARG(NPOS1)=ADIST1(IFAC)
14370          ELSE
14371            ARG(NPOS1)=ADIST1(IROW)
14372            ARG(NPOS2)=ADIST2(ICOL)
14373          ENDIF
14374        ELSE
14375          IF(ICPLTV.EQ.1)THEN
14376            ARG(NPOS1)=ADIST1(IFAC)
14377          ELSE
14378            ARG(NPOS1)=ADIST1(MOD(IROW-1,ICPLRV)+1)
14379            ARG(NPOS2)=ADIST2(ICOL)
14380          ENDIF
14381        ENDIF
14382C
14383        IF(IEMPTY.EQ.'YES')THEN
14384          DO6104I=1,MAXSUB
14385            ISU2SW(I)=ISUBSW(I)
14386            ISUBSW(I)='OFF'
14387 6104     CONTINUE
14388        ENDIF
14389        ICASPL='COND'
14390        IOPTN=3
14391        IDY=IRES
14392        IDX=1
14393        CALL DPSPM4(ICASPL,IOPTN,IDX,IDY,
14394     1              ISUBNU,ISUBSW,
14395     1              ASUBXL,ASUBXU,ASUBYL,ASUBYU,
14396     1              ISUBN9,ISUBSZ,
14397     1              ASBXL2,ASBXU2,ASBYL2,ASBYU2,
14398     1              PCPXSL,PCPXSU,PCPYSL,PCPYSU,
14399     1              IBUGG2,ISUBRO,IERROR)
14400C
14401        CALL DPSPM1(ICASPL,IVARN1,IVARN2,ICOLL,
14402     1              IMPNR,IMPNC,IROW,ICOL,IRES,IX,IPLOT,
14403     1              NPLOTS,NUMVAR,
14404     1              ICHAP2,ILINP2,
14405     1              GY1MNS,GY1MXS,GY2MNS,GY2MXS,
14406     1              GX1MNS,GX1MXS,GX2MNS,GX2MXS,
14407     1              IY1MNS,IY1MXS,IY2MNS,IY2MXS,
14408     1              IX1MNS,IX1MXS,IX2MNS,IX2MXS,
14409     1              IX1TSV,IX2TSV,IY1TSV,IY2TSV,
14410     1              IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV,
14411     1              PX1LD2,PX2LD2,
14412     1              IY1LJ2,IY1LD2,PY1LD2,PY1LA2,
14413     1              IX1LT2,IX2LT2,IY1LT2,IY2LT2,
14414     1              NCX1L2,NCX2L2,NCY1L2,NCY2L2,
14415     1              PCPXLL,PCPXUL,PCPYLL,PCPYUL,IXLIST,
14416     1              ICPLLA,ISPMLD,IPLOTT,ICPLFR,ICPLXA,ICPLYA,
14417     1              ISPMDI,ISPX1L,
14418     1              ISPMXT,ISPMXL,ISPMYT,ISPMYL,
14419     1              ICPLTD,PCPLTD,IVNMEX,
14420     1              IBUGG2,ISUBRO)
14421C
14422CCCCC   ITITTE(1)='S'
14423CCCCC   ITITTE(2)='U'
14424CCCCC   ITITTE(3)='B'
14425CCCCC   ITITTE(4)='S'
14426CCCCC   ITITTE(5)='E'
14427CCCCC   ITITTE(6)='T'
14428CCCCC   ITITTE(7)=' '
14429CCCCC   NCTEMP=7
14430        NCTEMP=0
14431        DO6161I=1,4
14432          IF(IVARN1(ICC1)(I:I).NE.' ')THEN
14433            NCTEMP=NCTEMP+1
14434            ITITTE(NCTEMP)=IVARN1(ICC1)(I:I)
14435          ENDIF
14436 6161   CONTINUE
14437        DO6163I=1,4
14438          IF(IVARN2(ICC1)(I:I).NE.' ')THEN
14439            NCTEMP=NCTEMP+1
14440            ITITTE(NCTEMP)=IVARN2(ICC1)(I:I)
14441          ENDIF
14442 6163   CONTINUE
14443        NCTEMP=NCTEMP+1
14444        ITITTE(NCTEMP)=' '
14445        NCTEMP=NCTEMP+1
14446        ITITTE(NCTEMP)='='
14447        NCTEMP=NCTEMP+1
14448        ITITTE(NCTEMP)=' '
14449        NCTEMP=NCTEMP+1
14450        VAL=ARG(NPOS1)
14451        IVAL=INT(VAL+0.5)
14452        IF(VAL.LT.0.0)IVAL=INT(VAL-0.5)
14453        CALL DPCONH(IVAL,VAL,ITITTE(NCTEMP),NH,IBUGG2,IERROR)
14454        NCTEMP=NCTEMP+NH-1
14455        IF(ICPLTV.EQ.1)GOTO6189
14456        DO6169I=1,15
14457          NCTEMP=NCTEMP+1
14458          ITITTE(NCTEMP)=' '
14459 6169   CONTINUE
14460        DO6171I=1,4
14461          IF(IVARN1(ICC2)(I:I).NE.' ')THEN
14462            NCTEMP=NCTEMP+1
14463            ITITTE(NCTEMP)=IVARN1(ICC2)(I:I)
14464          ENDIF
14465 6171   CONTINUE
14466        DO6173I=1,4
14467          IF(IVARN2(ICC2)(I:I).NE.' ')THEN
14468            NCTEMP=NCTEMP+1
14469            ITITTE(NCTEMP)=IVARN2(ICC2)(I:I)
14470          ENDIF
14471 6173   CONTINUE
14472        NCTEMP=NCTEMP+1
14473        ITITTE(NCTEMP)=' '
14474        NCTEMP=NCTEMP+1
14475        ITITTE(NCTEMP)='='
14476        NCTEMP=NCTEMP+1
14477        ITITTE(NCTEMP)=' '
14478        NCTEMP=NCTEMP+1
14479        VAL=ARG(NPOS2)
14480        IVAL=INT(VAL+0.5)
14481        IF(VAL.LT.0.0)IVAL=INT(VAL-0.5)
14482        CALL DPCONH(IVAL,VAL,ITITTE(NCTEMP),NH,IBUGG2,IERROR)
14483        NCTEMP=NCTEMP+NH-1
14484 6189   CONTINUE
14485        NCTITL=NCTEMP
14486        IF(ICPLFR.EQ.'DEFA')THEN
14487          PTITDS=-ABS(PTITDZ)
14488        ENDIF
14489C
14490        CALL MAINGR(ANOPL1,ANOPL2,NPLOTV,NPLOTP,NS,ICASPL,
14491     1              MAXNPP,ISEED,IBOOSS,
14492     1              IX1TSV,IX2TSV,IY1TSV,IY2TSV,
14493     1              IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV,
14494     1              BARHEF,BARWEF,
14495     1              IRHSTG,IHSTCW,IHSTEB,IHSTOU,IASHWT,IHSTMC,IHSTOP,
14496     1              ICAPSW,IFORSW,
14497     1              IGUIFL,IERRFA,
14498     1              IAND1,IAND2,ICONT,NUMHPP,NUMVPP,
14499CCCCC1              TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT,
14500     1              MAXNXT,
14501     1              ISUBRO,IFOUND,IERROR)
14502        IF(IEMPTY.EQ.'NO')THEN
14503          CALL DPSPM3(ICASPL,IOUNI5,
14504     1                IROW,ICOL,
14505     1                PX2LD2,NPLOTP,
14506     1                IFORSW,
14507     1                IFPX2L,ISPX2P,ISPX2S,
14508     1                IHRIGH,IHRIG2,IHWUSE,
14509     1                ISUBN1,ISUBN2,MESSAG,
14510     1                IBUGG2,ISUBRO,IERROR)
14511        ENDIF
14512C
14513        ICONT=IDCONT(1)
14514        IPOWE=IDPOWE(1)
14515        NUMHPP=IDNHPP(1)
14516        IMPARG=2
14517        CALL DPGRAP(Y,X,X3D,D,N,NPLOTP,ICASPL,ICONT,IPOWE,NUMHPP,
14518     1              XMATN,YMATN,XMITN,YMITN,
14519     1              ISQUAR,
14520     1              IVGMSW,IHGMSW,
14521     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,
14522     1              IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,
14523     1              YPLOT,XPLOT,X2PLOT,TAGPLO,
14524     1              IMPSW,IMPNR,IMPNC,IMPCO,IMPCO9,
14525     1              IMPARG,
14526     1              PMXMIN,PMXMAX,PMYMIN,PMYMAX,
14527     1              MAXCOL,
14528     1              DSIZE,DSYMB,DCOLOR,DFILL,
14529     1              ICAPSW,
14530     1              IBUGUG,IBUGU2,IBUGU3,IBUGU4,ISUBRO,
14531     1              IERROR)
14532C
14533        ICNTPL=ICNTPL+1
14534        IF(NPLOTP.GT.0)THEN
14535          DO3315II=1,NPLOTP
14536            WRITE(IOUNI5,3118)ICNTPL,Y(II),X(II),D(II)
14537 3315     CONTINUE
14538        ENDIF
14539C
14540        IF(IERROR.EQ.'NO')IAND1=IAND2
14541        IF(IERROR.EQ.'YES')GOTO6199
14542C
14543        IF(ICPLPT.NE.'PLOT')GOTO6199
14544        IF(ICPLFI.EQ.'NONE')GOTO6199
14545        IF(IEMPTY.EQ.'YES')GOTO6199
14546C
14547        IMPCO=IMPCO-1
14548        IF(IMPCO.LE.1)IERASW='OFF'
14549C
14550C  NOTE: NO FITTING DONE SINCE ONLY ONE VARIABLE PLOTTED
14551C        HERE.
14552C
14553 6199   CONTINUE
14554        ISHIFT=NARGT-NUMARG
14555        IF(ISHIFT.GT.0)THEN
14556          CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
14557     1                IBUGG2,IERROR)
14558        ELSEIF(ISHIFT.LT.0)THEN
14559          ISHIFT=-ISHIFT
14560          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
14561     1                IBUGG2,IERROR)
14562        ENDIF
14563        ICOM=ICT
14564        ICOM2=IC2T
14565        DO6101II=1,NARGT
14566          IHARG(II)=IHT(II)
14567          IHARG2(II)=IH2T(II)
14568          IARGT(II)=IARGTT(II)
14569          ARG(II)=ARGT(II)
14570 6101   CONTINUE
14571C
14572        PX1LDS=PX1LD2
14573        IF(IYAXIS.EQ.0.AND.IFLGIN.EQ.'NO')THEN
14574          GY1MIN=GY1MNS
14575          GY1MAX=GY1MXS
14576          GY2MIN=GY2MNS
14577          GY2MAX=GY2MXS
14578          IY1MIN=IY1MNS
14579          IY1MAX=IY1MXS
14580          IY2MIN=IY2MNS
14581          IY2MAX=IY2MXS
14582        ENDIF
14583        IF(IXAXIS.EQ.0.AND.IFLGIN.EQ.'NO')THEN
14584          GX1MIN=GX1MNS
14585          GX1MAX=GX1MXS
14586          GX2MIN=GX2MNS
14587          GX2MAX=GX2MXS
14588          IX1MIN=IX1MNS
14589          IX1MAX=IX1MXS
14590          IX2MIN=IX2MNS
14591          IX2MAX=IX2MXS
14592        ENDIF
14593        PX1ZDS=PX1ZD2
14594        PX2ZDS=PX2ZD2
14595        PY1ZDS=PY1ZD2
14596        PY2ZDS=PY2ZD2
14597        IF(IEMPTY.EQ.'YES')THEN
14598          DO6107I=1,MAXSUB
14599            ISUBSW(I)=ISU2SW(I)
14600 6107     CONTINUE
14601        ENDIF
14602        DO6108I=1,100
14603            ICHAPA(I)=ICHAP2(I)
14604            ILINPA(I)=ILINP2(I)
14605            ISPISW(I)=ISPIS2(I)
14606            IBARSW(I)=IBARS2(I)
14607 6108     CONTINUE
14608C
14609 6100 CONTINUE
14610 6200 CONTINUE
14611      IF(IYAXIS.EQ.1)THEN
14612        GY1MIN=GY1MNS
14613        GY1MAX=GY1MXS
14614        GY2MIN=GY2MNS
14615        GY2MAX=GY2MXS
14616        IY1MIN=IY1MNS
14617        IY1MAX=IY1MXS
14618        IY2MIN=IY2MNS
14619        IY2MAX=IY2MXS
14620      ENDIF
14621      IF(IXAXIS.EQ.1)THEN
14622        GX1MIN=GX1MNS
14623        GX1MAX=GX1MXS
14624        GX2MIN=GX2MNS
14625        GX2MAX=GX2MXS
14626        IX1MIN=IX1MNS
14627        IX1MAX=IX1MXS
14628        IX2MIN=IX2MNS
14629        IX2MAX=IX2MXS
14630      ENDIF
14631      GOTO8000
14632C
14633C               **********************************************
14634C               **   STEP 21--                              **
14635C               **   GENERATE THE PLOT               PLOTS  **
14636C               **   GENERATE THE BIHISTOGRAM        PLOTS  **
14637C               **   GENERATE THE QUANTILE-QUANTILE  PLOTS  **
14638C               **   GENERATE THE BOX-COX LINEARITY  PLOTS  **
14639C               **   GENERATE THE STATISTIC       PLOTS     **
14640C               **   GENERATE THE CROSS-TABULATE  PLOTS     **
14641C               **   GENERATE THE ROSE            PLOTS     **
14642C               **********************************************
14643C
14644 6999 CONTINUE
14645C
14646C  IF NO PRIOR LIMITS SET FOR Y AXIS, USE 0 TO 0.6 (THIS MAY NOT
14647C  BE OPTIMAL, BUT IT WILL ALWAYS SHOW ALL THE DATA).
14648C
14649      IF(NPLOTS.LT.1)GOTO8000
14650C
14651      ISHIFT=ILOCQ-1
14652      CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
14653     1IBUGG2,IERROR)
14654      IF(IERROR.EQ.'YES')GOTO8000
14655C
14656C  CREATE BASIC COMMAND LINE, FOR EXAMPLE:
14657C    RELATIVE BIHISTOGRAM Y1 Y2 SUBSET COND1 = <VAL> SUBSET COND2 = <VAL>
14658C  WHERE COND2 IS OPTIONAL
14659C
14660C  FOR SOME PLOT TYPES, NEED TO DO AN INITIAL PLOT TO SET PLOT LIMITS
14661C
14662      ISHIFT=NCCOMM+2
14663      IF(ICPLTV.GE.1)ISHIFT=ISHIFT+4
14664      IF(ICPLTV.GE.2)ISHIFT=ISHIFT+4
14665      CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
14666     1            IBUGG2,IERROR)
14667      ICOM=ICT
14668      ICOM2=IC2T
14669      DO7006II=1,NCCOMM
14670        IHARG(II)=IHT(II)
14671        IHARG2(II)=IH2T(II)
14672        IARGT(II)='WORD'
14673 7006 CONTINUE
14674      NWORD=NCCOMM+1
14675      NPOSA=NWORD
14676      IHARG(NWORD)=IVARN1(1)
14677      IHARG2(NWORD)=IVARN2(1)
14678      IARGT(NWORD)='WORD'
14679      NWORD=NCCOMM+2
14680      NPOSB=NWORD
14681      IHARG(NWORD)=IVARN1(IXC1)
14682      IHARG2(NWORD)=IVARN2(IXC1)
14683      IARGT(NWORD)='WORD'
14684C
14685      NWORD=NWORD+1
14686      IHARG(NWORD)='SUBS'
14687      IHARG2(NWORD)='ET  '
14688      IARGT(NWORD)='WORD'
14689C
14690      NWORD=NWORD+1
14691      IHARG(NWORD)=IVARN1(ICC1)
14692      IHARG2(NWORD)=IVARN2(ICC1)
14693      IARGT(NWORD)='WORD'
14694C
14695      NWORD=NWORD+1
14696      IHARG(NWORD)='=   '
14697      IHARG2(NWORD)='    '
14698      IARGT(NWORD)='WORD'
14699C
14700      NWORD=NWORD+1
14701      IHARG(NWORD)='0  '
14702      IHARG2(NWORD)='    '
14703      IARGT(NWORD)='NUMB'
14704      NPOS1=NWORD
14705C
14706      IF(ICPLTV.EQ.2)THEN
14707        NWORD=NWORD+1
14708        IHARG(NWORD)='SUBS'
14709        IHARG2(NWORD)='ET  '
14710        IARGT(NWORD)='WORD'
14711C
14712        NWORD=NWORD+1
14713        IHARG(NWORD)=IVARN1(ICC2)
14714        IHARG2(NWORD)=IVARN2(ICC2)
14715        IARGT(NWORD)='WORD'
14716C
14717        NWORD=NWORD+1
14718        IHARG(NWORD)='=   '
14719        IHARG2(NWORD)='    '
14720        IARGT(NWORD)='WORD'
14721C
14722        NWORD=NWORD+1
14723        IHARG(NWORD)='0  '
14724        IHARG2(NWORD)='    '
14725        IARGT(NWORD)='NUMB'
14726        NPOS2=NWORD
14727      ENDIF
14728      NARGT=NUMARG
14729C
14730      DO7020I=1,NARGT
14731        IHT(I)=IHARG(I)
14732        IH2T(I)=IHARG2(I)
14733        IARGTT(I)=IARGT(I)
14734        ARGT(I)=ARG(I)
14735 7020 CONTINUE
14736C
14737      IPLOT=0
14738      DO7200IRES=1,IROWT
14739C
14740C  CREATE INITIAL PLOT TO DETERMINE SCALE
14741C
14742      IF(IFLGIN.EQ.'YES')THEN
14743        ISHIFT=NWORD
14744        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
14745     1              IBUGG2,IERROR)
14746        ISHIFT=NCCOMM+2
14747        CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
14748     1              IBUGG2,IERROR)
14749        ICOM=ICT
14750        ICOM2=IC2T
14751        DO7210II=1,NCCOMM+2
14752          IHARG(II)=IHT(II)
14753          IHARG2(II)=IH2T(II)
14754          IARGT(II)='WORD'
14755 7210   CONTINUE
14756        NTEMP=NCCOMM+1
14757        IHARG(NTEMP)=IVARN1(IRES)
14758        IHARG2(NTEMP)=IVARN2(IRES)
14759        IARGT(NTEMP)='WORD'
14760C
14761C  GENERATE THE DUMMY PLOT
14762C
14763        ICHAPA(1)='BLAN'
14764        ILINPA(1)='BLAN'
14765        IBARSW(1)='OFF'
14766        ISPISW(1)='OFF'
14767        GY1MIN=CPUMIN
14768        GY1MAX=CPUMAX
14769        GY2MIN=CPUMIN
14770        GY2MAX=CPUMAX
14771        GX1MIN=CPUMIN
14772        GX1MAX=CPUMAX
14773        GX2MIN=CPUMIN
14774        GX2MAX=CPUMAX
14775        IY1MIN='FLOA'
14776        IY1MAX='FLOA'
14777        IY2MIN='FLOA'
14778        IY2MAX='FLOA'
14779        IX1MIN='FLOA'
14780        IX1MAX='FLOA'
14781        IX2MIN='FLOA'
14782        IX2MAX='FLOA'
14783        CALL MAINGR(ANOPL1,ANOPL2,NPLOTV,NPLOTP,NS,ICASPL,
14784     1              MAXNPP,ISEED,IBOOSS,
14785     1              IX1TSV,IX2TSV,IY1TSV,IY2TSV,
14786     1              IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV,
14787     1              BARHEF,BARWEF,
14788     1              IRHSTG,IHSTCW,IHSTEB,IHSTOU,IASHWT,IHSTMC,IHSTOP,
14789     1              ICAPSW,IFORSW,
14790     1              IGUIFL,IERRFA,
14791     1              IAND1,IAND2,ICONT,NUMHPP,NUMVPP,
14792CCCCC1              TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT,
14793     1              MAXNXT,
14794     1              ISUBRO,IFOUND,IERROR)
14795C
14796        IX1TSW='OFF'
14797        IX1ZSW='OFF'
14798        IX2TSW='OFF'
14799        IX2ZSW='OFF'
14800        IY1TSW='OFF'
14801        IY1ZSW='OFF'
14802        IY2TSW='OFF'
14803        IY2ZSW='OFF'
14804        IX1FSW='OFF'
14805        IX2FSW='OFF'
14806        IY1FSW='OFF'
14807        IY2FSW='OFF'
14808        IERASW='ON'
14809        DO7250I=1,MAXCH
14810          IX1LTE(I)='    '
14811          IX2LTE(I)='    '
14812          IY1LTE(I)='    '
14813          IY2LTE(I)='    '
14814 7250   CONTINUE
14815        NCX1LA=0
14816        NCX2LA=0
14817        NCY1LA=0
14818        NCY2LA=0
14819        NCTITL=0
14820        ICONT=IDCONT(1)
14821        IPOWE=IDPOWE(1)
14822        NUMHPP=IDNHPP(1)
14823        IMPARG=2
14824        CALL DPGRAP(Y,X,X3D,D,N,NPLOTP,ICASPL,ICONT,IPOWE,NUMHPP,
14825     1              XMATN,YMATN,XMITN,YMITN,
14826     1              ISQUAR,
14827     1              IVGMSW,IHGMSW,
14828     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,
14829     1              IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,
14830     1              YPLOT,XPLOT,X2PLOT,TAGPLO,
14831     1              IMPSW,IMPNR,IMPNC,IMPCO,IMPCO9,
14832     1              IMPARG,
14833     1              PMXMIN,PMXMAX,PMYMIN,PMYMAX,
14834     1              MAXCOL,
14835     1              DSIZE,DSYMB,DCOLOR,DFILL,
14836     1              ICAPSW,
14837     1              IBUGUG,IBUGU2,IBUGU3,IBUGU4,ISUBRO,
14838     1              IERROR)
14839C
14840        ICNTPL=ICNTPL+1
14841        IF(NPLOTP.GT.0)THEN
14842          DO3415II=1,NPLOTP
14843            WRITE(IOUNI5,3118)ICNTPL,Y(II),X(II),D(II)
14844 3415     CONTINUE
14845        ENDIF
14846C
14847        IF(IERROR.EQ.'NO')IAND1=IAND2
14848        IMPCO=IMPCO-1
14849        IF(IFLGY.EQ.'ON')THEN
14850          GY1MIN=FY1MNZ
14851          GY1MAX=FY1MXZ
14852          GY2MIN=FY2MNZ
14853          GY2MAX=FY2MXZ
14854          IY1MIN='FIXE'
14855          IY1MAX='FIXE'
14856          IY2MIN='FIXE'
14857          IY2MAX='FIXE'
14858        ELSE
14859          GY1MIN=GY1MNS
14860          GY1MAX=GY1MXS
14861          GY2MIN=GY2MNS
14862          GY2MAX=GY2MXS
14863          IY1MIN=IY1MNS
14864          IY1MAX=IY1MXS
14865          IY2MIN=IY2MNS
14866          IY2MAX=IY2MXS
14867        ENDIF
14868        IF(IFLGX.EQ.'ON')THEN
14869          GX1MIN=FX1MNZ
14870          GX1MAX=FX1MXZ
14871          GX2MIN=FX2MNZ
14872          GX2MAX=FX2MXZ
14873          IX1MIN='FIXE'
14874          IX1MAX='FIXE'
14875          IX2MIN='FIXE'
14876          IX2MAX='FIXE'
14877        ELSE
14878          GX1MIN=GX1MNS
14879          GX1MAX=GX1MXS
14880          GX2MIN=GX2MNS
14881          GX2MAX=GX2MXS
14882          IX1MIN=IX1MNS
14883          IX1MAX=IX1MXS
14884          IX2MIN=IX2MNS
14885          IX2MAX=IX2MXS
14886        ENDIF
14887C
14888        IX1TSW=IX1TSV
14889        IX1ZSW=IX1ZSV
14890        IX2TSW=IX2TSV
14891        IX2ZSW=IX2ZSV
14892        IY1TSW=IY1TSV
14893        IY1ZSW=IY1ZSV
14894        IY2TSW=IY2TSV
14895        IY2ZSW=IY2ZSV
14896        IX1FSW=IX1FSV
14897        IX2FSW=IX2FSV
14898        IY1FSW=IY1FSV
14899        IY2FSW=IY2FSV
14900        IERASW='OFF'
14901C
14902C  RESTORE COMMAND LINE
14903C
14904        ISHIFT=NARGT-NUMARG
14905        IF(ISHIFT.GT.0)THEN
14906          CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
14907     1                IBUGG2,IERROR)
14908        ELSEIF(ISHIFT.LT.0)THEN
14909          ISHIFT=-ISHIFT
14910          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
14911     1                IBUGG2,IERROR)
14912        ENDIF
14913        DO7220II=1,NARGT
14914          IHARG(II)=IHT(II)
14915          IHARG2(II)=IH2T(II)
14916          IARGT(II)=IARGTT(II)
14917          ARG(II)=ARGT(II)
14918 7220   CONTINUE
14919      ENDIF
14920C
14921      DO7100IFAC=1,ICOLT
14922C
14923        IPLOT=IPLOT+1
14924        IX=IXC1
14925        IXLIST=1
14926        IROW=INT(IPLOT/IMPNC)+1
14927        IF(MOD(IPLOT,IMPNC).EQ.0)IROW=IROW-1
14928        ICOL=MOD(IPLOT,IMPNC)
14929        IF(ICOL.EQ.0)ICOL=IMPNC
14930C
14931        IHARG(NPOSA)=IVARN1(IRES)
14932        IHARG2(NPOSA)=IVARN2(IRES)
14933C
14934        IEMPTY='NO'
14935        ITEMP=IFAC
14936        IF(ICPLLA.EQ.'BOX')THEN
14937          ICOL=ICOL-1
14938          ITEMP=IFAC-1
14939          IF(ITEMP.EQ.0)IEMPTY='YES'
14940          IF(IROW.EQ.IMPNR)IEMPTY='YES'
14941        ENDIF
14942C
14943        IF(ICPLRV.EQ.1)THEN
14944          IF(ICPLTV.EQ.1)THEN
14945            IF(ITEMP.GT.0)THEN
14946              ARG(NPOS1)=ADIST1(ITEMP)
14947            ELSE
14948              ARG(NPOS1)=ADIST1(1)
14949            ENDIF
14950          ELSE
14951            IJUNK=IROW
14952            IF(IJUNK.GT.NOUT)IJUNK=NOUT
14953            IF(IJUNK.LT.1)IJUNK=1
14954            ARG(NPOS1)=ADIST1(IJUNK)
14955            IJUNK=ICOL
14956            IF(IJUNK.GT.NOUT2)IJUNK=NOUT2
14957            IF(IJUNK.LT.1)IJUNK=1
14958            ARG(NPOS2)=ADIST2(IJUNK)
14959          ENDIF
14960        ELSE
14961          IF(ICPLTV.EQ.1)THEN
14962            IJUNK=ITEMP
14963            IF(IJUNK.LT.1)IJUNK=1
14964            IF(IJUNK.GT.NOUT)IJUNK=NOUT
14965            ARG(NPOS1)=ADIST1(IJUNK)
14966          ELSE
14967            IJUNK=MOD(IROW-1,ICPLRV)+1
14968            IF(IJUNK.LT.1)IJUNK=1
14969            IF(IJUNK.GT.NOUT)IJUNK=NOUT
14970            ARG(NPOS1)=ADIST1(IJUNK)
14971            IJUNK=ITEMP
14972            IF(IJUNK.GT.NOUT2)IJUNK=NOUT2
14973            IF(IJUNK.LT.1)IJUNK=1
14974            ARG(NPOS2)=ADIST2(IJUNK)
14975          ENDIF
14976        ENDIF
14977C
14978        IF(IEMPTY.EQ.'YES')THEN
14979          DO7104I=1,MAXSUB
14980            ISU2SW(I)=ISUBSW(I)
14981            ISUBSW(I)='OFF'
14982 7104     CONTINUE
14983        ENDIF
14984        ICASPL='COND'
14985        IOPTN=3
14986        IDY=IRES
14987        IDX=1
14988        CALL DPSPM4(ICASPL,IOPTN,IDX,IDY,
14989     1              ISUBNU,ISUBSW,
14990     1              ASUBXL,ASUBXU,ASUBYL,ASUBYU,
14991     1              ISUBN9,ISUBSZ,
14992     1              ASBXL2,ASBXU2,ASBYL2,ASBYU2,
14993     1              PCPXSL,PCPXSU,PCPYSL,PCPYSU,
14994     1              IBUGG2,ISUBRO,IERROR)
14995C
14996        CALL DPSPM1(ICASPL,IVARN1,IVARN2,ICOLL,
14997     1              IMPNR,IMPNC,IROW,ICOL,IRES,IX,IPLOT,
14998     1              NPLOTS,NUMVAR,
14999     1              ICHAP2,ILINP2,
15000     1              GY1MNS,GY1MXS,GY2MNS,GY2MXS,
15001     1              GX1MNS,GX1MXS,GX2MNS,GX2MXS,
15002     1              IY1MNS,IY1MXS,IY2MNS,IY2MXS,
15003     1              IX1MNS,IX1MXS,IX2MNS,IX2MXS,
15004     1              IX1TSV,IX2TSV,IY1TSV,IY2TSV,
15005     1              IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV,
15006     1              PX1LD2,PX2LD2,
15007     1              IY1LJ2,IY1LD2,PY1LD2,PY1LA2,
15008     1              IX1LT2,IX2LT2,IY1LT2,IY2LT2,
15009     1              NCX1L2,NCX2L2,NCY1L2,NCY2L2,
15010     1              PCPXLL,PCPXUL,PCPYLL,PCPYUL,IXLIST,
15011     1              ICPLLA,ISPMLD,IPLOTT,ICPLFR,ICPLXA,ICPLYA,
15012     1              ISPMDI,ISPX1L,
15013     1              ISPMXT,ISPMXL,ISPMYT,ISPMYL,
15014     1              ICPLTD,PCPLTD,IVNMEX,
15015     1              IBUGG2,ISUBRO)
15016C
15017CCCCC   ITITTE(1)='S'
15018CCCCC   ITITTE(2)='U'
15019CCCCC   ITITTE(3)='B'
15020CCCCC   ITITTE(4)='S'
15021CCCCC   ITITTE(5)='E'
15022CCCCC   ITITTE(6)='T'
15023CCCCC   ITITTE(7)=' '
15024CCCCC   NCTEMP=7
15025        NCTEMP=0
15026        DO7161I=1,4
15027          IF(IVARN1(ICC1)(I:I).NE.' ')THEN
15028            NCTEMP=NCTEMP+1
15029            ITITTE(NCTEMP)=IVARN1(ICC1)(I:I)
15030          ENDIF
15031 7161   CONTINUE
15032        DO7163I=1,4
15033          IF(IVARN2(ICC1)(I:I).NE.' ')THEN
15034            NCTEMP=NCTEMP+1
15035            ITITTE(NCTEMP)=IVARN2(ICC1)(I:I)
15036          ENDIF
15037 7163   CONTINUE
15038        NCTEMP=NCTEMP+1
15039        ITITTE(NCTEMP)=' '
15040        NCTEMP=NCTEMP+1
15041        ITITTE(NCTEMP)='='
15042        NCTEMP=NCTEMP+1
15043        ITITTE(NCTEMP)=' '
15044        NCTEMP=NCTEMP+1
15045        VAL=ARG(NPOS1)
15046        IVAL=INT(VAL+0.5)
15047        IF(VAL.LT.0.0)IVAL=INT(VAL-0.5)
15048        CALL DPCONH(IVAL,VAL,ITITTE(NCTEMP),NH,IBUGG2,IERROR)
15049        NCTEMP=NCTEMP+NH-1
15050        IF(ICPLTV.EQ.1)GOTO7189
15051        DO7169I=1,15
15052          NCTEMP=NCTEMP+1
15053          ITITTE(NCTEMP)=' '
15054 7169   CONTINUE
15055        DO7171I=1,4
15056          IF(IVARN1(ICC2)(I:I).NE.' ')THEN
15057            NCTEMP=NCTEMP+1
15058            ITITTE(NCTEMP)=IVARN1(ICC2)(I:I)
15059          ENDIF
15060 7171   CONTINUE
15061        DO7173I=1,4
15062          IF(IVARN2(ICC2)(I:I).NE.' ')THEN
15063            NCTEMP=NCTEMP+1
15064            ITITTE(NCTEMP)=IVARN2(ICC2)(I:I)
15065          ENDIF
15066 7173   CONTINUE
15067        NCTEMP=NCTEMP+1
15068        ITITTE(NCTEMP)=' '
15069        NCTEMP=NCTEMP+1
15070        ITITTE(NCTEMP)='='
15071        NCTEMP=NCTEMP+1
15072        ITITTE(NCTEMP)=' '
15073        NCTEMP=NCTEMP+1
15074        VAL=ARG(NPOS2)
15075        IVAL=INT(VAL+0.5)
15076        IF(VAL.LT.0.0)IVAL=INT(VAL-0.5)
15077        CALL DPCONH(IVAL,VAL,ITITTE(NCTEMP),NH,IBUGG2,IERROR)
15078        NCTEMP=NCTEMP+NH-1
15079 7189   CONTINUE
15080        NCTITL=NCTEMP
15081        IF(ICPLFR.EQ.'DEFA')THEN
15082          PTITDS=-ABS(PTITDZ)
15083        ENDIF
15084        IF(IEMPTY.EQ.'YES')THEN
15085          DO5306I=1,100
15086            ICHAPA(I)='BLAN'
15087            ILINPA(I)='BLAN'
15088            ISPISW(I)='OFF'
15089            IBARSW(I)='OFF'
15090 5306     CONTINUE
15091          NCTITL=0
15092        ENDIF
15093C
15094        IF(ICPLPT.EQ.'ROSE' .OR. ICPLPT.EQ.'ROS2')THEN
15095          NCTITL=0
15096        ENDIF
15097C
15098        CALL MAINGR(ANOPL1,ANOPL2,NPLOTV,NPLOTP,NS,ICASPL,
15099     1              MAXNPP,ISEED,IBOOSS,
15100     1              IX1TSV,IX2TSV,IY1TSV,IY2TSV,
15101     1              IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV,
15102     1              BARHEF,BARWEF,
15103     1              IRHSTG,IHSTCW,IHSTEB,IHSTOU,IASHWT,IHSTMC,IHSTOP,
15104     1              ICAPSW,IFORSW,
15105     1              IGUIFL,IERRFA,
15106     1              IAND1,IAND2,ICONT,NUMHPP,NUMVPP,
15107CCCCC1              TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT,
15108     1              MAXNXT,
15109     1              ISUBRO,IFOUND,IERROR)
15110        IF(IEMPTY.EQ.'NO' .AND. ICPLPT.NE.'ROS2')THEN
15111          CALL DPSPM3(ICASPL,IOUNI5,
15112     1                IROW,ICOL,
15113     1                PX2LD2,NPLOTP,
15114     1                IFORSW,
15115     1                IFPX2L,ISPX2P,ISPX2S,
15116     1                IHRIGH,IHRIG2,IHWUSE,
15117     1                ISUBN1,ISUBN2,MESSAG,
15118     1                IBUGG2,ISUBRO,IERROR)
15119        ENDIF
15120C
15121        ICONT=IDCONT(1)
15122        IPOWE=IDPOWE(1)
15123        NUMHPP=IDNHPP(1)
15124        IMPARG=2
15125        CALL DPGRAP(Y,X,X3D,D,N,NPLOTP,ICASPL,ICONT,IPOWE,NUMHPP,
15126     1              XMATN,YMATN,XMITN,YMITN,
15127     1              ISQUAR,
15128     1              IVGMSW,IHGMSW,
15129     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,
15130     1              IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,
15131     1              YPLOT,XPLOT,X2PLOT,TAGPLO,
15132     1              IMPSW,IMPNR,IMPNC,IMPCO,IMPCO9,
15133     1              IMPARG,
15134     1              PMXMIN,PMXMAX,PMYMIN,PMYMAX,
15135     1              MAXCOL,
15136     1              DSIZE,DSYMB,DCOLOR,DFILL,
15137     1              ICAPSW,
15138     1              IBUGUG,IBUGU2,IBUGU3,IBUGU4,ISUBRO,
15139     1              IERROR)
15140C
15141        ICNTPL=ICNTPL+1
15142        IF(NPLOTP.GT.0)THEN
15143          DO3515II=1,NPLOTP
15144            WRITE(IOUNI5,3118)ICNTPL,Y(II),X(II),D(II)
15145 3515     CONTINUE
15146        ENDIF
15147C
15148        IF(IERROR.EQ.'NO')IAND1=IAND2
15149        IF(IERROR.EQ.'YES')GOTO7199
15150C
15151        IF(ICPLPT.NE.'PLOT')GOTO7199
15152        IF(ICPLFI.EQ.'NONE')GOTO7199
15153        IF(IEMPTY.EQ.'YES')GOTO7199
15154C
15155        IMPCO=IMPCO-1
15156        IF(IMPCO.LE.1)IERASW='OFF'
15157C
15158        ICNTPL=0
15159        IOUNI5=-99
15160        CALL DPSPM2(ICASPL,IVARN1,IVARN2,ICOLL,NUMVAR,NPLOTP,
15161     1              IRES,IX,
15162     1              TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT,
15163     1              ALOWFR,ALOWDG,
15164     1              IANGLU,MAXNPP,IAND1,IAND2,
15165     1              ICPLFI,ICPLTA,
15166     1              XMATN,YMATN,XMITN,YMITN,
15167     1              ISQUAR,
15168     1              IVGMSW,IHGMSW,
15169     1              IMPSW,IMPNR,IMPNC,IMPCO,IMPCO9,
15170     1              IREPCH,
15171     1              PMXMIN,PMXMAX,PMYMIN,PMYMAX,
15172     1              ICNTPL,IOUNI5,
15173     1              IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ,
15174     1              IBUGUG,IBUGU2,IBUGU3,IBUGU4,
15175     1              ISUBRO,IFOUND,IERROR)
15176        IF(IERROR.EQ.'YES')GOTO7199
15177C
15178 7199   CONTINUE
15179        ISHIFT=NARGT-NUMARG
15180        IF(ISHIFT.GT.0)THEN
15181          CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
15182     1                IBUGG2,IERROR)
15183        ELSEIF(ISHIFT.LT.0)THEN
15184          ISHIFT=-ISHIFT
15185          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
15186     1                IBUGG2,IERROR)
15187        ENDIF
15188        ICOM=ICT
15189        ICOM2=IC2T
15190        DO7101II=1,NARGT
15191          IHARG(II)=IHT(II)
15192          IHARG2(II)=IH2T(II)
15193          IARGT(II)=IARGTT(II)
15194          ARG(II)=ARGT(II)
15195 7101   CONTINUE
15196C
15197        PX1LDS=PX1LD2
15198        IF(IYAXIS.EQ.0.AND.IFLGIN.EQ.'NO')THEN
15199          GY1MNS=GY1MIN
15200          GY1MXS=GY1MAX
15201          GY2MNS=GY2MIN
15202          GY2MXS=GY2MAX
15203          IY1MNS=IY1MIN
15204          IY1MXS=IY1MAX
15205          IY2MNS=IY2MIN
15206          IY2MXS=IY2MAX
15207        ENDIF
15208        IF(IXAXIS.EQ.0.AND.IFLGIN.EQ.'NO')THEN
15209          GX1MNS=GX1MIN
15210          GX1MXS=GX1MAX
15211          GX2MNS=GX2MIN
15212          GX2MXS=GX2MAX
15213          IX1MNS=IX1MIN
15214          IX1MXS=IX1MAX
15215          IX2MNS=IX2MIN
15216          IX2MXS=IX2MAX
15217        ENDIF
15218        PX1ZDS=PX1ZD2
15219        PX2ZDS=PX2ZD2
15220        PY1ZDS=PY1ZD2
15221        PY2ZDS=PY2ZD2
15222        IF(IEMPTY.EQ.'YES')THEN
15223          DO7107I=1,MAXSUB
15224            ISUBSW(I)=ISU2SW(I)
15225 7107     CONTINUE
15226        ENDIF
15227        DO7108I=1,100
15228            ICHAPA(I)=ICHAP2(I)
15229            ILINPA(I)=ILINP2(I)
15230            ISPISW(I)=ISPIS2(I)
15231            IBARSW(I)=IBARS2(I)
15232 7108     CONTINUE
15233C
15234 7100 CONTINUE
15235 7200 CONTINUE
15236      IF(IYAXIS.EQ.1)THEN
15237        GY1MIN=GY1MNS
15238        GY1MAX=GY1MXS
15239        GY2MIN=GY2MNS
15240        GY2MAX=GY2MXS
15241        IY1MIN=IY1MNS
15242        IY1MAX=IY1MXS
15243        IY2MIN=IY2MNS
15244        IY2MAX=IY2MXS
15245      ENDIF
15246      IF(IXAXIS.EQ.1)THEN
15247        GX1MIN=GX1MNS
15248        GX1MAX=GX1MXS
15249        GX2MIN=GX2MNS
15250        GX2MAX=GX2MXS
15251        IX1MIN=IX1MNS
15252        IX1MAX=IX1MXS
15253        IX2MIN=IX2MNS
15254        IX2MAX=IX2MXS
15255      ENDIF
15256      GOTO8000
15257C
15258C               **********************************************
15259C               **   STEP 21--                              **
15260C               **   GENERATE THE 3D                 PLOTS  **
15261C               **   GENERATE THE YATES CUBE         PLOTS  **
15262C               **********************************************
15263C
15264 7499 CONTINUE
15265C
15266      IF(NPLOTS.LT.1)GOTO8000
15267C
15268      ISHIFT=ILOCQ-1
15269      CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
15270     1IBUGG2,IERROR)
15271      IF(IERROR.EQ.'YES')GOTO8000
15272C
15273C  CREATE BASIC COMMAND LINE, FOR EXAMPLE:
15274C    YATES CUBE PLOT Y X1 X2 X3 SUBSET COND1 = <VAL> SUBSET COND2 = <VAL>
15275C  WHERE COND2 IS OPTIONAL
15276C
15277      ISHIFT=NCCOMM+4
15278      IF(ICPLTV.GE.1)ISHIFT=ISHIFT+4
15279      IF(ICPLTV.GE.2)ISHIFT=ISHIFT+4
15280      CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
15281     1            IBUGG2,IERROR)
15282      ICOM=ICT
15283      ICOM2=IC2T
15284      DO7506II=1,NCCOMM
15285        IHARG(II)=IHT(II)
15286        IHARG2(II)=IH2T(II)
15287        IARGT(II)='WORD'
15288 7506 CONTINUE
15289      NWORD=NCCOMM+1
15290      NPOSA=NWORD
15291      IHARG(NWORD)=IVARN1(1)
15292      IHARG2(NWORD)=IVARN2(1)
15293      IARGT(NWORD)='WORD'
15294      NWORD=NCCOMM+2
15295      NPOSB=NWORD
15296      IHARG(NWORD)=IVARN1(IXC1)
15297      IHARG2(NWORD)=IVARN2(IXC1)
15298      IARGT(NWORD)='WORD'
15299C
15300      IF(ICPLXV.GE.2)THEN
15301        NWORD=NWORD+1
15302        IHARG(NWORD)=IVARN1(IXC2)
15303        IHARG2(NWORD)=IVARN2(IXC2)
15304        IARGT(NWORD)='WORD'
15305      ENDIF
15306C
15307      IF(ICPLXV.GE.3)THEN
15308        NWORD=NWORD+1
15309        IHARG(NWORD)=IVARN1(IXC3)
15310        IHARG2(NWORD)=IVARN2(IXC3)
15311        IARGT(NWORD)='WORD'
15312      ENDIF
15313C
15314      NWORD=NWORD+1
15315      IHARG(NWORD)='SUBS'
15316      IHARG2(NWORD)='ET  '
15317      IARGT(NWORD)='WORD'
15318C
15319      NWORD=NWORD+1
15320      IHARG(NWORD)=IVARN1(ICC1)
15321      IHARG2(NWORD)=IVARN2(ICC1)
15322      IARGT(NWORD)='WORD'
15323C
15324      NWORD=NWORD+1
15325      IHARG(NWORD)='=   '
15326      IHARG2(NWORD)='    '
15327      IARGT(NWORD)='WORD'
15328C
15329      NWORD=NWORD+1
15330      IHARG(NWORD)='0  '
15331      IHARG2(NWORD)='    '
15332      IARGT(NWORD)='NUMB'
15333      NPOS1=NWORD
15334C
15335      IF(ICPLTV.EQ.2)THEN
15336        NWORD=NWORD+1
15337        IHARG(NWORD)='SUBS'
15338        IHARG2(NWORD)='ET  '
15339        IARGT(NWORD)='WORD'
15340C
15341        NWORD=NWORD+1
15342        IHARG(NWORD)=IVARN1(ICC2)
15343        IHARG2(NWORD)=IVARN2(ICC2)
15344        IARGT(NWORD)='WORD'
15345C
15346        NWORD=NWORD+1
15347        IHARG(NWORD)='=   '
15348        IHARG2(NWORD)='    '
15349        IARGT(NWORD)='WORD'
15350C
15351        NWORD=NWORD+1
15352        IHARG(NWORD)='0  '
15353        IHARG2(NWORD)='    '
15354        IARGT(NWORD)='NUMB'
15355        NPOS2=NWORD
15356      ENDIF
15357      NARGT=NUMARG
15358C
15359      DO7520I=1,NARGT
15360        IHT(I)=IHARG(I)
15361        IH2T(I)=IHARG2(I)
15362        IARGTT(I)=IARGT(I)
15363        ARGT(I)=ARG(I)
15364 7520 CONTINUE
15365C
15366      IPLOT=0
15367      IEMPTY='NO'
15368      DO7700IRES=1,IROWT
15369      DO7600IFAC=1,ICOLT
15370C
15371        IPLOT=IPLOT+1
15372        IX=IXC1
15373        IXLIST=1
15374        IROW=INT(IPLOT/IMPNC)+1
15375        IF(MOD(IPLOT,IMPNC).EQ.0)IROW=IROW-1
15376        ICOL=MOD(IPLOT,IMPNC)
15377        IF(ICOL.EQ.0)ICOL=IMPNC
15378C
15379        IHARG(NPOSA)=IVARN1(IRES)
15380        IHARG2(NPOSA)=IVARN2(IRES)
15381C
15382        IEMPTY='NO'
15383        ITEMP=IFAC
15384C
15385        IF(ICPLTV.EQ.1)THEN
15386          IF(ITEMP.GT.0)THEN
15387            ARG(NPOS1)=ADIST1(ITEMP)
15388          ELSE
15389            ARG(NPOS1)=ADIST1(1)
15390          ENDIF
15391        ELSE
15392          IJUNK=IROW
15393          IF(IJUNK.GT.NOUT)IJUNK=NOUT
15394          IF(IJUNK.LT.1)IJUNK=1
15395          ARG(NPOS1)=ADIST1(IJUNK)
15396          IJUNK=ICOL
15397          IF(IJUNK.GT.NOUT2)IJUNK=NOUT2
15398          IF(IJUNK.LT.1)IJUNK=1
15399          ARG(NPOS2)=ADIST2(IJUNK)
15400        ENDIF
15401C
15402        ICASPL='COND'
15403        NCTEMP=0
15404        DO7661I=1,4
15405          IF(IVARN1(ICC1)(I:I).NE.' ')THEN
15406            NCTEMP=NCTEMP+1
15407            ITITTE(NCTEMP)=IVARN1(ICC1)(I:I)
15408          ENDIF
15409 7661   CONTINUE
15410        DO7663I=1,4
15411          IF(IVARN2(ICC1)(I:I).NE.' ')THEN
15412            NCTEMP=NCTEMP+1
15413            ITITTE(NCTEMP)=IVARN2(ICC1)(I:I)
15414          ENDIF
15415 7663   CONTINUE
15416        NCTEMP=NCTEMP+1
15417        ITITTE(NCTEMP)=' '
15418        NCTEMP=NCTEMP+1
15419        ITITTE(NCTEMP)='='
15420        NCTEMP=NCTEMP+1
15421        ITITTE(NCTEMP)=' '
15422        NCTEMP=NCTEMP+1
15423        VAL=ARG(NPOS1)
15424        IVAL=INT(VAL+0.5)
15425        IF(VAL.LT.0.0)IVAL=INT(VAL-0.5)
15426        CALL DPCONH(IVAL,VAL,ITITTE(NCTEMP),NH,IBUGG2,IERROR)
15427        NCTEMP=NCTEMP+NH-1
15428        IF(ICPLTV.EQ.1)GOTO7689
15429        DO7669I=1,15
15430          NCTEMP=NCTEMP+1
15431          ITITTE(NCTEMP)=' '
15432 7669   CONTINUE
15433        DO7671I=1,4
15434          IF(IVARN1(ICC2)(I:I).NE.' ')THEN
15435            NCTEMP=NCTEMP+1
15436            ITITTE(NCTEMP)=IVARN1(ICC2)(I:I)
15437          ENDIF
15438 7671   CONTINUE
15439        DO7673I=1,4
15440          IF(IVARN2(ICC2)(I:I).NE.' ')THEN
15441            NCTEMP=NCTEMP+1
15442            ITITTE(NCTEMP)=IVARN2(ICC2)(I:I)
15443          ENDIF
15444 7673   CONTINUE
15445        NCTEMP=NCTEMP+1
15446        ITITTE(NCTEMP)=' '
15447        NCTEMP=NCTEMP+1
15448        ITITTE(NCTEMP)='='
15449        NCTEMP=NCTEMP+1
15450        ITITTE(NCTEMP)=' '
15451        NCTEMP=NCTEMP+1
15452        VAL=ARG(NPOS2)
15453        IVAL=INT(VAL+0.5)
15454        IF(VAL.LT.0.0)IVAL=INT(VAL-0.5)
15455        CALL DPCONH(IVAL,VAL,ITITTE(NCTEMP),NH,IBUGG2,IERROR)
15456        NCTEMP=NCTEMP+NH-1
15457 7689   CONTINUE
15458        NCTITL=NCTEMP
15459        IF(ICPLFR.EQ.'DEFA')THEN
15460          PTITDS=-ABS(PTITDZ)
15461        ENDIF
15462C
15463        CALL MAINGR(ANOPL1,ANOPL2,NPLOTV,NPLOTP,NS,ICASPL,
15464     1              MAXNPP,ISEED,IBOOSS,
15465     1              IX1TSV,IX2TSV,IY1TSV,IY2TSV,
15466     1              IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV,
15467     1              BARHEF,BARWEF,
15468     1              IRHSTG,IHSTCW,IHSTEB,IHSTOU,IASHWT,IHSTMC,IHSTOP,
15469     1              ICAPSW,IFORSW,
15470     1              IGUIFL,IERRFA,
15471     1              IAND1,IAND2,ICONT,NUMHPP,NUMVPP,
15472CCCCC1              TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT,
15473     1              MAXNXT,
15474     1              ISUBRO,IFOUND,IERROR)
15475C
15476        ICONT=IDCONT(1)
15477        IPOWE=IDPOWE(1)
15478        NUMHPP=IDNHPP(1)
15479        IMPARG=2
15480        CALL DPGRAP(Y,X,X3D,D,N,NPLOTP,ICASPL,ICONT,IPOWE,NUMHPP,
15481     1              XMATN,YMATN,XMITN,YMITN,
15482     1              ISQUAR,
15483     1              IVGMSW,IHGMSW,
15484     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,
15485     1              IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,
15486     1              YPLOT,XPLOT,X2PLOT,TAGPLO,
15487     1              IMPSW,IMPNR,IMPNC,IMPCO,IMPCO9,
15488     1              IMPARG,
15489     1              PMXMIN,PMXMAX,PMYMIN,PMYMAX,
15490     1              MAXCOL,
15491     1              DSIZE,DSYMB,DCOLOR,DFILL,
15492     1              ICAPSW,
15493     1              IBUGUG,IBUGU2,IBUGU3,IBUGU4,ISUBRO,
15494     1              IERROR)
15495C
15496        ICNTPL=ICNTPL+1
15497        IF(NPLOTP.GT.0)THEN
15498          DO3615II=1,NPLOTP
15499            WRITE(IOUNI5,3118)ICNTPL,Y(II),X(II),D(II)
15500 3615     CONTINUE
15501        ENDIF
15502C
15503        IF(IERROR.EQ.'NO')IAND1=IAND2
15504        IF(IERROR.EQ.'YES')GOTO7699
15505C
15506 7699   CONTINUE
15507        ISHIFT=NARGT-NUMARG
15508        IF(ISHIFT.GT.0)THEN
15509          CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
15510     1                IBUGG2,IERROR)
15511        ELSEIF(ISHIFT.LT.0)THEN
15512          ISHIFT=-ISHIFT
15513          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
15514     1                IBUGG2,IERROR)
15515        ENDIF
15516        ICOM=ICT
15517        ICOM2=IC2T
15518        DO7601II=1,NARGT
15519          IHARG(II)=IHT(II)
15520          IHARG2(II)=IH2T(II)
15521          IARGT(II)=IARGTT(II)
15522          ARG(II)=ARGT(II)
15523 7601   CONTINUE
15524C
15525 7600 CONTINUE
15526 7700 CONTINUE
15527      GOTO8000
15528C
15529C               **************************************************
15530C               **   STEP 28--                                  **
15531C               **   REINSTATE INITIAL SETTINGS                 **
15532C               **************************************************
15533C
15534 8000 CONTINUE
15535C
15536      ISTEPN='28'
15537      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'COND')THEN
15538        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15539        WRITE(ICOUT,8807)IMANUF,NUMDEV,IDMANU(1)
15540 8807   FORMAT('IMANUF,NUMDEV,IDMANU(1) = ',A4,I8,2X,A4)
15541        CALL DPWRST('XXX','BUG ')
15542      ENDIF
15543C
15544      IFLAG=2
15545      CALL DPSPM5(IFLAG,IMPSW,IMPCO,IMPNR,IMPNC,
15546     1            IBUGG2,ISUBRO,IFOUND,IERROR)
15547      ICPLFR=ICPLFZ
15548      IFEEDB=IFEED9
15549C
15550C               *****************
15551C               **  STEP 90--  **
15552C               **  EXIT       **
15553C               *****************
15554C
15555 9000 CONTINUE
15556C
15557      IOP='CLOS'
15558      CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLAG4,IFLAG5,
15559     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
15560     1            IBUGG2,ISUBRO,IERROR)
15561      IFITAU=IFITA2
15562C
15563      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'COND')THEN
15564        WRITE(ICOUT,999)
15565        CALL DPWRST('XXX','BUG ')
15566        WRITE(ICOUT,9011)
15567 9011   FORMAT('***** AT THE END       OF DPCOND--')
15568        CALL DPWRST('XXX','BUG ')
15569        WRITE(ICOUT,9012)IFOUND,IERROR
15570 9012   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
15571        CALL DPWRST('XXX','BUG ')
15572        WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
15573 9013   FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',31I8,3(2X,A4))
15574        CALL DPWRST('XXX','BUG ')
15575      ENDIF
15576C
15577      RETURN
15578      END
15579      SUBROUTINE DPCONF(XTEMP1,XTEMP2,MAXNXT,ICASAN,
15580     1                  ICAPSW,IFORSW,IMULT,IREPL,
15581     1                  ISUBRO,IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
15582C
15583C     PURPOSE--GENERATE (SYMMETRIC) CONFIDENCE LIMITS FOR THE MEAN
15584C              FOR PROBABILITY VALUE P = .90, .95, .99, .999, AND .9999.
15585C     WRITTEN BY--JAMES J. FILLIBEN
15586C                 STATISTICAL ENGINEERING DIVISION
15587C                 INFORMATION TECHNOLOGY LABORATORY
15588C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
15589C                 GAITHERSBURG, MD 20899-8980
15590C                 PHONE--301-975-2855
15591C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
15592C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
15593C     LANGUAGE--ANSI FORTRAN (1977)
15594C     VERSION NUMBER--82/7
15595C     ORIGINAL VERSION--JULY      1984.
15596C     UPDATED         --JUNE      1990. TEMPORARY ARRAYS TO GARBAGE COMMON
15597C     UPDATED         --MARCH     1999. IF 2 VARIABLES SPECIFIED,
15598C                                       COMPUTE CONFIDENCE INTERVAL
15599C                                       FOR DIFFERENCE BETWEEN MEANS
15600C     UPDATED         --MARCH     2003. SAVE CONFIDENCE BOUNDS AS
15601C                                       INTERNAL PARAMETERS
15602C     UPDATED         --OCTOBER   2003. SUPPORT FOR HTML, LATEX OUTPUT
15603C     UPDATED         --MARCH     2010. USE DPPARS
15604C     UPDATED         --MARCH     2010. USE DPDTA1, DPDTA4 TO GENERATE
15605C                                       HTML, LATEX, RTF FORMAT
15606C     UPDATED         --MARCH     2010. SUPPORT FOR MULTIPLE RESPONSE
15607C                                       VARIABLES AND FOR GROUP-ID
15608C                                       VARIABLES (I.E., REPLICATION
15609C                                       CASE)
15610C     UPDATED         --MARCH     2010. USE DPPAR3 TO EXTRACT EITHER A
15611C                                       RESPONSE VARIABLE OR A MATRIX
15612C                                       NAME
15613C     UPDATED         --APRIL     2013. SUPPORT <LOWER/UPPER> OPTION
15614C     UPDATED         --AUGUST    2017. SUPPORT FOR LOGNORMAL OPTION
15615C
15616C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
15617C
15618      CHARACTER*4 ICAPSW
15619      CHARACTER*4 IFORSW
15620      CHARACTER*4 ISUBRO
15621      CHARACTER*4 IBUGA2
15622      CHARACTER*4 IBUGA3
15623      CHARACTER*4 IBUGQ
15624      CHARACTER*4 IFOUND
15625      CHARACTER*4 IERROR
15626C
15627      CHARACTER*4 ICASAN
15628      CHARACTER*4 ICASA2
15629      CHARACTER*4 ICASA3
15630      CHARACTER*4 ICTMP0
15631      CHARACTER*4 ICTMP1
15632      CHARACTER*4 ICTMP2
15633      CHARACTER*4 ICTMP3
15634      CHARACTER*4 ICTMP4
15635      CHARACTER*4 ICTMP5
15636      CHARACTER*4 ICASE
15637      CHARACTER*4 ISUBN1
15638      CHARACTER*4 ISUBN2
15639      CHARACTER*4 ISTEPN
15640      CHARACTER*4 IFLAGU
15641      CHARACTER*4 IREPL
15642      CHARACTER*4 IMULT
15643C
15644      LOGICAL IFRST
15645      LOGICAL ILAST
15646C
15647      CHARACTER*40 INAME
15648      PARAMETER (MAXSPN=30)
15649      CHARACTER*4 IVARN1(MAXSPN)
15650      CHARACTER*4 IVARN2(MAXSPN)
15651      CHARACTER*4 IVARTY(MAXSPN)
15652      CHARACTER*4 IVARID(MAXSPN)
15653      CHARACTER*4 IVARI2(MAXSPN)
15654      REAL PVAR(MAXSPN)
15655      REAL PID(MAXSPN)
15656      INTEGER ILIS(MAXSPN)
15657      INTEGER NRIGHT(MAXSPN)
15658      INTEGER ICOLR(MAXSPN)
15659C
15660C---------------------------------------------------------------------
15661C
15662      INCLUDE 'DPCOPA.INC'
15663C
15664      DIMENSION XTEMP1(*)
15665      DIMENSION XTEMP2(*)
15666      DIMENSION TEMP1(MAXOBV)
15667      DIMENSION TEMP2(MAXOBV)
15668C
15669      DIMENSION XDESGN(MAXOBV,6)
15670      DIMENSION XIDTEM(MAXOBV)
15671      DIMENSION XIDTE2(MAXOBV)
15672      DIMENSION XIDTE3(MAXOBV)
15673      DIMENSION XIDTE4(MAXOBV)
15674      DIMENSION XIDTE5(MAXOBV)
15675      DIMENSION XIDTE6(MAXOBV)
15676C
15677      INCLUDE 'DPCOZZ.INC'
15678      EQUIVALENCE (GARBAG(IGARB1),XIDTEM(1))
15679      EQUIVALENCE (GARBAG(IGARB2),XIDTE2(1))
15680      EQUIVALENCE (GARBAG(IGARB3),XIDTE3(1))
15681      EQUIVALENCE (GARBAG(IGARB4),XIDTE4(1))
15682      EQUIVALENCE (GARBAG(IGARB5),XIDTE5(1))
15683      EQUIVALENCE (GARBAG(IGARB6),XIDTE6(1))
15684      EQUIVALENCE (GARBAG(IGARB7),TEMP1(1))
15685      EQUIVALENCE (GARBAG(IGARB8),TEMP2(1))
15686      EQUIVALENCE (GARBAG(IGARB9),XDESGN(1,1))
15687C
15688C-----COMMON----------------------------------------------------------
15689C
15690      INCLUDE 'DPCOHK.INC'
15691      INCLUDE 'DPCOSU.INC'
15692      INCLUDE 'DPCODA.INC'
15693      INCLUDE 'DPCOHO.INC'
15694      INCLUDE 'DPCOST.INC'
15695C
15696C-----COMMON VARIABLES (GENERAL)--------------------------------------
15697C
15698      INCLUDE 'DPCOP2.INC'
15699C
15700C-----START POINT-----------------------------------------------------
15701C
15702      ISUBN1='DPCO'
15703      ISUBN2='NF  '
15704      IFOUND='YES'
15705      IERROR='NO'
15706C
15707      MAXCP1=MAXCOL+1
15708      MAXCP2=MAXCOL+2
15709      MAXCP3=MAXCOL+3
15710      MAXCP4=MAXCOL+4
15711      MAXCP5=MAXCOL+5
15712      MAXCP6=MAXCOL+6
15713C
15714C               ****************************************
15715C               **  TREAT THE CONFIDENCE LIMITS CASE  **
15716C               ****************************************
15717C
15718      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CONF')THEN
15719        WRITE(ICOUT,999)
15720  999   FORMAT(1X)
15721        CALL DPWRST('XXX','BUG ')
15722        WRITE(ICOUT,51)
15723   51   FORMAT('***** AT THE BEGINNING OF DPCONF--')
15724        CALL DPWRST('XXX','BUG ')
15725        WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ,ISUBRO
15726   52   FORMAT('IBUGA2,IBUGA3,IBUGQ,ISUBRO = ',3(A4,2X),A4)
15727        CALL DPWRST('XXX','BUG ')
15728        WRITE(ICOUT,55)MAXNXT,ICASAN,MAXV2
15729   55   FORMAT('MAXNXT,ICASAN,MAXV2 = ',I8,2X,A4,2X,I5)
15730        CALL DPWRST('XXX','BUG ')
15731      ENDIF
15732C
15733C               *********************************
15734C               **  STEP 1--                   **
15735C               **  EXTRACT THE COMMAND        **
15736C               *********************************
15737C
15738      ISTEPN='1'
15739      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CONF')
15740     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15741C
15742C     THE FOLLOWING COMMANDS ARE ACCEPTED:
15743C
15744C         CONFIDENCE LIMITS Y               (TWO SIDED)
15745C         LOWER CONFIDENCE LIMITS Y         (ONE SIDED)
15746C         UPPER CONFIDENCE LIMITS Y         (ONE SIDED)
15747C
15748C         DIFFERENCE OF MEAN CONFIDENCE LIMITS Y1 Y2   (TWO SIDED)
15749C         DIFFERENCE OF MEAN LOWER CONFIDENCE LIMITS Y (ONE SIDED)
15750C         DIFFERENCE OF MEAN UPPER PREDICTION LIMITS Y (ONE SIDED)
15751C
15752C     IN ADDITION, CHECK FOR THE
15753C
15754C         1. "MULTIPLE"
15755C         2. "REPLICATION"
15756C         3. "LOGNORMAL"
15757C         4. "BOX COX"
15758C
15759C     OPTIONS.
15760C
15761      ILASTZ=9999
15762      IFOUND='NO'
15763      ICASAN='ONEV'
15764      ICASA2='TWOS'
15765      ICASA3='NORM'
15766C
15767      DO100I=0,NUMARG-1
15768C
15769        ICTMP0='XXXX'
15770        IF(I.EQ.0)THEN
15771          ICTMP1=ICOM
15772          ICTMP2=IHARG(I+1)
15773          ICTMP3=IHARG(I+2)
15774          ICTMP4=IHARG(I+3)
15775          ICTMP5=IHARG(I+4)
15776        ELSE
15777          IF(I.GE.2)ICTMP0=IHARG(I-1)
15778          ICTMP1=IHARG(I)
15779          ICTMP2=IHARG(I+1)
15780          ICTMP3=IHARG(I+2)
15781          ICTMP4=IHARG(I+3)
15782          ICTMP5=IHARG(I+4)
15783        ENDIF
15784C
15785        IF(ICTMP1.EQ.'=   ')GOTO9000
15786        IF(ICTMP1.EQ.'SD  ')GOTO9000
15787        IF(ICTMP1.EQ.'MEDI')GOTO9000
15788        IF(ICTMP1.EQ.'PROP')GOTO9000
15789        IF(ICTMP1.EQ.'STAN' .AND. ICTMP2.EQ.'DEVI')GOTO9000
15790        IF(ICTMP1.EQ.'TRIM' .AND. ICTMP2.EQ.'MEAN')GOTO9000
15791        IF(ICTMP1.EQ.'COEF' .AND. ICTMP2.EQ.'OF  ' .AND.
15792     1     ICTMP3.EQ.'DEVI')GOTO9000
15793        IF(ICTMP1.EQ.'COEF' .AND. ICTMP2.EQ.'OF  ' .AND.
15794     1     ICTMP3.EQ.'DISP')GOTO9000
15795        IF(ICTMP1.EQ.'COEF' .AND. ICTMP2.EQ.'OF  ' .AND.
15796     1     ICTMP3.EQ.'QUAR' .AND. ICTMP4.EQ.'DISP')GOTO9000
15797        IF(ICTMP1.EQ.'COEF' .AND. ICTMP2.EQ.'OF  ' .AND.
15798     1     ICTMP3.EQ.'QUAR' .AND. ICTMP4.EQ.'VARI')GOTO9000
15799        IF(ICTMP1.EQ.'QUAR' .AND. ICTMP2.EQ.'COEF' .AND.
15800     1     ICTMP3.EQ.'OF  ' .AND. ICTMP4.EQ.'DISP')GOTO9000
15801        IF(ICTMP1.EQ.'QUAR' .AND. ICTMP2.EQ.'COEF' .AND.
15802     1     ICTMP3.EQ.'OF  ' .AND. ICTMP4.EQ.'VARI')GOTO9000
15803C
15804        IF(ICTMP1.EQ.'DIFF' .AND. ICTMP2.EQ.'OF  ' .AND.
15805     1         ICTMP3.EQ.'MEAN' .AND. ICTMP4.EQ.'CONF' .AND.
15806     1         (ICTMP5.EQ.'LIMI' .OR. ICTMP5.EQ.'INTE'))THEN
15807          IFOUND='YES'
15808          ILASTZ=I+4
15809          ICASAN='TWOV'
15810          GOTO109
15811        ELSEIF(ICTMP1.EQ.'CONF' .AND. ICTMP2.EQ.'INTE' .AND.
15812     1     ICTMP0.NE.'SD  ' .AND. ICTMP0.NE.'DEVI' .AND.
15813     1     ICASAN.NE.'TWOV')THEN
15814          IFOUND='YES'
15815          ILASTZ=I+1
15816          ICASAN='ONEV'
15817          GOTO109
15818        ELSEIF(ICTMP1.EQ.'CONF' .AND. ICTMP2.EQ.'LIMI' .AND.
15819     1     ICTMP0.NE.'SD  ' .AND. ICTMP0.NE.'DEVI' .AND.
15820     1     ICTMP0.NE.'PROP' .AND. ICASAN.NE.'TWOV' .AND.
15821     1     ICTMP0.NE.'MEDI' .AND. ICTMP0.NE.'TRIM' .AND.
15822     1     ICTMP0.NE.'VARI')THEN
15823          IFOUND='YES'
15824          ILASTZ=I+1
15825          ICASAN='ONEV'
15826          GOTO109
15827        ELSEIF(ICTMP1.EQ.'LOWE')THEN
15828          ICASA2='LOWE'
15829        ELSEIF(ICTMP1.EQ.'UPPE')THEN
15830          ICASA2='UPPE'
15831        ELSEIF(ICTMP1.EQ.'REPL')THEN
15832          IREPL='ON'
15833        ELSEIF(ICTMP1.EQ.'MULT')THEN
15834          IMULT='ON'
15835        ELSEIF(ICTMP1.EQ.'LOGN')THEN
15836          ICASA3='LOGN'
15837        ENDIF
15838  100 CONTINUE
15839  109 CONTINUE
15840C
15841      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CONF')THEN
15842        WRITE(ICOUT,111)ICASAN,ICASA2,ICASA3,IREPL
15843  111   FORMAT('ICASAN,ICASA2,ICASA3,IREPL=',3(A4,2X),A4)
15844        CALL DPWRST('XXX','BUG ')
15845      ENDIF
15846C
15847      IF(IFOUND.EQ.'NO')GOTO9000
15848      ISHIFT=ILASTZ
15849      CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
15850     1            IBUGA2,IERROR)
15851C
15852      IF(ICASA3.EQ.'LOGN')ICASAN='LOGN'
15853C
15854      IF(IMULT.EQ.'ON')THEN
15855        IF(IREPL.EQ.'ON')THEN
15856          WRITE(ICOUT,999)
15857          CALL DPWRST('XXX','BUG ')
15858          WRITE(ICOUT,101)
15859  101     FORMAT('***** ERROR IN CONFIDENCE LIMITS--')
15860          CALL DPWRST('XXX','BUG ')
15861          WRITE(ICOUT,102)
15862  102     FORMAT('      YOU CANNOT SPECIFY BOTH "MULTIPLE" AND ',
15863     1           '"REPLICATION" FOR THE CONFIDENCE LIMITS COMMAND.')
15864          CALL DPWRST('XXX','BUG ')
15865          IERROR='YES'
15866          GOTO9000
15867        ENDIF
15868      ENDIF
15869C
15870C               *********************************
15871C               **  STEP 1--                   **
15872C               **  EXTRACT THE VARIABLE LIST  **
15873C               *********************************
15874C
15875      ISTEPN='1'
15876      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CONF')
15877     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15878C
15879      MINNA=1
15880      MAXNA=100
15881      MINNVA=1
15882      MAXNVA=100
15883      IFLAGP=0
15884      JMIN=1
15885      JMAX=NUMARG
15886      MINN2=2
15887C
15888      IF(ICASAN.EQ.'TWOV')THEN
15889        INAME='DIFFERENCE OF THE MEANS CONFIDENCE LIMIT'
15890        IFLAGE=0
15891        IFLAGM=1
15892        MINNA=2
15893        MINNVA=2
15894        MAXNVA=30
15895        IF(IREPL.EQ.'ON')THEN
15896          MAXNVA=8
15897          IFLAGE=1
15898          IFLAGM=0
15899        ENDIF
15900      ELSEIF(ICASAN.EQ.'LOGN')THEN
15901        INAME='LOGNORMAL CONFIDENCE LIMITS FOR THE MEAN'
15902        MINNVA=1
15903        MAXNVA=30
15904        IFLAGE=0
15905        IFLAGM=1
15906        IF(IREPL.EQ.'ON')THEN
15907          MINNVA=2
15908          MAXNVA=7
15909          IFLAGE=0
15910          IFLAGM=0
15911        ENDIF
15912      ELSE
15913        INAME='CONFIDENCE LIMITS FOR THE MEAN'
15914        MINNVA=1
15915        MAXNVA=30
15916        IFLAGE=0
15917        IFLAGM=1
15918        IF(IREPL.EQ.'ON')THEN
15919          MINNVA=2
15920          MAXNVA=7
15921          IFLAGE=0
15922          IFLAGM=0
15923        ENDIF
15924      ENDIF
15925C
15926      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
15927     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
15928     1            JMIN,JMAX,
15929     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
15930     1            IVARN1,IVARN2,IVARTY,PVAR,
15931     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
15932     1            MINNVA,MAXNVA,
15933     1            IFLAGM,IFLAGP,
15934     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
15935      IF(IERROR.EQ.'YES')GOTO9000
15936C
15937      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CONF')THEN
15938        WRITE(ICOUT,999)
15939        CALL DPWRST('XXX','BUG ')
15940        WRITE(ICOUT,181)
15941  181   FORMAT('***** AFTER CALL DPPARS--')
15942        CALL DPWRST('XXX','BUG ')
15943        WRITE(ICOUT,182)NQ,NUMVAR,IMULT,IREPL,ICASAN
15944  182   FORMAT('NQ,NUMVAR,IMULT,IREPL,ICASAN = ',2I8,3(2X,A4))
15945        CALL DPWRST('XXX','BUG ')
15946        IF(NUMVAR.GT.0)THEN
15947          DO185I=1,NUMVAR
15948            WRITE(ICOUT,187)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
15949     1                      ICOLR(I)
15950  187       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
15951     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
15952            CALL DPWRST('XXX','BUG ')
15953  185     CONTINUE
15954        ENDIF
15955      ENDIF
15956C
15957C               ***********************************************
15958C               **  STEP 2--                                 **
15959C               **  DETERMINE:                               **
15960C               **  1) NUMBER OF REPLICATION VARIABLES (0-6) **
15961C               **  2) NUMBER OF RESPONSE    VARIABLES (>= 1)**
15962C               ***********************************************
15963C
15964      ISTEPN='2'
15965      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CONF')
15966     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15967C
15968      NRESP=NUMVAR
15969      NREPL=0
15970C
15971      IF(IREPL.EQ.'ON')THEN
15972        NRESP=1
15973        IF(ICASAN.EQ.'TWOV')NRESP=2
15974        NREPL=NUMVAR-NRESP
15975        IF(NREPL.LT.1 .OR. NREPL.GT.6)THEN
15976          WRITE(ICOUT,999)
15977          CALL DPWRST('XXX','BUG ')
15978          WRITE(ICOUT,101)
15979          CALL DPWRST('XXX','BUG ')
15980          WRITE(ICOUT,211)
15981  211     FORMAT('      FOR THE REPLICATION CASE, THE NUMBER OF ',
15982     1           'REPLICATION VARIABLES')
15983          CALL DPWRST('XXX','BUG ')
15984          WRITE(ICOUT,213)NREPL
15985  213     FORMAT('      THE NUMBER OF REPLICATION VARIABLES = ',I5)
15986          CALL DPWRST('XXX','BUG ')
15987          IERROR='YES'
15988          GOTO9000
15989        ENDIF
15990      ENDIF
15991C
15992      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CONF')THEN
15993        WRITE(ICOUT,221)NRESP,NREPL
15994  221   FORMAT('NRESP,NREPL = ',2I5)
15995        CALL DPWRST('XXX','BUG ')
15996      ENDIF
15997C
15998C               *******************************************
15999C               **  STEP 3--                             **
16000C               **  CASE 1: NO REPLICATION CASE.         **
16001C               *******************************************
16002C
16003      IF(IREPL.EQ.'OFF' .AND.
16004     1   (ICASAN.EQ.'ONEV' .OR. ICASAN.EQ.'LOGN'))THEN
16005C
16006        ISTEPN='3'
16007        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CONF')
16008     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16009C
16010C       LOOP THROUGH EACH OF THE RESPONSE VARIABLES
16011C
16012        NCURVE=0
16013        DO310IRESP=1,NRESP
16014          NCURVE=NCURVE+1
16015C
16016          IINDX=ICOLR(IRESP)
16017          PID(1)=CPUMIN
16018          IVARID(1)=IVARN1(IRESP)
16019          IVARI2(1)=IVARN2(IRESP)
16020C
16021          IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CONF')THEN
16022            WRITE(ICOUT,999)
16023            CALL DPWRST('XXX','BUG ')
16024            WRITE(ICOUT,311)IRESP,NCURVE
16025  311       FORMAT('IRESP,NCURVE = ',2I5)
16026            CALL DPWRST('XXX','BUG ')
16027          ENDIF
16028C
16029          ICOL=IRESP
16030          NUMVA2=1
16031          CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
16032     1                INAME,IVARN1,IVARN2,IVARTY,
16033     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
16034     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
16035     1                MAXCP4,MAXCP5,MAXCP6,
16036     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
16037     1                Y,XTEMP1,XTEMP2,NLOCAL,NLOCA2,NLOCA3,ICASE,
16038     1                IBUGA3,ISUBRO,IFOUND,IERROR)
16039          IF(IERROR.EQ.'YES')GOTO9000
16040C
16041C         *****************************************************
16042C         **  STEP 3B--                                      **
16043C         *****************************************************
16044C
16045          ISTEPN='3B'
16046          IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CONF')
16047     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16048C
16049          IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CONF')THEN
16050            WRITE(ICOUT,999)
16051            CALL DPWRST('XXX','BUG ')
16052            WRITE(ICOUT,322)
16053  322       FORMAT('***** FROM THE MIDDLE  OF DPCONF--')
16054            CALL DPWRST('XXX','BUG ')
16055            WRITE(ICOUT,323)ICASAN,NUMVAR,NLOCAL,IRESP
16056  323       FORMAT('ICASAN,NUMVAR,NLOCAL,IRESP = ',A4,3I8)
16057            CALL DPWRST('XXX','BUG ')
16058            IF(NLOCAL.GE.1)THEN
16059              DO325I=1,NLOCAL
16060                WRITE(ICOUT,326)I,Y(I)
16061  326           FORMAT('I,Y(I) = ',I8,F12.5)
16062                CALL DPWRST('XXX','BUG ')
16063  325         CONTINUE
16064            ENDIF
16065          ENDIF
16066C
16067          CALL DPCNF2(Y,NLOCAL,X,NLOCA2,
16068     1                PID,IVARID,IVARI2,NREPL,
16069     1                CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
16070     1                CTL999,CTU999,
16071     1                ICAPSW,ICAPTY,IFORSW,ICASAN,ICASA2,
16072     1                ISUBRO,IBUGA3,IERROR)
16073C
16074          IFLAGU='FILE'
16075          IF(NRESP.EQ.1)IFLAGU='ON'
16076          IFRST=.FALSE.
16077          ILAST=.FALSE.
16078          IF(IRESP.EQ.1)IFRST=.TRUE.
16079          IF(IRESP.EQ.NRESP)ILAST=.TRUE.
16080          CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
16081     1                CTL999,CTU999,
16082     1                IFLAGU,IFRST,ILAST,ICASAN,
16083     1                IBUGA2,IBUGA3,ISUBRO,IERROR)
16084C
16085  310   CONTINUE
16086C
16087C               ****************************************************
16088C               **  STEP 5A--                                     **
16089C               **  CASE 3: ONE OR MORE REPLICATION VARIABLES.    **
16090C               **          FOR THIS CASE, ALL VARIABLES MUST     **
16091C               **          HAVE THE SAME LENGTH.                 **
16092C               ****************************************************
16093C
16094      ELSEIF(IREPL.EQ.'OFF' .AND. ICASAN.EQ.'TWOV')THEN
16095C
16096        ISTEPN='4A'
16097        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CONF')
16098     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16099C
16100        NUMVA2=1
16101        DO410I=1,NUMVAR
16102          DO420J=I+1,NUMVAR
16103            ICOL=I
16104            CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
16105     1                  INAME,IVARN1,IVARN2,IVARTY,
16106     1                  ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
16107     1                  MAXCOL,MAXCP1,MAXCP2,MAXCP3,
16108     1                  MAXCP4,MAXCP5,MAXCP6,
16109     1                  V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
16110     1                  Y,Y,Y,NS1,NLOCA2,NLOCA3,ICASE,
16111     1                  IBUGA3,ISUBRO,IFOUND,IERROR)
16112            IF(IERROR.EQ.'YES')GOTO9000
16113C
16114            ICOL=J
16115            CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
16116     1                  INAME,IVARN1,IVARN2,IVARTY,
16117     1                  ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
16118     1                  MAXCOL,MAXCP1,MAXCP2,MAXCP3,
16119     1                  MAXCP4,MAXCP5,MAXCP6,
16120     1                  V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
16121     1                  X,X,X,NS2,NLOCA2,NLOCA3,ICASE,
16122     1                  IBUGA3,ISUBRO,IFOUND,IERROR)
16123            IF(IERROR.EQ.'YES')GOTO9000
16124C
16125C               *****************************************
16126C               **  STEP 4B--                          **
16127C               **  PERFORM DIFFERENCE OF MEANS        **
16128C               **          CONFIDENCE LIMITS          **
16129C               *****************************************
16130C
16131            ISTEPN='52'
16132            IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CONF')THEN
16133              CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16134              WRITE(ICOUT,999)
16135              CALL DPWRST('XXX','BUG ')
16136              WRITE(ICOUT,411)
16137 411          FORMAT('***** FROM DPCONF, BEFORE CALL DPCNF2--')
16138              CALL DPWRST('XXX','BUG ')
16139              WRITE(ICOUT,412)I,J,NS1,NS2,MAXN
16140 412          FORMAT('I,J,NS1,NS2,MAXN = ',5I8)
16141              CALL DPWRST('XXX','BUG ')
16142              DO415II=1,MAX(NS1,NS2)
16143                WRITE(ICOUT,416)II,Y(II),X(II)
16144 416            FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
16145                CALL DPWRST('XXX','BUG ')
16146 415          CONTINUE
16147            ENDIF
16148C
16149            IVARID(1)=IVARN1(I)
16150            IVARI2(1)=IVARN2(I)
16151            IVARID(2)=IVARN1(J)
16152            IVARI2(2)=IVARN2(J)
16153            CALL DPCNF2(Y,NS1,X,NS2,
16154     1                  PID,IVARID,IVARI2,NREPL,
16155     1                  CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
16156     1                  CTL999,CTU999,
16157     1                  ICAPSW,ICAPTY,IFORSW,ICASAN,ICASA2,
16158     1                  ISUBRO,IBUGA3,IERROR)
16159C
16160C               ***************************************
16161C               **  STEP 8C--                        **
16162C               **  UPDATE INTERNAL DATAPLOT TABLES  **
16163C               ***************************************
16164C
16165            ISTEPN='8C'
16166            IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CNF2')
16167     1        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16168C
16169            IF(NUMVAR.GT.2)THEN
16170              IFLAGU='FILE'
16171            ELSE
16172              IFLAGU='ON'
16173            ENDIF
16174            IFRST=.FALSE.
16175            ILAST=.FALSE.
16176            IF(I.EQ.1 .AND. J.EQ.2)IFRST=.TRUE.
16177            IF(I.EQ.NUMVAR .AND. J.EQ.NUMVAR)ILAST=.TRUE.
16178            CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
16179     1                  CTL999,CTU999,
16180     1                  IFLAGU,IFRST,ILAST,ICASAN,
16181     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
16182C
16183 420        CONTINUE
16184 410      CONTINUE
16185C
16186      ELSEIF(IREPL.EQ.'ON')THEN
16187        ISTEPN='5A'
16188        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CONF')
16189     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16190C
16191        J=0
16192        IMAX=NRIGHT(1)
16193        IF(NQ.LT.NRIGHT(1))IMAX=NQ
16194        DO510I=1,IMAX
16195          IF(ISUB(I).EQ.0)GOTO510
16196          J=J+1
16197C
16198C         RESPONSE VARIABLE IN Y
16199C
16200          ICOLC=1
16201          IJ=MAXN*(ICOLR(ICOLC)-1)+I
16202          IF(ICOLR(ICOLC).LE.MAXCOL)Y(J)=V(IJ)
16203          IF(ICOLR(ICOLC).EQ.MAXCP1)Y(J)=PRED(I)
16204          IF(ICOLR(ICOLC).EQ.MAXCP2)Y(J)=RES(I)
16205          IF(ICOLR(ICOLC).EQ.MAXCP3)Y(J)=YPLOT(I)
16206          IF(ICOLR(ICOLC).EQ.MAXCP4)Y(J)=XPLOT(I)
16207          IF(ICOLR(ICOLC).EQ.MAXCP5)Y(J)=X2PLOT(I)
16208          IF(ICOLR(ICOLC).EQ.MAXCP6)Y(J)=TAGPLO(I)
16209C
16210C         SECOND RESPONSE VARIABLE FOR DIFFERENCE OF MEANS CASE
16211C
16212          IF(ICASAN.EQ.'TWOV')THEN
16213            ICOLC=ICOLC+1
16214            ICOLT=ICOLR(ICOLC)
16215            IJ=MAXN*(ICOLT-1)+I
16216            IF(ICOLT.LE.MAXCOL)X(J)=V(IJ)
16217            IF(ICOLT.EQ.MAXCP1)X(J)=PRED(I)
16218            IF(ICOLT.EQ.MAXCP2)X(J)=RES(I)
16219            IF(ICOLT.EQ.MAXCP3)X(J)=YPLOT(I)
16220            IF(ICOLT.EQ.MAXCP4)X(J)=XPLOT(I)
16221            IF(ICOLT.EQ.MAXCP5)X(J)=X2PLOT(I)
16222            IF(ICOLT.EQ.MAXCP6)X(J)=TAGPLO(I)
16223          ELSE
16224            X(J)=0.0
16225          ENDIF
16226C
16227          IF(NREPL.GE.1)THEN
16228            DO520IR=1,MIN(NREPL,6)
16229              ICOLC=ICOLC+1
16230              ICOLT=ICOLR(ICOLC)
16231              IJ=MAXN*(ICOLT-1)+I
16232              IF(ICOLT.LE.MAXCOL)XDESGN(J,IR)=V(IJ)
16233              IF(ICOLT.EQ.MAXCP1)XDESGN(J,IR)=PRED(I)
16234              IF(ICOLT.EQ.MAXCP2)XDESGN(J,IR)=RES(I)
16235              IF(ICOLT.EQ.MAXCP3)XDESGN(J,IR)=YPLOT(I)
16236              IF(ICOLT.EQ.MAXCP4)XDESGN(J,IR)=XPLOT(I)
16237              IF(ICOLT.EQ.MAXCP5)XDESGN(J,IR)=X2PLOT(I)
16238              IF(ICOLT.EQ.MAXCP6)XDESGN(J,IR)=TAGPLO(I)
16239  520       CONTINUE
16240          ENDIF
16241C
16242  510   CONTINUE
16243        NLOCAL=J
16244C
16245        ISTEPN='5B'
16246        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CONF')
16247     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16248C
16249        PID(1)=CPUMIN
16250        IVARID(1)=IVARN1(1)
16251        IVARI2(1)=IVARN2(1)
16252        IADD=1
16253        IF(ICASAN.EQ.'TWOV')THEN
16254          IADD=2
16255          PID(2)=CPUMIN
16256          IVARID(2)=IVARN1(2)
16257          IVARI2(2)=IVARN2(2)
16258        ENDIF
16259        DO540II=1,NREPL
16260          IVARID(II+IADD)=IVARN1(II+IADD)
16261          IVARI2(II+IADD)=IVARN2(II+IADD)
16262          IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CONF')THEN
16263            WRITE(ICOUT,532)IADD,II,IVARID(II+IADD),IVARN1(II+IADD)
16264  532       FORMAT('IADD,II,IVARID(II+IADD),IVARN1(II+IADD) = ',
16265     1             2I8,A4,2X,A4)
16266          CALL DPWRST('XXX','BUG ')
16267          ENDIF
16268  540   CONTINUE
16269C
16270C       *****************************************************
16271C       **  STEP 5C--                                      **
16272C       **                                                 **
16273C       **  FOR THIS CASE, WE NEED TO LOOP THROUGH THE     **
16274C       **  VARIOUS REPLICATIONS.                          **
16275C       *****************************************************
16276C
16277        ISTEPN='5C'
16278        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CONF')
16279     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16280C
16281        IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CONF')THEN
16282          WRITE(ICOUT,999)
16283          CALL DPWRST('XXX','BUG ')
16284          WRITE(ICOUT,541)
16285  541     FORMAT('***** FROM THE MIDDLE  OF DPCONF--')
16286          CALL DPWRST('XXX','BUG ')
16287          WRITE(ICOUT,542)ICASAN,NUMVAR,NLOCAL,NLOCA2,NREPL
16288  542     FORMAT('ICASAN,NUMVAR,NLOCAL,NLOCA2,NREPL = ',A4,2X,4I8)
16289          CALL DPWRST('XXX','BUG ')
16290          IF(NLOCAL.GE.1)THEN
16291            DO545I=1,NLOCAL
16292              WRITE(ICOUT,546)I,Y(I),X(I),XDESGN(I,1),XDESGN(I,2)
16293  546         FORMAT('I,Y(I),X(I),XDESGN(I,1),XDESGN(I,2) = ',
16294     1               I8,4F12.5)
16295              CALL DPWRST('XXX','BUG ')
16296  545       CONTINUE
16297          ENDIF
16298        ENDIF
16299C
16300C       *****************************************************
16301C       **  STEP 5C--                                      **
16302C       **  FIND THE DISTINCT VALUES IN EACH OF THE        **
16303C       **  REPLICATION VARIABLES.                         **
16304C       *****************************************************
16305C
16306        CALL DPPP5(XDESGN(1,1),XDESGN(1,2),XDESGN(1,3),
16307     1             XDESGN(1,4),XDESGN(1,5),XDESGN(1,6),
16308     1             NREPL,NLOCAL,MAXOBV,
16309     1             XIDTEM,XIDTE2,XIDTE3,XIDTE4,XIDTE5,XIDTE6,
16310     1             XTEMP1,XTEMP2,
16311     1             NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,NUMSE6,
16312     1             IBUGA3,ISUBRO,IERROR)
16313C
16314C       *****************************************************
16315C       **  STEP 5D--                                      **
16316C       **  NOW LOOP THROUGH THE VARIOUS REPLICATIONS      **
16317C       *****************************************************
16318C
16319        NPLOTP=0
16320        NCURVE=0
16321        IF(NREPL.EQ.1)THEN
16322          J=0
16323          DO1110ISET1=1,NUMSE1
16324            K=0
16325            PID(IADD+1)=XIDTEM(ISET1)
16326            DO1130I=1,NLOCAL
16327              IF(XIDTEM(ISET1).EQ.XDESGN(I,1))THEN
16328                K=K+1
16329                TEMP1(K)=Y(I)
16330                TEMP2(K)=X(I)
16331              ENDIF
16332 1130       CONTINUE
16333            NTEMP=K
16334            NCURVE=NCURVE+1
16335            IF(NTEMP.GT.0)THEN
16336              CALL DPCNF2(TEMP1,NTEMP,TEMP2,NTEMP,
16337     1                    PID,IVARID,IVARI2,NREPL,
16338     1                    CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
16339     1                    CTL999,CTU999,
16340     1                    ICAPSW,ICAPTY,IFORSW,ICASAN,ICASA2,
16341     1                    ISUBRO,IBUGA3,IERROR)
16342            ENDIF
16343C
16344            IFLAGU='FILE'
16345            IFRST=.FALSE.
16346            ILAST=.FALSE.
16347            IF(NCURVE.EQ.1)IFRST=.TRUE.
16348            IF(NCURVE.EQ.NUMSE1)ILAST=.TRUE.
16349            CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
16350     1                  CTL999,CTU999,
16351     1                  IFLAGU,IFRST,ILAST,ICASAN,
16352     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
16353 1110     CONTINUE
16354        ELSEIF(NREPL.EQ.2)THEN
16355          J=0
16356          NTOT=NUMSE1*NUMSE2
16357          DO1210ISET1=1,NUMSE1
16358          DO1220ISET2=1,NUMSE2
16359            K=0
16360            PID(1+IADD)=XIDTEM(ISET1)
16361            PID(2+IADD)=XIDTE2(ISET2)
16362            DO1290I=1,NLOCAL
16363              IF(
16364     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
16365     1           XIDTE2(ISET2).EQ.XDESGN(I,2)
16366     1          )THEN
16367                K=K+1
16368                TEMP1(K)=Y(I)
16369                TEMP2(K)=X(I)
16370              ENDIF
16371 1290       CONTINUE
16372            NTEMP=K
16373            NCURVE=NCURVE+1
16374            NPLOT1=NPLOTP
16375            IF(NTEMP.GT.0)THEN
16376              CALL DPCNF2(TEMP1,NTEMP,TEMP2,NTEMP,
16377     1                    PID,IVARID,IVARI2,NREPL,
16378     1                    CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
16379     1                    CTL999,CTU999,
16380     1                    ICAPSW,ICAPTY,IFORSW,ICASAN,ICASA2,
16381     1                    ISUBRO,IBUGA3,IERROR)
16382            ENDIF
16383            NPLOT2=NPLOTP
16384            IFLAGU='FILE'
16385            IFRST=.FALSE.
16386            ILAST=.FALSE.
16387            IF(NCURVE.EQ.1)IFRST=.TRUE.
16388            IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
16389            CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
16390     1                  CTL999,CTU999,
16391     1                  IFLAGU,IFRST,ILAST,ICASAN,
16392     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
16393 1220     CONTINUE
16394 1210     CONTINUE
16395        ELSEIF(NREPL.EQ.3)THEN
16396          J=0
16397          NTOT=NUMSE1*NUMSE2*NUMSE3
16398          DO1310ISET1=1,NUMSE1
16399          DO1320ISET2=1,NUMSE2
16400          DO1330ISET3=1,NUMSE3
16401            K=0
16402            PID(1+IADD)=XIDTEM(ISET1)
16403            PID(2+IADD)=XIDTE2(ISET2)
16404            PID(3+IADD)=XIDTE3(ISET3)
16405            DO1390I=1,NLOCAL
16406              IF(
16407     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
16408     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
16409     1           XIDTE3(ISET3).EQ.XDESGN(I,3)
16410     1          )THEN
16411                K=K+1
16412                TEMP1(K)=Y(I)
16413                TEMP2(K)=X(I)
16414              ENDIF
16415 1390       CONTINUE
16416            NTEMP=K
16417            NCURVE=NCURVE+1
16418            IF(NTEMP.GT.0)THEN
16419              CALL DPCNF2(TEMP1,NTEMP,TEMP2,NTEMP,
16420     1                    PID,IVARID,IVARI2,NREPL,
16421     1                    CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
16422     1                    CTL999,CTU999,
16423     1                    ICAPSW,ICAPTY,IFORSW,ICASAN,ICASA2,
16424     1                    ISUBRO,IBUGA3,IERROR)
16425            ENDIF
16426            IFLAGU='FILE'
16427            IFRST=.FALSE.
16428            ILAST=.FALSE.
16429            IF(NCURVE.EQ.1)IFRST=.TRUE.
16430            IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
16431            CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
16432     1                  CTL999,CTU999,
16433     1                  IFLAGU,IFRST,ILAST,ICASAN,
16434     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
16435 1330     CONTINUE
16436 1320     CONTINUE
16437 1310     CONTINUE
16438        ELSEIF(NREPL.EQ.4)THEN
16439          J=0
16440          NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4
16441          DO1410ISET1=1,NUMSE1
16442          DO1420ISET2=1,NUMSE2
16443          DO1430ISET3=1,NUMSE3
16444          DO1440ISET4=1,NUMSE4
16445            K=0
16446            PID(1+IADD)=XIDTEM(ISET1)
16447            PID(2+IADD)=XIDTE2(ISET2)
16448            PID(3+IADD)=XIDTE3(ISET3)
16449            PID(4+IADD)=XIDTE4(ISET4)
16450            DO1490I=1,NLOCAL
16451              IF(
16452     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
16453     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
16454     1           XIDTE3(ISET3).EQ.XDESGN(I,3) .AND.
16455     1           XIDTE4(ISET4).EQ.XDESGN(I,4)
16456     1          )THEN
16457                K=K+1
16458                TEMP1(K)=Y(I)
16459                TEMP2(K)=X(I)
16460              ENDIF
16461 1490       CONTINUE
16462            NTEMP=K
16463            NCURVE=NCURVE+1
16464            IF(NTEMP.GT.0)THEN
16465              CALL DPCNF2(TEMP1,NTEMP,TEMP2,NTEMP,
16466     1                    PID,IVARID,IVARI2,NREPL,
16467     1                    CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
16468     1                    CTL999,CTU999,
16469     1                    ICAPSW,ICAPTY,IFORSW,ICASAN,ICASA2,
16470     1                    ISUBRO,IBUGA3,IERROR)
16471            ENDIF
16472            IFLAGU='FILE'
16473            IFRST=.FALSE.
16474            ILAST=.FALSE.
16475            IF(NCURVE.EQ.1)IFRST=.TRUE.
16476            IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
16477            CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
16478     1                  CTL999,CTU999,
16479     1                  IFLAGU,IFRST,ILAST,ICASAN,
16480     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
16481 1440     CONTINUE
16482 1430     CONTINUE
16483 1420     CONTINUE
16484 1410     CONTINUE
16485        ELSEIF(NREPL.EQ.5)THEN
16486          J=0
16487          NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5
16488          DO1510ISET1=1,NUMSE1
16489          DO1520ISET2=1,NUMSE2
16490          DO1530ISET3=1,NUMSE3
16491          DO1540ISET4=1,NUMSE4
16492          DO1550ISET5=1,NUMSE5
16493            K=0
16494            PID(1+IADD)=XIDTEM(ISET1)
16495            PID(2+IADD)=XIDTE2(ISET2)
16496            PID(3+IADD)=XIDTE3(ISET3)
16497            PID(4+IADD)=XIDTE4(ISET4)
16498            PID(5+IADD)=XIDTE5(ISET4)
16499            DO1590I=1,NLOCAL
16500              IF(
16501     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
16502     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
16503     1           XIDTE3(ISET3).EQ.XDESGN(I,3) .AND.
16504     1           XIDTE4(ISET4).EQ.XDESGN(I,4) .AND.
16505     1           XIDTE5(ISET5).EQ.XDESGN(I,5)
16506     1          )THEN
16507                K=K+1
16508                TEMP1(K)=Y(I)
16509                TEMP2(K)=X(I)
16510              ENDIF
16511 1590       CONTINUE
16512            NTEMP=K
16513            NCURVE=NCURVE+1
16514            IF(NTEMP.GT.0)THEN
16515              CALL DPCNF2(TEMP1,NTEMP,TEMP2,NTEMP,
16516     1                    PID,IVARID,IVARI2,NREPL,
16517     1                    CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
16518     1                    CTL999,CTU999,
16519     1                    ICAPSW,ICAPTY,IFORSW,ICASAN,ICASA2,
16520     1                    ISUBRO,IBUGA3,IERROR)
16521            ENDIF
16522            IFLAGU='FILE'
16523            IFRST=.FALSE.
16524            ILAST=.FALSE.
16525            IF(NCURVE.EQ.1)IFRST=.TRUE.
16526            IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
16527            CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
16528     1                  CTL999,CTU999,
16529     1                  IFLAGU,IFRST,ILAST,ICASAN,
16530     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
16531 1550     CONTINUE
16532 1540     CONTINUE
16533 1530     CONTINUE
16534 1520     CONTINUE
16535 1510     CONTINUE
16536        ELSEIF(NREPL.EQ.6)THEN
16537          J=0
16538          NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5*NUMSE6
16539          DO1610ISET1=1,NUMSE1
16540          DO1620ISET2=1,NUMSE2
16541          DO1630ISET3=1,NUMSE3
16542          DO1640ISET4=1,NUMSE4
16543          DO1650ISET5=1,NUMSE5
16544          DO1660ISET6=1,NUMSE6
16545            K=0
16546            PID(1+IADD)=XIDTEM(ISET1)
16547            PID(2+IADD)=XIDTE2(ISET2)
16548            PID(3+IADD)=XIDTE3(ISET3)
16549            PID(4+IADD)=XIDTE4(ISET4)
16550            PID(5+IADD)=XIDTE5(ISET4)
16551            PID(6+IADD)=XIDTE6(ISET4)
16552            DO1690I=1,NLOCAL
16553              IF(
16554     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
16555     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
16556     1           XIDTE3(ISET3).EQ.XDESGN(I,3) .AND.
16557     1           XIDTE4(ISET4).EQ.XDESGN(I,4) .AND.
16558     1           XIDTE5(ISET5).EQ.XDESGN(I,5) .AND.
16559     1           XIDTE6(ISET6).EQ.XDESGN(I,6)
16560     1          )THEN
16561                K=K+1
16562                TEMP1(K)=Y(I)
16563                TEMP2(K)=X(I)
16564              ENDIF
16565 1690       CONTINUE
16566            NTEMP=K
16567            NCURVE=NCURVE+1
16568            IF(NTEMP.GT.0)THEN
16569              CALL DPCNF2(TEMP1,NTEMP,TEMP2,NTEMP,
16570     1                    PID,IVARID,IVARI2,NREPL,
16571     1                    CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
16572     1                    CTL999,CTU999,
16573     1                    ICAPSW,ICAPTY,IFORSW,ICASAN,ICASA2,
16574     1                    ISUBRO,IBUGA3,IERROR)
16575            ENDIF
16576            IFLAGU='FILE'
16577            IFRST=.FALSE.
16578            ILAST=.FALSE.
16579            IF(NCURVE.EQ.1)IFRST=.TRUE.
16580            IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
16581            CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
16582     1                  CTL999,CTU999,
16583     1                  IFLAGU,IFRST,ILAST,ICASAN,
16584     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
16585 1660     CONTINUE
16586 1650     CONTINUE
16587 1640     CONTINUE
16588 1630     CONTINUE
16589 1620     CONTINUE
16590 1610     CONTINUE
16591        ENDIF
16592C
16593      ENDIF
16594C
16595C               *****************
16596C               **  STEP 90--  **
16597C               **  EXIT       **
16598C               *****************
16599C
16600 9000 CONTINUE
16601      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CONF')THEN
16602        WRITE(ICOUT,999)
16603        CALL DPWRST('XXX','BUG ')
16604        WRITE(ICOUT,9011)
16605 9011   FORMAT('***** AT THE END       OF DPCONF--')
16606        CALL DPWRST('XXX','BUG ')
16607        WRITE(ICOUT,9014)NRIGHT(1),NRIGHT(2)
16608 9014   FORMAT('NRIGHT(1),NRIGHT(2) = ',2I8)
16609        CALL DPWRST('XXX','BUG ')
16610        WRITE(ICOUT,9016)IFOUND,IERROR
16611 9016   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
16612        CALL DPWRST('XXX','BUG ')
16613      ENDIF
16614C
16615      RETURN
16616      END
16617      SUBROUTINE DPCONH(IVAL,VAL,IH,NH,IBUGD2,IERROR)
16618C
16619C     NOTE--THIS SUBROUTINE IS IDENTICAL TO DPCON2.
16620C           IT HAS BEEN DUPLICATED AND PLACED
16621C           ON THIS BRANCH OF THE OVERLAY/SEGMENTATION
16622C           TREE STRUCTURE IN ORDER TO ACHIEVE
16623C           FASTER EXECUTION TIME.
16624C
16625C     NOTE--UPON INPUT, IVALUE IS USUALLY INT(VALUE+0.5), BUT
16626C       FOR NEGATIVE VALUE, IVALUE SHOULD BE INT(VALUE-0.5)
16627C
16628C     PURPOSE--CONVERT NUMERIC VALUE INTO CORRESPONDING
16629C              CHARACTER STRING.
16630C
16631C     WRITTEN BY--JAMES J. FILLIBEN
16632C                 STATISTICAL ENGINEERING DIVISION
16633C                 INFORMATION TECHNOLOGY LABORATORY
16634C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
16635C                 GAITHERSBURG, MD 20899-8980
16636C                 PHONE--301-975-2855
16637C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
16638C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
16639C     LANGUAGE--ANSI FORTRAN (1977)
16640C     VERSION NUMBER--82/7
16641C     ORIGINAL VERSION--MARCH   1983.
16642C     UPDATED         --JANUARY  2000. SUPPORT FOR EXPONENTIAL
16643C                                      EXPANSION (THIS IS PRIMARILY
16644C                                      FOR USE WITH THE FIT COMMAND)
16645C     UPDATED         --FEBRUARY 2005. SUPPORT FOR "SET PARAMETER
16646C                                      EXPAND DIGITS"
16647C     UPDATED         --FEBRUARY 2011. FIX TO EXTEND THE PRECISION
16648C                                      A FEW EXTRA PLACES
16649C     UPDATED         --MAY      2016. FIX TO EXTEND THE PRECISION
16650C                                      A FEW EXTRA PLACES (UP TO 9
16651C                                      DIGITS BY DEFAULT)
16652C
16653C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
16654C
16655      CHARACTER*4 IH
16656      CHARACTER*4 IBUGD2
16657      CHARACTER*4 IERROR
16658C
16659      CHARACTER*4 IHREM
16660      CHARACTER*4 IHNUM
16661      CHARACTER*4 IHTEMI
16662      CHARACTER*4 IHTEMD
16663C
16664      CHARACTER*25 IJUNK
16665      CHARACTER*10 IFORMT
16666C
16667      DIMENSION IH(*)
16668      DIMENSION IHTEMI(10)
16669      DIMENSION IHTEMD(10)
16670C
16671C-----COMMON----------------------------------------------------------
16672C
16673      INCLUDE 'DPCOST.INC'
16674      INCLUDE 'DPCOBE.INC'
16675      INCLUDE 'DPCOP2.INC'
16676C
16677C-----DATA STATEMENTS-------------------------------------------------
16678C
16679C-----START POINT---------------------------------------------------------
16680C
16681      AINUM=0.0
16682      FRACT=0.0
16683      NUMDID=0
16684      IPOS=0
16685C
16686      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CONH')THEN
16687        WRITE(ICOUT,999)
16688        CALL DPWRST('XXX','BUG ')
16689        WRITE(ICOUT,51)
16690   51   FORMAT('***** AT THE BEGINNING OF DPCONH--')
16691        CALL DPWRST('XXX','BUG ')
16692        WRITE(ICOUT,52)IVAL,VAL
16693   52   FORMAT('IVAL,VAL = ',I8,E15.7)
16694        CALL DPWRST('XXX','BUG ')
16695        WRITE(ICOUT,59)IBUGG4,ISUBG4,IERRG4
16696   59   FORMAT('IBUGG4,ISUBG4,IERRG4 = ',2(A4,2X),A4)
16697        CALL DPWRST('XXX','BUG ')
16698      ENDIF
16699C
16700      IF(IEXPPA.EQ.'EXPO')THEN
16701        IJUNK=' '
16702        WRITE(IJUNK,'(D20.12)')DBLE(VAL)
16703        NH=1
16704        IH(1)='('
16705        DO1010I=1,20
16706          IF(IJUNK(I:I).EQ.'D' .OR. IJUNK(I:I).EQ.'E')THEN
16707            DO1020J=1,MAX(1,I-1)
16708              IF(IJUNK(J:J).EQ.' ')GOTO1020
16709              NH=NH+1
16710              IH(NH)=IJUNK(J:J)
16711 1020       CONTINUE
16712            IPOS=I+1
16713            GOTO1019
16714          ENDIF
16715 1010   CONTINUE
16716 1019   CONTINUE
16717C
16718        NH=NH+1
16719        IH(NH)='*'
16720        NH=NH+1
16721        IH(NH)='1'
16722        NH=NH+1
16723        IH(NH)='0'
16724        NH=NH+1
16725        IH(NH)='*'
16726        NH=NH+1
16727        IH(NH)='*'
16728        NH=NH+1
16729        IH(NH)='('
16730        DO1040I=IPOS,20
16731          IF(IJUNK(I:I).EQ.' ')GOTO1040
16732          NH=NH+1
16733          IH(NH)=IJUNK(I:I)
16734 1040   CONTINUE
16735C
16736        NH=NH+1
16737        IH(NH)=')'
16738        NH=NH+1
16739        IH(NH)=')'
16740        GOTO9000
16741      ELSEIF(IEXPDI.GT.0)THEN
16742C
16743        IJUNK=' '
16744        IFORMT=' '
16745        IFORMT(1:8)='(F  .  )'
16746        NJUNK=IEXPDI
16747        IF(NJUNK.GT.15)NJUNK=15
16748        WRITE(IFORMT(6:7),'(I2)')NJUNK
16749        NJUNK=NJUNK+8
16750        WRITE(IFORMT(3:4),'(I2)')NJUNK
16751        WRITE(IJUNK,IFORMT)VAL
16752C
16753        NH=0
16754        DO1050I=1,NJUNK
16755          IF(NH.EQ.0 .AND. IJUNK(I:I).EQ.' ')GOTO1050
16756          NH=NH+1
16757          IH(NH)=IJUNK(I:I)
16758 1050   CONTINUE
16759        GOTO9000
16760      ELSEIF(IEXPDI.EQ.0)THEN
16761C
16762        IJUNK=' '
16763        IFORMT=' '
16764        IFORMT(1:5)='(I15)'
16765        WRITE(IJUNK,IFORMT)INT(VAL+0.5)
16766C
16767        NH=0
16768        DO1060I=1,15
16769          IF(NH.EQ.0 .AND. IJUNK(I:I).EQ.' ')GOTO1060
16770          NH=NH+1
16771          IH(NH)=IJUNK(I:I)
16772 1060   CONTINUE
16773        GOTO9000
16774      ENDIF
16775C
16776      ABSVAL=ABS(VAL)
16777C
16778      AIVAL=IVAL
16779      DEL=AIVAL-VAL
16780      ABSDEL=ABS(DEL)
16781C
16782      ABSRAT=ABSDEL
16783      IF(ABSVAL.GE.1.0)ABSRAT=ABSDEL/ABSVAL
16784C
16785CCCCC CUTDEL=10.0**(-16)
16786CCCCC CUTDEL=10.0**(-6)
16787CCCCC CUTRAT=10.0**(-6)
16788      CUTDEL=10.0**(-10)
16789      CUTRAT=10.0**(-10)
16790C
16791      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CONH')THEN
16792        WRITE(ICOUT,999)
16793        CALL DPWRST('XXX','BUG ')
16794        WRITE(ICOUT,911)
16795  911   FORMAT('***** FROM THE MIDDLE OF DPCONH--')
16796        CALL DPWRST('XXX','BUG ')
16797        WRITE(ICOUT,913)ABSVAL,VAL,IVAL,AIVAL,DEL,ABSDEL
16798  913   FORMAT('ABSVAL,VAL,IVAL,AIVAL,DEL,ABSDEL = ',2G15.7,I8,3G15.7)
16799        CALL DPWRST('XXX','BUG ')
16800        WRITE(ICOUT,914)ABSDEL,CUTDEL,ABSRAT,CUTRAT
16801  914   FORMAT('ABSDEL,CUTDEL,ABSRAT,CUTRAT = ',4G15.7)
16802        CALL DPWRST('XXX','BUG ')
16803      ENDIF
16804C
16805      IF(ABSVAL.LT.1.0.AND.ABSDEL.LE.CUTDEL)GOTO1000
16806      IF(ABSVAL.GE.1.0.AND.ABSRAT.LE.CUTRAT)GOTO1000
16807      GOTO2000
16808C
16809C               ******************************
16810C               **  STEP XX--               **
16811C               **  TREAT THE INTEGER CASE  **
16812C               ******************************
16813C
16814 1000 CONTINUE
16815C
16816      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CONH')THEN
16817        WRITE(ICOUT,1005)
16818 1005   FORMAT('*****INTEGER CASE*****')
16819        CALL DPWRST('XXX','BUG ')
16820      ENDIF
16821C
16822      INUM=IABS(IVAL)
16823      NUMDII=0
16824      IF(INUM.EQ.0)NUMDII=NUMDII+1
16825      IF(INUM.EQ.0)IHTEMI(NUMDII)='0'
16826      IF(INUM.EQ.0)GOTO1190
16827C
16828      DO1100I=1,10
16829        IF(INUM.LE.0)GOTO1190
16830        IRATIO=INUM/10
16831        IREM=INUM-10*IRATIO
16832        INUM=IRATIO
16833        NUMDII=NUMDII+1
16834        CALL DPCODH(IREM,IHREM,IBUGD2,IERROR)
16835        IHTEMI(NUMDII)=IHREM
16836 1100 CONTINUE
16837 1190 CONTINUE
16838      IF(IVAL.LT.0)NUMDII=NUMDII+1
16839      IF(IVAL.LT.0)IHTEMI(NUMDII)='-'
16840C
16841      NH=NUMDII
16842      IF(NUMDII.GT.0)THEN
16843        DO1200I=1,NUMDII
16844          IREV=NUMDII-I+1
16845          IH(I)=IHTEMI(IREV)
16846 1200   CONTINUE
16847      ENDIF
16848C
16849      GOTO9000
16850C
16851C               **********************************
16852C               **  STEP XX--                   **
16853C               **  TREAT THE NON-INTEGER CASE  **
16854C               **********************************
16855C
16856 2000 CONTINUE
16857C
16858      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CONH')THEN
16859        WRITE(ICOUT,2005)
16860 2005   FORMAT('*****NON-INTEGER CASE*****')
16861        CALL DPWRST('XXX','BUG ')
16862      ENDIF
16863C
16864      INUM=INT(ABSVAL)
16865      AINUM=REAL(INUM)
16866      FRACT=ABSVAL-AINUM
16867C
16868      NUMDII=0
16869      IF(INUM.EQ.0)NUMDII=NUMDII+1
16870      IF(INUM.EQ.0)IHTEMI(NUMDII)='0'
16871      IF(INUM.EQ.0)GOTO2190
16872C
16873      DO2100I=1,10
16874        IF(INUM.LE.0)GOTO2190
16875        IRATIO=INUM/10
16876        IREM=INUM-10*IRATIO
16877        INUM=IRATIO
16878        NUMDII=NUMDII+1
16879        CALL DPCODH(IREM,IHREM,IBUGD2,IERROR)
16880        IHTEMI(NUMDII)=IHREM
16881 2100 CONTINUE
16882 2190 CONTINUE
16883      IF(VAL.LT.0)NUMDII=NUMDII+1
16884      IF(VAL.LT.0)IHTEMI(NUMDII)='-'
16885C
16886      NUMDID=0
16887      IF(FRACT.EQ.0.0)NUMDID=0
16888      IF(FRACT.EQ.0.0)GOTO2390
16889C
16890      ANUM=FRACT
16891CCCCC NOTE 2011/2: ADD A FEW EXTRA DIGITS OF PRECISION
16892CCCCC NLOOP=8-NUMDII
16893CCCCC NLOOP=12-NUMDII
16894      NLOOP=14-NUMDII
16895CCCCC CUTOF2=10.0**(-NLOOP+1)
16896CCCCC CUTOF3=1.0-CUTOF2
16897      IF(NLOOP.LE.0)GOTO2390
16898      DO2300I=1,NLOOP
16899        CUTOF2=10.0**(-NLOOP+I+1)
16900        CUTOF3=1.0-CUTOF2
16901        ANUM=ANUM*10.0
16902        INUM=INT(ANUM)
16903        AINUM=REAL(INUM)
16904        DEL3=ANUM-AINUM
16905C
16906        IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CONH')THEN
16907          WRITE(ICOUT,2311)NLOOP,I,CUTOF3,CUTOF2
16908 2311     FORMAT('NLOOP,I,CUTOF3,CUTOF2 = ',I8,I8,2G15.7)
16909          CALL DPWRST('XXX','BUG ')
16910          WRITE(ICOUT,2312)ANUM,AINUM,DEL3,CUTOF3
16911 2312     FORMAT('ANUM,AINUM,DEL3,CUTOF3 = ',4G15.7)
16912          CALL DPWRST('XXX','BUG ')
16913        ENDIF
16914C
16915CCCCC   IF(CUTOF3.GT.0.0000001)THEN
16916        IF(CUTOF3.GT.0.000000001)THEN
16917          IF(DEL3.GE.CUTOF3)INUM=INUM+1
16918          IF(DEL3.GE.CUTOF3)ANUM=INUM
16919        ELSE
16920          IF(DEL3.GE.0.5)INUM=INUM+1
16921          IF(DEL3.GE.0.5)ANUM=INUM
16922        ENDIF
16923        NUMDID=NUMDID+1
16924        CALL DPCODH(INUM,IHNUM,IBUGD2,IERROR)
16925        IHTEMD(NUMDID)=IHNUM
16926        AINUM=INUM
16927        DEL2=ANUM-AINUM
16928        ANUM=DEL2
16929C
16930        IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CONH')THEN
16931          WRITE(ICOUT,2313)ANUM,AINUM,DEL2,CUTOF2
16932 2313     FORMAT('ANUM,AINUM,DEL2,CUTOF2 = ',4G15.7)
16933          CALL DPWRST('XXX','BUG ')
16934        ENDIF
16935C
16936        IF(DEL2.LE.CUTOF2)GOTO2390
16937 2300 CONTINUE
16938 2390 CONTINUE
16939C
16940      NH=0
16941      IF(NUMDII.GT.0)THEN
16942        DO2400I=1,NUMDII
16943        NH=NH+1
16944        IREV=NUMDII-I+1
16945        IH(NH)=IHTEMI(IREV)
16946 2400   CONTINUE
16947      ENDIF
16948C
16949      NH=NH+1
16950      IH(NH)='.'
16951C
16952      IF(NUMDID.GT.0)THEN
16953        DO2500I=1,NUMDID
16954          NH=NH+1
16955          IH(NH)=IHTEMD(I)
16956 2500   CONTINUE
16957      ENDIF
16958C
16959C               *****************
16960C               **  STEP 90--  **
16961C               **  EXIT       **
16962C               *****************
16963C
16964 9000 CONTINUE
16965      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CONH')THEN
16966        WRITE(ICOUT,999)
16967  999   FORMAT(1X)
16968        CALL DPWRST('XXX','BUG ')
16969        WRITE(ICOUT,9011)
16970 9011   FORMAT('***** AT THE END       OF DPCONH--')
16971        CALL DPWRST('XXX','BUG ')
16972        WRITE(ICOUT,9012)NUMDII,NUMDID,NH,IVAL,VAL
16973 9012   FORMAT('NUMDII,NUMDID,NH,IVAL,VAL = ',4I8,G15.7)
16974        CALL DPWRST('XXX','BUG ')
16975        WRITE(ICOUT,9013)AIVAL,VAL,DEL,ABSDEL,CUTDEL
16976 9013   FORMAT('AIVAL,VAL,DEL,ABSDEL,CUTDEL = ',5G15.7)
16977        CALL DPWRST('XXX','BUG ')
16978        WRITE(ICOUT,9014)ABSVAL,INUM,AINUM,FRACT
16979 9014   FORMAT('ABSVAL,INUM,AINUM,FRACT = ',G15.7,2X,I8,2G15.7)
16980        CALL DPWRST('XXX','BUG ')
16981        WRITE(ICOUT,9016)(IHTEMI(I),I=1,NUMDII)
16982 9016   FORMAT('(IHTEMI(I),I=1,NUMDII) = ',20A1)
16983        CALL DPWRST('XXX','BUG ')
16984        WRITE(ICOUT,9026)(IHTEMD(I),I=1,NUMDID)
16985 9026   FORMAT('(IHTEMD(I),I=1,NUMDID) = ',20A1)
16986        CALL DPWRST('XXX','BUG ')
16987        WRITE(ICOUT,9032)(IH(I),I=1,NH)
16988 9032   FORMAT('(IH(I),I=1,NH) = ',20A1)
16989        CALL DPWRST('XXX','BUG ')
16990      ENDIF
16991C
16992      RETURN
16993      END
16994      SUBROUTINE DPCONX(IX,IC)
16995C
16996C     PURPOSE--CONVERT IX = INTEGER IN INTERVAL 0 - 255 TO
16997C              HEX EQUIVALENT (CHARACTER*2).
16998C              USE BUILT TABLE FOR PEFORMANCE.
16999C
17000C
17001C     WRITTEN BY--JAMES J. FILLIBEN
17002C     LANGUAGE--ANSI FORTRAN (1977)
17003C     ORIGINAL VERSION--MARCH     2002.
17004C
17005C--------------------------------------------------------------------
17006C
17007      CHARACTER*2 IC
17008C
17009C-----COMMON VARIABLES (GENERAL)--------------------------------------
17010C
17011      INCLUDE 'DPCOP2.INC'
17012C
17013      CHARACTER*2 HEXTAB(256)
17014C
17015C-----DATA STATEMENTS-------------------------------------------------
17016C
17017C     DATA STATEMENTS FOR IBM EBCDIC COMPUTERS
17018C
17019      DATA HEXTAB(  1) /'00'/
17020      DATA HEXTAB(  2) /'01'/
17021      DATA HEXTAB(  3) /'02'/
17022      DATA HEXTAB(  4) /'03'/
17023      DATA HEXTAB(  5) /'04'/
17024      DATA HEXTAB(  6) /'05'/
17025      DATA HEXTAB(  7) /'06'/
17026      DATA HEXTAB(  8) /'07'/
17027      DATA HEXTAB(  9) /'08'/
17028      DATA HEXTAB( 10) /'09'/
17029      DATA HEXTAB( 11) /'0A'/
17030      DATA HEXTAB( 12) /'0B'/
17031      DATA HEXTAB( 13) /'0C'/
17032      DATA HEXTAB( 14) /'0D'/
17033      DATA HEXTAB( 15) /'0E'/
17034      DATA HEXTAB( 16) /'0F'/
17035      DATA HEXTAB( 17) /'10'/
17036      DATA HEXTAB( 18) /'11'/
17037      DATA HEXTAB( 19) /'12'/
17038      DATA HEXTAB( 20) /'13'/
17039      DATA HEXTAB( 21) /'14'/
17040      DATA HEXTAB( 22) /'15'/
17041      DATA HEXTAB( 23) /'16'/
17042      DATA HEXTAB( 24) /'17'/
17043      DATA HEXTAB( 25) /'18'/
17044      DATA HEXTAB( 26) /'19'/
17045      DATA HEXTAB( 27) /'1A'/
17046      DATA HEXTAB( 28) /'1B'/
17047      DATA HEXTAB( 29) /'1C'/
17048      DATA HEXTAB( 30) /'1D'/
17049      DATA HEXTAB( 31) /'1E'/
17050      DATA HEXTAB( 32) /'1F'/
17051      DATA HEXTAB( 33) /'20'/
17052      DATA HEXTAB( 34) /'21'/
17053      DATA HEXTAB( 35) /'22'/
17054      DATA HEXTAB( 36) /'23'/
17055      DATA HEXTAB( 37) /'24'/
17056      DATA HEXTAB( 38) /'25'/
17057      DATA HEXTAB( 39) /'26'/
17058      DATA HEXTAB( 40) /'27'/
17059      DATA HEXTAB( 41) /'28'/
17060      DATA HEXTAB( 42) /'29'/
17061      DATA HEXTAB( 43) /'2A'/
17062      DATA HEXTAB( 44) /'2B'/
17063      DATA HEXTAB( 45) /'2C'/
17064      DATA HEXTAB( 46) /'2D'/
17065      DATA HEXTAB( 47) /'2E'/
17066      DATA HEXTAB( 48) /'2F'/
17067      DATA HEXTAB( 49) /'30'/
17068      DATA HEXTAB( 50) /'31'/
17069      DATA HEXTAB( 51) /'32'/
17070      DATA HEXTAB( 52) /'33'/
17071      DATA HEXTAB( 53) /'34'/
17072      DATA HEXTAB( 54) /'35'/
17073      DATA HEXTAB( 55) /'36'/
17074      DATA HEXTAB( 56) /'37'/
17075      DATA HEXTAB( 57) /'38'/
17076      DATA HEXTAB( 58) /'39'/
17077      DATA HEXTAB( 59) /'3A'/
17078      DATA HEXTAB( 60) /'3B'/
17079      DATA HEXTAB( 61) /'3C'/
17080      DATA HEXTAB( 62) /'3D'/
17081      DATA HEXTAB( 63) /'3E'/
17082      DATA HEXTAB( 64) /'3F'/
17083      DATA HEXTAB( 65) /'40'/
17084      DATA HEXTAB( 66) /'41'/
17085      DATA HEXTAB( 67) /'42'/
17086      DATA HEXTAB( 68) /'43'/
17087      DATA HEXTAB( 69) /'44'/
17088      DATA HEXTAB( 70) /'45'/
17089      DATA HEXTAB( 71) /'46'/
17090      DATA HEXTAB( 72) /'47'/
17091      DATA HEXTAB( 73) /'48'/
17092      DATA HEXTAB( 74) /'49'/
17093      DATA HEXTAB( 75) /'4A'/
17094      DATA HEXTAB( 76) /'4B'/
17095      DATA HEXTAB( 77) /'4C'/
17096      DATA HEXTAB( 78) /'4D'/
17097      DATA HEXTAB( 79) /'4E'/
17098      DATA HEXTAB( 80) /'4F'/
17099      DATA HEXTAB( 81) /'50'/
17100      DATA HEXTAB( 82) /'51'/
17101      DATA HEXTAB( 83) /'52'/
17102      DATA HEXTAB( 84) /'53'/
17103      DATA HEXTAB( 85) /'54'/
17104      DATA HEXTAB( 86) /'55'/
17105      DATA HEXTAB( 87) /'56'/
17106      DATA HEXTAB( 88) /'57'/
17107      DATA HEXTAB( 89) /'58'/
17108      DATA HEXTAB( 90) /'59'/
17109      DATA HEXTAB( 91) /'5A'/
17110      DATA HEXTAB( 92) /'5B'/
17111      DATA HEXTAB( 93) /'5C'/
17112      DATA HEXTAB( 94) /'5D'/
17113      DATA HEXTAB( 95) /'5E'/
17114      DATA HEXTAB( 96) /'5F'/
17115      DATA HEXTAB( 97) /'60'/
17116      DATA HEXTAB( 98) /'61'/
17117      DATA HEXTAB( 99) /'62'/
17118      DATA HEXTAB(100) /'63'/
17119      DATA HEXTAB(101) /'64'/
17120      DATA HEXTAB(102) /'65'/
17121      DATA HEXTAB(103) /'66'/
17122      DATA HEXTAB(104) /'67'/
17123      DATA HEXTAB(105) /'68'/
17124      DATA HEXTAB(106) /'69'/
17125      DATA HEXTAB(107) /'6A'/
17126      DATA HEXTAB(108) /'6B'/
17127      DATA HEXTAB(109) /'6C'/
17128      DATA HEXTAB(110) /'6D'/
17129      DATA HEXTAB(111) /'6E'/
17130      DATA HEXTAB(112) /'6F'/
17131      DATA HEXTAB(113) /'70'/
17132      DATA HEXTAB(114) /'71'/
17133      DATA HEXTAB(115) /'72'/
17134      DATA HEXTAB(116) /'73'/
17135      DATA HEXTAB(117) /'74'/
17136      DATA HEXTAB(118) /'75'/
17137      DATA HEXTAB(119) /'76'/
17138      DATA HEXTAB(120) /'77'/
17139      DATA HEXTAB(121) /'78'/
17140      DATA HEXTAB(122) /'79'/
17141      DATA HEXTAB(123) /'7A'/
17142      DATA HEXTAB(124) /'7B'/
17143      DATA HEXTAB(125) /'7C'/
17144      DATA HEXTAB(126) /'7D'/
17145      DATA HEXTAB(127) /'7E'/
17146      DATA HEXTAB(128) /'7F'/
17147      DATA HEXTAB(129) /'80'/
17148      DATA HEXTAB(130) /'81'/
17149      DATA HEXTAB(131) /'82'/
17150      DATA HEXTAB(132) /'83'/
17151      DATA HEXTAB(133) /'84'/
17152      DATA HEXTAB(134) /'85'/
17153      DATA HEXTAB(135) /'86'/
17154      DATA HEXTAB(136) /'87'/
17155      DATA HEXTAB(137) /'88'/
17156      DATA HEXTAB(138) /'89'/
17157      DATA HEXTAB(139) /'8A'/
17158      DATA HEXTAB(140) /'8B'/
17159      DATA HEXTAB(141) /'8C'/
17160      DATA HEXTAB(142) /'8D'/
17161      DATA HEXTAB(143) /'8E'/
17162      DATA HEXTAB(144) /'8F'/
17163      DATA HEXTAB(145) /'90'/
17164      DATA HEXTAB(146) /'91'/
17165      DATA HEXTAB(147) /'92'/
17166      DATA HEXTAB(148) /'93'/
17167      DATA HEXTAB(149) /'94'/
17168      DATA HEXTAB(150) /'95'/
17169      DATA HEXTAB(151) /'96'/
17170      DATA HEXTAB(152) /'97'/
17171      DATA HEXTAB(153) /'98'/
17172      DATA HEXTAB(154) /'99'/
17173      DATA HEXTAB(155) /'9A'/
17174      DATA HEXTAB(156) /'9B'/
17175      DATA HEXTAB(157) /'9C'/
17176      DATA HEXTAB(158) /'9D'/
17177      DATA HEXTAB(159) /'9E'/
17178      DATA HEXTAB(160) /'9F'/
17179      DATA HEXTAB(161) /'A0'/
17180      DATA HEXTAB(162) /'A1'/
17181      DATA HEXTAB(163) /'A2'/
17182      DATA HEXTAB(164) /'A3'/
17183      DATA HEXTAB(165) /'A4'/
17184      DATA HEXTAB(166) /'A5'/
17185      DATA HEXTAB(167) /'A6'/
17186      DATA HEXTAB(168) /'A7'/
17187      DATA HEXTAB(169) /'A8'/
17188      DATA HEXTAB(170) /'A9'/
17189      DATA HEXTAB(171) /'AA'/
17190      DATA HEXTAB(172) /'AB'/
17191      DATA HEXTAB(173) /'AC'/
17192      DATA HEXTAB(174) /'AD'/
17193      DATA HEXTAB(175) /'AE'/
17194      DATA HEXTAB(176) /'AF'/
17195      DATA HEXTAB(177) /'B0'/
17196      DATA HEXTAB(178) /'B1'/
17197      DATA HEXTAB(179) /'B2'/
17198      DATA HEXTAB(180) /'B3'/
17199      DATA HEXTAB(181) /'B4'/
17200      DATA HEXTAB(182) /'B5'/
17201      DATA HEXTAB(183) /'B6'/
17202      DATA HEXTAB(184) /'B7'/
17203      DATA HEXTAB(185) /'B8'/
17204      DATA HEXTAB(186) /'B9'/
17205      DATA HEXTAB(187) /'BA'/
17206      DATA HEXTAB(188) /'BB'/
17207      DATA HEXTAB(189) /'BC'/
17208      DATA HEXTAB(190) /'BD'/
17209      DATA HEXTAB(191) /'BE'/
17210      DATA HEXTAB(192) /'BF'/
17211      DATA HEXTAB(193) /'C0'/
17212      DATA HEXTAB(194) /'C1'/
17213      DATA HEXTAB(195) /'C2'/
17214      DATA HEXTAB(196) /'C3'/
17215      DATA HEXTAB(197) /'C4'/
17216      DATA HEXTAB(198) /'C5'/
17217      DATA HEXTAB(199) /'C6'/
17218      DATA HEXTAB(200) /'C7'/
17219      DATA HEXTAB(201) /'C8'/
17220      DATA HEXTAB(202) /'C9'/
17221      DATA HEXTAB(203) /'CA'/
17222      DATA HEXTAB(204) /'CB'/
17223      DATA HEXTAB(205) /'CC'/
17224      DATA HEXTAB(206) /'CD'/
17225      DATA HEXTAB(207) /'CE'/
17226      DATA HEXTAB(208) /'CF'/
17227      DATA HEXTAB(209) /'D0'/
17228      DATA HEXTAB(210) /'D1'/
17229      DATA HEXTAB(211) /'D2'/
17230      DATA HEXTAB(212) /'D3'/
17231      DATA HEXTAB(213) /'D4'/
17232      DATA HEXTAB(214) /'D5'/
17233      DATA HEXTAB(215) /'D6'/
17234      DATA HEXTAB(216) /'D7'/
17235      DATA HEXTAB(217) /'D8'/
17236      DATA HEXTAB(218) /'D9'/
17237      DATA HEXTAB(219) /'DA'/
17238      DATA HEXTAB(220) /'DB'/
17239      DATA HEXTAB(221) /'DC'/
17240      DATA HEXTAB(222) /'DD'/
17241      DATA HEXTAB(223) /'DE'/
17242      DATA HEXTAB(224) /'DF'/
17243      DATA HEXTAB(225) /'E0'/
17244      DATA HEXTAB(226) /'E1'/
17245      DATA HEXTAB(227) /'E2'/
17246      DATA HEXTAB(228) /'E3'/
17247      DATA HEXTAB(229) /'E4'/
17248      DATA HEXTAB(230) /'E5'/
17249      DATA HEXTAB(231) /'E6'/
17250      DATA HEXTAB(232) /'E7'/
17251      DATA HEXTAB(233) /'E8'/
17252      DATA HEXTAB(234) /'E9'/
17253      DATA HEXTAB(235) /'EA'/
17254      DATA HEXTAB(236) /'EB'/
17255      DATA HEXTAB(237) /'EC'/
17256      DATA HEXTAB(238) /'ED'/
17257      DATA HEXTAB(239) /'EE'/
17258      DATA HEXTAB(240) /'EF'/
17259      DATA HEXTAB(241) /'F0'/
17260      DATA HEXTAB(242) /'F1'/
17261      DATA HEXTAB(243) /'F2'/
17262      DATA HEXTAB(244) /'F3'/
17263      DATA HEXTAB(245) /'F4'/
17264      DATA HEXTAB(246) /'F5'/
17265      DATA HEXTAB(247) /'F6'/
17266      DATA HEXTAB(248) /'F7'/
17267      DATA HEXTAB(249) /'F8'/
17268      DATA HEXTAB(250) /'F9'/
17269      DATA HEXTAB(251) /'FA'/
17270      DATA HEXTAB(252) /'FB'/
17271      DATA HEXTAB(253) /'FC'/
17272      DATA HEXTAB(254) /'FD'/
17273      DATA HEXTAB(255) /'FE'/
17274      DATA HEXTAB(256) /'FF'/
17275C
17276C-----START POINT-----------------------------------------------------
17277C
17278      IF(IX.LE.0)THEN
17279        IC=HEXTAB(1)
17280      ELSEIF(IX.GE.255)THEN
17281        IC=HEXTAB(256)
17282      ELSE
17283        IC=HEXTAB(IX+1)
17284      ENDIF
17285C
17286      RETURN
17287      END
17288      SUBROUTINE DPCOOR(ICASPL,ICASP2,Y,N,
17289     1                  PX1COO,X1COOR,NX1COO,
17290     1                  PX2COO,X2COOR,NX2COO,
17291     1                  PY1COO,Y1COOR,NY1COO,
17292     1                  PY2COO,Y2COOR,NY2COO,
17293     1                  IBUGG4,ISUBRO,IERROR)
17294C
17295C     PURPOSE--SAVE THE CURRENT SETTINGS OF THE Y (OR X) TIC MARK
17296C              LABEL COORDINATES.  THIS CAN OCCASSIONALLY BE USEFUL IF
17297C              YOU NEED TO ADD SOME ADDITIONAL TEXT TO THE TIC LABELS.
17298C              NOTE THAT THE COORDINATES CAN BE RETURNED IN EITHER
17299C              SCREEN (PX1COO, PX2COO, PY1COO, PY2COO) OR DATA
17300C              (X1COOR, X2COOR, Y1COOR, Y2COOR) UNITS.
17301C     EXAMPLES--LET YOUT = Y1TIC SCREEN COORDINATES
17302C               LET YOUT = Y1TIC DATA   COORDINATES
17303C               LET YOUT = YTIC  SCREEN COORDINATES
17304C               LET XOUT = XTIC  SCREEN COORDINATES
17305C     WRITTEN BY--ALAN HECKERT
17306C                 STATISTICAL ENGINEERING DIVISION
17307C                 INFORMATION TECHNOLOGY LABORATORY
17308C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
17309C                 GAITHERSBURG, MD 20899-8980
17310C                 PHONE--301-975-2899
17311C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
17312C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
17313C     LANGUAGE--ANSI FORTRAN (1977)
17314C     VERSION NUMBER--2018.10
17315C     ORIGINAL VERSION--OCTOBER   2018.
17316C
17317C-----NON-COMMON VARIABLES (GRAPHICS)-----------------------------------
17318C
17319      DIMENSION Y(*)
17320      DIMENSION PX1COO(*)
17321      DIMENSION X1COOR(*)
17322      DIMENSION PX2COO(*)
17323      DIMENSION X2COOR(*)
17324      DIMENSION PY1COO(*)
17325      DIMENSION Y1COOR(*)
17326      DIMENSION PY2COO(*)
17327      DIMENSION Y2COOR(*)
17328C
17329      CHARACTER*4 ICASPL
17330      CHARACTER*4 ICASP2
17331      CHARACTER*4 IBUGG4
17332      CHARACTER*4 ISUBRO
17333      CHARACTER*4 IERROR
17334C
17335C-----COMMON----------------------------------------------------------
17336C
17337C-----COMMON VARIABLES (GENERAL)--------------------------------------
17338C
17339      INCLUDE 'DPCOP2.INC'
17340C
17341C-----START POINT-----------------------------------------------------
17342C
17343      IF(IBUGG4.EQ.'ON'.OR.ISUBRO.EQ.'COOR')THEN
17344        WRITE(ICOUT,999)
17345  999   FORMAT(1X)
17346        CALL DPWRST('XXX','BUG ')
17347        WRITE(ICOUT,51)
17348   51   FORMAT('***** AT THE BEGINNING OF DPCOOR--')
17349        CALL DPWRST('XXX','BUG ')
17350        WRITE(ICOUT,54)ICASPL,ICASP2,NX1COO,NX2COO,NY1COO,NY2COO
17351   54   FORMAT('ICASPL,ICASP2,NX1COO,NX2COO,NY1COO,NY2COO = ',
17352     1         2(A4,2X),4I5)
17353        CALL DPWRST('XXX','BUG ')
17354        IF(NX1COO.GE.1)THEN
17355          DO61I=1,NX1COO
17356            WRITE(ICOUT,62)I,X1COOR(I),PX1COO(I)
17357   62       FORMAT('I,X1COOR(I),PX1COO(I) = ',I5,2G15.7)
17358            CALL DPWRST('XXX','BUG ')
17359   61     CONTINUE
17360        ENDIF
17361        IF(NX2COO.GE.1)THEN
17362          DO66I=1,NX2COO
17363            WRITE(ICOUT,67)I,X2COOR(I),PX2COO(I)
17364   67       FORMAT('I,X2COOR(I),PX2COO(I) = ',I5,2G15.7)
17365            CALL DPWRST('XXX','BUG ')
17366   66     CONTINUE
17367        ENDIF
17368        IF(NY1COO.GE.1)THEN
17369          DO71I=1,NY1COO
17370            WRITE(ICOUT,72)I,Y1COOR(I),PY1COO(I)
17371   72       FORMAT('I,Y1COOR(I),PY1COO(I) = ',I5,2G15.7)
17372            CALL DPWRST('XXX','BUG ')
17373   71     CONTINUE
17374        ENDIF
17375        IF(NY2COO.GE.1)THEN
17376          DO76I=1,NY2COO
17377            WRITE(ICOUT,77)I,Y2COOR(I),PY2COO(I)
17378   77       FORMAT('I,Y2COOR(I),PY2COO(I) = ',I5,2G15.7)
17379            CALL DPWRST('XXX','BUG ')
17380   76     CONTINUE
17381        ENDIF
17382      ENDIF
17383C
17384      IERROR='YES'
17385C
17386C               *******************************************************
17387C               **  STEP 1--                                         **
17388C               **  EXTRACT THE REQUESTED TIC MARK COORDINATES.      **
17389C               *******************************************************
17390C
17391      IF(ICASPL.EQ.'Y1  ' .OR. ICASPL.EQ.'Y   ')THEN
17392        IF(NY1COO.LT.1)THEN
17393          N=0
17394          GOTO9000
17395        ELSE
17396          N=NY1COO
17397        ENDIF
17398        IF(ICASP2.EQ.'SCRE')THEN
17399          DO110I=1,NY1COO
17400            Y(I)=PY1COO(I)
17401  110     CONTINUE
17402        ELSE
17403          DO120I=1,NY1COO
17404            Y(I)=Y1COOR(I)
17405  120     CONTINUE
17406        ENDIF
17407      ELSEIF(ICASPL.EQ.'Y2  ')THEN
17408        IF(NY2COO.LT.1)THEN
17409          N=0
17410          GOTO9000
17411        ELSE
17412          N=NY2COO
17413        ENDIF
17414        IF(ICASP2.EQ.'SCRE')THEN
17415          DO210I=1,NY2COO
17416            Y(I)=PY2COO(I)
17417  210     CONTINUE
17418        ELSE
17419          DO220I=1,NY2COO
17420            Y(I)=Y2COOR(I)
17421  220     CONTINUE
17422        ENDIF
17423      ELSEIF(ICASPL.EQ.'X1  ' .OR. ICASPL.EQ.'X   ')THEN
17424        IF(NX1COO.LT.1)THEN
17425          N=0
17426          GOTO9000
17427        ELSE
17428          N=NX1COO
17429        ENDIF
17430        IF(ICASP2.EQ.'SCRE')THEN
17431          DO310I=1,NX1COO
17432            Y(I)=PX1COO(I)
17433  310     CONTINUE
17434        ELSE
17435          DO320I=1,NX1COO
17436            Y(I)=X1COOR(I)
17437  320     CONTINUE
17438        ENDIF
17439      ELSEIF(ICASPL.EQ.'X2  ')THEN
17440        IF(NX2COO.LT.1)THEN
17441          N=0
17442          GOTO9000
17443        ELSE
17444          N=NX2COO
17445        ENDIF
17446        IF(ICASP2.EQ.'SCRE')THEN
17447          DO410I=1,NX2COO
17448            Y(I)=PX2COO(I)
17449  410     CONTINUE
17450        ELSE
17451          DO420I=1,NX2COO
17452            Y(I)=X2COOR(I)
17453  420     CONTINUE
17454        ENDIF
17455      ENDIF
17456C
17457C               *****************
17458C               **  STEP 90--  **
17459C               **  EXIT       **
17460C               *****************
17461C
17462 9000 CONTINUE
17463      IF(IBUGG4.EQ.'ON'.OR.ISUBRO.EQ.'COOR')THEN
17464        WRITE(ICOUT,999)
17465        CALL DPWRST('XXX','BUG ')
17466        WRITE(ICOUT,9011)
17467 9011   FORMAT('***** AT THE END       OF DPCOOR--')
17468        CALL DPWRST('XXX','BUG ')
17469        WRITE(ICOUT,9052)N
17470 9052   FORMAT('N = ',I6)
17471        CALL DPWRST('XXX','BUG ')
17472        IF(N.GE.1)THEN
17473          DO9060I=1,N
17474            WRITE(ICOUT,9062)I,Y(I)
17475 9062       FORMAT('I,Y(I) = ',I6,2X,G15.7)
17476            CALL DPWRST('XXX','BUG ')
17477 9060     CONTINUE
17478        ENDIF
17479      ENDIF
17480C
17481      RETURN
17482      END
17483      SUBROUTINE DPCOR2(Y1,Y2,N,NCURVE,ICASPL,NUMLAG,MAXN,
17484     1                  IAUTCP,IAUTL0,TEMP1,TEMP2,
17485     1                  Y,X,D,TOP,BOTTOM,PCC,NPLOTP,NPLOTV,
17486     1                  IBUGG3,ISUBRO,IERROR)
17487C
17488C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
17489C              THAT WILL DEFINE
17490C                   1) AN AUTOCORRELATION PLOT
17491C                   2) A CROSS-CORRELATION PLOT
17492C                   3) A PARTIAL AUTOCORRELATION PLOT
17493C                   4) AN AUTOCOMOVEMENT PLOT
17494C                   5) A CROSS-COMOVEMENT PLOT
17495C     WRITTEN BY--JAMES J. FILLIBEN
17496C                 STATISTICAL ENGINEERING DIVISION
17497C                 INFORMATION TECHNOLOGY LABORATORY
17498C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
17499C                 GAITHERSBURG, MD 20899-8980
17500C                 PHONE--301-921-3651
17501C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
17502C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
17503C     LANGUAGE--ANSI FORTRAN (1977)
17504C     VERSION NUMBER--82/7
17505C     ORIGINAL VERSION--APRIL     1978.
17506C     UPDATED         --MAY       1978.
17507C     UPDATED         --JUNE      1978.
17508C     UPDATED         --OCTOBER   1978.
17509C     UPDATED         --MARCH     1979.
17510C     UPDATED         --APRIL     1979.
17511C     UPDATED         --JANUARY   1981.
17512C     UPDATED         --DECEMBER  1981.
17513C     UPDATED         --MAY       1982.
17514C     UPDATED         --MAY       1992. REWRITE AUTOCORR. FOR SMALL N
17515C     UPDATED         --FEBRUARY  1993. PARTIAL AUTOCORRELATION PLOT
17516C     UPDATED         --DECEMBER  1994. FIX XLIMITS /REF. LINES PROBLEM
17517C     UPDATED         --JULY      1999. SUPPORT FIXED OR MOVING ERROR
17518C                                       LIMITS.
17519C     UPDATED         --FEBRUARY  2003. SUPPORT OPTION TO OMIT LAG 0 ON
17520C                                       AUTOCORRELATION AND PARTIAL
17521C                                       AUTOCORRELATION PLOT (IAUTL0)
17522C     UPDATED         --JANUARY   2012. FOLD IN COMOVEMENT PLOTS
17523C
17524C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
17525C
17526CCCCC ADD FOLLOWING LINE JULY 1999
17527      CHARACTER*4 IAUTCP
17528CCCCC ADD FOLLOWING LINE FEBRUARY 2003
17529      CHARACTER*4 IAUTL0
17530      CHARACTER*4 ICASPL
17531      CHARACTER*4 IBUGG3
17532      CHARACTER*4 ISUBRO
17533      CHARACTER*4 IERROR
17534C
17535      CHARACTER*4 ISUBN1
17536      CHARACTER*4 ISUBN2
17537      CHARACTER*4 ISTEPN
17538      CHARACTER*4 IFOUND
17539      CHARACTER*4 IWRITE
17540C
17541C---------------------------------------------------------------------
17542C
17543      DIMENSION Y1(*)
17544      DIMENSION Y2(*)
17545      DIMENSION TEMP1(*)
17546      DIMENSION TEMP2(*)
17547      DIMENSION Y(*)
17548      DIMENSION X(*)
17549      DIMENSION D(*)
17550C
17551CCCCC TO DO--THE FOLLOWING DIMENSIONS MUST BE GENERALIZED BEYOND 1000
17552CCCCC 2/93
17553CCCCC MOVE FOLLOWING DIMENSIONS TO DPCORR.   OCTOBER 1997
17554CCCCC DIMENSION TOP(1000)
17555CCCCC DIMENSION BOTTOM(1000)
17556CCCCC DIMENSION PCC(1000)
17557      DIMENSION TOP(*)
17558      DIMENSION BOTTOM(*)
17559      DIMENSION PCC(*)
17560C
17561C---------------------------------------------------------------------
17562C
17563      INCLUDE 'DPCOP2.INC'
17564C
17565C-----START POINT-----------------------------------------------------
17566C
17567      ISUBN1='DPCO'
17568      ISUBN2='R2  '
17569      IERROR='NO'
17570      IWRITE='OFF'
17571C
17572      J=(-999)
17573      KMAX=(-999)
17574      IFACT=1
17575C
17576      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'COR2')THEN
17577        WRITE(ICOUT,999)
17578        CALL DPWRST('XXX','BUG ')
17579        WRITE(ICOUT,70)
17580   70   FORMAT('***** AT THE BEGINNING OF DPCOR2--')
17581        CALL DPWRST('XXX','BUG ')
17582        WRITE(ICOUT,71)ICASPL,N,NUMLAG,MAXN
17583   71   FORMAT('ICASPL,N,NUMLAG,MAXN = ',A4,2X,3I8)
17584        CALL DPWRST('XXX','BUG ')
17585        DO73I=1,N
17586          WRITE(ICOUT,74)I,Y1(I),Y2(I)
17587   74     FORMAT('I,Y1(I),Y2(I) = ',I8,2G15.7)
17588          CALL DPWRST('XXX','BUG ')
17589   73   CONTINUE
17590      ENDIF
17591C
17592C               ********************************************
17593C               **  STEP 1--                              **
17594C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
17595C               ********************************************
17596C
17597      IF(N.LT.3)THEN
17598        WRITE(ICOUT,999)
17599  999   FORMAT(1X)
17600        CALL DPWRST('XXX','BUG ')
17601        WRITE(ICOUT,31)
17602   31   FORMAT('***** ERROR IN ...CORRELATION/COMOVEMENT PLOT--')
17603        CALL DPWRST('XXX','BUG ')
17604        WRITE(ICOUT,32)
17605   32   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 2.')
17606        CALL DPWRST('XXX','BUG ')
17607        WRITE(ICOUT,34)N
17608   34   FORMAT('      THE NUMBER OF OBSERVATIONS = ',I6)
17609        CALL DPWRST('XXX','BUG ')
17610        WRITE(ICOUT,999)
17611        CALL DPWRST('XXX','BUG ')
17612        IERROR='YES'
17613        GOTO9000
17614      ENDIF
17615C
17616      HOLD=Y1(1)
17617      DO60I=1,N
17618        IF(Y1(I).NE.HOLD)GOTO69
17619   60 CONTINUE
17620      WRITE(ICOUT,999)
17621      CALL DPWRST('XXX','BUG ')
17622      WRITE(ICOUT,31)
17623      CALL DPWRST('XXX','BUG ')
17624      WRITE(ICOUT,62)HOLD
17625   62 FORMAT('      ALL ELEMENTS IN Y1 ARE IDENTICALLY EQUAL TO ',G15.7)
17626      CALL DPWRST('XXX','BUG ')
17627      WRITE(ICOUT,999)
17628      CALL DPWRST('XXX','BUG ')
17629      IERROR='YES'
17630      GOTO9000
17631   69 CONTINUE
17632C
17633C               *******************************
17634C               **  STEP 2--                 **
17635C               **  IF NECESSARY,            **
17636C               **  COMPUTE THE MAXIMUM LAG  **
17637C               *******************************
17638C
17639      ISTEPN='2'
17640      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'COR2')
17641     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17642C
17643      MAXLAG=MAXN
17644      IF(NUMLAG.GE.1)KMAX=NUMLAG
17645      IF(NUMLAG.LE.0)KMAX=N/4
17646      IF(NUMLAG.LE.0.AND.N.LE.32)KMAX=N/2
17647      IF(NUMLAG.LE.0.AND.N.LE.16)KMAX=N
17648      IF(KMAX.GT.MAXLAG)KMAX=MAXLAG
17649      NM1=N-1
17650      IF(KMAX.GT.NM1)KMAX=NM1
17651CCCCC THE FOLLOWING 4 LINES WERE ADDED MAY 1992 (JJF)
17652      IF(N.LE.16)THEN
17653         NM2=N-2
17654         IF(KMAX.GT.NM2)KMAX=NM2
17655      ENDIF
17656      KMAXM1=KMAX-1
17657      AKMAXM=KMAXM1
17658      AN=N
17659C
17660C               **************************************
17661C               **  STEP 4--                        **
17662C               **  BRANCH TO THE APPROPRIATE CASE  **
17663C               **  AND DETERMINE PLOT COORDINATES  **
17664C               **************************************
17665C
17666      ISTEPN='4'
17667      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'COR2')
17668     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17669C
17670C
17671      IF(ICASPL.EQ.'AUCO')THEN
17672C
17673C        ******************************************************
17674C        **  STEP 4.1--                                      **
17675C        **  COMPUTE THE AUTOCORRELATIONS FOR THE X  DATA    **
17676C        **  DO SO IN 3 STEPS--                              **
17677C        **     1) COMPUTE THE SAMPLE MEAN;                  **
17678C        **     2) COMPUTE THE SAMPLE VARIANCE;              **
17679C        **     3) COMPUTE THE AUTOCORRELATIONS;             **
17680C        **  REFERENCE--JENKINS AND WATTS, PAGE 382 (9.3.1)  **
17681C        ******************************************************
17682C
17683        ISTEPN='4.1'
17684        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'COR2')
17685     1     CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17686C
17687        IF(N.LE.16)THEN
17688C
17689C         COMPUTE AUTOCORRELATIONS FOR N <= 16
17690C
17691          DO1110K=1,KMAXM1
17692            NMK=N-K
17693            ANMK=NMK
17694            SUM1=0.0
17695            SUM2=0.0
17696            DO1120I=1,NMK
17697              J=I+K
17698              SUM1=SUM1+Y1(I)
17699              SUM2=SUM2+Y1(J)
17700 1120       CONTINUE
17701            Y1BAR=SUM1/ANMK
17702            Y2BAR=SUM2/ANMK
17703C
17704            SUM1=0.0
17705            SUM2=0.0
17706            DO1130I=1,NMK
17707              J=I+K
17708              SUM1=SUM1+(Y1(I)-Y1BAR)**2
17709              SUM2=SUM2+(Y1(J)-Y2BAR)**2
17710 1130       CONTINUE
17711            SSQ1=SUM1
17712            SSQ2=SUM2
17713C
17714            SUM1=0.0
17715            DO1140I=1,NMK
17716              J=I+K
17717              SUM1=SUM1+(Y1(I)-Y1BAR)*(Y1(J)-Y2BAR)
17718 1140       CONTINUE
17719            ANUM=SUM1
17720C
17721            SQRT1=0.0
17722            IF(SSQ1.GT.0.0)SQRT1=SQRT(SSQ1)
17723            SQRT2=0.0
17724            IF(SSQ2.GT.0.0)SQRT2=SQRT(SSQ2)
17725            DENOM=SQRT1*SQRT2
17726            AC=0.0
17727            IF(DENOM.GT.0.0)AC=ANUM/DENOM
17728            TEMP1(K)=AC
17729 1110     CONTINUE
17730        ELSE
17731C
17732C         COMPUTE AUTOCORRELATIONS FOR N >= 17
17733C
17734          SUM1=0.0
17735          DO1210I=1,N
17736            SUM1=SUM1+Y1(I)
17737 1210     CONTINUE
17738          Y1BAR=SUM1/AN
17739C
17740          SUM1=0.0
17741          DO1220I=1,N
17742            SUM1=SUM1+(Y1(I)-Y1BAR)*(Y1(I)-Y1BAR)
17743 1220     CONTINUE
17744          VARB1=SUM1/AN
17745          VAR1=SUM1/(AN-1.0)
17746C
17747          DO1230K=1,KMAXM1
17748            SUM1=0.0
17749            NMK=N-K
17750            DO1240I=1,NMK
17751              J=I+K
17752              SUM1=SUM1+(Y1(I)-Y1BAR)*(Y1(J)-Y1BAR)
17753 1240       CONTINUE
17754            TEMP1(K)=SUM1/AN
17755            TEMP1(K)=TEMP1(K)/VARB1
17756 1230     CONTINUE
17757        ENDIF
17758C
17759C       FORM OUTPUT VECTORS FOR BOTH AUTOCORRELATION CASES
17760C
17761        YMID=0.0
17762        SDR=1.0/SQRT(AN)
17763        YUPP95=1.96*SDR
17764        YLOW95=(-YUPP95)
17765        YUPP99=2.576*SDR
17766        YLOW99=(-YUPP99)
17767        IOUT=0
17768        IFACT=6
17769        AFACT=1.0/AN
17770        YSUM1=0.0
17771        YSUM2=0.0
17772        YSUM3=0.0
17773        YSUM4=0.0
17774C
17775        J=0
17776        IF(IAUTL0.EQ.'ON')THEN
17777          J=J+1
17778          Y(J+NPLOTP)=1.0
17779          X(J+NPLOTP)=0.0
17780          D(J+NPLOTP)=REAL(1 + IFACT*(NCURVE-1))
17781          IF(IAUTCP.EQ.'BOXJ')THEN
17782            J=J+1
17783            Y(J+NPLOTP)=YMID
17784            X(J+NPLOTP)=0.0
17785            D(J+NPLOTP)=REAL(3 + IFACT*(NCURVE-1))
17786            J=J+1
17787            Y(J+NPLOTP)=YMID
17788            X(J+NPLOTP)=0.0
17789            D(J+NPLOTP)=REAL(4 + IFACT*(NCURVE-1))
17790            J=J+1
17791            Y(J+NPLOTP)=YMID
17792            X(J+NPLOTP)=0.0
17793            D(J+NPLOTP)=REAL(5 + IFACT*(NCURVE-1))
17794            J=J+1
17795            Y(J+NPLOTP)=YMID
17796            X(J+NPLOTP)=0.0
17797            D(J+NPLOTP)=REAL(6 + IFACT*(NCURVE-1))
17798          ENDIF
17799        ENDIF
17800C
17801        DO1310K=1,KMAXM1
17802          J=J+1
17803          Y(J+NPLOTP)=TEMP1(K)
17804          X(J+NPLOTP)=REAL(K)
17805          D(J+NPLOTP)=REAL(1 + IFACT*(NCURVE-1))
17806          IF(Y(J).GT.YUPP95)IOUT=IOUT+1
17807          IF(Y(J).LT.YLOW95)IOUT=IOUT+1
17808          J=J+1
17809          Y(J+NPLOTP)=YMID
17810          X(J+NPLOTP)=REAL(K)
17811          D(J+NPLOTP)=REAL(2 + IFACT*(NCURVE-1))
17812CCCCC     SUPPORT FIXED CONFIDENCE BANDS FOR TESTING FOR WHITE NOISE.
17813CCCCC     MOVING BANDS FOR BOX-JENKINS MODELING.
17814          IF(IAUTCP.NE.'BOXJ')THEN
17815            J=J+1
17816            Y(J+NPLOTP)=YUPP95
17817            X(J+NPLOTP)=REAL(K)
17818            D(J+NPLOTP)=REAL(3 + IFACT*(NCURVE-1))
17819            J=J+1
17820            Y(J+NPLOTP)=YLOW95
17821            X(J+NPLOTP)=REAL(K)
17822            D(J+NPLOTP)=REAL(4 + IFACT*(NCURVE-1))
17823            J=J+1
17824            Y(J+NPLOTP)=YUPP99
17825            X(J+NPLOTP)=REAL(K)
17826            D(J+NPLOTP)=REAL(5 + IFACT*(NCURVE-1))
17827            J=J+1
17828            Y(J+NPLOTP)=YLOW99
17829            X(J+NPLOTP)=REAL(K)
17830            D(J+NPLOTP)=REAL(6 + IFACT*(NCURVE-1))
17831          ELSE
17832C
17833            IF(K.EQ.1)THEN
17834              J=J+1
17835              YSUM1=YSUM1 + TEMP1(K)**2
17836              Y(J+NPLOTP)=YUPP95
17837              X(J+NPLOTP)=1.0
17838              D(J+NPLOTP)=REAL(3 + IFACT*(NCURVE-1))
17839              YSUM2=YSUM2 + TEMP1(K)**2
17840              J=J+1
17841              Y(J+NPLOTP)=YLOW95
17842              X(J+NPLOTP)=1.0
17843              D(J+NPLOTP)=REAL(4 + IFACT*(NCURVE-1))
17844              YSUM3=YSUM3 + TEMP1(K)**2
17845              J=J+1
17846              Y(J+NPLOTP)=YUPP99
17847              X(J+NPLOTP)=1.0
17848              D(J+NPLOTP)=REAL(5 + IFACT*(NCURVE-1))
17849              YSUM4=YSUM4 + TEMP1(K)**2
17850              J=J+1
17851              Y(J+NPLOTP)=YLOW99
17852              X(J+NPLOTP)=1
17853              D(J+NPLOTP)=REAL(6 + IFACT*(NCURVE-1))
17854            ELSE
17855              YSUM1=YSUM1 + TEMP1(K)**2
17856              J=J+1
17857              Y(J+NPLOTP)=1.96*SQRT(AFACT*(1.0+2.0*YSUM1))
17858              X(J+NPLOTP)=REAL(K)
17859              D(J+NPLOTP)=REAL(3 + IFACT*(NCURVE-1))
17860              YSUM2=YSUM2 + TEMP1(K)**2
17861              J=J+1
17862              Y(J+NPLOTP)=YLOW95
17863              Y(J+NPLOTP)=-1.96*SQRT(AFACT*(1.0+2.0*YSUM2))
17864              X(J+NPLOTP)=REAL(K)
17865              D(J+NPLOTP)=REAL(4 + IFACT*(NCURVE-1))
17866              YSUM3=YSUM3 + TEMP1(K)**2
17867              J=J+1
17868              Y(J+NPLOTP)=2.576*SQRT(AFACT*(1.0+2.0*YSUM3))
17869              X(J+NPLOTP)=REAL(K)
17870              D(J+NPLOTP)=REAL(5 + IFACT*(NCURVE-1))
17871              YSUM4=YSUM4 + TEMP1(K)**2
17872              J=J+1
17873              Y(J+NPLOTP)=-2.576*SQRT(AFACT*(1.0+2.0*YSUM4))
17874              X(J+NPLOTP)=REAL(K)
17875              D(J+NPLOTP)=REAL(6 + IFACT*(NCURVE-1))
17876            ENDIF
17877C
17878          ENDIF
17879C
17880 1310   CONTINUE
17881        AIOUT=IOUT
17882        AKMAXM=KMAXM1
17883        PEROUT=100.0*(AIOUT/AKMAXM)
17884C
17885        NPLOTP=NPLOTP+J
17886        NPLOTV=3
17887C
17888        CALL DPWCCP(ICASPL,
17889     1              YLOW95,YUPP95,IOUT,KMAXM1,PEROUT,
17890     1              IBUGG3,ISUBRO,IFOUND,IERROR)
17891C
17892      ELSEIF(ICASPL.EQ.'CRCO')THEN
17893C
17894C           **********************************************************
17895C           **  STEP 4.2--                                          **
17896C           **  COMPUTE CROSS-CORRELATIONS FOR THE X AND Y  DATA    **
17897C           **  DO SO IN 3 STEPS--                                  **
17898C           **     1) COMPUTE THE SAMPLE MEAN;                      **
17899C           **     2) COMPUTE THE SAMPLE VARIANCE;                  **
17900C           **     3) COMPUTE THE AUTOCORRELATIONS;                 **
17901C           **  REFERENCE--JENKINS AND WATTS, PAGE 382 (9.3.1)      **
17902C           **********************************************************
17903C
17904        ISTEPN='4.2'
17905        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'COR2')
17906     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17907C
17908        SUM1=0.0
17909        SUM2=0.0
17910        DO2110I=1,N
17911          SUM1=SUM1+Y1(I)
17912          SUM2=SUM2+Y2(I)
17913 2110   CONTINUE
17914        Y1BAR=SUM1/AN
17915        Y2BAR=SUM2/AN
17916C
17917        SUM1=0.0
17918        SUM2=0.0
17919        DO2120I=1,N
17920          SUM1=SUM1+(Y1(I)-Y1BAR)*(Y1(I)-Y1BAR)
17921          SUM2=SUM2+(Y2(I)-Y2BAR)*(Y2(I)-Y2BAR)
17922 2120   CONTINUE
17923        VARB1=SUM1/AN
17924        VARB2=SUM2/AN
17925        VAR1=SUM1/(AN-1.0)
17926        VAR2=SUM2/(AN-1.0)
17927        DENOM=0.0
17928        PROD=VAR1*VAR2
17929        IF(PROD.GT.0.0)DENOM=SQRT(PROD)
17930C
17931        INDEX=0
17932C
17933        DO2130K=1,KMAXM1
17934          INDEX=INDEX+1
17935          KREV=KMAXM1-K+1
17936          SUM12=0.0
17937          NMKREV=N-KREV
17938          DO2132I=1,NMKREV
17939            J=I+KREV
17940            SUM12=SUM12+(Y1(J)-Y1BAR)*(Y2(I)-Y2BAR)
17941 2132     CONTINUE
17942          TEMP1(INDEX)=SUM12/AN
17943 2130   CONTINUE
17944C
17945        K=0
17946        INDEX=INDEX+1
17947        SUM12=0.0
17948        DO2134I=1,N
17949          J=I
17950          SUM12=SUM12+(Y1(I)-Y1BAR)*(Y2(J)-Y2BAR)
17951 2134   CONTINUE
17952        TEMP1(INDEX)=SUM12/AN
17953C
17954        DO2136K=1,KMAXM1
17955          INDEX=INDEX+1
17956          SUM12=0.0
17957          NMK=N-K
17958          DO2138I=1,NMK
17959            J=I+K
17960            SUM12=SUM12+(Y1(I)-Y1BAR)*(Y2(J)-Y2BAR)
17961 2138     CONTINUE
17962          TEMP1(INDEX)=SUM12/AN
17963 2136   CONTINUE
17964C
17965        YMID=0.0
17966        SDR=1.0/SQRT(AN)
17967        YUPP95=1.96*SDR
17968        YLOW95=(-YUPP95)
17969        YUPP99=2.576*SDR
17970        YLOW99=(-YUPP99)
17971        IFACT=6
17972C
17973        L=(-KMAXM1-1)
17974        J=0
17975        DO2150J2=1,INDEX
17976          J=J+1
17977          L=L+1
17978          Y(J+NPLOTP)=1.0
17979          IF(DENOM.GT.0.0)Y(J+NPLOTP)=TEMP1(J2)/DENOM
17980          X(J+NPLOTP)=REAL(L)
17981          D(J+NPLOTP)=REAL(1 + IFACT*(NCURVE-1))
17982C
17983          J=J+1
17984          Y(J+NPLOTP)=YMID
17985          X(J+NPLOTP)=REAL(L)
17986          D(J+NPLOTP)=REAL(2 + IFACT*(NCURVE-1))
17987          J=J+1
17988          Y(J+NPLOTP)=YUPP95
17989          X(J+NPLOTP)=REAL(L)
17990          D(J+NPLOTP)=REAL(3 + IFACT*(NCURVE-1))
17991          J=J+1
17992          Y(J+NPLOTP)=YLOW95
17993          X(J+NPLOTP)=REAL(L)
17994          D(J+NPLOTP)=REAL(4 + IFACT*(NCURVE-1))
17995          J=J+1
17996          Y(J)=YUPP99
17997          X(J+NPLOTP)=REAL(L)
17998          D(J+NPLOTP)=REAL(5 + IFACT*(NCURVE-1))
17999          J=J+1
18000          Y(J)=YLOW99
18001          X(J+NPLOTP)=REAL(L)
18002          D(J+NPLOTP)=REAL(6 + IFACT*(NCURVE-1))
18003 2150   CONTINUE
18004C
18005        NPLOTP=NPLOTP+J
18006        NPLOTV=3
18007C
18008      ELSEIF(ICASPL.EQ.'PACO')THEN
18009C
18010CCCCC   THE FOLLOWING ENTIRE SECTION WAS ADDED FEBRUARY 1993
18011C           ******************************************************
18012C           **  STEP 4.3--                                      **
18013C           **  COMPUTE THE PARTIAL AUTOCORRELATIONS FOR THE X  **
18014C           **  DATA.   DO SO IN 4 STEPS--                      **
18015C           **     1) COMPUTE THE SAMPLE MEAN;                  **
18016C           **     2) COMPUTE THE SAMPLE VARIANCE;              **
18017C           **     3) COMPUTE THE AUTOCORRELATIONS;             **
18018C           **     4) COMPUTE THE PARTIAL AUTOCORRELATIONS;     **
18019C           **  REFERENCE--JENKINS AND WATTS, PAGE 382 (9.3.1)  **
18020C           **  REFERENCE--WEISS, COMMUNICATIONS IN STATISTICS, **
18021C           **             PAGE 382 (9.3.1)                     **
18022C           ******************************************************
18023C
18024        ISTEPN='4.3'
18025        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'COR2')
18026     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18027C
18028C
18029C       IF N <= 16, COMPUTE (SIMPLE) AUTOCORRELATIONS
18030C
18031        IF(N.LE.16)THEN
18032          AN=N
18033C
18034          DO3110K=1,KMAXM1
18035            NMK=N-K
18036            ANMK=NMK
18037            SUM1=0.0
18038            SUM2=0.0
18039            DO3120I=1,NMK
18040               J=I+K
18041               SUM1=SUM1+Y1(I)
18042               SUM2=SUM2+Y1(J)
18043 3120       CONTINUE
18044            Y1BAR=SUM1/ANMK
18045            Y2BAR=SUM2/ANMK
18046C
18047            SUM1=0.0
18048            SUM2=0.0
18049            DO3130I=1,NMK
18050               J=I+K
18051               SUM1=SUM1+(Y1(I)-Y1BAR)**2
18052               SUM2=SUM2+(Y1(J)-Y2BAR)**2
18053 3130       CONTINUE
18054            SSQ1=SUM1
18055            SSQ2=SUM2
18056C
18057            SUM1=0.0
18058            DO3140I=1,NMK
18059               J=I+K
18060               SUM1=SUM1+(Y1(I)-Y1BAR)*(Y1(J)-Y2BAR)
18061 3140       CONTINUE
18062            ANUM=SUM1
18063C
18064            SQRT1=0.0
18065            IF(SSQ1.GT.0.0)SQRT1=SQRT(SSQ1)
18066            SQRT2=0.0
18067            IF(SSQ2.GT.0.0)SQRT2=SQRT(SSQ2)
18068            DENOM=SQRT1*SQRT2
18069            AC=0.0
18070            IF(DENOM.GT.0.0)AC=ANUM/DENOM
18071            TEMP1(K)=AC
18072 3110     CONTINUE
18073C
18074C         IF N >= 17, COMPUTE (SIMPLE) AUTOCORRELATIONS
18075C
18076        ELSEIF(N.GE.17)THEN
18077          AN=N
18078C
18079          SUM1=0.0
18080          DO3210I=1,N
18081            SUM1=SUM1+Y1(I)
18082 3210     CONTINUE
18083          Y1BAR=SUM1/AN
18084C
18085          SUM1=0.0
18086          DO3220I=1,N
18087            SUM1=SUM1+(Y1(I)-Y1BAR)*(Y1(I)-Y1BAR)
18088 3220     CONTINUE
18089          VARB1=SUM1/AN
18090          VAR1=SUM1/(AN-1.0)
18091C
18092          DO3230K=1,KMAXM1
18093            SUM1=0.0
18094            NMK=N-K
18095            DO3240I=1,NMK
18096              J=I+K
18097              SUM1=SUM1+(Y1(I)-Y1BAR)*(Y1(J)-Y1BAR)
18098 3240       CONTINUE
18099            TEMP1(K)=SUM1/AN
18100            TEMP1(K)=TEMP1(K)/VARB1
18101 3230     CONTINUE
18102        ENDIF
18103C
18104C       FORM PARTIAL AUTOCORRELATIONS FROM SIMPLE AUTOCORRELATIONS
18105C       REFERENCE--WEISS, COMMUN. OF STAT., 1984, P. 541-542.
18106C
18107        K=KMAXM1
18108        I=0
18109        I2=I+1
18110        TOP(I2)=1.0
18111        BOTTOM(I2)=1.0
18112        DO3310I=1,K
18113          I2=I+1
18114          TOP(I2)=TEMP1(I)
18115          BOTTOM(I2)=TEMP1(I)
18116 3310   CONTINUE
18117C
18118        PCC(1)=1.0
18119        DO3320J=1,K
18120          J2=J+1
18121          PCC(J2)=TOP(1+1)/BOTTOM(0+1)
18122C
18123          IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'COR2')THEN
18124            WRITE(ICOUT,3321)J,J2,PCC(J2)
18125 3321       FORMAT('J,J2,PCC(J2) = ',2I8,F10.5)
18126            CALL DPWRST('XXX','BUG ')
18127          ENDIF
18128C
18129          KMJ=K-J
18130          DO3330I=1,KMJ
18131            I2=I+1
18132            BOTTOM(I2-1)=BOTTOM(I2-1)-TOP(I2)*PCC(J2)
18133            TOP(I2)=TOP(I2+1)-BOTTOM(I2)*PCC(J2)
18134 3330     CONTINUE
18135 3320   CONTINUE
18136C
18137C       FORM OUTPUT VECTORS
18138C
18139        YMID=0.0
18140        SDR=1.0/SQRT(AN)
18141        YUPP95=1.96*SDR
18142        YLOW95=(-YUPP95)
18143        YUPP99=2.576*SDR
18144        YLOW99=(-YUPP99)
18145        IOUT=0
18146C
18147        J=0
18148        IF(IAUTL0.EQ.'ON')THEN
18149          J=J+1
18150          Y(J+NPLOTP)=PCC(1)
18151          X(J+NPLOTP)=0.0
18152          D(J+NPLOTP)=REAL(1 + IFACT*(NCURVE-1))
18153        ENDIF
18154C
18155        DO3410K=1,KMAXM1
18156          J=J+1
18157          Y(J+NPLOTP)=PCC(K+1)
18158          X(J+NPLOTP)=REAL(K)
18159          D(J+NPLOTP)=REAL(1 + IFACT*(NCURVE-1))
18160          IF(Y(J+NPLOTP).GT.YUPP95)IOUT=IOUT+1
18161          IF(Y(J+NPLOTP).LT.YLOW95)IOUT=IOUT+1
18162          J=J+1
18163          Y(J+NPLOTP)=YMID
18164          X(J+NPLOTP)=REAL(K)
18165          D(J+NPLOTP)=REAL(2 + IFACT*(NCURVE-1))
18166          J=J+1
18167          Y(J+NPLOTP)=YUPP95
18168          X(J+NPLOTP)=REAL(K)
18169          D(J+NPLOTP)=REAL(3 + IFACT*(NCURVE-1))
18170          J=J+1
18171          Y(J+NPLOTP)=YLOW95
18172          X(J+NPLOTP)=REAL(K)
18173          D(J+NPLOTP)=REAL(4 + IFACT*(NCURVE-1))
18174          J=J+1
18175          Y(J+NPLOTP)=YUPP99
18176          X(J+NPLOTP)=REAL(K)
18177          D(J+NPLOTP)=REAL(5 + IFACT*(NCURVE-1))
18178          J=J+1
18179          Y(J+NPLOTP)=YLOW99
18180          X(J+NPLOTP)=REAL(K)
18181          D(J+NPLOTP)=REAL(6 + IFACT*(NCURVE-1))
18182 3410   CONTINUE
18183        AIOUT=IOUT
18184        AKMAXM=KMAXM1
18185        PEROUT=100.0*(AIOUT/AKMAXM)
18186C
18187        NPLOTP=NPLOTP+J
18188        NPLOTV=3
18189C
18190        CALL DPWCCP(ICASPL,
18191     1              YLOW95,YUPP95,IOUT,KMAXM1,PEROUT,
18192     1              IBUGG3,ISUBRO,IFOUND,IERROR)
18193C
18194C           ******************************************************
18195C           **  STEP 4.4--                                      **
18196C           **  COMPUTE THE AUTOCOMOVEMENT FOR THE X DATA.      **
18197C           ******************************************************
18198C
18199      ELSEIF(ICASPL.EQ.'AUCM')THEN
18200        IFACT=2
18201        YMID=0.0
18202        J=1
18203        X(J+NPLOTP)=0.0
18204        Y(J+NPLOTP)=1.0
18205        D(J+NPLOTP)=REAL(1 + IFACT*(NCURVE-1))
18206C
18207        DO4110K=1,KMAXM1
18208          NMK=N-K
18209          ANMK=NMK
18210          DO4120I=1,NMK
18211            JJ=I+K
18212            TEMP1(I)=Y1(I)
18213            TEMP2(I)=Y1(JJ)
18214 4120     CONTINUE
18215          CALL COMOVE(TEMP1,TEMP2,NMK,IWRITE,XYCOMO,IBUGG3,IERROR)
18216          J=J+1
18217          X(J+NPLOTP)=REAL(K)
18218          Y(J+NPLOTP)=XYCOMO
18219          D(J+NPLOTP)=REAL(1 + IFACT*(NCURVE-1))
18220          J=J+1
18221          Y(J+NPLOTP)=YMID
18222          X(J+NPLOTP)=REAL(K)
18223          D(J+NPLOTP)=REAL(2 + IFACT*(NCURVE-1))
18224 4110   CONTINUE
18225C
18226        NPLOTP=NPLOTP+J
18227        NPLOTV=3
18228C
18229      ELSEIF(ICASPL.EQ.'CRCM')THEN
18230C
18231C       **********************************************************
18232C       **  STEP 5.2--                                          **
18233C       **  COMPUTE CROSS-COMOVEMENTS  FOR THE X AND Y  DATA    **
18234C       **********************************************************
18235C
18236        IFACT=2
18237        YMID=0.0
18238        J=0
18239        L=(-KMAXM1-1)
18240        DO5110K=1,KMAXM1
18241          KREV=KMAXM1-K+1
18242          NMK=N-KREV
18243          ANMK=NMK
18244          DO5120I=1,NMK
18245            JJ=I+KREV
18246            TEMP1(I)=Y1(JJ)
18247            TEMP2(I)=Y2(I)
18248 5120     CONTINUE
18249          CALL COMOVE(TEMP1,TEMP2,NMK,IWRITE,XYCOMO,IBUGG3,IERROR)
18250          J=J+1
18251          L=L+1
18252          X(J+NPLOTP)=REAL(L)
18253          Y(J+NPLOTP)=XYCOMO
18254          D(J+NPLOTP)=REAL(1 + IFACT*(NCURVE-1))
18255          J=J+1
18256          Y(J+NPLOTP)=YMID
18257          X(J+NPLOTP)=REAL(L)
18258          D(J+NPLOTP)=REAL(2 + IFACT*(NCURVE-1))
18259 5110   CONTINUE
18260C
18261        J=J+1
18262        X(J+NPLOTP)=0.0
18263        Y(J+NPLOTP)=1.0
18264        D(J+NPLOTP)=REAL(1 + IFACT*(NCURVE-1))
18265        J=J+1
18266        X(J+NPLOTP)=0.0
18267        Y(J+NPLOTP)=0.0
18268        D(J+NPLOTP)=REAL(2 + IFACT*(NCURVE-1))
18269C
18270        DO5210K=1,KMAXM1
18271          NMK=N-K
18272          ANMK=NMK
18273          DO5220I=1,NMK
18274            JJ=I+K
18275            TEMP1(I)=Y1(I)
18276            TEMP2(I)=Y2(JJ)
18277 5220     CONTINUE
18278          CALL COMOVE(TEMP1,TEMP2,NMK,IWRITE,XYCOMO,IBUGG3,IERROR)
18279          J=J+1
18280          X(J+NPLOTP)=REAL(K)
18281          Y(J+NPLOTP)=XYCOMO
18282          D(J+NPLOTP)=REAL(1 + IFACT*(NCURVE-1))
18283          J=J+1
18284          Y(J+NPLOTP)=YMID
18285          X(J+NPLOTP)=REAL(K)
18286          D(J+NPLOTP)=REAL(2 + IFACT*(NCURVE-1))
18287 5210   CONTINUE
18288C
18289        NPLOTP=NPLOTP+J
18290        NPLOTV=3
18291C
18292      ELSE
18293        WRITE(ICOUT,999)
18294        CALL DPWRST('XXX','BUG ')
18295        WRITE(ICOUT,31)
18296        CALL DPWRST('XXX','BUG ')
18297        WRITE(ICOUT,112)
18298  112   FORMAT('      ICASPL SHOULD BE ONE OF')
18299        CALL DPWRST('XXX','BUG ')
18300        WRITE(ICOUT,1013)
18301 1013   FORMAT('      AUCO, CRCO, PACO, AUCM, OR CRCM, BUT IS NOT.')
18302        CALL DPWRST('XXX','BUG ')
18303        WRITE(ICOUT,1014)ICASPL
18304 1014   FORMAT('      ICASPL = ',A4)
18305        CALL DPWRST('XXX','BUG ')
18306        IERROR='YES'
18307      ENDIF
18308C
18309C               ******************
18310C               **   STEP 90--  **
18311C               **   EXIT       **
18312C               ******************
18313C
18314 9000 CONTINUE
18315      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'COR2')THEN
18316        WRITE(ICOUT,999)
18317        CALL DPWRST('XXX','BUG ')
18318        WRITE(ICOUT,9011)
18319 9011   FORMAT('***** AT THE END       OF DPCOR2--')
18320        CALL DPWRST('XXX','BUG ')
18321        WRITE(ICOUT,9012)ICASPL,NUMLAG,N,KMAX,NPLOTP,IERROR
18322 9012   FORMAT('ICASPL,NUMLAG,N,KMAX,NPLOTP,IERROR = ',A4,4I8,2X,A4)
18323        CALL DPWRST('XXX','BUG ')
18324        DO9015I=1,NPLOTP
18325          WRITE(ICOUT,9016)I,Y(I),X(I),D(I)
18326 9016     FORMAT('I,Y(I),X(I),D(I) = ',I8,3G15.7)
18327          CALL DPWRST('XXX','BUG ')
18328 9015   CONTINUE
18329        WRITE(ICOUT,999)
18330        CALL DPWRST('XXX','BUG ')
18331        DO9020I=1,10
18332          WRITE(ICOUT,9021)I,D(I),TOP(I),BOTTOM(I),PCC(I)
18333 9021     FORMAT('I,D(I),TOP(I),BOTTOM(I),PCC(I) = ',I8,4G15.7)
18334          CALL DPWRST('XXX','BUG ')
18335 9020   CONTINUE
18336      ENDIF
18337C
18338      RETURN
18339      END
18340      SUBROUTINE DPCORE(XMAT,K,N,MAXROM,MAXK,
18341     1                  CORE,ICTAG,NROW,NUMCOR,
18342     1                  IVLIST,TEMP1,TEMP2,
18343     1                  IBUGA3,ISUBRO,IERROR)
18344C
18345C     IMPLEMENT THE FOLLOWING COMMAND
18346C
18347C         LET COREFAC = DEX CORE X1 ... XK
18348C
18349C     COREFAC WILL BE A MATRIX WITH 5 COLUMNS.
18350C
18351C     THIS COMMAND IMPLEMENTS THE "CORE.DP" MACRO IN FORTRAN FOR
18352C     PERFORMANCE REASONS.  THIS COMMAND DETERMINES THE CORE VECTORS
18353C     SPANNING THE (N-1) SPACE (OR A LARGE PART OF IT) FOR EFFECT
18354C     ESTIMATION CALCULATIONS BY THE EST.DP MACRO IN THE 10-STEP
18355C     SERIES OF MACROS.
18356C
18357C     WRITTEN BY--ALAN HECKERT
18358C                 STATISTICAL ENGINEERING DIVISION
18359C                 INFORMATION TECHNOLOGY LABORATORY
18360C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
18361C                 GAITHERSBURG, MD 20899-8980
18362C                 PHONE--301-975-2855
18363C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
18364C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
18365C     LANGUAGE--ANSI FORTRAN (1977)
18366C     VERSION NUMBER--2018/01
18367C     ORIGINAL VERSION--JANUARY   2018.
18368C
18369C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
18370C
18371      CHARACTER*4 IBUGA3
18372      CHARACTER*4 ISUBRO
18373      CHARACTER*4 IERROR
18374C
18375      CHARACTER*4 ISUBN1
18376      CHARACTER*4 ISUBN2
18377      CHARACTER*4 ISTEPN
18378      CHARACTER*4 IWRITE
18379C
18380C---------------------------------------------------------------------
18381C
18382      PARAMETER (MAXNOC=100)
18383C
18384      DIMENSION XMAT(MAXROM,K)
18385      DIMENSION TEMP1(*)
18386      DIMENSION TEMP2(*)
18387      DIMENSION CORE(MAXROM,5)
18388      INTEGER IVLIST(NROW,5)
18389      INTEGER ICTAG(*)
18390C
18391C---------------------------------------------------------------------
18392C
18393      INCLUDE 'DPCOP2.INC'
18394C
18395C-----START POINT-----------------------------------------------------
18396C
18397      ISUBN1='DPCO'
18398      ISUBN2='RE  '
18399      IERROR='NO'
18400      IWRITE='OFF'
18401C
18402      KM1=0
18403      KM2=0
18404      KM3=0
18405      NUMFAC=K
18406      NINP=N
18407C
18408      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CORE')THEN
18409        WRITE(ICOUT,999)
18410  999   FORMAT(1X)
18411        CALL DPWRST('XXX','BUG ')
18412        WRITE(ICOUT,51)
18413   51   FORMAT('***** AT THE BEGINNING OF DPCORE--')
18414        CALL DPWRST('XXX','BUG ')
18415        WRITE(ICOUT,52)N,K,NROW,MAXK,MAXROM
18416   52   FORMAT('N,K,NROW,MAXK,MAXROM = ',5I8)
18417        CALL DPWRST('XXX','BUG ')
18418        DO61I=1,N
18419          WRITE(ICOUT,63)I,(XMAT(I,J),J=1,MIN(K,10))
18420   63     FORMAT('I,XMAT(I,J) = ',I8,10G15.7)
18421          CALL DPWRST('XXX','BUG ')
18422   61   CONTINUE
18423      ENDIF
18424C
18425C               **************************************************
18426C               **  STEP 0.5--                                  **
18427C               **   CHECK FOR VALID VALUES OF K                **
18428C               **************************************************
18429C
18430      ISTEPN='0.5'
18431      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIT2')
18432     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18433C
18434      IF(K.LT.1 .OR. K.GT.MAXK)THEN
18435        WRITE(ICOUT,999)
18436        CALL DPWRST('XXX','BUG ')
18437        WRITE(ICOUT,91)
18438   91   FORMAT('***** ERROR IN DEX CORE--')
18439        CALL DPWRST('XXX','BUG ')
18440        WRITE(ICOUT,93)MAXK
18441   93   FORMAT('      THE NUMBER OF DESIGN FACTORS IS LESS THAN ',
18442     1         '1 OR GREATER THAN ',I3)
18443        CALL DPWRST('XXX','BUG ')
18444        WRITE(ICOUT,95)K
18445   95   FORMAT('      THE NUMBER OF DESIGN FACTORS IS ',I8)
18446        CALL DPWRST('XXX','BUG ')
18447        IERROR='YES'
18448        GOTO9000
18449      ENDIF
18450C
18451C     REMOVE CENTER POINTS (I.E., = 0) AND CHECK THAT ALL REMAINING
18452C     POINTS ARE EITHER -1 OR +1.
18453C
18454      DO70J=1,NUMFAC
18455        ICNT=0
18456        DO80I=1,NINP
18457          AVAL=XMAT(I,J)
18458          IF(AVAL.EQ.0.0)THEN
18459            GOTO80
18460          ELSEIF(AVAL.NE.-1.0 .AND. AVAL.NE.1.0)THEN
18461            WRITE(ICOUT,999)
18462            CALL DPWRST('XXX','BUG ')
18463            WRITE(ICOUT,91)
18464            CALL DPWRST('XXX','BUG ')
18465            WRITE(ICOUT,85)I,J
18466   85       FORMAT('     ROW ',I8,' OF FACTOR ',I5,' DOES NOT EQUAL ',
18467     1             '-1 OR +1')
18468            CALL DPWRST('XXX','BUG ')
18469            WRITE(ICOUT,87)AVAL
18470  87        FORMAT('     THE VALUE IS ',G15.7)
18471            CALL DPWRST('XXX','BUG ')
18472            IERROR='YES'
18473            GOTO9000
18474          ELSE
18475            ICNT=ICNT+1
18476            XMAT(ICNT,J)=XMAT(I,J)
18477          ENDIF
18478   80   CONTINUE
18479   70 CONTINUE
18480      NINP=ICNT
18481C
18482      DO101J=1,5
18483        DO103I=1,NROW
18484          CORE(I,J)=-999.
18485          IVLIST(I,J)=-999
18486  103   CONTINUE
18487  101 CONTINUE
18488C
18489      DO105I=1,NROW
18490        ICTAG(I)=1
18491  105 CONTINUE
18492C
18493      NUMCOR=0
18494      DO110J=1,K
18495        NUMCOR=NUMCOR+1
18496        IVLIST(NUMCOR,1)=J
18497  110 CONTINUE
18498C
18499      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CORE')THEN
18500        WRITE(ICOUT,112)NUMCOR
18501  112   FORMAT('AFTER K = 1, NUMCOR = ',I5)
18502        CALL DPWRST('XXX','BUG ')
18503      ENDIF
18504C
18505      IF(K.GE.2)THEN
18506        KM1=K-1
18507        DO120J1=1,KM1
18508          J1P1=J1+1
18509          DO125J2=J1P1,K
18510            NUMCOR=NUMCOR+1
18511            IVLIST(NUMCOR,1)=J1
18512            IVLIST(NUMCOR,2)=J2
18513  125     CONTINUE
18514  120     CONTINUE
18515      ENDIF
18516C
18517      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CORE')THEN
18518        WRITE(ICOUT,122)NUMCOR
18519  122   FORMAT('AFTER K = 2, NUMCOR = ',I5)
18520        CALL DPWRST('XXX','BUG ')
18521      ENDIF
18522C
18523      IF(NUMCOR.LE.MAXNOC .AND. K.GE.3)THEN
18524        KM2=K-2
18525        DO130J1=1,KM2
18526          J1P1=J1+1
18527          DO135J2=J1P1,KM1
18528            J2P1=J2+1
18529            DO138J3=J2P1,K
18530              NUMCOR=NUMCOR+1
18531              IVLIST(NUMCOR,1)=J1
18532              IVLIST(NUMCOR,2)=J2
18533              IVLIST(NUMCOR,3)=J3
18534  138       CONTINUE
18535  135     CONTINUE
18536  130     CONTINUE
18537      ENDIF
18538C
18539      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CORE')THEN
18540        WRITE(ICOUT,132)NUMCOR
18541  132   FORMAT('AFTER K = 3, NUMCOR = ',I5)
18542        CALL DPWRST('XXX','BUG ')
18543      ENDIF
18544C
18545      IF(NUMCOR.LE.MAXNOC .AND. K.GE.4)THEN
18546        KM3=K-3
18547        DO140J1=1,KM3
18548          J1P1=J1+1
18549          DO143J2=J1P1,KM2
18550            J2P1=J2+1
18551            DO145J3=J2P1,KM1
18552              J3P1=J3+1
18553              DO148J4=J3P1,K
18554                NUMCOR=NUMCOR+1
18555                IVLIST(NUMCOR,1)=J1
18556                IVLIST(NUMCOR,2)=J2
18557                IVLIST(NUMCOR,3)=J3
18558                IVLIST(NUMCOR,4)=J4
18559  148         CONTINUE
18560  145       CONTINUE
18561  143     CONTINUE
18562  140   CONTINUE
18563      ENDIF
18564C
18565      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CORE')THEN
18566        WRITE(ICOUT,142)NUMCOR
18567  142   FORMAT('AFTER K = 4, NUMCOR = ',I5)
18568        CALL DPWRST('XXX','BUG ')
18569      ENDIF
18570C
18571      IF(NUMCOR.LE.MAXNOC .AND. K.GE.5)THEN
18572        KM4=K-4
18573        DO150J1=1,KM4
18574          J1P1=J1+1
18575          DO151J2=J1P1,KM3
18576            J2P1=J2+1
18577            DO153J3=J2P1,KM2
18578              J3P1=J3+1
18579              DO155J4=J3P1,KM1
18580                J4P1=J4+1
18581                DO158J5=J4P1,K
18582                  NUMCOR=NUMCOR+1
18583                  IVLIST(NUMCOR,1)=J1
18584                  IVLIST(NUMCOR,2)=J2
18585                  IVLIST(NUMCOR,3)=J3
18586                  IVLIST(NUMCOR,4)=J4
18587                  IVLIST(NUMCOR,5)=J5
18588  158           CONTINUE
18589  155         CONTINUE
18590  153       CONTINUE
18591  151     CONTINUE
18592  150   CONTINUE
18593      ENDIF
18594C
18595      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CORE')THEN
18596        WRITE(ICOUT,152)NUMCOR
18597  152   FORMAT('AFTER K = 5, NUMCOR = ',I5)
18598        CALL DPWRST('XXX','BUG ')
18599        DO161I=1,NUMCOR
18600          WRITE(ICOUT,162)I,(IVLIST(I,J),J=1,5)
18601  162     FORMAT('I,IVLIST(I,J=1,5) = ',6I8)
18602          CALL DPWRST('XXX','BUG ')
18603 161    CONTINUE
18604      ENDIF
18605C
18606C               *****************************************************
18607C               **  STEP 2--                                       **
18608C               **  SEQUENTIALLY COMPARE THE TENTATIVE CORE        **
18609C               **  ELEMENTS WITH ALL PREVIOUS ELEMENTS.  IF       **
18610C               **  ORTHOGONAL, TAG CORE ELEMENT AS ACCEPTABLE,    **
18611C               **  OTHERWISE TAG AS UNACCEPTABLE.                 **
18612C               *****************************************************
18613C
18614      ISTEPN='2'
18615      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CORE')
18616     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18617C
18618      DO210J1=2,NUMCOR
18619C
18620C       INITIALIZE THE TWO VECTORS
18621C
18622        ISTEPN='21'
18623        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CORE')THEN
18624          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18625          WRITE(ICOUT,201)J1
18626  201     FORMAT('LOOP 210: J1 = ',I8)
18627          CALL DPWRST('XXX','BUG ')
18628        ENDIF
18629C
18630        DO211I=1,N
18631          TEMP1(I)=1.0
18632  211   CONTINUE
18633C
18634C       NOW LOOP THROUGH THE COLUMNS
18635C
18636        DO213L=1,5
18637          ICOL=IVLIST(J1,L)
18638          IF(ICOL.GT.0)THEN
18639            DO215I=1,N
18640              TEMP1(I)=TEMP1(I)*XMAT(I,ICOL)
18641  215       CONTINUE
18642          ENDIF
18643  213   CONTINUE
18644C
18645C       NOW EXTRACT THE SECOND VECTOR
18646C
18647        J1M1=J1-1
18648        EPS=0.001
18649        DO220J2=1,J1M1
18650          DO221I=1,N
18651            TEMP2(I)=1.0
18652  221     CONTINUE
18653          DO223L=1,5
18654            ICOL=IVLIST(J2,L)
18655            IF(ICOL.GT.0)THEN
18656              DO225I=1,N
18657                TEMP2(I)=TEMP2(I)*XMAT(I,ICOL)
18658  225         CONTINUE
18659            ENDIF
18660  223     CONTINUE
18661C
18662          CALL CORR(TEMP1,TEMP2,N,IWRITE,CZ,IBUGA3,IERROR)
18663          CZABS=ABS(CZ)
18664          IF(ABS(CZABS-1.0).LE.EPS)ICTAG(J1)=0
18665          IF(J1.EQ.1)ICTAG(J1)=1
18666  220   CONTINUE
18667  210 CONTINUE
18668C
18669C               *****************************************************
18670C               **  STEP 3--                                       **
18671C               **  ONLY KEEP ROWS WHERE ICTAG IS 1.               **
18672C               *****************************************************
18673C
18674      ISTEPN='3'
18675      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CORE')
18676     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18677C
18678      ICNT2=0
18679      DO310J=1,NUMCOR
18680        IF(ICTAG(J).EQ.1)THEN
18681          ICNT2=ICNT2+1
18682          CORE(ICNT2,1)=REAL(IVLIST(J,1))
18683          CORE(ICNT2,2)=REAL(IVLIST(J,2))
18684          CORE(ICNT2,3)=REAL(IVLIST(J,3))
18685          CORE(ICNT2,4)=REAL(IVLIST(J,4))
18686          CORE(ICNT2,5)=REAL(IVLIST(J,5))
18687         ENDIF
18688  310  CONTINUE
18689       NUMCOR=ICNT2
18690C
18691C               *****************
18692C               **  STEP 90--  **
18693C               **  EXIT       **
18694C               *****************
18695C
18696 9000 CONTINUE
18697      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CORE')THEN
18698        WRITE(ICOUT,999)
18699        CALL DPWRST('XXX','BUG ')
18700        WRITE(ICOUT,9011)
18701 9011   FORMAT('***** AT THE END       OF DPCORE--')
18702        CALL DPWRST('XXX','BUG ')
18703        WRITE(ICOUT,9012)IERROR,NUMCOR
18704 9012   FORMAT('IERROR,NUMCOR = ',A4,I8)
18705        CALL DPWRST('XXX','BUG ')
18706        DO9020I=1,NUMCOR
18707          WRITE(ICOUT,9022)I,(CORE(I,J),J=1,5)
18708 9022     FORMAT('I,(CORE(I,J),J=1,5) = ',I8,5G15.7)
18709          CALL DPWRST('XXX','BUG ')
18710 9020   CONTINUE
18711      ENDIF
18712C
18713      RETURN
18714      END
18715      SUBROUTINE DPCORR(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
18716     1                  IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
18717C
18718C     PURPOSE--FORM
18719C              1) AUTOCORRELATION PLOT
18720C              2) CROSS-CORRELATION PLOT
18721C              3) PARTIAL AUTOCORRELATION PLOT
18722C     WRITTEN BY--JAMES J. FILLIBEN
18723C                 STATISTICAL ENGINEERING DIVISION
18724C                 INFORMATION TECHNOLOGY LABORATORY
18725C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
18726C                 GAITHERSBURG, MD 20899-8980
18727C                 PHONE--301-975-2855
18728C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
18729C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
18730C     LANGUAGE--ANSI FORTRAN (1977)
18731C     VERSION NUMBER--82/7
18732C     ORIGINAL VERSION--MAY       1978.
18733C     UPDATED         --JUNE      1978.
18734C     UPDATED         --JULY      1979.
18735C     UPDATED         --JANUARY   1981.
18736C     UPDATED         --DECEMBER  1981.
18737C     UPDATED         --MARCH     1982.
18738C     UPDATED         --MAY       1982.
18739C     UPDATED         --JUNE      1990.  TEMPORARY ARRAYS TO GARBAGE COMMON
18740C     UPDATED         --FEBRUARY  1990.  PARTIAL AUTOECORRELATION PLOT
18741C     UPDATED         --OCTOBER   1997.  MOVE SOME DIMENSIONS TO DPCORR
18742C     UPDATED         --JULY      1999.  ADD IAUTCP PARAMETER
18743C     UPDATED         --FEBRUARY  2003.  ADD IAUTL0 PARAMETER
18744C     UPDATED         --JANAURY   2012.  USE DPPARS
18745C     UPDATED         --JANAURY   2012.  FOLD IN COMOVEMENT PLOT
18746C     UPDATED         --JANAURY   2012.  SUPPORT FOR "MULTIPLE" AND
18747C                                        "REPLICATION" OPTIONS
18748C     UPDATED         --APRIL     2015.  FIX BUG IN CHECKING FOR
18749C                                        PARTIAL AUTOCORRELATION
18750C
18751C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
18752C
18753      CHARACTER*4 ICASPL
18754      CHARACTER*4 IAND1
18755      CHARACTER*4 IAND2
18756      CHARACTER*4 IBUGG2
18757      CHARACTER*4 IBUGG3
18758      CHARACTER*4 IBUGQ
18759      CHARACTER*4 ISUBRO
18760      CHARACTER*4 IFOUND
18761      CHARACTER*4 IERROR
18762C
18763      CHARACTER*4 IHWUSE
18764      CHARACTER*4 MESSAG
18765      CHARACTER*4 IH
18766      CHARACTER*4 IH2
18767      CHARACTER*4 ISUBN1
18768      CHARACTER*4 ISUBN2
18769      CHARACTER*4 ISTEPN
18770C
18771      CHARACTER*4 IREPL
18772      CHARACTER*4 IMULT
18773      CHARACTER*4 ICASE
18774      CHARACTER*40 INAME
18775      PARAMETER (MAXSPN=30)
18776      CHARACTER*4 IVARN1(MAXSPN)
18777      CHARACTER*4 IVARN2(MAXSPN)
18778      CHARACTER*4 IVARTY(MAXSPN)
18779      REAL PVAR(MAXSPN)
18780      INTEGER ILIS(MAXSPN)
18781      INTEGER NRIGHT(MAXSPN)
18782      INTEGER ICOLR(MAXSPN)
18783C
18784C---------------------------------------------------------------------
18785C
18786      INCLUDE 'DPCOPA.INC'
18787      INCLUDE 'DPCOZZ.INC'
18788C
18789      DIMENSION Y1(MAXOBV)
18790      DIMENSION Y2(MAXOBV)
18791      DIMENSION TOP(MAXOBV)
18792      DIMENSION BOTTOM(MAXOBV)
18793      DIMENSION PCC(MAXOBV)
18794      DIMENSION XIDTEM(MAXOBV)
18795      DIMENSION XIDTE2(MAXOBV)
18796      DIMENSION XIDTE3(MAXOBV)
18797      DIMENSION TEMP1(MAXOBV)
18798      DIMENSION TEMP2(MAXOBV)
18799      DIMENSION ZY1(MAXOBV)
18800      DIMENSION ZY2(MAXOBV)
18801      DIMENSION XDESGN(MAXOBV,2)
18802C
18803      EQUIVALENCE (GARBAG(IGARB1),Y1(1))
18804      EQUIVALENCE (GARBAG(IGARB2),Y2(1))
18805      EQUIVALENCE (GARBAG(IGARB3),TOP(1))
18806      EQUIVALENCE (GARBAG(IGARB4),BOTTOM(1))
18807      EQUIVALENCE (GARBAG(IGARB5),PCC(1))
18808      EQUIVALENCE (GARBAG(IGARB7),TEMP1(1))
18809      EQUIVALENCE (GARBAG(IGARB8),TEMP2(1))
18810      EQUIVALENCE (GARBAG(IGARB9),XIDTEM(1))
18811      EQUIVALENCE (GARBAG(IGAR10),XIDTE2(1))
18812      EQUIVALENCE (GARBAG(JGAR11),XIDTE3(1))
18813      EQUIVALENCE (GARBAG(JGAR12),ZY1(1))
18814      EQUIVALENCE (GARBAG(JGAR13),ZY2(1))
18815      EQUIVALENCE (GARBAG(JGAR14),XDESGN(1,1))
18816CCCCC END CHANGE
18817C
18818C-----COMMON----------------------------------------------------------
18819C
18820      INCLUDE 'DPCOHK.INC'
18821      INCLUDE 'DPCODA.INC'
18822CCCCC ADD FOLLOWING LINE JULY 1999
18823      INCLUDE 'DPCOST.INC'
18824C
18825C-----COMMON VARIABLES (GENERAL)--------------------------------------
18826C
18827      INCLUDE 'DPCOP2.INC'
18828C
18829C-----START POINT-----------------------------------------------------
18830C
18831      IFOUND='NO'
18832      IERROR='NO'
18833      IMULT='OFF'
18834      IREPL='OFF'
18835C
18836      ISUBN1='DPCO'
18837      ISUBN2='RR  '
18838C
18839      MAXCP1=MAXCOL+1
18840      MAXCP2=MAXCOL+2
18841      MAXCP3=MAXCOL+3
18842      MAXCP4=MAXCOL+4
18843      MAXCP5=MAXCOL+5
18844      MAXCP6=MAXCOL+6
18845C
18846C               **************************************************
18847C               **  TREAT THE FOLLOWING CASES--                  *
18848C               **        1) AUTOCORRELATION                     *
18849C               **        2) CROSS-CORRELATION;                  *
18850C               **        3) PARTIAL AUTO-CORRELATION;           *
18851C               **************************************************
18852C
18853      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'CORR')THEN
18854        WRITE(ICOUT,999)
18855  999   FORMAT(1X)
18856        CALL DPWRST('XXX','BUG ')
18857        WRITE(ICOUT,51)
18858   51   FORMAT('***** AT THE BEGINNING OF DPCORR--')
18859        CALL DPWRST('XXX','BUG ')
18860        WRITE(ICOUT,52)ICASPL,IAND1,IAND2
18861   52   FORMAT('ICASPL,IAND1,IAND2 = ',2(A4,2X),A4)
18862        CALL DPWRST('XXX','BUG ')
18863        WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ,ISUBRO
18864   53   FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',3(A4,2X),A4)
18865        CALL DPWRST('XXX','BUG ')
18866      ENDIF
18867C
18868C               ***************************
18869C               **  STEP 1--             **
18870C               **  EXTRACT THE COMMAND  **
18871C               ***************************
18872C
18873      ISTEPN='1'
18874      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'CORR')
18875     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18876C
18877C               ***************************************
18878C               **  STEP 1.1--                       **
18879C               **  SEARCH FOR AUTOCORRELATION PLOT, **
18880C               **  PARTIAL CORRELATION, OR          **
18881C               **  CROSS-CORRELATION.  ALSO LOOK    **
18882C               **  MULTIPLE OR REPLICATION.         **
18883C               ***************************************
18884C
18885      IF(ICOM.EQ.'MULT')IMULT='ON'
18886      IF(ICOM.EQ.'REPL')IREPL='ON'
18887C
18888      IF(NUMARG.GE.2 .AND.
18889     1   ICOM.EQ.'AUTO'.AND.IHARG(1).EQ.'CORR'.AND.
18890     1   IHARG(2).EQ.'PLOT')THEN
18891        ICASPL='AUCO'
18892        ILASTC=2
18893      ELSEIF(NUMARG.GE.1 .AND.
18894     1   ICOM.EQ.'AUTO'.AND.ICOM2.EQ.'CORR'.AND.
18895     1   IHARG(1).EQ.'PLOT')THEN
18896        ICASPL='AUCO'
18897        ILASTC=1
18898      ELSEIF(NUMARG.GE.3 .AND.ICOM.NE.'PART'.AND.
18899     1   IHARG(1).EQ.'AUTO'.AND.IHARG(2).EQ.'CORR'.AND.
18900     1   IHARG(3).EQ.'PLOT')THEN
18901        ILASTC=3
18902      ELSEIF(NUMARG.GE.2 .AND.
18903     1   ICOM.NE.'PART'.AND.
18904     1   IHARG(1).EQ.'AUTO'.AND.IHARG2(1).EQ.'CORR'.AND.
18905     1   IHARG(2).EQ.'PLOT')THEN
18906        ICASPL='AUCO'
18907        ILASTC=2
18908      ELSEIF(NUMARG.GE.3 .AND.
18909     1   ICOM.NE.'PART'.AND.
18910     1   IHARG(1).EQ.'AUTO'.AND.IHARG(2).EQ.'CORR'.AND.
18911     1   IHARG(3).EQ.'PLOT')THEN
18912        ICASPL='AUCO'
18913        ILASTC=3
18914      ELSEIF(NUMARG.GE.3 .AND.
18915     1   ICOM.EQ.'PART'.AND.IHARG(1).EQ.'AUTO'.AND.
18916     1   IHARG(2).EQ.'CORR'.AND.IHARG(3).EQ.'PLOT')THEN
18917        ICASPL='PACO'
18918        ILASTC=3
18919      ELSEIF(NUMARG.GE.2 .AND.
18920     1   ICOM.EQ.'PART'.AND.IHARG(1).EQ.'AUTO'.AND.
18921     1   IHARG2(1).EQ.'CORR'.AND.IHARG(2).EQ.'PLOT')THEN
18922        ICASPL='PACO'
18923        ILASTC=2
18924      ELSEIF(NUMARG.GE.4 .AND.
18925     1   IHARG(1).EQ.'PART'.AND.IHARG(2).EQ.'AUTO'.AND.
18926     1   IHARG(3).EQ.'CORR'.AND.IHARG(4).EQ.'PLOT')THEN
18927        ICASPL='PACO'
18928        ILASTC=4
18929      ELSEIF(NUMARG.GE.3 .AND.
18930     1   IHARG(1).EQ.'PART'.AND.IHARG(2).EQ.'AUTO'.AND.
18931     1   IHARG2(2).EQ.'CORR'.AND.IHARG(3).EQ.'PLOT')THEN
18932        ICASPL='PACO'
18933        ILASTC=3
18934      ELSEIF(NUMARG.GE.2 .AND.
18935     1   ICOM.EQ.'CROS'.AND.IHARG(1).EQ.'CORR'.AND.
18936     1   IHARG(2).EQ.'PLOT')THEN
18937        ICASPL='CRCO'
18938        ILASTC=2
18939      ELSEIF(NUMARG.GE.1 .AND.
18940     1   ICOM.EQ.'CROS'.AND.ICOM2.EQ.'SCOR'.AND.
18941     1   IHARG(1).EQ.'PLOT')THEN
18942        ICASPL='CRCO'
18943        ILASTC=1
18944      ELSEIF(NUMARG.GE.3 .AND.
18945     1   IHARG(1).EQ.'CROS'.AND.IHARG(2).EQ.'CORR'.AND.
18946     1   IHARG(3).EQ.'PLOT')THEN
18947        ICASPL='CRCO'
18948        ILASTC=3
18949      ELSEIF(NUMARG.GE.1 .AND.
18950     1   IHARG(1).EQ.'CROS'.AND.IHARG2(1).EQ.'SCOR'.AND.
18951     1   IHARG(2).EQ.'PLOT')THEN
18952        ICASPL='CRCO'
18953        ILASTC=2
18954      ELSEIF(NUMARG.GE.2 .AND.
18955     1   ICOM.EQ.'AUTO'.AND.IHARG(1).EQ.'COMO'.AND.
18956     1   IHARG(2).EQ.'PLOT')THEN
18957        ICASPL='AUCM'
18958        ILASTC=2
18959      ELSEIF(NUMARG.GE.1 .AND.
18960     1   ICOM.EQ.'AUTO'.AND.ICOM2.EQ.'COMO'.AND.
18961     1   IHARG(1).EQ.'PLOT')THEN
18962        ICASPL='AUCM'
18963        ILASTC=1
18964      ELSEIF(NUMARG.GE.2 .AND.
18965     1   IHARG(1).EQ.'AUTO'.AND.IHARG2(1).EQ.'COMO'.AND.
18966     1   IHARG(2).EQ.'PLOT')THEN
18967        ICASPL='AUCM'
18968        ILASTC=2
18969      ELSEIF(NUMARG.GE.2 .AND.
18970     1   ICOM.EQ.'CROS'.AND.IHARG(1).EQ.'COMO'.AND.
18971     1   IHARG(2).EQ.'PLOT')THEN
18972        ICASPL='CRCM'
18973        ILASTC=2
18974      ELSEIF(NUMARG.GE.1 .AND.
18975     1   ICOM.EQ.'CROS'.AND.ICOM2.EQ.'SCOM'.AND.
18976     1   IHARG(1).EQ.'PLOT')THEN
18977        ICASPL='CRCM'
18978        ILASTC=1
18979      ELSEIF(NUMARG.GE.3 .AND.
18980     1   IHARG(1).EQ.'CROS'.AND.IHARG(2).EQ.'COMO'.AND.
18981     1   IHARG(3).EQ.'PLOT')THEN
18982        ICASPL='CRCM'
18983        ILASTC=3
18984      ELSEIF(NUMARG.GE.1 .AND.
18985     1   IHARG(1).EQ.'CROS'.AND.IHARG2(1).EQ.'SCOM'.AND.
18986     1   IHARG(2).EQ.'PLOT')THEN
18987        ICASPL='CRCM'
18988        ILASTC=2
18989      ELSE
18990        ICASPL='    '
18991        IFOUND='NO'
18992        GOTO9000
18993      ENDIF
18994C
18995      IF(IMULT.EQ.'ON')THEN
18996        IF(IREPL.EQ.'ON')THEN
18997          WRITE(ICOUT,999)
18998          CALL DPWRST('XXX','BUG ')
18999          WRITE(ICOUT,101)
19000  101     FORMAT('***** ERROR IN ...CORRELATION/COMOVEMENT PLOT--')
19001          CALL DPWRST('XXX','BUG ')
19002          WRITE(ICOUT,102)
19003  102     FORMAT('      YOU CANNOT SPECIFY BOTH "MULTIPLE" AND ',
19004     1           '"REPLICATION" FOR THIS PLOT.')
19005          CALL DPWRST('XXX','BUG ')
19006          IERROR='YES'
19007          GOTO9000
19008        ELSEIF(ICASPL.NE.'AUCO' .AND. ICASPL.NE.'AUCM')THEN
19009          WRITE(ICOUT,999)
19010          CALL DPWRST('XXX','BUG ')
19011          WRITE(ICOUT,101)
19012          CALL DPWRST('XXX','BUG ')
19013          WRITE(ICOUT,107)
19014  107     FORMAT('      THE "MULTIPLE" OPTION IS ONLY SUPPORTED FOR')
19015          CALL DPWRST('XXX','BUG ')
19016          WRITE(ICOUT,109)
19017  109     FORMAT('      AUTOCORRELATION PLOT.')
19018          CALL DPWRST('XXX','BUG ')
19019          IERROR='YES'
19020          GOTO9000
19021        ENDIF
19022      ENDIF
19023C
19024      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
19025      IFOUND='YES'
19026C
19027C               ****************************************
19028C               **  STEP 2--                          **
19029C               **  EXTRACT THE VARIABLE LIST         **
19030C               ****************************************
19031C
19032      ISTEPN='2'
19033      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'CORR')
19034     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19035C
19036      INAME='AUTOCORRELATION PLOT'
19037      IF(ICASPL.EQ.'PACO')INAME='PARTIAL AUTOCORRELATION PLOT'
19038      IF(ICASPL.EQ.'CRCO')INAME='CROSS-CORRELATION PLOT'
19039      IF(ICASPL.EQ.'AUCM')INAME='AUTOCOMOVEMENT PLOT'
19040      IF(ICASPL.EQ.'CRCM')INAME='CROSS-COMOVEMENT PLOT'
19041      MINNA=1
19042      MAXNA=100
19043      MINN2=1
19044      IFLAGE=1
19045      IFLAGM=1
19046      IFLAGP=0
19047      JMIN=1
19048      JMAX=NUMARG
19049      IF(ICASPL.EQ.'AUCO' .OR. ICASPL.EQ.'AUCM' .OR.
19050     1   ICASPL.EQ.'PACO')THEN
19051        MINNVA=1
19052        MAXNVA=1
19053      ELSE
19054        MINNVA=2
19055        MAXNVA=2
19056      ENDIF
19057      IF(IREPL.EQ.'ON')THEN
19058        MINNVA=MINNVA+1
19059        MAXNVA=MAXNVA+2
19060      ELSEIF(IMULT.EQ.'ON')THEN
19061        MINNVA=1
19062        MAXNVA=MAXSPN
19063        IFLAGE=0
19064      ENDIF
19065C
19066      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
19067     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
19068     1            JMIN,JMAX,
19069     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
19070     1            IVARN1,IVARN2,IVARTY,PVAR,
19071     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
19072     1            MINNVA,MAXNVA,
19073     1            IFLAGM,IFLAGP,
19074     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
19075      IF(IERROR.EQ.'YES')GOTO9000
19076C
19077      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'CORR')THEN
19078        WRITE(ICOUT,999)
19079        CALL DPWRST('XXX','BUG ')
19080        WRITE(ICOUT,281)
19081  281   FORMAT('***** AFTER CALL DPPARS--')
19082        CALL DPWRST('XXX','BUG ')
19083        WRITE(ICOUT,282)NQ,NUMVAR
19084  282   FORMAT('NQ,NUMVAR = ',2I8)
19085        CALL DPWRST('XXX','BUG ')
19086        IF(NUMVAR.GT.0)THEN
19087          DO285I=1,NUMVAR
19088            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
19089     1                      ICOLR(I)
19090  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
19091     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
19092            CALL DPWRST('XXX','BUG ')
19093  285     CONTINUE
19094        ENDIF
19095      ENDIF
19096C
19097      NRESP=0
19098      NREPL=0
19099      IF(ICASPL.NE.'AUCO' .OR. ICASPL.EQ.'AUCM' .OR.
19100     1   ICASPL.EQ.'PACO')THEN
19101        IF(IREPL.EQ.'OFF' .AND. NUMVAR.GT.1)IMULT='ON'
19102      ENDIF
19103      IF(IMULT.EQ.'ON')THEN
19104        NRESP=NUMVAR
19105      ELSEIF(IREPL.EQ.'ON')THEN
19106        NRESP=1
19107        NREPL=NUMVAR-NRESP
19108        IF(NREPL.LT.1 .OR. NREPL.GT.2)THEN
19109          WRITE(ICOUT,999)
19110          CALL DPWRST('XXX','BUG ')
19111          WRITE(ICOUT,101)
19112          CALL DPWRST('XXX','BUG ')
19113          WRITE(ICOUT,511)
19114  511     FORMAT('      FOR THE REPLICATION CASE, THE NUMBER OF ',
19115     1           'REPLICATION VARIABLES')
19116          CALL DPWRST('XXX','BUG ')
19117          WRITE(ICOUT,512)
19118  512     FORMAT('      MUST BE BETWEEN 1 AND 2;  SUCH WAS NOT THE ',
19119     1           'CASE HERE.')
19120          CALL DPWRST('XXX','BUG ')
19121          WRITE(ICOUT,513)NREPL
19122  513     FORMAT('      THE NUMBER OF REPLICATION VARIABLES = ',I5)
19123          CALL DPWRST('XXX','BUG ')
19124          IERROR='YES'
19125          GOTO9000
19126        ENDIF
19127      ELSE
19128        NRESP=1
19129      ENDIF
19130C
19131      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'CORR')THEN
19132        WRITE(ICOUT,112)ICASPL,IMULT,IREPL
19133  112   FORMAT('ICASPL,IMULT,IREPL = ',2(A4,2X),A4)
19134        CALL DPWRST('XXX','BUG ')
19135      ENDIF
19136C
19137C               **********************************************************
19138C               **  STEP 8--                                            **
19139C               **  DETERMINE IF THE ANALYST                            **
19140C               **  HAS SPECIFIED THE NUMBER OF LAGS DESIRED            **
19141C               **  FOR THE CROSS-CORRELATION PLOT.                     **
19142C               **  THE LAG SETTING IS DONE BY SEARCHING THE            **
19143C               **  INTERNAL TABLE FOR THE PARAMETER NAMES              **
19144C               **  LAGS, LAG, OR NUMLAG                                **
19145C               **  (WITH THE SEARCH CONDUCTED IN THAT ORDER            **
19146C               **  AND WITH THE FIRST FIND TERMINATING                 **
19147C               **  THE SEARCH.)                                        **
19148C               **  IF FOUND, USE THE SPECIFIED VALUE                   **
19149C               **  (WHICH MUST BE BETWEEN 1 AND 1000, INCLUSIVE);      **
19150C               **  IF NOT FOUND, USE THE DEFAULT VALUE                 **
19151C               **  (USUALLY NS/4) WHICH WILL BE DEFINED                **
19152C               **  IN THE SUBROUTINE DPCOR2.                           **
19153C               **********************************************************
19154C
19155      ISTEPN='8'
19156      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'CORR')
19157     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19158C
19159      NUMLAG=0
19160C
19161      IH='LAGS'
19162      IH2='    '
19163      IHWUSE='P'
19164      MESSAG='NO'
19165      CALL CHECKN(IH,IH2,IHWUSE,
19166     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
19167     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
19168      IF(IERROR.EQ.'NO')THEN
19169        NUMLAG=INT(VALUE(ILOCV)+0.5)
19170        GOTO790
19171      ENDIF
19172C
19173      IH='LAG '
19174      IH2='    '
19175      IHWUSE='P'
19176      MESSAG='NO'
19177      CALL CHECKN(IH,IH2,IHWUSE,
19178     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
19179     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
19180      IF(IERROR.EQ.'NO')THEN
19181        NUMLAG=INT(VALUE(ILOCV)+0.5)
19182        IF(IERROR.EQ.'NO')GOTO790
19183      ENDIF
19184C
19185      IH='NUML'
19186      IH2='AG  '
19187      IHWUSE='P'
19188      MESSAG='NO'
19189      CALL CHECKN(IH,IH2,IHWUSE,
19190     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
19191     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
19192      IF(IERROR.EQ.'NO')THEN
19193        NUMLAG=INT(VALUE(ILOCV)+0.5)
19194        IF(IERROR.EQ.'NO')GOTO790
19195      ENDIF
19196C
19197  790 CONTINUE
19198C
19199C               ********************************************
19200C               **  STEP 6--                              **
19201C               **  GENERATE THE CORRELATION    PLOTS FOR **
19202C               **  THE VARIOUS CASES.                    **
19203C               ********************************************
19204C
19205      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'CORR')THEN
19206        ISTEPN='6'
19207        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19208        WRITE(ICOUT,601)NRESP,NREPL
19209  601   FORMAT('NRESP,NREPL = ',2I5)
19210        CALL DPWRST('XXX','BUG ')
19211      ENDIF
19212C
19213      IF(NREPL.EQ.0)THEN
19214        ISTEPN='8A'
19215        IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'CORR')
19216     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19217C
19218C       LOOP THROUGH EACH OF THE RESPONSE VARIABLES
19219C
19220        NPLOTP=0
19221        ISKIP=2
19222        IF(ICASPL.EQ.'AUCO' .OR. ICASPL.EQ.'AUCM' .OR.
19223     1     ICASPL.EQ.'PACO')ISKIP=1
19224        DO810IRESP=1,NRESP,ISKIP
19225          NCURVE=IRESP
19226C
19227          IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'CORR')THEN
19228            WRITE(ICOUT,999)
19229            CALL DPWRST('XXX','BUG ')
19230            WRITE(ICOUT,811)IRESP,NCURVE
19231  811       FORMAT('IRESP,NCURVE = ',2I5)
19232            CALL DPWRST('XXX','BUG ')
19233          ENDIF
19234C
19235          ICOL=IRESP
19236          NUMVA2=2
19237          IF(ICASPL.EQ.'AUCO' .OR. ICASPL.EQ.'AUCM' .OR.
19238     1       ICASPL.EQ.'PACO')NUMVA2=1
19239          CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
19240     1                INAME,IVARN1,IVARN2,IVARTY,
19241     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
19242     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
19243     1                MAXCP4,MAXCP5,MAXCP6,
19244     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
19245     1                Y1,Y2,Y2,NS,NS,NS,ICASE,
19246     1                IBUGG3,ISUBRO,IFOUND,IERROR)
19247          IF(IERROR.EQ.'YES')GOTO9000
19248C
19249C               *****************************************************
19250C               **  STEP 8B--                                      **
19251C               **  FORM THE VERTICAL AND HORIZONTAL AXIS          **
19252C               **  VALUES Y(.) AND X(.) FOR THE PLOT.             **
19253C               *****************************************************
19254C
19255         CALL DPCOR2(Y1,Y2,NS,NCURVE,ICASPL,NUMLAG,MAXN,
19256     1               IAUTCP,IAUTL0,TEMP1,TEMP2,
19257     1               Y,X,D,TOP,BOTTOM,PCC,NPLOTP,NPLOTV,
19258     1               IBUGG3,ISUBRO,IERROR)
19259C
19260  810   CONTINUE
19261C
19262C               *****************************************************
19263C               **  STEP 9A--                                      **
19264C               **  CASE 3: ONE OR TWO  REPLICATION VARIABLES.     **
19265C               **          FOR THIS CASE, THE NUMBER OF RESPONSE  **
19266C               **          VARIABLES MUST BE EXACTLY 1.           **
19267C               *****************************************************
19268C
19269      ELSEIF(NREPL.GE.1)THEN
19270        ISTEPN='9A'
19271        IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'CORR')
19272     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19273C
19274        J=0
19275        IMAX=NRIGHT(1)
19276        IF(NQ.LT.NRIGHT(1))IMAX=NQ
19277        DO910I=1,IMAX
19278          IF(ISUB(I).EQ.0)GOTO910
19279          J=J+1
19280C
19281C         RESPONSE VARIABLE IN Y1
19282C
19283          IJ=MAXN*(ICOLR(1)-1)+I
19284          IF(ICOLR(1).LE.MAXCOL)Y1(J)=V(IJ)
19285          IF(ICOLR(1).EQ.MAXCP1)Y1(J)=PRED(I)
19286          IF(ICOLR(1).EQ.MAXCP2)Y1(J)=RES(I)
19287          IF(ICOLR(1).EQ.MAXCP3)Y1(J)=YPLOT(I)
19288          IF(ICOLR(1).EQ.MAXCP4)Y1(J)=XPLOT(I)
19289          IF(ICOLR(1).EQ.MAXCP5)Y1(J)=X2PLOT(I)
19290          IF(ICOLR(1).EQ.MAXCP6)Y1(J)=TAGPLO(I)
19291          ICOLC=1
19292C
19293C         SECOND RESPONSE VARIABLE IN Y2
19294C
19295          IF(ICASPL.NE.'AUCO' .AND. ICASPL.NE.'AUCM' .AND.
19296     1       ICASPL.NE.'PACO')THEN
19297            IJ=MAXN*(ICOLR(2)-1)+I
19298            IF(ICOLR(2).LE.MAXCOL)Y2(J)=V(IJ)
19299            IF(ICOLR(2).EQ.MAXCP1)Y2(J)=PRED(I)
19300            IF(ICOLR(2).EQ.MAXCP2)Y2(J)=RES(I)
19301            IF(ICOLR(2).EQ.MAXCP3)Y2(J)=YPLOT(I)
19302            IF(ICOLR(2).EQ.MAXCP4)Y2(J)=XPLOT(I)
19303            IF(ICOLR(2).EQ.MAXCP5)Y2(J)=X2PLOT(I)
19304            IF(ICOLR(2).EQ.MAXCP6)Y2(J)=TAGPLO(I)
19305            ICOLC=2
19306          ENDIF
19307C
19308          DO920IR=1,MIN(NREPL,2)
19309            ICOLC=ICOLC+1
19310            ICOLT=ICOLR(ICOLC)
19311            IJ=MAXN*(ICOLT-1)+I
19312            IF(ICOLT.LE.MAXCOL)XDESGN(J,IR)=V(IJ)
19313            IF(ICOLT.EQ.MAXCP1)XDESGN(J,IR)=PRED(I)
19314            IF(ICOLT.EQ.MAXCP2)XDESGN(J,IR)=RES(I)
19315            IF(ICOLT.EQ.MAXCP3)XDESGN(J,IR)=YPLOT(I)
19316            IF(ICOLT.EQ.MAXCP4)XDESGN(J,IR)=XPLOT(I)
19317            IF(ICOLT.EQ.MAXCP5)XDESGN(J,IR)=X2PLOT(I)
19318            IF(ICOLT.EQ.MAXCP6)XDESGN(J,IR)=TAGPLO(I)
19319  920     CONTINUE
19320C
19321  910   CONTINUE
19322        NLOCAL=J
19323C
19324C       *****************************************************
19325C       **  STEP 9B--                                      **
19326C       **  FORM THE VERTICAL AND HORIZONTAL AXIS          **
19327C       **  VALUES Y(.) AND X(.) FOR THE PLOT.             **
19328C       **                                                 **
19329C       **  FOR THIS CASE, WE NEED TO LOOP THROUGH THE     **
19330C       **  VARIOUS REPLICATIONS.                          **
19331C       *****************************************************
19332C
19333        ISTEPN='9B'
19334        IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'CORR')THEN
19335          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19336          WRITE(ICOUT,999)
19337          CALL DPWRST('XXX','BUG ')
19338          WRITE(ICOUT,931)
19339  931     FORMAT('***** FROM THE MIDDLE  OF DPCORR--')
19340          CALL DPWRST('XXX','BUG ')
19341          WRITE(ICOUT,932)ICASPL,NUMVAR,NLOCAL
19342  932     FORMAT('ICASPL,NUMVAR,NLOCAL = ',A4,2I8)
19343          CALL DPWRST('XXX','BUG ')
19344          IF(NLOCAL.GE.1)THEN
19345            DO935I=1,NLOCAL
19346              WRITE(ICOUT,936)I,Y1(I),XDESGN(I,1),XDESGN(I,2)
19347  936         FORMAT('I,Y1(I),XDESGN(I,1),XDESGN(I,2) = ',I8,3F12.5)
19348              CALL DPWRST('XXX','BUG ')
19349  935       CONTINUE
19350          ENDIF
19351        ENDIF
19352C
19353C       *****************************************************
19354C       **  STEP 9C--                                      **
19355C       **  FIND THE DISTINCT VALUES IN EACH OF THE        **
19356C       **  REPLICATION VARIABLES.                         **
19357C       *****************************************************
19358C
19359        CALL DPFRE5(XDESGN(1,1),XDESGN(1,2),
19360     1             NREPL,NLOCAL,MAXOBV,
19361     1             XIDTEM,XIDTE2,
19362     1             TEMP1,TEMP2,
19363     1             NUMSE1,NUMSE2,
19364     1             IBUGG3,ISUBRO,IERROR)
19365C
19366C       *****************************************************
19367C       **  STEP 9D--                                      **
19368C       **  NOW LOOP THROUGH THE VARIOUS REPLICATIONS      **
19369C       *****************************************************
19370C
19371        NPLOTP=0
19372        NCURVE=0
19373        IF(NREPL.EQ.1)THEN
19374          J=0
19375          DO1110ISET1=1,NUMSE1
19376            K=0
19377            DO1130I=1,NLOCAL
19378              IF(XIDTEM(ISET1).EQ.XDESGN(I,1))THEN
19379                K=K+1
19380                ZY1(K)=Y1(I)
19381                ZY2(K)=Y2(I)
19382              ENDIF
19383 1130       CONTINUE
19384            NTEMP=K
19385            NCURVE=NCURVE+1
19386            IF(NTEMP.GT.0)THEN
19387              CALL DPCOR2(ZY1,ZY2,NTEMP,NCURVE,ICASPL,NUMLAG,MAXN,
19388     1                    IAUTCP,IAUTL0,TEMP1,TEMP2,
19389     1                    Y,X,D,TOP,BOTTOM,PCC,NPLOTP,NPLOTV,
19390     1                    IBUGG3,ISUBRO,IERROR)
19391            ENDIF
19392 1110     CONTINUE
19393        ELSEIF(NREPL.EQ.2)THEN
19394          J=0
19395          NTOT=NUMSE1*NUMSE2
19396          DO1210ISET1=1,NUMSE1
19397          DO1220ISET2=1,NUMSE2
19398            K=0
19399            DO1290I=1,NLOCAL
19400              IF(
19401     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
19402     1           XIDTE2(ISET2).EQ.XDESGN(I,2)
19403     1          )THEN
19404                K=K+1
19405                ZY1(K)=Y1(I)
19406                ZY2(K)=Y2(I)
19407              ENDIF
19408 1290       CONTINUE
19409            NTEMP=K
19410            NCURVE=NCURVE+1
19411            IF(NTEMP.GT.0)THEN
19412              CALL DPCOR2(ZY1,ZY2,NTEMP,NCURVE,ICASPL,NUMLAG,MAXN,
19413     1                    IAUTCP,IAUTL0,TEMP1,TEMP2,
19414     1                    Y,X,D,TOP,BOTTOM,PCC,NPLOTP,NPLOTV,
19415     1                    IBUGG3,ISUBRO,IERROR)
19416            ENDIF
19417 1220     CONTINUE
19418 1210     CONTINUE
19419        ENDIF
19420      ENDIF
19421C
19422C               *****************
19423C               **  STEP 90--  **
19424C               **  EXIT       **
19425C               *****************
19426C
19427 9000 CONTINUE
19428      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'CORR')THEN
19429        WRITE(ICOUT,999)
19430        CALL DPWRST('XXX','BUG ')
19431        WRITE(ICOUT,9011)
19432 9011   FORMAT('***** AT THE END       OF DPCORR--')
19433        CALL DPWRST('XXX','BUG ')
19434        WRITE(ICOUT,9012)IFOUND,IERROR,NUMLAG,MAXN
19435 9012   FORMAT('IFOUND,IERROR,NUMLAG,MAXN = ',2(A4,2X),2I8)
19436        CALL DPWRST('XXX','BUG ')
19437        WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
19438 9013   FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',3I8,3(2X,A4))
19439        CALL DPWRST('XXX','BUG ')
19440        IF(NPLOTP.LE.0)THEN
19441          DO9015I=1,NPLOTP
19442            WRITE(ICOUT,9016)I,Y(I),X(I),D(I)
19443 9016       FORMAT('I,Y(I),X(I),D(I) = ',I8,3G15.7)
19444            CALL DPWRST('XXX','BUG ')
19445 9015     CONTINUE
19446        ENDIF
19447      ENDIF
19448C
19449      RETURN
19450      END
19451      SUBROUTINE DPCPU(ICOM,IHARG,IHARG2,IARGT,IARG,ARG,NUMARG,
19452     1                 ATIME,
19453     1                 IBUGS2,ISUBRO,IFOUND,IERROR)
19454C
19455C     PURPOSE--RETURN THE AMOUNT OF CPU TIME CURRENTLY USED AND SAVE
19456C              IN THE INTERNAL PARAMETER   CPUTIME  .
19457C              THERE IS A FORTRAN 90 STANDARD, BUT NOT A FORTRAN 77
19458C              STANDARD, SO CALL DPCPUT (IN THE DP1.FOR
19459C              MACHINE DEPENDENT CODE FILE).
19460C     WRITTEN BY--ALAN HECKERT
19461C                 STATISTICAL ENGINEERING DIVISION
19462C                 STATISTICAL ENGINEEERING DIVISION
19463C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
19464C                 GAITHERSBURG, MD 20899-8980
19465C                 PHONE--301-975-2899
19466C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
19467C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
19468C     LANGUAGE--ANSI FORTRAN (1977)
19469C     VERSION NUMBER--2009.5
19470C     ORIGINAL VERSION--MAY        2009.
19471C
19472C-----NON-COMMON VARIABLES (GRAPHICS)---------------------------------
19473C
19474      CHARACTER*4 ICOM
19475      CHARACTER*4 IHARG
19476      CHARACTER*4 IHARG2
19477      CHARACTER*4 IARGT
19478C
19479      CHARACTER*4 IBUGS2
19480      CHARACTER*4 ISUBRO
19481      CHARACTER*4 IFOUND
19482      CHARACTER*4 IERROR
19483C
19484      DIMENSION IHARG(*)
19485      DIMENSION IHARG2(*)
19486      DIMENSION IARG(*)
19487      DIMENSION ARG(*)
19488      DIMENSION IARGT(*)
19489C
19490C-----COMMON VARIABLES (GENERAL)--------------------------------------
19491C
19492      INCLUDE 'DPCOP2.INC'
19493C
19494C-----START POINT-----------------------------------------------------
19495C
19496      IFOUND='NO'
19497      IERROR='NO'
19498C
19499      J2=0
19500C
19501      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'PCPU')THEN
19502        WRITE(ICOUT,999)
19503  999   FORMAT(1X)
19504        CALL DPWRST('XXX','BUG ')
19505        WRITE(ICOUT,51)
19506   51   FORMAT('***** AT THE BEGINNING OF DPCPU--')
19507        CALL DPWRST('XXX','BUG ')
19508        WRITE(ICOUT,81)IBUGS2,ISUBRO,IFOUND,IERROR
19509   81   FORMAT('IBUGS2,ISUBRO,IFOUND,IERROR = ',3(A4,2X),A4)
19510        CALL DPWRST('XXX','BUG ')
19511        DO85I=1,NUMARG
19512          WRITE(ICOUT,87)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I)
19513   87     FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) = ',
19514     1           I8,2X,3(A4,2X),I8,G15.7)
19515          CALL DPWRST('XXX','BUG ')
19516   85   CONTINUE
19517      ENDIF
19518C
19519C               *****************************************************
19520C               **  STEP 1--                                       **
19521C               **  CHECK FOR THE COMMAND                          **
19522C               *****************************************************
19523C
19524      IF(ICOM.EQ.'CPU ')THEN
19525        IFOUND='YES'
19526        CALL DPCPUT(ATIME,IBUGS2,ISUBRO,IFOUND,IERROR)
19527C
19528        IF(IFEEDB.EQ.'ON')THEN
19529          WRITE(ICOUT,1001)ATIME
19530 1001     FORMAT('THE CURRENT CPU USAGE IS ',G15.7)
19531          CALL DPWRST('XXX','BUG ')
19532        ENDIF
19533C
19534      ENDIF
19535C
19536C               *****************
19537C               **  STEP 90--  **
19538C               **  EXIT       **
19539C               *****************
19540C
19541      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'PCPU')THEN
19542        WRITE(ICOUT,999)
19543        CALL DPWRST('XXX','BUG ')
19544        WRITE(ICOUT,9011)
19545 9011   FORMAT('***** AT THE END       OF DPCPU--')
19546        CALL DPWRST('XXX','BUG ')
19547        WRITE(ICOUT,9031)IBUGS2,ISUBRO
19548 9031   FORMAT('IBUGS2,ISUBRO = ',A4,2X,A4)
19549        CALL DPWRST('XXX','BUG ')
19550        WRITE(ICOUT,9032)IFOUND,IERROR
19551 9032   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
19552        CALL DPWRST('XXX','BUG ')
19553        WRITE(ICOUT,9033)ATIME
19554 9033   FORMAT('ATIME = ',G15.7)
19555        CALL DPWRST('XXX','BUG ')
19556      ENDIF
19557C
19558      RETURN
19559      END
19560      SUBROUTINE DPCQD3(Y,N,ICASA2,ICASA4,ISEED,MAXNXT,IQUAME,
19561     1                  TEMP1,ALPHA,NALPHA,ALOWLM,AUPPLM,
19562     1                  CQV,Q1,Q3,
19563     1                  ISUBRO,IBUGA3,IERROR)
19564C
19565C     PURPOSE--THIS SUBROUTINE COMPUTES CONFIDENCE LIMITS FOR THE
19566C              COEFFIENT OF QUARTILE DISPERSION.  THE COEFFICIENT OF
19567C              QUARTILE DISPERSION IS AN ALTERNATIVE TO THE COEFFICIENT
19568C              OF VARIATION FOR NON-NORMAL DATA.  IT IS PARTICULARLY
19569C              RECOMMENDED FOR HIGHLY SKEWED OR HIGHLY NON-NORMAL DATA
19570C              (FOR MODERATELY NON-NORMAL DATA, THE COEFFICIENT OF
19571C              DISPERSION IS RECOMMENDED).
19572C
19573C              THE FOLLOWING CASES ARE SUPPORTED:
19574C
19575C                 LET A = LOWER COEFFICIENT OF QUARTILE DISPERSION CONFIDENCE LIMIT Y
19576C                 LET A = UPPER COEFFICIENT OF QUARTILE DISPERSION CONFIDENCE LIMIT Y
19577C
19578C              THE DATA CONSISTS OF N OBSERVATIONS IN Y.
19579C
19580C              THIS ALGORITHM IS FROM THE BONETT PAPER.
19581C
19582C              THE COEFFICIENT OF QUARTILE DISPERSION IS DEFINED AS:
19583C
19584C                  CQV = (Q3 - Q1)/(Q3 - Q1)
19585C
19586C              WHERE Q1 AND Q3 ARE THE 25-TH AND 75-TH PERCENTILES OF
19587C              THE DATA, RESPECTIVELY.
19588C
19589C     INPUT ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR OF
19590C                               (UNSORTED OR SORTED) OBSERVATIONS.
19591C                    --N      = THE INTEGER NUMBER OF OBSERVATIONS
19592C                               IN THE VECTOR Y.
19593C                    --ALPHA  = THE SINGLE PRECISION VECTOR OF CONFIDENCE
19594C                               LEVELS
19595C                      NALPHA = THE INTEGER NUMBER OF ALPHA VALUES
19596C     OUTPUT ARGUMENTS-ALOWLM = THE SINGLE PRECISION VECTOR OF LOWER
19597C                               CONFIDENCE LIMIT VALUES
19598C                     -AUPPLM = THE SINGLE PRECISION VECTOR OF UPPER
19599C                               CONFIDENCE LIMIT VALUES
19600C     OTHER DATAPAC   SUBROUTINES NEEDED--MEDIAN, MEAN, VAR, AAD, SORT.
19601C     FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT.
19602C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
19603C     LANGUAGE--ANSI FORTRAN.
19604C     REFERENCES--BONETT (2006), "CONFIDENCE INTERVAL FOR A
19605C                 COEFFICIENT OF QUARTILE VARIATIOIN", COMPUTATIONAL
19606C                 STATISTICS AND DATA ANALYSIS, VOL. 50, PP. 2953-2957.
19607C     WRITTEN BY--ALAN HECKERT
19608C                 STATISTICAL ENGINEERING LABORATORY
19609C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
19610C                 GAITHERSBURG, MD 20899-8980
19611C                 PHONE--301-975-2899
19612C     ORIGINAL VERSION--DECEMBER  2017.
19613C
19614C---------------------------------------------------------------------
19615C
19616      DIMENSION Y(*)
19617      DIMENSION TEMP1(*)
19618      DIMENSION ALOWLM(*)
19619      DIMENSION AUPPLM(*)
19620      DIMENSION ALPHA(*)
19621C
19622      CHARACTER*4 ICASA2
19623      CHARACTER*4 ICASA4
19624      CHARACTER*4 IQUAME
19625      CHARACTER*4 ISUBRO
19626      CHARACTER*4 IBUGA3
19627      CHARACTER*4 IERROR
19628C
19629      CHARACTER*4 IWRITE
19630      CHARACTER*4 ISUBN1
19631      CHARACTER*4 ISUBN2
19632      CHARACTER*4 ISTEPN
19633C
19634      INCLUDE 'DPCOP2.INC'
19635C
19636C-----START POINT-----------------------------------------------------
19637C
19638      ISUBN1='CQD3'
19639      ISUBN2='    '
19640      IWRITE='OFF'
19641      IERROR='NO'
19642C
19643      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CQD3')THEN
19644        WRITE(ICOUT,999)
19645  999   FORMAT(1X)
19646        CALL DPWRST('XXX','WRIT')
19647        WRITE(ICOUT,51)
19648   51   FORMAT('**** AT THE BEGINNING OF DPCQD3--')
19649        CALL DPWRST('XXX','WRIT')
19650        WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASA2,ICASA4
19651   52   FORMAT('IBUGA3,ISUBRO,ICASA2,ICASA4 = ',3(A4,2X),A4)
19652        CALL DPWRST('XXX','WRIT')
19653        WRITE(ICOUT,53)N,NALPHA,ISEED,ALPHA(1)
19654   53   FORMAT('N,NALPHA,ISEED,ALPHA(1) = ',3I8,G15.7)
19655        CALL DPWRST('XXX','WRIT')
19656        DO56I=1,N
19657          WRITE(ICOUT,57)I,Y(I)
19658   57     FORMAT('I,Y(I) = ',I8,G15.7)
19659          CALL DPWRST('XXX','WRIT')
19660   56   CONTINUE
19661        DO76I=1,NALPHA
19662          WRITE(ICOUT,77)I,ALPHA(I)
19663   77     FORMAT('I,ALPHA(I) = ',I8,G15.7)
19664          CALL DPWRST('XXX','WRIT')
19665   76   CONTINUE
19666      ENDIF
19667C
19668C               ********************************************
19669C               **  STEP 11--                             **
19670C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
19671C               ********************************************
19672C
19673      ISTEPN='11'
19674      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CQD3')
19675     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19676C
19677      DO110I=1,NALPHA
19678        ALOWLM(I)=CPUMIN
19679        AUPPLM(I)=CPUMIN
19680  110 CONTINUE
19681C
19682      IF(N.LT.5)THEN
19683        WRITE(ICOUT,999)
19684        CALL DPWRST('XXX','WRIT')
19685        WRITE(ICOUT,101)
19686  101   FORMAT('***** ERROR: COEFFICIENT OF QUARTILE DISPERSION ',
19687     1         'CONFIDENCE LIMITS--')
19688        CALL DPWRST('XXX','WRIT')
19689        WRITE(ICOUT,102)
19690  102   FORMAT('      THE NUMBER OF ORIGINAL OBSERVATIONS  IS LESS ',
19691     1         'THAN FIVE.')
19692        CALL DPWRST('XXX','WRIT')
19693        WRITE(ICOUT,103)N
19694  103   FORMAT('      SAMPLE SIZE = ',I8)
19695        CALL DPWRST('XXX','WRIT')
19696        IERROR='YES'
19697        GOTO9000
19698      ENDIF
19699C
19700C               ********************************************
19701C               **  STEP 21--                             **
19702C               **  CARRY OUT CALCULATIONS FOR CONFIDENCE **
19703C               **  LIMITS.                               **
19704C               ********************************************
19705C
19706      ISTEPN='21'
19707      IF(IBUGA3.EQ.'ON'.AND.ISUBRO.EQ.'CQD3')
19708     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19709C
19710C     ICASA2:  LOWE     => LOWER LIMIT
19711C              UPPE     => UPPER LIMIT
19712C     ICASA4:  ONES     => ONE-SIDED LIMIT
19713C              TWOS     => TWO-SIDED LIMIT
19714C
19715C     COMPUTE LOWER AND UPPER QUARTILES
19716C
19717      AN=REAL(N)
19718      CALL SORT(Y,N,Y)
19719      QNT=0.25
19720      CALL QUANT(QNT,Y,N,IWRITE,TEMP1,MAXNXT,IQUAME,Q1,IBUGA3,IERROR)
19721      QNT=0.75
19722      CALL QUANT(QNT,Y,N,IWRITE,TEMP1,MAXNXT,IQUAME,Q3,IBUGA3,IERROR)
19723C
19724      D=Q3 - Q1
19725      S=Q3 + Q1
19726C
19727      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CQD3')THEN
19728        WRITE(ICOUT,201)Q1,Q3,D,S
19729  201   FORMAT('Q1,Q3,D,S = ',4G15.7)
19730        CALL DPWRST('XXX','WRIT')
19731      ENDIF
19732C
19733      IF(S.LE.0.0)THEN
19734        WRITE(ICOUT,999)
19735        CALL DPWRST('XXX','WRIT')
19736        WRITE(ICOUT,101)
19737        CALL DPWRST('XXX','WRIT')
19738        WRITE(ICOUT,207)
19739  207   FORMAT('      THE DIFFERENCE BETWEEN THE UPPER AND LOWER ',
19740     1         'QUARTILES IS ZERO.')
19741        CALL DPWRST('XXX','WRIT')
19742        WRITE(ICOUT,209)
19743  209   FORMAT('      THE COEFFICIENT OF QUARTILE DISPERSION ',
19744     1         'CONFIDENCE LIMIT IS NOT COMPUTED IN THIS CASE.')
19745        CALL DPWRST('XXX','WRIT')
19746        IERROR='YES'
19747        GOTO9000
19748      ENDIF
19749C
19750      CQV=D/S
19751C
19752      TERM1=AN/4.0
19753      TERM2=SQRT(3.0*AN/16.0)
19754      TERM3=1.0/(16.0*AN)
19755C
19756      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CQD3')THEN
19757        WRITE(ICOUT,223)CQV,TERM1,TERM2,TERM3
19758  223   FORMAT('CQV,TERM1,TERM2,TERM3 = ',4G15.7)
19759        CALL DPWRST('XXX','WRIT')
19760      ENDIF
19761C
19762      DO300I=1,NALPHA
19763C
19764C       GET NORMAL CRITICAL VALUE
19765C
19766        ALP=ALPHA(I)
19767        IF(ALP.GE.1.0 .AND. ALP.LE.100.)ALP=ALP/100.
19768        IF(ALP.LE.0.0 .OR. ALP.GE.1.0)THEN
19769          IF(ICASA4.EQ.'ONES')THEN
19770            Z=1.645
19771          ELSE
19772            Z=1.96
19773          ENDIF
19774        ELSE
19775          IF(ALP.LT.0.5)THEN
19776            ALP=1.0-ALP
19777          ENDIF
19778          ALP=1.0 - ALP
19779          IF(ICASA4.EQ.'ONES')THEN
19780            P1=ALP
19781            P2=1.0-ALP
19782            CALL NORPPF(P2,Z)
19783          ELSE
19784            P1=ALP/2.0
19785            P2=1.0-(ALP/2.0)
19786            CALL NORPPF(P2,Z)
19787          ENDIF
19788        ENDIF
19789C
19790C       FIND IA, IB, IC, AND ID
19791C
19792C       ROUND IA AND IB UP TO NEAREST INTEGER
19793C
19794        A=TERM1 - Z*TERM2
19795        IA=INT(A+0.999)
19796        IF(IA.LE.0)IA=1
19797        B=TERM1 + Z*TERM2
19798        IB=INT(B+0.999)
19799        IF(IB.GE.N)IB=N
19800        IC=N+1-IB
19801        ID=N+1-IA
19802C
19803        IF(N.LE.100)THEN
19804          PTEMP=0.25
19805          CALL BINCDF(DBLE(IB-1),DBLE(PTEMP),N,DCDF1)
19806          CALL BINCDF(DBLE(IA-1),DBLE(PTEMP),N,DCDF2)
19807          ALPSTR=DCDF1 - DCDF2
19808          P9=(1.0 - ALPSTR)/2.0
19809          CALL NORPPF(P9,Z2)
19810          Z2=-Z2
19811        ELSE
19812          P9=0.975
19813          Z2=Z
19814        ENDIF
19815C
19816        F1SQ=3.0*Z2**2/(4.0*AN*(Y(IB) - Y(IA))**2)
19817        F3SQ=3.0*Z2**2/(4.0*AN*(Y(ID) - Y(IC))**2)
19818        F1=SQRT(F1SQ)
19819        F3=SQRT(F3SQ)
19820C
19821        TERM4=(3.0/F1SQ) + (3.0/F3SQ) - (2.0/(F1*F3))
19822        TERM4B=(3.0/F1SQ) + (3.0/F3SQ) + (2.0/(F1*F3))
19823        TERM5=2.0*((3.0/F3SQ) - (3.0/F1SQ))
19824        TERM6=(TERM4/D**2) + (TERM4B/S**2) - (TERM5/(D*S))
19825        V=TERM3*TERM6
19826        CENT=AN/(AN-1.0)
19827C
19828        ALOWLM(I)=EXP(LOG(D/S)*CENT - Z*SQRT(V))
19829        AUPPLM(I)=EXP(LOG(D/S)*CENT + Z*SQRT(V))
19830C
19831        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CQD3')THEN
19832          WRITE(ICOUT,311)I,IA,IB,IC,ID,Z
19833  311     FORMAT('I,IA,IB,IC,ID,Z = ',5I8,G15.7)
19834          CALL DPWRST('XXX','WRIT')
19835          WRITE(ICOUT,312)ALPSTR,P9,Z2
19836  312     FORMAT('ALPSTR,P9,Z2 = ',3G15.7)
19837          CALL DPWRST('XXX','WRIT')
19838          WRITE(ICOUT,313)F1SQ,F3SQ,F1,F3,TERM4,TERM5,TERM6
19839  313     FORMAT('F1SQ,F3SQ,F1,F3,TERM4,TERM5,TERM6 = ',7G15.7)
19840          CALL DPWRST('XXX','WRIT')
19841          WRITE(ICOUT,315)V,ALOWLM(I),AUPPLM(I)
19842  315     FORMAT('V,ALOWLM(I),AUPPLM(I) = ',3G15.7)
19843          CALL DPWRST('XXX','WRIT')
19844        ENDIF
19845C
19846  300 CONTINUE
19847C
19848 9000 CONTINUE
19849      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CQD3')THEN
19850        WRITE(ICOUT,999)
19851        CALL DPWRST('XXX','WRIT')
19852        WRITE(ICOUT,9051)
19853 9051   FORMAT('**** AT THE END OF DPCQD3--')
19854        CALL DPWRST('XXX','WRIT')
19855      ENDIF
19856C
19857      RETURN
19858      END
19859      SUBROUTINE DPCR(IHARG,NUMARG,
19860     1IDEFCR,
19861     1ITEXCR,
19862     1IBUGD2,ISUBRO,IFOUND,IERROR)
19863C
19864C     PURPOSE--DEFINE THE CARRIAGE RETURN SWITCH (ON OR OFF) FOR
19865C              TEXT SCRIPT.
19866C              THE CARRIAGE RETURN SWITCH WILL BE PLACED
19867C              IN THE CHARACTER VARIABLE ITEXCR.
19868C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
19869C                     --NUMARG
19870C                     --IDEFCR
19871C                     --IBUGD2
19872C     OUTPUT ARGUMENTS--ITEXCR
19873C                     --IFOUND ('YES' OR 'NO' )
19874C                     --IERROR ('YES' OR 'NO' )
19875C     WRITTEN BY--JAMES J. FILLIBEN
19876C                 STATISTICAL ENGINEERING DIVISION
19877C                 INFORMATION TECHNOLOGY LABORATORY
19878C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
19879C                 GAITHERSBURG, MD 20899-8980
19880C                 PHONE--301-975-2855
19881C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
19882C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
19883C     LANGUAGE--ANSI FORTRAN (1977)
19884C     VERSION NUMBER--82/7
19885C     ORIGINAL VERSION--APRIL     1981.
19886C     UPDATED         --MAY       1982.
19887C
19888C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
19889C
19890      CHARACTER*4 IHARG
19891      CHARACTER*4 IDEFCR
19892      CHARACTER*4 ITEXCR
19893      CHARACTER*4 IBUGD2
19894      CHARACTER*4 ISUBRO
19895      CHARACTER*4 IFOUND
19896      CHARACTER*4 IERROR
19897C
19898C---------------------------------------------------------------------
19899C
19900      DIMENSION IHARG(*)
19901C
19902C---------------------------------------------------------------------
19903C
19904      INCLUDE 'DPCOP2.INC'
19905C
19906C-----START POINT-----------------------------------------------------
19907C
19908      IFOUND='NO'
19909      IERROR='NO'
19910C
19911      IF(IBUGD2.EQ.'OFF')GOTO90
19912      WRITE(ICOUT,999)
19913  999 FORMAT(1X)
19914      CALL DPWRST('XXX','BUG ')
19915      WRITE(ICOUT,51)
19916   51 FORMAT('***** AT THE BEGINNING OF DPCR--')
19917      CALL DPWRST('XXX','BUG ')
19918      WRITE(ICOUT,53)IDEFCR
19919   53 FORMAT('IDEFCR = ',A4)
19920      CALL DPWRST('XXX','BUG ')
19921      WRITE(ICOUT,54)NUMARG
19922   54 FORMAT('NUMARG = ',I8)
19923      CALL DPWRST('XXX','BUG ')
19924      DO55I=1,NUMARG
19925      WRITE(ICOUT,56)I,IHARG(I)
19926   56 FORMAT('I,IHARG(I) = ',I8,2X,A4)
19927      CALL DPWRST('XXX','BUG ')
19928   55 CONTINUE
19929   90 CONTINUE
19930C
19931C               **************************************
19932C               **  TREAT THE CARRIAGE RETURN CASE  **
19933C               **************************************
19934C
19935      IF(NUMARG.LE.0)GOTO1161
19936      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'RETU')GOTO1161
19937      IF(IHARG(NUMARG).EQ.'ON')GOTO1161
19938      IF(IHARG(NUMARG).EQ.'OFF')GOTO1162
19939      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1161
19940      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1165
19941      GOTO1170
19942C
19943 1161 CONTINUE
19944      ITEXCR='ON'
19945      GOTO1180
19946C
19947 1162 CONTINUE
19948      ITEXCR='OFF'
19949      GOTO1180
19950C
19951 1165 CONTINUE
19952      ITEXCR=IDEFCR
19953      GOTO1180
19954C
19955 1170 CONTINUE
19956      IERROR='YES'
19957      WRITE(ICOUT,1171)
19958 1171 FORMAT('***** ERROR IN DPCR--')
19959      CALL DPWRST('XXX','BUG ')
19960      WRITE(ICOUT,1172)
19961 1172 FORMAT('      ILLEGAL ENTRY FOR CARRIAGE RETURN ',
19962     1'COMMAND.')
19963      CALL DPWRST('XXX','BUG ')
19964      WRITE(ICOUT,1173)
19965 1173 FORMAT('      TEST EXAMPLE TO DEMONSTRATE THE ',
19966     1'PROPER FORM--')
19967      CALL DPWRST('XXX','BUG ')
19968      WRITE(ICOUT,1174)
19969 1174 FORMAT('      SUPPOSE THE THE ANALYST WISHES ')
19970      CALL DPWRST('XXX','BUG ')
19971      WRITE(ICOUT,1175)
19972 1175 FORMAT('      TO HAVE A CARRIAGE RETURN AFTER THE TEXT ',
19973     1'COMMAND,')
19974      CALL DPWRST('XXX','BUG ')
19975      WRITE(ICOUT,1177)
19976 1177 FORMAT('      THEN ALLOWABLE FORMS ARE--')
19977      CALL DPWRST('XXX','BUG ')
19978      WRITE(ICOUT,1178)
19979 1178 FORMAT('           CARRIAGE RETURN ON     (OR   CR ON) ')
19980      CALL DPWRST('XXX','BUG ')
19981      WRITE(ICOUT,1179)
19982 1179 FORMAT('           CARRIAGE RETURN        (OR   CR) ')
19983      CALL DPWRST('XXX','BUG ')
19984      GOTO9000
19985C
19986 1180 CONTINUE
19987      IFOUND='YES'
19988C
19989      IF(IFEEDB.EQ.'OFF')GOTO1189
19990      WRITE(ICOUT,999)
19991      CALL DPWRST('XXX','BUG ')
19992      WRITE(ICOUT,1181)
19993 1181 FORMAT('THE CARRIAGE RETURN (AFTER TEXT) ')
19994      CALL DPWRST('XXX','BUG ')
19995      WRITE(ICOUT,1182)ITEXCR
19996 1182 FORMAT('HAS JUST BEEN SET TO ',A4)
19997      CALL DPWRST('XXX','BUG ')
19998 1189 CONTINUE
19999      GOTO9000
20000C
20001C               *****************
20002C               **  STEP 90--  **
20003C               **  EXIT       **
20004C               *****************
20005C
20006 9000 CONTINUE
20007      IF(IBUGD2.EQ.'OFF')GOTO9090
20008      WRITE(ICOUT,999)
20009      CALL DPWRST('XXX','BUG ')
20010      WRITE(ICOUT,9011)
20011 9011 FORMAT('***** AT THE END       OF DPCR')
20012      CALL DPWRST('XXX','BUG ')
20013      WRITE(ICOUT,9012)IBUGD2,ISUBRO,IFOUND,IERROR
20014 9012 FORMAT('IBUGD2,ISUBRO,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
20015      CALL DPWRST('XXX','BUG ')
20016      WRITE(ICOUT,9013)IDEFCR,ITEXCR
20017 9013 FORMAT('IDEFCR,ITEXCR = ',A4,2X,A4)
20018      CALL DPWRST('XXX','BUG ')
20019 9090 CONTINUE
20020C
20021      RETURN
20022      END
20023      SUBROUTINE DPCRCI(MAXNXT,ICAPSW,IFORSW,
20024     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
20025C
20026C     PURPOSE--GENERATE CONFIDENCE LIMITS FOR THE CORRELATION
20027C              COEFFICIENT
20028C     EXAMPLE--CORRELATION CONFIDENCE LIMTIS Y1 Y2
20029C     WRITTEN BY--ALAN HECKERT
20030C                 STATISTICAL ENGINEERING DIVISION
20031C                 INFORMATION TECHNOLOGY LABORATORY
20032C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
20033C                 GAITHERSBURG, MD 20899-8980
20034C                 PHONE--301-975-2899
20035C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
20036C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
20037C     LANGUAGE--ANSI FORTRAN (1977)
20038C     VERSION NUMBER--2012/6
20039C     ORIGINAL VERSION--JUNE      2012.
20040C
20041C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
20042C
20043      CHARACTER*4 ICAPSW
20044      CHARACTER*4 IFORSW
20045      CHARACTER*4 IBUGA2
20046      CHARACTER*4 IBUGA3
20047      CHARACTER*4 IBUGQ
20048      CHARACTER*4 ISUBRO
20049      CHARACTER*4 IFOUND
20050      CHARACTER*4 IERROR
20051C
20052      CHARACTER*4 ISUBN1
20053      CHARACTER*4 ISUBN2
20054      CHARACTER*4 ISTEPN
20055C
20056      CHARACTER*4 ICASE
20057      CHARACTER*4 IVARID
20058      CHARACTER*4 IVARI2
20059      CHARACTER*4 IVARI3
20060      CHARACTER*4 IVARI4
20061      CHARACTER*40 INAME
20062      PARAMETER (MAXSPN=30)
20063      CHARACTER*4 IVARN1(MAXSPN)
20064      CHARACTER*4 IVARN2(MAXSPN)
20065      CHARACTER*4 IVARTY(MAXSPN)
20066      REAL PVAR(MAXSPN)
20067      INTEGER ILIS(MAXSPN)
20068      INTEGER NRIGHT(MAXSPN)
20069      INTEGER ICOLR(MAXSPN)
20070C
20071      CHARACTER*4 IFLAGU
20072      LOGICAL IFRST
20073      LOGICAL ILAST
20074C
20075C-----COMMON----------------------------------------------------------
20076C
20077      INCLUDE 'DPCOPA.INC'
20078      INCLUDE 'DPCOHK.INC'
20079      INCLUDE 'DPCOSU.INC'
20080      INCLUDE 'DPCODA.INC'
20081      INCLUDE 'DPCOST.INC'
20082C
20083C-----COMMON VARIABLES (GENERAL)--------------------------------------
20084C
20085      INCLUDE 'DPCOP2.INC'
20086C
20087C-----START POINT-----------------------------------------------------
20088C
20089      ISUBN1='DPCR'
20090      ISUBN2='CI  '
20091C
20092      MAXCP1=MAXCOL+1
20093      MAXCP2=MAXCOL+2
20094      MAXCP3=MAXCOL+3
20095      MAXCP4=MAXCOL+4
20096      MAXCP5=MAXCOL+5
20097      MAXCP6=MAXCOL+6
20098C
20099      IFOUND='YES'
20100      IERROR='NO'
20101C
20102C               *******************************************************
20103C               **  TREAT THE CORRELATION CONFIDENCE LIMITS CASE     **
20104C               *******************************************************
20105C
20106      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CRCI')THEN
20107        WRITE(ICOUT,999)
20108  999   FORMAT(1X)
20109        CALL DPWRST('XXX','BUG ')
20110        WRITE(ICOUT,51)
20111   51   FORMAT('***** AT THE BEGINNING OF DPCRCI--')
20112        CALL DPWRST('XXX','BUG ')
20113        WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ,ISUBRO,MAXNXT
20114   52   FORMAT('IBUGA2,IBUGA3,IBUGQ,ISUBRO,MAXNXT = ',4(A4,2X),I8)
20115        CALL DPWRST('XXX','BUG ')
20116      ENDIF
20117C
20118C               ****************************************
20119C               **  STEP 2--                          **
20120C               **  EXTRACT THE VARIABLE LIST         **
20121C               ****************************************
20122C
20123      ISTEPN='2'
20124      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CRCI')
20125     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20126C
20127      INAME='CORRELATION CONFIDENCE LIMITS'
20128      MINNA=1
20129      MAXNA=100
20130      MINN2=4
20131      IFLAGE=1
20132      IFLAGM=1
20133      MINNVA=2
20134      MAXNVA=MAXSPN
20135      IFLAGP=0
20136      JMIN=1
20137      JMAX=NUMARG
20138C
20139      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
20140     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
20141     1            JMIN,JMAX,
20142     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
20143     1            IVARN1,IVARN2,IVARTY,PVAR,
20144     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
20145     1            MINNVA,MAXNVA,
20146     1            IFLAGM,IFLAGP,
20147     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
20148      IF(IERROR.EQ.'YES')GOTO9000
20149C
20150      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CRCI')THEN
20151        WRITE(ICOUT,999)
20152        CALL DPWRST('XXX','BUG ')
20153        WRITE(ICOUT,281)
20154  281   FORMAT('***** AFTER CALL DPPARS--')
20155        CALL DPWRST('XXX','BUG ')
20156        WRITE(ICOUT,282)NQ,NUMVAR
20157  282   FORMAT('NQ,NUMVAR = ',2I8)
20158        CALL DPWRST('XXX','BUG ')
20159        IF(NUMVAR.GT.0)THEN
20160          DO285I=1,NUMVAR
20161            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
20162     1                      ICOLR(I)
20163  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
20164     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
20165            CALL DPWRST('XXX','BUG ')
20166  285     CONTINUE
20167        ENDIF
20168      ENDIF
20169C
20170C               *****************************************
20171C               **  STEP 3A--                          **
20172C               **  CASE 1: TWO RESPONSE VARIABLES     **
20173C               **          WITH NO REPLICATION        **
20174C               *****************************************
20175C
20176      ISTEPN='3A'
20177      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CRCI')
20178     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20179C
20180      NUMVA2=1
20181      DO5210I=1,NUMVAR
20182        DO5220J=I+1,NUMVAR
20183          ICOL=I
20184          CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
20185     1                INAME,IVARN1,IVARN2,IVARTY,
20186     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
20187     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
20188     1                MAXCP4,MAXCP5,MAXCP6,
20189     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
20190     1                Y,Y,Y,NS1,NLOCA2,NLOCA3,ICASE,
20191     1                IBUGA3,ISUBRO,IFOUND,IERROR)
20192          IF(IERROR.EQ.'YES')GOTO9000
20193C
20194          ICOL=J
20195          CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
20196     1                INAME,IVARN1,IVARN2,IVARTY,
20197     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
20198     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
20199     1                MAXCP4,MAXCP5,MAXCP6,
20200     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
20201     1                X,X,X,NS1,NLOCA2,NLOCA3,ICASE,
20202     1                IBUGA3,ISUBRO,IFOUND,IERROR)
20203          IF(IERROR.EQ.'YES')GOTO9000
20204C
20205C               ***********************************************
20206C               **  STEP 52--                                **
20207C               **  GENERATE CORRELATION CONFIDENCE LIMITS   **
20208C               ***********************************************
20209C
20210          ISTEPN='52'
20211          IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CRCI')THEN
20212            CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20213            WRITE(ICOUT,999)
20214            CALL DPWRST('XXX','BUG ')
20215            WRITE(ICOUT,5211)
20216 5211       FORMAT('***** FROM DPCRCI, BEFORE CALL DPCRC2--')
20217            CALL DPWRST('XXX','BUG ')
20218            WRITE(ICOUT,5212)I,J,NS1,MAXN
20219 5212       FORMAT('I,J,NS1,MAXN = ',4I8)
20220            CALL DPWRST('XXX','BUG ')
20221            DO5215II=1,NS1
20222              WRITE(ICOUT,5216)II,Y(II),X(II)
20223 5216         FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
20224              CALL DPWRST('XXX','BUG ')
20225 5215       CONTINUE
20226          ENDIF
20227C
20228          IVARID=IVARN1(I)
20229          IVARI2=IVARN2(I)
20230          IVARI3=IVARN1(J)
20231          IVARI4=IVARN2(J)
20232          CALL DPCRC2(Y,X,NS1,
20233     1                ICAPSW,ICAPTY,IFORSW,
20234     1                IVARID,IVARI2,IVARI3,IVARI4,
20235     1                CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
20236     1                IBUGA3,ISUBRO,IERROR)
20237          IF(IERROR.EQ.'YES')GOTO9000
20238C
20239C               ***************************************
20240C               **  STEP 8C--                        **
20241C               **  UPDATE INTERNAL DATAPLOT TABLES  **
20242C               ***************************************
20243C
20244          ISTEPN='8C'
20245          IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CRCI')
20246     1      CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20247C
20248          IF(NUMVAR.GT.2)THEN
20249            IFLAGU='FILE'
20250          ELSE
20251            IFLAGU='ON'
20252          ENDIF
20253          IFRST=.FALSE.
20254          ILAST=.FALSE.
20255          IF(I.EQ.1 .AND. J.EQ.2)IFRST=.TRUE.
20256          IF(I.EQ.NUMVAR .AND. J.EQ.NUMVAR)ILAST=.TRUE.
20257          CALL DPCRC5(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
20258     1                IFLAGU,IFRST,ILAST,
20259     1                IBUGA2,IBUGA3,ISUBRO,IERROR)
20260C
20261 5220   CONTINUE
20262 5210 CONTINUE
20263C
20264C               *****************
20265C               **  STEP 90--  **
20266C               **  EXIT       **
20267C               *****************
20268C
20269 9000 CONTINUE
20270      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CRCI')THEN
20271        WRITE(ICOUT,999)
20272        CALL DPWRST('XXX','BUG ')
20273        WRITE(ICOUT,9011)
20274 9011   FORMAT('***** AT THE END       OF DPCRCI--')
20275        CALL DPWRST('XXX','BUG ')
20276        WRITE(ICOUT,9016)IFOUND,IERROR
20277 9016   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
20278        CALL DPWRST('XXX','BUG ')
20279      ENDIF
20280C
20281      RETURN
20282      END
20283      SUBROUTINE DPCRC2(Y1,Y2,N,
20284     1                  ICAPSW,ICAPTY,IFORSW,
20285     1                  IVARID,IVARI2,IVARI3,IVARI4,
20286     1                  CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
20287     1                  IBUGA3,ISUBRO,IERROR)
20288C
20289C     PURPOSE--THIS ROUTINE GENERATES A CONFIDENCE LIMITS FOR THE
20290C              CORRELATION COEFFICIENT BASED ON FISHER'S NORMAL
20291C              APPROXIMATION.
20292C
20293C                LCL = TANH(Z - NORPPF(1 - ALPHA/2)/SQRT(N-3))
20294C                UCL = TANH(Z + NORPPF(1 - ALPHA/2)/SQRT(N-3))
20295C
20296C              WHERE
20297C
20298C                Z = TANH**(-1)(R)
20299C                  = LOG[(1+R)/(1-R)]/2
20300C
20301C     EXAMPLE--CORRELATION COEFICIENT Y1 Y2
20302C              SAMPLE 1 IS IN INPUT VECTOR Y1 (WITH N OBSERVATIONS).
20303C              SAMPLE 2 IS IN INPUT VECTOR Y2 (WITH N OBSERVATIONS).
20304C     WRITTEN BY--ALAN HECKERT
20305C                 STATISTICAL ENGINEERING DIVISION
20306C                 INFORMATION TECHNOLOGY LABORATORY
20307C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
20308C                 GAITHERSBURG, MD 20899-8980
20309C                 PHONE--301-975-2899
20310C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
20311C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
20312C     LANGUAGE--ANSI FORTRAN (1977)
20313C     VERSION NUMBER--2012/6
20314C     ORIGINAL VERSION--JUNE      2012.
20315C
20316C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
20317C
20318      CHARACTER*4 ICAPSW
20319      CHARACTER*4 ICAPTY
20320      CHARACTER*4 IFORSW
20321      CHARACTER*4 IVARID
20322      CHARACTER*4 IVARI2
20323      CHARACTER*4 IVARI3
20324      CHARACTER*4 IVARI4
20325      CHARACTER*4 ICASA2
20326      CHARACTER*4 IBUGA3
20327      CHARACTER*4 ISUBRO
20328      CHARACTER*4 IERROR
20329C
20330      CHARACTER*4 IWRITE
20331C
20332      CHARACTER*4 ISUBN1
20333      CHARACTER*4 ISUBN2
20334      CHARACTER*4 ISTEPN
20335C
20336C---------------------------------------------------------------------
20337C
20338      DIMENSION Y1(*)
20339      DIMENSION Y2(*)
20340C
20341      PARAMETER (NUMALP=7)
20342      REAL ALPHA(NUMALP)
20343      REAL ALPHSV(NUMALP)
20344      REAL LOWLIM(NUMALP)
20345      REAL UPPLIM(NUMALP)
20346      REAL NORVAL(NUMALP)
20347C
20348      PARAMETER(NUMCLI=4)
20349      PARAMETER(MAXLIN=2)
20350      PARAMETER (MAXROW=20)
20351      CHARACTER*60 ITITLE
20352      CHARACTER*60 ITITLZ
20353      CHARACTER*60 ITEXT(MAXROW)
20354      REAL         AVALUE(MAXROW)
20355      INTEGER      NCTEXT(MAXROW)
20356      INTEGER      IDIGIT(MAXROW)
20357      INTEGER      NTOT(MAXROW)
20358      LOGICAL IFRST
20359      LOGICAL ILAST
20360C
20361C---------------------------------------------------------------------
20362C
20363      INCLUDE 'DPCOP2.INC'
20364C
20365      DATA ALPHA/0.50, 0.75, 0.80, 0.90, 0.95, 0.99, 0.999/
20366C
20367C-----START POINT-----------------------------------------------------
20368C
20369      ISUBN1='DPCR'
20370      ISUBN2='C2  '
20371      IERROR='NO'
20372C
20373      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CRC2')THEN
20374        WRITE(ICOUT,999)
20375  999   FORMAT(1X)
20376        CALL DPWRST('XXX','WRIT')
20377        WRITE(ICOUT,51)
20378   51   FORMAT('**** AT THE BEGINNING OF DPCRC2--')
20379        CALL DPWRST('XXX','WRIT')
20380        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
20381   52   FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8)
20382        CALL DPWRST('XXX','WRIT')
20383        DO56I=1,N
20384          WRITE(ICOUT,57)I,Y1(I),Y2(I)
20385   57     FORMAT('I,Y1(I),Y2(I) = ',I8,2G15.7)
20386          CALL DPWRST('XXX','WRIT')
20387   56   CONTINUE
20388      ENDIF
20389C
20390C               ******************************
20391C               **  STEP 1--                **
20392C               **  ERROR CHECK             **
20393C               ******************************
20394C
20395      IF(N.LT.4)THEN
20396        WRITE(ICOUT,999)
20397        CALL DPWRST('XXX','WRIT')
20398        WRITE(ICOUT,101)
20399  101   FORMAT('****** ERROR IN CORRELATION CONFIDENCE LIMITS--')
20400        CALL DPWRST('XXX','WRIT')
20401        WRITE(ICOUT,113)
20402  113   FORMAT('     THE NUMBER OF OBSERVATIONS IS LESS THAN FOUR.')
20403        CALL DPWRST('XXX','WRIT')
20404        WRITE(ICOUT,115)N
20405  115   FORMAT('     THE NUMBER OF OBSERVATIONS = ',I8)
20406        CALL DPWRST('XXX','WRIT')
20407        IERROR='YES'
20408        GOTO9000
20409      ENDIF
20410C
20411C
20412C               *****************************************
20413C               **  STEP 2--                           **
20414C               **  CARRY OUT CALCULATIONS             **
20415C               **  FOR CORRELATION CONFIDENCE LIMITS  **
20416C               *****************************************
20417C
20418      ISTEPN='2'
20419      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CRC2')
20420     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20421C
20422      IWRITE='OFF'
20423      CALL CORR(Y1,Y2,N,IWRITE,ACORR,IBUGA3,IERROR)
20424      IF(IERROR.EQ.'YES')GOTO9000
20425      CALL MEAN(Y1,N,IWRITE,YMEAN1,IBUGA3,IERROR)
20426      CALL SD(Y1,N,IWRITE,YSD1,IBUGA3,IERROR)
20427      CALL MEAN(Y2,N,IWRITE,YMEAN2,IBUGA3,IERROR)
20428      CALL SD(Y2,N,IWRITE,YSD2,IBUGA3,IERROR)
20429C
20430      DO200I=1,NUMALP
20431        ALPHT=ALPHA(I)
20432        CALL DPCRC3(ACORR,N,ALPHT,U,Z,
20433     1              ALOWLM,AUPPLM,
20434     1              IBUGA3,ISUBRO,IERROR)
20435        IF(IERROR.EQ.'YES')GOTO9000
20436        LOWLIM(I)=ALOWLM
20437        UPPLIM(I)=AUPPLM
20438        NORVAL(I)=U
20439  200 CONTINUE
20440C
20441      CUTL90=LOWLIM(5)
20442      CUTL95=LOWLIM(6)
20443      CUTL99=LOWLIM(7)
20444      CUTU90=UPPLIM(5)
20445      CUTU95=UPPLIM(6)
20446      CUTU99=UPPLIM(7)
20447C
20448C               ******************************
20449C               **   STEP 3-                **
20450C               **   WRITE OUT EVERYTHING   **
20451C               ******************************
20452C
20453      ISTEPN='3'
20454      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CRC2')
20455     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20456C
20457      IF(IPRINT.EQ.'OFF')GOTO9000
20458C
20459      NUMDIG=7
20460      IF(IFORSW.EQ.'1')NUMDIG=1
20461      IF(IFORSW.EQ.'2')NUMDIG=2
20462      IF(IFORSW.EQ.'3')NUMDIG=3
20463      IF(IFORSW.EQ.'4')NUMDIG=4
20464      IF(IFORSW.EQ.'5')NUMDIG=5
20465      IF(IFORSW.EQ.'6')NUMDIG=6
20466      IF(IFORSW.EQ.'7')NUMDIG=7
20467      IF(IFORSW.EQ.'8')NUMDIG=8
20468      IF(IFORSW.EQ.'9')NUMDIG=9
20469      IF(IFORSW.EQ.'0')NUMDIG=0
20470      IF(IFORSW.EQ.'E')NUMDIG=-2
20471      IF(IFORSW.EQ.'-2')NUMDIG=-2
20472      IF(IFORSW.EQ.'-3')NUMDIG=-3
20473      IF(IFORSW.EQ.'-4')NUMDIG=-4
20474      IF(IFORSW.EQ.'-5')NUMDIG=-5
20475      IF(IFORSW.EQ.'-6')NUMDIG=-6
20476      IF(IFORSW.EQ.'-7')NUMDIG=-7
20477      IF(IFORSW.EQ.'-8')NUMDIG=-8
20478      IF(IFORSW.EQ.'-9')NUMDIG=-9
20479C
20480      ITITLE='Confidence Limits for the Correlation Coefficient'
20481      NCTITL=49
20482      ITITLZ='(Based on Fisher Normal Approximation)'
20483      NCTITZ=38
20484C
20485      ICNT=1
20486      ITEXT(ICNT)=' '
20487      NCTEXT(ICNT)=0
20488      AVALUE(ICNT)=0.0
20489      IDIGIT(ICNT)=-1
20490      ICNT=ICNT+1
20491      ITEXT(ICNT)='Response Variable 1: '
20492      WRITE(ITEXT(ICNT)(22:25),'(A4)')IVARID(1:4)
20493      WRITE(ITEXT(ICNT)(26:29),'(A4)')IVARI2(1:4)
20494      NCTEXT(ICNT)=29
20495      AVALUE(ICNT)=0.0
20496      IDIGIT(ICNT)=-1
20497      ICNT=ICNT+1
20498      ITEXT(ICNT)='Response Variable 2: '
20499      WRITE(ITEXT(ICNT)(22:25),'(A4)')IVARI3(1:4)
20500      WRITE(ITEXT(ICNT)(26:29),'(A4)')IVARI4(1:4)
20501      NCTEXT(ICNT)=29
20502      AVALUE(ICNT)=0.0
20503      IDIGIT(ICNT)=-1
20504C
20505      ICNT=ICNT+1
20506      ITEXT(ICNT)=' '
20507      NCTEXT(ICNT)=1
20508      AVALUE(ICNT)=0.0
20509      IDIGIT(ICNT)=-1
20510C
20511      ICNT=ICNT+1
20512      ITEXT(ICNT)=' '
20513      NCTEXT(ICNT)=1
20514      AVALUE(ICNT)=0.0
20515      IDIGIT(ICNT)=-1
20516      ICNT=ICNT+1
20517      ITEXT(ICNT)='Summary Statistics for Variable 1:'
20518      NCTEXT(ICNT)=34
20519      AVALUE(ICNT)=0.0
20520      IDIGIT(ICNT)=-1
20521      ICNT=ICNT+1
20522      ITEXT(ICNT)='Number of Observations:'
20523      NCTEXT(ICNT)=23
20524      AVALUE(ICNT)=REAL(N)
20525      IDIGIT(ICNT)=0
20526      ICNT=ICNT+1
20527      ITEXT(ICNT)='Sample Mean:'
20528      NCTEXT(ICNT)=12
20529      AVALUE(ICNT)=YMEAN1
20530      IDIGIT(ICNT)=NUMDIG
20531      ICNT=ICNT+1
20532      ITEXT(ICNT)='Sample Standard Deviation:'
20533      NCTEXT(ICNT)=26
20534      AVALUE(ICNT)=YSD1
20535      IDIGIT(ICNT)=NUMDIG
20536      ICNT=ICNT+1
20537      ITEXT(ICNT)=' '
20538      NCTEXT(ICNT)=1
20539      AVALUE(ICNT)=0.0
20540      IDIGIT(ICNT)=-1
20541      ICNT=ICNT+1
20542      ITEXT(ICNT)='Summary Statistics for Variable 2:'
20543      NCTEXT(ICNT)=34
20544      AVALUE(ICNT)=0.0
20545      IDIGIT(ICNT)=-1
20546      ICNT=ICNT+1
20547      ITEXT(ICNT)='Number of Observations:'
20548      NCTEXT(ICNT)=23
20549      AVALUE(ICNT)=REAL(N)
20550      IDIGIT(ICNT)=0
20551      ICNT=ICNT+1
20552      ITEXT(ICNT)='Sample Mean:'
20553      NCTEXT(ICNT)=12
20554      AVALUE(ICNT)=YMEAN2
20555      IDIGIT(ICNT)=NUMDIG
20556      ICNT=ICNT+1
20557      ITEXT(ICNT)='Sample Standard Deviation:'
20558      NCTEXT(ICNT)=26
20559      AVALUE(ICNT)=YSD2
20560      IDIGIT(ICNT)=NUMDIG
20561      ICNT=ICNT+1
20562      ITEXT(ICNT)=' '
20563      NCTEXT(ICNT)=1
20564      AVALUE(ICNT)=0.0
20565      IDIGIT(ICNT)=-1
20566      ICNT=ICNT+1
20567      ITEXT(ICNT)='Correlation Coefficient (r):'
20568      NCTEXT(ICNT)=28
20569      AVALUE(ICNT)=ACORR
20570      IDIGIT(ICNT)=NUMDIG
20571      ICNT=ICNT+1
20572      ITEXT(ICNT)='atanh(r):'
20573      NCTEXT(ICNT)=9
20574      AVALUE(ICNT)=Z
20575      IDIGIT(ICNT)=NUMDIG
20576      ICNT=ICNT+1
20577      ITEXT(ICNT)=' '
20578      NCTEXT(ICNT)=1
20579      AVALUE(ICNT)=0.0
20580      IDIGIT(ICNT)=-1
20581C
20582      NUMROW=ICNT
20583      DO5210I=1,NUMROW
20584        NTOT(I)=15
20585 5210 CONTINUE
20586C
20587      IFRST=.TRUE.
20588      ILAST=.TRUE.
20589C
20590      ISTEPN='9A'
20591      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CNF2')
20592     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20593C
20594      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
20595     1            AVALUE,IDIGIT,
20596     1            NTOT,NUMROW,
20597     1            ICAPSW,ICAPTY,ILAST,IFRST,
20598     1            ISUBRO,IBUGA3,IERROR)
20599C
20600      ISTEPN='9B'
20601      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CNF2')
20602     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20603C
20604      ICASA2='CORR'
20605      DO4210I=1,NUMALP
20606        ALPHSV(I)=100.*ALPHA(I)
20607 4210 CONTINUE
20608      CALL DPDT11(ALPHSV,NORVAL,NORVAL,LOWLIM,UPPLIM,
20609     1            ICASA2,ICAPSW,ICAPTY,NUMDIG,
20610     1            ISUBRO,IBUGA3,IERROR)
20611C
20612C
20613C               *****************
20614C               **  STEP 90--  **
20615C               **  EXIT       **
20616C               *****************
20617C
20618 9000 CONTINUE
20619      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CRC2')THEN
20620        WRITE(ICOUT,999)
20621        CALL DPWRST('XXX','WRIT')
20622        WRITE(ICOUT,9011)
20623 9011   FORMAT('***** AT THE END       OF DPCRC2--')
20624        CALL DPWRST('XXX','WRIT')
20625        WRITE(ICOUT,9012)IERROR
20626 9012   FORMAT('IERROR = ',A4)
20627        CALL DPWRST('XXX','WRIT')
20628      ENDIF
20629C
20630      RETURN
20631      END
20632      SUBROUTINE DPCRC3(R,N,ALPHA,U,Z,
20633     1                  ALOWLM,AUPPLM,
20634     1                  IBUGA3,ISUBRO,IERROR)
20635C
20636C     PURPOSE--THIS ROUTINE GENERATES A CONFIDENCE LIMITS FOR THE
20637C              CORRELATION COEFFICIENT BASED ON FISHER'S NORMAL
20638C              APPROXIMATION.
20639C
20640C                LCL = TANH(Z - NORPPF(1 - ALPHA/2)/SQRT(N-3))
20641C                UCL = TANH(Z + NORPPF(1 - ALPHA/2)/SQRT(N-3))
20642C
20643C              WHERE
20644C
20645C                Z = TANH**(-1)(R)
20646C                  = LOG[(1+R)/(1-R)]/2
20647C
20648C     EXAMPLE--CORRELATION COEFICIENT Y1 Y2
20649C              SAMPLE 1 IS IN INPUT VECTOR Y1 (WITH N OBSERVATIONS).
20650C              SAMPLE 2 IS IN INPUT VECTOR Y2 (WITH N OBSERVATIONS).
20651C     WRITTEN BY--ALAN HECKERT
20652C                 STATISTICAL ENGINEERING DIVISION
20653C                 INFORMATION TECHNOLOGY LABORATORY
20654C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
20655C                 GAITHERSBURG, MD 20899-8980
20656C                 PHONE--301-975-2899
20657C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
20658C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
20659C     LANGUAGE--ANSI FORTRAN (1977)
20660C     VERSION NUMBER--2012/6
20661C     ORIGINAL VERSION--JUNE      2012.
20662C
20663C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
20664C
20665      CHARACTER*4 IBUGA3
20666      CHARACTER*4 ISUBRO
20667      CHARACTER*4 IERROR
20668C
20669      CHARACTER*4 ISUBN1
20670      CHARACTER*4 ISUBN2
20671      CHARACTER*4 ISTEPN
20672C
20673C---------------------------------------------------------------------
20674C
20675C---------------------------------------------------------------------
20676C
20677      INCLUDE 'DPCOP2.INC'
20678C
20679C-----START POINT-----------------------------------------------------
20680C
20681      ISUBN1='DPCR'
20682      ISUBN2='C3  '
20683      IERROR='NO'
20684C
20685      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CRC3')THEN
20686        WRITE(ICOUT,999)
20687  999   FORMAT(1X)
20688        CALL DPWRST('XXX','WRIT')
20689        WRITE(ICOUT,51)
20690   51   FORMAT('**** AT THE BEGINNING OF DPCRC3--')
20691        CALL DPWRST('XXX','WRIT')
20692        WRITE(ICOUT,52)IBUGA3,ISUBRO,N,R,ALPHA
20693   52   FORMAT('IBUGA3,ISUBRO,N,R,ALPHA = ',2(A4,2X),I8,2G15.7)
20694        CALL DPWRST('XXX','WRIT')
20695      ENDIF
20696C
20697C               **************************************
20698C               **  STEP 21--                       **
20699C               **  COMPUTE THE CONFIDENCE  LIMITS  **
20700C               **  FOR GIVEN VALUES OF R AND ALPHA **
20701C               **************************************
20702C
20703      ISTEPN='21'
20704      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CRC3')
20705     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20706C
20707      ALOWLM=CPUMIN
20708      AUPPLM=CPUMIN
20709C
20710      IF(R.LT.-1.0 .OR. R.GT.1.0)THEN
20711        WRITE(ICOUT,999)
20712        CALL DPWRST('XXX','WRIT')
20713        WRITE(ICOUT,101)
20714  101   FORMAT('**** ERROR IN CORRELATION CONFIDENCE INTERVAL--')
20715        CALL DPWRST('XXX','WRIT')
20716        WRITE(ICOUT,103)
20717  103   FORMAT('     THE VALUE OF R IS OUTSIDE THE (-1,1) INTERVAL.')
20718        CALL DPWRST('XXX','WRIT')
20719        WRITE(ICOUT,105)R
20720  105   FORMAT('     THE VALUE OF R = ',G15.7)
20721        CALL DPWRST('XXX','WRIT')
20722        IERROR='YES'
20723        GOTO9000
20724      ENDIF
20725C
20726      IF(N.LT.4)THEN
20727        WRITE(ICOUT,999)
20728        CALL DPWRST('XXX','WRIT')
20729        WRITE(ICOUT,101)
20730        CALL DPWRST('XXX','WRIT')
20731        WRITE(ICOUT,113)
20732  113   FORMAT('     THE NUMBER OF OBSERVATIONS IS LESS THAN FOUR.')
20733        CALL DPWRST('XXX','WRIT')
20734        WRITE(ICOUT,115)N
20735  115   FORMAT('     THE NUMBER OF OBSERVATIONS = ',I8)
20736        CALL DPWRST('XXX','WRIT')
20737        IERROR='YES'
20738        GOTO9000
20739      ENDIF
20740C
20741      ALPHSV=ALPHA
20742      IF(ALPHA.GT.1.0 .AND. ALPHA.LE.100.0)ALPHA=ALPHA/100.0
20743      IF(ALPHA.LE.0.0 .OR. ALPHA.GE.1.0)THEN
20744        IERROR='YES'
20745        WRITE(ICOUT,999)
20746        CALL DPWRST('XXX','BUG ')
20747        WRITE(ICOUT,101)
20748        CALL DPWRST('XXX','BUG ')
20749        WRITE(ICOUT,172)
20750  172   FORMAT('      THE VALUE OF ALPHA IS OUTSIDE THE (0,1) ',
20751     1         'INTERVAL.')
20752        CALL DPWRST('XXX','BUG ')
20753        WRITE(ICOUT,177)ALPHA
20754  177   FORMAT('      THE VALUE OF ALPHA = ',G15.7)
20755        CALL DPWRST('XXX','BUG ')
20756        IERROR='YES'
20757        GOTO9000
20758      ENDIF
20759C
20760      ALP=ALPHA
20761      IF(ALP.LT.0.5)THEN
20762        P2=1.0-(ALP/2.0)
20763      ELSE
20764        ALP=1.0 - ALPHA
20765        P2=1.0-(ALP/2.0)
20766      ENDIF
20767      CALL NORPPF(P2,U)
20768C
20769      AVAL2=(1.0 + R)/(1.0 - R)
20770      Z=LOG(AVAL2)/2.0
20771C
20772      AN=REAL(N)
20773      AVAL=Z - U/SQRT(AN-3.0)
20774      IF(AVAL.GT.40.0)THEN
20775        ALOWLM=1.0
20776      ELSEIF(AVAL.LT.-40.0)THEN
20777        ALOWLM=(-1.0)
20778      ELSE
20779        ALOWLM=(EXP(AVAL) - EXP(-AVAL))/(EXP(AVAL) + EXP(-AVAL))
20780      ENDIF
20781      IF(ALOWLM.LT.-1.0)ALOWLM=-1.0
20782C
20783      AVAL=Z + U/SQRT(REAL(N)-3.0)
20784      IF(AVAL.GT.40.0)THEN
20785        AUPPLM=1.0
20786      ELSEIF(AVAL.LT.-40.0)THEN
20787        AUPPLM=(-1.0)
20788      ELSE
20789        AUPPLM=(EXP(AVAL) - EXP(-AVAL))/(EXP(AVAL) + EXP(-AVAL))
20790      ENDIF
20791      IF(AUPPLM.GT.1.0)AUPPLM=1.0
20792C
20793C               *****************
20794C               **  STEP 90--  **
20795C               **  EXIT       **
20796C               *****************
20797C
20798 9000 CONTINUE
20799      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CRC3')THEN
20800        WRITE(ICOUT,999)
20801        CALL DPWRST('XXX','WRIT')
20802        WRITE(ICOUT,9011)
20803 9011   FORMAT('***** AT THE END       OF DPCRC3--')
20804        CALL DPWRST('XXX','WRIT')
20805        WRITE(ICOUT,9012)IERROR,ALOWLM,AUPPLM,U
20806 9012   FORMAT('IERROR,ALOWLM,AUPPLM,U = ',A4,2X,3G15.7)
20807        CALL DPWRST('XXX','WRIT')
20808        WRITE(ICOUT,9014)AVAL2,Z,AVAL
20809 9014   FORMAT('AVAL2,Z,AVAL = ',3G15.7)
20810        CALL DPWRST('XXX','WRIT')
20811      ENDIF
20812C
20813      RETURN
20814      END
20815      SUBROUTINE DPCRC5(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
20816     1                  IFLAGU,IFRST,ILAST,
20817     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
20818C
20819C     PURPOSE--UTILITY ROUTINE USED BY DPCRCI.  THIS ROUTINE UPDATES THE
20820C              VARIOUS CUTOFF POINTS AFTER A CORRELATION CONFIDENCE
20821C              INTERVAL.
20822C     WRITTEN BY--ALAN HECKERT
20823C                 STATISTICAL ENGINEERING DIVISION
20824C                 INFORMATION TECHNOLOGY LABORAOTRY
20825C                 NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY
20826C                 GAITHERSBURG, MD 20899-8980
20827C                 PHONE--301-975-2899
20828C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
20829C           OF THE NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY.
20830C     LANGUAGE--ANSI FORTRAN (1977)
20831C     VERSION NUMBER--2012/6
20832C     ORIGINAL VERSION--JUNE      2012.
20833C
20834C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
20835C
20836      CHARACTER*4 IFLAGU
20837      CHARACTER*4 IBUGA2
20838      CHARACTER*4 IBUGA3
20839      CHARACTER*4 ISUBRO
20840      CHARACTER*4 IERROR
20841C
20842      LOGICAL IFRST
20843      LOGICAL ILAST
20844C
20845      CHARACTER*4 IH
20846      CHARACTER*4 IH2
20847      CHARACTER*4 ISUBN0
20848      CHARACTER*4 ISUBN1
20849      CHARACTER*4 ISUBN2
20850      CHARACTER*4 ISTEPN
20851      CHARACTER*4 IOP
20852C
20853      SAVE IOUNI1
20854C
20855C---------------------------------------------------------------------
20856C
20857C-----COMMON VARIABLES (GENERAL)--------------------------------------
20858C
20859      INCLUDE 'DPCOPA.INC'
20860      INCLUDE 'DPCOHK.INC'
20861      INCLUDE 'DPCOHO.INC'
20862      INCLUDE 'DPCOP2.INC'
20863C
20864C-----START POINT-----------------------------------------------------
20865C
20866      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CRC5')THEN
20867        ISTEPN='1'
20868        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20869        WRITE(ICOUT,999)
20870  999   FORMAT(1X)
20871        CALL DPWRST('XXX','BUG ')
20872        WRITE(ICOUT,51)
20873   51   FORMAT('***** AT THE BEGINNING OF DPCRC5--')
20874        CALL DPWRST('XXX','BUG ')
20875        WRITE(ICOUT,54)CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99
20876   54   FORMAT('CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99 = ',6G15.7)
20877        CALL DPWRST('XXX','BUG ')
20878      ENDIF
20879C
20880      IF(IFLAGU.EQ.'FILE')THEN
20881C
20882        IF(IFRST)THEN
20883          IOP='OPEN'
20884          IFLAG1=1
20885          IFLAG2=0
20886          IFLAG3=0
20887          IFLAG4=0
20888          IFLAG5=0
20889          CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
20890     1                IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
20891     1                IBUGA3,ISUBRO,IERROR)
20892          IF(IERROR.EQ.'YES')GOTO9000
20893C
20894          WRITE(IOUNI1,295)
20895  295     FORMAT(
20896     1           7X,'CUTLOW90',7X,'CUTUPP90',7X,'CUTLOW95',
20897     1           7X,'CUTUPP95',7X,'CUTLOW99',7X,'CUTUPP99')
20898        ENDIF
20899        WRITE(IOUNI1,299)CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99
20900  299   FORMAT(6E15.7)
20901      ELSEIF(IFLAGU.EQ.'ON')THEN
20902C
20903        IF(CUTU90.NE.CPUMIN)THEN
20904          IH='CUTU'
20905          IH2='PP90'
20906          VALUE0=CUTU90
20907          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
20908     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
20909     1                IANS,IWIDTH,IBUGA3,IERROR)
20910        ENDIF
20911C
20912        IF(CUTU95.NE.CPUMIN)THEN
20913          IH='CUTU'
20914          IH2='PP95'
20915          VALUE0=CUTU95
20916          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
20917     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
20918     1                IANS,IWIDTH,IBUGA3,IERROR)
20919        ENDIF
20920C
20921        IF(CUTU99.NE.CPUMIN)THEN
20922          IH='CUTU'
20923          IH2='PP99'
20924          VALUE0=CUTU99
20925          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
20926     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
20927     1                IANS,IWIDTH,IBUGA3,IERROR)
20928        ENDIF
20929C
20930        IF(CUTL90.NE.CPUMIN)THEN
20931          IH='CUTL'
20932          IH2='OW90'
20933          VALUE0=CUTL90
20934          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
20935     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
20936     1                IANS,IWIDTH,IBUGA3,IERROR)
20937        ENDIF
20938C
20939        IF(CUTL95.NE.CPUMIN)THEN
20940          IH='CUTL'
20941          IH2='OW95'
20942          VALUE0=CUTL95
20943          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
20944     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
20945     1                IANS,IWIDTH,IBUGA3,IERROR)
20946        ENDIF
20947C
20948        IF(CUTL99.NE.CPUMIN)THEN
20949          IH='CUTL'
20950          IH2='OW99'
20951          VALUE0=CUTL99
20952          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
20953     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
20954     1                IANS,IWIDTH,IBUGA3,IERROR)
20955        ENDIF
20956C
20957      ENDIF
20958C
20959      IF(IFLAGU.EQ.'FILE')THEN
20960        IF(ILAST)THEN
20961          IOP='CLOS'
20962          IFLAG1=1
20963          IFLAG2=0
20964          IFLAG3=0
20965          IFLAG4=0
20966          IFLAG5=0
20967          CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
20968     1                IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
20969     1                IBUGA3,ISUBRO,IERROR)
20970C
20971          IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CRC5')THEN
20972            ISTEPN='3A'
20973            CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20974            WRITE(ICOUT,999)
20975            CALL DPWRST('XXX','BUG ')
20976            WRITE(ICOUT,301)IERROR,IOUNI1
20977  301       FORMAT('AFTER CALL DPCLFI, IERROR,IOUNI1 = ',A4,2X,I5)
20978            CALL DPWRST('XXX','BUG ')
20979          ENDIF
20980C
20981          IF(IERROR.EQ.'YES')GOTO9000
20982        ENDIF
20983      ENDIF
20984C
20985C               *****************
20986C               **  STEP 90--  **
20987C               **  EXIT       **
20988C               *****************
20989C
20990 9000 CONTINUE
20991C
20992      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CRC5')THEN
20993        WRITE(ICOUT,999)
20994        CALL DPWRST('XXX','BUG ')
20995        WRITE(ICOUT,9011)
20996 9011   FORMAT('***** AT THE END OF DPCRC5--')
20997        CALL DPWRST('XXX','BUG ')
20998      ENDIF
20999C
21000      RETURN
21001      END
21002      SUBROUTINE DPCRLF(IHARG,NUMARG,
21003     1                  IDEFCR,IDEFLF,ITEXCR,ITEXLF,
21004     1                  IBUGD2,ISUBRO,IFOUND,IERROR)
21005C
21006C     PURPOSE--DEFINE THE CARRIAGE RETURN AND LINE FEED SWITCHES
21007C              (ON OR OFF) FOR
21008C              TEXT SCRIPT.
21009C              THE CARRIAGE RETURN AND LINE FEED SWITCHES WILL BE PLACED
21010C              IN THE CHARACTER VARIABLES ITEXCR AND ITEXLF.
21011C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
21012C                     --NUMARG
21013C                     --IDEFCR
21014C                     --IDEFLF
21015C                     --IBUGD2
21016C     OUTPUT ARGUMENTS--ITEXCR
21017C                     --ITEXLF
21018C                     --IFOUND ('YES' OR 'NO' )
21019C                     --IERROR ('YES' OR 'NO' )
21020C     WRITTEN BY--JAMES J. FILLIBEN
21021C                 STATISTICAL ENGINEERING DIVISION
21022C                 INFORMATION TECHNOLOGY LABORATORY
21023C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
21024C                 GAITHERSBURG, MD 20899-8980
21025C                 PHONE--301-975-2855
21026C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
21027C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
21028C     LANGUAGE--ANSI FORTRAN (1977)
21029C     VERSION NUMBER--82/7
21030C     ORIGINAL VERSION--APRIL     1981.
21031C     UPDATED         --MAY       1982.
21032C
21033C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
21034C
21035      CHARACTER*4 IHARG
21036      CHARACTER*4 IDEFCR
21037      CHARACTER*4 IDEFLF
21038      CHARACTER*4 ITEXCR
21039      CHARACTER*4 ITEXLF
21040      CHARACTER*4 IBUGD2
21041      CHARACTER*4 ISUBRO
21042      CHARACTER*4 IFOUND
21043      CHARACTER*4 IERROR
21044C
21045C---------------------------------------------------------------------
21046C
21047      DIMENSION IHARG(*)
21048C
21049C---------------------------------------------------------------------
21050C
21051      INCLUDE 'DPCOP2.INC'
21052C
21053C-----START POINT-----------------------------------------------------
21054C
21055      IFOUND='NO'
21056      IERROR='NO'
21057C
21058      IF(IBUGD2.EQ.'OFF')GOTO90
21059      WRITE(ICOUT,999)
21060  999 FORMAT(1X)
21061      CALL DPWRST('XXX','BUG ')
21062      WRITE(ICOUT,51)
21063   51 FORMAT('***** AT THE BEGINNING OF DPCR--')
21064      CALL DPWRST('XXX','BUG ')
21065      WRITE(ICOUT,53)IDEFCR,IDEFLF
21066   53 FORMAT('IDEFCR,IDEFLF = ',A4,2X,A4)
21067      CALL DPWRST('XXX','BUG ')
21068      WRITE(ICOUT,54)NUMARG
21069   54 FORMAT('NUMARG = ',I8)
21070      CALL DPWRST('XXX','BUG ')
21071      DO55I=1,NUMARG
21072      WRITE(ICOUT,56)I,IHARG(I)
21073   56 FORMAT('I,IHARG(I) = ',I8,2X,A4)
21074      CALL DPWRST('XXX','BUG ')
21075   55 CONTINUE
21076   90 CONTINUE
21077C
21078C               **************************************
21079C               **  TREAT THE CARRIAGE RETURN CASE  **
21080C               **************************************
21081C
21082      IF(NUMARG.LE.0)GOTO1161
21083      IF(IHARG(NUMARG).EQ.'ON')GOTO1161
21084      IF(IHARG(NUMARG).EQ.'OFF')GOTO1162
21085      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1161
21086      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1165
21087      GOTO1170
21088C
21089 1161 CONTINUE
21090      ITEXCR='ON'
21091      ITEXLF='ON'
21092      GOTO1180
21093C
21094 1162 CONTINUE
21095      ITEXCR='OFF'
21096      ITEXLF='OFF'
21097      GOTO1180
21098C
21099 1165 CONTINUE
21100      ITEXCR=IDEFCR
21101      ITEXLF=IDEFLF
21102      GOTO1180
21103C
21104 1170 CONTINUE
21105      IERROR='YES'
21106      WRITE(ICOUT,1171)
21107 1171 FORMAT('***** ERROR IN DPCR--')
21108      CALL DPWRST('XXX','BUG ')
21109      WRITE(ICOUT,1172)
21110 1172 FORMAT('      ILLEGAL ENTRY FOR CARRIAGE RETURN ',
21111     1'COMMAND.')
21112      CALL DPWRST('XXX','BUG ')
21113      WRITE(ICOUT,1173)
21114 1173 FORMAT('      TEST EXAMPLE TO DEMONSTRATE THE ',
21115     1'PROPER FORM--')
21116      CALL DPWRST('XXX','BUG ')
21117      WRITE(ICOUT,1174)
21118 1174 FORMAT('      SUPPOSE THE THE ANALYST WISHES ')
21119      CALL DPWRST('XXX','BUG ')
21120      WRITE(ICOUT,1175)
21121 1175 FORMAT('      TO HAVE A CARRIAGE RETURN/LINE FEED ',
21122     1'AFTER THE TEXT COMMAND,')
21123      CALL DPWRST('XXX','BUG ')
21124      WRITE(ICOUT,1177)
21125 1177 FORMAT('      THEN ALLOWABLE FORMS ARE--')
21126      CALL DPWRST('XXX','BUG ')
21127      WRITE(ICOUT,1178)
21128 1178 FORMAT('           CRLF ON')
21129      CALL DPWRST('XXX','BUG ')
21130      WRITE(ICOUT,1179)
21131 1179 FORMAT('           CRLF')
21132      CALL DPWRST('XXX','BUG ')
21133      GOTO9000
21134C
21135 1180 CONTINUE
21136      IFOUND='YES'
21137C
21138      IF(IFEEDB.EQ.'OFF')GOTO1189
21139      WRITE(ICOUT,999)
21140      CALL DPWRST('XXX','BUG ')
21141      WRITE(ICOUT,1181)
21142 1181 FORMAT('THE CARRIAGE RETURN/LINE FEED (AFTER TEXT) ')
21143      CALL DPWRST('XXX','BUG ')
21144      WRITE(ICOUT,1182)ITEXCR
21145 1182 FORMAT('HAS JUST BEEN SET TO ',A4)
21146      CALL DPWRST('XXX','BUG ')
21147 1189 CONTINUE
21148      GOTO9000
21149C
21150C               *****************
21151C               **  STEP 90--  **
21152C               **  EXIT       **
21153C               *****************
21154C
21155 9000 CONTINUE
21156      IF(IBUGD2.EQ.'OFF')GOTO9090
21157      WRITE(ICOUT,999)
21158      CALL DPWRST('XXX','BUG ')
21159      WRITE(ICOUT,9011)
21160 9011 FORMAT('***** AT THE END       OF DPCR')
21161      CALL DPWRST('XXX','BUG ')
21162      WRITE(ICOUT,9012)IBUGD2,ISUBRO,IFOUND,IERROR
21163 9012 FORMAT('IBUGD2,ISUBRO,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
21164      CALL DPWRST('XXX','BUG ')
21165      WRITE(ICOUT,9013)IDEFCR,ITEXCR
21166 9013 FORMAT('IDEFCR,ITEXCR = ',A4,2X,A4)
21167      CALL DPWRST('XXX','BUG ')
21168      WRITE(ICOUT,9014)IDEFLF,ITEXLF
21169 9014 FORMAT('IDEFLF,ITEXLF = ',A4,2X,A4)
21170      CALL DPWRST('XXX','BUG ')
21171 9090 CONTINUE
21172C
21173      RETURN
21174      END
21175      SUBROUTINE DPCROS(ICOM,IHARG,IHARG2,IARGT,ARG,NUMARG,
21176     1                  IANS,IWIDTH,
21177     1                  IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,
21178     1                  NUMNAM,MAXNAM,
21179     1                  IGRASW,IDIASW,
21180     1                  PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
21181     1                  PDIAHE,PDIAWI,PDIAVG,PDIAHG,
21182     1                  NUMDEV,
21183     1                  IDMANU,IDMODE,IDMOD2,IDMOD3,
21184     1                  IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
21185     1                  IDNVOF,IDNHOF,IDFONT,PDSCAL,
21186     1                  PXMIN,PXMAX,PYMIN,PYMAX,
21187     1                  FX1MIN,FX1MAX,FY1MIN,FY1MAX,
21188     1                  IBUGD2,ISUBRO,IFOUND,IERROR)
21189C
21190C     PURPOSE--READ THE COORDINATES OF THE CROSS-HAIR.  SUCH COORDINATES WILL
21191C              BE IN STANDARDIZED (0.0 TO 100.0) UNITS.
21192C     WRITTEN BY--JAMES J. FILLIBEN
21193C                 STATISTICAL ENGINEERING DIVISION
21194C                 INFORMATION TECHNOLOGY LABORATORY
21195C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
21196C                 GAITHERSBURG, MD 20899-8980
21197C                 PHONE--301-975-2855
21198C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
21199C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
21200C     LANGUAGE--ANSI FORTRAN (1977)
21201C     VERSION NUMBER--83.6
21202C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY       1983.
21203C     UPDATED         --JANUARY   1989. CALL LIST FOR OFFSET VAR (ALAN)
21204C     UPDATED         --MARCH     1997. SUPPORT FOR DEVICE FONT (ALAN)
21205C     UPDATED         --FEBRUARY  1998. SUPPORT FORM OF COMMAND FOR GUI
21206C     UPDATED         --NOVEMBER  2018. RECODE FOR BETTER READABILITY
21207C     UPDATED         --NOVEMBER  2018. RESTRICT TO DEVICE 1 (I.E., THE
21208C                                       SCREEN DEVICE)
21209C     UPDATED         --NOVEMBER  2018. ADD "SQUARE" OPTION TO ALLOW A
21210C                                       RECTANGULAR REGION TO BE READ
21211C     UPDATED         --DECEMBER  2018. CHECK FOR DISCRETE, NULL, OR
21212C                                       NONE DEVICE
21213C     UPDATED         --DECEMBER  2018. SUPPORT FOR "DEVICE ... SCALE"
21214C                                       COMMAND
21215C
21216C-----NON-COMMON VARIABLES------------------------------------------------------
21217C
21218      CHARACTER*4 ICOM
21219C
21220      CHARACTER*4 IHARG
21221      CHARACTER*4 IHARG2
21222      CHARACTER*4 IARGT
21223      CHARACTER*4 IANS
21224      CHARACTER*4 IHNAME
21225      CHARACTER*4 IHNAM2
21226      CHARACTER*4 IUSE
21227      CHARACTER*4 IGRASW
21228      CHARACTER*4 IDIASW
21229C
21230      CHARACTER*4 IDMANU
21231      CHARACTER*4 IDMODE
21232      CHARACTER*4 IDMOD2
21233      CHARACTER*4 IDMOD3
21234      CHARACTER*4 IDPOWE
21235      CHARACTER*4 IDCONT
21236      CHARACTER*4 IDCOLO
21237      CHARACTER*4 IDFONT
21238C
21239      CHARACTER*4 IFOUND
21240      CHARACTER*4 IBUGD2
21241      CHARACTER*4 ISUBRO
21242      CHARACTER*4 IERROR
21243C
21244      CHARACTER*4 ICOPSJ
21245      CHARACTER*4 IFLAGU
21246      CHARACTER*4 IFLAGS
21247C
21248      CHARACTER*4 IHWORD
21249      CHARACTER*4 IHWOR2
21250      CHARACTER*4 IOP
21251      CHARACTER*4 MESSAG
21252      CHARACTER*4 IFOUNN
21253C
21254      DIMENSION IHARG(*)
21255      DIMENSION IHARG2(*)
21256      DIMENSION IARGT(*)
21257      DIMENSION ARG(*)
21258C
21259      DIMENSION IANS(*)
21260C
21261      DIMENSION IHNAME(*)
21262      DIMENSION IHNAM2(*)
21263      DIMENSION IUSE(*)
21264      DIMENSION IN(*)
21265      DIMENSION IVALUE(*)
21266      DIMENSION VALUE(*)
21267C
21268      DIMENSION IDMANU(*)
21269      DIMENSION IDMODE(*)
21270      DIMENSION IDMOD2(*)
21271      DIMENSION IDMOD3(*)
21272      DIMENSION IDPOWE(*)
21273      DIMENSION IDCONT(*)
21274      DIMENSION IDCOLO(*)
21275      DIMENSION IDFONT(*)
21276      DIMENSION IDNVPP(*)
21277      DIMENSION IDNHPP(*)
21278      DIMENSION IDUNIT(*)
21279      DIMENSION IDNVOF(*)
21280      DIMENSION IDNHOF(*)
21281      DIMENSION PDSCAL(*)
21282C
21283C-----COMMON----------------------------------------------------------
21284C
21285      INCLUDE 'DPCOGR.INC'
21286      INCLUDE 'DPCOBE.INC'
21287C
21288C-----COMMON VARIABLES (GENERAL)--------------------------------------
21289C
21290      INCLUDE 'DPCOP2.INC'
21291C
21292C-----START POINT-----------------------------------------------------
21293C
21294      IFOUND='NO'
21295      IERROR='NO'
21296C
21297      IBUGG4=IBUGD2
21298      ISUBG4=ISUBRO
21299C
21300      PXRATI=(-999.0)
21301      PYRATI=(-999.0)
21302      PXRANG=(-999.0)
21303      PYRANG=(-999.0)
21304      FXRANG=(-999.0)
21305      FYRANG=(-999.0)
21306      ILOCP3=(-999)
21307C
21308      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CROS')THEN
21309        WRITE(ICOUT,999)
21310  999   FORMAT(1X)
21311        CALL DPWRST('XXX','BUG ')
21312        WRITE(ICOUT,51)
21313   51   FORMAT('***** AT THE BEGINNING OF DPCROS--')
21314        CALL DPWRST('XXX','BUG ')
21315        WRITE(ICOUT,53)IWIDTH,NUMARG,NUMNAM,MAXNAM,NUMDEV
21316   53   FORMAT('IWIDTH,NUMARG,NUMNAM,MAXNAM,NUMDEV = ',5I8)
21317        CALL DPWRST('XXX','BUG ')
21318        WRITE(ICOUT,54)(IANS(I),I=1,MIN(25,IWIDTH))
21319   54   FORMAT('(IANS(I),I=1,IWIDTH) = ',25A4)
21320        CALL DPWRST('XXX','BUG ')
21321        DO62I=1,NUMARG
21322          WRITE(ICOUT,63)I,IHARG(I),IHARG2(I),IARGT(I),ARG(I)
21323   63     FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),ARG(I) = ',
21324     1           I8,3(2X,A4),G15.7)
21325          CALL DPWRST('XXX','BUG ')
21326   62   CONTINUE
21327        DO72I=1,NUMNAM
21328          WRITE(ICOUT,73)I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),IVALUE(I),
21329     1                   VALUE(I)
21330   73     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),IVALUE(I),',
21331     1           'VALUE(I) = ',I8,3(2X,A4),2I8,G15.7)
21332          CALL DPWRST('XXX','BUG ')
21333   72   CONTINUE
21334        WRITE(ICOUT,76)IGRASW,IDIASW
21335   76   FORMAT('IGRASW,IDIASW = ',A4,2X,A4)
21336        CALL DPWRST('XXX','BUG ')
21337        WRITE(ICOUT,77)PGRAXF,PGRAYF,PDIAXC,PDIAYC
21338   77   FORMAT('PGRAXF,PGRAYF,PDIAXC,PDIAYC = ',4G15.7)
21339        CALL DPWRST('XXX','BUG ')
21340        WRITE(ICOUT,78)PDIAHE,PDIAWI,PDIAVG,PDIAHG
21341   78   FORMAT('PDIAHE,PDIAWI,PDIAVG,PDIAHG = ',4G15.7)
21342        CALL DPWRST('XXX','BUG ')
21343        DO81I=1,NUMDEV
21344          WRITE(ICOUT,82)IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I)
21345   82     FORMAT('IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I) = ',
21346     1           3(A4,2X),A4)
21347          CALL DPWRST('XXX','BUG ')
21348          WRITE(ICOUT,83)IDPOWE(I),IDCONT(I),IDCOLO(I)
21349   83     FORMAT('IDPOWE(I),IDCONT(I),IDCOLO(I) = ',2(A4,2X),A4)
21350          CALL DPWRST('XXX','BUG ')
21351          WRITE(ICOUT,84)IDNVPP(I),IDNHPP(I),IDUNIT(I)
21352   84     FORMAT('IDNVPP(I),IDNHPP(I),IDUNIT(I) = ',3I8)
21353          CALL DPWRST('XXX','BUG ')
21354   81   CONTINUE
21355        WRITE(ICOUT,85)PXMIN,PXMAX,PYMIN,PYMAX
21356   85   FORMAT('PXMIN,PXMAX,PYMIN,PYMAX = ',4E15.7)
21357        CALL DPWRST('XXX','BUG ')
21358        WRITE(ICOUT,86)FX1MIN,FX1MAX,FY1MIN,FY1MAX
21359   86   FORMAT('FX1MIN,FX1MAX,FY1MIN,FY1MAX = ',4G15.7)
21360        CALL DPWRST('XXX','BUG ')
21361        WRITE(ICOUT,88)IBUGD2,IBUGG4,ISUBG4,IERRG4
21362   88   FORMAT('IBUGD2,IBUGG4,ISUBG4,IERRG4 = ',3(A4,2X),A4)
21363        CALL DPWRST('XXX','BUG ')
21364        WRITE(ICOUT,89)IFOUND,IERROR
21365   89   FORMAT('IFOUND,IERROR= ',A4,2X,A4)
21366        CALL DPWRST('XXX','BUG ')
21367      ENDIF
21368C
21369C               ********************************************************
21370C               **  STEP 1--                                          **
21371C               **  EXTRACT NEEDED INFORMATION FROM THE COMMAND LINE  **
21372C               ********************************************************
21373C
21374      ILOC=0
21375      IF(ICOM.EQ.'CH')THEN
21376        IF(IHARG(1).EQ.'ON' .OR. IHARG(1).EQ.'AUTO')THEN
21377          ILOC=1
21378          GOTO1190
21379        ELSEIF(IHARG(1).EQ.'DEFA' .OR. IHARG(1).EQ.'OFF')THEN
21380          GOTO1190
21381        ELSEIF(NUMARG.GE.0)THEN
21382          ILOC=0
21383          GOTO1190
21384        ENDIF
21385C
21386      ELSEIF(IHARG(1).EQ.'CH' .OR. IHARG(1).EQ.'HAIR')THEN
21387        IF(IHARG(2).EQ.'ON' .OR. IHARG(2).EQ.'AUTO')THEN
21388          ILOC=2
21389          GOTO1190
21390        ELSEIF(IHARG(2).EQ.'DEFA' .OR. IHARG(2).EQ.'OFF')THEN
21391          GOTO1190
21392        ELSEIF(NUMARG.GE.1)THEN
21393          ILOC=1
21394          GOTO1190
21395        ENDIF
21396C
21397      ELSEIF(IHARG(1).EQ.'CROS'.AND.IHARG(2).EQ.'HAIR')THEN
21398        IF(IHARG(3).EQ.'ON' .OR. IHARG(3).EQ.'AUTO')THEN
21399          ILOC=3
21400          GOTO1190
21401        ELSEIF(IHARG(3).EQ.'OFF' .OR. IHARG(3).EQ.'DEFA')THEN
21402          GOTO1190
21403        ELSEIF(NUMARG.GE.2)THEN
21404          ILOC=2
21405          GOTO1190
21406        ENDIF
21407      ENDIF
21408C
21409      GOTO9000
21410C
21411 1190 CONTINUE
21412C
21413C     NOVEMBER 2018: CHECK FOR FOLLOWING OPTIONS--
21414C
21415C                    DATA     - SPECIFY DATA UNITS
21416C                    SCREEN   - SPECIFY SCREEN UNITS
21417C                    SQUARE   - EXTRACT TWO POINTS TO DEFINE A SQUARE
21418C                               REGION
21419      IFLAGU='SCRE'
21420      IFLAGS='POIN'
21421      IF(NUMARG.GT.ILOC)THEN
21422        IF(IHARG(ILOC+1).EQ.'DATA')THEN
21423          IFLAGU='DATA'
21424          DO110II=ILOC+1,NUMARG-1
21425            IHARG(II)=IHARG(II+1)
21426            IHARG2(II)=IHARG2(II+1)
21427            IARGT(II)=IARGT(II+1)
21428            ARG(II)=ARG(II+1)
21429  110     CONTINUE
21430          IHARG(NUMARG)='    '
21431          IHARG2(NUMARG)='    '
21432          NUMARG=NUMARG-1
21433        ELSEIF(IHARG(ILOC+1).EQ.'SCRE')THEN
21434          IFLAGU='SCRE'
21435          DO120II=ILOC+1,NUMARG-1
21436            IHARG(II)=IHARG(II+1)
21437            IHARG2(II)=IHARG2(II+1)
21438            IARGT(II)=IARGT(II+1)
21439            ARG(II)=ARG(II+1)
21440  120     CONTINUE
21441          IHARG(NUMARG)='    '
21442          IHARG2(NUMARG)='    '
21443          NUMARG=NUMARG-1
21444        ENDIF
21445        IF(IHARG(ILOC+1).EQ.'SQUA')THEN
21446          IFLAGS='SQUA'
21447          DO130II=ILOC+1,NUMARG-1
21448            IHARG(II)=IHARG(II+1)
21449            IHARG2(II)=IHARG2(II+1)
21450            IARGT(II)=IARGT(II+1)
21451            ARG(II)=ARG(II+1)
21452  130     CONTINUE
21453          IHARG(NUMARG)='    '
21454          IHARG2(NUMARG)='    '
21455          NUMARG=NUMARG-1
21456        ENDIF
21457      ENDIF
21458C
21459C     COMPUTE SOME VALUES NEEDED TO CONVERT TO DATA UNITS
21460C
21461      PXRANG=PXMAX-PXMIN
21462      PYRANG=PYMAX-PYMIN
21463C
21464      FXRANG=PXRANG
21465      IF(FX1MIN.NE.CPUMIN.AND.FX1MIN.NE.CPUMAX.AND.
21466     1   FX1MAX.NE.CPUMIN.AND.FX1MAX.NE.CPUMAX)
21467     1   FXRANG=FX1MAX-FX1MIN
21468C
21469      FYRANG=PYRANG
21470      IF(FY1MIN.NE.CPUMIN.AND.FY1MIN.NE.CPUMAX.AND.
21471     1   FY1MAX.NE.CPUMIN.AND.FY1MAX.NE.CPUMAX)
21472     1   FYRANG=FY1MAX-FY1MIN
21473C
21474      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CROS')THEN
21475        WRITE(ICOUT,2170)PXRANG,PYRANG,FXRANG,FYRANG
21476 2170   FORMAT('PXRANG,PYRANG,FXRANG,FYRANG = ',4E15.7)
21477        CALL DPWRST('XXX','BUG ')
21478      ENDIF
21479C
21480C
21481CCCCC FEBRUARY 1998: SUPPORT FORM OF COMMAND--
21482CCCCC
21483CCCCC                    CROSS-HAIR 22.1  34.6
21484CCCCC
21485CCCCC                FOR GUI.  THIS FORM WILL PRINT THE COORDINATES IN
21486CCCCC                THE MOST RECENT PLOT UNITS.
21487C
21488      IF(NUMARG.EQ.2..AND.IARGT(1).EQ.'NUMB'.AND.
21489     1   IARGT(2).EQ.'NUMB')THEN
21490        PXCOOR=ARG(1)
21491        PYCOOR=ARG(2)
21492C
21493        PXRATI=(-999.0)
21494        IF(PXRANG.GT.0.0)PXRATI=(PXCOOR-PXMIN)/PXRANG
21495        XCOOR=PXCOOR
21496        IF(FX1MIN.NE.CPUMIN.AND.FX1MIN.NE.CPUMAX.AND.
21497     1     FX1MAX.NE.CPUMIN.AND.FX1MAX.NE.CPUMAX)
21498     1     XCOOR=FX1MIN+PXRATI*FXRANG
21499        IF(PYRANG.LE.0.0)PYRATI=(-999.0)
21500        IF(PYRANG.GT.0.0)PYRATI=(PYCOOR-PYMIN)/PYRANG
21501        YCOOR=PYCOOR
21502        IF(FY1MIN.NE.CPUMIN.AND.FY1MIN.NE.CPUMAX.AND.
21503     1     FY1MAX.NE.CPUMIN.AND.FY1MAX.NE.CPUMAX)
21504     1     YCOOR=FY1MIN+PYRATI*FYRANG
21505        WRITE(ICOUT,999)
21506        CALL DPWRST('XXX','BUG ')
21507        WRITE(ICOUT,2182)XCOOR
21508        CALL DPWRST('XXX','BUG ')
21509        WRITE(ICOUT,2183)YCOOR
21510        CALL DPWRST('XXX','BUG ')
21511        WRITE(ICOUT,2188)
21512        CALL DPWRST('XXX','BUG ')
21513        IFOUND='YES'
21514        GOTO9000
21515      ENDIF
21516C
21517C               ********************************
21518C               **  STEP 2--                  **
21519C               **  STEP THROUGH EACH DEVICE  **
21520C               ********************************
21521C
21522      IF(NUMDEV.LE.0)GOTO9000
21523CCCCC IUPPER=NUMDEV
21524      IUPPER=1
21525      DO8000IDEVIC=1,IUPPER
21526C
21527        IF(IDPOWE(IDEVIC).EQ.'OFF')GOTO8000
21528        IF(IDMANU(IDEVIC).EQ.'OFF')GOTO8000
21529        IF(IDMANU(IDEVIC).EQ.'NULL')GOTO8000
21530        IF(IDMANU(IDEVIC).EQ.'NONE')GOTO8000
21531        IF(IDMANU(IDEVIC).EQ.'DISC')GOTO8000
21532C
21533        IMANUF=IDMANU(IDEVIC)
21534        IMODEL=IDMODE(IDEVIC)
21535        IMODE2=IDMOD2(IDEVIC)
21536        IMODE3=IDMOD3(IDEVIC)
21537        IGCONT=IDCONT(IDEVIC)
21538        IGCOLO=IDCOLO(IDEVIC)
21539        IGFONT=IDFONT(IDEVIC)
21540        NUMVPP=IDNVPP(IDEVIC)
21541        NUMHPP=IDNHPP(IDEVIC)
21542        ANUMVP=NUMVPP
21543        ANUMHP=NUMHPP
21544        IOFFSV=IDNVOF(IDEVIC)
21545        IOFFSH=IDNHOF(IDEVIC)
21546        IGUNIT=IDUNIT(IDEVIC)
21547        PCHSCA=PDSCAL(IDEVIC)
21548C
21549C               ***********************************
21550C               **  STEP 3--                     **
21551C               **  READ THE SCREEN COORDINATES  **
21552C               ***********************************
21553C
21554        CALL GRRESC(PXCOOR,PYCOOR)
21555C
21556C       DEFINE:
21557C
21558C           PXCOOR   - X-COORDINATE OF FIRST POINT, SCREEN UNITS
21559C           PYCOOR   - Y-COORDINATE OF FIRST POINT, SCREEN UNITS
21560C           XCOOR    - X-COORDINATE OF FIRST POINT, DATA UNITS
21561C           YCOOR    - Y-COORDINATE OF FIRST POINT, DATA UNITS
21562C           PXCOO2   - X-COORDINATE OF SECOND POINT, SCREEN UNITS
21563C           PYCOO2   - Y-COORDINATE OF SECOND POINT, SCREEN UNITS
21564C           XCOOR2   - X-COORDINATE OF SECOND POINT, DATA UNITS
21565C           YCOOR2   - Y-COORDINATE OF SECOND POINT, DATA UNITS
21566C
21567        IF(PXRANG.GT.0.0)PXRATI=(PXCOOR-PXMIN)/PXRANG
21568        XCOOR=PXCOOR
21569        IF(FX1MIN.NE.CPUMIN.AND.FX1MIN.NE.CPUMAX.AND.
21570     1     FX1MAX.NE.CPUMIN.AND.FX1MAX.NE.CPUMAX)
21571     1     XCOOR=FX1MIN+PXRATI*FXRANG
21572        IF(PYRANG.LE.0.0)PYRATI=(-999.0)
21573        IF(PYRANG.GT.0.0)PYRATI=(PYCOOR-PYMIN)/PYRANG
21574        YCOOR=PYCOOR
21575        IF(FY1MIN.NE.CPUMIN.AND.FY1MIN.NE.CPUMAX.AND.
21576     1     FY1MAX.NE.CPUMIN.AND.FY1MAX.NE.CPUMAX)
21577     1     YCOOR=FY1MIN+PYRATI*FYRANG
21578C
21579        PXCOO2=CPUMIN
21580        PYCOO2=CPUMIN
21581        XCOO2=CPUMIN
21582        YCOO2=CPUMIN
21583        IF(IFLAGS.EQ.'SQUA')THEN
21584          CALL GRRESC(PXCOO2,PYCOO2)
21585          IF(PXRANG.GT.0.0)PXRATI=(PXCOO2-PXMIN)/PXRANG
21586          XCOOR2=PXCOO2
21587          IF(FX1MIN.NE.CPUMIN.AND.FX1MIN.NE.CPUMAX.AND.
21588     1       FX1MAX.NE.CPUMIN.AND.FX1MAX.NE.CPUMAX)
21589     1       XCOOR2=FX1MIN+PXRATI*FXRANG
21590          IF(PYRANG.LE.0.0)PYRATI=(-999.0)
21591          IF(PYRANG.GT.0.0)PYRATI=(PYCOO2-PYMIN)/PYRANG
21592          YCOOR2=PYCOO2
21593          IF(FY1MIN.NE.CPUMIN.AND.FY1MIN.NE.CPUMAX.AND.
21594     1       FY1MAX.NE.CPUMIN.AND.FY1MAX.NE.CPUMAX)
21595     1       YCOOR2=FY1MIN+PYRATI*FYRANG
21596C
21597        ENDIF
21598C
21599C               ************************************
21600C               **  STEP 3.5--                    **
21601C               **  CARRY OUT CLOSING OPERATIONS  **
21602C               **  ON THE GRAPHICS DEVICES       **
21603C               ************************************
21604C
21605        ICOPSJ='OFF'
21606        NUMCOJ=0
21607        CALL DPCLPL(ICOPSJ,NUMCOJ,
21608     1              PGRAXF,PGRAYF,
21609     1              IGRASW,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
21610     1              PDIAHE,PDIAWI,PDIAVG,PDIAHG)
21611        CALL DPCLDE
21612C
21613C               ***************************************
21614C               **  STEP 4--                         **
21615C               **  UPDATE INTERNAL DATAPLOT ARRAYS  **
21616C               ***************************************
21617C
21618C
21619        IF(IFLAGU.EQ.'SCRE')THEN
21620          ILOCP1=ILOC+1
21621          IF(ILOCP1.GT.NUMARG)GOTO2180
21622          IHWORD=IHARG(ILOCP1)
21623          IHWOR2=IHARG2(ILOCP1)
21624          IOP='CHAD'
21625          MESSAG='NO'
21626          CALL UPDATP(IHWORD,IHWOR2,PXCOOR,IOP,MESSAG,
21627     1                IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
21628     1                IANS,IWIDTH,IBUGD2,ILOCN,IFOUNN,IERROR)
21629          IF(IERROR.EQ.'YES')GOTO9000
21630C
21631          ILOCP2=ILOC+2
21632          IF(ILOCP2.GT.NUMARG)GOTO2180
21633          IHWORD=IHARG(ILOCP2)
21634          IHWOR2=IHARG2(ILOCP2)
21635          IOP='CHAD'
21636          MESSAG='NO'
21637          CALL UPDATP(IHWORD,IHWOR2,PYCOOR,IOP,MESSAG,
21638     1                IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
21639     1                IANS,IWIDTH,IBUGD2,ILOCN,IFOUNN,IERROR)
21640          IF(IERROR.EQ.'YES')GOTO9000
21641C
21642C         IF "SQUARE" OPTION GIVEN, THEN RETURN SECOND POINT IN SCREEN
21643C         UNITS.  OTHERWISE, RETURN THE FIRST POINT IN DATA UNITS.
21644C
21645          IF(IFLAGS.EQ.'POIN')THEN
21646            ILOCP3=ILOC+3
21647            IF(ILOCP3.GT.NUMARG)GOTO2180
21648            IHWORD=IHARG(ILOCP3)
21649            IHWOR2=IHARG2(ILOCP3)
21650            IOP='CHAD'
21651            MESSAG='NO'
21652            CALL UPDATP(IHWORD,IHWOR2,XCOOR,IOP,MESSAG,
21653     1                  IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,
21654     1                  NUMNAM,MAXNAM,
21655     1                  IANS,IWIDTH,IBUGD2,ILOCN,IFOUNN,IERROR)
21656            IF(IERROR.EQ.'YES')GOTO9000
21657C
21658            ILOCP4=ILOC+4
21659            IF(ILOCP4.GT.NUMARG)GOTO2180
21660            IHWORD=IHARG(ILOCP4)
21661            IHWOR2=IHARG2(ILOCP4)
21662            IOP='CHAD'
21663            MESSAG='NO'
21664            CALL UPDATP(IHWORD,IHWOR2,YCOOR,IOP,MESSAG,
21665     1                  IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,
21666     1                  NUMNAM,MAXNAM,
21667     1                  IANS,IWIDTH,IBUGD2,ILOCN,IFOUNN,IERROR)
21668            IF(IERROR.EQ.'YES')GOTO9000
21669          ELSEIF(IFLAGS.EQ.'SQUA')THEN
21670            ILOCP3=ILOC+3
21671            IF(ILOCP3.GT.NUMARG)GOTO2180
21672            IHWORD=IHARG(ILOCP3)
21673            IHWOR2=IHARG2(ILOCP3)
21674            IOP='CHAD'
21675            MESSAG='NO'
21676            CALL UPDATP(IHWORD,IHWOR2,PXCOO2,IOP,MESSAG,
21677     1                  IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,
21678     1                  NUMNAM,MAXNAM,
21679     1                  IANS,IWIDTH,IBUGD2,ILOCN,IFOUNN,IERROR)
21680            IF(IERROR.EQ.'YES')GOTO9000
21681C
21682            ILOCP4=ILOC+4
21683            IF(ILOCP4.GT.NUMARG)GOTO2180
21684            IHWORD=IHARG(ILOCP4)
21685            IHWOR2=IHARG2(ILOCP4)
21686            IOP='CHAD'
21687            MESSAG='NO'
21688            CALL UPDATP(IHWORD,IHWOR2,PYCOO2,IOP,MESSAG,
21689     1                  IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,
21690     1                  NUMNAM,MAXNAM,
21691     1                  IANS,IWIDTH,IBUGD2,ILOCN,IFOUNN,IERROR)
21692            IF(IERROR.EQ.'YES')GOTO9000
21693          ENDIF
21694C
21695        ELSEIF(IFLAGU.EQ.'DATA')THEN
21696          ILOCP1=ILOC+1
21697          IF(ILOCP1.GT.NUMARG)GOTO2180
21698          IHWORD=IHARG(ILOCP1)
21699          IHWOR2=IHARG2(ILOCP1)
21700          IOP='CHAD'
21701          MESSAG='NO'
21702          CALL UPDATP(IHWORD,IHWOR2,XCOOR,IOP,MESSAG,
21703     1                IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
21704     1                IANS,IWIDTH,IBUGD2,ILOCN,IFOUNN,IERROR)
21705          IF(IERROR.EQ.'YES')GOTO9000
21706C
21707          ILOCP2=ILOC+2
21708          IF(ILOCP2.GT.NUMARG)GOTO2180
21709          IHWORD=IHARG(ILOCP2)
21710          IHWOR2=IHARG2(ILOCP2)
21711          IOP='CHAD'
21712          MESSAG='NO'
21713          CALL UPDATP(IHWORD,IHWOR2,YCOOR,IOP,MESSAG,
21714     1                IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
21715     1                IANS,IWIDTH,IBUGD2,ILOCN,IFOUNN,IERROR)
21716          IF(IERROR.EQ.'YES')GOTO9000
21717C
21718C         IF "SQUARE" OPTION GIVEN, THEN RETURN SECOND POINT IN DATA
21719C         UNITS.  OTHERWISE, RETURN THE FIRST POINT IN SCREEN UNITS.
21720C
21721          IF(IFLAGS.EQ.'POIN')THEN
21722            ILOCP3=ILOC+3
21723            IF(ILOCP3.GT.NUMARG)GOTO2180
21724            IHWORD=IHARG(ILOCP3)
21725            IHWOR2=IHARG2(ILOCP3)
21726            IOP='CHAD'
21727            MESSAG='NO'
21728            CALL UPDATP(IHWORD,IHWOR2,PXCOOR,IOP,MESSAG,
21729     1                  IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,
21730     1                  NUMNAM,MAXNAM,
21731     1                  IANS,IWIDTH,IBUGD2,ILOCN,IFOUNN,IERROR)
21732            IF(IERROR.EQ.'YES')GOTO9000
21733C
21734            ILOCP4=ILOC+4
21735            IF(ILOCP4.GT.NUMARG)GOTO2180
21736            IHWORD=IHARG(ILOCP4)
21737            IHWOR2=IHARG2(ILOCP4)
21738            IOP='CHAD'
21739            MESSAG='NO'
21740            CALL UPDATP(IHWORD,IHWOR2,PYCOOR,IOP,MESSAG,
21741     1                  IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,
21742     1                  NUMNAM,MAXNAM,
21743     1                  IANS,IWIDTH,IBUGD2,ILOCN,IFOUNN,IERROR)
21744            IF(IERROR.EQ.'YES')GOTO9000
21745          ELSEIF(IFLAGS.EQ.'SQUA')THEN
21746            ILOCP3=ILOC+3
21747            IF(ILOCP3.GT.NUMARG)GOTO2180
21748            IHWORD=IHARG(ILOCP3)
21749            IHWOR2=IHARG2(ILOCP3)
21750            IOP='CHAD'
21751            MESSAG='NO'
21752            CALL UPDATP(IHWORD,IHWOR2,XCOOR2,IOP,MESSAG,
21753     1                  IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,
21754     1                  NUMNAM,MAXNAM,
21755     1                  IANS,IWIDTH,IBUGD2,ILOCN,IFOUNN,IERROR)
21756            IF(IERROR.EQ.'YES')GOTO9000
21757C
21758            ILOCP4=ILOC+4
21759            IF(ILOCP4.GT.NUMARG)GOTO2180
21760            IHWORD=IHARG(ILOCP4)
21761            IHWOR2=IHARG2(ILOCP4)
21762            IOP='CHAD'
21763            MESSAG='NO'
21764            CALL UPDATP(IHWORD,IHWOR2,YCOOR2,IOP,MESSAG,
21765     1                  IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,
21766     1                  NUMNAM,MAXNAM,
21767     1                  IANS,IWIDTH,IBUGD2,ILOCN,IFOUNN,IERROR)
21768            IF(IERROR.EQ.'YES')GOTO9000
21769          ENDIF
21770C
21771        ENDIF
21772C
21773 2180   CONTINUE
21774        IFOUND='YES'
21775C
21776        IF(IFEEDB.EQ.'ON')THEN
21777          IF(IFLAGU.EQ.'SCRE')THEN
21778            WRITE(ICOUT,999)
21779            CALL DPWRST('XXX','BUG ')
21780            WRITE(ICOUT,2182)PXCOOR
21781 2182       FORMAT('X COORDINATE = ',E15.7)
21782            CALL DPWRST('XXX','BUG ')
21783            WRITE(ICOUT,2183)PYCOOR
21784 2183       FORMAT('Y COORDINATE = ',E15.7)
21785            CALL DPWRST('XXX','BUG ')
21786            WRITE(ICOUT,2184)
21787 2184       FORMAT('(IN 0 TO 100 UNITS)')
21788            CALL DPWRST('XXX','BUG ')
21789C
21790            IF(IFLAGS.EQ.'POIN')THEN
21791C
21792              IF(ILOCP3.GT.NUMARG)GOTO2189
21793              IF(ICOM.EQ.'CH'.AND.NUMARG.LE.0)GOTO2189
21794              IF(IHARG(1).EQ.'CH'.AND.NUMARG.LE.1)GOTO2189
21795              IF(IHARG(1).EQ.'CROS'.AND.IHARG(2).EQ.'HAIR'.AND.
21796     1           NUMARG.LE.2)GOTO2189
21797C
21798              WRITE(ICOUT,999)
21799              CALL DPWRST('XXX','BUG ')
21800              WRITE(ICOUT,2182)XCOOR
21801              CALL DPWRST('XXX','BUG ')
21802              WRITE(ICOUT,2183)YCOOR
21803              CALL DPWRST('XXX','BUG ')
21804              WRITE(ICOUT,2188)
21805 2188         FORMAT('(IN UNITS OF THE DATA)')
21806              CALL DPWRST('XXX','BUG ')
21807            ELSEIF(IFLAGS.EQ.'SQUA')THEN
21808              WRITE(ICOUT,999)
21809              CALL DPWRST('XXX','BUG ')
21810              WRITE(ICOUT,2192)PXCOO2
21811 2192         FORMAT('X COORDINATE OF SECOND POINT = ',E15.7)
21812              CALL DPWRST('XXX','BUG ')
21813              WRITE(ICOUT,2193)PYCOO2
21814 2193         FORMAT('Y COORDINATE OF SECOND POINT = ',E15.7)
21815              CALL DPWRST('XXX','BUG ')
21816              WRITE(ICOUT,2184)
21817              CALL DPWRST('XXX','BUG ')
21818            ENDIF
21819          ELSEIF(IFLAGU.EQ.'DATA')THEN
21820            WRITE(ICOUT,999)
21821            CALL DPWRST('XXX','BUG ')
21822            WRITE(ICOUT,2182)XCOOR
21823            CALL DPWRST('XXX','BUG ')
21824            WRITE(ICOUT,2183)YCOOR
21825            CALL DPWRST('XXX','BUG ')
21826            WRITE(ICOUT,2188)
21827            CALL DPWRST('XXX','BUG ')
21828C
21829            IF(IFLAGS.EQ.'POIN')THEN
21830C
21831              IF(ILOCP3.GT.NUMARG)GOTO2189
21832              IF(ICOM.EQ.'CH'.AND.NUMARG.LE.0)GOTO2189
21833              IF(IHARG(1).EQ.'CH'.AND.NUMARG.LE.1)GOTO2189
21834              IF(IHARG(1).EQ.'CROS'.AND.IHARG(2).EQ.'HAIR'.AND.
21835     1           NUMARG.LE.2)GOTO2189
21836C
21837              WRITE(ICOUT,999)
21838              CALL DPWRST('XXX','BUG ')
21839              WRITE(ICOUT,2182)PXCOOR
21840              CALL DPWRST('XXX','BUG ')
21841              WRITE(ICOUT,2183)PYCOOR
21842              CALL DPWRST('XXX','BUG ')
21843              WRITE(ICOUT,2184)
21844              CALL DPWRST('XXX','BUG ')
21845            ELSEIF(IFLAGS.EQ.'SQUA')THEN
21846              WRITE(ICOUT,999)
21847              CALL DPWRST('XXX','BUG ')
21848              WRITE(ICOUT,2192)XCOOR2
21849              CALL DPWRST('XXX','BUG ')
21850              WRITE(ICOUT,2193)YCOOR2
21851              CALL DPWRST('XXX','BUG ')
21852              WRITE(ICOUT,2188)
21853              CALL DPWRST('XXX','BUG ')
21854            ENDIF
21855          ENDIF
21856C
21857 2189   CONTINUE
21858C
21859      ENDIF
21860      GOTO9000
21861C
21862 8000 CONTINUE
21863C
21864C               *****************
21865C               **  STEP 90--  **
21866C               **  EXIT       **
21867C               *****************
21868C
21869 9000 CONTINUE
21870      IERROR=IERRG4
21871      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'CROS')THEN
21872        WRITE(ICOUT,999)
21873        CALL DPWRST('XXX','BUG ')
21874        WRITE(ICOUT,9011)
21875 9011   FORMAT('***** AT THE END       OF DPCROS--')
21876        CALL DPWRST('XXX','BUG ')
21877        WRITE(ICOUT,9012)PXCOOR,PYCOOR,PXCOO2,PYCOO2
21878 9012   FORMAT('PXCOOR,PYCOOR,PXCOO2,PYCOO2 = ',4E15.7)
21879        CALL DPWRST('XXX','BUG ')
21880        WRITE(ICOUT,9013)ILOC,NUMNAM,MAXNAM,IFOUND
21881 9013   FORMAT('ILOC,NUMNAM,MAXNAM,IFOUND = ',3I8,2X,A4)
21882        CALL DPWRST('XXX','BUG ')
21883        DO9032I=1,NUMNAM
21884          WRITE(ICOUT,9033)I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),
21885     1                     IVALUE(I),VALUE(I)
21886 9033     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),',
21887     1           'IVALUE(I),VALUE(I) = ',I8,3(2X,A4),2I8,I8,G15.7)
21888          CALL DPWRST('XXX','BUG ')
21889 9032   CONTINUE
21890      ENDIF
21891C
21892      RETURN
21893      END
21894      SUBROUTINE DPCRPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
21895CCCCC1TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT,
21896     1MAXNXT,
21897     1ISEED,
21898     1ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
21899C
21900C     PURPOSE--GENERATE A CROSS TABULATION PLOT FOR ONE OF
21901C              DATAPLOT'S SUPPORTED STATISTICS
21902C
21903C     WRITTEN BY--ALAN HECKERT
21904C                 STATISTICAL ENGINEERING DIVISION
21905C                 INFORMATION TECHNOLOGY LABORATORY
21906C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
21907C                 GAITHERSBURG, MD 20899-8980
21908C                 PHONE--301-975-2899
21909C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
21910C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
21911C     LANGUAGE--ANSI FORTRAN (1977)
21912C     VERSION NUMBER--99/11
21913C     ORIGINAL VERSION--NOVEMBER  1999.
21914C     UPDATED         --APRIL     2001. ARGUMENT LIST FOR CP, CPK, CPM
21915C                                       ADD CPL AND CPU PLOTS
21916C     UPDATED         --OCTOBER   2001. HARMONIC MEAN, IQ RANGE
21917C     UPDATED         --NOVEMBER  2001. BIWEIGHT LOCATION
21918C     UPDATED         --NOVEMBER  2001. BIWEIGHT SCALE
21919C     UPDATED         --JULY      2002. WINSORIZED VARIANCE
21920C     UPDATED         --JULY      2002. WINSORIZED SD
21921C     UPDATED         --JULY      2002. ADD WINSORIZED COVARIANCE PLOT
21922C     UPDATED         --JULY      2002. ADD WINSORIZED CORRELATION PLOT
21923C     UPDATED         --JULY      2002. ADD BIWEIGHT MIDVARIANCE PLOT
21924C     UPDATED         --JULY      2002. ADD BIWEIGHT MIDCOVARIANCE PLOT
21925C     UPDATED         --JULY      2002. ADD BIWEIGHT MIDCORRELATION PLOT
21926C     UPDATED         --JULY      2002. ADD PERCENTAGE BEND MIDVARIANCE
21927C                                           PLOT
21928C     UPDATED         --JULY      2002. ADD HODGES LEHMAN PLOT
21929C     UPDATED         --JULY      2002. ADD QUANTILE PLOT
21930C     UPDATED         --JULY      2002. ADD QUANTILE STANDARD ERROR PLOT
21931C     UPDATED         --JULY      2002. ADD TRIMMED MEAN STANDARD ERROR
21932C                                       PLOT
21933C     UPDATED         --MARCH     2003. ADD 35 "DIFFERENCE OF" STATISTICS
21934C     UPDATED         --MARCH     2003. ADD WEIGHTED MEAN, WEIGHTED SD,
21935C                                       WEIGHTED VARIANCE
21936C     UPDATED         --APRIL     2003. ADD SN AND QN (AND DIFFERENCE
21937C                                       OF).  REQUIRED ADDITION OF
21938C                                       ADDITIONAL SCRATCH VARIABLES.
21939C     UPDATED         --MAY       2003. WEIGHTED TRIMMED MEAN
21940C     UPDATED         --OCTOBER   2004. KENDELLS TAU
21941C     UPDATED         --SEPTEMBER 2005. RATIO
21942C     UPDATED         --MARCH     2007. RELATIVE RISK
21943C     UPDATED         --MARCH     2007. CRAMER CONINGENCY COEFFICIENT
21944C     UPDATED         --MARCH     2007. PEARSON CONINGENCY COEFFICIENT
21945C     UPDATED         --MARCH     2007. FALSE POSITIVE
21946C     UPDATED         --MARCH     2007. FALSE NEGATIVE
21947C     UPDATED         --MARCH     2007. TRUE POSITIVE
21948C     UPDATED         --MARCH     2007. TRUE NEGATIVE
21949C     UPDATED         --MARCH     2007. TEST SENSITIVITY
21950C     UPDATED         --MARCH     2007. TEST SPECIFICITY
21951C     UPDATED         --APRIL     2007. POSITIVE PREDICTIVE VALUE
21952C     UPDATED         --APRIL     2007. NEGATIVE PREDICTIVE VALUE
21953C     UPDATED         --APRIL     2007. LOG ODDS RATIO
21954C     UPDATED         --APRIL     2007. LOG ODDS RATIO STANDARD ERROR
21955C     UPDATED         --MAY       2007. TRIMMED STANDARD DEVIATION
21956C     UPDATED         --AUGUST    2007. MOVE STORAGE OF TEMPORARY
21957C                                       VARIABLES TO COMMON BLOCKS
21958C     UPDATED         --NOVEMBER  2007. LP LOCATION
21959C     UPDATED         --NOVEMBER  2007. DOUBLE PRECISION TEMPORARY
21960C                                       ARRAYS FOR CMPSTA
21961C     UPDATED         --NOVEMBER  2007. LP LOCATION
21962C     UPDATED         --NOVEMBER  2007. VARIANCE OF LP LOCATION
21963C     UPDATED         --NOVEMBER  2007. SD OF LP LOCATION
21964C     UPDATED         --NOVEMBER  2007. DIFFERENCE OF LP LOCATION
21965C     UPDATED         --NOVEMBER  2007. DIFFERENCE OF VARI OF LP LOCATION
21966C     UPDATED         --NOVEMBER  2007. DIFFERENCE OF SD OF LP LOCATION
21967C     UPDATED         --SEPTEMBER 2008. BINOMIAL PROBABILITY
21968C     UPDATED         --SEPTEMBER 2008. DIFFERENCE OF BINOMIAL
21969C                                       PROBABILITY
21970C     UPDATED         --FEBRUARY  2009. INDEX MINIMUM
21971C     UPDATED         --FEBRUARY  2009. INDEX MAXIMUM
21972C     UPDATED         --FEBRUARY  2009. INDEX EXTREME
21973C     UPDATED         --FEBRUARY  2009. GRUBB
21974C                                       GRUBB CDF
21975C                                       GRUBB DIRECTION
21976C                                       GRUBB INDEX
21977C     UPDATED         --FEBRUARY  2009. ONE SAMPLE T TEST
21978C                                       ONE SAMPLE T TEST CDF
21979C     UPDATED         --FEBRUARY  2009. CHI-SQUARE SD TEST
21980C                                       CHI-SQUARE SD TEST CDF
21981C     UPDATED         --FEBRUARY  2009. FREQUENCY TEST
21982C                                       FREQUENCY TEST CDF
21983C     UPDATED         --FEBRUARY  2009. FREQUENCY WITHIN A BLOCK TEST
21984C                                       FREQUENCY WITHIN A BLOCK TEST CDF
21985C     UPDATED         --MARCH     2009. EXTRACT STATISTIC WITH "EXTSTA"
21986C     UPDATED         --JUNE      2010. PARSE WITH "DPPARS"
21987C     UPDATED         --JUNE      2010. ACCOMODATE 3 RESPONSE VARIABLES
21988C                                       (CMPSTA UPDATED)
21989C
21990C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
21991C
21992      CHARACTER*4 ICASPL
21993      CHARACTER*4 IAND1
21994      CHARACTER*4 IAND2
21995      CHARACTER*4 ICONT
21996      CHARACTER*4 ISUBRO
21997      CHARACTER*4 IBUGG2
21998      CHARACTER*4 IBUGG3
21999      CHARACTER*4 IBUGQ
22000      CHARACTER*4 IFOUND
22001      CHARACTER*4 IERROR
22002C
22003      CHARACTER*4 IH
22004      CHARACTER*4 IH2
22005      CHARACTER*4 IXVAR
22006      CHARACTER*4 IX2VAR
22007      CHARACTER*4 IYVAR
22008      CHARACTER*4  ISTADF
22009      CHARACTER*60 ISTANM
22010C
22011      CHARACTER*40 INAME
22012      PARAMETER (MAXSPN=30)
22013      CHARACTER*4 IVARN1(MAXSPN)
22014      CHARACTER*4 IVARN2(MAXSPN)
22015      CHARACTER*4 IVARTY(MAXSPN)
22016      REAL PVAR(MAXSPN)
22017      INTEGER ILIS(MAXSPN)
22018      INTEGER NRIGHT(MAXSPN)
22019      INTEGER ICOLR(MAXSPN)
22020C
22021      CHARACTER*4 ISUBN0
22022      CHARACTER*4 ISUBN1
22023      CHARACTER*4 ISUBN2
22024      CHARACTER*4 ISTEPN
22025C
22026C---------------------------------------------------------------------
22027C
22028      INCLUDE 'DPCOPA.INC'
22029C
22030C     AUGUST 2007: MOVE STORAGE OF FOLLOWING ARRAYS TO
22031C                  COMMON BLOCKS
22032C
22033CCCCC DIMENSION TEMP(*)
22034CCCCC DIMENSION TEMP2(*)
22035CCCCC DIMENSION TEMP3(*)
22036CCCCC DIMENSION XTEMP1(*)
22037CCCCC DIMENSION XTEMP2(*)
22038      DIMENSION TEMP(MAXOBV)
22039      DIMENSION TEMP2(MAXOBV)
22040      DIMENSION TEMP3(MAXOBV)
22041      DIMENSION TEMP4(MAXOBV)
22042      DIMENSION XTEMP1(MAXOBV)
22043      DIMENSION XTEMP2(MAXOBV)
22044C
22045      INTEGER ITEMP1(MAXOBV)
22046      INTEGER ITEMP2(MAXOBV)
22047      INTEGER ITEMP3(MAXOBV)
22048      INTEGER ITEMP4(MAXOBV)
22049      INTEGER ITEMP5(MAXOBV)
22050      INTEGER ITEMP6(MAXOBV)
22051C
22052      DOUBLE PRECISION DTEMP1(MAXOBV)
22053      DOUBLE PRECISION DTEMP2(MAXOBV)
22054      DOUBLE PRECISION DTEMP3(MAXOBV)
22055C
22056      DIMENSION X1(MAXOBV)
22057      DIMENSION X2(MAXOBV)
22058      DIMENSION Y1(MAXOBV)
22059      DIMENSION Z1(MAXOBV)
22060      DIMENSION Z2(MAXOBV)
22061      DIMENSION XTEMP3(MAXOBV)
22062      DIMENSION XTEMP4(MAXOBV)
22063C
22064      INCLUDE 'DPCOZZ.INC'
22065      INCLUDE 'DPCOZI.INC'
22066      INCLUDE 'DPCOZD.INC'
22067C
22068      EQUIVALENCE (GARBAG(IGARB1),X1(1))
22069      EQUIVALENCE (GARBAG(IGARB2),X2(1))
22070      EQUIVALENCE (GARBAG(IGARB3),Y1(1))
22071      EQUIVALENCE (GARBAG(IGARB4),Z1(1))
22072      EQUIVALENCE (GARBAG(IGARB5),Z2(1))
22073      EQUIVALENCE (GARBAG(IGARB6),XTEMP3(1))
22074      EQUIVALENCE (GARBAG(IGARB7),XTEMP4(1))
22075      EQUIVALENCE (GARBAG(IGARB9),TEMP(1))
22076      EQUIVALENCE (GARBAG(IGAR10),TEMP2(1))
22077      EQUIVALENCE (GARBAG(JGAR11),TEMP3(1))
22078      EQUIVALENCE (GARBAG(JGAR12),TEMP4(1))
22079      EQUIVALENCE (GARBAG(JGAR13),XTEMP1(1))
22080      EQUIVALENCE (GARBAG(JGAR14),XTEMP2(1))
22081C
22082      EQUIVALENCE (IGARBG(IIGAR1),ITEMP1(1))
22083      EQUIVALENCE (IGARBG(IIGAR2),ITEMP2(1))
22084      EQUIVALENCE (IGARBG(IIGAR3),ITEMP3(1))
22085      EQUIVALENCE (IGARBG(IIGAR4),ITEMP4(1))
22086      EQUIVALENCE (IGARBG(IIGAR5),ITEMP5(1))
22087      EQUIVALENCE (IGARBG(IIGAR6),ITEMP6(1))
22088C
22089      EQUIVALENCE (DGARBG(IDGAR1),DTEMP1(1))
22090      EQUIVALENCE (DGARBG(IDGAR2),DTEMP2(1))
22091      EQUIVALENCE (DGARBG(IDGAR3),DTEMP3(1))
22092C
22093C-----COMMON----------------------------------------------------------
22094C
22095      INCLUDE 'DPCOHK.INC'
22096      INCLUDE 'DPCODA.INC'
22097      INCLUDE 'DPCOHO.INC'
22098      INCLUDE 'DPCOST.INC'
22099C
22100C-----COMMON VARIABLES (GENERAL)--------------------------------------
22101C
22102      INCLUDE 'DPCOP2.INC'
22103C
22104C-----START POINT-----------------------------------------------------
22105C
22106      IERROR='NO'
22107      ISUBN1='CRPL'
22108      ISUBN2='    '
22109C
22110      MAXCP1=MAXCOL+1
22111      MAXCP2=MAXCOL+2
22112      MAXCP3=MAXCOL+3
22113      MAXCP4=MAXCOL+4
22114      MAXCP5=MAXCOL+5
22115      MAXCP6=MAXCOL+6
22116C
22117      MAXV2=2
22118      MINN2=2
22119C
22120      IXVAR='OFF'
22121      IX2VAR='OFF'
22122      IYVAR='ON'
22123C
22124C               ******************************************
22125C               **  TREAT THE CROSS TABULATE PLOT CASE  **
22126C               ******************************************
22127C
22128      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'CRPL')THEN
22129        WRITE(ICOUT,999)
22130  999   FORMAT(1X)
22131        CALL DPWRST('XXX','BUG ')
22132        WRITE(ICOUT,51)
22133   51   FORMAT('***** AT THE BEGINNING OF DPCRPL--')
22134        CALL DPWRST('XXX','BUG ')
22135        WRITE(ICOUT,52)ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ
22136   52   FORMAT('ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ  = ',
22137     1         A4,2X,A4,2X,A4,2X,A4,2X,A4)
22138        CALL DPWRST('XXX','BUG ')
22139        WRITE(ICOUT,53)ICASPL,IAND1,IAND2
22140   53   FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4)
22141        CALL DPWRST('XXX','BUG ')
22142      ENDIF
22143C
22144C               *************************************
22145C               **  STEP 1--                       **
22146C               **  EXTRACT THE COMMAND            **
22147C               **  COMMAND SYNTAX IS:             **
22148C               **  CROSS TABULATE <STAT> PLOT     **
22149C               *************************************
22150C
22151      ISTEPN='1'
22152      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'CRPL')
22153     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22154C
22155      IF(NUMARG.LE.2)GOTO9000
22156      IF(ICOM.NE.'CROS')GOTO9000
22157      IF(IHARG(1).NE.'TABU')GOTO9000
22158C
22159CCCCC MARCH 2009: USE "EXTSTA" TO PARSE.  NOTE THAT IF NO
22160CCCCC             STATISTIC IS GIVEN, WE ASSUME THE "COUNTS"
22161CCCCC             CASE.
22162C
22163      JMIN=2
22164      JMAX=MIN(NUMARG,JMIN+6)
22165      DO200I=JMIN,JMAX
22166        IF(IHARG(I).EQ.'PLOT')THEN
22167          JMAX=I-1
22168          ILASTC=I
22169          GOTO209
22170        ENDIF
22171  200 CONTINUE
22172      IFOUND='NO'
22173      GOTO9000
22174  209 CONTINUE
22175C
22176      CALL EXTSTA(ICOM,ICOM2,IHARG,IHARG2,IARGT,ARG,NUMARG,JMIN,JMAX,
22177     1            ICASPL,ISTANM,ISTANR,ISTADF,IFOUND,ILOCV,
22178     1            ISUBRO,IBUGG3,IERROR)
22179C
22180      IF(IFOUND.EQ.'YES')THEN
22181        IF(ISTANR.GE.2)IXVAR='ON'
22182        IF(ISTANR.GE.3)IX2VAR='ON'
22183        IF(ICASPL.EQ.'NUMB')IYVAR='OFF'
22184      ELSE
22185        ICASPL='NUMB'
22186        IYVAR='OFF'
22187        IXVAR='OFF'
22188        ILOCV=2
22189        IFOUND='YES'
22190      ENDIF
22191C
22192      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
22193C
22194C               *********************************
22195C               **  STEP 2--                   **
22196C               **  EXTRACT THE VARIABLE LIST  **
22197C               *********************************
22198C
22199      INAME='CROSS TABULATE PLOT'
22200      MINNA=1
22201      MAXNA=100
22202      MINN2=2
22203      IFLAGE=1
22204      IFLAGM=0
22205      IFLAGP=0
22206      JMIN=1
22207      JMAX=NUMARG
22208      MINNVA=-99
22209      MAXNVA=-99
22210C
22211      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
22212     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
22213     1            JMIN,JMAX,
22214     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
22215     1            IVARN1,IVARN2,IVARTY,PVAR,
22216     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
22217     1            MINNVA,MAXNVA,
22218     1            IFLAGM,IFLAGP,
22219     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
22220      IF(IERROR.EQ.'YES')GOTO9000
22221C
22222      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'CRPL')THEN
22223        WRITE(ICOUT,999)
22224        CALL DPWRST('XXX','BUG ')
22225        WRITE(ICOUT,281)
22226  281   FORMAT('***** AFTER CALL DPPARS--')
22227        CALL DPWRST('XXX','BUG ')
22228        WRITE(ICOUT,282)NQ,NUMVAR
22229  282   FORMAT('NQ,NUMVAR = ',2I8)
22230        CALL DPWRST('XXX','BUG ')
22231        IF(NUMVAR.GT.0)THEN
22232          DO285I=1,NUMVAR
22233            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
22234     1                      ICOLR(I)
22235  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
22236     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
22237            CALL DPWRST('XXX','BUG ')
22238  285     CONTINUE
22239        ENDIF
22240      ENDIF
22241C
22242C     NEED FOLLOWING VARIABLES:
22243C     1) TWO GROUP-ID VARIABLE
22244C     2) ONE RESPONSE VARIABLE FOR STATISTICS THAT REQUIRE ONE VARIABLE
22245C     3) TWO RESPONSE VARIABLES FOR STATISTICS THAT REQUIRE TWO VARIABLES
22246C     4) THREE RESPONSE VARIABLES FOR STATISTICS THAT REQUIRE THREE
22247C        VARIABLES
22248C
22249      IF(ICASPL.EQ.'NUMB')ISTANR=0
22250      MINVAR=2+ISTANR
22251      IF(NUMVAR.NE.MINVAR)THEN
22252C
22253        WRITE(ICOUT,999)
22254        CALL DPWRST('XXX','BUG ')
22255        WRITE(ICOUT,211)ISTANA
22256  211   FORMAT('***** ERROR IN CROSS TABULATE PLOT COMMAND--')
22257        CALL DPWRST('XXX','BUG ')
22258        WRITE(ICOUT,212)MINVAR
22259  212   FORMAT('      EXACTLY ',I5,' VARIABLES REQUIRED, BUT')
22260        CALL DPWRST('XXX','BUG ')
22261        WRITE(ICOUT,213)NUMVAR
22262  213   FORMAT('      ',I8,' VARIABLES WERE GIVEN.')
22263        CALL DPWRST('XXX','BUG ')
22264        WRITE(ICOUT,215)
22265  215   FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
22266        CALL DPWRST('XXX','BUG ')
22267        IF(IWIDTH.GE.1)THEN
22268          WRITE(ICOUT,216)(IANS(J),J=1,MIN(80,IWIDTH))
22269  216     FORMAT('      ',80A1)
22270          CALL DPWRST('XXX','BUG ')
22271          IERROR='YES'
22272          GOTO9000
22273        ENDIF
22274      ENDIF
22275C
22276C               ********************************
22277C               **  STEP 3--                  **
22278C               **  EXTRACT THE DATA          **
22279C               ********************************
22280C
22281      ISTEPN='3'
22282      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'CRPL')
22283     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22284C
22285      J=0
22286      IMAX=NRIGHT(1)
22287      IF(NQ.LT.IMAX)IMAX=NQ
22288      DO2660I=1,IMAX
22289        IF(ISUB(I).EQ.0)GOTO2660
22290        J=J+1
22291C
22292        IF(IYVAR.EQ.'OFF')THEN
22293          Y1(J)=0.0
22294        ELSE
22295          ICOLL=ICOLR(1)
22296          IJ=MAXN*(ICOLL-1)+I
22297          IF(ICOLL.LE.MAXCOL)Y1(J)=V(IJ)
22298          IF(ICOLL.EQ.MAXCP1)Y1(J)=PRED(I)
22299          IF(ICOLL.EQ.MAXCP2)Y1(J)=RES(I)
22300          IF(ICOLL.EQ.MAXCP3)Y1(J)=YPLOT(I)
22301          IF(ICOLL.EQ.MAXCP4)Y1(J)=XPLOT(I)
22302          IF(ICOLL.EQ.MAXCP5)Y1(J)=X2PLOT(I)
22303          IF(ICOLL.EQ.MAXCP6)Y1(J)=TAGPLO(I)
22304        ENDIF
22305        ICNT=1
22306C
22307        IF(IXVAR.EQ.'OFF')THEN
22308          Z1(J)=0.0
22309        ELSE
22310          ICNT=ICNT+1
22311          ICOLX=ICOLR(ICNT)
22312          IJ=MAXN*(ICOLX-1)+I
22313          IF(ICOLX.LE.MAXCOL)Z1(J)=V(IJ)
22314          IF(ICOLX.EQ.MAXCP1)Z1(J)=PRED(I)
22315          IF(ICOLX.EQ.MAXCP2)Z1(J)=RES(I)
22316          IF(ICOLX.EQ.MAXCP3)Z1(J)=YPLOT(I)
22317          IF(ICOLX.EQ.MAXCP4)Z1(J)=XPLOT(I)
22318          IF(ICOLX.EQ.MAXCP5)Z1(J)=X2PLOT(I)
22319          IF(ICOLX.EQ.MAXCP6)Z1(J)=TAGPLO(I)
22320        ENDIF
22321C
22322        IF(IX2VAR.EQ.'OFF')THEN
22323          Z2(J)=0.0
22324        ELSE
22325          ICNT=ICNT+1
22326          ICOLX=ICOLR(ICNT)
22327          IJ=MAXN*(ICOLX-1)+I
22328          IF(ICOLX.LE.MAXCOL)Z2(J)=V(IJ)
22329          IF(ICOLX.EQ.MAXCP1)Z2(J)=PRED(I)
22330          IF(ICOLX.EQ.MAXCP2)Z2(J)=RES(I)
22331          IF(ICOLX.EQ.MAXCP3)Z2(J)=YPLOT(I)
22332          IF(ICOLX.EQ.MAXCP4)Z2(J)=XPLOT(I)
22333          IF(ICOLX.EQ.MAXCP5)Z2(J)=X2PLOT(I)
22334          IF(ICOLX.EQ.MAXCP6)Z2(J)=TAGPLO(I)
22335        ENDIF
22336C
22337        ICNT=ICNT+1
22338        ICOLH=ICOLR(ICNT)
22339        IJ=MAXN*(ICOLH-1)+I
22340        IF(ICOLH.LE.MAXCOL)X1(J)=V(IJ)
22341        IF(ICOLH.EQ.MAXCP1)X1(J)=PRED(I)
22342        IF(ICOLH.EQ.MAXCP2)X1(J)=RES(I)
22343        IF(ICOLH.EQ.MAXCP3)X1(J)=YPLOT(I)
22344        IF(ICOLH.EQ.MAXCP4)X1(J)=XPLOT(I)
22345        IF(ICOLH.EQ.MAXCP5)X1(J)=X2PLOT(I)
22346        IF(ICOLH.EQ.MAXCP6)X1(J)=TAGPLO(I)
22347C
22348        ICNT=ICNT+1
22349        ICOLH2=ICOLR(ICNT)
22350        IJ=MAXN*(ICOLH2-1)+I
22351        IF(ICOLH2.LE.MAXCOL)X2(J)=V(IJ)
22352        IF(ICOLH2.EQ.MAXCP1)X2(J)=PRED(I)
22353        IF(ICOLH2.EQ.MAXCP2)X2(J)=RES(I)
22354        IF(ICOLH2.EQ.MAXCP3)X2(J)=YPLOT(I)
22355        IF(ICOLH2.EQ.MAXCP4)X2(J)=XPLOT(I)
22356        IF(ICOLH2.EQ.MAXCP5)X2(J)=X2PLOT(I)
22357        IF(ICOLH2.EQ.MAXCP6)X2(J)=TAGPLO(I)
22358C
22359 2660 CONTINUE
22360      NLOCAL=J
22361C
22362C               ******************************************************
22363C               **  STEP 28--                                       **
22364C               **  COMPUTE THE APPROPRIATE STATISTIC PLOT STATISTIC--
22365C               **  (MEAN, STANDARD DEVIATION, RANGE, OR CUSUM).    **
22366C               **  COMPUTE CONFIDENCE LINES.                       **
22367C               **  FORM THE VERTICAL AND HORIZONTAL AXIS           **
22368C               **  VALUES Y(.) AND X(.) FOR THE PLOT.              **
22369C               **  DEFINE THE VECTOR D(.) TO 1'S, 2'S, AND 3'S     **
22370C               **  FOR THE PLOTTED VALUE, THE LOWER CONFIDENCE LINE,*
22371C               **  AND THE UPPER CONFIDENCE LINE.                  **
22372C               **  DEFINE THE NUMBER OF PLOT POINTS    (NPLOTP).   **
22373C               **  DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV).   **
22374C               ******************************************************
22375C
22376      ISTEPN='28'
22377      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'CRPL')
22378     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22379C
22380      CALL DPCRP2(Y1,Z1,Z2,X1,X2,NLOCAL,NUMV2,ISTANR,ICASPL,ISIZE,ICONT,
22381     1            TEMP,TEMP2,TEMP3,TEMP4,
22382     1            XTEMP1,XTEMP2,XTEMP3,XTEMP4,MAXNXT,
22383     1            ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
22384     1            DTEMP1,DTEMP2,DTEMP3,
22385     1            ICTBDI,
22386     1            Y,X,D,X3D,NPLOTP,NPLOTV,ISUBRO,IBUGG3,IERROR)
22387      IF(ICASPL.EQ.'COUN')THEN
22388        ICASPL='CTCO'
22389      ELSE
22390        IF(ICTBDI.EQ.'2')THEN
22391          ICASPL='CTA2'
22392        ELSE
22393          ICASPL='CTAB'
22394        ENDIF
22395      ENDIF
22396C
22397C
22398C               *************************************************
22399C               **  STEP 29--                                  **
22400C               **  SAVE DIFFERENCE BETWEEN HIGHEST VALUE AND  **
22401C               **  LOWEST VALUE OF STATISTIC IN INTERNAL      **
22402C               **  PARAMETER ALOWHIGH                         **
22403C               *************************************************
22404      AMINS=CPUMAX
22405      AMAXS=CPUMIN
22406      DO2910I=1,NPLOTP
22407        IF(D(I).NE.1.0)GOTO2910
22408        IF(Y(I).GT.AMAXS)AMAXS=Y(I)
22409        IF(Y(I).LT.AMINS)AMINS=Y(I)
22410 2910 CONTINUE
22411      ADIFF=0.0
22412      IF(AMINS.NE.CPUMAX.AND.AMAXS.NE.CPUMIN)ADIFF=AMAXS-AMINS
22413C
22414      ISUBN0='DPCR'
22415      IH='ALOW'
22416      IH2='HIGH'
22417      VALUE0=ADIFF
22418      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
22419     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
22420     1IANS,IWIDTH,IBUGG3,IERROR)
22421C
22422C
22423C
22424C               *****************
22425C               **  STEP 90--  **
22426C               **  EXIT       **
22427C               *****************
22428C
22429 9000 CONTINUE
22430      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'CRPL')THEN
22431        WRITE(ICOUT,999)
22432        CALL DPWRST('XXX','BUG ')
22433        WRITE(ICOUT,9011)
22434 9011   FORMAT('***** AT THE END       OF DPCRPL--')
22435        CALL DPWRST('XXX','BUG ')
22436        WRITE(ICOUT,9012)ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ
22437 9012   FORMAT('ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ  = ',
22438     1         A4,2X,A4,2X,A4,2X,A4,2X,A4)
22439        CALL DPWRST('XXX','BUG ')
22440        WRITE(ICOUT,9013)IFOUND,IERROR
22441 9013   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
22442        CALL DPWRST('XXX','BUG ')
22443        WRITE(ICOUT,9014)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
22444 9014   FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',
22445     1         I8,I8,I8,2X,A4,2X,A4,2X,A4)
22446        CALL DPWRST('XXX','BUG ')
22447        WRITE(ICOUT,9015)ISIZE,NUMV2
22448 9015   FORMAT('ISIZE,NUMV2 = ',2I8)
22449        CALL DPWRST('XXX','BUG ')
22450        WRITE(ICOUT,9017)IHLEFT,IHLEF2,ICOLL,NLEFT
22451 9017   FORMAT('IHLEFT,IHLEF2,ICOLL,NLEFT = ',A4,2X,A4,I8,I8)
22452        CALL DPWRST('XXX','BUG ')
22453        IF(NUMV2.GE.2)THEN
22454          WRITE(ICOUT,9018)IHHOR,IHHOR2,ICOLH,NHOR
22455 9018     FORMAT('IHHOR,IHHOR2,ICOLH,NHOR = ',A4,2X,A4,I8,I8)
22456          CALL DPWRST('XXX','BUG ')
22457        ENDIF
22458        IF(NUMV2.GE.3)THEN
22459          WRITE(ICOUT,9019)IHX,IHX2,ICOLX,NX
22460 9019     FORMAT('IHX,IHX2,ICOLX,NX = ',A4,2X,A4,I8,I8)
22461          CALL DPWRST('XXX','BUG ')
22462        ENDIF
22463CCCCC   THE FOLLOWING LINE WAS CHANGED SEPTEMBER 1992
22464CCCCC   IF(NPLOTP.LE.0)GOTO9090
22465        IF(IFOUND.EQ.'YES'.AND.NPLOTP.GT.0)THEN
22466          DO9025I=1,NPLOTP
22467            WRITE(ICOUT,9026)I,Y(I),X(I),D(I)
22468 9026       FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5)
22469            CALL DPWRST('XXX','BUG ')
22470 9025     CONTINUE
22471        ENDIF
22472      ENDIF
22473C
22474      RETURN
22475      END
22476      SUBROUTINE DPCRP2(Y,Z,Z2,TAG1,TAG2,N,NUMV2,ISTANR,ICASPL,
22477     1                  ISIZE,ICONT,
22478     1                  TEMP,TEMPZ,TEMPZ2,XIDTEM,XIDTE2,
22479     1                  XTEMP1,XTEMP2,XTEMP4,MAXNXT,
22480     1                  ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
22481     1                  DTEMP1,DTEMP2,DTEMP3,
22482     1                  ICTBDI,
22483     1                  Y2,X2,D2,X3D,N2,NPLOTV,ISUBRO,IBUGG3,IERROR)
22484C
22485C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS THAT WILL DEFINE
22486C              A PLOT FOR ONE OF DATAPLOT'S SUPPORTED STATISTICS
22487C     WRITTEN BY--ALAN HECKERT
22488C                 STATISTICAL ENGINEERING DIVISION
22489C                 INFORMATION TECHNOLOGY LABORATORY
22490C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
22491C                 GAITHERSBURG, MD 20899-8980
22492C                 PHONE--301-975-2899
22493C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
22494C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
22495C     REFERENCE--ASTM MANUAL STP-15D, PAGES 78-84, 100-105
22496C     LANGUAGE--ANSI FORTRAN (1977)
22497C     VERSION NUMBER--99/11
22498C     ORIGINAL VERSION--NOVEMBER  1999.
22499C     UPDATED         --JULY      2002. WINSORIZED VARIANCE
22500C     UPDATED         --JULY      2002. WINSORIZED SD
22501C     UPDATED         --JULY      2002. ADD WINSORIZED COVARIANCE PLOT
22502C     UPDATED         --JULY      2002. ADD WINSORIZED CORRELATION PLOT
22503C     UPDATED         --JULY      2002. ADD BIWEIGHT MIDVARIANCE PLOT
22504C     UPDATED         --JULY      2002. ADD BIWEIGHT MIDCOVARIANCE PLOT
22505C     UPDATED         --JULY      2002. ADD PERCENTAGE BEND MIDVARIANCE
22506C                                           PLOT
22507C     UPDATED         --JULY      2002. ADD HODGES LEHMAN PLOT
22508C     UPDATED         --JULY      2002. ADD QUANTILE PLOT
22509C     UPDATED         --JULY      2002. ADD QUANTILE STANDARD ERROR PLOT
22510C     UPDATED         --JULY      2002. ADD TRIMMED MEAN STANDARD ERROR
22511C                                       PLOT
22512C     UPDATED         --APRIL     2003. ADD SN AND QN
22513C     UPDATED         --JUNE      2010. ADD Z2/TEMPZ2 TO CALL LIST
22514C     UPDATED         --JUNE      2010. CALL LIST TO CMPSTA
22515C
22516C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
22517C
22518      CHARACTER*4 ICASPL
22519      CHARACTER*4 ICASP2
22520      CHARACTER*4 ICONT
22521      CHARACTER*4 ICTBDI
22522      CHARACTER*4 ISUBRO
22523      CHARACTER*4 IBUGG3
22524      CHARACTER*4 IERROR
22525C
22526      CHARACTER*4 IWRITE
22527      CHARACTER*4 ISUBN1
22528      CHARACTER*4 ISUBN2
22529      CHARACTER*4 ISTEPN
22530C
22531C---------------------------------------------------------------------
22532C
22533      DIMENSION Y(*)
22534      DIMENSION Z(*)
22535      DIMENSION Z2(*)
22536      DIMENSION TAG1(*)
22537      DIMENSION TAG2(*)
22538      DIMENSION Y2(*)
22539      DIMENSION X2(*)
22540      DIMENSION D2(*)
22541      DIMENSION X3D(*)
22542C
22543      DIMENSION TEMP(*)
22544      DIMENSION TEMPZ(*)
22545      DIMENSION TEMPZ2(*)
22546      DIMENSION XIDTEM(*)
22547      DIMENSION XIDTE2(*)
22548      DIMENSION XTEMP1(*)
22549      DIMENSION XTEMP2(*)
22550      DIMENSION XTEMP4(*)
22551      INTEGER ITEMP1(*)
22552      INTEGER ITEMP2(*)
22553      INTEGER ITEMP3(*)
22554      INTEGER ITEMP4(*)
22555      INTEGER ITEMP5(*)
22556      INTEGER ITEMP6(*)
22557C
22558      DOUBLE PRECISION DTEMP1(*)
22559      DOUBLE PRECISION DTEMP2(*)
22560      DOUBLE PRECISION DTEMP3(*)
22561C
22562C-----COMMON----------------------------------------------------------
22563C
22564      INCLUDE 'DPCOPA.INC'
22565      INCLUDE 'DPCOHK.INC'
22566C
22567C-----COMMON VARIABLES (GENERAL)--------------------------------------
22568C
22569      INCLUDE 'DPCOP2.INC'
22570C
22571C-----START POINT-----------------------------------------------------
22572C
22573      ISUBN1='DPCR'
22574      ISUBN2='P2  '
22575      IWRITE='OFF'
22576C
22577      I2=0
22578      ISIZE2=0
22579C
22580      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'CRP2')THEN
22581        WRITE(ICOUT,70)
22582   70   FORMAT('AT THE BEGINNING OF DPCRP2--')
22583        CALL DPWRST('XXX','BUG ')
22584        WRITE(ICOUT,71)IBUGG3,ISUBRO,ICASPL,ICONT,N
22585   71   FORMAT('IBUGG3,ISUBRO,ICASPL,ICONT,N = ',4(A4,2X),I8)
22586        CALL DPWRST('XXX','BUG ')
22587        DO73I=1,N
22588          WRITE(ICOUT,74)I,Y(I),Z(I),Z2(I),TAG1(I),TAG2(I)
22589   74     FORMAT('I, Y(I),Z(I),Z2(I),TAG1(I)TAG2(I) = ',I8,5G15.7)
22590          CALL DPWRST('XXX','BUG ')
22591   73   CONTINUE
22592        WRITE(ICOUT,75)ISIZE,NUMV2
22593   75   FORMAT('ISIZE,NUMV2 = ',2I8)
22594        CALL DPWRST('XXX','BUG ')
22595      ENDIF
22596C
22597C     CHECK THE INPUT ARGUMENTS FOR ERRORS
22598C
22599      IF(N.LT.2)THEN
22600        WRITE(ICOUT,999)
22601  999   FORMAT(1X)
22602        CALL DPWRST('XXX','BUG ')
22603        WRITE(ICOUT,31)
22604   31   FORMAT('***** ERROR IN CROSS TABULATE PLOT--')
22605        CALL DPWRST('XXX','BUG ')
22606        WRITE(ICOUT,32)
22607   32   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 1;')
22608        CALL DPWRST('XXX','BUG ')
22609        WRITE(ICOUT,34)N
22610   34   FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6)
22611        CALL DPWRST('XXX','BUG ')
22612        WRITE(ICOUT,999)
22613        CALL DPWRST('XXX','BUG ')
22614        IERROR='YES'
22615        GOTO9000
22616      ENDIF
22617C
22618C               ******************************************************
22619C               **  STEP 1--                                        **
22620C               **  DETERMINE THE NUMBER OF DISTINCT VALUES         **
22621C               **  FOR THE GROUP VARIABLES (TAG1, TAG2)            **
22622C               **  IF ALL VALUES ARE DISTINCT, THEN THIS           **
22623C               **  IMPLIES WE HAVE THE NO REPLICATION CASE         **
22624C               **  WHICH IS AN ERROR CONDITION FOR A PLOT.         **
22625C               ******************************************************
22626C
22627      ISTEPN='1'
22628      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'CRP2')
22629     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22630C
22631      CALL DISTIN(TAG1,N,IWRITE,XIDTEM,NUMSE1,IBUGG3,IERROR)
22632      CALL SORT(XIDTEM,NUMSE1,XIDTEM)
22633      CALL DISTIN(TAG2,N,IWRITE,XIDTE2,NUMSE2,IBUGG3,IERROR)
22634      CALL SORT(XIDTE2,NUMSE2,XIDTE2)
22635C
22636      IF(NUMSE1.LT.1)THEN
22637        WRITE(ICOUT,999)
22638        CALL DPWRST('XXX','BUG ')
22639        WRITE(ICOUT,31)
22640        CALL DPWRST('XXX','BUG ')
22641        WRITE(ICOUT,192)
22642  192   FORMAT('      NUMBER OF SETS    NUMSE1 = 0 ')
22643        CALL DPWRST('XXX','BUG ')
22644        IERROR='YES'
22645        GOTO9000
22646      ENDIF
22647C
22648      IF(NUMSE2.LT.1)THEN
22649        WRITE(ICOUT,999)
22650        CALL DPWRST('XXX','BUG ')
22651        WRITE(ICOUT,31)
22652        CALL DPWRST('XXX','BUG ')
22653        WRITE(ICOUT,194)
22654  194   FORMAT('      NUMBER OF SETS    NUMSE2 = 0 ')
22655        CALL DPWRST('XXX','BUG ')
22656        IERROR='YES'
22657        GOTO9000
22658      ENDIF
22659C
22660      IF(NUMSE1.EQ.N)THEN
22661        WRITE(ICOUT,999)
22662        CALL DPWRST('XXX','BUG ')
22663        WRITE(ICOUT,31)
22664        CALL DPWRST('XXX','BUG ')
22665        WRITE(ICOUT,196)NUMSE1
22666  196   FORMAT('      NUMBER OF SETS FOR GROUP 1 VARIABLE ',I8,
22667     1         ' IDENTICAL TO ')
22668        CALL DPWRST('XXX','BUG ')
22669        WRITE(ICOUT,197)N
22670  197   FORMAT('      NUMBER OF OBSERVATIONS ',I8,' .')
22671        CALL DPWRST('XXX','BUG ')
22672        IERROR='YES'
22673        GOTO9000
22674      ENDIF
22675C
22676      IF(NUMSE2.EQ.N)THEN
22677        WRITE(ICOUT,999)
22678        CALL DPWRST('XXX','BUG ')
22679        WRITE(ICOUT,31)
22680        CALL DPWRST('XXX','BUG ')
22681        WRITE(ICOUT,206)NUMSE2
22682  206   FORMAT('      NUMBER OF SETS FOR GROUP 2 VARIABLE ',I8,
22683     1         ' IDENTICAL TO ')
22684        CALL DPWRST('XXX','BUG ')
22685        WRITE(ICOUT,197)N
22686        CALL DPWRST('XXX','BUG ')
22687        IERROR='YES'
22688        GOTO9000
22689      ENDIF
22690C
22691      AN=N
22692      ANUMS1=NUMSE1
22693      ANUMS2=NUMSE2
22694C
22695C               ****************************************************
22696C               **  STEP 11--                                     **
22697C               **  COMPUTE THE SPECIFIED STATISTIC               **
22698C               **  FOR EACH CROSS-TAB CATEGORY OF THE DATA, AND  **
22699C               **  THEN FOR THE FULL DATA SET                    **
22700C               ****************************************************
22701C
22702      ISTEPN='11'
22703      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'CRP2')
22704     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22705C
22706      J=0
22707      ATAG=1.0
22708C
22709      AINC=0.4/REAL(NUMSE2)
22710      ICASP2=ICASPL
22711      IF(ICASPL.EQ.'COUN')ICASP2='NUMB'
22712      DO11000ISET1=1,NUMSE1
22713CCCCC ATAG=ATAG+1.0
22714      DO12000ISET2=1,NUMSE2
22715C
22716        K=0
22717        ASTRT=XIDTEM(ISET1)-0.2
22718        DO11011I=1,N
22719        IF(TAG1(I).EQ.XIDTEM(ISET1).AND.TAG2(I).EQ.XIDTE2(ISET2))THEN
22720          K=K+1
22721          TEMP(K)=Y(I)
22722          TEMPZ(K)=Z(I)
22723          TEMPZ2(K)=Z2(I)
22724        ENDIF
2272511011   CONTINUE
22726        NS2=K
22727        IF(NS2.LT.1)GOTO12000
22728        CALL DPCRP3(ICASP2,TEMP,TEMPZ,TEMPZ2,NS2,XTEMP1,XTEMP2,XTEMP4,
22729     1              MAXNXT,RIGHT,
22730     1              ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
22731     1              DTEMP1,DTEMP2,DTEMP3,
22732     1              ISTANR,
22733     1              ISUBRO,IBUGG3,IERROR)
22734        J=J+1
22735        IF(ICASPL.NE.'COUN'.AND.ICTBDI.EQ.'1')THEN
22736          Y2(J)=RIGHT
22737          X2(J)=ASTRT + REAL(ISET2-1)*AINC
22738          D2(J)=ATAG
22739        ELSE
22740          Y2(J)=REAL(XIDTE2(ISET2))
22741          X2(J)=REAL(XIDTEM(ISET1))
22742          X3D(J)=RIGHT
22743CCCCC     D2(J)=RIGHT
22744          D2(J)=1.0
22745        ENDIF
2274612000 CONTINUE
2274711000 CONTINUE
22748C
22749      IF(ICASPL.EQ.'COUN')GOTO13000
22750      IF(ICTBDI.EQ.'2')GOTO13000
22751      ATAG=2.0
22752      DO10500ISET1=1,NUMSE1
22753        K=0
22754        DO10550I=1,N
22755          IF(TAG1(I).EQ.XIDTEM(ISET1))THEN
22756            K=K+1
22757            TEMP(K)=Y(I)
22758            TEMPZ(K)=Z(I)
22759            TEMPZ2(K)=Z2(I)
22760          ENDIF
2276110550   CONTINUE
22762        NS2=K
22763        IF(NS2.LT.1)GOTO10500
22764        CALL DPCRP3(ICASPL,TEMP,TEMPZ,TEMPZ2,NS2,XTEMP1,XTEMP2,XTEMP4,
22765     1              MAXNXT,RIGHT,
22766     1              ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
22767     1              DTEMP1,DTEMP2,DTEMP3,
22768     1              ISTANR,
22769     1              ISUBRO,IBUGG3,IERROR)
22770        J=J+1
22771        ATAG=ATAG+1.0
22772        Y2(J)=RIGHT
22773        X2(J)=XIDTEM(ISET1)-0.2
22774        D2(J)=ATAG
22775        J=J+1
22776        Y2(J)=RIGHT
22777        X2(J)=XIDTEM(ISET1)+0.2
22778        D2(J)=ATAG
2277910500 CONTINUE
22780C
22781      DO10100I=1,N
22782        TEMP(I)=Y(I)
22783        TEMPZ(I)=Z(I)
22784        TEMPZ2(I)=Z2(I)
2278510100 CONTINUE
22786      NS2=N
22787      CALL DPCRP3(ICASPL,TEMP,TEMPZ,TEMPZ2,NS2,XTEMP1,XTEMP2,XTEMP4,
22788     1            MAXNXT,RIGHT,
22789     1            ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
22790     1            DTEMP1,DTEMP2,DTEMP3,
22791     1            ISTANR,
22792     1            ISUBRO,IBUGG3,IERROR)
22793      ATAG=2.0
22794      J=J+1
22795      Y2(J)=RIGHT
22796      X2(J)=XIDTEM(1)-0.2
22797      D2(J)=ATAG
22798      J=J+1
22799      Y2(J)=RIGHT
22800      X2(J)=XIDTEM(NUMSE1)+0.2
22801      D2(J)=ATAG
22802C
2280313000 CONTINUE
22804      N2=J
22805      NPLOTV=3
22806      GOTO9000
22807C
22808C               ******************
22809C               **   STEP 90--  **
22810C               **   EXIT       **
22811C               ******************
22812C
22813 9000 CONTINUE
22814      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'CRP2')THEN
22815        WRITE(ICOUT,999)
22816        CALL DPWRST('XXX','BUG ')
22817        WRITE(ICOUT,9011)
22818 9011   FORMAT('***** AT THE END       OF DPCRP2--')
22819        CALL DPWRST('XXX','BUG ')
22820        WRITE(ICOUT,9012)IBUGG3,ISUBRO
22821 9012   FORMAT('IBUGG3,ISUBRO = ',A4,2X,A4)
22822        CALL DPWRST('XXX','BUG ')
22823        WRITE(ICOUT,9013)ICASPL,N,NUMSE1,NUMSE2,N2,IERROR
22824 9013   FORMAT('ICASPL,N,NUMSE1,NUMSE2,N2,IERROR = ',A4,4I8,2X,A4)
22825        CALL DPWRST('XXX','BUG ')
22826        DO9020I=1,N2
22827          WRITE(ICOUT,9021)I,Y2(I),X2(I),D2(I)
22828 9021     FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2)
22829          CALL DPWRST('XXX','BUG ')
22830 9020   CONTINUE
22831      ENDIF
22832C
22833      RETURN
22834      END
22835      SUBROUTINE DPCRP3(ICASPL,TEMP,TEMPZ,TEMPZ3,NS2,
22836     1                  XTEMP1,XTEMP2,XTEMP3,
22837     1                  MAXNXT,RIGHT,
22838     1                  ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
22839     1                  DTEMP1,DTEMP2,DTEMP3,
22840     1                  ISTANR,
22841     1                  ISUBRO,IBUGG3,IERROR)
22842C
22843C     PURPOSE--FOR CROSS-TABULATE PLOT, GENERATE VALUE OF
22844C              STATISTIC.
22845C     WRITTEN BY--ALAN HECKERT
22846C                 STATISTICAL ENGINEERING DIVISION
22847C                 INFORMATION TECHNOLOGY LABORATORY
22848C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
22849C                 GAITHERSBURG, MD 20899-8980
22850C                 PHONE--301-975-2899
22851C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
22852C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
22853C     REFERENCE--ASTM MANUAL STP-15D, PAGES 78-84, 100-105
22854C     LANGUAGE--ANSI FORTRAN (1977)
22855C     VERSION NUMBER--99/11
22856C     ORIGINAL VERSION--NOVEMBER  1999.
22857C     UPDATED         --AUGUST    2002. USE "CMPSTA" TO COMPUTE THE
22858C                                       DESIRED STATISTIC
22859C     UPDATED         --JUNE      2010. CALL LIST TO CMPSTA
22860C
22861C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
22862C
22863      CHARACTER*4 ICASPL
22864      CHARACTER*4 ISUBRO
22865      CHARACTER*4 IBUGG3
22866      CHARACTER*4 IERROR
22867C
22868      CHARACTER*4 IWRITE
22869      CHARACTER*4 ISUBN1
22870      CHARACTER*4 ISUBN2
22871C
22872C---------------------------------------------------------------------
22873C
22874      DIMENSION TEMP(*)
22875      DIMENSION TEMPZ(*)
22876      DIMENSION TEMPZ3(*)
22877      DIMENSION XTEMP1(*)
22878      DIMENSION XTEMP2(*)
22879      DIMENSION XTEMP3(*)
22880      INTEGER ITEMP1(*)
22881      INTEGER ITEMP2(*)
22882      INTEGER ITEMP3(*)
22883      INTEGER ITEMP4(*)
22884      INTEGER ITEMP5(*)
22885      INTEGER ITEMP6(*)
22886      DOUBLE PRECISION DTEMP1(*)
22887      DOUBLE PRECISION DTEMP2(*)
22888      DOUBLE PRECISION DTEMP3(*)
22889C
22890C-----COMMON VARIABLES (GENERAL)--------------------------------------
22891C
22892      INCLUDE 'DPCOPA.INC'
22893      INCLUDE 'DPCOHK.INC'
22894      INCLUDE 'DPCOP2.INC'
22895C
22896C-----START POINT-----------------------------------------------------
22897C
22898      ISUBN1='DPCR'
22899      ISUBN2='P3  '
22900C
22901      IWRITE='OFF'
22902C
22903      CALL CMPSTA(TEMP,TEMPZ,TEMPZ3,XTEMP1,XTEMP2,XTEMP3,MAXNXT,
22904     1            NS2,NS2,NS2,ISTANR,ICASPL,
22905     1            ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
22906     1            DTEMP1,DTEMP2,DTEMP3,
22907CCCCC1            IQUAME,IQUASE,PSTAMV,
22908     1            RIGHT,
22909     1            ISUBRO,IBUGG3,IERROR)
22910C
22911C               ******************
22912C               **   STEP 90--  **
22913C               **   EXIT       **
22914C               ******************
22915C
22916      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'CRP3')THEN
22917        WRITE(ICOUT,999)
22918  999   FORMAT(1X)
22919        CALL DPWRST('XXX','BUG ')
22920        WRITE(ICOUT,9011)
22921 9011   FORMAT('***** AT THE END       OF DPCRP3--')
22922        CALL DPWRST('XXX','BUG ')
22923        WRITE(ICOUT,9012)IBUGG3,ISUBRO
22924 9012   FORMAT('IBUGG3,ISUBRO = ',A4,2X,A4)
22925        CALL DPWRST('XXX','BUG ')
22926        WRITE(ICOUT,9013)ICASPL,NS2,IERROR
22927 9013   FORMAT('ICASPL,NS2,IERROR = ',A4,I8,2X,A4)
22928        CALL DPWRST('XXX','BUG ')
22929        DO9020I=1,NS2
22930          WRITE(ICOUT,9021)I,TEMP(I),TEMPZ(I)
22931 9021     FORMAT('I,TEMP(I),TEMPZ(I) = ',I8,2E15.7)
22932          CALL DPWRST('XXX','BUG ')
22933 9020   CONTINUE
22934      ENDIF
22935C
22936      RETURN
22937      END
22938      SUBROUTINE DPCRTA(Y1,ISEED,ICAPSW,IFORSW,
22939     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
22940C
22941C     PURPOSE--GENERATE A CROSS-TABULATION FOR ONE OF DATAPLOT'S
22942C              SUPPORTED STATISTICS.
22943C     WRITTEN BY--ALAN HECKERT
22944C                 STATISTICAL ENGINEERING DIVISION
22945C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
22946C                 GAITHERSBURG, MD 20899-8980
22947C                 PHONE--301-975-2899
22948C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
22949C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
22950C     LANGUAGE--ANSI FORTRAN (1977)
22951C     VERSION NUMBER--89/12
22952C     ORIGINAL VERSION--NOVEMBER  1989.
22953C     UPDATED         --JUNE      1990.  TEMPORARY ARRAYS TO GARBAGE COMMON
22954C     UPDATED         --OCTOBER   1992. ADD SUMS AND CHI-SQUARE
22955C     UPDATED         --AUGUST    2002. EXPAND LIST OF SUPPORTED
22956C                                       STATISTICS
22957C     UPDATED         --MARCH     2003. WEIGHTED MEAN, WEIGHTED SD,
22958C                                       WEIGHTED VARIANCE
22959C     UPDATED         --MARCH     2003. 35 "DIFFERENCE OF" STATISTICS
22960C     UPDATED         --APRIL     2003. SN AND QN (AND DIFFERENCE OF)
22961C                                       REQUIRED ADDITION OF
22962C                                       ADDITIONAL SCRATCH ARRAYS
22963C     UPDATED         --MAY       2003. WEIGHTED TRIMMED MEAN
22964C     UPDATED         --OCTOBER   2004. KENDELLS TAU
22965C     UPDATED         --SEPTEMBER 2005. RATIO
22966C     UPDATED         --MARCH     2007. RELATIVE RISK
22967C     UPDATED         --MARCH     2007. CRAMER CONTINGENCY COEFFICIENT
22968C     UPDATED         --MARCH     2007. PEARSON CONTINGENCY COEFFICIENT
22969C     UPDATED         --MARCH     2007. FALSE POSITIVE
22970C     UPDATED         --MARCH     2007. FALSE NEGATIVE
22971C     UPDATED         --MARCH     2007. TRUE POSITIVE
22972C     UPDATED         --MARCH     2007. TRUE NEGATIVE
22973C     UPDATED         --MARCH     2007. TEST SENSITIVITY
22974C     UPDATED         --MARCH     2007. TEST SPECIFICITY
22975C     UPDATED         --APRIL     2007. POSITIVE PREDICTIVE VALUE
22976C     UPDATED         --APRIL     2007. NEGATIVE PREDICTIVE VALUE
22977C     UPDATED         --APRIL     2007. ODDS RATIO
22978C     UPDATED         --APRIL     2007. STANDARD ERROR ODDS RATIO
22979C     UPDATED         --APRIL     2007. LOG ODDS RATIO
22980C     UPDATED         --APRIL     2007. LOG STANDARD ERROR ODDS RATIO
22981C     UPDATED         --NOVEMBER  2007. DOUBLE PRECISION ARRAYS FOR
22982C                                       CMPSTA
22983C     UPDATED         --NOVEMBER  2007. LP LOCATION
22984C     UPDATED         --NOVEMBER  2007. VARIANCE OF LP LOCATION
22985C     UPDATED         --NOVEMBER  2007. SD OF LP LOCATION
22986C     UPDATED         --NOVEMBER  2007. DIFFERENCE OF LP LOCATION
22987C     UPDATED         --NOVEMBER  2007. DIFFERENCE OF VARI OF LP LOCATION
22988C     UPDATED         --NOVEMBER  2007. DIFFERENCE OF SD OF LP LOCATION
22989C     UPDATED         --APRIL     2008. SUPPORT FOR 3, 4, 5, OR 6
22990C                                       CROSS-TABULATION VARIABLES
22991C     UPDATED         --APRIL     2008. SUPPORT FOR RTF
22992C     UPDATED         --APRIL     2008. SINCE THERE IS NOW A SEPARATE
22993C                                       "CHI-SQUARE INDEPENDENCE" TEST
22994C                                       REMOVE IT FROM HERE
22995C     UPDATED         --APRIL     2008. "BINOMIAL PROBABILITY" OPTION
22996C                                       (THIS RECIEVES SPECIAL
22997C                                       HANDLING)
22998C     UPDATED         --FEBRUARY  2009. INDEX MINIMUM
22999C     UPDATED         --FEBRUARY  2009. INDEX MAXIMUM
23000C     UPDATED         --FEBRUARY  2009. INDEX EXTREME
23001C     UPDATED         --FEBRUARY  2009. GRUBB
23002C                                       GRUBB CDF
23003C                                       GRUBB DIRECTION
23004C                                       GRUBB INDEX
23005C     UPDATED         --FEBRUARY  2009. ONE SAMPLE T TEST
23006C                                       ONE SAMPLE T TEST CDF
23007C     UPDATED         --FEBRUARY  2009. CHI-SQUARE SD TEST
23008C                                       CHI-SQUARE SD TEST CDF
23009C     UPDATED         --FEBRUARY  2009. FREQUENCY TEST
23010C                                       FREQUENCY TEST CDF
23011C     UPDATED         --FEBRUARY  2009. FREQUENCY WITHIN A BLOCK TEST
23012C                                       FREQUENCY WITHIN A BLOCK TEST CDF
23013C     UPDATED         --MARCH     2009. PARSE WITH "EXTSTA"
23014C     UPDATED         --FEBRUARY  2010. USE DPPARS
23015C     UPDATED         --FEBRUARY  2010. HANDLE ONE GROUP-ID VARIABLE
23016C                                       CASE
23017C     UPDATED         --JUNE      2010. CALL LIST TO CMPSTA
23018C     UPDATED         --MAY       2014. SUPPORT UP TO 8 CROSS-TAB
23019C                                       VARIABLES
23020C     UPDATED         --APRIL     2018. CROSS TABULATE LIMITS OPTION
23021C     UPDATED         --JULY      2019. TWEAK USE OF SCRATCH SPACE
23022C
23023C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
23024C
23025      CHARACTER*4 ICASCT
23026      CHARACTER*40 ICTNAM
23027      CHARACTER*4 ICAPSW
23028      CHARACTER*4 IFORSW
23029      CHARACTER*4 IBUGA2
23030      CHARACTER*4 IBUGA3
23031      CHARACTER*4 IBUGQ
23032      CHARACTER*4 ISUBRO
23033      CHARACTER*4 IFOUND
23034      CHARACTER*4 IERROR
23035C
23036      CHARACTER*4 IHWUSE
23037      CHARACTER*4 MESSAG
23038      CHARACTER*4 IHP
23039      CHARACTER*4 IHP2
23040      CHARACTER*4 IFLAGL
23041C
23042      CHARACTER*40 INAME
23043      PARAMETER (MAXSPN=12)
23044      CHARACTER*4 IVARN1(MAXSPN)
23045      CHARACTER*4 IVARN2(MAXSPN)
23046      CHARACTER*4 IVARTY(MAXSPN)
23047      REAL PVAR(MAXSPN)
23048      INTEGER ILIS(MAXSPN)
23049      INTEGER NRIGHT(MAXSPN)
23050      INTEGER ICOLR(MAXSPN)
23051C
23052      CHARACTER*4 IXVAR
23053      CHARACTER*4 IX2VAR
23054      CHARACTER*4 IYVAR
23055C
23056      CHARACTER*8 IYNAM
23057      CHARACTER*8 IXNAM
23058      CHARACTER*8 IXNAM2
23059      CHARACTER*8 IX1NAM
23060      CHARACTER*8 IX2NAM
23061      CHARACTER*8 IX3NAM
23062      CHARACTER*8 IX4NAM
23063      CHARACTER*8 IX5NAM
23064      CHARACTER*8 IX6NAM
23065      CHARACTER*8 IX7NAM
23066      CHARACTER*8 IX8NAM
23067C
23068      CHARACTER*4 ISTADF
23069      CHARACTER*60 ISTANM
23070C
23071      CHARACTER*4 ISUBN1
23072      CHARACTER*4 ISUBN2
23073      CHARACTER*4 ISTEPN
23074C
23075C---------------------------------------------------------------------
23076C
23077      INCLUDE 'DPCOPA.INC'
23078      INCLUDE 'DPCOZZ.INC'
23079      INCLUDE 'DPCOZI.INC'
23080      INCLUDE 'DPCOZD.INC'
23081C
23082      DIMENSION Y1(*)
23083C
23084      PARAMETER (MAXGR9=8)
23085      DIMENSION XH1DIS(MAXOBV,MAXGR9)
23086      DIMENSION XDESGN(MAXOBV,MAXGR9)
23087      DIMENSION TEMP(MAXOBV)
23088      DIMENSION TEMPZ(MAXOBV)
23089      DIMENSION TEMPZ2(MAXOBV)
23090      DIMENSION XTEMP1(MAXOBV)
23091      DIMENSION Z1(MAXOBV)
23092      DIMENSION Z2(MAXOBV)
23093      DIMENSION XTEMP2(MAXOBV)
23094      DIMENSION XTEMP3(MAXOBV)
23095      DIMENSION XTEMP6(MAXOBV)
23096      DIMENSION XTEMP7(MAXOBV)
23097      DIMENSION XNTRIA(MAXOBV)
23098      DIMENSION XACLOW(MAXOBV)
23099      DIMENSION XACUPP(MAXOBV)
23100C
23101      DIMENSION ITEMP1(MAXOBV)
23102      DIMENSION ITEMP2(MAXOBV)
23103      DIMENSION ITEMP3(MAXOBV)
23104      DIMENSION ITEMP4(MAXOBV)
23105      DIMENSION ITEMP5(MAXOBV)
23106      DIMENSION ITEMP6(MAXOBV)
23107C
23108      DOUBLE PRECISION DTEMP1(MAXOBV)
23109      DOUBLE PRECISION DTEMP2(MAXOBV)
23110      DOUBLE PRECISION DTEMP3(MAXOBV)
23111C
23112      EQUIVALENCE (GARBAG(IGARB1),TEMP(1))
23113      EQUIVALENCE (GARBAG(IGARB2),TEMPZ(1))
23114      EQUIVALENCE (GARBAG(IGARB3),XTEMP1(1))
23115      EQUIVALENCE (GARBAG(IGARB4),XTEMP2(1))
23116      EQUIVALENCE (GARBAG(IGARB5),Z1(1))
23117      EQUIVALENCE (GARBAG(IGARB6),XTEMP3(1))
23118      EQUIVALENCE (GARBAG(IGARB7),XNTRIA(1))
23119      EQUIVALENCE (GARBAG(IGARB8),XACLOW(1))
23120      EQUIVALENCE (GARBAG(IGARB9),XACUPP(1))
23121      EQUIVALENCE (GARBAG(IGAR10),Z2(1))
23122      EQUIVALENCE (GARBAG(JGAR11),TEMPZ2(1))
23123      EQUIVALENCE (GARBAG(JGAR12),XTEMP6(1))
23124      EQUIVALENCE (GARBAG(JGAR13),XTEMP7(1))
23125      EQUIVALENCE (GARBAG(JGAR14),XH1DIS(1,1))
23126      EQUIVALENCE (GARBAG(IGAR13),XDESGN(1,1))
23127C
23128      EQUIVALENCE (IGARBG(IIGAR1),ITEMP1(1))
23129      EQUIVALENCE (IGARBG(IIGAR2),ITEMP2(1))
23130      EQUIVALENCE (IGARBG(IIGAR3),ITEMP3(1))
23131      EQUIVALENCE (IGARBG(IIGAR4),ITEMP4(1))
23132      EQUIVALENCE (IGARBG(IIGAR5),ITEMP5(1))
23133      EQUIVALENCE (IGARBG(IIGAR6),ITEMP6(1))
23134C
23135      EQUIVALENCE (DGARBG(IDGAR1),DTEMP1(1))
23136      EQUIVALENCE (DGARBG(IDGAR2),DTEMP2(1))
23137      EQUIVALENCE (DGARBG(IDGAR3),DTEMP3(1))
23138C
23139CCCCC END CHANGE
23140C
23141C-----COMMON----------------------------------------------------------
23142C
23143      INCLUDE 'DPCOSU.INC'
23144      INCLUDE 'DPCOHK.INC'
23145      INCLUDE 'DPCODA.INC'
23146      INCLUDE 'DPCOST.INC'
23147      INCLUDE 'DPCOP2.INC'
23148C
23149C-----START POINT-----------------------------------------------------
23150C
23151      IERROR='NO'
23152      ISUBN1='DPCR'
23153      ISUBN2='TA  '
23154C
23155      IYNAM=' '
23156      IXNAM=' '
23157      IXNAM2=' '
23158      IX1NAM=' '
23159      IX2NAM=' '
23160      IX3NAM=' '
23161      IX4NAM=' '
23162      IX5NAM=' '
23163      IX6NAM=' '
23164      IX7NAM=' '
23165      IX8NAM=' '
23166C
23167      MAXCP1=MAXCOL+1
23168      MAXCP2=MAXCOL+2
23169      MAXCP3=MAXCOL+3
23170      MAXCP4=MAXCOL+4
23171      MAXCP5=MAXCOL+5
23172      MAXCP6=MAXCOL+6
23173C
23174      MINN2=1
23175C
23176C               ******************************************
23177C               **  TREAT THE CROSS-TABULATION    CASE  **
23178C               ******************************************
23179C
23180      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CRTA')THEN
23181        WRITE(ICOUT,999)
23182  999   FORMAT(1X)
23183        CALL DPWRST('XXX','BUG ')
23184        WRITE(ICOUT,51)
23185   51   FORMAT('***** AT THE BEGINNING OF DPCRTA--')
23186        CALL DPWRST('XXX','BUG ')
23187        WRITE(ICOUT,53)ICASCT,IBUGA2,IBUGA3,IBUGQ
23188   53   FORMAT('ICASCT,IBUGA2,IBUGA3,IBUGQ = ',3(A4,2X),A4)
23189        CALL DPWRST('XXX','BUG ')
23190      ENDIF
23191C
23192C               ***************************
23193C               **  STEP 1--             **
23194C               **  EXTRACT THE COMMAND  **
23195C               ***************************
23196C
23197      ISTEPN='1'
23198      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CRTA')
23199     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23200C
23201C               *******************************************************
23202C               **  STEP 1.5--                                       **
23203C               **  SEARCH FOR CROSS-TABULATE CHI-SQUARE             **
23204C               *******************************************************
23205C
23206      ICASCT='CSCT'
23207      IYVAR='ON'
23208      IXVAR='OFF'
23209      IX2VAR='OFF'
23210      IFLAGL='OFF'
23211C
23212      IF(ICOM.EQ.'CROS' .AND. IHARG(1).EQ.'TABU')THEN
23213        JMIN=2
23214        IF(IHARG(2).EQ.'LIMI')THEN
23215          JMIN=3
23216          IFLAGL='ON'
23217        ENDIF
23218      ELSEIF(ICOM.EQ.'TABU')THEN
23219        JMIN=1
23220        IF(IHARG(1).EQ.'LIMI')THEN
23221          JMIN=2
23222          IFLAGL='ON'
23223        ENDIF
23224      ELSE
23225        IFOUND='NO'
23226        GOTO9000
23227      ENDIF
23228      JMAX=MIN(NUMARG,JMIN+6)
23229C
23230CCCCC MARCH 2009: USE "EXTSTA" TO PARSE.  NOTE THAT IF NO
23231CCCCC             STATISTIC IS GIVEN, WE ASSUME THE "COUNTS"
23232CCCCC             CASE.
23233C
23234      CALL EXTSTA(ICOM,ICOM2,IHARG,IHARG2,IARGT,ARG,NUMARG,JMIN,JMAX,
23235     1            ICASCT,ISTANM,ISTANR,ISTADF,IFOUND,ILOCV,
23236     1            ISUBRO,IBUGA3,IERROR)
23237C
23238      IF(IFOUND.EQ.'YES')THEN
23239        ICTNAM(1:40)=ISTANM(1:40)
23240        IYVAR='ON'
23241        IXVAR='OFF'
23242        IX2VAR='OFF'
23243        IF(ISTANR.GE.2)IXVAR='ON'
23244        IF(ISTANR.GE.3)IX2VAR='ON'
23245        IF(ICASCT.EQ.'NUMB')THEN
23246          IYVAR='OFF'
23247          ISTANR=0
23248        ENDIF
23249      ELSE
23250        ICASCT='NUMB'
23251        ICTNAM='NUMBER'
23252        IYVAR='OFF'
23253        IXVAR='OFF'
23254        IX2VAR='OFF'
23255        ISTANR=0
23256        IFOUND='YES'
23257        ILOCV=JMIN
23258      ENDIF
23259C
23260      ILASTC=ILOCV-1
23261      IF(ILASTC.GE.1)THEN
23262        CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
23263      ENDIF
23264C
23265C               ****************************************
23266C               **  STEP 2--                          **
23267C               **  EXTRACT THE VARIABLE LIST         **
23268C               ****************************************
23269C
23270      ISTEPN='2'
23271      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CRTA')
23272     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23273C
23274      INAME='CROSS TABULATE'
23275      MINNA=1
23276      MAXNA=100
23277      MINN2=1
23278      IFLAGE=1
23279      IFLAGM=0
23280      IFLAGP=0
23281      JMIN=1
23282      JMAX=NUMARG
23283      MINNVA=1
23284      MAXNVA=8 + ISTANR
23285C
23286      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
23287     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
23288     1            JMIN,JMAX,
23289     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
23290     1            IVARN1,IVARN2,IVARTY,PVAR,
23291     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
23292     1            MINNVA,MAXNVA,
23293     1            IFLAGM,IFLAGP,
23294     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
23295      IF(IERROR.EQ.'YES')GOTO9000
23296C
23297      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CRTA')THEN
23298        WRITE(ICOUT,999)
23299        CALL DPWRST('XXX','BUG ')
23300        WRITE(ICOUT,281)
23301  281   FORMAT('***** AFTER CALL DPPARS--')
23302        CALL DPWRST('XXX','BUG ')
23303        WRITE(ICOUT,282)NQ,NUMVAR
23304  282   FORMAT('NQ,NUMVAR = ',2I8)
23305        CALL DPWRST('XXX','BUG ')
23306        IF(NUMVAR.GT.0)THEN
23307          DO285I=1,NUMVAR
23308            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
23309     1                      ICOLR(I)
23310  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
23311     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
23312            CALL DPWRST('XXX','BUG ')
23313  285     CONTINUE
23314        ENDIF
23315      ENDIF
23316C
23317C               ****************************************
23318C               **  STEP 3--                          **
23319C               **  EXTRACT THE DATA                  **
23320C               ****************************************
23321C
23322      NRESP=ISTANR
23323      NCRTV=NUMVAR-NRESP
23324      IF(NCRTV.LT.1 .OR. NCRTV.GT.8)THEN
23325        WRITE(ICOUT,999)
23326        CALL DPWRST('XXX','BUG ')
23327        WRITE(ICOUT,301)
23328  301   FORMAT('****** ERROR IN CROSS TABULATE--')
23329        CALL DPWRST('XXX','BUG ')
23330        WRITE(ICOUT,302)
23331  302   FORMAT('       THE NUMBER OF GROUP-ID VARIABLES IS LESS THAN')
23332        CALL DPWRST('XXX','BUG ')
23333        WRITE(ICOUT,303)
23334  303   FORMAT('       OR GREATER THAN EIGHT.')
23335        CALL DPWRST('XXX','BUG ')
23336        WRITE(ICOUT,304)NGROUP
23337  304   FORMAT('       THE NUMBER OF GROUP-ID VARIABLES   = ',I5)
23338        CALL DPWRST('XXX','BUG ')
23339        WRITE(ICOUT,305)NRESP
23340  305   FORMAT('       THE NUMBER OF RESPONSE VARIABLES   = ',I5)
23341        CALL DPWRST('XXX','BUG ')
23342        IERROR='YES'
23343        GOTO9000
23344      ENDIF
23345C
23346      J=0
23347      DO2660I=1,NRIGHT(1)
23348        ICOLH=0
23349        IF(ISUB(I).EQ.0)GOTO2660
23350        J=J+1
23351C
23352        IF(NRESP.GE.1)THEN
23353          ICOLH=ICOLH+1
23354          IJ=MAXN*(ICOLR(ICOLH)-1)+I
23355          IF(ICOLR(ICOLH).LE.MAXCOL)Y1(J)=V(IJ)
23356          IF(ICOLR(ICOLH).EQ.MAXCP1)Y1(J)=PRED(I)
23357          IF(ICOLR(ICOLH).EQ.MAXCP2)Y1(J)=RES(I)
23358          IF(ICOLR(ICOLH).EQ.MAXCP3)Y1(J)=YPLOT(I)
23359          IF(ICOLR(ICOLH).EQ.MAXCP4)Y1(J)=XPLOT(I)
23360          IF(ICOLR(ICOLH).EQ.MAXCP5)Y1(J)=X2PLOT(I)
23361          IF(ICOLR(ICOLH).EQ.MAXCP6)Y1(J)=TAGPLO(I)
23362        ELSE
23363          Y1(J)=0.0
23364        ENDIF
23365C
23366        IF(NRESP.GE.2)THEN
23367          ICOLH=ICOLH+1
23368          IJ=MAXN*(ICOLR(ICOLH)-1)+I
23369          IF(ICOLR(ICOLH).LE.MAXCOL)Z1(J)=V(IJ)
23370          IF(ICOLR(ICOLH).EQ.MAXCP1)Z1(J)=PRED(I)
23371          IF(ICOLR(ICOLH).EQ.MAXCP2)Z1(J)=RES(I)
23372          IF(ICOLR(ICOLH).EQ.MAXCP3)Z1(J)=YPLOT(I)
23373          IF(ICOLR(ICOLH).EQ.MAXCP4)Z1(J)=XPLOT(I)
23374          IF(ICOLR(ICOLH).EQ.MAXCP5)Z1(J)=X2PLOT(I)
23375          IF(ICOLR(ICOLH).EQ.MAXCP6)Z1(J)=TAGPLO(I)
23376        ELSE
23377          Z1(J)=0.0
23378        ENDIF
23379C
23380        IF(NRESP.GE.3)THEN
23381          ICOLH=ICOLH+1
23382          IJ=MAXN*(ICOLR(ICOLH)-1)+I
23383          IF(ICOLR(ICOLH).LE.MAXCOL)Z2(J)=V(IJ)
23384          IF(ICOLR(ICOLH).EQ.MAXCP1)Z2(J)=PRED(I)
23385          IF(ICOLR(ICOLH).EQ.MAXCP2)Z2(J)=RES(I)
23386          IF(ICOLR(ICOLH).EQ.MAXCP3)Z2(J)=YPLOT(I)
23387          IF(ICOLR(ICOLH).EQ.MAXCP4)Z2(J)=XPLOT(I)
23388          IF(ICOLR(ICOLH).EQ.MAXCP5)Z2(J)=X2PLOT(I)
23389          IF(ICOLR(ICOLH).EQ.MAXCP6)Z2(J)=TAGPLO(I)
23390        ELSE
23391          Z2(J)=0.0
23392        ENDIF
23393C
23394        DO2670K=1,NCRTV
23395          ICOLH=ICOLH+1
23396          IJ=MAXN*(ICOLR(ICOLH)-1)+I
23397          IF(ICOLR(ICOLH).LE.MAXCOL)XDESGN(J,K)=V(IJ)
23398          IF(ICOLR(ICOLH).EQ.MAXCP1)XDESGN(J,K)=PRED(I)
23399          IF(ICOLR(ICOLH).EQ.MAXCP2)XDESGN(J,K)=RES(I)
23400          IF(ICOLR(ICOLH).EQ.MAXCP3)XDESGN(J,K)=YPLOT(I)
23401          IF(ICOLR(ICOLH).EQ.MAXCP4)XDESGN(J,K)=XPLOT(I)
23402          IF(ICOLR(ICOLH).EQ.MAXCP5)XDESGN(J,K)=X2PLOT(I)
23403          IF(ICOLR(ICOLH).EQ.MAXCP6)XDESGN(J,K)=TAGPLO(I)
23404 2670   CONTINUE
23405C
23406 2660 CONTINUE
23407      NLOCAL=J
23408C
23409      ICNT=0
23410      IF(NRESP.GE.1)THEN
23411        ICNT=ICNT+1
23412        IYNAM(1:4)=IVARN1(ICNT)(1:4)
23413        IYNAM(5:8)=IVARN2(ICNT)(1:4)
23414      ENDIF
23415      IF(NRESP.GE.2)THEN
23416        ICNT=ICNT+1
23417        IXNAM(1:4)=IVARN1(ICNT)(1:4)
23418        IXNAM(5:8)=IVARN2(ICNT)(1:4)
23419      ENDIF
23420      IF(NRESP.GE.3)THEN
23421        ICNT=ICNT+1
23422        IXNAM2(1:4)=IVARN1(ICNT)(1:4)
23423        IXNAM2(5:8)=IVARN2(ICNT)(1:4)
23424      ENDIF
23425      IF(NCRTV.GE.1)THEN
23426        ICNT=ICNT+1
23427        IX1NAM(1:4)=IVARN1(ICNT)(1:4)
23428        IX1NAM(5:8)=IVARN2(ICNT)(1:4)
23429      ENDIF
23430      IF(NCRTV.GE.2)THEN
23431        ICNT=ICNT+1
23432        IX2NAM(1:4)=IVARN1(ICNT)(1:4)
23433        IX2NAM(5:8)=IVARN2(ICNT)(1:4)
23434      ENDIF
23435      IF(NCRTV.GE.3)THEN
23436        ICNT=ICNT+1
23437        IX3NAM(1:4)=IVARN1(ICNT)(1:4)
23438        IX3NAM(5:8)=IVARN2(ICNT)(1:4)
23439      ENDIF
23440      IF(NCRTV.GE.4)THEN
23441        ICNT=ICNT+1
23442        IX4NAM(1:4)=IVARN1(ICNT)(1:4)
23443        IX4NAM(5:8)=IVARN2(ICNT)(1:4)
23444      ENDIF
23445      IF(NCRTV.GE.5)THEN
23446        ICNT=ICNT+1
23447        IX5NAM(1:4)=IVARN1(ICNT)(1:4)
23448        IX5NAM(5:8)=IVARN2(ICNT)(1:4)
23449      ENDIF
23450      IF(NCRTV.GE.6)THEN
23451        ICNT=ICNT+1
23452        IX6NAM(1:4)=IVARN1(ICNT)(1:4)
23453        IX6NAM(5:8)=IVARN2(ICNT)(1:4)
23454      ENDIF
23455      IF(NCRTV.GE.7)THEN
23456        ICNT=ICNT+1
23457        IX7NAM(1:4)=IVARN1(ICNT)(1:4)
23458        IX7NAM(5:8)=IVARN2(ICNT)(1:4)
23459      ENDIF
23460      IF(NCRTV.GE.8)THEN
23461        ICNT=ICNT+1
23462        IX8NAM(1:4)=IVARN1(ICNT)(1:4)
23463        IX8NAM(5:8)=IVARN2(ICNT)(1:4)
23464      ENDIF
23465C
23466      IF(NLOCAL.LE.0)THEN
23467        WRITE(ICOUT,999)
23468        CALL DPWRST('XXX','BUG ')
23469        WRITE(ICOUT,301)
23470        CALL DPWRST('XXX','BUG ')
23471        WRITE(ICOUT,2710)
23472 2710   FORMAT('      AFTER EXTRACTING THE SUBSET, THERE ARE NO')
23473        CALL DPWRST('XXX','BUG ')
23474        WRITE(ICOUT,2712)
23475 2712   FORMAT('      OBSERVATIONS REMAINING ON WHICH TO PERFORM')
23476        CALL DPWRST('XXX','BUG ')
23477        WRITE(ICOUT,2714)
23478 2714   FORMAT('      THE RELEVANT CROSS-TABULATION.')
23479        CALL DPWRST('XXX','BUG ')
23480        IERROR='YES'
23481        GOTO9000
23482      ENDIF
23483C
23484C               *****************************************************
23485C               **  STEP 8--                                       **
23486C               **  COMPUTE THE APPROPRIATE CROSS-TABULATION       **
23487C               **  STATISTIC--                                    **
23488C               **  (MEAN, STANDARD DEVIATION, RANGE, OR COUNT).   **
23489C               *****************************************************
23490C
23491      ISTEPN='8'
23492      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CRTA')
23493     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23494C
23495      IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
23496     1   ICASCT.EQ.'MDCL' .OR. ICASCT.EQ.'BRAT')THEN
23497        IHP='ALPH'
23498        IHP2='A   '
23499        IHWUSE='P'
23500        MESSAG='NO'
23501        CALL CHECKN(IHP,IHP2,IHWUSE,
23502     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,
23503     1              NUMNAM,MAXNAM,
23504     1              ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,
23505     1              ILOCP,IERROR)
23506        IF(IERROR.EQ.'YES')THEN
23507          ALPHA=0.95
23508        ELSE
23509          ALPHA=VALUE(ILOCP)
23510          IF(ALPHA.GE.1.0 .AND. ALPHA.LE.100.0)ALPHA=ALPHA/100.
23511          IF(ALPHA.LE.0.0 .OR. ALPHA.GE.1.0)ALPHA=0.95
23512          IF(ALPHA.LT.0.5)ALPHA=1.0 - ALPHA
23513          IF(IBINTA.EQ.'LOWE' .OR. IBINTA.EQ.'UPPE')THEN
23514            ATEMP=1.0 - ALPHA
23515            ATEMP=2.0*ATEMP
23516            ALPHA=1.0 - ATEMP
23517          ENDIF
23518        ENDIF
23519      ELSE
23520        ALPHA=0.05
23521      ENDIF
23522C
23523      IF(IFLAGL.EQ.'ON')THEN
23524      ELSE
23525        CALL DPCRT2(Y1,Z1,Z2,XDESGN,NLOCAL,MAXGR9,
23526     1              NUMVAR,ICASCT,ICTNAM,
23527     1              XH1DIS,
23528     1              TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,
23529     1              XNTRIA,XACLOW,XACUPP,
23530     1              ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
23531     1              DTEMP1,DTEMP2,DTEMP3,
23532     1              ISEED,IQUAME,IQUASE,PSTAMV,ALPHA,
23533     1              IXVAR,IX2VAR,IYVAR,
23534     1              IYNAM,IXNAM,IXNAM2,
23535     1              IX1NAM,IX2NAM,IX3NAM,IX4NAM,IX5NAM,IX6NAM,
23536     1              IX7NAM,IX8NAM,
23537     1              ICAPSW,ICAPTY,IFORSW,NCRTV,MAXOBV,
23538     1              Y,X,D,DSIZE,DFILL,DCOLOR,DSYMB,
23539     1              XTEMP6,XTEMP7,NPLOTP,
23540     1              ISUBRO,IBUGA3,IERROR)
23541      ENDIF
23542C
23543C               *****************
23544C               **  STEP 90--  **
23545C               **  EXIT       **
23546C               *****************
23547C
23548 9000 CONTINUE
23549      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CRTA')THEN
23550        WRITE(ICOUT,999)
23551        CALL DPWRST('XXX','BUG ')
23552        WRITE(ICOUT,9011)
23553 9011   FORMAT('***** AT THE END       OF DPCRTA--')
23554        CALL DPWRST('XXX','BUG ')
23555        WRITE(ICOUT,9012)IFOUND,IERROR,ICASCT
23556 9012   FORMAT('IFOUND,IERROR,ICASCT = ',2(A4,2X),A4)
23557        CALL DPWRST('XXX','BUG ')
23558        WRITE(ICOUT,9013)NPLOTP,NS,NCRTV
23559 9013   FORMAT('NPLOTP,NS,ICASCT = ',3I8)
23560        CALL DPWRST('XXX','BUG ')
23561        IF(NPLOTP.GT.0)THEN
23562          DO9015I=1,MIN(200,NPLOTP)
23563          WRITE(ICOUT,9016)I,Y(I),X(I),D(I)
23564 9016     FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5)
23565          CALL DPWRST('XXX','BUG ')
23566 9015     CONTINUE
23567        ENDIF
23568      ENDIF
23569C
23570      RETURN
23571      END
23572      SUBROUTINE DPCRT2(Y,Z,Z2,TAG,N,MAXGRP,
23573     1                  NUMV2,ICASCT,ICTNAM,
23574     1                  XIDTEM,
23575     1                  TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,
23576     1                  XNTRIA,XACLOW,XACUPP,
23577     1                  ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
23578     1                  DTEMP1,DTEMP2,DTEMP3,
23579     1                  ISEED,IQUAME,IQUASE,PSTAMV,ALPHA,
23580     1                  IXVAR,IX2VAR,IYVAR,
23581     1                  IYNAM,IXNAM,IXNAM2,
23582     1                  IX1NAM,IX2NAM,IX3NAM,IX4NAM,IX5NAM,IX6NAM,
23583     1                  IX7NAM,IX8NAM,
23584     1                  ICAPSW,ICAPTY,IFORSW,NCRTV,MAXNXT,
23585     1                  Y2,X2,D2,DSIZE,DFILL,DCOLOR,DSYMB,
23586     1                  XPLOT,YPLOT,N2,
23587     1                  ISUBRO,IBUGA3,IERROR)
23588C
23589C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
23590C              THAT WILL DEFINE A CROSS-TABULATION
23591C              OF THE FOLLOWING TYPES--
23592C                 1) MEAN CROSS-TABULATION;
23593C                 2) STANDARD DEVIATION CROSS-TABULATION;
23594C                 3) RANGE CROSS-TABULATION;
23595C                 4) COUNT CROSS-TABULATION.
23596C                 5) SUM CROSS-TABULATION`
23597C                 6) CHI-SQUARE ANALYSIS CROSS_TABULATION
23598C     WRITTEN BY--ALAN HECKERT
23599C                 STATISTICAL ENGINEERING DIVISION
23600C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
23601C                 GAITHERSBURG, MD 20899-8980
23602C                 PHONE--301-975-2899
23603C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
23604C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
23605C     REFERENCE--ASTM MANUAL STP-15D, PAGES 78-84, 100-105
23606C     LANGUAGE--ANSI FORTRAN (1977)
23607C     VERSION NUMBER--82/7
23608C     ORIGINAL VERSION--JUNE      1978.
23609C     UPDATED         --OCTOBER   1978.
23610C     UPDATED         --JANUARY   1981.
23611C     UPDATED         --DECEMBER  1981.
23612C     UPDATED         --APRIL     1982.
23613C     UPDATED         --MAY       1982.
23614C     UPDATED         --NOVEMBER  1989.  COMMENT OUT CHECK OF NUMSET=N
23615C     UPDATED         --DECEMBEDR 1989.  FIX CROSS-TAB X1 X2
23616C     UPDATED         --OCTOBER   1992.  SUPPRESS ERROR MESSAGE FOR
23617C                                        ZERO COUNT CELLS.
23618C                                        ADD SUM AND CHI-SQUARE OPTIONS
23619C     UPDATED         --MARCH     1994.  FIX CROSS TABU SUM CASE
23620C     UPDATED         --MARCH     1994.  MODIFY CROSS TABU CHI-SQUARE
23621C                                        OUTPUT
23622C     UPDATED         --DECEMBER  1998.  WRITE OUTPUT TO FILE
23623C     UPDATED         --AUGUST    2002.  USE CMPSTA TO COMPUTE THE
23624C                                        STATISTICS
23625C     UPDATED         --AUGUST    2002.  GREATLY EXPAND LIST OF
23626C                                        SUPPORTED STATISICS
23627C     UPDATED         --AUGUST    2002.  SUPPORT FOR HTML OUTPUT
23628C     UPDATED         --APRIL     2003.  ADD SN AND QN (AND DIFFERENCE
23629C                                        OF), REQUIRED ADDITIONAL
23630C                                        SCRATCH ARAYS
23631C     UPDATED         --OCTOBER   2003.  SUPPORT FOR LATEX OUTPUT
23632C     UPDATED         --APRIL     2008.  SUPPORT FOR RTF OUTPUT
23633C     UPDATED         --APRIL     2008.  SUPPORT FOR 3, 4, 5, OR 6
23634C                                        CROSS-TABULATION VARIABLES
23635C     UPDATED         --APRIL     2008.  "BINOMIAL PROBABILITY" OPTION
23636C                                        (THIS RECIEVES SPECIAL
23637C                                        HANDLING)
23638C     UPDATED         --AUGUST    2008.  FIXED SOME BUGS
23639C     UPDATED         --JUNE      2010.  CALL LIST TO CMPSTA
23640C     UPDATED         --MAY       2014.  SUPPORT UP TO 8 CROSS-TAB
23641C                                        VARIABLES
23642C
23643C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
23644C
23645      CHARACTER*40 ICTNAM
23646      CHARACTER*4 ICASCT
23647      CHARACTER*4 IXVAR
23648      CHARACTER*4 IX2VAR
23649      CHARACTER*4 IYVAR
23650      CHARACTER*4 IQUAME
23651      CHARACTER*4 IQUASE
23652      CHARACTER*4 ICAPSW
23653      CHARACTER*4 ICAPTY
23654      CHARACTER*4 IFORSW
23655      CHARACTER*4 IBUGA3
23656      CHARACTER*4 IERROR
23657C
23658      CHARACTER*8 IYNAM
23659      CHARACTER*8 IXNAM
23660      CHARACTER*8 IXNAM2
23661      CHARACTER*8 IX1NAM
23662      CHARACTER*8 IX2NAM
23663      CHARACTER*8 IX3NAM
23664      CHARACTER*8 IX4NAM
23665      CHARACTER*8 IX5NAM
23666      CHARACTER*8 IX6NAM
23667      CHARACTER*8 IX7NAM
23668      CHARACTER*8 IX8NAM
23669C
23670      CHARACTER*4 ISUBRO
23671      CHARACTER*4 IWRITE
23672      CHARACTER*4 ISUBN1
23673      CHARACTER*4 ISUBN2
23674      CHARACTER*4 ISTEPN
23675C
23676C---------------------------------------------------------------------
23677C
23678      DIMENSION Y(*)
23679      DIMENSION Z(*)
23680      DIMENSION Z2(*)
23681      DIMENSION XIDTEM(MAXNXT,MAXGRP)
23682      DIMENSION Y2(*)
23683      DIMENSION X2(*)
23684      DIMENSION D2(*)
23685      DIMENSION DSIZE(*)
23686      DIMENSION DFILL(*)
23687      DIMENSION DCOLOR(*)
23688      DIMENSION DSYMB(*)
23689      DIMENSION XPLOT(*)
23690      DIMENSION YPLOT(*)
23691C
23692      DIMENSION TAG(MAXNXT,MAXGRP)
23693      DIMENSION TEMP(*)
23694      DIMENSION TEMPZ(*)
23695      DIMENSION TEMPZ2(*)
23696      DIMENSION XTEMP1(*)
23697      DIMENSION XTEMP2(*)
23698      DIMENSION XTEMP3(*)
23699      DIMENSION XNTRIA(*)
23700      DIMENSION XACLOW(*)
23701      DIMENSION XACUPP(*)
23702C
23703      INTEGER ITEMP1(*)
23704      INTEGER ITEMP2(*)
23705      INTEGER ITEMP3(*)
23706      INTEGER ITEMP4(*)
23707      INTEGER ITEMP5(*)
23708      INTEGER ITEMP6(*)
23709C
23710      INTEGER NUMSET(8)
23711C
23712      DOUBLE PRECISION DTEMP1(*)
23713      DOUBLE PRECISION DTEMP2(*)
23714      DOUBLE PRECISION DTEMP3(*)
23715C
23716C---------------------------------------------------------------------
23717C
23718      INCLUDE 'DPCOP2.INC'
23719C
23720C-----START POINT-----------------------------------------------------
23721C
23722      ISUBN1='DPCR'
23723      ISUBN2='T2  '
23724C
23725      I2=0
23726C
23727      AN=0.0
23728      YUPPER=0.0
23729      YLOWER=0.0
23730C
23731C     CHECK THE INPUT ARGUMENTS FOR ERRORS
23732C
23733      IF(N.LT.1)THEN
23734        WRITE(ICOUT,999)
23735  999   FORMAT(1X)
23736        CALL DPWRST('XXX','BUG ')
23737        WRITE(ICOUT,31)
23738   31   FORMAT('***** ERROR IN CROSS-TABULATE--')
23739        CALL DPWRST('XXX','BUG ')
23740        WRITE(ICOUT,32)
23741   32   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 1.')
23742        CALL DPWRST('XXX','BUG ')
23743        WRITE(ICOUT,34)N
23744   34   FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6)
23745        CALL DPWRST('XXX','BUG ')
23746        WRITE(ICOUT,999)
23747        CALL DPWRST('XXX','BUG ')
23748        IERROR='YES'
23749        GOTO9000
23750      ENDIF
23751C
23752CCCCC MAY 2008: DO NOT TREAT FOLLOWING AS AN ERROR.
23753CCCCC           PRINT A WARNING, BUT CONTINUE TO PROCESS.
23754CCCCC
23755CCCCC           WHEN CROSS-TABBING MULTIPLE VARIABLES, CAN
23756CCCCC           GET A LOT OF ERROR MESSAGES DUE TO CLASSES
23757CCCCC           WITH SMALL NUMBER OF ELEMENTS.  SO DO NOT
23758CCCCC           PRINT WARNING MESSAGE.
23759C
23760CCCCC IF(IYVAR.EQ.'ON')THEN
23761CCCCC   HOLD=Y(1)
23762CCCCC   DO60I=1,N
23763CCCCC     IF(Y(I).NE.HOLD)GOTO69
23764CCC60   CONTINUE
23765CCCCC   WRITE(ICOUT,999)
23766CCCCC   CALL DPWRST('XXX','BUG ')
23767CCCCC   WRITE(ICOUT,61)
23768CCC61   FORMAT('***** WARNING IN CROSS-TABULATE--')
23769CCCCC   CALL DPWRST('XXX','BUG ')
23770CCCCC   WRITE(ICOUT,62)
23771CCC62   FORMAT('      ALL RESPONSE VARIABLE ELEMENTS')
23772CCCCC   CALL DPWRST('XXX','BUG ')
23773CCCCC   WRITE(ICOUT,63)HOLD
23774CCC63   FORMAT('      ARE IDENTICALLY EQUAL TO ',G15.7)
23775CCCCC   CALL DPWRST('XXX','BUG ')
23776CCCCC   WRITE(ICOUT,999)
23777CCCCC   CALL DPWRST('XXX','BUG ')
23778CCC69   CONTINUE
23779CCCCC ENDIF
23780C
23781      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CRT2')THEN
23782        WRITE(ICOUT,70)
23783   70   FORMAT('AT THE BEGINNING OF DPCRT2--')
23784        CALL DPWRST('XXX','BUG ')
23785        WRITE(ICOUT,71)N,ICASCT,NUMV2,NCRTV
23786   71   FORMAT('N,ICASCT,NUMV2,NCRTV = ',I8,2X,A4,I8,2X,I5)
23787        CALL DPWRST('XXX','BUG ')
23788        DO72I=1,N
23789          WRITE(ICOUT,73)I,Y(I),Z(I),Z2(I),(TAG(I,J),J=1,MAXGRP)
23790   73     FORMAT('I,Y(I),Z(I),Z2(I),TAG1-6(I) = ',I8,12F10.3)
23791          CALL DPWRST('XXX','BUG ')
23792   72   CONTINUE
23793        WRITE(ICOUT,74)IQUAME,IQUASE,PSTAMV
23794   74   FORMAT('IQUAME,IQUASE,PSTAMV = ',2(A4,2X),G15.7)
23795        CALL DPWRST('XXX','BUG ')
23796      ENDIF
23797C
23798C               ******************************************************
23799C               **  STEP 1--                                        **
23800C               **  DETERMINE THE NUMBER OF DISTINCT VALUES         **
23801C               **  FOR THE GROUP VARIABLES (TAG1, TAG2)            **
23802C               **  IF ALL VALUES ARE DISTINCT, THEN THIS           **
23803C               **  IMPLIES WE HAVE THE NO REPLICATION CASE         **
23804C               **  WHICH IS AN ERROR CONDITION FOR A PLOT.         **
23805C               ******************************************************
23806C
23807      ISTEPN='1'
23808      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CRT2')
23809     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23810C
23811      DO100J=1,MAXGRP
23812        NUMSET(J)=0
23813  100 CONTINUE
23814C
23815      DO110J=1,NCRTV
23816        CALL DISTIN(TAG(1,J),N,IWRITE,XIDTEM(1,J),NUMSET(J),
23817     1              IBUGA3,IERROR)
23818        CALL SORT(XIDTEM(1,J),NUMSET(J),TEMP)
23819        DO120I=1,NUMSET(J)
23820          XIDTEM(I,J)=TEMP(I)
23821  120   CONTINUE
23822        IF(NUMSET(J).LT.1 .OR. NUMSET(J).GT.N)THEN
23823          WRITE(ICOUT,999)
23824          CALL DPWRST('XXX','BUG ')
23825          WRITE(ICOUT,31)
23826          CALL DPWRST('XXX','BUG ')
23827          WRITE(ICOUT,111)J,NUMSET(J)
23828  111     FORMAT('      THE NUMBER OF SETS FOR THE GROUP ',I1,
23829     1           ' VARIABLE, ',I8,',')
23830          CALL DPWRST('XXX','BUG ')
23831          WRITE(ICOUT,113)
23832  113     FORMAT('      IS EITHER LESS THAN ONE OR GREATER THAN THE ',
23833     1           'NUMBER')
23834          CALL DPWRST('XXX','BUG ')
23835          WRITE(ICOUT,115)N
23836  115     FORMAT('      OF OBSERVATIONS, ',I8,'.')
23837          CALL DPWRST('XXX','BUG ')
23838          IERROR='YES'
23839          GOTO9000
23840        ENDIF
23841  110 CONTINUE
23842C
23843      AN=N
23844      ANUMS1=NUMSET(1)
23845      ANUMS2=NUMSET(2)
23846      ANUMS3=NUMSET(3)
23847      ANUMS4=NUMSET(4)
23848      ANUMS5=NUMSET(5)
23849      ANUMS6=NUMSET(6)
23850      ANUMS7=NUMSET(7)
23851      ANUMS8=NUMSET(8)
23852C
23853C               ***********************************************
23854C               **  STEP 5--                                 **
23855C               **  COMPUTE THE VARIOUS CROSS-TAB STATISTICS **
23856C               ***********************************************
23857C
23858      ISTEPN='5.1'
23859      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CRT2')
23860     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23861C
23862      IWRITE='OFF'
23863C
23864      IF(NCRTV.EQ.1)THEN
23865        CALL DPCRT0(Y,Z,Z2,TAG,N,
23866     1              NUMV2,ICASCT,ICTNAM,
23867     1              XIDTEM(1,1),
23868     1              NUMSET(1),
23869     1              TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,
23870     1              XNTRIA,XACLOW,XACUPP,
23871     1              ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
23872     1              DTEMP1,DTEMP2,DTEMP3,
23873     1              ISEED,ALPHA,
23874     1              IXVAR,IX2VAR,IYVAR,
23875     1              IYNAM,IXNAM,IXNAM2,IX1NAM,
23876     1              ICAPSW,ICAPTY,IFORSW,
23877     1              MAXNXT,
23878     1              Y2,X2,N2,ISUBRO,IBUGA3,IERROR)
23879      ELSEIF(NCRTV.EQ.2)THEN
23880        CALL DPCRT3(Y,Z,Z2,TAG(1,1),TAG(1,2),N,
23881     1              NUMV2,ICASCT,ICTNAM,
23882     1              XIDTEM(1,1),XIDTEM(1,2),
23883     1              NUMSET(1),NUMSET(2),
23884     1              TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,
23885     1              XNTRIA,XACLOW,XACUPP,
23886     1              ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
23887     1              DTEMP1,DTEMP2,DTEMP3,
23888     1              ISEED,ALPHA,
23889     1              IXVAR,IX2VAR,IYVAR,
23890     1              IYNAM,IXNAM,IXNAM2,
23891     1              IX1NAM,IX2NAM,
23892     1              ICAPSW,ICAPTY,IFORSW,
23893     1              MAXNXT,
23894     1              Y2,X2,D2,N2,ISUBRO,IBUGA3,IERROR)
23895      ELSEIF(NCRTV.EQ.3)THEN
23896        CALL DPCRT4(Y,Z,Z2,TAG(1,1),TAG(1,2),TAG(1,3),N,
23897     1              NUMV2,ICASCT,ICTNAM,
23898     1              XIDTEM(1,1),XIDTEM(1,2),XIDTEM(1,3),
23899     1              NUMSET(1),NUMSET(2),NUMSET(3),
23900     1              TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,
23901     1              XNTRIA,XACLOW,XACUPP,
23902     1              ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
23903     1              DTEMP1,DTEMP2,DTEMP3,
23904     1              ISEED,ALPHA,
23905     1              IXVAR,IX2VAR,IYVAR,
23906     1              IYNAM,IXNAM,IXNAM2,
23907     1              IX1NAM,IX2NAM,IX3NAM,
23908     1              ICAPSW,ICAPTY,IFORSW,
23909     1              MAXNXT,
23910     1              Y2,X2,D2,DSIZE,N2,ISUBRO,IBUGA3,IERROR)
23911      ELSEIF(NCRTV.EQ.4)THEN
23912        CALL DPCRT5(Y,Z,Z2,TAG(1,1),TAG(1,2),TAG(1,3),TAG(1,4),N,
23913     1              NUMV2,ICASCT,ICTNAM,
23914     1              XIDTEM(1,1),XIDTEM(1,2),XIDTEM(1,3),XIDTEM(1,4),
23915     1              NUMSET(1),NUMSET(2),NUMSET(3),NUMSET(4),
23916     1              TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,
23917     1              XNTRIA,XACLOW,XACUPP,
23918     1              ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
23919     1              DTEMP1,DTEMP2,DTEMP3,
23920     1              ISEED,ALPHA,
23921     1              IXVAR,IX2VAR,IYVAR,
23922     1              IYNAM,IXNAM,IXNAM2,
23923     1              IX1NAM,IX2NAM,IX3NAM,IX4NAM,
23924     1              ICAPSW,ICAPTY,IFORSW,
23925     1              MAXNXT,
23926     1              Y2,X2,D2,DSIZE,DCOLOR,N2,ISUBRO,IBUGA3,IERROR)
23927      ELSEIF(NCRTV.EQ.5)THEN
23928        CALL DPCRT6(Y,Z,Z2,TAG(1,1),TAG(1,2),TAG(1,3),
23929     1              TAG(1,4),TAG(1,5),N,
23930     1              NUMV2,ICASCT,ICTNAM,
23931     1              XIDTEM(1,1),XIDTEM(1,2),XIDTEM(1,3),
23932     1              XIDTEM(1,4),XIDTEM(1,5),
23933     1              NUMSET(1),NUMSET(2),NUMSET(3),
23934     1              NUMSET(4),NUMSET(5),
23935     1              TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,
23936     1              XNTRIA,XACLOW,XACUPP,
23937     1              ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
23938     1              DTEMP1,DTEMP2,DTEMP3,
23939     1              ISEED,ALPHA,
23940     1              IXVAR,IX2VAR,IYVAR,
23941     1              IYNAM,IXNAM,IXNAM2,
23942     1              IX1NAM,IX2NAM,IX3NAM,IX4NAM,IX5NAM,
23943     1              ICAPSW,ICAPTY,IFORSW,
23944     1              MAXNXT,
23945     1              Y2,X2,D2,DSIZE,DCOLOR,DFILL,N2,
23946     1              ISUBRO,IBUGA3,IERROR)
23947      ELSEIF(NCRTV.EQ.6)THEN
23948        CALL DPCRT7(Y,Z,Z2,TAG(1,1),TAG(1,2),TAG(1,3),TAG(1,4),
23949     1              TAG(1,5),TAG(1,6),N,
23950     1              NUMV2,ICASCT,ICTNAM,
23951     1              XIDTEM(1,1),XIDTEM(1,2),XIDTEM(1,3),
23952     1              XIDTEM(1,4),XIDTEM(1,5),XIDTEM(1,6),
23953     1              NUMSET(1),NUMSET(2),NUMSET(3),
23954     1              NUMSET(4),NUMSET(5),NUMSET(6),
23955     1              TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,
23956     1              XNTRIA,XACLOW,XACUPP,
23957     1              ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
23958     1              DTEMP1,DTEMP2,DTEMP3,
23959     1              ISEED,ALPHA,
23960     1              IXVAR,IX2VAR,IYVAR,
23961     1              IYNAM,IXNAM,IXNAM2,
23962     1              IX1NAM,IX2NAM,IX3NAM,IX4NAM,IX5NAM,
23963     1              IX6NAM,
23964     1              ICAPSW,ICAPTY,IFORSW,
23965     1              MAXNXT,
23966     1              Y2,X2,D2,DSIZE,DCOLOR,DFILL,DSYMB,N2,
23967     1              ISUBRO,IBUGA3,IERROR)
23968      ELSEIF(NCRTV.EQ.7)THEN
23969        CALL DPCRT8(Y,Z,Z2,TAG(1,1),TAG(1,2),TAG(1,3),TAG(1,4),
23970     1              TAG(1,5),TAG(1,6),TAG(1,7),N,
23971     1              NUMV2,ICASCT,ICTNAM,
23972     1              XIDTEM(1,1),XIDTEM(1,2),XIDTEM(1,3),
23973     1              XIDTEM(1,4),XIDTEM(1,5),XIDTEM(1,6),
23974     1              XIDTEM(1,7),
23975     1              NUMSET(1),NUMSET(2),NUMSET(3),NUMSET(4),
23976     1              NUMSET(5),NUMSET(6),NUMSET(7),
23977     1              TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,
23978     1              XNTRIA,XACLOW,XACUPP,
23979     1              ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
23980     1              DTEMP1,DTEMP2,DTEMP3,
23981     1              ISEED,ALPHA,
23982     1              IXVAR,IX2VAR,IYVAR,
23983     1              IYNAM,IXNAM,IXNAM2,
23984     1              IX1NAM,IX2NAM,IX3NAM,IX4NAM,IX5NAM,
23985     1              IX6NAM,IX7NAM,
23986     1              ICAPSW,ICAPTY,IFORSW,
23987     1              MAXNXT,
23988     1              Y2,X2,D2,DSIZE,DCOLOR,DFILL,DSYMB,XPLOT,N2,
23989     1              ISUBRO,IBUGA3,IERROR)
23990      ELSEIF(NCRTV.EQ.8)THEN
23991        CALL DPCRT9(Y,Z,Z2,TAG(1,1),TAG(1,2),TAG(1,3),TAG(1,4),
23992     1              TAG(1,5),TAG(1,6),TAG(1,7),TAG(1,8),N,
23993     1              NUMV2,ICASCT,ICTNAM,
23994     1              XIDTEM(1,1),XIDTEM(1,2),XIDTEM(1,3),
23995     1              XIDTEM(1,4),XIDTEM(1,5),XIDTEM(1,6),
23996     1              XIDTEM(1,7),XIDTEM(1,8),
23997     1              NUMSET(1),NUMSET(2),NUMSET(3),NUMSET(4),
23998     1              NUMSET(5),NUMSET(6),NUMSET(7),NUMSET(8),
23999     1              TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,
24000     1              XNTRIA,XACLOW,XACUPP,
24001     1              ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
24002     1              DTEMP1,DTEMP2,DTEMP3,
24003     1              ISEED,ALPHA,
24004     1              IXVAR,IX2VAR,IYVAR,
24005     1              IYNAM,IXNAM,IXNAM2,
24006     1              IX1NAM,IX2NAM,IX3NAM,IX4NAM,IX5NAM,
24007     1              IX6NAM,IX7NAM,IX8NAM,
24008     1              ICAPSW,ICAPTY,IFORSW,
24009     1              MAXNXT,
24010     1              Y2,X2,D2,DSIZE,DCOLOR,DFILL,DSYMB,XPLOT,YPLOT,N2,
24011     1              ISUBRO,IBUGA3,IERROR)
24012      ENDIF
24013C
24014C               ******************
24015C               **   STEP 90--  **
24016C               **   EXIT       **
24017C               ******************
24018C
24019 9000 CONTINUE
24020      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CRT2')THEN
24021        WRITE(ICOUT,999)
24022        CALL DPWRST('XXX','BUG ')
24023        WRITE(ICOUT,9011)
24024 9011   FORMAT('***** AT THE END       OF DPCRT2--')
24025        CALL DPWRST('XXX','BUG ')
24026        WRITE(ICOUT,9012)ICASCT,N,N2,NUMV2,IERROR
24027 9012   FORMAT('ICASCT,N,N2,NUMV2,IERROR = ',A4,3I8,2X,A4)
24028        CALL DPWRST('XXX','BUG ')
24029        WRITE(ICOUT,9015)NUMSET(1),NUMSET(2),N2
24030 9015   FORMAT('NUMSET(1),NUMSET(2),N2 = ',3I8)
24031        CALL DPWRST('XXX','BUG ')
24032        WRITE(ICOUT,9016)ANUMS1,ANUMS2
24033 9016   FORMAT('ANUMS1,ANUMS2 = ',2E15.7)
24034        CALL DPWRST('XXX','BUG ')
24035        DO9020I=1,N2
24036          WRITE(ICOUT,9021)I,Y2(I),X2(I)
24037 9021     FORMAT('I,Y2(I),X2(I) = ',I8,2E15.7)
24038          CALL DPWRST('XXX','BUG ')
24039 9020   CONTINUE
24040      ENDIF
24041C
24042      RETURN
24043      END
24044      SUBROUTINE DPCRT3(Y,Z,Z2,TAG1,TAG2,N,
24045     1                  NUMV2,ICASCT,ICTNAM,
24046     1                  XIDTEM,XIDTE2,
24047     1                  NUMSE1,NUMSE2,
24048     1                  TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,
24049     1                  XNTRIA,XACLOW,XACUPP,
24050     1                  ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
24051     1                  DTEMP1,DTEMP2,DTEMP3,
24052     1                  ISEED,ALPHA,
24053     1                  IXVAR,IX2VAR,IYVAR,
24054     1                  IYNAM,IXNAM,IXNAM2,
24055     1                  IX1NAM,IX2NAM,
24056     1                  ICAPSW,ICAPTY,IFORSW,
24057     1                  MAXNXT,
24058     1                  Y2,X2,D2,N2,ISUBRO,IBUGA3,IERROR)
24059C
24060C     PURPOSE--GENERATE A TWO-WAY CROSS-TABULATION AND
24061C              OPTIONALLY PRINT THE RESULTS TO AN ASCII,
24062C              HTML, LATEX, OR RTF TABLE.
24063C     WRITTEN BY--ALAN HECKERT
24064C                 STATISTICAL ENGINEERING DIVISION
24065C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
24066C                 GAITHERSBURG, MD 20899-8980
24067C                 PHONE--301-975-2899
24068C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
24069C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
24070C     REFERENCE--ASTM MANUAL STP-15D, PAGES 78-84, 100-105
24071C     LANGUAGE--ANSI FORTRAN (1977)
24072C     VERSION NUMBER--2008/4
24073C     ORIGINAL VERSION--APRIL     2008. SPLIT OFF FROM DPCRT2 ROUTINE
24074C     UPDATED         --SEPTEMBER 2008. ACCOMODATE "MISSING" DATA
24075C     UPDATED         --JANUARY   2010. TREAT BINOMIAL RATIO IN A
24076C                                       SIMILAR FASHION TO BINOMIAL
24077C                                       PROBABILITY
24078C     UPDATED         --JUNE      2010. CALL LIST TO CMPSTA
24079C     UPDATED         --JUNE      2010. USE DPDTA5 TO PRINT TABLE
24080C
24081C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
24082C
24083      CHARACTER*4 ICASCT
24084      CHARACTER*40 ICTNAM
24085      CHARACTER*4 IXVAR
24086      CHARACTER*4 IX2VAR
24087      CHARACTER*4 IYVAR
24088      CHARACTER*4 ICAPSW
24089      CHARACTER*4 ICAPTY
24090      CHARACTER*4 IFORSW
24091      CHARACTER*4 IBUGA3
24092      CHARACTER*4 IERROR
24093C
24094      PARAMETER(NUMCLI=7)
24095      PARAMETER(MAXLIN=2)
24096      PARAMETER (MAXROW=30)
24097      CHARACTER*60 ITITLE
24098      CHARACTER*60 ITITL9
24099      CHARACTER*4  ALIGN(NUMCLI)
24100      CHARACTER*4  VALIGN(NUMCLI)
24101      INTEGER      NCTEXT(MAXROW)
24102      INTEGER      IDIGIT(MAXROW)
24103      INTEGER      NTOT(MAXROW)
24104      CHARACTER*60 ITITL2(MAXLIN,NUMCLI)
24105      CHARACTER*15 IVALUE(MAXROW,NUMCLI)
24106      CHARACTER*4  ITYPCO(NUMCLI)
24107      INTEGER      NCTIT2(MAXLIN,NUMCLI)
24108      INTEGER      NCVALU(MAXROW,NUMCLI)
24109      INTEGER      IWHTML(NUMCLI)
24110      INTEGER      IWRTF(NUMCLI)
24111      REAL         AMAT(MAXROW,NUMCLI)
24112      LOGICAL IFRST
24113      LOGICAL ILAST
24114      LOGICAL IFLAGS
24115      LOGICAL IFLAGE
24116C
24117      CHARACTER*8 IYNAM
24118      CHARACTER*8 IXNAM
24119      CHARACTER*8 IXNAM2
24120      CHARACTER*8 IX1NAM
24121      CHARACTER*8 IX2NAM
24122C
24123      CHARACTER*4 ISUBRO
24124      CHARACTER*4 IWRITE
24125      CHARACTER*4 IBFLAG
24126      CHARACTER*4 ISUBN1
24127      CHARACTER*4 ISUBN2
24128      CHARACTER*4 ISTEPN
24129C
24130C---------------------------------------------------------------------
24131C
24132      DIMENSION Y(*)
24133      DIMENSION Z(*)
24134      DIMENSION Z2(*)
24135      DIMENSION XIDTEM(*)
24136      DIMENSION XIDTE2(*)
24137      DIMENSION Y2(*)
24138      DIMENSION X2(*)
24139      DIMENSION D2(*)
24140C
24141      DIMENSION TAG1(*)
24142      DIMENSION TAG2(*)
24143      DIMENSION TEMP(*)
24144      DIMENSION TEMPZ(*)
24145      DIMENSION TEMPZ2(*)
24146      DIMENSION XTEMP1(*)
24147      DIMENSION XTEMP2(*)
24148      DIMENSION XTEMP3(*)
24149      DIMENSION XNTRIA(*)
24150      DIMENSION XACLOW(*)
24151      DIMENSION XACUPP(*)
24152C
24153      INTEGER ITEMP1(*)
24154      INTEGER ITEMP2(*)
24155      INTEGER ITEMP3(*)
24156      INTEGER ITEMP4(*)
24157      INTEGER ITEMP5(*)
24158      INTEGER ITEMP6(*)
24159C
24160      DOUBLE PRECISION DTEMP1(*)
24161      DOUBLE PRECISION DTEMP2(*)
24162      DOUBLE PRECISION DTEMP3(*)
24163C
24164      CHARACTER*4 IOP
24165C
24166      INCLUDE 'DPCOST.INC'
24167      INCLUDE 'DPCOP2.INC'
24168C
24169C-----START POINT-----------------------------------------------------
24170C
24171      ISUBN1='DPCR'
24172      ISUBN2='T3  '
24173C
24174      I2=0
24175C
24176      AN=INT(N+0.01)
24177      ANUMS1=INT(NUMSE1+0.01)
24178      ANUMS2=INT(NUMSE2+0.01)
24179C
24180C               ***********************************************
24181C               **  STEP 5--                                 **
24182C               **  COMPUTE THE VARIOUS CROSS-TAB STATISTICS **
24183C               ***********************************************
24184C
24185      ISTEPN='5.1'
24186      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CRT3')
24187     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24188C
24189C     ALLOW THE   SET WRITE DECIMALS COMMAND    TO BE USED TO
24190C     DETERMINE HOW MANY DIGITS PRINTED IN TABLE.
24191C
24192      NUMDIG=-7
24193      IF(IFORSW.EQ.'1')NUMDIG=1
24194      IF(IFORSW.EQ.'2')NUMDIG=2
24195      IF(IFORSW.EQ.'3')NUMDIG=3
24196      IF(IFORSW.EQ.'4')NUMDIG=4
24197      IF(IFORSW.EQ.'5')NUMDIG=5
24198      IF(IFORSW.EQ.'6')NUMDIG=6
24199      IF(IFORSW.EQ.'7')NUMDIG=7
24200      IF(IFORSW.EQ.'8')NUMDIG=8
24201      IF(IFORSW.EQ.'9')NUMDIG=9
24202      IF(IFORSW.EQ.'0')NUMDIG=10
24203      IF(IFORSW.EQ.'-2')NUMDIG=-2
24204      IF(IFORSW.EQ.'-3')NUMDIG=-3
24205      IF(IFORSW.EQ.'-4')NUMDIG=-4
24206      IF(IFORSW.EQ.'-5')NUMDIG=-5
24207      IF(IFORSW.EQ.'-6')NUMDIG=-6
24208      IF(IFORSW.EQ.'-7')NUMDIG=-7
24209      IF(IFORSW.EQ.'-8')NUMDIG=-8
24210      IF(IFORSW.EQ.'-9')NUMDIG=-9
24211C
24212C     NOTE 9/2008: IN FOLLOWING, WE NEED TO DISTINGUISH BETWEEN
24213C                  EMPTY SETS DUE TO NO POINTS FALLING IN THE
24214C                  PARTICULAR CROSS TABULATION (IN WHICH CASE,
24215C                  WE WANT TO SKIP IN THE OUTPUT FILE) AND EMPTY
24216C                  SETS DUE TO ALL POINTS IN THE PARTICULAR
24217C                  CROSS TABULATION BEING MISSING (IN WHICH CASE,
24218C                  WE MAY WANT TO WRITE A 0 OR A MISSING VALUE).
24219C
24220C                  THERE ARE 2 MISSING VALUES:
24221C
24222C                  PSTAMV   - SPECIFIES WHETHER THE INPUT DATA
24223C                             VALUE IS TO BE INCLUDED IN THE
24224C                             COMPUTATION OF THE STATISTIC
24225C
24226C                  PCTAMV    - IF ALL THE DATA IS MISSING, THIS
24227C                              IS THE VALUE TO USE IN WRITING THE
24228C                              CROSS TABULATE OUTPUT.
24229C
24230      IWRITE='OFF'
24231      IBFLAG=ICASCT
24232      IF(IBFLAG.EQ.'BRAT')IBFLAG='BPRO'
24233C
24234      EPS=0.1E-7
24235      J=0
24236      NRESP=NUMV2-2
24237      DO1110ISET1=1,NUMSE1
24238        DO1120ISET2=1,NUMSE2
24239C
24240          K=0
24241          NTEMP2=0
24242          DO1130I=1,N
24243            IF(XIDTEM(ISET1).EQ.TAG1(I).AND.XIDTE2(ISET2).EQ.TAG2(I))
24244     1        GOTO1131
24245            GOTO1130
24246 1131       CONTINUE
24247C
24248            NTEMP2=NTEMP2+1
24249            IF(IYVAR.EQ.'OFF')THEN
24250              K=K+1
24251              TEMP(K)=0.0
24252            ELSE
24253              IF(ABS(Y(I)-PSTAMV).GT.EPS)THEN
24254                K=K+1
24255                TEMP(K)=Y(I)
24256                IF(IXVAR.EQ.'ON')TEMPZ(K)=Z(I)
24257                IF(IX2VAR.EQ.'ON')TEMPZ2(K)=Z2(I)
24258              ENDIF
24259            ENDIF
24260 1130     CONTINUE
24261          NTEMP=K
24262C
24263C         AUGUST 2002.  CALL CMPSTA (EXCEPT FOR CHI-SQUARE CASE)
24264C
24265C         NTEMP2 IS THE NUMBER OF POINTS IN THE SUBSET AND
24266C         NTEMP IS THE NUMBER OF NON-MISSING POINTS IN THE SUBSET.
24267C
24268          IF(NTEMP2.EQ.0)GOTO1129
24269C
24270          IF(NTEMP.EQ.0)THEN
24271            IF(ICTAMV.EQ.'ZERO')THEN
24272              STAT=0.0
24273              IF(IBFLAG.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
24274     1           ICASCT.EQ.'MDCL')THEN
24275                NTRIAL=0
24276                ALOWLM=0.0
24277                AUPPLM=0.0
24278              ENDIF
24279            ELSEIF(ICTAMV.EQ.'MV  ')THEN
24280              STAT=PCTAMV
24281              IF(IBFLAG.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
24282     1           ICASCT.EQ.'MDCL')THEN
24283                NTRIAL=0
24284                ALOWLM=PCTAMV
24285                AUPPLM=PCTAMV
24286              ENDIF
24287            ELSE
24288              GOTO1129
24289            ENDIF
24290          ELSE
24291            CALL CMPSTA(
24292     1              TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,
24293     1              MAXNXT,NTEMP,NTEMP,NTEMP,
24294     1              NRESP,ICASCT,
24295     1              ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
24296     1              DTEMP1,DTEMP2,DTEMP3,
24297CCCCC1              IQUAME,IQUASE,PSTAMV,
24298     1              STAT,
24299     1              ISUBRO,IBUGA3,IERROR)
24300            IF(IERROR.EQ.'YES')GOTO9000
24301            IF(IBFLAG.EQ.'BPRO')THEN
24302              PTEMP=STAT
24303              NTRIAL=NTEMP
24304              IF(ICASCT.EQ.'BRAT')NTRIAL=ITEMP1(1)
24305              IF(STAT.EQ.PSTAMV)THEN
24306                ALOWLM=PSTAMV
24307                AUPPLM=PSTAMV
24308              ELSE
24309                ALPHAT=ALPHA
24310                CALL DPAGCO(PTEMP,NTRIAL,ALPHAT,IWRITE,
24311     1                      ALOWLM,AUPPLM,IBUGA3,IERROR)
24312              ENDIF
24313            ELSEIF(ICASCT.EQ.'MECL')THEN
24314              XMEAN=STAT
24315              NTRIAL=NTEMP
24316              IF(STAT.EQ.PSTAMV)THEN
24317                ALOWLM=PSTAMV
24318                AUPPLM=PSTAMV
24319              ELSE
24320                CALL SD(TEMP,NTEMP,IWRITE,XSD,IBUGA3,IERROR)
24321                ALPHAT=ALPHA
24322                CALL DPMECL(XMEAN,XSD,NTEMP,ALPHAT,IWRITE,
24323     1                      ALOWLM,AUPPLM,IBUGA3,IERROR)
24324              ENDIF
24325            ELSEIF(ICASCT.EQ.'MDCL')THEN
24326              XMED=STAT
24327              NTRIAL=NTEMP
24328              IF(STAT.EQ.PSTAMV)THEN
24329                ALOWLM=PSTAMV
24330                AUPPLM=PSTAMV
24331              ELSE
24332                XQ=0.5
24333                CALL QUANSE(XQ,TEMP,NTEMP,IWRITE,XTEMP1,MAXNXT,IQUASE,
24334     1                      QUASE,IBUGA3,IERROR)
24335                ALPHAT=ALPHA
24336                CALL DPMECL(XMED,QUASE,NTEMP,ALPHAT,IWRITE,
24337     1                      ALOWLM,AUPPLM,IBUGA3,IERROR)
24338              ENDIF
24339            ENDIF
24340          ENDIF
24341C
24342          J=J+1
24343          Y2(J)=STAT
24344          X2(J)=XIDTEM(ISET1)
24345          D2(J)=XIDTE2(ISET2)
24346          IF(IBFLAG.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
24347     1       ICASCT.EQ.'MDCL')THEN
24348            XNTRIA(J)=REAL(NTRIAL)
24349            XACLOW(J)=ALOWLM
24350            XACUPP(J)=AUPPLM
24351          ENDIF
24352C
24353 1129   CONTINUE
24354          IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CRT3')THEN
24355            WRITE(ICOUT,999)
24356            CALL DPWRST('XXX','BUG ')
24357            WRITE(ICOUT,1140)ISET1,ISET2,NTEMP,NTEMP2,STAT
24358 1140       FORMAT('DPCRT3: ISET1,ISET2,NTEMP,NTEMP2,STAT = ',
24359     1             2I5,2I8,G15.7)
24360            CALL DPWRST('XXX','BUG ')
24361            WRITE(ICOUT,1141)XIDTEM(ISET1),XIDTE2(ISET2)
24362 1141       FORMAT('XIDTEM(ISET1),XIDTE2(ISET2) = ',2G15.7)
24363            CALL DPWRST('XXX','BUG ')
24364            WRITE(ICOUT,1142)J,Y2(J),X2(J),D2(J)
24365 1142       FORMAT('J,Y2(J),X2(J),D2(J) = ',I8,3G15.7)
24366            CALL DPWRST('XXX','BUG ')
24367          ENDIF
24368C
24369 1120   CONTINUE
24370 1110 CONTINUE
24371      N2=J
24372C
24373      IF(ICASCT.EQ.'BRAT')THEN
24374        IBFLAG='BRAT'
24375        ICASCT='BPRO'
24376      ENDIF
24377C
24378      IOP='OPEN'
24379      IFLG11=1
24380      IFLG21=0
24381      IFLG31=0
24382      IFLAG4=0
24383      IFLAG5=0
24384      CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLAG4,IFLAG5,
24385     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
24386     1            IBUGA3,ISUBRO,IERROR)
24387      IF(IERROR.EQ.'YES')GOTO9000
24388C
24389      WRITE(IOUNI1,2111)ICTNAM
24390 2111 FORMAT(' GROUP-ID 1   GROUP-ID 2           ',A40)
24391      IF(ICASCT.EQ.'BPRO')THEN
24392        DO2170I=1,N2
24393          IF(IBINTA.EQ.'LOWE')THEN
24394            WRITE(IOUNI1,2171)X2(I),D2(I),Y2(I),XNTRIA(I),XACLOW(I)
24395 2171       FORMAT(5E17.9)
24396          ELSEIF(IBINTA.EQ.'UPPE')THEN
24397            WRITE(IOUNI1,2171)X2(I),D2(I),Y2(I),XNTRIA(I),XACUPP(I)
24398          ELSE
24399            WRITE(IOUNI1,2173)X2(I),D2(I),Y2(I),XNTRIA(I),
24400     1                        XACLOW(I),XACUPP(I)
24401 2173       FORMAT(6E17.9)
24402          ENDIF
24403 2170   CONTINUE
24404      ELSEIF(ICASCT.EQ.'MECL' .OR. ICASCT.EQ.'MDCL')THEN
24405        DO2175I=1,N2
24406          WRITE(IOUNI1,2173)X2(I),D2(I),Y2(I),XNTRIA(I),
24407     1                      XACLOW(I),XACUPP(I)
24408 2175   CONTINUE
24409      ELSE
24410        DO2160I=1,N2
24411          WRITE(IOUNI1,2161)X2(I),D2(I),Y2(I)
24412 2161     FORMAT(3E17.9)
24413 2160   CONTINUE
24414      ENDIF
24415C
24416      IOP='CLOS'
24417      CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLAG4,IFLAG5,
24418     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
24419     1            IBUGA3,ISUBRO,IERROR)
24420      IF(IERROR.EQ.'YES')GOTO9000
24421C
24422C               *****************************
24423C               **   STEP 6--              **
24424C               **   WRITE OUT THE TABLE   **
24425C               *****************************
24426C
24427      ISTEPN='6'
24428      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CRT3')
24429     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24430C
24431      WRITE(ICOUT,999)
24432  999 FORMAT(1X)
24433      CALL DPWRST('XXX','BUG ')
24434C
24435      IF(IPRINT.EQ.'OFF')GOTO8000
24436C
24437      ITITLE(1:15)='Cross Tabulate '
24438      IF(ICASCT.EQ.'BPRO')THEN
24439        NCTITL=37
24440        ITITLE(16:NCTITL)='Binomial Probabilities'
24441      ELSEIF(ICASCT.EQ.'MECL')THEN
24442        NCTITL=37
24443        ITITLE(16:NCTITL)='Mean Confidence Limits'
24444      ELSEIF(ICASCT.EQ.'MDCL')THEN
24445        NCTITL=39
24446        ITITLE(16:NCTITL)='Median Confidence Limits'
24447      ELSE
24448        ITITLE(16:55)=ICTNAM(1:40)
24449        NCTITL=55
24450        DO4010I=55,1,-1
24451          IF(ITITLE(I:I).NE.' ')THEN
24452            NCTITL=I
24453            GOTO4019
24454          ENDIF
24455 4010   CONTINUE
24456 4019   CONTINUE
24457      ENDIF
24458C
24459      IF(IYVAR.EQ.'ON')THEN
24460        ITITL9(1:21)='(Response Variables: '
24461        NTEMP=21
24462        ITITL9(22:30)=IYNAM(1:8)
24463        NTEMP=30
24464        IF(IXVAR.EQ.'ON')THEN
24465          ITITL9(30:30)=' '
24466          ITITL9(31:38)=IXNAM(1:8)
24467          NTEMP=38
24468        ENDIF
24469        IF(IX2VAR.EQ.'ON')THEN
24470          ITITL9(39:39)=' '
24471          ITITL9(40:47)=IXNAM2(1:8)
24472          NTEMP=47
24473        ENDIF
24474        NTEMP=NTEMP+1
24475        ITITL9(NTEMP:NTEMP)=')'
24476        NCTIT9=NTEMP
24477      ELSE
24478        ITITL9=' '
24479        NCTIT9=0
24480      ENDIF
24481C
24482      ITITL2(1,1)(1:8)=IX1NAM
24483      NCTIT2(1,1)=8
24484      ITITL2(1,2)(1:8)=IX2NAM
24485      NCTIT2(1,2)=8
24486      ITITL2(1,3)='   |   '
24487      IF(ICAPTY.EQ.'LATE')THEN
24488        ITITL2(1,3)='  $|$  '
24489      ENDIF
24490      NCTIT2(1,3)=7
24491C
24492      NUMLIN=1
24493      IF(ICASCT.EQ.'BPRO')THEN
24494        NUMCOL=7
24495        IF(IBINTA.EQ.'LOWE' .OR. IBINTA.EQ.'UPPE')NUMCOL=6
24496        ITITL2(1,4)='P'
24497        NCTIT2(1,4)=1
24498        ITITL2(1,5)='N'
24499        NCTIT2(1,5)=1
24500        IF(IBINTA.EQ.'LOWE')THEN
24501          ITITL2(1,6)(1:40)='Lower AC'
24502          NCTIT2(1,6)=8
24503        ELSEIF(IBINTA.EQ.'UPPE')THEN
24504          ITITL2(1,6)(1:40)='Upper AC'
24505          NCTIT2(1,6)=8
24506        ELSE
24507          ITITL2(1,6)(1:40)='Lower AC'
24508          NCTIT2(1,6)=8
24509          ITITL2(1,7)(1:40)='Upper AC'
24510          NCTIT2(1,7)=8
24511        ENDIF
24512      ELSEIF(ICASCT.EQ.'MECL' .OR. ICASCT.EQ.'MDCL')THEN
24513        NUMCOL=7
24514        IF(ICASCT.EQ.'MECL')THEN
24515          ITITL2(1,4)='Mean'
24516          NCTIT2(1,4)=4
24517        ELSE
24518          ITITL2(1,4)='Median'
24519          NCTIT2(1,4)=6
24520        ENDIF
24521        ITITL2(1,5)='N'
24522        NCTIT2(1,5)=1
24523        ITITL2(1,6)='Lower Limit'
24524        ITITL2(1,7)='Upper Limit'
24525        NCTIT2(1,6)=11
24526        NCTIT2(1,7)=11
24527      ELSE
24528        NUMCOL=4
24529        ITITL2(1,4)(1:15)=ICTNAM(1:15)
24530        NTEMP=15
24531        DO4070I=15,1,-1
24532          IF(ITITL2(1,4)(I:I).NE.' ')THEN
24533            NTEMP=I
24534            GOTO4079
24535          ENDIF
24536 4070   CONTINUE
24537 4079   CONTINUE
24538        NCTIT2(1,4)=NTEMP
24539      ENDIF
24540C
24541      NMAX=0
24542      DO4210I=1,NUMCOL
24543        VALIGN(I)='b'
24544        ALIGN(I)='r'
24545        NTOT(I)=15
24546        IF(NCTIT2(1,I).GT.NTOT(I))NTOT(I)=NCTIT2(1,I)
24547        NMAX=NMAX+NTOT(I)
24548        IDIGIT(I)=NUMDIG
24549        ITYPCO(I)='NUME'
24550        IF(I.EQ.5)THEN
24551          NTOT(I)=8
24552          IDIGIT(I)=0
24553        ELSEIF(I.EQ.3)THEN
24554          ITYPCO(I)='ALPH'
24555          NTOT(I)=7
24556          IDIGIT(I)=-1
24557        ENDIF
24558 4210 CONTINUE
24559C
24560      IWHTML(1)=125
24561      IWHTML(2)=125
24562      IWHTML(3)=25
24563      IWHTML(4)=125
24564      IWHTML(5)=75
24565      IWHTML(6)=125
24566      IWHTML(7)=125
24567      IJUNK=1400
24568      IWRTF(1)=IJUNK
24569      IWRTF(2)=IWRTF(1)+IJUNK
24570      IWRTF(3)=IWRTF(2)+200
24571      IWRTF(4)=IWRTF(3)+IJUNK
24572      IWRTF(5)=IWRTF(4)+800
24573      IWRTF(6)=IWRTF(5)+IJUNK
24574      IWRTF(7)=IWRTF(6)+IJUNK
24575      IFRST=.TRUE.
24576      IFLAGS=.TRUE.
24577      ILAST=.TRUE.
24578      IFLAGE=.FALSE.
24579C
24580      ICALL=0
24581      ICNT=0
24582      DO4310I=1,N2
24583        IF(ICNT.GE.30)THEN
24584          IF(I.EQ.N2)IFLAGE=.TRUE.
24585          CALL DPDTA5(ITITLE,NCTITL,
24586     1                ITITL9,NCTIT9,ITITL2,NCTIT2,
24587     1                MAXLIN,NUMLIN,NUMCLI,NUMCOL,
24588     1                IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
24589     1                IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
24590     1                ICAPSW,ICAPTY,IFRST,ILAST,
24591     1                IFLAGS,IFLAGE,
24592     1                ISUBRO,IBUGA3,IERROR)
24593          IFRST=.FALSE.
24594          IFLAGS=.FALSE.
24595          ICALL=1
24596          ICNT=0
24597        ENDIF
24598        ICNT=ICNT+1
24599        NCTEXT(ICNT)=0
24600        AMAT(ICNT,1)=X2(I)
24601        AMAT(ICNT,2)=D2(I)
24602        AMAT(ICNT,3)=0.0
24603        AMAT(ICNT,4)=Y2(I)
24604        IF(ICASCT.EQ.'BPRO' .AND. IBINTA.EQ.'LOWE')THEN
24605          AMAT(ICNT,5)=XNTRIA(I)
24606          AMAT(ICNT,6)=XACLOW(I)
24607        ELSEIF(ICASCT.EQ.'BPRO' .AND. IBINTA.EQ.'UPPE')THEN
24608          AMAT(ICNT,5)=XNTRIA(I)
24609          AMAT(ICNT,6)=XACUPP(I)
24610        ELSEIF(ICASCT.EQ.'BPRO')THEN
24611          AMAT(ICNT,5)=XNTRIA(I)
24612          AMAT(ICNT,6)=XACLOW(I)
24613          AMAT(ICNT,7)=XACUPP(I)
24614        ELSEIF(ICASCT.EQ.'MECL' .OR. ICASCT.EQ.'MDCL')THEN
24615          AMAT(ICNT,5)=XNTRIA(I)
24616          AMAT(ICNT,6)=XACLOW(I)
24617          AMAT(ICNT,7)=XACUPP(I)
24618        ENDIF
24619        DO4320J=1,NUMCOL
24620          IF(J.EQ.3)THEN
24621            NCVALU(ICNT,J)=7
24622            IVALUE(ICNT,J)='   |   '
24623            IF(ICAPTY.EQ.'LATE')THEN
24624              IVALUE(ICNT,J)='  $|$  '
24625            ENDIF
24626          ELSE
24627            NCVALU(ICNT,J)=0
24628            IVALUE(ICNT,J)=' '
24629          ENDIF
24630 4320   CONTINUE
24631 4310 CONTINUE
24632C
24633      IF(ICNT.GE.1)THEN
24634        IFLAGE=.TRUE.
24635        ILAST=.TRUE.
24636        CALL DPDTA5(ITITLE,NCTITL,
24637     1              ITITL9,NCTIT9,ITITL2,NCTIT2,
24638     1              MAXLIN,NUMLIN,NUMCLI,NUMCOL,
24639     1              IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
24640     1              IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
24641     1              ICAPSW,ICAPTY,IFRST,ILAST,
24642     1              IFLAGS,IFLAGE,
24643     1              ISUBRO,IBUGA3,IERROR)
24644      ENDIF
24645C
24646 8000 CONTINUE
24647      IF(IFEEDB.EQ.'ON')THEN
24648        WRITE(ICOUT,9212)
24649 9212   FORMAT(6X,'GROUP-IDs AND STATISTIC WRITTEN TO FILE ',
24650     1         'DPST1F.DAT')
24651        CALL DPWRST('XXX','BUG ')
24652      ENDIF
24653C
24654C               ******************
24655C               **   STEP 90--  **
24656C               **   EXIT       **
24657C               ******************
24658C
24659 9000 CONTINUE
24660C
24661      IF(IBFLAG.EQ.'BRAT')THEN
24662        ICASCT='BRAT'
24663      ENDIF
24664C
24665      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CRT3')THEN
24666        WRITE(ICOUT,999)
24667        CALL DPWRST('XXX','BUG ')
24668        WRITE(ICOUT,9011)
24669 9011   FORMAT('***** AT THE END       OF DPCRT3--')
24670        CALL DPWRST('XXX','BUG ')
24671        WRITE(ICOUT,9012)ICASCT,N,NUMSE1,N2,IERROR
24672 9012   FORMAT('ICASCT,N,NUMSE1,N2,IERROR = ',A4,3I8,2X,A4)
24673        CALL DPWRST('XXX','BUG ')
24674        WRITE(ICOUT,9015)NUMV2,NUMSE1,NUMSE2,N2
24675 9015   FORMAT('NUMV2,NUMSE1,NUMSE2,N2 = ',4I8)
24676        CALL DPWRST('XXX','BUG ')
24677        WRITE(ICOUT,9016)ANUMS1,ANUMS2
24678 9016   FORMAT('ANUMS1,ANUMS2 = ',2E15.7)
24679        CALL DPWRST('XXX','BUG ')
24680        DO9020I=1,N2
24681          WRITE(ICOUT,9021)I,Y2(I),X2(I),D2(I)
24682 9021     FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,3G15.7)
24683          CALL DPWRST('XXX','BUG ')
24684 9020   CONTINUE
24685      ENDIF
24686C
24687      RETURN
24688      END
24689      SUBROUTINE DPCRT4(Y,Z,Z2,TAG1,TAG2,TAG3,N,
24690     1                  NUMV2,ICASCT,ICTNAM,
24691     1                  XIDTEM,XIDTE2,XIDTE3,
24692     1                  NUMSE1,NUMSE2,NUMSE3,
24693     1                  TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,
24694     1                  XNTRIA,XACLOW,XACUPP,
24695     1                  ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
24696     1                  DTEMP1,DTEMP2,DTEMP3,
24697     1                  ISEED,ALPHA,
24698     1                  IXVAR,IX2VAR,IYVAR,
24699     1                  IYNAM,IXNAM,IXNAM2,
24700     1                  IX1NAM,IX2NAM,IX3NAM,
24701     1                  ICAPSW,ICAPTY,IFORSW,
24702     1                  MAXNXT,
24703     1                  Y2,X2,D2,DSIZE,N2,ISUBRO,IBUGA3,IERROR)
24704C
24705C     PURPOSE--GENERATE A THREE-WAY CROSS-TABULATION AND
24706C              OPTIONALLY PRINT THE RESULTS TO AN ASCII,
24707C              HTML, LATEX, OR RTF TABLE.
24708C     WRITTEN BY--ALAN HECKERT
24709C                 STATISTICAL ENGINEERING DIVISION
24710C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
24711C                 GAITHERSBURG, MD 20899-8980
24712C                 PHONE--301-975-2899
24713C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
24714C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
24715C     REFERENCE--ASTM MANUAL STP-15D, PAGES 78-84, 100-105
24716C     LANGUAGE--ANSI FORTRAN (1977)
24717C     VERSION NUMBER--2008/4
24718C     ORIGINAL VERSION--APRIL     2008.
24719C     UPDATED         --SEPTEMBER 2008. ACCOMODATE "MISSING" DATA
24720C     UPDATED         --JANUARY   2010. TREAT BINOMIAL RATIO IN A
24721C                                       SIMILAR FASHION TO BINOMIAL
24722C     UPDATED         --JUNE      2010. CALL LIST TO CMPSTA
24723C     UPDATED         --JUNE      2010. PRINT TABLES USING DPDTA5
24724C
24725C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
24726C
24727      CHARACTER*4 ICASCT
24728      CHARACTER*40 ICTNAM
24729      CHARACTER*4 IXVAR
24730      CHARACTER*4 IX2VAR
24731      CHARACTER*4 IYVAR
24732      CHARACTER*4 ICAPSW
24733      CHARACTER*4 ICAPTY
24734      CHARACTER*4 IFORSW
24735      CHARACTER*4 IBUGA3
24736      CHARACTER*4 IERROR
24737C
24738      PARAMETER(NUMCLI=8)
24739      PARAMETER(MAXLIN=2)
24740      PARAMETER (MAXROW=30)
24741      CHARACTER*60 ITITLE
24742      CHARACTER*60 ITITL9
24743      CHARACTER*4  ALIGN(NUMCLI)
24744      CHARACTER*4  VALIGN(NUMCLI)
24745      INTEGER      NCTEXT(MAXROW)
24746      INTEGER      IDIGIT(MAXROW)
24747      INTEGER      NTOT(MAXROW)
24748      CHARACTER*60 ITITL2(MAXLIN,NUMCLI)
24749      CHARACTER*15 IVALUE(MAXROW,NUMCLI)
24750      CHARACTER*4  ITYPCO(NUMCLI)
24751      INTEGER      NCTIT2(MAXLIN,NUMCLI)
24752      INTEGER      NCVALU(MAXROW,NUMCLI)
24753      INTEGER      IWHTML(NUMCLI)
24754      INTEGER      IWRTF(NUMCLI)
24755      REAL         AMAT(MAXROW,NUMCLI)
24756      LOGICAL IFRST
24757      LOGICAL ILAST
24758      LOGICAL IFLAGS
24759      LOGICAL IFLAGE
24760C
24761      CHARACTER*8 IYNAM
24762      CHARACTER*8 IXNAM
24763      CHARACTER*8 IXNAM2
24764      CHARACTER*8 IX1NAM
24765      CHARACTER*8 IX2NAM
24766      CHARACTER*8 IX3NAM
24767C
24768      CHARACTER*4 ISUBRO
24769      CHARACTER*4 IWRITE
24770      CHARACTER*4 ISUBN1
24771      CHARACTER*4 ISUBN2
24772      CHARACTER*4 ISTEPN
24773      CHARACTER*4 IBFLAG
24774C
24775C---------------------------------------------------------------------
24776C
24777      DIMENSION Y(*)
24778      DIMENSION Z(*)
24779      DIMENSION Z2(*)
24780      DIMENSION XIDTEM(*)
24781      DIMENSION XIDTE2(*)
24782      DIMENSION XIDTE3(*)
24783      DIMENSION Y2(*)
24784      DIMENSION X2(*)
24785      DIMENSION D2(*)
24786      DIMENSION DSIZE(*)
24787      DIMENSION XNTRIA(*)
24788      DIMENSION XACLOW(*)
24789      DIMENSION XACUPP(*)
24790C
24791      DIMENSION TAG1(*)
24792      DIMENSION TAG2(*)
24793      DIMENSION TAG3(*)
24794      DIMENSION TEMP(*)
24795      DIMENSION TEMPZ(*)
24796      DIMENSION TEMPZ2(*)
24797      DIMENSION XTEMP1(*)
24798      DIMENSION XTEMP2(*)
24799      DIMENSION XTEMP3(*)
24800C
24801      INTEGER ITEMP1(*)
24802      INTEGER ITEMP2(*)
24803      INTEGER ITEMP3(*)
24804      INTEGER ITEMP4(*)
24805      INTEGER ITEMP5(*)
24806      INTEGER ITEMP6(*)
24807C
24808      DOUBLE PRECISION DTEMP1(*)
24809      DOUBLE PRECISION DTEMP2(*)
24810      DOUBLE PRECISION DTEMP3(*)
24811C
24812      CHARACTER*4 IOP
24813C
24814      INCLUDE 'DPCOST.INC'
24815      INCLUDE 'DPCOP2.INC'
24816C
24817C-----START POINT-----------------------------------------------------
24818C
24819      ISUBN1='DPCR'
24820      ISUBN2='T4  '
24821C
24822      I2=0
24823C
24824      AN=INT(N+0.01)
24825      ANUMS1=INT(NUMSE1+0.01)
24826      ANUMS2=INT(NUMSE2+0.01)
24827      ANUMS3=INT(NUMSE3+0.01)
24828C
24829C               ***********************************************
24830C               **  STEP 5--                                 **
24831C               **  COMPUTE THE VARIOUS CROSS-TAB STATISTICS **
24832C               ***********************************************
24833C
24834      ISTEPN='5.1'
24835      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CRT4')
24836     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24837C
24838C     ALLOW THE   SET WRITE DECIMALS COMMAND    TO BE USED TO
24839C     DETERMINE HOW MANY DIGITS PRINTED IN TABLE.
24840C
24841      NUMDIG=-7
24842      IF(IFORSW.EQ.'1')NUMDIG=1
24843      IF(IFORSW.EQ.'2')NUMDIG=2
24844      IF(IFORSW.EQ.'3')NUMDIG=3
24845      IF(IFORSW.EQ.'4')NUMDIG=4
24846      IF(IFORSW.EQ.'5')NUMDIG=5
24847      IF(IFORSW.EQ.'6')NUMDIG=6
24848      IF(IFORSW.EQ.'7')NUMDIG=7
24849      IF(IFORSW.EQ.'8')NUMDIG=8
24850      IF(IFORSW.EQ.'9')NUMDIG=9
24851      IF(IFORSW.EQ.'0')NUMDIG=10
24852      IF(IFORSW.EQ.'-2')NUMDIG=-2
24853      IF(IFORSW.EQ.'-3')NUMDIG=-3
24854      IF(IFORSW.EQ.'-4')NUMDIG=-4
24855      IF(IFORSW.EQ.'-5')NUMDIG=-5
24856      IF(IFORSW.EQ.'-6')NUMDIG=-6
24857      IF(IFORSW.EQ.'-7')NUMDIG=-7
24858      IF(IFORSW.EQ.'-8')NUMDIG=-8
24859      IF(IFORSW.EQ.'-9')NUMDIG=-9
24860C
24861C     NOTE 9/2008: IN FOLLOWING, WE NEED TO DISTINGUISH BETWEEN
24862C                  EMPTY SETS DUE TO NO POINTS FALLING IN THE
24863C                  PARTICULAR CROSS TABULATION (IN WHICH CASE,
24864C                  WE WANT TO SKIP IN THE OUTPUT FILE) AND EMPTY
24865C                  SETS DUE TO ALL POINTS IN THE PARTICULAR
24866C                  CROSS TABULATION BEING MISSING (IN WHICH CASE,
24867C                  WE MAY WANT TO WRITE A 0 OR A MISSING VALUE).
24868C
24869C                  THERE ARE 2 MISSING VALUES:
24870C
24871C                  PSTAMV   - SPECIFIES WHETHER THE INPUT DATA
24872C                             VALUE IS TO BE INCLUDED IN THE
24873C                             COMPUTATION OF THE STATISTIC
24874C
24875C                  PCTAMV    - IF ALL THE DATA IS MISSING, THIS
24876C                              IS THE VALUE TO USE IN WRITING THE
24877C                              CROSS TABULATE OUTPUT.
24878C
24879      IWRITE='OFF'
24880      IBFLAG=ICASCT
24881      IF(IBFLAG.EQ.'BRAT')IBFLAG='BPRO'
24882C
24883      EPS=0.1E-7
24884      J=0
24885      NRESP=NUMV2-3
24886      DO1110ISET1=1,NUMSE1
24887        DO1120ISET2=1,NUMSE2
24888          DO1130ISET3=1,NUMSE3
24889C
24890            K=0
24891            NTEMP2=0
24892            DO1140I=1,N
24893              IF(XIDTEM(ISET1).EQ.TAG1(I).AND.XIDTE2(ISET2).EQ.TAG2(I)
24894     1           .AND.XIDTE3(ISET3).EQ.TAG3(I))
24895     1           GOTO1141
24896              GOTO1140
24897 1141         CONTINUE
24898C
24899              NTEMP2=NTEMP2+1
24900              IF(IYVAR.EQ.'OFF')THEN
24901                K=K+1
24902                TEMP(K)=0.0
24903              ELSE
24904                IF(ABS(Y(I)-PSTAMV).GT.EPS)THEN
24905                  K=K+1
24906                  TEMP(K)=Y(I)
24907                  IF(IXVAR.EQ.'ON')TEMPZ(K)=Z(I)
24908                  IF(IX2VAR.EQ.'ON')TEMPZ2(K)=Z2(I)
24909                ENDIF
24910              ENDIF
24911 1140       CONTINUE
24912            NTEMP=K
24913C
24914C           AUGUST 2002.  CALL CMPSTA (EXCEPT FOR CHI-SQUARE CASE)
24915C
24916C         NTEMP2 IS THE NUMBER OF POINTS IN THE SUBSET AND
24917C         NTEMP IS THE NUMBER OF NON-MISSING POINTS IN THE SUBSET.
24918C
24919          IF(NTEMP2.EQ.0)GOTO1130
24920C
24921            IF(NTEMP.EQ.0)THEN
24922              IF(ICTAMV.EQ.'ZERO')THEN
24923                STAT=0.0
24924                IF(IBFLAG.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
24925     1             ICASCT.EQ.'MDCL')THEN
24926                  NTRIAL=0
24927                  ALOWLM=0.0
24928                  AUPPLM=0.0
24929                ENDIF
24930              ELSEIF(ICTAMV.EQ.'MV  ')THEN
24931                STAT=PCTAMV
24932                IF(IBFLAG.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
24933     1             ICASCT.EQ.'MDCL')THEN
24934                  NTRIAL=0
24935                  ALOWLM=PCTAMV
24936                  AUPPLM=PCTAMV
24937                ENDIF
24938              ELSE
24939                GOTO1130
24940              ENDIF
24941            ELSE
24942              CALL CMPSTA(
24943     1              TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,
24944     1              MAXNXT,NTEMP,NTEMP,NTEMP,
24945     1              NRESP,ICASCT,
24946     1              ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
24947     1              DTEMP1,DTEMP2,DTEMP3,
24948CCCCC1              IQUAME,IQUASE,PSTAMV,
24949     1              STAT,
24950     1              ISUBRO,IBUGA3,IERROR)
24951              IF(IERROR.EQ.'YES')GOTO9000
24952              IF(IBFLAG.EQ.'BPRO')THEN
24953                PTEMP=STAT
24954                NTRIAL=NTEMP
24955                IF(ICASCT.EQ.'BRAT')NTRIAL=ITEMP1(1)
24956                IF(STAT.EQ.PSTAMV)THEN
24957                  ALOWLM=PSTAMV
24958                  AUPPLM=PSTAMV
24959                ELSE
24960                  ALPHAT=ALPHA
24961                  CALL DPAGCO(PTEMP,NTRIAL,ALPHAT,IWRITE,
24962     1                        ALOWLM,AUPPLM,IBUGA3,IERROR)
24963                ENDIF
24964              ELSEIF(ICASCT.EQ.'MECL')THEN
24965                XMEAN=STAT
24966                NTRIAL=NTEMP
24967                IF(STAT.EQ.PSTAMV)THEN
24968                  ALOWLM=PSTAMV
24969                  AUPPLM=PSTAMV
24970                ELSE
24971                  CALL SD(TEMP,NTEMP,IWRITE,XSD,IBUGA3,IERROR)
24972                  ALPHAT=ALPHA
24973                  CALL DPMECL(XMEAN,XSD,NTEMP,ALPHAT,IWRITE,
24974     1                        ALOWLM,AUPPLM,IBUGA3,IERROR)
24975                ENDIF
24976              ELSEIF(ICASCT.EQ.'MDCL')THEN
24977                XMED=STAT
24978                NTRIAL=NTEMP
24979                IF(STAT.EQ.PSTAMV)THEN
24980                  ALOWLM=PSTAMV
24981                  AUPPLM=PSTAMV
24982                ELSE
24983                  XQ=0.5
24984                  CALL QUANSE(XQ,TEMP,NTEMP,IWRITE,XTEMP1,MAXNXT,IQUASE,
24985     1                        QUASE,IBUGA3,IERROR)
24986                  ALPHAT=ALPHA
24987                  CALL DPMECL(XMED,QUASE,NTEMP,ALPHAT,IWRITE,
24988     1                        ALOWLM,AUPPLM,IBUGA3,IERROR)
24989                ENDIF
24990              ENDIF
24991            ENDIF
24992C
24993            J=J+1
24994            Y2(J)=STAT
24995            X2(J)=XIDTEM(ISET1)
24996            D2(J)=XIDTE2(ISET2)
24997            DSIZE(J)=XIDTE3(ISET3)
24998            IF(IBFLAG.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
24999     1         ICASCT.EQ.'MDCL')THEN
25000              XNTRIA(J)=REAL(NTRIAL)
25001              XACLOW(J)=ALOWLM
25002              XACUPP(J)=AUPPLM
25003            ENDIF
25004C
25005 1130     CONTINUE
25006 1120   CONTINUE
25007 1110 CONTINUE
25008      N2=J
25009C
25010      IF(ICASCT.EQ.'BRAT')THEN
25011        IBFLAG='BRAT'
25012        ICASCT='BPRO'
25013      ENDIF
25014C
25015      IOP='OPEN'
25016      IFLG11=1
25017      IFLG21=0
25018      IFLG31=0
25019      IFLAG4=0
25020      IFLAG5=0
25021      CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLAG4,IFLAG5,
25022     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
25023     1            IBUGA3,ISUBRO,IERROR)
25024      IF(IERROR.EQ.'YES')GOTO9000
25025C
25026      WRITE(IOUNI1,2111)ICTNAM
25027 2111 FORMAT(' GROUP-ID 1   GROUP-ID 2   GROUP-ID 3           ',A40)
25028      IF(ICASCT.EQ.'BPRO')THEN
25029        DO2170I=1,N2
25030          IF(IBINTA.EQ.'LOWE')THEN
25031            WRITE(IOUNI1,2171)X2(I),D2(I),DSIZE(I),
25032     1                        Y2(I),XNTRIA(I),XACLOW(I)
25033 2171       FORMAT(6E17.8)
25034          ELSEIF(IBINTA.EQ.'UPPE')THEN
25035            WRITE(IOUNI1,2171)X2(I),D2(I),DSIZE(I),
25036     1                        Y2(I),XNTRIA(I),XACUPP(I)
25037          ELSE
25038            WRITE(IOUNI1,2173)X2(I),D2(I),DSIZE(I),
25039     1                        Y2(I),XNTRIA(I),
25040     1                        XACLOW(I),XACUPP(I)
25041 2173       FORMAT(7E17.9)
25042          ENDIF
25043 2170   CONTINUE
25044      ELSEIF(ICASCT.EQ.'MECL' .OR. ICASCT.EQ.'MDCL')THEN
25045        DO2175I=1,N2
25046          WRITE(IOUNI1,2173)X2(I),D2(I),DSIZE(I),Y2(I),XNTRIA(I),
25047     1                      XACLOW(I),XACUPP(I)
25048 2175   CONTINUE
25049      ELSE
25050        DO2160I=1,N2
25051          WRITE(IOUNI1,2161)X2(I),D2(I),DSIZE(I),Y2(I)
25052 2161     FORMAT(4E17.9)
25053 2160   CONTINUE
25054      ENDIF
25055C
25056      IOP='CLOS'
25057      CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLAG4,IFLAG5,
25058     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
25059     1            IBUGA3,ISUBRO,IERROR)
25060      IF(IERROR.EQ.'YES')GOTO9000
25061C
25062C               *****************************
25063C               **   STEP 6--              **
25064C               **   WRITE OUT THE TABLE   **
25065C               *****************************
25066C
25067      ISTEPN='6'
25068      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CRT4')
25069     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25070C
25071      WRITE(ICOUT,999)
25072  999 FORMAT(1X)
25073      CALL DPWRST('XXX','BUG ')
25074C
25075      IF(IPRINT.EQ.'OFF')GOTO8000
25076C
25077      ITITLE(1:15)='Cross Tabulate '
25078      IF(ICASCT.EQ.'BPRO')THEN
25079        NCTITL=37
25080        ITITLE(16:NCTITL)='Binomial Probabilities'
25081      ELSEIF(ICASCT.EQ.'MECL')THEN
25082        NCTITL=37
25083        ITITLE(16:NCTITL)='Mean Confidence Limits'
25084      ELSEIF(ICASCT.EQ.'MDCL')THEN
25085        NCTITL=39
25086        ITITLE(16:NCTITL)='Median Confidence Limits'
25087      ELSE
25088        ITITLE(16:55)=ICTNAM(1:40)
25089        NCTITL=55
25090        DO4010I=55,1,-1
25091          IF(ITITLE(I:I).NE.' ')THEN
25092            NCTITL=I
25093            GOTO4019
25094          ENDIF
25095 4010   CONTINUE
25096 4019   CONTINUE
25097      ENDIF
25098C
25099      IF(IYVAR.EQ.'ON')THEN
25100        ITITL9(1:21)='(Response Variables: '
25101        NTEMP=21
25102        ITITL9(22:30)=IYNAM(1:8)
25103        NTEMP=30
25104        IF(IXVAR.EQ.'ON')THEN
25105          ITITL9(30:30)=' '
25106          ITITL9(31:38)=IXNAM(1:8)
25107          NTEMP=38
25108        ENDIF
25109        IF(IX2VAR.EQ.'ON')THEN
25110          ITITL9(39:39)=' '
25111          ITITL9(40:47)=IXNAM2(1:8)
25112          NTEMP=47
25113        ENDIF
25114        NTEMP=NTEMP+1
25115        ITITL9(NTEMP:NTEMP)=')'
25116        NCTIT9=NTEMP
25117      ELSE
25118        ITITL9=' '
25119        NCTIT9=0
25120      ENDIF
25121C
25122      ITITL2(1,1)(1:8)=IX1NAM
25123      NCTIT2(1,1)=8
25124      ITITL2(1,2)(1:8)=IX2NAM
25125      NCTIT2(1,2)=8
25126      ITITL2(1,3)(1:8)=IX3NAM
25127      NCTIT2(1,3)=8
25128      ITITL2(1,4)='   |   '
25129      IF(ICAPTY.EQ.'LATE')THEN
25130        ITITL2(1,4)='  $|$  '
25131      ENDIF
25132      NCTIT2(1,4)=7
25133C
25134      NUMLIN=1
25135      IF(ICASCT.EQ.'BPRO')THEN
25136        NUMCOL=8
25137        IF(IBINTA.EQ.'LOWE' .OR. IBINTA.EQ.'UPPE')NUMCOL=7
25138        ITITL2(1,5)='P'
25139        NCTIT2(1,5)=1
25140        ITITL2(1,6)='N'
25141        NCTIT2(1,6)=1
25142        IF(IBINTA.EQ.'LOWE')THEN
25143          ITITL2(1,7)(1:40)='Lower AC'
25144          NCTIT2(1,7)=8
25145        ELSEIF(IBINTA.EQ.'UPPE')THEN
25146          ITITL2(1,7)(1:40)='Upper AC'
25147          NCTIT2(1,7)=8
25148        ELSE
25149          ITITL2(1,7)(1:40)='Lower AC'
25150          NCTIT2(1,7)=8
25151          ITITL2(1,8)(1:40)='Upper AC'
25152          NCTIT2(1,8)=8
25153        ENDIF
25154      ELSEIF(ICASCT.EQ.'MECL' .OR. ICASCT.EQ.'MDCL')THEN
25155        NUMCOL=8
25156        IF(ICASCT.EQ.'MECL')THEN
25157          ITITL2(1,5)='Mean'
25158          NCTIT2(1,5)=4
25159        ELSE
25160          ITITL2(1,5)='Median'
25161          NCTIT2(1,5)=6
25162        ENDIF
25163        ITITL2(1,6)='N'
25164        NCTIT2(1,6)=1
25165        ITITL2(1,7)='Lower Limit'
25166        ITITL2(1,7)='Upper Limit'
25167        NCTIT2(1,8)=11
25168        NCTIT2(1,8)=11
25169      ELSE
25170        NUMCOL=5
25171        ITITL2(1,5)(1:15)=ICTNAM(1:15)
25172        NTEMP=15
25173        DO4070I=15,1,-1
25174          IF(ITITL2(1,5)(I:I).NE.' ')THEN
25175            NTEMP=I
25176            GOTO4079
25177          ENDIF
25178 4070   CONTINUE
25179 4079   CONTINUE
25180        NCTIT2(1,5)=NTEMP
25181      ENDIF
25182C
25183      NMAX=0
25184      DO4210I=1,NUMCOL
25185        VALIGN(I)='b'
25186        ALIGN(I)='r'
25187        NTOT(I)=15
25188        IF(NCTIT2(1,I).GT.NTOT(I))NTOT(I)=NCTIT2(1,I)
25189        NMAX=NMAX+NTOT(I)
25190        IDIGIT(I)=NUMDIG
25191        ITYPCO(I)='NUME'
25192        IF(I.EQ.6)THEN
25193          NTOT(I)=8
25194          IDIGIT(I)=0
25195        ELSEIF(I.EQ.4)THEN
25196          ITYPCO(I)='ALPH'
25197          NTOT(I)=7
25198          IDIGIT(I)=-1
25199CCCCC   ELSEIF(I.EQ.5)THEN
25200CCCCC     IF(ICASCT.NE.'BPRO' .AND. ICASCT.NE.'MECL' .AND.
25201CCCCC1       ICASCT.NE.'MDCL')THEN
25202CCCCC        ALIGN(I)='l'
25203CCCCC     ENDIF
25204        ENDIF
25205 4210 CONTINUE
25206C
25207      IWHTML(1)=125
25208      IWHTML(2)=125
25209      IWHTML(3)=125
25210      IWHTML(4)=25
25211      IWHTML(5)=125
25212      IWHTML(6)=75
25213      IWHTML(7)=125
25214      IWHTML(8)=125
25215      IJUNK=1400
25216      IWRTF(1)=IJUNK
25217      IWRTF(2)=IWRTF(1)+IJUNK
25218      IWRTF(3)=IWRTF(2)+IJUNK
25219      IWRTF(4)=IWRTF(3)+200
25220      IWRTF(5)=IWRTF(4)+IJUNK
25221      IWRTF(6)=IWRTF(5)+800
25222      IWRTF(7)=IWRTF(6)+IJUNK
25223      IWRTF(8)=IWRTF(7)+IJUNK
25224      IFRST=.TRUE.
25225      ILAST=.TRUE.
25226      IFLAGS=.TRUE.
25227      IFLAGE=.FALSE.
25228C
25229      ICNT=0
25230      ICALL=0
25231      DO4310I=1,N2
25232        IF(ICNT.GE.30)THEN
25233          IF(I.EQ.N2)IFLAGE=.TRUE.
25234          CALL DPDTA5(ITITLE,NCTITL,
25235     1                ITITL9,NCTIT9,ITITL2,NCTIT2,
25236     1                MAXLIN,NUMLIN,NUMCLI,NUMCOL,
25237     1                IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
25238     1                IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
25239     1                ICAPSW,ICAPTY,IFRST,ILAST,
25240     1                IFLAGS,IFLAGE,
25241     1                ISUBRO,IBUGA3,IERROR)
25242          IFRST=.FALSE.
25243          IFLAGS=.FALSE.
25244          ICALL=1
25245          ICNT=0
25246        ENDIF
25247        ICNT=ICNT+1
25248        NCTEXT(ICNT)=0
25249        AMAT(ICNT,1)=X2(I)
25250        AMAT(ICNT,2)=D2(I)
25251        AMAT(ICNT,3)=DSIZE(I)
25252        AMAT(ICNT,4)=0.0
25253        AMAT(ICNT,5)=Y2(I)
25254        IF(ICASCT.EQ.'BPRO' .AND. IBINTA.EQ.'LOWE')THEN
25255          AMAT(ICNT,6)=XNTRIA(I)
25256          AMAT(ICNT,7)=XACLOW(I)
25257        ELSEIF(ICASCT.EQ.'BPRO' .AND. IBINTA.EQ.'UPPE')THEN
25258          AMAT(ICNT,6)=XNTRIA(I)
25259          AMAT(ICNT,7)=XACUPP(I)
25260        ELSEIF(ICASCT.EQ.'BPRO')THEN
25261          AMAT(ICNT,6)=XNTRIA(I)
25262          AMAT(ICNT,7)=XACLOW(I)
25263          AMAT(ICNT,8)=XACUPP(I)
25264        ELSEIF(ICASCT.EQ.'MECL' .OR. ICASCT.EQ.'MDCL')THEN
25265          AMAT(ICNT,6)=XNTRIA(I)
25266          AMAT(ICNT,7)=XACLOW(I)
25267          AMAT(ICNT,8)=XACUPP(I)
25268        ENDIF
25269        DO4320J=1,NUMCOL
25270          IF(J.EQ.4)THEN
25271            NCVALU(ICNT,J)=7
25272            IVALUE(ICNT,J)='   |   '
25273            IF(ICAPTY.EQ.'LATE')THEN
25274              IVALUE(ICNT,J)='  $|$  '
25275            ENDIF
25276          ELSE
25277            NCVALU(ICNT,J)=0
25278            IVALUE(ICNT,J)=' '
25279          ENDIF
25280 4320   CONTINUE
25281 4310 CONTINUE
25282C
25283      IF(ICNT.GE.1)THEN
25284        IFLAGE=.TRUE.
25285        ILAST=.TRUE.
25286        CALL DPDTA5(ITITLE,NCTITL,
25287     1              ITITL9,NCTIT9,ITITL2,NCTIT2,
25288     1              MAXLIN,NUMLIN,NUMCLI,NUMCOL,
25289     1              IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
25290     1              IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
25291     1              ICAPSW,ICAPTY,IFRST,ILAST,
25292     1              IFLAGS,IFLAGE,
25293     1              ISUBRO,IBUGA3,IERROR)
25294      ENDIF
25295C
25296 8000 CONTINUE
25297      IF(IFEEDB.EQ.'ON')THEN
25298        WRITE(ICOUT,9212)
25299 9212   FORMAT(6X,'GROUP-IDs AND STATISTIC WRITTEN TO FILE ',
25300     1         'DPST1F.DAT')
25301        CALL DPWRST('XXX','BUG ')
25302      ENDIF
25303C
25304C               ******************
25305C               **   STEP 90--  **
25306C               **   EXIT       **
25307C               ******************
25308C
25309 9000 CONTINUE
25310C
25311      IF(IBFLAG.EQ.'BRAT')THEN
25312        ICASCT='BRAT'
25313      ENDIF
25314C
25315      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CRT4')THEN
25316        WRITE(ICOUT,999)
25317        CALL DPWRST('XXX','BUG ')
25318        WRITE(ICOUT,9011)
25319 9011   FORMAT('***** AT THE END       OF DPCRT4--')
25320        CALL DPWRST('XXX','BUG ')
25321        WRITE(ICOUT,9012)ICASCT,N,N2,IERROR
25322 9012   FORMAT('ICASCT,N,N2,IERROR = ',A4,2I8,2X,A4)
25323        CALL DPWRST('XXX','BUG ')
25324        WRITE(ICOUT,9013)NUMV2
25325 9013   FORMAT('NUMV2 = ',I8)
25326        CALL DPWRST('XXX','BUG ')
25327        WRITE(ICOUT,9015)NUMSE1,NUMSE2,NUMSE3
25328 9015   FORMAT('NUMSE1,NUMSE2,NUMSE3 = ',3I8)
25329        CALL DPWRST('XXX','BUG ')
25330        WRITE(ICOUT,9016)ANUMS1,ANUMS2,ANUMS3
25331 9016   FORMAT('ANUMS1,ANUMS2,ANUMS3 = ',3E15.7)
25332        CALL DPWRST('XXX','BUG ')
25333        DO9020I=1,N2
25334          WRITE(ICOUT,9021)I,Y2(I),X2(I),DSIZE(I),D2(I)
25335 9021     FORMAT('I,Y2(I),X2(I),DSIZE(I),D2(I) = ',I8,4G15.7)
25336          CALL DPWRST('XXX','BUG ')
25337 9020   CONTINUE
25338      ENDIF
25339C
25340      RETURN
25341      END
25342      SUBROUTINE DPCRT5(Y,Z,Z2,TAG1,TAG2,TAG3,TAG4,N,
25343     1                  NUMV2,ICASCT,ICTNAM,
25344     1                  XIDTEM,XIDTE2,XIDTE3,XIDTE4,
25345     1                  NUMSE1,NUMSE2,NUMSE3,NUMSE4,
25346     1                  TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,
25347     1                  XNTRIA,XACLOW,XACUPP,
25348     1                  ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
25349     1                  DTEMP1,DTEMP2,DTEMP3,
25350     1                  ISEED,ALPHA,
25351     1                  IXVAR,IX2VAR,IYVAR,
25352     1                  IYNAM,IXNAM,IXNAM2,
25353     1                  IX1NAM,IX2NAM,IX3NAM,IX4NAM,
25354     1                  ICAPSW,ICAPTY,IFORSW,
25355     1                  MAXNXT,
25356     1                  Y2,X2,D2,DSIZE,DCOLOR,N2,ISUBRO,IBUGA3,IERROR)
25357C
25358C     PURPOSE--GENERATE A FOUR-WAY CROSS-TABULATION AND
25359C              OPTIONALLY PRINT THE RESULTS TO AN ASCII,
25360C              HTML, LATEX, OR RTF TABLE.
25361C     WRITTEN BY--ALAN HECKERT
25362C                 STATISTICAL ENGINEERING DIVISION
25363C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
25364C                 GAITHERSBURG, MD 20899-8980
25365C                 PHONE--301-975-2899
25366C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
25367C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
25368C     REFERENCE--ASTM MANUAL STP-15D, PAGES 78-84, 100-105
25369C     LANGUAGE--ANSI FORTRAN (1977)
25370C     VERSION NUMBER--2008/4
25371C     ORIGINAL VERSION--APRIL     2008.
25372C     UPDATED         --SEPTEMBER 2008. ACCOMODATE "MISSING" DATA
25373C     UPDATED         --JANUARY   2010. TREAT BINOMIAL RATIO IN A
25374C                                       SIMILAR FASHION TO BINOMIAL
25375C     UPDATED         --JUNE      2010. CALL LIST TO CMPSTA
25376C     UPDATED         --JUNE      2010. USE DPDTA5 TO PRINT TABLE
25377C
25378C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
25379C
25380      CHARACTER*4 ICASCT
25381      CHARACTER*40 ICTNAM
25382      CHARACTER*4 IXVAR
25383      CHARACTER*4 IX2VAR
25384      CHARACTER*4 IYVAR
25385      CHARACTER*4 ICAPSW
25386      CHARACTER*4 ICAPTY
25387      CHARACTER*4 IFORSW
25388      CHARACTER*4 IBUGA3
25389      CHARACTER*4 IERROR
25390C
25391      PARAMETER(NUMCLI=9)
25392      PARAMETER(MAXLIN=2)
25393      PARAMETER (MAXROW=30)
25394      CHARACTER*60 ITITLE
25395      CHARACTER*60 ITITL9
25396      CHARACTER*4  ALIGN(NUMCLI)
25397      CHARACTER*4  VALIGN(NUMCLI)
25398      INTEGER      NCTEXT(MAXROW)
25399      INTEGER      IDIGIT(MAXROW)
25400      INTEGER      NTOT(MAXROW)
25401      CHARACTER*60 ITITL2(MAXLIN,NUMCLI)
25402      CHARACTER*15 IVALUE(MAXROW,NUMCLI)
25403      CHARACTER*4  ITYPCO(NUMCLI)
25404      INTEGER      NCTIT2(MAXLIN,NUMCLI)
25405      INTEGER      NCVALU(MAXROW,NUMCLI)
25406      INTEGER      IWHTML(NUMCLI)
25407      INTEGER      IWRTF(NUMCLI)
25408      REAL         AMAT(MAXROW,NUMCLI)
25409      LOGICAL IFRST
25410      LOGICAL ILAST
25411      LOGICAL IFLAGS
25412      LOGICAL IFLAGE
25413C
25414      CHARACTER*8 IYNAM
25415      CHARACTER*8 IXNAM
25416      CHARACTER*8 IXNAM2
25417      CHARACTER*8 IX1NAM
25418      CHARACTER*8 IX2NAM
25419      CHARACTER*8 IX3NAM
25420      CHARACTER*8 IX4NAM
25421C
25422      CHARACTER*4 ISUBRO
25423      CHARACTER*4 IWRITE
25424      CHARACTER*4 ISUBN1
25425      CHARACTER*4 ISUBN2
25426      CHARACTER*4 ISTEPN
25427      CHARACTER*4 IBFLAG
25428C
25429C---------------------------------------------------------------------
25430C
25431      DIMENSION Y(*)
25432      DIMENSION Z(*)
25433      DIMENSION Z2(*)
25434      DIMENSION XIDTEM(*)
25435      DIMENSION XIDTE2(*)
25436      DIMENSION XIDTE3(*)
25437      DIMENSION XIDTE4(*)
25438      DIMENSION Y2(*)
25439      DIMENSION X2(*)
25440      DIMENSION D2(*)
25441      DIMENSION DSIZE(*)
25442      DIMENSION DCOLOR(*)
25443C
25444      DIMENSION TAG1(*)
25445      DIMENSION TAG2(*)
25446      DIMENSION TAG3(*)
25447      DIMENSION TAG4(*)
25448      DIMENSION TEMP(*)
25449      DIMENSION TEMPZ(*)
25450      DIMENSION TEMPZ2(*)
25451      DIMENSION XTEMP1(*)
25452      DIMENSION XTEMP2(*)
25453      DIMENSION XTEMP3(*)
25454      DIMENSION XNTRIA(*)
25455      DIMENSION XACLOW(*)
25456      DIMENSION XACUPP(*)
25457C
25458      INTEGER ITEMP1(*)
25459      INTEGER ITEMP2(*)
25460      INTEGER ITEMP3(*)
25461      INTEGER ITEMP4(*)
25462      INTEGER ITEMP5(*)
25463      INTEGER ITEMP6(*)
25464C
25465      DOUBLE PRECISION DTEMP1(*)
25466      DOUBLE PRECISION DTEMP2(*)
25467      DOUBLE PRECISION DTEMP3(*)
25468C
25469      CHARACTER*4 IOP
25470C
25471      INCLUDE 'DPCOST.INC'
25472      INCLUDE 'DPCOP2.INC'
25473C
25474C-----START POINT-----------------------------------------------------
25475C
25476      ISUBN1='DPCR'
25477      ISUBN2='T5  '
25478C
25479      I2=0
25480C
25481      AN=INT(N+0.01)
25482      ANUMS1=INT(NUMSE1+0.01)
25483      ANUMS2=INT(NUMSE2+0.01)
25484      ANUMS3=INT(NUMSE3+0.01)
25485      ANUMS4=INT(NUMSE4+0.01)
25486C
25487C               ***********************************************
25488C               **  STEP 5--                                 **
25489C               **  COMPUTE THE VARIOUS CROSS-TAB STATISTICS **
25490C               ***********************************************
25491C
25492      ISTEPN='5.1'
25493      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CRT5')
25494     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25495C
25496C     ALLOW THE   SET WRITE DECIMALS COMMAND    TO BE USED TO
25497C     DETERMINE HOW MANY DIGITS PRINTED IN TABLE.
25498C
25499      NUMDIG=-7
25500      IF(IFORSW.EQ.'1')NUMDIG=1
25501      IF(IFORSW.EQ.'2')NUMDIG=2
25502      IF(IFORSW.EQ.'3')NUMDIG=3
25503      IF(IFORSW.EQ.'4')NUMDIG=4
25504      IF(IFORSW.EQ.'5')NUMDIG=5
25505      IF(IFORSW.EQ.'6')NUMDIG=6
25506      IF(IFORSW.EQ.'7')NUMDIG=7
25507      IF(IFORSW.EQ.'8')NUMDIG=8
25508      IF(IFORSW.EQ.'9')NUMDIG=9
25509      IF(IFORSW.EQ.'0')NUMDIG=10
25510      IF(IFORSW.EQ.'-2')NUMDIG=-2
25511      IF(IFORSW.EQ.'-3')NUMDIG=-3
25512      IF(IFORSW.EQ.'-4')NUMDIG=-4
25513      IF(IFORSW.EQ.'-5')NUMDIG=-5
25514      IF(IFORSW.EQ.'-6')NUMDIG=-6
25515      IF(IFORSW.EQ.'-7')NUMDIG=-7
25516      IF(IFORSW.EQ.'-8')NUMDIG=-8
25517      IF(IFORSW.EQ.'-9')NUMDIG=-9
25518C
25519C     NOTE 9/2008: IN FOLLOWING, WE NEED TO DISTINGUISH BETWEEN
25520C                  EMPTY SETS DUE TO NO POINTS FALLING IN THE
25521C                  PARTICULAR CROSS TABULATION (IN WHICH CASE,
25522C                  WE WANT TO SKIP IN THE OUTPUT FILE) AND EMPTY
25523C                  SETS DUE TO ALL POINTS IN THE PARTICULAR
25524C                  CROSS TABULATION BEING MISSING (IN WHICH CASE,
25525C                  WE MAY WANT TO WRITE A 0 OR A MISSING VALUE).
25526C
25527C                  THERE ARE 2 MISSING VALUES:
25528C
25529C                  PSTAMV   - SPECIFIES WHETHER THE INPUT DATA
25530C                             VALUE IS TO BE INCLUDED IN THE
25531C                             COMPUTATION OF THE STATISTIC
25532C
25533C                  PCTAMV    - IF ALL THE DATA IS MISSING, THIS
25534C                              IS THE VALUE TO USE IN WRITING THE
25535C                              CROSS TABULATE OUTPUT.
25536C
25537      IWRITE='OFF'
25538      IBFLAG=ICASCT
25539      IF(IBFLAG.EQ.'BRAT')IBFLAG='BPRO'
25540C
25541      EPS=0.1E-7
25542      J=0
25543      NRESP=NUMV2-4
25544      DO1110ISET1=1,NUMSE1
25545        DO1120ISET2=1,NUMSE2
25546          DO1130ISET3=1,NUMSE3
25547          DO1140ISET4=1,NUMSE4
25548C
25549            K=0
25550            NTEMP2=0
25551            DO1180I=1,N
25552              IF(XIDTEM(ISET1).EQ.TAG1(I) .AND.
25553     1           XIDTE2(ISET2).EQ.TAG2(I) .AND.
25554     1           XIDTE3(ISET3).EQ.TAG3(I) .AND.
25555     1           XIDTE4(ISET4).EQ.TAG4(I))
25556     1           GOTO1181
25557              GOTO1180
25558 1181         CONTINUE
25559C
25560              NTEMP2=NTEMP2+1
25561              IF(IYVAR.EQ.'OFF')THEN
25562                K=K+1
25563                TEMP(K)=0.0
25564              ELSE
25565                IF(ABS(Y(I)-PSTAMV).GT.EPS)THEN
25566                  K=K+1
25567                  TEMP(K)=Y(I)
25568                  IF(IXVAR.EQ.'ON')TEMPZ(K)=Z(I)
25569                  IF(IX2VAR.EQ.'ON')TEMPZ2(K)=Z2(I)
25570                ENDIF
25571              ENDIF
25572 1180       CONTINUE
25573            NTEMP=K
25574C
25575C           AUGUST 2002.  CALL CMPSTA (EXCEPT FOR CHI-SQUARE CASE)
25576C
25577C           NTEMP2 IS THE NUMBER OF POINTS IN THE SUBSET AND
25578C           NTEMP IS THE NUMBER OF NON-MISSING POINTS IN THE SUBSET.
25579C
25580            IF(NTEMP2.EQ.0)GOTO1140
25581C
25582            IF(NTEMP.EQ.0)THEN
25583              IF(ICTAMV.EQ.'ZERO')THEN
25584                STAT=0.0
25585                IF(IBFLAG.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
25586     1             ICASCT.EQ.'MDCL')THEN
25587                  NTRIAL=0
25588                  ALOWLM=0.0
25589                  AUPPLM=0.0
25590                ENDIF
25591              ELSEIF(ICTAMV.EQ.'MV  ')THEN
25592                STAT=PCTAMV
25593                IF(IBFLAG.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
25594     1             ICASCT.EQ.'MDCL')THEN
25595                  NTRIAL=0
25596                  ALOWLM=PCTAMV
25597                  AUPPLM=PCTAMV
25598                ENDIF
25599              ELSE
25600                GOTO1140
25601              ENDIF
25602            ELSE
25603              CALL CMPSTA(
25604     1              TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,
25605     1              MAXNXT,NTEMP,NTEMP,NTEMP,
25606     1              NRESP,ICASCT,
25607     1              ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
25608     1              DTEMP1,DTEMP2,DTEMP3,
25609CCCCC1              IQUAME,IQUASE,PSTAMV,
25610     1              STAT,
25611     1              ISUBRO,IBUGA3,IERROR)
25612              IF(IERROR.EQ.'YES')GOTO9000
25613              IF(IBFLAG.EQ.'BPRO')THEN
25614                PTEMP=STAT
25615                NTRIAL=NTEMP
25616                IF(ICASCT.EQ.'BRAT')NTRIAL=ITEMP1(1)
25617                IF(STAT.EQ.PSTAMV)THEN
25618                  ALOWLM=PSTAMV
25619                  AUPPLM=PSTAMV
25620                ELSE
25621                  ALPHAT=ALPHA
25622                  CALL DPAGCO(PTEMP,NTRIAL,ALPHAT,IWRITE,
25623     1                        ALOWLM,AUPPLM,IBUGA3,IERROR)
25624                ENDIF
25625              ELSEIF(ICASCT.EQ.'MECL')THEN
25626                XMEAN=STAT
25627                NTRIAL=NTEMP
25628                IF(STAT.EQ.PSTAMV)THEN
25629                  ALOWLM=PSTAMV
25630                  AUPPLM=PSTAMV
25631                ELSE
25632                  CALL SD(TEMP,NTEMP,IWRITE,XSD,IBUGA3,IERROR)
25633                  ALPHAT=ALPHA
25634                  CALL DPMECL(XMEAN,XSD,NTEMP,ALPHAT,IWRITE,
25635     1                        ALOWLM,AUPPLM,IBUGA3,IERROR)
25636                ENDIF
25637              ELSEIF(ICASCT.EQ.'MDCL')THEN
25638                XMED=STAT
25639                NTRIAL=NTEMP
25640                IF(STAT.EQ.PSTAMV)THEN
25641                  ALOWLM=PSTAMV
25642                  AUPPLM=PSTAMV
25643                ELSE
25644                  XQ=0.5
25645                  CALL QUANSE(XQ,TEMP,NTEMP,IWRITE,XTEMP1,MAXNXT,IQUASE,
25646     1                        QUASE,IBUGA3,IERROR)
25647                  ALPHAT=ALPHA
25648                  CALL DPMECL(XMED,QUASE,NTEMP,ALPHAT,IWRITE,
25649     1                        ALOWLM,AUPPLM,IBUGA3,IERROR)
25650                ENDIF
25651              ENDIF
25652            ENDIF
25653C
25654            J=J+1
25655            Y2(J)=STAT
25656            X2(J)=XIDTEM(ISET1)
25657            D2(J)=XIDTE2(ISET2)
25658            DSIZE(J)=XIDTE3(ISET3)
25659            DCOLOR(J)=XIDTE4(ISET4)
25660            IF(IBFLAG.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
25661     1         ICASCT.EQ.'MDCL')THEN
25662              XNTRIA(J)=REAL(NTRIAL)
25663              XACLOW(J)=ALOWLM
25664              XACUPP(J)=AUPPLM
25665            ENDIF
25666C
25667 1140     CONTINUE
25668 1130     CONTINUE
25669 1120   CONTINUE
25670 1110 CONTINUE
25671      N2=J
25672C
25673      IF(ICASCT.EQ.'BRAT')THEN
25674        IBFLAG='BRAT'
25675        ICASCT='BPRO'
25676      ENDIF
25677C
25678      IOP='OPEN'
25679      IFLG11=1
25680      IFLG21=0
25681      IFLG31=0
25682      IFLAG4=0
25683      IFLAG5=0
25684      CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLAG4,IFLAG5,
25685     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
25686     1            IBUGA3,ISUBRO,IERROR)
25687      IF(IERROR.EQ.'YES')GOTO9000
25688C
25689      WRITE(IOUNI1,2111)ICTNAM
25690 2111 FORMAT(' GROUP-ID 1   GROUP-ID 2   GROUP-ID 3   GROUP-ID 4',
25691     1       '           ',A40)
25692      IF(ICASCT.EQ.'BPRO')THEN
25693        DO2170I=1,N2
25694          IF(IBINTA.EQ.'LOWE')THEN
25695            WRITE(IOUNI1,2171)X2(I),D2(I),DSIZE(I),DCOLOR(I),
25696     1                        Y2(I),XNTRIA(I),XACLOW(I)
25697 2171       FORMAT(7E17.9)
25698          ELSEIF(IBINTA.EQ.'UPPE')THEN
25699            WRITE(IOUNI1,2171)X2(I),D2(I),DSIZE(I),DCOLOR(I),
25700     1                        Y2(I),XNTRIA(I),XACUPP(I)
25701          ELSE
25702            WRITE(IOUNI1,2173)X2(I),D2(I),DSIZE(I),DCOLOR(I),
25703     1                        Y2(I),XNTRIA(I),
25704     1                        XACLOW(I),XACUPP(I)
25705 2173       FORMAT(8E17.9)
25706          ENDIF
25707 2170   CONTINUE
25708      ELSEIF(ICASCT.EQ.'MECL' .OR. ICASCT.EQ.'MDCL')THEN
25709        DO2175I=1,N2
25710          WRITE(IOUNI1,2173)X2(I),D2(I),DSIZE(I),DCOLOR(I),
25711     1                      Y2(I),XNTRIA(I),XACLOW(I),XACUPP(I)
25712 2175   CONTINUE
25713      ELSE
25714        DO2160I=1,N2
25715          WRITE(IOUNI1,2161)X2(I),D2(I),DSIZE(I),DCOLOR(I),Y2(I)
25716 2161     FORMAT(5E17.9)
25717 2160   CONTINUE
25718      ENDIF
25719C
25720      IOP='CLOS'
25721      CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLAG4,IFLAG5,
25722     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
25723     1            IBUGA3,ISUBRO,IERROR)
25724      IF(IERROR.EQ.'YES')GOTO9000
25725C
25726C               *****************************
25727C               **   STEP 6--              **
25728C               **   WRITE OUT THE TABLE   **
25729C               *****************************
25730C
25731      ISTEPN='6'
25732      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CRT5')
25733     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25734C
25735      WRITE(ICOUT,999)
25736  999 FORMAT(1X)
25737      CALL DPWRST('XXX','BUG ')
25738C
25739      IF(IPRINT.EQ.'OFF')GOTO8000
25740C
25741      ITITLE(1:15)='Cross Tabulate '
25742      IF(ICASCT.EQ.'BPRO')THEN
25743        NCTITL=37
25744        ITITLE(16:NCTITL)='Binomial Probabilities'
25745      ELSEIF(ICASCT.EQ.'MECL')THEN
25746        NCTITL=37
25747        ITITLE(16:NCTITL)='Mean Confidence Limits'
25748      ELSEIF(ICASCT.EQ.'MDCL')THEN
25749        NCTITL=39
25750        ITITLE(16:NCTITL)='Median Confidence Limits'
25751      ELSE
25752        ITITLE(16:55)=ICTNAM(1:40)
25753        NCTITL=55
25754        DO4010I=55,1,-1
25755          IF(ITITLE(I:I).NE.' ')THEN
25756            NCTITL=I
25757            GOTO4019
25758          ENDIF
25759 4010   CONTINUE
25760 4019   CONTINUE
25761      ENDIF
25762C
25763      IF(IYVAR.EQ.'ON')THEN
25764        ITITL9(1:21)='(Response Variables: '
25765        NTEMP=21
25766        ITITL9(22:30)=IYNAM(1:8)
25767        NTEMP=30
25768        IF(IXVAR.EQ.'ON')THEN
25769          ITITL9(30:30)=' '
25770          ITITL9(31:38)=IXNAM(1:8)
25771          NTEMP=38
25772        ENDIF
25773        IF(IX2VAR.EQ.'ON')THEN
25774          ITITL9(39:39)='-'
25775          ITITL9(40:47)=IXNAM2(1:8)
25776          NTEMP=47
25777        ENDIF
25778        NTEMP=NTEMP+1
25779        ITITL9(NTEMP:NTEMP)=')'
25780        NCTIT9=NTEMP
25781      ELSE
25782        ITITL9=' '
25783        NCTIT9=0
25784      ENDIF
25785C
25786      ITITL2(1,1)(1:8)=IX1NAM
25787      NCTIT2(1,1)=8
25788      ITITL2(1,2)(1:8)=IX2NAM
25789      NCTIT2(1,2)=8
25790      ITITL2(1,3)(1:8)=IX3NAM
25791      NCTIT2(1,3)=8
25792      ITITL2(1,4)(1:8)=IX4NAM
25793      NCTIT2(1,4)=8
25794      ITITL2(1,5)='   |   '
25795      IF(ICAPTY.EQ.'LATE')THEN
25796        ITITL2(1,5)='  $|$  '
25797      ENDIF
25798      NCTIT2(1,5)=7
25799C
25800      NUMLIN=1
25801      IF(ICASCT.EQ.'BPRO')THEN
25802        NUMCOL=9
25803        IF(IBINTA.EQ.'LOWE' .OR. IBINTA.EQ.'UPPE')NUMCOL=8
25804        ITITL2(1,6)='P'
25805        NCTIT2(1,6)=1
25806        ITITL2(1,7)='N'
25807        NCTIT2(1,7)=1
25808        IF(IBINTA.EQ.'LOWE')THEN
25809          ITITL2(1,8)(1:40)='Lower AC'
25810          NCTIT2(1,8)=8
25811        ELSEIF(IBINTA.EQ.'UPPE')THEN
25812          ITITL2(1,8)(1:40)='Upper AC'
25813          NCTIT2(1,8)=8
25814        ELSE
25815          ITITL2(1,8)(1:40)='Lower AC'
25816          NCTIT2(1,8)=8
25817          ITITL2(1,9)(1:40)='Upper AC'
25818          NCTIT2(1,9)=8
25819        ENDIF
25820      ELSEIF(ICASCT.EQ.'MECL' .OR. ICASCT.EQ.'MDCL')THEN
25821        NUMCOL=9
25822        IF(ICASCT.EQ.'MECL')THEN
25823          ITITL2(1,6)='Mean'
25824          NCTIT2(1,6)=4
25825        ELSE
25826          ITITL2(1,6)='Median'
25827          NCTIT2(1,6)=6
25828        ENDIF
25829        ITITL2(1,7)='N'
25830        NCTIT2(1,7)=1
25831        ITITL2(1,8)='Lower Limit'
25832        ITITL2(1,8)='Upper Limit'
25833        NCTIT2(1,9)=11
25834        NCTIT2(1,9)=11
25835      ELSE
25836        NUMCOL=6
25837        ITITL2(1,6)(1:15)=ICTNAM(1:15)
25838        NTEMP=15
25839        DO4070I=15,1,-1
25840          IF(ITITL2(1,6)(I:I).NE.' ')THEN
25841            NTEMP=I
25842            GOTO4079
25843          ENDIF
25844 4070   CONTINUE
25845 4079   CONTINUE
25846        NCTIT2(1,6)=NTEMP
25847      ENDIF
25848C
25849      NMAX=0
25850      DO4210I=1,NUMCOL
25851        VALIGN(I)='b'
25852        ALIGN(I)='r'
25853        NTOT(I)=15
25854        IF(NCTIT2(1,I).GT.NTOT(I))NTOT(I)=NCTIT2(1,I)
25855        NMAX=NMAX+NTOT(I)
25856        IDIGIT(I)=NUMDIG
25857        ITYPCO(I)='NUME'
25858        IF(I.EQ.7)THEN
25859          NTOT(I)=8
25860          IDIGIT(I)=0
25861        ELSEIF(I.EQ.5)THEN
25862          ITYPCO(I)='ALPH'
25863          NTOT(I)=7
25864          IDIGIT(I)=-1
25865CCCCC   ELSEIF(I.EQ.6)THEN
25866CCCCC     IF(ICASCT.NE.'BPRO' .AND. ICASCT.NE.'MECL' .AND.
25867CCCCC1       ICASCT.NE.'MDCL')THEN
25868CCCCC        ALIGN(I)='l'
25869CCCCC     ENDIF
25870        ENDIF
25871 4210 CONTINUE
25872C
25873      IWHTML(1)=125
25874      IWHTML(2)=125
25875      IWHTML(3)=125
25876      IWHTML(4)=125
25877      IWHTML(5)=25
25878      IWHTML(6)=125
25879      IWHTML(7)=75
25880      IWHTML(8)=125
25881      IWHTML(9)=125
25882      IJUNK=1300
25883      IF(ICASCT.EQ.'BPRO')IJUNK=1100
25884      IF(ICASCT.EQ.'MECL')IJUNK=1100
25885      IF(ICASCT.EQ.'MDCL')IJUNK=1100
25886      IWRTF(1)=IJUNK
25887      IWRTF(2)=IWRTF(1)+IJUNK
25888      IWRTF(3)=IWRTF(2)+IJUNK
25889      IWRTF(4)=IWRTF(3)+IJUNK
25890      IWRTF(5)=IWRTF(4)+200
25891      IWRTF(6)=IWRTF(5)+IJUNK
25892      IWRTF(7)=IWRTF(6)+800
25893      IWRTF(8)=IWRTF(7)+IJUNK
25894      IWRTF(9)=IWRTF(8)+IJUNK
25895      IFRST=.TRUE.
25896      ILAST=.TRUE.
25897      IFLAGS=.TRUE.
25898      IFLAGE=.FALSE.
25899      ICALL=0
25900C
25901      ICNT=0
25902      DO4310I=1,N2
25903        IF(ICNT.GE.30)THEN
25904          IF(I.EQ.N2)IFLAGE=.TRUE.
25905          CALL DPDTA5(ITITLE,NCTITL,
25906     1                ITITL9,NCTIT9,ITITL2,NCTIT2,
25907     1                MAXLIN,NUMLIN,NUMCLI,NUMCOL,
25908     1                IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
25909     1                IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
25910     1                ICAPSW,ICAPTY,IFRST,ILAST,
25911     1                IFLAGS,IFLAGE,
25912     1                ISUBRO,IBUGA3,IERROR)
25913          IFRST=.FALSE.
25914          IFLAGS=.FALSE.
25915          ICALL=1
25916          ICNT=0
25917        ENDIF
25918        ICNT=ICNT+1
25919        NCTEXT(ICNT)=0
25920        AMAT(ICNT,1)=X2(I)
25921        AMAT(ICNT,2)=D2(I)
25922        AMAT(ICNT,3)=DSIZE(I)
25923        AMAT(ICNT,4)=DCOLOR(I)
25924        AMAT(ICNT,5)=0.0
25925        AMAT(ICNT,6)=Y2(I)
25926        IF(ICASCT.EQ.'BPRO' .AND. IBINTA.EQ.'LOWE')THEN
25927          AMAT(ICNT,7)=XNTRIA(I)
25928          AMAT(ICNT,8)=XACLOW(I)
25929        ELSEIF(ICASCT.EQ.'BPRO' .AND. IBINTA.EQ.'UPPE')THEN
25930          AMAT(ICNT,7)=XNTRIA(I)
25931          AMAT(ICNT,8)=XACUPP(I)
25932        ELSEIF(ICASCT.EQ.'BPRO')THEN
25933          AMAT(ICNT,7)=XNTRIA(I)
25934          AMAT(ICNT,8)=XACLOW(I)
25935          AMAT(ICNT,9)=XACUPP(I)
25936        ELSEIF(ICASCT.EQ.'MECL' .OR. ICASCT.EQ.'MDCL')THEN
25937          AMAT(ICNT,7)=XNTRIA(I)
25938          AMAT(ICNT,8)=XACLOW(I)
25939          AMAT(ICNT,9)=XACUPP(I)
25940        ENDIF
25941        DO4320J=1,NUMCOL
25942          IF(J.EQ.5)THEN
25943            NCVALU(ICNT,J)=7
25944            IVALUE(ICNT,J)='   |   '
25945            IF(ICAPTY.EQ.'LATE')THEN
25946              IVALUE(ICNT,J)='  $|$  '
25947            ENDIF
25948          ELSE
25949            NCVALU(ICNT,J)=0
25950            IVALUE(ICNT,J)=' '
25951          ENDIF
25952 4320   CONTINUE
25953 4310 CONTINUE
25954C
25955      IF(ICNT.GE.1)THEN
25956        IFLAGE=.TRUE.
25957        ILAST=.TRUE.
25958        CALL DPDTA5(ITITLE,NCTITL,
25959     1              ITITL9,NCTIT9,ITITL2,NCTIT2,
25960     1              MAXLIN,NUMLIN,NUMCLI,NUMCOL,
25961     1              IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
25962     1              IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
25963     1              ICAPSW,ICAPTY,IFRST,ILAST,
25964     1              IFLAGS,IFLAGE,
25965     1              ISUBRO,IBUGA3,IERROR)
25966      ENDIF
25967C
25968 8000 CONTINUE
25969      IF(IFEEDB.EQ.'ON')THEN
25970        WRITE(ICOUT,9212)
25971 9212   FORMAT(6X,'GROUP-IDs AND STATISTIC WRITTEN TO FILE ',
25972     1         'DPST1F.DAT')
25973        CALL DPWRST('XXX','BUG ')
25974      ENDIF
25975C
25976C               ******************
25977C               **   STEP 90--  **
25978C               **   EXIT       **
25979C               ******************
25980C
25981 9000 CONTINUE
25982C
25983      IF(IBFLAG.EQ.'BRAT')THEN
25984        ICASCT='BRAT'
25985      ENDIF
25986C
25987      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CRT5')THEN
25988        WRITE(ICOUT,999)
25989        CALL DPWRST('XXX','BUG ')
25990        WRITE(ICOUT,9011)
25991 9011   FORMAT('***** AT THE END       OF DPCRT5--')
25992        CALL DPWRST('XXX','BUG ')
25993        WRITE(ICOUT,9012)ICASCT,N,N2,IERROR
25994 9012   FORMAT('ICASCT,N,N2,IERROR = ',A4,2I8,2X,A4)
25995        CALL DPWRST('XXX','BUG ')
25996        WRITE(ICOUT,9013)NUMV2
25997 9013   FORMAT('NUMV2 = ',I8)
25998        CALL DPWRST('XXX','BUG ')
25999        WRITE(ICOUT,9015)NUMSE1,NUMSE2,NUMSE3,NUMSE4
26000 9015   FORMAT('NUMSE1,NUMSE2,NUMSE3,NUMSE4 = ',4I8)
26001        CALL DPWRST('XXX','BUG ')
26002        WRITE(ICOUT,9016)ANUMS1,ANUMS2,ANUMS3,ANUMS4
26003 9016   FORMAT('ANUMS1,ANUMS2,ANUMS3,ANUMS4 = ',4G15.7)
26004        CALL DPWRST('XXX','BUG ')
26005        DO9020I=1,N2
26006          WRITE(ICOUT,9021)I,Y2(I),X2(I),DSIZE(I),D2(I)
26007 9021     FORMAT('I,Y2(I),X2(I),DSIZE(I),D2(I) = ',I8,4G15.7)
26008          CALL DPWRST('XXX','BUG ')
26009 9020   CONTINUE
26010      ENDIF
26011C
26012      RETURN
26013      END
26014      SUBROUTINE DPCRT6(Y,Z,Z2,TAG1,TAG2,TAG3,TAG4,TAG5,N,
26015     1                  NUMV2,ICASCT,ICTNAM,
26016     1                  XIDTEM,XIDTE2,XIDTE3,XIDTE4,XIDTE5,
26017     1                  NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,
26018     1                  TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,
26019     1                  XNTRIA,XACLOW,XACUPP,
26020     1                  ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
26021     1                  DTEMP1,DTEMP2,DTEMP3,
26022     1                  ISEED,ALPHA,
26023     1                  IXVAR,IX2VAR,IYVAR,
26024     1                  IYNAM,IXNAM,IXNAM2,
26025     1                  IX1NAM,IX2NAM,IX3NAM,IX4NAM,IX5NAM,
26026     1                  ICAPSW,ICAPTY,IFORSW,
26027     1                  MAXNXT,
26028     1                  Y2,X2,D2,DSIZE,DCOLOR,DFILL,N2,
26029     1                  ISUBRO,IBUGA3,IERROR)
26030C
26031C     PURPOSE--GENERATE A FIVE-WAY CROSS-TABULATION AND
26032C              OPTIONALLY PRINT THE RESULTS TO AN ASCII,
26033C              HTML, LATEX, OR RTF TABLE.
26034C     WRITTEN BY--ALAN HECKERT
26035C                 STATISTICAL ENGINEERING DIVISION
26036C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
26037C                 GAITHERSBURG, MD 20899-8980
26038C                 PHONE--301-975-2899
26039C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
26040C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
26041C     REFERENCE--ASTM MANUAL STP-15D, PAGES 78-84, 100-105
26042C     LANGUAGE--ANSI FORTRAN (1977)
26043C     VERSION NUMBER--2008/4
26044C     ORIGINAL VERSION--APRIL     2008.
26045C     UPDATED         --SEPTEMBER 2008. ACCOMODATE "MISSING" DATA
26046C     UPDATED         --JANUARY   2010. TREAT BINOMIAL RATIO IN A
26047C                                       SIMILAR FASHION TO BINOMIAL
26048C     UPDATED         --JUNE      2010. CALL LIST TO CMPSTA
26049C     UPDATED         --JUNE      2010. USE DPDTA5 TO PRINT TABLE
26050C
26051C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
26052C
26053      CHARACTER*4 ICASCT
26054      CHARACTER*40 ICTNAM
26055      CHARACTER*4 IXVAR
26056      CHARACTER*4 IX2VAR
26057      CHARACTER*4 IYVAR
26058      CHARACTER*4 ICAPSW
26059      CHARACTER*4 ICAPTY
26060      CHARACTER*4 IFORSW
26061      CHARACTER*4 IBUGA3
26062      CHARACTER*4 IERROR
26063C
26064      PARAMETER(NUMCLI=10)
26065      PARAMETER(MAXLIN=2)
26066      PARAMETER (MAXROW=30)
26067      CHARACTER*60 ITITLE
26068      CHARACTER*60 ITITL9
26069      CHARACTER*4  ALIGN(NUMCLI)
26070      CHARACTER*4  VALIGN(NUMCLI)
26071      INTEGER      NCTEXT(MAXROW)
26072      INTEGER      IDIGIT(MAXROW)
26073      INTEGER      NTOT(MAXROW)
26074      CHARACTER*60 ITITL2(MAXLIN,NUMCLI)
26075      CHARACTER*15 IVALUE(MAXROW,NUMCLI)
26076      CHARACTER*4  ITYPCO(NUMCLI)
26077      INTEGER      NCTIT2(MAXLIN,NUMCLI)
26078      INTEGER      NCVALU(MAXROW,NUMCLI)
26079      INTEGER      IWHTML(NUMCLI)
26080      INTEGER      IWRTF(NUMCLI)
26081      REAL         AMAT(MAXROW,NUMCLI)
26082      LOGICAL IFRST
26083      LOGICAL ILAST
26084      LOGICAL IFLAGS
26085      LOGICAL IFLAGE
26086      CHARACTER*1 IBASLC
26087C
26088      CHARACTER*8 IYNAM
26089      CHARACTER*8 IXNAM
26090      CHARACTER*8 IXNAM2
26091      CHARACTER*8 IX1NAM
26092      CHARACTER*8 IX2NAM
26093      CHARACTER*8 IX3NAM
26094      CHARACTER*8 IX4NAM
26095      CHARACTER*8 IX5NAM
26096C
26097      CHARACTER*4 ISUBRO
26098      CHARACTER*4 IWRITE
26099      CHARACTER*4 ISUBN1
26100      CHARACTER*4 ISUBN2
26101      CHARACTER*4 ISTEPN
26102      CHARACTER*4 IBFLAG
26103C
26104C---------------------------------------------------------------------
26105C
26106      DIMENSION Y(*)
26107      DIMENSION Z(*)
26108      DIMENSION Z2(*)
26109      DIMENSION XIDTEM(*)
26110      DIMENSION XIDTE2(*)
26111      DIMENSION XIDTE3(*)
26112      DIMENSION XIDTE4(*)
26113      DIMENSION XIDTE5(*)
26114      DIMENSION Y2(*)
26115      DIMENSION X2(*)
26116      DIMENSION D2(*)
26117      DIMENSION DSIZE(*)
26118      DIMENSION DCOLOR(*)
26119      DIMENSION DFILL(*)
26120C
26121      DIMENSION TAG1(*)
26122      DIMENSION TAG2(*)
26123      DIMENSION TAG3(*)
26124      DIMENSION TAG4(*)
26125      DIMENSION TAG5(*)
26126      DIMENSION TEMP(*)
26127      DIMENSION TEMPZ(*)
26128      DIMENSION TEMPZ2(*)
26129      DIMENSION XTEMP1(*)
26130      DIMENSION XTEMP2(*)
26131      DIMENSION XTEMP3(*)
26132      DIMENSION XNTRIA(*)
26133      DIMENSION XACLOW(*)
26134      DIMENSION XACUPP(*)
26135C
26136      INTEGER ITEMP1(*)
26137      INTEGER ITEMP2(*)
26138      INTEGER ITEMP3(*)
26139      INTEGER ITEMP4(*)
26140      INTEGER ITEMP5(*)
26141      INTEGER ITEMP6(*)
26142C
26143      DOUBLE PRECISION DTEMP1(*)
26144      DOUBLE PRECISION DTEMP2(*)
26145      DOUBLE PRECISION DTEMP3(*)
26146C
26147      CHARACTER*4 IOP
26148C
26149      INCLUDE 'DPCOST.INC'
26150      INCLUDE 'DPCOP2.INC'
26151C
26152C-----START POINT-----------------------------------------------------
26153C
26154      ISUBN1='DPCR'
26155      ISUBN2='T6  '
26156C
26157      I2=0
26158      IPTSAV=IRTFPS
26159C
26160      AN=INT(N+0.01)
26161      ANUMS1=INT(NUMSE1+0.01)
26162      ANUMS2=INT(NUMSE2+0.01)
26163      ANUMS3=INT(NUMSE3+0.01)
26164      ANUMS4=INT(NUMSE4+0.01)
26165      ANUMS5=INT(NUMSE5+0.01)
26166C
26167C               ***********************************************
26168C               **  STEP 5--                                 **
26169C               **  COMPUTE THE VARIOUS CROSS-TAB STATISTICS **
26170C               ***********************************************
26171C
26172      ISTEPN='5.1'
26173      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CRT6')
26174     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26175C
26176C     ALLOW THE   SET WRITE DECIMALS COMMAND    TO BE USED TO
26177C     DETERMINE HOW MANY DIGITS PRINTED IN TABLE.
26178C
26179      NUMDIG=-7
26180      IF(IFORSW.EQ.'1')NUMDIG=1
26181      IF(IFORSW.EQ.'2')NUMDIG=2
26182      IF(IFORSW.EQ.'3')NUMDIG=3
26183      IF(IFORSW.EQ.'4')NUMDIG=4
26184      IF(IFORSW.EQ.'5')NUMDIG=5
26185      IF(IFORSW.EQ.'6')NUMDIG=6
26186      IF(IFORSW.EQ.'7')NUMDIG=7
26187      IF(IFORSW.EQ.'8')NUMDIG=8
26188      IF(IFORSW.EQ.'9')NUMDIG=9
26189      IF(IFORSW.EQ.'0')NUMDIG=10
26190      IF(IFORSW.EQ.'-2')NUMDIG=-2
26191      IF(IFORSW.EQ.'-3')NUMDIG=-3
26192      IF(IFORSW.EQ.'-4')NUMDIG=-4
26193      IF(IFORSW.EQ.'-5')NUMDIG=-5
26194      IF(IFORSW.EQ.'-6')NUMDIG=-6
26195      IF(IFORSW.EQ.'-7')NUMDIG=-7
26196      IF(IFORSW.EQ.'-8')NUMDIG=-8
26197      IF(IFORSW.EQ.'-9')NUMDIG=-9
26198C
26199C     NOTE 9/2008: IN FOLLOWING, WE NEED TO DISTINGUISH BETWEEN
26200C                  EMPTY SETS DUE TO NO POINTS FALLING IN THE
26201C                  PARTICULAR CROSS TABULATION (IN WHICH CASE,
26202C                  WE WANT TO SKIP IN THE OUTPUT FILE) AND EMPTY
26203C                  SETS DUE TO ALL POINTS IN THE PARTICULAR
26204C                  CROSS TABULATION BEING MISSING (IN WHICH CASE,
26205C                  WE MAY WANT TO WRITE A 0 OR A MISSING VALUE).
26206C
26207C                  THERE ARE 2 MISSING VALUES:
26208C
26209C                  PSTAMV   - SPECIFIES WHETHER THE INPUT DATA
26210C                             VALUE IS TO BE INCLUDED IN THE
26211C                             COMPUTATION OF THE STATISTIC
26212C
26213C                  PCTAMV    - IF ALL THE DATA IS MISSING, THIS
26214C                              IS THE VALUE TO USE IN WRITING THE
26215C                              CROSS TABULATE OUTPUT.
26216C
26217      IWRITE='OFF'
26218      IBFLAG=ICASCT
26219      IF(IBFLAG.EQ.'BRAT')IBFLAG='BPRO'
26220C
26221      EPS=0.1E-7
26222      J=0
26223      NRESP=NUMV2-5
26224      DO1110ISET1=1,NUMSE1
26225        DO1120ISET2=1,NUMSE2
26226          DO1130ISET3=1,NUMSE3
26227          DO1140ISET4=1,NUMSE4
26228          DO1150ISET5=1,NUMSE5
26229C
26230            K=0
26231            NTEMP2=0
26232            DO1180I=1,N
26233              IF(XIDTEM(ISET1).EQ.TAG1(I) .AND.
26234     1           XIDTE2(ISET2).EQ.TAG2(I) .AND.
26235     1           XIDTE3(ISET3).EQ.TAG3(I) .AND.
26236     1           XIDTE4(ISET4).EQ.TAG4(I) .AND.
26237     1           XIDTE5(ISET5).EQ.TAG5(I))
26238     1           GOTO1181
26239              GOTO1180
26240 1181         CONTINUE
26241C
26242              NTEMP2=NTEMP2+1
26243              IF(IYVAR.EQ.'OFF')THEN
26244                K=K+1
26245                TEMP(K)=0.0
26246              ELSE
26247                IF(ABS(Y(I)-PSTAMV).GT.EPS)THEN
26248                  K=K+1
26249                  TEMP(K)=Y(I)
26250                  IF(IXVAR.EQ.'ON')TEMPZ(K)=Z(I)
26251                  IF(IX2VAR.EQ.'ON')TEMPZ2(K)=Z2(I)
26252                ENDIF
26253              ENDIF
26254 1180       CONTINUE
26255            NTEMP=K
26256C
26257C           AUGUST 2002.  CALL CMPSTA (EXCEPT FOR CHI-SQUARE CASE)
26258C
26259C           NTEMP2 IS THE NUMBER OF POINTS IN THE SUBSET AND
26260C           NTEMP IS THE NUMBER OF NON-MISSING POINTS IN THE SUBSET.
26261C
26262            IF(NTEMP2.EQ.0)GOTO1150
26263C
26264            IF(NTEMP.EQ.0)THEN
26265              IF(ICTAMV.EQ.'ZERO')THEN
26266                STAT=0.0
26267                IF(IBFLAG.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
26268     1             ICASCT.EQ.'MDCL')THEN
26269                  NTRIAL=0
26270                  ALOWLM=0.0
26271                  AUPPLM=0.0
26272                ENDIF
26273              ELSEIF(ICTAMV.EQ.'MV  ')THEN
26274                STAT=PCTAMV
26275                IF(IBFLAG.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
26276     1             ICASCT.EQ.'MDCL')THEN
26277                  NTRIAL=0
26278                  ALOWLM=PCTAMV
26279                  AUPPLM=PCTAMV
26280                ENDIF
26281              ELSE
26282                GOTO1150
26283              ENDIF
26284            ELSE
26285              CALL CMPSTA(
26286     1              TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,
26287     1              MAXNXT,NTEMP,NTEMP,NTEMP,
26288     1              NRESP,ICASCT,
26289     1              ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
26290     1              DTEMP1,DTEMP2,DTEMP3,
26291CCCCC1              IQUAME,IQUASE,PSTAMV,
26292     1              STAT,
26293     1              ISUBRO,IBUGA3,IERROR)
26294              IF(IERROR.EQ.'YES')GOTO9000
26295              IF(IBFLAG.EQ.'BPRO')THEN
26296                PTEMP=STAT
26297                NTRIAL=NTEMP
26298                IF(ICASCT.EQ.'BRAT')NTRIAL=ITEMP1(1)
26299                IF(STAT.EQ.PSTAMV)THEN
26300                  ALOWLM=PSTAMV
26301                  AUPPLM=PSTAMV
26302                ELSE
26303                  ALPHAT=ALPHA
26304                  CALL DPAGCO(PTEMP,NTRIAL,ALPHAT,IWRITE,
26305     1                        ALOWLM,AUPPLM,IBUGA3,IERROR)
26306                ENDIF
26307              ELSEIF(ICASCT.EQ.'MECL')THEN
26308                XMEAN=STAT
26309                NTRIAL=NTEMP
26310                IF(STAT.EQ.PSTAMV)THEN
26311                  ALOWLM=PSTAMV
26312                  AUPPLM=PSTAMV
26313                ELSE
26314                  CALL SD(TEMP,NTEMP,IWRITE,XSD,IBUGA3,IERROR)
26315                  ALPHAT=ALPHA
26316                  CALL DPMECL(XMEAN,XSD,NTEMP,ALPHAT,IWRITE,
26317     1                        ALOWLM,AUPPLM,IBUGA3,IERROR)
26318                ENDIF
26319              ELSEIF(ICASCT.EQ.'MDCL')THEN
26320                XMED=STAT
26321                NTRIAL=NTEMP
26322                IF(STAT.EQ.PSTAMV)THEN
26323                  ALOWLM=PSTAMV
26324                  AUPPLM=PSTAMV
26325                ELSE
26326                  XQ=0.5
26327                  CALL QUANSE(XQ,TEMP,NTEMP,IWRITE,XTEMP1,MAXNXT,IQUASE,
26328     1                        QUASE,IBUGA3,IERROR)
26329                  ALPHAT=ALPHA
26330                  CALL DPMECL(XMED,QUASE,NTEMP,ALPHAT,IWRITE,
26331     1                        ALOWLM,AUPPLM,IBUGA3,IERROR)
26332                ENDIF
26333              ENDIF
26334            ENDIF
26335C
26336            J=J+1
26337            Y2(J)=STAT
26338            X2(J)=XIDTEM(ISET1)
26339            D2(J)=XIDTE2(ISET2)
26340            DSIZE(J)=XIDTE3(ISET3)
26341            DCOLOR(J)=XIDTE4(ISET4)
26342            DFILL(J)=XIDTE5(ISET5)
26343            IF(IBFLAG.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
26344     1         ICASCT.EQ.'MDCL')THEN
26345              XNTRIA(J)=REAL(NTRIAL)
26346              XACLOW(J)=ALOWLM
26347              XACUPP(J)=AUPPLM
26348            ENDIF
26349C
26350 1150     CONTINUE
26351 1140     CONTINUE
26352 1130     CONTINUE
26353 1120   CONTINUE
26354 1110 CONTINUE
26355      N2=J
26356C
26357      IF(ICASCT.EQ.'BRAT')THEN
26358        IBFLAG='BRAT'
26359        ICASCT='BPRO'
26360      ENDIF
26361C
26362      IOP='OPEN'
26363      IFLG11=1
26364      IFLG21=0
26365      IFLG31=0
26366      IFLAG4=0
26367      IFLAG5=0
26368      CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLAG4,IFLAG5,
26369     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
26370     1            IBUGA3,ISUBRO,IERROR)
26371      IF(IERROR.EQ.'YES')GOTO9000
26372C
26373      WRITE(IOUNI1,2111)ICTNAM
26374 2111 FORMAT(' GROUP-ID 1   GROUP-ID 2   GROUP-ID 3   GROUP-ID 4',
26375     1       '   GROUP-ID 5           ',A40)
26376C
26377      IF(ICASCT.EQ.'BPRO')THEN
26378        DO2170I=1,N2
26379          IF(IBINTA.EQ.'LOWE')THEN
26380            WRITE(IOUNI1,2171)X2(I),D2(I),DSIZE(I),DCOLOR(I),DFILL(I),
26381     1                        Y2(I),XNTRIA(I),XACLOW(I)
26382 2171       FORMAT(8E17.9)
26383          ELSEIF(IBINTA.EQ.'UPPE')THEN
26384            WRITE(IOUNI1,2171)X2(I),D2(I),DSIZE(I),DCOLOR(I),DFILL(I),
26385     1                        Y2(I),XNTRIA(I),XACUPP(I)
26386          ELSE
26387            WRITE(IOUNI1,2173)X2(I),D2(I),DSIZE(I),DCOLOR(I),DFILL(I),
26388     1                        Y2(I),XNTRIA(I),
26389     1                        XACLOW(I),XACUPP(I)
26390 2173       FORMAT(9E17.9)
26391          ENDIF
26392 2170   CONTINUE
26393      ELSEIF(ICASCT.EQ.'MECL' .OR. ICASCT.EQ.'MDCL')THEN
26394        DO2175I=1,N2
26395          WRITE(IOUNI1,2173)X2(I),D2(I),DSIZE(I),DCOLOR(I),DFILL(I),
26396     1                      Y2(I),XNTRIA(I),XACLOW(I),XACUPP(I)
26397 2175   CONTINUE
26398      ELSE
26399        DO2160I=1,N2
26400          WRITE(IOUNI1,2161)X2(I),D2(I),DSIZE(I),DCOLOR(I),DFILL(I),
26401     1                      Y2(I)
26402 2161     FORMAT(6E17.9)
26403 2160   CONTINUE
26404      ENDIF
26405C
26406      IOP='CLOS'
26407      CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLAG4,IFLAG5,
26408     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
26409     1            IBUGA3,ISUBRO,IERROR)
26410      IF(IERROR.EQ.'YES')GOTO9000
26411C
26412C               *****************************
26413C               **   STEP 6--              **
26414C               **   WRITE OUT THE TABLE   **
26415C               *****************************
26416C
26417      ISTEPN='6'
26418      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CRT6')
26419     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26420C
26421      WRITE(ICOUT,999)
26422  999 FORMAT(1X)
26423      CALL DPWRST('XXX','BUG ')
26424C
26425      IF(IPRINT.EQ.'OFF')GOTO8000
26426C
26427      ITITLE(1:15)='Cross Tabulate '
26428      IF(ICASCT.EQ.'BPRO')THEN
26429        NCTITL=37
26430        ITITLE(16:NCTITL)='Binomial Probabilities'
26431      ELSEIF(ICASCT.EQ.'MECL')THEN
26432        NCTITL=37
26433        ITITLE(16:NCTITL)='Mean Confidence Limits'
26434      ELSEIF(ICASCT.EQ.'MDCL')THEN
26435        NCTITL=39
26436        ITITLE(16:NCTITL)='Median Confidence Limits'
26437      ELSE
26438        ITITLE(16:55)=ICTNAM(1:40)
26439        NCTITL=55
26440        DO4010I=55,1,-1
26441          IF(ITITLE(I:I).NE.' ')THEN
26442            NCTITL=I
26443            GOTO4019
26444          ENDIF
26445 4010   CONTINUE
26446 4019   CONTINUE
26447      ENDIF
26448C
26449      IF(IYVAR.EQ.'ON')THEN
26450        ITITL9(1:21)='(Response Variables: '
26451        NTEMP=21
26452        ITITL9(22:30)=IYNAM(1:8)
26453        NTEMP=30
26454        IF(IXVAR.EQ.'ON')THEN
26455          ITITL9(30:30)=' '
26456          ITITL9(31:38)=IXNAM(1:8)
26457          NTEMP=38
26458        ENDIF
26459        IF(IX2VAR.EQ.'ON')THEN
26460          ITITL9(39:39)=' '
26461          ITITL9(40:47)=IXNAM2(1:8)
26462          NTEMP=47
26463        ENDIF
26464        NTEMP=NTEMP+1
26465        ITITL9(NTEMP:NTEMP)=')'
26466        NCTIT9=NTEMP
26467      ELSE
26468        ITITL9=' '
26469        NCTIT9=0
26470      ENDIF
26471C
26472      ITITL2(1,1)(1:8)=IX1NAM
26473      NCTIT2(1,1)=8
26474      ITITL2(1,2)(1:8)=IX2NAM
26475      NCTIT2(1,2)=8
26476      ITITL2(1,3)(1:8)=IX3NAM
26477      NCTIT2(1,3)=8
26478      ITITL2(1,4)(1:8)=IX4NAM
26479      NCTIT2(1,4)=8
26480      ITITL2(1,5)(1:8)=IX5NAM
26481      NCTIT2(1,5)=8
26482      ITITL2(1,6)='   |   '
26483      IF(ICAPTY.EQ.'LATE')THEN
26484        ITITL2(1,6)='  $|$  '
26485      ENDIF
26486      NCTIT2(1,6)=7
26487C
26488      NUMLIN=1
26489      IF(ICASCT.EQ.'BPRO')THEN
26490        NUMCOL=10
26491        IF(IBINTA.EQ.'LOWE' .OR. IBINTA.EQ.'UPPE')NUMCOL=9
26492        ITITL2(1,7)='P'
26493        NCTIT2(1,7)=1
26494        ITITL2(1,8)='N'
26495        NCTIT2(1,8)=1
26496        IF(IBINTA.EQ.'LOWE')THEN
26497          ITITL2(1,9)(1:40)='Lower AC'
26498          NCTIT2(1,9)=8
26499        ELSEIF(IBINTA.EQ.'UPPE')THEN
26500          ITITL2(1,9)(1:40)='Upper AC'
26501          NCTIT2(1,9)=8
26502        ELSE
26503          ITITL2(1,9)(1:40)='Lower AC'
26504          NCTIT2(1,9)=8
26505          ITITL2(1,10)(1:40)='Upper AC'
26506          NCTIT2(1,10)=8
26507        ENDIF
26508      ELSEIF(ICASCT.EQ.'MECL' .OR. ICASCT.EQ.'MDCL')THEN
26509        NUMCOL=10
26510        IF(ICASCT.EQ.'MECL')THEN
26511          ITITL2(1,7)='Mean'
26512          NCTIT2(1,7)=4
26513        ELSE
26514          ITITL2(1,7)='Median'
26515          NCTIT2(1,7)=6
26516        ENDIF
26517        ITITL2(1,8)='N'
26518        NCTIT2(1,8)=1
26519        ITITL2(1,9)='Lower Limit'
26520        ITITL2(1,9)='Upper Limit'
26521        NCTIT2(1,10)=11
26522        NCTIT2(1,10)=11
26523      ELSE
26524        NUMCOL=7
26525        ITITL2(1,7)(1:15)=ICTNAM(1:15)
26526        NTEMP=15
26527        DO4070I=15,1,-1
26528          IF(ITITL2(1,7)(I:I).NE.' ')THEN
26529            NTEMP=I
26530            GOTO4079
26531          ENDIF
26532 4070   CONTINUE
26533 4079   CONTINUE
26534        NCTIT2(1,7)=NTEMP
26535      ENDIF
26536C
26537      NMAX=0
26538      DO4210I=1,NUMCOL
26539        VALIGN(I)='b'
26540        ALIGN(I)='r'
26541        NTOT(I)=15
26542        IF(NCTIT2(1,I).GT.NTOT(I))NTOT(I)=NCTIT2(1,I)
26543        NMAX=NMAX+NTOT(I)
26544        IDIGIT(I)=NUMDIG
26545        ITYPCO(I)='NUME'
26546        IF(I.EQ.8)THEN
26547          NTOT(I)=8
26548          IDIGIT(I)=0
26549        ELSEIF(I.EQ.6)THEN
26550          ITYPCO(I)='ALPH'
26551          NTOT(I)=7
26552          IDIGIT(I)=-1
26553CCCCC   ELSEIF(I.EQ.6)THEN
26554CCCCC     IF(ICASCT.NE.'BPRO' .AND. ICASCT.NE.'MECL' .AND.
26555CCCCC1       ICASCT.NE.'MDCL')THEN
26556CCCCC        ALIGN(I)='l'
26557CCCCC     ENDIF
26558        ENDIF
26559 4210 CONTINUE
26560C
26561      IWHTML(1)=100
26562      IWHTML(2)=100
26563      IWHTML(3)=100
26564      IWHTML(4)=100
26565      IWHTML(5)=100
26566      IWHTML(6)=25
26567      IWHTML(7)=100
26568      IWHTML(8)=75
26569      IWHTML(9)=100
26570      IWHTML(10)=100
26571      IJUNK=1300
26572      IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
26573     1   ICASCT.EQ.'MDCL')THEN
26574        IJUNK=1000
26575        IPTSAV=IRTFPS
26576        IRTFPS=16
26577        CALL DPCONA(92,IBASLC)
26578        WRITE(ICOUT,7003)IBASLC,IRTFPS
26579 7003   FORMAT(A1,'fs',I2)
26580        CALL DPWRST('XXX','WRIT')
26581      ENDIF
26582      IWRTF(1)=IJUNK
26583      IWRTF(2)=IWRTF(1)+IJUNK
26584      IWRTF(3)=IWRTF(2)+IJUNK
26585      IWRTF(4)=IWRTF(3)+IJUNK
26586      IWRTF(5)=IWRTF(4)+IJUNK
26587      IWRTF(6)=IWRTF(5)+200
26588      IWRTF(7)=IWRTF(6)+IJUNK
26589      IWRTF(8)=IWRTF(7)+800
26590      IWRTF(9)=IWRTF(8)+IJUNK
26591      IWRTF(10)=IWRTF(9)+IJUNK
26592      IFRST=.TRUE.
26593      ILAST=.TRUE.
26594      IFLAGS=.TRUE.
26595      IFLAGE=.FALSE.
26596      ICALL=0
26597C
26598      ICNT=0
26599      DO4310I=1,N2
26600        IF(ICNT.GE.30)THEN
26601          IF(I.EQ.N2)IFLAGE=.TRUE.
26602          CALL DPDTA5(ITITLE,NCTITL,
26603     1                ITITL9,NCTIT9,ITITL2,NCTIT2,
26604     1                MAXLIN,NUMLIN,NUMCLI,NUMCOL,
26605     1                IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
26606     1                IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
26607     1                ICAPSW,ICAPTY,IFRST,ILAST,
26608     1                IFLAGS,IFLAGE,
26609     1                ISUBRO,IBUGA3,IERROR)
26610          IFRST=.FALSE.
26611          IFLAGS=.FALSE.
26612          ICALL=1
26613          ICNT=0
26614        ENDIF
26615        ICNT=ICNT+1
26616        NCTEXT(ICNT)=0
26617        AMAT(ICNT,1)=X2(I)
26618        AMAT(ICNT,2)=D2(I)
26619        AMAT(ICNT,3)=DSIZE(I)
26620        AMAT(ICNT,4)=DCOLOR(I)
26621        AMAT(ICNT,5)=DFILL(I)
26622        AMAT(ICNT,6)=0.0
26623        AMAT(ICNT,7)=Y2(I)
26624        IF(ICASCT.EQ.'BPRO' .AND. IBINTA.EQ.'LOWE')THEN
26625          AMAT(ICNT,8)=XNTRIA(I)
26626          AMAT(ICNT,9)=XACLOW(I)
26627        ELSEIF(ICASCT.EQ.'BPRO' .AND. IBINTA.EQ.'UPPE')THEN
26628          AMAT(ICNT,8)=XNTRIA(I)
26629          AMAT(ICNT,9)=XACUPP(I)
26630        ELSEIF(ICASCT.EQ.'BPRO')THEN
26631          AMAT(ICNT,8)=XNTRIA(I)
26632          AMAT(ICNT,9)=XACLOW(I)
26633          AMAT(ICNT,10)=XACUPP(I)
26634        ELSEIF(ICASCT.EQ.'MECL' .OR. ICASCT.EQ.'MDCL')THEN
26635          AMAT(ICNT,8)=XNTRIA(I)
26636          AMAT(ICNT,9)=XACLOW(I)
26637          AMAT(ICNT,10)=XACUPP(I)
26638        ENDIF
26639        DO4320J=1,NUMCOL
26640          IF(J.EQ.6)THEN
26641            NCVALU(ICNT,J)=7
26642            IVALUE(ICNT,J)='   |   '
26643            IF(ICAPTY.EQ.'LATE')THEN
26644              IVALUE(ICNT,J)='  $|$  '
26645            ENDIF
26646          ELSE
26647            NCVALU(ICNT,J)=0
26648            IVALUE(ICNT,J)=' '
26649          ENDIF
26650 4320   CONTINUE
26651 4310 CONTINUE
26652C
26653      IF(ICNT.GE.1)THEN
26654        IFLAGE=.TRUE.
26655        ILAST=.TRUE.
26656        CALL DPDTA5(ITITLE,NCTITL,
26657     1              ITITL9,NCTIT9,ITITL2,NCTIT2,
26658     1              MAXLIN,NUMLIN,NUMCLI,NUMCOL,
26659     1              IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
26660     1              IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
26661     1              ICAPSW,ICAPTY,IFRST,ILAST,
26662     1              IFLAGS,IFLAGE,
26663     1              ISUBRO,IBUGA3,IERROR)
26664      ENDIF
26665C
26666      IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
26667     1   ICASCT.EQ.'MDCL')THEN
26668        IJUNK=1000
26669        IRTFPS=IPTSAV
26670        WRITE(ICOUT,7003)IBASLC,IRTFPS
26671        CALL DPWRST('XXX','WRIT')
26672      ENDIF
26673C
26674 8000 CONTINUE
26675      IF(IFEEDB.EQ.'ON')THEN
26676        WRITE(ICOUT,9212)
26677 9212   FORMAT(6X,'GROUP-IDs AND STATISTIC WRITTEN TO FILE ',
26678     1         'DPST1F.DAT')
26679        CALL DPWRST('XXX','BUG ')
26680      ENDIF
26681C
26682C               ******************
26683C               **   STEP 90--  **
26684C               **   EXIT       **
26685C               ******************
26686C
26687 9000 CONTINUE
26688C
26689      IF(IBFLAG.EQ.'BRAT')THEN
26690        ICASCT='BRAT'
26691      ENDIF
26692C
26693      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CRT6')THEN
26694        WRITE(ICOUT,999)
26695        CALL DPWRST('XXX','BUG ')
26696        WRITE(ICOUT,9011)
26697 9011   FORMAT('***** AT THE END       OF DPCRT6--')
26698        CALL DPWRST('XXX','BUG ')
26699        WRITE(ICOUT,9012)ICASCT,N,N2,IERROR
26700 9012   FORMAT('ICASCT,N,N2,IERROR = ',A4,2I8,2X,A4)
26701        CALL DPWRST('XXX','BUG ')
26702        WRITE(ICOUT,9013)NUMV2
26703 9013   FORMAT('NUMV2 = ',I8)
26704        CALL DPWRST('XXX','BUG ')
26705        WRITE(ICOUT,9015)NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5
26706 9015   FORMAT('NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5 = ',5I8)
26707        CALL DPWRST('XXX','BUG ')
26708        WRITE(ICOUT,9016)ANUMS1,ANUMS2,ANUMS3,ANUMS4,ANUMSE5
26709 9016   FORMAT('ANUMS1,ANUMS2,ANUMS3,ANUMS4,ANUMSE5 = ',5G15.7)
26710        CALL DPWRST('XXX','BUG ')
26711        DO9020I=1,N2
26712          WRITE(ICOUT,9021)I,Y2(I),X2(I),DSIZE(I),D2(I)
26713 9021     FORMAT('I,Y2(I),X2(I),DSIZE(I),D2(I) = ',I8,4G15.7)
26714          CALL DPWRST('XXX','BUG ')
26715 9020   CONTINUE
26716      ENDIF
26717C
26718      RETURN
26719      END
26720      SUBROUTINE DPCRT7(Y,Z,Z2,TAG1,TAG2,TAG3,TAG4,TAG5,TAG6,N,
26721     1                  NUMV2,ICASCT,ICTNAM,
26722     1                  XIDTEM,XIDTE2,XIDTE3,XIDTE4,XIDTE5,XIDTE6,
26723     1                  NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,NUMSE6,
26724     1                  TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,
26725     1                  XNTRIA,XACLOW,XACUPP,
26726     1                  ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
26727     1                  DTEMP1,DTEMP2,DTEMP3,
26728     1                  ISEED,ALPHA,
26729     1                  IXVAR,IX2VAR,IYVAR,
26730     1                  IYNAM,IXNAM,IXNAM2,
26731     1                  IX1NAM,IX2NAM,IX3NAM,IX4NAM,IX5NAM,IX6NAM,
26732     1                  ICAPSW,ICAPTY,IFORSW,
26733     1                  MAXNXT,
26734     1                  Y2,X2,D2,DSIZE,DCOLOR,DFILL,DSYMB,N2,
26735     1                  ISUBRO,IBUGA3,IERROR)
26736C
26737C     PURPOSE--GENERATE A SIX-WAY CROSS-TABULATION AND
26738C              OPTIONALLY PRINT THE RESULTS TO AN ASCII,
26739C              HTML, LATEX, OR RTF TABLE.
26740C     WRITTEN BY--ALAN HECKERT
26741C                 STATISTICAL ENGINEERING DIVISION
26742C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
26743C                 GAITHERSBURG, MD 20899-8980
26744C                 PHONE--301-975-2899
26745C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
26746C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
26747C     REFERENCE--ASTM MANUAL STP-15D, PAGES 78-84, 100-105
26748C     LANGUAGE--ANSI FORTRAN (1977)
26749C     VERSION NUMBER--2008/4
26750C     ORIGINAL VERSION--APRIL     2008.
26751C     UPDATED         --SEPTEMBER 2008. ACCOMODATE "MISSING" DATA
26752C     UPDATED         --JANUARY   2010. TREAT BINOMIAL RATIO IN A
26753C                                       SIMILAR FASHION TO BINOMIAL
26754C     UPDATED         --JUNE      2010. CALL LIST TO CMPSTA
26755C     UPDATED         --JUNE      2010. USE DPDTA5 TO PRINT TABLE
26756C
26757C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
26758C
26759      CHARACTER*4 ICASCT
26760      CHARACTER*40 ICTNAM
26761      CHARACTER*4 IXVAR
26762      CHARACTER*4 IX2VAR
26763      CHARACTER*4 IYVAR
26764      CHARACTER*4 ICAPSW
26765      CHARACTER*4 ICAPTY
26766      CHARACTER*4 IFORSW
26767      CHARACTER*4 IBUGA3
26768      CHARACTER*4 IERROR
26769C
26770      PARAMETER(NUMCLI=11)
26771      PARAMETER(MAXLIN=2)
26772      PARAMETER (MAXROW=30)
26773      CHARACTER*60 ITITLE
26774      CHARACTER*60 ITITL9
26775      CHARACTER*4  ALIGN(NUMCLI)
26776      CHARACTER*4  VALIGN(NUMCLI)
26777      INTEGER      NCTEXT(MAXROW)
26778      INTEGER      IDIGIT(MAXROW)
26779      INTEGER      NTOT(MAXROW)
26780      CHARACTER*60 ITITL2(MAXLIN,NUMCLI)
26781      CHARACTER*15 IVALUE(MAXROW,NUMCLI)
26782      CHARACTER*4  ITYPCO(NUMCLI)
26783      INTEGER      NCTIT2(MAXLIN,NUMCLI)
26784      INTEGER      NCVALU(MAXROW,NUMCLI)
26785      INTEGER      IWHTML(NUMCLI)
26786      INTEGER      IWRTF(NUMCLI)
26787      REAL         AMAT(MAXROW,NUMCLI)
26788      LOGICAL IFRST
26789      LOGICAL ILAST
26790      LOGICAL IFLAGS
26791      LOGICAL IFLAGE
26792      CHARACTER*1 IBASLC
26793C
26794      CHARACTER*8 IYNAM
26795      CHARACTER*8 IXNAM
26796      CHARACTER*8 IXNAM2
26797      CHARACTER*8 IX1NAM
26798      CHARACTER*8 IX2NAM
26799      CHARACTER*8 IX3NAM
26800      CHARACTER*8 IX4NAM
26801      CHARACTER*8 IX5NAM
26802      CHARACTER*8 IX6NAM
26803C
26804      CHARACTER*4 ISUBRO
26805      CHARACTER*4 IWRITE
26806      CHARACTER*4 ISUBN1
26807      CHARACTER*4 ISUBN2
26808      CHARACTER*4 ISTEPN
26809      CHARACTER*4 IBFLAG
26810C
26811C---------------------------------------------------------------------
26812C
26813      DIMENSION Y(*)
26814      DIMENSION Z(*)
26815      DIMENSION Z2(*)
26816      DIMENSION XIDTEM(*)
26817      DIMENSION XIDTE2(*)
26818      DIMENSION XIDTE3(*)
26819      DIMENSION XIDTE4(*)
26820      DIMENSION XIDTE5(*)
26821      DIMENSION XIDTE6(*)
26822      DIMENSION Y2(*)
26823      DIMENSION X2(*)
26824      DIMENSION D2(*)
26825      DIMENSION DSIZE(*)
26826      DIMENSION DCOLOR(*)
26827      DIMENSION DFILL(*)
26828      DIMENSION DSYMB(*)
26829C
26830      DIMENSION TAG1(*)
26831      DIMENSION TAG2(*)
26832      DIMENSION TAG3(*)
26833      DIMENSION TAG4(*)
26834      DIMENSION TAG5(*)
26835      DIMENSION TAG6(*)
26836      DIMENSION TEMP(*)
26837      DIMENSION TEMPZ(*)
26838      DIMENSION TEMPZ2(*)
26839      DIMENSION XTEMP1(*)
26840      DIMENSION XTEMP2(*)
26841      DIMENSION XTEMP3(*)
26842      DIMENSION XNTRIA(*)
26843      DIMENSION XACLOW(*)
26844      DIMENSION XACUPP(*)
26845C
26846      INTEGER ITEMP1(*)
26847      INTEGER ITEMP2(*)
26848      INTEGER ITEMP3(*)
26849      INTEGER ITEMP4(*)
26850      INTEGER ITEMP5(*)
26851      INTEGER ITEMP6(*)
26852C
26853      DOUBLE PRECISION DTEMP1(*)
26854      DOUBLE PRECISION DTEMP2(*)
26855      DOUBLE PRECISION DTEMP3(*)
26856C
26857      CHARACTER*4 IOP
26858C
26859      INCLUDE 'DPCOST.INC'
26860      INCLUDE 'DPCOP2.INC'
26861C
26862C-----START POINT-----------------------------------------------------
26863C
26864      ISUBN1='DPCR'
26865      ISUBN2='T7  '
26866C
26867      I2=0
26868      IPTSAV=IRTFPS
26869C
26870      AN=INT(N+0.01)
26871      ANUMS1=INT(NUMSE1+0.01)
26872      ANUMS2=INT(NUMSE2+0.01)
26873      ANUMS3=INT(NUMSE3+0.01)
26874      ANUMS4=INT(NUMSE4+0.01)
26875      ANUMS5=INT(NUMSE5+0.01)
26876      ANUMS6=INT(NUMSE6+0.01)
26877C
26878C               ***********************************************
26879C               **  STEP 5--                                 **
26880C               **  COMPUTE THE VARIOUS CROSS-TAB STATISTICS **
26881C               ***********************************************
26882C
26883      ISTEPN='5.1'
26884      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CRT7')
26885     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26886C
26887C     ALLOW THE   SET WRITE DECIMALS COMMAND    TO BE USED TO
26888C     DETERMINE HOW MANY DIGITS PRINTED IN TABLE.
26889C
26890      NUMDIG=-7
26891      IF(IFORSW.EQ.'1')NUMDIG=1
26892      IF(IFORSW.EQ.'2')NUMDIG=2
26893      IF(IFORSW.EQ.'3')NUMDIG=3
26894      IF(IFORSW.EQ.'4')NUMDIG=4
26895      IF(IFORSW.EQ.'5')NUMDIG=5
26896      IF(IFORSW.EQ.'6')NUMDIG=6
26897      IF(IFORSW.EQ.'7')NUMDIG=7
26898      IF(IFORSW.EQ.'8')NUMDIG=8
26899      IF(IFORSW.EQ.'9')NUMDIG=9
26900      IF(IFORSW.EQ.'0')NUMDIG=10
26901      IF(IFORSW.EQ.'-2')NUMDIG=-2
26902      IF(IFORSW.EQ.'-3')NUMDIG=-3
26903      IF(IFORSW.EQ.'-4')NUMDIG=-4
26904      IF(IFORSW.EQ.'-5')NUMDIG=-5
26905      IF(IFORSW.EQ.'-6')NUMDIG=-6
26906      IF(IFORSW.EQ.'-7')NUMDIG=-7
26907      IF(IFORSW.EQ.'-8')NUMDIG=-8
26908      IF(IFORSW.EQ.'-9')NUMDIG=-9
26909C
26910C     NOTE 9/2008: IN FOLLOWING, WE NEED TO DISTINGUISH BETWEEN
26911C                  EMPTY SETS DUE TO NO POINTS FALLING IN THE
26912C                  PARTICULAR CROSS TABULATION (IN WHICH CASE,
26913C                  WE WANT TO SKIP IN THE OUTPUT FILE) AND EMPTY
26914C                  SETS DUE TO ALL POINTS IN THE PARTICULAR
26915C                  CROSS TABULATION BEING MISSING (IN WHICH CASE,
26916C                  WE MAY WANT TO WRITE A 0 OR A MISSING VALUE).
26917C
26918C                  THERE ARE 2 MISSING VALUES:
26919C
26920C                  PSTAMV   - SPECIFIES WHETHER THE INPUT DATA
26921C                             VALUE IS TO BE INCLUDED IN THE
26922C                             COMPUTATION OF THE STATISTIC
26923C
26924C                  PCTAMV    - IF ALL THE DATA IS MISSING, THIS
26925C                              IS THE VALUE TO USE IN WRITING THE
26926C                              CROSS TABULATE OUTPUT.
26927C
26928      IWRITE='OFF'
26929      IBFLAG=ICASCT
26930      IF(IBFLAG.EQ.'BRAT')IBFLAG='BPRO'
26931C
26932      EPS=0.1E-7
26933      J=0
26934      NRESP=NUMV2-6
26935      DO1110ISET1=1,NUMSE1
26936        DO1120ISET2=1,NUMSE2
26937          DO1130ISET3=1,NUMSE3
26938          DO1140ISET4=1,NUMSE4
26939          DO1150ISET5=1,NUMSE5
26940          DO1160ISET6=1,NUMSE6
26941C
26942            K=0
26943            NTEMP2=0
26944            DO1180I=1,N
26945              IF(XIDTEM(ISET1).EQ.TAG1(I) .AND.
26946     1           XIDTE2(ISET2).EQ.TAG2(I) .AND.
26947     1           XIDTE3(ISET3).EQ.TAG3(I) .AND.
26948     1           XIDTE4(ISET4).EQ.TAG4(I) .AND.
26949     1           XIDTE5(ISET5).EQ.TAG5(I) .AND.
26950     1           XIDTE6(ISET6).EQ.TAG6(I))
26951     1           GOTO1181
26952              GOTO1180
26953 1181         CONTINUE
26954C
26955              NTEMP2=NTEMP2+1
26956              IF(IYVAR.EQ.'OFF')THEN
26957                K=K+1
26958                TEMP(K)=0.0
26959              ELSE
26960                IF(ABS(Y(I)-PSTAMV).GT.EPS)THEN
26961                  K=K+1
26962                  TEMP(K)=Y(I)
26963                  IF(IXVAR.EQ.'ON')TEMPZ(K)=Z(I)
26964                  IF(IX2VAR.EQ.'ON')TEMPZ2(K)=Z2(I)
26965                ENDIF
26966              ENDIF
26967 1180       CONTINUE
26968            NTEMP=K
26969C
26970C           AUGUST 2002.  CALL CMPSTA (EXCEPT FOR CHI-SQUARE CASE)
26971C
26972C           NTEMP2 IS THE NUMBER OF POINTS IN THE SUBSET AND
26973C           NTEMP IS THE NUMBER OF NON-MISSING POINTS IN THE SUBSET.
26974C
26975            IF(NTEMP2.EQ.0)GOTO1160
26976C
26977            IF(NTEMP.EQ.0)THEN
26978              IF(ICTAMV.EQ.'ZERO')THEN
26979                STAT=0.0
26980                IF(IBFLAG.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
26981     1             ICASCT.EQ.'MDCL')THEN
26982                  NTRIAL=0
26983                  ALOWLM=0.0
26984                  AUPPLM=0.0
26985                ENDIF
26986              ELSEIF(ICTAMV.EQ.'MV  ')THEN
26987                STAT=PCTAMV
26988                IF(IBFLAG.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
26989     1             ICASCT.EQ.'MDCL')THEN
26990                  NTRIAL=0
26991                  ALOWLM=PCTAMV
26992                  AUPPLM=PCTAMV
26993                ENDIF
26994              ELSE
26995                GOTO1160
26996              ENDIF
26997            ELSE
26998              CALL CMPSTA(
26999     1              TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,
27000     1              MAXNXT,NTEMP,NTEMP,NTEMP,
27001     1              NRESP,ICASCT,
27002     1              ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
27003     1              DTEMP1,DTEMP2,DTEMP3,
27004CCCCC1              IQUAME,IQUASE,PSTAMV,
27005     1              STAT,
27006     1              ISUBRO,IBUGA3,IERROR)
27007              IF(IERROR.EQ.'YES')GOTO9000
27008              IF(IBFLAG.EQ.'BPRO')THEN
27009                PTEMP=STAT
27010                NTRIAL=NTEMP
27011                IF(ICASCT.EQ.'BRAT')NTRIAL=ITEMP1(1)
27012                IF(STAT.EQ.PSTAMV)THEN
27013                  ALOWLM=PSTAMV
27014                  AUPPLM=PSTAMV
27015                ELSE
27016                  ALPHAT=ALPHA
27017                  CALL DPAGCO(PTEMP,NTRIAL,ALPHAT,IWRITE,
27018     1                        ALOWLM,AUPPLM,IBUGA3,IERROR)
27019                ENDIF
27020              ELSEIF(ICASCT.EQ.'MECL')THEN
27021                XMEAN=STAT
27022                NTRIAL=NTEMP
27023                IF(STAT.EQ.PSTAMV)THEN
27024                  ALOWLM=PSTAMV
27025                  AUPPLM=PSTAMV
27026                ELSE
27027                  CALL SD(TEMP,NTEMP,IWRITE,XSD,IBUGA3,IERROR)
27028                  ALPHAT=ALPHA
27029                  CALL DPMECL(XMEAN,XSD,NTEMP,ALPHAT,IWRITE,
27030     1                        ALOWLM,AUPPLM,IBUGA3,IERROR)
27031                ENDIF
27032              ELSEIF(ICASCT.EQ.'MDCL')THEN
27033                XMED=STAT
27034                NTRIAL=NTEMP
27035                IF(STAT.EQ.PSTAMV)THEN
27036                  ALOWLM=PSTAMV
27037                  AUPPLM=PSTAMV
27038                ELSE
27039                  XQ=0.5
27040                  CALL QUANSE(XQ,TEMP,NTEMP,IWRITE,XTEMP1,MAXNXT,IQUASE,
27041     1                        QUASE,IBUGA3,IERROR)
27042                  ALPHAT=ALPHA
27043                  CALL DPMECL(XMED,QUASE,NTEMP,ALPHAT,IWRITE,
27044     1                        ALOWLM,AUPPLM,IBUGA3,IERROR)
27045                ENDIF
27046              ENDIF
27047            ENDIF
27048C
27049            J=J+1
27050            Y2(J)=STAT
27051            X2(J)=XIDTEM(ISET1)
27052            D2(J)=XIDTE2(ISET2)
27053            DSIZE(J)=XIDTE3(ISET3)
27054            DCOLOR(J)=XIDTE4(ISET4)
27055            DFILL(J)=XIDTE5(ISET5)
27056            DSYMB(J)=XIDTE6(ISET6)
27057            IF(IBFLAG.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
27058     1         ICASCT.EQ.'MDCL')THEN
27059              XNTRIA(J)=REAL(NTRIAL)
27060              XACLOW(J)=ALOWLM
27061              XACUPP(J)=AUPPLM
27062            ENDIF
27063C
27064 1160     CONTINUE
27065 1150     CONTINUE
27066 1140     CONTINUE
27067 1130     CONTINUE
27068 1120   CONTINUE
27069 1110 CONTINUE
27070      N2=J
27071C
27072      IF(ICASCT.EQ.'BRAT')THEN
27073        IBFLAG='BRAT'
27074        ICASCT='BPRO'
27075      ENDIF
27076C
27077      IOP='OPEN'
27078      IFLG11=1
27079      IFLG21=0
27080      IFLG31=0
27081      IFLAG4=0
27082      IFLAG5=0
27083      CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLAG4,IFLAG5,
27084     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
27085     1            IBUGA3,ISUBRO,IERROR)
27086      IF(IERROR.EQ.'YES')GOTO9000
27087C
27088      WRITE(IOUNI1,2111)ICTNAM
27089 2111 FORMAT(' GROUP-ID 1   GROUP-ID 2   GROUP-ID 3   GROUP-ID 4',
27090     1       '   GROUP-ID 5   GROUP-ID 6           ',A40)
27091C
27092      IF(ICASCT.EQ.'BPRO')THEN
27093        DO2170I=1,N2
27094          IF(IBINTA.EQ.'LOWE')THEN
27095            WRITE(IOUNI1,2171)X2(I),D2(I),DSIZE(I),DCOLOR(I),DFILL(I),
27096     1                        DSYMB(I),Y2(I),XNTRIA(I),XACLOW(I)
27097
27098 2171       FORMAT(9E17.9)
27099          ELSEIF(IBINTA.EQ.'UPPE')THEN
27100            WRITE(IOUNI1,2171)X2(I),D2(I),DSIZE(I),DCOLOR(I),DFILL(I),
27101     1                        DSYMB(I),Y2(I),XNTRIA(I),XACUPP(I)
27102          ELSE
27103            WRITE(IOUNI1,2173)X2(I),D2(I),DSIZE(I),DCOLOR(I),DFILL(I),
27104     1                        DSYMB(I),Y2(I),XNTRIA(I),
27105     1                        XACLOW(I),XACUPP(I)
27106 2173       FORMAT(10E17.9)
27107          ENDIF
27108 2170   CONTINUE
27109      ELSEIF(ICASCT.EQ.'MECL' .OR. ICASCT.EQ.'MDCL')THEN
27110        DO2175I=1,N2
27111          WRITE(IOUNI1,2173)X2(I),D2(I),DSIZE(I),DCOLOR(I),DFILL(I),
27112     1                      DSYMB(I),Y2(I),XNTRIA(I),XACLOW(I),XACUPP(I)
27113 2175   CONTINUE
27114      ELSE
27115        DO2160I=1,N2
27116          WRITE(IOUNI1,2161)X2(I),D2(I),DSIZE(I),DCOLOR(I),DFILL(I),
27117     1                      DSYMB(I),Y2(I)
27118 2161     FORMAT(7E17.9)
27119 2160   CONTINUE
27120      ENDIF
27121C
27122      IOP='CLOS'
27123      CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLAG4,IFLAG5,
27124     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
27125     1            IBUGA3,ISUBRO,IERROR)
27126      IF(IERROR.EQ.'YES')GOTO9000
27127C
27128C               *****************************
27129C               **   STEP 6--              **
27130C               **   WRITE OUT THE TABLE   **
27131C               *****************************
27132C
27133      ISTEPN='6'
27134      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CRT7')
27135     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
27136C
27137      WRITE(ICOUT,999)
27138  999 FORMAT(1X)
27139      CALL DPWRST('XXX','BUG ')
27140C
27141      IF(IPRINT.EQ.'OFF')GOTO8000
27142C
27143      ITITLE(1:15)='Cross Tabulate '
27144      IF(ICASCT.EQ.'BPRO')THEN
27145        NCTITL=37
27146        ITITLE(16:NCTITL)='Binomial Probabilities'
27147      ELSEIF(ICASCT.EQ.'MECL')THEN
27148        NCTITL=37
27149        ITITLE(16:NCTITL)='Mean Confidence Limits'
27150      ELSEIF(ICASCT.EQ.'MDCL')THEN
27151        NCTITL=39
27152        ITITLE(16:NCTITL)='Median Confidence Limits'
27153      ELSE
27154        ITITLE(16:55)=ICTNAM(1:40)
27155        NCTITL=55
27156        DO4010I=55,1,-1
27157          IF(ITITLE(I:I).NE.' ')THEN
27158            NCTITL=I
27159            GOTO4019
27160          ENDIF
27161 4010   CONTINUE
27162 4019   CONTINUE
27163      ENDIF
27164C
27165      IF(IYVAR.EQ.'ON')THEN
27166        ITITL9(1:21)='(Response Variables: '
27167        NTEMP=21
27168        ITITL9(22:30)=IYNAM(1:8)
27169        NTEMP=30
27170        IF(IXVAR.EQ.'ON')THEN
27171          ITITL9(30:30)=' '
27172          ITITL9(31:38)=IXNAM(1:8)
27173          NTEMP=38
27174        ENDIF
27175        IF(IX2VAR.EQ.'ON')THEN
27176          ITITL9(39:39)=' '
27177          ITITL9(40:47)=IXNAM2(1:8)
27178          NTEMP=47
27179        ENDIF
27180        NTEMP=NTEMP+1
27181        ITITL9(NTEMP:NTEMP)=')'
27182        NCTIT9=NTEMP
27183      ELSE
27184        ITITL9=' '
27185        NCTIT9=0
27186      ENDIF
27187C
27188      ITITL2(1,1)(1:8)=IX1NAM
27189      NCTIT2(1,1)=8
27190      ITITL2(1,2)(1:8)=IX2NAM
27191      NCTIT2(1,2)=8
27192      ITITL2(1,3)(1:8)=IX3NAM
27193      NCTIT2(1,3)=8
27194      ITITL2(1,4)(1:8)=IX4NAM
27195      NCTIT2(1,4)=8
27196      ITITL2(1,5)(1:8)=IX5NAM
27197      NCTIT2(1,5)=8
27198      ITITL2(1,6)(1:8)=IX6NAM
27199      NCTIT2(1,6)=8
27200      ITITL2(1,7)='   |   '
27201      IF(ICAPTY.EQ.'LATE')THEN
27202        ITITL2(1,7)='  $|$  '
27203      ENDIF
27204      NCTIT2(1,7)=7
27205C
27206      NUMLIN=1
27207      IF(ICASCT.EQ.'BPRO')THEN
27208        NUMCOL=11
27209        IF(IBINTA.EQ.'LOWE' .OR. IBINTA.EQ.'UPPE')NUMCOL=10
27210        ITITL2(1,8)='P'
27211        NCTIT2(1,8)=1
27212        ITITL2(1,9)='N'
27213        NCTIT2(1,9)=1
27214        IF(IBINTA.EQ.'LOWE')THEN
27215          ITITL2(1,10)(1:40)='Lower AC'
27216          NCTIT2(1,10)=8
27217        ELSEIF(IBINTA.EQ.'UPPE')THEN
27218          ITITL2(1,10)(1:40)='Upper AC'
27219          NCTIT2(1,10)=8
27220        ELSE
27221          ITITL2(1,10)(1:40)='Lower AC'
27222          NCTIT2(1,10)=8
27223          ITITL2(1,11)(1:40)='Upper AC'
27224          NCTIT2(1,11)=8
27225        ENDIF
27226      ELSEIF(ICASCT.EQ.'MECL' .OR. ICASCT.EQ.'MDCL')THEN
27227        NUMCOL=11
27228        IF(ICASCT.EQ.'MECL')THEN
27229          ITITL2(1,8)='Mean'
27230          NCTIT2(1,8)=4
27231        ELSE
27232          ITITL2(1,8)='Median'
27233          NCTIT2(1,8)=6
27234        ENDIF
27235        ITITL2(1,9)='N'
27236        NCTIT2(1,9)=1
27237        ITITL2(1,10)='Lower Limit'
27238        ITITL2(1,10)='Upper Limit'
27239        NCTIT2(1,11)=11
27240        NCTIT2(1,11)=11
27241      ELSE
27242        NUMCOL=8
27243        ITITL2(1,8)(1:15)=ICTNAM(1:15)
27244        NTEMP=15
27245        DO4070I=15,1,-1
27246          IF(ITITL2(1,8)(I:I).NE.' ')THEN
27247            NTEMP=I
27248            GOTO4079
27249          ENDIF
27250 4070   CONTINUE
27251 4079   CONTINUE
27252        NCTIT2(1,8)=NTEMP
27253      ENDIF
27254C
27255      NMAX=0
27256      DO4210I=1,NUMCOL
27257        VALIGN(I)='b'
27258        ALIGN(I)='r'
27259        NTOT(I)=15
27260        IF(NCTIT2(1,I).GT.NTOT(I))NTOT(I)=NCTIT2(1,I)
27261        NMAX=NMAX+NTOT(I)
27262        IDIGIT(I)=NUMDIG
27263        ITYPCO(I)='NUME'
27264        IF(I.EQ.9)THEN
27265          NTOT(I)=8
27266          IDIGIT(I)=0
27267        ELSEIF(I.EQ.7)THEN
27268          ITYPCO(I)='ALPH'
27269          NTOT(I)=7
27270          IDIGIT(I)=-1
27271CCCCC   ELSEIF(I.EQ.6)THEN
27272CCCCC     IF(ICASCT.NE.'BPRO' .AND. ICASCT.NE.'MECL' .AND.
27273CCCCC1       ICASCT.NE.'MDCL')THEN
27274CCCCC        ALIGN(I)='l'
27275CCCCC     ENDIF
27276        ENDIF
27277 4210 CONTINUE
27278C
27279      IWHTML(1)=100
27280      IWHTML(2)=100
27281      IWHTML(3)=100
27282      IWHTML(4)=100
27283      IWHTML(5)=100
27284      IWHTML(6)=100
27285      IWHTML(7)=25
27286      IWHTML(8)=100
27287      IWHTML(9)=75
27288      IWHTML(10)=100
27289      IWHTML(11)=100
27290      IJUNK=1300
27291      IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
27292     1   ICASCT.EQ.'MDCL')THEN
27293        IJUNK=900
27294        IPTSAV=IRTFPS
27295        IRTFPS=14
27296        CALL DPCONA(92,IBASLC)
27297        WRITE(ICOUT,7003)IBASLC,IRTFPS
27298 7003   FORMAT(A1,'fs',I2)
27299        CALL DPWRST('XXX','WRIT')
27300      ENDIF
27301      IWRTF(1)=IJUNK
27302      IWRTF(2)=IWRTF(1)+IJUNK
27303      IWRTF(3)=IWRTF(2)+IJUNK
27304      IWRTF(4)=IWRTF(3)+IJUNK
27305      IWRTF(5)=IWRTF(4)+IJUNK
27306      IWRTF(6)=IWRTF(5)+IJUNK
27307      IWRTF(7)=IWRTF(6)+200
27308      IWRTF(8)=IWRTF(7)+IJUNK
27309      IWRTF(9)=IWRTF(8)+800
27310      IWRTF(10)=IWRTF(9)+IJUNK
27311      IWRTF(11)=IWRTF(10)+IJUNK
27312      IFRST=.TRUE.
27313      ILAST=.TRUE.
27314      IFLAGS=.TRUE.
27315      IFLAGE=.FALSE.
27316      ICALL=0
27317C
27318      ICNT=0
27319      DO4310I=1,N2
27320        IF(ICNT.GE.30)THEN
27321          IF(I.EQ.N2)IFLAGE=.TRUE.
27322          CALL DPDTA5(ITITLE,NCTITL,
27323     1                ITITL9,NCTIT9,ITITL2,NCTIT2,
27324     1                MAXLIN,NUMLIN,NUMCLI,NUMCOL,
27325     1                IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
27326     1                IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
27327     1                ICAPSW,ICAPTY,IFRST,ILAST,
27328     1                IFLAGS,IFLAGE,
27329     1                ISUBRO,IBUGA3,IERROR)
27330          IFRST=.FALSE.
27331          IFLAGS=.FALSE.
27332          ICALL=1
27333          ICNT=0
27334        ENDIF
27335        ICNT=ICNT+1
27336        NCTEXT(ICNT)=0
27337        AMAT(ICNT,1)=X2(I)
27338        AMAT(ICNT,2)=D2(I)
27339        AMAT(ICNT,3)=DSIZE(I)
27340        AMAT(ICNT,4)=DCOLOR(I)
27341        AMAT(ICNT,5)=DFILL(I)
27342        AMAT(ICNT,6)=DSYMB(I)
27343        AMAT(ICNT,7)=0.0
27344        AMAT(ICNT,8)=Y2(I)
27345        IF(ICASCT.EQ.'BPRO' .AND. IBINTA.EQ.'LOWE')THEN
27346          AMAT(ICNT,9)=XNTRIA(I)
27347          AMAT(ICNT,10)=XACLOW(I)
27348        ELSEIF(ICASCT.EQ.'BPRO' .AND. IBINTA.EQ.'UPPE')THEN
27349          AMAT(ICNT,9)=XNTRIA(I)
27350          AMAT(ICNT,10)=XACUPP(I)
27351        ELSEIF(ICASCT.EQ.'BPRO')THEN
27352          AMAT(ICNT,9)=XNTRIA(I)
27353          AMAT(ICNT,10)=XACLOW(I)
27354          AMAT(ICNT,11)=XACUPP(I)
27355        ELSEIF(ICASCT.EQ.'MECL' .OR. ICASCT.EQ.'MDCL')THEN
27356          AMAT(ICNT,9)=XNTRIA(I)
27357          AMAT(ICNT,10)=XACLOW(I)
27358          AMAT(ICNT,11)=XACUPP(I)
27359        ENDIF
27360        DO4320J=1,NUMCOL
27361          IF(J.EQ.7)THEN
27362            NCVALU(ICNT,J)=7
27363            IVALUE(ICNT,J)='   |   '
27364            IF(ICAPTY.EQ.'LATE')THEN
27365              IVALUE(ICNT,J)='  $|$  '
27366            ENDIF
27367          ELSE
27368            NCVALU(ICNT,J)=0
27369            IVALUE(ICNT,J)=' '
27370          ENDIF
27371 4320   CONTINUE
27372 4310 CONTINUE
27373C
27374      IF(ICNT.GE.1)THEN
27375        IFLAGE=.TRUE.
27376        ILAST=.TRUE.
27377        CALL DPDTA5(ITITLE,NCTITL,
27378     1              ITITL9,NCTIT9,ITITL2,NCTIT2,
27379     1              MAXLIN,NUMLIN,NUMCLI,NUMCOL,
27380     1              IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
27381     1              IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
27382     1              ICAPSW,ICAPTY,IFRST,ILAST,
27383     1              IFLAGS,IFLAGE,
27384     1              ISUBRO,IBUGA3,IERROR)
27385      ENDIF
27386C
27387      IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
27388     1   ICASCT.EQ.'MDCL')THEN
27389        IRTFPS=IPTSAV
27390        WRITE(ICOUT,7003)IBASLC,IRTFPS
27391        CALL DPWRST('XXX','WRIT')
27392      ENDIF
27393C
27394 8000 CONTINUE
27395      IF(IFEEDB.EQ.'ON')THEN
27396        WRITE(ICOUT,9212)
27397 9212   FORMAT(6X,'GROUP-IDs AND STATISTIC WRITTEN TO FILE ',
27398     1         'DPST1F.DAT')
27399        CALL DPWRST('XXX','BUG ')
27400      ENDIF
27401C
27402C               ******************
27403C               **   STEP 90--  **
27404C               **   EXIT       **
27405C               ******************
27406C
27407 9000 CONTINUE
27408C
27409      IF(IBFLAG.EQ.'BRAT')THEN
27410        ICASCT='BRAT'
27411      ENDIF
27412C
27413      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CRT7')THEN
27414        WRITE(ICOUT,999)
27415        CALL DPWRST('XXX','BUG ')
27416        WRITE(ICOUT,9011)
27417 9011   FORMAT('***** AT THE END       OF DPCRT7--')
27418        CALL DPWRST('XXX','BUG ')
27419        WRITE(ICOUT,9012)ICASCT,N,N2,IERROR
27420 9012   FORMAT('ICASCT,N,N2,IERROR = ',A4,2I8,2X,A4)
27421        CALL DPWRST('XXX','BUG ')
27422        WRITE(ICOUT,9013)NUMV2
27423 9013   FORMAT('NUMV2 = ',I8)
27424        CALL DPWRST('XXX','BUG ')
27425        WRITE(ICOUT,9015)NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,NUMSE6
27426 9015   FORMAT('NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,NUMSE6 = ',6I8)
27427        CALL DPWRST('XXX','BUG ')
27428        WRITE(ICOUT,9016)ANUMS1,ANUMS2,ANUMS3,ANUMS4,ANUMSE5,ANUMSE6
27429 9016   FORMAT('ANUMS1,ANUMS2,ANUMS3,ANUMS4,ANUMSE5,ANUMSE6 = ',6G15.7)
27430        CALL DPWRST('XXX','BUG ')
27431        DO9020I=1,N2
27432          WRITE(ICOUT,9021)I,Y2(I),X2(I),DSIZE(I),D2(I)
27433 9021     FORMAT('I,Y2(I),X2(I),DSIZE(I),D2(I) = ',I8,4G15.7)
27434          CALL DPWRST('XXX','BUG ')
27435 9020   CONTINUE
27436      ENDIF
27437C
27438      RETURN
27439      END
27440      SUBROUTINE DPCRT8(Y,Z,Z2,TAG1,TAG2,TAG3,TAG4,TAG5,TAG6,TAG7,N,
27441     1                  NUMV2,ICASCT,ICTNAM,
27442     1                  XIDTEM,XIDTE2,XIDTE3,XIDTE4,
27443     1                  XIDTE5,XIDTE6,XIDTE7,
27444     1                  NUMSE1,NUMSE2,NUMSE3,NUMSE4,
27445     1                  NUMSE5,NUMSE6,NUMSE7,
27446     1                  TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,
27447     1                  XNTRIA,XACLOW,XACUPP,
27448     1                  ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
27449     1                  DTEMP1,DTEMP2,DTEMP3,
27450     1                  ISEED,ALPHA,
27451     1                  IXVAR,IX2VAR,IYVAR,
27452     1                  IYNAM,IXNAM,IXNAM2,
27453     1                  IX1NAM,IX2NAM,IX3NAM,IX4NAM,IX5NAM,IX6NAM,
27454     1                  IX7NAM,
27455     1                  ICAPSW,ICAPTY,IFORSW,
27456     1                  MAXNXT,
27457     1                  Y2,X2,D2,DSIZE,DCOLOR,DFILL,DSYMB,XPLOT,N2,
27458     1                  ISUBRO,IBUGA3,IERROR)
27459C
27460C     PURPOSE--GENERATE A SEVEN-WAY CROSS-TABULATION AND
27461C              OPTIONALLY PRINT THE RESULTS TO AN ASCII,
27462C              HTML, LATEX, OR RTF TABLE.
27463C     WRITTEN BY--ALAN HECKERT
27464C                 STATISTICAL ENGINEERING DIVISION
27465C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
27466C                 GAITHERSBURG, MD 20899-8980
27467C                 PHONE--301-975-2899
27468C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
27469C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
27470C     REFERENCE--ASTM MANUAL STP-15D, PAGES 78-84, 100-105
27471C     LANGUAGE--ANSI FORTRAN (1977)
27472C     VERSION NUMBER--2014/5
27473C     ORIGINAL VERSION--MAY       2014.
27474C
27475C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
27476C
27477      CHARACTER*4 ICASCT
27478      CHARACTER*40 ICTNAM
27479      CHARACTER*4 IXVAR
27480      CHARACTER*4 IX2VAR
27481      CHARACTER*4 IYVAR
27482      CHARACTER*4 ICAPSW
27483      CHARACTER*4 ICAPTY
27484      CHARACTER*4 IFORSW
27485      CHARACTER*4 IBUGA3
27486      CHARACTER*4 IERROR
27487C
27488      PARAMETER(NUMCLI=12)
27489      PARAMETER(MAXLIN=2)
27490      PARAMETER (MAXROW=30)
27491      CHARACTER*60 ITITLE
27492      CHARACTER*60 ITITL9
27493      CHARACTER*4  ALIGN(NUMCLI)
27494      CHARACTER*4  VALIGN(NUMCLI)
27495      INTEGER      NCTEXT(MAXROW)
27496      INTEGER      IDIGIT(MAXROW)
27497      INTEGER      NTOT(MAXROW)
27498      CHARACTER*60 ITITL2(MAXLIN,NUMCLI)
27499      CHARACTER*15 IVALUE(MAXROW,NUMCLI)
27500      CHARACTER*4  ITYPCO(NUMCLI)
27501      INTEGER      NCTIT2(MAXLIN,NUMCLI)
27502      INTEGER      NCVALU(MAXROW,NUMCLI)
27503      INTEGER      IWHTML(NUMCLI)
27504      INTEGER      IWRTF(NUMCLI)
27505      REAL         AMAT(MAXROW,NUMCLI)
27506      LOGICAL IFRST
27507      LOGICAL ILAST
27508      LOGICAL IFLAGS
27509      LOGICAL IFLAGE
27510      CHARACTER*1 IBASLC
27511C
27512      CHARACTER*8 IYNAM
27513      CHARACTER*8 IXNAM
27514      CHARACTER*8 IXNAM2
27515      CHARACTER*8 IX1NAM
27516      CHARACTER*8 IX2NAM
27517      CHARACTER*8 IX3NAM
27518      CHARACTER*8 IX4NAM
27519      CHARACTER*8 IX5NAM
27520      CHARACTER*8 IX6NAM
27521      CHARACTER*8 IX7NAM
27522C
27523      CHARACTER*4 ISUBRO
27524      CHARACTER*4 IWRITE
27525      CHARACTER*4 ISUBN1
27526      CHARACTER*4 ISUBN2
27527      CHARACTER*4 ISTEPN
27528      CHARACTER*4 IBFLAG
27529C
27530C---------------------------------------------------------------------
27531C
27532      DIMENSION Y(*)
27533      DIMENSION Z(*)
27534      DIMENSION Z2(*)
27535      DIMENSION XIDTEM(*)
27536      DIMENSION XIDTE2(*)
27537      DIMENSION XIDTE3(*)
27538      DIMENSION XIDTE4(*)
27539      DIMENSION XIDTE5(*)
27540      DIMENSION XIDTE6(*)
27541      DIMENSION XIDTE7(*)
27542      DIMENSION Y2(*)
27543      DIMENSION X2(*)
27544      DIMENSION D2(*)
27545      DIMENSION DSIZE(*)
27546      DIMENSION DCOLOR(*)
27547      DIMENSION DFILL(*)
27548      DIMENSION DSYMB(*)
27549      DIMENSION XPLOT(*)
27550C
27551      DIMENSION TAG1(*)
27552      DIMENSION TAG2(*)
27553      DIMENSION TAG3(*)
27554      DIMENSION TAG4(*)
27555      DIMENSION TAG5(*)
27556      DIMENSION TAG6(*)
27557      DIMENSION TAG7(*)
27558      DIMENSION TEMP(*)
27559      DIMENSION TEMPZ(*)
27560      DIMENSION TEMPZ2(*)
27561      DIMENSION XTEMP1(*)
27562      DIMENSION XTEMP2(*)
27563      DIMENSION XTEMP3(*)
27564      DIMENSION XNTRIA(*)
27565      DIMENSION XACLOW(*)
27566      DIMENSION XACUPP(*)
27567C
27568      INTEGER ITEMP1(*)
27569      INTEGER ITEMP2(*)
27570      INTEGER ITEMP3(*)
27571      INTEGER ITEMP4(*)
27572      INTEGER ITEMP5(*)
27573      INTEGER ITEMP6(*)
27574C
27575      DOUBLE PRECISION DTEMP1(*)
27576      DOUBLE PRECISION DTEMP2(*)
27577      DOUBLE PRECISION DTEMP3(*)
27578C
27579      CHARACTER*4 IOP
27580C
27581      INCLUDE 'DPCOST.INC'
27582      INCLUDE 'DPCOP2.INC'
27583C
27584C-----START POINT-----------------------------------------------------
27585C
27586      ISUBN1='DPCR'
27587      ISUBN2='T8  '
27588C
27589      I2=0
27590      IPTSAV=IRTFPS
27591C
27592      AN=INT(N+0.01)
27593      ANUMS1=INT(NUMSE1+0.01)
27594      ANUMS2=INT(NUMSE2+0.01)
27595      ANUMS3=INT(NUMSE3+0.01)
27596      ANUMS4=INT(NUMSE4+0.01)
27597      ANUMS5=INT(NUMSE5+0.01)
27598      ANUMS6=INT(NUMSE6+0.01)
27599      ANUMS7=INT(NUMSE7+0.01)
27600C
27601C               ***********************************************
27602C               **  STEP 5--                                 **
27603C               **  COMPUTE THE VARIOUS CROSS-TAB STATISTICS **
27604C               ***********************************************
27605C
27606      ISTEPN='5.1'
27607      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CRT8')
27608     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
27609C
27610C     ALLOW THE   SET WRITE DECIMALS COMMAND    TO BE USED TO
27611C     DETERMINE HOW MANY DIGITS PRINTED IN TABLE.
27612C
27613      NUMDIG=-7
27614      IF(IFORSW.EQ.'1')NUMDIG=1
27615      IF(IFORSW.EQ.'2')NUMDIG=2
27616      IF(IFORSW.EQ.'3')NUMDIG=3
27617      IF(IFORSW.EQ.'4')NUMDIG=4
27618      IF(IFORSW.EQ.'5')NUMDIG=5
27619      IF(IFORSW.EQ.'6')NUMDIG=6
27620      IF(IFORSW.EQ.'7')NUMDIG=7
27621      IF(IFORSW.EQ.'8')NUMDIG=8
27622      IF(IFORSW.EQ.'9')NUMDIG=9
27623      IF(IFORSW.EQ.'0')NUMDIG=10
27624      IF(IFORSW.EQ.'-2')NUMDIG=-2
27625      IF(IFORSW.EQ.'-3')NUMDIG=-3
27626      IF(IFORSW.EQ.'-4')NUMDIG=-4
27627      IF(IFORSW.EQ.'-5')NUMDIG=-5
27628      IF(IFORSW.EQ.'-6')NUMDIG=-6
27629      IF(IFORSW.EQ.'-7')NUMDIG=-7
27630      IF(IFORSW.EQ.'-8')NUMDIG=-8
27631      IF(IFORSW.EQ.'-9')NUMDIG=-9
27632C
27633C     NOTE 9/2008: IN FOLLOWING, WE NEED TO DISTINGUISH BETWEEN
27634C                  EMPTY SETS DUE TO NO POINTS FALLING IN THE
27635C                  PARTICULAR CROSS TABULATION (IN WHICH CASE,
27636C                  WE WANT TO SKIP IN THE OUTPUT FILE) AND EMPTY
27637C                  SETS DUE TO ALL POINTS IN THE PARTICULAR
27638C                  CROSS TABULATION BEING MISSING (IN WHICH CASE,
27639C                  WE MAY WANT TO WRITE A 0 OR A MISSING VALUE).
27640C
27641C                  THERE ARE 2 MISSING VALUES:
27642C
27643C                  PSTAMV   - SPECIFIES WHETHER THE INPUT DATA
27644C                             VALUE IS TO BE INCLUDED IN THE
27645C                             COMPUTATION OF THE STATISTIC
27646C
27647C                  PCTAMV    - IF ALL THE DATA IS MISSING, THIS
27648C                              IS THE VALUE TO USE IN WRITING THE
27649C                              CROSS TABULATE OUTPUT.
27650C
27651      IWRITE='OFF'
27652      IBFLAG=ICASCT
27653      IF(IBFLAG.EQ.'BRAT')IBFLAG='BPRO'
27654C
27655      EPS=0.1E-7
27656      J=0
27657      NRESP=NUMV2-6
27658      DO1110ISET1=1,NUMSE1
27659        DO1120ISET2=1,NUMSE2
27660          DO1130ISET3=1,NUMSE3
27661          DO1140ISET4=1,NUMSE4
27662          DO1150ISET5=1,NUMSE5
27663          DO1160ISET6=1,NUMSE6
27664          DO1170ISET7=1,NUMSE7
27665C
27666            K=0
27667            NTEMP2=0
27668            DO1180I=1,N
27669              IF(XIDTEM(ISET1).EQ.TAG1(I) .AND.
27670     1           XIDTE2(ISET2).EQ.TAG2(I) .AND.
27671     1           XIDTE3(ISET3).EQ.TAG3(I) .AND.
27672     1           XIDTE4(ISET4).EQ.TAG4(I) .AND.
27673     1           XIDTE5(ISET5).EQ.TAG5(I) .AND.
27674     1           XIDTE6(ISET6).EQ.TAG6(I) .AND.
27675     1           XIDTE7(ISET7).EQ.TAG7(I))
27676     1           GOTO1181
27677              GOTO1180
27678 1181         CONTINUE
27679C
27680              NTEMP2=NTEMP2+1
27681              IF(IYVAR.EQ.'OFF')THEN
27682                K=K+1
27683                TEMP(K)=0.0
27684              ELSE
27685                IF(ABS(Y(I)-PSTAMV).GT.EPS)THEN
27686                  K=K+1
27687                  TEMP(K)=Y(I)
27688                  IF(IXVAR.EQ.'ON')TEMPZ(K)=Z(I)
27689                  IF(IX2VAR.EQ.'ON')TEMPZ2(K)=Z2(I)
27690                ENDIF
27691              ENDIF
27692 1180       CONTINUE
27693            NTEMP=K
27694C
27695C           AUGUST 2002.  CALL CMPSTA (EXCEPT FOR CHI-SQUARE CASE)
27696C
27697C           NTEMP2 IS THE NUMBER OF POINTS IN THE SUBSET AND
27698C           NTEMP IS THE NUMBER OF NON-MISSING POINTS IN THE SUBSET.
27699C
27700            IF(NTEMP2.EQ.0)GOTO1170
27701C
27702            IF(NTEMP.EQ.0)THEN
27703              IF(ICTAMV.EQ.'ZERO')THEN
27704                STAT=0.0
27705                IF(IBFLAG.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
27706     1             ICASCT.EQ.'MDCL')THEN
27707                  NTRIAL=0
27708                  ALOWLM=0.0
27709                  AUPPLM=0.0
27710                ENDIF
27711              ELSEIF(ICTAMV.EQ.'MV  ')THEN
27712                STAT=PCTAMV
27713                IF(IBFLAG.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
27714     1             ICASCT.EQ.'MDCL')THEN
27715                  NTRIAL=0
27716                  ALOWLM=PCTAMV
27717                  AUPPLM=PCTAMV
27718                ENDIF
27719              ELSE
27720                GOTO1160
27721              ENDIF
27722            ELSE
27723              CALL CMPSTA(
27724     1              TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,
27725     1              MAXNXT,NTEMP,NTEMP,NTEMP,
27726     1              NRESP,ICASCT,
27727     1              ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
27728     1              DTEMP1,DTEMP2,DTEMP3,
27729CCCCC1              IQUAME,IQUASE,PSTAMV,
27730     1              STAT,
27731     1              ISUBRO,IBUGA3,IERROR)
27732              IF(IERROR.EQ.'YES')GOTO9000
27733              IF(IBFLAG.EQ.'BPRO')THEN
27734                PTEMP=STAT
27735                NTRIAL=NTEMP
27736                IF(ICASCT.EQ.'BRAT')NTRIAL=ITEMP1(1)
27737                IF(STAT.EQ.PSTAMV)THEN
27738                  ALOWLM=PSTAMV
27739                  AUPPLM=PSTAMV
27740                ELSE
27741                  ALPHAT=ALPHA
27742                  CALL DPAGCO(PTEMP,NTRIAL,ALPHAT,IWRITE,
27743     1                        ALOWLM,AUPPLM,IBUGA3,IERROR)
27744                ENDIF
27745              ELSEIF(ICASCT.EQ.'MECL')THEN
27746                XMEAN=STAT
27747                NTRIAL=NTEMP
27748                IF(STAT.EQ.PSTAMV)THEN
27749                  ALOWLM=PSTAMV
27750                  AUPPLM=PSTAMV
27751                ELSE
27752                  CALL SD(TEMP,NTEMP,IWRITE,XSD,IBUGA3,IERROR)
27753                  ALPHAT=ALPHA
27754                  CALL DPMECL(XMEAN,XSD,NTEMP,ALPHAT,IWRITE,
27755     1                        ALOWLM,AUPPLM,IBUGA3,IERROR)
27756                ENDIF
27757              ELSEIF(ICASCT.EQ.'MDCL')THEN
27758                XMED=STAT
27759                NTRIAL=NTEMP
27760                IF(STAT.EQ.PSTAMV)THEN
27761                  ALOWLM=PSTAMV
27762                  AUPPLM=PSTAMV
27763                ELSE
27764                  XQ=0.5
27765                  CALL QUANSE(XQ,TEMP,NTEMP,IWRITE,XTEMP1,MAXNXT,IQUASE,
27766     1                        QUASE,IBUGA3,IERROR)
27767                  ALPHAT=ALPHA
27768                  CALL DPMECL(XMED,QUASE,NTEMP,ALPHAT,IWRITE,
27769     1                        ALOWLM,AUPPLM,IBUGA3,IERROR)
27770                ENDIF
27771              ENDIF
27772            ENDIF
27773C
27774            J=J+1
27775            Y2(J)=STAT
27776            X2(J)=XIDTEM(ISET1)
27777            D2(J)=XIDTE2(ISET2)
27778            DSIZE(J)=XIDTE3(ISET3)
27779            DCOLOR(J)=XIDTE4(ISET4)
27780            DFILL(J)=XIDTE5(ISET5)
27781            DSYMB(J)=XIDTE6(ISET6)
27782            XPLOT(J)=XIDTE7(ISET7)
27783            IF(IBFLAG.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
27784     1         ICASCT.EQ.'MDCL')THEN
27785              XNTRIA(J)=REAL(NTRIAL)
27786              XACLOW(J)=ALOWLM
27787              XACUPP(J)=AUPPLM
27788            ENDIF
27789C
27790 1170     CONTINUE
27791 1160     CONTINUE
27792 1150     CONTINUE
27793 1140     CONTINUE
27794 1130     CONTINUE
27795 1120   CONTINUE
27796 1110 CONTINUE
27797      N2=J
27798C
27799      IF(ICASCT.EQ.'BRAT')THEN
27800        IBFLAG='BRAT'
27801        ICASCT='BPRO'
27802      ENDIF
27803C
27804      IOP='OPEN'
27805      IFLG11=1
27806      IFLG21=0
27807      IFLG31=0
27808      IFLAG4=0
27809      IFLAG5=0
27810      CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLAG4,IFLAG5,
27811     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
27812     1            IBUGA3,ISUBRO,IERROR)
27813      IF(IERROR.EQ.'YES')GOTO9000
27814C
27815      WRITE(IOUNI1,2111)ICTNAM
27816 2111 FORMAT(' GROUP-ID 1   GROUP-ID 2   GROUP-ID 3   GROUP-ID 4',
27817     1       '   GROUP-ID 5   GROUP-ID 6  GROUP-ID 7         ',A40)
27818C
27819      IF(ICASCT.EQ.'BPRO')THEN
27820        DO2170I=1,N2
27821          IF(IBINTA.EQ.'LOWE')THEN
27822            WRITE(IOUNI1,2171)X2(I),D2(I),DSIZE(I),DCOLOR(I),DFILL(I),
27823     1                        DSYMB(I),XPLOT(I),
27824     1                        Y2(I),XNTRIA(I),XACLOW(I)
27825
27826 2171       FORMAT(10E17.9)
27827          ELSEIF(IBINTA.EQ.'UPPE')THEN
27828            WRITE(IOUNI1,2171)X2(I),D2(I),DSIZE(I),DCOLOR(I),DFILL(I),
27829     1                        DSYMB(I),XPLOT(I),
27830     1                        Y2(I),XNTRIA(I),XACUPP(I)
27831          ELSE
27832            WRITE(IOUNI1,2173)X2(I),D2(I),DSIZE(I),DCOLOR(I),DFILL(I),
27833     1                        DSYMB(I),XPLOT(I),Y2(I),XNTRIA(I),
27834     1                        XACLOW(I),XACUPP(I)
27835 2173       FORMAT(11E17.9)
27836          ENDIF
27837 2170   CONTINUE
27838      ELSEIF(ICASCT.EQ.'MECL' .OR. ICASCT.EQ.'MDCL')THEN
27839        DO2175I=1,N2
27840          WRITE(IOUNI1,2173)X2(I),D2(I),DSIZE(I),DCOLOR(I),DFILL(I),
27841     1                      DSYMB(I),XPLOT(I),
27842     1                      Y2(I),XNTRIA(I),XACLOW(I),XACUPP(I)
27843 2175   CONTINUE
27844      ELSE
27845        DO2160I=1,N2
27846          WRITE(IOUNI1,2161)X2(I),D2(I),DSIZE(I),DCOLOR(I),DFILL(I),
27847     1                      DSYMB(I),XPLOT(I),Y2(I)
27848 2161     FORMAT(8E17.9)
27849 2160   CONTINUE
27850      ENDIF
27851C
27852      IOP='CLOS'
27853      CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLAG4,IFLAG5,
27854     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
27855     1            IBUGA3,ISUBRO,IERROR)
27856      IF(IERROR.EQ.'YES')GOTO9000
27857C
27858C               *****************************
27859C               **   STEP 6--              **
27860C               **   WRITE OUT THE TABLE   **
27861C               *****************************
27862C
27863      ISTEPN='6'
27864      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CRT8')
27865     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
27866C
27867      WRITE(ICOUT,999)
27868  999 FORMAT(1X)
27869      CALL DPWRST('XXX','BUG ')
27870C
27871      IF(IPRINT.EQ.'OFF')GOTO8000
27872C
27873      ITITLE(1:15)='Cross Tabulate '
27874      IF(ICASCT.EQ.'BPRO')THEN
27875        NCTITL=37
27876        ITITLE(16:NCTITL)='Binomial Probabilities'
27877      ELSEIF(ICASCT.EQ.'MECL')THEN
27878        NCTITL=37
27879        ITITLE(16:NCTITL)='Mean Confidence Limits'
27880      ELSEIF(ICASCT.EQ.'MDCL')THEN
27881        NCTITL=39
27882        ITITLE(16:NCTITL)='Median Confidence Limits'
27883      ELSE
27884        ITITLE(16:55)=ICTNAM(1:40)
27885        NCTITL=55
27886        DO4010I=55,1,-1
27887          IF(ITITLE(I:I).NE.' ')THEN
27888            NCTITL=I
27889            GOTO4019
27890          ENDIF
27891 4010   CONTINUE
27892 4019   CONTINUE
27893      ENDIF
27894C
27895      IF(IYVAR.EQ.'ON')THEN
27896        ITITL9(1:21)='(Response Variables: '
27897        NTEMP=21
27898        ITITL9(22:30)=IYNAM(1:8)
27899        NTEMP=30
27900        IF(IXVAR.EQ.'ON')THEN
27901          ITITL9(30:30)=' '
27902          ITITL9(31:38)=IXNAM(1:8)
27903          NTEMP=38
27904        ENDIF
27905        IF(IX2VAR.EQ.'ON')THEN
27906          ITITL9(39:39)=' '
27907          ITITL9(40:47)=IXNAM2(1:8)
27908          NTEMP=47
27909        ENDIF
27910        NTEMP=NTEMP+1
27911        ITITL9(NTEMP:NTEMP)=')'
27912        NCTIT9=NTEMP
27913      ELSE
27914        ITITL9=' '
27915        NCTIT9=0
27916      ENDIF
27917C
27918      ITITL2(1,1)(1:8)=IX1NAM
27919      NCTIT2(1,1)=8
27920      ITITL2(1,2)(1:8)=IX2NAM
27921      NCTIT2(1,2)=8
27922      ITITL2(1,3)(1:8)=IX3NAM
27923      NCTIT2(1,3)=8
27924      ITITL2(1,4)(1:8)=IX4NAM
27925      NCTIT2(1,4)=8
27926      ITITL2(1,5)(1:8)=IX5NAM
27927      NCTIT2(1,5)=8
27928      ITITL2(1,6)(1:8)=IX6NAM
27929      NCTIT2(1,6)=8
27930      ITITL2(1,7)(1:8)=IX7NAM
27931      NCTIT2(1,7)=8
27932      ITITL2(1,8)='   |   '
27933      IF(ICAPTY.EQ.'LATE')THEN
27934        ITITL2(1,8)='  $|$  '
27935      ENDIF
27936      NCTIT2(1,8)=7
27937C
27938      NUMLIN=1
27939      IF(ICASCT.EQ.'BPRO')THEN
27940        NUMCOL=12
27941        IF(IBINTA.EQ.'LOWE' .OR. IBINTA.EQ.'UPPE')NUMCOL=11
27942        ITITL2(1,9)='P'
27943        NCTIT2(1,9)=1
27944        ITITL2(1,10)='N'
27945        NCTIT2(1,10)=1
27946        IF(IBINTA.EQ.'LOWE')THEN
27947          ITITL2(1,11)(1:40)='Lower AC'
27948          NCTIT2(1,11)=8
27949        ELSEIF(IBINTA.EQ.'UPPE')THEN
27950          ITITL2(1,11)(1:40)='Upper AC'
27951          NCTIT2(1,11)=8
27952        ELSE
27953          ITITL2(1,11)(1:40)='Lower AC'
27954          NCTIT2(1,11)=8
27955          ITITL2(1,12)(1:40)='Upper AC'
27956          NCTIT2(1,12)=8
27957        ENDIF
27958      ELSEIF(ICASCT.EQ.'MECL' .OR. ICASCT.EQ.'MDCL')THEN
27959        NUMCOL=12
27960        IF(ICASCT.EQ.'MECL')THEN
27961          ITITL2(1,9)='Mean'
27962          NCTIT2(1,9)=4
27963        ELSE
27964          ITITL2(1,9)='Median'
27965          NCTIT2(1,9)=6
27966        ENDIF
27967        ITITL2(1,10)='N'
27968        NCTIT2(1,10)=1
27969        ITITL2(1,11)='Lower Limit'
27970        ITITL2(1,11)='Upper Limit'
27971        NCTIT2(1,12)=11
27972        NCTIT2(1,12)=11
27973      ELSE
27974        NUMCOL=9
27975        ITITL2(1,9)(1:15)=ICTNAM(1:15)
27976        NTEMP=15
27977        DO4070I=15,1,-1
27978          IF(ITITL2(1,9)(I:I).NE.' ')THEN
27979            NTEMP=I
27980            GOTO4079
27981          ENDIF
27982 4070   CONTINUE
27983 4079   CONTINUE
27984        NCTIT2(1,9)=NTEMP
27985      ENDIF
27986C
27987      NMAX=0
27988      DO4210I=1,NUMCOL
27989        VALIGN(I)='b'
27990        ALIGN(I)='r'
27991        NTOT(I)=15
27992        IF(NCTIT2(1,I).GT.NTOT(I))NTOT(I)=NCTIT2(1,I)
27993        IDIGIT(I)=NUMDIG
27994        ITYPCO(I)='NUME'
27995        IF(I.EQ.10)THEN
27996          NTOT(I)=8
27997          IDIGIT(I)=0
27998        ELSEIF(I.EQ.8)THEN
27999          ITYPCO(I)='ALPH'
28000          NTOT(I)=7
28001          IDIGIT(I)=-1
28002CCCCC   ELSEIF(I.EQ.6)THEN
28003CCCCC     IF(ICASCT.NE.'BPRO' .AND. ICASCT.NE.'MECL' .AND.
28004CCCCC1       ICASCT.NE.'MDCL')THEN
28005CCCCC        ALIGN(I)='l'
28006CCCCC     ENDIF
28007        ENDIF
28008        NMAX=NMAX+NTOT(I)
28009 4210 CONTINUE
28010C
28011      IWHTML(1)=100
28012      IWHTML(2)=100
28013      IWHTML(3)=100
28014      IWHTML(4)=100
28015      IWHTML(5)=100
28016      IWHTML(6)=100
28017      IWHTML(7)=100
28018      IWHTML(8)=25
28019      IWHTML(9)=100
28020      IWHTML(10)=75
28021      IWHTML(11)=100
28022      IWHTML(12)=100
28023      IJUNK=1300
28024      IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
28025     1   ICASCT.EQ.'MDCL')THEN
28026        IJUNK=900
28027        IPTSAV=IRTFPS
28028        IRTFPS=14
28029        CALL DPCONA(92,IBASLC)
28030        WRITE(ICOUT,7003)IBASLC,IRTFPS
28031 7003   FORMAT(A1,'fs',I2)
28032        CALL DPWRST('XXX','WRIT')
28033      ENDIF
28034      IWRTF(1)=IJUNK
28035      IWRTF(2)=IWRTF(1)+IJUNK
28036      IWRTF(3)=IWRTF(2)+IJUNK
28037      IWRTF(4)=IWRTF(3)+IJUNK
28038      IWRTF(5)=IWRTF(4)+IJUNK
28039      IWRTF(6)=IWRTF(5)+IJUNK
28040      IWRTF(7)=IWRTF(6)+IJUNK
28041      IWRTF(8)=IWRTF(7)+200
28042      IWRTF(9)=IWRTF(8)+IJUNK
28043      IWRTF(10)=IWRTF(9)+800
28044      IWRTF(11)=IWRTF(10)+IJUNK
28045      IWRTF(12)=IWRTF(11)+IJUNK
28046      IFRST=.TRUE.
28047      ILAST=.TRUE.
28048      IFLAGS=.TRUE.
28049      IFLAGE=.FALSE.
28050      ICALL=0
28051C
28052      ICNT=0
28053      DO4310I=1,N2
28054        IF(ICNT.GE.30)THEN
28055          IF(I.EQ.N2)IFLAGE=.TRUE.
28056          CALL DPDTA5(ITITLE,NCTITL,
28057     1                ITITL9,NCTIT9,ITITL2,NCTIT2,
28058     1                MAXLIN,NUMLIN,NUMCLI,NUMCOL,
28059     1                IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
28060     1                IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
28061     1                ICAPSW,ICAPTY,IFRST,ILAST,
28062     1                IFLAGS,IFLAGE,
28063     1                ISUBRO,IBUGA3,IERROR)
28064          IFRST=.FALSE.
28065          IFLAGS=.FALSE.
28066          ICALL=1
28067          ICNT=0
28068        ENDIF
28069        ICNT=ICNT+1
28070        NCTEXT(ICNT)=0
28071        AMAT(ICNT,1)=X2(I)
28072        AMAT(ICNT,2)=D2(I)
28073        AMAT(ICNT,3)=DSIZE(I)
28074        AMAT(ICNT,4)=DCOLOR(I)
28075        AMAT(ICNT,5)=DFILL(I)
28076        AMAT(ICNT,6)=DSYMB(I)
28077        AMAT(ICNT,7)=XPLOT(I)
28078        AMAT(ICNT,8)=0.0
28079        AMAT(ICNT,9)=Y2(I)
28080        IF(ICASCT.EQ.'BPRO' .AND. IBINTA.EQ.'LOWE')THEN
28081          AMAT(ICNT,10)=XNTRIA(I)
28082          AMAT(ICNT,11)=XACLOW(I)
28083        ELSEIF(ICASCT.EQ.'BPRO' .AND. IBINTA.EQ.'UPPE')THEN
28084          AMAT(ICNT,10)=XNTRIA(I)
28085          AMAT(ICNT,11)=XACUPP(I)
28086        ELSEIF(ICASCT.EQ.'BPRO')THEN
28087          AMAT(ICNT,10)=XNTRIA(I)
28088          AMAT(ICNT,11)=XACLOW(I)
28089          AMAT(ICNT,12)=XACUPP(I)
28090        ELSEIF(ICASCT.EQ.'MECL' .OR. ICASCT.EQ.'MDCL')THEN
28091          AMAT(ICNT,10)=XNTRIA(I)
28092          AMAT(ICNT,11)=XACLOW(I)
28093          AMAT(ICNT,12)=XACUPP(I)
28094        ENDIF
28095        DO4320J=1,NUMCOL
28096          IF(J.EQ.8)THEN
28097            NCVALU(ICNT,J)=7
28098            IVALUE(ICNT,J)='   |   '
28099            IF(ICAPTY.EQ.'LATE')THEN
28100              IVALUE(ICNT,J)='  $|$  '
28101            ENDIF
28102          ELSE
28103            NCVALU(ICNT,J)=0
28104            IVALUE(ICNT,J)=' '
28105          ENDIF
28106 4320   CONTINUE
28107 4310 CONTINUE
28108C
28109      IF(ICNT.GE.1)THEN
28110        IFLAGE=.TRUE.
28111        ILAST=.TRUE.
28112        CALL DPDTA5(ITITLE,NCTITL,
28113     1              ITITL9,NCTIT9,ITITL2,NCTIT2,
28114     1              MAXLIN,NUMLIN,NUMCLI,NUMCOL,
28115     1              IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
28116     1              IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
28117     1              ICAPSW,ICAPTY,IFRST,ILAST,
28118     1              IFLAGS,IFLAGE,
28119     1              ISUBRO,IBUGA3,IERROR)
28120      ENDIF
28121C
28122      IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
28123     1   ICASCT.EQ.'MDCL')THEN
28124        IRTFPS=IPTSAV
28125        WRITE(ICOUT,7003)IBASLC,IRTFPS
28126        CALL DPWRST('XXX','WRIT')
28127      ENDIF
28128C
28129 8000 CONTINUE
28130      IF(IFEEDB.EQ.'ON')THEN
28131        WRITE(ICOUT,9212)
28132 9212   FORMAT(6X,'GROUP-IDs AND STATISTIC WRITTEN TO FILE ',
28133     1         'DPST1F.DAT')
28134        CALL DPWRST('XXX','BUG ')
28135      ENDIF
28136C
28137C               ******************
28138C               **   STEP 90--  **
28139C               **   EXIT       **
28140C               ******************
28141C
28142 9000 CONTINUE
28143C
28144      IF(IBFLAG.EQ.'BRAT')THEN
28145        ICASCT='BRAT'
28146      ENDIF
28147C
28148      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CRT8')THEN
28149        WRITE(ICOUT,999)
28150        CALL DPWRST('XXX','BUG ')
28151        WRITE(ICOUT,9011)
28152 9011   FORMAT('***** AT THE END       OF DPCRT8--')
28153        CALL DPWRST('XXX','BUG ')
28154        WRITE(ICOUT,9012)ICASCT,N,N2,IERROR
28155 9012   FORMAT('ICASCT,N,N2,IERROR = ',A4,2I8,2X,A4)
28156        CALL DPWRST('XXX','BUG ')
28157        WRITE(ICOUT,9013)NUMV2
28158 9013   FORMAT('NUMV2 = ',I8)
28159        CALL DPWRST('XXX','BUG ')
28160        WRITE(ICOUT,9015)NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,
28161     1                   NUMSE6,NUSE7
28162 9015   FORMAT('NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,NUMSE6,NUMSE7 = ',
28163     1         7I8)
28164        CALL DPWRST('XXX','BUG ')
28165        WRITE(ICOUT,9016)ANUMS1,ANUMS2,ANUMS3,ANUMS4,ANUMSE5,
28166     1                   ANUMSE6,ANUMSE7
28167 9016   FORMAT('ANUMS1,ANUMS2,ANUMS3,ANUMS4,ANUMSE5,ANUMSE6,ANUMSE7 = ',
28168     1         7G15.7)
28169        CALL DPWRST('XXX','BUG ')
28170        DO9020I=1,N2
28171          WRITE(ICOUT,9021)I,Y2(I),X2(I),DSIZE(I),D2(I)
28172 9021     FORMAT('I,Y2(I),X2(I),DSIZE(I),D2(I) = ',I8,4G15.7)
28173          CALL DPWRST('XXX','BUG ')
28174 9020   CONTINUE
28175      ENDIF
28176C
28177      RETURN
28178      END
28179      SUBROUTINE DPCRT9(Y,Z,Z2,TAG1,TAG2,TAG3,TAG4,TAG5,TAG6,
28180     1                  TAG7,TAG8,N,
28181     1                  NUMV2,ICASCT,ICTNAM,
28182     1                  XIDTEM,XIDTE2,XIDTE3,XIDTE4,
28183     1                  XIDTE5,XIDTE6,XIDTE7,XIDTE8,
28184     1                  NUMSE1,NUMSE2,NUMSE3,NUMSE4,
28185     1                  NUMSE5,NUMSE6,NUMSE7,NUMSE8,
28186     1                  TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,
28187     1                  XNTRIA,XACLOW,XACUPP,
28188     1                  ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
28189     1                  DTEMP1,DTEMP2,DTEMP3,
28190     1                  ISEED,ALPHA,
28191     1                  IXVAR,IX2VAR,IYVAR,
28192     1                  IYNAM,IXNAM,IXNAM2,
28193     1                  IX1NAM,IX2NAM,IX3NAM,IX4NAM,IX5NAM,IX6NAM,
28194     1                  IX7NAM,IX8NAM,
28195     1                  ICAPSW,ICAPTY,IFORSW,
28196     1                  MAXNXT,
28197     1                  Y2,X2,D2,DSIZE,DCOLOR,DFILL,DSYMB,
28198     1                  XPLOT,YPLOT,N2,
28199     1                  ISUBRO,IBUGA3,IERROR)
28200C
28201C     PURPOSE--GENERATE AN EIGHT-WAY CROSS-TABULATION AND
28202C              OPTIONALLY PRINT THE RESULTS TO AN ASCII,
28203C              HTML, LATEX, OR RTF TABLE.
28204C     WRITTEN BY--ALAN HECKERT
28205C                 STATISTICAL ENGINEERING DIVISION
28206C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
28207C                 GAITHERSBURG, MD 20899-8980
28208C                 PHONE--301-975-2899
28209C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
28210C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
28211C     REFERENCE--ASTM MANUAL STP-15D, PAGES 78-84, 100-105
28212C     LANGUAGE--ANSI FORTRAN (1977)
28213C     VERSION NUMBER--2014/5
28214C     ORIGINAL VERSION--MAY       2014.
28215C
28216C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
28217C
28218      CHARACTER*4 ICASCT
28219      CHARACTER*40 ICTNAM
28220      CHARACTER*4 IXVAR
28221      CHARACTER*4 IX2VAR
28222      CHARACTER*4 IYVAR
28223      CHARACTER*4 ICAPSW
28224      CHARACTER*4 ICAPTY
28225      CHARACTER*4 IFORSW
28226      CHARACTER*4 IBUGA3
28227      CHARACTER*4 IERROR
28228C
28229      PARAMETER(NUMCLI=13)
28230      PARAMETER(MAXLIN=2)
28231      PARAMETER (MAXROW=50)
28232      CHARACTER*60 ITITLE
28233      CHARACTER*60 ITITL9
28234      CHARACTER*4  ALIGN(NUMCLI)
28235      CHARACTER*4  VALIGN(NUMCLI)
28236      INTEGER      NCTEXT(MAXROW)
28237      INTEGER      IDIGIT(MAXROW)
28238      INTEGER      NTOT(MAXROW)
28239      CHARACTER*60 ITITL2(MAXLIN,NUMCLI)
28240      CHARACTER*15 IVALUE(MAXROW,NUMCLI)
28241      CHARACTER*4  ITYPCO(NUMCLI)
28242      INTEGER      NCTIT2(MAXLIN,NUMCLI)
28243      INTEGER      NCVALU(MAXROW,NUMCLI)
28244      INTEGER      IWHTML(NUMCLI)
28245      INTEGER      IWRTF(NUMCLI)
28246      REAL         AMAT(MAXROW,NUMCLI)
28247      LOGICAL IFRST
28248      LOGICAL ILAST
28249      LOGICAL IFLAGS
28250      LOGICAL IFLAGE
28251      CHARACTER*1 IBASLC
28252C
28253      CHARACTER*8 IYNAM
28254      CHARACTER*8 IXNAM
28255      CHARACTER*8 IXNAM2
28256      CHARACTER*8 IX1NAM
28257      CHARACTER*8 IX2NAM
28258      CHARACTER*8 IX3NAM
28259      CHARACTER*8 IX4NAM
28260      CHARACTER*8 IX5NAM
28261      CHARACTER*8 IX6NAM
28262      CHARACTER*8 IX7NAM
28263      CHARACTER*8 IX8NAM
28264C
28265      CHARACTER*4 ISUBRO
28266      CHARACTER*4 IWRITE
28267      CHARACTER*4 ISUBN1
28268      CHARACTER*4 ISUBN2
28269      CHARACTER*4 ISTEPN
28270      CHARACTER*4 IBFLAG
28271C
28272C---------------------------------------------------------------------
28273C
28274      DIMENSION Y(*)
28275      DIMENSION Z(*)
28276      DIMENSION Z2(*)
28277      DIMENSION XIDTEM(*)
28278      DIMENSION XIDTE2(*)
28279      DIMENSION XIDTE3(*)
28280      DIMENSION XIDTE4(*)
28281      DIMENSION XIDTE5(*)
28282      DIMENSION XIDTE6(*)
28283      DIMENSION XIDTE7(*)
28284      DIMENSION XIDTE8(*)
28285      DIMENSION Y2(*)
28286      DIMENSION X2(*)
28287      DIMENSION D2(*)
28288      DIMENSION DSIZE(*)
28289      DIMENSION DCOLOR(*)
28290      DIMENSION DFILL(*)
28291      DIMENSION DSYMB(*)
28292      DIMENSION XPLOT(*)
28293      DIMENSION YPLOT(*)
28294C
28295      DIMENSION TAG1(*)
28296      DIMENSION TAG2(*)
28297      DIMENSION TAG3(*)
28298      DIMENSION TAG4(*)
28299      DIMENSION TAG5(*)
28300      DIMENSION TAG6(*)
28301      DIMENSION TAG7(*)
28302      DIMENSION TAG8(*)
28303      DIMENSION TEMP(*)
28304      DIMENSION TEMPZ(*)
28305      DIMENSION TEMPZ2(*)
28306      DIMENSION XTEMP1(*)
28307      DIMENSION XTEMP2(*)
28308      DIMENSION XTEMP3(*)
28309      DIMENSION XNTRIA(*)
28310      DIMENSION XACLOW(*)
28311      DIMENSION XACUPP(*)
28312C
28313      INTEGER ITEMP1(*)
28314      INTEGER ITEMP2(*)
28315      INTEGER ITEMP3(*)
28316      INTEGER ITEMP4(*)
28317      INTEGER ITEMP5(*)
28318      INTEGER ITEMP6(*)
28319C
28320      DOUBLE PRECISION DTEMP1(*)
28321      DOUBLE PRECISION DTEMP2(*)
28322      DOUBLE PRECISION DTEMP3(*)
28323C
28324      CHARACTER*4 IOP
28325C
28326C-----COMMON----------------------------------------------------------
28327C
28328      INCLUDE 'DPCOST.INC'
28329      INCLUDE 'DPCOP2.INC'
28330C
28331C-----START POINT-----------------------------------------------------
28332C
28333      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CRT9')THEN
28334        WRITE(ICOUT,51)
28335   51   FORMAT('AT THE BEGINNING OF DPCRT9')
28336        CALL DPWRST('XXX','BUG ')
28337        WRITE(ICOUT,55)NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,
28338     1                   NUMSE6,NUSE7,NUMSE8
28339   55   FORMAT('NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,NUMSE6,',
28340     1         'NUMSE7,NUMSE8 = ',8I8)
28341        CALL DPWRST('XXX','BUG ')
28342      ENDIF
28343C
28344      ISUBN1='DPCR'
28345      ISUBN2='T9  '
28346C
28347      I2=0
28348      IPTSAV=IRTFPS
28349C
28350      AN=INT(N+0.01)
28351      ANUMS1=INT(NUMSE1+0.01)
28352      ANUMS2=INT(NUMSE2+0.01)
28353      ANUMS3=INT(NUMSE3+0.01)
28354      ANUMS4=INT(NUMSE4+0.01)
28355      ANUMS5=INT(NUMSE5+0.01)
28356      ANUMS6=INT(NUMSE6+0.01)
28357      ANUMS7=INT(NUMSE7+0.01)
28358      ANUMS8=INT(NUMSE8+0.01)
28359C
28360C               ***********************************************
28361C               **  STEP 5--                                 **
28362C               **  COMPUTE THE VARIOUS CROSS-TAB STATISTICS **
28363C               ***********************************************
28364C
28365      ISTEPN='5.1'
28366      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CRT9')
28367     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28368C
28369C     ALLOW THE   SET WRITE DECIMALS COMMAND    TO BE USED TO
28370C     DETERMINE HOW MANY DIGITS PRINTED IN TABLE.
28371C
28372      NUMDIG=-7
28373      IF(IFORSW.EQ.'1')NUMDIG=1
28374      IF(IFORSW.EQ.'2')NUMDIG=2
28375      IF(IFORSW.EQ.'3')NUMDIG=3
28376      IF(IFORSW.EQ.'4')NUMDIG=4
28377      IF(IFORSW.EQ.'5')NUMDIG=5
28378      IF(IFORSW.EQ.'6')NUMDIG=6
28379      IF(IFORSW.EQ.'7')NUMDIG=7
28380      IF(IFORSW.EQ.'8')NUMDIG=8
28381      IF(IFORSW.EQ.'9')NUMDIG=9
28382      IF(IFORSW.EQ.'0')NUMDIG=10
28383      IF(IFORSW.EQ.'-2')NUMDIG=-2
28384      IF(IFORSW.EQ.'-3')NUMDIG=-3
28385      IF(IFORSW.EQ.'-4')NUMDIG=-4
28386      IF(IFORSW.EQ.'-5')NUMDIG=-5
28387      IF(IFORSW.EQ.'-6')NUMDIG=-6
28388      IF(IFORSW.EQ.'-7')NUMDIG=-7
28389      IF(IFORSW.EQ.'-8')NUMDIG=-8
28390      IF(IFORSW.EQ.'-9')NUMDIG=-9
28391C
28392C     NOTE 9/2008: IN FOLLOWING, WE NEED TO DISTINGUISH BETWEEN
28393C                  EMPTY SETS DUE TO NO POINTS FALLING IN THE
28394C                  PARTICULAR CROSS TABULATION (IN WHICH CASE,
28395C                  WE WANT TO SKIP IN THE OUTPUT FILE) AND EMPTY
28396C                  SETS DUE TO ALL POINTS IN THE PARTICULAR
28397C                  CROSS TABULATION BEING MISSING (IN WHICH CASE,
28398C                  WE MAY WANT TO WRITE A 0 OR A MISSING VALUE).
28399C
28400C                  THERE ARE 2 MISSING VALUES:
28401C
28402C                  PSTAMV   - SPECIFIES WHETHER THE INPUT DATA
28403C                             VALUE IS TO BE INCLUDED IN THE
28404C                             COMPUTATION OF THE STATISTIC
28405C
28406C                  PCTAMV    - IF ALL THE DATA IS MISSING, THIS
28407C                              IS THE VALUE TO USE IN WRITING THE
28408C                              CROSS TABULATE OUTPUT.
28409C
28410      IWRITE='OFF'
28411      IBFLAG=ICASCT
28412      IF(IBFLAG.EQ.'BRAT')IBFLAG='BPRO'
28413C
28414      EPS=0.1E-7
28415      J=0
28416      NRESP=NUMV2-6
28417      DO1110ISET1=1,NUMSE1
28418        DO1120ISET2=1,NUMSE2
28419          DO1130ISET3=1,NUMSE3
28420          DO1140ISET4=1,NUMSE4
28421          DO1150ISET5=1,NUMSE5
28422          DO1160ISET6=1,NUMSE6
28423          DO1170ISET7=1,NUMSE7
28424          DO1180ISET8=1,NUMSE8
28425C
28426            K=0
28427            NTEMP2=0
28428            DO1190I=1,N
28429              IF(XIDTEM(ISET1).EQ.TAG1(I) .AND.
28430     1           XIDTE2(ISET2).EQ.TAG2(I) .AND.
28431     1           XIDTE3(ISET3).EQ.TAG3(I) .AND.
28432     1           XIDTE4(ISET4).EQ.TAG4(I) .AND.
28433     1           XIDTE5(ISET5).EQ.TAG5(I) .AND.
28434     1           XIDTE6(ISET6).EQ.TAG6(I) .AND.
28435     1           XIDTE7(ISET7).EQ.TAG7(I) .AND.
28436     1           XIDTE8(ISET8).EQ.TAG8(I))
28437     1           GOTO1191
28438              GOTO1190
28439 1191         CONTINUE
28440C
28441              NTEMP2=NTEMP2+1
28442              IF(IYVAR.EQ.'OFF')THEN
28443                K=K+1
28444                TEMP(K)=0.0
28445              ELSE
28446                IF(ABS(Y(I)-PSTAMV).GT.EPS)THEN
28447                  K=K+1
28448                  TEMP(K)=Y(I)
28449                  IF(IXVAR.EQ.'ON')TEMPZ(K)=Z(I)
28450                  IF(IX2VAR.EQ.'ON')TEMPZ2(K)=Z2(I)
28451                ENDIF
28452              ENDIF
28453 1190       CONTINUE
28454            NTEMP=K
28455C
28456C           AUGUST 2002.  CALL CMPSTA (EXCEPT FOR CHI-SQUARE CASE)
28457C
28458C           NTEMP2 IS THE NUMBER OF POINTS IN THE SUBSET AND
28459C           NTEMP IS THE NUMBER OF NON-MISSING POINTS IN THE SUBSET.
28460C
28461            IF(NTEMP2.EQ.0)GOTO1180
28462C
28463            IF(NTEMP.EQ.0)THEN
28464              IF(ICTAMV.EQ.'ZERO')THEN
28465                STAT=0.0
28466                IF(IBFLAG.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
28467     1             ICASCT.EQ.'MDCL')THEN
28468                  NTRIAL=0
28469                  ALOWLM=0.0
28470                  AUPPLM=0.0
28471                ENDIF
28472              ELSEIF(ICTAMV.EQ.'MV  ')THEN
28473                STAT=PCTAMV
28474                IF(IBFLAG.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
28475     1             ICASCT.EQ.'MDCL')THEN
28476                  NTRIAL=0
28477                  ALOWLM=PCTAMV
28478                  AUPPLM=PCTAMV
28479                ENDIF
28480              ELSE
28481                GOTO1180
28482              ENDIF
28483            ELSE
28484              CALL CMPSTA(
28485     1              TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,
28486     1              MAXNXT,NTEMP,NTEMP,NTEMP,
28487     1              NRESP,ICASCT,
28488     1              ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
28489     1              DTEMP1,DTEMP2,DTEMP3,
28490CCCCC1              IQUAME,IQUASE,PSTAMV,
28491     1              STAT,
28492     1              ISUBRO,IBUGA3,IERROR)
28493              IF(IERROR.EQ.'YES')GOTO9000
28494              IF(IBFLAG.EQ.'BPRO')THEN
28495                PTEMP=STAT
28496                NTRIAL=NTEMP
28497                IF(ICASCT.EQ.'BRAT')NTRIAL=ITEMP1(1)
28498                IF(STAT.EQ.PSTAMV)THEN
28499                  ALOWLM=PSTAMV
28500                  AUPPLM=PSTAMV
28501                ELSE
28502                  ALPHAT=ALPHA
28503                  CALL DPAGCO(PTEMP,NTRIAL,ALPHAT,IWRITE,
28504     1                        ALOWLM,AUPPLM,IBUGA3,IERROR)
28505                ENDIF
28506              ELSEIF(ICASCT.EQ.'MECL')THEN
28507                XMEAN=STAT
28508                NTRIAL=NTEMP
28509                IF(STAT.EQ.PSTAMV)THEN
28510                  ALOWLM=PSTAMV
28511                  AUPPLM=PSTAMV
28512                ELSE
28513                  CALL SD(TEMP,NTEMP,IWRITE,XSD,IBUGA3,IERROR)
28514                  ALPHAT=ALPHA
28515                  CALL DPMECL(XMEAN,XSD,NTEMP,ALPHAT,IWRITE,
28516     1                        ALOWLM,AUPPLM,IBUGA3,IERROR)
28517                ENDIF
28518              ELSEIF(ICASCT.EQ.'MDCL')THEN
28519                XMED=STAT
28520                NTRIAL=NTEMP
28521                IF(STAT.EQ.PSTAMV)THEN
28522                  ALOWLM=PSTAMV
28523                  AUPPLM=PSTAMV
28524                ELSE
28525                  XQ=0.5
28526                  CALL QUANSE(XQ,TEMP,NTEMP,IWRITE,XTEMP1,MAXNXT,IQUASE,
28527     1                        QUASE,IBUGA3,IERROR)
28528                  ALPHAT=ALPHA
28529                  CALL DPMECL(XMED,QUASE,NTEMP,ALPHAT,IWRITE,
28530     1                        ALOWLM,AUPPLM,IBUGA3,IERROR)
28531                ENDIF
28532              ENDIF
28533            ENDIF
28534C
28535            J=J+1
28536            Y2(J)=STAT
28537            X2(J)=XIDTEM(ISET1)
28538            D2(J)=XIDTE2(ISET2)
28539            DSIZE(J)=XIDTE3(ISET3)
28540            DCOLOR(J)=XIDTE4(ISET4)
28541            DFILL(J)=XIDTE5(ISET5)
28542            DSYMB(J)=XIDTE6(ISET6)
28543            XPLOT(J)=XIDTE7(ISET7)
28544            YPLOT(J)=XIDTE8(ISET8)
28545            IF(IBFLAG.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
28546     1         ICASCT.EQ.'MDCL')THEN
28547              XNTRIA(J)=REAL(NTRIAL)
28548              XACLOW(J)=ALOWLM
28549              XACUPP(J)=AUPPLM
28550            ENDIF
28551C
28552 1180     CONTINUE
28553 1170     CONTINUE
28554 1160     CONTINUE
28555 1150     CONTINUE
28556 1140     CONTINUE
28557 1130     CONTINUE
28558 1120   CONTINUE
28559 1110 CONTINUE
28560      N2=J
28561C
28562      IF(ICASCT.EQ.'BRAT')THEN
28563        IBFLAG='BRAT'
28564        ICASCT='BPRO'
28565      ENDIF
28566C
28567      IOP='OPEN'
28568      IFLG11=1
28569      IFLG21=0
28570      IFLG31=0
28571      IFLAG4=0
28572      IFLAG5=0
28573      CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLAG4,IFLAG5,
28574     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
28575     1            IBUGA3,ISUBRO,IERROR)
28576      IF(IERROR.EQ.'YES')GOTO9000
28577C
28578      WRITE(IOUNI1,2111)ICTNAM
28579 2111 FORMAT(' GROUP-ID 1   GROUP-ID 2   GROUP-ID 3   GROUP-ID 4',
28580     1       '   GROUP-ID 5   GROUP-ID 6  GROUP-ID 7   GROUP-ID 8',
28581     1       '      ',A40)
28582C
28583      IF(ICASCT.EQ.'BPRO')THEN
28584        DO2170I=1,N2
28585          IF(IBINTA.EQ.'LOWE')THEN
28586            WRITE(IOUNI1,2171)X2(I),D2(I),DSIZE(I),DCOLOR(I),DFILL(I),
28587     1                        DSYMB(I),XPLOT(I),YPLOT(I),
28588     1                        Y2(I),XNTRIA(I),XACLOW(I)
28589
28590 2171       FORMAT(11E17.9)
28591          ELSEIF(IBINTA.EQ.'UPPE')THEN
28592            WRITE(IOUNI1,2171)X2(I),D2(I),DSIZE(I),DCOLOR(I),DFILL(I),
28593     1                        DSYMB(I),XPLOT(I),YPLOT(I),
28594     1                        Y2(I),XNTRIA(I),XACUPP(I)
28595          ELSE
28596            WRITE(IOUNI1,2173)X2(I),D2(I),DSIZE(I),DCOLOR(I),DFILL(I),
28597     1                        DSYMB(I),XPLOT(I),YPLOT(I),
28598     1                        Y2(I),XNTRIA(I),XACLOW(I),XACUPP(I)
28599 2173       FORMAT(12E17.9)
28600          ENDIF
28601 2170   CONTINUE
28602      ELSEIF(ICASCT.EQ.'MECL' .OR. ICASCT.EQ.'MDCL')THEN
28603        DO2175I=1,N2
28604          WRITE(IOUNI1,2173)X2(I),D2(I),DSIZE(I),DCOLOR(I),DFILL(I),
28605     1                      DSYMB(I),XPLOT(I),YPLOT(I),
28606     1                      Y2(I),XNTRIA(I),XACLOW(I),XACUPP(I)
28607 2175   CONTINUE
28608      ELSE
28609        DO2160I=1,N2
28610          WRITE(IOUNI1,2161)X2(I),D2(I),DSIZE(I),DCOLOR(I),DFILL(I),
28611     1                      DSYMB(I),XPLOT(I),YPLOT(I),Y2(I)
28612 2161     FORMAT(9E17.9)
28613 2160   CONTINUE
28614      ENDIF
28615C
28616      IOP='CLOS'
28617      CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLAG4,IFLAG5,
28618     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
28619     1            IBUGA3,ISUBRO,IERROR)
28620      IF(IERROR.EQ.'YES')GOTO9000
28621C
28622C               *****************************
28623C               **   STEP 6--              **
28624C               **   WRITE OUT THE TABLE   **
28625C               *****************************
28626C
28627      ISTEPN='6'
28628      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CRT9')
28629     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28630C
28631      WRITE(ICOUT,999)
28632  999 FORMAT(1X)
28633      CALL DPWRST('XXX','BUG ')
28634C
28635      IF(IPRINT.EQ.'OFF')GOTO8000
28636C
28637      ITITLE(1:15)='Cross Tabulate '
28638      IF(ICASCT.EQ.'BPRO')THEN
28639        NCTITL=37
28640        ITITLE(16:NCTITL)='Binomial Probabilities'
28641      ELSEIF(ICASCT.EQ.'MECL')THEN
28642        NCTITL=37
28643        ITITLE(16:NCTITL)='Mean Confidence Limits'
28644      ELSEIF(ICASCT.EQ.'MDCL')THEN
28645        NCTITL=39
28646        ITITLE(16:NCTITL)='Median Confidence Limits'
28647      ELSE
28648        ITITLE(16:55)=ICTNAM(1:40)
28649        NCTITL=55
28650        DO4010I=55,1,-1
28651          IF(ITITLE(I:I).NE.' ')THEN
28652            NCTITL=I
28653            GOTO4019
28654          ENDIF
28655 4010   CONTINUE
28656 4019   CONTINUE
28657      ENDIF
28658C
28659      IF(IYVAR.EQ.'ON')THEN
28660        ITITL9(1:21)='(Response Variables: '
28661        NTEMP=21
28662        ITITL9(22:30)=IYNAM(1:8)
28663        NTEMP=30
28664        IF(IXVAR.EQ.'ON')THEN
28665          ITITL9(30:30)=' '
28666          ITITL9(31:38)=IXNAM(1:8)
28667          NTEMP=38
28668        ENDIF
28669        IF(IX2VAR.EQ.'ON')THEN
28670          ITITL9(39:39)=' '
28671          ITITL9(40:47)=IXNAM2(1:8)
28672          NTEMP=47
28673        ENDIF
28674        NTEMP=NTEMP+1
28675        ITITL9(NTEMP:NTEMP)=')'
28676        NCTIT9=NTEMP
28677      ELSE
28678        ITITL9=' '
28679        NCTIT9=0
28680      ENDIF
28681C
28682      ITITL2(1,1)(1:8)=IX1NAM
28683      NCTIT2(1,1)=8
28684      ITITL2(1,2)(1:8)=IX2NAM
28685      NCTIT2(1,2)=8
28686      ITITL2(1,3)(1:8)=IX3NAM
28687      NCTIT2(1,3)=8
28688      ITITL2(1,4)(1:8)=IX4NAM
28689      NCTIT2(1,4)=8
28690      ITITL2(1,5)(1:8)=IX5NAM
28691      NCTIT2(1,5)=8
28692      ITITL2(1,6)(1:8)=IX6NAM
28693      NCTIT2(1,6)=8
28694      ITITL2(1,7)(1:8)=IX7NAM
28695      NCTIT2(1,7)=8
28696      ITITL2(1,8)(1:8)=IX8NAM
28697      NCTIT2(1,8)=8
28698      ITITL2(1,9)='   |   '
28699      IF(ICAPTY.EQ.'LATE')THEN
28700        ITITL2(1,9)='  $|$  '
28701      ENDIF
28702      NCTIT2(1,9)=7
28703C
28704      NUMLIN=1
28705      IF(ICASCT.EQ.'BPRO')THEN
28706        NUMCOL=13
28707        IF(IBINTA.EQ.'LOWE' .OR. IBINTA.EQ.'UPPE')NUMCOL=12
28708        ITITL2(1,10)='P'
28709        NCTIT2(1,10)=1
28710        ITITL2(1,11)='N'
28711        NCTIT2(1,11)=1
28712        IF(IBINTA.EQ.'LOWE')THEN
28713          ITITL2(1,12)(1:40)='Lower AC'
28714          NCTIT2(1,12)=8
28715        ELSEIF(IBINTA.EQ.'UPPE')THEN
28716          ITITL2(1,12)(1:40)='Upper AC'
28717          NCTIT2(1,12)=8
28718        ELSE
28719          ITITL2(1,12)(1:40)='Lower AC'
28720          NCTIT2(1,12)=8
28721          ITITL2(1,13)(1:40)='Upper AC'
28722          NCTIT2(1,13)=8
28723        ENDIF
28724      ELSEIF(ICASCT.EQ.'MECL' .OR. ICASCT.EQ.'MDCL')THEN
28725        NUMCOL=13
28726        IF(ICASCT.EQ.'MECL')THEN
28727          ITITL2(1,10)='Mean'
28728          NCTIT2(1,10)=4
28729        ELSE
28730          ITITL2(1,10)='Median'
28731          NCTIT2(1,10)=6
28732        ENDIF
28733        ITITL2(1,11)='N'
28734        NCTIT2(1,11)=1
28735        ITITL2(1,12)='Lower Limit'
28736        ITITL2(1,12)='Upper Limit'
28737        NCTIT2(1,13)=11
28738        NCTIT2(1,13)=11
28739      ELSE
28740        NUMCOL=10
28741        ITITL2(1,10)(1:15)=ICTNAM(1:15)
28742        NTEMP=15
28743        DO4070I=15,1,-1
28744          IF(ITITL2(1,9)(I:I).NE.' ')THEN
28745            NTEMP=I
28746            GOTO4079
28747          ENDIF
28748 4070   CONTINUE
28749 4079   CONTINUE
28750        NCTIT2(1,10)=NTEMP
28751      ENDIF
28752C
28753      NMAX=0
28754      DO4210I=1,NUMCOL
28755        VALIGN(I)='b'
28756        ALIGN(I)='r'
28757        NTOT(I)=15
28758        IF(NCTIT2(1,I).GT.NTOT(I))NTOT(I)=NCTIT2(1,I)
28759        IDIGIT(I)=NUMDIG
28760        ITYPCO(I)='NUME'
28761        IF(I.EQ.11)THEN
28762          NTOT(I)=8
28763          IDIGIT(I)=0
28764        ELSEIF(I.EQ.9)THEN
28765          ITYPCO(I)='ALPH'
28766          NTOT(I)=7
28767          IDIGIT(I)=-1
28768CCCCC   ELSEIF(I.EQ.6)THEN
28769CCCCC     IF(ICASCT.NE.'BPRO' .AND. ICASCT.NE.'MECL' .AND.
28770CCCCC1       ICASCT.NE.'MDCL')THEN
28771CCCCC        ALIGN(I)='l'
28772CCCCC     ENDIF
28773        ENDIF
28774        NMAX=NMAX+NTOT(I)
28775 4210 CONTINUE
28776C
28777      IWHTML(1)=100
28778      IWHTML(2)=100
28779      IWHTML(3)=100
28780      IWHTML(4)=100
28781      IWHTML(5)=100
28782      IWHTML(6)=100
28783      IWHTML(7)=100
28784      IWHTML(8)=100
28785      IWHTML(9)=25
28786      IWHTML(10)=100
28787      IWHTML(11)=75
28788      IWHTML(12)=100
28789      IWHTML(13)=100
28790      IJUNK=1300
28791      IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
28792     1   ICASCT.EQ.'MDCL')THEN
28793        IJUNK=900
28794        IPTSAV=IRTFPS
28795        IRTFPS=14
28796        CALL DPCONA(92,IBASLC)
28797        WRITE(ICOUT,7003)IBASLC,IRTFPS
28798 7003   FORMAT(A1,'fs',I2)
28799        CALL DPWRST('XXX','WRIT')
28800      ENDIF
28801      IWRTF(1)=IJUNK
28802      IWRTF(2)=IWRTF(1)+IJUNK
28803      IWRTF(3)=IWRTF(2)+IJUNK
28804      IWRTF(4)=IWRTF(3)+IJUNK
28805      IWRTF(5)=IWRTF(4)+IJUNK
28806      IWRTF(6)=IWRTF(5)+IJUNK
28807      IWRTF(7)=IWRTF(6)+IJUNK
28808      IWRTF(8)=IWRTF(7)+IJUNK
28809      IWRTF(9)=IWRTF(8)+200
28810      IWRTF(10)=IWRTF(9)+IJUNK
28811      IWRTF(11)=IWRTF(10)+800
28812      IWRTF(12)=IWRTF(11)+IJUNK
28813      IWRTF(13)=IWRTF(10)+IJUNK
28814      IFRST=.TRUE.
28815      ILAST=.TRUE.
28816      IFLAGS=.TRUE.
28817      IFLAGE=.FALSE.
28818      ICALL=0
28819C
28820      ICNT=0
28821      DO4310I=1,N2
28822        IF(ICNT.GE.30)THEN
28823          IF(I.EQ.N2)IFLAGE=.TRUE.
28824          CALL DPDTA5(ITITLE,NCTITL,
28825     1                ITITL9,NCTIT9,ITITL2,NCTIT2,
28826     1                MAXLIN,NUMLIN,NUMCLI,NUMCOL,
28827     1                IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
28828     1                IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
28829     1                ICAPSW,ICAPTY,IFRST,ILAST,
28830     1                IFLAGS,IFLAGE,
28831     1                ISUBRO,IBUGA3,IERROR)
28832          IFRST=.FALSE.
28833          IFLAGS=.FALSE.
28834          ICALL=1
28835          ICNT=0
28836        ENDIF
28837        ICNT=ICNT+1
28838        NCTEXT(ICNT)=0
28839        AMAT(ICNT,1)=X2(I)
28840        AMAT(ICNT,2)=D2(I)
28841        AMAT(ICNT,3)=DSIZE(I)
28842        AMAT(ICNT,4)=DCOLOR(I)
28843        AMAT(ICNT,5)=DFILL(I)
28844        AMAT(ICNT,6)=DSYMB(I)
28845        AMAT(ICNT,7)=XPLOT(I)
28846        AMAT(ICNT,8)=YPLOT(I)
28847        AMAT(ICNT,9)=0.0
28848        AMAT(ICNT,10)=Y2(I)
28849        IF(ICASCT.EQ.'BPRO' .AND. IBINTA.EQ.'LOWE')THEN
28850          AMAT(ICNT,11)=XNTRIA(I)
28851          AMAT(ICNT,12)=XACLOW(I)
28852        ELSEIF(ICASCT.EQ.'BPRO' .AND. IBINTA.EQ.'UPPE')THEN
28853          AMAT(ICNT,11)=XNTRIA(I)
28854          AMAT(ICNT,12)=XACUPP(I)
28855        ELSEIF(ICASCT.EQ.'BPRO')THEN
28856          AMAT(ICNT,11)=XNTRIA(I)
28857          AMAT(ICNT,12)=XACLOW(I)
28858          AMAT(ICNT,13)=XACUPP(I)
28859        ELSEIF(ICASCT.EQ.'MECL' .OR. ICASCT.EQ.'MDCL')THEN
28860          AMAT(ICNT,11)=XNTRIA(I)
28861          AMAT(ICNT,12)=XACLOW(I)
28862          AMAT(ICNT,13)=XACUPP(I)
28863        ENDIF
28864        DO4320J=1,NUMCOL
28865          IF(J.EQ.9)THEN
28866            NCVALU(ICNT,J)=7
28867            IVALUE(ICNT,J)='   |   '
28868            IF(ICAPTY.EQ.'LATE')THEN
28869              IVALUE(ICNT,J)='  $|$  '
28870            ENDIF
28871          ELSE
28872            NCVALU(ICNT,J)=0
28873            IVALUE(ICNT,J)=' '
28874          ENDIF
28875 4320   CONTINUE
28876 4310 CONTINUE
28877C
28878      IF(ICNT.GE.1)THEN
28879        IFLAGE=.TRUE.
28880        ILAST=.TRUE.
28881        CALL DPDTA5(ITITLE,NCTITL,
28882     1              ITITL9,NCTIT9,ITITL2,NCTIT2,
28883     1              MAXLIN,NUMLIN,NUMCLI,NUMCOL,
28884     1              IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
28885     1              IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
28886     1              ICAPSW,ICAPTY,IFRST,ILAST,
28887     1              IFLAGS,IFLAGE,
28888     1              ISUBRO,IBUGA3,IERROR)
28889      ENDIF
28890C
28891      IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
28892     1   ICASCT.EQ.'MDCL')THEN
28893        IRTFPS=IPTSAV
28894        WRITE(ICOUT,7003)IBASLC,IRTFPS
28895        CALL DPWRST('XXX','WRIT')
28896      ENDIF
28897C
28898 8000 CONTINUE
28899      IF(IFEEDB.EQ.'ON')THEN
28900        WRITE(ICOUT,9212)
28901 9212   FORMAT(6X,'GROUP-IDs AND STATISTIC WRITTEN TO FILE ',
28902     1         'DPST1F.DAT')
28903        CALL DPWRST('XXX','BUG ')
28904      ENDIF
28905C
28906C               ******************
28907C               **   STEP 90--  **
28908C               **   EXIT       **
28909C               ******************
28910C
28911 9000 CONTINUE
28912C
28913      IF(IBFLAG.EQ.'BRAT')THEN
28914        ICASCT='BRAT'
28915      ENDIF
28916C
28917      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CRT9')THEN
28918        WRITE(ICOUT,999)
28919        CALL DPWRST('XXX','BUG ')
28920        WRITE(ICOUT,9011)
28921 9011   FORMAT('***** AT THE END       OF DPCRT9--')
28922        CALL DPWRST('XXX','BUG ')
28923        WRITE(ICOUT,9012)ICASCT,N,N2,IERROR
28924 9012   FORMAT('ICASCT,N,N2,IERROR = ',A4,2I8,2X,A4)
28925        CALL DPWRST('XXX','BUG ')
28926        WRITE(ICOUT,9013)NUMV2
28927 9013   FORMAT('NUMV2 = ',I8)
28928        CALL DPWRST('XXX','BUG ')
28929        WRITE(ICOUT,9015)NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,
28930     1                   NUMSE6,NUSE7,NUMSE8
28931 9015   FORMAT('NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,NUMSE6,',
28932     1         'NUMSE7,NUMSE8 = ',8I8)
28933        CALL DPWRST('XXX','BUG ')
28934        WRITE(ICOUT,9016)ANUMS1,ANUMS2,ANUMS3,ANUMS4,ANUMSE5,
28935     1                   ANUMSE6,ANUMSE7,ANUMSE8
28936 9016   FORMAT('ANUMS1,ANUMS2,ANUMS3,ANUMS4,ANUMSE5,ANUMSE6,',
28937     1         'ANUMSE7,ANUMSE8 = ',8G15.7)
28938        CALL DPWRST('XXX','BUG ')
28939        DO9020I=1,N2
28940          WRITE(ICOUT,9021)I,Y2(I),X2(I),DSIZE(I),D2(I)
28941 9021     FORMAT('I,Y2(I),X2(I),DSIZE(I),D2(I) = ',I8,4G15.7)
28942          CALL DPWRST('XXX','BUG ')
28943 9020   CONTINUE
28944      ENDIF
28945C
28946      RETURN
28947      END
28948      SUBROUTINE DPCRT0(Y,Z,Z2,TAG1,N,
28949     1                  NUMV2,ICASCT,ICTNAM,
28950     1                  XIDTEM,
28951     1                  NUMSE1,
28952     1                  TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,
28953     1                  XNTRIA,XACLOW,XACUPP,
28954     1                  ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
28955     1                  DTEMP1,DTEMP2,DTEMP3,
28956     1                  ISEED,ALPHA,
28957     1                  IXVAR,IX2VAR,IYVAR,
28958     1                  IYNAM,IXNAM,IXNAM2,IX1NAM,
28959     1                  ICAPSW,ICAPTY,IFORSW,
28960     1                  MAXNXT,
28961     1                  Y2,X2,N2,ISUBRO,IBUGA3,IERROR)
28962C
28963C     PURPOSE--GENERATE A ONE-WAY TABULATION AND
28964C              OPTIONALLY PRINT THE RESULTS TO AN ASCII,
28965C              HTML, LATEX, OR RTF TABLE.
28966C     WRITTEN BY--ALAN HECKERT
28967C                 STATISTICAL ENGINEERING DIVISION
28968C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
28969C                 GAITHERSBURG, MD 20899-8980
28970C                 PHONE--301-975-2899
28971C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
28972C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
28973C     REFERENCE--ASTM MANUAL STP-15D, PAGES 78-84, 100-105
28974C     LANGUAGE--ANSI FORTRAN (1977)
28975C     VERSION NUMBER--2008/6
28976C     ORIGINAL VERSION--JUNE      2008. SPLIT OFF FROM DPTAB2 ROUTINE
28977C     UPDATED         --SEPTEMBER 2008. ACCOMODATE "MISSING" DATA
28978C     UPDATED         --JANUARY   2010. "BINOMIAL RATIO" HANDLED
28979C                                       SAME AS "BINOMIAL PROB"
28980C     UPDATED         --JUNE      2010. CALL LIST TO CMPSTA
28981C     UPDATED         --JUNE      2010. USE DPDTA5 TO PRINT TABLE
28982C
28983C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
28984C
28985      CHARACTER*4 ICASCT
28986      CHARACTER*40 ICTNAM
28987      CHARACTER*4 IXVAR
28988      CHARACTER*4 IX2VAR
28989      CHARACTER*4 IYVAR
28990      CHARACTER*4 ICAPSW
28991      CHARACTER*4 ICAPTY
28992      CHARACTER*4 IFORSW
28993      CHARACTER*4 IBUGA3
28994      CHARACTER*4 IERROR
28995C
28996      PARAMETER(NUMCLI=6)
28997      PARAMETER(MAXLIN=2)
28998      PARAMETER (MAXROW=30)
28999      CHARACTER*60 ITITLE
29000      CHARACTER*60 ITITL9
29001      CHARACTER*4  ALIGN(NUMCLI)
29002      CHARACTER*4  VALIGN(NUMCLI)
29003      INTEGER      NCTEXT(MAXROW)
29004      INTEGER      IDIGIT(MAXROW)
29005      INTEGER      NTOT(MAXROW)
29006      CHARACTER*60 ITITL2(MAXLIN,NUMCLI)
29007      CHARACTER*15 IVALUE(MAXROW,NUMCLI)
29008      CHARACTER*4  ITYPCO(NUMCLI)
29009      INTEGER      NCTIT2(MAXLIN,NUMCLI)
29010      INTEGER      NCVALU(MAXROW,NUMCLI)
29011      INTEGER      IWHTML(NUMCLI)
29012      INTEGER      IWRTF(NUMCLI)
29013      REAL         AMAT(MAXROW,NUMCLI)
29014      LOGICAL IFRST
29015      LOGICAL ILAST
29016      LOGICAL IFLAGS
29017      LOGICAL IFLAGE
29018C
29019      CHARACTER*8 IYNAM
29020      CHARACTER*8 IXNAM
29021      CHARACTER*8 IXNAM2
29022      CHARACTER*8 IX1NAM
29023C
29024      CHARACTER*4 ISUBRO
29025      CHARACTER*4 IWRITE
29026      CHARACTER*4 ISUBN1
29027      CHARACTER*4 ISUBN2
29028      CHARACTER*4 ISTEPN
29029      CHARACTER*4 IBFLAG
29030C
29031C---------------------------------------------------------------------
29032C
29033      DIMENSION Y(*)
29034      DIMENSION Z(*)
29035      DIMENSION Z2(*)
29036      DIMENSION XIDTEM(*)
29037      DIMENSION Y2(*)
29038      DIMENSION X2(*)
29039C
29040      DIMENSION TAG1(*)
29041      DIMENSION TEMP(*)
29042      DIMENSION TEMPZ(*)
29043      DIMENSION TEMPZ2(*)
29044      DIMENSION XTEMP1(*)
29045      DIMENSION XTEMP2(*)
29046      DIMENSION XTEMP3(*)
29047      DIMENSION XNTRIA(*)
29048      DIMENSION XACLOW(*)
29049      DIMENSION XACUPP(*)
29050C
29051      INTEGER ITEMP1(*)
29052      INTEGER ITEMP2(*)
29053      INTEGER ITEMP3(*)
29054      INTEGER ITEMP4(*)
29055      INTEGER ITEMP5(*)
29056      INTEGER ITEMP6(*)
29057C
29058      DOUBLE PRECISION DTEMP1(*)
29059      DOUBLE PRECISION DTEMP2(*)
29060      DOUBLE PRECISION DTEMP3(*)
29061C
29062      CHARACTER*4 IOP
29063C
29064C-----COMMON----------------------------------------------------------
29065C
29066      INCLUDE 'DPCOST.INC'
29067      INCLUDE 'DPCOP2.INC'
29068C
29069C-----START POINT-----------------------------------------------------
29070C
29071      ISUBN1='DPCR'
29072      ISUBN2='T0  '
29073C
29074      IBFLAG=ICASCT
29075      IF(IBFLAG.EQ.'BRAT')IBFLAG='BPRO'
29076      I2=0
29077      AN=INT(N+0.01)
29078      ANUMS1=INT(NUMSE1+0.01)
29079C
29080      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CRT0')THEN
29081        WRITE(ICOUT,999)
29082        CALL DPWRST('XXX','BUG ')
29083        WRITE(ICOUT,11)
29084   11   FORMAT('***** AT THE BEGINNING OF DPCRT0--')
29085        CALL DPWRST('XXX','BUG ')
29086        WRITE(ICOUT,12)ICASCT,N,NUMSE1
29087   12   FORMAT('ICASCT,N,NUMSE1 = ',A4,2I8)
29088        CALL DPWRST('XXX','BUG ')
29089        WRITE(ICOUT,13)IYVAR,IXVAR,IX2VAR
29090   13   FORMAT('IYVAR,IXVAR,IX2VAR = ',A4,2X,A4,2X,A4)
29091        CALL DPWRST('XXX','BUG ')
29092        WRITE(ICOUT,14)IYNAM,IXNAM,IXNAM2
29093   14   FORMAT('IYNAM,IXNAM,IXNAM2 = ',A8,2X,A8,2X,A8)
29094        CALL DPWRST('XXX','BUG ')
29095        DO20I=1,N
29096          WRITE(ICOUT,16)I,Y(I),Z(I),Z2(I),TAG1(I)
29097   16     FORMAT('I,Y(I),Z(I),Z2(I),TAG1(I) = ',I8,4G15.7)
29098          CALL DPWRST('XXX','BUG ')
29099   20   CONTINUE
29100      ENDIF
29101C
29102C               ***********************************************
29103C               **  STEP 5--                                 **
29104C               **  COMPUTE THE VARIOUS CROSS-TAB STATISTICS **
29105C               ***********************************************
29106C
29107      ISTEPN='5.1'
29108      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CRT0')
29109     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
29110C
29111C     ALLOW THE   SET WRITE DECIMALS COMMAND    TO BE USED TO
29112C     DETERMINE HOW MANY DIGITS PRINTED IN TABLE.
29113C
29114      NUMDIG=-7
29115      IF(IFORSW.EQ.'1')NUMDIG=1
29116      IF(IFORSW.EQ.'2')NUMDIG=2
29117      IF(IFORSW.EQ.'3')NUMDIG=3
29118      IF(IFORSW.EQ.'4')NUMDIG=4
29119      IF(IFORSW.EQ.'5')NUMDIG=5
29120      IF(IFORSW.EQ.'6')NUMDIG=6
29121      IF(IFORSW.EQ.'7')NUMDIG=7
29122      IF(IFORSW.EQ.'8')NUMDIG=8
29123      IF(IFORSW.EQ.'9')NUMDIG=9
29124      IF(IFORSW.EQ.'0')NUMDIG=10
29125      IF(IFORSW.EQ.'-2')NUMDIG=-2
29126      IF(IFORSW.EQ.'-3')NUMDIG=-3
29127      IF(IFORSW.EQ.'-4')NUMDIG=-4
29128      IF(IFORSW.EQ.'-5')NUMDIG=-5
29129      IF(IFORSW.EQ.'-6')NUMDIG=-6
29130      IF(IFORSW.EQ.'-7')NUMDIG=-7
29131      IF(IFORSW.EQ.'-8')NUMDIG=-8
29132      IF(IFORSW.EQ.'-9')NUMDIG=-9
29133C
29134C     NOTE 9/2008: IN FOLLOWING, WE NEED TO DISTINGUISH BETWEEN
29135C                  EMPTY SETS DUE TO NO POINTS FALLING IN THE
29136C                  PARTICULAR CROSS TABULATION (IN WHICH CASE,
29137C                  WE WANT TO SKIP IN THE OUTPUT FILE) AND EMPTY
29138C                  SETS DUE TO ALL POINTS IN THE PARTICULAR
29139C                  CROSS TABULATION BEING MISSING (IN WHICH CASE,
29140C                  WE MAY WANT TO WRITE A 0 OR A MISSING VALUE).
29141C
29142C                  THERE ARE 2 MISSING VALUES:
29143C
29144C                  PSTAMV   - SPECIFIES WHETHER THE INPUT DATA
29145C                             VALUE IS TO BE INCLUDED IN THE
29146C                             COMPUTATION OF THE STATISTIC
29147C
29148C                  PCTAMV    - IF ALL THE DATA IS MISSING, THIS
29149C                              IS THE VALUE TO USE IN WRITING THE
29150C                              CROSS TABULATE OUTPUT.
29151C
29152      IWRITE='OFF'
29153C
29154      EPS=0.1E-7
29155      J=0
29156      K=0
29157      NRESP=NUMV2-1
29158C
29159      ISTEPN='5.2'
29160      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CRT0')
29161     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
29162C
29163      DO1110ISET1=1,NUMSE1
29164C
29165        K=0
29166        NTEMP2=0
29167        NTEMP=0
29168C
29169        ISTEPN='5.2'
29170        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CRT0')
29171     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
29172C
29173        DO1130I=1,N
29174          IF(XIDTEM(ISET1).EQ.TAG1(I))GOTO1131
29175          GOTO1130
29176 1131     CONTINUE
29177C
29178          NTEMP2=NTEMP2+1
29179          IF(IYVAR.EQ.'OFF')THEN
29180            NTEMP=NTEMP+1
29181            TEMP(NTEMP)=0.0
29182          ELSE
29183            IF(ABS(Y(I)-PSTAMV).GT.EPS)THEN
29184              NTEMP=NTEMP+1
29185              TEMP(NTEMP)=Y(I)
29186              IF(IXVAR.EQ.'ON')TEMPZ(NTEMP)=Z(I)
29187              IF(IX2VAR.EQ.'ON')TEMPZ2(NTEMP)=Z2(I)
29188            ENDIF
29189          ENDIF
29190 1130   CONTINUE
29191C
29192        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CRT0')THEN
29193          ISTEPN='5.3'
29194          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
29195          WRITE(ICOUT,999)
29196          CALL DPWRST('XXX','BUG ')
29197          WRITE(ICOUT,1133)NTEMP,NTEMP2
29198 1133     FORMAT('DPCRT0: NTEMP,NTEMP2=',2I8)
29199          CALL DPWRST('XXX','BUG ')
29200        ENDIF
29201C
29202C       AUGUST 2002.  CALL CMPSTA (EXCEPT FOR CHI-SQUARE CASE)
29203C
29204C       NTEMP2 IS THE NUMBER OF POINTS IN THE SUBSET AND
29205C       NTEMP IS THE NUMBER OF NON-MISSING POINTS IN THE SUBSET.
29206C
29207        IF(NTEMP2.EQ.0)GOTO1110
29208C
29209        IF(NTEMP.EQ.0)THEN
29210          IF(ICTAMV.EQ.'ZERO')THEN
29211            STAT=0.0
29212            IF(IBFLAG.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
29213     1         ICASCT.EQ.'MDCL')THEN
29214              NTRIAL=0
29215              ALOWLM=0.0
29216              AUPPLM=0.0
29217            ENDIF
29218          ELSEIF(ICTAMV.EQ.'MV  ')THEN
29219            STAT=PCTAMV
29220            IF(IBFLAG.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
29221     1         ICASCT.EQ.'MDCL')THEN
29222              NTRIAL=0
29223              ALOWLM=PCTAMV
29224              AUPPLM=PCTAMV
29225            ENDIF
29226          ELSE
29227            GOTO1110
29228          ENDIF
29229        ELSE
29230          CALL CMPSTA(
29231     1              TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,
29232     1              MAXNXT,NTEMP,NTEMP,NTEMP,
29233     1              NRESP,ICASCT,
29234     1              ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
29235     1              DTEMP1,DTEMP2,DTEMP3,
29236CCCCC1              IQUAME,IQUASE,PSTAMV,
29237     1              STAT,
29238     1              ISUBRO,IBUGA3,IERROR)
29239          IF(IERROR.EQ.'YES')GOTO9000
29240          IF(IBFLAG.EQ.'BPRO')THEN
29241            PTEMP=STAT
29242            NTRIAL=NTEMP
29243            IF(ICASCT.EQ.'BRAT')NTRIAL=ITEMP1(1)
29244            IF(STAT.EQ.PSTAMV)THEN
29245              ALOWLM=PSTAMV
29246              AUPPLM=PSTAMV
29247            ELSE
29248              ALPHAT=ALPHA
29249              CALL DPAGCO(PTEMP,NTRIAL,ALPHAT,IWRITE,
29250     1                    ALOWLM,AUPPLM,IBUGA3,IERROR)
29251            ENDIF
29252          ELSEIF(ICASCT.EQ.'MECL')THEN
29253            XMEAN=STAT
29254            NTRIAL=NTEMP
29255            IF(STAT.EQ.PSTAMV)THEN
29256              ALOWLM=PSTAMV
29257              AUPPLM=PSTAMV
29258            ELSE
29259              CALL SD(TEMP,NTEMP,IWRITE,XSD,IBUGA3,IERROR)
29260              ALPHAT=ALPHA
29261              CALL DPMECL(XMEAN,XSD,NTEMP,ALPHAT,IWRITE,
29262     1                    ALOWLM,AUPPLM,IBUGA3,IERROR)
29263            ENDIF
29264          ELSEIF(ICASCT.EQ.'MDCL')THEN
29265            XMED=STAT
29266            NTRIAL=NTEMP
29267            IF(STAT.EQ.PSTAMV)THEN
29268              ALOWLM=PSTAMV
29269              AUPPLM=PSTAMV
29270            ELSE
29271              XQ=0.5
29272              CALL QUANSE(XQ,TEMP,NTEMP,IWRITE,XTEMP1,MAXNXT,IQUASE,
29273     1                    QUASE,IBUGA3,IERROR)
29274              ALPHAT=ALPHA
29275              CALL DPMECL(XMED,QUASE,NTEMP,ALPHAT,IWRITE,
29276     1                    ALOWLM,AUPPLM,IBUGA3,IERROR)
29277            ENDIF
29278          ENDIF
29279        ENDIF
29280C
29281        J=J+1
29282        Y2(J)=STAT
29283        X2(J)=XIDTEM(ISET1)
29284C
29285        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CRT0')THEN
29286          WRITE(ICOUT,999)
29287          CALL DPWRST('XXX','BUG ')
29288          WRITE(ICOUT,1136)J
29289 1136     FORMAT('DPCRT0: J=',I8)
29290          CALL DPWRST('XXX','BUG ')
29291        ENDIF
29292C
29293        IF(IBFLAG.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
29294     1     ICASCT.EQ.'MDCL')THEN
29295          XNTRIA(J)=REAL(NTRIAL)
29296          XACLOW(J)=ALOWLM
29297          XACUPP(J)=AUPPLM
29298        ENDIF
29299C
29300 1110 CONTINUE
29301C
29302      N2=J
29303C
29304      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CRT0')THEN
29305        WRITE(ICOUT,999)
29306        CALL DPWRST('XXX','BUG ')
29307        WRITE(ICOUT,1191)J,N2
29308 1191   FORMAT('DPCRT0: J,N2=',2I8)
29309        CALL DPWRST('XXX','BUG ')
29310      ENDIF
29311C
29312      IOP='OPEN'
29313      IFLG11=1
29314      IFLG21=0
29315      IFLG31=0
29316      IFLAG4=0
29317      IFLAG5=0
29318      CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLAG4,IFLAG5,
29319     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
29320     1            IBUGA3,ISUBRO,IERROR)
29321      IF(IERROR.EQ.'YES')GOTO9000
29322C
29323CCCCC WRITE OUT TO DPST1F.DAT
29324C
29325      WRITE(IOUNI1,2111)ICTNAM
29326 2111 FORMAT(' GROUP-ID 1          ',A40)
29327      IF(IBFLAG.EQ.'BPRO')THEN
29328        DO2170I=1,N2
29329          IF(IBINTA.EQ.'LOWE')THEN
29330            WRITE(IOUNI1,2171)X2(I),Y2(I),XNTRIA(I),XACLOW(I)
29331 2171       FORMAT(4E17.9)
29332          ELSEIF(IBINTA.EQ.'UPPE')THEN
29333            WRITE(IOUNI1,2171)X2(I),Y2(I),XNTRIA(I),XACUPP(I)
29334          ELSE
29335            WRITE(IOUNI1,2173)X2(I),Y2(I),XNTRIA(I),
29336     1                        XACLOW(I),XACUPP(I)
29337 2173       FORMAT(5E17.9)
29338          ENDIF
29339 2170   CONTINUE
29340      ELSEIF(ICASCT.EQ.'MECL' .OR. ICASCT.EQ.'MDCL')THEN
29341        DO2175I=1,N2
29342          WRITE(IOUNI1,2173)X2(I),Y2(I),XNTRIA(I),
29343     1                      XACLOW(I),XACUPP(I)
29344 2175   CONTINUE
29345      ELSE
29346        DO2160I=1,N2
29347          WRITE(IOUNI1,2161)X2(I),Y2(I)
29348 2161     FORMAT(2E17.9)
29349 2160   CONTINUE
29350      ENDIF
29351C
29352      IOP='CLOS'
29353      CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLAG4,IFLAG5,
29354     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
29355     1            IBUGA3,ISUBRO,IERROR)
29356      IF(IERROR.EQ.'YES')GOTO9000
29357C
29358C               *****************************
29359C               **   STEP 6--              **
29360C               **   WRITE OUT THE TABLE   **
29361C               *****************************
29362C
29363      ISTEPN='6'
29364      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CRT0')
29365     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
29366C
29367      WRITE(ICOUT,999)
29368  999 FORMAT(1X)
29369      CALL DPWRST('XXX','BUG ')
29370C
29371      IF(IPRINT.EQ.'OFF')GOTO8000
29372C
29373      ITITLE(1:15)='Cross Tabulate '
29374      IF(ICASCT.EQ.'BPRO')THEN
29375        NCTITL=37
29376        ITITLE(16:NCTITL)='Binomial Probabilities'
29377      ELSEIF(ICASCT.EQ.'MECL')THEN
29378        NCTITL=37
29379        ITITLE(16:NCTITL)='Mean Confidence Limits'
29380      ELSEIF(ICASCT.EQ.'MDCL')THEN
29381        NCTITL=39
29382        ITITLE(16:NCTITL)='Median Confidence Limits'
29383      ELSE
29384        ITITLE(16:55)=ICTNAM(1:40)
29385        NCTITL=55
29386        DO4010I=55,1,-1
29387          IF(ITITLE(I:I).NE.' ')THEN
29388            NCTITL=I
29389            GOTO4019
29390          ENDIF
29391 4010   CONTINUE
29392 4019   CONTINUE
29393      ENDIF
29394C
29395      IF(IYVAR.EQ.'ON')THEN
29396        ITITL9(1:21)='(Response Variables: '
29397        NTEMP=21
29398        ITITL9(22:30)=IYNAM(1:8)
29399        NTEMP=30
29400        IF(IXVAR.EQ.'ON')THEN
29401          ITITL9(30:30)=' '
29402          ITITL9(31:38)=IXNAM(1:8)
29403          NTEMP=38
29404        ENDIF
29405        IF(IX2VAR.EQ.'ON')THEN
29406          ITITL9(39:39)=' '
29407          ITITL9(40:47)=IXNAM2(1:8)
29408          NTEMP=47
29409        ENDIF
29410        NTEMP=NTEMP+1
29411        ITITL9(NTEMP:NTEMP)=')'
29412        NCTIT9=NTEMP
29413      ELSE
29414        ITITL9=' '
29415        NCTIT9=0
29416      ENDIF
29417C
29418      ITITL2(1,1)(1:8)=IX1NAM
29419      NCTIT2(1,1)=8
29420      ITITL2(1,2)='   |   '
29421      IF(ICAPTY.EQ.'LATE')THEN
29422        ITITL2(1,2)='  $|$  '
29423      ENDIF
29424      NCTIT2(1,2)=7
29425C
29426      NUMLIN=1
29427      IF(ICASCT.EQ.'BPRO')THEN
29428        NUMCOL=6
29429        IF(IBINTA.EQ.'LOWE' .OR. IBINTA.EQ.'UPPE')NUMCOL=5
29430        ITITL2(1,3)='P'
29431        NCTIT2(1,3)=1
29432        ITITL2(1,4)='N'
29433        NCTIT2(1,4)=1
29434        IF(IBINTA.EQ.'LOWE')THEN
29435          ITITL2(1,5)(1:40)='Lower AC'
29436          NCTIT2(1,5)=8
29437        ELSEIF(IBINTA.EQ.'UPPE')THEN
29438          ITITL2(1,5)(1:40)='Upper AC'
29439          NCTIT2(1,5)=8
29440        ELSE
29441          ITITL2(1,5)(1:40)='Lower AC'
29442          NCTIT2(1,5)=8
29443          ITITL2(1,6)(1:40)='Upper AC'
29444          NCTIT2(1,6)=8
29445        ENDIF
29446      ELSEIF(ICASCT.EQ.'MECL' .OR. ICASCT.EQ.'MDCL')THEN
29447        NUMCOL=6
29448        IF(ICASCT.EQ.'MECL')THEN
29449          ITITL2(1,3)='Mean'
29450          NCTIT2(1,3)=4
29451        ELSE
29452          ITITL2(1,3)='Median'
29453          NCTIT2(1,3)=6
29454        ENDIF
29455        ITITL2(1,4)='N'
29456        NCTIT2(1,4)=1
29457        ITITL2(1,5)='Lower Limit'
29458        ITITL2(1,6)='Upper Limit'
29459        NCTIT2(1,5)=11
29460        NCTIT2(1,6)=11
29461      ELSE
29462        NUMCOL=3
29463        ITITL2(1,3)(1:15)=ICTNAM(1:15)
29464        NTEMP=15
29465        DO4070I=15,1,-1
29466          IF(ITITL2(1,3)(I:I).NE.' ')THEN
29467            NTEMP=I
29468            GOTO4079
29469          ENDIF
29470 4070   CONTINUE
29471 4079   CONTINUE
29472        NCTIT2(1,3)=NTEMP
29473      ENDIF
29474C
29475      NMAX=0
29476      DO4210I=1,NUMCOL
29477        VALIGN(I)='b'
29478        ALIGN(I)='r'
29479        NTOT(I)=15
29480        IF(NCTIT2(1,I).GT.NTOT(I))NTOT(I)=NCTIT2(1,I)
29481        NMAX=NMAX+NTOT(I)
29482        IDIGIT(I)=NUMDIG
29483        ITYPCO(I)='NUME'
29484        IF(I.EQ.4)THEN
29485          NTOT(I)=8
29486          IDIGIT(I)=0
29487        ELSEIF(I.EQ.2)THEN
29488          ITYPCO(I)='ALPH'
29489          NTOT(I)=7
29490          IDIGIT(I)=-1
29491        ENDIF
29492 4210 CONTINUE
29493C
29494      IWHTML(1)=125
29495      IWHTML(2)=25
29496      IWHTML(3)=125
29497      IWHTML(4)=75
29498      IWHTML(5)=125
29499      IWHTML(6)=125
29500      IJUNK=1400
29501      IWRTF(1)=IJUNK
29502      IWRTF(2)=IWRTF(1)+200
29503      IWRTF(3)=IWRTF(2)+IJUNK
29504      IWRTF(4)=IWRTF(3)+800
29505      IWRTF(5)=IWRTF(4)+IJUNK
29506      IWRTF(6)=IWRTF(5)+IJUNK
29507      IFRST=.TRUE.
29508      IFLAGS=.TRUE.
29509      ILAST=.TRUE.
29510      IFLAGE=.FALSE.
29511C
29512      ICALL=0
29513      ICNT=0
29514      DO4310I=1,N2
29515        IF(ICNT.GE.30)THEN
29516          IF(I.EQ.N2)IFLAGE=.TRUE.
29517          CALL DPDTA5(ITITLE,NCTITL,
29518     1                ITITL9,NCTIT9,ITITL2,NCTIT2,
29519     1                MAXLIN,NUMLIN,NUMCLI,NUMCOL,
29520     1                IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
29521     1                IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
29522     1                ICAPSW,ICAPTY,IFRST,ILAST,
29523     1                IFLAGS,IFLAGE,
29524     1                ISUBRO,IBUGA3,IERROR)
29525          IFRST=.FALSE.
29526          IFLAGS=.FALSE.
29527          ICALL=1
29528          ICNT=0
29529        ENDIF
29530        ICNT=ICNT+1
29531        NCTEXT(ICNT)=0
29532        AMAT(ICNT,1)=X2(I)
29533        AMAT(ICNT,2)=0.0
29534        AMAT(ICNT,3)=Y2(I)
29535        IF(ICASCT.EQ.'BPRO' .AND. IBINTA.EQ.'LOWE')THEN
29536          AMAT(ICNT,4)=XNTRIA(I)
29537          AMAT(ICNT,5)=XACLOW(I)
29538        ELSEIF(ICASCT.EQ.'BPRO' .AND. IBINTA.EQ.'UPPE')THEN
29539          AMAT(ICNT,4)=XNTRIA(I)
29540          AMAT(ICNT,5)=XACUPP(I)
29541        ELSEIF(ICASCT.EQ.'BPRO')THEN
29542          AMAT(ICNT,4)=XNTRIA(I)
29543          AMAT(ICNT,5)=XACLOW(I)
29544          AMAT(ICNT,6)=XACUPP(I)
29545        ELSEIF(ICASCT.EQ.'MECL' .OR. ICASCT.EQ.'MDCL')THEN
29546          AMAT(ICNT,4)=XNTRIA(I)
29547          AMAT(ICNT,5)=XACLOW(I)
29548          AMAT(ICNT,6)=XACUPP(I)
29549        ENDIF
29550        DO4320J=1,NUMCOL
29551          IF(J.EQ.2)THEN
29552            NCVALU(ICNT,J)=7
29553            IVALUE(ICNT,J)='   |   '
29554            IF(ICAPTY.EQ.'LATE')THEN
29555              IVALUE(ICNT,J)='  $|$  '
29556            ENDIF
29557          ELSE
29558            NCVALU(ICNT,J)=0
29559            IVALUE(ICNT,J)=' '
29560          ENDIF
29561 4320   CONTINUE
29562 4310 CONTINUE
29563C
29564      IF(ICNT.GE.1)THEN
29565        IFLAGE=.TRUE.
29566        ILAST=.TRUE.
29567        CALL DPDTA5(ITITLE,NCTITL,
29568     1              ITITL9,NCTIT9,ITITL2,NCTIT2,
29569     1              MAXLIN,NUMLIN,NUMCLI,NUMCOL,
29570     1              IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
29571     1              IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
29572     1              ICAPSW,ICAPTY,IFRST,ILAST,
29573     1              IFLAGS,IFLAGE,
29574     1              ISUBRO,IBUGA3,IERROR)
29575      ENDIF
29576C
29577 8000 CONTINUE
29578      IF(IFEEDB.EQ.'ON')THEN
29579        WRITE(ICOUT,9212)
29580 9212   FORMAT(6X,'GROUP-IDs AND STATISTIC WRITTEN TO FILE ',
29581     1         'DPST1F.DAT')
29582        CALL DPWRST('XXX','BUG ')
29583      ENDIF
29584C
29585C               ******************
29586C               **   STEP 90--  **
29587C               **   EXIT       **
29588C               ******************
29589C
29590 9000 CONTINUE
29591      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CRT0')THEN
29592        WRITE(ICOUT,999)
29593        CALL DPWRST('XXX','BUG ')
29594        WRITE(ICOUT,9011)
29595 9011   FORMAT('***** AT THE END       OF DPCRT0--')
29596        CALL DPWRST('XXX','BUG ')
29597        WRITE(ICOUT,9012)ICASCT,N,NUMV2,NUMSE1,N2,IERROR
29598 9012   FORMAT('ICASCT,N,NUMV2,NUMSE1,N2,IERROR = ',A4,4I8,2X,A4)
29599        CALL DPWRST('XXX','BUG ')
29600        WRITE(ICOUT,9016)ANUMS1
29601 9016   FORMAT('ANUMS1 = ',E15.7)
29602        CALL DPWRST('XXX','BUG ')
29603        DO9020I=1,N2
29604          WRITE(ICOUT,9021)I,Y2(I),X2(I)
29605 9021     FORMAT('I,Y2(I),X2(I) = ',I8,2G15.7)
29606          CALL DPWRST('XXX','BUG ')
29607 9020   CONTINUE
29608      ENDIF
29609C
29610      RETURN
29611      END
29612      SUBROUTINE DPCSR2(Y,X,N,ICASAN,MAXNXT,TEMP1,TEMP2,
29613     1                  IVARID,IVARI2,IVARI3,IVARI4,
29614     1                  XMIN,XMAX,YMIN,YMAX,
29615     1                  ICAPSW,ICAPTY,IFORSW,
29616     1                  STATV1,STATV2,STATC2,PVAL2,
29617     1                  CV01,CV02,CV05,CV10,CV15,CV25,CV50,
29618     1                  CV75,CV85,CV90,CV95,CV98,CV99,
29619     1                  CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
29620     1                  ISUBRO,IBUGA3,IERROR)
29621C
29622C     PURPOSE--THIS ROUTINE CARRIES OUT SEVERAL TESTS FOR COMPLETE
29623C              SPATIAL RANDOMNESS:
29624C
29625C                 1. BIVARAITE CRAMER VON-MISES TEST (I.E., BIVARIATE
29626C                    UNIFORMITY.
29627C
29628C                 2. MEAN NEAREST NEIGHBORS DISTANCE TEST.
29629C
29630C                 3. POLLARD'S STATISTIC (FOR DISTANCE INDEX
29631C                    1, 2, 3, 4, 5)
29632C
29633C     EXAMPLE--COMPLETE SPATIAL RANDOMNESS Y X
29634C     REFERENCES--DALE ZIMMERMAN (1993), "A BIVARIATE CRAMER-VON MISES
29635C                 TYPE OF TEST FOR SPATIAL RANDONNESS", JOURNAL OF
29636C                 THE ROYAL STATISTICAL SOCIETY, SERIES C (APPLIED
29637C                 STATISTICS, VOL. 42, NO. 1, PP. 43-54.
29638C                 LONDON.
29639C               --CLARK AND EVANS (1954), "DISTANCE TO NEAREST
29640C                 NEIGHBOR AS A MEASURE OF SPATIAL RELATIONSHIPS
29641C                 IN POPULATIONS", ECOLOGY, 35, PP. 23-30.
29642C               --DONNELLY (1978), "SIMULATIONS TO DETERMINE THE
29643C                 VARIANCE AND EDGE-EFFECT OF TOTAL NEAREST-NEIGHBOR
29644C                 DISTANCE", IN SIMULATION STUDIES IN ARCHAEOLOGY
29645C                 (ED. HODDER), PP. 91-95, LONDON: CAMBRIDGE UNIVERSITY
29646C                 PRESS.
29647C               --FORTIN AND DALE (2005), "SPATIAL ANALYSIS: A GUIDE
29648C                 FOR ECOLOGISTS", CAMBRIDGE UNIVERSITY PRESS, PP. 34-35.
29649C               --POLLARD (1971), "ON DISTANCE ESTIMATORS OF DENSITY
29650C                 IN RANDOMLY DISTRIBUTED FORESTS", BIOMETRICS, 27,
29651C                 991-1002.
29652C               --LIU (2001), "A COMPARISON OF FIVE DISTANCE-BASED
29653C                 METHODS FOR PATTERN ANALYSIS", JOURNAL OF VEGETATION
29654C                 SCIENCE, 12, 411-416.
29655C     WRITTEN BY--ALAN HECKERT
29656C                 STATISTICAL ENGINEERING DIVISION
29657C                 INFORMATION TECHNOLOGY LABORATORY
29658C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
29659C                 GAITHERSBURG, MD 20899-8980
29660C                 PHONE--301-975-2899
29661C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
29662C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
29663C     LANGUAGE--ANSI FORTRAN (1977)
29664C     VERSION NUMBER--2014/1
29665C     ORIGINAL VERSION--JANUARY   2014.
29666C
29667C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
29668C
29669      CHARACTER*4 ICASAN
29670      CHARACTER*4 IERROR
29671      CHARACTER*4 IVARID
29672      CHARACTER*4 IVARI2
29673      CHARACTER*4 IVARI3
29674      CHARACTER*4 IVARI4
29675      CHARACTER*4 ICAPSW
29676      CHARACTER*4 ICAPTY
29677      CHARACTER*4 IFORSW
29678      CHARACTER*4 ISUBRO
29679      CHARACTER*4 IBUGA3
29680C
29681      CHARACTER*4 IWRITE
29682C
29683      CHARACTER*4 ISUBN1
29684      CHARACTER*4 ISUBN2
29685      CHARACTER*4 ISTEPN
29686C
29687      PARAMETER (NUMALP=7)
29688      REAL ALPHA(NUMALP)
29689      REAL ALOWER(NUMALP)
29690      REAL AUPPER(NUMALP)
29691C
29692      PARAMETER(NUMCLI=5)
29693      PARAMETER(MAXLIN=3)
29694      PARAMETER (MAXROW=50)
29695      CHARACTER*60 ITITLE
29696      CHARACTER*60 ITITLZ
29697      CHARACTER*40 ITITL9
29698      CHARACTER*60 ITEXT(MAXROW)
29699      CHARACTER*4  ALIGN(NUMCLI)
29700      CHARACTER*4  VALIGN(NUMCLI)
29701      REAL         AVALUE(MAXROW)
29702      INTEGER      NCTEXT(MAXROW)
29703      INTEGER      IDIGIT(MAXROW)
29704      INTEGER      NTOT(MAXROW)
29705      CHARACTER*60 ITITL2(MAXLIN,NUMCLI)
29706      CHARACTER*15 IVALUE(MAXROW,NUMCLI)
29707      CHARACTER*4  ITYPCO(NUMCLI)
29708      INTEGER      NCTIT2(MAXLIN,NUMCLI)
29709      INTEGER      NCVALU(MAXROW,NUMCLI)
29710      INTEGER      IWHTML(NUMCLI)
29711      INTEGER      IWRTF(NUMCLI)
29712      REAL         AMAT(MAXROW,NUMCLI)
29713      LOGICAL IFRST
29714      LOGICAL ILAST
29715      LOGICAL IFLAGS
29716      LOGICAL IFLAGE
29717C
29718C---------------------------------------------------------------------
29719C
29720      DIMENSION Y(*)
29721      DIMENSION X(*)
29722      DIMENSION TEMP1(*)
29723      DIMENSION TEMP2(*)
29724C
29725      DIMENSION STATV3(5)
29726      DIMENSION STATV4(5)
29727      DIMENSION STATC3(5)
29728      DIMENSION STATP3(5)
29729      DIMENSION STATN3(5)
29730C
29731C---------------------------------------------------------------------
29732C
29733      INCLUDE 'DPCOP2.INC'
29734C
29735      DATA ALPHA/
29736     1 50.0, 75.0, 80.0, 90.0, 95.0, 99.0, 99.9/
29737C
29738C-----START POINT-----------------------------------------------------
29739C
29740      ISUBN1='DPCS'
29741      ISUBN2='R2  '
29742      IERROR='NO'
29743      STATV1=CPUMIN
29744      STATV2=CPUMIN
29745      STATC2=CPUMIN
29746      PVAL2=CPUMIN
29747      CUTL90=CPUMIN
29748      CUTU90=CPUMIN
29749      CUTL95=CPUMIN
29750      CUTU95=CPUMIN
29751      CUTL99=CPUMIN
29752      CUTU99=CPUMIN
29753C
29754      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CSR2')THEN
29755        WRITE(ICOUT,999)
29756  999   FORMAT(1X)
29757        CALL DPWRST('XXX','WRIT')
29758        WRITE(ICOUT,51)
29759   51   FORMAT('**** AT THE BEGINNING OF DPCSR2--')
29760        CALL DPWRST('XXX','WRIT')
29761        WRITE(ICOUT,52)ISUBRO,IBUGA3,ICASAN,N,MAXNXT
29762   52   FORMAT('ISUBRO,IBUGA3,ICASAN,N,MAXNXT = ',3(A4,2X),2I8)
29763        CALL DPWRST('XXX','WRIT')
29764        WRITE(ICOUT,54)XMIN,XMAX,YMIN,YMAX
29765   54   FORMAT('XMIN,XMAX,YMIN,YMAX = ',4G15.7)
29766        CALL DPWRST('XXX','WRIT')
29767        DO56I=1,N
29768          WRITE(ICOUT,57)I,Y(I),X(I)
29769   57     FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
29770          CALL DPWRST('XXX','WRIT')
29771   56   CONTINUE
29772      ENDIF
29773C
29774C               ********************************************
29775C               **  STEP 11--                             **
29776C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
29777C               ********************************************
29778C
29779      ISTEPN='11'
29780      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CSR2')
29781     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
29782C
29783      IF(N.LT.5)THEN
29784        WRITE(ICOUT,999)
29785        CALL DPWRST('XXX','WRIT')
29786        WRITE(ICOUT,1111)
29787 1111   FORMAT('***** ERROR IN COMPLETE SPATIAL RANDOMNESS TEST--')
29788        CALL DPWRST('XXX','WRIT')
29789        WRITE(ICOUT,1113)
29790 1113   FORMAT('      THE NUMBER OF OBSERVATIONS IS LESS THAN 5.')
29791        CALL DPWRST('XXX','WRIT')
29792        WRITE(ICOUT,1114)N
29793 1114   FORMAT('SAMPLE SIZE = ',I8)
29794        CALL DPWRST('XXX','WRIT')
29795        IERROR='YES'
29796        GOTO9000
29797      ENDIF
29798C
29799      HOLD=Y(1)
29800      DO1135I=2,N
29801        IF(Y(I).NE.HOLD)GOTO1139
29802 1135 CONTINUE
29803      WRITE(ICOUT,999)
29804      CALL DPWRST('XXX','WRIT')
29805      WRITE(ICOUT,1111)
29806      CALL DPWRST('XXX','WRIT')
29807      WRITE(ICOUT,1131)HOLD
29808 1131 FORMAT('      THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7)
29809      CALL DPWRST('XXX','WRIT')
29810      IERROR='YES'
29811      GOTO9000
29812 1139 CONTINUE
29813C
29814C               ******************************
29815C               **  STEP 21--               **
29816C               **  CARRY OUT CALCULATIONS  **
29817C               ******************************
29818C
29819      ISTEPN='41'
29820      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CSR2')
29821     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
29822C
29823      XMINZ=XMIN
29824      XMAXZ=XMAX
29825      YMINZ=YMIN
29826      YMAXZ=YMAX
29827      IWRITE='OFF'
29828      CALL MINIM(X,N,IWRITE,XMIND,IBUGA3,IERROR)
29829      CALL MAXIM(X,N,IWRITE,XMAXD,IBUGA3,IERROR)
29830      CALL MINIM(Y,N,IWRITE,YMIND,IBUGA3,IERROR)
29831      CALL MAXIM(Y,N,IWRITE,YMAXD,IBUGA3,IERROR)
29832C
29833      CALL DPCSR3(X,Y,N,TEMP1,TEMP2,
29834     1            XMIN,XMAX,YMIN,YMAX,
29835     1            STATV1,
29836     1            CV01,CV02,CV05,CV10,CV15,CV25,CV50,
29837     1            CV75,CV85,CV90,CV95,CV98,CV99,
29838     1            ISUBRO,IBUGA3,IERROR)
29839C
29840      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CSR2')THEN
29841        WRITE(ICOUT,2111)STATV1,CV05,CV10,CV90,CV95
29842 2111   FORMAT('STATV1,CV05,CV10,CV90,CV95 = ',5G15.7)
29843        CALL DPWRST('XXX','BUG ')
29844      ENDIF
29845C
29846      CALL DPCSR4(X,Y,N,TEMP1,TEMP2,
29847     1            STATV2,STATC2,PVAL2,
29848     1            ISUBRO,IBUGA3,IERROR)
29849C
29850      DO2140I=1,NUMALP
29851        PCONF=ALPHA(I)/100.0
29852        CDF=PCONF
29853        CDF=0.5+(PCONF/2.0)
29854        CALL NORPPF(CDF,PPF)
29855        ALOWER(I)=-PPF
29856        AUPPER(I)=PPF
29857 2140 CONTINUE
29858      CUTL50=ALOWER(1)
29859      CUTU50=AUPPER(1)
29860      CUTL75=ALOWER(2)
29861      CUTU75=AUPPER(2)
29862      CUTL80=ALOWER(3)
29863      CUTU80=AUPPER(3)
29864      CUTL90=ALOWER(4)
29865      CUTU90=AUPPER(4)
29866      CUTL95=ALOWER(5)
29867      CUTU95=AUPPER(5)
29868      CUTL99=ALOWER(6)
29869      CUTU99=AUPPER(6)
29870      CTL999=ALOWER(7)
29871      CTU999=AUPPER(7)
29872C
29873      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CSR2')THEN
29874        WRITE(ICOUT,2141)STATV2,STATC2,PVAL2
29875 2141   FORMAT('STATV2,STATC2,PVAL2 = ',3G15.7)
29876        CALL DPWRST('XXX','BUG ')
29877        WRITE(ICOUT,2143)CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99
29878 2143   FORMAT('CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99=',6G15.7)
29879        CALL DPWRST('XXX','BUG ')
29880      ENDIF
29881C
29882C
29883C               ***************************************
29884C               **   STEP 42--                       **
29885C               **   WRITE OUT EVERYTHING FOR        **
29886C               **   BIVARIATE CRAMER VON-MISES TEST **
29887C               ***************************************
29888C
29889      ISTEPN='42'
29890      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CSR2')
29891     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
29892C
29893      IF(IPRINT.EQ.'OFF')GOTO9000
29894C
29895      NUMDIG=7
29896      IF(IFORSW.EQ.'1')NUMDIG=1
29897      IF(IFORSW.EQ.'2')NUMDIG=2
29898      IF(IFORSW.EQ.'3')NUMDIG=3
29899      IF(IFORSW.EQ.'4')NUMDIG=4
29900      IF(IFORSW.EQ.'5')NUMDIG=5
29901      IF(IFORSW.EQ.'6')NUMDIG=6
29902      IF(IFORSW.EQ.'7')NUMDIG=7
29903      IF(IFORSW.EQ.'8')NUMDIG=8
29904      IF(IFORSW.EQ.'9')NUMDIG=9
29905      IF(IFORSW.EQ.'0')NUMDIG=0
29906      IF(IFORSW.EQ.'E')NUMDIG=-2
29907      IF(IFORSW.EQ.'-2')NUMDIG=-2
29908      IF(IFORSW.EQ.'-3')NUMDIG=-3
29909      IF(IFORSW.EQ.'-4')NUMDIG=-4
29910      IF(IFORSW.EQ.'-5')NUMDIG=-5
29911      IF(IFORSW.EQ.'-6')NUMDIG=-6
29912      IF(IFORSW.EQ.'-7')NUMDIG=-7
29913      IF(IFORSW.EQ.'-8')NUMDIG=-8
29914      IF(IFORSW.EQ.'-9')NUMDIG=-9
29915C
29916      ITITLE='Bivariate Cramer Von-Mises Test'
29917      NCTITL=31
29918      ITITLZ='for Complete Spatial Randomness'
29919      NCTITZ=31
29920C
29921      ICNT=1
29922      ITEXT(ICNT)=' '
29923      NCTEXT(ICNT)=0
29924      AVALUE(ICNT)=0.0
29925      IDIGIT(ICNT)=-1
29926      ICNT=ICNT+1
29927      ITEXT(ICNT)='First Response Variable: '
29928      WRITE(ITEXT(ICNT)(26:29),'(A4)')IVARID(1:4)
29929      WRITE(ITEXT(ICNT)(30:35),'(A4)')IVARI2(1:4)
29930      NCTEXT(ICNT)=35
29931      AVALUE(ICNT)=0.0
29932      IDIGIT(ICNT)=-1
29933      ICNT=ICNT+1
29934      ITEXT(ICNT)='Second Response Variable: '
29935      WRITE(ITEXT(ICNT)(27:30),'(A4)')IVARI3(1:4)
29936      WRITE(ITEXT(ICNT)(31:36),'(A4)')IVARI4(1:4)
29937      NCTEXT(ICNT)=36
29938      AVALUE(ICNT)=0.0
29939      IDIGIT(ICNT)=-1
29940C
29941      ICNT=ICNT+1
29942      ITEXT(ICNT)=' '
29943      NCTEXT(ICNT)=1
29944      AVALUE(ICNT)=0.0
29945      IDIGIT(ICNT)=-1
29946C
29947      ICNT=ICNT+1
29948      ITEXT(ICNT)='H0: Complete Spatial Randomness'
29949      NCTEXT(ICNT)=31
29950      AVALUE(ICNT)=0.0
29951      IDIGIT(ICNT)=-1
29952      ICNT=ICNT+1
29953      ITEXT(ICNT)='Ha: Not Complete Spatial Randomness'
29954      NCTEXT(ICNT)=35
29955      AVALUE(ICNT)=0.0
29956      IDIGIT(ICNT)=-1
29957C
29958      ICNT=ICNT+1
29959      ITEXT(ICNT)=' '
29960      NCTEXT(ICNT)=1
29961      AVALUE(ICNT)=0.0
29962      IDIGIT(ICNT)=-1
29963      ICNT=ICNT+1
29964      ITEXT(ICNT)='Number of Observations:'
29965      NCTEXT(ICNT)=23
29966      AVALUE(ICNT)=REAL(N)
29967      IDIGIT(ICNT)=0
29968      ICNT=ICNT+1
29969      ITEXT(ICNT)='Data Minimum for X:'
29970      NCTEXT(ICNT)=19
29971      AVALUE(ICNT)=XMIND
29972      IDIGIT(ICNT)=NUMDIG
29973      ICNT=ICNT+1
29974      ITEXT(ICNT)='Data Maximum for X:'
29975      NCTEXT(ICNT)=19
29976      AVALUE(ICNT)=XMAXD
29977      IDIGIT(ICNT)=NUMDIG
29978      ICNT=ICNT+1
29979      ITEXT(ICNT)='Data Minimum for Y:'
29980      NCTEXT(ICNT)=19
29981      AVALUE(ICNT)=YMIND
29982      IDIGIT(ICNT)=NUMDIG
29983      ICNT=ICNT+1
29984      ITEXT(ICNT)='Data Maximum for Y:'
29985      NCTEXT(ICNT)=19
29986      AVALUE(ICNT)=YMAXD
29987      IDIGIT(ICNT)=NUMDIG
29988C
29989      IFLAGT=1
29990      IF(XMINZ.EQ.CPUMIN)IFLAGT=0
29991      IF(XMAXZ.EQ.CPUMIN)IFLAGT=0
29992      IF(YMINZ.EQ.CPUMIN)IFLAGT=0
29993      IF(YMAXZ.EQ.CPUMIN)IFLAGT=0
29994      IF(IFLAGT.EQ.1)THEN
29995        ICNT=ICNT+1
29996        ITEXT(ICNT)='User Specified Minimum for X:'
29997        NCTEXT(ICNT)=29
29998        AVALUE(ICNT)=XMINZ
29999        IDIGIT(ICNT)=NUMDIG
30000        ICNT=ICNT+1
30001        ITEXT(ICNT)='User Specified Maximum for X:'
30002        NCTEXT(ICNT)=29
30003        AVALUE(ICNT)=XMAXZ
30004        IDIGIT(ICNT)=NUMDIG
30005        ICNT=ICNT+1
30006        ITEXT(ICNT)='User Specified Minimum for Y:'
30007        NCTEXT(ICNT)=29
30008        AVALUE(ICNT)=YMINZ
30009        IDIGIT(ICNT)=NUMDIG
30010        ICNT=ICNT+1
30011        ITEXT(ICNT)='User Specified Maximum for Y:'
30012        NCTEXT(ICNT)=29
30013        AVALUE(ICNT)=YMAXZ
30014        IDIGIT(ICNT)=NUMDIG
30015      ENDIF
30016C
30017      ICNT=ICNT+1
30018      ITEXT(ICNT)=' '
30019      NCTEXT(ICNT)=1
30020      AVALUE(ICNT)=0.0
30021      IDIGIT(ICNT)=-1
30022      ICNT=ICNT+1
30023      ITEXT(ICNT)='Test Statistic Value:'
30024      NCTEXT(ICNT)=21
30025      AVALUE(ICNT)=STATV1
30026      IDIGIT(ICNT)=NUMDIG
30027C
30028      NUMROW=ICNT
30029      DO4210I=1,NUMROW
30030        NTOT(I)=15
30031 4210 CONTINUE
30032C
30033      IFRST=.TRUE.
30034      ILAST=.TRUE.
30035C
30036      ISTEPN='42A'
30037      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CSR2')
30038     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30039C
30040      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
30041     1            AVALUE,IDIGIT,
30042     1            NTOT,NUMROW,
30043     1            ICAPSW,ICAPTY,ILAST,IFRST,
30044     1            ISUBRO,IBUGA3,IERROR)
30045C
30046      ISTEPN='42B'
30047      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CSR2')
30048     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30049C
30050      ITITLE=' '
30051      NCTITL=0
30052C
30053      ITITL9=' '
30054      NCTIT9=0
30055      ITITLE(1:44)='Percent Points of the Reference Distribution'
30056      NCTITL=44
30057      NUMLIN=1
30058      NUMROW=13
30059      NUMCOL=3
30060      ITITL2(1,1)='Percent Point'
30061      ITITL2(1,2)=' '
30062      ITITL2(1,3)='Value'
30063      NCTIT2(1,1)=13
30064      NCTIT2(1,2)=1
30065      NCTIT2(1,3)=5
30066C
30067      NMAX=0
30068      DO4221I=1,NUMCOL
30069        VALIGN(I)='b'
30070        ALIGN(I)='r'
30071        NTOT(I)=15
30072        IF(I.EQ.2)NTOT(I)=5
30073        NMAX=NMAX+NTOT(I)
30074        IDIGIT(I)=NUMDIG
30075        ITYPCO(I)='NUME'
30076 4221 CONTINUE
30077      ITYPCO(2)='ALPH'
30078      IDIGIT(1)=2
30079      IDIGIT(3)=3
30080      DO4223I=1,NUMROW
30081        DO4225J=1,NUMCOL
30082          NCVALU(I,J)=0
30083          IVALUE(I,J)=' '
30084          NCVALU(I,J)=0
30085          AMAT(I,J)=0.0
30086          IF(J.EQ.1)THEN
30087            IF(I.EQ.1)THEN
30088              AMAT(I,1)=0.01
30089            ELSEIF(I.EQ.2)THEN
30090              AMAT(I,1)=0.02
30091            ELSEIF(I.EQ.3)THEN
30092              AMAT(I,1)=0.05
30093            ELSEIF(I.EQ.4)THEN
30094              AMAT(I,1)=0.10
30095            ELSEIF(I.EQ.5)THEN
30096              AMAT(I,1)=0.15
30097            ELSEIF(I.EQ.6)THEN
30098              AMAT(I,1)=0.25
30099            ELSEIF(I.EQ.7)THEN
30100              AMAT(I,1)=0.50
30101            ELSEIF(I.EQ.8)THEN
30102              AMAT(I,1)=0.75
30103            ELSEIF(I.EQ.9)THEN
30104              AMAT(I,1)=0.85
30105            ELSEIF(I.EQ.10)THEN
30106              AMAT(I,1)=0.90
30107            ELSEIF(I.EQ.11)THEN
30108              AMAT(I,1)=0.95
30109            ELSEIF(I.EQ.12)THEN
30110              AMAT(I,1)=0.98
30111            ELSEIF(I.EQ.13)THEN
30112              AMAT(I,1)=0.99
30113            ENDIF
30114          ELSEIF(J.EQ.2)THEN
30115            IVALUE(I,J)='='
30116            NCVALU(I,J)=1
30117          ELSEIF(J.EQ.3)THEN
30118            IF(I.EQ.1)THEN
30119              AMAT(I,J)=CV01
30120            ELSEIF(I.EQ.2)THEN
30121              AMAT(I,J)=CV02
30122            ELSEIF(I.EQ.3)THEN
30123              AMAT(I,J)=CV05
30124            ELSEIF(I.EQ.4)THEN
30125              AMAT(I,J)=CV10
30126            ELSEIF(I.EQ.5)THEN
30127              AMAT(I,J)=CV15
30128            ELSEIF(I.EQ.6)THEN
30129              AMAT(I,J)=CV25
30130            ELSEIF(I.EQ.7)THEN
30131              AMAT(I,J)=CV50
30132            ELSEIF(I.EQ.8)THEN
30133              AMAT(I,J)=CV75
30134            ELSEIF(I.EQ.9)THEN
30135              AMAT(I,J)=CV85
30136            ELSEIF(I.EQ.10)THEN
30137              AMAT(I,J)=CV90
30138            ELSEIF(I.EQ.11)THEN
30139              AMAT(I,J)=CV95
30140            ELSEIF(I.EQ.12)THEN
30141              AMAT(I,J)=CV98
30142            ELSEIF(I.EQ.13)THEN
30143              AMAT(I,J)=CV99
30144            ENDIF
30145          ENDIF
30146 4225   CONTINUE
30147 4223 CONTINUE
30148C
30149      IWHTML(1)=150
30150      IWHTML(2)=50
30151      IWHTML(3)=150
30152      IWRTF(1)=2000
30153      IWRTF(2)=IWRTF(1)+500
30154      IWRTF(3)=IWRTF(2)+2000
30155      IFRST=.TRUE.
30156      ILAST=.FALSE.
30157C
30158      ISTEPN='42C'
30159      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CSR2')
30160     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30161C
30162      CALL DPDTA4(ITITL9,NCTIT9,
30163     1            ITITLE,NCTITL,ITITL2,NCTIT2,
30164     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
30165     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW,
30166     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
30167     1            ICAPSW,ICAPTY,IFRST,ILAST,
30168     1            ISUBRO,IBUGA3,IERROR)
30169C
30170      ISTEPN='42D'
30171      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CSR2')
30172     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30173C
30174      ITITL9=' '
30175      NCTIT9=0
30176      ITITLE='Conclusions (Two-Tailed Test)'
30177      NCTITL=29
30178      NUMLIN=2
30179      NUMROW=4
30180      NUMCOL=4
30181      ITITL2(1,1)=' '
30182      ITITL2(2,1)='Alpha'
30183      NCTIT2(1,1)=0
30184      NCTIT2(2,1)=5
30185      ITITL2(1,2)='Lower'
30186      ITITL2(2,2)='Critical Value'
30187      NCTIT2(1,2)=5
30188      NCTIT2(2,2)=14
30189      ITITL2(1,3)='Upper'
30190      ITITL2(2,3)='Critical Value'
30191      NCTIT2(1,3)=5
30192      NCTIT2(2,3)=14
30193      ITITL2(1,4)=' '
30194      ITITL2(2,4)='Conclusion'
30195      NCTIT2(1,4)=0
30196      NCTIT2(2,4)=10
30197C
30198      NMAX=0
30199      DO4321I=1,NUMCOL
30200        VALIGN(I)='b'
30201        ALIGN(I)='r'
30202        NTOT(I)=15
30203        IF(I.EQ.1)NTOT(I)=7
30204        IF(I.EQ.2 .OR. I.EQ.3)NTOT(I)=17
30205        NMAX=NMAX+NTOT(I)
30206        IDIGIT(I)=3
30207        ITYPCO(I)='ALPH'
30208        IF(I.EQ.2 .OR. I.EQ.3)ITYPCO(I)='NUME'
30209 4321 CONTINUE
30210      IDIGIT(1)=0
30211      IDIGIT(4)=0
30212      DO4323I=1,NUMROW
30213        DO4325J=1,NUMCOL
30214          NCVALU(I,J)=0
30215          IVALUE(I,J)=' '
30216          NCVALU(I,J)=0
30217          AMAT(I,J)=0.0
30218 4325   CONTINUE
30219 4323 CONTINUE
30220      IVALUE(1,1)='20%'
30221      IVALUE(2,1)='10%'
30222      IVALUE(3,1)='4%'
30223      IVALUE(4,1)='2%'
30224      NCVALU(1,1)=3
30225      NCVALU(2,1)=3
30226      NCVALU(3,1)=2
30227      NCVALU(4,1)=2
30228      IVALUE(1,4)='Accept H0'
30229      IVALUE(2,4)='Accept H0'
30230      IVALUE(3,4)='Accept H0'
30231      IVALUE(4,4)='Accept H0'
30232      NCVALU(1,4)=9
30233      NCVALU(2,4)=9
30234      NCVALU(3,4)=9
30235      NCVALU(4,4)=9
30236      IF(STATV1.LT.CV10 .OR. STATV1.GT.CV90)IVALUE(1,4)='Reject H0'
30237      IF(STATV1.LT.CV05 .OR. STATV1.GT.CV95)IVALUE(2,4)='Reject H0'
30238      IF(STATV1.LT.CV02 .OR. STATV1.GT.CV98)IVALUE(3,4)='Reject H0'
30239      IF(STATV1.LT.CV01 .OR. STATV1.GT.CV99)IVALUE(4,4)='Reject H0'
30240      AMAT(1,2)=RND(CV10,3)
30241      AMAT(1,3)=RND(CV90,3)
30242      AMAT(2,2)=RND(CV05,3)
30243      AMAT(2,3)=RND(CV95,3)
30244      AMAT(3,2)=RND(CV02,3)
30245      AMAT(3,3)=RND(CV98,3)
30246      AMAT(4,2)=RND(CV01,3)
30247      AMAT(4,3)=RND(CV99,3)
30248C
30249      IWHTML(1)=150
30250      IWHTML(2)=150
30251      IWHTML(3)=150
30252      IWHTML(4)=150
30253      IWRTF(1)=1500
30254      IWRTF(2)=IWRTF(1)+2000
30255      IWRTF(3)=IWRTF(2)+2000
30256      IWRTF(4)=IWRTF(3)+2000
30257      IFRST=.FALSE.
30258      ILAST=.TRUE.
30259C
30260      ISTEPN='42E'
30261      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CSR2')
30262     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30263C
30264      CALL DPDTA4(ITITL9,NCTIT9,
30265     1            ITITLE,NCTITL,ITITL2,NCTIT2,
30266     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
30267     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW,
30268     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
30269     1            ICAPSW,ICAPTY,IFRST,ILAST,
30270     1            ISUBRO,IBUGA3,IERROR)
30271C
30272      ISTEPN='42F'
30273      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CSR2')
30274     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30275C
30276      ITITLE='Mean Nearest Neighbors Test'
30277      NCTITL=27
30278      ITITLZ='for Complete Spatial Randomness'
30279      NCTITZ=31
30280C
30281      ICNT=1
30282      ITEXT(ICNT)=' '
30283      NCTEXT(ICNT)=0
30284      AVALUE(ICNT)=0.0
30285      IDIGIT(ICNT)=-1
30286      ICNT=ICNT+1
30287      ITEXT(ICNT)='First Response Variable: '
30288      WRITE(ITEXT(ICNT)(26:29),'(A4)')IVARID(1:4)
30289      WRITE(ITEXT(ICNT)(30:35),'(A4)')IVARI2(1:4)
30290      NCTEXT(ICNT)=35
30291      AVALUE(ICNT)=0.0
30292      IDIGIT(ICNT)=-1
30293      ICNT=ICNT+1
30294      ITEXT(ICNT)='Second Response Variable: '
30295      WRITE(ITEXT(ICNT)(27:30),'(A4)')IVARI3(1:4)
30296      WRITE(ITEXT(ICNT)(31:36),'(A4)')IVARI4(1:4)
30297      NCTEXT(ICNT)=36
30298      AVALUE(ICNT)=0.0
30299      IDIGIT(ICNT)=-1
30300C
30301      ICNT=ICNT+1
30302      ITEXT(ICNT)=' '
30303      NCTEXT(ICNT)=1
30304      AVALUE(ICNT)=0.0
30305      IDIGIT(ICNT)=-1
30306C
30307      ICNT=ICNT+1
30308      ITEXT(ICNT)='H0: Complete Spatial Randomness'
30309      NCTEXT(ICNT)=31
30310      AVALUE(ICNT)=0.0
30311      IDIGIT(ICNT)=-1
30312      ICNT=ICNT+1
30313      ITEXT(ICNT)='Ha: Not Complete Spatial Randomness'
30314      NCTEXT(ICNT)=35
30315      AVALUE(ICNT)=0.0
30316      IDIGIT(ICNT)=-1
30317C
30318      ICNT=ICNT+1
30319      ITEXT(ICNT)=' '
30320      NCTEXT(ICNT)=1
30321      AVALUE(ICNT)=0.0
30322      IDIGIT(ICNT)=-1
30323      ICNT=ICNT+1
30324      ITEXT(ICNT)='Number of Observations:'
30325      NCTEXT(ICNT)=23
30326      AVALUE(ICNT)=REAL(N)
30327      IDIGIT(ICNT)=0
30328      ICNT=ICNT+1
30329      ITEXT(ICNT)=' '
30330      NCTEXT(ICNT)=1
30331      AVALUE(ICNT)=0.0
30332      IDIGIT(ICNT)=-1
30333      ICNT=ICNT+1
30334      ITEXT(ICNT)='Test Statistic Value:'
30335      NCTEXT(ICNT)=21
30336      AVALUE(ICNT)=STATV2
30337      IDIGIT(ICNT)=NUMDIG
30338      ICNT=ICNT+1
30339      ITEXT(ICNT)='Test Statistic CDF:'
30340      NCTEXT(ICNT)=19
30341      AVALUE(ICNT)=STATC2
30342      IDIGIT(ICNT)=NUMDIG
30343      ICNT=ICNT+1
30344      ITEXT(ICNT)='Test Statistic P-Value:'
30345      NCTEXT(ICNT)=23
30346      AVALUE(ICNT)=PVAL2
30347      IDIGIT(ICNT)=NUMDIG
30348C
30349      NUMROW=ICNT
30350      DO4310I=1,NUMROW
30351        NTOT(I)=15
30352 4310 CONTINUE
30353C
30354      IFRST=.TRUE.
30355      ILAST=.TRUE.
30356C
30357      ISTEPN='42A'
30358      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CSR2')
30359     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30360C
30361      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
30362     1            AVALUE,IDIGIT,
30363     1            NTOT,NUMROW,
30364     1            ICAPSW,ICAPTY,ILAST,IFRST,
30365     1            ISUBRO,IBUGA3,IERROR)
30366C
30367      ISTEPN='43D'
30368      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CSR2')
30369     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30370C
30371      CDF1=CUT90
30372      CDF2=CUT95
30373      CDF3=CUT975
30374      CDF4=CUT99
30375C
30376      ITITLE='Two-Tailed Test for Complete Spatial Randomness'
30377      NCTITL=47
30378      ITITL9='H0: Complete Spatial Randomness'
30379      NCTIT9=31
30380C
30381      DO4330J=1,5
30382        DO4340I=1,3
30383          ITITL2(I,J)=' '
30384          NCTIT2(I,J)=0
30385 4340   CONTINUE
30386 4330 CONTINUE
30387C
30388      ITITL2(2,1)='Significance'
30389      NCTIT2(2,1)=12
30390      ITITL2(3,1)='Level'
30391      NCTIT2(3,1)=5
30392C
30393      ITITL2(2,2)='Test '
30394      NCTIT2(2,2)=4
30395      ITITL2(3,2)='Statistic'
30396      NCTIT2(3,2)=9
30397C
30398      ITITL2(2,3)='Critical'
30399      NCTIT2(2,3)=8
30400      ITITL2(3,3)='Value (+/-)'
30401      NCTIT2(3,3)=11
30402C
30403      ITITL2(1,4)='Null'
30404      NCTIT2(1,4)=4
30405      ITITL2(2,4)='Hypothesis'
30406      NCTIT2(2,4)=10
30407      ITITL2(3,4)='Conclusion'
30408      NCTIT2(3,4)=10
30409C
30410      NMAX=0
30411      NUMCOL=4
30412      DO4350I=1,NUMCOL
30413        VALIGN(I)='b'
30414        ALIGN(I)='r'
30415        NTOT(I)=15
30416        NMAX=NMAX+NTOT(I)
30417        ITYPCO(I)='NUME'
30418        IDIGIT(I)=NUMDIG
30419        IF(I.EQ.1 .OR. I.EQ.4)THEN
30420          ITYPCO(I)='ALPH'
30421        ENDIF
30422 4350 CONTINUE
30423C
30424      IWHTML(1)=125
30425      IWHTML(2)=175
30426      IWHTML(3)=175
30427      IWHTML(4)=175
30428      IINC=1800
30429      IINC2=1400
30430      IWRTF(1)=IINC
30431      IWRTF(2)=IWRTF(1)+IINC
30432      IWRTF(3)=IWRTF(2)+IINC
30433      IWRTF(4)=IWRTF(3)+IINC
30434C
30435      DO4360J=1,NUMALP
30436C
30437        AMAT(J,2)=STATV2
30438        IF(J.EQ.1)THEN
30439          AMAT(J,3)=CUTU50
30440          IVALUE(J,1)='50%'
30441          NCVALU(J,1)=3
30442        ELSEIF(J.EQ.2)THEN
30443          AMAT(J,3)=CUTU75
30444          IVALUE(J,1)='75%'
30445          NCVALU(J,1)=3
30446        ELSEIF(J.EQ.3)THEN
30447          AMAT(J,3)=CUTU80
30448          IVALUE(J,1)='80%'
30449          NCVALU(J,1)=3
30450        ELSEIF(J.EQ.4)THEN
30451          AMAT(J,3)=CUTU90
30452          IVALUE(J,1)='90%'
30453          NCVALU(J,1)=3
30454        ELSEIF(J.EQ.5)THEN
30455          AMAT(J,3)=CUTU95
30456          IVALUE(J,1)='95%'
30457          NCVALU(J,1)=3
30458        ELSEIF(J.EQ.6)THEN
30459          AMAT(J,3)=CUTU99
30460          IVALUE(J,1)='99%'
30461          NCVALU(J,1)=3
30462        ELSEIF(J.EQ.7)THEN
30463          IVALUE(J,1)='99.9%'
30464          NCVALU(J,1)=5
30465          AMAT(J,3)=CTU999
30466        ENDIF
30467        IVALUE(J,4)(1:6)='REJECT'
30468        IF(ABS(STATV2).LT.AMAT(J,3))THEN
30469          IVALUE(J,4)(1:6)='ACCEPT'
30470        ENDIF
30471        NCVALU(J,4)=6
30472C
30473 4360 CONTINUE
30474C
30475      ICNT=NUMALP
30476      NUMLIN=3
30477      NUMCOL=4
30478      IFRST=.TRUE.
30479      ILAST=.TRUE.
30480      IFLAGS=.TRUE.
30481      IFLAGE=.TRUE.
30482      CALL DPDTA5(ITITLE,NCTITL,
30483     1            ITITL9,NCTIT9,ITITL2,NCTIT2,
30484     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
30485     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
30486     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
30487     1            ICAPSW,ICAPTY,IFRST,ILAST,
30488     1            IFLAGS,IFLAGE,
30489     1            ISUBRO,IBUGA3,IERROR)
30490C
30491      ISTEPN='44'
30492      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CSR2')
30493     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30494C
30495      DO4401JINDX=1,5
30496C
30497        CALL DPCSR5(X,Y,N,JINDX,TEMP1,
30498     1            STATZ1,STATZ2,STATCZ,PVALZ3,STATNZ,
30499     1            ISUBRO,IBUGA3,IERROR)
30500C
30501        STATV3(JINDX)=STATZ1
30502        STATV4(JINDX)=STATZ2
30503        STATC3(JINDX)=STATCZ
30504        STATP3(JINDX)=PVALZ3
30505        STATN3(JINDX)=STATNZ
30506C
30507        DO4440I=1,NUMALP
30508          PCONF=ALPHA(I)/100.0
30509          CDF=PCONF
30510          CDF=0.5+(PCONF/2.0)
30511          IDF=N-1
30512          CALL CHSPPF(CDF,IDF,PPF)
30513          AUPPER(I)=PPF
30514          CDF=1.0-CDF
30515          CALL CHSPPF(CDF,IDF,PPF)
30516          ALOWER(I)=PPF
30517 4440   CONTINUE
30518C
30519        CL50=ALOWER(1)
30520        CU50=AUPPER(1)
30521        CL75=ALOWER(2)
30522        CU75=AUPPER(2)
30523        CL80=ALOWER(3)
30524        CU80=AUPPER(3)
30525        CL90=ALOWER(4)
30526        CU90=AUPPER(4)
30527        CL95=ALOWER(5)
30528        CU95=AUPPER(5)
30529        CL99=ALOWER(6)
30530        CU99=AUPPER(6)
30531        CL999=ALOWER(7)
30532        CU999=AUPPER(7)
30533C
30534        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CSR2')THEN
30535          WRITE(ICOUT,4441)STATZ1,STATZ2,STATCZ,PVALZ3,STATNZ
30536 4441     FORMAT('STATZ1,STATZ2,STATCZ,PVALZ3,STATNZ = ',5G15.7)
30537          CALL DPWRST('XXX','BUG ')
30538          WRITE(ICOUT,4443)CL90,CU90,CL95,CU95,CL99,CU99
30539 4443     FORMAT('CL90,CU90,CL95,CU95,CL99,CU99=',6G15.7)
30540          CALL DPWRST('XXX','BUG ')
30541        ENDIF
30542C
30543        ITITLE='Pollard Statistic Test (index =  )'
30544        WRITE(ITITLE(33:33),'(I1)')JINDX
30545        NCTITL=34
30546        ITITLZ='for Complete Spatial Randomness'
30547        NCTITZ=31
30548C
30549        ICNT=1
30550        ITEXT(ICNT)=' '
30551        NCTEXT(ICNT)=0
30552        AVALUE(ICNT)=0.0
30553        IDIGIT(ICNT)=-1
30554        ICNT=ICNT+1
30555        ITEXT(ICNT)='First Response Variable: '
30556        WRITE(ITEXT(ICNT)(26:29),'(A4)')IVARID(1:4)
30557        WRITE(ITEXT(ICNT)(30:35),'(A4)')IVARI2(1:4)
30558        NCTEXT(ICNT)=35
30559        AVALUE(ICNT)=0.0
30560        IDIGIT(ICNT)=-1
30561        ICNT=ICNT+1
30562        ITEXT(ICNT)='Second Response Variable: '
30563        WRITE(ITEXT(ICNT)(27:30),'(A4)')IVARI3(1:4)
30564        WRITE(ITEXT(ICNT)(31:36),'(A4)')IVARI4(1:4)
30565        NCTEXT(ICNT)=36
30566        AVALUE(ICNT)=0.0
30567        IDIGIT(ICNT)=-1
30568C
30569        ICNT=ICNT+1
30570        ITEXT(ICNT)=' '
30571        NCTEXT(ICNT)=1
30572        AVALUE(ICNT)=0.0
30573        IDIGIT(ICNT)=-1
30574C
30575        ICNT=ICNT+1
30576        ITEXT(ICNT)='H0: Complete Spatial Randomness'
30577        NCTEXT(ICNT)=31
30578        AVALUE(ICNT)=0.0
30579        IDIGIT(ICNT)=-1
30580        ICNT=ICNT+1
30581        ITEXT(ICNT)='Ha: Not Complete Spatial Randomness'
30582        NCTEXT(ICNT)=35
30583        AVALUE(ICNT)=0.0
30584        IDIGIT(ICNT)=-1
30585C
30586        ICNT=ICNT+1
30587        ITEXT(ICNT)=' '
30588        NCTEXT(ICNT)=1
30589        AVALUE(ICNT)=0.0
30590        IDIGIT(ICNT)=-1
30591        ICNT=ICNT+1
30592        ITEXT(ICNT)='Number of Observations:'
30593        NCTEXT(ICNT)=23
30594        AVALUE(ICNT)=REAL(N)
30595        IDIGIT(ICNT)=0
30596        ICNT=ICNT+1
30597        ITEXT(ICNT)='Nearest Neighbor Index:'
30598        NCTEXT(ICNT)=24
30599        AVALUE(ICNT)=REAL(JINDX)
30600        IDIGIT(ICNT)=0
30601        ICNT=ICNT+1
30602        ITEXT(ICNT)=' '
30603        NCTEXT(ICNT)=1
30604        AVALUE(ICNT)=0.0
30605        IDIGIT(ICNT)=-1
30606        ICNT=ICNT+1
30607        ITEXT(ICNT)='Test Statistic Value:'
30608        NCTEXT(ICNT)=21
30609        AVALUE(ICNT)=STATZ1
30610        IDIGIT(ICNT)=NUMDIG
30611        ICNT=ICNT+1
30612        ITEXT(ICNT)='Adjusted Test Statistic Value:'
30613        NCTEXT(ICNT)=30
30614        AVALUE(ICNT)=STATZ2
30615        IDIGIT(ICNT)=NUMDIG
30616        ICNT=ICNT+1
30617        ITEXT(ICNT)='Test Statistic CDF:'
30618        NCTEXT(ICNT)=19
30619        AVALUE(ICNT)=STATC2
30620        IDIGIT(ICNT)=NUMDIG
30621        ICNT=ICNT+1
30622        ITEXT(ICNT)='Test Statistic P-Value:'
30623        NCTEXT(ICNT)=23
30624        AVALUE(ICNT)=PVAL2
30625        IDIGIT(ICNT)=NUMDIG
30626C
30627        NUMROW=ICNT
30628        DO4410I=1,NUMROW
30629          NTOT(I)=15
30630 4410   CONTINUE
30631C
30632        IFRST=.TRUE.
30633        ILAST=.TRUE.
30634C
30635        ISTEPN='44A'
30636        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CSR2')
30637     1     CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30638C
30639        CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
30640     1              AVALUE,IDIGIT,
30641     1              NTOT,NUMROW,
30642     1              ICAPSW,ICAPTY,ILAST,IFRST,
30643     1              ISUBRO,IBUGA3,IERROR)
30644C
30645        ISTEPN='44B'
30646        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CSR2')
30647     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30648C
30649        ITITLE='Two-Tailed Test for Complete Spatial Randomness'
30650        NCTITL=47
30651        ITITL9='H0: Complete Spatial Randomness'
30652        NCTIT9=31
30653C
30654        DO4450J=1,5
30655          DO4460I=1,3
30656            ITITL2(I,J)=' '
30657            NCTIT2(I,J)=0
30658 4460     CONTINUE
30659 4450   CONTINUE
30660C
30661        ITITL2(2,1)='Significance'
30662        NCTIT2(2,1)=12
30663        ITITL2(3,1)='Level'
30664        NCTIT2(3,1)=5
30665C
30666        ITITL2(2,2)='Test '
30667        NCTIT2(2,2)=4
30668        ITITL2(3,2)='Statistic'
30669        NCTIT2(3,2)=9
30670C
30671        ITITL2(1,3)='Lower'
30672        NCTIT2(1,3)=5
30673        ITITL2(2,3)='Critical'
30674        NCTIT2(2,3)=8
30675        ITITL2(3,3)='Value (+/-)'
30676        NCTIT2(3,3)=11
30677C
30678        ITITL2(1,4)='Upper'
30679        NCTIT2(1,4)=5
30680        ITITL2(2,4)='Critical'
30681        NCTIT2(2,4)=8
30682        ITITL2(3,4)='Value (+/-)'
30683        NCTIT2(3,4)=11
30684C
30685        ITITL2(1,5)='Null'
30686        NCTIT2(1,5)=4
30687        ITITL2(2,5)='Hypothesis'
30688        NCTIT2(2,5)=10
30689        ITITL2(3,5)='Conclusion'
30690        NCTIT2(3,5)=10
30691C
30692        NMAX=0
30693        NUMCOL=5
30694        DO4470I=1,NUMCOL
30695          VALIGN(I)='b'
30696          ALIGN(I)='r'
30697          NTOT(I)=15
30698          NMAX=NMAX+NTOT(I)
30699          ITYPCO(I)='NUME'
30700          IDIGIT(I)=NUMDIG
30701          IF(I.EQ.1 .OR. I.EQ.5)THEN
30702            ITYPCO(I)='ALPH'
30703          ENDIF
30704 4470   CONTINUE
30705C
30706        IWHTML(1)=125
30707        IWHTML(2)=175
30708        IWHTML(3)=175
30709        IWHTML(4)=175
30710        IWHTML(5)=175
30711        IINC=1800
30712        IINC2=1400
30713        IWRTF(1)=IINC
30714        IWRTF(2)=IWRTF(1)+IINC
30715        IWRTF(3)=IWRTF(2)+IINC
30716        IWRTF(4)=IWRTF(3)+IINC
30717        IWRTF(5)=IWRTF(4)+IINC
30718C
30719        DO4480J=1,NUMALP
30720C
30721          AMAT(J,2)=STATZ2
30722          IF(J.EQ.1)THEN
30723            IVALUE(J,1)='50%'
30724            NCVALU(J,1)=3
30725            AMAT(J,3)=CL50
30726            AMAT(J,4)=CU50
30727          ELSEIF(J.EQ.2)THEN
30728            IVALUE(J,1)='75%'
30729            NCVALU(J,1)=3
30730            AMAT(J,3)=CL75
30731            AMAT(J,4)=CU75
30732          ELSEIF(J.EQ.3)THEN
30733            IVALUE(J,1)='80%'
30734            NCVALU(J,1)=3
30735            AMAT(J,3)=CL80
30736            AMAT(J,4)=CU80
30737          ELSEIF(J.EQ.4)THEN
30738            IVALUE(J,1)='90%'
30739            NCVALU(J,1)=3
30740            AMAT(J,3)=CL90
30741            AMAT(J,4)=CU90
30742          ELSEIF(J.EQ.5)THEN
30743            IVALUE(J,1)='95%'
30744            NCVALU(J,1)=3
30745            AMAT(J,3)=CL95
30746            AMAT(J,4)=CU95
30747          ELSEIF(J.EQ.6)THEN
30748            IVALUE(J,1)='99%'
30749            NCVALU(J,1)=3
30750            AMAT(J,3)=CL99
30751            AMAT(J,4)=CU99
30752          ELSEIF(J.EQ.7)THEN
30753            IVALUE(J,1)='99.9%'
30754            NCVALU(J,1)=5
30755            AMAT(J,3)=CL999
30756            AMAT(J,4)=CU999
30757          ENDIF
30758          IVALUE(J,5)(1:6)='ACCEPT'
30759          IF(STATZ2.LT.AMAT(J,3) .OR. STATZ2.GT.AMAT(J,4))THEN
30760            IVALUE(J,5)(1:6)='REJECT'
30761          ENDIF
30762          NCVALU(J,5)=6
30763C
30764 4480   CONTINUE
30765C
30766        ICNT=NUMALP
30767        NUMLIN=3
30768        NUMCOL=5
30769        IFRST=.TRUE.
30770        ILAST=.TRUE.
30771        IFLAGS=.TRUE.
30772        IFLAGE=.TRUE.
30773        CALL DPDTA5(ITITLE,NCTITL,
30774     1            ITITL9,NCTIT9,ITITL2,NCTIT2,
30775     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
30776     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
30777     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
30778     1            ICAPSW,ICAPTY,IFRST,ILAST,
30779     1            IFLAGS,IFLAGE,
30780     1            ISUBRO,IBUGA3,IERROR)
30781C
30782 4401   CONTINUE
30783C
30784C               *****************
30785C               **  STEP 90--  **
30786C               **  EXIT       **
30787C               *****************
30788C
30789 9000 CONTINUE
30790      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CSR2')THEN
30791        WRITE(ICOUT,999)
30792        CALL DPWRST('XXX','WRIT')
30793        WRITE(ICOUT,9011)
30794 9011   FORMAT('***** AT THE END       OF DPCSR2--')
30795        CALL DPWRST('XXX','WRIT')
30796        WRITE(ICOUT,9012)N,IERROR
30797 9012   FORMAT('N,IERROR = ',I8,2X,A4)
30798        CALL DPWRST('XXX','WRIT')
30799        WRITE(ICOUT,9013)STATVA,STATCD,PVAL
30800 9013   FORMAT('STATVA,STATCD,PVAL = ',3G15.7)
30801        CALL DPWRST('XXX','WRIT')
30802      ENDIF
30803C
30804      RETURN
30805      END
30806      SUBROUTINE DPCSRA(XTEMP1,XTEMP2,MAXNXT,
30807     1                  ICAPSW,IFORSW,
30808     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
30809C
30810C     PURPOSE--PERFORM SEVERAL TESTS FOR COMPLETE SPATIAL RANDOMNESS.
30811C              CURRENTLY SUPPORTED TESTS ARE:
30812C
30813C                 1) BIVARIATE CRAMER VON MISES TEST
30814C                 2) MEAN NEAREST NEIGHBORS DISTANCE TEST
30815C                 3) POLLARD'S STATISTIC (FOR DISTANCE INDEX
30816C                    1, 2, 3, 4, 5)
30817C
30818C     EXAMPLE--COMPLETE SPATIAL RANDOMNESS TEST X Y
30819C     WRITTEN BY--ALAN HECKERT
30820C                 STATISTICAL ENGINEERING DIVISION
30821C                 INFORMATION TECHNOLOGY LABORATORY
30822C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
30823C                 GAITHERSBURG, MD 20899-8980
30824C                 PHONE--301-975-2899
30825C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
30826C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
30827C     LANGUAGE--ANSI FORTRAN (1977)
30828C     VERSION NUMBER--2014/01
30829C     ORIGINAL VERSION--JANUARY   2014.
30830C
30831C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
30832C
30833      CHARACTER*4 ICAPSW
30834      CHARACTER*4 IFORSW
30835      CHARACTER*4 IBUGA2
30836      CHARACTER*4 IBUGA3
30837      CHARACTER*4 IBUGQ
30838      CHARACTER*4 ISUBRO
30839      CHARACTER*4 IFOUND
30840      CHARACTER*4 IERROR
30841C
30842      CHARACTER*4 IHWUSE
30843      CHARACTER*4 MESSAG
30844C
30845      CHARACTER*4 IH
30846      CHARACTER*4 IH2
30847      CHARACTER*4 IHOST1
30848      CHARACTER*4 ISUBN0
30849C
30850      CHARACTER*4 ISUBN1
30851      CHARACTER*4 ISUBN2
30852      CHARACTER*4 ISTEPN
30853C
30854      CHARACTER*4 ICASAN
30855      CHARACTER*4 ICASE
30856      CHARACTER*4 IVARID
30857      CHARACTER*4 IVARI2
30858      CHARACTER*4 IVARI3
30859      CHARACTER*4 IVARI4
30860      CHARACTER*40 INAME
30861      PARAMETER (MAXSPN=30)
30862      CHARACTER*4 IVARN1(MAXSPN)
30863      CHARACTER*4 IVARN2(MAXSPN)
30864      CHARACTER*4 IVARTY(MAXSPN)
30865      REAL PVAR(MAXSPN)
30866      INTEGER ILIS(MAXSPN)
30867      INTEGER NRIGHT(MAXSPN)
30868      INTEGER ICOLR(MAXSPN)
30869C
30870C---------------------------------------------------------------------
30871C
30872      DIMENSION XTEMP1(*)
30873      DIMENSION XTEMP2(*)
30874C
30875C-----COMMON----------------------------------------------------------
30876C
30877      INCLUDE 'DPCOPA.INC'
30878      INCLUDE 'DPCOHK.INC'
30879      INCLUDE 'DPCOSU.INC'
30880      INCLUDE 'DPCODA.INC'
30881      INCLUDE 'DPCOST.INC'
30882C
30883C-----COMMON VARIABLES (GENERAL)--------------------------------------
30884C
30885      INCLUDE 'DPCOP2.INC'
30886C
30887C-----START POINT-----------------------------------------------------
30888C
30889      ISUBN1='DPCS'
30890      ISUBN2='RA  '
30891C
30892      MAXCP1=MAXCOL+1
30893      MAXCP2=MAXCOL+2
30894      MAXCP3=MAXCOL+3
30895      MAXCP4=MAXCOL+4
30896      MAXCP5=MAXCOL+5
30897      MAXCP6=MAXCOL+6
30898C
30899      IFOUND='YES'
30900      IERROR='NO'
30901C
30902C               *******************************************************
30903C               **  TREAT THE COMPLETE SPATIAL RANDOMNESS TEST CASE  **
30904C               *******************************************************
30905C
30906      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CSRA')THEN
30907        WRITE(ICOUT,999)
30908  999   FORMAT(1X)
30909        CALL DPWRST('XXX','BUG ')
30910        WRITE(ICOUT,51)
30911   51   FORMAT('***** AT THE BEGINNING OF DPCSRA--')
30912        CALL DPWRST('XXX','BUG ')
30913        WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ,ISUBRO,MAXNXT
30914   52   FORMAT('IBUGA2,IBUGA3,IBUGQ,ISUBRO,MAXNXT = ',4(A4,2X),I8)
30915        CALL DPWRST('XXX','BUG ')
30916      ENDIF
30917C
30918C               ****************************************
30919C               **  STEP 2--                          **
30920C               **  EXTRACT THE VARIABLE LIST         **
30921C               ****************************************
30922C
30923      ISTEPN='2'
30924      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CSRA')
30925     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30926C
30927      INAME='COMPLETE SPATIAL RANDOMNESS TEST'
30928      MINNA=1
30929      MAXNA=100
30930      MINN2=5
30931      IFLAGE=1
30932      IFLAGM=0
30933      MINNVA=2
30934      MAXNVA=2
30935      IFLAGP=0
30936      JMIN=1
30937      JMAX=NUMARG
30938C
30939      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
30940     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
30941     1            JMIN,JMAX,
30942     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
30943     1            IVARN1,IVARN2,IVARTY,PVAR,
30944     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
30945     1            MINNVA,MAXNVA,
30946     1            IFLAGM,IFLAGP,
30947     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
30948      IF(IERROR.EQ.'YES')GOTO9000
30949C
30950      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CSRA')THEN
30951        WRITE(ICOUT,999)
30952        CALL DPWRST('XXX','BUG ')
30953        WRITE(ICOUT,281)
30954  281   FORMAT('***** AFTER CALL DPPARS--')
30955        CALL DPWRST('XXX','BUG ')
30956        WRITE(ICOUT,282)NQ,NUMVAR
30957  282   FORMAT('NQ,NUMVAR = ',2I8)
30958        CALL DPWRST('XXX','BUG ')
30959        IF(NUMVAR.GT.0)THEN
30960          DO285I=1,NUMVAR
30961            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
30962     1                      ICOLR(I)
30963  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
30964     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
30965            CALL DPWRST('XXX','BUG ')
30966  285     CONTINUE
30967        ENDIF
30968      ENDIF
30969C
30970      IH='XMIN'
30971      IH2='    '
30972      IHWUSE='P'
30973      MESSAG='NO'
30974      CALL CHECKN(IH,IH2,IHWUSE,
30975     1            IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
30976     1            ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
30977      IF(IERROR.EQ.'NO')THEN
30978        XMIN=VALUE(ILOCP)
30979      ELSE
30980        XMIN=CPUMIN
30981      ENDIF
30982C
30983      IH='XMAX'
30984      IH2='    '
30985      IHWUSE='P'
30986      MESSAG='NO'
30987      CALL CHECKN(IH,IH2,IHWUSE,
30988     1            IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
30989     1            ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
30990      IF(IERROR.EQ.'NO')THEN
30991        XMAX=VALUE(ILOCP)
30992      ELSE
30993        XMAX=CPUMIN
30994      ENDIF
30995C
30996      IH='YMIN'
30997      IH2='    '
30998      IHWUSE='P'
30999      MESSAG='NO'
31000      CALL CHECKN(IH,IH2,IHWUSE,
31001     1            IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
31002     1            ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
31003      IF(IERROR.EQ.'NO')THEN
31004        YMIN=VALUE(ILOCP)
31005      ELSE
31006        YMIN=CPUMIN
31007      ENDIF
31008C
31009      IH='YMAX'
31010      IH2='    '
31011      IHWUSE='P'
31012      MESSAG='NO'
31013      CALL CHECKN(IH,IH2,IHWUSE,
31014     1            IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
31015     1            ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
31016      IF(IERROR.EQ.'NO')THEN
31017        YMAX=VALUE(ILOCP)
31018      ELSE
31019        YMAX=CPUMIN
31020      ENDIF
31021C
31022C               *****************************************
31023C               **  STEP 3A--                          **
31024C               **  CASE 1: TWO RESPONSE VARIABLES     **
31025C               *****************************************
31026C
31027      ISTEPN='3A'
31028      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CSRA')
31029     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31030C
31031      NUMVA2=2
31032      ICOL=1
31033      CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
31034     1            INAME,IVARN1,IVARN2,IVARTY,
31035     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
31036     1            MAXCOL,MAXCP1,MAXCP2,MAXCP3,
31037     1            MAXCP4,MAXCP5,MAXCP6,
31038     1            V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
31039     1            Y,X,Y,NS1,NS1,NS1,ICASE,
31040     1            IBUGA3,ISUBRO,IFOUND,IERROR)
31041      IF(IERROR.EQ.'YES')GOTO9000
31042C
31043C               *****************************************
31044C               **  STEP 52--                          **
31045C               **  PERFORM TEST                       **
31046C               *****************************************
31047C
31048      ISTEPN='52'
31049      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CSRA')THEN
31050        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31051        WRITE(ICOUT,999)
31052        CALL DPWRST('XXX','BUG ')
31053        WRITE(ICOUT,5211)
31054 5211   FORMAT('***** FROM DPCSRA, BEFORE CALL DPFTES--')
31055        CALL DPWRST('XXX','BUG ')
31056        WRITE(ICOUT,5212)I,J,NS1,NS2,MAXN
31057 5212   FORMAT('I,J,NS1,NS2,MAXN = ',5I8)
31058        CALL DPWRST('XXX','BUG ')
31059        DO5215II=1,MAX(NS1,NS2)
31060          WRITE(ICOUT,5216)II,Y(II),X(II)
31061 5216     FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
31062          CALL DPWRST('XXX','BUG ')
31063 5215   CONTINUE
31064      ENDIF
31065C
31066      IVARID=IVARN1(1)
31067      IVARI2=IVARN2(1)
31068      IVARI3=IVARN1(2)
31069      IVARI4=IVARN2(2)
31070C
31071      CALL DPCSR2(Y,X,NS1,ICASAN,MAXNXT,XTEMP1,XTEMP2,
31072     1            IVARID,IVARI2,IVARI3,IVARI4,
31073     1            XMIN,XMAX,YMIN,YMAX,
31074     1            ICAPSW,ICAPTY,IFORSW,
31075     1            STATV1,STATV2,STATC2,PVAL2,
31076     1            CV01,CV02,CV05,CV10,CV15,CV25,CV50,
31077     1            CV75,CV85,CV90,CV95,CV98,CV99,
31078     1            CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
31079     1            ISUBRO,IBUGA3,IERROR)
31080      IF(IERROR.EQ.'YES')GOTO9000
31081C
31082C               ***************************************
31083C               **  STEP 8C--                        **
31084C               **  UPDATE INTERNAL DATAPLOT TABLES  **
31085C               ***************************************
31086C
31087      ISTEPN='8C'
31088      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FTE2')
31089     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31090C
31091      IH='STAT'
31092      IH2='VAL1'
31093      VALUE0=STATV1
31094      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
31095     1            IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
31096     1            IANS,IWIDTH,IBUGA3,IERROR)
31097C
31098      IH='STAT'
31099      IH2='VAL2'
31100      VALUE0=STATV2
31101      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
31102     1            IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
31103     1            IANS,IWIDTH,IBUGA3,IERROR)
31104C
31105      IH='STAT'
31106      IH2='CDF2'
31107      VALUE0=STATC2
31108      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
31109     1            IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
31110     1            IANS,IWIDTH,IBUGA3,IERROR)
31111C
31112      IH='PVAL'
31113      IH2='UE2 '
31114      VALUE0=PVAL2
31115      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
31116     1            IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
31117     1            IANS,IWIDTH,IBUGA3,IERROR)
31118C
31119      IH='CV01'
31120      IH2='    '
31121      VALUE0=CV01
31122      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
31123     1            IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
31124     1            IANS,IWIDTH,IBUGA3,IERROR)
31125C
31126      IH='CV02'
31127      IH2='    '
31128      VALUE0=CV02
31129      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
31130     1            IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
31131     1            IANS,IWIDTH,IBUGA3,IERROR)
31132C
31133      IH='CV05'
31134      IH2='    '
31135      VALUE0=CV05
31136      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
31137     1            IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
31138     1            IANS,IWIDTH,IBUGA3,IERROR)
31139C
31140      IH='CV10'
31141      IH2='    '
31142      VALUE0=CV10
31143      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
31144     1            IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
31145     1            IANS,IWIDTH,IBUGA3,IERROR)
31146C
31147      IH='CV15'
31148      IH2='    '
31149      VALUE0=CV15
31150      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
31151     1            IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
31152     1            IANS,IWIDTH,IBUGA3,IERROR)
31153C
31154      IH='CV25'
31155      IH2='    '
31156      VALUE0=CV25
31157      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
31158     1            IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
31159     1            IANS,IWIDTH,IBUGA3,IERROR)
31160C
31161      IH='CV50'
31162      IH2='    '
31163      VALUE0=CV50
31164      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
31165     1            IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
31166     1            IANS,IWIDTH,IBUGA3,IERROR)
31167C
31168      IH='CV75'
31169      IH2='    '
31170      VALUE0=CV75
31171      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
31172     1            IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
31173     1            IANS,IWIDTH,IBUGA3,IERROR)
31174C
31175      IH='CV85'
31176      IH2='    '
31177      VALUE0=CV85
31178      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
31179     1            IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
31180     1            IANS,IWIDTH,IBUGA3,IERROR)
31181C
31182      IH='CV90'
31183      IH2='    '
31184      VALUE0=CV90
31185      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
31186     1            IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
31187     1            IANS,IWIDTH,IBUGA3,IERROR)
31188C
31189      IH='CV95'
31190      IH2='    '
31191      VALUE0=CV95
31192      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
31193     1            IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
31194     1            IANS,IWIDTH,IBUGA3,IERROR)
31195C
31196      IH='CV98'
31197      IH2='    '
31198      VALUE0=CV98
31199      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
31200     1            IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
31201     1            IANS,IWIDTH,IBUGA3,IERROR)
31202C
31203      IH='CV99'
31204      IH2='    '
31205      VALUE0=CV99
31206      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
31207     1            IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
31208     1            IANS,IWIDTH,IBUGA3,IERROR)
31209C
31210C               *****************
31211C               **  STEP 90--  **
31212C               **  EXIT       **
31213C               *****************
31214C
31215 9000 CONTINUE
31216      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CSRA')THEN
31217        WRITE(ICOUT,999)
31218        CALL DPWRST('XXX','BUG ')
31219        WRITE(ICOUT,9011)
31220 9011   FORMAT('***** AT THE END       OF DPCSRA--')
31221        CALL DPWRST('XXX','BUG ')
31222        WRITE(ICOUT,9016)IFOUND,IERROR
31223 9016   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
31224        CALL DPWRST('XXX','BUG ')
31225      ENDIF
31226C
31227      RETURN
31228      END
31229      SUBROUTINE DPCSR3(X,Y,N,U,V,
31230     1                  XMIN,XMAX,YMIN,YMAX,
31231     1                  STATVA,
31232     1                  CV01,CV02,CV05,CV10,CV15,CV25,CV50,
31233     1                  CV75,CV85,CV90,CV95,CV98,CV99,
31234     1                  ISUBRO,IBUGA3,IERROR)
31235C
31236C     PURPOSE--THIS SUBROUTINE COMPUTES THE BIVARIATE CRAMER
31237C              VON-MISES TEST (DESCRIBED BY DALE ZIMMERMAN)
31238C              FOR COMPLETE SPATIAL RANDOMNESS.
31239C
31240C              FOR THIS TEST, WE HAVE A SET OF N POINTS (X,Y).  WE
31241C              ALSO NEED TO DEFINE THE COORDINATES OF THE ENCLOSING
31242C              RECTANGLE (IF THESE NOT GIVEN, THEY WILL BE BASED ON
31243C              THE DATA MINIMUM AND MAXIMUMS).
31244C
31245C              THE TEST STATISTIC IS
31246C
31247C                    WBAR^2 = (1/(4*N))*SUM[i=1 to N]
31248C                             [SUM[j=1 to N][(1 - |u(i) - u(j)|)*
31249C                             (1 - |v(i) - v(j)|)]] -
31250C                             0.5*SUM[i=1 to N][(u(i)**2 - u(i) - 0.5)*
31251C                             (v(i)**2 - v(i) - 0.5)] + N/9
31252C
31253C                 WHERE
31254C
31255C                    u(i) = X(i)/XMAX
31256C                    v(i) = Y(i)/YMAX
31257C
31258C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
31259C                                OBSERVATIONS FOR THE FIRST RESPONSE
31260C                                VARIABLE.
31261C                     --Y      = THE SINGLE PRECISION VECTOR OF
31262C                                OBSERVATIONS FOR THE SECOND RESPONSE
31263C                                VARIABLE.
31264C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
31265C                                IN THE VECTOR Y.
31266C                     --ICASE  = A CHARACTER VARIABLE THAT SPECIFIES
31267C                                WHETHER GROUPED OR UNGROUPED DATA IS
31268C                                BEING GIVEN.
31269C     OUTPUT ARGUMENTS--STATVA = THE SINGLE PRECISION VALUE OF THE
31270C                                COMPUTED STATISTIC.
31271C     REFERENCE--DALE ZIMMERMAN (1993), "A BIVARIATE CRAMER-VON MISES
31272C                TYPE OF TEST FOR SPATIAL RANDONNESS", JOURNAL OF
31273C                THE ROYAL STATISTICAL SOCIETY, SERIES C (APPLIED
31274C                STATISTICS, VOL. 42, NO. 1, PP. 43-54.
31275C                LONDON.
31276C     OTHER DATAPAC   SUBROUTINES NEEDED--LININ3
31277C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
31278C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
31279C     LANGUAGE--ANSI FORTRAN (1977)
31280C     WRITTEN BY--ALAN HECKERT
31281C                 STATISTICAL ENGINEERING DIVISION
31282C                 INFORMATION TECHNOLOGY LABORATORY
31283C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
31284C                 GAITHERSBURG, MD 20899-8980
31285C                 PHONE--301-975-2899
31286C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
31287C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
31288C     LANGUAGE--ANSI FORTRAN (1977)
31289C     VERSION NUMBER--2013.12
31290C     ORIGINAL VERSION--DECEMBER  2013.
31291C
31292C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
31293C
31294      CHARACTER*4 ISUBRO
31295      CHARACTER*4 IBUGA3
31296      CHARACTER*4 IERROR
31297C
31298      CHARACTER*4 IWRITE
31299      CHARACTER*4 ISUBN1
31300      CHARACTER*4 ISUBN2
31301C
31302C---------------------------------------------------------------------
31303C
31304      DIMENSION Y(*)
31305      DIMENSION X(*)
31306      DIMENSION U(*)
31307      DIMENSION V(*)
31308C
31309      DOUBLE PRECISION DSUM1
31310      DOUBLE PRECISION DSUM2
31311      DOUBLE PRECISION DTERM1
31312      DOUBLE PRECISION DTERM2
31313      DOUBLE PRECISION DTERM3
31314      DOUBLE PRECISION DTERM4
31315      DOUBLE PRECISION DUI
31316      DOUBLE PRECISION DUJ
31317      DOUBLE PRECISION DVI
31318      DOUBLE PRECISION DVJ
31319      DOUBLE PRECISION DN
31320      DOUBLE PRECISION DSTAT
31321C
31322      REAL CRAMCV(13,5)
31323      REAL LININ3
31324C
31325C---------------------------------------------------------------------
31326C
31327      INCLUDE 'DPCOP2.INC'
31328C
31329      DATA ((CRAMCV(I,J),J=1,5),I=1,13)/
31330     1 0.052,  0.049,  0.047,  0.046,  0.043,
31331     1 0.056,  0.053,  0.052,  0.051,  0.049,
31332     1 0.063,  0.061,  0.060,  0.059,  0.057,
31333     1 0.071,  0.069,  0.068,  0.067,  0.066,
31334     1 0.078,  0.077,  0.076,  0.075,  0.075,
31335     1 0.091,  0.090,  0.089,  0.088,  0.088,
31336     1 0.122,  0.121,  0.122,  0.121,  0.122,
31337     1 0.170,  0.169,  0.171,  0.170,  0.171,
31338     1 0.203,  0.204,  0.204,  0.204,  0.206,
31339     1 0.229,  0.229,  0.232,  0.232,  0.234,
31340     1 0.273,  0.273,  0.281,  0.280,  0.281,
31341     1 0.326,  0.332,  0.341,  0.338,  0.342,
31342     1 0.360,  0.372,  0.385,  0.392,  0.389/
31343C
31344C-----START POINT-----------------------------------------------------
31345C
31346      ISUBN1='DPCS'
31347      ISUBN2='R3  '
31348      IWRITE='OFF'
31349      IERROR='NO'
31350C
31351      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CSR3')THEN
31352        WRITE(ICOUT,999)
31353  999   FORMAT(1X)
31354        CALL DPWRST('XXX','BUG ')
31355        WRITE(ICOUT,51)
31356   51   FORMAT('***** AT THE BEGINNING OF DPCSR3--')
31357        CALL DPWRST('XXX','BUG ')
31358        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
31359   52   FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8)
31360        CALL DPWRST('XXX','BUG ')
31361        DO55I=1,N
31362          WRITE(ICOUT,56)I,Y(I),X(I)
31363   56     FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
31364          CALL DPWRST('XXX','BUG ')
31365   55   CONTINUE
31366      ENDIF
31367C
31368      STATVA=CPUMIN
31369C
31370C               *******************************************
31371C               **  CRAMER-VON MISES TEST                **
31372C               *******************************************
31373C
31374      IF(N.LE.4)THEN
31375        WRITE(ICOUT,999)
31376        CALL DPWRST('XXX','BUG ')
31377        WRITE(ICOUT,111)
31378  111   FORMAT('***** ERROR IN COMPLETE SPATIAL RANDOMNESS TEST--')
31379        CALL DPWRST('XXX','BUG ')
31380        WRITE(ICOUT,112)
31381  112   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ',
31382     1         'VARIABLE IS LESS THAN FOUR.')
31383        CALL DPWRST('XXX','BUG ')
31384        WRITE(ICOUT,117)N
31385  117   FORMAT('      THE NUMBER OF OBSERVATIONS = ',I8)
31386        CALL DPWRST('XXX','BUG ')
31387        IERROR='YES'
31388        GOTO9000
31389      ENDIF
31390C
31391C               ********************************************
31392C               **  STEP 2--                              **
31393C               **  CHECK THAT THE POINTS LIE IN THE      **
31394C               **  RECTANGLE AND DEFINE LOWER LEFT       **
31395C               **  CORNER AT (0,0).                      **
31396C               ********************************************
31397C
31398      CALL MINIM(Y,N,IWRITE,YMIND,IBUGA3,IERROR)
31399      CALL MAXIM(Y,N,IWRITE,YMAXD,IBUGA3,IERROR)
31400      CALL MINIM(X,N,IWRITE,XMIND,IBUGA3,IERROR)
31401      CALL MAXIM(X,N,IWRITE,XMAXD,IBUGA3,IERROR)
31402C
31403      IF(YMIN.EQ.CPUMIN)THEN
31404        IF(YMIND.GE.0.0)THEN
31405          YMIN=0.0
31406        ELSE
31407          YMIN=YMIND
31408        ENDIF
31409      ELSE
31410        IF(YMIND.LT.YMIN)THEN
31411          YMIN=YMIND
31412        ENDIF
31413      ENDIF
31414C
31415      IF(YMAX.EQ.CPUMIN)THEN
31416        YMAX=YMAXD
31417      ELSE
31418        IF(YMAXD.GT.YMAX)THEN
31419          YMAX=YMAXD
31420        ENDIF
31421      ENDIF
31422C
31423      IF(XMIN.EQ.CPUMIN)THEN
31424        IF(XMIND.GE.0.0)THEN
31425          XMIN=0.0
31426        ELSE
31427          XMIN=XMIND
31428        ENDIF
31429      ELSE
31430        IF(XMIND.LT.XMIN)THEN
31431          XMIN=XMIND
31432        ENDIF
31433      ENDIF
31434C
31435      IF(XMAX.EQ.CPUMIN)THEN
31436        XMAX=XMAXD
31437      ELSE
31438        IF(XMAXD.GT.XMAX)THEN
31439          XMAX=XMAXD
31440        ENDIF
31441      ENDIF
31442C
31443      IF(XMIN.NE.0.0)XMAX=XMAX-XMIN
31444      IF(YMIN.NE.0.0)YMAX=YMAX-YMIN
31445      DO200I=1,N
31446        U(I)=(X(I) - XMIN)/XMAX
31447        V(I)=(Y(I) - YMIN)/YMAX
31448  200 CONTINUE
31449C
31450      DN=DBLE(N)
31451      DTERM1=1.0D0/(4.0D0*DN)
31452      DTERM2=DN/9.0D0
31453      DSUM1=0.0D0
31454      DSUM2=0.0D0
31455      DSUM3=0.0D0
31456C
31457      DO210I=1,N
31458        DU=DBLE(U(I))
31459        DV=DBLE(V(I))
31460        DTERM3=DU**2 - DU - 0.5D0
31461        DTERM4=DV**2 - DV - 0.5D0
31462        DSUM1=DSUM1 + DTERM3*DTERM4
31463  210 CONTINUE
31464C
31465      DO220I=1,N
31466        DUI=DBLE(U(I))
31467        DVI=DBLE(V(I))
31468        DO230J=1,N
31469          DUJ=DBLE(U(J))
31470          DVJ=DBLE(V(J))
31471          DTERM3=1.0D0 - DABS(DUI - DUJ)
31472          DTERM4=1.0D0 - DABS(DVI - DVJ)
31473          DSUM2=DSUM2 + DTERM3*DTERM4
31474  230   CONTINUE
31475  220 CONTINUE
31476C
31477      DSTAT=DTERM1*DSUM2 - 0.5D0*DSUM1 + DTERM2
31478      STATVA=REAL(DSTAT)
31479C
31480      IF(N.EQ.5)THEN
31481        CV01=CRAMCV(1,1)
31482        CV02=CRAMCV(2,1)
31483        CV05=CRAMCV(3,1)
31484        CV10=CRAMCV(4,1)
31485        CV15=CRAMCV(5,1)
31486        CV25=CRAMCV(6,1)
31487        CV50=CRAMCV(7,1)
31488        CV75=CRAMCV(8,1)
31489        CV85=CRAMCV(9,1)
31490        CV90=CRAMCV(10,1)
31491        CV95=CRAMCV(11,1)
31492        CV98=CRAMCV(12,1)
31493        CV99=CRAMCV(13,1)
31494      ELSEIF(N.GE.6 .AND. N.LE.9)THEN
31495        AN1=5.0
31496        AN2=10.0
31497        AN=REAL(N)
31498        CV01=LININ3(AN1,CRAMCV(1,1),AN2,CRAMCV(1,2),AN,
31499     1       IBUGA3,ISUBRO,IERROR)
31500        CV02=LININ3(AN1,CRAMCV(2,1),AN2,CRAMCV(2,2),AN,
31501     1       IBUGA3,ISUBRO,IERROR)
31502        CV05=LININ3(AN1,CRAMCV(3,1),AN2,CRAMCV(3,2),AN,
31503     1       IBUGA3,ISUBRO,IERROR)
31504        CV10=LININ3(AN1,CRAMCV(4,1),AN2,CRAMCV(4,2),AN,
31505     1       IBUGA3,ISUBRO,IERROR)
31506        CV15=LININ3(AN1,CRAMCV(5,1),AN2,CRAMCV(5,2),AN,
31507     1       IBUGA3,ISUBRO,IERROR)
31508        CV25=LININ3(AN1,CRAMCV(6,1),AN2,CRAMCV(6,2),AN,
31509     1       IBUGA3,ISUBRO,IERROR)
31510        CV50=LININ3(AN1,CRAMCV(7,1),AN2,CRAMCV(7,2),AN,
31511     1       IBUGA3,ISUBRO,IERROR)
31512        CV75=LININ3(AN1,CRAMCV(8,1),AN2,CRAMCV(8,2),AN,
31513     1       IBUGA3,ISUBRO,IERROR)
31514        CV85=LININ3(AN1,CRAMCV(9,1),AN2,CRAMCV(9,2),AN,
31515     1       IBUGA3,ISUBRO,IERROR)
31516        CV90=LININ3(AN1,CRAMCV(10,1),AN2,CRAMCV(10,2),AN,
31517     1       IBUGA3,ISUBRO,IERROR)
31518        CV95=LININ3(AN1,CRAMCV(11,1),AN2,CRAMCV(11,2),AN,
31519     1       IBUGA3,ISUBRO,IERROR)
31520        CV98=LININ3(AN1,CRAMCV(12,1),AN2,CRAMCV(12,2),AN,
31521     1       IBUGA3,ISUBRO,IERROR)
31522        CV99=LININ3(AN1,CRAMCV(13,1),AN2,CRAMCV(13,2),AN,
31523     1       IBUGA3,ISUBRO,IERROR)
31524      ELSEIF(N.EQ.10)THEN
31525        CV01=CRAMCV(1,2)
31526        CV02=CRAMCV(2,2)
31527        CV05=CRAMCV(3,2)
31528        CV10=CRAMCV(4,2)
31529        CV15=CRAMCV(5,2)
31530        CV25=CRAMCV(6,2)
31531        CV50=CRAMCV(7,2)
31532        CV75=CRAMCV(8,2)
31533        CV85=CRAMCV(9,2)
31534        CV90=CRAMCV(10,2)
31535        CV95=CRAMCV(11,2)
31536        CV98=CRAMCV(12,2)
31537        CV99=CRAMCV(13,2)
31538      ELSEIF(N.GE.11 .AND. N.LE.14)THEN
31539        AN1=10.0
31540        AN2=15.0
31541        AN=REAL(N)
31542        CV01=LININ3(AN1,CRAMCV(1,2),AN2,CRAMCV(1,3),AN,
31543     1       IBUGA3,ISUBRO,IERROR)
31544        CV02=LININ3(AN1,CRAMCV(2,2),AN2,CRAMCV(2,3),AN,
31545     1       IBUGA3,ISUBRO,IERROR)
31546        CV05=LININ3(AN1,CRAMCV(3,2),AN2,CRAMCV(3,3),AN,
31547     1       IBUGA3,ISUBRO,IERROR)
31548        CV10=LININ3(AN1,CRAMCV(4,2),AN2,CRAMCV(4,3),AN,
31549     1       IBUGA3,ISUBRO,IERROR)
31550        CV15=LININ3(AN1,CRAMCV(5,2),AN2,CRAMCV(5,3),AN,
31551     1       IBUGA3,ISUBRO,IERROR)
31552        CV25=LININ3(AN1,CRAMCV(6,2),AN2,CRAMCV(6,3),AN,
31553     1       IBUGA3,ISUBRO,IERROR)
31554        CV50=LININ3(AN1,CRAMCV(7,2),AN2,CRAMCV(7,3),AN,
31555     1       IBUGA3,ISUBRO,IERROR)
31556        CV75=LININ3(AN1,CRAMCV(8,2),AN2,CRAMCV(8,3),AN,
31557     1       IBUGA3,ISUBRO,IERROR)
31558        CV85=LININ3(AN1,CRAMCV(9,2),AN2,CRAMCV(9,3),AN,
31559     1       IBUGA3,ISUBRO,IERROR)
31560        CV90=LININ3(AN1,CRAMCV(10,2),AN2,CRAMCV(10,3),AN,
31561     1       IBUGA3,ISUBRO,IERROR)
31562        CV95=LININ3(AN1,CRAMCV(11,2),AN2,CRAMCV(11,3),AN,
31563     1       IBUGA3,ISUBRO,IERROR)
31564        CV98=LININ3(AN1,CRAMCV(12,2),AN2,CRAMCV(12,3),AN,
31565     1       IBUGA3,ISUBRO,IERROR)
31566        CV99=LININ3(AN1,CRAMCV(13,2),AN2,CRAMCV(13,3),AN,
31567     1       IBUGA3,ISUBRO,IERROR)
31568      ELSEIF(N.EQ.15)THEN
31569        CV01=CRAMCV(1,3)
31570        CV02=CRAMCV(2,3)
31571        CV05=CRAMCV(3,3)
31572        CV10=CRAMCV(4,3)
31573        CV15=CRAMCV(5,3)
31574        CV25=CRAMCV(6,3)
31575        CV50=CRAMCV(7,3)
31576        CV75=CRAMCV(8,3)
31577        CV85=CRAMCV(9,3)
31578        CV90=CRAMCV(10,3)
31579        CV95=CRAMCV(11,3)
31580        CV98=CRAMCV(12,3)
31581        CV99=CRAMCV(13,3)
31582      ELSEIF(N.GE.16 .AND. N.LE.19)THEN
31583        AN1=15.0
31584        AN2=20.0
31585        AN=REAL(N)
31586        CV01=LININ3(AN1,CRAMCV(1,3),AN2,CRAMCV(1,4),AN,
31587     1       IBUGA3,ISUBRO,IERROR)
31588        CV02=LININ3(AN1,CRAMCV(2,3),AN2,CRAMCV(2,4),AN,
31589     1       IBUGA3,ISUBRO,IERROR)
31590        CV05=LININ3(AN1,CRAMCV(3,3),AN2,CRAMCV(3,4),AN,
31591     1       IBUGA3,ISUBRO,IERROR)
31592        CV10=LININ3(AN1,CRAMCV(4,3),AN2,CRAMCV(4,4),AN,
31593     1       IBUGA3,ISUBRO,IERROR)
31594        CV15=LININ3(AN1,CRAMCV(5,3),AN2,CRAMCV(5,4),AN,
31595     1       IBUGA3,ISUBRO,IERROR)
31596        CV25=LININ3(AN1,CRAMCV(6,3),AN2,CRAMCV(6,4),AN,
31597     1       IBUGA3,ISUBRO,IERROR)
31598        CV50=LININ3(AN1,CRAMCV(7,3),AN2,CRAMCV(7,4),AN,
31599     1       IBUGA3,ISUBRO,IERROR)
31600        CV75=LININ3(AN1,CRAMCV(8,3),AN2,CRAMCV(8,4),AN,
31601     1       IBUGA3,ISUBRO,IERROR)
31602        CV85=LININ3(AN1,CRAMCV(9,3),AN2,CRAMCV(9,4),AN,
31603     1       IBUGA3,ISUBRO,IERROR)
31604        CV90=LININ3(AN1,CRAMCV(10,3),AN2,CRAMCV(10,4),AN,
31605     1       IBUGA3,ISUBRO,IERROR)
31606        CV95=LININ3(AN1,CRAMCV(11,3),AN2,CRAMCV(11,4),AN,
31607     1       IBUGA3,ISUBRO,IERROR)
31608        CV98=LININ3(AN1,CRAMCV(12,3),AN2,CRAMCV(12,4),AN,
31609     1       IBUGA3,ISUBRO,IERROR)
31610        CV99=LININ3(AN1,CRAMCV(13,3),AN2,CRAMCV(13,4),AN,
31611     1       IBUGA3,ISUBRO,IERROR)
31612      ELSEIF(N.EQ.20)THEN
31613        CV01=CRAMCV(1,4)
31614        CV02=CRAMCV(2,4)
31615        CV05=CRAMCV(3,4)
31616        CV10=CRAMCV(4,4)
31617        CV15=CRAMCV(5,4)
31618        CV25=CRAMCV(6,4)
31619        CV50=CRAMCV(7,4)
31620        CV75=CRAMCV(8,4)
31621        CV85=CRAMCV(9,4)
31622        CV90=CRAMCV(10,4)
31623        CV95=CRAMCV(11,4)
31624        CV98=CRAMCV(12,4)
31625        CV99=CRAMCV(13,4)
31626      ELSE
31627        CV01=CRAMCV(1,5)
31628        CV02=CRAMCV(2,5)
31629        CV05=CRAMCV(3,5)
31630        CV10=CRAMCV(4,5)
31631        CV15=CRAMCV(5,5)
31632        CV25=CRAMCV(6,5)
31633        CV50=CRAMCV(7,5)
31634        CV75=CRAMCV(8,5)
31635        CV85=CRAMCV(9,5)
31636        CV90=CRAMCV(10,5)
31637        CV95=CRAMCV(11,5)
31638        CV98=CRAMCV(12,5)
31639        CV99=CRAMCV(13,5)
31640      ENDIF
31641C
31642C               *****************
31643C               **  STEP 90--  **
31644C               **  EXIT.      **
31645C               *****************
31646C
31647 9000 CONTINUE
31648C
31649      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CSR3')THEN
31650        WRITE(ICOUT,999)
31651        CALL DPWRST('XXX','BUG ')
31652        WRITE(ICOUT,9011)
31653 9011   FORMAT('***** AT THE END       OF DPCSR3--')
31654        CALL DPWRST('XXX','BUG ')
31655        WRITE(ICOUT,9015)STATVA,IERROR
31656 9015   FORMAT('STATVA,IERROR = ',G15.7,2X,A4)
31657        CALL DPWRST('XXX','BUG ')
31658        WRITE(ICOUT,9016)CV01,CV05,CV10,CV90,CV95,CV99
31659 9016   FORMAT('CV01,CV05,CV10,CV90,CV95,CV99=',6G15.7)
31660        CALL DPWRST('XXX','BUG ')
31661      ENDIF
31662C
31663      RETURN
31664      END
31665      SUBROUTINE DPCSR4(X,Y,N,YTEMP,DIST,
31666     1                  STATVA,STATCD,PVALUE,
31667     1                  ISUBRO,IBUGA3,IERROR)
31668C
31669C     PURPOSE--THIS SUBROUTINE COMPUTES THE MEAN NEAREST NEIGHBOR
31670C              DISTANCE TEST FOR COMPLETE SPATIAL RANDOMNESS FOR
31671C              BIVARIATE DATA.  WE HAVE A SET OF N POINTS (X,Y).
31672C
31673C              THE TEST STATISTIC IS
31674C
31675C                  T = (ZBAR - MU(ZBAR))/SIGMA(ZBAR)
31676C
31677C                  ZBAR = (1/N)*SUM[i=1 to N][Z(i)]
31678C
31679C              WHERE
31680C
31681C                  Z(i) IS THE DISTANCE FROM THE i-TH EVENT
31682C                  TO IT'S NEAREST NEIGHBOR
31683C
31684C                  MU(ZBAR) = 0.5*N**(-1/2)  + 0.206*N**(-1) +
31685C                             0.164*N**(-3/2)
31686C
31687C                  SIGMA(ZBAR) = 0.070*N**(-2) + 0.148*N**(-5/2)
31688C
31689C               THIS IS A MODIFIED VERSION OF THE CLARK-EVANS TEST
31690C               (GIVEN BY DONNELLY).
31691C
31692C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
31693C                                OBSERVATIONS FOR THE FIRST RESPONSE
31694C                                VARIABLE.
31695C                     --Y      = THE SINGLE PRECISION VECTOR OF
31696C                                OBSERVATIONS FOR THE SECOND RESPONSE
31697C                                VARIABLE.
31698C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
31699C                                IN THE VECTOR Y.
31700C     OUTPUT ARGUMENTS--STATVA = THE SINGLE PRECISION VALUE OF THE
31701C                                COMPUTED STATISTIC.
31702C                     --STATCD = THE SINGLE PRECISION VALUE OF THE
31703C                                COMPUTED CDF OF THE TEST STATISTIC.
31704C                     --STATNU = THE SINGLE PRECISION VALUE OF THE
31705C                                CHI-SQUARE DEGREES OF FREEDOM.
31706C                     --PVALUE = THE SINGLE PRECISION VALUE OF THE
31707C                                COMPUTED P-VALUE.
31708C     REFERENCE--DALE ZIMMERMAN (1993), "A BIVARIATE CRAMER-VON MISES
31709C                TYPE OF TEST FOR SPATIAL RANDONNESS", JOURNAL OF
31710C                THE ROYAL STATISTICAL SOCIETY, SERIES C (APPLIED
31711C                STATISTICS, VOL. 42, NO. 1, PP. 43-54.
31712C                LONDON.
31713C              --CLARK AND EVANS (1954), "DISTANCE TO NEAREST
31714C                NEIGHBOR AS A MEASURE OF SPATIAL RELATIONSHIPS
31715C                IN POPULATIONS", ECOLOGY, 35, PP. 23-30.
31716C              --DONNELLY (1978), "SIMULATIONS TO DETERMINE THE
31717C                VARIANCE AND EDGE-EFFECT OF TOTAL NEAREST-NEIGHBOR
31718C                DISTANCE", IN SIMULATION STUDIES IN ARCHAEOLOGY
31719C                (ED. HODDER), PP. 91-95, LONDON: CAMBRIDGE UNIVERSITY
31720C                PRESS.
31721C     OTHER DATAPAC   SUBROUTINES NEEDED--MEAN, SD.
31722C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
31723C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
31724C     LANGUAGE--ANSI FORTRAN (1977)
31725C     WRITTEN BY--ALAN HECKERT
31726C                 STATISTICAL ENGINEERING DIVISION
31727C                 INFORMATION TECHNOLOGY LABORATORY
31728C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
31729C                 GAITHERSBURG, MD 20899-8980
31730C                 PHONE--301-975-2899
31731C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
31732C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
31733C     LANGUAGE--ANSI FORTRAN (1977)
31734C     VERSION NUMBER--2013.12
31735C     ORIGINAL VERSION--DECEMBER  2013.
31736C
31737C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
31738C
31739      CHARACTER*4 ISUBRO
31740      CHARACTER*4 IBUGA3
31741      CHARACTER*4 IERROR
31742C
31743      CHARACTER*4 IWRITE
31744      CHARACTER*4 ISUBN1
31745      CHARACTER*4 ISUBN2
31746C
31747C---------------------------------------------------------------------
31748C
31749      DIMENSION Y(*)
31750      DIMENSION X(*)
31751      DIMENSION YTEMP(*)
31752      DIMENSION DIST(*)
31753C
31754C---------------------------------------------------------------------
31755C
31756      INCLUDE 'DPCOP2.INC'
31757C
31758C-----START POINT-----------------------------------------------------
31759C
31760      ISUBN1='DPCS'
31761      ISUBN2='R4  '
31762      IWRITE='OFF'
31763      IERROR='NO'
31764C
31765      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CSR4')THEN
31766        WRITE(ICOUT,999)
31767  999   FORMAT(1X)
31768        CALL DPWRST('XXX','BUG ')
31769        WRITE(ICOUT,51)
31770   51   FORMAT('***** AT THE BEGINNING OF DPCSR4--')
31771        CALL DPWRST('XXX','BUG ')
31772        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
31773   52   FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8)
31774        CALL DPWRST('XXX','BUG ')
31775        DO55I=1,N
31776          WRITE(ICOUT,56)I,Y(I),X(I)
31777   56     FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
31778          CALL DPWRST('XXX','BUG ')
31779   55   CONTINUE
31780      ENDIF
31781C
31782      STATVA=CPUMIN
31783      STATCD=CPUMIN
31784      STATNU=CPUMIN
31785      PVALUE=CPUMIN
31786C
31787C               *******************************************
31788C               **  MEAN NEAREST NEIGHBORS TEST          **
31789C               *******************************************
31790C
31791C
31792C               ********************************************
31793C               **  STEP 1--                              **
31794C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
31795C               ********************************************
31796C
31797      IF(N.LE.4)THEN
31798        WRITE(ICOUT,999)
31799        CALL DPWRST('XXX','BUG ')
31800        WRITE(ICOUT,111)
31801  111   FORMAT('***** ERROR IN MEAN NEAREST NEIGHBORS TEST--')
31802        CALL DPWRST('XXX','BUG ')
31803        WRITE(ICOUT,112)
31804  112   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ',
31805     1         'VARIABLE IS LESS THAN FOUR.')
31806        CALL DPWRST('XXX','BUG ')
31807        WRITE(ICOUT,117)N
31808  117   FORMAT('      THE NUMBER OF OBSERVATIONS = ',I8)
31809        CALL DPWRST('XXX','BUG ')
31810        IERROR='YES'
31811        GOTO9000
31812      ENDIF
31813C
31814      CALL NEARNE(Y,X,N,YTEMP,DIST,
31815     1            IBUGA3,ISUBRO,IERROR)
31816      CALL MEAN(DIST,N,IWRITE,ZMEAN,IBUGA3,IERROR)
31817      AN=REAL(N)
31818      AMUZ=(0.5/SQRT(AN)) + (0.206/AN) + (0.164/AN**(-1.5))
31819      VARZ=(0.070/AN**2) + (0.148/AN**(-2.5))
31820      STATVA=(ZMEAN - AMUZ)/VARZ
31821      CALL NORCDF(STATVA,STATCD)
31822      PVALLT=STATCD
31823      PVALUT=1.0 - STATCD
31824      IF(STATVA.LE.0.0)THEN
31825        PVALUE=2.0*PVALLT
31826      ELSE
31827        PVALUE=2.0*PVALUT
31828      ENDIF
31829C
31830C               *****************
31831C               **  STEP 90--  **
31832C               **  EXIT.      **
31833C               *****************
31834C
31835 9000 CONTINUE
31836C
31837      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CSR4')THEN
31838        WRITE(ICOUT,999)
31839        CALL DPWRST('XXX','BUG ')
31840        WRITE(ICOUT,9011)
31841 9011   FORMAT('***** AT THE END       OF DPCSR4--')
31842        CALL DPWRST('XXX','BUG ')
31843        WRITE(ICOUT,9015)STATVA,STATCD,PVALUE,IERROR
31844 9015   FORMAT('STATVA,STATCD,PVALUE,IERROR = ',3G15.7,2X,A4)
31845        CALL DPWRST('XXX','BUG ')
31846        WRITE(ICOUT,9016)AMUZ,VARZ
31847 9016   FORMAT('AMUZ,VARZ = ',2G15.7)
31848        CALL DPWRST('XXX','BUG ')
31849      ENDIF
31850C
31851      RETURN
31852      END
31853      SUBROUTINE DPCSR5(X,Y,N,JINDX,DIST,
31854     1                  STATVA,STATV2,STATCD,PVALUE,STATNU,
31855     1                  ISUBRO,IBUGA3,IERROR)
31856C
31857C     PURPOSE--THIS SUBROUTINE COMPUTES POLLARD'S TEST FOR
31858C              COMPLETE SPATIAL RANDOMNESS FOR BIVARIATE DATA.
31859C              WE HAVE A SET OF N POINTS (X,Y).
31860C
31861C              THE TEST STATISTIC IS
31862C
31863C                  P(j) = C1*[N*LN(C2) - C3]/C4
31864C
31865C              WHERE
31866C
31867C                  C1 = 12*j**2*N
31868C                  C2 = SUM[i=1 to N][X(ij)**2/N]
31869C                  C3 = SUM[i=1 to N][LOG(X(ij)**2)]
31870C                  C4 = (6*j*N + N + 1)*(N-1)
31871C
31872C              AND WHERE
31873C
31874C                  j DENOTES THE j-TH NEAREST NEIGHBOR
31875C                  X(ij) IS THE DISTANCE FROM THE i-TH POINT TO
31876C                        IT'S J-TH NEAREST NEIGHBOR
31877C
31878C               J IS 1, 2, 3, 4, 5
31879C
31880C               (N-1)*P(j) HAS A CHI-SQUARE DISTRIBUTION WITH
31881C               (N-1) DEGREES OF FREEDOM.
31882C
31883C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
31884C                                OBSERVATIONS FOR THE FIRST RESPONSE
31885C                                VARIABLE.
31886C                     --Y      = THE SINGLE PRECISION VECTOR OF
31887C                                OBSERVATIONS FOR THE SECOND RESPONSE
31888C                                VARIABLE.
31889C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
31890C                                IN THE VECTOR Y.
31891C     OUTPUT ARGUMENTS--STATVA = THE SINGLE PRECISION VALUE OF THE
31892C                                COMPUTED STATISTIC.
31893C                     --STATCD = THE SINGLE PRECISION VALUE OF THE
31894C                                COMPUTED CDF OF THE TEST STATISTIC.
31895C                     --STATNU = THE SINGLE PRECISION VALUE OF THE
31896C                                CHI-SQUARE DEGREES OF FREEDOM.
31897C                     --PVALUE = THE SINGLE PRECISION VALUE OF THE
31898C                                COMPUTED P-VALUE.
31899C     REFERENCE--FORTIN AND DALE (2005), "SPATIAL ANALYSIS: A GUIDE
31900C                FOR ECOLOGISTS", CAMBRIDGE UNIVERSITY PRESS, PP. 34-35.
31901C              --POLLARD (1971), "ON DISTANCE ESTIMATORS OF DENSITY
31902C                IN RANDOMLY DISTRIBUTED FORESTS", BIOMETRICS, 27,
31903C                991-1002.
31904C              --LIU (2001), "A COMPARISON OF FIVE DISTANCE-BASED METHODS
31905C                FOR PATTERN ANALYSIS", JOURNAL OF VEGETATION SCIENCE,
31906C                12, 411-416.
31907C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
31908C     FORTRAN LIBRARY SUBROUTINES NEEDED--LOG.
31909C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
31910C     LANGUAGE--ANSI FORTRAN (1977)
31911C     WRITTEN BY--ALAN HECKERT
31912C                 STATISTICAL ENGINEERING DIVISION
31913C                 INFORMATION TECHNOLOGY LABORATORY
31914C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
31915C                 GAITHERSBURG, MD 20899-8980
31916C                 PHONE--301-975-2899
31917C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
31918C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
31919C     LANGUAGE--ANSI FORTRAN (1977)
31920C     VERSION NUMBER--2014.01
31921C     ORIGINAL VERSION--JANUARY   2014.
31922C
31923C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
31924C
31925      CHARACTER*4 ISUBRO
31926      CHARACTER*4 IBUGA3
31927      CHARACTER*4 IERROR
31928C
31929      CHARACTER*4 IWRITE
31930      CHARACTER*4 ISUBN1
31931      CHARACTER*4 ISUBN2
31932C
31933C---------------------------------------------------------------------
31934C
31935      DIMENSION Y(*)
31936      DIMENSION X(*)
31937      DIMENSION DIST(*)
31938C
31939      DOUBLE PRECISION DSUM1
31940      DOUBLE PRECISION DSUM2
31941      DOUBLE PRECISION DN
31942      DOUBLE PRECISION DX
31943      DOUBLE PRECISION DJ
31944      DOUBLE PRECISION DSTAT
31945      DOUBLE PRECISION DC1
31946      DOUBLE PRECISION DC2
31947C
31948C---------------------------------------------------------------------
31949C
31950      INCLUDE 'DPCOP2.INC'
31951C
31952C-----START POINT-----------------------------------------------------
31953C
31954      ISUBN1='DPCS'
31955      ISUBN2='R5  '
31956      IWRITE='OFF'
31957      IERROR='NO'
31958C
31959      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CSR5')THEN
31960        WRITE(ICOUT,999)
31961  999   FORMAT(1X)
31962        CALL DPWRST('XXX','BUG ')
31963        WRITE(ICOUT,51)
31964   51   FORMAT('***** AT THE BEGINNING OF DPCSR5--')
31965        CALL DPWRST('XXX','BUG ')
31966        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
31967   52   FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8)
31968        CALL DPWRST('XXX','BUG ')
31969        DO55I=1,N
31970          WRITE(ICOUT,56)I,Y(I),X(I)
31971   56     FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
31972          CALL DPWRST('XXX','BUG ')
31973   55   CONTINUE
31974      ENDIF
31975C
31976      STATVA=CPUMIN
31977      STATCD=CPUMIN
31978      STATNU=CPUMIN
31979      PVALUE=CPUMIN
31980C
31981C               ********************************************
31982C               **  STEP 1--                              **
31983C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS. **
31984C               **  FIRST FILTER OUT ANY DUPLICATE POINTS.**
31985C               ********************************************
31986C
31987      IF(JINDX.LT.1 .OR. JINDX.GT.5)THEN
31988        WRITE(ICOUT,999)
31989        CALL DPWRST('XXX','BUG ')
31990        WRITE(ICOUT,111)
31991        CALL DPWRST('XXX','BUG ')
31992        WRITE(ICOUT,92)JINDX
31993   92   FORMAT('      THE DISTANCE INDEX (',I8,') IS LESS THAN ',
31994     1         '1 OR GREATER THAN 5.')
31995        CALL DPWRST('XXX','BUG ')
31996        IERROR='YES'
31997        GOTO9000
31998      ENDIF
31999C
32000      ICNT=0
32001      DO101I=1,N-1
32002        DO103J=I+1,N
32003          IF(X(I).EQ.X(J) .AND. Y(I).EQ.Y(J))GOTO101
32004  103   CONTINUE
32005        ICNT=ICNT+1
32006        X(ICNT)=X(I)
32007        Y(ICNT)=Y(I)
32008  101 CONTINUE
32009      ICNT=ICNT+1
32010      X(ICNT)=X(N)
32011      Y(ICNT)=Y(N)
32012C
32013      N=ICNT
32014      IF(N.LT.10)THEN
32015        WRITE(ICOUT,999)
32016        CALL DPWRST('XXX','BUG ')
32017        WRITE(ICOUT,111)
32018  111   FORMAT('***** ERROR IN POLLARD TEST--')
32019        CALL DPWRST('XXX','BUG ')
32020        WRITE(ICOUT,112)
32021  112   FORMAT('      THE NUMBER OF UNIQUE OBSERVATIONS FOR THE ',
32022     1         'RESPONSE VARIABLE IS LESS THAN TEN.')
32023        CALL DPWRST('XXX','BUG ')
32024        WRITE(ICOUT,117)N
32025  117   FORMAT('      THE NUMBER OF OBSERVATIONS = ',I8)
32026        CALL DPWRST('XXX','BUG ')
32027        IERROR='YES'
32028        GOTO9000
32029      ENDIF
32030C
32031C               ********************************************
32032C               **  STEP 2--                              **
32033C               **  COMPUTE POLLARDS STATISTIC            **
32034C               ********************************************
32035C
32036      DN=DBLE(N)
32037      DJ=DBLE(JINDX)
32038      DC1=12.0D0*(DJ**2)*DN
32039      DC2=(6.0D0*DJ*DN + DN + 1.0D0)*(DN - 1.0D0)
32040      DSUM1=0.0D0
32041      DSUM2=0.0D0
32042C
32043      DO200I=1,N
32044        X2=X(I)
32045        Y2=Y(I)
32046        CALL NEARN3(Y,X,N,Y2,X2,DIST,
32047     1              IBUGA3,ISUBRO,IERROR)
32048        DX=DBLE(DIST(JINDX))
32049        DSUM1=DSUM1 + DX**2/DN
32050        DSUM2=DSUM2 + DLOG(DX**2)
32051  200 CONTINUE
32052C
32053      DSTAT=DC1*(DN*DLOG(DSUM1) - DSUM2)/DC2
32054C
32055      STATVA=REAL(DSTAT)
32056      STATV2=REAL(N-1)*STATVA
32057      IDF=N-1
32058      STATNU=REAL(IDF)
32059      CALL CHSCDF(STATV2,IDF,STATCD)
32060      PVALLT=STATCD
32061      PVALUT=1.0 - STATCD
32062      IF(STATCD.LE.0.5)THEN
32063        PVALUE=2.0*PVALLT
32064      ELSE
32065        PVALUE=2.0*PVALUT
32066      ENDIF
32067C
32068C               *****************
32069C               **  STEP 90--  **
32070C               **  EXIT.      **
32071C               *****************
32072C
32073 9000 CONTINUE
32074C
32075      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CSR5')THEN
32076        WRITE(ICOUT,999)
32077        CALL DPWRST('XXX','BUG ')
32078        WRITE(ICOUT,9011)
32079 9011   FORMAT('***** AT THE END       OF DPCSR5--')
32080        CALL DPWRST('XXX','BUG ')
32081        WRITE(ICOUT,9015)STATVA,STATV2,STATCD,PVALUE,IERROR
32082 9015   FORMAT('STATVA,STATV2,STATCD,PVALUE,IERROR = ',4G15.7,2X,A4)
32083        CALL DPWRST('XXX','BUG ')
32084        WRITE(ICOUT,9016)AMUZ,VARZ
32085 9016   FORMAT('AMUZ,VARZ = ',2G15.7)
32086        CALL DPWRST('XXX','BUG ')
32087      ENDIF
32088C
32089      RETURN
32090      END
32091      SUBROUTINE DPCSTE(MAXNXT,ICAPSW,IFORSW,ICASAN,
32092     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
32093C
32094C     PURPOSE--CARRY OUT A ONE-SAMPLE CHI-SQUARED TEST
32095C     EXAMPLE--CHI-SQUARED TEST Y SIGMA
32096C              CHI-SQUARED TEST SIGMA Y
32097C     WRITTEN BY--JAMES J. FILLIBEN
32098C                 STATISTICAL ENGINEERING DIVISION
32099C                 INFORMATION TECHNOLOGY LABORATORY
32100C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
32101C                 GAITHERSBURG, MD 20899-8980
32102C                 PHONE--301-975-2899
32103C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
32104C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
32105C     LANGUAGE--ANSI FORTRAN (1977)
32106C     VERSION NUMBER--94/2
32107C     ORIGINAL VERSION--FEBRUARY  1994.
32108C     UPDATED         --DECEMBER  1994.  COPY CHI-SQUARED TEST PARAM.
32109C     UPDATED         --MAY       1995.  BUG FIX
32110C     UPDATED         --JANUARY   2004.  SUPPORT FOR HTML, LATEX
32111C     UPDATED         --APRIL     2011.  USE DPPARS AND DPPAR3
32112C
32113C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
32114C
32115      CHARACTER*4 IBUGA2
32116      CHARACTER*4 IBUGA3
32117      CHARACTER*4 IBUGQ
32118      CHARACTER*4 ISUBRO
32119      CHARACTER*4 IFOUND
32120      CHARACTER*4 IERROR
32121      CHARACTER*4 ICAPSW
32122      CHARACTER*4 IFORSW
32123      CHARACTER*4 ICASAN
32124C
32125      CHARACTER*4 IREPL
32126      CHARACTER*4 ISUBN1
32127      CHARACTER*4 ISUBN2
32128      CHARACTER*4 ISTEPN
32129C
32130      CHARACTER*4 ICASA2
32131      CHARACTER*4 ICASA3
32132      CHARACTER*4 ICASE
32133      CHARACTER*4 IVARID
32134      CHARACTER*4 IVARI2
32135      CHARACTER*40 INAME
32136      PARAMETER (MAXSPN=30)
32137      CHARACTER*4 IVARN1(MAXSPN)
32138      CHARACTER*4 IVARN2(MAXSPN)
32139      CHARACTER*4 IVARTY(MAXSPN)
32140      REAL PVAR(MAXSPN)
32141      INTEGER ILIS(MAXSPN)
32142      INTEGER NRIGHT(MAXSPN)
32143      INTEGER ICOLR(MAXSPN)
32144C
32145      CHARACTER*4 IFLAGU
32146      LOGICAL IFRST
32147      LOGICAL ILAST
32148C
32149C-----COMMON----------------------------------------------------------
32150C
32151      INCLUDE 'DPCOPA.INC'
32152      INCLUDE 'DPCOHK.INC'
32153      INCLUDE 'DPCOSU.INC'
32154      INCLUDE 'DPCODA.INC'
32155C
32156C-----COMMON VARIABLES (GENERAL)--------------------------------------
32157C
32158      INCLUDE 'DPCOP2.INC'
32159C
32160C-----START POINT-----------------------------------------------------
32161C
32162      ISUBN1='DPCS'
32163      ISUBN2='TE  '
32164C
32165      MAXCP1=MAXCOL+1
32166      MAXCP2=MAXCOL+2
32167      MAXCP3=MAXCOL+3
32168      MAXCP4=MAXCOL+4
32169      MAXCP5=MAXCOL+5
32170      MAXCP6=MAXCOL+6
32171C
32172      IFOUND='YES'
32173      IERROR='NO'
32174C
32175      ICASA2='BOTH'
32176      IF(ICASAN.EQ.'CSLT')THEN
32177        ICASAN='CSTE'
32178        ICASA2='LOWE'
32179      ELSEIF(ICASAN.EQ.'CSUT')THEN
32180        ICASAN='CSTE'
32181        ICASA2='UPPE'
32182      ELSEIF(ICASAN.EQ.'CS2T')THEN
32183        ICASAN='CSTE'
32184        ICASA2='TWOT'
32185      ENDIF
32186C
32187C               ***************************************
32188C               **  TREAT THE CHI-SQUARED TEST CASE  **
32189C               ***************************************
32190C
32191      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CSTE')THEN
32192        WRITE(ICOUT,999)
32193  999   FORMAT(1X)
32194        CALL DPWRST('XXX','BUG ')
32195        WRITE(ICOUT,51)
32196   51   FORMAT('***** AT THE BEGINNING OF DPCSTE--')
32197        CALL DPWRST('XXX','BUG ')
32198        WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ,ISUBRO,MAXNXT
32199   52   FORMAT('IBUGA2,IBUGA3,IBUGQ,ISUBRO = ',4(A4,2X),I8)
32200        CALL DPWRST('XXX','BUG ')
32201      ENDIF
32202C
32203C               ****************************************
32204C               **  STEP 2--                          **
32205C               **  EXTRACT THE VARIABLE LIST         **
32206C               ****************************************
32207C
32208      ISTEPN='2'
32209      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CSTE')
32210     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
32211C
32212      INAME='CHI-SQUARE TEST'
32213      MINNA=1
32214      MAXNA=100
32215      MINN2=2
32216      IFLAGE=0
32217      IFLAGM=1
32218      MINNVA=2
32219      MAXNVA=MAXSPN
32220      IFLAGP=29
32221      IF(IREPL.EQ.'ON')THEN
32222        IFLAGE=1
32223        IFLAGM=0
32224      ENDIF
32225      JMIN=1
32226      JMAX=NUMARG
32227C
32228      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
32229     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
32230     1            JMIN,JMAX,
32231     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
32232     1            IVARN1,IVARN2,IVARTY,PVAR,
32233     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
32234     1            MINNVA,MAXNVA,
32235     1            IFLAGM,IFLAGP,
32236     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
32237      IF(IERROR.EQ.'YES')GOTO9000
32238C
32239      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CSTE')THEN
32240        WRITE(ICOUT,999)
32241        CALL DPWRST('XXX','BUG ')
32242        WRITE(ICOUT,281)
32243  281   FORMAT('***** AFTER CALL DPPARS--')
32244        CALL DPWRST('XXX','BUG ')
32245        WRITE(ICOUT,282)NQ,NUMVAR
32246  282   FORMAT('NQ,NUMVAR = ',2I8)
32247        CALL DPWRST('XXX','BUG ')
32248        IF(NUMVAR.GT.0)THEN
32249          DO285I=1,NUMVAR
32250            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
32251     1                      ICOLR(I)
32252  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
32253     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
32254            CALL DPWRST('XXX','BUG ')
32255  285     CONTINUE
32256        ENDIF
32257      ENDIF
32258C
32259C     EITHER THE FIRST OR LAST ARGUMENT SHOULD BE A PARAMETER.
32260C
32261      IF(IVARTY(1).NE.'PARA' .AND. IVARTY(NUMVAR).NE.'PARA')THEN
32262        WRITE(ICOUT,999)
32263        CALL DPWRST('XXX','BUG ')
32264        WRITE(ICOUT,101)
32265  101   FORMAT('***** ERROR IN CHI-SQUARE TEST--')
32266        CALL DPWRST('XXX','BUG ')
32267        WRITE(ICOUT,292)
32268  292   FORMAT('      EITHER THE FIRST OR THE LAST ARGUMENT MUST BE ',
32269     1         'A PARAMETER.')
32270        CALL DPWRST('XXX','BUG ')
32271        IERROR='YES'
32272        GOTO9000
32273      ELSEIF(IVARTY(1).EQ.'PARA')THEN
32274        ISTART=2
32275        ISTOP=NUMVAR
32276        SIGMA0=PVAR(1)
32277      ELSEIF(IVARTY(NUMVAR).EQ.'PARA')THEN
32278        ISTART=1
32279        ISTOP=NUMVAR-1
32280        SIGMA0=PVAR(NUMVAR)
32281      ENDIF
32282C
32283C               *****************************************
32284C               **  STEP 3A--                          **
32285C               **  CASE 1: NO REPLICATION CASE        **
32286C               *****************************************
32287C
32288      ISTEPN='3A'
32289      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CSTE')
32290     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
32291C
32292      NUMVA2=1
32293      DO5210I=ISTART,ISTOP
32294        ICOL=I
32295        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
32296     1              INAME,IVARN1,IVARN2,IVARTY,
32297     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
32298     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
32299     1              MAXCP4,MAXCP5,MAXCP6,
32300     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
32301     1              Y,Y,Y,NS1,NLOCA2,NLOCA3,ICASE,
32302     1              IBUGA3,ISUBRO,IFOUND,IERROR)
32303        IF(IERROR.EQ.'YES')GOTO9000
32304C
32305C               *****************************************
32306C               **  STEP 52--                          **
32307C               **  PERFORM CHI-SQUARE TEST            **
32308C               *****************************************
32309C
32310        ISTEPN='52'
32311        IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CSTE')THEN
32312          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
32313          WRITE(ICOUT,999)
32314          CALL DPWRST('XXX','BUG ')
32315          WRITE(ICOUT,5211)
32316 5211     FORMAT('***** FROM DPCSTE, BEFORE CALL DPCST2--')
32317          CALL DPWRST('XXX','BUG ')
32318          WRITE(ICOUT,5212)I,J,NS1,MAXN
32319 5212     FORMAT('I,J,NS1,MAXN = ',4I8)
32320          CALL DPWRST('XXX','BUG ')
32321          DO5215II=1,NS1
32322            WRITE(ICOUT,5216)II,Y(II)
32323 5216       FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
32324            CALL DPWRST('XXX','BUG ')
32325 5215     CONTINUE
32326        ENDIF
32327C
32328        IVARID=IVARN1(I)
32329        IVARI2=IVARN2(I)
32330        CALL DPCST2(Y,NS1,SIGMA0,
32331     1              ICAPSW,ICAPTY,IFORSW,
32332     1              IVARID,IVARI2,ICASA2,
32333     1              STATVA,STATCD,STATNU,PVAL2T,PVALLT,PVALUT,
32334     1              CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50,
32335     1              CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50,
32336     1              IBUGA3,ISUBRO,IERROR)
32337        IF(IERROR.EQ.'YES')GOTO9000
32338C
32339C               ***************************************
32340C               **  STEP 8C--                        **
32341C               **  UPDATE INTERNAL DATAPLOT TABLES  **
32342C               ***************************************
32343C
32344        ISTEPN='8C'
32345        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CSTE')
32346     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
32347C
32348        IF(ISTOP-ISTART.GT.0)THEN
32349          IFLAGU='FILE'
32350        ELSE
32351          IFLAGU='ON'
32352        ENDIF
32353        IFRST=.FALSE.
32354        ILAST=.FALSE.
32355        IF(I.EQ.ISTART)IFRST=.TRUE.
32356        IF(I.EQ.ISTOP)ILAST=.TRUE.
32357        STATV2=CPUMIN
32358        STATC2=CPUMIN
32359        STATN2=CPUMIN
32360        ICASA3='ONES'
32361        CALL DPTTE5(ICASA3,STATVA,STATCD,STATNU,
32362     1              STATV2,STATC2,STATN2,
32363     1              PVAL2T,PVALLT,PVALUT,
32364     1              CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50,
32365     1              CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50,
32366     1              IFLAGU,IFRST,ILAST,
32367     1              IBUGA2,IBUGA3,ISUBRO,IERROR)
32368C
32369 5210 CONTINUE
32370C
32371C               *****************
32372C               **  STEP 90--  **
32373C               **  EXIT       **
32374C               *****************
32375C
32376 9000 CONTINUE
32377      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CSTE')THEN
32378        WRITE(ICOUT,999)
32379        CALL DPWRST('XXX','BUG ')
32380        WRITE(ICOUT,9011)
32381 9011   FORMAT('***** AT THE END       OF DPCSTE--')
32382        CALL DPWRST('XXX','BUG ')
32383        WRITE(ICOUT,9016)IFOUND,IERROR
32384 9016   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
32385        CALL DPWRST('XXX','BUG ')
32386        WRITE(ICOUT,9018)STATVA,STATCD,PVAL
32387 9018   FORMAT('STATVA,STATCD,PVAL = ',3G15.7)
32388        CALL DPWRST('XXX','BUG ')
32389      ENDIF
32390C
32391      RETURN
32392      END
32393      SUBROUTINE DPCST2(Y1,N1,SIGMA0,
32394     1                  ICAPSW,ICAPTY,IFORSW,
32395     1                  IVARID,IVARI2,ICASA2,
32396     1                  STATVA,STATCD,STATNU,PVAL2T,PVALLT,PVALUT,
32397     1                  CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50,
32398     1                  CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50,
32399     1                  IBUGA3,ISUBRO,IERROR)
32400C
32401C     PURPOSE--THIS ROUTINE CARRIES OUT A ONE-SAMPLE CHI-SQUARED TEST
32402C     EXAMPLE--CHI-SQUARED TEST Y SIGMA0
32403C              CHI-SQUARED TEST SIGMA0 Y
32404C     WRITTEN BY--JAMES J. FILLIBEN
32405C                 STATISTICAL ENGINEERING DIVISION
32406C                 INFORMATION TECHNOLOGY LABORATORY
32407C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
32408C                 GAITHERSBURG, MD 20899-8980
32409C                 PHONE--301-975-2899
32410C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
32411C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
32412C     LANGUAGE--ANSI FORTRAN (1977)
32413C     VERSION NUMBER--82/7
32414C     ORIGINAL VERSION--MAY       1984.
32415C     UPDATED         --APRIL     1987.  (LARRY KNAB CORRECTION--
32416C                                        BROWNLEE, P. 225)
32417C     UPDATED         --FEBRUARY  1994.  REFORMAT OUTPUT
32418C     UPDATED         --FEBRUARY  1994.  DPWRST: 'BUG ' => 'WRIT'
32419C     UPDATED         --DECEMBER  1994.  COPY CHI-SQUARED TEST PARAM.
32420C     UPDATED         --OCTOBER   2001.  MODIFY SOME OF THE
32421C                                        PRINT OUT FOR BETTER
32422C                                        CLARITY
32423C     UPDATED         --JANUARY   2004.  SUPPORT FOR HTML, LATEX
32424C     UPDATED         --APRIL     2011.  USE DPDTA1 AND DPDTA5 TO
32425C                                        PRINT OUTPUT.  REFORMAT OUTPUT
32426C                                        SOMEWHAT AS WELL.
32427C
32428C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
32429C
32430      CHARACTER*4 IVARID
32431      CHARACTER*4 IVARI2
32432      CHARACTER*4 ICASA2
32433      CHARACTER*4 IBUGA3
32434      CHARACTER*4 ISUBRO
32435      CHARACTER*4 IERROR
32436      CHARACTER*4 ICAPSW
32437      CHARACTER*4 ICAPTY
32438      CHARACTER*4 IFORSW
32439C
32440      CHARACTER*4 IWRITE
32441      CHARACTER*4 ISUBN1
32442      CHARACTER*4 ISUBN2
32443      CHARACTER*4 ISTEPN
32444C
32445C---------------------------------------------------------------------
32446C
32447      DIMENSION Y1(*)
32448C
32449      PARAMETER (NUMALP=6)
32450      REAL ALPHA(NUMALP)
32451C
32452      PARAMETER(NUMCLI=5)
32453      PARAMETER(MAXLIN=3)
32454      PARAMETER (MAXROW=NUMALP)
32455      PARAMETER (MAXRO2=30)
32456      CHARACTER*60 ITITLE
32457      CHARACTER*60 ITITLZ
32458      CHARACTER*60 ITITL9
32459      CHARACTER*60 ITEXT(MAXRO2)
32460      CHARACTER*4  ALIGN(NUMCLI)
32461      CHARACTER*4  VALIGN(NUMCLI)
32462      REAL         AVALUE(MAXRO2)
32463      INTEGER      NCTEXT(MAXRO2)
32464      INTEGER      IDIGIT(MAXRO2)
32465      INTEGER      NTOT(MAXRO2)
32466      CHARACTER*60 ITITL2(MAXLIN,NUMCLI)
32467      CHARACTER*15 IVALUE(MAXROW,NUMCLI)
32468      CHARACTER*4  ITYPCO(NUMCLI)
32469      INTEGER      NCTIT2(MAXLIN,NUMCLI)
32470      INTEGER      NCVALU(MAXROW,NUMCLI)
32471      INTEGER      IWHTML(NUMCLI)
32472      INTEGER      IWRTF(NUMCLI)
32473      REAL         AMAT(MAXROW,NUMCLI)
32474      LOGICAL IFRST
32475      LOGICAL ILAST
32476      LOGICAL IFLAGS
32477      LOGICAL IFLAGE
32478C
32479C---------------------------------------------------------------------
32480C
32481      INCLUDE 'DPCOP2.INC'
32482C
32483      DATA ALPHA/0.50, 0.80, 0.90, 0.95, 0.99, 0.999/
32484C
32485C-----START POINT-----------------------------------------------------
32486C
32487      ISUBN1='DPCS'
32488      ISUBN2='T2  '
32489      IERROR='NO'
32490      IWRITE='OFF'
32491C
32492      NUMDIG=7
32493      IF(IFORSW.EQ.'1')NUMDIG=1
32494      IF(IFORSW.EQ.'2')NUMDIG=2
32495      IF(IFORSW.EQ.'3')NUMDIG=3
32496      IF(IFORSW.EQ.'4')NUMDIG=4
32497      IF(IFORSW.EQ.'5')NUMDIG=5
32498      IF(IFORSW.EQ.'6')NUMDIG=6
32499      IF(IFORSW.EQ.'7')NUMDIG=7
32500      IF(IFORSW.EQ.'8')NUMDIG=8
32501      IF(IFORSW.EQ.'9')NUMDIG=9
32502      IF(IFORSW.EQ.'0')NUMDIG=0
32503      IF(IFORSW.EQ.'E')NUMDIG=-2
32504      IF(IFORSW.EQ.'-2')NUMDIG=-2
32505      IF(IFORSW.EQ.'-3')NUMDIG=-3
32506      IF(IFORSW.EQ.'-4')NUMDIG=-4
32507      IF(IFORSW.EQ.'-5')NUMDIG=-5
32508      IF(IFORSW.EQ.'-6')NUMDIG=-6
32509      IF(IFORSW.EQ.'-7')NUMDIG=-7
32510      IF(IFORSW.EQ.'-8')NUMDIG=-8
32511      IF(IFORSW.EQ.'-9')NUMDIG=-9
32512C
32513      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CST2')THEN
32514        WRITE(ICOUT,999)
32515  999   FORMAT(1X)
32516        CALL DPWRST('XXX','WRIT')
32517        WRITE(ICOUT,51)
32518   51   FORMAT('**** AT THE BEGINNING OF DPCST2--')
32519        CALL DPWRST('XXX','WRIT')
32520        WRITE(ICOUT,52)IBUGA3,ISUBRO,SIGMA0,N1
32521   52   FORMAT('IBUGA3,ISUBRO,SIGMA0,N1 = ',2(A4,2X),G15.7,I8)
32522        CALL DPWRST('XXX','WRIT')
32523        DO56I=1,N1
32524          WRITE(ICOUT,57)I,Y1(I)
32525   57     FORMAT('I,Y1(I) = ',I8,G15.7)
32526          CALL DPWRST('XXX','WRIT')
32527   56   CONTINUE
32528      ENDIF
32529C
32530C               ******************************
32531C               **  STEP 31--               **
32532C               **  CARRY OUT CALCULATIONS  **
32533C               **  FOR A CHI-SQUARED TEST  **
32534C               ******************************
32535C
32536      ISTEPN='31'
32537      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CST2')
32538     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
32539C
32540      CALL DPCST3(Y1,N1,SIGMA0,IWRITE,
32541     1            STATVA,STATCD,STATNU,
32542     1            YMEAN,YSD,RATIO,
32543     1            ISUBRO,IBUGA3,IERROR)
32544      IF(IERROR.EQ.'YES')GOTO9000
32545C
32546      IDF=INT(STATNU+0.1)
32547      CALL CHSPPF(.0005,IDF,CTL999)
32548      CALL CHSPPF(.005,IDF,CUTL99)
32549      CALL CHSPPF(.025,IDF,CUTL95)
32550      CALL CHSPPF(.05,IDF,CUTL90)
32551      CALL CHSPPF(.1,IDF,CUTL80)
32552      CALL CHSPPF(.25,IDF,CUTL50)
32553      CALL CHSPPF(.75,IDF,CUTU50)
32554      CALL CHSPPF(.90,IDF,CUTU80)
32555      CALL CHSPPF(.95,IDF,CUTU90)
32556      CALL CHSPPF(.975,IDF,CUTU95)
32557      CALL CHSPPF(.995,IDF,CUTU99)
32558      CALL CHSPPF(.9995,IDF,CTU999)
32559C
32560      PVALLT=STATCD
32561      PVALUT=1.0 - STATCD
32562      IF(YSD.LE.SIGMA0)THEN
32563        PVAL2T=2.0*STATCD
32564      ELSE
32565        PVAL2T=2.0*(1.0 - STATCD)
32566      ENDIF
32567C
32568C               *******************************
32569C               **   STEP 32--               **
32570C               **   WRITE OUT EVERYTHING    **
32571C               **   FOR A CHI-SQUARED TEST  **
32572C               *******************************
32573C
32574      ISTEPN='22'
32575      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CST2')
32576     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
32577C
32578      IF(IPRINT.EQ.'OFF')GOTO9000
32579C
32580      ITITLE='One Sample Chi-Square Standard Deviation Test'
32581      NCTITL=45
32582      ITITLZ=' '
32583      NCTITZ=0
32584C
32585      ICNT=1
32586      ITEXT(ICNT)=' '
32587      NCTEXT(ICNT)=0
32588      AVALUE(ICNT)=0.0
32589      IDIGIT(ICNT)=-1
32590C
32591      ICNT=ICNT+1
32592      ITEXT(ICNT)='Response Variable: '
32593      WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1:4)
32594      WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1:4)
32595      NCTEXT(ICNT)=27
32596      AVALUE(ICNT)=0.0
32597      IDIGIT(ICNT)=-1
32598C
32599      ICNT=ICNT+1
32600      ITEXT(ICNT)=' '
32601      NCTEXT(ICNT)=1
32602      AVALUE(ICNT)=0.0
32603      IDIGIT(ICNT)=-1
32604C
32605      ICNT=ICNT+1
32606      ITEXT(ICNT)='H0: Standard Deviation Equal'
32607      NCTEXT(ICNT)=28
32608      AVALUE(ICNT)=SIGMA0
32609      IDIGIT(ICNT)=NUMDIG
32610      ICNT=ICNT+1
32611      ITEXT(ICNT)='H0: Standard Deviation Not Equal'
32612      NCTEXT(ICNT)=32
32613      AVALUE(ICNT)=SIGMA0
32614      IDIGIT(ICNT)=NUMDIG
32615C
32616      ICNT=ICNT+1
32617      ITEXT(ICNT)=' '
32618      NCTEXT(ICNT)=1
32619      AVALUE(ICNT)=0.0
32620      IDIGIT(ICNT)=-1
32621      ICNT=ICNT+1
32622      ITEXT(ICNT)='Summary Statistics:'
32623      NCTEXT(ICNT)=19
32624      AVALUE(ICNT)=0.0
32625      IDIGIT(ICNT)=-1
32626      ICNT=ICNT+1
32627      ITEXT(ICNT)='Number of Observations:'
32628      NCTEXT(ICNT)=23
32629      AVALUE(ICNT)=REAL(N1)
32630      IDIGIT(ICNT)=0
32631      ICNT=ICNT+1
32632      ITEXT(ICNT)='Sample Mean:'
32633      NCTEXT(ICNT)=12
32634      AVALUE(ICNT)=YMEAN
32635      IDIGIT(ICNT)=NUMDIG
32636      ICNT=ICNT+1
32637      ITEXT(ICNT)='Sample Standard Deviation:'
32638      NCTEXT(ICNT)=26
32639      AVALUE(ICNT)=YSD
32640      IDIGIT(ICNT)=NUMDIG
32641      ICNT=ICNT+1
32642      ITEXT(ICNT)=' '
32643      NCTEXT(ICNT)=1
32644      AVALUE(ICNT)=0.0
32645      IDIGIT(ICNT)=-1
32646C
32647      ICNT=ICNT+1
32648      ITEXT(ICNT)='Test:'
32649      NCTEXT(ICNT)=5
32650      AVALUE(ICNT)=0.0
32651      IDIGIT(ICNT)=-1
32652      ICNT=ICNT+1
32653      ITEXT(ICNT)='s/sigma0'
32654      NCTEXT(ICNT)=8
32655      AVALUE(ICNT)=RATIO
32656      IDIGIT(ICNT)=NUMDIG
32657      ICNT=ICNT+1
32658      ITEXT(ICNT)='Chi-Square Test Statistic Value:'
32659      NCTEXT(ICNT)=32
32660      AVALUE(ICNT)=STATVA
32661      IDIGIT(ICNT)=NUMDIG
32662      ICNT=ICNT+1
32663      ITEXT(ICNT)='Degrees of Freedom:'
32664      NCTEXT(ICNT)=19
32665      AVALUE(ICNT)=INT(STATNU+0.1)
32666      IDIGIT(ICNT)=0
32667      ICNT=ICNT+1
32668      ITEXT(ICNT)='CDF Value:'
32669      NCTEXT(ICNT)=10
32670      AVALUE(ICNT)=STATCD
32671      IDIGIT(ICNT)=NUMDIG
32672      ICNT=ICNT+1
32673      ITEXT(ICNT)='P-Value (2-tailed test):'
32674      NCTEXT(ICNT)=24
32675      AVALUE(ICNT)=PVAL2T
32676      IDIGIT(ICNT)=NUMDIG
32677      ICNT=ICNT+1
32678      ITEXT(ICNT)='P-Value (lower-tailed test):'
32679      NCTEXT(ICNT)=28
32680      AVALUE(ICNT)=PVALLT
32681      IDIGIT(ICNT)=NUMDIG
32682      ICNT=ICNT+1
32683      ITEXT(ICNT)='P-Value (upper-tailed test):'
32684      NCTEXT(ICNT)=28
32685      AVALUE(ICNT)=PVALUT
32686      IDIGIT(ICNT)=NUMDIG
32687C
32688      NUMROW=ICNT
32689      DO2110I=1,NUMROW
32690        NTOT(I)=15
32691 2110 CONTINUE
32692C
32693      IFRST=.TRUE.
32694      ILAST=.TRUE.
32695C
32696      ISTEPN='21A'
32697      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CST2')
32698     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
32699C
32700      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
32701     1            AVALUE,IDIGIT,
32702     1            NTOT,NUMROW,
32703     1            ICAPSW,ICAPTY,ILAST,IFRST,
32704     1            ISUBRO,IBUGA3,IERROR)
32705C
32706      ISTEPN='21B'
32707      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CST2')
32708     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
32709C
32710      ITITLE='Two-Tailed Test'
32711      NCTITL=15
32712      ITITL9='H0: sigma = sigma0; Ha: sigma <> sigma0'
32713      NCTIT9=39
32714C
32715      DO2130J=1,5
32716        DO2140I=1,3
32717          ITITL2(I,J)=' '
32718          NCTIT2(I,J)=0
32719 2140   CONTINUE
32720 2130 CONTINUE
32721C
32722      ITITL2(2,1)='Significance'
32723      NCTIT2(2,1)=12
32724      ITITL2(3,1)='Level'
32725      NCTIT2(3,1)=5
32726C
32727      ITITL2(2,2)='Test '
32728      NCTIT2(2,2)=4
32729      ITITL2(3,2)='Statistic'
32730      NCTIT2(3,2)=9
32731C
32732      ITITL2(1,3)='Lower'
32733      NCTIT2(1,3)=5
32734      ITITL2(2,3)='Critical'
32735      NCTIT2(2,3)=8
32736      ITITL2(3,3)='Value (<)'
32737      NCTIT2(3,3)=9
32738C
32739      ITITL2(1,4)='Upper'
32740      NCTIT2(1,4)=5
32741      ITITL2(2,4)='Critical'
32742      NCTIT2(2,4)=8
32743      ITITL2(3,4)='Value (>)'
32744      NCTIT2(3,4)=9
32745C
32746      ITITL2(1,5)='Null'
32747      NCTIT2(1,5)=4
32748      ITITL2(2,5)='Hypothesis'
32749      NCTIT2(2,5)=10
32750      ITITL2(3,5)='Conclusion'
32751      NCTIT2(3,5)=10
32752C
32753      NMAX=0
32754      NUMCOL=5
32755      DO2150I=1,NUMCOL
32756        VALIGN(I)='b'
32757        ALIGN(I)='r'
32758        NTOT(I)=15
32759        NMAX=NMAX+NTOT(I)
32760        ITYPCO(I)='NUME'
32761        IDIGIT(I)=NUMDIG
32762        IF(I.EQ.1 .OR. I.EQ.5)THEN
32763          ITYPCO(I)='ALPH'
32764        ENDIF
32765 2150 CONTINUE
32766C
32767      IWHTML(1)=125
32768      IWHTML(2)=150
32769      IWHTML(3)=150
32770      IWHTML(4)=150
32771      IWHTML(5)=150
32772      IINC=1600
32773      IINC2=1400
32774      IWRTF(1)=IINC
32775      IWRTF(2)=IWRTF(1)+IINC
32776      IWRTF(3)=IWRTF(2)+IINC
32777      IWRTF(4)=IWRTF(3)+IINC
32778      IWRTF(5)=IWRTF(4)+IINC
32779C
32780      DO2160J=1,NUMALP
32781C
32782        AMAT(J,2)=STATVA
32783        ALPHAT=(1.0 - ALPHA(J))/2.0
32784        CALL CHSPPF(ALPHAT,IDF,ATEMP)
32785        AMAT(J,3)=ATEMP
32786        ALPHAT=1.0 - ALPHAT
32787        CALL CHSPPF(ALPHAT,IDF,ATEMP)
32788        AMAT(J,4)=ATEMP
32789        IVALUE(J,5)(1:6)='ACCEPT'
32790        IF(STATVA.LT.AMAT(J,3))IVALUE(J,5)(1:6)='REJECT'
32791        IF(STATVA.GT.AMAT(J,4))IVALUE(J,5)(1:6)='REJECT'
32792        NCVALU(J,5)=6
32793C
32794        ALPHAT=100.0*ALPHA(J)
32795        WRITE(IVALUE(J,1)(1:4),'(F4.1)')ALPHAT
32796        IVALUE(J,1)(5:5)='%'
32797        NCVALU(J,1)=5
32798 2160 CONTINUE
32799C
32800      ICNT=NUMALP
32801      NUMLIN=3
32802      IFRST=.TRUE.
32803      ILAST=.TRUE.
32804      IFLAGS=.TRUE.
32805      IFLAGE=.TRUE.
32806      IF(ICASA2.NE.'LOWE' .AND. ICASA2.NE.'UPPE')THEN
32807        CALL DPDTA5(ITITLE,NCTITL,
32808     1              ITITL9,NCTIT9,ITITL2,NCTIT2,
32809     1              MAXLIN,NUMLIN,NUMCLI,NUMCOL,
32810     1              IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
32811     1              IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
32812     1              ICAPSW,ICAPTY,IFRST,ILAST,
32813     1              IFLAGS,IFLAGE,
32814     1              ISUBRO,IBUGA3,IERROR)
32815      ENDIF
32816      IF(ICASA2.EQ.'TWOT')GOTO9000
32817C
32818      ITITLE='Lower-Tailed Test'
32819      NCTITL=17
32820      ITITL9='H0: sigma = sigma0; Ha: sigma < sigma0'
32821      NCTIT9=38
32822C
32823      ITITL2(1,3)='Lower'
32824      NCTIT2(1,3)=5
32825      ITITL2(2,3)='Critical'
32826      NCTIT2(2,3)=8
32827      ITITL2(3,3)='Value (<)'
32828      NCTIT2(3,3)=9
32829C
32830      ITITL2(1,4)='Null'
32831      NCTIT2(1,4)=4
32832      ITITL2(2,4)='Hypothesis'
32833      NCTIT2(2,4)=10
32834      ITITL2(3,4)='Conclusion'
32835      NCTIT2(3,4)=10
32836C
32837      NMAX=0
32838      NUMCOL=4
32839      DO2250I=1,NUMCOL
32840        VALIGN(I)='b'
32841        ALIGN(I)='r'
32842        NTOT(I)=15
32843        NMAX=NMAX+NTOT(I)
32844        ITYPCO(I)='NUME'
32845        IDIGIT(I)=NUMDIG
32846        IF(I.EQ.1 .OR. I.EQ.4)THEN
32847          ITYPCO(I)='ALPH'
32848        ENDIF
32849 2250 CONTINUE
32850C
32851      DO2260J=1,NUMALP
32852C
32853        AMAT(J,2)=STATVA
32854        ALPHAT=(1.0 - ALPHA(J))
32855        CALL CHSPPF(ALPHAT,IDF,ATEMP)
32856        AMAT(J,3)=ATEMP
32857        IVALUE(J,4)(1:6)='ACCEPT'
32858        IF(STATVA.LT.AMAT(J,3))IVALUE(J,4)(1:6)='REJECT'
32859        NCVALU(J,4)=6
32860C
32861        ALPHAT=100.0*ALPHA(J)
32862        WRITE(IVALUE(J,1)(1:4),'(F4.1)')ALPHAT
32863        IVALUE(J,1)(5:5)='%'
32864        NCVALU(J,1)=5
32865 2260 CONTINUE
32866C
32867      ICNT=NUMALP
32868      NUMLIN=3
32869      IFRST=.TRUE.
32870      ILAST=.TRUE.
32871      IFLAGS=.TRUE.
32872      IFLAGE=.TRUE.
32873      IF(ICASA2.NE.'UPPE')THEN
32874        CALL DPDTA5(ITITLE,NCTITL,
32875     1              ITITL9,NCTIT9,ITITL2,NCTIT2,
32876     1              MAXLIN,NUMLIN,NUMCLI,NUMCOL,
32877     1              IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
32878     1              IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
32879     1              ICAPSW,ICAPTY,IFRST,ILAST,
32880     1              IFLAGS,IFLAGE,
32881     1              ISUBRO,IBUGA3,IERROR)
32882      ENDIF
32883      IF(ICASA2.EQ.'LOWE')GOTO9000
32884C
32885      ITITLE='Upper-Tailed Test'
32886      NCTITL=17
32887      ITITL9='H0: sigma = sigma0; Ha: sigma > sigma0'
32888      NCTIT9=38
32889C
32890      ITITL2(1,3)='Upper'
32891      NCTIT2(1,3)=5
32892      ITITL2(2,3)='Critical'
32893      NCTIT2(2,3)=8
32894      ITITL2(3,3)='Value (>)'
32895      NCTIT2(3,3)=9
32896C
32897      NMAX=0
32898      NUMCOL=4
32899      DO2350I=1,NUMCOL
32900        NTOT(I)=15
32901        NMAX=NMAX+NTOT(I)
32902 2350 CONTINUE
32903C
32904      DO2360J=1,NUMALP
32905C
32906        ALPHAT=ALPHA(J)
32907        CALL CHSPPF(ALPHAT,IDF,ATEMP)
32908        AMAT(J,3)=ATEMP
32909        IVALUE(J,4)(1:6)='ACCEPT'
32910        IF(STATVA.GT.AMAT(J,3))IVALUE(J,4)(1:6)='REJECT'
32911        NCVALU(J,4)=6
32912 2360 CONTINUE
32913C
32914      ICNT=NUMALP
32915      NUMLIN=3
32916      IFRST=.TRUE.
32917      ILAST=.TRUE.
32918      IFLAGS=.TRUE.
32919      IFLAGE=.TRUE.
32920      IF(ICASA2.NE.'LOWE')THEN
32921        CALL DPDTA5(ITITLE,NCTITL,
32922     1              ITITL9,NCTIT9,ITITL2,NCTIT2,
32923     1              MAXLIN,NUMLIN,NUMCLI,NUMCOL,
32924     1              IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
32925     1              IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
32926     1              ICAPSW,ICAPTY,IFRST,ILAST,
32927     1              IFLAGS,IFLAGE,
32928     1              ISUBRO,IBUGA3,IERROR)
32929      ENDIF
32930C
32931C
32932C               *****************
32933C               **  STEP 90--  **
32934C               **  EXIT       **
32935C               *****************
32936C
32937 9000 CONTINUE
32938      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CST2')THEN
32939        WRITE(ICOUT,999)
32940        CALL DPWRST('XXX','WRIT')
32941        WRITE(ICOUT,9011)
32942 9011   FORMAT('***** AT THE END       OF DPCST2--')
32943        CALL DPWRST('XXX','WRIT')
32944        WRITE(ICOUT,9013)IERROR,STATVA,STATCD,STATNU
32945 9013   FORMAT('IERROR,STATVA,STATCD,STATNU = ',A4,3G15.7)
32946        CALL DPWRST('XXX','WRIT')
32947      ENDIF
32948C
32949      RETURN
32950      END
32951      SUBROUTINE DPCST3(X,N,SIGMA0,IWRITE,
32952     1                  STATVA,STATCD,STATNU,
32953     1                  XMEAN,XSD,RATIO,
32954     1                  ISUBRO,IBUGA3,IERROR)
32955C
32956C     PURPOSE--THIS SUBROUTINE COMPUTES THE ONE SAMPLE CHI-SQUARE TEST
32957C              (AND ALTERNATIVELY THE CDF VALUE).
32958C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
32959C                                (UNSORTED OR SORTED) OBSERVATIONS.
32960C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
32961C                                IN THE VECTOR X.
32962C                     --SIGMA0 = THE SINGLE PRECISION VALUE FOR WHICH
32963C                                THE TEST IS PERFORMED (I.E.,
32964C                                H0: SIGMA = SIGMA0).
32965C     OUTPUT ARGUMENTS--STATVA = THE SINGLE PRECISION VALUE OF THE
32966C                                COMPUTED STATISTIC.
32967C                     --STATCD = THE SINGLE PRECISION VALUE OF THE
32968C                                COMPUTED CDF OF THE TEST STATISTIC.
32969C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
32970C             TEST STATISTIC.
32971C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
32972C                   OF N FOR THIS SUBROUTINE.
32973C     OTHER DATAPAC   SUBROUTINES NEEDED--CHSCDF.
32974C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
32975C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
32976C     LANGUAGE--ANSI FORTRAN (1977)
32977C     WRITTEN BY--JAMES J. FILLIBEN
32978C                 STATISTICAL ENGINEERING DIVISION
32979C                 INFORMATION TECHNOLOGY LABORATORY
32980C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
32981C                 GAITHERSBURG, MD 20899-8980
32982C                 PHONE--301-975-2855
32983C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
32984C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
32985C     LANGUAGE--ANSI FORTRAN (1977)
32986C     VERSION NUMBER--2009.2
32987C     ORIGINAL VERSION--FEBRUARY  2009.
32988C
32989C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
32990C
32991      CHARACTER*4 IWRITE
32992      CHARACTER*4 IWRTSV
32993      CHARACTER*4 ISUBRO
32994      CHARACTER*4 IBUGA3
32995      CHARACTER*4 IERROR
32996C
32997      CHARACTER*4 ISUBN1
32998      CHARACTER*4 ISUBN2
32999C
33000C---------------------------------------------------------------------
33001C
33002      DIMENSION X(*)
33003C
33004C---------------------------------------------------------------------
33005C
33006      INCLUDE 'DPCOP2.INC'
33007C
33008C-----START POINT-----------------------------------------------------
33009C
33010      ISUBN1='DPCS'
33011      ISUBN2='T3  '
33012      IWRTSV=IWRITE
33013C
33014      IERROR='NO'
33015C
33016      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CST3')THEN
33017        WRITE(ICOUT,999)
33018  999   FORMAT(1X)
33019        CALL DPWRST('XXX','BUG ')
33020        WRITE(ICOUT,51)
33021   51   FORMAT('***** AT THE BEGINNING OF DPCST3--')
33022        CALL DPWRST('XXX','BUG ')
33023        WRITE(ICOUT,52)IBUGA3
33024   52   FORMAT('IBUGA3 = ',A4)
33025        CALL DPWRST('XXX','BUG ')
33026        WRITE(ICOUT,53)N,SIGMA0
33027   53   FORMAT('N,SIGMA0 = ',I8,G15.7)
33028        CALL DPWRST('XXX','BUG ')
33029        DO55I=1,N
33030          WRITE(ICOUT,56)I,X(I)
33031   56     FORMAT('I,X(I) = ',I8,G15.7)
33032          CALL DPWRST('XXX','BUG ')
33033   55   CONTINUE
33034      ENDIF
33035C
33036C               ******************************************
33037C               **  COMPUTE ONE SAMPLE CHI-SQUARE TEST  **
33038C               ******************************************
33039C
33040C               ********************************************
33041C               **  STEP 1--                              **
33042C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
33043C               ********************************************
33044C
33045      STATVA=-99.0
33046      STATCD=-99.0
33047      IWRITE='OFF'
33048C
33049      AN=N
33050C
33051      IF(N.LE.1)THEN
33052        IERROR='YES'
33053        WRITE(ICOUT,999)
33054        CALL DPWRST('XXX','BUG ')
33055        WRITE(ICOUT,111)
33056  111   FORMAT('***** ERROR IN CHI-SQUARE SD TEST--')
33057        CALL DPWRST('XXX','BUG ')
33058        WRITE(ICOUT,112)
33059  112   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS FOR THE ',
33060     1         'RESPONSE')
33061        CALL DPWRST('XXX','BUG ')
33062        WRITE(ICOUT,113)
33063  113   FORMAT('      VARIABLE MUST BE 2 OR LARGER.')
33064        CALL DPWRST('XXX','BUG ')
33065        WRITE(ICOUT,116)
33066  116   FORMAT('      SUCH WAS NOT THE CASE HERE.')
33067        CALL DPWRST('XXX','BUG ')
33068        WRITE(ICOUT,117)N
33069  117   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
33070     1         '.')
33071        CALL DPWRST('XXX','BUG ')
33072        GOTO9000
33073      ENDIF
33074C
33075      IF(SIGMA0.LE.0.0)THEN
33076        WRITE(ICOUT,999)
33077        CALL DPWRST('XXX','WRIT')
33078        WRITE(ICOUT,111)
33079        CALL DPWRST('XXX','WRIT')
33080        WRITE(ICOUT,1101)
33081 1101   FORMAT('      THE SPECIFIED SIGMA0 IS NON-POSITIVE.')
33082        CALL DPWRST('XXX','WRIT')
33083        WRITE(ICOUT,1102)SIGMA0
33084 1102   FORMAT('SIGMA0 = ',G15.7)
33085        CALL DPWRST('XXX','WRIT')
33086        IERROR='YES'
33087        GOTO9000
33088      ENDIF
33089C
33090      HOLD=X(1)
33091      DO1135I=2,N
33092        IF(X(I).NE.HOLD)GOTO1139
33093 1135 CONTINUE
33094      WRITE(ICOUT,999)
33095      CALL DPWRST('XXX','WRIT')
33096      WRITE(ICOUT,111)
33097      CALL DPWRST('XXX','WRIT')
33098      WRITE(ICOUT,1131)HOLD
33099 1131 FORMAT('      THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7)
33100      CALL DPWRST('XXX','WRIT')
33101      IERROR='YES'
33102      GOTO9000
33103 1139 CONTINUE
33104C
33105C               ***********************************************
33106C               **  STEP 2--                                 **
33107C               **  COMPUTE THE ONE SAMPLE CHI-SQUARE TEST.  **
33108C               ***********************************************
33109C
33110      CALL MEAN(X,N,IWRITE,XMEAN,IBUGA3,IERROR)
33111      CALL SD(X,N,IWRITE,XSD,IBUGA3,IERROR)
33112      AN=N
33113      RATIO=XSD/SIGMA0
33114      STATVA=(AN-1.0)*RATIO**2
33115      IDF=N-1
33116      STATNU=REAL(IDF)
33117      CALL CHSCDF(STATVA,IDF,STATCD)
33118C
33119C               *******************************
33120C               **  STEP 3--                 **
33121C               **  WRITE OUT A LINE         **
33122C               **  OF SUMMARY INFORMATION.  **
33123C               *******************************
33124C
33125      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
33126        WRITE(ICOUT,999)
33127        CALL DPWRST('XXX','BUG ')
33128        WRITE(ICOUT,811)N,STATVA
33129  811   FORMAT('THE VALUE OF THE CHI-SQUARE SD TEST OF THE ',I8,
33130     1         ' OBSERVATIONS = ',G15.7)
33131        CALL DPWRST('XXX','BUG ')
33132      ENDIF
33133C
33134C               *****************
33135C               **  STEP 90--  **
33136C               **  EXIT.      **
33137C               *****************
33138C
33139 9000 CONTINUE
33140C
33141      IWRITE=IWRTSV
33142C
33143      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CST3')THEN
33144        WRITE(ICOUT,999)
33145        CALL DPWRST('XXX','BUG ')
33146        WRITE(ICOUT,9011)
33147 9011   FORMAT('***** AT THE END       OF DPCST3--')
33148        CALL DPWRST('XXX','BUG ')
33149        WRITE(ICOUT,9012)IBUGA3,IERROR
33150 9012   FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
33151        CALL DPWRST('XXX','BUG ')
33152        WRITE(ICOUT,9015)STATVA,STATCD
33153 9015   FORMAT('STATVA,STATCD = ',2G15.7)
33154        CALL DPWRST('XXX','BUG ')
33155        WRITE(ICOUT,9016)XMEAN,XSD
33156 9016   FORMAT('XMEAN,XSD = ',2G15.7)
33157        CALL DPWRST('XXX','BUG ')
33158      ENDIF
33159C
33160      RETURN
33161      END
33162      SUBROUTINE DPCVCI(XTEMP1,XTEMP2,MAXNXT,ICASAN,
33163     1                  ICAPSW,IFORSW,IMULT,IREPL,ISEED,
33164     1                  ISUBRO,IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
33165C
33166C     PURPOSE--GENERATE A CONFIDENCE INTERVAL FOR THE COEFFICIENT OF
33167C              VARIATION FOR NORMALLY DISTRIBUTED DATA.  THE FOLLOWING
33168C              ARE SUPPORTED:
33169C
33170C                  COEFFICIENT OF VARIATION CONFIDENCE LIMIT Y
33171C                  LOGNORMAL COEFFICIENT OF VARIATION CONFIDENCE LIMIT Y
33172C                  COMMON COEFFICIENT OF VARIATION CONFIDENCE LIMIT Y X
33173C
33174C              THE REPLICATION AND MULTIPLE KEYWORDS ARE SUPPORTED FOR
33175C              THE SINGLE VARIABLE CASE.  THE MULTIPLE OPTION IS
33176C              SUPPORTED FOR THE TWO VARIABLE (COMMON) CASE.
33177C
33178C              THE ONE SIDED <LOWER/UPPER> OPTIONS ARE ALSO SUPPORTED.
33179C
33180C              IN ADDITION, SUPPORT
33181C
33182C                 CONFIDENCE INTERVAL FOR COEFFICIENT OF DISPERSION
33183C                 CONFIDENCE INTERVAL FOR COEFFICIENT OF QUARTILE DISPERSION
33184C
33185C     WRITTEN BY--ALAN HECKERT
33186C                 STATISTICAL ENGINEERING DIVISION
33187C                 INFORMATION TECHNOLOGY LABORATORY
33188C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
33189C                 GAITHERSBURG, MD 20899-8980
33190C                 PHONE--301-975-2899
33191C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
33192C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
33193C     LANGUAGE--ANSI FORTRAN (1977)
33194C     VERSION NUMBER--2016/12
33195C     REFERENCES--MARK VANGEL (1996), "CONFIDENCE INTERVALS FOR A NORMAL
33196C                 COEFFICIENT OF VARIATION", AMERICAN STATISTICIAN,
33197C                 VOL. 15, NO. 1, PP. 21-26.
33198C                 GUIDE FOR PRACTIONERS", WILEY, PP. 55-56.
33199C               --MCKAY (1932), "DISTRIBUTIONS OF THE COEFFICIENT OF
33200C                 VARIATION AND THE EXTENDED 't' DISTRIBUTION", JOURNAL
33201C                 OF THE ROYAL STATISTICAL SOCIETY, VOL. 95, PP. 695-698.
33202C               --Steve Verrill, Confidence Bounds for Normal and
33203C                 Lognormal Distribution Coefficients of Variation, 2003,
33204C                 Research Paper 609, USDA Forest Products Laboratory,
33205C                 Madison, Wisconsin.
33206C               --Verrill, S. and Johnson, R.A. (2007). "Confidence
33207C                 Bounds and Hypothesis Tests for Normal Distribution
33208C                 Coefficients of Variation." Communications in Statistics
33209C                 Theory and Methods, Volume 36, Number 12, pages 2187-2206.
33210C               --JOHANNES FORKMAN (xxxx), "ESTIMATOR AND TESTS FOR
33211C                 COMMON COEFFICIENTS OF VARIATION IN NORMAL
33212C                 DISTRIBUTIONS",
33213C               --BONETT AND SEIER (2006), "CONFIDENCE INTERVAL FOR A
33214C                 COEFFICIENT OF DISPERSION", BIOMETRICAL JOURNAL,
33215C                 VOL. 48, NO. 1, PP. 144-148.
33216C     ORIGINAL VERSION--JANUARY   2017.
33217C     UPDATED         --NOVEMBER  2017. SUPPORT FOR COEFFICIENT OF
33218C                                       DISPERSION CONFIDENCE INTERVAL
33219C     UPDATED         --DECEMBER  2017. SUPPORT FOR COEFFICIENT OF
33220C                                       QUARTILE DISPERSION CONFIDENCE
33221C                                       INTERVAL
33222C
33223C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
33224C
33225      CHARACTER*4 ICAPSW
33226      CHARACTER*4 IFORSW
33227      CHARACTER*4 ISUBRO
33228      CHARACTER*4 IBUGA2
33229      CHARACTER*4 IBUGA3
33230      CHARACTER*4 IBUGQ
33231      CHARACTER*4 IFOUND
33232      CHARACTER*4 IERROR
33233C
33234      CHARACTER*4 IHWUSE
33235      CHARACTER*4 MESSAG
33236      CHARACTER*4 IH
33237      CHARACTER*4 IH2
33238      CHARACTER*4 ICASAN
33239      CHARACTER*4 ICASA2
33240      CHARACTER*4 ICASA3
33241      CHARACTER*4 ICASA4
33242      CHARACTER*4 ICASE
33243      CHARACTER*4 ISUBN1
33244      CHARACTER*4 ISUBN2
33245      CHARACTER*4 ISTEPN
33246      CHARACTER*4 IFLAGU
33247C
33248      CHARACTER*4 IREPL
33249      CHARACTER*4 IMULT
33250      CHARACTER*4 ICOMM
33251      CHARACTER*4 IDIST
33252      CHARACTER*4 ICTMP0
33253      CHARACTER*4 ICTMP1
33254      CHARACTER*4 ICTMP2
33255      CHARACTER*4 ICTMP3
33256      CHARACTER*4 ICTMP4
33257      CHARACTER*4 ICTMP5
33258      CHARACTER*4 ICTMP6
33259C
33260      LOGICAL IFRST
33261      LOGICAL ILAST
33262C
33263      CHARACTER*40 INAME
33264      PARAMETER (MAXSPN=30)
33265      CHARACTER*4 IVARN1(MAXSPN)
33266      CHARACTER*4 IVARN2(MAXSPN)
33267      CHARACTER*4 IVARTY(MAXSPN)
33268      CHARACTER*4 IVARID(MAXSPN)
33269      CHARACTER*4 IVARI2(MAXSPN)
33270      REAL PVAR(MAXSPN)
33271      REAL PID(MAXSPN)
33272      INTEGER ILIS(MAXSPN)
33273      INTEGER NRIGHT(MAXSPN)
33274      INTEGER ICOLR(MAXSPN)
33275C
33276C---------------------------------------------------------------------
33277C
33278      INCLUDE 'DPCOPA.INC'
33279C
33280      DIMENSION XTEMP1(*)
33281      DIMENSION XTEMP2(*)
33282      DIMENSION TEMP1(MAXOBV)
33283      DIMENSION TEMP2(MAXOBV)
33284      DIMENSION TEMP3(MAXOBV)
33285      DIMENSION TEMP4(MAXOBV)
33286C
33287      DIMENSION XDESGN(MAXOBV,6)
33288      DIMENSION XIDTEM(MAXOBV)
33289      DIMENSION XIDTE2(MAXOBV)
33290      DIMENSION XIDTE3(MAXOBV)
33291      DIMENSION XIDTE4(MAXOBV)
33292      DIMENSION XIDTE5(MAXOBV)
33293      DIMENSION XIDTE6(MAXOBV)
33294C
33295      INTEGER ITEMP1(MAXOBV)
33296C
33297      INCLUDE 'DPCOZZ.INC'
33298      INCLUDE 'DPCOZI.INC'
33299      EQUIVALENCE (GARBAG(IGARB1),XIDTEM(1))
33300      EQUIVALENCE (GARBAG(IGARB2),XIDTE2(1))
33301      EQUIVALENCE (GARBAG(IGARB3),XIDTE3(1))
33302      EQUIVALENCE (GARBAG(IGARB4),XIDTE4(1))
33303      EQUIVALENCE (GARBAG(IGARB5),XIDTE5(1))
33304      EQUIVALENCE (GARBAG(IGARB6),XIDTE6(1))
33305      EQUIVALENCE (GARBAG(IGARB7),TEMP1(1))
33306      EQUIVALENCE (GARBAG(IGARB8),TEMP2(1))
33307      EQUIVALENCE (GARBAG(IGARB9),TEMP3(1))
33308      EQUIVALENCE (GARBAG(IGAR10),TEMP4(1))
33309      EQUIVALENCE (GARBAG(JGAR11),XDESGN(1,1))
33310      EQUIVALENCE (IGARBG(IIGAR1),ITEMP1(1))
33311C
33312C-----COMMON----------------------------------------------------------
33313C
33314      INCLUDE 'DPCOHK.INC'
33315      INCLUDE 'DPCOSU.INC'
33316      INCLUDE 'DPCODA.INC'
33317      INCLUDE 'DPCOHO.INC'
33318      INCLUDE 'DPCOST.INC'
33319C
33320C-----COMMON VARIABLES (GENERAL)--------------------------------------
33321C
33322      INCLUDE 'DPCOP2.INC'
33323C
33324C-----START POINT-----------------------------------------------------
33325C
33326      ISUBN1='DPCV'
33327      ISUBN2='CI  '
33328      IFOUND='YES'
33329      IERROR='NO'
33330      IREPL='OFF'
33331      IMULT='OFF'
33332      ICOMM='OFF'
33333C
33334      MAXCP1=MAXCOL+1
33335      MAXCP2=MAXCOL+2
33336      MAXCP3=MAXCOL+3
33337      MAXCP4=MAXCOL+4
33338      MAXCP5=MAXCOL+5
33339      MAXCP6=MAXCOL+6
33340      MAXNXT=MAXOBV
33341C
33342C               ****************************************************
33343C               **  TREAT THE COEFFICIENT OF VARIATION CONFIDENCE **
33344C               **  LIMITS CASE                                   **
33345C               ****************************************************
33346C
33347      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CVCI')THEN
33348        WRITE(ICOUT,999)
33349  999   FORMAT(1X)
33350        CALL DPWRST('XXX','BUG ')
33351        WRITE(ICOUT,51)
33352   51   FORMAT('***** AT THE BEGINNING OF DPCVCI--')
33353        CALL DPWRST('XXX','BUG ')
33354        WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ,ISUBRO,MAXNXT
33355   52   FORMAT('IBUGA2,IBUGA3,IBUGQ,ISUBRO,MAXNXT = ',4(A4,2X),I8)
33356        CALL DPWRST('XXX','BUG ')
33357      ENDIF
33358C
33359C               *********************************
33360C               **  STEP 1--                   **
33361C               **  EXTRACT THE COMMAND        **
33362C               *********************************
33363C
33364      ISTEPN='1'
33365      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CVCI')
33366     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
33367C
33368C     THE FOLLOWING COMMANDS ARE ACCEPTED:
33369C
33370C         COEFFICIENT OF VARIATION CONFIDENCE LIMITS Y        (TWO SIDED)
33371C         LOWER COEFFICIENT OF VARIATION CONFIDENCE LIMITS Y  (ONE SIDED)
33372C         UPPER COEFFICIENT OF VARIATION CONFIDENCE LIMITS Y  (ONE SIDED)
33373C         LOGNORMAL COEFFICIENT OF VARIATION CONFIDENCE
33374C                   LIMITS Y                                  (TWO SIDED)
33375C         LOWER LOGNORMAL COEFFICIENT OF VARIATION
33376C               CONFIDENCE LIMITS Y                           (ONE SIDED)
33377C         UPPER LOGNORMAL COEFFICIENTOF VARIATION
33378C               CONFIDENCE LIMITS Y                           (ONE SIDED)
33379C         COMMON COEFFICIENT OF VARIATION CONFIDENCE LIMITS Y X (TWO SIDED)
33380C         COEFFICIENT OF DISPERSION CONFIDENCE LIMITS Y       (TWO SIDED)
33381C         LOWER COEFFICIENT OF DISPERSION CONFIDENCE LIMITS Y (ONE SIDED)
33382C         UPPER COEFFICIENT OF DISPERSION CONFIDENCE LIMITS Y (ONE SIDED)
33383C         COEFFICIENT OF QUARTILE DISPERSION CONFIDENCE LIMITS Y       (TWO SIDED)
33384C         LOWER COEFFICIENT OF QUARTILE DISPERSION CONFIDENCE LIMITS Y (ONE SIDED)
33385C         UPPER COEFFICIENT OF QUARTILE DISPERSION CONFIDENCE LIMITS Y (ONE SIDED)
33386C
33387C     IN ADDITION, CHECK FOR THE "MULTIPLE" AND "REPLICATION" OPTIONS.
33388C
33389      ILASTZ=9999
33390      IFOUND='NO'
33391      ICASAN='CVLI'
33392      ICASA2='UPPE'
33393      ICASA3='RAW'
33394      ICASA4='TWOS'
33395      IDIST='NORM'
33396C
33397      DO100I=0,NUMARG-1
33398C
33399        ICTMP0='XXXX'
33400        IF(I.EQ.0)THEN
33401          ICTMP1=ICOM
33402          ICTMP2=IHARG(I+1)
33403          ICTMP3=IHARG(I+2)
33404          ICTMP4=IHARG(I+3)
33405          ICTMP5=IHARG(I+4)
33406          ICTMP6=IHARG(I+5)
33407        ELSE
33408          IF(I.GE.2)ICTMP0=IHARG(I-1)
33409          ICTMP1=IHARG(I)
33410          ICTMP2=IHARG(I+1)
33411          ICTMP3=IHARG(I+2)
33412          ICTMP4=IHARG(I+3)
33413          ICTMP5=IHARG(I+4)
33414          ICTMP6=IHARG(I+5)
33415        ENDIF
33416C
33417        IF(ICTMP1.EQ.'COEF' .AND. ICTMP2.EQ.'OF  ' .AND.
33418     1     ICTMP3.EQ.'VARI' .AND. ICTMP4.EQ.'CONF' .AND.
33419     1     ICTMP5.EQ.'LIMI')THEN
33420          IFOUND='YES'
33421          ILASTZ=I+4
33422          ICASAN='CVLI'
33423          GOTO109
33424        ELSEIF(ICTMP1.EQ.'COEF' .AND. ICTMP2.EQ.'OF  ' .AND.
33425     1         ICTMP3.EQ.'VARI' .AND. ICTMP4.EQ.'CONF' .AND.
33426     1         ICTMP5.EQ.'INTE')THEN
33427          IFOUND='YES'
33428          ILASTZ=I+4
33429          ICASAN='CVLI'
33430          GOTO109
33431        ELSEIF(ICTMP1.EQ.'COEF' .AND. ICTMP2.EQ.'OF  ' .AND.
33432     1         ICTMP3.EQ.'DISP' .AND. ICTMP4.EQ.'CONF' .AND.
33433     1         ICTMP5.EQ.'LIMI')THEN
33434          IFOUND='YES'
33435          ILASTZ=I+4
33436          ICASAN='CDLI'
33437          GOTO109
33438        ELSEIF(ICTMP1.EQ.'COEF' .AND. ICTMP2.EQ.'OF  ' .AND.
33439     1         ICTMP3.EQ.'DISP' .AND. ICTMP4.EQ.'CONF' .AND.
33440     1         ICTMP5.EQ.'INTE')THEN
33441          IFOUND='YES'
33442          ILASTZ=I+4
33443          ICASAN='CDLI'
33444          GOTO109
33445        ELSEIF(ICTMP1.EQ.'COEF' .AND. ICTMP2.EQ.'OF  ' .AND.
33446     1         ICTMP3.EQ.'QUAR' .AND. ICTMP4.EQ.'DISP' .AND.
33447     1         ICTMP5.EQ.'CONF' .AND. ICTMP6.EQ.'LIMI')THEN
33448          IFOUND='YES'
33449          ILASTZ=I+5
33450          ICASAN='CQLI'
33451          GOTO109
33452        ELSEIF(ICTMP1.EQ.'COEF' .AND. ICTMP2.EQ.'OF  ' .AND.
33453     1         ICTMP3.EQ.'QUAR' .AND. ICTMP4.EQ.'DISP' .AND.
33454     1         ICTMP5.EQ.'CONF' .AND. ICTMP6.EQ.'INTE')THEN
33455          IFOUND='YES'
33456          ILASTZ=I+5
33457          ICASAN='CQLI'
33458          GOTO109
33459        ELSEIF(ICTMP1.EQ.'QUAR' .AND. ICTMP2.EQ.'COEF' .AND.
33460     1         ICTMP3.EQ.'OF  ' .AND. ICTMP4.EQ.'DISP' .AND.
33461     1         ICTMP5.EQ.'CONF' .AND. ICTMP6.EQ.'LIMI')THEN
33462          IFOUND='YES'
33463          ILASTZ=I+5
33464          ICASAN='CQLI'
33465          GOTO109
33466        ELSEIF(ICTMP1.EQ.'QUAR' .AND. ICTMP2.EQ.'COEF' .AND.
33467     1         ICTMP3.EQ.'OF  ' .AND. ICTMP4.EQ.'DISP' .AND.
33468     1         ICTMP5.EQ.'CONF' .AND. ICTMP6.EQ.'INTE')THEN
33469          IFOUND='YES'
33470          ILASTZ=I+5
33471          ICASAN='CQLI'
33472          GOTO109
33473        ELSEIF(ICTMP1.EQ.'COEF' .AND. ICTMP2.EQ.'OF  ' .AND.
33474     1         ICTMP3.EQ.'QUAR' .AND. ICTMP4.EQ.'VARI' .AND.
33475     1         ICTMP5.EQ.'CONF' .AND. ICTMP6.EQ.'LIMI')THEN
33476          IFOUND='YES'
33477          ILASTZ=I+5
33478          ICASAN='CQLI'
33479          GOTO109
33480        ELSEIF(ICTMP1.EQ.'COEF' .AND. ICTMP2.EQ.'OF  ' .AND.
33481     1         ICTMP3.EQ.'QUAR' .AND. ICTMP4.EQ.'VARI' .AND.
33482     1         ICTMP5.EQ.'CONF' .AND. ICTMP6.EQ.'INTE')THEN
33483          IFOUND='YES'
33484          ILASTZ=I+5
33485          ICASAN='CQLI'
33486          GOTO109
33487        ELSEIF(ICTMP1.EQ.'QUAR' .AND. ICTMP2.EQ.'COEF' .AND.
33488     1         ICTMP3.EQ.'OF  ' .AND. ICTMP4.EQ.'VARI' .AND.
33489     1         ICTMP5.EQ.'CONF' .AND. ICTMP6.EQ.'LIMI')THEN
33490          IFOUND='YES'
33491          ILASTZ=I+5
33492          ICASAN='CQLI'
33493          GOTO109
33494        ELSEIF(ICTMP1.EQ.'QUAR' .AND. ICTMP2.EQ.'COEF' .AND.
33495     1         ICTMP3.EQ.'OF  ' .AND. ICTMP4.EQ.'VARI' .AND.
33496     1         ICTMP5.EQ.'CONF' .AND. ICTMP6.EQ.'INTE')THEN
33497          IFOUND='YES'
33498          ILASTZ=I+5
33499          ICASAN='CQLI'
33500          GOTO109
33501        ELSEIF(ICTMP1.EQ.'LOWE')THEN
33502          ICASA4='ONES'
33503          ICASA2='LOWE'
33504        ELSEIF(ICTMP1.EQ.'UPPE')THEN
33505          ICASA4='ONES'
33506          ICASA2='UPPE'
33507        ELSEIF(ICTMP1.EQ.'ONE ' .AND. ICTMP2.EQ.'SIDE')THEN
33508          ICASA4='ONES'
33509        ELSEIF(ICTMP1.EQ.'REPL')THEN
33510          IREPL='ON'
33511        ELSEIF(ICTMP1.EQ.'MULT')THEN
33512          IMULT='ON'
33513        ELSEIF(ICTMP1.EQ.'COMM')THEN
33514          ICOMM='ON'
33515        ELSEIF(ICTMP1.EQ.'LOGN')THEN
33516          IDIST='LOGN'
33517        ENDIF
33518  100 CONTINUE
33519  109 CONTINUE
33520C
33521      IF(IFOUND.EQ.'NO')GOTO9000
33522      ISHIFT=ILASTZ
33523      CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
33524     1            IBUGA2,IERROR)
33525C
33526      IF(IMULT.EQ.'ON')THEN
33527        IF(IREPL.EQ.'ON')THEN
33528          WRITE(ICOUT,999)
33529          CALL DPWRST('XXX','BUG ')
33530          WRITE(ICOUT,101)
33531  101     FORMAT('***** ERROR IN COEFFICIENT OF VARIATION CONFIDENCE ',
33532     1           'LIMITS--')
33533          CALL DPWRST('XXX','BUG ')
33534          WRITE(ICOUT,102)
33535  102     FORMAT('      YOU CANNOT SPECIFY BOTH "MULTIPLE" AND ',
33536     1           '"REPLICATION" FOR THIS COMMAND.')
33537          CALL DPWRST('XXX','BUG ')
33538          IERROR='YES'
33539          GOTO9000
33540        ENDIF
33541      ENDIF
33542C
33543      IF(ICOMM.EQ.'ON')THEN
33544        IF(IREPL.EQ.'ON')THEN
33545          WRITE(ICOUT,999)
33546          CALL DPWRST('XXX','BUG ')
33547          WRITE(ICOUT,101)
33548          CALL DPWRST('XXX','BUG ')
33549          WRITE(ICOUT,112)
33550  112     FORMAT('      YOU CANNOT SPECIFY BOTH "COMMON" AND ',
33551     1           '"REPLICATION" FOR THIS COMMAND.')
33552          CALL DPWRST('XXX','BUG ')
33553          IERROR='YES'
33554          GOTO9000
33555        ELSEIF(IDIST.EQ.'ON')THEN
33556          WRITE(ICOUT,999)
33557          CALL DPWRST('XXX','BUG ')
33558          WRITE(ICOUT,101)
33559          CALL DPWRST('XXX','BUG ')
33560          WRITE(ICOUT,114)
33561  114     FORMAT('      YOU CANNOT SPECIFY BOTH "COMMON" AND ',
33562     1           '"LOGNORMAL" FOR THIS COMMAND.')
33563          CALL DPWRST('XXX','BUG ')
33564          IERROR='YES'
33565          GOTO9000
33566        ENDIF
33567      ENDIF
33568C
33569C               *********************************
33570C               **  STEP 2--                   **
33571C               **  EXTRACT THE VARIABLE LIST  **
33572C               *********************************
33573C
33574      ISTEPN='2'
33575      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CVCI')
33576     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
33577C
33578      INAME='COEFFICIENT OF VARIATION CONFIDENCE LIMI'
33579      IF(ICASAN.EQ.'CDLI')INAME=
33580     1   'COEFFICIENT OF DISPERSION CONF LIMI'
33581      IF(ICASAN.EQ.'CQLI')INAME=
33582     1   'COEFF OF QUARTILE DISPERSION CONF LIMI'
33583      MAXNA=100
33584      MINNVA=1
33585      MAXNVA=100
33586      MINNA=1
33587      IFLAGE=1
33588      IFLAGM=1
33589      IF(IREPL.EQ.'ON')THEN
33590        MAXNVA=7
33591        IFLAGM=0
33592      ELSE
33593        MAXNVA=30
33594        IFLAGE=0
33595      ENDIF
33596      IF(ICOMM.EQ.'ON')THEN
33597        MINNVA=2
33598        IF(IMULT.EQ.'OFF')MAXNVA=2
33599      ENDIF
33600      MINN2=4
33601      IFLAGP=0
33602      JMIN=1
33603      JMAX=NUMARG
33604C
33605      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
33606     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
33607     1            JMIN,JMAX,
33608     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
33609     1            IVARN1,IVARN2,IVARTY,PVAR,
33610     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
33611     1            MINNVA,MAXNVA,
33612     1            IFLAGM,IFLAGP,
33613     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
33614      IF(IERROR.EQ.'YES')GOTO9000
33615C
33616      IF(NUMVAR.GT.1 .AND. IREPL.EQ.'OFF' .AND. ICOMM.EQ.'OFF')
33617     1   IMULT='ON'
33618C
33619      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CVCI')THEN
33620        WRITE(ICOUT,999)
33621        CALL DPWRST('XXX','BUG ')
33622        WRITE(ICOUT,181)
33623  181   FORMAT('***** AFTER CALL DPPARS--')
33624        CALL DPWRST('XXX','BUG ')
33625        WRITE(ICOUT,182)NQ,NUMVAR,IMULT,IREPL,ICOMM
33626  182   FORMAT('NQ,NUMVAR,IMULT,IREPL,ICOMM = ',2I8,3(2X,A4))
33627        CALL DPWRST('XXX','BUG ')
33628        IF(NUMVAR.GT.0)THEN
33629          DO185I=1,NUMVAR
33630            WRITE(ICOUT,187)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
33631     1                      ICOLR(I)
33632  187       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
33633     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
33634            CALL DPWRST('XXX','BUG ')
33635  185     CONTINUE
33636        ENDIF
33637      ENDIF
33638C
33639C               ***********************************************
33640C               **  STEP 2--                                 **
33641C               **  DETERMINE:                               **
33642C               **  1) NUMBER OF REPLICATION VARIABLES (0-6) **
33643C               **  2) NUMBER OF RESPONSE    VARIABLES (>= 1)**
33644C               ***********************************************
33645C
33646      ISTEPN='2'
33647      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CVCI')
33648     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
33649C
33650      NRESP=0
33651      NREPL=0
33652C
33653      IF(IMULT.EQ.'ON')THEN
33654        NRESP=NUMVAR
33655      ELSEIF(IREPL.EQ.'ON')THEN
33656        NRESP=1
33657        NREPL=NUMVAR-NRESP
33658        IF(NREPL.LT.1 .OR. NREPL.GT.6)THEN
33659          WRITE(ICOUT,999)
33660          CALL DPWRST('XXX','BUG ')
33661          WRITE(ICOUT,101)
33662          CALL DPWRST('XXX','BUG ')
33663          WRITE(ICOUT,211)
33664  211     FORMAT('      FOR THE REPLICATION CASE, THE NUMBER OF ',
33665     1           'REPLICATION VARIABLES')
33666          CALL DPWRST('XXX','BUG ')
33667          WRITE(ICOUT,212)
33668  212     FORMAT('      MUST BE BETWEEN ONE AND SIX.')
33669          CALL DPWRST('XXX','BUG ')
33670          WRITE(ICOUT,213)NREPL
33671  213     FORMAT('      THE NUMBER OF REPLICATION VARIABLES = ',I5)
33672          CALL DPWRST('XXX','BUG ')
33673          IERROR='YES'
33674          GOTO9000
33675        ENDIF
33676      ELSEIF(ICOMM.EQ.'ON')THEN
33677        NRESP=2
33678      ELSE
33679        NRESP=1
33680      ENDIF
33681C
33682      IH='NNEW'
33683      IH2='    '
33684      IHWUSE='P'
33685      MESSAG='NO'
33686      CALL CHECKN(IH,IH2,IHWUSE,
33687     1            IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
33688     1            ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
33689      IF(IERROR.EQ.'YES')THEN
33690        NNEW=1
33691      ELSE
33692        NNEW=INT(VALUE(ILOCV)+0.5)
33693        IF(NNEW.LT.1)NNEW=1
33694      ENDIF
33695C
33696      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CVCI')THEN
33697        WRITE(ICOUT,221)NRESP,NREPL,NNEW
33698  221   FORMAT('NRESP,NREPL,NNEW = ',3I5)
33699        CALL DPWRST('XXX','BUG ')
33700      ENDIF
33701C
33702C               ******************************************************
33703C               **  STEP 3--                                        **
33704C               **  GENERATE THE PREDICTION LIMITS FOR THE VARIOUS  **
33705C               **  CASES                                           **
33706C               ******************************************************
33707C
33708      ISTEPN='3'
33709      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CVCI')
33710     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
33711C
33712C               *****************************************
33713C               **  STEP 3A--                          **
33714C               **  CASE 1: NO REPLICATION             **
33715C               *****************************************
33716C
33717      IF(NREPL.EQ.0)THEN
33718        ISTEPN='3A'
33719        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CVCI')
33720     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
33721C
33722C       COMMON COEFFICIENT OF VARIATION CASE
33723C
33724        IF(ICOMM.EQ.'ON')THEN
33725          IF(IMULT.EQ.'OFF')THEN
33726C
33727C           CASE WHERE RESPONSE AND GROUP-ID VARIABLE GIVEN
33728C
33729            IINDX=ICOLR(1)
33730            PID(1)=CPUMIN
33731            IVARID(1)=IVARN1(1)
33732            IVARI2(1)=IVARN2(1)
33733            IINDX2=ICOLR(2)
33734            PID(2)=CPUMIN
33735            IVARID(2)=IVARN1(2)
33736            IVARI2(2)=IVARN2(2)
33737C
33738            ICOL=1
33739            NUMVA2=2
33740            CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
33741     1                  INAME,IVARN1,IVARN2,IVARTY,
33742     1                  ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
33743     1                  MAXCOL,MAXCP1,MAXCP2,MAXCP3,
33744     1                  MAXCP4,MAXCP5,MAXCP6,
33745     1                  V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
33746     1                  Y,TEMP1,TEMP1,NLOCAL,NLOCA2,NLOCA3,ICASE,
33747     1                  IBUGA3,ISUBRO,IFOUND,IERROR)
33748            IF(IERROR.EQ.'YES')GOTO9000
33749C
33750C           *****************************************************
33751C           **  STEP 4B--                                      **
33752C           *****************************************************
33753C
33754            ISTEPN='4B'
33755            IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CVCI')
33756     1      CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
33757C
33758            IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CVCI')THEN
33759              WRITE(ICOUT,999)
33760              CALL DPWRST('XXX','BUG ')
33761              WRITE(ICOUT,422)
33762              CALL DPWRST('XXX','BUG ')
33763              WRITE(ICOUT,463)ICASAN,NUMVAR,NLOCAL
33764  463         FORMAT('ICASAN,NUMVAR,NLOCAL = ',A4,2I8)
33765              CALL DPWRST('XXX','BUG ')
33766              IF(NLOCAL.GE.1)THEN
33767                DO465I=1,NLOCAL
33768                  WRITE(ICOUT,466)I,Y(I),TEMP1(I)
33769  466             FORMAT('I,Y(I),TEMP1(I) = ',I8,2G15.7)
33770                  CALL DPWRST('XXX','BUG ')
33771  465           CONTINUE
33772              ENDIF
33773            ENDIF
33774C
33775            CALL DPCVC2(Y,TEMP1,NLOCAL,ICASAN,ICASA2,ICASA3,ICASA4,
33776     1                  PID,IVARID,IVARI2,NREPL,TEMP3,TEMP4,ITEMP1,
33777     1                  CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
33778     1                  CTL999,CTU999,
33779     1                  ICAPSW,ICAPTY,IFORSW,ICVACI,IDIST,ICOMM,
33780     1                  ISEED,MAXNXT,IQUAME,
33781     1                  ISUBRO,IBUGA3,IERROR)
33782C
33783            IFLAGU='FILE'
33784            IFRST=.FALSE.
33785            ILAST=.FALSE.
33786            IF(IRESP.EQ.1)IFRST=.TRUE.
33787            IF(IRESP.EQ.NRESP)ILAST=.TRUE.
33788            CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
33789     1                  CTL999,CTU999,
33790     1                  IFLAGU,IFRST,ILAST,ICASAN,
33791     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
33792C
33793          ELSE
33794C
33795C           CASE WHERE EACH GROUP AS SEPARATE VARIABLE
33796C
33797            PID(1)=CPUMIN
33798            IVARID(1)='NULL'
33799            IVARI2(1)='    '
33800            PID(2)=CPUMIN
33801            IVARID(2)='NULL'
33802            IVARI2(2)='    '
33803C
33804            ICOL=1
33805            NUMVA2=NUMVAR
33806            CALL DPPAR8(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
33807     1                  INAME,IVARN1,IVARN2,IVARTY,
33808     1                  ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
33809     1                  MAXCOL,MAXCP1,MAXCP2,MAXCP3,
33810     1                  MAXCP4,MAXCP5,MAXCP6,
33811     1                  V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
33812     1                  XTEMP1,Y,TEMP1,NLOCAL,ICASE,
33813     1                  IBUGA3,ISUBRO,IFOUND,IERROR)
33814            IF(IERROR.EQ.'YES')GOTO9000
33815            NUMVAR=2
33816            IMULT='OFF'
33817C
33818C               *****************************************************
33819C               **  STEP 4C--                                      **
33820C               *****************************************************
33821C
33822            CALL DPCVC2(Y,TEMP1,NLOCAL,ICASAN,ICASA2,ICASA3,ICASA4,
33823     1                  PID,IVARID,IVARI2,NREPL,TEMP3,TEMP4,ITEMP1,
33824     1                  CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
33825     1                  CTL999,CTU999,
33826     1                  ICAPSW,ICAPTY,IFORSW,ICVACI,IDIST,ICOMM,
33827     1                  ISEED,MAXNXT,IQUAME,
33828     1                  ISUBRO,IBUGA3,IERROR)
33829C
33830            IFLAGU='FILE'
33831            IFRST=.FALSE.
33832            ILAST=.FALSE.
33833            IF(IRESP.EQ.1)IFRST=.TRUE.
33834            IF(IRESP.EQ.NRESP)ILAST=.TRUE.
33835            CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
33836     1                  CTL999,CTU999,
33837     1                  IFLAGU,IFRST,ILAST,ICASAN,
33838     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
33839          ENDIF
33840        ELSE
33841C
33842C         LOOP THROUGH EACH OF THE RESPONSE VARIABLES
33843C
33844          NCURVE=0
33845          DO410IRESP=1,NRESP
33846            NCURVE=NCURVE+1
33847C
33848            IINDX=ICOLR(IRESP)
33849            PID(1)=CPUMIN
33850            IVARID(1)=IVARN1(IRESP)
33851            IVARI2(1)=IVARN2(IRESP)
33852C
33853            IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CVCI')THEN
33854              WRITE(ICOUT,999)
33855              CALL DPWRST('XXX','BUG ')
33856              WRITE(ICOUT,411)IRESP,NCURVE
33857  411         FORMAT('IRESP,NCURVE = ',2I5)
33858              CALL DPWRST('XXX','BUG ')
33859            ENDIF
33860C
33861            ICOL=IRESP
33862            NUMVA2=1
33863            CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
33864     1                  INAME,IVARN1,IVARN2,IVARTY,
33865     1                  ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
33866     1                  MAXCOL,MAXCP1,MAXCP2,MAXCP3,
33867     1                  MAXCP4,MAXCP5,MAXCP6,
33868     1                  V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
33869     1                  Y,XTEMP1,XTEMP2,NLOCAL,NLOCA2,NLOCA3,ICASE,
33870     1                  IBUGA3,ISUBRO,IFOUND,IERROR)
33871            IF(IERROR.EQ.'YES')GOTO9000
33872C
33873C           *****************************************************
33874C           **  STEP 4B--                                      **
33875C           *****************************************************
33876C
33877            ISTEPN='4B'
33878            IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CVCI')
33879     1      CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
33880C
33881            IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CVCI')THEN
33882              WRITE(ICOUT,999)
33883              CALL DPWRST('XXX','BUG ')
33884              WRITE(ICOUT,422)
33885  422         FORMAT('***** FROM THE MIDDLE  OF DPCVCI--')
33886              CALL DPWRST('XXX','BUG ')
33887              WRITE(ICOUT,423)ICASAN,NUMVAR,NLOCAL,IRESP
33888  423         FORMAT('ICASAN,NUMVAR,NLOCAL,IRESP = ',A4,3I8)
33889              CALL DPWRST('XXX','BUG ')
33890              IF(NLOCAL.GE.1)THEN
33891                DO425I=1,NLOCAL
33892                  WRITE(ICOUT,426)I,Y(I)
33893  426             FORMAT('I,Y(I) = ',I8,F12.5)
33894                  CALL DPWRST('XXX','BUG ')
33895  425           CONTINUE
33896              ENDIF
33897            ENDIF
33898C
33899            CALL DPCVC2(Y,Y,NLOCAL,ICASAN,ICASA2,ICASA3,ICASA4,
33900     1                  PID,IVARID,IVARI2,NREPL,TEMP3,TEMP4,ITEMP1,
33901     1                  CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
33902     1                  CTL999,CTU999,
33903     1                  ICAPSW,ICAPTY,IFORSW,ICVACI,IDIST,ICOMM,
33904     1                  ISEED,MAXNXT,IQUAME,
33905     1                  ISUBRO,IBUGA3,IERROR)
33906C
33907            IFLAGU='FILE'
33908            IFRST=.FALSE.
33909            ILAST=.FALSE.
33910            IF(IRESP.EQ.1)IFRST=.TRUE.
33911            IF(IRESP.EQ.NRESP)ILAST=.TRUE.
33912            CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
33913     1                  CTL999,CTU999,
33914     1                  IFLAGU,IFRST,ILAST,ICASAN,
33915     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
33916C
33917  410     CONTINUE
33918        ENDIF
33919C
33920C               ****************************************************
33921C               **  STEP 5A--                                     **
33922C               **  CASE 3: ONE OR MORE REPLICATION VARIABLES.    **
33923C               **          FOR THIS CASE, ALL VARIABLES MUST     **
33924C               **          HAVE THE SAME LENGTH.                 **
33925C               ****************************************************
33926C
33927      ELSEIF(IREPL.EQ.'ON')THEN
33928        ISTEPN='5A'
33929        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CVCI')
33930     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
33931C
33932        J=0
33933        IMAX=NRIGHT(1)
33934        IF(NQ.LT.NRIGHT(1))IMAX=NQ
33935        DO510I=1,IMAX
33936          IF(ISUB(I).EQ.0)GOTO510
33937          J=J+1
33938C
33939C         RESPONSE VARIABLE IN Y
33940C
33941          ICOLC=1
33942          IJ=MAXN*(ICOLR(ICOLC)-1)+I
33943          IF(ICOLR(ICOLC).LE.MAXCOL)Y(J)=V(IJ)
33944          IF(ICOLR(ICOLC).EQ.MAXCP1)Y(J)=PRED(I)
33945          IF(ICOLR(ICOLC).EQ.MAXCP2)Y(J)=RES(I)
33946          IF(ICOLR(ICOLC).EQ.MAXCP3)Y(J)=YPLOT(I)
33947          IF(ICOLR(ICOLC).EQ.MAXCP4)Y(J)=XPLOT(I)
33948          IF(ICOLR(ICOLC).EQ.MAXCP5)Y(J)=X2PLOT(I)
33949          IF(ICOLR(ICOLC).EQ.MAXCP6)Y(J)=TAGPLO(I)
33950C
33951          IF(NREPL.GE.1)THEN
33952            DO520IR=1,MIN(NREPL,6)
33953              ICOLC=ICOLC+1
33954              ICOLT=ICOLR(ICOLC)
33955              IJ=MAXN*(ICOLT-1)+I
33956              IF(ICOLT.LE.MAXCOL)XDESGN(J,IR)=V(IJ)
33957              IF(ICOLT.EQ.MAXCP1)XDESGN(J,IR)=PRED(I)
33958              IF(ICOLT.EQ.MAXCP2)XDESGN(J,IR)=RES(I)
33959              IF(ICOLT.EQ.MAXCP3)XDESGN(J,IR)=YPLOT(I)
33960              IF(ICOLT.EQ.MAXCP4)XDESGN(J,IR)=XPLOT(I)
33961              IF(ICOLT.EQ.MAXCP5)XDESGN(J,IR)=X2PLOT(I)
33962              IF(ICOLT.EQ.MAXCP6)XDESGN(J,IR)=TAGPLO(I)
33963  520       CONTINUE
33964          ENDIF
33965C
33966  510   CONTINUE
33967        NLOCAL=J
33968C
33969        ISTEPN='5B'
33970        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CVCI')
33971     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
33972C
33973        PID(1)=CPUMIN
33974        IVARID(1)=IVARN1(1)
33975        IVARI2(1)=IVARN2(1)
33976        IADD=1
33977        DO540II=1,NREPL
33978          IVARID(II+IADD)=IVARN1(II+IADD)
33979          IVARI2(II+IADD)=IVARN2(II+IADD)
33980  540   CONTINUE
33981C
33982C       *****************************************************
33983C       **  STEP 5C--                                      **
33984C       **                                                 **
33985C       **  FOR THIS CASE, WE NEED TO LOOP THROUGH THE     **
33986C       **  VARIOUS REPLICATIONS.                          **
33987C       *****************************************************
33988C
33989        ISTEPN='5C'
33990        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CVCI')
33991     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
33992C
33993        IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CVCI')THEN
33994          WRITE(ICOUT,999)
33995          CALL DPWRST('XXX','BUG ')
33996          WRITE(ICOUT,541)
33997  541     FORMAT('***** FROM THE MIDDLE  OF DPSDCL--')
33998          CALL DPWRST('XXX','BUG ')
33999          WRITE(ICOUT,542)ICASAN,NUMVAR,NLOCAL,NLOCA2,NREPL
34000  542     FORMAT('ICASAN,NUMVAR,NLOCAL,NLOCA2,NREPL = ',A4,2X,4I8)
34001          CALL DPWRST('XXX','BUG ')
34002          IF(NLOCAL.GE.1)THEN
34003            DO545I=1,NLOCAL
34004              WRITE(ICOUT,546)I,Y(I),X(I),XDESGN(I,1),XDESGN(I,2)
34005  546         FORMAT('I,Y(I),X(I),XDESGN(I,1),XDESGN(I,2) = ',
34006     1               I8,4F12.5)
34007              CALL DPWRST('XXX','BUG ')
34008  545       CONTINUE
34009          ENDIF
34010        ENDIF
34011C
34012C       *****************************************************
34013C       **  STEP 5C--                                      **
34014C       **  FIND THE DISTINCT VALUES IN EACH OF THE        **
34015C       **  REPLICATION VARIABLES.                         **
34016C       *****************************************************
34017C
34018        CALL DPPP5(XDESGN(1,1),XDESGN(1,2),XDESGN(1,3),
34019     1             XDESGN(1,4),XDESGN(1,5),XDESGN(1,6),
34020     1             NREPL,NLOCAL,MAXOBV,
34021     1             XIDTEM,XIDTE2,XIDTE3,XIDTE4,XIDTE5,XIDTE6,
34022     1             XTEMP1,XTEMP2,
34023     1             NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,NUMSE6,
34024     1             IBUGA3,ISUBRO,IERROR)
34025C
34026C       *****************************************************
34027C       **  STEP 5D--                                      **
34028C       **  NOW LOOP THROUGH THE VARIOUS REPLICATIONS      **
34029C       *****************************************************
34030C
34031        NPLOTP=0
34032        NCURVE=0
34033        IF(NREPL.EQ.1)THEN
34034          J=0
34035          DO1110ISET1=1,NUMSE1
34036            K=0
34037            PID(IADD+1)=XIDTEM(ISET1)
34038            DO1130I=1,NLOCAL
34039              IF(XIDTEM(ISET1).EQ.XDESGN(I,1))THEN
34040                K=K+1
34041                TEMP1(K)=Y(I)
34042                TEMP2(K)=X(I)
34043              ENDIF
34044 1130       CONTINUE
34045            NTEMP=K
34046            NCURVE=NCURVE+1
34047            IF(NTEMP.GT.0)THEN
34048              CALL DPCVC2(TEMP1,TEMP1,NTEMP,ICASAN,ICASA2,ICASA3,ICASA4,
34049     1                    PID,IVARID,IVARI2,NREPL,TEMP3,TEMP4,ITEMP1,
34050     1                    CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
34051     1                    CTL999,CTU999,
34052     1                    ICAPSW,ICAPTY,IFORSW,ICVACI,IDIST,ICOMM,
34053     1                    ISEED,MAXNXT,IQUAME,
34054     1                    ISUBRO,IBUGA3,IERROR)
34055            ENDIF
34056C
34057            IFLAGU='FILE'
34058            IFRST=.FALSE.
34059            ILAST=.FALSE.
34060            IF(NCURVE.EQ.1)IFRST=.TRUE.
34061            IF(NCURVE.EQ.NUMSE1)ILAST=.TRUE.
34062            CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
34063     1                  CTL999,CTU999,
34064     1                  IFLAGU,IFRST,ILAST,ICASAN,
34065     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
34066 1110     CONTINUE
34067        ELSEIF(NREPL.EQ.2)THEN
34068          J=0
34069          NTOT=NUMSE1*NUMSE2
34070          DO1210ISET1=1,NUMSE1
34071          DO1220ISET2=1,NUMSE2
34072            K=0
34073            PID(1+IADD)=XIDTEM(ISET1)
34074            PID(2+IADD)=XIDTE2(ISET2)
34075            DO1290I=1,NLOCAL
34076              IF(
34077     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
34078     1           XIDTE2(ISET2).EQ.XDESGN(I,2)
34079     1          )THEN
34080                K=K+1
34081                TEMP1(K)=Y(I)
34082                TEMP2(K)=X(I)
34083              ENDIF
34084 1290       CONTINUE
34085            NTEMP=K
34086            NCURVE=NCURVE+1
34087            NPLOT1=NPLOTP
34088            IF(NTEMP.GT.0)THEN
34089              CALL DPCVC2(TEMP1,TEMP1,NTEMP,ICASAN,ICASA2,ICASA3,ICASA4,
34090     1                    PID,IVARID,IVARI2,NREPL,TEMP3,TEMP4,ITEMP1,
34091     1                    CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
34092     1                    CTL999,CTU999,
34093     1                    ICAPSW,ICAPTY,IFORSW,ICVACI,IDIST,ICOMM,
34094     1                    ISEED,MAXNXT,IQUAME,
34095     1                    ISUBRO,IBUGA3,IERROR)
34096            ENDIF
34097            NPLOT2=NPLOTP
34098            IFLAGU='FILE'
34099            IFRST=.FALSE.
34100            ILAST=.FALSE.
34101            IF(NCURVE.EQ.1)IFRST=.TRUE.
34102            IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
34103            CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
34104     1                  CTL999,CTU999,
34105     1                  IFLAGU,IFRST,ILAST,ICASAN,
34106     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
34107 1220     CONTINUE
34108 1210     CONTINUE
34109        ELSEIF(NREPL.EQ.3)THEN
34110          J=0
34111          NTOT=NUMSE1*NUMSE2*NUMSE3
34112          DO1310ISET1=1,NUMSE1
34113          DO1320ISET2=1,NUMSE2
34114          DO1330ISET3=1,NUMSE3
34115            K=0
34116            PID(1+IADD)=XIDTEM(ISET1)
34117            PID(2+IADD)=XIDTE2(ISET2)
34118            PID(3+IADD)=XIDTE3(ISET3)
34119            DO1390I=1,NLOCAL
34120              IF(
34121     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
34122     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
34123     1           XIDTE3(ISET3).EQ.XDESGN(I,3)
34124     1          )THEN
34125                K=K+1
34126                TEMP1(K)=Y(I)
34127                TEMP2(K)=X(I)
34128              ENDIF
34129 1390       CONTINUE
34130            NTEMP=K
34131            NCURVE=NCURVE+1
34132            IF(NTEMP.GT.0)THEN
34133              CALL DPCVC2(TEMP1,TEMP1,NTEMP,ICASAN,ICASA2,ICASA3,ICASA4,
34134     1                    PID,IVARID,IVARI2,NREPL,TEMP3,TEMP4,ITEMP1,
34135     1                    CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
34136     1                    CTL999,CTU999,
34137     1                    ICAPSW,ICAPTY,IFORSW,ICVACI,IDIST,ICOMM,
34138     1                    ISEED,MAXNXT,IQUAME,
34139     1                    ISUBRO,IBUGA3,IERROR)
34140            ENDIF
34141            IFLAGU='FILE'
34142            IFRST=.FALSE.
34143            ILAST=.FALSE.
34144            IF(NCURVE.EQ.1)IFRST=.TRUE.
34145            IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
34146            CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
34147     1                  CTL999,CTU999,
34148     1                  IFLAGU,IFRST,ILAST,ICASAN,
34149     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
34150 1330     CONTINUE
34151 1320     CONTINUE
34152 1310     CONTINUE
34153        ELSEIF(NREPL.EQ.4)THEN
34154          J=0
34155          NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4
34156          DO1410ISET1=1,NUMSE1
34157          DO1420ISET2=1,NUMSE2
34158          DO1430ISET3=1,NUMSE3
34159          DO1440ISET4=1,NUMSE4
34160            K=0
34161            PID(1+IADD)=XIDTEM(ISET1)
34162            PID(2+IADD)=XIDTE2(ISET2)
34163            PID(3+IADD)=XIDTE3(ISET3)
34164            PID(4+IADD)=XIDTE4(ISET4)
34165            DO1490I=1,NLOCAL
34166              IF(
34167     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
34168     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
34169     1           XIDTE3(ISET3).EQ.XDESGN(I,3) .AND.
34170     1           XIDTE4(ISET4).EQ.XDESGN(I,4)
34171     1          )THEN
34172                K=K+1
34173                TEMP1(K)=Y(I)
34174                TEMP2(K)=X(I)
34175              ENDIF
34176 1490       CONTINUE
34177            NTEMP=K
34178            NCURVE=NCURVE+1
34179            IF(NTEMP.GT.0)THEN
34180              CALL DPCVC2(TEMP1,TEMP1,NTEMP,ICASAN,ICASA2,ICASA3,ICASA4,
34181     1                    PID,IVARID,IVARI2,NREPL,TEMP3,TEMP4,ITEMP1,
34182     1                    CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
34183     1                    CTL999,CTU999,
34184     1                    ICAPSW,ICAPTY,IFORSW,ICVACI,IDIST,ICOMM,
34185     1                    ISEED,MAXNXT,IQUAME,
34186     1                    ISUBRO,IBUGA3,IERROR)
34187            ENDIF
34188            IFLAGU='FILE'
34189            IFRST=.FALSE.
34190            ILAST=.FALSE.
34191            IF(NCURVE.EQ.1)IFRST=.TRUE.
34192            IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
34193            CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
34194     1                  CTL999,CTU999,
34195     1                  IFLAGU,IFRST,ILAST,ICASAN,
34196     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
34197 1440     CONTINUE
34198 1430     CONTINUE
34199 1420     CONTINUE
34200 1410     CONTINUE
34201        ELSEIF(NREPL.EQ.5)THEN
34202          J=0
34203          NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5
34204          DO1510ISET1=1,NUMSE1
34205          DO1520ISET2=1,NUMSE2
34206          DO1530ISET3=1,NUMSE3
34207          DO1540ISET4=1,NUMSE4
34208          DO1550ISET5=1,NUMSE5
34209            K=0
34210            PID(1+IADD)=XIDTEM(ISET1)
34211            PID(2+IADD)=XIDTE2(ISET2)
34212            PID(3+IADD)=XIDTE3(ISET3)
34213            PID(4+IADD)=XIDTE4(ISET4)
34214            PID(5+IADD)=XIDTE5(ISET4)
34215            DO1590I=1,NLOCAL
34216              IF(
34217     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
34218     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
34219     1           XIDTE3(ISET3).EQ.XDESGN(I,3) .AND.
34220     1           XIDTE4(ISET4).EQ.XDESGN(I,4) .AND.
34221     1           XIDTE5(ISET5).EQ.XDESGN(I,5)
34222     1          )THEN
34223                K=K+1
34224                TEMP1(K)=Y(I)
34225                TEMP2(K)=X(I)
34226              ENDIF
34227 1590       CONTINUE
34228            NTEMP=K
34229            NCURVE=NCURVE+1
34230            IF(NTEMP.GT.0)THEN
34231              CALL DPCVC2(TEMP1,TEMP1,NTEMP,ICASAN,ICASA2,ICASA3,ICASA4,
34232     1                    PID,IVARID,IVARI2,NREPL,TEMP3,TEMP4,ITEMP1,
34233     1                    CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
34234     1                    CTL999,CTU999,
34235     1                    ICAPSW,ICAPTY,IFORSW,ICVACI,IDIST,ICOMM,
34236     1                    ISEED,MAXNXT,IQUAME,
34237     1                    ISUBRO,IBUGA3,IERROR)
34238            ENDIF
34239            IFLAGU='FILE'
34240            IFRST=.FALSE.
34241            ILAST=.FALSE.
34242            IF(NCURVE.EQ.1)IFRST=.TRUE.
34243            IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
34244            CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
34245     1                  CTL999,CTU999,
34246     1                  IFLAGU,IFRST,ILAST,ICASAN,
34247     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
34248 1550     CONTINUE
34249 1540     CONTINUE
34250 1530     CONTINUE
34251 1520     CONTINUE
34252 1510     CONTINUE
34253        ELSEIF(NREPL.EQ.6)THEN
34254          J=0
34255          NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5*NUMSE6
34256          DO1610ISET1=1,NUMSE1
34257          DO1620ISET2=1,NUMSE2
34258          DO1630ISET3=1,NUMSE3
34259          DO1640ISET4=1,NUMSE4
34260          DO1650ISET5=1,NUMSE5
34261          DO1660ISET6=1,NUMSE6
34262            K=0
34263            PID(1+IADD)=XIDTEM(ISET1)
34264            PID(2+IADD)=XIDTE2(ISET2)
34265            PID(3+IADD)=XIDTE3(ISET3)
34266            PID(4+IADD)=XIDTE4(ISET4)
34267            PID(5+IADD)=XIDTE5(ISET4)
34268            PID(6+IADD)=XIDTE6(ISET4)
34269            DO1690I=1,NLOCAL
34270              IF(
34271     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
34272     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
34273     1           XIDTE3(ISET3).EQ.XDESGN(I,3) .AND.
34274     1           XIDTE4(ISET4).EQ.XDESGN(I,4) .AND.
34275     1           XIDTE5(ISET5).EQ.XDESGN(I,5) .AND.
34276     1           XIDTE6(ISET6).EQ.XDESGN(I,6)
34277     1          )THEN
34278                K=K+1
34279                TEMP1(K)=Y(I)
34280                TEMP2(K)=X(I)
34281              ENDIF
34282 1690       CONTINUE
34283            NTEMP=K
34284            NCURVE=NCURVE+1
34285            IF(NTEMP.GT.0)THEN
34286              CALL DPCVC2(TEMP1,TEMP1,NTEMP,ICASAN,ICASA2,ICASA3,ICASA4,
34287     1                    PID,IVARID,IVARI2,NREPL,TEMP3,TEMP4,ITEMP1,
34288     1                    CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
34289     1                    CTL999,CTU999,
34290     1                    ICAPSW,ICAPTY,IFORSW,ICVACI,IDIST,ICOMM,
34291     1                    ISEED,MAXNXT,IQUAME,
34292     1                    ISUBRO,IBUGA3,IERROR)
34293            ENDIF
34294            IFLAGU='FILE'
34295            IFRST=.FALSE.
34296            ILAST=.FALSE.
34297            IF(NCURVE.EQ.1)IFRST=.TRUE.
34298            IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
34299            CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
34300     1                  CTL999,CTU999,
34301     1                  IFLAGU,IFRST,ILAST,ICASAN,
34302     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
34303 1660     CONTINUE
34304 1650     CONTINUE
34305 1640     CONTINUE
34306 1630     CONTINUE
34307 1620     CONTINUE
34308 1610     CONTINUE
34309        ENDIF
34310C
34311      ENDIF
34312C
34313C               *****************
34314C               **  STEP 90--  **
34315C               **  EXIT       **
34316C               *****************
34317C
34318 9000 CONTINUE
34319      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CVCI')THEN
34320        WRITE(ICOUT,999)
34321        CALL DPWRST('XXX','BUG ')
34322        WRITE(ICOUT,9011)
34323 9011   FORMAT('***** AT THE END       OF DPSDCL--')
34324        CALL DPWRST('XXX','BUG ')
34325        WRITE(ICOUT,9016)IFOUND,IERROR
34326 9016   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
34327        CALL DPWRST('XXX','BUG ')
34328      ENDIF
34329C
34330      RETURN
34331      END
34332      SUBROUTINE DPCVC2(Y,X,N,ICASAN,ICASA2,ICASA3,ICASA4,
34333     1                  PID,IVARID,IVARI2,NREPL,TEMP1,TEMP2,ITEMP1,
34334     1                  CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
34335     1                  CTL999,CTU999,
34336     1                  ICAPSW,ICAPTY,IFORSW,ICVACI,IDIST,ICOMM,
34337     1                  ISEED,MAXNXT,IQUAME,
34338     1                  ISUBRO,IBUGA3,IERROR)
34339C
34340C     PURPOSE--GENERATE A CONFIDENCE INTERVAL FOR THE COEFFICIENT
34341C              OF VARIATION FOR NORMALLY DISTRIBUTED DATA.
34342C
34343C     INPUT  ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR OF
34344C                                ORIGINAL OBSERVATIONS.
34345C                       N      = THE INTEGER NUMBER OF OBSERVATIONS
34346C                                IN THE VECTOR Y.
34347C     WRITTEN BY--ALAN HECKERT
34348C                 STATISTICAL ENGINEERING DIVISION
34349C                 INFORMATION TECHNOLOGY LABORATORY
34350C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
34351C                 GAITHERSBURG, MD 20899-8980
34352C                 PHONE--301-975-2899
34353C     REFERENCES--MARK VANGEL (1996), "CONFIDENCE INTERVALS FOR A NORMAL
34354C                 COEFFICIENT OF VARIATION", AMERICAN STATISTICIAN,
34355C                 VOL. 15, NO. 1, PP. 21-26.
34356C                 GUIDE FOR PRACTIONERS", WILEY, PP. 55-56.
34357C               --MCKAY (1932), "DISTRIBUTIONS OF THE COEFFICIENT OF
34358C                 VARIATION AND THE EXTENDED 't' DISTRIBUTION", JOURNAL
34359C                 OF THE ROYAL STATISTICAL SOCIETY, VOL. 95, PP. 695-698.
34360C               --JOHANNES FORKMAN (xxxx), "ESTIMATOR AND TESTS FOR
34361C                 COMMON COEFFICIENTS OF VARIATION IN NORMAL
34362C                 DISTRIBUTIONS",
34363C               --BONETT AND SEIER (2006), "CONFIDENCE INTERVAL FOR A
34364C                 COEFFICIENT OF DISPERSION", BIOMETRICAL JOURNAL,
34365C                 VOL. 48, NO. 1, PP. 144-148.
34366C               --BONETT (2006), "CONFIDENCE INTERVAL FOR A
34367C                 COEFFICIENT OF QUARTILE VARIATIOIN", COMPUTATIONAL
34368C                 STATISTICS AND DATA ANALYSIS, VOL. 50, PP. 2953-2957.
34369C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
34370C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
34371C     LANGUAGE--ANSI FORTRAN (1977)
34372C     VERSION NUMBER--2016/12
34373C     ORIGINAL VERSION--DECEMBER  2016.
34374C     UPDATED         --NOVEMBER  2017. SUPPORT COEFFICIENT OF DISPERSION
34375C                                       CONFIDENCE LIMITS
34376C     UPDATED         --DECEMBER  2017. SUPPORT FOR COEFFICIENT OF
34377C                                       QUARTILE DISPERSION CONFIDENCE
34378C                                       INTERVAL
34379C
34380C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
34381C
34382      CHARACTER*4 ICASAN
34383      CHARACTER*4 ICASA2
34384      CHARACTER*4 ICASA3
34385      CHARACTER*4 ICASA4
34386      CHARACTER*4 ICAPSW
34387      CHARACTER*4 ICAPTY
34388      CHARACTER*4 IFORSW
34389      CHARACTER*4 ICVACI
34390      CHARACTER*4 IDIST
34391      CHARACTER*4 ICOMM
34392      CHARACTER*4 IQUAME
34393      CHARACTER*4 ISUBRO
34394      CHARACTER*4 IBUGA3
34395      CHARACTER*4 IERROR
34396C
34397      CHARACTER*4 IVARID(*)
34398      CHARACTER*4 IVARI2(*)
34399C
34400      CHARACTER*4 IWRITE
34401      CHARACTER*4 ISUBN1
34402      CHARACTER*4 ISUBN2
34403      CHARACTER*4 ISTEPN
34404      CHARACTER*20 ISTR
34405C
34406C---------------------------------------------------------------------
34407C
34408      DIMENSION Y(*)
34409      DIMENSION X(*)
34410      DIMENSION TEMP1(*)
34411      DIMENSION TEMP2(*)
34412      DIMENSION PID(*)
34413C
34414      INTEGER ITEMP1(*)
34415C
34416      PARAMETER (NUMALP=6)
34417      REAL ALPHA(NUMALP)
34418      REAL CONF(NUMALP)
34419C
34420      DIMENSION ALOWLM(NUMALP)
34421      DIMENSION AUPPLM(NUMALP)
34422C
34423      PARAMETER(NUMCLI=4)
34424      PARAMETER(MAXLIN=2)
34425      PARAMETER (MAXROW=20)
34426      CHARACTER*60 ITITLE
34427      CHARACTER*60 ITITLZ
34428      CHARACTER*40 ITITL9
34429      CHARACTER*60 ITEXT(MAXROW)
34430      CHARACTER*4  ALIGN(NUMCLI)
34431      CHARACTER*4  VALIGN(NUMCLI)
34432      CHARACTER*4  ITYPCO(NUMCLI)
34433      CHARACTER*20 ITITL2(MAXLIN,NUMCLI)
34434      CHARACTER*4  IVALUE(MAXROW,NUMCLI)
34435      REAL         AVALUE(MAXROW)
34436      REAL         AMAT(MAXROW,NUMCLI)
34437      INTEGER      NCVALU(MAXROW,NUMCLI)
34438      INTEGER      NCTIT2(MAXLIN,NUMCLI)
34439      INTEGER      NCTEXT(MAXROW)
34440      INTEGER      IDIGIT(MAXROW)
34441      INTEGER      NTOT(MAXROW)
34442      INTEGER      IWHTML(NUMCLI)
34443      INTEGER      IWRTF(NUMCLI)
34444      LOGICAL IFRST
34445      LOGICAL ILAST
34446C
34447C---------------------------------------------------------------------
34448C
34449      INCLUDE 'DPCOP2.INC'
34450C
34451C-----START POINT-----------------------------------------------------
34452C
34453      DATA ALPHA /0.50, 0.80, 0.90, 0.95, 0.99, 0.999/
34454C
34455      ISUBN1='DPCV'
34456      ISUBN2='C2  '
34457      IERROR='NO'
34458      IWRITE='OFF'
34459      ISTR='VARIATION'
34460      IF(ICASAN.EQ.'CDLI')ISTR='DISPERSION'
34461      IF(ICASAN.EQ.'CQLI')ISTR='QUARTILE DISPERSION'
34462C
34463      NUMDIG=7
34464      IF(IFORSW.EQ.'1')NUMDIG=1
34465      IF(IFORSW.EQ.'2')NUMDIG=2
34466      IF(IFORSW.EQ.'3')NUMDIG=3
34467      IF(IFORSW.EQ.'4')NUMDIG=4
34468      IF(IFORSW.EQ.'5')NUMDIG=5
34469      IF(IFORSW.EQ.'6')NUMDIG=6
34470      IF(IFORSW.EQ.'7')NUMDIG=7
34471      IF(IFORSW.EQ.'8')NUMDIG=8
34472      IF(IFORSW.EQ.'9')NUMDIG=9
34473      IF(IFORSW.EQ.'0')NUMDIG=0
34474      IF(IFORSW.EQ.'E')NUMDIG=-2
34475      IF(IFORSW.EQ.'-2')NUMDIG=-2
34476      IF(IFORSW.EQ.'-3')NUMDIG=-3
34477      IF(IFORSW.EQ.'-4')NUMDIG=-4
34478      IF(IFORSW.EQ.'-5')NUMDIG=-5
34479      IF(IFORSW.EQ.'-6')NUMDIG=-6
34480      IF(IFORSW.EQ.'-7')NUMDIG=-7
34481      IF(IFORSW.EQ.'-8')NUMDIG=-8
34482      IF(IFORSW.EQ.'-9')NUMDIG=-9
34483C
34484      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CVC2')THEN
34485        WRITE(ICOUT,999)
34486  999   FORMAT(1X)
34487        CALL DPWRST('XXX','WRIT')
34488        WRITE(ICOUT,51)
34489   51   FORMAT('**** AT THE BEGINNING OF DPCVC2--')
34490        CALL DPWRST('XXX','WRIT')
34491        WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASAN,ICASA2,ICASA3,ICASA4
34492   52   FORMAT('IBUGA3,ISUBRO,ICASAN,ICASA2,ICASA3,ICASA4 = ',
34493     1         5(A4,2X),A4)
34494        CALL DPWRST('XXX','WRIT')
34495        WRITE(ICOUT,54)N
34496   54   FORMAT('N = ',I8)
34497        CALL DPWRST('XXX','WRIT')
34498        DO56I=1,N
34499          WRITE(ICOUT,57)I,Y(I),X(I)
34500   57     FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
34501          CALL DPWRST('XXX','WRIT')
34502   56   CONTINUE
34503      ENDIF
34504C
34505C               ********************************************
34506C               **  STEP 1--                              **
34507C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
34508C               ********************************************
34509C
34510      ISTEPN='1'
34511      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CVC2')
34512     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
34513C
34514      IF(N.LE.1)THEN
34515        WRITE(ICOUT,999)
34516        CALL DPWRST('XXX','WRIT')
34517        WRITE(ICOUT,101)ISTR
34518  101   FORMAT('***** ERROR IN COEFFICIENT OF ',A20,' CONFIDENCE ',
34519     1         'LIMITS--')
34520        CALL DPWRST('XXX','WRIT')
34521        WRITE(ICOUT,103)
34522  103   FORMAT('      THE NUMBER OF OBSERVATIONS IN THE RESPONSE ',
34523     1         'VARIABLE IS LESS THAN TWO.')
34524        CALL DPWRST('XXX','WRIT')
34525        WRITE(ICOUT,105)N
34526  105   FORMAT('SAMPLE SIZE = ',I8)
34527        CALL DPWRST('XXX','WRIT')
34528        IERROR='YES'
34529        GOTO9000
34530      ENDIF
34531C
34532      HOLD=Y(1)
34533      DO135I=2,N
34534        IF(Y(I).NE.HOLD)GOTO139
34535  135 CONTINUE
34536      WRITE(ICOUT,999)
34537      CALL DPWRST('XXX','WRIT')
34538      WRITE(ICOUT,101)ISTR
34539      CALL DPWRST('XXX','WRIT')
34540      WRITE(ICOUT,131)HOLD
34541  131 FORMAT('      THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7)
34542      CALL DPWRST('XXX','WRIT')
34543      IERROR='YES'
34544      GOTO9000
34545  139 CONTINUE
34546C
34547C               ***************************************
34548C               **  STEP 3--                         **
34549C               **  COMPUTE CONFIDENCE LIMITS        **
34550C               **  FOR VARIOUS PROBABILITY VALUES.  **
34551C               ***************************************
34552C
34553      ISTEPN='4'
34554      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVC2')
34555     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
34556C
34557C     ICASAN - LIMI   => CONFIDENCE LIMIT FOR THE SD
34558C     ICASA2:  LOWE   => LOWER LIMIT
34559C              UPPE   => UPPER LIMIT
34560C     ICASA3:  RAW    => RAW DATA
34561C              SUMM   => SUMMARY DATA
34562C     ICASA4:  ONES   => ONE-SIDED LIMIT
34563C              TWOS   => TWO-SIDED LIMIT
34564C
34565C     NOTE THAT THE NON-CENTRAL T COMPUTATION CAN GET A LITTLE IFFY
34566C     FOR LARGE VALUES OF ALPHA AND LARGE VALUES OF THE NON-CENTRALITY
34567C     PARAMETER.  SO FOR THE EXACT METHOD, DO NOT USE THE HIGHEST
34568C     LEVEL OF ALPHA (99.9 CONFIDENCE).
34569C
34570      AN=N
34571      ICASA3='RAW'
34572      NUMAL2=NUMALP
34573      IF(ICOMM.EQ.'ON')THEN
34574        CALL DPCVC4(Y,X,N,ITEMP1,TEMP1,TEMP2,
34575     1              ICASAN,ICASA2,ICASA3,ICASA4,
34576     1              ALPHA,NUMAL2,ALOWLM,AUPPLM,
34577     1              YCV,YCVBC,NDIST,NGROUP,
34578     1              ISUBRO,IBUGA3,IERROR)
34579        IF(IERROR.EQ.'YES')GOTO9000
34580      ELSEIF(ICASAN.EQ.'CDLI')THEN
34581        CALL DPCDC3(Y,N,ICASA2,ICASA4,ISEED,MAXNXT,
34582     1              TEMP1,ALPHA,NUMAL2,ALOWLM,AUPPLM,
34583     1              YCD,YMED,YAAD,
34584     1              ISUBRO,IBUGA3,IERROR)
34585        IF(IERROR.EQ.'YES')GOTO9000
34586      ELSEIF(ICASAN.EQ.'CQLI')THEN
34587        CALL DPCQD3(Y,N,ICASA2,ICASA4,ISEED,MAXNXT,IQUAME,
34588     1              TEMP1,ALPHA,NUMAL2,ALOWLM,AUPPLM,
34589     1              CQV,Q1,Q3,
34590     1              ISUBRO,IBUGA3,IERROR)
34591C
34592C       OMIT THE 50% INTERVAL FOR THIS CASE
34593C
34594        ALOWLM(1)=CPUMIN
34595        AUPPLM(1)=CPUMIN
34596        IF(IERROR.EQ.'YES')GOTO9000
34597      ELSE
34598        YMEAN=CPUMIN
34599        YSD=CPUMIN
34600        IF(N.LE.3000 .AND. ICVACI.EQ.'EXAC')NUMAL2=NUMALP-1
34601C
34602        CALL DPCVC3(Y,N,YMEAN,YSD,ICASAN,ICASA2,ICASA3,ICASA4,
34603     1              ISEED,MAXNXT,IDIST,
34604     1              TEMP1,TEMP2,
34605     1              ICVACI,ALPHA,NUMAL2,ALOWLM,AUPPLM,YCV,
34606     1              ISUBRO,IBUGA3,IERROR)
34607C
34608        IF(YSD.LE.0.0)THEN
34609          IERROR='YES'
34610          GOTO9000
34611        ENDIF
34612      ENDIF
34613C
34614      CUTL90=ALOWLM(3)
34615      CUTU90=AUPPLM(3)
34616      CUTL95=ALOWLM(4)
34617      CUTU95=AUPPLM(4)
34618      CUTL99=ALOWLM(5)
34619      CUTU99=AUPPLM(5)
34620      CTL999=ALOWLM(6)
34621      CTU999=AUPPLM(6)
34622      NALP=NUMAL2
34623      DO420I=1,NUMAL2
34624        CONF(I)=100.0*ALPHA(I) + 0.0001
34625  420 CONTINUE
34626C
34627C               ****************************
34628C               **  STEP 5--              **
34629C               **  WRITE EVERYTHING OUT  **
34630C               ****************************
34631C
34632      ISTEPN='5'
34633      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVC2')
34634     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
34635C
34636      IF(IPRINT.EQ.'OFF')GOTO9000
34637C
34638      IF(ICASA4.EQ.'TWOS')THEN
34639        IF(ICOMM.EQ.'ON')THEN
34640          ITITLE=
34641     1    'Two-Sided Confidence Limits for the Common Coefficient'
34642          NCTITL=54
34643          ITITLZ='of Variation for Normally Distributed Data'
34644          NCTITZ=42
34645        ELSEIF(ICASAN.EQ.'CDLI')THEN
34646          ITITLE=
34647     1  'Two-Sided Confidence Limit for the Coefficient of Dispersion'
34648          NCTITL=60
34649          ITITLZ=' '
34650          NCTITZ=0
34651        ELSEIF(ICASAN.EQ.'CQLI')THEN
34652          ITITLE='Two-Sided Confidence Limit for the Coefficient of'
34653          NCTITL=49
34654          ITITLZ='Quartile Dispersion'
34655          NCTITZ=19
34656        ELSE
34657          ITITLE=
34658     1  'Two-Sided Confidence Limits for the Coefficient of Variation'
34659          NCTITL=60
34660          ITITLZ=' '
34661          NCTITZ=0
34662          IF(IDIST.EQ.'LOGN')THEN
34663            ITITLZ='for Lognormally Distributed Data'
34664            NCTITZ=32
34665          ELSE
34666            ITITLZ='for Normally Distributed Data'
34667            NCTITZ=29
34668          ENDIF
34669        ENDIF
34670      ELSEIF(ICASA4.EQ.'ONES')THEN
34671        IF(ICOMM.EQ.'ON')THEN
34672          IF(ICASA2.EQ.'LOWE')THEN
34673            ITITLE=
34674     1 'One-Sided Lower Confidence Limits for the Common Coefficient'
34675            NCTITL=60
34676            ITITLZ='of Variation for Normally Distributed Data'
34677            NCTITZ=42
34678          ELSEIF(ICASA2.EQ.'UPPE')THEN
34679            ITITLE=
34680     1 'One-Sided Upper Confidence Limits for the Common Coefficient'
34681            NCTITL=60
34682            ITITLZ='of Variation for Normally Distributed Data'
34683            NCTITZ=42
34684          ENDIF
34685        ELSEIF(ICASAN.EQ.'CDLI')THEN
34686          IF(ICASA2.EQ.'LOWE')THEN
34687            ITITLE='One-Sided Lower Confidence Limits for the'
34688            NCTITL=41
34689            ITITLZ='Coefficient of Dispersion'
34690            NCTITZ=25
34691          ELSEIF(ICASA2.EQ.'UPPE')THEN
34692            ITITLE='One-Sided Upper Confidence Limits for the'
34693            NCTITL=41
34694            ITITLZ='Coefficient of Dispersion'
34695            NCTITZ=25
34696          ENDIF
34697        ELSEIF(ICASAN.EQ.'CQLI')THEN
34698          IF(ICASA2.EQ.'LOWE')THEN
34699            ITITLE='One-Sided Lower Confidence Limits for the'
34700            NCTITL=41
34701            ITITLZ='Coefficient of Quartile Dispersion'
34702            NCTITZ=34
34703          ELSEIF(ICASA2.EQ.'UPPE')THEN
34704            ITITLE='One-Sided Upper Confidence Limits for the'
34705            NCTITL=41
34706            ITITLZ='Coefficient of Quartile Dispersion'
34707            NCTITZ=34
34708          ENDIF
34709        ELSE
34710          IF(ICASA2.EQ.'LOWE')THEN
34711            ITITLE=
34712     1      'One-Sided Lower Confidence Limits for the Coefficient'
34713            NCTITL=53
34714            IF(IDIST.EQ.'LOGN')THEN
34715              ITITLZ='of Variation (for Lognormally Distributed Data)'
34716              NCTITZ=47
34717            ELSE
34718              ITITLZ='of Variation (for Normally Distributed Data)'
34719              NCTITZ=44
34720            ENDIF
34721          ELSEIF(ICASA2.EQ.'UPPE')THEN
34722            ITITLE=
34723     1      'One-Sided Upper Confidence Limits for the Coefficient'
34724            NCTITL=53
34725            IF(IDIST.EQ.'LOGN')THEN
34726              ITITLZ='of Variation (for Lognormally Distributed Data)'
34727              NCTITZ=47
34728            ELSE
34729              ITITLZ='of Variation (for Normally Distributed Data)'
34730              NCTITZ=44
34731            ENDIF
34732          ENDIF
34733        ENDIF
34734      ENDIF
34735C
34736      ICNT=1
34737      ITEXT(ICNT)=' '
34738      NCTEXT(ICNT)=0
34739      AVALUE(ICNT)=0.0
34740      IDIGIT(ICNT)=-1
34741      IF(ICOMM.EQ.'OFF')THEN
34742        ICNT=ICNT+1
34743        IF(ICASAN.EQ.'CDLI' .OR. ICASAN.EQ.'CQLI')THEN
34744          CONTINUE
34745        ELSEIF(IDIST.EQ.'LOGN')THEN
34746          ITEXT(ICNT)='Method: Koopmans, Owen, and Rosenblatt'
34747          NCTEXT(ICNT)=38
34748        ELSEIF(ICVACI.EQ.'VANG')THEN
34749          ITEXT(ICNT)='Method: Vangel (Modified McKay)'
34750          NCTEXT(ICNT)=31
34751        ELSEIF(ICVACI.EQ.'MCKA')THEN
34752          ITEXT(ICNT)='Method: McKay'
34753          NCTEXT(ICNT)=13
34754        ELSEIF(ICVACI.EQ.'NAIV')THEN
34755          ITEXT(ICNT)='Method: Naive'
34756          NCTEXT(ICNT)=13
34757        ELSEIF(ICVACI.EQ.'EXAC')THEN
34758          IF(N.GT.3000)THEN
34759            ITEXT(ICNT)='Method: Vangel (Modified McKay)'
34760            NCTEXT(ICNT)=31
34761          ELSE
34762            ITEXT(ICNT)='Method: Exact'
34763            NCTEXT(ICNT)=13
34764          ENDIF
34765        ELSEIF(ICVACI.EQ.'GPQ ')THEN
34766          ITEXT(ICNT)='Method: GPQ'
34767          NCTEXT(ICNT)=11
34768        ENDIF
34769        AVALUE(ICNT)=0.0
34770        IDIGIT(ICNT)=-1
34771      ELSE
34772        ICNT=ICNT+1
34773        ITEXT(ICNT)='Method: Forkman'
34774        NCTEXT(ICNT)=15
34775        AVALUE(ICNT)=0.0
34776        IDIGIT(ICNT)=-1
34777      ENDIF
34778      IF(ICOMM.EQ.'OFF')THEN
34779        ICNT=ICNT+1
34780        ITEXT(ICNT)='Response Variable: '
34781        WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1)(1:4)
34782        WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1)(1:4)
34783        NCTEXT(ICNT)=27
34784        AVALUE(ICNT)=0.0
34785        IDIGIT(ICNT)=-1
34786      ELSEIF(ICOMM.EQ.'ON' .AND. IVARID(1).NE.'NULL')THEN
34787        ICNT=ICNT+1
34788        ITEXT(ICNT)='Response Variable: '
34789        WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1)(1:4)
34790        WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1)(1:4)
34791        NCTEXT(ICNT)=27
34792        AVALUE(ICNT)=0.0
34793        IDIGIT(ICNT)=-1
34794        ICNT=ICNT+1
34795        ITEXT(ICNT)='Group-ID Variable: '
34796        WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(2)(1:4)
34797        WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(2)(1:4)
34798        IDIGIT(ICNT)=-1
34799        NCTEXT(ICNT)=27
34800      ENDIF
34801C
34802      IF(NREPL.GT.0)THEN
34803        NRESP=1
34804        DO4101I=1,NREPL
34805          ICNT=ICNT+1
34806          ITEMP=I+NRESP
34807          ITEXT(ICNT)='Factor Variable  : '
34808          WRITE(ITEXT(ICNT)(17:17),'(I1)')I
34809          WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(ITEMP)(1:4)
34810          WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(ITEMP)(1:4)
34811          NCTEXT(ICNT)=27
34812          AVALUE(ICNT)=PID(ITEMP)
34813          IDIGIT(ICNT)=NUMDIG
34814 4101   CONTINUE
34815      ENDIF
34816C
34817      ICNT=ICNT+1
34818      ITEXT(ICNT)=' '
34819      NCTEXT(ICNT)=1
34820      AVALUE(ICNT)=0.0
34821      IDIGIT(ICNT)=-1
34822C
34823      IF(ICOMM.EQ.'OFF')THEN
34824        ICNT=ICNT+1
34825        ITEXT(ICNT)='Summary Statistics:'
34826        NCTEXT(ICNT)=19
34827        AVALUE(ICNT)=0.0
34828        IDIGIT(ICNT)=-1
34829        ICNT=ICNT+1
34830        ITEXT(ICNT)='Number of Observations:'
34831        NCTEXT(ICNT)=23
34832        AVALUE(ICNT)=REAL(N)
34833        IDIGIT(ICNT)=0
34834        IF(ICASAN.EQ.'CDLI')THEN
34835          ICNT=ICNT+1
34836          ITEXT(ICNT)='Sample Median:'
34837          NCTEXT(ICNT)=14
34838          AVALUE(ICNT)=YMED
34839          IDIGIT(ICNT)=NUMDIG
34840          ICNT=ICNT+1
34841          ITEXT(ICNT)='Sample Average Absolute Deviation:'
34842          NCTEXT(ICNT)=34
34843          AVALUE(ICNT)=YAAD
34844          IDIGIT(ICNT)=NUMDIG
34845        ELSEIF(ICASAN.EQ.'CQLI')THEN
34846          ICNT=ICNT+1
34847          ITEXT(ICNT)='Sample Lower Quartile:'
34848          NCTEXT(ICNT)=22
34849          AVALUE(ICNT)=Q1
34850          IDIGIT(ICNT)=NUMDIG
34851          ICNT=ICNT+1
34852          ITEXT(ICNT)='Sample Upper Quartile:'
34853          NCTEXT(ICNT)=22
34854          AVALUE(ICNT)=Q3
34855          IDIGIT(ICNT)=NUMDIG
34856          ICNT=ICNT+1
34857          IF(IQUAME.EQ.'AVER')THEN
34858            ITEXT(ICNT)='Quantile Method: Average'
34859            NCTEXT(ICNT)=24
34860          ELSEIF(IQUAME.EQ.'R6')THEN
34861            ITEXT(ICNT)='Quantile Method: R6'
34862            NCTEXT(ICNT)=19
34863          ELSEIF(IQUAME.EQ.'R7')THEN
34864            ITEXT(ICNT)='Quantile Method: R7'
34865            NCTEXT(ICNT)=19
34866          ELSEIF(IQUAME.EQ.'R8')THEN
34867            ITEXT(ICNT)='Quantile Method: R8'
34868            NCTEXT(ICNT)=19
34869          ENDIF
34870          AVALUE(ICNT)=0.0
34871          IDIGIT(ICNT)=-1
34872        ELSEIF(IDIST.EQ.'NORM')THEN
34873          ICNT=ICNT+1
34874          ITEXT(ICNT)='Sample Mean:'
34875          NCTEXT(ICNT)=12
34876          AVALUE(ICNT)=YMEAN
34877          IDIGIT(ICNT)=NUMDIG
34878          ICNT=ICNT+1
34879          ITEXT(ICNT)='Sample Standard Deviation:'
34880          NCTEXT(ICNT)=26
34881          AVALUE(ICNT)=YSD
34882          IDIGIT(ICNT)=NUMDIG
34883        ELSE
34884          ICNT=ICNT+1
34885          ITEXT(ICNT)='Sample Mean (Log of Data):'
34886          NCTEXT(ICNT)=26
34887          AVALUE(ICNT)=YMEAN
34888          IDIGIT(ICNT)=NUMDIG
34889          ICNT=ICNT+1
34890          ITEXT(ICNT)='Sample Standard Deviation (Log of Data):'
34891          NCTEXT(ICNT)=40
34892          AVALUE(ICNT)=YSD
34893          IDIGIT(ICNT)=NUMDIG
34894        ENDIF
34895        IF(ICASAN.EQ.'CDLI')THEN
34896          ICNT=ICNT+1
34897          ITEXT(ICNT)='Sample Coefficient of Dispersion:'
34898          NCTEXT(ICNT)=33
34899          AVALUE(ICNT)=YCD
34900          IDIGIT(ICNT)=NUMDIG
34901        ELSEIF(ICASAN.EQ.'CQLI')THEN
34902          ICNT=ICNT+1
34903          ITEXT(ICNT)='Sample Coefficient of Quartile Disp:'
34904          NCTEXT(ICNT)=36
34905          AVALUE(ICNT)=CQV
34906          IDIGIT(ICNT)=NUMDIG
34907        ELSE
34908          ICNT=ICNT+1
34909          ITEXT(ICNT)='Sample Coefficient of Variation:'
34910          NCTEXT(ICNT)=32
34911          AVALUE(ICNT)=YCV
34912          IDIGIT(ICNT)=NUMDIG
34913        ENDIF
34914        ICNT=ICNT+1
34915        ITEXT(ICNT)=' '
34916        NCTEXT(ICNT)=1
34917        AVALUE(ICNT)=0.0
34918        IDIGIT(ICNT)=-1
34919      ELSE
34920        ICNT=ICNT+1
34921        ITEXT(ICNT)='Number of Distinct Groups:'
34922        NCTEXT(ICNT)=26
34923        AVALUE(ICNT)=NDIST
34924        IDIGIT(ICNT)=0
34925        ICNT=ICNT+1
34926        ITEXT(ICNT)='Number of Groups Included in Analysis:'
34927        NCTEXT(ICNT)=38
34928        AVALUE(ICNT)=NGROUP
34929        IDIGIT(ICNT)=0
34930        ICNT=ICNT+1
34931        ITEXT(ICNT)='Common Coefficient of Variation:'
34932        NCTEXT(ICNT)=32
34933        AVALUE(ICNT)=YCV
34934        IDIGIT(ICNT)=NUMDIG
34935        ICNT=ICNT+1
34936        ITEXT(ICNT)='Bias Corrected Estimate:'
34937        NCTEXT(ICNT)=24
34938        AVALUE(ICNT)=YCVBC
34939        IDIGIT(ICNT)=NUMDIG
34940      ENDIF
34941C
34942      NUMROW=ICNT
34943      DO4210I=1,NUMROW
34944        NTOT(I)=15
34945 4210 CONTINUE
34946C
34947      IFRST=.TRUE.
34948      ILAST=.TRUE.
34949C
34950      ISTEPN='5A'
34951      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVC2')
34952     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
34953C
34954      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
34955     1            AVALUE,IDIGIT,
34956     1            NTOT,NUMROW,
34957     1            ICAPSW,ICAPTY,ILAST,IFRST,
34958     1            ISUBRO,IBUGA3,IERROR)
34959C
34960      ITITL2(1,1)='Confidence'
34961      NCTIT2(1,1)=10
34962      ITITL2(2,1)='Value (%)'
34963      NCTIT2(2,1)=9
34964C
34965      IF(ICASAN.EQ.'CDLI')THEN
34966        ITITL2(1,2)='Coefficient'
34967        NCTIT2(1,2)=11
34968        ITITL2(2,2)='of Dispersion'
34969        NCTIT2(2,2)=13
34970      ELSEIF(ICASAN.EQ.'CQLI')THEN
34971        ITITL2(1,2)='Coefficient of'
34972        NCTIT2(1,2)=14
34973        ITITL2(2,2)='Quartile Dispersion'
34974        NCTIT2(2,2)=19
34975      ELSE
34976        ITITL2(1,2)='Coefficient'
34977        NCTIT2(1,2)=11
34978        ITITL2(2,2)='of Variation'
34979        NCTIT2(2,2)=12
34980      ENDIF
34981      ICOL=2
34982C
34983      IF(ICASA4.EQ.'TWOS' .OR.
34984     1  (ICASA4.EQ.'ONES' .AND. ICASA2.EQ.'LOWE'))THEN
34985        ICOL=ICOL+1
34986        ITITL2(1,ICOL)='Lower'
34987        NCTIT2(1,ICOL)=5
34988        ITITL2(2,ICOL)='Limit'
34989        NCTIT2(2,ICOL)=5
34990      ENDIF
34991C
34992      IF(ICASA4.EQ.'TWOS' .OR.
34993     1  (ICASA4.EQ.'ONES' .AND. ICASA2.EQ.'UPPE'))THEN
34994        ICOL=ICOL+1
34995        ITITL2(1,ICOL)='Upper'
34996        NCTIT2(1,ICOL)=5
34997        ITITL2(2,ICOL)='Limit'
34998        NCTIT2(2,ICOL)=5
34999      ENDIF
35000C
35001      NUMLIN=2
35002      NUMCOL=ICOL
35003      NUMROW=NUMAL2
35004      NMAX=0
35005      DO4221I=1,NUMCOL
35006        VALIGN(I)='b'
35007        ALIGN(I)='r'
35008        NTOT(I)=15
35009        IF(I.EQ.2 .AND. ICASAN.EQ.'CQLI')NTOT(I)=21
35010        IDIGIT(I)=NUMDIG
35011        ITYPCO(I)='NUME'
35012        IF(I.EQ.1)THEN
35013          NTOT(I)=12
35014          IDIGIT(I)=1
35015          IWHTML(1)=75
35016        ENDIF
35017        NMAX=NMAX+NTOT(I)
35018 4221 CONTINUE
35019      NUMRO2=NUMROW
35020      ICNT=0
35021      DO4223I=1,NUMROW
35022        IF(ALOWLM(I).EQ.CPUMIN .OR. AUPPLM(I).EQ.CPUMIN)THEN
35023          NUMRO2=NUMRO2-1
35024          GOTO4223
35025        ENDIF
35026        ICNT=ICNT+1
35027        DO4225J=1,NUMCOL
35028          NCVALU(ICNT,J)=0
35029          IVALUE(ICNT,J)=' '
35030          AMAT(ICNT,J)=0.0
35031 4225   CONTINUE
35032        AMAT(ICNT,1)=CONF(I)
35033        IF(ICASAN.EQ.'CDLI')THEN
35034          AMAT(ICNT,2)=YCD
35035        ELSEIF(ICASAN.EQ.'CQLI')THEN
35036          AMAT(ICNT,2)=CQV
35037        ELSE
35038          AMAT(ICNT,2)=YCV
35039        ENDIF
35040        JCNT=2
35041        IF(ICASA4.EQ.'TWOS' .OR.
35042     1    (ICASA4.EQ.'ONES' .AND. ICASA2.EQ.'LOWE'))THEN
35043          JCNT=JCNT+1
35044          AMAT(ICNT,JCNT)=ALOWLM(I)
35045        ENDIF
35046        IF(ICASA4.EQ.'TWOS' .OR.
35047     1    (ICASA4.EQ.'ONES' .AND. ICASA2.EQ.'UPPE'))THEN
35048          JCNT=JCNT+1
35049          AMAT(ICNT,JCNT)=AUPPLM(I)
35050        ENDIF
35051 4223 CONTINUE
35052C
35053      IWHTML(1)=150
35054      IWHTML(2)=150
35055      IF(ICASAN.EQ.'CQLI')IWHTML(2)=250
35056      IWHTML(3)=150
35057      IWHTML(4)=150
35058      IWRTF(1)=2000
35059      IWRTF(2)=IWRTF(1)+2000
35060      IF(ICASAN.EQ.'CQLI')IWRTF(2)=IWRTF(1)+3000
35061      IWRTF(3)=IWRTF(2)+2000
35062      IWRTF(4)=IWRTF(3)+2000
35063      IFRST=.TRUE.
35064      ILAST=.TRUE.
35065      NCTIT9=0
35066      NCTITL=0
35067C
35068      CALL DPDTA4(ITITL9,NCTIT9,
35069     1            ITITLE,NCTITL,ITITL2,NCTIT2,
35070     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
35071     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMRO2,
35072     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
35073     1            ICAPSW,ICAPTY,IFRST,ILAST,
35074     1            ISUBRO,IBUGA3,IERROR)
35075C
35076C               *****************
35077C               **  STEP 90--  **
35078C               **  EXIT       **
35079C               *****************
35080C
35081 9000 CONTINUE
35082      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CVC2')THEN
35083        WRITE(ICOUT,999)
35084        CALL DPWRST('XXX','WRIT')
35085        WRITE(ICOUT,9011)
35086 9011   FORMAT('***** AT THE END       OF DPCVC2--')
35087        CALL DPWRST('XXX','WRIT')
35088        WRITE(ICOUT,9012)IERROR
35089 9012   FORMAT('IERROR = ',A4)
35090        CALL DPWRST('XXX','WRIT')
35091      ENDIF
35092C
35093      RETURN
35094      END
35095      SUBROUTINE DPCVC3(Y,N,YMEAN,YSD,ICASAN,ICASA2,ICASA3,ICASA4,
35096     1                  ISEED,MAXNXT,IDIST,
35097     1                  TEMP1,TEMP2,
35098     1                  IMETHD,ALPHA,NALPHA,ALOWLM,AUPPLM,CV,
35099     1                  ISUBRO,IBUGA3,IERROR)
35100C
35101C     PURPOSE--THIS SUBROUTINE COMPUTES CONFIDENCE LIMITS FOR THE
35102C              COEFFIENT OF VARIATION ASSUMING A NORMAL DISTRIBUTION
35103C
35104C              THE FOLLOWING CASES ARE SUPPORTED:
35105C
35106C                 LET A = LOWER COEFFICIENT OF VARIATION CONFIDENCE LIMIT Y
35107C                 LET A = UPPER COEFFICIENT OF VARIATION CONFIDENCE LIMIT Y
35108C                 LET A = ONE SIDED LOWER COEFFICIENT OF VARIATION CONFIDENCE LIMIT Y
35109C                 LET A = ONE SIDED UPPER COEFFICIENT OF VARIATION CONFIDENCE LIMIT Y
35110C
35111C              THE DATA CONSISTS OF N OBSERVATIONS IN Y.
35112C
35113C              WE IMPLEMENT THE FOLLOWING METHODS:
35114C
35115C
35116C              THE COEFFICIENT OF VARIATION IS DEFINED AS:
35117C
35118C                  C = STANDARD DEVIATION/MEAN
35119C
35120C                 1. MARK VANGEL'S MODIFIED MCKAY METHOD:
35121C
35122C                    Clow  = C*[(u1+2)/N - 1)*c**2 + u1/(N + 1)]**(-1/2)
35123C                    Chigh = C*[(u2+2)/N - 1)*c**2 + u1/(N + 1)]**(-1/2)
35124C
35125C                    WHERE
35126C
35127C                    u1 = CHSPPF((1-(ALPHA/2)),N-1)
35128C                    u2 = CHSPPF((ALPHA/2),N-1)
35129C
35130C                    WITH CHSPPF DENOTING THE CHI-SQUARE PERCENT POINT
35131C                    FUNCTION WITH SIGNFICANCE LEVEL ALPHA (E.G.,
35132C                    ALPHA=0.05) AND N - 1 DEGREES OF FREEDOM.
35133C
35134C                 2. MARK VANGEL'S MODIFIED MCKAY METHOD:
35135C
35136C     INPUT ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR OF
35137C                               (UNSORTED OR SORTED) OBSERVATIONS.
35138C                    --N      = THE INTEGER NUMBER OF OBSERVATIONS
35139C                               IN THE VECTOR Y.
35140C                    --ALPHA  = THE SINGLE PRECISION VECTOR OF CONFIDENCE
35141C                               LEVELS
35142C                      NALPHA = THE INTEGER NUMBER OF ALPHA VALUES
35143C     OUTPUT ARGUMENTS-YLOWLM = THE SINGLE PRECISION VECTOR OF LOWER
35144C                               CONFIDENCE LIMIT VALUES
35145C                     -YUPPLM = THE SINGLE PRECISION VECTOR OF UPPER
35146C                               CONFIDENCE LIMIT VALUES
35147C     OTHER DATAPAC   SUBROUTINES NEEDED--MEAN, SD.
35148C     FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT.
35149C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
35150C     LANGUAGE--ANSI FORTRAN.
35151C     REFERENCES--MARK VANGEL (1996), "CONFIDENCE INTERVALS FOR A NORMAL
35152C                 COEFFICIENT OF VARIATION", AMERICAN STATISTICIAN,
35153C                 VOL. 15, NO. 1, PP. 21-26.
35154C                 GUIDE FOR PRACTIONERS", WILEY, PP. 55-56.
35155C               --MCKAY (1932), "DISTRIBUTIONS OF THE COEFFICIENT OF
35156C                 VARIATION AND THE EXTENDED 't' DISTRIBUTION", JOURNAL
35157C                 OF THE ROYAL STATISTICAL SOCIETY, VOL. 95, PP. 695-698.
35158C               --CODE FOR EXACT METHOD BASED ON STEVE VERRILL'S FORTRAN
35159C                 CODE.
35160C     WRITTEN BY--ALAN HECKERT
35161C                 STATISTICAL ENGINEERING LABORATORY
35162C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
35163C                 GAITHERSBURG, MD 20899-8980
35164C                 PHONE--301-975-2899
35165C     ORIGINAL VERSION--DECEMBER  2016.
35166C
35167C---------------------------------------------------------------------
35168C
35169      DIMENSION Y(*)
35170      DIMENSION TEMP1(*)
35171      DIMENSION TEMP2(*)
35172      DIMENSION ALOWLM(*)
35173      DIMENSION AUPPLM(*)
35174      DIMENSION ALPHA(*)
35175C
35176      CHARACTER*4 ICASAN
35177      CHARACTER*4 ICASA2
35178      CHARACTER*4 ICASA3
35179      CHARACTER*4 ICASA4
35180      CHARACTER*4 IMETHD
35181      CHARACTER*4 IDIST
35182      CHARACTER*4 ISUBRO
35183      CHARACTER*4 IBUGA3
35184      CHARACTER*4 IERROR
35185C
35186      CHARACTER*4 IWRITE
35187      CHARACTER*4 IMTHD2
35188      CHARACTER*4 ISUBN1
35189      CHARACTER*4 ISUBN2
35190      CHARACTER*4 ISTEPN
35191      CHARACTER*4 IQUAME
35192C
35193      DOUBLE PRECISION CVFLOW
35194      EXTERNAL CVFLOW
35195      DOUBLE PRECISION CVFUP
35196      EXTERNAL CVFUP
35197C
35198      DOUBLE PRECISION B1
35199      DOUBLE PRECISION C
35200      DOUBLE PRECISION R
35201      DOUBLE PRECISION RE
35202      DOUBLE PRECISION AE
35203C
35204      DOUBLE PRECISION ESTCV
35205      DOUBLE PRECISION DSQRTN
35206      DOUBLE PRECISION DNU1
35207      DOUBLE PRECISION RATIO
35208      DOUBLE PRECISION ALPHAD2
35209      DOUBLE PRECISION OMAD2
35210      COMMON/CVC/ESTCV,DSQRTN,DNU1,RATIO,ALPHAD2,OMAD2
35211C
35212      INCLUDE 'DPCOP2.INC'
35213C
35214C-----START POINT-----------------------------------------------------
35215C
35216      ISUBN1='CVC3'
35217      ISUBN2='    '
35218      IWRITE='OFF'
35219      IERROR='NO'
35220      IMTHD2=IMETHD
35221      IQUAME='ORDE'
35222C
35223      CVSQ=0.0
35224      ANUP1=-99.0
35225C
35226      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVC3')THEN
35227        WRITE(ICOUT,999)
35228  999   FORMAT(1X)
35229        CALL DPWRST('XXX','WRIT')
35230        WRITE(ICOUT,51)
35231   51   FORMAT('**** AT THE BEGINNING OF DPCVC3--')
35232        CALL DPWRST('XXX','WRIT')
35233        WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASAN,ICASA2,ICASA3,ICASA4,IMETHD
35234   52   FORMAT('IBUGA3,ISUBRO,ICASAN,ICASA2,ICASA3,ICASA4,IMETHD = ',
35235     1         6(A4,2X),A4)
35236        CALL DPWRST('XXX','WRIT')
35237        WRITE(ICOUT,53)N,NALPHA,YMEAN,YSD,ALPHA(1)
35238   53   FORMAT('N,NALPHA,YMEAN,YSD,ALPHA(1) = ',2I8,3G15.7)
35239        CALL DPWRST('XXX','WRIT')
35240        IF(ICASA3.EQ.'RAW')THEN
35241          DO56I=1,N
35242            WRITE(ICOUT,57)I,Y(I)
35243   57       FORMAT('I,Y(I) = ',I8,G15.7)
35244            CALL DPWRST('XXX','WRIT')
35245   56     CONTINUE
35246        ENDIF
35247        DO76I=1,NALPHA
35248          WRITE(ICOUT,77)I,ALPHA(I)
35249   77     FORMAT('I,ALPHA(I) = ',I8,G15.7)
35250          CALL DPWRST('XXX','WRIT')
35251   76   CONTINUE
35252      ENDIF
35253C
35254C               ********************************************
35255C               **  STEP 11--                             **
35256C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
35257C               ********************************************
35258C
35259      ISTEPN='11'
35260      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVC3')
35261     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
35262C
35263      DO110I=1,NALPHA
35264        ALOWLM(I)=CPUMIN
35265        AUPPLM(I)=CPUMIN
35266  110 CONTINUE
35267C
35268      IF(ICASA3.EQ.'RAW' .AND. N.LT.2)THEN
35269        WRITE(ICOUT,999)
35270        CALL DPWRST('XXX','WRIT')
35271        WRITE(ICOUT,101)
35272  101   FORMAT('***** ERROR: COEFFICIENT OF VARIANCE CONFIDENCE ',
35273     1         'LIMITS--')
35274        CALL DPWRST('XXX','WRIT')
35275        WRITE(ICOUT,102)
35276  102   FORMAT('      THE NUMBER OF ORIGINAL OBSERVATIONS  IS LESS ',
35277     1         'THAN TWO.')
35278        CALL DPWRST('XXX','WRIT')
35279        WRITE(ICOUT,103)N
35280  103   FORMAT('      SAMPLE SIZE = ',I8)
35281        CALL DPWRST('XXX','WRIT')
35282        IERROR='YES'
35283        GOTO9000
35284      ENDIF
35285C
35286      IF(IDIST.EQ.'LOGN')THEN
35287        DO130I=1,N
35288          IF(Y(I).GT.0.0)THEN
35289            Y(I)=LOG(Y(I))
35290          ELSE
35291            WRITE(ICOUT,999)
35292            CALL DPWRST('XXX','WRIT')
35293            WRITE(ICOUT,101)
35294            CALL DPWRST('XXX','WRIT')
35295            WRITE(ICOUT,131)I
35296  131       FORMAT('      FOR LOG-NORMAL DATA, ROW ',I8,
35297     1             'IS NON-POSITIVE.')
35298            CALL DPWRST('XXX','WRIT')
35299            IERROR='YES'
35300            GOTO9000
35301          ENDIF
35302  130   CONTINUE
35303        CALL MEAN(Y,N,IWRITE,YMEAN,IBUGA3,IERROR)
35304        CALL SD(Y,N,IWRITE,YSD,IBUGA3,IERROR)
35305        CV=SQRT(EXP(YSD*YSD) - 1.0)
35306        GOTO399
35307      ENDIF
35308C
35309C               ********************************************
35310C               **  STEP 21--                             **
35311C               **  CARRY OUT CALCULATIONS FOR PREDICTION **
35312C               **  LIMITS.                               **
35313C               ********************************************
35314C
35315      ISTEPN='21'
35316      IF(IBUGA3.EQ.'ON'.AND.ISUBRO.EQ.'CVC3')
35317     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
35318C
35319C     ICASAN:  CVLI     => CONFIDENCE LIMIT FOR COEFFICIENT OF
35320C                          VARIATION
35321C     ICASA2:  LOWE     => LOWER LIMIT
35322C              UPPE     => UPPER LIMIT
35323C     ICASA3:  RAW      => RAW DATA IN Y1
35324C              SUMM     => SUMMARY DATA IN YMEAN AND YSD
35325C     ICASA4:  ONES     => ONE-SIDED LIMIT
35326C              TWOS     => TWO-SIDED LIMIT
35327C
35328C
35329C     COMPUTE STANDARD DEVIATION
35330C
35331      IF(ICASA3.EQ.'RAW')THEN
35332        CALL MEAN(Y,N,IWRITE,YMEAN,IBUGA3,IERROR)
35333        IF(IMETHD.EQ.'MLE')THEN
35334          CALL SDMLE(Y,N,IWRITE,YSD,IBUGA3,IERROR)
35335          IMTHD2='VANG'
35336        ELSE
35337          CALL SD(Y,N,IWRITE,YSD,IBUGA3,IERROR)
35338        ENDIF
35339      ENDIF
35340C
35341      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVC3')THEN
35342        WRITE(ICOUT,201)YMEAN,YSD
35343  201   FORMAT('YMEAN,YSD = ',2G15.7)
35344        CALL DPWRST('XXX','WRIT')
35345        WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASAN,ICASA2,ICASA3,ICASA4,IMETHD
35346      ENDIF
35347C
35348      IF(YSD.LT.0.0)THEN
35349        WRITE(ICOUT,999)
35350        CALL DPWRST('XXX','WRIT')
35351        WRITE(ICOUT,101)
35352        CALL DPWRST('XXX','WRIT')
35353        WRITE(ICOUT,212)
35354  212   FORMAT('      THE STANDARD DEVIATION OF THE ORIGINAL ',
35355     1         'OBSERVATIONS IS NON-POSITIVE.')
35356        CALL DPWRST('XXX','WRIT')
35357        IERROR='YES'
35358        GOTO9000
35359      ELSEIF(YSD.EQ.0.0)THEN
35360        ALOWLM(I)=0.0
35361        AUPPLM(I)=0.0
35362        GOTO9000
35363      ELSEIF(YMEAN.LE.0.0)THEN
35364        WRITE(ICOUT,999)
35365        CALL DPWRST('XXX','WRIT')
35366        WRITE(ICOUT,101)
35367        CALL DPWRST('XXX','WRIT')
35368        WRITE(ICOUT,217)
35369  217   FORMAT('      THE MEAN OF THE ORIGINAL OBSERVATIONS IS ',
35370     1         'NON-POSITIVE.')
35371        CALL DPWRST('XXX','WRIT')
35372        WRITE(ICOUT,219)
35373  219   FORMAT('      THE COEFFICIENT OF VARIATION CONFIDENCE LIMIT ',
35374     1         'IS NOT COMPUTED IN THIS CASE.')
35375        CALL DPWRST('XXX','WRIT')
35376        IERROR='YES'
35377        GOTO9000
35378      ENDIF
35379C
35380      CV=YSD/YMEAN
35381C
35382      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVC3')THEN
35383        WRITE(ICOUT,220)CV
35384  220   FORMAT('CV = ',G15.7)
35385        CALL DPWRST('XXX','WRIT')
35386      ENDIF
35387C
35388      IF(CV.GT.0.33)THEN
35389        WRITE(ICOUT,999)
35390        CALL DPWRST('XXX','WRIT')
35391        WRITE(ICOUT,221)
35392  221   FORMAT('***** WARNING: COEFFICIENT OF VARIANCE CONFIDENCE ',
35393     1         'LIMITS--')
35394        CALL DPWRST('XXX','WRIT')
35395        WRITE(ICOUT,223)CV
35396  223   FORMAT('      THE COEFFICIENT OF VARIATION ',G15.7,' IS ',
35397     1         '> 0.33.  THE')
35398        CALL DPWRST('XXX','WRIT')
35399        WRITE(ICOUT,224)
35400  224   FORMAT('      THE CONFIDENCE LIMITS APPROXIMATION MAY NOT BE ',
35401     1         'ACCURATE.')
35402        CALL DPWRST('XXX','WRIT')
35403      ENDIF
35404C
35405C     2016/07: ISSUE WITH CHSPPF WHEN DEGREES OF FREEDOM IS LARGE.
35406C              FOR NOW, TRUNCATE DEGREES OF FREEDOM AT 150,000.
35407C
35408      NU1=N-1
35409      IF(NU1.GT.150000)NU1=150000
35410      ANU=REAL(NU1)
35411      AN=REAL(N)
35412      ANUP1=ANU+1.0
35413      CVSQ=CV**2
35414      AFACT=2.0
35415      IF(IMTHD2.EQ.'MCKA')THEN
35416        AFACT=0.0
35417      ELSEIF(IMTHD2.EQ.'GPQ')THEN
35418        AN=REAL(N)
35419        NTEMP=10000
35420        CALL NORRAN(NTEMP,ISEED,TEMP1)
35421        ANU=REAL(N-1)
35422        CALL CHSRAN(NTEMP,ANU,ISEED,TEMP2)
35423        YVAR=YSD**2
35424        DO310II=1,NTEMP
35425          TERM1=ANU*YVAR/TEMP2(II)
35426          TERM3=SQRT(TERM1/AN)
35427          TERM2=YMEAN - SQRT(TERM1/AN)*TEMP1(II)
35428          TEMP1(II)=SQRT(TERM1)/TERM2
35429  310   CONTINUE
35430        CALL SORT(TEMP1,NTEMP,TEMP1)
35431      ELSEIF(IMTHD2.EQ.'EXAC')THEN
35432        IF(N.GT.3000)THEN
35433          IMTHD2='VANG'
35434        ELSE
35435          AN=REAL(N)
35436          ANSQRT=SQRT(AN)
35437          DSQRTN=DBLE(ANSQRT)
35438          ESTCV=DBLE(CV)
35439          RATIO=DSQRTN/ESTCV
35440        ENDIF
35441      ENDIF
35442C
35443  399 CONTINUE
35444C
35445      IF(ICASA4.EQ.'ONES')THEN
35446        IF(IDIST.EQ.'LOGN')THEN
35447          NU1=N-1
35448          ANU1=REAL(NU1)
35449          DO400I=1,NALPHA
35450            ALPHAT=ALPHA(I)
35451            IF(ALPHAT.GE.1.0 .AND. ALPHAT.LT.100.0)ALPHAT=ALPHAT/100.
35452            IF(ALPHAT.LE.0.0 .OR. ALPHAT.GE.1.0)GOTO8000
35453            IF(ALPHAT.GT.0.5)ALPHAT=1.0 - ALPHAT
35454            ALPHAT=ALPHAT
35455            CALL CHSPPF(ALPHAT,NU1TMP,PPFU)
35456            AU=YSD*SQRT(ANU/PPFU)
35457            AU=AU**2
35458            ALPHAT=1.0 - ALPHAT
35459            CALL CHSPPF(ALPHAT,NU1TMP,PPFL)
35460            AL=YSD*SQRT(ANU/PPFL)
35461            AL=AL**2
35462            IF(AL.GE.1.0)THEN
35463              ALOWLM(I)=SQRT(EXP(AL) - 1.0)
35464            ELSE
35465              ALOWLM(I)=CPUMIN
35466            ENDIF
35467            IF(AU.GE.1.0)THEN
35468              AUPPLM(I)=SQRT(EXP(AU) - 1.0)
35469            ELSE
35470              AUPPLM(I)=CPUMAX
35471            ENDIF
35472  400     CONTINUE
35473        ELSEIF(IMTHD2.EQ.'VANG' .OR. IMTHD2.EQ.'MCKA')THEN
35474          DO410I=1,NALPHA
35475            ALPHAT=ALPHA(I)
35476            IF(ALPHAT.GE.1.0 .AND. ALPHAT.LT.100.0)ALPHAT=ALPHAT/100.
35477            IF(ALPHAT.LE.0.0 .OR. ALPHAT.GE.1.0)GOTO8000
35478            IF(ALPHAT.GT.0.5)ALPHAT=1.0 - ALPHAT
35479            ALPHAT=ALPHAT
35480            CALL CHSPPF(ALPHAT,NU1,PPFL)
35481            ALPHAT=1.0 - ALPHAT
35482            CALL CHSPPF(ALPHAT,NU1,PPFU)
35483            TERM1=((PPFL + AFACT)/ANUP1) - 1.0
35484            TERM2=TERM1*CVSQ
35485            TERM3=PPFL/ANU
35486            TERM4=TERM2 + TERM3
35487            IF(TERM4.LE.0.0)THEN
35488              AUPPLM(I)=CPUMAX
35489              GOTO410
35490            ENDIF
35491            AUPPLM(I)=CV/SQRT(TERM4)
35492            TERM1=((PPFU + AFACT)/ANUP1) - 1.0
35493            TERM2=TERM1*CVSQ
35494            TERM3=PPFU/ANU
35495            TERM4=TERM2 + TERM3
35496            IF(TERM4.LE.0.0)THEN
35497              ALOWLM(I)=CPUMIN
35498              GOTO410
35499            ENDIF
35500            ALOWLM(I)=CV/SQRT(TERM4)
35501  410     CONTINUE
35502        ELSEIF(IMTHD2.EQ.'NAIV')THEN
35503          DO420I=1,NALPHA
35504            ALPHAT=ALPHA(I)
35505            IF(ALPHAT.GE.1.0 .AND. ALPHAT.LT.100.0)ALPHAT=ALPHAT/100.
35506            IF(ALPHAT.LE.0.0 .OR. ALPHAT.GE.1.0)GOTO8000
35507            IF(ALPHAT.GT.0.5)ALPHAT=1.0 - ALPHAT
35508            ALPHAT=ALPHAT
35509            CALL CHSPPF(ALPHAT,NU1,PPFL)
35510            ALPHAT=1.0 - ALPHAT
35511            CALL CHSPPF(ALPHAT,NU1,PPFU)
35512            AUPPLM(I)=CV/SQRT(PPFL/ANU)
35513            ALOWLM(I)=CV/SQRT(PPFU/ANU)
35514  420     CONTINUE
35515        ELSEIF(IMTHD2.EQ.'EXAC')THEN
35516          DO430I=1,NALPHA
35517            ALPHAT=ALPHA(I)
35518            IF(ALPHAT.GE.1.0 .AND. ALPHAT.LT.100.0)ALPHAT=ALPHAT/100.
35519            IF(ALPHAT.LE.0.0 .OR. ALPHAT.GE.1.0)GOTO8000
35520            IF(ALPHAT.GT.0.5)ALPHAT=1.0 - ALPHAT
35521            ALPHAT=ALPHAT
35522            ALPHAT=1.0 - ALPHAT
35523C
35524C           COMPUTE UPPER CONFIDENCE LIMIT
35525C
35526            ALPHAD2=ALPHAT
35527            OMAD2=1.0 - ALPHAT
35528            ANU1=REAL(NU1)
35529            DNU1=DBLE(ANU1)
35530            CALL TPPF(ALPHAT,ANU1,TPPFT)
35531            IF(TPPFT.LT.0.0 .OR. TPPFT.GT.100.0)THEN
35532              WRITE(ICOUT,999)
35533              CALL DPWRST('XXX','WRIT')
35534              WRITE(ICOUT,101)
35535              CALL DPWRST('XXX','WRIT')
35536              WRITE(ICOUT,431)
35537  431         FORMAT('      THE T PERCENT POINT VALUE IS OUTSIDE THE ',
35538     1               '(0,100) INTERVAL.')
35539              CALL DPWRST('XXX','WRIT')
35540              WRITE(ICOUT,433)ALPHA(I)
35541  433         FORMAT('      ALPHA = ',F10.3)
35542              CALL DPWRST('XXX','WRIT')
35543              WRITE(ICOUT,435)ANU1
35544  435         FORMAT('      DEGREES OF FREEDOM = ',F10.3)
35545              CALL DPWRST('XXX','WRIT')
35546              GOTO430
35547            ENDIF
35548            B1=0.001D0
35549            C=10.0D0
35550            R=CV
35551            RE=0.000001D0
35552            AE = 0.00001D0
35553            CALL DFZERO(CVFLOW,B1,C,R,RE,AE,IFLAG1)
35554             IF(IFLAG1 .EQ. 4)THEN
35555               IF(B1 .LT. 5.0)THEN
35556CCCCC            WRITE(6,35)
35557C35              FORMAT(/,1X,'tHE LOWER CONFIDENCE BOUND ON THE cov',
35558CCCCC1                  /,1X,'LIES BETWEEN 0 AND .001.',/)
35559                 AUPPLM(I)=0.001
35560               ELSEIF(B1 .GT. 5.0)THEN
35561                 B2 = 10.0D0
35562                 C = 100.0D0
35563                 R = ESTCV
35564                 RE = .000001D0
35565                 AE = .001D0
35566                 CALL DFZERO(CVFLOW,B2,C,R,RE,AE,IFLAG2)
35567                 IF(IFLAG2 .EQ. 4 .AND. B2 .GT. 50.0D0)THEN
35568CCCCC              WRITE(6,45)
35569C45                FORMAT(/,1X,'tHE LOWER CONFIDENCE BOUND ON THE cov',
35570CCCCCX                    /,1X,'IS GREATER THAN 100.',/)
35571                   ALOWLM(I)=100.0
35572                   AUPPLM(I)=CPUMAX
35573                   GOTO430
35574                 ELSE
35575                   AUPPLM(I)=REAL(B2)
35576                 ENDIF
35577               ELSE
35578                 AUPPLM(I)=REAL(B2)
35579               ENDIF
35580             ELSE
35581               AUPPLM(I)=REAL(B1)
35582             ENDIF
35583C
35584C           COMPUTE LOWER CONFIDENCE LIMIT
35585C
35586            IF(TPPFT.GE.RATIO)THEN
35587              ALOWLM(I)=0.0
35588              GOTO430
35589            ENDIF
35590C
35591            B1 = .001D0
35592            C = 10.0D0
35593            R = ESTCV
35594            RE = .000001D0
35595            AE = .00001D0
35596            CALL DFZERO(CVFUP,B1,C,R,RE,AE,IFLAG1)
35597            IF(IFLAG1 .EQ. 4)THEN
35598              IF(B1 .LT. 5.0)THEN
35599CCCCC           WRITE(6,135)
35600C135            FORMAT(/,1X,'tHE UPPER CONFIDENCE BOUND ON THE cov',
35601CCCCC1                 /,1X,'LIES BETWEEN 0 AND .001.',/)
35602                ALOWLM(I)=0.0
35603                GOTO430
35604              ELSEIF(B1 .GT. 5.0) THEN
35605                B2 = 10.0D0
35606                C = 100.0D0
35607                R = ESTCV
35608                RE = .000001D0
35609                AE = .001D0
35610                CALL DFZERO(CVFUP,B2,C,R,RE,AE,IFLAG2)
35611                IF(IFLAG2 .EQ. 4 .AND. B2 .GT. 50.0D0)THEN
35612CCCCC             WRITE(6,145)
35613C145              FORMAT(/,1X,'tHE UPPER CONFIDENCE BOUND ON THE cov',
35614CCCCCX                   /,1X,'IS GREATER THAN 100.',/)
35615                  ALOWLM(I)=100.
35616                  GOTO430
35617                ELSE
35618                  ALOWLM(I)=REAL(B2)
35619                ENDIF
35620              ENDIF
35621            ELSE
35622              ALOWLM(I)=REAL(B1)
35623            ENDIF
35624C
35625  430     CONTINUE
35626        ELSEIF(IMTHD2.EQ.'GPQ')THEN
35627          DO440I=1,NALPHA
35628            ALPHAT=ALPHA(I)
35629            IF(ALPHAT.GE.1.0 .AND. ALPHAT.LT.100.0)ALPHAT=ALPHAT/100.
35630            IF(ALPHAT.LE.0.0 .OR. ALPHAT.GE.1.0)GOTO8000
35631            IF(ALPHAT.GT.0.5)ALPHAT=1.0 - ALPHAT
35632            ALPHAT=ALPHAT
35633            CALL QUANT(ALPHAT,TEMP1,NTEMP,IWRITE,TEMP2,MAXNXT,
35634     1                 IQUAME,XQUANT,IBUGA3,IERROR)
35635            ALOWLM(I)=XQUANT
35636            ALPHAT=1.0 - ALPHAT
35637            CALL QUANT(ALPHAT,TEMP1,NTEMP,IWRITE,TEMP2,MAXNXT,
35638     1                 IQUAME,XQUANT,IBUGA3,IERROR)
35639            AUPPLM(I)=XQUANT
35640  440     CONTINUE
35641        ENDIF
35642      ELSEIF(ICASA4.EQ.'TWOS')THEN
35643        IF(IDIST.EQ.'LOGN')THEN
35644          NU1TMP=N-1
35645          ANU=REAL(NU1TMP)
35646          DO450I=1,NALPHA
35647            ALPHAT=ALPHA(I)
35648            IF(ALPHAT.GE.1.0 .AND. ALPHAT.LT.100.0)ALPHAT=ALPHAT/100.
35649            IF(ALPHAT.LE.0.0 .OR. ALPHAT.GE.1.0)GOTO8000
35650            IF(ALPHAT.GT.0.5)ALPHAT=1.0 - ALPHAT
35651            ALPHAT=ALPHAT/2.0
35652            CALL CHSPPF(ALPHAT,NU1TMP,PPFU)
35653            AU=YSD*SQRT(ANU/PPFU)
35654            AU=AU**2
35655            ALPHAT=1.0 - ALPHAT
35656            CALL CHSPPF(ALPHAT,NU1TMP,PPFL)
35657            AL=YSD*SQRT(ANU/PPFL)
35658            AL=AL**2
35659            IF(AL.GE.1.0)THEN
35660              ALOWLM(I)=SQRT(EXP(AL) - 1.0)
35661            ELSE
35662              ALOWLM(I)=CPUMIN
35663            ENDIF
35664            IF(AU.GE.1.0)THEN
35665              AUPPLM(I)=SQRT(EXP(AU) - 1.0)
35666            ELSE
35667              AUPPLM(I)=CPUMAX
35668            ENDIF
35669  450     CONTINUE
35670        ELSEIF(IMTHD2.EQ.'VANG' .OR. IMETHD.EQ.'MCKA')THEN
35671          DO460I=1,NALPHA
35672            ALPHAT=ALPHA(I)
35673            IF(ALPHAT.GE.1.0 .AND. ALPHAT.LT.100.0)ALPHAT=ALPHAT/100.
35674            IF(ALPHAT.LE.0.0 .OR. ALPHAT.GE.1.0)GOTO8000
35675            IF(ALPHAT.GT.0.5)ALPHAT=1.0 - ALPHAT
35676            ALPHAT=ALPHAT/2.0
35677            CALL CHSPPF(ALPHAT,NU1,PPFL)
35678            ALPHAT=1.0 - ALPHAT
35679            CALL CHSPPF(ALPHAT,NU1,PPFU)
35680            TERM1=((PPFL + AFACT)/ANUP1) - 1.0
35681            TERM2=TERM1*CVSQ
35682            TERM3=PPFL/ANU
35683            TERM4=TERM2 + TERM3
35684            IF(TERM4.LE.0.0)THEN
35685              AUPPLM(I)=CPUMAX
35686              GOTO460
35687            ENDIF
35688            AUPPLM(I)=CV/SQRT(TERM4)
35689            TERM1=((PPFU + AFACT)/ANUP1) - 1.0
35690            TERM2=TERM1*CVSQ
35691            TERM3=PPFU/ANU
35692            TERM4=TERM2 + TERM3
35693            IF(TERM4.LE.0.0)THEN
35694              ALOWLM(I)=CPUMIN
35695              GOTO460
35696            ENDIF
35697            ALOWLM(I)=CV/SQRT(TERM4)
35698C
35699            IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVC3')THEN
35700              WRITE(ICOUT,462)I,ALPHA(I),PPFL,PPFU,AFACT
35701  462         FORMAT('I,ALPHA(I),PPFL,PPFU,AFACT = ',I5,4G15.7)
35702              CALL DPWRST('XXX','WRIT')
35703            ENDIF
35704C
35705  460     CONTINUE
35706        ELSEIF(IMTHD2.EQ.'NAIV')THEN
35707          DO470I=1,NALPHA
35708            ALPHAT=ALPHA(I)
35709            IF(ALPHAT.GE.1.0 .AND. ALPHAT.LT.100.0)ALPHAT=ALPHAT/100.
35710            IF(ALPHAT.LE.0.0 .OR. ALPHAT.GE.1.0)GOTO8000
35711            IF(ALPHAT.GT.0.5)ALPHAT=1.0 - ALPHAT
35712            ALPHAT=ALPHAT/2.0
35713            CALL CHSPPF(ALPHAT,NU1,PPFL)
35714            ALPHAT=1.0 - ALPHAT
35715            CALL CHSPPF(ALPHAT,NU1,PPFU)
35716            AUPPLM(I)=CV/SQRT(PPFL/ANU)
35717            ALOWLM(I)=CV/SQRT(PPFU/ANU)
35718  470     CONTINUE
35719        ELSEIF(IMTHD2.EQ.'EXAC')THEN
35720          DO480I=1,NALPHA
35721            ALPHAT=ALPHA(I)
35722            IF(ALPHAT.GE.1.0 .AND. ALPHAT.LT.100.0)ALPHAT=ALPHAT/100.
35723            IF(ALPHAT.LE.0.0 .OR. ALPHAT.GE.1.0)GOTO8000
35724            IF(ALPHAT.GT.0.5)ALPHAT=1.0 - ALPHAT
35725            ALPHAT=1.0 - (ALPHAT/2.0)
35726C
35727C           COMPUTE UPPER CONFIDENCE LIMIT
35728C
35729            ALPHAD2=ALPHAT
35730            OMAD2=1.0 - ALPHAT
35731            ANU1=REAL(NU1)
35732            DNU1=DBLE(ANU1)
35733            CALL TPPF(ALPHAT,ANU1,TPPFT)
35734            IF(TPPFT.LT.0.0 .OR. TPPFT.GT.100.0)THEN
35735              WRITE(ICOUT,999)
35736              CALL DPWRST('XXX','WRIT')
35737              WRITE(ICOUT,101)
35738              CALL DPWRST('XXX','WRIT')
35739              WRITE(ICOUT,481)
35740  481         FORMAT('      THE T PERCENT POINT VALUE IS OUTSIDE THE ',
35741     1               '(0,100) INTERVAL.')
35742              CALL DPWRST('XXX','WRIT')
35743              WRITE(ICOUT,483)ALPHA(I)
35744  483         FORMAT('      ALPHA = ',F10.3)
35745              CALL DPWRST('XXX','WRIT')
35746              WRITE(ICOUT,485)ANU1
35747  485         FORMAT('      DEGREES OF FREEDOM = ',F10.3)
35748              CALL DPWRST('XXX','WRIT')
35749              GOTO480
35750            ENDIF
35751            B1=0.001D0
35752            C=10.0D0
35753            R=CV
35754            RE=0.000001D0
35755            AE = 0.00001D0
35756            CALL DFZERO(CVFLOW,B1,C,R,RE,AE,IFLAG1)
35757             IF(IFLAG1 .EQ. 4)THEN
35758               IF(B1 .LT. 5.0)THEN
35759CCCCC            WRITE(6,35)
35760C35              FORMAT(/,1X,'tHE LOWER CONFIDENCE BOUND ON THE cov',
35761CCCCC1                  /,1X,'LIES BETWEEN 0 AND .001.',/)
35762                 AUPPLM(I)=0.001
35763               ELSEIF(B1 .GT. 5.0)THEN
35764                 B2 = 10.0D0
35765                 C = 100.0D0
35766                 R = ESTCV
35767                 RE = .000001D0
35768                 AE = .001D0
35769                 CALL DFZERO(CVFLOW,B2,C,R,RE,AE,IFLAG2)
35770                 IF(IFLAG2 .EQ. 4 .AND. B2 .GT. 50.0D0)THEN
35771CCCCC              WRITE(6,45)
35772C45                FORMAT(/,1X,'tHE LOWER CONFIDENCE BOUND ON THE cov',
35773CCCCCX                    /,1X,'IS GREATER THAN 100.',/)
35774                   ALOWLM(I)=100.0
35775                   AUPPLM(I)=CPUMAX
35776                   GOTO480
35777                 ELSE
35778                   AUPPLM(I)=REAL(B2)
35779                 ENDIF
35780               ELSE
35781                 AUPPLM(I)=REAL(B2)
35782               ENDIF
35783             ELSE
35784               AUPPLM(I)=REAL(B1)
35785             ENDIF
35786C
35787C           COMPUTE LOWER CONFIDENCE LIMIT
35788C
35789            IF(TPPFT.GE.RATIO)THEN
35790              ALOWLM(I)=0.0
35791              GOTO480
35792            ENDIF
35793C
35794            B1 = .001D0
35795            C = 10.0D0
35796            R = ESTCV
35797            RE = .000001D0
35798            AE = .00001D0
35799            CALL DFZERO(CVFUP,B1,C,R,RE,AE,IFLAG1)
35800            IF(IFLAG1 .EQ. 4)THEN
35801              IF(B1 .LT. 5.0)THEN
35802CCCCC           WRITE(6,135)
35803C135            FORMAT(/,1X,'tHE UPPER CONFIDENCE BOUND ON THE cov',
35804CCCCC1                 /,1X,'LIES BETWEEN 0 AND .001.',/)
35805                ALOWLM(I)=0.0
35806                GOTO480
35807              ELSEIF(B1 .GT. 5.0) THEN
35808                B2 = 10.0D0
35809                C = 100.0D0
35810                R = ESTCV
35811                RE = .000001D0
35812                AE = .001D0
35813                CALL DFZERO(CVFUP,B2,C,R,RE,AE,IFLAG2)
35814                IF(IFLAG2 .EQ. 4 .AND. B2 .GT. 50.0D0)THEN
35815CCCCC             WRITE(6,145)
35816C145              FORMAT(/,1X,'tHE UPPER CONFIDENCE BOUND ON THE cov',
35817CCCCCX                   /,1X,'IS GREATER THAN 100.',/)
35818                  ALOWLM(I)=100.
35819                  GOTO480
35820                ELSE
35821                  ALOWLM(I)=REAL(B2)
35822                ENDIF
35823              ENDIF
35824            ELSE
35825              ALOWLM(I)=REAL(B1)
35826            ENDIF
35827C
35828  480     CONTINUE
35829        ELSEIF(IMTHD2.EQ.'GPQ')THEN
35830          DO490I=1,NALPHA
35831            ALPHAT=ALPHA(I)
35832            IF(ALPHAT.GE.1.0 .AND. ALPHAT.LT.100.0)ALPHAT=ALPHAT/100.
35833            IF(ALPHAT.LE.0.0 .OR. ALPHAT.GE.1.0)GOTO8000
35834            IF(ALPHAT.GT.0.5)ALPHAT=1.0 - ALPHAT
35835            ALPHAT=ALPHAT/2.0
35836            CALL QUANT(ALPHAT,TEMP1,NTEMP,IWRITE,TEMP2,MAXNXT,
35837     1                 IQUAME,XQUANT,IBUGA3,IERROR)
35838            ALOWLM(I)=XQUANT
35839            ALPHAT=1.0 - ALPHAT
35840            CALL QUANT(ALPHAT,TEMP1,NTEMP,IWRITE,TEMP2,MAXNXT,
35841     1                 IQUAME,XQUANT,IBUGA3,IERROR)
35842            AUPPLM(I)=XQUANT
35843  490     CONTINUE
35844        ENDIF
35845      ENDIF
35846C
35847      GOTO9000
35848C
35849 8000 CONTINUE
35850      WRITE(ICOUT,999)
35851      CALL DPWRST('XXX','WRIT')
35852      WRITE(ICOUT,101)
35853      CALL DPWRST('XXX','WRIT')
35854      WRITE(ICOUT,8001)I
35855 8001 FORMAT('      ROW ',I8,' OF ALPHA VALUES IS OUT OF RANGE.')
35856      CALL DPWRST('XXX','WRIT')
35857      WRITE(ICOUT,8003)ALPHA(I)
35858 8003 FORMAT('      THE VALUE OF ALPHA IS ',G15.7)
35859      CALL DPWRST('XXX','WRIT')
35860      IERROR='YES'
35861      GOTO9000
35862C
35863 9000 CONTINUE
35864      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CVC3')THEN
35865        WRITE(ICOUT,999)
35866        CALL DPWRST('XXX','WRIT')
35867        WRITE(ICOUT,9051)
35868 9051   FORMAT('**** AT THE END OF DPCVC3--')
35869        CALL DPWRST('XXX','WRIT')
35870        WRITE(ICOUT,9052)YSD,PPF,ALPHA(NALPHA),ALPHAT,ANU,PPF
35871 9052   FORMAT('YSD,PPF,ALPHA(NALPHA),ALPHAT,ANU,PPF = ',6G15.7)
35872        CALL DPWRST('XXX','WRIT')
35873      ENDIF
35874C
35875      RETURN
35876      END
35877      SUBROUTINE DPCVC4(Y,X,N,NSIZE,XIDTEM,TEMP1,
35878     1                  ICASAN,ICASA2,ICASA3,ICASA4,
35879     1                  ALPHA,NALPHA,ALOWLM,AUPPLM,
35880     1                  CV,CVBC,NDIST,NGROUP,
35881     1                  ISUBRO,IBUGA3,IERROR)
35882C
35883C     PURPOSE--THIS SUBROUTINE COMPUTES A COMMON COEFFICIENT OF
35884C              VARIATION AND, OPTIONALLY, CONFIDENCE LIMITS FOR THE
35885C              COMMON COEFFIENT OF VARIATION.  IT IS ASSUMED THAT THE
35886C              DATA FOR EACH GROUP IS NORMALLY DISTRIBUTED.
35887C
35888C              THE FOLLOWING CASES ARE SUPPORTED:
35889C
35890C                 LET A = LOWER COMMON COEFFICIENT OF VARIATION CONFIDENCE
35891C                         LIMIT Y X
35892C                 LET A = UPPER COMMON COEFFICIENT OF VARIATION CONFIDENCE
35893C                         LIMIT Y X
35894C                 LET A = ONE SIDED LOWER COMMON COEFFICIENT OF VARIATION
35895C                         CONFIDENCE LIMIT Y X
35896C                 LET A = ONE SIDED UPPER COMMON COEFFICIENT OF VARIATION
35897C                         CONFIDENCE LIMIT Y X
35898C
35899C              THE DATA CONSISTS OF N OBSERVATIONS IN Y WITH X
35900C              DEFINING THE K GROUPS.
35901C
35902C              WE IMPLEMENT THE METHOD OF PANICHKITKOSOLKUL (SEE
35903C              REFERENCE BELOW).
35904C
35905C              THE (BIASED) COMMON COEFFICIENT OF VARIATION IS:
35906C
35907C                 GAMMA = SQRT[SUM{I=1 to k}{(N(i)-1)*C(i)**2}/
35908C                              SUM{i=1 to k}{N(i)-1)}]
35909C
35910C              THE BIAS CORRECTED COMMON COEFFICIENT OF VARIATION IS:
35911C
35912C                 GAMMABC = GAMMA/[1 - 1/(4*SUM{i=1 to k}{N(i) -1)}]
35913C
35914C              WHERE
35915C
35916C                 k     = NUMBER OF GROUPS
35917C                 N(i)  = SAMPLE SIZE OF THE i-TH GROUP
35918C                 C(i)  = SAMPLE COEFFICIENT OF VARIATION OF THE i-TH GROUP
35919C
35920C              THE CONFIDENCE LIMITS ARE COMPUTED AS
35921C
35922C                 LOWER LIMIT = SQRT[SUM{I=1 to k}{(N(i)-1)*U(i)}/
35923C                               (CHSPPF(1-ALPHA/2,DF) - SUM{i=1 to k}{(N(i)-1)*U(i)}]
35924C                 UPPER LIMIT = SQRT[SUM{I=1 to k}{(N(i)-1)*U(i)}/
35925C                               (CHSPPF(ALPHA/2,DF) - SUM{i=1 to k}{(N(i)-1)*U(i)}]
35926C
35927C              WHERE
35928C
35929C                 U(i)  = C(i)**2/(1 + C(i)**2*(N(i)-1)/N(i)
35930C                 DF    = SUM[i=1 to k][N(i) - 1]
35931C
35932C              NOTE THAT THE ALGORITHM CAN BE COMPUTED FROM SUMMARY
35933C              STATISTICS (THE MEAN AND STANDARD DEVIATION IN THIS
35934C              CASE).  BOTH THE RAW DATA AND SUMMARY STATISTIC CASES
35935C              ARE SUPPORTED.
35936C
35937C              IF THE NUMBER OF ALPHA VALUES IS ZERO, THEN ONLY COMPUTE
35938C              THE COMMON CV STATISTIC AND OMIT THE CONFIDENCE INTERVAL.
35939C
35940C     INPUT ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR OF
35941C                               (UNSORTED OR SORTED) OBSERVATIONS.
35942C                    --X      = THE SINGLE PRECISION VECTOR THAT
35943C                               SPECIFIES THE GROUP ID VARIABLE
35944C                    --N      = THE INTEGER NUMBER OF OBSERVATIONS
35945C                               IN THE VECTOR Y.
35946C                    --ALPHA  = THE SINGLE PRECISION VECTOR OF CONFIDENCE
35947C                               LEVELS
35948C                      NALPHA = THE INTEGER NUMBER OF ALPHA VALUES
35949C     OUTPUT ARGUMENTS-YLOWLM = THE SINGLE PRECISION VECTOR OF LOWER
35950C                               CONFIDENCE LIMIT VALUES
35951C                     -YUPPLM = THE SINGLE PRECISION VECTOR OF UPPER
35952C                               CONFIDENCE LIMIT VALUES
35953C     OTHER DATAPAC   SUBROUTINES NEEDED--MEAN, SD.
35954C     FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT.
35955C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
35956C     LANGUAGE--ANSI FORTRAN.
35957C     REFERENCES--JOHANNES FORKMAN (2009)), "ESTIMATOR AND TESTS FOR
35958C                 COMMON COEFFICIENTS OF VARIATION IN NORMAL
35959C                 DISTRIBUTIONS", XCOMMUNICATIONS IN STATISTICS -
35960C                 THEROY AND METHODS, Vol. 38, No. 2, pp. 233-251.
35961C     WRITTEN BY--ALAN HECKERT
35962C                 STATISTICAL ENGINEERING LABORATORY
35963C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
35964C                 GAITHERSBURG, MD 20899-8980
35965C                 PHONE--301-975-2899
35966C     ORIGINAL VERSION--JANUARY   2017.
35967C
35968C---------------------------------------------------------------------
35969C
35970      DIMENSION Y(*)
35971      DIMENSION X(*)
35972      DIMENSION XIDTEM(*)
35973      DIMENSION TEMP1(*)
35974      DIMENSION ALOWLM(*)
35975      DIMENSION AUPPLM(*)
35976      DIMENSION ALPHA(*)
35977C
35978      INTEGER NSIZE(*)
35979C
35980      CHARACTER*4 ICASAN
35981      CHARACTER*4 ICASA2
35982      CHARACTER*4 ICASA3
35983      CHARACTER*4 ICASA4
35984      CHARACTER*4 ISUBRO
35985      CHARACTER*4 IBUGA3
35986      CHARACTER*4 IERROR
35987      CHARACTER*4 IOP
35988C
35989      DOUBLE PRECISION DSUM1
35990      DOUBLE PRECISION DSUM2
35991      DOUBLE PRECISION DSUM3
35992      DOUBLE PRECISION DTERM1
35993      DOUBLE PRECISION DTERM2
35994      DOUBLE PRECISION DTERM3
35995      DOUBLE PRECISION DTERM4
35996C
35997      CHARACTER*4 IWRITE
35998      CHARACTER*4 ISUBN1
35999      CHARACTER*4 ISUBN2
36000      CHARACTER*4 ISTEPN
36001C
36002      INCLUDE 'DPCOP2.INC'
36003C
36004C-----START POINT-----------------------------------------------------
36005C
36006C     ICASAN:  CCVA     => CONFIDENCE LIMIT FOR COMMON COEFFICIENT OF
36007C                          VARIATION
36008C     ICASA2:  LOWE     => LOWER LIMIT
36009C              UPPE     => UPPER LIMIT
36010C     ICASA3:  RAW      => RAW DATA IN Y (AND X IS GROUP-ID VARIABLE)
36011C              SUMM     => SUMMARY DATA (Y CONTAINS MEANS AND X CONTAINS
36012C                          STANDARD DEVIATIONS)
36013C     ICASA4:  ONES     => ONE-SIDED LIMIT
36014C              TWOS     => TWO-SIDED LIMIT
36015C
36016      ISUBN1='CVC4'
36017      ISUBN2='    '
36018      IWRITE='OFF'
36019      IERROR='NO'
36020      NDIST=0
36021      NGROUP=0
36022C
36023      IOP='OPEN'
36024      IFLAG1=1
36025      IFLAG2=0
36026      IFLAG3=0
36027      IFLAG4=0
36028      IFLAG5=0
36029      CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
36030     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
36031     1            IBUGA3,ISUBRO,IERROR)
36032      IF(IERROR.EQ.'YES')GOTO9000
36033      WRITE(IOUNI1,41)
36034   41 FORMAT(4X,'N(I)',11X,'MEAN',13X,'SD',3X,'COEF OF VARI')
36035C
36036      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVC4')THEN
36037        WRITE(ICOUT,999)
36038  999   FORMAT(1X)
36039        CALL DPWRST('XXX','WRIT')
36040        WRITE(ICOUT,51)
36041   51   FORMAT('**** AT THE BEGINNING OF DPCCVC4--')
36042        CALL DPWRST('XXX','WRIT')
36043        WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASAN,ICASA2,ICASA3,ICASA4
36044   52   FORMAT('IBUGA3,ISUBRO,ICASAN,ICASA2,ICASA3,ICASA4 = ',
36045     1         5(A4,2X),A4)
36046        CALL DPWRST('XXX','WRIT')
36047        WRITE(ICOUT,53)N,NALPHA,ALPHA(1)
36048   53   FORMAT('N,NALPHA,ALPHA(1) = ',2I8,G15.7)
36049        CALL DPWRST('XXX','WRIT')
36050        DO56I=1,N
36051          WRITE(ICOUT,57)I,Y(I),X(I)
36052   57     FORMAT('I,Y(I) = ',I8,2G15.7)
36053          CALL DPWRST('XXX','WRIT')
36054   56   CONTINUE
36055        DO76I=1,NALPHA
36056          WRITE(ICOUT,77)I,ALPHA(I)
36057   77     FORMAT('I,ALPHA(I) = ',I8,G15.7)
36058          CALL DPWRST('XXX','WRIT')
36059   76   CONTINUE
36060      ENDIF
36061C
36062C               ********************************************
36063C               **  STEP 11--                             **
36064C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
36065C               ********************************************
36066C
36067      ISTEPN='11'
36068      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVC4')
36069     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
36070C
36071      DO110I=1,NALPHA
36072        ALOWLM(I)=CPUMIN
36073        AUPPLM(I)=CPUMIN
36074  110 CONTINUE
36075C
36076      IF(N.LT.2)THEN
36077        WRITE(ICOUT,999)
36078        CALL DPWRST('XXX','WRIT')
36079        WRITE(ICOUT,101)
36080  101   FORMAT('***** ERROR: COMMON COEFFICIENT OF VARIATION ',
36081     1         'CONFIDENCE LIMITS--')
36082        CALL DPWRST('XXX','WRIT')
36083        WRITE(ICOUT,102)
36084  102   FORMAT('      THE NUMBER OF OBSERVATIONS  IS LESS THAN TWO.')
36085        CALL DPWRST('XXX','WRIT')
36086        WRITE(ICOUT,103)N
36087  103   FORMAT('      SAMPLE SIZE = ',I8)
36088        CALL DPWRST('XXX','WRIT')
36089        IERROR='YES'
36090        GOTO9000
36091      ENDIF
36092C
36093C               ********************************************
36094C               **  STEP 21--                             **
36095C               **  DETERMINE THE NUMBER OF GROUPS        **
36096C               ********************************************
36097C
36098      ISTEPN='21'
36099      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVC4')
36100     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
36101C
36102      IF(ICASA3.EQ.'RAW')THEN
36103        CALL DISTIN(X,N,IWRITE,XIDTEM,NDIST,IBUGA3,IERROR)
36104        IF(IERROR.EQ.'YES')GOTO9000
36105        IF(NDIST.LT.2)THEN
36106          WRITE(ICOUT,999)
36107          CALL DPWRST('XXX','WRIT')
36108          WRITE(ICOUT,101)
36109          CALL DPWRST('XXX','WRIT')
36110          WRITE(ICOUT,201)
36111  201     FORMAT('      THE NUMBER OF GROUPS  IS LESS THAN TWO.')
36112          IERROR='YES'
36113          GOTO9000
36114        ENDIF
36115C
36116C               ********************************************
36117C               **  STEP 22--                             **
36118C               **  COMPUTE THE GROUP STATISTICS          **
36119C               ********************************************
36120C
36121        ISTEPN='22'
36122        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVC4')
36123     1     CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
36124C
36125        NGROUP=0
36126        DSUM1=0.0D0
36127        DSUM2=0.0D0
36128        DSUM3=0.0D0
36129C
36130        DO210II=1,NDIST
36131          K=0
36132C
36133          YMEANT=CPUMIN
36134          YSDT=CPUMIN
36135          CT=CPUMIN
36136C
36137          HOLD=XIDTEM(II)
36138          DO220JJ=1,N
36139            IF(X(JJ).EQ.HOLD)THEN
36140              K=K+1
36141              TEMP1(K)=Y(JJ)
36142            ENDIF
36143  220     CONTINUE
36144C
36145          IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVC4')THEN
36146            WRITE(ICOUT,211)II,K
36147  211       FORMAT('GROUP ',I8,' HAS ',I8,' OBSERVATIONS.')
36148            CALL DPWRST('XXX','WRIT')
36149          ENDIF
36150C
36151          IF(K.GT.1)THEN
36152            CALL MEAN(TEMP1,K,IWRITE,YMEANT,IBUGA3,IERROR)
36153            CALL SD(TEMP1,K,IWRITE,YSDT,IBUGA3,IERROR)
36154C
36155C           CHECK FOR:
36156C
36157C               1) POSITIVE MEAN
36158C                  (OMIT GROUP FROM COMPUTATIONS FOR NON-POSITIVE MEAN)
36159C               2) POSITIVE SD
36160C                  (OMIT GROUP FROM COMPUTATIONS FOR NON-POSITIVE SD)
36161C               3) COEFFICIENT OF VARIATION < 0.33
36162C                  (THIS WILL BE WARNING, BUT INCLUDE IN THE COMPUTATIONS)
36163C
36164            IF(YMEANT.LT.0.0)THEN
36165              WRITE(ICOUT,999)
36166              CALL DPWRST('XXX','WRIT')
36167              WRITE(ICOUT,203)
36168  203         FORMAT('***** WARNING COMMON COEFFICIENT OF VARIANCE ',
36169     1               'CONFIDENCE LIMITS--')
36170              CALL DPWRST('XXX','WRIT')
36171              WRITE(ICOUT,204)II
36172  204         FORMAT('      GROUP ',I5,' HAS A NON-POSITIVE MEAN.')
36173              CALL DPWRST('XXX','WRIT')
36174              WRITE(ICOUT,205)
36175  205         FORMAT('      IT WILL BE OMITTED FROM THE COMPUTATION.')
36176              CALL DPWRST('XXX','WRIT')
36177              GOTO219
36178            ELSEIF(YSDT.LE.0.0)THEN
36179              WRITE(ICOUT,999)
36180              CALL DPWRST('XXX','WRIT')
36181              WRITE(ICOUT,203)
36182              CALL DPWRST('XXX','WRIT')
36183              WRITE(ICOUT,206)II
36184  206         FORMAT('      GROUP ',I5,' HAS A NON-POSITIVE STANDARD ',
36185     1               'DEVIATION.')
36186              CALL DPWRST('XXX','WRIT')
36187              WRITE(ICOUT,205)
36188              CALL DPWRST('XXX','WRIT')
36189              GOTO219
36190            ENDIF
36191            NGROUP=NGROUP+1
36192            CT=YSDT/YMEANT
36193            ANT=REAL(K)
36194            ANTM1=REAL(K) - 1.0
36195            UT=CT**2/(1.0 + (CT**2*ANTM1/ANT))
36196            DSUM1=DSUM1 + DBLE(ANTM1)
36197            DSUM2=DSUM2 + DBLE(ANTM1*CT**2)
36198            DSUM3=DSUM3 + DBLE(ANTM1*UT)
36199C
36200            IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVC4')THEN
36201              WRITE(ICOUT,213)NGROUP,YMEANT,YSDT,CT,UT
36202  213         FORMAT('NGROUP,YMEANT,YSDT,CT,UT = ',I8,4G15.7)
36203              CALL DPWRST('XXX','WRIT')
36204            ENDIF
36205C
36206          ELSE
36207            WRITE(ICOUT,999)
36208            CALL DPWRST('XXX','WRIT')
36209            WRITE(ICOUT,203)
36210            CALL DPWRST('XXX','WRIT')
36211            WRITE(ICOUT,207)II
36212  207       FORMAT('      GROUP ',I5,' HAS FEWER THAN TWO ',
36213     1             'OBSERVATIONS.')
36214            CALL DPWRST('XXX','WRIT')
36215            WRITE(ICOUT,205)
36216            CALL DPWRST('XXX','WRIT')
36217          ENDIF
36218  219   CONTINUE
36219        WRITE(IOUNI1,'(I8,3E15.7)')K,YMEANT,YSDT,CT
36220  210   CONTINUE
36221C
36222      ELSE
36223C
36224C       SUMMARY DATA CASE
36225C
36226        NGROUP=0
36227        DSUM1=0.0D0
36228        DSUM2=0.0D0
36229        DSUM3=0.0D0
36230C
36231        DO260II=1,N
36232          K=NSIZE(II)
36233          IF(K.LT.2)THEN
36234            WRITE(ICOUT,207)II
36235            CALL DPWRST('XXX','WRIT')
36236            WRITE(ICOUT,205)
36237            CALL DPWRST('XXX','WRIT')
36238            GOTO260
36239          ENDIF
36240C
36241C         CHECK FOR:
36242C
36243C             1) POSITIVE MEAN
36244C                (OMIT GROUP FROM COMPUTATIONS FOR NON-POSITIVE MEAN)
36245C             2) POSITIVE SD
36246C                (OMIT GROUP FROM COMPUTATIONS FOR NON-POSITIVE SD)
36247C             3) COEFFICIENT OF VARIATION < 0.33
36248C                (THIS WILL BE WARNING, BUT INCLUDE IN THE COMPUTATIONS)
36249C
36250            YMEANT=Y(II)
36251            YSDT=X(II)
36252            IF(YMEANT.LT.0.0)THEN
36253              WRITE(ICOUT,999)
36254              CALL DPWRST('XXX','WRIT')
36255              WRITE(ICOUT,203)
36256              CALL DPWRST('XXX','WRIT')
36257              WRITE(ICOUT,204)II
36258              CALL DPWRST('XXX','WRIT')
36259              WRITE(ICOUT,205)
36260              CALL DPWRST('XXX','WRIT')
36261              GOTO260
36262            ELSEIF(YSDT.LE.0.0)THEN
36263              WRITE(ICOUT,999)
36264              CALL DPWRST('XXX','WRIT')
36265              WRITE(ICOUT,203)
36266              CALL DPWRST('XXX','WRIT')
36267              WRITE(ICOUT,206)II
36268              CALL DPWRST('XXX','WRIT')
36269              WRITE(ICOUT,205)
36270              CALL DPWRST('XXX','WRIT')
36271              GOTO260
36272            ENDIF
36273            NGROUP=NGROUP+1
36274            CT=YSDT/YMEANT
36275            ANT=REAL(K)
36276            ANTM1=REAL(K) - 1.0
36277            UT=CT**2/(1.0 + (CT**2*ANTM1/ANT))
36278            DSUM1=DSUM1 + DBLE(ANTM1)
36279            DSUM2=DSUM2 + DBLE(ANTM1*CT**2)
36280            DSUM3=DSUM3 + DBLE(ANTM1*UT)
36281C
36282            IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVC4')THEN
36283              WRITE(ICOUT,213)NGROUP,YMEANT,YSDT,CT,UT
36284              CALL DPWRST('XXX','WRIT')
36285            ENDIF
36286  260   CONTINUE
36287      ENDIF
36288C
36289      IF(NGROUP.LT.2)THEN
36290        WRITE(ICOUT,999)
36291        CALL DPWRST('XXX','WRIT')
36292        WRITE(ICOUT,101)
36293        CALL DPWRST('XXX','WRIT')
36294        WRITE(ICOUT,281)
36295  281   FORMAT('      AFTER REMOVING GROUPS, LESS THAN TWO GROUPS ',
36296     1         'REMAIN.')
36297        CALL DPWRST('XXX','WRIT')
36298        IERROR='YES'
36299        GOTO9000
36300      ENDIF
36301C
36302      DTERM1=DSQRT(DSUM2/DSUM1)
36303      DTERM2=1.0D0 - (1.0D0/(4.0D0*DSUM1))
36304      CV=REAL(DTERM1)
36305      CVBC=REAL(DTERM1/DTERM2)
36306C
36307C               ********************************************
36308C               **  STEP 31--                             **
36309C               **  GENERATE CONFIDENCE LIMITS FOR        **
36310C               **  VARIOUS VALUES OF ALPHA               **
36311C               ********************************************
36312C
36313      ISTEPN='31'
36314      IF(IBUGA3.EQ.'ON'.AND.ISUBRO.EQ.'CVC4')
36315     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
36316C
36317      ANU1=REAL(DSUM1)
36318      IF(ANU1.GE.150000)THEN
36319        NU1=150000
36320      ELSE
36321        NU1=INT(ANU1+0.1)
36322      ENDIF
36323C
36324      IF(ICASA4.EQ.'ONES')THEN
36325        DO420I=1,NALPHA
36326          ALPHAT=ALPHA(I)
36327          IF(ALPHAT.GE.1.0 .AND. ALPHAT.LT.100.0)ALPHAT=ALPHAT/100.
36328          IF(ALPHAT.LE.0.0 .OR. ALPHAT.GE.1.0)GOTO8000
36329          IF(ALPHAT.GT.0.5)ALPHAT=1.0 - ALPHAT
36330          ALPHAT=ALPHAT
36331          CALL CHSPPF(ALPHAT,NU1,PPFU)
36332          ALPHAT=1.0 - ALPHAT
36333          CALL CHSPPF(ALPHAT,NU1,PPFL)
36334          DTERM3=DSQRT(DSUM3/(DBLE(PPFL) - DSUM3))
36335          DTERM4=DSQRT(DSUM3/(DBLE(PPFU) - DSUM3))
36336          ALOWLM(I)=REAL(DTERM3)
36337          AUPPLM(I)=REAL(DTERM4)
36338  420   CONTINUE
36339      ELSEIF(ICASA4.EQ.'TWOS')THEN
36340        DO470I=1,NALPHA
36341          ALPHAT=ALPHA(I)
36342          IF(ALPHAT.GE.1.0 .AND. ALPHAT.LT.100.0)ALPHAT=ALPHAT/100.
36343          IF(ALPHAT.LE.0.0 .OR. ALPHAT.GE.1.0)GOTO8000
36344          IF(ALPHAT.GT.0.5)ALPHAT=1.0 - ALPHAT
36345          ALPHAT=ALPHAT/2.0
36346          CALL CHSPPF(ALPHAT,NU1,PPFU)
36347          ALPHAT=1.0 - ALPHAT
36348          CALL CHSPPF(ALPHAT,NU1,PPFL)
36349          DTERM3=DSQRT(DSUM3/(DBLE(PPFL) - DSUM3))
36350          DTERM4=DSQRT(DSUM3/(DBLE(PPFU) - DSUM3))
36351          ALOWLM(I)=REAL(DTERM3)
36352          AUPPLM(I)=REAL(DTERM4)
36353  470   CONTINUE
36354      ENDIF
36355C
36356      GOTO9000
36357C
36358 8000 CONTINUE
36359      WRITE(ICOUT,999)
36360      CALL DPWRST('XXX','WRIT')
36361      WRITE(ICOUT,101)
36362      CALL DPWRST('XXX','WRIT')
36363      WRITE(ICOUT,8001)I
36364 8001 FORMAT('      ROW ',I8,' OF ALPHA VALUES IS OUT OF RANGE.')
36365      CALL DPWRST('XXX','WRIT')
36366      WRITE(ICOUT,8003)ALPHA(I)
36367 8003 FORMAT('      THE VALUE OF ALPHA IS ',G15.7)
36368      CALL DPWRST('XXX','WRIT')
36369      IERROR='YES'
36370      GOTO9000
36371C
36372 9000 CONTINUE
36373C
36374      IOP='CLOS'
36375      CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
36376     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
36377     1            IBUGA3,ISUBRO,IERROR)
36378C
36379      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CVC4')THEN
36380        WRITE(ICOUT,999)
36381        CALL DPWRST('XXX','WRIT')
36382        WRITE(ICOUT,9051)
36383 9051   FORMAT('**** AT THE END OF DPCCVC4--')
36384        CALL DPWRST('XXX','WRIT')
36385        WRITE(ICOUT,9053)DTERM1,DTERM2,CV,CVBC
36386 9053   FORMAT('DTERM1,DTERM2,CV,CVBC = ',4G15.7)
36387        CALL DPWRST('XXX','WRIT')
36388      ENDIF
36389C
36390      RETURN
36391      END
36392      SUBROUTINE DPCVOT(YTEMP,XTEMP,MAXNXT,ICASAN,
36393     1                  ICAPSW,IFORSW,
36394     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
36395C
36396C     PURPOSE--CARRY OUT COCHRAN VARIANCE OUTLIER TEST
36397C     EXAMPLE--COCHRAN VARIANCE OUTLIER TEST Y X
36398C     REFERENCES--RUBEN U.E. 't LAM (2010), "SCRUTINY OF VARIANCE RESULTS
36399C                 FOR OUTLIERS: COCHRAN'S TEST OPTIMIZED", ANALYTICA
36400C                 CHIMICA ACTA, VOL. 659, NO. 1-2, PP. 68-84.
36401C               --KANJI (2006), "100 STATISTICAL TESTS", SAGE
36402C                 PUBLICATIONS, P. 75.
36403C               --W.G. Cochran, The distribution of the largest of a set
36404C                 of estimated variances as a fraction of their total,
36405C                 Annals of Human Genetics (London) 11(1), 47–52 (January
36406C                 1941).
36407C               --ISO Standard 5725–2:1994, “Accuracy (trueness and
36408C                 precision) of measurement methods and results – Part 2:
36409C                 Basic method for the determination of repeatability and
36410C                 reproducibility of a standard measurement method”,
36411C                 International Organization for Standardization,
36412C                 Geneva, Switzerland, 1994;
36413C                 http://www.iso.org/iso/iso_catalogue/catalogue_tc/
36414C                 catalogue_detail.htm?csnumber=11834
36415C     WRITTEN BY--ALAN HECKERT
36416C                 STATISTICAL ENGINEERING DIVISION
36417C                 INFORMATION TECHNOLOGY LABORATORY
36418C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
36419C                 Gaithersburg, MD 20899-8980
36420C                 PHONE--301-975-2899
36421C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
36422C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
36423C     LANGUAGE--ANSI FORTRAN (1977)
36424C     VERSION NUMBER--2015/3
36425C     ORIGINAL VERSION--MARCH     2015.
36426C
36427C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
36428C
36429      CHARACTER*4 ICASAN
36430      CHARACTER*4 IFORSW
36431      CHARACTER*4 IMULT
36432      CHARACTER*4 IBUGA2
36433      CHARACTER*4 IBUGA3
36434      CHARACTER*4 IBUGQ
36435      CHARACTER*4 ISUBRO
36436      CHARACTER*4 IFOUND
36437      CHARACTER*4 IERROR
36438      CHARACTER*4 ICAPSW
36439C
36440      CHARACTER*4 ICASA2
36441      CHARACTER*4 ICASE
36442      CHARACTER*4 ISUBN1
36443      CHARACTER*4 ISUBN2
36444      CHARACTER*4 ISTEPN
36445      CHARACTER*4 IH
36446      CHARACTER*4 IH2
36447      CHARACTER*4 IHOST1
36448      CHARACTER*4 ISUBN0
36449C
36450      CHARACTER*40 INAME
36451      PARAMETER (MAXSPN=30)
36452      CHARACTER*4 IVARN1(MAXSPN)
36453      CHARACTER*4 IVARN2(MAXSPN)
36454      CHARACTER*4 IVARTY(MAXSPN)
36455      REAL PVAR(MAXSPN)
36456      INTEGER ILIS(MAXSPN)
36457      INTEGER NRIGHT(MAXSPN)
36458      INTEGER ICOLR(MAXSPN)
36459C
36460C---------------------------------------------------------------------
36461C
36462      DIMENSION YTEMP(*)
36463      DIMENSION XTEMP(*)
36464C
36465C-----COMMON----------------------------------------------------------
36466C
36467      INCLUDE 'DPCOPA.INC'
36468C
36469      DIMENSION TEMP1(MAXOBV)
36470      DIMENSION TEMP2(MAXOBV)
36471      DIMENSION TEMP3(MAXOBV)
36472      DIMENSION TEMP4(MAXOBV)
36473      DIMENSION NU(MAXOBV)
36474C
36475      INCLUDE 'DPCOZZ.INC'
36476      INCLUDE 'DPCOZI.INC'
36477      EQUIVALENCE(GARBAG(IGARB1),TEMP1(1))
36478      EQUIVALENCE(GARBAG(IGARB2),TEMP2(1))
36479      EQUIVALENCE(GARBAG(IGARB3),TEMP3(1))
36480      EQUIVALENCE(GARBAG(IGARB4),TEMP4(1))
36481      EQUIVALENCE(IGARBG(IIGAR1),NU(1))
36482C
36483      INCLUDE 'DPCOHK.INC'
36484      INCLUDE 'DPCOSU.INC'
36485      INCLUDE 'DPCODA.INC'
36486      INCLUDE 'DPCOST.INC'
36487C
36488C-----COMMON VARIABLES (GENERAL)--------------------------------------
36489C
36490      INCLUDE 'DPCOP2.INC'
36491C
36492C-----START POINT-----------------------------------------------------
36493C
36494      ISUBN1='DPCV'
36495      ISUBN2='OT '
36496      IERROR='NO'
36497      IFOUND='YES'
36498C
36499      MAXCP1=MAXCOL+1
36500      MAXCP2=MAXCOL+2
36501      MAXCP3=MAXCOL+3
36502      MAXCP4=MAXCOL+4
36503      MAXCP5=MAXCOL+5
36504      MAXCP6=MAXCOL+6
36505C
36506C               ****************************************************
36507C               **  TREAT THE COCHRAN VARIANCE OUTLIER TEST CASE  **
36508C               ****************************************************
36509C
36510      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CVOT')THEN
36511        WRITE(ICOUT,999)
36512  999   FORMAT(1X)
36513        CALL DPWRST('XXX','BUG ')
36514        WRITE(ICOUT,51)
36515   51   FORMAT('***** AT THE BEGINNING OF DPCVOT--')
36516        CALL DPWRST('XXX','BUG ')
36517        WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ,ISUBRO
36518   52   FORMAT('IBUGA2,IBUGA3,IBUGQ,ISUBRO = ',3(A4,2X),A4)
36519        CALL DPWRST('XXX','BUG ')
36520        WRITE(ICOUT,55)MAXNXT,IFORSW
36521   55   FORMAT('MAXNXT,IFORSW = ',I8,2X,A4)
36522        CALL DPWRST('XXX','BUG ')
36523      ENDIF
36524C
36525C               *********************************
36526C               **  STEP 1--                   **
36527C               **  EXTRACT THE COMMAND        **
36528C               *********************************
36529C
36530      ISTEPN='1'
36531      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CVOT')
36532     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
36533C
36534C
36535C     CHECK FOR FOLLOWING COMMAND:
36536C
36537C        <MULTIPLE> COCHRAN <MINIMUM/MAXIMUM/TWO-SIDED> VARIANCE OUTLIER TEST
36538C
36539      ICASAN='CVOT'
36540      ICASA2='UPPE'
36541      IMULT='OFF'
36542      IFOUND='NO'
36543      ISTRT=0
36544C
36545C     FIRST CHECK FOR WORD "MULTIPLE"
36546C
36547      IF(ICOM.EQ.'MULT')THEN
36548        ISTRT=1
36549        IMULT='ON'
36550      ENDIF
36551C
36552C     NEXT CHECK FOR WORD "COCHRAN"
36553C
36554      IF(ISTRT.EQ.0)THEN
36555        IF(ICOM.EQ.'COCH')THEN
36556          ISTRT=1
36557        ELSE
36558          GOTO9000
36559        ENDIF
36560      ELSE
36561        IF(IHARG(ISTRT+1).EQ.'COCH')THEN
36562          ISTRT=ISTRT+1
36563        ELSE
36564          GOTO9000
36565        ENDIF
36566      ENDIF
36567C
36568C     NEXT CHECK FOR MINIMUM (LOWER), MAXIMUM (UPPER), OR TWO-SIDED
36569C
36570      IF(IHARG(ISTRT).EQ.'LOWE' .OR. IHARG(ISTRT).EQ.'MINI')THEN
36571        ISTRT=ISTRT+1
36572        ICASA2='LOWE'
36573      ELSEIF(IHARG(ISTRT).EQ.'UPPE' .OR. IHARG(ISTRT).EQ.'MAXI')THEN
36574        ISTRT=ISTRT+1
36575        ICASA2='UPPE'
36576      ELSEIF(IHARG(ISTRT).EQ.'TWOS')THEN
36577        ISTRT=ISTRT+1
36578        ICASA2='TWOS'
36579      ELSEIF(IHARG(ISTRT).EQ.'TWO ' .AND.
36580     1       IHARG(ISTRT+1).EQ.'SIDE')THEN
36581        ISTRT=ISTRT+2
36582        ICASA2='TWOS'
36583      ENDIF
36584C
36585C     CHECK FOR "VARIANCE OUTLIER TEST"
36586C
36587      IF(IHARG(ISTRT).EQ.'VARI' .AND. IHARG(ISTRT+1).EQ.'OUTL' .AND.
36588     1   IHARG(ISTRT+2).EQ.'TEST')THEN
36589         IFOUND='YES'
36590         ISTRT=ISTRT+2
36591      ELSEIF(IHARG(ISTRT).EQ.'VARI' .AND. IHARG(ISTRT+1).EQ.'OUTL')THEN
36592         IFOUND='YES'
36593         ISTRT=ISTRT+1
36594      ELSEIF(IHARG(ISTRT).EQ.'VARI' .AND. IHARG(ISTRT+1).EQ.'TEST')THEN
36595         IFOUND='YES'
36596         ISTRT=ISTRT+1
36597      ELSEIF(IHARG(ISTRT).EQ.'VARI')THEN
36598         IFOUND='YES'
36599      ENDIF
36600C
36601      IF(IFOUND.EQ.'NO')GOTO9000
36602      IF(ISTRT.GT.0)THEN
36603        CALL ADJUST(ISTRT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
36604      ENDIF
36605C
36606C               *********************************
36607C               **  STEP 2--                   **
36608C               **  EXTRACT THE VARIABLE LIST  **
36609C               *********************************
36610C
36611      ISTEPN='2'
36612      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CVOT')
36613     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
36614C
36615      INAME='COCHRAN VARIANCE OUTLIER TEST'
36616      MINNA=1
36617      MAXNA=100
36618      MINNVA=2
36619      MAXNVA=2
36620      IFLAGE=1
36621      IFLAGM=0
36622      IF(IMULT.EQ.'ON')THEN
36623        IFLAGE=0
36624        IFLAGM=1
36625        MINNVA=2
36626        MAXNVA=30
36627      ENDIF
36628      MINN2=2
36629      IFLAGP=0
36630      JMIN=1
36631      JMAX=NUMARG
36632C
36633      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
36634     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
36635     1            JMIN,JMAX,
36636     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
36637     1            IVARN1,IVARN2,IVARTY,PVAR,
36638     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
36639     1            MINNVA,MAXNVA,
36640     1            IFLAGM,IFLAGP,
36641     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
36642      IF(IERROR.EQ.'YES')GOTO9000
36643C
36644      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CVOT')THEN
36645        WRITE(ICOUT,999)
36646        CALL DPWRST('XXX','BUG ')
36647        WRITE(ICOUT,181)
36648  181   FORMAT('***** AFTER CALL DPPARS--')
36649        CALL DPWRST('XXX','BUG ')
36650        WRITE(ICOUT,182)NQ,NUMVAR,IMULT
36651  182   FORMAT('NQ,NUMVAR,IMULT = ',2I8,2X,A4)
36652        CALL DPWRST('XXX','BUG ')
36653        IF(NUMVAR.GT.0)THEN
36654          DO185I=1,NUMVAR
36655            WRITE(ICOUT,187)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
36656     1                      ICOLR(I)
36657  187       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
36658     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
36659            CALL DPWRST('XXX','BUG ')
36660  185     CONTINUE
36661        ENDIF
36662      ENDIF
36663C
36664C               ******************************************************
36665C               **  STEP 3--                                       **
36666C               **  GENERATE THE COCHRAN VARIANCE OUTLIER TEST FOR **
36667C               **  THE VARIOUS  CASES                             **
36668C               ******************************************************
36669C
36670      ISTEPN='3'
36671      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CVOT')
36672     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
36673C
36674C               *****************************************
36675C               **  STEP 3A--                          **
36676C               **  CASE 1: TWO RESPONSE VARIABLES     **
36677C               **          WITH NO REPLICATION        **
36678C               *****************************************
36679C
36680C     NOTE: ONLY ALLOW MATRIX ARGUMENTS FOR "MULTIPLE" CASE.
36681C           FOR CASE WHERE SECOND VARIABLE IS A GROUP-ID VARIABLE,
36682C           MATRIX ARGUMENTS DON'T MAKE SENSE.
36683C
36684      IF(IMULT.EQ.'OFF')THEN
36685        ISTEPN='3A'
36686        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CVOT')
36687     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
36688C
36689        ICOL=1
36690        NUMVA2=2
36691        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
36692     1              INAME,IVARN1,IVARN2,IVARTY,
36693     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
36694     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
36695     1              MAXCP4,MAXCP5,MAXCP6,
36696     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
36697     1              YTEMP,XTEMP,YTEMP,NLOCAL,NLOCA2,NLOCA3,ICASE,
36698     1              IBUGA3,ISUBRO,IFOUND,IERROR)
36699        IF(IERROR.EQ.'YES')GOTO9000
36700C
36701C               ******************************************************
36702C               **  STEP 3B--                                       **
36703C               **  PREPARE FOR ENTRANCE INTO DPCVO2--              **
36704C               ******************************************************
36705C
36706        ISTEPN='3B'
36707        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CVOT')THEN
36708          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
36709          WRITE(ICOUT,999)
36710          CALL DPWRST('XXX','BUG ')
36711          WRITE(ICOUT,331)
36712  331     FORMAT('***** FROM DPCVOT, AS WE ARE ABOUT TO CALL DPCVO2--')
36713          CALL DPWRST('XXX','BUG ')
36714          WRITE(ICOUT,332)NLOCAL
36715  332     FORMAT('NLOCAL = ',I8)
36716          CALL DPWRST('XXX','BUG ')
36717          DO335I=1,NLOCAL
36718            WRITE(ICOUT,336)I,YTEMP(I),XTEMP(I)
36719  336       FORMAT('I,YTEMP(I),XTEMP(I) = ',I8,2G15.7)
36720            CALL DPWRST('XXX','BUG ')
36721  335     CONTINUE
36722        ENDIF
36723C
36724        CALL DPCVO2(YTEMP,XTEMP,NLOCAL,ICASA2,
36725     1              IVARN1,IVARN2,
36726     1              TEMP1,TEMP2,TEMP3,TEMP4,NU,
36727     1              ICAPSW,ICAPTY,IFORSW,IMULT,
36728     1              STATVA,STATV2,STATCU,STATCL,PVALU,PVALL,
36729     1              CUT001,CUT005,CUT01,CUT025,CUT05,CUT10,CUT25,
36730     1              CUT50,
36731     1              CUT75,CUT90,CUT95,CUT975,CUT99,CUT995,CUT999,
36732     1              IBUGA3,ISUBRO,IERROR)
36733C
36734C               *******************************************************
36735C               **  STEP 4A--                                        **
36736C               **  CASE 2: MULTIPLE RESPONSE VARIABLES.  NOTE THAT  **
36737C               **          FOR THE COCHRAN TEST, THE MULTIPLE LABS  **
36738C               **          ARE CONVERTED INTO A "Y X" STACKED PAIR  **
36739C               **          WHERE "X" IS THE LAB-ID VARIABLE.        **
36740C               *******************************************************
36741C
36742      ELSEIF(IMULT.EQ.'ON')THEN
36743        ISTEPN='4A'
36744        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CVOT')
36745     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
36746C
36747        ICOL=1
36748        NUMVA2=NUMVAR
36749        CALL DPPAR8(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
36750     1              INAME,IVARN1,IVARN2,IVARTY,
36751     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
36752     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
36753     1              MAXCP4,MAXCP5,MAXCP6,
36754     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
36755     1              TEMP1,YTEMP,XTEMP,NLOCAL,ICASE,
36756     1              IBUGA3,ISUBRO,IFOUND,IERROR)
36757        IF(IERROR.EQ.'YES')GOTO9000
36758        NUMVAR=2
36759C
36760        IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CVOT')THEN
36761          ISTEPN='4B'
36762          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
36763          WRITE(ICOUT,999)
36764          CALL DPWRST('XXX','BUG ')
36765          WRITE(ICOUT,442)
36766  442     FORMAT('***** FROM THE MIDDLE  OF DPCVOT--')
36767          CALL DPWRST('XXX','BUG ')
36768          WRITE(ICOUT,443)ICASAN,NUMVAR,NLOCAL
36769  443     FORMAT('ICASAN,NUMVAR,NLOCAL = ',A4,2I8)
36770          CALL DPWRST('XXX','BUG ')
36771          IF(NLOCAL.GE.1)THEN
36772            DO445I=1,NLOCAL
36773              WRITE(ICOUT,446)I,YTEMP(I),XTEMP(I)
36774  446         FORMAT('I,YTEMP(I),XTEMP(I) = ',I8,2G15.7)
36775              CALL DPWRST('XXX','BUG ')
36776  445       CONTINUE
36777          ENDIF
36778        ENDIF
36779C
36780        CALL DPCVO2(YTEMP,XTEMP,NLOCAL,ICASA2,
36781     1              IVARN1,IVARN2,
36782     1              TEMP1,TEMP2,TEMP3,TEMP4,NU,
36783     1              ICAPSW,ICAPTY,IFORSW,IMULT,
36784     1              STATVA,STATV2,STATCU,STATCL,PVALU,PVALL,
36785     1              CUT001,CUT005,CUT01,CUT025,CUT05,CUT10,CUT25,
36786     1              CUT50,
36787     1              CUT75,CUT90,CUT95,CUT975,CUT99,CUT995,CUT999,
36788     1              IBUGA3,ISUBRO,IERROR)
36789C
36790      ENDIF
36791C
36792C               ***************************************
36793C               **  STEP 61--                        **
36794C               **  UPDATE INTERNAL DATAPLOT TABLES  **
36795C               ***************************************
36796C
36797      ISTEPN='61'
36798      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CVOT')
36799     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
36800C
36801      ISUBN0='DPLT'
36802C
36803      IF(ICASA2.EQ.'UPPE')THEN
36804        IH='STAT'
36805        IH2='VAL '
36806        VALUE0=STATVA
36807        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
36808     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
36809     1              IANS,IWIDTH,IBUGA3,IERROR)
36810        IH='STAT'
36811        IH2='CDF '
36812        VALUE0=STATCU
36813        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
36814     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
36815     1              IANS,IWIDTH,IBUGA3,IERROR)
36816        IH='PVAL'
36817        IH2='UE  '
36818        VALUE0=PVALU
36819        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
36820     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
36821     1              IANS,IWIDTH,IBUGA3,IERROR)
36822      ELSEIF(ICASA2.EQ.'LOWE')THEN
36823        IH='STAT'
36824        IH2='VAL '
36825        VALUE0=STATV2
36826        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
36827     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
36828     1              IANS,IWIDTH,IBUGA3,IERROR)
36829        IH='STAT'
36830        IH2='CDF '
36831        VALUE0=STATCL
36832        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
36833     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
36834     1              IANS,IWIDTH,IBUGA3,IERROR)
36835        IH='PVAL'
36836        IH2='UE  '
36837        VALUE0=PVALL
36838        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
36839     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
36840     1              IANS,IWIDTH,IBUGA3,IERROR)
36841      ELSE
36842        IH='STAT'
36843        IH2='VALU'
36844        VALUE0=STATVA
36845        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
36846     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
36847     1              IANS,IWIDTH,IBUGA3,IERROR)
36848C
36849        IH='STAT'
36850        IH2='VALL'
36851        VALUE0=STATV2
36852        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
36853     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
36854     1              IANS,IWIDTH,IBUGA3,IERROR)
36855      ENDIF
36856C
36857      IH='CUTO'
36858      IH2='FF50'
36859      VALUE0=CUT50
36860      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
36861     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
36862     1IANS,IWIDTH,IBUGA3,IERROR)
36863C
36864      IH='CUTO'
36865      IH2='FF75'
36866      VALUE0=CUT75
36867      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
36868     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
36869     1IANS,IWIDTH,IBUGA3,IERROR)
36870C
36871      IH='CUTO'
36872      IH2='FF90'
36873      VALUE0=CUT90
36874      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
36875     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
36876     1IANS,IWIDTH,IBUGA3,IERROR)
36877C
36878      IH='CUTO'
36879      IH2='FF95'
36880      VALUE0=CUT95
36881      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
36882     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
36883     1IANS,IWIDTH,IBUGA3,IERROR)
36884C
36885      IH='CUTO'
36886      IH2='F975'
36887      VALUE0=CUT975
36888      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
36889     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
36890     1IANS,IWIDTH,IBUGA3,IERROR)
36891C
36892      IH='CUTO'
36893      IH2='FF99'
36894      VALUE0=CUT99
36895      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
36896     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
36897     1IANS,IWIDTH,IBUGA3,IERROR)
36898C
36899      IH='CUTO'
36900      IH2='F995'
36901      VALUE0=CUT995
36902      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
36903     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
36904     1IANS,IWIDTH,IBUGA3,IERROR)
36905C
36906      IH='CUTO'
36907      IH2='F999'
36908      VALUE0=CUT999
36909      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
36910     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
36911     1IANS,IWIDTH,IBUGA3,IERROR)
36912C
36913      IH='CUTO'
36914      IH2='FF25'
36915      VALUE0=CUT25
36916      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
36917     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
36918     1IANS,IWIDTH,IBUGA3,IERROR)
36919C
36920      IH='CUTO'
36921      IH2='FF10'
36922      VALUE0=CUT10
36923      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
36924     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
36925     1IANS,IWIDTH,IBUGA3,IERROR)
36926C
36927      IH='CUTO'
36928      IH2='FF05'
36929      VALUE0=CUT05
36930      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
36931     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
36932     1IANS,IWIDTH,IBUGA3,IERROR)
36933C
36934      IH='CUTO'
36935      IH2='F025'
36936      VALUE0=CUT025
36937      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
36938     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
36939     1IANS,IWIDTH,IBUGA3,IERROR)
36940C
36941      IH='CUTO'
36942      IH2='FF01'
36943      VALUE0=CUT01
36944      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
36945     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
36946     1IANS,IWIDTH,IBUGA3,IERROR)
36947C
36948      IH='CUTO'
36949      IH2='F005'
36950      VALUE0=CUT005
36951      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
36952     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
36953     1IANS,IWIDTH,IBUGA3,IERROR)
36954C
36955      IH='CUTO'
36956      IH2='F001'
36957      VALUE0=CUT001
36958      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
36959     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
36960     1IANS,IWIDTH,IBUGA3,IERROR)
36961C
36962C               *****************
36963C               **  STEP 90--  **
36964C               **  EXIT       **
36965C               *****************
36966C
36967 9000 CONTINUE
36968      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CVOT')THEN
36969        WRITE(ICOUT,999)
36970        CALL DPWRST('XXX','BUG ')
36971        WRITE(ICOUT,9011)
36972 9011   FORMAT('***** AT THE END       OF DPCVOT--')
36973        CALL DPWRST('XXX','BUG ')
36974        WRITE(ICOUT,9014)NLOCAL,STATVA,STATCD
36975 9014   FORMAT('NLOCAL,STATVA,STATCD = ',I8,2G15.7)
36976        CALL DPWRST('XXX','BUG ')
36977        WRITE(ICOUT,9016)IFOUND,IERROR
36978 9016   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
36979        CALL DPWRST('XXX','BUG ')
36980      ENDIF
36981C
36982      RETURN
36983      END
36984      SUBROUTINE DPCVO2(Y,TAG,N,ICASA2,IVARID,IVARI2,
36985     1                  TEMP1,TEMP2,G,V,NU,
36986     1                  ICAPSW,ICAPTY,IFORSW,IMULT,
36987     1                  STATVA,STATV2,STATCU,STATCL,PVALU,PVALL,
36988     1                  CUT001,CUT005,CUT01,CUT025,CUT05,CUT10,CUT25,
36989     1                  CUT50,
36990     1                  CUT75,CUT90,CUT95,CUT975,CUT99,CUT995,CUT999,
36991     1                  IBUGA3,ISUBRO,IERROR)
36992C
36993C     PURPOSE--THIS ROUTINE CARRIES OUT COCHRAN'S TEST FOR VARIANCE
36994C              OUTLIERS (I.E., IS LARGEST VARIANCE FROM K TREATEMENTS
36995C              SIGNIFICANCTLY LARGER THAN THE VARIANCES FROM THE OTHER
36996C              GROUPS).
36997C
36998C              THE TEST STATISTIC IS RATIO OF THE LARGEST VARIANCE TO
36999C              THE SUM OF ALL THE VARIANCES.
37000C
37001C              IT IS ASSUMED THAT THE DATA ARE APPROXIMATELY NORMAL AND
37002C              AT LEAST 3 GROUPS ARE REQUIRED.
37003C
37004C              NOTE THAT COCHRAN'S ORIGINAL TEST REQUIRED EQUAL GROUP
37005C              SIZES AND WAS FOR THE MAXIMUM VARIANCE ONLY.  WE HAVE
37006C              INCORPORATED LAM'S UPDATES TO THE TEST WHICH ALLOW
37007C              THE MINIMUM VARIANCE (OR A TWO-SIDED TEST) TO BE
37008C              TESTED AND ALSO ALLOW FOR UNEQUAL GROUP SIZES.
37009C
37010C              NOTE THAT THE LEVENE AND BARTLETT TESTS ARE USED TO
37011C              TEST FOR THE HOMOGENEITY OF VARIANCES.  THE COCHRAN
37012C              TEST HAS A SOMEWHAT SIMILAR PURPOSE.  HOWEVER, IT IS
37013C              SPECIFICALLY AN "OUTLIER" TEST WHEREAS THE LEVENE AND
37014C              BARTLETT TEST FOR OVERALL HOMOGENEITY.  THE COCHRAN TEST
37015C              MAY BE MORE RELEVANT IN THE CONTEXT OF PROFICIENCY TEST
37016C              WHERE WE ARE TRYING TO IDENTIFY SPECIFICE LABORATORIES
37017C              THAT ARE "DIFFERENT" THAN THE OTHERS RATHER THAN JUST
37018C              TESTING FOR GENERAL HOMOGENEITY.
37019C
37020C     EXAMPLE--COCHRAN VARIANCE OUTLIER TEST Y TAG
37021C     REFERENCES--RUBEM U.E. 't LAM (2010), "SCRUTINY OF VARIANCE RESULTS
37022C                 FOR OUTLIERS: COCHRAN'S TEST OPTIMIZED", ANALYTICA
37023C                 CHIMICA ACTA, VOL. 659, NO. 1-2, PP. 68-84.
37024C               --KANJI (2006), "100 STATISTICAL TESTS", SAGE
37025C                 PUBLICATIONS, P. 75.
37026C               --W.G. Cochran, The distribution of the largest of a set
37027C                 of estimated variances as a fraction of their total,
37028C                 Annals of Human Genetics (London) 11(1), 47–52 (January
37029C                 1941).
37030C               --ISO Standard 5725–2:1994, “Accuracy (trueness and
37031C                 precision) of measurement methods and results – Part 2:
37032C                 Basic method for the determination of repeatability and
37033C                 reproducibility of a standard measurement method”,
37034C                 International Organization for Standardization,
37035C                 Geneva, Switzerland, 1994;
37036C                 http://www.iso.org/iso/iso_catalogue/catalogue_tc/
37037C                 catalogue_detail.htm?csnumber=11834
37038C     WRITTEN BY--ALAN HECKERT
37039C                 STATISTICAL ENGINEERING DIVISION
37040C                 INFORMATION TECHNOLOGY LABORATORY
37041C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
37042C                 GAITHERSBURG, MD 20899-8980
37043C                 PHONE--301-975-2899
37044C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
37045C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
37046C     LANGUAGE--ANSI FORTRAN (1977)
37047C     VERSION NUMBER--2015/04
37048C     ORIGINAL VERSION--APRIL     2015.
37049C
37050C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
37051C
37052      CHARACTER*4 ICASA2
37053      CHARACTER*4 IBUGA3
37054      CHARACTER*4 ISUBRO
37055      CHARACTER*4 IERROR
37056      CHARACTER*4 ICAPSW
37057      CHARACTER*4 ICAPTY
37058      CHARACTER*4 IFORSW
37059      CHARACTER*4 IMULT
37060      CHARACTER*4 IVARID(*)
37061      CHARACTER*4 IVARI2(*)
37062C
37063      CHARACTER*4 IWRITE
37064      CHARACTER*4 IOP
37065      CHARACTER*4 ISUBN1
37066      CHARACTER*4 ISUBN2
37067      CHARACTER*4 ISTEPN
37068C
37069C---------------------------------------------------------------------
37070C
37071      DIMENSION Y(*)
37072      DIMENSION TAG(*)
37073      DIMENSION TEMP1(*)
37074      DIMENSION TEMP2(*)
37075      DIMENSION G(*)
37076      DIMENSION V(*)
37077C
37078      INTEGER NU(*)
37079C
37080      PARAMETER (NUMALP=15)
37081      REAL ALPHA(NUMALP)
37082      REAL CV(NUMALP)
37083C
37084      PARAMETER(NUMCLI=5)
37085      PARAMETER(MAXLIN=2)
37086      PARAMETER (MAXROW=25)
37087      CHARACTER*60 ITITLE
37088      CHARACTER*60 ITITLZ
37089      CHARACTER*1  ITITL9
37090      CHARACTER*60 ITEXT(MAXROW)
37091      CHARACTER*4  ALIGN(NUMCLI)
37092      CHARACTER*4  VALIGN(NUMCLI)
37093      REAL         AVALUE(MAXROW)
37094      INTEGER      NCTEXT(MAXROW)
37095      INTEGER      IDIGIT(MAXROW)
37096      INTEGER      NTOT(MAXROW)
37097      CHARACTER*60 ITITL2(MAXLIN,NUMCLI)
37098      CHARACTER*15 IVALUE(MAXROW,NUMCLI)
37099      CHARACTER*4  ITYPCO(NUMCLI)
37100      INTEGER      NCTIT2(MAXLIN,NUMCLI)
37101      INTEGER      NCVALU(MAXROW,NUMCLI)
37102      INTEGER      IWHTML(NUMCLI)
37103      INTEGER      IWRTF(NUMCLI)
37104      REAL         AMAT(MAXROW,NUMCLI)
37105      LOGICAL IFRST
37106      LOGICAL ILAST
37107C
37108C---------------------------------------------------------------------
37109C
37110      INCLUDE 'DPCOP2.INC'
37111C
37112      DATA ALPHA/
37113     1 0.1, 0.5, 1.0, 2.5, 5.0, 10.0, 25.0,
37114     1 50.0,
37115     1 75.0, 90.0, 95.0, 97.5, 99.0, 99.5, 99.9/
37116C
37117C-----START POINT-----------------------------------------------------
37118C
37119      ISUBN1='DPCV'
37120      ISUBN2='O2  '
37121      IERROR='NO'
37122C
37123      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CVO2')THEN
37124        WRITE(ICOUT,999)
37125  999   FORMAT(1X)
37126        CALL DPWRST('XXX','WRIT')
37127        WRITE(ICOUT,51)
37128   51   FORMAT('**** AT THE BEGINNING OF DPCVO2--')
37129        CALL DPWRST('XXX','WRIT')
37130        WRITE(ICOUT,52)IBUGA3,ISUBRO,IMULT,ICASA2,N
37131   52   FORMAT('IBUGA3,ISUBRO,IMULT,ICASA2,N = ',4(A4,2X),I8)
37132        CALL DPWRST('XXX','WRIT')
37133        DO56I=1,N
37134          WRITE(ICOUT,57)I,Y(I),TAG(I)
37135   57     FORMAT('I,Y(I),TAG(I) = ',I8,2G15.7)
37136          CALL DPWRST('XXX','WRIT')
37137   56   CONTINUE
37138      ENDIF
37139C
37140C               ***************************************
37141C               **  STEP 1--                         **
37142C               **  CARRY OUT CALCULATIONS  FOR      **
37143C               **  COCHRAN'S VARIANCE OUTLIER TEST  **
37144C               ***************************************
37145C
37146      ISTEPN='1'
37147      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVO2')
37148     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
37149C
37150      IWRITE='OFF'
37151      CALL DPCVO3(Y,TAG,N,ICASA2,
37152     1            TEMP1,TEMP2,G,V,NU,
37153     1            STATVA,STATV2,STATCU,STATCL,PVALU,PVALL,
37154     1            ALPHA,CV,NUMALP,
37155     1            IDF1,IDF2,ILABMX,ILABMN,NUMDIS,NGROUP,
37156     1            DTOTVA,VARMAX,VARMIN,
37157     1            IBUGA3,ISUBRO,IERROR)
37158C
37159C     WRITE FOLLOWING TO DPST1F.DAT
37160C
37161C       1. GROUP NUMBER
37162C       2. VARIANCE
37163C       3. VALUE OF G-STATISTIC
37164C
37165      IOP='OPEN'
37166      IFLG11=1
37167      IFLG21=1
37168      IFLG31=0
37169      IFLG41=0
37170      IFLG51=0
37171      CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLA41,IFLG51,
37172     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
37173     1            IBUGA3,ISUBRO,IERROR)
37174C
37175      WRITE(IOUNI1,110)
37176  110 FORMAT(3X,'GROUP',7X,'VARIANCE',4X,'G-STATISTIC')
37177      DO120I=1,NUMDIS
37178        WRITE(IOUNI1,125)NU(I)+1,V(I),G(I)
37179  125   FORMAT(I8,2E15.7)
37180  120 CONTINUE
37181C
37182      WRITE(IOUNI2,130)
37183  130 FORMAT(10X,'ALPHA',1X,'CRITICAL VALUE')
37184      DO140I=1,NUMALP
37185        WRITE(IOUNI2,145)ALPHA(I),CV(I)
37186  145   FORMAT(2E15.7)
37187  140 CONTINUE
37188C
37189      IOP='CLOS'
37190      CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLA41,IFLG51,
37191     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
37192     1            IBUGA3,ISUBRO,IERROR)
37193C
37194C               **********************************************
37195C               **   STEP 42--                              **
37196C               **   WRITE OUT EVERYTHING                   **
37197C               **   FOR COCHRAN'S VARIANCE OUTLIER TEST    **
37198C               **********************************************
37199C
37200      ISTEPN='42'
37201      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVO2')
37202     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
37203C
37204      IF(IPRINT.EQ.'OFF')GOTO9000
37205C
37206      NUMDIG=7
37207      IF(IFORSW.EQ.'1')NUMDIG=1
37208      IF(IFORSW.EQ.'2')NUMDIG=2
37209      IF(IFORSW.EQ.'3')NUMDIG=3
37210      IF(IFORSW.EQ.'4')NUMDIG=4
37211      IF(IFORSW.EQ.'5')NUMDIG=5
37212      IF(IFORSW.EQ.'6')NUMDIG=6
37213      IF(IFORSW.EQ.'7')NUMDIG=7
37214      IF(IFORSW.EQ.'8')NUMDIG=8
37215      IF(IFORSW.EQ.'9')NUMDIG=9
37216      IF(IFORSW.EQ.'0')NUMDIG=0
37217      IF(IFORSW.EQ.'E')NUMDIG=-2
37218      IF(IFORSW.EQ.'-2')NUMDIG=-2
37219      IF(IFORSW.EQ.'-3')NUMDIG=-3
37220      IF(IFORSW.EQ.'-4')NUMDIG=-4
37221      IF(IFORSW.EQ.'-5')NUMDIG=-5
37222      IF(IFORSW.EQ.'-6')NUMDIG=-6
37223      IF(IFORSW.EQ.'-7')NUMDIG=-7
37224      IF(IFORSW.EQ.'-8')NUMDIG=-8
37225      IF(IFORSW.EQ.'-9')NUMDIG=-9
37226C
37227      ITITLE='Cochran Variance Outlier Test'
37228      NCTITL=29
37229      ITITLZ=' '
37230      NCTITZ=0
37231C
37232      ICNT=1
37233      ITEXT(ICNT)=' '
37234      NCTEXT(ICNT)=0
37235      AVALUE(ICNT)=0.0
37236      IDIGIT(ICNT)=-1
37237      IF(IMULT.EQ.'OFF')THEN
37238        ICNT=ICNT+1
37239        ITEXT(ICNT)='Response Variable: '
37240        WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1)(1:4)
37241        WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1)(1:4)
37242        NCTEXT(ICNT)=27
37243        AVALUE(ICNT)=0.0
37244        IDIGIT(ICNT)=-1
37245C
37246        ICNT=ICNT+1
37247        ITEXT(ICNT)='Group-ID Variable: '
37248        WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(2)(1:4)
37249        WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(2)(1:4)
37250        NCTEXT(ICNT)=27
37251        AVALUE(ICNT)=0.0
37252        IDIGIT(ICNT)=-1
37253      ENDIF
37254C
37255      ICNT=ICNT+1
37256      ITEXT(ICNT)=' '
37257      NCTEXT(ICNT)=1
37258      AVALUE(ICNT)=0.0
37259      IDIGIT(ICNT)=-1
37260C
37261      IF(ICASA2.EQ.'UPPE')THEN
37262        ICNT=ICNT+1
37263        ITEXT(ICNT)='H0: Largest Variance is Not an Outlier'
37264        NCTEXT(ICNT)=38
37265        AVALUE(ICNT)=0.0
37266        IDIGIT(ICNT)=-1
37267        ICNT=ICNT+1
37268        ITEXT(ICNT)='Ha: Largest Variance is an Outlier'
37269        NCTEXT(ICNT)=34
37270        AVALUE(ICNT)=0.0
37271        IDIGIT(ICNT)=-1
37272      ELSEIF(ICASA2.EQ.'LOWE')THEN
37273        ICNT=ICNT+1
37274        ITEXT(ICNT)='H0: Smallest Variance is Not an Outlier'
37275        NCTEXT(ICNT)=39
37276        AVALUE(ICNT)=0.0
37277        IDIGIT(ICNT)=-1
37278        ICNT=ICNT+1
37279        ITEXT(ICNT)='Ha: Smallest Variance is an Outlier'
37280        NCTEXT(ICNT)=35
37281        AVALUE(ICNT)=0.0
37282        IDIGIT(ICNT)=-1
37283      ELSE
37284        ICNT=ICNT+1
37285        ITEXT(ICNT)='H0: Extreme Variance is Not an Outlier'
37286        NCTEXT(ICNT)=38
37287        AVALUE(ICNT)=0.0
37288        IDIGIT(ICNT)=-1
37289        ICNT=ICNT+1
37290        ITEXT(ICNT)='Ha: Extreme Variance is an Outlier'
37291        NCTEXT(ICNT)=34
37292        AVALUE(ICNT)=0.0
37293        IDIGIT(ICNT)=-1
37294      ENDIF
37295C
37296      ICNT=ICNT+1
37297      ITEXT(ICNT)=' '
37298      NCTEXT(ICNT)=1
37299      AVALUE(ICNT)=0.0
37300      IDIGIT(ICNT)=-1
37301      ICNT=ICNT+1
37302      ITEXT(ICNT)='Summary Statistics:'
37303      NCTEXT(ICNT)=19
37304      AVALUE(ICNT)=0.0
37305      IDIGIT(ICNT)=-1
37306      ICNT=ICNT+1
37307      ITEXT(ICNT)='Total Number of Observations:'
37308      NCTEXT(ICNT)=29
37309      AVALUE(ICNT)=REAL(N)
37310      IDIGIT(ICNT)=0
37311      ICNT=ICNT+1
37312      ITEXT(ICNT)='Number of Groups:'
37313      NCTEXT(ICNT)=17
37314      AVALUE(ICNT)=REAL(NUMDIS)
37315      IDIGIT(ICNT)=0
37316      ICNT=ICNT+1
37317      ITEXT(ICNT)='Number of Groups with Positive Variance:'
37318      NCTEXT(ICNT)=40
37319      AVALUE(ICNT)=REAL(NGROUP)
37320      IDIGIT(ICNT)=0
37321      IF(ICASA2.EQ.'UPPE' .OR. ICASA2.EQ.'TWOS')THEN
37322        ICNT=ICNT+1
37323        ITEXT(ICNT)='Group with Largest Variance:'
37324        NCTEXT(ICNT)=28
37325        AVALUE(ICNT)=REAL(ILABMX)
37326        IDIGIT(ICNT)=0
37327        ICNT=ICNT+1
37328        ITEXT(ICNT)='Largest Variance:'
37329        NCTEXT(ICNT)=17
37330        AVALUE(ICNT)=VARMAX
37331        IDIGIT(ICNT)=NUMDIG
37332      ELSEIF(ICASA2.EQ.'LOWE' .OR. ICASA2.EQ.'TWOS')THEN
37333        ICNT=ICNT+1
37334        ITEXT(ICNT)='Group with Smallest Variance:'
37335        NCTEXT(ICNT)=29
37336        AVALUE(ICNT)=REAL(ILABMN)
37337        IDIGIT(ICNT)=0
37338        ICNT=ICNT+1
37339        ITEXT(ICNT)='Smallest Variance:'
37340        NCTEXT(ICNT)=18
37341        AVALUE(ICNT)=VARMIN
37342        IDIGIT(ICNT)=NUMDIG
37343      ENDIF
37344      ICNT=ICNT+1
37345      ITEXT(ICNT)='Sum of Variance:'
37346      NCTEXT(ICNT)=16
37347      AVALUE(ICNT)=DTOTVA
37348      IDIGIT(ICNT)=NUMDIG
37349      ICNT=ICNT+1
37350      ITEXT(ICNT)=' '
37351      NCTEXT(ICNT)=1
37352      AVALUE(ICNT)=0.0
37353      IDIGIT(ICNT)=-1
37354C
37355      IF(ICASA2.EQ.'TWOS')THEN
37356        ICNT=ICNT+1
37357        ITEXT(ICNT)='Cochran Test Statistic Value (upper):'
37358        NCTEXT(ICNT)=37
37359        AVALUE(ICNT)=STATVA
37360        IDIGIT(ICNT)=NUMDIG
37361        ICNT=ICNT+1
37362        ITEXT(ICNT)='Cochran Test Statistic Value (lower):'
37363        NCTEXT(ICNT)=37
37364        AVALUE(ICNT)=STATV2
37365        IDIGIT(ICNT)=NUMDIG
37366      ELSE
37367        ICNT=ICNT+1
37368        ITEXT(ICNT)='Cochran Test Statistic Value:'
37369        NCTEXT(ICNT)=29
37370        IF(ICASA2.EQ.'UPPE')THEN
37371          AVALUE(ICNT)=STATVA
37372        ELSE
37373          AVALUE(ICNT)=STATV2
37374        ENDIF
37375        IDIGIT(ICNT)=NUMDIG
37376        IF(ICASA2.EQ.'UPPE')THEN
37377          ICNT=ICNT+1
37378          ITEXT(ICNT)='CDF of Test Statistic:'
37379          NCTEXT(ICNT)=22
37380          AVALUE(ICNT)=STATCU
37381          IDIGIT(ICNT)=NUMDIG
37382          ICNT=ICNT+1
37383          ITEXT(ICNT)='P-Value:'
37384          NCTEXT(ICNT)=8
37385          AVALUE(ICNT)=PVALU
37386          IDIGIT(ICNT)=NUMDIG
37387        ELSEIF(ICASA2.EQ.'LOWE')THEN
37388          ICNT=ICNT+1
37389          ITEXT(ICNT)='CDF of Test Statistic:'
37390          NCTEXT(ICNT)=22
37391          AVALUE(ICNT)=STATCL
37392          IDIGIT(ICNT)=NUMDIG
37393          ICNT=ICNT+1
37394          ITEXT(ICNT)='P-Value:'
37395          NCTEXT(ICNT)=8
37396          AVALUE(ICNT)=PVALL
37397          IDIGIT(ICNT)=NUMDIG
37398        ENDIF
37399      ENDIF
37400C
37401      NUMROW=ICNT
37402      DO4210I=1,NUMROW
37403        NTOT(I)=15
37404 4210 CONTINUE
37405C
37406      IFRST=.TRUE.
37407      ILAST=.TRUE.
37408C
37409      ISTEPN='42A'
37410      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVO2')
37411     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
37412C
37413      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
37414     1            AVALUE,IDIGIT,
37415     1            NTOT,NUMROW,
37416     1            ICAPSW,ICAPTY,ILAST,IFRST,
37417     1            ISUBRO,IBUGA3,IERROR)
37418C
37419      ISTEPN='42B'
37420      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVO2')
37421     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
37422C
37423      ITITLE=' '
37424      NCTITL=0
37425C
37426C     DON'T PRINT REFERENCE DISTRIBUTION FOR TWO-TAILED TEST SINCE
37427C     IT IS DIFFERENT FOR MINIMUM AND MAXIMUM TESTS.
37428C
37429      IF(ICASA2.EQ.'TWOS')GOTO4299
37430C
37431      ITITL9=' '
37432      NCTIT9=0
37433      ITITLE(1:44)='Percent Points of the Reference Distribution'
37434      NCTITL=44
37435      NUMLIN=1
37436      NUMROW=NUMALP
37437      NUMCOL=3
37438      ITITL2(1,1)='Percent Point'
37439      ITITL2(1,2)=' '
37440      ITITL2(1,3)='Value'
37441      NCTIT2(1,1)=13
37442      NCTIT2(1,2)=1
37443      NCTIT2(1,3)=5
37444C
37445      NMAX=0
37446      DO4221I=1,NUMCOL
37447        VALIGN(I)='b'
37448        ALIGN(I)='r'
37449        NTOT(I)=15
37450        IF(I.EQ.2)NTOT(I)=5
37451        NMAX=NMAX+NTOT(I)
37452        IDIGIT(I)=NUMDIG
37453        ITYPCO(I)='NUME'
37454 4221 CONTINUE
37455      ITYPCO(2)='ALPH'
37456      IDIGIT(1)=1
37457      DO4223I=1,NUMALP
37458        DO4225J=1,NUMCOL
37459          NCVALU(I,J)=0
37460          IVALUE(I,J)=' '
37461          NCVALU(I,J)=0
37462          AMAT(I,J)=0.0
37463          IF(J.EQ.1)THEN
37464            AMAT(I,J)=ALPHA(I)
37465          ELSEIF(J.EQ.2)THEN
37466            IVALUE(I,J)='='
37467            NCVALU(I,J)=1
37468          ELSEIF(J.EQ.3)THEN
37469            AMAT(I,J)=CV(I)
37470          ENDIF
37471 4225   CONTINUE
37472 4223 CONTINUE
37473C
37474      IWHTML(1)=150
37475      IWHTML(2)=50
37476      IWHTML(3)=150
37477      IWRTF(1)=2000
37478      IWRTF(2)=IWRTF(1)+500
37479      IWRTF(3)=IWRTF(2)+2000
37480      IFRST=.TRUE.
37481      ILAST=.FALSE.
37482C
37483      ISTEPN='42C'
37484      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVO2')
37485     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
37486C
37487      CALL DPDTA4(ITITL9,NCTIT9,
37488     1            ITITLE,NCTITL,ITITL2,NCTIT2,
37489     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
37490     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMALP,
37491     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
37492     1            ICAPSW,ICAPTY,IFRST,ILAST,
37493     1            ISUBRO,IBUGA3,IERROR)
37494C
37495 4299 CONTINUE
37496C
37497      ISTEPN='42D'
37498      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVO2')
37499     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
37500C
37501      CUT0=0.0
37502      CUT001=CV(1)
37503      CUT005=CV(2)
37504      CUT01=CV(3)
37505      CUT025=CV(4)
37506      CUT05=CV(5)
37507      CUT10=CV(6)
37508      CUT25=CV(7)
37509      CUT50=CV(8)
37510      CUT75=CV(9)
37511      CUT90=CV(10)
37512      CUT95=CV(11)
37513      CUT975=CV(12)
37514      CUT99=CV(13)
37515      CUT995=CV(14)
37516      CUT999=CV(15)
37517      IF(ICASA2.EQ.'UPPE')THEN
37518        CDF1=CUT90
37519        CDF2=CUT95
37520        CDF3=CUT975
37521        CDF4=CUT99
37522      ELSEIF(ICASA2.EQ.'LOWE')THEN
37523        CDF1=CUT10
37524        CDF2=CUT05
37525        CDF3=CUT025
37526        CDF4=CUT01
37527      ELSE
37528        CDF1=CUT95
37529        CDF2=CUT975
37530        CDF3=CUT995
37531        CDF4=CUT05
37532        CDF5=CUT025
37533        CDF6=CUT005
37534      ENDIF
37535C
37536      ITITL9=' '
37537      NCTIT9=0
37538      IF(ICASA2.EQ.'UPPE')THEN
37539        ITITLE='Conclusions (Upper 1-Tailed Test)'
37540        NCTITL=33
37541      ELSEIF(ICASA2.EQ.'LOWE')THEN
37542        ITITLE='Conclusions (Lower 1-Tailed Test)'
37543        NCTITL=33
37544      ELSEIF(ICASA2.EQ.'TWOS')THEN
37545        ITITLE='Conclusions (Two-Tailed Test)'
37546        NCTITL=29
37547      ENDIF
37548      IF(ICASA2.EQ.'TWOS')THEN
37549        NUMLIN=2
37550        NUMROW=3
37551        NUMCOL=5
37552        ITITL2(1,1)=' '
37553        ITITL2(2,1)='Alpha'
37554        NCTIT2(1,1)=0
37555        NCTIT2(2,1)=5
37556        ITITL2(1,2)='Significance'
37557        ITITL2(2,2)='Level'
37558        NCTIT2(1,2)=12
37559        NCTIT2(2,2)=5
37560        ITITL2(1,3)='Lower'
37561        ITITL2(2,3)='Critical Value'
37562        NCTIT2(1,3)=5
37563        NCTIT2(2,3)=14
37564        ITITL2(1,4)='Upper'
37565        ITITL2(2,4)='Critical Value'
37566        NCTIT2(1,4)=5
37567        NCTIT2(2,4)=14
37568        ITITL2(1,5)=' '
37569        ITITL2(2,5)='Conclusion'
37570        NCTIT2(1,5)=0
37571        NCTIT2(2,5)=10
37572      ELSE
37573        NUMLIN=1
37574        NUMROW=4
37575        NUMCOL=4
37576        ITITL2(1,1)='Alpha'
37577        NCTIT2(1,1)=5
37578        ITITL2(1,2)='CDF'
37579        NCTIT2(1,2)=3
37580        ITITL2(1,3)='Critical Value'
37581        NCTIT2(1,3)=14
37582        ITITL2(1,4)='Conclusion'
37583        NCTIT2(1,4)=10
37584      ENDIF
37585C
37586      NMAX=0
37587      DO4321I=1,NUMCOL
37588        VALIGN(I)='b'
37589        ALIGN(I)='r'
37590        NTOT(I)=15
37591        IF(I.EQ.1)NTOT(I)=7
37592        IF(ICASA2.NE.'TWOS' .AND. I.EQ.2)NTOT(I)=7
37593        IF(I.EQ.3)NTOT(I)=17
37594        IF(ICASA2.EQ.'TWOS' .AND. I.EQ.4)NTOT(I)=17
37595        NMAX=NMAX+NTOT(I)
37596        IDIGIT(I)=NUMDIG
37597        ITYPCO(I)='ALPH'
37598 4321 CONTINUE
37599      ITYPCO(3)='NUME'
37600      IF(ICASA2.EQ.'TWOS')ITYPCO(4)='NUME'
37601      IDIGIT(1)=0
37602      IDIGIT(2)=0
37603      DO4323I=1,NUMROW
37604        DO4325J=1,NUMCOL
37605          NCVALU(I,J)=0
37606          IVALUE(I,J)=' '
37607          NCVALU(I,J)=0
37608          AMAT(I,J)=0.0
37609 4325   CONTINUE
37610 4323 CONTINUE
37611      IF(ICASA2.EQ.'UPPE')THEN
37612        IVALUE(1,1)='10%'
37613        IVALUE(2,1)='5%'
37614        IVALUE(3,1)='2.5%'
37615        IVALUE(4,1)='1%'
37616        IVALUE(1,2)='90%'
37617        IVALUE(2,2)='95%'
37618        IVALUE(3,2)='97.5%'
37619        IVALUE(4,2)='99%'
37620        NCVALU(1,1)=3
37621        NCVALU(2,1)=2
37622        NCVALU(3,1)=4
37623        NCVALU(4,1)=2
37624        NCVALU(1,2)=3
37625        NCVALU(2,2)=3
37626        NCVALU(3,2)=5
37627        NCVALU(4,2)=3
37628        IVALUE(1,4)='Accept H0'
37629        IVALUE(2,4)='Accept H0'
37630        IVALUE(3,4)='Accept H0'
37631        IVALUE(4,4)='Accept H0'
37632        NCVALU(1,4)=9
37633        NCVALU(2,4)=9
37634        NCVALU(3,4)=9
37635        NCVALU(4,4)=9
37636        IF(STATVA.GT.CUT90)IVALUE(1,4)='Reject H0'
37637        IF(STATVA.GT.CUT95)IVALUE(2,4)='Reject H0'
37638        IF(STATVA.GT.CUT975)IVALUE(3,4)='Reject H0'
37639        IF(STATVA.GT.CUT99)IVALUE(4,4)='Reject H0'
37640        AMAT(1,3)=RND(CUT90,IDIGIT(3))
37641        AMAT(2,3)=RND(CUT95,IDIGIT(3))
37642        AMAT(3,3)=RND(CUT975,IDIGIT(3))
37643        AMAT(4,3)=RND(CUT99,IDIGIT(3))
37644      ELSEIF(ICASA2.EQ.'LOWE')THEN
37645        IVALUE(4,1)='10%'
37646        IVALUE(3,1)='5%'
37647        IVALUE(2,1)='2.5%'
37648        IVALUE(1,1)='1%'
37649        IVALUE(4,2)='10%'
37650        IVALUE(3,2)='5%'
37651        IVALUE(2,2)='2.5%'
37652        IVALUE(1,2)='1%'
37653        NCVALU(4,1)=3
37654        NCVALU(3,1)=2
37655        NCVALU(2,1)=4
37656        NCVALU(1,1)=2
37657        NCVALU(4,2)=3
37658        NCVALU(3,2)=2
37659        NCVALU(2,2)=4
37660        NCVALU(1,2)=2
37661        IVALUE(4,4)='Accept H0'
37662        IVALUE(3,4)='Accept H0'
37663        IVALUE(2,4)='Accept H0'
37664        IVALUE(1,4)='Accept H0'
37665        NCVALU(4,4)=9
37666        NCVALU(3,4)=9
37667        NCVALU(2,4)=9
37668        NCVALU(1,4)=9
37669        IF(STATVA.LT.CUT10)IVALUE(4,4)='Reject H0'
37670        IF(STATVA.LT.CUT05)IVALUE(3,4)='Reject H0'
37671        IF(STATVA.LT.CUT025)IVALUE(2,4)='Reject H0'
37672        IF(STATVA.LT.CUT01)IVALUE(1,4)='Reject H0'
37673        AMAT(4,3)=RND(CUT10,IDIGIT(3))
37674        AMAT(3,3)=RND(CUT05,IDIGIT(3))
37675        AMAT(2,3)=RND(CUT025,IDIGIT(3))
37676        AMAT(1,3)=RND(CUT01,IDIGIT(3))
37677      ELSE
37678        IVALUE(1,1)='10%'
37679        IVALUE(2,1)='5%'
37680        IVALUE(3,1)='1%'
37681        IVALUE(1,2)='90%'
37682        IVALUE(2,2)='95%'
37683        IVALUE(3,2)='99%'
37684        NCVALU(1,1)=3
37685        NCVALU(2,1)=2
37686        NCVALU(3,1)=2
37687        NCVALU(1,2)=3
37688        NCVALU(2,2)=3
37689        NCVALU(3,2)=3
37690        IVALUE(1,5)='Accept H0'
37691        IVALUE(2,5)='Accept H0'
37692        IVALUE(3,5)='Accept H0'
37693        NCVALU(1,5)=9
37694        NCVALU(2,5)=9
37695        NCVALU(3,5)=9
37696        IF(STATVA.GT.CUT95.OR.STATV2.LT.CUT05)IVALUE(1,5)='Reject H0'
37697        IF(STATVA.GT.CUT975.OR.STATV2.LT.CUT025)IVALUE(2,5)='Reject H0'
37698        IF(STATVA.GT.CUT995.OR.STATV2.LT.CUT005)IVALUE(3,5)='Reject H0'
37699        AMAT(1,3)=RND(CUT05,IDIGIT(3))
37700        AMAT(2,3)=RND(CUT025,IDIGIT(3))
37701        AMAT(3,3)=RND(CUT005,IDIGIT(3))
37702        AMAT(1,4)=RND(CUT95,IDIGIT(3))
37703        AMAT(2,4)=RND(CUT975,IDIGIT(3))
37704        AMAT(3,4)=RND(CUT995,IDIGIT(3))
37705      ENDIF
37706C
37707      IWHTML(1)=150
37708      IWHTML(2)=150
37709      IWHTML(3)=150
37710      IWHTML(4)=150
37711      IWRTF(1)=1500
37712      IWRTF(2)=IWRTF(1)+1500
37713      IWRTF(3)=IWRTF(2)+2000
37714      IWRTF(4)=IWRTF(3)+2000
37715      IFRST=.FALSE.
37716      ILAST=.TRUE.
37717C
37718      ISTEPN='42E'
37719      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVO2')
37720     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
37721C
37722      CALL DPDTA4(ITITL9,NCTIT9,
37723     1            ITITLE,NCTITL,ITITL2,NCTIT2,
37724     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
37725     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW,
37726     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
37727     1            ICAPSW,ICAPTY,IFRST,ILAST,
37728     1            ISUBRO,IBUGA3,IERROR)
37729C
37730C               *****************
37731C               **  STEP 90--  **
37732C               **  EXIT       **
37733C               *****************
37734C
37735 9000 CONTINUE
37736      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CVO2')THEN
37737        WRITE(ICOUT,999)
37738        CALL DPWRST('XXX','WRIT')
37739        WRITE(ICOUT,9011)
37740 9011   FORMAT('***** AT THE END       OF DPCVO2--')
37741        CALL DPWRST('XXX','WRIT')
37742        WRITE(ICOUT,9012)N,IBUGA3,IERROR
37743 9012   FORMAT('N,IBUGA3,IERROR = ',I8,2X,A4,2X,A4)
37744        CALL DPWRST('XXX','WRIT')
37745        WRITE(ICOUT,9014)STATVA,STATCD,PVAL
37746 9014   FORMAT('STATVA,STATCD,PVAL = ',3G15.7)
37747        CALL DPWRST('XXX','WRIT')
37748      ENDIF
37749C
37750      RETURN
37751      END
37752      SUBROUTINE DPCVO3(Y,TAG,N,ICASAN,
37753     1                  DTAG,YTEMP,G,V,NU,
37754     1                  STATVA,STATV2,STATCU,STATCL,PVALU,PVALL,
37755     1                  ALPHAV,CV,NALPHA,
37756     1                  IDF1,IDF2,ILABMX,ILABMN,NUMDIS,NGROUP,
37757     1                  DVARTO,VARMAX,VARMIN,
37758     1                  IBUGA3,ISUBRO,IERROR)
37759C
37760C     PURPOSE--THIS ROUTINE CARRIES OUT COCHRAN'S TEST FOR VARIANCE
37761C              OUTLIERS (I.E., IS LARGEST VARIANCE FROM K TREATEMENTS
37762C              SIGNIFICANCTLY LARGER THAN THE VARIANCES FROM THE OTHER
37763C              GROUPS).
37764C
37765C              THE TEST STATISTIC IS RATIO OF THE LARGEST VARIANCE TO
37766C              THE SUM OF ALL THE VARIANCES.
37767C
37768C              IT IS ASSUMED THAT THE DATA ARE APPROXIMATELY NORMAL,
37769C              AT LEAST 3 GROUPS ARE REQUIRED, AND ALL SAMPLE SIZES
37770C              ARE EQUAL.
37771C
37772C              THE TEST STATISITC IS:
37773C
37774C                 C = MAX(S(i)**2)/SUM[i=1 to k][S(i)]
37775C
37776C              WHERE THE S(i) ARE THE VARIANCES FROM THE K GROUPS.
37777C
37778C              THIS IS AN UPPER ONE-SIDED TEST AND THE CRITICAL VALUE
37779C              CAN BE COMPUTED AS
37780C
37781C                 CUL(ALPHA,NI,K) = 1/[1 +
37782C                 (K-1)/Fc(ALPHA/K,(NI-1),(K-1)*(NI-1))}
37783C
37784C              NOTE THAT 't LAM HAS EXTENDED THIS TEST TO HANDLE UNEQUAL
37785C              SAMPLE SIZES AND TO TEST FOR THE SMALLEST AS WELL AS THE
37786C              LARGEST VARIANCE (AND TO PERFORM TWO-SIDED TESTS AS
37787C              WELL).  SEE  DPGVT3 FOR THIS VERSION OF THE TEST.
37788C
37789C     EXAMPLE--COCHRAN VARIANCE OUTLIER TEST Y TAG
37790C     REFERENCES--RUBEM U.E. 't LAM (2010), "SCRUTINY OF VARIANCE RESULTS
37791C                 FOR OUTLIERS: COCHRAN'S TEST OPTIMIZED", ANALYTICA
37792C                 CHIMICA ACTA, VOL. 659, NO. 1-2, PP. 68-84.
37793C               --KANJI (2006), "100 STATISTICAL TESTS", SAGE
37794C                 PUBLICATIONS, P. 75.
37795C               --W.G. Cochran, The distribution of the largest of a set
37796C                 of estimated variances as a fraction of their total,
37797C                 Annals of Human Genetics (London) 11(1), 47–52 (January
37798C                 1941).
37799C               --ISO Standard 5725–2:1994, “Accuracy (trueness and
37800C                 precision) of measurement methods and results – Part 2:
37801C                 Basic method for the determination of repeatability and
37802C                 reproducibility of a standard measurement method”,
37803C                 International Organization for Standardization,
37804C                 Geneva, Switzerland, 1994;
37805C                 http://www.iso.org/iso/iso_catalogue/catalogue_tc/
37806C                 catalogue_detail.htm?csnumber=11834
37807C     WRITTEN BY--ALAN HECKERT
37808C                 STATISTICAL ENGINEERING DIVISION
37809C                 INFORMATION TECHNOLOGY LABORATORY
37810C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
37811C                 GAITHERSBURG, MD 20899-8980
37812C                 PHONE--301-975-2899
37813C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
37814C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
37815C     LANGUAGE--ANSI FORTRAN (1977)
37816C     VERSION NUMBER--2015/3
37817C     ORIGINAL VERSION--MARCH     2015.
37818C
37819C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
37820C
37821      CHARACTER*4 ICASAN
37822      CHARACTER*4 ISUBRO
37823      CHARACTER*4 IBUGA3
37824      CHARACTER*4 IERROR
37825C
37826      CHARACTER*4 IWRITE
37827      CHARACTER*4 ISUBN0
37828      CHARACTER*4 ISUBN1
37829      CHARACTER*4 ISUBN2
37830      CHARACTER*4 ISTEPN
37831C
37832C---------------------------------------------------------------------
37833C
37834      DIMENSION Y(*)
37835      DIMENSION TAG(*)
37836      DIMENSION DTAG(*)
37837      DIMENSION YTEMP(*)
37838      DIMENSION V(*)
37839      DIMENSION G(*)
37840      DIMENSION ALPHAV(*)
37841      DIMENSION CV(*)
37842      INTEGER NU(*)
37843C
37844C---------------------------------------------------------------------
37845C
37846      INCLUDE 'DPCOP2.INC'
37847C
37848C-----START POINT-----------------------------------------------------
37849C
37850      ISUBN1='DPCV'
37851      ISUBN2='O3  '
37852      ISUBN0='    '
37853      IERROR='NO'
37854      IWRITE='OFF'
37855C
37856      STATVA=CPUMIN
37857      STATV2=CPUMIN
37858      STATCU=CPUMIN
37859      STATCL=CPUMIN
37860      PVALU=CPUMIN
37861      PVALL=CPUMIN
37862      XL=CPUMIN
37863      XLF=CPUMIN
37864      XR=CPUMIN
37865C
37866      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CVO3')THEN
37867        WRITE(ICOUT,999)
37868  999   FORMAT(1X)
37869        CALL DPWRST('XXX','WRIT')
37870        WRITE(ICOUT,51)
37871   51   FORMAT('**** AT THE BEGINNING OF DPCOV3--')
37872        CALL DPWRST('XXX','WRIT')
37873        WRITE(ICOUT,52)IBUGA3,ISUBRO,N,NALPHA,IDF1,IDF2
37874   52   FORMAT('IBUGA3,ISUBRO,N,NALPHA,IDF1,IDF2 = ',2(A4,2X),4I8)
37875        CALL DPWRST('XXX','WRIT')
37876        DO56I=1,N
37877          WRITE(ICOUT,57)I,Y(I),TAG(I)
37878   57     FORMAT('I,Y(I),TAG(I) = ',I8,2G15.7)
37879          CALL DPWRST('XXX','WRIT')
37880   56   CONTINUE
37881      ENDIF
37882C
37883C               ********************************************
37884C               **  STEP 11--                             **
37885C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
37886C               ********************************************
37887C
37888      ISTEPN='11'
37889      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVO3')
37890     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
37891C
37892      IF(N.LT.5)THEN
37893        WRITE(ICOUT,999)
37894        CALL DPWRST('XXX','WRIT')
37895        WRITE(ICOUT,1111)
37896 1111   FORMAT('***** ERROR IN COCHRANS VARIANCE OUTLIER TEST--')
37897        CALL DPWRST('XXX','WRIT')
37898        WRITE(ICOUT,1113)
37899 1113   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ',
37900     1         'VARIABLE IS LESS THAN 5.')
37901        WRITE(ICOUT,1115)N
37902 1115   FORMAT('      THE SAMPLE SIZE = ',I8)
37903        CALL DPWRST('XXX','WRIT')
37904        IERROR='YES'
37905        GOTO9000
37906      ENDIF
37907C
37908      HOLD=Y(1)
37909      DO1135I=2,N
37910        IF(Y(I).NE.HOLD)GOTO1139
37911 1135 CONTINUE
37912      WRITE(ICOUT,999)
37913      CALL DPWRST('XXX','WRIT')
37914      WRITE(ICOUT,1111)
37915      CALL DPWRST('XXX','WRIT')
37916      WRITE(ICOUT,1133)HOLD
37917 1133 FORMAT('      THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7)
37918      CALL DPWRST('XXX','WRIT')
37919      GOTO9000
37920 1139 CONTINUE
37921C
37922      HOLD=TAG(1)
37923      DO1235I=2,N
37924        IF(TAG(I).NE.HOLD)GOTO1239
37925 1235 CONTINUE
37926      WRITE(ICOUT,999)
37927      CALL DPWRST('XXX','WRIT')
37928      WRITE(ICOUT,1111)
37929      CALL DPWRST('XXX','WRIT')
37930      WRITE(ICOUT,1231)HOLD
37931 1231 FORMAT('      THE GROUP-ID VARIABLE HAS ALL ELEMENTS = ',G15.7)
37932      CALL DPWRST('XXX','WRIT')
37933      GOTO9000
37934 1239 CONTINUE
37935C
37936C               ********************************************
37937C               **  STEP 41--                            **
37938C               **  CARRY OUT CALCULATIONS               **
37939C               **  FOR COCHRAN'S VARIANCE OUTLIER TEST  **
37940C               *******************************************
37941C
37942      ISTEPN='21'
37943      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVO3')
37944     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
37945C
37946C     COMPUTE THE VARIANCE FOR EACH GROUP
37947C
37948      CALL DISTIN(TAG,N,IWRITE,DTAG,NUMDIS,IBUGA3,IERROR)
37949C
37950      DVARTO=0.0
37951      VARMAX=CPUMIN
37952      VARMIN=CPUMAX
37953      NNOVAR=0
37954      ILABMX=0
37955      NUPOOL=0
37956      DO2105II=1,NUMDIS
37957        NU(II)=0
37958        V(II)=0.0
37959        G(II)=0.0
37960 2105 CONTINUE
37961C
37962      DO2110II=1,NUMDIS
37963        NTEMP=0
37964        HOLD=DTAG(II)
37965        DO2120J=1,N
37966          IF(TAG(J).EQ.HOLD)THEN
37967            NTEMP=NTEMP+1
37968            YTEMP(NTEMP)=Y(J)
37969          ENDIF
37970 2120   CONTINUE
37971        NU(II)=NTEMP-1
37972        NUPOOL=NUPOOL + NU(II)
37973        IF(NU(II).GE.1)THEN
37974          CALL VAR(YTEMP,NTEMP,IWRITE,AVAR,IBUGA3,IERROR)
37975          V(II)=AVAR
37976          DVARTO=DVARTO + REAL(NU(II))*V(II)
37977          IF(AVAR.LE.0)THEN
37978            NNOVAR=NNOVAR + 1
37979          ENDIF
37980        ELSE
37981          NNOVAR=NNOVAR + 1
37982        ENDIF
37983C
37984 2110 CONTINUE
37985C
37986      ISTEPN='22'
37987      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVO3')
37988     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
37989C
37990      IF(NUPOOL.GT.0)THEN
37991        GMAX=CPUMIN
37992        GMIN=CPUMAX
37993        DO2115II=1,NUMDIS
37994          ANUM=REAL(NU(II))*V(II)
37995          G(II)=ANUM/DVARTO
37996          IF(G(II).GT.GMAX)THEN
37997            GMAX=G(II)
37998            G(II)=GMAX
37999            ILABMX=II
38000            VARMAX=V(II)
38001          ENDIF
38002          IF(G(II).LT.GMIN .AND. G(II).GT.0.0)THEN
38003            GMIN=G(II)
38004            ILABMN=II
38005            VARMIN=V(II)
38006          ENDIF
38007 2115   CONTINUE
38008      ENDIF
38009C
38010C     CHECK: AT LEAST 3 POSITIVE VARIANCES
38011C
38012      ISTEPN='23'
38013      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVO3')
38014     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
38015C
38016      NGROUP=NUMDIS - NNOVAR
38017      IF(NGROUP.LT.3)THEN
38018        WRITE(ICOUT,999)
38019        CALL DPWRST('XXX','WRIT')
38020        WRITE(ICOUT,1111)
38021        CALL DPWRST('XXX','WRIT')
38022        WRITE(ICOUT,2131)
38023 2131   FORMAT('      AT LEAST 3 GROUPS WITH NON-ZERO VARIANCE ',
38024     1         'REQUIRED.')
38025        CALL DPWRST('XXX','WRIT')
38026        WRITE(ICOUT,2133)NGROUP
38027 2133   FORMAT('      THE NUMBER OF GROUPS WITH NON-ZERO VARIANCE = ',
38028     1         I8)
38029        CALL DPWRST('XXX','WRIT')
38030        IERROR='YES'
38031        GOTO9000
38032      ENDIF
38033C
38034C     FOR CRITICAL VALUES:
38035C
38036C        1. ICASAN = UPPE  => AN UPPER TAILED TEST (LARGEST VARIANCE)
38037C        2. ICASAN = LOWE  => A  LOWER TAILED TEST (SMALLEST VARIANCE)
38038C        3. ICASAN = TWOS  => A  TWO   TAILED TEST (LARGEST/SMALLEST VARIANCE)
38039C
38040C
38041C       FOR TWO-SIDED TEST, TEST BOTH THE MAXIMUM AND THE MINIMUM
38042C       VARIANCE.
38043C
38044CCCCC IF(ICASAN.EQ.'TWOS')THEN
38045C
38046CCCCC   VPOOL=REAL(NUPOOL)
38047C
38048C       MAXIMUM VARIANCE FIRST
38049C
38050CCCCC   ANUM=(VPOOL/REAL(NU(ILABMX))) - 1.0
38051CCCCC   DENOM=(1.0/G(ILABMX)) - 1.0
38052CCCCC   FJMX=ANUM/DENOM
38053CCCCC   IDF1MX=NU(ILABMX)
38054CCCCC   IDF2MX=NUPOOL-IDF1
38055CCCCC   CALL FCDF(FJMX,IDF1MX,IDF2MX,PHIMX)
38056CCCCC   PHIMX=MIN(PHIMX,1.0-PHIMX)
38057C
38058C       NOW MINIMUM VARIANCE
38059C
38060CCCCC   ANUM=(VPOOL/REAL(NU(ILABMN))) - 1.0
38061CCCCC   DENOM=(1.0/G(ILABMN)) - 1.0
38062CCCCC   FJMN=ANUM/DENOM
38063CCCCC   IDF1MN=NU(ILABMN)
38064CCCCC   IDF2MN=NUPOOL-IDF1
38065CCCCC   CALL FCDF(FJMN,IDF1MN,IDF2MN,PHIMN)
38066CCCCC   PHIMN=MIN(PHIMN,1.0-PHIMN)
38067C
38068CCCCC   IF(PHIMX.LE.PHIMN)THEN
38069CCCCC     STATVA=G(ILABMX)
38070CCCCC     IDF1=IDF1MX
38071CCCCC     IDF2=IDFMN
38072CCCCC   ELSE
38073CCCCC     STATVA=G(ILABMN)
38074CCCCC     IDF1=IDF1MN
38075CCCCC     IDF2=IDF2MN
38076CCCCC   ENDIF
38077C
38078CCCCC   DO3010I=1,NALPHA
38079CCCCC     CV(I)=CPUMIN
38080CCCCC     ALPHA=ALPHAV(I)
38081CCCCC     IF(ALPHA.GE.1.0 .AND. ALPHA.LT.100.0)ALPHA=ALPHA/100.
38082CCCCC     IF(ALPHA.GT.0.5 .AND. ALPHA.LT.1.0)THEN
38083CCCCC       ALPHA=1.0 - ALPHA
38084CCCCC     ELSEIF(ALPHA.LE.0.0 .OR. ALPHA.GE.1.0)THEN
38085CCCCC       GOTO3010
38086CCCCC     ENDIF
38087CCCCC     TERM9=2.0*REAL(NGROUP)
38088CCCCC     ALPHA1=1.0-(ALPHA/TERM9)
38089CCCCC     CALL FPPF(ALPHA1,IDF1,IDF2,FC)
38090CCCCC     TERM1=1.0 + (REAL(NGROUP-1)/FC)
38091CCCCC     CV(I)=1.0/TERM1
38092C3010   CONTINUE
38093C
38094CCCCC ELSE
38095C
38096        ISTEPN='24'
38097        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVO3')
38098     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
38099C
38100        IDF1MX=NU(ILABMX)
38101        STATVA=G(ILABMX)
38102        IDF1MN=NU(ILABMN)
38103        STATV2=G(ILABMN)
38104        IDF2MX=NUPOOL - IDF1MX
38105        IDF2MN=NUPOOL - IDF1MN
38106        AFACT=1.0
38107        DO3019I=1,NALPHA
38108          IF(ALPHAV(I).GE.1.0 .AND. ALPHAV(I).LT.100.0)AFACT=100.
38109 3019   CONTINUE
38110C
38111        DO3020I=1,NALPHA
38112          CV(I)=CPUMIN
38113          ALPHA=ALPHAV(I)/AFACT
38114          IF(ICASAN.EQ.'UPPE' .OR.
38115     1       (ICASAN.EQ.'TWOS' .AND. ALPHA.GE.0.5))THEN
38116            ALPHAT=(1.0 - ALPHA)
38117            ALPHA1=1.0-(ALPHAT/REAL(NUMDIS))
38118            TERM1=(REAL(NUPOOL)/REAL(NU(ILABMX))) - 1.0
38119            CALL FPPF(ALPHA1,IDF1MX,IDF2MX,FC)
38120            TERM2=1.0 + (TERM1/FC)
38121            CV(I)=1.0/TERM2
38122          ELSEIF(ICASAN.EQ.'LOWE' .OR.
38123     1          (ICASAN.EQ.'TWOS' .AND. ALPHA.LT.0.5))THEN
38124            ALPHAT=ALPHA
38125            ALPHA1=ALPHAT/REAL(NUMDIS)
38126            TERM1=(REAL(NUPOOL)/REAL(NU(ILABMN))) - 1.0
38127            CALL FPPF(ALPHA1,IDF1MN,IDF2MN,FC)
38128            TERM2=1.0 + (TERM1/FC)
38129            CV(I)=1.0/TERM2
38130          ENDIF
38131 3020   CONTINUE
38132CCCCC ENDIF
38133C
38134C     COMPUTE THE CDF/P-VALUE FOR THE ONE-TAILED TESTS.  USE
38135C     THE CV ARRAY TO FIND THE BRACKETING INTERVAL.
38136C
38137      ISTEPN='25'
38138      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVO3')
38139     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
38140C
38141      SIG=1.0E-5
38142      EPS=1.0E-5
38143      MAXIT=100
38144C
38145      IF(ICASAN.EQ.'UPPE')THEN
38146        IF(STATVA.EQ.0.0)THEN
38147          STATCU=0.0
38148          PVALU=1.0
38149          GOTO9000
38150        ELSEIF(STATVA.LT.CV(1))THEN
38151          XR=ALPHAV(1)/AFACT
38152          XRF=CV(1)
38153          XL=XR/100.
38154          ALPHAT=(1.0 - XL)
38155          ALPHA1=1.0-(ALPHAT/REAL(NUMDIS))
38156          TERM1=(REAL(NUPOOL)/REAL(NU(ILABMX))) - 1.0
38157          CALL FPPF(ALPHA1,IDF1MX,IDF2MX,FC)
38158          TERM2=1.0 + (TERM1/FC)
38159          XLF=1.0/TERM2
38160          IF(STATVA.LT.XLF)THEN
38161            STATCU=XL
38162            PVALU=1.0 - STATCU
38163            GOTO9000
38164          ENDIF
38165        ELSEIF(STATVA.GT.CV(NALPHA))THEN
38166          XL=ALPHAV(NALPHA)/AFACT
38167          XLF=CV(NALPHA)
38168          IF(XL.LE.0.999)THEN
38169            XR=0.99999
38170          ELSE
38171            XR=MAX(0.99999,XL)
38172          ENDIF
38173          ALPHAT=(1.0 - XR)
38174          ALPHA1=1.0-(ALPHAT/REAL(NUMDIS))
38175          TERM1=(REAL(NUPOOL)/REAL(NU(ILABMX))) - 1.0
38176          CALL FPPF(ALPHA1,IDF1MX,IDF2MX,FC)
38177          TERM2=1.0 + (TERM1/FC)
38178          XRF=1.0/TERM2
38179          IF(STATVA.GT.XRF)THEN
38180            STATCU=XR
38181            PVALU=1.0 - STATCU
38182            GOTO9000
38183          ENDIF
38184        ELSE
38185          DO4010I=2,NALPHA
38186            IF(STATVA.GE.CV(I-1) .AND. STATVA.LE.CV(I))THEN
38187              XL=ALPHAV(I-1)/AFACT
38188              XLF=CV(I-1)
38189              XR=ALPHAV(I)/AFACT
38190              XRF=CV(I)
38191              GOTO4019
38192            ENDIF
38193 4010     CONTINUE
38194 4019     CONTINUE
38195        ENDIF
38196C
38197C       NOW THAT WE HAVE BRACKETING INTERVAL, USE BISECTION
38198C       TO DETERMINE CDF VALUE.
38199C
38200        IF(STATVA.EQ.XL)THEN
38201          STATCU=XL
38202          PVALU=1.0 - STATCU
38203          GOTO9000
38204        ELSEIF(STATVA.EQ.XR)THEN
38205          STATCU=XR
38206          PVALU=1.0 - STATCU
38207          GOTO9000
38208        ENDIF
38209C
38210        FXL=XLF-STATVA
38211        FXR=XRF-STATVA
38212        IC=0
38213 4025   CONTINUE
38214        XMID=(XL+XR)/2.0
38215        ALPHAT=(1.0 - XMID)
38216        ALPHA1=1.0-(ALPHAT/REAL(NUMDIS))
38217        TERM1=(REAL(NUPOOL)/REAL(NU(ILABMX))) - 1.0
38218        CALL FPPF(ALPHA1,IDF1MX,IDF2MX,FC)
38219        TERM2=1.0 + (TERM1/FC)
38220        XMIDF=1.0/TERM2
38221        FCS=XMIDF-STATVA
38222        IF(FCS*FXL.GT.0.0)THEN
38223          XL=XMID
38224          XLF=XMIDF
38225          FXL=FCS
38226        ELSE
38227          XR=XMID
38228          XRF=XMIDF
38229          FXR=FCS
38230        ENDIF
38231        XRML=XR-XL
38232        IF(XRML.LE.SIG .AND. ABS(FCS).LE.EPS)THEN
38233          STATCU=XMID
38234          PVALU=1.0 - STATCU
38235          GOTO9000
38236        ENDIF
38237        IC=IC+1
38238        IF(IC.LE.MAXIT)GOTO4025
38239        WRITE(ICOUT,999)
38240        CALL DPWRST('XXX','WRIT')
38241        WRITE(ICOUT,4031)
38242 4031   FORMAT('***** WARNING FROM COCHRAN VARIANCE OUTLIER TEST')
38243        CALL DPWRST('XXX','WRIT')
38244        WRITE(ICOUT,4033)
38245 4033   FORMAT('      THE P-VALUE COMPUTATION DID NOT CONVERGE.')
38246        CALL DPWRST('XXX','WRIT')
38247        STATCU=XMID
38248        PVALU=1.0 - STATCU
38249        GOTO9000
38250C
38251      ELSEIF(ICASAN.EQ.'LOWE')THEN
38252        IF(STATV2.LT.CV(1))THEN
38253          XR=ALPHAV(1)/AFACT
38254          XRF=CV(1)
38255          XL=XR/100.
38256          ALPHAT=XL
38257          ALPHA1=1.0-(ALPHAT/REAL(NUMDIS))
38258          TERM1=(REAL(NUPOOL)/REAL(NU(ILABMN))) - 1.0
38259          CALL FPPF(ALPHA1,IDF1MN,IDF2MN,FC)
38260          TERM2=1.0 + (TERM1/FC)
38261          XLF=1.0/TERM2
38262          IF(STATVA.LT.XLF)THEN
38263            STATCL=XL
38264            PVALL=STATCL
38265            GOTO9000
38266          ENDIF
38267        ELSEIF(STATV2.GT.CV(NALPHA))THEN
38268          XL=ALPHAV(NALPHA)/AFACT
38269          XLF=CV(NALPHA)
38270          XR=XL*100.
38271          ALPHAT=XR
38272          ALPHA1=1.0-(ALPHAT/REAL(NUMDIS))
38273          TERM1=(REAL(NUPOOL)/REAL(NU(ILABMN))) - 1.0
38274          CALL FPPF(ALPHA1,IDF1MN,IDF2MN,FC)
38275          TERM2=1.0 + (TERM1/FC)
38276          XRF=1.0/TERM2
38277          IF(STATV2.GT.XRF)THEN
38278            STATCL=XR
38279            PVALL=STATCL
38280            GOTO9000
38281          ENDIF
38282        ELSE
38283          DO4110I=2,NALPHA
38284            IF(STATV2.GE.CV(I-1) .AND. STATV2.LE.CV(I))THEN
38285              XL=ALPHAV(I-1)/AFACT
38286              XLF=CV(I-1)
38287              XR=ALPHAV(I)/AFACT
38288              XRF=CV(I)
38289              GOTO4119
38290            ENDIF
38291 4110     CONTINUE
38292 4119     CONTINUE
38293        ENDIF
38294C
38295C       NOW THAT WE HAVE BRACKETING INTERVAL, USE BISECTION
38296C       TO DETERMINE CDF VALUE.
38297C
38298        IF(STATV2.EQ.XL)THEN
38299          STATCL=XL
38300          PVALU=STATCU
38301          GOTO9000
38302        ELSEIF(STATV2.EQ.XR)THEN
38303          STATCL=XR
38304          PVALL=STATCL
38305          GOTO9000
38306        ENDIF
38307C
38308        FXL=XLF-STATV2
38309        FXR=XRF-STATV2
38310        IC=0
38311 4125   CONTINUE
38312        XMID=(XL+XR)/2.0
38313        ALPHAT=XMID
38314        ALPHA1=ALPHAT/REAL(NUMDIS)
38315        TERM1=(REAL(NUPOOL)/REAL(NU(ILABMN))) - 1.0
38316        CALL FPPF(ALPHA1,IDF1MN,IDF2MN,FC)
38317        TERM2=1.0 + (TERM1/FC)
38318        XMIDF=1.0/TERM2
38319        FCS=XMIDF-STATV2
38320        IF(FCS*FXL.GT.0.0)THEN
38321          XL=XMID
38322          XLF=XMIDF
38323          FXL=FCS
38324        ELSE
38325          XR=XMID
38326          XRF=XMIDF
38327          FXR=FCS
38328        ENDIF
38329        XRML=XR-XL
38330        IF(XRML.LE.SIG .AND. ABS(FCS).LE.EPS)THEN
38331          STATCL=XMID
38332          PVALL=STATCL
38333          GOTO9000
38334        ENDIF
38335        IC=IC+1
38336        IF(IC.LE.MAXIT)GOTO4125
38337        WRITE(ICOUT,999)
38338        CALL DPWRST('XXX','WRIT')
38339        WRITE(ICOUT,4031)
38340        CALL DPWRST('XXX','WRIT')
38341        WRITE(ICOUT,4033)
38342        CALL DPWRST('XXX','WRIT')
38343        STATCL=XMID
38344        PVALL=STATCL
38345        GOTO9000
38346C
38347      ENDIF
38348C
38349C               *****************
38350C               **  STEP 90--  **
38351C               **  EXIT       **
38352C               *****************
38353C
38354 9000 CONTINUE
38355      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CVO3')THEN
38356        WRITE(ICOUT,999)
38357        CALL DPWRST('XXX','WRIT')
38358        WRITE(ICOUT,9011)
38359 9011   FORMAT('***** AT THE END       OF DPCOV3--')
38360        CALL DPWRST('XXX','WRIT')
38361        WRITE(ICOUT,9025)STATVA,STATV2
38362 9025   FORMAT('STATVA,STATV2 = ',2G15.7)
38363        CALL DPWRST('XXX','WRIT')
38364        DO9031I=1,NALPHA
38365          WRITE(ICOUT,9033)I,ALPHAV(I),CV(I)
38366 9033     FORMAT('I,ALPHAV(I),CV(I) = ',I8,2G15.7)
38367          CALL DPWRST('XXX','WRIT')
38368 9031   CONTINUE
38369      ENDIF
38370C
38371      RETURN
38372      END
38373      SUBROUTINE DPCUBE(IHARG,IARGT,ARG,NUMARG,
38374     1                  PXSTAR,PYSTAR,PXEND,PYEND,
38375     1                  ILINPA,ILINCO,PLINTH,
38376     1                  AREGBA,IREBLI,IREBCO,PREBTH,
38377     1                  IREFSW,IREFCO,
38378     1                  IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
38379     1                  PTEXHE,PTEXWI,PTEXVG,PTEXHG,
38380     1                  IGRASW,IDIASW,
38381     1                  PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
38382     1                  PDIAHE,PDIAWI,PDIAVG,PDIAHG,
38383     1                  NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
38384     1                  IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
38385     1                  IDNVOF,IDNHOF,IDFONT,UNITSW,PDSCAL,
38386     1                  IBUGD2,IFOUND,IERROR)
38387C
38388C     PURPOSE--DRAW ONE OR MORE CUBES (DEPENDING ON HOW MANY NUMBERS ARE
38389C              PROVIDED).  THE COORDINATES ARE IN STANDARDIZED UNITS
38390C              OF 0 TO 100.
38391C     NOTE--THE INPUT COORDINATES DEFINE THE OPPOSING CORNERS
38392C           OF (THE FRONT FACE OF) THE CUBE.
38393C     NOTE-THE USUAL INPUT NUMBER OF COORDINATES IS 2
38394C          AND THEREFORE THE USUAL INPUT NUMBER OF NUMBERS IS 2*2 = 4.
38395C     NOTE--IF 2 NUMBERS ARE PROVIDED, THEN THE DRAWN CUBE WILL GO FROM THE
38396C           LAST CURSOR POSITION TO THE (X,Y) POINT (EITHER ABSOLUTE OR
38397C           RELATIVE) AS DEFINED BY THE 2 NUMBERS.
38398C     NOTE--IF 4 NUMBERS ARE PROVIDED, THEN THE DRAWN CUBE WILL GO FROM THE
38399C           ABSOLUTE (X,Y) POSITION AS DEFINED BY THE FIRST 2 NUMBERS TO THE
38400C           (X,Y) POINT (EITHER ABSOLUTE OR RELATIVE) AS DEFINED BY THE THIRD
38401C           AND FOURTH NUMBERS.
38402C     NOTE--IF 6 NUMBERS ARE PROVIDED, THEN THE DRAWN CUBE WILL GO FROM THE
38403C           (X,Y) POSITION AS RESULTING FROM THE THIRD AND FOURTH NUMBERS TO
38404C           THE (X,Y) POINT (EITHER ABSOLUTE OR RELATIVE) AS DEFINED BY THE
38405C           FIFTH AND SIXTH NUMBERS.
38406C     NOTE--AND SO FORTH FOR 8, 10, 12, ... NUMBERS.
38407C     INPUT  ARGUMENTS--IHARG
38408C                     --IARGT
38409C                     --ARG
38410C                     --NUMARG
38411C                     --PXSTAR
38412C                     --PYSTAR
38413C     OUTPUT ARGUMENTS--PXEND
38414C                     --PYEND
38415C                     --IFOUND ('YES' OR 'NO' )
38416C                     --IERROR ('YES' OR 'NO' )
38417C     WRITTEN BY--JAMES J. FILLIBEN
38418C                 STATISTICAL ENGINEERING DIVISION
38419C                 INFORMATION TECHNOLOGY LABORATORY
38420C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
38421C                 GAITHERSBURG, MD 20899-8980
38422C                 PHONE--301-975-2855
38423C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
38424C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
38425C     LANGUAGE--ANSI FORTRAN (1977)
38426C     VERSION NUMBER--82/7
38427C     ORIGINAL VERSION--APRIL     1987.
38428C     UPDATED         --JANUARY   1989. CALL LIST FOR OFFSET VAR (ALAN)
38429C     UPDATED         --MARCH     1997. SUPPORT FOR DEVICE FONT (ALAN)
38430C     UPDATED         --JULY      1997. SUPPORT FOR "DATA" UNITS (ALAN)
38431C     UPDATED         --DECEMBER  2018. CHECK FOR DISCRETE, NULL, OR
38432C                                       NONE DEVICE
38433C     UPDATED         --DECEMBER  2018. SUPPORT FOR "DEVICE ... SCALE"
38434C                                       COMMAND
38435C
38436C-----NON-COMMON VARIABLES-----------------------------------------
38437C
38438      CHARACTER*4 IHARG
38439      CHARACTER*4 IARGT
38440C
38441      CHARACTER*4 ILINPA
38442      CHARACTER*4 ILINCO
38443C
38444      CHARACTER*4 IREBLI
38445      CHARACTER*4 IREBCO
38446      CHARACTER*4 IREFSW
38447      CHARACTER*4 IREFCO
38448      CHARACTER*4 IREPTY
38449      CHARACTER*4 IREPLI
38450      CHARACTER*4 IREPCO
38451C
38452      CHARACTER*4 IGRASW
38453      CHARACTER*4 IDIASW
38454C
38455      CHARACTER*4 IDMANU
38456      CHARACTER*4 IDMODE
38457      CHARACTER*4 IDMOD2
38458      CHARACTER*4 IDMOD3
38459      CHARACTER*4 IDPOWE
38460      CHARACTER*4 IDCONT
38461      CHARACTER*4 IDCOLO
38462CCCCC ADD FOLLOWING LINE MARCH 1997.
38463      CHARACTER*4 IDFONT
38464CCCCC ADD FOLLOWING LINE JULY 1997.
38465      CHARACTER*4 UNITSW
38466C
38467      CHARACTER*4 IFOUND
38468      CHARACTER*4 IBUGD2
38469      CHARACTER*4 IERROR
38470      CHARACTER*4 ISUBRO
38471C
38472      CHARACTER*4 IFIG
38473      CHARACTER*4 IBELSW
38474      CHARACTER*4 IERASW
38475      CHARACTER*4 IBACCO
38476      CHARACTER*4 ICOPSW
38477      CHARACTER*4 ITYPEO
38478C
38479      DIMENSION IHARG(*)
38480      DIMENSION IARGT(*)
38481      DIMENSION ARG(*)
38482C
38483      DIMENSION ILINPA(*)
38484      DIMENSION ILINCO(*)
38485      DIMENSION PLINTH(*)
38486C
38487      DIMENSION AREGBA(*)
38488      DIMENSION IREBLI(*)
38489      DIMENSION IREBCO(*)
38490      DIMENSION PREBTH(*)
38491      DIMENSION IREFSW(*)
38492      DIMENSION IREFCO(*)
38493      DIMENSION IREPTY(*)
38494      DIMENSION IREPLI(*)
38495      DIMENSION IREPCO(*)
38496      DIMENSION PREPTH(*)
38497      DIMENSION PREPSP(*)
38498      DIMENSION PDSCAL(*)
38499C
38500      DIMENSION IDMANU(*)
38501      DIMENSION IDMODE(*)
38502      DIMENSION IDMOD2(*)
38503      DIMENSION IDMOD3(*)
38504      DIMENSION IDPOWE(*)
38505      DIMENSION IDCONT(*)
38506      DIMENSION IDCOLO(*)
38507CCCCC ADD FOLLOWING LINE MARCH 1997.
38508      DIMENSION IDFONT(*)
38509      DIMENSION IDNVPP(*)
38510      DIMENSION IDNHPP(*)
38511      DIMENSION IDUNIT(*)
38512C
38513      DIMENSION IDNVOF(*)
38514      DIMENSION IDNHOF(*)
38515C
38516C-----COMMON----------------------------------------------------------
38517C
38518      INCLUDE 'DPCOGR.INC'
38519      INCLUDE 'DPCOBE.INC'
38520C
38521C-----COMMON VARIABLES (GENERAL)--------------------------------------
38522C
38523      INCLUDE 'DPCOP2.INC'
38524C
38525C-----START POINT-----------------------------------------------------
38526C
38527      IFOUND='NO'
38528      IERROR='NO'
38529      IERRG4=IERROR
38530CCCCC IBUGG4=IBUGD2
38531CCCCC ISUBG4=ISUBRO
38532C
38533      ILOCFN=0
38534      NUMNUM=0
38535C
38536      X1=0.0
38537      Y1=0.0
38538      X2=0.0
38539      Y2=0.0
38540C
38541      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CUBE')GOTO90
38542      WRITE(ICOUT,999)
38543  999 FORMAT(1X)
38544      CALL DPWRST('XXX','BUG ')
38545      WRITE(ICOUT,51)
38546   51 FORMAT('***** AT THE BEGINNING OF DPCUBE--')
38547      CALL DPWRST('XXX','BUG ')
38548      WRITE(ICOUT,53)NUMARG
38549   53 FORMAT('NUMARG = ',I8)
38550      CALL DPWRST('XXX','BUG ')
38551      DO55I=1,NUMARG
38552      WRITE(ICOUT,56)I,IHARG(I),IARGT(I),ARG(I)
38553   56 FORMAT('I,IHARG(I),IARGT(I),ARG(I) = ',I8,2X,A4,2X,A4,E15.7)
38554      CALL DPWRST('XXX','BUG ')
38555   55 CONTINUE
38556      WRITE(ICOUT,57)PXSTAR,PYSTAR
38557   57 FORMAT('PXSTAR,PYSTAR = ',2E15.7)
38558      CALL DPWRST('XXX','BUG ')
38559      WRITE(ICOUT,58)PXEND,PYEND
38560   58 FORMAT('PXEND,PYEND = ',2E15.7)
38561      CALL DPWRST('XXX','BUG ')
38562      WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1)
38563   61 FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',A4,2X,A4,E15.7)
38564      CALL DPWRST('XXX','BUG ')
38565      WRITE(ICOUT,62)AREGBA(1)
38566   62 FORMAT('AREGBA(1) = ',E15.7)
38567      CALL DPWRST('XXX','BUG ')
38568      WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1)
38569   63 FORMAT('IREBLI(1),IREBCO(1),PREBTH(1) = ',A4,2X,A4,E15.7)
38570      CALL DPWRST('XXX','BUG ')
38571      WRITE(ICOUT,64)IREFSW(1),IREFCO(1)
38572   64 FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4)
38573      CALL DPWRST('XXX','BUG ')
38574      WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1)
38575   65 FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ',
38576     1A4,2X,A4,2X,A4,2E15.7)
38577      CALL DPWRST('XXX','BUG ')
38578      WRITE(ICOUT,69)PTEXHE,PTEXWI
38579   69 FORMAT('PTEXHE,PTEXWI= ',2E15.7)
38580      CALL DPWRST('XXX','BUG ')
38581      WRITE(ICOUT,70)PTEXVG,PTEXHG
38582   70 FORMAT('PTEXVG,PTEXHG= ',2E15.6)
38583      CALL DPWRST('XXX','BUG ')
38584      WRITE(ICOUT,76)IGRASW,IDIASW
38585   76 FORMAT('IGRASW,IDIASW = ',A4,2X,A4)
38586      CALL DPWRST('XXX','BUG ')
38587      WRITE(ICOUT,77)PGRAXF,PGRAYF,PDIAXC,PDIAYC
38588   77 FORMAT('PGRAXF,PGRAYF,PDIAXC,PDIAYC = ',4E15.7)
38589      CALL DPWRST('XXX','BUG ')
38590      WRITE(ICOUT,78)PDIAHE,PDIAWI,PDIAVG,PDIAHG
38591   78 FORMAT('PDIAHE,PDIAWI,PDIAVG,PDIAHG = ',4E15.7)
38592      CALL DPWRST('XXX','BUG ')
38593      WRITE(ICOUT,80)NUMDEV
38594   80 FORMAT('NUMDEV= ',I8)
38595      CALL DPWRST('XXX','BUG ')
38596      DO81I=1,NUMDEV
38597      WRITE(ICOUT,82)IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I)
38598   82 FORMAT('IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I) = ',
38599     1A4,2X,A4,2X,A4,2X,A4)
38600      CALL DPWRST('XXX','BUG ')
38601      WRITE(ICOUT,83)IDPOWE(I),IDCONT(I),IDCOLO(I)
38602   83 FORMAT('IDPOWE(I),IDCONT(I),IDCOLO(I) = ',
38603     1A4,2X,A4,2X,A4)
38604      CALL DPWRST('XXX','BUG ')
38605      WRITE(ICOUT,84)IDNVPP(I),IDNHPP(I),IDUNIT(I)
38606   84 FORMAT('IDNVPP(I),IDNHPP(I),IDUNIT(I) = ',
38607     1I8,I8,I8)
38608      CALL DPWRST('XXX','BUG ')
38609   81 CONTINUE
38610      WRITE(ICOUT,87)IFOUND
38611   87 FORMAT('IFOUND= ',A4)
38612      CALL DPWRST('XXX','BUG ')
38613      WRITE(ICOUT,88)IBUGG4,ISUBG4,IERRG4
38614   88 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
38615      CALL DPWRST('XXX','BUG ')
38616      WRITE(ICOUT,89)IBUGD2,IERROR
38617   89 FORMAT('IBUGD2,IERROR= ',A4,2X,A4)
38618      CALL DPWRST('XXX','BUG ')
38619   90 CONTINUE
38620C
38621      IFIG='CUBE'
38622      NUMPT=2
38623      NUMPT2=2*NUMPT
38624C
38625C               ********************************
38626C               **  STEP 0--                  **
38627C               **  STEP THROUGH EACH DEVICE  **
38628C               ********************************
38629C
38630      IF(NUMDEV.LE.0)GOTO9000
38631      DO8000IDEVIC=1,NUMDEV
38632C
38633      IF(IDPOWE(IDEVIC).EQ.'OFF')GOTO8000
38634      IF(IDMANU(IDEVIC).EQ.'OFF')GOTO8000
38635      IF(IDMANU(IDEVIC).EQ.'NULL')GOTO8000
38636      IF(IDMANU(IDEVIC).EQ.'NONE')GOTO8000
38637      IF(IDMANU(IDEVIC).EQ.'DISC')GOTO8000
38638C
38639      IMANUF=IDMANU(IDEVIC)
38640      IMODEL=IDMODE(IDEVIC)
38641      IMODE2=IDMOD2(IDEVIC)
38642      IMODE3=IDMOD3(IDEVIC)
38643      IGCONT=IDCONT(IDEVIC)
38644      IGCOLO=IDCOLO(IDEVIC)
38645      IGFONT=IDFONT(IDEVIC)
38646      NUMVPP=IDNVPP(IDEVIC)
38647      NUMHPP=IDNHPP(IDEVIC)
38648      ANUMVP=NUMVPP
38649      ANUMHP=NUMHPP
38650      IOFFSV=IDNVOF(IDEVIC)
38651      IOFFSH=IDNHOF(IDEVIC)
38652      IGUNIT=IDUNIT(IDEVIC)
38653      PCHSCA=PDSCAL(IDEVIC)
38654C
38655C               ************************************
38656C               **  STEP 1--                      **
38657C               **  CARRY OUT OPENING OPERATIONS  **
38658C               **  ON THE GRAPHICS DEVICES       **
38659C               ************************************
38660C
38661      CALL DPOPDE
38662C
38663      IBELSW='OFF'
38664      NUMRIN=0
38665      IERASW='OFF'
38666      IBACCO='JUNK'
38667C
38668      CALL DPOPPL(IGRASW,
38669     1IBELSW,NUMRIN,IERASW,
38670     1IBACCO)
38671C
38672C               *****************************************
38673C               **  STEP 2--                           **
38674C               **  SEARCH FOR COMMAND SPECIFICATIONS  **
38675C               *****************************************
38676C
38677      IF(NUMARG.GE.2.AND.
38678     1IARGT(1).EQ.'NUMB'.AND.IARGT(2).EQ.'NUMB')
38679     1GOTO1111
38680      IF(NUMARG.GE.3.AND.IHARG(1).EQ.'ABSO'.AND.
38681     1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB')
38682     1GOTO1112
38683      IF(NUMARG.GE.3.AND.IHARG(1).EQ.'RELA'.AND.
38684     1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB')
38685     1GOTO1113
38686      GOTO1130
38687C
38688 1111 CONTINUE
38689      ITYPEO='ABSO'
38690      ILOCFN=1
38691      GOTO1119
38692C
38693 1112 CONTINUE
38694      ITYPEO='ABSO'
38695      ILOCFN=2
38696      GOTO1119
38697C
38698 1113 CONTINUE
38699      ITYPEO='RELA'
38700      ILOCFN=2
38701      GOTO1119
38702 1119 CONTINUE
38703C
38704      IF(ILOCFN.GT.NUMARG)GOTO1129
38705      DO1120I=ILOCFN,NUMARG
38706      IF(IARGT(I).EQ.'NUMB')GOTO1120
38707      GOTO1129
38708 1120 CONTINUE
38709      IFOUND='YES'
38710      GOTO1149
38711 1129 CONTINUE
38712      GOTO1130
38713C
38714 1130 CONTINUE
38715      IERRG4='YES'
38716      WRITE(ICOUT,1131)
38717 1131 FORMAT('***** ERROR IN DPCUBE--')
38718      CALL DPWRST('XXX','BUG ')
38719      WRITE(ICOUT,1132)
38720 1132 FORMAT('      ILLEGAL FORM FOR DRAW ',
38721     1'COMMAND.')
38722      CALL DPWRST('XXX','BUG ')
38723      WRITE(ICOUT,1134)
38724 1134 FORMAT('      TEST EXAMPLE TO DEMONSTRATE THE ',
38725     1'PROPER FORM--')
38726      CALL DPWRST('XXX','BUG ')
38727      WRITE(ICOUT,1135)
38728 1135 FORMAT('      SUPPOSE IT IS DESIRED TO DRAW A CUBE ')
38729      CALL DPWRST('XXX','BUG ')
38730      WRITE(ICOUT,1136)
38731 1136 FORMAT('      WITH ONE FRONT FACE CORNER AT THE POINT 20 20 ')
38732      CALL DPWRST('XXX','BUG ')
38733      WRITE(ICOUT,1137)
38734 1137 FORMAT('      AND THE FRONT FACE OPPOSITE CORNER AT 40 60')
38735      CALL DPWRST('XXX','BUG ')
38736      WRITE(ICOUT,1141)
38737 1141 FORMAT('      THEN THE ALLOWABLE FORMS ARE--')
38738      CALL DPWRST('XXX','BUG ')
38739      WRITE(ICOUT,1142)
38740 1142 FORMAT('      CUBE 20 20 40 60 ')
38741      CALL DPWRST('XXX','BUG ')
38742      WRITE(ICOUT,1143)
38743 1143 FORMAT('      CUBE ABSOLUTE 20 20 40 60 ')
38744      CALL DPWRST('XXX','BUG ')
38745      GOTO9000
38746 1149 CONTINUE
38747C
38748C               ****************************
38749C               **  STEP 3--              **
38750C               **  DRAW OUT THE LINE(S)  **
38751C               ****************************
38752C
38753      NUMNUM=NUMARG-ILOCFN+1
38754      IF(NUMNUM.LT.NUMPT2)GOTO1151
38755      GOTO1152
38756C
38757 1151 CONTINUE
38758      J=ILOCFN-1
38759      X1=PXSTAR
38760      Y1=PYSTAR
38761      GOTO1159
38762C
38763 1152 CONTINUE
38764      J=ILOCFN
38765      IF(J.GT.NUMARG)GOTO1190
38766      X1=ARG(J)
38767CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997
38768      IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X1,X1,IBUGD2,ISUBRO,IERROR)
38769      J=J+1
38770      IF(J.GT.NUMARG)GOTO1190
38771      Y1=ARG(J)
38772CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997
38773      IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y1,Y1,IBUGD2,ISUBRO,IERROR)
38774      GOTO1159
38775 1159 CONTINUE
38776C
38777 1160 CONTINUE
38778      J=J+1
38779      IF(J.GT.NUMARG)GOTO1190
38780      X2=ARG(J)
38781CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997
38782      IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X2,X2,IBUGD2,ISUBRO,IERROR)
38783      IF(ITYPEO.EQ.'RELA')X2=X1+X2
38784      J=J+1
38785      IF(J.GT.NUMARG)GOTO1190
38786      Y2=ARG(J)
38787CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997
38788      IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y2,Y2,IBUGD2,ISUBRO,IERROR)
38789      IF(ITYPEO.EQ.'RELA')Y2=Y1+Y2
38790C
38791      CALL DPCUB2(X1,Y1,X2,Y2,
38792     1            IFIG,
38793     1            ILINPA,ILINCO,PLINTH,
38794     1            AREGBA,
38795     1            IREBLI,IREBCO,PREBTH,
38796     1            IREFSW,IREFCO,
38797     1            IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
38798     1            PTEXHE,PTEXWI,PTEXVG,PTEXHG)
38799C
38800      X1=X2
38801      Y1=Y2
38802C
38803      GOTO1160
38804 1190 CONTINUE
38805C
38806      PXEND=X2
38807      PYEND=Y2
38808C
38809C               ************************************
38810C               **  STEP 4--                      **
38811C               **  CARRY OUT CLOSING OPERATIONS  **
38812C               **  ON THE GRAPHICS DEVICES       **
38813C               ************************************
38814C
38815      ICOPSW='OFF'
38816      NUMCOP=0
38817      CALL DPCLPL(ICOPSW,NUMCOP,
38818     1PGRAXF,PGRAYF,
38819     1IGRASW,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
38820     1PDIAHE,PDIAWI,PDIAVG,PDIAHG)
38821C
38822      CALL DPCLDE
38823C
38824 8000 CONTINUE
38825C
38826C               *****************
38827C               **  STEP 90--  **
38828C               **  EXIT       **
38829C               *****************
38830C
38831 9000 CONTINUE
38832      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CUBE')GOTO9090
38833      WRITE(ICOUT,999)
38834      CALL DPWRST('XXX','BUG ')
38835      WRITE(ICOUT,9011)
38836 9011 FORMAT('***** AT THE END       OF DPCUBE--')
38837      CALL DPWRST('XXX','BUG ')
38838      WRITE(ICOUT,9012)ILOCFN,NUMNUM
38839 9012 FORMAT('ILOCFN,NUMNUM = ',2I8)
38840      CALL DPWRST('XXX','BUG ')
38841      WRITE(ICOUT,9013)X1,Y1,X2,Y2
38842 9013 FORMAT('X1,Y1,X2,Y2 = ',4E15.7)
38843      CALL DPWRST('XXX','BUG ')
38844      WRITE(ICOUT,9015)PXSTAR,PYSTAR
38845 9015 FORMAT('PXSTAR,PYSTAR = ',2E15.7)
38846      CALL DPWRST('XXX','BUG ')
38847      WRITE(ICOUT,9016)PXEND,PYEND
38848 9016 FORMAT('PXEND,PYEND = ',2E15.7)
38849      CALL DPWRST('XXX','BUG ')
38850      WRITE(ICOUT,9017)IFIG
38851 9017 FORMAT('IFIG = ',A4)
38852      CALL DPWRST('XXX','BUG ')
38853      WRITE(ICOUT,9027)IFOUND
38854 9027 FORMAT('IFOUND = ',A4)
38855      CALL DPWRST('XXX','BUG ')
38856      WRITE(ICOUT,9028)IBUGG4,ISUBG4,IERRG4
38857 9028 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4)
38858      CALL DPWRST('XXX','BUG ')
38859      WRITE(ICOUT,9029)IBUGD2,IERROR
38860 9029 FORMAT('IBUGD2,IERROR = ',A4,2X,A4)
38861      CALL DPWRST('XXX','BUG ')
38862 9090 CONTINUE
38863C
38864      RETURN
38865      END
38866      SUBROUTINE DPCUB2(X1,Y1,X2,Y2,
38867     1IFIG,
38868     1ILINPA,ILINCO,PLINTH,
38869     1AREGBA,
38870     1IREBLI,IREBCO,PREBTH,
38871     1IREFSW,IREFCO,
38872     1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
38873     1PTEXHE,PTEXWI,PTEXVG,PTEXHG)
38874C
38875C     PURPOSE--DRAW A CUBE
38876C              WITH ONE FRONT FACE CORNER AT (X1,Y1)
38877C              AND THE FRONT FACE OPPOSITE CORNER AT (X2,Y2).
38878C     WRITTEN BY--JAMES J. FILLIBEN
38879C                 STATISTICAL ENGINEERING DIVISION
38880C                 INFORMATION TECHNOLOGY LABORATORY
38881C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
38882C                 GAITHERSBURG, MD 20899-8980
38883C                 PHONE--301-975-2855
38884C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
38885C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
38886C     LANGUAGE--ANSI FORTRAN (1977)
38887C     VERSION NUMBER--87/5
38888C     ORIGINAL VERSION--APRIL     1987.
38889C     UPDATED         --JANUARY   1989.  MODIFY CALLS TO DPDRPL (ALAN)
38890C     UPDATED         --JANUARY   1989.  MODIFY CALL  TO DPFIRE (ALAN)
38891C
38892C-----NON-COMMON VARIABLES-------------------------------------
38893C
38894      CHARACTER*4 IFIG
38895      CHARACTER*4 IPATT2
38896C
38897      CHARACTER*4 ILINPA
38898      CHARACTER*4 ILINCO
38899C
38900      CHARACTER*4 IREBLI
38901      CHARACTER*4 IREBCO
38902      CHARACTER*4 IREFSW
38903      CHARACTER*4 IREFCO
38904      CHARACTER*4 IREPTY
38905      CHARACTER*4 IREPLI
38906      CHARACTER*4 IREPCO
38907C
38908      CHARACTER*4 IPATT
38909      CHARACTER*4 ICOLF
38910      CHARACTER*4 ICOLP
38911      CHARACTER*4 ICOL
38912      CHARACTER*4 IFLAG
38913C
38914      DIMENSION PX(20)
38915      DIMENSION PY(20)
38916CCCCC DIMENSION PX3(20)
38917CCCCC DIMENSION PY3(20)
38918C
38919      DIMENSION ILINPA(*)
38920      DIMENSION ILINCO(*)
38921      DIMENSION PLINTH(*)
38922C
38923      DIMENSION AREGBA(*)
38924      DIMENSION IREBLI(*)
38925      DIMENSION IREBCO(*)
38926      DIMENSION PREBTH(*)
38927      DIMENSION IREFSW(*)
38928      DIMENSION IREFCO(*)
38929      DIMENSION IREPTY(*)
38930      DIMENSION IREPLI(*)
38931      DIMENSION IREPCO(*)
38932      DIMENSION PREPTH(*)
38933      DIMENSION PREPSP(*)
38934C
38935C-----COMMON----------------------------------------------------------
38936C
38937      INCLUDE 'DPCOGR.INC'
38938      INCLUDE 'DPCOBE.INC'
38939C
38940C-----COMMON VARIABLES (GENERAL)--------------------------------------
38941C
38942      INCLUDE 'DPCOP2.INC'
38943C
38944C-----START POINT-----------------------------------------------------
38945C
38946      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CUB2')GOTO90
38947      WRITE(ICOUT,999)
38948  999 FORMAT(1X)
38949      CALL DPWRST('XXX','BUG ')
38950      WRITE(ICOUT,51)
38951   51 FORMAT('***** AT THE BEGINNING OF DPCUB2--')
38952      CALL DPWRST('XXX','BUG ')
38953      WRITE(ICOUT,53)X1,Y1
38954   53 FORMAT('X1,Y1 = ',2E15.7)
38955      CALL DPWRST('XXX','BUG ')
38956      WRITE(ICOUT,54)X2,Y2
38957   54 FORMAT('X2,Y2 = ',2E15.7)
38958      CALL DPWRST('XXX','BUG ')
38959      WRITE(ICOUT,59)IFIG
38960   59 FORMAT('IFIG = ',A4)
38961      CALL DPWRST('XXX','BUG ')
38962      WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1)
38963   61 FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',A4,2X,A4,E15.7)
38964      CALL DPWRST('XXX','BUG ')
38965      WRITE(ICOUT,62)AREGBA(1)
38966   62 FORMAT('AREGBA(1) = ',E15.7)
38967      CALL DPWRST('XXX','BUG ')
38968      WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1)
38969   63 FORMAT('IREBLI(1),IREBCO(1),PREBTH(1) = ',A4,2X,A4,E15.7)
38970      CALL DPWRST('XXX','BUG ')
38971      WRITE(ICOUT,64)IREFSW(1),IREFCO(1)
38972   64 FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4)
38973      CALL DPWRST('XXX','BUG ')
38974      WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1)
38975   65 FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ',
38976     1A4,2X,A4,2X,A4,2E15.7)
38977      CALL DPWRST('XXX','BUG ')
38978      WRITE(ICOUT,69)PTEXHE,PTEXWI
38979   69 FORMAT('PTEXHE,PTEXWI= ',2E15.7)
38980      CALL DPWRST('XXX','BUG ')
38981      WRITE(ICOUT,70)PTEXVG,PTEXHG
38982   70 FORMAT('PTEXVG,PTEXHG= ',2E15.6)
38983      CALL DPWRST('XXX','BUG ')
38984      WRITE(ICOUT,79)IBUGG4,ISUBG4,IERRG4
38985   79 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
38986      CALL DPWRST('XXX','BUG ')
38987   90 CONTINUE
38988C
38989C               *********************************
38990C               **  STEP 1--                   **
38991C               **  SET THE SPECS              **
38992C               **  WHICH CONTROL THE          **
38993C               **  APPEARANCE OF THE          **
38994C               **  RESULTING CUBE.            **
38995C               *********************************
38996C
38997      DELX=ABS(X2-X1)
38998      DELY=ABS(Y2-Y1)
38999      DELMIN=DELX
39000CCCCC IF(DELY.LT.DELX)DELMIN=DELY
39001      P3D=0.3
39002      DEL3D=P3D*DELMIN
39003C
39004C               *************************
39005C               **  STEP 2--           **
39006C               **  FILL THE FIGURE    **
39007C               **  (IF CALLED FOR)    **
39008C               *************************
39009C
39010      IF(IREFSW(1).EQ.'OFF')GOTO2190
39011C
39012      IPATT=IREPTY(1)
39013      PTHICK=PREPTH(1)
39014      PXGAP=PREPSP(1)
39015      PYGAP=PREPSP(1)
39016      ICOLF=IREFCO(1)
39017      ICOLP=IREPCO(1)
39018C
39019      IF(IREFSW(1).EQ.'ON')GOTO2110
39020      IF(IREFSW(1).EQ.'ONF')GOTO2110
39021      IF(IREFSW(1).EQ.'ONS')GOTO2120
39022      IF(IREFSW(1).EQ.'ONT')GOTO2130
39023      IF(IREFSW(1).EQ.'ONFS')GOTO2110
39024      IF(IREFSW(1).EQ.'ONSF')GOTO2110
39025      IF(IREFSW(1).EQ.'ONFT')GOTO2110
39026      IF(IREFSW(1).EQ.'ONTF')GOTO2110
39027      IF(IREFSW(1).EQ.'ONST')GOTO2120
39028      IF(IREFSW(1).EQ.'ONTS')GOTO2120
39029C
39030C               ********************************
39031C               **  STEP 2.1--                **
39032C               **  FRONT FACE ONLY           **
39033C               ********************************
39034C
39035 2110 CONTINUE
39036      PX(1)=X1
39037      PY(1)=Y1
39038C
39039      PX(2)=X2
39040      PY(2)=Y1
39041C
39042      PX(3)=X2
39043      PY(3)=Y2
39044C
39045      PX(4)=X1
39046      PY(4)=Y2
39047C
39048      PX(5)=X1
39049      PY(5)=Y1
39050C
39051      NP=5
39052C
39053      IPATT2='SOLI'
39054      CALL DPFIRE(PX,PY,NP,
39055     1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,IPATT2)
39056C
39057      IF(IREFSW(1).EQ.'ON')GOTO2120
39058      IF(IREFSW(1).EQ.'ONF')GOTO2190
39059      IF(IREFSW(1).EQ.'ONS')GOTO2120
39060      IF(IREFSW(1).EQ.'ONT')GOTO2130
39061      IF(IREFSW(1).EQ.'ONFS')GOTO2120
39062      IF(IREFSW(1).EQ.'ONSF')GOTO2120
39063      IF(IREFSW(1).EQ.'ONFT')GOTO2130
39064      IF(IREFSW(1).EQ.'ONTF')GOTO2130
39065      IF(IREFSW(1).EQ.'ONST')GOTO2120
39066      IF(IREFSW(1).EQ.'ONTS')GOTO2120
39067C
39068C               ********************************
39069C               **  STEP 2.2--                **
39070C               **  SIDE (= RIGHT) FACE ONLY  **
39071C               ********************************
39072C
39073C
39074 2120 CONTINUE
39075      PX(1)=X2
39076      PY(1)=Y2
39077C
39078      PX(2)=X2+DEL3D
39079      PY(2)=Y2+DEL3D
39080C
39081      PX(3)=X2+DEL3D
39082      PY(3)=Y1+DEL3D
39083C
39084      PX(4)=X2
39085      PY(4)=Y1
39086C
39087      PX(5)=X2
39088      PY(5)=Y2
39089C
39090      NP=5
39091C
39092      IPATT2='SOLI'
39093      CALL DPFIRE(PX,PY,NP,
39094     1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,IPATT2)
39095C
39096      IF(IREFSW(1).EQ.'ON')GOTO2130
39097      IF(IREFSW(1).EQ.'ONF')GOTO2190
39098      IF(IREFSW(1).EQ.'ONS')GOTO2190
39099      IF(IREFSW(1).EQ.'ONT')GOTO2130
39100      IF(IREFSW(1).EQ.'ONFS')GOTO2190
39101      IF(IREFSW(1).EQ.'ONSF')GOTO2190
39102      IF(IREFSW(1).EQ.'ONFT')GOTO2130
39103      IF(IREFSW(1).EQ.'ONTF')GOTO2130
39104      IF(IREFSW(1).EQ.'ONST')GOTO2130
39105      IF(IREFSW(1).EQ.'ONTS')GOTO2130
39106C
39107C               ********************************
39108C               **  STEP 2.3--                **
39109C               **  TOP FACE ONLY             **
39110C               ********************************
39111C
39112 2130 CONTINUE
39113      PX(1)=X1
39114      PY(1)=Y2
39115C
39116      PX(2)=X1+DEL3D
39117      PY(2)=Y2+DEL3D
39118C
39119      PX(3)=X2+DEL3D
39120      PY(3)=Y2+DEL3D
39121C
39122      PX(4)=X2
39123      PY(4)=Y2
39124C
39125      PX(5)=X1
39126      PY(5)=Y2
39127C
39128      NP=5
39129C
39130      IPATT2='SOLI'
39131      CALL DPFIRE(PX,PY,NP,
39132     1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,IPATT2)
39133C
39134 2190 CONTINUE
39135C
39136C               ***************************
39137C               **  STEP 3--             **
39138C               **  DRAW OUT THE FIGURE  **
39139C               ***************************
39140C
39141      IPATT=ILINPA(1)
39142      PTHICK=PLINTH(1)
39143      ICOL=ILINCO(1)
39144C
39145      PX(1)=X1
39146      PY(1)=Y1
39147C
39148      PX(2)=X2
39149      PY(2)=Y1
39150C
39151      PX(3)=X2
39152      PY(3)=Y2
39153C
39154      PX(4)=X1
39155      PY(4)=Y2
39156C
39157      PX(5)=X1
39158      PY(5)=Y1
39159C
39160      NP=5
39161C
39162      IFLAG='ON'
39163CCCCC CALL DPDRPL(PX,PY,NP,PX3,PY3,NP3,
39164CCCCC1IFIG,IPATT,PTHICK,ICOL)
39165      CALL DPDRPL(PX,PY,NP,
39166     1IFIG,IPATT,PTHICK,ICOL,
39167     1JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
39168C
39169      PX(1)=X1
39170      PY(1)=Y2
39171C
39172      PX(2)=X1+DEL3D
39173      PY(2)=Y2+DEL3D
39174C
39175      PX(3)=X2+DEL3D
39176      PY(3)=Y2+DEL3D
39177C
39178      PX(4)=X2
39179      PY(4)=Y2
39180C
39181      NP=4
39182C
39183      IFLAG='ON'
39184CCCCC CALL DPDRPL(PX,PY,NP,PX3,PY3,NP3,
39185CCCCC1IFIG,IPATT,PTHICK,ICOL)
39186      CALL DPDRPL(PX,PY,NP,
39187     1IFIG,IPATT,PTHICK,ICOL,
39188     1JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
39189C
39190      PX(1)=X2+DEL3D
39191      PY(1)=Y2+DEL3D
39192C
39193      PX(2)=X2+DEL3D
39194      PY(2)=Y1+DEL3D
39195C
39196      PX(3)=X2
39197      PY(3)=Y1
39198C
39199      NP=3
39200C
39201      IFLAG='ON'
39202CCCCC CALL DPDRPL(PX,PY,NP,PX3,PY3,NP3,
39203CCCCC1IFIG,IPATT,PTHICK,ICOL)
39204      CALL DPDRPL(PX,PY,NP,
39205     1IFIG,IPATT,PTHICK,ICOL,
39206     1JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
39207C
39208C               *****************
39209C               **  STEP 90--  **
39210C               **  EXIT       **
39211C               *****************
39212C
39213      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CUB2')GOTO9090
39214      WRITE(ICOUT,999)
39215      CALL DPWRST('XXX','BUG ')
39216      WRITE(ICOUT,9011)
39217 9011 FORMAT('***** AT THE END       OF DPCUB2--')
39218      CALL DPWRST('XXX','BUG ')
39219      WRITE(ICOUT,9013)NP
39220 9013 FORMAT('NP = ',I8)
39221      CALL DPWRST('XXX','BUG ')
39222      DO9015I=1,NP
39223      WRITE(ICOUT,9016)I,PX(I),PY(I)
39224 9016 FORMAT('I,PX(I),PY(I) = ',I8,2E15.7)
39225      CALL DPWRST('XXX','BUG ')
39226 9015 CONTINUE
39227      WRITE(ICOUT,9021)IREFSW(1),IREFCO(1)
39228 9021 FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4)
39229      CALL DPWRST('XXX','BUG ')
39230      WRITE(ICOUT,9022)DELX,DELY,DELMIN,P3D,DEL3D
39231 9022 FORMAT('DELX,DELY,DELMIN,P3D,DEL3D = ',5E15.7)
39232      CALL DPWRST('XXX','BUG ')
39233      WRITE(ICOUT,9039)IBUGG4,ISUBG4,IERRG4
39234 9039 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
39235      CALL DPWRST('XXX','BUG ')
39236 9090 CONTINUE
39237C
39238      RETURN
39239      END
39240      SUBROUTINE DPCUCO(IHARG,IARGT,ARG,NUMARG,PDIAYC,
39241     1PDIAY2,IFOUND,IERROR)
39242C
39243C     PURPOSE--DEFINE THE (VERTICAL) COORDINATE FOR THE CURSOR
39244C              THE COORDINATE FOR THE CURSOR WILL BE PLACED
39245C              IN THE FLOATING POINT VARIABLE PDIAY2.
39246C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
39247C                     --NUMARG
39248C                     --PDIAYC
39249C     OUTPUT ARGUMENTS--PDIAY2
39250C                     --IFOUND ('YES' OR 'NO' )
39251C                     --IERROR ('YES' OR 'NO' )
39252C     WRITTEN BY--JAMES J. FILLIBEN
39253C                 STATISTICAL ENGINEERING DIVISION
39254C                 INFORMATION TECHNOLOGY LABORATORY
39255C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
39256C                 GAITHERSBURG, MD 20899-8980
39257C                 PHONE--301-975-2855
39258C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
39259C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
39260C     LANGUAGE--ANSI FORTRAN (1977)
39261C     VERSION NUMBER--86/7
39262C     ORIGINAL VERSION--APRIL     1986.
39263C
39264C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
39265C
39266      CHARACTER*4 IHARG
39267      CHARACTER*4 IARGT
39268      CHARACTER*4 IFOUND
39269      CHARACTER*4 IERROR
39270C
39271C---------------------------------------------------------------------
39272C
39273      DIMENSION IHARG(*)
39274      DIMENSION IARGT(*)
39275      DIMENSION ARG(*)
39276C
39277C---------------------------------------------------------------------
39278C
39279      INCLUDE 'DPCOP2.INC'
39280C
39281C-----START POINT-----------------------------------------------------
39282C
39283      IFOUND='NO'
39284      IERROR='NO'
39285C
39286      IF(NUMARG.EQ.1)GOTO1150
39287      IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160
39288      GOTO1110
39289C
39290 1110 CONTINUE
39291      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
39292      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
39293      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
39294      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
39295C
39296      IERROR='YES'
39297      WRITE(ICOUT,1121)
39298 1121 FORMAT('***** ERROR IN DPCUCO--')
39299      CALL DPWRST('XXX','BUG ')
39300      WRITE(ICOUT,1122)
39301 1122 FORMAT('      ILLEGAL FORM FOR CURSOR COORDINATES ',
39302     1'COMMAND.')
39303      CALL DPWRST('XXX','BUG ')
39304      WRITE(ICOUT,1124)
39305 1124 FORMAT('      TEST EXAMPLE TO DEMONSTRATE THE ',
39306     1'PROPER FORM--')
39307      CALL DPWRST('XXX','BUG ')
39308      WRITE(ICOUT,1125)
39309 1125 FORMAT('      SUPPOSE IT IS DESIRED TO HAVE ')
39310      CALL DPWRST('XXX','BUG ')
39311      WRITE(ICOUT,1126)
39312 1126 FORMAT('      THE CURSOR COORDINATE TO BE 20 PERCENT ')
39313      CALL DPWRST('XXX','BUG ')
39314      WRITE(ICOUT,1127)
39315 1127 FORMAT('      OF THE WAY UP THE SCREEN (FROM THE BOTTOM), ')
39316      CALL DPWRST('XXX','BUG ')
39317      WRITE(ICOUT,1128)
39318 1128 FORMAT('      THEN THE ALLOWABLE FORM IS--')
39319      CALL DPWRST('XXX','BUG ')
39320      WRITE(ICOUT,1131)
39321 1131 FORMAT('      CURSOR COORDINATE 20')
39322      CALL DPWRST('XXX','BUG ')
39323      GOTO1199
39324C
39325 1150 CONTINUE
39326      PDIAY2=PDIAYC
39327      GOTO1180
39328C
39329 1160 CONTINUE
39330      PDIAY2=ARG(NUMARG)
39331      GOTO1180
39332C
39333 1180 CONTINUE
39334      IFOUND='YES'
39335C
39336      IF(IFEEDB.EQ.'OFF')GOTO1189
39337      WRITE(ICOUT,999)
39338  999 FORMAT(1X)
39339      CALL DPWRST('XXX','BUG ')
39340      WRITE(ICOUT,1181)PDIAY2
39341 1181 FORMAT('THE CURSOR COORDINATE HAS JUST BEEN SET TO ',
39342     1E15.7)
39343      CALL DPWRST('XXX','BUG ')
39344 1189 CONTINUE
39345      GOTO1199
39346C
39347 1199 CONTINUE
39348      RETURN
39349      END
39350      SUBROUTINE DPCUSP(IHARG,IARGT,ARG,NUMARG,DEFCSP,
39351     1PDIAVG,IFOUND,IERROR)
39352C
39353C     PURPOSE--DEFINE THE SPACING (= VERTICAL GAP) FOR THE CURSOR
39354C              THE SPACING FOR THE CURSOR WILL BE PLACED
39355C              IN THE FLOATING POINT VARIABLE PDIAVG.
39356C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
39357C                     --NUMARG
39358C                     --DEFCSP
39359C     OUTPUT ARGUMENTS--PDIAVG
39360C                     --IFOUND ('YES' OR 'NO' )
39361C                     --IERROR ('YES' OR 'NO' )
39362C     WRITTEN BY--JAMES J. FILLIBEN
39363C                 STATISTICAL ENGINEERING DIVISION
39364C                 INFORMATION TECHNOLOGY LABORATORY
39365C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
39366C                 GAITHERSBURG, MD 20899-8980
39367C                 PHONE--301-975-2855
39368C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
39369C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
39370C     LANGUAGE--ANSI FORTRAN (1977)
39371C     VERSION NUMBER--86/7
39372C     ORIGINAL VERSION--APRIL     1986.
39373C
39374C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
39375C
39376      CHARACTER*4 IHARG
39377      CHARACTER*4 IARGT
39378      CHARACTER*4 IFOUND
39379      CHARACTER*4 IERROR
39380C
39381C---------------------------------------------------------------------
39382C
39383      DIMENSION IHARG(*)
39384      DIMENSION IARGT(*)
39385      DIMENSION ARG(*)
39386C
39387C---------------------------------------------------------------------
39388C
39389      INCLUDE 'DPCOP2.INC'
39390C
39391C-----START POINT-----------------------------------------------------
39392C
39393      IFOUND='NO'
39394      IERROR='NO'
39395C
39396      IF(NUMARG.EQ.1)GOTO1150
39397      IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160
39398      GOTO1110
39399C
39400 1110 CONTINUE
39401      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
39402      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
39403      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
39404      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
39405C
39406      IERROR='YES'
39407      WRITE(ICOUT,1121)
39408 1121 FORMAT('***** ERROR IN DPCUSP--')
39409      CALL DPWRST('XXX','BUG ')
39410      WRITE(ICOUT,1122)
39411 1122 FORMAT('      ILLEGAL FORM FOR CURSOR SPACING ',
39412     1'COMMAND.')
39413      CALL DPWRST('XXX','BUG ')
39414      WRITE(ICOUT,1124)
39415 1124 FORMAT('      TEST EXAMPLE TO DEMONSTRATE THE ',
39416     1'PROPER FORM--')
39417      CALL DPWRST('XXX','BUG ')
39418      WRITE(ICOUT,1125)
39419 1125 FORMAT('      SUPPOSE IT IS DESIRED TO HAVE ')
39420      CALL DPWRST('XXX','BUG ')
39421      WRITE(ICOUT,1126)
39422 1126 FORMAT('      THE CURSOR SPACING TO BE 2 PERCENT ')
39423      CALL DPWRST('XXX','BUG ')
39424      WRITE(ICOUT,1127)
39425 1127 FORMAT('      OF TOTAL SCREEN HEIGHT, ')
39426      CALL DPWRST('XXX','BUG ')
39427      WRITE(ICOUT,1128)
39428 1128 FORMAT('      THEN THE ALLOWABLE FORM IS--')
39429      CALL DPWRST('XXX','BUG ')
39430      WRITE(ICOUT,1131)
39431 1131 FORMAT('      CURSOR SPACING 2')
39432      CALL DPWRST('XXX','BUG ')
39433      GOTO1199
39434C
39435 1150 CONTINUE
39436      PDIAVG=DEFCSP
39437      GOTO1180
39438C
39439 1160 CONTINUE
39440      PDIAVG=ARG(NUMARG)
39441      GOTO1180
39442C
39443 1180 CONTINUE
39444      IFOUND='YES'
39445C
39446      IF(IFEEDB.EQ.'OFF')GOTO1189
39447      WRITE(ICOUT,999)
39448  999 FORMAT(1X)
39449      CALL DPWRST('XXX','BUG ')
39450      WRITE(ICOUT,1181)PDIAVG
39451 1181 FORMAT('THE CURSOR SPACING HAS JUST BEEN SET TO ',
39452     1E15.7)
39453      CALL DPWRST('XXX','BUG ')
39454 1189 CONTINUE
39455      GOTO1199
39456C
39457 1199 CONTINUE
39458      RETURN
39459      END
39460      SUBROUTINE DPCUSU(XTEMP1,MAXNXT,
39461     1                  ICASAN,ICAPSW,IFORSW,
39462     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
39463C
39464C     PURPOSE--PERFORM A CUMULATIVE SUM TEST FOR RANDOMNESS
39465C     EXAMPLE--CUMULATIVE SUM TEST Y
39466C     REFERENCE--A STATISTICAL TEST SUITE FOR RANDOM AND PSUEDORANDOM
39467C                NUMBER GENERATORS FOR CRYPTOGRAPHIC APPLICATIONS,
39468C                ANDREW RUKHIN, JUAN SOTO, JAMES NECHVATAL, MILES SMID,
39469C                ELAINE BARKER, STEFAN LEIGH, MARK LEVENSON,
39470C                MARK VANGEL, DAVID BANKS, ALAN HECKERT, JAMES DRAY,
39471C                SAN VO.  NIST SPECIAL PUBLICATION 800-22,
39472C                OCTOBER 2000, PP. 14-16.
39473C     WRITTEN BY--ALAN HECKERT
39474C                 STATISTICAL ENGINEERING DIVISION
39475C                 INFORMATION TECHNOLOGY LABORATORY
39476C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
39477C                 GAITHERSBURG, MD 20899-8980
39478C                 PHONE--301-975-2899
39479C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
39480C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
39481C     LANGUAGE--ANSI FORTRAN (1977)
39482C     VERSION NUMBER--2003/12
39483C     ORIGINAL VERSION--DECEMBER  2003.
39484C     UPDATED         --MARCH     2011. USE DPPARS ROUTINE
39485C     UPATED          --MARCH     2011. REWRITTEN TO HANDLE MULTIPLE
39486C                                       RESPONSE VARIABLES, GROUP-ID
39487C                                       VARIABLES, OR A LAB-ID VARIABLE
39488C     UPATED          --JUNE      2019. TWEAK TO SCRATCH STORAGE
39489C
39490C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
39491C
39492      CHARACTER*4 ICASAN
39493      CHARACTER*4 ICAPSW
39494      CHARACTER*4 IFORSW
39495      CHARACTER*4 IBUGA2
39496      CHARACTER*4 IBUGA3
39497      CHARACTER*4 IBUGQ
39498      CHARACTER*4 ISUBRO
39499      CHARACTER*4 IFOUND
39500      CHARACTER*4 IERROR
39501C
39502      CHARACTER*4 ISUBN1
39503      CHARACTER*4 ISUBN2
39504      CHARACTER*4 ISTEPN
39505      CHARACTER*4 IFLAGU
39506      CHARACTER*4 IREPL
39507      CHARACTER*4 IMULT
39508      CHARACTER*4 ICTMP1
39509      CHARACTER*4 ICTMP2
39510      CHARACTER*4 ICTMP3
39511      CHARACTER*4 ICTMP4
39512      CHARACTER*4 ICASE
39513C
39514      CHARACTER*40 INAME
39515      PARAMETER (MAXSPN=30)
39516      CHARACTER*4 IVARN1(MAXSPN)
39517      CHARACTER*4 IVARN2(MAXSPN)
39518      CHARACTER*4 IVARTY(MAXSPN)
39519      CHARACTER*4 IVARID(1)
39520      CHARACTER*4 IVARI2(1)
39521      REAL PVAR(MAXSPN)
39522      REAL PID(MAXSPN)
39523      INTEGER ILIS(MAXSPN)
39524      INTEGER NRIGHT(MAXSPN)
39525      INTEGER ICOLR(MAXSPN)
39526C
39527      LOGICAL IFRST
39528      LOGICAL ILAST
39529C
39530C---------------------------------------------------------------------
39531C
39532      DIMENSION XTEMP1(*)
39533C
39534C-----COMMON----------------------------------------------------------
39535C
39536      INCLUDE 'DPCOPA.INC'
39537      INCLUDE 'DPCOZZ.INC'
39538C
39539      DIMENSION YTEMP1(MAXOBV)
39540      DIMENSION YTEMP2(MAXOBV)
39541      DIMENSION YTEMP3(MAXOBV)
39542      DIMENSION XDESGN(MAXOBV,7)
39543      DIMENSION XIDTEM(MAXOBV)
39544      DIMENSION XIDTE2(MAXOBV)
39545      DIMENSION XIDTE3(MAXOBV)
39546      DIMENSION XIDTE4(MAXOBV)
39547      DIMENSION XIDTE5(MAXOBV)
39548      DIMENSION XIDTE6(MAXOBV)
39549C
39550      DIMENSION TEMP1(MAXOBV)
39551      DIMENSION TEMP2(MAXOBV)
39552C
39553      EQUIVALENCE (GARBAG(IGARB1),YTEMP1(1))
39554      EQUIVALENCE (GARBAG(IGARB2),YTEMP2(1))
39555      EQUIVALENCE (GARBAG(IGARB3),YTEMP3(1))
39556      EQUIVALENCE (GARBAG(IGARB4),TEMP1(1))
39557      EQUIVALENCE (GARBAG(IGARB5),XIDTEM(1))
39558      EQUIVALENCE (GARBAG(IGARB6),XIDTE2(1))
39559      EQUIVALENCE (GARBAG(IGARB7),XIDTE3(1))
39560      EQUIVALENCE (GARBAG(IGARB8),XIDTE4(1))
39561      EQUIVALENCE (GARBAG(IGARB9),XIDTE5(1))
39562      EQUIVALENCE (GARBAG(IGAR10),XIDTE6(1))
39563      EQUIVALENCE (GARBAG(JGAR11),TEMP2(1))
39564      EQUIVALENCE (GARBAG(JGAR12),XDESGN(1,1))
39565C
39566      INCLUDE 'DPCOHK.INC'
39567      INCLUDE 'DPCOSU.INC'
39568      INCLUDE 'DPCODA.INC'
39569      INCLUDE 'DPCOST.INC'
39570C
39571C-----COMMON VARIABLES (GENERAL)--------------------------------------
39572C
39573      INCLUDE 'DPCOP2.INC'
39574C
39575C-----START POINT-----------------------------------------------------
39576C
39577      IREPL='OFF'
39578      IMULT='OFF'
39579      ISUBN1='DPCU'
39580      ISUBN2='SU  '
39581C
39582      MAXCP1=MAXCOL+1
39583      MAXCP2=MAXCOL+2
39584      MAXCP3=MAXCOL+3
39585      MAXCP4=MAXCOL+4
39586      MAXCP5=MAXCOL+5
39587      MAXCP6=MAXCOL+6
39588C
39589      IFOUND='NO'
39590      IERROR='NO'
39591C
39592C               ********************************************
39593C               **  TREAT THE CUMULATIVE SUM   TEST CASE  **
39594C               ********************************************
39595C
39596      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CUSU')THEN
39597        WRITE(ICOUT,999)
39598  999   FORMAT(1X)
39599        CALL DPWRST('XXX','BUG ')
39600        WRITE(ICOUT,51)
39601   51   FORMAT('***** AT THE BEGINNING OF DPCUSU--')
39602        CALL DPWRST('XXX','BUG ')
39603        WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ,ISUBRO
39604   52   FORMAT('IBUGA2,IBUGA3,IBUGQ,ISUBRO = ',3(A4,2X),A4)
39605        CALL DPWRST('XXX','BUG ')
39606        WRITE(ICOUT,55)IFORSW,ICAPSW,ICAPTY,MAXNXT
39607   55   FORMAT('IFORSW,ICAPSW,ICAPTY,MAXNXT = ',3(A4,2X),I8)
39608        CALL DPWRST('XXX','BUG ')
39609      ENDIF
39610C
39611C               *****************************************************
39612C               **  STEP 1--                                       **
39613C               **  EXTRACT THE COMMAND                            **
39614C               **  LOOK FOR ONE OF THE FOLLOWING COMMANDS:        **
39615C               **    1) CUMULATIVE SUM TEST Y                     **
39616C               **    2) MULTIPLE CUMULATIVE SUM TEST   Y1 ... YK  **
39617C               **    3) REPLICATED CUMULATIVE SUM TEST            **
39618C               **       Y X1 ... XK                               **
39619C               *****************************************************
39620C
39621      ISTEPN='1'
39622      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CUSU')
39623     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
39624C
39625      ILASTC=9999
39626      ILASTZ=9999
39627      ICASAN='CUSU'
39628C
39629C     LOOK FOR:
39630C
39631C          CUMULATIVE SUM TEST
39632C
39633      DO100I=0,NUMARG-1
39634C
39635        IF(I.EQ.0)THEN
39636          ICTMP1=ICOM
39637        ELSE
39638          ICTMP1=IHARG(I)
39639        ENDIF
39640        ICTMP2=IHARG(I+1)
39641        ICTMP3=IHARG(I+2)
39642        ICTMP4=IHARG(I+3)
39643C
39644        IF(ICTMP1.EQ.'=')THEN
39645          IFOUND='NO'
39646          GOTO9000
39647        ELSEIF(ICTMP1.EQ.'CUMU' .AND. ICTMP2.EQ.'SUM ' .AND.
39648     1         ICTMP3.EQ.'TEST')THEN
39649          IFOUND='YES'
39650          ICASAN='CUSU'
39651          ILASTC=I
39652          ILASTZ=I+2
39653        ELSEIF(ICTMP1.EQ.'REPL')THEN
39654          IREPL='ON'
39655          ILASTC=MIN(ILASTC,I)
39656          ILASTZ=MAX(ILASTZ,I)
39657        ELSEIF(ICTMP1.EQ.'MULT')THEN
39658          IMULT='ON'
39659          ILASTC=MIN(ILASTC,I)
39660          ILASTZ=MAX(ILASTZ,I)
39661        ENDIF
39662  100 CONTINUE
39663C
39664      IF(IFOUND.EQ.'NO')GOTO9000
39665C
39666      ISHIFT=ILASTZ
39667      CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
39668     1            IBUGA2,IERROR)
39669C
39670      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CUSU')THEN
39671        WRITE(ICOUT,91)ICASAN,IMULT,IREPL,ISHIFT
39672   91   FORMAT('DPCUSU: ICASAN,IMULT,IREPL,ISHIFT = ',3(A4,2X),I5)
39673        CALL DPWRST('XXX','BUG ')
39674      ENDIF
39675C
39676      IF(IMULT.EQ.'ON')THEN
39677        IF(IREPL.EQ.'ON')THEN
39678          WRITE(ICOUT,999)
39679          CALL DPWRST('XXX','BUG ')
39680          WRITE(ICOUT,101)
39681  101     FORMAT('***** ERROR IN CUMULATIVE SUM TEST--')
39682          CALL DPWRST('XXX','BUG ')
39683          WRITE(ICOUT,103)
39684  103     FORMAT('      YOU CANNOT SPECIFY BOTH "MULTIPLE" AND ',
39685     1           '"REPLICATION"')
39686          CALL DPWRST('XXX','BUG ')
39687          WRITE(ICOUT,104)
39688  104     FORMAT('      FOR THE CUMULATIVE SUM TEST COMMAND.')
39689          CALL DPWRST('XXX','BUG ')
39690          IERROR='YES'
39691          GOTO9000
39692        ENDIF
39693      ENDIF
39694C
39695C               *********************************
39696C               **  STEP 4--                   **
39697C               **  EXTRACT THE VARIABLE LIST  **
39698C               *********************************
39699C
39700      ISTEPN='4'
39701      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CUSU')
39702     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
39703C
39704      INAME='CUMULATIVE SUM TEST'
39705      MINNA=1
39706      MAXNA=100
39707      MINN2=2
39708      IFLAGE=0
39709      IFLAGM=1
39710      IF(IREPL.EQ.'ON')THEN
39711        IFLAGM=0
39712        IFLAGE=1
39713      ENDIF
39714      IFLAGP=0
39715      JMIN=1
39716      JMAX=NUMARG
39717      MINNVA=1
39718      MAXNVA=MAXSPN
39719C
39720      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
39721     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
39722     1            JMIN,JMAX,
39723     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
39724     1            IVARN1,IVARN2,IVARTY,PVAR,
39725     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
39726     1            MINNVA,MAXNVA,
39727     1            IFLAGM,IFLAGP,
39728     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
39729      IF(IERROR.EQ.'YES')GOTO9000
39730C
39731      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CUSU')THEN
39732        WRITE(ICOUT,999)
39733        CALL DPWRST('XXX','BUG ')
39734        WRITE(ICOUT,281)
39735  281   FORMAT('***** AFTER CALL DPPARS--')
39736        CALL DPWRST('XXX','BUG ')
39737        WRITE(ICOUT,282)NQ,NUMVAR
39738  282   FORMAT('NQ,NUMVAR = ',2I8)
39739        CALL DPWRST('XXX','BUG ')
39740        IF(NUMVAR.GT.0)THEN
39741          DO285I=1,NUMVAR
39742            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
39743     1                      ICOLR(I)
39744  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
39745     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
39746            CALL DPWRST('XXX','BUG ')
39747  285     CONTINUE
39748        ENDIF
39749      ENDIF
39750C
39751C               ***********************************************
39752C               **  STEP 5--                                 **
39753C               **  DETERMINE:                               **
39754C               **  1) NUMBER OF REPLICATION VARIABLES (0-6) **
39755C               **  2) NUMBER OF RESPONSE    VARIABLES (>= 1)**
39756C               ***********************************************
39757C
39758      ISTEPN='5'
39759      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CUSU')
39760     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
39761C
39762      NRESP=0
39763      NREPL=0
39764      IF(IMULT.EQ.'ON')THEN
39765        NRESP=NUMVAR
39766      ELSEIF(IREPL.EQ.'ON')THEN
39767        NRESP=1
39768        NREPL=NUMVAR-NRESP
39769        IF(NREPL.LT.1 .OR. NREPL.GT.6)THEN
39770          WRITE(ICOUT,999)
39771          CALL DPWRST('XXX','BUG ')
39772          WRITE(ICOUT,101)
39773          CALL DPWRST('XXX','BUG ')
39774          WRITE(ICOUT,511)
39775  511     FORMAT('      FOR THE REPLICATION CASE, THE NUMBER OF ',
39776     1           'REPLICATION VARIABLES')
39777          CALL DPWRST('XXX','BUG ')
39778          WRITE(ICOUT,512)
39779  512     FORMAT('      MUST BE BETWEEN ONE AND SIX.')
39780          CALL DPWRST('XXX','BUG ')
39781          WRITE(ICOUT,513)NREPL
39782  513     FORMAT('      THE NUMBER OF REPLICATION VARIABLES = ',I5)
39783          CALL DPWRST('XXX','BUG ')
39784          IERROR='YES'
39785          GOTO9000
39786        ENDIF
39787      ELSE
39788        NRESP=NUMVAR
39789        IMULT='ON'
39790      ENDIF
39791C
39792      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CUSU')THEN
39793        WRITE(ICOUT,521)NRESP,NREPL
39794  521   FORMAT('NRESP,NREPL = ',2I5)
39795        CALL DPWRST('XXX','BUG ')
39796      ENDIF
39797C
39798C               ******************************************************
39799C               **  STEP 6--                                        **
39800C               **  GENERATE THE CUMULATIVE SUM   TEST FOR THE      **
39801C               **  VARIOUS CASES                                   **
39802C               ******************************************************
39803C
39804      ISTEPN='6'
39805      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CUSU')
39806     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
39807C
39808C               ******************************************
39809C               **  STEP 8A--                           **
39810C               **  CASE 1: NO REPLICATION VARIABLES    **
39811C               ******************************************
39812C
39813      IF(NREPL.LT.1)THEN
39814        ISTEPN='8A'
39815        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CUSU')
39816     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
39817C
39818C       LOOP THROUGH EACH OF THE RESPONSE VARIABLES
39819C
39820        NCURVE=0
39821        DO810IRESP=1,NRESP
39822          NCURVE=NCURVE+1
39823C
39824          IINDX=ICOLR(IRESP)
39825          PID(1)=CPUMIN
39826          IVARID(1)=IVARN1(IRESP)
39827          IVARI2(1)=IVARN2(IRESP)
39828C
39829          IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CUSU')THEN
39830            WRITE(ICOUT,999)
39831            CALL DPWRST('XXX','BUG ')
39832            WRITE(ICOUT,811)IRESP,NCURVE
39833  811       FORMAT('IRESP,NCURVE = ',2I5)
39834            CALL DPWRST('XXX','BUG ')
39835          ENDIF
39836C
39837          ICOL=IRESP
39838          NUMVA2=1
39839          CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
39840     1                INAME,IVARN1,IVARN2,IVARTY,
39841     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
39842     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
39843     1                MAXCP4,MAXCP5,MAXCP6,
39844     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
39845     1                Y,XTEMP1,XTEMP1,NS1,NLOCA2,NLOCA3,ICASE,
39846     1                IBUGA3,ISUBRO,IFOUND,IERROR)
39847          IF(IERROR.EQ.'YES')GOTO9000
39848C
39849C         *****************************************************
39850C         **  STEP 8B--                                      **
39851C         *****************************************************
39852C
39853          IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CUSU')THEN
39854            ISTEPN='8B'
39855            CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
39856            WRITE(ICOUT,999)
39857            CALL DPWRST('XXX','BUG ')
39858            WRITE(ICOUT,822)
39859  822       FORMAT('***** FROM THE MIDDLE  OF DPFRTE--')
39860            CALL DPWRST('XXX','BUG ')
39861            WRITE(ICOUT,823)ICASAN,NUMVAR,NS1
39862  823       FORMAT('ICASAN,NUMVAR,NS1 = ',A4,2I8)
39863            CALL DPWRST('XXX','BUG ')
39864            IF(NS1.GE.1)THEN
39865              DO825I=1,NS1
39866                WRITE(ICOUT,826)I,Y(I)
39867  826           FORMAT('I,Y(I) = ',I8,G15.7)
39868                CALL DPWRST('XXX','BUG ')
39869  825         CONTINUE
39870            ENDIF
39871          ENDIF
39872C
39873          CALL DPCUS2(Y,NS1,
39874     1                XTEMP1,MAXNXT,
39875     1                ICAPSW,ICAPTY,IFORSW,ICASAN,M,
39876     1                PID,IVARID,IVARI2,NREPL,
39877     1                STATVA,STATV2,PVAL1,PVAL2,
39878     1                YTEMP1,
39879     1                ISUBRO,IBUGA3,IERROR)
39880C
39881C               ***************************************
39882C               **  STEP 61--                        **
39883C               **  UPDATE INTERNAL DATAPLOT TABLES  **
39884C               ***************************************
39885C
39886          ISTEPN='8C'
39887          IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CUSU')
39888     1      CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
39889C
39890          IF(NRESP.GT.1)THEN
39891            IFLAGU='FILE'
39892          ELSE
39893            IFLAGU='ON'
39894          ENDIF
39895          IFRST=.FALSE.
39896          ILAST=.FALSE.
39897          IF(IRESP.EQ.1)IFRST=.TRUE.
39898          IF(IRESP.EQ.NRESP)ILAST=.TRUE.
39899          CALL DPCUS5(STATVA,STATV2,PVAL1,PVAL2,
39900     1                IFLAGU,IFRST,ILAST,
39901     1                IBUGA2,IBUGA3,ISUBRO,IERROR)
39902  810   CONTINUE
39903C
39904C               ****************************************************
39905C               **  STEP 9A--                                     **
39906C               **  CASE 3: ONE OR MORE REPLICATION VARIABLES.    **
39907C               **          FOR THIS CASE, THE NUMBER OF RESPONSE **
39908C               **          VARIABLES MUST BE EXACTLY 1.          **
39909C               **          FOR THIS CASE, ALL VARIABLES MUST     **
39910C               **          HAVE THE SAME LENGTH.                 **
39911C               ****************************************************
39912C
39913      ELSEIF(NREPL.GE.1)THEN
39914        ISTEPN='9A'
39915        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CUSU')
39916     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
39917C
39918        J=0
39919        IMAX=NRIGHT(1)
39920        IF(NQ.LT.NRIGHT(1))IMAX=NQ
39921        DO910I=1,IMAX
39922          IF(ISUB(I).EQ.0)GOTO910
39923          J=J+1
39924C
39925C         RESPONSE VARIABLE IN Y
39926C
39927          ICOLC=1
39928          IJ=MAXN*(ICOLR(ICOLC)-1)+I
39929          IF(ICOLR(ICOLC).LE.MAXCOL)Y(J)=V(IJ)
39930          IF(ICOLR(ICOLC).EQ.MAXCP1)Y(J)=PRED(I)
39931          IF(ICOLR(ICOLC).EQ.MAXCP2)Y(J)=RES(I)
39932          IF(ICOLR(ICOLC).EQ.MAXCP3)Y(J)=YPLOT(I)
39933          IF(ICOLR(ICOLC).EQ.MAXCP4)Y(J)=XPLOT(I)
39934          IF(ICOLR(ICOLC).EQ.MAXCP5)Y(J)=X2PLOT(I)
39935          IF(ICOLR(ICOLC).EQ.MAXCP6)Y(J)=TAGPLO(I)
39936C
39937          IF(NREPL.GE.1)THEN
39938            DO920IR=1,MIN(NREPL,6)
39939              ICOLC=ICOLC+1
39940              ICOLT=ICOLR(ICOLC)
39941              IJ=MAXN*(ICOLT-1)+I
39942              IF(ICOLT.LE.MAXCOL)XDESGN(J,IR)=V(IJ)
39943              IF(ICOLT.EQ.MAXCP1)XDESGN(J,IR)=PRED(I)
39944              IF(ICOLT.EQ.MAXCP2)XDESGN(J,IR)=RES(I)
39945              IF(ICOLT.EQ.MAXCP3)XDESGN(J,IR)=YPLOT(I)
39946              IF(ICOLT.EQ.MAXCP4)XDESGN(J,IR)=XPLOT(I)
39947              IF(ICOLT.EQ.MAXCP5)XDESGN(J,IR)=X2PLOT(I)
39948              IF(ICOLT.EQ.MAXCP6)XDESGN(J,IR)=TAGPLO(I)
39949  920       CONTINUE
39950          ENDIF
39951C
39952  910   CONTINUE
39953        NLOCAL=J
39954C
39955C       *****************************************************
39956C       **  STEP 9B--                                      **
39957C       **  CALL DPCUS2 TO PERFORM CUMULATIVE SUM TEST.    **
39958C       *****************************************************
39959C
39960C
39961        IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CUSU')THEN
39962          ISTEPN='9C'
39963          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
39964          WRITE(ICOUT,999)
39965          CALL DPWRST('XXX','BUG ')
39966          WRITE(ICOUT,941)
39967  941     FORMAT('***** FROM THE MIDDLE  OF DPCUSU--')
39968          CALL DPWRST('XXX','BUG ')
39969          WRITE(ICOUT,942)ICASAN,NUMVAR,NLOCAL,NREPL
39970  942     FORMAT('ICASAN,NUMVAR,NLOCAL,NREPL = ',
39971     1           A4,3I8)
39972          CALL DPWRST('XXX','BUG ')
39973          IF(NLOCAL.GE.1)THEN
39974            DO945I=1,NLOCAL
39975              WRITE(ICOUT,946)I,Y(I),XDESGN(I,1),XDESGN(I,2)
39976  946         FORMAT('I,Y(I),XDESGN(I,1),XDESGN(I,2) = ',
39977     1               I8,4F12.5)
39978              CALL DPWRST('XXX','BUG ')
39979  945       CONTINUE
39980          ENDIF
39981        ENDIF
39982C
39983C       *****************************************************
39984C       **  STEP 9C--                                      **
39985C       **  FIND THE DISTINCT VALUES IN EACH OF THE        **
39986C       **  REPLICATION VARIABLES.                         **
39987C       *****************************************************
39988C
39989        CALL DPPP5(XDESGN(1,1),XDESGN(1,2),XDESGN(1,3),
39990     1             XDESGN(1,4),XDESGN(1,5),XDESGN(1,6),
39991     1             NREPL,NLOCAL,MAXOBV,
39992     1             XIDTEM,XIDTE2,XIDTE3,XIDTE4,XIDTE5,XIDTE6,
39993     1             XTEMP1,TEMP2,
39994     1             NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,NUMSE6,
39995     1             IBUGA3,ISUBRO,IERROR)
39996C
39997C       *****************************************************
39998C       **  STEP 9D--                                      **
39999C       **  NOW LOOP THROUGH THE VARIOUS REPLICATIONS      **
40000C       *****************************************************
40001C
40002        NCURVE=0
40003        IADD=1
40004C
40005        IF(NREPL.EQ.1)THEN
40006          J=0
40007          DO1110ISET1=1,NUMSE1
40008            K=0
40009            PID(IADD+1)=XIDTEM(ISET1)
40010            DO1130I=1,NLOCAL
40011              IF(XIDTEM(ISET1).EQ.XDESGN(I,1))THEN
40012                K=K+1
40013                TEMP1(K)=Y(I)
40014              ENDIF
40015 1130       CONTINUE
40016            NTEMP=K
40017            NCURVE=NCURVE+1
40018            IF(NTEMP.GT.0)THEN
40019              CALL DPCUS2(TEMP1,NTEMP,
40020     1                    XTEMP1,MAXNXT,
40021     1                    ICAPSW,ICAPTY,IFORSW,ICASAN,M,
40022     1                    PID,IVARID,IVARI2,NREPL,
40023     1                    STATVA,STATV2,PVAL1,PVAL2,
40024     1                    YTEMP1,
40025     1                    ISUBRO,IBUGA3,IERROR)
40026            ENDIF
40027            IFLAGU='FILE'
40028            IFRST=.FALSE.
40029            ILAST=.FALSE.
40030            IF(NCURVE.EQ.1)IFRST=.TRUE.
40031            IF(NCURVE.EQ.NUMSE1)ILAST=.TRUE.
40032            CALL DPCUS5(STATVA,STATV2,PVAL1,PVAL2,
40033     1                  IFLAGU,IFRST,ILAST,
40034     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
40035 1110     CONTINUE
40036        ELSEIF(NREPL.EQ.2)THEN
40037          J=0
40038          NTOT=NUMSE1*NUMSE2
40039          DO1210ISET1=1,NUMSE1
40040          DO1220ISET2=1,NUMSE2
40041            K=0
40042            PID(1+IADD)=XIDTEM(ISET1)
40043            PID(2+IADD)=XIDTE2(ISET2)
40044            DO1290I=1,NLOCAL
40045              IF(
40046     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
40047     1           XIDTE2(ISET2).EQ.XDESGN(I,2)
40048     1          )THEN
40049                K=K+1
40050                TEMP1(K)=Y(I)
40051              ENDIF
40052 1290       CONTINUE
40053            NTEMP=K
40054            NCURVE=NCURVE+1
40055            IF(NTEMP.GT.0)THEN
40056              CALL DPCUS2(TEMP1,NTEMP,
40057     1                    XTEMP1,MAXNXT,
40058     1                    ICAPSW,ICAPTY,IFORSW,ICASAN,M,
40059     1                    PID,IVARID,IVARI2,NREPL,
40060     1                    STATVA,STATV2,PVAL1,PVAL2,
40061     1                    YTEMP1,
40062     1                    ISUBRO,IBUGA3,IERROR)
40063              IFLAGU='FILE'
40064              IFRST=.FALSE.
40065              ILAST=.FALSE.
40066              IF(NCURVE.EQ.1)IFRST=.TRUE.
40067              IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
40068              CALL DPCUS5(STATVA,STATV2,PVAL1,PVAL2,
40069     1                    IFLAGU,IFRST,ILAST,
40070     1                    IBUGA2,IBUGA3,ISUBRO,IERROR)
40071            ENDIF
40072 1220     CONTINUE
40073 1210     CONTINUE
40074        ELSEIF(NREPL.EQ.3)THEN
40075          J=0
40076          NTOT=NUMSE1*NUMSE2*NUMSE3
40077          DO1310ISET1=1,NUMSE1
40078          DO1320ISET2=1,NUMSE2
40079          DO1330ISET3=1,NUMSE3
40080            K=0
40081            PID(1+IADD)=XIDTEM(ISET1)
40082            PID(2+IADD)=XIDTE2(ISET2)
40083            PID(3+IADD)=XIDTE3(ISET3)
40084            DO1390I=1,NLOCAL
40085              IF(
40086     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
40087     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
40088     1           XIDTE3(ISET3).EQ.XDESGN(I,3)
40089     1          )THEN
40090                K=K+1
40091                TEMP1(K)=Y(I)
40092              ENDIF
40093 1390       CONTINUE
40094            NTEMP=K
40095            NCURVE=NCURVE+1
40096            NPLOT1=NPLOTP
40097            IF(NTEMP.GT.0)THEN
40098              CALL DPCUS2(TEMP1,NTEMP,
40099     1                    XTEMP1,MAXNXT,
40100     1                    ICAPSW,ICAPTY,IFORSW,ICASAN,M,
40101     1                    PID,IVARID,IVARI2,NREPL,
40102     1                    STATVA,STATV2,PVAL1,PVAL2,
40103     1                    YTEMP1,
40104     1                    ISUBRO,IBUGA3,IERROR)
40105              IFLAGU='FILE'
40106              IFRST=.FALSE.
40107              ILAST=.FALSE.
40108              IF(NCURVE.EQ.1)IFRST=.TRUE.
40109              IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
40110              CALL DPCUS5(STATVA,STATV2,PVAL1,PVAL2,
40111     1                    IFLAGU,IFRST,ILAST,
40112     1                    IBUGA2,IBUGA3,ISUBRO,IERROR)
40113            ENDIF
40114 1330     CONTINUE
40115 1320     CONTINUE
40116 1310     CONTINUE
40117        ELSEIF(NREPL.EQ.4)THEN
40118          J=0
40119          NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4
40120          DO1410ISET1=1,NUMSE1
40121          DO1420ISET2=1,NUMSE2
40122          DO1430ISET3=1,NUMSE3
40123          DO1440ISET4=1,NUMSE4
40124            K=0
40125            PID(1+IADD)=XIDTEM(ISET1)
40126            PID(2+IADD)=XIDTE2(ISET2)
40127            PID(3+IADD)=XIDTE3(ISET3)
40128            PID(4+IADD)=XIDTE4(ISET4)
40129            DO1490I=1,NLOCAL
40130              IF(
40131     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
40132     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
40133     1           XIDTE3(ISET3).EQ.XDESGN(I,3) .AND.
40134     1           XIDTE4(ISET4).EQ.XDESGN(I,4)
40135     1          )THEN
40136                K=K+1
40137                TEMP1(K)=Y(I)
40138              ENDIF
40139 1490       CONTINUE
40140            NTEMP=K
40141            NCURVE=NCURVE+1
40142            NPLOT1=NPLOTP
40143            IF(NTEMP.GT.0)THEN
40144              CALL DPCUS2(TEMP1,NTEMP,
40145     1                    XTEMP1,MAXNXT,
40146     1                    ICAPSW,ICAPTY,IFORSW,ICASAN,M,
40147     1                    PID,IVARID,IVARI2,NREPL,
40148     1                    STATVA,STATV2,PVAL1,PVAL2,
40149     1                    YTEMP1,
40150     1                    ISUBRO,IBUGA3,IERROR)
40151              IFLAGU='FILE'
40152              IFRST=.FALSE.
40153              ILAST=.FALSE.
40154              IF(NCURVE.EQ.1)IFRST=.TRUE.
40155              IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
40156              CALL DPCUS5(STATVA,STATV2,PVAL1,PVAL2,
40157     1                    IFLAGU,IFRST,ILAST,
40158     1                    IBUGA2,IBUGA3,ISUBRO,IERROR)
40159            ENDIF
40160 1440     CONTINUE
40161 1430     CONTINUE
40162 1420     CONTINUE
40163 1410     CONTINUE
40164        ELSEIF(NREPL.EQ.5)THEN
40165          J=0
40166          NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5
40167          DO1510ISET1=1,NUMSE1
40168          DO1520ISET2=1,NUMSE2
40169          DO1530ISET3=1,NUMSE3
40170          DO1540ISET4=1,NUMSE4
40171          DO1550ISET5=1,NUMSE5
40172            K=0
40173            PID(1+IADD)=XIDTEM(ISET1)
40174            PID(2+IADD)=XIDTE2(ISET2)
40175            PID(3+IADD)=XIDTE3(ISET3)
40176            PID(4+IADD)=XIDTE4(ISET4)
40177            PID(5+IADD)=XIDTE5(ISET4)
40178            DO1590I=1,NLOCAL
40179              IF(
40180     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
40181     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
40182     1           XIDTE3(ISET3).EQ.XDESGN(I,3) .AND.
40183     1           XIDTE4(ISET4).EQ.XDESGN(I,4) .AND.
40184     1           XIDTE5(ISET5).EQ.XDESGN(I,5)
40185     1          )THEN
40186                K=K+1
40187                TEMP1(K)=Y(I)
40188              ENDIF
40189 1590       CONTINUE
40190            NTEMP=K
40191            NCURVE=NCURVE+1
40192            NPLOT1=NPLOTP
40193            IF(NTEMP.GT.0)THEN
40194              CALL DPCUS2(TEMP1,NTEMP,
40195     1                    XTEMP1,MAXNXT,
40196     1                    ICAPSW,ICAPTY,IFORSW,ICASAN,M,
40197     1                    PID,IVARID,IVARI2,NREPL,
40198     1                    STATVA,STATV2,PVAL1,PVAL2,
40199     1                    YTEMP1,
40200     1                    ISUBRO,IBUGA3,IERROR)
40201              IFLAGU='FILE'
40202              IFRST=.FALSE.
40203              ILAST=.FALSE.
40204              IF(NCURVE.EQ.1)IFRST=.TRUE.
40205              IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
40206              CALL DPCUS5(STATVA,STATV2,PVAL1,PVAL2,
40207     1                    IFLAGU,IFRST,ILAST,
40208     1                    IBUGA2,IBUGA3,ISUBRO,IERROR)
40209            ENDIF
40210 1550     CONTINUE
40211 1540     CONTINUE
40212 1530     CONTINUE
40213 1520     CONTINUE
40214 1510     CONTINUE
40215        ELSEIF(NREPL.EQ.6)THEN
40216          J=0
40217          NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5*NUMSE6
40218          DO1610ISET1=1,NUMSE1
40219          DO1620ISET2=1,NUMSE2
40220          DO1630ISET3=1,NUMSE3
40221          DO1640ISET4=1,NUMSE4
40222          DO1650ISET5=1,NUMSE5
40223          DO1660ISET6=1,NUMSE6
40224            K=0
40225            PID(1+IADD)=XIDTEM(ISET1)
40226            PID(2+IADD)=XIDTE2(ISET2)
40227            PID(3+IADD)=XIDTE3(ISET3)
40228            PID(4+IADD)=XIDTE4(ISET4)
40229            PID(5+IADD)=XIDTE5(ISET4)
40230            PID(6+IADD)=XIDTE6(ISET4)
40231            DO1690I=1,NLOCAL
40232              IF(
40233     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
40234     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
40235     1           XIDTE3(ISET3).EQ.XDESGN(I,3) .AND.
40236     1           XIDTE4(ISET4).EQ.XDESGN(I,4) .AND.
40237     1           XIDTE5(ISET5).EQ.XDESGN(I,5) .AND.
40238     1           XIDTE6(ISET6).EQ.XDESGN(I,6)
40239     1          )THEN
40240                K=K+1
40241                TEMP1(K)=Y(I)
40242              ENDIF
40243 1690       CONTINUE
40244            NTEMP=K
40245            NCURVE=NCURVE+1
40246            NPLOT1=NPLOTP
40247            IF(NTEMP.GT.0)THEN
40248              CALL DPCUS2(TEMP1,NTEMP,
40249     1                    XTEMP1,MAXNXT,
40250     1                    ICAPSW,ICAPTY,IFORSW,ICASAN,M,
40251     1                    PID,IVARID,IVARI2,NREPL,
40252     1                    STATVA,STATV2,PVAL1,PVAL2,
40253     1                    YTEMP1,
40254     1                    ISUBRO,IBUGA3,IERROR)
40255              IFLAGU='FILE'
40256              IFRST=.FALSE.
40257              ILAST=.FALSE.
40258              IF(NCURVE.EQ.1)IFRST=.TRUE.
40259              IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
40260              CALL DPCUS5(STATVA,STATV2,PVAL1,PVAL2,
40261     1                    IFLAGU,IFRST,ILAST,
40262     1                    IBUGA2,IBUGA3,ISUBRO,IERROR)
40263            ENDIF
40264 1660     CONTINUE
40265 1650     CONTINUE
40266 1640     CONTINUE
40267 1630     CONTINUE
40268 1620     CONTINUE
40269 1610     CONTINUE
40270        ENDIF
40271C
40272      ENDIF
40273C
40274C               *****************
40275C               **  STEP 90--  **
40276C               **  EXIT       **
40277C               *****************
40278C
40279 9000 CONTINUE
40280      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CUSU')THEN
40281        WRITE(ICOUT,999)
40282        CALL DPWRST('XXX','BUG ')
40283        WRITE(ICOUT,9011)
40284 9011   FORMAT('***** AT THE END       OF DPCUSU--')
40285        CALL DPWRST('XXX','BUG ')
40286        WRITE(ICOUT,9016)IFOUND,IERROR
40287 9016   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
40288        CALL DPWRST('XXX','BUG ')
40289      ENDIF
40290C
40291      RETURN
40292      END
40293      SUBROUTINE DPCUS2(Y,N,
40294     1                  XTEMP,MAXNXT,
40295     1                  ICAPSW,ICAPTY,IFORSW,ICASAN,M,
40296     1                  PID,IVARID,IVARI2,NREPL,
40297     1                  STATVA,STATV2,PVAL1,PVAL2,
40298     1                  YTEMP1,
40299     1                  ISUBRO,IBUGA3,IERROR)
40300C
40301C     PURPOSE--THIS ROUTINE CARRIES OUT THE CUMULATIVE SUM TEST
40302C              FOR RANDOMNESS.
40303C     EXAMPLE--CUMULATIVE SUM TEST Y
40304C     REFERENCE--A STATISTICAL TEST SUITE FOR RANDOM AND PSUEDORANDOM
40305C                NUMBER GENERATORS FOR CRYPTOGRAPHIC APPLICATIONS,
40306C                ANDREW RUKHIN, JUAN SOTO, JAMES NECHVATAL, MILES SMID,
40307C                ELAINE BARKER, STEFAN LEIGH, MARK LEVENSON,
40308C                MARK VANGEL, DAVID BANKS, ALAN HECKERT, JAMES DRAY,
40309C                SAN VO.  NIST SPECIAL PUBLICATION 800-22,
40310C                OCTOBER 2000, PP. 14-18.
40311C     WRITTEN BY--ALAN HECKERT
40312C                 STATISTICAL ENGINEERING DIVISION
40313C                 INFORMATION TECHNOLOGY LABORATORY
40314C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
40315C                 GAITHERSBURG, MD 20899-8980
40316C                 PHONE--301-975-2899
40317C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
40318C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
40319C     LANGUAGE--ANSI FORTRAN (1977)
40320C     VERSION NUMBER--2003/12
40321C     ORIGINAL VERSION--DECEMBER  2003.
40322C     UPDATED         --MARCH     2011. USE DPDTA1 AND DPDTA5 TO PRINT
40323C                                       TABLES
40324C
40325C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
40326C
40327      CHARACTER*4 IVARID(*)
40328      CHARACTER*4 IVARI2(*)
40329C
40330      CHARACTER*4 ICAPSW
40331      CHARACTER*4 ICAPTY
40332      CHARACTER*4 IFORSW
40333      CHARACTER*4 ICASAN
40334C
40335      CHARACTER*4 ISUBRO
40336      CHARACTER*4 IBUGA3
40337      CHARACTER*4 IERROR
40338      CHARACTER*4 ISUBN1
40339      CHARACTER*4 ISUBN2
40340      CHARACTER*4 ISTEPN
40341C
40342C---------------------------------------------------------------------
40343C
40344      DIMENSION Y(*)
40345      DIMENSION XTEMP(*)
40346      DIMENSION YTEMP1(*)
40347      DIMENSION PID(*)
40348C
40349      PARAMETER (NUMALP=7)
40350C
40351      PARAMETER(NUMCLI=4)
40352      PARAMETER(MAXLIN=3)
40353      PARAMETER (MAXROW=NUMALP)
40354      PARAMETER (MAXRO2=20)
40355      CHARACTER*60 ITITLE
40356      CHARACTER*60 ITITLZ
40357      CHARACTER*1  ITITL9
40358      CHARACTER*60 ITEXT(MAXRO2)
40359      CHARACTER*4  ALIGN(NUMCLI)
40360      CHARACTER*4  VALIGN(NUMCLI)
40361      REAL         AVALUE(MAXRO2)
40362      INTEGER      NCTEXT(MAXRO2)
40363      INTEGER      IDIGIT(MAXRO2)
40364      INTEGER      NTOT(MAXRO2)
40365      CHARACTER*60 ITITL2(MAXLIN,NUMCLI)
40366      CHARACTER*15 IVALUE(MAXROW,NUMCLI)
40367      CHARACTER*4  ITYPCO(NUMCLI)
40368      INTEGER      NCTIT2(MAXLIN,NUMCLI)
40369      INTEGER      NCVALU(MAXROW,NUMCLI)
40370      INTEGER      IWHTML(NUMCLI)
40371      INTEGER      IWRTF(NUMCLI)
40372      REAL         AMAT(MAXROW,NUMCLI)
40373      LOGICAL IFRST
40374      LOGICAL ILAST
40375      LOGICAL IFLAGS
40376      LOGICAL IFLAGE
40377C
40378C---------------------------------------------------------------------
40379C
40380      INCLUDE 'DPCOP2.INC'
40381C
40382C-----START POINT-----------------------------------------------------
40383C
40384      ISUBN1='DPCU'
40385      ISUBN2='S2  '
40386      IERROR='NO'
40387C
40388      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CUS2')THEN
40389        WRITE(ICOUT,999)
40390  999   FORMAT(1X)
40391        CALL DPWRST('XXX','BUG ')
40392        WRITE(ICOUT,51)
40393   51   FORMAT('**** AT THE BEGINNING OF DPCUS2--')
40394        CALL DPWRST('XXX','BUG ')
40395        WRITE(ICOUT,52)ICASAN,IBUGA3,ISUBRO,N,M,MAXNXT
40396   52   FORMAT('ICASAN,IBUGA3,ISUBRO,N,M,MAXNXT = ',3(A4,2X),3I8)
40397        CALL DPWRST('XXX','BUG ')
40398        DO56I=1,N
40399          WRITE(ICOUT,57)I,Y(I)
40400   57     FORMAT('I,Y(I) = ',I8,G15.7)
40401          CALL DPWRST('XXX','BUG ')
40402   56   CONTINUE
40403      ENDIF
40404C
40405      CALL DPCUS3(Y,N,
40406     1            STATVA,STATV2,STATCD,STATC2,PVAL1,PVAL2,
40407     1            YTEMP1,
40408     1            ISUBRO,IBUGA3,IERROR)
40409C
40410C               *********************************
40411C               **   STEP 52--                 **
40412C               **   WRITE OUT EVERYTHING      **
40413C               **   FOR CUMULATIVE SUM TEST   **
40414C               *********************************
40415C
40416      ISTEPN='52'
40417      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CUS2')
40418     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
40419C
40420      IF(IPRINT.EQ.'OFF')GOTO9000
40421C
40422      NUMDIG=7
40423      IF(IFORSW.EQ.'1')NUMDIG=1
40424      IF(IFORSW.EQ.'2')NUMDIG=2
40425      IF(IFORSW.EQ.'3')NUMDIG=3
40426      IF(IFORSW.EQ.'4')NUMDIG=4
40427      IF(IFORSW.EQ.'5')NUMDIG=5
40428      IF(IFORSW.EQ.'6')NUMDIG=6
40429      IF(IFORSW.EQ.'7')NUMDIG=7
40430      IF(IFORSW.EQ.'8')NUMDIG=8
40431      IF(IFORSW.EQ.'9')NUMDIG=9
40432      IF(IFORSW.EQ.'0')NUMDIG=0
40433      IF(IFORSW.EQ.'E')NUMDIG=-2
40434      IF(IFORSW.EQ.'-2')NUMDIG=-2
40435      IF(IFORSW.EQ.'-3')NUMDIG=-3
40436      IF(IFORSW.EQ.'-4')NUMDIG=-4
40437      IF(IFORSW.EQ.'-5')NUMDIG=-5
40438      IF(IFORSW.EQ.'-6')NUMDIG=-6
40439      IF(IFORSW.EQ.'-7')NUMDIG=-7
40440      IF(IFORSW.EQ.'-8')NUMDIG=-8
40441      IF(IFORSW.EQ.'-9')NUMDIG=-9
40442C
40443      ITITLE='Cumulative Sum Test for Randomness'
40444      NCTITL=34
40445      ITITLZ=' '
40446      NCTITZ=0
40447C
40448      ICNT=1
40449      ITEXT(ICNT)=' '
40450      NCTEXT(ICNT)=0
40451      AVALUE(ICNT)=0.0
40452      IDIGIT(ICNT)=-1
40453C
40454      ICNT=ICNT+1
40455      ITEXT(ICNT)='Response Variable: '
40456      WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1)(1:4)
40457      WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1)(1:4)
40458      NCTEXT(ICNT)=27
40459      AVALUE(ICNT)=0.0
40460      IDIGIT(ICNT)=-1
40461C
40462      IF(NREPL.GT.0)THEN
40463        IADD=1
40464        DO6101I=1,NREPL
40465          ICNT=ICNT+1
40466          ITEMP=I+IADD
40467          ITEXT(ICNT)='Factor Variable  : '
40468          WRITE(ITEXT(ICNT)(17:17),'(I1)')I
40469          WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(ITEMP)(1:4)
40470          WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(ITEMP)(1:4)
40471          NCTEXT(ICNT)=27
40472          AVALUE(ICNT)=PID(ITEMP)
40473          IDIGIT(ICNT)=NUMDIG
40474 6101   CONTINUE
40475      ENDIF
40476C
40477      ICNT=ICNT+1
40478      ITEXT(ICNT)=' '
40479      NCTEXT(ICNT)=1
40480      AVALUE(ICNT)=0.0
40481      IDIGIT(ICNT)=-1
40482C
40483      ICNT=ICNT+1
40484      ITEXT(ICNT)='H0: The Data Are Random'
40485      NCTEXT(ICNT)=23
40486      AVALUE(ICNT)=0.0
40487      IDIGIT(ICNT)=-1
40488      ICNT=ICNT+1
40489      ITEXT(ICNT)='Ha: The Data Are Not Random'
40490      NCTEXT(ICNT)=27
40491      AVALUE(ICNT)=0.0
40492      IDIGIT(ICNT)=-1
40493C
40494      ICNT=ICNT+1
40495      ITEXT(ICNT)=' '
40496      NCTEXT(ICNT)=1
40497      AVALUE(ICNT)=0.0
40498      IDIGIT(ICNT)=-1
40499      ICNT=ICNT+1
40500      ITEXT(ICNT)='Summary Statistics:'
40501      NCTEXT(ICNT)=19
40502      AVALUE(ICNT)=0.0
40503      IDIGIT(ICNT)=-1
40504      ICNT=ICNT+1
40505      ITEXT(ICNT)='Number of Observations:'
40506      NCTEXT(ICNT)=23
40507      AVALUE(ICNT)=REAL(N)
40508      IDIGIT(ICNT)=0
40509      ICNT=ICNT+1
40510      ITEXT(ICNT)=' '
40511      NCTEXT(ICNT)=1
40512      AVALUE(ICNT)=0.0
40513      IDIGIT(ICNT)=-1
40514      ICNT=ICNT+1
40515      ITEXT(ICNT)='Forward Direction Cumulative Sum Test Statistic:'
40516      NCTEXT(ICNT)=48
40517      AVALUE(ICNT)=STATVA
40518      IDIGIT(ICNT)=NUMDIG
40519      ICNT=ICNT+1
40520      ITEXT(ICNT)='Forward Direction P-Value:'
40521      NCTEXT(ICNT)=26
40522      AVALUE(ICNT)=PVAL1
40523      IDIGIT(ICNT)=NUMDIG
40524      ICNT=ICNT+1
40525      ITEXT(ICNT)=' '
40526      NCTEXT(ICNT)=1
40527      AVALUE(ICNT)=0.0
40528      IDIGIT(ICNT)=-1
40529      ICNT=ICNT+1
40530      ITEXT(ICNT)='Backward Direction Cumulative Sum Test Statistic:'
40531      NCTEXT(ICNT)=49
40532      AVALUE(ICNT)=STATV2
40533      IDIGIT(ICNT)=NUMDIG
40534      ICNT=ICNT+1
40535      ITEXT(ICNT)='Backward Direction P-Value:'
40536      NCTEXT(ICNT)=28
40537      AVALUE(ICNT)=PVAL2
40538      IDIGIT(ICNT)=NUMDIG
40539      ICNT=ICNT+1
40540      ITEXT(ICNT)=' '
40541      NCTEXT(ICNT)=1
40542      AVALUE(ICNT)=0.0
40543      IDIGIT(ICNT)=-1
40544C
40545      NUMROW=ICNT
40546      DO6110I=1,NUMROW
40547        NTOT(I)=15
40548 6110 CONTINUE
40549C
40550      IFRST=.TRUE.
40551      ILAST=.TRUE.
40552C
40553      ISTEPN='42A'
40554      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CUS2')
40555     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
40556C
40557      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
40558     1            AVALUE,IDIGIT,
40559     1            NTOT,NUMROW,
40560     1            ICAPSW,ICAPTY,ILAST,IFRST,
40561     1            ISUBRO,IBUGA3,IERROR)
40562C
40563      ISTEPN='42D'
40564      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CUS2')
40565     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
40566C
40567      ITITL9=' '
40568      NCTIT9=0
40569      ITITLE='Conclusions for Forward Direction Test'
40570      NCTITL=38
40571C
40572      DO6130J=1,4
40573        DO6140I=1,3
40574          ITITL2(I,J)=' '
40575          NCTIT2(I,J)=0
40576 6140   CONTINUE
40577 6130 CONTINUE
40578C
40579      ITITL2(2,1)='Null'
40580      NCTIT2(2,1)=4
40581      ITITL2(3,1)='Hypothesis'
40582      NCTIT2(3,1)=10
40583C
40584      ITITL2(2,2)='Confidence'
40585      NCTIT2(2,2)=10
40586      ITITL2(3,2)='Level'
40587      NCTIT2(3,2)=5
40588C
40589      ITITL2(3,3)='P-Value'
40590      NCTIT2(3,3)=7
40591C
40592      ITITL2(1,4)='Null'
40593      NCTIT2(1,4)=4
40594      ITITL2(2,4)='Hypothesis'
40595      NCTIT2(2,4)=10
40596      ITITL2(3,4)='Conclusion'
40597      NCTIT2(3,4)=10
40598C
40599      NMAX=0
40600      NUMCOL=4
40601      DO6150I=1,NUMCOL
40602        VALIGN(I)='b'
40603        ALIGN(I)='r'
40604        NTOT(I)=15
40605        IF(I.EQ.1)NTOT(I)=12
40606        NMAX=NMAX+NTOT(I)
40607        ITYPCO(I)='ALPH'
40608        IF(I.EQ.3)ITYPCO(I)='NUME'
40609        IDIGIT(I)=NUMDIG
40610        IWHTML(1)=150
40611        IWHTML(2)=125
40612        IWHTML(3)=150
40613        IWHTML(4)=150
40614        IINC=1600
40615        IINC2=1400
40616        IINC3=2200
40617        IWRTF(1)=IINC
40618        IWRTF(2)=IWRTF(1)+IINC
40619        IWRTF(3)=IWRTF(2)+IINC2
40620        IWRTF(4)=IWRTF(3)+IINC
40621C
40622        DO6160J=1,NUMALP
40623C
40624          AMAT(J,I)=0.0
40625          AMAT(J,3)=PVAL1
40626          IVALUE(J,1)='Random'
40627          NCVALU(J,1)=6
40628          IVALUE(J,4)(1:6)='REJECT'
40629          IF(J.EQ.1)THEN
40630            IVALUE(J,2)(1:5)='50.0%'
40631            IF(PVAL1.GE.0.50)IVALUE(J,4)(1:6)='ACCEPT'
40632          ELSEIF(J.EQ.2)THEN
40633            IVALUE(J,2)(1:5)='75.0%'
40634            IF(PVAL1.GE.0.25)IVALUE(J,4)(1:6)='ACCEPT'
40635          ELSEIF(J.EQ.3)THEN
40636            IVALUE(J,2)(1:5)='90.0%'
40637            IF(PVAL1.GE.0.10)IVALUE(J,4)(1:6)='ACCEPT'
40638          ELSEIF(J.EQ.4)THEN
40639            IVALUE(J,2)(1:5)='95.0%'
40640            IF(PVAL1.GE.0.05)IVALUE(J,4)(1:6)='ACCEPT'
40641          ELSEIF(J.EQ.5)THEN
40642            IVALUE(J,2)(1:5)='97.5%'
40643            IF(PVAL1.GE.0.025)IVALUE(J,4)(1:6)='ACCEPT'
40644          ELSEIF(J.EQ.6)THEN
40645            IVALUE(J,2)(1:5)='99.0%'
40646            IF(PVAL1.GE.0.01)IVALUE(J,4)(1:6)='ACCEPT'
40647          ELSEIF(J.EQ.7)THEN
40648            IVALUE(J,2)(1:5)='99.9%'
40649            IF(PVAL1.GE.0.001)IVALUE(J,4)(1:6)='ACCEPT'
40650          ENDIF
40651          NCVALU(J,2)=5
40652          NCVALU(J,4)=6
40653C
40654 6160   CONTINUE
40655 6150 CONTINUE
40656C
40657      ICNT=NUMALP
40658      NUMLIN=3
40659      NUMCOL=4
40660      IFRST=.TRUE.
40661      ILAST=.TRUE.
40662      IFLAGS=.TRUE.
40663      IFLAGE=.TRUE.
40664      CALL DPDTA5(ITITLE,NCTITL,
40665     1            ITITL9,NCTIT9,ITITL2,NCTIT2,
40666     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
40667     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
40668     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
40669     1            ICAPSW,ICAPTY,IFRST,ILAST,
40670     1            IFLAGS,IFLAGE,
40671     1            ISUBRO,IBUGA3,IERROR)
40672C
40673      ITITL9=' '
40674      NCTIT9=0
40675      ITITLE='Conclusions for Backward Direction Test'
40676      NCTITL=40
40677C
40678      NMAX=0
40679      NUMCOL=4
40680      DO7150I=1,NUMCOL
40681        NTOT(I)=15
40682        IF(I.EQ.1)NTOT(I)=12
40683        NMAX=NMAX+NTOT(I)
40684C
40685        DO7160J=1,NUMALP
40686C
40687          AMAT(J,I)=0.0
40688          AMAT(J,3)=PVAL2
40689          IVALUE(J,4)(1:6)='REJECT'
40690          IF(J.EQ.1)THEN
40691            IVALUE(J,2)(1:5)='50.0%'
40692            IF(PVAL2.GE.0.50)IVALUE(J,4)(1:6)='ACCEPT'
40693          ELSEIF(J.EQ.2)THEN
40694            IVALUE(J,2)(1:5)='75.0%'
40695            IF(PVAL2.GE.0.25)IVALUE(J,4)(1:6)='ACCEPT'
40696          ELSEIF(J.EQ.3)THEN
40697            IVALUE(J,2)(1:5)='90.0%'
40698            IF(PVAL2.GE.0.10)IVALUE(J,4)(1:6)='ACCEPT'
40699          ELSEIF(J.EQ.4)THEN
40700            IVALUE(J,2)(1:5)='95.0%'
40701            IF(PVAL2.GE.0.05)IVALUE(J,4)(1:6)='ACCEPT'
40702          ELSEIF(J.EQ.5)THEN
40703            IVALUE(J,2)(1:5)='97.5%'
40704            IF(PVAL2.GE.0.025)IVALUE(J,4)(1:6)='ACCEPT'
40705          ELSEIF(J.EQ.6)THEN
40706            IVALUE(J,2)(1:5)='99.0%'
40707            IF(PVAL2.GE.0.01)IVALUE(J,4)(1:6)='ACCEPT'
40708          ELSEIF(J.EQ.7)THEN
40709            IVALUE(J,2)(1:5)='99.9%'
40710            IF(PVAL2.GE.0.001)IVALUE(J,4)(1:6)='ACCEPT'
40711          ENDIF
40712          NCVALU(J,2)=5
40713          NCVALU(J,4)=6
40714C
40715 7160   CONTINUE
40716 7150 CONTINUE
40717C
40718      ICNT=NUMALP
40719      NUMLIN=3
40720      NUMCOL=4
40721      IFRST=.TRUE.
40722      ILAST=.TRUE.
40723      IFLAGS=.TRUE.
40724      IFLAGE=.TRUE.
40725      CALL DPDTA5(ITITLE,NCTITL,
40726     1            ITITL9,NCTIT9,ITITL2,NCTIT2,
40727     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
40728     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
40729     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
40730     1            ICAPSW,ICAPTY,IFRST,ILAST,
40731     1            IFLAGS,IFLAGE,
40732     1            ISUBRO,IBUGA3,IERROR)
40733C
40734C               *****************
40735C               **  STEP 90--  **
40736C               **  EXIT       **
40737C               *****************
40738C
40739 9000 CONTINUE
40740      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CUS2')THEN
40741        WRITE(ICOUT,999)
40742        CALL DPWRST('XXX','WRIT')
40743        WRITE(ICOUT,9011)
40744 9011   FORMAT('***** AT THE END       OF DPCUS2--')
40745        CALL DPWRST('XXX','WRIT')
40746        WRITE(ICOUT,9012)N,IBUGA3,IERROR
40747 9012   FORMAT('N,IBUGA3,IERROR = ',I8,2X,A4,2X,A4)
40748        CALL DPWRST('XXX','WRIT')
40749        DO9016I=1,N
40750          WRITE(ICOUT,9017)I,Y(I),XTEMP(I)
40751 9017     FORMAT('I,Y(I),XTEMP(I) = ',I8,2G15.7)
40752          CALL DPWRST('XXX','WRIT')
40753 9016   CONTINUE
40754      ENDIF
40755C
40756      RETURN
40757      END
40758      SUBROUTINE DPCUS3(Y,N,
40759     1                  STATVA,STATV2,STATCD,STATC2,PVAL1,PVAL2,
40760     1                  YTEMP1,
40761     1                  ISUBRO,IBUGA3,IERROR)
40762C
40763C     PURPOSE--THIS ROUTINE CARRIES OUT THE CUMULATIVE SUM TEST
40764C              FOR RANDOMNESS (EITHER FORWARD DIRECTION OR
40765C              BACKWARD DIRECTION).  THIS IS EXTRACTED FROM DPCUS2
40766C              IN ORDER TO MAKE IT CALLABLE FROM CMPSTA (I.E.,
40767C              MAKE A SUPPORTED STATISTIC).
40768C     EXAMPLE--LET A = CUMULATIVE SUM FORWARD TEST Y
40769C     REFERENCE--A STATISTICAL TEST SUITE FOR RANDOM AND PSUEDORANDOM
40770C                NUMBER GENERATORS FOR CRYPTOGRAPHIC APPLICATIONS,
40771C                ANDREW RUKHIN, JUAN SOTO, JAMES NECHVATAL, MILES SMID,
40772C                ELAINE BARKER, STEFAN LEIGH, MARK LEVENSON,
40773C                MARK VANGEL, DAVID BANKS, ALAN HECKERT, JAMES DRAY,
40774C                SAN VO.  NIST SPECIAL PUBLICATION 800-22,
40775C                OCTOBER 2000, PP. 14-18.
40776C     WRITTEN BY--ALAN HECKERT
40777C                 STATISTICAL ENGINEERING DIVISION
40778C                 INFORMATION TECHNOLOGY LABORATORY
40779C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
40780C                 GAITHERSBURG, MD 20899-8980
40781C                 PHONE--301-975-2899
40782C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
40783C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
40784C     LANGUAGE--ANSI FORTRAN (1977)
40785C     VERSION NUMBER--2011/3
40786C     ORIGINAL VERSION--MARCH     2011. EXTRACTED FROM DPCUS2
40787C
40788C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
40789C
40790      CHARACTER*4 ISUBRO
40791      CHARACTER*4 IBUGA3
40792      CHARACTER*4 IERROR
40793C
40794      CHARACTER*4 IWRITE
40795      CHARACTER*4 ISUBN1
40796      CHARACTER*4 ISUBN2
40797      CHARACTER*4 ISTEPN
40798C
40799C---------------------------------------------------------------------
40800C
40801      DIMENSION Y(*)
40802      DIMENSION YTEMP1(*)
40803C
40804      DOUBLE PRECISION DSUM1
40805      DOUBLE PRECISION DSUM2
40806      DOUBLE PRECISION DSUM3
40807      DOUBLE PRECISION DSUM4
40808      DOUBLE PRECISION DZ1
40809      DOUBLE PRECISION DZ2
40810      DOUBLE PRECISION DCDF1
40811      DOUBLE PRECISION DCDF2
40812C
40813C---------------------------------------------------------------------
40814C
40815      INCLUDE 'DPCOP2.INC'
40816C
40817C-----START POINT-----------------------------------------------------
40818C
40819      ISUBN1='DPCU'
40820      ISUBN2='S3  '
40821      IERROR='NO'
40822C
40823      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CUS3')THEN
40824        WRITE(ICOUT,999)
40825  999   FORMAT(1X)
40826        CALL DPWRST('XXX','BUG ')
40827        WRITE(ICOUT,51)
40828   51   FORMAT('**** AT THE BEGINNING OF DPCUS3--')
40829        CALL DPWRST('XXX','BUG ')
40830        WRITE(ICOUT,52)ICASAN,IBUGA3,ISUBRO,N
40831   52   FORMAT('ICASAN,IBUGA3,ISUBRO,N = ',3(A4,2X),I8)
40832        CALL DPWRST('XXX','BUG ')
40833        DO56I=1,N
40834          WRITE(ICOUT,57)I,Y(I)
40835   57     FORMAT('I,Y(I) = ',I8,G15.7)
40836          CALL DPWRST('XXX','BUG ')
40837   56   CONTINUE
40838      ENDIF
40839C
40840C               ********************************************
40841C               **  STEP 11--                             **
40842C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
40843C               ********************************************
40844C
40845      ISTEPN='11'
40846      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CUS3')
40847     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
40848C
40849      IF(N.LE.5)THEN
40850        WRITE(ICOUT,999)
40851        CALL DPWRST('XXX','BUG ')
40852        WRITE(ICOUT,1111)
40853 1111   FORMAT('***** ERROR IN CUMULATIVE SUM RANDOMNESS TEST.')
40854        CALL DPWRST('XXX','BUG ')
40855        WRITE(ICOUT,1113)
40856 1113   FORMAT('      AT LEAST SIX OBSERVATIONS REQUIRED.')
40857        CALL DPWRST('XXX','BUG ')
40858        WRITE(ICOUT,1115)N
40859 1115   FORMAT('SAMPLE SIZE = ',I8)
40860        CALL DPWRST('XXX','BUG ')
40861        IERROR='YES'
40862        GOTO9000
40863      ENDIF
40864C
40865      HOLD=Y(1)
40866      DO1135I=2,N
40867      IF(Y(I).NE.HOLD)GOTO1139
40868 1135 CONTINUE
40869      WRITE(ICOUT,999)
40870      CALL DPWRST('XXX','BUG ')
40871      WRITE(ICOUT,1111)
40872      CALL DPWRST('XXX','BUG ')
40873      WRITE(ICOUT,1131)HOLD
40874 1131 FORMAT('      THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7)
40875      CALL DPWRST('XXX','BUG ')
40876      IERROR='YES'
40877      GOTO9000
40878 1139 CONTINUE
40879C
40880C               *******************************
40881C               **  STEP 2--                 **
40882C               **  COMPUTE THE NUMBER OF    **
40883C               **  DISTINCT VALUES.         **
40884C               *******************************
40885C
40886      ISTEPN='2'
40887      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CUS3')
40888     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
40889C
40890      IWRITE='NO'
40891      CALL DISTIN(Y,N,IWRITE,YTEMP1,NDIST,IBUGA3,IERROR)
40892C
40893      IF(IERROR.EQ.'YES')GOTO9000
40894      IF(NDIST.NE.2)THEN
40895        WRITE(ICOUT,999)
40896        CALL DPWRST('XXX','BUG ')
40897        WRITE(ICOUT,1111)
40898        CALL DPWRST('XXX','BUG ')
40899        WRITE(ICOUT,2003)
40900 2003   FORMAT('      FOR CUMULATIVE SUM TEST, EXACTLY TWO DISTINCT ',
40901     1         'VALUES ARE ALLOWED.')
40902        CALL DPWRST('XXX','BUG ')
40903        WRITE(ICOUT,2005)NDIST
40904 2005   FORMAT('      NUMBER OF DISTINCT VALUES = ',I8)
40905        CALL DPWRST('XXX','BUG ')
40906        IERROR='YES'
40907        GOTO9000
40908      ENDIF
40909C
40910C               ******************************
40911C               **  STEP 21--               **
40912C               **  CARRY OUT CALCULATIONS  **
40913C               **  FOR CUSUM         TEST  **
40914C               ******************************
40915C
40916      ISTEPN='21'
40917      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CUS3')
40918     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
40919C
40920      IWRITE='OFF'
40921C
40922      ALOW=MIN(YTEMP1(1),YTEMP1(2))
40923      AHIGH=MAX(YTEMP1(1),YTEMP1(2))
40924      DZ1=0.0D0
40925      DZ2=0.0D0
40926      DSUM1=0.0D0
40927      DSUM2=0.0D0
40928      DSUM3=0.0D0
40929      DSUM4=0.0D0
40930C
40931      DO2120I=1,N
40932        IF(Y(I).EQ.ALOW)THEN
40933          DSUM1=DSUM1 - 1.0
40934        ELSE
40935          DSUM1=DSUM1 + 1.0
40936        ENDIF
40937        DZ1=MAX(DZ1,ABS(DSUM1))
40938 2120 CONTINUE
40939C
40940      DO2130I=N,1,-1
40941        IF(Y(I).EQ.ALOW)THEN
40942          DSUM2=DSUM2 - 1.0
40943        ELSE
40944          DSUM2=DSUM2 + 1.0
40945        ENDIF
40946        DZ2=MAX(DZ2,ABS(DSUM2))
40947 2130 CONTINUE
40948C
40949      AN=REAL(N)
40950      Z1=REAL(DZ1)/SQRT(AN)
40951      Z2=REAL(DZ2)/SQRT(AN)
40952      STATVA=Z1
40953      STATV2=Z2
40954C
40955      DSUM1=0.0D0
40956      DSUM2=0.0D0
40957C
40958      ATEMP=((AN/Z1)-1.0)/4.0
40959      IUPP=INT(ATEMP)
40960      ATEMP=((-AN/Z1)+1.0)/4.0
40961      ILOW=INT(ATEMP)
40962      DSUM1=0.0D0
40963      DO2140K=ILOW,IUPP
40964        AK=REAL(K)
40965        ATEMP=(4.0*AK+1.0)*Z1
40966        CALL NODCDF(DBLE(ATEMP),DCDF1)
40967        ATEMP=((4.0*AK - 1.0)*Z1)
40968        CALL NODCDF(DBLE(ATEMP),DCDF2)
40969        DSUM1=DSUM1 + (DCDF1 - DCDF2)
40970 2140 CONTINUE
40971C
40972      ATEMP=((AN/Z1)-3.0)/4.0
40973      IUPP=INT(ATEMP)
40974      ATEMP=((-AN/Z1)-1.0)/4.0
40975      ILOW=INT(ATEMP)
40976      DO2150K=ILOW,IUPP
40977        AK=REAL(K)
40978        ATEMP=(4.0*AK+3.0)*Z1
40979        CALL NODCDF(DBLE(ATEMP),DCDF1)
40980        ATEMP=((4.0*AK + 1.0)*Z1)
40981        CALL NODCDF(DBLE(ATEMP),DCDF2)
40982        DSUM2=DSUM2 + (DCDF1 - DCDF2)
40983 2150 CONTINUE
40984C
40985      ATEMP=((AN/Z2)-1.0)/4.0
40986      IUPP=INT(ATEMP)
40987      ATEMP=((-AN/Z2)+1.0)/4.0
40988      ILOW=INT(ATEMP)
40989      DSUM3=0.0D0
40990      DO2180K=ILOW,IUPP
40991        ATEMP=(4.0*REAL(K)+1.0)*Z2
40992        CALL NODCDF(DBLE(ATEMP),DCDF1)
40993        ATEMP=((4.0*REAL(K) - 1.0)*Z2)
40994        CALL NODCDF(DBLE(ATEMP),DCDF2)
40995        DSUM3=DSUM3 + (DCDF1 - DCDF2)
40996 2180 CONTINUE
40997C
40998      ATEMP=((AN/Z2)-3.0)/4.0
40999      IUPP=INT(ATEMP)
41000      ATEMP=((-AN/Z2)-1.0)/4.0
41001      ILOW=INT(ATEMP)
41002      DSUM4=0.0D0
41003      DO2190K=ILOW,IUPP
41004        ATEMP=(4.0*REAL(K)+3.0)*Z2
41005        CALL NODCDF(DBLE(ATEMP),DCDF1)
41006        ATEMP=((4.0*REAL(K) + 1.0)*Z2)
41007        CALL NODCDF(DBLE(ATEMP),DCDF2)
41008        DSUM4=DSUM4 + (DCDF1 - DCDF2)
41009 2190 CONTINUE
41010C
41011      STATCD=REAL(1.0D0 - DSUM1 + DSUM2)
41012      STATC2=REAL(1.0D0 - DSUM3 + DSUM4)
41013      PVAL1=STATCD
41014      PVAL2=STATC2
41015C
41016C               *****************
41017C               **  STEP 90--  **
41018C               **  EXIT       **
41019C               *****************
41020C
41021 9000 CONTINUE
41022      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CUS3')THEN
41023        WRITE(ICOUT,999)
41024        CALL DPWRST('XXX','WRIT')
41025        WRITE(ICOUT,9011)
41026 9011   FORMAT('***** AT THE END       OF DPCUS3--')
41027        CALL DPWRST('XXX','WRIT')
41028        WRITE(ICOUT,9012)N,IBUGA3,IERROR
41029 9012   FORMAT('N,IBUGA3,IERROR = ',I8,2X,A4,2X,A4)
41030        CALL DPWRST('XXX','WRIT')
41031      ENDIF
41032C
41033      RETURN
41034      END
41035      SUBROUTINE DPCUS5(STATVA,STATV2,PVAL1,PVAL2,
41036     1                  IFLAGU,IFRST,ILAST,
41037     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
41038C
41039C     PURPOSE--UTILITY ROUTINE USED BY DPCUSU.  THIS ROUTINE
41040C              UPDATES THE PARAMETERS "STATVAL" AND
41041C              "PVALUE".  NOTE THAT THERE ARE "FORWARD" AND "BACKWARD"
41042C              VERSIONS OF THE STATISTIC.
41043C
41044C     WRITTEN BY--ALAN HECKERT
41045C                 STATISTICAL ENGINEERING DIVISION
41046C                 INFORMATION TECHNOLOGY LABORAOTRY
41047C                 NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY
41048C                 GAITHERSBURG, MD 20899-8980
41049C                 PHONE--301-975-2899
41050C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
41051C           OF THE NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY.
41052C     LANGUAGE--ANSI FORTRAN (1977)
41053C     VERSION NUMBER--2011/3
41054C     ORIGINAL VERSION--MARCH     2011.
41055C
41056C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
41057C
41058      CHARACTER*4 IFLAGU
41059      CHARACTER*4 IBUGA2
41060      CHARACTER*4 IBUGA3
41061      CHARACTER*4 ISUBRO
41062      CHARACTER*4 IERROR
41063C
41064      LOGICAL IFRST
41065      LOGICAL ILAST
41066C
41067      CHARACTER*4 IH
41068      CHARACTER*4 IH2
41069      CHARACTER*4 ISUBN0
41070      CHARACTER*4 ISUBN1
41071      CHARACTER*4 ISUBN2
41072      CHARACTER*4 ISTEPN
41073      CHARACTER*4 IOP
41074C
41075C---------------------------------------------------------------------
41076C
41077      SAVE IOUNI1
41078C
41079C-----COMMON VARIABLES (GENERAL)--------------------------------------
41080C
41081      INCLUDE 'DPCOPA.INC'
41082      INCLUDE 'DPCOHK.INC'
41083      INCLUDE 'DPCOHO.INC'
41084C
41085      INCLUDE 'DPCOP2.INC'
41086C
41087C-----START POINT-----------------------------------------------------
41088C
41089      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CUS5')THEN
41090        ISTEPN='1'
41091        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
41092        WRITE(ICOUT,999)
41093  999   FORMAT(1X)
41094        CALL DPWRST('XXX','BUG ')
41095        WRITE(ICOUT,51)
41096   51   FORMAT('***** AT THE BEGINNING OF DPCUS5--')
41097        CALL DPWRST('XXX','BUG ')
41098        WRITE(ICOUT,53)STATVA,STATV2,PVAL1,PVAL2
41099   53   FORMAT('STATVA,STATV2,PVAL1,PVAL2 = ',4G15.7)
41100        CALL DPWRST('XXX','BUG ')
41101      ENDIF
41102C
41103      IF(IFLAGU.EQ.'FILE')THEN
41104C
41105        IF(IFRST)THEN
41106          IOP='OPEN'
41107          IFLAG1=1
41108          IFLAG2=0
41109          IFLAG3=0
41110          IFLAG4=0
41111          IFLAG5=0
41112          CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
41113     1                IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
41114     1                IBUGA3,ISUBRO,IERROR)
41115          IF(IERROR.EQ.'YES')GOTO9000
41116C
41117          WRITE(IOUNI1,295)
41118  295     FORMAT(11X,'STATVAL',8X,'PVALUE',
41119     1           6X,'STATVAL2',7X,'PVALUE2')
41120        ENDIF
41121        WRITE(IOUNI1,299)STATVA,STATV2,PVAL1,PVAL2
41122  299   FORMAT(4E15.7)
41123      ELSEIF(IFLAGU.EQ.'ON')THEN
41124        IF(STATVA.NE.CPUMIN)THEN
41125          IH='STAT'
41126          IH2='VAL '
41127          VALUE0=STATVA
41128          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
41129     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
41130     1                IANS,IWIDTH,IBUGA3,IERROR)
41131        ENDIF
41132C
41133        IF(STATV2.NE.CPUMIN)THEN
41134          IH='STAT'
41135          IH2='VAL2'
41136          VALUE0=STATV2
41137          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
41138     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
41139     1                IANS,IWIDTH,IBUGA3,IERROR)
41140        ENDIF
41141C
41142        IF(PVAL1.NE.CPUMIN)THEN
41143          IH='PVAL'
41144          IH2='UE  '
41145          VALUE0=PVAL1
41146          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
41147     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
41148     1                IANS,IWIDTH,IBUGA3,IERROR)
41149        ENDIF
41150C
41151        IF(PVAL2.NE.CPUMIN)THEN
41152          IH='PVAL'
41153          IH2='UE2 '
41154          VALUE0=PVAL2
41155          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
41156     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
41157     1                IANS,IWIDTH,IBUGA3,IERROR)
41158        ENDIF
41159C
41160      ENDIF
41161C
41162      IF(IFLAGU.EQ.'FILE')THEN
41163        IF(ILAST)THEN
41164          IOP='CLOS'
41165          IFLAG1=1
41166          IFLAG2=0
41167          IFLAG3=0
41168          IFLAG4=0
41169          IFLAG5=0
41170          CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
41171     1                IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
41172     1                IBUGA3,ISUBRO,IERROR)
41173C
41174          IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CUS5')THEN
41175            ISTEPN='3A'
41176            CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
41177            WRITE(ICOUT,999)
41178            CALL DPWRST('XXX','BUG ')
41179            WRITE(ICOUT,301)IERROR,IOUNI1
41180  301       FORMAT('AFTER CALL DPCLFI, IERROR,IOUNI1 = ',A4,2X,I5)
41181            CALL DPWRST('XXX','BUG ')
41182          ENDIF
41183C
41184          IF(IERROR.EQ.'YES')GOTO9000
41185        ENDIF
41186      ENDIF
41187C
41188C               *****************
41189C               **  STEP 90--  **
41190C               **  EXIT       **
41191C               *****************
41192C
41193 9000 CONTINUE
41194C
41195      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CUS5')THEN
41196        WRITE(ICOUT,999)
41197        CALL DPWRST('XXX','BUG ')
41198        WRITE(ICOUT,9011)
41199 9011   FORMAT('***** AT THE END OF DPCUS5--')
41200        CALL DPWRST('XXX','BUG ')
41201      ENDIF
41202C
41203      RETURN
41204      END
41205      SUBROUTINE DPCUSZ(IHARG,IARGT,ARG,NUMARG,DEFCSZ,
41206     1                  ACURSZ,IFOUND,IERROR)
41207C
41208C     PURPOSE--DEFINE THE SIZE FOR THE CURSOR (THE HORIZONTAL STRING
41209C              ABOVE THE UPPER HORIZONTAL FRAME).  THE SIZE FOR THE
41210C              CURSOR WILL BE PLACED IN THE FLOATING POINT VARIABLE
41211C              ACURSZ.  (NOTE THAT THE IMPORTANT VARIABLE PDIAHE IS
41212C              USUALLY SET EQUAL TO ACURSZ IN THE CALLING ROUTINE
41213C              AFTER THE CALL TO THIS SUBROUTINE).
41214C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
41215C                     --NUMARG
41216C                     --DEFCSZ
41217C     OUTPUT ARGUMENTS--ACURSZ
41218C                     --IFOUND ('YES' OR 'NO' )
41219C                     --IERROR ('YES' OR 'NO' )
41220C     WRITTEN BY--JAMES J. FILLIBEN
41221C                 STATISTICAL ENGINEERING DIVISION
41222C                 INFORMATION TECHNOLOGY LABORATORY
41223C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
41224C                 GAITHERSBURG, MD 20899-8980
41225C                 PHONE--301-975-2855
41226C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
41227C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
41228C     LANGUAGE--ANSI FORTRAN (1977)
41229C     VERSION NUMBER--82/7
41230C     ORIGINAL VERSION--JANUARY   1980.
41231C     UPDATED         --MAY       1982.
41232C
41233C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
41234C
41235      CHARACTER*4 IHARG
41236      CHARACTER*4 IARGT
41237      CHARACTER*4 IFOUND
41238      CHARACTER*4 IERROR
41239C
41240C---------------------------------------------------------------------
41241C
41242      DIMENSION IHARG(*)
41243      DIMENSION IARGT(*)
41244      DIMENSION ARG(*)
41245C
41246C---------------------------------------------------------------------
41247C
41248      INCLUDE 'DPCOP2.INC'
41249C
41250C-----START POINT-----------------------------------------------------
41251C
41252      IFOUND='NO'
41253      IERROR='NO'
41254C
41255      IF(NUMARG.LE.0)GOTO1199
41256      IF(IHARG(1).NE.'SIZE')GOTO1199
41257      IF(NUMARG.EQ.1)GOTO1150
41258      IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160
41259      GOTO1110
41260C
41261 1110 CONTINUE
41262      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
41263      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
41264      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
41265      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
41266C
41267      IERROR='YES'
41268      WRITE(ICOUT,1121)
41269 1121 FORMAT('***** ERROR IN DPCUSZ--')
41270      CALL DPWRST('XXX','BUG ')
41271      WRITE(ICOUT,1122)
41272 1122 FORMAT('      ILLEGAL FORM FOR CURSOR SIZE ',
41273     1'COMMAND.')
41274      CALL DPWRST('XXX','BUG ')
41275      WRITE(ICOUT,1124)
41276 1124 FORMAT('      TEST EXAMPLE TO DEMONSTRATE THE ',
41277     1'PROPER FORM--')
41278      CALL DPWRST('XXX','BUG ')
41279      WRITE(ICOUT,1125)
41280 1125 FORMAT('      SUPPOSE IT IS DESIRED TO HAVE ')
41281      CALL DPWRST('XXX','BUG ')
41282      WRITE(ICOUT,1126)
41283 1126 FORMAT('      THE CURSOR ONE AND ONE HALF TIMES AS BIG ')
41284      CALL DPWRST('XXX','BUG ')
41285      WRITE(ICOUT,1127)
41286 1127 FORMAT('      AS THE DEFAULT SIZE (WHICH IS SIZE 1), ')
41287      CALL DPWRST('XXX','BUG ')
41288      WRITE(ICOUT,1128)
41289 1128 FORMAT('      THEN THE ALLOWABLE FORM IS--')
41290      CALL DPWRST('XXX','BUG ')
41291      WRITE(ICOUT,1131)
41292 1131 FORMAT('      CURSOR SIZE 1.5 ')
41293      CALL DPWRST('XXX','BUG ')
41294      GOTO1199
41295C
41296 1150 CONTINUE
41297      ACURSZ=DEFCSZ
41298      GOTO1180
41299C
41300 1160 CONTINUE
41301      ACURSZ=ARG(NUMARG)
41302      GOTO1180
41303C
41304 1180 CONTINUE
41305      IFOUND='YES'
41306C
41307      IF(IFEEDB.EQ.'OFF')GOTO1189
41308      WRITE(ICOUT,999)
41309  999 FORMAT(1X)
41310      CALL DPWRST('XXX','BUG ')
41311      WRITE(ICOUT,1181)ACURSZ
41312 1181 FORMAT('THE CURSOR SIZE HAS JUST BEEN SET TO ',
41313     1E15.7)
41314      CALL DPWRST('XXX','BUG ')
41315 1189 CONTINUE
41316      GOTO1199
41317C
41318 1199 CONTINUE
41319      RETURN
41320      END
41321      SUBROUTINE DPCVTE(XTEMP1,XTEMP2,MAXNXT,
41322     1                  ICAPSW,IFORSW,
41323     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
41324C
41325C     PURPOSE--THIS ROUTINE CARRIES OUT A COEFFICIENT OF VARIATION TEST
41326C              (1-SAMPLE OR 2-SAMPLE) BASED ON THE FORKMAN METHOD.
41327C
41328C              NOTE THAT THIS HANDLES THE GENERAL CASE WHERE WE HAVE
41329C              MULTIPLE GROUPS. THAT IS, FOR THE ONE SAMPLE CASE WE ARE
41330C              TESTING WHETHER THE COMMON COEFFICIENT OF VARIATION FOR
41331C              MULTIPLE GROUPS IS EQUAL TO A GIVEN VALUE.  FOR THE TWO
41332C              SAMPLE CASE, WE ARE TESTING WHETHER THE COMMON
41333C              COEFFICIENT OF VARIATION FOR ONE SET OF GROUPS OF DATA
41334C              IS EQUAL TO THE COMMON COEFFICIENT OF VARIATION FOR A
41335C              SECOND SET OF GROUPS OF DATA.
41336C
41337C              THE MORE COMMON CASE WHERE THERE IS A SINGLE GROUP IS A
41338C              SPECIAL CASE OF THE MORE GENERAL MULTIPLE GROUPS CASE.
41339C
41340C     EXAMPLE--COEFFICIENT OF VARIATION TEST Y X GAMMA0
41341C              COEFFICIENT OF VARIATION TWO SAMPLE TEST Y1 Y2
41342C              COEFFICIENT OF VARIATION TWO SAMPLE TEST Y1 X1 Y2 X2
41343C     REFERENCES--JOHANNES FORKMAN (2009)), "ESTIMATOR AND TESTS FOR
41344C                 COMMON COEFFICIENTS OF VARIATION IN NORMAL
41345C                 DISTRIBUTIONS", COMMUNICATIONS IN STATISTICS -
41346C                 THEROY AND METHODS, Vol. 38, No. 2, pp. 233-251.
41347C     WRITTEN BY--ALAN HECKERT
41348C                 STATISTICAL ENGINEERING DIVISION
41349C                 INFORMATION TECHNOLOGY LABORATORY
41350C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
41351C                 GAITHERSBURG, MD 20899-8980
41352C                 PHONE--301-975-2899
41353C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
41354C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
41355C     LANGUAGE--ANSI FORTRAN (1977)
41356C     VERSION NUMBER--2017/06
41357C     ORIGINAL VERSION--JUNE      2017.
41358C
41359C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
41360C
41361      CHARACTER*4 ICAPSW
41362      CHARACTER*4 IFORSW
41363      CHARACTER*4 IBUGA2
41364      CHARACTER*4 IBUGA3
41365      CHARACTER*4 IBUGQ
41366      CHARACTER*4 ISUBRO
41367      CHARACTER*4 IFOUND
41368      CHARACTER*4 IERROR
41369C
41370      CHARACTER*4 ICASAN
41371      CHARACTER*4 ICASA2
41372      CHARACTER*4 ICASA3
41373      CHARACTER*4 IHWUSE
41374      CHARACTER*4 MESSAG
41375      CHARACTER*4 ISUBN1
41376      CHARACTER*4 ISUBN2
41377      CHARACTER*4 ISTEPN
41378      CHARACTER*4 IH
41379      CHARACTER*4 IH2
41380C
41381      CHARACTER*4 ICASE
41382      CHARACTER*4 IVARID
41383      CHARACTER*4 IVARI2
41384      CHARACTER*4 IVARI3
41385      CHARACTER*4 IVARI4
41386      CHARACTER*4 IVARI5
41387      CHARACTER*4 IVARI6
41388      CHARACTER*4 IVARI7
41389      CHARACTER*4 IVARI8
41390      CHARACTER*40 INAME
41391      PARAMETER (MAXSPN=30)
41392      CHARACTER*4 IVARN1(MAXSPN)
41393      CHARACTER*4 IVARN2(MAXSPN)
41394      CHARACTER*4 IVARTY(MAXSPN)
41395      REAL PVAR(MAXSPN)
41396      INTEGER ILIS(MAXSPN)
41397      INTEGER NRIGHT(MAXSPN)
41398      INTEGER ICOLR(MAXSPN)
41399C
41400      CHARACTER*4 IFLAGU
41401      LOGICAL IFRST
41402      LOGICAL ILAST
41403C
41404C---------------------------------------------------------------------
41405C
41406      DIMENSION XTEMP1(*)
41407      DIMENSION XTEMP2(*)
41408C
41409C-----COMMON----------------------------------------------------------
41410C
41411      INCLUDE 'DPCOPA.INC'
41412      INCLUDE 'DPCOHK.INC'
41413      INCLUDE 'DPCOSU.INC'
41414      INCLUDE 'DPCODA.INC'
41415      INCLUDE 'DPCOHO.INC'
41416      INCLUDE 'DPCOST.INC'
41417      INCLUDE 'DPCOZZ.INC'
41418C
41419      DIMENSION Y1(MAXOBV)
41420      DIMENSION X1(MAXOBV)
41421      DIMENSION Y2(MAXOBV)
41422      DIMENSION X2(MAXOBV)
41423C
41424      EQUIVALENCE (GARBAG(IGARB1),Y1(1))
41425      EQUIVALENCE (GARBAG(IGARB2),X1(1))
41426      EQUIVALENCE (GARBAG(IGARB3),Y2(1))
41427      EQUIVALENCE (GARBAG(IGARB4),X2(1))
41428C
41429C-----COMMON VARIABLES (GENERAL)--------------------------------------
41430C
41431      INCLUDE 'DPCOP2.INC'
41432C
41433C-----START POINT-----------------------------------------------------
41434C
41435      ISUBN1='DPCV'
41436      ISUBN2='TE  '
41437      IFOUND='NO'
41438      IERROR='NO'
41439      ICASAN='CVTE'
41440      ICASA2='UNKN'
41441      ICASA3='TWOT'
41442C
41443      MAXCP1=MAXCOL+1
41444      MAXCP2=MAXCOL+2
41445      MAXCP3=MAXCOL+3
41446      MAXCP4=MAXCOL+4
41447      MAXCP5=MAXCOL+5
41448      MAXCP6=MAXCOL+6
41449C
41450C               ****************************************************
41451C               **  TREAT THE COEFFICIENT OF VARIATION TEST CASE  **
41452C               ****************************************************
41453C
41454      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CVTE')THEN
41455        WRITE(ICOUT,999)
41456  999   FORMAT(1X)
41457        CALL DPWRST('XXX','BUG ')
41458        WRITE(ICOUT,51)
41459   51   FORMAT('***** AT THE BEGINNING OF DPCVTE--')
41460        CALL DPWRST('XXX','BUG ')
41461        WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ,ISUBRO,MAXNXT
41462   52   FORMAT('IBUGA2,IBUGA3,IBUGQ,ISUBRO = ',4(A4,2X),I8)
41463        CALL DPWRST('XXX','BUG ')
41464      ENDIF
41465C
41466C               *********************************************************
41467C               **  STEP 1--                                           **
41468C               **  EXTRACT THE COMMAND                                **
41469C               *********************************************************
41470C
41471      ISTEPN='1'
41472      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CVTE')
41473     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
41474C
41475C
41476C     NOTE THAT SINCE THESE TESTS CAN OPTIONALLY SUPPORT GROUP-ID
41477C     VARIABLES, THE "MULTIPLE" AND "REPLICATION" OPTIONS WILL NOT
41478C     BE SUPPORTED.
41479C
41480C          ONE SAMPLE COEFFICIENT OF VARIATION TEST (OR 1 SAMPLE)
41481C          TWO SAMPLE COEFFICIENT OF VARIATION TEST (OR 2 SAMPLE)
41482C
41483      IF((ICOM.EQ.'ONE ' .OR. ICOM.EQ.'1   ') .AND.
41484     1    IHARG(1).EQ.'SAMP' .AND. IHARG(2).EQ.'COEF' .AND.
41485     1    IHARG(3).EQ.'OF  ' .AND. IHARG(4).EQ.'VARI' .AND.
41486     1    IHARG(5).EQ.'UPPE' .AND. IHARG(6).EQ.'TAIL' .AND.
41487     1    IHARG(7).EQ.'TEST')THEN
41488        ILASTZ=7
41489        ICASA2='ONES'
41490        ICASA3='UPPE'
41491      ELSEIF((ICOM.EQ.'ONE ' .OR. ICOM.EQ.'1   ') .AND.
41492     1    IHARG(1).EQ.'SAMP' .AND. IHARG(2).EQ.'COEF' .AND.
41493     1    IHARG(3).EQ.'OF  ' .AND. IHARG(4).EQ.'VARI' .AND.
41494     1    IHARG(5).EQ.'LOWE' .AND. IHARG(6).EQ.'TAIL' .AND.
41495     1    IHARG(7).EQ.'TEST')THEN
41496        ILASTZ=7
41497        ICASA2='ONES'
41498        ICASA3='LOWE'
41499      ELSEIF((ICOM.EQ.'TWO ' .OR. ICOM.EQ.'2   ') .AND.
41500     1    IHARG(1).EQ.'SAMP' .AND. IHARG(2).EQ.'COEF' .AND.
41501     1    IHARG(3).EQ.'OF  ' .AND. IHARG(4).EQ.'VARI' .AND.
41502     1    IHARG(5).EQ.'UPPE' .AND. IHARG(6).EQ.'TAIL' .AND.
41503     1    IHARG(7).EQ.'TEST')THEN
41504        ILASTZ=7
41505        ICASA2='TWOS'
41506        ICASA3='UPPE'
41507      ELSEIF((ICOM.EQ.'TWO ' .OR. ICOM.EQ.'2   ') .AND.
41508     1    IHARG(1).EQ.'SAMP' .AND. IHARG(2).EQ.'COEF' .AND.
41509     1    IHARG(3).EQ.'OF  ' .AND. IHARG(4).EQ.'VARI' .AND.
41510     1    IHARG(5).EQ.'LOWE' .AND. IHARG(6).EQ.'TAIL' .AND.
41511     1    IHARG(7).EQ.'TEST')THEN
41512        ILASTZ=7
41513        ICASA2='TWOS'
41514        ICASA3='LOWE'
41515      ELSEIF((ICOM.EQ.'ONE ' .OR. ICOM.EQ.'1   ') .AND.
41516     1    IHARG(1).EQ.'SAMP' .AND. IHARG(2).EQ.'COEF' .AND.
41517     1    IHARG(3).EQ.'OF  ' .AND. IHARG(4).EQ.'VARI')THEN
41518        ILASTZ=4
41519        IF(IHARG(5).EQ.'TEST')ILASTZ=5
41520        ICASA2='ONES'
41521      ELSEIF((ICOM.EQ.'TWO ' .OR. ICOM.EQ.'2   ') .AND.
41522     1    IHARG(1).EQ.'SAMP' .AND. IHARG(2).EQ.'COEF' .AND.
41523     1    IHARG(3).EQ.'OF  ' .AND. IHARG(4).EQ.'VARI')THEN
41524        ILASTZ=4
41525        IF(IHARG(5).EQ.'TEST')ILASTZ=5
41526        ICASA2='TWOS'
41527      ELSE
41528        GOTO9000
41529      ENDIF
41530C
41531      IFOUND='YES'
41532      CALL SHIFTL(ILASTZ,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
41533     1            IBUGA2,IERROR)
41534C
41535      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CVTE')THEN
41536        WRITE(ICOUT,91)ICASAN,ICASA2,ICASA3,ILASTZ
41537   91   FORMAT('DPCVTE: ICASAN,ICASA2,ICASA3,ILASTZ = ',3(A4,2X),I5)
41538        CALL DPWRST('XXX','BUG ')
41539      ENDIF
41540C
41541C               ****************************************
41542C               **  STEP 2--                          **
41543C               **  EXTRACT THE VARIABLE LIST         **
41544C               ****************************************
41545C
41546      ISTEPN='2'
41547      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CVTE')
41548     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
41549C
41550      INAME='COEFFICIENT OF VARIATION TEST'
41551      MINNA=1
41552      MAXNA=100
41553      MINN2=2
41554      IFLAGM=0
41555      IF(ICASA2.EQ.'ONES')THEN
41556        MINNVA=1
41557        MAXNVA=3
41558        IFLAGP=29
41559        IFLAGE=1
41560      ELSE
41561        MINNVA=2
41562        MAXNVA=4
41563        IFLAGP=0
41564        IFLAGE=0
41565      ENDIF
41566      JMIN=1
41567      JMAX=NUMARG
41568C
41569      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
41570     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
41571     1            JMIN,JMAX,
41572     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
41573     1            IVARN1,IVARN2,IVARTY,PVAR,
41574     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
41575     1            MINNVA,MAXNVA,
41576     1            IFLAGM,IFLAGP,
41577     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
41578      IF(IERROR.EQ.'YES')GOTO9000
41579C
41580      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CVTE')THEN
41581        WRITE(ICOUT,999)
41582        CALL DPWRST('XXX','BUG ')
41583        WRITE(ICOUT,201)
41584  201   FORMAT('***** AFTER CALL DPPARS--')
41585        CALL DPWRST('XXX','BUG ')
41586        WRITE(ICOUT,202)NQ,NUMVAR
41587  202   FORMAT('NQ,NUMVAR = ',2I8)
41588        CALL DPWRST('XXX','BUG ')
41589        IF(NUMVAR.GT.0)THEN
41590          DO205I=1,NUMVAR
41591            WRITE(ICOUT,207)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
41592     1                      ICOLR(I)
41593  207       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
41594     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
41595            CALL DPWRST('XXX','BUG ')
41596  205     CONTINUE
41597        ENDIF
41598      ENDIF
41599C
41600C     FOR THE ONE-SAMPLE TEST, CHECK TO SEE IF THE LAST ARGUMENT IS
41601C     A PARAMETER (AT LEAST ONE VARIABLE MUST BE ENTERED).  IF IT IS
41602C     NOT, CHECK TO SEE IF THE "GAMMA0" PARAMETER EXISTS.
41603C
41604      IF(ICASA2.EQ.'ONES')THEN
41605        IF(IVARTY(NUMVAR).EQ.'PARA')THEN
41606          IF(NUMVAR.EQ.1)THEN
41607            WRITE(ICOUT,999)
41608            CALL DPWRST('XXX','BUG ')
41609            WRITE(ICOUT,101)
41610  101       FORMAT('***** ERROR IN COEFFICIENT OF VARIATION TEST--')
41611            CALL DPWRST('XXX','BUG ')
41612            WRITE(ICOUT,282)
41613  282       FORMAT('      FOR THE ONE-SAMPLE TEST, IF ONLY ONE NAME ',
41614     1             'IS GIVEN')
41615            CALL DPWRST('XXX','BUG ')
41616            WRITE(ICOUT,284)
41617  284       FORMAT('      IT MUST BE A VARIABLE NAME RATHER THAN A ',
41618     1             'PARAMETER NAME')
41619            CALL DPWRST('XXX','BUG ')
41620            IERROR='YES'
41621            GOTO9000
41622          ELSEIF(NUMVAR.EQ.2)THEN
41623            NVAR=1
41624          ELSEIF(NUMVAR.EQ.3)THEN
41625            NVAR=2
41626          ENDIF
41627          GAMMA0=PVAR(NUMVAR)
41628        ELSE
41629          IH='GAMM'
41630          IH2='A0  '
41631          IHWUSE='P'
41632          MESSAG='YES'
41633          CALL CHECKN(IH,IH2,IHWUSE,
41634     1                IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
41635     1                ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
41636          IF(IERROR.EQ.'YES')THEN
41637            GOTO9000
41638          ELSE
41639           GAMMA0=VALUE(ILOCP)
41640          ENDIF
41641          NVAR=NUMVAR
41642        ENDIF
41643      ELSE
41644        NVAR=NUMVAR
41645      ENDIF
41646C
41647C               ******************************************************
41648C               **  STEP 3--                                        **
41649C               **  EXTRACT THE DATA.                               **
41650C               ******************************************************
41651C
41652      ISTEPN='3'
41653      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CVTE')
41654     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
41655C
41656      IF(ICASA2.EQ.'ONES')THEN
41657        ICOL=1
41658        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
41659     1              INAME,IVARN1,IVARN2,IVARTY,
41660     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NVAR,
41661     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
41662     1              MAXCP4,MAXCP5,MAXCP6,
41663     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
41664     1              Y1,X1,Y1,NS1,NLOCA2,NLOCA3,ICASE,
41665     1              IBUGA3,ISUBRO,IFOUND,IERROR)
41666        IF(IERROR.EQ.'YES')GOTO9000
41667        IF(NVAR.EQ.1)THEN
41668          DO310II=1,NS1
41669            X1(II)=1.0
41670  310     CONTINUE
41671        ENDIF
41672      ELSE
41673        IF(NVAR.EQ.2)THEN
41674          ICOL=1
41675          CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
41676     1                INAME,IVARN1,IVARN2,IVARTY,
41677     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NVAR,
41678     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
41679     1                MAXCP4,MAXCP5,MAXCP6,
41680     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
41681     1                Y1,Y2,Y1,NS1,NS2,NLOCA3,ICASE,
41682     1              IBUGA3,ISUBRO,IFOUND,IERROR)
41683          IF(IERROR.EQ.'YES')GOTO9000
41684          DO321II=1,NS1
41685            X1(II)=1.0
41686  321     CONTINUE
41687          DO322II=1,NS2
41688            X2(II)=1.0
41689  322     CONTINUE
41690        ELSEIF(NVAR.EQ.3)THEN
41691          WRITE(ICOUT,999)
41692          CALL DPWRST('XXX','BUG ')
41693          WRITE(ICOUT,101)
41694          CALL DPWRST('XXX','BUG ')
41695          WRITE(ICOUT,324)
41696  324     FORMAT('      FOR THE TWO-SAMPLE TEST, EITHER TWO OR FOUR ',
41697     1           'VARAIBLES SHOULD BE GIVEN.')
41698          CALL DPWRST('XXX','BUG ')
41699          WRITE(ICOUT,326)
41700  326     FORMAT('      THREE VARIABLE WERE GIVEN HERE.')
41701          CALL DPWRST('XXX','BUG ')
41702        ELSEIF(NVAR.EQ.4)THEN
41703          IF(NRIGHT(1).NE.NRIGHT(2))THEN
41704            WRITE(ICOUT,999)
41705            CALL DPWRST('XXX','BUG ')
41706            WRITE(ICOUT,101)
41707            CALL DPWRST('XXX','BUG ')
41708            WRITE(ICOUT,332)
41709  332       FORMAT('      FOR THE TWO-SAMPLE TEST WITH FOUR VARIABLES ',
41710     1             'CASE,')
41711            CALL DPWRST('XXX','BUG ')
41712            WRITE(ICOUT,334)
41713  334       FORMAT('      VARIABLES ONE AND TWO MUST HAVE THE SAME ',
41714     1            'LENGTH.')
41715            CALL DPWRST('XXX','BUG ')
41716            WRITE(ICOUT,336)IVARN1(1),IVARN2(1),NRIGHT(1)
41717  336       FORMAT('      VARIABLE ',2A4,' HAS ',I8,' ROWS.')
41718            CALL DPWRST('XXX','BUG ')
41719            WRITE(ICOUT,336)IVARN1(2),IVARN2(2),NRIGHT(2)
41720            CALL DPWRST('XXX','BUG ')
41721            IERROR='YES'
41722            GOTO9000
41723          ELSEIF(NRIGHT(3).NE.NRIGHT(4))THEN
41724            WRITE(ICOUT,999)
41725            CALL DPWRST('XXX','BUG ')
41726            WRITE(ICOUT,101)
41727            CALL DPWRST('XXX','BUG ')
41728            WRITE(ICOUT,332)
41729            CALL DPWRST('XXX','BUG ')
41730            WRITE(ICOUT,338)
41731  338       FORMAT('      VARIABLES THREE AND FOUR MUST HAVE THE SAME ',
41732     1            'LENGTH.')
41733            CALL DPWRST('XXX','BUG ')
41734            WRITE(ICOUT,336)IVARN1(3),IVARN2(3),NRIGHT(3)
41735            CALL DPWRST('XXX','BUG ')
41736            WRITE(ICOUT,336)IVARN1(4),IVARN2(4),NRIGHT(4)
41737            CALL DPWRST('XXX','BUG ')
41738            IERROR='YES'
41739            GOTO9000
41740          ENDIF
41741          ICOL=1
41742          NVAR2=2
41743          CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
41744     1                INAME,IVARN1,IVARN2,IVARTY,
41745     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NVAR2,
41746     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
41747     1                MAXCP4,MAXCP5,MAXCP6,
41748     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
41749     1                Y1,X1,Y1,NS1,NS1,NLOCA3,ICASE,
41750     1                IBUGA3,ISUBRO,IFOUND,IERROR)
41751          IF(IERROR.EQ.'YES')GOTO9000
41752          ICOL=3
41753          NVAR2=2
41754          CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
41755     1                INAME,IVARN1,IVARN2,IVARTY,
41756     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NVAR2,
41757     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
41758     1                MAXCP4,MAXCP5,MAXCP6,
41759     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
41760     1                Y2,X2,Y1,NS2,NS2,NLOCA3,ICASE,
41761     1              IBUGA3,ISUBRO,IFOUND,IERROR)
41762          IF(IERROR.EQ.'YES')GOTO9000
41763        ENDIF
41764      ENDIF
41765C
41766C               ************************************************
41767C               **  STEP 4--                                  **
41768C               **  PERFORM THE COEFFICIENT OF VARIATION TEST **
41769C               ************************************************
41770C
41771      ISTEPN='4'
41772      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CVTE')THEN
41773        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
41774        WRITE(ICOUT,999)
41775        CALL DPWRST('XXX','BUG ')
41776        WRITE(ICOUT,411)
41777  411   FORMAT('***** FROM DPCVTE, BEFORE CALL DPCVT2--')
41778        CALL DPWRST('XXX','BUG ')
41779        WRITE(ICOUT,412)NS1,NS2,MAXN,NVAR,GAMMA0
41780  412   FORMAT('NS1,NS2,MAXN,NVAR,GAMMA0 = ',4I8,G15.7)
41781        CALL DPWRST('XXX','BUG ')
41782        IF(ICASA2.EQ.'ONES')THEN
41783          NTEMP=NS1
41784        ELSE
41785          NTEMP=MAX(NS1,NS2)
41786        ENDIF
41787        DO415II=1,NTEMP
41788          WRITE(ICOUT,416)II,Y1(II),X1(II),Y2(II),X2(II)
41789  416     FORMAT('I,Y(I),X(I) = ',I8,4G15.7)
41790          CALL DPWRST('XXX','BUG ')
41791  415   CONTINUE
41792      ENDIF
41793C
41794      IVARID=IVARN1(1)
41795      IVARI2=IVARN2(1)
41796      IVARI3=IVARN1(2)
41797      IVARI4=IVARN2(2)
41798      IVARI5=IVARN1(3)
41799      IVARI6=IVARN2(3)
41800      IVARI7=IVARN1(4)
41801      IVARI8=IVARN2(4)
41802C
41803      CALL DPCVT2(Y1,X1,NS1,Y2,X2,NS2,GAMMA0,ICASA2,ICASA3,
41804     1            XTEMP1,XTEMP2,MAXNXT,
41805     1            ICAPSW,ICAPTY,IFORSW,ICVTTE,
41806     1            IVARID,IVARI2,IVARI3,IVARI4,
41807     1            IVARI5,IVARI6,IVARI7,IVARI7,
41808     1            STATVA,STATCD,STATN1,STATN2,
41809     1            PVAL2T,PVALLT,PVALUT,
41810     1            CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50,
41811     1            CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50,
41812     1            IBUGA3,ISUBRO,IERROR)
41813      IF(IERROR.EQ.'YES')GOTO9000
41814C
41815C               ***************************************
41816C               **  STEP 6--                         **
41817C               **  UPDATE INTERNAL DATAPLOT TABLES  **
41818C               ***************************************
41819C
41820      ISTEPN='6'
41821      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TTE2')
41822     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
41823C
41824      IFLAGU='ON'
41825      IFRST=.TRUE.
41826      ILAST=.TRUE.
41827      CALL DPCVT5(STATVA,STATCD,PVAL,STANU1,STANU2,
41828     1            CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50,
41829     1            CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50,
41830     1            IFLAGU,IFRST,ILAST,
41831     1            IBUGA2,IBUGA3,ISUBRO,IERROR)
41832C
41833C               *****************
41834C               **  STEP 90--  **
41835C               **  EXIT       **
41836C               *****************
41837C
41838 9000 CONTINUE
41839      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CVTE')THEN
41840        WRITE(ICOUT,999)
41841        CALL DPWRST('XXX','BUG ')
41842        WRITE(ICOUT,9011)
41843 9011   FORMAT('***** AT THE END       OF DPCVTE--')
41844        CALL DPWRST('XXX','BUG ')
41845        WRITE(ICOUT,9016)IFOUND,IERROR
41846 9016   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
41847        CALL DPWRST('XXX','BUG ')
41848      ENDIF
41849C
41850      RETURN
41851      END
41852      SUBROUTINE DPCVT2(Y1,X1,N1,Y2,X2,N2,GAMMA0,ICASA2,ICASA3,
41853     1                  TEMP1,TEMP2,MAXNXT,
41854     1                  ICAPSW,ICAPTY,IFORSW,ICVTTE,
41855     1                  IVARID,IVARI2,IVARI3,IVARI4,
41856     1                  IVARI5,IVARI6,IVARI7,IVARI8,
41857     1                  STATVA,STATCD,STATN1,STATN2,
41858     1                  PVAL2T,PVALLT,PVALUT,
41859     1                  CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50,
41860     1                  CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50,
41861     1                  IBUGA3,ISUBRO,IERROR)
41862C
41863C     PURPOSE--THIS ROUTINE CARRIES OUT A COEFFICIENT OF VARIATION TEST
41864C              (1-SAMPLE OR 2-SAMPLE) BASED ON THE FORKMAN METHOD.
41865C
41866C              NOTE THAT THIS HANDLES THE GENERAL CASE WHERE WE HAVE
41867C              MULTIPLE GROUPS. THAT IS, FOR THE ONE SAMPLE CASE WE ARE
41868C              TESTING WHETHER THE COMMON COEFFICIENT OF VARIATION FOR
41869C              MULTIPLE GROUPS IS EQUAL TO A GIVEN VALUE.  FOR THE TWO
41870C              SAMPLE CASE, WE ARE TESTING WHETHER THE COMMON
41871C              COEFFICIENT OF VARIATION FOR ONE SET OF GROUPS OF DATA
41872C              IS EQUAL TO THE COMMON COEFFICIENT OF VARIATION FOR A
41873C              SECOND SET OF GROUPS OF DATA.
41874C
41875C              THE MORE COMMON CASE WHERE THERE IS A SINGLE GROUP IS A
41876C              SPECIAL CASE OF THE MORE GENERAL MULTIPLE GROUPS CASE.
41877C
41878C     EXAMPLE--COEFFICIENT OF VARIATION TEST Y X GAMMA0
41879C              COEFFICIENT OF VARIATION TWO SAMPLE TEST Y1 Y2
41880C              COEFFICIENT OF VARIATION TWO SAMPLE TEST Y1 X1 Y2 X2
41881C     REFERENCES--JOHANNES FORKMAN (2009)), "ESTIMATOR AND TESTS FOR
41882C                 COMMON COEFFICIENTS OF VARIATION IN NORMAL
41883C                 DISTRIBUTIONS", COMMUNICATIONS IN STATISTICS -
41884C                 THEROY AND METHODS, Vol. 38, No. 2, pp. 233-251.
41885C     WRITTEN BY--ALAN HECKERT
41886C                 STATISTICAL ENGINEERING DIVISION
41887C                 INFORMATION TECHNOLOGY LABORATORY
41888C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
41889C                 GAITHERSBURG, MD 20899-8980
41890C                 PHONE--301-975-2899
41891C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
41892C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
41893C     LANGUAGE--ANSI FORTRAN (1977)
41894C     VERSION NUMBER--2017/06
41895C     ORIGINAL VERSION--JUNE      2017.
41896C
41897C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
41898C
41899      CHARACTER*4 IVARID
41900      CHARACTER*4 IVARI2
41901      CHARACTER*4 IVARI3
41902      CHARACTER*4 IVARI4
41903      CHARACTER*4 IVARI5
41904      CHARACTER*4 IVARI6
41905      CHARACTER*4 IVARI7
41906      CHARACTER*4 IVARI8
41907      CHARACTER*4 ICAPSW
41908      CHARACTER*4 ICAPTY
41909      CHARACTER*4 IFORSW
41910      CHARACTER*4 ICVTTE
41911      CHARACTER*4 ICASA2
41912      CHARACTER*4 ICASA3
41913      CHARACTER*4 IBUGA3
41914      CHARACTER*4 ISUBRO
41915      CHARACTER*4 IERROR
41916C
41917      CHARACTER*4 IWRITE
41918      CHARACTER*4 ISUBN1
41919      CHARACTER*4 ISUBN2
41920      CHARACTER*4 ISTEPN
41921      CHARACTER*4 ICASA5
41922C
41923C---------------------------------------------------------------------
41924C
41925      DIMENSION Y1(*)
41926      DIMENSION Y2(*)
41927      DIMENSION X1(*)
41928      DIMENSION X2(*)
41929      DIMENSION TEMP1(*)
41930      DIMENSION TEMP2(*)
41931C
41932      INTEGER ITEMP1(1)
41933C
41934      PARAMETER (NUMALP=6)
41935      REAL ALPHA(NUMALP)
41936C
41937      PARAMETER(NUMCLI=5)
41938      PARAMETER(MAXLIN=3)
41939      PARAMETER (MAXROW=NUMALP)
41940      PARAMETER (MAXRO2=40)
41941      CHARACTER*60 ITITLE
41942      CHARACTER*60 ITITLZ
41943      CHARACTER*60 ITITL9
41944      CHARACTER*60 ITEXT(MAXRO2)
41945      CHARACTER*4  ALIGN(NUMCLI)
41946      CHARACTER*4  VALIGN(NUMCLI)
41947      REAL         AVALUE(MAXRO2)
41948      INTEGER      NCTEXT(MAXRO2)
41949      INTEGER      IDIGIT(MAXRO2)
41950      INTEGER      NTOT(MAXRO2)
41951      CHARACTER*60 ITITL2(MAXLIN,NUMCLI)
41952      CHARACTER*15 IVALUE(MAXROW,NUMCLI)
41953      CHARACTER*4  ITYPCO(NUMCLI)
41954      INTEGER      NCTIT2(MAXLIN,NUMCLI)
41955      INTEGER      NCVALU(MAXROW,NUMCLI)
41956      INTEGER      IWHTML(NUMCLI)
41957      INTEGER      IWRTF(NUMCLI)
41958      REAL         AMAT(MAXROW,NUMCLI)
41959      LOGICAL IFRST
41960      LOGICAL ILAST
41961      LOGICAL IFLAGS
41962      LOGICAL IFLAGE
41963C
41964C---------------------------------------------------------------------
41965C
41966      INCLUDE 'DPCOP2.INC'
41967C
41968      DATA ALPHA/0.50, 0.80, 0.90, 0.95, 0.99, 0.999/
41969C
41970C-----START POINT-----------------------------------------------------
41971C
41972      ISUBN1='DPCV'
41973      ISUBN2='T2  '
41974      IERROR='NO'
41975      IWRITE='OFF'
41976C
41977      NUMDIG=7
41978      IF(IFORSW.EQ.'1')NUMDIG=1
41979      IF(IFORSW.EQ.'2')NUMDIG=2
41980      IF(IFORSW.EQ.'3')NUMDIG=3
41981      IF(IFORSW.EQ.'4')NUMDIG=4
41982      IF(IFORSW.EQ.'5')NUMDIG=5
41983      IF(IFORSW.EQ.'6')NUMDIG=6
41984      IF(IFORSW.EQ.'7')NUMDIG=7
41985      IF(IFORSW.EQ.'8')NUMDIG=8
41986      IF(IFORSW.EQ.'9')NUMDIG=9
41987      IF(IFORSW.EQ.'0')NUMDIG=0
41988      IF(IFORSW.EQ.'E')NUMDIG=-2
41989      IF(IFORSW.EQ.'-2')NUMDIG=-2
41990      IF(IFORSW.EQ.'-3')NUMDIG=-3
41991      IF(IFORSW.EQ.'-4')NUMDIG=-4
41992      IF(IFORSW.EQ.'-5')NUMDIG=-5
41993      IF(IFORSW.EQ.'-6')NUMDIG=-6
41994      IF(IFORSW.EQ.'-7')NUMDIG=-7
41995      IF(IFORSW.EQ.'-8')NUMDIG=-8
41996      IF(IFORSW.EQ.'-9')NUMDIG=-9
41997C
41998      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CVT2')THEN
41999        WRITE(ICOUT,999)
42000  999   FORMAT(1X)
42001        CALL DPWRST('XXX','WRIT')
42002        WRITE(ICOUT,51)
42003   51   FORMAT('**** AT THE BEGINNING OF DPCVT2--')
42004        CALL DPWRST('XXX','WRIT')
42005        WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASA2
42006   52   FORMAT('IBUGA3,ISUBRO = ',2(A4,2X),A4)
42007        CALL DPWRST('XXX','WRIT')
42008        WRITE(ICOUT,55)N1,N2,NUMDIG,MAXNXT,GAMMA0
42009   55   FORMAT('N1,N2,NUMDIG,MAXNXT,GAMMA0 = ',4I8,G15.7)
42010        CALL DPWRST('XXX','WRIT')
42011        IF(N1.GE.1)THEN
42012          DO56I=1,N1
42013            WRITE(ICOUT,57)I,X1(I),Y1(I)
42014   57       FORMAT('I,Y1(I),X1(I) = ',I8,2G15.7)
42015            CALL DPWRST('XXX','WRIT')
42016   56     CONTINUE
42017        ENDIF
42018        IF(N2.GE.1 .AND. ICASA2.EQ.'TWOS')THEN
42019          DO66I=1,N2
42020            WRITE(ICOUT,67)I,X2(I),Y2(I)
42021   67       FORMAT('I,X2(I),Y2(I) = ',I8,2G15.7)
42022            CALL DPWRST('XXX','WRIT')
42023   66     CONTINUE
42024        ENDIF
42025      ENDIF
42026C
42027C               ************************************
42028C               **   STEP 1--                     **
42029C               **   BRANCH DEPENDING ON WHETHER  **
42030C               **   1-SAMPLE TEST OR             **
42031C               **   2-SAMPLE TEST.               **
42032C               ************************************
42033C
42034      ISTEPN='1'
42035      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVT2')
42036     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
42037C
42038      IF(ICASA2.EQ.'ONES')THEN
42039        GOTO2100
42040      ELSEIF(ICASA2.EQ.'TWOS')THEN
42041        IF(ICVTTE.EQ.'MILL')THEN
42042          GOTO4100
42043        ELSE
42044          GOTO3100
42045        ENDIF
42046      ELSE
42047        GOTO9000
42048      ENDIF
42049C
42050C               ******************************
42051C               **  STEP 21--               **
42052C               **  CARRY OUT CALCULATIONS  **
42053C               **  FOR A 1-SAMPLE TEST     **
42054C               ******************************
42055C
42056 2100 CONTINUE
42057C
42058      ISTEPN='21'
42059      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVT2')
42060     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
42061C
42062      ICASA5='RAW'
42063      CALL DPCVT3(Y1,X1,ITEMP1,N1,GAMMA0,IWRITE,ICASA5,
42064     1            TEMP1,TEMP2,
42065     1            NDIST,NGROUP,YMEANT,YSDT,YCVT,
42066     1            STATVA,STATCD,STATNU,
42067     1            PVAL2T,PVALLT,PVALUT,
42068     1            ISUBRO,IBUGA3,IERROR)
42069      IF(IERROR.EQ.'YES')GOTO9000
42070C
42071      IDF=INT(STATNU+0.5)
42072      CALL CHSPPF(.0005,IDF,CTL999)
42073      CALL CHSPPF(.005,IDF,CUTL99)
42074      CALL CHSPPF(.025,IDF,CUTL95)
42075      CALL CHSPPF(.05,IDF,CUTL90)
42076      CALL CHSPPF(.1,IDF,CUTL80)
42077      CALL CHSPPF(.25,IDF,CUTL50)
42078      CALL CHSPPF(.75,IDF,CUTU50)
42079      CALL CHSPPF(.90,IDF,CUTU80)
42080      CALL CHSPPF(.95,IDF,CUTU90)
42081      CALL CHSPPF(.975,IDF,CUTU95)
42082      CALL CHSPPF(.995,IDF,CUTU99)
42083      CALL CHSPPF(.9995,IDF,CTU999)
42084C
42085C               ******************************
42086C               **   STEP 22--              **
42087C               **   WRITE OUT EVERYTHING   **
42088C               **   FOR A 1-SAMPLE TEST    **
42089C               ******************************
42090C
42091      ISTEPN='22'
42092      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVT2')
42093     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
42094C
42095      IF(IPRINT.EQ.'OFF')GOTO9000
42096C
42097      ITITLE='Forkman One Sample Coefficient of Variation Test'
42098      NCTITL=48
42099      ITITLZ=' '
42100      NCTITZ=0
42101C
42102      ICNT=1
42103      ITEXT(ICNT)=' '
42104      NCTEXT(ICNT)=0
42105      AVALUE(ICNT)=0.0
42106      IDIGIT(ICNT)=-1
42107C
42108      ICNT=ICNT+1
42109      ITEXT(ICNT)='Response Variable: '
42110      WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1:4)
42111      WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1:4)
42112      NCTEXT(ICNT)=27
42113      AVALUE(ICNT)=0.0
42114      IDIGIT(ICNT)=-1
42115C
42116      IF(NDIST.GT.1)THEN
42117        ICNT=ICNT+1
42118        ITEXT(ICNT)='Group-ID Variable: '
42119        WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARI3(1:4)
42120        WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI4(1:4)
42121        NCTEXT(ICNT)=27
42122        AVALUE(ICNT)=0.0
42123        IDIGIT(ICNT)=-1
42124      ENDIF
42125C
42126      ICNT=ICNT+1
42127      ITEXT(ICNT)=' '
42128      NCTEXT(ICNT)=1
42129      AVALUE(ICNT)=0.0
42130      IDIGIT(ICNT)=-1
42131C
42132      ICNT=ICNT+1
42133      ITEXT(ICNT)='H0: Coefficient of Variation Equal'
42134      NCTEXT(ICNT)=34
42135      AVALUE(ICNT)=GAMMA0
42136      IDIGIT(ICNT)=NUMDIG
42137      ICNT=ICNT+1
42138      IF(ICASA3.EQ.'TWOT')THEN
42139        ITEXT(ICNT)='Ha: Coefficient of Variation Not Equal'
42140        NCTEXT(ICNT)=38
42141      ELSEIF(ICASA3.EQ.'UPPE')THEN
42142        ITEXT(ICNT)='Ha: Coefficient of Variation >'
42143        NCTEXT(ICNT)=30
42144      ELSEIF(ICASA3.EQ.'LOWE')THEN
42145        ITEXT(ICNT)='Ha: Coefficient of Variation <'
42146        NCTEXT(ICNT)=30
42147      ENDIF
42148      AVALUE(ICNT)=GAMMA0
42149      IDIGIT(ICNT)=NUMDIG
42150C
42151      ICNT=ICNT+1
42152      ITEXT(ICNT)=' '
42153      NCTEXT(ICNT)=1
42154      AVALUE(ICNT)=0.0
42155      IDIGIT(ICNT)=-1
42156      ICNT=ICNT+1
42157      ITEXT(ICNT)='Summary Statistics:'
42158      NCTEXT(ICNT)=19
42159      AVALUE(ICNT)=0.0
42160      IDIGIT(ICNT)=-1
42161      ICNT=ICNT+1
42162      ITEXT(ICNT)='Total Number of Observations:'
42163      NCTEXT(ICNT)=29
42164      AVALUE(ICNT)=REAL(N1)
42165      IDIGIT(ICNT)=0
42166      ICNT=ICNT+1
42167      ITEXT(ICNT)='Number of Groups:'
42168      NCTEXT(ICNT)=29
42169      AVALUE(ICNT)=REAL(NDIST)
42170      IDIGIT(ICNT)=0
42171      ICNT=ICNT+1
42172      ITEXT(ICNT)='Number of Groups Included in Test:'
42173      NCTEXT(ICNT)=34
42174      AVALUE(ICNT)=REAL(NGROUP)
42175      IDIGIT(ICNT)=0
42176      IF(NDIST.EQ.1)THEN
42177        ICNT=ICNT+1
42178        ITEXT(ICNT)='Sample Mean:'
42179        NCTEXT(ICNT)=12
42180        AVALUE(ICNT)=YMEANT
42181        IDIGIT(ICNT)=NUMDIG
42182        ICNT=ICNT+1
42183        ITEXT(ICNT)='Sample Standard Deviation:'
42184        NCTEXT(ICNT)=26
42185        AVALUE(ICNT)=YSDT
42186        IDIGIT(ICNT)=NUMDIG
42187        ICNT=ICNT+1
42188        ITEXT(ICNT)='Sample Coefficient of Variation:'
42189        NCTEXT(ICNT)=32
42190        AVALUE(ICNT)=YCVT
42191        IDIGIT(ICNT)=NUMDIG
42192      ELSE
42193        ICNT=ICNT+1
42194        ITEXT(ICNT)='Sample Common Coefficient of Variation:'
42195        NCTEXT(ICNT)=39
42196        AVALUE(ICNT)=YCVT
42197        IDIGIT(ICNT)=NUMDIG
42198      ENDIF
42199      ICNT=ICNT+1
42200      ITEXT(ICNT)=' '
42201      NCTEXT(ICNT)=1
42202      AVALUE(ICNT)=0.0
42203      IDIGIT(ICNT)=-1
42204C
42205      ICNT=ICNT+1
42206      ITEXT(ICNT)='Test:'
42207      NCTEXT(ICNT)=5
42208      AVALUE(ICNT)=0.0
42209      IDIGIT(ICNT)=-1
42210      ICNT=ICNT+1
42211      ITEXT(ICNT)='Gamma0:'
42212      NCTEXT(ICNT)=7
42213      AVALUE(ICNT)=GAMMA0
42214      IDIGIT(ICNT)=NUMDIG
42215      ICNT=ICNT+1
42216      ITEXT(ICNT)='Test Statistic Value:'
42217      NCTEXT(ICNT)=21
42218      AVALUE(ICNT)=STATVA
42219      IDIGIT(ICNT)=NUMDIG
42220      ICNT=ICNT+1
42221      ITEXT(ICNT)='Degrees of Freedom:'
42222      NCTEXT(ICNT)=19
42223      AVALUE(ICNT)=INT(STATNU+0.1)
42224      IDIGIT(ICNT)=0
42225      ICNT=ICNT+1
42226      ITEXT(ICNT)='CDF Value:'
42227      NCTEXT(ICNT)=10
42228      AVALUE(ICNT)=STATCD
42229      IDIGIT(ICNT)=NUMDIG
42230      ICNT=ICNT+1
42231      ITEXT(ICNT)='P-Value (2-tailed test):'
42232      NCTEXT(ICNT)=24
42233      AVALUE(ICNT)=PVAL2T
42234      IDIGIT(ICNT)=NUMDIG
42235      ICNT=ICNT+1
42236      ITEXT(ICNT)='P-Value (lower-tailed test):'
42237      NCTEXT(ICNT)=28
42238      AVALUE(ICNT)=PVALLT
42239      IDIGIT(ICNT)=NUMDIG
42240      ICNT=ICNT+1
42241      ITEXT(ICNT)='P-Value (upper-tailed test):'
42242      NCTEXT(ICNT)=28
42243      AVALUE(ICNT)=PVALUT
42244      IDIGIT(ICNT)=NUMDIG
42245C
42246      NUMROW=ICNT
42247      DO2110I=1,NUMROW
42248        NTOT(I)=15
42249 2110 CONTINUE
42250C
42251      IFRST=.TRUE.
42252      ILAST=.TRUE.
42253C
42254      ISTEPN='21A'
42255      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVT2')
42256     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
42257C
42258      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
42259     1            AVALUE,IDIGIT,
42260     1            NTOT,NUMROW,
42261     1            ICAPSW,ICAPTY,ILAST,IFRST,
42262     1            ISUBRO,IBUGA3,IERROR)
42263C
42264      ISTEPN='21B'
42265      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVT2')
42266     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
42267C
42268      ITITLE='Two-Tailed Test'
42269      NCTITL=15
42270      ITITL9='H0: Gamma = Gamma0; Ha: Gamma <> Gamma0'
42271      NCTIT9=39
42272C
42273      DO2130J=1,5
42274        DO2140I=1,3
42275          ITITL2(I,J)=' '
42276          NCTIT2(I,J)=0
42277 2140   CONTINUE
42278 2130 CONTINUE
42279C
42280      ITITL2(2,1)='Significance'
42281      NCTIT2(2,1)=12
42282      ITITL2(3,1)='Level'
42283      NCTIT2(3,1)=5
42284C
42285      ITITL2(2,2)='Test '
42286      NCTIT2(2,2)=4
42287      ITITL2(3,2)='Statistic'
42288      NCTIT2(3,2)=9
42289C
42290      ITITL2(1,3)='Lower'
42291      NCTIT2(1,3)=5
42292      ITITL2(2,3)='Critical'
42293      NCTIT2(2,3)=8
42294      ITITL2(3,3)='Value'
42295      NCTIT2(3,3)=5
42296C
42297      ITITL2(1,4)='Upper'
42298      NCTIT2(1,4)=5
42299      ITITL2(2,4)='Critical'
42300      NCTIT2(2,4)=8
42301      ITITL2(3,4)='Value'
42302      NCTIT2(3,4)=5
42303C
42304      ITITL2(1,5)='Null'
42305      NCTIT2(1,5)=4
42306      ITITL2(2,5)='Hypothesis'
42307      NCTIT2(2,5)=10
42308      ITITL2(3,5)='Conclusion'
42309      NCTIT2(3,5)=10
42310C
42311      NMAX=0
42312      NUMCOL=5
42313      DO2150I=1,NUMCOL
42314        VALIGN(I)='b'
42315        ALIGN(I)='r'
42316        NTOT(I)=15
42317        NMAX=NMAX+NTOT(I)
42318        ITYPCO(I)='NUME'
42319        IDIGIT(I)=NUMDIG
42320        IF(I.EQ.1 .OR. I.EQ.5)THEN
42321          ITYPCO(I)='ALPH'
42322        ENDIF
42323 2150 CONTINUE
42324C
42325      IWHTML(1)=125
42326      IWHTML(2)=175
42327      IWHTML(3)=175
42328      IWHTML(4)=175
42329      IWHTML(5)=175
42330      IINC=1800
42331      IINC2=1400
42332      IWRTF(1)=IINC
42333      IWRTF(2)=IWRTF(1)+IINC
42334      IWRTF(3)=IWRTF(2)+IINC
42335      IWRTF(4)=IWRTF(3)+IINC
42336      IWRTF(5)=IWRTF(4)+IINC
42337C
42338      DO2160J=1,NUMALP
42339C
42340        ALPHAT=(1.0 - ALPHA(J))/2.0
42341        CALL CHSPPF(ALPHAT,IDF,ALOWCV)
42342        ALPHT2=1.0 - ALPHAT
42343        CALL CHSPPF(ALPHT2,IDF,AUPPCV)
42344        ALPHAT=100.0*ALPHA(J)
42345        WRITE(IVALUE(J,1)(1:4),'(F4.1)')ALPHAT
42346        IVALUE(J,1)(5:5)='%'
42347        NCVALU(J,1)=5
42348C
42349        AMAT(J,2)=STATVA
42350        AMAT(J,3)=ALOWCV
42351        AMAT(J,4)=AUPPCV
42352        IVALUE(J,5)(1:6)='REJECT'
42353        IF(STATVA.GE.AMAT(J,3).AND.STATVA.LE.AMAT(J,4))THEN
42354          IVALUE(J,5)(1:6)='ACCEPT'
42355        ENDIF
42356        NCVALU(J,5)=6
42357C
42358 2160 CONTINUE
42359C
42360      ICNT=NUMALP
42361      NUMLIN=3
42362      NUMCOL=5
42363      IFRST=.TRUE.
42364      ILAST=.TRUE.
42365      IFLAGS=.TRUE.
42366      IFLAGE=.TRUE.
42367      IF(ICASA3.EQ.'TWOT')THEN
42368        CALL DPDTA5(ITITLE,NCTITL,
42369     1              ITITL9,NCTIT9,ITITL2,NCTIT2,
42370     1              MAXLIN,NUMLIN,NUMCLI,NUMCOL,
42371     1              IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
42372     1              IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
42373     1              ICAPSW,ICAPTY,IFRST,ILAST,
42374     1              IFLAGS,IFLAGE,
42375     1              ISUBRO,IBUGA3,IERROR)
42376      ENDIF
42377      IF(ICASA3.EQ.'TWOT')GOTO9000
42378C
42379      ITITLE='Lower One-Tailed Test'
42380      NCTITL=21
42381      ITITL9='H0: Gamma = Gamma0; Ha: Gamma < Gamma0'
42382      NCTIT9=38
42383C
42384      ITITL2(1,3)=' '
42385      NCTIT2(1,3)=0
42386      ITITL2(2,3)='Critical'
42387      NCTIT2(2,3)=8
42388      ITITL2(3,3)='Value (<)'
42389      NCTIT2(3,3)=9
42390C
42391      ITITL2(1,4)='Null'
42392      NCTIT2(1,4)=4
42393      ITITL2(2,4)='Hypothesis'
42394      NCTIT2(2,4)=10
42395      ITITL2(3,4)='Conclusion'
42396      NCTIT2(3,4)=10
42397C
42398      NMAX=0
42399      NUMCOL=4
42400      DO2250I=1,NUMCOL
42401        NTOT(I)=15
42402        NMAX=NMAX+NTOT(I)
42403        IF(I.EQ.1 .OR. I.EQ.4)THEN
42404          ITYPCO(I)='ALPH'
42405        ENDIF
42406 2250 CONTINUE
42407C
42408      IDF=INT(STATNU+0.5)
42409      DO2260J=1,NUMALP
42410        ALPHAT=1.0 - ALPHA(J)
42411        CALL CHSPPF(ALPHAT,IDF,ATEMP)
42412        AMAT(J,3)=ATEMP
42413        IVALUE(J,4)(1:6)='REJECT'
42414        IF(STATVA.GE.AMAT(J,3))THEN
42415          IVALUE(J,4)(1:6)='ACCEPT'
42416        ENDIF
42417        NCVALU(J,4)=6
42418 2260 CONTINUE
42419C
42420      ICNT=NUMALP
42421      NUMLIN=3
42422      IFRST=.TRUE.
42423      ILAST=.TRUE.
42424      IFLAGS=.TRUE.
42425      IFLAGE=.TRUE.
42426      IF(ICASA3.NE.'UPPE')THEN
42427        CALL DPDTA5(ITITLE,NCTITL,
42428     1              ITITL9,NCTIT9,ITITL2,NCTIT2,
42429     1              MAXLIN,NUMLIN,NUMCLI,NUMCOL,
42430     1              IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
42431     1              IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
42432     1              ICAPSW,ICAPTY,IFRST,ILAST,
42433     1              IFLAGS,IFLAGE,
42434     1              ISUBRO,IBUGA3,IERROR)
42435      ENDIF
42436C
42437      IF(ICASA3.EQ.'LOWE')GOTO9000
42438C
42439      ITITLE='Upper One-Tailed Test'
42440      NCTITL=21
42441      ITITL9='H0: Gamma = Gamma0; Ha: Gamma > Gamma0'
42442      NCTIT9=38
42443C
42444      ITITL2(2,3)='Critical'
42445      NCTIT2(2,3)=8
42446      ITITL2(3,3)='Value (>)'
42447      NCTIT2(3,3)=9
42448C
42449      NMAX=0
42450      NUMCOL=4
42451      DO2350I=1,NUMCOL
42452        NTOT(I)=15
42453        NMAX=NMAX+NTOT(I)
42454 2350 CONTINUE
42455C
42456      IDF=INT(STATNU+0.5)
42457      DO2360J=1,NUMALP
42458        ALPHAT=ALPHA(J)
42459        CALL CHSPPF(ALPHAT,IDF,ATEMP)
42460        AMAT(J,3)=ATEMP
42461        IVALUE(J,4)(1:6)='REJECT'
42462        IF(STATVA.LE.AMAT(J,3))THEN
42463          IVALUE(J,4)(1:6)='ACCEPT'
42464        ENDIF
42465        NCVALU(J,4)=6
42466 2360 CONTINUE
42467C
42468      ICNT=NUMALP
42469      NUMLIN=3
42470      IFRST=.TRUE.
42471      ILAST=.TRUE.
42472      IFLAGS=.TRUE.
42473      IFLAGE=.TRUE.
42474      CALL DPDTA5(ITITLE,NCTITL,
42475     1            ITITL9,NCTIT9,ITITL2,NCTIT2,
42476     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
42477     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
42478     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
42479     1            ICAPSW,ICAPTY,IFRST,ILAST,
42480     1            IFLAGS,IFLAGE,
42481     1            ISUBRO,IBUGA3,IERROR)
42482C
42483      GOTO9000
42484C
42485C               ****************************************
42486C               **  STEP 31--                         **
42487C               **  CARRY OUT CALCULATIONS            **
42488C               **  FOR A 2-SAMPLE TEST               **
42489C               **  (FORKMAN TEST)                    **
42490C               ****************************************
42491C
42492 3100 CONTINUE
42493C
42494      ISTEPN='31'
42495      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVT2')
42496     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
42497C
42498      CALL DPCVT4(Y1,X1,N1,Y2,X2,N2,IWRITE,
42499     1            TEMP1,TEMP2,NGROU1,NGROU2,
42500     1            Y1MEAN,Y1SD,Y1CV,Y2MEAN,Y2SD,Y2CV,
42501     1            STATVA,STATCD,STATN1,STATN2,
42502     1            PVAL2T,PVALLT,PVALUT,
42503     1            ISUBRO,IBUGA3,IERROR)
42504      IF(IERROR.EQ.'YES')GOTO9000
42505C
42506C               ******************************
42507C               **   STEP 32--              **
42508C               **   WRITE OUT EVERYTHING   **
42509C               **   FOR A 2-SAMPLE TEST    **
42510C               ******************************
42511C
42512      ISTEPN='32'
42513      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVT2')
42514     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
42515C
42516      IF(IPRINT.EQ.'OFF')GOTO9000
42517C
42518      ITITLE=
42519     1  'Forkman Two Sample Test for Equal Coefficient of Variations'
42520      NCTITL=59
42521      ITITLZ=' '
42522      NCTITZ=0
42523C
42524      ICNT=1
42525      ITEXT(ICNT)=' '
42526      NCTEXT(ICNT)=0
42527      AVALUE(ICNT)=0.0
42528      IDIGIT(ICNT)=-1
42529C
42530      ICNT=ICNT+1
42531      ITEXT(ICNT)='First Response Variable:  '
42532      WRITE(ITEXT(ICNT)(27:30),'(A4)')IVARID(1:4)
42533      WRITE(ITEXT(ICNT)(31:34),'(A4)')IVARI2(1:4)
42534      NCTEXT(ICNT)=34
42535      AVALUE(ICNT)=0.0
42536      IDIGIT(ICNT)=-1
42537      IF(NGROU1.GT.1)THEN
42538        ICNT=ICNT+1
42539        ITEXT(ICNT)='First Group-ID Variable:  '
42540        WRITE(ITEXT(ICNT)(27:30),'(A4)')IVARI3(1:4)
42541        WRITE(ITEXT(ICNT)(31:34),'(A4)')IVARI4(1:4)
42542        NCTEXT(ICNT)=34
42543        AVALUE(ICNT)=0.0
42544        IDIGIT(ICNT)=-1
42545      ENDIF
42546C
42547      ICNT=ICNT+1
42548      ITEXT(ICNT)='Second Response Variable: '
42549      IF(NGROU1.GT.1)THEN
42550        WRITE(ITEXT(ICNT)(27:30),'(A4)')IVARI5(1:4)
42551        WRITE(ITEXT(ICNT)(31:34),'(A4)')IVARI6(1:4)
42552      ELSE
42553        WRITE(ITEXT(ICNT)(27:30),'(A4)')IVARI3(1:4)
42554        WRITE(ITEXT(ICNT)(31:34),'(A4)')IVARI4(1:4)
42555      ENDIF
42556      NCTEXT(ICNT)=34
42557      AVALUE(ICNT)=0.0
42558      IDIGIT(ICNT)=-1
42559      IF(NGROU2.GT.1)THEN
42560        ICNT=ICNT+1
42561        ITEXT(ICNT)='Second Group-ID Variable:  '
42562        IF(NGROU1.GT.1)THEN
42563          WRITE(ITEXT(ICNT)(28:31),'(A4)')IVARI7(1:4)
42564          WRITE(ITEXT(ICNT)(32:35),'(A4)')IVARI8(1:4)
42565        ELSE
42566          WRITE(ITEXT(ICNT)(28:31),'(A4)')IVARI5(1:4)
42567          WRITE(ITEXT(ICNT)(32:35),'(A4)')IVARI6(1:4)
42568        ENDIF
42569        NCTEXT(ICNT)=35
42570        AVALUE(ICNT)=0.0
42571        IDIGIT(ICNT)=-1
42572      ENDIF
42573C
42574      ICNT=ICNT+1
42575      ITEXT(ICNT)=' '
42576      NCTEXT(ICNT)=0
42577      AVALUE(ICNT)=0.0
42578      IDIGIT(ICNT)=-1
42579C
42580      ICNT=ICNT+1
42581      ITEXT(ICNT)='H0: Population Coefficients of Variation'
42582      NCTEXT(ICNT)=40
42583      AVALUE(ICNT)=0.0
42584      IDIGIT(ICNT)=-1
42585      ICNT=ICNT+1
42586      ITEXT(ICNT)='    Are Equal (gamma1 = gamma2)'
42587      NCTEXT(ICNT)=31
42588      AVALUE(ICNT)=0.0
42589      IDIGIT(ICNT)=-1
42590      ICNT=ICNT+1
42591      IF(ICASA3.EQ.'TWOT')THEN
42592        ITEXT(ICNT)='Ha: gamma1 <> gamma2'
42593        NCTEXT(ICNT)=20
42594      ELSEIF(ICASA3.EQ.'UPPE')THEN
42595        ITEXT(ICNT)='Ha: gamma1 > gamma2'
42596        NCTEXT(ICNT)=19
42597      ELSEIF(ICASA3.EQ.'LOWE')THEN
42598        ITEXT(ICNT)='Ha: gamma1 < gamma2'
42599        NCTEXT(ICNT)=19
42600      ENDIF
42601      AVALUE(ICNT)=0.0
42602      IDIGIT(ICNT)=-1
42603C
42604      ICNT=ICNT+1
42605      ITEXT(ICNT)=' '
42606      NCTEXT(ICNT)=1
42607      AVALUE(ICNT)=0.0
42608      IDIGIT(ICNT)=-1
42609C
42610      ICNT=ICNT+1
42611      ITEXT(ICNT)='Sample One Summary Statistics:'
42612      NCTEXT(ICNT)=30
42613      AVALUE(ICNT)=0.0
42614      IDIGIT(ICNT)=-1
42615      ICNT=ICNT+1
42616      ITEXT(ICNT)='Total Number of Observations:'
42617      NCTEXT(ICNT)=29
42618      AVALUE(ICNT)=REAL(N1)
42619      IDIGIT(ICNT)=0
42620      ICNT=ICNT+1
42621      ITEXT(ICNT)='Number of Groups Included:'
42622      NCTEXT(ICNT)=26
42623      AVALUE(ICNT)=REAL(NGROU1)
42624      IDIGIT(ICNT)=0
42625      IF(NGROU1.EQ.1)THEN
42626        ICNT=ICNT+1
42627        ITEXT(ICNT)='Sample Mean:'
42628        NCTEXT(ICNT)=12
42629        AVALUE(ICNT)=Y1MEAN
42630        IDIGIT(ICNT)=NUMDIG
42631        ICNT=ICNT+1
42632        ITEXT(ICNT)='Sample Standard Deviation:'
42633        NCTEXT(ICNT)=26
42634        AVALUE(ICNT)=Y1SD
42635        IDIGIT(ICNT)=NUMDIG
42636        ICNT=ICNT+1
42637        ITEXT(ICNT)='Sample Coefficient of Variation:'
42638        NCTEXT(ICNT)=32
42639        AVALUE(ICNT)=Y1CV
42640        IDIGIT(ICNT)=NUMDIG
42641      ELSE
42642        ICNT=ICNT+1
42643        ITEXT(ICNT)='Sample Common Coefficient of Variation:'
42644        NCTEXT(ICNT)=39
42645        AVALUE(ICNT)=Y1CV
42646        IDIGIT(ICNT)=NUMDIG
42647      ENDIF
42648      ICNT=ICNT+1
42649      ITEXT(ICNT)=' '
42650      NCTEXT(ICNT)=1
42651      AVALUE(ICNT)=0.0
42652      IDIGIT(ICNT)=-1
42653C
42654      ICNT=ICNT+1
42655      ITEXT(ICNT)='Sample Two Summary Statistics:'
42656      NCTEXT(ICNT)=30
42657      AVALUE(ICNT)=0.0
42658      IDIGIT(ICNT)=-1
42659      ICNT=ICNT+1
42660      ITEXT(ICNT)='Total Number of Observations:'
42661      NCTEXT(ICNT)=29
42662      AVALUE(ICNT)=REAL(N2)
42663      IDIGIT(ICNT)=0
42664      ICNT=ICNT+1
42665      ITEXT(ICNT)='Number of Included Groups:'
42666      NCTEXT(ICNT)=26
42667      AVALUE(ICNT)=REAL(NGROU2)
42668      IDIGIT(ICNT)=0
42669      IF(NGROU2.EQ.1)THEN
42670        ICNT=ICNT+1
42671        ITEXT(ICNT)='Sample Mean:'
42672        NCTEXT(ICNT)=12
42673        AVALUE(ICNT)=Y2MEAN
42674        IDIGIT(ICNT)=NUMDIG
42675        ICNT=ICNT+1
42676        ITEXT(ICNT)='Sample Standard Deviation:'
42677        NCTEXT(ICNT)=26
42678        AVALUE(ICNT)=Y2SD
42679        IDIGIT(ICNT)=NUMDIG
42680        ICNT=ICNT+1
42681        ITEXT(ICNT)='Sample Coefficient of Variation:'
42682        NCTEXT(ICNT)=32
42683        AVALUE(ICNT)=Y2CV
42684        IDIGIT(ICNT)=NUMDIG
42685      ELSE
42686        ICNT=ICNT+1
42687        ITEXT(ICNT)='Sample Common Coefficient of Variation:'
42688        NCTEXT(ICNT)=39
42689        AVALUE(ICNT)=Y2CV
42690        IDIGIT(ICNT)=NUMDIG
42691      ENDIF
42692      ICNT=ICNT+1
42693      ITEXT(ICNT)=' '
42694      NCTEXT(ICNT)=1
42695      AVALUE(ICNT)=0.0
42696      IDIGIT(ICNT)=-1
42697C
42698      ICNT=ICNT+1
42699      ITEXT(ICNT)='Forkman Test Statistic Value:'
42700      NCTEXT(ICNT)=29
42701      AVALUE(ICNT)=STATVA
42702      IDIGIT(ICNT)=NUMDIG
42703      ICNT=ICNT+1
42704      ITEXT(ICNT)='Degrees of Freedom 1:'
42705      NCTEXT(ICNT)=19
42706      AVALUE(ICNT)=STATN1
42707      IDIGIT(ICNT)=0
42708      ICNT=ICNT+1
42709      ITEXT(ICNT)='Degrees of Freedom 2:'
42710      NCTEXT(ICNT)=19
42711      AVALUE(ICNT)=STATN2
42712      IDIGIT(ICNT)=0
42713      ICNT=ICNT+1
42714      ITEXT(ICNT)='CDF Value:'
42715      NCTEXT(ICNT)=10
42716      AVALUE(ICNT)=STATCD
42717      IDIGIT(ICNT)=NUMDIG
42718      ICNT=ICNT+1
42719      ITEXT(ICNT)='P-Value (2-tailed test):'
42720      NCTEXT(ICNT)=24
42721      AVALUE(ICNT)=PVAL2T
42722      IDIGIT(ICNT)=NUMDIG
42723      ICNT=ICNT+1
42724      ITEXT(ICNT)='P-Value (lower-tailed test):'
42725      NCTEXT(ICNT)=28
42726      AVALUE(ICNT)=PVALLT
42727      IDIGIT(ICNT)=NUMDIG
42728      ICNT=ICNT+1
42729      ITEXT(ICNT)='P-Value (upper-tailed test):'
42730      NCTEXT(ICNT)=28
42731      AVALUE(ICNT)=PVALUT
42732      IDIGIT(ICNT)=NUMDIG
42733C
42734      NUMROW=ICNT
42735      DO3110I=1,NUMROW
42736        NTOT(I)=15
42737 3110 CONTINUE
42738C
42739      IFRST=.TRUE.
42740      ILAST=.TRUE.
42741C
42742      ISTEPN='31A'
42743      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVT2')
42744     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
42745C
42746      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
42747     1            AVALUE,IDIGIT,
42748     1            NTOT,NUMROW,
42749     1            ICAPSW,ICAPTY,ILAST,IFRST,
42750     1            ISUBRO,IBUGA3,IERROR)
42751C
42752      ISTEPN='31B'
42753      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVT2')
42754     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
42755C
42756      IDF1=INT(STATN1+0.5)
42757      IDF2=INT(STATN2+0.5)
42758C
42759      CALL FPPF(.0005,IDF1,IDF2,CTL999)
42760      CALL FPPF(.005,IDF1,IDF2,CUTL99)
42761      CALL FPPF(.025,IDF1,IDF2,CUTL95)
42762      CALL FPPF(.05,IDF1,IDF2,CUTL90)
42763      CALL FPPF(.1,IDF1,IDF2,CUTL80)
42764      CALL FPPF(.25,IDF1,IDF2,CUTL50)
42765      CALL FPPF(.75,IDF1,IDF2,CUTU50)
42766      CALL FPPF(.90,IDF1,IDF2,CUTU80)
42767      CALL FPPF(.95,IDF1,IDF2,CUTU90)
42768      CALL FPPF(.975,IDF1,IDF2,CUTU95)
42769      CALL FPPF(.995,IDF1,IDF2,CUTU99)
42770      CALL FPPF(.9995,IDF1,IDF2,CTU999)
42771C
42772      ITITL9='H0: gamma1 = gamma2; Ha: gamma1 <> gamma2'
42773      NCTIT9=41
42774C
42775      DO3130J=1,5
42776        DO3140I=1,3
42777          ITITL2(I,J)=' '
42778          NCTIT2(I,J)=0
42779 3140   CONTINUE
42780 3130 CONTINUE
42781C
42782      ITITL2(2,1)='Significance'
42783      NCTIT2(2,1)=12
42784      ITITL2(3,1)='Level'
42785      NCTIT2(3,1)=5
42786C
42787      ITITL2(2,2)='Test '
42788      NCTIT2(2,2)=4
42789      ITITL2(3,2)='Statistic'
42790      NCTIT2(3,2)=9
42791C
42792      ITITL2(1,3)='Lower'
42793      NCTIT2(1,3)=5
42794      ITITL2(2,3)='Critical'
42795      NCTIT2(2,3)=8
42796      ITITL2(3,3)='Value'
42797      NCTIT2(3,3)=5
42798C
42799      ITITL2(1,4)='Upper'
42800      NCTIT2(1,4)=5
42801      ITITL2(2,4)='Critical'
42802      NCTIT2(2,4)=8
42803      ITITL2(3,4)='Value'
42804      NCTIT2(3,4)=5
42805C
42806      ITITL2(1,5)='Null'
42807      NCTIT2(1,5)=4
42808      ITITL2(2,5)='Hypothesis'
42809      NCTIT2(2,5)=10
42810      ITITL2(3,5)='Conclusion'
42811      NCTIT2(3,5)=10
42812C
42813      NMAX=0
42814      NUMCOL=5
42815      DO3150I=1,NUMCOL
42816        VALIGN(I)='b'
42817        ALIGN(I)='r'
42818        NTOT(I)=15
42819        NMAX=NMAX+NTOT(I)
42820        ITYPCO(I)='NUME'
42821        IDIGIT(I)=NUMDIG
42822        IF(I.EQ.1 .OR. I.EQ.5)THEN
42823          ITYPCO(I)='ALPH'
42824        ENDIF
42825 3150 CONTINUE
42826C
42827      IWHTML(1)=125
42828      IWHTML(2)=175
42829      IWHTML(3)=175
42830      IWHTML(4)=175
42831      IWHTML(5)=175
42832      IINC=1800
42833      IINC2=1400
42834      IWRTF(1)=IINC
42835      IWRTF(2)=IWRTF(1)+IINC
42836      IWRTF(3)=IWRTF(2)+IINC
42837      IWRTF(4)=IWRTF(3)+IINC
42838      IWRTF(5)=IWRTF(4)+IINC
42839C
42840      DO3160J=1,NUMALP
42841C
42842        ALPHAT=(1.0 - ALPHA(J))/2.0
42843        CALL FPPF(ALPHAT,IDF1,IDF2,ALOWCV)
42844        ALPHT2=1.0 - ALPHAT
42845        CALL FPPF(ALPHT2,IDF1,IDF2,AUPPCV)
42846        ALPHAT=100.0*ALPHA(J)
42847        WRITE(IVALUE(J,1)(1:4),'(F4.1)')ALPHAT
42848        IVALUE(J,1)(5:5)='%'
42849        NCVALU(J,1)=5
42850C
42851        AMAT(J,2)=STATVA
42852        AMAT(J,3)=ALOWCV
42853        AMAT(J,4)=AUPPCV
42854        IVALUE(J,5)(1:6)='REJECT'
42855        IF(STATVA.GE.AMAT(J,3).AND.STATVA.LE.AMAT(J,4))THEN
42856          IVALUE(J,5)(1:6)='ACCEPT'
42857        ENDIF
42858        NCVALU(J,5)=6
42859C
42860 3160 CONTINUE
42861C
42862      ICNT=NUMALP
42863      NUMLIN=3
42864      NUMCOL=5
42865      IFRST=.TRUE.
42866      ILAST=.TRUE.
42867      IFLAGS=.TRUE.
42868      IFLAGE=.TRUE.
42869      IF(ICASA3.NE.'LOWE' .AND. ICASA3.NE.'UPPE')THEN
42870        CALL DPDTA5(ITITLE,NCTITL,
42871     1              ITITL9,NCTIT9,ITITL2,NCTIT2,
42872     1              MAXLIN,NUMLIN,NUMCLI,NUMCOL,
42873     1              IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
42874     1              IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
42875     1              ICAPSW,ICAPTY,IFRST,ILAST,
42876     1              IFLAGS,IFLAGE,
42877     1              ISUBRO,IBUGA3,IERROR)
42878      ENDIF
42879      IF(ICASA3.EQ.'TWOT')GOTO3199
42880C
42881      IF(ICASA3.EQ.'LOWE')THEN
42882        ITITLE='Lower One-Tailed Test'
42883        NCTITL=21
42884        ITITL9='H0: gamma1 = gamma2; Ha: gamma1 < gamma2'
42885        NCTIT9=40
42886        ITITL2(1,3)=' '
42887        NCTIT2(1,3)=0
42888        ITITL2(2,3)='Critical'
42889        NCTIT2(2,3)=8
42890        ITITL2(3,3)='Value (<)'
42891        NCTIT2(3,3)=9
42892      ELSEIF(ICASA3.EQ.'UPPE')THEN
42893        ITITLE='Upper One-Tailed Test'
42894        NCTITL=21
42895        ITITL9='H0: gamma1 = gamma2; Ha: gamma1 > gamma2'
42896        NCTIT9=40
42897        NCTIT2(1,3)=0
42898        ITITL2(2,3)='Critical'
42899        NCTIT2(2,3)=8
42900        ITITL2(3,3)='Value (>)'
42901        NCTIT2(3,3)=9
42902      ENDIF
42903C
42904      ITITL2(1,4)='Null'
42905      NCTIT2(1,4)=4
42906      ITITL2(2,4)='Hypothesis'
42907      NCTIT2(2,4)=10
42908      ITITL2(3,4)='Conclusion'
42909      NCTIT2(3,4)=10
42910C
42911      NMAX=0
42912      NUMCOL=4
42913      DO3250I=1,NUMCOL
42914        NTOT(I)=15
42915        NMAX=NMAX+NTOT(I)
42916        IF(I.EQ.1 .OR. I.EQ.4)ITYPCO(I)='ALPH'
42917 3250 CONTINUE
42918C
42919      DO3260J=1,NUMALP
42920        IF(ICASA3.EQ.'UPPE')THEN
42921          ALPHAT=ALPHA(J)
42922        ELSE
42923          ALPHAT=1.0 - ALPHA(J)
42924        ENDIF
42925        CALL FPPF(ALPHAT,IDF1,IDF2,ATEMP)
42926        AMAT(J,3)=ATEMP
42927        IVALUE(J,4)(1:6)='REJECT'
42928        IF(ICASA3.EQ.'UPPE')THEN
42929          IF(STATVA.GE.AMAT(J,3))THEN
42930            IVALUE(J,4)(1:6)='ACCEPT'
42931          ENDIF
42932        ELSE
42933          IF(STATVA.LE.AMAT(J,3))THEN
42934            IVALUE(J,4)(1:6)='ACCEPT'
42935          ENDIF
42936        ENDIF
42937        NCVALU(J,4)=6
42938 3260 CONTINUE
42939C
42940        ICNT=NUMALP
42941        NUMLIN=3
42942        NUMCOL=4
42943        IFRST=.TRUE.
42944        ILAST=.TRUE.
42945        IFLAGS=.TRUE.
42946        IFLAGE=.TRUE.
42947        CALL DPDTA5(ITITLE,NCTITL,
42948     1              ITITL9,NCTIT9,ITITL2,NCTIT2,
42949     1              MAXLIN,NUMLIN,NUMCLI,NUMCOL,
42950     1              IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
42951     1              IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
42952     1              ICAPSW,ICAPTY,IFRST,ILAST,
42953     1              IFLAGS,IFLAGE,
42954     1              ISUBRO,IBUGA3,IERROR)
42955C
42956 3199 CONTINUE
42957      GOTO9000
42958C
42959C               ****************************************
42960C               **  STEP 41--                         **
42961C               **  CARRY OUT CALCULATIONS            **
42962C               **  FOR A 2-SAMPLE TEST               **
42963C               **  (MILLER TEST)                     **
42964C               ****************************************
42965C
42966 4100 CONTINUE
42967C
42968      ISTEPN='41'
42969      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVT2')
42970     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
42971C
42972      CALL DPCVT6(Y1,N1,Y2,N2,IWRITE,
42973     1            Y1MEAN,Y1SD,Y1CV,Y2MEAN,Y2SD,Y2CV,
42974     1            STATVA,STATCD,PVAL2T,PVALLT,PVALUT,
42975     1            ISUBRO,IBUGA3,IERROR)
42976      IF(IERROR.EQ.'YES')GOTO9000
42977C
42978C               ******************************
42979C               **   STEP 42--              **
42980C               **   WRITE OUT EVERYTHING   **
42981C               **   FOR A 2-SAMPLE TEST    **
42982C               ******************************
42983C
42984      ISTEPN='42'
42985      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVT2')
42986     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
42987C
42988      IF(IPRINT.EQ.'OFF')GOTO9000
42989C
42990      ITITLE=
42991     1  'Miller Two Sample Test for Equal Coefficient of Variations'
42992      NCTITL=58
42993      ITITLZ=' '
42994      NCTITZ=0
42995C
42996      ICNT=1
42997      ITEXT(ICNT)=' '
42998      NCTEXT(ICNT)=0
42999      AVALUE(ICNT)=0.0
43000      IDIGIT(ICNT)=-1
43001C
43002      ICNT=ICNT+1
43003      ITEXT(ICNT)='First Response Variable:  '
43004      WRITE(ITEXT(ICNT)(27:30),'(A4)')IVARID(1:4)
43005      WRITE(ITEXT(ICNT)(31:34),'(A4)')IVARI2(1:4)
43006      NCTEXT(ICNT)=34
43007      AVALUE(ICNT)=0.0
43008      IDIGIT(ICNT)=-1
43009C
43010      ICNT=ICNT+1
43011      ITEXT(ICNT)='Second Response Variable: '
43012      WRITE(ITEXT(ICNT)(27:30),'(A4)')IVARI3(1:4)
43013      WRITE(ITEXT(ICNT)(31:34),'(A4)')IVARI4(1:4)
43014      NCTEXT(ICNT)=34
43015      AVALUE(ICNT)=0.0
43016      IDIGIT(ICNT)=-1
43017C
43018      ICNT=ICNT+1
43019      ITEXT(ICNT)=' '
43020      NCTEXT(ICNT)=0
43021      AVALUE(ICNT)=0.0
43022      IDIGIT(ICNT)=-1
43023C
43024      ICNT=ICNT+1
43025      ITEXT(ICNT)='H0: Population Coefficients of Variation'
43026      NCTEXT(ICNT)=40
43027      AVALUE(ICNT)=0.0
43028      IDIGIT(ICNT)=-1
43029      ICNT=ICNT+1
43030      ITEXT(ICNT)='    Are Equal (gamma1 = gamma2)'
43031      NCTEXT(ICNT)=41
43032      AVALUE(ICNT)=0.0
43033      IDIGIT(ICNT)=-1
43034      ICNT=ICNT+1
43035      IF(ICASA3.EQ.'TWOT')THEN
43036        ITEXT(ICNT)='Ha: gamma1 <> gamma2'
43037        NCTEXT(ICNT)=20
43038      ELSEIF(ICASA3.EQ.'UPPE')THEN
43039        ITEXT(ICNT)='Ha: gamma1 > gamma2'
43040        NCTEXT(ICNT)=19
43041      ELSEIF(ICASA3.EQ.'LOWE')THEN
43042        ITEXT(ICNT)='Ha: gamma1 < gamma2'
43043        NCTEXT(ICNT)=19
43044      ENDIF
43045      AVALUE(ICNT)=0.0
43046      IDIGIT(ICNT)=-1
43047C
43048      ICNT=ICNT+1
43049      ITEXT(ICNT)=' '
43050      NCTEXT(ICNT)=1
43051      AVALUE(ICNT)=0.0
43052      IDIGIT(ICNT)=-1
43053C
43054      ICNT=ICNT+1
43055      ITEXT(ICNT)='Sample One Summary Statistics:'
43056      NCTEXT(ICNT)=30
43057      AVALUE(ICNT)=0.0
43058      IDIGIT(ICNT)=-1
43059      ICNT=ICNT+1
43060      ITEXT(ICNT)='Number of Observations:'
43061      NCTEXT(ICNT)=23
43062      AVALUE(ICNT)=REAL(N1)
43063      IDIGIT(ICNT)=0
43064      ICNT=ICNT+1
43065      ITEXT(ICNT)='Sample Mean:'
43066      NCTEXT(ICNT)=12
43067      AVALUE(ICNT)=Y1MEAN
43068      IDIGIT(ICNT)=NUMDIG
43069      ICNT=ICNT+1
43070      ITEXT(ICNT)='Sample Standard Deviation:'
43071      NCTEXT(ICNT)=26
43072      AVALUE(ICNT)=Y1SD
43073      IDIGIT(ICNT)=NUMDIG
43074      ICNT=ICNT+1
43075      ITEXT(ICNT)='Sample Coefficient of Variation:'
43076      NCTEXT(ICNT)=42
43077      AVALUE(ICNT)=Y1CV
43078      IDIGIT(ICNT)=NUMDIG
43079      ICNT=ICNT+1
43080      ITEXT(ICNT)=' '
43081      NCTEXT(ICNT)=1
43082      AVALUE(ICNT)=0.0
43083      IDIGIT(ICNT)=-1
43084C
43085      ICNT=ICNT+1
43086      ITEXT(ICNT)='Sample Two Summary Statistics:'
43087      NCTEXT(ICNT)=30
43088      AVALUE(ICNT)=0.0
43089      IDIGIT(ICNT)=-1
43090      ICNT=ICNT+1
43091      ITEXT(ICNT)='Number of Observations:'
43092      NCTEXT(ICNT)=23
43093      AVALUE(ICNT)=REAL(N2)
43094      IDIGIT(ICNT)=0
43095      ICNT=ICNT+1
43096      ITEXT(ICNT)='Sample Mean:'
43097      NCTEXT(ICNT)=12
43098      AVALUE(ICNT)=Y2MEAN
43099      IDIGIT(ICNT)=NUMDIG
43100      ICNT=ICNT+1
43101      ITEXT(ICNT)='Sample Standard Deviation:'
43102      NCTEXT(ICNT)=26
43103      AVALUE(ICNT)=Y2SD
43104      IDIGIT(ICNT)=NUMDIG
43105      ICNT=ICNT+1
43106      ITEXT(ICNT)='Sample Coefficient of Variation:'
43107      NCTEXT(ICNT)=42
43108      AVALUE(ICNT)=Y2CV
43109      IDIGIT(ICNT)=NUMDIG
43110      ICNT=ICNT+1
43111      ITEXT(ICNT)=' '
43112      NCTEXT(ICNT)=1
43113      AVALUE(ICNT)=0.0
43114      IDIGIT(ICNT)=-1
43115C
43116      ICNT=ICNT+1
43117      ITEXT(ICNT)='Miller Test Statistic Value:'
43118      NCTEXT(ICNT)=28
43119      AVALUE(ICNT)=STATVA
43120      IDIGIT(ICNT)=NUMDIG
43121      ICNT=ICNT+1
43122      ITEXT(ICNT)='CDF Value:'
43123      NCTEXT(ICNT)=10
43124      AVALUE(ICNT)=STATCD
43125      IDIGIT(ICNT)=NUMDIG
43126      ICNT=ICNT+1
43127      ITEXT(ICNT)='P-Value (2-tailed test):'
43128      NCTEXT(ICNT)=24
43129      AVALUE(ICNT)=PVAL2T
43130      IDIGIT(ICNT)=NUMDIG
43131      ICNT=ICNT+1
43132      ITEXT(ICNT)='P-Value (lower-tailed test):'
43133      NCTEXT(ICNT)=28
43134      AVALUE(ICNT)=PVALLT
43135      IDIGIT(ICNT)=NUMDIG
43136      ICNT=ICNT+1
43137      ITEXT(ICNT)='P-Value (upper-tailed test):'
43138      NCTEXT(ICNT)=28
43139      AVALUE(ICNT)=PVALUT
43140      IDIGIT(ICNT)=NUMDIG
43141C
43142      NUMROW=ICNT
43143      DO4110I=1,NUMROW
43144        NTOT(I)=15
43145 4110 CONTINUE
43146C
43147      IFRST=.TRUE.
43148      ILAST=.TRUE.
43149C
43150      ISTEPN='41A'
43151      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVT2')
43152     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
43153C
43154      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
43155     1            AVALUE,IDIGIT,
43156     1            NTOT,NUMROW,
43157     1            ICAPSW,ICAPTY,ILAST,IFRST,
43158     1            ISUBRO,IBUGA3,IERROR)
43159C
43160      ISTEPN='41B'
43161      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVT2')
43162     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
43163C
43164      CALL NORPPF(.0005,CTL999)
43165      CALL NORPPF(.005,CUTL99)
43166      CALL NORPPF(.025,CUTL95)
43167      CALL NORPPF(.05,CUTL90)
43168      CALL NORPPF(.1,CUTL80)
43169      CALL NORPPF(.25,CUTL50)
43170      CALL NORPPF(.75,CUTU50)
43171      CALL NORPPF(.90,CUTU80)
43172      CALL NORPPF(.95,CUTU90)
43173      CALL NORPPF(.975,CUTU95)
43174      CALL NORPPF(.995,CUTU99)
43175      CALL NORPPF(.9995,CTU999)
43176C
43177      ITITL9='H0: gamma1 = gamma2; Ha: gamma1 <> gamma2'
43178      NCTIT9=41
43179C
43180      DO4130J=1,5
43181        DO4140I=1,3
43182          ITITL2(I,J)=' '
43183          NCTIT2(I,J)=0
43184 4140   CONTINUE
43185 4130 CONTINUE
43186C
43187      ITITL2(2,1)='Significance'
43188      NCTIT2(2,1)=12
43189      ITITL2(3,1)='Level'
43190      NCTIT2(3,1)=5
43191C
43192      ITITL2(2,2)='Test '
43193      NCTIT2(2,2)=4
43194      ITITL2(3,2)='Statistic'
43195      NCTIT2(3,2)=9
43196C
43197      ITITL2(1,3)='Lower'
43198      NCTIT2(1,3)=5
43199      ITITL2(2,3)='Critical'
43200      NCTIT2(2,3)=8
43201      ITITL2(3,3)='Value'
43202      NCTIT2(3,3)=5
43203C
43204      ITITL2(1,4)='Upper'
43205      NCTIT2(1,4)=5
43206      ITITL2(2,4)='Critical'
43207      NCTIT2(2,4)=8
43208      ITITL2(3,4)='Value'
43209      NCTIT2(3,4)=5
43210C
43211      ITITL2(1,5)='Null'
43212      NCTIT2(1,5)=4
43213      ITITL2(2,5)='Hypothesis'
43214      NCTIT2(2,5)=10
43215      ITITL2(3,5)='Conclusion'
43216      NCTIT2(3,5)=10
43217C
43218      NMAX=0
43219      NUMCOL=5
43220      DO4150I=1,NUMCOL
43221        VALIGN(I)='b'
43222        ALIGN(I)='r'
43223        NTOT(I)=15
43224        NMAX=NMAX+NTOT(I)
43225        ITYPCO(I)='NUME'
43226        IDIGIT(I)=NUMDIG
43227        IF(I.EQ.1 .OR. I.EQ.5)THEN
43228          ITYPCO(I)='ALPH'
43229        ENDIF
43230 4150 CONTINUE
43231C
43232      IWHTML(1)=125
43233      IWHTML(2)=175
43234      IWHTML(3)=175
43235      IWHTML(4)=175
43236      IWHTML(5)=175
43237      IINC=1800
43238      IINC2=1400
43239      IWRTF(1)=IINC
43240      IWRTF(2)=IWRTF(1)+IINC
43241      IWRTF(3)=IWRTF(2)+IINC
43242      IWRTF(4)=IWRTF(3)+IINC
43243      IWRTF(5)=IWRTF(4)+IINC
43244C
43245      DO4160J=1,NUMALP
43246C
43247        ALPHAT=(1.0 - ALPHA(J))/2.0
43248        CALL NORPPF(ALPHAT,ALOWCV)
43249        ALPHT2=1.0 - ALPHAT
43250        CALL NORPPF(ALPHT2,AUPPCV)
43251        ALPHAT=100.0*ALPHA(J)
43252        WRITE(IVALUE(J,1)(1:4),'(F4.1)')ALPHAT
43253        IVALUE(J,1)(5:5)='%'
43254        NCVALU(J,1)=5
43255C
43256        AMAT(J,2)=STATVA
43257        AMAT(J,3)=ALOWCV
43258        AMAT(J,4)=AUPPCV
43259        IVALUE(J,5)(1:6)='REJECT'
43260        IF(STATVA.GE.AMAT(J,3).AND.STATVA.LE.AMAT(J,4))THEN
43261          IVALUE(J,5)(1:6)='ACCEPT'
43262        ENDIF
43263        NCVALU(J,5)=6
43264C
43265 4160 CONTINUE
43266C
43267      ICNT=NUMALP
43268      NUMLIN=3
43269      NUMCOL=5
43270      IFRST=.TRUE.
43271      ILAST=.TRUE.
43272      IFLAGS=.TRUE.
43273      IFLAGE=.TRUE.
43274      IF(ICASA3.NE.'LOWE' .AND. ICASA3.NE.'UPPE')THEN
43275        CALL DPDTA5(ITITLE,NCTITL,
43276     1              ITITL9,NCTIT9,ITITL2,NCTIT2,
43277     1              MAXLIN,NUMLIN,NUMCLI,NUMCOL,
43278     1              IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
43279     1              IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
43280     1              ICAPSW,ICAPTY,IFRST,ILAST,
43281     1              IFLAGS,IFLAGE,
43282     1              ISUBRO,IBUGA3,IERROR)
43283      ENDIF
43284      IF(ICASA3.EQ.'TWOT')GOTO4199
43285C
43286      IF(ICASA3.EQ.'LOWE')THEN
43287        ITITLE='Lower One-Tailed Test'
43288        NCTITL=21
43289        ITITL9='H0: gamma1 = gamma2; Ha: gamma1 < gamma2'
43290        NCTIT9=40
43291        ITITL2(1,3)=' '
43292        NCTIT2(1,3)=0
43293        ITITL2(2,3)='Critical'
43294        NCTIT2(2,3)=8
43295        ITITL2(3,3)='Value (<)'
43296        NCTIT2(3,3)=9
43297      ELSEIF(ICASA3.EQ.'UPPE')THEN
43298        ITITLE='Upper One-Tailed Test'
43299        NCTITL=21
43300        ITITL9='H0: gamma1 = gamma2; Ha: gamma1 > gamma2'
43301        NCTIT9=40
43302        NCTIT2(1,3)=0
43303        ITITL2(2,3)='Critical'
43304        NCTIT2(2,3)=8
43305        ITITL2(3,3)='Value (>)'
43306        NCTIT2(3,3)=9
43307      ENDIF
43308C
43309      ITITL2(1,4)='Null'
43310      NCTIT2(1,4)=4
43311      ITITL2(2,4)='Hypothesis'
43312      NCTIT2(2,4)=10
43313      ITITL2(3,4)='Conclusion'
43314      NCTIT2(3,4)=10
43315C
43316      NMAX=0
43317      NUMCOL=4
43318      DO4250I=1,NUMCOL
43319        NTOT(I)=15
43320        NMAX=NMAX+NTOT(I)
43321        IF(I.EQ.1 .OR. I.EQ.4)ITYPCO(I)='ALPH'
43322 4250 CONTINUE
43323C
43324      DO4260J=1,NUMALP
43325        IF(ICASA3.EQ.'UPPE')THEN
43326          ALPHAT=ALPHA(J)
43327        ELSE
43328          ALPHAT=1.0 - ALPHA(J)
43329        ENDIF
43330        CALL NORPPF(ALPHAT,ATEMP)
43331        AMAT(J,3)=ATEMP
43332        IVALUE(J,4)(1:6)='REJECT'
43333        IF(ICASA3.EQ.'UPPE')THEN
43334          IF(STATVA.GE.AMAT(J,3))THEN
43335            IVALUE(J,4)(1:6)='ACCEPT'
43336          ENDIF
43337        ELSE
43338          IF(STATVA.LE.AMAT(J,3))THEN
43339            IVALUE(J,4)(1:6)='ACCEPT'
43340          ENDIF
43341        ENDIF
43342        NCVALU(J,4)=6
43343 4260 CONTINUE
43344C
43345        ICNT=NUMALP
43346        NUMLIN=3
43347        NUMCOL=4
43348        IFRST=.TRUE.
43349        ILAST=.TRUE.
43350        IFLAGS=.TRUE.
43351        IFLAGE=.TRUE.
43352        CALL DPDTA5(ITITLE,NCTITL,
43353     1              ITITL9,NCTIT9,ITITL2,NCTIT2,
43354     1              MAXLIN,NUMLIN,NUMCLI,NUMCOL,
43355     1              IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
43356     1              IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
43357     1              ICAPSW,ICAPTY,IFRST,ILAST,
43358     1              IFLAGS,IFLAGE,
43359     1              ISUBRO,IBUGA3,IERROR)
43360C
43361 4199 CONTINUE
43362C
43363C               *****************
43364C               **  STEP 90--  **
43365C               **  EXIT       **
43366C               *****************
43367C
43368 9000 CONTINUE
43369      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CVT2')THEN
43370        WRITE(ICOUT,999)
43371        CALL DPWRST('XXX','WRIT')
43372        WRITE(ICOUT,9011)
43373 9011   FORMAT('***** AT THE END       OF DPCVT2--')
43374        CALL DPWRST('XXX','WRIT')
43375        WRITE(ICOUT,9013)STATVA,STATCD,PVAL2T,PVALLT,PVALUT
43376 9013   FORMAT('STATVA,STATCD,PVAL2T,PVALLT,PVALUT = ',5G15.7)
43377        CALL DPWRST('XXX','WRIT')
43378      ENDIF
43379C
43380      RETURN
43381      END
43382      SUBROUTINE DPCVT3(Y,X,NI,N,GAMMA0,IWRITE,ICASA3,
43383     1                  TEMP1,XIDTEM,
43384     1                  NDIST,NGROUP,YMEAN,YSD,YCV,
43385     1                  STATVA,STATCD,STATNU,
43386     1                  PVAL2T,PVALLT,PVALUT,
43387     1                  ISUBRO,IBUGA3,IERROR)
43388C
43389C     PURPOSE--THIS SUBROUTINE COMPUTES THE FOLLOWING TESTS FOR A
43390C              COMMON COEFFICIENT OF VARIATION:
43391C
43392C                 H0: GAMMA = GAMMA0
43393C
43394C              THE TEST STATISTIC IS
43395C
43396C                 SUM[i=1 to k][(n(i) - 1)*u(i)/THETA0]
43397C
43398C              WHERE
43399C
43400C                 k     = NUMBER OF GROUPS
43401C                 u(i)  = c(i)**2/[1 + c(i)**2*(n(i) - 1)/n(i)]
43402C                 c(i)  = COEFFICIENT OF VARIATION FOR i-TH GROUP
43403C                 n(i)  = SAMPLE SIZE FOR i-THE GROUP
43404C                 THETA0 = GAMMA0**2/(1 + GAMMA0**2)
43405C
43406C              WHERE GAMMA IS THE COMMON COEFFICIENT OF VARIATION
43407C              AND GAMMA0 IS THE HYPOTHESIZED VALUE.
43408C
43409C              THIS STATISTIC IS COMPARED TO A CHI-SQUARE WITH
43410C              SUM[i=1 to k][n(i)- 1] DEGREES OF FREEDOM.
43411C
43412C              FOR THE RAW DATA CASE, Y IS THE RESPONSE VARIABLE.  FOR
43413C              THE SUMMARY DATA CASE, Y IS THE MEAN VALUES, X IS THE
43414C              STANDARD DEVIATIONS, AND NI IS THE SAMPLE SIZES.
43415C
43416C              THE (BIASED) COMMON COEFFICIENT OF VARIATION IS:
43417C
43418C                 CVCOMM = SQRT[SUM{I=1 to k}{(N(i)-1)*C(i)**2}/
43419C                               SUM{i=1 to k}{N(i)-1)}]
43420C
43421C
43422C     INPUT  ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR OF
43423C                                RESPONSE VALUES.
43424C                     --X      = THE SINGLE PRECISION VECTOR OF
43425C                                GROUP-ID VALUES.
43426C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
43427C                                IN THE VECTOR X.
43428C                     --GAMMA0 = THE SINGLE PRECISION VALUE FOR WHICH
43429C                                THE TEST IS PERFORMED (I.E.,
43430C                                H0: GAMMA = GAMMA0).
43431C     OUTPUT ARGUMENTS--STATVA = THE SINGLE PRECISION VALUE OF THE
43432C                                COMPUTED STATISTIC.
43433C                     --STATCD = THE SINGLE PRECISION VALUE OF THE
43434C                                COMPUTED CDF OF THE TEST STATISTIC.
43435C                     --STATNU = THE SINGLE PRECISION VALUE OF THE
43436C                                COMPUTED DEGREES OF FREDDOM
43437C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
43438C             TEST STATISTIC.
43439C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
43440C                   OF N FOR THIS SUBROUTINE.
43441C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
43442C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
43443C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
43444C     LANGUAGE--ANSI FORTRAN (1977)
43445C     REFERENCES--JOHANNES FORKMAN (2009)), "ESTIMATOR AND TESTS FOR
43446C                 COMMON COEFFICIENTS OF VARIATION IN NORMAL
43447C                 DISTRIBUTIONS", COMMUNICATIONS IN STATISTICS -
43448C                 THEROY AND METHODS, Vol. 38, No. 2, pp. 233-251.
43449C     WRITTEN BY--ALAN HECKERT
43450C                 STATISTICAL ENGINEERING DIVISION
43451C                 INFORMATION TECHNOLOGY LABORATORY
43452C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
43453C                 GAITHERSBURG, MD 20899-8980
43454C                 PHONE--301-975-2899
43455C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
43456C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
43457C     LANGUAGE--ANSI FORTRAN (1977)
43458C     VERSION NUMBER--2017.06
43459C     ORIGINAL VERSION--JUNE      2017.
43460C
43461C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
43462C
43463      CHARACTER*4 ICASA3
43464      CHARACTER*4 IWRITE
43465      CHARACTER*4 ISUBRO
43466      CHARACTER*4 IBUGA3
43467      CHARACTER*4 IERROR
43468C
43469      CHARACTER*4 ISUBN1
43470      CHARACTER*4 ISUBN2
43471      CHARACTER*4 ISTEPN
43472      CHARACTER*4 IOP
43473C
43474      DOUBLE PRECISION DSUM1
43475      DOUBLE PRECISION DSUM2
43476      DOUBLE PRECISION DSUM3
43477      DOUBLE PRECISION DTERM1
43478      DOUBLE PRECISION DTERM2
43479C
43480C---------------------------------------------------------------------
43481C
43482      DIMENSION Y(*)
43483      DIMENSION X(*)
43484      DIMENSION TEMP1(*)
43485      DIMENSION XIDTEM(*)
43486C
43487      INTEGER NI(*)
43488C
43489C---------------------------------------------------------------------
43490C
43491      INCLUDE 'DPCOP2.INC'
43492C
43493C-----START POINT-----------------------------------------------------
43494C
43495      ISUBN1='DPCV'
43496      ISUBN2='T3  '
43497      IERROR='NO'
43498      IWRITE='OFF'
43499C
43500      STATVA=-99.0
43501      STATCD=-99.0
43502      STATNU=-99.0
43503      PVAL2T=-99.0
43504      PVALLT=-99.0
43505      PVALUT=-99.0
43506      YMEAN=-99.0
43507      YSD=-99.0
43508      YCV=-99.0
43509C
43510      IOP='OPEN'
43511      IFLAG1=1
43512      IFLAG2=0
43513      IFLAG3=0
43514      IFLAG4=0
43515      IFLAG5=0
43516      CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
43517     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
43518     1            IBUGA3,ISUBRO,IERROR)
43519      IF(IERROR.EQ.'YES')GOTO9000
43520      WRITE(IOUNI1,41)
43521   41 FORMAT(4X,'N(I)',8X,'MEAN(I)',10X,'SD(I)',10X,'CV(I)')
43522C
43523      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CVT3')THEN
43524        WRITE(ICOUT,999)
43525  999   FORMAT(1X)
43526        CALL DPWRST('XXX','BUG ')
43527        WRITE(ICOUT,51)
43528   51   FORMAT('***** AT THE BEGINNING OF DPCVT3--')
43529        CALL DPWRST('XXX','BUG ')
43530        WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASA3,N
43531   52   FORMAT('IBUGA3,ISUBRO,ICASA3,N = ',3(A4,2X),I8)
43532        CALL DPWRST('XXX','BUG ')
43533        DO55I=1,N
43534          WRITE(ICOUT,56)I,Y(I),X(I)
43535   56     FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
43536          CALL DPWRST('XXX','BUG ')
43537   55   CONTINUE
43538      ENDIF
43539C
43540C               ********************************************
43541C               **  STEP 1--                              **
43542C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
43543C               ********************************************
43544C
43545C
43546C
43547      IF(N.LT.2)THEN
43548        WRITE(ICOUT,999)
43549        CALL DPWRST('XXX','WRIT')
43550        WRITE(ICOUT,101)
43551  101   FORMAT('***** ERROR: COMMON COEFFICIENT OF VARIATION ',
43552     1         'ONE SAMPLE TEST--')
43553        CALL DPWRST('XXX','WRIT')
43554        WRITE(ICOUT,102)
43555  102   FORMAT('      THE NUMBER OF OBSERVATIONS  IS LESS THAN TWO.')
43556        CALL DPWRST('XXX','WRIT')
43557        WRITE(ICOUT,103)N
43558  103   FORMAT('      SAMPLE SIZE = ',I8)
43559        CALL DPWRST('XXX','WRIT')
43560        IERROR='YES'
43561        GOTO9000
43562      ELSEIF(GAMMA0.LE.0.0)THEN
43563        WRITE(ICOUT,999)
43564        CALL DPWRST('XXX','WRIT')
43565        WRITE(ICOUT,101)
43566        CALL DPWRST('XXX','WRIT')
43567        WRITE(ICOUT,107)GAMMA0
43568  107   FORMAT('      THE HYPOTHESIZED VALUE, (',G15.7,') IS ',
43569     1         'NON-POSITIVE.')
43570        CALL DPWRST('XXX','WRIT')
43571        IERROR='YES'
43572        GOTO9000
43573      ENDIF
43574C
43575C               ********************************************
43576C               **  STEP 21--                             **
43577C               **  DETERMINE THE NUMBER OF GROUPS        **
43578C               ********************************************
43579C
43580      ISTEPN='21'
43581      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVC4')
43582     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
43583C
43584      IF(ICASA3.EQ.'RAW')THEN
43585        CALL DISTIN(X,N,IWRITE,XIDTEM,NDIST,IBUGA3,IERROR)
43586        IF(IERROR.EQ.'YES')GOTO9000
43587C
43588        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVT3')THEN
43589          DO201I=1,NDIST
43590            WRITE(ICOUT,203)I,XIDTEM(I)
43591  203       FORMAT('I,XIDTEM(I) = ',I8,G15.7)
43592            CALL DPWRST('XXX','WRIT')
43593  201     CONTINUE
43594        ENDIF
43595C
43596C       NOTE: ALLOW SINGLE GROUP
43597C
43598CCCCC   IF(NDIST.LT.2)THEN
43599CCCCC     WRITE(ICOUT,999)
43600CCCCC     CALL DPWRST('XXX','WRIT')
43601CCCCC     WRITE(ICOUT,101)
43602CCCCC     CALL DPWRST('XXX','WRIT')
43603CCCCC     WRITE(ICOUT,201)
43604CC201     FORMAT('      THE NUMBER OF GROUPS  IS LESS THAN TWO.')
43605CCCCC     IERROR='YES'
43606CCCCC     GOTO9000
43607CCCCC   ENDIF
43608      ELSE
43609        NDIST=N
43610      ENDIF
43611C
43612C               ********************************************
43613C               **  STEP 22--                             **
43614C               **  COMPUTE THE GROUP STATISTICS          **
43615C               ********************************************
43616C
43617      ISTEPN='22'
43618      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVC4')
43619     1   CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
43620C
43621      AN=N
43622      THETA0=GAMMA0**2/(1.0 + GAMMA0**2)
43623      NGROUP=0
43624      DSUM1=0.0D0
43625      DSUM2=0.0D0
43626      DSUM3=0.0D0
43627C
43628      DO210II=1,NDIST
43629        K=0
43630C
43631        YMEANT=CPUMIN
43632        YSDT=CPUMIN
43633        CT=CPUMIN
43634C
43635        IF(ICASA3.EQ.'SUMM')THEN
43636          YMEANT=Y(II)
43637          YSDT=X(II)
43638          NT=NI(II)
43639        ELSE
43640          HOLD=XIDTEM(II)
43641          DO220JJ=1,N
43642            IF(X(JJ).EQ.HOLD)THEN
43643              K=K+1
43644              TEMP1(K)=Y(JJ)
43645            ENDIF
43646  220     CONTINUE
43647          NT=K
43648C
43649          IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVT3')THEN
43650            WRITE(ICOUT,211)II,HOLD,NT
43651  211       FORMAT('GROUP ',I8,' (',G15.7,') HAS ',I8,' OBSERVATIONS.')
43652            CALL DPWRST('XXX','WRIT')
43653          ENDIF
43654C
43655          IF(NT.GT.1)THEN
43656            CALL MEAN(TEMP1,NT,IWRITE,YMEANT,IBUGA3,IERROR)
43657            CALL SD(TEMP1,NT,IWRITE,YSDT,IBUGA3,IERROR)
43658          ELSE
43659            WRITE(ICOUT,999)
43660            CALL DPWRST('XXX','WRIT')
43661            WRITE(ICOUT,203)
43662            CALL DPWRST('XXX','WRIT')
43663            WRITE(ICOUT,207)II
43664  207       FORMAT('      GROUP ',I5,' HAS FEWER THAN TWO ',
43665     1             'OBSERVATIONS.')
43666            CALL DPWRST('XXX','WRIT')
43667            WRITE(ICOUT,225)
43668            CALL DPWRST('XXX','WRIT')
43669            GOTO219
43670          ENDIF
43671        ENDIF
43672C
43673C       CHECK FOR:
43674C
43675C           1) POSITIVE MEAN
43676C              (OMIT GROUP FROM COMPUTATIONS FOR NON-POSITIVE MEAN)
43677C           2) POSITIVE SD
43678C              (OMIT GROUP FROM COMPUTATIONS FOR NON-POSITIVE SD)
43679C           3) COEFFICIENT OF VARIATION < 0.33
43680C              (THIS WILL BE WARNING, BUT INCLUDE IN THE COMPUTATIONS)
43681C
43682        IF(YMEANT.LT.0.0)THEN
43683          WRITE(ICOUT,999)
43684          CALL DPWRST('XXX','WRIT')
43685          WRITE(ICOUT,223)
43686  223     FORMAT('***** WARNING COMMON COEFFICIENT OF VARIATION ',
43687     1           'ONE SAMPLE TEST--')
43688          CALL DPWRST('XXX','WRIT')
43689          WRITE(ICOUT,224)II
43690  224     FORMAT('      GROUP ',I5,' HAS A NON-POSITIVE MEAN.')
43691          CALL DPWRST('XXX','WRIT')
43692          WRITE(ICOUT,225)
43693  225     FORMAT('      IT WILL BE OMITTED FROM THE COMPUTATION.')
43694          CALL DPWRST('XXX','WRIT')
43695          GOTO219
43696        ELSEIF(YSDT.LE.0.0)THEN
43697          WRITE(ICOUT,999)
43698          CALL DPWRST('XXX','WRIT')
43699          WRITE(ICOUT,223)
43700          CALL DPWRST('XXX','WRIT')
43701          WRITE(ICOUT,226)II
43702  226     FORMAT('      GROUP ',I5,' HAS A NON-POSITIVE STANDARD ',
43703     1           'DEVIATION.')
43704          CALL DPWRST('XXX','WRIT')
43705          WRITE(ICOUT,225)
43706          CALL DPWRST('XXX','WRIT')
43707          GOTO219
43708        ENDIF
43709C
43710        NGROUP=NGROUP+1
43711        CT=YSDT/YMEANT
43712        ANT=REAL(NT)
43713        ANTM1=ANT - 1.0
43714        UT=CT**2/(1.0 + (CT**2*ANTM1/ANT))
43715        DSUM1=DSUM1 + DBLE(ANTM1)
43716        DSUM2=DSUM2 + DBLE(ANTM1*UT)
43717        DSUM3=DSUM3 + DBLE(ANTM1*CT**2)
43718C
43719        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVT3')THEN
43720          WRITE(ICOUT,233)NGROUP,YMEANT,YSDT,CT,UT
43721  233     FORMAT('NGROUP,YMEANT,YSDT,CT,UT = ',I8,4G15.7)
43722          CALL DPWRST('XXX','WRIT')
43723        ENDIF
43724C
43725  219   CONTINUE
43726        WRITE(IOUNI1,'(I8,3E15.7)')NT,YMEANT,YSDT,CT
43727        IF(NDIST.EQ.1 .AND. II.EQ.1)THEN
43728          YMEAN=YMEANT
43729          YSD=YSDT
43730          YCV=CT
43731        ENDIF
43732C
43733  210 CONTINUE
43734C
43735CCCCC IF(NGROUP.LT.2)THEN
43736CCCCC   WRITE(ICOUT,999)
43737CCCCC   CALL DPWRST('XXX','WRIT')
43738CCCCC   WRITE(ICOUT,101)
43739CCCCC   CALL DPWRST('XXX','WRIT')
43740CCCCC   WRITE(ICOUT,281)
43741CC281   FORMAT('      AFTER REMOVING GROUPS, LESS THAN TWO GROUPS ',
43742CCCCC1         'REMAIN.')
43743CCCCC   CALL DPWRST('XXX','WRIT')
43744CCCCC   IERROR='YES'
43745CCCCC   GOTO9000
43746CCCCC ENDIF
43747C
43748      DTERM1=DSUM2/DBLE(THETA0)
43749      DTERM2=DSQRT(DSUM3/DSUM1)
43750      YCV=REAL(DTERM2)
43751      STATVA=REAL(DTERM1)
43752      IDF=INT(DSUM1+0.5D0)
43753      STATNU=REAL(IDF)
43754      CALL CHSCDF(STATVA,IDF,STATCD)
43755C
43756      PVALLT=STATCD
43757      PVALUT=1.0 - STATCD
43758      IF(YCV.LE.GAMMA0)THEN
43759        PVAL2T=2.0*STATCD
43760      ELSE
43761        PVAL2T=2.0*(1.0 - STATCD)
43762      ENDIF
43763C
43764C               *****************
43765C               **  STEP 90--  **
43766C               **  EXIT.      **
43767C               *****************
43768C
43769 9000 CONTINUE
43770C
43771      IOP='CLOS'
43772      CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
43773     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
43774     1            IBUGA3,ISUBRO,IERROR)
43775C
43776      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CVT3')THEN
43777        WRITE(ICOUT,999)
43778        CALL DPWRST('XXX','BUG ')
43779        WRITE(ICOUT,9011)
43780 9011   FORMAT('***** AT THE END       OF DPCVT3--')
43781        CALL DPWRST('XXX','BUG ')
43782        WRITE(ICOUT,9012)IBUGA3,IERROR,NDIST,NGROUP
43783 9012   FORMAT('IBUGA3,IERROR,NDIST,NGROUP = ',2(A4,2X),2I8)
43784        CALL DPWRST('XXX','BUG ')
43785        WRITE(ICOUT,9015)STATVA,STATNU,STATCD,YCV
43786 9015   FORMAT('STATVA,STATNU,STATCD,YCV = ',4G15.7)
43787        CALL DPWRST('XXX','BUG ')
43788        WRITE(ICOUT,9016)DSUM1,DSUM2,DSUM3,THETA0
43789 9016   FORMAT('DSUM1,DSUM2,DSUM3,THETA0 = ',4G15.7)
43790        CALL DPWRST('XXX','BUG ')
43791      ENDIF
43792C
43793      RETURN
43794      END
43795      SUBROUTINE DPCVT4(Y1,X1,N1,Y2,X2,N2,IWRITE,
43796     1                  TEMP1,XIDTEM,NGROU1,NGROU2,
43797     1                  YMEAN1,YSD1,CV1,YMEAN2,YSD2,CV2,
43798     1                  STATVA,STATCD,STATN1,STATN2,
43799     1                  PVAL2T,PVALLT,PVALUT,
43800     1                  ISUBRO,IBUGA3,IERROR)
43801C
43802C     PURPOSE--THIS SUBROUTINE COMPUTES AN APPROXIMATE F TEST FOR THE
43803C              EQUALITY OF THE COEFFIIENTS OF VARIATION FROM TWO
43804C              SAMPLES.  NOTE THAT THE MOST GENERAL FORM OF THIS TEST
43805C              CAN BE USED FOR THE CASE WHERE EACH SAMPLE IS COMPRISED
43806C              OF MULTIPLE GROUPS (I.E., WE ARE COMPARING THE COMMON
43807C              COEFFICIENT OF VARIATION FOR SAMPLE 1 WITH K1 GROUPS WITH
43808C              THE COMMON COEFFICIENT OF VARIATION FOR SAMPLE 2 WITH K2
43809C              GROUPS.
43810C
43811C                 H0: GAMMA1 = GAMMA2
43812C
43813C              THE TEST STATISTIC IS
43814C
43815C                 F = NUM/DENOM
43816C
43817C                 NUM   = SUM[i=1 to k1][(n1(i) - 1)*u1(i)]/
43818C                         SUM[i=1 to k1][n1(i) - 1]
43819C                 DENOM = SUM[i=1 to k2][(n2(i) - 1)*u2(i)]/
43820C                         SUM[i=1 to k2][n2(i) - 1]
43821C
43822C              WHEN k1 = k2 = 1, THE TEST SIMPLIFIES TO
43823C
43824C                  F = [c1**2/(1 + c1**2*(n1-1)/n1)]/
43825C                      [c2**2/(1 + c2**2*(n2-1)/n2)]
43826C              WHERE
43827C
43828C                 k1     = NUMBER OF GROUPS FOR SAMPLE ONE
43829C                 k2     = NUMBER OF GROUPS FOR SAMPLE TWO
43830C                 ur(i)  = cr(i)**2/[1 + cr(i)**2*(nr(i) - 1)/nr(i)]
43831C                 cr(i)  = COEFFICIENT OF VARIATION FOR i-TH GROUP AND
43832C                          r-TH SAMPLE
43833C                 nr(i)  = SAMPLE SIZE FOR i-THE GROUP AND r-TH SAMPLE
43834C                 r      = 1, 2 (I.E., TWO SAMPLES)
43835C
43836C              THIS STATISTIC IS COMPARED TO THE F DISTRIBUTION WITH
43837C              SUM[i=1 to k1][n1(i)- 1] AND SUM[i=1 to k2][n2(i) - 1]
43838C              DEGREES OF FREEDOM.
43839C
43840C              CURRENTLY, ONLY THE RAW DATA CASE IS SUPPORTED.  ALSO,
43841C              THE CASE WHERE THERE IS ONE GROUP FOR EACH SAMPLE IS THE
43842C              MOST COMMONLY USED IN PRACTICE.
43843C
43844C     INPUT  ARGUMENTS--Y1     = THE SINGLE PRECISION VECTOR OF
43845C                                RESPONSE VALUES FOR SAMPLE ONE.
43846C                     --X1     = THE SINGLE PRECISION VECTOR OF
43847C                                GROUP-ID VALUES FOR SAMPLE ONE.
43848C                     --N1     = THE INTEGER NUMBER OF OBSERVATIONS
43849C                                FOR SAMPLE ONE.
43850C                     --Y2     = THE SINGLE PRECISION VECTOR OF
43851C                                RESPONSE VALUES FOR SAMPLE TWO.
43852C                     --X2     = THE SINGLE PRECISION VECTOR OF
43853C                                GROUP-ID VALUES FOR SAMPLE TWO.
43854C                     --N2     = THE INTEGER NUMBER OF OBSERVATIONS
43855C                                FOR SAMPLE TWO.
43856C     OUTPUT ARGUMENTS--STATVA = THE SINGLE PRECISION VALUE OF THE
43857C                                COMPUTED STATISTIC.
43858C                     --STATCD = THE SINGLE PRECISION VALUE OF THE
43859C                                COMPUTED CDF OF THE TEST STATISTIC.
43860C                     --STATN1 = THE SINGLE PRECISION VALUE OF THE
43861C                                COMPUTED DEGREES OF FREDDOM
43862C                     --STATN2 = THE SINGLE PRECISION VALUE OF THE
43863C                                COMPUTED DEGREES OF FREDDOM
43864C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
43865C             TEST STATISTIC.
43866C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
43867C                   OF N FOR THIS SUBROUTINE.
43868C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
43869C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
43870C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
43871C     LANGUAGE--ANSI FORTRAN (1977)
43872C     REFERENCES--JOHANNES FORKMAN (2009)), "ESTIMATOR AND TESTS FOR
43873C                 COMMON COEFFICIENTS OF VARIATION IN NORMAL
43874C                 DISTRIBUTIONS", COMMUNICATIONS IN STATISTICS -
43875C                 THEROY AND METHODS, VOL. 38, NO. 2, PP. 233-251.
43876C     WRITTEN BY--ALAN HECKERT
43877C                 STATISTICAL ENGINEERING DIVISION
43878C                 INFORMATION TECHNOLOGY LABORATORY
43879C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
43880C                 GAITHERSBURG, MD 20899-8980
43881C                 PHONE--301-975-2899
43882C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
43883C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
43884C     LANGUAGE--ANSI FORTRAN (1977)
43885C     VERSION NUMBER--2017.06
43886C     ORIGINAL VERSION--JUNE      2017.
43887C
43888C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
43889C
43890      CHARACTER*4 IWRITE
43891      CHARACTER*4 ISUBRO
43892      CHARACTER*4 IBUGA3
43893      CHARACTER*4 IERROR
43894C
43895      CHARACTER*4 ISUBN1
43896      CHARACTER*4 ISUBN2
43897      CHARACTER*4 ISTEPN
43898C
43899      DOUBLE PRECISION DSUM1
43900      DOUBLE PRECISION DSUM2
43901      DOUBLE PRECISION DSUM3
43902      DOUBLE PRECISION DNUM
43903      DOUBLE PRECISION DENOM
43904      DOUBLE PRECISION DTERM1
43905C
43906C---------------------------------------------------------------------
43907C
43908      DIMENSION Y1(*)
43909      DIMENSION X1(*)
43910      DIMENSION Y2(*)
43911      DIMENSION X2(*)
43912      DIMENSION TEMP1(*)
43913      DIMENSION XIDTEM(*)
43914C
43915C---------------------------------------------------------------------
43916C
43917      INCLUDE 'DPCOP2.INC'
43918C
43919C-----START POINT-----------------------------------------------------
43920C
43921      ISUBN1='DPCV'
43922      ISUBN2='T4  '
43923      IERROR='NO'
43924      IWRITE='OFF'
43925C
43926      STATVA=-99.0
43927      STATCD=-99.0
43928      STATNU=-99.0
43929      PVAL2T=-99.0
43930      PVALLT=-99.0
43931      PVALUT=-99.0
43932      YMEAN1=-99.0
43933      YSD1=-99.0
43934      CV1=-99.0
43935      YMEAN2=-99.0
43936      YSD2=-99.0
43937      CV2=-99.0
43938C
43939      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CVT4')THEN
43940        WRITE(ICOUT,999)
43941  999   FORMAT(1X)
43942        CALL DPWRST('XXX','BUG ')
43943        WRITE(ICOUT,51)
43944   51   FORMAT('***** AT THE BEGINNING OF DPCVT4--')
43945        CALL DPWRST('XXX','BUG ')
43946        WRITE(ICOUT,52)IBUGA3,ISUBRO,N1,N2
43947   52   FORMAT('IBUGA3,ISUBRO,N1,N2 = ',2(A4,2X),2I8)
43948        CALL DPWRST('XXX','BUG ')
43949        DO55I=1,N1
43950          WRITE(ICOUT,56)I,Y1(I),X1(I)
43951   56     FORMAT('I,Y1(I),X1(I) = ',I8,2G15.7)
43952          CALL DPWRST('XXX','BUG ')
43953   55   CONTINUE
43954        DO65I=1,N2
43955          WRITE(ICOUT,66)I,Y2(I),X2(I)
43956   66     FORMAT('I,Y2(I),X2(I) = ',I8,2G15.7)
43957          CALL DPWRST('XXX','BUG ')
43958   65   CONTINUE
43959      ENDIF
43960C
43961C               ********************************************
43962C               **  STEP 1--                              **
43963C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
43964C               ********************************************
43965C
43966C
43967C
43968      IF(N1.LT.2)THEN
43969        WRITE(ICOUT,999)
43970        CALL DPWRST('XXX','WRIT')
43971        WRITE(ICOUT,101)
43972  101   FORMAT('***** ERROR: COMMON COEFFICIENT OF VARIANCE ',
43973     1         'TWO SAMPLE TEST--')
43974        CALL DPWRST('XXX','WRIT')
43975        WRITE(ICOUT,102)
43976  102   FORMAT('      THE NUMBER OF OBSERVATIONS FOR SAMPLE ONE ',
43977     1          'IS LESS THAN TWO.')
43978        CALL DPWRST('XXX','WRIT')
43979        WRITE(ICOUT,103)N1
43980  103   FORMAT('      SAMPLE SIZE = ',I8)
43981        CALL DPWRST('XXX','WRIT')
43982        IERROR='YES'
43983        GOTO9000
43984      ELSEIF(N2.LT.2)THEN
43985        WRITE(ICOUT,999)
43986        CALL DPWRST('XXX','WRIT')
43987        WRITE(ICOUT,101)
43988        CALL DPWRST('XXX','WRIT')
43989        WRITE(ICOUT,112)
43990  112   FORMAT('      THE NUMBER OF OBSERVATIONS FOR SAMPLE TWO ',
43991     1          'IS LESS THAN TWO.')
43992        CALL DPWRST('XXX','WRIT')
43993        WRITE(ICOUT,103)N2
43994        CALL DPWRST('XXX','WRIT')
43995        IERROR='YES'
43996        GOTO9000
43997      ENDIF
43998C
43999C               ********************************************
44000C               **  STEP 21--                             **
44001C               **  DETERMINE THE NUMBER OF GROUPS        **
44002C               ********************************************
44003C
44004      ISTEPN='21'
44005      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVC4')
44006     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
44007C
44008      CALL DISTIN(X1,N1,IWRITE,XIDTEM,NDIST,IBUGA3,IERROR)
44009      IF(IERROR.EQ.'YES')GOTO9000
44010C
44011C               ********************************************
44012C               **  STEP 2--                              **
44013C               **  COMPUTE THE NUMERATOR OF THE F TEST   **
44014C               ********************************************
44015C
44016      ISTEPN='2'
44017      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVC4')
44018     1   CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
44019C
44020      NGROUP=0
44021      DSUM1=0.0D0
44022      DSUM2=0.0D0
44023      DSUM3=0.0D0
44024C
44025      DO210II=1,NDIST
44026        K=0
44027C
44028        YMEANT=CPUMIN
44029        YSDT=CPUMIN
44030        CT=CPUMIN
44031C
44032        HOLD=XIDTEM(II)
44033        DO220JJ=1,N1
44034          IF(X1(JJ).EQ.HOLD)THEN
44035            K=K+1
44036            TEMP1(K)=Y1(JJ)
44037          ENDIF
44038  220   CONTINUE
44039        NT=K
44040C
44041        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVC4')THEN
44042          WRITE(ICOUT,211)II,NT
44043  211     FORMAT('GROUP ',I8,' HAS ',I8,' OBSERVATIONS.')
44044          CALL DPWRST('XXX','WRIT')
44045        ENDIF
44046C
44047        IF(NT.GT.1)THEN
44048          CALL MEAN(TEMP1,NT,IWRITE,YMEANT,IBUGA3,IERROR)
44049          CALL SD(TEMP1,NT,IWRITE,YSDT,IBUGA3,IERROR)
44050        ELSE
44051          WRITE(ICOUT,999)
44052          CALL DPWRST('XXX','WRIT')
44053          WRITE(ICOUT,203)
44054          CALL DPWRST('XXX','WRIT')
44055          WRITE(ICOUT,207)II
44056  207     FORMAT('      GROUP ',I5,' HAS FEWER THAN TWO ',
44057     1           'OBSERVATIONS.')
44058          CALL DPWRST('XXX','WRIT')
44059          WRITE(ICOUT,205)
44060          CALL DPWRST('XXX','WRIT')
44061          GOTO219
44062        ENDIF
44063C
44064C       CHECK FOR:
44065C
44066C           1) POSITIVE MEAN
44067C              (OMIT GROUP FROM COMPUTATIONS FOR NON-POSITIVE MEAN)
44068C           2) POSITIVE SD
44069C              (OMIT GROUP FROM COMPUTATIONS FOR NON-POSITIVE SD)
44070C           3) COEFFICIENT OF VARIATION < 0.33
44071C              (THIS WILL BE WARNING, BUT INCLUDE IN THE COMPUTATIONS)
44072C
44073        IF(YMEANT.LT.0.0)THEN
44074          WRITE(ICOUT,999)
44075          CALL DPWRST('XXX','WRIT')
44076          WRITE(ICOUT,203)
44077  203     FORMAT('***** WARNING COEFFICIENT OF VARIATION ',
44078     1           'TWO SAMPLE TEST--')
44079          CALL DPWRST('XXX','WRIT')
44080          WRITE(ICOUT,204)II
44081  204     FORMAT('      GROUP ',I5,' OF SAMPLE ONE HAS A NON-POSITIVE ',
44082     1           'MEAN.')
44083          CALL DPWRST('XXX','WRIT')
44084          WRITE(ICOUT,205)
44085  205     FORMAT('      IT WILL BE OMITTED FROM THE COMPUTATION.')
44086          CALL DPWRST('XXX','WRIT')
44087          GOTO219
44088        ELSEIF(YSDT.LE.0.0)THEN
44089          WRITE(ICOUT,999)
44090          CALL DPWRST('XXX','WRIT')
44091          WRITE(ICOUT,203)
44092          CALL DPWRST('XXX','WRIT')
44093          WRITE(ICOUT,206)II
44094  206     FORMAT('      GROUP ',I5,' OF SAMPLE ONE HAS A NON-POSITIVE ',
44095     1           'STANDARD DEVIATION.')
44096          CALL DPWRST('XXX','WRIT')
44097          WRITE(ICOUT,205)
44098          CALL DPWRST('XXX','WRIT')
44099          GOTO219
44100        ENDIF
44101C
44102        NGROUP=NGROUP+1
44103        CT=YSDT/YMEANT
44104        IF(NGROUP.EQ.1)THEN
44105          YMEAN1=YMEANT
44106          YSD1=YSDT
44107          CV1=CT
44108        ENDIF
44109        ANT=REAL(NT)
44110        ANTM1=ANT - 1.0
44111        UT=CT**2/(1.0 + (CT**2*ANTM1/ANT))
44112        DSUM1=DSUM1 + DBLE(ANTM1)
44113        DSUM2=DSUM2 + DBLE(ANTM1*UT)
44114        DSUM3=DSUM3 + DBLE(ANTM1)*DBLE(CT**2)
44115C
44116        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVC4')THEN
44117          WRITE(ICOUT,213)NGROUP,YMEANT,YSDT,CT,UT
44118  213     FORMAT('NGROUP,YMEANT,YSDT,CT,UT = ',I8,4G15.7)
44119          CALL DPWRST('XXX','WRIT')
44120        ENDIF
44121C
44122  219   CONTINUE
44123  210 CONTINUE
44124C
44125      IF(NGROUP.GT.1)THEN
44126        DTERM1=DSQRT(DSUM3/DSUM1)
44127        CV1=REAL(DTERM1)
44128      ENDIF
44129C
44130      IF(NGROUP.LT.1)THEN
44131        WRITE(ICOUT,999)
44132        CALL DPWRST('XXX','WRIT')
44133        WRITE(ICOUT,101)
44134        CALL DPWRST('XXX','WRIT')
44135        WRITE(ICOUT,281)
44136  281   FORMAT('      AFTER REMOVING GROUPS, LESS THAN ONE GROUP ',
44137     1         'REMAIN FOR SAMPLE ONE.')
44138        CALL DPWRST('XXX','WRIT')
44139        IERROR='YES'
44140        GOTO9000
44141      ENDIF
44142C
44143      NGROU1=NGROUP
44144      IDF1=INT(DSUM1+0.5D0)
44145      DNUM=DSUM2/DSUM1
44146C
44147C               **********************************************
44148C               **  STEP 3--                                **
44149C               **  COMPUTE THE DENOMINATOR OF THE F TEST   **
44150C               **********************************************
44151C
44152      ISTEPN='3'
44153      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVC4')
44154     1   CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
44155C
44156      CALL DISTIN(X2,N2,IWRITE,XIDTEM,NDIST,IBUGA3,IERROR)
44157      IF(IERROR.EQ.'YES')GOTO9000
44158      NGROUP=0
44159      DSUM1=0.0D0
44160      DSUM2=0.0D0
44161C
44162      DO310II=1,NDIST
44163        K=0
44164C
44165        YMEANT=CPUMIN
44166        YSDT=CPUMIN
44167        CT=CPUMIN
44168C
44169        HOLD=XIDTEM(II)
44170        DO320JJ=1,N2
44171          IF(X2(JJ).EQ.HOLD)THEN
44172            K=K+1
44173            TEMP1(K)=Y2(JJ)
44174          ENDIF
44175  320   CONTINUE
44176        NT=K
44177C
44178        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVC4')THEN
44179          WRITE(ICOUT,211)II,NT
44180          CALL DPWRST('XXX','WRIT')
44181        ENDIF
44182C
44183        IF(NT.GT.1)THEN
44184          CALL MEAN(TEMP1,NT,IWRITE,YMEANT,IBUGA3,IERROR)
44185          CALL SD(TEMP1,NT,IWRITE,YSDT,IBUGA3,IERROR)
44186        ELSE
44187          WRITE(ICOUT,999)
44188          CALL DPWRST('XXX','WRIT')
44189          WRITE(ICOUT,203)
44190          CALL DPWRST('XXX','WRIT')
44191          WRITE(ICOUT,207)II
44192          CALL DPWRST('XXX','WRIT')
44193          WRITE(ICOUT,205)
44194          CALL DPWRST('XXX','WRIT')
44195          GOTO319
44196        ENDIF
44197C
44198C       CHECK FOR:
44199C
44200C           1) POSITIVE MEAN
44201C              (OMIT GROUP FROM COMPUTATIONS FOR NON-POSITIVE MEAN)
44202C           2) POSITIVE SD
44203C              (OMIT GROUP FROM COMPUTATIONS FOR NON-POSITIVE SD)
44204C           3) COEFFICIENT OF VARIATION < 0.33
44205C              (THIS WILL BE WARNING, BUT INCLUDE IN THE COMPUTATIONS)
44206C
44207        IF(YMEANT.LT.0.0)THEN
44208          WRITE(ICOUT,999)
44209          CALL DPWRST('XXX','WRIT')
44210          WRITE(ICOUT,203)
44211          CALL DPWRST('XXX','WRIT')
44212          WRITE(ICOUT,204)II
44213          CALL DPWRST('XXX','WRIT')
44214          WRITE(ICOUT,205)
44215          CALL DPWRST('XXX','WRIT')
44216          GOTO319
44217        ELSEIF(YSDT.LE.0.0)THEN
44218          WRITE(ICOUT,999)
44219          CALL DPWRST('XXX','WRIT')
44220          WRITE(ICOUT,203)
44221          CALL DPWRST('XXX','WRIT')
44222          WRITE(ICOUT,206)II
44223          CALL DPWRST('XXX','WRIT')
44224          WRITE(ICOUT,205)
44225          CALL DPWRST('XXX','WRIT')
44226          GOTO319
44227        ENDIF
44228C
44229        NGROUP=NGROUP+1
44230        CT=YSDT/YMEANT
44231        IF(NGROUP.EQ.1)THEN
44232          YMEAN2=YMEANT
44233          YSD2=YSDT
44234          CV2=CT
44235        ENDIF
44236        ANT=REAL(NT)
44237        ANTM1=ANT - 1.0
44238        UT=CT**2/(1.0 + (CT**2*ANTM1/ANT))
44239        DSUM1=DSUM1 + DBLE(ANTM1)
44240        DSUM2=DSUM2 + DBLE(ANTM1*UT)
44241        DSUM3=DSUM3 + DBLE(ANTM1)*DBLE(CT**2)
44242C
44243        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVC4')THEN
44244          WRITE(ICOUT,213)NGROUP,YMEANT,YSDT,CT,UT
44245          CALL DPWRST('XXX','WRIT')
44246        ENDIF
44247C
44248  319   CONTINUE
44249  310 CONTINUE
44250C
44251      IF(NGROUP.LT.1)THEN
44252        WRITE(ICOUT,999)
44253        CALL DPWRST('XXX','WRIT')
44254        WRITE(ICOUT,101)
44255        CALL DPWRST('XXX','WRIT')
44256        WRITE(ICOUT,381)
44257  381   FORMAT('      AFTER REMOVING GROUPS, LESS THAN ONE GROUP ',
44258     1         'REMAIN FOR SAMPLE TWO.')
44259        CALL DPWRST('XXX','WRIT')
44260        IERROR='YES'
44261        GOTO9000
44262      ENDIF
44263C
44264      IF(NGROUP.GT.1)THEN
44265        DTERM1=DSQRT(DSUM3/DSUM1)
44266        CV2=REAL(DTERM1)
44267      ENDIF
44268C
44269      IDF2=INT(DSUM1+0.5D0)
44270      NGROU2=NGROUP
44271      DENOM=DSUM2/DSUM1
44272C
44273      IF(DENOM.NE.0.0D0)THEN
44274        STATVA=REAL(DNUM/DENOM)
44275      ELSE
44276        IERROR='YES'
44277        GOTO9000
44278      ENDIF
44279      CALL FCDF(STATVA,IDF1,IDF2,STATCD)
44280      CALL FPPF(0.50,IDF1,IDF2,FCV50)
44281      STATN1=REAL(IDF1)
44282      STATN2=REAL(IDF2)
44283      PVALLT=STATCD
44284      PVALUT=1.0 - STATCD
44285      IF(STATVA.LE.FCV50)THEN
44286        PVAL2T=2.0*PVALLT
44287      ELSE
44288        PVAL2T=2.0*PVALUT
44289      ENDIF
44290C
44291C               *****************
44292C               **  STEP 90--  **
44293C               **  EXIT.      **
44294C               *****************
44295C
44296 9000 CONTINUE
44297C
44298      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CVT4')THEN
44299        WRITE(ICOUT,999)
44300        CALL DPWRST('XXX','BUG ')
44301        WRITE(ICOUT,9011)
44302 9011   FORMAT('***** AT THE END       OF DPCVT4--')
44303        CALL DPWRST('XXX','BUG ')
44304        WRITE(ICOUT,9012)IBUGA3,IERROR
44305 9012   FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
44306        CALL DPWRST('XXX','BUG ')
44307        WRITE(ICOUT,9015)STATVA,STATN1,STATN2,STATCD
44308 9015   FORMAT('STATVA,STATN1,STATN2,STATCD = ',4G15.7)
44309        CALL DPWRST('XXX','BUG ')
44310        WRITE(ICOUT,9016)NGROU1,NGROU2,DNUM,DENOM
44311 9016   FORMAT('NGROU1,NGROU2,DNUM,DENOM = ',2I8,2G15.7)
44312        CALL DPWRST('XXX','BUG ')
44313        WRITE(ICOUT,9017)CV1,CV2
44314 9017   FORMAT('CV1,CV2 = ',2G15.7)
44315        CALL DPWRST('XXX','BUG ')
44316      ENDIF
44317C
44318      RETURN
44319      END
44320      SUBROUTINE DPCVT5(STATVA,STATCD,PVAL,STANU1,STANU2,
44321     1                  CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50,
44322     1                  CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50,
44323     1                  IFLAGU,IFRST,ILAST,
44324     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
44325C
44326C     PURPOSE--UTILITY ROUTINE USED BY DPCVTE.  THIS ROUTINE UPDATES THE
44327C              PARAMETERS "STATVAL", "STATCDF", "PVALUE", "STANU1",
44328C              "STANU2", AND VARIOUS CUTOFF POINTS AFTER A COEFFICIENT
44329C              OF VARIATION TEST.
44330C     WRITTEN BY--ALAN HECKERT
44331C                 STATISTICAL ENGINEERING DIVISION
44332C                 INFORMATION TECHNOLOGY LABORAOTRY
44333C                 NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY
44334C                 GAITHERSBURG, MD 20899-8980
44335C                 PHONE--301-975-2899
44336C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
44337C           OF THE NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY.
44338C     LANGUAGE--ANSI FORTRAN (1977)
44339C     VERSION NUMBER--2017/06
44340C     ORIGINAL VERSION--JUNE      2017.
44341C
44342C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
44343C
44344      CHARACTER*4 IFLAGU
44345      CHARACTER*4 IBUGA2
44346      CHARACTER*4 IBUGA3
44347      CHARACTER*4 ISUBRO
44348      CHARACTER*4 IERROR
44349C
44350      LOGICAL IFRST
44351      LOGICAL ILAST
44352C
44353      CHARACTER*4 IH
44354      CHARACTER*4 IH2
44355      CHARACTER*4 ISUBN0
44356      CHARACTER*4 ISUBN1
44357      CHARACTER*4 ISUBN2
44358      CHARACTER*4 ISTEPN
44359      CHARACTER*4 IOP
44360C
44361C---------------------------------------------------------------------
44362C
44363      SAVE IOUNI1
44364C
44365C-----COMMON VARIABLES (GENERAL)--------------------------------------
44366C
44367      INCLUDE 'DPCOPA.INC'
44368      INCLUDE 'DPCOHK.INC'
44369      INCLUDE 'DPCOHO.INC'
44370      INCLUDE 'DPCOP2.INC'
44371C
44372C-----START POINT-----------------------------------------------------
44373C
44374      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CVT5')THEN
44375        ISTEPN='1'
44376        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
44377        WRITE(ICOUT,999)
44378  999   FORMAT(1X)
44379        CALL DPWRST('XXX','BUG ')
44380        WRITE(ICOUT,51)
44381   51   FORMAT('***** AT THE BEGINNING OF DPCVT5--')
44382        CALL DPWRST('XXX','BUG ')
44383        WRITE(ICOUT,53)STATVA,STATCD,PVAL,STANU1,STANU2
44384   53   FORMAT('STATVA,STATCD,PVAL,STANU1,STANU2 = ',5G15.7)
44385        CALL DPWRST('XXX','BUG ')
44386        WRITE(ICOUT,54)CUTL95,CUTU95,CUTL99,CUTU99
44387   54   FORMAT('CUTL95,CUTU95,CUTL99,CUTU99 = ',4G15.7)
44388        CALL DPWRST('XXX','BUG ')
44389      ENDIF
44390C
44391      IF(IFLAGU.EQ.'FILE')THEN
44392C
44393        IF(IFRST)THEN
44394          IOP='OPEN'
44395          IFLAG1=1
44396          IFLAG2=0
44397          IFLAG3=0
44398          IFLAG4=0
44399          IFLAG5=0
44400          CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
44401     1                IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
44402     1                IBUGA3,ISUBRO,IERROR)
44403          IF(IERROR.EQ.'YES')GOTO9000
44404C
44405          WRITE(IOUNI1,295)
44406  295     FORMAT(11X,'STATVAL',8X,'STATCDF',8X,'PVALUE',
44407     1            8X,'STATNU1',8X,'STATNU2',
44408     1            7X,'0.0005  ',7X,'0.005   ',
44409     1            7X,'0.025   ',7X,'0.1     ',7X,'0.25    ',
44410     1            7X,'0.75    ',7X,'0.90    ',
44411     1            7X,'0.95    ',7X,'0.975   ',
44412     1            7X,'0.995   ',7X,'0.9995  ')
44413        ENDIF
44414        WRITE(IOUNI1,299)STATVA,STATCD,PVAL,STANU1,STANU2,
44415     1                   CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50
44416     1                   CUTU50,CUTU80,CUTU90,CUTU95,CUTU99,CTU999
44417  299   FORMAT(12E15.7)
44418      ELSEIF(IFLAGU.EQ.'ON')THEN
44419        IF(STATVA.NE.CPUMIN)THEN
44420          IH='STAT'
44421          IH2='VAL '
44422          VALUE0=STATVA
44423          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
44424     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
44425     1                IANS,IWIDTH,IBUGA3,IERROR)
44426        ENDIF
44427C
44428        IF(STATCD.NE.CPUMIN)THEN
44429          IH='STAT'
44430          IH2='CDF '
44431          VALUE0=STATCD
44432          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
44433     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
44434     1                IANS,IWIDTH,IBUGA3,IERROR)
44435        ENDIF
44436C
44437        IF(PVAL.NE.CPUMIN)THEN
44438          IH='PVAL'
44439          IH2='UE  '
44440          VALUE0=PVAL
44441          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
44442     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
44443     1                IANS,IWIDTH,IBUGA3,IERROR)
44444        ENDIF
44445C
44446        IF(STANU1.NE.CPUMIN)THEN
44447          IH='STAT'
44448          IH2='NU1 '
44449          VALUE0=STANU1
44450          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
44451     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
44452     1                IANS,IWIDTH,IBUGA3,IERROR)
44453        ENDIF
44454C
44455        IF(STANU2.NE.CPUMIN)THEN
44456          IH='STAT'
44457          IH2='NU2 '
44458          VALUE0=STANU2
44459          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
44460     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
44461     1                IANS,IWIDTH,IBUGA3,IERROR)
44462        ENDIF
44463C
44464        IF(CUTU50.NE.CPUMIN)THEN
44465          IH='CUTU'
44466          IH2='PP50'
44467          VALUE0=CUTU50
44468          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
44469     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
44470     1                IANS,IWIDTH,IBUGA3,IERROR)
44471        ENDIF
44472C
44473        IF(CUTU80.NE.CPUMIN)THEN
44474          IH='CUTU'
44475          IH2='PP80'
44476          VALUE0=CUTU80
44477          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
44478     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
44479     1                IANS,IWIDTH,IBUGA3,IERROR)
44480        ENDIF
44481C
44482        IF(CUTU90.NE.CPUMIN)THEN
44483          IH='CUTU'
44484          IH2='PP90'
44485          VALUE0=CUTU95
44486          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
44487     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
44488     1                IANS,IWIDTH,IBUGA3,IERROR)
44489        ENDIF
44490C
44491        IF(CUTU95.NE.CPUMIN)THEN
44492          IH='CUTU'
44493          IH2='PP95'
44494          VALUE0=CUTU95
44495          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
44496     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
44497     1                IANS,IWIDTH,IBUGA3,IERROR)
44498        ENDIF
44499C
44500        IF(CUTU99.NE.CPUMIN)THEN
44501          IH='CUTU'
44502          IH2='PP99'
44503          VALUE0=CUTU99
44504          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
44505     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
44506     1                IANS,IWIDTH,IBUGA3,IERROR)
44507        ENDIF
44508C
44509        IF(CTU999.NE.CPUMIN)THEN
44510          IH='CUTU'
44511          IH2='P999'
44512          VALUE0=CTU999
44513          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
44514     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
44515     1                IANS,IWIDTH,IBUGA3,IERROR)
44516        ENDIF
44517C
44518        IF(CUTL50.NE.CPUMIN)THEN
44519          IH='CUTL'
44520          IH2='OW50'
44521          VALUE0=CUTL50
44522          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
44523     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
44524     1                IANS,IWIDTH,IBUGA3,IERROR)
44525        ENDIF
44526C
44527        IF(CUTL80.NE.CPUMIN)THEN
44528          IH='CUTL'
44529          IH2='OW80'
44530          VALUE0=CUTL80
44531          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
44532     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
44533     1                IANS,IWIDTH,IBUGA3,IERROR)
44534        ENDIF
44535C
44536        IF(CUTL90.NE.CPUMIN)THEN
44537          IH='CUTL'
44538          IH2='PP90'
44539          VALUE0=CUTL90
44540          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
44541     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
44542     1                IANS,IWIDTH,IBUGA3,IERROR)
44543        ENDIF
44544C
44545        IF(CUTL95.NE.CPUMIN)THEN
44546          IH='CUTL'
44547          IH2='OW95'
44548          VALUE0=CUTL95
44549          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
44550     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
44551     1                IANS,IWIDTH,IBUGA3,IERROR)
44552        ENDIF
44553C
44554        IF(CUTL99.NE.CPUMIN)THEN
44555          IH='CUTL'
44556          IH2='OW99'
44557          VALUE0=CUTL99
44558          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
44559     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
44560     1                IANS,IWIDTH,IBUGA3,IERROR)
44561        ENDIF
44562C
44563        IF(CTL999.NE.CPUMIN)THEN
44564          IH='CUTL'
44565          IH2='P999'
44566          VALUE0=CTL999
44567          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
44568     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
44569     1                IANS,IWIDTH,IBUGA3,IERROR)
44570        ENDIF
44571      ENDIF
44572C
44573      IF(IFLAGU.EQ.'FILE')THEN
44574        IF(ILAST)THEN
44575          IOP='CLOS'
44576          IFLAG1=1
44577          IFLAG2=0
44578          IFLAG3=0
44579          IFLAG4=0
44580          IFLAG5=0
44581          CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
44582     1                IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
44583     1                IBUGA3,ISUBRO,IERROR)
44584C
44585          IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CVT5')THEN
44586            ISTEPN='3A'
44587            CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
44588            WRITE(ICOUT,999)
44589            CALL DPWRST('XXX','BUG ')
44590            WRITE(ICOUT,301)IERROR,IOUNI1
44591  301       FORMAT('AFTER CALL DPCLFI, IERROR,IOUNI1 = ',A4,2X,I5)
44592            CALL DPWRST('XXX','BUG ')
44593          ENDIF
44594C
44595          IF(IERROR.EQ.'YES')GOTO9000
44596        ENDIF
44597      ENDIF
44598C
44599C               *****************
44600C               **  STEP 90--  **
44601C               **  EXIT       **
44602C               *****************
44603C
44604 9000 CONTINUE
44605C
44606      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CVT5')THEN
44607        WRITE(ICOUT,999)
44608        CALL DPWRST('XXX','BUG ')
44609        WRITE(ICOUT,9011)
44610 9011   FORMAT('***** AT THE END OF DPCVT5--')
44611        CALL DPWRST('XXX','BUG ')
44612      ENDIF
44613C
44614      RETURN
44615      END
44616      SUBROUTINE DPCVT6(Y1,N1,Y2,N2,IWRITE,
44617     1                  YMEAN1,YSD1,C1,YMEAN2,YSD2,C2,
44618     1                  STATVA,STATCD,PVAL2T,PVALLT,PVALUT,
44619     1                  ISUBRO,IBUGA3,IERROR)
44620C
44621C     PURPOSE--THIS SUBROUTINE COMPUTES MILLER'S TEST FOR THE EQUALITY
44622C              OF THE COEFFICIENTS OF VARIATION FROM TWO SAMPLES.
44623C
44624C                 H0: GAMMA1 = GAMMA2
44625C
44626C              THE TEST STATISTIC IS
44627C
44628C                 (C1-C2)/SQRT{C**2/(2*(N1-1)) + C**4/(N1-1) +
44629C                              C**2/(2*(N2-1)) + C**4/(N2-1)}
44630C
44631C              WHERE
44632C
44633C                 N1     = THE SAMPLE SIZE FOR SAMPLE ONE
44634C                 C1     = THE SAMPLE COEFFICIENT OF VARIATION FOR
44635C                          SAMPLE ONE
44636C                 N2     = THE SAMPLE SIZE FOR SAMPLE TWO
44637C                 C2     = THE SAMPLE COEFFICIENT OF VARIATION FOR
44638C                          SAMPLE TWO
44639C                 C      = ((N1-1)*C1 + (N2-1)*C2)/(N1+N2-2)
44640C
44641C              THIS STATISTIC IS COMPARED TO THE STANDARD NORMAL
44642C              DISTRIBUTION.
44643C
44644C              CURRENTLY, ONLY THE RAW DATA CASE IS SUPPORTED.
44645C
44646C     INPUT  ARGUMENTS--Y1     = THE SINGLE PRECISION VECTOR OF
44647C                                RESPONSE VALUES FOR SAMPLE ONE.
44648C                     --N1     = THE INTEGER NUMBER OF OBSERVATIONS
44649C                                FOR SAMPLE ONE.
44650C                     --Y2     = THE SINGLE PRECISION VECTOR OF
44651C                                RESPONSE VALUES FOR SAMPLE TWO.
44652C                     --N2     = THE INTEGER NUMBER OF OBSERVATIONS
44653C                                FOR SAMPLE TWO.
44654C     OUTPUT ARGUMENTS--STATVA = THE SINGLE PRECISION VALUE OF THE
44655C                                COMPUTED STATISTIC.
44656C                     --STATCD = THE SINGLE PRECISION VALUE OF THE
44657C                                COMPUTED CDF OF THE TEST STATISTIC.
44658C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
44659C             TEST STATISTIC.
44660C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
44661C                   OF N FOR THIS SUBROUTINE.
44662C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
44663C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
44664C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
44665C     LANGUAGE--ANSI FORTRAN (1977)
44666C     REFERENCES--JOHANNES FORKMAN (2009)), "ESTIMATOR AND TESTS FOR
44667C                 COMMON COEFFICIENTS OF VARIATION IN NORMAL
44668C                 DISTRIBUTIONS", COMMUNICATIONS IN STATISTICS -
44669C                 THEROY AND METHODS, VOL. 38, NO. 2, PP. 233-251.
44670C     WRITTEN BY--ALAN HECKERT
44671C                 STATISTICAL ENGINEERING DIVISION
44672C                 INFORMATION TECHNOLOGY LABORATORY
44673C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
44674C                 GAITHERSBURG, MD 20899-8980
44675C                 PHONE--301-975-2899
44676C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
44677C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
44678C     LANGUAGE--ANSI FORTRAN (1977)
44679C     VERSION NUMBER--2017.06
44680C     ORIGINAL VERSION--JUNE      2017.
44681C
44682C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
44683C
44684      CHARACTER*4 IWRITE
44685      CHARACTER*4 ISUBRO
44686      CHARACTER*4 IBUGA3
44687      CHARACTER*4 IERROR
44688C
44689      CHARACTER*4 ISUBN1
44690      CHARACTER*4 ISUBN2
44691      CHARACTER*4 ISTEPN
44692C
44693C---------------------------------------------------------------------
44694C
44695      DIMENSION Y1(*)
44696      DIMENSION Y2(*)
44697C
44698C---------------------------------------------------------------------
44699C
44700      INCLUDE 'DPCOP2.INC'
44701C
44702C-----START POINT-----------------------------------------------------
44703C
44704      ISUBN1='DPCV'
44705      ISUBN2='T6  '
44706      IERROR='NO'
44707      IWRITE='OFF'
44708C
44709      STATVA=-99.0
44710      STATCD=-99.0
44711      PVAL2T=-99.0
44712      PVALLT=-99.0
44713      PVALUT=-99.0
44714      YMEAN1=-99.0
44715      YSD1=-99.0
44716      C1=-99.0
44717      YMEAN2=-99.0
44718      YSD2=-99.0
44719      C2=-99.0
44720C
44721      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CVT6')THEN
44722        WRITE(ICOUT,999)
44723  999   FORMAT(1X)
44724        CALL DPWRST('XXX','BUG ')
44725        WRITE(ICOUT,51)
44726   51   FORMAT('***** AT THE BEGINNING OF DPCVT6--')
44727        CALL DPWRST('XXX','BUG ')
44728        WRITE(ICOUT,52)IBUGA3,ISUBRO,N1,N2
44729   52   FORMAT('IBUGA3,ISUBRO,N1,N2 = ',2(A4,2X),2I8)
44730        CALL DPWRST('XXX','BUG ')
44731        DO55I=1,N1
44732          WRITE(ICOUT,56)I,Y1(I)
44733   56     FORMAT('I,Y1(I),X1(I) = ',I8,G15.7)
44734          CALL DPWRST('XXX','BUG ')
44735   55   CONTINUE
44736        DO65I=1,N2
44737          WRITE(ICOUT,66)I,Y2(I)
44738   66     FORMAT('I,Y2(I) = ',I8,G15.7)
44739          CALL DPWRST('XXX','BUG ')
44740   65   CONTINUE
44741      ENDIF
44742C
44743C               ********************************************
44744C               **  STEP 1--                              **
44745C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
44746C               ********************************************
44747C
44748      IF(N1.LT.2)THEN
44749        WRITE(ICOUT,999)
44750        CALL DPWRST('XXX','WRIT')
44751        WRITE(ICOUT,101)
44752  101   FORMAT('***** ERROR: COMMON COEFFICIENT OF VARIANCE ',
44753     1         'TWO SAMPLE TEST--')
44754        CALL DPWRST('XXX','WRIT')
44755        WRITE(ICOUT,102)
44756  102   FORMAT('      THE NUMBER OF OBSERVATIONS FOR SAMPLE ONE ',
44757     1          'IS LESS THAN TWO.')
44758        CALL DPWRST('XXX','WRIT')
44759        WRITE(ICOUT,103)N1
44760  103   FORMAT('      SAMPLE SIZE = ',I8)
44761        CALL DPWRST('XXX','WRIT')
44762        IERROR='YES'
44763        GOTO9000
44764      ELSEIF(N2.LT.2)THEN
44765        WRITE(ICOUT,999)
44766        CALL DPWRST('XXX','WRIT')
44767        WRITE(ICOUT,101)
44768        CALL DPWRST('XXX','WRIT')
44769        WRITE(ICOUT,112)
44770  112   FORMAT('      THE NUMBER OF OBSERVATIONS FOR SAMPLE TWO ',
44771     1          'IS LESS THAN TWO.')
44772        CALL DPWRST('XXX','WRIT')
44773        WRITE(ICOUT,103)N2
44774        CALL DPWRST('XXX','WRIT')
44775        IERROR='YES'
44776        GOTO9000
44777      ENDIF
44778C
44779C               ********************************************
44780C               **  STEP 2--                              **
44781C               **  COMPUTE THE TWO SAMPLE COEFICIENT OF  **
44782C               **  VARIATION TEST.                       **
44783C               ********************************************
44784C
44785      ISTEPN='2'
44786      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CVC4')
44787     1   CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
44788C
44789      CALL MEAN(Y1,N1,IWRITE,YMEAN1,IBUGA3,IERROR)
44790      CALL SD(Y1,N1,IWRITE,YSD1,IBUGA3,IERROR)
44791      IF(YMEAN1.GT.0.0)THEN
44792         C1=YSD1/YMEAN1
44793      ELSE
44794        WRITE(ICOUT,999)
44795        CALL DPWRST('XXX','WRIT')
44796        WRITE(ICOUT,101)
44797        CALL DPWRST('XXX','WRIT')
44798        WRITE(ICOUT,201)YMEAN1
44799  201   FORMAT('      THE MEAN FOR SAMPLE ONE IS NON-POSITIVE.')
44800        CALL DPWRST('XXX','WRIT')
44801        IERROR='YES'
44802        GOTO9000
44803      ENDIF
44804C
44805      CALL MEAN(Y2,N2,IWRITE,YMEAN2,IBUGA3,IERROR)
44806      CALL SD(Y2,N2,IWRITE,YSD2,IBUGA3,IERROR)
44807      IF(YMEAN2.GT.0.0)THEN
44808         C2=YSD2/YMEAN2
44809      ELSE
44810        WRITE(ICOUT,999)
44811        CALL DPWRST('XXX','WRIT')
44812        WRITE(ICOUT,101)
44813        CALL DPWRST('XXX','WRIT')
44814        WRITE(ICOUT,211)YMEAN2
44815  211   FORMAT('      THE MEAN FOR SAMPLE TWO IS NON-POSITIVE.')
44816        CALL DPWRST('XXX','WRIT')
44817        IERROR='YES'
44818        GOTO9000
44819      ENDIF
44820C
44821      AN1=REAL(N1)
44822      AN2=REAL(N2)
44823      C=((AN1-1.0)*C1 + (AN2-1.0)*C2)/(AN1 + AN2 - 2.0)
44824      CC=C*C
44825      C4=C**4
44826      TERM1=C1 - C2
44827      TERM2=CC/(2.0*(AN1-1.0))
44828      TERM3=C4/(AN1-1.0)
44829      TERM4=CC/(2.0*(AN2-1.0))
44830      TERM5=C4/(AN2-1.0)
44831      STATVA=TERM1/SQRT(TERM2 + TERM3 + TERM4 + TERM5)
44832      CALL NORCDF(STATVA,STATCD)
44833      PVALLT=STATCD
44834      PVALUT=1.0 - STATCD
44835      IF(STATVA.LE.0.0)THEN
44836        PVAL2T=2.0*PVALLT
44837      ELSE
44838        PVAL2T=2.0*PVALUT
44839      ENDIF
44840C
44841C               *****************
44842C               **  STEP 90--  **
44843C               **  EXIT.      **
44844C               *****************
44845C
44846 9000 CONTINUE
44847C
44848      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CVT6')THEN
44849        WRITE(ICOUT,999)
44850        CALL DPWRST('XXX','BUG ')
44851        WRITE(ICOUT,9011)
44852 9011   FORMAT('***** AT THE END       OF DPCVT6--')
44853        CALL DPWRST('XXX','BUG ')
44854        WRITE(ICOUT,9012)IBUGA3,IERROR
44855 9012   FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
44856        CALL DPWRST('XXX','BUG ')
44857        WRITE(ICOUT,9015)STATVA,STATCD,PVAL2T
44858 9015   FORMAT('STATVA,STATCD,PVAL2T = ',3G15.7)
44859        CALL DPWRST('XXX','BUG ')
44860        WRITE(ICOUT,9016)TERM1,TERM2,TERM3,TERM4,TERM5
44861 9016   FORMAT('TERM1,TERM2,TERM3,TERM4,TERM5 = ',5G15.7)
44862        CALL DPWRST('XXX','BUG ')
44863        WRITE(ICOUT,9017)CV1,CV2
44864 9017   FORMAT('CV1,CV2 = ',2G15.7)
44865        CALL DPWRST('XXX','BUG ')
44866      ENDIF
44867C
44868      RETURN
44869      END
44870      SUBROUTINE DPCWSH(YTEMP,XTEMP,MAXNXT,ICASAN,
44871     1                  ICAPSW,IFORSW,IMULT,
44872     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
44873C
44874C     PURPOSE--CARRY OUT COMMON WEIBULL SHAPE TEST
44875C              (K-SAMPLE HOMOGENEITY OF SHAPE PARAMETERS FOR TWO
44876C              PARAMETER WEIBULL)
44877C     EXAMPLE--COMMON WEIBULL SHAPE TEST Y X
44878C     REFERENCES--MCCOOL (2012), "USING THE WEIBULL DISTRIBUTION:
44879C                 RELIABILITY, MODELING, AND INFERENCE", WILEY, PP.
44880C                 236-238.
44881C     WRITTEN BY--ALAN HECKERT
44882C                 STATISTICAL ENGINEERING DIVISION
44883C                 INFORMATION TECHNOLOGY LABORATORY
44884C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
44885C                 Gaithersburg, MD 20899-8980
44886C                 PHONE--301-975-2899
44887C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
44888C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
44889C     LANGUAGE--ANSI FORTRAN (1977)
44890C     VERSION NUMBER--2014/4
44891C     ORIGINAL VERSION--APRIL     2014.
44892C     UPDATED         --DECEMBER  2016. CONVERT TEMP2 TO DOUBLE
44893C                                       PRECISION
44894C
44895C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
44896C
44897      CHARACTER*4 ICASAN
44898      CHARACTER*4 IFORSW
44899      CHARACTER*4 IMULT
44900      CHARACTER*4 IBUGA2
44901      CHARACTER*4 IBUGA3
44902      CHARACTER*4 IBUGQ
44903      CHARACTER*4 ISUBRO
44904      CHARACTER*4 IFOUND
44905      CHARACTER*4 IERROR
44906      CHARACTER*4 ICAPSW
44907C
44908      CHARACTER*4 IHWUSE
44909      CHARACTER*4 MESSAG
44910      CHARACTER*4 ICASE
44911C
44912      CHARACTER*4 ISUBN1
44913      CHARACTER*4 ISUBN2
44914      CHARACTER*4 ISTEPN
44915C
44916      CHARACTER*4 IH
44917      CHARACTER*4 IH2
44918      CHARACTER*4 IHOST1
44919      CHARACTER*4 ISUBN0
44920      CHARACTER*4 IWRITE
44921C
44922      CHARACTER*40 INAME
44923      PARAMETER (MAXSPN=30)
44924      CHARACTER*4 IVARN1(MAXSPN)
44925      CHARACTER*4 IVARN2(MAXSPN)
44926      CHARACTER*4 IVARTY(MAXSPN)
44927      REAL PVAR(MAXSPN)
44928      INTEGER ILIS(MAXSPN)
44929      INTEGER NRIGHT(MAXSPN)
44930      INTEGER ICOLR(MAXSPN)
44931C
44932C---------------------------------------------------------------------
44933C
44934      DIMENSION YTEMP(*)
44935      DIMENSION XTEMP(*)
44936C
44937C-----COMMON----------------------------------------------------------
44938C
44939      INCLUDE 'DPCOPA.INC'
44940C
44941      DIMENSION TEMP1(MAXOBV)
44942CCCCC DIMENSION TEMP2(MAXOBV)
44943      DIMENSION TEMP3(MAXOBV)
44944      DIMENSION TEMP4(MAXOBV)
44945      DIMENSION TEMP5(MAXOBV)
44946      DOUBLE PRECISION DTEMP1(MAXOBV)
44947      DOUBLE PRECISION DTEMP2(MAXOBV)
44948C
44949      INCLUDE 'DPCOZZ.INC'
44950      INCLUDE 'DPCOZD.INC'
44951      EQUIVALENCE(GARBAG(IGARB1),TEMP1(1))
44952      EQUIVALENCE(GARBAG(IGARB2),TEMP3(1))
44953      EQUIVALENCE(GARBAG(IGARB3),TEMP4(1))
44954      EQUIVALENCE(GARBAG(IGARB4),TEMP5(1))
44955      EQUIVALENCE(DGARBG(IDGAR1),DTEMP1(1))
44956      EQUIVALENCE(DGARBG(IDGAR2),DTEMP2(1))
44957C
44958      INCLUDE 'DPCOHK.INC'
44959      INCLUDE 'DPCOSU.INC'
44960      INCLUDE 'DPCOS2.INC'
44961      INCLUDE 'DPCODA.INC'
44962      INCLUDE 'DPCOST.INC'
44963C
44964C-----COMMON VARIABLES (GENERAL)--------------------------------------
44965C
44966      INCLUDE 'DPCOP2.INC'
44967C
44968C-----START POINT-----------------------------------------------------
44969C
44970      ISUBN1='DPCW'
44971      ISUBN2='SH  '
44972      IERROR='NO'
44973      IFOUND='YES'
44974C
44975      MAXCP1=MAXCOL+1
44976      MAXCP2=MAXCOL+2
44977      MAXCP3=MAXCOL+3
44978      MAXCP4=MAXCOL+4
44979      MAXCP5=MAXCOL+5
44980      MAXCP6=MAXCOL+6
44981C
44982C               ************************************************
44983C               **  TREAT THE COMMON WEIBULL SHAPE TEST CASE  **
44984C               ************************************************
44985C
44986      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CWSH')THEN
44987        WRITE(ICOUT,999)
44988  999   FORMAT(1X)
44989        CALL DPWRST('XXX','BUG ')
44990        WRITE(ICOUT,51)
44991   51   FORMAT('***** AT THE BEGINNING OF DPCWSH--')
44992        CALL DPWRST('XXX','BUG ')
44993        WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ,ISUBRO
44994   52   FORMAT('IBUGA2,IBUGA3,IBUGQ,ISUBRO = ',3(A4,2X),A4)
44995        CALL DPWRST('XXX','BUG ')
44996        WRITE(ICOUT,55)MAXNXT,IMULT,IFORSW
44997   55   FORMAT('MAXNXT,IMULT,IFORSW = ',I8,2X,A4,2X,A4)
44998        CALL DPWRST('XXX','BUG ')
44999      ENDIF
45000C
45001C               *********************************
45002C               **  STEP 1--                   **
45003C               **  EXTRACT THE VARIABLE LIST  **
45004C               *********************************
45005C
45006      ISTEPN='1'
45007      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CWSH')
45008     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
45009C
45010      INAME='COMMON WEIBULL SHAPE TEST'
45011      MINNA=1
45012      MAXNA=100
45013      MINNVA=2
45014      MAXNVA=2
45015      IFLAGE=1
45016      IFLAGM=0
45017      IF(IMULT.EQ.'ON')THEN
45018        IFLAGE=0
45019        IFLAGM=1
45020        MINNVA=2
45021        MAXNVA=30
45022      ENDIF
45023      MINN2=5
45024      IFLAGP=0
45025      JMIN=1
45026      JMAX=NUMARG
45027C
45028      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
45029     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
45030     1            JMIN,JMAX,
45031     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
45032     1            IVARN1,IVARN2,IVARTY,PVAR,
45033     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
45034     1            MINNVA,MAXNVA,
45035     1            IFLAGM,IFLAGP,
45036     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
45037      IF(IERROR.EQ.'YES')GOTO9000
45038C
45039      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CWSH')THEN
45040        WRITE(ICOUT,999)
45041        CALL DPWRST('XXX','BUG ')
45042        WRITE(ICOUT,181)
45043  181   FORMAT('***** AFTER CALL DPPARS--')
45044        CALL DPWRST('XXX','BUG ')
45045        WRITE(ICOUT,182)NQ,NUMVAR,IMULT
45046  182   FORMAT('NQ,NUMVAR,IMULT = ',2I8,2X,A4)
45047        CALL DPWRST('XXX','BUG ')
45048        IF(NUMVAR.GT.0)THEN
45049          DO185I=1,NUMVAR
45050            WRITE(ICOUT,187)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
45051     1                      ICOLR(I)
45052  187       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
45053     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
45054            CALL DPWRST('XXX','BUG ')
45055  185     CONTINUE
45056        ENDIF
45057      ENDIF
45058C
45059C               ******************************************************
45060C               **  STEP 3--                                        **
45061C               **  GENERATE THE COMMON WEIBULL SHAPE TEST FOR THE  **
45062C               **  VARIOUS CASES                                   **
45063C               ******************************************************
45064C
45065      ISTEPN='3'
45066      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CWSH')
45067     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
45068C
45069C     DEFINE CUT-OFF FOR "ACCEPTABLE" AGREEMENT.  LIMIT THIS
45070C     TO 0.90, 0.95, OR 0.99.  IF SHAPE PARAMETERS ARE JUDGED
45071C     EQUAL, THEN WE WILL ESTIMATE THE COMMON SHAPE PARAMETER.
45072C
45073      IH='ALPH'
45074      IH2='A   '
45075      IHWUSE='P'
45076      MESSAG='NO'
45077      CALL CHECKN(IH,IH2,IHWUSE,
45078     1            IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
45079     1            ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
45080      ALPHA=0.95
45081      IF(IERROR.EQ.'NO')ALPHA=VALUE(ILOCP)
45082      IF(ALPHA.LE.0.0 .OR. ALPHA.GE.1.0)THEN
45083        ALPHA=0.95
45084      ELSEIF(ALPHA.LT.0.50)THEN
45085        ALPHA=1.0-ALPHA
45086      ENDIF
45087      IF(ALPHA.LE.0.925)THEN
45088        ALPHA=0.90
45089      ELSEIF(ALPHA.GT.0.925 .AND. ALPHA.LT.0.975)THEN
45090        ALPHA=0.95
45091      ELSE
45092        ALPHA=0.99
45093      ENDIF
45094C
45095C               *****************************************
45096C               **  STEP 3A--                          **
45097C               **  CASE 1: TWO RESPONSE VARIABLES     **
45098C               **          WITH NO REPLICATION        **
45099C               *****************************************
45100C
45101C     NOTE: ONLY ALLOW MATRIX ARGUMENTS FOR "MULTIPLE" CASE.
45102C           FOR CASE WHERE SECOND VARIABLE IS A GROUP-ID VARIABLE,
45103C           MATRIX ARGUMENTS DON'T MAKE SENSE.
45104C
45105      IF(IMULT.EQ.'OFF')THEN
45106        ISTEPN='3A'
45107        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CWSH')
45108     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
45109C
45110        ICOL=1
45111        NUMVA2=2
45112        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
45113     1              INAME,IVARN1,IVARN2,IVARTY,
45114     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
45115     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
45116     1              MAXCP4,MAXCP5,MAXCP6,
45117     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
45118     1              Y,X,YTEMP,NLOCAL,NLOCA2,NLOCA3,ICASE,
45119     1              IBUGA3,ISUBRO,IFOUND,IERROR)
45120        IF(IERROR.EQ.'YES')GOTO9000
45121C
45122C       PUT GROUP-ID AND CENSORING VARIABLES IN "DPCOZD" SCRATCH SPACE
45123C       FOR USE BY THE WEIFU8 ROUTINE.
45124C
45125        IWRITE='OFF'
45126        CALL DISTIN(X,NLOCAL,IWRITE,TEMP1,NTEMP,IBUGA3,IERROR)
45127        DO311I=1,NLOCAL
45128          DGARBG(IDGAR2+I-1)=DBLE(X(I))
45129          DGARBG(IDGAR3+I-1)=1.0D0
45130  311   CONTINUE
45131        DO313I=1,NTEMP
45132          DGARBG(IDGAR4+I-1)=DBLE(TEMP1(I))
45133  313   CONTINUE
45134C
45135C               *********************************************
45136C               **  STEP 3B--                              **
45137C               **  PREPARE FOR ENTRANCE INTO DPCWS2--     **
45138C               *********************************************
45139C
45140        ISTEPN='3B'
45141        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CWSH')THEN
45142          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
45143          WRITE(ICOUT,999)
45144          CALL DPWRST('XXX','BUG ')
45145          WRITE(ICOUT,331)
45146  331     FORMAT('***** FROM DPCWSH, AS WE ARE ABOUT TO CALL DPCWS2--')
45147          CALL DPWRST('XXX','BUG ')
45148          WRITE(ICOUT,332)NLOCAL
45149  332     FORMAT('NLOCAL = ',I8)
45150          CALL DPWRST('XXX','BUG ')
45151          DO335I=1,NLOCAL
45152            WRITE(ICOUT,336)I,Y(I),X(I)
45153  336       FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
45154            CALL DPWRST('XXX','BUG ')
45155  335     CONTINUE
45156        ENDIF
45157C
45158        CALL DPCWS2(Y,X,NLOCAL,MAXOBV,IVARN1,IVARN2,
45159     1              TEMP1,DTEMP2,TEMP3,TEMP4,TEMP5,DTEMP1,
45160     1              ICAPSW,ICAPTY,IFORSW,IMULT,MINMAX,ALPHA,
45161     1              STATVA,STATCD,PVALUE,
45162     1              CUT0,CUT50,CUT75,CUT90,CUT95,CUT99,CUT999,
45163     1              IBUGA3,ISUBRO,IERROR)
45164C
45165C               *******************************************************
45166C               **  STEP 4A--                                        **
45167C               **  CASE 2: MULTIPLE RESPONSE VARIABLES.             **
45168C               *******************************************************
45169C
45170      ELSEIF(IMULT.EQ.'ON')THEN
45171        ISTEPN='4A'
45172        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CWSH')
45173     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
45174C
45175        ICOL=1
45176        NUMVA2=NUMVAR
45177        CALL DPPAR8(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
45178     1              INAME,IVARN1,IVARN2,IVARTY,
45179     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
45180     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
45181     1              MAXCP4,MAXCP5,MAXCP6,
45182     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
45183     1              XTEMP,Y,X,NLOCAL,ICASE,
45184     1              IBUGA3,ISUBRO,IFOUND,IERROR)
45185        IF(IERROR.EQ.'YES')GOTO9000
45186        NUMVAR=2
45187C
45188C       PUT GROUP-ID AND CENSORING VARIABLES IN "DPCOZD" SCRATCH SPACE
45189C       FOR USE BY THE WEIFU8 ROUTINE.
45190C
45191        IWRITE='OFF'
45192        CALL DISTIN(X,NLOCAL,IWRITE,TEMP1,NTEMP,IBUGA3,IERROR)
45193        DO411I=1,NLOCAL
45194          DGARBG(IDGAR2+I-1)=DBLE(X(I))
45195          DGARBG(IDGAR3+I-1)=1.0D0
45196  411   CONTINUE
45197        DO413I=1,NTEMP
45198          DGARBG(IDGAR4+I-1)=DBLE(TEMP1(I))
45199  413   CONTINUE
45200C
45201        IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CWSH')THEN
45202          ISTEPN='4B'
45203          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
45204          WRITE(ICOUT,999)
45205          CALL DPWRST('XXX','BUG ')
45206          WRITE(ICOUT,442)
45207  442     FORMAT('***** FROM THE MIDDLE  OF DPCWSH--')
45208          CALL DPWRST('XXX','BUG ')
45209          WRITE(ICOUT,443)ICASAN,NUMVAR,NLOCAL
45210  443     FORMAT('ICASAN,NUMVAR,NLOCAL = ',A4,2I8)
45211          CALL DPWRST('XXX','BUG ')
45212          IF(NLOCAL.GE.1)THEN
45213            DO445I=1,NLOCAL
45214              WRITE(ICOUT,446)I,Y(I),X(I)
45215  446         FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
45216              CALL DPWRST('XXX','BUG ')
45217  445       CONTINUE
45218          ENDIF
45219        ENDIF
45220C
45221        CALL DPCWS2(Y,X,NLOCAL,MAXOBV,IVARN1,IVARN2,
45222     1              TEMP1,DTEMP2,TEMP3,TEMP4,TEMP5,DTEMP1,
45223     1              ICAPSW,ICAPTY,IFORSW,IMULT,MINMAX,ALPHA,
45224     1              STATVA,STATCD,PVALUE,
45225     1              CUT0,CUT50,CUT975,CUT90,CUT95,CUT99,CUT999,
45226     1              IBUGA3,ISUBRO,IERROR)
45227      ENDIF
45228C
45229C               ***************************************
45230C               **  STEP 61--                        **
45231C               **  UPDATE INTERNAL DATAPLOT TABLES  **
45232C               ***************************************
45233C
45234      ISTEPN='61'
45235      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CWSH')
45236     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
45237C
45238      ISUBN0='DPCW'
45239C
45240      IH='STAT'
45241      IH2='VAL '
45242      VALUE0=STATVA
45243      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
45244     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
45245     1IANS,IWIDTH,IBUGA3,IERROR)
45246C
45247      IH='STAT'
45248      IH2='CDF '
45249      VALUE0=STATCD
45250      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
45251     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
45252     1IANS,IWIDTH,IBUGA3,IERROR)
45253C
45254      IH='PVAL'
45255      IH2='UE  '
45256      VALUE0=PVALUE
45257      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
45258     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
45259     1IANS,IWIDTH,IBUGA3,IERROR)
45260C
45261      IH='CUTO'
45262      IH2='FF0 '
45263      VALUE0=CUT0
45264      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
45265     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
45266     1IANS,IWIDTH,IBUGA3,IERROR)
45267C
45268      IH='CUTO'
45269      IH2='FF50'
45270      VALUE0=CUT50
45271      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
45272     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
45273     1IANS,IWIDTH,IBUGA3,IERROR)
45274C
45275      IH='CUTO'
45276      IH2='FF75'
45277      VALUE0=CUT75
45278      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
45279     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
45280     1IANS,IWIDTH,IBUGA3,IERROR)
45281C
45282      IH='CUTO'
45283      IH2='FF90'
45284      VALUE0=CUT90
45285      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
45286     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
45287     1IANS,IWIDTH,IBUGA3,IERROR)
45288C
45289      IH='CUTO'
45290      IH2='FF95'
45291      VALUE0=CUT95
45292      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
45293     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
45294     1IANS,IWIDTH,IBUGA3,IERROR)
45295C
45296      IH='CUTO'
45297      IH2='FF99'
45298      VALUE0=CUT99
45299      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
45300     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
45301     1IANS,IWIDTH,IBUGA3,IERROR)
45302C
45303      IH='CUTO'
45304      IH2='F975'
45305      VALUE0=CUT975
45306      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
45307     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
45308     1IANS,IWIDTH,IBUGA3,IERROR)
45309C
45310      IH='CUTO'
45311      IH2='F999'
45312      VALUE0=CUT99
45313      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
45314     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
45315     1IANS,IWIDTH,IBUGA3,IERROR)
45316C
45317C               *****************
45318C               **  STEP 90--  **
45319C               **  EXIT       **
45320C               *****************
45321C
45322 9000 CONTINUE
45323      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CWSH')THEN
45324        WRITE(ICOUT,999)
45325        CALL DPWRST('XXX','BUG ')
45326        WRITE(ICOUT,9011)
45327 9011   FORMAT('***** AT THE END       OF DPCWSH--')
45328        CALL DPWRST('XXX','BUG ')
45329        WRITE(ICOUT,9014)NLOCAL,STATVA,STATCD
45330 9014   FORMAT('NLOCAL,STATVA,STATCD = ',I8,2G15.7)
45331        CALL DPWRST('XXX','BUG ')
45332        WRITE(ICOUT,9016)IFOUND,IERROR
45333 9016   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
45334        CALL DPWRST('XXX','BUG ')
45335      ENDIF
45336C
45337      RETURN
45338      END
45339      SUBROUTINE DPCWS2(Y,TAG,N,MAXOBV,IVARID,IVARI2,
45340     1                  YTEMP,YTEMP2,XTEMP1,XIDTEM,YSTAT,DTEMP1,
45341     1                  ICAPSW,ICAPTY,IFORSW,IMULT,MINMAX,ALPHAT,
45342     1                  STATVA,STATCD,PVALUE,
45343     1                  CUT0,CUT50,CUT75,CUT90,CUT95,CUT99,CUT999,
45344     1                  IBUGA3,ISUBRO,IERROR)
45345C
45346C     PURPOSE--CARRY OUT COMMON WEIBULL SHAPE TEST
45347C              (K-SAMPLE HOMOGENEITY OF SHAPE PARAMETERS FOR TWO
45348C              PARAMETER WEIBULL)
45349C     EXAMPLE--COMMON WEIBULL SHAPE TEST Y X
45350C     REFERENCES--MCCOOL (2012), "USING THE WEIBULL DISTRIBUTION:
45351C                 RELIABILITY, MODELING, AND INFERENCE", WILEY, PP.
45352C                 236-238.
45353C     WRITTEN BY--ALAN HECKERT
45354C                 STATISTICAL ENGINEERING DIVISION
45355C                 INFORMATION TECHNOLOGY LABORATORY
45356C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
45357C                 Gaithersburg, MD 20899-8980
45358C                 PHONE--301-975-2899
45359C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
45360C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
45361C     LANGUAGE--ANSI FORTRAN (1977)
45362C     VERSION NUMBER--2014/4
45363C     ORIGINAL VERSION--APRIL     2014.
45364C
45365C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
45366C
45367      CHARACTER*4 IBUGA3
45368      CHARACTER*4 ISUBRO
45369      CHARACTER*4 IERROR
45370      CHARACTER*4 ICAPSW
45371      CHARACTER*4 ICAPTY
45372      CHARACTER*4 IFORSW
45373      CHARACTER*4 IMULT
45374      CHARACTER*4 IVARID(*)
45375      CHARACTER*4 IVARI2(*)
45376C
45377      CHARACTER*4 IWRITE
45378      CHARACTER*4 ISUBN1
45379      CHARACTER*4 ISUBN2
45380      CHARACTER*4 ISTEPN
45381      CHARACTER*4 ILIKFL
45382      CHARACTER*4 IOP
45383C
45384C---------------------------------------------------------------------
45385C
45386      DIMENSION Y(*)
45387      DIMENSION TAG(*)
45388      DIMENSION YTEMP(*)
45389      DIMENSION XTEMP1(*)
45390      DIMENSION YSTAT(*)
45391      DIMENSION XIDTEM(*)
45392C
45393      DOUBLE PRECISION YTEMP2(*)
45394      DOUBLE PRECISION DTEMP1(*)
45395C
45396      PARAMETER (NUMALP=8)
45397      PARAMETER (NUMAL2=6)
45398      REAL ALPHA(NUMALP)
45399      REAL ALPHA2(NUMAL2)
45400      REAL ALOWLM(NUMAL2)
45401      REAL AUPPLM(NUMAL2)
45402C
45403      PARAMETER(NUMCLI=4)
45404      PARAMETER(MAXLIN=2)
45405      PARAMETER (MAXROW=30)
45406      CHARACTER*60 ITITLE
45407      CHARACTER*60 ITITLZ
45408      CHARACTER*1  ITITL9
45409      CHARACTER*60 ITEXT(MAXROW)
45410      CHARACTER*4  ALIGN(NUMCLI)
45411      CHARACTER*4  VALIGN(NUMCLI)
45412      REAL         AVALUE(MAXROW)
45413      INTEGER      NCTEXT(MAXROW)
45414      INTEGER      IDIGIT(MAXROW)
45415      INTEGER      NTOT(MAXROW)
45416      CHARACTER*60 ITITL2(MAXLIN,NUMCLI)
45417      CHARACTER*15 IVALUE(MAXROW,NUMCLI)
45418      CHARACTER*4  ITYPCO(NUMCLI)
45419      INTEGER      NCTIT2(MAXLIN,NUMCLI)
45420      INTEGER      NCVALU(MAXROW,NUMCLI)
45421      INTEGER      IWHTML(NUMCLI)
45422      INTEGER      IWRTF(NUMCLI)
45423      REAL         AMAT(MAXROW,NUMCLI)
45424      LOGICAL IFRST
45425      LOGICAL ILAST
45426C
45427      INTEGER   NSIZE(50)
45428      INTEGER   NR(50)
45429      REAL      SCALE(50)
45430      COMMON/CWSHAP/IN,NDIST2,NSIZE,NR,SCALE,BETAMN,BETAMX,BETAMD
45431C
45432C---------------------------------------------------------------------
45433C
45434      INCLUDE 'DPCOP2.INC'
45435C
45436      DATA ALPHA/
45437     1 0.0, 50.0, 75.0, 90.0, 95.0, 97.5, 99.0, 99.9/
45438      DATA ALPHA2 /0.50, 0.20, 0.10, 0.05, 0.01, 0.001/
45439C
45440C-----START POINT-----------------------------------------------------
45441C
45442      ISUBN1='DPCW'
45443      ISUBN2='S2  '
45444      IERROR='NO'
45445C
45446      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CWS2')THEN
45447        WRITE(ICOUT,999)
45448  999   FORMAT(1X)
45449        CALL DPWRST('XXX','WRIT')
45450        WRITE(ICOUT,51)
45451   51   FORMAT('**** AT THE BEGINNING OF DPCWS2--')
45452        CALL DPWRST('XXX','WRIT')
45453        WRITE(ICOUT,52)IBUGA3,ISUBRO,IMULT,N,ALPHAT
45454   52   FORMAT('IBUGA3,ISUBRO,IMULT,N,ALPHAT = ',3(A4,2X),I8,G15.7)
45455        CALL DPWRST('XXX','WRIT')
45456        DO56I=1,N
45457          WRITE(ICOUT,57)I,Y(I),TAG(I)
45458   57     FORMAT('I,Y(I),TAG(I) = ',I8,2G15.7)
45459          CALL DPWRST('XXX','WRIT')
45460   56   CONTINUE
45461      ENDIF
45462C
45463C               *************************************
45464C               **  STEP 41--                      **
45465C               **  CARRY OUT CALCULATIONS         **
45466C               **  FOR COMMON WEIBULL SHAPE TEST  **
45467C               *************************************
45468C
45469      ISTEPN='41'
45470      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CWS2')
45471     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
45472C
45473      CALL DPCWS3(Y,TAG,N,IWRITE,ISEED,MINMAX,MAXOBV,
45474     1            YTEMP,YTEMP2,XTEMP1,XIDTEM,YSTAT,DTEMP1,
45475     1            STATVA,STATCD,PVALUE,NDIST,NGROUP,
45476     1            CV90,CV95,CV99,BETACM,
45477     1            IBUGA3,ISUBRO,IERROR)
45478      IF(IERROR.EQ.'YES')GOTO9000
45479C
45480      CUT0=0.0
45481      CUT50=YSTAT(5000)
45482      CUT75=YSTAT(7500)
45483      CUT90=YSTAT(9000)
45484      CUT95=YSTAT(9500)
45485      CUT975=YSTAT(9750)
45486      CUT99=YSTAT(9900)
45487      CUT999=YSTAT(9990)
45488C
45489C               *****************************************
45490C               **  STEP 42--                          **
45491C               **  IF SHAPES ARE EQUAL AT SPECIFIED   **
45492C               **  ALPHA, THEN ESTIMATE THE COMMON    **
45493C               **  SHAPE PARAMETER.                   **
45494C               *****************************************
45495C
45496      IF(BETACM.GT.0.0)THEN
45497        NSIMUL=10000
45498        DO4101I=1,NSIMUL
45499          XTEMP1(I)=YSTAT(NSIMUL+I)
45500 4101   CONTINUE
45501C
45502        CALL SORT(XTEMP1,NSIMUL,XTEMP1)
45503        DO4191I=1,NUMAL2
45504          ALP=ALPHA2(I)
45505          P1=100.0*(ALP/2.0)
45506          P2=100.0*(1.0-(ALP/2.0))
45507          CALL PERCEN(P2,XTEMP1,NSIMUL,IWRITE,YTEMP,MAXOBV,
45508     1                XPERC,IBUGA3,IERROR)
45509          ALOWLM(I)=BETACM/XPERC
45510          CALL PERCEN(P1,XTEMP1,NSIMUL,IWRITE,YTEMP,MAXOBV,
45511     1                XPERC,IBUGA3,IERROR)
45512          AUPPLM(I)=BETACM/XPERC
45513 4191   CONTINUE
45514C
45515C       WRITE SCALE PARAMETERS BASED ON COMMON SHAPE PARAMETER TO
45516C       dpst1f.dat.
45517C
45518        IOP='OPEN'
45519        IFLG1=1
45520        IFLG2=0
45521        IFLG3=0
45522        IFLG4=0
45523        IFLG5=0
45524        CALL DPAUFI(IOP,IFLG1,IFLG2,IFLG3,IFLG4,IFLG5,
45525     1              IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
45526     1              IBUGA3,ISUBRO,IERROR)
45527        IF(IERROR.EQ.'YES')GOTO9000
45528        DO4193I=1,NDIST
45529          WRITE(IOUNI1,'(I8,E15.7)')I,SCALE(I)
45530 4193   CONTINUE
45531        IOP='CLOS'
45532        CALL DPAUFI(IOP,IFLG1,IFLG2,IFLG3,IFLG4,IFLG5,
45533     1              IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
45534     1              IBUGA3,ISUBRO,IERROR)
45535C
45536      ENDIF
45537C
45538C               ******************************
45539C               **   STEP 42--              **
45540C               **   WRITE OUT EVERYTHING   **
45541C               ******************************
45542C
45543      ISTEPN='42'
45544      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CWS2')
45545     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
45546C
45547      IF(IPRINT.EQ.'OFF')GOTO9000
45548C
45549      NUMDIG=7
45550      IF(IFORSW.EQ.'1')NUMDIG=1
45551      IF(IFORSW.EQ.'2')NUMDIG=2
45552      IF(IFORSW.EQ.'3')NUMDIG=3
45553      IF(IFORSW.EQ.'4')NUMDIG=4
45554      IF(IFORSW.EQ.'5')NUMDIG=5
45555      IF(IFORSW.EQ.'6')NUMDIG=6
45556      IF(IFORSW.EQ.'7')NUMDIG=7
45557      IF(IFORSW.EQ.'8')NUMDIG=8
45558      IF(IFORSW.EQ.'9')NUMDIG=9
45559      IF(IFORSW.EQ.'0')NUMDIG=0
45560      IF(IFORSW.EQ.'E')NUMDIG=-2
45561      IF(IFORSW.EQ.'-2')NUMDIG=-2
45562      IF(IFORSW.EQ.'-3')NUMDIG=-3
45563      IF(IFORSW.EQ.'-4')NUMDIG=-4
45564      IF(IFORSW.EQ.'-5')NUMDIG=-5
45565      IF(IFORSW.EQ.'-6')NUMDIG=-6
45566      IF(IFORSW.EQ.'-7')NUMDIG=-7
45567      IF(IFORSW.EQ.'-8')NUMDIG=-8
45568      IF(IFORSW.EQ.'-9')NUMDIG=-9
45569C
45570      ITITLE='Test for Common Weibull Shape Parameter'
45571      NCTITL=39
45572      ITITLZ='(For the 2-Parameter Weibull Distribution)'
45573      NCTITZ=42
45574C
45575      ICNT=1
45576      ITEXT(ICNT)=' '
45577      NCTEXT(ICNT)=0
45578      AVALUE(ICNT)=0.0
45579      IDIGIT(ICNT)=-1
45580      IF(IMULT.EQ.'OFF')THEN
45581        ICNT=ICNT+1
45582        ITEXT(ICNT)='Response Variable: '
45583        WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1)(1:4)
45584        WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1)(1:4)
45585        NCTEXT(ICNT)=27
45586        AVALUE(ICNT)=0.0
45587        IDIGIT(ICNT)=-1
45588C
45589        ICNT=ICNT+1
45590        ITEXT(ICNT)='Group-ID Variable: '
45591        WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(2)(1:4)
45592        WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(2)(1:4)
45593        NCTEXT(ICNT)=27
45594        AVALUE(ICNT)=0.0
45595        IDIGIT(ICNT)=-1
45596      ENDIF
45597C
45598      ICNT=ICNT+1
45599      ITEXT(ICNT)=' '
45600      NCTEXT(ICNT)=1
45601      AVALUE(ICNT)=0.0
45602      IDIGIT(ICNT)=-1
45603C
45604      ICNT=ICNT+1
45605      ITEXT(ICNT)='H0: Homogeneous Shape Parameters'
45606      NCTEXT(ICNT)=32
45607      AVALUE(ICNT)=0.0
45608      IDIGIT(ICNT)=-1
45609      ICNT=ICNT+1
45610      ITEXT(ICNT)='Ha: Shape Parameters Are Not Homogeneous'
45611      NCTEXT(ICNT)=40
45612      AVALUE(ICNT)=0.0
45613      IDIGIT(ICNT)=-1
45614C
45615      ICNT=ICNT+1
45616      ITEXT(ICNT)=' '
45617      NCTEXT(ICNT)=1
45618      AVALUE(ICNT)=0.0
45619      IDIGIT(ICNT)=-1
45620      ICNT=ICNT+1
45621      ITEXT(ICNT)='Summary Statistics:'
45622      NCTEXT(ICNT)=19
45623      AVALUE(ICNT)=0.0
45624      IDIGIT(ICNT)=-1
45625      ICNT=ICNT+1
45626      ITEXT(ICNT)='Total Number of Observations:'
45627      NCTEXT(ICNT)=29
45628      AVALUE(ICNT)=REAL(N)
45629      IDIGIT(ICNT)=0
45630      ICNT=ICNT+1
45631      ITEXT(ICNT)='Number of Groups:'
45632      NCTEXT(ICNT)=17
45633      AVALUE(ICNT)=REAL(NDIST)
45634      IDIGIT(ICNT)=0
45635      ICNT=ICNT+1
45636      ITEXT(ICNT)='Number of Groups Used in Test:'
45637      NCTEXT(ICNT)=30
45638      AVALUE(ICNT)=REAL(NGROUP)
45639      IDIGIT(ICNT)=0
45640      ICNT=ICNT+1
45641      ITEXT(ICNT)=' '
45642      NCTEXT(ICNT)=1
45643      AVALUE(ICNT)=0.0
45644      IDIGIT(ICNT)=-1
45645      ICNT=ICNT+1
45646      ITEXT(ICNT)='Minimum Value of Shape Parameter:'
45647      NCTEXT(ICNT)=33
45648      AVALUE(ICNT)=BETAMN
45649      IDIGIT(ICNT)=NUMDIG
45650      ICNT=ICNT+1
45651      ITEXT(ICNT)='Maximum Value of Shape Parameter:'
45652      NCTEXT(ICNT)=33
45653      AVALUE(ICNT)=BETAMX
45654      IDIGIT(ICNT)=NUMDIG
45655C
45656      ICNT=ICNT+1
45657      ITEXT(ICNT)='Test Statistic Value:'
45658      NCTEXT(ICNT)=21
45659      AVALUE(ICNT)=STATVA
45660      IDIGIT(ICNT)=NUMDIG
45661      ICNT=ICNT+1
45662      ITEXT(ICNT)='CDF of Test Statistic:'
45663      NCTEXT(ICNT)=22
45664      AVALUE(ICNT)=STATCD
45665      IDIGIT(ICNT)=NUMDIG
45666      ICNT=ICNT+1
45667      ITEXT(ICNT)='P-Value:'
45668      NCTEXT(ICNT)=8
45669      AVALUE(ICNT)=PVALUE
45670      IDIGIT(ICNT)=NUMDIG
45671C
45672      IF(BETACM.GT.0.0)THEN
45673        ICNT=ICNT+1
45674        ITEXT(ICNT)=' '
45675        NCTEXT(ICNT)=1
45676        AVALUE(ICNT)=0.0
45677        IDIGIT(ICNT)=-1
45678        ICNT=ICNT+1
45679        ITEXT(ICNT)='Estimate of Common Shape Parameter:'
45680        NCTEXT(ICNT)=35
45681        AVALUE(ICNT)=BETACM
45682        IDIGIT(ICNT)=NUMDIG
45683      ENDIF
45684C
45685      NUMROW=ICNT
45686      DO4210I=1,NUMROW
45687        NTOT(I)=15
45688 4210 CONTINUE
45689C
45690      IFRST=.TRUE.
45691      ILAST=.TRUE.
45692C
45693      ISTEPN='42A'
45694      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CWS2')
45695     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
45696C
45697      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
45698     1            AVALUE,IDIGIT,
45699     1            NTOT,NUMROW,
45700     1            ICAPSW,ICAPTY,ILAST,IFRST,
45701     1            ISUBRO,IBUGA3,IERROR)
45702C
45703      ISTEPN='42B'
45704      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CWS2')
45705     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
45706C
45707      ITITLE=' '
45708      NCTITL=0
45709C
45710      ITITL9=' '
45711      NCTIT9=0
45712      ITITLE(1:44)='Percent Points of the Reference Distribution'
45713      NCTITL=44
45714      NUMLIN=1
45715      NUMROW=8
45716      NUMCOL=3
45717      ITITL2(1,1)='Percent Point'
45718      ITITL2(1,2)=' '
45719      ITITL2(1,3)='Value'
45720      NCTIT2(1,1)=13
45721      NCTIT2(1,2)=1
45722      NCTIT2(1,3)=5
45723C
45724      NMAX=0
45725      DO4221I=1,NUMCOL
45726        VALIGN(I)='b'
45727        ALIGN(I)='r'
45728        NTOT(I)=15
45729        IF(I.EQ.2)NTOT(I)=5
45730        NMAX=NMAX+NTOT(I)
45731        IDIGIT(I)=NUMDIG
45732        ITYPCO(I)='NUME'
45733 4221 CONTINUE
45734      ITYPCO(2)='ALPH'
45735      IDIGIT(1)=1
45736      IDIGIT(3)=3
45737      DO4223I=1,NUMROW
45738        DO4225J=1,NUMCOL
45739          NCVALU(I,J)=0
45740          IVALUE(I,J)=' '
45741          NCVALU(I,J)=0
45742          AMAT(I,J)=0.0
45743          IF(J.EQ.1)THEN
45744            AMAT(I,J)=ALPHA(I)
45745          ELSEIF(J.EQ.2)THEN
45746            IVALUE(I,J)='='
45747            NCVALU(I,J)=1
45748          ELSEIF(J.EQ.3)THEN
45749            IF(I.EQ.1)THEN
45750              AMAT(I,J)=RND(CUT0,IDIGIT(J))
45751            ELSEIF(I.EQ.2)THEN
45752              AMAT(I,J)=RND(CUT50,IDIGIT(J))
45753            ELSEIF(I.EQ.3)THEN
45754              AMAT(I,J)=RND(CUT75,IDIGIT(J))
45755            ELSEIF(I.EQ.4)THEN
45756              AMAT(I,J)=RND(CUT90,IDIGIT(J))
45757            ELSEIF(I.EQ.5)THEN
45758              AMAT(I,J)=RND(CUT95,IDIGIT(J))
45759            ELSEIF(I.EQ.6)THEN
45760              AMAT(I,J)=RND(CUT975,IDIGIT(J))
45761            ELSEIF(I.EQ.7)THEN
45762              AMAT(I,J)=RND(CUT99,IDIGIT(J))
45763            ELSEIF(I.EQ.8)THEN
45764              AMAT(I,J)=RND(CUT999,IDIGIT(J))
45765            ENDIF
45766          ENDIF
45767 4225   CONTINUE
45768 4223 CONTINUE
45769C
45770      IWHTML(1)=150
45771      IWHTML(2)=50
45772      IWHTML(3)=150
45773      IWRTF(1)=2000
45774      IWRTF(2)=IWRTF(1)+500
45775      IWRTF(3)=IWRTF(2)+2000
45776      IFRST=.TRUE.
45777      ILAST=.FALSE.
45778C
45779      ISTEPN='42C'
45780      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CWS2')
45781     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
45782C
45783      CALL DPDTA4(ITITL9,NCTIT9,
45784     1            ITITLE,NCTITL,ITITL2,NCTIT2,
45785     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
45786     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW,
45787     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
45788     1            ICAPSW,ICAPTY,IFRST,ILAST,
45789     1            ISUBRO,IBUGA3,IERROR)
45790C
45791      ISTEPN='42D'
45792      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CWS2')
45793     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
45794C
45795      CDF1=CUT90
45796      CDF2=CUT95
45797      CDF3=CUT975
45798      CDF4=CUT99
45799C
45800      ITITL9=' '
45801      NCTIT9=0
45802      ITITLE='Conclusions (Upper 1-Tailed Test)'
45803      NCTITL=33
45804      NUMLIN=1
45805      NUMROW=4
45806      NUMCOL=4
45807      ITITL2(1,1)='Alpha'
45808      ITITL2(1,2)='CDF'
45809      ITITL2(1,3)='Critical Value'
45810      ITITL2(1,4)='Conclusion'
45811      NCTIT2(1,1)=5
45812      NCTIT2(1,2)=3
45813      NCTIT2(1,3)=14
45814      NCTIT2(1,4)=10
45815C
45816      NMAX=0
45817      DO4321I=1,NUMCOL
45818        VALIGN(I)='b'
45819        ALIGN(I)='r'
45820        NTOT(I)=15
45821        IF(I.EQ.1 .OR. I.EQ.2)NTOT(I)=7
45822        IF(I.EQ.3)NTOT(I)=17
45823        NMAX=NMAX+NTOT(I)
45824        IDIGIT(I)=3
45825        ITYPCO(I)='ALPH'
45826 4321 CONTINUE
45827      ITYPCO(3)='NUME'
45828      IDIGIT(1)=0
45829      IDIGIT(2)=0
45830      DO4323I=1,NUMROW
45831        DO4325J=1,NUMCOL
45832          NCVALU(I,J)=0
45833          IVALUE(I,J)=' '
45834          NCVALU(I,J)=0
45835          AMAT(I,J)=0.0
45836 4325   CONTINUE
45837 4323 CONTINUE
45838      IVALUE(1,1)='10%'
45839      IVALUE(2,1)='5%'
45840      IVALUE(3,1)='2.5%'
45841      IVALUE(4,1)='1%'
45842      IVALUE(1,2)='90%'
45843      IVALUE(2,2)='95%'
45844      IVALUE(3,2)='97.5%'
45845      IVALUE(4,2)='99%'
45846      NCVALU(1,1)=3
45847      NCVALU(2,1)=2
45848      NCVALU(3,1)=4
45849      NCVALU(4,1)=2
45850      NCVALU(1,2)=3
45851      NCVALU(2,2)=3
45852      NCVALU(3,2)=5
45853      NCVALU(4,2)=3
45854      IVALUE(1,4)='Accept H0'
45855      IVALUE(2,4)='Accept H0'
45856      IVALUE(3,4)='Accept H0'
45857      IVALUE(4,4)='Accept H0'
45858      NCVALU(1,4)=9
45859      NCVALU(2,4)=9
45860      NCVALU(3,4)=9
45861      NCVALU(4,4)=9
45862      IF(STATVA.GT.CUT90)IVALUE(1,4)='Reject H0'
45863      IF(STATVA.GT.CUT95)IVALUE(2,4)='Reject H0'
45864      IF(STATVA.GT.CUT975)IVALUE(3,4)='Reject H0'
45865      IF(STATVA.GT.CUT99)IVALUE(4,4)='Reject H0'
45866      AMAT(1,3)=RND(CUT90,IDIGIT(3))
45867      AMAT(2,3)=RND(CUT95,IDIGIT(3))
45868      AMAT(3,3)=RND(CUT975,IDIGIT(3))
45869      AMAT(4,3)=RND(CUT99,IDIGIT(3))
45870C
45871      IWHTML(1)=150
45872      IWHTML(2)=150
45873      IWHTML(3)=150
45874      IWHTML(4)=150
45875      IWRTF(1)=1500
45876      IWRTF(2)=IWRTF(1)+1500
45877      IWRTF(3)=IWRTF(2)+2000
45878      IWRTF(4)=IWRTF(3)+2000
45879      IFRST=.FALSE.
45880      ILAST=.TRUE.
45881C
45882      ISTEPN='42E'
45883      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CWS2')
45884     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
45885C
45886      CALL DPDTA4(ITITL9,NCTIT9,
45887     1            ITITLE,NCTITL,ITITL2,NCTIT2,
45888     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
45889     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW,
45890     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
45891     1            ICAPSW,ICAPTY,IFRST,ILAST,
45892     1            ISUBRO,IBUGA3,IERROR)
45893C
45894      IF(BETACM.GT.0.0)THEN
45895        ILIKFL='WCSH'
45896        CALL DPDTA8(ALOWLM,ALOWLM,ALOWLM,ALOWLM,
45897     1              ALOWLM,AUPPLM,ALOWLM,AUPPLM,ALPHA2,NUMAL2,
45898     1              ICAPSW,ICAPTY,NUMDIG,ILIKFL,
45899     1              ISUBRO,IBUGA3,IERROR)
45900      ENDIF
45901C
45902C               *****************
45903C               **  STEP 90--  **
45904C               **  EXIT       **
45905C               *****************
45906C
45907 9000 CONTINUE
45908      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CWS2')THEN
45909        WRITE(ICOUT,999)
45910        CALL DPWRST('XXX','WRIT')
45911        WRITE(ICOUT,9011)
45912 9011   FORMAT('***** AT THE END       OF DPCWS2--')
45913        CALL DPWRST('XXX','WRIT')
45914        WRITE(ICOUT,9012)N,IBUGA3,IERROR
45915 9012   FORMAT('N,IBUGA3,IERROR = ',I8,2X,A4,2X,A4)
45916        CALL DPWRST('XXX','WRIT')
45917        WRITE(ICOUT,9014)STATVA,STATCD,PVAL
45918 9014   FORMAT('STATVA,STATCD,PVAL = ',3G15.7)
45919        CALL DPWRST('XXX','WRIT')
45920      ENDIF
45921C
45922      RETURN
45923      END
45924      SUBROUTINE DPCWS3(Y,X,N,IWRITE,ISEED,MINMAX,MAXNXT,
45925     1                  YTEMP,YTEMP2,XTEMP1,XIDTEM,YSTAT,DTEMP1,
45926     1                  STATVA,STATCD,PVALUE,NDIST,NGROUP,
45927     1                  CV90,CV95,CV99,BETACM,
45928     1                  IBUGA3,ISUBRO,IERROR)
45929C
45930C     PURPOSE--GIVEN K GROUPS OF DATA, THIS ROUTINE TESTS WHETHER
45931C              THE K SHAPE PARAMETERS FOR A 2-PARAMETER WEIBULL
45932C              DISTRIBUTION ARE EQUAL.  THE TEST PROCEDURE IS
45933C
45934C                 1) FOR EACH GROUP, FIT A 2-PARAMETER WEIBULL
45935C                    DISTRIBUTION.
45936C
45937C                 2) DETERMINE THE MINIMUM AND MAXIMUM VALUES OF
45938C                    THE SHAPE PARAMETER.
45939C
45940C                 3) THE TEST STATISTIC IS
45941C
45942C                        Bhat(max)/Bhat(min)
45943C
45944C                 4) CRITICAL VALUES ARE DETERMINED VIA SIMULATION.
45945C                    SPECIFICALLY, GENERATE K 2-PARAMETER WEIBULL
45946C                    SAMPLES WITH A COMMON SHAPE PARAMETER
45947C                    (SPECIFICALLY, WE WILL USE THE MEDIAN VALUE
45948C                    OF THE FITTED SHAPE PARAMETERS).  COMPUTE
45949C                    THIS RATIO FOR 10,000 SIMULATIONS.
45950C
45951C              WE CURRENTLY ONLY SUPPORT THIS TEST FOR UNCENSORED DATA.
45952C              HOWEVER, IT CAN BE EXTENDED TO SUPPORT TYPE II CENSORING.
45953C
45954C              THIS TEST IS DESCRIBED IN MCCOOL (SEE REFERENCE).
45955C     INPUT  ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR OF
45956C                                (UNSORTED OR SORTED) OBSERVATIONS.
45957C                     --X      = THE SINGLE PRECISION VECTOR FOR
45958C                                THE GROUP-IDENTIFIER.
45959C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
45960C                                IN THE VECTOR Y.
45961C     OUTPUT ARGUMENTS--STATVA = THE SINGLE PRECISION VALUE OF THE
45962C                                COMPUTED TEST STATISTIC.
45963C     OUTPUT--NONE.
45964C     PRINTING--YES.
45965C     OTHER DATAPAC   SUBROUTINES NEEDED--XXXXX.
45966C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
45967C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
45968C     LANGUAGE--ANSI FORTRAN (1977)
45969C     REFERENCES--MCCOOL (2012), "USING THE WEIBULL DISTRIBUTION:
45970C                 RELIABILITY, MODELING, AND INFERENCE", WILEY, PP.
45971C                 236-238.
45972C     WRITTEN BY--ALAN HECKERT
45973C                 STATISTICAL ENGINEERING DIVISION
45974C                 INFORMATION TECHNOLOGY LABORATORY
45975C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
45976C                 GAITHERSBURG, MD 20899-8980
45977C                 PHONE--301-975-2899
45978C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
45979C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
45980C     LANGUAGE--ANSI FORTRAN (1977)
45981C     VERSION NUMBER--2014.4
45982C     ORIGINAL VERSION--APRIL     2014.
45983C
45984C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
45985C
45986      CHARACTER*4 IWRITE
45987      CHARACTER*4 IBUGA3
45988      CHARACTER*4 ISUBRO
45989      CHARACTER*4 IERROR
45990C
45991      CHARACTER*4 ISUBN1
45992      CHARACTER*4 ISUBN2
45993      CHARACTER*4 IDIR
45994      CHARACTER*4 ISTEPN
45995      CHARACTER*4 IRANSV
45996      CHARACTER*4 IWEIFL
45997C
45998C---------------------------------------------------------------------
45999C
46000      DIMENSION X(*)
46001      DIMENSION Y(*)
46002      DIMENSION YTEMP(*)
46003      DIMENSION XIDTEM(*)
46004      DIMENSION XTEMP1(*)
46005      DIMENSION YSTAT(*)
46006C
46007      DOUBLE PRECISION DTEMP1(*)
46008      DOUBLE PRECISION YTEMP2(*)
46009C
46010CCCCC PARAMETER (MAXGRP=50)
46011      DIMENSION BETA(50)
46012      DIMENSION BETA2(50)
46013      DIMENSION SCALE(50)
46014      INTEGER   NSIZE(50)
46015      INTEGER   NR(50)
46016      COMMON/CWSHAP/IN,NDIST2,NSIZE,NR,SCALE,BETAMN,BETAMX,BETAMD
46017C
46018      DOUBLE PRECISION WEIFU8
46019      EXTERNAL WEIFU8
46020      DOUBLE PRECISION DXSTRT
46021      DOUBLE PRECISION DXLOW
46022      DOUBLE PRECISION DXUP
46023      DOUBLE PRECISION DRE
46024      DOUBLE PRECISION DAE
46025C
46026      DOUBLE PRECISION DSUM1
46027      DOUBLE PRECISION DTERM1
46028C
46029      INCLUDE 'DPCOST.INC'
46030C
46031C---------------------------------------------------------------------
46032C
46033      INCLUDE 'DPCOP2.INC'
46034C
46035C-----START POINT-----------------------------------------------------
46036C
46037      ISUBN1='DPWC'
46038      ISUBN2='S3  '
46039      IERROR='NO'
46040      IWRITE='OFF'
46041      STATVA=CPUMIN
46042      STATCD=CPUMIN
46043      PVALUE=CPUMIN
46044C
46045      IRANSV=IRANAL
46046      IRANAL='FIBC'
46047      ISEESV=ISEED
46048      ISEED=36243
46049C
46050      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CWS3')THEN
46051        WRITE(ICOUT,999)
46052  999   FORMAT(1X)
46053        CALL DPWRST('XXX','BUG ')
46054        WRITE(ICOUT,51)
46055   51   FORMAT('***** AT THE BEGINNING OF DPCWS3--')
46056        CALL DPWRST('XXX','BUG ')
46057        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
46058   52   FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8)
46059        CALL DPWRST('XXX','BUG ')
46060        DO55I=1,N
46061          WRITE(ICOUT,56)I,X(I),Y(I)
46062   56     FORMAT('I,X(I),Y(I) = ',I8,2G15.7)
46063          CALL DPWRST('XXX','BUG ')
46064   55   CONTINUE
46065      ENDIF
46066C
46067C               ********************************************
46068C               **  STEP 1--                              **
46069C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
46070C               ********************************************
46071C
46072      IF(N.LT.5)THEN
46073        WRITE(ICOUT,999)
46074        CALL DPWRST('XXX','BUG ')
46075        WRITE(ICOUT,111)
46076  111   FORMAT('***** ERROR IN WEIBULL COMMON SHAPE PARAMETER--')
46077        CALL DPWRST('XXX','BUG ')
46078        WRITE(ICOUT,112)
46079  112   FORMAT('      THE RESPONSE VARIABLE HAS FEWER THAN FIVE ',
46080     1         'OBSERVATIONS.')
46081        CALL DPWRST('XXX','BUG ')
46082        WRITE(ICOUT,118)N
46083  118   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS = ',I8)
46084        CALL DPWRST('XXX','BUG ')
46085        IERROR='YES'
46086        GOTO9000
46087      ENDIF
46088C
46089      IF(MINMAX.EQ.2)THEN
46090        DO130I=1,N
46091          IF(Y(I).GE.0.0)THEN
46092            WRITE(ICOUT,999)
46093            CALL DPWRST('XXX','BUG ')
46094            WRITE(ICOUT,111)
46095            CALL DPWRST('XXX','BUG ')
46096            WRITE(ICOUT,132)
46097  132       FORMAT('      ROW ',I8,' OF THE RESPONSE VARIABLE IS ',
46098     1             'NON-NEGATIVE.')
46099            CALL DPWRST('XXX','BUG ')
46100            WRITE(ICOUT,134)Y(I)
46101  134       FORMAT('      IT HAS THE VALUE ',G15.7)
46102            CALL DPWRST('XXX','BUG ')
46103            IERROR='YES'
46104            GOTO9000
46105          ELSE
46106            Y(I)=-Y(I)
46107          ENDIF
46108  130   CONTINUE
46109      ELSE
46110        DO120I=1,N
46111          IF(Y(I).LE.0.0)THEN
46112            WRITE(ICOUT,999)
46113            CALL DPWRST('XXX','BUG ')
46114            WRITE(ICOUT,111)
46115            CALL DPWRST('XXX','BUG ')
46116            WRITE(ICOUT,122)
46117  122       FORMAT('      ROW ',I8,' OF THE RESPONSE VARIABLE IS ',
46118     1             'NON-POSITIVE.')
46119            CALL DPWRST('XXX','BUG ')
46120            WRITE(ICOUT,124)Y(I)
46121  124       FORMAT('      IT HAS THE VALUE ',G15.7)
46122            CALL DPWRST('XXX','BUG ')
46123            IERROR='YES'
46124            GOTO9000
46125          ENDIF
46126  120   CONTINUE
46127      ENDIF
46128C
46129      CALL DISTIN(X,N,IWRITE,XIDTEM,NDIST,IBUGA3,IERROR)
46130      IF(NDIST.LT.2)THEN
46131        WRITE(ICOUT,999)
46132        CALL DPWRST('XXX','BUG ')
46133        WRITE(ICOUT,111)
46134        CALL DPWRST('XXX','BUG ')
46135        WRITE(ICOUT,142)
46136  142   FORMAT('      NO DISTINCT GROUPS DETECTED.')
46137        CALL DPWRST('XXX','BUG ')
46138        IERROR='YES'
46139        GOTO9000
46140      ENDIF
46141C
46142C               *************************************************
46143C               **  STEP 2--                                   **
46144C               **  COMPUTE THE TEST STATISTIC                 **
46145C               *************************************************
46146C
46147      ISTEPN='2'
46148      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CWS3')
46149     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
46150C
46151      IWEIFL='WEIB'
46152      ICNT1=0
46153      DO1000I=1,NDIST
46154        HOLD=XIDTEM(I)
46155        ICNT2=0
46156        DO1100J=1,N
46157          IF(X(J).EQ.HOLD)THEN
46158            ICNT2=ICNT2+1
46159            YTEMP(ICNT2)=Y(J)
46160          ENDIF
46161 1100   CONTINUE
46162        IF(ICNT2.GE.3)THEN
46163          ICNT1=ICNT1+1
46164          NSIZE(ICNT1)=ICNT2
46165          CALL WEIML1(YTEMP,ICNT2,IWEIBC,IWEIFL,MINMAX,
46166     1                XTEMP1,DTEMP1,
46167     1                XMEAN,XSD,XVAR,XMIN,XMAX,
46168     1                ZMEAN,ZSD,
46169     1                SCALML,SCALSE,SHAPML,SHAPSE,
46170     1                SHAPBC,SHABSE,COVSE,COVBSE,
46171     1                ISUBRO,IBUGA3,IERROR)
46172          BETA(ICNT1)=SHAPML
46173        ELSE
46174          WRITE(ICOUT,999)
46175          CALL DPWRST('XXX','BUG ')
46176          WRITE(ICOUT,1111)
46177 1111     FORMAT('***** WARNING IN WEIBULL COMMON SHAPE PARAMETER--')
46178          CALL DPWRST('XXX','BUG ')
46179          WRITE(ICOUT,1112)I
46180 1112     FORMAT('      GROUP ',I3,' HAS FEWER THAN THREE ',
46181     1           'OBSERVATIONS')
46182          CALL DPWRST('XXX','BUG ')
46183          WRITE(ICOUT,1113)
46184 1113     FORMAT('      AND WILL BE OMITTED FROM THE ANALYSIS.')
46185          CALL DPWRST('XXX','BUG ')
46186        ENDIF
46187C
46188        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CWS3')THEN
46189          WRITE(ICOUT,1191)I,ICNT1,NSIZE(ICNT1),BETA(ICNT1)
46190 1191     FORMAT('I,ICNT1,NSIZE(ICNT1),BETA(ICNT1) = ',3I8,G15.7)
46191          CALL DPWRST('XXX','BUG ')
46192        ENDIF
46193C
46194 1000 CONTINUE
46195C
46196      ISTEPN='2B'
46197      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CWS3')
46198     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
46199C
46200      NGROUP=ICNT1
46201      IF(ICNT1.LE.1)THEN
46202        WRITE(ICOUT,999)
46203        CALL DPWRST('XXX','BUG ')
46204        WRITE(ICOUT,111)
46205        CALL DPWRST('XXX','BUG ')
46206        WRITE(ICOUT,1211)
46207 1211   FORMAT('      LESS THAN TWO GROUPS HAVE AT LEAST THREE ',
46208     1         'OBSERVATIONS, SO TEST NOT PERFORMED.')
46209        CALL DPWRST('XXX','BUG ')
46210        IERROR='YES'
46211        GOTO9000
46212      ELSE
46213        CALL MINIM(BETA,NGROUP,IWRITE,BETAMN,IBUGA3,IERROR)
46214        CALL MAXIM(BETA,NGROUP,IWRITE,BETAMX,IBUGA3,IERROR)
46215        CALL MEDIAN(BETA,NGROUP,IWRITE,XTEMP1,MAXNXT,BETAMD,
46216     1              IBUGA3,IERROR)
46217        IF(BETAMN.GT.0.0)THEN
46218          STATVA=BETAMX/BETAMN
46219        ELSE
46220          IERROR='YES'
46221          GOTO9000
46222        ENDIF
46223      ENDIF
46224C
46225C     COMPUTE THE COMMON SHAPE PARAMETER
46226C
46227      ISTEPN='2C'
46228      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CWS3')
46229     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
46230C
46231      DO4101I=1,N
46232        DTEMP1(I)=DBLE(Y(I))
46233 4101 CONTINUE
46234      DO4103I=1,50
46235        NR(I)=NSIZE(I)
46236 4103 CONTINUE
46237      IFLAG=0
46238      IN=N
46239      NDIST2=NDIST
46240      DAE=1.D-7
46241      DRE=1.D-7
46242      DXLOW=DBLE(BETAMN)/2.0D0
46243      DXUP=DBLE(BETAMX)*2.0D0
46244      DXSTRT=DBLE(BETAMD)
46245      CALL DFZER3(WEIFU8,DXLOW,DXUP,DXSTRT,DRE,DAE,IFLAG,DTEMP1)
46246      BETACM=REAL(DXLOW)
46247C
46248C     BASED ON THE COMMON SHAPE PARAMETER, COMPUTE THE SCALE
46249C     PARAMETERS FOR EACH GROUP.
46250C
46251      DO4410I=1,NDIST
46252        HOLD=XIDTEM(I)
46253        DSUM1=0.0D0
46254        DO4420J=1,N
46255          IF(X(J).EQ.HOLD)THEN
46256            DSUM1=DSUM1 + DBLE(Y(J))**DBLE(BETACM)
46257          ENDIF
46258 4420   CONTINUE
46259        IF(DSUM1.GT.0.0D0 .AND. NR(I).GT.0)THEN
46260          DTERM1=(DSUM1/DBLE(NR(I)))**(1.0D0/DBLE(BETACM))
46261          SCALE(I)=REAL(DTERM1)
46262        ELSE
46263          SCALE(I)=CPUMIN
46264        ENDIF
46265 4410 CONTINUE
46266C
46267      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CWS3')THEN
46268        WRITE(ICOUT,1291)BETAMN,BETAMX,BETAMD,STATVA,BETACM
46269 1291   FORMAT('BETAMN,BETAMX,BETAMD,STATVA,BETACM = ',5G15.7)
46270        CALL DPWRST('XXX','BUG ')
46271      ENDIF
46272C
46273C               *************************************************
46274C               **  STEP 3--                                   **
46275C               **  COMPUTE THE CRITICAL VALUES                **
46276C               *************************************************
46277C
46278      ISTEPN='3'
46279      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CWS3')
46280     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
46281C
46282      NSIMUL=10000
46283      BETATE=2.0
46284C
46285      DO3000I=1,NSIMUL
46286        ICNT=0
46287        DO3100J=1,NGROUP
46288          NTEMP=NSIZE(J)
46289C
46290C         GENERATE THE WEIBULL RANDOM NUMBERS FOR THE SUB-GROUP
46291C
46292CCCCC     CALL WEIRAN(NTEMP,BETAMD,MINMAX,ISEED,YTEMP)
46293          CALL WEIRAN(NTEMP,BETATE,MINMAX,ISEED,YTEMP)
46294          DO3105II=1,NTEMP
46295            ICNT=ICNT+1
46296            YTEMP2(ICNT)=YTEMP(II)
46297 3105     CONTINUE
46298C
46299C         ESTIMATE BETA FOR THIS RANDOM SAMPLE
46300C
46301          CALL WEIML1(YTEMP,NTEMP,IWEIBC,IWEIFL,MINMAX,
46302     1                XTEMP1,DTEMP1,
46303     1                XMEAN,XSD,XVAR,XMIN,XMAX,
46304     1                ZMEAN,ZSD,
46305     1                SCALML,SCALSE,SHAPML,SHAPSE,
46306     1                SHAPBC,SHABSE,COVSE,COVBSE,
46307     1                ISUBRO,IBUGA3,IERROR)
46308          BETA2(J)=SHAPML
46309 3100   CONTINUE
46310C
46311C       NOW COMPUTE TEST STATISTIC
46312C
46313        CALL MINIM(BETA2,NGROUP,IWRITE,BETMN2,IBUGA3,IERROR)
46314        CALL MAXIM(BETA2,NGROUP,IWRITE,BETMX2,IBUGA3,IERROR)
46315        STATV9=BETMX2/BETMN2
46316        YSTAT(I)=STATV9
46317C
46318C       COMPUTE COMMON SHAPE PARAMETER AND THEN COMPUTE
46319C       V1 = BETAHAT/BETA = COMMON BETA/BETA USED FOR SIMULATION
46320C
46321        DO3301II=1,N
46322          DTEMP1(II)=YTEMP2(II)
46323 3301   CONTINUE
46324        DO3303II=1,50
46325          NR(II)=NSIZE(II)
46326 3303   CONTINUE
46327        IFLAG=0
46328        IN=N
46329        NDIST2=NDIST
46330        DAE=1.D-7
46331        DRE=1.D-7
46332        DXLOW=DBLE(BETMN2)/2.0D0
46333        DXUP=DBLE(BETMX2)*2.0D0
46334        DXSTRT=DBLE((BETMN2 + BETMX2)/2.0)
46335        CALL DFZER3(WEIFU8,DXLOW,DXUP,DXSTRT,DRE,DAE,IFLAG,DTEMP1)
46336        BETCM2=REAL(DXLOW)
46337        YSTAT(NSIMUL+I)=BETCM2/BETATE
46338C
46339 3000 CONTINUE
46340C
46341C     NOW COMPUTE CDF AND PVALUE
46342C
46343      IDIR='UPPE'
46344      CALL DPGOF8(YSTAT,NSIMUL,STATVA,PVALUE,IDIR,
46345     1            IBUGA3,ISUBRO,IERROR)
46346      STATCD=1.0 - PVALUE
46347      CV90=YSTAT(9000)
46348      CV95=YSTAT(9500)
46349      CV99=YSTAT(9900)
46350C
46351C               *****************
46352C               **  STEP 90--  **
46353C               **  EXIT.      **
46354C               *****************
46355C
46356 9000 CONTINUE
46357C
46358      ISEED=ISEESV
46359      IRANAL=IRANSV
46360C
46361      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CWS3')THEN
46362        WRITE(ICOUT,999)
46363        CALL DPWRST('XXX','BUG ')
46364        WRITE(ICOUT,9011)
46365 9011   FORMAT('***** AT THE END       OF DPCWS3--')
46366        CALL DPWRST('XXX','BUG ')
46367        WRITE(ICOUT,9012)IBUGA3,IERROR
46368 9012   FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
46369        CALL DPWRST('XXX','BUG ')
46370        WRITE(ICOUT,9014)NGROUP,BETAMN,BETAMX,BETAMD
46371 9014   FORMAT('NGROUP,BETAMN,BETAMX,BETAMD = ',I8,3G15.7)
46372        CALL DPWRST('XXX','BUG ')
46373        WRITE(ICOUT,9016)STATVA,STATCD,PVALUE
46374 9016   FORMAT('STATVA,STATCD,PVALUE = ',3G15.7)
46375        CALL DPWRST('XXX','BUG ')
46376        WRITE(ICOUT,9018)CV90,CV95,CV99
46377 9018   FORMAT('CV90,CV95,CV99 = ',3G15.7)
46378        CALL DPWRST('XXX','BUG ')
46379      ENDIF
46380C
46381      RETURN
46382      END
46383      SUBROUTINE DPCXTE(XTEMP1,XTEMP2,MAXNXT,
46384     1                  ICAPSW,IFORSW,
46385     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
46386C
46387C     PURPOSE--CARRY OUT A COX STUART TEST FOR TREND
46388C     EXAMPLE--COX STUART TEST Y
46389C     WRITTEN BY--ALAN HECKERT
46390C                 STATISTICAL ENGINEERING DIVISION
46391C                 INFORMATION TECHNOLOGY LABORATORY
46392C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
46393C                 GAITHERSBUG, MD 20899-8980
46394C                 PHONE--301-975-2899
46395C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
46396C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
46397C     LANGUAGE--ANSI FORTRAN (1977)
46398C     VERSION NUMBER--2011/6
46399C     ORIGINAL VERSION--JUNE      2011.
46400C
46401C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
46402C
46403      CHARACTER*4 IBUGA2
46404      CHARACTER*4 IBUGA3
46405      CHARACTER*4 IBUGQ
46406      CHARACTER*4 ISUBRO
46407      CHARACTER*4 ICAPSW
46408      CHARACTER*4 IFORSW
46409      CHARACTER*4 IFOUND
46410      CHARACTER*4 IERROR
46411C
46412      CHARACTER*4 ISUBN1
46413      CHARACTER*4 ISUBN2
46414      CHARACTER*4 ISTEPN
46415      CHARACTER*4 ICASAN
46416      CHARACTER*4 ICASA2
46417      CHARACTER*4 ICASA3
46418      CHARACTER*4 IMULT
46419      CHARACTER*4 IREPL
46420      CHARACTER*4 ICTMP1
46421      CHARACTER*4 ICTMP2
46422      CHARACTER*4 ICTMP3
46423C
46424      CHARACTER*4 ICASE
46425      CHARACTER*4 IVARID
46426      CHARACTER*4 IVARI2
46427      CHARACTER*40 INAME
46428      PARAMETER (MAXSPN=30)
46429      CHARACTER*4 IVARN1(MAXSPN)
46430      CHARACTER*4 IVARN2(MAXSPN)
46431      CHARACTER*4 IVARTY(MAXSPN)
46432      REAL PVAR(MAXSPN)
46433      INTEGER ILIS(MAXSPN)
46434      INTEGER NRIGHT(MAXSPN)
46435      INTEGER ICOLR(MAXSPN)
46436C
46437      CHARACTER*4 IFLAGU
46438      LOGICAL IFRST
46439      LOGICAL ILAST
46440C
46441C---------------------------------------------------------------------
46442C
46443      DIMENSION XTEMP1(*)
46444      DIMENSION XTEMP2(*)
46445C
46446      INCLUDE 'DPCOPA.INC'
46447      INCLUDE 'DPCOZZ.INC'
46448      DIMENSION Y2(MAXOBV)
46449      EQUIVALENCE (GARBAG(IGARB1),Y2(1))
46450C
46451C-----COMMON----------------------------------------------------------
46452C
46453      INCLUDE 'DPCOHK.INC'
46454      INCLUDE 'DPCOSU.INC'
46455      INCLUDE 'DPCODA.INC'
46456      INCLUDE 'DPCOHO.INC'
46457      INCLUDE 'DPCOST.INC'
46458C
46459C-----COMMON VARIABLES (GENERAL)--------------------------------------
46460C
46461      INCLUDE 'DPCOP2.INC'
46462C
46463C-----START POINT-----------------------------------------------------
46464C
46465      ISUBN1='DPCX'
46466      ISUBN2='TE  '
46467C
46468      MAXCP1=MAXCOL+1
46469      MAXCP2=MAXCOL+2
46470      MAXCP3=MAXCOL+3
46471      MAXCP4=MAXCOL+4
46472      MAXCP5=MAXCOL+5
46473      MAXCP6=MAXCOL+6
46474C
46475      IFOUND='YES'
46476      IERROR='NO'
46477      IREPL='OFF'
46478      IMULT='OFF'
46479      ICASA2='TWOT'
46480C
46481C               **************************************
46482C               **  TREAT THE COX STUART TEST CASE  **
46483C               **************************************
46484C
46485      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CXTE')THEN
46486        WRITE(ICOUT,999)
46487  999   FORMAT(1X)
46488        CALL DPWRST('XXX','BUG ')
46489        WRITE(ICOUT,51)
46490   51   FORMAT('***** AT THE BEGINNING OF DPCXTE--')
46491        CALL DPWRST('XXX','BUG ')
46492        WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ,ISUBRO,MAXNXT
46493   52   FORMAT('IBUGA2,IBUGA3,IBUGQ,ISUBRO = ',4(A4,2X),I8)
46494        CALL DPWRST('XXX','BUG ')
46495      ENDIF
46496C
46497C               *********************************************************
46498C               **  STEP 1--                                           **
46499C               **  EXTRACT THE COMMAND                                **
46500C               *********************************************************
46501C
46502      ISTEPN='1'
46503      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CXTE')
46504     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
46505C
46506      ILASTZ=9999
46507      ICASAN='COXS'
46508C
46509C     LOOK FOR:
46510C
46511C          COX STUART TEST
46512C          LOWER TAILED
46513C          UPPER TAILED
46514C
46515      DO100I=0,NUMARG-1
46516C
46517        IF(I.EQ.0)THEN
46518          ICTMP1=ICOM
46519        ELSE
46520          ICTMP1=IHARG(I)
46521        ENDIF
46522        ICTMP2=IHARG(I+1)
46523        ICTMP3=IHARG(I+2)
46524C
46525        IF(ICTMP1.EQ.'=')THEN
46526          IFOUND='NO'
46527          GOTO9000
46528        ELSEIF(ICTMP1.EQ.'COX ' .AND. ICTMP2.EQ.'STUA' .AND.
46529     1         ICTMP3.EQ.'TEST')THEN
46530          IFOUND='YES'
46531          ICASAN='COXS'
46532          ILASTZ=I+2
46533        ELSEIF(ICTMP1.EQ.'COX ' .AND. ICTMP2.EQ.'STUA')THEN
46534          IFOUND='YES'
46535          ICASAN='COXS'
46536          ILASTZ=I+1
46537        ELSEIF(ICTMP1.EQ.'LOWE' .AND. ICTMP2.EQ.'TAIL')THEN
46538          ICASA2='LOWE'
46539          ILASTZ=MAX(ILASTZ,I+1)
46540        ELSEIF(ICTMP1.EQ.'UPPE' .AND. ICTMP2.EQ.'TAIL')THEN
46541          ICASA2='UPPE'
46542          ILASTZ=MAX(ILASTZ,I+1)
46543        ENDIF
46544  100 CONTINUE
46545C
46546      IF(IFOUND.EQ.'NO')GOTO9000
46547C
46548      ISHIFT=ILASTZ
46549      CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
46550     1            IBUGA2,IERROR)
46551C
46552      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CXTE')THEN
46553        WRITE(ICOUT,91)ICASAN,ICASA2,ISHIFT
46554   91   FORMAT('DPCXTE: ICASAN,ICASA2,ISHIFT = ',
46555     1         2(A4,2X),I5)
46556        CALL DPWRST('XXX','BUG ')
46557      ENDIF
46558C
46559C               ****************************************
46560C               **  STEP 2--                          **
46561C               **  EXTRACT THE VARIABLE LIST         **
46562C               ****************************************
46563C
46564      ISTEPN='2'
46565      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CXTE')
46566     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
46567C
46568      INAME='COX-STUART TEST'
46569      MINNA=1
46570      MAXNA=100
46571      MINN2=2
46572      IFLAGE=0
46573      IFLAGM=1
46574      MINNVA=1
46575      MAXNVA=MAXSPN
46576      IF(IREPL.EQ.'ON')THEN
46577        IFLAGE=1
46578        IFLAGM=0
46579      ENDIF
46580      JMIN=1
46581      JMAX=NUMARG
46582C
46583      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
46584     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
46585     1            JMIN,JMAX,
46586     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
46587     1            IVARN1,IVARN2,IVARTY,PVAR,
46588     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
46589     1            MINNVA,MAXNVA,
46590     1            IFLAGM,IFLAGP,
46591     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
46592      IF(IERROR.EQ.'YES')GOTO9000
46593C
46594      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CXTE')THEN
46595        WRITE(ICOUT,999)
46596        CALL DPWRST('XXX','BUG ')
46597        WRITE(ICOUT,281)
46598  281   FORMAT('***** AFTER CALL DPPARS--')
46599        CALL DPWRST('XXX','BUG ')
46600        WRITE(ICOUT,282)NQ,NUMVAR
46601  282   FORMAT('NQ,NUMVAR = ',2I8)
46602        CALL DPWRST('XXX','BUG ')
46603        IF(NUMVAR.GT.0)THEN
46604          DO285I=1,NUMVAR
46605            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
46606     1                      ICOLR(I)
46607  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
46608     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
46609            CALL DPWRST('XXX','BUG ')
46610  285     CONTINUE
46611        ENDIF
46612      ENDIF
46613C
46614C               ******************************************************
46615C               **  STEP 3A--                                       **
46616C               **  CASE 1: NO REPLICATION.                         **
46617C               ******************************************************
46618C
46619      ISTEPN='3A'
46620      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CXTE')
46621     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
46622C
46623      NUMVA2=1
46624      DO5210I=1,NUMVAR
46625        ICOL=I
46626        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
46627     1              INAME,IVARN1,IVARN2,IVARTY,
46628     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
46629     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
46630     1              MAXCP4,MAXCP5,MAXCP6,
46631     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
46632     1              Y,Y,Y,NS1,NLOCA2,NLOCA3,ICASE,
46633     1              IBUGA3,ISUBRO,IFOUND,IERROR)
46634        IF(IERROR.EQ.'YES')GOTO9000
46635C
46636C               *****************************************
46637C               **  STEP 52--                          **
46638C               **  PERFORM COX STUART    TEST         **
46639C               *****************************************
46640C
46641        ISTEPN='52'
46642        IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CXTE')THEN
46643          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
46644          WRITE(ICOUT,999)
46645          CALL DPWRST('XXX','BUG ')
46646          WRITE(ICOUT,5211)
46647 5211     FORMAT('***** FROM DPCXTE, BEFORE CALL DPCXT2--')
46648          CALL DPWRST('XXX','BUG ')
46649          WRITE(ICOUT,5212)I,NS1,MAXN
46650 5212     FORMAT('I,NS1,MAXN = ',3I8)
46651          CALL DPWRST('XXX','BUG ')
46652          DO5215II=1,NS1
46653            WRITE(ICOUT,5216)II,Y(II)
46654 5216       FORMAT('I,Y(I) = ',I8,G15.7)
46655            CALL DPWRST('XXX','BUG ')
46656 5215     CONTINUE
46657        ENDIF
46658C
46659        IVARID=IVARN1(I)
46660        IVARI2=IVARN2(I)
46661        CALL DPCXT2(Y,NS1,ICASA2,
46662     1              Y2,XTEMP1,XTEMP2,MAXNXT,
46663     1              ICAPSW,ICAPTY,IFORSW,
46664     1              IVARID,IVARI2,
46665     1              STATV1,STATV2,STATC1,STATC2,
46666     1              PVAL2T,PVALLT,PVALUT,
46667     1              CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50,
46668     1              CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50,
46669     1              IBUGA3,ISUBRO,IERROR)
46670        IF(IERROR.EQ.'YES')GOTO9000
46671C
46672C               ***************************************
46673C               **  STEP 8C--                        **
46674C               **  UPDATE INTERNAL DATAPLOT TABLES  **
46675C               ***************************************
46676C
46677        ISTEPN='8C'
46678        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CXTE')
46679     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
46680C
46681        IFLAGU='ON'
46682        IFRST=.FALSE.
46683        ILAST=.FALSE.
46684        IF(I.EQ.1)IFRST=.TRUE.
46685        IF(I.EQ.NUMVAR)ILAST=.TRUE.
46686        ICASA3='TWOS'
46687        CALL DPSIG5(ICASA3,STATV1,STATC1,
46688     1              PVAL2T,PVALLT,PVALUT,
46689     1              CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50,
46690     1              CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50,
46691     1              IFLAGU,IFRST,ILAST,
46692     1              IBUGA2,IBUGA3,ISUBRO,IERROR)
46693C
46694 5210 CONTINUE
46695C
46696C               *****************
46697C               **  STEP 90--  **
46698C               **  EXIT       **
46699C               *****************
46700C
46701 9000 CONTINUE
46702      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CXTE')THEN
46703        WRITE(ICOUT,999)
46704        CALL DPWRST('XXX','BUG ')
46705        WRITE(ICOUT,9011)
46706 9011   FORMAT('***** AT THE END       OF DPCXTE--')
46707        CALL DPWRST('XXX','BUG ')
46708        WRITE(ICOUT,9016)IFOUND,IERROR
46709 9016   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
46710        CALL DPWRST('XXX','BUG ')
46711      ENDIF
46712C
46713      RETURN
46714      END
46715      SUBROUTINE DPCXT2(Y1,N,ICASAN,
46716     1                  Y2,XTEMP1,XTEMP2,MAXNXT,
46717     1                  ICAPSW,ICAPTY,IFORSW,
46718     1                  IVARID,IVARI2,
46719     1                  STATV1,STATV2,STATC1,STATC2,
46720     1                  PVAL2T,PVALLT,PVALUT,
46721     1                  CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50,
46722     1                  CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50,
46723     1                  IBUGA3,ISUBRO,IERROR)
46724C
46725C     PURPOSE--THIS ROUTINE CARRIES OUT THE COX-STUART TREND TEST.
46726C              THIS IS ESSENTIALLY A TWO-SAMPLE SIGN TEST BETWEEN POINTS
46727C              BELOW THE MEDIAN WITH POINTS ABOVE THE MEDIAN.
46728C     EXAMPLE--COX STUART TEST Y
46729C     WRITTEN BY--ALAN HECKERT
46730C                 STATISTICAL ENGINEERING DIVISION
46731C                 INFORMATION TECHNOLOGY LABORATORY
46732C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
46733C                 GAITHERSBUG, MD 20899-8980
46734C                 PHONE--301-975-2899
46735C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
46736C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
46737C     LANGUAGE--ANSI FORTRAN (1977)
46738C     VERSION NUMBER--2011/6
46739C     ORIGINAL VERSION--JUNE      2011.
46740C
46741C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
46742C
46743      CHARACTER*4 IVARID
46744      CHARACTER*4 IVARI2
46745      CHARACTER*4 ICAPTY
46746      CHARACTER*4 ICAPSW
46747      CHARACTER*4 IFORSW
46748      CHARACTER*4 IBUGA3
46749      CHARACTER*4 ICASAN
46750      CHARACTER*4 ISUBRO
46751      CHARACTER*4 IERROR
46752C
46753      CHARACTER*4 IWRITE
46754      CHARACTER*4 ISUBN1
46755      CHARACTER*4 ISUBN2
46756      CHARACTER*4 ISTEPN
46757C
46758C---------------------------------------------------------------------
46759C
46760      DIMENSION Y1(*)
46761      DIMENSION Y2(*)
46762      DIMENSION XTEMP1(*)
46763      DIMENSION XTEMP2(*)
46764C
46765      DOUBLE PRECISION DPPF
46766      DOUBLE PRECISION DPAR
46767C
46768      PARAMETER (NUMALP=6)
46769      REAL ALPHA(NUMALP)
46770C
46771      PARAMETER(NUMCLI=5)
46772      PARAMETER(MAXLIN=3)
46773      PARAMETER (MAXROW=NUMALP)
46774      PARAMETER (MAXRO2=35)
46775      CHARACTER*60 ITITLE
46776      CHARACTER*60 ITITLZ
46777      CHARACTER*60 ITITL9
46778      CHARACTER*60 ITEXT(MAXRO2)
46779      CHARACTER*4  ALIGN(NUMCLI)
46780      CHARACTER*4  VALIGN(NUMCLI)
46781      REAL         AVALUE(MAXRO2)
46782      INTEGER      NCTEXT(MAXRO2)
46783      INTEGER      IDIGIT(MAXRO2)
46784      INTEGER      NTOT(MAXRO2)
46785      CHARACTER*60 ITITL2(MAXLIN,NUMCLI)
46786      CHARACTER*15 IVALUE(MAXROW,NUMCLI)
46787      CHARACTER*4  ITYPCO(NUMCLI)
46788      INTEGER      NCTIT2(MAXLIN,NUMCLI)
46789      INTEGER      NCVALU(MAXROW,NUMCLI)
46790      INTEGER      IWHTML(NUMCLI)
46791      INTEGER      IWRTF(NUMCLI)
46792      REAL         AMAT(MAXROW,NUMCLI)
46793      LOGICAL IFRST
46794      LOGICAL ILAST
46795      LOGICAL IFLAGS
46796      LOGICAL IFLAGE
46797C
46798C---------------------------------------------------------------------
46799C
46800      INCLUDE 'DPCOP2.INC'
46801C
46802C-----START POINT-----------------------------------------------------
46803C
46804      DATA ALPHA/0.50, 0.80, 0.90, 0.95, 0.99, 0.999/
46805C
46806      ISUBN1='DPCX'
46807      ISUBN2='T2  '
46808      IERROR='NO'
46809      IWRITE='OFF'
46810C
46811      NUMDIG=7
46812      IF(IFORSW.EQ.'1')NUMDIG=1
46813      IF(IFORSW.EQ.'2')NUMDIG=2
46814      IF(IFORSW.EQ.'3')NUMDIG=3
46815      IF(IFORSW.EQ.'4')NUMDIG=4
46816      IF(IFORSW.EQ.'5')NUMDIG=5
46817      IF(IFORSW.EQ.'6')NUMDIG=6
46818      IF(IFORSW.EQ.'7')NUMDIG=7
46819      IF(IFORSW.EQ.'8')NUMDIG=8
46820      IF(IFORSW.EQ.'9')NUMDIG=9
46821      IF(IFORSW.EQ.'0')NUMDIG=0
46822      IF(IFORSW.EQ.'E')NUMDIG=-2
46823      IF(IFORSW.EQ.'-2')NUMDIG=-2
46824      IF(IFORSW.EQ.'-3')NUMDIG=-3
46825      IF(IFORSW.EQ.'-4')NUMDIG=-4
46826      IF(IFORSW.EQ.'-5')NUMDIG=-5
46827      IF(IFORSW.EQ.'-6')NUMDIG=-6
46828      IF(IFORSW.EQ.'-7')NUMDIG=-7
46829      IF(IFORSW.EQ.'-8')NUMDIG=-8
46830      IF(IFORSW.EQ.'-9')NUMDIG=-9
46831C
46832      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CXT2')THEN
46833        WRITE(ICOUT,999)
46834  999   FORMAT(1X)
46835        CALL DPWRST('XXX','WRIT')
46836        WRITE(ICOUT,51)
46837   51   FORMAT('**** AT THE BEGINNING OF DPCXT2--')
46838        CALL DPWRST('XXX','WRIT')
46839        WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASAN,IVARID,IVARI2
46840   52   FORMAT('IBUGA3,ISUBRO,ICASAN,IVARID,IVARI2 = ',4(A4,2X),A4)
46841        CALL DPWRST('XXX','WRIT')
46842        WRITE(ICOUT,55)N
46843   55   FORMAT('N1 = ',2I8)
46844        CALL DPWRST('XXX','WRIT')
46845        DO56I=1,N
46846          WRITE(ICOUT,57)I,Y1(I)
46847   57     FORMAT('I,Y1(I) = ',I8,G15.7)
46848          CALL DPWRST('XXX','WRIT')
46849   56   CONTINUE
46850      ENDIF
46851C
46852C               *********************************
46853C               **  STEP 11--                  **
46854C               **  SPLIT THE DATA INTO 2      **
46855C               **  PARTS                      **
46856C               *********************************
46857C
46858      ISTEPN='11'
46859      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CXT2')
46860     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
46861C
46862      IODD=MOD(N,2)
46863      IF(IODD.EQ.0)THEN
46864        IC=N/2
46865        DO1110I=1,IC
46866          Y2(I)=Y1(IC+I)
46867 1110   CONTINUE
46868        N1=IC
46869      ELSE
46870        IC=(N+1)/2
46871        N1=IC-1
46872        DO1120I=1,N1
46873          Y2(I)=Y1(IC+I)
46874 1120   CONTINUE
46875      ENDIF
46876C
46877C               *********************************
46878C               **  STEP 11--                  **
46879C               **  CARRY OUT CALCULATIONS FOR **
46880C               **  THE COX-STUART      TEST   **
46881C               *********************************
46882C
46883      ISTEPN='11'
46884      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CXT2')
46885     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
46886C
46887      D0=0.0
46888      CALL DPSIG4(Y1,N1,Y2,N1,D0,IWRITE,
46889     1            XTEMP1,XTEMP2,MAXNXT,
46890     1            Y1MEAN,Y1MED,Y1SD,Y1MAD,
46891     1            Y2MEAN,Y2MED,Y2SD,Y2MAD,
46892     1            STATV1,STATC1,STATV2,STATC2,RTIES,NTEMP,
46893     1            PVAL2T,PVALLT,PVALUT,
46894     1            ISUBRO,IBUGA3,IERROR)
46895      IF(IERROR.EQ.'YES')GOTO9000
46896C
46897      DPAR=0.5D0
46898      CALL BINPPF(.0005D0,DPAR,NTEMP,DPPF)
46899      CTL999=DPPF
46900      CALL BINPPF(.005D0,DPAR,NTEMP,DPPF)
46901      CUTL99=DPPF
46902      CALL BINPPF(.025D0,DPAR,NTEMP,DPPF)
46903      CUTL95=DPPF
46904      CALL BINPPF(.05D0,DPAR,NTEMP,DPPF)
46905      CUTL90=DPPF
46906      CALL BINPPF(.1D0,DPAR,NTEMP,DPPF)
46907      CUTL80=DPPF
46908      CALL BINPPF(.25D0,DPAR,NTEMP,DPPF)
46909      CUTL50=DPPF
46910      CALL BINPPF(.75D0,DPAR,NTEMP,DPPF)
46911      CUTU50=DPPF
46912      CALL BINPPF(.90D0,DPAR,NTEMP,DPPF)
46913      CUTU80=DPPF
46914      CALL BINPPF(.95D0,DPAR,NTEMP,DPPF)
46915      CUTU90=DPPF
46916      CALL BINPPF(.975D0,DPAR,NTEMP,DPPF)
46917      CUTU95=DPPF
46918      CALL BINPPF(.995D0,DPAR,NTEMP,DPPF)
46919      CUTU99=DPPF
46920      CALL BINPPF(.9995D0,DPAR,NTEMP,DPPF)
46921      CTU999=DPPF
46922C
46923C               *********************************
46924C               **   STEP 32--                 **
46925C               **   WRITE OUT EVERYTHING      **
46926C               **   FOR COX STUART      TEST  **
46927C               *********************************
46928C
46929      ISTEPN='42'
46930      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CXT2')
46931     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
46932C
46933      IF(IPRINT.EQ.'OFF')GOTO9000
46934C
46935      ITITLE='Cox Stuart Test for Trend'
46936      NCTITL=25
46937      ITITLZ='(Compare Observations < Midpoint to Those > Midpoint)'
46938      NCTITZ=53
46939C
46940      ICNT=1
46941      ITEXT(ICNT)=' '
46942      NCTEXT(ICNT)=0
46943      AVALUE(ICNT)=0.0
46944      IDIGIT(ICNT)=-1
46945C
46946      ICNT=ICNT+1
46947      ITEXT(ICNT)='Response Variable:  '
46948      WRITE(ITEXT(ICNT)(21:24),'(A4)')IVARID(1:4)
46949      WRITE(ITEXT(ICNT)(25:28),'(A4)')IVARI2(1:4)
46950      NCTEXT(ICNT)=28
46951      AVALUE(ICNT)=0.0
46952      IDIGIT(ICNT)=-1
46953C
46954      ICNT=ICNT+1
46955      ITEXT(ICNT)=' '
46956      NCTEXT(ICNT)=1
46957      AVALUE(ICNT)=0.0
46958      IDIGIT(ICNT)=-1
46959C
46960      ICNT=ICNT+1
46961      ITEXT(ICNT)='H0: There is No Trend'
46962      NCTEXT(ICNT)=21
46963      AVALUE(ICNT)=0.0
46964      IDIGIT(ICNT)=-1
46965      ICNT=ICNT+1
46966      ITEXT(ICNT)='Ha: There is a Trend'
46967      NCTEXT(ICNT)=20
46968      AVALUE(ICNT)=0.0
46969      IDIGIT(ICNT)=-1
46970C
46971      ICNT=ICNT+1
46972      ITEXT(ICNT)=' '
46973      NCTEXT(ICNT)=1
46974      AVALUE(ICNT)=0.0
46975      IDIGIT(ICNT)=-1
46976      ICNT=ICNT+1
46977      ITEXT(ICNT)='Summary Statistics:'
46978      NCTEXT(ICNT)=19
46979      AVALUE(ICNT)=0.0
46980      IDIGIT(ICNT)=-1
46981      ICNT=ICNT+1
46982      ITEXT(ICNT)='Number of Observations for Original Sample:'
46983      NCTEXT(ICNT)=23
46984      AVALUE(ICNT)=REAL(N)
46985      IDIGIT(ICNT)=0
46986      ICNT=ICNT+1
46987      ITEXT(ICNT)='Number of Observations After Matching:'
46988      NCTEXT(ICNT)=38
46989      AVALUE(ICNT)=REAL(NTEMP)
46990      IDIGIT(ICNT)=0
46991      ICNT=ICNT+1
46992      ITEXT(ICNT)=' '
46993      NCTEXT(ICNT)=1
46994      AVALUE(ICNT)=0.0
46995      IDIGIT(ICNT)=-1
46996      ICNT=ICNT+1
46997      ITEXT(ICNT)='Summary Statistics for Points Below Midpoint:'
46998      NCTEXT(ICNT)=45
46999      AVALUE(ICNT)=0.0
47000      IDIGIT(ICNT)=-1
47001      ICNT=ICNT+1
47002      ITEXT(ICNT)='Sample Mean:'
47003      NCTEXT(ICNT)=12
47004      AVALUE(ICNT)=Y1MEAN
47005      IDIGIT(ICNT)=NUMDIG
47006      ICNT=ICNT+1
47007      ITEXT(ICNT)='Sample Median:'
47008      NCTEXT(ICNT)=14
47009      AVALUE(ICNT)=Y1MED
47010      IDIGIT(ICNT)=NUMDIG
47011      ICNT=ICNT+1
47012      ITEXT(ICNT)='Sample Standard Deviation:'
47013      NCTEXT(ICNT)=26
47014      AVALUE(ICNT)=Y1SD
47015      IDIGIT(ICNT)=NUMDIG
47016      ICNT=ICNT+1
47017      ITEXT(ICNT)='Sample Median Absolute Deviation:'
47018      NCTEXT(ICNT)=32
47019      AVALUE(ICNT)=Y1MAD
47020      IDIGIT(ICNT)=NUMDIG
47021      ICNT=ICNT+1
47022      ITEXT(ICNT)=' '
47023      NCTEXT(ICNT)=1
47024      AVALUE(ICNT)=0.0
47025      IDIGIT(ICNT)=-1
47026C
47027      ICNT=ICNT+1
47028      ITEXT(ICNT)=' '
47029      NCTEXT(ICNT)=1
47030      AVALUE(ICNT)=0.0
47031      IDIGIT(ICNT)=-1
47032      ICNT=ICNT+1
47033      ITEXT(ICNT)='Summary Statistics for Points Above Midpoint:'
47034      NCTEXT(ICNT)=45
47035      AVALUE(ICNT)=0.0
47036      IDIGIT(ICNT)=-1
47037      ICNT=ICNT+1
47038      ITEXT(ICNT)='Sample Mean:'
47039      NCTEXT(ICNT)=12
47040      AVALUE(ICNT)=Y2MEAN
47041      IDIGIT(ICNT)=NUMDIG
47042      ICNT=ICNT+1
47043      ITEXT(ICNT)='Sample Median:'
47044      NCTEXT(ICNT)=14
47045      AVALUE(ICNT)=Y2MED
47046      IDIGIT(ICNT)=NUMDIG
47047      ICNT=ICNT+1
47048      ITEXT(ICNT)='Sample Standard Deviation:'
47049      NCTEXT(ICNT)=26
47050      AVALUE(ICNT)=Y2SD
47051      IDIGIT(ICNT)=NUMDIG
47052      ICNT=ICNT+1
47053      ITEXT(ICNT)='Sample Median Absolute Deviation:'
47054      NCTEXT(ICNT)=32
47055      AVALUE(ICNT)=Y2MAD
47056      IDIGIT(ICNT)=NUMDIG
47057      ICNT=ICNT+1
47058      ITEXT(ICNT)=' '
47059      NCTEXT(ICNT)=1
47060      AVALUE(ICNT)=0.0
47061      IDIGIT(ICNT)=-1
47062C
47063      ICNT=ICNT+1
47064      ITEXT(ICNT)='Test:'
47065      NCTEXT(ICNT)=5
47066      AVALUE(ICNT)=0.0
47067      IDIGIT(ICNT)=-1
47068      ICNT=ICNT+1
47069      ITEXT(ICNT)='Number of Positive Differences:'
47070      NCTEXT(ICNT)=31
47071      AVALUE(ICNT)=STATV1
47072      IDIGIT(ICNT)=0
47073      ICNT=ICNT+1
47074      ITEXT(ICNT)='Number of Negative Differences:'
47075      NCTEXT(ICNT)=31
47076      AVALUE(ICNT)=STATV2
47077      IDIGIT(ICNT)=0
47078      ICNT=ICNT+1
47079      ITEXT(ICNT)='Number of Ties:'
47080      NCTEXT(ICNT)=15
47081      AVALUE(ICNT)=RTIES
47082      IDIGIT(ICNT)=0
47083      ICNT=ICNT+1
47084      ITEXT(ICNT)='CDF Value for Positive Values:'
47085      NCTEXT(ICNT)=30
47086      AVALUE(ICNT)=STATC1
47087      IDIGIT(ICNT)=NUMDIG
47088      ICNT=ICNT+1
47089      ITEXT(ICNT)='CDF Value for Negative Values:'
47090      NCTEXT(ICNT)=30
47091      AVALUE(ICNT)=STATC2
47092      IDIGIT(ICNT)=NUMDIG
47093      ICNT=ICNT+1
47094      ITEXT(ICNT)='P-Value (2-tailed test):'
47095      NCTEXT(ICNT)=24
47096      AVALUE(ICNT)=PVAL2T
47097      IDIGIT(ICNT)=NUMDIG
47098      ICNT=ICNT+1
47099      ITEXT(ICNT)='P-Value (lower-tailed test):'
47100      NCTEXT(ICNT)=28
47101      AVALUE(ICNT)=PVALLT
47102      IDIGIT(ICNT)=NUMDIG
47103      ICNT=ICNT+1
47104      ITEXT(ICNT)='P-Value (upper-tailed test):'
47105      NCTEXT(ICNT)=28
47106      AVALUE(ICNT)=PVALUT
47107      IDIGIT(ICNT)=NUMDIG
47108C
47109      NUMROW=ICNT
47110      DO4110I=1,NUMROW
47111        NTOT(I)=15
47112 4110 CONTINUE
47113C
47114      IFRST=.TRUE.
47115      ILAST=.TRUE.
47116C
47117      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
47118     1            AVALUE,IDIGIT,
47119     1            NTOT,NUMROW,
47120     1            ICAPSW,ICAPTY,ILAST,IFRST,
47121     1            ISUBRO,IBUGA3,IERROR)
47122C
47123      ISTEPN='21B'
47124      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CXT2')
47125     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
47126C
47127      ITITLE='Two-Tailed Test'
47128      NCTITL=15
47129      ITITL9='H0: P(+) = P(-); Ha: P(+) <> P(-)'
47130      NCTIT9=33
47131C
47132      DO4130J=1,NUMCLI
47133        DO4140I=1,3
47134          ITITL2(I,J)=' '
47135          NCTIT2(I,J)=0
47136 4140   CONTINUE
47137 4130 CONTINUE
47138C
47139      ITITL2(2,1)='Significance'
47140      NCTIT2(2,1)=12
47141      ITITL2(3,1)='Level'
47142      NCTIT2(3,1)=5
47143C
47144      ITITL2(2,2)='Test '
47145      NCTIT2(2,2)=4
47146      ITITL2(3,2)='Statistic'
47147      NCTIT2(3,2)=9
47148C
47149      ITITL2(1,3)='Lower'
47150      NCTIT2(1,3)=5
47151      ITITL2(2,3)='Critical'
47152      NCTIT2(2,3)=8
47153      ITITL2(3,3)='Value (<)'
47154      NCTIT2(3,3)=9
47155C
47156      ITITL2(1,4)='Upper'
47157      NCTIT2(1,4)=5
47158      ITITL2(2,4)='Critical'
47159      NCTIT2(2,4)=8
47160      ITITL2(3,4)='Value (>)'
47161      NCTIT2(3,4)=9
47162C
47163      ITITL2(1,5)='Null'
47164      NCTIT2(1,5)=4
47165      ITITL2(2,5)='Hypothesis'
47166      NCTIT2(2,5)=10
47167      ITITL2(3,5)='Conclusion'
47168      NCTIT2(3,5)=10
47169C
47170      NMAX=0
47171      NUMCOL=5
47172      DO4150I=1,NUMCOL
47173        VALIGN(I)='b'
47174        ALIGN(I)='r'
47175        NTOT(I)=15
47176        NMAX=NMAX+NTOT(I)
47177        ITYPCO(I)='NUME'
47178        IDIGIT(I)=0
47179        IF(I.EQ.1 .OR. I.EQ.5)THEN
47180          ITYPCO(I)='ALPH'
47181        ENDIF
47182 4150 CONTINUE
47183C
47184      IWHTML(1)=125
47185      IWHTML(2)=150
47186      IWHTML(3)=150
47187      IWHTML(4)=150
47188      IWHTML(5)=150
47189      IINC=1600
47190      IINC2=1400
47191      IWRTF(1)=IINC
47192      IWRTF(2)=IWRTF(1)+IINC
47193      IWRTF(3)=IWRTF(2)+IINC
47194      IWRTF(4)=IWRTF(3)+IINC
47195      IWRTF(5)=IWRTF(4)+IINC
47196C
47197      DO4160J=1,NUMALP
47198C
47199        AMAT(J,2)=STATV1
47200        ALPHAT=(1.0 - ALPHA(J))/2.0
47201        CALL BINPPF(DBLE(ALPHAT),DPAR,NTEMP,DPPF)
47202        AMAT(J,3)=REAL(DPPF)
47203        ALPHAT=1.0 - ALPHAT
47204        CALL BINPPF(DBLE(ALPHAT),DPAR,NTEMP,DPPF)
47205        AMAT(J,4)=REAL(DPPF)
47206        IVALUE(J,5)(1:6)='ACCEPT'
47207        IF(STATV1.LT.AMAT(J,3))IVALUE(J,5)(1:6)='REJECT'
47208        IF(STATV1.GT.AMAT(J,4))IVALUE(J,5)(1:6)='REJECT'
47209        NCVALU(J,5)=6
47210C
47211        ALPHAT=100.0*ALPHA(J)
47212        WRITE(IVALUE(J,1)(1:4),'(F4.1)')ALPHAT
47213        IVALUE(J,1)(5:5)='%'
47214        NCVALU(J,1)=5
47215 4160 CONTINUE
47216C
47217      ICNT=NUMALP
47218      NUMLIN=3
47219      IFRST=.TRUE.
47220      ILAST=.TRUE.
47221      IFLAGS=.TRUE.
47222      IFLAGE=.TRUE.
47223      IF(ICASAN.NE.'LOWE' .AND. ICASAN.NE.'UPPE')THEN
47224        CALL DPDTA5(ITITLE,NCTITL,
47225     1              ITITL9,NCTIT9,ITITL2,NCTIT2,
47226     1              MAXLIN,NUMLIN,NUMCLI,NUMCOL,
47227     1              IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
47228     1              IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
47229     1              ICAPSW,ICAPTY,IFRST,ILAST,
47230     1              IFLAGS,IFLAGE,
47231     1              ISUBRO,IBUGA3,IERROR)
47232      ENDIF
47233      IF(ICASAN.EQ.'TWOT')GOTO9000
47234C
47235      ITITLE='Lower One-Tailed Test (decreasing trend)'
47236      NCTITL=40
47237      ITITL9='H0: P(+) = P(-); Ha: P(+) < P(-)'
47238      NCTIT9=32
47239C
47240      ITITL2(2,3)='Critical'
47241      NCTIT2(2,3)=8
47242      ITITL2(3,3)='Value (<)'
47243      NCTIT2(3,3)=9
47244C
47245      ITITL2(1,4)='Null'
47246      NCTIT2(1,4)=4
47247      ITITL2(2,4)='Hypothesis'
47248      NCTIT2(2,4)=10
47249      ITITL2(3,4)='Conclusion'
47250      NCTIT2(3,4)=10
47251      ITYPCO(4)='ALPH'
47252C
47253      NMAX=0
47254      NUMCOL=4
47255      DO4250I=1,NUMCOL
47256        NTOT(I)=15
47257        NMAX=NMAX+NTOT(I)
47258 4250 CONTINUE
47259C
47260      DO4260J=1,NUMALP
47261        ALPHAT=1.0 - ALPHA(J)
47262        CALL BINPPF(DBLE(ALPHAT),DPAR,NTEMP,DPPF)
47263        AMAT(J,3)=REAL(DPPF)
47264        IVALUE(J,4)(1:6)='REJECT'
47265        IF(AMAT(J,2).GE.AMAT(J,3))THEN
47266          IVALUE(J,4)(1:6)='ACCEPT'
47267        ENDIF
47268        NCVALU(J,4)=6
47269 4260 CONTINUE
47270C
47271      ICNT=NUMALP
47272      NUMLIN=3
47273      IFRST=.TRUE.
47274      ILAST=.TRUE.
47275      IFLAGS=.TRUE.
47276      IFLAGE=.TRUE.
47277      IF(ICASAN.NE.'UPPE')THEN
47278        CALL DPDTA5(ITITLE,NCTITL,
47279     1              ITITL9,NCTIT9,ITITL2,NCTIT2,
47280     1              MAXLIN,NUMLIN,NUMCLI,NUMCOL,
47281     1              IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
47282     1              IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
47283     1              ICAPSW,ICAPTY,IFRST,ILAST,
47284     1              IFLAGS,IFLAGE,
47285     1              ISUBRO,IBUGA3,IERROR)
47286      ENDIF
47287C
47288      IF(ICASAN.EQ.'LOWE')GOTO9000
47289C
47290      ITITLE='Upper One-Tailed Test (increasing trend)'
47291      NCTITL=40
47292      ITITL9='H0: P(+) = P(-); Ha: P(+) > P(-)'
47293      NCTIT9=32
47294C
47295      ITITL2(1,3)='Upper'
47296      NCTIT2(1,3)=5
47297      ITITL2(2,3)='Critical'
47298      NCTIT2(2,3)=8
47299      ITITL2(3,3)='Value (>)'
47300      NCTIT2(3,3)=9
47301C
47302      NMAX=0
47303      NUMCOL=4
47304      DO4350I=1,NUMCOL
47305        NTOT(I)=15
47306        NMAX=NMAX+NTOT(I)
47307 4350 CONTINUE
47308C
47309      DO4360J=1,NUMALP
47310        ALPHAT=ALPHA(J)
47311        CALL BINPPF(DBLE(ALPHAT),DPAR,NTEMP,DPPF)
47312        AMAT(J,3)=REAL(DPPF)
47313        IVALUE(J,4)(1:6)='REJECT'
47314        IF(AMAT(J,2).LE.AMAT(J,3))THEN
47315          IVALUE(J,4)(1:6)='ACCEPT'
47316        ENDIF
47317        NCVALU(J,4)=6
47318 4360 CONTINUE
47319C
47320      ICNT=NUMALP
47321      NUMLIN=3
47322      IFRST=.TRUE.
47323      ILAST=.TRUE.
47324      IFLAGS=.TRUE.
47325      IFLAGE=.TRUE.
47326      CALL DPDTA5(ITITLE,NCTITL,
47327     1            ITITL9,NCTIT9,ITITL2,NCTIT2,
47328     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
47329     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
47330     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
47331     1            ICAPSW,ICAPTY,IFRST,ILAST,
47332     1            IFLAGS,IFLAGE,
47333     1            ISUBRO,IBUGA3,IERROR)
47334C
47335C               *****************
47336C               **  STEP 90--  **
47337C               **  EXIT       **
47338C               *****************
47339C
47340 9000 CONTINUE
47341      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CXT2')THEN
47342        WRITE(ICOUT,999)
47343        CALL DPWRST('XXX','WRIT')
47344        WRITE(ICOUT,9011)
47345 9011   FORMAT('***** AT THE END       OF DPCXT2--')
47346        CALL DPWRST('XXX','WRIT')
47347      ENDIF
47348C
47349      RETURN
47350      END
47351      SUBROUTINE DPCYGR(IANSLC,IWIDTH,IHARG,IARGT,IARG,NUMARG,
47352     1                  IBUGS2,ISUBRO,IFOUND,IERROR)
47353C
47354C     PURPOSE--CYCLE THROUGH THE CURRENTLY SAVED PIXMAPS
47355C
47356C                  CYCLE GRAPHS  (OR CYCLE PLOT, CG, CP)
47357C
47358C     WRITTEN BY--JAMES J. FILLIBEN
47359C                 STATISTICAL ENGINEERING DIVISION
47360C                 INFORMATION TECHNOLOGY LABORATORY
47361C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
47362C                 GAITHERSBURG, MD 20899-8980
47363C                 PHONE--301-975-2899
47364C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
47365C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
47366C     LANGUAGE--ANSI FORTRAN (1977)
47367C     VERSION NUMBER--97/4
47368C     ORIGINAL VERSION--APRIL     1997.
47369C     UPDATED         --AUGUST    1997. MOVE SOME CODE TO A LOWER LEVEL
47370C                                       TO SUPPORT NON-X11 DEVICES
47371C                                       (SPECIFICALLY PC FOR NOW)
47372C
47373C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
47374C
47375      INCLUDE 'DPCOPA.INC'
47376      CHARACTER*4 IANSLC
47377      CHARACTER*4 IHARG
47378      CHARACTER*4 IARGT
47379      CHARACTER*4 ICODE
47380      CHARACTER*256 ISTRI2
47381      CHARACTER*128 CTEMP
47382C
47383      CHARACTER*4 IBUGS2
47384      CHARACTER*4 ISUBRO
47385      CHARACTER*4 IERROR
47386      CHARACTER*4 IFOUND
47387C
47388      CHARACTER*4 ISTEPN
47389      CHARACTER*4 ISUBN1
47390      CHARACTER*4 ISUBN2
47391C
47392CCCCC DIMENSION IADE(128)
47393CCCCC DIMENSION IADE2(128)
47394C
47395      DIMENSION IANSLC(*)
47396      DIMENSION IHARG(*)
47397      DIMENSION IARGT(*)
47398      DIMENSION IARG(*)
47399C
47400C-----COMMON----------------------------------------------------------
47401C
47402      INCLUDE 'DPCOPM.INC'
47403      INCLUDE 'DPCOF2.INC'
47404      INCLUDE 'DPCOHO.INC'
47405C
47406C-----COMMON VARIABLES (GENERAL)--------------------------------------
47407C
47408      INCLUDE 'DPCOP2.INC'
47409C
47410C-----START POINT-----------------------------------------------------
47411C
47412      ISUBN1='DPLI'
47413      ISUBN2='GR  '
47414      IFOUND='YES'
47415      IERROR='NO'
47416C
47417      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CYGR')THEN
47418        WRITE(ICOUT,999)
47419  999   FORMAT(1X)
47420        CALL DPWRST('XXX','BUG ')
47421        WRITE(ICOUT,51)
47422   51   FORMAT('AT THE BEGINNING OF DPCYGR--')
47423        CALL DPWRST('XXX','BUG ')
47424        WRITE(ICOUT,52)IBUGS2,ISUBRO,IFOUND,IERROR
47425   52   FORMAT('IBUGS2,ISUBRO,IFOUND,IERROR = ',3(A4,2X),A4)
47426        CALL DPWRST('XXX','BUG ')
47427        DO60I=1,IWIDTH
47428          WRITE(ICOUT,62)I,IANSLC(I)
47429   62     FORMAT('I,IANSLC(I) = ',I8,2X,A4)
47430          CALL DPWRST('XXX','BUG ')
47431   60   CONTINUE
47432        DO70I=1,NUMARG
47433          WRITE(ICOUT,72)I,IHARG(I),IARGT(I),IARG(I)
47434   72     FORMAT('I,IHARG(I),IARGT(I),IARG(I) = ',
47435     1           I8,2(2X,A4),I8,G15.7)
47436          CALL DPWRST('XXX','BUG ')
47437   70   CONTINUE
47438      ENDIF
47439C
47440C               *******************************
47441C               **  STEP 12--                **
47442C               **  CALL XCYCLE              **
47443C               *******************************
47444C
47445      ISTEPN='12'
47446      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CYGR')
47447     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
47448C
47449      IF(NUMPXM.LT.2)THEN
47450        WRITE(ICOUT,999)
47451        CALL DPWRST('XXX','BUG ')
47452        WRITE(ICOUT,1203)
47453        CALL DPWRST('XXX','BUG ')
47454        IERROR='YES'
47455        GOTO9000
47456      ELSE
47457        IF(IFEEDB.EQ.'ON')THEN
47458          CALL DPWRST('XXX','BUG ')
47459          WRITE(ICOUT,1213)
47460          CALL DPWRST('XXX','BUG ')
47461          WRITE(ICOUT,1215)
47462          CALL DPWRST('XXX','BUG ')
47463          WRITE(ICOUT,1217)
47464          CALL DPWRST('XXX','BUG ')
47465          IF(ICOMPI.EQ.'MS-F')THEN
47466            WRITE(ICOUT,1221)
47467          ELSE
47468            WRITE(ICOUT,1219)
47469          ENDIF
47470          CALL DPWRST('XXX','BUG ')
47471        ENDIF
47472      ENDIF
47473 1203 FORMAT('***** THERE ARE FEWER THAN TWO CURRENTLY SAVED PIMAPS.')
47474 1213 FORMAT('***** TO CYCLE THROUGH THE PREVIOUSLY SAVED GRAPHS:')
47475 1215 FORMAT('      1. CLICK THE LEFT MOUSE BUTTON TO CYCLE BACK.')
47476 1217 FORMAT('      2. CLICK THE RIGHT MOUSE BUTTON TO CYCLE FORWARD.')
47477 1219 FORMAT('      3. CLICK THE MIDDLE MOUSE BUTTON TO STOP CYCLING.')
47478 1221 FORMAT('      3. HOLD SHIFT OR CONTROL KEY DOWN WHILE CLICKING ',
47479     1'THE LEFT OR RIGHT BUTTON TO STOP CYCLING.')
47480C
47481C  AUGUST 1997.  IN ORDER TO GENERALIZE THE CODE TO NON-X11 DEVICES,
47482C  MOVE FOLLOWING CODE TO LOWER LEVEL ROUTINE.
47483C
47484      ICODE='CYCL'
47485      ISTRI2=' '
47486      CTEMP=' '
47487      NCSTR2=0
47488      NCTEMP=0
47489      CALL GRSAGR(ICODE,ISTRI2,NCSTR2,CTEMP,NCTEMP)
47490C
47491C1000 CONTINUE
47492CCCCC IERR=0
47493CCCCC CALL XCYCLE(IERR,IBUTTN)
47494CCCCC IF(IERR.EQ.4)THEN
47495CCCCC   WRITE(ICOUT,999)
47496CCCCC   CALL DPWRST('XXX','BUG ')
47497CCCCC   WRITE(ICOUT,1310)
47498CCCCC   CALL DPWRST('XXX','BUG ')
47499CCCCC   IERROR='YES'
47500CCCCC   GOTO9000
47501CCCCC ELSEIF(IERR.NE.0)THEN
47502CCCCC   WRITE(ICOUT,999)
47503CCCCC   CALL DPWRST('XXX','BUG ')
47504CCCCC   WRITE(ICOUT,1310)
47505CCCCC   CALL DPWRST('XXX','BUG ')
47506CCCCC   IERROR='YES'
47507CCCCC   GOTO9000
47508CCCCC ENDIF
47509C1310 FORMAT('***** ERROR FROM DPCYGR: X11 NOT ACTIVE ON THIS ',
47510CCCCC1'IMPLEMENTATION.')
47511C1311 FORMAT('***** ERROR FROM DPCYGR: ERROR TRYING TO REDRAW PIXMAP.')
47512CCCCC IF(IBUTTN.EQ.1)THEN
47513CCCCC   ICURPM=ICURPM-1
47514CCCCC   IF(ICURPM.LT.1)ICURPM=1
47515CCCCC ELSEIF(IBUTTN.EQ.3)THEN
47516CCCCC   ICURPM=ICURPM+1
47517CCCCC   IF(ICURPM.GT.NUMPXM)ICURPM=NUMPXM
47518CCCCC ELSE
47519CCCCC   GOTO9000
47520CCCCC ENDIF
47521C
47522CCCCC NCSTR2=1
47523CCCCC DO1405I=128,1,-1
47524CCCCC   NCSTR2=I
47525CCCCC   IF(IPXMFN(ICURPM)(I:I).NE.' ')GOTO1409
47526C1405 CONTINUE
47527C1409 CONTINUE
47528CCCCC CTEMP=' '
47529CCCCC IF(ICURPM.LE.9)THEN
47530CCCCC   CTEMP(1:4)='  - '
47531CCCCC   WRITE(CTEMP(1:1),'(I1)')ICURPM
47532CCCCC   NCTEMP=4
47533CCCCC ELSEIF(ICURPM.LE.99)THEN
47534CCCCC   CTEMP(1:5)='   - '
47535CCCCC   WRITE(CTEMP(1:2),'(I2)')ICURPM
47536CCCCC   NCTEMP=5
47537CCCCC ELSEIF(ICURPM.LE.999)THEN
47538CCCCC   CTEMP(1:6)='    - '
47539CCCCC   WRITE(CTEMP(1:3),'(I3)')ICURPM
47540CCCCC   NCTEMP=6
47541CCCCC ENDIF
47542CCCCC DO1415I=1,NCTEMP
47543CCCCC   CALL DPCOAN(CTEMP(I:I),IADE2(I))
47544C1415 CONTINUE
47545CCCCC DO1420I=1,NCSTR2
47546CCCCC   CALL DPCOAN(IPXMFN(ICURPM)(I:I),IADE(I))
47547CCCCC   CALL DPCOAN(IPXMFN(ICURPM)(I:I),IADE2(I+NCTEMP))
47548C1420 CONTINUE
47549CCCCC IADE(NCSTR2+1)=0
47550CCCCC IADE2(NCSTR2+NCTEMP+1)=0
47551CCCCC IERR=0
47552CCCCC CALL XRESTG(IADE,IADE2,IERR)
47553CCCCC IF(IERR.NE.0)THEN
47554CCCCC   WRITE(ICOUT,999)
47555CCCCC   CALL DPWRST('XXX','BUG ')
47556CCCCC   WRITE(ICOUT,1310)
47557CCCCC   CALL DPWRST('XXX','BUG ')
47558CCCCC   IERROR='YES'
47559CCCCC   GOTO9000
47560CCCCC ENDIF
47561C
47562CCCCC GOTO1000
47563C
47564C               *****************
47565C               **  STEP 90--  **
47566C               **  EXIT       **
47567C               *****************
47568C
47569 9000 CONTINUE
47570      IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'CYGR')GOTO9090
47571      WRITE(ICOUT,999)
47572      CALL DPWRST('XXX','BUG ')
47573 9090 CONTINUE
47574C
47575      RETURN
47576      END
47577