1      SUBROUTINE DPFACT(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
2     1                  IANGLU,MAXNPP,MAXNXT,
3     1                  ICONT,NUMHPP,NUMVPP,IMANUF,
4     1                  XMATN,YMATN,XMITN,YMITN,
5     1                  ISQUAR,IVGMSW,IHGMSW,
6     1                  IMPSW,IMPNR,IMPNC,IMPCO,
7     1                  PMXMIN,PMXMAX,PMYMIN,PMYMAX,
8     1                  ALOWFR,ALOWDG,IFORSW,
9     1                  ANOPL1,ANOPL2,ISEED,IBOOSS,BARHEF,BARWEF,
10     1                  ICAPSW,
11     1                  IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ,
12     1                  IBUGUG,IBUGU2,IBUGU3,IBUGU4,ISUBRO,
13     1                  IFOUND,IERROR)
14C
15C     PURPOSE--GENERATE A FACTOR PLOT.  THAT IS,
16C
17C                 FACTOR PLOT Y X1 X2 X3 X4 X5 X6
18C
19C              PLOTS Y VS X1, Y VS X2, ETC. AS A MULTIPLOT ON
20C              A SINGLE PAGE.
21C     WRITTEN BY--ALAN HECKERT
22C                 STATISTICAL ENGINEERING DIVISION
23C                 INFORMATION TECHNOLOGY LABORATORY
24C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
25C                 GAITHERSBURG, MD 20899-8980
26C                 PHONE--301-975-2899
27C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
28C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
29C     LANGUAGE--ANSI FORTRAN (1977)
30C     VERSION NUMBER--99/10
31C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--OCTOBER   1999.
32C     UPDATED       --AUGUST      2007. CALL LIST TO MAINGR
33C     UPDATED       --JUNE        2014. WRITE YPLOT, XPLOT, TAGPLOT TO
34C                                       DPST5F.DAT
35C
36C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES---------------
37C
38      INCLUDE 'DPCOPA.INC'
39C
40      CHARACTER*4 ICASPL
41      CHARACTER*4 ICAPSW
42      CHARACTER*4 ICONT
43      CHARACTER*4 IPOWE
44      CHARACTER*4 IAND1
45      CHARACTER*4 IAND2
46      CHARACTER*4 IANGLU
47      CHARACTER*4 IFORSW
48C
49      CHARACTER*4 IBUGG2
50      CHARACTER*4 IBUGG3
51      CHARACTER*4 IBUGUG
52      CHARACTER*4 IBUGU2
53      CHARACTER*4 IBUGU3
54      CHARACTER*4 IBUGU4
55      CHARACTER*4 IBUGCO
56      CHARACTER*4 IBUGEV
57      CHARACTER*4 IBUGQ
58C
59      CHARACTER*4 ISUBRO
60      CHARACTER*4 IFOUND
61      CHARACTER*4 IERROR
62C
63      CHARACTER*4 IEMPTY
64      CHARACTER*4 ISQUAR
65      CHARACTER*4 IVGMSW
66      CHARACTER*4 IHGMSW
67      CHARACTER*4 IREPCH
68      CHARACTER*4 IMPSW
69      CHARACTER*4 IFEED9
70      CHARACTER*4 IMANUF
71C
72      CHARACTER*4 IFPLFZ
73      CHARACTER*4 IFPLTZ
74      CHARACTER*4 IFPLPZ
75      CHARACTER*4 IFPLLZ
76      CHARACTER*4 IFPLL2
77      CHARACTER*4 IFPLXZ
78      CHARACTER*4 IFPLYZ
79      CHARACTER*4 IFPLDZ
80      CHARACTER*4 IFPLZT
81      CHARACTER*4 IFPLZ2
82      CHARACTER*4 IFPLZ3
83      CHARACTER*4 IFPLZ4
84      CHARACTER*4 IFPLLD
85      CHARACTER*4 IFPLDI
86      CHARACTER*4 ILFLAX
87      CHARACTER*4 ILFLAY
88      CHARACTER*4 IFPLSV
89      CHARACTER*4 ISUBSZ
90C
91      CHARACTER*4 IOP
92      CHARACTER*4 IFITA2
93C
94      CHARACTER*4 IPLOTT
95      CHARACTER*4 ICT
96      CHARACTER*4 IC2T
97      CHARACTER*4 IHT(5)
98      CHARACTER*4 IH2T(5)
99C
100C  MAXY IS THE MAXIMUM NUMBER OF VARIABLES TO USE IN CREATING THE
101C  FACTOR PLOT   CURVE
102C
103      PARAMETER(MAXY=50)
104      CHARACTER*40 INAME
105      CHARACTER*4 IVARN1(MAXY)
106      CHARACTER*4 IVARN2(MAXY)
107      CHARACTER*4 IVARTY(MAXY)
108      DIMENSION ILIS(MAXY)
109      DIMENSION PVAR(MAXY)
110      DIMENSION NRIGHT(MAXY)
111      DIMENSION ICOLL(MAXY)
112C
113      CHARACTER*4 IHRIGH
114      CHARACTER*4 IHRIG2
115      CHARACTER*4 IHWUSE
116      CHARACTER*4 MESSAG
117      CHARACTER*4 ISTEPN
118      CHARACTER*4 ISUBN1
119      CHARACTER*4 ISUBN2
120C
121      DIMENSION TEMP(MAXOBV)
122      DIMENSION TEMP2(MAXOBV)
123      DIMENSION TEMP3(MAXOBV)
124      DIMENSION XTEMP1(MAXOBV)
125      DIMENSION XTEMP2(MAXOBV)
126C
127C-----COMMON------------------------------------------------------
128C
129      INCLUDE 'DPCOZ3.INC'
130      INCLUDE 'DPCOPC.INC'
131      INCLUDE 'DPCOHK.INC'
132      INCLUDE 'DPCODA.INC'
133      INCLUDE 'DPCOST.INC'
134      INCLUDE 'DPCOSP.INC'
135C
136      EQUIVALENCE (G3RBAG(KGARB1),TEMP(1))
137      EQUIVALENCE (G3RBAG(KGARB2),TEMP2(1))
138      EQUIVALENCE (G3RBAG(KGARB3),TEMP3(1))
139      EQUIVALENCE (G3RBAG(KGARB4),XTEMP1(1))
140      EQUIVALENCE (G3RBAG(KGARB5),XTEMP2(1))
141C
142C-----COMMON VARIABLES (GENERAL)----------------------------------
143C
144      INCLUDE 'DPCOP2.INC'
145C
146C-----START POINT-------------------------------------------------
147C
148      IFOUND='YES'
149      IERROR='NO'
150      ISUBN1='DPFA'
151      ISUBN2='CT  '
152      ICASPL='FACT'
153      IFPLLD='ON'
154      IFPLDI='LINE'
155      ICT=' '
156      IFLAGV=5
157      NCCOMM=0
158C
159C     WRITE XPLOT, YPLOT, TAGPLOT TO "dpst5f.dat"
160C
161      IOP='OPEN'
162      IFLG11=0
163      IFLG21=0
164      IFLG31=0
165      IFLAG4=0
166      IFLAG5=1
167      CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLAG4,IFLAG5,
168     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
169     1            IBUGG2,ISUBRO,IERROR)
170      ICNTPL=0
171      IFITA2=IFITAU
172      IFITAU='OFF'
173      IF(IERROR.EQ.'YES')GOTO9000
174C
175C               *****************************************
176C               **  TREAT THE FACTOR PLOT   CASE       **
177C               *****************************************
178C
179      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'FACT')THEN
180        WRITE(ICOUT,999)
181  999   FORMAT(1X)
182        CALL DPWRST('XXX','BUG ')
183        WRITE(ICOUT,51)
184   51   FORMAT('***** AT THE BEGINNING OF DPFACT--')
185        CALL DPWRST('XXX','BUG ')
186        WRITE(ICOUT,52)ICASPL,IAND1,IAND2,NUMARG,MAXY
187   52   FORMAT('ICASPL,IAND1,IAND2,NUMARG,MAXY = ',3(A4,2X),2I8)
188        CALL DPWRST('XXX','BUG ')
189        WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ,ISUBRO
190   53   FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',3(A4,2X),A4)
191        CALL DPWRST('XXX','BUG ')
192        IF(NUMARG.GT.0)THEN
193          DO61I=1,NUMARG
194            WRITE(ICOUT,62)I,IHARG(I),IARGT(I)
195   62       FORMAT('I,IHARG(I),IARGT(I) = ',I8,2X,A4,2X,A4)
196            CALL DPWRST('XXX','BUG ')
197   61     CONTINUE
198        ENDIF
199        WRITE(ICOUT,71)IFPLLA,IFPLTA,IFPLPT,IFPLFI,IFPLFR
200   71   FORMAT('IFPLLA,IFPLTA,IFPLPT,IFPLFI,IFPLFR = ',5(A4,2X),A4)
201        CALL DPWRST('XXX','BUG ')
202      ENDIF
203C
204C               ******************************************************
205C               **  STEP 1--                                        **
206C               **  SHIFT COMMAND LINE ARGMENTS                     **
207C               ******************************************************
208C
209      ISTEPN='1'
210      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'FACT')
211     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
212C
213      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')THEN
214        ISHIFT=1
215        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
216     1              IBUGG2,IERROR)
217        IF(IERROR.EQ.'YES')GOTO9000
218      ENDIF
219      ICOM='PLOT'
220      ICOM2='    '
221      IFOUND='YES'
222C
223C               *******************************************************
224C               **  STEP 2--                                         **
225C               **  CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS.  **
226C               *******************************************************
227C
228      ISTEPN='2'
229      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'FACT')
230     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
231C
232      INAME='FACTOR PLOT'
233      MINNA=1
234      MAXNA=100
235      MINN2=2
236      IFLAGE=1
237      IF(IFPLPT.EQ.'HIST')IFLAGE=0
238      IF(IFPLPT.EQ.'PERC')IFLAGE=0
239      IF(IFPLPT.EQ.'RUNS')IFLAGE=0
240      IF(IFPLPT.EQ.'SPEC')IFLAGE=0
241      IF(IFPLPT.EQ.'LAG ')IFLAGE=0
242      IF(IFPLPT.EQ.'AUTO')IFLAGE=0
243      IF(IFPLPT.EQ.'KERN')IFLAGE=0
244      IFLAGM=1
245      IFLAGP=0
246      JMIN=1
247      JMAX=NUMARG
248      MINNVA=2
249      MAXNVA=MAXY
250C
251      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
252     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
253     1            JMIN,JMAX,
254     1            MINN2,MINNA,MAXNA,MAXY,IFLAGE,INAME,
255     1            IVARN1,IVARN2,IVARTY,PVAR,
256     1            ILIS,NRIGHT,ICOLL,ISUB,NQ,ILOCQ,NUMVAR,
257     1            MINNVA,MAXNVA,
258     1            IFLAGM,IFLAGP,
259     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
260      IF(IERROR.EQ.'YES')GOTO9000
261C
262      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'FACT')THEN
263        WRITE(ICOUT,999)
264        CALL DPWRST('XXX','BUG ')
265        WRITE(ICOUT,281)
266  281   FORMAT('***** AFTER CALL DPPARS--')
267        CALL DPWRST('XXX','BUG ')
268        WRITE(ICOUT,282)NQ,NUMVAR
269  282   FORMAT('NQ,NUMVAR = ',2I8)
270        CALL DPWRST('XXX','BUG ')
271        IF(NUMVAR.GT.0)THEN
272          DO285I=1,NUMVAR
273            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
274     1                      ICOLL(I)
275  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
276     1             'ICOLL(I) = ',I8,2X,A4,A4,2X,3I8)
277            CALL DPWRST('XXX','BUG ')
278  285     CONTINUE
279        ENDIF
280      ENDIF
281C
282C               **************************************************
283C               **   STEP 1--                                   **
284C               **   SAVE INITIAL SETTINGS                      **
285C               **************************************************
286C
287      ISTEPN='1'
288      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'FACT')
289     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
290C
291      IFLAG=1
292      IFPLSV=IFPLFR
293      ISPMFR=IFPLFR
294      CALL DPSPM5(IFLAG,IMPSW,IMPCO,IMPNR,IMPNC,
295     1            IBUGG2,ISUBRO,IFOUND,IERROR)
296      IFPLFR=IFPLSV
297C
298      ILFLAX='OFF'
299      ILFLAY='OFF'
300      IF(IY1MIN.EQ.'FIXE'.AND.IY1MAX.EQ.'FIXE')THEN
301        ILFLAY='ON'
302      ENDIF
303      IF(IX1MIN.EQ.'FIXE'.AND.IX2MAX.EQ.'FIXE')THEN
304        ILFLAX='ON'
305      ENDIF
306C
307      IFPLL2=IFPLLA
308      IFPLTZ=IFPLTA
309      IFPLFZ=IFPLFR
310      IFPLPZ=IFPLPT
311      IFPLLZ=IFPLLD
312      IFPLZT=IFPLST
313      IFPLZ2=IFPLS2
314      IFPLZ3=IFPLS3
315      IFPLZ4=IFPLS4
316      IFPLXZ=IFPLXA
317      IFPLYZ=IFPLYA
318      IFPLDZ=IFPLDI
319      IF(IFPLFR.EQ.'USER'.AND.IFPLLA.EQ.'BOX')IFPLLA='ON'
320      IF(IFPLFR.EQ.'CONN')IFPLFR='DEFA'
321      IF(IFPLLA.EQ.'BOX ')THEN
322        IFPLLD='ON'
323        IF(IFPLDI.EQ.'BLAN')IFPLDI='LINE'
324      ENDIF
325      IF(IFPLPT.EQ.'YOUD')THEN
326        IFPLTA='ON'
327      ENDIF
328C
329      IFEED9=IFEEDB
330C
331      IF(IFPLTA.EQ.'ON')THEN
332        ISHIFT=ILOCQ-1
333        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
334     1              IBUGG2,IERROR)
335        IF(IERROR.EQ.'YES')GOTO9000
336        ISHIFT=NUMVAR-1
337        CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
338     1              IBUGG2,IERROR)
339        IF(IERROR.EQ.'YES')GOTO9000
340        DO1509I=1,NUMVAR-1
341          IHARG(I)=IVARN1(I)
342          IHARG2(I)=IVARN2(I)
343 1509   CONTINUE
344        NUMVAR=NUMVAR-1
345        IF(IFPLPT.EQ.'HIST'.OR.IFPLPT.EQ.'RUNS'.OR.IFPLPT.EQ.'PERC'.OR.
346     1     IFPLPT.EQ.'AUTO'.OR.IFPLPT.EQ.'SPEC'.OR.IFPLPT.EQ.'LAG ')THEN
347          IF(NUMVAR.LT.1)GOTO9000
348        ELSE
349          IF(NUMVAR.LT.2)GOTO9000
350        ENDIF
351        ILOCQ=ILOCQ-1
352      ENDIF
353C
354      IMPSW3=IMPSW
355      IMPCO2=IMPCO
356      IMPNR2=IMPNR
357      IMPNC2=IMPNC
358      IMPSW='ON'
359      IMPCO=1
360      IMPCO9=IMPCO
361C
362      IFPLRV=INT(PFPLRV+0.5)
363      IF(IFPLRV.LT.1)IFPLRV=1
364      NPLOTS=NUMVAR
365      IFACTV=NPLOTS-IFPLRV
366      IF(IFACTV.LT.1)THEN
367        IFACTV=1
368        IFPLRV=NPLOTS-1
369      ENDIF
370C
371      NPLOTS=IFPLRV*IFACTV
372C
373      IF(IFPLRV.GT.1)THEN
374        IMPNR=IFPLRV
375        IMPNC=IFACTV
376      ELSEIF(IMPNR*IMPNC.LT.NPLOTS)THEN
377        IMPNC=INT(SQRT(REAL(NPLOTS-1)))+1
378        IMPNR=1
379        IF(NPLOTS.GE.11)THEN
380          IMPNR=INT(NPLOTS/IMPNC)+1
381        ELSEIF(NPLOTS.GE.7)THEN
382          IMPNR=3
383        ELSEIF(NPLOTS.GE.3)THEN
384          IMPNR=2
385        ENDIF
386      ENDIF
387C
388      IROWT=IFPLRV
389      ICOLT=IFACTV
390      IF(IFPLLA.EQ.'BOX')THEN
391        IMPNR=IMPNR+1
392        IMPNC=IMPNC+1
393        IROWT=IFPLRV+1
394        ICOLT=IFACTV+1
395      ENDIF
396C
397C               *************************************
398C               **   STEP 21--                     **
399C               **   GENERATE THE SCATTER PLOTS    **
400C               *************************************
401C
402      ISTEPN='21'
403      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'DPFACT')
404     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
405C
406C
407C  2-VARIABLE PLOTS
408C
409      IVAR=2
410      IF(IFPLPT.EQ.'PLOT')THEN
411        ICT='PLOT'
412        IC2T='    '
413        NCCOMM=0
414        IPLOTT='FPLO'
415      ELSEIF(IFPLPT.EQ.'STAT')THEN
416        ICT=IFPLST
417        IC2T=IFPLS2
418        NCCOMM=0
419        IF(IFPLS3.NE.'    ')THEN
420          NCCOMM=NCCOMM+1
421          IHT(NCCOMM)=IFPLS3
422          IH2T(NCCOMM)=IFPLS4
423        ENDIF
424        NCCOMM=NCCOMM+1
425        IHT(NCCOMM)='STAT'
426        IH2T(NCCOMM)='ISTI'
427        NCCOMM=NCCOMM+1
428        IHT(NCCOMM)='PLOT'
429        IH2T(NCCOMM)='    '
430        IPLOTT='STAT'
431      ELSEIF(IFPLPT.EQ.'BIHI')THEN
432        ICT='RELA'
433        IC2T='TIVE'
434        IHT(1)='BIHI'
435        IH2T(1)='STOG'
436        NCCOMM=1
437        IPLOTT='BIHI'
438      ELSEIF(IFPLPT.EQ.'QQPL')THEN
439        ICT='QUAN'
440        IC2T='TILE'
441        IHT(1)='QUAN'
442        IH2T(1)='TILE'
443        IHT(2)='PLOT'
444        IH2T(2)='    '
445        NCCOMM=2
446        IPLOTT='QQFP'
447      ELSEIF(IFPLPT.EQ.'BOXC')THEN
448        ICT='BOX '
449        IC2T='    '
450        IHT(1)='COX '
451        IH2T(1)='    '
452        IHT(2)='LINE'
453        IH2T(2)='ARIT'
454        IHT(3)='PLOT'
455        IH2T(3)='    '
456        NCCOMM=3
457        IPLOTT='BOXC'
458C
459C       UNIVARIATE PLOTS
460C
461      ELSEIF(IFPLPT.EQ.'HIST'.OR.IFPLPT.EQ.'PERC'.OR.
462     1       IFPLPT.EQ.'RUNS'.OR.IFPLPT.EQ.'SPEC'.OR.
463     1       IFPLPT.EQ.'LAG '.OR.IFPLPT.EQ.'AUTO'.OR.
464     1       IFPLPT.EQ.'KERN'.OR.
465     1       IFPLPT.EQ.'PROB'.OR.IFPLPT.EQ.'PPCC')THEN
466        IVAR=1
467        IFPLRV=NUMVAR
468        NPLOTS=NUMVAR
469        IFACTV=0
470        IF(IMPNR*IMPNC.LT.NPLOTS)THEN
471          IMPNC=INT(SQRT(REAL(NPLOTS-1)))+1
472          IMPNR=1
473          IF(NPLOTS.GE.11)THEN
474            IMPNR=INT(NPLOTS/IMPNC)+1
475          ELSEIF(NPLOTS.GE.7)THEN
476            IMPNR=3
477          ELSEIF(NPLOTS.GE.3)THEN
478            IMPNR=2
479          ENDIF
480        ENDIF
481        IF(IFPLLA.EQ.'BOX')IFPLLA='ON'
482C
483        IF(IFPLPT.EQ.'HIST')THEN
484          ICT='RELA'
485          IC2T='TIVE'
486          IHT(1)='HIST'
487          IH2T(1)='OGRA'
488          NCCOMM=1
489          IPLOTT='HIST'
490        ELSEIF(IFPLPT.EQ.'KERN')THEN
491          ICT='KERN'
492          IC2T='EL  '
493          IHT(1)='DENS'
494          IH2T(1)='ITY '
495          IHT(2)='DENS'
496          IH2T(2)='ITY '
497          NCCOMM=2
498          IPLOTT='KERN'
499        ELSEIF(IFPLPT.EQ.'RUNS')THEN
500          ICT='RUN '
501          IC2T='    '
502          IHT(1)='SEQU'
503          IH2T(1)='ENCE'
504          IHT(2)='PLOT'
505          IH2T(2)='    '
506          NCCOMM=2
507          IPLOTT='RUNS'
508        ELSEIF(IFPLPT.EQ.'PERC')THEN
509          ICT='PERC'
510          IC2T='CENT'
511          IHT(1)='POIN'
512          IH2T(1)='T   '
513          IHT(2)='PLOT'
514          IH2T(2)='    '
515          NCCOMM=2
516          IPPTB2=IPPTBI
517          IPPTBI='UNBI'
518          IPLOTT='PERC'
519        ELSEIF(IFPLPT.EQ.'AUTO')THEN
520          ICT='AUTO'
521          IC2T='CORR'
522          IHT(1)='PLOT'
523          IH2T(1)='    '
524          NCCOMM=1
525          IPLOTT='AUTO'
526        ELSEIF(IFPLPT.EQ.'SPEC')THEN
527          ICT='SPEC'
528          IC2T='TRAL'
529          IHT(1)='PLOT'
530          IH2T(1)='    '
531          NCCOMM=1
532          IPLOTT='SPEC'
533        ELSEIF(IFPLPT.EQ.'LAG ')THEN
534          ICT='LAG '
535          IC2T='    '
536          IHT(1)='PLOT'
537          IH2T(1)='    '
538          NCCOMM=1
539          IPLOTT='LAG '
540        ELSEIF(IFPLPT.EQ.'PROB')THEN
541          IF(IFPLP1.EQ.'    ')THEN
542            ICT='NORM'
543            IC2T='AL  '
544            IHT(1)='PROB'
545            IH2T(1)='ABIL'
546            IHT(2)='PLOT'
547            IH2T(2)='    '
548            NCCOMM=2
549          ELSE
550            ICT=IFPLP1
551            IC2T='    '
552            NCCOMM=0
553            IF(IFPLP2.NE.'    ')THEN
554              NCCOMM=NCCOMM+1
555              IHT(NCCOMM)=IFPLP2
556              IH2T(NCCOMM)='    '
557            ENDIF
558            IF(IFPLP3.NE.'    ')THEN
559              NCCOMM=NCCOMM+1
560              IHT(NCCOMM)=IFPLP3
561              IH2T(NCCOMM)='    '
562            ENDIF
563            IF(IFPLP4.NE.'    ')THEN
564              NCCOMM=NCCOMM+1
565              IHT(NCCOMM)=IFPLP4
566              IH2T(NCCOMM)='    '
567            ENDIF
568            IF(IFPLP5.NE.'    ')THEN
569              NCCOMM=NCCOMM+1
570              IHT(NCCOMM)=IFPLP5
571              IH2T(NCCOMM)='    '
572            ENDIF
573            NCCOMM=NCCOMM+1
574            IHT(NCCOMM)='PROB'
575            IH2T(NCCOMM)='ABIL'
576            NCCOMM=NCCOMM+1
577            IHT(NCCOMM)='PLOT'
578            IH2T(NCCOMM)='    '
579          ENDIF
580          IPLOTT='PROB'
581        ELSEIF(IFPLPT.EQ.'PPCC')THEN
582          ICT=IFPLC1
583          IC2T='    '
584          NCCOMM=0
585          IF(IFPLC2.NE.'    ')THEN
586            NCCOMM=NCCOMM+1
587            IHT(NCCOMM)=IFPLC2
588            IH2T(NCCOMM)='    '
589          ENDIF
590          IF(IFPLC3.NE.'    ')THEN
591            NCCOMM=NCCOMM+1
592            IHT(NCCOMM)=IFPLC3
593            IH2T(NCCOMM)='    '
594          ENDIF
595          IF(IFPLC4.NE.'    ')THEN
596            NCCOMM=NCCOMM+1
597            IHT(NCCOMM)=IFPLC4
598            IH2T(NCCOMM)='    '
599          ENDIF
600          IF(IFPLC5.NE.'    ')THEN
601            NCCOMM=NCCOMM+1
602            IHT(NCCOMM)=IFPLC5
603            IH2T(NCCOMM)='    '
604          ENDIF
605          NCCOMM=NCCOMM+1
606          IHT(NCCOMM)='PPCC'
607          IH2T(NCCOMM)='    '
608          NCCOMM=NCCOMM+1
609          IHT(NCCOMM)='PLOT'
610          IH2T(NCCOMM)='    '
611          IPLOTT='PPCC'
612        ENDIF
613      ENDIF
614C
615C               *************************************
616C               **   GENERATE PLOTS                **
617C               *************************************
618C
619      IF(NPLOTS.LT.1)GOTO8000
620C
621      ISHIFT=ILOCQ-1
622      CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
623     1            IBUGG2,IERROR)
624      ISHIFT=NCCOMM+IVAR
625      IF(IFPLTA.EQ.'ON' .AND. IVAR.EQ.2)ISHIFT=ISHIFT+1
626      CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
627     1            IBUGG2,IERROR)
628      ICOM=ICT
629      ICOM2=IC2T
630      IF(NCCOMM.GT.0)THEN
631        DO5301II=1,NCCOMM
632          IHARG(II)=IHT(II)
633          IHARG2(II)=IH2T(II)
634 5301   CONTINUE
635      ENDIF
636      IHARG(NCCOMM+1)=IVARN1(1)
637      IHARG2(NCCOMM+1)=IVARN2(1)
638      IF(IVAR.GE.2)THEN
639        IHARG(NCCOMM+2)=IVARN1(2)
640        IHARG2(NCCOMM+2)=IVARN2(2)
641        IF(IFPLTA.EQ.'ON')THEN
642          IHARG(NCCOMM+3)=IVARN1(NUMVAR+1)
643          IHARG2(NCCOMM+3)=IVARN2(NUMVAR+1)
644        ENDIF
645      ENDIF
646      NARGT=NUMARG
647C
648      IPLOT=0
649      IF(IVAR.EQ.1)THEN
650        IROWT=IFPLRV
651        ICOLT=1
652      ELSE
653        IF(IFPLLA.EQ.'BOX')THEN
654          NPLOTS=NPLOTS+IMPNR+IMPNC-1
655        ENDIF
656      ENDIF
657C
658      DO5300IRES=1,IROWT
659        DO5400IFAC=1,ICOLT
660C
661          IPLOT=IPLOT+1
662          IEMPTY='NO'
663C
664C         ONE RESPONSE VARIABLE CASE
665C
666          IF(IVAR.EQ.1)THEN
667            IHARG(NCCOMM+1)=IVARN1(IRES)
668            IHARG2(NCCOMM+1)=IVARN2(IRES)
669            IX=0
670            IXLIST=1
671            IROW=INT(IPLOT/IMPNC)+1
672            IF(MOD(IPLOT,IMPNC).EQ.0)IROW=IROW-1
673            ICOL=MOD(IPLOT,IMPNC)
674            IF(ICOL.EQ.0)ICOL=IMPNC
675            IF(IFPLLA.EQ.'BOX')THEN
676              ICOL=ICOL-1
677              IF(ICOL.EQ.0)IEMPTY='YES'
678              IF(IROW.EQ.IMPNR)IEMPTY='YES'
679            ENDIF
680            IDY=IRES
681            IDX=1
682            IXZZ=IRES
683C
684C         TWO RESPONSE VARIABLE CASE
685C
686          ELSE
687            IXLIST=IFAC
688            IROW=INT(IPLOT/IMPNC)+1
689            IF(MOD(IPLOT,IMPNC).EQ.0)IROW=IROW-1
690            ICOL=MOD(IPLOT,IMPNC)
691            IF(ICOL.EQ.0)ICOL=IMPNC
692C
693            ITEMP=IFAC
694            IF(IFPLLA.EQ.'BOX')THEN
695              ICOL=ICOL-1
696              ITEMP=IFAC-1
697              IF(ITEMP.EQ.0)IEMPTY='YES'
698              IF(IROW.EQ.IMPNR)IEMPTY='YES'
699            ENDIF
700C
701            IF(IRES.LE.IFPLRV)THEN
702              IHARG(NCCOMM+1)=IVARN1(IRES)
703              IHARG2(NCCOMM+1)=IVARN2(IRES)
704              IDY=IRES
705            ELSE
706              IHARG(NCCOMM+1)=IVARN1(IFPLRV)
707              IHARG2(NCCOMM+1)=IVARN2(IFPLRV)
708              IDY=IFPLRV
709            ENDIF
710C
711            IX=IFPLRV+ITEMP
712            IDX=ITEMP
713            IF(IDX.LE.0)IDX=1
714            IF(IX.GT.IFPLRV)THEN
715              IHARG(NCCOMM+2)=IVARN1(IX)
716              IHARG2(NCCOMM+2)=IVARN2(IX)
717            ELSE
718              IHARG(NCCOMM+2)=IVARN1(IFPLRV+1)
719              IHARG2(NCCOMM+2)=IVARN2(IFPLRV+1)
720            ENDIF
721            IXZZ=IX
722          ENDIF
723C
724          IF(IEMPTY.EQ.'YES')THEN
725            DO5304I=1,MAXSUB
726              ISU2SW(I)=ISUBSW(I)
727              ISUBSW(I)='OFF'
728 5304       CONTINUE
729          ENDIF
730          IOPTN=3
731          CALL DPSPM4(ICASPL,IOPTN,IDX,IDY,
732     1                ISUBNU,ISUBSW,
733     1                ASUBXL,ASUBXU,ASUBYL,ASUBYU,
734     1                ISUBN9,ISUBSZ,
735     1                ASBXL2,ASBXU2,ASBYL2,ASBYU2,
736     1                PFPXSL,PFPXSU,PFPYSL,PFPYSU,
737     1                IBUGG2,ISUBRO,IERROR)
738C
739          ICASPL='FACT'
740          CALL DPSPM1(ICASPL,IVARN1,IVARN2,ICOLL,
741     1                IMPNR,IMPNC,IROW,ICOL,IRES,IXZZ,IPLOT,
742     1                NPLOTS,NUMVAR,
743     1                ICHAP2,ILINP2,
744     1                GY1MNS,GY1MXS,GY2MNS,GY2MXS,
745     1                GX1MNS,GX1MXS,GX2MNS,GX2MXS,
746     1                IY1MNS,IY1MXS,IY2MNS,IY2MXS,
747     1                IX1MNS,IX1MXS,IX2MNS,IX2MXS,
748     1                IX1TSV,IX2TSV,IY1TSV,IY2TSV,
749     1                IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV,
750     1                PX1LD2,PX2LD2,
751     1                IY1LJ2,IY1LD2,PY1LD2,PY1LA2,
752     1                IX1LT2,IX2LT2,IY1LT2,IY2LT2,
753     1                NCX1L2,NCX2L2,NCY1L2,NCY2L2,
754     1                PFPXLL,PFPXUL,PFPYLL,PFPYUL,IXLIST,
755     1                IFPLLA,IFPLLD,IPLOTT,IFPLFR,IFPLXA,IFPLYA,
756     1                IFPLDI,ISPX1L,
757     1                ISPMXT,ISPMXL,ISPMYT,ISPMYL,
758     1                IFPLTD,PFPLTD,IVNMEX,
759     1                IBUGG2,ISUBRO)
760C
761          IF(IEMPTY.EQ.'YES')THEN
762            DO5306I=1,100
763              ICHAPA(I)='BLAN'
764              ILINPA(I)='BLAN'
765              ISPISW(I)='OFF'
766              IBARSW(I)='OFF'
767 5306       CONTINUE
768          ENDIF
769C
770          CALL MAINGR(ANOPL1,ANOPL2,NPLOTV,NPLOTP,NS,ICASPL,
771     1                MAXNPP,ISEED,IBOOSS,
772     1                IX1TSV,IX2TSV,IY1TSV,IY2TSV,
773     1                IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV,
774     1                BARHEF,BARWEF,
775     1                IRHSTG,IHSTCW,IHSTEB,IHSTOU,IASHWT,IHSTMC,IHSTOP,
776     1                ICAPSW,IFORSW,
777     1                IGUIFL,IERRFA,
778     1                IAND1,IAND2,ICONT,NUMHPP,NUMVPP,
779     1                MAXNXT,
780     1                ISUBRO,IFOUND,IERROR)
781          IF(IEMPTY.EQ.'NO')THEN
782            CALL DPSPM3(ICASPL,IOUNI5,
783     1                  IROW,ICOL,
784     1                  PX2LD2,NPLOTP,
785     1                  IFORSW,
786     1                  IFPX2L,ISPX2P,ISPX2S,
787     1                  IHRIGH,IHRIG2,IHWUSE,
788     1                  ISUBN1,ISUBN2,MESSAG,
789     1                  IBUGG2,ISUBRO,IERROR)
790          ENDIF
791C
792          IF(IVAR.EQ.1)THEN
793            ISHIFT=NARGT-NUMARG
794            IF(ISHIFT.GT.0)THEN
795              CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
796     1                    IBUGG2,IERROR)
797            ELSEIF(ISHIFT.LT.0)THEN
798              ISHIFT=-ISHIFT
799              CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
800     1                    IBUGG2,IERROR)
801            ENDIF
802            ICOM=ICT
803            ICOM2=IC2T
804            DO6101II=1,NCCOMM
805              IHARG(II)=IHT(II)
806              IHARG2(II)=IH2T(II)
807 6101       CONTINUE
808            IHARG(NCCOMM+1)=IVARN1(1)
809            IHARG2(NCCOMM+1)=IVARN2(1)
810          ENDIF
811C
812          ICONT=IDCONT(1)
813          IPOWE=IDPOWE(1)
814          NUMHPP=IDNHPP(1)
815          IMPARG=2
816          CALL DPGRAP(Y,X,X3D,D,N,NPLOTP,ICASPL,ICONT,IPOWE,NUMHPP,
817     1                XMATN,YMATN,XMITN,YMITN,
818     1                ISQUAR,
819     1                IVGMSW,IHGMSW,
820     1                IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,
821     1                IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,
822     1                YPLOT,XPLOT,X2PLOT,TAGPLO,
823     1                IMPSW,IMPNR,IMPNC,IMPCO,IMPCO9,
824     1                IMPARG,
825     1                PMXMIN,PMXMAX,PMYMIN,PMYMAX,
826     1                MAXCOL,
827     1                DSIZE,DSYMB,DCOLOR,DFILL,
828     1                ICAPSW,
829     1                IBUGUG,IBUGU2,IBUGU3,IBUGU4,ISUBRO,
830     1                IERROR)
831C
832          ICNTPL=ICNTPL+1
833          IF(N.GT.0)THEN
834            DO3115II=1,N
835              WRITE(IOUNI5,3118)ICNTPL,Y(II),X(II),D(II)
836 3115       CONTINUE
837 3118       FORMAT(I12,3E15.7)
838          ENDIF
839C
840          IF(IERROR.EQ.'NO')IAND1=IAND2
841          IF(IERROR.EQ.'YES')GOTO5499
842C
843          IF(IVAR.EQ.1)GOTO5499
844          IF(IFPLPT.NE.'PLOT')GOTO5499
845          IF(IFPLFI.EQ.'NONE')GOTO5499
846          IF(IEMPTY.EQ.'YES')GOTO5499
847C
848          IMPCO=IMPCO-1
849          IF(IMPCO.LE.1)IERASW='OFF'
850C
851          ICNTPL=0
852          IOUNI5=-99
853          CALL DPSPM2(ICASPL,IVARN1,IVARN2,ICOLL,NUMVAR,NPLOTP,
854     1                IRES,IX,
855     1                TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT,
856     1                ALOWFR,ALOWDG,
857     1                IANGLU,MAXNPP,IAND1,IAND2,
858     1                IFPLFI,IFPLTA,
859     1                XMATN,YMATN,XMITN,YMITN,
860     1                ISQUAR,
861     1                IVGMSW,IHGMSW,
862     1                IMPSW,IMPNR,IMPNC,IMPCO,IMPCO9,
863     1                IREPCH,
864     1                PMXMIN,PMXMAX,PMYMIN,PMYMAX,
865     1                ICNTPL,IOUNI5,
866     1                IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ,
867     1                IBUGUG,IBUGU2,IBUGU3,IBUGU4,
868     1                ISUBRO,IFOUND,IERROR)
869          IF(IERROR.EQ.'YES')GOTO5499
870
871 5499     CONTINUE
872          IERROR='NO'
873          IF(IVAR.EQ.2)THEN
874            ISHIFT=NARGT-NUMARG
875            IF(ISHIFT.GT.0)THEN
876              CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
877     1                    IBUGG2,IERROR)
878            ELSEIF(ISHIFT.LT.0)THEN
879              ISHIFT=-ISHIFT
880              CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
881     1                    IBUGG2,IERROR)
882            ENDIF
883            ICOM=ICT
884            ICOM2=IC2T
885            IF(NCCOMM.GT.0)THEN
886              DO5401II=1,NCCOMM
887                IHARG(II)=IHT(II)
888                IHARG2(II)=IH2T(II)
889 5401         CONTINUE
890            ENDIF
891            IHARG(NCCOMM+1)=IVARN1(1)
892            IHARG2(NCCOMM+1)=IVARN2(1)
893            IHARG(NCCOMM+2)=IVARN1(1)
894            IHARG2(NCCOMM+2)=IVARN2(1)
895            IF(IFPLTA.EQ.'ON')THEN
896              IHARG(NCCOMM+3)=IVARN1(NUMVAR+1)
897              IHARG2(NCCOMM+3)=IVARN2(NUMVAR+1)
898            ENDIF
899          ENDIF
900C
901        PX1LDS=PX1LD2
902        GX1MIN=GX1MNS
903        GX1MAX=GX1MXS
904        GX2MIN=GX2MNS
905        GX2MAX=GX2MXS
906        GY1MIN=GY1MNS
907        GY1MAX=GY1MXS
908        GY2MIN=GY2MNS
909        GY2MAX=GY2MXS
910        IX1MIN=IX1MNS
911        IX1MAX=IX1MXS
912        IX2MIN=IX2MNS
913        IX2MAX=IX2MXS
914        IY1MIN=IY1MNS
915        IY1MAX=IY1MXS
916        IY2MIN=IY2MNS
917        IY2MAX=IY2MXS
918        PX1ZDS=PX1ZD2
919        PX2ZDS=PX2ZD2
920        PY1ZDS=PY1ZD2
921        PY2ZDS=PY2ZD2
922        IF(IEMPTY.EQ.'YES')THEN
923          DO5407I=1,MAXSUB
924            ISUBSW(I)=ISU2SW(I)
925 5407     CONTINUE
926        ENDIF
927        DO5408I=1,100
928            ICHAPA(I)=ICHAP2(I)
929            ILINPA(I)=ILINP2(I)
930            ISPISW(I)=ISPIS2(I)
931            IBARSW(I)=IBARS2(I)
932 5408   CONTINUE
933        IF(IERROR.EQ.'YES')GOTO5400
934C
935 5400 CONTINUE
936 5300 CONTINUE
937C
938C
939C               **************************************************
940C               **   STEP 28--                                  **
941C               **   REINSTATE INITIAL SETTINGS                 **
942C               **************************************************
943C
944 8000 CONTINUE
945C
946      ISTEPN='28'
947      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'4PLO')THEN
948        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
949        WRITE(ICOUT,8807)IMANUF,NUMDEV,IDMANU(1)
950 8807   FORMAT('IMANUF,NUMDEV,IDMANU(1) = ',A4,I8,2X,A4)
951        CALL DPWRST('XXX','BUG ')
952      ENDIF
953C
954      IFLAG=2
955      CALL DPSPM5(IFLAG,IMPSW,IMPCO,IMPNR,IMPNC,
956     1            IBUGG2,ISUBRO,IFOUND,IERROR)
957      IFPLLA=IFPLL2
958      IFPLTA=IFPLTZ
959      IFPLFR=IFPLFZ
960      IFPLPT=IFPLPZ
961      IFPLLD=IFPLLZ
962      IFPLXA=IFPLXZ
963      IFPLYA=IFPLYZ
964      IFPLDI=IFPLDZ
965      IFPLST=IFPLZT
966      IFPLS2=IFPLZ2
967      IFPLS3=IFPLZ3
968      IFPLS4=IFPLZ4
969C
970      IFEEDB=IFEED9
971C
972C               *****************
973C               **  STEP 90--  **
974C               **  EXIT       **
975C               *****************
976C
977 9000 CONTINUE
978C
979      IOP='CLOS'
980      CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLAG4,IFLAG5,
981     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
982     1            IBUGG2,ISUBRO,IERROR)
983      IFITAU=IFITA2
984C
985      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'FACT')THEN
986        WRITE(ICOUT,999)
987        CALL DPWRST('XXX','BUG ')
988        WRITE(ICOUT,9011)
989 9011   FORMAT('***** AT THE END       OF DPFACT--')
990        CALL DPWRST('XXX','BUG ')
991        WRITE(ICOUT,9012)IFOUND,IERROR
992 9012   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
993        CALL DPWRST('XXX','BUG ')
994        WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
995 9013   FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',3I8,3(2X,A4))
996        CALL DPWRST('XXX','BUG ')
997      ENDIF
998C
999      RETURN
1000      END
1001      SUBROUTINE DPFAIR(NPTS,NLAB,
1002     1                  AMEAN,ASD,N,
1003     1                  XFAIR,XFAIS2,SEFWK1,SEFWK2,
1004     1                  DLOWFW,DHIGFW,DLOWF2,DHIGF2,DLOWF3,DHIGF3,
1005     1                  IWRITE,
1006     1                  ICAPSW,ICAPTY,IFLAG9,NUMDIG,
1007     1                  ISUBRO,IBUGA3,IERROR)
1008C
1009C     PURPOSE--IMPLEMENT FAIRWEATHER APPROACH TO CONSENSUS MEANS
1010C     PRINTING--YES
1011C     SUBROUTINES NEEDED--NONE
1012C     REFERENCES--ADAPTED FROM MATLAB SCRIPT PROVIDED BY
1013C                 ANDREW RUHKIN OF THE NIST STATISTICAL
1014C                 ENGINEERING DIVISION
1015C               --FAIRWEATHER (1972), "A METHOD FOR OBTAINING
1016C                 AN EXACT CONFIDENCE INTERVAL FOR THE COMMON
1017C                 MEAN OF SEVERAL NORMAL POPULATIONS",
1018C                 APPLIED STATISTICS, 21, PP. 229-233.
1019C               --M. G. COX (2002), "THE EVALUATION OF KEY
1020C                 COMPARISON DATA", METROLOGIA, 39, PP. 589-595.
1021C     WRITTEN BY--ALAN HECKERT
1022C                 STATISTICAL ENGINEERING DIVISION
1023C                 INFORMATION TECHNOLOGY LABORATORY
1024C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
1025C                 GAITHERSBURG, MD 20899-8980
1026C                 PHONE--301-975-2899
1027C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
1028C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
1029C     LANGUAGE--ANSI FORTRAN (1977)
1030C     VERSION NUMBER--2006/4
1031C     ORIGINAL VERSION--APRIL     2006.
1032C     UPDATED         --OCTOBER   2006. CALL LIST TO TPPF
1033C     UPDATED         --UPDATED   2010. USE DPDTA1 TO PRINT
1034C
1035C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES--------------
1036C
1037      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
1038C
1039      CHARACTER*4 IWRITE
1040      CHARACTER*4 ICAPSW
1041      CHARACTER*4 ICAPTY
1042      CHARACTER*4 ISUBRO
1043      CHARACTER*4 IBUGA3
1044      CHARACTER*4 IERROR
1045C
1046      CHARACTER*4 ISUBN1
1047      CHARACTER*4 ISUBN2
1048C
1049      REAL AMEAN(*)
1050      REAL ASD(*)
1051C
1052      REAL APPF
1053      REAL XFAIR
1054      REAL XFAIS2
1055      REAL SEFWK1
1056      REAL SEFWK2
1057C
1058      LOGICAL IFLAG9
1059C
1060      INTEGER N(*)
1061C
1062C----------------------------------------------------------------
1063C
1064      INCLUDE 'DPCOST.INC'
1065C
1066      PARAMETER (MAXROW=20)
1067      CHARACTER*60 ITITLE
1068      CHARACTER*60 ITITLZ
1069      CHARACTER*60 ITITL9
1070      CHARACTER*60 ITEXT(MAXROW)
1071      REAL         AVALUE(MAXROW)
1072      INTEGER      NCTEXT(MAXROW)
1073      INTEGER      IDIGIT(MAXROW)
1074      INTEGER      NTOT(MAXROW)
1075      LOGICAL IFRST
1076      LOGICAL ILAST
1077C
1078      INCLUDE 'DPCOP2.INC'
1079C
1080C-----START POINT------------------------------------------------
1081C
1082      IERROR='NO'
1083      ISUBN1='DPFA'
1084      ISUBN2='IR  '
1085C
1086      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FAIR')THEN
1087        WRITE(ICOUT,999)
1088  999   FORMAT(1X)
1089        CALL DPWRST('XXX','BUG ')
1090        WRITE(ICOUT,51)
1091   51   FORMAT('***** AT THE BEGINNING OF DPFAIR--')
1092        CALL DPWRST('XXX','BUG ')
1093        WRITE(ICOUT,52)IWRITE,NPTS,NLAB
1094   52   FORMAT('IWRITE,NPTS,NLAB = ',A4,2X,2I8)
1095        CALL DPWRST('XXX','BUG ')
1096      ENDIF
1097C
1098C     STEP 1: COMPUTE THE FAIRWEATHER CONSENSUS MEAN
1099C
1100      IFLAG9=.TRUE.
1101      DSUM1=0.0D0
1102      DO910I=1,NLAB
1103        DNI=DABS(DBLE(N(I)))
1104        IF(N(I).GT.5)THEN
1105          DSUM1=DSUM1 + (DNI-3.0D0)/(DNI-1.0D0)
1106        ELSE
1107          IFLAG9=.FALSE.
1108          XFAIR=CPUMIN
1109          DLOWFW=0.0D0
1110          DHIGFW=0.0D0
1111          GOTO9000
1112        ENDIF
1113  910 CONTINUE
1114      DU1=DSUM1
1115C
1116      DSUM1=0.0D0
1117      DO920I=1,NLAB
1118        DNI=DBLE(N(I))
1119        IF(N(I).LT.0)THEN
1120          DVARI=DBLE(ASD(I))**2
1121          U=DVARI
1122        ELSE
1123          DVARI=DBLE(ASD(I))**2
1124          U=DVARI/DNI
1125        ENDIF
1126        CK=(DABS(DNI)-3.0D0)/(DABS(DNI)-1.0D0)
1127        CF=CK/DU1
1128        WF=CF/DSQRT(U)
1129        DSUM1=DSUM1 +  WF
1130  920 CONTINUE
1131      DSS=DSUM1
1132C
1133      DSUM1=0.0D0
1134      DO930I=1,NLAB
1135        DNI=DBLE(N(I))
1136        DMEAN=DBLE(AMEAN(I))
1137        IF(N(I).LT.0)THEN
1138          DVARI=DBLE(ASD(I))**2
1139          U=DVARI
1140        ELSE
1141          DVARI=DBLE(ASD(I))**2
1142          U=DVARI/DNI
1143        ENDIF
1144        CK=(DABS(DNI)-3.0D0)/(DABS(DNI)-1.0D0)
1145        CF=CK/DU1
1146        WF=CF/DSQRT(U)
1147        DWI=WF/DSS
1148        DSUM1=DSUM1 + DWI*DMEAN
1149  930 CONTINUE
1150      XFAIR=REAL(DSUM1)
1151C
1152      DP=DBLE(NLAB)
1153      DPP=1.0D0/DBLE(NLAB-1)
1154      DRR=DP**(DP*DPP/2.0D0)
1155      IDF=NLAB-1
1156      ALPHA=0.975
1157      CALL TPPF(REAL(ALPHA),REAL(IDF),APPF)
1158      DPH=DBLE(APPF)/DRR/(DSQRT(DP-1.0D0))
1159C
1160      DSUM2=0.0D0
1161      DSUM3=0.0D0
1162      DSUM4=0.0D0
1163      DSUM5=0.0D0
1164C
1165      DPROD1=1.0D0
1166      DO940I=1,NLAB
1167        DNI=DBLE(N(I))
1168        DMEAN=DBLE(AMEAN(I))
1169        IF(N(I).LT.0)THEN
1170          DVARI=DBLE(ASD(I))**2
1171          U=DVARI
1172        ELSE
1173          DVARI=DBLE(ASD(I))**2
1174          U=DVARI/DNI
1175        ENDIF
1176        CK=(DABS(DNI)-3.0D0)/(DABS(DNI)-1.0D0)
1177        CF=CK/DU1
1178        WF=CF/DSQRT(U)
1179        DWI=WF/DSS
1180        DSUM2=DSUM2 + DWI*(DMEAN - DBLE(XFAIR))**2
1181        DPROD1=DPROD1*DWI
1182        DSUM3=DSUM3 + CF*CF/(DABS(DNI)-5.0D0)
1183        DSUM4=DSUM4 + WF**4/(CK*CK*(DABS(DNI)-5.0D0))
1184        DSUM5=DSUM5 + WF**2/CK
1185  940 CONTINUE
1186      DPH2=1.0D0/DRR/(DSQRT(DP-1.0D0))
1187      DPROD1=DPROD1**DPP
1188      DRI=DPH*DSQRT(DSUM2)/DSQRT(DPROD1)
1189      SEFWK1=DPH2*DSQRT(DSUM2)/DSQRT(DPROD1)
1190      SEFWK2=2.0*SEFWK2
1191      SU2=DSUM3
1192      SU=DSUM4
1193      UD=DSUM5
1194      NR=INT(4.0D0 + (1.0D0/SU2))
1195      ALPHA=0.975
1196      CALL TPPF(REAL(ALPHA),REAL(NR),APPF)
1197      FC=DSQRT((DBLE(NR)-2.0D0)/(DBLE(NR)*DU1))
1198      TF=FC*DBLE(APPF)
1199      NU=INT(4.0 + (UD*UD/SU))
1200C
1201      DLOWF2=DBLE(XFAIR) - (TF/DSS)
1202      DHIGF2=DBLE(XFAIR) + (TF/DSS)
1203C
1204      CALL TPPF(REAL(ALPHA),REAL(NU),APPF)
1205      RC=DSQRT(UD*(DBLE(NU) - 2.0D0)/DBLE(NU))
1206      DLOWF3=DBLE(XFAIR) - (RC*DBLE(APPF))
1207      DHIGF3=DBLE(XFAIR) + (RC*DBLE(APPF))
1208C
1209C
1210      DLOWFW=DBLE(XFAIR) - DRI
1211      DHIGFW=DBLE(XFAIR) + DRI
1212C
1213      IF(.NOT.IFLAG9)GOTO9000
1214      IF(IPRINT.EQ.'OFF')GOTO9000
1215C
1216      ITITLE=' '
1217      NCTITL=0
1218      ITITLZ=' '
1219      NCTITZ=0
1220C
1221      ICNT=1
1222      ITEXT(ICNT)=' 6. Method: Fairweather'
1223      NCTEXT(ICNT)=23
1224      AVALUE(ICNT)=0.0
1225      IDIGIT(ICNT)=-1
1226C
1227      ICNT=ICNT+1
1228      ITEXT(ICNT)='    Estimate of Consensus Mean:'
1229      NCTEXT(ICNT)=31
1230      AVALUE(ICNT)=XFAIR
1231      IDIGIT(ICNT)=NUMDIG
1232      ICNT=ICNT+1
1233      ITEXT(ICNT)='    Degrees of Freedom (Fairweather):'
1234      NCTEXT(ICNT)=37
1235      AVALUE(ICNT)=NR
1236      IDIGIT(ICNT)=0
1237      ICNT=ICNT+1
1238      ITEXT(ICNT)='    Degrees of Freedom (Cox):'
1239      NCTEXT(ICNT)=28
1240      AVALUE(ICNT)=NU
1241      IDIGIT(ICNT)=0
1242      ICNT=ICNT+1
1243      ITEXT(ICNT)='    Lower 95% (Fairweather) Confidence Limit:'
1244      NCTEXT(ICNT)=45
1245      AVALUE(ICNT)=DLOWF2
1246      IDIGIT(ICNT)=NUMDIG
1247      ICNT=ICNT+1
1248      ITEXT(ICNT)='    Upper 95% (Fairweather) Confidence Limit:'
1249      NCTEXT(ICNT)=45
1250      AVALUE(ICNT)=DHIGF2
1251      IDIGIT(ICNT)=NUMDIG
1252      ICNT=ICNT+1
1253      ITEXT(ICNT)='    Lower 95% (Cox) Confidence Limit:'
1254      NCTEXT(ICNT)=37
1255      AVALUE(ICNT)=DLOWF3
1256      IDIGIT(ICNT)=NUMDIG
1257      ICNT=ICNT+1
1258      ITEXT(ICNT)='    Upper 95% (Cox) Confidence Limit:'
1259      NCTEXT(ICNT)=37
1260      AVALUE(ICNT)=DHIGF3
1261      IDIGIT(ICNT)=NUMDIG
1262      ICNT=ICNT+1
1263      ITEXT(ICNT)='    Lower 95% (minmax) Confidence Limit:'
1264      NCTEXT(ICNT)=40
1265      AVALUE(ICNT)=DLOWFW
1266      IDIGIT(ICNT)=NUMDIG
1267      ICNT=ICNT+1
1268      ITEXT(ICNT)='    Upper 95% (minmax) Confidence Limit:'
1269      NCTEXT(ICNT)=40
1270      AVALUE(ICNT)=DHIGFW
1271      IDIGIT(ICNT)=NUMDIG
1272      ICNT=ICNT+1
1273      ITEXT(ICNT)='    Note: Fairweather Best Usage:'
1274      NCTEXT(ICNT)=33
1275      AVALUE(ICNT)=0.0
1276      IDIGIT(ICNT)=-1
1277      ICNT=ICNT+1
1278      ITEXT(ICNT)='          Minimum Sample Size for Lab > 5'
1279      NCTEXT(ICNT)=41
1280      AVALUE(ICNT)=0.0
1281      IDIGIT(ICNT)=-1
1282C
1283      NUMROW=ICNT
1284      DO310I=1,NUMROW
1285        NTOT(I)=15
1286  310 CONTINUE
1287C
1288      IFRST=.TRUE.
1289      ILAST=.TRUE.
1290      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
1291     1            AVALUE,IDIGIT,
1292     1            NTOT,NUMROW,
1293     1            ICAPSW,ICAPTY,ILAST,IFRST,
1294     1            ISUBRO,IBUGA3,IERROR)
1295      ITITLE=' '
1296      NCTITL=0
1297      ITITLZ=' '
1298      NCTITZ=0
1299      ITITL9=' '
1300      NCTIT9=0
1301C
1302C               *****************
1303C               **  STEP 90--  **
1304C               **  EXIT       **
1305C               *****************
1306C
1307 9000 CONTINUE
1308      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FAIR')THEN
1309        WRITE(ICOUT,999)
1310        CALL DPWRST('XXX','BUG ')
1311        WRITE(ICOUT,9011)
1312 9011   FORMAT('***** AT THE END       OF DPFAIR--')
1313        CALL DPWRST('XXX','BUG ')
1314        WRITE(ICOUT,9012)IERROR
1315 9012   FORMAT('IERROR = ',A4)
1316        CALL DPWRST('XXX','BUG ')
1317        WRITE(ICOUT,9013)NPTS,NLAB,XFAIR,XFAIS2
1318 9013   FORMAT('NPTS,NLAB,XFAIR,XFAIS2 = ',2I8,2G15.7)
1319        CALL DPWRST('XXX','BUG ')
1320        WRITE(ICOUT,9015)DLOWFW,DHIGFW
1321 9015   FORMAT('DLOWFW,DHIGFW = ',2G15.7)
1322        CALL DPWRST('XXX','BUG ')
1323      ENDIF
1324C
1325      RETURN
1326      END
1327      SUBROUTINE DPFAN2(X,NROW,NCOL,NCLUST,IVARN1,IVARN2,
1328     1                  DSS,DVEC,P,DP,PT,ESP,EF,RDRAW,
1329     1                  NCLUV,NELEM,NFUZZ,
1330     1                  ICAPSW,ICAPTY,IFORSW,MAXNXT,
1331     1                  ISUBRO,IBUGA3,IERROR)
1332C
1333C     PURPOSE--PERFORM A "FUZZY" CLUSTER ANALYSIS USING KAUFFMAN AND
1334C              ROUSSEEUW "FANNY" ALGORITHM.
1335C     REFERENCES--KAUFMAN AND ROUSSEEUW (1990), "FINDING GROUPS IN DATA:
1336C                 AN INTRODUCTION TO CLUSTER ANALYSIS", WILEY.
1337C               --ROUSSEEUW (1987), "SILHOUETTES: A GRAPHICAL AID TO THE
1338C                 INTERPRETATION AND VALIDATION OF CLUSTER ANALYSIS",
1339C                 JOURNAL OF COMPUTATIONAL AND APPLIED MATHEMATICS,
1340C                 VOL. 20, PP. 53-65, NORTH HOLLAND.
1341C     WRITTEN BY--ALAN HECKERT
1342C                 STATISTICAL ENGINEERING DIVISION
1343C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
1344C                 GAITHERSBURG, MD 20899-8980
1345C                 PHONE--301-975-2899
1346C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
1347C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
1348C     REFERENCE--ASTM MANUAL STP-15D, PAGES 78-84, 100-105
1349C     LANGUAGE--ANSI FORTRAN (1977)
1350C     VERSION NUMBER--2017/08
1351C     ORIGINAL VERSION--AUGUST      2017.
1352C
1353C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
1354C
1355      DIMENSION X(NROW,NCOL)
1356      DIMENSION P(NROW,NCOL)
1357      DIMENSION DP(NROW,NCOL)
1358      DIMENSION DSS(*)
1359      DIMENSION DVEC(*)
1360      DIMENSION PT(*)
1361      DIMENSION ESP(*)
1362      DIMENSION EF(*)
1363      DIMENSION RDRAW(*)
1364C
1365      INTEGER NCLUV(*)
1366      INTEGER NELEM(*)
1367      INTEGER NFUZZ(*)
1368C
1369      CHARACTER*4 IVARN1(*)
1370      CHARACTER*4 IVARN2(*)
1371      CHARACTER*4 ICAPSW
1372      CHARACTER*4 ICAPTY
1373      CHARACTER*4 IFORSW
1374      CHARACTER*4 ISUBRO
1375      CHARACTER*4 IBUGA3
1376      CHARACTER*4 IERROR
1377C
1378      CHARACTER*4 IWRITE
1379      CHARACTER*4 ISUBN1
1380      CHARACTER*4 ISUBN2
1381      CHARACTER*4 ISTEPN
1382      CHARACTER*4 ICASPL
1383      CHARACTER*4 ITYP3
1384      CHARACTER*4 IOP
1385      CHARACTER*3 LAB
1386C
1387      INCLUDE 'DPCOST.INC'
1388      INCLUDE 'DPCOP2.INC'
1389C
1390C-----START POINT-----------------------------------------------------
1391C
1392      ISUBN1='DPFA'
1393      ISUBN2='N2  '
1394      IWRITE='OFF'
1395      IFLAGO=0
1396C
1397      ICNT=0
1398C
1399      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FAN2')THEN
1400        WRITE(ICOUT,999)
1401  999   FORMAT(1X)
1402        CALL DPWRST('XXX','BUG ')
1403        WRITE(ICOUT,70)
1404   70   FORMAT('AT THE BEGINNING OF DPFAN2--')
1405        CALL DPWRST('XXX','BUG ')
1406        WRITE(ICOUT,72)NROW,NCOL,NCLUST,IFANMS,IFANSC,IFANDI,IFANTY
1407   72   FORMAT('NROW,NCOL,NCLUST,IFANMS,IFANSC,IFANDI,IFANTY = ',
1408     1         4I8,3(2X,A4))
1409        CALL DPWRST('XXX','BUG ')
1410        WRITE(ICOUT,18)ICAPSW,ICAPTY,IFORSW,MAXNXT
1411   18   FORMAT('ICAPSW,ICAPTY,IFORSW,MAXNXT = ',3(A4,2X),I8)
1412        CALL DPWRST('XXX','BUG ')
1413        DO75I=1,NROW
1414          WRITE(ICOUT,77)I,(X(I,J),J=1,5)
1415   77     FORMAT('I,(X(I,J),J=1,5) = ',I8,2X,5G15.7)
1416          CALL DPWRST('XXX','BUG ')
1417   75   CONTINUE
1418      ENDIF
1419C
1420C               ********************************
1421C               **   STEP 1--                 **
1422C               **   CHECK FOR MISSING VALUES **
1423C               ********************************
1424C
1425      ISTEPN='1'
1426      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FAN2')
1427     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1428C
1429C     FIRST CHECK WHETHER ANY ROWS OR COLUMNS CONTAIN ONLY
1430C     MISSING DATA.  THIS WILL BE TREATED AS AN ERROR CONDITION.
1431C
1432C     CHECK ROWS FIRST
1433C
1434      DO80I=1,NROW
1435        DO90J=1,NCOL
1436          IF(X(I,J).NE.PSTAMV)GOTO99
1437   90   CONTINUE
1438        WRITE(ICOUT,999)
1439        CALL DPWRST('XXX','BUG ')
1440        WRITE(ICOUT,91)
1441   91   FORMAT('****** ERROR IN PAM CLUSTERING--')
1442        CALL DPWRST('XXX','BUG ')
1443        WRITE(ICOUT,93)I
1444   93   FORMAT('       ROW (OBSERVATION) ',I8,' CONTAINS ONLY ',
1445     1         'MISSING DATA.')
1446        CALL DPWRST('XXX','BUG ')
1447        IERROR='YES'
1448        GOTO9000
1449   99   CONTINUE
1450   80 CONTINUE
1451C
1452C     NOW CHECK COLUMNS
1453C
1454      NMISS=0
1455      NMAT=0
1456C
1457      DO730J=1,NCOL
1458        NMISSV=0
1459        DO740I=1,NROW
1460          IF(X(I,J).EQ.PSTAMV)THEN
1461            NMISSV=NMISSV + 1
1462          ENDIF
1463  740   CONTINUE
1464        IF(NMISSV.EQ.NROW)THEN
1465          WRITE(ICOUT,999)
1466          CALL DPWRST('XXX','BUG ')
1467          WRITE(ICOUT,91)
1468          CALL DPWRST('XXX','BUG ')
1469          WRITE(ICOUT,743)J
1470  743     FORMAT('       COLUMN (VARIABLE) ',I8,' CONTAINS ONLY ',
1471     1           'MISSING DATA.')
1472          CALL DPWRST('XXX','BUG ')
1473          IERROR='YES'
1474          GOTO9000
1475        ELSEIF(NMISSV.EQ.0)THEN
1476          NMAT=1
1477        ELSE
1478          WRITE(ICOUT,999)
1479          CALL DPWRST('XXX','BUG ')
1480          WRITE(ICOUT,746)IVARN1(J),IVARN2(J),NMISSV
1481  746     FORMAT('VARIABLE ',2A4,' CONTAINS ',I8,' MISSING VALUES.')
1482          CALL DPWRST('XXX','BUG ')
1483          WRITE(ICOUT,743)J
1484        ENDIF
1485        NMISS=NMISS + NMISSV
1486  730 CONTINUE
1487C
1488      IF(NMISS.GT.0)THEN
1489        WRITE(ICOUT,999)
1490        CALL DPWRST('XXX','BUG ')
1491        WRITE(ICOUT,163)
1492  163   FORMAT('THE TOTAL NUMBER OF MISSING VALUES IS ',I8)
1493        CALL DPWRST('XXX','BUG ')
1494        IF(NMAT.EQ.0)THEN
1495          WRITE(ICOUT,999)
1496          CALL DPWRST('XXX','BUG ')
1497          WRITE(ICOUT,165)
1498  165     FORMAT('****** WARNING IN PAM CLUSTERING--')
1499          CALL DPWRST('XXX','BUG ')
1500          WRITE(ICOUT,167)
1501  167     FORMAT('       NO VARIABLES ARE DEFINED FOR ALL ',
1502     1           'OBSERVATIONS.')
1503          CALL DPWRST('XXX','BUG ')
1504        ENDIF
1505      ENDIF
1506C
1507C               ******************************
1508C               **   STEP 2--               **
1509C               **   SCALE IF REQUESTED     **
1510C               ******************************
1511C
1512      ISTEPN='1'
1513      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PAM2')THEN
1514        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1515        WRITE(ICOUT,168)NMISS,PSTAMV
1516  168   FORMAT('NMISS,PSTAMV = ',I8,2X,G15.7)
1517        CALL DPWRST('XXX','BUG ')
1518      ENDIF
1519C
1520C     IF NROW = NCOL, ASSUME OUR DATA IS A DISSIMILARITY MATRIX.
1521C     OTHERWISE, ASSUME OUR DATA IS MEASUREMENT DATA.  DO NOT SCALE
1522C     DISSIMILARITY DATA EVEN IF SCALING OPTION TURNED ON.
1523C
1524      LARGE=2
1525      IF(IFANPR.EQ.'FINA')LARGE=1
1526      IF(NROW.EQ.NCOL .AND. IFANTY.EQ.'DISS')THEN
1527        JDYSS=1
1528      ELSE
1529        JDYSS=0
1530      ENDIF
1531      NSTAN=0
1532      IF(JDYSS.EQ.1)GOTO299
1533      IF(IFANSC.EQ.'OFF')GOTO299
1534C
1535      NSTAN=1
1536      DO201JJ=1,NCOL
1537        NROWT=0
1538        DO203II=1,NROW
1539          IF(X(II,JJ).NE.PSTAMV)THEN
1540            NROWT=NROWT+1
1541            DSS(NROWT)=X(II,JJ)
1542          ENDIF
1543  203   CONTINUE
1544        IF(ISTALO.EQ.'MEAN')THEN
1545          CALL MEAN(DSS,NROWT,IWRITE,XMEAN,IBUGA3,IERROR)
1546        ELSEIF(ISTALO.EQ.'MEDI')THEN
1547          CALL MEDIAN(DSS,NROWT,IWRITE,ESP,MAXNXT,XMEAN,
1548     1                IBUGA3,IERROR)
1549        ELSEIF(ISTALO.EQ.'MIDM')THEN
1550          CALL MIDMEA(DSS,NROWT,IWRITE,ESP,MAXNXT,XMEAN,
1551     1                IBUGA3,IERROR)
1552        ELSEIF(ISTALO.EQ.'HARM')THEN
1553          CALL HARMEA(DSS,NROWT,IWRITE,XMEAN,IBUGA3,IERROR)
1554        ELSEIF(ISTALO.EQ.'MINI')THEN
1555          CALL MINIM(DSS,NROWT,IWRITE,XMEAN,IBUGA3,IERROR)
1556        ELSEIF(ISTALO.EQ.'GEOM')THEN
1557          CALL GEOMEA(DSS,NROWT,IWRITE,XMEAN,IBUGA3,IERROR)
1558        ELSEIF(ISTALO.EQ.'BILO')THEN
1559          CALL BIWLOC(DSS,NROWT,IWRITE,EF,ESP,MAXNXT,XMEAN,
1560     1                IBUGA3,IERROR)
1561        ELSEIF(ISTALO.EQ.'H15 ')THEN
1562          NCUT=0
1563          C=1.5
1564          CALL H15(DSS,NROWT,C,NCUT,XMEAN,XSC,EF,ESP,MAXNXT,
1565     1                IBUGA3,IERROR)
1566        ELSEIF(ISTALO.EQ.'H10 ')THEN
1567          NCUT=0
1568          C=1.0
1569          CALL H15(DSS,NROWT,C,NCUT,XMEAN,XSC,EF,ESP,MAXNXT,
1570     1                IBUGA3,IERROR)
1571        ELSEIF(ISTALO.EQ.'H12 ')THEN
1572          NCUT=0
1573          C=1.2
1574          CALL H15(DSS,NROWT,C,NCUT,XMEAN,XSC,EF,ESP,MAXNXT,
1575     1                IBUGA3,IERROR)
1576        ELSEIF(ISTALO.EQ.'H17 ')THEN
1577          NCUT=0
1578          C=1.7
1579          CALL H15(DSS,NROWT,C,NCUT,XMEAN,XSC,EF,ESP,MAXNXT,
1580     1                IBUGA3,IERROR)
1581        ELSEIF(ISTALO.EQ.'H20 ')THEN
1582          NCUT=0
1583          C=2.0
1584          CALL H15(DSS,NROWT,C,NCUT,XMEAN,XSC,EF,ESP,MAXNXT,
1585     1                IBUGA3,IERROR)
1586        ELSE
1587          CALL MEAN(DSS,NROWT,IWRITE,XMEAN,IBUGA3,IERROR)
1588        ENDIF
1589C
1590        IF(ISTASC.EQ.'SD  ')THEN
1591          CALL SD(DSS,NROWT,IWRITE,XSD,IBUGA3,IERROR)
1592        ELSEIF(ISTASC.EQ.'H15S')THEN
1593          NCUT=0
1594          C=1.5
1595          CALL H15(DSS,NROWT,C,NCUT,XLOC,XSD,EF,ESP,MAXNXT,
1596     1                IBUGA3,IERROR)
1597        ELSEIF(ISTASC.EQ.'H10S')THEN
1598          NCUT=0
1599          C=1.0
1600          CALL H15(DSS,NROWT,C,NCUT,XLOC,XSD,EF,ESP,MAXNXT,
1601     1                IBUGA3,IERROR)
1602        ELSEIF(ISTASC.EQ.'H12S')THEN
1603          NCUT=0
1604          C=1.2
1605          CALL H15(DSS,NROWT,C,NCUT,XLOC,XSD,EF,ESP,MAXNXT,
1606     1                IBUGA3,IERROR)
1607        ELSEIF(ISTASC.EQ.'H17S')THEN
1608          NCUT=0
1609          C=1.7
1610          CALL H15(DSS,NROWT,C,NCUT,XLOC,XSD,EF,ESP,MAXNXT,
1611     1                IBUGA3,IERROR)
1612        ELSEIF(ISTASC.EQ.'H20S')THEN
1613          NCUT=0
1614          C=2.0
1615          CALL H15(DSS,NROWT,C,NCUT,XLOC,XSD,EF,ESP,MAXNXT,
1616     1                IBUGA3,IERROR)
1617        ELSEIF(ISTASC.EQ.'BISC')THEN
1618          CALL BIWSCA(DSS,NROWT,IWRITE,EF,ESP,MAXNXT,XSD,
1619     1                IBUGA3,IERROR)
1620        ELSEIF(ISTASC.EQ.'MAD ')THEN
1621          CALL MAD(DSS,NROWT,IWRITE,EF,ESP,MAXNXT,XSD,
1622     1             IBUGA3,IERROR)
1623        ELSEIF(ISTASC.EQ.'MADN')THEN
1624          CALL MAD(DSS,NROWT,IWRITE,EF,ESP,MAXNXT,XSD,
1625     1             IBUGA3,IERROR)
1626          XSD=XSD/0.67449
1627        ELSEIF(ISTASC.EQ.'AAD ')THEN
1628          CALL AAD(DSS,NROWT,IWRITE,EF,MAXNXT,XSD,'MEAN',
1629     1             IBUGA3,IERROR)
1630        ELSEIF(ISTASC.EQ.'IQRA')THEN
1631          CALL LOWQUA(DSS,NROWT,IWRITE,EF,MAXNXT,RIGH1,
1632     1                IBUGA3,IERROR)
1633          CALL UPPQUA(DSS,NROWT,IWRITE,EF,MAXNXT,RIGH2,
1634     1                IBUGA3,IERROR)
1635          XSD=RIGH2-RIGH1
1636        ELSEIF(ISTASC.EQ.'NIQR')THEN
1637          CALL LOWQUA(DSS,NROWT,IWRITE,EF,MAXNXT,RIGH1,
1638     1                IBUGA3,IERROR)
1639          CALL UPPQUA(DSS,NROWT,IWRITE,EF,MAXNXT,RIGH2,
1640     1                IBUGA3,IERROR)
1641          XSD=0.7413*(RIGH2-RIGH1)
1642        ELSEIF(ISTASC.EQ.'SNSC')THEN
1643          XSD=SN(DSS,NROWT,ESP,EF,RDRAW)
1644        ELSEIF(ISTASC.EQ.'MAXI')THEN
1645          CALL MINIM(DSS,NROWT,IWRITE,XMIN,IBUGA3,IERROR)
1646          CALL MAXIM(DSS,NROWT,IWRITE,XMAX,IBUGA3,IERROR)
1647          XSD=XMAX - XMIN
1648        ELSE
1649          CALL SD(DSS,NROWT,IWRITE,XMEAN,IBUGA3,IERROR)
1650        ENDIF
1651C
1652        IF(XSD.LE.0.0)THEN
1653          WRITE(ICOUT,91)
1654          CALL DPWRST('XXX','BUG ')
1655          WRITE(ICOUT,206)JJ
1656  206     FORMAT('       VARIABLE ',I4,' HAS ZERO STANDARD DEVIATION ',
1657     1           'WHEN SCALING REQUESTED.')
1658          CALL DPWRST('XXX','BUG ')
1659          IERROR='YES'
1660          GOTO9000
1661        ENDIF
1662        DO205II=1,NROW
1663          IF(X(II,JJ).NE.PSTAMV)THEN
1664            AVAL=(X(II,JJ)-XMEAN)/XSD
1665            X(II,JJ)=AVAL
1666          ENDIF
1667  205   CONTINUE
1668  201 CONTINUE
1669C
1670C
1671  299 CONTINUE
1672C
1673C     OPEN THE AUXILLARY FILES
1674C
1675      IOP='OPEN'
1676      IFLG11=1
1677      IFLG21=1
1678      IFLG31=1
1679      IFLAG4=0
1680      IFLAG5=0
1681      CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLAG4,IFLAG5,
1682     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
1683     1            IBUGA3,ISUBRO,IERROR)
1684      IFLAGO=1
1685      IF(IERROR.EQ.'YES')GOTO9000
1686C
1687C               ************************************
1688C               **   STEP 3--                     **
1689C               **   PERFORM THE CLUSTER ANALYSIS **
1690C               ************************************
1691C
1692C     THIS CODE IS A SOMEWHAT MODIFED VERSION OF CODE IN THE
1693C     FANNY MAIN ROUTINE.
1694C
1695      NN=NROW
1696      JPP=NCOL
1697C
1698      ISTEPN='3'
1699      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FAN2')THEN
1700        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1701        WRITE(ICOUT,169)NCLUST,NN,JPP,NDYST,LARGE,JDYSS
1702  169   FORMAT('NCLUST,NN,JPP,NDYST,LARGE,JDYSS = ',6I8)
1703        CALL DPWRST('XXX','BUG ')
1704      ENDIF
1705C
1706      IF(IPRINT.EQ.'ON')THEN
1707        WRITE(ICOUT,999)
1708        CALL DPWRST('XXX','BUG ')
1709        WRITE(ICOUT,999)
1710        CALL DPWRST('XXX','BUG ')
1711        WRITE(ICOUT,301)
1712  301   FORMAT(10X,'**********************************************')
1713        CALL DPWRST('XXX','BUG ')
1714        WRITE(ICOUT,302)
1715  302   FORMAT(10X,'*                                            *')
1716        CALL DPWRST('XXX','BUG ')
1717        WRITE(ICOUT,303)
1718  303   FORMAT(10X,'*  ROUSSEEUW/KAUFFMAN FUZZY CLUSTERING       *')
1719        CALL DPWRST('XXX','BUG ')
1720        WRITE(ICOUT,304)
1721  304   FORMAT(10X,'*  (USING THE FANNY ROUTINE).                *')
1722        CALL DPWRST('XXX','BUG ')
1723        WRITE(ICOUT,302)
1724        CALL DPWRST('XXX','BUG ')
1725        WRITE(ICOUT,301)
1726        CALL DPWRST('XXX','BUG ')
1727        WRITE(ICOUT,999)
1728        CALL DPWRST('XXX','BUG ')
1729      ENDIF
1730C
1731      IF(JDYSS.EQ.0)THEN
1732C
1733C       IF RAW DATA ENTERED, CREATE THE DISSIMILARITY MATRIX.
1734C
1735        CALL DYSTAF(NROW,NCOL,NROW,NCOL,X,DSS,NDYST,AMISS,JHALT,
1736     1              ISUBRO,IBUGA3)
1737        IF(JHALT.EQ.1)THEN
1738          WRITE(ICOUT,91)
1739          CALL DPWRST('XXX','BUG ')
1740          WRITE(ICOUT,870)
1741  870     FORMAT('       ERROR IN COMPUTING THE DISSSIMILARITY MATRIX.')
1742          CALL DPWRST('XXX','BUG ')
1743          IERROR='YES'
1744          GOTO9000
1745        ENDIF
1746C
1747      ELSE
1748C
1749C       IF DISSIMILARITY MATRIX ENTERED AS INPUT, COPY LOWER DIAGONAL
1750C       TO DSS.
1751C
1752C       NOTE THAT FANNY EXPECTS THE DISSSIMILARITIES IN COLUMN ORDER
1753C       (AGNES AND PAM EXPECT IT IN ROW ORDER)
1754C
1755        DO74II=1,MAXNXT
1756          DSS(II)=0.0
1757   74   CONTINUE
1758C
1759        ICNT=0
1760        DO71JJ=1,NCOL
1761          DO73II=JJ+1,NROW
1762            IF(X(II,JJ).LT.0.0)THEN
1763              WRITE(ICOUT,91)
1764              CALL DPWRST('XXX','BUG ')
1765              WRITE(ICOUT,872)II,JJ
1766  872         FORMAT('       ROW ',I5,' COLUMN ',I5,' OF THE ',
1767     1               'DISSIMILARITY MATRIX IS NON-POSITIVE.')
1768              CALL DPWRST('XXX','BUG ')
1769              IERROR='YES'
1770              GOTO9000
1771            ELSEIF(X(II,JJ).NE.X(JJ,II))THEN
1772              WRITE(ICOUT,91)
1773              CALL DPWRST('XXX','BUG ')
1774              WRITE(ICOUT,874)
1775  874         FORMAT('       THE DISSIMILARITY MATRIX IS NOT '
1776     1               'SYMMETRIC.')
1777              CALL DPWRST('XXX','BUG ')
1778              IERROR='YES'
1779              GOTO9000
1780            ENDIF
1781            ICNT=ICNT+1
1782            DSS(ICNT)=X(II,JJ)
1783   73     CONTINUE
1784   71   CONTINUE
1785      ENDIF
1786C
1787      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FAN2')THEN
1788        ISTEPN='2B'
1789        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1790        WRITE(ICOUT,76)
1791   76   FORMAT('AFTER CREATE DSS ARRAY:')
1792        CALL DPWRST('XXX','BUG ')
1793        DO78II=1,ICNT
1794          WRITE(ICOUT,79)II,DSS(II)
1795   79     FORMAT('II,DSS(II) = ',I5,F10.3)
1796          CALL DPWRST('XXX','BUG ')
1797   78   CONTINUE
1798      ENDIF
1799C
1800      IF(LARGE.EQ.2 .AND. IPRINT.EQ.'ON')THEN
1801        WRITE(ICOUT,999)
1802        CALL DPWRST('XXX','BUG ')
1803        WRITE(ICOUT,999)
1804        CALL DPWRST('XXX','BUG ')
1805        WRITE(ICOUT,9060)
1806 9060   FORMAT('DISSIMILARITY MATRIX')
1807        CALL DPWRST('XXX','BUG ')
1808        WRITE(ICOUT,9061)
1809 9061   FORMAT('--------------------')
1810        CALL DPWRST('XXX','BUG ')
1811        WRITE(ICOUT,999)
1812        CALL DPWRST('XXX','BUG ')
1813        LAB='001'
1814        WRITE(ICOUT,9033)LAB
1815 9033   FORMAT(A3,2X,8F9.2)
1816        CALL DPWRST('XXX','BUG ')
1817C
1818        DO 120 L=2,NN
1819          LSUBT=L-1
1820          JPEND=LSUBT
1821          IF(LSUBT.GT.8)JPEND=8
1822          DO 110 J=1,LSUBT
1823            NLJ=NN*(J-1)+L-(J*(J+1))/2
1824            DVEC(J)=DSS(NLJ)
1825  110     CONTINUE
1826          LAB='000'
1827          IF(L.LE.9)THEN
1828            WRITE(LAB(3:3),'(I1)')L
1829          ELSEIF(L.LE.99)THEN
1830            WRITE(LAB(2:3),'(I2)')L
1831          ELSE
1832            WRITE(LAB(1:3),'(I3)')L
1833          ENDIF
1834C
1835          WRITE(ICOUT,9033)LAB,(DVEC(J),J=1,JPEND)
1836          CALL DPWRST('XXX','BUG ')
1837          IF(LSUBT.GT.8)THEN
1838            WRITE(ICOUT,9040)(DVEC(J),J=9,LSUBT)
1839 9040       FORMAT(5X,8F9.2)
1840            CALL DPWRST('XXX','BUG ')
1841          ENDIF
1842  120   CONTINUE
1843      ENDIF
1844C
1845      S=0.0
1846      NHALF=NN*(NN-1)/2+1
1847      L=1
1848  130 CONTINUE
1849      L=L+1
1850      IF(DSS(L).GT.S)S=DSS(L)
1851      IF(L.LT.NHALF)GO TO 130
1852C
1853C     ORIGINAL FANNY CODE ALLOWS FOR SPECIFICATION OF MINIMUM AND
1854C     MAXIMUM VALUES FOR THE NUMBER OF CLUSTERS.  CURRENTLY, WE ONLY
1855C     IMPLEMENT FOR A SINGLE VALUE FOR THE NUMBER OF CLUSTERS.
1856C
1857      KBEG=NCLUST
1858      KEND=NCLUST
1859      DO 140 KK=KBEG,KEND
1860        IF(KK.GT.KBEG)THEN
1861          KMP=KK-1
1862CNIST     WRITE(ICOUT,9068)KMP,KK
1863C9068     FORMAT(' I am finished with',I3,' clusters, working on',I3)
1864        ENDIF
1865        IF(IPRINT.EQ.'ON')THEN
1866          WRITE(ICOUT,999)
1867          CALL DPWRST('XXX','BUG ')
1868          WRITE(ICOUT,9070)
1869 9070     FORMAT('********************************')
1870          CALL DPWRST('XXX','BUG ')
1871          WRITE(ICOUT,9071)KK
1872 9071     FORMAT('*  NUMBER OF CLUSTERS',I6,4X,'*')
1873          CALL DPWRST('XXX','BUG ')
1874          WRITE(ICOUT,9070)
1875          CALL DPWRST('XXX','BUG ')
1876        ENDIF
1877C
1878        CALL FUZZY(NROW,NROW,P,DP,PT,DSS,ESP,EF,EDA,EDB,KK,
1879     1             IBUGA3,ISUBRO)
1880C
1881        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FAN2')THEN
1882          WRITE(ICOUT,9077)
1883 9077     FORMAT('DPFAN2: BETWEEN FUZZY AND CADDY')
1884          CALL DPWRST('XXX','BUG ')
1885          DO9073II=1,NROW
1886            WRITE(ICOUT,9074)II,(P(II,JJ),JJ=1,MIN(KK,10))
1887 9074       FORMAT('II,(P(II,JJ),JJ=1,K) = ',I6,10G15.7)
1888            CALL DPWRST('XXX','BUG ')
1889 9073     CONTINUE
1890        ENDIF
1891C
1892        CALL CADDY(NROW,NROW,P,KK,KTRUE,
1893     1             NFUZZ,NCLUV,PT,NELEM,EDA,EDB,
1894     1             IOUNI1,IOUNI2,IBUGA3,ISUBRO)
1895C
1896CNIST   IF(LGRAP.GT.0 .AND. KTRUE.GT.1 .AND. KTRUE.LT.NN)THEN
1897CNIST     CALL FYGUR(KTRUE,NN,MAXNN,MAXKK,MAXHH,NCLUV,NSEND,NELEM,
1898CNIST1               NEGBR,SYL,DVEC,PT,DSS,S,NUM(11),NUM(12),NUM(13))
1899CNIST   ENDIF
1900C
1901  140 CONTINUE
1902C
1903C
1904C               *****************************************
1905C               **   STEP 4B--                         **
1906C               **   CREATE VALUES FOR SILHOUETTE PLOT **
1907C               *****************************************
1908C
1909      ISTEPN='4B'
1910      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FAN2')
1911     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1912C
1913C     COMPUTE THE s(i) VALUE AS
1914C
1915C        s(i) = (b(i) - a(i))/max{a(i),b(i)}
1916C
1917C     WHERE
1918C
1919C        a(i)   = AVERAGE DISSIMILARITY OF THE i-TH POINT WITH
1920C                 ALL OTHER POINTS IN THE CLUSTER TO WHICH IT
1921C                 BELONGS
1922C
1923C        b(i)   = LOWEST AVERAGE DISSIMILARITY OF THE i-TH POINT
1924C                 WITH ALL OTHER CLUSTERS.
1925C
1926C     USE ONE-PASS MEAN ALGORITHMS TO KEEP TRACK OF AVERAGE
1927C     DISSIMILARITY OF ALL CLUSTERS.  THE ONE-PASS FORMUALA IS
1928C
1929C         M(K)=X1                            K = 1
1930C             =M(K-1) + (X(K) - M(K-1))/K    K = 2, ...., N
1931C
1932      IF(JDYSS.EQ.1)THEN
1933C
1934C       CASE WHERE INPUT DATA IS A DISSIMILARITY MATRIX
1935C
1936        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FAN2')THEN
1937          WRITE(ICOUT,8111)NROW
1938 8111     FORMAT('DISSIMILARITY CASE: NROW = ',I5)
1939          CALL DPWRST('XXX','BUG ')
1940        ENDIF
1941C
1942        DO8110II=1,NROW
1943          ICLUS1=NCLUV(II)
1944C
1945          DO8114KK=1,NCLUST
1946            NFUZZ(KK)=0
1947 8114     CONTINUE
1948C
1949          DO8120JJ=1,NROW
1950            IF(II.EQ.JJ)GOTO8120
1951            ICLUS2=NCLUV(JJ)
1952            ADIST=X(II,JJ)
1953C
1954            IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FAN2')THEN
1955              WRITE(ICOUT,8117)II,JJ,ICLUS1,ICLUS2,ADIST
1956 8117         FORMAT('II,JJ,ICLUS1,ICLUS2,ADIST = ',4I5,G15.7)
1957              CALL DPWRST('XXX','BUG ')
1958            ENDIF
1959C
1960            IF(ICLUS1.EQ.ICLUS2)THEN
1961C
1962C             COMPUTE A(I) TERM
1963C
1964              NFUZZ(ICLUS1)=NFUZZ(ICLUS1)+1
1965              IF(NFUZZ(ICLUS1).EQ.1)THEN
1966                DVEC(ICLUS1)=ADIST
1967              ELSE
1968                TERM1=(ADIST - DVEC(ICLUS1))/REAL(NFUZZ(ICLUS1))
1969                DVEC(ICLUS1)=DVEC(ICLUS1) + TERM1
1970              ENDIF
1971            ELSE
1972              NFUZZ(ICLUS2)=NFUZZ(ICLUS2)+1
1973              IF(NFUZZ(ICLUS2).EQ.1)THEN
1974                DVEC(ICLUS2)=ADIST
1975              ELSE
1976                TERM1=(ADIST - DVEC(ICLUS2))/REAL(NFUZZ(ICLUS2))
1977                DVEC(ICLUS2)=DVEC(ICLUS2) + TERM1
1978              ENDIF
1979            ENDIF
1980 8120     CONTINUE
1981C
1982          AI=DVEC(ICLUS1)
1983          BI=CPUMAX
1984          DO8130JJ=1,NCLUST
1985            IF(JJ.EQ.ICLUS1)GOTO8130
1986            IF(DVEC(JJ).LT.BI)BI=DVEC(JJ)
1987 8130     CONTINUE
1988          SYL=0.0
1989          IF(AI.LT.BI)THEN
1990            SYL=1.0 - (AI/BI)
1991          ELSEIF(AI.GT.BI)THEN
1992            SYL=(BI/AI) - 1.0
1993          ENDIF
1994CCCCC     SYL=(BI - AI)/MAX(AI,BI)
1995C
1996          WRITE(IOUNI3,'(3E15.7)')REAL(II),REAL(NCLUV(II)),SYL
1997C
1998          IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FAN2')THEN
1999            WRITE(ICOUT,8131)II,NCLUV(II),AI,BI,SYL
2000 8131       FORMAT('II,NCLUV(II),AI,BI,SYL = ',2I6,3G15.7)
2001            CALL DPWRST('XXX','BUG ')
2002          ENDIF
2003C
2004 8110   CONTINUE
2005      ELSE
2006C
2007C       CASE WHERE INPUT DATA IS MEASUREMENT DATA
2008C
2009        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FAN2')THEN
2010          WRITE(ICOUT,8121)NROW
2011 8121     FORMAT('MEASUREMENT DATA CASE: NROW = ',I5)
2012          CALL DPWRST('XXX','BUG ')
2013        ENDIF
2014C
2015        DO8210II=1,NROW
2016          ICLUS1=NCLUV(II)
2017          DO8212JJ=1,NCOL
2018            RDRAW(JJ)=X(II,JJ)
2019 8212     CONTINUE
2020          ICASPL='VEDI'
2021          DO8214KK=1,NCLUST
2022            ESP(KK)=CPUMIN
2023            NFUZZ(KK)=0
2024 8214     CONTINUE
2025C
2026          DO8220JJ=1,NROW
2027            IF(II.EQ.JJ)GOTO8220
2028            ICLUS2=NCLUV(JJ)
2029            DO8222KK=1,NCOL
2030              ESP(KK)=X(JJ,KK)
2031 8222       CONTINUE
2032            CALL VECARI(RDRAW,ESP,NCOL,ICASPL,IWRITE,
2033     1                  EF,N3,ADIST,ITYP3,
2034     1                  IBUGA3,ISUBRO,IERROR)
2035            IF(ICLUS1.EQ.ICLUS2)THEN
2036              NFUZZ(ICLUS1)=NFUZZ(ICLUS1)+1
2037              IF(NFUZZ(ICLUS1).EQ.1)THEN
2038                DVEC(ICLUS1)=ADIST
2039              ELSE
2040                TERM1=(ADIST - DVEC(ICLUS1))/REAL(NFUZZ(ICLUS1))
2041                DVEC(ICLUS1)=DVEC(ICLUS1) + TERM1
2042              ENDIF
2043            ELSE
2044              NFUZZ(ICLUS2)=NFUZZ(ICLUS2)+1
2045              IF(NFUZZ(ICLUS2).EQ.1)THEN
2046                DVEC(ICLUS2)=ADIST
2047              ELSE
2048                TERM1=(ADIST - DVEC(ICLUS2))/REAL(NFUZZ(ICLUS2))
2049                DVEC(ICLUS2)=DVEC(ICLUS2) + TERM1
2050              ENDIF
2051            ENDIF
2052 8220     CONTINUE
2053C
2054          AI=DVEC(ICLUS1)
2055          BI=CPUMAX
2056          DO8230JJ=1,NCLUST
2057            IF(JJ.EQ.ICLUS1)GOTO8230
2058            IF(DVEC(JJ).LT.BI)BI=DVEC(JJ)
2059 8230     CONTINUE
2060          SYL=(BI - AI)/MAX(AI,BI)
2061          WRITE(IOUNI3,'(2E15.7)')REAL(NCLUV(II)),SYL
2062C
2063 8210   CONTINUE
2064      ENDIF
2065C
2066      IF(IFEEDB.EQ.'ON')THEN
2067        WRITE(ICOUT,999)
2068        CALL DPWRST('XXX','BUG ')
2069        WRITE(ICOUT,9450)
2070 9450   FORMAT('THIS RUN HAS BEEN SUCCESSFULLY COMPLETED.')
2071        CALL DPWRST('XXX','BUG ')
2072        WRITE(ICOUT,999)
2073        CALL DPWRST('XXX','BUG ')
2074        WRITE(ICOUT,8091)
2075 8091   FORMAT('THE FUZZY CLUSTERING PROBABILITIES ARE WRITTEN TO ',
2076     1         'dpst1f.dat')
2077        CALL DPWRST('XXX','BUG ')
2078        WRITE(ICOUT,8092)
2079 8092   FORMAT('THE CLUSTER ID VALUES FOR THE CLOSEST HARD CLUSTER ',
2080     1         'ARE WRITTEN TO dpst2f.dat')
2081        CALL DPWRST('XXX','BUG ')
2082        WRITE(ICOUT,8099)
2083 8099   FORMAT('THE SILHOUETTE VALUES FOR THE CLOSEST HARD CLUSTER ',
2084     1         'ARE WRITTEN TO dpst3f.dat')
2085        CALL DPWRST('XXX','BUG ')
2086      ENDIF
2087C
2088C               ******************
2089C               **   STEP 90--  **
2090C               **   EXIT       **
2091C               ******************
2092C
2093 9000 CONTINUE
2094C
2095      IF(IFLAGO.EQ.1)THEN
2096        IOP='CLOS'
2097        CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLAG4,IFLAG5,
2098     1              IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
2099     1              IBUGA3,ISUBRO,IERROR)
2100      ENDIF
2101C
2102      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FAN2')THEN
2103        WRITE(ICOUT,999)
2104        CALL DPWRST('XXX','BUG ')
2105        WRITE(ICOUT,9011)
2106 9011   FORMAT('***** AT THE END       OF DPFAN2--')
2107        CALL DPWRST('XXX','BUG ')
2108      ENDIF
2109C
2110      RETURN
2111      END
2112      SUBROUTINE DPFBEX(IFBNAM,IANGLU,ISEED,IFTEXP,IFTORD,IFORSW,
2113     1                  IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,
2114     1                  ISUBRO,IFOUND,IERROR)
2115C
2116C     PURPOSE--CARRY OUT A SUBSET OF THE LET COMMAND TO BE USED BY
2117C              THE "FUNCTION BLOCK".
2118C     WRITTEN BY--ALAN HECKERT
2119C                 STATISTICAL ENGINEERING DIVISION
2120C                 INFORMATION TECHNOLOGY LABOARATORY
2121C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
2122C                 GAITHERSBURG, MD 20899-8980
2123C                 PHONE--301-975-2899
2124C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
2125C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
2126C     LANGUAGE--ANSI FORTRAN (1977)
2127C     VERSION NUMBER--2015/8
2128C     ORIGINAL VERSION--AUGUST    2015.
2129C     UPDATED         --DECEMBER  2015.  LET ... = EXECUTE ...
2130C     UPDATED         --MARCH     2019.  CALL LIST TO DPNONP
2131C     UPDATED         --JULY      2019.  TWEAK SCRATCH STORAGE
2132C
2133C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
2134C
2135      CHARACTER*4 IFBNAM
2136      CHARACTER*4 IANGLU
2137      CHARACTER*4 IFTEXP
2138      CHARACTER*4 IFTORD
2139      CHARACTER*4 IFORSW
2140      CHARACTER*4 IBUGA2
2141      CHARACTER*4 IBUGA3
2142      CHARACTER*4 IBUGCO
2143      CHARACTER*4 IBUGEV
2144      CHARACTER*4 IBUGQ
2145      CHARACTER*4 ISUBRO
2146      CHARACTER*4 IFOUND
2147      CHARACTER*4 IERROR
2148C
2149      CHARACTER*4 ICASLE
2150      CHARACTER*4 ITYPEL
2151      CHARACTER*4 IFOUNZ
2152      CHARACTER*4 ITYPE
2153      CHARACTER*4 IHOL
2154      CHARACTER*4 IHOL2
2155      CHARACTER*4 IERRO1
2156      CHARACTER*4 ITYPEH
2157      CHARACTER*4 IW21HO
2158      CHARACTER*4 IW22HO
2159      CHARACTER*4 IA
2160      CHARACTER*4 IPARN
2161      CHARACTER*4 IPARN2
2162      CHARACTER*4 IFOUNR
2163      CHARACTER*4 IFOUN7
2164      CHARACTER*4 IFOUN8
2165      CHARACTER*4 ICASL7
2166      CHARACTER*4 ICASS7
2167      CHARACTER*4 ICASL8
2168      CHARACTER*4 ICASRA
2169      CHARACTER*4 ITYW1L
2170      CHARACTER*4 ICAT1L
2171      CHARACTER*4 INLI1L
2172      CHARACTER*4 ITYW2L
2173      CHARACTER*4 ITYW1R
2174      CHARACTER*4 ICAT1R
2175      CHARACTER*4 INLI1R
2176      CHARACTER*4 ITYW2R
2177      CHARACTER*4 IH
2178      CHARACTER*4 IH2
2179      CHARACTER*4 ISUBN1
2180      CHARACTER*4 ISUBN2
2181      CHARACTER*4 ICOMT
2182      CHARACTER*4 IMSUBC
2183      CHARACTER*4 ICASAR
2184      CHARACTER*1 IREPCH
2185C
2186C---------------------------------------------------------------------
2187C
2188      DIMENSION IFOUNZ(30)
2189      DIMENSION IBEGIN(30)
2190      DIMENSION IEND(30)
2191      DIMENSION ITYPE(30)
2192      DIMENSION IHOL(30)
2193      DIMENSION IHOL2(30)
2194      DIMENSION INT1(30)
2195      DIMENSION FLOAT1(30)
2196      DIMENSION IERRO1(30)
2197C
2198      DIMENSION ITYPEH(1000)
2199      DIMENSION IW21HO(1000)
2200      DIMENSION IW22HO(1000)
2201      DIMENSION W2HOLD(1000)
2202C
2203C     NOTE--THE DIMENSION OF IA SHOULD BE THE SAME AS
2204C           THE DIMENSION OF IB IN SUBROUTINE COMPIM
2205C           (THE DIMENSION OF IB IS 1000 (JULY 1986))
2206C
2207      DIMENSION IA(1000)
2208      DIMENSION PARAM(100)
2209      DIMENSION IPARN(100)
2210      DIMENSION IPARN2(100)
2211C
2212C-----COMMON----------------------------------------------------------
2213C
2214      INCLUDE 'DPCOPA.INC'
2215      INCLUDE 'DPCOHK.INC'
2216      INCLUDE 'DPCOFB.INC'
2217      INCLUDE 'DPCOHO.INC'
2218      INCLUDE 'DPCODA.INC'
2219C
2220      INCLUDE 'DPCOZI.INC'
2221      INCLUDE 'DPCOZ3.INC'
2222      INCLUDE 'DPCOZD.INC'
2223C
2224      DIMENSION TEMP1(MAXOBV)
2225      DIMENSION TEMP2(MAXOBV)
2226      DIMENSION TEMP3(MAXOBV)
2227      DIMENSION TEMP4(MAXOBV)
2228      DIMENSION TEMP5(MAXOBV)
2229      DIMENSION TEMP6(MAXOBV)
2230      INTEGER ITEMP1(MAXOBV)
2231      INTEGER ITEMP2(MAXOBV)
2232      INTEGER ITEMP3(MAXOBV)
2233      INTEGER ITEMP4(MAXOBV)
2234      INTEGER ITEMP5(MAXOBV)
2235      INTEGER ITEMP6(MAXOBV)
2236C
2237      EQUIVALENCE (G3RBAG(KGARB1),TEMP1(1))
2238      EQUIVALENCE (G3RBAG(KGARB2),TEMP2(1))
2239      EQUIVALENCE (G3RBAG(KGARB3),TEMP3(1))
2240      EQUIVALENCE (G3RBAG(KGARB4),TEMP4(1))
2241      EQUIVALENCE (G3RBAG(KGARB5),TEMP5(1))
2242      EQUIVALENCE (G3RBAG(KGARB6),TEMP6(1))
2243C
2244      EQUIVALENCE (IGARBG(IIGR12),ITEMP1(1))
2245      EQUIVALENCE (IGARBG(IIGR13),ITEMP2(1))
2246      EQUIVALENCE (IGARBG(IIGR14),ITEMP3(1))
2247      EQUIVALENCE (IGARBG(IIGR15),ITEMP4(1))
2248      EQUIVALENCE (IGARBG(IIGR16),ITEMP5(1))
2249      EQUIVALENCE (IGARBG(IIGR17),ITEMP6(1))
2250C
2251      DOUBLE PRECISION DTEMP1(MAXOBV)
2252      DOUBLE PRECISION DTEMP2(MAXOBV)
2253      DOUBLE PRECISION DTEMP3(MAXOBV)
2254      EQUIVALENCE (DGARBG(IDGAR8),DTEMP1(1))
2255      EQUIVALENCE (DGARBG(IDGAR9),DTEMP2(1))
2256      EQUIVALENCE (DGARBG(IDGA10),DTEMP3(1))
2257C
2258      CHARACTER*4 IANSSV(MAXSTR)
2259C
2260C-----COMMON VARIABLES (GENERAL)--------------------------------------
2261C
2262      INCLUDE 'DPCOP2.INC'
2263C
2264C-----START POINT-----------------------------------------------------
2265C
2266      ISUBN1='DPFB'
2267      ISUBN2='EX  '
2268      IERROR='NO'
2269      ICASLE='UNKN'
2270      IMSUBC='UNKN'
2271      IREPCH='^'
2272C
2273      MAXCP1=MAXCOL+1
2274      MAXCP2=MAXCOL+2
2275      MAXCP3=MAXCOL+3
2276      MAXCP4=MAXCOL+4
2277      MAXCP5=MAXCOL+5
2278      MAXCP6=MAXCOL+6
2279C
2280      DO40I=1,1000
2281        ITYPEH(I)='    '
2282        IW21HO(I)='    '
2283        IW22HO(I)='    '
2284        W2HOLD(I)=0.0
2285   40 CONTINUE
2286C
2287C               *************************************
2288C               **  TREAT THE FUNCTION BLOCK CASE  **
2289C               *************************************
2290C
2291      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FBEX')THEN
2292        WRITE(ICOUT,51)
2293   51   FORMAT('***** AT THE BEGINNING OF DPFBEX--')
2294        CALL DPWRST('XXX','BUG ')
2295        WRITE(ICOUT,52)IFBNAM,IANGLU,IFTEXP,IFORSW,ISEED
2296   52   FORMAT('IFBNAM,IANGLU,IFTEXP,IFORSW,ISEED, = ',
2297     1         A8,2X,3(A4,2X),I8)
2298        CALL DPWRST('XXX','BUG ')
2299        WRITE(ICOUT,53)IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ
2300   53   FORMAT('IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ = ',4(A4,2X),A4)
2301        CALL DPWRST('XXX','BUG ')
2302        WRITE(ICOUT,55)IFBNA1,IFBNA2,IFBNA3
2303   55   FORMAT('IFBNA1,IFBNA2,IFBNA3 = ',2(A8,2X),A8)
2304        CALL DPWRST('XXX','BUG ')
2305        WRITE(ICOUT,57)IFBCN1,IFBCN2,IFBCN3
2306   57   FORMAT('IFBCN1,IFBCN2,IFBCN3 = ',3I8)
2307        CALL DPWRST('XXX','BUG ')
2308      ENDIF
2309C
2310C               ******************************************
2311C               **  STEP 1--                            **
2312C               **  CHECK IF FUNCTION BLOCK IS DEFINED  **
2313C               ******************************************
2314C
2315      IFLAG=0
2316      IF(IFBNAM.EQ.IFBNA1)THEN
2317        IFLAG=1
2318        IFBCNT=IFBCN1
2319        IFBCN2=IFBCP1
2320      ELSEIF(IFBNAM.EQ.IFBNA2)THEN
2321        IFLAG=2
2322        IFBCNT=IFBCN2
2323        IFBCN2=IFBCP2
2324      ELSEIF(IFBNAM.EQ.IFBNA3)THEN
2325        IFLAG=3
2326        IFBCNT=IFBCN3
2327        IFBCN2=IFBCP3
2328      ELSE
2329        WRITE(ICOUT,999)
2330  999   FORMAT(1X)
2331        CALL DPWRST('XXX','BUG ')
2332        WRITE(ICOUT,101)
2333  101   FORMAT('***** ERROR IN FUNCTION BLOCK--')
2334        CALL DPWRST('XXX','BUG ')
2335        WRITE(ICOUT,102)IFBNAM
2336  102   FORMAT('      FUNCTION BLOCK ',A8,' HAS NOT BEEN DEFINED.')
2337        CALL DPWRST('XXX','BUG ')
2338        IERROR='YES'
2339        GOTO9000
2340      ENDIF
2341C
2342      IF(IFBCNT.LT.1)THEN
2343        WRITE(ICOUT,999)
2344        CALL DPWRST('XXX','BUG ')
2345        WRITE(ICOUT,101)
2346        CALL DPWRST('XXX','BUG ')
2347        WRITE(ICOUT,112)IFBNAM
2348  112   FORMAT('      FUNCTION BLOCK ',A8,' HAS NO ACTIVE COMMANDS.')
2349        CALL DPWRST('XXX','BUG ')
2350        IERROR='YES'
2351        GOTO9000
2352      ENDIF
2353C
2354C     SAVE CURRENT COMMAND LINE
2355C
2356      DO910II=1,MAXSTR
2357        IANSSV(II)=IANSLC(II)
2358  910 CONTINUE
2359C
2360C     LOOP THROUGH EACH LINE OF THE FUNCTION BLOCK
2361C
2362      DO1000KK=1,IFBCNT
2363C
2364C       STEP 1: PUT THE FUNCTION BLOCK LINE INTO IANSLC
2365C
2366        IF(IFLAG.EQ.1)THEN
2367          DO1010II=1,256
2368            IANSLC(II)=' '
2369            IANSLC(II)(1:1)=IFBLI1(KK)(II:II)
2370 1010     CONTINUE
2371        ELSEIF(IFLAG.EQ.2)THEN
2372          DO1020II=1,256
2373            IANSLC(II)=' '
2374            IANSLC(II)(1:1)=IFBLI2(KK)(II:II)
2375 1020     CONTINUE
2376        ELSEIF(IFLAG.EQ.3)THEN
2377          DO1030II=1,256
2378            IANSLC(II)=' '
2379            IANSLC(II)(1:1)=IFBLI3(KK)(II:II)
2380 1030     CONTINUE
2381        ENDIF
2382C
2383        IWIDTH=1
2384        DO1040II=MAXSTR,1,-1
2385          IF(IANSLC(II)(1:1).NE.' ')THEN
2386            IWIDTH=II
2387            GOTO1049
2388          ENDIF
2389 1040   CONTINUE
2390 1049   CONTINUE
2391C
2392        IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FBEX')THEN
2393          WRITE(ICOUT,1051)KK,IWIDTH
2394 1051     FORMAT('KK,IWIDTH = ',2I8)
2395          CALL DPWRST('XXX','BUG ')
2396          DO1053II=1,IWIDTH
2397            WRITE(ICOUT,1054)II,IANSLC(II)
2398 1054       FORMAT('II,IANSLC(II) = ',I5,2X,A4)
2399            CALL DPWRST('XXX','BUG ')
2400 1053     CONTINUE
2401        ENDIF
2402C
2403C       STEP 2: NOW PROCESS IANSLC TO BREAK IT INTO COMPONENT ARGUMENTS
2404C
2405        CALL DPNONP(IANSLC,IWIDTH,IANSLC,IBUGA2,ISUBRO,IERROR)
2406        CALL DPREP2(IANSLC,IWIDTH,
2407     1              IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,
2408     1              IVARLB,IROWLB,MAXOBV,
2409     1              IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,IMALEV,
2410     1              IBUGA2,ISUBRO,IERROR)
2411        CALL DPUPPE(IANSLC,IWIDTH,IANS,IBUGA2,IERROR)
2412        CALL DPTYPE(IANSLC,IWIDTH,IBUGA2,
2413     1              ICOM,ICOM2,ICOMT,ICOMI,ACOM,ICOMLC,ICOML2,
2414     1              IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,
2415     1              IHARG,IHARG2,IARGT,IARG,ARG,IHARLC,IHARL2,NUMARG,
2416     1              IHOST1,IHOST2)
2417C
2418        IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FBEX')THEN
2419          WRITE(ICOUT,1061)NUMARG
2420 1061     FORMAT('NUMARG = ',I8)
2421          CALL DPWRST('XXX','BUG ')
2422          DO1063II=1,NUMARG
2423            WRITE(ICOUT,1064)II,IHARG(II),IHARG2(II)
2424 1064       FORMAT('II,IHARG(II),IHARG2(II) = ',I5,2(2X,A4))
2425            CALL DPWRST('XXX','BUG ')
2426 1063     CONTINUE
2427        ENDIF
2428C
2429C       STEP 3: NOW PROCESS THE LET COMMANDS
2430C
2431C               CHECK FOR AN "=" SIGN (THIS SHOULD NOT BE LAST
2432C               ARGUMENT IN LIST)
2433C
2434        DO1103I=1,NUMARG
2435          IF(IHARG(I).EQ.'=   ')THEN
2436            IF(I.LT.NUMARG)GOTO1119
2437            WRITE(ICOUT,999)
2438            CALL DPWRST('XXX','BUG ')
2439            WRITE(ICOUT,101)
2440            CALL DPWRST('XXX','BUG ')
2441            WRITE(ICOUT,1112)
2442 1112       FORMAT('      IMPROPER FORM FOR THE    LET   COMMAND.')
2443            CALL DPWRST('XXX','BUG ')
2444            WRITE(ICOUT,1123)
2445 1123       FORMAT('      NOTHING FOUND TO THE RIGHT OF THE EQUAL SIGN')
2446            CALL DPWRST('XXX','BUG ')
2447            WRITE(ICOUT,1114)
2448            CALL DPWRST('XXX','BUG ')
2449            IF(IWIDTH.GE.1)THEN
2450              WRITE(ICOUT,1115)(IANSLC(JJ),JJ=1,MIN(120,IWIDTH))
2451              CALL DPWRST('XXX','BUG ')
2452            ENDIF
2453            IERROR='YES'
2454            GOTO9000
2455          ENDIF
2456 1103   CONTINUE
2457C
2458        WRITE(ICOUT,999)
2459        CALL DPWRST('XXX','BUG ')
2460        WRITE(ICOUT,101)
2461        CALL DPWRST('XXX','BUG ')
2462        WRITE(ICOUT,1112)
2463        CALL DPWRST('XXX','BUG ')
2464        WRITE(ICOUT,1113)
2465 1113   FORMAT('      NO EQUAL SIGN FOUND AFTER THE ',
2466     1         'VARIABLE/PARAMETER NAME.')
2467        CALL DPWRST('XXX','BUG ')
2468        WRITE(ICOUT,1114)
2469 1114   FORMAT('      THE ENTERED COMMAND LINE IS AS FOLLOWS--')
2470        CALL DPWRST('XXX','BUG ')
2471        IF(IWIDTH.GE.1)THEN
2472          WRITE(ICOUT,1115)(IANSLC(I),I=1,MIN(120,IWIDTH))
2473 1115     FORMAT('      ',120A1)
2474          CALL DPWRST('XXX','BUG ')
2475        ENDIF
2476        IERROR='YES'
2477        GOTO9000
2478C
2479 1119   CONTINUE
2480C
2481C               **************************************
2482C               **  STEP 2--                        **
2483C               **  TREAT THE VARIOUS LET SUBCASES  **
2484C               **************************************
2485C
2486C      CURRENTLY, FUNCTION BLOCKS ARE SUPPORTED BY THE FOLLOWING
2487C      COMMANDS:
2488C
2489C         1. PLOT FUNCTION
2490C         2. 3D-PLOT FUNCTION
2491C         3. LET ... = ROOTS ...
2492C         4. LET ... = OPTIMIZE ...
2493C         5. LET ... = INTEGRAL ...
2494C         6. LET ... = NUMERICAL DERIVATIVE ...
2495C
2496C      THE FOLLOWING COMMANDS THAT PERFORM FUNCTION EVALUATIONS ARE
2497C      NOT YET SUPPORTED:
2498C
2499C         1. ORTHOGONAL DISTANCE FIT ...
2500C         2. FIT Y = ...  (NON-LINEAR FIT)
2501C         3. PRE-FIT ...
2502C         4. LET ... = RUNGE KUTTA ...
2503C         5. LET ... = DERIVATIVE ...
2504C         6. LET ... = RECURSIVE FUNCTION ...  (COMMAND NOT IMPLEMENTED)
2505C
2506C      OF THESE, THE DERIVATIVE COMMAND WILL NOT BE IMPLEMNTED (FOR
2507C      FUNCTION BLOCKS, THE NUMERICAL DERIVATIVE CAN BE USED).  THE
2508C      OTHER COMMANDS WILL BE UPDATED TO SUPPORT FUNCTION BLOCKS.
2509C
2510C      CURRENTLY, RESTRICT TO:
2511C
2512C         1. PATTERN/DATA
2513C         2. RANDOM NUMBERS
2514C         3. MATH LET SUB-COMMANDS (BUT NOT MATRIX COMMANDS)
2515C         4. STATISTICS LET SUB-COMMANDS
2516C         5. ARITHMETIC OPERATIONS
2517C         6. LET ... = EXECUTE ...
2518C
2519C            NOTE THAT FOLLOWING MATH LET SUB-COMMANDS ARE NOT
2520C            HANDLED IN DPMATC AND ARE NOT SUPPORTED IN FUNCTION
2521C            BLOCKS:
2522C
2523C                 A. DERIVATIVE
2524C                 B. NUMERICAL DERIVATIVE
2525C                 C. INTEGRAL
2526C                 D. RUNGE-KUTTA
2527C                 E. OPTIMIZE
2528C                 F. ROOTS
2529C
2530C
2531C            THE ABOVE EITHER SUPPORT FUNCTION BLOCKS OR IT IS
2532C            PLANNED TO SUPPORT FUNCTIONS BLOCKS, SO THERE IS A
2533C            BIT OF CIRCULARITY IN TRYING TO INCLUDE THEM.
2534C
2535C
2536C               ********************************************
2537C               **  STEP 2.12--                           **
2538C               **  TREAT THE PATTERN GENERATION SUBCASE  **
2539C               ********************************************
2540C
2541      IF((IHARG(3).EQ.'PATT'.AND.IHARG2(3).EQ.'ERN ') .OR.
2542     1   (IHARG(3).EQ.'DATA'.AND.IHARG2(3).EQ.'    '))THEN
2543        IF(IHARG(1).EQ.'PLOT' .AND.
2544     1    (IHARG(2).EQ.'CHAR' .OR. IHARG(2).EQ.'LINE' .OR.
2545     1    IHARG(2).EQ.'SPIK' .OR. IHARG(2).EQ.'REGI' .OR.
2546     1    IHARG(2).EQ.'BAR'))GOTO1290
2547        ICASLE='PATT'
2548        CALL DPPAT(IBUGA3,IBUGQ,IFOUND,IERROR)
2549      ENDIF
2550C
2551 1290 CONTINUE
2552C
2553C               **************************************************
2554C               **  STEP 2.13--                                 **
2555C               **  TREAT THE RANDOM NUMBER GENERATION SUBCASE  **
2556C               **  (AND THE RANDOM PERMUTATION SUBCASE)        **
2557C               **  (AND THE BOOTSTRAP INDEX SUBCASE == THE     **
2558C               **  DISCRETE UNIFORM RANDOM NUMBER SUBCASE)     **
2559C               **************************************************
2560C
2561      CALL CKRAND(ICASRA,ILOCNU,NUMSHA,
2562     1            SHAPE1,SHAPE2,SHAPE3,SHAPE4,
2563     1            SHAPE5,SHAPE6,SHAPE7,
2564     1            IBUGA3,ISUBRO,IFOUNR,IERROR)
2565      IF(IFOUNR.EQ.'YES')THEN
2566        ICASLE='RAND'
2567        CALL DPRAND(ICASRA,ISEED,ILOCNU,NUMSHA,
2568     1              SHAPE1,SHAPE2,SHAPE3,SHAPE4,
2569     1              SHAPE5,SHAPE6,SHAPE7,
2570     1              IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
2571        GOTO9000
2572      ENDIF
2573C
2574C               **********************************************
2575C               **  STEP 2.20--                             **
2576C               **  TREAT THE MATH CALCULATIONS SUBCASE     **
2577C               **   (INPUT = A VECTOR; OUTPUT = A VECTOR)  **
2578C               **********************************************
2579C
2580C
2581        IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FBEX')THEN
2582          WRITE(ICOUT,2001)
2583 2001     FORMAT('BEFORE CALL CKMATH')
2584          CALL DPWRST('XXX','BUG ')
2585        ENDIF
2586C
2587C        MATH LET SUBCOMMANDS.
2588C
2589        CALL CKMATH(IBUGA3,ISUBRO,IFOUN7,ICASL7,ICASS7,ISTANR,
2590     1              IMSUBC,ILOCV)
2591        IF(IFOUN7.EQ.'YES'.AND.ICASL7.NE.'UNKN'.AND.
2592     1     ILOCV.GE.1)THEN
2593          ICASLE='MANI'
2594          IFOUND='NO'
2595          CALL DPMATC(ICASL7,ICASS7,ISTANR,ILOCV,IFTEXP,IFTORD,ISEED,
2596     1                IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
2597          IF(IFOUND.EQ.'YES')GOTO1000
2598C
2599C         DON'T SUPPORT MATRIX CALLS AS THESE MAY HAVE
2600C         POTENTIAL CONFLICTS WITH SCRATCH STORAGE.
2601C
2602CCCCC     CALL DPMAT2(ICASL7,ICASS7,ILOCV,
2603CCCCC1                ISEED,IMSUBC,
2604CCCCC1                IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
2605          GOTO1000
2606        ENDIF
2607C
2608C               **************************************************
2609C               **  STEP 2.41--                                 **
2610C               **  TREAT THE STATISTICAL CALCULATIONS SUBCASE  **
2611C               **  (INPUT = A VECTOR; OUTPUT = A PARAMETER)    **
2612C               **************************************************
2613C
2614        CALL DPTYP2(IANS,IWIDTH,IHNAME,IHNAM2,NUMNAM,MAXNAM,IBUGA3,
2615     1             IUSE,IVALUE,VALUE,IN,
2616     1             IFOUNZ,IBEGIN,IEND,
2617     1             ITYPE,IHOL,IHOL2,INT1,FLOAT1,IERRO1,
2618     1             NUMCL,NUMPL,NUMAOL,ITYW1L,ICAT1L,INLI1L,ITYW2L,
2619     1             NUMCR,NUMPR,NUMAOR,ITYW1R,ICAT1R,INLI1R,ITYW2R)
2620C
2621        IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FBEX')THEN
2622          WRITE(ICOUT,3091)
2623 3091     FORMAT('BEFORE CALL CKARIT')
2624          CALL DPWRST('XXX','BUG ')
2625        ENDIF
2626C
2627        CALL CKARIT(IFOUNZ,IBEGIN,IANS,IWIDTH,ICASAR,IBUGA3,ISUBRO)
2628C
2629        IF(NUMARG.GE.3 .AND.
2630     1    (IHARG(3).EQ.'SN- ' .OR. IHARG(3).EQ.'SN+ '))ICASAR='NO'
2631        IF(NUMARG.GE.4 .AND. IHARG(3).EQ.'TAGU' .AND.
2632     1    (IHARG(4).EQ.'SN- ' .OR. IHARG(4).EQ.'SN+ '))ICASAR='NO'
2633        IF(NUMARG.GE.6 .AND. IHARG(3).EQ.'CHI ' .AND.
2634     1     IHARG(4).EQ.'SQUA'.AND. IHARG(5).EQ.'SD  ' .AND.
2635     1     IHARG(6).EQ.'TEST')ICASAR='NO'
2636        IF(NUMARG.GE.6 .AND. IHARG(3).EQ.'ONE '.AND.
2637     1     IHARG(4).EQ.'SAMP' .AND. IHARG(5).EQ.'T   ' .AND.
2638     1     IHARG(6).EQ.'TEST')ICASAR='NO'
2639        IF(NUMARG.GE.7 .AND. IHARG(3).EQ.'CHI ' .AND.
2640     1     IHARG(4).EQ.'SQUA' .AND. IHARG(5).EQ.'STAN' .AND.
2641     1     IHARG(6).EQ.'DEVI' .AND. IHARG(7).EQ.'TEST')ICASAR='NO'
2642        IF(NUMARG.GE.4 .AND. IHARG(3).EQ.'HODG' .AND.
2643     1     IHARG(4).EQ.'LEHM')ICASAR='NO'
2644        IF(NUMARG.GE.6 .AND. IHARG(5).EQ.'HODG' .AND.
2645     1     IHARG(6).EQ.'LEHM')ICASAR='NO'
2646C
2647        IF(ICASAR.EQ.'NO')THEN
2648C
2649          IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FBEX')THEN
2650            WRITE(ICOUT,4001)
2651 4001       FORMAT('BEFORE CALL CKSTAT')
2652            CALL DPWRST('XXX','BUG ')
2653          ENDIF
2654C
2655          CALL CKSTAT(IBUGA3,IFOUN8,ICASL8,ILOCV,ISTANR)
2656          IF(IFOUN8.EQ.'YES'.AND.ICASL8.NE.'UNKN'.AND.
2657     1       ILOCV.GE.1)THEN
2658            ICASLE='STAT'
2659            CALL DPSTAC(ICASL8,ILOCV,ISTANR,
2660     1                  IFOUNZ,IBEGIN,IEND,ITYPE,IHOL,IHOL2,INT1,
2661     1                  FLOAT1,IERRO1,
2662     1                  TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,TEMP6,MAXOBV,
2663     1                  ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
2664     1                  DTEMP1,DTEMP2,DTEMP3,
2665     1                  IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
2666            GOTO1000
2667          ENDIF
2668        ENDIF
2669C
2670C               **********************************************
2671C               **  STEP 2.19A--                            **
2672C               **  TREAT THE EXECUTE              SUBCASE  **
2673C               **********************************************
2674C
2675      IF(IHARG(2).EQ.'=   '.AND.IHARG(3).EQ.'EXEC')THEN
2676        ICASLE='EXEC'
2677        IFOUND='YES'
2678        ITYPEL='V'
2679C
2680C       EXTRACT CURRENT PARAMETER LIST FOR FUNCTION BLOCK
2681C
2682        ICNT=0
2683        DO2190K=1,IFBCN2
2684          IH='    '
2685          IH2='    '
2686          IF(IFLAG.EQ.1)THEN
2687            IH=IFBPL1(K)(1:4)
2688            IH2=IFBPL1(K)(5:8)
2689          ELSEIF(IFLAG.EQ.2)THEN
2690            IH=IFBPL2(K)(1:4)
2691            IH2=IFBPL2(K)(5:8)
2692          ELSEIF(IFLAG.EQ.3)THEN
2693            IH=IFBPL3(K)(1:4)
2694            IH2=IFBPL3(K)(5:8)
2695          ENDIF
2696C
2697          DO2195II=1,NUMNAM
2698            IF(IH.EQ.IHNAME(II) .AND. IH2.EQ.IHNAM2(II) .AND.
2699     1         IUSE(II).EQ.'P')THEN
2700              ICNT=ICNT+1
2701              TEMP1(ICNT)=VALUE(II)
2702              GOTO2190
2703            ENDIF
2704 2195     CONTINUE
2705 2190     CONTINUE
2706C
2707        CALL DPEXFI(TEMP1,ICNT,IBUGA3,ISUBRO,IFOUND,IERROR)
2708        GOTO1000
2709      ENDIF
2710C
2711C               *********************************************
2712C               **  STEP 2.50--                            **
2713C               **  TREAT THE FUNCTION EVALUATION SUBCASE  **
2714C               *********************************************
2715C
2716C       DON'T SUPPORT THIS AS IT IS MORE USEFUL TO CALL DPFBEX FROM
2717C       DPFUEV (I.E., ALLOW FUNCTION EVALUATION TO HANDLE FUNCTION
2718C       BLOCKS).
2719C
2720        IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FBEX')THEN
2721          WRITE(ICOUT,5001)
2722 5001     FORMAT('BEFORE CALL DPFUEV')
2723          CALL DPWRST('XXX','BUG ')
2724        ENDIF
2725C
2726        ICASLE='FUNC'
2727        CALL DPFUEV(ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,
2728     1              IA,PARAM,IPARN,IPARN2,
2729     1              IFOUNZ,IBEGIN,IEND,ITYPE,IHOL,IHOL2,INT1,
2730     1              FLOAT1,IERRO1,
2731     1              NUMCL,NUMPL,NUMAOL,ITYW1L,ICAT1L,INLI1L,ITYW2L,
2732     1              NUMCR,NUMPR,NUMAOR,ITYW1R,ICAT1R,INLI1R,ITYW2R,
2733     1              IANGLU,
2734     1              IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO,IFOUND,IERROR)
2735        IF(IFOUND.EQ.'YES')GOTO1000
2736C
2737C       ADMISSABLE LET COMMAND NOT FOUND
2738C
2739        WRITE(ICOUT,999)
2740        CALL DPWRST('XXX','BUG ')
2741        WRITE(ICOUT,101)
2742        CALL DPWRST('XXX','BUG ')
2743        WRITE(ICOUT,6001)
2744 6001   FORMAT('      COMMAND IS NOT SUPPORTED IN FUNCTION BLOCK')
2745        IERROR='YES'
2746        GOTO9000
2747C
2748 1000 CONTINUE
2749C
2750C
2751C               **************************************
2752C               **  STEP 3--                        **
2753C               **  RESET ORIGINAL COMMAND LINE     **
2754C               **************************************
2755      DO7010II=1,MAXSTR
2756        IANSLC(II)=IANSSV(II)
2757 7010 CONTINUE
2758C
2759      CALL DPNONP(IANSLC,IWIDTH,IANSLC,IBUGA2,ISUBRO,IERROR)
2760      CALL DPREP2(IANSLC,IWIDTH,
2761     1            IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,
2762     1            IVARLB,IROWLB,MAXOBV,
2763     1            IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,IMALEV,
2764     1            IBUGA2,ISUBRO,IERROR)
2765      CALL DPUPPE(IANSLC,IWIDTH,IANS,IBUGA2,IERROR)
2766      CALL DPTYPE(IANSLC,IWIDTH,IBUGA2,
2767     1            ICOM,ICOM2,ICOMT,ICOMI,ACOM,ICOMLC,ICOML2,
2768     1            IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,
2769     1            IHARG,IHARG2,IARGT,IARG,ARG,IHARLC,IHARL2,NUMARG,
2770     1            IHOST1,IHOST2)
2771C
2772C               *****************
2773C               **  STEP 90--  **
2774C               **  EXIT       **
2775C               *****************
2776C
2777 9000 CONTINUE
2778      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FBEX')THEN
2779        WRITE(ICOUT,999)
2780        CALL DPWRST('XXX','BUG ')
2781        WRITE(ICOUT,9011)
2782 9011   FORMAT('***** AT THE END       OF DPFBEX--')
2783        CALL DPWRST('XXX','BUG ')
2784        WRITE(ICOUT,9016)ICASLE,IMSUBC
2785 9016   FORMAT('ICASLE,IMSUBC = ',A4,2X,A4)
2786        CALL DPWRST('XXX','BUG ')
2787        WRITE(ICOUT,9017)IFOUND,IERROR
2788 9017   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
2789        CALL DPWRST('XXX','BUG ')
2790      ENDIF
2791C
2792      RETURN
2793      END
2794      SUBROUTINE DPFEED(IHARG,NUMARG,
2795     1IFEED2,IFOUND,IERROR)
2796C
2797C     PURPOSE--SPECIFY THE FEEDBACK SWITCH WHICH IN TURN
2798C              DETERMINES WHETHER ANY SUBSEQUENT FEEDBACK OUTPUT
2799C              (LIKE, SAY, FROM A SUBSET SPECIFICATION)
2800C              WILL BE PRINTED OR NOT.
2801C              THIS CAPABILITY IS USEFUL IF ONE WISHES TO SUPPRESS
2802C              FEEDBACK OUTPUT FROM ALL SWITCH SETTING COMMANDS
2803C              SO AS TO NOT CLUTTER UP THE SCREEN
2804C              IN FORMING (FOR EXAMPLE) DIAGRAMMATIC GRAPHICS.
2805C              THE SPECIFIED FEEDBACK SWITCH SPECIFICATION
2806C              WILL BE PLACED IN THE HOLLERITH VARIABLE IFEED2.
2807C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
2808C                     --NUMARG (AN INTEGER VARIABLE)
2809C     OUTPUT ARGUMENTS--IFEED2 (A HOLLERITH VARIABLE)
2810C                     --IFOUND ('YES' OR 'NO' )
2811C                     --IERROR ('YES' OR 'NO' )
2812C     WRITTEN BY--JAMES J. FILLIBEN
2813C                 STATISTICAL ENGINEERING DIVISION
2814C                 INFORMATION TECHNOLOGY LABORATORY
2815C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
2816C                 GAITHERSBURG, MD 20899-8980
2817C                 PHONE--301-975-2855
2818C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
2819C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
2820C     LANGUAGE--ANSI FORTRAN (1977)
2821C     VERSION NUMBER--82/7
2822C     ORIGINAL VERSION--MAY       1981.
2823C     UPDATED         --MAY       1982.
2824C     UPDATED         --JANUARY   2009. ADD "SAVE/RESTORE" OPTION
2825C
2826C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
2827C
2828      CHARACTER*4 IHARG
2829      CHARACTER*4 IFEED2
2830      CHARACTER*4 IFOUND
2831      CHARACTER*4 IERROR
2832C
2833      CHARACTER*4 IHOLD
2834C
2835C---------------------------------------------------------------------
2836C
2837      DIMENSION IHARG(*)
2838C
2839      CHARACTER*4 IFEESV
2840      COMMON/IFEED/IFEESV
2841C
2842C---------------------------------------------------------------------
2843C
2844      INCLUDE 'DPCOP2.INC'
2845C
2846C-----START POINT-----------------------------------------------------
2847C
2848      IFOUND='NO'
2849      IERROR='NO'
2850C
2851      IF(NUMARG.LE.0)GOTO1150
2852      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
2853      IF(IHARG(NUMARG).EQ.'OFF')GOTO1160
2854      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
2855      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
2856      IF(IHARG(NUMARG).EQ.'SAVE')GOTO1170
2857      IF(IHARG(NUMARG).EQ.'REST')GOTO1175
2858      GOTO1199
2859C
2860 1150 CONTINUE
2861      IHOLD='ON'
2862      GOTO1180
2863C
2864 1160 CONTINUE
2865      IHOLD='OFF'
2866      GOTO1180
2867C
2868 1170 CONTINUE
2869      IFOUND='YES'
2870      IFEESV=IFEEDB
2871      GOTO1199
2872C
2873 1175 CONTINUE
2874      IFOUND='YES'
2875      IFEEDB=IFEESV
2876      GOTO1199
2877C
2878 1180 CONTINUE
2879      IFOUND='YES'
2880      IFEED2=IHOLD
2881      IFEEDB=IFEED2
2882C
2883CCCCC GOTO1189
2884CCCCC IF(IFEEDB.EQ.'OFF')GOTO1189
2885CCCCC WRITE(ICOUT,999)
2886CC999 FORMAT(1X)
2887CCCCC CALL DPWRST('XXX','BUG ')
2888CCCCC WRITE(ICOUT,1181)IFEED2
2889C1181 FORMAT('THE FEEDBACK SWITCH HAS JUST BEEN SET TO ',
2890CCCCC CALL DPWRST('XXX','BUG ')
2891CCCCC1A4)
2892C1189 CONTINUE
2893      GOTO1199
2894C
2895 1199 CONTINUE
2896      RETURN
2897      END
2898      SUBROUTINE DPFENC(IHARG,NUMARG,
2899     1IFENSW,IFOUND,IERROR)
2900C
2901C     PURPOSE--SPECIFY THE FENCE SWITCH WHICH IN TURN
2902C              DETERMINES WHETHER SUCCEEDING BOX PLOTS WILL HAVE
2903C              VALUES BEYOND THE INNER FENCE AND OUTER FENCE INDICATED.
2904C              THE SPECIFIED FENCE SWITCH SPECIFICATION
2905C              WILL BE PLACED IN THE CHARACTER VARIABLE IFENSW.
2906C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
2907C                     --NUMARG (AN INTEGER VARIABLE)
2908C     OUTPUT ARGUMENTS--IFENSW (A CHARACTER VARIABLE)
2909C                     --IFOUND ('YES' OR 'NO' )
2910C                     --IERROR ('YES' OR 'NO' )
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
2920C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
2921C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
2922C     LANGUAGE--ANSI FORTRAN (1977)
2923C     VERSION NUMBER--83/7
2924C     ORIGINAL VERSION--JULY      1983.
2925C
2926C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
2927C
2928      CHARACTER*4 IHARG
2929      CHARACTER*4 IFENSW
2930      CHARACTER*4 IFOUND
2931      CHARACTER*4 IERROR
2932C
2933      CHARACTER*4 IHOLD
2934C
2935C---------------------------------------------------------------------
2936C
2937      DIMENSION IHARG(*)
2938C
2939C---------------------------------------------------------------------
2940C
2941      INCLUDE 'DPCOP2.INC'
2942C
2943C-----START POINT-----------------------------------------------------
2944C
2945      IFOUND='NO'
2946      IERROR='NO'
2947C
2948      IF(NUMARG.LE.0)GOTO1150
2949      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
2950      IF(IHARG(NUMARG).EQ.'OFF')GOTO1160
2951      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
2952      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1160
2953      GOTO1150
2954C
2955 1150 CONTINUE
2956      IHOLD='ON'
2957      GOTO1180
2958C
2959 1160 CONTINUE
2960      IHOLD='OFF'
2961      GOTO1180
2962C
2963 1180 CONTINUE
2964      IFOUND='YES'
2965      IFENSW=IHOLD
2966C
2967      IF(IFEEDB.EQ.'OFF')GOTO1189
2968      WRITE(ICOUT,999)
2969  999 FORMAT(1X)
2970      CALL DPWRST('XXX','BUG ')
2971      WRITE(ICOUT,1181)IFENSW
2972 1181 FORMAT('THE FENCE SWITCH (FOR BOX PLOTS) HAS JUST ',
2973     1'BEEN SET TO ',A4)
2974      CALL DPWRST('XXX','BUG ')
2975 1189 CONTINUE
2976      GOTO1199
2977C
2978 1199 CONTINUE
2979      RETURN
2980      END
2981      SUBROUTINE DPFICN(ICOM,IHARG,IHARG2,IARGT,ARG,NUMARG,
2982     1                  IPARNC,IPANC2,IPAROP,
2983     1                  PARLIM,PARLLM,PARULM,
2984     1                  NUMCON,MAXCON,IFOUND,IERROR,IBUG)
2985C
2986C     PURPOSE--DEFINE CONSTRAINTS TO BE USED
2987C              IN CONJUNCTION WITH THE FIT COMMAND
2988C              (AND THE PRE-FIT COMMAND).
2989C              THE SPECIFIED CONSTRAINED PARAMETER NAME WILL BE PLACED
2990C              IN AN ELEMENT OF THE HOLLERITH VARIABLES
2991C              IPARNC(.) AND IPANC2(.).
2992C              THE SPECIFIED MATHEMATICAL OPERATION
2993C              (< OR <= OR = OR >= OR >)
2994C              INVOLVED WITH THE CONSTRAINT
2995C              WILL BE PLACED IN THE CORRESPONDING ELEMENT
2996C              OF THE HOLLARIRTH VECTOR IPAROP(.).
2997C              THE SPECIFIED NUMBER WHICH SERVES AS THE BOUNDARY VALUE
2998C              IN THE CONSTRAINT WILL BE PLACED IN THE CORRESPONDING
2999C              ELEMENT OF THE FLOATING POINT VECTOR PARLIM(.).
3000C     INPUT  ARGUMENTS--ICOM   (A  HOLLERITH VECTOR)
3001C                     --IHARG  (A  HOLLERITH VECTOR)
3002C                     --IHARG2 (A  HOLLERITH VECTOR)
3003C                     --IARGT  (A  HOLLERITH VECTOR)
3004C                     --ARG    (A  FLOATING POINT VECTOR)
3005C                     --NUMARG (AN INTEGER VARIABLE)
3006C     OUTPUT ARGUMENTS--IPARNC (A  HOLLERITH VECTOR)
3007C                     --IPANC2 (A  HOLLERITH VECTOR)
3008C                     --IPAROP (A  HOLLERITH VECTOR)
3009C                     --PARLIM (A  FLOATING POINT VECTOR)
3010C                     --IFOUND ('YES' OR 'NO' )
3011C                     --IERROR ('YES' OR 'NO' )
3012C     WRITTEN BY--JAMES J. FILLIBEN
3013C                 STATISTICAL ENGINEERING DIVISION
3014C                 INFORMATION TECHNOLOGY LABORATORY
3015C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
3016C                 GAITHERSBURG, MD 20899-8980
3017C                 PHONE--301-975-2855
3018C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
3019C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
3020C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
3021C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
3022C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
3023C     LANGUAGE--ANSI FORTRAN (1977)
3024C     VERSION NUMBER--82/7
3025C     ORIGINAL VERSION--JUNE      1979.
3026C     UPDATED         --JULY      1979.
3027C     UPDATED         --DECEMBER  1980.
3028C     UPDATED         --JANUARY   1981.
3029C     UPDATED         --NOVEMBER  1981.
3030C     UPDATED         --MAY       1982.
3031C
3032C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
3033C
3034      CHARACTER*4 ICOM
3035      CHARACTER*4 IHARG
3036      CHARACTER*4 IHARG2
3037      CHARACTER*4 IARGT
3038      CHARACTER*4 IPARNC
3039      CHARACTER*4 IPANC2
3040      CHARACTER*4 IPAROP
3041      CHARACTER*4 IFOUND
3042      CHARACTER*4 IERROR
3043      CHARACTER*4 IBUG
3044C
3045      CHARACTER*4 IH1
3046      CHARACTER*4 IH2
3047      CHARACTER*4 NEWCON
3048C
3049      CHARACTER*4 ISUBN1
3050      CHARACTER*4 ISUBN2
3051      CHARACTER*4 ISTEPN
3052C
3053C---------------------------------------------------------------------
3054C
3055      DIMENSION IHARG(*)
3056      DIMENSION IHARG2(*)
3057      DIMENSION IARGT(*)
3058      DIMENSION ARG(*)
3059C
3060      DIMENSION IPARNC(*)
3061      DIMENSION IPANC2(*)
3062      DIMENSION IPAROP(*)
3063      DIMENSION PARLIM(*)
3064      DIMENSION PARLLM(*)
3065      DIMENSION PARULM(*)
3066C
3067C---------------------------------------------------------------------
3068C
3069      INCLUDE 'DPCOP2.INC'
3070C
3071C-----START POINT-----------------------------------------------------
3072C
3073      ISUBN1='DPFI'
3074      ISUBN2='CN  '
3075      NEWCON='UNKN'
3076C
3077      ICON=0
3078C
3079      IF(IBUG.EQ.'OFF')GOTO90
3080      WRITE(ICOUT,999)
3081  999 FORMAT(1X)
3082      CALL DPWRST('XXX','BUG ')
3083      WRITE(ICOUT,61)
3084   61 FORMAT('***** AT THE BEGINNING OF DPFICN--')
3085      CALL DPWRST('XXX','BUG ')
3086      WRITE(ICOUT,62)NUMARG
3087   62 FORMAT('NUMARG = ',I8)
3088      CALL DPWRST('XXX','BUG ')
3089      WRITE(ICOUT,63)ICOM
3090   63 FORMAT('ICOM = ',A4)
3091      CALL DPWRST('XXX','BUG ')
3092      IF(NUMARG.LE.0)GOTO67
3093      DO65I=1,NUMARG
3094      WRITE(ICOUT,66)I,IHARG(I),IHARG2(I),ARG(I)
3095   66 FORMAT('I,IHARG(I),IHARG2(I),ARG(I) = ',
3096     1I8,2X,A4,2X,A4,2X,E15.7)
3097      CALL DPWRST('XXX','BUG ')
3098   65 CONTINUE
3099   67 CONTINUE
3100C
3101      WRITE(ICOUT,999)
3102      CALL DPWRST('XXX','BUG ')
3103      WRITE(ICOUT,72)NUMCON,MAXCON,NEWCON,IBUG
3104   72 FORMAT('NUMCON,MAXCON,NEWCON,IBUG = ',I8,I8,2X,A4,2X,A4)
3105      CALL DPWRST('XXX','BUG ')
3106      IF(NUMCON.LE.0)GOTO77
3107      DO75I=1,NUMCON
3108      WRITE(ICOUT,76)I,IPARNC(I),IPANC2(I),IPAROP(I),PARLIM(I)
3109   76 FORMAT('I,IPARNC(I),IPANC2(I),IPAROP(I),PARLIM(I) = ',
3110     1I8,2X,A4,2X,A4,2X,A4,2X,E15.7)
3111      CALL DPWRST('XXX','BUG ')
3112   75 CONTINUE
3113   77 CONTINUE
3114C
3115   90 CONTINUE
3116C
3117C               **********************************************
3118C               **  STEP 1--                                **
3119C               **  DETERMINE IF HAVE THE TOTAL RESET CASE  **
3120C               **********************************************
3121C
3122      ISTEPN='1'
3123      IF(IBUG.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3124C
3125      IFOUND='NO'
3126      IERROR='NO'
3127C
3128      IF(NUMARG.GE.1.AND.ICOM.EQ.'FIT'.AND.IHARG(1).EQ.'CONS'.AND.
3129     1IHARG2(1).EQ.'TRAI')GOTO100
3130      GOTO900
3131C
3132  100 CONTINUE
3133      IF(NUMARG.LE.1)GOTO110
3134      IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'ON')GOTO110
3135      IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'OFF')GOTO110
3136      IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'AUTO')GOTO110
3137      IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'DEFA')GOTO110
3138      GOTO190
3139C
3140  110 CONTINUE
3141      IFOUND='YES'
3142      DO120I=1,MAXCON
3143      IPARNC(I)='    '
3144      IPANC2(I)='    '
3145      IPAROP(I)='NONE'
3146      PARLIM(I)=CPUMIN
3147  120 CONTINUE
3148      NUMCON=0
3149C
3150      IF(IFEEDB.EQ.'OFF')GOTO129
3151      WRITE(ICOUT,999)
3152      CALL DPWRST('XXX','BUG ')
3153      WRITE(ICOUT,121)
3154  121 FORMAT('ALL PARAMETERS HAVE JUST BEEN SET SO AS ')
3155      CALL DPWRST('XXX','BUG ')
3156      WRITE(ICOUT,122)
3157  122 FORMAT('    TO BE UNCONSTRAINED')
3158      CALL DPWRST('XXX','BUG ')
3159  129 CONTINUE
3160      GOTO900
3161C
3162  190 CONTINUE
3163C
3164C               ********************************************************
3165C               **  STEP 2--                                          **
3166C               **  DETERMINE IF NAME OF PARAMETER TO BE CONSTRAINED  **
3167C               **  ALREADY EXISTS IN CONSTRAINT TABLE.               **
3168C               ********************************************************
3169C
3170      ISTEPN='2'
3171      IF(IBUG.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3172C
3173      IH1=IHARG(2)
3174      IH2=IHARG2(2)
3175C
3176CC    NEWCON='NO'
3177CC    ICON=0
3178CC    IF(NUMCON.LE.0)GOTO220
3179CC    DO200I=1,NUMCON
3180CC    I2=I
3181CC    IF(IH1.EQ.IPARNC(I).AND.IH2.EQ.IPANC2(I))GOTO210
3182CC200 CONTINUE
3183CC    GOTO220
3184CC
3185CC210 CONTINUE
3186CC    ICON=I2
3187CC    GOTO290
3188CC
3189CC220 CONTINUE
3190      ICON=NUMCON+1
3191      IF(ICON.LE.MAXCON)GOTO229
3192      WRITE(ICOUT,999)
3193      CALL DPWRST('XXX','BUG ')
3194      WRITE(ICOUT,221)
3195  221 FORMAT('***** ERROR IN DPFICN--')
3196      CALL DPWRST('XXX','BUG ')
3197      WRITE(ICOUT,222)
3198  222 FORMAT('      THE NUMBER OF CONSTRAINTS')
3199      CALL DPWRST('XXX','BUG ')
3200      WRITE(ICOUT,224)
3201  224 FORMAT('      HAS JUST EXCEEDED THE MAXIMUM SIZE')
3202      CALL DPWRST('XXX','BUG ')
3203      WRITE(ICOUT,225)MAXCON
3204  225 FORMAT('      (',I5,') OF THE INTERNAL CONSTRAINT TABLE.')
3205      CALL DPWRST('XXX','BUG ')
3206      IERROR='YES'
3207      GOTO900
3208  229 CONTINUE
3209C
3210      NEWCON='YES'
3211      NUMCON=ICON
3212      GOTO290
3213C
3214  290 CONTINUE
3215C
3216C               ***********************************************
3217C               **  STEP 3--                                 **
3218C               **  ENTER THE PARAMETER NAME (IF NECESSARY)  **
3219C               **  INTO THE NAME VECTORS IPARNC(.) AND      **
3220C               **  IPANC2(.)                                **
3221C               ***********************************************
3222C
3223      ISTEPN='3'
3224      IF(IBUG.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3225C
3226      IPARNC(ICON)=IH1
3227      IPANC2(ICON)=IH2
3228C
3229C               ******************************************
3230C               **  STEP 4--                            **
3231C               **  ENTER THE CONSTRAINT OPERATION      **
3232C               **  INTO THE OPERATION VECTOR IPAROP(.) **
3233C               ******************************************
3234C
3235      ISTEPN='4'
3236      IF(IBUG.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3237C
3238      IPAROP(ICON)='NONE'
3239      IF(NUMARG.LE.3)GOTO410
3240      IF(IHARG(3).EQ.'ON')GOTO410
3241      IF(IHARG(3).EQ.'OFF')GOTO410
3242      IF(IHARG(3).EQ.'DEFA')GOTO410
3243      IF(IHARG(3).EQ.'AUTO')GOTO410
3244C
3245      IF(IHARG(3).EQ.'<'.AND.IHARG(4).NE.'=')GOTO420
3246      IF(IHARG(3).EQ.'<'.AND.IHARG(4).EQ.'=')GOTO430
3247      IF(IHARG(3).EQ.'='.AND.IHARG(4).EQ.'<')GOTO430
3248      IF(IHARG(3).EQ.'='.AND.IHARG(4).NE.'<'.AND.
3249     1IHARG(4).NE.'>')GOTO440
3250      IF(IHARG(3).EQ.'>'.AND.IHARG(4).EQ.'=')GOTO450
3251      IF(IHARG(3).EQ.'='.AND.IHARG(4).EQ.'>')GOTO450
3252      IF(IHARG(3).EQ.'>'.AND.IHARG(4).NE.'=')GOTO460
3253      GOTO470
3254C
3255  410 CONTINUE
3256      IPAROP(ICON)='NONE'
3257      GOTO490
3258C
3259  420 CONTINUE
3260      IPAROP(ICON)='<'
3261      GOTO490
3262C
3263  430 CONTINUE
3264      IPAROP(ICON)='<='
3265      GOTO490
3266C
3267  440 CONTINUE
3268      IPAROP(ICON)='='
3269      GOTO490
3270C
3271  450 CONTINUE
3272      IPAROP(ICON)='>='
3273      GOTO490
3274C
3275  460 CONTINUE
3276      IPAROP(ICON)='>'
3277      GOTO490
3278C
3279  470 CONTINUE
3280      IERROR='YES'
3281      WRITE(ICOUT,999)
3282      CALL DPWRST('XXX','BUG ')
3283      WRITE(ICOUT,471)
3284  471 FORMAT('ERROR IN DPFICN--')
3285      CALL DPWRST('XXX','BUG ')
3286      WRITE(ICOUT,472)
3287  472 FORMAT('      THE SECOND ARGUMENT IN THE FIT CONSTRAINT ')
3288      CALL DPWRST('XXX','BUG ')
3289      WRITE(ICOUT,473)
3290  473 FORMAT('      COMMAND SHOULD BE ONE OF THE FOLLOWING 5  ')
3291      CALL DPWRST('XXX','BUG ')
3292      WRITE(ICOUT,474)
3293  474 FORMAT('      MATHEMATICAL OPERATIONS-- <   <=   =   >=   >')
3294      CALL DPWRST('XXX','BUG ')
3295      WRITE(ICOUT,475)
3296  475 FORMAT('      OR SHOULD BE ONE OF THE FOLLOWING 4 WORDS--')
3297      CALL DPWRST('XXX','BUG ')
3298      WRITE(ICOUT,476)
3299  476 FORMAT('      ON    OFF    AUTOMATIC    DEFAULT,')
3300      CALL DPWRST('XXX','BUG ')
3301      WRITE(ICOUT,477)
3302  477 FORMAT('      BUT WAS NOT.')
3303      CALL DPWRST('XXX','BUG ')
3304      WRITE(ICOUT,478)
3305  478 FORMAT('      THE FOLLOWING ILLUSTRATIVE EXAMPLE')
3306      CALL DPWRST('XXX','BUG ')
3307      WRITE(ICOUT,479)
3308  479 FORMAT('      DEMONSTRATES THE ALLOWABLE FORM--')
3309      CALL DPWRST('XXX','BUG ')
3310      WRITE(ICOUT,480)
3311  480 FORMAT('      SUPPOSE THE ANALYST WISHES TO')
3312      CALL DPWRST('XXX','BUG ')
3313      WRITE(ICOUT,481)
3314  481 FORMAT('      CONSTRAIN THE PARAMETER ALPHA IN A FIT')
3315      CALL DPWRST('XXX','BUG ')
3316      WRITE(ICOUT,482)
3317  482 FORMAT('      TO BE STRICTLY GREATER THAN 0 AND')
3318      CALL DPWRST('XXX','BUG ')
3319      WRITE(ICOUT,483)
3320  483 FORMAT('      ALSO TO BE LESS THAN OR EQUAL TO 100,')
3321      CALL DPWRST('XXX','BUG ')
3322      WRITE(ICOUT,484)
3323  484 FORMAT('      THEN THE FOLLOWING MAY BE ENTERED--')
3324      CALL DPWRST('XXX','BUG ')
3325      WRITE(ICOUT,485)
3326  485 FORMAT('      FIT CONSTRAINT ALPHA > 0')
3327      CALL DPWRST('XXX','BUG ')
3328      WRITE(ICOUT,486)
3329  486 FORMAT('      FIT CONSTRAINT ALPHA <= 100')
3330      CALL DPWRST('XXX','BUG ')
3331      IF(NEWCON.EQ.'NO')GOTO489
3332      NUMCON=NUMCON-1
3333      IPARNC(ICON)='    '
3334      IPANC2(ICON)='    '
3335  489 CONTINUE
3336      GOTO900
3337C
3338  490 CONTINUE
3339C
3340C               **************************************
3341C               **  STEP 5--                        **
3342C               **  ENTER THE CONSTRAINT LIMITS     **
3343C               **  INTO THE VECTOR PARLIM(.)       **
3344C               **************************************
3345C
3346      ISTEPN='5'
3347      IF(IBUG.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3348C
3349      IF(IPAROP(ICON).EQ.'NONE')GOTO590
3350      IF(IARGT(NUMARG).EQ.'NUMB')GOTO510
3351      GOTO570
3352C
3353  510 CONTINUE
3354      IFOUND='YES'
3355      PARLIM(ICON)=ARG(NUMARG)
3356      GOTO590
3357C
3358  570 CONTINUE
3359      IERROR='YES'
3360      WRITE(ICOUT,999)
3361      CALL DPWRST('XXX','BUG ')
3362      WRITE(ICOUT,571)
3363  571 FORMAT('ERROR IN DPFICN--')
3364      CALL DPWRST('XXX','BUG ')
3365      WRITE(ICOUT,572)
3366  572 FORMAT('      THE THIRD ARGUMENT IN THE FIT CONSTRAINT')
3367      CALL DPWRST('XXX','BUG ')
3368      WRITE(ICOUT,573)
3369  573 FORMAT('      COMMAND SHOULD BE A NUMBER ')
3370      CALL DPWRST('XXX','BUG ')
3371      WRITE(ICOUT,574)
3372  574 FORMAT('      OR A PREVIOUSLY-DEFINED PARAMETER,')
3373      CALL DPWRST('XXX','BUG ')
3374      WRITE(ICOUT,575)
3375  575 FORMAT('      BUT WAS NOT.')
3376      CALL DPWRST('XXX','BUG ')
3377      WRITE(ICOUT,576)
3378  576 FORMAT('      THE FOLLOWING ILLUSTRATIVE EXAMPLE')
3379      CALL DPWRST('XXX','BUG ')
3380      WRITE(ICOUT,577)
3381  577 FORMAT('      DEMONSTRATES THE ALLOWABLE FORM--')
3382      CALL DPWRST('XXX','BUG ')
3383      WRITE(ICOUT,578)
3384  578 FORMAT('      SUPPOSE THE ANALYST WISHES TO')
3385      CALL DPWRST('XXX','BUG ')
3386      WRITE(ICOUT,579)
3387  579 FORMAT('      CONSTRAIN THE PARAMETER ALPHA IN A FIT')
3388      CALL DPWRST('XXX','BUG ')
3389      WRITE(ICOUT,580)
3390  580 FORMAT('      TO BE STRICTLY GREATER THAN 0 AND')
3391      CALL DPWRST('XXX','BUG ')
3392      WRITE(ICOUT,581)
3393  581 FORMAT('      ALSO TO BE LESS THAN OR EQUAL TO 100,')
3394      CALL DPWRST('XXX','BUG ')
3395      WRITE(ICOUT,582)
3396  582 FORMAT('      THEN THE FOLLOWING MAY BE ENTERED--')
3397      CALL DPWRST('XXX','BUG ')
3398      WRITE(ICOUT,583)
3399  583 FORMAT('      FIT CONSTRAINT ALPHA > 0')
3400      CALL DPWRST('XXX','BUG ')
3401      WRITE(ICOUT,584)
3402  584 FORMAT('      FIT CONSTRAINT ALPHA <= 100')
3403      CALL DPWRST('XXX','BUG ')
3404      IF(NEWCON.EQ.'NO')GOTO589
3405      NUMCON=NUMCON-1
3406      IPARNC(ICON)='    '
3407      IPANC2(ICON)='    '
3408  589 CONTINUE
3409      GOTO900
3410  590 CONTINUE
3411C
3412C               ****************************
3413C               **  STEP 6--              **
3414C               **  WRITE OUT A MESSAGE.  **
3415C               ****************************
3416C
3417      ISTEPN='6'
3418      IF(IBUG.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3419C
3420      IF(IPAROP(ICON).EQ.'NONE')GOTO610
3421      IF(IPAROP(ICON).EQ.'<')GOTO620
3422      IF(IPAROP(ICON).EQ.'<=')GOTO630
3423      IF(IPAROP(ICON).EQ.'=')GOTO640
3424      IF(IPAROP(ICON).EQ.'>=')GOTO650
3425      IF(IPAROP(ICON).EQ.'>')GOTO660
3426      GOTO690
3427C
3428  610 CONTINUE
3429      IF(IFEEDB.EQ.'OFF')GOTO619
3430      WRITE(ICOUT,999)
3431      CALL DPWRST('XXX','BUG ')
3432      WRITE(ICOUT,611)IPARNC(ICON),IPANC2(ICON)
3433  611 FORMAT('THE PARAMETER ',A4,A4,' HAS JUST BEEN SET')
3434      CALL DPWRST('XXX','BUG ')
3435      WRITE(ICOUT,612)
3436  612 FORMAT('    SO AS TO BE UNCONSTRAINED')
3437      CALL DPWRST('XXX','BUG ')
3438  619 CONTINUE
3439      GOTO670
3440C
3441  620 CONTINUE
3442      IF(IFEEDB.EQ.'OFF')GOTO629
3443      WRITE(ICOUT,999)
3444      CALL DPWRST('XXX','BUG ')
3445      WRITE(ICOUT,621)IPARNC(ICON),IPANC2(ICON)
3446  621 FORMAT('THE PARAMETER ',A4,A4,' HAS JUST BEEN CONSTRAINED ')
3447      CALL DPWRST('XXX','BUG ')
3448      WRITE(ICOUT,622)PARLIM(ICON)
3449  622 FORMAT('    TO BE STRICTLY LESS THAN ',E15.7)
3450      CALL DPWRST('XXX','BUG ')
3451  629 CONTINUE
3452      GOTO690
3453C
3454  630 CONTINUE
3455      IF(IFEEDB.EQ.'OFF')GOTO639
3456      WRITE(ICOUT,999)
3457      CALL DPWRST('XXX','BUG ')
3458      WRITE(ICOUT,631)IPARNC(ICON),IPANC2(ICON)
3459  631 FORMAT('THE PARAMETER ',A4,A4,' HAS JUST BEEN CONSTRAINED ')
3460      CALL DPWRST('XXX','BUG ')
3461      WRITE(ICOUT,632)PARLIM(ICON)
3462  632 FORMAT('    TO BE LESS THAN OR EQUAL TO ',E15.7)
3463      CALL DPWRST('XXX','BUG ')
3464  639 CONTINUE
3465      GOTO690
3466C
3467  640 CONTINUE
3468      IF(IFEEDB.EQ.'OFF')GOTO649
3469      WRITE(ICOUT,999)
3470      CALL DPWRST('XXX','BUG ')
3471      WRITE(ICOUT,641)IPARNC(ICON),IPANC2(ICON)
3472  641 FORMAT('THE PARAMETER ',A4,A4,' HAS JUST BEEN CONSTRAINED ')
3473      CALL DPWRST('XXX','BUG ')
3474      WRITE(ICOUT,642)PARLIM(ICON)
3475  642 FORMAT('    TO BE IDENTICALLY EQUAL TO ',E15.7)
3476      CALL DPWRST('XXX','BUG ')
3477  649 CONTINUE
3478      GOTO690
3479C
3480  650 CONTINUE
3481      IF(IFEEDB.EQ.'OFF')GOTO659
3482      WRITE(ICOUT,999)
3483      CALL DPWRST('XXX','BUG ')
3484      WRITE(ICOUT,651)IPARNC(ICON),IPANC2(ICON)
3485  651 FORMAT('THE PARAMETER ',A4,A4,' HAS JUST BEEN CONSTRAINED ')
3486      CALL DPWRST('XXX','BUG ')
3487      WRITE(ICOUT,652)PARLIM(ICON)
3488  652 FORMAT('    TO BE GREATER THAN OR EQUAL TO ',E15.7)
3489      CALL DPWRST('XXX','BUG ')
3490  659 CONTINUE
3491      GOTO690
3492C
3493  660 CONTINUE
3494      IF(IFEEDB.EQ.'OFF')GOTO669
3495      WRITE(ICOUT,999)
3496      CALL DPWRST('XXX','BUG ')
3497      WRITE(ICOUT,661)IPARNC(ICON),IPANC2(ICON)
3498  661 FORMAT('THE PARAMETER ',A4,A4,' HAS JUST BEEN CONSTRAINED ')
3499      CALL DPWRST('XXX','BUG ')
3500      WRITE(ICOUT,662)PARLIM(ICON)
3501  662 FORMAT('    TO BE STRICTLY GREATER THAN ',E15.7)
3502      CALL DPWRST('XXX','BUG ')
3503  669 CONTINUE
3504      GOTO690
3505C
3506  670 CONTINUE
3507      NUMCO2=NUMCON
3508      IF(NUMCON.LE.0)GOTO679
3509      DO671I=1,NUMCON
3510      IF(I.GT.NUMCO2)GOTO679
3511      I2=I
3512      IF(IH1.EQ.IPARNC(I).AND.IH2.EQ.IPANC2(I))GOTO672
3513      GOTO671
3514C
3515  672 CONTINUE
3516      J=I
3517      JM1=J-1
3518      JMIN=I+1
3519      JMAX=NUMCO2
3520      IF(JMIN.GT.JMAX)GOTO674
3521      DO673J=JMIN,JMAX
3522      JM1=J-1
3523      IPARNC(JM1)=IPARNC(J)
3524      IPANC2(JM1)=IPANC2(J)
3525      IPAROP(JM1)=IPAROP(J)
3526      PARLIM(JM1)=PARLIM(J)
3527  673 CONTINUE
3528  674 CONTINUE
3529      NUMCO2=JM1
3530C
3531  671 CONTINUE
3532  679 CONTINUE
3533      NUMCON=NUMCO2
3534      GOTO690
3535C
3536  690 CONTINUE
3537C
3538C               ****************
3539C               **  STEP 9--  **
3540C               **  EXIT      **
3541C               ****************
3542C
3543  900 CONTINUE
3544      IF(IBUG.EQ.'ON')THEN
3545        WRITE(ICOUT,999)
3546        CALL DPWRST('XXX','BUG ')
3547        WRITE(ICOUT,901)
3548  901   FORMAT('***** AT THE END OF DPFICN--')
3549        CALL DPWRST('XXX','BUG ')
3550        WRITE(ICOUT,902)NUMCON,MAXCON,ICON,NEWCON,IBUG
3551  902   FORMAT('NUMCON,MAXCON,ICON,NEWCON,IBUG = ',3I8,2(2X,A4))
3552        CALL DPWRST('XXX','BUG ')
3553        IF(NUMCON.GE.1)THEN
3554          DO910I=1,NUMCON
3555            WRITE(ICOUT,911)I,IPARNC(I),IPANC2(I),IPAROP(I),
3556     1                      PARLIM(I),PARLLM(I),PARULM(I)
3557  911       FORMAT('I,IPARNC(I),IPANC2(I),IPAROP(I),PARLIM(I)',
3558     1             'PARLLM(I),PARULM(I) = ',I8,3(2X,A4),3G15.7)
3559            CALL DPWRST('XXX','BUG ')
3560  910     CONTINUE
3561        ENDIF
3562      ENDIF
3563C
3564      RETURN
3565      END
3566      SUBROUTINE DPFIFO(IHARG,NUMARG,
3567     1IOUTTY,IFOUND,IERROR)
3568C
3569C     PURPOSE--SET THE FORMAT/TYPE SWITCH FOR THE OUTPUT FILE.
3570C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
3571C                     --NUMARG (AN INTEGER VARIABLE)
3572C     OUTPUT ARGUMENTS--IOUTTY (A HOLLERITH VARIABLE)
3573C                     --IFOUND ('YES' OR 'NO' )
3574C                     --IERROR ('YES' OR 'NO' )
3575C     WRITTEN BY--JAMES J. FILLIBEN
3576C                 STATISTICAL ENGINEERING DIVISION
3577C                 INFORMATION TECHNOLOGY LABORATORY
3578C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
3579C                 GAITHERSBURG, MD 20899-8980
3580C                 PHONE--301-975-2855
3581C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
3582C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
3583C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
3584C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
3585C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
3586C     LANGUAGE--ANSI FORTRAN (1977)
3587C     VERSION NUMBER--92/4
3588C     ORIGINAL VERSION--MARCH     1992.
3589C
3590C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
3591C
3592      CHARACTER*4 IHARG
3593      CHARACTER*4 IOUTTY
3594      CHARACTER*4 IFOUND
3595      CHARACTER*4 IERROR
3596C
3597      CHARACTER*4 IHOLD
3598C
3599C---------------------------------------------------------------------
3600C
3601      DIMENSION IHARG(*)
3602C
3603C---------------------------------------------------------------------
3604C
3605      INCLUDE 'DPCOP2.INC'
3606C
3607C-----START POINT-----------------------------------------------------
3608C
3609      IFOUND='NO'
3610      IERROR='NO'
3611C
3612      IF(NUMARG.LE.0)GOTO1150
3613      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
3614      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
3615      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
3616      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
3617      IF(IHARG(NUMARG).EQ.'?')GOTO1160
3618      GOTO1170
3619C
3620 1150 CONTINUE
3621      IHOLD='ASCI'
3622      GOTO1180
3623C
3624 1160 CONTINUE
3625      IF(IFEEDB.EQ.'OFF')GOTO1169
3626      WRITE(ICOUT,999)
3627  999 FORMAT(1X)
3628      CALL DPWRST('XXX','BUG ')
3629      WRITE(ICOUT,1161)IOUTTY
3630 1161 FORMAT('THE CURRENT FORMAT OF THE OUTPUT FILE IS ',A4)
3631      CALL DPWRST('XXX','BUG ')
3632 1169 CONTINUE
3633      IFOUND='YES'
3634      GOTO1199
3635C
3636 1170 CONTINUE
3637      IHOLD=IHARG(NUMARG)
3638      GOTO1180
3639C
3640 1180 CONTINUE
3641      IFOUND='YES'
3642      IOUTTY=IHOLD
3643C
3644      IF(IFEEDB.EQ.'OFF')GOTO1189
3645      WRITE(ICOUT,999)
3646      CALL DPWRST('XXX','BUG ')
3647      WRITE(ICOUT,1181)IOUTTY
3648 1181 FORMAT('THE OUTPUT FILE FORMAT SWITCH HAS JUST ',
3649     1'BEEN SET TO ',A4)
3650      CALL DPWRST('XXX','BUG ')
3651 1189 CONTINUE
3652      GOTO1199
3653C
3654 1199 CONTINUE
3655      RETURN
3656      END
3657      SUBROUTINE DPFIIT(IHARG,IARGT,IARG,NUMARG,IDEFFI,
3658     1IFITIT,IFOUND,IERROR)
3659C
3660C     PURPOSE--DEFINE THE UPPER BOUND FOR THE NUMBER OF FIT ITERATIONS.
3661C              THE SPECIFIED FIT ITERATION VALUE WILL BE PLACED
3662C              IN THE INTEGER VARIABLE IFITIT.
3663C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
3664C                     --IARGT  (A  HOLLERITH VECTOR)
3665C                     --IARG   (AN INTEGER VECTOR)
3666C                     --NUMARG (AN INTEGER VARIABLE)
3667C                     --IDEFFI (AN INTEGER VARIABLE)
3668C     OUTPUT ARGUMENTS--IFITIT (AN INTEGER VARIABLE)
3669C                     --IFOUND ('YES' OR 'NO' )
3670C                     --IERROR ('YES' OR 'NO' )
3671C     WRITTEN BY--JAMES J. FILLIBEN
3672C                 STATISTICAL ENGINEERING DIVISION
3673C                 INFORMATION TECHNOLOGY LABORATORY
3674C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
3675C                 GAITHERSBURG, MD 20899-8980
3676C                 PHONE--301-975-2855
3677C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
3678C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
3679C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
3680C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
3681C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
3682C     LANGUAGE--ANSI FORTRAN (1977)
3683C     VERSION NUMBER--82/7
3684C     ORIGINAL VERSION--NOVEMBER  1980.
3685C     UPDATED         --MAY       1982.
3686C
3687C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
3688C
3689      CHARACTER*4 IHARG
3690      CHARACTER*4 IARGT
3691      CHARACTER*4 IFOUND
3692      CHARACTER*4 IERROR
3693C
3694C---------------------------------------------------------------------
3695C
3696      DIMENSION IHARG(*)
3697      DIMENSION IARGT(*)
3698      DIMENSION IARG(*)
3699C
3700C---------------------------------------------------------------------
3701C
3702      INCLUDE 'DPCOP2.INC'
3703C
3704C-----START POINT-----------------------------------------------------
3705C
3706      IFOUND='NO'
3707      IERROR='NO'
3708C
3709      IF(NUMARG.EQ.0)GOTO1199
3710      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'=')GOTO1199
3711      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'ITER')GOTO1110
3712      GOTO1199
3713C
3714 1110 CONTINUE
3715      IF(IHARG(NUMARG).EQ.'ITER')GOTO1150
3716      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
3717      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
3718      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
3719      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
3720      IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160
3721      GOTO1120
3722C
3723 1120 CONTINUE
3724      IERROR='YES'
3725      WRITE(ICOUT,1121)
3726 1121 FORMAT('***** ERROR IN DPFIIT--')
3727      CALL DPWRST('XXX','BUG ')
3728      WRITE(ICOUT,1122)
3729 1122 FORMAT('      ILLEGAL FORM FOR FIT ITERATIONS ',
3730     1'COMMAND.')
3731      CALL DPWRST('XXX','BUG ')
3732      WRITE(ICOUT,1124)
3733 1124 FORMAT('      TEST EXAMPLE TO DEMONSTRATE THE ',
3734     1'PROPER FORM--')
3735      CALL DPWRST('XXX','BUG ')
3736      WRITE(ICOUT,1125)
3737 1125 FORMAT('      SUPPOSE THE THE ANALYST WILL BE CARRYING OUT  ')
3738      CALL DPWRST('XXX','BUG ')
3739      WRITE(ICOUT,1126)
3740 1126 FORMAT('      A NON-LINEAR FIT , ')
3741      CALL DPWRST('XXX','BUG ')
3742      WRITE(ICOUT,1127)
3743 1127 FORMAT('      AND SUPPOSE THE ANALYST WISHES TO TERMINATE  ')
3744      CALL DPWRST('XXX','BUG ')
3745      WRITE(ICOUT,1128)
3746 1128 FORMAT('      THE FIT IF THE NUMBER OF ITERATIONS ')
3747      CALL DPWRST('XXX','BUG ')
3748      WRITE(ICOUT,1129)
3749 1129 FORMAT('      HAPPENS TO REACH 30;')
3750      CALL DPWRST('XXX','BUG ')
3751      WRITE(ICOUT,1130)
3752 1130 FORMAT('      THEN THE ALLOWABLE FORM IS--')
3753      CALL DPWRST('XXX','BUG ')
3754      WRITE(ICOUT,1131)
3755 1131 FORMAT('      FIT ITERATIONS 30 ')
3756      CALL DPWRST('XXX','BUG ')
3757      GOTO1199
3758C
3759 1150 CONTINUE
3760      IHOLD=IDEFFI
3761      GOTO1180
3762C
3763 1160 CONTINUE
3764      IHOLD=IARG(NUMARG)
3765      GOTO1180
3766C
3767 1180 CONTINUE
3768      IFOUND='YES'
3769      IFITIT=IHOLD
3770C
3771      IF(IFEEDB.EQ.'OFF')GOTO1189
3772      WRITE(ICOUT,999)
3773  999 FORMAT(1X)
3774      CALL DPWRST('XXX','BUG ')
3775      WRITE(ICOUT,1181)IFITIT
3776 1181 FORMAT('THE FIT ITERATIONS HAVE JUST BEEN SET TO ',
3777     1I8)
3778      CALL DPWRST('XXX','BUG ')
3779 1189 CONTINUE
3780      GOTO1199
3781C
3782 1199 CONTINUE
3783      RETURN
3784      END
3785      SUBROUTINE DPFILE(IANS,IWIDTH,IWORD,
3786     1                  IOFILE,IBUGS2,ISUBRO,IERROR)
3787C
3788C     PURPOSE--SCAN THE    IWORD-TH   WORD OF THE INPUT LINE.
3789C              AND DETERMINE IF IT IS A FILE NAME.
3790C              THE CRITERION IS THAT IF THAT WORD
3791C              CONTAINS THE CHARACTER    IFCHAR   ,
3792C              THEN IT IS CONSIDERED A FILE NAME,
3793C              OTHERWISE IT IS CONSIDERED NOT TO BE A FILE NAME.
3794C     OUTPUT ARGUMENT--IOFILE ('YES' OR 'NO')
3795C     NOTE--THIS SUBROUTINE IS "SYSTEM-DEPENDENT" IN THE SENSE
3796C           THAT IFCHAR MAY DIFFER FROM ONE SYSTEM TO ANOTHER.
3797C     NOTE--IFCHAR IS SET AT TIMPLEMENTATION TIME
3798C           IN THE SUBROUTINE INITFO.
3799C     NOTE--THE DEFAULT SETTING FOR IFCHAR IS . (= PERIOD).
3800C           THUS YOU MAY ENTER  READ X. Y Z
3801C           TO TELL DATAPLOT TO READ VARIABLES Y AND Z
3802C           FROM FILE X
3803C           AS OPPOSED TO ENTERING   READ X Y Z
3804C           TO TELL DATAPLOT TO READ VARIABLES X, Y, AND Z
3805C           FROM THE TERMINAL.
3806C           READ X. Y Z
3807C     WRITTEN BY--JAMES J. FILLIBEN
3808C                 STATISTICAL ENGINEERING DIVISION
3809C                 INFORMATION TECHNOLOGY LABORATORY
3810C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
3811C                 GAITHERSBURG, MD 20899-8980
3812C                 PHONE--301-975-2855
3813C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
3814C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
3815C     LANGUAGE--ANSI FORTRAN (1977)
3816C     VERSION NUMBER--86/1
3817C     ORIGINAL VERSION--NOVEMBER  1977.
3818C     UPDATED         --OCTOBER   1978.
3819C     UPDATED         --NOVEMBER  1980.
3820C     UPDATED         --JUNE      1981.
3821C     UPDATED         --MAY       1982.
3822C     UPDATED         --DECEMBER  1986.
3823C     UPDATED         --DECEMBER  1988. DESLATTES FILE NAME INSIDE QUOTE PROBLEM
3824C     UPDATED         --JULY      2002. OPTION (IFILQU=ON/OFF) TO
3825C                                       DETERMINE IF FILE NAME CAN
3826C                                       BE ENCLOSED IN QUOTES
3827C     UPDATED         --JULY      2003. BUG: EVEN THOUGH FILE NAMES
3828C                                       MAY BE RESTRICTED TO 80
3829C                                       CHARACTERS, THE COMMAND LINE
3830C                                       CONTAINING THEM CAN BE
3831C                                       LONGER.  ADJUST DIMENSIONING
3832C                                       TO ACCOUNT FOR THIS.  ALSO ADD
3833C                                       CHECK FOR FILE NAMES EXCEEDING
3834C                                       80 CHARACTERS.
3835C     UPDATED         --FEBRUARY  2008. ADD FILE NAME QUOTE NOFILE
3836C
3837C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
3838C
3839      CHARACTER*4 IANS(*)
3840      CHARACTER*4 IOFILE
3841      CHARACTER*4 IBUGS2
3842      CHARACTER*4 ISUBRO
3843      CHARACTER*4 IERROR
3844C
3845      CHARACTER*4 IANSI
3846      CHARACTER*1024 ICANS
3847      CHARACTER*1024 ISTRIN
3848C
3849      CHARACTER*4 ISUBN1
3850      CHARACTER*4 ISUBN2
3851      CHARACTER*4 ISTEPN
3852C
3853      PARAMETER (MAXFNC=80)
3854C
3855C-----COMMON----------------------------------------------------------
3856C
3857      INCLUDE 'DPCOF2.INC'
3858      INCLUDE 'DPCOST.INC'
3859      INCLUDE 'DPCOP2.INC'
3860C
3861C-----START POINT-----------------------------------------------------
3862C
3863      ISUBN1='DPFI'
3864      ISUBN2='LE  '
3865      IERROR='NO'
3866C
3867      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'FILE')THEN
3868        WRITE(ICOUT,999)
3869  999   FORMAT(1X)
3870        CALL DPWRST('XXX','BUG ')
3871        WRITE(ICOUT,51)
3872   51   FORMAT('***** AT THE BEGINNING OF DPFILE--')
3873        CALL DPWRST('XXX','BUG ')
3874        WRITE(ICOUT,52)IWIDTH,IWORD
3875   52   FORMAT('IWIDTH,IWORD = ',2I8)
3876        CALL DPWRST('XXX','BUG ')
3877        IF(IWIDTH.GE.1)THEN
3878          WRITE(ICOUT,53)(IANS(I),I=1,MIN(100,IWIDTH))
3879   53     FORMAT('IANS(.) = ',100A1)
3880          CALL DPWRST('XXX','BUG ')
3881        ENDIF
3882        WRITE(ICOUT,54)IFCHARS,IFILQU
3883   54   FORMAT('IFCHAR,IFILQU = ',A1,2X,A4)
3884        CALL DPWRST('XXX','BUG ')
3885      ENDIF
3886C
3887C               ***************************************
3888C               **  STEP 1--                         **
3889C               **  DETERMINE IF HAVE THE FILE CASE  **
3890C               ***************************************
3891C
3892      ISTEPN='1'
3893      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'FILE')
3894     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3895C
3896      DO1110I=1,MIN(1024,IWIDTH)
3897        IANSI=IANS(I)
3898        ICANS(I:I)=IANSI(1:1)
3899 1110 CONTINUE
3900C
3901      ISTART=1
3902      ISTOP=MIN(IWIDTH,1024)
3903      CALL DPEXWO(ICANS,ISTART,ISTOP,IWORD,
3904     1ICOL1,ICOL2,ISTRIN,NCSTRI,
3905     1IBUGS2,ISUBRO,IERROR)
3906C
3907      IOFILE='NO'
3908      IF(NCSTRI.LE.0)GOTO1290
3909C     THE FOLLOWING LINE WAS INSERTED DECEMBER 1988 TO
3910C     SOLVE THE DESLATTES PROBLEM    WRITE "(EXAMPLE--ABC.DEF)"
3911C     JULY 2002: MAKE QUOTE OPTIONAL (PC FILES CAN HAVE SPACES,
3912C     SO ENCLOSE IN QUOTES TO EXTRACT)
3913CCCCC IF(ICANS(1:1).EQ.'"')GOTO1290
3914CCCCC
3915CCCCC FEBRUARY 2008: IF FILE NAME QUOTE IS "OFF" OR "NOFILE",
3916CCCCC                THEN DON'T CHECK FOR FILE NAME.
3917CCCCC
3918CCCCC IF(ICANS(1:1).EQ.'"' .AND. IFILQU.EQ.'OFF')GOTO1290
3919      IF(ICANS(ICOL1:ICOL1).EQ.'"' .AND. IFILQU.EQ.'OFF')GOTO1290
3920      IF(ICANS(ICOL1:ICOL1).EQ.'"' .AND. IFILQU.EQ.'NOFI')GOTO1290
3921      IF(ICOL1.GT.ICOL2)GOTO1290
3922      DO1200I=ICOL1,ICOL2
3923      IF(ICANS(I:I).EQ.IFCHAR)GOTO1250
3924 1200 CONTINUE
3925      GOTO1290
3926 1250 CONTINUE
3927      IOFILE='YES'
3928      NC=ICOL2-ICOL1+1
3929      IF(IFILQU.EQ.'ON' .AND. ICANS(ICOL1:ICOL1).EQ.'"')NC=NC-1
3930      IF(IFILQU.EQ.'ON' .AND. ICANS(ICOL2:ICOL2).EQ.'"')NC=NC-1
3931      IF(NC.GT.MAXFNC)THEN
3932        WRITE(ICOUT,999)
3933        CALL DPWRST('XXX','BUG ')
3934        WRITE(ICOUT,1251)MAXFNC
3935 1251   FORMAT('***** FATAL ERROR: FILE NAME EXCEEDS MAXIMUM ',
3936     1         'LENGTH OF ',I8,' CHARACTERS.')
3937        CALL DPWRST('XXX','BUG ')
3938        WRITE(ICOUT,1253)NC
3939 1253   FORMAT('      REQUESTED FILE NAME HAS ',I8,' CHARACTERS.')
3940        CALL DPWRST('XXX','BUG ')
3941        IERROR='YES'
3942        GOTO9000
3943      ENDIF
3944      GOTO1290
3945 1290 CONTINUE
3946C
3947C               ****************
3948C               **  STEP 90-- **
3949C               **  EXIT.     **
3950C               ****************
3951C
3952 9000 CONTINUE
3953      IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'FILE')GOTO9090
3954      WRITE(ICOUT,999)
3955      CALL DPWRST('XXX','BUG ')
3956      WRITE(ICOUT,9011)
3957 9011 FORMAT('***** AT THE END      OF DPFILE--')
3958      CALL DPWRST('XXX','BUG ')
3959      WRITE(ICOUT,9012)IWIDTH,IWORD
3960 9012 FORMAT('IWIDTH,IWORD = ',2I8)
3961      CALL DPWRST('XXX','BUG ')
3962      IF(IWIDTH.GE.1)THEN
3963        WRITE(ICOUT,9013)(IANS(I),I=1,MIN(100,IWIDTH))
3964 9013   FORMAT('IANS(.) = ',100A1)
3965        CALL DPWRST('XXX','BUG ')
3966      ENDIF
3967      WRITE(ICOUT,9014)IFCHAR
3968 9014 FORMAT('IFCHAR = ',A1)
3969      CALL DPWRST('XXX','BUG ')
3970      WRITE(ICOUT,9015)ICOL1,ICOL2,NCSTRI
3971 9015 FORMAT('ICOL1,ICOL2,NCSTRI = ',3I8)
3972      CALL DPWRST('XXX','BUG ')
3973      IF(IWIDTH.GE.1)THEN
3974        WRITE(ICOUT,9021)(ICANS(I:I),I=1,MIN(100,IWIDTH))
3975 9021   FORMAT('ICANS(.:.) = ',100A1)
3976        CALL DPWRST('XXX','BUG ')
3977        WRITE(ICOUT,9022)(ISTRIN(I:I),I=1,MIN(100,IWIDTH))
3978 9022   FORMAT('ISTRIN(.:.) = ',100A1)
3979        CALL DPWRST('XXX','BUG ')
3980      ENDIF
3981      WRITE(ICOUT,9031)IBUGS2,IERROR
3982 9031 FORMAT('IBUGS2,IERROR = ',A4,2X,A4)
3983      CALL DPWRST('XXX','BUG ')
3984      WRITE(ICOUT,9032)IOFILE
3985 9032 FORMAT('IOFILE = ',A4)
3986      CALL DPWRST('XXX','BUG ')
3987 9090 CONTINUE
3988C
3989      RETURN
3990      END
3991      SUBROUTINE DPFIL2(ICHAR,IMIN,IMAX,IANS2,IWID,
3992     1LOCCHA,NAM,NPACKC,IBUG,IERROR)
3993C
3994C     PURPOSE--EXTRACT QUALIFIER, FILE, OR SUBFILE
3995C              NAME FROM A STRING.
3996C     INPUT  ARGUMENTS--IMIN   = INTEGER VARIABLE
3997C                                CONTAINING THE START LOCATION
3998C                                (IN THE VECTOR IANS2(.))
3999C                                FOR THE SEARCH.
4000C                     --IMAX   = INTEGER VARIABLE
4001C                                CONTAINING THE STOP LOCATION
4002C                                (IN THE VECTOR IANS2(.))
4003C                                FOR THE SEARCH.
4004C                     --ICHAR  = HOLLERITH VARIABLE GIVING
4005C                                THE SOUGHT-AFTER CHARACTER
4006C                                IN THE SEARCH.
4007C                     --IANS2  = HOLLERITH VECTOR BEING SEARCHED.
4008C                     --IWID   = THE NUMBER OF ELEMENTS
4009C                                IN THE HOLLERITH VECTOR IANS2(.)
4010C     OUTPUT ARGUMENTS--LOCCHA = INTEGER VARIABLE
4011C                                CONTAINING THE LOCATION
4012C                                (IN THE VECTR IANS2(.))
4013C                                WHERE THE CHARACTER WAS FOUND.
4014C                     --NAM    = HOLLERITH VECTOR
4015C                                INTO WHICH THE PACKED NAME
4016C                                IS PLACED.
4017C                     --NPACKC = INTEGER VARIABLE
4018C                                CONTAINING THE NUMBER OF WORDS
4019C                                IN THE VARIABLE NAM(.) FOR
4020C                                THE PACKED VERSION OF THE
4021C                                QUALIFIER, FILE, AND/OR SUBFILE NAME
4022C                                (WHERE THE WORDS ARE PACKED--
4023C                                4, 6, 10, ETC. CHARACTERS PER WORD).
4024C     NOTE--IF THE NAME DOES NOT EXIST,
4025C           THE LOCCHA IS SET TO IMIN-1,
4026C           NAM(.) IS FILLED WITH BLANKS,
4027C           AND NPACKC IS SET TO 0   .
4028C     WRITTEN BY--JAMES J. FILLIBEN
4029C                 STATISTICAL ENGINEERING DIVISION
4030C                 INFORMATION TECHNOLOGY LABORATORY
4031C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
4032C                 GAITHERSBURG, MD 20899-8980
4033C                 PHONE--301-975-2855
4034C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
4035C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
4036C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
4037C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
4038C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
4039C     LANGUAGE--ANSI FORTRAN (1977)
4040C     VERSION NUMBER--82/7
4041C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--JUNE        1981.
4042C     UPDATED         --NOVEMBER  1981.
4043C     UPDATED         --MAY       1982.
4044C
4045C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
4046C
4047      CHARACTER*4 ICHAR
4048      CHARACTER*4 IANS2
4049      CHARACTER*4 NAM
4050      CHARACTER*4 IBUG
4051      CHARACTER*4 IERROR
4052C
4053C---------------------------------------------------------------------
4054C
4055      DIMENSION IANS2(*)
4056      DIMENSION NAM(*)
4057C
4058C---------------------------------------------------------------------
4059C
4060      INCLUDE 'DPCOP2.INC'
4061C
4062C-----START POINT-----------------------------------------------------
4063C
4064      IERROR='NO'
4065C
4066      IF(IBUG.EQ.'OFF')GOTO90
4067      WRITE(ICOUT,999)
4068  999 FORMAT(1X)
4069      CALL DPWRST('XXX','BUG ')
4070      WRITE(ICOUT,51)
4071   51 FORMAT('***** AT THE BEGINNING OF DPFIL2--')
4072      CALL DPWRST('XXX','BUG ')
4073      WRITE(ICOUT,52)ICHAR,IMIN,IMAX
4074   52 FORMAT('ICHAR,IMIN,IMAX = ',A4,2I8)
4075      CALL DPWRST('XXX','BUG ')
4076      WRITE(ICOUT,53)IWID
4077   53 FORMAT('IWID = ',I8)
4078      CALL DPWRST('XXX','BUG ')
4079      WRITE(ICOUT,54)(IANS2(I),I=1,IWID)
4080   54 FORMAT('IANS2(.)--',120A1)
4081      CALL DPWRST('XXX','BUG ')
4082      WRITE(ICOUT,55)IBUG,IERROR
4083   55 FORMAT('IBUG,IERROR = ',A4,2X,A4)
4084      CALL DPWRST('XXX','BUG ')
4085   90 CONTINUE
4086C
4087C               ****************************************
4088C               **  STEP 1--                          **
4089C               **  ZERO-OUT AND BLANK-OUT            **
4090C               **  THE OUTPUT VARIABLES AND VECTOR.  **
4091C               ****************************************
4092C
4093      LOCCHA=IMIN-1
4094      NPACKC=0
4095C
4096      DO1110J=1,10
4097      NAM(J)=' '
4098 1110 CONTINUE
4099C
4100C               *******************************************
4101C               **  STEP 2--                             **
4102C               **  SEARCH FOR THE TARGET CHARACTER;     **
4103C               **  DETERMINE ITS LOCATION IN IANS2(.);  **
4104C               **  PLACE THE LOCATION VALUE IN LOCCHA.  **
4105C               *******************************************
4106C
4107      IF(ICHAR.EQ.'END')GOTO1126
4108      IF(IMAX.LE.0)GOTO1190
4109      IF(IMIN.GT.IMAX)GOTO1190
4110      DO1120I=IMIN,IMAX
4111      I2=I
4112      IF(IBUG.EQ.'ON')WRITE(ICOUT,1111)I,IANS2(I),ICHAR
4113 1111 FORMAT('I,IANS2(I),ICHAR = ',I6,A6,A6)
4114      IF(IBUG.EQ.'ON')CALL DPWRST('XXX','BUG ')
4115      IF(IANS2(I).EQ.ICHAR)GOTO1125
4116 1120 CONTINUE
4117      GOTO1190
4118 1125 CONTINUE
4119      LOCCHA=I2
4120      GOTO1129
4121 1126 CONTINUE
4122      LOCCHA=IMAX+1
4123      GOTO1129
4124 1129 CONTINUE
4125C
4126C               *************************************************
4127C               **  STEP 3--                                   **
4128C               **  EXTRACT THE NAME BETWEEN LOCATION IMIN     **
4129C               **  AND THE LOCATION OF THE TARGET CHARACTER.  **
4130C               **  PACK THE NAME INTO NAM(.)                  **
4131C               **  COMPUTE NPACKC = THE NUMBER OF PACKED WORDS**
4132C               **  IN NAM(.) NEEDED FOR THE NAME.             **
4133C               *************************************************
4134C
4135      NUMCH=0
4136      IMAX2=LOCCHA-1
4137      IF(IMAX2.LE.0)GOTO1190
4138      IF(IMIN.GT.IMAX2)GOTO1190
4139      DO1130I=IMIN,IMAX2
4140CCCCC J=((I-IMIN)/NUMBPC)+1
4141      J=((I-IMIN)/NUMCPW)+1
4142      IF(IANS2(I).EQ.' ')GOTO1130
4143      NUMCH=NUMCH+1
4144      ISTAR3=(NUMBPC*(NUMCH-1)) - (NUMBPW*(J-1))
4145      ISTAR3=IABS(ISTAR3)
4146      CALL DPCHEX(0,NUMBPC,IANS2(I),ISTAR3,NUMBPC,NAM(J))
4147 1130 CONTINUE
4148      NPACKC=J
4149C
4150 1190 CONTINUE
4151C
4152C               *****************
4153C               **  STEP 90--  **
4154C               **  EXIT       **
4155C               *****************
4156C
4157      IF(IBUG.EQ.'ON')THEN
4158        WRITE(ICOUT,999)
4159        CALL DPWRST('XXX','BUG ')
4160        WRITE(ICOUT,9011)
4161 9011   FORMAT('***** AT THE END       OF DPFIL2--')
4162        CALL DPWRST('XXX','BUG ')
4163        WRITE(ICOUT,9012)IERROR,ICHAR,IMIN,IMAX,IWID
4164 9012   FORMAT('IERROR,ICHAR,IMIN,IMAX = ',2(A4,2X),2X,3I8)
4165        CALL DPWRST('XXX','BUG ')
4166        WRITE(ICOUT,9014)(IANS2(I),I=1,IWID)
4167 9014   FORMAT('IANS2(.)--',120A1)
4168        CALL DPWRST('XXX','BUG ')
4169        WRITE(ICOUT,9016)LOCCHA,NPACKC
4170 9016   FORMAT('LOCCHA,NPACKC = ',2I8)
4171        CALL DPWRST('XXX','BUG ')
4172        WRITE(ICOUT,9017)(NAM(I),I=1,10)
4173 9017   FORMAT('NAM(.)--',10A6)
4174        CALL DPWRST('XXX','BUG ')
4175      ENDIF
4176C
4177      RETURN
4178      END
4179      SUBROUTINE DPFILL(IHARG,NUMARG,
4180     1IDEFFI,
4181     1ITEXFI,
4182     1IBUGD2,ISUBRO,IFOUND,IERROR)
4183C
4184C     PURPOSE--DEFINE THE FILL SWITCH (ON OR OFF) FOR
4185C              TEXT SCRIPT AND OTHER DIAGRAMMATIC FIGURES
4186C              ON A PLOT.
4187C              THE FILL SWITCH WILL BE PLACED
4188C              IN THE CHARACTER VARIABLE ITEXFI.
4189C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
4190C                     --NUMARG
4191C                     --IDEFFI
4192C                     --IBUGD2
4193C     OUTPUT ARGUMENTS--ITEXFI
4194C                     --IFOUND ('YES' OR 'NO' )
4195C                     --IERROR ('YES' OR 'NO' )
4196C     WRITTEN BY--JAMES J. FILLIBEN
4197C                 STATISTICAL ENGINEERING DIVISION
4198C                 INFORMATION TECHNOLOGY LABORATORY
4199C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
4200C                 GAITHERSBURG, MD 20899-8980
4201C                 PHONE--301-975-2855
4202C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
4203C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
4204C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
4205C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
4206C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
4207C     LANGUAGE--ANSI FORTRAN (1977)
4208C     VERSION NUMBER--82/7
4209C     ORIGINAL VERSION--APRIL     1981.
4210C     UPDATED         --MAY       1982.
4211C
4212C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
4213C
4214      CHARACTER*4 IHARG
4215      CHARACTER*4 IDEFFI
4216      CHARACTER*4 ITEXFI
4217      CHARACTER*4 IBUGD2
4218      CHARACTER*4 ISUBRO
4219      CHARACTER*4 IFOUND
4220      CHARACTER*4 IERROR
4221C
4222C---------------------------------------------------------------------
4223C
4224      DIMENSION IHARG(*)
4225C
4226C---------------------------------------------------------------------
4227C
4228      INCLUDE 'DPCOP2.INC'
4229C
4230C-----START POINT-----------------------------------------------------
4231C
4232      IFOUND='NO'
4233      IERROR='NO'
4234C
4235      IF(IBUGD2.EQ.'OFF')GOTO90
4236      WRITE(ICOUT,999)
4237  999 FORMAT(1X)
4238      CALL DPWRST('XXX','BUG ')
4239      WRITE(ICOUT,51)
4240   51 FORMAT('***** AT THE BEGINNING OF DPFILL--')
4241      CALL DPWRST('XXX','BUG ')
4242      WRITE(ICOUT,53)IDEFFI
4243   53 FORMAT('IDEFFI = ',A4)
4244      CALL DPWRST('XXX','BUG ')
4245      WRITE(ICOUT,54)NUMARG
4246   54 FORMAT('NUMARG = ',I8)
4247      CALL DPWRST('XXX','BUG ')
4248      DO55I=1,NUMARG
4249      WRITE(ICOUT,56)I,IHARG(I)
4250   56 FORMAT('I,IHARG(I) = ',I8,2X,A4)
4251      CALL DPWRST('XXX','BUG ')
4252   55 CONTINUE
4253   90 CONTINUE
4254C
4255C               ************************************
4256C               **  TREAT THE FILL          CASE  **
4257C               ************************************
4258C
4259      IF(NUMARG.LE.0)GOTO1161
4260      IF(IHARG(NUMARG).EQ.'ON')GOTO1161
4261      IF(IHARG(NUMARG).EQ.'OFF')GOTO1162
4262      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1161
4263      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1165
4264      GOTO1170
4265C
4266 1161 CONTINUE
4267      ITEXFI='ON'
4268      GOTO1180
4269C
4270 1162 CONTINUE
4271      ITEXFI='OFF'
4272      GOTO1180
4273C
4274 1165 CONTINUE
4275      ITEXFI=IDEFFI
4276      GOTO1180
4277C
4278 1170 CONTINUE
4279      IERROR='YES'
4280      WRITE(ICOUT,1171)
4281 1171 FORMAT('***** ERROR IN DPFILL--')
4282      CALL DPWRST('XXX','BUG ')
4283      WRITE(ICOUT,1172)
4284 1172 FORMAT('      ILLEGAL ENTRY FOR FILL ',
4285     1'COMMAND.')
4286      CALL DPWRST('XXX','BUG ')
4287      WRITE(ICOUT,1173)
4288 1173 FORMAT('      TEST EXAMPLE TO DEMONSTRATE THE ',
4289     1'PROPER FORM--')
4290      CALL DPWRST('XXX','BUG ')
4291      WRITE(ICOUT,1174)
4292 1174 FORMAT('      SUPPOSE THE THE ANALYST WISHES ')
4293      CALL DPWRST('XXX','BUG ')
4294      WRITE(ICOUT,1175)
4295 1175 FORMAT('      TO HAVE ALL TEXT AND FIGURES FILLED,')
4296      CALL DPWRST('XXX','BUG ')
4297      WRITE(ICOUT,1177)
4298 1177 FORMAT('      THEN ALLOWABLE FORMS ARE--')
4299      CALL DPWRST('XXX','BUG ')
4300      WRITE(ICOUT,1178)
4301 1178 FORMAT('           FILL ON ')
4302      CALL DPWRST('XXX','BUG ')
4303      WRITE(ICOUT,1179)
4304 1179 FORMAT('           FILL ')
4305      CALL DPWRST('XXX','BUG ')
4306      GOTO9000
4307C
4308 1180 CONTINUE
4309      IFOUND='YES'
4310C
4311      IF(IFEEDB.EQ.'OFF')GOTO1189
4312      WRITE(ICOUT,999)
4313      CALL DPWRST('XXX','BUG ')
4314      WRITE(ICOUT,1181)
4315 1181 FORMAT('THE FILL (FOR TEXT AND FIGURES) ')
4316      CALL DPWRST('XXX','BUG ')
4317      WRITE(ICOUT,1182)ITEXFI
4318 1182 FORMAT('HAS JUST BEEN SET TO ',A4)
4319      CALL DPWRST('XXX','BUG ')
4320 1189 CONTINUE
4321      GOTO9000
4322C
4323C               *****************
4324C               **  STEP 90--  **
4325C               **  EXIT       **
4326C               *****************
4327C
4328 9000 CONTINUE
4329      IF(IBUGD2.EQ.'OFF')GOTO9090
4330      WRITE(ICOUT,999)
4331      CALL DPWRST('XXX','BUG ')
4332      WRITE(ICOUT,9011)
4333 9011 FORMAT('***** AT THE END       OF DPFILL')
4334      CALL DPWRST('XXX','BUG ')
4335      WRITE(ICOUT,9012)IBUGD2,ISUBRO,IFOUND,IERROR
4336 9012 FORMAT('IBUGD2,ISUBRO,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
4337      CALL DPWRST('XXX','BUG ')
4338      WRITE(ICOUT,9013)IDEFFI,ITEXFI
4339 9013 FORMAT('IDEFFI,ITEXFI = ',A4,2X,A4)
4340      CALL DPWRST('XXX','BUG ')
4341 9090 CONTINUE
4342C
4343      RETURN
4344      END
4345      SUBROUTINE DPFIMA(PXMIN,PYMIN,PXMAX,PYMAX,
4346     1ICASPL,ICAS3D,
4347     1IMARCO)
4348C
4349C     PURPOSE--FILL  THE MARGIN REGION ON THE SCREEN
4350C              (THE REGION OUTSIDE THE FRAME LINES).
4351C
4352C     WRITTEN BY--JAMES J. FILLIBEN
4353C                 STATISTICAL ENGINEERING DIVISION
4354C                 INFORMATION TECHNOLOGY LABORATORY
4355C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
4356C                 GAITHERSBURG, MD 20899-8980
4357C                 PHONE--301-975-2855
4358C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
4359C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
4360C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
4361C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
4362C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
4363C     LANGUAGE--ANSI FORTRAN (1977)
4364C     VERSION NUMBER--83.6
4365C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY       1983.
4366C     UPDATED         --FEBRUARY  1988.  STAR PLOT
4367C     UPDATED         --JUNE      1988.  CALL TO GRFIRE
4368C     UPDATED         --JANUARY   1989.  MODIFY CALL  TO GRFIRE (ALAN)
4369C
4370C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
4371C
4372      CHARACTER*4 ICASPL
4373      CHARACTER*4 ICAS3D
4374C
4375      CHARACTER*4 IMARCO
4376C
4377      CHARACTER*4 IFIG
4378      CHARACTER*4 IPATT
4379      CHARACTER*4 ICOLB
4380      CHARACTER*4 ICOLP
4381C
4382      CHARACTER*4 ICOL
4383C
4384      CHARACTER*4 ICASE
4385C
4386      CHARACTER*4 IHORPA
4387      CHARACTER*4 IVERPA
4388      CHARACTER*4 IDUPPA
4389      CHARACTER*4 IDDOPA
4390C
4391      CHARACTER*4 IPATT2
4392C
4393      DIMENSION PX(10)
4394      DIMENSION PY(10)
4395C
4396C-----COMMON----------------------------------------------------------
4397C
4398      INCLUDE 'DPCOGR.INC'
4399      INCLUDE 'DPCOBE.INC'
4400      INCLUDE 'DPCOP2.INC'
4401C
4402C
4403C-----START POINT-----------------------------------------------------
4404C
4405      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'FIMA')GOTO90
4406      WRITE(ICOUT,999)
4407  999 FORMAT(1X)
4408      CALL DPWRST('XXX','BUG ')
4409      WRITE(ICOUT,51)
4410   51 FORMAT('***** AT THE BEGINNING OF DPFIMA--')
4411      CALL DPWRST('XXX','BUG ')
4412      WRITE(ICOUT,52)PXMIN,PYMIN,PXMAX,PYMAX
4413   52 FORMAT('PXMIN,PYMIN,PXMAX,PYMAX = ',4F10.5)
4414      CALL DPWRST('XXX','BUG ')
4415      WRITE(ICOUT,53)ICASPL,ICAS3D
4416   53 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4)
4417      CALL DPWRST('XXX','BUG ')
4418      WRITE(ICOUT,54)IMARCO
4419   54 FORMAT('IMARCO = ',A4)
4420      CALL DPWRST('XXX','BUG ')
4421      WRITE(ICOUT,59)IBUGG4,ISUBG4,IERRG4
4422   59 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
4423      CALL DPWRST('XXX','BUG ')
4424   90 CONTINUE
4425C
4426      IPATT2='SOLI'
4427C
4428      IF(ICASPL.EQ.'PIEC')GOTO9000
4429      IF(ICASPL.EQ.'STAR')GOTO9000
4430      IF(ICAS3D.EQ.'ON')GOTO9000
4431C
4432C               **********************************
4433C               **  STEP 0--                    **
4434C               **  COPY OVER THE MARGIN COLOR  **
4435C               **********************************
4436C
4437      ICASE='REGI'
4438      IFIG='BOX'
4439      IPATT='SOLI'
4440      IF(IGCOLO.EQ.'OFF')IPATT='EMPT'
4441      PTHICK=0.0
4442      PXGAP=0.0
4443      PYGAP=0.0
4444      ICOLB=IMARCO
4445      ICOLP=IMARCO
4446C
4447C               **********************************************
4448C               **  STEP 1--                                **
4449C               **  TRANSLATE THE CHARACTER REPRESENTATION  **
4450C               **  OF THE FILL COLOR                       **
4451C               **  INTO A NUMERIC REPRESENTATION           **
4452C               **  WHICH CAN BE UNDERSTOOD BY THE          **
4453C               **  GRAPHICS DEVICE.                        **
4454C               **********************************************
4455C
4456      ICOL=ICOLB
4457      CALL GRTRCO(ICASE,ICOL,JCOL)
4458      JCOLB=JCOL
4459C
4460C               *******************************
4461C               **  STEP 2--                 **
4462C               **  SET THE FILL   COLOR     **
4463C               **  ON THE GRAPHICS DEVICE.  **
4464C               *******************************
4465C
4466      CALL GRSECO(ICASE,ICOL,JCOL)
4467C
4468C               **********************************************
4469C               **  STEP 3--                                **
4470C               **  TRANSLATE THE CHARACTER REPRESENTATION  **
4471C               **  OF THE FILL PATTERN                     **
4472C               **  INTO A NUMERIC REPRESENTATION           **
4473C               **  WHICH CAN BE UNDERSTOOD BY THE          **
4474C               **  GRAPHICS DEVICE.                        **
4475C               **********************************************
4476C
4477      CALL GRTRPA(ICASE,IPATT,PXGAP,PYGAP,
4478     1JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXGAP2,PYGAP2)
4479C
4480C               *******************************
4481C               **  STEP 4--                 **
4482C               **  SET THE FILL PATTERN     **
4483C               **  ON THE GRAPHICS DEVICE.  **
4484C               *******************************
4485C
4486      CALL GRSEPA(ICASE,IPATT,PXGAP,PYGAP,
4487     1JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXGAP2,PYGAP2)
4488C
4489C               **********************************************
4490C               **  STEP 5--                                **
4491C               **  TRANSLATE THE CHARACTER REPRESENTATION  **
4492C               **  OF THE PATTERN COLOR                    **
4493C               **  INTO A NUMERIC REPRESENTATION           **
4494C               **  WHICH CAN BE UNDERSTOOD BY THE          **
4495C               **  GRAPHICS DEVICE.                        **
4496C               **********************************************
4497C
4498      ICOL=ICOLP
4499      CALL GRTRCO(ICASE,ICOL,JCOL)
4500      JCOLP=JCOL
4501C
4502C               *******************************
4503C               **  STEP 6--                 **
4504C               **  SET THE PATTERN COLOR    **
4505C               **  ON THE GRAPHICS DEVICE.  **
4506C               *******************************
4507C
4508      CALL GRSECO(ICASE,ICOL,JCOL)
4509C
4510C               **********************************************
4511C               **  STEP 7--                                **
4512C               **  TRANSLATE THE  DESIRED                  **
4513C               **  LINE THICKNESS (OF THE PATTERN)         **
4514C               **  INTO A NUMERIC REPRESENTATION           **
4515C               **  WHICH CAN BE UNDERSTOOD BY THE          **
4516C               **  GRAPHICS DEVICE.                        **
4517C               **********************************************
4518C
4519      CALL GRTRTH(ICASE,PTHICK,JTHICK,PTHIC2)
4520C
4521C               *******************************
4522C               **  STEP 8--                 **
4523C               **  SET THE LINE THICKNESS   **
4524C               **  (OF THE PATTERN)         **
4525C               **  ON THE GRAPHICS DEVICE.  **
4526C               *******************************
4527C
4528      CALL GRSETH(ICASE,PTHICK,JTHICK,PTHIC2)
4529C
4530C               ***********************************
4531C               **  STEP 11--                    **
4532C               **  FILL  THE REGION             **
4533C               **  BELOW THE BOTTOM FRAME LINE  **
4534C               ***********************************
4535C
4536      PX(1)=0.0
4537      PY(1)=0.0
4538      PX(2)=100.0
4539      PY(2)=0.0
4540      PX(3)=100.0
4541      PY(3)=PYMIN
4542      PX(4)=0.0
4543      PY(4)=PYMIN
4544      NP=4
4545      CALL GRFIRE(PX,PY,NP,IFIG,
4546     1IPATT,JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXGAP2,PYGAP2,
4547     1PTHICK,JTHICK,PTHIC2,
4548     1ICOLB,JCOLB,ICOLP,JCOLP,
4549     1IPATT2)
4550C
4551C               ********************************************
4552C               **  STEP 12--                             **
4553C               **  FILL  THE REGION                      **
4554C               **  TO THE RIGHT OF THE RIGHT FRAME LINE  **
4555C               ********************************************
4556C
4557      PX(1)=PXMAX
4558      PY(1)=PYMIN
4559      PX(2)=100.0
4560      PY(2)=PYMIN
4561      PX(3)=100.0
4562      PY(3)=100.0
4563      PX(4)=PXMAX
4564      PY(4)=100.0
4565      NP=4
4566      CALL GRFIRE(PX,PY,NP,IFIG,
4567     1IPATT,JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXGAP2,PYGAP2,
4568     1PTHICK,JTHICK,PTHIC2,
4569     1ICOLB,JCOLB,ICOLP,JCOLP,
4570     1IPATT2)
4571C
4572C               ********************************
4573C               **  STEP 13--                 **
4574C               **  FILL  THE REGION          **
4575C               **  ABOVE THE TOP FRAME LINE  **
4576C               ********************************
4577C
4578      PX(1)=0.0
4579      PY(1)=PYMAX
4580      PX(2)=PXMAX
4581      PY(2)=PYMAX
4582      PX(3)=PXMAX
4583      PY(3)=100.0
4584      PX(4)=0.0
4585      PY(4)=100.0
4586      NP=4
4587      CALL GRFIRE(PX,PY,NP,IFIG,
4588     1IPATT,JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXGAP2,PYGAP2,
4589     1PTHICK,JTHICK,PTHIC2,
4590     1ICOLB,JCOLB,ICOLP,JCOLP,
4591     1IPATT2)
4592C
4593C               ******************************************
4594C               **  STEP 14--                           **
4595C               **  FILL  THE REGION                    **
4596C               **  TO THE LEFT OF THE LEFT FRAME LINE  **
4597C               ******************************************
4598C
4599      PX(1)=0.0
4600      PY(1)=PYMIN
4601      PX(2)=PXMIN
4602      PY(2)=PYMIN
4603      PX(3)=PXMIN
4604      PY(3)=PYMAX
4605      PX(4)=0.0
4606      PY(4)=PYMAX
4607      NP=4
4608      CALL GRFIRE(PX,PY,NP,IFIG,
4609     1IPATT,JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXGAP2,PYGAP2,
4610     1PTHICK,JTHICK,PTHIC2,
4611     1ICOLB,JCOLB,ICOLP,JCOLP,
4612     1IPATT2)
4613C
4614C               *****************
4615C               **  STEP 90--  **
4616C               **  EXIT       **
4617C               *****************
4618C
4619 9000 CONTINUE
4620      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'FIMA')GOTO9090
4621      WRITE(ICOUT,999)
4622      CALL DPWRST('XXX','BUG ')
4623      WRITE(ICOUT,9011)
4624 9011 FORMAT('***** AT THE END       OF DPFIMA--')
4625      CALL DPWRST('XXX','BUG ')
4626      WRITE(ICOUT,9012)PXMIN,PYMIN,PXMAX,PYMAX
4627 9012 FORMAT('PXMIN,PYMIN,PXMAX,PYMAX = ',4F10.5)
4628      CALL DPWRST('XXX','BUG ')
4629      WRITE(ICOUT,9013)ICASPL,ICAS3D
4630 9013 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4)
4631      CALL DPWRST('XXX','BUG ')
4632      WRITE(ICOUT,9014)IMARCO
4633 9014 FORMAT('IMARCO = ',A4)
4634      CALL DPWRST('XXX','BUG ')
4635      WRITE(ICOUT,9015)IFIG,IPATT,ICOLB,ICOLP
4636 9015 FORMAT('IFIG,IPATT,ICOLB,ICOLP = ',A4,2X,A4,2X,A4,2X,A4)
4637      CALL DPWRST('XXX','BUG ')
4638      WRITE(ICOUT,9019)IBUGG4,ISUBG4,IERRG4
4639 9019 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
4640      CALL DPWRST('XXX','BUG ')
4641 9090 CONTINUE
4642C
4643      RETURN
4644      END
4645      SUBROUTINE DPFIPW(IHARG,IARGT,ARG,NUMARG,DEFFPW,
4646     1FITPOW,IFOUND,IERROR)
4647C
4648C     PURPOSE--DEFINE THE POWER IN THE FIT CRITERION
4649C              IN THE FIT COMMAND (AND THE PRE-FIT COMMAND).
4650C              THE SPECIFIED FIT POWER VALUE WILL BE PLACED
4651C              IN THE FLOATING POINT VARIABLE FITPOW.
4652C     NOTE--POWER = 2 YIELDS THE LEAST SQUARES CRITERION.
4653C         --POWER = 1 YIELDS THE L1 CRITERION.
4654C         --POWER = INFINITY YIELDS THE MINIMAX CRITERION.
4655C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
4656C                     --IARGT  (A  HOLLERITH VECTOR)
4657C                     --ARG    (A  FLOATING POINT VECTOR)
4658C                     --NUMARG (AN INTEGER VARIABLE)
4659C                     --DEFFPW (A  FLOATING POINT VARIABLE)
4660C     OUTPUT ARGUMENTS--FITPOW (A  FLOATING POINT VARIABLE)
4661C                     --IFOUND ('YES' OR 'NO' )
4662C                     --IERROR ('YES' OR 'NO' )
4663C     WRITTEN BY--JAMES J. FILLIBEN
4664C                 STATISTICAL ENGINEERING DIVISION
4665C                 INFORMATION TECHNOLOGY LABORATORY
4666C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
4667C                 GAITHERSBURG, MD 20899-8980
4668C                 PHONE--301-975-2855
4669C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
4670C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
4671C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
4672C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
4673C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
4674C     LANGUAGE--ANSI FORTRAN (1977)
4675C     VERSION NUMBER--82/7
4676C     ORIGINAL VERSION--NOVEMBER 1980.
4677C     UPDATED         --MAY       1982.
4678C
4679C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
4680C
4681      CHARACTER*4 IHARG
4682      CHARACTER*4 IARGT
4683      CHARACTER*4 IFOUND
4684      CHARACTER*4 IERROR
4685C
4686C---------------------------------------------------------------------
4687C
4688      DIMENSION IHARG(*)
4689      DIMENSION IARGT(*)
4690      DIMENSION ARG(*)
4691C
4692C---------------------------------------------------------------------
4693C
4694      INCLUDE 'DPCOP2.INC'
4695C
4696C-----START POINT-----------------------------------------------------
4697C
4698      IFOUND='NO'
4699      IERROR='NO'
4700C
4701      IF(NUMARG.EQ.0)GOTO1199
4702      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'=')GOTO1199
4703      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'POWE')GOTO1110
4704      GOTO1199
4705C
4706 1110 CONTINUE
4707      IF(IHARG(NUMARG).EQ.'POWE')GOTO1150
4708      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
4709      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
4710      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
4711      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
4712      IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160
4713      GOTO1120
4714C
4715 1120 CONTINUE
4716      IERROR='YES'
4717      WRITE(ICOUT,1121)
4718 1121 FORMAT('***** ERROR IN DPFIPW--')
4719      CALL DPWRST('XXX','BUG ')
4720      WRITE(ICOUT,1122)
4721 1122 FORMAT('      ILLEGAL FORM FOR FIT POWER ',
4722     1'COMMAND.')
4723      CALL DPWRST('XXX','BUG ')
4724      WRITE(ICOUT,1124)
4725 1124 FORMAT('      TEST EXAMPLE TO DEMONSTRATE THE ',
4726     1'PROPER FORM--')
4727      CALL DPWRST('XXX','BUG ')
4728      WRITE(ICOUT,1125)
4729 1125 FORMAT('      SUPPOSE THE THE ANALYST WILL BE CARRYING OUT  ')
4730      CALL DPWRST('XXX','BUG ')
4731      WRITE(ICOUT,1126)
4732 1126 FORMAT('      A FIT , ')
4733      CALL DPWRST('XXX','BUG ')
4734      WRITE(ICOUT,1127)
4735 1127 FORMAT('      AND SUPPOSE THE ANALYST WISHES TO USE  ')
4736      CALL DPWRST('XXX','BUG ')
4737      WRITE(ICOUT,1128)
4738 1128 FORMAT('      POWER OF 1.5 IN THE FIT CRITERION; ')
4739      CALL DPWRST('XXX','BUG ')
4740      WRITE(ICOUT,1130)
4741 1130 FORMAT('      THEN THE ALLOWABLE FORM IS--')
4742      CALL DPWRST('XXX','BUG ')
4743      WRITE(ICOUT,1131)
4744 1131 FORMAT('      FIT POWER 1.5 ')
4745      CALL DPWRST('XXX','BUG ')
4746      GOTO1199
4747C
4748 1150 CONTINUE
4749      HOLD=DEFFPW
4750      GOTO1180
4751C
4752 1160 CONTINUE
4753      HOLD=ARG(NUMARG)
4754      GOTO1180
4755C
4756 1180 CONTINUE
4757      IFOUND='YES'
4758      FITPOW=HOLD
4759C
4760      IF(IFEEDB.EQ.'OFF')GOTO1189
4761      WRITE(ICOUT,999)
4762  999 FORMAT(1X)
4763      CALL DPWRST('XXX','BUG ')
4764      WRITE(ICOUT,1181)FITPOW
4765 1181 FORMAT('THE FIT POWER HAS JUST BEEN SET TO ',
4766     1E15.7)
4767      CALL DPWRST('XXX','BUG ')
4768 1189 CONTINUE
4769      GOTO1199
4770C
4771 1199 CONTINUE
4772      RETURN
4773      END
4774      SUBROUTINE DPFIRE(PX,PY,NP,
4775     1                  IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,
4776     1                  IPATT2)
4777C  ABOVE LINE ADDED SEPTEMBER, 1987
4778C  CONTAINS THE PATTERN FOR THE LINE (I.E., SOLID DASH, ETC.)
4779C
4780C
4781C     PURPOSE--FOR A GENERAL GRAPHICS DEVICE,
4782C              FILL THE REGION
4783C              DEFINED BY THE VERTICES AS GIVEN
4784C              IN THE PX(.) AND PY(.) VECTORS.
4785C              THIS REGION HAS SPECIFIED FILL PATTERN,
4786C              BACKGROUND COLOR, PATTERN LINE THICKNESS,
4787C              PATTERN LINE GAPCING, AND PATTERN COLOR.
4788C
4789C     NOTE--THE COORDINATES IN (PX(.),PY(.)) ARE IN
4790C           STANDARDIZED (0.0 TO 100.0) UNITS.
4791C     NOTE--THERE ARE NP SUCH COORDINATE PAIRS.
4792C           (BUT NP SHOULD ALWAYS = 2 FOR THIS SUBROUTINE).
4793C
4794C     WRITTEN BY--JAMES J. FILLIBEN
4795C                 STATISTICAL ENGINEERING DIVISION
4796C                 INFORMATION TECHNOLOGY LABORATORY
4797C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
4798C                 GAITHERSBURG, MD 20899-8980
4799C                 PHONE--301-975-2855
4800C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
4801C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
4802C     LANGUAGE--ANSI FORTRAN (1977)
4803C     VERSION NUMBER--83.6
4804C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY       1983.
4805C     UPDATED         --JANUARY   1989.  ADDED PARAMETER TO CALL LIST (ALAN)
4806C     UPDATED         --JANUARY   1989.  MODIFY CALL  TO GRFIRE (ALAN)
4807C     UPDATED         --JANUARY   1989.  BUGS FOR BAR PLOT COMMAND (ALAN)
4808C     UPDATED         --MARCH     1990.  MOVE CALL TO SEPA BEFORE COLOR
4809C                                        ROUTINES.  EITHER SET PATTERN
4810C                                        OR FILL COLOR, BUT NOT BOTH (PATTERN
4811C                                        COLOR WAS OVER-RIDING FILL COLOR)
4812C
4813C-----NON-COMMON VARIABLES (GRAPHICS)----------------------------------
4814C
4815      CHARACTER*4 IFIG
4816      CHARACTER*4 IPATT
4817      CHARACTER*4 ICOL
4818      CHARACTER*4 ICOLF
4819      CHARACTER*4 ICOLP
4820      CHARACTER*4 ICASE
4821      CHARACTER*4 IHORPA
4822      CHARACTER*4 IVERPA
4823      CHARACTER*4 IDUPPA
4824      CHARACTER*4 IDDOPA
4825      CHARACTER*4 IPATT2
4826C
4827      DIMENSION PX(*)
4828      DIMENSION PY(*)
4829C
4830C-----COMMON----------------------------------------------------------
4831C
4832      INCLUDE 'DPCOGR.INC'
4833      INCLUDE 'DPCOBE.INC'
4834      INCLUDE 'DPCOP2.INC'
4835C
4836C-----START POINT-----------------------------------------------------
4837C
4838      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'FIRE')THEN
4839        WRITE(ICOUT,999)
4840  999   FORMAT(1X)
4841        CALL DPWRST('XXX','BUG ')
4842        WRITE(ICOUT,51)
4843   51   FORMAT('***** AT THE BEGINNING OF DPFIRE--')
4844        CALL DPWRST('XXX','BUG ')
4845        WRITE(ICOUT,54)NP,IFIG,IPATT,ICOLF,ICOLP
4846   54   FORMAT('NP,IFIG,IPATT,ICOLF,ICOLP = ',I8,4(2X,A4))
4847        CALL DPWRST('XXX','BUG ')
4848        DO55I=1,NP
4849          WRITE(ICOUT,56)PX(I),PY(I)
4850   56     FORMAT('PX(I),PY(I) = ',2G15.7)
4851          CALL DPWRST('XXX','BUG ')
4852   55   CONTINUE
4853        WRITE(ICOUT,64)PTHICK,PXGAP,PYGAP
4854   64   FORMAT('PTHICK,PXGAP,PYGAP = ',3G15.7)
4855        CALL DPWRST('XXX','BUG ')
4856        WRITE(ICOUT,69)IBUGG4,ISUBG4,IERRG4
4857   69   FORMAT('IBUGG4,ISUBG4,IERRG4 = ',2(A4,2X),A4)
4858        CALL DPWRST('XXX','BUG ')
4859      ENDIF
4860C
4861      ICASE='REGI'
4862C  FOLLOWING BLOCK MOVED MARCH, 1990.  PATTERN COLOR WAS
4863C  OVERRIDING FILL COLOR.  DETERMINE WHICH ONE TO CALL
4864C  (EITHER PATTERN OR FILL, BUT NOT BOTH)
4865C
4866C               **********************************************
4867C               **  STEP X--                                **
4868C               **  TRANSLATE THE CHARACTER REPRESENTATION  **
4869C               **  OF THE FILL PATTERN                     **
4870C               **  INTO A NUMERIC REPRESENTATION           **
4871C               **  WHICH CAN BE UNDERSTOOD BY THE          **
4872C               **  GRAPHICS DEVICE.                        **
4873C               **********************************************
4874C
4875      CALL GRTRPA(ICASE,IPATT,PXGAP,PYGAP,
4876     1JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXGAP2,PYGAP2)
4877C
4878C               *******************************
4879C               **  STEP X--                 **
4880C               **  SET THE FILL PATTERN     **
4881C               **  ON THE GRAPHICS DEVICE.  **
4882C               *******************************
4883C
4884      CALL GRSEPA(ICASE,IPATT,PXGAP,PYGAP,
4885     1JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXGAP2,PYGAP2)
4886C
4887      IF(IPATT.EQ.'SOLI')GOTO1099
4888      IF(IPATT.EQ.'FILL')GOTO1099
4889      GOTO1199
4890 1099 CONTINUE
4891C
4892C               **********************************************
4893C               **  STEP 1--                                **
4894C               **  TRANSLATE THE CHARACTER REPRESENTATION  **
4895C               **  OF THE FILL COLOR                       **
4896C               **  INTO A NUMERIC REPRESENTATION           **
4897C               **  WHICH CAN BE UNDERSTOOD BY THE          **
4898C               **  GRAPHICS DEVICE.                        **
4899C               **********************************************
4900C
4901      ICOL=ICOLF
4902      CALL GRTRCO(ICASE,ICOL,JCOL)
4903      JCOLF=JCOL
4904      JCOLP=JCOL
4905C
4906C               *******************************
4907C               **  STEP 2--                 **
4908C               **  SET THE FILL   COLOR     **
4909C               **  ON THE GRAPHICS DEVICE.  **
4910C               *******************************
4911C
4912      CALL GRSECO(ICASE,ICOL,JCOL)
4913C  FOLLOWING LINE ADDED MARCH 1990.
4914      GOTO1999
4915C
4916C               **********************************************
4917C               **  STEP 3--                                **
4918C               **  TRANSLATE THE CHARACTER REPRESENTATION  **
4919C               **  OF THE FILL PATTERN                     **
4920C               **  INTO A NUMERIC REPRESENTATION           **
4921C               **  WHICH CAN BE UNDERSTOOD BY THE          **
4922C               **  GRAPHICS DEVICE.                        **
4923C               **********************************************
4924C
4925CCCCC CALL GRTRPA(ICASE,IPATT,PXGAP,PYGAP,
4926CCCCC1JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXGAP2,PYGAP2)
4927C
4928C               *******************************
4929C               **  STEP 4--                 **
4930C               **  SET THE FILL PATTERN     **
4931C               **  ON THE GRAPHICS DEVICE.  **
4932C               *******************************
4933C
4934CCCCC CALL GRSEPA(ICASE,IPATT,PXGAP,PYGAP,
4935CCCCC1JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXGAP2,PYGAP2)
4936C
4937C               **********************************************
4938C               **  STEP 5--                                **
4939C               **  TRANSLATE THE CHARACTER REPRESENTATION  **
4940C               **  OF THE PATTERN COLOR                    **
4941C               **  INTO A NUMERIC REPRESENTATION           **
4942C               **  WHICH CAN BE UNDERSTOOD BY THE          **
4943C               **  GRAPHICS DEVICE.                        **
4944C               **********************************************
4945C
4946CCCCC FOLLOWING LINE ADDED MARCH 1990.
4947 1199 CONTINUE
4948      ICOL=ICOLP
4949      CALL GRTRCO(ICASE,ICOL,JCOL)
4950      JCOLP=JCOL
4951C
4952C               *******************************
4953C               **  STEP 6--                 **
4954C               **  SET THE PATTERN COLOR    **
4955C               **  ON THE GRAPHICS DEVICE.  **
4956C               *******************************
4957C
4958      CALL GRSECO(ICASE,ICOL,JCOL)
4959CCCCC FOLLOWING LINE ADDED MARCH 1990.
4960 1999 CONTINUE
4961C
4962C               **********************************************
4963C               **  STEP 7--                                **
4964C               **  TRANSLATE THE  DESIRED                  **
4965C               **  LINE THICKNESS (OF THE PATTERN)         **
4966C               **  INTO A NUMERIC REPRESENTATION           **
4967C               **  WHICH CAN BE UNDERSTOOD BY THE          **
4968C               **  GRAPHICS DEVICE.                        **
4969C               **********************************************
4970C
4971      CALL GRTRTH(ICASE,PTHICK,JTHICK,PTHIC2)
4972C
4973C               *******************************
4974C               **  STEP 8--                 **
4975C               **  SET THE LINE THICKNESS   **
4976C               **  (OF THE PATTERN)         **
4977C               **  ON THE GRAPHICS DEVICE.  **
4978C               *******************************
4979C
4980      CALL GRSETH(ICASE,PTHICK,JTHICK,PTHIC2)
4981C
4982C               *********************
4983C               **  STEP 11--      **
4984C               **  FILL  THE BOX  **
4985C               *********************
4986C
4987      CALL GRFIRE(PX,PY,NP,IFIG,
4988     1            IPATT,JPATT,IHORPA,IVERPA,
4989     1            IDUPPA,IDDOPA,PXGAP2,PYGAP2,
4990     1            PTHICK,JTHICK,PTHIC2,
4991     1            ICOLF,JCOLF,ICOLP,JCOLP,
4992     1            IPATT2)
4993C
4994C               *****************
4995C               **  STEP 90--  **
4996C               **  EXIT       **
4997C               *****************
4998C
4999      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'FIRE')THEN
5000        WRITE(ICOUT,999)
5001        CALL DPWRST('XXX','BUG ')
5002        WRITE(ICOUT,9011)
5003 9011   FORMAT('***** AT THE END       OF DPFIRE--')
5004        CALL DPWRST('XXX','BUG ')
5005      ENDIF
5006C
5007      RETURN
5008      END
5009      SUBROUTINE DPFIRT(MAXNXT,ICAPSW,IFORSW,
5010     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
5011C
5012C     PURPOSE--CARRY OUT A 2-SAMPLE FISHER RANDOMIZATION TEST
5013C     EXAMPLE--FISHER TWO SAMPLE RANDOMIZATION TEST Y1 Y2
5014C              FISHER TWO SAMPLE RANDOMIZATION TEST Y1 Y2 Y3 Y4
5015C              FISHER TWO SAMPLE RANDOMIZATION TEST Y1 TO Y10
5016C     WRITTEN BY--ALAN HECKERT
5017C                 STATISTICAL ENGINEERING DIVISION
5018C                 INFORMATION TECHNOLOGY LABORATORY
5019C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
5020C                 GAITHERSBURG, MD 20899-8980
5021C                 PHONE--301-975-2899
5022C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
5023C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
5024C     LANGUAGE--ANSI FORTRAN (1977)
5025C     VERSION NUMBER--2011/6
5026C     ORIGINAL VERSION--JUNE      2011.
5027C
5028C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
5029C
5030      CHARACTER*4 ICAPSW
5031      CHARACTER*4 IFORSW
5032      CHARACTER*4 IBUGA2
5033      CHARACTER*4 IBUGA3
5034      CHARACTER*4 IBUGQ
5035      CHARACTER*4 ISUBRO
5036      CHARACTER*4 IFOUND
5037      CHARACTER*4 IERROR
5038C
5039      CHARACTER*4 ICASAN
5040      CHARACTER*4 ICTMP1
5041      CHARACTER*4 ICTMP2
5042      CHARACTER*4 ICTMP3
5043      CHARACTER*4 ICTMP4
5044      CHARACTER*4 ICTMP5
5045      CHARACTER*4 ISUBN1
5046      CHARACTER*4 ISUBN2
5047      CHARACTER*4 ISTEPN
5048      CHARACTER*4 ICASE
5049      CHARACTER*4 IVARID
5050      CHARACTER*4 IVARI2
5051      CHARACTER*4 IVARI3
5052      CHARACTER*4 IVARI4
5053      CHARACTER*40 INAME
5054      PARAMETER (MAXSPN=30)
5055      CHARACTER*4 IVARN1(MAXSPN)
5056      CHARACTER*4 IVARN2(MAXSPN)
5057      CHARACTER*4 IVARTY(MAXSPN)
5058      REAL PVAR(MAXSPN)
5059      INTEGER ILIS(MAXSPN)
5060      INTEGER NRIGHT(MAXSPN)
5061      INTEGER ICOLR(MAXSPN)
5062C
5063      CHARACTER*4 IFLAGU
5064      LOGICAL IFRST
5065      LOGICAL ILAST
5066C
5067C---------------------------------------------------------------------
5068C
5069C-----COMMON----------------------------------------------------------
5070C
5071      INCLUDE 'DPCOPA.INC'
5072      INCLUDE 'DPCOZZ.INC'
5073      INCLUDE 'DPCOZI.INC'
5074      INCLUDE 'DPCOHK.INC'
5075      INCLUDE 'DPCOSU.INC'
5076      INCLUDE 'DPCODA.INC'
5077      INCLUDE 'DPCOHO.INC'
5078      INCLUDE 'DPCOST.INC'
5079C
5080      DIMENSION TEMP1(MAXOBV)
5081      DIMENSION TEMP2(MAXOBV)
5082      DIMENSION ITEMP1(MAXOBV)
5083      EQUIVALENCE(GARBAG(IGARB1),TEMP1(1))
5084      EQUIVALENCE(GARBAG(IGARB3),TEMP2(1))
5085      EQUIVALENCE(IGARBG(IIGAR1),ITEMP1(1))
5086C
5087C-----COMMON VARIABLES (GENERAL)--------------------------------------
5088C
5089      INCLUDE 'DPCOP2.INC'
5090C
5091C-----START POINT-----------------------------------------------------
5092C
5093      ISUBN1='DPFI'
5094      ISUBN2='RT  '
5095      IFOUND='NO'
5096      IERROR='NO'
5097C
5098      MAXCP1=MAXCOL+1
5099      MAXCP2=MAXCOL+2
5100      MAXCP3=MAXCOL+3
5101      MAXCP4=MAXCOL+4
5102      MAXCP5=MAXCOL+5
5103      MAXCP6=MAXCOL+6
5104C
5105C               ************************************************
5106C               **  TREAT THE FISHER TWO SAMPLE RANDOMIZATION **
5107C               **  TEST CASE                                 **
5108C               ************************************************
5109C
5110      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FIRT')THEN
5111        WRITE(ICOUT,999)
5112  999   FORMAT(1X)
5113        CALL DPWRST('XXX','BUG ')
5114        WRITE(ICOUT,51)
5115   51   FORMAT('***** AT THE BEGINNING OF DPFIRT--')
5116        CALL DPWRST('XXX','BUG ')
5117        WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ,ISUBRO,MAXNXT
5118   52   FORMAT('IBUGA2,IBUGA3,IBUGQ,ISUBRO = ',4(A4,2X),I8)
5119        CALL DPWRST('XXX','BUG ')
5120      ENDIF
5121C
5122C               *********************************************************
5123C               **  STEP 1--                                           **
5124C               **  EXTRACT THE COMMAND                                **
5125C               *********************************************************
5126C
5127      ISTEPN='1'
5128      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FIRT')
5129     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5130C
5131      ILASTZ=9999
5132      ICASAN='2FRT'
5133C
5134C     LOOK FOR:
5135C
5136C          FISHER TWO SAMPLE RANDOMIZATION TEST
5137C
5138      DO100I=0,NUMARG-1
5139C
5140        IF(I.EQ.0)THEN
5141          ICTMP1=ICOM
5142        ELSE
5143          ICTMP1=IHARG(I)
5144        ENDIF
5145        ICTMP2=IHARG(I+1)
5146        ICTMP3=IHARG(I+2)
5147        ICTMP4=IHARG(I+3)
5148        ICTMP5=IHARG(I+4)
5149C
5150        IF(ICTMP1.EQ.'=')THEN
5151          IFOUND='NO'
5152          GOTO9000
5153        ELSEIF(ICTMP1.EQ.'FISH' .AND. ICTMP2.EQ.'TWO ' .AND.
5154     1         ICTMP3.EQ.'SAMP' .AND. ICTMP4.EQ.'RAND' .AND.
5155     1         ICTMP5.EQ.'TEST')THEN
5156          IFOUND='YES'
5157          ILASTZ=I+4
5158        ELSEIF(ICTMP1.EQ.'FISH' .AND. ICTMP2.EQ.'TWO' .AND.
5159     1         ICTMP3.EQ.'SAMP' .AND. ICTMP4.EQ.'RAND ')THEN
5160          IFOUND='YES'
5161          ILASTZ=I+3
5162        ELSEIF(ICTMP1.EQ.'FISH' .AND. ICTMP2.EQ.'TWO' .AND.
5163     1         ICTMP3.EQ.'SAMP' .AND. ICTMP4.EQ.'TEST ')THEN
5164          IFOUND='YES'
5165          ILASTZ=I+3
5166        ENDIF
5167  100 CONTINUE
5168C
5169      IF(IFOUND.EQ.'NO')GOTO9000
5170C
5171      ISHIFT=ILASTZ
5172      CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
5173     1            IBUGA2,IERROR)
5174C
5175      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FIRT')THEN
5176        WRITE(ICOUT,91)ICASAN,ISHIFT
5177   91   FORMAT('DPFIRT: ICASAN,ISHIFT = ',A4,2X,A4)
5178        CALL DPWRST('XXX','BUG ')
5179      ENDIF
5180C
5181C               ****************************************
5182C               **  STEP 2--                          **
5183C               **  EXTRACT THE VARIABLE LIST         **
5184C               ****************************************
5185C
5186      ISTEPN='2'
5187      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FIRT')
5188     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5189C
5190      INAME='FISHER TWO SAMPLE RANDOMIZATION TEST'
5191      MINNA=1
5192      MAXNA=100
5193      MINN2=2
5194      IFLAGE=0
5195      IFLAGM=1
5196      MINNVA=2
5197      MAXNVA=MAXSPN
5198      IFLAGP=0
5199      JMIN=1
5200      JMAX=NUMARG
5201C
5202      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
5203     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
5204     1            JMIN,JMAX,
5205     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
5206     1            IVARN1,IVARN2,IVARTY,PVAR,
5207     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
5208     1            MINNVA,MAXNVA,
5209     1            IFLAGM,IFLAGP,
5210     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
5211      IF(IERROR.EQ.'YES')GOTO9000
5212C
5213      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FIRT')THEN
5214        WRITE(ICOUT,999)
5215        CALL DPWRST('XXX','BUG ')
5216        WRITE(ICOUT,281)
5217  281   FORMAT('***** AFTER CALL DPPARS--')
5218        CALL DPWRST('XXX','BUG ')
5219        WRITE(ICOUT,282)NQ,NUMVAR
5220  282   FORMAT('NQ,NUMVAR = ',2I8)
5221        CALL DPWRST('XXX','BUG ')
5222        IF(NUMVAR.GT.0)THEN
5223          DO285I=1,NUMVAR
5224            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
5225     1                      ICOLR(I)
5226  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
5227     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
5228            CALL DPWRST('XXX','BUG ')
5229  285     CONTINUE
5230        ENDIF
5231      ENDIF
5232C
5233C               ******************************************************
5234C               **  STEP 3A--                                       **
5235C               **  CASE 1: TWO RESPONSE VARIABLES, NO REPLICATION  **
5236C               **          HANDLE MULTIPLE RESPONSE VARIABLES      **
5237C               **          DIFFERENTLY FOR ONE SAMPLE AND TWO      **
5238C               **          SAMPLE TESTS.                           **
5239C               ******************************************************
5240C
5241      ISTEPN='3A'
5242      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FIRT')
5243     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5244C
5245      NUMVA2=1
5246      DO5210I=1,NUMVAR
5247        ICOL=I
5248        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
5249     1              INAME,IVARN1,IVARN2,IVARTY,
5250     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
5251     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
5252     1              MAXCP4,MAXCP5,MAXCP6,
5253     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
5254     1              Y,Y,Y,NS1,NLOCA2,NLOCA3,ICASE,
5255     1              IBUGA3,ISUBRO,IFOUND,IERROR)
5256        IF(IERROR.EQ.'YES')GOTO9000
5257C
5258        ISTRT2=I+1
5259        ISTOP2=NUMVAR
5260C
5261        DO5220J=ISTRT2,ISTOP2
5262C
5263          ICOL=J
5264          CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
5265     1                INAME,IVARN1,IVARN2,IVARTY,
5266     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
5267     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
5268     1                MAXCP4,MAXCP5,MAXCP6,
5269     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
5270     1                X,X,X,NS2,NLOCA2,NLOCA3,ICASE,
5271     1                IBUGA3,ISUBRO,IFOUND,IERROR)
5272          IF(IERROR.EQ.'YES')GOTO9000
5273C
5274C               *****************************************************
5275C               **  STEP 52--                                      **
5276C               **  PERFORM A FISHER TWO SAMPLE RANDOMIZATION TEST **
5277C               *****************************************************
5278C
5279          ISTEPN='52'
5280          IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FIRT')THEN
5281            CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5282            WRITE(ICOUT,999)
5283            CALL DPWRST('XXX','BUG ')
5284            WRITE(ICOUT,5211)
5285 5211       FORMAT('***** FROM DPFIRT, BEFORE CALL DPMNN2--')
5286            CALL DPWRST('XXX','BUG ')
5287            WRITE(ICOUT,5212)I,J,NS1,NS2,MAXN
5288 5212       FORMAT('I,J,NS1,NS2,MAXN = ',5I8)
5289            CALL DPWRST('XXX','BUG ')
5290            DO5215II=1,MAX(NS1,NS2)
5291              WRITE(ICOUT,5216)II,Y(II),X(II)
5292 5216         FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
5293              CALL DPWRST('XXX','BUG ')
5294 5215       CONTINUE
5295          ENDIF
5296C
5297          IVARID=IVARN1(I)
5298          IVARI2=IVARN2(I)
5299          IVARI3=IVARN1(J)
5300          IVARI4=IVARN2(J)
5301          CALL DPFIR2(Y,NS1,X,NS2,ICASAN,
5302     1               TEMP1,TEMP2,ITEMP1,MAXNXT,
5303     1               ICAPSW,ICAPTY,IFORSW,
5304     1               IVARID,IVARI2,IVARI3,IVARI4,
5305     1               STATVA,PVAL2T,PVALLT,
5306     1               IBUGA3,ISUBRO,IERROR)
5307          IF(IERROR.EQ.'YES')GOTO9000
5308C
5309C               ***************************************
5310C               **  STEP 8C--                        **
5311C               **  UPDATE INTERNAL DATAPLOT TABLES  **
5312C               ***************************************
5313C
5314          ISTEPN='8C'
5315          IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FIRT')
5316     1      CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5317C
5318          IF(NUMVAR.GT.2)THEN
5319            IFLAGU='FILE'
5320          ELSE
5321            IFLAGU='ON'
5322          ENDIF
5323          IFRST=.FALSE.
5324          ILAST=.FALSE.
5325          IF(I.EQ.1 .AND. J.EQ.2)IFRST=.TRUE.
5326          IF(I.EQ.NUMVAR .AND. J.EQ.NUMVAR)ILAST=.TRUE.
5327          CALL DPFIR5(STATVA,PVAL2T,PVALLT,
5328     1                IFLAGU,IFRST,ILAST,
5329     1                IBUGA2,IBUGA3,ISUBRO,IERROR)
5330C
5331 5220   CONTINUE
5332 5210 CONTINUE
5333C
5334C               *****************
5335C               **  STEP 90--  **
5336C               **  EXIT       **
5337C               *****************
5338C
5339 9000 CONTINUE
5340      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FIRT')THEN
5341        WRITE(ICOUT,999)
5342        CALL DPWRST('XXX','BUG ')
5343        WRITE(ICOUT,9011)
5344 9011   FORMAT('***** AT THE END       OF DPFIRT--')
5345        CALL DPWRST('XXX','BUG ')
5346        WRITE(ICOUT,9016)IFOUND,IERROR
5347 9016   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
5348        CALL DPWRST('XXX','BUG ')
5349      ENDIF
5350C
5351      RETURN
5352      END
5353      SUBROUTINE DPFIR2(Y1,N1,Y2,N2,ICASAN,
5354     1                  TEMP1,TEMP2,ITEMP1,MAXNXT,
5355     1                  ICAPSW,ICAPTY,IFORSW,
5356     1                  IVARID,IVARI2,IVARI3,IVARI4,
5357     1                  STATVA,PVAL2T,PVALLT,
5358     1                  IBUGA3,ISUBRO,IERROR)
5359C
5360C     PURPOSE--THIS ROUTINE CARRIES OUT A 2-SAMPLE FISHER RANDOMIZATION
5361C              TEST.
5362C              SAMPLE 1 IS IN INPUT VECTOR Y1 (WITH N1 OBSERVATIONS).
5363C              SAMPLE 2 IS IN INPUT VECTOR Y2 (WITH N2 OBSERVATIONS).
5364C     EXAMPLE--FISHER TWO SAMPLE RANDOMIZATION TEST Y1 Y2
5365C     REFERENCE--RICHARDS (1996), "FISHER'S RANDOMIZATION TEST FOR
5366C                TWO SMALL INDEPENDENT SAMPLES", APPLIED STATISTICS,
5367C                VOL. 45, NO. 3, PP. 394-398.
5368C                THIS ROUTINE CALLS RICHARD'S ALGORITHM (FISHER)
5369C                TO IMPLEMENT THIS TEST.
5370C     WRITTEN BY--ALAN HECKERT
5371C                 STATISTICAL ENGINEERING DIVISION
5372C                 INFORMATION TECHNOLOGY LABORATORY
5373C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
5374C                 GAITHERSBURG, MD 20899-8980
5375C                 PHONE--301-975-2899
5376C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
5377C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
5378C     LANGUAGE--ANSI FORTRAN (1977)
5379C     VERSION NUMBER--2011/6
5380C     ORIGINAL VERSION--JUNE      2011.
5381C
5382C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
5383C
5384      CHARACTER*4 IVARID
5385      CHARACTER*4 IVARI2
5386      CHARACTER*4 IVARI3
5387      CHARACTER*4 IVARI4
5388      CHARACTER*4 ICAPSW
5389      CHARACTER*4 ICAPTY
5390      CHARACTER*4 IFORSW
5391      CHARACTER*4 ICASAN
5392      CHARACTER*4 IBUGA3
5393      CHARACTER*4 ISUBRO
5394      CHARACTER*4 IERROR
5395C
5396      CHARACTER*4 IWRITE
5397C
5398      CHARACTER*4 ISUBN1
5399      CHARACTER*4 ISUBN2
5400      CHARACTER*4 ISTEPN
5401C
5402C---------------------------------------------------------------------
5403C
5404      DIMENSION Y1(*)
5405      DIMENSION Y2(*)
5406      DIMENSION TEMP1(*)
5407      DIMENSION TEMP2(*)
5408      DIMENSION ITEMP1(*)
5409C
5410      REAL MEANX
5411      REAL MEANY
5412C
5413      PARAMETER (MAXROW=25)
5414      CHARACTER*60 ITITLE
5415      CHARACTER*60 ITITLZ
5416      CHARACTER*60 ITEXT(MAXROW)
5417      REAL         AVALUE(MAXROW)
5418      INTEGER      NCTEXT(MAXROW)
5419      INTEGER      IDIGIT(MAXROW)
5420      INTEGER      NTOT(MAXROW)
5421      LOGICAL IFRST
5422      LOGICAL ILAST
5423C
5424C---------------------------------------------------------------------
5425C
5426      INCLUDE 'DPCOP2.INC'
5427C
5428C-----START POINT-----------------------------------------------------
5429C
5430      ISUBN1='DPFI'
5431      ISUBN2='R2  '
5432      IERROR='NO'
5433      IWRITE='OFF'
5434C
5435      NUMDIG=7
5436      IF(IFORSW.EQ.'1')NUMDIG=1
5437      IF(IFORSW.EQ.'2')NUMDIG=2
5438      IF(IFORSW.EQ.'3')NUMDIG=3
5439      IF(IFORSW.EQ.'4')NUMDIG=4
5440      IF(IFORSW.EQ.'5')NUMDIG=5
5441      IF(IFORSW.EQ.'6')NUMDIG=6
5442      IF(IFORSW.EQ.'7')NUMDIG=7
5443      IF(IFORSW.EQ.'8')NUMDIG=8
5444      IF(IFORSW.EQ.'9')NUMDIG=9
5445      IF(IFORSW.EQ.'0')NUMDIG=0
5446      IF(IFORSW.EQ.'E')NUMDIG=-2
5447      IF(IFORSW.EQ.'-2')NUMDIG=-2
5448      IF(IFORSW.EQ.'-3')NUMDIG=-3
5449      IF(IFORSW.EQ.'-4')NUMDIG=-4
5450      IF(IFORSW.EQ.'-5')NUMDIG=-5
5451      IF(IFORSW.EQ.'-6')NUMDIG=-6
5452      IF(IFORSW.EQ.'-7')NUMDIG=-7
5453      IF(IFORSW.EQ.'-8')NUMDIG=-8
5454      IF(IFORSW.EQ.'-9')NUMDIG=-9
5455C
5456      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FIR2')THEN
5457        WRITE(ICOUT,999)
5458  999   FORMAT(1X)
5459        CALL DPWRST('XXX','WRIT')
5460        WRITE(ICOUT,51)
5461   51   FORMAT('**** AT THE BEGINNING OF DPFIR2--')
5462        CALL DPWRST('XXX','WRIT')
5463        WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASAN
5464   52   FORMAT('IBUGA3,ISUBRO,ICASAN = ',2(A4,2X),A4)
5465        CALL DPWRST('XXX','WRIT')
5466        WRITE(ICOUT,53)IVARID,IVARI2,IVARI3,IVARI4
5467   53   FORMAT('IVARID,IVARI2,IVARI3,IVARI4 = ',3(A4,2X),A4)
5468        CALL DPWRST('XXX','WRIT')
5469        WRITE(ICOUT,55)N1,N2,NUMDIG
5470   55   FORMAT('N1,N2,NUMDIG = ',3I8)
5471        CALL DPWRST('XXX','WRIT')
5472        IF(N1.GE.1)THEN
5473          DO56I=1,MAX(N1,N2)
5474            WRITE(ICOUT,57)I,Y1(I),Y2(I)
5475   57       FORMAT('I,Y1(I),Y2(I) = ',I8,2G15.7)
5476            CALL DPWRST('XXX','WRIT')
5477   56     CONTINUE
5478        ENDIF
5479      ENDIF
5480C
5481C               ************************************
5482C               **   STEP 1--                     **
5483C               **   CALL FISHER TO COMPUTE THE   **
5484C               **   BASIC TEST STATISTIC         **
5485C               ************************************
5486C
5487      ISTEPN='1'
5488      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIR2')
5489     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5490C
5491      IF(MAXNXT.GE.1000000)THEN
5492        MAXSAM=22
5493      ELSE
5494        MAXSAM=20
5495      ENDIF
5496      SUMX=CPUMIN
5497      SUMY=CPUMIN
5498      MEANX=CPUMIN
5499      MEANY=CPUMIN
5500      PTEMP=CPUMIN
5501      CALL FISHER(Y1,N1,Y2,N2,ITOTAL,POSSIB,PVAL,
5502     1            SUMX,SUMY,MEANX,MEANY,
5503     1            TEMP1,TEMP2,ITEMP1,MAXSAM,MAXNXT,
5504     1            IFAULT,IBUGA3)
5505C
5506      IF(IFAULT.EQ.1)THEN
5507        WRITE(ICOUT,999)
5508        CALL DPWRST('XXX','WRIT')
5509        WRITE(ICOUT,101)
5510  101   FORMAT('****** ERROR IN FISHER TWO-SAMPLE RANDOMIZATION TEST--')
5511        CALL DPWRST('XXX','WRIT')
5512        WRITE(ICOUT,103)
5513  103   FORMAT('       MAXIMUM STORAGE SPACE EXCEEDED.')
5514        CALL DPWRST('XXX','WRIT')
5515        WRITE(ICOUT,105)N1
5516  105   FORMAT('       NUMBER OF OBSERVATIONS FOR SAMPLE ONE  = ',I8)
5517        CALL DPWRST('XXX','WRIT')
5518        WRITE(ICOUT,107)N2
5519  107   FORMAT('       NUMBER OF OBSERVATIONS FOR SAMPLE TWO  = ',I8)
5520        CALL DPWRST('XXX','WRIT')
5521        IERROR='YES'
5522        GOTO9000
5523      ELSEIF(IFAULT.EQ.2)THEN
5524        WRITE(ICOUT,999)
5525        CALL DPWRST('XXX','WRIT')
5526        WRITE(ICOUT,101)
5527        CALL DPWRST('XXX','WRIT')
5528        WRITE(ICOUT,113)MAXSAM
5529  113   FORMAT('       SAMPLE SIZE > ',I8)
5530        CALL DPWRST('XXX','WRIT')
5531        WRITE(ICOUT,105)N1
5532        CALL DPWRST('XXX','WRIT')
5533        WRITE(ICOUT,107)N2
5534        CALL DPWRST('XXX','WRIT')
5535        IERROR='YES'
5536        GOTO9000
5537      ENDIF
5538C
5539      STATVA=SUMX
5540      PVALLT=PVAL
5541      PVAL2T=2.0*PVALLT
5542C
5543C     P-VALUE RETURNED IS FOR THE LOWER-TAILED TEST.  FOR
5544C     EQUAL SAMPLE SIZES, THE EXACT P-VALUE FOR THE TWO-TAILED
5545C     TEST CAN BE OBTAINED SIMPLY MULTIPLYING ONE-TAILED TEST
5546C     BY 2.  HOWEVER, FOR UNEQUAL SAMPLE SIZES, THIS IS ONLY
5547C     APPROXIMATE.  FOR THIS CASE, THE UPPER TAIL VALUES CAN
5548C     BE OBTAINED FROM THE FOLLOWING PROCEDURE:
5549C
5550C        1) LET
5551C
5552C           X      = SAMPLE WITH SMALLER MEAN
5553C           M      = SAMPLE SIZE FOR X
5554C           Y      = SAMPLE WITH LARGER MEAN
5555C           N      = SAMPLE SIZE FOR Y
5556C           D      = MEAN OF X  -  MEAN OF Y
5557C           T      = TOTAL OF ALL SAMPLE OBSERVATIONS (SUM OF X + SUM OF Y)
5558C
5559C        2) FIND THE MINIMUM SUM FOR M SAMPLE OBSERVATIONS THAT SATISFIES
5560C
5561C            SUM OF X >= M*(T- N*D)/(M + N)
5562C
5563C     NOTE THAT THE ORIGINAL CALL TO FISHER WILL AUTOMATICALLY
5564C     EXCHANGE Y1 AND Y2 IF Y2 (AND N1 AND N2) IF Y2 HAS THE SMALLER
5565C     MEAN.
5566C
5567C     PUT Y1 AND Y2 IN A COMMON VARIABLE AND SORT THIS VARIABLE (AND
5568C     CARRY ALONG A VARIABLE THAT IDENTIFIES WHICH SAMPLE THE
5569C     OBSERVATION BELONGS TO).
5570C
5571C     FOR NOW, REPORT THE APPROXIMATE P-VALUE FOR THE TWO-TAILED CASE.
5572C     THE ABOVE ALGORITHM CAN GET A BIT COMPLICATED TO AUTOMATE SINCE
5573C     WE MAY NEED TO TEST MANY DIFFERENT SUBSETS.  IF MINIMUM SUM WITH
5574C     EXACTLY M OBSERVATIONS AND GREATER THAN OR EQUAL TO THRESHOLD
5575C     REACHED AT SMALLEST M OR M + 1 SAMPLES, THIS CAN BE DONE IN A
5576C     RELATIVELY STRAIGHTFORWARD WAY.  IF M + 2 OR MORE SAMPLES REQUIRED,
5577C     THEN THIS GETS A BIT MORE COMPLICATED.
5578C
5579CCCCC M=N1
5580CCCCC N=N2
5581CCCCC T=SUMX + SUMY
5582CCCCC D=ABS(MEANX - MEANY)
5583CCCCC ASUM=REAL(M)*(T - REAL(N)*D)/REAL(M+N)
5584CCCCC DO210I=1,N1
5585CCCCC   TEMP1(I)=Y1(I)
5586CCCCC   TEMP2(I)=1.0
5587CC210 CONTINUE
5588CCCCC ICNT=N1
5589CCCCC DO220I=1,N2
5590CCCCC   ICNT=ICNT+1
5591CCCCC   TEMP1(ICNT)=Y2(I)
5592CCCCC   TEMP2(ICNT)=2.0
5593CC220 CONTINUE
5594CCCCC NCOMB=N1+N2
5595CCCCC CALL SORTC(TEMP1,TEMP2,NCOMB,TEMP1,TEMP3)
5596C
5597C     FIRST, FIND WHICH POINT IN THE ARRAY HAS SUFFICIENTLY
5598C     LARGE SUM WITH EXACTLY M VALUES
5599C
5600CCCCC DO300ICNT=M,NCOMB
5601CCCCC   ISTRT=ICNT-M+1
5602CCCCC   CALL SUMDP(TEMP1(ISTRT),ICNT,IWRITE,SUMT,IBUGA3,IERROR)
5603CCCCC   IF(SUMT.GE.ASUM)THEN
5604CCCCC     print *,'m,icnt,asum,sumt=',m,icnt,asum,sumt
5605CCCCC     ISTOP=ICNT
5606CCCCC     GOTO309
5607CCCCC   ENDIF
5608C
5609C               *************************************************
5610C               **   STEP 22--                                 **
5611C               **   WRITE OUT EVERYTHING FOR A                **
5612C               **   FISHER TWO SAMPLE RANDOMIZATION TEST      **
5613C               *************************************************
5614C
5615      ISTEPN='22'
5616      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIR2')
5617     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5618C
5619      IF(IPRINT.EQ.'OFF')GOTO9000
5620C
5621      IF(ICASAN.EQ.'LOWE')THEN
5622        ITITLE='Two Sample Lower-Tailed Fisher Randomization Test'
5623        NCTITL=49
5624      ELSE
5625        ITITLE='Two Sample Two-Sided Fisher Randomization Test'
5626        NCTITL=46
5627      ENDIF
5628      ITITLZ='(Independent Samples)'
5629      NCTITZ=21
5630C
5631      ICNT=1
5632      ITEXT(ICNT)=' '
5633      NCTEXT(ICNT)=0
5634      AVALUE(ICNT)=0.0
5635      IDIGIT(ICNT)=-1
5636C
5637      ICNT=ICNT+1
5638      ITEXT(ICNT)='First Response Variable: '
5639      WRITE(ITEXT(ICNT)(26:29),'(A4)')IVARID(1:4)
5640      WRITE(ITEXT(ICNT)(30:33),'(A4)')IVARI2(1:4)
5641      NCTEXT(ICNT)=33
5642      AVALUE(ICNT)=0.0
5643      IDIGIT(ICNT)=-1
5644      ICNT=ICNT+1
5645      ITEXT(ICNT)='Second Response Variable: '
5646      WRITE(ITEXT(ICNT)(27:30),'(A4)')IVARI3(1:4)
5647      WRITE(ITEXT(ICNT)(31:34),'(A4)')IVARI4(1:4)
5648      NCTEXT(ICNT)=34
5649      AVALUE(ICNT)=0.0
5650      IDIGIT(ICNT)=-1
5651C
5652      ICNT=ICNT+1
5653      ITEXT(ICNT)=' '
5654      NCTEXT(ICNT)=1
5655      AVALUE(ICNT)=0.0
5656      IDIGIT(ICNT)=-1
5657C
5658      ICNT=ICNT+1
5659      ITEXT(ICNT)='H0: E(X) = E(Y)'
5660      NCTEXT(ICNT)=15
5661      AVALUE(ICNT)=0.0
5662      IDIGIT(ICNT)=-1
5663      ICNT=ICNT+1
5664      IF(ICASAN.EQ.'LOWE')THEN
5665        ITEXT(ICNT)='Ha: E(X) < E(Y)'
5666        NCTEXT(ICNT)=15
5667      ELSE
5668        ITEXT(ICNT)='Ha: E(X) <> E(Y)'
5669        NCTEXT(ICNT)=16
5670      ENDIF
5671      AVALUE(ICNT)=0.0
5672      IDIGIT(ICNT)=-1
5673C
5674      ICNT=ICNT+1
5675      ITEXT(ICNT)=' '
5676      NCTEXT(ICNT)=1
5677      AVALUE(ICNT)=0.0
5678      IDIGIT(ICNT)=-1
5679      ICNT=ICNT+1
5680      ITEXT(ICNT)='Summary Statistics:'
5681      NCTEXT(ICNT)=19
5682      AVALUE(ICNT)=0.0
5683      IDIGIT(ICNT)=-1
5684      ICNT=ICNT+1
5685      ITEXT(ICNT)='Sample with Smaller Mean:'
5686      NCTEXT(ICNT)=25
5687      AVALUE(ICNT)=0.0
5688      IDIGIT(ICNT)=-1
5689      ICNT=ICNT+1
5690      ITEXT(ICNT)='Number of Observations:'
5691      NCTEXT(ICNT)=23
5692      AVALUE(ICNT)=REAL(N1)
5693      IDIGIT(ICNT)=0
5694      ICNT=ICNT+1
5695      ITEXT(ICNT)='Mean:'
5696      NCTEXT(ICNT)=5
5697      AVALUE(ICNT)=MEANX
5698      IDIGIT(ICNT)=NUMDIG
5699      ICNT=ICNT+1
5700      ITEXT(ICNT)='Sum of Observations:'
5701      NCTEXT(ICNT)=20
5702      AVALUE(ICNT)=SUMX
5703      IDIGIT(ICNT)=NUMDIG
5704      ICNT=ICNT+1
5705      ITEXT(ICNT)='Sample with Larger Mean:'
5706      NCTEXT(ICNT)=24
5707      AVALUE(ICNT)=0.0
5708      IDIGIT(ICNT)=-1
5709      ICNT=ICNT+1
5710      ITEXT(ICNT)='Number of Observations:'
5711      NCTEXT(ICNT)=23
5712      AVALUE(ICNT)=REAL(N2)
5713      IDIGIT(ICNT)=0
5714      ICNT=ICNT+1
5715      ITEXT(ICNT)='Mean:'
5716      NCTEXT(ICNT)=5
5717      AVALUE(ICNT)=MEANY
5718      IDIGIT(ICNT)=NUMDIG
5719      ICNT=ICNT+1
5720      ITEXT(ICNT)='Sum of Observations:'
5721      NCTEXT(ICNT)=20
5722      AVALUE(ICNT)=SUMY
5723      IDIGIT(ICNT)=NUMDIG
5724      ICNT=ICNT+1
5725      ITEXT(ICNT)='Difference of Means:'
5726      NCTEXT(ICNT)=20
5727      AVALUE(ICNT)=MEANX - MEANY
5728      IDIGIT(ICNT)=NUMDIG
5729      ICNT=ICNT+1
5730      ITEXT(ICNT)=' '
5731      NCTEXT(ICNT)=1
5732      AVALUE(ICNT)=0.0
5733      IDIGIT(ICNT)=-1
5734C
5735      ICNT=ICNT+1
5736      ITEXT(ICNT)='Test Statistic:'
5737      NCTEXT(ICNT)=15
5738      AVALUE(ICNT)=STATVA
5739      IDIGIT(ICNT)=NUMDIG
5740      ICNT=ICNT+1
5741      ITEXT(ICNT)='Approximate P-Value (two-tailed test):'
5742      NCTEXT(ICNT)=38
5743      AVALUE(ICNT)=PVAL2T
5744      IDIGIT(ICNT)=NUMDIG
5745      ICNT=ICNT+1
5746      ITEXT(ICNT)='Exact P-Value (lower-tailed test):'
5747      NCTEXT(ICNT)=34
5748      AVALUE(ICNT)=PVALLT
5749      IDIGIT(ICNT)=NUMDIG
5750C
5751      NUMROW=ICNT
5752      DO2110I=1,NUMROW
5753        NTOT(I)=15
5754 2110 CONTINUE
5755C
5756      IFRST=.TRUE.
5757      ILAST=.TRUE.
5758C
5759      ISTEPN='21A'
5760      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIR2')
5761     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5762C
5763      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
5764     1            AVALUE,IDIGIT,
5765     1            NTOT,NUMROW,
5766     1            ICAPSW,ICAPTY,ILAST,IFRST,
5767     1            ISUBRO,IBUGA3,IERROR)
5768C
5769C               *****************
5770C               **  STEP 90--  **
5771C               **  EXIT       **
5772C               *****************
5773C
5774 9000 CONTINUE
5775      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FIR2')THEN
5776        WRITE(ICOUT,999)
5777        CALL DPWRST('XXX','WRIT')
5778        WRITE(ICOUT,9011)
5779 9011   FORMAT('***** AT THE END       OF DPFIR2--')
5780        CALL DPWRST('XXX','WRIT')
5781        WRITE(ICOUT,9013)STATVA,PVAL2T,PVALLT
5782 9013   FORMAT('STATVA,PVAL2T,PVALLT = ',3G15.7)
5783        CALL DPWRST('XXX','WRIT')
5784      ENDIF
5785C
5786      RETURN
5787      END
5788      SUBROUTINE DPFIR5(STATVA,PVAL2T,PVALLT,
5789     1                  IFLAGU,IFRST,ILAST,
5790     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
5791C
5792C     PURPOSE--UTILITY ROUTINE USED BY DPFIRT TO UPDATE VARIOUS
5793C              INTERNAL PARAMETERS AFTER A FISHER TWO SAMPLE
5794C              RANDOMIZATION TEST.
5795C
5796C     WRITTEN BY--ALAN HECKERT
5797C                 STATISTICAL ENGINEERING DIVISION
5798C                 INFORMATION TECHNOLOGY LABORAOTRY
5799C                 NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY
5800C                 GAITHERSBURG, MD 20899-8980
5801C                 PHONE--301-975-2899
5802C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
5803C           OF THE NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY.
5804C     LANGUAGE--ANSI FORTRAN (1977)
5805C     VERSION NUMBER--2011/6
5806C     ORIGINAL VERSION--JUNE      2011.
5807C
5808C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
5809C
5810      CHARACTER*4 IFLAGU
5811      CHARACTER*4 IBUGA2
5812      CHARACTER*4 IBUGA3
5813      CHARACTER*4 ISUBRO
5814      CHARACTER*4 IERROR
5815C
5816      LOGICAL IFRST
5817      LOGICAL ILAST
5818C
5819      CHARACTER*4 IH
5820      CHARACTER*4 IH2
5821      CHARACTER*4 ISUBN0
5822      CHARACTER*4 ISUBN1
5823      CHARACTER*4 ISUBN2
5824      CHARACTER*4 ISTEPN
5825      CHARACTER*4 IOP
5826C
5827      SAVE IOUNI1
5828C
5829C-----COMMON VARIABLES (GENERAL)--------------------------------------
5830C
5831      INCLUDE 'DPCOPA.INC'
5832      INCLUDE 'DPCOHK.INC'
5833      INCLUDE 'DPCOHO.INC'
5834      INCLUDE 'DPCOP2.INC'
5835C
5836C-----START POINT-----------------------------------------------------
5837C
5838      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FIR5')THEN
5839        ISTEPN='1'
5840        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5841        WRITE(ICOUT,999)
5842  999   FORMAT(1X)
5843        CALL DPWRST('XXX','BUG ')
5844        WRITE(ICOUT,51)
5845   51   FORMAT('***** AT THE BEGINNING OF DPFIR5--')
5846        CALL DPWRST('XXX','BUG ')
5847        WRITE(ICOUT,53)STATVA,PVAL2T,PVALLT
5848   53   FORMAT('STATVA,PVAL2T,PVALLT = ',3G15.7)
5849        CALL DPWRST('XXX','BUG ')
5850      ENDIF
5851C
5852      IF(IFLAGU.EQ.'FILE')THEN
5853C
5854        IF(IFRST)THEN
5855          IOP='OPEN'
5856          IFLAG1=1
5857          IFLAG2=0
5858          IFLAG3=0
5859          IFLAG4=0
5860          IFLAG5=0
5861          CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
5862     1                IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
5863     1                IBUGA3,ISUBRO,IERROR)
5864          IF(IERROR.EQ.'YES')GOTO9000
5865C
5866          WRITE(IOUNI1,295)
5867  295     FORMAT(10X,'STATVAL',9X,'PVAL2T',9X,'PVALLT')
5868        ENDIF
5869        WRITE(IOUNI1,298)STATVA,PVAL2T,PVALLT
5870  298   FORMAT(3E15.7)
5871      ELSEIF(IFLAGU.EQ.'ON')THEN
5872        IH='STAT'
5873        IH2='VALU'
5874        VALUE0=STATVA
5875        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
5876     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
5877     1              IANS,IWIDTH,IBUGA3,IERROR)
5878C
5879        IH='PVAL'
5880        IH2='UE  '
5881        VALUE0=PVAL2T
5882        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
5883     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
5884     1              IANS,IWIDTH,IBUGA3,IERROR)
5885C
5886        IH='PVAL'
5887        IH2='UELT'
5888        VALUE0=PVALLT
5889        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
5890     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
5891     1              IANS,IWIDTH,IBUGA3,IERROR)
5892C
5893      ENDIF
5894C
5895      IF(IFLAGU.EQ.'FILE')THEN
5896        IF(ILAST)THEN
5897          IOP='CLOS'
5898          IFLAG1=1
5899          IFLAG2=0
5900          IFLAG3=0
5901          IFLAG4=0
5902          IFLAG5=0
5903          CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
5904     1                IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
5905     1                IBUGA3,ISUBRO,IERROR)
5906C
5907          IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FIR5')THEN
5908            ISTEPN='3A'
5909            CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5910            WRITE(ICOUT,999)
5911            CALL DPWRST('XXX','BUG ')
5912            WRITE(ICOUT,301)IERROR,IOUNI1
5913  301       FORMAT('AFTER CALL DPCLFI, IERROR,IOUNI1 = ',A4,2X,I5)
5914            CALL DPWRST('XXX','BUG ')
5915          ENDIF
5916C
5917          IF(IERROR.EQ.'YES')GOTO9000
5918        ENDIF
5919      ENDIF
5920C
5921C               *****************
5922C               **  STEP 90--  **
5923C               **  EXIT       **
5924C               *****************
5925C
5926 9000 CONTINUE
5927C
5928      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FIR5')THEN
5929        WRITE(ICOUT,999)
5930        CALL DPWRST('XXX','BUG ')
5931        WRITE(ICOUT,9011)
5932 9011   FORMAT('***** AT THE END OF DPFIR5--')
5933        CALL DPWRST('XXX','BUG ')
5934      ENDIF
5935C
5936      RETURN
5937      END
5938      SUBROUTINE DPFISD(IHARG,IARGT,ARG,NUMARG,DEFFSD,
5939     1FITSD,IFOUND,IERROR)
5940C
5941C     PURPOSE--DEFINE THE LOWER BOUND FOR THE FIT STANDARD DEVIATION.
5942C              THE RESIDUAL STANDARD DEVIATION AFTER EACH
5943C              ITERATION OF A FIT WILL BE COMPARED
5944C              TO THE SPECIFIED FIT STANDARD DEVIATION.
5945C              THE SPECIFIED FIT STANDARD DEVIATION VALUE WILL BE PLACED
5946C              IN THE FLOATING POINT VARIABLE FITSD.
5947C              THE RESIDUAL STANDARD DEVIATION WILL BE
5948C              COMPARED TO THE FIT STANDARD DEVIATION VALUE.
5949C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
5950C                     --IARGT  (A  HOLLERITH VECTOR)
5951C                     --ARG    (A  FLOATING POINT VECTOR)
5952C                     --NUMARG (AN INTEGER VARIABLE)
5953C                     --DEFFSD (A  FLOATING POINT VARIABLE)
5954C     OUTPUT ARGUMENTS--FITSD  (A  FLOATING POINT VARIABLE)
5955C                     --IFOUND ('YES' OR 'NO' )
5956C                     --IERROR ('YES' OR 'NO' )
5957C     WRITTEN BY--JAMES J. FILLIBEN
5958C                 STATISTICAL ENGINEERING DIVISION
5959C                 INFORMATION TECHNOLOGY LABORATORY
5960C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
5961C                 GAITHERSBURG, MD 20899-8980
5962C                 PHONE--301-975-2855
5963C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
5964C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
5965C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
5966C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
5967C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
5968C     LANGUAGE--ANSI FORTRAN (1977)
5969C     VERSION NUMBER--82/7
5970C     ORIGINAL VERSION--NOVEMBER 1980.
5971C     UPDATED         --MAY       1982.
5972C
5973C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
5974C
5975      CHARACTER*4 IHARG
5976      CHARACTER*4 IARGT
5977      CHARACTER*4 IFOUND
5978      CHARACTER*4 IERROR
5979C
5980C---------------------------------------------------------------------
5981C
5982      DIMENSION IHARG(*)
5983      DIMENSION IARGT(*)
5984      DIMENSION ARG(*)
5985C
5986C---------------------------------------------------------------------
5987C
5988      INCLUDE 'DPCOP2.INC'
5989C
5990C-----START POINT-----------------------------------------------------
5991C
5992      IFOUND='NO'
5993      IERROR='NO'
5994C
5995      IF(NUMARG.EQ.0)GOTO1199
5996      IF(NUMARG.GE.3.AND.IHARG(3).EQ.'=')GOTO1199
5997      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'STAN'.AND.
5998     1IHARG(2).EQ.'DEVI')GOTO1110
5999      GOTO1199
6000C
6001 1110 CONTINUE
6002      IF(IHARG(NUMARG).EQ.'DEVI')GOTO1150
6003      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
6004      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
6005      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
6006      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
6007      IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160
6008      GOTO1120
6009C
6010 1120 CONTINUE
6011      IERROR='YES'
6012      WRITE(ICOUT,1121)
6013 1121 FORMAT('***** ERROR IN DPFISD--')
6014      CALL DPWRST('XXX','BUG ')
6015      WRITE(ICOUT,1122)
6016 1122 FORMAT('      ILLEGAL FORM FOR FIT STANDARD DEVIATION ',
6017     1'COMMAND.')
6018      CALL DPWRST('XXX','BUG ')
6019      WRITE(ICOUT,1124)
6020 1124 FORMAT('      TEST EXAMPLE TO DEMONSTRATE THE ',
6021     1'PROPER FORM--')
6022      CALL DPWRST('XXX','BUG ')
6023      WRITE(ICOUT,1125)
6024 1125 FORMAT('      SUPPOSE THE THE ANALYST WILL BE CARRYING OUT  ')
6025      CALL DPWRST('XXX','BUG ')
6026      WRITE(ICOUT,1126)
6027 1126 FORMAT('      A NON-LINEAR FIT , ')
6028      CALL DPWRST('XXX','BUG ')
6029      WRITE(ICOUT,1127)
6030 1127 FORMAT('      AND SUPPOSE THE ANALYST WISHES TO TERMINATE  ')
6031      CALL DPWRST('XXX','BUG ')
6032      WRITE(ICOUT,1128)
6033 1128 FORMAT('      THE FIT ITERATIONS WHENEVER THE RESIDUAL ')
6034      CALL DPWRST('XXX','BUG ')
6035      WRITE(ICOUT,1129)
6036 1129 FORMAT('      STANDARD DEVIATION REACHES .0001 OR SMALLER; ')
6037      CALL DPWRST('XXX','BUG ')
6038      WRITE(ICOUT,1130)
6039 1130 FORMAT('      THEN THE ALLOWABLE FORM IS--')
6040      CALL DPWRST('XXX','BUG ')
6041      WRITE(ICOUT,1131)
6042 1131 FORMAT('      FIT STANDARD DEVIATION .0001 ')
6043      CALL DPWRST('XXX','BUG ')
6044      GOTO1199
6045C
6046 1150 CONTINUE
6047      HOLD=DEFFSD
6048      GOTO1180
6049C
6050 1160 CONTINUE
6051      HOLD=ARG(NUMARG)
6052      GOTO1180
6053C
6054 1180 CONTINUE
6055      IFOUND='YES'
6056      FITSD=HOLD
6057C
6058      IF(IFEEDB.EQ.'OFF')GOTO1189
6059      WRITE(ICOUT,999)
6060  999 FORMAT(1X)
6061      CALL DPWRST('XXX','BUG ')
6062      WRITE(ICOUT,1181)FITSD
6063 1181 FORMAT('THE FIT STANDARD DEVIATION HAS JUST BEEN SET TO ',
6064     1E15.7)
6065      CALL DPWRST('XXX','BUG ')
6066 1189 CONTINUE
6067      GOTO1199
6068C
6069 1199 CONTINUE
6070      RETURN
6071      END
6072      SUBROUTINE DPFISH(MAXNXT,ICASAN,ICAPSW,IFORSW,
6073     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
6074C
6075C     PURPOSE--COMPUTE THE FISHER EXACT TEST
6076C     EXAMPLE--FISHER EXACT TEST Y1 Y2
6077C            --FISHER EXACT TEST N11 N21 N12 N22
6078C            --FISHER EXACT TEST M
6079C     REFERENCE--XXX
6080C     WRITTEN BY--ALAN HECKERT
6081C                 STATISTICAL ENGINEERING DIVISION
6082C                 INFORMATION TECHNOLOGY LABORATORY
6083C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
6084C                 GAITHERSBURG, MD 20899-8980
6085C                 PHONE--301-975-2899
6086C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
6087C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
6088C     LANGUAGE--ANSI FORTRAN (1977)
6089C     VERSION NUMBER--2007/3
6090C     ORIGINAL VERSION--MARCH     2007.
6091C     UPDATED  VERSION--FEBRUARY  2011. USE DPPARS, DPPAR3, DPPAR6
6092C     UPDATED  VERSION--JULY      2019. TWEAK SCRATCH STORAGE
6093C
6094C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
6095C
6096      CHARACTER*4 ICASAN
6097      CHARACTER*4 ICAPSW
6098      CHARACTER*4 IFORSW
6099C
6100      CHARACTER*4 IBUGA2
6101      CHARACTER*4 IBUGA3
6102      CHARACTER*4 IBUGQ
6103      CHARACTER*4 ISUBRO
6104      CHARACTER*4 IFOUND
6105      CHARACTER*4 IERROR
6106C
6107      CHARACTER*4 ISUBN1
6108      CHARACTER*4 ISUBN2
6109      CHARACTER*4 ISTEPN
6110      CHARACTER*4 IH
6111      CHARACTER*4 IH2
6112      CHARACTER*4 ISUBN0
6113      CHARACTER*4 ICASE
6114C
6115      CHARACTER*40 INAME
6116      PARAMETER (MAXSPN=20)
6117      CHARACTER*4 IVARN1(MAXSPN)
6118      CHARACTER*4 IVARN2(MAXSPN)
6119      CHARACTER*4 IVARTY(MAXSPN)
6120      REAL PVAR(MAXSPN)
6121      INTEGER ILIS(MAXSPN)
6122      INTEGER NRIGHT(MAXSPN)
6123      INTEGER ICOLR(MAXSPN)
6124C
6125C---------------------------------------------------------------------
6126C
6127      PARAMETER(MAXLEV=200)
6128      PARAMETER(IWKMX=1000000)
6129C
6130      INCLUDE 'DPCOPA.INC'
6131      INCLUDE 'DPCOZZ.INC'
6132      INCLUDE 'DPCOZD.INC'
6133      INCLUDE 'DPCOZI.INC'
6134C
6135      REAL TEMP1(MAXOBV)
6136      REAL TEMP2(MAXOBV)
6137      REAL TEMP3(MAXOBV)
6138      REAL XIDTEM(MAXOBV)
6139      REAL XIDTE2(MAXOBV)
6140      REAL RWORK(10*MAXOBV)
6141C
6142      INTEGER IWORK(10*MAXOBV)
6143C
6144      REAL XMAT2(MAXLEV,MAXLEV)
6145      DOUBLE PRECISION XMAT(MAXLEV,MAXLEV)
6146      DOUBLE PRECISION ROWTOT(MAXOBV)
6147      DOUBLE PRECISION COLTOT(MAXOBV)
6148      DOUBLE PRECISION DWORK(8*MAXOBV)
6149C
6150      EQUIVALENCE (GARBAG(IGARB1),TEMP1(1))
6151      EQUIVALENCE (GARBAG(IGARB2),TEMP2(1))
6152      EQUIVALENCE (GARBAG(IGARB3),TEMP3(1))
6153      EQUIVALENCE (GARBAG(IGARB4),XIDTEM(1))
6154      EQUIVALENCE (GARBAG(IGARB5),XIDTE2(1))
6155      EQUIVALENCE (GARBAG(IGARB6),XMAT2(1,1))
6156      EQUIVALENCE (GARBAG(IGARB7),RWORK(1))
6157      EQUIVALENCE (GARBAG(JGAR20),XMAT(1,1))
6158C
6159      EQUIVALENCE (DGARBG(IDGAR1),ROWTOT(1))
6160      EQUIVALENCE (DGARBG(IDGAR2),COLTOT(1))
6161      EQUIVALENCE (DGARBG(IDGAR3),DWORK(1))
6162C
6163      EQUIVALENCE (IGARBG(IIGAR1),IWORK(1))
6164C
6165C
6166C-----COMMON----------------------------------------------------------
6167C
6168      INCLUDE 'DPCOHK.INC'
6169      INCLUDE 'DPCOSU.INC'
6170      INCLUDE 'DPCOST.INC'
6171      INCLUDE 'DPCODA.INC'
6172      INCLUDE 'DPCOHO.INC'
6173      INCLUDE 'DPCOP2.INC'
6174C
6175C-----START POINT-----------------------------------------------------
6176C
6177      ISUBN1='DPFI'
6178      ISUBN2='SH  '
6179      IFOUND='YES'
6180      IERROR='NO'
6181C
6182      MAXCP1=MAXCOL+1
6183      MAXCP2=MAXCOL+2
6184      MAXCP3=MAXCOL+3
6185      MAXCP4=MAXCOL+4
6186      MAXCP5=MAXCOL+5
6187      MAXCP6=MAXCOL+6
6188C
6189      N11=(-999)
6190      N21=(-999)
6191      N12=(-999)
6192      N22=(-999)
6193C
6194      ICASE='PARA'
6195C
6196C               ***************************************************
6197C               **  TREAT THE FISHER EXACT TEST CASE  **
6198C               ***************************************************
6199C
6200      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FISH')THEN
6201        WRITE(ICOUT,999)
6202  999   FORMAT(1X)
6203        CALL DPWRST('XXX','BUG ')
6204        WRITE(ICOUT,51)
6205   51   FORMAT('***** AT THE BEGINNING OF DPFISH--')
6206        CALL DPWRST('XXX','BUG ')
6207        WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ,ISUBRO,ICASAN
6208   52   FORMAT('IBUGA2,IBUGA3,IBUGQ,ISUBRO,ICASAN = ',4(A4,2X),A4)
6209        CALL DPWRST('XXX','BUG ')
6210        WRITE(ICOUT,55)MAXNXT,NUMARG,IFORSW
6211   55   FORMAT('MAXNXT,NUMARG,IFORSW = ',2I8,2X,A4)
6212        CALL DPWRST('XXX','BUG ')
6213        DO59I=1,NUMARG
6214          WRITE(ICOUT,57)I,IHARG(I),IHARG2(I),ARG(I)
6215   57     FORMAT('I,IHARG(I),IHARG2(I),ARG(I) = ',I5,A4,A4,G15.7)
6216   59   CONTINUE
6217      ENDIF
6218C
6219C               *********************************
6220C               **  STEP 4--                   **
6221C               **  EXTRACT THE VARIABLE LIST  **
6222C               *********************************
6223C
6224      ISTEPN='4'
6225      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FISH')
6226     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6227C
6228      INAME='FISHER EXACT TEST'
6229      MINNA=1
6230      MAXNA=100
6231      MINN2=2
6232      IFLAGE=0
6233      IFLAGM=9
6234      IFLAGP=9
6235      JMIN=1
6236      JMAX=NUMARG
6237      MINNVA=1
6238      MAXNVA=4
6239C
6240      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
6241     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
6242     1            JMIN,JMAX,
6243     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
6244     1            IVARN1,IVARN2,IVARTY,PVAR,
6245     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
6246     1            MINNVA,MAXNVA,
6247     1            IFLAGM,IFLAGP,
6248     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
6249      IF(IERROR.EQ.'YES')GOTO9000
6250C
6251      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FISH')THEN
6252        WRITE(ICOUT,999)
6253        CALL DPWRST('XXX','BUG ')
6254        WRITE(ICOUT,281)
6255  281   FORMAT('***** AFTER CALL DPPARS--')
6256        CALL DPWRST('XXX','BUG ')
6257        WRITE(ICOUT,282)NQ,NUMVAR
6258  282   FORMAT('NQ,NUMVAR = ',2I8)
6259        CALL DPWRST('XXX','BUG ')
6260        IF(NUMVAR.GT.0)THEN
6261          DO285I=1,NUMVAR
6262            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
6263     1                      ICOLR(I),PVAR(I)
6264  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
6265     1             'ICOLR(I),PVAR(I) = ',I8,2X,A4,A4,2X,3I8,G15.7)
6266            CALL DPWRST('XXX','BUG ')
6267  285     CONTINUE
6268        ENDIF
6269      ENDIF
6270C
6271C               ***********************************
6272C               **  STEP 22--                    **
6273C               **  CHECK FOR PROPER VALUES FOR  **
6274C               **  INPUT PARAMETERS             **
6275C               ***********************************
6276C
6277      IF(IVARTY(1).EQ.'PARA' .OR. IVARTY(1).EQ.'NUMB')THEN
6278        N11=INT(PVAR(1)+0.5)
6279        N21=INT(PVAR(2)+0.5)
6280        N12=INT(PVAR(3)+0.5)
6281        N22=INT(PVAR(4)+0.5)
6282        AN11=REAL(N11)
6283        AN21=REAL(N21)
6284        AN12=REAL(N12)
6285        AN22=REAL(N22)
6286        ICASE='PARA'
6287C
6288        ISTEPN='22'
6289        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FISH')
6290     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6291C
6292        IF(N11.LT.0)THEN
6293          WRITE(ICOUT,999)
6294          CALL DPWRST('XXX','BUG ')
6295          WRITE(ICOUT,2201)
6296 2201     FORMAT('***** ERROR FROM FISHER EXACT TEST--')
6297          CALL DPWRST('XXX','BUG ')
6298          WRITE(ICOUT,2203)
6299 2203     FORMAT('      THE VALUE OF THE FIRST PARAMETER (N11 = THE ',
6300     1           'NUMBER OF SUCCESSES')
6301          CALL DPWRST('XXX','BUG ')
6302          WRITE(ICOUT,2204)
6303 2204     FORMAT('      FOR THE FIRST VARIABLE MUST BE NON-NEGATIVE.')
6304          CALL DPWRST('XXX','BUG ')
6305          WRITE(ICOUT,2205)N11
6306 2205     FORMAT('      N11 = ',I8)
6307          CALL DPWRST('XXX','BUG ')
6308          IERROR='YES'
6309          GOTO9000
6310C
6311        ELSEIF(N21.LT.0)THEN
6312          WRITE(ICOUT,999)
6313          CALL DPWRST('XXX','BUG ')
6314          WRITE(ICOUT,2201)
6315          CALL DPWRST('XXX','BUG ')
6316          WRITE(ICOUT,2303)
6317 2303     FORMAT('      THE VALUE OF THE SECOND PARAMETER (N21 = THE ',
6318     1           'NUMBER OF FAILURES')
6319          CALL DPWRST('XXX','BUG ')
6320          WRITE(ICOUT,2304)
6321 2304     FORMAT('      FOR THE FIRST VARIABLE MUST BE NON-NEGATIVE.')
6322          CALL DPWRST('XXX','BUG ')
6323          WRITE(ICOUT,2305)N21
6324 2305     FORMAT('      N21 = ',I8)
6325          CALL DPWRST('XXX','BUG ')
6326          IERROR='YES'
6327          GOTO9000
6328C
6329        ELSEIF(N12.LT.0)THEN
6330          WRITE(ICOUT,999)
6331          CALL DPWRST('XXX','BUG ')
6332          WRITE(ICOUT,2201)
6333          CALL DPWRST('XXX','BUG ')
6334          WRITE(ICOUT,2403)
6335 2403     FORMAT('      THE VALUE OF THE THIRD PARAMETER (N12 = THE ',
6336     1           'NUMBER OF SUCCESSES')
6337          CALL DPWRST('XXX','BUG ')
6338          WRITE(ICOUT,2404)
6339 2404     FORMAT('      FOR THE SECOND VARIABLE MUST BE NON-NEGATIVE.')
6340          CALL DPWRST('XXX','BUG ')
6341          WRITE(ICOUT,2405)N12
6342 2405     FORMAT('      N12 = ',I8)
6343          CALL DPWRST('XXX','BUG ')
6344          IERROR='YES'
6345          GOTO9000
6346C
6347        ELSEIF(N22.LT.0)THEN
6348          WRITE(ICOUT,999)
6349          CALL DPWRST('XXX','BUG ')
6350          WRITE(ICOUT,2201)
6351          CALL DPWRST('XXX','BUG ')
6352          WRITE(ICOUT,2503)
6353 2503     FORMAT('      THE VALUE OF THE FOURTH PARAMETER (N22 = THE ',
6354     1           'NUMBER OF FAILURES')
6355          CALL DPWRST('XXX','BUG ')
6356          WRITE(ICOUT,2504)
6357 2504     FORMAT('      FOR THE SECOND VARIABLE MUST BE NON-NEGATIVE.')
6358          CALL DPWRST('XXX','BUG ')
6359          WRITE(ICOUT,2505)N22
6360 2505     FORMAT('      N22 = ',I8)
6361          CALL DPWRST('XXX','BUG ')
6362          IERROR='YES'
6363          GOTO9000
6364        ENDIF
6365C
6366      ELSEIF(IVARTY(1).EQ.'VARI')THEN
6367C
6368        ICASE='VARI'
6369        ICOL=1
6370        IF(NUMVAR.GT.2)THEN
6371          WRITE(ICOUT,999)
6372          CALL DPWRST('XXX','BUG ')
6373          WRITE(ICOUT,2201)
6374          CALL DPWRST('XXX','BUG ')
6375          WRITE(ICOUT,2603)
6376 2603     FORMAT('      MORE THAN TWO VARIABLES GIVEN.')
6377          CALL DPWRST('XXX','BUG ')
6378          WRITE(ICOUT,2605)NUMVAR
6379 2605     FORMAT('      THE NUMBER OF VARIABLES GIVEN  = ',I5)
6380          CALL DPWRST('XXX','BUG ')
6381          IERROR='YES'
6382          GOTO9000
6383        ENDIF
6384        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
6385     1              INAME,IVARN1,IVARN2,IVARTY,
6386     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
6387     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
6388     1              MAXCP4,MAXCP5,MAXCP6,
6389     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
6390     1              Y,X,X,NLOCAL,NLOCA2,NLOCA3,ICASE,
6391     1              IBUGA3,ISUBRO,IFOUND,IERROR)
6392        IF(IERROR.EQ.'YES')GOTO9000
6393        NS1=NLOCAL
6394        NS2=NLOCA2
6395C
6396      ELSEIF(IVARTY(1).EQ.'MATR')THEN
6397        ICASE='MATR'
6398        ICOL=1
6399        NUMVAR=1
6400        CALL DPPAR6(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
6401     1              INAME,IVARN1,IVARN2,IVARTY,
6402     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
6403     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
6404     1              MAXCP4,MAXCP5,MAXCP6,
6405     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
6406     1              XMAT2,MAXLEV,NROW,NCOL,ICASE,
6407     1              IBUGA3,ISUBRO,IFOUND,IERROR)
6408        DO5090J=1,MAXLEV
6409          DO5093I=1,MAXLEV
6410            XMAT(I,J)=DBLE(XMAT2(I,J))
6411 5093     CONTINUE
6412 5090   CONTINUE
6413        ICASE='TABL'
6414        IF(IERROR.EQ.'YES')GOTO9000
6415      ENDIF
6416C
6417C               *************************************
6418C               **  STEP 61--                      **
6419C               **  COMPUTE THE FISHER EXACT TEST  **
6420C               *************************************
6421C
6422      ISTEPN='61'
6423C
6424      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FISH')THEN
6425        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6426        WRITE(ICOUT,999)
6427        CALL DPWRST('XXX','BUG ')
6428        WRITE(ICOUT,6111)
6429 6111   FORMAT('***** FROM DPFISH--READY TO COMPUTE TEST')
6430        CALL DPWRST('XXX','BUG ')
6431        WRITE(ICOUT,6112)AN11,AN21,AN12,AN22
6432 6112   FORMAT('AN11,AN21,AN12,AN22 = ',4G15.7)
6433        CALL DPWRST('XXX','BUG ')
6434      ENDIF
6435C
6436      CALL DPFIS2(Y,NS1,X,NS2,
6437     1            AN11,AN21,AN12,AN22,
6438     1            XMAT,MAXLEV,NROW,NCOL,
6439     1            XIDTEM,XIDTE2,TEMP1,TEMP2,TEMP3,MAXOBW,
6440     1            ROWTOT,COLTOT,
6441     1            ICASE,
6442     1            ICAPSW,ICAPTY,IFORSW,
6443     1            STATVA,PVAL,CDF,
6444     1            RWORK,DWORK,IWORK,IWKMX,
6445     1            ISUBRO,IBUGA3,IERROR)
6446C
6447C               ***************************************
6448C               **  STEP 62--                        **
6449C               **  UPDATE INTERNAL DATAPLOT TABLES  **
6450C               ***************************************
6451C
6452      ISTEPN='62'
6453      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FISH')
6454     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6455C
6456      ISUBN0='FISH'
6457C
6458      IH='STAT'
6459      IH2='VAL '
6460      VALUE0=STATVA
6461      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6462     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6463     1IANS,IWIDTH,IBUGA3,IERROR)
6464C
6465      IH='STAT'
6466      IH2='CDF '
6467      VALUE0=CDF
6468      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6469     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6470     1IANS,IWIDTH,IBUGA3,IERROR)
6471C
6472      IH='PVAL'
6473      IH2='UE  '
6474      VALUE0=PVAL
6475      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6476     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6477     1IANS,IWIDTH,IBUGA3,IERROR)
6478C
6479C               *****************
6480C               **  STEP 90--  **
6481C               **  EXIT       **
6482C               *****************
6483C
6484 9000 CONTINUE
6485      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FISH')THEN
6486        WRITE(ICOUT,999)
6487        CALL DPWRST('XXX','BUG ')
6488        WRITE(ICOUT,9011)
6489 9011   FORMAT('***** AT THE END       OF DPFISH--')
6490        CALL DPWRST('XXX','BUG ')
6491        WRITE(ICOUT,9016)IERROR
6492 9016   FORMAT('IERROR = ',A4)
6493        CALL DPWRST('XXX','BUG ')
6494      ENDIF
6495C
6496      RETURN
6497      END
6498      SUBROUTINE DPFIS2(Y1,N1,Y2,N2,
6499     1                  AN11,AN21,AN12,AN22,
6500     1                  XMAT,MAXLEV,NROW,NCOL,
6501     1                  XIDTEM,XIDTE2,TEMP1,TEMP2,TEMP3,MAXNXT,
6502     1                  ROWTOT,COLTOT,
6503     1                  ICASE,
6504     1                  ICAPSW,ICAPTY,IFORSW,
6505     1                  STATVA,PVAL,CDF,
6506     1                  RWORK,DWORK,IWORK,IWKMX,
6507     1                  ISUBRO,IBUGA3,IERROR)
6508C
6509C     PURPOSE--PERFORM A FISHER EXACT TEST FOR INDEPENDENCE.
6510C              THE INPUT CAN BE ENTERED IN THE FOLLOWING WAYS:
6511C
6512C              1) THE COMMON CASE OF A 2X2 TABLE CAN BE
6513C                 ENTERED AS 4 PARAMETERS:
6514C
6515C                    N11 = NUMBER OF SUCCESSES FOR VARIABLE 1
6516C                    N21 = NUMBER OF FAILURES  FOR VARIABLE 1
6517C                    N12 = NUMBER OF SUCCESSES FOR VARIABLE 2
6518C                    N22 = NUMBER OF SUCCESSES FOR VARIABLE 2
6519C
6520C              2) AS RAW DATA, THAT IS TWO VARIABLES.  A
6521C                 CROSS-TABULATION IS PERFORMED TO GENERATE
6522C                 AN RXC TABLE OF COUNTS.
6523C
6524C              3) AS A MATRIX, I.E., THE RXC TABLE HAS ALREADY
6525C                 BEEN GENERATED.
6526C
6527C              THE FISHER EXACT TEST IS COMPUTED USING ACM
6528C              ALGORITHM 643.
6529C
6530C     EXAMPLE--FISHER EXACT TEST Y1 Y2
6531C            --FISHER EXACT TEST N11 N21 N12 N22
6532C            --FISHER EXACT TEST M
6533C     WRITTEN BY--ALAN HECKERT
6534C                 STATISTICAL ENGINEERING DIVISION
6535C                 INFORMATION TECHNOLOGYU LABORATORY
6536C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
6537C                 GAITHERSBURG, MD 20899-8980
6538C                 PHONE--301-975-2899
6539C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
6540C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
6541C     LANGUAGE--ANSI FORTRAN (1977)
6542C     VERSION NUMBER--2007/3
6543C     ORIGINAL VERSION--MARCH     2007.
6544C
6545C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
6546C
6547      CHARACTER*4 ISUBRO
6548      CHARACTER*4 IBUGA3
6549      CHARACTER*4 IERROR
6550      CHARACTER*4 ICASE
6551      CHARACTER*4 ICAPSW
6552      CHARACTER*4 ICAPTY
6553      CHARACTER*4 IFORSW
6554C
6555      CHARACTER*4 IWRITE
6556      CHARACTER*6 ICONC1
6557      CHARACTER*6 ICONC2
6558      CHARACTER*6 ICONC3
6559      CHARACTER*6 ICONC4
6560      CHARACTER*6 ICONC5
6561      CHARACTER*4 ISUBN1
6562      CHARACTER*4 ISUBN2
6563      CHARACTER*4 ISTEPN
6564      CHARACTER*4 IOP
6565C
6566C---------------------------------------------------------------------
6567C
6568      DIMENSION Y1(*)
6569      DIMENSION Y2(*)
6570      DIMENSION TEMP1(*)
6571      DIMENSION TEMP2(*)
6572      DIMENSION TEMP3(*)
6573      DIMENSION XIDTEM(*)
6574      DIMENSION XIDTE2(*)
6575      DIMENSION RWORK(*)
6576C
6577      INTEGER IWORK(*)
6578C
6579      DOUBLE PRECISION XMAT(MAXLEV,MAXLEV)
6580      DOUBLE PRECISION ROWTOT(*)
6581      DOUBLE PRECISION COLTOT(*)
6582      DOUBLE PRECISION DWORK(*)
6583C
6584      PARAMETER (NUMALP=5)
6585CCCCC DIMENSION SIGVAL(NUMALP)
6586CCCCC DIMENSION ALOWCL(NUMALP)
6587CCCCC DIMENSION AUPPCL(NUMALP)
6588CCCCC DIMENSION ALOWC2(NUMALP)
6589CCCCC DIMENSION AUPPC2(NUMALP)
6590C
6591      DOUBLE PRECISION GTOTAL
6592      DOUBLE PRECISION EMIN
6593      DOUBLE PRECISION EXPECT
6594      DOUBLE PRECISION PERCNT
6595      DOUBLE PRECISION PRE
6596      DOUBLE PRECISION PRT
6597C
6598      PARAMETER(NUMCLI=4)
6599      PARAMETER(MAXLIN=3)
6600      PARAMETER (MAXROW=NUMALP)
6601      PARAMETER (MAXRO2=20)
6602      CHARACTER*60 ITITLE
6603      CHARACTER*60 ITITLZ
6604      CHARACTER*60 ITITL9
6605      CHARACTER*60 ITEXT(MAXRO2)
6606      CHARACTER*4  ALIGN(NUMCLI)
6607      CHARACTER*4  VALIGN(NUMCLI)
6608      REAL         AVALUE(MAXRO2)
6609      INTEGER      NCTEXT(MAXRO2)
6610      INTEGER      IDIGIT(MAXRO2)
6611      INTEGER      NTOT(MAXRO2)
6612      CHARACTER*60 ITITL2(MAXLIN,NUMCLI)
6613      CHARACTER*15 IVALUE(MAXROW,NUMCLI)
6614      CHARACTER*4  ITYPCO(NUMCLI)
6615      INTEGER      NCTIT2(MAXLIN,NUMCLI)
6616      INTEGER      NCVALU(MAXROW,NUMCLI)
6617      INTEGER      IWHTML(NUMCLI)
6618      INTEGER      IWRTF(NUMCLI)
6619      REAL         AMAT(MAXROW,NUMCLI)
6620      LOGICAL IFRST
6621      LOGICAL ILAST
6622      LOGICAL IFLAGS
6623      LOGICAL IFLAGE
6624C
6625C-----COMMON----------------------------------------------------------
6626C
6627      INCLUDE 'DPCOST.INC'
6628      INCLUDE 'DPCOP2.INC'
6629C
6630CCCCC DATA SIGVAL /0.50, 0.80, 0.90, 0.95, 0.99/
6631C
6632C-----START POINT-----------------------------------------------------
6633C
6634      ISUBN1='DPFI'
6635      ISUBN2='S2  '
6636C
6637      IERROR='NO'
6638      IWRITE='NO'
6639C
6640      IOP='OPEN'
6641      IFLAG1=1
6642      IFLAG2=0
6643      IFLAG3=0
6644      IFLAG4=0
6645      IFLAG5=0
6646      CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
6647     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
6648     1            IBUGA3,ISUBRO,IERROR)
6649      IF(IERROR.EQ.'YES')GOTO9000
6650C
6651      WRITE(IOUNI1,41)
6652   41 FORMAT(5X,'ROW  COLUMN',9X,'ROWTOT',9X,'COLTOT',6X,'EXPECTED',
6653     1      8X,'OBSERVED')
6654C
6655      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FIS2')THEN
6656        WRITE(ICOUT,999)
6657  999   FORMAT(1X)
6658        CALL DPWRST('XXX','WRIT')
6659        WRITE(ICOUT,51)
6660   51   FORMAT('**** AT THE BEGINNING OF DPFIS2--')
6661        CALL DPWRST('XXX','WRIT')
6662        WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASE,MAXNXT
6663   52   FORMAT('IBUGA3,ISUBRO,ICASE,MAXNXT = ',3(A4,2X),I8)
6664        CALL DPWRST('XXX','WRIT')
6665        IF(ICASE.EQ.'VARI')THEN
6666          WRITE(ICOUT,55)N1
6667   55     FORMAT('N1 = ',I8)
6668          CALL DPWRST('XXX','WRIT')
6669          DO56I=1,N1
6670            WRITE(ICOUT,57)I,Y1(I)
6671   57       FORMAT('I,Y1(I) = ',I8,E15.7)
6672            CALL DPWRST('XXX','WRIT')
6673   56     CONTINUE
6674          WRITE(ICOUT,65)N2
6675   65     FORMAT('N2 = ',I8)
6676          CALL DPWRST('XXX','WRIT')
6677          DO66I=1,N2
6678            WRITE(ICOUT,67)I,Y2(I)
6679   67       FORMAT('I,Y2(I) = ',I8,E15.7)
6680            CALL DPWRST('XXX','WRIT')
6681   66     CONTINUE
6682        ELSEIF(ICASE.EQ.'TABL')THEN
6683          WRITE(ICOUT,81)NROW,NCOL
6684   81     FORMAT('NROW,NCOL = ',2I8)
6685          CALL DPWRST('XXX','WRIT')
6686          DO82I=1,NROW
6687            WRITE(ICOUT,83)(XMAT(I,J),J=1,MIN(NCOL,5))
6688   83       FORMAT('I,XMAT(I,J) = ',I8,5G15.7)
6689            CALL DPWRST('XXX','WRIT')
6690   82     CONTINUE
6691        ELSE
6692          WRITE(ICOUT,75)AN11,AN21,AN12,AN22
6693   75     FORMAT('AN11,AN21,AN12,AN22 = ',4G15.7)
6694          CALL DPWRST('XXX','WRIT')
6695        ENDIF
6696      ENDIF
6697
6698C               ********************************************
6699C               **  STEP 0--                              **
6700C               **  BRANCH TO APPROPRIATE CASE (PARAMETER **
6701C               **  OR VARIABLE)                          **
6702C               ********************************************
6703C
6704      ISTEPN='00'
6705      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIS2')
6706     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6707C
6708      IF(ICASE.EQ.'PARA')GOTO1000
6709      IF(ICASE.EQ.'VARI')GOTO2000
6710      IF(ICASE.EQ.'TABL')GOTO3000
6711C
6712C               ********************************************
6713C               **  STEP 11--                             **
6714C               **  PARAMETER CASE                        **
6715C               ********************************************
6716C
6717 1000 CONTINUE
6718C
6719      ISTEPN='11'
6720      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIS2')
6721     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6722C
6723C               ********************************************
6724C               **  STEP 12--                             **
6725C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
6726C               ********************************************
6727C
6728      N11=INT(AN11+0.5)
6729      N21=INT(AN21+0.5)
6730      N12=INT(AN12+0.5)
6731      N22=INT(AN22+0.5)
6732C
6733      ISTEPN='12'
6734      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIS2')
6735     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6736C
6737      IF(N11.LT.0)THEN
6738        WRITE(ICOUT,999)
6739        CALL DPWRST('XXX','BUG ')
6740        WRITE(ICOUT,1201)
6741 1201   FORMAT('***** ERROR FROM THE FISHER EXACT TEST--')
6742        CALL DPWRST('XXX','BUG ')
6743        WRITE(ICOUT,1203)
6744 1203   FORMAT('      THE VALUE OF THE FIRST PARAMETER (N11 = THE ',
6745     1         'NUMBER OF SUCCESSES')
6746        CALL DPWRST('XXX','BUG ')
6747        WRITE(ICOUT,1204)
6748 1204   FORMAT('      FOR THE FIRST VARIABLE MUST BE NON-NEGATIVE.')
6749        CALL DPWRST('XXX','BUG ')
6750        WRITE(ICOUT,1205)N11
6751 1205   FORMAT('      N11 = ',I8)
6752        CALL DPWRST('XXX','BUG ')
6753        IERROR='YES'
6754        GOTO9000
6755      ENDIF
6756C
6757      IF(N21.LT.0)THEN
6758        WRITE(ICOUT,999)
6759        CALL DPWRST('XXX','BUG ')
6760        WRITE(ICOUT,1201)
6761        CALL DPWRST('XXX','BUG ')
6762        WRITE(ICOUT,1303)
6763 1303   FORMAT('      THE VALUE OF THE SECOND PARAMETER (N21 = THE ',
6764     1         'NUMBER OF FAILURES')
6765        CALL DPWRST('XXX','BUG ')
6766        WRITE(ICOUT,1304)
6767 1304   FORMAT('      FOR THE FIRST VARIABLE MUST BE NON-NEGATIVE.')
6768        CALL DPWRST('XXX','BUG ')
6769        WRITE(ICOUT,1305)N21
6770 1305   FORMAT('      N21 = ',I8)
6771        CALL DPWRST('XXX','BUG ')
6772        IERROR='YES'
6773        GOTO9000
6774      ENDIF
6775C
6776      IF(N12.LT.0)THEN
6777        WRITE(ICOUT,999)
6778        CALL DPWRST('XXX','BUG ')
6779        WRITE(ICOUT,1201)
6780        CALL DPWRST('XXX','BUG ')
6781        WRITE(ICOUT,1403)
6782 1403   FORMAT('      THE VALUE OF THE THIRD PARAMETER (N12 = THE ',
6783     1         'NUMBER OF SUCCESSES')
6784        CALL DPWRST('XXX','BUG ')
6785        WRITE(ICOUT,1404)
6786 1404   FORMAT('      FOR THE SECOND VARIABLE MUST BE NON-NEGATIVE.')
6787        CALL DPWRST('XXX','BUG ')
6788        WRITE(ICOUT,1405)N12
6789 1405   FORMAT('      N12 = ',I8)
6790        CALL DPWRST('XXX','BUG ')
6791        IERROR='YES'
6792        GOTO9000
6793      ENDIF
6794C
6795      IF(N22.LT.0)THEN
6796        WRITE(ICOUT,999)
6797        CALL DPWRST('XXX','BUG ')
6798        WRITE(ICOUT,1201)
6799        CALL DPWRST('XXX','BUG ')
6800        WRITE(ICOUT,1503)
6801 1503   FORMAT('      THE VALUE OF THE FOURTH PARAMETER (N22 = THE ',
6802     1         'NUMBER OF FAILURES')
6803        CALL DPWRST('XXX','BUG ')
6804        WRITE(ICOUT,1504)
6805 1504   FORMAT('      FOR THE SECOND VARIABLE MUST BE NON-NEGATIVE.')
6806        CALL DPWRST('XXX','BUG ')
6807        WRITE(ICOUT,1505)N22
6808 1505   FORMAT('      N22 = ',I8)
6809        CALL DPWRST('XXX','BUG ')
6810        IERROR='YES'
6811        GOTO9000
6812      ENDIF
6813C
6814C               ********************************************
6815C               **  STEP 12--                             **
6816C               **  COMPUTE THE FISHER EXACT TEST         **
6817C               ********************************************
6818C
6819      XMAT(1,1)=DBLE(AN11)
6820      XMAT(2,1)=DBLE(AN21)
6821      XMAT(1,2)=DBLE(AN12)
6822      XMAT(2,2)=DBLE(AN22)
6823      ROWTOT(1)=DBLE(AN11 + AN12)
6824      ROWTOT(2)=DBLE(AN21 + AN22)
6825      COLTOT(1)=DBLE(AN11 + AN21)
6826      COLTOT(2)=DBLE(AN12 + AN22)
6827      GTOTAL=ROWTOT(1) + ROWTOT(2)
6828      NROW=2
6829      NCOL=2
6830C
6831      IINDX=0
6832      DO1600J=1,2
6833        DO1610I=1,2
6834          IINDX=IINDX+1
6835          EXP=ROWTOT(I)*COLTOT(J)/GTOTAL
6836          OBS=XMAT(I,J)
6837          WRITE(IOUNI1,1605)I,J,ROWTOT(I),COLTOT(J),EXP,OBS
6838 1605     FORMAT(I8,I8,4E15.7)
6839C
6840 1610   CONTINUE
6841 1600 CONTINUE
6842      GOTO4000
6843C
6844C               ********************************************
6845C               **  STEP 20--                             **
6846C               **  VARIABLE  CASE                        **
6847C               ********************************************
6848C
6849 2000 CONTINUE
6850C
6851C               ********************************************
6852C               **  STEP 21--                             **
6853C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
6854C               ********************************************
6855C
6856      ISTEPN='21'
6857      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIS2')
6858     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6859C
6860      IF(N1.LT.2)THEN
6861        WRITE(ICOUT,999)
6862        CALL DPWRST('XXX','WRIT')
6863        WRITE(ICOUT,1201)
6864        CALL DPWRST('XXX','WRIT')
6865        WRITE(ICOUT,2101)
6866 2101   FORMAT('      THE NUMBER OF OBSERVATIONS FOR VARIABLE 1 ',
6867     1         'IS NON-POSITIVE')
6868        CALL DPWRST('XXX','WRIT')
6869        WRITE(ICOUT,2103)N1
6870 2103   FORMAT('SAMPLE SIZE = ',I8)
6871        CALL DPWRST('XXX','WRIT')
6872        IERROR='YES'
6873        GOTO9000
6874      ENDIF
6875C
6876      IF(N2.LT.2)THEN
6877        WRITE(ICOUT,999)
6878        CALL DPWRST('XXX','WRIT')
6879        WRITE(ICOUT,1201)
6880        CALL DPWRST('XXX','WRIT')
6881        WRITE(ICOUT,2106)
6882 2106   FORMAT('      THE NUMBER OF OBSERVATIONS FOR VARIABLE 2 ',
6883     1         'IS NON-POSITIVE')
6884        CALL DPWRST('XXX','WRIT')
6885        WRITE(ICOUT,2103)N2
6886        CALL DPWRST('XXX','WRIT')
6887        IERROR='YES'
6888        GOTO9000
6889      ENDIF
6890C
6891C               ******************************************************
6892C               **  STEP 2.2--                                      **
6893C               **  DETERMINE THE NUMBER OF DISTINCT VALUES         **
6894C               **  FOR THE GROUP VARIABLES (Y1, Y2).               **
6895C               ******************************************************
6896C
6897      ISTEPN='22'
6898      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIS2')
6899     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6900C
6901      CALL DISTIN(Y1,N1,IWRITE,XIDTEM,NUMSE1,IBUGA3,IERROR)
6902      CALL SORT(XIDTEM,NUMSE1,XIDTEM)
6903      CALL DISTIN(Y2,N2,IWRITE,XIDTE2,NUMSE2,IBUGA3,IERROR)
6904      CALL SORT(XIDTE2,NUMSE2,XIDTE2)
6905C
6906      IF(NUMSE1.LT.1)THEN
6907        WRITE(ICOUT,999)
6908        CALL DPWRST('XXX','BUG ')
6909        WRITE(ICOUT,2201)
6910 2201   FORMAT('***** ERROR IN FISHER EXACT TEST--')
6911        CALL DPWRST('XXX','BUG ')
6912        WRITE(ICOUT,2202)
6913 2202   FORMAT('      NUMBER OF SETS    NUMSE1 = 0 ')
6914        CALL DPWRST('XXX','BUG ')
6915        IERROR='YES'
6916        GOTO9000
6917      ENDIF
6918C
6919      IF(NUMSE2.LT.1)THEN
6920        WRITE(ICOUT,999)
6921        CALL DPWRST('XXX','BUG ')
6922        WRITE(ICOUT,2201)
6923        CALL DPWRST('XXX','BUG ')
6924        WRITE(ICOUT,2204)
6925 2204   FORMAT('      NUMBER OF SETS    NUMSE2 = 0 ')
6926        CALL DPWRST('XXX','BUG ')
6927        IERROR='YES'
6928        GOTO9000
6929      ENDIF
6930C
6931      AN1=N1
6932      AN2=N2
6933      ANUMS1=NUMSE1
6934      ANUMS2=NUMSE2
6935C
6936C               ***********************************************
6937C               **  STEP 2.3--                               **
6938C               **  COMPUTE COUNTS FOR EACH CELL             **
6939C               ***********************************************
6940C
6941      ISTEPN='23'
6942      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIS2')
6943     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6944C
6945      IWRITE='OFF'
6946C
6947      J=0
6948      DO2310ISET1=1,NUMSE1
6949        DO2320ISET2=1,NUMSE2
6950C
6951          K=0
6952          DO2330I=1,N1
6953            IF(XIDTEM(ISET1).EQ.Y1(I).AND.XIDTE2(ISET2).EQ.Y2(I))THEN
6954C
6955              K=K+1
6956            ENDIF
6957 2330     CONTINUE
6958          NTEMP=K
6959          J=J+1
6960          TEMP1(J)=REAL(K)
6961          TEMP2(J)=XIDTEM(ISET1)
6962          TEMP3(J)=XIDTE2(ISET2)
6963C
6964 2320   CONTINUE
6965 2310 CONTINUE
6966      NTEMP2=J
6967C
6968C     COMPUTE ROW AND COLUMN TOTALS AND GRAND TOTAL.
6969C
6970      J=0
6971      GTOTAL=0.0D0
6972C
6973      DO2340ISET1=1,NUMSE1
6974        ROWTOT(ISET1)=0.0D0
6975        DO2350ISET2=1,NUMSE2
6976          J=J+1
6977          ROWTOT(ISET1)=ROWTOT(ISET1) + DBLE(TEMP1(J))
6978          GTOTAL=GTOTAL + DBLE(TEMP1(J))
6979 2350   CONTINUE
6980C
6981        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIS2')THEN
6982          WRITE(ICOUT,2352)ISET1,ROWTOT(ISET1)
6983 2352     FORMAT('ISET1,ROWTOT(ISET1)=',I5,1X,G15.7)
6984          CALL DPWRST('XXX','BUG ')
6985        ENDIF
6986 2340 CONTINUE
6987C
6988      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIS2')THEN
6989        WRITE(ICOUT,2355)GTOTAL
6990 2355   FORMAT('GTOTAL=',G15.7)
6991        CALL DPWRST('XXX','BUG ')
6992      ENDIF
6993C
6994      DO2360ISET2=1,NUMSE2
6995        COLTOT(ISET2)=0.0D0
6996        VALTMP=XIDTE2(ISET2)
6997        DO2370J=1,NTEMP2
6998          IF(TEMP3(J).EQ.XIDTE2(ISET2))THEN
6999            COLTOT(ISET2)=COLTOT(ISET2) + DBLE(TEMP1(J))
7000          ENDIF
7001 2370   CONTINUE
7002C
7003        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIS2')THEN
7004          WRITE(ICOUT,2372)ISET2,COLTOT(ISET2)
7005 2372     FORMAT('ISET2,COLTOT(ISET2)=',I5,1X,G15.7)
7006          CALL DPWRST('XXX','BUG ')
7007        ENDIF
7008C
7009 2360 CONTINUE
7010C
7011      NROW=NUMSE1
7012      NCOL=NUMSE2
7013C
7014      J=0
7015C
7016      DO2380ISET1=1,NUMSE1
7017        DO2390ISET2=1,NUMSE2
7018          J=J+1
7019          EXP=ROWTOT(ISET1)*COLTOT(ISET2)/GTOTAL
7020          OBS=TEMP1(J)
7021          XMAT(ISET1,ISET2)=DBLE(OBS)
7022          WRITE(IOUNI1,2385)ISET1,ISET2,ROWTOT(ISET1),COLTOT(ISET2),
7023     1                      EXP,OBS
7024 2385     FORMAT(I8,I8,E15.7,E15.7,E15.7,E15.7)
7025 2390   CONTINUE
7026 2380 CONTINUE
7027      GOTO4000
7028C
7029 3000 CONTINUE
7030C
7031C               ********************************************
7032C               **  STEP 31--                             **
7033C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
7034C               **  ALL TABLE ENTRIES SHOULD BE           **
7035C               **  NON-NEGATIVE INTEGERS.  NEGATIVE      **
7036C               **  VALUES WILL BE FLAGGED AS ERRORS      **
7037C               **  WHILE NON-INTEGER VALUES WILL BE      **
7038C               **  ROUNDED TO NEAREST INTEGER.           **
7039C               **  SINCE WE ARE SCANNING TABLE, COMPUTE  **
7040C               **  ROW AND COLUMN TOTALS.                **
7041C               ********************************************
7042C
7043      ISTEPN='31'
7044      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIS2')
7045     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7046C
7047      IERROR='NO'
7048      NUMERR=0
7049      MAXERR=10
7050C
7051      DO3001I=1,NROW
7052        ROWTOT(I)=0.0D0
7053 3001 CONTINUE
7054      GTOTAL=0.0D0
7055C
7056      DO3010J=1,NCOL
7057        COLTOT(J)=0.0D0
7058        DO3020I=1,NROW
7059          IF(XMAT(I,J).LT.0.0D0)THEN
7060            NUMERR=NUMERR+1
7061            IF(NUMERR.GT.MAXERR)GOTO9000
7062            IERROR='YES'
7063            WRITE(ICOUT,999)
7064            CALL DPWRST('XXX','WRIT')
7065            WRITE(ICOUT,1201)
7066            CALL DPWRST('XXX','WRIT')
7067            WRITE(ICOUT,3021)I,J
7068 3021       FORMAT('      ROW ',I8,' AND COLUMN ',I8,
7069     1             ' OF THE INPUT TABLE')
7070            CALL DPWRST('XXX','WRIT')
7071            WRITE(ICOUT,3023)XMAT(I,J)
7072 3023       FORMAT('      IS NEGATIVE.  THE VALIE IS ',G15.7)
7073            CALL DPWRST('XXX','WRIT')
7074          ELSE
7075            ITEMP=INT(XMAT(I,J)+0.5D0)
7076            XMAT(I,J)=DBLE(ITEMP)
7077            COLTOT(J)=COLTOT(J) + XMAT(I,J)
7078            ROWTOT(I)=ROWTOT(I) + XMAT(I,J)
7079            GTOTAL=GTOTAL + XMAT(I,J)
7080          ENDIF
7081 3020   CONTINUE
7082 3010 CONTINUE
7083C
7084      DO3110I=1,NROW
7085        DO3120J=1,NCOL
7086          EXP=ROWTOT(I)*COLTOT(J)/GTOTAL
7087          WRITE(IOUNI1,2385)I,J,ROWTOT(I),COLTOT(J),
7088     1                      EXP,XMAT(I,J)
7089 3120   CONTINUE
7090 3110 CONTINUE
7091C
7092      IF(IERROR.EQ.'YES')GOTO9000
7093C
7094C               **********************************************
7095C               **  STEP 32--                               **
7096C               **  COMPUTE THE FISHER EXACT TEST STATISTIC **
7097C               **********************************************
7098C
7099      ISTEPN='32'
7100      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIS2')
7101     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7102C
7103      AN1=REAL(GTOTAL)
7104      AN2=REAL(GTOTAL)
7105C
7106      GOTO4000
7107C
7108C               ********************************************
7109C               **  STEP 41--                             **
7110C               **  FOR ALL INPUT METHODS (SCALAR,        **
7111C               **  TWO VARIABLES, TABLE), CALL FEXACT    **
7112C               **  AND PRINT THE RESULTS.                **
7113C               ********************************************
7114C
7115 4000 CONTINUE
7116C
7117      ISTEPN='41'
7118      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIS2')
7119     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7120C
7121      IOP='CLOS'
7122      CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
7123     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
7124     1            IBUGA3,ISUBRO,IERROR)
7125      IF(IERROR.EQ.'YES')GOTO9000
7126C
7127C     NOTE THAT EXPECT, PERCNT, AND EMIN ARE USED TO DEFINE
7128C     WHEN CHI-SQUARE APPROXIMATIONS CAN BE USED.  WE USE THE
7129C     DEFAULT "COCHRAN CONDITION" SETTINGS.  ONCE BASIC CODE IS
7130C     DEBUGGED, WE WILL MAKE THESE VALUES SETTABLE VIA SET
7131C     COMMANDS.
7132C
7133      LDTABL=MAXLEV
7134CCCCC EXPECT=5.0D0
7135      EXPECT=-1.0D0
7136      PERCNT=80.0D0
7137      EMIN=1.0D0
7138C
7139      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FIS2')THEN
7140        WRITE(ICOUT,999)
7141        CALL DPWRST('XXX','WRIT')
7142        WRITE(ICOUT,4011)
7143 4011   FORMAT('***** BEFORE CALL FEXACT')
7144        CALL DPWRST('XXX','WRIT')
7145        WRITE(ICOUT,4012)LDTABL,EXPECT,PERCNT,EMIN
7146 4012   FORMAT('LDTABL,EXPECT,PERCNT,EMIN=',4G15.7)
7147        CALL DPWRST('XXX','WRIT')
7148        WRITE(ICOUT,4013)NROW,NCOL,IWKMX
7149 4013   FORMAT('NROW,NCOL,IWKMX = ',3I8)
7150        CALL DPWRST('XXX','WRIT')
7151      ENDIF
7152C
7153      CALL FEXACT(NROW,NCOL,XMAT,LDTABL,EXPECT,PERCNT,
7154     1             EMIN,PRT,PRE,
7155     1             RWORK,DWORK,IWORK,IWKMX)
7156      STATVA=REAL(PRT)
7157      PVAL=REAL(PRE)
7158      CDF=1.0 - PVAL
7159C
7160      IWRITE='OFF'
7161C
7162      ICONC1='REJECT'
7163      ICONC2='REJECT'
7164      ICONC3='REJECT'
7165      ICONC4='REJECT'
7166      ICONC5='REJECT'
7167C
7168      IF(0.250.LE.CDF.AND.CDF.LE.0.750)ICONC1='ACCEPT'
7169      IF(0.100.LE.CDF.AND.CDF.LE.0.90)ICONC2='ACCEPT'
7170      IF(0.050.LE.CDF.AND.CDF.LE.0.95)ICONC3='ACCEPT'
7171      IF(0.025.LE.CDF.AND.CDF.LE.0.975)ICONC4='ACCEPT'
7172      IF(0.005.LE.CDF.AND.CDF.LE.0.995)ICONC5='ACCEPT'
7173C
7174C               ******************************
7175C               **   STEP 42--              **
7176C               **   WRITE OUT EVERYTHING   **
7177C               **   FOR FISHER EXACT TEST  **
7178C               ******************************
7179C
7180      ISTEPN='42'
7181      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIS2')
7182     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7183C
7184      IF(IPRINT.EQ.'OFF')GOTO9000
7185C
7186      NUMDIG=7
7187      IF(IFORSW.EQ.'1')NUMDIG=1
7188      IF(IFORSW.EQ.'2')NUMDIG=2
7189      IF(IFORSW.EQ.'3')NUMDIG=3
7190      IF(IFORSW.EQ.'4')NUMDIG=4
7191      IF(IFORSW.EQ.'5')NUMDIG=5
7192      IF(IFORSW.EQ.'6')NUMDIG=6
7193      IF(IFORSW.EQ.'7')NUMDIG=7
7194      IF(IFORSW.EQ.'8')NUMDIG=8
7195      IF(IFORSW.EQ.'9')NUMDIG=9
7196      IF(IFORSW.EQ.'0')NUMDIG=0
7197      IF(IFORSW.EQ.'E')NUMDIG=-2
7198      IF(IFORSW.EQ.'-2')NUMDIG=-2
7199      IF(IFORSW.EQ.'-3')NUMDIG=-3
7200      IF(IFORSW.EQ.'-4')NUMDIG=-4
7201      IF(IFORSW.EQ.'-5')NUMDIG=-5
7202      IF(IFORSW.EQ.'-6')NUMDIG=-6
7203      IF(IFORSW.EQ.'-7')NUMDIG=-7
7204      IF(IFORSW.EQ.'-8')NUMDIG=-8
7205      IF(IFORSW.EQ.'-9')NUMDIG=-9
7206C
7207      ITITLE='Fisher Exact Test for Independence (RxC Table)'
7208      NCTITL=46
7209      ITITLZ=' '
7210      NCTITZ=0
7211C
7212      ICNT=0
7213      ICNT=ICNT+1
7214      ITEXT(ICNT)=' '
7215      NCTEXT(ICNT)=0
7216      AVALUE(ICNT)=0.0
7217      IDIGIT(ICNT)=-1
7218      ICNT=ICNT+1
7219      ITEXT(ICNT)='H0: The Two Variables Are Independent'
7220      NCTEXT(ICNT)=38
7221      AVALUE(ICNT)=0.0
7222      IDIGIT(ICNT)=-1
7223      ICNT=ICNT+1
7224      ITEXT(ICNT)='Ha: The Two Variables Are Not Independent'
7225      NCTEXT(ICNT)=42
7226      AVALUE(ICNT)=0.0
7227      IDIGIT(ICNT)=-1
7228      ICNT=ICNT+1
7229      ITEXT(ICNT)=' '
7230      NCTEXT(ICNT)=0
7231      AVALUE(ICNT)=0.0
7232      IDIGIT(ICNT)=-1
7233C
7234      ICNT=ICNT+1
7235      ITEXT(ICNT)='Sample 1:'
7236      NCTEXT(ICNT)=9
7237      AVALUE(ICNT)=0.0
7238      IDIGIT(ICNT)=-1
7239      ICNT=ICNT+1
7240      ITEXT(ICNT)='Number of Observations:'
7241      NCTEXT(ICNT)=23
7242      AVALUE(ICNT)=AN1
7243      IDIGIT(ICNT)=0
7244      ICNT=ICNT+1
7245      ITEXT(ICNT)='Number of Levels (rows):'
7246      NCTEXT(ICNT)=24
7247      AVALUE(ICNT)=REAL(NROW)
7248      IDIGIT(ICNT)=0
7249      ICNT=ICNT+1
7250      ITEXT(ICNT)=' '
7251      NCTEXT(ICNT)=0
7252      AVALUE(ICNT)=0.0
7253      IDIGIT(ICNT)=-1
7254C
7255      ICNT=ICNT+1
7256      ITEXT(ICNT)='Sample 2:'
7257      NCTEXT(ICNT)=9
7258      AVALUE(ICNT)=0.0
7259      IDIGIT(ICNT)=-1
7260      ICNT=ICNT+1
7261      ITEXT(ICNT)='Number of Observations:'
7262      NCTEXT(ICNT)=23
7263      AVALUE(ICNT)=AN2
7264      IDIGIT(ICNT)=0
7265      ICNT=ICNT+1
7266      ITEXT(ICNT)='Number of Levels (Columns):'
7267      NCTEXT(ICNT)=27
7268      AVALUE(ICNT)=REAL(NCOL)
7269      IDIGIT(ICNT)=0
7270      ICNT=ICNT+1
7271      ITEXT(ICNT)=' '
7272      NCTEXT(ICNT)=0
7273      AVALUE(ICNT)=0.0
7274      IDIGIT(ICNT)=-1
7275      ICNT=ICNT+1
7276      ITEXT(ICNT)='Probability of Observed Table:'
7277      NCTEXT(ICNT)=30
7278      AVALUE(ICNT)=STATVA
7279      IDIGIT(ICNT)=NUMDIG
7280      ICNT=ICNT+1
7281      ITEXT(ICNT)='CDF Value of Test Statistic:'
7282      NCTEXT(ICNT)=26
7283      AVALUE(ICNT)=CDF
7284      IDIGIT(ICNT)=NUMDIG
7285      ICNT=ICNT+1
7286      ITEXT(ICNT)='P-Value:'
7287      NCTEXT(ICNT)=8
7288      AVALUE(ICNT)=PVAL
7289      IDIGIT(ICNT)=NUMDIG
7290C
7291      NUMROW=ICNT
7292      DO5010I=1,NUMROW
7293        NTOT(I)=15
7294 5010 CONTINUE
7295C
7296      IFRST=.TRUE.
7297      ILAST=.TRUE.
7298      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,
7299     1            NCTEXT,AVALUE,IDIGIT,
7300     1            NTOT,NUMROW,
7301     1            ICAPSW,ICAPTY,ILAST,IFRST,
7302     1            ISUBRO,IBUGA3,IERROR)
7303C
7304      ITITLE(1:14)='Two-Sided Test'
7305      NCTITL=14
7306      ITITL9=' '
7307      NCTIT9=0
7308C
7309      ITITL2(1,1)=' '
7310      NCTIT2(1,1)=0
7311      ITITL2(2,1)='Null'
7312      NCTIT2(2,1)=4
7313      ITITL2(3,1)='Hypothesis'
7314      NCTIT2(3,1)=10
7315C
7316      ITITL2(1,2)=' '
7317      NCTIT2(1,2)=0
7318      ITITL2(2,2)='Confidence'
7319      NCTIT2(2,2)=10
7320      ITITL2(3,2)='Level'
7321      NCTIT2(3,2)=5
7322C
7323      ITITL2(1,3)='Null Hypothesis'
7324      NCTIT2(1,3)=15
7325      ITITL2(2,3)='Acceptance'
7326      NCTIT2(2,3)=10
7327      ITITL2(3,3)='Interval'
7328      NCTIT2(3,3)=8
7329C
7330      ITITL2(1,4)='Null'
7331      NCTIT2(1,4)=4
7332      ITITL2(2,4)='Hypothesis'
7333      NCTIT2(2,4)=10
7334      ITITL2(3,4)='Conclusion'
7335      NCTIT2(3,4)=10
7336C
7337      NMAX=0
7338      NUMCOL=4
7339      DO5210I=1,NUMCOL
7340        VALIGN(I)='b'
7341        ALIGN(I)='r'
7342        NTOT(I)=15
7343        IF(I.EQ.3 .OR. I.EQ.4)NTOT(I)=18
7344        NMAX=NMAX+NTOT(I)
7345        ITYPCO(I)='ALPH'
7346        IF(I.EQ.2)THEN
7347          IDIGIT(I)=1
7348        ELSE
7349          IDIGIT(I)=NUMDIG
7350        ENDIF
7351        IWHTML(1)=150
7352        IWHTML(2)=125
7353        IWHTML(3)=150
7354        IWHTML(4)=150
7355        IINC=1600
7356        IINC2=1400
7357        IINC3=2200
7358        IWRTF(1)=IINC
7359        IWRTF(2)=IWRTF(1)+IINC
7360        IWRTF(3)=IWRTF(2)+IINC3
7361        IWRTF(4)=IWRTF(3)+IINC2
7362C
7363        DO5289J=1,NUMALP
7364          IF(J.EQ.1)THEN
7365            IVALUE(J,2)='50.0%'
7366            NCVALU(J,2)=5
7367            IVALUE(J,3)='(0.250,0.750)'
7368            NCVALU(J,3)=13
7369            IVALUE(J,4)(1:6)=ICONC1(1:6)
7370            NCVALU(J,4)=6
7371          ELSEIF(J.EQ.2)THEN
7372            IVALUE(J,2)='80.0%'
7373            NCVALU(J,2)=5
7374            IVALUE(J,3)='(0.100,0.900)'
7375            NCVALU(J,3)=13
7376            IVALUE(J,4)(1:6)=ICONC2(1:6)
7377            NCVALU(J,4)=6
7378          ELSEIF(J.EQ.3)THEN
7379            IVALUE(J,2)='90.0%'
7380            NCVALU(J,2)=5
7381            IVALUE(J,3)='(0.050,0.950)'
7382            NCVALU(J,3)=13
7383            IVALUE(J,4)(1:6)=ICONC3(1:6)
7384            NCVALU(J,4)=6
7385          ELSEIF(J.EQ.4)THEN
7386            IVALUE(J,2)='95.0%'
7387            NCVALU(J,2)=5
7388            IVALUE(J,3)='(0.025,0.975)'
7389            NCVALU(J,3)=13
7390            IVALUE(J,4)(1:6)=ICONC4(1:6)
7391            NCVALU(J,4)=6
7392          ELSEIF(J.EQ.5)THEN
7393            IVALUE(J,2)='99.0%'
7394            NCVALU(J,2)=5
7395            IVALUE(J,3)='(0.005,0.995)'
7396            NCVALU(J,3)=13
7397            IVALUE(J,4)(1:6)=ICONC5(1:6)
7398            NCVALU(J,4)=6
7399          ENDIF
7400          AMAT(J,1)=0.0
7401          AMAT(J,2)=0.0
7402          AMAT(J,4)=0.0
7403          IVALUE(J,1)='Independent'
7404          NCVALU(J,1)=11
7405 5289   CONTINUE
7406C
7407 5210 CONTINUE
7408C
7409      ICNT=NUMALP
7410      NUMLIN=3
7411      NUMCOL=4
7412      IFRST=.TRUE.
7413      ILAST=.TRUE.
7414      IFLAGS=.TRUE.
7415      IFLAGE=.TRUE.
7416      CALL DPDTA5(ITITLE,NCTITL,
7417     1            ITITL9,NCTIT9,ITITL2,NCTIT2,
7418     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
7419     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
7420     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
7421     1            ICAPSW,ICAPTY,IFRST,ILAST,
7422     1            IFLAGS,IFLAGE,
7423     1            ISUBRO,IBUGA3,IERROR)
7424C
7425C
7426C               *****************
7427C               **  STEP 90--  **
7428C               **  EXIT       **
7429C               *****************
7430C
7431 9000 CONTINUE
7432      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FIS2')THEN
7433        WRITE(ICOUT,999)
7434        CALL DPWRST('XXX','WRIT')
7435        WRITE(ICOUT,9011)
7436 9011   FORMAT('***** AT THE END       OF DPFIS2--')
7437        CALL DPWRST('XXX','WRIT')
7438        WRITE(ICOUT,9013)AN11,AN21,AN12,AN22
7439 9013   FORMAT('AN11,AN21,AN12,AN22=',4G15.7)
7440        CALL DPWRST('XXX','WRIT')
7441        WRITE(ICOUT,9015)AN1,AN2
7442 9015   FORMAT('AN1,AN2=',2G15.7)
7443        CALL DPWRST('XXX','WRIT')
7444        WRITE(ICOUT,9017)N11,N21,N12,N22
7445 9017   FORMAT('N11,N21,N12,N22=',4I8)
7446        CALL DPWRST('XXX','WRIT')
7447      ENDIF
7448C
7449      RETURN
7450      END
7451      SUBROUTINE DPFITH(IHARG,IARGT,ARG,NUMARG,PDEFFT,MAXFIL,PFILTH,
7452     1IBUGP2,IFOUND,IERROR)
7453C
7454C     PURPOSE--DEFINE THE FILL THICKNESSES.
7455C              THESE ARE LOCATED IN THE VECTOR PFILTH(.).
7456C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
7457C                     --IARGT  (A  CHARACTER VECTOR)
7458C                     --ARG
7459C                     --NUMARG
7460C                     --PDEFFT
7461C                     --MAXFIL
7462C                     --IBUGP2 ('ON' OR 'OFF' )
7463C     OUTPUT ARGUMENTS--PFILTH (A FLOATING POINT VECTOR)
7464C                     --IFOUND ('YES' OR 'NO' )
7465C                     --IERROR ('YES' OR 'NO' )
7466C     WRITTEN BY--JAMES J. FILLIBEN
7467C                 STATISTICAL ENGINEERING DIVISION
7468C                 INFORMATION TECHNOLOGY LABORATORY
7469C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
7470C                 GAITHERSBURG, MD 20899-8980
7471C                 PHONE--301-975-2855
7472C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
7473C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
7474C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
7475C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
7476C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
7477C     LANGUAGE--ANSI FORTRAN (1977)
7478C     VERSION NUMBER--82/7
7479C     ORIGINAL VERSION--DECEMBER  1983.
7480C
7481C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
7482C
7483      CHARACTER*4 IHARG
7484C
7485      CHARACTER*4 IBUGP2
7486      CHARACTER*4 IFOUND
7487      CHARACTER*4 IERROR
7488C
7489      CHARACTER*4 IHOLD1
7490C
7491      CHARACTER*4 ISUBN1
7492      CHARACTER*4 ISUBN2
7493      CHARACTER*4 ISTEPN
7494C
7495      DIMENSION IHARG(*)
7496      DIMENSION IARGT(*)
7497      DIMENSION ARG(*)
7498      DIMENSION PFILTH(*)
7499C
7500C---------------------------------------------------------------------
7501C
7502      INCLUDE 'DPCOP2.INC'
7503C
7504C-----START POINT-----------------------------------------------------
7505C
7506      IFOUND='NO'
7507      IERROR='NO'
7508C
7509      NUMFIL=0
7510      IHOLD1='-999'
7511      HOLD1=-999.0
7512      HOLD2=-999.0
7513C
7514      IF(IBUGP2.EQ.'OFF')GOTO90
7515      WRITE(ICOUT,999)
7516  999 FORMAT(1X)
7517      CALL DPWRST('XXX','BUG ')
7518      WRITE(ICOUT,51)
7519   51 FORMAT('***** AT THE BEGINNING OF DPFITH--')
7520      CALL DPWRST('XXX','BUG ')
7521      WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR
7522   52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
7523      CALL DPWRST('XXX','BUG ')
7524      WRITE(ICOUT,53)MAXFIL,NUMFIL
7525   53 FORMAT('MAXFIL,NUMFIL = ',I8,I8)
7526      CALL DPWRST('XXX','BUG ')
7527      WRITE(ICOUT,54)IHOLD1,HOLD1,HOLD2
7528   54 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7)
7529      CALL DPWRST('XXX','BUG ')
7530      WRITE(ICOUT,55)PDEFFT
7531   55 FORMAT('PDEFFT = ',E15.7)
7532      CALL DPWRST('XXX','BUG ')
7533      WRITE(ICOUT,60)NUMARG
7534   60 FORMAT('NUMARG = ',I8)
7535      CALL DPWRST('XXX','BUG ')
7536      DO65I=1,NUMARG
7537      WRITE(ICOUT,66)IHARG(I),IARGT(I),ARG(I)
7538   66 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8)
7539      CALL DPWRST('XXX','BUG ')
7540   65 CONTINUE
7541      WRITE(ICOUT,70)PFILTH(1)
7542   70 FORMAT('PFILTH(1) = ',E15.7)
7543      CALL DPWRST('XXX','BUG ')
7544      DO75I=1,10
7545      WRITE(ICOUT,76)I,PFILTH(I)
7546   76 FORMAT('I,PFILTH(I) = ',I8,2X,E15.7)
7547      CALL DPWRST('XXX','BUG ')
7548   75 CONTINUE
7549   90 CONTINUE
7550C
7551C               **************************************
7552C               **  STEP 1--                        **
7553C               **  BRANCH TO THE APPROPRIATE CASE  **
7554C               **************************************
7555C
7556      ISTEPN='1'
7557      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7558C
7559      IF(NUMARG.LE.0)GOTO9000
7560      IF(NUMARG.EQ.1)GOTO1110
7561      IF(NUMARG.EQ.2)GOTO1120
7562      IF(NUMARG.EQ.3)GOTO1130
7563      GOTO1140
7564C
7565 1110 CONTINUE
7566      GOTO1200
7567C
7568 1120 CONTINUE
7569      IF(IHARG(2).EQ.'ALL')IHOLD1='    '
7570      IF(IHARG(2).EQ.'ALL')HOLD1=PDEFFT
7571      IF(IHARG(2).EQ.'ALL')GOTO1300
7572      GOTO1200
7573C
7574 1130 CONTINUE
7575      IF(IHARG(2).EQ.'ALL')IHOLD1=IHARG(3)
7576      IF(IHARG(2).EQ.'ALL')HOLD1=ARG(3)
7577      IF(IHARG(2).EQ.'ALL')GOTO1300
7578      IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(2)
7579      IF(IHARG(3).EQ.'ALL')HOLD1=ARG(2)
7580      IF(IHARG(3).EQ.'ALL')GOTO1300
7581      GOTO1200
7582C
7583 1140 CONTINUE
7584      GOTO1200
7585C
7586C               *************************************************
7587C               **  STEP 2--                                   **
7588C               **  TREAT THE INDIVIDUAL SPECIFICATIONS CASE  **
7589C               *************************************************
7590C
7591 1200 CONTINUE
7592      ISTEPN='2'
7593      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7594C
7595      IF(NUMARG.LE.1)GOTO1210
7596      GOTO1220
7597C
7598 1210 CONTINUE
7599      NUMFIL=1
7600      PFILTH(1)=PDEFFT
7601      GOTO1270
7602C
7603 1220 CONTINUE
7604      NUMFIL=NUMARG-1
7605      IF(NUMFIL.GT.MAXFIL)NUMFIL=MAXFIL
7606      DO1225I=1,NUMFIL
7607      J=I+1
7608      IHOLD1=IHARG(J)
7609      HOLD1=ARG(J)
7610      HOLD2=HOLD1
7611      IF(IHOLD1.EQ.'ON')HOLD2=PDEFFT
7612      IF(IHOLD1.EQ.'OFF')HOLD2=PDEFFT
7613      IF(IHOLD1.EQ.'AUTO')HOLD2=PDEFFT
7614      IF(IHOLD1.EQ.'DEFA')HOLD2=PDEFFT
7615      PFILTH(I)=HOLD2
7616 1225 CONTINUE
7617      GOTO1270
7618C
7619 1270 CONTINUE
7620      IF(IFEEDB.EQ.'OFF')GOTO1279
7621      WRITE(ICOUT,999)
7622      CALL DPWRST('XXX','BUG ')
7623      DO1278I=1,NUMFIL
7624      WRITE(ICOUT,1276)I,PFILTH(I)
7625 1276 FORMAT('FILL THICKNESS ',I6,' HAS JUST BEEN SET TO ',
7626     1E15.7)
7627      CALL DPWRST('XXX','BUG ')
7628 1278 CONTINUE
7629 1279 CONTINUE
7630      IFOUND='YES'
7631      GOTO9000
7632C
7633C               **************************
7634C               **  STEP 2--            **
7635C               **  TREAT THE ALL CASE  **
7636C               **************************
7637C
7638 1300 CONTINUE
7639      ISTEPN='3'
7640      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7641C
7642      NUMFIL=MAXFIL
7643      HOLD2=HOLD1
7644      IF(IHOLD1.EQ.'ON')HOLD2=PDEFFT
7645      IF(IHOLD1.EQ.'OFF')HOLD2=PDEFFT
7646      IF(IHOLD1.EQ.'AUTO')HOLD2=PDEFFT
7647      IF(IHOLD1.EQ.'DEFA')HOLD2=PDEFFT
7648      DO1315I=1,NUMFIL
7649      PFILTH(I)=HOLD2
7650 1315 CONTINUE
7651      GOTO1370
7652C
7653 1370 CONTINUE
7654      IF(IFEEDB.EQ.'OFF')GOTO1319
7655      WRITE(ICOUT,999)
7656      CALL DPWRST('XXX','BUG ')
7657      I=1
7658      WRITE(ICOUT,1316)PFILTH(I)
7659 1316 FORMAT('ALL FILL THICKNESSES HAVE JUST BEEN SET TO ',
7660     1A4)
7661      CALL DPWRST('XXX','BUG ')
7662 1319 CONTINUE
7663      IFOUND='YES'
7664      GOTO9000
7665C
7666C               *****************
7667C               **  STEP 90--  **
7668C               **  EXIT       **
7669C               *****************
7670C
7671 9000 CONTINUE
7672      IF(IBUGP2.EQ.'OFF')GOTO9090
7673      WRITE(ICOUT,9011)
7674 9011 FORMAT('***** AT THE END       OF DPFITH--')
7675      CALL DPWRST('XXX','BUG ')
7676      WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR
7677 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
7678      CALL DPWRST('XXX','BUG ')
7679      WRITE(ICOUT,9013)MAXFIL,NUMFIL
7680 9013 FORMAT('MAXFIL,NUMFIL = ',I8,I8)
7681      CALL DPWRST('XXX','BUG ')
7682      WRITE(ICOUT,9014)IHOLD1,HOLD1,HOLD2
7683 9014 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7)
7684      CALL DPWRST('XXX','BUG ')
7685      WRITE(ICOUT,9015)PDEFFT
7686 9015 FORMAT('PDEFFT = ',E15.7)
7687      CALL DPWRST('XXX','BUG ')
7688      WRITE(ICOUT,9020)NUMARG
7689 9020 FORMAT('NUMARG = ',I8)
7690      CALL DPWRST('XXX','BUG ')
7691      DO9025I=1,NUMARG
7692      WRITE(ICOUT,9026)IHARG(I),IARGT(I),ARG(I)
7693 9026 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8)
7694      CALL DPWRST('XXX','BUG ')
7695 9025 CONTINUE
7696      WRITE(ICOUT,9030)PFILTH(1)
7697 9030 FORMAT('PFILTH(1) = ',E15.7)
7698      CALL DPWRST('XXX','BUG ')
7699      DO9035I=1,10
7700      WRITE(ICOUT,9036)I,PFILTH(I)
7701 9036 FORMAT('I,PFILTH(I) = ',I8,2X,E15.7)
7702      CALL DPWRST('XXX','BUG ')
7703 9035 CONTINUE
7704 9090 CONTINUE
7705C
7706      RETURN
7707      END
7708      SUBROUTINE DPFIWI(IHARG,IARGT,ARG,NUMARG,DEFFW,
7709     1FILWID,IFOUND,IERROR)
7710C
7711C     PURPOSE--DEFINE THE WIDTH (USUALLY INTEGER) OF THE FILTER
7712C              FOR A SMOOTHING OPERATION
7713C              FOR USE IN THE SMOOTH COMMAND.
7714C              THE SPECIFIED WIDTH WILL BE PLACED
7715C              IN THE FLOATING POINT VARIABLE FILWID.
7716C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
7717C                     --IARGT  (A  HOLLERITH VECTOR)
7718C                     --ARG    (A  HOLLERITH VECTOR)
7719C                     --NUMARG (AN INTEGER VARIABLE)
7720C                     --DEFFW  (A FLOATING POINT VARIABLE)
7721C     OUTPUT ARGUMENTS--FILWID (A FLOATING POINT INTEGER VARIABLE)
7722C                     --IFOUND ('YES' OR 'NO' )
7723C                     --IERROR ('YES' OR 'NO' )
7724C     WRITTEN BY--JAMES J. FILLIBEN
7725C                 STATISTICAL ENGINEERING DIVISION
7726C                 INFORMATION TECHNOLOGY LABORATORY
7727C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
7728C                 GAITHERSBURG, MD 20899-8980
7729C                 PHONE--301-975-2855
7730C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
7731C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
7732C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
7733C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
7734C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
7735C     LANGUAGE--ANSI FORTRAN (1977)
7736C     VERSION NUMBER--82/7
7737C     ORIGINAL VERSION--MAY      1981.
7738C     UPDATED         --MAY       1982.
7739C
7740C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
7741C
7742      CHARACTER*4 IHARG
7743      CHARACTER*4 IARGT
7744      CHARACTER*4 IFOUND
7745      CHARACTER*4 IERROR
7746C
7747C---------------------------------------------------------------------
7748C
7749      DIMENSION IHARG(*)
7750      DIMENSION IARGT(*)
7751      DIMENSION ARG(*)
7752C
7753C---------------------------------------------------------------------
7754C
7755      INCLUDE 'DPCOP2.INC'
7756C
7757C-----START POINT-----------------------------------------------------
7758C
7759      IFOUND='NO'
7760      IERROR='NO'
7761C
7762      IF(NUMARG.LE.0)GOTO1150
7763      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'WIDT')GOTO1150
7764      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
7765      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
7766      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
7767      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
7768      IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160
7769      GOTO1120
7770C
7771 1120 CONTINUE
7772      IERROR='YES'
7773      WRITE(ICOUT,1121)
7774 1121 FORMAT('***** ERROR IN DPFIWI--')
7775      CALL DPWRST('XXX','BUG ')
7776      WRITE(ICOUT,1122)
7777 1122 FORMAT('      ILLEGAL FORM FOR FILTER WIDTH ',
7778     1'COMMAND.')
7779      CALL DPWRST('XXX','BUG ')
7780      WRITE(ICOUT,1124)
7781 1124 FORMAT('      TEST EXAMPLE TO DEMONSTRATE THE ',
7782     1'PROPER FORM--')
7783      CALL DPWRST('XXX','BUG ')
7784      WRITE(ICOUT,1125)
7785 1125 FORMAT('      SUPPOSE THE THE ANALYST WISHES ')
7786      CALL DPWRST('XXX','BUG ')
7787      WRITE(ICOUT,1126)
7788 1126 FORMAT('      TO SET THE FILTER WIDTH = 7 OBSERVATIONS  ')
7789      CALL DPWRST('XXX','BUG ')
7790      WRITE(ICOUT,1127)
7791 1127 FORMAT('      FOR SOME SMOOTHING OPERATION,')
7792      CALL DPWRST('XXX','BUG ')
7793      WRITE(ICOUT,1128)
7794 1128 FORMAT('      THEN AN ALLOWABLE FORM IS--')
7795      CALL DPWRST('XXX','BUG ')
7796      WRITE(ICOUT,1129)
7797 1129 FORMAT('      FILTER WIDTH 7 ')
7798      CALL DPWRST('XXX','BUG ')
7799      GOTO1199
7800C
7801 1150 CONTINUE
7802      HOLD=DEFFW
7803      GOTO1180
7804C
7805 1160 CONTINUE
7806      HOLD=ARG(NUMARG)
7807      GOTO1180
7808C
7809 1180 CONTINUE
7810      IFOUND='YES'
7811      FILWID=HOLD
7812C
7813      IF(IFEEDB.EQ.'OFF')GOTO1189
7814      WRITE(ICOUT,999)
7815  999 FORMAT(1X)
7816      CALL DPWRST('XXX','BUG ')
7817      WRITE(ICOUT,1181)FILWID
7818 1181 FORMAT('THE FILTER WIDTH HAS JUST BEEN SET TO ',
7819     1E15.7)
7820      CALL DPWRST('XXX','BUG ')
7821 1189 CONTINUE
7822      GOTO1199
7823C
7824 1199 CONTINUE
7825      RETURN
7826      END
7827      SUBROUTINE DPFLTE(YTEMP,MAXNXT,
7828     1                  ICAPSW,IFORSW,IMULT,
7829     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
7830C
7831C     PURPOSE--CARRY OUT F TEST FOR SHIFT IN LOCATION
7832C     EXAMPLE--F LOCATION TEST Y X
7833C     REFERENCE--XX
7834C     WRITTEN BY--JAMES J. FILLIBEN
7835C                 STATISTICAL ENGINEERING DIVISION
7836C                 INFORMATION TECHNOLOGY LABORATORY
7837C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
7838C                 GAITHERSBURG, MD 20899-8980
7839C                 PHONE--301-975-2855
7840C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
7841C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
7842C     LANGUAGE--ANSI FORTRAN (1977)
7843C     VERSION NUMBER--97/9
7844C     ORIGINAL VERSION--SEPTEMBER 1997.
7845C     UPDATED         --MAY       2011. SUPPORT FOR HTML, RTF AND LATEX
7846C                                       OUTPUT
7847C     UPDATED         --MAY       2011. USE DPPARS
7848C     UPDATED         --MAY       2011. SUPPORT FOR "MULTIPLE" CASE
7849C
7850C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
7851C
7852      CHARACTER*4 ICAPSW
7853      CHARACTER*4 IFORSW
7854      CHARACTER*4 IMULT
7855      CHARACTER*4 IBUGA2
7856      CHARACTER*4 IBUGA3
7857      CHARACTER*4 IBUGQ
7858      CHARACTER*4 ISUBRO
7859      CHARACTER*4 IFOUND
7860      CHARACTER*4 IERROR
7861C
7862      CHARACTER*4 ISUBN1
7863      CHARACTER*4 ISUBN2
7864      CHARACTER*4 ISTEPN
7865      CHARACTER*4 ICASE
7866C
7867      CHARACTER*4 IFLAGU
7868      LOGICAL IFRST
7869      LOGICAL ILAST
7870      CHARACTER*40 INAME
7871      PARAMETER (MAXSPN=30)
7872      CHARACTER*4 IVARN1(MAXSPN)
7873      CHARACTER*4 IVARN2(MAXSPN)
7874      CHARACTER*4 IVARTY(MAXSPN)
7875      REAL PVAR(MAXSPN)
7876      INTEGER ILIS(MAXSPN)
7877      INTEGER NRIGHT(MAXSPN)
7878      INTEGER ICOLR(MAXSPN)
7879C
7880C---------------------------------------------------------------------
7881C
7882      DIMENSION YTEMP(*)
7883C
7884C-----COMMON----------------------------------------------------------
7885C
7886      INCLUDE 'DPCOPA.INC'
7887C
7888      DIMENSION YMEAN(MAXOBV)
7889      DIMENSION YBARIV(MAXOBV)
7890      DIMENSION DTAG(MAXOBV)
7891C
7892      INCLUDE 'DPCOZZ.INC'
7893      EQUIVALENCE(GARBAG(IGARB1),YBARIV(1))
7894      EQUIVALENCE(GARBAG(IGARB2),DTAG(1))
7895      EQUIVALENCE(GARBAG(IGARB3),YMEAN(1))
7896C
7897      INCLUDE 'DPCOHK.INC'
7898      INCLUDE 'DPCOSU.INC'
7899      INCLUDE 'DPCODA.INC'
7900      INCLUDE 'DPCOP2.INC'
7901C
7902C-----START POINT-----------------------------------------------------
7903C
7904      ISUBN1='DPFL'
7905      ISUBN2='TE  '
7906      IFOUND='YES'
7907      IERROR='NO'
7908C
7909      MAXCP1=MAXCOL+1
7910      MAXCP2=MAXCOL+2
7911      MAXCP3=MAXCOL+3
7912      MAXCP4=MAXCOL+4
7913      MAXCP5=MAXCOL+5
7914      MAXCP6=MAXCOL+6
7915C
7916C               **************************************
7917C               **  TREAT THE F LOCATION TEST CASE  **
7918C               **************************************
7919C
7920      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FLTE')THEN
7921        WRITE(ICOUT,999)
7922  999   FORMAT(1X)
7923        CALL DPWRST('XXX','BUG ')
7924        WRITE(ICOUT,51)
7925   51   FORMAT('***** AT THE BEGINNING OF DPFLTE--')
7926        CALL DPWRST('XXX','BUG ')
7927        WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ,ISUBRO
7928   52   FORMAT('IBUGA2,IBUGA3,IBUGQ,ISUBRO = ',3(A4,2X),A4)
7929        CALL DPWRST('XXX','BUG ')
7930        WRITE(ICOUT,55)IMULT,MAXNXT
7931   55   FORMAT('IMULT,MAXNXT = ',A4,2X,I8)
7932        CALL DPWRST('XXX','BUG ')
7933      ENDIF
7934C
7935C               *********************************
7936C               **  STEP 1--                   **
7937C               **  EXTRACT THE VARIABLE LIST  **
7938C               *********************************
7939C
7940      ISTEPN='1'
7941      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FLTE')
7942     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7943C
7944      INAME='F LOCATION TEST'
7945      MAXNA=100
7946      MINNVA=1
7947      MAXNVA=100
7948      MINNA=1
7949      IFLAGE=1
7950      IFLAGM=0
7951      IF(IMULT.EQ.'ON')THEN
7952        IFLAGE=0
7953        IFLAGM=1
7954      ENDIF
7955      MINN2=2
7956      IFLAGP=0
7957      JMIN=1
7958      JMAX=NUMARG
7959C
7960      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
7961     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
7962     1            JMIN,JMAX,
7963     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
7964     1            IVARN1,IVARN2,IVARTY,PVAR,
7965     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
7966     1            MINNVA,MAXNVA,
7967     1            IFLAGM,IFLAGP,
7968     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
7969      IF(IERROR.EQ.'YES')GOTO9000
7970C
7971      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FLTE')THEN
7972        WRITE(ICOUT,999)
7973        CALL DPWRST('XXX','BUG ')
7974        WRITE(ICOUT,181)
7975  181   FORMAT('***** AFTER CALL DPPARS--')
7976        CALL DPWRST('XXX','BUG ')
7977        WRITE(ICOUT,182)NQ,NUMVAR,IMULT
7978  182   FORMAT('NQ,NUMVAR,IMULT = ',2I8,2X,A4)
7979        CALL DPWRST('XXX','BUG ')
7980        IF(NUMVAR.GT.0)THEN
7981          DO185I=1,NUMVAR
7982            WRITE(ICOUT,187)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
7983     1                      ICOLR(I)
7984  187       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
7985     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
7986            CALL DPWRST('XXX','BUG ')
7987  185     CONTINUE
7988        ENDIF
7989      ENDIF
7990C
7991C               *******************************************************
7992C               **  STEP 3--                                         **
7993C               **  GENERATE THE F LOCATION     TEST FOR THE VARIOUS **
7994C               **  CASES                                            **
7995C               *******************************************************
7996C
7997      ISTEPN='3'
7998      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FLTE')
7999     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8000C
8001C               *****************************************
8002C               **  STEP 3A--                          **
8003C               **  CASE 1: TWO RESPONSE VARIABLES     **
8004C               **          WITH NO REPLICATION        **
8005C               *****************************************
8006C
8007      IF(IMULT.EQ.'OFF')THEN
8008        ISTEPN='3A'
8009        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FLTE')
8010     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8011C
8012        ICOL=1
8013        NUMVA2=2
8014        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
8015     1              INAME,IVARN1,IVARN2,IVARTY,
8016     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
8017     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
8018     1              MAXCP4,MAXCP5,MAXCP6,
8019     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
8020     1              Y,X,YTEMP,NLOCAL,NLOCA2,NLOCA3,ICASE,
8021     1              IBUGA3,ISUBRO,IFOUND,IERROR)
8022        IF(IERROR.EQ.'YES')GOTO9000
8023C
8024C
8025C               *******************************************
8026C               **  STEP 3B--                            **
8027C               **  PREPARE FOR ENTRANCE INTO DPFLT2--   **
8028C               *******************************************
8029C
8030        ISTEPN='3B'
8031        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FLTE')THEN
8032          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8033          WRITE(ICOUT,999)
8034          CALL DPWRST('XXX','BUG ')
8035          WRITE(ICOUT,331)
8036  331     FORMAT('***** FROM DPFLTE, AS WE ARE ABOUT TO CALL DPFLT2--')
8037          CALL DPWRST('XXX','BUG ')
8038          WRITE(ICOUT,332)NLOCAL
8039  332     FORMAT('NLOCAL = ',I8)
8040          CALL DPWRST('XXX','BUG ')
8041          DO335I=1,NLOCAL
8042            WRITE(ICOUT,336)I,Y(I),X(I)
8043  336       FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
8044            CALL DPWRST('XXX','BUG ')
8045  335     CONTINUE
8046        ENDIF
8047C
8048        CALL DPFLT2(Y,X,NLOCAL,IVARN1,IVARN2,
8049     1              YTEMP,YMEAN,YBARIV,DTAG,MAXNXT,
8050     1              STATVA,STATCD,PVAL,
8051     1              CUT0,CUT50,CUT75,CUT90,CUT95,
8052     1              CUT975,CUT99,CUT999,
8053     1              ICAPSW,ICAPTY,IFORSW,IMULT,
8054     1              ISUBRO,IBUGA3,IERROR)
8055C
8056C               ***************************************
8057C               **  STEP 8C--                        **
8058C               **  UPDATE INTERNAL DATAPLOT TABLES  **
8059C               ***************************************
8060C
8061          ISTEPN='8C'
8062          IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FLTE')
8063     1      CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8064C
8065          IFLAGU='ON'
8066          IFRST=.TRUE.
8067          ILAST=.TRUE.
8068          CALL DPFRT5(STATVA,STATCD,PVAL,
8069     1                CUT0,CUT50,CUT75,CUT90,CUT95,
8070     1                CUT975,CUT99,CUT999,
8071     1                IFLAGU,IFRST,ILAST,
8072     1                IBUGA2,IBUGA3,ISUBRO,IERROR)
8073C
8074C               *******************************************************
8075C               **  STEP 4A--                                        **
8076C               **  CASE 2: MULTIPLE RESPONSE VARIABLES.  NOTE THAT  **
8077C               **          FOR F LOCATION     TEST, THE MULTIPLE    **
8078C               **          LABS ARE CONVERTED INTO A "Y X" STACKED  **
8079C               **          PAIR WHERE "X" IS THE LAB-ID VARIABLE.   **
8080C               *******************************************************
8081C
8082      ELSEIF(IMULT.EQ.'ON')THEN
8083        ISTEPN='4A'
8084        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FLTE')
8085     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8086C
8087        ICOL=1
8088        NUMVA2=NUMVAR
8089        CALL DPPAR8(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
8090     1              INAME,IVARN1,IVARN2,IVARTY,
8091     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
8092     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
8093     1              MAXCP4,MAXCP5,MAXCP6,
8094     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
8095     1              YTEMP,Y,X,NLOCAL,ICASE,
8096     1              IBUGA3,ISUBRO,IFOUND,IERROR)
8097        NUMVAR=2
8098        IF(IERROR.EQ.'YES')GOTO9000
8099C
8100        IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FLTE')THEN
8101          ISTEPN='4B'
8102          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8103          WRITE(ICOUT,999)
8104          CALL DPWRST('XXX','BUG ')
8105          WRITE(ICOUT,442)
8106  442     FORMAT('***** FROM THE MIDDLE  OF DPFLTE--')
8107          CALL DPWRST('XXX','BUG ')
8108          WRITE(ICOUT,443)ICASAN,NUMVAR,NLOCAL
8109  443     FORMAT('ICASAN,NUMVAR,NLOCAL = ',A4,2I8)
8110          CALL DPWRST('XXX','BUG ')
8111          IF(NLOCAL.GE.1)THEN
8112            DO445I=1,NLOCAL
8113              WRITE(ICOUT,446)I,Y(I),X(I)
8114  446         FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
8115              CALL DPWRST('XXX','BUG ')
8116  445       CONTINUE
8117          ENDIF
8118        ENDIF
8119C
8120        CALL DPFLT2(Y,X,NLOCAL,IVARN1,IVARN2,
8121     1              YTEMP,YMEAN,YBARIV,DTAG,MAXNXT,
8122     1              STATVA,STATCD,PVAL,
8123     1              CUT0,CUT50,CUT75,CUT90,CUT95,
8124     1              CUT975,CUT99,CUT999,
8125     1              ICAPSW,ICAPTY,IFORSW,IMULT,
8126     1              ISUBRO,IBUGA3,IERROR)
8127C
8128C         ***************************************
8129C         **  STEP 8C--                        **
8130C         **  UPDATE INTERNAL DATAPLOT TABLES  **
8131C         ***************************************
8132C
8133          ISTEPN='8C'
8134          IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'KRUS')
8135     1      CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8136C
8137          IFLAGU='ON'
8138          IFRST=.TRUE.
8139          ILAST=.TRUE.
8140          CALL DPFRT5(STATVA,STATCD,PVAL,
8141     1                CUT0,CUT50,CUT75,CUT90,CUT95,
8142     1                CUT975,CUT99,CUT999,
8143     1                IFLAGU,IFRST,ILAST,
8144     1                IBUGA2,IBUGA3,ISUBRO,IERROR)
8145C
8146      ENDIF
8147C
8148C               *****************
8149C               **  STEP 90--  **
8150C               **  EXIT       **
8151C               *****************
8152C
8153 9000 CONTINUE
8154      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FLTE')THEN
8155        WRITE(ICOUT,999)
8156        CALL DPWRST('XXX','BUG ')
8157        WRITE(ICOUT,9011)
8158 9011   FORMAT('***** AT THE END       OF DPFLTE--')
8159        CALL DPWRST('XXX','BUG ')
8160        WRITE(ICOUT,9014)NLOCAL,STATVA,STATCD
8161 9014   FORMAT('NLOCAL,STATVA,STATCD = ',I8,2G15.7)
8162        CALL DPWRST('XXX','BUG ')
8163        WRITE(ICOUT,9016)IFOUND,IERROR
8164 9016   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
8165        CALL DPWRST('XXX','BUG ')
8166      ENDIF
8167C
8168      RETURN
8169      END
8170      SUBROUTINE DPFLT2(Y,TAG,N,IVARID,IVARI2,
8171     1                  YTEMP,YMEAN,YBARIV,DTAG,MAXNXT,
8172     1                  STATVA,STATCD,PVAL,
8173     1                  CUT0,CUT50,CUT75,CUT90,CUT95,
8174     1                  CUT975,CUT99,CUT999,
8175     1                  ICAPSW,ICAPTY,IFORSW,IMULT,
8176     1                  ISUBRO,IBUGA3,IERROR)
8177C
8178C     PURPOSE--THIS ROUTINE CARRIES OUT AN F TEST FOR SHIFT IN LOCATION
8179C     EXAMPLE--F LOCATION'S TEST Y TAG
8180C     REFERENCE--XX
8181C     WRITTEN BY--JAMES J. FILLIBEN
8182C                 STATISTICAL ENGINEERING DIVISION
8183C                 INFORMATION TECHNOLOGY LABORATORY
8184C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
8185C                 GAITHERSBURG, MD 20899-8980
8186C                 PHONE--301-975-2855
8187C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
8188C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
8189C     LANGUAGE--ANSI FORTRAN (1977)
8190C     VERSION NUMBER--97/9
8191C     ORIGINAL VERSION--SEPTEMBER 1997.
8192C     UPDATED         --MAY       2011. USE DPTAB1 AND DPDTA4 TO PRINT
8193C                                       OUTPUT TABLES.  THIS ADDS
8194C                                       HTML/LATEX/RTF SUPPORT AS WELL.
8195C
8196C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
8197C
8198      CHARACTER*4 ICAPSW
8199      CHARACTER*4 ICAPTY
8200      CHARACTER*4 IFORSW
8201      CHARACTER*4 IMULT
8202      CHARACTER*4 ISUBRO
8203      CHARACTER*4 IBUGA3
8204      CHARACTER*4 IERROR
8205      CHARACTER*4 IVARID(*)
8206      CHARACTER*4 IVARI2(*)
8207C
8208      CHARACTER*4 IWRITE
8209      CHARACTER*4 ISUBN1
8210      CHARACTER*4 ISUBN2
8211      CHARACTER*4 ISTEPN
8212C
8213      DOUBLE PRECISION DSUM1
8214C
8215C---------------------------------------------------------------------
8216C
8217      DIMENSION Y(*)
8218      DIMENSION TAG(*)
8219      DIMENSION DTAG(*)
8220      DIMENSION YTEMP(*)
8221      DIMENSION YMEAN(*)
8222      DIMENSION YBARIV(*)
8223C
8224      PARAMETER (NUMALP=8)
8225      REAL ALPHA(NUMALP)
8226C
8227      PARAMETER(NUMCLI=4)
8228      PARAMETER(MAXLIN=1)
8229      PARAMETER (MAXROW=15)
8230      CHARACTER*60 ITITLE
8231      CHARACTER*60 ITITLZ
8232      CHARACTER*1  ITITL9
8233      CHARACTER*60 ITEXT(MAXROW)
8234      CHARACTER*4  ALIGN(NUMCLI)
8235      CHARACTER*4  VALIGN(NUMCLI)
8236      REAL         AVALUE(MAXROW)
8237      INTEGER      NCTEXT(MAXROW)
8238      INTEGER      IDIGIT(MAXROW)
8239      INTEGER      NTOT(MAXROW)
8240      CHARACTER*60 ITITL2(MAXLIN,NUMCLI)
8241      CHARACTER*15 IVALUE(MAXROW,NUMCLI)
8242      CHARACTER*4  ITYPCO(NUMCLI)
8243      INTEGER      NCTIT2(MAXLIN,NUMCLI)
8244      INTEGER      NCVALU(MAXROW,NUMCLI)
8245      INTEGER      IWHTML(NUMCLI)
8246      INTEGER      IWRTF(NUMCLI)
8247      REAL         AMAT(MAXROW,NUMCLI)
8248      LOGICAL IFRST
8249      LOGICAL ILAST
8250C
8251C---------------------------------------------------------------------
8252C
8253      INCLUDE 'DPCOP2.INC'
8254C
8255      DATA ALPHA/
8256     1 0.0, 50.0, 75.0, 90.0, 95.0, 97.5, 99.0, 99.9/
8257C
8258C-----START POINT-----------------------------------------------------
8259C
8260      ISUBN1='DPFL'
8261      ISUBN2='T2  '
8262      IERROR='NO'
8263      IWRITE='OFF'
8264C
8265      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FLT2')THEN
8266        WRITE(ICOUT,999)
8267  999   FORMAT(1X)
8268        CALL DPWRST('XXX','WRIT')
8269        WRITE(ICOUT,51)
8270   51   FORMAT('**** AT THE BEGINNING OF DPFLT2--')
8271        CALL DPWRST('XXX','WRIT')
8272        WRITE(ICOUT,52)IBUGA3,ISUBRO,N,MAXNXT
8273   52   FORMAT('IBUGA3,ISUBRO,N,MAXNXT = ',2(A4,2X),2I8)
8274        CALL DPWRST('XXX','WRIT')
8275        DO56I=1,N
8276          WRITE(ICOUT,57)I,Y(I),TAG(I)
8277   57     FORMAT('I,Y(I),TAG(I) = ',I8,2G15.7)
8278          CALL DPWRST('XXX','WRIT')
8279   56   CONTINUE
8280      ENDIF
8281C
8282C               ********************************************
8283C               **  STEP 11--                             **
8284C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
8285C               ********************************************
8286C
8287      ISTEPN='11'
8288      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FLT2')
8289     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8290C
8291      IF(N.LE.1)THEN
8292        WRITE(ICOUT,999)
8293        CALL DPWRST('XXX','WRIT')
8294        WRITE(ICOUT,1111)
8295 1111   FORMAT('***** ERROR IN F LOCATION TEST--')
8296        CALL DPWRST('XXX','WRIT')
8297        WRITE(ICOUT,1113)
8298 1113   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ',
8299     1         'VARIABLE IS LESS THAN 2.')
8300        WRITE(ICOUT,1115)N
8301 1115   FORMAT('      THE SAMPLE SIZE = ',I8)
8302        CALL DPWRST('XXX','WRIT')
8303        IERROR='YES'
8304        GOTO9000
8305      ENDIF
8306C
8307      HOLD=Y(1)
8308      DO1135I=2,N
8309        IF(Y(I).NE.HOLD)GOTO1139
8310 1135 CONTINUE
8311      WRITE(ICOUT,999)
8312      CALL DPWRST('XXX','WRIT')
8313      WRITE(ICOUT,1111)
8314      CALL DPWRST('XXX','WRIT')
8315      WRITE(ICOUT,1133)HOLD
8316 1133 FORMAT('      THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7)
8317      CALL DPWRST('XXX','WRIT')
8318      GOTO9000
8319 1139 CONTINUE
8320C
8321      HOLD=TAG(1)
8322      DO1235I=2,N
8323        IF(TAG(I).NE.HOLD)GOTO1239
8324 1235 CONTINUE
8325      WRITE(ICOUT,999)
8326      CALL DPWRST('XXX','WRIT')
8327      WRITE(ICOUT,1111)
8328      CALL DPWRST('XXX','WRIT')
8329      WRITE(ICOUT,1231)HOLD
8330 1231 FORMAT('      THE GROUP-ID VARIABLE HAS ALL ELEMENTS = ',G15.7)
8331      CALL DPWRST('XXX','WRIT')
8332      GOTO9000
8333 1239 CONTINUE
8334C
8335C               ******************************
8336C               **  STEP 21--               **
8337C               **  CARRY OUT CALCULATIONS  **
8338C               **  FOR F LOCATION  TEST    **
8339C               ******************************
8340C
8341      ISTEPN='21'
8342      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FLT2')
8343     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8344C
8345      CALL MEAN(Y,N,IWRITE,YBAR,IBUGA3,IERROR)
8346      CALL SD(Y,N,IWRITE,YSD,IBUGA3,IERROR)
8347      CALL DISTIN(TAG,N,IWRITE,DTAG,NUMDIS,IBUGA3,IERROR)
8348C
8349      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FLT2')THEN
8350        WRITE(ICOUT,2111)YBAR
8351 2111   FORMAT('YBAR = ',G15.7)
8352        CALL DPWRST('XXX','BUG ')
8353        DO2115I=1,NUMDIS
8354          WRITE(ICOUT,2116)I,DTAG(I)
8355 2116     FORMAT('I,DTAG(I) =',I8,G15.7)
8356          CALL DPWRST('XXX','BUG ')
8357 2115   CONTINUE
8358      ENDIF
8359C
8360      DO2200IDIS=1,NUMDIS
8361         J=0
8362         DO2300I=1,N
8363            IF(TAG(I).EQ.DTAG(IDIS))THEN
8364               J=J+1
8365               YTEMP(J)=Y(I)
8366            ENDIF
8367 2300    CONTINUE
8368         CALL MEAN(YTEMP,J,IWRITE,YMEAN(IDIS),IBUGA3,IERROR)
8369         DO2400I=1,N
8370           IF(TAG(I).EQ.DTAG(IDIS))YBARIV(I)=YMEAN(IDIS)
8371 2400    CONTINUE
8372 2200 CONTINUE
8373C
8374      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FLT2')THEN
8375        DO2205I=1,N
8376          WRITE(ICOUT,2206)I,DTAG(I),YBARIV(I)
8377 2206     FORMAT('I,DTAG(I),YBARIV(I)=',I8,2G15.7)
8378          CALL DPWRST('XXX','BUG ')
8379 2205   CONTINUE
8380      ENDIF
8381C
8382      DSUM1=0.D0
8383      DO2600I=1,N
8384        DSUM1=DSUM1 + (YBARIV(I)-YBAR)**2
8385 2600 CONTINUE
8386      SSQ=SNGL(DSUM1)
8387      NUMDF=NUMDIS-1
8388      ANUMMS=SSQ/REAL(NUMDF)
8389C
8390      DSUM1=0.D0
8391      DO2610I=1,N
8392        DSUM1=DSUM1 + (Y(I)-YBARIV(I))**2
8393 2610 CONTINUE
8394      SSQ=SNGL(DSUM1)
8395      IDENDF=N-NUMDIS
8396      DENMS=SSQ/REAL(IDENDF)
8397C
8398      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FLT2')THEN
8399        WRITE(ICOUT,2612)ANUMMS,DENMS
8400 2612   FORMAT('ANUMMS,DENMS=',2G15.7)
8401        CALL DPWRST('XXX','BUG ')
8402      ENDIF
8403C
8404      STATVA=ANUMMS/DENMS
8405      CALL FCDF(STATVA,NUMDF,IDENDF,STATCD)
8406      PVAL=1.0 - STATCD
8407C
8408      KM1=NUMDIS-1
8409      NMK=N-NUMDIS
8410C
8411      CUT0=0.0
8412      CALL FPPF(.50,KM1,NMK,CUT50)
8413      CALL FPPF(.75,KM1,NMK,CUT75)
8414      CALL FPPF(.90,KM1,NMK,CUT90)
8415      CALL FPPF(.95,KM1,NMK,CUT95)
8416      CALL FPPF(.975,KM1,NMK,CUT975)
8417      CALL FPPF(.99,KM1,NMK,CUT99)
8418      CALL FPPF(.999,KM1,NMK,CUT999)
8419C
8420C               ******************************
8421C               **   STEP 42--              **
8422C               **   WRITE OUT EVERYTHING   **
8423C               **   FOR F LOCATION'S TEST  **
8424C               ******************************
8425C
8426      ISTEPN='42'
8427      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FLT2')
8428     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8429C
8430      IF(IPRINT.EQ.'OFF')GOTO9000
8431C
8432      NUMDIG=7
8433      IF(IFORSW.EQ.'1')NUMDIG=1
8434      IF(IFORSW.EQ.'2')NUMDIG=2
8435      IF(IFORSW.EQ.'3')NUMDIG=3
8436      IF(IFORSW.EQ.'4')NUMDIG=4
8437      IF(IFORSW.EQ.'5')NUMDIG=5
8438      IF(IFORSW.EQ.'6')NUMDIG=6
8439      IF(IFORSW.EQ.'7')NUMDIG=7
8440      IF(IFORSW.EQ.'8')NUMDIG=8
8441      IF(IFORSW.EQ.'9')NUMDIG=9
8442      IF(IFORSW.EQ.'0')NUMDIG=0
8443      IF(IFORSW.EQ.'E')NUMDIG=-2
8444      IF(IFORSW.EQ.'-2')NUMDIG=-2
8445      IF(IFORSW.EQ.'-3')NUMDIG=-3
8446      IF(IFORSW.EQ.'-4')NUMDIG=-4
8447      IF(IFORSW.EQ.'-5')NUMDIG=-5
8448      IF(IFORSW.EQ.'-6')NUMDIG=-6
8449      IF(IFORSW.EQ.'-7')NUMDIG=-7
8450      IF(IFORSW.EQ.'-8')NUMDIG=-8
8451      IF(IFORSW.EQ.'-9')NUMDIG=-9
8452C
8453      ITITLE='F-Test for Shift in Location'
8454      NCTITL=28
8455      ITITLZ='(Assumption: Normality)'
8456      NCTITZ=24
8457C
8458      ICNT=1
8459      ITEXT(ICNT)=' '
8460      NCTEXT(ICNT)=0
8461      AVALUE(ICNT)=0.0
8462      IDIGIT(ICNT)=-1
8463      IF(IMULT.EQ.'OFF')THEN
8464        ICNT=ICNT+1
8465        ITEXT(ICNT)='Response Variable: '
8466        WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1)(1:4)
8467        WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1)(1:4)
8468        NCTEXT(ICNT)=27
8469        AVALUE(ICNT)=0.0
8470        IDIGIT(ICNT)=-1
8471C
8472        ICNT=ICNT+1
8473        ITEXT(ICNT)='Group-ID Variable: '
8474        WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(2)(1:4)
8475        WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(2)(1:4)
8476        NCTEXT(ICNT)=27
8477        AVALUE(ICNT)=0.0
8478        IDIGIT(ICNT)=-1
8479      ENDIF
8480C
8481      ICNT=ICNT+1
8482      ITEXT(ICNT)=' '
8483      NCTEXT(ICNT)=1
8484      AVALUE(ICNT)=0.0
8485      IDIGIT(ICNT)=-1
8486C
8487      ICNT=ICNT+1
8488      ITEXT(ICNT)='H0: Groups are Homogeneous with'
8489      NCTEXT(ICNT)=31
8490      AVALUE(ICNT)=0.0
8491      IDIGIT(ICNT)=-1
8492      ICNT=ICNT+1
8493      ITEXT(ICNT)='    Respect to Location'
8494      NCTEXT(ICNT)=23
8495      AVALUE(ICNT)=0.0
8496      IDIGIT(ICNT)=-1
8497      ICNT=ICNT+1
8498      ITEXT(ICNT)='Ha: Groups are Not Homogeneous with'
8499      NCTEXT(ICNT)=35
8500      AVALUE(ICNT)=0.0
8501      IDIGIT(ICNT)=-1
8502      ICNT=ICNT+1
8503      ITEXT(ICNT)='    Respect to Location'
8504      NCTEXT(ICNT)=23
8505      AVALUE(ICNT)=0.0
8506      IDIGIT(ICNT)=-1
8507C
8508      ICNT=ICNT+1
8509      ITEXT(ICNT)=' '
8510      NCTEXT(ICNT)=1
8511      AVALUE(ICNT)=0.0
8512      IDIGIT(ICNT)=-1
8513      ICNT=ICNT+1
8514      ITEXT(ICNT)='Summary Statistics:'
8515      NCTEXT(ICNT)=19
8516      AVALUE(ICNT)=0.0
8517      IDIGIT(ICNT)=-1
8518      ICNT=ICNT+1
8519      ITEXT(ICNT)='Total Number of Observations:'
8520      NCTEXT(ICNT)=29
8521      AVALUE(ICNT)=REAL(N)
8522      IDIGIT(ICNT)=0
8523      ICNT=ICNT+1
8524      ITEXT(ICNT)='Number of Groups:'
8525      NCTEXT(ICNT)=17
8526      AVALUE(ICNT)=REAL(NUMDIS)
8527      IDIGIT(ICNT)=0
8528      ICNT=ICNT+1
8529      ITEXT(ICNT)=' '
8530      NCTEXT(ICNT)=1
8531      AVALUE(ICNT)=0.0
8532      IDIGIT(ICNT)=-1
8533C
8534      ICNT=ICNT+1
8535      ITEXT(ICNT)='F Location Test Statistic Value:'
8536      NCTEXT(ICNT)=32
8537      AVALUE(ICNT)=STATVA
8538      IDIGIT(ICNT)=NUMDIG
8539      ICNT=ICNT+1
8540      ITEXT(ICNT)='CDF of Test Statistic:'
8541      NCTEXT(ICNT)=22
8542      AVALUE(ICNT)=STATCD
8543      IDIGIT(ICNT)=NUMDIG
8544      ICNT=ICNT+1
8545      ITEXT(ICNT)='P-Value:'
8546      NCTEXT(ICNT)=8
8547      AVALUE(ICNT)=PVAL
8548      IDIGIT(ICNT)=NUMDIG
8549C
8550      NUMROW=ICNT
8551      DO4210I=1,NUMROW
8552        NTOT(I)=15
8553 4210 CONTINUE
8554C
8555      IFRST=.TRUE.
8556      ILAST=.TRUE.
8557C
8558      ISTEPN='42A'
8559      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FLT2')
8560     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8561C
8562      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
8563     1            AVALUE,IDIGIT,
8564     1            NTOT,NUMROW,
8565     1            ICAPSW,ICAPTY,ILAST,IFRST,
8566     1            ISUBRO,IBUGA3,IERROR)
8567C
8568      ITITLE=' '
8569      NCTITL=0
8570C
8571      ITITL9=' '
8572      NCTIT9=0
8573      ITITLE(1:55)=
8574     1'Percent Points of the F Reference Distribution'
8575      NCTITL=46
8576      NUMLIN=1
8577      NUMROW=8
8578      NUMCOL=3
8579      ITITL2(1,1)='Percent Point'
8580      ITITL2(1,2)=' '
8581      ITITL2(1,3)='Value'
8582      NCTIT2(1,1)=13
8583      NCTIT2(1,2)=1
8584      NCTIT2(1,3)=5
8585C
8586      NMAX=0
8587      DO4221I=1,NUMCOL
8588        VALIGN(I)='b'
8589        ALIGN(I)='r'
8590        NTOT(I)=15
8591        IF(I.EQ.2)NTOT(I)=5
8592        NMAX=NMAX+NTOT(I)
8593        IDIGIT(I)=NUMDIG
8594        ITYPCO(I)='NUME'
8595 4221 CONTINUE
8596      ITYPCO(2)='ALPH'
8597      IDIGIT(1)=1
8598      IDIGIT(3)=3
8599      DO4223I=1,NUMROW
8600        DO4225J=1,NUMCOL
8601          NCVALU(I,J)=0
8602          IVALUE(I,J)=' '
8603          NCVALU(I,J)=0
8604          AMAT(I,J)=0.0
8605          IF(J.EQ.1)THEN
8606            AMAT(I,J)=ALPHA(I)
8607          ELSEIF(J.EQ.2)THEN
8608            IVALUE(I,J)='='
8609            NCVALU(I,J)=1
8610          ELSEIF(J.EQ.3)THEN
8611            IF(I.EQ.1)THEN
8612              AMAT(I,J)=RND(CUT0,IDIGIT(J))
8613            ELSEIF(I.EQ.2)THEN
8614              AMAT(I,J)=RND(CUT50,IDIGIT(J))
8615            ELSEIF(I.EQ.3)THEN
8616              AMAT(I,J)=RND(CUT75,IDIGIT(J))
8617            ELSEIF(I.EQ.4)THEN
8618              AMAT(I,J)=RND(CUT90,IDIGIT(J))
8619            ELSEIF(I.EQ.5)THEN
8620              AMAT(I,J)=RND(CUT95,IDIGIT(J))
8621            ELSEIF(I.EQ.6)THEN
8622              AMAT(I,J)=RND(CUT975,IDIGIT(J))
8623            ELSEIF(I.EQ.7)THEN
8624              AMAT(I,J)=RND(CUT99,IDIGIT(J))
8625            ELSEIF(I.EQ.8)THEN
8626              AMAT(I,J)=RND(CUT999,IDIGIT(J))
8627            ENDIF
8628          ENDIF
8629 4225   CONTINUE
8630 4223 CONTINUE
8631C
8632      IWHTML(1)=150
8633      IWHTML(2)=50
8634      IWHTML(3)=150
8635      IWRTF(1)=2000
8636      IWRTF(2)=IWRTF(1)+500
8637      IWRTF(3)=IWRTF(2)+2000
8638      IFRST=.TRUE.
8639      ILAST=.FALSE.
8640C
8641      ISTEPN='42C'
8642      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FLT2')
8643     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8644C
8645      CALL DPDTA4(ITITL9,NCTIT9,
8646     1            ITITLE,NCTITL,ITITL2,NCTIT2,
8647     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
8648     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW,
8649     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
8650     1            ICAPSW,ICAPTY,IFRST,ILAST,
8651     1            ISUBRO,IBUGA3,IERROR)
8652C
8653      ISTEPN='42D'
8654      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FLT2')
8655     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8656C
8657      CDF1=CUT90
8658      CDF2=CUT95
8659      CDF3=CUT975
8660      CDF4=CUT99
8661C
8662      ITITL9=' '
8663      NCTIT9=0
8664      ITITLE='Conclusions (Upper 1-Tailed Test)'
8665      NCTITL=33
8666      NUMLIN=1
8667      NUMROW=4
8668      NUMCOL=4
8669      ITITL2(1,1)='Alpha'
8670      ITITL2(1,2)='CDF'
8671      ITITL2(1,3)='Critical Value'
8672      ITITL2(1,4)='Conclusion'
8673      NCTIT2(1,1)=5
8674      NCTIT2(1,2)=3
8675      NCTIT2(1,3)=14
8676      NCTIT2(1,4)=10
8677C
8678      NMAX=0
8679      DO4321I=1,NUMCOL
8680        VALIGN(I)='b'
8681        ALIGN(I)='r'
8682        NTOT(I)=15
8683        IF(I.EQ.1 .OR. I.EQ.2)NTOT(I)=7
8684        IF(I.EQ.3)NTOT(I)=17
8685        NMAX=NMAX+NTOT(I)
8686        IDIGIT(I)=3
8687        ITYPCO(I)='ALPH'
8688 4321 CONTINUE
8689      ITYPCO(3)='NUME'
8690      IDIGIT(1)=0
8691      IDIGIT(2)=0
8692      DO4323I=1,NUMROW
8693        DO4325J=1,NUMCOL
8694          NCVALU(I,J)=0
8695          IVALUE(I,J)=' '
8696          NCVALU(I,J)=0
8697          AMAT(I,J)=0.0
8698 4325   CONTINUE
8699 4323 CONTINUE
8700      IVALUE(1,1)='10%'
8701      IVALUE(2,1)='5%'
8702      IVALUE(3,1)='2.5%'
8703      IVALUE(4,1)='1%'
8704      IVALUE(1,2)='90%'
8705      IVALUE(2,2)='95%'
8706      IVALUE(3,2)='97.5%'
8707      IVALUE(4,2)='99%'
8708      NCVALU(1,1)=3
8709      NCVALU(2,1)=2
8710      NCVALU(3,1)=4
8711      NCVALU(4,1)=2
8712      NCVALU(1,2)=3
8713      NCVALU(2,2)=3
8714      NCVALU(3,2)=5
8715      NCVALU(4,2)=3
8716      IVALUE(1,4)='Accept H0'
8717      IVALUE(2,4)='Accept H0'
8718      IVALUE(3,4)='Accept H0'
8719      IVALUE(4,4)='Accept H0'
8720      NCVALU(1,4)=9
8721      NCVALU(2,4)=9
8722      NCVALU(3,4)=9
8723      NCVALU(4,4)=9
8724      IF(STATVA.GT.CUT90)IVALUE(1,4)='Reject H0'
8725      IF(STATVA.GT.CUT95)IVALUE(2,4)='Reject H0'
8726      IF(STATVA.GT.CUT975)IVALUE(3,4)='Reject H0'
8727      IF(STATVA.GT.CUT99)IVALUE(4,4)='Reject H0'
8728      AMAT(1,3)=RND(CUT90,IDIGIT(3))
8729      AMAT(2,3)=RND(CUT95,IDIGIT(3))
8730      AMAT(3,3)=RND(CUT975,IDIGIT(3))
8731      AMAT(4,3)=RND(CUT99,IDIGIT(3))
8732C
8733      IWHTML(1)=150
8734      IWHTML(2)=150
8735      IWHTML(3)=150
8736      IWHTML(4)=150
8737      IWRTF(1)=1500
8738      IWRTF(2)=IWRTF(1)+1500
8739      IWRTF(3)=IWRTF(2)+2000
8740      IWRTF(4)=IWRTF(3)+2000
8741      IFRST=.FALSE.
8742      ILAST=.TRUE.
8743C
8744      ISTEPN='42E'
8745      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FLT2')
8746     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8747C
8748      CALL DPDTA4(ITITL9,NCTIT9,
8749     1            ITITLE,NCTITL,ITITL2,NCTIT2,
8750     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
8751     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW,
8752     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
8753     1            ICAPSW,ICAPTY,IFRST,ILAST,
8754     1            ISUBRO,IBUGA3,IERROR)
8755C
8756C
8757C               *****************
8758C               **  STEP 90--  **
8759C               **  EXIT       **
8760C               *****************
8761C
8762 9000 CONTINUE
8763      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FLT2')THEN
8764        WRITE(ICOUT,999)
8765        CALL DPWRST('XXX','WRIT')
8766        WRITE(ICOUT,9011)
8767 9011   FORMAT('***** AT THE END       OF DPFLT2--')
8768        CALL DPWRST('XXX','WRIT')
8769        WRITE(ICOUT,9025)STATVA,STATCD,PVAL
8770 9025   FORMAT('STATVA,STATCD,PVAL = ',3G15.7)
8771        CALL DPWRST('XXX','WRIT')
8772      ENDIF
8773C
8774      RETURN
8775      END
8776      SUBROUTINE DPFLUC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
8777     1                  IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
8778C
8779C     PURPOSE--GENERATE A FLUCTUATION PLOT--THIS IS A VARIANT OF
8780C              THE MOSAIC PLOT IN WHICH THE CELL AREAS ARE ALL
8781C              EQUAL SIZE AND WE THEN "COLORIZE" A PORTION OF THAT
8782C              CELL AREA BASED ON THE PROPORTION FOR THAT CELL.
8783C              WE CURRENTLY SUPPORT THIS PLOT FOR TWO-WAY THROUGH
8784C              SIX-WAY TABLES.  THE DATA CAN BE EITHER RAW DATA
8785C
8786C                  X1  = CATEGORY LEVEL FOR VARIABLE 1
8787C                  X2  = CATEGORY LEVEL FOR VARIABLE 2
8788C                  X3  = CATEGORY LEVEL FOR VARIABLE 3
8789C                  X4  = CATEGORY LEVEL FOR VARIABLE 4
8790C                  X5  = CATEGORY LEVEL FOR VARIABLE 4
8791C                  X6  = CATEGORY LEVEL FOR VARIABLE 4
8792C
8793C              OR A MATRIX.  A MATRIX REPRESENTS DATA THAT
8794C              IS ALREADY CROSS-TABULATED FOR A TWO-WAY TABLE.
8795C
8796C              NOTE THAT WE EXTENED THE FLUCUATION PLOT TO ALLOW
8797C              ANY OF DATAPLOT'S SUPPORTED STATISTICS TO BE
8798C              PLOTTED (THE DEFAULT IS COUNTS).
8799C
8800C     EXAMPLES--FLUCTUATION PLOT X1
8801C             --FLUCTUATION PLOT X1 X2
8802C             --FLUCTUATION PLOT X1 X2 X3
8803C             --FLUCTUATION PLOT X1 X2 X3 X4
8804C             --FLUCTUATION PLOT X1 X2 X3 X4 X5
8805C             --FLUCTUATION PLOT X1 X2 X3 X4 X5 X6
8806C             --FLUCTUATION PLOT TABLE
8807C             --FLUCTUATION MEAN PLOT Y X1 X2
8808C     REFERENCE--UNWIN, THEUS, AND HOFMANN (2006), "GRAPHICS OF
8809C                LARGE DATA SETS: VISUALIZING A MILLION",
8810C                SPRINGER, P. 46, CHAPTER 5.
8811C     WRITTEN BY--ALAN HECKERT
8812C                 STATISTICAL ENGINEERING DIVISION
8813C                 INFORMATION TECHNOLOGY LABORATORY
8814C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
8815C                 GAITHERSBURG, MD 20899-8980
8816C                 PHONE--301-975-2899
8817C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
8818C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
8819C     LANGUAGE--ANSI FORTRAN (1977)
8820C     VERSION NUMBER--2008/5
8821C     ORIGINAL VERSION--MAY       2008.
8822C     UPDATED         --JANUARY   2009. SUPPORT CASE FOR TABLE INPUT
8823C                                       (THIS IS RESTRICTED TO THE
8824C                                       CASE WITH TWO CLASSICATION
8825C                                       VARIABLES--INPUT TABLE CONTAINS
8826C                                       PREVIOUSLY CROSS-TABULATED
8827C                                       VALUES)
8828C     UPDATED         --FEBRUARY  2009. GRUBB
8829C     UPDATED         --FEBRUARY  2009. GRUBB CDF
8830C     UPDATED         --FEBRUARY  2009. ONE SAMPLE T TEST
8831C                                       ONE SAMPLE T TEST CDF
8832C     UPDATED         --FEBRUARY  2009. CHI-SQUARE SD TEST
8833C                                       CHI-SQUARE SD TEST CDF
8834C     UPDATED         --FEBRUARY  2009. FREQUENCY TEST
8835C                                       FREQUENCY TEST CDF
8836C     UPDATED         --FEBRUARY  2009. FREQUENCY WITHIN A BLOCK TEST
8837C                                       FREQUENCY WITHIN A BLOCK TEST CDF
8838C     UPDATED         --MARCH     2009. PARSE WITH "EXTSTA"
8839C     UPDATED         --SEPTEMBER 2009. ADD "UNCERTAINTY INTERVALS"
8840C                                       FOR BINOMIAL PROPORTIONS AND
8841C                                       MEAN/MEDIAN CONFIDENCE LIMITS
8842C     UPDATED         --MARCH     2010. DIFFERENT FORMAT FOR
8843C                                       UNCERTAINTY INTERVALS
8844C     UPDATED         --APRIL     2010. ADD "CONTOUR" OPTION
8845C     UPDATED         --JUNE      2010. ADD "SORT" OPTION FOR 2 GROUP-ID
8846C                                       VARIABLES CASE
8847C     UPDATED         --JUNE      2010. CMPSTA SUPPORTS 3 RESPONSE
8848C                                       VARIABLES
8849C     UPDATED         --SEPTEMBER 2016. MODIFY HOW MATRIX ARGUMENTS ARE
8850C                                       HANDLED
8851C     UPDATED         --NOVEMBER  2017. DIFFERENCE OF MEAN AND
8852C                                       DIFFERENCE OF BINOMIAL
8853C                                       PROPORTIONS SUPPORT UNCERTAINTY
8854C                                       INTERVALS
8855C     UPDATED         --JULY      2019. TWEAK SCRATCH STORAGE
8856C
8857C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
8858C
8859      CHARACTER*4 ICASPL
8860      CHARACTER*4 IAND1
8861      CHARACTER*4 IAND2
8862      CHARACTER*4 IBUGG2
8863      CHARACTER*4 IBUGG3
8864      CHARACTER*4 IBUGQ
8865      CHARACTER*4 ISUBRO
8866      CHARACTER*4 IFOUND
8867      CHARACTER*4 IERROR
8868C
8869      CHARACTER*4 ICASCT
8870      CHARACTER*4 IHP
8871      CHARACTER*4 IHP2
8872      CHARACTER*4 IXVAR
8873      CHARACTER*4 IX2VAR
8874      CHARACTER*4 IYVAR
8875C
8876      CHARACTER*4 IHWUSE
8877      CHARACTER*4 MESSAG
8878      CHARACTER*4 ICASE
8879      CHARACTER*4 IH
8880      CHARACTER*4 IH2
8881      CHARACTER*4 ISUBN0
8882      CHARACTER*4  ISTADF
8883      CHARACTER*60 ICTNAM
8884      CHARACTER*4 ISUBN1
8885      CHARACTER*4 ISUBN2
8886      CHARACTER*4 ISTEPN
8887C
8888      PARAMETER (MAXSPN=20)
8889      CHARACTER*4 IVARN1(MAXSPN)
8890      CHARACTER*4 IVARN2(MAXSPN)
8891      CHARACTER*4 IVARTY(MAXSPN)
8892      REAL PVAR(MAXSPN)
8893      INTEGER ILIS(MAXSPN)
8894      INTEGER NRIGHT(MAXSPN)
8895      INTEGER ICOLR(MAXSPN)
8896      CHARACTER*40 INAME
8897C
8898C---------------------------------------------------------------------
8899C
8900      INCLUDE 'DPCOPA.INC'
8901      INCLUDE 'DPCOZZ.INC'
8902      INCLUDE 'DPCOZI.INC'
8903      INCLUDE 'DPCOZD.INC'
8904C
8905      DIMENSION Y1(MAXOBV)
8906      DIMENSION Y2(MAXOBV)
8907      DIMENSION Y3(MAXOBV)
8908      DIMENSION Y4(MAXOBV)
8909      DIMENSION TMP11(MAXOBV)
8910      DIMENSION TMP12(MAXOBV)
8911      DIMENSION TMP13(MAXOBV)
8912      DIMENSION TMP14(MAXOBV)
8913C
8914      DIMENSION YLEVEL(MAXOBV)
8915C
8916      DIMENSION XH1DIS(MAXOBV)
8917      DIMENSION XH2DIS(MAXOBV)
8918      DIMENSION XH3DIS(MAXOBV)
8919      DIMENSION XH4DIS(MAXOBV)
8920      DIMENSION XH5DIS(MAXOBV)
8921      DIMENSION XH6DIS(MAXOBV)
8922C
8923      DIMENSION X1(MAXOBV)
8924      DIMENSION X2(MAXOBV)
8925      DIMENSION X3(MAXOBV)
8926      DIMENSION X4(MAXOBV)
8927      DIMENSION X5(MAXOBV)
8928      DIMENSION X6(MAXOBV)
8929C
8930      DIMENSION TEMP1(MAXOBV)
8931      DIMENSION TEMP2(MAXOBV)
8932      DIMENSION TEMP3(MAXOBV)
8933      DIMENSION TEMP4(MAXOBV)
8934      DIMENSION TEMP5(MAXOBV)
8935      DIMENSION TEMP6(MAXOBV)
8936      DIMENSION TEMP7(MAXOBV)
8937      DIMENSION TEMP8(MAXOBV)
8938      DIMENSION TEMP9(MAXOBV)
8939      DIMENSION TMP10(MAXOBV)
8940c
8941      DIMENSION XNTRIA(MAXOBV)
8942      DIMENSION XACLOW(MAXOBV)
8943      DIMENSION XACUPP(MAXOBV)
8944C
8945      PARAMETER(MAXLEV=1000)
8946      DIMENSION XMAT(MAXLEV,MAXLEV)
8947C
8948      DIMENSION ITEMP1(MAXOBV)
8949      DIMENSION ITEMP2(MAXOBV)
8950      DIMENSION ITEMP3(MAXOBV)
8951      DIMENSION ITEMP4(MAXOBV)
8952      DIMENSION ITEMP5(MAXOBV)
8953      DIMENSION ITEMP6(MAXOBV)
8954      DOUBLE PRECISION DTEMP1(MAXOBV)
8955      DOUBLE PRECISION DTEMP2(MAXOBV)
8956      DOUBLE PRECISION DTEMP3(MAXOBV)
8957C
8958      EQUIVALENCE (GARBAG(IGARB1),Y1(1))
8959      EQUIVALENCE (GARBAG(IGARB2),Y2(1))
8960      EQUIVALENCE (GARBAG(IGARB3),Y3(1))
8961      EQUIVALENCE (GARBAG(IGARB4),TMP11(1))
8962      EQUIVALENCE (GARBAG(IGARB5),TMP12(1))
8963      EQUIVALENCE (GARBAG(IGARB6),TMP13(1))
8964      EQUIVALENCE (GARBAG(IGARB7),X1(1))
8965      EQUIVALENCE (GARBAG(IGARB8),X2(1))
8966      EQUIVALENCE (GARBAG(IGARB9),X3(1))
8967      EQUIVALENCE (GARBAG(IGAR10),X4(1))
8968      EQUIVALENCE (GARBAG(JGAR11),X5(1))
8969      EQUIVALENCE (GARBAG(JGAR12),X6(1))
8970      EQUIVALENCE (GARBAG(JGAR13),XH1DIS(1))
8971      EQUIVALENCE (GARBAG(JGAR14),XH2DIS(1))
8972      EQUIVALENCE (GARBAG(JGAR15),XH3DIS(1))
8973      EQUIVALENCE (GARBAG(JGAR16),XH4DIS(1))
8974      EQUIVALENCE (GARBAG(JGAR17),XH5DIS(1))
8975      EQUIVALENCE (GARBAG(JGAR18),XH6DIS(1))
8976      EQUIVALENCE (GARBAG(JGAR19),Y4(1))
8977      EQUIVALENCE (GARBAG(JGAR20),TMP14(1))
8978      EQUIVALENCE (GARBAG(IGAR11),TEMP1(1))
8979      EQUIVALENCE (GARBAG(IGAR12),TEMP2(1))
8980      EQUIVALENCE (GARBAG(IGAR13),TEMP3(1))
8981      EQUIVALENCE (GARBAG(IGAR14),TEMP4(1))
8982      EQUIVALENCE (GARBAG(IGAR15),TEMP5(1))
8983      EQUIVALENCE (GARBAG(IGAR16),TEMP6(1))
8984      EQUIVALENCE (GARBAG(IGAR17),TEMP7(1))
8985      EQUIVALENCE (GARBAG(IGAR18),TEMP8(1))
8986      EQUIVALENCE (GARBAG(IGAR19),TEMP9(1))
8987      EQUIVALENCE (GARBAG(IGAR20),TMP10(1))
8988      EQUIVALENCE (GARBAG(IGAR21),XNTRIA(1))
8989      EQUIVALENCE (GARBAG(IGAR22),XACLOW(1))
8990      EQUIVALENCE (GARBAG(IGAR23),XACUPP(1))
8991      EQUIVALENCE (GARBAG(IGAR24),YLEVEL(1))
8992      EQUIVALENCE (GARBAG(IGAR25),XMAT(1,1))
8993C
8994      EQUIVALENCE (IGARBG(IIGAR1),ITEMP1(1))
8995      EQUIVALENCE (IGARBG(IIGAR2),ITEMP2(1))
8996      EQUIVALENCE (IGARBG(IIGAR3),ITEMP3(1))
8997      EQUIVALENCE (IGARBG(IIGAR4),ITEMP4(1))
8998      EQUIVALENCE (IGARBG(IIGAR5),ITEMP5(1))
8999      EQUIVALENCE (IGARBG(IIGAR6),ITEMP6(1))
9000C
9001      EQUIVALENCE (DGARBG(IDGAR1),DTEMP1(1))
9002      EQUIVALENCE (DGARBG(IDGAR2),DTEMP2(1))
9003      EQUIVALENCE (DGARBG(IDGAR3),DTEMP3(1))
9004C
9005C
9006C-----COMMON----------------------------------------------------------
9007C
9008      INCLUDE 'DPCOSU.INC'
9009      INCLUDE 'DPCOHK.INC'
9010      INCLUDE 'DPCODA.INC'
9011      INCLUDE 'DPCOST.INC'
9012      INCLUDE 'DPCOHO.INC'
9013      INCLUDE 'DPCOP2.INC'
9014C
9015C-----START POINT-----------------------------------------------------
9016C
9017      IERROR='NO'
9018      IFOUND='NO'
9019      ISUBN1='DPFL'
9020      ISUBN2='UC  '
9021      ICASPL='FLUC'
9022      ICASCT=' '
9023      IYVAR='ON'
9024      IXVAR='OFF'
9025      IX2VAR='OFF'
9026C
9027      MAXCP1=MAXCOL+1
9028      MAXCP2=MAXCOL+2
9029      MAXCP3=MAXCOL+3
9030      MAXCP4=MAXCOL+4
9031      MAXCP5=MAXCOL+5
9032      MAXCP6=MAXCOL+6
9033C
9034C               ****************************************
9035C               **  TREAT THE FLUCTUATION PLOT CASE   **
9036C               ****************************************
9037C
9038      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'FLUC')THEN
9039        WRITE(ICOUT,999)
9040  999   FORMAT(1X)
9041        CALL DPWRST('XXX','BUG ')
9042        WRITE(ICOUT,51)
9043   51   FORMAT('***** AT THE BEGINNING OF DPFLUC--')
9044        CALL DPWRST('XXX','BUG ')
9045        WRITE(ICOUT,52)IBUGG2,IBUGG3,IBUGQ,ISUBRO
9046   52   FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',A4,2X,A4,2X,A4,2X,A4)
9047        CALL DPWRST('XXX','BUG ')
9048        WRITE(ICOUT,53)ICASPL,IAND1,IAND2
9049   53   FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4)
9050        CALL DPWRST('XXX','BUG ')
9051        WRITE(ICOUT,54)MAXN,N2,NS
9052   54   FORMAT('MAXN,N2,NS = ',3I8)
9053        CALL DPWRST('XXX','BUG ')
9054      ENDIF
9055C
9056C               ***************************
9057C               **  STEP 1--             **
9058C               **  EXTRACT THE COMMAND  **
9059C               ***************************
9060C
9061      ISTEPN='11'
9062      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'FLUC')
9063     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9064C
9065C               *******************************************************
9066C               **  STEP 1.5--                                       **
9067C               **  SEARCH FOR FLUCUATION <STAT> PLOT                **
9068C               *******************************************************
9069C
9070C
9071      IF(NUMARG.LE.1)GOTO9000
9072      IF(ICOM.NE.'FLUC')GOTO9000
9073C
9074CCCCC MARCH 2009: USE "EXTSTA" TO PARSE.  NOTE THAT IF NO
9075CCCCC             STATISTIC IS GIVEN, WE ASSUME THE "COUNTS"
9076CCCCC             CASE.
9077C
9078      JMIN=1
9079      JMAX=MIN(NUMARG,JMIN+6)
9080      DO200I=JMIN,JMAX
9081        IF(IHARG(I).EQ.'CONT' .AND. IHARG(I+1).EQ.'PLOT')THEN
9082          ICASPL='FLCP'
9083          JMAX=I-1
9084          ILASTC=I+1
9085          GOTO209
9086        ENDIF
9087        IF(IHARG(I).EQ.'PLOT')THEN
9088          JMAX=I-1
9089          ILASTC=I
9090          GOTO209
9091        ENDIF
9092  200 CONTINUE
9093      IFOUND='NO'
9094      GOTO9000
9095  209 CONTINUE
9096C
9097      IFLAGT=0
9098      IF(JMAX.LT.JMIN)THEN
9099C
9100C       THIS IS THE CASE WHERE NO EXPLICIT STATISTIC IS GIVEN.  THIS
9101C       IS PRIMARILY USED FOR THE CASE WHERE THE RESPONSE IS A
9102C       PRE-COMPUTED STATISTIC.  IN PARTICULAR, IF A MATRIX ARGUMENT
9103C       IS USED, THIS WILL OFTEN BE A PRE-COMPUTED CROSS-TABULATION,
9104C       A CORRELATION MATRIX, AND SO ON.  IN ANY EVENT, WE WILL TREAT
9105C       THIS CASE AS A "MEAN".  THIS HAS THE EFFECT OF TREATING A
9106C       PRE-COMPUTED STATISTIC AS THE VALUE.
9107C
9108        IFOUND='NO'
9109      ELSE
9110        CALL EXTSTA(ICOM,ICOM2,IHARG,IHARG2,IARGT,ARG,NUMARG,JMIN,JMAX,
9111     1              ICASCT,ICTNAM,ISTANR,ISTADF,IFOUND,ILOCV,
9112     1              ISUBRO,IBUGG3,IERROR)
9113      ENDIF
9114C
9115      IF(IFOUND.EQ.'YES')THEN
9116        IYVAR='ON'
9117        IXVAR='OFF'
9118        IX2VAR='OFF'
9119        IF(ISTANR.GE.2)IXVAR='ON'
9120        IF(ISTANR.GE.3)IX2VAR='ON'
9121        IF(ICTNAM.EQ.'NUMB')IYVAR='OFF'
9122      ELSE
9123        ISTANR=1
9124        ICASCT='MEAN'
9125        ICTNAM='MEAN'
9126        IYVAR='ON'
9127        IXVAR='OFF'
9128        IX2VAR='OFF'
9129        ILOCV=2
9130        IFOUND='YES'
9131      ENDIF
9132C
9133      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
9134C
9135C               *********************************
9136C               **  STEP 2--                   **
9137C               **  EXTRACT THE VARIABLE LIST  **
9138C               *********************************
9139C
9140      ISTEPN='2'
9141      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'FLUC')
9142     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9143C
9144      INAME='FLUCTUATION PLOT'
9145      MINNA=1
9146      MAXNA=100
9147      MAXVAR=100
9148      MINN2=2
9149      IFLAGE=1
9150      IF(ICASPL.EQ.'FLCP')IFLAGE=99
9151      IFLAGM=1
9152      IFLAGP=0
9153      JMIN=1
9154      JMAX=NUMARG
9155      MINNVA=-99
9156      MAXNVA=-99
9157C
9158      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
9159     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
9160     1            JMIN,JMAX,
9161     1            MINN2,MINNA,MAXNA,MAXVAR,IFLAGE,INAME,
9162     1            IVARN1,IVARN2,IVARTY,PVAR,
9163     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
9164     1            MINNVA,MAXNVA,
9165     1            IFLAGM,IFLAGP,
9166     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
9167      IF(IERROR.EQ.'YES')GOTO9000
9168C
9169      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'FLUC')THEN
9170        WRITE(ICOUT,999)
9171        CALL DPWRST('XXX','BUG ')
9172        WRITE(ICOUT,281)
9173  281   FORMAT('***** AFTER CALL DPPARS--')
9174        CALL DPWRST('XXX','BUG ')
9175        WRITE(ICOUT,282)NQ,NUMVAR
9176  282   FORMAT('NQ,NUMVAR = ',2I8)
9177        CALL DPWRST('XXX','BUG ')
9178        IF(NUMVAR.GT.0)THEN
9179          DO285I=1,NUMVAR
9180            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
9181     1                      ICOLR(I)
9182  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
9183     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
9184            CALL DPWRST('XXX','BUG ')
9185  285     CONTINUE
9186        ENDIF
9187      ENDIF
9188C
9189C     IF MATRIX ARGUMENTS GIVEN, THEN ALL RESPONSES MUST BE MATRICES
9190C     AND ALL MATRICES MUST HAVE SAME DIMENSION.
9191C
9192      IFLAGM=0
9193      DO260I=1,NUMVAR
9194        IF(IVARTY(I).EQ.'MATR')IFLAGM=1
9195  260 CONTINUE
9196C
9197      IF(IFLAGM.EQ.1)THEN
9198C
9199        NRESP=ISTANR
9200        NLVARI=0
9201        IF(ICASPL.EQ.'FLCP')NLVARI=1
9202        NCRTV=2
9203C
9204        DO291I=1,NRESP
9205          IF(IVARTY(I).NE.'MATR')THEN
9206            WRITE(ICOUT,999)
9207            CALL DPWRST('XXX','BUG ')
9208            WRITE(ICOUT,311)
9209            CALL DPWRST('XXX','BUG ')
9210            WRITE(ICOUT,292)
9211  292       FORMAT('      IF ONE RESPONSE VARIABLE IS A MATRIX, ',
9212     1             'THEN ALL MUST BE MATRICES.')
9213            CALL DPWRST('XXX','BUG ')
9214            WRITE(ICOUT,293)I
9215  293       FORMAT('      RESPONSE VARIABLE ',I5,' IS NOT A MATRIX.')
9216            CALL DPWRST('XXX','BUG ')
9217            IERROR='YES'
9218            GOTO9000
9219          ELSE
9220             ILISR=ILIS(I)
9221             NRTEMP=IN(ILISR)
9222             ICOL1=IVALUE(ILISR)
9223             ICOL2=IVALU2(ILISR)
9224             NCTEMP=(ICOL2 - ICOL1) + 1
9225             IF(I.EQ.1)THEN
9226               NROW=NRTEMP
9227               NCOL=NCTEMP
9228             ELSE
9229               IF(NRTEMP.NE.NROW .OR. NCTEMP.NE.NCOL)THEN
9230                 WRITE(ICOUT,999)
9231                 CALL DPWRST('XXX','BUG ')
9232                 WRITE(ICOUT,311)
9233                 CALL DPWRST('XXX','BUG ')
9234                 WRITE(ICOUT,296)
9235  296            FORMAT('      FOR MATRIX RESPONSE VARIABLES, THE ',
9236     1                  'ROW AND COLUMN DIMENSIONS MUST BE EQUAL.')
9237                 CALL DPWRST('XXX','BUG ')
9238                 WRITE(ICOUT,297)NROW,NCOL
9239  297            FORMAT('      THE FIRST MATRIX HAS ',I5,' ROWS AND ',
9240     1                  I5,' COLUMNS.')
9241                 CALL DPWRST('XXX','BUG ')
9242                 WRITE(ICOUT,298)I,NRTEMP,NCTEMP
9243  298            FORMAT('      MATRIX ',I2,' HAS ',I5,' ROWS AND ',
9244     1                  I5,' COLUMNS.')
9245                 CALL DPWRST('XXX','BUG ')
9246                 IERROR='YES'
9247                 GOTO9000
9248               ENDIF
9249             ENDIF
9250          ENDIF
9251  291   CONTINUE
9252C
9253        NTEMP=NRESP + NLVARI
9254        IF(NTEMP.NE.NUMVAR)THEN
9255          WRITE(ICOUT,999)
9256          CALL DPWRST('XXX','BUG ')
9257          WRITE(ICOUT,311)
9258          CALL DPWRST('XXX','BUG ')
9259          WRITE(ICOUT,272)
9260  272     FORMAT('      WHEN MATRIX ARGUMENTS ARE GIVEN, THE ',
9261     1           'NUMBER OF MATRICES')
9262          CALL DPWRST('XXX','BUG ')
9263          WRITE(ICOUT,274)
9264  274     FORMAT('      MUST BE THE SAME AS THE NUMBER OF RESPONSE ',
9265     1           'VARIABLES FOR THE SELECTED STATISTIC.')
9266          CALL DPWRST('XXX','BUG ')
9267          WRITE(ICOUT,276)NUMVAR-NLVARI
9268  276     FORMAT('      THE NUMBER OF MATRICES ENTERED = ',I5)
9269          CALL DPWRST('XXX','BUG ')
9270          WRITE(ICOUT,278)ISTANR
9271  278     FORMAT('      THE NUMBER OF MATRICES EXPECTED = ',I5)
9272          CALL DPWRST('XXX','BUG ')
9273          IERROR='YES'
9274          GOTO9000
9275        ENDIF
9276C
9277        GOTO400
9278C
9279      ENDIF
9280C
9281C               ******************************************************
9282C               **  STEP 3--                                        **
9283C               **  CHECK FOR ALLOWABLE NUMBER OF CROSS TABULATION  **
9284C               **  VARIABLES.                                      **
9285C               ******************************************************
9286C
9287
9288      ISTEPN='3'
9289      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'FLUC')
9290     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9291C
9292CCCCC IF(IVARTY(1).EQ.'MATR')GOTO5000
9293C
9294      NRESP=ISTANR
9295      NCRTV=NUMVAR - NRESP
9296      IF(ICASPL.EQ.'FLCP')NCRTV=NCRTV-1
9297      IF(NCRTV.LT.1 .OR. NCRTV.GT.6)THEN
9298        WRITE(ICOUT,999)
9299        CALL DPWRST('XXX','BUG ')
9300        WRITE(ICOUT,311)
9301  311   FORMAT('***** ERROR IN FLUCTUATION PLOT--')
9302        CALL DPWRST('XXX','BUG ')
9303        WRITE(ICOUT,312)
9304  312   FORMAT('      THE NUMBER OF CROSS TABULATION VARIABLES MUST')
9305        CALL DPWRST('XXX','BUG ')
9306        WRITE(ICOUT,313)
9307  313   FORMAT('      BE BETWEEN 1 AND 6.  SUCH WAS NOT THE CASE HERE;')
9308        CALL DPWRST('XXX','BUG ')
9309        WRITE(ICOUT,314)NCRTV
9310  314   FORMAT('      THE SPECIFIED NUMBER OF CROSS TABULATION ',
9311     1         'VARIABLES WAS ',I8)
9312        CALL DPWRST('XXX','BUG ')
9313        IF(IWIDTH.GE.1)THEN
9314          WRITE(ICOUT,318)(IANS(I),I=1,MIN(80,IWIDTH))
9315  318     FORMAT(80A1)
9316          CALL DPWRST('XXX','BUG ')
9317        ENDIF
9318        IERROR='YES'
9319        GOTO9000
9320      ENDIF
9321C
9322C               *******************************
9323C               **  STEP 4--                 **
9324C               **  CREATE THE VARIABLES     **
9325C               *******************************
9326C
9327  400 CONTINUE
9328C
9329      ISTEPN='4'
9330      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'FLUC')
9331     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9332C
9333      IF(IFLAGM.EQ.1)THEN
9334        ICOL=1
9335        CALL DPPARZ(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
9336     1              INAME,IVARN1,IVARN2,IVARTY,
9337     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
9338     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
9339     1              MAXCP4,MAXCP5,MAXCP6,
9340     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
9341     1              Y1,X1,X2,NLOCAL,
9342     1              IBUGG3,ISUBRO,IFOUND,IERROR)
9343        IF(IERROR.EQ.'YES')GOTO9000
9344C
9345        IF(NRESP.GE.2)THEN
9346          ICOL=2
9347          CALL DPPARZ(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
9348     1                INAME,IVARN1,IVARN2,IVARTY,
9349     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
9350     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
9351     1                MAXCP4,MAXCP5,MAXCP6,
9352     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
9353     1                Y2,X3,X4,N2,
9354     1                IBUGG3,ISUBRO,IFOUND,IERROR)
9355          IF(IERROR.EQ.'YES')GOTO9000
9356        ENDIF
9357C
9358        IF(NRESP.GE.3)THEN
9359          ICOL=3
9360          CALL DPPARZ(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
9361     1                INAME,IVARN1,IVARN2,IVARTY,
9362     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
9363     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
9364     1                MAXCP4,MAXCP5,MAXCP6,
9365     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
9366     1                Y3,X3,X4,N3,
9367     1                IBUGG3,ISUBRO,IFOUND,IERROR)
9368          IF(IERROR.EQ.'YES')GOTO9000
9369        ENDIF
9370C
9371        GOTO499
9372      ENDIF
9373C
9374      J=0
9375      IMAX=NRIGHT(1)
9376      IF(NQ.LT.NRIGHT(1))IMAX=NQ
9377      DO410I=1,IMAX
9378        IF(ISUB(I).EQ.0)GOTO410
9379        J=J+1
9380C
9381        IJ=MAXN*(ICOLR(1)-1)+I
9382        IF(ISTANR.LT.1)THEN
9383          Y1(J)=0.0
9384        ELSE
9385          IF(ICOLR(1).LE.MAXCOL)Y1(J)=V(IJ)
9386          IF(ICOLR(1).EQ.MAXCP1)Y1(J)=PRED(I)
9387          IF(ICOLR(1).EQ.MAXCP2)Y1(J)=RES(I)
9388          IF(ICOLR(1).EQ.MAXCP3)Y1(J)=YPLOT(I)
9389          IF(ICOLR(1).EQ.MAXCP4)Y1(J)=XPLOT(I)
9390          IF(ICOLR(1).EQ.MAXCP5)Y1(J)=X2PLOT(I)
9391          IF(ICOLR(1).EQ.MAXCP6)Y1(J)=TAGPLO(I)
9392        ENDIF
9393C
9394        IJ=MAXN*(ICOLR(2)-1)+I
9395        IF(ISTANR.LT.2)THEN
9396          Y2(J)=0.0
9397        ELSE
9398          IF(ICOLR(2).LE.MAXCOL)Y2(J)=V(IJ)
9399          IF(ICOLR(2).EQ.MAXCP1)Y2(J)=PRED(I)
9400          IF(ICOLR(2).EQ.MAXCP2)Y2(J)=RES(I)
9401          IF(ICOLR(2).EQ.MAXCP3)Y2(J)=YPLOT(I)
9402          IF(ICOLR(2).EQ.MAXCP4)Y2(J)=XPLOT(I)
9403          IF(ICOLR(2).EQ.MAXCP5)Y2(J)=X2PLOT(I)
9404          IF(ICOLR(2).EQ.MAXCP6)Y2(J)=TAGPLO(I)
9405        ENDIF
9406C
9407        IJ=MAXN*(ICOLR(3)-1)+I
9408        IF(ISTANR.LT.3)THEN
9409          Y3(J)=0.0
9410        ELSE
9411          IF(ICOLR(3).LE.MAXCOL)Y3(J)=V(IJ)
9412          IF(ICOLR(3).EQ.MAXCP1)Y3(J)=PRED(I)
9413          IF(ICOLR(3).EQ.MAXCP2)Y3(J)=RES(I)
9414          IF(ICOLR(3).EQ.MAXCP3)Y3(J)=YPLOT(I)
9415          IF(ICOLR(3).EQ.MAXCP4)Y3(J)=XPLOT(I)
9416          IF(ICOLR(3).EQ.MAXCP5)Y3(J)=X2PLOT(I)
9417          IF(ICOLR(3).EQ.MAXCP6)Y3(J)=TAGPLO(I)
9418        ENDIF
9419C
9420        ICNT=ISTANR+1
9421        IF(NCRTV.GE.1)THEN
9422          IJ=MAXN*(ICOLR(ICNT)-1)+I
9423          IF(ICOLR(ICNT).LE.MAXCOL)X1(J)=V(IJ)
9424          IF(ICOLR(ICNT).EQ.MAXCP1)X1(J)=PRED(I)
9425          IF(ICOLR(ICNT).EQ.MAXCP2)X1(J)=RES(I)
9426          IF(ICOLR(ICNT).EQ.MAXCP3)X1(J)=YPLOT(I)
9427          IF(ICOLR(ICNT).EQ.MAXCP4)X1(J)=XPLOT(I)
9428          IF(ICOLR(ICNT).EQ.MAXCP5)X1(J)=X2PLOT(I)
9429          IF(ICOLR(ICNT).EQ.MAXCP6)X1(J)=TAGPLO(I)
9430        ELSE
9431          X1(J)=0.0
9432        ENDIF
9433C
9434        ICNT=ISTANR+2
9435        IF(NCRTV.GE.2)THEN
9436          IJ=MAXN*(ICOLR(ICNT)-1)+I
9437          IF(ICOLR(ICNT).LE.MAXCOL)X2(J)=V(IJ)
9438          IF(ICOLR(ICNT).EQ.MAXCP1)X2(J)=PRED(I)
9439          IF(ICOLR(ICNT).EQ.MAXCP2)X2(J)=RES(I)
9440          IF(ICOLR(ICNT).EQ.MAXCP3)X2(J)=YPLOT(I)
9441          IF(ICOLR(ICNT).EQ.MAXCP4)X2(J)=XPLOT(I)
9442          IF(ICOLR(ICNT).EQ.MAXCP5)X2(J)=X2PLOT(I)
9443          IF(ICOLR(ICNT).EQ.MAXCP6)X2(J)=TAGPLO(I)
9444        ELSE
9445          X2(J)=0.0
9446        ENDIF
9447C
9448        ICNT=ISTANR+3
9449        IF(NCRTV.GE.3)THEN
9450          IJ=MAXN*(ICOLR(ICNT)-1)+I
9451          IF(ICOLR(ICNT).LE.MAXCOL)X3(J)=V(IJ)
9452          IF(ICOLR(ICNT).EQ.MAXCP1)X3(J)=PRED(I)
9453          IF(ICOLR(ICNT).EQ.MAXCP2)X3(J)=RES(I)
9454          IF(ICOLR(ICNT).EQ.MAXCP3)X3(J)=YPLOT(I)
9455          IF(ICOLR(ICNT).EQ.MAXCP4)X3(J)=XPLOT(I)
9456          IF(ICOLR(ICNT).EQ.MAXCP5)X3(J)=X2PLOT(I)
9457          IF(ICOLR(ICNT).EQ.MAXCP6)X3(J)=TAGPLO(I)
9458        ELSE
9459          X3(J)=0.0
9460        ENDIF
9461C
9462        ICNT=ISTANR+4
9463        IF(NCRTV.GE.4)THEN
9464          IJ=MAXN*(ICOLR(ICNT)-1)+I
9465          IF(ICOLR(ICNT).LE.MAXCOL)X4(J)=V(IJ)
9466          IF(ICOLR(ICNT).EQ.MAXCP1)X4(J)=PRED(I)
9467          IF(ICOLR(ICNT).EQ.MAXCP2)X4(J)=RES(I)
9468          IF(ICOLR(ICNT).EQ.MAXCP3)X4(J)=YPLOT(I)
9469          IF(ICOLR(ICNT).EQ.MAXCP4)X4(J)=XPLOT(I)
9470          IF(ICOLR(ICNT).EQ.MAXCP5)X4(J)=X2PLOT(I)
9471          IF(ICOLR(ICNT).EQ.MAXCP6)X4(J)=TAGPLO(I)
9472        ELSE
9473          X4(J)=0.0
9474        ENDIF
9475C
9476        ICNT=ISTANR+5
9477        IF(NCRTV.GE.5)THEN
9478          IJ=MAXN*(ICOLR(ICNT)-1)+I
9479          IF(ICOLR(ICNT).LE.MAXCOL)X5(J)=V(IJ)
9480          IF(ICOLR(ICNT).EQ.MAXCP1)X5(J)=PRED(I)
9481          IF(ICOLR(ICNT).EQ.MAXCP2)X5(J)=RES(I)
9482          IF(ICOLR(ICNT).EQ.MAXCP3)X5(J)=YPLOT(I)
9483          IF(ICOLR(ICNT).EQ.MAXCP4)X5(J)=XPLOT(I)
9484          IF(ICOLR(ICNT).EQ.MAXCP5)X5(J)=X2PLOT(I)
9485          IF(ICOLR(ICNT).EQ.MAXCP6)X5(J)=TAGPLO(I)
9486        ELSE
9487          X5(J)=0.0
9488        ENDIF
9489C
9490        ICNT=ISTANR+6
9491        IF(NCRTV.GE.6)THEN
9492          IJ=MAXN*(ICOLR(ICNT)-1)+I
9493          IF(ICOLR(ICNT).LE.MAXCOL)X6(J)=V(IJ)
9494          IF(ICOLR(ICNT).EQ.MAXCP1)X6(J)=PRED(I)
9495          IF(ICOLR(ICNT).EQ.MAXCP2)X6(J)=RES(I)
9496          IF(ICOLR(ICNT).EQ.MAXCP3)X6(J)=YPLOT(I)
9497          IF(ICOLR(ICNT).EQ.MAXCP4)X6(J)=XPLOT(I)
9498          IF(ICOLR(ICNT).EQ.MAXCP5)X6(J)=X2PLOT(I)
9499          IF(ICOLR(ICNT).EQ.MAXCP6)X6(J)=TAGPLO(I)
9500        ELSE
9501          X6(J)=0.0
9502        ENDIF
9503C
9504  410 CONTINUE
9505      NLOCAL=J
9506C
9507  499 CONTINUE
9508C
9509      IF(ICASPL.EQ.'FLCP')THEN
9510        ICNT=NRESP+NCRTV+1
9511        J2=0
9512        IMAX=NRIGHT(ICNT)
9513        DO490I=1,IMAX
9514          J2=J2+1
9515C
9516          IJ=MAXN*(ICOLR(ICNT)-1)+I
9517          IF(ICOLR(ICNT).LE.MAXCOL)YLEVEL(J2)=V(IJ)
9518          IF(ICOLR(ICNT).EQ.MAXCP1)YLEVEL(J2)=PRED(I)
9519          IF(ICOLR(ICNT).EQ.MAXCP2)YLEVEL(J2)=RES(I)
9520          IF(ICOLR(ICNT).EQ.MAXCP3)YLEVEL(J2)=YPLOT(I)
9521          IF(ICOLR(ICNT).EQ.MAXCP4)YLEVEL(J2)=XPLOT(I)
9522          IF(ICOLR(ICNT).EQ.MAXCP5)YLEVEL(J2)=X2PLOT(I)
9523          IF(ICOLR(ICNT).EQ.MAXCP6)YLEVEL(J2)=TAGPLO(I)
9524  490   CONTINUE
9525        NLEVEL=J2
9526      ELSE
9527        NLEVEL=0
9528      ENDIF
9529C
9530C               *************************************
9531C               **  STEP 61--                      **
9532C               **  GENERATE THE FLUCTUATION PLOT  **
9533C               *************************************
9534C
9535      ISTEPN='61'
9536      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'FLUC')THEN
9537        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9538        WRITE(ICOUT,6001)NLOCAL,ICASPL
9539 6001   FORMAT('NLOCAL,ICASPL=',I5,1X,A4)
9540        CALL DPWRST('XXX','BUG ')
9541      ENDIF
9542C
9543      IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
9544     1   ICASCT.EQ.'DMEA' .OR. ICASCT.EQ.'DBPR' .OR.
9545     1   ICASCT.EQ.'MDCL' .OR. ICASCT.EQ.'BRAT')THEN
9546        IHP='ALPH'
9547        IHP2='A   '
9548        IHWUSE='P'
9549        MESSAG='NO'
9550        CALL CHECKN(IHP,IHP2,IHWUSE,
9551     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,
9552     1              NUMNAM,MAXNAM,
9553     1              ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,
9554     1              ILOCP,IERROR)
9555        IF(IERROR.EQ.'YES')THEN
9556          ALPHA=0.05
9557        ELSE
9558          ALPHA=VALUE(ILOCP)
9559          IF(ALPHA.LE.0.0)ALPHA=0.05
9560          IF(ALPHA.GE.1.0)ALPHA=0.05
9561        ENDIF
9562      ELSE
9563        ALPHA=0.05
9564      ENDIF
9565C
9566CCCCC GOTO6999
9567C
9568C5000 CONTINUE
9569C
9570C     MATRIX CASE.  IN THIS CASE, WE ASSUME THAT THE RAW
9571C     DATA HAS ALREADY BEEN CROSS-CLASSIFIED INTO A 2-WAY
9572C     TABLE OF COUNTS.  IN THIS CASE, WE ONLY GENERATE THE
9573C     FLUCTUATION PLOT FOR THE COUNTS CASE (I.E., NOT FOR
9574C     A STATISTIC SUCH AS THE MEAN).
9575C
9576CCCCC ICASCT='NUMB'
9577CCCCC ICTNAM='COUNT'
9578CCCCC NCRTV=2
9579CCCCC ICASE='TABL'
9580C
9581CCCCC ILISR=ILIS(1)
9582CCCCC N1=IN(ILISR)
9583CCCCC ICOL1=IVALUE(ILISR)
9584CCCCC ICOL2=IVALU2(ILISR)
9585CCCCC NCOL=(ICOL2 - ICOL1) + 1
9586CCCCC print *,'ilisr,n1,ncol=',ilisr,n1,ncol
9587C
9588CCCCC NLOOP=NCOL
9589CCCCC IF(NLOOP.LT.1)NLOOP=1
9590CCCCC IMAX=N1
9591CCCCC IF(NQ.LT.N1)IMAX=NQ
9592C
9593CCCCC JCOL=0
9594CCCCC DO5571JLOOP=1,NLOOP
9595CCCCC   J=0
9596CCCCC   DO5570I=1,IMAX
9597CCCCC     IF(ISUB(I).EQ.0)GOTO5570
9598CCCCC     J=J+1
9599CCCCC     ICOLT=ICOLR(1)+JLOOP-1
9600CCCCC     IJ=MAXN*(ICOLT-1)+I
9601C
9602CCCCC     IF(ICOLT.LE.MAXCOL)XMAT(J,JLOOP)=V(IJ)
9603CCCCC     IF(ICOLT.EQ.MAXCP1)XMAT(J,JLOOP)=PRED(I)
9604CCCCC     IF(ICOLT.EQ.MAXCP2)XMAT(J,JLOOP)=RES(I)
9605CCCCC     IF(ICOLT.EQ.MAXCP3)XMAT(J,JLOOP)=YPLOT(I)
9606CCCCC     IF(ICOLT.EQ.MAXCP4)XMAT(J,JLOOP)=XPLOT(I)
9607CCCCC     IF(ICOLT.EQ.MAXCP5)XMAT(J,JLOOP)=X2PLOT(I)
9608CCCCC     IF(ICOLT.EQ.MAXCP6)XMAT(J,JLOOP)=TAGPLO(I)
9609C
9610C5570   CONTINUE
9611c5571 CONTINUE
9612C
9613CCCCC NROW=J
9614C
9615C6999 CONTINUE
9616C
9617      CALL DPFLU2(Y1,Y2,Y3,X1,X2,X3,X4,X5,X6,NLOCAL,
9618     1            YLEVEL,NLEVEL,
9619     1            NUMV2,ICASCT,ICASE,ICASPL,
9620     1            XH1DIS,XH2DIS,XH3DIS,XH4DIS,XH5DIS,XH6DIS,
9621     1            TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,
9622     1            TEMP6,TEMP7,TEMP8,TEMP9,TMP10,
9623     1            TMP11,TMP12,TMP13,TMP14,
9624     1            ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
9625     1            DTEMP1,DTEMP2,DTEMP3,
9626     1            XMAT,MAXLEV,NROW,NCOL,
9627     1            ISEED,IQUASE,IBINME,IBI2ME,ICTAMV,
9628     1            PSTAMV,PCTAMV,ALPHA,
9629     1            IXVAR,IX2VAR,IYVAR,
9630     1            NCRTV,MAXOBV,PFLUFL,PFLUCL,IFLUWI,IFLUUN,
9631     1            IFLUCD,IFLUBP,IFLUDI,IFLUSO,IFLUSR,IFLUSC,IFLUBD,
9632     1            STATMN,STATMX,
9633     1            XACLOW,XACUPP,
9634     1            Y,X,D,DCOLOR,
9635     1            NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR)
9636C
9637C               ***************************************
9638C               **  STEP 71--                        **
9639C               **  UPDATE INTERNAL DATAPLOT TABLES  **
9640C               ***************************************
9641C
9642      ISTEPN='71'
9643      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'FLUC')
9644     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9645C
9646      IH='STAT'
9647      IH2='MINI'
9648      VALUE0=STATMN
9649      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
9650     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
9651     1IANS,IWIDTH,IBUGG3,IERROR)
9652C
9653      IH='STAT'
9654      IH2='MAXI'
9655      VALUE0=STATMX
9656      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
9657     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
9658     1IANS,IWIDTH,IBUGG3,IERROR)
9659C
9660C               *****************
9661C               **  STEP 9--   **
9662C               **  EXIT       **
9663C               *****************
9664C
9665 9000 CONTINUE
9666      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'FLUC')THEN
9667        WRITE(ICOUT,999)
9668        CALL DPWRST('XXX','BUG ')
9669        WRITE(ICOUT,9011)
9670 9011   FORMAT('***** AT THE END       OF DPFLUC--')
9671        CALL DPWRST('XXX','BUG ')
9672        WRITE(ICOUT,9012)IBUGG2,IBUGG3,IBUGQ,ISUBRO
9673 9012   FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',A4,2X,A4,2X,A4,2X,A4)
9674        CALL DPWRST('XXX','BUG ')
9675        WRITE(ICOUT,9013)IFOUND,IERROR
9676 9013   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
9677        CALL DPWRST('XXX','BUG ')
9678        WRITE(ICOUT,9014)NPLOTV,NPLOTP,NLOCAL,ICASPL,IAND1,IAND2
9679 9014   FORMAT('NPLOTV,NPLOTP,NLOCAL,ICASPL,IAND1,IAND2 = ',
9680     1         I8,I8,I8,2X,A4,2X,A4,2X,A4)
9681        CALL DPWRST('XXX','BUG ')
9682        WRITE(ICOUT,9041)NLOCAL
9683 9041   FORMAT('NLOCAL = ',I8)
9684        CALL DPWRST('XXX','BUG ')
9685        IF(NLOCAL.GE.1 .AND. ICASE.EQ.'VARI')THEN
9686          DO9042I=1,NLOCAL
9687            WRITE(ICOUT,9043)I,Y1(I),Y2(I)
9688 9043       FORMAT('I,Y1(I),Y2(I) = ',I8,2E15.7)
9689            CALL DPWRST('XXX','BUG ')
9690 9042     CONTINUE
9691        ENDIF
9692        WRITE(ICOUT,9051)NPLOTP
9693 9051   FORMAT('NPLOTP = ',I8)
9694        CALL DPWRST('XXX','BUG ')
9695        IF(NPLOTP.GE.1)THEN
9696          DO9052I=1,NPLOTP
9697            WRITE(ICOUT,9053)I,Y(I),X(I),D(I),DCOLOR(I)
9698 9053       FORMAT('I,Y(I),X(I),D(I),DCOLOR(I),',I8,4F12.5)
9699            CALL DPWRST('XXX','BUG ')
9700 9052     CONTINUE
9701        ENDIF
9702      ENDIF
9703C
9704      RETURN
9705      END
9706      SUBROUTINE DPFLU2(Y1,Y2,Y3,TAG1,TAG2,TAG3,TAG4,TAG5,TAG6,N,
9707     1                  YLEVEL,NLEVEL,
9708     1                  NUMV2,ICASCT,ICASE,ICASPL,
9709     1                  XIDTEM,XIDTE2,XIDTE3,XIDTE4,XIDTE5,XIDTE6,
9710     1                  TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,
9711     1                  TEMP6,TEMP7,TEMP8,TEMP9,TMP10,
9712     1                  TMP11,TMP12,TMP13,TMP14,
9713     1                  ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
9714     1                  DTEMP1,DTEMP2,DTEMP3,
9715     1                  XMAT,MAXLEV,NROW,NCOL,
9716     1                  ISEED,IQUASE,IBINME,IBI2ME,ICTAMV,
9717     1                  PSTAMV,PCTAMV,ALPHA,
9718     1                  IXVAR,IX2VAR,IYVAR,
9719     1                  NCRTV,MAXOBV,PFLUFL,PFLUCL,IFLUWI,IFLUUN,
9720     1                  IFLUCD,IFLUBP,
9721     1                  IFLUDI,IFLUSO,IFLUSR,IFLUSC,IFLUBD,
9722     1                  STATMN,STATMX,
9723     1                  XACLOW,XACUPP,
9724     1                  Y,X,D,DCOLOR,
9725     1                  NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR)
9726C
9727C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
9728C              THAT WILL DEFINE AN FLUCUATION PLOT
9729C     REFERENCE--UNWIN, THEUS, AND HOFMANN (2006), "GRAPHICS OF
9730C                LARGE DATA SETS: VISUALIZING A MILLION", SPRINGER.
9731C     WRITTEN BY--JAMES J. FILLIBEN
9732C                 STATISTICAL ENGINEERING DIVISION
9733C                 INFORMATION TECHNOLOGY LABORATORY
9734C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
9735C                 GAITHERSBURG, MD 20899-8980
9736C                 PHONE--301-975-2855
9737C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
9738C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
9739C     LANGUAGE--ANSI FORTRAN (1977)
9740C     VERSION NUMBER--2008/5
9741C     ORIGINAL VERSION--MAY       2008.
9742C     UPDATED         --JANUARY   2009. SUPPORT CASE FOR TABLE INPUT
9743C                                       (THIS IS RESTRICTED TO THE
9744C                                       CASE WITH TWO CLASSICATION
9745C                                       VARIABLES--INPUT TABLE CONTAINS
9746C                                       PREVIOUSLY CROSS-TABULATED
9747C                                       VALUES)
9748C     UPDATED         --AUGUST    2009. CORRECT ORDERING FOR XVAL AND
9749C                                       YVAL
9750C     UPDATED         --SEPTEMBER 2009. ADD "UNCERTAINTY INTERVALS"
9751C                                       FOR BINOMIAL PROPORTION AND
9752C                                       MEAN/MEDIAN CONFIDENCE LIMITS
9753C     UPDATED         --MARCH     2010. FOR "UNCERTAINTY INTERVALS",
9754C                                       ADD PLOT POINTS FOR POINT
9755C                                       ESTIMATE
9756C     UPDATED         --JUNE      2010. SUPPORT FOR "SORTED" OPTION FOR
9757C                                       THE TWO GROUP-ID VARIABLE CASE
9758C     UPDATED         --JULY      2011. FOR "UNCERTAINTY INTERVAL" CASE,
9759C                                       SUPPORT "LOWER/UPPER" OPTIONS
9760C     UPDATED         --APRIL     2013. SUPPORT FOR "BAR DIRECTION"
9761C     UPDATED         --NOVEMBER  2017. DIFFERENCE OF MEAN AND
9762C                                       DIFFERENCE OF BINOMIAL
9763C                                       PROPORTIONS SUPPORT UNCERTAINTY
9764C                                       INTERVALS
9765C
9766C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
9767C
9768      CHARACTER*4 ICASCT
9769      CHARACTER*4 IXVAR
9770      CHARACTER*4 IX2VAR
9771      CHARACTER*4 IYVAR
9772      CHARACTER*4 IQUASE
9773      CHARACTER*4 IBINME
9774      CHARACTER*4 IBI2ME
9775      CHARACTER*4 ICTAMV
9776      CHARACTER*4 IFLUUN
9777      CHARACTER*4 IFLUWI
9778      CHARACTER*4 IFLUCD
9779      CHARACTER*4 IFLUBP
9780      CHARACTER*4 IFLUDI
9781      CHARACTER*4 IFLUSO
9782      CHARACTER*4 IFLUSR
9783      CHARACTER*4 IFLUSC
9784      CHARACTER*4 IFLUBD
9785      CHARACTER*4 ICASE
9786      CHARACTER*4 ICASPL
9787      CHARACTER*4 IBUGG3
9788      CHARACTER*4 ISUBRO
9789      CHARACTER*4 IERROR
9790C
9791      CHARACTER*4 IWRITE
9792      CHARACTER*4 ISUBN1
9793      CHARACTER*4 ISUBN2
9794      CHARACTER*4 ISTEPN
9795C
9796C---------------------------------------------------------------------
9797C
9798      DIMENSION Y1(*)
9799      DIMENSION Y2(*)
9800      DIMENSION Y3(*)
9801      DIMENSION TAG1(*)
9802      DIMENSION TAG2(*)
9803      DIMENSION TAG3(*)
9804      DIMENSION TAG4(*)
9805      DIMENSION TAG5(*)
9806      DIMENSION TAG6(*)
9807C
9808      DIMENSION YLEVEL(*)
9809C
9810      DIMENSION XIDTEM(*)
9811      DIMENSION XIDTE2(*)
9812      DIMENSION XIDTE3(*)
9813      DIMENSION XIDTE4(*)
9814      DIMENSION XIDTE5(*)
9815      DIMENSION XIDTE6(*)
9816C
9817      DIMENSION TEMP1(*)
9818      DIMENSION TEMP2(*)
9819      DIMENSION TEMP3(*)
9820      DIMENSION TEMP4(*)
9821      DIMENSION TEMP5(*)
9822      DIMENSION TEMP6(*)
9823      DIMENSION TEMP7(*)
9824      DIMENSION TEMP8(*)
9825      DIMENSION TEMP9(*)
9826      DIMENSION TMP10(*)
9827      DIMENSION TMP11(*)
9828      DIMENSION TMP12(*)
9829      DIMENSION TMP13(*)
9830      DIMENSION TMP14(*)
9831C
9832      DIMENSION XACLOW(*)
9833      DIMENSION XACUPP(*)
9834C
9835      DIMENSION ITEMP1(*)
9836      DIMENSION ITEMP2(*)
9837      DIMENSION ITEMP3(*)
9838      DIMENSION ITEMP4(*)
9839      DIMENSION ITEMP5(*)
9840      DIMENSION ITEMP6(*)
9841C
9842      DOUBLE PRECISION DTEMP1(*)
9843      DOUBLE PRECISION DTEMP2(*)
9844      DOUBLE PRECISION DTEMP3(*)
9845C
9846      DIMENSION Y(*)
9847      DIMENSION X(*)
9848      DIMENSION D(*)
9849      DIMENSION DCOLOR(*)
9850C
9851      DIMENSION XMAT(MAXLEV,MAXLEV)
9852C
9853C---------------------------------------------------------------------
9854C
9855      INCLUDE 'DPCOP2.INC'
9856C
9857C-----START POINT-----------------------------------------------------
9858C
9859      ISUBN1='DPFL'
9860      ISUBN2='U2  '
9861      IERROR='NO'
9862C
9863      I2=0
9864      INDEX=0
9865      ILEVEL=0
9866C
9867      AN=0.0
9868      YUPPER=0.0
9869      YLOWER=0.0
9870C
9871      ANUMS1=0.0
9872      ANUMS2=0.0
9873      ANUMS3=0.0
9874      ANUMS4=0.0
9875      ANUMS5=0.0
9876      ANUMS6=0.0
9877C
9878C               ********************************************
9879C               **  STEP 1--                              **
9880C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
9881C               ********************************************
9882C
9883C
9884C     CHECK THE INPUT ARGUMENTS FOR ERRORS
9885C
9886      IF(N.LT.2 .AND. ICASE.EQ.'VARI')THEN
9887        WRITE(ICOUT,999)
9888  999   FORMAT(1X)
9889        CALL DPWRST('XXX','BUG ')
9890        WRITE(ICOUT,31)
9891   31   FORMAT('***** ERROR IN FLUCUATION PLOT--')
9892        CALL DPWRST('XXX','BUG ')
9893        WRITE(ICOUT,32)
9894   32   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 2.')
9895        CALL DPWRST('XXX','BUG ')
9896        WRITE(ICOUT,34)N
9897   34   FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6)
9898        CALL DPWRST('XXX','BUG ')
9899        WRITE(ICOUT,999)
9900        CALL DPWRST('XXX','BUG ')
9901        IERROR='YES'
9902        GOTO9000
9903      ELSEIF(ICASE.EQ.'TABL' .AND. NROW.LT.1)THEN
9904        WRITE(ICOUT,999)
9905        CALL DPWRST('XXX','BUG ')
9906        WRITE(ICOUT,31)
9907        CALL DPWRST('XXX','BUG ')
9908        WRITE(ICOUT,42)
9909   42   FORMAT('      FOR THE MATRIX CASE, THE NUMBER OF ROWS IS ',
9910     1         'NON-POSITIVE.')
9911        CALL DPWRST('XXX','BUG ')
9912        WRITE(ICOUT,43)NROW
9913   43   FORMAT('      THE NUMBER OF ROWS = ',I8)
9914        CALL DPWRST('XXX','BUG ')
9915      ELSEIF(ICASE.EQ.'TABL' .AND. NCOL.LT.1)THEN
9916        WRITE(ICOUT,999)
9917        CALL DPWRST('XXX','BUG ')
9918        WRITE(ICOUT,31)
9919        CALL DPWRST('XXX','BUG ')
9920        WRITE(ICOUT,47)
9921   47   FORMAT('      FOR THE MATRIX CASE, THE NUMBER OF COLUMNS IS ',
9922     1         'NON-POSITIVE.')
9923        CALL DPWRST('XXX','BUG ')
9924        WRITE(ICOUT,48)NCOL
9925   48   FORMAT('      THE NUMBER OF COLUMNS = ',I8)
9926        CALL DPWRST('XXX','BUG ')
9927      ENDIF
9928C
9929CCCCC DO NOT TREAT FOLLOWING AS AN ERROR.
9930CCCCC PRINT A WARNING, BUT CONTINUE TO PROCESS.
9931C
9932CCCCC  IF(IYVAR.EQ.'ON')THEN
9933CCCCC    HOLD=Y(1)
9934CCCCC    DO60I=1,N
9935CCCCC      IF(Y(I).NE.HOLD)GOTO69
9936CCC60    CONTINUE
9937CCCCC    WRITE(ICOUT,999)
9938CCCCC    CALL DPWRST('XXX','BUG ')
9939CCCCC    WRITE(ICOUT,31)
9940CCCCC    CALL DPWRST('XXX','BUG ')
9941CCCCC    WRITE(ICOUT,62)
9942CCC62    FORMAT('      ALL RESPONSE VARIABLE ELEMENTS')
9943CCCCC    CALL DPWRST('XXX','BUG ')
9944CCCCC    WRITE(ICOUT,63)HOLD
9945CCC63    FORMAT('      ARE IDENTICALLY EQUAL TO ',G15.7)
9946CCCCC    CALL DPWRST('XXX','BUG ')
9947CCCCC    WRITE(ICOUT,999)
9948CCCCC    CALL DPWRST('XXX','BUG ')
9949CCC69   CONTINUE
9950CCCCC  ENDIF
9951C
9952      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'FLU2')THEN
9953        WRITE(ICOUT,70)
9954   70   FORMAT('AT THE BEGINNING OF DPFLU2--')
9955        CALL DPWRST('XXX','BUG ')
9956        WRITE(ICOUT,71)N,ICASCT,ICASE,NUMV2,NCRTV,NLEVEL
9957   71   FORMAT('N,ICASCT,ICASE,NUMV2,NCRTV,NLEVEL = ',
9958     1         I8,2X,A4,2X,A4,3I8)
9959        CALL DPWRST('XXX','BUG ')
9960        WRITE(ICOUT,74)PFLUFL,PFLUCL,IFLUWI
9961   74   FORMAT('PFLUFL,PFLUCL,IFLUWI = ',2G15.7,A4)
9962        CALL DPWRST('XXX','BUG ')
9963        DO72I=1,MIN(N,100)
9964          WRITE(ICOUT,73)I,Y1(I),Y2(I),TAG1(I),TAG2(I),TAG3(I),
9965     1                   TAG4(I),TAG5(I),TAG6(I)
9966   73     FORMAT('I,Y(I),Y2(I),TAG1-6(I) = ',I8,9F10.3)
9967          CALL DPWRST('XXX','BUG ')
9968   72   CONTINUE
9969        IF(NLEVEL.GT.0)THEN
9970          DO82I=1,MIN(NLEVEL,100)
9971            WRITE(ICOUT,83)I,YLEVEL(I)
9972   83       FORMAT('I,YLEVEL(I) = ',I8,G15.7)
9973            CALL DPWRST('XXX','BUG ')
9974   82     CONTINUE
9975        ENDIF
9976      ENDIF
9977C
9978C               ******************************************************
9979C               **  STEP 1--                                        **
9980C               **  DETERMINE THE NUMBER OF DISTINCT VALUES         **
9981C               **  FOR THE GROUP VARIABLES (TAG1, TAG2)            **
9982C               **  IF ALL VALUES ARE DISTINCT, THEN THIS           **
9983C               **  IMPLIES WE HAVE THE NO REPLICATION CASE         **
9984C               **  WHICH IS AN ERROR CONDITION FOR A PLOT.         **
9985C               ******************************************************
9986C
9987      ISTEPN='1'
9988      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'FLU2')
9989     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9990C
9991      IF(ICASE.EQ.'TABL')GOTO990
9992C
9993      IF(IFLUCD.EQ.'ON')THEN
9994        CALL CODE(TAG1,N,IWRITE,TEMP1,TEMP2,MAXOBV,IBUGG3,IERROR)
9995        DO910I=1,N
9996          TAG1(I)=TEMP1(I)
9997  910   CONTINUE
9998      ENDIF
9999      CALL DISTIN(TAG1,N,IWRITE,XIDTEM,NUMSE1,IBUGG3,IERROR)
10000      CALL SORT(XIDTEM,NUMSE1,XIDTEM)
10001C
10002      IF(NCRTV.GE.2)THEN
10003        IF(IFLUCD.EQ.'ON')THEN
10004          CALL CODE(TAG2,N,IWRITE,TEMP1,TEMP2,MAXOBV,IBUGG3,IERROR)
10005          DO920I=1,N
10006            TAG2(I)=TEMP1(I)
10007  920     CONTINUE
10008        ENDIF
10009        CALL DISTIN(TAG2,N,IWRITE,XIDTE2,NUMSE2,IBUGG3,IERROR)
10010        CALL SORT(XIDTE2,NUMSE2,XIDTE2)
10011      ENDIF
10012C
10013      IF(NCRTV.GE.3)THEN
10014        IF(IFLUCD.EQ.'ON')THEN
10015          CALL CODE(TAG3,N,IWRITE,TEMP1,TEMP2,MAXOBV,IBUGG3,IERROR)
10016          DO930I=1,N
10017            TAG3(I)=TEMP1(I)
10018  930     CONTINUE
10019        ENDIF
10020        CALL DISTIN(TAG3,N,IWRITE,XIDTE3,NUMSE3,IBUGG3,IERROR)
10021        CALL SORT(XIDTE3,NUMSE3,XIDTE3)
10022      ELSE
10023        NUMSE3=0
10024      ENDIF
10025      IF(NCRTV.GE.4)THEN
10026        IF(IFLUCD.EQ.'ON')THEN
10027          CALL CODE(TAG4,N,IWRITE,TEMP1,TEMP2,MAXOBV,IBUGG3,IERROR)
10028          DO940I=1,N
10029            TAG4(I)=TEMP1(I)
10030  940     CONTINUE
10031        ENDIF
10032        CALL DISTIN(TAG4,N,IWRITE,XIDTE4,NUMSE4,IBUGG3,IERROR)
10033        CALL SORT(XIDTE4,NUMSE4,XIDTE4)
10034      ELSE
10035        NUMSE4=0
10036      ENDIF
10037      IF(NCRTV.GE.5)THEN
10038        IF(IFLUCD.EQ.'ON')THEN
10039          CALL CODE(TAG5,N,IWRITE,TEMP1,TEMP2,MAXOBV,IBUGG3,IERROR)
10040          DO950I=1,N
10041            TAG5(I)=TEMP1(I)
10042  950     CONTINUE
10043        ENDIF
10044        CALL DISTIN(TAG5,N,IWRITE,XIDTE5,NUMSE5,IBUGG3,IERROR)
10045        CALL SORT(XIDTE5,NUMSE5,XIDTE5)
10046      ELSE
10047        NUMSE5=0
10048      ENDIF
10049      IF(NCRTV.GE.6)THEN
10050        IF(IFLUCD.EQ.'ON')THEN
10051          CALL CODE(TAG6,N,IWRITE,TEMP1,TEMP2,MAXOBV,IBUGG3,IERROR)
10052          DO960I=1,N
10053            TAG6(I)=TEMP1(I)
10054  960     CONTINUE
10055        ENDIF
10056        CALL DISTIN(TAG6,N,IWRITE,XIDTE6,NUMSE6,IBUGG3,IERROR)
10057        CALL SORT(XIDTE6,NUMSE6,XIDTE6)
10058      ELSE
10059        NUMSE6=0
10060      ENDIF
10061C
10062      IF(NUMSE1.LT.1 .OR. NUMSE1.GT.N)THEN
10063        WRITE(ICOUT,999)
10064        CALL DPWRST('XXX','BUG ')
10065        WRITE(ICOUT,31)
10066        CALL DPWRST('XXX','BUG ')
10067        ITEMP=1
10068        WRITE(ICOUT,111)ITEMP,NUMSE1
10069  111   FORMAT('      THE NUMBER OF SETS FOR THE GROUP ',I1,
10070     1         ' VARIABLE, ',I8,',')
10071        CALL DPWRST('XXX','BUG ')
10072        WRITE(ICOUT,113)
10073  113   FORMAT('      IS EITHER LESS THAN ONE OR GREATER THAN THE ',
10074     1         'NUMBER')
10075        CALL DPWRST('XXX','BUG ')
10076        WRITE(ICOUT,115)N
10077  115   FORMAT('      OF OBSERVATIONS, ',I8,'.')
10078        CALL DPWRST('XXX','BUG ')
10079        IERROR='YES'
10080        GOTO9000
10081      ENDIF
10082C
10083      IF(NCRTV.GE.2 .AND. (NUMSE2.LT.1 .OR. NUMSE2.GT.N))THEN
10084        WRITE(ICOUT,999)
10085        CALL DPWRST('XXX','BUG ')
10086        WRITE(ICOUT,31)
10087        CALL DPWRST('XXX','BUG ')
10088        ITEMP=2
10089        WRITE(ICOUT,111)ITEMP,NUMSE2
10090        CALL DPWRST('XXX','BUG ')
10091        WRITE(ICOUT,113)
10092        CALL DPWRST('XXX','BUG ')
10093        WRITE(ICOUT,115)N
10094        CALL DPWRST('XXX','BUG ')
10095        IERROR='YES'
10096        GOTO9000
10097      ENDIF
10098C
10099      IF(NCRTV.GE.3 .AND. (NUMSE3.LT.1 .OR. NUMSE3.GT.N))THEN
10100        WRITE(ICOUT,999)
10101        CALL DPWRST('XXX','BUG ')
10102        WRITE(ICOUT,31)
10103        CALL DPWRST('XXX','BUG ')
10104        ITEMP=3
10105        WRITE(ICOUT,111)ITEMP,NUMSE3
10106        CALL DPWRST('XXX','BUG ')
10107        WRITE(ICOUT,113)
10108        CALL DPWRST('XXX','BUG ')
10109        WRITE(ICOUT,115)N
10110        CALL DPWRST('XXX','BUG ')
10111        IERROR='YES'
10112        GOTO9000
10113      ENDIF
10114C
10115      IF(NCRTV.GE.4 .AND. (NUMSE4.LT.1 .OR. NUMSE4.GT.N))THEN
10116        WRITE(ICOUT,999)
10117        CALL DPWRST('XXX','BUG ')
10118        WRITE(ICOUT,31)
10119        CALL DPWRST('XXX','BUG ')
10120        ITEMP=4
10121        WRITE(ICOUT,111)ITEMP,NUMSE4
10122        CALL DPWRST('XXX','BUG ')
10123        WRITE(ICOUT,113)
10124        CALL DPWRST('XXX','BUG ')
10125        WRITE(ICOUT,115)N
10126        CALL DPWRST('XXX','BUG ')
10127        IERROR='YES'
10128        GOTO9000
10129      ENDIF
10130C
10131      IF(NCRTV.GE.5 .AND. (NUMSE5.LT.1 .OR. NUMSE5.GT.N))THEN
10132        WRITE(ICOUT,999)
10133        CALL DPWRST('XXX','BUG ')
10134        WRITE(ICOUT,31)
10135        CALL DPWRST('XXX','BUG ')
10136        ITEMP=5
10137        WRITE(ICOUT,111)ITEMP,NUMSE5
10138        CALL DPWRST('XXX','BUG ')
10139        WRITE(ICOUT,113)
10140        CALL DPWRST('XXX','BUG ')
10141        WRITE(ICOUT,115)N
10142        CALL DPWRST('XXX','BUG ')
10143        IERROR='YES'
10144        GOTO9000
10145      ENDIF
10146C
10147      IF(NCRTV.GE.6 .AND. (NUMSE6.LT.1 .OR. NUMSE6.GT.N))THEN
10148        WRITE(ICOUT,999)
10149        CALL DPWRST('XXX','BUG ')
10150        WRITE(ICOUT,31)
10151        CALL DPWRST('XXX','BUG ')
10152        ITEMP=6
10153        WRITE(ICOUT,111)ITEMP,NUMSE6
10154        CALL DPWRST('XXX','BUG ')
10155        WRITE(ICOUT,113)
10156        CALL DPWRST('XXX','BUG ')
10157        WRITE(ICOUT,115)N
10158        CALL DPWRST('XXX','BUG ')
10159        IERROR='YES'
10160        GOTO9000
10161      ENDIF
10162C
10163      AN=N
10164      ANUMS1=NUMSE1
10165      ANUMS2=NUMSE2
10166      ANUMS3=NUMSE3
10167      ANUMS4=NUMSE4
10168      ANUMS5=NUMSE5
10169      ANUMS6=NUMSE6
10170C
10171  990 CONTINUE
10172C               ***********************************************
10173C               **  STEP 5--                                 **
10174C               **  COMPUTE THE VARIOUS CROSS-TAB STATISTICS **
10175C               ***********************************************
10176C
10177      ISTEPN='5.1'
10178      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'CRT2')
10179     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10180C
10181      IWRITE='OFF'
10182C
10183      AINC=0.4
10184C
10185      IF(NCRTV.EQ.1)THEN
10186        CALL DPFLU0(Y1,Y2,Y3,TAG1,N,
10187     1              NUMV2,ICASCT,
10188     1              XIDTEM,
10189     1              NUMSE1,
10190     1              TEMP1,TEMP2,TMP14,TEMP3,TEMP4,TEMP5,
10191     1              ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
10192     1              DTEMP1,DTEMP2,DTEMP3,
10193     1              ISEED,IQUASE,IBINME,IBI2ME,ALPHA,
10194     1              IXVAR,IX2VAR,IYVAR,
10195     1              STATMN,STATMX,TMP13,NMAX,XACLOW,XACUPP,
10196     1              MAXOBV,PFLUFL,PFLUCL,IFLUUN,
10197     1              ICTAMV,PCTAMV,PSTAMV,
10198     1              TEMP6,TEMP7,N2,ISUBRO,IBUGG3,IERROR)
10199C
10200CCCCC   NOW GENERATE THE PLOT COORDINATES.  DEFINE TWO RECTANGLES
10201CCCCC   FOR EACH POINT:
10202CCCCC
10203CCCCC     1) A FULL RECTANGLE THAT WILL BE SHADED IN A LIGHTER
10204CCCCC        SHADE.
10205CCCCC
10206CCCCC     2) A RECTANGLE THAT IS PROPORTIONAL TO THE VALUE OF
10207CCCCC        THE STATISTIC THAT WILL BE SHADED IN A DARKER
10208CCCCC        COLOR.
10209C
10210        IFLAGU=0
10211        IF((ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
10212     1      ICASCT.EQ.'DMEA' .OR. ICASCT.EQ.'DBPR' .OR.
10213     1      ICASCT.EQ.'MDCL' .OR. ICASCT.EQ.'BRAT') .AND.
10214     1      IFLUUN.NE.'OFF')THEN
10215          IFLAGU=1
10216        ENDIF
10217C
10218        ICNT=0
10219        ICNT2=0
10220        AFACT=1.0
10221        DENOM=STATMX-STATMN
10222        DO1001I=1,N2
10223          IF(IFLUWI.EQ.'PROP')THEN
10224            AFACT=TMP13(I)/REAL(NMAX)
10225          ENDIF
10226          IF(ICASPL.EQ.'FLCP')THEN
10227            STATT=TEMP6(I)
10228            IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'BRAT')THEN
10229              IF(IFLUBP.EQ.'LOWE')STATT=XACLOW(I)
10230              IF(IFLUBP.EQ.'UPPE')STATT=XACUPP(I)
10231            ENDIF
10232            IF(STATT.LT.YLEVEL(1))THEN
10233              ILEVEL=1
10234            ELSEIF(STATT.GE.YLEVEL(NLEVEL))THEN
10235              ILEVEL=NLEVEL+1
10236            ELSE
10237              DO1005J=2,NLEVEL
10238                IF(STATT.GE.YLEVEL(J-1) .AND. STATT.LT.YLEVEL(J))THEN
10239                  ILEVEL=J
10240                ENDIF
10241 1005         CONTINUE
10242            ENDIF
10243            ACOL=REAL(ILEVEL+1)
10244          ELSE
10245            ACOL=2.0
10246          ENDIF
10247C
10248          XVAL=TEMP7(I)
10249          YVAL=TEMP6(I)
10250          CALL DPFLUW(Y,X,D,DCOLOR,TEMP6,XACLOW,XACUPP,
10251     1                XCOOR1,XCOOR2,XCOOR3,XCOOR4,XCOOR5,
10252     1                YCOOR1,YCOOR2,YCOOR3,YCOOR4,YCOOR5,
10253     1                ICNT,ICNT2,ACOL,IFLAGU,
10254     1                I,XVAL,YVAL,AFACT,AINC,STATMN,DENOM,
10255     1                IFLUBD)
10256C
10257 1001   CONTINUE
10258C
10259        NPLOTP=ICNT
10260        NPLOTV=2
10261C
10262C       WHEN THERE ARE EXACTLY TWO CROSS-TABULATION VARIABLES, THEN
10263C       SUPPORT A "SORT" OPTION.  FIRST NEED TO OBTAIN ROW AND COLUMN
10264C       VALUES FOR THE STATISTICS.  FROM THESE, CREATE "INDEX" VARIABLES.
10265C
10266      ELSEIF(NCRTV.EQ.2)THEN
10267C
10268C       SORT THE ROWS.  FOR THIS APPLICATION, NEED A RANK.  SINCE THE
10269C       RANK WILL SERVE AS AN ARRAY INDEX, NEED TO CHECK FOR TIES.
10270C
10271        IF(IFLUSO.EQ.'ON' .OR. IFLUSO.EQ.'ROW')THEN
10272          CALL DPFLU0(Y1,Y2,Y3,TAG1,N,
10273     1                NUMV2,ICASCT,
10274     1                XIDTEM,
10275     1                NUMSE1,
10276     1                TEMP1,TEMP2,TMP14,TEMP3,TEMP4,TEMP5,
10277     1                ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
10278     1                DTEMP1,DTEMP2,DTEMP3,
10279     1                ISEED,IQUASE,IBINME,IBI2ME,ALPHA,
10280     1                IXVAR,IX2VAR,IYVAR,
10281     1                STATMN,STATMX,TMP13,NMAX,XACLOW,XACUPP,
10282     1                MAXOBV,PFLUFL,PFLUCL,IFLUUN,
10283     1                ICTAMV,PCTAMV,PSTAMV,
10284     1                TEMP9,TEMP7,N2,ISUBRO,IBUGG3,IERROR)
10285          CALL RANKI(TEMP9,NUMSE1,IWRITE,XIDTE3,TEMP7,ITEMP1,MAXOBV,
10286     1               IBUGG3,IERROR)
10287          CALL DISTIN(XIDTE3,NUMSE1,IWRITE,TEMP7,NTEMP,IBUGG3,IERROR)
10288          IF(NTEMP.NE.NUMSE1)THEN
10289            DO1006II=1,NUMSE1
10290              XIDTE3(II)=XIDTEM(II)
10291 1006       CONTINUE
10292          ENDIF
10293          IF(IFLUSR.EQ.'DESC')THEN
10294            DO4006I=1,N
10295              IRANK=INT(XIDTE3(I)+0.1)
10296              IRANK2=NUMSE1 - IRANK + 1
10297              XIDTE3(I)=REAL(IRANK2)
10298 4006       CONTINUE
10299          ENDIF
10300        ELSE
10301          IF(IFLUSR.EQ.'DESC')THEN
10302            DO4007II=1,NUMSE1
10303              IVAL=NUMSE1 - II + 1
10304              XIDTE3(II)=XIDTEM(IVAL)
10305 4007       CONTINUE
10306          ELSE
10307            DO1007II=1,NUMSE1
10308              XIDTE3(II)=XIDTEM(II)
10309 1007       CONTINUE
10310          ENDIF
10311        ENDIF
10312C
10313C       SORT THE COLUMNS
10314C
10315        IF(IFLUSO.EQ.'ON' .OR. IFLUSO.EQ.'COLU')THEN
10316          CALL DPFLU0(Y1,Y2,Y3,TAG1,N,
10317     1                NUMV2,ICASCT,
10318     1                XIDTEM,
10319     1                NUMSE1,
10320     1                TEMP1,TEMP2,TMP14,TEMP3,TEMP4,TEMP5,
10321     1                ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
10322     1                DTEMP1,DTEMP2,DTEMP3,
10323     1                ISEED,IQUASE,IBINME,IBI2ME,ALPHA,
10324     1                IXVAR,IX2VAR,IYVAR,
10325     1                STATMN,STATMX,TMP13,NMAX,XACLOW,XACUPP,
10326     1                MAXOBV,PFLUFL,PFLUCL,IFLUUN,
10327     1                ICTAMV,PCTAMV,PSTAMV,
10328     1                TMP10,TEMP7,N2,ISUBRO,IBUGG3,IERROR)
10329          CALL RANKI(TMP10,NUMSE2,IWRITE,XIDTE4,TEMP7,ITEMP1,MAXOBV,
10330     1              IBUGG3,IERROR)
10331          CALL DISTIN(XIDTE4,NUMSE2,IWRITE,TEMP7,NTEMP,IBUGG3,IERROR)
10332          IF(NTEMP.NE.NUMSE2)THEN
10333            DO1008II=1,NUMSE2
10334              XIDTE4(II)=XIDTE2(II)
10335 1008       CONTINUE
10336          ENDIF
10337          IF(IFLUSC.EQ.'DESC')THEN
10338            DO4008I=1,N
10339              IRANK=INT(XIDTE4(I)+0.1)
10340              IRANK2=NUMSE2 - IRANK + 1
10341              XIDTE4(I)=REAL(IRANK2)
10342 4008       CONTINUE
10343          ENDIF
10344        ELSE
10345          IF(IFLUSR.EQ.'DESC')THEN
10346            DO5008II=1,NUMSE2
10347              IVAL=NUMSE2 - II + 1
10348              XIDTE4(II)=XIDTE2(IVAL)
10349 5008       CONTINUE
10350          ELSE
10351             DO1009II=1,NUMSE2
10352              XIDTE4(II)=XIDTE2(II)
10353 1009       CONTINUE
10354          ENDIF
10355        ENDIF
10356C
10357        CALL DPFLU3(Y1,Y2,Y3,TAG1,TAG2,N,
10358     1              NUMV2,ICASCT,
10359     1              XIDTEM,XIDTE2,
10360     1              NUMSE1,NUMSE2,
10361     1              TEMP1,TEMP2,TMP14,TEMP3,TEMP4,TEMP5,
10362     1              ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
10363     1              DTEMP1,DTEMP2,DTEMP3,
10364     1              ICASE,XMAT,MAXLEV,NROW,NCOL,
10365     1              ISEED,IQUASE,IBINME,IBI2ME,ALPHA,
10366     1              IXVAR,IX2VAR,IYVAR,
10367     1              STATMN,STATMX,TMP13,NMAX,XACLOW,XACUPP,
10368     1              MAXOBV,PFLUFL,PFLUCL,IFLUUN,
10369     1              ICTAMV,PCTAMV,PSTAMV,
10370     1              TEMP6,TEMP7,TEMP8,N2,ISUBRO,IBUGG3,IERROR)
10371C
10372CCCCC   NOW GENERATE THE PLOT COORDINATES.  DEFINE TWO RECTANGLES
10373CCCCC   FOR EACH POINT:
10374CCCCC
10375CCCCC     1) A FULL RECTANGLE THAT WILL BE SHADED IN A LIGHTER
10376CCCCC        SHADE.
10377CCCCC
10378CCCCC     2) A RECTANGLE THAT IS PROPORTIONAL TO THE VALUE OF
10379CCCCC        THE STATISTIC THAT WILL BE SHADED IN A DARKER
10380CCCCC        COLOR.
10381CCCCC
10382CCCCC     FOR THE BINOMIAL PROPORTION, MEAN CONFIDENCE LIMT, AND
10383CCCCC     MEDIAN CONFIDENCE LIMIT, OPTIONALLY ADD UNCERTAINTY
10384CCCCC     RECTANGLES: ONE WILL BE FROM STATISTIC VALUE TO LOWER
10385CCCCC     INTERVAL WHILE THE OTHER WILL BE FROM STAISTIC TO
10386CCCCC     UPPER INTERVAL.
10387CCCCC
10388CCCCC     4/2010: IF "CONTOUR" OPTION IS SPECIFIED, THEN ADJUST
10389CCCCC             COLOR OR SMALLER BOX BASED ON LEVEL OF STATISTIC.
10390CCCCC
10391CCCCC     4/2013: BAR CAN BE DRAWN EITHER VERTICALLY (THE
10392CCCCC             DEFAULT) OR HORIZONTALLY.
10393C
10394        IFLAGU=0
10395        IF((ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
10396     1      ICASCT.EQ.'DMEA' .OR. ICASCT.EQ.'DBPR' .OR.
10397     1      ICASCT.EQ.'MDCL' .OR. ICASCT.EQ.'BRAT') .AND.
10398     1      IFLUUN.NE.'OFF')THEN
10399          IFLAGU=1
10400        ENDIF
10401C
10402        ICNT=0
10403        ICNT2=0
10404        AFACT=1.0
10405        DENOM=STATMX-STATMN
10406        DO1010I=1,N2
10407          IF(IFLUWI.EQ.'PROP' .AND. ICASE.NE.'TABL')THEN
10408            AFACT=TMP13(I)/REAL(NMAX)
10409          ENDIF
10410          IF(ICASPL.EQ.'FLCP')THEN
10411            STATT=TEMP6(I)
10412            IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'BRAT')THEN
10413              IF(IFLUBP.EQ.'LOWE')STATT=XACLOW(I)
10414              IF(IFLUBP.EQ.'UPPE')STATT=XACUPP(I)
10415            ENDIF
10416            IF(STATT.LT.YLEVEL(1))THEN
10417              ILEVEL=1
10418            ELSEIF(STATT.GE.YLEVEL(NLEVEL))THEN
10419              ILEVEL=NLEVEL+1
10420            ELSE
10421              DO1015J=2,NLEVEL
10422                IF(STATT.GE.YLEVEL(J-1) .AND. STATT.LT.YLEVEL(J))THEN
10423                  ILEVEL=J
10424                ENDIF
10425 1015         CONTINUE
10426            ENDIF
10427            ACOL=REAL(ILEVEL+1)
10428          ELSE
10429            ACOL=2.0
10430          ENDIF
10431CCCCC     XVAL=TEMP8(I)
10432CCCCC     YVAL=TEMP7(I)
10433          IF(IFLUSO.EQ.'OFF' .AND. IFLUCD.EQ.'OFF')THEN
10434            IF(IFLUDI.EQ.'X')THEN
10435              XVAL=TEMP7(I)
10436              YVAL=TEMP8(I)
10437            ELSE
10438              XVAL=TEMP8(I)
10439              YVAL=TEMP7(I)
10440            ENDIF
10441          ELSE
10442            IF(IFLUDI.EQ.'X')THEN
10443              INDEXX=INT(TEMP7(I)+0.1)
10444              INDEXY=INT(TEMP8(I)+0.1)
10445              XVAL=XIDTE3(INDEXX)
10446              YVAL=XIDTE4(INDEXY)
10447            ELSE
10448              INDEXX=INT(TEMP8(I)+0.1)
10449              INDEXY=INT(TEMP7(I)+0.1)
10450              XVAL=XIDTE4(INDEXX)
10451              YVAL=XIDTE3(INDEXY)
10452            ENDIF
10453          ENDIF
10454C
10455          IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'FLU2')THEN
10456            WRITE(ICOUT,1070)I,INDEXX,INDEXY
10457 1070       FORMAT('AT DPFLU3: I,INDEXX,INDEXY = ',3I8)
10458            CALL DPWRST('XXX','BUG ')
10459            WRITE(ICOUT,1071)XVAL,YVAL,AFACT,AINC
10460 1071       FORMAT('XVAL,YVAL,AFACT,AINC = ',4G15.7)
10461            CALL DPWRST('XXX','BUG ')
10462            WRITE(ICOUT,1072)XIDTE3(I),XIDTE4(I)
10463 1072       FORMAT('XIDTE3(I),XIDTE4(I) = ',2G15.7)
10464            CALL DPWRST('XXX','BUG ')
10465          ENDIF
10466C
10467          CALL DPFLUW(Y,X,D,DCOLOR,TEMP6,XACLOW,XACUPP,
10468     1                XCOOR1,XCOOR2,XCOOR3,XCOOR4,XCOOR5,
10469     1                YCOOR1,YCOOR2,YCOOR3,YCOOR4,YCOOR5,
10470     1                ICNT,ICNT2,ACOL,IFLAGU,
10471     1                I,XVAL,YVAL,AFACT,AINC,STATMN,DENOM,
10472     1                IFLUBD)
10473C
10474 1010   CONTINUE
10475C
10476        NPLOTP=ICNT
10477        NPLOTV=2
10478C
10479      ELSEIF(NCRTV.EQ.3)THEN
10480        CALL DPFLU4(Y1,Y2,Y3,TAG1,TAG2,TAG3,N,
10481     1              NUMV2,ICASCT,
10482     1              XIDTEM,XIDTE2,XIDTE3,
10483     1              NUMSE1,NUMSE2,NUMSE3,
10484     1              TEMP1,TEMP2,TMP14,TEMP3,TEMP4,TEMP5,
10485     1              ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
10486     1              DTEMP1,DTEMP2,DTEMP3,
10487     1              ISEED,IQUASE,IBINME,IBI2ME,ALPHA,
10488     1              IXVAR,IX2VAR,IYVAR,
10489     1              STATMN,STATMX,TMP13,NMAX,XACLOW,XACUPP,
10490     1              MAXOBV,PFLUFL,PFLUCL,IFLUUN,
10491     1              ICTAMV,PCTAMV,PSTAMV,
10492     1              TEMP6,TEMP7,TEMP8,TEMP9,N2,ISUBRO,IBUGG3,IERROR)
10493C
10494CCCCC   NOW GENERATE THE PLOT COORDINATES.  DEFINE TWO RECTANGLES
10495CCCCC   FOR EACH POINT:
10496CCCCC
10497CCCCC     1) A FULL RECTANGLE THAT WILL BE SHADED IN A LIGHTER
10498CCCCC        SHADE.
10499CCCCC
10500CCCCC     2) A RECTANGLE THAT IS PROPORTIONAL TO THE VALUE OF
10501CCCCC        THE STATISTIC THAT WILL BE SHADED IN A DARKER
10502CCCCC        COLOR.
10503C
10504        IFLAGU=0
10505        IF((ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
10506     1      ICASCT.EQ.'DMEA' .OR. ICASCT.EQ.'DBPR' .OR.
10507     1      ICASCT.EQ.'MDCL' .OR. ICASCT.EQ.'BRAT') .AND.
10508     1      IFLUUN.NE.'OFF')THEN
10509          IFLAGU=1
10510        ENDIF
10511C
10512        ICNT=0
10513        ICNT2=0
10514        AFACT=1.0
10515        DENOM=STATMX-STATMN
10516        DO1020I=1,N2
10517          IF(IFLUWI.EQ.'PROP')THEN
10518            AFACT=TMP13(I)/REAL(NMAX)
10519          ENDIF
10520          IF(ICASPL.EQ.'FLCP')THEN
10521            STATT=TEMP6(I)
10522            IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'BRAT')THEN
10523              IF(IFLUBP.EQ.'LOWE')STATT=XACLOW(I)
10524              IF(IFLUBP.EQ.'UPPE')STATT=XACUPP(I)
10525            ENDIF
10526            IF(STATT.LT.YLEVEL(1))THEN
10527              ILEVEL=1
10528            ELSEIF(STATT.GE.YLEVEL(NLEVEL))THEN
10529              ILEVEL=NLEVEL+1
10530            ELSE
10531              DO1025J=2,NLEVEL
10532                IF(STATT.GE.YLEVEL(J-1) .AND. STATT.LT.YLEVEL(J))THEN
10533                  ILEVEL=J
10534                ENDIF
10535 1025         CONTINUE
10536            ENDIF
10537            ACOL=REAL(ILEVEL+1)
10538          ELSE
10539            ACOL=2.0
10540          ENDIF
10541          XVAL=TEMP8(I)
10542CCCCC     YVAL=ANUMS3*(TEMP7(I) - 1.0) + TEMP9(I)
10543          YVAL=ANUMS1*(TEMP9(I) - 1.0) + TEMP7(I)
10544C
10545          CALL DPFLUW(Y,X,D,DCOLOR,TEMP6,XACLOW,XACUPP,
10546     1                XCOOR1,XCOOR2,XCOOR3,XCOOR4,XCOOR5,
10547     1                YCOOR1,YCOOR2,YCOOR3,YCOOR4,YCOOR5,
10548     1                ICNT,ICNT2,ACOL,IFLAGU,
10549     1                I,XVAL,YVAL,AFACT,AINC,STATMN,DENOM,
10550     1                IFLUBD)
10551C
10552 1020   CONTINUE
10553C
10554        NPLOTP=ICNT
10555        NPLOTV=2
10556C
10557      ELSEIF(NCRTV.EQ.4)THEN
10558        CALL DPFLU5(Y1,Y2,Y3,TAG1,TAG2,TAG3,TAG4,N,
10559     1              NUMV2,ICASCT,
10560     1              XIDTEM,XIDTE2,XIDTE3,XIDTE4,
10561     1              NUMSE1,NUMSE2,NUMSE3,NUMSE4,
10562     1              TEMP1,TEMP2,TMP14,TEMP3,TEMP4,TEMP5,
10563     1              ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
10564     1              DTEMP1,DTEMP2,DTEMP3,
10565     1              ISEED,IQUASE,IBINME,IBI2ME,ALPHA,
10566     1              IXVAR,IX2VAR,IYVAR,
10567     1              STATMN,STATMX,TMP13,NMAX,XACLOW,XACUPP,
10568     1              MAXOBV,PFLUFL,PFLUCL,IFLUUN,
10569     1              ICTAMV,PCTAMV,PSTAMV,
10570     1              TEMP6,TEMP7,TEMP8,TEMP9,TMP10,N2,
10571     1              ISUBRO,IBUGG3,IERROR)
10572C
10573CCCCC   NOW GENERATE THE PLOT COORDINATES.  DEFINE TWO RECTANGLES
10574CCCCC   FOR EACH POINT:
10575CCCCC
10576CCCCC     1) A FULL RECTANGLE THAT WILL BE SHADED IN A LIGHTER
10577CCCCC        SHADE.
10578CCCCC
10579CCCCC     2) A RECTANGLE THAT IS PROPORTIONAL TO THE VALUE OF
10580CCCCC        THE STATISTIC THAT WILL BE SHADED IN A DARKER
10581CCCCC        COLOR.
10582C
10583        IFLAGU=0
10584        IF((ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
10585     1      ICASCT.EQ.'DMEA' .OR. ICASCT.EQ.'DBPR' .OR.
10586     1      ICASCT.EQ.'MDCL' .OR. ICASCT.EQ.'BRAT') .AND.
10587     1      IFLUUN.NE.'OFF')THEN
10588          IFLAGU=1
10589        ENDIF
10590C
10591        ICNT=0
10592        ICNT2=0
10593        AFACT=1.0
10594        DENOM=STATMX-STATMN
10595        DO1030I=1,N2
10596          IF(IFLUWI.EQ.'PROP')THEN
10597            AFACT=TMP13(I)/REAL(NMAX)
10598          ENDIF
10599          IF(ICASPL.EQ.'FLCP')THEN
10600            STATT=TEMP6(I)
10601            IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'BRAT')THEN
10602              IF(IFLUBP.EQ.'LOWE')STATT=XACLOW(I)
10603              IF(IFLUBP.EQ.'UPPE')STATT=XACUPP(I)
10604            ENDIF
10605            IF(STATT.LT.YLEVEL(1))THEN
10606              ILEVEL=1
10607            ELSEIF(STATT.GE.YLEVEL(NLEVEL))THEN
10608              ILEVEL=NLEVEL+1
10609            ELSE
10610              DO1035J=2,NLEVEL
10611                IF(STATT.GE.YLEVEL(J-1) .AND. STATT.LT.YLEVEL(J))THEN
10612                  ILEVEL=J
10613                ENDIF
10614 1035         CONTINUE
10615            ENDIF
10616            ACOL=REAL(ILEVEL+1)
10617          ELSE
10618            ACOL=2.0
10619          ENDIF
10620CCCCC     XVAL=ANUMS4*(TEMP8(I) - 1.0) + TMP10(I)
10621CCCCC     YVAL=ANUMS3*(TEMP7(I) - 1.0) + TEMP9(I)
10622          XVAL=ANUMS2*(TMP10(I) - 1.0) + TEMP8(I)
10623          YVAL=ANUMS1*(TEMP9(I) - 1.0) + TEMP7(I)
10624C
10625          CALL DPFLUW(Y,X,D,DCOLOR,TEMP6,XACLOW,XACUPP,
10626     1                XCOOR1,XCOOR2,XCOOR3,XCOOR4,XCOOR5,
10627     1                YCOOR1,YCOOR2,YCOOR3,YCOOR4,YCOOR5,
10628     1                ICNT,ICNT2,ACOL,IFLAGU,
10629     1                I,XVAL,YVAL,AFACT,AINC,STATMN,DENOM,
10630     1                IFLUBD)
10631C
10632 1030   CONTINUE
10633C
10634        NPLOTP=ICNT
10635        NPLOTV=2
10636C
10637      ELSEIF(NCRTV.EQ.5)THEN
10638        CALL DPFLU6(Y1,Y2,Y3,TAG1,TAG2,TAG3,TAG4,TAG5,N,
10639     1              NUMV2,ICASCT,
10640     1              XIDTEM,XIDTE2,XIDTE3,XIDTE4,XIDTE5,
10641     1              NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,
10642     1              TEMP1,TEMP2,TMP14,TEMP3,TEMP4,TEMP5,
10643     1              ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
10644     1              DTEMP1,DTEMP2,DTEMP3,
10645     1              ISEED,IQUASE,IBINME,IBI2ME,ALPHA,
10646     1              IXVAR,IX2VAR,IYVAR,
10647     1              STATMN,STATMX,TMP13,NMAX,XACLOW,XACUPP,
10648     1              MAXOBV,PFLUFL,PFLUCL,IFLUUN,
10649     1              ICTAMV,PCTAMV,PSTAMV,
10650     1              TEMP6,TEMP7,TEMP8,TEMP9,TMP10,TMP11,N2,
10651     1              ISUBRO,IBUGG3,IERROR)
10652C
10653CCCCC   NOW GENERATE THE PLOT COORDINATES.  DEFINE TWO RECTANGLES
10654CCCCC   FOR EACH POINT:
10655CCCCC
10656CCCCC     1) A FULL RECTANGLE THAT WILL BE SHADED IN A LIGHTER
10657CCCCC        SHADE.
10658CCCCC
10659CCCCC     2) A RECTANGLE THAT IS PROPORTIONAL TO THE VALUE OF
10660CCCCC        THE STATISTIC THAT WILL BE SHADED IN A DARKER
10661CCCCC        COLOR.
10662C
10663        IFLAGU=0
10664        IF((ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
10665     1      ICASCT.EQ.'DMEA' .OR. ICASCT.EQ.'DBPR' .OR.
10666     1      ICASCT.EQ.'MDCL' .OR. ICASCT.EQ.'BRAT') .AND.
10667     1      IFLUUN.NE.'OFF')THEN
10668          IFLAGU=1
10669        ENDIF
10670C
10671        ICNT=0
10672        ICNT2=0
10673        AFACT=1.0
10674        DENOM=STATMX-STATMN
10675        DO1040I=1,N2
10676          IF(IFLUWI.EQ.'PROP')THEN
10677            AFACT=TMP13(I)/REAL(NMAX)
10678          ENDIF
10679          IF(ICASPL.EQ.'FLCP')THEN
10680            STATT=TEMP6(I)
10681            IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'BRAT')THEN
10682              IF(IFLUBP.EQ.'LOWE')STATT=XACLOW(I)
10683              IF(IFLUBP.EQ.'UPPE')STATT=XACUPP(I)
10684            ENDIF
10685            IF(STATT.LT.YLEVEL(1))THEN
10686              ILEVEL=1
10687            ELSEIF(STATT.GE.YLEVEL(NLEVEL))THEN
10688              ILEVEL=NLEVEL+1
10689            ELSE
10690              DO1045J=2,NLEVEL
10691                IF(STATT.GE.YLEVEL(J-1) .AND. STATT.LT.YLEVEL(J))THEN
10692                  ILEVEL=J
10693                ENDIF
10694 1045         CONTINUE
10695            ENDIF
10696            ACOL=REAL(ILEVEL+1)
10697          ELSE
10698            ACOL=2.0
10699          ENDIF
10700CCCCC     XVAL=ANUMS4*(TEMP8(I) - 1.0) + TMP10(I)
10701          XVAL=ANUMS2*(TMP10(I) - 1.0) + TEMP8(I)
10702CCCCC     YVAL=(ANUMS3+ANUMS5)*(TEMP7(I) - 1.0) +
10703CCCCC1         ANUMS5*(TEMP9(I) - 1.0) + TMP11(I)
10704          YVAL=(ANUMS1+ANUMS3)*(TMP11(I) - 1.0) +
10705     1         ANUMS1*(TEMP9(I) - 1.0) + TEMP7(I)
10706C
10707          CALL DPFLUW(Y,X,D,DCOLOR,TEMP6,XACLOW,XACUPP,
10708     1                XCOOR1,XCOOR2,XCOOR3,XCOOR4,XCOOR5,
10709     1                YCOOR1,YCOOR2,YCOOR3,YCOOR4,YCOOR5,
10710     1                ICNT,ICNT2,ACOL,IFLAGU,
10711     1                I,XVAL,YVAL,AFACT,AINC,STATMN,DENOM,
10712     1                IFLUBD)
10713C
10714 1040   CONTINUE
10715C
10716        NPLOTP=ICNT
10717        NPLOTV=2
10718C
10719      ELSEIF(NCRTV.EQ.6)THEN
10720        CALL DPFLU7(Y1,Y2,Y3,TAG1,TAG2,TAG3,TAG4,TAG5,TAG6,N,
10721     1              NUMV2,ICASCT,
10722     1              XIDTEM,XIDTE2,XIDTE3,XIDTE4,XIDTE5,XIDTE6,
10723     1              NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,NUMSE6,
10724     1              TEMP1,TEMP2,TMP14,TEMP3,TEMP4,TEMP5,
10725     1              ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
10726     1              DTEMP1,DTEMP2,DTEMP3,
10727     1              ISEED,IQUASE,IBINME,IBI2ME,ALPHA,
10728     1              IXVAR,IX2VAR,IYVAR,
10729     1              STATMN,STATMX,TMP13,NMAX,XACLOW,XACUPP,
10730     1              MAXOBV,PFLUFL,PFLUCL,IFLUUN,
10731     1              ICTAMV,PCTAMV,PSTAMV,
10732     1              TEMP6,TEMP7,TEMP8,TEMP9,TMP10,TMP11,TMP12,N2,
10733     1              ISUBRO,IBUGG3,IERROR)
10734C
10735CCCCC   NOW GENERATE THE PLOT COORDINATES.  DEFINE TWO RECTANGLES
10736CCCCC   FOR EACH POINT:
10737CCCCC
10738CCCCC     1) A FULL RECTANGLE THAT WILL BE SHADED IN A LIGHTER
10739CCCCC        SHADE.
10740CCCCC
10741CCCCC     2) A RECTANGLE THAT IS PROPORTIONAL TO THE VALUE OF
10742CCCCC        THE STATISTIC THAT WILL BE SHADED IN A DARKER
10743CCCCC        COLOR.
10744C
10745        IFLAGU=0
10746        IF((ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
10747     1      ICASCT.EQ.'DMEA' .OR. ICASCT.EQ.'DBPR' .OR.
10748     1      ICASCT.EQ.'MDCL' .OR. ICASCT.EQ.'BRAT') .AND.
10749     1      IFLUUN.NE.'OFF')THEN
10750          IFLAGU=1
10751        ENDIF
10752C
10753        ICNT=0
10754        ICNT2=0
10755        AFACT=1.0
10756        DENOM=STATMX-STATMN
10757        DO1050I=1,N2
10758          IF(IFLUWI.EQ.'PROP')THEN
10759            AFACT=TMP13(I)/REAL(NMAX)
10760          ENDIF
10761          IF(ICASPL.EQ.'FLCP')THEN
10762            STATT=TEMP6(I)
10763            IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'BRAT')THEN
10764              IF(IFLUBP.EQ.'LOWE')STATT=XACLOW(I)
10765              IF(IFLUBP.EQ.'UPPE')STATT=XACUPP(I)
10766            ENDIF
10767            IF(STATT.LT.YLEVEL(1))THEN
10768              ILEVEL=1
10769            ELSEIF(STATT.GE.YLEVEL(NLEVEL))THEN
10770              ILEVEL=NLEVEL+1
10771            ELSE
10772              DO1055J=2,NLEVEL
10773                IF(STATT.GE.YLEVEL(J-1) .AND. STATT.LT.YLEVEL(J))THEN
10774                  ILEVEL=J
10775                ENDIF
10776 1055         CONTINUE
10777            ENDIF
10778            ACOL=REAL(ILEVEL+1)
10779          ELSE
10780            ACOL=2.0
10781          ENDIF
10782CCCCC     XVAL=(ANUMS4+ANUMS6)*(TEMP8(I) - 1.0) +
10783CCCCC1         ANUMS5*(TMP10(I) - 1.0) + TMP12(I)
10784CCCCC     YVAL=(ANUMS3+ANUMS5)*(TEMP7(I) - 1.0) +
10785CCCCC1         ANUMS5*(TEMP9(I) - 1.0) + TMP11(I)
10786          XVAL=(ANUMS2+ANUMS4)*(TMP12(I) - 1.0) +
10787     1         ANUMS2*(TMP10(I) - 1.0) + TEMP8(I)
10788          YVAL=(ANUMS1+ANUMS3)*(TMP11(I) - 1.0) +
10789     1         ANUMS1*(TEMP9(I) - 1.0) + TEMP7(I)
10790C
10791          CALL DPFLUW(Y,X,D,DCOLOR,TEMP6,XACLOW,XACUPP,
10792     1                XCOOR1,XCOOR2,XCOOR3,XCOOR4,XCOOR5,
10793     1                YCOOR1,YCOOR2,YCOOR3,YCOOR4,YCOOR5,
10794     1                ICNT,ICNT2,ACOL,IFLAGU,
10795     1                I,XVAL,YVAL,AFACT,AINC,STATMN,DENOM,
10796     1                IFLUBD)
10797C
10798 1050   CONTINUE
10799C
10800        NPLOTP=ICNT
10801        NPLOTV=2
10802C
10803      ENDIF
10804C               *****************
10805C               **  STEP 90--  **
10806C               **  EXIT       **
10807C               *****************
10808C
10809 9000 CONTINUE
10810      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'FLU2')THEN
10811        WRITE(ICOUT,999)
10812        CALL DPWRST('XXX','BUG ')
10813        WRITE(ICOUT,9011)
10814 9011   FORMAT('***** AT THE END       OF DPFLU2--')
10815        CALL DPWRST('XXX','BUG ')
10816        WRITE(ICOUT,9012)ICASCT,N,NPLOTP,NPLOTV,IERROR
10817 9012   FORMAT('ICASCT,N,NPLOTP,NPLOTV,IERROR = ',A4,3I8,2X,A4)
10818        CALL DPWRST('XXX','BUG ')
10819        DO9035I=1,NPLOTP
10820          WRITE(ICOUT,9036)I,Y(I),X(I),D(I),DCOLOR(I)
10821 9036     FORMAT('I,Y(I),X(I),D(I),DCOLOR(I) = ',I8,4G15.7)
10822          CALL DPWRST('XXX','BUG ')
10823 9035   CONTINUE
10824      ENDIF
10825C
10826      RETURN
10827      END
10828      SUBROUTINE DPFLU0(Y,Z,Z2,TAG1,N,
10829     1                  NUMV2,ICASCT,
10830     1                  XIDTEM,NUMSE1,
10831     1                  TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,
10832     1                  ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
10833     1                  DTEMP1,DTEMP2,DTEMP3,
10834     1                  ISEED,IQUASE,IBINME,IBI2ME,ALPHA,
10835     1                  IXVAR,IX2VAR,IYVAR,
10836     1                  STATMN,STATMX,PSIZE,NMAX,XACLOW,XACUPP,
10837     1                  MAXOBV,PFLUFL,PFLUCL,IFLUUN,
10838     1                  ICTAMV,PCTAMV,PSTAMV,
10839     1                  Y2,X2,N2,ISUBRO,IBUGG3,IERROR)
10840C
10841C     PURPOSE--GENERATE A ONE-WAY FLUCUATION PLOT.
10842C     WRITTEN BY--ALAN HECKERT
10843C                 STATISTICAL ENGINEERING DIVISION
10844C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
10845C                 GAITHERSBURG, MD 20899-8980
10846C                 PHONE--301-975-2899
10847C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
10848C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
10849C     REFERENCE--UNWIN, THEUS, AND HOFMANN (2006), "GRAPHICS OF
10850C                LARGE DATA SETS: VISUALIZING A MILLION", SPRINGER.
10851C     LANGUAGE--ANSI FORTRAN (1977)
10852C     VERSION NUMBER--2008/11
10853C     ORIGINAL VERSION--NOVEMBER  2008.
10854C     UPDATED         --SEPTEMBER 2009. SUPPORT FOR UNCERTAINTY INTERVALS
10855C                                       FOR BINOMIAL PROPORTION AND
10856C                                       MEAN/MEDIAN CONFIDENCE INTERVALS
10857C     UPDATED         --JANUARY   2010. SUPPORT FOR UNCERTAINTY INTERVALS
10858C                                       FOR BINOMIAL RATIO
10859C     UPDATED         --NOVEMBER  2017. DIFFERENCE OF MEAN AND
10860C                                       DIFFERENCE OF BINOMIAL
10861C                                       PROPORTIONS SUPPORT UNCERTAINTY
10862C                                       INTERVALS
10863C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
10864C
10865      CHARACTER*4 ICASCT
10866      CHARACTER*4 IXVAR
10867      CHARACTER*4 IX2VAR
10868      CHARACTER*4 IYVAR
10869      CHARACTER*4 IQUASE
10870      CHARACTER*4 IBINME
10871      CHARACTER*4 IBI2ME
10872      CHARACTER*4 ICTAMV
10873      CHARACTER*4 IFLUUN
10874      CHARACTER*4 ICAPSW
10875      CHARACTER*4 ICAPTY
10876      CHARACTER*4 IFORSW
10877      CHARACTER*4 IBUGG3
10878      CHARACTER*4 IERROR
10879C
10880      CHARACTER*4 ISUBRO
10881      CHARACTER*4 IWRITE
10882      CHARACTER*4 IDIR
10883      CHARACTER*4 ISUBN1
10884      CHARACTER*4 ISUBN2
10885      CHARACTER*4 ISTEPN
10886C
10887C---------------------------------------------------------------------
10888C
10889      DIMENSION Y(*)
10890      DIMENSION Z(*)
10891      DIMENSION Z2(*)
10892      DIMENSION XIDTEM(*)
10893      DIMENSION Y2(*)
10894      DIMENSION X2(*)
10895C
10896      DIMENSION PSIZE(*)
10897C
10898      DIMENSION TAG1(*)
10899      DIMENSION TEMP(*)
10900      DIMENSION TEMPZ(*)
10901      DIMENSION TEMPZ2(*)
10902      DIMENSION XTEMP1(*)
10903      DIMENSION XTEMP2(*)
10904      DIMENSION XTEMP3(*)
10905C
10906      DIMENSION XACLOW(*)
10907      DIMENSION XACUPP(*)
10908C
10909      INTEGER ITEMP1(*)
10910      INTEGER ITEMP2(*)
10911      INTEGER ITEMP3(*)
10912      INTEGER ITEMP4(*)
10913      INTEGER ITEMP5(*)
10914      INTEGER ITEMP6(*)
10915C
10916      DOUBLE PRECISION DTEMP1(*)
10917      DOUBLE PRECISION DTEMP2(*)
10918      DOUBLE PRECISION DTEMP3(*)
10919C
10920C---------------------------------------------------------------------
10921C
10922      INCLUDE 'DPCOP2.INC'
10923C
10924C-----START POINT-----------------------------------------------------
10925C
10926      ISUBN1='DPFL'
10927      ISUBN2='U0  '
10928C
10929      I2=0
10930C
10931      AN=INT(N+0.01)
10932C
10933      ISTEPN='5.1'
10934      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'FLU0')THEN
10935        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10936        WRITE(ICOUT,999)
10937        CALL DPWRST('XXX','BUG ')
10938        WRITE(ICOUT,51)
10939   51   FORMAT('***** AT THE BEGINNING OF DPFLU0--')
10940        CALL DPWRST('XXX','BUG ')
10941        WRITE(ICOUT,52)N,NUMSE1,N2,MAXNXT,NUMSE1,NUMV2,MAXOBV
10942   52   FORMAT('N,NUMSE1,N2,MAXNXT,NUMSE1,NUMV2,MAXOBV = ',7I8)
10943        CALL DPWRST('XXX','BUG ')
10944        WRITE(ICOUT,53)ICASCT,ICAPSW,ICAPTY,IFORSW,IERROR
10945   53   FORMAT('ICASCT,ICAPSW,ICAPTY,IFORSW,IERROR = ',4(A4,2X),A4)
10946        CALL DPWRST('XXX','BUG ')
10947        DO56I=1,N
10948          WRITE(ICOUT,57)I,Y(I),Z(I),TAG1(I)
10949   57     FORMAT('I,Y(I),Z(I),TAG1(I) = ',I8,4G15.7)
10950          CALL DPWRST('XXX','BUG ')
10951   56   CONTINUE
10952      ENDIF
10953C
10954C               ***********************************************
10955C               **  STEP 5--                                 **
10956C               **  COMPUTE THE VARIOUS CROSS-TAB STATISTICS **
10957C               ***********************************************
10958C
10959      ISTEPN='5.1'
10960      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'FLU0')
10961     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10962C
10963      IWRITE='OFF'
10964C
10965      STATMN=CPUMAX
10966      IF(ICASCT.EQ.'NUMB')STATMN=0.0
10967      STATMX=CPUMIN
10968      IF(PFLUCL.NE.-9999.0)STATMX=PFLUCL
10969      IF(PFLUFL.NE.-9999.0)STATMN=PFLUFL
10970      NMAX=0
10971      J=0
10972      NRESP=NUMV2-1
10973      DO1110ISET1=1,NUMSE1
10974C
10975        K=0
10976        DO1130I=1,N
10977          IF(XIDTEM(ISET1).EQ.TAG1(I))GOTO1131
10978          GOTO1130
10979 1131     CONTINUE
10980C
10981          K=K+1
10982          IF(IYVAR.EQ.'OFF')THEN
10983            TEMP(K)=0.0
10984          ELSE
10985            TEMP(K)=Y(I)
10986            IF(IXVAR.EQ.'ON')TEMPZ(K)=Z(I)
10987            IF(IX2VAR.EQ.'ON')TEMPZ2(K)=Z2(I)
10988          ENDIF
10989 1130   CONTINUE
10990        NTEMP=K
10991C
10992        NTRIAL=0
10993        ALOWLM=0.0
10994        AUPPLM=0.0
10995        IF(NTEMP.EQ.0)THEN
10996          IF(ICTAMV.EQ.'ZERO')THEN
10997            STAT=0.0
10998            IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
10999     1         ICASCT.EQ.'MDCL' .OR. ICASCT.EQ.'BRAT' .OR.
11000     1         ICASCT.EQ.'DBPR' .OR. ICASCT.EQ.'DMEA')THEN
11001              NTRIAL=0
11002              ALOWLM=0.0
11003              AUPPLM=0.0
11004            ENDIF
11005          ELSEIF(ICTAMV.EQ.'MV  ')THEN
11006            STAT=PCTAMV
11007            IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
11008     1         ICASCT.EQ.'DMEA' .OR. ICASCT.EQ.'DBPR' .OR.
11009     1         ICASCT.EQ.'MDCL' .OR. ICASCT.EQ.'BRAT')THEN
11010              NTRIAL=0
11011              ALOWLM=PCTAMV
11012              AUPPLM=PCTAMV
11013            ENDIF
11014          ELSE
11015            GOTO1110
11016          ENDIF
11017        ELSE
11018          CALL CMPSTA(
11019     1              TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,
11020     1              MAXNXT,NTEMP,NTEMP,NTEMP,
11021     1              NRESP,ICASCT,
11022     1              ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
11023     1              DTEMP1,DTEMP2,DTEMP3,
11024CCCCC1              IQUAME,IQUASE,PSTAMV,
11025     1              STAT,
11026     1              ISUBRO,IBUGG3,IERROR)
11027          IF(IERROR.EQ.'YES')GOTO9000
11028          IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'BRAT')THEN
11029            PTEMP=STAT
11030            NTRIAL=NTEMP
11031            IF(ICASCT.EQ.'BRAT')NTRIAL=ITEMP1(1)
11032            IF(STAT.EQ.PSTAMV)THEN
11033              ALOWLM=PSTAMV
11034              AUPPLM=PSTAMV
11035            ELSE
11036              ALPHAT=ALPHA
11037              IF(ALPHAT.LE.0.5)ALPHAT=1.0 - ALPHA
11038              IF(IFLUUN.EQ.'LOWE')THEN
11039                IDIR='LOWE'
11040                CALL DPAGC1(PTEMP,NTRIAL,ALPHAT,IDIR,IWRITE,
11041     1                      ALOWLM,IBUGG3,IERROR)
11042                AUPPLM=STAT
11043              ELSEIF(IFLUUN.EQ.'UPPE')THEN
11044                IDIR='UPPE'
11045                CALL DPAGC1(PTEMP,NTRIAL,ALPHAT,IDIR,IWRITE,
11046     1                      AUPPLM,IBUGG3,IERROR)
11047                ALOWLM=STAT
11048              ELSE
11049                IF(ICASCT.EQ.'BPRO')THEN
11050                  CALL DPPRC3(TEMP,NTEMP,ALPHAT,PSTAMV,IBINME,TEMPZ2,
11051     1                        PTEMP2,ALOWLM,AUPPLM,
11052     1                        ISUBRO,IBUGG3,IERROR)
11053                ELSEIF(ICASCT.EQ.'BRAT')THEN
11054                  CALL DPAGCO(PTEMP,NTRIAL,ALPHAT,IWRITE,
11055     1                        ALOWLM,AUPPLM,IBUGG3,IERROR)
11056                ENDIF
11057              ENDIF
11058            ENDIF
11059          ELSEIF(ICASCT.EQ.'MECL')THEN
11060            XMEAN=STAT
11061            NTRIAL=NTEMP
11062            IF(STAT.EQ.PSTAMV)THEN
11063              ALOWLM=PSTAMV
11064              AUPPLM=PSTAMV
11065            ELSE
11066              CALL SD(TEMP,NTEMP,IWRITE,XSD,IBUGG3,IERROR)
11067              ALPHAT=ALPHA
11068              CALL DPMECL(XMEAN,XSD,NTEMP,ALPHAT,IWRITE,
11069     1                    ALOWLM,AUPPLM,IBUGG3,IERROR)
11070            ENDIF
11071          ELSEIF(ICASCT.EQ.'MDCL')THEN
11072            XMED=STAT
11073            NTRIAL=NTEMP
11074            IF(STAT.EQ.PSTAMV)THEN
11075              ALOWLM=PSTAMV
11076              AUPPLM=PSTAMV
11077            ELSE
11078              XQ=0.5
11079              CALL QUANSE(XQ,TEMP,NTEMP,IWRITE,XTEMP1,MAXNXT,IQUASE,
11080     1                    QUASE,IBUGG3,IERROR)
11081              ALPHAT=ALPHA
11082              CALL DPMECL(XMED,QUASE,NTEMP,ALPHAT,IWRITE,
11083     1                    ALOWLM,AUPPLM,IBUGG3,IERROR)
11084            ENDIF
11085          ELSEIF(ICASCT.EQ.'DMEA')THEN
11086            XDIFF=STAT
11087            NTRIAL=NTEMP
11088            IF(STAT.EQ.PSTAMV)THEN
11089              ALOWLM=PSTAMV
11090              AUPPLM=PSTAMV
11091            ELSE
11092              ALPHAT=ALPHA
11093              ALP=ALPHA
11094              IF(ALP.LT.0.5)THEN
11095                ALPHAT=1.0-(ALP/2.0)
11096              ELSE
11097                ALP=1.0 - ALPHA
11098                ALPHAT=1.0-(ALP/2.0)
11099              ENDIF
11100              AN=REAL(NTEMP)
11101              CALL MEAN(TEMP,NTEMP,IWRITE,XMEAN1,IBUGG3,IERROR)
11102              CALL SD(TEMP,NTEMP,IWRITE,XSD1,IBUGG3,IERROR)
11103              AVAL1=XSD1**2/AN
11104              CALL MEAN(TEMPZ,NTEMP,IWRITE,XMEAN2,IBUGG3,IERROR)
11105              CALL SD(TEMPZ,NTEMP,IWRITE,XSD2,IBUGG3,IERROR)
11106              AVAL2=XSD2**2/AN
11107              XSTERR=SQRT(AVAL1 + AVAL2)
11108              TERM1=(AVAL1 + AVAL2)**2
11109              TERM2=AVAL1*AVAL1/(AN-1.0) + AVAL2*AVAL2/(AN-1.0)
11110              V=TERM1/TERM2
11111              IV=INT(V+0.5)
11112              CALL TCDF(ALPHAT,REAL(IV),TCV)
11113              ALOWLM=XDIFF - TCV*XSTERR
11114              AUPPLM=XDIFF + TCV*XSTERR
11115            ENDIF
11116          ELSEIF(ICASCT.EQ.'DBPR')THEN
11117            IF(STAT.EQ.PSTAMV)THEN
11118              ALOWLM=PSTAMV
11119              AUPPLM=PSTAMV
11120            ELSE
11121              ALPHAT=ALPHA
11122              ALP=ALPHA
11123              IF(ALP.LT.0.5)THEN
11124                ALPHAT=1.0-(ALP/2.0)
11125              ELSE
11126                ALP=1.0 - ALPHA
11127                ALPHAT=1.0-(ALP/2.0)
11128              ENDIF
11129              CALL DPPRC4(TEMP,NTEMP,TEMPZ,NTEMP,ALPHAT,PSTAMV,
11130     1                    IBI2ME,TEMPZ2,
11131     1                    XDIFF,ALOWLM,AUPPLM,
11132     1                    ISUBRO,IBUGG3,IERROR)
11133            ENDIF
11134          ENDIF
11135        ENDIF
11136C
11137        J=J+1
11138        IF(PFLUCL.EQ.-9999.0)THEN
11139          IF(STAT.GT.STATMX)STATMX=STAT
11140        ELSE
11141          IF(STAT.GT.PFLUCL)STAT=PFLUCL
11142        ENDIF
11143        IF(PFLUFL.EQ.-9999.0)THEN
11144          IF(STAT.LT.STATMN)STATMN=STAT
11145        ELSE
11146          IF(STAT.LT.PFLUFL)STAT=PFLUFL
11147        ENDIF
11148        IF(NTEMP.GT.NMAX)NMAX=NTEMP
11149        PSIZE(J)=REAL(NTEMP)
11150C
11151        Y2(J)=STAT
11152        X2(J)=XIDTEM(ISET1)
11153        IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
11154     1     ICASCT.EQ.'DMEA' .OR. ICASCT.EQ.'DBPR' .OR.
11155     1     ICASCT.EQ.'MDCL' .OR. ICASCT.EQ.'BRAT' .AND.
11156     1     IFLUUN.NE.'OFF')THEN
11157          IF(PFLUCL.EQ.-9999.0)THEN
11158            IF(AUPPLM.GT.STATMX)STATMX=AUPPLM
11159          ELSE
11160            IF(AUPPLM.GT.PFLUCL)AUPPLM=PFLUCL
11161          ENDIF
11162          IF(PFLUFL.EQ.-9999.0)THEN
11163            IF(ALOWLM.LT.STATMN)STATMN=ALOWLM
11164          ELSE
11165            IF(ALOWLM.LT.PFLUFL)ALOWLM=PFLUFL
11166          ENDIF
11167          XACLOW(J)=ALOWLM
11168          XACUPP(J)=AUPPLM
11169        ENDIF
11170C
11171 1110 CONTINUE
11172      N2=J
11173C
11174      IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'BRAT')THEN
11175        STATMN=0.0
11176        STATMX=1.0
11177      ELSEIF(ICASCT.EQ.'DBPR')THEN
11178        STATMN=-1.0
11179        STATMX=1.0
11180      ELSEIF(ICASCT.EQ.'COUN')THEN
11181        STATMN=0.0
11182      ENDIF
11183C
11184C               *****************************
11185C               **   STEP 6--              **
11186C               **   WRITE OUT THE TABLE   **
11187C               *****************************
11188C
11189      ISTEPN='6'
11190      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'FLU0')
11191     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11192C
11193C               ******************
11194C               **   STEP 90--  **
11195C               **   EXIT       **
11196C               ******************
11197C
11198 9000 CONTINUE
11199      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'FLU0')THEN
11200        WRITE(ICOUT,999)
11201  999   FORMAT(1X)
11202        CALL DPWRST('XXX','BUG ')
11203        WRITE(ICOUT,9011)
11204 9011   FORMAT('***** AT THE END       OF DPFLU0--')
11205        CALL DPWRST('XXX','BUG ')
11206        WRITE(ICOUT,9012)ICASCT,N,NUMSE1,N2,IERROR
11207 9012   FORMAT('ICASCT,N,NUMSE1,N2,IERROR = ',A4,3I8,2X,A4)
11208        CALL DPWRST('XXX','BUG ')
11209        WRITE(ICOUT,9013)NUMV2
11210 9013   FORMAT('NUMV2 = ',I8)
11211        CALL DPWRST('XXX','BUG ')
11212        DO9020I=1,N2
11213          WRITE(ICOUT,9021)I,Y2(I),X2(I)
11214 9021     FORMAT('I,Y2(I),X2(I) = ',I8,2G15.7)
11215          CALL DPWRST('XXX','BUG ')
11216 9020   CONTINUE
11217      ENDIF
11218C
11219      RETURN
11220      END
11221      SUBROUTINE DPFLU3(Y,Z,Z2,TAG1,TAG2,N,
11222     1                  NUMV2,ICASCT,
11223     1                  XIDTEM,XIDTE2,
11224     1                  NUMSE1,NUMSE2,
11225     1                  TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,
11226     1                  ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
11227     1                  DTEMP1,DTEMP2,DTEMP3,
11228     1                  ICASE,XMAT,MAXLEV,NROW,NCOL,
11229     1                  ISEED,IQUASE,IBINME,IBI2ME,ALPHA,
11230     1                  IXVAR,IX2VAR,IYVAR,
11231     1                  STATMN,STATMX,PSIZE,NMAX,XACLOW,XACUPP,
11232     1                  MAXOBV,PFLUFL,PFLUCL,IFLUUN,
11233     1                  ICTAMV,PCTAMV,PSTAMV,
11234     1                  Y2,X2,D2,N2,ISUBRO,IBUGG3,IERROR)
11235C
11236C     PURPOSE--GENERATE A TWO-WAY FLUCUATION PLOT.
11237C     WRITTEN BY--ALAN HECKERT
11238C                 STATISTICAL ENGINEERING DIVISION
11239C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
11240C                 GAITHERSBURG, MD 20899-8980
11241C                 PHONE--301-975-2899
11242C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
11243C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
11244C     REFERENCE--UNWIN, THEUS, AND HOFMANN (2006), "GRAPHICS OF
11245C                LARGE DATA SETS: VISUALIZING A MILLION",
11246C     LANGUAGE--ANSI FORTRAN (1977)
11247C     VERSION NUMBER--2008/5
11248C     ORIGINAL VERSION--MAY       2008.
11249C     UPDATED         --JANUARY   2009. SUPPORT CASE FOR TABLE INPUT
11250C                                       (THIS IS RESTRICTED TO THE
11251C                                       CASE WITH TWO CLASSICATION
11252C                                       VARIABLES--INPUT TABLE CONTAINS
11253C                                       PREVIOUSLY CROSS-TABULATED
11254C                                       VALUES)
11255C     UPDATED         --SEPTEMBER 2009. UNCERTAINTY INTERVALS FOR
11256C                                       BINOMIAL PROPORTION,
11257C                                       MEAN/MEDIAN CONFIDENCE LIMITS
11258C     UPDATED         --JANUARY   2010. UNCERTAINTY INTERVALS FOR
11259C                                       BINOMIAL RATIO
11260C     UPDATED         --NOVEMBER  2017. DIFFERENCE OF MEAN AND
11261C                                       DIFFERENCE OF BINOMIAL
11262C                                       PROPORTIONS SUPPORT UNCERTAINTY
11263C                                       INTERVALS
11264C
11265C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
11266C
11267      CHARACTER*4 ICASCT
11268      CHARACTER*4 ICASE
11269      CHARACTER*4 IXVAR
11270      CHARACTER*4 IX2VAR
11271      CHARACTER*4 IYVAR
11272      CHARACTER*4 IQUASE
11273      CHARACTER*4 IBINME
11274      CHARACTER*4 IBI2ME
11275      CHARACTER*4 ICTAMV
11276      CHARACTER*4 IFLUUN
11277      CHARACTER*4 ICAPSW
11278      CHARACTER*4 ICAPTY
11279      CHARACTER*4 IFORSW
11280      CHARACTER*4 IBUGG3
11281      CHARACTER*4 IERROR
11282C
11283      CHARACTER*4 ISUBRO
11284      CHARACTER*4 IWRITE
11285      CHARACTER*4 IDIR
11286      CHARACTER*4 ISUBN1
11287      CHARACTER*4 ISUBN2
11288      CHARACTER*4 ISTEPN
11289C
11290C---------------------------------------------------------------------
11291C
11292      DIMENSION Y(*)
11293      DIMENSION Z(*)
11294      DIMENSION Z2(*)
11295      DIMENSION XIDTEM(*)
11296      DIMENSION XIDTE2(*)
11297      DIMENSION Y2(*)
11298      DIMENSION X2(*)
11299      DIMENSION D2(*)
11300C
11301      DIMENSION PSIZE(*)
11302C
11303      DIMENSION TAG1(*)
11304      DIMENSION TAG2(*)
11305      DIMENSION TEMP(*)
11306      DIMENSION TEMPZ(*)
11307      DIMENSION TEMPZ2(*)
11308      DIMENSION XTEMP1(*)
11309      DIMENSION XTEMP2(*)
11310      DIMENSION XTEMP3(*)
11311C
11312      DIMENSION XACLOW(*)
11313      DIMENSION XACUPP(*)
11314C
11315      INTEGER ITEMP1(*)
11316      INTEGER ITEMP2(*)
11317      INTEGER ITEMP3(*)
11318      INTEGER ITEMP4(*)
11319      INTEGER ITEMP5(*)
11320      INTEGER ITEMP6(*)
11321C
11322      DOUBLE PRECISION DTEMP1(*)
11323      DOUBLE PRECISION DTEMP2(*)
11324      DOUBLE PRECISION DTEMP3(*)
11325C
11326      DIMENSION XMAT(MAXLEV,MAXLEV)
11327C
11328C---------------------------------------------------------------------
11329C
11330      INCLUDE 'DPCOP2.INC'
11331C
11332C-----START POINT-----------------------------------------------------
11333C
11334      ISUBN1='DPFL'
11335      ISUBN2='U3  '
11336C
11337      IF(ICASE.EQ.'TABL')GOTO2000
11338      I2=0
11339      AN=INT(N+0.01)
11340C
11341C               ***********************************************
11342C               **  STEP 5--                                 **
11343C               **  COMPUTE THE VARIOUS CROSS-TAB STATISTICS **
11344C               ***********************************************
11345C
11346      ISTEPN='5.1'
11347      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'FLU3')THEN
11348        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11349        WRITE(ICOUT,999)
11350  999   FORMAT(1X)
11351        CALL DPWRST('XXX','BUG ')
11352        WRITE(ICOUT,51)
11353   51   FORMAT('***** AT THE BEGINNING OF DPFLU3--')
11354        CALL DPWRST('XXX','BUG ')
11355        WRITE(ICOUT,52)ICASCT,ICAPTY,ICAPSW,IFORSW,IERROR
11356   52   FORMAT('ICASCT,ICAPTY,ICAPSW,IFORSW,IERROR = ',4(A4,2X),A4)
11357        CALL DPWRST('XXX','BUG ')
11358        WRITE(ICOUT,53)N,NUMSE1,N2,MAXOBV
11359   53   FORMAT('N,NUMSE1,N2,MAXOBV = ',4I8)
11360        CALL DPWRST('XXX','BUG ')
11361        WRITE(ICOUT,55)NUMSE1,NUMSE2,NUMV2
11362   55   FORMAT('NUMSE1,NUMSE2,NUMV2 = ',4I8)
11363        CALL DPWRST('XXX','BUG ')
11364        DO56I=1,N
11365          WRITE(ICOUT,57)I,Y(I),Z(I),TAG1(I),TAG2(I)
11366   57     FORMAT('I,Y(I),Z(I),TAG1(I),TAG2(I) = ',I8,4G15.7)
11367          CALL DPWRST('XXX','BUG ')
11368   56   CONTINUE
11369      ENDIF
11370C
11371      IWRITE='OFF'
11372C
11373      STATMN=CPUMAX
11374      IF(ICASCT.EQ.'NUMB')STATMN=0.0
11375      STATMX=CPUMIN
11376      IF(PFLUCL.NE.-9999.0)STATMX=PFLUCL
11377      IF(PFLUFL.NE.-9999.0)STATMN=PFLUFL
11378      NMAX=0
11379      J=0
11380      NRESP=NUMV2-2
11381      DO1110ISET1=1,NUMSE1
11382        DO1120ISET2=1,NUMSE2
11383C
11384          K=0
11385          DO1130I=1,N
11386            IF(XIDTEM(ISET1).EQ.TAG1(I).AND.XIDTE2(ISET2).EQ.TAG2(I))
11387     1        GOTO1131
11388            GOTO1130
11389 1131       CONTINUE
11390C
11391            K=K+1
11392            IF(IYVAR.EQ.'OFF')THEN
11393              TEMP(K)=0.0
11394            ELSE
11395              TEMP(K)=Y(I)
11396              IF(IXVAR.EQ.'ON')TEMPZ(K)=Z(I)
11397              IF(IX2VAR.EQ.'ON')TEMPZ2(K)=Z2(I)
11398            ENDIF
11399 1130     CONTINUE
11400          NTEMP=K
11401C
11402          NTRIAL=0
11403          ALOWLM=0.0
11404          AUPPLM=0.0
11405          IF(NTEMP.EQ.0)THEN
11406            IF(ICTAMV.EQ.'ZERO')THEN
11407              STAT=0.0
11408              IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
11409     1           ICASCT.EQ.'DMEA' .OR. ICASCT.EQ.'DBPR' .OR.
11410     1           ICASCT.EQ.'MDCL' .OR. ICASCT.EQ.'BRAT')THEN
11411                NTRIAL=0
11412                ALOWLM=0.0
11413                AUPPLM=0.0
11414              ENDIF
11415            ELSEIF(ICTAMV.EQ.'MV  ')THEN
11416              STAT=PCTAMV
11417              IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
11418     1           ICASCT.EQ.'DMEA' .OR. ICASCT.EQ.'DBPR' .OR.
11419     1           ICASCT.EQ.'MDCL' .OR. ICASCT.EQ.'BRAT')THEN
11420                NTRIAL=0
11421                ALOWLM=PCTAMV
11422                AUPPLM=PCTAMV
11423              ENDIF
11424            ELSE
11425              GOTO1120
11426            ENDIF
11427          ELSE
11428            CALL CMPSTA(
11429     1              TEMP,TEMPZ,TEMPZ,XTEMP1,XTEMP2,XTEMP3,
11430     1              MAXNXT,NTEMP,NTEMP,NTEMP,
11431     1              NRESP,ICASCT,
11432     1              ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
11433     1              DTEMP1,DTEMP2,DTEMP3,
11434CCCCC1              IQUAME,IQUASE,PSTAMV,
11435     1              STAT,
11436     1              ISUBRO,IBUGG3,IERROR)
11437            IF(IERROR.EQ.'YES')GOTO9000
11438            IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'BRAT')THEN
11439              PTEMP=STAT
11440              NTRIAL=NTEMP
11441              IF(ICASCT.EQ.'BRAT')NTRIAL=ITEMP1(1)
11442              IF(STAT.EQ.PSTAMV)THEN
11443                ALOWLM=PSTAMV
11444                AUPPLM=PSTAMV
11445              ELSE
11446                ALPHAT=ALPHA
11447                IF(ALPHAT.LE.0.5)ALPHAT=1.0 - ALPHA
11448                IF(IFLUUN.EQ.'LOWE')THEN
11449                  IDIR='LOWE'
11450                  CALL DPAGC1(PTEMP,NTRIAL,ALPHAT,IDIR,IWRITE,
11451     1                        ALOWLM,IBUGG3,IERROR)
11452                  AUPPLM=STAT
11453                ELSEIF(IFLUUN.EQ.'UPPE')THEN
11454                  IDIR='UPPE'
11455                  CALL DPAGC1(PTEMP,NTRIAL,ALPHAT,IDIR,IWRITE,
11456     1                        AUPPLM,IBUGG3,IERROR)
11457                  ALOWLM=STAT
11458                ELSE
11459                  IF(ICASCT.EQ.'BPRO')THEN
11460                    CALL DPPRC3(TEMP,NTEMP,ALPHAT,PSTAMV,IBINME,TEMPZ2,
11461     1                          PTEMP2,ALOWLM,AUPPLM,
11462     1                          ISUBRO,IBUGG3,IERROR)
11463                  ELSEIF(ICASCT.EQ.'BRAT')THEN
11464                    CALL DPAGCO(PTEMP,NTRIAL,ALPHAT,IWRITE,
11465     1                          ALOWLM,AUPPLM,IBUGG3,IERROR)
11466                  ENDIF
11467                ENDIF
11468              ENDIF
11469            ELSEIF(ICASCT.EQ.'MECL')THEN
11470              XMEAN=STAT
11471              NTRIAL=NTEMP
11472              IF(STAT.EQ.PSTAMV)THEN
11473                ALOWLM=PSTAMV
11474                AUPPLM=PSTAMV
11475              ELSE
11476                CALL SD(TEMP,NTEMP,IWRITE,XSD,IBUGG3,IERROR)
11477                ALPHAT=ALPHA
11478                CALL DPMECL(XMEAN,XSD,NTEMP,ALPHAT,IWRITE,
11479     1                      ALOWLM,AUPPLM,IBUGG3,IERROR)
11480              ENDIF
11481            ELSEIF(ICASCT.EQ.'MDCL')THEN
11482              XMED=STAT
11483              NTRIAL=NTEMP
11484              IF(STAT.EQ.PSTAMV)THEN
11485                ALOWLM=PSTAMV
11486                AUPPLM=PSTAMV
11487              ELSE
11488                XQ=0.5
11489                CALL QUANSE(XQ,TEMP,NTEMP,IWRITE,XTEMP1,MAXNXT,IQUASE,
11490     1                      QUASE,IBUGG3,IERROR)
11491                ALPHAT=ALPHA
11492                CALL DPMECL(XMED,QUASE,NTEMP,ALPHAT,IWRITE,
11493     1                      ALOWLM,AUPPLM,IBUGG3,IERROR)
11494              ENDIF
11495            ELSEIF(ICASCT.EQ.'DMEA')THEN
11496              XDIFF=STAT
11497              NTRIAL=NTEMP
11498              IF(STAT.EQ.PSTAMV)THEN
11499                ALOWLM=PSTAMV
11500                AUPPLM=PSTAMV
11501              ELSE
11502                ALPHAT=ALPHA
11503                ALP=ALPHA
11504                IF(ALP.LT.0.5)THEN
11505                  ALPHAT=1.0-(ALP/2.0)
11506                ELSE
11507                  ALP=1.0 - ALPHA
11508                  ALPHAT=1.0-(ALP/2.0)
11509                ENDIF
11510                AN=REAL(NTEMP)
11511                CALL MEAN(TEMP,NTEMP,IWRITE,XMEAN1,IBUGG3,IERROR)
11512                CALL SD(TEMP,NTEMP,IWRITE,XSD1,IBUGG3,IERROR)
11513                AVAL1=XSD1**2/AN
11514                CALL MEAN(TEMPZ,NTEMP,IWRITE,XMEAN2,IBUGG3,IERROR)
11515                CALL SD(TEMPZ,NTEMP,IWRITE,XSD2,IBUGG3,IERROR)
11516                AVAL2=XSD2**2/AN
11517                XSTERR=SQRT(AVAL1 + AVAL2)
11518                TERM1=(AVAL1 + AVAL2)**2
11519                TERM2=AVAL1*AVAL1/(AN-1.0) + AVAL2*AVAL2/(AN-1.0)
11520                V=TERM1/TERM2
11521                IV=INT(V+0.5)
11522                CALL TCDF(ALPHAT,REAL(IV),TCV)
11523                ALOWLM=XDIFF - TCV*XSTERR
11524                AUPPLM=XDIFF + TCV*XSTERR
11525              ENDIF
11526            ELSEIF(ICASCT.EQ.'DBPR')THEN
11527              IF(STAT.EQ.PSTAMV)THEN
11528                ALOWLM=PSTAMV
11529                AUPPLM=PSTAMV
11530              ELSE
11531                ALPHAT=ALPHA
11532                ALP=ALPHA
11533                IF(ALP.LT.0.5)THEN
11534                  ALPHAT=1.0-(ALP/2.0)
11535                ELSE
11536                  ALP=1.0 - ALPHA
11537                  ALPHAT=1.0-(ALP/2.0)
11538                ENDIF
11539                CALL DPPRC4(TEMP,NTEMP,TEMPZ,NTEMP,ALPHAT,PSTAMV,
11540     1                      IBI2ME,TEMPZ2,
11541     1                      XDIFF,ALOWLM,AUPPLM,
11542     1                      ISUBRO,IBUGG3,IERROR)
11543              ENDIF
11544            ENDIF
11545          ENDIF
11546C
11547          J=J+1
11548          IF(PFLUCL.EQ.-9999.0)THEN
11549            IF(STAT.GT.STATMX)STATMX=STAT
11550          ELSE
11551            IF(STAT.GT.PFLUCL)STAT=PFLUCL
11552          ENDIF
11553          IF(PFLUFL.EQ.-9999.0)THEN
11554            IF(STAT.LT.STATMN)STATMN=STAT
11555          ELSE
11556            IF(STAT.LT.PFLUFL)STAT=PFLUFL
11557          ENDIF
11558          IF(NTEMP.GT.NMAX)NMAX=NTEMP
11559          PSIZE(J)=REAL(NTEMP)
11560C
11561          Y2(J)=STAT
11562          X2(J)=XIDTEM(ISET1)
11563          D2(J)=XIDTE2(ISET2)
11564          IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
11565     1       ICASCT.EQ.'DMEA' .OR. ICASCT.EQ.'DBPR' .OR.
11566     1       ICASCT.EQ.'MDCL' .OR. ICASCT.EQ.'BRAT' .AND.
11567     1       IFLUUN.NE.'OFF')THEN
11568            IF(PFLUCL.EQ.-9999.0)THEN
11569              IF(AUPPLM.GT.STATMX)STATMX=AUPPLM
11570            ELSE
11571              IF(AUPPLM.GT.PFLUCL)AUPPLM=PFLUCL
11572            ENDIF
11573            IF(PFLUFL.EQ.-9999.0)THEN
11574              IF(ALOWLM.LT.STATMN)STATMN=ALOWLM
11575            ELSE
11576              IF(ALOWLM.LT.PFLUFL)ALOWLM=PFLUFL
11577            ENDIF
11578            XACLOW(J)=ALOWLM
11579            XACUPP(J)=AUPPLM
11580          ENDIF
11581C
11582 1120   CONTINUE
11583 1110 CONTINUE
11584      N2=J
11585C
11586      IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'BRAT')THEN
11587        STATMN=0.0
11588        STATMX=1.0
11589      ELSEIF(ICASCT.EQ.'DBPR')THEN
11590        STATMN=-1.0
11591        STATMX=1.0
11592      ELSEIF(ICASCT.EQ.'COUN')THEN
11593        STATMN=0.0
11594      ENDIF
11595C
11596      GOTO3999
11597C
11598 2000 CONTINUE
11599C
11600      ISTEPN='6.1'
11601      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'FLU3')
11602     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11603C
11604      STATMN=CPUMAX
11605      IF(ICASCT.EQ.'NUMB')STATMN=0.0
11606      STATMX=CPUMIN
11607      IF(PFLUCL.NE.-9999.0)STATMX=PFLUCL
11608      IF(PFLUFL.NE.-9999.0)STATMN=PFLUFL
11609C
11610      ICNT=0
11611      DO2010I=1,NROW
11612        DO2020J=1,NCOL
11613C
11614C         2016/09: DON'T ASSUME INTEGER.  FOR EXAMPLE, WE MAY WANT A
11615C                  CORRELATION MATRIX (AS OPPOSSED TO A COUNT).
11616C
11617CCCCC     IJUNK=INT(XMAT(I,J)+0.5)
11618C
11619CCCCC     STAT=REAL(IJUNK)
11620          STAT=XMAT(I,J)
11621          IF(PFLUCL.EQ.-9999.0)THEN
11622            IF(STAT.GT.STATMX)STATMX=STAT
11623          ELSE
11624            IF(STAT.GT.PFLUCL)STAT=PFLUCL
11625          ENDIF
11626          IF(PFLUFL.EQ.-9999.0)THEN
11627            IF(STAT.LT.STATMN)STATMN=STAT
11628          ELSE
11629            IF(STAT.LT.PFLUFL)STAT=PFLUFL
11630          ENDIF
11631C
11632          ICNT=ICNT+1
11633          Y2(ICNT)=STAT
11634          X2(ICNT)=REAL(I)
11635          D2(ICNT)=REAL(J)
11636 2020   CONTINUE
11637 2010 CONTINUE
11638      N2=ICNT
11639C
11640      GOTO3999
11641C
11642 3999 CONTINUE
11643C
11644C               *****************************
11645C               **   STEP 6--              **
11646C               **   WRITE OUT THE TABLE   **
11647C               *****************************
11648C
11649      ISTEPN='6'
11650      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'FLU3')
11651     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11652C
11653C               ******************
11654C               **   STEP 90--  **
11655C               **   EXIT       **
11656C               ******************
11657C
11658 9000 CONTINUE
11659      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'FLU3')THEN
11660        WRITE(ICOUT,999)
11661        CALL DPWRST('XXX','BUG ')
11662        WRITE(ICOUT,9011)
11663 9011   FORMAT('***** AT THE END       OF DPFLU3--')
11664        CALL DPWRST('XXX','BUG ')
11665        WRITE(ICOUT,9016)STATMN,STATMX,N2
11666 9016   FORMAT('STATMN,STATMX,N2 = ',2G15.7,I8)
11667        CALL DPWRST('XXX','BUG ')
11668        DO9020I=1,N2
11669          WRITE(ICOUT,9021)I,Y2(I),X2(I),D2(I)
11670 9021     FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,3G15.7)
11671          CALL DPWRST('XXX','BUG ')
11672 9020   CONTINUE
11673      ENDIF
11674C
11675      RETURN
11676      END
11677      SUBROUTINE DPFLU4(Y,Z,Z2,TAG1,TAG2,TAG3,N,
11678     1                  NUMV2,ICASCT,
11679     1                  XIDTEM,XIDTE2,XIDTE3,
11680     1                  NUMSE1,NUMSE2,NUMSE3,
11681     1                  TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,
11682     1                  ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
11683     1                  DTEMP1,DTEMP2,DTEMP3,
11684     1                  ISEED,IQUASE,IBINME,IBI2ME,ALPHA,
11685     1                  IXVAR,IX2VAR,IYVAR,
11686     1                  STATMN,STATMX,PSIZE,NMAX,XACLOW,XACUPP,
11687     1                  MAXOBV,PFLUFL,PFLUCL,IFLUUN,ICTAMV,
11688     1                  PCTAMV,PSTAMV,
11689     1                  Y2,X2,D2,D3,N2,ISUBRO,IBUGG3,IERROR)
11690C
11691C     PURPOSE--GENERATE A THREE-WAY FLUCUATION PLOT.
11692C     WRITTEN BY--ALAN HECKERT
11693C                 STATISTICAL ENGINEERING DIVISION
11694C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
11695C                 GAITHERSBURG, MD 20899-8980
11696C                 PHONE--301-975-2899
11697C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
11698C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
11699C     REFERENCE--UNWIN, THEUS, AND HOFMANN (2006), "GRAPHICS OF
11700C                LARGE DATA SETS: VISUALIZING A MILLION",
11701C                SPRINGER.
11702C     LANGUAGE--ANSI FORTRAN (1977)
11703C     VERSION NUMBER--2008/5
11704C     ORIGINAL VERSION--MAY       2008.
11705C     UPDATED         --SEPTEMBER 2009. UNCERTAINTY INTERVALS FOR
11706C                                       BINOMIAL PROPORTION,
11707C                                       MEAN/MEDIAN CONFIDENCE LIMITS
11708C     UPDATED         --JANUARY   2010. SUPPORT FOR UNCERTAINTY INTERVALS
11709C                                       FOR BINOMIAL RATIO
11710C     UPDATED         --NOVEMBER  2017. DIFFERENCE OF MEAN AND
11711C                                       DIFFERENCE OF BINOMIAL
11712C                                       PROPORTIONS SUPPORT UNCERTAINTY
11713C                                       INTERVALS
11714C
11715C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
11716C
11717      CHARACTER*4 ICASCT
11718      CHARACTER*4 IXVAR
11719      CHARACTER*4 IX2VAR
11720      CHARACTER*4 IYVAR
11721      CHARACTER*4 IQUASE
11722      CHARACTER*4 IBINME
11723      CHARACTER*4 IBI2ME
11724      CHARACTER*4 ICTAMV
11725      CHARACTER*4 IFLUUN
11726      CHARACTER*4 ICAPSW
11727      CHARACTER*4 ICAPTY
11728      CHARACTER*4 IFORSW
11729      CHARACTER*4 IBUGG3
11730      CHARACTER*4 IERROR
11731C
11732      CHARACTER*4 ISUBRO
11733      CHARACTER*4 IWRITE
11734      CHARACTER*4 IDIR
11735      CHARACTER*4 ISUBN1
11736      CHARACTER*4 ISUBN2
11737      CHARACTER*4 ISTEPN
11738C
11739C---------------------------------------------------------------------
11740C
11741      DIMENSION Y(*)
11742      DIMENSION Z(*)
11743      DIMENSION Z2(*)
11744      DIMENSION XIDTEM(*)
11745      DIMENSION XIDTE2(*)
11746      DIMENSION XIDTE3(*)
11747      DIMENSION Y2(*)
11748      DIMENSION X2(*)
11749      DIMENSION D2(*)
11750      DIMENSION D3(*)
11751C
11752      DIMENSION PSIZE(*)
11753C
11754      DIMENSION TAG1(*)
11755      DIMENSION TAG2(*)
11756      DIMENSION TAG3(*)
11757      DIMENSION TEMP(*)
11758      DIMENSION TEMPZ(*)
11759      DIMENSION TEMPZ2(*)
11760      DIMENSION XTEMP1(*)
11761      DIMENSION XTEMP2(*)
11762      DIMENSION XTEMP3(*)
11763C
11764      DIMENSION XACLOW(*)
11765      DIMENSION XACUPP(*)
11766C
11767      INTEGER ITEMP1(*)
11768      INTEGER ITEMP2(*)
11769      INTEGER ITEMP3(*)
11770      INTEGER ITEMP4(*)
11771      INTEGER ITEMP5(*)
11772      INTEGER ITEMP6(*)
11773C
11774      DOUBLE PRECISION DTEMP1(*)
11775      DOUBLE PRECISION DTEMP2(*)
11776      DOUBLE PRECISION DTEMP3(*)
11777C
11778C---------------------------------------------------------------------
11779C
11780      INCLUDE 'DPCOP2.INC'
11781C
11782C-----START POINT-----------------------------------------------------
11783C
11784      ISUBN1='DPFL'
11785      ISUBN2='U4  '
11786C
11787      I2=0
11788C
11789      AN=INT(N+0.01)
11790C
11791      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'FLU4')THEN
11792        WRITE(ICOUT,999)
11793        CALL DPWRST('XXX','BUG ')
11794        WRITE(ICOUT,11)
11795   11   FORMAT('***** AT THE BEGINNING OF DPFLU5--')
11796        CALL DPWRST('XXX','BUG ')
11797        WRITE(ICOUT,12)ICASCT,ICAPSW,ICAPTY,IFORSW
11798   12   FORMAT('ICASCT,ICAPSW,ICAPTY,IFORSW,N,NUMV2 = ',3(A4,2X),A4)
11799        CALL DPWRST('XXX','BUG ')
11800        WRITE(ICOUT,13)N,NUMV2,MAXOBV
11801   13   FORMAT('N,NUMV2,MAXOBV = ',3I8)
11802        CALL DPWRST('XXX','BUG ')
11803        WRITE(ICOUT,15)NUMSE1,NUMSE2,NUMSE3
11804   15   FORMAT('NUMSE1,NUMSE2,NUMSE3 = ',3I8)
11805        CALL DPWRST('XXX','BUG ')
11806      ENDIF
11807C
11808C               ***********************************************
11809C               **  STEP 5--                                 **
11810C               **  COMPUTE THE VARIOUS CROSS-TAB STATISTICS **
11811C               ***********************************************
11812C
11813      ISTEPN='5.1'
11814      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'FLU4')
11815     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11816C
11817      IWRITE='OFF'
11818C
11819      STATMN=CPUMAX
11820      IF(ICASCT.EQ.'NUMB')STATMN=0.0
11821      STATMX=CPUMIN
11822      IF(PFLUCL.NE.-9999.0)STATMX=PFLUCL
11823      IF(PFLUFL.NE.-9999.0)STATMN=PFLUFL
11824      NMAX=0
11825      J=0
11826      NRESP=NUMV2-3
11827      DO1110ISET1=1,NUMSE1
11828        DO1120ISET2=1,NUMSE2
11829        DO1130ISET3=1,NUMSE3
11830C
11831          K=0
11832          DO1180I=1,N
11833            IF(XIDTEM(ISET1).EQ.TAG1(I).AND.
11834     1         XIDTE2(ISET2).EQ.TAG2(I).AND.
11835     1         XIDTE3(ISET3).EQ.TAG3(I))
11836     1        GOTO1181
11837            GOTO1180
11838 1181       CONTINUE
11839C
11840            K=K+1
11841            IF(IYVAR.EQ.'OFF')THEN
11842              TEMP(K)=0.0
11843            ELSE
11844              TEMP(K)=Y(I)
11845              IF(IXVAR.EQ.'ON')TEMPZ(K)=Z(I)
11846              IF(IX2VAR.EQ.'ON')TEMPZ2(K)=Z2(I)
11847            ENDIF
11848 1180     CONTINUE
11849          NTEMP=K
11850C
11851          NTRIAL=0
11852          ALOWLM=0.0
11853          AUPPLM=0.0
11854          IF(NTEMP.EQ.0)THEN
11855            IF(ICTAMV.EQ.'ZERO')THEN
11856              STAT=0.0
11857              IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
11858     1           ICASCT.EQ.'DMEA' .OR. ICASCT.EQ.'DBPR' .OR.
11859     1           ICASCT.EQ.'MDCL' .OR. ICASCT.EQ.'BRAT')THEN
11860                NTRIAL=0
11861                ALOWLM=0.0
11862                AUPPLM=0.0
11863              ENDIF
11864            ELSEIF(ICTAMV.EQ.'MV  ')THEN
11865              STAT=PCTAMV
11866              IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
11867     1           ICASCT.EQ.'DMEA' .OR. ICASCT.EQ.'DBPR' .OR.
11868     1           ICASCT.EQ.'MDCL' .OR. ICASCT.EQ.'BRAT')THEN
11869                NTRIAL=0
11870                ALOWLM=PCTAMV
11871                AUPPLM=PCTAMV
11872              ENDIF
11873            ELSE
11874              GOTO1130
11875            ENDIF
11876          ELSE
11877            CALL CMPSTA(
11878     1              TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,
11879     1              MAXNXT,NTEMP,NTEMP,NTEMP,
11880     1              NRESP,ICASCT,
11881     1              ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
11882     1              DTEMP1,DTEMP2,DTEMP3,
11883CCCCC1              IQUAME,IQUASE,PSTAMV,
11884     1              STAT,
11885     1              ISUBRO,IBUGG3,IERROR)
11886            IF(IERROR.EQ.'YES')GOTO9000
11887            IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'BRAT')THEN
11888              PTEMP=STAT
11889              NTRIAL=NTEMP
11890              IF(ICASCT.EQ.'BRAT')NTRIAL=ITEMP1(1)
11891              IF(STAT.EQ.PSTAMV)THEN
11892                ALOWLM=PSTAMV
11893                AUPPLM=PSTAMV
11894              ELSE
11895                ALPHAT=ALPHA
11896                IF(ALPHAT.LE.0.5)ALPHAT=1.0 - ALPHA
11897                IF(IFLUUN.EQ.'LOWE')THEN
11898                  IDIR='LOWE'
11899                  CALL DPAGC1(PTEMP,NTRIAL,ALPHAT,IDIR,IWRITE,
11900     1                        ALOWLM,IBUGG3,IERROR)
11901                  AUPPLM=STAT
11902                ELSEIF(IFLUUN.EQ.'UPPE')THEN
11903                  IDIR='UPPE'
11904                  CALL DPAGC1(PTEMP,NTRIAL,ALPHAT,IDIR,IWRITE,
11905     1                        AUPPLM,IBUGG3,IERROR)
11906                  ALOWLM=STAT
11907                ELSE
11908                  IF(ICASCT.EQ.'BPRO')THEN
11909                    CALL DPPRC3(TEMP,NTEMP,ALPHAT,PSTAMV,IBINME,TEMPZ2,
11910     1                          PTEMP2,ALOWLM,AUPPLM,
11911     1                          ISUBRO,IBUGG3,IERROR)
11912                  ELSEIF(ICASCT.EQ.'BRAT')THEN
11913                    CALL DPAGCO(PTEMP,NTRIAL,ALPHAT,IWRITE,
11914     1                          ALOWLM,AUPPLM,IBUGG3,IERROR)
11915                  ENDIF
11916                ENDIF
11917              ENDIF
11918            ELSEIF(ICASCT.EQ.'MECL')THEN
11919              XMEAN=STAT
11920              NTRIAL=NTEMP
11921              IF(STAT.EQ.PSTAMV)THEN
11922                ALOWLM=PSTAMV
11923                AUPPLM=PSTAMV
11924              ELSE
11925                CALL SD(TEMP,NTEMP,IWRITE,XSD,IBUGG3,IERROR)
11926                ALPHAT=ALPHA
11927                CALL DPMECL(XMEAN,XSD,NTEMP,ALPHAT,IWRITE,
11928     1                      ALOWLM,AUPPLM,IBUGG3,IERROR)
11929              ENDIF
11930            ELSEIF(ICASCT.EQ.'MDCL')THEN
11931              XMED=STAT
11932              NTRIAL=NTEMP
11933              IF(STAT.EQ.PSTAMV)THEN
11934                ALOWLM=PSTAMV
11935                AUPPLM=PSTAMV
11936              ELSE
11937                XQ=0.5
11938                CALL QUANSE(XQ,TEMP,NTEMP,IWRITE,XTEMP1,MAXNXT,IQUASE,
11939     1                      QUASE,IBUGG3,IERROR)
11940                ALPHAT=ALPHA
11941                CALL DPMECL(XMED,QUASE,NTEMP,ALPHAT,IWRITE,
11942     1                      ALOWLM,AUPPLM,IBUGG3,IERROR)
11943              ENDIF
11944            ELSEIF(ICASCT.EQ.'DMEA')THEN
11945              XDIFF=STAT
11946              NTRIAL=NTEMP
11947              IF(STAT.EQ.PSTAMV)THEN
11948                ALOWLM=PSTAMV
11949                AUPPLM=PSTAMV
11950              ELSE
11951                ALPHAT=ALPHA
11952                ALP=ALPHA
11953                IF(ALP.LT.0.5)THEN
11954                  ALPHAT=1.0-(ALP/2.0)
11955                ELSE
11956                  ALP=1.0 - ALPHA
11957                  ALPHAT=1.0-(ALP/2.0)
11958                ENDIF
11959                AN=REAL(NTEMP)
11960                CALL MEAN(TEMP,NTEMP,IWRITE,XMEAN1,IBUGG3,IERROR)
11961                CALL SD(TEMP,NTEMP,IWRITE,XSD1,IBUGG3,IERROR)
11962                AVAL1=XSD1**2/AN
11963                CALL MEAN(TEMPZ,NTEMP,IWRITE,XMEAN2,IBUGG3,IERROR)
11964                CALL SD(TEMPZ,NTEMP,IWRITE,XSD2,IBUGG3,IERROR)
11965                AVAL2=XSD2**2/AN
11966                XSTERR=SQRT(AVAL1 + AVAL2)
11967                TERM1=(AVAL1 + AVAL2)**2
11968                TERM2=AVAL1*AVAL1/(AN-1.0) + AVAL2*AVAL2/(AN-1.0)
11969                V=TERM1/TERM2
11970                IV=INT(V+0.5)
11971                CALL TCDF(ALPHAT,REAL(IV),TCV)
11972                ALOWLM=XDIFF - TCV*XSTERR
11973                AUPPLM=XDIFF + TCV*XSTERR
11974              ENDIF
11975            ELSEIF(ICASCT.EQ.'DBPR')THEN
11976              IF(STAT.EQ.PSTAMV)THEN
11977                ALOWLM=PSTAMV
11978                AUPPLM=PSTAMV
11979              ELSE
11980                ALPHAT=ALPHA
11981                ALP=ALPHA
11982                IF(ALP.LT.0.5)THEN
11983                  ALPHAT=1.0-(ALP/2.0)
11984                ELSE
11985                  ALP=1.0 - ALPHA
11986                  ALPHAT=1.0-(ALP/2.0)
11987                ENDIF
11988                CALL DPPRC4(TEMP,NTEMP,TEMPZ,NTEMP,ALPHAT,PSTAMV,
11989     1                      IBI2ME,TEMPZ2,
11990     1                      XDIFF,ALOWLM,AUPPLM,
11991     1                      ISUBRO,IBUGG3,IERROR)
11992              ENDIF
11993            ENDIF
11994          ENDIF
11995C
11996          J=J+1
11997          IF(PFLUCL.EQ.-9999.0)THEN
11998            IF(STAT.GT.STATMX)STATMX=STAT
11999          ELSE
12000            IF(STAT.GT.PFLUCL)STAT=PFLUCL
12001          ENDIF
12002          IF(PFLUFL.EQ.-9999.0)THEN
12003            IF(STAT.LT.STATMN)STATMN=STAT
12004          ELSE
12005            IF(STAT.LT.PFLUFL)STAT=PFLUFL
12006          ENDIF
12007          IF(NTEMP.GT.NMAX)NMAX=NTEMP
12008          PSIZE(J)=REAL(NTEMP)
12009C
12010          Y2(J)=STAT
12011          X2(J)=XIDTEM(ISET1)
12012          D2(J)=XIDTE2(ISET2)
12013          D3(J)=XIDTE3(ISET3)
12014          IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
12015     1       ICASCT.EQ.'DMEA' .OR. ICASCT.EQ.'DBPR' .OR.
12016     1       ICASCT.EQ.'MDCL' .OR. ICASCT.EQ.'BRAT' .AND.
12017     1       IFLUUN.NE.'OFF')THEN
12018            IF(PFLUCL.EQ.-9999.0)THEN
12019              IF(AUPPLM.GT.STATMX)STATMX=AUPPLM
12020            ELSE
12021              IF(AUPPLM.GT.PFLUCL)AUPPLM=PFLUCL
12022            ENDIF
12023            IF(PFLUFL.EQ.-9999.0)THEN
12024              IF(ALOWLM.LT.STATMN)STATMN=ALOWLM
12025            ELSE
12026              IF(ALOWLM.LT.PFLUFL)ALOWLM=PFLUFL
12027            ENDIF
12028            XACLOW(J)=ALOWLM
12029            XACUPP(J)=AUPPLM
12030          ENDIF
12031C
12032 1130   CONTINUE
12033 1120   CONTINUE
12034 1110 CONTINUE
12035      N2=J
12036C
12037      IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'BRAT')THEN
12038        STATMN=0.0
12039        STATMX=1.0
12040      ELSEIF(ICASCT.EQ.'DBPR')THEN
12041        STATMN=-1.0
12042        STATMX=1.0
12043      ELSEIF(ICASCT.EQ.'COUN')THEN
12044        STATMN=0.0
12045      ENDIF
12046C
12047C               *****************************
12048C               **   STEP 6--              **
12049C               **   WRITE OUT THE TABLE   **
12050C               *****************************
12051C
12052      ISTEPN='6'
12053      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'FLU4')
12054     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12055C
12056C               ******************
12057C               **   STEP 90--  **
12058C               **   EXIT       **
12059C               ******************
12060C
12061 9000 CONTINUE
12062      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'FLU4')THEN
12063        WRITE(ICOUT,999)
12064  999   FORMAT(1X)
12065        CALL DPWRST('XXX','BUG ')
12066        WRITE(ICOUT,9011)
12067 9011   FORMAT('***** AT THE END       OF DPFLU4--')
12068        CALL DPWRST('XXX','BUG ')
12069        WRITE(ICOUT,9012)ICASCT,N,NUMSE1,N2,IERROR
12070 9012   FORMAT('ICASCT,N,NUMSE1,N2,IERROR = ',A4,3I8,2X,A4)
12071        CALL DPWRST('XXX','BUG ')
12072        WRITE(ICOUT,9013)NUMV2
12073 9013   FORMAT('NUMV2 = ',I8)
12074        CALL DPWRST('XXX','BUG ')
12075        WRITE(ICOUT,9015)NUMSE1,NUMSE2,NUMSE3,N2
12076 9015   FORMAT('NUMSE1,NUMSE2,NUMSE3,N2 = ',4I8)
12077        CALL DPWRST('XXX','BUG ')
12078        DO9020I=1,N2
12079          WRITE(ICOUT,9021)I,Y2(I),X2(I),D2(I),D3(I)
12080 9021     FORMAT('I,Y2(I),X2(I),D2(I),D3(I) = ',I8,4G15.7)
12081          CALL DPWRST('XXX','BUG ')
12082 9020   CONTINUE
12083      ENDIF
12084C
12085      RETURN
12086      END
12087      SUBROUTINE DPFLU5(Y,Z,Z2,TAG1,TAG2,TAG3,TAG4,N,
12088     1                  NUMV2,ICASCT,
12089     1                  XIDTEM,XIDTE2,XIDTE3,XIDTE4,
12090     1                  NUMSE1,NUMSE2,NUMSE3,NUMSE4,
12091     1                  TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,
12092     1                  ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
12093     1                  DTEMP1,DTEMP2,DTEMP3,
12094     1                  ISEED,IQUASE,IBINME,IBI2ME,ALPHA,
12095     1                  IXVAR,IX2VAR,IYVAR,
12096     1                  STATMN,STATMX,PSIZE,NMAX,XACLOW,XACUPP,
12097     1                  MAXOBV,PFLUFL,PFLUCL,IFLUUN,
12098     1                  ICTAMV,PCTAMV,PSTAMV,
12099     1                  Y2,X2,D2,D3,D4,N2,ISUBRO,IBUGG3,IERROR)
12100C
12101C     PURPOSE--GENERATE A FOUR-WAY FLUCUATION PLOT.
12102C     WRITTEN BY--ALAN HECKERT
12103C                 STATISTICAL ENGINEERING DIVISION
12104C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
12105C                 GAITHERSBURG, MD 20899-8980
12106C                 PHONE--301-975-2899
12107C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
12108C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
12109C     REFERENCE--UNWIN, THEUS, AND HOFMANN (2006), "GRAPHICS OF
12110C                LARGE DATA SETS: VISUALIZING A MILLION",
12111C                SPRINGER.
12112C     LANGUAGE--ANSI FORTRAN (1977)
12113C     VERSION NUMBER--2008/5
12114C     ORIGINAL VERSION--MAY       2008.
12115C     UPDATED         --SEPTEMBER 2009. SUPPORT FOR UNCERTAINTY
12116C                                       INTERVALS FOR BINOMIAL PROPORTION
12117C                                       AND MEAN/MEDIAN CONFIDENCE
12118C                                       LIMITS
12119C     UPDATED         --JANUARY   2010. SUPPORT FOR UNCERTAINTY INTERVALS
12120C                                       FOR BINOMIAL RATIO
12121C     UPDATED         --NOVEMBER  2017. DIFFERENCE OF MEAN AND
12122C                                       DIFFERENCE OF BINOMIAL
12123C                                       PROPORTIONS SUPPORT UNCERTAINTY
12124C                                       INTERVALS
12125C
12126C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
12127C
12128      CHARACTER*4 ICASCT
12129      CHARACTER*4 IXVAR
12130      CHARACTER*4 IX2VAR
12131      CHARACTER*4 IYVAR
12132      CHARACTER*4 IQUASE
12133      CHARACTER*4 IBINME
12134      CHARACTER*4 IBI2ME
12135      CHARACTER*4 ICTAMV
12136      CHARACTER*4 IFLUUN
12137      CHARACTER*4 ICAPSW
12138      CHARACTER*4 ICAPTY
12139      CHARACTER*4 IFORSW
12140      CHARACTER*4 IBUGG3
12141      CHARACTER*4 IERROR
12142C
12143      CHARACTER*4 ISUBRO
12144      CHARACTER*4 IWRITE
12145      CHARACTER*4 IDIR
12146      CHARACTER*4 ISUBN1
12147      CHARACTER*4 ISUBN2
12148      CHARACTER*4 ISTEPN
12149C
12150C---------------------------------------------------------------------
12151C
12152      DIMENSION Y(*)
12153      DIMENSION Z(*)
12154      DIMENSION Z2(*)
12155      DIMENSION XIDTEM(*)
12156      DIMENSION XIDTE2(*)
12157      DIMENSION XIDTE3(*)
12158      DIMENSION XIDTE4(*)
12159      DIMENSION Y2(*)
12160      DIMENSION X2(*)
12161      DIMENSION D2(*)
12162      DIMENSION D3(*)
12163      DIMENSION D4(*)
12164C
12165      DIMENSION PSIZE(*)
12166C
12167      DIMENSION TAG1(*)
12168      DIMENSION TAG2(*)
12169      DIMENSION TAG3(*)
12170      DIMENSION TAG4(*)
12171      DIMENSION TEMP(*)
12172      DIMENSION TEMPZ(*)
12173      DIMENSION TEMPZ2(*)
12174      DIMENSION XTEMP1(*)
12175      DIMENSION XTEMP2(*)
12176      DIMENSION XTEMP3(*)
12177C
12178      DIMENSION XACLOW(*)
12179      DIMENSION XACUPP(*)
12180C
12181      INTEGER ITEMP1(*)
12182      INTEGER ITEMP2(*)
12183      INTEGER ITEMP3(*)
12184      INTEGER ITEMP4(*)
12185      INTEGER ITEMP5(*)
12186      INTEGER ITEMP6(*)
12187C
12188      DOUBLE PRECISION DTEMP1(*)
12189      DOUBLE PRECISION DTEMP2(*)
12190      DOUBLE PRECISION DTEMP3(*)
12191C
12192C---------------------------------------------------------------------
12193C
12194      INCLUDE 'DPCOP2.INC'
12195C
12196C-----START POINT-----------------------------------------------------
12197C
12198      ISUBN1='DPFL'
12199      ISUBN2='U5  '
12200C
12201      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'FLU5')THEN
12202        WRITE(ICOUT,999)
12203        CALL DPWRST('XXX','BUG ')
12204        WRITE(ICOUT,11)
12205   11   FORMAT('***** AT THE BEGINNING OF DPFLU5--')
12206        CALL DPWRST('XXX','BUG ')
12207        WRITE(ICOUT,12)ICASCT,ICAPSW,ICAPTY,IFORSW
12208   12   FORMAT('ICASCT,ICAPSW,ICAPTY,IFORSW,N,NUMV2 = ',3(A4,2X),A4)
12209        CALL DPWRST('XXX','BUG ')
12210        WRITE(ICOUT,13)N,NUMV2,MAXOBV
12211   13   FORMAT('N,NUMV2,MAXOBV = ',3I8)
12212        CALL DPWRST('XXX','BUG ')
12213        WRITE(ICOUT,15)NUMSE1,NUMSE2,NUMSE3,NUMSE4
12214   15   FORMAT('NUMSE1,NUMSE2,NUMSE3,NUMSE4 = ',4I8)
12215        CALL DPWRST('XXX','BUG ')
12216      ENDIF
12217C
12218      I2=0
12219C
12220      AN=INT(N+0.01)
12221C
12222C               ***********************************************
12223C               **  STEP 5--                                 **
12224C               **  COMPUTE THE VARIOUS CROSS-TAB STATISTICS **
12225C               ***********************************************
12226C
12227      ISTEPN='5.1'
12228      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'FLU5')
12229     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12230C
12231      IWRITE='OFF'
12232C
12233      STATMN=CPUMAX
12234      IF(ICASCT.EQ.'NUMB')STATMN=0.0
12235      STATMX=CPUMIN
12236      J=0
12237      NRESP=NUMV2-4
12238      IF(PFLUCL.NE.-9999.0)STATMX=PFLUCL
12239      IF(PFLUFL.NE.-9999.0)STATMN=PFLUFL
12240      NMAX=0
12241      DO1110ISET1=1,NUMSE1
12242        DO1120ISET2=1,NUMSE2
12243        DO1130ISET3=1,NUMSE3
12244        DO1140ISET4=1,NUMSE4
12245C
12246          IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'FLU5')THEN
12247            WRITE(ICOUT,999)
12248            CALL DPWRST('XXX','BUG ')
12249            WRITE(ICOUT,1011)
12250 1011       FORMAT('***** IN THE MIDDLE OF DPFLU5--')
12251            CALL DPWRST('XXX','BUG ')
12252            WRITE(ICOUT,1013)ISET1,ISET2,ISET3,ISET4
12253 1013       FORMAT('ISET1,ISET2,ISET3,ISET4 = ',4I6)
12254            CALL DPWRST('XXX','BUG ')
12255            WRITE(ICOUT,1014)XIDTEM(ISET1),XIDTE2(ISET2)
12256 1014       FORMAT('XIDTEM(ISET1),XIDTE2(ISET2) = ',2G15.7)
12257            CALL DPWRST('XXX','BUG ')
12258            WRITE(ICOUT,1015)XIDTE3(ISET3),XIDTE4(ISET4)
12259 1015       FORMAT('XIDTE3(ISET3),XIDTE4(ISET4) = ',2G15.7)
12260            CALL DPWRST('XXX','BUG ')
12261          ENDIF
12262C
12263          K=0
12264          DO1180I=1,N
12265            IF(XIDTEM(ISET1).EQ.TAG1(I).AND.
12266     1         XIDTE2(ISET2).EQ.TAG2(I).AND.
12267     1         XIDTE3(ISET3).EQ.TAG3(I).AND.
12268     1         XIDTE4(ISET4).EQ.TAG4(I))
12269     1        GOTO1181
12270            GOTO1180
12271 1181       CONTINUE
12272C
12273            K=K+1
12274            IF(IYVAR.EQ.'OFF')THEN
12275              TEMP(K)=0.0
12276            ELSE
12277              TEMP(K)=Y(I)
12278              IF(IXVAR.EQ.'ON')TEMPZ(K)=Z(I)
12279              IF(IX2VAR.EQ.'ON')TEMPZ2(K)=Z2(I)
12280            ENDIF
12281 1180     CONTINUE
12282          NTEMP=K
12283C
12284          IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'FLU5')THEN
12285            WRITE(ICOUT,1019)NTEMP
12286 1019       FORMAT('NTEMP = ',I8)
12287            CALL DPWRST('XXX','BUG ')
12288          ENDIF
12289C
12290          NTRIAL=0
12291          ALOWLM=0.0
12292          AUPPLM=0.0
12293          IF(NTEMP.EQ.0)THEN
12294            IF(ICTAMV.EQ.'ZERO')THEN
12295              STAT=0.0
12296              IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
12297     1           ICASCT.EQ.'DMEA' .OR. ICASCT.EQ.'DBPR' .OR.
12298     1           ICASCT.EQ.'MDCL' .OR. ICASCT.EQ.'BRAT')THEN
12299                NTRIAL=0
12300                ALOWLM=0.0
12301                AUPPLM=0.0
12302              ENDIF
12303            ELSEIF(ICTAMV.EQ.'MV  ')THEN
12304              STAT=PCTAMV
12305              IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
12306     1           ICASCT.EQ.'DMEA' .OR. ICASCT.EQ.'DBPR' .OR.
12307     1           ICASCT.EQ.'MDCL' .OR. ICASCT.EQ.'BRAT')THEN
12308                NTRIAL=0
12309                ALOWLM=PCTAMV
12310                AUPPLM=PCTAMV
12311              ENDIF
12312            ELSE
12313              GOTO1140
12314            ENDIF
12315          ELSE
12316            CALL CMPSTA(
12317     1              TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,
12318     1              MAXNXT,NTEMP,NTEMP,NTEMP,
12319     1              NRESP,ICASCT,
12320     1              ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
12321     1              DTEMP1,DTEMP2,DTEMP3,
12322CCCCC1              IQUAME,IQUASE,PSTAMV,
12323     1              STAT,
12324     1              ISUBRO,IBUGG3,IERROR)
12325            IF(IERROR.EQ.'YES')GOTO9000
12326            IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'BRAT')THEN
12327              PTEMP=STAT
12328              NTRIAL=NTEMP
12329              IF(ICASCT.EQ.'BRAT')NTRIAL=ITEMP1(1)
12330              IF(STAT.EQ.PSTAMV)THEN
12331                ALOWLM=PSTAMV
12332                AUPPLM=PSTAMV
12333              ELSE
12334                ALPHAT=ALPHA
12335                IF(ALPHAT.LE.0.5)ALPHAT=1.0 - ALPHA
12336                IF(IFLUUN.EQ.'LOWE')THEN
12337                  IDIR='LOWE'
12338                  CALL DPAGC1(PTEMP,NTRIAL,ALPHAT,IDIR,IWRITE,
12339     1                        ALOWLM,IBUGG3,IERROR)
12340                  AUPPLM=STAT
12341                ELSEIF(IFLUUN.EQ.'UPPE')THEN
12342                  IDIR='UPPE'
12343                  CALL DPAGC1(PTEMP,NTRIAL,ALPHAT,IDIR,IWRITE,
12344     1                        AUPPLM,IBUGG3,IERROR)
12345                  ALOWLM=STAT
12346                ELSE
12347                  IF(ICASCT.EQ.'BPRO')THEN
12348                    CALL DPPRC3(TEMP,NTEMP,ALPHAT,PSTAMV,IBINME,TEMPZ2,
12349     1                          PTEMP2,ALOWLM,AUPPLM,
12350     1                          ISUBRO,IBUGG3,IERROR)
12351                  ELSEIF(ICASCT.EQ.'BRAT')THEN
12352                    CALL DPAGCO(PTEMP,NTRIAL,ALPHAT,IWRITE,
12353     1                          ALOWLM,AUPPLM,IBUGG3,IERROR)
12354                  ENDIF
12355                ENDIF
12356              ENDIF
12357            ELSEIF(ICASCT.EQ.'MECL')THEN
12358              XMEAN=STAT
12359              NTRIAL=NTEMP
12360              IF(STAT.EQ.PSTAMV)THEN
12361                ALOWLM=PSTAMV
12362                AUPPLM=PSTAMV
12363              ELSE
12364                CALL SD(TEMP,NTEMP,IWRITE,XSD,IBUGG3,IERROR)
12365                ALPHAT=ALPHA
12366                CALL DPMECL(XMEAN,XSD,NTEMP,ALPHAT,IWRITE,
12367     1                      ALOWLM,AUPPLM,IBUGG3,IERROR)
12368              ENDIF
12369            ELSEIF(ICASCT.EQ.'MDCL')THEN
12370              XMED=STAT
12371              NTRIAL=NTEMP
12372              IF(STAT.EQ.PSTAMV)THEN
12373                ALOWLM=PSTAMV
12374                AUPPLM=PSTAMV
12375              ELSE
12376                XQ=0.5
12377                CALL QUANSE(XQ,TEMP,NTEMP,IWRITE,XTEMP1,MAXNXT,IQUASE,
12378     1                      QUASE,IBUGG3,IERROR)
12379                ALPHAT=ALPHA
12380                CALL DPMECL(XMED,QUASE,NTEMP,ALPHAT,IWRITE,
12381     1                      ALOWLM,AUPPLM,IBUGG3,IERROR)
12382              ENDIF
12383            ELSEIF(ICASCT.EQ.'DMEA')THEN
12384              XDIFF=STAT
12385              NTRIAL=NTEMP
12386              IF(STAT.EQ.PSTAMV)THEN
12387                ALOWLM=PSTAMV
12388                AUPPLM=PSTAMV
12389              ELSE
12390                ALPHAT=ALPHA
12391                ALP=ALPHA
12392                IF(ALP.LT.0.5)THEN
12393                  ALPHAT=1.0-(ALP/2.0)
12394                ELSE
12395                  ALP=1.0 - ALPHA
12396                  ALPHAT=1.0-(ALP/2.0)
12397                ENDIF
12398                AN=REAL(NTEMP)
12399                CALL MEAN(TEMP,NTEMP,IWRITE,XMEAN1,IBUGG3,IERROR)
12400                CALL SD(TEMP,NTEMP,IWRITE,XSD1,IBUGG3,IERROR)
12401                AVAL1=XSD1**2/AN
12402                CALL MEAN(TEMPZ,NTEMP,IWRITE,XMEAN2,IBUGG3,IERROR)
12403                CALL SD(TEMPZ,NTEMP,IWRITE,XSD2,IBUGG3,IERROR)
12404                AVAL2=XSD2**2/AN
12405                XSTERR=SQRT(AVAL1 + AVAL2)
12406                TERM1=(AVAL1 + AVAL2)**2
12407                TERM2=AVAL1*AVAL1/(AN-1.0) + AVAL2*AVAL2/(AN-1.0)
12408                V=TERM1/TERM2
12409                IV=INT(V+0.5)
12410                CALL TCDF(ALPHAT,REAL(IV),TCV)
12411                ALOWLM=XDIFF - TCV*XSTERR
12412                AUPPLM=XDIFF + TCV*XSTERR
12413              ENDIF
12414            ELSEIF(ICASCT.EQ.'DBPR')THEN
12415              IF(STAT.EQ.PSTAMV)THEN
12416                ALOWLM=PSTAMV
12417                AUPPLM=PSTAMV
12418              ELSE
12419                ALPHAT=ALPHA
12420                ALP=ALPHA
12421                IF(ALP.LT.0.5)THEN
12422                  ALPHAT=1.0-(ALP/2.0)
12423                ELSE
12424                  ALP=1.0 - ALPHA
12425                  ALPHAT=1.0-(ALP/2.0)
12426                ENDIF
12427                CALL DPPRC4(TEMP,NTEMP,TEMPZ,NTEMP,ALPHAT,PSTAMV,
12428     1                      IBI2ME,TEMPZ2,
12429     1                      XDIFF,ALOWLM,AUPPLM,
12430     1                      ISUBRO,IBUGG3,IERROR)
12431              ENDIF
12432            ENDIF
12433          ENDIF
12434C
12435          J=J+1
12436          IF(PFLUCL.EQ.-9999.0)THEN
12437            IF(STAT.GT.STATMX)STATMX=STAT
12438          ELSE
12439            IF(STAT.GT.PFLUCL)STAT=PFLUCL
12440          ENDIF
12441          IF(PFLUFL.EQ.-9999.0)THEN
12442            IF(STAT.LT.STATMN)STATMN=STAT
12443          ELSE
12444            IF(STAT.LT.PFLUFL)STAT=PFLUFL
12445          ENDIF
12446          IF(NTEMP.GT.NMAX)NMAX=NTEMP
12447          PSIZE(J)=REAL(NTEMP)
12448C
12449          Y2(J)=STAT
12450          X2(J)=XIDTEM(ISET1)
12451          D2(J)=XIDTE2(ISET2)
12452          D3(J)=XIDTE3(ISET3)
12453          D4(J)=XIDTE4(ISET4)
12454          IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
12455     1       ICASCT.EQ.'DMEA' .OR. ICASCT.EQ.'DBPR' .OR.
12456     1       ICASCT.EQ.'MDCL' .OR. ICASCT.EQ.'BRAT' .AND.
12457     1       IFLUUN.NE.'OFF')THEN
12458            IF(PFLUCL.EQ.-9999.0)THEN
12459              IF(AUPPLM.GT.STATMX)STATMX=AUPPLM
12460            ELSE
12461              IF(AUPPLM.GT.PFLUCL)AUPPLM=PFLUCL
12462            ENDIF
12463            IF(PFLUFL.EQ.-9999.0)THEN
12464              IF(ALOWLM.LT.STATMN)STATMN=ALOWLM
12465            ELSE
12466              IF(ALOWLM.LT.PFLUFL)ALOWLM=PFLUFL
12467            ENDIF
12468            XACLOW(J)=ALOWLM
12469            XACUPP(J)=AUPPLM
12470          ENDIF
12471C
12472 1140   CONTINUE
12473 1130   CONTINUE
12474 1120   CONTINUE
12475 1110 CONTINUE
12476      N2=J
12477C
12478      IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'BRAT')THEN
12479        STATMN=0.0
12480        STATMX=1.0
12481      ELSEIF(ICASCT.EQ.'DBPR')THEN
12482        STATMN=-1.0
12483        STATMX=1.0
12484      ELSEIF(ICASCT.EQ.'COUN')THEN
12485        STATMN=0.0
12486      ENDIF
12487C
12488C               ******************
12489C               **   STEP 90--  **
12490C               **   EXIT       **
12491C               ******************
12492C
12493 9000 CONTINUE
12494      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'FLU5')THEN
12495        WRITE(ICOUT,999)
12496  999   FORMAT(1X)
12497        CALL DPWRST('XXX','BUG ')
12498        WRITE(ICOUT,9011)
12499 9011   FORMAT('***** AT THE END       OF DPFLU5--')
12500        CALL DPWRST('XXX','BUG ')
12501        WRITE(ICOUT,9012)ICASCT,N,NUMSE1,N2,IERROR
12502 9012   FORMAT('ICASCT,N,NUMSE1,N2,IERROR = ',A4,3I8,2X,A4)
12503        CALL DPWRST('XXX','BUG ')
12504        WRITE(ICOUT,9013)NUMV2
12505 9013   FORMAT('NUMV2 = ',I8)
12506        CALL DPWRST('XXX','BUG ')
12507        WRITE(ICOUT,9015)NUMSE1,NUMSE2,NUMSE3,NUMSE4,N2
12508 9015   FORMAT('NUMSE1,NUMSE2,NUMSE3,NUMSE4,N2 = ',5I8)
12509        CALL DPWRST('XXX','BUG ')
12510        DO9020I=1,N2
12511          WRITE(ICOUT,9021)I,Y2(I),X2(I),D2(I),D3(I),D4(I)
12512 9021     FORMAT('I,Y2(I),X2(I),D2(I),D3(I),D4(I) = ',I8,5G15.7)
12513          CALL DPWRST('XXX','BUG ')
12514 9020   CONTINUE
12515      ENDIF
12516C
12517      RETURN
12518      END
12519      SUBROUTINE DPFLU6(Y,Z,Z2,TAG1,TAG2,TAG3,TAG4,TAG5,N,
12520     1                  NUMV2,ICASCT,
12521     1                  XIDTEM,XIDTE2,XIDTE3,XIDTE4,XIDTE5,
12522     1                  NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,
12523     1                  TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,
12524     1                  ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
12525     1                  DTEMP1,DTEMP2,DTEMP3,
12526     1                  ISEED,IQUASE,IBINME,IBI2ME,ALPHA,
12527     1                  IXVAR,IX2VAR,IYVAR,
12528     1                  STATMN,STATMX,PSIZE,NMAX,XACLOW,XACUPP,
12529     1                  MAXOBV,PFLUFL,PFLUCL,IFLUUN,
12530     1                  ICTAMV,PCTAMV,PSTAMV,
12531     1                  Y2,X2,D2,D3,D4,D5,N2,
12532     1                  ISUBRO,IBUGG3,IERROR)
12533C
12534C     PURPOSE--GENERATE A FIVE-WAY FLUCUATION PLOT.
12535C     WRITTEN BY--ALAN HECKERT
12536C                 STATISTICAL ENGINEERING DIVISION
12537C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
12538C                 GAITHERSBURG, MD 20899-8980
12539C                 PHONE--301-975-2899
12540C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
12541C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
12542C     REFERENCE--UNWIN, THEUS, AND HOFMANN (2006), "GRAPHICS OF
12543C                LARGE DATA SETS: VISUALIZING A MILLION",
12544C                SPRINGER.
12545C     LANGUAGE--ANSI FORTRAN (1977)
12546C     VERSION NUMBER--2008/5
12547C     ORIGINAL VERSION--MAY       2008.
12548C     UPDATED         --SEPTEMBER 2009. SUPPORT FOR UNCERTAINTY INTERVALS
12549C                                       FOR BINOMIAL PROPORTION AND
12550C                                       MEAN/MEDIAN CONFIDENCE INTERVALS
12551C     UPDATED         --JANUARY   2010. SUPPORT FOR UNCERTAINTY INTERVALS
12552C                                       FOR BINOMIAL RATIO
12553C     UPDATED         --NOVEMBER  2017. DIFFERENCE OF MEAN AND
12554C                                       DIFFERENCE OF BINOMIAL
12555C                                       PROPORTIONS SUPPORT UNCERTAINTY
12556C                                       INTERVALS
12557C
12558C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
12559C
12560      CHARACTER*4 ICASCT
12561      CHARACTER*4 IXVAR
12562      CHARACTER*4 IX2VAR
12563      CHARACTER*4 IYVAR
12564      CHARACTER*4 IQUASE
12565      CHARACTER*4 IBINME
12566      CHARACTER*4 IBI2ME
12567      CHARACTER*4 ICTAMV
12568      CHARACTER*4 IFLUUN
12569      CHARACTER*4 ICAPSW
12570      CHARACTER*4 ICAPTY
12571      CHARACTER*4 IFORSW
12572      CHARACTER*4 IBUGG3
12573      CHARACTER*4 ISUBRO
12574      CHARACTER*4 IERROR
12575C
12576      CHARACTER*4 IWRITE
12577      CHARACTER*4 IDIR
12578      CHARACTER*4 ISUBN1
12579      CHARACTER*4 ISUBN2
12580      CHARACTER*4 ISTEPN
12581C
12582C---------------------------------------------------------------------
12583C
12584      DIMENSION Y(*)
12585      DIMENSION Z(*)
12586      DIMENSION Z2(*)
12587      DIMENSION XIDTEM(*)
12588      DIMENSION XIDTE2(*)
12589      DIMENSION XIDTE3(*)
12590      DIMENSION XIDTE4(*)
12591      DIMENSION XIDTE5(*)
12592      DIMENSION Y2(*)
12593      DIMENSION X2(*)
12594      DIMENSION D2(*)
12595      DIMENSION D3(*)
12596      DIMENSION D4(*)
12597      DIMENSION D5(*)
12598C
12599      DIMENSION PSIZE(*)
12600C
12601      DIMENSION TAG1(*)
12602      DIMENSION TAG2(*)
12603      DIMENSION TAG3(*)
12604      DIMENSION TAG4(*)
12605      DIMENSION TAG5(*)
12606      DIMENSION TEMP(*)
12607      DIMENSION TEMPZ(*)
12608      DIMENSION TEMPZ2(*)
12609      DIMENSION XTEMP1(*)
12610      DIMENSION XTEMP2(*)
12611      DIMENSION XTEMP3(*)
12612C
12613      DIMENSION XACLOW(*)
12614      DIMENSION XACUPP(*)
12615C
12616      INTEGER ITEMP1(*)
12617      INTEGER ITEMP2(*)
12618      INTEGER ITEMP3(*)
12619      INTEGER ITEMP4(*)
12620      INTEGER ITEMP5(*)
12621      INTEGER ITEMP6(*)
12622C
12623      DOUBLE PRECISION DTEMP1(*)
12624      DOUBLE PRECISION DTEMP2(*)
12625      DOUBLE PRECISION DTEMP3(*)
12626C
12627C---------------------------------------------------------------------
12628C
12629      INCLUDE 'DPCOP2.INC'
12630C
12631C-----START POINT-----------------------------------------------------
12632C
12633      ISUBN1='DPFL'
12634      ISUBN2='U6  '
12635C
12636      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'FLU6')THEN
12637        WRITE(ICOUT,999)
12638        CALL DPWRST('XXX','BUG ')
12639        WRITE(ICOUT,11)
12640   11   FORMAT('***** AT THE BEGINNING OF DPFLU6--')
12641        CALL DPWRST('XXX','BUG ')
12642        WRITE(ICOUT,12)ICASCT,ICAPSW,ICAPTY,IFORSW
12643   12   FORMAT('ICASCT,ICAPSW,ICAPTY,IFORSW,N,NUMV2 = ',3(A4,2X),A4)
12644        CALL DPWRST('XXX','BUG ')
12645        WRITE(ICOUT,13)N,NUMV2,MAXOBV
12646   13   FORMAT('N,NUMV2,MAXOBV = ',3I8)
12647        CALL DPWRST('XXX','BUG ')
12648        WRITE(ICOUT,15)NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5
12649   15   FORMAT('NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5 = ',5I8)
12650        CALL DPWRST('XXX','BUG ')
12651      ENDIF
12652C
12653      I2=0
12654C
12655      AN=INT(N+0.01)
12656C
12657C               ***********************************************
12658C               **  STEP 5--                                 **
12659C               **  COMPUTE THE VARIOUS CROSS-TAB STATISTICS **
12660C               ***********************************************
12661C
12662      ISTEPN='5.1'
12663      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'FLU6')
12664     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12665C
12666      IWRITE='OFF'
12667C
12668      STATMN=CPUMAX
12669      IF(ICASCT.EQ.'NUMB')STATMN=0.0
12670      STATMX=CPUMIN
12671      J=0
12672      NRESP=NUMV2-5
12673      IF(PFLUCL.NE.-9999.0)STATMX=PFLUCL
12674      IF(PFLUFL.NE.-9999.0)STATMN=PFLUFL
12675      NMAX=0
12676      DO1110ISET1=1,NUMSE1
12677        DO1120ISET2=1,NUMSE2
12678        DO1130ISET3=1,NUMSE3
12679        DO1140ISET4=1,NUMSE4
12680        DO1150ISET5=1,NUMSE5
12681C
12682          IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'FLU6')THEN
12683            WRITE(ICOUT,999)
12684            CALL DPWRST('XXX','BUG ')
12685            WRITE(ICOUT,1011)
12686 1011       FORMAT('***** IN THE MIDDLE OF DPFLU6--')
12687            CALL DPWRST('XXX','BUG ')
12688            WRITE(ICOUT,1013)ISET1,ISET2,ISET3,ISET4,ISET5
12689 1013       FORMAT('ISET1,ISET2,ISET3,ISET4,ISET5 = ',5I6)
12690            CALL DPWRST('XXX','BUG ')
12691            WRITE(ICOUT,1014)XIDTEM(ISET1),XIDTE2(ISET2),XIDTE3(ISET3)
12692 1014       FORMAT('XIDTEM(ISET1),XIDTE2(ISET2),XIDTE3(ISET3) = ',
12693     1             3G15.7)
12694            CALL DPWRST('XXX','BUG ')
12695            WRITE(ICOUT,1015)XIDTE4(ISET4),XIDTE5(ISET5)
12696 1015       FORMAT('XIDTE4(ISET4),XIDTE5(ISET5) = ',
12697     1             2G15.7)
12698            CALL DPWRST('XXX','BUG ')
12699          ENDIF
12700C
12701          K=0
12702          DO1180I=1,N
12703            IF(XIDTEM(ISET1).EQ.TAG1(I).AND.
12704     1         XIDTE2(ISET2).EQ.TAG2(I).AND.
12705     1         XIDTE3(ISET3).EQ.TAG3(I).AND.
12706     1         XIDTE4(ISET4).EQ.TAG4(I).AND.
12707     1         XIDTE5(ISET5).EQ.TAG5(I))
12708     1        GOTO1181
12709            GOTO1180
12710 1181       CONTINUE
12711C
12712            K=K+1
12713            IF(IYVAR.EQ.'OFF')THEN
12714              TEMP(K)=0.0
12715            ELSE
12716              TEMP(K)=Y(I)
12717              IF(IXVAR.EQ.'ON')TEMPZ(K)=Z(I)
12718              IF(IX2VAR.EQ.'ON')TEMPZ2(K)=Z2(I)
12719            ENDIF
12720 1180     CONTINUE
12721          NTEMP=K
12722C
12723          IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'FLU6')THEN
12724            WRITE(ICOUT,1019)NTEMP
12725 1019       FORMAT('NTEMP = ',I8)
12726            CALL DPWRST('XXX','BUG ')
12727          ENDIF
12728C
12729          NTRIAL=0
12730          ALOWLM=0.0
12731          AUPPLM=0.0
12732          IF(NTEMP.EQ.0)THEN
12733            IF(ICTAMV.EQ.'ZERO')THEN
12734              STAT=0.0
12735              IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
12736     1           ICASCT.EQ.'DMEA' .OR. ICASCT.EQ.'DBPR' .OR.
12737     1           ICASCT.EQ.'MDCL' .OR. ICASCT.EQ.'BRAT')THEN
12738                NTRIAL=0
12739                ALOWLM=0.0
12740                AUPPLM=0.0
12741              ENDIF
12742            ELSEIF(ICTAMV.EQ.'MV  ')THEN
12743              STAT=PCTAMV
12744              IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
12745     1           ICASCT.EQ.'DMEA' .OR. ICASCT.EQ.'DBPR' .OR.
12746     1           ICASCT.EQ.'MDCL' .OR. ICASCT.EQ.'BRAT')THEN
12747                NTRIAL=0
12748                ALOWLM=PCTAMV
12749                AUPPLM=PCTAMV
12750              ENDIF
12751            ELSE
12752              GOTO1150
12753            ENDIF
12754          ELSE
12755            CALL CMPSTA(
12756     1              TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,
12757     1              MAXNXT,NTEMP,NTEMP,NTEMP,
12758     1              NRESP,ICASCT,
12759     1              ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
12760     1              DTEMP1,DTEMP2,DTEMP3,
12761CCCCC1              IQUAME,IQUASE,PSTAMV,
12762     1              STAT,
12763     1              ISUBRO,IBUGG3,IERROR)
12764            IF(IERROR.EQ.'YES')GOTO9000
12765            IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'BRAT')THEN
12766              PTEMP=STAT
12767              NTRIAL=NTEMP
12768              IF(ICASCT.EQ.'BRAT')NTRIAL=ITEMP1(1)
12769              IF(STAT.EQ.PSTAMV)THEN
12770                ALOWLM=PSTAMV
12771                AUPPLM=PSTAMV
12772              ELSE
12773                ALPHAT=ALPHA
12774                IF(ALPHAT.LE.0.5)ALPHAT=1.0 - ALPHA
12775                IF(IFLUUN.EQ.'LOWE')THEN
12776                  IDIR='LOWE'
12777                  CALL DPAGC1(PTEMP,NTRIAL,ALPHAT,IDIR,IWRITE,
12778     1                        ALOWLM,IBUGG3,IERROR)
12779                  AUPPLM=STAT
12780                ELSEIF(IFLUUN.EQ.'UPPE')THEN
12781                  IDIR='UPPE'
12782                  CALL DPAGC1(PTEMP,NTRIAL,ALPHAT,IDIR,IWRITE,
12783     1                        AUPPLM,IBUGG3,IERROR)
12784                  ALOWLM=STAT
12785                ELSE
12786                  IF(ICASCT.EQ.'BPRO')THEN
12787                    CALL DPPRC3(TEMP,NTEMP,ALPHAT,PSTAMV,IBINME,TEMPZ2,
12788     1                          PTEMP2,ALOWLM,AUPPLM,
12789     1                          ISUBRO,IBUGG3,IERROR)
12790                  ELSEIF(ICASCT.EQ.'BRAT')THEN
12791                    CALL DPAGCO(PTEMP,NTRIAL,ALPHAT,IWRITE,
12792     1                          ALOWLM,AUPPLM,IBUGG3,IERROR)
12793                  ENDIF
12794                ENDIF
12795              ENDIF
12796            ELSEIF(ICASCT.EQ.'MECL')THEN
12797              XMEAN=STAT
12798              NTRIAL=NTEMP
12799              IF(STAT.EQ.PSTAMV)THEN
12800                ALOWLM=PSTAMV
12801                AUPPLM=PSTAMV
12802              ELSE
12803                CALL SD(TEMP,NTEMP,IWRITE,XSD,IBUGG3,IERROR)
12804                ALPHAT=ALPHA
12805                CALL DPMECL(XMEAN,XSD,NTEMP,ALPHAT,IWRITE,
12806     1                      ALOWLM,AUPPLM,IBUGG3,IERROR)
12807              ENDIF
12808            ELSEIF(ICASCT.EQ.'MDCL')THEN
12809              XMED=STAT
12810              NTRIAL=NTEMP
12811              IF(STAT.EQ.PSTAMV)THEN
12812                ALOWLM=PSTAMV
12813                AUPPLM=PSTAMV
12814              ELSE
12815                XQ=0.5
12816                CALL QUANSE(XQ,TEMP,NTEMP,IWRITE,XTEMP1,MAXNXT,IQUASE,
12817     1                      QUASE,IBUGG3,IERROR)
12818                ALPHAT=ALPHA
12819                CALL DPMECL(XMED,QUASE,NTEMP,ALPHAT,IWRITE,
12820     1                      ALOWLM,AUPPLM,IBUGG3,IERROR)
12821              ENDIF
12822            ELSEIF(ICASCT.EQ.'DMEA')THEN
12823              XDIFF=STAT
12824              NTRIAL=NTEMP
12825              IF(STAT.EQ.PSTAMV)THEN
12826                ALOWLM=PSTAMV
12827                AUPPLM=PSTAMV
12828              ELSE
12829                ALPHAT=ALPHA
12830                ALP=ALPHA
12831                IF(ALP.LT.0.5)THEN
12832                  ALPHAT=1.0-(ALP/2.0)
12833                ELSE
12834                  ALP=1.0 - ALPHA
12835                  ALPHAT=1.0-(ALP/2.0)
12836                ENDIF
12837                AN=REAL(NTEMP)
12838                CALL MEAN(TEMP,NTEMP,IWRITE,XMEAN1,IBUGG3,IERROR)
12839                CALL SD(TEMP,NTEMP,IWRITE,XSD1,IBUGG3,IERROR)
12840                AVAL1=XSD1**2/AN
12841                CALL MEAN(TEMPZ,NTEMP,IWRITE,XMEAN2,IBUGG3,IERROR)
12842                CALL SD(TEMPZ,NTEMP,IWRITE,XSD2,IBUGG3,IERROR)
12843                AVAL2=XSD2**2/AN
12844                XSTERR=SQRT(AVAL1 + AVAL2)
12845                TERM1=(AVAL1 + AVAL2)**2
12846                TERM2=AVAL1*AVAL1/(AN-1.0) + AVAL2*AVAL2/(AN-1.0)
12847                V=TERM1/TERM2
12848                IV=INT(V+0.5)
12849                CALL TCDF(ALPHAT,REAL(IV),TCV)
12850                ALOWLM=XDIFF - TCV*XSTERR
12851                AUPPLM=XDIFF + TCV*XSTERR
12852              ENDIF
12853            ELSEIF(ICASCT.EQ.'DBPR')THEN
12854              IF(STAT.EQ.PSTAMV)THEN
12855                ALOWLM=PSTAMV
12856                AUPPLM=PSTAMV
12857              ELSE
12858                ALPHAT=ALPHA
12859                ALP=ALPHA
12860                IF(ALP.LT.0.5)THEN
12861                  ALPHAT=1.0-(ALP/2.0)
12862                ELSE
12863                  ALP=1.0 - ALPHA
12864                  ALPHAT=1.0-(ALP/2.0)
12865                ENDIF
12866                CALL DPPRC4(TEMP,NTEMP,TEMPZ,NTEMP,ALPHAT,PSTAMV,
12867     1                      IBI2ME,TEMPZ2,
12868     1                      XDIFF,ALOWLM,AUPPLM,
12869     1                      ISUBRO,IBUGG3,IERROR)
12870              ENDIF
12871            ENDIF
12872          ENDIF
12873C
12874          J=J+1
12875          IF(PFLUCL.EQ.-9999.0)THEN
12876            IF(STAT.GT.STATMX)STATMX=STAT
12877          ELSE
12878            IF(STAT.GT.PFLUCL)STAT=PFLUCL
12879          ENDIF
12880          IF(PFLUFL.EQ.-9999.0)THEN
12881            IF(STAT.LT.STATMN)STATMN=STAT
12882          ELSE
12883            IF(STAT.LT.PFLUFL)STAT=PFLUFL
12884          ENDIF
12885          IF(NTEMP.GT.NMAX)NMAX=NTEMP
12886          PSIZE(J)=REAL(NTEMP)
12887C
12888          Y2(J)=STAT
12889          X2(J)=XIDTEM(ISET1)
12890          D2(J)=XIDTE2(ISET2)
12891          D3(J)=XIDTE3(ISET3)
12892          D4(J)=XIDTE4(ISET4)
12893          D5(J)=XIDTE5(ISET5)
12894          IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
12895     1       ICASCT.EQ.'DMEA' .OR. ICASCT.EQ.'DBPR' .OR.
12896     1       ICASCT.EQ.'MDCL' .OR. ICASCT.EQ.'BRAT' .AND.
12897     1       IFLUUN.NE.'OFF')THEN
12898            IF(PFLUCL.EQ.-9999.0)THEN
12899              IF(AUPPLM.GT.STATMX)STATMX=AUPPLM
12900            ELSE
12901              IF(AUPPLM.GT.PFLUCL)AUPPLM=PFLUCL
12902            ENDIF
12903            IF(PFLUFL.EQ.-9999.0)THEN
12904              IF(ALOWLM.LT.STATMN)STATMN=ALOWLM
12905            ELSE
12906              IF(ALOWLM.LT.PFLUFL)ALOWLM=PFLUFL
12907            ENDIF
12908            XACLOW(J)=ALOWLM
12909            XACUPP(J)=AUPPLM
12910          ENDIF
12911C
12912 1150   CONTINUE
12913 1140   CONTINUE
12914 1130   CONTINUE
12915 1120   CONTINUE
12916 1110 CONTINUE
12917      N2=J
12918C
12919      IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'BRAT')THEN
12920        STATMN=0.0
12921        STATMX=1.0
12922      ELSEIF(ICASCT.EQ.'DBPR')THEN
12923        STATMN=-1.0
12924        STATMX=1.0
12925      ELSEIF(ICASCT.EQ.'COUN')THEN
12926        STATMN=0.0
12927      ENDIF
12928C
12929C               ******************
12930C               **   STEP 90--  **
12931C               **   EXIT       **
12932C               ******************
12933C
12934 9000 CONTINUE
12935      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'FLU6')THEN
12936        WRITE(ICOUT,999)
12937  999   FORMAT(1X)
12938        CALL DPWRST('XXX','BUG ')
12939        WRITE(ICOUT,9011)
12940 9011   FORMAT('***** AT THE END       OF DPFLU6--')
12941        CALL DPWRST('XXX','BUG ')
12942        WRITE(ICOUT,9012)ICASCT,N,N2,IERROR
12943 9012   FORMAT('ICASCT,N,N2,IERROR = ',A4,2I8,2X,A4)
12944        CALL DPWRST('XXX','BUG ')
12945        WRITE(ICOUT,9013)NUMV2
12946 9013   FORMAT('NUMV2 = ',I8)
12947        CALL DPWRST('XXX','BUG ')
12948        WRITE(ICOUT,9015)NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5
12949 9015   FORMAT('NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5 = ',5I8)
12950        CALL DPWRST('XXX','BUG ')
12951        DO9020I=1,N2
12952          WRITE(ICOUT,9021)I,Y2(I),X2(I),D2(I),D3(I),D4(I),D5(I)
12953 9021     FORMAT('I,Y2(I),X2(I),D2(I),D3(I),D4(I),D5(I) = ',
12954     1           I8,6G15.7)
12955          CALL DPWRST('XXX','BUG ')
12956 9020   CONTINUE
12957      ENDIF
12958C
12959      RETURN
12960      END
12961      SUBROUTINE DPFLU7(Y,Z,Z2,TAG1,TAG2,TAG3,TAG4,TAG5,TAG6,N,
12962     1                  NUMV2,ICASCT,
12963     1                  XIDTEM,XIDTE2,XIDTE3,XIDTE4,XIDTE5,XIDTE6,
12964     1                  NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,NUMSE6,
12965     1                  TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,
12966     1                  ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
12967     1                  DTEMP1,DTEMP2,DTEMP3,
12968     1                  ISEED,IQUASE,IBINME,IBI2ME,ALPHA,
12969     1                  IXVAR,IX2VAR,IYVAR,
12970     1                  STATMN,STATMX,PSIZE,NMAX,XACLOW,XACUPP,
12971     1                  MAXOBV,PFLUFL,PFLUCL,IFLUUN,
12972     1                  ICTAMV,PCTAMV,PSTAMV,
12973     1                  Y2,X2,D2,D3,D4,D5,D6,N2,
12974     1                  ISUBRO,IBUGG3,IERROR)
12975C
12976C     PURPOSE--GENERATE A FIVE-WAY FLUCUATION PLOT.
12977C     WRITTEN BY--ALAN HECKERT
12978C                 STATISTICAL ENGINEERING DIVISION
12979C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
12980C                 GAITHERSBURG, MD 20899-8980
12981C                 PHONE--301-975-2899
12982C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
12983C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
12984C     REFERENCE--UNWIN, THEUS, AND HOFMANN (2006), "GRAPHICS OF
12985C                LARGE DATA SETS: VISUALIZING A MILLION",
12986C                SPRINGER.
12987C     LANGUAGE--ANSI FORTRAN (1977)
12988C     VERSION NUMBER--2008/5
12989C     ORIGINAL VERSION--MAY       2008.
12990C     UPDATED         --SEPTEMBER 2009. SUPPORT FOR UNCERTAINTY INTERVALS
12991C                                       FOR BINOMIAL PROPORTION AND
12992C                                       MEAN/MEDIAN CONFIDENCE INTERVALS
12993C     UPDATED         --JANUARY   2010. SUPPORT FOR UNCERTAINTY INTERVALS
12994C                                       FOR BINOMIAL RATIO
12995C     UPDATED         --NOVEMBER  2017. DIFFERENCE OF MEAN AND
12996C                                       DIFFERENCE OF BINOMIAL
12997C                                       PROPORTIONS SUPPORT UNCERTAINTY
12998C                                       INTERVALS
12999C
13000C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
13001C
13002      CHARACTER*4 ICASCT
13003      CHARACTER*4 IXVAR
13004      CHARACTER*4 IX2VAR
13005      CHARACTER*4 IYVAR
13006      CHARACTER*4 IQUASE
13007      CHARACTER*4 IBINME
13008      CHARACTER*4 IBI2ME
13009      CHARACTER*4 ICTAMV
13010      CHARACTER*4 IFLUUN
13011      CHARACTER*4 ICAPSW
13012      CHARACTER*4 ICAPTY
13013      CHARACTER*4 IFORSW
13014      CHARACTER*4 IBUGG3
13015      CHARACTER*4 IERROR
13016C
13017      CHARACTER*4 ISUBRO
13018      CHARACTER*4 IWRITE
13019      CHARACTER*4 IDIR
13020      CHARACTER*4 ISUBN1
13021      CHARACTER*4 ISUBN2
13022      CHARACTER*4 ISTEPN
13023C
13024C---------------------------------------------------------------------
13025C
13026      DIMENSION Y(*)
13027      DIMENSION Z(*)
13028      DIMENSION Z2(*)
13029      DIMENSION XIDTEM(*)
13030      DIMENSION XIDTE2(*)
13031      DIMENSION XIDTE3(*)
13032      DIMENSION XIDTE4(*)
13033      DIMENSION XIDTE5(*)
13034      DIMENSION XIDTE6(*)
13035      DIMENSION Y2(*)
13036      DIMENSION X2(*)
13037      DIMENSION D2(*)
13038      DIMENSION D3(*)
13039      DIMENSION D4(*)
13040      DIMENSION D5(*)
13041      DIMENSION D6(*)
13042C
13043      DIMENSION PSIZE(*)
13044C
13045      DIMENSION TAG1(*)
13046      DIMENSION TAG2(*)
13047      DIMENSION TAG3(*)
13048      DIMENSION TAG4(*)
13049      DIMENSION TAG5(*)
13050      DIMENSION TAG6(*)
13051      DIMENSION TEMP(*)
13052      DIMENSION TEMPZ(*)
13053      DIMENSION TEMPZ2(*)
13054      DIMENSION XTEMP1(*)
13055      DIMENSION XTEMP2(*)
13056      DIMENSION XTEMP3(*)
13057C
13058      DIMENSION XACLOW(*)
13059      DIMENSION XACUPP(*)
13060C
13061      INTEGER ITEMP1(*)
13062      INTEGER ITEMP2(*)
13063      INTEGER ITEMP3(*)
13064      INTEGER ITEMP4(*)
13065      INTEGER ITEMP5(*)
13066      INTEGER ITEMP6(*)
13067C
13068      DOUBLE PRECISION DTEMP1(*)
13069      DOUBLE PRECISION DTEMP2(*)
13070      DOUBLE PRECISION DTEMP3(*)
13071C
13072C---------------------------------------------------------------------
13073C
13074      INCLUDE 'DPCOP2.INC'
13075C
13076C-----START POINT-----------------------------------------------------
13077C
13078      ISUBN1='DPFL'
13079      ISUBN2='U7  '
13080C
13081      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'FLU6')THEN
13082        WRITE(ICOUT,999)
13083        CALL DPWRST('XXX','BUG ')
13084        WRITE(ICOUT,11)
13085   11   FORMAT('***** AT THE BEGINNING OF DPFLU7--')
13086        CALL DPWRST('XXX','BUG ')
13087        WRITE(ICOUT,12)ICASCT,ICAPSW,ICAPTY,IFORSW
13088   12   FORMAT('ICASCT,ICAPSW,ICAPTY,IFORSW,N,NUMV2 = ',3(A4,2X),A4)
13089        CALL DPWRST('XXX','BUG ')
13090        WRITE(ICOUT,13)N,NUMV2,MAXOBV
13091   13   FORMAT('N,NUMV2,MAXOBV = ',3I8)
13092        CALL DPWRST('XXX','BUG ')
13093        WRITE(ICOUT,15)NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,NUMSE6
13094   15   FORMAT('NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,NUMSE6 = ',6I8)
13095        CALL DPWRST('XXX','BUG ')
13096      ENDIF
13097C
13098      I2=0
13099C
13100      AN=INT(N+0.01)
13101C
13102C               ***********************************************
13103C               **  STEP 5--                                 **
13104C               **  COMPUTE THE VARIOUS CROSS-TAB STATISTICS **
13105C               ***********************************************
13106C
13107      ISTEPN='5.1'
13108      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'FLU6')
13109     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
13110C
13111      IWRITE='OFF'
13112C
13113      STATMN=CPUMAX
13114      IF(ICASCT.EQ.'NUMB')STATMN=0.0
13115      STATMX=CPUMIN
13116      J=0
13117      NRESP=NUMV2-6
13118      IF(PFLUCL.NE.-9999.0)STATMX=PFLUCL
13119      IF(PFLUFL.NE.-9999.0)STATMN=PFLUFL
13120      NMAX=0
13121      DO1110ISET1=1,NUMSE1
13122        DO1120ISET2=1,NUMSE2
13123        DO1130ISET3=1,NUMSE3
13124        DO1140ISET4=1,NUMSE4
13125        DO1150ISET5=1,NUMSE5
13126        DO1160ISET6=1,NUMSE6
13127C
13128          IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'FLU6')THEN
13129            WRITE(ICOUT,999)
13130            CALL DPWRST('XXX','BUG ')
13131            WRITE(ICOUT,1011)
13132 1011       FORMAT('***** IN THE MIDDLE OF DPFLU7--')
13133            CALL DPWRST('XXX','BUG ')
13134            WRITE(ICOUT,1013)ISET1,ISET2,ISET3,ISET4,ISET5,ISET6
13135 1013       FORMAT('ISET1,ISET2,ISET3,ISET4,ISET5,ISET6 = ',6I6)
13136            CALL DPWRST('XXX','BUG ')
13137            WRITE(ICOUT,1014)XIDTEM(ISET1),XIDTE2(ISET2),XIDTE3(ISET3)
13138 1014       FORMAT('XIDTEM(ISET1),XIDTE2(ISET2),XIDTE3(ISET3) = ',
13139     1             3G15.7)
13140            CALL DPWRST('XXX','BUG ')
13141            WRITE(ICOUT,1015)XIDTE4(ISET4),XIDTE5(ISET5),XIDTE6(ISET6)
13142 1015       FORMAT('XIDTE4(ISET4),XIDTE5(ISET5),XIDTE6(ISET6) = ',
13143     1             3G15.7)
13144            CALL DPWRST('XXX','BUG ')
13145          ENDIF
13146C
13147          K=0
13148          DO1180I=1,N
13149            IF(XIDTEM(ISET1).EQ.TAG1(I).AND.
13150     1         XIDTE2(ISET2).EQ.TAG2(I).AND.
13151     1         XIDTE3(ISET3).EQ.TAG3(I).AND.
13152     1         XIDTE4(ISET4).EQ.TAG4(I).AND.
13153     1         XIDTE5(ISET5).EQ.TAG5(I).AND.
13154     1         XIDTE6(ISET6).EQ.TAG6(I))
13155     1        GOTO1181
13156            GOTO1180
13157 1181       CONTINUE
13158C
13159            K=K+1
13160            IF(IYVAR.EQ.'OFF')THEN
13161              TEMP(K)=0.0
13162            ELSE
13163              TEMP(K)=Y(I)
13164              IF(IXVAR.EQ.'ON')TEMPZ(K)=Z(I)
13165              IF(IX2VAR.EQ.'ON')TEMPZ2(K)=Z2(I)
13166            ENDIF
13167 1180     CONTINUE
13168          NTEMP=K
13169C
13170          IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'FLU6')THEN
13171            WRITE(ICOUT,1019)NTEMP
13172 1019       FORMAT('NTEMP = ',I8)
13173            CALL DPWRST('XXX','BUG ')
13174          ENDIF
13175C
13176          NTRIAL=0
13177          ALOWLM=0.0
13178          AUPPLM=0.0
13179          IF(NTEMP.EQ.0)THEN
13180            IF(ICTAMV.EQ.'ZERO')THEN
13181              STAT=0.0
13182              IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
13183     1           ICASCT.EQ.'DMEA' .OR. ICASCT.EQ.'DBPR' .OR.
13184     1           ICASCT.EQ.'MDCL' .OR. ICASCT.EQ.'BRAT')THEN
13185                NTRIAL=0
13186                ALOWLM=0.0
13187                AUPPLM=0.0
13188              ENDIF
13189            ELSEIF(ICTAMV.EQ.'MV  ')THEN
13190              STAT=PCTAMV
13191              IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
13192     1           ICASCT.EQ.'DMEA' .OR. ICASCT.EQ.'DBPR' .OR.
13193     1           ICASCT.EQ.'MDCL' .OR. ICASCT.EQ.'BRAT')THEN
13194                NTRIAL=0
13195                ALOWLM=PCTAMV
13196                AUPPLM=PCTAMV
13197              ENDIF
13198            ELSE
13199              GOTO1160
13200            ENDIF
13201          ELSE
13202            CALL CMPSTA(
13203     1              TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,
13204     1              MAXNXT,NTEMP,NTEMP,NTEMP2,
13205     1              NRESP,ICASCT,
13206     1              ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
13207     1              DTEMP1,DTEMP2,DTEMP3,
13208CCCCC1              IQUAME,IQUASE,PSTAMV,
13209     1              STAT,
13210     1              ISUBRO,IBUGG3,IERROR)
13211            IF(IERROR.EQ.'YES')GOTO9000
13212            IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'BRAT')THEN
13213              PTEMP=STAT
13214              NTRIAL=NTEMP
13215              IF(ICASCT.EQ.'BRAT')NTRIAL=ITEMP1(1)
13216              IF(STAT.EQ.PSTAMV)THEN
13217                ALOWLM=PSTAMV
13218                AUPPLM=PSTAMV
13219              ELSE
13220                ALPHAT=ALPHA
13221                IF(ALPHAT.LE.0.5)ALPHAT=1.0 - ALPHA
13222                IF(IFLUUN.EQ.'LOWE')THEN
13223                  IDIR='LOWE'
13224                  CALL DPAGC1(PTEMP,NTRIAL,ALPHAT,IDIR,IWRITE,
13225     1                        ALOWLM,IBUGG3,IERROR)
13226                  AUPPLM=STAT
13227                ELSEIF(IFLUUN.EQ.'UPPE')THEN
13228                  IDIR='UPPE'
13229                  CALL DPAGC1(PTEMP,NTRIAL,ALPHAT,IDIR,IWRITE,
13230     1                        AUPPLM,IBUGG3,IERROR)
13231                  ALOWLM=STAT
13232                ELSE
13233                  IF(ICASCT.EQ.'BPRO')THEN
13234                    CALL DPPRC3(TEMP,NTEMP,ALPHAT,PSTAMV,IBINME,TEMPZ2,
13235     1                          PTEMP2,ALOWLM,AUPPLM,
13236     1                          ISUBRO,IBUGG3,IERROR)
13237                  ELSEIF(ICASCT.EQ.'BRAT')THEN
13238                    CALL DPAGCO(PTEMP,NTRIAL,ALPHAT,IWRITE,
13239     1                          ALOWLM,AUPPLM,IBUGG3,IERROR)
13240                  ENDIF
13241                ENDIF
13242              ENDIF
13243            ELSEIF(ICASCT.EQ.'MECL')THEN
13244              XMEAN=STAT
13245              NTRIAL=NTEMP
13246              IF(STAT.EQ.PSTAMV)THEN
13247                ALOWLM=PSTAMV
13248                AUPPLM=PSTAMV
13249              ELSE
13250                CALL SD(TEMP,NTEMP,IWRITE,XSD,IBUGG3,IERROR)
13251                ALPHAT=ALPHA
13252                CALL DPMECL(XMEAN,XSD,NTEMP,ALPHAT,IWRITE,
13253     1                      ALOWLM,AUPPLM,IBUGG3,IERROR)
13254              ENDIF
13255            ELSEIF(ICASCT.EQ.'MDCL')THEN
13256              XMED=STAT
13257              NTRIAL=NTEMP
13258              IF(STAT.EQ.PSTAMV)THEN
13259                ALOWLM=PSTAMV
13260                AUPPLM=PSTAMV
13261              ELSE
13262                XQ=0.5
13263                CALL QUANSE(XQ,TEMP,NTEMP,IWRITE,XTEMP1,MAXNXT,IQUASE,
13264     1                      QUASE,IBUGG3,IERROR)
13265                ALPHAT=ALPHA
13266                CALL DPMECL(XMED,QUASE,NTEMP,ALPHAT,IWRITE,
13267     1                      ALOWLM,AUPPLM,IBUGG3,IERROR)
13268              ENDIF
13269            ELSEIF(ICASCT.EQ.'DMEA')THEN
13270              XDIFF=STAT
13271              NTRIAL=NTEMP
13272              IF(STAT.EQ.PSTAMV)THEN
13273                ALOWLM=PSTAMV
13274                AUPPLM=PSTAMV
13275              ELSE
13276                ALPHAT=ALPHA
13277                ALP=ALPHA
13278                IF(ALP.LT.0.5)THEN
13279                  ALPHAT=1.0-(ALP/2.0)
13280                ELSE
13281                  ALP=1.0 - ALPHA
13282                  ALPHAT=1.0-(ALP/2.0)
13283                ENDIF
13284                AN=REAL(NTEMP)
13285                CALL MEAN(TEMP,NTEMP,IWRITE,XMEAN1,IBUGG3,IERROR)
13286                CALL SD(TEMP,NTEMP,IWRITE,XSD1,IBUGG3,IERROR)
13287                AVAL1=XSD1**2/AN
13288                CALL MEAN(TEMPZ,NTEMP,IWRITE,XMEAN2,IBUGG3,IERROR)
13289                CALL SD(TEMPZ,NTEMP,IWRITE,XSD2,IBUGG3,IERROR)
13290                AVAL2=XSD2**2/AN
13291                XSTERR=SQRT(AVAL1 + AVAL2)
13292                TERM1=(AVAL1 + AVAL2)**2
13293                TERM2=AVAL1*AVAL1/(AN-1.0) + AVAL2*AVAL2/(AN-1.0)
13294                V=TERM1/TERM2
13295                IV=INT(V+0.5)
13296                CALL TCDF(ALPHAT,REAL(IV),TCV)
13297                ALOWLM=XDIFF - TCV*XSTERR
13298                AUPPLM=XDIFF + TCV*XSTERR
13299              ENDIF
13300            ELSEIF(ICASCT.EQ.'DBPR')THEN
13301              IF(STAT.EQ.PSTAMV)THEN
13302                ALOWLM=PSTAMV
13303                AUPPLM=PSTAMV
13304              ELSE
13305                ALPHAT=ALPHA
13306                ALP=ALPHA
13307                IF(ALP.LT.0.5)THEN
13308                  ALPHAT=1.0-(ALP/2.0)
13309                ELSE
13310                  ALP=1.0 - ALPHA
13311                  ALPHAT=1.0-(ALP/2.0)
13312                ENDIF
13313                CALL DPPRC4(TEMP,NTEMP,TEMPZ,NTEMP,ALPHAT,PSTAMV,
13314     1                      IBI2ME,TEMPZ2,
13315     1                      XDIFF,ALOWLM,AUPPLM,
13316     1                      ISUBRO,IBUGG3,IERROR)
13317              ENDIF
13318            ENDIF
13319          ENDIF
13320C
13321          J=J+1
13322          IF(PFLUCL.EQ.-9999.0)THEN
13323            IF(STAT.GT.STATMX)STATMX=STAT
13324          ELSE
13325            IF(STAT.GT.PFLUCL)STAT=PFLUCL
13326          ENDIF
13327          IF(PFLUFL.EQ.-9999.0)THEN
13328            IF(STAT.LT.STATMN)STATMN=STAT
13329          ELSE
13330            IF(STAT.LT.PFLUFL)STAT=PFLUFL
13331          ENDIF
13332          IF(NTEMP.GT.NMAX)NMAX=NTEMP
13333          PSIZE(J)=REAL(NTEMP)
13334C
13335          Y2(J)=STAT
13336          X2(J)=XIDTEM(ISET1)
13337          D2(J)=XIDTE2(ISET2)
13338          D3(J)=XIDTE3(ISET3)
13339          D4(J)=XIDTE4(ISET4)
13340          D5(J)=XIDTE5(ISET5)
13341          D6(J)=XIDTE6(ISET6)
13342          IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR.
13343     1       ICASCT.EQ.'DMEA' .OR. ICASCT.EQ.'DBPR' .OR.
13344     1       ICASCT.EQ.'MDCL' .OR. ICASCT.EQ.'BRAT' .AND.
13345     1       IFLUUN.NE.'OFF')THEN
13346            IF(PFLUCL.EQ.-9999.0)THEN
13347              IF(AUPPLM.GT.STATMX)STATMX=AUPPLM
13348            ELSE
13349              IF(AUPPLM.GT.PFLUCL)AUPPLM=PFLUCL
13350            ENDIF
13351            IF(PFLUFL.EQ.-9999.0)THEN
13352              IF(ALOWLM.LT.STATMN)STATMN=ALOWLM
13353            ELSE
13354              IF(ALOWLM.LT.PFLUFL)ALOWLM=PFLUFL
13355            ENDIF
13356            XACLOW(J)=ALOWLM
13357            XACUPP(J)=AUPPLM
13358          ENDIF
13359C
13360 1160   CONTINUE
13361 1150   CONTINUE
13362 1140   CONTINUE
13363 1130   CONTINUE
13364 1120   CONTINUE
13365 1110 CONTINUE
13366      N2=J
13367C
13368      IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'BRAT')THEN
13369        STATMN=0.0
13370        STATMX=1.0
13371      ELSEIF(ICASCT.EQ.'DBPR')THEN
13372        STATMN=-1.0
13373        STATMX=1.0
13374      ELSEIF(ICASCT.EQ.'COUN')THEN
13375        STATMN=0.0
13376      ENDIF
13377C
13378C               ******************
13379C               **   STEP 90--  **
13380C               **   EXIT       **
13381C               ******************
13382C
13383 9000 CONTINUE
13384      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'FLU6')THEN
13385        WRITE(ICOUT,999)
13386  999   FORMAT(1X)
13387        CALL DPWRST('XXX','BUG ')
13388        WRITE(ICOUT,9011)
13389 9011   FORMAT('***** AT THE END       OF DPFLU7--')
13390        CALL DPWRST('XXX','BUG ')
13391        WRITE(ICOUT,9012)ICASCT,N,N2,IERROR
13392 9012   FORMAT('ICASCT,N,N2,IERROR = ',A4,2I8,2X,A4)
13393        CALL DPWRST('XXX','BUG ')
13394        WRITE(ICOUT,9013)NUMV2
13395 9013   FORMAT('NUMV2 = ',I8)
13396        CALL DPWRST('XXX','BUG ')
13397        WRITE(ICOUT,9015)NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,NUMSE6
13398 9015   FORMAT('NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,NUMSE6 = ',6I8)
13399        CALL DPWRST('XXX','BUG ')
13400        DO9020I=1,N2
13401          WRITE(ICOUT,9021)I,Y2(I),X2(I),D2(I),D3(I),D4(I),D5(I),D6(I)
13402 9021     FORMAT('I,Y2(I),X2(I),D2(I),D3(I),D4(I),D5(I),D6(I) = ',
13403     1           I8,7G15.7)
13404          CALL DPWRST('XXX','BUG ')
13405 9020   CONTINUE
13406      ENDIF
13407C
13408      RETURN
13409      END
13410      SUBROUTINE DPFLUW(Y,X,D,DCOLOR,TEMP6,XACLOW,XACUPP,
13411     1                  XCOOR1,XCOOR2,XCOOR3,XCOOR4,XCOOR5,
13412     1                  YCOOR1,YCOOR2,YCOOR3,YCOOR4,YCOOR5,
13413     1                  ICNT,ICNT2,ACOL,IFLAGU,
13414     1                  I,XVAL,YVAL,AFACT,AINC,STATMN,DENOM,
13415     1                  IFLUBD)
13416C
13417C     PURPOSE--UTILITY ROUTINE FOR DPFLU2.  THIS BLOCK OF
13418C              CODE IS EXECUTED MULTIPLE TIMES, BUT IS WITHIN
13419C              A LOOP (SO CANNOT EASILY INCLUDE JUST ONCE IN
13420C              DPFLU2).  SO FOR CONVENIENCE, SETUP AS A SEPARATE
13421C              SUBROUTINE.
13422C     WRITTEN BY--ALAN HECKERT
13423C                 STATISTICAL ENGINEERING DIVISION
13424C                 INFORMATION TECHNOLOGY LABORATORY
13425C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
13426C                 GAITHERSBURG, MD 20899-8980
13427C                 PHONE--301-975-2899
13428C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
13429C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
13430C     LANGUAGE--ANSI FORTRAN (1977)
13431C     VERSION NUMBER--2013/4
13432C     ORIGINAL VERSION--APRIL     2013. EXTRACT AS DISTINCT SUBROUTINE
13433C
13434C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
13435C
13436      CHARACTER*4 IFLUBD
13437C
13438      DIMENSION Y(*)
13439      DIMENSION X(*)
13440      DIMENSION D(*)
13441      DIMENSION DCOLOR(*)
13442      DIMENSION TEMP6(*)
13443      DIMENSION XACLOW(*)
13444      DIMENSION XACUPP(*)
13445C
13446C---------------------------------------------------------------------
13447C
13448      INCLUDE 'DPCOP2.INC'
13449C
13450C-----START POINT-----------------------------------------------------
13451C
13452      D1=AFACT*AINC
13453      D2=AINC
13454      D3=(2.0*AINC)*((TEMP6(I) - STATMN)/DENOM)
13455      D4=2.0*AINC
13456      D5=(2.0*AINC)*((XACLOW(I) - STATMN)/DENOM)
13457      D6=(2.0*AINC)*((XACUPP(I) - STATMN)/DENOM)
13458      IF(IFLUBD.EQ.'HORI')THEN
13459        XCOOR1=XVAL - D2
13460        XCOOR2=XVAL + D2
13461        YCOOR1=YVAL - D1
13462        YCOOR2=YVAL + D1
13463        IF(DENOM.NE.0.0)THEN
13464          XCOOR3=XCOOR1 + D3
13465        ELSE
13466          XCOOR3=XCOOR1 + D4
13467        ENDIF
13468C
13469        IF(IFLAGU.EQ.1)THEN
13470          IF(DENOM.NE.0.0)THEN
13471            XCOOR4=XCOOR1 + D5
13472            XCOOR5=XCOOR1 + D6
13473          ELSE
13474            XCOOR4=XCOOR3
13475            XCOOR5=XCOOR3
13476          ENDIF
13477        ENDIF
13478      ELSE
13479        XCOOR1=XVAL - D1
13480        XCOOR2=XVAL + D1
13481        YCOOR1=YVAL - D2
13482        YCOOR2=YVAL + D2
13483        IF(DENOM.NE.0.0)THEN
13484          YCOOR3=YCOOR1 + D3
13485        ELSE
13486          YCOOR3=YCOOR1 + D4
13487        ENDIF
13488C
13489        IF(IFLAGU.EQ.1)THEN
13490          IF(DENOM.NE.0.0)THEN
13491            YCOOR4=YCOOR1 + D5
13492            YCOOR5=YCOOR1 + D6
13493          ELSE
13494            YCOOR4=YCOOR3
13495            YCOOR5=YCOOR3
13496          ENDIF
13497        ENDIF
13498      ENDIF
13499C
13500      ICNT2=ICNT2+1
13501      ICNT=ICNT+1
13502      X(ICNT)=XCOOR1
13503      Y(ICNT)=YCOOR1
13504      D(ICNT)=REAL(ICNT2)
13505      DCOLOR(ICNT)=1.0
13506C
13507      ICNT=ICNT+1
13508      X(ICNT)=XCOOR2
13509      Y(ICNT)=YCOOR1
13510      D(ICNT)=REAL(ICNT2)
13511      DCOLOR(ICNT)=1.0
13512C
13513      ICNT=ICNT+1
13514      X(ICNT)=XCOOR2
13515      Y(ICNT)=YCOOR2
13516      D(ICNT)=REAL(ICNT2)
13517      DCOLOR(ICNT)=1.0
13518C
13519      ICNT=ICNT+1
13520      X(ICNT)=XCOOR1
13521      Y(ICNT)=YCOOR2
13522      D(ICNT)=REAL(ICNT2)
13523      DCOLOR(ICNT)=1.0
13524C
13525      ICNT=ICNT+1
13526      X(ICNT)=XCOOR1
13527      Y(ICNT)=YCOOR1
13528      D(ICNT)=REAL(ICNT2)
13529      DCOLOR(ICNT)=1.0
13530C
13531      IF(IFLUBD.EQ.'HORI')THEN
13532C
13533         ICNT2=ICNT2+1
13534         ICNT=ICNT+1
13535         X(ICNT)=XCOOR1
13536         Y(ICNT)=YCOOR2
13537         D(ICNT)=REAL(ICNT2)
13538         DCOLOR(ICNT)=ACOL
13539C
13540         ICNT=ICNT+1
13541         X(ICNT)=XCOOR1
13542         Y(ICNT)=YCOOR1
13543         D(ICNT)=REAL(ICNT2)
13544         DCOLOR(ICNT)=ACOL
13545C
13546         ICNT=ICNT+1
13547         X(ICNT)=XCOOR3
13548         Y(ICNT)=YCOOR1
13549         D(ICNT)=REAL(ICNT2)
13550         DCOLOR(ICNT)=ACOL
13551C
13552         ICNT=ICNT+1
13553         X(ICNT)=XCOOR3
13554         Y(ICNT)=YCOOR2
13555         D(ICNT)=REAL(ICNT2)
13556         DCOLOR(ICNT)=ACOL
13557C
13558         ICNT=ICNT+1
13559         X(ICNT)=XCOOR1
13560         Y(ICNT)=YCOOR2
13561         D(ICNT)=REAL(ICNT2)
13562         DCOLOR(ICNT)=ACOL
13563C
13564         IF(IFLAGU.EQ.1 .AND. XCOOR3.NE.XCOOR4)THEN
13565           ICNT2=ICNT2+1
13566           ICNT=ICNT+1
13567           X(ICNT)=XCOOR4
13568           Y(ICNT)=YCOOR2
13569           D(ICNT)=REAL(ICNT2)
13570           DCOLOR(ICNT)=3.0
13571C
13572           ICNT=ICNT+1
13573           X(ICNT)=XCOOR4
13574           Y(ICNT)=YCOOR1
13575           D(ICNT)=REAL(ICNT2)
13576           DCOLOR(ICNT)=3.0
13577C
13578           ICNT=ICNT+1
13579           X(ICNT)=XCOOR3
13580           Y(ICNT)=YCOOR1
13581           D(ICNT)=REAL(ICNT2)
13582           DCOLOR(ICNT)=3.0
13583C
13584           ICNT=ICNT+1
13585           X(ICNT)=XCOOR3
13586           Y(ICNT)=YCOOR2
13587           D(ICNT)=REAL(ICNT2)
13588           DCOLOR(ICNT)=3.0
13589C
13590           ICNT=ICNT+1
13591           X(ICNT)=XCOOR4
13592           Y(ICNT)=YCOOR2
13593           D(ICNT)=REAL(ICNT2)
13594           DCOLOR(ICNT)=3.0
13595C
13596         ENDIF
13597C
13598         IF(IFLAGU.GE.1 .AND. XCOOR3.NE.XCOOR5)THEN
13599           ICNT2=ICNT2+1
13600           ICNT=ICNT+1
13601           X(ICNT)=XCOOR3
13602           Y(ICNT)=YCOOR2
13603           D(ICNT)=REAL(ICNT2)
13604           DCOLOR(ICNT)=4.0
13605C
13606           ICNT=ICNT+1
13607           X(ICNT)=XCOOR3
13608           Y(ICNT)=YCOOR1
13609           D(ICNT)=REAL(ICNT2)
13610           DCOLOR(ICNT)=4.0
13611C
13612           ICNT=ICNT+1
13613           X(ICNT)=XCOOR5
13614           Y(ICNT)=YCOOR1
13615           D(ICNT)=REAL(ICNT2)
13616           DCOLOR(ICNT)=4.0
13617C
13618           ICNT=ICNT+1
13619           X(ICNT)=XCOOR5
13620           Y(ICNT)=YCOOR2
13621           D(ICNT)=REAL(ICNT2)
13622           DCOLOR(ICNT)=4.0
13623C
13624           ICNT=ICNT+1
13625           X(ICNT)=XCOOR3
13626           Y(ICNT)=YCOOR2
13627           D(ICNT)=REAL(ICNT2)
13628           DCOLOR(ICNT)=4.0
13629         ENDIF
13630C
13631         IF(IFLAGU.EQ.1)THEN
13632           ICNT2=ICNT2+1
13633           ICNT=ICNT+1
13634           X(ICNT)=XCOOR3
13635           Y(ICNT)=(YCOOR1 + YCOOR2)/2.0
13636           D(ICNT)=REAL(ICNT2)
13637           DCOLOR(ICNT)=5.0
13638C
13639           ICNT2=ICNT2+1
13640           ICNT=ICNT+1
13641           X(ICNT)=XCOOR3
13642           Y(ICNT)=YCOOR1
13643           D(ICNT)=REAL(ICNT2)
13644           DCOLOR(ICNT)=6.0
13645C
13646           ICNT=ICNT+1
13647           X(ICNT)=XCOOR3
13648           Y(ICNT)=YCOOR2
13649           D(ICNT)=REAL(ICNT2)
13650           DCOLOR(ICNT)=6.0
13651C
13652         ENDIF
13653C
13654      ELSE
13655         ICNT2=ICNT2+1
13656         ICNT=ICNT+1
13657         X(ICNT)=XCOOR1
13658         Y(ICNT)=YCOOR1
13659         D(ICNT)=REAL(ICNT2)
13660         DCOLOR(ICNT)=ACOL
13661C
13662         ICNT=ICNT+1
13663         X(ICNT)=XCOOR2
13664         Y(ICNT)=YCOOR1
13665         D(ICNT)=REAL(ICNT2)
13666         DCOLOR(ICNT)=ACOL
13667C
13668         ICNT=ICNT+1
13669         X(ICNT)=XCOOR2
13670         Y(ICNT)=YCOOR3
13671         D(ICNT)=REAL(ICNT2)
13672         DCOLOR(ICNT)=ACOL
13673C
13674         ICNT=ICNT+1
13675         X(ICNT)=XCOOR1
13676         Y(ICNT)=YCOOR3
13677         D(ICNT)=REAL(ICNT2)
13678         DCOLOR(ICNT)=ACOL
13679C
13680         ICNT=ICNT+1
13681         X(ICNT)=XCOOR1
13682         Y(ICNT)=YCOOR1
13683         D(ICNT)=REAL(ICNT2)
13684         DCOLOR(ICNT)=ACOL
13685C
13686         IF(IFLAGU.EQ.1 .AND. YCOOR3.NE.YCOOR4)THEN
13687           ICNT2=ICNT2+1
13688           ICNT=ICNT+1
13689           X(ICNT)=XCOOR1
13690           Y(ICNT)=YCOOR4
13691           D(ICNT)=REAL(ICNT2)
13692           DCOLOR(ICNT)=3.0
13693C
13694           ICNT=ICNT+1
13695           X(ICNT)=XCOOR2
13696           Y(ICNT)=YCOOR4
13697           D(ICNT)=REAL(ICNT2)
13698           DCOLOR(ICNT)=3.0
13699C
13700           ICNT=ICNT+1
13701           X(ICNT)=XCOOR2
13702           Y(ICNT)=YCOOR3
13703           D(ICNT)=REAL(ICNT2)
13704           DCOLOR(ICNT)=3.0
13705C
13706           ICNT=ICNT+1
13707           X(ICNT)=XCOOR1
13708           Y(ICNT)=YCOOR3
13709           D(ICNT)=REAL(ICNT2)
13710           DCOLOR(ICNT)=3.0
13711C
13712           ICNT=ICNT+1
13713           X(ICNT)=XCOOR1
13714           Y(ICNT)=YCOOR4
13715           D(ICNT)=REAL(ICNT2)
13716           DCOLOR(ICNT)=3.0
13717C
13718         ENDIF
13719C
13720         IF(IFLAGU.GE.1 .AND. YCOOR3.NE.YCOOR5)THEN
13721           ICNT2=ICNT2+1
13722           ICNT=ICNT+1
13723           X(ICNT)=XCOOR1
13724           Y(ICNT)=YCOOR3
13725           D(ICNT)=REAL(ICNT2)
13726           DCOLOR(ICNT)=4.0
13727C
13728           ICNT=ICNT+1
13729           X(ICNT)=XCOOR2
13730           Y(ICNT)=YCOOR3
13731           D(ICNT)=REAL(ICNT2)
13732           DCOLOR(ICNT)=4.0
13733C
13734           ICNT=ICNT+1
13735           X(ICNT)=XCOOR2
13736           Y(ICNT)=YCOOR5
13737           D(ICNT)=REAL(ICNT2)
13738           DCOLOR(ICNT)=4.0
13739C
13740           ICNT=ICNT+1
13741           X(ICNT)=XCOOR1
13742           Y(ICNT)=YCOOR5
13743           D(ICNT)=REAL(ICNT2)
13744           DCOLOR(ICNT)=4.0
13745C
13746           ICNT=ICNT+1
13747           X(ICNT)=XCOOR1
13748           Y(ICNT)=YCOOR3
13749           D(ICNT)=REAL(ICNT2)
13750           DCOLOR(ICNT)=4.0
13751         ENDIF
13752C
13753         IF(IFLAGU.EQ.1)THEN
13754           ICNT2=ICNT2+1
13755           ICNT=ICNT+1
13756           X(ICNT)=(XCOOR1 + XCOOR2)/2.0
13757           Y(ICNT)=YCOOR3
13758           D(ICNT)=REAL(ICNT2)
13759           DCOLOR(ICNT)=5.0
13760C
13761           ICNT2=ICNT2+1
13762           ICNT=ICNT+1
13763           X(ICNT)=XCOOR1
13764           Y(ICNT)=YCOOR3
13765           D(ICNT)=REAL(ICNT2)
13766           DCOLOR(ICNT)=6.0
13767C
13768           ICNT=ICNT+1
13769           X(ICNT)=XCOOR2
13770           Y(ICNT)=YCOOR3
13771           D(ICNT)=REAL(ICNT2)
13772           DCOLOR(ICNT)=6.0
13773C
13774         ENDIF
13775C
13776      ENDIF
13777C
13778      RETURN
13779      END
13780      SUBROUTINE DPFONT(IHARG,NUMARG,
13781     1IDEFFO,
13782     1ITEXFO,
13783     1IBUGD2,ISUBRO,IFOUND,IERROR)
13784C
13785C     PURPOSE--DEFINE THE FONT TYPE FOR
13786C              TITLE, LABEL, AND LEGEND SCRIPT
13787C              ON A PLOT.
13788C              THE FONT FOR THE SCRIPT WILL BE PLACED
13789C              IN THE CHARACTER VARIABLE ITEXFO.
13790C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
13791C                     --NUMARG
13792C                     --IDEFFO
13793C                     --IBUGD2
13794C     OUTPUT ARGUMENTS--ITEXFO
13795C                     --IERROR ('YES' OR 'NO' )
13796C     WRITTEN BY--JAMES J. FILLIBEN
13797C                 STATISTICAL ENGINEERING DIVISION
13798C                 INFORMATION TECHNOLOGY LABORATORY
13799C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
13800C                 GAITHERSBURG, MD 20899-8980
13801C                 PHONE--301-975-2855
13802C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
13803C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
13804C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
13805C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
13806C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
13807C     LANGUAGE--ANSI FORTRAN (1977)
13808C     VERSION NUMBER--82/7
13809C     ORIGINAL VERSION--SEPTEMBER 1980.
13810C     UPDATED         --APRIL     1981.
13811C     UPDATED         --MAY       1982.
13812C
13813C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
13814C
13815      CHARACTER*4 IHARG
13816      CHARACTER*4 IDEFFO
13817      CHARACTER*4 ITEXFO
13818      CHARACTER*4 IBUGD2
13819      CHARACTER*4 ISUBRO
13820      CHARACTER*4 IFOUND
13821      CHARACTER*4 IERROR
13822C
13823C---------------------------------------------------------------------
13824C
13825      DIMENSION IHARG(*)
13826C
13827C---------------------------------------------------------------------
13828C
13829      INCLUDE 'DPCOP2.INC'
13830C
13831C-----START POINT-----------------------------------------------------
13832C
13833      IFOUND='NO'
13834      IERROR='NO'
13835C
13836      IF(IBUGD2.EQ.'OFF')GOTO90
13837      WRITE(ICOUT,999)
13838  999 FORMAT(1X)
13839      CALL DPWRST('XXX','BUG ')
13840      WRITE(ICOUT,51)
13841   51 FORMAT('***** AT THE BEGINNING OF DPFONT--')
13842      CALL DPWRST('XXX','BUG ')
13843      WRITE(ICOUT,53)IDEFFO
13844   53 FORMAT('IDEFFO = ',A4)
13845      CALL DPWRST('XXX','BUG ')
13846      WRITE(ICOUT,54)NUMARG
13847   54 FORMAT('NUMARG = ',I8)
13848      CALL DPWRST('XXX','BUG ')
13849      DO55I=1,NUMARG
13850      WRITE(ICOUT,56)I,IHARG(I)
13851   56 FORMAT('I,IHARG(I) = ',I8,2X,A4)
13852      CALL DPWRST('XXX','BUG ')
13853   55 CONTINUE
13854   90 CONTINUE
13855C
13856C               ***************************
13857C               **  TREAT THE FONT CASE  **
13858C               ***************************
13859C
13860      IF(NUMARG.LE.0)GOTO1120
13861      IF(IHARG(NUMARG).EQ.'ON')GOTO1120
13862      IF(IHARG(NUMARG).EQ.'OFF')GOTO1120
13863      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1120
13864      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1120
13865      IF(IHARG(NUMARG).EQ.'?')GOTO8100
13866      GOTO1140
13867C
13868 1120 CONTINUE
13869      ITEXFO=IDEFFO
13870      GOTO1180
13871C
13872 1140 CONTINUE
13873      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'SIMP')GOTO1141
13874      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'DUPL')GOTO1142
13875      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'TRIP')GOTO1143
13876      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'COMP')GOTO1144
13877      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'TRIP'.AND.
13878     1IHARG(2).EQ.'ITAL')GOTO1145
13879      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'TRII')GOTO1145
13880      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'COMP'.AND.
13881     1IHARG(2).EQ.'ITAL')GOTO1146
13882      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'COMI')GOTO1146
13883      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'SIMP'.AND.
13884     1IHARG(2).EQ.'SCRI')GOTO1147
13885      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'SIMS')GOTO1147
13886      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'COMP'.AND.
13887     1IHARG(2).EQ.'SCRI')GOTO1148
13888      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'COMS')GOTO1148
13889C
13890      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEKT')GOTO1151
13891      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEK')GOTO1151
13892C
13893      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'HEWL'.AND.
13894     1IHARG(2).EQ.'PACK')GOTO1152
13895      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'HP')GOTO1152
13896C
13897      IERROR='YES'
13898      WRITE(ICOUT,1131)
13899 1131 FORMAT('***** ERROR IN DPFONT--')
13900      CALL DPWRST('XXX','BUG ')
13901      WRITE(ICOUT,1132)
13902 1132 FORMAT('      ILLEGAL ENTRY FOR FONT ',
13903     1'COMMAND.')
13904      CALL DPWRST('XXX','BUG ')
13905      WRITE(ICOUT,1133)
13906 1133 FORMAT('      TEST EXAMPLE TO DEMONSTRATE THE ',
13907     1'PROPER FORM--')
13908      CALL DPWRST('XXX','BUG ')
13909      WRITE(ICOUT,1134)
13910 1134 FORMAT('      SUPPOSE THE THE ANALYST WISHES ')
13911      CALL DPWRST('XXX','BUG ')
13912      WRITE(ICOUT,1135)
13913 1135 FORMAT('      TO SET THE FONT TO TRIPLEX ITALIC ')
13914      CALL DPWRST('XXX','BUG ')
13915      WRITE(ICOUT,1136)
13916 1136 FORMAT('      FOR PLOT TITLES, LABELS, ETC.,')
13917      CALL DPWRST('XXX','BUG ')
13918      WRITE(ICOUT,1137)
13919 1137 FORMAT('      THEN 2 ALLOWABLE FORMS ARE--')
13920      CALL DPWRST('XXX','BUG ')
13921      WRITE(ICOUT,1138)
13922 1138 FORMAT('            FONT TRIPLEX ITALIC ')
13923      CALL DPWRST('XXX','BUG ')
13924      WRITE(ICOUT,1139)
13925 1139 FORMAT('            FONT TRII ')
13926      CALL DPWRST('XXX','BUG ')
13927      GOTO9000
13928C
13929 1141 CONTINUE
13930      ITEXFO='SIMP'
13931      GOTO1180
13932C
13933 1142 CONTINUE
13934      ITEXFO='DUPL'
13935      GOTO1180
13936C
13937 1143 CONTINUE
13938      ITEXFO='TRIP'
13939      GOTO1180
13940C
13941 1144 CONTINUE
13942      ITEXFO='COMP'
13943      GOTO1180
13944C
13945 1145 CONTINUE
13946      ITEXFO='TRII'
13947      GOTO1180
13948C
13949 1146 CONTINUE
13950      ITEXFO='COMI'
13951      GOTO1180
13952C
13953 1147 CONTINUE
13954      ITEXFO='SIMS'
13955      GOTO1180
13956C
13957 1148 CONTINUE
13958      ITEXFO='COMS'
13959      GOTO1180
13960C
13961 1151 CONTINUE
13962      ITEXFO='TEKT'
13963      GOTO1180
13964C
13965 1152 CONTINUE
13966      ITEXFO='HEWL'
13967      GOTO1180
13968C
13969 1180 CONTINUE
13970      IFOUND='YES'
13971C
13972      IF(IFEEDB.EQ.'OFF')GOTO1189
13973      WRITE(ICOUT,999)
13974      CALL DPWRST('XXX','BUG ')
13975      WRITE(ICOUT,1181)
13976 1181 FORMAT('THE FONT (FOR PLOT SCRIPT AND TEXT)')
13977      CALL DPWRST('XXX','BUG ')
13978      WRITE(ICOUT,1182)ITEXFO
13979 1182 FORMAT('HAS JUST BEEN SET TO ',A4)
13980      CALL DPWRST('XXX','BUG ')
13981 1189 CONTINUE
13982      GOTO9000
13983C
13984C               ********************************************
13985C               **  STEP 81--                             **
13986C               **  TREAT THE    ?    CASE--              **
13987C               **  DUMP OUT CURRENT AND DEFAULT VALUES.  **
13988C               ********************************************
13989C
13990 8100 CONTINUE
13991      IFOUND='YES'
13992      WRITE(ICOUT,999)
13993      CALL DPWRST('XXX','BUG ')
13994      WRITE(ICOUT,8111)ITEXFO
13995 8111 FORMAT('THE CURRENT FONT IS ',A4)
13996      CALL DPWRST('XXX','BUG ')
13997      WRITE(ICOUT,8112)IDEFFO
13998 8112 FORMAT('THE DEFAULT FONT IS ',A4)
13999      CALL DPWRST('XXX','BUG ')
14000      GOTO9000
14001C
14002C               *****************
14003C               **  STEP 90--  **
14004C               **  EXIT       **
14005C               *****************
14006C
14007 9000 CONTINUE
14008      IF(IBUGD2.EQ.'OFF')GOTO9090
14009      WRITE(ICOUT,999)
14010      CALL DPWRST('XXX','BUG ')
14011      WRITE(ICOUT,9011)
14012 9011 FORMAT('***** AT THE END       OF DPFONT--')
14013      CALL DPWRST('XXX','BUG ')
14014      WRITE(ICOUT,9012)IBUGD2,ISUBRO,IFOUND,IERROR
14015 9012 FORMAT('IBUGD2,ISUBRO,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
14016      CALL DPWRST('XXX','BUG ')
14017      WRITE(ICOUT,9013)IDEFFO,ITEXFO
14018 9013 FORMAT('IDEFFO,ITEXFO = ',A4,2X,A4)
14019      CALL DPWRST('XXX','BUG ')
14020 9090 CONTINUE
14021C
14022      RETURN
14023      END
14024      SUBROUTINE DPFOR(NIOLD,NINEW,IROW1,IROWN,
14025     1                 NLOCAL,ILOCS,NS,IBUGQ,IERROR)
14026C
14027C     PURPOSE--DEFINE AN INTEGER 0-1 VECTOR ISUB
14028C              WHICH WILL BE USED IN OTHER SUBROUTINES
14029C              FOR EXTRACTING SUBSETS.
14030C     ALLOWABLE FORMS--FOR XX <  XX
14031C                      FOR XX <= XX
14032C                      FOR XX =  XX
14033C                      FOR XX =  XX XX XX
14034C                      FOR XX =  XX TO XX
14035C                      FOR XX >= XX
14036C                      FOR XX >  XX
14037C     INPUT  ARGUMENTS--NIOLD  = THE ORIGINAL NUMBER OF
14038C                                ELEMENTS (ROWS) FOR THE LEFT-SIDE VARIABLE.
14039C                                (IT MAY BE ZERO).
14040C     OUTPUT ARGUMENTS--NINEW  = THE NEW NUMBER OF ELEMENTS (ROWS)
14041C                                FOR THE LEFT-SIDE VARIABLE.
14042C                                NINEW EQUALS MAX(NIOLD,IROWN)
14043C                     --IROW1  = THE FIRST ROW TO BE CHANGED.
14044C                     --IROWN  = THE LAST ROW TO BE CHANGED.
14045C     NOTE THAT IF THE WORD 'FOR' IS NOT IN THE ARGUMENT LIST,
14046C     THEN THE OUTPUT PARAMETER WILL BE SET TO NUMARG+1.
14047C     WRITTEN BY--JAMES J. FILLIBEN
14048C                 STATISTICAL ENGINEERING DIVISION
14049C                 INFORMATION TECHNOLOGY LABORATORY
14050C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
14051C                 GAITHERSBURG, MD 20899-8980
14052C                 PHONE--301-975-2855
14053C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
14054C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
14055C     LANGUAGE--ANSI FORTRAN (1977)
14056C     VERSION NUMBER--82/7
14057C     ORIGINAL VERSION--JANUARY  1978.
14058C     UPDATED         --JANUARY   1978.
14059C     UPDATED         --FEBRUARY  1978.
14060C     UPDATED         --JULY      1978.
14061C     UPDATED         --OCTOBER   1978.
14062C     UPDATED         --NOVEMBER  1978.
14063C     UPDATED         --NOVEMBER  1980.
14064C     UPDATED         --JANUARY   1981.
14065C     UPDATED         --JULY      1981.
14066C     UPDATED         --SEPTEMBER 1981.
14067C     UPDATED         --OCTOBER   1981.
14068C     UPDATED         --DECEMBER  1981.
14069C     UPDATED         --MARCH     1982.
14070C     UPDATED         --MAY       1982.
14071C
14072C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
14073C
14074      CHARACTER*4 IBUGQ
14075      CHARACTER*4 IERROR
14076C
14077      CHARACTER*4 MESSAG
14078      CHARACTER*4 IHWUSE
14079      CHARACTER*4 IH
14080      CHARACTER*4 IH2
14081C
14082      CHARACTER*4 ISUBN1
14083      CHARACTER*4 ISUBN2
14084      CHARACTER*4 ISTEPN
14085C
14086C---------------------------------------------------------------------
14087C
14088C-----COMMON----------------------------------------------------------
14089C
14090      INCLUDE 'DPCOPA.INC'
14091      INCLUDE 'DPCOHK.INC'
14092      INCLUDE 'DPCODA.INC'
14093      INCLUDE 'DPCOP2.INC'
14094C
14095C-----START POINT-----------------------------------------------------
14096C
14097      ISUBN1='DPFO'
14098      ISUBN2='R   '
14099      IERROR='NO'
14100C
14101      MAXCP1=MAXCOL+1
14102      MAXCP2=MAXCOL+2
14103      MAXCP3=MAXCOL+3
14104      MAXCP4=MAXCOL+4
14105      MAXCP5=MAXCOL+5
14106      MAXCP6=MAXCOL+6
14107C
14108      ILOCF=0
14109      NUMIT=0
14110      I2=0
14111C
14112C               **************************
14113C               **  TREAT THE FOR CASE  **
14114C               **************************
14115C
14116      IF(IBUGQ.EQ.'ON')THEN
14117        WRITE(ICOUT,999)
14118  999   FORMAT(1X)
14119        CALL DPWRST('XXX','BUG ')
14120        WRITE(ICOUT,51)
14121   51   FORMAT('***** AT THE BEGINNING OF DPFOR--')
14122        CALL DPWRST('XXX','BUG ')
14123        WRITE(ICOUT,52)NIOLD,NINEW,IROW1,IROWN
14124   52   FORMAT('NIOLD,NINEW,IROW1,IROWN = ',4I8)
14125        CALL DPWRST('XXX','BUG ')
14126        WRITE(ICOUT,53)NLOCAL,ILOCS,NS
14127   53   FORMAT('NLOCAL,ILOCS,NS = ',3I8)
14128        CALL DPWRST('XXX','BUG ')
14129        WRITE(ICOUT,54)IBUGQ,IERROR
14130   54   FORMAT('IBUGQ,IERROR = ',A4,2X,A4)
14131        CALL DPWRST('XXX','BUG ')
14132        WRITE(ICOUT,55)NUMARG,NUMNAM,MAXNAM,N
14133   55   FORMAT('NUMARG,NUMNAM,MAXNAM,N = ',5I8)
14134        CALL DPWRST('XXX','BUG ')
14135        WRITE(ICOUT,56)IWIDTH,NLOCAL,ILOCF,MAXN
14136   56   FORMAT('IWIDTH,NLOCAL,ILOCF,MAXN = ',4I8)
14137        CALL DPWRST('XXX','BUG ')
14138      ENDIF
14139C
14140C               *******************************************************
14141C               **  STEP 1--                                         **
14142C               **  INITIALIZE THE SUBSET SIZE (NS) TO MAXN.         **
14143C               **  CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS.  **
14144C               **  ALSO CHECK THAT THE RELEVANT NUMBER OF           **
14145C               **  OBSERVATIONS (NLOCAL) IS POSITIVE.               **
14146C               *******************************************************
14147C
14148      ISTEPN='1'
14149      IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14150C
14151      NLOCAL=MAXN
14152      NS=MAXN
14153      ILOCF=NUMARG+1
14154      MINNA=0
14155      MAXNA=100
14156      CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR)
14157      IF(IERROR.EQ.'YES')GOTO9000
14158C
14159      IF(NLOCAL.LT.1)THEN
14160        WRITE(ICOUT,999)
14161        CALL DPWRST('XXX','BUG ')
14162        WRITE(ICOUT,111)
14163  111   FORMAT('***** ERROR IN DPFOR--')
14164        CALL DPWRST('XXX','BUG ')
14165        WRITE(ICOUT,112)
14166  112   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS (FROM WHICH A')
14167        CALL DPWRST('XXX','BUG ')
14168        WRITE(ICOUT,113)
14169  113   FORMAT('      SUBSET WAS TO HAVE BEEN EXTRACTED) IS 0.')
14170        CALL DPWRST('XXX','BUG ')
14171        IERROR='YES'
14172        GOTO9000
14173      ENDIF
14174C
14175C               *************************************************
14176C               **  STEP 2--                                   **
14177C               **  INITIALIZE ALL ELEMENTS IN ISUB(.) TO 1 .  **
14178C               *************************************************
14179C
14180      ISTEPN='2'
14181      IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14182C
14183      DO200I=1,NLOCAL
14184        ISUB(I)=1
14185  200 CONTINUE
14186C
14187C               ************************************************
14188C               **  STEP 3.1--                                **
14189C               **  CHECK TO SEE IF HAVE THE 'FOR' CASE.      **
14190C               **  LOCATE THE POSITION IN THE ARGUMENT LIST  **
14191C               **  OF THE LAST OCCURRANCE OF THE WORD 'FOR'. **
14192C               ************************************************
14193C
14194      ISTEPN='3.1'
14195      IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14196C
14197      ILOCF=-1
14198      IF(NUMARG.LE.0)GOTO9000
14199      DO300J=1,NUMARG
14200        JP1=J+1
14201        IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.'    '.AND.
14202     1     IHARG(JP1).EQ.'I   '.AND.IHARG2(JP1).EQ.'    '.AND.
14203     1     JP1.LE.NUMARG)THEN
14204          ILOCF=J
14205        ENDIF
14206  300 CONTINUE
14207      IF(ILOCF.EQ.-1)THEN
14208        ILOCF=NUMARG+1
14209        GOTO9000
14210      ENDIF
14211C
14212C               *************************************************
14213C               **  STEP 3.2--                                 **
14214C               **  IF EXISTENT,                               **
14215C               **  PACK < = INTO <=                           **
14216C               **  PACK = < INTO =<                           **
14217C               **  PACK > = INTO >=                           **
14218C               **  PACK = > INTO =>                           **
14219C               **  THIS IS BECAUSE = SIGNS ARE AUTOMATICALLY  **
14220C               **  GIVEN A SPACE IN DPTYPE AND TREATED AS     **
14221C               **  AS A SEPARATE WORD.                        **
14222C               **  NOTE THAT NUMARG WILL BE CHANGED.          **
14223C               *************************************************
14224C
14225      ISTEPN='3.2'
14226      IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14227C
14228      CALL ADJUS2(IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
14229C
14230C               ***********************************************
14231C               **  STEP 4--                                 **
14232C               **  CHECK THAT FOR IS SUCCEEDED BY AT LEAST  **
14233C               **  3 OTHER ARGUMENTS.                       **
14234C               ***********************************************
14235C
14236      ISTEPN='4'
14237      IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14238C
14239      ILOCF3=ILOCF+3
14240      IF(ILOCF3.GT.NUMARG)THEN
14241        WRITE(ICOUT,111)
14242        CALL DPWRST('XXX','BUG ')
14243        WRITE(ICOUT,402)
14244  402   FORMAT('      THE WORD    FOR    SHOULD HAVE BEEN FOLLOWED')
14245        CALL DPWRST('XXX','BUG ')
14246        WRITE(ICOUT,403)
14247  403   FORMAT('      BY EXACTLY 3 OR BY EXACTLY 5    WORDS   --')
14248        CALL DPWRST('XXX','BUG ')
14249        WRITE(ICOUT,404)
14250  404   FORMAT('      1) A DUMMY VARIABLE NAME;')
14251        CALL DPWRST('XXX','BUG ')
14252        WRITE(ICOUT,405)
14253  405   FORMAT('      2) AN EQUAL SIGN;')
14254        CALL DPWRST('XXX','BUG ')
14255        WRITE(ICOUT,406)
14256  406   FORMAT('      3) ONE LIMIT (LOWER OR UPPER) FOR THE DUMMY ',
14257     1         'VARIABLE;')
14258        CALL DPWRST('XXX','BUG ')
14259        WRITE(ICOUT,409)
14260  409   FORMAT('      4) THE INCREMENT FOR THE DUMMY VARIABLE;')
14261        CALL DPWRST('XXX','BUG ')
14262        WRITE(ICOUT,410)
14263  410   FORMAT('      5) THE OTHER LIMIT (UPPER OR LOWER) ',
14264     1         'FOR THE DUMMY VARIABLE.')
14265        CALL DPWRST('XXX','BUG ')
14266        WRITE(ICOUT,999)
14267        CALL DPWRST('XXX','BUG ')
14268        WRITE(ICOUT,421)
14269  421   FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
14270        CALL DPWRST('XXX','BUG ')
14271        IF(IWIDTH.GE.1)THEN
14272          WRITE(ICOUT,422)(IANS(I),I=1,MIN(100,IWIDTH))
14273  422     FORMAT('      ',100A1)
14274          CALL DPWRST('XXX','BUG ')
14275        ENDIF
14276        IERROR='YES'
14277        GOTO9000
14278      ENDIF
14279C
14280C               *************************************
14281C               **  STEP 5--                       **
14282C               **  FORM THE 3 INTERNAL VALUES--   **
14283C               **  START, AINC, AND STOP.         **
14284C               *************************************
14285C
14286      ISTEPN='5'
14287      IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14288C
14289      ILOCF2=ILOCF+2
14290      ILOCF3=ILOCF+3
14291      ILOCF4=ILOCF+4
14292      ILOCF5=ILOCF+5
14293C
14294      ILOCA=ILOCF3
14295      IF(IARGT(ILOCA).EQ.'NUMB')THEN
14296        START=ARG(ILOCA)
14297        IF(IHARG(ILOCF2).EQ.'=   ')GOTO519
14298        AINC=0.0
14299        STOP=ARG(ILOCA)
14300        IF(IHARG(ILOCF2).EQ.'<   ')THEN
14301          START=1.0
14302          AINC=1.0
14303          STOP=ARG(ILOCA)-1.0
14304          GOTO580
14305        ELSEIF(IHARG(ILOCF2).EQ.'<=  ' .OR. IHARG(ILOCF2).EQ.'=<  ')THEN
14306          START=1.0
14307          AINC=1.0
14308          STOP=ARG(ILOCA)
14309          GOTO580
14310        ELSEIF(IHARG(ILOCF2).EQ.'>=  ' .OR. IHARG(ILOCF2).EQ.'>=  ')THEN
14311          START=ARG(ILOCA)
14312          AINC=1.0
14313          STOP=NIOLD
14314          GOTO580
14315        ELSEIF(IHARG(ILOCF2).EQ.'>   ')THEN
14316          START=ARG(ILOCA)+1.0
14317          AINC=1.0
14318          STOP=NIOLD
14319          GOTO580
14320        ENDIF
14321        GOTO519
14322      ELSEIF(IARGT(ILOCA).EQ.'WORD')THEN
14323        IH=IHARG(ILOCA)
14324        IH2=IHARG2(ILOCA)
14325        MESSAG='YES'
14326        IHWUSE='P'
14327        CALL CHECKN(IH,IH2,IHWUSE,
14328     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
14329     1              ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR)
14330        IF(IERROR.EQ.'YES')GOTO9000
14331        START=VALUE(ILOC)
14332        IF(IHARG(ILOCF2).EQ.'=   ')GOTO519
14333        AINC=0.0
14334        STOP=VALUE(ILOC)
14335        IF(IHARG(ILOCF2).EQ.'<   ')THEN
14336          START=1.0
14337          AINC=1.0
14338          STOP=VALUE(ILOC)-1.0
14339          GOTO580
14340        ELSEIF(IHARG(ILOCF2).EQ.'<=  ' .OR. IHARG(ILOCF2).EQ.'=<  ')THEN
14341          START=1.0
14342          AINC=1.0
14343          STOP=VALUE(ILOC)
14344          GOTO580
14345        ELSEIF(IHARG(ILOCF2).EQ.'>=  ' .OR. IHARG(ILOCF2).EQ.'=>  ')THEN
14346          START=VALUE(ILOC)
14347          AINC=1.0
14348          STOP=NIOLD
14349          GOTO580
14350        ELSEIF(IHARG(ILOCF2).EQ.'>   ')THEN
14351          START=VALUE(ILOC)+1.0
14352          AINC=1.0
14353          STOP=NIOLD
14354          GOTO580
14355        ENDIF
14356      ENDIF
14357      GOTO570
14358C
14359  519 CONTINUE
14360C
14361      ILOCA=ILOCF4
14362      IF(ILOCA.GT.NUMARG)THEN
14363        AINC=0.0
14364        GOTO529
14365      ELSEIF(ILOCA.EQ.NUMARG.AND.IHARG(ILOCA).EQ.'AND'.AND.
14366     1   IHARG2(ILOCA).EQ.'    ')THEN
14367        AINC=0.0
14368        GOTO529
14369      ELSEIF(IARGT(ILOCA).EQ.'NUMB')THEN
14370        AINC=ARG(ILOCA)
14371        GOTO529
14372      ELSEIF(IARGT(ILOCA).EQ.'WORD'.AND.IHARG(ILOCA).EQ.'TO  ')THEN
14373        AINC=1.0
14374        GOTO529
14375      ELSEIF(IARGT(ILOCA).EQ.'WORD'.AND.IHARG(ILOCA).NE.'TO  ')THEN
14376        IH=IHARG(ILOCA)
14377        IH2=IHARG2(ILOCA)
14378        MESSAG='YES'
14379        IHWUSE='P'
14380        CALL CHECKN(IH,IH2,IHWUSE,
14381     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
14382     1              ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR)
14383        IF(IERROR.EQ.'YES')GOTO9000
14384        AINC=VALUE(ILOC)
14385        GOTO529
14386      ENDIF
14387      GOTO570
14388C
14389  529 CONTINUE
14390      ILOCA=ILOCF5
14391      IF(ILOCA.GT.NUMARG)THEN
14392        STOP=START
14393        GOTO580
14394      ELSEIF(ILOCA.EQ.NUMARG.AND.IHARG(ILOCA).EQ.'AND'.AND.
14395     1   IHARG2(ILOCA).EQ.'    ')THEN
14396        STOP=START
14397        GOTO580
14398      ELSEIF(IARGT(ILOCA).EQ.'NUMB')THEN
14399        STOP=ARG(ILOCA)
14400        GOTO580
14401      ELSEIF(IARGT(ILOCA).EQ.'WORD')THEN
14402        IH=IHARG(ILOCA)
14403        IH2=IHARG2(ILOCA)
14404        MESSAG='YES'
14405        IHWUSE='P'
14406        CALL CHECKN(IH,IH2,IHWUSE,
14407     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
14408     1              ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR)
14409        IF(IERROR.EQ.'YES')GOTO9000
14410        STOP=VALUE(ILOC)
14411        GOTO580
14412      ENDIF
14413      GOTO570
14414C
14415  570 CONTINUE
14416      WRITE(ICOUT,571)
14417  571 FORMAT('***** INTERNAL ERROR IN DPFOR--')
14418      CALL DPWRST('XXX','BUG ')
14419      WRITE(ICOUT,572)
14420  572 FORMAT('      AN ARGUMENT TYPE WHICH SHOULD BE')
14421      CALL DPWRST('XXX','BUG ')
14422      WRITE(ICOUT,573)
14423  573 FORMAT('      EITHER A NUMBER OR A WORD, IS NEITHER.')
14424      CALL DPWRST('XXX','BUG ')
14425      WRITE(ICOUT,574)IHARG(ILOCA),IHARG2(ILOCA)
14426  574 FORMAT('      ARGUMENT                  = ',2A4)
14427      CALL DPWRST('XXX','BUG ')
14428      WRITE(ICOUT,575)ILOCA
14429  575 FORMAT('      LOCATION IN ARGUMENT LIST = ',I8)
14430      CALL DPWRST('XXX','BUG ')
14431      WRITE(ICOUT,576)IARGT(ILOCA)
14432  576 FORMAT('      ARGUMENT TYPE             = ',A4)
14433      CALL DPWRST('XXX','BUG ')
14434      WRITE(ICOUT,421)
14435      CALL DPWRST('XXX','BUG ')
14436      IF(IWIDTH.GE.1)THEN
14437        WRITE(ICOUT,422)(IANS(I),I=1,MIN(100,IWIDTH))
14438        CALL DPWRST('XXX','BUG ')
14439      ENDIF
14440      IERROR='YES'
14441      GOTO9000
14442C
14443  580 CONTINUE
14444      IF(START.EQ.STOP)AINC=0.0
14445      IF(START.LT.STOP.AND.AINC.LT.0.0)AINC=-AINC
14446      IF(START.GT.STOP.AND.AINC.GT.0.0)AINC=-AINC
14447C
14448C               *****************************************************
14449C               **  STEP 6--                                       **
14450C               **  FORM THE ISUB(.) VECTOR;                       **
14451C               **  DETERMINE ALSO--                               **
14452C               **  THE FIRST ROW CHANGED (IROW1),                 **
14453C               **  THE ROW INCREMENT (IROWIN),                    **
14454C               **  THE LAST  ROW CHANGED (IROWN),                 **
14455C               **  THE NUMBER OF ROWS CHANGED (NS),               **
14456C               **  AND THE OUTPUT NUMBER OF ROWS (NINEW).         **
14457C               **  (THAT IS, THE SUBSET SAMPLE SIZE).             **
14458C               *****************************************************
14459C
14460      ISTEPN='6'
14461      IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14462C
14463      DO600I=1,MAXN
14464        ISUB(I)=0
14465  600 CONTINUE
14466C
14467C     2016/07: FOR LARGE VALUES OF MAXOBV, NEED TO BE CAREFUL WITH
14468C              ARITHMETIC HERE.
14469C
14470      IF(AINC.EQ.0.0)THEN
14471        NUMIT=1
14472      ELSEIF(AINC.NE.0.0)THEN
14473        NUMIT=INT((STOP-START)/AINC + 0.1)
14474        IF(NUMIT.LT.0.0)NUMIT=-NUMIT
14475        NUMIT=NUMIT+1
14476        IF(NUMIT.GT.MAXN)NUMIT=MAXN
14477      ENDIF
14478C
14479      L2=0
14480      DO620I=1,NUMIT
14481        I2=I
14482        I2M1=I2-1
14483        AI=I
14484        RESULT=START+(AI-1.0)*AINC
14485        IF(I.NE.1)THEN
14486          IF(AINC.EQ.0.0 .OR. START.EQ.STOP .OR.
14487     1      (START.LT.STOP.AND.RESULT.GT.STOP) .OR.
14488     1      (START.GT.STOP.AND.RESULT.LT.STOP))THEN
14489            NS=I2M1
14490            GOTO690
14491          ENDIF
14492        ENDIF
14493        L2=L2+1
14494C
14495        IF(L2.GT.MAXN)THEN
14496          WRITE(ICOUT,111)
14497          CALL DPWRST('XXX','BUG ')
14498          WRITE(ICOUT,633)MAXN
14499  633     FORMAT('      THE NUMBER OF GENERATED POINTS HAS JUST ',
14500     1           'EXCEEDED ',I8)
14501          CALL DPWRST('XXX','BUG ')
14502          WRITE(ICOUT,421)
14503          CALL DPWRST('XXX','BUG ')
14504          IF(IWIDTH.GE.1)THEN
14505            WRITE(ICOUT,422)(IANS(II),II=1,MIN(100,IWIDTH))
14506            CALL DPWRST('XXX','BUG ')
14507          ENDIF
14508          IERROR='YES'
14509          GOTO9000
14510        ENDIF
14511C
14512        XTEMP=RESULT
14513        ITEMP=INT(XTEMP+0.5)
14514        IF(ITEMP.GT.MAXN)THEN
14515          WRITE(ICOUT,642)
14516  642     FORMAT('***** ERROR IN DPFOR--')
14517          CALL DPWRST('XXX','BUG ')
14518          WRITE(ICOUT,643)MAXN
14519  643     FORMAT('      A REFERENCED ROW NUMBER HAS JUST EXCEEDED ',I8)
14520          CALL DPWRST('XXX','BUG ')
14521          WRITE(ICOUT,421)
14522          CALL DPWRST('XXX','BUG ')
14523          IF(IWIDTH.GE.1)THEN
14524            WRITE(ICOUT,422)(IANS(II),II=1,MIN(100,IWIDTH))
14525            CALL DPWRST('XXX','BUG ')
14526          ENDIF
14527          IERROR='YES'
14528          GOTO9000
14529        ELSEIF(ITEMP.LT.1)THEN
14530          WRITE(ICOUT,652)
14531  652     FORMAT('***** ERROR IN DPFOR--')
14532          CALL DPWRST('XXX','BUG ')
14533          WRITE(ICOUT,653)
14534  653     FORMAT('      A REFERENCED ROW NUMBER IS LESS THAN 1.')
14535          CALL DPWRST('XXX','BUG ')
14536          WRITE(ICOUT,421)
14537          CALL DPWRST('XXX','BUG ')
14538          IF(IWIDTH.GE.1)THEN
14539            WRITE(ICOUT,422)(IANS(II),II=1,MIN(100,IWIDTH))
14540            CALL DPWRST('XXX','BUG ')
14541          ENDIF
14542          IERROR='YES'
14543          GOTO9000
14544        ENDIF
14545C
14546        ISUB(ITEMP)=1
14547        IF(I.EQ.1)IROW1=ITEMP
14548        IROWN=ITEMP
14549  620 CONTINUE
14550      NS=I2
14551C
14552  690 CONTINUE
14553      NINEW=NIOLD
14554      IF(IROWN.GT.NIOLD)NINEW=IROWN
14555      IROWIN=INT(AINC+0.5)
14556C
14557C               *************************************************
14558C               **  STEP 7--                                   **
14559C               **  WRITE OUT A MESSAGE INDICATING             **
14560C               **  THE FIRST ROW CHANGED (IROW1),             **
14561C               **  THE ROW INCREMENT (IROWIN),                **
14562C               **  THE LAST  ROW CHANGED (IROWN),             **
14563C               **  THE INPUT NUMBER OF ROWS (NIOLD),          **
14564C               **  THE NUMBER OF ROWS CHANGED (NS),           **
14565C               **  AND THE OUTPUT NUMBER OF ROWS (NINEW).     **
14566C               **  (THAT IS, THE SUBSET SAMPLE SIZE).         **
14567C               **  ALSO, CHECK THAT NS IS POSITIVE.           **
14568C               *************************************************
14569C
14570      ISTEPN='7'
14571      IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14572C
14573      IF(IFEEDB.EQ.'ON')THEN
14574        WRITE(ICOUT,999)
14575        CALL DPWRST('XXX','BUG ')
14576        WRITE(ICOUT,701)
14577  701   FORMAT('***** NOTE--')
14578        CALL DPWRST('XXX','BUG ')
14579        WRITE(ICOUT,702)IROW1
14580  702   FORMAT('      ROW START      = ',I8)
14581        CALL DPWRST('XXX','BUG ')
14582        WRITE(ICOUT,703)IROWIN
14583  703   FORMAT('      ROW INCREMENT  = ',I8)
14584        CALL DPWRST('XXX','BUG ')
14585        WRITE(ICOUT,704)IROWN
14586  704   FORMAT('      ROW STOP       = ',I8)
14587        CALL DPWRST('XXX','BUG ')
14588        WRITE(ICOUT,705)NIOLD
14589  705   FORMAT('      INPUT  NUMBER OF ROWS   = ',I8)
14590        CALL DPWRST('XXX','BUG ')
14591        WRITE(ICOUT,706)NS
14592  706   FORMAT('      NUMBER OF ROWS AFFECTED = ',I8)
14593        CALL DPWRST('XXX','BUG ')
14594        WRITE(ICOUT,707)NINEW
14595  707   FORMAT('      OUTPUT NUMBER OF ROWS   = ',I8)
14596        CALL DPWRST('XXX','BUG ')
14597      ENDIF
14598C
14599CCCCC IF(NS.GE.1)GOTO790
14600CCCCC WRITE(ICOUT,999)
14601CCCCC CALL DPWRST('XXX','BUG ')
14602CCCCC WRITE(ICOUT,711)
14603CC711 FORMAT('***** ERROR IN DPFOR--')
14604CCCCC CALL DPWRST('XXX','BUG ')
14605CCCCC WRITE(ICOUT,712)
14606CC712 FORMAT('      THE SUBSET IS EMPTY--IT HAS NO ELEMENTS IN IT.')
14607CCCCC CALL DPWRST('XXX','BUG ')
14608CCCCC IERROR='YES'
14609CCCCC GOTO9000
14610C
14611CC790 CONTINUE
14612C
14613C               *****************
14614C               **  STEP 90--  **
14615C               **  EXIT       **
14616C               *****************
14617C
14618 9000 CONTINUE
14619      IF(IBUGQ.EQ.'ON')THEN
14620        WRITE(ICOUT,999)
14621        CALL DPWRST('XXX','BUG ')
14622        WRITE(ICOUT,9011)
14623 9011   FORMAT('***** AT THE END       OF DPFOR--')
14624        CALL DPWRST('XXX','BUG ')
14625        WRITE(ICOUT,9012)NIOLD,NINEW,IROW1,IROWN
14626 9012   FORMAT('NIOLD,NINEW,IROW1,IROWN = ',4I8)
14627        CALL DPWRST('XXX','BUG ')
14628        WRITE(ICOUT,9013)NLOCAL,ILOCS,NS
14629 9013   FORMAT('NLOCAL,ILOCS,NS = ',3I8)
14630        CALL DPWRST('XXX','BUG ')
14631        WRITE(ICOUT,9014)IBUGQ,IERROR
14632 9014   FORMAT('IBUGQ,IERROR = ',A4,2X,A4)
14633        CALL DPWRST('XXX','BUG ')
14634        WRITE(ICOUT,9015)NUMARG,NUMNAM,MAXNAM,N,MAXN
14635 9015   FORMAT('NUMARG,NUMNAM,MAXNAM,N,MAXN = ',5I8)
14636        CALL DPWRST('XXX','BUG ')
14637        WRITE(ICOUT,9016)IWIDTH,NLOCAL,ILOCF
14638 9016   FORMAT('IWIDTH,NLOCAL,ILOCF = ',3I8)
14639        CALL DPWRST('XXX','BUG ')
14640        DO9020I=1,NIOLD
14641          WRITE(ICOUT,9021)I,ISUB(I)
14642 9021     FORMAT('I,ISUB(I) = ',2I8)
14643          CALL DPWRST('XXX','BUG ')
14644 9020   CONTINUE
14645      ENDIF
14646C
14647      RETURN
14648      END
14649      SUBROUTINE DPFRAC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,ICONT,
14650     1                  IANGLU,ISEED,
14651CCCCC                   JULY 1993.  ADD FOLLOWING LINE.
14652     1                  IFRAIT,IFRATY,
14653     1                  IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
14654C
14655C     PURPOSE--GENERATE A FRACTAL PLOT
14656C     WRITTEN BY--JAMES J. FILLIBEN
14657C                 STATISTICAL ENGINEERING DIVISION
14658C                 INFORMATION TECHNOLOGY LABORATORY
14659C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
14660C                 GAITHERSBURG, MD 20899-8980
14661C                 PHONE--301-975-2855
14662C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
14663C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
14664C     LANGUAGE--ANSI FORTRAN (1977)
14665C     VERSION NUMBER--89/1
14666C     ORIGINAL VERSION--DECEMBER  1988.
14667C     UPDATED         --JUNE      1990. TEMPORARY ARRAYS TO GARBAGE COMMON
14668C     UPDATED         --APRIL     1992. MAXCP7 AND MAXCP... MISTAKES
14669C     UPDATED         --JULY      1993. ADD FRACTAL ITERATIONS AND
14670C                                       FRACTAL TYPE
14671C     UPDATED         --FEBRUARY  2011. USE DPPARS, DPPAR5
14672C
14673C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
14674C
14675      CHARACTER*4 ICASPL
14676      CHARACTER*4 IAND1
14677      CHARACTER*4 IAND2
14678      CHARACTER*4 ICONT
14679      CHARACTER*4 IANGLU
14680      CHARACTER*4 IBUGG2
14681      CHARACTER*4 IBUGG3
14682      CHARACTER*4 IBUGQ
14683      CHARACTER*4 ISUBRO
14684      CHARACTER*4 IFOUND
14685      CHARACTER*4 IERROR
14686C
14687      CHARACTER*4 ISUBN1
14688      CHARACTER*4 ISUBN2
14689      CHARACTER*4 ISTEPN
14690CCCCC JULY 1993.  ADD FOLLOWING LINE.
14691      CHARACTER*4 IFRATY
14692C
14693      CHARACTER*40 INAME
14694      PARAMETER (MAXSPN=30)
14695      CHARACTER*4 IVARN1(MAXSPN)
14696      CHARACTER*4 IVARN2(MAXSPN)
14697      CHARACTER*4 IVARTY(MAXSPN)
14698      REAL PVAR(MAXSPN)
14699      INTEGER ILIS(MAXSPN)
14700      INTEGER NRIGHT(MAXSPN)
14701      INTEGER ICOLR(MAXSPN)
14702C
14703C---------------------------------------------------------------------
14704C
14705      INCLUDE 'DPCOPA.INC'
14706      INCLUDE 'DPCOZZ.INC'
14707C
14708      DIMENSION Z1(MAXOBV)
14709      DIMENSION Z2(MAXOBV)
14710      DIMENSION Z3(MAXOBV)
14711      DIMENSION Z4(MAXOBV)
14712      DIMENSION Z5(MAXOBV)
14713      DIMENSION Z6(MAXOBV)
14714      DIMENSION Z7(MAXOBV)
14715      DIMENSION W(MAXOBV)
14716      DIMENSION U(MAXPOP)
14717C
14718      EQUIVALENCE (GARBAG(IGARB1),Z1(1))
14719      EQUIVALENCE (GARBAG(IGARB2),Z2(1))
14720      EQUIVALENCE (GARBAG(IGARB3),Z3(1))
14721      EQUIVALENCE (GARBAG(IGARB4),Z4(1))
14722      EQUIVALENCE (GARBAG(IGARB5),Z5(1))
14723      EQUIVALENCE (GARBAG(IGARB6),Z6(1))
14724      EQUIVALENCE (GARBAG(IGARB7),Z7(1))
14725      EQUIVALENCE (GARBAG(IGARB8),W(1))
14726      EQUIVALENCE (GARBAG(IGARB9),U(1))
14727C
14728C-----COMMON----------------------------------------------------------
14729C
14730      INCLUDE 'DPCOHK.INC'
14731      INCLUDE 'DPCODA.INC'
14732      INCLUDE 'DPCOP2.INC'
14733C
14734C-----START POINT-----------------------------------------------------
14735C
14736      IERROR='NO'
14737      ISUBN1='DPFR'
14738      ISUBN2='AC  '
14739C
14740      MAXCP1=MAXCOL+1
14741      MAXCP2=MAXCOL+2
14742      MAXCP3=MAXCOL+3
14743      MAXCP4=MAXCOL+4
14744      MAXCP5=MAXCOL+5
14745      MAXCP6=MAXCOL+6
14746C
14747C               *************************************
14748C               **  TREAT THE FRACTAL PLOT CASE    **
14749C               *************************************
14750C
14751      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'FRAC')THEN
14752        WRITE(ICOUT,999)
14753  999   FORMAT(1X)
14754        CALL DPWRST('XXX','BUG ')
14755        WRITE(ICOUT,51)
14756   51   FORMAT('***** AT THE BEGINNING OF DPFRAC--')
14757        CALL DPWRST('XXX','BUG ')
14758        WRITE(ICOUT,52)IBUGG2,IBUGG3,IBUGQ,ISUBRO
14759   52   FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',3(A4,2X),A4)
14760        CALL DPWRST('XXX','BUG ')
14761        WRITE(ICOUT,53)ICASPL,IAND1,IAND2,ICONT
14762   53   FORMAT('ICASPL,IAND1,IAND2,ICONT = ',3(A4,2X),A4)
14763        CALL DPWRST('XXX','BUG ')
14764        WRITE(ICOUT,54)IANGLU,ISEED,MAXPOP
14765   54   FORMAT('IANGLU,ISEED,MAXPOP = ',A4,2I8)
14766        CALL DPWRST('XXX','BUG ')
14767      ENDIF
14768C
14769C               ***************************
14770C               **  STEP 11--            **
14771C               **  EXTRACT THE COMMAND  **
14772C               ***************************
14773C
14774      ISTEPN='11'
14775      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'FRAC')
14776     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14777C
14778      ICASPL='FRAC'
14779C
14780      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')THEN
14781        ILASTC=1
14782        CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
14783      ELSE
14784        GOTO9000
14785      ENDIF
14786      IFOUND='YES'
14787C
14788C               ****************************************
14789C               **  STEP 2--                          **
14790C               **  EXTRACT THE VARIABLE LIST         **
14791C               ****************************************
14792C
14793      ISTEPN='2'
14794      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'FRAC')
14795     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14796C
14797      INAME='FRACTAL PLOT'
14798      MINNA=6
14799      MAXNA=100
14800      MINN2=2
14801      IFLAGE=1
14802      IFLAGM=0
14803      IFLAGP=0
14804      JMIN=1
14805      JMAX=NUMARG
14806      MINNVA=6
14807      MAXNVA=7
14808C
14809      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
14810     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
14811     1            JMIN,JMAX,
14812     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
14813     1            IVARN1,IVARN2,IVARTY,PVAR,
14814     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
14815     1            MINNVA,MAXNVA,
14816     1            IFLAGM,IFLAGP,
14817     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
14818      IF(IERROR.EQ.'YES')GOTO9000
14819C
14820      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'FRAC')THEN
14821        WRITE(ICOUT,999)
14822        CALL DPWRST('XXX','BUG ')
14823        WRITE(ICOUT,281)
14824  281   FORMAT('***** AFTER CALL DPPARS--')
14825        CALL DPWRST('XXX','BUG ')
14826        WRITE(ICOUT,282)NQ,NUMVAR
14827  282   FORMAT('NQ,NUMVAR = ',2I8)
14828        CALL DPWRST('XXX','BUG ')
14829        IF(NUMVAR.GT.0)THEN
14830          DO285I=1,NUMVAR
14831            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
14832     1                      ICOLR(I),IVARTY(I)
14833  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
14834     1             'ICOLR(I),IVARTY(I) = ',I8,2X,A4,A4,2X,3I8,2X,A4)
14835            CALL DPWRST('XXX','BUG ')
14836  285     CONTINUE
14837        ENDIF
14838      ENDIF
14839C
14840      ICOL=1
14841      CALL DPPAR5(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
14842     1            INAME,IVARN1,IVARN2,IVARTY,
14843     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
14844     1            MAXCOL,MAXCP1,MAXCP2,MAXCP3,
14845     1            MAXCP4,MAXCP5,MAXCP6,
14846     1            V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
14847     1            Z1,Z2,Z3,Z4,Z5,Z6,Z7,NLOCAL,
14848     1            IBUGG3,ISUBRO,IFOUND,IERROR)
14849      IF(IERROR.EQ.'YES')GOTO9000
14850C
14851      IF(NUMVAR.LT.7)THEN
14852        DO3111I=1,NLOCAL
14853          Z7(I)=1.0
14854 3111   CONTINUE
14855      ENDIF
14856C
14857      CALL DPFRA2(Z1,Z2,Z3,Z4,Z5,Z6,Z7,NLOCAL,NUMV2,ICASPL,ICONT,
14858     1            IANGLU,ISEED,W,U,MAXPOP,
14859CCCCC             JULY 1993.  ADD FOLLOWING LINE (FRACTAL ITERATIONS,
14860CCCCC                         FRACTAL TYPE)
14861     1            IFRAIT,IFRATY,
14862     1            Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR)
14863C
14864C               *****************
14865C               **  STEP 90--  **
14866C               **  EXIT       **
14867C               *****************
14868C
14869 9000 CONTINUE
14870      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'FRAC')THEN
14871        WRITE(ICOUT,999)
14872        CALL DPWRST('XXX','BUG ')
14873        WRITE(ICOUT,9011)
14874 9011   FORMAT('***** AT THE END       OF DPFRAC--')
14875        CALL DPWRST('XXX','BUG ')
14876        WRITE(ICOUT,9013)IFOUND,IERROR
14877 9013   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
14878        CALL DPWRST('XXX','BUG ')
14879        WRITE(ICOUT,9016)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
14880 9016   FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',
14881     1         3I8,2X,2(A4,2X),A4)
14882        CALL DPWRST('XXX','BUG ')
14883        WRITE(ICOUT,9041)NLOCAL,NUMVAR
14884 9041   FORMAT('NLOCAL,NUMV2 = ',2I8)
14885        CALL DPWRST('XXX','BUG ')
14886        IF(NLOCAL.GE.1)THEN
14887          DO9042I=1,NLOCAL
14888            WRITE(ICOUT,9043)I,Z1(I),Z2(I),Z3(I),Z4(I),Z5(I),Z6(I)
14889 9043       FORMAT('I,Z1(I),Z2(I),Z3(I),Z4(I),Z5(I),Z6(I) = ',I8,6E10.3)
14890            CALL DPWRST('XXX','BUG ')
14891 9042     CONTINUE
14892        ENDIF
14893        IF(NPLOTP.GE.1)THEN
14894          DO9052I=1,NPLOTP
14895            WRITE(ICOUT,9053)I,Y(I),X(I),D(I)
14896 9053       FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5)
14897            CALL DPWRST('XXX','BUG ')
14898 9052     CONTINUE
14899        ENDIF
14900      ENDIF
14901C
14902      RETURN
14903      END
14904      SUBROUTINE DPFRA2(Z1,Z2,Z3,Z4,Z5,Z6,Z7,N,NUMV2,ICASPL,ICONT,
14905     1                  IANGLU,ISEED,W,U,MAXPOP,
14906CCCCC                   JULY 1993.  ADD FOLLOWING LINE
14907     1                  IFRAIT,IFRATY,
14908     1                  Y2,X2,D2,N2,NPLOTV,IBUGG3,ISUBRO,IERROR)
14909C
14910C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
14911C              THAT WILL DEFINE AN FRACTAL PLOT
14912C     NOTE--Z1 = INITIAL ROTATION
14913C           Z2 = X-SCALING
14914C           Z3 = Y-SCALING
14915C           Z4 = FINAL ROTATION
14916C           Z5 = X-TRANSLATION
14917C           Z6 = Y-TRANSLATION
14918C           Z7 = PROBABILITY WEIGHTING FOR EACH REGION
14919C     REFERENCE--WILLIAM DOUGLAS WITHERS, NAVAL ACADEMY
14920C     WRITTEN BY--JAMES J. FILLIBEN
14921C                 STATISTICAL ENGINEERING DIVISION
14922C                 INFORMATION TECHNOLOGY LABORATORY
14923C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
14924C                 GAITHERSBURG, MD 20899-8980
14925C                 PHONE--301-975-2855
14926C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
14927C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
14928C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
14929C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
14930C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
14931C     LANGUAGE--ANSI FORTRAN (1977)
14932C     VERSION NUMBER--88/12
14933C     ORIGINAL VERSION--DECEMBER  1988.
14934C     UPDATED         --JULY      1993.  FRACTAL ITERATIONS, FRACTAL
14935C                                        TYPE.
14936C
14937C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
14938C
14939      CHARACTER*4 ICASPL
14940      CHARACTER*4 ICONT
14941      CHARACTER*4 IANGLU
14942      CHARACTER*4 IBUGG3
14943      CHARACTER*4 ISUBRO
14944      CHARACTER*4 IERROR
14945CCCCC JULY 1993.  ADD FOLLOWING LINE.
14946      CHARACTER*4 IFRATY
14947C
14948C---------------------------------------------------------------------
14949C
14950      DIMENSION Z1(*)
14951      DIMENSION Z2(*)
14952      DIMENSION Z3(*)
14953      DIMENSION Z4(*)
14954      DIMENSION Z5(*)
14955      DIMENSION Z6(*)
14956      DIMENSION Z7(*)
14957C
14958      DIMENSION W(*)
14959      DIMENSION U(*)
14960C
14961      DIMENSION Y2(*)
14962      DIMENSION X2(*)
14963      DIMENSION D2(*)
14964C
14965      DIMENSION A11(100)
14966      DIMENSION A12(100)
14967      DIMENSION A21(100)
14968      DIMENSION A22(100)
14969C
14970      EXTERNAL UNIRAN
14971C
14972C---------------------------------------------------------------------
14973C
14974      INCLUDE 'DPCOP2.INC'
14975C
14976C-----START POINT-----------------------------------------------------
14977C
14978      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'FRA2')GOTO90
14979      WRITE(ICOUT,999)
14980  999 FORMAT(1X)
14981      CALL DPWRST('XXX','BUG ')
14982      WRITE(ICOUT,51)
14983   51 FORMAT('***** AT THE BEGINNING OF DPFRA2--')
14984      CALL DPWRST('XXX','BUG ')
14985      WRITE(ICOUT,52)IBUGG3,ISUBRO,IERROR
14986   52 FORMAT('IBUGG3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
14987      CALL DPWRST('XXX','BUG ')
14988      WRITE(ICOUT,53)ICASPL,ICONT,IANGLU,ISEED,MAXPOP
14989   53 FORMAT('ICASPL,ICONT,IANGLU,ISEED,MAXPOP = ',
14990     1A4,2X,A4,2X,A4,2I8)
14991      CALL DPWRST('XXX','BUG ')
14992      WRITE(ICOUT,54)NUMV2
14993   54 FORMAT('NUMV2 = ',I8)
14994      CALL DPWRST('XXX','BUG ')
14995      WRITE(ICOUT,61)N
14996   61 FORMAT('N = ',I8)
14997      CALL DPWRST('XXX','BUG ')
14998      DO62I=1,N
14999      WRITE(ICOUT,63)I,Z1(I),Z2(I),Z3(I),Z4(I),Z5(I),Z6(I),Z7(I)
15000   63 FORMAT('I,Z1(I),Z2(I),Z3(I),Z4(I),Z5(I),Z6(I),Z7(I) = ',
15001     1I8,7E9.2)
15002      CALL DPWRST('XXX','BUG ')
15003   62 CONTINUE
15004   90 CONTINUE
15005C
15006      INDEX=0
15007      CONST=1.0
15008      IF(IANGLU.EQ.'DEGR')CONST=2*3.14159/360.0
15009CCCCC JULY 1993.  BRANCH ACCORDING TO CASE.
15010C
15011C  WHITHER'S FORMAT
15012C
15013      IF(IFRATY.EQ.'WHIT')THEN
15014        DO1100I=1,N
15015C
15016        ALPHA=Z1(I)
15017        SCALEX=Z2(I)
15018        SCALEY=Z3(I)
15019        BETA=Z4(I)
15020C
15021        SINALP=SIN(CONST*ALPHA)
15022        COSALP=COS(CONST*ALPHA)
15023        SINBET=SIN(CONST*BETA)
15024        COSBET=COS(CONST*BETA)
15025        A11(I)=COSALP*COSBET*SCALEX-SINALP*SINBET*SCALEY
15026        A12(I)=(-SINALP*COSBET*SCALEX-COSALP*SINBET*SCALEY)
15027        A21(I)=COSALP*SINBET*SCALEX+SINALP*COSBET*SCALEY
15028        A22(I)=(-SINALP*SINBET*SCALEX+COSALP*COSBET*SCALEY)
15029C
15030 1100   CONTINUE
15031C
15032C  BARNSLEY ROTATION ANGLE FORMAT
15033C
15034      ELSEIF(IFRATY.EQ.'ANGL')THEN
15035        DO1110I=1,N
15036C
15037        ALPHA=Z1(I)
15038        SCALEX=Z2(I)
15039        SCALEY=Z3(I)
15040        BETA=Z4(I)
15041C
15042        A11(I)=SCALEX*COS(ALPHA)
15043        A12(I)=-SCALEY*SIN(BETA)
15044        A21(I)=SCALEX*SIN(ALPHA)
15045        A22(I)=SCALEY*COS(BETA)
15046C
15047 1110   CONTINUE
15048C
15049C  BARNSLEY STANDARD FORMAT
15050C
15051      ELSE
15052        DO1120I=1,N
15053        A11(I)=Z1(I)
15054        A12(I)=Z2(I)
15055        A21(I)=Z3(I)
15056        A22(I)=Z4(I)
15057 1120   CONTINUE
15058      ENDIF
15059C
15060      SUM=0.0
15061      DO1210I=1,N
15062      SUM=SUM+Z7(I)
15063 1210 CONTINUE
15064C
15065      DO1220I=1,N
15066      W(I)=Z7(I)/SUM
15067 1220 CONTINUE
15068C
15069      CUM=0.0
15070      DO1230I=1,N
15071      CUM=CUM+W(I)
15072      W(I)=CUM
15073 1230 CONTINUE
15074C
15075CCCCC JULY 1993.  ADD FOLLOWING LINES
15076CCCCC NU=MAXPOP
15077      NU=IFRAIT
15078      IF(NU.GT.MAXPOP)NU=IFRAIT
15079CCCCC END CHANGE
15080      CALL UNIRAN(NU,ISEED,U)
15081C
15082      XNEW=0.0
15083      YNEW=0.0
15084      K=0
15085      JCUT=20
15086      DO1310J=1,NU
15087C
15088      UJ=U(J)
15089      DO1320I=1,N
15090      INDEX=I
15091      IF(UJ.LE.W(I))GOTO1329
15092 1320 CONTINUE
15093 1329 CONTINUE
15094C
15095      XOLD=XNEW
15096      YOLD=YNEW
15097      XTEMP=A11(INDEX)*XOLD+A12(INDEX)*YOLD
15098      YTEMP=A21(INDEX)*XOLD+A22(INDEX)*YOLD
15099      XNEW=XTEMP+Z5(INDEX)
15100      YNEW=YTEMP+Z6(INDEX)
15101      IF(J.LE.JCUT)GOTO1310
15102      IF(J.GT.JCUT)K=K+1
15103      X2(K)=XNEW
15104      Y2(K)=YNEW
15105      D2(K)=1.0
15106 1310 CONTINUE
15107C
15108      N2=K
15109      NPLOTV=2
15110      GOTO9000
15111C
15112C               ******************
15113C               **   STEP 90--  **
15114C               **   EXIT       **
15115C               ******************
15116C
15117 9000 CONTINUE
15118      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'FRA2')GOTO9090
15119      WRITE(ICOUT,999)
15120      CALL DPWRST('XXX','BUG ')
15121      WRITE(ICOUT,9011)
15122 9011 FORMAT('***** AT THE END       OF DPFRA2--')
15123      CALL DPWRST('XXX','BUG ')
15124      WRITE(ICOUT,9012)IBUGG3,ISUBRO,IERROR
15125 9012 FORMAT('IBUGG3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
15126      CALL DPWRST('XXX','BUG ')
15127      WRITE(ICOUT,9013)ICASPL,ICONT,IANGLU,ISEED,MAXPOP
15128 9013 FORMAT('ICASPL,ICONT,IANGLU,ISEED,MAXPOP = ',
15129     1A4,2X,A4,2X,A4,2I8)
15130      CALL DPWRST('XXX','BUG ')
15131      WRITE(ICOUT,9021)N
15132 9021 FORMAT('N = ',I8)
15133      CALL DPWRST('XXX','BUG ')
15134      DO9022I=1,N
15135      WRITE(ICOUT,9023)A11(I),A12(I),A21(I),A22(I)
15136 9023 FORMAT('A11(I),A12(I),A21(I),A22(I) = ',4E15.7)
15137      CALL DPWRST('XXX','BUG ')
15138 9022 CONTINUE
15139      DO9024I=1,N
15140      WRITE(ICOUT,9025)I,W(I)
15141 9025 FORMAT('I,W(I) = ',I8,E15.7)
15142      CALL DPWRST('XXX','BUG ')
15143 9024 CONTINUE
15144      WRITE(ICOUT,9051)NUMV2
15145 9051 FORMAT('NUMV2 = ',I8)
15146      CALL DPWRST('XXX','BUG ')
15147      WRITE(ICOUT,9052)N2,NPLOTV
15148 9052 FORMAT('N2,NPLOTV = ',2I8)
15149      CALL DPWRST('XXX','BUG ')
15150      DO9053I=1,N2
15151CCCCC WRITE(ICOUT,9054)I,U(I),X2(I),Y2(I)
15152C9054 FORMAT('I,U(I),X2(I),Y2(I) = ',I8,3E15.7)
15153CCCCC CALL DPWRST('XXX','BUG ')
15154 9053 CONTINUE
15155 9090 CONTINUE
15156C
15157      RETURN
15158      END
15159      SUBROUTINE DPFRAG(X,N,IWRITE,YBREAK,NBREAK,YFRAGC,YFRAGL,NFRAG,
15160     1                  ISUBRO,IBUGA3,IERROR)
15161C
15162C     PURPOSE--THIS ROUTINE ASSUMES X IS A SEQUENCE OF POINTS WHERE
15163C              EACH POINT CONTAINS 4 X COORDINATES.  THESE COORDINATES
15164C              DEFINE THE BOUNDARY OF A "BREAK".  THIS ROUTINE RETURNS
15165C              THE FOLLOWING:
15166C
15167C                 1) YBREAK CONTAINS THE BREAK CENTROID.  THIS IS
15168C                    SIMPLY THE AVERAGE OF THE 4 POINTS.
15169C
15170C                 2) YFRAGC CONTAINS THE "FRAGMENT CENTROID".  GIVEN
15171C                    TWO SUCCESSIVE BREAKS, DEFINE THE LOWER BOUNDARY
15172C                    OF THE FRAGMENT BY THE AVERAGE OF THE RIGHT CORNER
15173C                    POINTS OF THE FIRST BREAK AND THE UPPER BOUNDARY
15174C                    BY THE AVERAGE OF THE LEFT CORNER POINTS OF THE
15175C                    SECOND BREAK.
15176C
15177C                 3) YFRAGL CONTAINS THE FRAGMENT LENGTH.  THIS IS
15178C                    SIMPLY THE DISTANCE BETWEEN THE LOWER BOUNDARY
15179C                    AND THE UPPER BOUNDARY.
15180C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
15181C                                OBSERVATIONS CONTAINING THE
15182C                                X-COORDIANTES OF THE BREAK POINTS
15183C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
15184C                                IN THE VECTOR X.
15185C     OUTPUT ARGUMENTS--YBREAK = THE SINGLE PRECISION VECTOR THAT
15186C                                CONTAINS THE BREAK CENTROIDS.
15187C                     --YFRAGC = THE SINGLE PRECISION VECTOR THAT
15188C                                CONTAINS THE FRAGMENT CENTROIDS.
15189C                     --YFRAGL = THE SINGLE PRECISION VECTOR THAT
15190C                                CONTAINS THE FRAGMENT LENGTHS.
15191C                     --NBREAK = THE INTEGER NUMBER OF BREAK LOCATIONS.
15192C                     --NFRAG  = THE INTEGER NUMBER OF FRAGMENT
15193C                                CENTROIDS/LENGTHS.
15194C     OUTPUT--THE SINGLE PRECISION VECTORS YBREAK, YFRAGC, AND YFRAGL.
15195C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
15196C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
15197C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
15198C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
15199C     LANGUAGE--ANSI FORTRAN (1977)
15200C     COMMENT--THE INPUT VECTOR X REMAINS UNALTERED.
15201C     WRITTEN BY--ALAN HECKERT
15202C                 STATISTICAL ENGINEERING DIVISION
15203C                 INFORMATION TECHNOLOGY LABORATORY
15204C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
15205C                 GAITHERSBURG, MD 20899
15206C                 PHONE--301-975-2899
15207C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
15208C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
15209C     LANGUAGE--ANSI FORTRAN (1977)
15210C     VERSION NUMBER--2019/07
15211C     ORIGINAL VERSION--JULY      2019.
15212C
15213C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
15214C
15215      CHARACTER*4 IWRITE
15216      CHARACTER*4 ISUBRO
15217      CHARACTER*4 IBUGA3
15218      CHARACTER*4 IERROR
15219C
15220      CHARACTER*4 ISUBN1
15221      CHARACTER*4 ISUBN2
15222C
15223C---------------------------------------------------------------------
15224C
15225      DIMENSION X(*)
15226      DIMENSION YBREAK(*)
15227      DIMENSION YFRAGC(*)
15228      DIMENSION YFRAGL(*)
15229C
15230      DIMENSION XLEFT(4)
15231      DIMENSION XRIGHT(4)
15232C
15233C---------------------------------------------------------------------
15234C
15235      INCLUDE 'DPCOP2.INC'
15236C
15237C-----START POINT-----------------------------------------------------
15238C
15239      ISUBN1='DPFR'
15240      ISUBN2='AG  '
15241      IERROR='NO'
15242C
15243      NBREAK=0
15244      NFRAG=0
15245C
15246      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FRAG')THEN
15247        WRITE(ICOUT,999)
15248  999   FORMAT(1X)
15249        CALL DPWRST('XXX','BUG ')
15250        WRITE(ICOUT,51)
15251   51   FORMAT('***** AT THE BEGINNING OF DPFRAG--')
15252        CALL DPWRST('XXX','BUG ')
15253        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
15254   52   FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8)
15255        CALL DPWRST('XXX','BUG ')
15256        DO55I=1,N
15257          WRITE(ICOUT,56)I,X(I)
15258   56     FORMAT('I,X(I) = ',I8,G15.7)
15259          CALL DPWRST('XXX','BUG ')
15260   55   CONTINUE
15261      ENDIF
15262C
15263C               ********************************************
15264C               **  STEP 1--                              **
15265C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
15266C               ********************************************
15267C
15268      NMOD=MOD(N,4)
15269      IF(NMOD.NE.0)THEN
15270        WRITE(ICOUT,999)
15271        CALL DPWRST('XXX','BUG ')
15272        WRITE(ICOUT,111)
15273  111   FORMAT('***** ERROR IN DPFRAG--')
15274        CALL DPWRST('XXX','BUG ')
15275        WRITE(ICOUT,113)
15276  113   FORMAT('      THE NUMBER OF OBSERVATIONS IN THE RESPONSE ',
15277     1         'VARIABLE')
15278        CALL DPWRST('XXX','BUG ')
15279        WRITE(ICOUT,115)
15280  115   FORMAT('      IS NOT DIVISIBLE BY FOUR.')
15281        CALL DPWRST('XXX','BUG ')
15282        WRITE(ICOUT,118)N
15283  118   FORMAT('      THE VALUE OF THE ARGUMENT IS ',I8)
15284        CALL DPWRST('XXX','BUG ')
15285        IERROR='YES'
15286        GOTO9000
15287      ENDIF
15288C
15289C               ********************************************************
15290C               **  STEP 2--                                          **
15291C               **  COMPUTE THE BREAK LOCATIONS                       **
15292C               ********************************************************
15293C
15294      IFLAGS=0
15295      ICNT=0
15296      DO200I=1,N,4
15297C
15298C       BREAK LOCATIONS
15299C
15300        AVAL=(X(I) + X(I+1) + X(I+2) + X(I+3))/4.0
15301        NBREAK=NBREAK+1
15302        YBREAK(NBREAK)=AVAL
15303C
15304C       FRAGMENT CENTROIDS AND LENGTHS
15305C
15306        IF(I+7.GT.N)GOTO200
15307        XLEFT(1)=X(I)
15308        XLEFT(2)=X(I+1)
15309        XLEFT(3)=X(I+2)
15310        XLEFT(4)=X(I+3)
15311        CALL SORT(XLEFT,4,XLEFT)
15312        AVAL1=(XLEFT(3) + XLEFT(4))/2.0
15313C
15314        XRIGHT(1)=X(I+4)
15315        XRIGHT(2)=X(I+5)
15316        XRIGHT(3)=X(I+6)
15317        XRIGHT(4)=X(I+7)
15318        CALL SORT(XRIGHT,4,XRIGHT)
15319        AVAL2=(XRIGHT(1) + XRIGHT(2))/2.0
15320C
15321C       CHECK FOR LEFT TO RIGHT OR RIGHT TO LEFT SORTING.  IF
15322C       SORTING IS NOT CONSISTENT, PRINT AN ERROR MESSAGE, BUT
15323C       CONTINUE PROCESSING.
15324C
15325        IF(I.EQ.1)THEN
15326          IF(AVAL1.LE.AVAL2)THEN
15327            IFLAGS=1
15328          ELSE
15329            IFLAGS=2
15330          ENDIF
15331        ELSE
15332C
15333          IF(IFLAGS.EQ.1 .AND. AVAL1.GT.AVAL2)THEN
15334            ICNT=ICNT+1
15335            IF(ICNT.EQ.1)THEN
15336              WRITE(ICOUT,999)
15337              CALL DPWRST('XXX','BUG ')
15338              WRITE(ICOUT,211)
15339  211         FORMAT('***** WARNING IN DPFRAG--')
15340              CALL DPWRST('XXX','BUG ')
15341              WRITE(ICOUT,213)
15342  213         FORMAT('      BREAKS DO NOT APPEAR TO BE CONSISTENTLY ',
15343     1               'SORTED FROM LEFT TO RIGHT.')
15344              CALL DPWRST('XXX','BUG ')
15345CCCCC         IERROR='YES'
15346CCCCC         GOTO9000
15347            ENDIF
15348          ELSEIF(IFLAGS.EQ.2 .AND. AVAL1.LT.AVAL2)THEN
15349            ICNT=ICNT+1
15350            IF(ICNT.EQ.1)THEN
15351              WRITE(ICOUT,999)
15352              CALL DPWRST('XXX','BUG ')
15353              WRITE(ICOUT,211)
15354              CALL DPWRST('XXX','BUG ')
15355              WRITE(ICOUT,218)
15356  218         FORMAT('      BREAKS DO NOT APPEAR TO BE CONSISTENLY ',
15357     1               'SORTED FROM RIGHT TO LEFT.')
15358              CALL DPWRST('XXX','BUG ')
15359CCCCC         IERROR='YES'
15360CCCCC         GOTO9000
15361            ENDIF
15362          ENDIF
15363C
15364        ENDIF
15365C
15366        NFRAG=NFRAG+1
15367        YFRAGC(NFRAG)=(AVAL1+AVAL2)/2.0
15368        YFRAGL(NFRAG)=AVAL2-AVAL1
15369C
15370  200 CONTINUE
15371C
15372C               ******************************
15373C               **  STEP 3--                **
15374C               **  WRITE OUT A FEW LINES   **
15375C               **  OF SUMMARY INFORMATION. **
15376C               ******************************
15377C
15378      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
15379        WRITE(ICOUT,999)
15380        CALL DPWRST('XXX','BUG ')
15381        WRITE(ICOUT,811)NBREAKS
15382  811   FORMAT('NUMBER OF BREAKS = ',I8)
15383        CALL DPWRST('XXX','BUG ')
15384        WRITE(ICOUT,812)NFRAG
15385  812   FORMAT('NUMBER OF FRAGMENTS = ',I8)
15386        CALL DPWRST('XXX','BUG ')
15387        WRITE(ICOUT,999)
15388        CALL DPWRST('XXX','BUG ')
15389      ENDIF
15390C
15391C               *****************
15392C               **  STEP 90--  **
15393C               **  EXIT.      **
15394C               *****************
15395C
15396 9000 CONTINUE
15397C
15398      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FRAG')THEN
15399        WRITE(ICOUT,999)
15400        CALL DPWRST('XXX','BUG ')
15401        WRITE(ICOUT,9011)
15402 9011   FORMAT('***** AT THE END OF DPFRAG--')
15403        CALL DPWRST('XXX','BUG ')
15404        WRITE(ICOUT,9012)IERROR,NBREAK,NFRAG
15405 9012   FORMAT('IERROR,NBREAK,NFRAG = ',A4,2X,2I8)
15406        CALL DPWRST('XXX','BUG ')
15407        IF(NBREAK.GE.1)THEN
15408          DO9015I=1,NBREAK
15409            WRITE(ICOUT,9016)I,YBREAK(I)
15410 9016       FORMAT('I,YBREAK(I) = ',I8,G15.7)
15411            CALL DPWRST('XXX','BUG ')
15412 9015     CONTINUE
15413        ENDIF
15414        IF(NFRAG.GE.1)THEN
15415          DO9025I=1,NFRAG
15416            WRITE(ICOUT,9026)I,YFRAGC(I),YFRAGL(I)
15417 9026       FORMAT('I,YFRAGC(I),YFRAGL = ',I8,2G15.7)
15418            CALL DPWRST('XXX','BUG ')
15419 9025     CONTINUE
15420        ENDIF
15421      ENDIF
15422C
15423      RETURN
15424      END
15425      SUBROUTINE DPFRAM(ICOM,IHARG,NUMARG,
15426     1IX1FSW,IX2FSW,IY1FSW,IY2FSW,
15427CCCCC THE FOLLOWING LINE WAS ADDED   SEPTEMBER 1993
15428     1FRASTY,
15429     1IFOUND,IERROR)
15430C
15431C     PURPOSE--DEFINE THE FRAME SWITCHES (ON/OFF)
15432C              FOR ANY OF THE 4 FRAME LINES.
15433C              SUCH FRAME SWITCHES DEFINE WHETHER OR NOT
15434C              EACH OF THE 4 FRAME LINES EXISTS.
15435C              THE CONTENTS OF A FRAME SWITCH ARE
15436C              ON    OR    OFF.
15437C              THE FRAME SWITCHES FOR THE 4 FRAME LINES
15438C              ARE CONTAINED IN THE 4 VARIABLES
15439C              IX1FSW,IX2FSW,IY1FSW,IY2FSW.
15440C     INPUT  ARGUMENTS--ICOM
15441C                     --IHARG  (A  HOLLERITH VECTOR)
15442C                     --NUMARG
15443C     OUTPUT ARGUMENTS--IX1FSW (A HOLLERITH VECTOR)
15444C                     --IX2FSW (A HOLLERITH VECTOR)
15445C                     --IY1FSW (A HOLLERITH VECTOR)
15446C                     --IY2FSW (A HOLLERITH VECTOR)
15447C                     --IFOUND ('YES' OR 'NO' )
15448C                     --IERROR ('YES' OR 'NO' )
15449C     WRITTEN BY--JAMES J. FILLIBEN
15450C                 STATISTICAL ENGINEERING DIVISION
15451C                 INFORMATION TECHNOLOGY LABORATORY
15452C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
15453C                 GAITHERSBURG, MD 20899-8980
15454C                 PHONE--301-975-2855
15455C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
15456C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
15457C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
15458C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
15459C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
15460C     LANGUAGE--ANSI FORTRAN (1977)
15461C     VERSION NUMBER--82/7
15462C     ORIGINAL VERSION--OCTOBER   1980.
15463C     UPDATED         --MAY       1982.
15464C     UPDATED         --SEPTEMBER 1993. 3-D
15465C
15466C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
15467C
15468      CHARACTER*4 ICOM
15469      CHARACTER*4 IHARG
15470C
15471      CHARACTER*4 IX1FSW
15472      CHARACTER*4 IX2FSW
15473      CHARACTER*4 IY1FSW
15474      CHARACTER*4 IY2FSW
15475C
15476CCCCC THE FOLLOWING LINE WAS ADDED   SEPTEMBER 1993
15477      CHARACTER*4 FRASTY
15478C
15479      CHARACTER*4 IFOUND
15480      CHARACTER*4 IERROR
15481C
15482C---------------------------------------------------------------------
15483C
15484      DIMENSION IHARG(*)
15485C
15486C---------------------------------------------------------------------
15487C
15488      INCLUDE 'DPCOP2.INC'
15489C
15490C-----START POINT-----------------------------------------------------
15491C
15492      IFOUND='NO'
15493      IERROR='NO'
15494C
15495      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CORN')GOTO1900
15496      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COOR')GOTO1900
15497      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COLO')GOTO1900
15498C
15499CCCCC THE FOLLOWING SECTION WAS ADDED           SEPTEMBER 1993
15500CCCCC TO ALLOW FOR 3-D FRAME STYLE  SETTINGS    SEPTEMBER 1993
15501C               *****************************************************
15502C               **  TREAT THE CASE WHEN                           **
15503C               **  THE 3D FRAME STYLE IS TO BE CHANGED     **
15504C               *****************************************************
15505C
15506      IF(ICOM.EQ.'3DFR')GOTO1000
15507      GOTO1099
15508C
15509 1000 CONTINUE
15510      IF(NUMARG.LE.0)GOTO1010
15511      IF(IHARG(NUMARG).EQ.'ON')GOTO1010
15512      IF(IHARG(NUMARG).EQ.'OFF')GOTO1020
15513      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1010
15514      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1010
15515      IF(IHARG(NUMARG).EQ.'?')GOTO1030
15516      GOTO1020
15517C
15518 1010 CONTINUE
15519      IFOUND='YES'
15520      FRASTY='3PRO'
15521      IF(IFEEDB.EQ.'ON')THEN
15522         WRITE(ICOUT,999)
15523  999    FORMAT(1X)
15524         CALL DPWRST('XXX','BUG ')
15525         WRITE(ICOUT,1011)
15526 1011    FORMAT('THE 3D FRAME SWITCH')
15527         CALL DPWRST('XXX','BUG ')
15528         WRITE(ICOUT,1012)
15529 1012    FORMAT('HAS JUST BEEN SET TO    3PRONG')
15530         CALL DPWRST('XXX','BUG ')
15531         GOTO1900
15532      ENDIF
15533C
15534 1020 CONTINUE
15535      IFOUND='YES'
15536C
15537      IF(IHARG(1).EQ.'OFF'.OR.IHARG(1).EQ.'NONE')THEN
15538         FRASTY='OFF'
15539         IF(IFEEDB.EQ.'ON')THEN
15540            WRITE(ICOUT,999)
15541            CALL DPWRST('XXX','BUG ')
15542            WRITE(ICOUT,1011)
15543            CALL DPWRST('XXX','BUG ')
15544            WRITE(ICOUT,1021)
15545 1021       FORMAT('HAS JUST BEEN SET TO    OFF')
15546            CALL DPWRST('XXX','BUG ')
15547         ENDIF
15548         GOTO1900
15549      ENDIF
15550C
15551      IF(IHARG(1).EQ.'3PRO')THEN
15552         FRASTY='3PRO'
15553         IF(IFEEDB.EQ.'ON')THEN
15554            WRITE(ICOUT,999)
15555            CALL DPWRST('XXX','BUG ')
15556            WRITE(ICOUT,1011)
15557            CALL DPWRST('XXX','BUG ')
15558            WRITE(ICOUT,1022)
15559 1022       FORMAT('HAS JUST BEEN SET TO    3PRONG')
15560            CALL DPWRST('XXX','BUG ')
15561         ENDIF
15562         GOTO1900
15563      ENDIF
15564C
15565      IF(IHARG(1).EQ.'3PLA')THEN
15566         FRASTY='3PLA'
15567         IF(IFEEDB.EQ.'ON')THEN
15568            WRITE(ICOUT,999)
15569            CALL DPWRST('XXX','BUG ')
15570            WRITE(ICOUT,1011)
15571            CALL DPWRST('XXX','BUG ')
15572            WRITE(ICOUT,1023)
15573 1023       FORMAT('HAS JUST BEEN SET TO    3PLANE')
15574            CALL DPWRST('XXX','BUG ')
15575         ENDIF
15576         GOTO1900
15577      ENDIF
15578C
15579      IF(IHARG(1).EQ.'CUBE'.OR.IHARG(1).EQ.'BOX')THEN
15580         FRASTY='BOX'
15581         IF(IFEEDB.EQ.'ON')THEN
15582            WRITE(ICOUT,999)
15583            CALL DPWRST('XXX','BUG ')
15584            WRITE(ICOUT,1011)
15585            CALL DPWRST('XXX','BUG ')
15586            WRITE(ICOUT,1024)
15587 1024       FORMAT('HAS JUST BEEN SET TO    BOX')
15588            CALL DPWRST('XXX','BUG ')
15589         ENDIF
15590         GOTO1900
15591      ENDIF
15592C
15593      IF(IHARG(1).EQ.'ZIGZ')THEN
15594         FRASTY='ZIGZ'
15595         IF(IFEEDB.EQ.'ON')THEN
15596            WRITE(ICOUT,999)
15597            CALL DPWRST('XXX','BUG ')
15598            WRITE(ICOUT,1011)
15599            CALL DPWRST('XXX','BUG ')
15600            WRITE(ICOUT,1025)
15601 1025       FORMAT('HAS JUST BEEN SET TO    ZIGZAG')
15602            CALL DPWRST('XXX','BUG ')
15603         ENDIF
15604         GOTO1900
15605      ENDIF
15606C
15607 1030 CONTINUE
15608      IFOUND='YES'
15609      WRITE(ICOUT,999)
15610      CALL DPWRST('XXX','BUG ')
15611      WRITE(ICOUT,1031)
15612 1031 FORMAT('THE 3D FRAME SWITCH')
15613      CALL DPWRST('XXX','BUG ')
15614      WRITE(ICOUT,1032)FRASTY
15615 1032 FORMAT('HAS THE CURRENT SETTING = ',A4)
15616      CALL DPWRST('XXX','BUG ')
15617      WRITE(ICOUT,999)
15618      CALL DPWRST('XXX','BUG ')
15619      WRITE(ICOUT,1033)
15620 1033 FORMAT('ALLOWABLE SETTINGS--')
15621      CALL DPWRST('XXX','BUG ')
15622      WRITE(ICOUT,1034)
15623 1034 FORMAT('   3PRONG')
15624      CALL DPWRST('XXX','BUG ')
15625      WRITE(ICOUT,1035)
15626 1035 FORMAT('   3PLANE')
15627      CALL DPWRST('XXX','BUG ')
15628      WRITE(ICOUT,1036)
15629 1036 FORMAT('   BOX')
15630      CALL DPWRST('XXX','BUG ')
15631      WRITE(ICOUT,1037)
15632 1037 FORMAT('   ZIGZAG')
15633      CALL DPWRST('XXX','BUG ')
15634      WRITE(ICOUT,1038)
15635 1038 FORMAT('   OFF')
15636      CALL DPWRST('XXX','BUG ')
15637      GOTO1900
15638C
15639 1099 CONTINUE
15640C
15641C               *****************************************************
15642C               **  TREAT THE CASE WHEN                           **
15643C               **  BOTH HORIZONTAL FRAME LINES ARE TO BE CHANGED  **
15644C               *****************************************************
15645C
15646      IF(ICOM.EQ.'XFRA')GOTO1100
15647      GOTO1199
15648C
15649 1100 CONTINUE
15650      IF(NUMARG.LE.0)GOTO1110
15651      IF(IHARG(NUMARG).EQ.'ON')GOTO1110
15652      IF(IHARG(NUMARG).EQ.'OFF')GOTO1120
15653      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1110
15654      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1110
15655      IERROR='YES'
15656      GOTO1900
15657C
15658 1110 CONTINUE
15659      IFOUND='YES'
15660      IX1FSW='ON'
15661      IX2FSW='ON'
15662C
15663      IF(IFEEDB.EQ.'OFF')GOTO1119
15664      WRITE(ICOUT,999)
15665      CALL DPWRST('XXX','BUG ')
15666      WRITE(ICOUT,1115)
15667 1115 FORMAT('THE XFRAME SWITCH (FOR BOTH HORIZONTAL FRAME LINES) ',
15668     1'HAS JUST BEEN TURNED ON')
15669      CALL DPWRST('XXX','BUG ')
15670 1119 CONTINUE
15671      GOTO1900
15672C
15673 1120 CONTINUE
15674      IFOUND='YES'
15675      IX1FSW='OFF'
15676      IX2FSW='OFF'
15677C
15678      IF(IFEEDB.EQ.'OFF')GOTO1129
15679      WRITE(ICOUT,999)
15680      CALL DPWRST('XXX','BUG ')
15681      WRITE(ICOUT,1125)
15682 1125 FORMAT('THE XFRAME SWITCH (FOR BOTH HORIZONTAL FRAME LINES) ',
15683     1'HAS JUST BEEN TURNED OFF')
15684      CALL DPWRST('XXX','BUG ')
15685 1129 CONTINUE
15686      GOTO1900
15687C
15688 1199 CONTINUE
15689C
15690C               **************************************************************
15691C               **  TREAT THE CASE WHEN                                     **
15692C               **  ONLY THE BOTTOM HORIZONTAL FRAME LINE IS TO BE CHANGED  **
15693C               **************************************************************
15694C
15695      IF(ICOM.EQ.'X1FR')GOTO1200
15696      GOTO1299
15697C
15698 1200 CONTINUE
15699      IF(NUMARG.LE.0)GOTO1210
15700      IF(IHARG(NUMARG).EQ.'ON')GOTO1210
15701      IF(IHARG(NUMARG).EQ.'OFF')GOTO1220
15702      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1210
15703      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1210
15704      IERROR='YES'
15705      GOTO1900
15706C
15707 1210 CONTINUE
15708      IFOUND='YES'
15709      IX1FSW='ON'
15710C
15711      IF(IFEEDB.EQ.'OFF')GOTO1219
15712      WRITE(ICOUT,999)
15713      CALL DPWRST('XXX','BUG ')
15714      WRITE(ICOUT,1215)
15715 1215 FORMAT('THE X1FRAME SWITCH (FOR THE BOTTOM HORIZONTAL ',
15716     1'FRAME LINE ONLY) HAS JUST BEEN TURNED ON')
15717      CALL DPWRST('XXX','BUG ')
15718 1219 CONTINUE
15719      GOTO1900
15720C
15721 1220 CONTINUE
15722      IFOUND='YES'
15723      IX1FSW='OFF'
15724C
15725      IF(IFEEDB.EQ.'OFF')GOTO1229
15726      WRITE(ICOUT,999)
15727      CALL DPWRST('XXX','BUG ')
15728      WRITE(ICOUT,1225)
15729 1225 FORMAT('THE X1FRAME SWITCH (FOR THE BOTTOM HORIZONTAL ',
15730     1'FRAME LINE ONLY) HAS JUST BEEN TURNED OFF')
15731      CALL DPWRST('XXX','BUG ')
15732 1229 CONTINUE
15733      GOTO1900
15734C
15735 1299 CONTINUE
15736C
15737C               **************************************************************
15738C               **  TREAT THE CASE WHEN                                     **
15739C               **  ONLY THE TOP    HORIZONTAL FRAME LINE IS TO BE CHANGED  **
15740C               **************************************************************
15741C
15742      IF(ICOM.EQ.'X2FR')GOTO1300
15743      GOTO1399
15744C
15745 1300 CONTINUE
15746      IF(NUMARG.LE.0)GOTO1310
15747      IF(IHARG(NUMARG).EQ.'ON')GOTO1310
15748      IF(IHARG(NUMARG).EQ.'OFF')GOTO1320
15749      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1310
15750      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1310
15751      IERROR='YES'
15752      GOTO1900
15753C
15754 1310 CONTINUE
15755      IFOUND='YES'
15756      IX2FSW='ON'
15757C
15758      IF(IFEEDB.EQ.'OFF')GOTO1319
15759      WRITE(ICOUT,999)
15760      CALL DPWRST('XXX','BUG ')
15761      WRITE(ICOUT,1315)
15762 1315 FORMAT('THE X2FRAME SWITCH (FOR THE TOP HORIZONTAL ',
15763     1'FRAME LINE ONLY) HAS JUST BEEN TURNED ON')
15764      CALL DPWRST('XXX','BUG ')
15765 1319 CONTINUE
15766      GOTO1900
15767C
15768 1320 CONTINUE
15769      IFOUND='YES'
15770      IX2FSW='OFF'
15771C
15772      IF(IFEEDB.EQ.'OFF')GOTO1329
15773      WRITE(ICOUT,999)
15774      CALL DPWRST('XXX','BUG ')
15775      WRITE(ICOUT,1325)
15776 1325 FORMAT('THE X2FRAME SWITCH (FOR THE TOP HORIZONTAL ',
15777     1'FRAME LINE ONLY) HAS JUST BEEN TURNED OFF')
15778      CALL DPWRST('XXX','BUG ')
15779 1329 CONTINUE
15780      GOTO1900
15781C
15782 1399 CONTINUE
15783C
15784C               ***************************************************
15785C               **  TREAT THE CASE WHEN                          **
15786C               **  BOTH VERTICAL FRAME LINES ARE TO BE CHANGED  **
15787C               ***************************************************
15788C
15789      IF(ICOM.EQ.'YFRA')GOTO1400
15790      GOTO1499
15791C
15792 1400 CONTINUE
15793      IF(NUMARG.LE.0)GOTO1410
15794      IF(IHARG(NUMARG).EQ.'ON')GOTO1410
15795      IF(IHARG(NUMARG).EQ.'OFF')GOTO1420
15796      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1410
15797      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1410
15798      IERROR='YES'
15799      GOTO1900
15800C
15801 1410 CONTINUE
15802      IFOUND='YES'
15803      IY1FSW='ON'
15804      IY2FSW='ON'
15805C
15806      IF(IFEEDB.EQ.'OFF')GOTO1419
15807      WRITE(ICOUT,999)
15808      CALL DPWRST('XXX','BUG ')
15809      WRITE(ICOUT,1415)
15810 1415 FORMAT('THE YFRAME SWITCH (FOR BOTH VERTICAL FRAME LINES) ',
15811     1'HAS JUST BEEN TURNED ON')
15812      CALL DPWRST('XXX','BUG ')
15813 1419 CONTINUE
15814      GOTO1900
15815C
15816 1420 CONTINUE
15817      IFOUND='YES'
15818      IY1FSW='OFF'
15819      IY2FSW='OFF'
15820C
15821      IF(IFEEDB.EQ.'OFF')GOTO1429
15822      WRITE(ICOUT,999)
15823      CALL DPWRST('XXX','BUG ')
15824      WRITE(ICOUT,1425)
15825 1425 FORMAT('THE YFRAME SWITCH (FOR BOTH VERTICAL FRAME LINES) ',
15826     1'HAS JUST BEEN TURNED OFF')
15827      CALL DPWRST('XXX','BUG ')
15828 1429 CONTINUE
15829      GOTO1900
15830C
15831 1499 CONTINUE
15832C
15833C               **************************************************************
15834C               **  TREAT THE CASE WHEN                                     **
15835C               **  ONLY THE LEFT   VERTICAL   FRAME LINE IS TO BE CHANGED  **
15836C               **************************************************************
15837C
15838      IF(ICOM.EQ.'Y1FR')GOTO1500
15839      GOTO1599
15840C
15841 1500 CONTINUE
15842      IF(NUMARG.LE.0)GOTO1510
15843      IF(IHARG(NUMARG).EQ.'ON')GOTO1510
15844      IF(IHARG(NUMARG).EQ.'OFF')GOTO1520
15845      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1510
15846      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1510
15847      IERROR='YES'
15848      GOTO1900
15849C
15850 1510 CONTINUE
15851      IFOUND='YES'
15852      IY1FSW='ON'
15853C
15854      IF(IFEEDB.EQ.'OFF')GOTO1519
15855      WRITE(ICOUT,999)
15856      CALL DPWRST('XXX','BUG ')
15857      WRITE(ICOUT,1515)
15858 1515 FORMAT('THE Y1FRAME SWITCH (FOR THE LEFT VERTICAL ',
15859     1'FRAME LINE ONLY) HAS JUST BEEN TURNED ON')
15860      CALL DPWRST('XXX','BUG ')
15861 1519 CONTINUE
15862      GOTO1900
15863C
15864 1520 CONTINUE
15865      IFOUND='YES'
15866      IY1FSW='OFF'
15867C
15868      IF(IFEEDB.EQ.'OFF')GOTO1529
15869      WRITE(ICOUT,999)
15870      CALL DPWRST('XXX','BUG ')
15871      WRITE(ICOUT,1525)
15872 1525 FORMAT('THE Y1FRAME SWITCH (FOR THE LEFT VERTICAL ',
15873     1'FRAME LINE ONLY) HAS JUST BEEN TURNED OFF')
15874      CALL DPWRST('XXX','BUG ')
15875 1529 CONTINUE
15876      GOTO1900
15877C
15878 1599 CONTINUE
15879C
15880C               **************************************************************
15881C               **  TREAT THE CASE WHEN                                     **
15882C               **  ONLY THE RIGHT  VERTCIAL   FRAME LINE IS TO BE CHANGED  **
15883C               **************************************************************
15884C
15885      IF(ICOM.EQ.'Y2FR')GOTO1600
15886      GOTO1699
15887C
15888 1600 CONTINUE
15889      IF(NUMARG.LE.0)GOTO1610
15890      IF(IHARG(NUMARG).EQ.'ON')GOTO1610
15891      IF(IHARG(NUMARG).EQ.'OFF')GOTO1620
15892      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1610
15893      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1610
15894      IERROR='YES'
15895      GOTO1900
15896C
15897 1610 CONTINUE
15898      IFOUND='YES'
15899      IY2FSW='ON'
15900C
15901      IF(IFEEDB.EQ.'OFF')GOTO1619
15902      WRITE(ICOUT,999)
15903      CALL DPWRST('XXX','BUG ')
15904      WRITE(ICOUT,1615)
15905 1615 FORMAT('THE Y2FRAME SWITCH (FOR THE RIGHT VERTICAL ',
15906     1'FRAME LINE ONLY) HAS JUST BEEN TURNED ON')
15907      CALL DPWRST('XXX','BUG ')
15908 1619 CONTINUE
15909      GOTO1900
15910C
15911 1620 CONTINUE
15912      IFOUND='YES'
15913      IY2FSW='OFF'
15914C
15915      IF(IFEEDB.EQ.'OFF')GOTO1629
15916      WRITE(ICOUT,999)
15917      CALL DPWRST('XXX','BUG ')
15918      WRITE(ICOUT,1625)
15919 1625 FORMAT('THE Y2FRAME SWITCH (FOR THE RIGHT VERTICAL ',
15920     1'FRAME LINE ONLY) HAS JUST BEEN TURNED OFF')
15921      CALL DPWRST('XXX','BUG ')
15922 1629 CONTINUE
15923      GOTO1900
15924C
15925 1699 CONTINUE
15926C
15927C               **************************************************
15928C               **  TREAT THE CASE WHEN                         **
15929C               **  THE ENTIRE 4-SIDED FRAME IS TO BE CHANGED   **
15930C               **************************************************
15931C
15932      IF(ICOM.EQ.'XYFR')GOTO1700
15933      IF(ICOM.EQ.'YXFR')GOTO1700
15934      IF(ICOM.EQ.'FRAM')GOTO1700
15935      GOTO1799
15936C
15937 1700 CONTINUE
15938      IF(NUMARG.LE.0)GOTO1710
15939      IF(IHARG(NUMARG).EQ.'ON')GOTO1710
15940      IF(IHARG(NUMARG).EQ.'OFF')GOTO1720
15941      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1710
15942      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1710
15943      IERROR='YES'
15944      GOTO1900
15945C
15946 1710 CONTINUE
15947      IFOUND='YES'
15948      IX1FSW='ON'
15949      IX2FSW='ON'
15950      IY1FSW='ON'
15951      IY2FSW='ON'
15952C
15953      IF(IFEEDB.EQ.'OFF')GOTO1719
15954      WRITE(ICOUT,999)
15955      CALL DPWRST('XXX','BUG ')
15956      WRITE(ICOUT,1715)
15957 1715 FORMAT('THE FRAME SWITCH (FOR THE ENTIRE 4-SIDED FRAME) ',
15958     1'HAS JUST BEEN TURNED ON')
15959      CALL DPWRST('XXX','BUG ')
15960 1719 CONTINUE
15961      GOTO1900
15962C
15963 1720 CONTINUE
15964      IFOUND='YES'
15965      IX1FSW='OFF'
15966      IX2FSW='OFF'
15967      IY1FSW='OFF'
15968      IY2FSW='OFF'
15969C
15970      IF(IFEEDB.EQ.'OFF')GOTO1729
15971      WRITE(ICOUT,999)
15972      CALL DPWRST('XXX','BUG ')
15973      WRITE(ICOUT,1725)
15974 1725 FORMAT('THE FRAME SWITCH (FOR THE ENTIRE 4-SIDED FRAME) ',
15975     1'HAS JUST BEEN TURNED OFF')
15976      CALL DPWRST('XXX','BUG ')
15977 1729 CONTINUE
15978      GOTO1900
15979C
15980 1799 CONTINUE
15981C
15982 1900 CONTINUE
15983      RETURN
15984      END
15985      SUBROUTINE DPFRCC(IHARG,IHARG2,IARGT,ARG,NUMARG,
15986     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,IANS,IWIDTH,
15987     1PXMIN,PXMAX,PYMIN,PYMAX,IBUGP2,IFOUND,IERROR)
15988C
15989C     PURPOSE--DEFINE THE FRAME CORNER COORDINATES
15990C              (LOWER LEFT AND UPPER RIGHT)
15991C              WHICH IN TURN WILL DEFINE THE SIZE AND SHAPE
15992C              OF THE PLOT FRAME.
15993C              THE 2 PAIRS OF COORDINATES ARE CONTAINED IN THE
15994C              4 VARIABLES    PXMIN,PYMIN    AND    PXMAX,PYMAX
15995C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
15996C                     --IARGT  (A  HOLLERITH VECTOR)
15997C                     --ARG    (A  FLOATING POINT VECTOR)
15998C                     --NUMARG
15999C     OUTPUT ARGUMENTS--PXMIN = X COOR. FOR LOWER LEFT  CORNER
16000C                     --PXMAX = X COOR. FOR UPPER RIGHT CORNER
16001C                     --PYMIN = Y COOR. FOR LOWER LEFT  CORNER
16002C                     --PYMAX = Y COOR. FOR UPPER RIGHT CORNER
16003C                     --IFOUND ('YES' OR 'NO' )
16004C                     --IERROR ('YES' OR 'NO' )
16005C     WRITTEN BY--JAMES J. FILLIBEN
16006C                 STATISTICAL ENGINEERING DIVISION
16007C                 INFORMATION TECHNOLOGY LABORATORY
16008C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
16009C                 GAITHERSBURG, MD 20899-8980
16010C                 PHONE--301-975-2855
16011C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
16012C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
16013C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
16014C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
16015C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
16016C     LANGUAGE--ANSI FORTRAN (1977)
16017C     VERSION NUMBER--82/7
16018C     ORIGINAL VERSION--NOVEMBER  1978.
16019C     UPDATED         --SEPTEMBER 1980.
16020C     UPDATED         --MARCH     1981.
16021C     UPDATED         --MAY       1982.
16022C
16023C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
16024C
16025      CHARACTER*4 IHARG
16026      CHARACTER*4 IHARG2
16027      CHARACTER*4 IARGT
16028      CHARACTER*4 IHNAME
16029      CHARACTER*4 IHNAM2
16030      CHARACTER*4 IUSE
16031      CHARACTER*4 IANS
16032      CHARACTER*4 IBUGP2
16033      CHARACTER*4 IFOUND
16034      CHARACTER*4 IERROR
16035C
16036      CHARACTER*4 IHWUSE
16037      CHARACTER*4 MESSAG
16038      CHARACTER*4 IHWORD
16039      CHARACTER*4 IHWOR2
16040C
16041      CHARACTER*4 ISUBN1
16042      CHARACTER*4 ISUBN2
16043C
16044C---------------------------------------------------------------------
16045C
16046      DIMENSION IHARG(*)
16047      DIMENSION IHARG2(*)
16048      DIMENSION IARGT(*)
16049      DIMENSION ARG(*)
16050C
16051      DIMENSION IHNAME(*)
16052      DIMENSION IHNAM2(*)
16053      DIMENSION IUSE(*)
16054      DIMENSION IN(*)
16055      DIMENSION IVALUE(*)
16056      DIMENSION VALUE(*)
16057      DIMENSION IANS(*)
16058C
16059C---------------------------------------------------------------------
16060C
16061      INCLUDE 'DPCOP2.INC'
16062C
16063C-----START POINT-----------------------------------------------------
16064C
16065      ISUBN1='DPFR'
16066      ISUBN2='CC  '
16067      IFOUND='NO'
16068      IERROR='NO'
16069C
16070      IF(IBUGP2.EQ.'OFF')GOTO90
16071      WRITE(ICOUT,999)
16072  999 FORMAT(1X)
16073      CALL DPWRST('XXX','BUG ')
16074      WRITE(ICOUT,51)
16075   51 FORMAT('***** AT THE BEGINNING OF DPFRCC--')
16076      CALL DPWRST('XXX','BUG ')
16077      WRITE(ICOUT,52)IFOUND,IERROR
16078   52 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
16079      CALL DPWRST('XXX','BUG ')
16080      WRITE(ICOUT,53)PXMIN,PXMAX,PYMIN,PYMAX
16081   53 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX = ',4E15.7)
16082      CALL DPWRST('XXX','BUG ')
16083   90 CONTINUE
16084C
16085C               **************************************************
16086C               **  TREAT THE    FRAME     COORDINATES    CASE  **
16087C               **************************************************
16088C
16089      IF(NUMARG.LE.1)GOTO1150
16090      GOTO1110
16091C
16092 1110 CONTINUE
16093      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
16094      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
16095      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
16096      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
16097      IF(NUMARG.GE.2)GOTO1175
16098      GOTO1120
16099C
16100 1120 CONTINUE
16101      IERROR='YES'
16102      WRITE(ICOUT,1121)
16103 1121 FORMAT('***** ERROR IN DPFRCC--')
16104      CALL DPWRST('XXX','BUG ')
16105      WRITE(ICOUT,1122)
16106 1122 FORMAT('      ILLEGAL FORM FOR FRAME CORNER COORDINATES ',
16107     1'COMMAND.')
16108      CALL DPWRST('XXX','BUG ')
16109      WRITE(ICOUT,1124)
16110 1124 FORMAT('      TEST EXAMPLE TO DEMONSTRATE THE ',
16111     1'PROPER FORM--')
16112      CALL DPWRST('XXX','BUG ')
16113      WRITE(ICOUT,1125)
16114 1125 FORMAT('      SUPPOSE IT IS DESIRED TO POSITION   ')
16115      CALL DPWRST('XXX','BUG ')
16116      WRITE(ICOUT,1126)
16117 1126 FORMAT('      THE LOWER LEFT CORNER OF THE FRAME')
16118      CALL DPWRST('XXX','BUG ')
16119      WRITE(ICOUT,1127)
16120 1127 FORMAT('      10% ACROSS THE PAGE AND 20% UP THE PAGE, AND')
16121      CALL DPWRST('XXX','BUG ')
16122      WRITE(ICOUT,1128)
16123 1128 FORMAT('      THE UPPER RIGHT CORNER OF THE FRAME')
16124      CALL DPWRST('XXX','BUG ')
16125      WRITE(ICOUT,1129)
16126 1129 FORMAT('      90% ACROSS THE PAGE AND 80% UP THE PAGE,')
16127      CALL DPWRST('XXX','BUG ')
16128      WRITE(ICOUT,1130)
16129 1130 FORMAT('      THEN THE ALLOWABLE FORM IS--')
16130      CALL DPWRST('XXX','BUG ')
16131      WRITE(ICOUT,1131)
16132 1131 FORMAT('      FRAME CORNER COORDINATES 10 20 90 80')
16133      CALL DPWRST('XXX','BUG ')
16134      GOTO9000
16135C
16136 1150 CONTINUE
16137      PXMIN=15.
16138      PYMIN=20.
16139      PXMAX=85.
16140      PYMAX=90.
16141      GOTO1180
16142C
16143 1175 CONTINUE
16144      DO1176J=2,NUMARG
16145      IF(IARGT(J).EQ.'NUMB')GOTO1177
16146      GOTO1178
16147 1177 CONTINUE
16148      IF(J.EQ.2)PXMIN=ARG(J)
16149      IF(J.EQ.3)PYMIN=ARG(J)
16150      IF(J.EQ.4)PXMAX=ARG(J)
16151      IF(J.EQ.5)PYMAX=ARG(J)
16152      GOTO1176
16153 1178 CONTINUE
16154      IHWORD=IHARG(J)
16155      IHWOR2=IHARG2(J)
16156      IHWUSE='P'
16157      MESSAG='YES'
16158      CALL CHECKN(IHWORD,IHWOR2,IHWUSE,
16159     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
16160     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR)
16161      IF(IERROR.EQ.'YES')GOTO9000
16162      IF(J.EQ.2)PXMIN=VALUE(ILOC)
16163      IF(J.EQ.3)PYMIN=VALUE(ILOC)
16164      IF(J.EQ.4)PXMAX=VALUE(ILOC)
16165      IF(J.EQ.5)PYMAX=VALUE(ILOC)
16166 1176 CONTINUE
16167      GOTO1180
16168C
16169 1180 CONTINUE
16170      IFOUND='YES'
16171C
16172      IF(IFEEDB.EQ.'OFF')GOTO1189
16173      WRITE(ICOUT,999)
16174      CALL DPWRST('XXX','BUG ')
16175      WRITE(ICOUT,1185)
16176 1185 FORMAT('THE FRAME CORNER COORDINATES HAVE JUST BEEN SET ',
16177     1'AS FOLLOWS--')
16178      CALL DPWRST('XXX','BUG ')
16179      WRITE(ICOUT,1186)PXMIN,PYMIN
16180 1186 FORMAT('    (X,Y) FOR LOWER LEFT  CORNER OF FRAME = ',2E15.7)
16181      CALL DPWRST('XXX','BUG ')
16182      WRITE(ICOUT,1187)PXMAX,PYMAX
16183 1187 FORMAT('    (X,Y) FOR UPPER RIGHT CORNER OF FRAME = ',2E15.7)
16184      CALL DPWRST('XXX','BUG ')
16185 1189 CONTINUE
16186      GOTO9000
16187C
16188C               *****************
16189C               **  STEP 90--  **
16190C               **  EXIT       **
16191C               *****************
16192C
16193 9000 CONTINUE
16194      IF(IBUGP2.EQ.'OFF')GOTO9090
16195      WRITE(ICOUT,999)
16196      CALL DPWRST('XXX','BUG ')
16197      WRITE(ICOUT,9011)
16198 9011 FORMAT('***** AT THE END       OF DPFRCC--')
16199      CALL DPWRST('XXX','BUG ')
16200      WRITE(ICOUT,9012)IFOUND,IERROR
16201 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
16202      CALL DPWRST('XXX','BUG ')
16203      WRITE(ICOUT,9013)PXMIN,PXMAX,PYMIN,PYMAX
16204 9013 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX = ',4E15.7)
16205      CALL DPWRST('XXX','BUG ')
16206 9090 CONTINUE
16207C
16208      RETURN
16209      END
16210      SUBROUTINE DPFRCL(ICOM,IHARG,NUMARG,
16211     1IDEFCO,
16212     1IX1FCO,IX2FCO,IY1FCO,IY2FCO,
16213     1IFOUND,IERROR)
16214C
16215C     PURPOSE--DEFINE THE FRAME COLOR SWITCHES
16216C              FOR ANY OF THE 4 FRAME LINES.
16217C              SUCH FRAME COLOR SWITCHES DEFINE THE COLOR
16218C              FOR EACH OF THE 4 FRAME LINES.
16219C              THE CONTENTS OF A FRAME COLOR SWITCH ARE
16220C              A COLOR.
16221C              THE FRAME COLOR SWITCHES FOR THE 4 FRAME LINES
16222C              ARE CONTAINED IN THE 4 VARIABLES
16223C              IX1FCO,IX2FCO,IY1FCO,IY2FCO.
16224C     INPUT  ARGUMENTS--ICOM
16225C                     --IHARG  (A  HOLLERITH VECTOR)
16226C                     --NUMARG
16227C                     --IDEFCO
16228C     OUTPUT ARGUMENTS--IX1FCO (A HOLLERITH VECTOR)
16229C                     --IX2FCO (A HOLLERITH VECTOR)
16230C                     --IY1FCO (A HOLLERITH VECTOR)
16231C                     --IY2FCO (A HOLLERITH VECTOR)
16232C                     --IFOUND ('YES' OR 'NO' )
16233C                     --IERROR ('YES' OR 'NO' )
16234C     WRITTEN BY--JAMES J. FILLIBEN
16235C                 STATISTICAL ENGINEERING DIVISION
16236C                 INFORMATION TECHNOLOGY LABORATORY
16237C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
16238C                 GAITHERSBURG, MD 20899-8980
16239C                 PHONE--301-975-2855
16240C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
16241C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
16242C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
16243C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
16244C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
16245C     LANGUAGE--ANSI FORTRAN (1977)
16246C     VERSION NUMBER--82/7
16247C     ORIGINAL VERSION--OCTOBER   1980.
16248C     UPDATED         --MAY       1982.
16249C
16250C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
16251C
16252      CHARACTER*4 ICOM
16253      CHARACTER*4 IHARG
16254      CHARACTER*4 IDEFCO
16255C
16256      CHARACTER*4 IX1FCO
16257      CHARACTER*4 IX2FCO
16258      CHARACTER*4 IY1FCO
16259      CHARACTER*4 IY2FCO
16260C
16261      CHARACTER*4 IFOUND
16262      CHARACTER*4 IERROR
16263C
16264      CHARACTER*4 IHOLD
16265C
16266C---------------------------------------------------------------------
16267C
16268      DIMENSION IHARG(*)
16269C
16270C
16271C---------------------------------------------------------------------
16272C
16273      INCLUDE 'DPCOP2.INC'
16274C
16275C-----START POINT-----------------------------------------------------
16276C
16277      IFOUND='NO'
16278      IERROR='NO'
16279C
16280      IF(NUMARG.LE.0)GOTO1900
16281      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COLO')GOTO1090
16282      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MARK'.AND.
16283     1IHARG(2).EQ.'COLO')GOTO1090
16284      GOTO1900
16285 1090 CONTINUE
16286C
16287C               *****************************************************
16288C               **  TREAT THE CASE WHEN                            **
16289C               **  BOTH HORIZONTAL FRAMES    ARE TO BE CHANGED    **
16290C               *****************************************************
16291C
16292      IF(ICOM.EQ.'XFRA')GOTO1100
16293      GOTO1199
16294C
16295 1100 CONTINUE
16296      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
16297      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
16298      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
16299      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
16300      IF(IHARG(NUMARG).EQ.'COLO')GOTO1150
16301      GOTO1160
16302C
16303 1150 CONTINUE
16304      IHOLD=IDEFCO
16305      GOTO1180
16306C
16307 1160 CONTINUE
16308      IHOLD=IHARG(NUMARG)
16309      GOTO1180
16310C
16311 1180 CONTINUE
16312      IFOUND='YES'
16313      IX1FCO=IHOLD
16314      IX2FCO=IHOLD
16315C
16316      IF(IFEEDB.EQ.'OFF')GOTO1189
16317      WRITE(ICOUT,999)
16318  999 FORMAT(1X)
16319      CALL DPWRST('XXX','BUG ')
16320      WRITE(ICOUT,1181)
16321 1181 FORMAT('THE FRAME COLOR (FOR BOTH HORIZONTAL ',
16322     1'FRAME LINES)')
16323      CALL DPWRST('XXX','BUG ')
16324      WRITE(ICOUT,1182)IHOLD
16325 1182 FORMAT('HAS JUST BEEN SET TO ',A4)
16326      CALL DPWRST('XXX','BUG ')
16327 1189 CONTINUE
16328      GOTO1900
16329C
16330 1199 CONTINUE
16331C
16332C               **************************************************************
16333C               **  TREAT THE CASE WHEN                                     **
16334C               **  ONLY THE BOTTOM HORIZONTAL FRAME IS      TO BE CHANGED  **
16335C               **************************************************************
16336C
16337      IF(ICOM.EQ.'X1FR')GOTO1200
16338      GOTO1299
16339C
16340 1200 CONTINUE
16341      IF(IHARG(NUMARG).EQ.'ON')GOTO1250
16342      IF(IHARG(NUMARG).EQ.'OFF')GOTO1250
16343      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250
16344      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250
16345      IF(IHARG(NUMARG).EQ.'COLO')GOTO1250
16346      GOTO1260
16347C
16348 1250 CONTINUE
16349      IHOLD=IDEFCO
16350      GOTO1280
16351C
16352 1260 CONTINUE
16353      IHOLD=IHARG(NUMARG)
16354      GOTO1280
16355C
16356 1280 CONTINUE
16357      IFOUND='YES'
16358      IX1FCO=IHOLD
16359C
16360      IF(IFEEDB.EQ.'OFF')GOTO1289
16361      WRITE(ICOUT,999)
16362      CALL DPWRST('XXX','BUG ')
16363      WRITE(ICOUT,1281)
16364 1281 FORMAT('THE FRAME COLOR (FOR THE BOTTOM HORIZONTAL ',
16365     1'FRAME LINE)')
16366      CALL DPWRST('XXX','BUG ')
16367      WRITE(ICOUT,1282)IHOLD
16368 1282 FORMAT('HAS JUST BEEN SET TO ',A4)
16369      CALL DPWRST('XXX','BUG ')
16370 1289 CONTINUE
16371      GOTO1900
16372C
16373 1299 CONTINUE
16374C
16375C               **************************************************************
16376C               **  TREAT THE CASE WHEN                                     **
16377C               **  ONLY THE TOP    HORIZONTAL FRAME IS      TO BE CHANGED  **
16378C               **************************************************************
16379C
16380      IF(ICOM.EQ.'X2FR')GOTO1300
16381      GOTO1399
16382C
16383 1300 CONTINUE
16384      IF(IHARG(NUMARG).EQ.'ON')GOTO1350
16385      IF(IHARG(NUMARG).EQ.'OFF')GOTO1350
16386      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350
16387      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350
16388      IF(IHARG(NUMARG).EQ.'COLO')GOTO1350
16389      GOTO1360
16390C
16391 1350 CONTINUE
16392      IHOLD=IDEFCO
16393      GOTO1380
16394C
16395 1360 CONTINUE
16396      IHOLD=IHARG(NUMARG)
16397      GOTO1380
16398C
16399 1380 CONTINUE
16400      IFOUND='YES'
16401      IX2FCO=IHOLD
16402C
16403      IF(IFEEDB.EQ.'OFF')GOTO1389
16404      WRITE(ICOUT,999)
16405      CALL DPWRST('XXX','BUG ')
16406      WRITE(ICOUT,1381)
16407 1381 FORMAT('THE FRAME COLOR (FOR THE TOP HORIZONTAL ',
16408     1'FRAME LINE)')
16409      CALL DPWRST('XXX','BUG ')
16410      WRITE(ICOUT,1382)IHOLD
16411 1382 FORMAT('HAS JUST BEEN SET TO ',A4)
16412      CALL DPWRST('XXX','BUG ')
16413 1389 CONTINUE
16414      GOTO1900
16415C
16416 1399 CONTINUE
16417C
16418C               *****************************************************
16419C               **  TREAT THE CASE WHEN                            **
16420C               **  BOTH VERTICAL   FRAMES    ARE TO BE CHANGED    **
16421C               *****************************************************
16422C
16423      IF(ICOM.EQ.'YFRA')GOTO1400
16424      GOTO1499
16425C
16426 1400 CONTINUE
16427      IF(IHARG(NUMARG).EQ.'ON')GOTO1450
16428      IF(IHARG(NUMARG).EQ.'OFF')GOTO1450
16429      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1450
16430      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1450
16431      IF(IHARG(NUMARG).EQ.'COLO')GOTO1450
16432      GOTO1460
16433C
16434 1450 CONTINUE
16435      IHOLD=IDEFCO
16436      GOTO1480
16437C
16438 1460 CONTINUE
16439      IHOLD=IHARG(NUMARG)
16440      GOTO1480
16441C
16442 1480 CONTINUE
16443      IFOUND='YES'
16444      IY1FCO=IHOLD
16445      IY2FCO=IHOLD
16446C
16447      IF(IFEEDB.EQ.'OFF')GOTO1489
16448      WRITE(ICOUT,999)
16449      CALL DPWRST('XXX','BUG ')
16450      WRITE(ICOUT,1481)
16451 1481 FORMAT('THE FRAME COLOR (FOR BOTH VERTICAL ',
16452     1'FRAME LINES)')
16453      CALL DPWRST('XXX','BUG ')
16454      WRITE(ICOUT,1482)IHOLD
16455 1482 FORMAT('HAS JUST BEEN SET TO ',A4)
16456      CALL DPWRST('XXX','BUG ')
16457 1489 CONTINUE
16458      GOTO1900
16459C
16460 1499 CONTINUE
16461C
16462C               **************************************************************
16463C               **  TREAT THE CASE WHEN                                     **
16464C               **  ONLY THE LEFT   VERTICAL   FRAME IS      TO BE CHANGED  **
16465C               **************************************************************
16466C
16467      IF(ICOM.EQ.'Y1FR')GOTO1500
16468      GOTO1599
16469C
16470 1500 CONTINUE
16471      IF(IHARG(NUMARG).EQ.'ON')GOTO1550
16472      IF(IHARG(NUMARG).EQ.'OFF')GOTO1550
16473      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1550
16474      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1550
16475      IF(IHARG(NUMARG).EQ.'COLO')GOTO1550
16476      GOTO1560
16477C
16478 1550 CONTINUE
16479      IHOLD=IDEFCO
16480      GOTO1580
16481C
16482 1560 CONTINUE
16483      IHOLD=IHARG(NUMARG)
16484      GOTO1580
16485C
16486 1580 CONTINUE
16487      IFOUND='YES'
16488      IY1FCO=IHOLD
16489C
16490      IF(IFEEDB.EQ.'OFF')GOTO1589
16491      WRITE(ICOUT,999)
16492      CALL DPWRST('XXX','BUG ')
16493      WRITE(ICOUT,1581)
16494 1581 FORMAT('THE FRAME COLOR (FOR THE LEFT VERTICAL ',
16495     1'FRAME LINE)')
16496      CALL DPWRST('XXX','BUG ')
16497      WRITE(ICOUT,1582)IHOLD
16498 1582 FORMAT('HAS JUST BEEN SET TO ',A4)
16499      CALL DPWRST('XXX','BUG ')
16500 1589 CONTINUE
16501      GOTO1900
16502C
16503 1599 CONTINUE
16504C
16505C               **************************************************************
16506C               **  TREAT THE CASE WHEN                                     **
16507C               **  ONLY THE RIGHT  VERTICAL   FRAME IS      TO BE CHANGED  **
16508C               **************************************************************
16509C
16510      IF(ICOM.EQ.'Y2FR')GOTO1600
16511      GOTO1699
16512C
16513 1600 CONTINUE
16514      IF(IHARG(NUMARG).EQ.'ON')GOTO1650
16515      IF(IHARG(NUMARG).EQ.'OFF')GOTO1650
16516      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1650
16517      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1650
16518      IF(IHARG(NUMARG).EQ.'COLO')GOTO1650
16519      GOTO1660
16520C
16521 1650 CONTINUE
16522      IHOLD=IDEFCO
16523      GOTO1680
16524C
16525 1660 CONTINUE
16526      IHOLD=IHARG(NUMARG)
16527      GOTO1680
16528C
16529 1680 CONTINUE
16530      IFOUND='YES'
16531      IY2FCO=IHOLD
16532C
16533      IF(IFEEDB.EQ.'OFF')GOTO1689
16534      WRITE(ICOUT,999)
16535      CALL DPWRST('XXX','BUG ')
16536      WRITE(ICOUT,1681)
16537 1681 FORMAT('THE FRAME COLOR (FOR THE RIGHT VERTICAL ',
16538     1'FRAME LINE)')
16539      CALL DPWRST('XXX','BUG ')
16540      WRITE(ICOUT,1682)IHOLD
16541 1682 FORMAT('HAS JUST BEEN SET TO ',A4)
16542      CALL DPWRST('XXX','BUG ')
16543 1689 CONTINUE
16544      GOTO1900
16545C
16546 1699 CONTINUE
16547C
16548C               *****************************************************
16549C               **  TREAT THE CASE WHEN                            **
16550C               **  ALL 4 FRAME FRAME LINES ARE TO BE CHANGED      **
16551C               *****************************************************
16552C
16553      IF(ICOM.EQ.'FRAM')GOTO1700
16554      IF(ICOM.EQ.'XYFR')GOTO1700
16555      IF(ICOM.EQ.'YXFR')GOTO1700
16556      GOTO1799
16557C
16558 1700 CONTINUE
16559      IF(IHARG(NUMARG).EQ.'ON')GOTO1750
16560      IF(IHARG(NUMARG).EQ.'OFF')GOTO1750
16561      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1750
16562      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1750
16563      IF(IHARG(NUMARG).EQ.'COLO')GOTO1750
16564      GOTO1760
16565C
16566 1750 CONTINUE
16567      IHOLD=IDEFCO
16568      GOTO1780
16569C
16570 1760 CONTINUE
16571      IHOLD=IHARG(NUMARG)
16572      GOTO1780
16573C
16574 1780 CONTINUE
16575      IFOUND='YES'
16576      IX1FCO=IHOLD
16577      IX2FCO=IHOLD
16578      IY1FCO=IHOLD
16579      IY2FCO=IHOLD
16580C
16581      IF(IFEEDB.EQ.'OFF')GOTO1789
16582      WRITE(ICOUT,999)
16583      CALL DPWRST('XXX','BUG ')
16584      WRITE(ICOUT,1781)
16585 1781 FORMAT('THE FRAME COLOR (FOR ALL 4 ',
16586     1'FRAME LINES)')
16587      CALL DPWRST('XXX','BUG ')
16588      WRITE(ICOUT,1782)IHOLD
16589 1782 FORMAT('HAS JUST BEEN SET TO ',A4)
16590      CALL DPWRST('XXX','BUG ')
16591 1789 CONTINUE
16592      GOTO1900
16593C
16594 1799 CONTINUE
16595C
16596 1900 CONTINUE
16597      RETURN
16598      END
16599      SUBROUTINE DPFRE2(Y,X,XHIGH,N,NCURVE,
16600     1                  ICASPL,IRELAT,IHIGH,IDATSW,IRHSTG,IHSTCW,
16601     1                  IHSTEB,IHSTOU,
16602     1                  CLWID,XSTART,XSTOP,
16603     1                  XTEMP1,XTEMP2,XIDTEM,MAXOBV,
16604     1                  Y2,X2,X3D,D2,N2,NPLOTV,
16605     1                  IBUGG3,ISUBRO,IERROR)
16606C
16607C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
16608C              THAT WILL DEFINE
16609C                   1) A FREQUENCY PLOT,
16610C                   2) A RELATIVE FREQUENCY PLOT
16611C                      (THAT IS, WITH AREA = 1).
16612C                   3) A CUMULATIVE FREQUENCY PLOT
16613C                   4) A RELATIVE CUMULATIVE FREQUENCY PLOT
16614C                      (THAT IS, WITH MAX ORDINATE = 1).
16615C     WRITTEN BY--JAMES J. FILLIBEN
16616C                 STATISTICAL ENGINEERING DIVISION
16617C                 INFORMATION TECHNOLOGY LABORATORY
16618C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
16619C                 GAITHERSBURG, MD 20899-8980
16620C                 PHONE--301-975-2855
16621C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
16622C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
16623C     LANGUAGE--ANSI FORTRAN (1977)
16624C     VERSION NUMBER--82/7
16625C     ORIGINAL VERSION--APRIL     1978.
16626C     UPDATED         --MAY       1978.
16627C     UPDATED         --JUNE      1978.
16628C     UPDATED         --OCTOBER   1978.
16629C     UPDATED         --MARCH     1979.
16630C     UPDATED         --APRIL     1979.
16631C     UPDATED         --JANUARY   1981.
16632C     UPDATED         --AUGUST    1981.
16633C     UPDATED         --OCTOBER   1981.
16634C     UPDATED         --DECEMBER  1981.
16635C     UPDATED         --APRIL     1982.
16636C     UPDATED         --MAY       1982.
16637C     UPDATED         --DECEMBER  1999.  CHECK FOR POINTS OUTSIDE
16638C                                        INTERVAL
16639C     UPDATED         --FEBRUARY   2010. FOR "RAW" CASE, PUT RESPONSE
16640C                                        IN Y RATHER THAN X
16641C     UPDATED         --FEBRUARY   2010. SUPPORT FOR "HIGHLIGHTED" OPTION
16642C     UPDATED         --FEBRUARY   2010. SUPPORT FOR NON-EQUISPACED
16643C                                        FREQUENCY PLOTS
16644C     UPDATED         --FEBRUARY   2010. OPTION TO SUPPRESS EMPTY BINS
16645C     UPDATED         --FEBRUARY   2010. OPTION TO INCLUDE OUTLIERS
16646C     UPDATED         --FEBRUARY   2010. CALL DPBINZ TO HANDLE BINNING
16647C
16648C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
16649C
16650      CHARACTER*4 ICASPL
16651      CHARACTER*4 IRELAT
16652      CHARACTER*4 IDATSW
16653      CHARACTER*4 IRHSTG
16654      CHARACTER*4 IHSTCW
16655      CHARACTER*4 IHSTEB
16656      CHARACTER*4 IHSTOU
16657      CHARACTER*4 IHIGH
16658      CHARACTER*4 IBUGG3
16659      CHARACTER*4 ISUBRO
16660      CHARACTER*4 IERROR
16661C
16662      CHARACTER*4 IWRIT2
16663      CHARACTER*4 ISUBN1
16664      CHARACTER*4 ISUBN2
16665C
16666      DOUBLE PRECISION DCLWID
16667      DOUBLE PRECISION DXSTAR
16668      DOUBLE PRECISION DXSTOP
16669      DOUBLE PRECISION DCLMNJ
16670      DOUBLE PRECISION DCLMDJ
16671      DOUBLE PRECISION DCLMXJ
16672      DOUBLE PRECISION DJ
16673      DOUBLE PRECISION DXI
16674      DOUBLE PRECISION DXI2
16675      DOUBLE PRECISION DDELI
16676      DOUBLE PRECISION DABSDE
16677      DOUBLE PRECISION DTOTWI
16678      DOUBLE PRECISION DD21
16679      DOUBLE PRECISION DD2N
16680      DOUBLE PRECISION DN3
16681      DOUBLE PRECISION DN4
16682      DOUBLE PRECISION DSUM
16683C
16684C---------------------------------------------------------------------
16685C
16686      DIMENSION Y(*)
16687      DIMENSION X(*)
16688      DIMENSION XHIGH(*)
16689      DIMENSION Y2(*)
16690      DIMENSION X2(*)
16691      DIMENSION X3D(*)
16692      DIMENSION D2(*)
16693      DIMENSION XTEMP1(*)
16694      DIMENSION XTEMP2(*)
16695      DIMENSION XIDTEM(*)
16696C
16697C---------------------------------------------------------------------
16698C
16699      INCLUDE 'DPCOP2.INC'
16700C
16701C-----START POINT-----------------------------------------------------
16702C
16703      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'FRE2')THEN
16704        WRITE(ICOUT,999)
16705  999   FORMAT(1X)
16706        CALL DPWRST('XXX','BUG ')
16707        WRITE(ICOUT,70)
16708   70   FORMAT('***** AT THE BEGINNING OF DPFRE2--')
16709        CALL DPWRST('XXX','BUG ')
16710        WRITE(ICOUT,71)IDATSW,IHSTCW,IHSTOU
16711   71   FORMAT('IDATSW,IHSTCW,IHSTOU = ',2(A4,2X),A4)
16712        CALL DPWRST('XXX','BUG ')
16713        WRITE(ICOUT,72)N,CLWID,XSTART,XSTOP
16714   72   FORMAT('N,CLWID,XSTART,XSTOP = ',I6,3E15.7)
16715        CALL DPWRST('XXX','BUG ')
16716        DO73I=1,N
16717          WRITE(ICOUT,74)I,Y(I),X(I)
16718   74     FORMAT('I, Y(I), X(I) = ',I8,2E15.7)
16719          CALL DPWRST('XXX','BUG ')
16720   73   CONTINUE
16721      ENDIF
16722C
16723      ISUBN1='DPFR'
16724      ISUBN2='E2  '
16725      IERROR='NO'
16726      IWRIT2='OFF'
16727C
16728      K=-999
16729      DCLMDJ=-999.0D0
16730      KP3=0
16731      AN3=0.0
16732      DENOM=0.0
16733      DN4=0.0D0
16734C
16735      DCLWID=CLWID
16736      DXSTAR=XSTART
16737      DXSTOP=XSTOP
16738C
16739C               ********************************************
16740C               **  STEP 1--                              **
16741C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
16742C               ********************************************
16743C
16744      IF(N.LT.1)THEN
16745        WRITE(ICOUT,999)
16746        CALL DPWRST('XXX','BUG ')
16747        WRITE(ICOUT,31)
16748   31   FORMAT('***** ERROR IN FREQUENCY PLOT--')
16749        CALL DPWRST('XXX','BUG ')
16750        WRITE(ICOUT,32)
16751   32   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 1;')
16752        CALL DPWRST('XXX','BUG ')
16753        WRITE(ICOUT,34)N
16754   34   FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6)
16755        CALL DPWRST('XXX','BUG ')
16756        WRITE(ICOUT,999)
16757        CALL DPWRST('XXX','BUG ')
16758        IERROR='YES'
16759        GOTO9000
16760      ENDIF
16761C
16762CCCCC FEBRUARY 2010. IF ALL ELEMENTS THE SAME, THEN PRINT WARNING
16763CCCCC                AND HANDLE AS A SPECIAL CASE.
16764C
16765      IF(IDATSW.EQ.'RAW')THEN
16766        HOLD=Y(1)
16767        DO60I=1,N
16768          IF(Y(I).NE.HOLD)GOTO69
16769   60   CONTINUE
16770        WRITE(ICOUT,999)
16771        CALL DPWRST('XXX','BUG ')
16772        WRITE(ICOUT,61)
16773   61   FORMAT('***** WARNING IN FREQUENCY PLOT--')
16774        CALL DPWRST('XXX','BUG ')
16775        WRITE(ICOUT,62)
16776   62   FORMAT('      ALL INPUT HORIZONTAL AXIS ELEMENTS')
16777        CALL DPWRST('XXX','BUG ')
16778        WRITE(ICOUT,63)HOLD
16779   63   FORMAT('      ARE IDENTICALLY EQUAL TO ',G15.7)
16780        CALL DPWRST('XXX','BUG ')
16781        WRITE(ICOUT,999)
16782        CALL DPWRST('XXX','BUG ')
16783C
16784        X2(N2+1)=HOLD-1.0
16785        X2(N2+2)=HOLD
16786        X2(N2+3)=HOLD+1.0
16787        IF(IRELAT.EQ.'ON')THEN
16788          Y2(N2+1)=0.0
16789          Y2(N2+2)=1.0
16790          Y2(N2+3)=0.0
16791        ELSE
16792          Y2(N2+1)=0.0
16793          Y2(N2+2)=REAL(N)
16794          Y2(N2+3)=0.0
16795        ENDIF
16796        D2(N2+1)=REAL(NCURVE)
16797        D2(N2+2)=REAL(NCURVE)
16798        D2(N2+3)=REAL(NCURVE)
16799        N2=N2+3
16800        NPLOTV=2
16801        GOTO9000
16802      ENDIF
16803C
16804   69 CONTINUE
16805C
16806C               **********************************************
16807C               **  STEP 2--                                **
16808C               **  IF NECESSARY,                           **
16809C               **  DETERMINE CLASS WIDTH,                  **
16810C               **  START VALUE, STOP VALUE,                **
16811C               **  AND NUMBER OF CLASSES.                  **
16812C               **********************************************
16813C
16814      IF(IDATSW.EQ.'RAW')THEN
16815        CALL DPBINZ(Y,N,CLWID,XSTART,XSTOP,
16816     1              XTEMP1,MAXOBV,IHSTCW,IHSTOU,
16817     1              DCLWID,DXSTAR,DXSTOP,
16818     1              ISUBRO,IBUGG3,IERROR)
16819C
16820      ELSEIF(IDATSW.EQ.'FREQ')THEN
16821        CALL SORT(X,N,XTEMP1)
16822        NM1=N-1
16823        DCLWID=XTEMP1(2)-XTEMP1(1)
16824        DO160I=1,NM1
16825          IP1=I+1
16826          DDELI=XTEMP1(IP1)-XTEMP1(I)
16827          IF(DDELI.LT.DCLWID)DCLWID=DDELI
16828  160   CONTINUE
16829        DD21=XTEMP1(1)
16830        DD2N=XTEMP1(N)
16831        DXSTAR=DD21-(DCLWID/2.0D0)
16832        DXSTOP=DD2N+(DCLWID/2.0D0)
16833C
16834      ELSEIF(IDATSW.EQ.'FRE2')THEN
16835        DXSTAR=X(1)
16836        DXSTOP=XHIGH(N)
16837      ENDIF
16838C
16839      IF(IDATSW.EQ.'FRE2')THEN
16840        NUMCLA=N
16841      ELSE
16842        DTOTWI=DXSTOP-DXSTAR
16843        ANUMCL=DTOTWI/DCLWID
16844        NUMCLA=INT(ANUMCL+1.0 + 0.1)
16845C
16846        J=NUMCLA-1
16847        DJ=J
16848        DCLMXJ=DXSTAR+DJ*DCLWID
16849        DABSDE=DABS(DCLMXJ-DXSTOP)
16850        IF(DABSDE.LE.0.0001D0)NUMCLA=NUMCLA-1
16851      ENDIF
16852C
16853C               *******************************************************
16854C               **  STEP 3--                                         **
16855C               **  DETERMINE THE FREQUENCY (COUNTS) FOR EACH CLASS  **
16856C               *******************************************************
16857C
16858C     HISTOGRAM SUPPORTS A "HIGHLIGHTED" OPTION.  CURRENTLY, THIS
16859C     IS NOT SUPPORTED FOR FREQUENCY POLYGON.  HOWEVER, LEAVE BASIC
16860C     STRUCTURE IN PLACE IN CASE WE WANT TO IMPLEMENT THIS IN THE
16861C     FUTURE.
16862C
16863      IF(IDATSW.EQ.'RAW' .AND. IHIGH.EQ.'ON')THEN
16864        CALL DISTIN(X,N,IWRIT2,XIDTEM,NDIST,IBUGG3,IERROR)
16865        CALL SORT(XIDTEM,NDIST,XIDTEM)
16866      ELSE
16867        NDIST=1
16868      ENDIF
16869      NPOINT=0
16870C
16871      DO300IREPL=1,NDIST
16872C
16873        IF(IREPL.EQ.1)THEN
16874          DO301ISET=1,N
16875            XTEMP2(ISET)=Y(ISET)
16876  301     CONTINUE
16877          NTEMP=N
16878          ATAG=REAL(NCURVE)
16879        ELSE
16880          ICNT=0
16881          AHOLD=XIDTEM(IREPL-1)
16882          DO306ISET=1,N
16883            IF(X(ISET).EQ.AHOLD)THEN
16884              ICNT=ICNT+1
16885              XTEMP2(ICNT)=Y(ISET)
16886            ENDIF
16887  306     CONTINUE
16888          NTEMP=ICNT
16889          ATAG=REAL(NDIST - IREPL + 2)
16890        ENDIF
16891C
16892        DO310J=1,NUMCLA
16893          XTEMP1(J)=0.0
16894  310   CONTINUE
16895C
16896        IF(IDATSW.EQ.'RAW')THEN
16897          IBELOW=0
16898          IABOVE=0
16899          DO420I=1,NTEMP
16900            DXI=XTEMP2(I)
16901            IF(DXI.LT.DXSTAR)THEN
16902              IBELOW=IBELOW+1
16903              GOTO420
16904            ELSEIF(DXI.GT.DXSTOP)THEN
16905              IABOVE=IABOVE+1
16906              GOTO420
16907            ENDIF
16908            DO430J=1,NUMCLA
16909              J2=J
16910              DJ=J
16911              DCLMNJ=DXSTAR+(DJ-1.0D0)*DCLWID
16912              DCLMXJ=DXSTAR+DJ*DCLWID
16913              IF(DCLMXJ.GT.DXSTOP)DCLMXJ=DXSTOP
16914              IF(DCLMNJ.LE.DXI.AND.DXI.LT.DCLMXJ)GOTO440
16915  430       CONTINUE
16916            GOTO420
16917  440       CONTINUE
16918            XTEMP1(J2)=XTEMP1(J2)+1.0
16919  420     CONTINUE
16920C
16921C         FOR THIS RAW DATA CASE,
16922C         TREAT THE SPECIAL CASE OF EQUALITY
16923C         WITH THE UPPER LIMIT OF THE LAST (RIGHT-MOST) CLASS
16924C
16925          J=NUMCLA
16926          DO450I=1,NTEMP
16927            DJ=J
16928            DCLMXJ=DXSTAR+DJ*DCLWID
16929            IF(DCLMXJ.GT.DXSTOP)DCLMXJ=DXSTOP
16930            DXI=XTEMP2(I)
16931            IF(DXI.EQ.DCLMXJ)XTEMP1(J)=XTEMP1(J)+1.0
16932  450     CONTINUE
16933        ELSEIF(IDATSW.EQ.'FREQ')THEN
16934          IBELOW=0
16935          IABOVE=0
16936          DO520I=1,N
16937            DXI=X(I)
16938            IF(DXI.LT.DXSTAR)THEN
16939              IBELOW=IBELOW+1
16940              GOTO520
16941            ELSEIF(DXI.GT.DXSTOP)THEN
16942              IABOVE=IABOVE+1
16943              GOTO520
16944            ENDIF
16945            DO530J=1,NUMCLA
16946              J2=J
16947              DJ=J
16948              DCLMNJ=DXSTAR+(DJ-1.0D0)*DCLWID
16949              DCLMXJ=DXSTAR+DJ*DCLWID
16950              IF(DCLMXJ.GT.DXSTOP)DCLMXJ=DXSTOP
16951              IF(DCLMNJ.LE.DXI.AND.DXI.LT.DCLMXJ)GOTO540
16952  530       CONTINUE
16953            GOTO520
16954  540       CONTINUE
16955            XTEMP1(J2)=XTEMP1(J2)+Y(I)
16956  520     CONTINUE
16957C
16958C         FOR THIS FREQUENCY DATA CASE, TREAT THE SPECIAL CASE OF
16959C         EQUALITY WITH THE UPPER LIMIT OF THE LAST (RIGHT-MOST) CLASS
16960C         (ALTHOUGH THIS SHOULD NOT HAPPEN WITH THE IDATSW = 'FREQ'
16961C         CASE.)
16962C
16963          J=NUMCLA
16964          DO550I=1,N
16965            DJ=J
16966            DCLMXJ=DXSTAR+DJ*DCLWID
16967            IF(DCLMXJ.GT.DXSTOP)DCLMXJ=DXSTOP
16968            DXI=X(I)
16969            IF(DXI.EQ.DCLMXJ)XTEMP1(J)=XTEMP1(J)+Y(I)
16970  550     CONTINUE
16971        ELSEIF(IDATSW.EQ.'FRE2')THEN
16972          IBELOW=0
16973          IABOVE=0
16974          DO570J=1,NUMCLA
16975            J2=J
16976            DXI=X(J)
16977            DXI2=XHIGH(J)
16978            IF(DXI.LT.DXSTAR)THEN
16979              IBELOW=IBELOW+1
16980              GOTO570
16981            ELSEIF(DXI2.GT.DXSTOP)THEN
16982              IABOVE=IABOVE+1
16983              GOTO570
16984             ELSE
16985                XTEMP1(J2)=Y(J)
16986            ENDIF
16987  570     CONTINUE
16988        ENDIF
16989C
16990        IF(IBELOW.GE.1)THEN
16991          WRITE(ICOUT,999)
16992          CALL DPWRST('XXX','BUG ')
16993          WRITE(ICOUT,1591)IBELOW,DXSTAR
16994 1591     FORMAT('***** WARNING: ',I8,' DATA POINTS ARE BELOW THE ',
16995     1           'MINIMUM CLASS VALUE OF ',G15.7)
16996          CALL DPWRST('XXX','BUG ')
16997        ENDIF
16998        IF(IABOVE.GE.1)THEN
16999          WRITE(ICOUT,999)
17000          CALL DPWRST('XXX','BUG ')
17001          WRITE(ICOUT,1691)IABOVE,DXSTOP
17002 1691     FORMAT('***** WARNING: ',I8,' DATA POINTS ARE ABOVE THE ',
17003     1           'MAXIMUM CLASS VALUE OF ',G15.7)
17004          CALL DPWRST('XXX','BUG ')
17005        ENDIF
17006C
17007        IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'FRE2')THEN
17008          WRITE(ICOUT,999)
17009          CALL DPWRST('XXX','BUG ')
17010          WRITE(ICOUT,591)
17011  591     FORMAT('***** IN THE MIDDLE    OF DPFRE2--')
17012          CALL DPWRST('XXX','BUG ')
17013          WRITE(ICOUT,592)DCLWID,DXSTAR,DXSTOP,DTOTWI,ANUMCL,NUMCLA
17014  592     FORMAT('DCLWID,DXSTAR,DXSTOP,DTOTWI,ANUMCL,NUMCLA= ',
17015     1           4D11.4,F10.0,I8)
17016          CALL DPWRST('XXX','BUG ')
17017          DO593J=1,NUMCLA
17018            DJ=J
17019            IF(IDATSW.EQ.'FRE2')THEN
17020              DCLMNJ=DBLE(X(J))
17021              DCLMXJ=DBLE(XHIGH(J))
17022            ELSE
17023              DCLMNJ=DXSTAR+(DJ-1.0D0)*DCLWID
17024              DCLMXJ=DXSTAR+DJ*DCLWID
17025            ENDIF
17026            IF(DCLMXJ.GT.DXSTOP)DCLMXJ=DXSTOP
17027            FJ=XTEMP1(J)
17028            WRITE(ICOUT,594)J,DCLMNJ,DCLMXJ,FJ
17029  594       FORMAT('J,DCLMNJ,DCLMXJ,FJ = ',I8,3G15.7)
17030            CALL DPWRST('XXX','BUG ')
17031  593     CONTINUE
17032        ENDIF
17033C
17034C               **********************************
17035C               **  STEP 4--                    **
17036C               **  DETERMINE PLOT COORDINATES  **
17037C               **********************************
17038C
17039        DSUM=0.0D0
17040        DO1110J=1,NUMCLA
17041          FJ=XTEMP1(J)
17042          DSUM=DSUM+DBLE(FJ)
17043 1110   CONTINUE
17044        DN3=DSUM
17045        AN3=DN3
17046C
17047        IF(IDATSW.EQ.'FRE2')THEN
17048          DSUM=0.0D0
17049          DO1112J=1,NUMCLA
17050            FJ=XTEMP1(J)*(XHIGH(J) - X(J))
17051            DSUM=DSUM+FJ
17052 1112     CONTINUE
17053          DN4=DSUM
17054        ENDIF
17055C
17056CCCCC   NOTE THAT THERE ARE TWO
17057CCCCC   WAYS TO DEFINE HEIGHT FOR RELATIVE HISTOGRAM.  ONE WAY DEFINES
17058CCCCC   THE AREA SO THAT THE AREA SUMS TO 1 (I.E., THE INTEGRAL) AS IN
17059CCCCC   A PROBABILITY DENSITY FUNCTION.  THE OTHER WAY IS SO THAT THE
17060CCCCC   THE HEIGHTS SUM TO 1, I.E., THE HEIGHT IS THE PERCENT OF THE
17061CCCCC   TOTAL.  THE IRHSTG SWITCH NOW DETERMINES WHICH METHOD IS USED.
17062C
17063        DENOM=1.0
17064        IF(IRELAT.EQ.'ON')THEN
17065          IF(IRHSTG.EQ.'PERC')THEN
17066            DENOM=DN3
17067          ELSE
17068            IF(IDATSW.EQ.'FRE2')THEN
17069              DENOM=DN4
17070            ELSE
17071              DENOM=DN3*DCLWID
17072            ENDIF
17073          ENDIF
17074        ENDIF
17075C
17076        NSTRT=NPOINT+1
17077        DSUM=0.0D0
17078        DO1120J=1,NUMCLA
17079          K=J
17080          NPOINT=NPOINT+1
17081          D2(N2+NPOINT)=ATAG
17082          IF(IDATSW.EQ.'FRE2')THEN
17083            X2(N2+NPOINT)=X(K)
17084            X3D(N2+NPOINT)=XHIGH(K)
17085          ELSE
17086            DJ=J
17087            DCLMDJ=DXSTAR+(DJ-0.5D0)*DCLWID
17088            X2(N2+NPOINT)=DCLMDJ
17089          ENDIF
17090          FJ=XTEMP1(J)
17091C
17092          IF(IREPL.GT.2)THEN
17093            ABASE=Y2(N2+NPOINT-NUMCLA)
17094          ELSE
17095            ABASE=0.0
17096          ENDIF
17097C
17098          IF(ICASPL.EQ.'FREQ')THEN
17099            Y2(N2+NPOINT)=(FJ/DENOM) + ABASE
17100          ELSEIF(ICASPL.EQ.'CUMF')THEN
17101            IF(IRELAT.EQ.'ON' .AND. IRHSTG.EQ.'AREA')THEN
17102              Y2(N2+NPOINT)=(FJ/DENOM) + ABASE
17103            ELSE
17104              DSUM=DSUM+FJ
17105              CUMFJ=(DSUM/DENOM)
17106              Y2(N2+NPOINT)=CUMFJ + ABASE
17107            ENDIF
17108          ENDIF
17109 1120   CONTINUE
17110C
17111C       FOR CUMULATIVE RELATIVE FREQUENCY PLOT (AREA CASE), COMPUTE
17112C       CUMULATIVE INTEGRAL OF POINTS.
17113C
17114        IF(ICASPL.EQ.'CUMF' .AND. IRELAT.EQ.'ON' .AND.
17115     1     IRHSTG.EQ.'AREA')THEN
17116          NSTOP=NPOINT
17117          NTOT=NSTOP-NSTRT+1
17118          NJUNK=2
17119          IWRIT2='OFF'
17120          CALL CUMINT(Y2(N2+NSTRT),X2(N2+NSTRT),NTOT,NJUNK,
17121     1                IWRIT2,XTEMP1,
17122     1                IBUGG3,IERROR)
17123          DO1129II=NSTRT,NSTOP
17124            Y2(N2+II)=XTEMP1(II)
17125 1129     CONTINUE
17126        ENDIF
17127C
17128  300 CONTINUE
17129C
17130      N2TEMP=NPOINT
17131      NPLOTV=2
17132C
17133C     FOR FREQUENCY POLYGON, "EMPTY BINS" OPTION ONLY APPLIES TO
17134C     THE START AND END PORTIONS OF THE PLOT.
17135C
17136      IF(IHSTEB.EQ.'OFF')THEN
17137        ICNT=0
17138        ISTRT=1
17139        ISTOP=N2TEMP
17140C
17141        DO1140J=1,N2TEMP
17142          IF(Y2(N2+J).GT.0.0)THEN
17143            ISTRT=J
17144            GOTO1149
17145          ENDIF
17146 1140   CONTINUE
17147 1149   CONTINUE
17148C
17149        DO1150J=N2TEMP,ISTRT,-1
17150          IF(Y2(N2+J).GT.0.0)THEN
17151            ISTOP=J
17152            GOTO1159
17153          ENDIF
17154 1150   CONTINUE
17155 1159   CONTINUE
17156C
17157        IF(ISTRT.GT.1 .OR. ISTOP.LT.N2TEMP)THEN
17158          DO1160J=ISTRT,ISTOP
17159            ICNT=ICNT+1
17160            X2(N2+ICNT)=X2(N2+J)
17161            Y2(N2+ICNT)=Y2(N2+J)
17162            X3D(N2+ICNT)=X3D(N2+J)
17163            D2(N2+ICNT)=D2(N2+J)
17164 1160     CONTINUE
17165          N2TEMP=ICNT
17166        ENDIF
17167      ENDIF
17168C
17169      N2=N2+N2TEMP
17170C
17171C               ******************
17172C               **   STEP 90--  **
17173C               **   EXIT       **
17174C               ******************
17175C
17176 9000 CONTINUE
17177      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'FRE2')THEN
17178        WRITE(ICOUT,999)
17179        CALL DPWRST('XXX','BUG ')
17180        WRITE(ICOUT,9011)
17181 9011   FORMAT('***** AT THE END       OF DPFRE2--')
17182        CALL DPWRST('XXX','BUG ')
17183        WRITE(ICOUT,9012)ICASPL,IRELAT,IERROR,N2
17184 9012   FORMAT('ICASPL,IRELAT,IERROR,N2 = ',A4,2X,A4,2X,A4,2X,I8)
17185        CALL DPWRST('XXX','BUG ')
17186        WRITE(ICOUT,9013)IDATSW,AN3,DENOM
17187 9013   FORMAT('IDATSW,AN3,DENOM = ',A4,2X,E15.8,E15.8)
17188        CALL DPWRST('XXX','BUG ')
17189        DO9015I=1,N2
17190          WRITE(ICOUT,9016)I,Y2(I),X2(I),D2(I)
17191 9016     FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2)
17192          CALL DPWRST('XXX','BUG ')
17193 9015   CONTINUE
17194      ENDIF
17195C
17196      RETURN
17197      END
17198      SUBROUTINE DPFRE5(TAG1,TAG2,NREPL,N,MAXOBV,
17199     1                 XIDTEM,XIDTE2,
17200     1                 TEMP1,TEMP2,
17201     1                 NUMSE1,NUMSE2,
17202     1                 IBUGG3,ISUBRO,IERROR)
17203C
17204C     PURPOSE--UTILITY ROUTINE USED BY DPFREQ (AND POSSIBLY OTHER
17205C              ROUTINES). FOR 1 TO 2 REPLICATION VARIABLES, IT
17206C              EXTRACTS THE DISTINCT ELEMENTS FROM EACH OF THEM
17207C              (AND CODES THEM 1 TO K WHERE K IS THE NUMBER OF
17208C              DISTINCT ELEMENTS).
17209C
17210C     WRITTEN BY--JAMES J. FILLIBEN
17211C                 STATISTICAL ENGINEERING DIVISION
17212C                 INFORMATION TECHNOLOGY LABORAOTRY
17213C                 NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY
17214C                 GAITHERSBURG, MD 20899-8980
17215C                 PHONE--301-975-2855
17216C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
17217C           OF THE NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY.
17218C     LANGUAGE--ANSI FORTRAN (1977)
17219C     VERSION NUMBER--2010/2
17220C     ORIGINAL VERSION--FEBRUARY  2010.
17221C
17222C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
17223C
17224      CHARACTER*4 IBUGG3
17225      CHARACTER*4 ISUBRO
17226      CHARACTER*4 IERROR
17227C
17228      CHARACTER*4 IWRITE
17229C
17230      CHARACTER*4 ISUBN1
17231      CHARACTER*4 ISUBN2
17232      CHARACTER*4 ISTEPN
17233C
17234C---------------------------------------------------------------------
17235C
17236      DIMENSION TAG1(*)
17237      DIMENSION TAG2(*)
17238      DIMENSION XIDTEM(*)
17239      DIMENSION XIDTE2(*)
17240      DIMENSION TEMP1(*)
17241      DIMENSION TEMP2(*)
17242C
17243C-----COMMON----------------------------------------------------------
17244C
17245C-----COMMON VARIABLES (GENERAL)--------------------------------------
17246C
17247      INCLUDE 'DPCOP2.INC'
17248C
17249C-----START POINT-----------------------------------------------------
17250C
17251      ISUBN1='DPFR'
17252      ISUBN2='E5  '
17253C
17254      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'FRE5')THEN
17255        ISTEPN='1'
17256        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17257        WRITE(ICOUT,999)
17258  999   FORMAT(1X)
17259        CALL DPWRST('XXX','BUG ')
17260        WRITE(ICOUT,51)
17261   51   FORMAT('***** AT THE BEGINNING OF DPFRE5--')
17262        CALL DPWRST('XXX','BUG ')
17263        WRITE(ICOUT,53)N,NREPL
17264   53   FORMAT('N,NREPL = ',2I8)
17265        CALL DPWRST('XXX','BUG ')
17266        DO55I=1,N
17267          WRITE(ICOUT,57)I,TAG1(I),TAG2(I)
17268   57     FORMAT('I,TAG1(I),TAG2(I) = ',I8,2G15.7)
17269          CALL DPWRST('XXX','BUG ')
17270   55   CONTINUE
17271      ENDIF
17272C
17273C               ******************************************************
17274C               **  STEP 1--                                        **
17275C               **  DETERMINE THE NUMBER OF DISTINCT VALUES         **
17276C               **  FOR THE GROUP VARIABLES (TAG1, TAG2)            **
17277C               **  IF ALL VALUES ARE DISTINCT, THEN THIS           **
17278C               **  IMPLIES WE HAVE THE NO REPLICATION CASE         **
17279C               **  WHICH IS AN ERROR CONDITION.                    **
17280C               ******************************************************
17281C
17282      ISTEPN='1'
17283      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'FRE5')
17284     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17285C
17286      IWRITE='OFF'
17287      NUMSE1=0
17288      NUMSE2=0
17289C
17290      IF(NREPL.GE.1)THEN
17291        CALL CODE(TAG1,N,IWRITE,TEMP1,TEMP2,MAXOBV,IBUGG3,IERROR)
17292        DO110I=1,N
17293          TAG1(I)=TEMP1(I)
17294  110   CONTINUE
17295        CALL DISTIN(TAG1,N,IWRITE,XIDTEM,NUMSE1,IBUGG3,IERROR)
17296        CALL SORT(XIDTEM,NUMSE1,XIDTEM)
17297      ENDIF
17298C
17299      IF(NREPL.GE.2)THEN
17300        CALL CODE(TAG2,N,IWRITE,TEMP1,TEMP2,MAXOBV,IBUGG3,IERROR)
17301        DO120I=1,N
17302          TAG2(I)=TEMP1(I)
17303  120   CONTINUE
17304        CALL DISTIN(TAG2,N,IWRITE,XIDTE2,NUMSE2,IBUGG3,IERROR)
17305        CALL SORT(XIDTE2,NUMSE2,XIDTE2)
17306      ENDIF
17307C
17308      IF(NUMSE1.LT.1 .OR. NUMSE1.GT.N)THEN
17309        WRITE(ICOUT,999)
17310        CALL DPWRST('XXX','BUG ')
17311        WRITE(ICOUT,201)
17312  201   FORMAT('***** ERROR IN DPFRE5 ROUTINE--')
17313        CALL DPWRST('XXX','BUG ')
17314        ITEMP=1
17315        WRITE(ICOUT,202)ITEMP,NUMSE1
17316  202   FORMAT('      THE NUMBER OF SETS FOR THE GROUP ',I1,
17317     1         ' VARIABLE, ',I8,',')
17318        CALL DPWRST('XXX','BUG ')
17319        WRITE(ICOUT,203)
17320  203   FORMAT('      IS EITHER LESS THAN ONE OR GREATER THAN THE ',
17321     1         'NUMBER')
17322        CALL DPWRST('XXX','BUG ')
17323        WRITE(ICOUT,205)N
17324  205   FORMAT('      OF OBSERVATIONS, ',I8,'.')
17325        CALL DPWRST('XXX','BUG ')
17326        IERROR='YES'
17327        GOTO9000
17328      ENDIF
17329C
17330      IF(NREPL.GE.2 .AND. (NUMSE2.LT.1 .OR. NUMSE2.GT.N))THEN
17331        WRITE(ICOUT,999)
17332        CALL DPWRST('XXX','BUG ')
17333        WRITE(ICOUT,201)
17334        CALL DPWRST('XXX','BUG ')
17335        ITEMP=2
17336        WRITE(ICOUT,202)ITEMP,NUMSE2
17337        CALL DPWRST('XXX','BUG ')
17338        WRITE(ICOUT,203)
17339        CALL DPWRST('XXX','BUG ')
17340        WRITE(ICOUT,205)N
17341        CALL DPWRST('XXX','BUG ')
17342        IERROR='YES'
17343        GOTO9000
17344      ENDIF
17345C
17346C
17347C               *****************
17348C               **  STEP 90--  **
17349C               **  EXIT       **
17350C               *****************
17351C
17352 9000 CONTINUE
17353C
17354      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'FRE5')THEN
17355        WRITE(ICOUT,999)
17356        CALL DPWRST('XXX','BUG ')
17357        WRITE(ICOUT,9001)
17358 9001   FORMAT('***** AT THE END OF DPFRE5--')
17359        CALL DPWRST('XXX','BUG ')
17360        WRITE(ICOUT,9003)NUMSE1,NUMSE2
17361 9003   FORMAT('NUMSE1,NUMSE2 = ',2I6)
17362        CALL DPWRST('XXX','BUG ')
17363        IF(NREPL.GE.1)THEN
17364          DO9011I=1,NUMSE1
17365            WRITE(ICOUT,9013)I,XIDTEM(I)
17366 9013       FORMAT('I,XIDTEM(I) = ',I8,G15.7)
17367            CALL DPWRST('XXX','BUG ')
17368 9011     CONTINUE
17369        ENDIF
17370        IF(NREPL.GE.2)THEN
17371          DO9021I=1,NUMSE2
17372            WRITE(ICOUT,9023)I,XIDTE2(I)
17373 9023       FORMAT('I,XIDTE2(I) = ',I8,G15.7)
17374            CALL DPWRST('XXX','BUG ')
17375 9021     CONTINUE
17376        ENDIF
17377      ENDIF
17378C
17379      RETURN
17380      END
17381      SUBROUTINE DPFREQ(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
17382     1                  CLLIMI,CLWIDT,
17383     1                  IRHSTG,IHSTCW,IHSTEB,IHSTOU,
17384     1                  IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
17385C
17386C     PURPOSE--GENERATE ONE OF THE FOLLOWING 4 PLOTS--
17387C              1) FREQUENCY PLOT;
17388C              2) RELATIVE FREQUENCY PLOT;
17389C              3) CUMULATIVE FREQUENCY PLOT;
17390C              4) RELATIVE CUMULATIVE FREQUENCY PLOT;
17391C     WRITTEN BY--JAMES J. FILLIBEN
17392C                 STATISTICAL ENGINEERING DIVISION
17393C                 INFORMATION TECHNOLOGY LABORATORY
17394C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
17395C                 GAITHERSBURG, MD 20899-8980
17396C                 PHONE--301-975-2855
17397C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
17398C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
17399C     LANGUAGE--ANSI FORTRAN (1977)
17400C     VERSION NUMBER--82/7
17401C     ORIGINAL VERSION--APRIL     1978.
17402C     UPDATED         --JUNE      1978.
17403C     UPDATED         --JULY      1978.
17404C     UPDATED         --OCTOBER   1978.
17405C     UPDATED         --APRIL     1979.
17406C     UPDATED         --JANUARY   1981.
17407C     UPDATED         --OCTOBER   1981.
17408C     UPDATED         --MAY       1982.
17409C     UPDATED         --JUNE      1990. TEMPORARY ARRAYS TO GARBAGE
17410C                                       COMMON
17411C     UPDATED         --FEBRUARY  2010. USE DPPARS
17412C     UPDATED         --FEBRUARY  2010. SUPPORT FOR "MULTIPLE" AND
17413C                                       "REPLICATION"
17414C     UPDATED         --FEBRUARY  2010. SUPPORT FOR NON-EQUISPACED BINS
17415C     UPDATED         --FEBRUARY  2010. OPTION TO INCLUDE OUTLIERS
17416C     UPDATED         --MARCH     2010. USE DPPAR3 FOR SINGLE RESPONSE
17417C                                       VARIABLE OR MULTIPLE CASES
17418C     UPDATED         --JULY      2019. TWEAK SCRATCH STORAGE
17419C
17420C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
17421C
17422      CHARACTER*4 ICASPL
17423      CHARACTER*4 IAND1
17424      CHARACTER*4 IAND2
17425      CHARACTER*4 IRHSTG
17426      CHARACTER*4 IHSTCW
17427      CHARACTER*4 IHSTEB
17428      CHARACTER*4 IHSTOU
17429      CHARACTER*4 IBUGG2
17430      CHARACTER*4 IBUGG3
17431      CHARACTER*4 IBUGQ
17432      CHARACTER*4 ISUBRO
17433      CHARACTER*4 IFOUND
17434      CHARACTER*4 IFOUN1
17435      CHARACTER*4 IFOUN2
17436      CHARACTER*4 IERROR
17437C
17438      CHARACTER*4 IRELAT
17439      CHARACTER*4 IHIGH
17440      CHARACTER*4 ICASE
17441      CHARACTER*4 IDATSW
17442      CHARACTER*4 ISUBN1
17443      CHARACTER*4 ISUBN2
17444      CHARACTER*4 ISTEPN
17445      CHARACTER*4 IREPL
17446      CHARACTER*4 IMULT
17447C
17448      CHARACTER*40 INAME
17449      PARAMETER (MAXSPN=30)
17450      CHARACTER*4 IVARN1(MAXSPN)
17451      CHARACTER*4 IVARN2(MAXSPN)
17452      CHARACTER*4 IVARTY(MAXSPN)
17453      REAL PVAR(MAXSPN)
17454      INTEGER ILIS(MAXSPN)
17455      INTEGER NRIGHT(MAXSPN)
17456      INTEGER ICOLR(MAXSPN)
17457C
17458C---------------------------------------------------------------------
17459C
17460      INCLUDE 'DPCOPA.INC'
17461      INCLUDE 'DPCOZZ.INC'
17462C
17463      DIMENSION CLLIMI(*)
17464      DIMENSION CLWIDT(*)
17465C
17466      DIMENSION Y1(20*MAXOBV)
17467      DIMENSION X1(MAXOBV)
17468      DIMENSION XHIGH(MAXOBV)
17469      DIMENSION XIDTEM(MAXOBV)
17470      DIMENSION XIDTE2(MAXOBV)
17471      DIMENSION XIDTE3(MAXOBV)
17472      DIMENSION XTEMP1(MAXOBV)
17473      DIMENSION XTEMP2(MAXOBV)
17474      DIMENSION ZY(MAXOBV)
17475      DIMENSION XDESGN(MAXOBV,2)
17476C
17477      EQUIVALENCE (GARBAG(IGARB1),X1(1))
17478      EQUIVALENCE (GARBAG(IGARB2),XHIGH(1))
17479      EQUIVALENCE (GARBAG(IGARB3),XTEMP1(1))
17480      EQUIVALENCE (GARBAG(IGARB4),XTEMP2(1))
17481      EQUIVALENCE (GARBAG(IGARB5),XIDTEM(1))
17482      EQUIVALENCE (GARBAG(IGARB6),XIDTE2(1))
17483      EQUIVALENCE (GARBAG(IGARB7),XIDTE3(1))
17484      EQUIVALENCE (GARBAG(IGARB8),ZY(1))
17485      EQUIVALENCE (GARBAG(IGARB9),XDESGN(1,1))
17486      EQUIVALENCE (GARBAG(JGAR11),Y1(1))
17487C
17488C-----COMMON----------------------------------------------------------
17489C
17490      INCLUDE 'DPCOHK.INC'
17491      INCLUDE 'DPCODA.INC'
17492      INCLUDE 'DPCOP2.INC'
17493C
17494C-----START POINT-----------------------------------------------------
17495C
17496      IFOUND='NO'
17497      IERROR='NO'
17498      ISUBN1='DPFR'
17499      ISUBN2='EQ  '
17500C
17501      MAXCP1=MAXCOL+1
17502      MAXCP2=MAXCOL+2
17503      MAXCP3=MAXCOL+3
17504      MAXCP4=MAXCOL+4
17505      MAXCP5=MAXCOL+5
17506      MAXCP6=MAXCOL+6
17507C
17508      MAXV2=2
17509      MINN2=2
17510C
17511C               **********************************************
17512C               **  TREAT THE FREQUENCY PLOT AND            **
17513C               **  RELATED STATISTICAL DISTRIBUTION PLOTS  **
17514C               **********************************************
17515C
17516      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'FREQ')THEN
17517        WRITE(ICOUT,999)
17518  999   FORMAT(1X)
17519        CALL DPWRST('XXX','BUG ')
17520        WRITE(ICOUT,51)
17521   51   FORMAT('***** AT THE BEGINNING OF DPFREQ--')
17522        CALL DPWRST('XXX','BUG ')
17523        WRITE(ICOUT,52)ICASPL,IAND1,IAND2
17524   52   FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4)
17525        CALL DPWRST('XXX','BUG ')
17526        WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ,ISUBRO
17527   53   FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',3(A4,2X),A4)
17528        CALL DPWRST('XXX','BUG ')
17529      ENDIF
17530C
17531C               *************************************************
17532C               **  STEP 1--                                   **
17533C               **  EXTRACT THE COMMAND                        **
17534C               **  LOOK FOR ONE OF THE FOLLOWING COMMANDS:    **
17535C               **    1) FREQUENCY PLOT Y                      **
17536C               **    2) FREQUENCY PLOT Y X                    **
17537C               **    3) FREQUENCY PLOT Y XLOW XHIGH           **
17538C               **                                             **
17539C               **    4) MULTIPLE FREQUENCY PLOT Y1 ... YK     **
17540C               **    5) REPLICATED FREQUENCY PLOT Y X1 ... X2 **
17541C               *************************************************
17542C
17543      ISTEPN='1'
17544      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'FREQ')
17545     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17546C
17547      ICASPL='FREQ'
17548      IRELAT='OFF'
17549      IMULT='OFF'
17550      IREPL='OFF'
17551      IHIGH='OFF'
17552      ILASTC=9999
17553C
17554      IF(ICOM.EQ.'FREQ')GOTO89
17555      IF(ICOM.EQ.'RELA')GOTO89
17556      IF(ICOM.EQ.'CUMU')GOTO89
17557      IF(ICOM.EQ.'MULT')GOTO89
17558      IF(ICOM.EQ.'REPL')GOTO89
17559      GOTO9000
17560C
17561   89 CONTINUE
17562      IF(ICOM.EQ.'FREQ')THEN
17563        ICASPL='FREQ'
17564        IFOUN1='YES'
17565      ELSEIF(ICOM.EQ.'RELA')THEN
17566        IRELAT='ON'
17567      ELSEIF(ICOM.EQ.'CUMU')THEN
17568        ICASPL='CUMF'
17569      ELSEIF(ICOM.EQ.'MULT')THEN
17570        IMULT='ON'
17571      ELSEIF(ICOM.EQ.'REPL')THEN
17572        IREPL='ON'
17573      ENDIF
17574C
17575      ISTOP=NUMARG-1
17576      DO90I=1,NUMARG
17577        IF(IHARG(I).EQ.'PLOT')THEN
17578          ISTOP=I
17579          GOTO99
17580        ENDIF
17581   90 CONTINUE
17582   99 CONTINUE
17583C
17584      IFOUND='NO'
17585      DO100I=1,ISTOP
17586        IF(IHARG(I).EQ.'=')THEN
17587          IFOUND='NO'
17588          GOTO9000
17589        ELSEIF(IHARG(I).EQ.'FREQ')THEN
17590          IFOUN1='YES'
17591        ELSEIF(IHARG(I).EQ.'PLOT')THEN
17592          IFOUN2='YES'
17593          ILASTC=MIN(ILASTC,I)
17594        ELSEIF(IHARG(I).EQ.'REPL')THEN
17595          IREPL='ON'
17596        ELSEIF(IHARG(I).EQ.'MULT')THEN
17597          IMULT='ON'
17598        ELSEIF(IHARG(I).EQ.'CUMU')THEN
17599          ICASPL='CUMF'
17600        ELSEIF(IHARG(I).EQ.'RELA')THEN
17601          IRELAT='ON'
17602        ENDIF
17603  100 CONTINUE
17604C
17605      IF(IFOUN1.EQ.'YES' .AND. IFOUN2.EQ.'YES')IFOUND='YES'
17606      IF(IFOUND.EQ.'NO')GOTO9000
17607C
17608      IF(IMULT.EQ.'ON')THEN
17609        IF(IREPL.EQ.'ON')THEN
17610          WRITE(ICOUT,999)
17611          CALL DPWRST('XXX','BUG ')
17612          WRITE(ICOUT,101)
17613  101     FORMAT('***** ERROR IN FREQUENCY PLOT--')
17614          CALL DPWRST('XXX','BUG ')
17615          WRITE(ICOUT,102)
17616  102     FORMAT('      YOU CANNOT SPECIFY BOTH "MULTIPLE" AND ',
17617     1           '"REPLICATION" FOR THE FREQUENCY PLOT.')
17618          CALL DPWRST('XXX','BUG ')
17619          IERROR='YES'
17620          GOTO9000
17621        ENDIF
17622      ENDIF
17623C
17624      IF(ILASTC.GE.1)THEN
17625        CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
17626        ILASTC=0
17627      ENDIF
17628C
17629      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'FREQ')THEN
17630        WRITE(ICOUT,112)ICASPL,IRELAT,IMULT,IREPL
17631  112   FORMAT('ICASPL,IRELAT,IMULT,IREPL = ',3(A4,2X),A4)
17632        CALL DPWRST('XXX','BUG ')
17633      ENDIF
17634C
17635C               ****************************************
17636C               **  STEP 2--                          **
17637C               **  EXTRACT THE VARIABLE LIST         **
17638C               ****************************************
17639C
17640      ISTEPN='2'
17641      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'FREQ')
17642     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17643C
17644      INAME='FREQUENCY PLOT'
17645      MINNA=1
17646      MAXNA=100
17647      MINN2=1
17648      IFLAGE=1
17649      IF(IMULT.EQ.'ON')IFLAGE=0
17650      IFLAGM=1
17651      IFLAGP=0
17652      JMIN=1
17653      JMAX=NUMARG
17654      MINNVA=1
17655      MAXNVA=3
17656      IF(IREPL.EQ.'ON')THEN
17657        MINNVA=2
17658        MAXNVA=3
17659      ELSEIF(IMULT.EQ.'ON')THEN
17660        MINNVA=1
17661        MAXNVA=100
17662      ENDIF
17663C
17664      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
17665     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
17666     1            JMIN,JMAX,
17667     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
17668     1            IVARN1,IVARN2,IVARTY,PVAR,
17669     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
17670     1            MINNVA,MAXNVA,
17671     1            IFLAGM,IFLAGP,
17672     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
17673      IF(IERROR.EQ.'YES')GOTO9000
17674C
17675      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'FREQ')THEN
17676        WRITE(ICOUT,999)
17677        CALL DPWRST('XXX','BUG ')
17678        WRITE(ICOUT,281)
17679  281   FORMAT('***** AFTER CALL DPPARS--')
17680        CALL DPWRST('XXX','BUG ')
17681        WRITE(ICOUT,282)NQ,NUMVAR
17682  282   FORMAT('NQ,NUMVAR = ',2I8)
17683        CALL DPWRST('XXX','BUG ')
17684        IF(NUMVAR.GT.0)THEN
17685          DO285I=1,NUMVAR
17686            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
17687     1                      ICOLR(I)
17688  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
17689     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
17690            CALL DPWRST('XXX','BUG ')
17691  285     CONTINUE
17692        ENDIF
17693      ENDIF
17694C
17695      NRESP=0
17696      NREPL=0
17697      NGROUP=0
17698      IF(IMULT.EQ.'ON')THEN
17699        NRESP=NUMVAR
17700        IDATSW='RAW'
17701      ELSEIF(IREPL.EQ.'ON')THEN
17702        IDATSW='RAW'
17703        NRESP=1
17704        NREPL=NUMVAR-NRESP
17705        IF(NREPL.LT.1 .OR. NREPL.GT.2)THEN
17706          WRITE(ICOUT,999)
17707          CALL DPWRST('XXX','BUG ')
17708          WRITE(ICOUT,101)
17709          CALL DPWRST('XXX','BUG ')
17710          WRITE(ICOUT,511)
17711  511     FORMAT('      FOR THE REPLICATION CASE, THE NUMBER OF ',
17712     1           'REPLICATION VARIABLES')
17713          CALL DPWRST('XXX','BUG ')
17714          WRITE(ICOUT,512)
17715  512     FORMAT('      MUST BE BETWEEN 1 AND 2;  SUCH WAS NOT THE ',
17716     1           'CASE HERE.')
17717          CALL DPWRST('XXX','BUG ')
17718          WRITE(ICOUT,513)NREPL
17719  513     FORMAT('      THE NUMBER OF REPLICATION VARIABLES = ',I5)
17720          CALL DPWRST('XXX','BUG ')
17721          IERROR='YES'
17722          GOTO9000
17723        ENDIF
17724      ELSE
17725        NRESP=1
17726        NGROUP=NUMVAR-NRESP
17727        IF(NGROUP.EQ.0)IDATSW='RAW'
17728        IF(NGROUP.EQ.1)IDATSW='FREQ'
17729        IF(NGROUP.EQ.2)IDATSW='FRE2'
17730        IF(NGROUP.LT.0 .OR. NGROUP.GT.2)THEN
17731          WRITE(ICOUT,999)
17732          CALL DPWRST('XXX','BUG ')
17733          WRITE(ICOUT,101)
17734          CALL DPWRST('XXX','BUG ')
17735          WRITE(ICOUT,521)
17736  521     FORMAT('      THE NUMBER OF CLASS VARIABLES IS LESS THAN ',
17737     1           'ZERO OR GREATER THAN TWO.')
17738          CALL DPWRST('XXX','BUG ')
17739          WRITE(ICOUT,523)NGROUP
17740  523     FORMAT('      THE NUMBER OF CLASS VARIABLES = ',I5)
17741          CALL DPWRST('XXX','BUG ')
17742          IERROR='YES'
17743          GOTO9000
17744        ENDIF
17745      ENDIF
17746C
17747C
17748C               ********************************************************
17749C               **  STEP 7--                                          **
17750C               **  DETERMINE IF THE ANALYST                          **
17751C               **  HAS SPECIFIED    1)  THE CLASS WIDTH,             **
17752C               **                   2)  THE MIN POINT OF THE FIRST   **
17753C               **                       CELL,                        **
17754C               **                   3)  THE MAX POINT OF THE LAST    **
17755C               **                       CELL,                        **
17756C               ********************************************************
17757C
17758      ISTEPN='7'
17759      IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17760C
17761      CLWID=CLWIDT(1)
17762      XSTART=CLLIMI(1)
17763      XSTOP=CLLIMI(2)
17764C
17765C               *****************************************
17766C               **  STEP 6--                           **
17767C               **  GENERATE THE FREQUENCY   PLOTS FOR **
17768C               **  THE VARIOUS CASES.                 **
17769C               *****************************************
17770C
17771      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'FREQ')THEN
17772        ISTEPN='6'
17773        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17774        WRITE(ICOUT,601)NRESP,NREPL,NGROUP
17775  601   FORMAT('NRESP,NREPL,NGROUP = ',3I5)
17776        CALL DPWRST('XXX','BUG ')
17777      ENDIF
17778C
17779C               *************************************************
17780C               **  STEP 7A--                                  **
17781C               **  CASE 1: SINGLE RESPONSE VARIABLE WITH NO   **
17782C               **          REPLICATION (RESPONSE VARIABLE CAN **
17783C               **          BE A MATRIX).                      **
17784C               *************************************************
17785C
17786      IF(NRESP.EQ.1 .AND. NREPL.EQ.0)THEN
17787        ISTEPN='7A'
17788        IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'FREQ')
17789     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17790C
17791        ICOL=1
17792        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
17793     1              INAME,IVARN1,IVARN2,IVARTY,
17794     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
17795     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
17796     1              MAXCP4,MAXCP5,MAXCP6,
17797     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
17798     1              Y1,X1,XHIGH,NLOCAL,NLOCA2,NLOCA3,ICASE,
17799     1              IBUGG3,ISUBRO,IFOUND,IERROR)
17800        IF(IERROR.EQ.'YES')GOTO9000
17801C
17802C               *****************************************************
17803C               **  STEP 7B--                                      **
17804C               **  FORM THE VERTICAL AND HORIZONTAL AXIS          **
17805C               **  VALUES Y(.) AND X(.) FOR THE PLOT.             **
17806C               **  RESET THE VECTOR D(.) TO ALL ONES.             **
17807C               **  DEFINE THE NUMBER OF PLOT POINTS    (NPLOTP).  **
17808C               **  DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV).  **
17809C               *****************************************************
17810C
17811        NCURVE=1
17812        NPLOTP=0
17813        CALL DPFRE2(Y1,X1,XHIGH,NLOCAL,NCURVE,
17814     1              ICASPL,IRELAT,IHIGH,IDATSW,IRHSTG,IHSTCW,
17815     1              IHSTEB,IHSTOU,
17816     1              CLWID,XSTART,XSTOP,
17817     1              XTEMP1,XTEMP2,XIDTEM,MAXOBV,
17818     1              Y,X,X3D,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR)
17819C
17820C               ******************************************
17821C               **  STEP 8A--                           **
17822C               **  CASE 2: MULTIPLE RESPONSE VARIABLES **
17823C               ******************************************
17824C
17825      ELSEIF(NRESP.GT.1)THEN
17826        ISTEPN='8A'
17827        IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'FREQ')
17828     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17829C
17830C       LOOP THROUGH EACH OF THE RESPONSE VARIABLES
17831C
17832        NPLOTP=0
17833        IDATSW='RAW'
17834        DO810IRESP=1,NRESP
17835          NCURVE=IRESP
17836C
17837          IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'FREQ')THEN
17838            WRITE(ICOUT,999)
17839            CALL DPWRST('XXX','BUG ')
17840            WRITE(ICOUT,811)IRESP,NCURVE
17841  811       FORMAT('IRESP,NCURVE = ',2I5)
17842            CALL DPWRST('XXX','BUG ')
17843          ENDIF
17844C
17845          CLWID=CLWIDT(1)
17846          XSTART=CLLIMI(1)
17847          XSTOP=CLLIMI(2)
17848C
17849          ICOL=IRESP
17850          NUMVA2=1
17851          CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
17852     1                INAME,IVARN1,IVARN2,IVARTY,
17853     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
17854     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
17855     1                MAXCP4,MAXCP5,MAXCP6,
17856     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
17857     1                Y1,X1,XHIGH,NLOCAL,NLOCA2,NLOCA3,ICASE,
17858     1                IBUGG3,ISUBRO,IFOUND,IERROR)
17859          IF(IERROR.EQ.'YES')GOTO9000
17860C
17861C               *****************************************************
17862C               **  STEP 8B--                                      **
17863C               **  FORM THE VERTICAL AND HORIZONTAL AXIS          **
17864C               **  VALUES Y(.) AND X(.) FOR THE PLOT.             **
17865C               *****************************************************
17866C
17867          CALL DPFRE2(Y1,X1,XHIGH,NLOCAL,NCURVE,
17868     1                ICASPL,IRELAT,IHIGH,IDATSW,IRHSTG,IHSTCW,
17869     1                IHSTEB,IHSTOU,
17870     1                CLWID,XSTART,XSTOP,
17871     1                XTEMP1,XTEMP2,XIDTEM,MAXOBV,
17872     1                Y,X,X3D,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR)
17873C
17874  810   CONTINUE
17875C
17876C               *****************************************************
17877C               **  STEP 9A--                                      **
17878C               **  CASE 3: ONE OR TWO  REPLICATION VARIABLES.     **
17879C               **          FOR THIS CASE, THE NUMBER OF RESPONSE  **
17880C               **          VARIABLES MUST BE EXACTLY 1.           **
17881C               **          CURRENTLY, GROUPED DATA NOT SUPPORTED  **
17882C               **          WITH REPLICATION.                      **
17883C               *****************************************************
17884C
17885      ELSEIF(NRESP.EQ.1 .AND. NREPL.GE.1)THEN
17886        ISTEPN='9A'
17887        IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'FREQ')
17888     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17889C
17890        J=0
17891        IMAX=NRIGHT(1)
17892        IF(NQ.LT.NRIGHT(1))IMAX=NQ
17893        DO910I=1,IMAX
17894          IF(ISUB(I).EQ.0)GOTO910
17895          J=J+1
17896C
17897C         RESPONSE VARIABLE IN Y1
17898C
17899          IJ=MAXN*(ICOLR(1)-1)+I
17900          IF(ICOLR(1).LE.MAXCOL)Y1(J)=V(IJ)
17901          IF(ICOLR(1).EQ.MAXCP1)Y1(J)=PRED(I)
17902          IF(ICOLR(1).EQ.MAXCP2)Y1(J)=RES(I)
17903          IF(ICOLR(1).EQ.MAXCP3)Y1(J)=YPLOT(I)
17904          IF(ICOLR(1).EQ.MAXCP4)Y1(J)=XPLOT(I)
17905          IF(ICOLR(1).EQ.MAXCP5)Y1(J)=X2PLOT(I)
17906          IF(ICOLR(1).EQ.MAXCP6)Y1(J)=TAGPLO(I)
17907C
17908          ICOLC=1
17909          DO920IR=1,MIN(NREPL,2)
17910            ICOLC=ICOLC+1
17911            ICOLT=ICOLR(ICOLC)
17912            IJ=MAXN*(ICOLT-1)+I
17913            IF(ICOLT.LE.MAXCOL)XDESGN(J,IR)=V(IJ)
17914            IF(ICOLT.EQ.MAXCP1)XDESGN(J,IR)=PRED(I)
17915            IF(ICOLT.EQ.MAXCP2)XDESGN(J,IR)=RES(I)
17916            IF(ICOLT.EQ.MAXCP3)XDESGN(J,IR)=YPLOT(I)
17917            IF(ICOLT.EQ.MAXCP4)XDESGN(J,IR)=XPLOT(I)
17918            IF(ICOLT.EQ.MAXCP5)XDESGN(J,IR)=X2PLOT(I)
17919            IF(ICOLT.EQ.MAXCP6)XDESGN(J,IR)=TAGPLO(I)
17920  920     CONTINUE
17921C
17922  910   CONTINUE
17923        NLOCAL=J
17924C
17925C       *****************************************************
17926C       **  STEP 9B--                                      **
17927C       **  FORM THE VERTICAL AND HORIZONTAL AXIS          **
17928C       **  VALUES Y(.) AND X(.) FOR THE PLOT.             **
17929C       **                                                 **
17930C       **  FOR THIS CASE, WE NEED TO LOOP THROUGH THE     **
17931C       **  VARIOUS REPLICATIONS.                          **
17932C       *****************************************************
17933C
17934        ISTEPN='9B'
17935        IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'FREQ')THEN
17936          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17937          WRITE(ICOUT,999)
17938          CALL DPWRST('XXX','BUG ')
17939          WRITE(ICOUT,931)
17940  931     FORMAT('***** FROM THE MIDDLE  OF FREQ--')
17941          CALL DPWRST('XXX','BUG ')
17942          WRITE(ICOUT,932)ICASPL,NUMVAR,IDATSW,NLOCAL
17943  932     FORMAT('ICASPL,NUMVAR,IDATSW,NQ = ',A4,I8,2X,A4,I8)
17944          CALL DPWRST('XXX','BUG ')
17945          IF(NLOCAL.GE.1)THEN
17946            DO935I=1,NLOCAL
17947              WRITE(ICOUT,936)I,Y1(I),XDESGN(I,1),XDESGN(I,2)
17948  936         FORMAT('I,Y1(I),XDESGN(I,1),XDESGN(I,2) = ',I8,3F12.5)
17949              CALL DPWRST('XXX','BUG ')
17950  935       CONTINUE
17951          ENDIF
17952        ENDIF
17953C
17954C       *****************************************************
17955C       **  STEP 9C--                                      **
17956C       **  FIND THE DISTINCT VALUES IN EACH OF THE        **
17957C       **  REPLICATION VARIABLES.                         **
17958C       *****************************************************
17959C
17960        CALL DPFRE5(XDESGN(1,1),XDESGN(1,2),
17961     1             NREPL,NLOCAL,MAXOBV,
17962     1             XIDTEM,XIDTE2,
17963     1             XTEMP1,XTEMP2,
17964     1             NUMSE1,NUMSE2,
17965     1             IBUGG3,ISUBRO,IERROR)
17966C
17967C       *****************************************************
17968C       **  STEP 9D--                                      **
17969C       **  NOW LOOP THROUGH THE VARIOUS REPLICATIONS      **
17970C       *****************************************************
17971C
17972        NPLOTP=0
17973        NCURVE=0
17974        IF(NREPL.EQ.1)THEN
17975          J=0
17976          DO1110ISET1=1,NUMSE1
17977            K=0
17978            DO1130I=1,NLOCAL
17979              IF(XIDTEM(ISET1).EQ.XDESGN(I,1))THEN
17980                K=K+1
17981                ZY(K)=Y1(I)
17982              ENDIF
17983 1130       CONTINUE
17984            NTEMP=K
17985            NCURVE=NCURVE+1
17986            IF(NTEMP.GT.0)THEN
17987              CALL DPFRE2(ZY,X1,XHIGH,NTEMP,NCURVE,
17988     1                    ICASPL,IRELAT,IHIGH,IDATSW,IRHSTG,IHSTCW,
17989     1                    IHSTEB,IHSTOU,
17990     1                    CLWID,XSTART,XSTOP,
17991     1                    XTEMP1,XTEMP2,XIDTEM,MAXOBV,
17992     1                    Y,X,X3D,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR)
17993            ENDIF
17994 1110     CONTINUE
17995        ELSEIF(NREPL.EQ.2)THEN
17996          J=0
17997          NTOT=NUMSE1*NUMSE2
17998          DO1210ISET1=1,NUMSE1
17999          DO1220ISET2=1,NUMSE2
18000            K=0
18001            DO1290I=1,NLOCAL
18002              IF(
18003     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
18004     1           XIDTE2(ISET2).EQ.XDESGN(I,2)
18005     1          )THEN
18006                K=K+1
18007                ZY(K)=Y1(I)
18008              ENDIF
18009 1290       CONTINUE
18010            NTEMP=K
18011            NCURVE=NCURVE+1
18012            IF(NTEMP.GT.0)THEN
18013              CALL DPFRE2(ZY,X1,XHIGH,NTEMP,NCURVE,
18014     1                    ICASPL,IRELAT,IHIGH,IDATSW,IRHSTG,IHSTCW,
18015     1                    IHSTEB,IHSTOU,
18016     1                    CLWID,XSTART,XSTOP,
18017     1                    XTEMP1,XTEMP2,XIDTEM,MAXOBV,
18018     1                    Y,X,X3D,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR)
18019            ENDIF
18020 1220     CONTINUE
18021 1210     CONTINUE
18022        ENDIF
18023      ENDIF
18024C
18025C               *****************
18026C               **  STEP 90--  **
18027C               **  EXIT       **
18028C               *****************
18029C
18030 9000 CONTINUE
18031      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'FRE2')THEN
18032        WRITE(ICOUT,999)
18033        CALL DPWRST('XXX','BUG ')
18034        WRITE(ICOUT,9011)
18035 9011   FORMAT('***** AT THE END       OF DPFREQ--')
18036        CALL DPWRST('XXX','BUG ')
18037        WRITE(ICOUT,9012)IFOUND,IERROR
18038 9012   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
18039        CALL DPWRST('XXX','BUG ')
18040        WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
18041 9013   FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',
18042     1         I8,I8,I8,2X,A4,2X,A4,2X,A4)
18043        CALL DPWRST('XXX','BUG ')
18044        WRITE(ICOUT,9014)IRELAT,CLWID,XSTART,XSTOP
18045 9014   FORMAT('IRELAT,CLWID,XSTART,XSTOP = ',A4,2X,3E15.7)
18046        CALL DPWRST('XXX','BUG ')
18047        IF(NPLOTP.GE.1)THEN
18048          DO9015I=1,NPLOTP
18049            WRITE(ICOUT,9016)I,Y(I),X(I),D(I)
18050 9016       FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5)
18051            CALL DPWRST('XXX','BUG ')
18052 9015     CONTINUE
18053        ENDIF
18054      ENDIF
18055C
18056      RETURN
18057      END
18058      SUBROUTINE DPFRIE(TEMP1,TEMP2,MAXNXT,
18059     1                  ICAPSW,IFORSW,IMULT,
18060     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
18061C
18062C     PURPOSE--CARRY OUT FRIEDMAN TEST
18063C              NON-PARAMETRIC TWO-WAY ANOVA
18064C     EXAMPLE--FRIEDMAN TEST Y X1 X2
18065C     REFERENCE--CONOVER (1999), "PRACTICAL NONPARAMETRIC STATISTICS",
18066C                THIRD EDITION, WILEY, PP. 369-372.
18067C     WRITTEN BY--ALAN HECKERT
18068C                 STATISTICAL ENGINEERING DIVISION
18069C                 INFORMATION TECHNOLOGY LABORATORY
18070C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
18071C                 GAITHERSBURG, MD 20899-8980
18072C                 PHONE--301-975-2899
18073C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
18074C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
18075C     LANGUAGE--ANSI FORTRAN (1977)
18076C     VERSION NUMBER--2003/10
18077C     ORIGINAL VERSION--OCTOBER   2003.
18078C     UPDATED         --JANUARY   2007.  CALL LIST TO DPFRI2
18079C     UPDATED         --APRIL     2011. USE DPPARS
18080C     UPDATED         --APRIL     2011. SUPPORT FOR "MULTIPLE" CASE
18081C
18082C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
18083C
18084      CHARACTER*4 ICAPSW
18085      CHARACTER*4 IFORSW
18086      CHARACTER*4 IMULT
18087      CHARACTER*4 IBUGA2
18088      CHARACTER*4 IBUGA3
18089      CHARACTER*4 IBUGQ
18090      CHARACTER*4 ISUBRO
18091      CHARACTER*4 IFOUND
18092      CHARACTER*4 IERROR
18093C
18094      CHARACTER*4 ISUBN1
18095      CHARACTER*4 ISUBN2
18096      CHARACTER*4 ISTEPN
18097C
18098      LOGICAL IFRST
18099      LOGICAL ILAST
18100      CHARACTER*4 IFLAGU
18101      CHARACTER*4 ICASE
18102      CHARACTER*40 INAME
18103      PARAMETER (MAXSPN=30)
18104      CHARACTER*4 IVARN1(MAXSPN)
18105      CHARACTER*4 IVARN2(MAXSPN)
18106      CHARACTER*4 IVARTY(MAXSPN)
18107      REAL PVAR(MAXSPN)
18108      INTEGER ILIS(MAXSPN)
18109      INTEGER NRIGHT(MAXSPN)
18110      INTEGER ICOLR(MAXSPN)
18111C
18112C---------------------------------------------------------------------
18113C
18114      DIMENSION TEMP1(*)
18115      DIMENSION TEMP2(*)
18116C
18117C-----COMMON----------------------------------------------------------
18118C
18119      INCLUDE 'DPCOPA.INC'
18120      INCLUDE 'DPCOZZ.INC'
18121      INCLUDE 'DPCOZD.INC'
18122C
18123      DIMENSION XTEMP2(MAXOBV)
18124      DIMENSION DBLOCK(MAXOBV)
18125      DIMENSION DTREAT(MAXOBV)
18126      DIMENSION RJ(MAXOBV)
18127      DOUBLE PRECISION YRANK(MAXOBV)
18128C
18129      EQUIVALENCE(GARBAG(IGARB1),XTEMP2(1))
18130      EQUIVALENCE(GARBAG(IGARB2),DBLOCK(1))
18131      EQUIVALENCE(GARBAG(IGARB3),DTREAT(1))
18132      EQUIVALENCE(GARBAG(IGARB4),RJ(1))
18133      EQUIVALENCE(DGARBG(IDGAR1),YRANK(1))
18134C
18135      INCLUDE 'DPCOHK.INC'
18136      INCLUDE 'DPCOSU.INC'
18137      INCLUDE 'DPCODA.INC'
18138      INCLUDE 'DPCOP2.INC'
18139C
18140C-----START POINT-----------------------------------------------------
18141C
18142      ISUBN1='DPFR'
18143      ISUBN2='IE  '
18144      IFOUND='YES'
18145      IERROR='NO'
18146C
18147      MAXCP1=MAXCOL+1
18148      MAXCP2=MAXCOL+2
18149      MAXCP3=MAXCOL+3
18150      MAXCP4=MAXCOL+4
18151      MAXCP5=MAXCOL+5
18152      MAXCP6=MAXCOL+6
18153C
18154C               ******************************************
18155C               **  TREAT THE FRIEDMAN TEST CASE        **
18156C               ******************************************
18157C
18158      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FRIE')THEN
18159        WRITE(ICOUT,999)
18160  999   FORMAT(1X)
18161        CALL DPWRST('XXX','BUG ')
18162        WRITE(ICOUT,51)
18163   51   FORMAT('***** AT THE BEGINNING OF DPFRIE--')
18164        CALL DPWRST('XXX','BUG ')
18165        WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ,ISUBRO,MAXNXT
18166   52   FORMAT('IBUGA2,IBUGA3,IBUBQ,ISUBRO,MAXNXT = ',4(A4,2X),I8)
18167        CALL DPWRST('XXX','BUG ')
18168        WRITE(ICOUT,53)ICAPSW,ICAPTY,IFORSW
18169   53   FORMAT('ICAPSW,ICAPTY,IFORSW = ',2(A4,2X),A4)
18170        CALL DPWRST('XXX','BUG ')
18171      ENDIF
18172C
18173C               *********************************
18174C               **  STEP 1--                   **
18175C               **  EXTRACT THE VARIABLE LIST  **
18176C               *********************************
18177C
18178      ISTEPN='1'
18179      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FRIE')
18180     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18181C
18182      IMULT='OFF'
18183      INAME='FRIEDMAN TEST'
18184      MAXNA=100
18185      MINNVA=1
18186      MAXNVA=MAXSPN
18187      MINNA=1
18188      IFLAGE=1
18189      IFLAGM=0
18190      IF(IMULT.EQ.'ON')THEN
18191        IFLAGM=0
18192      ENDIF
18193      MINN2=2
18194      IFLAGP=0
18195      JMIN=1
18196      JMAX=NUMARG
18197C
18198      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
18199     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
18200     1            JMIN,JMAX,
18201     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
18202     1            IVARN1,IVARN2,IVARTY,PVAR,
18203     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
18204     1            MINNVA,MAXNVA,
18205     1            IFLAGM,IFLAGP,
18206     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
18207      IF(IERROR.EQ.'YES')GOTO9000
18208C
18209      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FRIE')THEN
18210        WRITE(ICOUT,999)
18211        CALL DPWRST('XXX','BUG ')
18212        WRITE(ICOUT,181)
18213  181   FORMAT('***** AFTER CALL DPPARS--')
18214        CALL DPWRST('XXX','BUG ')
18215        WRITE(ICOUT,182)NQ,NUMVAR,IMULT
18216  182   FORMAT('NQ,NUMVAR,IMULT = ',2I8,2X,A4)
18217        CALL DPWRST('XXX','BUG ')
18218        IF(NUMVAR.GT.0)THEN
18219          DO185I=1,NUMVAR
18220            WRITE(ICOUT,187)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
18221     1                      ICOLR(I)
18222  187       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
18223     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
18224            CALL DPWRST('XXX','BUG ')
18225  185     CONTINUE
18226        ENDIF
18227      ENDIF
18228C
18229C               **********************************
18230C               **  STEP 3--                    **
18231C               **  CARRY OUT THE FRIEDMAN TEST **
18232C               **********************************
18233C
18234      ISTEPN='3'
18235      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FRIE')
18236     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18237C
18238C               *****************************************
18239C               **  STEP 3A--                          **
18240C               **  CASE 1: THREE RESPONSE VARIABLES   **
18241C               **          NO MATRIX, NO MULTIPLE     **
18242C               *****************************************
18243C
18244      IF(IMULT.EQ.'OFF')THEN
18245        ISTEPN='3A'
18246        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FRIE')
18247     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18248C
18249        ICOL=1
18250        NUMVA2=3
18251        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
18252     1              INAME,IVARN1,IVARN2,IVARTY,
18253     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
18254     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
18255     1              MAXCP4,MAXCP5,MAXCP6,
18256     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
18257     1              Y,X,XTEMP2,NS1,NS1,NS1,ICASE,
18258     1              IBUGA3,ISUBRO,IFOUND,IERROR)
18259        IF(IERROR.EQ.'YES')GOTO9000
18260C
18261        IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FRIE')THEN
18262          WRITE(ICOUT,999)
18263          CALL DPWRST('XXX','BUG ')
18264          WRITE(ICOUT,5211)
18265 5211     FORMAT('***** FROM DPFRIE, AS WE ARE ABOUT TO CALL DPFRI2--')
18266          CALL DPWRST('XXX','BUG ')
18267          WRITE(ICOUT,5212)NS1
18268 5212     FORMAT('NS1 = ',I8)
18269          CALL DPWRST('XXX','BUG ')
18270          DO5215I=1,NS1
18271            WRITE(ICOUT,5216)I,Y(I),X(I),XTEMP2(I)
18272 5216       FORMAT('I,Y(I),X(I),XTEMP2(I) = ',I8,3G15.7)
18273            CALL DPWRST('XXX','BUG ')
18274 5215     CONTINUE
18275        ENDIF
18276C
18277        CALL DPFRI2(Y,X,XTEMP2,NS1,IVARN1,IVARN2,
18278     1              DBLOCK,DTREAT,YRANK,RJ,
18279     1              TEMP1,TEMP2,MAXNXT,
18280     1              STATVA,STATCD,PVAL,
18281     1              CUT0,CUT50,CUT75,CUT90,CUT95,CUT99,CUT999,
18282     1              ICAPSW,ICAPTY,IFORSW,IMULT,
18283     1              IBUGA3,ISUBRO,IERROR)
18284C
18285C               ***************************************
18286C               **  STEP 61--                        **
18287C               **  UPDATE INTERNAL DATAPLOT TABLES  **
18288C               ***************************************
18289C
18290        ISTEPN='61'
18291        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FRIE')
18292     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18293C
18294        IFLAGU='ON'
18295        IFRST=.TRUE.
18296        ILAST=.TRUE.
18297        CALL DPFRT5(STATVA,STATCD,PVAL,
18298     1              CUT0,CUT50,CUT75,CUT90,CUT95,
18299     1              CUT975,CUT99,CUT999,
18300     1              IFLAGU,IFRST,ILAST,
18301     1              IBUGA2,IBUGA3,ISUBRO,IERROR)
18302      ENDIF
18303C
18304C               *****************
18305C               **  STEP 90--  **
18306C               **  EXIT       **
18307C               *****************
18308C
18309 9000 CONTINUE
18310      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FRI2')THEN
18311        WRITE(ICOUT,999)
18312        CALL DPWRST('XXX','BUG ')
18313        WRITE(ICOUT,9011)
18314 9011   FORMAT('***** AT THE END       OF DPFRIE--')
18315        CALL DPWRST('XXX','BUG ')
18316        WRITE(ICOUT,9016)IFOUND,IERROR,STATVA,STATCD
18317 9016   FORMAT('IFOUND,IERROR,STATVA,STATCD = ',2(A4,2X),2G15.7)
18318        CALL DPWRST('XXX','BUG ')
18319      ENDIF
18320C
18321      RETURN
18322      END
18323      SUBROUTINE DPFRIT(IHARG,IARGT,ARG,NUMARG,IDEFFI,
18324     1IFRAIT,IFOUND,IERROR)
18325C
18326C     PURPOSE--DEFINE THE FRACTAL ITERATIONS
18327C              THIS DEFINES THE MAXIMUM NUMBER OF POINTS TO
18328C              PLOT FOR FRACTAL PLOTS.
18329C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
18330C                     --IARGT  (A  HOLLERITH VECTOR)
18331C                     --ARG    (A  FLOATING POINT VECTOR)
18332C                     --NUMARG (AN INTEGER VARIABLE)
18333C                     --IDEFFI (A  FLOATING POINT VARIABLE)
18334C     OUTPUT ARGUMENTS--IFRAIT  (AN INTEGER VARIABLE)
18335C                     --IFOUND ('YES' OR 'NO' )
18336C                     --IERROR ('YES' OR 'NO' )
18337C     WRITTEN BY-ALAN HECKERT
18338C                 INFORMATION TECHNOLOGY LABORATORY
18339C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
18340C                 GAITHERSBURG, MD 20899-8980
18341C                 PHONE--301-975-2899
18342C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
18343C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
18344C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
18345C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
18346C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
18347C     LANGUAGE--ANSI FORTRAN (1977)
18348C     VERSION NUMBER--93/7
18349C     ORIGINAL VERSION--JULY    1993.
18350C
18351C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
18352C
18353      CHARACTER*4 IHARG
18354      CHARACTER*4 IARGT
18355      CHARACTER*4 IFOUND
18356      CHARACTER*4 IERROR
18357C
18358C---------------------------------------------------------------------
18359C
18360      DIMENSION IHARG(*)
18361      DIMENSION IARGT(*)
18362      DIMENSION ARG(*)
18363C
18364C---------------------------------------------------------------------
18365C
18366      INCLUDE 'DPCOP2.INC'
18367C
18368C-----START POINT-----------------------------------------------------
18369C
18370      IFOUND='NO'
18371      IERROR='NO'
18372C
18373      IF(NUMARG.EQ.0)GOTO1199
18374      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'ITER')GOTO1110
18375      GOTO1199
18376C
18377 1110 CONTINUE
18378      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
18379      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
18380      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
18381      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
18382      IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160
18383      GOTO1120
18384C
18385 1120 CONTINUE
18386      IERROR='YES'
18387      WRITE(ICOUT,999)
18388  999 FORMAT(1X)
18389      CALL DPWRST('XXX','BUG ')
18390      WRITE(ICOUT,1121)
18391 1121 FORMAT('***** ERROR IN DPFRIT--')
18392      CALL DPWRST('XXX','BUG ')
18393      WRITE(ICOUT,1122)
18394 1122 FORMAT('      ILLEGAL FORM FOR FRACTAL ITERATIONS ',
18395     1'COMMAND.')
18396      CALL DPWRST('XXX','BUG ')
18397      WRITE(ICOUT,1124)
18398 1124 FORMAT('      TEST EXAMPLE TO DEMONSTRATE THE ',
18399     1'PROPER FORM--')
18400      CALL DPWRST('XXX','BUG ')
18401      WRITE(ICOUT,1131)
18402 1131 FORMAT('      FRACTAL ITERATIONS 20000')
18403      CALL DPWRST('XXX','BUG ')
18404      GOTO1199
18405C
18406 1150 CONTINUE
18407      IHOLD=IDEFFI
18408      GOTO1180
18409C
18410 1160 CONTINUE
18411      IHOLD=INT(ARG(NUMARG)+0.5)
18412      IF(IHOLD.LE.0)IHOLD=IDEFFI
18413      GOTO1180
18414C
18415 1180 CONTINUE
18416      IFOUND='YES'
18417      IFRAIT=IHOLD
18418C
18419      IF(IFEEDB.EQ.'OFF')GOTO1189
18420      WRITE(ICOUT,999)
18421      CALL DPWRST('XXX','BUG ')
18422      WRITE(ICOUT,1181)IFRAIT
18423 1181 FORMAT('THE FRACTAL ITERATIONS HAS JUST BEEN SET TO ',
18424     1I8)
18425      CALL DPWRST('XXX','BUG ')
18426 1189 CONTINUE
18427      GOTO1199
18428C
18429 1199 CONTINUE
18430      RETURN
18431      END
18432      SUBROUTINE DPFRI2(Y,BLOCK,TREAT,N,IVARID,IVARI2,
18433     1                  DBLOCK,DTREAT,YRANK,RJ,
18434     1                  TEMP1,TEMP2,MAXNXT,
18435     1                  STATVA,STATCD,PVAL,
18436     1                  CUT0,CUT50,CUT75,CUT90,CUT95,CUT99,CUT999,
18437     1                  ICAPSW,ICAPTY,IFORSW,IMULT,
18438     1                  IBUGA3,ISUBRO,IERROR)
18439C
18440C     PURPOSE--THIS ROUTINE CARRIES OUT FRIEDMAN'S TEST
18441C              NON-PARAMETRIC TWO-WAY ANOVA
18442C     EXAMPLE--FRIEDMAN TEST Y BLOCK TREAT
18443C     REFERENCE--CONOVER (1999), "PRACTICAL NONPARAMETRIC STATISTICS",
18444C                THIRD EDITION, WILEY, PP. 369-372.
18445C     WRITTEN BY--ALAN HECKERT
18446C                 STATISTICAL ENGINEERING DIVISION
18447C                 INFORMATION TECHNOLOGY LABORATORY
18448C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
18449C                 GAITHERSBURG, MD 20899-8980
18450C                 PHONE--301-975-2899
18451C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
18452C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
18453C     LANGUAGE--ANSI FORTRAN (1977)
18454C     VERSION NUMBER--2003/10
18455C     ORIGINAL VERSION--OCTOBER   2003.
18456C     UPDATED         --JANUARY   2006. FIX BUG IN RANKING
18457C                                       (UNCORRECTED VERSION WORKS
18458C                                       IF DATA ARE RANKS WITHIN
18459C                                       THE BLOCK).
18460C     UPDATED         --JANUARY   2006. SOME INFO THAT WAS SUPPOSSED
18461C                                       TO GO TO DPST2F.DAT WAS
18462C                                       GOING TO DPST1F.DAT
18463C     UPDATED         --OCTOBER   2006. CALL LIST TO TPPF
18464C     UPDATED         --JANUARY   2007. CALL LIST TO RANK
18465C     UPDATED         --APRIL     2011. USE DPDTA1 AND DPDTA4 TO PRINT
18466C                                       OUTPUT TABLES.  THIS ADDS RTF
18467C                                       SUPPORT AND SPECIFICATION OF
18468C                                       THE NUMBER OF DIGITS.
18469C
18470C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
18471C
18472      CHARACTER*4 ICAPSW
18473      CHARACTER*4 ICAPTY
18474      CHARACTER*4 IFORSW
18475      CHARACTER*4 IMULT
18476      CHARACTER*4 IBUGA3
18477      CHARACTER*4 ISUBRO
18478      CHARACTER*4 IERROR
18479      CHARACTER*4 IVARID(*)
18480      CHARACTER*4 IVARI2(*)
18481C
18482      CHARACTER*4 IWRITE
18483      CHARACTER*4 ISUBN1
18484      CHARACTER*4 ISUBN2
18485      CHARACTER*4 ISTEPN
18486      CHARACTER*4 IOP
18487      CHARACTER*3 IATEMP
18488C
18489C---------------------------------------------------------------------
18490C
18491      DIMENSION Y(*)
18492      DIMENSION BLOCK(*)
18493      DIMENSION TREAT(*)
18494      DIMENSION RJ(*)
18495      DIMENSION DBLOCK(*)
18496      DIMENSION DTREAT(*)
18497      DIMENSION TEMP1(*)
18498      DIMENSION TEMP2(*)
18499C
18500      DOUBLE PRECISION YRANK(*)
18501C
18502      PARAMETER (NUMALP=8)
18503      REAL ALPHA(NUMALP)
18504C
18505      PARAMETER(NUMCLI=6)
18506      PARAMETER(MAXLIN=2)
18507      PARAMETER (MAXROW=50)
18508      CHARACTER*60 ITITLE
18509      CHARACTER*60 ITITLZ
18510      CHARACTER*1  ITITL9
18511      CHARACTER*60 ITEXT(MAXROW)
18512      CHARACTER*4  ALIGN(NUMCLI)
18513      CHARACTER*4  VALIGN(NUMCLI)
18514      REAL         AVALUE(MAXROW)
18515      INTEGER      NCTEXT(MAXROW)
18516      INTEGER      IDIGIT(MAXROW)
18517      INTEGER      NTOT(MAXROW)
18518      CHARACTER*60 ITITL2(MAXLIN,NUMCLI)
18519      CHARACTER*15 IVALUE(MAXROW,NUMCLI)
18520      CHARACTER*4  ITYPCO(NUMCLI)
18521      INTEGER      NCTIT2(MAXLIN,NUMCLI)
18522      INTEGER      NCVALU(MAXROW,NUMCLI)
18523      INTEGER      IWHTML(NUMCLI)
18524      INTEGER      IWRTF(NUMCLI)
18525      REAL         AMAT(MAXROW,NUMCLI)
18526      LOGICAL IFRST
18527      LOGICAL ILAST
18528C
18529C---------------------------------------------------------------------
18530C
18531      INCLUDE 'DPCOP2.INC'
18532C
18533C-----START POINT-----------------------------------------------------
18534C
18535      DATA ALPHA/
18536     1 0.0, 50.0, 75.0, 90.0, 95.0, 97.5, 99.0, 99.9/
18537C
18538      ISUBN1='DPFR'
18539      ISUBN2='I2  '
18540      IERROR='NO'
18541      IWRITE='OFF'
18542C
18543      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FRI2')THEN
18544        WRITE(ICOUT,999)
18545  999   FORMAT(1X)
18546        CALL DPWRST('XXX','WRIT')
18547        WRITE(ICOUT,51)
18548   51   FORMAT('**** AT THE BEGINNING OF DPFRI2--')
18549        CALL DPWRST('XXX','WRIT')
18550        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
18551   52   FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8)
18552        CALL DPWRST('XXX','WRIT')
18553        DO56I=1,N
18554          WRITE(ICOUT,57)I,Y(I),BLOCK(I),TREAT(I)
18555   57     FORMAT('I,Y(I),BLOCK(I),TREAT(I) = ',I8,3G15.7)
18556          CALL DPWRST('XXX','WRIT')
18557   56   CONTINUE
18558      ENDIF
18559C
18560      MAXNX2=MAXNXT
18561      CALL DPFRI3(Y,BLOCK,TREAT,N,
18562     1            DBLOCK,DTREAT,RJ,TEMP1,TEMP2,YRANK,
18563     1            MAXNXT,MAXNX2,
18564     1            STATVA,STATCD,PVAL,
18565     1            NBLOCK,NTREAT,NUMDF1,NUMDF2,T1,T2,A1,C1,
18566     1            IBUGA3,ISUBRO,IERROR)
18567      IF(IERROR.EQ.'YES')GOTO9000
18568C
18569      CUT0=0.0
18570      CALL FPPF(.50,NUMDF1,NUMDF2,CUT50)
18571      CALL FPPF(.75,NUMDF1,NUMDF2,CUT75)
18572      CALL FPPF(.90,NUMDF1,NUMDF2,CUT90)
18573      CALL FPPF(.95,NUMDF1,NUMDF2,CUT95)
18574      CALL FPPF(.975,NUMDF1,NUMDF2,CUT975)
18575      CALL FPPF(.99,NUMDF1,NUMDF2,CUT99)
18576      CALL FPPF(.999,NUMDF1,NUMDF2,CUT999)
18577C
18578      ANB=REAL(NBLOCK)
18579      AK=REAL(NTREAT)
18580C
18581      IDF=(NBLOCK-1)*(NTREAT-1)
18582      CALL TPPF(0.95,REAL(IDF),T95)
18583      CALL TPPF(0.975,REAL(IDF),T975)
18584      CALL TPPF(0.995,REAL(IDF),T995)
18585      TERM1=(A1-C1)*2.0*ANB/((ANB-1.0)*(AK-1.0))
18586      TERM2=1.0 - T1/(ANB*(AK-1.0))
18587      CONTRA=SQRT(TERM1*TERM2)
18588      CONTR1=T95*CONTRA
18589      CONTR2=T975*CONTRA
18590      CONTR3=T995*CONTRA
18591C
18592      IOP='OPEN'
18593      IFLG1=1
18594      IFLG2=1
18595      IFLG3=0
18596      IFLG4=0
18597      IFLG5=0
18598      CALL DPAUFI(IOP,IFLG1,IFLG2,IFLG3,IFLG4,IFLG5,
18599     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
18600     1            IBUGA3,ISUBRO,IERROR)
18601      IF(IERROR.EQ.'YES')GOTO9000
18602C
18603      WRITE(IOUNI1,2405)
18604 2405 FORMAT(4X,'RESPONSE',13X,'RANK',11X,'BLOCK',8X,'TREATMENT')
18605      DO2410I=1,N
18606        WRITE(IOUNI1,2411)Y(I),YRANK(I),BLOCK(I),TREAT(I)
18607 2411   FORMAT(1X,E15.7,F15.2,F15.2,F15.2)
18608 2410 CONTINUE
18609C
18610      WRITE(IOUNI2,2421)CONTRA
18611 2421 FORMAT(1X,'Contrast term:          ',E15.7)
18612      WRITE(IOUNI2,2422)CONTR1
18613 2422 FORMAT(1X,'Contrast term*t(0.95):  ',E15.7)
18614      WRITE(IOUNI2,2423)CONTR2
18615 2423 FORMAT(1X,'Contrast term*t(0.975): ',E15.7)
18616      WRITE(IOUNI2,2424)CONTR3
18617 2424 FORMAT(1X,'Contrast term*t(0.995): ',E15.7)
18618      WRITE(IOUNI2,2425)
18619 2425 FORMAT(10X,'I',10X,'J',8X,'R(I)-R(J)')
18620C
18621      DO2430I=1,NTREAT
18622        DO2439J=1,NTREAT
18623          IF(I.LT.J)THEN
18624            ADIFF=RJ(I)-RJ(J)
18625            IATEMP='   '
18626            IF(ABS(ADIFF).GE.CONTR1)IATEMP(1:1)='*'
18627            IF(ABS(ADIFF).GE.CONTR2)IATEMP(2:2)='*'
18628            IF(ABS(ADIFF).GE.CONTR3)IATEMP(3:3)='*'
18629            WRITE(IOUNI2,2437)I,J,ADIFF,IATEMP
18630 2437       FORMAT(3X,I8,3X,I8,5X,E15.7,A3)
18631          ENDIF
18632 2439   CONTINUE
18633 2430 CONTINUE
18634C
18635      IOP='CLOS'
18636      CALL DPAUFI(IOP,IFLG1,IFLG2,IFLG3,IFLG4,IFLG5,
18637     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
18638     1            IBUGA3,ISUBRO,IERROR)
18639C
18640C               *****************************
18641C               **   STEP 42-              **
18642C               **   WRITE OUT THE TABLE   **
18643C               *****************************
18644C
18645      ISTEPN='42'
18646      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FRI2')
18647     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18648C
18649C               ******************************
18650C               **   STEP 43--              **
18651C               **   WRITE OUT EVERYTHING   **
18652C               **   FOR FRIEDMAN TEST      **
18653C               ******************************
18654C
18655      ISTEPN='43'
18656      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FRI2')
18657     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18658C
18659      IF(IPRINT.EQ.'OFF')GOTO9000
18660C
18661      NUMDIG=7
18662      IF(IFORSW.EQ.'1')NUMDIG=1
18663      IF(IFORSW.EQ.'2')NUMDIG=2
18664      IF(IFORSW.EQ.'3')NUMDIG=3
18665      IF(IFORSW.EQ.'4')NUMDIG=4
18666      IF(IFORSW.EQ.'5')NUMDIG=5
18667      IF(IFORSW.EQ.'6')NUMDIG=6
18668      IF(IFORSW.EQ.'7')NUMDIG=7
18669      IF(IFORSW.EQ.'8')NUMDIG=8
18670      IF(IFORSW.EQ.'9')NUMDIG=9
18671      IF(IFORSW.EQ.'0')NUMDIG=0
18672      IF(IFORSW.EQ.'E')NUMDIG=-2
18673      IF(IFORSW.EQ.'-2')NUMDIG=-2
18674      IF(IFORSW.EQ.'-3')NUMDIG=-3
18675      IF(IFORSW.EQ.'-4')NUMDIG=-4
18676      IF(IFORSW.EQ.'-5')NUMDIG=-5
18677      IF(IFORSW.EQ.'-6')NUMDIG=-6
18678      IF(IFORSW.EQ.'-7')NUMDIG=-7
18679      IF(IFORSW.EQ.'-8')NUMDIG=-8
18680      IF(IFORSW.EQ.'-9')NUMDIG=-9
18681C
18682      ITITLE='Friedman Two Factor Test'
18683      NCTITL=24
18684      ITITLZ=' '
18685      NCTITZ=0
18686C
18687      ICNT=1
18688      ITEXT(ICNT)=' '
18689      NCTEXT(ICNT)=0
18690      AVALUE(ICNT)=0.0
18691      IDIGIT(ICNT)=-1
18692      ICNT=ICNT+1
18693      ITEXT(ICNT)='Response Variable: '
18694      WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1)(1:4)
18695      WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1)(1:4)
18696      NCTEXT(ICNT)=27
18697      AVALUE(ICNT)=0.0
18698      IDIGIT(ICNT)=-1
18699C
18700      IF(IMULT.EQ.'OFF')THEN
18701C
18702        ICNT=ICNT+1
18703        ITEXT(ICNT)='First Group-ID Variable: '
18704        WRITE(ITEXT(ICNT)(26:29),'(A4)')IVARID(2)(1:4)
18705        WRITE(ITEXT(ICNT)(30:33),'(A4)')IVARI2(2)(1:4)
18706        NCTEXT(ICNT)=33
18707        AVALUE(ICNT)=0.0
18708        IDIGIT(ICNT)=-1
18709C
18710        ICNT=ICNT+1
18711        ITEXT(ICNT)='Second Group-ID Variable: '
18712        WRITE(ITEXT(ICNT)(27:30),'(A4)')IVARID(3)(1:4)
18713        WRITE(ITEXT(ICNT)(31:34),'(A4)')IVARI2(3)(1:4)
18714        NCTEXT(ICNT)=34
18715        AVALUE(ICNT)=0.0
18716        IDIGIT(ICNT)=-1
18717C
18718      ELSE
18719      ENDIF
18720C
18721      ICNT=ICNT+1
18722      ITEXT(ICNT)=' '
18723      NCTEXT(ICNT)=1
18724      AVALUE(ICNT)=0.0
18725      IDIGIT(ICNT)=-1
18726C
18727      ICNT=ICNT+1
18728      ITEXT(ICNT)='H0: Treatments Have Identical Effects'
18729      NCTEXT(ICNT)=37
18730      AVALUE(ICNT)=0.0
18731      IDIGIT(ICNT)=-1
18732      ICNT=ICNT+1
18733      ITEXT(ICNT)='Ha: Treatments Do Not Have Identical Effects'
18734      NCTEXT(ICNT)=44
18735      AVALUE(ICNT)=0.0
18736      IDIGIT(ICNT)=-1
18737C
18738      ICNT=ICNT+1
18739      ITEXT(ICNT)=' '
18740      NCTEXT(ICNT)=1
18741      AVALUE(ICNT)=0.0
18742      IDIGIT(ICNT)=-1
18743C
18744      ICNT=ICNT+1
18745      ITEXT(ICNT)='Summary Statistics:'
18746      NCTEXT(ICNT)=19
18747      AVALUE(ICNT)=0.0
18748      IDIGIT(ICNT)=-1
18749      ICNT=ICNT+1
18750      ITEXT(ICNT)='Total Number of Observations:'
18751      NCTEXT(ICNT)=29
18752      AVALUE(ICNT)=REAL(N)
18753      IDIGIT(ICNT)=0
18754      ICNT=ICNT+1
18755      ITEXT(ICNT)='Number of Blocks:'
18756      NCTEXT(ICNT)=17
18757      AVALUE(ICNT)=REAL(NBLOCK)
18758      IDIGIT(ICNT)=0
18759      ICNT=ICNT+1
18760      ITEXT(ICNT)='Number of Treatments:'
18761      NCTEXT(ICNT)=21
18762      AVALUE(ICNT)=REAL(NTREAT)
18763      IDIGIT(ICNT)=0
18764      ICNT=ICNT+1
18765      ITEXT(ICNT)=' '
18766      NCTEXT(ICNT)=1
18767      AVALUE(ICNT)=0.0
18768      IDIGIT(ICNT)=-1
18769C
18770      ICNT=ICNT+1
18771      ITEXT(ICNT)='Test:'
18772      NCTEXT(ICNT)=5
18773      AVALUE(ICNT)=0.0
18774      IDIGIT(ICNT)=-1
18775      ICNT=ICNT+1
18776      ITEXT(ICNT)='Friedman Test Statistic (Original):'
18777      NCTEXT(ICNT)=35
18778      AVALUE(ICNT)=T1
18779      IDIGIT(ICNT)=NUMDIG
18780      ICNT=ICNT+1
18781      ITEXT(ICNT)='Sum of Squares of Ranks (A1):'
18782      NCTEXT(ICNT)=29
18783      AVALUE(ICNT)=A1
18784      IDIGIT(ICNT)=NUMDIG
18785      ICNT=ICNT+1
18786      ITEXT(ICNT)='Correction Factor (C1):'
18787      NCTEXT(ICNT)=29
18788      AVALUE(ICNT)=C1
18789      IDIGIT(ICNT)=NUMDIG
18790      ICNT=ICNT+1
18791      ITEXT(ICNT)='Friedman Test Statistic (Conover):'
18792      NCTEXT(ICNT)=34
18793      AVALUE(ICNT)=STATVA
18794      IDIGIT(ICNT)=NUMDIG
18795      ICNT=ICNT+1
18796      ITEXT(ICNT)='CDF of Test Statistic:'
18797      NCTEXT(ICNT)=22
18798      AVALUE(ICNT)=STATCD
18799      IDIGIT(ICNT)=NUMDIG
18800      ICNT=ICNT+1
18801      ITEXT(ICNT)='P-Value:'
18802      NCTEXT(ICNT)=8
18803      PVAL=1.0 - STATCD
18804      AVALUE(ICNT)=1.0 - STATCD
18805      IDIGIT(ICNT)=NUMDIG
18806C
18807      NUMROW=ICNT
18808      DO4210I=1,NUMROW
18809        NTOT(I)=15
18810 4210 CONTINUE
18811C
18812      IFRST=.TRUE.
18813      ILAST=.TRUE.
18814C
18815      ISTEPN='42A'
18816      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FRI2')
18817     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18818C
18819      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
18820     1            AVALUE,IDIGIT,
18821     1            NTOT,NUMROW,
18822     1            ICAPSW,ICAPTY,ILAST,IFRST,
18823     1            ISUBRO,IBUGA3,IERROR)
18824C
18825      ITITLE=' '
18826      NCTITL=0
18827      ITITL9=' '
18828      NCTIT9=0
18829      ITITLE='Percent Points of the F Reference Distribution'
18830      NCTITL=46
18831      NUMLIN=1
18832      NUMROW=8
18833      NUMCOL=3
18834      ITITL2(1,1)='Percent Point'
18835      ITITL2(1,2)=' '
18836      ITITL2(1,3)='Value'
18837      NCTIT2(1,1)=13
18838      NCTIT2(1,2)=1
18839      NCTIT2(1,3)=5
18840C
18841      NMAX=0
18842      DO4221I=1,NUMCOL
18843        VALIGN(I)='b'
18844        ALIGN(I)='r'
18845        NTOT(I)=15
18846        IF(I.EQ.2)NTOT(I)=5
18847        NMAX=NMAX+NTOT(I)
18848        IDIGIT(I)=NUMDIG
18849        ITYPCO(I)='NUME'
18850 4221 CONTINUE
18851      ITYPCO(2)='ALPH'
18852      IDIGIT(1)=1
18853      IDIGIT(3)=3
18854      DO4223I=1,NUMROW
18855        DO4225J=1,NUMCOL
18856          NCVALU(I,J)=0
18857          IVALUE(I,J)=' '
18858          NCVALU(I,J)=0
18859          AMAT(I,J)=0.0
18860          IF(J.EQ.1)THEN
18861            AMAT(I,J)=ALPHA(I)
18862          ELSEIF(J.EQ.2)THEN
18863            IVALUE(I,J)='='
18864            NCVALU(I,J)=1
18865          ELSEIF(J.EQ.3)THEN
18866            IF(I.EQ.1)THEN
18867              AMAT(I,J)=RND(CUT0,IDIGIT(J))
18868            ELSEIF(I.EQ.2)THEN
18869              AMAT(I,J)=RND(CUT50,IDIGIT(J))
18870            ELSEIF(I.EQ.3)THEN
18871              AMAT(I,J)=RND(CUT75,IDIGIT(J))
18872            ELSEIF(I.EQ.4)THEN
18873              AMAT(I,J)=RND(CUT90,IDIGIT(J))
18874            ELSEIF(I.EQ.5)THEN
18875              AMAT(I,J)=RND(CUT95,IDIGIT(J))
18876            ELSEIF(I.EQ.6)THEN
18877              AMAT(I,J)=RND(CUT975,IDIGIT(J))
18878            ELSEIF(I.EQ.7)THEN
18879              AMAT(I,J)=RND(CUT99,IDIGIT(J))
18880            ELSEIF(I.EQ.8)THEN
18881              AMAT(I,J)=RND(CUT999,IDIGIT(J))
18882            ENDIF
18883          ENDIF
18884 4225   CONTINUE
18885 4223 CONTINUE
18886C
18887      IWHTML(1)=150
18888      IWHTML(2)=50
18889      IWHTML(3)=150
18890      IWRTF(1)=2000
18891      IWRTF(2)=IWRTF(1)+500
18892      IWRTF(3)=IWRTF(2)+2000
18893      IFRST=.TRUE.
18894      ILAST=.TRUE.
18895C
18896      ISTEPN='42C'
18897      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FRI2')
18898     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18899C
18900      CALL DPDTA4(ITITL9,NCTIT9,
18901     1            ITITLE,NCTITL,ITITL2,NCTIT2,
18902     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
18903     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW,
18904     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
18905     1            ICAPSW,ICAPTY,IFRST,ILAST,
18906     1            ISUBRO,IBUGA3,IERROR)
18907C
18908      CDF1=CUT90
18909      CDF2=CUT95
18910      CDF3=CUT975
18911      CDF4=CUT99
18912C
18913      ITITL9=' '
18914      NCTIT9=0
18915      ITITLE='Conclusions (Upper 1-Tailed Test)'
18916      NCTITL=33
18917      NUMLIN=1
18918      NUMROW=4
18919      NUMCOL=4
18920      ITITL2(1,1)='Alpha'
18921      ITITL2(1,2)='CDF'
18922      ITITL2(1,3)='Critical Value'
18923      ITITL2(1,4)='Conclusion'
18924      NCTIT2(1,1)=5
18925      NCTIT2(1,2)=3
18926      NCTIT2(1,3)=14
18927      NCTIT2(1,4)=10
18928C
18929      NMAX=0
18930      DO4321I=1,NUMCOL
18931        VALIGN(I)='b'
18932        ALIGN(I)='r'
18933        NTOT(I)=15
18934        IF(I.EQ.1 .OR. I.EQ.2)NTOT(I)=7
18935        IF(I.EQ.3)NTOT(I)=17
18936        NMAX=NMAX+NTOT(I)
18937        IDIGIT(I)=3
18938        ITYPCO(I)='ALPH'
18939 4321 CONTINUE
18940      ITYPCO(3)='NUME'
18941      IDIGIT(1)=0
18942      IDIGIT(2)=0
18943      DO4323I=1,NUMROW
18944        DO4325J=1,NUMCOL
18945          NCVALU(I,J)=0
18946          IVALUE(I,J)=' '
18947          NCVALU(I,J)=0
18948          AMAT(I,J)=0.0
18949 4325   CONTINUE
18950 4323 CONTINUE
18951      IVALUE(1,1)='10%'
18952      IVALUE(2,1)='5%'
18953      IVALUE(3,1)='2.5%'
18954      IVALUE(4,1)='1%'
18955      IVALUE(1,2)='90%'
18956      IVALUE(2,2)='95%'
18957      IVALUE(3,2)='97.5%'
18958      IVALUE(4,2)='99%'
18959      NCVALU(1,1)=3
18960      NCVALU(2,1)=2
18961      NCVALU(3,1)=4
18962      NCVALU(4,1)=2
18963      NCVALU(1,2)=3
18964      NCVALU(2,2)=3
18965      NCVALU(3,2)=5
18966      NCVALU(4,2)=3
18967      IVALUE(1,4)='Accept H0'
18968      IVALUE(2,4)='Accept H0'
18969      IVALUE(3,4)='Accept H0'
18970      IVALUE(4,4)='Accept H0'
18971      NCVALU(1,4)=9
18972      NCVALU(2,4)=9
18973      NCVALU(3,4)=9
18974      NCVALU(4,4)=9
18975      IF(STATVA.GT.CUT90)IVALUE(1,4)='Reject H0'
18976      IF(STATVA.GT.CUT95)IVALUE(2,4)='Reject H0'
18977      IF(STATVA.GT.CUT975)IVALUE(3,4)='Reject H0'
18978      IF(STATVA.GT.CUT99)IVALUE(4,4)='Reject H0'
18979      AMAT(1,3)=RND(CUT90,IDIGIT(3))
18980      AMAT(2,3)=RND(CUT95,IDIGIT(3))
18981      AMAT(3,3)=RND(CUT975,IDIGIT(3))
18982      AMAT(4,3)=RND(CUT99,IDIGIT(3))
18983C
18984      IWHTML(1)=150
18985      IWHTML(2)=150
18986      IWHTML(3)=150
18987      IWHTML(4)=150
18988      IWRTF(1)=1500
18989      IWRTF(2)=IWRTF(1)+1500
18990      IWRTF(3)=IWRTF(2)+2000
18991      IWRTF(4)=IWRTF(3)+2000
18992      IFRST=.FALSE.
18993      ILAST=.TRUE.
18994C
18995      ISTEPN='42E'
18996      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'KRU2')
18997     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18998C
18999      CALL DPDTA4(ITITL9,NCTIT9,
19000     1            ITITLE,NCTITL,ITITL2,NCTIT2,
19001     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
19002     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW,
19003     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
19004     1            ICAPSW,ICAPTY,IFRST,ILAST,
19005     1            ISUBRO,IBUGA3,IERROR)
19006C
19007C
19008C               *****************
19009C               **  STEP 90--  **
19010C               **  EXIT       **
19011C               *****************
19012C
19013 9000 CONTINUE
19014      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FRI2')THEN
19015        WRITE(ICOUT,999)
19016        CALL DPWRST('XXX','WRIT')
19017        WRITE(ICOUT,9011)
19018 9011   FORMAT('***** AT THE END       OF DPFRI2--')
19019        CALL DPWRST('XXX','WRIT')
19020        WRITE(ICOUT,9012)STATVA,STATCD,PVAL
19021 9012   FORMAT('STATVA,STATCD,PVAL = ',3G15.7)
19022        CALL DPWRST('XXX','WRIT')
19023      ENDIF
19024C
19025      RETURN
19026      END
19027      SUBROUTINE DPFRI3(Y,BLOCK,TREAT,N,
19028     1                  DBLOCK,DTREAT,RJ,TEMP1,TEMP2,YRANK,
19029     1                  MAXNXT,MAXNX2,
19030     1                  STATVA,STATCD,PVAL,
19031     1                  NBLOCK,NTREAT,NUMDF1,NUMDF2,T1,T2,A1,C1,
19032     1                  IBUGA3,ISUBRO,IERROR)
19033C
19034C     PURPOSE--THIS ROUTINE CARRIES OUT FRIEDMAN'S TEST
19035C              NON-PARAMETRIC TWO-WAY ANOVA
19036C     EXAMPLE--FRIEDMAN TEST Y BLOCK TREAT
19037C     REFERENCE--CONOVER (1999), "PRACTICAL NONPARAMETRIC STATISTICS",
19038C                THIRD EDITION, WILEY, PP. 369-372.
19039C     WRITTEN BY--ALAN HECKERT
19040C                 STATISTICAL ENGINEERING DIVISION
19041C                 INFORMATION TECHNOLOGY LABORATORY
19042C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
19043C                 GAITHERSBURG, MD 20899-8980
19044C                 PHONE--301-975-2899
19045C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
19046C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
19047C     LANGUAGE--ANSI FORTRAN (1977)
19048C     VERSION NUMBER--2011/7
19049C     ORIGINAL VERSION--JULY      2011. EXTRACTED FROM DPFRI2 ROUTINE
19050C
19051C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
19052C
19053      CHARACTER*4 IBUGA3
19054      CHARACTER*4 ISUBRO
19055      CHARACTER*4 IERROR
19056C
19057      CHARACTER*4 IWRITE
19058      CHARACTER*4 ISUBN1
19059      CHARACTER*4 ISUBN2
19060      CHARACTER*4 ISTEPN
19061C
19062      DOUBLE PRECISION DSUM1
19063C
19064C---------------------------------------------------------------------
19065C
19066      DIMENSION Y(*)
19067      DIMENSION BLOCK(*)
19068      DIMENSION TREAT(*)
19069      DIMENSION RJ(*)
19070      DIMENSION DBLOCK(*)
19071      DIMENSION DTREAT(*)
19072      DIMENSION TEMP1(*)
19073      DIMENSION TEMP2(*)
19074      DOUBLE PRECISION YRANK(*)
19075C
19076C---------------------------------------------------------------------
19077C
19078      INCLUDE 'DPCOP2.INC'
19079C
19080C-----START POINT-----------------------------------------------------
19081C
19082      ISUBN1='DPFR'
19083      ISUBN2='I3  '
19084      IERROR='NO'
19085      IWRITE='OFF'
19086C
19087      STATVA=CPUMIN
19088      STATCD=CPUMIN
19089      PVAL=CPUMIN
19090C
19091      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FRI3')THEN
19092        WRITE(ICOUT,999)
19093  999   FORMAT(1X)
19094        CALL DPWRST('XXX','WRIT')
19095        WRITE(ICOUT,51)
19096   51   FORMAT('**** AT THE BEGINNING OF DPFRI3--')
19097        CALL DPWRST('XXX','WRIT')
19098        WRITE(ICOUT,52)IBUGA3,ISUBRO,N,MAXNXT
19099   52   FORMAT('IBUGA3,ISUBRO,N,MAXNXT = ',2(A4,2X),2I8)
19100        CALL DPWRST('XXX','WRIT')
19101        DO56I=1,N
19102          WRITE(ICOUT,57)I,Y(I),BLOCK(I),TREAT(I)
19103   57     FORMAT('I,Y(I),BLOCK(I),TREAT(I) = ',I8,3G15.7)
19104          CALL DPWRST('XXX','WRIT')
19105   56   CONTINUE
19106      ENDIF
19107C
19108C               ********************************************
19109C               **  STEP 11--                             **
19110C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
19111C               ********************************************
19112C
19113      ISTEPN='11'
19114      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FRI3')
19115     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19116C
19117      HOLD=Y(1)
19118      DO1135I=2,N
19119      IF(Y(I).NE.HOLD)GOTO1139
19120 1135 CONTINUE
19121      WRITE(ICOUT,999)
19122      CALL DPWRST('XXX','WRIT')
19123      WRITE(ICOUT,1131)
19124 1131 FORMAT('***** ERROR FROM FRIEDMAN TEST--')
19125      CALL DPWRST('XXX','WRIT')
19126      WRITE(ICOUT,1133)HOLD
19127 1133 FORMAT('      THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7)
19128      CALL DPWRST('XXX','WRIT')
19129      IERROR='YES'
19130      GOTO9000
19131 1139 CONTINUE
19132C
19133      HOLD=BLOCK(1)
19134      DO1235I=2,N
19135      IF(BLOCK(I).NE.HOLD)GOTO1239
19136 1235 CONTINUE
19137      WRITE(ICOUT,999)
19138      CALL DPWRST('XXX','WRIT')
19139      WRITE(ICOUT,1131)
19140      CALL DPWRST('XXX','WRIT')
19141      WRITE(ICOUT,1231)HOLD
19142 1231 FORMAT('      THE FIRST FACTOR VARIABLE HAS ALL ELEMENTS = ',
19143     1       G15.7)
19144      CALL DPWRST('XXX','WRIT')
19145      IERROR='YES'
19146      GOTO9000
19147 1239 CONTINUE
19148C
19149      HOLD=TREAT(1)
19150      DO1335I=2,N
19151      IF(TREAT(I).NE.HOLD)GOTO1339
19152 1335 CONTINUE
19153      WRITE(ICOUT,999)
19154      CALL DPWRST('XXX','WRIT')
19155      WRITE(ICOUT,1131)
19156      CALL DPWRST('XXX','WRIT')
19157      WRITE(ICOUT,1331)HOLD
19158 1331 FORMAT('      THE SECOND FACTOR VARIABLE HAS ALL ELEMENTS = ',
19159     1       G15.7)
19160      CALL DPWRST('XXX','WRIT')
19161      GOTO9000
19162 1339 CONTINUE
19163C
19164C               ******************************
19165C               **  STEP 2--                **
19166C               **  CARRY OUT CALCULATIONS  **
19167C               **  FOR FRIEDMAN TEST       **
19168C               ******************************
19169C
19170      ISTEPN='2'
19171      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FRI3')
19172     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19173C
19174C  STEP 2A: COMPUTE NUMBER OF DISTINCT BLOCKS AND TREATMENTS
19175C
19176      CALL DISTIN(BLOCK,N,IWRITE,DBLOCK,NBLOCK,IBUGA3,IERROR)
19177      IF(IERROR.EQ.'YES')GOTO9000
19178      IF(NBLOCK.GT.MAXNX2)THEN
19179        WRITE(ICOUT,999)
19180        CALL DPWRST('XXX','BUG ')
19181        WRITE(ICOUT,1131)
19182        CALL DPWRST('XXX','BUG ')
19183        WRITE(ICOUT,1232)NBLOCK,MAXNX2
19184 1232     FORMAT('      THE NUMBER OF BLOCKS (',I8,') IS GREATER ',
19185     1           'THAN',I8)
19186          CALL DPWRST('XXX','BUG ')
19187          IERROR='YES'
19188          GOTO9000
19189      ENDIF
19190      CALL DISTIN(TREAT,N,IWRITE,DTREAT,NTREAT,IBUGA3,IERROR)
19191      IF(IERROR.EQ.'YES')GOTO9000
19192      IF(NTREAT.GT.MAXNX2)THEN
19193        WRITE(ICOUT,999)
19194        CALL DPWRST('XXX','BUG ')
19195        WRITE(ICOUT,1131)
19196        CALL DPWRST('XXX','BUG ')
19197        WRITE(ICOUT,1237)NTREAT,MAXNX2
19198 1237     FORMAT('      THE NUMBER OF TREATMENTS (',I8,') IS GREATER ',
19199     1           'THAN ',I8)
19200          CALL DPWRST('XXX','BUG ')
19201          IERROR='YES'
19202          GOTO9000
19203      ENDIF
19204C
19205C  STEP 2B: COMPUTE TREATMENT RANKS WITHIN EACH BLOCK
19206C
19207      ISTEPN='2B'
19208      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FRI3')
19209     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19210C
19211      DO2010I=1,N
19212        YRANK(I)=-1.0D0
19213 2010 CONTINUE
19214C
19215      DO2110I=1,NBLOCK
19216        HOLD=DBLOCK(I)
19217        ICOUNT=0
19218        DO2120J=1,N
19219          IF(BLOCK(J).EQ.HOLD)THEN
19220            ICOUNT=ICOUNT+1
19221            RJ(ICOUNT)=Y(J)
19222          ENDIF
19223 2120   CONTINUE
19224        CALL RANK(RJ,ICOUNT,IWRITE,TEMP1,TEMP2,MAXNX2,
19225     1            IBUGA3,IERROR)
19226        IF(IERROR.EQ.'YES')GOTO9000
19227        ICOUNT=0
19228        DO2130J=1,N
19229          IF(BLOCK(J).EQ.HOLD)THEN
19230            ICOUNT=ICOUNT+1
19231            YRANK(J)=DBLE(TEMP1(ICOUNT))
19232          ENDIF
19233 2130   CONTINUE
19234 2110 CONTINUE
19235C
19236      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FRI3')THEN
19237        DO2140I=1,N
19238          WRITE(ICOUT,2142)I,Y(I),YRANK(I)
19239 2142     FORMAT('I,Y(I),YRANK(I) = ',I8,G15.7,F12.2)
19240          CALL DPWRST('XXX','BUG ')
19241 2140   CONTINUE
19242      ENDIF
19243C
19244C  STEP 2C: NOW COMPUTE RANK SUMS FOR EACH TREATMENT
19245C
19246      ISTEPN='2C'
19247      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FRI3')
19248     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19249C
19250      DO2210I=1,NTREAT
19251        HOLD=DTREAT(I)
19252        DSUM1=0.0D0
19253        DO2220J=1,N
19254          IF(TREAT(J).EQ.HOLD)THEN
19255            DSUM1=DSUM1 + YRANK(J)
19256          ENDIF
19257 2220   CONTINUE
19258        RJ(I)=REAL(DSUM1)
19259 2210 CONTINUE
19260C
19261      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FRI3')THEN
19262        DO2240I=1,NTREAT
19263          WRITE(ICOUT,2242)I,RJ(I)
19264 2242     FORMAT('I,RJ(I) = ',I8,G15.7)
19265          CALL DPWRST('XXX','BUG ')
19266 2240   CONTINUE
19267      ENDIF
19268C
19269C  STEP 4: NOW COMPUTE VARIOUS QUANTITIES BASED ON RJ
19270C
19271      ANB=REAL(NBLOCK)
19272      AK=REAL(NTREAT)
19273      C1=ANB*AK*(AK+1.0)**2/4.0
19274      DSUM1=0.0D0
19275      DO2310I=1,N
19276        DSUM1=DSUM1 + YRANK(I)**2
19277 2310 CONTINUE
19278      A1=REAL(DSUM1)
19279      DSUM1=0.0D0
19280      DO2320I=1,NTREAT
19281        DSUM1=DSUM1 + RJ(I)**2
19282 2320 CONTINUE
19283      T1=(AK-1.0)*(REAL(DSUM1)-ANB*C1)/(A1-C1)
19284      T2=(ANB-1.0)*T1/(ANB*(AK-1.0) - T1)
19285C
19286      STATVA=T2
19287      NUMDF1=NTREAT-1
19288      NUMDF2=(NBLOCK-1)*(NTREAT-1)
19289      CALL FCDF(STATVA,NUMDF1,NUMDF2,STATCD)
19290      PVAL=1.0 - STATCD
19291C
19292C               *****************
19293C               **  STEP 90--  **
19294C               **  EXIT       **
19295C               *****************
19296C
19297 9000 CONTINUE
19298      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FRI3')THEN
19299        WRITE(ICOUT,999)
19300        CALL DPWRST('XXX','WRIT')
19301        WRITE(ICOUT,9011)
19302 9011   FORMAT('***** AT THE END       OF DPFRI3--')
19303        CALL DPWRST('XXX','WRIT')
19304        WRITE(ICOUT,9012)STATVA,STATCD,PVAL
19305 9012   FORMAT('STATVA,STATCD,PVAL = ',3G15.7)
19306        CALL DPWRST('XXX','WRIT')
19307      ENDIF
19308C
19309      RETURN
19310      END
19311      SUBROUTINE DPFRLI(ICASPL,IFRALI,Y,N,
19312     1                  GX1MIN,GX1MAX,GY1MIN,GY1MAX,
19313     1                  IX1TSC,IX1TSW,IY1TSC,IY1TSW,
19314     1                  IX1JSW,IY1JSW,
19315     1                  NMJX1T,NMNX1T,IX1NSW,NMJY1T,NMNY1T,IY1NSW,
19316     1                  PX1COO,X1COOR,NX1COO,
19317     1                  PY1COO,Y1COOR,NY1COO,
19318     1                  PX1CMN,X1COMN,NX1CMN,PX1TOL,PX1TOR,
19319     1                  PY1CMN,Y1COMN,NY1CMN,PY1TOL,PY1TOR,
19320     1                  ITICUN,PXMIN,PXMAX,PYMIN,PYMAX,
19321     1                  FMIN,FMAX,
19322     1                  IBUGG4,ISUBRO,IERROR)
19323C
19324C     PURPOSE--IN SOME CASES, WE MAY WANT TO DETERMINE THE FRAME LIMITS
19325C              THAT WOULD BE COMPUTED FOR A GIVEN DATA SET WITHOUT
19326C              GENERATING A PLOT.  FOR EXAMPLE, IF WE ARE PLOTTING
19327C              SUBSETS OF DATA BUT WE WANT LIMITS BASED ON THE FULL DATA
19328C              SET.  THIS IS A MODIFIED VERSION OF DPDEDL/DPDEFL. IN
19329C              THIS CASE, WE ARE ONLY LOOKING AT A SINGLE AXIS (I.E.,
19330C              EITHER Y OR X BUT NOT BOTH TOGETHER).  ALSO, WE DO NOT
19331C              WANT TO ACTUALLY MODIFY THE COMMON BLOCK SWITCHES (I.E.,
19332C              DX1MIN, FX1MIN, GX1MIN, ETC.) AND WE ALSO IGNORE SOME
19333C              SWITCHES THAT DPDEDL AND DPDEFL USE.
19334C     WRITTEN BY--ALAN HECKERT
19335C                 STATISTICAL ENGINEERING DIVISION
19336C                 INFORMATION TECHNOLOGY LABORATORY
19337C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
19338C                 GAITHERSBURG, MD 20899-8980
19339C                 PHONE--301-975-2899
19340C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
19341C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
19342C     LANGUAGE--ANSI FORTRAN (1977)
19343C     VERSION NUMBER--83.6
19344C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY       1983.
19345C
19346C-----NON-COMMON VARIABLES (GRAPHICS)-----------------------------------
19347C
19348      DIMENSION Y(*)
19349      DIMENSION PX1COO(*)
19350      DIMENSION X1COOR(*)
19351      DIMENSION PX1CMN(*)
19352      DIMENSION X1COMN(*)
19353      DIMENSION PY1COO(*)
19354      DIMENSION Y1COOR(*)
19355      DIMENSION PY1CMN(*)
19356      DIMENSION Y1COMN(*)
19357C
19358      CHARACTER*4 ICASPL
19359      CHARACTER*4 IFRALI
19360      CHARACTER*4 IXMIN
19361      CHARACTER*4 IXMAX
19362      CHARACTER*4 IX1TSC
19363      CHARACTER*4 IX1TSW
19364      CHARACTER*4 IX1JSW
19365      CHARACTER*4 IX1NSW
19366      CHARACTER*4 IY1TSC
19367      CHARACTER*4 IY1TSW
19368      CHARACTER*4 IY1NSW
19369      CHARACTER*4 IY1JSW
19370      CHARACTER*4 ITICUN
19371      CHARACTER*4 IBUGG4
19372      CHARACTER*4 ISUBRO
19373      CHARACTER*4 IERROR
19374C
19375C-----COMMON----------------------------------------------------------
19376C
19377C-----COMMON VARIABLES (GENERAL)--------------------------------------
19378C
19379      INCLUDE 'DPCOP2.INC'
19380C
19381C-----START POINT-----------------------------------------------------
19382C
19383      IF(IBUGG4.EQ.'ON'.OR.ISUBRO.EQ.'FRLI')THEN
19384        WRITE(ICOUT,999)
19385  999   FORMAT(1X)
19386        CALL DPWRST('XXX','BUG ')
19387        WRITE(ICOUT,51)
19388   51   FORMAT('***** AT THE BEGINNING OF DPFRLI--')
19389        CALL DPWRST('XXX','BUG ')
19390        WRITE(ICOUT,54)GX1MIN,GX1MAX,GY1MIN,GY1MAX
19391   54   FORMAT('GX1MIN,GX1MAX,GY1MIN,GY1MAX = ',4G15.7)
19392        CALL DPWRST('XXX','BUG ')
19393        WRITE(ICOUT,58)IX1TSC,IX1TSW,IY1TSC,IY1TSW
19394   58   FORMAT('IX1TSC,IX1TSW,IY1TSC,IY1TSW = ',3(A4,2X),A4)
19395        CALL DPWRST('XXX','BUG ')
19396        WRITE(ICOUT,59)IX1TSC,IY1TSC,NMJX1T,NMJY1T
19397   59   FORMAT('IX1TSC,IY1TSC,NMJX1T,NMJY1T = ',2(A4,2X),2I8)
19398        CALL DPWRST('XXX','BUG ')
19399        WRITE(ICOUT,60)PX1TOL,PX1TOR,PY1TOL,PY1TOR
19400   60   FORMAT('PX1TOL,PX1TOR,PY1TOL,PY1TOR = ',4G15.7)
19401        CALL DPWRST('XXX','BUG ')
19402        WRITE(ICOUT,61)PXMIN,PXMAX,PYMIN,PYMAX
19403   61   FORMAT('PXMIN,PXMAX,PYMIN,PYMAX = ',4G15.7)
19404        CALL DPWRST('XXX','BUG ')
19405        WRITE(ICOUT,69)ICASPL,IFRALI,IBUGG4,ISUBRO
19406   69   FORMAT('ICASPL,IFRALI,IBUGG4,ISUBRO = ',3(A4,2X),A4)
19407        CALL DPWRST('XXX','BUG ')
19408      ENDIF
19409C
19410      IERROR='NO'
19411C
19412C               *******************************************************
19413C               **  STEP 1--                                         **
19414C               **  DETERMINE THE DATA LIMITS.  UNLIKE DPDEDL, WE    **
19415C               **  IGNORE ANY PRE-SET LIMITS AND WE DO NOT MAKE ANY **
19416C               **  ADJUSTMENTS BASED ON PLOT TYPE (E.G., BAR PLOTS).**
19417C               *******************************************************
19418C
19419      CALL SORT(Y,N,Y)
19420      DMIN=Y(1)
19421      DMAX=Y(N)
19422C
19423C               *******************************************************
19424C               **  STEP 1--                                         **
19425C               **  DETERMINE FRAME LIMITS ON BOTTOM HORIZONTAL AXIS **
19426C               *******************************************************
19427C
19428      IXMIN='FLOA'
19429      IXMAX='FLOA'
19430C
19431      IF(ICASPL.EQ.'X')THEN
19432        CALL DPDEF2(DMIN,DMAX,GX1MIN,GX1MAX,IXMIN,IXMAX,IX1TSC,
19433     1              FMIN,FMAX,NMJX1T)
19434        IF(IFRALI.EQ.'ON')THEN
19435          CALL DPDET2(PXMIN,PXMAX,FMIN,FMAX,
19436     1                IX1TSW,IX1TSC,
19437     1                NMJX1T,IX1JSW,
19438     1                PX1COO,X1COOR,NX1COO,
19439     1                NMNX1T,IX1NSW,
19440     1                PX1CMN,X1COMN,NX1CMN,
19441     1                PX1TOL,PX1TOR,ITICUN)
19442        ENDIF
19443      ELSE
19444        CALL DPDEF2(DMIN,DMAX,GY1MIN,GY1MAX,IXMIN,IXMAX,IY1TSC,
19445     1              FMIN,FMAX,NMJY1T)
19446        IF(IFRALI.EQ.'ON')THEN
19447          CALL DPDET2(PXMIN,PXMAX,FMIN,FMAX,
19448     1                IY1TSW,IY1TSC,
19449     1                NMJY1T,IY1JSW,
19450     1                PY1COO,Y1COOR,NY1COO,
19451     1                NMNY1T,IY1NSW,
19452     1                PY1CMN,Y1COMN,NY1CMN,
19453     1                PY1TOL,PY1TOR,ITICUN)
19454        ENDIF
19455      ENDIF
19456C
19457C               *****************
19458C               **  STEP 90--  **
19459C               **  EXIT       **
19460C               *****************
19461C
19462      IF(IBUGG4.EQ.'ON'.OR.ISUBRO.EQ.'FRLI')THEN
19463        WRITE(ICOUT,999)
19464        CALL DPWRST('XXX','BUG ')
19465        WRITE(ICOUT,9011)
19466 9011   FORMAT('***** AT THE END       OF DPFRLI--')
19467        CALL DPWRST('XXX','BUG ')
19468        WRITE(ICOUT,9052)DMIN,DMAX,FMIN,FMAX
19469 9052   FORMAT('DMIN,DMAX,FMIN,FMAX = ',4G15.7)
19470        CALL DPWRST('XXX','BUG ')
19471      ENDIF
19472C
19473      RETURN
19474      END
19475      SUBROUTINE DPFRPA(ICOM,IHARG,IHARG2,NUMARG,
19476CCCCC AUGUST 1995.  ADD IHARG2 FOR DASH2, ETC
19477CCCCC SUBROUTINE DPFRPA(ICOM,IHARG,NUMARG,
19478     1IDEFPA,
19479     1IX1FPA,IX2FPA,IY1FPA,IY2FPA,
19480     1IFOUND,IERROR)
19481C
19482C     PURPOSE--DEFINE THE FRAME PATTERN SWITCHES
19483C              FOR ANY OF THE 4 FRAME LINES.
19484C              SUCH FRAME PATTERN SWITCHES DEFINE THE PATTERN
19485C              FOR EACH OF THE 4 FRAME LINES.
19486C              THE CONTENTS OF A FRAME PATTERN SWITCH ARE
19487C              A PATTERN.
19488C              THE FRAME PATTERN SWITCHES FOR THE 4 FRAME LINES
19489C              ARE CONTAINED IN THE 4 VARIABLES
19490C              IX1FPA,IX2FPA,IY1FPA,IY2FPA.
19491C     INPUT  ARGUMENTS--ICOM
19492C                     --IHARG  (A  HOLLERITH VECTOR)
19493C                     --NUMARG
19494C                     --IDEFPA
19495C     OUTPUT ARGUMENTS--IX1FPA (A HOLLERITH VECTOR)
19496C                     --IX2FPA (A HOLLERITH VECTOR)
19497C                     --IY1FPA (A HOLLERITH VECTOR)
19498C                     --IY2FPA (A HOLLERITH VECTOR)
19499C                     --IFOUND ('YES' OR 'NO' )
19500C                     --IERROR ('YES' OR 'NO' )
19501C     WRITTEN BY--ALAN HECKERT
19502C                 COMPUTER SERVICES DIVISION
19503C                 INFORMATION TECHNOLOGY LABORATORY
19504C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
19505C                 GAITHERSBURG, MD 20899-8980
19506C                 PHONE--301-975-2899
19507C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
19508C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
19509C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
19510C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
19511C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
19512C     LANGUAGE--ANSI FORTRAN (1977)
19513C     VERSION NUMBER--82/7
19514C     ORIGINAL VERSION--OCTOBER   1980.
19515C     UPDATED         --MAY       1982.
19516C     UPDATED         --AUGUST    1995.  DASH2 BUG
19517C
19518C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
19519C
19520      CHARACTER*4 ICOM
19521      CHARACTER*4 IHARG
19522CCCCC AUGUST 1995.  ADD FOLLOWING LINE
19523      CHARACTER*4 IHARG2
19524      CHARACTER*4 IDEFPA
19525C
19526      CHARACTER*4 IX1FPA
19527      CHARACTER*4 IX2FPA
19528      CHARACTER*4 IY1FPA
19529      CHARACTER*4 IY2FPA
19530C
19531      CHARACTER*4 IFOUND
19532      CHARACTER*4 IERROR
19533C
19534      CHARACTER*4 IHOLD
19535C
19536C---------------------------------------------------------------------
19537C
19538      DIMENSION IHARG(*)
19539CCCCC AUGUST 1995.  ADD FOLLOWING LINE
19540      DIMENSION IHARG2(*)
19541C
19542C
19543C---------------------------------------------------------------------
19544C
19545      INCLUDE 'DPCOP2.INC'
19546C
19547C-----START POINT-----------------------------------------------------
19548C
19549      IFOUND='NO'
19550      IERROR='NO'
19551C
19552      IF(NUMARG.LE.0)GOTO1900
19553      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PATT')GOTO1090
19554      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MARK'.AND.
19555     1IHARG(2).EQ.'PATT')GOTO1090
19556      GOTO1900
19557 1090 CONTINUE
19558C
19559C               *****************************************************
19560C               **  TREAT THE CASE WHEN                            **
19561C               **  BOTH HORIZONTAL FRAMES    ARE TO BE CHANGED    **
19562C               *****************************************************
19563C
19564      IF(ICOM.EQ.'XFRA')GOTO1100
19565      GOTO1199
19566C
19567 1100 CONTINUE
19568      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
19569      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
19570      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
19571      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
19572      IF(IHARG(NUMARG).EQ.'PATT')GOTO1150
19573      GOTO1160
19574C
19575 1150 CONTINUE
19576      IHOLD=IDEFPA
19577      GOTO1180
19578C
19579 1160 CONTINUE
19580      IHOLD=IHARG(NUMARG)
19581      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'2')IHOLD='DA2'
19582      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'3')IHOLD='DA3'
19583      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'4')IHOLD='DA4'
19584      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'5')IHOLD='DA5'
19585      GOTO1180
19586C
19587 1180 CONTINUE
19588      IFOUND='YES'
19589      IX1FPA=IHOLD
19590      IX2FPA=IHOLD
19591C
19592      IF(IFEEDB.EQ.'OFF')GOTO1189
19593      WRITE(ICOUT,999)
19594  999 FORMAT(1X)
19595      CALL DPWRST('XXX','BUG ')
19596      WRITE(ICOUT,1181)
19597 1181 FORMAT('THE FRAME PATTERN (FOR BOTH HORIZONTAL ',
19598     1'FRAME LINES)')
19599      CALL DPWRST('XXX','BUG ')
19600      WRITE(ICOUT,1182)IHOLD
19601 1182 FORMAT('HAS JUST BEEN SET TO ',A4)
19602      CALL DPWRST('XXX','BUG ')
19603 1189 CONTINUE
19604      GOTO1900
19605C
19606 1199 CONTINUE
19607C
19608C               **************************************************************
19609C               **  TREAT THE CASE WHEN                                     **
19610C               **  ONLY THE BOTTOM HORIZONTAL FRAME IS      TO BE CHANGED  **
19611C               **************************************************************
19612C
19613      IF(ICOM.EQ.'X1FR')GOTO1200
19614      GOTO1299
19615C
19616 1200 CONTINUE
19617      IF(IHARG(NUMARG).EQ.'ON')GOTO1250
19618      IF(IHARG(NUMARG).EQ.'OFF')GOTO1250
19619      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250
19620      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250
19621      IF(IHARG(NUMARG).EQ.'PATT')GOTO1250
19622      GOTO1260
19623C
19624 1250 CONTINUE
19625      IHOLD=IDEFPA
19626      GOTO1280
19627C
19628 1260 CONTINUE
19629      IHOLD=IHARG(NUMARG)
19630      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'2')IHOLD='DA2'
19631      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'3')IHOLD='DA3'
19632      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'4')IHOLD='DA4'
19633      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'5')IHOLD='DA5'
19634      GOTO1280
19635C
19636 1280 CONTINUE
19637      IFOUND='YES'
19638      IX1FPA=IHOLD
19639C
19640      IF(IFEEDB.EQ.'OFF')GOTO1289
19641      WRITE(ICOUT,999)
19642      CALL DPWRST('XXX','BUG ')
19643      WRITE(ICOUT,1281)
19644 1281 FORMAT('THE FRAME PATTERN (FOR THE BOTTOM HORIZONTAL ',
19645     1'FRAME LINE)')
19646      CALL DPWRST('XXX','BUG ')
19647      WRITE(ICOUT,1282)IHOLD
19648 1282 FORMAT('HAS JUST BEEN SET TO ',A4)
19649      CALL DPWRST('XXX','BUG ')
19650 1289 CONTINUE
19651      GOTO1900
19652C
19653 1299 CONTINUE
19654C
19655C               **************************************************************
19656C               **  TREAT THE CASE WHEN                                     **
19657C               **  ONLY THE TOP    HORIZONTAL FRAME IS      TO BE CHANGED  **
19658C               **************************************************************
19659C
19660      IF(ICOM.EQ.'X2FR')GOTO1300
19661      GOTO1399
19662C
19663 1300 CONTINUE
19664      IF(IHARG(NUMARG).EQ.'ON')GOTO1350
19665      IF(IHARG(NUMARG).EQ.'OFF')GOTO1350
19666      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350
19667      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350
19668      IF(IHARG(NUMARG).EQ.'PATT')GOTO1350
19669      GOTO1360
19670C
19671 1350 CONTINUE
19672      IHOLD=IDEFPA
19673      GOTO1380
19674C
19675 1360 CONTINUE
19676      IHOLD=IHARG(NUMARG)
19677      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'2')IHOLD='DA2'
19678      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'3')IHOLD='DA3'
19679      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'4')IHOLD='DA4'
19680      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'5')IHOLD='DA5'
19681      GOTO1380
19682C
19683 1380 CONTINUE
19684      IFOUND='YES'
19685      IX2FPA=IHOLD
19686C
19687      IF(IFEEDB.EQ.'OFF')GOTO1389
19688      WRITE(ICOUT,999)
19689      CALL DPWRST('XXX','BUG ')
19690      WRITE(ICOUT,1381)
19691 1381 FORMAT('THE FRAME PATTERN (FOR THE TOP HORIZONTAL ',
19692     1'FRAME LINE)')
19693      CALL DPWRST('XXX','BUG ')
19694      WRITE(ICOUT,1382)IHOLD
19695 1382 FORMAT('HAS JUST BEEN SET TO ',A4)
19696      CALL DPWRST('XXX','BUG ')
19697 1389 CONTINUE
19698      GOTO1900
19699C
19700 1399 CONTINUE
19701C
19702C               *****************************************************
19703C               **  TREAT THE CASE WHEN                            **
19704C               **  BOTH VERTICAL   FRAMES    ARE TO BE CHANGED    **
19705C               *****************************************************
19706C
19707      IF(ICOM.EQ.'YFRA')GOTO1400
19708      GOTO1499
19709C
19710 1400 CONTINUE
19711      IF(IHARG(NUMARG).EQ.'ON')GOTO1450
19712      IF(IHARG(NUMARG).EQ.'OFF')GOTO1450
19713      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1450
19714      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1450
19715      IF(IHARG(NUMARG).EQ.'PATT')GOTO1450
19716      GOTO1460
19717C
19718 1450 CONTINUE
19719      IHOLD=IDEFPA
19720      GOTO1480
19721C
19722 1460 CONTINUE
19723      IHOLD=IHARG(NUMARG)
19724      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'2')IHOLD='DA2'
19725      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'3')IHOLD='DA3'
19726      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'4')IHOLD='DA4'
19727      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'5')IHOLD='DA5'
19728      GOTO1480
19729C
19730 1480 CONTINUE
19731      IFOUND='YES'
19732      IY1FPA=IHOLD
19733      IY2FPA=IHOLD
19734C
19735      IF(IFEEDB.EQ.'OFF')GOTO1489
19736      WRITE(ICOUT,999)
19737      CALL DPWRST('XXX','BUG ')
19738      WRITE(ICOUT,1481)
19739 1481 FORMAT('THE FRAME PATTERN (FOR BOTH VERTICAL ',
19740     1'FRAME LINES)')
19741      CALL DPWRST('XXX','BUG ')
19742      WRITE(ICOUT,1482)IHOLD
19743 1482 FORMAT('HAS JUST BEEN SET TO ',A4)
19744      CALL DPWRST('XXX','BUG ')
19745 1489 CONTINUE
19746      GOTO1900
19747C
19748 1499 CONTINUE
19749C
19750C               **************************************************************
19751C               **  TREAT THE CASE WHEN                                     **
19752C               **  ONLY THE LEFT   VERTICAL   FRAME IS      TO BE CHANGED  **
19753C               **************************************************************
19754C
19755      IF(ICOM.EQ.'Y1FR')GOTO1500
19756      GOTO1599
19757C
19758 1500 CONTINUE
19759      IF(IHARG(NUMARG).EQ.'ON')GOTO1550
19760      IF(IHARG(NUMARG).EQ.'OFF')GOTO1550
19761      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1550
19762      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1550
19763      IF(IHARG(NUMARG).EQ.'PATT')GOTO1550
19764      GOTO1560
19765C
19766 1550 CONTINUE
19767      IHOLD=IDEFPA
19768      GOTO1580
19769C
19770 1560 CONTINUE
19771      IHOLD=IHARG(NUMARG)
19772      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'2')IHOLD='DA2'
19773      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'3')IHOLD='DA3'
19774      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'4')IHOLD='DA4'
19775      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'5')IHOLD='DA5'
19776      GOTO1580
19777C
19778 1580 CONTINUE
19779      IFOUND='YES'
19780      IY1FPA=IHOLD
19781C
19782      IF(IFEEDB.EQ.'OFF')GOTO1589
19783      WRITE(ICOUT,999)
19784      CALL DPWRST('XXX','BUG ')
19785      WRITE(ICOUT,1581)
19786 1581 FORMAT('THE FRAME PATTERN (FOR THE LEFT VERTICAL ',
19787     1'FRAME LINE)')
19788      CALL DPWRST('XXX','BUG ')
19789      WRITE(ICOUT,1582)IHOLD
19790 1582 FORMAT('HAS JUST BEEN SET TO ',A4)
19791      CALL DPWRST('XXX','BUG ')
19792 1589 CONTINUE
19793      GOTO1900
19794C
19795 1599 CONTINUE
19796C
19797C               **************************************************************
19798C               **  TREAT THE CASE WHEN                                     **
19799C               **  ONLY THE RIGHT  VERTICAL   FRAME IS      TO BE CHANGED  **
19800C               **************************************************************
19801C
19802      IF(ICOM.EQ.'Y2FR')GOTO1600
19803      GOTO1699
19804C
19805 1600 CONTINUE
19806      IF(IHARG(NUMARG).EQ.'ON')GOTO1650
19807      IF(IHARG(NUMARG).EQ.'OFF')GOTO1650
19808      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1650
19809      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1650
19810      IF(IHARG(NUMARG).EQ.'PATT')GOTO1650
19811      GOTO1660
19812C
19813 1650 CONTINUE
19814      IHOLD=IDEFPA
19815      GOTO1680
19816C
19817 1660 CONTINUE
19818      IHOLD=IHARG(NUMARG)
19819      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'2')IHOLD='DA2'
19820      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'3')IHOLD='DA3'
19821      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'4')IHOLD='DA4'
19822      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'5')IHOLD='DA5'
19823      GOTO1680
19824C
19825 1680 CONTINUE
19826      IFOUND='YES'
19827      IY2FPA=IHOLD
19828C
19829      IF(IFEEDB.EQ.'OFF')GOTO1689
19830      WRITE(ICOUT,999)
19831      CALL DPWRST('XXX','BUG ')
19832      WRITE(ICOUT,1681)
19833 1681 FORMAT('THE FRAME PATTERN (FOR THE RIGHT VERTICAL ',
19834     1'FRAME LINE)')
19835      CALL DPWRST('XXX','BUG ')
19836      WRITE(ICOUT,1682)IHOLD
19837 1682 FORMAT('HAS JUST BEEN SET TO ',A4)
19838      CALL DPWRST('XXX','BUG ')
19839 1689 CONTINUE
19840      GOTO1900
19841C
19842 1699 CONTINUE
19843C
19844C               *****************************************************
19845C               **  TREAT THE CASE WHEN                            **
19846C               **  ALL 4 FRAME FRAME LINES ARE TO BE CHANGED      **
19847C               *****************************************************
19848C
19849      IF(ICOM.EQ.'FRAM')GOTO1700
19850      IF(ICOM.EQ.'XYFR')GOTO1700
19851      IF(ICOM.EQ.'YXFR')GOTO1700
19852      GOTO1799
19853C
19854 1700 CONTINUE
19855      IF(IHARG(NUMARG).EQ.'ON')GOTO1750
19856      IF(IHARG(NUMARG).EQ.'OFF')GOTO1750
19857      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1750
19858      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1750
19859      IF(IHARG(NUMARG).EQ.'PATT')GOTO1750
19860      GOTO1760
19861C
19862 1750 CONTINUE
19863      IHOLD=IDEFPA
19864      GOTO1780
19865C
19866 1760 CONTINUE
19867      IHOLD=IHARG(NUMARG)
19868      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'2')IHOLD='DA2'
19869      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'3')IHOLD='DA3'
19870      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'4')IHOLD='DA4'
19871      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'5')IHOLD='DA5'
19872      GOTO1780
19873C
19874 1780 CONTINUE
19875      IFOUND='YES'
19876      IX1FPA=IHOLD
19877      IX2FPA=IHOLD
19878      IY1FPA=IHOLD
19879      IY2FPA=IHOLD
19880C
19881      IF(IFEEDB.EQ.'OFF')GOTO1789
19882      WRITE(ICOUT,999)
19883      CALL DPWRST('XXX','BUG ')
19884      WRITE(ICOUT,1781)
19885 1781 FORMAT('THE FRAME PATTERN (FOR ALL 4 ',
19886     1'FRAME LINES)')
19887      CALL DPWRST('XXX','BUG ')
19888      WRITE(ICOUT,1782)IHOLD
19889 1782 FORMAT('HAS JUST BEEN SET TO ',A4)
19890      CALL DPWRST('XXX','BUG ')
19891 1789 CONTINUE
19892      GOTO1900
19893C
19894 1799 CONTINUE
19895C
19896 1900 CONTINUE
19897      RETURN
19898      END
19899      SUBROUTINE DPFRTE(XTEMP1,MAXNXT,
19900     1                  ICASAN,ICAPSW,IFORSW,
19901     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
19902C
19903C     PURPOSE--PERFORM EITHER A FREQUENCY OR FREQUENCY WITHIN A BLOCK
19904C              TEST FOR RANDOMNESS
19905C     EXAMPLE--FREQUENCY TEST Y
19906C              FREQUENCY WITHIN A BLOCK TEST Y
19907C     REFERENCE--A STATISTICAL TEST SUITE FOR RANDOM AND PSUEDORANDOM
19908C                NUMBER GENERATORS FOR CRYPTOGRAPHIC APPLICATIONS,
19909C                ANDREW RUHKIN, JUAN SOTO, JAMES NECHVATAL, MILES SMID,
19910C                ELAINE BARKER, STEFAN LEIGH, MARK LEVENSON,
19911C                MARK VANGEL, DAVID BANKS, ALAN HECKERT, JAMES DRAY,
19912C                SAN VO.  NIST SPECIAL PUBLICATION 800-22,
19913C                OCTOBER 2000, PP. 14-16.
19914C     WRITTEN BY--ALAN HECKERT
19915C                 STATISTICAL ENGINEERING DIVISION
19916C                 INFORMATION TECHNOLOGY LABORATORY
19917C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
19918C                 GAITHERSBURG, MD 20899-8980
19919C                 PHONE--301-975-2899
19920C     EXAMPLE--TOLERANCE LIMITS Y
19921C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
19922C           OF THE NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY.
19923C     LANGUAGE--ANSI FORTRAN (1977)
19924C     VERSION NUMBER--98/11
19925C     VERSION NUMBER--2003/11
19926C     ORIGINAL VERSION--NOVEMBER  2003.
19927C     UPDATED         --MARCH     2011. USE DPPARS ROUTINE
19928C     UPATED          --MARCH     2011. REWRITTEN TO HANDLE MULTIPLE
19929C                                       RESPONSE VARIABLES, GROUP-ID
19930C                                       VARIABLES, OR A LAB-ID VARIABLE
19931C     UPATED          --JULY      2019. TWEAK HOW SCRATCH STORAGE
19932C                                       HANDLED
19933C
19934C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
19935C
19936      CHARACTER*4 ICASAN
19937      CHARACTER*4 ICAPSW
19938      CHARACTER*4 IFORSW
19939      CHARACTER*4 IBUGA2
19940      CHARACTER*4 IBUGA3
19941      CHARACTER*4 IBUGQ
19942      CHARACTER*4 ISUBRO
19943      CHARACTER*4 IFOUND
19944      CHARACTER*4 IERROR
19945C
19946      CHARACTER*4 IHWUSE
19947      CHARACTER*4 MESSAG
19948      CHARACTER*4 IH
19949      CHARACTER*4 IH2
19950      CHARACTER*4 ISUBN1
19951      CHARACTER*4 ISUBN2
19952      CHARACTER*4 ISTEPN
19953      CHARACTER*4 IREPL
19954      CHARACTER*4 IMULT
19955      CHARACTER*4 ICTMP1
19956      CHARACTER*4 ICTMP2
19957      CHARACTER*4 ICTMP3
19958      CHARACTER*4 ICTMP4
19959      CHARACTER*4 ICTMP5
19960      CHARACTER*4 ICASE
19961C
19962      CHARACTER*4 IFLAGU
19963      LOGICAL IFRST
19964      LOGICAL ILAST
19965C
19966      CHARACTER*40 INAME
19967      PARAMETER (MAXSPN=30)
19968      CHARACTER*4 IVARN1(MAXSPN)
19969      CHARACTER*4 IVARN2(MAXSPN)
19970      CHARACTER*4 IVARTY(MAXSPN)
19971      CHARACTER*4 IVARID(1)
19972      CHARACTER*4 IVARI2(1)
19973      REAL PVAR(MAXSPN)
19974      REAL PID(MAXSPN)
19975      INTEGER ILIS(MAXSPN)
19976      INTEGER NRIGHT(MAXSPN)
19977      INTEGER ICOLR(MAXSPN)
19978C
19979C---------------------------------------------------------------------
19980C
19981      INCLUDE 'DPCOPA.INC'
19982      INCLUDE 'DPCOZZ.INC'
19983C
19984      DIMENSION XTEMP1(*)
19985      DIMENSION YTEMP1(MAXOBV)
19986      DIMENSION YTEMP2(MAXOBV)
19987      DIMENSION XDESGN(MAXOBV,7)
19988      DIMENSION XIDTEM(MAXOBV)
19989      DIMENSION XIDTE2(MAXOBV)
19990      DIMENSION XIDTE3(MAXOBV)
19991      DIMENSION XIDTE4(MAXOBV)
19992      DIMENSION XIDTE5(MAXOBV)
19993      DIMENSION XIDTE6(MAXOBV)
19994      DIMENSION TEMP1(MAXOBV)
19995      DIMENSION TEMP2(MAXOBV)
19996C
19997      EQUIVALENCE (GARBAG(IGARB1),YTEMP1(1))
19998      EQUIVALENCE (GARBAG(IGARB2),TEMP1(1))
19999      EQUIVALENCE (GARBAG(IGARB3),XIDTEM(1))
20000      EQUIVALENCE (GARBAG(IGARB4),XIDTE2(1))
20001      EQUIVALENCE (GARBAG(IGARB5),XIDTE3(1))
20002      EQUIVALENCE (GARBAG(IGARB6),XIDTE4(1))
20003      EQUIVALENCE (GARBAG(IGARB7),XIDTE5(1))
20004      EQUIVALENCE (GARBAG(IGARB8),XIDTE6(1))
20005      EQUIVALENCE (GARBAG(IGARB9),YTEMP2(1))
20006      EQUIVALENCE (GARBAG(IGAR10),TEMP2(1))
20007      EQUIVALENCE (GARBAG(JGAR11),XDESGN(1,1))
20008C
20009C-----COMMON----------------------------------------------------------
20010C
20011      INCLUDE 'DPCOHK.INC'
20012      INCLUDE 'DPCODA.INC'
20013      INCLUDE 'DPCOSU.INC'
20014      INCLUDE 'DPCOST.INC'
20015      INCLUDE 'DPCOP2.INC'
20016C
20017C-----START POINT-----------------------------------------------------
20018C
20019      IERROR='NO'
20020      IFOUND='NO'
20021      ICASAN='FRTE'
20022      IREPL='OFF'
20023      IMULT='OFF'
20024      ISUBN1='DPFR'
20025      ISUBN2='TE  '
20026C
20027      MAXCP1=MAXCOL+1
20028      MAXCP2=MAXCOL+2
20029      MAXCP3=MAXCOL+3
20030      MAXCP4=MAXCOL+4
20031      MAXCP5=MAXCOL+5
20032      MAXCP6=MAXCOL+6
20033      NTOT=0
20034C
20035C               ***********************************************
20036C               **  TREAT THE FREQUENCY        TEST  CASE    **
20037C               ***********************************************
20038C
20039      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FRTE')THEN
20040        WRITE(ICOUT,999)
20041  999   FORMAT(1X)
20042        CALL DPWRST('XXX','BUG ')
20043        WRITE(ICOUT,51)
20044   51   FORMAT('***** AT THE BEGINNING OF DPFRTE--')
20045        CALL DPWRST('XXX','BUG ')
20046        WRITE(ICOUT,53)IBUGA2,IBUGA3,IBUGQ,ISUBRO
20047   53   FORMAT('IBUGA2,IBUGA3,IBUGQ,ISUBRO = ',3(A4,2X),A4)
20048        CALL DPWRST('XXX','BUG ')
20049      ENDIF
20050C
20051C               *****************************************************
20052C               **  STEP 1--                                       **
20053C               **  EXTRACT THE COMMAND                            **
20054C               **  LOOK FOR ONE OF THE FOLLOWING COMMANDS:        **
20055C               **    1) FREQUENCY TEST   Y                        **
20056C               **    2) MULTIPLE FREQUENCY TEST   Y1 ... YK       **
20057C               **    3) REPLICATED FREQUENCY TEST   Y X1 ... XK   **
20058C               *****************************************************
20059C
20060      ISTEPN='1'
20061      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FRTE')
20062     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20063C
20064      ILASTZ=0
20065      ICASAN='FRTE'
20066C
20067C     LOOK FOR:
20068C
20069C          FREQUENCY TEST
20070C          FREQUENCY WITHIN A BLOCK TEST
20071C
20072      DO100I=0,NUMARG-1
20073C
20074        IF(I.EQ.0)THEN
20075          ICTMP1=ICOM
20076        ELSE
20077          ICTMP1=IHARG(I)
20078        ENDIF
20079        ICTMP2=IHARG(I+1)
20080        ICTMP3=IHARG(I+2)
20081        ICTMP4=IHARG(I+3)
20082        ICTMP5=IHARG(I+4)
20083C
20084        IF(ICTMP1.EQ.'=')THEN
20085          IFOUND='NO'
20086          GOTO9000
20087        ELSEIF(ICTMP1.EQ.'FREQ' .AND. ICTMP2.EQ.'TEST')THEN
20088          IFOUND='YES'
20089          ICASAN='FRTE'
20090          ILASTZ=I+1
20091        ELSEIF(ICTMP1.EQ.'FREQ' .AND. ICTMP2.EQ.'WITH' .AND.
20092     1         ICTMP3.EQ.'A   ' .AND. ICTMP4.EQ.'BLOC' .AND.
20093     1         ICTMP5.EQ.'TEST')THEN
20094          IFOUND='YES'
20095          ICASAN='FBTE'
20096          ILASTZ=I+4
20097        ELSEIF(ICTMP1.EQ.'FREQ' .AND. ICTMP2.EQ.'WITH' .AND.
20098     1         ICTMP3.EQ.'BLOC' .AND. ICTMP4.EQ.'TEST')THEN
20099          IFOUND='YES'
20100          ICASAN='FBTE'
20101          ILASTZ=I+3
20102        ELSEIF(ICTMP1.EQ.'FREQ' .AND. ICTMP2.EQ.'BLOC' .AND.
20103     1         ICTMP3.EQ.'TEST')THEN
20104          IFOUND='YES'
20105          ICASAN='FBTE'
20106          ILASTZ=I+2
20107        ELSEIF(ICTMP1.EQ.'REPL')THEN
20108          IREPL='ON'
20109          ILASTZ=MAX(ILASTZ,I)
20110        ELSEIF(ICTMP1.EQ.'MULT')THEN
20111          IMULT='ON'
20112          ILASTZ=MAX(ILASTZ,I)
20113        ENDIF
20114  100 CONTINUE
20115C
20116      IF(IFOUND.EQ.'NO')GOTO9000
20117C
20118      ISHIFT=ILASTZ
20119      CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
20120     1            IBUGA2,IERROR)
20121C
20122      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FRTE')THEN
20123        WRITE(ICOUT,91)ICASAN,IMULT,IREPL,ISHIFT
20124   91   FORMAT('DPFRTE: ICASAN,IMULT,IREPL,ISHIFT = ',3(A4,2X),I5)
20125        CALL DPWRST('XXX','BUG ')
20126      ENDIF
20127C
20128      IF(IMULT.EQ.'ON')THEN
20129        IF(IREPL.EQ.'ON')THEN
20130          WRITE(ICOUT,999)
20131          CALL DPWRST('XXX','BUG ')
20132          IF(ICASAN.EQ.'FRTE')THEN
20133            WRITE(ICOUT,101)
20134  101       FORMAT('***** ERROR IN FREQUENCY TEST--')
20135            CALL DPWRST('XXX','BUG ')
20136          ELSE
20137            WRITE(ICOUT,102)
20138  102       FORMAT('***** ERROR IN FREQUENCY WITHIN A BLOCK TEST--')
20139            CALL DPWRST('XXX','BUG ')
20140          ENDIF
20141          WRITE(ICOUT,103)
20142  103     FORMAT('      YOU CANNOT SPECIFY BOTH "MULTIPLE" AND ',
20143     1           '"REPLICATION"')
20144          CALL DPWRST('XXX','BUG ')
20145          WRITE(ICOUT,104)
20146  104     FORMAT('      FOR THE FREQUENCY TEST COMMAND.')
20147          CALL DPWRST('XXX','BUG ')
20148          IERROR='YES'
20149          GOTO9000
20150        ENDIF
20151      ENDIF
20152C
20153C               *********************************
20154C               **  STEP 4--                   **
20155C               **  EXTRACT THE VARIABLE LIST  **
20156C               *********************************
20157C
20158      ISTEPN='4'
20159      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FRTE')
20160     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20161C
20162      IF(ICASAN.EQ.'FBTE')THEN
20163        INAME='FREQUENCY WITHIN A BLOCK TEST'
20164      ELSE
20165        INAME='FREQUENCY TEST'
20166      ENDIF
20167      MINNA=1
20168      MAXNA=100
20169      MINN2=2
20170      IFLAGE=0
20171      IFLAGM=1
20172      IF(IREPL.EQ.'ON')THEN
20173        IFLAGM=0
20174        IFLAGE=1
20175      ENDIF
20176      IFLAGP=0
20177      JMIN=1
20178      JMAX=NUMARG
20179      MINNVA=1
20180      MAXNVA=MAXSPN
20181C
20182      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
20183     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
20184     1            JMIN,JMAX,
20185     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
20186     1            IVARN1,IVARN2,IVARTY,PVAR,
20187     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
20188     1            MINNVA,MAXNVA,
20189     1            IFLAGM,IFLAGP,
20190     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
20191      IF(IERROR.EQ.'YES')GOTO9000
20192C
20193      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FRTE')THEN
20194        WRITE(ICOUT,999)
20195        CALL DPWRST('XXX','BUG ')
20196        WRITE(ICOUT,281)
20197  281   FORMAT('***** AFTER CALL DPPARS--')
20198        CALL DPWRST('XXX','BUG ')
20199        WRITE(ICOUT,282)NQ,NUMVAR
20200  282   FORMAT('NQ,NUMVAR = ',2I8)
20201        CALL DPWRST('XXX','BUG ')
20202        IF(NUMVAR.GT.0)THEN
20203          DO285I=1,NUMVAR
20204            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
20205     1                      ICOLR(I)
20206  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
20207     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
20208            CALL DPWRST('XXX','BUG ')
20209  285     CONTINUE
20210        ENDIF
20211      ENDIF
20212C
20213C               ***********************************************
20214C               **  STEP 5--                                 **
20215C               **  DETERMINE:                               **
20216C               **  1) NUMBER OF REPLICATION VARIABLES (0-6) **
20217C               **  2) NUMBER OF RESPONSE    VARIABLES (>= 1)**
20218C               ***********************************************
20219C
20220      ISTEPN='5'
20221      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FRTE')
20222     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20223C
20224      NRESP=0
20225      NREPL=0
20226      IF(IMULT.EQ.'ON')THEN
20227        NRESP=NUMVAR
20228      ELSEIF(IREPL.EQ.'ON')THEN
20229        NRESP=1
20230        NREPL=NUMVAR-NRESP
20231        IF(NREPL.LT.1 .OR. NREPL.GT.6)THEN
20232          WRITE(ICOUT,999)
20233          CALL DPWRST('XXX','BUG ')
20234          IF(ICASAN.EQ.'FRTE')THEN
20235            WRITE(ICOUT,101)
20236          ELSE
20237            WRITE(ICOUT,102)
20238          ENDIF
20239          CALL DPWRST('XXX','BUG ')
20240          WRITE(ICOUT,511)
20241  511     FORMAT('      FOR THE REPLICATION CASE, THE NUMBER OF ',
20242     1           'REPLICATION VARIABLES')
20243          CALL DPWRST('XXX','BUG ')
20244          WRITE(ICOUT,512)
20245  512     FORMAT('      MUST BE BETWEEN ONE AND SIX.')
20246          CALL DPWRST('XXX','BUG ')
20247          WRITE(ICOUT,513)NREPL
20248  513     FORMAT('      THE NUMBER OF REPLICATION VARIABLES = ',I5)
20249          CALL DPWRST('XXX','BUG ')
20250          IERROR='YES'
20251          GOTO9000
20252        ENDIF
20253      ELSE
20254        NRESP=NUMVAR
20255        IMULT='ON'
20256      ENDIF
20257C
20258      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FRTE')THEN
20259        WRITE(ICOUT,521)NRESP,NREPL
20260  521   FORMAT('NRESP,NREPL = ',2I5)
20261        CALL DPWRST('XXX','BUG ')
20262      ENDIF
20263C
20264      IF(ICASAN.EQ.'FBTE')THEN
20265        IH='M   '
20266        IH2='    '
20267        IHWUSE='P'
20268        MESSAG='NO'
20269        CALL CHECKN(IH,IH2,IHWUSE,
20270     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
20271     1              ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
20272        IF(IERROR.EQ.'NO')THEN
20273          AM=VALUE(ILOCP)
20274          M=INT(AM+0.5)
20275        ELSE
20276          WRITE(ICOUT,999)
20277          CALL DPWRST('XXX','BUG ')
20278          WRITE(ICOUT,102)
20279          CALL DPWRST('XXX','BUG ')
20280          WRITE(ICOUT,5811)
20281 5811     FORMAT('      THE DESIRED BLOCK SIZE WAS NOT SET.  TO SET ')
20282          CALL DPWRST('XXX','BUG ')
20283          WRITE(ICOUT,5813)
20284 5813     FORMAT('      THE BLOCK SIZE, ENTER THE COMMAND')
20285          CALL DPWRST('XXX','BUG ')
20286          WRITE(ICOUT,999)
20287          CALL DPWRST('XXX','BUG ')
20288          WRITE(ICOUT,5814)
20289 5814     FORMAT('      LET M = value')
20290          CALL DPWRST('XXX','BUG ')
20291          WRITE(ICOUT,999)
20292          CALL DPWRST('XXX','BUG ')
20293          IERROR='YES'
20294          GOTO9000
20295        ENDIF
20296        IF(M.LT.20)THEN
20297          WRITE(ICOUT,999)
20298          CALL DPWRST('XXX','BUG ')
20299          WRITE(ICOUT,5821)
20300 5821     FORMAT('***** WARNING: FOR THE FREQUENCY WITHIN A BLOCK ',
20301     1           'TEST, THE ')
20302          CALL DPWRST('XXX','BUG ')
20303          WRITE(ICOUT,5822)
20304 5822     FORMAT('      RECOMMENDATION FOR THE MINIMUM BLOCK SIZE')
20305          CALL DPWRST('XXX','BUG ')
20306          WRITE(ICOUT,5823)M
20307 5823     FORMAT('      IS 20.  THE SPECIFIED BLOCK SIZE IS ',I8)
20308          CALL DPWRST('XXX','BUG ')
20309        ENDIF
20310      ENDIF
20311C
20312C               ******************************************************
20313C               **  STEP 6--                                        **
20314C               **  GENERATE THE FREQUENCY        TEST FOR THE      **
20315C               **  VARIOUS CASES                                   **
20316C               ******************************************************
20317C
20318      ISTEPN='6'
20319      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FRTE')
20320     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20321C
20322C               ******************************************
20323C               **  STEP 8A--                           **
20324C               **  CASE 1: NO REPLICATION VARIABLES    **
20325C               ******************************************
20326C
20327      IF(NREPL.LT.1)THEN
20328        ISTEPN='8A'
20329        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FRTE')
20330     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20331C
20332C       LOOP THROUGH EACH OF THE RESPONSE VARIABLES
20333C
20334        NCURVE=0
20335        DO810IRESP=1,NRESP
20336          NCURVE=NCURVE+1
20337C
20338          IINDX=ICOLR(IRESP)
20339          PID(1)=CPUMIN
20340          IVARID(1)=IVARN1(IRESP)
20341          IVARI2(1)=IVARN2(IRESP)
20342C
20343          IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FRTE')THEN
20344            WRITE(ICOUT,999)
20345            CALL DPWRST('XXX','BUG ')
20346            WRITE(ICOUT,811)IRESP,NCURVE
20347  811       FORMAT('IRESP,NCURVE = ',2I5)
20348            CALL DPWRST('XXX','BUG ')
20349          ENDIF
20350C
20351          ICOL=IRESP
20352          NUMVA2=1
20353          CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
20354     1                INAME,IVARN1,IVARN2,IVARTY,
20355     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
20356     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
20357     1                MAXCP4,MAXCP5,MAXCP6,
20358     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
20359     1                Y,XTEMP1,XTEMP1,NS1,NLOCA2,NLOCA3,ICASE,
20360     1                IBUGA3,ISUBRO,IFOUND,IERROR)
20361          IF(IERROR.EQ.'YES')GOTO9000
20362C
20363C         *****************************************************
20364C         **  STEP 8B--                                      **
20365C         *****************************************************
20366C
20367          IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FRTE')THEN
20368            ISTEPN='8B'
20369            CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20370            WRITE(ICOUT,999)
20371            CALL DPWRST('XXX','BUG ')
20372            WRITE(ICOUT,822)
20373  822       FORMAT('***** FROM THE MIDDLE  OF DPFRTE--')
20374            CALL DPWRST('XXX','BUG ')
20375            WRITE(ICOUT,823)ICASAN,NUMVAR,NS1
20376  823       FORMAT('ICASAN,NUMVAR,NQ = ',A4,2I8)
20377            CALL DPWRST('XXX','BUG ')
20378            IF(NS1.GE.1)THEN
20379              DO825I=1,NS1
20380                WRITE(ICOUT,826)I,Y(I)
20381  826           FORMAT('I,Y(I) = ',I8,G15.7)
20382                CALL DPWRST('XXX','BUG ')
20383  825         CONTINUE
20384            ENDIF
20385          ENDIF
20386C
20387          CALL DPFRT2(Y,NS1,
20388     1                XTEMP1,MAXNXT,
20389     1                ICAPSW,ICAPTY,IFORSW,ICASAN,M,
20390     1                PID,IVARID,IVARI2,NREPL,
20391     1                STATVA,STATCD,PVAL,
20392     1                CUT0,CUT50,CUT75,CUT90,CUT95,
20393     1                CUT975,CUT99,CUT999,
20394     1                YTEMP1,YTEMP2,
20395     1                ISUBRO,IBUGA3,IERROR)
20396C
20397C               ***************************************
20398C               **  STEP 8C--                        **
20399C               **  UPDATE INTERNAL DATAPLOT TABLES  **
20400C               ***************************************
20401C
20402          ISTEPN='8C'
20403          IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FRTE')
20404     1      CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20405C
20406          IF(NRESP.GT.1)THEN
20407            IFLAGU='FILE'
20408          ELSE
20409            IFLAGU='ON'
20410          ENDIF
20411          IFRST=.FALSE.
20412          ILAST=.FALSE.
20413          IF(IRESP.EQ.1)IFRST=.TRUE.
20414          IF(IRESP.EQ.NRESP)ILAST=.TRUE.
20415          CALL DPFRT5(STATVA,STATCD,PVAL,
20416     1                CUT0,CUT50,CUT75,CUT90,CUT95,
20417     1                CUT975,CUT99,CUT999,
20418     1                IFLAGU,IFRST,ILAST,
20419     1                IBUGA2,IBUGA3,ISUBRO,IERROR)
20420  810   CONTINUE
20421C
20422C               ****************************************************
20423C               **  STEP 9A--                                     **
20424C               **  CASE 3: ONE OR MORE REPLICATION VARIABLES.    **
20425C               **          FOR THIS CASE, THE NUMBER OF RESPONSE **
20426C               **          VARIABLES MUST BE EXACTLY 1.          **
20427C               **          FOR THIS CASE, ALL VARIABLES MUST     **
20428C               **          HAVE THE SAME LENGTH.                 **
20429C               ****************************************************
20430C
20431      ELSEIF(NREPL.GE.1)THEN
20432        ISTEPN='9A'
20433        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FRTE')
20434     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20435C
20436        J=0
20437        IMAX=NRIGHT(1)
20438        IF(NQ.LT.NRIGHT(1))IMAX=NQ
20439        DO910I=1,IMAX
20440          IF(ISUB(I).EQ.0)GOTO910
20441          J=J+1
20442C
20443C         RESPONSE VARIABLE IN Y
20444C
20445          ICOLC=1
20446          IJ=MAXN*(ICOLR(ICOLC)-1)+I
20447          IF(ICOLR(ICOLC).LE.MAXCOL)Y(J)=V(IJ)
20448          IF(ICOLR(ICOLC).EQ.MAXCP1)Y(J)=PRED(I)
20449          IF(ICOLR(ICOLC).EQ.MAXCP2)Y(J)=RES(I)
20450          IF(ICOLR(ICOLC).EQ.MAXCP3)Y(J)=YPLOT(I)
20451          IF(ICOLR(ICOLC).EQ.MAXCP4)Y(J)=XPLOT(I)
20452          IF(ICOLR(ICOLC).EQ.MAXCP5)Y(J)=X2PLOT(I)
20453          IF(ICOLR(ICOLC).EQ.MAXCP6)Y(J)=TAGPLO(I)
20454C
20455          IF(NREPL.GE.1)THEN
20456            DO920IR=1,MIN(NREPL,6)
20457              ICOLC=ICOLC+1
20458              ICOLT=ICOLR(ICOLC)
20459              IJ=MAXN*(ICOLT-1)+I
20460              IF(ICOLT.LE.MAXCOL)XDESGN(J,IR)=V(IJ)
20461              IF(ICOLT.EQ.MAXCP1)XDESGN(J,IR)=PRED(I)
20462              IF(ICOLT.EQ.MAXCP2)XDESGN(J,IR)=RES(I)
20463              IF(ICOLT.EQ.MAXCP3)XDESGN(J,IR)=YPLOT(I)
20464              IF(ICOLT.EQ.MAXCP4)XDESGN(J,IR)=XPLOT(I)
20465              IF(ICOLT.EQ.MAXCP5)XDESGN(J,IR)=X2PLOT(I)
20466              IF(ICOLT.EQ.MAXCP6)XDESGN(J,IR)=TAGPLO(I)
20467  920       CONTINUE
20468          ENDIF
20469C
20470  910   CONTINUE
20471        NLOCAL=J
20472C
20473C       *****************************************************
20474C       **  STEP 9B--                                      **
20475C       **  CALL DPFRT2 TO PERFORM FREQUENCY        TEST.  **
20476C       *****************************************************
20477C
20478C
20479        IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FRTE')THEN
20480          ISTEPN='9C'
20481          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20482          WRITE(ICOUT,999)
20483          CALL DPWRST('XXX','BUG ')
20484          WRITE(ICOUT,941)
20485  941     FORMAT('***** FROM THE MIDDLE  OF DPFRTE--')
20486          CALL DPWRST('XXX','BUG ')
20487          WRITE(ICOUT,942)ICASAN,NUMVAR,NLOCAL,NREPL
20488  942     FORMAT('ICASAN,NUMVAR,NLOCAL,NREPL = ',
20489     1           A4,3I8)
20490          CALL DPWRST('XXX','BUG ')
20491          IF(NLOCAL.GE.1)THEN
20492            DO945I=1,NLOCAL
20493              WRITE(ICOUT,946)I,Y(I),XDESGN(I,1),XDESGN(I,2)
20494  946         FORMAT('I,Y(I),XDESGN(I,1),XDESGN(I,2) = ',
20495     1               I8,4F12.5)
20496              CALL DPWRST('XXX','BUG ')
20497  945       CONTINUE
20498          ENDIF
20499        ENDIF
20500C
20501C       *****************************************************
20502C       **  STEP 9C--                                      **
20503C       **  FIND THE DISTINCT VALUES IN EACH OF THE        **
20504C       **  REPLICATION VARIABLES.                         **
20505C       *****************************************************
20506C
20507        CALL DPPP5(XDESGN(1,1),XDESGN(1,2),XDESGN(1,3),
20508     1             XDESGN(1,4),XDESGN(1,5),XDESGN(1,6),
20509     1             NREPL,NLOCAL,MAXOBV,
20510     1             XIDTEM,XIDTE2,XIDTE3,XIDTE4,XIDTE5,XIDTE6,
20511     1             XTEMP1,TEMP2,
20512     1             NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,NUMSE6,
20513     1             IBUGA3,ISUBRO,IERROR)
20514C
20515C       *****************************************************
20516C       **  STEP 9D--                                      **
20517C       **  NOW LOOP THROUGH THE VARIOUS REPLICATIONS      **
20518C       *****************************************************
20519C
20520        NCURVE=0
20521        IADD=1
20522C
20523        IF(NREPL.EQ.1)THEN
20524          J=0
20525          DO1110ISET1=1,NUMSE1
20526            K=0
20527            PID(IADD+1)=XIDTEM(ISET1)
20528            DO1130I=1,NLOCAL
20529              IF(XIDTEM(ISET1).EQ.XDESGN(I,1))THEN
20530                K=K+1
20531                TEMP1(K)=Y(I)
20532              ENDIF
20533 1130       CONTINUE
20534            NTEMP=K
20535            NCURVE=NCURVE+1
20536            IF(NTEMP.GT.0)THEN
20537              CALL DPFRT2(TEMP1,NTEMP,
20538     1                    XTEMP1,MAXNXT,
20539     1                    ICAPSW,ICAPTY,IFORSW,ICASAN,M,
20540     1                    PID,IVARN1,IVARN2,NREPL,
20541     1                    STATVA,STATCD,PVAL,
20542     1                    CUT0,CUT50,CUT75,CUT90,CUT95,
20543     1                    CUT975,CUT99,CUT999,
20544     1                    YTEMP1,YTEMP2,
20545     1                    ISUBRO,IBUGA3,IERROR)
20546              IFLAGU='FILE'
20547              IFRST=.FALSE.
20548              ILAST=.FALSE.
20549              IF(NCURVE.EQ.1)IFRST=.TRUE.
20550              IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
20551              CALL DPFRT5(STATVA,STATCD,PVAL,
20552     1                    CUT0,CUT50,CUT75,CUT90,CUT95,
20553     1                    CUT975,CUT99,CUT999,
20554     1                    IFLAGU,IFRST,ILAST,
20555     1                    IBUGA2,IBUGA3,ISUBRO,IERROR)
20556            ENDIF
20557 1110     CONTINUE
20558        ELSEIF(NREPL.EQ.2)THEN
20559          J=0
20560          NTOT=NUMSE1*NUMSE2
20561          DO1210ISET1=1,NUMSE1
20562          DO1220ISET2=1,NUMSE2
20563            K=0
20564            PID(1+IADD)=XIDTEM(ISET1)
20565            PID(2+IADD)=XIDTE2(ISET2)
20566            DO1290I=1,NLOCAL
20567              IF(
20568     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
20569     1           XIDTE2(ISET2).EQ.XDESGN(I,2)
20570     1          )THEN
20571                K=K+1
20572                TEMP1(K)=Y(I)
20573              ENDIF
20574 1290       CONTINUE
20575            NTEMP=K
20576            NCURVE=NCURVE+1
20577            IF(NTEMP.GT.0)THEN
20578              CALL DPFRT2(TEMP1,NTEMP,
20579     1                    XTEMP1,MAXNXT,
20580     1                    ICAPSW,ICAPTY,IFORSW,ICASAN,M,
20581     1                    PID,IVARN1,IVARN2,NREPL,
20582     1                    STATVA,STATCD,PVAL,
20583     1                    CUT0,CUT50,CUT75,CUT90,CUT95,
20584     1                    CUT975,CUT99,CUT999,
20585     1                    YTEMP1,YTEMP2,
20586     1                    ISUBRO,IBUGA3,IERROR)
20587              IFLAGU='FILE'
20588              IFRST=.FALSE.
20589              ILAST=.FALSE.
20590              IF(NCURVE.EQ.1)IFRST=.TRUE.
20591              IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
20592              CALL DPFRT5(STATVA,STATCD,PVAL,
20593     1                    CUT0,CUT50,CUT75,CUT90,CUT95,
20594     1                    CUT975,CUT99,CUT999,
20595     1                    IFLAGU,IFRST,ILAST,
20596     1                    IBUGA2,IBUGA3,ISUBRO,IERROR)
20597            ENDIF
20598 1220     CONTINUE
20599 1210     CONTINUE
20600        ELSEIF(NREPL.EQ.3)THEN
20601          J=0
20602          NTOT=NUMSE1*NUMSE2*NUMSE3
20603          DO1310ISET1=1,NUMSE1
20604          DO1320ISET2=1,NUMSE2
20605          DO1330ISET3=1,NUMSE3
20606            K=0
20607            PID(1+IADD)=XIDTEM(ISET1)
20608            PID(2+IADD)=XIDTE2(ISET2)
20609            PID(3+IADD)=XIDTE3(ISET3)
20610            DO1390I=1,NLOCAL
20611              IF(
20612     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
20613     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
20614     1           XIDTE3(ISET3).EQ.XDESGN(I,3)
20615     1          )THEN
20616                K=K+1
20617                TEMP1(K)=Y(I)
20618              ENDIF
20619 1390       CONTINUE
20620            NTEMP=K
20621            NCURVE=NCURVE+1
20622            NPLOT1=NPLOTP
20623            IF(NTEMP.GT.0)THEN
20624              CALL DPFRT2(TEMP1,NTEMP,
20625     1                    XTEMP1,MAXNXT,
20626     1                    ICAPSW,ICAPTY,IFORSW,ICASAN,M,
20627     1                    PID,IVARN1,IVARN2,NREPL,
20628     1                    STATVA,STATCD,PVAL,
20629     1                    CUT0,CUT50,CUT75,CUT90,CUT95,
20630     1                    CUT975,CUT99,CUT999,
20631     1                    YTEMP1,YTEMP2,
20632     1                    ISUBRO,IBUGA3,IERROR)
20633              IFLAGU='FILE'
20634              IFRST=.FALSE.
20635              ILAST=.FALSE.
20636              IF(NCURVE.EQ.1)IFRST=.TRUE.
20637              IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
20638              CALL DPFRT5(STATVA,STATCD,PVAL,
20639     1                    CUT0,CUT50,CUT75,CUT90,CUT95,
20640     1                    CUT975,CUT99,CUT999,
20641     1                    IFLAGU,IFRST,ILAST,
20642     1                    IBUGA2,IBUGA3,ISUBRO,IERROR)
20643            ENDIF
20644 1330     CONTINUE
20645 1320     CONTINUE
20646 1310     CONTINUE
20647        ELSEIF(NREPL.EQ.4)THEN
20648          J=0
20649          NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4
20650          DO1410ISET1=1,NUMSE1
20651          DO1420ISET2=1,NUMSE2
20652          DO1430ISET3=1,NUMSE3
20653          DO1440ISET4=1,NUMSE4
20654            K=0
20655            PID(1+IADD)=XIDTEM(ISET1)
20656            PID(2+IADD)=XIDTE2(ISET2)
20657            PID(3+IADD)=XIDTE3(ISET3)
20658            PID(4+IADD)=XIDTE4(ISET4)
20659            DO1490I=1,NLOCAL
20660              IF(
20661     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
20662     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
20663     1           XIDTE3(ISET3).EQ.XDESGN(I,3) .AND.
20664     1           XIDTE4(ISET4).EQ.XDESGN(I,4)
20665     1          )THEN
20666                K=K+1
20667                TEMP1(K)=Y(I)
20668              ENDIF
20669 1490       CONTINUE
20670            NTEMP=K
20671            NCURVE=NCURVE+1
20672            NPLOT1=NPLOTP
20673            IF(NTEMP.GT.0)THEN
20674              CALL DPFRT2(TEMP1,NTEMP,
20675     1                    XTEMP1,MAXNXT,
20676     1                    ICAPSW,ICAPTY,IFORSW,ICASAN,M,
20677     1                    PID,IVARN1,IVARN2,NREPL,
20678     1                    STATVA,STATCD,PVAL,
20679     1                    CUT0,CUT50,CUT75,CUT90,CUT95,
20680     1                    CUT975,CUT99,CUT999,
20681     1                    YTEMP1,YTEMP2,
20682     1                    ISUBRO,IBUGA3,IERROR)
20683              IFLAGU='FILE'
20684              IFRST=.FALSE.
20685              ILAST=.FALSE.
20686              IF(NCURVE.EQ.1)IFRST=.TRUE.
20687              IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
20688              CALL DPFRT5(STATVA,STATCD,PVAL,
20689     1                    CUT0,CUT50,CUT75,CUT90,CUT95,
20690     1                    CUT975,CUT99,CUT999,
20691     1                    IFLAGU,IFRST,ILAST,
20692     1                    IBUGA2,IBUGA3,ISUBRO,IERROR)
20693            ENDIF
20694 1440     CONTINUE
20695 1430     CONTINUE
20696 1420     CONTINUE
20697 1410     CONTINUE
20698        ELSEIF(NREPL.EQ.5)THEN
20699          J=0
20700          NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5
20701          DO1510ISET1=1,NUMSE1
20702          DO1520ISET2=1,NUMSE2
20703          DO1530ISET3=1,NUMSE3
20704          DO1540ISET4=1,NUMSE4
20705          DO1550ISET5=1,NUMSE5
20706            K=0
20707            PID(1+IADD)=XIDTEM(ISET1)
20708            PID(2+IADD)=XIDTE2(ISET2)
20709            PID(3+IADD)=XIDTE3(ISET3)
20710            PID(4+IADD)=XIDTE4(ISET4)
20711            PID(5+IADD)=XIDTE5(ISET4)
20712            DO1590I=1,NLOCAL
20713              IF(
20714     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
20715     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
20716     1           XIDTE3(ISET3).EQ.XDESGN(I,3) .AND.
20717     1           XIDTE4(ISET4).EQ.XDESGN(I,4) .AND.
20718     1           XIDTE5(ISET5).EQ.XDESGN(I,5)
20719     1          )THEN
20720                K=K+1
20721                TEMP1(K)=Y(I)
20722              ENDIF
20723 1590       CONTINUE
20724            NTEMP=K
20725            NCURVE=NCURVE+1
20726            NPLOT1=NPLOTP
20727            IF(NTEMP.GT.0)THEN
20728              CALL DPFRT2(TEMP1,NTEMP,
20729     1                    XTEMP1,MAXNXT,
20730     1                    ICAPSW,ICAPTY,IFORSW,ICASAN,M,
20731     1                    PID,IVARN1,IVARN2,NREPL,
20732     1                    STATVA,STATCD,PVAL,
20733     1                    CUT0,CUT50,CUT75,CUT90,CUT95,
20734     1                    CUT975,CUT99,CUT999,
20735     1                    YTEMP1,YTEMP2,
20736     1                    ISUBRO,IBUGA3,IERROR)
20737              IFLAGU='FILE'
20738              IFRST=.FALSE.
20739              ILAST=.FALSE.
20740              IF(NCURVE.EQ.1)IFRST=.TRUE.
20741              IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
20742              CALL DPFRT5(STATVA,STATCD,PVAL,
20743     1                    CUT0,CUT50,CUT75,CUT90,CUT95,
20744     1                    CUT975,CUT99,CUT999,
20745     1                    IFLAGU,IFRST,ILAST,
20746     1                    IBUGA2,IBUGA3,ISUBRO,IERROR)
20747            ENDIF
20748 1550     CONTINUE
20749 1540     CONTINUE
20750 1530     CONTINUE
20751 1520     CONTINUE
20752 1510     CONTINUE
20753        ELSEIF(NREPL.EQ.6)THEN
20754          J=0
20755          NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5*NUMSE6
20756          DO1610ISET1=1,NUMSE1
20757          DO1620ISET2=1,NUMSE2
20758          DO1630ISET3=1,NUMSE3
20759          DO1640ISET4=1,NUMSE4
20760          DO1650ISET5=1,NUMSE5
20761          DO1660ISET6=1,NUMSE6
20762            K=0
20763            PID(1+IADD)=XIDTEM(ISET1)
20764            PID(2+IADD)=XIDTE2(ISET2)
20765            PID(3+IADD)=XIDTE3(ISET3)
20766            PID(4+IADD)=XIDTE4(ISET4)
20767            PID(5+IADD)=XIDTE5(ISET4)
20768            PID(6+IADD)=XIDTE6(ISET4)
20769            DO1690I=1,NLOCAL
20770              IF(
20771     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
20772     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
20773     1           XIDTE3(ISET3).EQ.XDESGN(I,3) .AND.
20774     1           XIDTE4(ISET4).EQ.XDESGN(I,4) .AND.
20775     1           XIDTE5(ISET5).EQ.XDESGN(I,5) .AND.
20776     1           XIDTE6(ISET6).EQ.XDESGN(I,6)
20777     1          )THEN
20778                K=K+1
20779                TEMP1(K)=Y(I)
20780              ENDIF
20781 1690       CONTINUE
20782            NTEMP=K
20783            NCURVE=NCURVE+1
20784            NPLOT1=NPLOTP
20785            IF(NTEMP.GT.0)THEN
20786              CALL DPFRT2(TEMP1,NTEMP,
20787     1                    XTEMP1,MAXNXT,
20788     1                    ICAPSW,ICAPTY,IFORSW,ICASAN,M,
20789     1                    PID,IVARN1,IVARN2,NREPL,
20790     1                    STATVA,STATCD,PVAL,
20791     1                    CUT0,CUT50,CUT75,CUT90,CUT95,
20792     1                    CUT975,CUT99,CUT999,
20793     1                    YTEMP1,YTEMP2,
20794     1                    ISUBRO,IBUGA3,IERROR)
20795              IFLAGU='FILE'
20796              IFRST=.FALSE.
20797              ILAST=.FALSE.
20798              IF(NCURVE.EQ.1)IFRST=.TRUE.
20799              IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
20800              CALL DPFRT5(STATVA,STATCD,PVAL,
20801     1                    CUT0,CUT50,CUT75,CUT90,CUT95,
20802     1                    CUT975,CUT99,CUT999,
20803     1                    IFLAGU,IFRST,ILAST,
20804     1                    IBUGA2,IBUGA3,ISUBRO,IERROR)
20805            ENDIF
20806 1660     CONTINUE
20807 1650     CONTINUE
20808 1640     CONTINUE
20809 1630     CONTINUE
20810 1620     CONTINUE
20811 1610     CONTINUE
20812        ENDIF
20813C
20814      ENDIF
20815C
20816C               *****************
20817C               **  STEP 90--  **
20818C               **  EXIT       **
20819C               *****************
20820C
20821 9000 CONTINUE
20822C
20823      IF(IERROR.EQ.'YES')THEN
20824        IF(IWIDTH.GE.1)THEN
20825          WRITE(ICOUT,9001)(IANS(I),I=1,MIN(100,IWIDTH))
20826 9001     FORMAT(100A1)
20827          CALL DPWRST('XXX','BUG ')
20828        ENDIF
20829      ENDIF
20830C
20831      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FRTE')THEN
20832        WRITE(ICOUT,999)
20833        CALL DPWRST('XXX','BUG ')
20834        WRITE(ICOUT,9011)
20835 9011   FORMAT('***** AT THE END       OF DPFRTE--')
20836        CALL DPWRST('XXX','BUG ')
20837        WRITE(ICOUT,9012)IFOUND,IERROR,ICASAN
20838 9012   FORMAT('IFOUND,IERROR,ICASAN = ',2(A4,2X),A4)
20839        CALL DPWRST('XXX','BUG ')
20840      ENDIF
20841C
20842      RETURN
20843      END
20844      SUBROUTINE DPFRT2(Y,N,
20845     1                  XTEMP,MAXNXT,
20846     1                  ICAPSW,ICAPTY,IFORSW,ICASAN,M,
20847     1                  PID,IVARID,IVARI2,NREPL,
20848     1                  STATVA,STATCD,PVAL,
20849     1                  CUT0,CUT50,CUT75,CUT90,CUT95,
20850     1                  CUT975,CUT99,CUT999,
20851     1                  YTEMP1,YTEMP2,
20852     1                  ISUBRO,IBUGA3,IERROR)
20853C
20854C     PURPOSE--THIS ROUTINE CARRIES OUT EITHER THE FREQUENCY TEST
20855C              FOR RANDOMNESS OR THE FREQUENCY WITHIN A BLOCK TEST
20856C              FOR RANDOMNESS.
20857C     EXAMPLE--FREQUENCY TEST Y
20858C              FREQUENCY WITHIN A BLOCK TEST Y
20859C     REFERENCE--A STATISTICAL TEST SUITE FOR RANDOM AND PSUEDORANDOM
20860C                NUMBER GENERATORS FOR CRYPTOGRAPHIC APPLICATIONS,
20861C                ANDREW RUHKIN, JUAN SOTO, JAMES NECHVATAL, MILES SMID,
20862C                ELAINE BARKER, STEFAN LEIGH, MARK LEVENSON,
20863C                MARK VANGEL, DAVID BANKS, ALAN HECKERT, JAMES DRAY,
20864C                SAN VO.  NIST SPECIAL PUBLICATION 800-22,
20865C                OCTOBER 2000, PP. 14-18.
20866C     WRITTEN BY--ALAN HECKERT
20867C                 STATISTICAL ENGINEERING DIVISION
20868C                 INFORMATION TECHNOLOGY LABORATORY
20869C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
20870C                 GAITHERSBURG, MD 20899-8980
20871C                 PHONE--301-975-2899
20872C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
20873C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
20874C     LANGUAGE--ANSI FORTRAN (1977)
20875C     VERSION NUMBER--2003/11
20876C     ORIGINAL VERSION--NOVEMBER  2003.
20877C     UPDATED         --MARCH     2011. USE DPDTA1 AND DPDTA5 TO PRINT
20878C                                       TABLES
20879C
20880C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
20881C
20882      CHARACTER*4 IVARID(*)
20883      CHARACTER*4 IVARI2(*)
20884C
20885      CHARACTER*4 ICAPSW
20886      CHARACTER*4 ICAPTY
20887      CHARACTER*4 IFORSW
20888      CHARACTER*4 ICASAN
20889C
20890      CHARACTER*4 ISUBRO
20891      CHARACTER*4 IBUGA3
20892      CHARACTER*4 IERROR
20893C
20894      CHARACTER*4 IWRITE
20895      CHARACTER*4 ISUBN1
20896      CHARACTER*4 ISUBN2
20897      CHARACTER*4 ISTEPN
20898C
20899C---------------------------------------------------------------------
20900C
20901      DIMENSION Y(*)
20902      DIMENSION XTEMP(*)
20903      DIMENSION YTEMP1(*)
20904      DIMENSION YTEMP2(*)
20905      DIMENSION PID(*)
20906C
20907      DOUBLE PRECISION DRESLT
20908      DOUBLE PRECISION DGAMIP
20909C
20910      PARAMETER (NUMALP=7)
20911C
20912      PARAMETER(NUMCLI=5)
20913      PARAMETER(MAXLIN=3)
20914      PARAMETER (MAXROW=NUMALP)
20915      PARAMETER (MAXRO2=20)
20916      CHARACTER*60 ITITLE
20917      CHARACTER*60 ITITLZ
20918      CHARACTER*1  ITITL9
20919      CHARACTER*60 ITEXT(MAXRO2)
20920      CHARACTER*4  ALIGN(NUMCLI)
20921      CHARACTER*4  VALIGN(NUMCLI)
20922      REAL         AVALUE(MAXRO2)
20923      INTEGER      NCTEXT(MAXRO2)
20924      INTEGER      IDIGIT(MAXRO2)
20925      INTEGER      NTOT(MAXRO2)
20926      CHARACTER*60 ITITL2(MAXLIN,NUMCLI)
20927      CHARACTER*15 IVALUE(MAXROW,NUMCLI)
20928      CHARACTER*4  ITYPCO(NUMCLI)
20929      INTEGER      NCTIT2(MAXLIN,NUMCLI)
20930      INTEGER      NCVALU(MAXROW,NUMCLI)
20931      INTEGER      IWHTML(NUMCLI)
20932      INTEGER      IWRTF(NUMCLI)
20933      REAL         AMAT(MAXROW,NUMCLI)
20934      LOGICAL IFRST
20935      LOGICAL ILAST
20936      LOGICAL IFLAGS
20937      LOGICAL IFLAGE
20938C
20939C---------------------------------------------------------------------
20940C
20941      INCLUDE 'DPCOP2.INC'
20942C
20943C-----START POINT-----------------------------------------------------
20944C
20945      ISUBN1='DPFR'
20946      ISUBN2='T2  '
20947      IERROR='NO'
20948C
20949      SN=0.0
20950C
20951      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FRT2')THEN
20952        WRITE(ICOUT,999)
20953  999   FORMAT(1X)
20954        CALL DPWRST('XXX','WRIT')
20955        WRITE(ICOUT,51)
20956   51   FORMAT('**** AT THE BEGINNING OF DPFRT2--')
20957        CALL DPWRST('XXX','WRIT')
20958        WRITE(ICOUT,52)N,MAXNXT,ICASAN,IBUGA3,ISUBRO
20959   52   FORMAT('N,MAXNXT,ICASAN,IBUGA3,ISUBRO = ',2I8,3(A4,2X))
20960        CALL DPWRST('XXX','WRIT')
20961        DO56I=1,N
20962          WRITE(ICOUT,57)I,Y(I)
20963   57     FORMAT('I,Y(I) = ',I8,G15.7)
20964          CALL DPWRST('XXX','WRIT')
20965   56   CONTINUE
20966      ENDIF
20967C
20968C               ********************************************
20969C               **  STEP 11--                             **
20970C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
20971C               ********************************************
20972C
20973      ISTEPN='11'
20974      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FRT2')
20975     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20976C
20977      IF(N.LE.5)THEN
20978        WRITE(ICOUT,999)
20979        CALL DPWRST('XXX','WRIT')
20980        WRITE(ICOUT,1111)
20981 1111   FORMAT('***** ERROR IN FREQUENCY TEST FOR RANDOMNESS.')
20982        CALL DPWRST('XXX','WRIT')
20983        WRITE(ICOUT,1113)
20984 1113   FORMAT('      AT LEAST SIX OBSERVATIONS REQUIRED.')
20985        CALL DPWRST('XXX','WRIT')
20986        WRITE(ICOUT,1115)N
20987 1115   FORMAT('SAMPLE SIZE = ',I8)
20988        CALL DPWRST('XXX','WRIT')
20989        IERROR='YES'
20990        GOTO9000
20991      ENDIF
20992C
20993C               *******************************
20994C               **  STEP 2--                 **
20995C               **  COMPUTE THE NUMBER OF    **
20996C               **  DISTINCT VALUES.         **
20997C               *******************************
20998C
20999      ISTEPN='2'
21000      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FRT2')
21001     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21002C
21003      IWRITE='NO'
21004      CALL DISTIN(Y,N,IWRITE,YTEMP1,NDIST,IBUGA3,IERROR)
21005C
21006      IF(IERROR.EQ.'YES')GOTO9000
21007      IF(NDIST.GT.2)THEN
21008        WRITE(ICOUT,999)
21009        CALL DPWRST('XXX','WRIT')
21010        WRITE(ICOUT,2001)
21011 2001   FORMAT('***** ERROR IN FREQUENCY RANDOMNESS TEST.')
21012        CALL DPWRST('XXX','WRIT')
21013        WRITE(ICOUT,2003)
21014 2003   FORMAT('      FOR FREQUENCY TEST, AT MOST TWO DISTINCT ',
21015     1         'VALUES ARE ALLOWED.')
21016        CALL DPWRST('XXX','WRIT')
21017        WRITE(ICOUT,2005)NDIST
21018 2005   FORMAT('      NUMBER OF DISTINCT VALUES = ',I8)
21019        CALL DPWRST('XXX','WRIT')
21020        IERROR='YES'
21021        GOTO9000
21022      ENDIF
21023C
21024      IF(ICASAN.EQ.'FRTE')GOTO2000
21025      IF(ICASAN.EQ.'FBTE')GOTO3000
21026C
21027 2000 CONTINUE
21028      IF(NDIST.EQ.1)THEN
21029        DO2010I=1,N
21030          YTEMP2(I)=1.0
21031 2010   CONTINUE
21032      ELSE
21033        ALOW=MIN(YTEMP1(1),YTEMP1(2))
21034        AHIGH=MAX(YTEMP1(1),YTEMP1(2))
21035        SN=0.0
21036        DO2020I=1,N
21037          IF(Y(I).EQ.ALOW)THEN
21038            SN=SN - 1.0
21039          ELSE
21040            SN=SN + 1.0
21041          ENDIF
21042 2020   CONTINUE
21043      ENDIF
21044C
21045C               ******************************
21046C               **  STEP 21--               **
21047C               **  CARRY OUT CALCULATIONS  **
21048C               **  FOR FREQUENCY     TEST  **
21049C               ******************************
21050C
21051      ISTEPN='21'
21052      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FRT2')
21053     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21054C
21055      IWRITE='OFF'
21056C
21057      STATVA=ABS(SN)/SQRT(REAL(N))
21058C
21059      ARG1=STATVA
21060      CALL NORCDF(ARG1,RESULT)
21061      TERM=2.0*RESULT-1.0
21062      PVAL=1.0-TERM
21063      STATCD=RESULT
21064C
21065      CUT0=0.
21066C
21067      ALPHA=.5
21068      P2=1.0-ALPHA/2.0
21069      CALL NORPPF(P2,CUT50)
21070C
21071      ALPHA=.25
21072      P2=1.0-ALPHA/2.0
21073      CALL NORPPF(P2,CUT75)
21074C
21075      ALPHA=.10
21076      P2=1.0-ALPHA/2.0
21077      CALL NORPPF(P2,CUT90)
21078C
21079      ALPHA=.05
21080      P2=1.0-ALPHA/2.0
21081      CALL NORPPF(P2,CUT95)
21082C
21083      ALPHA=.025
21084      P2=1.0-ALPHA/2.0
21085      CALL NORPPF(P2,CUT975)
21086C
21087      ALPHA=.01
21088      P2=1.0-ALPHA/2.0
21089      CALL NORPPF(P2,CUT99)
21090C
21091      ALPHA=.001
21092      P2=1.0-ALPHA/2.0
21093      CALL NORPPF(P2,CUT999)
21094C
21095C               *********************************
21096C               **   STEP 52--                 **
21097C               **   WRITE OUT EVERYTHING      **
21098C               **   FOR FREQUENCY TEST        **
21099C               *********************************
21100C
21101      ISTEPN='22'
21102      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FRT2')
21103     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21104C
21105      IF(IPRINT.EQ.'OFF')GOTO9000
21106C
21107      NUMDIG=7
21108      IF(IFORSW.EQ.'1')NUMDIG=1
21109      IF(IFORSW.EQ.'2')NUMDIG=2
21110      IF(IFORSW.EQ.'3')NUMDIG=3
21111      IF(IFORSW.EQ.'4')NUMDIG=4
21112      IF(IFORSW.EQ.'5')NUMDIG=5
21113      IF(IFORSW.EQ.'6')NUMDIG=6
21114      IF(IFORSW.EQ.'7')NUMDIG=7
21115      IF(IFORSW.EQ.'8')NUMDIG=8
21116      IF(IFORSW.EQ.'9')NUMDIG=9
21117      IF(IFORSW.EQ.'0')NUMDIG=0
21118      IF(IFORSW.EQ.'E')NUMDIG=-2
21119      IF(IFORSW.EQ.'-2')NUMDIG=-2
21120      IF(IFORSW.EQ.'-3')NUMDIG=-3
21121      IF(IFORSW.EQ.'-4')NUMDIG=-4
21122      IF(IFORSW.EQ.'-5')NUMDIG=-5
21123      IF(IFORSW.EQ.'-6')NUMDIG=-6
21124      IF(IFORSW.EQ.'-7')NUMDIG=-7
21125      IF(IFORSW.EQ.'-8')NUMDIG=-8
21126      IF(IFORSW.EQ.'-9')NUMDIG=-9
21127C
21128      ITITLE='Frequency Test for Randomness'
21129      NCTITL=29
21130      ITITLZ=' '
21131      NCTITZ=0
21132C
21133      ICNT=1
21134      ITEXT(ICNT)=' '
21135      NCTEXT(ICNT)=0
21136      AVALUE(ICNT)=0.0
21137      IDIGIT(ICNT)=-1
21138C
21139      ICNT=ICNT+1
21140      ITEXT(ICNT)='Response Variable: '
21141      WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1)(1:4)
21142      WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1)(1:4)
21143      NCTEXT(ICNT)=27
21144      AVALUE(ICNT)=0.0
21145      IDIGIT(ICNT)=-1
21146C
21147      IF(NREPL.GT.0)THEN
21148        IADD=1
21149        DO2101I=1,NREPL
21150          ICNT=ICNT+1
21151          ITEMP=I+IADD
21152          ITEXT(ICNT)='Factor Variable  : '
21153          WRITE(ITEXT(ICNT)(17:17),'(I1)')I
21154          WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(ITEMP)(1:4)
21155          WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(ITEMP)(1:4)
21156          NCTEXT(ICNT)=27
21157          AVALUE(ICNT)=PID(ITEMP)
21158          IDIGIT(ICNT)=NUMDIG
21159 2101   CONTINUE
21160      ENDIF
21161C
21162      ICNT=ICNT+1
21163      ITEXT(ICNT)=' '
21164      NCTEXT(ICNT)=1
21165      AVALUE(ICNT)=0.0
21166      IDIGIT(ICNT)=-1
21167C
21168      ICNT=ICNT+1
21169      ITEXT(ICNT)='H0: The Data Are Random'
21170      NCTEXT(ICNT)=23
21171      AVALUE(ICNT)=0.0
21172      IDIGIT(ICNT)=-1
21173      ICNT=ICNT+1
21174      ITEXT(ICNT)='Ha: The Data Are Not Random'
21175      NCTEXT(ICNT)=27
21176      AVALUE(ICNT)=0.0
21177      IDIGIT(ICNT)=-1
21178C
21179      ICNT=ICNT+1
21180      ITEXT(ICNT)=' '
21181      NCTEXT(ICNT)=1
21182      AVALUE(ICNT)=0.0
21183      IDIGIT(ICNT)=-1
21184      ICNT=ICNT+1
21185      ITEXT(ICNT)='Summary Statistics:'
21186      NCTEXT(ICNT)=19
21187      AVALUE(ICNT)=0.0
21188      IDIGIT(ICNT)=-1
21189      ICNT=ICNT+1
21190      ITEXT(ICNT)='Number of Observations:'
21191      NCTEXT(ICNT)=23
21192      AVALUE(ICNT)=REAL(N)
21193      IDIGIT(ICNT)=0
21194      ICNT=ICNT+1
21195      ITEXT(ICNT)='Sum of +1 and -1 Values:'
21196      NCTEXT(ICNT)=24
21197      AVALUE(ICNT)=SN
21198      IDIGIT(ICNT)=NUMDIG
21199      ICNT=ICNT+1
21200      ITEXT(ICNT)=' '
21201      NCTEXT(ICNT)=1
21202      AVALUE(ICNT)=0.0
21203      IDIGIT(ICNT)=-1
21204      ICNT=ICNT+1
21205      ITEXT(ICNT)='Frequency Test Statistic:'
21206      NCTEXT(ICNT)=25
21207      AVALUE(ICNT)=STATVA
21208      IDIGIT(ICNT)=NUMDIG
21209      ICNT=ICNT+1
21210      ITEXT(ICNT)='CDF Value:'
21211      NCTEXT(ICNT)=10
21212      AVALUE(ICNT)=STATCD
21213      IDIGIT(ICNT)=NUMDIG
21214      ICNT=ICNT+1
21215      ITEXT(ICNT)='P-Value:'
21216      NCTEXT(ICNT)=8
21217      AVALUE(ICNT)=PVAL
21218      IDIGIT(ICNT)=NUMDIG
21219      ICNT=ICNT+1
21220      ITEXT(ICNT)=' '
21221      NCTEXT(ICNT)=1
21222      AVALUE(ICNT)=0.0
21223      IDIGIT(ICNT)=-1
21224C
21225      NUMROW=ICNT
21226      DO2110I=1,NUMROW
21227        NTOT(I)=15
21228 2110 CONTINUE
21229C
21230      IFRST=.TRUE.
21231      ILAST=.TRUE.
21232C
21233      ISTEPN='42A'
21234      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FRT2')
21235     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21236C
21237      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
21238     1            AVALUE,IDIGIT,
21239     1            NTOT,NUMROW,
21240     1            ICAPSW,ICAPTY,ILAST,IFRST,
21241     1            ISUBRO,IBUGA3,IERROR)
21242C
21243      ISTEPN='42D'
21244      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FRT2')
21245     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21246C
21247      ITITL9=' '
21248      NCTIT9=0
21249      ITITLE='Conclusions'
21250      NCTITL=11
21251C
21252      DO5030J=1,5
21253        DO5040I=1,3
21254          ITITL2(I,J)=' '
21255          NCTIT2(I,J)=0
21256 5040   CONTINUE
21257 5030 CONTINUE
21258C
21259      ITITL2(2,1)='Null'
21260      NCTIT2(2,1)=4
21261      ITITL2(3,1)='Hypothesis'
21262      NCTIT2(3,1)=10
21263C
21264      ITITL2(2,2)='Confidence'
21265      NCTIT2(2,2)=10
21266      ITITL2(3,2)='Level'
21267      NCTIT2(3,2)=5
21268C
21269      ITITL2(2,3)='Test'
21270      NCTIT2(2,3)=4
21271      ITITL2(3,3)='Statistic'
21272      NCTIT2(3,3)=9
21273C
21274      ITITL2(2,4)='Critical'
21275      NCTIT2(2,4)=8
21276      ITITL2(3,4)='Value (+/-)'
21277      NCTIT2(3,4)=11
21278C
21279      ITITL2(1,5)='Null'
21280      NCTIT2(1,5)=4
21281      ITITL2(2,5)='Hypothesis'
21282      NCTIT2(2,5)=10
21283      ITITL2(3,5)='Conclusion'
21284      NCTIT2(3,5)=10
21285C
21286      NMAX=0
21287      NUMCOL=5
21288      DO2050I=1,NUMCOL
21289        VALIGN(I)='b'
21290        ALIGN(I)='r'
21291        NTOT(I)=15
21292        IF(I.EQ.1)NTOT(I)=12
21293        NMAX=NMAX+NTOT(I)
21294        ITYPCO(I)='ALPH'
21295        IF(I.EQ.3 .OR. I.EQ.4)ITYPCO(I)='NUME'
21296        IDIGIT(I)=NUMDIG
21297        IWHTML(1)=150
21298        IWHTML(2)=125
21299        IWHTML(3)=150
21300        IWHTML(4)=150
21301        IWHTML(5)=150
21302        IINC=1600
21303        IINC2=1400
21304        IINC3=2200
21305        IWRTF(1)=IINC
21306        IWRTF(2)=IWRTF(1)+IINC
21307        IWRTF(3)=IWRTF(2)+IINC3
21308        IWRTF(4)=IWRTF(3)+IINC3
21309        IWRTF(5)=IWRTF(4)+IINC3
21310C
21311        DO2060J=1,NUMALP
21312C
21313          AMAT(J,I)=0.0
21314          AMAT(J,3)=STATVA
21315          IVALUE(J,1)='Random'
21316          NCVALU(J,1)=6
21317          IVALUE(J,5)(1:6)='REJECT'
21318          IF(J.EQ.1)THEN
21319            IVALUE(J,2)(1:5)='50.0%'
21320            AMAT(J,4)=CUT50
21321            IF(STATVA.LT.CUT50)IVALUE(J,5)(1:6)='ACCEPT'
21322          ELSEIF(J.EQ.2)THEN
21323            IVALUE(J,2)(1:5)='75.0%'
21324            AMAT(J,4)=CUT75
21325            IF(STATVA.LT.CUT75)IVALUE(J,5)(1:6)='ACCEPT'
21326          ELSEIF(J.EQ.3)THEN
21327            IVALUE(J,2)(1:5)='90.0%'
21328            AMAT(J,4)=CUT90
21329            IF(STATVA.LT.CUT90)IVALUE(J,5)(1:6)='ACCEPT'
21330          ELSEIF(J.EQ.4)THEN
21331            IVALUE(J,2)(1:5)='95.0%'
21332            AMAT(J,4)=CUT95
21333            IF(STATVA.LT.CUT95)IVALUE(J,5)(1:6)='ACCEPT'
21334          ELSEIF(J.EQ.5)THEN
21335            IVALUE(J,2)(1:5)='97.5%'
21336            AMAT(J,4)=CUT975
21337            IF(STATVA.LT.CUT975)IVALUE(J,5)(1:6)='ACCEPT'
21338          ELSEIF(J.EQ.6)THEN
21339            IVALUE(J,2)(1:5)='99.0%'
21340            AMAT(J,4)=CUT99
21341            IF(STATVA.LT.CUT99)IVALUE(J,5)(1:6)='ACCEPT'
21342          ELSEIF(J.EQ.7)THEN
21343            IVALUE(J,2)(1:5)='99.9%'
21344            AMAT(J,4)=CUT999
21345            IF(STATVA.LT.CUT999)IVALUE(J,5)(1:6)='ACCEPT'
21346          ENDIF
21347          NCVALU(J,2)=5
21348          NCVALU(J,5)=6
21349C
21350 2060   CONTINUE
21351 2050 CONTINUE
21352C
21353      ICNT=NUMALP
21354      NUMLIN=3
21355      NUMCOL=5
21356      IFRST=.TRUE.
21357      ILAST=.TRUE.
21358      IFLAGS=.TRUE.
21359      IFLAGE=.TRUE.
21360      CALL DPDTA5(ITITLE,NCTITL,
21361     1            ITITL9,NCTIT9,ITITL2,NCTIT2,
21362     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
21363     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
21364     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
21365     1            ICAPSW,ICAPTY,IFRST,ILAST,
21366     1            IFLAGS,IFLAGE,
21367     1            ISUBRO,IBUGA3,IERROR)
21368      GOTO9000
21369C
21370 3000 CONTINUE
21371C
21372      NBLOCK=N/M
21373      AMNSZ=0.01*REAL(N)
21374C
21375      IF(NBLOCK.GE.100)THEN
21376        WRITE(ICOUT,999)
21377        CALL DPWRST('XXX','BUG ')
21378        WRITE(ICOUT,3011)
21379 3011   FORMAT('***** WARNING: THE NUMBER OF BLOCKS IS GREATER')
21380        CALL DPWRST('XXX','BUG ')
21381        WRITE(ICOUT,3012)
21382 3012   FORMAT('      THAN THE RECOMMENDED MAXIMUM OF 100.')
21383        CALL DPWRST('XXX','BUG ')
21384        WRITE(ICOUT,3013)N
21385 3013   FORMAT('      SAMPLE SIZE       = ',I8)
21386        CALL DPWRST('XXX','BUG ')
21387        WRITE(ICOUT,3014)M
21388 3014   FORMAT('      BLOCK SIZE        = ',I8)
21389        CALL DPWRST('XXX','BUG ')
21390        WRITE(ICOUT,3015)NBLOCK
21391 3015   FORMAT('      NUMBER OF BLOCKS  = ',I8)
21392        CALL DPWRST('XXX','BUG ')
21393        WRITE(ICOUT,999)
21394        CALL DPWRST('XXX','BUG ')
21395      ENDIF
21396C
21397      IF(M.LE.INT(AMNSZ))THEN
21398        WRITE(ICOUT,999)
21399        CALL DPWRST('XXX','BUG ')
21400        WRITE(ICOUT,3021)
21401 3021   FORMAT('***** WARNING: THE BLOCK SIZE IS LESS THAN THE')
21402        CALL DPWRST('XXX','BUG ')
21403        WRITE(ICOUT,3022)INT(AMNSZ)
21404 3022   FORMAT('      RECOMMENDED MINIMUM OF ',I8)
21405        CALL DPWRST('XXX','BUG ')
21406        WRITE(ICOUT,3023)N
21407 3023   FORMAT('      SAMPLE SIZE                     = ',I8)
21408        CALL DPWRST('XXX','BUG ')
21409        WRITE(ICOUT,3024)M
21410 3024   FORMAT('      BLOCK SIZE                      = ',I8)
21411        CALL DPWRST('XXX','BUG ')
21412        WRITE(ICOUT,3025)NBLOCK
21413 3025   FORMAT('      NUMBER OF BLOCKS                = ',I8)
21414        CALL DPWRST('XXX','BUG ')
21415        WRITE(ICOUT,3026)INT(AMNSZ)
21416 3026   FORMAT('      RECOMMENDED MINIMUM BLOCK SIZE  = ',I8)
21417        CALL DPWRST('XXX','BUG ')
21418        WRITE(ICOUT,999)
21419        CALL DPWRST('XXX','BUG ')
21420      ENDIF
21421C
21422      IF(M.GT.N)THEN
21423        WRITE(ICOUT,999)
21424        CALL DPWRST('XXX','BUG ')
21425        WRITE(ICOUT,1111)
21426        CALL DPWRST('XXX','BUG ')
21427        WRITE(ICOUT,3031)
21428 3031   FORMAT('      THE BLOCK SIZE IS GREATER THAN THE SAMPLE SIZE')
21429        CALL DPWRST('XXX','BUG ')
21430        WRITE(ICOUT,3033)N
21431 3033   FORMAT('      SAMPLE SIZE                     = ',I8)
21432        CALL DPWRST('XXX','BUG ')
21433        WRITE(ICOUT,3034)M
21434 3034   FORMAT('      BLOCK SIZE                      = ',I8)
21435        CALL DPWRST('XXX','BUG ')
21436        WRITE(ICOUT,3035)NBLOCK
21437 3035   FORMAT('      NUMBER OF BLOCKS                = ',I8)
21438        CALL DPWRST('XXX','BUG ')
21439        WRITE(ICOUT,3036)INT(AMNSZ)
21440 3036   FORMAT('      RECOMMENDED MINIMUM BLOCK SIZE  = ',I8)
21441        CALL DPWRST('XXX','BUG ')
21442        WRITE(ICOUT,999)
21443        CALL DPWRST('XXX','BUG ')
21444        IERROR='YES'
21445        GOTO9000
21446      ENDIF
21447C
21448      IF(NDIST.NE.2)THEN
21449        WRITE(ICOUT,999)
21450        CALL DPWRST('XXX','BUG ')
21451        WRITE(ICOUT,1111)
21452        CALL DPWRST('XXX','BUG ')
21453        WRITE(ICOUT,3041)NDIST
21454 3041   FORMAT('      THE RESPONSE VARIBLE CONTAINS ',I8,' DISTINCT ',
21455     1         'VALUES.')
21456        CALL DPWRST('XXX','BUG ')
21457        WRITE(ICOUT,999)
21458        CALL DPWRST('XXX','BUG ')
21459        IERROR='YES'
21460        GOTO9000
21461      ENDIF
21462C
21463      ALOW=MIN(YTEMP1(1),YTEMP1(2))
21464      AHIGH=MAX(YTEMP1(1),YTEMP1(2))
21465      AM=REAL(M)
21466C
21467      SUM=0.0
21468      DO3110K=1,NBLOCK
21469        ISTRT=(K-1)*M+1
21470        ISTOP=K*M
21471        AONES=0
21472        DO3120I=ISTRT,ISTOP
21473          IF(Y(I).EQ.AHIGH)AONES=AONES+1.0
21474 3120   CONTINUE
21475        API=AONES/AM
21476        SUM=SUM + (API-0.5)**2
21477 3110 CONTINUE
21478C
21479      STATVA=4.0*AM*SUM
21480      DRESLT=1.0D0 - DGAMIP(DBLE(NBLOCK)/2.0D0,DBLE(STATVA)/2.0D0)
21481      PVAL=REAL(DRESLT)
21482C
21483C               *********************************
21484C               **   STEP 32--                 **
21485C               **   WRITE OUT EVERYTHING      **
21486C               **   FOR FREQUENCY TEST        **
21487C               *********************************
21488C
21489      ISTEPN='32'
21490      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FRT2')
21491     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21492C
21493      IF(IPRINT.EQ.'OFF')GOTO9000
21494C
21495      NUMDIG=7
21496      IF(IFORSW.EQ.'1')NUMDIG=1
21497      IF(IFORSW.EQ.'2')NUMDIG=2
21498      IF(IFORSW.EQ.'3')NUMDIG=3
21499      IF(IFORSW.EQ.'4')NUMDIG=4
21500      IF(IFORSW.EQ.'5')NUMDIG=5
21501      IF(IFORSW.EQ.'6')NUMDIG=6
21502      IF(IFORSW.EQ.'7')NUMDIG=7
21503      IF(IFORSW.EQ.'8')NUMDIG=8
21504      IF(IFORSW.EQ.'9')NUMDIG=9
21505      IF(IFORSW.EQ.'0')NUMDIG=0
21506      IF(IFORSW.EQ.'E')NUMDIG=-2
21507      IF(IFORSW.EQ.'-2')NUMDIG=-2
21508      IF(IFORSW.EQ.'-3')NUMDIG=-3
21509      IF(IFORSW.EQ.'-4')NUMDIG=-4
21510      IF(IFORSW.EQ.'-5')NUMDIG=-5
21511      IF(IFORSW.EQ.'-6')NUMDIG=-6
21512      IF(IFORSW.EQ.'-7')NUMDIG=-7
21513      IF(IFORSW.EQ.'-8')NUMDIG=-8
21514      IF(IFORSW.EQ.'-9')NUMDIG=-9
21515C
21516      ITITLE='Frequency Within a Block Test for Randomness'
21517      NCTITL=44
21518      ITITLZ=' '
21519      NCTITZ=0
21520C
21521      ICNT=1
21522      ITEXT(ICNT)=' '
21523      NCTEXT(ICNT)=0
21524      AVALUE(ICNT)=0.0
21525      IDIGIT(ICNT)=-1
21526C
21527      ICNT=ICNT+1
21528      ITEXT(ICNT)='Response Variable: '
21529      WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1)(1:4)
21530      WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1)(1:4)
21531      NCTEXT(ICNT)=27
21532      AVALUE(ICNT)=0.0
21533      IDIGIT(ICNT)=-1
21534C
21535      IF(NREPL.GT.0)THEN
21536        IADD=1
21537        DO6101I=1,NREPL
21538          ICNT=ICNT+1
21539          ITEMP=I+IADD
21540          ITEXT(ICNT)='Factor Variable  : '
21541          WRITE(ITEXT(ICNT)(17:17),'(I1)')I
21542          WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(ITEMP)(1:4)
21543          WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(ITEMP)(1:4)
21544          NCTEXT(ICNT)=27
21545          AVALUE(ICNT)=PID(ITEMP)
21546          IDIGIT(ICNT)=NUMDIG
21547 6101   CONTINUE
21548      ENDIF
21549C
21550      ICNT=ICNT+1
21551      ITEXT(ICNT)=' '
21552      NCTEXT(ICNT)=1
21553      AVALUE(ICNT)=0.0
21554      IDIGIT(ICNT)=-1
21555C
21556      ICNT=ICNT+1
21557      ITEXT(ICNT)='H0: The Data Are Random'
21558      NCTEXT(ICNT)=23
21559      AVALUE(ICNT)=0.0
21560      IDIGIT(ICNT)=-1
21561      ICNT=ICNT+1
21562      ITEXT(ICNT)='Ha: The Data Are Not Random'
21563      NCTEXT(ICNT)=27
21564      AVALUE(ICNT)=0.0
21565      IDIGIT(ICNT)=-1
21566C
21567      ICNT=ICNT+1
21568      ITEXT(ICNT)=' '
21569      NCTEXT(ICNT)=1
21570      AVALUE(ICNT)=0.0
21571      IDIGIT(ICNT)=-1
21572      ICNT=ICNT+1
21573      ITEXT(ICNT)='Summary Statistics:'
21574      NCTEXT(ICNT)=19
21575      AVALUE(ICNT)=0.0
21576      IDIGIT(ICNT)=-1
21577      ICNT=ICNT+1
21578      ITEXT(ICNT)='Number of Observations:'
21579      NCTEXT(ICNT)=23
21580      AVALUE(ICNT)=REAL(N)
21581      IDIGIT(ICNT)=0
21582      ICNT=ICNT+1
21583      ITEXT(ICNT)='Block Size:'
21584      NCTEXT(ICNT)=11
21585      AVALUE(ICNT)=REAL(M)
21586      IDIGIT(ICNT)=0
21587      ICNT=ICNT+1
21588      ITEXT(ICNT)='Number of Observations Within a Block:'
21589      NCTEXT(ICNT)=38
21590      AVALUE(ICNT)=REAL(NBLOCK)
21591      IDIGIT(ICNT)=0
21592      ICNT=ICNT+1
21593      ITEXT(ICNT)=' '
21594      NCTEXT(ICNT)=1
21595      AVALUE(ICNT)=0.0
21596      IDIGIT(ICNT)=-1
21597      ICNT=ICNT+1
21598      ITEXT(ICNT)='Frequency Within A Block Test Statistic:'
21599      NCTEXT(ICNT)=40
21600      AVALUE(ICNT)=STATVA
21601      IDIGIT(ICNT)=NUMDIG
21602      ICNT=ICNT+1
21603      ITEXT(ICNT)='P-Value:'
21604      NCTEXT(ICNT)=8
21605      AVALUE(ICNT)=PVAL
21606      IDIGIT(ICNT)=NUMDIG
21607      ICNT=ICNT+1
21608      ITEXT(ICNT)=' '
21609      NCTEXT(ICNT)=1
21610      AVALUE(ICNT)=0.0
21611      IDIGIT(ICNT)=-1
21612C
21613      NUMROW=ICNT
21614      DO6110I=1,NUMROW
21615        NTOT(I)=15
21616 6110 CONTINUE
21617C
21618      IFRST=.TRUE.
21619      ILAST=.TRUE.
21620C
21621      ISTEPN='42A'
21622      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FRT2')
21623     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21624C
21625      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
21626     1            AVALUE,IDIGIT,
21627     1            NTOT,NUMROW,
21628     1            ICAPSW,ICAPTY,ILAST,IFRST,
21629     1            ISUBRO,IBUGA3,IERROR)
21630C
21631      ISTEPN='42D'
21632      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FRT2')
21633     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21634C
21635      ITITL9=' '
21636      NCTIT9=0
21637      ITITLE='Conclusions'
21638      NCTITL=11
21639C
21640      DO6130J=1,4
21641        DO6140I=1,3
21642          ITITL2(I,J)=' '
21643          NCTIT2(I,J)=0
21644 6140   CONTINUE
21645 6130 CONTINUE
21646C
21647      ITITL2(2,1)='Null'
21648      NCTIT2(2,1)=4
21649      ITITL2(3,1)='Hypothesis'
21650      NCTIT2(3,1)=10
21651C
21652      ITITL2(2,2)='Confidence'
21653      NCTIT2(2,2)=10
21654      ITITL2(3,2)='Level'
21655      NCTIT2(3,2)=5
21656C
21657      ITITL2(3,3)='P-Value'
21658      NCTIT2(3,3)=7
21659C
21660      ITITL2(1,4)='Null'
21661      NCTIT2(1,4)=4
21662      ITITL2(2,4)='Hypothesis'
21663      NCTIT2(2,4)=10
21664      ITITL2(3,4)='Conclusion'
21665      NCTIT2(3,4)=10
21666C
21667      NMAX=0
21668      NUMCOL=4
21669      DO6150I=1,NUMCOL
21670        VALIGN(I)='b'
21671        ALIGN(I)='r'
21672        NTOT(I)=15
21673        IF(I.EQ.1)NTOT(I)=12
21674        NMAX=NMAX+NTOT(I)
21675        ITYPCO(I)='ALPH'
21676        IF(I.EQ.3)ITYPCO(I)='NUME'
21677        IDIGIT(I)=NUMDIG
21678        IWHTML(1)=150
21679        IWHTML(2)=125
21680        IWHTML(3)=150
21681        IWHTML(4)=150
21682        IINC=1600
21683        IINC2=1400
21684        IINC3=2200
21685        IWRTF(1)=IINC
21686        IWRTF(2)=IWRTF(1)+IINC
21687        IWRTF(3)=IWRTF(2)+IINC3
21688        IWRTF(4)=IWRTF(3)+IINC3
21689C
21690        DO6160J=1,NUMALP
21691C
21692          AMAT(J,I)=0.0
21693          AMAT(J,3)=PVAL
21694          IVALUE(J,1)='Random'
21695          NCVALU(J,1)=6
21696          IVALUE(J,4)(1:6)='REJECT'
21697          IF(J.EQ.1)THEN
21698            IVALUE(J,2)(1:5)='50.0%'
21699            IF(PVAL.GE.0.50)IVALUE(J,4)(1:6)='ACCEPT'
21700          ELSEIF(J.EQ.2)THEN
21701            IVALUE(J,2)(1:5)='75.0%'
21702            IF(PVAL.GE.0.25)IVALUE(J,4)(1:6)='ACCEPT'
21703          ELSEIF(J.EQ.3)THEN
21704            IVALUE(J,2)(1:5)='90.0%'
21705            IF(PVAL.GE.0.10)IVALUE(J,4)(1:6)='ACCEPT'
21706          ELSEIF(J.EQ.4)THEN
21707            IVALUE(J,2)(1:5)='95.0%'
21708            IF(PVAL.GE.0.05)IVALUE(J,4)(1:6)='ACCEPT'
21709          ELSEIF(J.EQ.5)THEN
21710            IVALUE(J,2)(1:5)='97.5%'
21711            IF(PVAL.GE.0.025)IVALUE(J,4)(1:6)='ACCEPT'
21712          ELSEIF(J.EQ.6)THEN
21713            IVALUE(J,2)(1:5)='99.0%'
21714            IF(PVAL.GE.0.01)IVALUE(J,4)(1:6)='ACCEPT'
21715          ELSEIF(J.EQ.7)THEN
21716            IVALUE(J,2)(1:5)='99.9%'
21717            IF(PVAL.GE.0.001)IVALUE(J,4)(1:6)='ACCEPT'
21718          ENDIF
21719          NCVALU(J,2)=5
21720          NCVALU(J,4)=6
21721C
21722 6160   CONTINUE
21723 6150 CONTINUE
21724C
21725      ICNT=NUMALP
21726      NUMLIN=3
21727      NUMCOL=4
21728      IFRST=.TRUE.
21729      ILAST=.TRUE.
21730      IFLAGS=.TRUE.
21731      IFLAGE=.TRUE.
21732      CALL DPDTA5(ITITLE,NCTITL,
21733     1            ITITL9,NCTIT9,ITITL2,NCTIT2,
21734     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
21735     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
21736     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
21737     1            ICAPSW,ICAPTY,IFRST,ILAST,
21738     1            IFLAGS,IFLAGE,
21739     1            ISUBRO,IBUGA3,IERROR)
21740C
21741C               *****************
21742C               **  STEP 90--  **
21743C               **  EXIT       **
21744C               *****************
21745C
21746 9000 CONTINUE
21747      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FRT2')THEN
21748        WRITE(ICOUT,999)
21749        CALL DPWRST('XXX','WRIT')
21750        WRITE(ICOUT,9011)
21751 9011   FORMAT('***** AT THE END       OF DPFRT2--')
21752        CALL DPWRST('XXX','WRIT')
21753        WRITE(ICOUT,9012)N,IBUGA3,IERROR
21754 9012   FORMAT('N,IBUGA3,IERROR = ',I8,2X,A4,2X,A4)
21755        CALL DPWRST('XXX','WRIT')
21756        DO9016I=1,N
21757          WRITE(ICOUT,9017)I,Y(I),XTEMP(I)
21758 9017     FORMAT('I,Y(I),XTEMP(I) = ',I8,2G15.7)
21759          CALL DPWRST('XXX','WRIT')
21760 9016   CONTINUE
21761      ENDIF
21762C
21763      RETURN
21764      END
21765      SUBROUTINE DPFRT3(X,N,IWRITE,XTEMP,STATVA,STATCD,
21766     1                  ISUBRO,IBUGA3,IERROR)
21767C
21768C     PURPOSE--THIS SUBROUTINE COMPUTES THE FREQUENCY STATISTIC (AND
21769C              ALTERNATIVELY THE CDF VALUE).
21770C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
21771C                                (UNSORTED OR SORTED) OBSERVATIONS.
21772C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
21773C                                IN THE VECTOR X.
21774C     OUTPUT ARGUMENTS--STATVA = THE SINGLE PRECISION VALUE OF THE
21775C                                COMPUTED STATISTIC.
21776C                     --STATCD = THE SINGLE PRECISION VALUE OF THE
21777C                                COMPUTED CDF OF THE TEST STATISTIC.
21778C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
21779C             TEST STATISTIC.
21780C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
21781C                   OF N FOR THIS SUBROUTINE.
21782C     OTHER DATAPAC   SUBROUTINES NEEDED--DISTIN
21783C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
21784C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
21785C     LANGUAGE--ANSI FORTRAN (1977)
21786C     WRITTEN BY--JAMES J. FILLIBEN
21787C                 STATISTICAL ENGINEERING DIVISION
21788C                 INFORMATION TECHNOLOGY LABORATORY
21789C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
21790C                 GAITHERSBURG, MD 20899-8980
21791C                 PHONE--301-975-2855
21792C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
21793C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
21794C     LANGUAGE--ANSI FORTRAN (1977)
21795C     VERSION NUMBER--2009.2
21796C     ORIGINAL VERSION--FEBRUARY  2009.
21797C
21798C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
21799C
21800      CHARACTER*4 IWRITE
21801      CHARACTER*4 IWRTSV
21802      CHARACTER*4 ISUBRO
21803      CHARACTER*4 IBUGA3
21804      CHARACTER*4 IERROR
21805C
21806      CHARACTER*4 ISUBN1
21807      CHARACTER*4 ISUBN2
21808C
21809C---------------------------------------------------------------------
21810C
21811      DIMENSION X(*)
21812      DIMENSION XTEMP(*)
21813C
21814C---------------------------------------------------------------------
21815C
21816      INCLUDE 'DPCOP2.INC'
21817C
21818C-----START POINT-----------------------------------------------------
21819C
21820      ISUBN1='DPFR'
21821      ISUBN2='T3  '
21822      IWRTSV=IWRITE
21823      IERROR='NO'
21824C
21825      SN=0.0
21826C
21827      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FRT3')THEN
21828        WRITE(ICOUT,999)
21829  999   FORMAT(1X)
21830        CALL DPWRST('XXX','BUG ')
21831        WRITE(ICOUT,51)
21832   51   FORMAT('***** AT THE BEGINNING OF DPFRT3--')
21833        CALL DPWRST('XXX','BUG ')
21834        WRITE(ICOUT,52)IBUGA3
21835   52   FORMAT('IBUGA3 = ',A4)
21836        CALL DPWRST('XXX','BUG ')
21837        WRITE(ICOUT,53)N
21838   53   FORMAT('N = ',I8)
21839        CALL DPWRST('XXX','BUG ')
21840        DO55I=1,N
21841          WRITE(ICOUT,56)I,X(I)
21842   56     FORMAT('I,X(I) = ',I8,G15.7)
21843          CALL DPWRST('XXX','BUG ')
21844   55   CONTINUE
21845      ENDIF
21846C
21847C               *******************************
21848C               **  COMPUTE FREQUENCY STATISTIC  **
21849C               *******************************
21850C
21851C               ********************************************
21852C               **  STEP 1--                              **
21853C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
21854C               ********************************************
21855C
21856      STATVA=-99.0
21857      STATCD=-99.0
21858      IWRITE='OFF'
21859C
21860      AN=N
21861C
21862      IF(N.LE.5)THEN
21863        IERROR='YES'
21864        WRITE(ICOUT,999)
21865        CALL DPWRST('XXX','BUG ')
21866        WRITE(ICOUT,111)
21867  111   FORMAT('***** ERROR IN FREQUENCY STATISTIC--')
21868        CALL DPWRST('XXX','BUG ')
21869        WRITE(ICOUT,112)
21870  112   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS FOR THE ',
21871     1         'RESPONSE')
21872        CALL DPWRST('XXX','BUG ')
21873        WRITE(ICOUT,113)
21874  113   FORMAT('      VARIABLE MUST BE 6 OR LARGER.')
21875        CALL DPWRST('XXX','BUG ')
21876        WRITE(ICOUT,116)
21877  116   FORMAT('      SUCH WAS NOT THE CASE HERE.')
21878        CALL DPWRST('XXX','BUG ')
21879        WRITE(ICOUT,117)N
21880  117   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
21881     1         '.')
21882        CALL DPWRST('XXX','BUG ')
21883        GOTO9000
21884      ENDIF
21885C
21886C               *****************************************
21887C               **  STEP 2--                           **
21888C               **  COMPUTE THE FREQUENCY STATISTIC.   **
21889C               *****************************************
21890C
21891      CALL DISTIN(X,N,IWRITE,XTEMP,NDIST,IBUGA3,IERROR)
21892C
21893      IF(IERROR.EQ.'YES')GOTO9000
21894      IF(NDIST.GT.2)THEN
21895        WRITE(ICOUT,999)
21896        CALL DPWRST('XXX','WRIT')
21897        WRITE(ICOUT,2001)
21898 2001   FORMAT('***** ERROR IN FREQUENCY RANDOMNESS TEST.')
21899        CALL DPWRST('XXX','WRIT')
21900        WRITE(ICOUT,2003)
21901 2003   FORMAT('      FOR FREQUENCY TEST, AT MOST TWO DISTINCT ',
21902     1         'VALUES ARE ALLOWED.')
21903        CALL DPWRST('XXX','WRIT')
21904        WRITE(ICOUT,2005)NDIST
21905 2005   FORMAT('      NUMBER OF DISTINCT VALUES = ',I8)
21906        CALL DPWRST('XXX','WRIT')
21907        IERROR='YES'
21908        GOTO9000
21909      ENDIF
21910C
21911      IF(NDIST.EQ.1)THEN
21912        DO2010I=1,N
21913          XTEMP(I)=1.0
21914 2010   CONTINUE
21915      ELSE
21916        ALOW=MIN(XTEMP(1),XTEMP(2))
21917        AHIGH=MAX(XTEMP(1),XTEMP(2))
21918        SN=0.0
21919        DO2020I=1,N
21920          IF(X(I).EQ.ALOW)THEN
21921            SN=SN - 1.0
21922          ELSE
21923            SN=SN + 1.0
21924          ENDIF
21925 2020   CONTINUE
21926      ENDIF
21927C
21928      STATVA=ABS(SN)/SQRT(REAL(N))
21929C
21930      ARG1=STATVA
21931      CALL NORCDF(ARG1,RESULT)
21932      TERM=2.0*RESULT-1.0
21933      STATCD=1.0-TERM
21934C
21935C               *******************************
21936C               **  STEP 3--                 **
21937C               **  WRITE OUT A LINE         **
21938C               **  OF SUMMARY INFORMATION.  **
21939C               *******************************
21940C
21941      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
21942        WRITE(ICOUT,999)
21943        CALL DPWRST('XXX','BUG ')
21944        WRITE(ICOUT,811)N,STATVA
21945  811   FORMAT('THE VALUE OF THE FREQUENCY STATISTIC OF THE ',I8,
21946     1         ' OBSERVATIONS = ',G15.7)
21947        CALL DPWRST('XXX','BUG ')
21948      ENDIF
21949C
21950C               *****************
21951C               **  STEP 90--  **
21952C               **  EXIT.      **
21953C               *****************
21954C
21955 9000 CONTINUE
21956C
21957      IWRITE=IWRTSV
21958C
21959      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FRT3')THEN
21960        WRITE(ICOUT,999)
21961        CALL DPWRST('XXX','BUG ')
21962        WRITE(ICOUT,9011)
21963 9011   FORMAT('***** AT THE END       OF DPFRT3--')
21964        CALL DPWRST('XXX','BUG ')
21965        WRITE(ICOUT,9012)IBUGA3,IERROR
21966 9012   FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
21967        CALL DPWRST('XXX','BUG ')
21968        WRITE(ICOUT,9015)STATVA,STATCD
21969 9015   FORMAT('STATVA,STATCD = ',2G15.7)
21970        CALL DPWRST('XXX','BUG ')
21971      ENDIF
21972C
21973      RETURN
21974      END
21975      SUBROUTINE DPFRT4(X,N,M,IWRITE,XTEMP,STATVA,STATCD,
21976     1                  ISUBRO,IBUGA3,IERROR)
21977C
21978C     PURPOSE--THIS SUBROUTINE COMPUTES THE FREQUENCY WITHIN A BLOCK
21979C              STATISTIC (AND ALTERNATIVELY THE CDF VALUE).
21980C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
21981C                                (UNSORTED OR SORTED) OBSERVATIONS.
21982C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
21983C                                IN THE VECTOR X.
21984C                     --M      = THE INTEGER NUMBER OF OBSERVATIONS
21985C                                PER BLOCK.
21986C     OUTPUT ARGUMENTS--STATVA = THE SINGLE PRECISION VALUE OF THE
21987C                                COMPUTED STATISTIC.
21988C                     --STATCD = THE SINGLE PRECISION VALUE OF THE
21989C                                COMPUTED CDF OF THE TEST STATISTIC.
21990C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
21991C             TEST STATISTIC.
21992C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
21993C                   OF N FOR THIS SUBROUTINE.
21994C     OTHER DATAPAC   SUBROUTINES NEEDED--DISTIN
21995C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
21996C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
21997C     LANGUAGE--ANSI FORTRAN (1977)
21998C     WRITTEN BY--JAMES J. FILLIBEN
21999C                 STATISTICAL ENGINEERING DIVISION
22000C                 INFORMATION TECHNOLOGY LABORATORY
22001C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
22002C                 GAITHERSBURG, MD 20899-8980
22003C                 PHONE--301-975-2855
22004C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
22005C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
22006C     LANGUAGE--ANSI FORTRAN (1977)
22007C     VERSION NUMBER--2009.2
22008C     ORIGINAL VERSION--FEBRUARY  2009.
22009C
22010C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
22011C
22012      CHARACTER*4 IWRITE
22013      CHARACTER*4 IWRTSV
22014      CHARACTER*4 ISUBRO
22015      CHARACTER*4 IBUGA3
22016      CHARACTER*4 IERROR
22017C
22018      CHARACTER*4 ISUBN1
22019      CHARACTER*4 ISUBN2
22020C
22021C---------------------------------------------------------------------
22022C
22023      DIMENSION X(*)
22024      DIMENSION XTEMP(*)
22025C
22026      DOUBLE PRECISION DRESLT
22027      DOUBLE PRECISION DGAMIP
22028C
22029C---------------------------------------------------------------------
22030C
22031      INCLUDE 'DPCOP2.INC'
22032C
22033C-----START POINT-----------------------------------------------------
22034C
22035      ISUBN1='DPFR'
22036      ISUBN2='T4  '
22037      IERROR='NO'
22038      IWRTSV=IWRITE
22039C
22040      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FRT4')THEN
22041        WRITE(ICOUT,999)
22042  999   FORMAT(1X)
22043        CALL DPWRST('XXX','BUG ')
22044        WRITE(ICOUT,51)
22045   51   FORMAT('***** AT THE BEGINNING OF DPFRT4--')
22046        CALL DPWRST('XXX','BUG ')
22047        WRITE(ICOUT,52)IBUGA3
22048   52   FORMAT('IBUGA3 = ',A4)
22049        CALL DPWRST('XXX','BUG ')
22050        WRITE(ICOUT,53)N,M
22051   53   FORMAT('N,M = ',2I8)
22052        CALL DPWRST('XXX','BUG ')
22053        DO55I=1,N
22054          WRITE(ICOUT,56)I,X(I)
22055   56     FORMAT('I,X(I) = ',I8,G15.7)
22056          CALL DPWRST('XXX','BUG ')
22057   55   CONTINUE
22058      ENDIF
22059C
22060C               **************************************************
22061C               **  COMPUTE FREQUENCY WITHIN A BLOCK STATISTIC  **
22062C               **************************************************
22063C
22064C               ********************************************
22065C               **  STEP 1--                              **
22066C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
22067C               ********************************************
22068C
22069      AN=N
22070C
22071      IF(N.LE.5)THEN
22072        IERROR='YES'
22073        WRITE(ICOUT,999)
22074        CALL DPWRST('XXX','BUG ')
22075        WRITE(ICOUT,111)
22076  111   FORMAT('***** ERROR IN FREQUENCY IN BLOCK STATISTIC--')
22077        CALL DPWRST('XXX','BUG ')
22078        WRITE(ICOUT,112)
22079  112   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS FOR THE ',
22080     1         'RESPONSE')
22081        CALL DPWRST('XXX','BUG ')
22082        WRITE(ICOUT,113)
22083  113   FORMAT('      VARIABLE MUST BE 6 OR LARGER.')
22084        CALL DPWRST('XXX','BUG ')
22085        WRITE(ICOUT,116)
22086  116   FORMAT('      SUCH WAS NOT THE CASE HERE.')
22087        CALL DPWRST('XXX','BUG ')
22088        WRITE(ICOUT,117)N
22089  117   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
22090     1         '.')
22091        CALL DPWRST('XXX','BUG ')
22092        GOTO9000
22093      ENDIF
22094C
22095      STATVA=-99.0
22096      STATCD=-99.0
22097      IWRITE='OFF'
22098C
22099      IWRITE='NO'
22100      CALL DISTIN(X,N,IWRITE,XTEMP,NDIST,IBUGA3,IERROR)
22101C
22102      NBLOCK=N/M
22103      AMNSZ=0.01*REAL(N)
22104C
22105      IF(NBLOCK.GE.100)THEN
22106        WRITE(ICOUT,999)
22107        CALL DPWRST('XXX','BUG ')
22108        WRITE(ICOUT,3010)
22109 3010   FORMAT('***** WARNING IN FREQUENCY IN BLOCK STATISTIC--')
22110        CALL DPWRST('XXX','BUG ')
22111        WRITE(ICOUT,3011)
22112 3011   FORMAT('      THE NUMBER OF BLOCKS IS GREATER')
22113        CALL DPWRST('XXX','BUG ')
22114        WRITE(ICOUT,3012)
22115 3012   FORMAT('      THAN THE RECOMMENDED MAXIMUM OF 100.')
22116        CALL DPWRST('XXX','BUG ')
22117        WRITE(ICOUT,3013)N
22118 3013   FORMAT('      SAMPLE SIZE       = ',I8)
22119        CALL DPWRST('XXX','BUG ')
22120        WRITE(ICOUT,3014)M
22121 3014   FORMAT('      BLOCK SIZE        = ',I8)
22122        CALL DPWRST('XXX','BUG ')
22123        WRITE(ICOUT,3015)NBLOCK
22124 3015   FORMAT('      NUMBER OF BLOCKS  = ',I8)
22125        CALL DPWRST('XXX','BUG ')
22126        WRITE(ICOUT,999)
22127        CALL DPWRST('XXX','BUG ')
22128      ENDIF
22129C
22130      IF(M.LE.INT(AMNSZ))THEN
22131        WRITE(ICOUT,999)
22132        CALL DPWRST('XXX','BUG ')
22133        WRITE(ICOUT,3010)
22134        CALL DPWRST('XXX','BUG ')
22135        WRITE(ICOUT,3021)
22136 3021   FORMAT('      THE BLOCK SIZE IS LESS THAN THE')
22137        CALL DPWRST('XXX','BUG ')
22138        WRITE(ICOUT,3022)INT(AMNSZ)
22139 3022   FORMAT('      RECOMMENDED MINIMUM OF ',I8)
22140        CALL DPWRST('XXX','BUG ')
22141        WRITE(ICOUT,3023)N
22142 3023   FORMAT('      SAMPLE SIZE                     = ',I8)
22143        CALL DPWRST('XXX','BUG ')
22144        WRITE(ICOUT,3024)M
22145 3024   FORMAT('      BLOCK SIZE                      = ',I8)
22146        CALL DPWRST('XXX','BUG ')
22147        WRITE(ICOUT,3025)NBLOCK
22148 3025   FORMAT('      NUMBER OF BLOCKS                = ',I8)
22149        CALL DPWRST('XXX','BUG ')
22150        WRITE(ICOUT,3026)INT(AMNSZ)
22151 3026   FORMAT('      RECOMMENDED MINIMUM BLOCK SIZE  = ',I8)
22152        CALL DPWRST('XXX','BUG ')
22153        WRITE(ICOUT,999)
22154        CALL DPWRST('XXX','BUG ')
22155      ENDIF
22156C
22157      IF(M.GT.N)THEN
22158        WRITE(ICOUT,999)
22159        CALL DPWRST('XXX','BUG ')
22160        WRITE(ICOUT,111)
22161        CALL DPWRST('XXX','BUG ')
22162        WRITE(ICOUT,3031)
22163 3031   FORMAT('      THE BLOCK SIZE IS GREATER THAN THE SAMPLE ',
22164     1         'SIZE.')
22165        CALL DPWRST('XXX','BUG ')
22166        WRITE(ICOUT,3033)N
22167 3033   FORMAT('      SAMPLE SIZE                     = ',I8)
22168        CALL DPWRST('XXX','BUG ')
22169        WRITE(ICOUT,3034)M
22170 3034   FORMAT('      BLOCK SIZE                      = ',I8)
22171        CALL DPWRST('XXX','BUG ')
22172        WRITE(ICOUT,3035)NBLOCK
22173 3035   FORMAT('      NUMBER OF BLOCKS                = ',I8)
22174        CALL DPWRST('XXX','BUG ')
22175        WRITE(ICOUT,3036)INT(AMNSZ)
22176 3036   FORMAT('      RECOMMENDED MINIMUM BLOCK SIZE  = ',I8)
22177        CALL DPWRST('XXX','BUG ')
22178        WRITE(ICOUT,999)
22179        CALL DPWRST('XXX','BUG ')
22180        IERROR='YES'
22181        GOTO9000
22182      ENDIF
22183C
22184      IF(NDIST.NE.2)THEN
22185        WRITE(ICOUT,999)
22186        CALL DPWRST('XXX','BUG ')
22187        WRITE(ICOUT,111)
22188        CALL DPWRST('XXX','BUG ')
22189        WRITE(ICOUT,3041)NDIST
22190 3041   FORMAT('      THE RESPONSE VARIBLE CONTAINS ',I8)
22191        CALL DPWRST('XXX','BUG ')
22192        WRITE(ICOUT,3043)
22193 3043   FORMAT('      DISTINCT VALUES.')
22194        CALL DPWRST('XXX','BUG ')
22195        WRITE(ICOUT,999)
22196        CALL DPWRST('XXX','BUG ')
22197        IERROR='YES'
22198        GOTO9000
22199      ENDIF
22200C
22201      ALOW=MIN(XTEMP(1),XTEMP(2))
22202      AHIGH=MAX(XTEMP(1),XTEMP(2))
22203      AM=REAL(M)
22204C
22205      SUM=0.0
22206      DO3110K=1,NBLOCK
22207        ISTRT=(K-1)*M+1
22208        ISTOP=K*M
22209        AONES=0
22210        DO3120I=ISTRT,ISTOP
22211          IF(X(I).EQ.AHIGH)AONES=AONES+1.0
22212 3120   CONTINUE
22213        API=AONES/AM
22214        SUM=SUM + (API-0.5)**2
22215 3110 CONTINUE
22216C
22217      STATVA=4.0*AM*SUM
22218      DRESLT=1.0D0 - DGAMIP(DBLE(NBLOCK)/2.0D0,DBLE(STATVA)/2.0D0)
22219      STATCD=REAL(DRESLT)
22220C
22221C               *******************************
22222C               **  STEP 3--                 **
22223C               **  WRITE OUT A LINE         **
22224C               **  OF SUMMARY INFORMATION.  **
22225C               *******************************
22226C
22227      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
22228        WRITE(ICOUT,999)
22229        CALL DPWRST('XXX','BUG ')
22230        WRITE(ICOUT,811)N,STATVA
22231  811   FORMAT('THE VALUE OF THE FREQUENCY STATISTIC OF THE ',I8,
22232     1         ' OBSERVATIONS = ',G15.7)
22233        CALL DPWRST('XXX','BUG ')
22234      ENDIF
22235C
22236C               *****************
22237C               **  STEP 90--  **
22238C               **  EXIT.      **
22239C               *****************
22240C
22241 9000 CONTINUE
22242C
22243      IWRITE=IWRTSV
22244C
22245      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FRT4')THEN
22246        WRITE(ICOUT,999)
22247        CALL DPWRST('XXX','BUG ')
22248        WRITE(ICOUT,9011)
22249 9011   FORMAT('***** AT THE END       OF DPFRT4--')
22250        CALL DPWRST('XXX','BUG ')
22251        WRITE(ICOUT,9012)IBUGA3,IERROR
22252 9012   FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
22253        CALL DPWRST('XXX','BUG ')
22254        WRITE(ICOUT,9015)STATVA,STATCD
22255 9015   FORMAT('STATVA,STATCD = ',2G15.7)
22256        CALL DPWRST('XXX','BUG ')
22257      ENDIF
22258C
22259      RETURN
22260      END
22261      SUBROUTINE DPFRT5(STATVA,STATCD,PVAL,
22262     1                  CUT0,CUT50,CUT75,CUT90,CUT95,
22263     1                  CUT975,CUT99,CUT999,
22264     1                  IFLAGU,IFRST,ILAST,
22265     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
22266C
22267C     PURPOSE--UTILITY ROUTINE USED BY DPFRTE.  THIS ROUTINE
22268C              UPDATES THE PARAMETERS "STATVAL", "STATCDF", AND
22269C              "PVALUE" AND VARIOUS CUTOFF POINTS AFTER A FREQUENCY TEST.
22270C
22271C              THIS ROUTINE MAY ALSO BE CALLED BY OTHER ROUTINES AS
22272C              WELL.
22273C
22274C     WRITTEN BY--ALAN HECKERT
22275C                 STATISTICAL ENGINEERING DIVISION
22276C                 INFORMATION TECHNOLOGY LABORAOTRY
22277C                 NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY
22278C                 GAITHERSBURG, MD 20899-8980
22279C                 PHONE--301-975-2899
22280C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
22281C           OF THE NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY.
22282C     LANGUAGE--ANSI FORTRAN (1977)
22283C     VERSION NUMBER--2011/3
22284C     ORIGINAL VERSION--MARCH     2011.
22285C
22286C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
22287C
22288      CHARACTER*4 IFLAGU
22289      CHARACTER*4 IBUGA2
22290      CHARACTER*4 IBUGA3
22291      CHARACTER*4 ISUBRO
22292      CHARACTER*4 IERROR
22293C
22294      LOGICAL IFRST
22295      LOGICAL ILAST
22296C
22297      CHARACTER*4 IH
22298      CHARACTER*4 IH2
22299      CHARACTER*4 ISUBN0
22300      CHARACTER*4 ISUBN1
22301      CHARACTER*4 ISUBN2
22302      CHARACTER*4 ISTEPN
22303      CHARACTER*4 IOP
22304C
22305      SAVE IOUNI1
22306C
22307C-----COMMON VARIABLES (GENERAL)--------------------------------------
22308C
22309      INCLUDE 'DPCOPA.INC'
22310      INCLUDE 'DPCOHK.INC'
22311      INCLUDE 'DPCOHO.INC'
22312      INCLUDE 'DPCOP2.INC'
22313C
22314C-----START POINT-----------------------------------------------------
22315C
22316      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FRT5')THEN
22317        ISTEPN='1'
22318        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22319        WRITE(ICOUT,999)
22320  999   FORMAT(1X)
22321        CALL DPWRST('XXX','BUG ')
22322        WRITE(ICOUT,51)
22323   51   FORMAT('***** AT THE BEGINNING OF DPFRT5--')
22324        CALL DPWRST('XXX','BUG ')
22325        WRITE(ICOUT,53)STATVA,STATCD,PVAL
22326   53   FORMAT('STATVA,STATCD,PVAL = ',3G15.7)
22327        CALL DPWRST('XXX','BUG ')
22328        WRITE(ICOUT,54)CUT0,CUT50,CUT75,CUT90
22329   54   FORMAT('CUT0,CUT50,CUT75,CUT90 = ',4G15.7)
22330        CALL DPWRST('XXX','BUG ')
22331        WRITE(ICOUT,55)CUT95,CUT975,CUT99,CUT999
22332   55   FORMAT('CUT95,CUT975,CUT99 = ',4G15.7)
22333        CALL DPWRST('XXX','BUG ')
22334      ENDIF
22335C
22336      IF(IFLAGU.EQ.'FILE')THEN
22337C
22338        IF(IFRST)THEN
22339          IOP='OPEN'
22340          IFLAG1=1
22341          IFLAG2=0
22342          IFLAG3=0
22343          IFLAG4=0
22344          IFLAG5=0
22345          CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
22346     1                IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
22347     1                IBUGA3,ISUBRO,IERROR)
22348          IF(IERROR.EQ.'YES')GOTO9000
22349C
22350          WRITE(IOUNI1,295)
22351  295     FORMAT(11X,'STATVAL',8X,'STATCDF',8X,'PVALUE',
22352     1           7X,'CUTOFF0',7X,'CUTOFF50',7X,'CUTOFF75',
22353     1           7X,'CUTOFF90',7X,'CUTOFF95',7X,'CUTOF975',
22354     1           7X,'CUTOFF99',7X,'CUTOF999')
22355        ENDIF
22356        WRITE(IOUNI1,299)STATVA,STATCD,PVAL,CUT0,CUT50,CUT75,
22357     1                   CUT90,CUT95,CUT975,CUT99,CUT999
22358  299   FORMAT(11E15.7)
22359      ELSEIF(IFLAGU.EQ.'ON')THEN
22360        IF(STATVA.NE.CPUMIN)THEN
22361          IH='STAT'
22362          IH2='VAL '
22363          VALUE0=STATVA
22364          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
22365     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
22366     1                IANS,IWIDTH,IBUGA3,IERROR)
22367        ENDIF
22368C
22369        IF(STATCD.NE.CPUMIN)THEN
22370          IH='STAT'
22371          IH2='CDF '
22372          VALUE0=STATCD
22373          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
22374     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
22375     1                IANS,IWIDTH,IBUGA3,IERROR)
22376        ENDIF
22377C
22378        IF(PVAL.NE.CPUMIN)THEN
22379          IH='PVAL'
22380          IH2='UE  '
22381          VALUE0=PVAL
22382          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
22383     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
22384     1                IANS,IWIDTH,IBUGA3,IERROR)
22385        ENDIF
22386C
22387        IF(CUT0.NE.CPUMIN)THEN
22388          IH='CUTO'
22389          IH2='FF0'
22390          VALUE0=CUT0
22391          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
22392     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
22393     1                IANS,IWIDTH,IBUGA3,IERROR)
22394        ENDIF
22395C
22396        IF(CUT50.NE.CPUMIN)THEN
22397          IH='CUTO'
22398          IH2='FF50'
22399          VALUE0=CUT50
22400          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
22401     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
22402     1                IANS,IWIDTH,IBUGA3,IERROR)
22403        ENDIF
22404C
22405        IF(CUT75.NE.CPUMIN)THEN
22406          IH='CUTO'
22407          IH2='FF75'
22408          VALUE0=CUT75
22409          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
22410     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
22411     1                IANS,IWIDTH,IBUGA3,IERROR)
22412        ENDIF
22413C
22414        IF(CUT90.NE.CPUMIN)THEN
22415          IH='CUTO'
22416          IH2='FF90'
22417          VALUE0=CUT90
22418          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
22419     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
22420     1                IANS,IWIDTH,IBUGA3,IERROR)
22421        ENDIF
22422C
22423        IF(CUT95.NE.CPUMIN)THEN
22424          IH='CUTO'
22425          IH2='FF95'
22426          VALUE0=CUT95
22427          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
22428     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
22429     1                IANS,IWIDTH,IBUGA3,IERROR)
22430        ENDIF
22431C
22432        IF(CUT975.NE.CPUMIN)THEN
22433          IH='CUTO'
22434          IH2='F975'
22435          VALUE0=CUT975
22436          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
22437     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
22438     1                IANS,IWIDTH,IBUGA3,IERROR)
22439        ENDIF
22440C
22441        IF(CUT99.NE.CPUMIN)THEN
22442          IH='CUTO'
22443          IH2='FF99'
22444          VALUE0=CUT99
22445          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
22446     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
22447     1                IANS,IWIDTH,IBUGA3,IERROR)
22448        ENDIF
22449C
22450        IF(CUT999.NE.CPUMIN)THEN
22451          IH='CUTO'
22452          IH2='F999'
22453          VALUE0=CUT999
22454          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
22455     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
22456     1                IANS,IWIDTH,IBUGA3,IERROR)
22457        ENDIF
22458C
22459      ENDIF
22460C
22461      IF(IFLAGU.EQ.'FILE')THEN
22462        IF(ILAST)THEN
22463          IOP='CLOS'
22464          IFLAG1=1
22465          IFLAG2=0
22466          IFLAG3=0
22467          IFLAG4=0
22468          IFLAG5=0
22469          CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
22470     1                IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
22471     1                IBUGA3,ISUBRO,IERROR)
22472C
22473          IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FRT5')THEN
22474            ISTEPN='3A'
22475            CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22476            WRITE(ICOUT,999)
22477            CALL DPWRST('XXX','BUG ')
22478            WRITE(ICOUT,301)IERROR,IOUNI1
22479  301       FORMAT('AFTER CALL DPCLFI, IERROR,IOUNI1 = ',A4,2X,I5)
22480            CALL DPWRST('XXX','BUG ')
22481          ENDIF
22482C
22483          IF(IERROR.EQ.'YES')GOTO9000
22484        ENDIF
22485      ENDIF
22486C
22487C               *****************
22488C               **  STEP 90--  **
22489C               **  EXIT       **
22490C               *****************
22491C
22492 9000 CONTINUE
22493C
22494      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FRT5')THEN
22495        WRITE(ICOUT,999)
22496        CALL DPWRST('XXX','BUG ')
22497        WRITE(ICOUT,9011)
22498 9011   FORMAT('***** AT THE END OF DPFRT5--')
22499        CALL DPWRST('XXX','BUG ')
22500      ENDIF
22501C
22502      RETURN
22503      END
22504      SUBROUTINE DPFRTH(ICOM,IHARG,ARG,NUMARG,
22505     1PDEFTH,
22506     1PFRATH,
22507     1IFOUND,IERROR)
22508C
22509C     PURPOSE--DEFINE THE FRAME THICKNESS
22510C              CURRENTLY ALL 4 FRAME LINES MUST
22511C              BE SET TO THE SAME THICKNESS.
22512C              THE FRAME THICKNESS SWITCHES FOR THE FRAME
22513C              IS CONTAINED IN THE VARIABLE
22514C              PFRATH
22515C     INPUT  ARGUMENTS--ICOM
22516C                     --IHARG  (A  HOLLERITH VECTOR)
22517C                     --NUMARG
22518C                     --PDEFCO
22519C     OUTPUT ARGUMENTS--PFRATH (A REAL VARIABLE)
22520C                     --IFOUND ('YES' OR 'NO' )
22521C                     --IERROR ('YES' OR 'NO' )
22522C     WRITTEN BY--ALAN HECKERT
22523C                 COMPUTER SERVICES DIVISION
22524C                 INFORMATION TECHNOLOGY LABORATORY
22525C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
22526C                 GAITHERSBURG, MD 20899-8980
22527C                 PHONE--301-975-2899
22528C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
22529C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
22530C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
22531C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
22532C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
22533C     LANGUAGE--ANSI FORTRAN (1977)
22534C     VERSION NUMBER--82/7
22535C     ORIGINAL VERSION--OCTOBER   1980.
22536C     UPDATED         --MAY       1982.
22537C
22538C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
22539C
22540      CHARACTER*4 ICOM
22541      CHARACTER*4 IHARG
22542C
22543      CHARACTER*4 IFOUND
22544      CHARACTER*4 IERROR
22545C
22546      REAL        PHOLD
22547C
22548C---------------------------------------------------------------------
22549C
22550      DIMENSION IHARG(*)
22551      DIMENSION ARG(*)
22552C
22553C---------------------------------------------------------------------
22554C
22555      INCLUDE 'DPCOP2.INC'
22556C
22557C-----START POINT-----------------------------------------------------
22558C
22559      IFOUND='NO'
22560      IERROR='NO'
22561C
22562      IF(NUMARG.LE.0)GOTO1900
22563      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'THIC')GOTO1090
22564      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MARK'.AND.
22565     1IHARG(2).EQ.'THIC')GOTO1090
22566      GOTO1900
22567 1090 CONTINUE
22568C
22569C               *****************************************************
22570C               **  TREAT THE CASE WHEN                            **
22571C               **  BOTH HORIZONTAL FRAMES    ARE TO BE CHANGED    **
22572C               *****************************************************
22573C
22574      IF(ICOM.EQ.'XFRA')GOTO1100
22575      GOTO1199
22576C
22577 1100 CONTINUE
22578      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
22579      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
22580      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
22581      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
22582      IF(IHARG(NUMARG).EQ.'THIC')GOTO1150
22583      GOTO1160
22584C
22585 1150 CONTINUE
22586      PHOLD=PDEFTH
22587      GOTO1180
22588C
22589 1160 CONTINUE
22590      PHOLD=ARG(NUMARG)
22591      GOTO1180
22592C
22593 1180 CONTINUE
22594      IFOUND='YES'
22595      PFRATH=PHOLD
22596C
22597      IF(IFEEDB.EQ.'OFF')GOTO1189
22598      WRITE(ICOUT,999)
22599  999 FORMAT(1X)
22600      CALL DPWRST('XXX','BUG ')
22601      WRITE(ICOUT,1181)
22602 1181 FORMAT('THE FRAME THICKNESS (FOR ALL FRAME LINES ')
22603      CALL DPWRST('XXX','BUG ')
22604      WRITE(ICOUT,1182)PHOLD
22605 1182 FORMAT('HAS JUST BEEN SET TO ',E15.7)
22606      CALL DPWRST('XXX','BUG ')
22607 1189 CONTINUE
22608      GOTO1900
22609C
22610 1199 CONTINUE
22611C
22612C               **************************************************************
22613C               **  TREAT THE CASE WHEN                                     **
22614C               **  ONLY THE BOTTOM HORIZONTAL FRAME IS      TO BE CHANGED  **
22615C               **************************************************************
22616C
22617      IF(ICOM.EQ.'X1FR')GOTO1200
22618      GOTO1299
22619C
22620 1200 CONTINUE
22621      IF(IHARG(NUMARG).EQ.'ON')GOTO1250
22622      IF(IHARG(NUMARG).EQ.'OFF')GOTO1250
22623      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250
22624      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250
22625      IF(IHARG(NUMARG).EQ.'THIC')GOTO1250
22626      GOTO1260
22627C
22628 1250 CONTINUE
22629      PHOLD=PDEFTH
22630      GOTO1280
22631C
22632 1260 CONTINUE
22633      PHOLD=ARG(NUMARG)
22634      GOTO1280
22635C
22636 1280 CONTINUE
22637      IFOUND='YES'
22638      PFRATH=PHOLD
22639C
22640      IF(IFEEDB.EQ.'OFF')GOTO1289
22641      WRITE(ICOUT,999)
22642      CALL DPWRST('XXX','BUG ')
22643      WRITE(ICOUT,1281)
22644 1281 FORMAT('THE FRAME THICKNESS (FOR ALL FRAME LINES) ')
22645      CALL DPWRST('XXX','BUG ')
22646      WRITE(ICOUT,1282)PHOLD
22647 1282 FORMAT('HAS JUST BEEN SET TO ',E15.7)
22648      CALL DPWRST('XXX','BUG ')
22649 1289 CONTINUE
22650      GOTO1900
22651C
22652 1299 CONTINUE
22653C
22654C               **************************************************************
22655C               **  TREAT THE CASE WHEN                                     **
22656C               **  ONLY THE TOP    HORIZONTAL FRAME IS      TO BE CHANGED  **
22657C               **************************************************************
22658C
22659      IF(ICOM.EQ.'X2FR')GOTO1300
22660      GOTO1399
22661C
22662 1300 CONTINUE
22663      IF(IHARG(NUMARG).EQ.'ON')GOTO1350
22664      IF(IHARG(NUMARG).EQ.'OFF')GOTO1350
22665      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350
22666      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350
22667      IF(IHARG(NUMARG).EQ.'THIC')GOTO1350
22668      GOTO1360
22669C
22670 1350 CONTINUE
22671      PHOLD=PDEFTH
22672      GOTO1380
22673C
22674 1360 CONTINUE
22675      PHOLD=ARG(NUMARG)
22676      GOTO1380
22677C
22678 1380 CONTINUE
22679      IFOUND='YES'
22680      PFRATH=PHOLD
22681C
22682      IF(IFEEDB.EQ.'OFF')GOTO1389
22683      WRITE(ICOUT,999)
22684      CALL DPWRST('XXX','BUG ')
22685      WRITE(ICOUT,1381)
22686 1381 FORMAT('THE FRAME THICKNESS (FOR ALL FRAME LINES) ')
22687      CALL DPWRST('XXX','BUG ')
22688      WRITE(ICOUT,1382)PHOLD
22689 1382 FORMAT('HAS JUST BEEN SET TO ',E15.7)
22690      CALL DPWRST('XXX','BUG ')
22691 1389 CONTINUE
22692      GOTO1900
22693C
22694 1399 CONTINUE
22695C
22696C               *****************************************************
22697C               **  TREAT THE CASE WHEN                            **
22698C               **  BOTH VERTICAL   FRAMES    ARE TO BE CHANGED    **
22699C               *****************************************************
22700C
22701      IF(ICOM.EQ.'YFRA')GOTO1400
22702      GOTO1499
22703C
22704 1400 CONTINUE
22705      IF(IHARG(NUMARG).EQ.'ON')GOTO1450
22706      IF(IHARG(NUMARG).EQ.'OFF')GOTO1450
22707      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1450
22708      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1450
22709      IF(IHARG(NUMARG).EQ.'THIC')GOTO1450
22710      GOTO1460
22711C
22712 1450 CONTINUE
22713      PHOLD=PDEFTH
22714      GOTO1480
22715C
22716 1460 CONTINUE
22717      PHOLD=ARG(NUMARG)
22718      GOTO1480
22719C
22720 1480 CONTINUE
22721      IFOUND='YES'
22722      PFRATH=PHOLD
22723C
22724      IF(IFEEDB.EQ.'OFF')GOTO1489
22725      WRITE(ICOUT,999)
22726      CALL DPWRST('XXX','BUG ')
22727      WRITE(ICOUT,1481)
22728 1481 FORMAT('THE FRAME THICKNESS (FOR ALL FRAME LINES)')
22729      CALL DPWRST('XXX','BUG ')
22730      WRITE(ICOUT,1482)PHOLD
22731 1482 FORMAT('HAS JUST BEEN SET TO ',E15.7)
22732      CALL DPWRST('XXX','BUG ')
22733 1489 CONTINUE
22734      GOTO1900
22735C
22736 1499 CONTINUE
22737C
22738C               **************************************************************
22739C               **  TREAT THE CASE WHEN                                     **
22740C               **  ONLY THE LEFT   VERTICAL   FRAME IS      TO BE CHANGED  **
22741C               **************************************************************
22742C
22743      IF(ICOM.EQ.'Y1FR')GOTO1500
22744      GOTO1599
22745C
22746 1500 CONTINUE
22747      IF(IHARG(NUMARG).EQ.'ON')GOTO1550
22748      IF(IHARG(NUMARG).EQ.'OFF')GOTO1550
22749      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1550
22750      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1550
22751      IF(IHARG(NUMARG).EQ.'THIC')GOTO1550
22752      GOTO1560
22753C
22754 1550 CONTINUE
22755      PHOLD=PDEFTH
22756      GOTO1580
22757C
22758 1560 CONTINUE
22759      PHOLD=ARG(NUMARG)
22760      GOTO1580
22761C
22762 1580 CONTINUE
22763      IFOUND='YES'
22764      PFRATH=PHOLD
22765C
22766      IF(IFEEDB.EQ.'OFF')GOTO1589
22767      WRITE(ICOUT,999)
22768      CALL DPWRST('XXX','BUG ')
22769      WRITE(ICOUT,1581)
22770 1581 FORMAT('THE FRAME THICKNESS (FOR ALL FRAME LINES)')
22771      CALL DPWRST('XXX','BUG ')
22772      WRITE(ICOUT,1582)PHOLD
22773 1582 FORMAT('HAS JUST BEEN SET TO ',E15.7)
22774      CALL DPWRST('XXX','BUG ')
22775 1589 CONTINUE
22776      GOTO1900
22777C
22778 1599 CONTINUE
22779C
22780C               **************************************************************
22781C               **  TREAT THE CASE WHEN                                     **
22782C               **  ONLY THE RIGHT  VERTICAL   FRAME IS      TO BE CHANGED  **
22783C               **************************************************************
22784C
22785      IF(ICOM.EQ.'Y2FR')GOTO1600
22786      GOTO1699
22787C
22788 1600 CONTINUE
22789      IF(IHARG(NUMARG).EQ.'ON')GOTO1650
22790      IF(IHARG(NUMARG).EQ.'OFF')GOTO1650
22791      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1650
22792      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1650
22793      IF(IHARG(NUMARG).EQ.'THIC')GOTO1650
22794      GOTO1660
22795C
22796 1650 CONTINUE
22797      PHOLD=PDEFTH
22798      GOTO1680
22799C
22800 1660 CONTINUE
22801      PHOLD=ARG(NUMARG)
22802      GOTO1680
22803C
22804 1680 CONTINUE
22805      IFOUND='YES'
22806      PFRATH=PHOLD
22807C
22808      IF(IFEEDB.EQ.'OFF')GOTO1689
22809      WRITE(ICOUT,999)
22810      CALL DPWRST('XXX','BUG ')
22811      WRITE(ICOUT,1681)
22812 1681 FORMAT('THE FRAME THICKNESS (FOR ALL FRAME LINES)')
22813      CALL DPWRST('XXX','BUG ')
22814      WRITE(ICOUT,1682)PHOLD
22815 1682 FORMAT('HAS JUST BEEN SET TO ',E15.7)
22816      CALL DPWRST('XXX','BUG ')
22817 1689 CONTINUE
22818      GOTO1900
22819C
22820 1699 CONTINUE
22821C
22822C               *****************************************************
22823C               **  TREAT THE CASE WHEN                            **
22824C               **  ALL 4 FRAME FRAME LINES ARE TO BE CHANGED      **
22825C               *****************************************************
22826C
22827      IF(ICOM.EQ.'FRAM')GOTO1700
22828      IF(ICOM.EQ.'XYFR')GOTO1700
22829      IF(ICOM.EQ.'YXFR')GOTO1700
22830      GOTO1799
22831C
22832 1700 CONTINUE
22833      IF(IHARG(NUMARG).EQ.'ON')GOTO1750
22834      IF(IHARG(NUMARG).EQ.'OFF')GOTO1750
22835      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1750
22836      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1750
22837      IF(IHARG(NUMARG).EQ.'THIC')GOTO1750
22838      GOTO1760
22839C
22840 1750 CONTINUE
22841      PHOLD=PDEFTH
22842      GOTO1780
22843C
22844 1760 CONTINUE
22845      PHOLD=ARG(NUMARG)
22846      GOTO1780
22847C
22848 1780 CONTINUE
22849      IFOUND='YES'
22850      PFRATH=PHOLD
22851C
22852      IF(IFEEDB.EQ.'OFF')GOTO1789
22853      WRITE(ICOUT,999)
22854      CALL DPWRST('XXX','BUG ')
22855      WRITE(ICOUT,1781)
22856 1781 FORMAT('THE FRAME THICKNESS (FOR ALL 4 ',
22857     1'FRAME LINES)')
22858      CALL DPWRST('XXX','BUG ')
22859      WRITE(ICOUT,1782)PHOLD
22860 1782 FORMAT('HAS JUST BEEN SET TO ',E15.7)
22861      CALL DPWRST('XXX','BUG ')
22862 1789 CONTINUE
22863      GOTO1900
22864C
22865 1799 CONTINUE
22866C
22867 1900 CONTINUE
22868      RETURN
22869      END
22870      SUBROUTINE DPFRTY(IHARG,NUMARG,
22871     1IDEFFT,
22872     1IFRATY,
22873     1IBUGS2,IFOUND,IERROR)
22874C
22875C     PURPOSE--DEFINE THE FRACTAL TYPE
22876C              CAN BE <WHITHERS/ANGLE/BARNSLEY> (DEFAULT IS BARNSLEY)
22877C              THIS SWITCH CONTROLS HOW THE ARGUMENTS TO THE
22878C              FRACTAL PLOT COMMAND ARE INTERPERTED.
22879C
22880C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
22881C                     --NUMARG (AN INTEGER VARIABLE)
22882C                     --IDEFFT (A  CHARACTER VARIABLE)
22883C                     --IBUGS2 (A  CHARACTER VARIABLE)
22884C     OUTPUT ARGUMENTS--IFRATY (A CHARACTER VARIABLE)
22885C                     --IFOUND ('YES' OR 'NO' )
22886C                     --IERROR ('YES' OR 'NO' )
22887C     WRITTEN BY--JAMES J. FILLIBEN
22888C                 STATISTICAL ENGINEERING DIVISION
22889C                 INFORMATION TECHNOLOGY LABORATORY
22890C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
22891C                 GAITHERSBURG, MD 20899-8980
22892C                 PHONE--301-975-2855
22893C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
22894C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
22895C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
22896C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
22897C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
22898C     LANGUAGE--ANSI FORTRAN (1977)
22899C     VERSION NUMBER--93/7
22900C     ORIGINAL VERSION--JULY     1993.
22901C
22902C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
22903C
22904      CHARACTER*4 IHARG
22905      CHARACTER*4 IDEFFT
22906      CHARACTER*4 IFRATY
22907      CHARACTER*4 IBUGS2
22908      CHARACTER*4 IFOUND
22909      CHARACTER*4 IERROR
22910C
22911      CHARACTER*4 IHOLD
22912C
22913C---------------------------------------------------------------------
22914C
22915      DIMENSION IHARG(*)
22916C
22917C---------------------------------------------------------------------
22918C
22919      INCLUDE 'DPCOP2.INC'
22920C
22921C-----START POINT-----------------------------------------------------
22922C
22923      IF(IBUGS2.EQ.'OFF')GOTO90
22924      WRITE(ICOUT,999)
22925  999 FORMAT(1X)
22926      CALL DPWRST('XXX','BUG ')
22927      WRITE(ICOUT,51)
22928   51 FORMAT('***** AT THE BEGINNING OF DPFRTY--')
22929      CALL DPWRST('XXX','BUG ')
22930      WRITE(ICOUT,53)IDEFFT
22931   53 FORMAT('IDEFFT = ',A4)
22932      CALL DPWRST('XXX','BUG ')
22933      WRITE(ICOUT,54)NUMARG
22934   54 FORMAT('NUMARG = ',I8)
22935      CALL DPWRST('XXX','BUG ')
22936      DO55I=1,NUMARG
22937      WRITE(ICOUT,56)I,IHARG(I)
22938   56 FORMAT('I,IHARG(I) = ',I8,2X,A4)
22939      CALL DPWRST('XXX','BUG ')
22940   55 CONTINUE
22941   90 CONTINUE
22942C
22943      IFOUND='NO'
22944      IERROR='NO'
22945C
22946      IF(NUMARG.LE.1)GOTO1150
22947      IF(NUMARG.GT.2)GOTO9000
22948C
22949      IF(IHARG(2).EQ.'AUTO')GOTO1150
22950      IF(IHARG(2).EQ.'DEFA')GOTO1150
22951      GOTO1160
22952C
22953 1150 CONTINUE
22954      IHOLD=IDEFFT
22955      GOTO1180
22956C
22957 1160 CONTINUE
22958      IHOLD=IHARG(2)
22959      IF(IHOLD.EQ.'BARN')GOTO1180
22960      IF(IHOLD.EQ.'WHIT')GOTO1180
22961      IF(IHOLD.EQ.'ROTA')IHOLD='ANGL'
22962      IF(IHOLD.EQ.'ANGL')GOTO1180
22963      GOTO1170
22964C
22965 1170 CONTINUE
22966      IERROR='YES'
22967      IFOUND='YES'
22968      WRITE(ICOUT,1171)IHOLD
22969 1171 FORMAT('THE FRACTAL TYPE SWITCH ',A4,' IS NOT RECOGNIZED')
22970      CALL DPWRST('XXX','BUG ')
22971      WRITE(ICOUT,1172)
22972 1172 FORMAT('IT SHOLUD BE: BARNSLEY, WHITHERS, OR ANGLE')
22973      CALL DPWRST('XXX','BUG ')
22974      GOTO9000
22975C
22976 1180 CONTINUE
22977      IFOUND='YES'
22978      IFRATY=IHOLD
22979C
22980      IF(IFEEDB.EQ.'OFF')GOTO1189
22981      WRITE(ICOUT,999)
22982      CALL DPWRST('XXX','BUG ')
22983      WRITE(ICOUT,1181)IFRATY
22984 1181 FORMAT('THE FRACTAL TYPE SWITCH HAS JUST BEEN SET TO ',A4)
22985      CALL DPWRST('XXX','BUG ')
22986 1189 CONTINUE
22987      GOTO9000
22988C
22989 9000 CONTINUE
22990      IF(IBUGS2.EQ.'OFF')GOTO9090
22991      WRITE(ICOUT,999)
22992      CALL DPWRST('XXX','BUG ')
22993      WRITE(ICOUT,9011)
22994 9011 FORMAT('***** AT THE END       OF DPFRTY')
22995      CALL DPWRST('XXX','BUG ')
22996      WRITE(ICOUT,9012)IBUGS2,IFOUND,IERROR
22997 9012 FORMAT('IBUGS2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
22998      CALL DPWRST('XXX','BUG ')
22999      WRITE(ICOUT,9013)IDEFFT,IFRATY
23000 9013 FORMAT('IDEFFT,IFRATY = ',A4,2X,A4)
23001      CALL DPWRST('XXX','BUG ')
23002 9090 CONTINUE
23003C
23004      RETURN
23005      END
23006      SUBROUTINE DPFTES(MAXNXT,ICAPSW,IFORSW,
23007     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
23008C
23009C     PURPOSE--CARRY OUT A TWO-SAMPLE F-TEST
23010C     EXAMPLE--F TEST Y1 Y2
23011C     WRITTEN BY--JAMES J. FILLIBEN
23012C                 STATISTICAL ENGINEERING DIVISION
23013C                 INFORMATION TECHNOLOGY LABORATORY
23014C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
23015C                 GAITHERSBURG, MD 20899-8980
23016C                 PHONE--301-975-2855
23017C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
23018C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
23019C     LANGUAGE--ANSI FORTRAN (1977)
23020C     VERSION NUMBER--82/7
23021C     ORIGINAL VERSION--JULY      1984.
23022C     UPDATED         --FEBRUARY  1994. ADD COMMENTS ABOVE
23023C     UPDATED         --DECEMBER  1994. COPY F TEST PARAMETERS
23024C     UPDATED         --JANUARY   2004. SUPPORT FOR HTML, LATEX
23025C     UPDATED         --MARCH     2011. USE DPPARS AND DPPAR3
23026C     UPDATED         --MARCH     2011. IF MORE THAN 2 VARIABLES
23027C                                       SPECIFIED, PERFORM ALL
23028C                                       PAIRWISE TESTS
23029C
23030C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
23031C
23032      CHARACTER*4 ICAPSW
23033      CHARACTER*4 IFORSW
23034      CHARACTER*4 IBUGA2
23035      CHARACTER*4 IBUGA3
23036      CHARACTER*4 IBUGQ
23037      CHARACTER*4 ISUBRO
23038      CHARACTER*4 IFOUND
23039      CHARACTER*4 IERROR
23040C
23041      CHARACTER*4 ISUBN1
23042      CHARACTER*4 ISUBN2
23043      CHARACTER*4 ISTEPN
23044C
23045      CHARACTER*4 ICASE
23046      CHARACTER*4 IVARID
23047      CHARACTER*4 IVARI2
23048      CHARACTER*4 IVARI3
23049      CHARACTER*4 IVARI4
23050      CHARACTER*40 INAME
23051      PARAMETER (MAXSPN=30)
23052      CHARACTER*4 IVARN1(MAXSPN)
23053      CHARACTER*4 IVARN2(MAXSPN)
23054      CHARACTER*4 IVARTY(MAXSPN)
23055      REAL PVAR(MAXSPN)
23056      INTEGER ILIS(MAXSPN)
23057      INTEGER NRIGHT(MAXSPN)
23058      INTEGER ICOLR(MAXSPN)
23059C
23060      CHARACTER*4 IFLAGU
23061      LOGICAL IFRST
23062      LOGICAL ILAST
23063C
23064C---------------------------------------------------------------------
23065C
23066C-----COMMON----------------------------------------------------------
23067C
23068      INCLUDE 'DPCOPA.INC'
23069      INCLUDE 'DPCOHK.INC'
23070      INCLUDE 'DPCOSU.INC'
23071      INCLUDE 'DPCODA.INC'
23072      INCLUDE 'DPCOST.INC'
23073      INCLUDE 'DPCOP2.INC'
23074C
23075C-----START POINT-----------------------------------------------------
23076C
23077      ISUBN1='DPFT'
23078      ISUBN2='ES  '
23079      IFOUND='YES'
23080      IERROR='NO'
23081C
23082      MAXCP1=MAXCOL+1
23083      MAXCP2=MAXCOL+2
23084      MAXCP3=MAXCOL+3
23085      MAXCP4=MAXCOL+4
23086      MAXCP5=MAXCOL+5
23087      MAXCP6=MAXCOL+6
23088C
23089C               ********************************
23090C               **  TREAT THE F TEST CASE     **
23091C               ********************************
23092C
23093      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FTES')THEN
23094        WRITE(ICOUT,999)
23095  999   FORMAT(1X)
23096        CALL DPWRST('XXX','BUG ')
23097        WRITE(ICOUT,51)
23098   51   FORMAT('***** AT THE BEGINNING OF DPFTES--')
23099        CALL DPWRST('XXX','BUG ')
23100        WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ,ISUBRO,MAXNXT
23101   52   FORMAT('IBUGA2,IBUGA3,IBUGQ,ISUBRO,MAXNXT = ',4(A4,2X),I8)
23102        CALL DPWRST('XXX','BUG ')
23103      ENDIF
23104C
23105C               ****************************************
23106C               **  STEP 2--                          **
23107C               **  EXTRACT THE VARIABLE LIST         **
23108C               ****************************************
23109C
23110      ISTEPN='2'
23111      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FTES')
23112     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23113C
23114      INAME='F-TEST'
23115      MINNA=1
23116      MAXNA=100
23117      MINN2=2
23118      IFLAGE=0
23119      IFLAGM=1
23120      MINNVA=2
23121      MAXNVA=MAXSPN
23122      IFLAGP=0
23123      JMIN=1
23124      JMAX=NUMARG
23125C
23126      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
23127     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
23128     1            JMIN,JMAX,
23129     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
23130     1            IVARN1,IVARN2,IVARTY,PVAR,
23131     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
23132     1            MINNVA,MAXNVA,
23133     1            IFLAGM,IFLAGP,
23134     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
23135      IF(IERROR.EQ.'YES')GOTO9000
23136C
23137      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FTES')THEN
23138        WRITE(ICOUT,999)
23139        CALL DPWRST('XXX','BUG ')
23140        WRITE(ICOUT,281)
23141  281   FORMAT('***** AFTER CALL DPPARS--')
23142        CALL DPWRST('XXX','BUG ')
23143        WRITE(ICOUT,282)NQ,NUMVAR
23144  282   FORMAT('NQ,NUMVAR = ',2I8)
23145        CALL DPWRST('XXX','BUG ')
23146        IF(NUMVAR.GT.0)THEN
23147          DO285I=1,NUMVAR
23148            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
23149     1                      ICOLR(I)
23150  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
23151     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
23152            CALL DPWRST('XXX','BUG ')
23153  285     CONTINUE
23154        ENDIF
23155      ENDIF
23156C
23157C               *****************************************
23158C               **  STEP 3A--                          **
23159C               **  CASE 1: TWO RESPONSE VARIABLES     **
23160C               **          WITH NO REPLICATION        **
23161C               *****************************************
23162C
23163      ISTEPN='3A'
23164      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FTES')
23165     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23166C
23167      NUMVA2=1
23168      DO5210I=1,NUMVAR
23169        DO5220J=I+1,NUMVAR
23170          ICOL=I
23171          CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
23172     1                INAME,IVARN1,IVARN2,IVARTY,
23173     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
23174     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
23175     1                MAXCP4,MAXCP5,MAXCP6,
23176     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
23177     1                Y,Y,Y,NS1,NLOCA2,NLOCA3,ICASE,
23178     1                IBUGA3,ISUBRO,IFOUND,IERROR)
23179          IF(IERROR.EQ.'YES')GOTO9000
23180C
23181          ICOL=J
23182          CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
23183     1                INAME,IVARN1,IVARN2,IVARTY,
23184     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
23185     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
23186     1                MAXCP4,MAXCP5,MAXCP6,
23187     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
23188     1                X,X,X,NS2,NLOCA2,NLOCA3,ICASE,
23189     1                IBUGA3,ISUBRO,IFOUND,IERROR)
23190          IF(IERROR.EQ.'YES')GOTO9000
23191C
23192C               *****************************************
23193C               **  STEP 52--                          **
23194C               **  PERFORM 2-SAMPLE F-TEST            **
23195C               *****************************************
23196C
23197          ISTEPN='52'
23198          IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FTES')THEN
23199            CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23200            WRITE(ICOUT,999)
23201            CALL DPWRST('XXX','BUG ')
23202            WRITE(ICOUT,5211)
23203 5211       FORMAT('***** FROM DPFTES, BEFORE CALL DPFTES--')
23204            CALL DPWRST('XXX','BUG ')
23205            WRITE(ICOUT,5212)I,J,NS1,NS2,MAXN
23206 5212       FORMAT('I,J,NS1,NS2,MAXN = ',5I8)
23207            CALL DPWRST('XXX','BUG ')
23208            DO5215II=1,MAX(NS1,NS2)
23209              WRITE(ICOUT,5216)II,Y(II),X(II)
23210 5216         FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
23211              CALL DPWRST('XXX','BUG ')
23212 5215       CONTINUE
23213          ENDIF
23214C
23215          IVARID=IVARN1(I)
23216          IVARI2=IVARN2(I)
23217          IVARI3=IVARN1(J)
23218          IVARI4=IVARN2(J)
23219          CALL DPFTE2(Y,NS1,X,NS2,MAXNXT,
23220     1                ICAPSW,ICAPTY,IFORSW,
23221     1                STATVA,STANU1,STANU2,POOLSD,STATCD,PVAL,
23222     1                IVARID,IVARI2,IVARI3,IVARI4,
23223     1                CUTU50,CUTU75,CUTU90,CUTU95,CUT975,
23224     1                CUTU99,CUT999,
23225     1                IBUGA3,ISUBRO,IERROR)
23226          IF(IERROR.EQ.'YES')GOTO9000
23227C
23228C               ***************************************
23229C               **  STEP 8C--                        **
23230C               **  UPDATE INTERNAL DATAPLOT TABLES  **
23231C               ***************************************
23232C
23233          ISTEPN='8C'
23234          IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FTE2')
23235     1      CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23236C
23237          IF(NUMVAR.GT.2)THEN
23238            IFLAGU='FILE'
23239          ELSE
23240            IFLAGU='ON'
23241          ENDIF
23242          IFRST=.FALSE.
23243          ILAST=.FALSE.
23244          IF(I.EQ.1 .AND. J.EQ.2)IFRST=.TRUE.
23245          IF(I.EQ.NUMVAR .AND. J.EQ.NUMVAR)ILAST=.TRUE.
23246          CALL DPFTE5(STATVA,STATCD,PVAL,STANU1,STANU2,POOLSD,
23247     1                CUTU50,CUTU75,CUTU90,CUTU95,CUT975,
23248     1                CUTU99,CUT999,
23249     1                IFLAGU,IFRST,ILAST,
23250     1                IBUGA2,IBUGA3,ISUBRO,IERROR)
23251C
23252 5220   CONTINUE
23253 5210 CONTINUE
23254C
23255C               *****************
23256C               **  STEP 90--  **
23257C               **  EXIT       **
23258C               *****************
23259C
23260 9000 CONTINUE
23261      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FTES')THEN
23262        WRITE(ICOUT,999)
23263        CALL DPWRST('XXX','BUG ')
23264        WRITE(ICOUT,9011)
23265 9011   FORMAT('***** AT THE END       OF DPFTES--')
23266        CALL DPWRST('XXX','BUG ')
23267        WRITE(ICOUT,9016)IFOUND,IERROR
23268 9016   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
23269        CALL DPWRST('XXX','BUG ')
23270      ENDIF
23271C
23272      RETURN
23273      END
23274      SUBROUTINE DPFTE2(Y1,N1,Y2,N2,MAXNXT,
23275     1                  ICAPSW,ICAPTY,IFORSW,
23276     1                  STATVA,STANU1,STANU2,POOLSD,STATCD,PVAL,
23277     1                  IVARID,IVARI2,IVARI3,IVARI4,
23278     1                  CUTU50,CUTU75,CUTU90,CUTU95,CUT975,
23279     1                  CUTU99,CUT999,
23280     1                  IBUGA3,ISUBRO,IERROR)
23281C
23282C     PURPOSE--THIS ROUTINE CARRIES OUT AN F TEST (NECESSARILY 2-SAMPLE)
23283C     EXAMPLE--F TEST Y1 Y2
23284C              SAMPLE 1 IS IN INPUT VECTOR Y1 (WITH N1 OBSERVATIONS).
23285C              SAMPLE 2 IS IN INPUT VECTOR Y2 (WITH N2 OBSERVATIONS).
23286C     WRITTEN BY--JAMES J. FILLIBEN
23287C                 STATISTICAL ENGINEERING DIVISION
23288C                 INFORMATION TECHNOLOGY LABORATORY
23289C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
23290C                 GAITHERSBURG, MD 20899-8980
23291C                 PHONE--301-975-2855
23292C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
23293C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
23294C     LANGUAGE--ANSI FORTRAN (1977)
23295C     VERSION NUMBER--94/2
23296C     ORIGINAL VERSION--FEBRUARY  1994.
23297C     UPDATED         --DECEMBER  1994. COPY F TEST PARAMETERS
23298C     UPDATED         --JANUARY   2004. SUPPORT FOR HTML, LATEX
23299C     UPDATED         --MARCH     2011. USE DPDTA1, DPDTA5 TO PRINT
23300C                                       OUTPUT
23301C
23302C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
23303C
23304      CHARACTER*4 ICAPSW
23305      CHARACTER*4 ICAPTY
23306      CHARACTER*4 IFORSW
23307      CHARACTER*4 IVARID
23308      CHARACTER*4 IVARI2
23309      CHARACTER*4 IVARI3
23310      CHARACTER*4 IVARI4
23311      CHARACTER*4 IBUGA3
23312      CHARACTER*4 ISUBRO
23313      CHARACTER*4 IERROR
23314C
23315      CHARACTER*4 ISUBN1
23316      CHARACTER*4 ISUBN2
23317      CHARACTER*4 ISTEPN
23318C
23319C---------------------------------------------------------------------
23320C
23321      DIMENSION Y1(*)
23322      DIMENSION Y2(*)
23323C
23324      PARAMETER (NUMALP=7)
23325      REAL ALPHA(NUMALP)
23326C
23327      PARAMETER(NUMCLI=4)
23328      PARAMETER(MAXLIN=3)
23329      PARAMETER (MAXROW=NUMALP)
23330      PARAMETER (MAXRO2=30)
23331      CHARACTER*60 ITITLE
23332      CHARACTER*60 ITITLZ
23333      CHARACTER*60 ITITL9
23334      CHARACTER*60 ITEXT(MAXRO2)
23335      CHARACTER*4  ALIGN(NUMCLI)
23336      CHARACTER*4  VALIGN(NUMCLI)
23337      REAL         AVALUE(MAXRO2)
23338      INTEGER      NCTEXT(MAXRO2)
23339      INTEGER      IDIGIT(MAXRO2)
23340      INTEGER      NTOT(MAXRO2)
23341      CHARACTER*60 ITITL2(MAXLIN,NUMCLI)
23342      CHARACTER*15 IVALUE(MAXROW,NUMCLI)
23343      CHARACTER*4  ITYPCO(NUMCLI)
23344      INTEGER      NCTIT2(MAXLIN,NUMCLI)
23345      INTEGER      NCVALU(MAXROW,NUMCLI)
23346      INTEGER      IWHTML(NUMCLI)
23347      INTEGER      IWRTF(NUMCLI)
23348      REAL         AMAT(MAXROW,NUMCLI)
23349      LOGICAL IFRST
23350      LOGICAL ILAST
23351      LOGICAL IFLAGS
23352      LOGICAL IFLAGE
23353C
23354C---------------------------------------------------------------------
23355C
23356      INCLUDE 'DPCOP2.INC'
23357C
23358      DATA ALPHA/0.50, 0.75, 0.90, 0.95, 0.975, 0.99, 0.999/
23359C
23360C-----START POINT-----------------------------------------------------
23361C
23362      ISUBN1='DPFT'
23363      ISUBN2='E2  '
23364      IERROR='NO'
23365C
23366      N=(-99)
23367C
23368      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FTE2')THEN
23369        WRITE(ICOUT,999)
23370  999   FORMAT(1X)
23371        CALL DPWRST('XXX','WRIT')
23372        WRITE(ICOUT,51)
23373   51   FORMAT('**** AT THE BEGINNING OF DPFTE2--')
23374        CALL DPWRST('XXX','WRIT')
23375        WRITE(ICOUT,52)IBUGA3,ISUBRO,N1,N2
23376   52   FORMAT('IBUGA3,ISUBRO,N1,N2 = ',2(A4,2X),2I8)
23377        CALL DPWRST('XXX','WRIT')
23378        DO56I=1,N1
23379          WRITE(ICOUT,57)I,Y1(I)
23380   57     FORMAT('I,Y1(I) = ',I8,G15.7)
23381          CALL DPWRST('XXX','WRIT')
23382   56   CONTINUE
23383        DO66I=1,N2
23384          WRITE(ICOUT,67)I,Y2(I)
23385   67     FORMAT('I,Y2(I) = ',I8,E15.7)
23386          CALL DPWRST('XXX','WRIT')
23387   66   CONTINUE
23388      ENDIF
23389C
23390C               ******************************
23391C               **  STEP 21--               **
23392C               **  CARRY OUT CALCULATIONS  **
23393C               **  FOR AN          F TEST  **
23394C               ******************************
23395C
23396      ISTEPN='21'
23397      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FTE2')
23398     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23399C
23400      CALL DPFTE3(Y1,N1,Y2,N2,MAXNXT,
23401     1            Y1MEAN,Y1SD,Y2MEAN,Y2SD,
23402     1            SDNUM,SDDEN,IDFNUM,IDFDEN,
23403     1            STATVA,STANU1,STANU2,POOLSD,STATCD,PVAL,
23404     1            IBUGA3,ISUBRO,IERROR)
23405      IF(IERROR.EQ.'YES')GOTO9000
23406C
23407      CALL FPPF(.50,IDFNUM,IDFDEN,CUTU50)
23408      CALL FPPF(.75,IDFNUM,IDFDEN,CUTU75)
23409      CALL FPPF(.90,IDFNUM,IDFDEN,CUTU90)
23410      CALL FPPF(.95,IDFNUM,IDFDEN,CUTU95)
23411      CALL FPPF(.975,IDFNUM,IDFDEN,CUT975)
23412      CALL FPPF(.99,IDFNUM,IDFDEN,CUTU99)
23413      CALL FPPF(.999,IDFNUM,IDFDEN,CUT999)
23414C
23415C               ******************************
23416C               **   STEP 42--              **
23417C               **   WRITE OUT EVERYTHING   **
23418C               **   FOR AN         F TEST  **
23419C               ******************************
23420C
23421      ISTEPN='42'
23422      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FTE2')
23423     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23424C
23425      IF(IPRINT.EQ.'OFF')GOTO9000
23426C
23427      NUMDIG=7
23428      IF(IFORSW.EQ.'1')NUMDIG=1
23429      IF(IFORSW.EQ.'2')NUMDIG=2
23430      IF(IFORSW.EQ.'3')NUMDIG=3
23431      IF(IFORSW.EQ.'4')NUMDIG=4
23432      IF(IFORSW.EQ.'5')NUMDIG=5
23433      IF(IFORSW.EQ.'6')NUMDIG=6
23434      IF(IFORSW.EQ.'7')NUMDIG=7
23435      IF(IFORSW.EQ.'8')NUMDIG=8
23436      IF(IFORSW.EQ.'9')NUMDIG=9
23437      IF(IFORSW.EQ.'0')NUMDIG=0
23438      IF(IFORSW.EQ.'E')NUMDIG=-2
23439      IF(IFORSW.EQ.'-2')NUMDIG=-2
23440      IF(IFORSW.EQ.'-3')NUMDIG=-3
23441      IF(IFORSW.EQ.'-4')NUMDIG=-4
23442      IF(IFORSW.EQ.'-5')NUMDIG=-5
23443      IF(IFORSW.EQ.'-6')NUMDIG=-6
23444      IF(IFORSW.EQ.'-7')NUMDIG=-7
23445      IF(IFORSW.EQ.'-8')NUMDIG=-8
23446      IF(IFORSW.EQ.'-9')NUMDIG=-9
23447C
23448      ITITLE='Two Sample F-Test for Equal Standard Deviations'
23449      NCTITL=47
23450      ITITLZ=' '
23451      NCTITZ=0
23452C
23453      ICNT=1
23454      ITEXT(ICNT)=' '
23455      NCTEXT(ICNT)=0
23456      AVALUE(ICNT)=0.0
23457      IDIGIT(ICNT)=-1
23458C
23459      ICNT=ICNT+1
23460      ITEXT(ICNT)='First Response Variable:  '
23461      WRITE(ITEXT(ICNT)(27:30),'(A4)')IVARID(1:4)
23462      WRITE(ITEXT(ICNT)(31:34),'(A4)')IVARI2(1:4)
23463      NCTEXT(ICNT)=34
23464      AVALUE(ICNT)=0.0
23465      IDIGIT(ICNT)=-1
23466C
23467      ICNT=ICNT+1
23468      ITEXT(ICNT)='Second Response Variable: '
23469      WRITE(ITEXT(ICNT)(27:30),'(A4)')IVARI3(1:4)
23470      WRITE(ITEXT(ICNT)(31:34),'(A4)')IVARI4(1:4)
23471      NCTEXT(ICNT)=34
23472      AVALUE(ICNT)=0.0
23473      IDIGIT(ICNT)=-1
23474C
23475      ICNT=ICNT+1
23476      ITEXT(ICNT)=' '
23477      NCTEXT(ICNT)=1
23478      AVALUE(ICNT)=0.0
23479      IDIGIT(ICNT)=-1
23480C
23481      ICNT=ICNT+1
23482      ITEXT(ICNT)='H0: Sigma1 = Sigma2'
23483      NCTEXT(ICNT)=19
23484      AVALUE(ICNT)=0.0
23485      IDIGIT(ICNT)=-1
23486      ICNT=ICNT+1
23487      ITEXT(ICNT)='Ha: Sigma1 not equal Sigma2'
23488      NCTEXT(ICNT)=27
23489      AVALUE(ICNT)=0.0
23490      IDIGIT(ICNT)=-1
23491C
23492      ICNT=ICNT+1
23493      ITEXT(ICNT)=' '
23494      NCTEXT(ICNT)=1
23495      AVALUE(ICNT)=0.0
23496      IDIGIT(ICNT)=-1
23497      ICNT=ICNT+1
23498      ITEXT(ICNT)='Sample One Summary Statistics:'
23499      NCTEXT(ICNT)=30
23500      AVALUE(ICNT)=0.0
23501      IDIGIT(ICNT)=-1
23502      ICNT=ICNT+1
23503      ITEXT(ICNT)='Number of Observations:'
23504      NCTEXT(ICNT)=23
23505      AVALUE(ICNT)=REAL(N1)
23506      IDIGIT(ICNT)=0
23507      ICNT=ICNT+1
23508      ITEXT(ICNT)='Sample Mean:'
23509      NCTEXT(ICNT)=12
23510      AVALUE(ICNT)=Y1MEAN
23511      IDIGIT(ICNT)=NUMDIG
23512      ICNT=ICNT+1
23513      ITEXT(ICNT)='Sample Standard Deviation:'
23514      NCTEXT(ICNT)=26
23515      AVALUE(ICNT)=Y1SD
23516      IDIGIT(ICNT)=NUMDIG
23517      ICNT=ICNT+1
23518      ITEXT(ICNT)=' '
23519      NCTEXT(ICNT)=1
23520      AVALUE(ICNT)=0.0
23521      IDIGIT(ICNT)=-1
23522C
23523      ICNT=ICNT+1
23524      ITEXT(ICNT)='Sample Two Summary Statistics:'
23525      NCTEXT(ICNT)=30
23526      AVALUE(ICNT)=0.0
23527      IDIGIT(ICNT)=-1
23528      ICNT=ICNT+1
23529      ITEXT(ICNT)='Number of Observations:'
23530      NCTEXT(ICNT)=23
23531      AVALUE(ICNT)=REAL(N2)
23532      IDIGIT(ICNT)=0
23533      ICNT=ICNT+1
23534      ITEXT(ICNT)='Sample Mean:'
23535      NCTEXT(ICNT)=12
23536      AVALUE(ICNT)=Y2MEAN
23537      IDIGIT(ICNT)=NUMDIG
23538      ICNT=ICNT+1
23539      ITEXT(ICNT)='Sample Standard Deviation:'
23540      NCTEXT(ICNT)=26
23541      AVALUE(ICNT)=Y2SD
23542      IDIGIT(ICNT)=NUMDIG
23543      ICNT=ICNT+1
23544      ITEXT(ICNT)=' '
23545      NCTEXT(ICNT)=1
23546      AVALUE(ICNT)=0.0
23547      IDIGIT(ICNT)=-1
23548C
23549      ICNT=ICNT+1
23550      ITEXT(ICNT)='Test:'
23551      NCTEXT(ICNT)=5
23552      AVALUE(ICNT)=0.0
23553      IDIGIT(ICNT)=-1
23554      ICNT=ICNT+1
23555      ITEXT(ICNT)='Standard Deviation (Numerator):'
23556      NCTEXT(ICNT)=31
23557      AVALUE(ICNT)=SDNUM
23558      IDIGIT(ICNT)=NUMDIG
23559      ICNT=ICNT+1
23560      ITEXT(ICNT)='Standard Deviation (Denomerator):'
23561      NCTEXT(ICNT)=33
23562      AVALUE(ICNT)=SDDEN
23563      IDIGIT(ICNT)=NUMDIG
23564      ICNT=ICNT+1
23565      ITEXT(ICNT)='Degrees of Freedom (Numerator):'
23566      NCTEXT(ICNT)=31
23567      AVALUE(ICNT)=IDFNUM
23568      IDIGIT(ICNT)=0
23569      ICNT=ICNT+1
23570      ITEXT(ICNT)='Degrees of Freedom (Denomerator):'
23571      NCTEXT(ICNT)=33
23572      AVALUE(ICNT)=IDFDEN
23573      IDIGIT(ICNT)=0
23574      ICNT=ICNT+1
23575      ITEXT(ICNT)='Pooled Standard Deviation:'
23576      NCTEXT(ICNT)=26
23577      AVALUE(ICNT)=POOLSD
23578      IDIGIT(ICNT)=NUMDIG
23579      ICNT=ICNT+1
23580      ITEXT(ICNT)='F-Test Statistic Value:'
23581      NCTEXT(ICNT)=23
23582      AVALUE(ICNT)=STATVA
23583      IDIGIT(ICNT)=NUMDIG
23584      ICNT=ICNT+1
23585      ITEXT(ICNT)='F-Test CDF Value:'
23586      NCTEXT(ICNT)=17
23587      AVALUE(ICNT)=STATCD
23588      IDIGIT(ICNT)=NUMDIG
23589      ICNT=ICNT+1
23590      ITEXT(ICNT)='F-Test P-Value:'
23591      NCTEXT(ICNT)=15
23592      AVALUE(ICNT)=PVAL
23593      IDIGIT(ICNT)=NUMDIG
23594C
23595      NUMROW=ICNT
23596      DO5010I=1,NUMROW
23597        NTOT(I)=15
23598 5010 CONTINUE
23599C
23600      IFRST=.TRUE.
23601      ILAST=.TRUE.
23602C
23603      ISTEPN='42A'
23604      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'ADK2')
23605     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23606C
23607      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
23608     1            AVALUE,IDIGIT,
23609     1            NTOT,NUMROW,
23610     1            ICAPSW,ICAPTY,ILAST,IFRST,
23611     1            ISUBRO,IBUGA3,IERROR)
23612C
23613      ISTEPN='42D'
23614      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'ADK2')
23615     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23616C
23617      ITITLE='Conclusions (Upper 1-Tailed Test)'
23618      NCTITL=33
23619      ITITL9='H0: sigma1 = sigma2; sigma1 <> sigma2'
23620      NCTIT9=37
23621C
23622      DO5030J=1,NUMCLI
23623        DO5040I=1,3
23624          ITITL2(I,J)=' '
23625          NCTIT2(I,J)=0
23626 5040   CONTINUE
23627 5030 CONTINUE
23628C
23629      ITITL2(2,1)='Significance'
23630      NCTIT2(2,1)=12
23631      ITITL2(3,1)='Level'
23632      NCTIT2(3,1)=5
23633C
23634      ITITL2(2,2)='Test '
23635      NCTIT2(2,2)=4
23636      ITITL2(3,2)='Statistic'
23637      NCTIT2(3,2)=9
23638C
23639      ITITL2(2,3)='Critical'
23640      NCTIT2(2,3)=8
23641      ITITL2(3,3)='Region (>=)'
23642      NCTIT2(3,3)=11
23643C
23644      ITITL2(1,4)='Null'
23645      NCTIT2(1,4)=4
23646      ITITL2(2,4)='Hypothesis'
23647      NCTIT2(2,4)=10
23648      ITITL2(3,4)='Conclusion'
23649      NCTIT2(3,4)=10
23650C
23651      NMAX=0
23652      NUMCOL=NUMCLI
23653      DO5050I=1,NUMCOL
23654        VALIGN(I)='b'
23655        ALIGN(I)='r'
23656        NTOT(I)=15
23657        NMAX=NMAX+NTOT(I)
23658        ITYPCO(I)='NUME'
23659        IDIGIT(I)=NUMDIG
23660        IF(I.EQ.1 .OR. I.EQ.4)THEN
23661          ITYPCO(I)='ALPH'
23662        ENDIF
23663 5050 CONTINUE
23664C
23665      IWHTML(1)=125
23666      IWHTML(2)=175
23667      IWHTML(3)=175
23668      IWHTML(4)=175
23669      IINC=1800
23670      IINC2=1400
23671      IWRTF(1)=IINC
23672      IWRTF(2)=IWRTF(1)+IINC
23673      IWRTF(3)=IWRTF(2)+IINC
23674      IWRTF(4)=IWRTF(3)+IINC
23675C
23676      DO5060J=1,NUMALP
23677C
23678        AMAT(J,2)=STATVA
23679        IF(J.EQ.1)THEN
23680          AMAT(J,3)=CUTU50
23681        ELSEIF(J.EQ.2)THEN
23682          AMAT(J,3)=CUTU75
23683        ELSEIF(J.EQ.3)THEN
23684          AMAT(J,3)=CUTU90
23685        ELSEIF(J.EQ.4)THEN
23686          AMAT(J,3)=CUTU95
23687        ELSEIF(J.EQ.5)THEN
23688          AMAT(J,3)=CUT975
23689        ELSEIF(J.EQ.6)THEN
23690          AMAT(J,3)=CUTU99
23691        ELSEIF(J.EQ.7)THEN
23692          AMAT(J,3)=CUT999
23693        ENDIF
23694        IVALUE(J,4)(1:6)='REJECT'
23695        IF(STATVA.LT.AMAT(J,3))THEN
23696          IVALUE(J,4)(1:6)='ACCEPT'
23697        ENDIF
23698        NCVALU(J,4)=6
23699C
23700        ALPHAT=100.0*ALPHA(J)
23701        WRITE(IVALUE(J,1)(1:4),'(F4.1)')ALPHAT
23702        IVALUE(J,1)(5:5)='%'
23703        NCVALU(J,1)=5
23704 5060 CONTINUE
23705C
23706      ICNT=NUMALP
23707      NUMLIN=3
23708      IFRST=.TRUE.
23709      ILAST=.TRUE.
23710      IFLAGS=.TRUE.
23711      IFLAGE=.TRUE.
23712      CALL DPDTA5(ITITLE,NCTITL,
23713     1            ITITL9,NCTIT9,ITITL2,NCTIT2,
23714     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
23715     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
23716     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
23717     1            ICAPSW,ICAPTY,IFRST,ILAST,
23718     1            IFLAGS,IFLAGE,
23719     1            ISUBRO,IBUGA3,IERROR)
23720C
23721C               *****************
23722C               **  STEP 90--  **
23723C               **  EXIT       **
23724C               *****************
23725C
23726 9000 CONTINUE
23727      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FTE2')THEN
23728        WRITE(ICOUT,999)
23729        CALL DPWRST('XXX','WRIT')
23730        WRITE(ICOUT,9011)
23731 9011   FORMAT('***** AT THE END       OF DPFTE2--')
23732        CALL DPWRST('XXX','WRIT')
23733        WRITE(ICOUT,9012)IERROR
23734 9012   FORMAT('IERROR = ',A4)
23735        CALL DPWRST('XXX','WRIT')
23736      ENDIF
23737C
23738      RETURN
23739      END
23740      SUBROUTINE DPFTE3(Y1,N1,Y2,N2,MAXNXT,
23741     1                  Y1MEAN,Y1SD,Y2MEAN,Y2SD,
23742     1                  SDNUM,SDDEN,IDFNUM,IDFDEN,
23743     1                  STATVA,STANU1,STANU2,POOLSD,STATCD,PVAL,
23744     1                  IBUGA3,ISUBRO,IERROR)
23745C
23746C     PURPOSE--THIS ROUTINE CARRIES OUT AN F TEST.  EXTRACTED FROM
23747C              DPFTE2 TO MAKE IT CALLABLE FROM CMPSTA (I.E., A
23748C              SUPPORTED STATISTIC).
23749C     EXAMPLE--LET A = F TEST Y1 Y2
23750C     WRITTEN BY--JAMES J. FILLIBEN
23751C                 STATISTICAL ENGINEERING DIVISION
23752C                 INFORMATION TECHNOLOGY LABORATORY
23753C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
23754C                 GAITHERSBURG, MD 20899-8980
23755C                 PHONE--301-975-2855
23756C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
23757C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
23758C     LANGUAGE--ANSI FORTRAN (1977)
23759C     VERSION NUMBER--2011/3
23760C     ORIGINAL VERSION--MARCHARY  2011. EXTRACTED FROM DPFTE2
23761C
23762C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
23763C
23764      CHARACTER*4 IBUGA3
23765      CHARACTER*4 ISUBRO
23766      CHARACTER*4 IERROR
23767C
23768      CHARACTER*4 IWRITE
23769      CHARACTER*4 ISUBN1
23770      CHARACTER*4 ISUBN2
23771      CHARACTER*4 ISTEPN
23772C
23773C---------------------------------------------------------------------
23774C
23775      DIMENSION Y1(*)
23776      DIMENSION Y2(*)
23777C
23778C---------------------------------------------------------------------
23779C
23780      INCLUDE 'DPCOP2.INC'
23781C
23782C-----START POINT-----------------------------------------------------
23783C
23784      ISUBN1='DPFT'
23785      ISUBN2='E3  '
23786      IERROR='NO'
23787C
23788      N=(-99)
23789C
23790      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FTE3')THEN
23791        WRITE(ICOUT,999)
23792  999   FORMAT(1X)
23793        CALL DPWRST('XXX','WRIT')
23794        WRITE(ICOUT,51)
23795   51   FORMAT('**** AT THE BEGINNING OF DPFTE3--')
23796        CALL DPWRST('XXX','WRIT')
23797        WRITE(ICOUT,52)IBUGA3,ISUBRO,N1,N2,MAXNXT
23798   52   FORMAT('IBUGA3,ISUBRO,N1,N2,MAXNXT = ',2(A4,2X),3I8)
23799        CALL DPWRST('XXX','WRIT')
23800        DO56I=1,N1
23801          WRITE(ICOUT,57)I,Y1(I)
23802   57     FORMAT('I,Y1(I) = ',I8,G15.7)
23803          CALL DPWRST('XXX','WRIT')
23804   56   CONTINUE
23805        DO66I=1,N2
23806          WRITE(ICOUT,67)I,Y2(I)
23807   67     FORMAT('I,Y2(I) = ',I8,G15.7)
23808          CALL DPWRST('XXX','WRIT')
23809   66   CONTINUE
23810      ENDIF
23811C
23812C               ********************************************
23813C               **  STEP 11--                             **
23814C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
23815C               ********************************************
23816C
23817      ISTEPN='11'
23818      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FTE3')
23819     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23820C
23821      IF(N1.LT.2)THEN
23822        WRITE(ICOUT,999)
23823        CALL DPWRST('XXX','WRIT')
23824        WRITE(ICOUT,1111)
23825 1111   FORMAT('***** ERROR IN F-TEST')
23826        CALL DPWRST('XXX','WRIT')
23827        WRITE(ICOUT,1113)
23828 1113   FORMAT('      THE NUMBER OF OBSERVATIONS IN THE FIRST ',
23829     1         'RESPONSE VARIABLE IS LESS THAN TWO.')
23830        CALL DPWRST('XXX','WRIT')
23831        WRITE(ICOUT,1115)N1
23832 1115   FORMAT('SAMPLE SIZE = ',I8)
23833        CALL DPWRST('XXX','WRIT')
23834        IERROR='YES'
23835        GOTO9000
23836      ELSEIF(N2.LT.2)THEN
23837        WRITE(ICOUT,999)
23838        CALL DPWRST('XXX','WRIT')
23839        WRITE(ICOUT,1111)
23840        CALL DPWRST('XXX','WRIT')
23841        WRITE(ICOUT,1123)
23842 1123   FORMAT('      THE NUMBER OF OBSERVATIONS IN THE SECOND ',
23843     1         'RESPONSE VARIABLE IS LESS THAN TWO.')
23844        CALL DPWRST('XXX','WRIT')
23845        WRITE(ICOUT,1115)N2
23846        CALL DPWRST('XXX','WRIT')
23847        IERROR='YES'
23848        GOTO9000
23849      ENDIF
23850C
23851      HOLD=Y1(1)
23852      DO1135I=2,N1
23853        IF(Y1(I).NE.HOLD)GOTO1139
23854 1135 CONTINUE
23855      WRITE(ICOUT,999)
23856      CALL DPWRST('XXX','WRIT')
23857      WRITE(ICOUT,1111)
23858      CALL DPWRST('XXX','WRIT')
23859      WRITE(ICOUT,1131)HOLD
23860 1131 FORMAT('      THE FIRST RESPONSE VARIABLE HAS ALL ELEMENTS = ',
23861     1       G15.7)
23862      CALL DPWRST('XXX','WRIT')
23863      IERROR='YES'
23864      GOTO9000
23865 1139 CONTINUE
23866C
23867      HOLD=Y2(1)
23868      DO1145I=2,N2
23869        IF(Y2(I).NE.HOLD)GOTO1149
23870 1145 CONTINUE
23871      WRITE(ICOUT,999)
23872      CALL DPWRST('XXX','WRIT')
23873      WRITE(ICOUT,1111)
23874      CALL DPWRST('XXX','WRIT')
23875      WRITE(ICOUT,1141)HOLD
23876 1141 FORMAT('      THE SECOND RESPONSE VARIABLE HAS ALL ELEMENTS = ',
23877     1       G15.7)
23878      CALL DPWRST('XXX','WRIT')
23879      IERROR='YES'
23880      GOTO9000
23881 1149 CONTINUE
23882C
23883C               ******************************
23884C               **  STEP 21--               **
23885C               **  CARRY OUT CALCULATIONS  **
23886C               **  FOR AN          F TEST  **
23887C               ******************************
23888C
23889      ISTEPN='21'
23890      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FTE3')
23891     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23892C
23893      IWRITE='OFF'
23894C
23895      CALL MEAN(Y1,N1,IWRITE,Y1MEAN,IBUGA3,IERROR)
23896      CALL SD(Y1,N1,IWRITE,Y1SD,IBUGA3,IERROR)
23897      Y1VAR=Y1SD**2
23898C
23899      CALL MEAN(Y2,N2,IWRITE,Y2MEAN,IBUGA3,IERROR)
23900      CALL SD(Y2,N2,IWRITE,Y2SD,IBUGA3,IERROR)
23901      Y2VAR=Y2SD**2
23902C
23903      AN1=N1
23904      AN2=N2
23905C
23906      IF(Y1SD.GE.Y2SD)THEN
23907         SDNUM=Y1SD
23908         SDDEN=Y2SD
23909         IDFNUM=N1-1
23910         IDFDEN=N2-1
23911      ELSE
23912         SDNUM=Y2SD
23913         SDDEN=Y1SD
23914         IDFNUM=N2-1
23915         IDFDEN=N1-1
23916      ENDIF
23917      RATIO=(SDNUM/SDDEN)**2
23918      CALL FCDF(RATIO,IDFNUM,IDFDEN,CDF)
23919      DFNUM=IDFNUM
23920      DFDEN=IDFDEN
23921C
23922      POOLSS=DFNUM*SDNUM*SDNUM+DFDEN*SDDEN*SDDEN
23923      POOLDF=DFNUM+DFDEN
23924      POOLVA=0.0
23925      IF(POOLDF.GT.0.0)POOLVA=POOLSS/POOLDF
23926      POOLSD=0.0
23927      IF(POOLVA.GT.0.0)POOLSD=SQRT(POOLVA)
23928C
23929      STATVA=RATIO
23930      STATCD=CDF
23931      PVAL=1.0 - CDF
23932      STANU1=IDFNUM
23933      STANU2=IDFDEN
23934C
23935C               *****************
23936C               **  STEP 90--  **
23937C               **  EXIT       **
23938C               *****************
23939C
23940 9000 CONTINUE
23941      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FTE3')THEN
23942        WRITE(ICOUT,999)
23943        CALL DPWRST('XXX','WRIT')
23944        WRITE(ICOUT,9011)
23945 9011   FORMAT('***** AT THE END       OF DPFTE3--')
23946        CALL DPWRST('XXX','WRIT')
23947        WRITE(ICOUT,9012)IERROR
23948 9012   FORMAT('IERROR = ',A4)
23949        CALL DPWRST('XXX','WRIT')
23950      ENDIF
23951C
23952      RETURN
23953      END
23954      SUBROUTINE DPFTE5(STATVA,STATCD,PVAL,STANU1,STANU2,POOLSD,
23955     1                  CUTU50,CUTU75,CUTU90,CUTU95,CUT975,
23956     1                  CUTU99,CUT999,
23957     1                  IFLAGU,IFRST,ILAST,
23958     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
23959C
23960C     PURPOSE--UTILITY ROUTINE USED BY DPFTES.  THIS ROUTINE UPDATES THE
23961C              PARAMETERS "STATVAL", "STATCDF", "PVALUE", "STANU1",
23962C              "STANU2", "POOLSD", AND VARIOUS CUTOFF POINTS AFTER A
23963C              F TEST.
23964C
23965C     WRITTEN BY--ALAN HECKERT
23966C                 STATISTICAL ENGINEERING DIVISION
23967C                 INFORMATION TECHNOLOGY LABORAOTRY
23968C                 NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY
23969C                 GAITHERSBURG, MD 20899-8980
23970C                 PHONE--301-975-2899
23971C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
23972C           OF THE NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY.
23973C     LANGUAGE--ANSI FORTRAN (1977)
23974C     VERSION NUMBER--2011/3
23975C     ORIGINAL VERSION--MARCH     2011.
23976C
23977C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
23978C
23979      CHARACTER*4 IFLAGU
23980      CHARACTER*4 IBUGA2
23981      CHARACTER*4 IBUGA3
23982      CHARACTER*4 ISUBRO
23983      CHARACTER*4 IERROR
23984C
23985      LOGICAL IFRST
23986      LOGICAL ILAST
23987C
23988      CHARACTER*4 IH
23989      CHARACTER*4 IH2
23990      CHARACTER*4 ISUBN0
23991      CHARACTER*4 ISUBN1
23992      CHARACTER*4 ISUBN2
23993      CHARACTER*4 ISTEPN
23994      CHARACTER*4 IOP
23995C
23996      SAVE IOUNI1
23997C
23998C-----COMMON VARIABLES (GENERAL)--------------------------------------
23999C
24000      INCLUDE 'DPCOPA.INC'
24001      INCLUDE 'DPCOHK.INC'
24002      INCLUDE 'DPCOHO.INC'
24003      INCLUDE 'DPCOP2.INC'
24004C
24005C-----START POINT-----------------------------------------------------
24006C
24007      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FTE5')THEN
24008        ISTEPN='1'
24009        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24010        WRITE(ICOUT,999)
24011  999   FORMAT(1X)
24012        CALL DPWRST('XXX','BUG ')
24013        WRITE(ICOUT,51)
24014   51   FORMAT('***** AT THE BEGINNING OF DPFTE5--')
24015        CALL DPWRST('XXX','BUG ')
24016        WRITE(ICOUT,53)STATVA,STATCD,PVAL
24017   53   FORMAT('STATVA,STATCD,PVAL = ',3G15.7)
24018        CALL DPWRST('XXX','BUG ')
24019        WRITE(ICOUT,54)CUTL95,CUTU95,CUTL99,CUTU99
24020   54   FORMAT('CUTL95,CUTU95,CUTL99,CUTU99 = ',4G15.7)
24021        CALL DPWRST('XXX','BUG ')
24022        WRITE(ICOUT,55)STANU1,STANU2,POOLSD
24023   55   FORMAT('STANU1,STANU2,POOLSD = ',3G15.7)
24024        CALL DPWRST('XXX','BUG ')
24025      ENDIF
24026C
24027      IF(IFLAGU.EQ.'FILE')THEN
24028C
24029        IF(IFRST)THEN
24030          IOP='OPEN'
24031          IFLAG1=1
24032          IFLAG2=0
24033          IFLAG3=0
24034          IFLAG4=0
24035          IFLAG5=0
24036          CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
24037     1                IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
24038     1                IBUGA3,ISUBRO,IERROR)
24039          IF(IERROR.EQ.'YES')GOTO9000
24040C
24041          WRITE(IOUNI1,295)
24042  295     FORMAT(11X,'STATVAL',8X,'STATCDF',8X,'PVALUE',
24043     1            8X,'STATNU1',8X,'STATNU2',9X,'POOLSD',
24044     1            7X,'CUTUPP50',7X,'CUTUPP75',
24045     1            7X,'CUTUPP90',7X,'CUTUPP95',7X,'CUTUP975',
24046     1            7X,'CUTLOW99',7X,'CUTUPP99')
24047        ENDIF
24048        WRITE(IOUNI1,299)STATVA,STATCD,PVAL,STANU1,STANU2,POOLSD,
24049     1                   CUTU50,CUTU75,CUTU90,CUTU95,CUT975,
24050     1                   CUTU99,CUT999
24051  299   FORMAT(13E15.7)
24052      ELSEIF(IFLAGU.EQ.'ON')THEN
24053        IF(STATVA.NE.CPUMIN)THEN
24054          IH='STAT'
24055          IH2='VAL '
24056          VALUE0=STATVA
24057          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
24058     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
24059     1                IANS,IWIDTH,IBUGA3,IERROR)
24060        ENDIF
24061C
24062        IF(STATCD.NE.CPUMIN)THEN
24063          IH='STAT'
24064          IH2='CDF '
24065          VALUE0=STATCD
24066          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
24067     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
24068     1                IANS,IWIDTH,IBUGA3,IERROR)
24069        ENDIF
24070C
24071        IF(PVAL.NE.CPUMIN)THEN
24072          IH='PVAL'
24073          IH2='UE  '
24074          VALUE0=PVAL
24075          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
24076     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
24077     1                IANS,IWIDTH,IBUGA3,IERROR)
24078        ENDIF
24079C
24080        IF(STANU1.NE.CPUMIN)THEN
24081          IH='STAT'
24082          IH2='NU1 '
24083          VALUE0=STANU1
24084          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
24085     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
24086     1                IANS,IWIDTH,IBUGA3,IERROR)
24087        ENDIF
24088C
24089        IF(STANU2.NE.CPUMIN)THEN
24090          IH='STAT'
24091          IH2='NU2 '
24092          VALUE0=STANU2
24093          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
24094     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
24095     1                IANS,IWIDTH,IBUGA3,IERROR)
24096        ENDIF
24097C
24098        IF(POOLSD.NE.CPUMIN)THEN
24099          IH='POOL'
24100          IH2='SD  '
24101          VALUE0=POOLSD
24102          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
24103     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
24104     1                IANS,IWIDTH,IBUGA3,IERROR)
24105        ENDIF
24106C
24107        IF(CUTU50.NE.CPUMIN)THEN
24108          IH='CUTU'
24109          IH2='PP50'
24110          VALUE0=CUTU50
24111          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
24112     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
24113     1                IANS,IWIDTH,IBUGA3,IERROR)
24114        ENDIF
24115C
24116        IF(CUTU75.NE.CPUMIN)THEN
24117          IH='CUTU'
24118          IH2='PP75'
24119          VALUE0=CUTU75
24120          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
24121     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
24122     1                IANS,IWIDTH,IBUGA3,IERROR)
24123        ENDIF
24124C
24125        IF(CUTU90.NE.CPUMIN)THEN
24126          IH='CUTU'
24127          IH2='PP90'
24128          VALUE0=CUTU90
24129          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
24130     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
24131     1                IANS,IWIDTH,IBUGA3,IERROR)
24132        ENDIF
24133C
24134        IF(CUTU95.NE.CPUMIN)THEN
24135          IH='CUTU'
24136          IH2='PP95'
24137          VALUE0=CUTU95
24138          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
24139     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
24140     1                IANS,IWIDTH,IBUGA3,IERROR)
24141        ENDIF
24142C
24143        IF(CUT975.NE.CPUMIN)THEN
24144          IH='CUTU'
24145          IH2='P975'
24146          VALUE0=CUT975
24147          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
24148     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
24149     1                IANS,IWIDTH,IBUGA3,IERROR)
24150        ENDIF
24151C
24152        IF(CUTU99.NE.CPUMIN)THEN
24153          IH='CUTU'
24154          IH2='PP99'
24155          VALUE0=CUTU99
24156          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
24157     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
24158     1                IANS,IWIDTH,IBUGA3,IERROR)
24159        ENDIF
24160C
24161        IF(CUT999.NE.CPUMIN)THEN
24162          IH='CUTU'
24163          IH2='P999'
24164          VALUE0=CUT999
24165          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
24166     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
24167     1                IANS,IWIDTH,IBUGA3,IERROR)
24168        ENDIF
24169C
24170      ENDIF
24171C
24172      IF(IFLAGU.EQ.'FILE')THEN
24173        IF(ILAST)THEN
24174          IOP='CLOS'
24175          IFLAG1=1
24176          IFLAG2=0
24177          IFLAG3=0
24178          IFLAG4=0
24179          IFLAG5=0
24180          CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
24181     1                IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
24182     1                IBUGA3,ISUBRO,IERROR)
24183C
24184          IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FTE5')THEN
24185            ISTEPN='3A'
24186            CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24187            WRITE(ICOUT,999)
24188            CALL DPWRST('XXX','BUG ')
24189            WRITE(ICOUT,301)IERROR,IOUNI1
24190  301       FORMAT('AFTER CALL DPCLFI, IERROR,IOUNI1 = ',A4,2X,I5)
24191            CALL DPWRST('XXX','BUG ')
24192          ENDIF
24193C
24194          IF(IERROR.EQ.'YES')GOTO9000
24195        ENDIF
24196      ENDIF
24197C
24198C               *****************
24199C               **  STEP 90--  **
24200C               **  EXIT       **
24201C               *****************
24202C
24203 9000 CONTINUE
24204C
24205      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FTE5')THEN
24206        WRITE(ICOUT,999)
24207        CALL DPWRST('XXX','BUG ')
24208        WRITE(ICOUT,9011)
24209 9011   FORMAT('***** AT THE END OF DPFTE5--')
24210        CALL DPWRST('XXX','BUG ')
24211      ENDIF
24212C
24213      RETURN
24214      END
24215      SUBROUTINE DPFUEV(ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,
24216     1                  IA,PARAM,IPARN,IPARN2,
24217     1                  IFOUNZ,IBEGIN,IEND,ITYPE,IHOL,IHOL2,
24218     1                  INT1,FLOAT1,IERRO1,
24219     1                  NUMCL,NUMPL,NUMAOL,ITYW1L,ICAT1L,INLI1L,ITYW2L,
24220     1                  NUMCR,NUMPR,NUMAOR,ITYW1R,ICAT1R,INLI1R,ITYW2R,
24221     1                  IANGLU,
24222     1                  IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO,IFOUND,IERROR)
24223C
24224C     PURPOSE--TREAT THE TYPE 6 LET CASE--
24225C              COMPUTING A GENERAL FUNCTION
24226C              (FOR A PARAMETER, A FULL VARIABLE,
24227C              OR PART OF A VARIABLE).
24228C     OUTPUT--A PARAMETER OR A VARIABLE.
24229C     EXAMPLE--IN THE FOLLOWING EXAMPLES,
24230C              A REPRESENTS A PREVIOUSLY-DEFINED PARAMETER
24231C              B REPRESENTS A PREVIOUSLY-DEFINED PARAMETER
24232C              X REPRESENTS A PREVIOUSLY-DEFINED VARIABLE (VECTOR)
24233C              Y REPRESENTS A PREVIOUSLY-DEFINED VARIABLE (VECTOR)
24234C              U REPRESENTS AN UNYET-DEFINED TERM
24235C              I REPRESENTS A DUMMY VARIABLE
24236C                     --LET A    = I                         (ILLEGAL)
24237C                     --LET A    = X(2)                      (A PARAMETER)
24238C                     --LET A    = 3*SIN(4)                  (A PARAMETER)
24239C                     --LET A    = B*SIN(B)                  (A PARAMETER)
24240C                     --LET A    = X*SIN(X)                  (ILLEGAL)
24241C
24242C                     --LET Y    = I                         (ILLEGAL)
24243C                     --LET Y    = X(2)                      (ILLEGAL)
24244C                     --LET Y    = 3*SIN(4)                  (ILLEGAL)
24245C                     --LET Y    = B*SIN(B)                  (ILLEGAL)
24246C                     --LET Y    = X*SIN(X)                  (A FULL VARIABLE)
24247C
24248C                     --LET Y(I) = I                         (A FULL VARIABLE)
24249C                     --LET Y(I) = X(2)                      (A FULL VARIABLE)
24250C                     --LET Y(I) = 3*SIN(4)                  (A FULL VARIABLE)
24251C                     --LET Y(I) = B*SIN(B)                  (A FULL VARIABLE)
24252C                     --LET Y(I) = X*SIN(X)                  (A FULL VARIABLE)
24253C
24254C                     --LET Y(2) = I                         (ILLEGAL)
24255C                     --LET Y(2) = X(2)                      (AN EL. OF A VAR.)
24256C                     --LET Y(2) = 3*SIN(4)                  (AN EL. OF A VAR.)
24257C                     --LET Y(2) = B*SIN(B)                  (AN EL. OF A VAR.)
24258C                     --LET Y(2) = X*SIN(X)                  (ILLEGAL)
24259C
24260C                     --LET U    = I                         (ILLEGAL)
24261C                     --LET U    = X(2)                      (A PARAMETER)
24262C                     --LET U    = 3*SIN(4)                  (A PARAMETER)
24263C                     --LET U    = B*SIN(B)                  (A PARAMETER)
24264C                     --LET U    = X*SIN(X)                  (A FULL VARIABLE)
24265C
24266C                     --LET U(I) = I                         (ILLEGAL)
24267C                     --LET U(I) = X(2)                      (ILLEGAL)
24268C                     --LET U(I) = 3*SIN(4)                  (ILLEGAL)
24269C                     --LET U(I) = B*SIN(B)                  (ILLEGAL)
24270C                     --LET U(I) = X*SIN(X)                  (A FULL VARIABLE)
24271C
24272C                     --LET U(2) = I                         (ILLEGAL)
24273C                     --LET U(2) = X(2)                      (AN EL. OF A VAR.)
24274C                     --LET U(2) = 3*SIN(4)                  (AN EL. OF A VAR.)
24275C                     --LET U(2) = B*SIN(B)                  (AN EL. OF A VAR.)
24276C                     --LET U(2) = X*SIN(X)                  (ILLEGAL)
24277C                ********************************
24278C
24279C                     --LET A    = I         SUBSET 2 3 5    (ILLEGAL)
24280C                     --LET A    = X(2)      SUBSET 2 3 5    (ILLEGAL)
24281C                     --LET A    = 3*SIN(4)  SUBSET 2 3 5    (ILLEGAL)
24282C                     --LET A    = B*SIN(B)  SUBSET 2 3 5    (ILLEGAL)
24283C                     --LET A    = X*SIN(X)  SUBSET 2 3 5    (ILLEGAL)
24284C
24285C                     --LET Y    = I         SUBSET 2 3 5    (A PARTIAL VAR.)
24286C                     --LET Y    = X(2)      SUBSET 2 3 5    (A PARTIAL VAR.)
24287C                     --LET Y    = 3*SIN(4)  SUBSET 2 3 5    (A PARTIAL VAR.)
24288C                     --LET Y    = B*SIN(B)  SUBSET 2 3 5    (A PARTIAL VAR.)
24289C                     --LET Y    = X*SIN(X)  SUBSET 2 3 5    (A PARTIAL VAR.)
24290C
24291C                     --LET Y(I) = I         SUBSET 2 3 5    (A PARTIAL VAR.)
24292C                     --LET Y(I) = X(2)      SUBSET 2 3 5    (A PARTIAL VAR.)
24293C                     --LET Y(I) = 3*SIN(4)  SUBSET 2 3 5    (A PARTIAL VAR.)
24294C                     --LET Y(I) = B*SIN(B)  SUBSET 2 3 5    (A PARTIAL VAR.)
24295C                     --LET Y(I) = X*SIN(X)  SUBSET 2 3 5    (A PARTIAL VAR.)
24296C
24297C                     --LET Y(2) = I         SUBSET 2 3 5    (ILLEGAL)
24298C                     --LET Y(2) = X(2)      SUBSET 2 3 5    (ILLEGAL)
24299C                     --LET Y(2) = 3*SIN(4)  SUBSET 2 3 5    (ILLEGAL)
24300C                     --LET Y(2) = B*SIN(B)  SUBSET 2 3 5    (ILLEGAL)
24301C                     --LET Y(2) = X*SIN(X)  SUBSET 2 3 5    (ILLEGAL)
24302C
24303C                     --LET U    = I         SUBSET 2 3 5    (A PARTIAL VAR.)
24304C                     --LET U    = X(2)      SUBSET 2 3 5    (A PARTIAL VAR.)
24305C                     --LET U    = 3*SIN(4)  SUBSET 2 3 5    (A PARTIAL VAR.)
24306C                     --LET U    = B*SIN(B)  SUBSET 2 3 5    (A PARTIAL VAR.)
24307C                     --LET U    = X*SIN(X)  SUBSET 2 3 5    (A PARTIAL VAR.)
24308C
24309C                     --LET U(I) = I         SUBSET 2 3 5    (A PARTIAL VAR.)
24310C                     --LET U(I) = X(2)      SUBSET 2 3 5    (A PARTIAL VAR.)
24311C                     --LET U(I) = 3*SIN(4)  SUBSET 2 3 5    (A PARTIAL VAR.)
24312C                     --LET U(I) = B*SIN(B)  SUBSET 2 3 5    (A PARTIAL VAR.)
24313C                     --LET U(I) = X*SIN(X)  SUBSET 2 3 5    (A PARTIAL VAR.)
24314C
24315C                     --LET U(2) = I         SUBSET 2 3 5    (ILLEGAL)
24316C                     --LET U(2) = X(2)      SUBSET 2 3 5    (ILLEGAL)
24317C                     --LET U(2) = 3*SIN(4)  SUBSET 2 3 5    (ILLEGAL)
24318C                     --LET U(2) = B*SIN(B)  SUBSET 2 3 5    (ILLEGAL)
24319C                     --LET U(2) = X*SIN(X)  SUBSET 2 3 5    (ILLEGAL)
24320C
24321C                ********************************
24322C
24323C                     --LET A    = I         FOR I = 1 2 10  (ILLEGAL)
24324C                     --LET A    = X(2)      FOR I = 1 2 10  (ILLEGAL)
24325C                     --LET A    = 3*SIN(4)  FOR I = 1 2 10  (ILLEGAL)
24326C                     --LET A    = B*SIN(B)  FOR I = 1 2 10  (ILLEGAL)
24327C                     --LET A    = X*SIN(X)  FOR I = 1 2 10  (ILLEGAL)
24328C
24329C                     --LET Y    = I         FOR I = 1 2 10  (A PARTIAL VAR.)
24330C                     --LET Y    = X(2)      FOR I = 1 2 10  (A PARTIAL VAR.)
24331C                     --LET Y    = 3*SIN(4)  FOR I = 1 2 10  (A PARTIAL VAR.)
24332C                     --LET Y    = B*SIN(B)  FOR I = 1 2 10  (A PARTIAL VAR.)
24333C                     --LET Y    = X*SIN(X)  FOR I = 1 2 10  (A PARTIAL VAR.)
24334C
24335C                     --LET Y(I) = I         FOR I = 1 2 10  (A PARTIAL VAR.)
24336C                     --LET Y(I) = X(2)      FOR I = 1 2 10  (A PARTIAL VAR.)
24337C                     --LET Y(I) = 3*SIN(4)  FOR I = 1 2 10  (A PARTIAL VAR.)
24338C                     --LET Y(I) = B*SIN(B)  FOR I = 1 2 10  (A PARTIAL VAR.)
24339C                     --LET Y(I) = X*SIN(X)  FOR I = 1 2 10  (A PARTIAL VAR.)
24340C
24341C                     --LET Y(2) = I         FOR I = 1 2 10  (ILLEGAL)
24342C                     --LET Y(2) = X(2)      FOR I = 1 2 10  (ILLEGAL)
24343C                     --LET Y(2) = 3*SIN(4)  FOR I = 1 2 10  (ILLEGAL)
24344C                     --LET Y(2) = B*SIN(B)  FOR I = 1 2 10  (ILLEGAL)
24345C                     --LET Y(2) = X*SIN(X)  FOR I = 1 2 10  (ILLEGAL)
24346C
24347C                     --LET U    = I         FOR I = 1 2 10  (A PARTIAL VAR.)
24348C                     --LET U    = X(2)      FOR I = 1 2 10  (A PARTIAL VAR.)
24349C                     --LET U    = 3*SIN(4)  FOR I = 1 2 10  (A PARTIAL VAR.)
24350C                     --LET U    = B*SIN(B)  FOR I = 1 2 10  (A PARTIAL VAR.)
24351C                     --LET U    = X*SIN(X)  FOR I = 1 2 10  (A PARTIAL VAR.)
24352C
24353C                     --LET U(I) = I         FOR I = 1 2 10  (A PARTIAL VAR.)
24354C                     --LET U(I) = X(2)      FOR I = 1 2 10  (A PARTIAL VAR.)
24355C                     --LET U(I) = 3*SIN(4)  FOR I = 1 2 10  (A PARTIAL VAR.)
24356C                     --LET U(I) = B*SIN(B)  FOR I = 1 2 10  (A PARTIAL VAR.)
24357C                     --LET U(I) = X*SIN(X)  FOR I = 1 2 10  (A PARTIAL VAR.)
24358C
24359C                     --LET U(2) = I         FOR I = 1 2 10  (ILLEGAL)
24360C                     --LET U(2) = X(2)      FOR I = 1 2 10  (ILLEGAL)
24361C                     --LET U(2) = 3*SIN(4)  FOR I = 1 2 10  (ILLEGAL)
24362C                     --LET U(2) = B*SIN(B)  FOR I = 1 2 10  (ILLEGAL)
24363C                     --LET U(2) = X*SIN(X)  FOR I = 1 2 10  (ILLEGAL)
24364C
24365C     WRITTEN BY--JAMES J. FILLIBEN
24366C                 STATISTICAL ENGINEERING DIVISION
24367C                 INFORMATION TECHNOLOGY LABORATORY
24368C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
24369C                 GAITHERSBURG, MD 20899-8980
24370C                 PHONE--301-975-2855
24371C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
24372C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
24373C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
24374C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
24375C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
24376C     LANGUAGE--ANSI FORTRAN (1977)
24377C     VERSION NUMBER--82/7
24378C     ORIGINAL VERSION (IN DPLET)--DECEMBER 1977.
24379C     ORIGINAL VERSION AS A SEPARATE SUBROUTINE--MARCH 1978.
24380C     UPDATED         --MAY       1982.
24381C     UPDATED         --JULY      1978.
24382C     UPDATED         --NOVEMBER  1978.
24383C     UPDATED         --FEBRUARY  1979.
24384C     UPDATED         --MARCH     1979.
24385C     UPDATED         --JUNE      1981.
24386C     UPDATED         --SEPTEMBER 1981.
24387C     UPDATED         --OCTOBER   1981.
24388C     UPDATED         --NOVEMBER  1981.
24389C     UPDATED         --JANUARY   1982.
24390C     UPDATED         --APRIL     1982.
24391C     UPDATED         --MARCH     1986.
24392C     UPDATED         --JANUARY   1988.  CUTOFF VALUE FOR CDC COMPUTERS
24393C     UPDATED         --MARCH     1988.  FIX LET PRED=... SUBSET/FOR/ALL
24394C     UPDATED         --DECEMBER  1988.  FIX LET Y(K) = X(K) INSIDE LOOP
24395C     UPDATED         --FEBRUARY  1989.  CUTOFF VALUE FOR CDC 205 COMPUTER
24396C     UPDATED         --MARCH     2003.  FOR PARAMETERS, CHECK FOR
24397C                                        IVALUE > LARGEST MACHINE
24398C                                        INTEGER
24399C     UPDATED         --FEBRUARY  2005.  IF FUNCTION DEFINED WITH
24400C                                        "LET STRING", CASE PRESERVED.
24401C                                        WHEN FUNCTION EXTRACTED IN
24402C                                        THIS CONTEXT, NEED TO
24403C                                        CONVERT LOWER CASE TO UPPER
24404C                                        CASE
24405C     UPDATED         --JULY      2007.  FIX BUG WHEN HAVE EMPTY
24406C                                        SUBSET
24407C
24408C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
24409C
24410      CHARACTER*4 ITYPEH
24411      CHARACTER*4 IW21HO
24412      CHARACTER*4 IW22HO
24413      CHARACTER*4 IA
24414      CHARACTER*4 IPARN
24415      CHARACTER*4 IPARN2
24416      CHARACTER*4 IFOUNZ
24417      CHARACTER*4 ITYPE
24418      CHARACTER*4 IHOL
24419      CHARACTER*4 IHOL2
24420      CHARACTER*4 IERRO1
24421      CHARACTER*4 ITYW1L
24422      CHARACTER*4 ICAT1L
24423      CHARACTER*4 INLI1L
24424      CHARACTER*4 ITYW2L
24425      CHARACTER*4 ITYW1R
24426      CHARACTER*4 ICAT1R
24427      CHARACTER*4 INLI1R
24428      CHARACTER*4 ITYW2R
24429      CHARACTER*4 IANGLU
24430      CHARACTER*4 IBUGA3
24431      CHARACTER*4 IBUGCO
24432      CHARACTER*4 IBUGEV
24433      CHARACTER*4 IBUGQ
24434      CHARACTER*4 ISUBRO
24435      CHARACTER*4 IFOUND
24436      CHARACTER*4 IERROR
24437C
24438      CHARACTER*4 IWD1
24439      CHARACTER*4 IWD2
24440      CHARACTER*4 IWD12
24441      CHARACTER*4 IWD22
24442      CHARACTER*4 IVOLDR
24443      CHARACTER*4 IVOLR2
24444      CHARACTER*4 IHWUSE
24445      CHARACTER*4 MESSAG
24446      CHARACTER*4 NEWNAM
24447      CHARACTER*4 NEWCOL
24448      CHARACTER*4 IVNEWR
24449      CHARACTER*4 IVNER2
24450      CHARACTER*4 ICASEL
24451      CHARACTER*4 ICASER
24452      CHARACTER*4 ICASEQ
24453      CHARACTER*4 ICASIF
24454      CHARACTER*4 IPJ
24455      CHARACTER*4 IPJ2
24456      CHARACTER*4 IHSET
24457      CHARACTER*4 IHSET2
24458      CHARACTER*4 ILEFT
24459      CHARACTER*4 ILEFT2
24460      CHARACTER*4 IRIGHT
24461      CHARACTER*4 IRIGH2
24462      CHARACTER*4 IARG4F
24463      CHARACTER*4 IARG4T
24464C
24465      CHARACTER*4 ISUBN1
24466      CHARACTER*4 ISUBN2
24467      CHARACTER*4 ISTEPN
24468C
24469      INCLUDE 'DPCOPA.INC'
24470      INCLUDE 'DPCOZC.INC'
24471      CHARACTER*4 IFSAVE(MAXF1)
24472      EQUIVALENCE (CGARBG(1),IFSAVE(1))
24473C
24474C---------------------------------------------------------------------
24475C
24476      DIMENSION IFOUNZ(*)
24477      DIMENSION IBEGIN(*)
24478      DIMENSION IEND(*)
24479      DIMENSION ITYPE(*)
24480      DIMENSION IHOL(*)
24481      DIMENSION IHOL2(*)
24482      DIMENSION INT1(*)
24483      DIMENSION FLOAT1(*)
24484      DIMENSION IERRO1(*)
24485C
24486      DIMENSION ITYPEH(*)
24487      DIMENSION IW21HO(*)
24488      DIMENSION IW22HO(*)
24489      DIMENSION W2HOLD(*)
24490C
24491      DIMENSION IA(*)
24492      DIMENSION PARAM(*)
24493      DIMENSION IPARN(*)
24494      DIMENSION IPARN2(*)
24495C
24496C-----COMMON----------------------------------------------------------
24497C
24498      INCLUDE 'DPCOHK.INC'
24499      INCLUDE 'DPCODA.INC'
24500      INCLUDE 'DPCOHO.INC'
24501      INCLUDE 'DPCOMC.INC'
24502      INCLUDE 'DPCOP2.INC'
24503C
24504C-----START POINT-----------------------------------------------------
24505C
24506      ISUBN1='DPFU'
24507      ISUBN2='EV  '
24508C
24509      NILEFT=0
24510      NIRIGH=0
24511      ICOLR=0
24512C
24513C  CONVERT FUNCTION TABLE TO UPPER CASE, BUT SAVE ORIGINAL FIRST
24514C
24515      DO10I=1,NUMCHF
24516        IFSAVE(I)=IFUNC(I)
24517CCCCC   CALL DPCOAN(IFSAVE(I)(1:1),IATEMP)
24518CCCCC   IF(IATEMP.GE.97 .AND. IATEMP.LE.122)THEN
24519CCCCC     IATEMP=IATEMP-32
24520CCCCC     CALL DPCONA(IATEMP,IFSAVE(I)(1:1))
24521CCCCC   ENDIF
24522   10 CONTINUE
24523C
24524      MAXCP1=MAXCOL+1
24525      MAXCP2=MAXCOL+2
24526      MAXCP3=MAXCOL+3
24527      MAXCP4=MAXCOL+4
24528      MAXCP5=MAXCOL+5
24529      MAXCP6=MAXCOL+6
24530C
24531      IFOUND='NO'
24532      IERROR='NO'
24533C
24534C               *******************************************************
24535C               **  TREAT THE CASE OF A GENERAL FUNCTION EVALUATION  **
24536C               **        1) FOR A PARAMETER,                        **
24537C               **        2) FOR A FULL VARIABLE, OR                 **
24538C               **        3) FOR PART OF A VARIABLE.                 **
24539C               *******************************************************
24540C
24541      IF(IBUGA3.EQ.'ON')THEN
24542        WRITE(ICOUT,999)
24543  999   FORMAT(1X)
24544        CALL DPWRST('XXX','BUG ')
24545        WRITE(ICOUT,51)
24546   51   FORMAT('***** AT THE BEGINNING OF DPFUEV--')
24547        CALL DPWRST('XXX','BUG ')
24548        WRITE(ICOUT,53)IBUGA3,IBUGCO,IBUGEV,IBUGQ,IANGLU
24549   53   FORMAT('IBUGA3,IBUGCO,IBUGEV,IBUGQ,IANGLU = ',4(A4,2X),A4)
24550        CALL DPWRST('XXX','BUG ')
24551        WRITE(ICOUT,55)ICAT1L,ITYW1L,ITYW2L,IERRO1(1)
24552   55   FORMAT('ICAT1L,ITYW1L,ITYW2L,IERROR(1) = ',3(A4,2X),A4)
24553        CALL DPWRST('XXX','BUG ')
24554        WRITE(ICOUT,56)NUMAOL,NUMCL,NUMPL
24555   56   FORMAT('NUMAOL,NUMCL,NUMPL = ',3I8)
24556        CALL DPWRST('XXX','BUG ')
24557        WRITE(ICOUT,57)NUMNAM,IBEGIN(1),IEND(1),INLI1L
24558   57   FORMAT('NUMNAM,IBEGIN(1),IEND(1),INLI1L = ',4I8)
24559        CALL DPWRST('XXX','BUG ')
24560        DO60I=1,NUMNAM
24561          WRITE(ICOUT,61)I,IHNAME(I),IHNAM2(I),IUSE(I),
24562     1                   IVALUE(I),VALUE(I)
24563   61     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVALUE(I),VALUE(I) = ',
24564     1           I8,3(2X,A4),I8,G15.7)
24565          CALL DPWRST('XXX','BUG ')
24566   60   CONTINUE
24567      ENDIF
24568C
24569C               **********************************
24570C               **  STEP 1--                    **
24571C               **  INITIALIZE SOME VARIABLES.  **
24572C               **********************************
24573C
24574      ISTEPN='1'
24575      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24576C
24577      NEWNAM='NO'
24578      NEWCOL='NO'
24579C
24580      MAXN2=MAXCHF
24581      MAXN3=MAXCHF
24582      MAXN4=MAXCHF
24583C
24584      IF(IBUGA3.EQ.'OFF')GOTO99
24585      WRITE(ICOUT,91)
24586   91 FORMAT('I,IFOUNZ(I),ITYPE(I),IHOL(I),IHOL2(I),INT1(I),',
24587     1'FLOAT1(I)--')
24588      CALL DPWRST('XXX','BUG ')
24589      DO92I=1,30
24590      WRITE(ICOUT,93)I,IFOUNZ(I),ITYPE(I),IHOL(I),IHOL2(I),INT1(I),
24591     1FLOAT1(I)
24592   93 FORMAT(I3,2X,A4,2X,A4,2X,A4,2X,A4,2X,I8,2X,E15.7)
24593      CALL DPWRST('XXX','BUG ')
24594   92 CONTINUE
24595   99 CONTINUE
24596C
24597C               ****************************************************************
24598C               **  STEP 2--                                                   *
24599C               **  EXAMINE THE LEFT-HAND SIDE--                               *
24600C               **  IS THE PARAMETER OR VARIABLE NAME TO LEFT OF = SIGN        *
24601C               **  ALREADY IN THE NAME LIST?                                  *
24602C               **  IS IT A PARAMETER OR A VARIABLE?                           *
24603C               **  NOTE THAT     ILEFT     IS THE NAME OF THE VARIABLE        *
24604C               **  ON THE LEFT.                                               *
24605C               **  NOTE THAT     ILISTL    IS THE LINE IN THE TABLE           *
24606C               **  OF THE NAME ON THE LEFT.                                   *
24607C               **  NOTE THAT     ICOLL    IS THE DATA COLUMN (1 TO 12)        *
24608C               **  FOR THE NAME OF THE LEFT.                                  *
24609C               **  WHEN THIS STEP IS FINISHED,                                *
24610C               **  ICASEL   WILL HAVE ONE OF THE FOLLOWING 3 VALUES--         *
24611C               **           1) PARAM                                          *
24612C               **           2) VAR                                            *
24613C               **           3) UNKNOWN (YET TO BE DEFINED; DEPENDS ON RIGHT). *
24614C               ****************************************************************
24615C               ****************************************************************
24616C
24617      ISTEPN='2'
24618      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24619C
24620      ICASEL='UNKN'
24621      ILEFT=IHOL(2)
24622      ILEFT2=IHOL2(2)
24623      DO2000I=1,NUMNAM
24624      I2=I
24625      IF(ILEFT.EQ.IHNAME(I).AND.ILEFT2.EQ.IHNAM2(I).AND.
24626     1IUSE(I).EQ.'P')GOTO2500
24627      IF(ILEFT.EQ.IHNAME(I).AND.ILEFT2.EQ.IHNAM2(I).AND.
24628     1IUSE(I).EQ.'V')GOTO2600
24629 2000 CONTINUE
24630      ICASEL='UNKN'
24631      NEWNAM='YES'
24632      ILISTL=NUMNAM+1
24633      IF(ILISTL.GT.MAXNAM)GOTO2800
24634      IN(ILISTL)=0
24635      GOTO2900
24636C
24637 2500 CONTINUE
24638      ICASEL='PARA'
24639      ILISTL=I2
24640      GOTO2900
24641C
24642 2600 CONTINUE
24643      ICASEL='VAR'
24644      ILISTL=I2
24645      ICOLL=IVALUE(ILISTL)
24646      NILEFT=IN(ILISTL)
24647      GOTO2900
24648C
24649 2800 CONTINUE
24650      WRITE(ICOUT,999)
24651      CALL DPWRST('XXX','BUG ')
24652      WRITE(ICOUT,2801)
24653 2801 FORMAT('***** ERROR IN DPFUEV AT 2801--')
24654      CALL DPWRST('XXX','BUG ')
24655      WRITE(ICOUT,2802)
24656 2802 FORMAT('      THE NUMBER OF VARIABLE AND/OR PARAMETER')
24657      CALL DPWRST('XXX','BUG ')
24658      WRITE(ICOUT,2803)MAXNAM
24659 2803 FORMAT('      NAMES HAS JUST EXCEEDED THE MAX ALLOWABLE ',
24660     1I8,'  .')
24661      CALL DPWRST('XXX','BUG ')
24662      WRITE(ICOUT,2804)
24663 2804 FORMAT('      SUGGESTED ACTION--')
24664      CALL DPWRST('XXX','BUG ')
24665      WRITE(ICOUT,2805)
24666 2805 FORMAT('      ENTER      STAT')
24667      CALL DPWRST('XXX','BUG ')
24668      WRITE(ICOUT,2806)
24669 2806 FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES,')
24670      CALL DPWRST('XXX','BUG ')
24671      WRITE(ICOUT,2807)
24672 2807 FORMAT('      AND THEN REDEFINE (REUSE) SOME OF THE')
24673      CALL DPWRST('XXX','BUG ')
24674      WRITE(ICOUT,2808)
24675 2808 FORMAT('      ALREADY-USED NAMES')
24676      CALL DPWRST('XXX','BUG ')
24677      IERROR='YES'
24678      GOTO19000
24679C
24680 2900 CONTINUE
24681C
24682C               **************************************************
24683C               **  STEP 3--                                    **
24684C               **  EXAMINE THE RIGHT-HAND SIDE--               **
24685C               **  1)  FIRST, SCREEN OUT THE DUMMY             **
24686C               **      AND THE ELEMENT SPECIFICATION CASES;    **
24687C               **  2)  THEN EXTRACT THE FUNCTIONAL EXPRESSION; **
24688C               **  3)  DETERMINE THE TYPE OF QUALIFIERS--      **
24689C               **      A)  NONE (= FULL = UNQUALIFIED);        **
24690C               **      B)  SUBSET/EXCEPT; OR                   **
24691C               **      C)  FOR.                                **
24692C               **  4)  EXAMINE THE FUNCTION    AL EXPRESSION   **
24693C               **      FOR PARAMETERS AND VARIABLES.           **
24694C               **  WHEN THIS STEP IS FINISHED,                 **
24695C               **  ICASER  WILL BE FULLY DETERMINED AND        **
24696C               **  WILL HAVE ONE OF THE FOLLOWING 4 VALUES--   **
24697C               **          1) DUMMY;                           **
24698C               **          2) ELEMENT;                         **
24699C               **          3) PARAM (NO VARIABLES);            **
24700C               **          4) VAR (AT LEAST ONE VARIABLE).     **
24701C               **  WHEN THIS STEP IS FINISHED,                 **
24702C               **  ICASEQ  WILL BE FILLY DETERMINED AND        **
24703C               **  WILL HAVE ONE OF THE FOLLOWING 3 VALUES--   **
24704C               **          1) FULL;                            **
24705C               **          2) SUBSET/EXCEPT OR;                **
24706C               **          3) FOR.                             **
24707C               **************************************************
24708C
24709      ISTEPN='3'
24710      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24711C
24712      ICASER='UNKN'
24713      ICASEQ='UNKN'
24714      IF(NUMCR.EQ.1.AND.NUMPR.EQ.0.AND.NUMAOR.EQ.0.
24715     1AND.ITYW1R.EQ.'WORD'.AND.INLI1R.EQ.'NO')GOTO3010
24716      IF(1.LE.NUMCR.AND.NUMCR.LE.4.AND.NUMPR.EQ.2.AND.NUMAOR.EQ.0.
24717     1AND.ITYW1R.EQ.'WORD'.AND.ICAT1R.EQ.'VARP'.
24718     1AND.INLI1R.EQ.'YES'.AND.ITYW2R.EQ.'NUMB')GOTO3020
24719      IF(1.LE.NUMCR.AND.NUMCR.LE.4.AND.NUMPR.EQ.2.AND.NUMAOR.EQ.0.
24720     1AND.ITYW1R.EQ.'WORD'.AND.ICAT1R.EQ.'VARP'.
24721     1AND.INLI1R.EQ.'YES'.AND.ITYW2R.EQ.'WORD')GOTO3020
24722      GOTO3090
24723C
24724 3010 CONTINUE
24725      ICASER='DUMM'
24726      IF(IFOUNZ(11).EQ.'NO'.AND.IFOUNZ(21).EQ.'NO')ICASEQ='FULL'
24727      IF(IFOUNZ(11).EQ.'YES')ICASEQ='SUBS'
24728      IF(IFOUNZ(21).EQ.'YES')ICASEQ='FOR'
24729      GOTO3990
24730C
24731 3020 CONTINUE
24732      ICASER='ELEM'
24733      IRIGHT=IHOL(7)
24734      IRIGH2=IHOL2(7)
24735      DO3030I=1,NUMNAM
24736      I2=I
24737      IF(IRIGHT.EQ.IHNAME(I).AND.IRIGH2.EQ.IHNAM2(I).AND.
24738     1IUSE(I).EQ.'P')GOTO3040
24739      IF(IRIGHT.EQ.IHNAME(I).AND.IRIGH2.EQ.IHNAM2(I).AND.
24740     1IUSE(I).EQ.'V')GOTO3050
24741 3030 CONTINUE
24742C
24743      WRITE(ICOUT,999)
24744      CALL DPWRST('XXX','BUG ')
24745      WRITE(ICOUT,3031)
24746 3031 FORMAT('***** ERROR IN DPFUEV--')
24747      CALL DPWRST('XXX','BUG ')
24748      WRITE(ICOUT,3032)
24749 3032 FORMAT('      THE VARIABLE NAME ON THE RIGHT')
24750      CALL DPWRST('XXX','BUG ')
24751      WRITE(ICOUT,3033)
24752 3033 FORMAT('      OF THE = SIGN')
24753      CALL DPWRST('XXX','BUG ')
24754      WRITE(ICOUT,3034)
24755 3034 FORMAT('      WAS NOT FOUND IN THE INTERNAL NAME LIST.')
24756      CALL DPWRST('XXX','BUG ')
24757      WRITE(ICOUT,3035)
24758 3035 FORMAT('      THE COMMAND LINE WAS AS FOLLOWS--')
24759      CALL DPWRST('XXX','BUG ')
24760      WRITE(ICOUT,3036)(IANS(I),I=1,IWIDTH)
24761 3036 FORMAT(80A1)
24762      CALL DPWRST('XXX','BUG ')
24763      IERROR='YES'
24764      GOTO19000
24765C
24766 3040 CONTINUE
24767      WRITE(ICOUT,999)
24768      CALL DPWRST('XXX','BUG ')
24769      WRITE(ICOUT,3041)
24770 3041 FORMAT('***** ERROR IN DPFUEV--')
24771      CALL DPWRST('XXX','BUG ')
24772      WRITE(ICOUT,3042)
24773 3042 FORMAT('      THE VARIABLE NAME ON THE RIGHT')
24774      CALL DPWRST('XXX','BUG ')
24775      WRITE(ICOUT,3043)
24776 3043 FORMAT('      OF THE = SIGN')
24777      CALL DPWRST('XXX','BUG ')
24778      WRITE(ICOUT,3044)
24779 3044 FORMAT('      WAS FOUND IN THE INTERNAL NAME LIST,')
24780      CALL DPWRST('XXX','BUG ')
24781      WRITE(ICOUT,3045)
24782 3045 FORMAT('      BUT AS A PARAMETER,')
24783      CALL DPWRST('XXX','BUG ')
24784      WRITE(ICOUT,3046)
24785 3046 FORMAT('      AND NOT AS A VARIABLE AS IT SHOULD BE HERE.')
24786      CALL DPWRST('XXX','BUG ')
24787      WRITE(ICOUT,3047)
24788 3047 FORMAT('      THE COMMAND LINE WAS AS FOLLOWS--')
24789      CALL DPWRST('XXX','BUG ')
24790      WRITE(ICOUT,3048)(IANS(I),I=1,IWIDTH)
24791 3048 FORMAT(80A1)
24792      CALL DPWRST('XXX','BUG ')
24793      IERROR='YES'
24794      GOTO19000
24795C
24796 3050 CONTINUE
24797      ILISTR=I2
24798      ICOLR=IVALUE(ILISTR)
24799      NIRIGH=IN(ILISTR)
24800C
24801      IARGIR=INT1(9)
24802      IF(1.LE.IARGIR.AND.IARGIR.LE.MAXN)GOTO3060
24803      WRITE(ICOUT,3061)
24804 3061 FORMAT('***** ERROR IN DPFUEV')
24805      CALL DPWRST('XXX','BUG ')
24806      WRITE(ICOUT,3062)
24807 3062 FORMAT('      THE SPECIFIED ARGUMENT (ROW NUMBER)')
24808      CALL DPWRST('XXX','BUG ')
24809      WRITE(ICOUT,3063)
24810 3063 FORMAT('      ON THE RIGHT SIDE OF THE = SIGN')
24811      CALL DPWRST('XXX','BUG ')
24812      WRITE(ICOUT,3064)
24813 3064 FORMAT('      IS SMALLER THAN 1 OR')
24814      CALL DPWRST('XXX','BUG ')
24815      WRITE(ICOUT,3065)
24816 3065 FORMAT('      LARGER THAN THE MAXIMUM ALLOWABLE NUMBER  ')
24817      CALL DPWRST('XXX','BUG ')
24818      WRITE(ICOUT,3066)MAXN
24819 3066 FORMAT('      (',I6,')  FOR A GIVEN VARIABLE.')
24820      CALL DPWRST('XXX','BUG ')
24821      WRITE(ICOUT,3067)IARGIR
24822 3067 FORMAT('      THE VALUE (IARGIR) = ',I8)
24823      CALL DPWRST('XXX','BUG ')
24824      WRITE(ICOUT,3068)
24825 3068 FORMAT('      THE COMMAND LINE WAS AS FOLLOWS--')
24826      CALL DPWRST('XXX','BUG ')
24827      WRITE(ICOUT,3069)(IANS(I),I=1,IWIDTH)
24828 3069 FORMAT(80A1)
24829      CALL DPWRST('XXX','BUG ')
24830      IERROR='YES'
24831      GOTO19000
24832C
24833 3060 CONTINUE
24834      IF(IFOUNZ(11).EQ.'NO'.AND.IFOUNZ(21).EQ.'NO')ICASEQ='FULL'
24835      IF(IFOUNZ(11).EQ.'YES')ICASEQ='SUBS'
24836      IF(IFOUNZ(21).EQ.'YES')ICASEQ='FOR'
24837      GOTO3990
24838C
24839 3090 CONTINUE
24840      ICASEQ='UNKN'
24841C
24842C     LOCATE THE EQUAL SIGN.
24843C
24844      DO3100I=1,IWIDTH
24845      I2=I
24846      IF(IANS(I).EQ.'=')GOTO3150
24847 3100 CONTINUE
24848      GOTO3400
24849 3150 CONTINUE
24850      ISTART=I2
24851C
24852      IF(ISTART.GT.IWIDTH)GOTO3400
24853      DO3200I=ISTART,IWIDTH
24854      I2=I
24855      IP1=I+1
24856      IP2=I+2
24857      IP3=I+3
24858      IP4=I+4
24859      IP5=I+5
24860      IP6=I+6
24861      IP7=I+7
24862      IF(IP7.GT.IWIDTH)GOTO3230
24863      IF(IANS(I).EQ.' '.AND.IANS(IP1).EQ.'S'.AND.IANS(IP2).EQ.'U'
24864     1.AND.IANS(IP3).EQ.'B'.AND.IANS(IP4).EQ.'S'.AND.IANS(IP5).EQ.'E'
24865     1.AND.IANS(IP6).EQ.'T'.AND.IANS(IP7).EQ.' ')GOTO3250
24866      IF(IANS(I).EQ.' '.AND.IANS(IP1).EQ.'F'.AND.IANS(IP2).EQ.'O'
24867     1.AND.IANS(IP3).EQ.'R'.AND.IANS(IP4).EQ.' ')GOTO3270
24868      IF(IANS(I).EQ.' '.AND.IANS(IP1).EQ.'I'.AND.IANS(IP2).EQ.'F'
24869     1.AND.IANS(IP3).EQ.' ')GOTO3280
24870 3200 CONTINUE
24871C
24872 3230 CONTINUE
24873      ICASEQ='FULL'
24874      ISTOP=IWIDTH
24875      GOTO3290
24876C
24877 3250 CONTINUE
24878      ICASEQ='SUBS'
24879      ISTOP=I2
24880      GOTO3290
24881C
24882 3270 CONTINUE
24883      ICASEQ='FOR'
24884      ISTOP=I2
24885      GOTO3290
24886C
24887 3280 CONTINUE
24888      ICASEQ='IF'
24889      ISTOP=I2
24890      GOTO3290
24891C
24892 3290 CONTINUE
24893C
24894C               ***************************************
24895C               **  STEP 3.1--                       **
24896C               **  EXTRACT THE UNDERLYING FUNCTION  **
24897C               **  FROM FUNCTION DEFINITIONS.       **
24898C               ***************************************
24899C
24900      ISTEPN='3.1'
24901      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24902C
24903CCCCC J=0
24904CCCCC IMIN=ISTART+1
24905CCCCC DO3370I=IMIN,ISTOP
24906CCCCC J=J+1
24907CCCCC IA(J)=IANS(I)
24908C3370 CONTINUE
24909CCCCC NUMCHA=J
24910C
24911      IWD1='=   '
24912      IWD12='    '
24913      IF(ICASEQ.EQ.'FULL')IWD2='    '
24914      IF(ICASEQ.EQ.'FULL')IWD22='    '
24915      IF(ICASEQ.EQ.'SUBS'.AND.IHOL(11).EQ.'SUBS')IWD2='SUBS'
24916      IF(ICASEQ.EQ.'SUBS'.AND.IHOL(11).EQ.'SUBS')IWD22='ET  '
24917      IF(ICASEQ.EQ.'SUBS'.AND.IHOL(11).EQ.'EXCE')IWD2='EXCE'
24918      IF(ICASEQ.EQ.'SUBS'.AND.IHOL(11).EQ.'EXCE')IWD22='PT  '
24919      IF(ICASEQ.EQ.'FOR ')IWD2='FOR '
24920      IF(ICASEQ.EQ.'FOR ')IWD22='    '
24921      IF(ICASEQ.EQ.'IF  ')IWD2='IF  '
24922      IF(ICASEQ.EQ.'IF  ')IWD22='    '
24923      CALL DPEXST(IANS,IWIDTH,IWD1,IWD12,IWD2,IWD22,MAXN2,
24924     1IFUNC2,N2,IBUGA3,IFOUND,IERROR)
24925      IF(IBUGA3.EQ.'ON')WRITE(ICOUT,3011)
24926 3011 FORMAT('***** FROM DPFUEV, AFTER  THE CALL TO DPEXST--')
24927      IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ')
24928      IF(IERROR.EQ.'YES')GOTO19000
24929      IF(IFOUND.EQ.'YES')GOTO3379
24930C
24931      WRITE(ICOUT,999)
24932      CALL DPWRST('XXX','BUG ')
24933      WRITE(ICOUT,3371)
24934 3371 FORMAT('***** ERROR IN DPFUEV--')
24935      CALL DPWRST('XXX','BUG ')
24936      WRITE(ICOUT,3372)
24937 3372 FORMAT('      INVALID COMMAND FORM FOR FUNCTION EVALUATION.')
24938      CALL DPWRST('XXX','BUG ')
24939      WRITE(ICOUT,3373)
24940 3373 FORMAT('      GENERAL FORM--')
24941      CALL DPWRST('XXX','BUG ')
24942      WRITE(ICOUT,3374)
24943 3374 FORMAT('      LET ... = ...  ',
24944     1'SUBSET ... ... ...')
24945      CALL DPWRST('XXX','BUG ')
24946      WRITE(ICOUT,3375)
24947 3375 FORMAT('      THE ENTIRE COMMAND LINE WAS AS FOLLOWS--')
24948      CALL DPWRST('XXX','BUG ')
24949      IF(IWIDTH.GE.1)WRITE(ICOUT,3376)(IANS(I),I=1,IWIDTH)
24950 3376 FORMAT('      ',100A1)
24951      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
24952      IERROR='YES'
24953      GOTO19000
24954 3379 CONTINUE
24955C
24956      IF(IBUGA3.EQ.'ON')WRITE(ICOUT,3012)
24957 3012 FORMAT('***** FROM DPFUEV, BEFORE THE CALL TO DPEXFU--')
24958      IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ')
24959C
24960      DO3018I=1,N2
24961        IA(I)=IFUNC2(I)
24962        ITEMP=ICHAR(IFUNC2(I)(1:1))
24963        IF(ITEMP.GE.97 .AND. ITEMP.LE.122)THEN
24964          ITEMP=ITEMP-32
24965          IFUNC2(I)(1:1)=CHAR(ITEMP)
24966        ENDIF
24967 3018 CONTINUE
24968C
24969      CALL DPEXFU(IFUNC2,N2,IHNAME,IHNAM2,IUSE,IVSTAR,IVSTOP,
24970     1NUMNAM,IANS,IWIDTH,IFUNC,NUMCHF,MAXCHF,IFUNC3,N3,MAXN3,
24971     1IBUGA3,IERROR)
24972      IF(IBUGA3.EQ.'ON')WRITE(ICOUT,3013)
24973 3013 FORMAT('***** FROM DPFUEV, AFTER  THE CALL TO DPEXFU--')
24974      IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ')
24975      IF(IERROR.EQ.'YES')GOTO19000
24976C
24977      J=0
24978      DO3380I=1,N3
24979        J=J+1
24980        IA(J)=IFUNC3(I)
24981        ITEMP=ICHAR(IA(J)(1:1))
24982        IF(ITEMP.GE.97 .AND. ITEMP.LE.122)THEN
24983          ITEMP=ITEMP-32
24984          IA(J)(1:1)=CHAR(ITEMP)
24985        ENDIF
24986 3380 CONTINUE
24987      NUMCHA=J
24988      GOTO3500
24989C
24990 3400 CONTINUE
24991      WRITE(ICOUT,3411)
24992 3411 FORMAT('***** INTERNAL ERROR IN DPFUEV')
24993      CALL DPWRST('XXX','BUG ')
24994      WRITE(ICOUT,3412)
24995 3412 FORMAT('      AT BRANCH POINT 3400--')
24996      CALL DPWRST('XXX','BUG ')
24997      WRITE(ICOUT,3413)
24998 3413 FORMAT('      ISTART GREATER THAN ISTOP.')
24999      CALL DPWRST('XXX','BUG ')
25000      WRITE(ICOUT,3418)
25001 3418 FORMAT('      THE COMMAND LINE WAS AS FOLLOWS--')
25002      CALL DPWRST('XXX','BUG ')
25003      WRITE(ICOUT,3419)(IANS(I),I=1,IWIDTH)
25004 3419 FORMAT(80A1)
25005      CALL DPWRST('XXX','BUG ')
25006      IERROR='YES'
25007      GOTO19000
25008C
25009 3500 CONTINUE
25010      ICASER='UNKN'
25011C
25012      IPASS=1
25013      IF(IBUGA3.EQ.'ON')WRITE(ICOUT,3014)
25014 3014 FORMAT('***** FROM DPFUEV, BEFORE THE CALL TO COMPIM--')
25015      IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ')
25016      CALL COMPIM(IA,NUMCHA,IPASS,PARAM,IPARN,IPARN2,NUMPAR,
25017     1IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,AJUNK,
25018     1IBUGCO,IBUGEV,IERROR)
25019      IF(IBUGA3.EQ.'ON')WRITE(ICOUT,3015)
25020 3015 FORMAT('***** FROM DPFUEV, AFTER  THE CALL TO COMPIM--')
25021      IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ')
25022      IF(IERROR.EQ.'YES')GOTO19000
25023C
25024      NUMP=0
25025      NUMV=0
25026      NIOLDR=0
25027      IVOLDR='JUNK'
25028      IVOLR2='JUNK'
25029      IF(NUMPAR.EQ.0)GOTO3900
25030      DO3600J=1,NUMPAR
25031      DO3700I=1,NUMNAM
25032      I2=I
25033      IF(IPARN(J).EQ.IHNAME(I).AND.IPARN2(J).EQ.IHNAM2(I).AND.
25034     1IUSE(I).EQ.'P')GOTO3850
25035      IF(IPARN(J).EQ.IHNAME(I).AND.IPARN2(J).EQ.IHNAM2(I).AND.
25036     1IUSE(I).EQ.'V')GOTO3870
25037 3700 CONTINUE
25038      GOTO3800
25039C
25040 3850 CONTINUE
25041      NUMP=NUMP+1
25042      GOTO3600
25043C
25044 3870 CONTINUE
25045      NUMV=NUMV+1
25046      NIRIGH=IN(I2)
25047      NIOLDR=NINEWR
25048      IVOLDR=IVNEWR
25049      IVOLR2=IVNER2
25050      NINEWR=IN(I2)
25051      IVNEWR=IHNAME(I2)
25052      IVNER2=IHNAM2(I2)
25053      IF(NUMV.GE.2.AND.NINEWR.NE.NIOLDR)GOTO3820
25054      GOTO3600
25055C
25056 3600 CONTINUE
25057      GOTO3900
25058C
25059 3800 CONTINUE
25060      WRITE(ICOUT,3801)
25061 3801 FORMAT('***** ERROR IN DPFUEV--')
25062      CALL DPWRST('XXX','BUG ')
25063      WRITE(ICOUT,3802)
25064 3802 FORMAT('      A VARIABLE OR PARAMETER NAME USED')
25065      CALL DPWRST('XXX','BUG ')
25066      WRITE(ICOUT,3803)
25067 3803 FORMAT('      IN AN EXPRESSION IS NOT YET DEFINED.')
25068      CALL DPWRST('XXX','BUG ')
25069      WRITE(ICOUT,999)
25070      CALL DPWRST('XXX','BUG ')
25071      WRITE(ICOUT,3804)IPARN(J),IPARN2(J)
25072 3804 FORMAT('      VARIABLE OR PARAMETER NAME = ',A4,A4)
25073      CALL DPWRST('XXX','BUG ')
25074      GOTO3809
25075CCCCC WRITE(ICOUT,999)
25076CCCCC CALL DPWRST('XXX','BUG ')
25077CCCCC WRITE(ICOUT,3805)
25078C3805 FORMAT('      CURRENT LIST OF DEFINED VARIABLES AND ',
25079CCCCC CALL DPWRST('XXX','BUG ')
25080CCCCC1'PARAMETERS--')
25081CCCCC WRITE(ICOUT,999)
25082CCCCC CALL DPWRST('XXX','BUG ')
25083CCCCC DO3806I2=1,NUMNAM
25084CCCCC WRITE(ICOUT,3807)IHNAME(I2),IHNAM2(I2),IUSE(I2),IVALUE(I2),
25085CCCCC CALL DPWRST('XXX','BUG ')
25086CCCCC1VALUE(I2),IN(I2)
25087C3807 FORMAT(6X,A4,A4,6X,A4,6X,I6,6X,E15.6,I6)
25088C3806 CONTINUE
25089CCCCC WRITE(ICOUT,999)
25090CCCCC CALL DPWRST('XXX','BUG ')
25091CCCCC WRITE(ICOUT,3808)(IA(I),I=1,NUMCHA)
25092C3808 FORMAT('      FUNCTION EXPRESSION--'100A1)
25093CCCCC CALL DPWRST('XXX','BUG ')
25094 3809 CONTINUE
25095      IERROR='YES'
25096      GOTO19000
25097C
25098 3820 CONTINUE
25099      WRITE(ICOUT,3821)
25100 3821 FORMAT('***** ERROR IN DPFUEV--')
25101      CALL DPWRST('XXX','BUG ')
25102      WRITE(ICOUT,3822)
25103 3822 FORMAT('      ALL VARIABLES USED')
25104      CALL DPWRST('XXX','BUG ')
25105      WRITE(ICOUT,3823)
25106 3823 FORMAT('      IN A FUNCTIONAL EXPRESSION')
25107      CALL DPWRST('XXX','BUG ')
25108      WRITE(ICOUT,3824)
25109 3824 FORMAT('      MUST HAVE THE SAME LENGTH')
25110      CALL DPWRST('XXX','BUG ')
25111      WRITE(ICOUT,3825)
25112 3825 FORMAT('      (NUMBER OF ELEMENTS);')
25113      CALL DPWRST('XXX','BUG ')
25114      WRITE(ICOUT,3826)
25115 3826 FORMAT('      SUCH WAS NOT THE CASE HERE FOR--')
25116      CALL DPWRST('XXX','BUG ')
25117      WRITE(ICOUT,3827)IVOLDR,IVOLR2,NIOLDR
25118 3827 FORMAT('      VARIABLE ',A4,A4,' WITH ',I8,' ELEMENTS')
25119      CALL DPWRST('XXX','BUG ')
25120      WRITE(ICOUT,3828)IVNEWR,IVNER2,NINEWR
25121 3828 FORMAT('      VARIABLE ',A4,A4,' WITH ',I8,' ELEMENTS')
25122      CALL DPWRST('XXX','BUG ')
25123      WRITE(ICOUT,3829)
25124 3829 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
25125      CALL DPWRST('XXX','BUG ')
25126      IF(IWIDTH.GE.1)WRITE(ICOUT,3830)(IANS(I),I=1,IWIDTH)
25127 3830 FORMAT(80A1)
25128      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
25129      IERROR='YES'
25130      GOTO19000
25131C
25132 3900 CONTINUE
25133      ICASER='VAR'
25134      IF(NUMV.LE.0)ICASER='PARA'
25135C
25136 3990 CONTINUE
25137C
25138C               *******************************
25139C               **  STEP 4--                 **
25140C               **  DETERMINE THE SUBCASE    **
25141C               **  AND BRANCH ACCORDINGLY.  **
25142C               *******************************
25143C
25144      ISTEPN='4'
25145      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25146C
25147      IARG4F=IFOUNZ(4)
25148      IARG4T=ITYPE(4)
25149      IARG4I=INT1(4)
25150      IF(IBUGA3.EQ.'ON')WRITE(ICOUT,4001)ICASEL,ICASER,ICASEQ,
25151     1IARG4F,IARG4T
25152 4001 FORMAT('***** IN DPFUEV, AT START OF STEP 4; ',
25153     1'ICASEL,ICASER,ICASEQ,IARG4F,IARG4T = ',
25154     1A4,1X,A4,1X,A4,1X,A4,1X,A4)
25155      IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ')
25156C
25157      IF(ICASEQ.EQ.'FULL')GOTO4100
25158      IF(ICASEQ.EQ.'SUBS')GOTO4200
25159      IF(ICASEQ.EQ.'FOR')GOTO4300
25160      IF(ICASEQ.EQ.'IF')GOTO4100
25161C
25162 4100 CONTINUE
25163      IF(IBUGA3.EQ.'OFF')GOTO4119
25164      WRITE(ICOUT,999)
25165      CALL DPWRST('XXX','BUG ')
25166      WRITE(ICOUT,4111)
25167 4111 FORMAT('***** IN MIDDLE OF DPFUEV, AT 4100--')
25168      CALL DPWRST('XXX','BUG ')
25169      WRITE(ICOUT,4112)ICASEL,ICASER,IHOL(4),IHOL2(4)
25170 4112 FORMAT('ICASEL,ICASER,IHOL(4),IHOL2(4) = ',
25171     1A4,2X,A4,2X,A4,2X,A4)
25172      CALL DPWRST('XXX','BUG ')
25173      WRITE(ICOUT,4113)IARG4F,IARG4T,IARG4I
25174 4113 FORMAT('IARG4F,IARG4T,IARG4I = ',A4,2X,A4,I8)
25175      CALL DPWRST('XXX','BUG ')
25176 4119 CONTINUE
25177C
25178      IF(ICASEL.EQ.'PARA'.AND.IARG4F.EQ.'NO'.AND.ICASER.EQ.'PARA')
25179     1GOTO5000
25180      IF(ICASEL.EQ.'PARA'.AND.IARG4F.EQ.'NO'.AND.ICASER.EQ.'ELEM')
25181     1GOTO5000
25182      IF(ICASEL.EQ.'VAR'.AND.IARG4F.EQ.'NO'.AND.ICASER.EQ.'VAR')
25183     1GOTO7000
25184C
25185      IF(ICASEL.EQ.'VAR'.AND.IARG4F.EQ.'YES'.AND.IHOL(4).EQ.'I   '.AND.
25186     1IHOL2(4).EQ.'    ')GOTO6000
25187      IF(ICASEL.EQ.'VAR'.AND.IARG4F.EQ.'YES'.AND.IARG4T.EQ.'WORD'.AND.
25188     1IARG4I.LE.0)GOTO7000
25189      IF(ICASEL.EQ.'VAR'.AND.IARG4F.EQ.'YES'.AND.IARG4T.EQ.'WORD'.AND.
25190     1IARG4I.GE.1)GOTO6000
25191      IF(ICASEL.EQ.'VAR'.AND.IARG4F.EQ.'YES'.AND.IARG4T.EQ.'NUMB'
25192     1.AND.ICASER.EQ.'PARA')GOTO6000
25193      IF(ICASEL.EQ.'VAR'.AND.IARG4F.EQ.'YES'.AND.IARG4T.EQ.'NUMB'
25194     1.AND.ICASER.EQ.'ELEM')GOTO6000
25195C
25196      IF(ICASEL.EQ.'UNKN'.AND.IARG4F.EQ.'NO'.AND.ICASER.EQ.'PARA')
25197     1GOTO5000
25198      IF(ICASEL.EQ.'UNKN'.AND.IARG4F.EQ.'NO'.AND.ICASER.EQ.'ELEM')
25199     1GOTO5000
25200      IF(ICASEL.EQ.'UNKN'.AND.IARG4F.EQ.'NO'.AND.ICASER.EQ.'VAR')
25201     1GOTO7000
25202C
25203      IF(ICASEL.EQ.'UNKN'.AND.IARG4F.EQ.'YES'.AND.IARG4T.EQ.'WORD'
25204     1.AND.IARG4I.LE.0.AND.ICASER.EQ.'VAR')GOTO7000
25205      IF(ICASEL.EQ.'UNKN'.AND.IARG4F.EQ.'YES'.AND.IARG4T.EQ.'WORD'
25206     1.AND.IARG4I.GE.1.AND.ICASER.EQ.'VAR')GOTO6000
25207      IF(ICASEL.EQ.'UNKN'.AND.IARG4F.EQ.'YES'.AND.IARG4T.EQ.'WORD'
25208     1.AND.IARG4I.GE.1.AND.ICASER.EQ.'PARA')GOTO6000
25209CCCCC THE FOLLOWING 2 LINES WERE INSERTED TO SOLVE    (DECEMBER 1988)
25210CCCCC THE PROBLEM OF AN ERROR MESSAGE AND NO-ACTION    (DECEMBER 1988)
25211CCCCC FROM (E.G.,) LET Y(K) = X(K) INSIDE A LOOP   (DECEMBER 1988)
25212      IF(ICASEL.EQ.'UNKN'.AND.IARG4F.EQ.'YES'.AND.IARG4T.EQ.'WORD'
25213     1.AND.IARG4I.GE.1.AND.ICASER.EQ.'ELEM')GOTO6000
25214      IF(ICASEL.EQ.'UNKN'.AND.IARG4F.EQ.'YES'.AND.IARG4T.EQ.'NUMB'
25215     1.AND.ICASER.EQ.'PARA')GOTO6000
25216      IF(ICASEL.EQ.'UNKN'.AND.IARG4F.EQ.'YES'.AND.IARG4T.EQ.'NUMB'
25217     1.AND.ICASER.EQ.'ELEM')GOTO6000
25218      GOTO4800
25219C
25220 4200 CONTINUE
25221      IF(ICASEL.EQ.'VAR'.AND.IARG4F.EQ.'NO')
25222     1GOTO8000
25223      IF(ICASEL.EQ.'VAR'.AND.IARG4F.EQ.'YES'.AND.IARG4T.EQ.'WORD')
25224     1GOTO8000
25225      IF(ICASEL.EQ.'UNKN'.AND.IARG4F.EQ.'NO')
25226     1GOTO8000
25227      IF(ICASEL.EQ.'UNKN'.AND.IARG4F.EQ.'YES'.AND.IARG4T.EQ.'WORD')
25228     1GOTO8000
25229      GOTO4800
25230C
25231 4300 CONTINUE
25232      IF(ICASEL.EQ.'VAR'.AND.IARG4F.EQ.'NO')
25233     1GOTO9000
25234      IF(ICASEL.EQ.'VAR'.AND.IARG4F.EQ.'YES'.AND.IARG4T.EQ.'WORD')
25235     1GOTO9000
25236      IF(ICASEL.EQ.'UNKN'.AND.IARG4F.EQ.'NO')
25237     1GOTO9000
25238      IF(ICASEL.EQ.'UNKN'.AND.IARG4F.EQ.'YES'.AND.IARG4T.EQ.'WORD')
25239     1GOTO9000
25240      GOTO4800
25241C
25242 4800 CONTINUE
25243      WRITE(ICOUT,4811)
25244 4811 FORMAT('***** ERROR IN DPFUEV--')
25245      CALL DPWRST('XXX','BUG ')
25246      WRITE(ICOUT,4812)
25247 4812 FORMAT('      ILLEGAL SYNTAX FOR LET COMMAND')
25248      CALL DPWRST('XXX','BUG ')
25249      WRITE(ICOUT,4814)
25250 4814 FORMAT('      POSSIBLE CAUSE--UNDEFINED PARAMETER/VARIABLE')
25251      CALL DPWRST('XXX','BUG ')
25252      WRITE(ICOUT,4815)
25253 4815 FORMAT('      ON RIGHT-HAND SIDE OF EQUAL SIGN.')
25254      CALL DPWRST('XXX','BUG ')
25255      WRITE(ICOUT,4816)ICASEL,ICASER,ICASEQ
25256 4816 FORMAT(6X,'ICASEL, ICASER, ICASEQ = ',A4,2X,A4,2X,A4)
25257      CALL DPWRST('XXX','BUG ')
25258      WRITE(ICOUT,4818)
25259 4818 FORMAT('      THE COMMAND LINE WAS AS FOLLOWS--')
25260      CALL DPWRST('XXX','BUG ')
25261      WRITE(ICOUT,4819)(IANS(I),I=1,MIN(80,IWIDTH))
25262 4819 FORMAT(80A1)
25263      CALL DPWRST('XXX','BUG ')
25264      IERROR='YES'
25265      GOTO19000
25266C
25267C               *****************************************************
25268C               **  STEP 5--                                       **
25269C               **  TREAT THE PARAMETER CASE.                      **
25270C               **  EXAMPLES--                                     **
25271C               **            LET A    = X(2)                      **
25272C               **            LET A    = 3*SIN(4)                  **
25273C               **            LET A    = B*SIN(B)                  **
25274C               **            LET U    = X(2)                      **
25275C               **            LET U    = 3*SIN(4)                  **
25276C               **            LET U    = B*SIN(B)                  **
25277C               **  WHERE A WAS A PREVIOUSLY-DEFINED PARAMETER     **
25278C               **  AND WHERE U WAS PREVIOUSLY UNDEFINED.          **
25279C               **  CARRY OUT THE LIST UPDATING  AND               **
25280C               **  GENERATE THE INFORMATIVE PRINTING.             **
25281C               **  THEN EXIT.                                     **
25282C               *****************************************************
25283C
25284 5000 CONTINUE
25285      ISTEPN='5'
25286      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25287C
25288      IF(ICASEQ.EQ.'IF')THEN
25289        ICASIF='TRUE'
25290        IHSET=IHOL(12)
25291        IHSET2=IHOL2(12)
25292C
25293C       2018/05: FIRST TEST FOR STRING (IF SUPPORTS CHECKING
25294C                FOR EQUALITY OF STRINGS).  IF NOT A STRING,
25295C                THEN CHECK FOR PARAMETER (WHICH IS THE MORE
25296C                LIKELY CASE).
25297C
25298        NISET=0
25299        IHWUSE='F'
25300        MESSAG='NO'
25301        CALL CHECKN(IHSET,IHSET2,IHWUSE,
25302     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
25303     1              ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR)
25304
25305        IF(IERROR.EQ.'YES')THEN
25306          IHWUSE='P'
25307          MESSAG='YES'
25308          CALL CHECKN(IHSET,IHSET2,IHWUSE,
25309     1                IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
25310     1                ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR)
25311          IF(IERROR.EQ.'YES')GOTO19000
25312          NISET=IN(ILOC)
25313        ENDIF
25314C
25315        ISUBRO='XXXX'
25316        CALL DPIF(ILOCS,ICASIF,IBUGQ,ISUBRO,IERROR)
25317      ENDIF
25318C
25319      IF(ICASER.EQ.'ELEM')GOTO5200
25320      IF(ICASER.EQ.'PARA')GOTO5300
25321C
25322      WRITE(ICOUT,999)
25323      CALL DPWRST('XXX','BUG ')
25324      WRITE(ICOUT,5101)
25325 5101 FORMAT('***** INTERNAL ERROR IN DPFUEV')
25326      CALL DPWRST('XXX','BUG ')
25327      WRITE(ICOUT,5102)
25328 5102 FORMAT('      AT BRANCH POINT 5101--')
25329      CALL DPWRST('XXX','BUG ')
25330      WRITE(ICOUT,5103)ICASER
25331 5103 FORMAT('      ICASER = ',A4,' DETECTED')
25332      CALL DPWRST('XXX','BUG ')
25333      WRITE(ICOUT,5104)
25334 5104 FORMAT('      IN STEP 5 (PARAMETER CALCULATION).')
25335      CALL DPWRST('XXX','BUG ')
25336      WRITE(ICOUT,5106)
25337 5106 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
25338      CALL DPWRST('XXX','BUG ')
25339      IF(IWIDTH.GE.1)WRITE(ICOUT,5107)(IANS(I),I=1,IWIDTH)
25340 5107 FORMAT(80A1)
25341      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
25342      IERROR='YES'
25343      GOTO19000
25344C
25345 5200 CONTINUE
25346      IF(ICASEQ.EQ.'IF'.AND.ICASIF.EQ.'FALS')GOTO5119
25347      IARG9I=INT1(9)
25348      IJ=MAXN*(ICOLR-1)+IARG9I
25349      IF(ICOLR.LE.MAXCOL)RIGHT=V(IJ)
25350      IF(ICOLR.EQ.MAXCP1)RIGHT=PRED(IARG9I)
25351      IF(ICOLR.EQ.MAXCP2)RIGHT=RES(IARG9I)
25352      IF(ICOLR.EQ.MAXCP3)RIGHT=YPLOT(IARG9I)
25353      IF(ICOLR.EQ.MAXCP4)RIGHT=XPLOT(IARG9I)
25354      IF(ICOLR.EQ.MAXCP5)RIGHT=X2PLOT(IARG9I)
25355      IF(ICOLR.EQ.MAXCP6)RIGHT=TAGPLO(IARG9I)
25356      GOTO5500
25357C
25358 5300 CONTINUE
25359      IF(ICASEQ.EQ.'IF'.AND.ICASIF.EQ.'FALS')GOTO5119
25360      IF(NUMPAR.LE.0)GOTO5490
25361      DO5400J=1,NUMPAR
25362      IPJ=IPARN(J)
25363      IPJ2=IPARN2(J)
25364      DO5450I=1,NUMNAM
25365      I2=I
25366      IF(IPJ.EQ.IHNAME(I).AND.IPJ2.EQ.IHNAM2(I).AND.
25367     1IUSE(I).EQ.'P')GOTO5460
25368 5450 CONTINUE
25369      GOTO5480
25370 5460 CONTINUE
25371      PARAM(J)=VALUE(I2)
25372 5400 CONTINUE
25373      GOTO5490
25374C
25375 5480 CONTINUE
25376      WRITE(ICOUT,999)
25377      CALL DPWRST('XXX','BUG ')
25378      WRITE(ICOUT,5481)
25379 5481 FORMAT('***** INTERNAL ERROR IN DPFUEV')
25380      CALL DPWRST('XXX','BUG ')
25381      WRITE(ICOUT,5482)
25382 5482 FORMAT('      AT BRANCH POINT 5481--')
25383      CALL DPWRST('XXX','BUG ')
25384      WRITE(ICOUT,5483)
25385 5483 FORMAT('      PARAMETER NAME FOR FUNCTION EVALUATION')
25386      CALL DPWRST('XXX','BUG ')
25387      WRITE(ICOUT,5484)
25388 5484 FORMAT('      NOT FOUND IN INTERNAL LIST.')
25389      CALL DPWRST('XXX','BUG ')
25390      WRITE(ICOUT,5485)IPJ,IPJ2
25391 5485 FORMAT('      PARAMETER NAME = ',A4,A4)
25392      CALL DPWRST('XXX','BUG ')
25393      WRITE(ICOUT,5486)
25394 5486 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
25395      CALL DPWRST('XXX','BUG ')
25396      IF(IWIDTH.GE.1)WRITE(ICOUT,5487)(IANS(I),I=1,IWIDTH)
25397 5487 FORMAT(80A1)
25398      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
25399      IERROR='YES'
25400      GOTO19000
25401C
25402 5490 CONTINUE
25403      IPASS=2
25404      CALL COMPIM(IA,NUMCHA,IPASS,PARAM,IPARN,IPARN2,NUMPAR,
25405     1IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,RIGHT,
25406     1IBUGCO,IBUGEV,IERROR)
25407      IF(IERROR.EQ.'YES')GOTO19000
25408      GOTO5500
25409C
25410 5500 CONTINUE
25411      IFOUND='YES'
25412      IHNAME(ILISTL)=ILEFT
25413      IHNAM2(ILISTL)=ILEFT2
25414      IUSE(ILISTL)='P'
25415      VALUE(ILISTL)=RIGHT
25416CCCCC IVALUE(ILISTL)=VALUE(ILISTL)+0.5
25417C
25418CCCCC MARCH 2002.  CHANGE CODE BELOW.  BASE ON LARGEST INTEGER AS
25419CCCCC GIVEN IN DPCOMC.
25420CCCCC CUTOFF=2**(NUMBPW-3)
25421C3/02 ICUTMX=NUMBPW
25422C3/02 IF(IHOST1.EQ.'CDC '.OR.IHOST1.EQ.'CYBE')ICUTMX=48
25423CCCCC THE FOLLOWING LINE WAS ADDED FEBRUARY 1989
25424C3/02 IF(IHOST1.EQ.'205 ')ICUTMX=48
25425C3/02 CUTOFF=2**(ICUTMX-3)
25426      CUTOFF=REAL(I1MACH(9)-1)
25427C
25428      IF((-CUTOFF).LE.RIGHT.AND.RIGHT.LE.CUTOFF)THEN
25429        IVALUE(ILISTL)=INT(RIGHT+0.5)
25430      ELSEIF(RIGHT.GT.CUTOFF)THEN
25431        IVALUE(ILISTL)=I1MACH(9)-1
25432      ELSEIF(RIGHT.LT.(-CUTOFF))THEN
25433        IVALUE(ILISTL)=-(I1MACH(9)-1)
25434      ELSE
25435        IVALUE(ILISTL)=0
25436      ENDIF
25437      IN(ILISTL)=1
25438C
25439      IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1
25440C
25441      IF(IPRINT.EQ.'OFF')GOTO5119
25442      IF(IFEEDB.EQ.'OFF')GOTO5119
25443      WRITE(ICOUT,999)
25444      CALL DPWRST('XXX','BUG ')
25445      WRITE(ICOUT,5111)ILEFT,ILEFT2,RIGHT
25446 5111 FORMAT('THE COMPUTED VALUE OF THE CONSTANT ',
25447     1A4,A4,' = ',E15.7)
25448      CALL DPWRST('XXX','BUG ')
25449      WRITE(ICOUT,999)
25450      CALL DPWRST('XXX','BUG ')
25451 5119 CONTINUE
25452      GOTO19000
25453C
25454C               *****************************************************
25455C               **  STEP 6--                                       **
25456C               **  TREAT THE ELEMENT SPECIFICATION CASE.          **
25457C               **  EXAMPLES--                                     **
25458C               **            LET Y(2) = X(2)                      **
25459C               **            LET Y(2) = 3*SIN(4)                  **
25460C               **            LET Y(2) = B*SIN(B)                  **
25461C               **            LET U(2) = X(2)                      **
25462C               **            LET U(2) = 3*SIN(4)                  **
25463C               **            LET U(2) = B*SIN(B)                  **
25464C               **  WHERE Y WAS A PREVIOUSLY-DEFINED VARIABLE      **
25465C               **  AND WHERE U WAS PREVIOUSLY UNDEFINED.          **
25466C               **  CARRY OUT THE LIST UPDATING  AND               **
25467C               **  GENERATE THE INFORMATIVE PRINTING.             **
25468C               **  THEN EXIT.                                     **
25469C               *****************************************************
25470C
25471 6000 CONTINUE
25472      ISTEPN='6'
25473      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25474C
25475      IARG4I=INT1(4)
25476C
25477      IF(1.LE.IARG4I.AND.IARG4I.LE.MAXN)GOTO6050
25478      WRITE(ICOUT,6061)
25479 6061 FORMAT('***** ERROR IN DPFUEV')
25480      CALL DPWRST('XXX','BUG ')
25481      WRITE(ICOUT,6062)IARG4I,ILEFT,ILEFT2
25482 6062 FORMAT('      THE SPECIFIED ROW (',I8,') OF VARIABLE ',A4,A4)
25483      CALL DPWRST('XXX','BUG ')
25484      WRITE(ICOUT,6063)
25485 6063 FORMAT('      ON THE LEFT SIDE OF THE EQUAL SIGN')
25486      CALL DPWRST('XXX','BUG ')
25487      WRITE(ICOUT,6064)
25488 6064 FORMAT('      WAS LESS THAN 1 OR')
25489      CALL DPWRST('XXX','BUG ')
25490      WRITE(ICOUT,6065)MAXN
25491 6065 FORMAT('      GREATER THAN THE MAX ALLOWABLE ',I8)
25492      CALL DPWRST('XXX','BUG ')
25493      IERROR='YES'
25494      GOTO19000
25495C
25496 6050 CONTINUE
25497      IF(ICASEL.EQ.'VAR')ICOLL=IVALUE(ILISTL)
25498      IF(ICASEL.EQ.'UNKN')ICOLL=NUMCOL+1
25499      IF(ICOLL.LE.MAXCOL)GOTO6090
25500      WRITE(ICOUT,6051)
25501 6051 FORMAT('***** ERROR IN DPFUEV AT 6051--')
25502      CALL DPWRST('XXX','BUG ')
25503      WRITE(ICOUT,6052)
25504 6052 FORMAT('      THE NUMBER OF DATA COLUMNS')
25505      CALL DPWRST('XXX','BUG ')
25506      WRITE(ICOUT,6053)MAXCOL
25507 6053 FORMAT('      HAS JUST EXCEEDED THE MAX ALLOWABLE ',I8,'  .')
25508      CALL DPWRST('XXX','BUG ')
25509      WRITE(ICOUT,6054)
25510 6054 FORMAT('      SUGGESTED ACTION--')
25511      CALL DPWRST('XXX','BUG ')
25512      WRITE(ICOUT,6055)
25513 6055 FORMAT('      ENTER      STAT')
25514      CALL DPWRST('XXX','BUG ')
25515      WRITE(ICOUT,6056)
25516 6056 FORMAT('      TO FIND OUT THE FULL LIST OF USED COLUMNS')
25517      CALL DPWRST('XXX','BUG ')
25518      WRITE(ICOUT,6057)
25519 6057 FORMAT('      AND THEN OVERWRITE SOME COLUMN.   ')
25520      CALL DPWRST('XXX','BUG ')
25521      WRITE(ICOUT,6058)
25522 6058 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
25523      CALL DPWRST('XXX','BUG ')
25524      IF(IWIDTH.GE.1)WRITE(ICOUT,6059)(IANS(I),I=1,IWIDTH)
25525 6059 FORMAT(80A1)
25526      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
25527      IERROR='YES'
25528      GOTO19000
25529C
25530 6090 CONTINUE
25531      IF(ICASEL.EQ.'VAR'.AND.IARG4I.LE.NILEFT)NINEW=NILEFT
25532      IF(ICASEL.EQ.'VAR'.AND.IARG4I.GT.NILEFT)NINEW=IARG4I
25533      IF(ICASEL.EQ.'UNKN')NINEW=IARG4I
25534C
25535      IF(ICASER.EQ.'ELEM')GOTO6200
25536      IF(ICASER.EQ.'PARA')GOTO6300
25537C
25538      WRITE(ICOUT,999)
25539      CALL DPWRST('XXX','BUG ')
25540      WRITE(ICOUT,6101)
25541 6101 FORMAT('***** INTERNAL ERROR IN DPFUEV')
25542      CALL DPWRST('XXX','BUG ')
25543      WRITE(ICOUT,6102)
25544 6102 FORMAT('      AT BRANCH POINT 6101--')
25545      CALL DPWRST('XXX','BUG ')
25546      WRITE(ICOUT,6103)ICASER
25547 6103 FORMAT('      ICASER = ',A4,' DETECTED')
25548      CALL DPWRST('XXX','BUG ')
25549      WRITE(ICOUT,6104)
25550 6104 FORMAT('      IN STEP 6 (ELEMENT CALCULATION).')
25551      CALL DPWRST('XXX','BUG ')
25552      WRITE(ICOUT,6106)
25553 6106 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
25554      CALL DPWRST('XXX','BUG ')
25555      IF(IWIDTH.GE.1)WRITE(ICOUT,6107)(IANS(I),I=1,IWIDTH)
25556 6107 FORMAT(80A1)
25557      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
25558      IERROR='YES'
25559      GOTO19000
25560C
25561 6200 CONTINUE
25562      IARG9I=INT1(9)
25563      IJ=MAXN*(ICOLR-1)+IARG9I
25564      IF(ICOLR.LE.MAXCOL)RIGHT=V(IJ)
25565      IF(ICOLR.EQ.MAXCP1)RIGHT=PRED(IARG9I)
25566      IF(ICOLR.EQ.MAXCP2)RIGHT=RES(IARG9I)
25567      IF(ICOLR.EQ.MAXCP3)RIGHT=YPLOT(IARG9I)
25568      IF(ICOLR.EQ.MAXCP4)RIGHT=XPLOT(IARG9I)
25569      IF(ICOLR.EQ.MAXCP5)RIGHT=X2PLOT(IARG9I)
25570      IF(ICOLR.EQ.MAXCP6)RIGHT=TAGPLO(IARG9I)
25571      IJ=MAXN*(ICOLL-1)+IARG4I
25572      IF(ICOLL.LE.MAXCOL)V(IJ)=RIGHT
25573      IF(ICOLL.EQ.MAXCP1)PRED(IARG4I)=RIGHT
25574      IF(ICOLL.EQ.MAXCP2)RES(IARG4I)=RIGHT
25575      IF(ICOLL.EQ.MAXCP3)YPLOT(IARG4I)=RIGHT
25576      IF(ICOLL.EQ.MAXCP4)XPLOT(IARG4I)=RIGHT
25577      IF(ICOLL.EQ.MAXCP5)X2PLOT(IARG4I)=RIGHT
25578      IF(ICOLL.EQ.MAXCP6)TAGPLO(IARG4I)=RIGHT
25579      GOTO6500
25580C
25581 6300 CONTINUE
25582      IF(NUMPAR.LE.0)GOTO6490
25583      DO6400J=1,NUMPAR
25584      IPJ=IPARN(J)
25585      IPJ2=IPARN2(J)
25586      DO6450I=1,NUMNAM
25587      I2=I
25588      IF(IPJ.EQ.IHNAME(I).AND.IPJ2.EQ.IHNAM2(I).AND.
25589     1IUSE(I).EQ.'P')GOTO6460
25590 6450 CONTINUE
25591      GOTO6480
25592 6460 CONTINUE
25593      PARAM(J)=VALUE(I2)
25594 6400 CONTINUE
25595      GOTO6490
25596C
25597 6480 CONTINUE
25598      WRITE(ICOUT,999)
25599      CALL DPWRST('XXX','BUG ')
25600      WRITE(ICOUT,6481)
25601 6481 FORMAT('***** INTERNAL ERROR IN DPFUEV')
25602      CALL DPWRST('XXX','BUG ')
25603      WRITE(ICOUT,6482)
25604 6482 FORMAT('      AT BRANCH POINT 6481--')
25605      CALL DPWRST('XXX','BUG ')
25606      WRITE(ICOUT,6483)
25607 6483 FORMAT('      PARAMETER NAME FOR FUNCTION EVALUATION')
25608      CALL DPWRST('XXX','BUG ')
25609      WRITE(ICOUT,6484)
25610 6484 FORMAT('      NOT FOUND IN INTERNAL LIST.')
25611      CALL DPWRST('XXX','BUG ')
25612      WRITE(ICOUT,6485)IPJ,IPJ2
25613 6485 FORMAT('      PARAMETER NAME = ',A4,A4)
25614      CALL DPWRST('XXX','BUG ')
25615      WRITE(ICOUT,6486)
25616 6486 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
25617      CALL DPWRST('XXX','BUG ')
25618      IF(IWIDTH.GE.1)WRITE(ICOUT,6487)(IANS(I),I=1,IWIDTH)
25619 6487 FORMAT(80A1)
25620      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
25621      IERROR='YES'
25622      GOTO19000
25623C
25624 6490 CONTINUE
25625      IPASS=2
25626      CALL COMPIM(IA,NUMCHA,IPASS,PARAM,IPARN,IPARN2,NUMPAR,
25627     1IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,RIGHT,
25628     1IBUGCO,IBUGEV,IERROR)
25629      IF(IERROR.EQ.'YES')GOTO19000
25630      IJ=MAXN*(ICOLL-1)+IARG4I
25631      IF(ICOLL.LE.MAXCOL)V(IJ)=RIGHT
25632      IF(ICOLL.EQ.MAXCP1)PRED(IARG4I)=RIGHT
25633      IF(ICOLL.EQ.MAXCP2)RES(IARG4I)=RIGHT
25634      IF(ICOLL.EQ.MAXCP3)YPLOT(IARG4I)=RIGHT
25635      IF(ICOLL.EQ.MAXCP4)XPLOT(IARG4I)=RIGHT
25636      IF(ICOLL.EQ.MAXCP5)X2PLOT(IARG4I)=RIGHT
25637      IF(ICOLL.EQ.MAXCP6)TAGPLO(IARG4I)=RIGHT
25638      GOTO6500
25639C
25640 6500 CONTINUE
25641      IFOUND='YES'
25642      IHNAME(ILISTL)=ILEFT
25643      IHNAM2(ILISTL)=ILEFT2
25644      IUSE(ILISTL)='V'
25645      IVALUE(ILISTL)=ICOLL
25646      VALUE(ILISTL)=ICOLL
25647      IN(ILISTL)=NINEW
25648C
25649CCCCC IUSE(ICOLL)='V'
25650CCCCC IVALUE(ICOLL)=ICOLL
25651CCCCC VALUE(ICOLL)=ICOLL
25652CCCCC IN(ICOLL)=NINEW
25653C
25654      IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1
25655      IF(NEWNAM.EQ.'YES')NUMCOL=NUMCOL+1
25656C
25657      DO6600J4=1,NUMNAM
25658      IF(IUSE(J4).EQ.'V'.AND.IVALUE(J4).EQ.ICOLL)GOTO6605
25659      GOTO6600
25660 6605 CONTINUE
25661      IUSE(J4)='V'
25662      IVALUE(J4)=ICOLL
25663      VALUE(J4)=ICOLL
25664      IN(J4)=NINEW
25665 6600 CONTINUE
25666C
25667      IF(IPRINT.EQ.'OFF')GOTO6119
25668      IF(IFEEDB.EQ.'OFF')GOTO6119
25669      WRITE(ICOUT,999)
25670      CALL DPWRST('XXX','BUG ')
25671      WRITE(ICOUT,6111)ILEFT,ILEFT2,IARG4I,RIGHT
25672 6111 FORMAT('THE COMPUTED VALUE OF ',
25673     1A4,A4,'(',I6,') = ',E15.7)
25674      CALL DPWRST('XXX','BUG ')
25675      WRITE(ICOUT,999)
25676      CALL DPWRST('XXX','BUG ')
25677      WRITE(ICOUT,6112)ILEFT,ILEFT2,ICOLL
25678 6112 FORMAT('THE CURRENT COLUMN FOR ',
25679     1'THE VARIABLE ',A4,A4,' = ',I8)
25680      CALL DPWRST('XXX','BUG ')
25681      WRITE(ICOUT,6113)ILEFT,ILEFT2,NINEW
25682 6113 FORMAT('THE CURRENT LENGTH OF  ',
25683     1'THE VARIABLE ',A4,A4,' = ',I8)
25684      CALL DPWRST('XXX','BUG ')
25685      WRITE(ICOUT,999)
25686      CALL DPWRST('XXX','BUG ')
25687 6119 CONTINUE
25688      GOTO19000
25689C
25690C               *****************************************************
25691C               **  STEP 7--                                       **
25692C               **  TREAT THE FULL VARIABLE CASE.                  **
25693C               **  EXAMPLES--                                     **
25694C               **            LET Y    = X*SIN(X)                  **
25695C               **            LET Y(I) = I                         **
25696C               **            LET Y(I) = X(2)                      **
25697C               **            LET Y(I) = 3*SIN(4)                  **
25698C               **            LET Y(I) = B*SIN(B)                  **
25699C               **            LET Y(I) = X*SIN(X)                  **
25700C               **            LET U    = X*SIN(X)                  **
25701C               **            LET U(I) = X*SIN(X)                  **
25702C               **  WHERE Y WAS A PREVIOUSLY-DEFINED VARIABLE      **
25703C               **  AND WHERE U WAS PREVIOUSLY UNDEFINED.          **
25704C               **  THEN JUMP TO STEP NUMBER 10 BELOW              **
25705C               **  FOR THE THE LIST UPDATING AND                  **
25706C               **  GENERATE THE INFORMATIVE PRINTING.             **
25707C               **  THEN EXIT.                                     **
25708C               *****************************************************
25709C
25710 7000 CONTINUE
25711      ISTEPN='7'
25712      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25713C
25714      IF(ICASEL.EQ.'VAR')ICOLL=IVALUE(ILISTL)
25715      IF(ICASEL.EQ.'UNKN')ICOLL=NUMCOL+1
25716CCCCC IF(ILEFT.EQ.'PRED'.AND.ILEFT2.EQ.'    ')GOTO7090  MARCH 1988
25717CCCCC IF(ILEFT.EQ.'RES '.AND.ILEFT2.EQ.'    ')GOTO7090  MARCH 1988
25718      IF(ICOLL.LE.MAXCOL)GOTO7090
25719CCCCC THE FOLLOWING LINE WAS INSERTED MARCH 1988
25720CCCCC TO FIX THE PROBLEM OF LET PRED = ... SUBSET ...
25721CCCCC YIELDING A "TOO MANY VARIABLES" MESSAGE
25722      IF(ICASEL.EQ.'VAR')GOTO7090
25723      WRITE(ICOUT,7051)
25724 7051 FORMAT('***** ERROR IN DPFUEV AT 7051--')
25725      CALL DPWRST('XXX','BUG ')
25726      WRITE(ICOUT,7052)ICOLL
25727 7052 FORMAT('      THE NUMBER OF DATA COLUMNS (',I8,')')
25728      CALL DPWRST('XXX','BUG ')
25729      WRITE(ICOUT,7053)MAXCOL
25730 7053 FORMAT('      HAS JUST EXCEEDED THE MAX ALLOWABLE (',I8,').')
25731      CALL DPWRST('XXX','BUG ')
25732      WRITE(ICOUT,7054)
25733 7054 FORMAT('      SUGGESTED ACTION--')
25734      CALL DPWRST('XXX','BUG ')
25735      WRITE(ICOUT,7055)
25736 7055 FORMAT('      ENTER      STAT')
25737      CALL DPWRST('XXX','BUG ')
25738      WRITE(ICOUT,7056)
25739 7056 FORMAT('      TO FIND OUT THE FULL LIST OF USED COLUMNS')
25740      CALL DPWRST('XXX','BUG ')
25741      WRITE(ICOUT,7057)
25742 7057 FORMAT('      AND THEN OVERWRITE SOME COLUMN.   ')
25743      CALL DPWRST('XXX','BUG ')
25744      WRITE(ICOUT,7058)
25745 7058 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
25746      CALL DPWRST('XXX','BUG ')
25747      IF(IWIDTH.GE.1)WRITE(ICOUT,7059)(IANS(I),I=1,IWIDTH)
25748 7059 FORMAT(80A1)
25749      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
25750      IERROR='YES'
25751      GOTO19000
25752C
25753 7090 CONTINUE
25754      NINEW=NILEFT
25755      IF(ICASER.EQ.'VAR')NINEW=NIRIGH
25756C
25757      IF(ICASER.EQ.'DUMM')GOTO7100
25758      IF(ICASER.EQ.'ELEM')GOTO7200
25759      IF(ICASER.EQ.'PARA')GOTO7300
25760      IF(ICASER.EQ.'VAR')GOTO7300
25761C
25762 7100 CONTINUE
25763      NS2=0
25764      DO7150I=1,NINEW
25765      NS2=NS2+1
25766      RIGHT=I
25767      IJ=MAXN*(ICOLL-1)+I
25768      IF(ICOLL.LE.MAXCOL)V(IJ)=RIGHT
25769      IF(ICOLL.EQ.MAXCP1)PRED(I)=RIGHT
25770      IF(ICOLL.EQ.MAXCP2)RES(I)=RIGHT
25771      IF(ICOLL.EQ.MAXCP3)YPLOT(I)=RIGHT
25772      IF(ICOLL.EQ.MAXCP4)XPLOT(I)=RIGHT
25773      IF(ICOLL.EQ.MAXCP5)X2PLOT(I)=RIGHT
25774      IF(ICOLL.EQ.MAXCP6)TAGPLO(I)=RIGHT
25775      IF(NS2.EQ.1)IROW1=I
25776      IROWN=I
25777 7150 CONTINUE
25778      GOTO10000
25779C
25780 7200 CONTINUE
25781      IARG9I=INT1(9)
25782      IJ=MAXN*(ICOLR-1)+IARG9I
25783      IF(ICOLR.LE.MAXCOL)RIGHT=V(IJ)
25784      IF(ICOLR.EQ.MAXCP1)RIGHT=PRED(IARG9I)
25785      IF(ICOLR.EQ.MAXCP2)RIGHT=RES(IARG9I)
25786      IF(ICOLR.EQ.MAXCP3)RIGHT=YPLOT(IARG9I)
25787      IF(ICOLR.EQ.MAXCP4)RIGHT=XPLOT(IARG9I)
25788      IF(ICOLR.EQ.MAXCP5)RIGHT=X2PLOT(IARG9I)
25789      IF(ICOLR.EQ.MAXCP6)RIGHT=TAGPLO(IARG9I)
25790      NS2=0
25791      DO7250I=1,NINEW
25792      NS2=NS2+1
25793      IJ=MAXN*(ICOLL-1)+I
25794      IF(ICOLL.LE.MAXCOL)V(IJ)=RIGHT
25795      IF(ICOLL.EQ.MAXCP1)PRED(I)=RIGHT
25796      IF(ICOLL.EQ.MAXCP2)RES(I)=RIGHT
25797      IF(ICOLL.EQ.MAXCP3)YPLOT(I)=RIGHT
25798      IF(ICOLL.EQ.MAXCP4)XPLOT(I)=RIGHT
25799      IF(ICOLL.EQ.MAXCP5)X2PLOT(I)=RIGHT
25800      IF(ICOLL.EQ.MAXCP6)TAGPLO(I)=RIGHT
25801      IF(NS2.EQ.1)IROW1=I
25802      IROWN=I
25803 7250 CONTINUE
25804      GOTO10000
25805C
25806 7300 CONTINUE
25807      IPASS=2
25808      NS2=0
25809      DO7350I=1,NINEW
25810      NS2=NS2+1
25811C
25812      IF(NUMPAR.LE.0)GOTO7390
25813      DO7355J=1,NUMPAR
25814      IPJ=IPARN(J)
25815      IPJ2=IPARN2(J)
25816      DO7356K=1,NUMNAM
25817      K2=K
25818      IF(IPJ.EQ.IHNAME(K).AND.IPJ2.EQ.IHNAM2(K).AND.
25819     1IUSE(K).EQ.'P')GOTO7360
25820      IF(IPJ.EQ.IHNAME(K).AND.IPJ2.EQ.IHNAM2(K).AND.
25821     1IUSE(K).EQ.'V')GOTO7370
25822 7356 CONTINUE
25823      GOTO7380
25824C
25825 7360 CONTINUE
25826      PARAM(J)=VALUE(K2)
25827      GOTO7355
25828C
25829 7370 CONTINUE
25830      ICOLK2=IVALUE(K2)
25831      IJ=MAXN*(ICOLK2-1)+I
25832      IF(ICOLK2.LE.MAXCOL)PARAM(J)=V(IJ)
25833      IF(ICOLK2.EQ.MAXCP1)PARAM(J)=PRED(I)
25834      IF(ICOLK2.EQ.MAXCP2)PARAM(J)=RES(I)
25835      IF(ICOLK2.EQ.MAXCP3)PARAM(J)=YPLOT(I)
25836      IF(ICOLK2.EQ.MAXCP4)PARAM(J)=XPLOT(I)
25837      IF(ICOLK2.EQ.MAXCP5)PARAM(J)=X2PLOT(I)
25838      IF(ICOLK2.EQ.MAXCP6)PARAM(J)=TAGPLO(I)
25839 7355 CONTINUE
25840      GOTO7390
25841C
25842 7380 CONTINUE
25843      WRITE(ICOUT,999)
25844      CALL DPWRST('XXX','BUG ')
25845      WRITE(ICOUT,7381)
25846 7381 FORMAT('***** INTERNAL ERROR IN DPFUEV')
25847      CALL DPWRST('XXX','BUG ')
25848      WRITE(ICOUT,7382)
25849 7382 FORMAT('      AT BRANCH POINT 7381--')
25850      CALL DPWRST('XXX','BUG ')
25851      WRITE(ICOUT,7383)
25852 7383 FORMAT('      PARAMETER/VARIABLE NAME FOR FUNCTION ',
25853     1'EVALUATION')
25854      CALL DPWRST('XXX','BUG ')
25855      WRITE(ICOUT,7384)
25856 7384 FORMAT('      NOT FOUND IN INTERNAL LIST.')
25857      CALL DPWRST('XXX','BUG ')
25858      WRITE(ICOUT,7385)IPJ,IPJ2
25859 7385 FORMAT('      PARAMETER/VARIABLE NAME = ',A4,A4)
25860      CALL DPWRST('XXX','BUG ')
25861      WRITE(ICOUT,7386)
25862 7386 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
25863      CALL DPWRST('XXX','BUG ')
25864      IF(IWIDTH.GE.1)WRITE(ICOUT,7387)(IANS(I3),I3=1,IWIDTH)
25865 7387 FORMAT(80A1)
25866      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
25867      IERROR='YES'
25868      GOTO19000
25869C
25870 7390 CONTINUE
25871      CALL COMPIM(IA,NUMCHA,IPASS,PARAM,IPARN,IPARN2,NUMPAR,
25872     1IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,RIGHT,
25873     1IBUGCO,IBUGEV,IERROR)
25874      IF(IERROR.EQ.'YES')GOTO19000
25875      IJ=MAXN*(ICOLL-1)+I
25876      IF(ICOLL.LE.MAXCOL)V(IJ)=RIGHT
25877      IF(ICOLL.EQ.MAXCP1)PRED(I)=RIGHT
25878      IF(ICOLL.EQ.MAXCP2)RES(I)=RIGHT
25879      IF(ICOLL.EQ.MAXCP3)YPLOT(I)=RIGHT
25880      IF(ICOLL.EQ.MAXCP4)XPLOT(I)=RIGHT
25881      IF(ICOLL.EQ.MAXCP5)X2PLOT(I)=RIGHT
25882      IF(ICOLL.EQ.MAXCP6)TAGPLO(I)=RIGHT
25883      IF(NS2.EQ.1)IROW1=I
25884      IROWN=I
25885 7350 CONTINUE
25886      GOTO10000
25887C
25888C               *****************************************************
25889C               **  STEP 8--                                       **
25890C               **  TREAT THE PARTIAL VARIABLE SUBSET CASE.        **
25891C               **  EXAMPLES--                                     **
25892C               **            LET Y    = I         SUBSET 2 3 5    **
25893C               **            LET Y    = X(2)      SUBSET 2 3 5    **
25894C               **            LET Y    = 3*SIN(4)  SUBSET 2 3 5    **
25895C               **            LET Y    = B*SIN(B)  SUBSET 2 3 5    **
25896C               **            LET Y    = X*SIN(X)  SUBSET 2 3 5    **
25897C               **            LET Y(I) = I         SUBSET 2 3 5    **
25898C               **            LET Y(I) = X(2)      SUBSET 2 3 5    **
25899C               **            LET Y(I) = 3*SIN(4)  SUBSET 2 3 5    **
25900C               **            LET Y(I) = B*SIN(B)  SUBSET 2 3 5    **
25901C               **            LET Y(I) = X*SIN(X)  SUBSET 2 3 5    **
25902C               **            LET U    = I         SUBSET 2 3 5    **
25903C               **            LET U    = X(2)      SUBSET 2 3 5    **
25904C               **            LET U    = 3*SIN(4)  SUBSET 2 3 5    **
25905C               **            LET U    = B*SIN(B)  SUBSET 2 3 5    **
25906C               **            LET U    = X*SIN(X)  SUBSET 2 3 5    **
25907C               **            LET U(I) = I         SUBSET 2 3 5    **
25908C               **            LET U(I) = X(2)      SUBSET 2 3 5    **
25909C               **            LET U(I) = 3*SIN(4)  SUBSET 2 3 5    **
25910C               **            LET U(I) = B*SIN(B)  SUBSET 2 3 5    **
25911C               **            LET U(I) = X*SIN(X)  SUBSET 2 3 5    **
25912C               **  WHERE Y WAS A PREVIOUSLY-DEFINED VARIABLE      **
25913C               **  AND WHERE U WAS PREVIOUSLY UNDEFINED.          **
25914C               **  THEN JUMP TO STEP NUMBER 10 BELOW              **
25915C               **  FOR THE THE LIST UPDATING  AND                 **
25916C               **  GENERATE THE INFORMATIVE PRINTING.             **
25917C               **  THEN EXIT.                                     **
25918C               *****************************************************
25919C
25920 8000 CONTINUE
25921      ISTEPN='8'
25922      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25923C
25924      IF(ICASEL.EQ.'VAR')ICOLL=IVALUE(ILISTL)
25925      IF(ICASEL.EQ.'UNKN')ICOLL=NUMCOL+1
25926      IF(ICOLL.LE.MAXCOL)GOTO8090
25927CCCCC THE FOLLOWING LINE WAS INSERTED MARCH 1988
25928CCCCC TO FIX THE PROBLEM OF LET PRED = ... SUBSET ...
25929CCCCC YIELDING A "TOO MANY VARIABLES" MESSAGE
25930      IF(ICASEL.EQ.'VAR')GOTO8090
25931      WRITE(ICOUT,8051)
25932 8051 FORMAT('***** ERROR IN DPFUEV AT 8051--')
25933      CALL DPWRST('XXX','BUG ')
25934      WRITE(ICOUT,8052)
25935 8052 FORMAT('      THE NUMBER OF DATA COLUMNS')
25936      CALL DPWRST('XXX','BUG ')
25937      WRITE(ICOUT,8053)MAXCOL
25938 8053 FORMAT('      HAS JUST EXCEEDED THE MAX ALLOWABLE ',I8,'  .')
25939      CALL DPWRST('XXX','BUG ')
25940      WRITE(ICOUT,8054)
25941 8054 FORMAT('      SUGGESTED ACTION--')
25942      CALL DPWRST('XXX','BUG ')
25943      WRITE(ICOUT,8055)
25944 8055 FORMAT('      ENTER      STAT')
25945      CALL DPWRST('XXX','BUG ')
25946      WRITE(ICOUT,8056)
25947 8056 FORMAT('      TO FIND OUT THE FULL LIST OF USED COLUMNS')
25948      CALL DPWRST('XXX','BUG ')
25949      WRITE(ICOUT,8057)
25950 8057 FORMAT('      AND THEN OVERWRITE SOME COLUMN.   ')
25951      CALL DPWRST('XXX','BUG ')
25952      WRITE(ICOUT,8058)
25953 8058 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
25954      CALL DPWRST('XXX','BUG ')
25955      IF(IWIDTH.GE.1)WRITE(ICOUT,8059)(IANS(I),I=1,IWIDTH)
25956 8059 FORMAT(80A1)
25957      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
25958      IERROR='YES'
25959      GOTO19000
25960C
25961 8090 CONTINUE
25962      IHSET=IHOL(12)
25963      IHSET2=IHOL2(12)
25964      IHWUSE='V'
25965      MESSAG='YES'
25966      CALL CHECKN(IHSET,IHSET2,IHWUSE,
25967     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
25968     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR)
25969      IF(IERROR.EQ.'YES')GOTO19000
25970C
25971CCCCC JULY 2007: FIX EMPTY SUBSET BUG.  IF AN EMPTY SUBSET
25972CCCCC            IS GIVEN, SET IERROR AND RETURN.  CHECK AT
25973CCCCC            BOTH INPUT (I.E., N BEFORE SUBSET) AND
25974CCCCC            OUTPUT (I.E., N AFTER SUBSET).
25975C
25976      NISET=IN(ILOC)
25977C
25978      IF(NISET.LT.1)THEN
25979        IERROR='WARN'
25980        GOTO19000
25981      ENDIF
25982C
25983      CALL DPSUBS(NISET,ILOCS,NS,IBUGQ,IERROR)
25984C
25985      NINEW=NISET
25986      IF(ICASER.EQ.'VAR')NINEW=NIRIGH
25987C
25988      IF(ICASER.EQ.'DUMM')GOTO8100
25989      IF(ICASER.EQ.'ELEM')GOTO8200
25990      IF(ICASER.EQ.'PARA')GOTO8300
25991      IF(ICASER.EQ.'VAR')GOTO8300
25992C
25993 8100 CONTINUE
25994      NS2=0
25995      DO8150I=1,NISET
25996      IF(ISUB(I).EQ.0)GOTO8150
25997      NS2=NS2+1
25998      RIGHT=I
25999      IJ=MAXN*(ICOLL-1)+I
26000      IF(ICOLL.LE.MAXCOL)V(IJ)=RIGHT
26001      IF(ICOLL.EQ.MAXCP1)PRED(I)=RIGHT
26002      IF(ICOLL.EQ.MAXCP2)RES(I)=RIGHT
26003      IF(ICOLL.EQ.MAXCP3)YPLOT(I)=RIGHT
26004      IF(ICOLL.EQ.MAXCP4)XPLOT(I)=RIGHT
26005      IF(ICOLL.EQ.MAXCP5)X2PLOT(I)=RIGHT
26006      IF(ICOLL.EQ.MAXCP6)TAGPLO(I)=RIGHT
26007      IF(NS2.EQ.1)IROW1=I
26008      IROWN=I
26009 8150 CONTINUE
26010C
26011      IF(NS2.LT.1)THEN
26012        IERROR='WARN'
26013        GOTO19000
26014      ENDIF
26015C
26016      GOTO10000
26017C
26018 8200 CONTINUE
26019      IARG9I=INT1(9)
26020      IJ=MAXN*(ICOLR-1)+IARG9I
26021C ???????????
26022      IF(ICOLR.LE.MAXCOL)RIGHT=V(IJ)
26023      IF(ICOLR.EQ.MAXCP1)RIGHT=PRED(IARG9I)
26024      IF(ICOLR.EQ.MAXCP2)RIGHT=RES(IARG9I)
26025      IF(ICOLR.EQ.MAXCP3)RIGHT=YPLOT(IARG9I)
26026      IF(ICOLR.EQ.MAXCP4)RIGHT=XPLOT(IARG9I)
26027      IF(ICOLR.EQ.MAXCP5)RIGHT=X2PLOT(IARG9I)
26028      IF(ICOLR.EQ.MAXCP6)RIGHT=TAGPLO(IARG9I)
26029      NS2=0
26030      DO8250I=1,NISET
26031      IF(ISUB(I).EQ.0)GOTO8250
26032      NS2=NS2+1
26033      IJ=MAXN*(ICOLL-1)+I
26034      IF(ICOLL.LE.MAXCOL)V(IJ)=RIGHT
26035      IF(ICOLL.EQ.MAXCP1)PRED(I)=RIGHT
26036      IF(ICOLL.EQ.MAXCP2)RES(I)=RIGHT
26037      IF(ICOLL.EQ.MAXCP3)YPLOT(I)=RIGHT
26038      IF(ICOLL.EQ.MAXCP4)XPLOT(I)=RIGHT
26039      IF(ICOLL.EQ.MAXCP5)X2PLOT(I)=RIGHT
26040      IF(ICOLL.EQ.MAXCP6)TAGPLO(I)=RIGHT
26041      IF(NS2.EQ.1)IROW1=I
26042      IROWN=I
26043 8250 CONTINUE
26044C
26045      IF(NS2.LT.1)THEN
26046        IERROR='WARN'
26047        GOTO19000
26048      ENDIF
26049C
26050      GOTO10000
26051C
26052 8300 CONTINUE
26053      IPASS=2
26054      IMAX=NISET
26055      IF(NINEW.LT.IMAX)IMAX=NINEW
26056      NS2=0
26057      DO8350I=1,IMAX
26058      IF(ISUB(I).EQ.0)GOTO8350
26059      NS2=NS2+1
26060C
26061      IF(NUMPAR.LE.0)GOTO8390
26062      DO8355J=1,NUMPAR
26063      IPJ=IPARN(J)
26064      IPJ2=IPARN2(J)
26065      DO8356K=1,NUMNAM
26066      K2=K
26067      IF(IPJ.EQ.IHNAME(K).AND.IPJ2.EQ.IHNAM2(K).AND.
26068     1IUSE(K).EQ.'P')GOTO8360
26069      IF(IPJ.EQ.IHNAME(K).AND.IPJ2.EQ.IHNAM2(K).AND.
26070     1IUSE(K).EQ.'V')GOTO8370
26071 8356 CONTINUE
26072      GOTO8380
26073C
26074 8360 CONTINUE
26075      PARAM(J)=VALUE(K2)
26076      GOTO8355
26077C
26078 8370 CONTINUE
26079      ICOLK2=IVALUE(K2)
26080      IJ=MAXN*(ICOLK2-1)+I
26081      IF(ICOLK2.LE.MAXCOL)PARAM(J)=V(IJ)
26082      IF(ICOLK2.EQ.MAXCP1)PARAM(J)=PRED(I)
26083      IF(ICOLK2.EQ.MAXCP2)PARAM(J)=RES(I)
26084      IF(ICOLK2.EQ.MAXCP3)PARAM(J)=YPLOT(I)
26085      IF(ICOLK2.EQ.MAXCP4)PARAM(J)=XPLOT(I)
26086      IF(ICOLK2.EQ.MAXCP5)PARAM(J)=X2PLOT(I)
26087      IF(ICOLK2.EQ.MAXCP6)PARAM(J)=TAGPLO(I)
26088 8355 CONTINUE
26089      GOTO8390
26090C
26091 8380 CONTINUE
26092      WRITE(ICOUT,999)
26093      CALL DPWRST('XXX','BUG ')
26094      WRITE(ICOUT,8381)
26095 8381 FORMAT('***** INTERNAL ERROR IN DPFUEV')
26096      CALL DPWRST('XXX','BUG ')
26097      WRITE(ICOUT,8382)
26098 8382 FORMAT('      AT BRANCH POINT 8381--')
26099      CALL DPWRST('XXX','BUG ')
26100      WRITE(ICOUT,8383)
26101 8383 FORMAT('      PARAMETER/VARIABLE NAME FOR FUNCTION ',
26102     1'EVALUATION')
26103      CALL DPWRST('XXX','BUG ')
26104      WRITE(ICOUT,8384)
26105 8384 FORMAT('      NOT FOUND IN INTERNAL LIST.')
26106      CALL DPWRST('XXX','BUG ')
26107      WRITE(ICOUT,8385)IPJ,IPJ2
26108 8385 FORMAT('      PARAMETER/VARIABLE NAME = ',A4,A4)
26109      CALL DPWRST('XXX','BUG ')
26110      WRITE(ICOUT,8386)
26111 8386 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
26112      CALL DPWRST('XXX','BUG ')
26113      IF(IWIDTH.GE.1)WRITE(ICOUT,8387)(IANS(I3),I3=1,IWIDTH)
26114 8387 FORMAT(80A1)
26115      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
26116      IERROR='YES'
26117      GOTO19000
26118C
26119 8390 CONTINUE
26120      CALL COMPIM(IA,NUMCHA,IPASS,PARAM,IPARN,IPARN2,NUMPAR,
26121     1IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,RIGHT,
26122     1IBUGCO,IBUGEV,IERROR)
26123      IF(IERROR.EQ.'YES')GOTO19000
26124      IJ=MAXN*(ICOLL-1)+I
26125      IF(ICOLL.LE.MAXCOL)V(IJ)=RIGHT
26126      IF(ICOLL.EQ.MAXCP1)PRED(I)=RIGHT
26127      IF(ICOLL.EQ.MAXCP2)RES(I)=RIGHT
26128      IF(ICOLL.EQ.MAXCP3)YPLOT(I)=RIGHT
26129      IF(ICOLL.EQ.MAXCP4)XPLOT(I)=RIGHT
26130      IF(ICOLL.EQ.MAXCP5)X2PLOT(I)=RIGHT
26131      IF(ICOLL.EQ.MAXCP6)TAGPLO(I)=RIGHT
26132      IF(NS2.EQ.1)IROW1=I
26133      IROWN=I
26134 8350 CONTINUE
26135C
26136      IF(NS2.LT.1)THEN
26137        IERROR='WARN'
26138        GOTO19000
26139      ENDIF
26140C
26141      GOTO10000
26142C
26143C               *****************************************************
26144C               **  STEP 9--                                       **
26145C               **  TREAT THE PARTIAL VARIABLE FOR CASE.           **
26146C               **  EXAMPLES--                                     **
26147C               **            LET Y    = I         FOR I = 1 2 10  **
26148C               **            LET Y    = X(2)      FOR I = 1 2 10  **
26149C               **            LET Y    = 3*SIN(4)  FOR I = 1 2 10  **
26150C               **            LET Y    = B*SIN(B)  FOR I = 1 2 10  **
26151C               **            LET Y    = X*SIN(X)  FOR I = 1 2 10  **
26152C               **            LET Y(I) = I         FOR I = 1 2 10  **
26153C               **            LET Y(I) = X(2)      FOR I = 1 2 10  **
26154C               **            LET Y(I) = 3*SIN(4)  FOR I = 1 2 10  **
26155C               **            LET Y(I) = B*SIN(B)  FOR I = 1 2 10  **
26156C               **            LET Y(I) = X*SIN(X)  FOR I = 1 2 10  **
26157C               **            LET U    = I         FOR I = 1 2 10  **
26158C               **            LET U    = X(2)      FOR I = 1 2 10  **
26159C               **            LET U    = 3*SIN(4)  FOR I = 1 2 10  **
26160C               **            LET U    = B*SIN(B)  FOR I = 1 2 10  **
26161C               **            LET U    = X*SIN(X)  FOR I = 1 2 10  **
26162C               **            LET U(I) = I         FOR I = 1 2 10  **
26163C               **            LET U(I) = X(2)      FOR I = 1 2 10  **
26164C               **            LET U(I) = 3*SIN(4)  FOR I = 1 2 10  **
26165C               **            LET U(I) = B*SIN(B)  FOR I = 1 2 10  **
26166C               **            LET U(I) = X*SIN(X)  FOR I = 1 2 10  **
26167C               **  WHERE Y WAS A PREVIOUSLY-DEFINED VARIABLE      **
26168C               **  AND WHERE U WAS PREVIOUSLY UNDEFINED.          **
26169C               **  THEN JUMP TO STEP NUMBER 10 BELOW              **
26170C               **  FOR THE THE LIST UPDATING  AND                 **
26171C               **  GENERATE THE INFORMATIVE PRINTING.             **
26172C               **  THEN EXIT.                                     **
26173C               *****************************************************
26174C
26175 9000 CONTINUE
26176      ISTEPN='9'
26177      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26178C
26179      IF(ICASEL.EQ.'VAR')ICOLL=IVALUE(ILISTL)
26180      IF(ICASEL.EQ.'UNKN')ICOLL=NUMCOL+1
26181      IF(ICOLL.LE.MAXCOL)GOTO9090
26182CCCCC THE FOLLOWING LINE WAS INSERTED MARCH 1988
26183CCCCC TO FIX THE PROBLEM OF LET PRED = ... SUBSET ...
26184CCCCC YIELDING A "TOO MANY VARIABLES" MESSAGE
26185      IF(ICASEL.EQ.'VAR')GOTO9090
26186      WRITE(ICOUT,9051)
26187 9051 FORMAT('***** ERROR IN DPFUEV AT 9051--')
26188      CALL DPWRST('XXX','BUG ')
26189      WRITE(ICOUT,9052)
26190 9052 FORMAT('      THE NUMBER OF DATA COLUMNS')
26191      CALL DPWRST('XXX','BUG ')
26192      WRITE(ICOUT,9053)MAXCOL
26193 9053 FORMAT('      HAS JUST EXCEEDED THE MAX ALLOWABLE ',I8,'  .')
26194      CALL DPWRST('XXX','BUG ')
26195      WRITE(ICOUT,9054)
26196 9054 FORMAT('      SUGGESTED ACTION--')
26197      CALL DPWRST('XXX','BUG ')
26198      WRITE(ICOUT,9055)
26199 9055 FORMAT('      ENTER      STAT')
26200      CALL DPWRST('XXX','BUG ')
26201      WRITE(ICOUT,9056)
26202 9056 FORMAT('      TO FIND OUT THE FULL LIST OF USED COLUMNS')
26203      CALL DPWRST('XXX','BUG ')
26204      WRITE(ICOUT,9057)
26205 9057 FORMAT('      AND THEN OVERWRITE SOME COLUMN.   ')
26206      CALL DPWRST('XXX','BUG ')
26207      WRITE(ICOUT,9058)
26208 9058 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
26209      CALL DPWRST('XXX','BUG ')
26210      IF(IWIDTH.GE.1)WRITE(ICOUT,9059)(IANS(I),I=1,IWIDTH)
26211 9059 FORMAT(80A1)
26212      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
26213      IERROR='YES'
26214      GOTO19000
26215C
26216 9090 CONTINUE
26217      NIOLD=IN(ILISTL)
26218      CALL DPFOR(NIOLD,NIFOR,IROW1,IROWN,
26219     1NLOCAL,ILOCS,NS,IBUGQ,IERROR)
26220C
26221      NINEW=NIFOR
26222      IF(ICASER.EQ.'VAR')NINEW=NIRIGH
26223C
26224      IF(ICASER.EQ.'DUMM')GOTO9100
26225      IF(ICASER.EQ.'ELEM')GOTO9200
26226      IF(ICASER.EQ.'PARA')GOTO9300
26227      IF(ICASER.EQ.'VAR')GOTO9300
26228C
26229 9100 CONTINUE
26230      NS2=0
26231      DO9150I=1,NIFOR
26232      IF(ISUB(I).EQ.0)GOTO9150
26233      NS2=NS2+1
26234      RIGHT=I
26235      IJ=MAXN*(ICOLL-1)+I
26236      IF(ICOLL.LE.MAXCOL)V(IJ)=RIGHT
26237      IF(ICOLL.EQ.MAXCP1)PRED(I)=RIGHT
26238      IF(ICOLL.EQ.MAXCP2)RES(I)=RIGHT
26239      IF(ICOLL.EQ.MAXCP3)YPLOT(I)=RIGHT
26240      IF(ICOLL.EQ.MAXCP4)XPLOT(I)=RIGHT
26241      IF(ICOLL.EQ.MAXCP5)X2PLOT(I)=RIGHT
26242      IF(ICOLL.EQ.MAXCP6)TAGPLO(I)=RIGHT
26243      IF(NS2.EQ.1)IROW1=I
26244      IROWN=I
26245 9150 CONTINUE
26246      GOTO10000
26247C
26248 9200 CONTINUE
26249      IARG9I=INT1(9)
26250      IJ=MAXN*(ICOLR-1)+IARG9I
26251      IF(ICOLR.LE.MAXCOL)RIGHT=V(IJ)
26252      IF(ICOLR.EQ.MAXCP1)RIGHT=PRED(IARG9I)
26253      IF(ICOLR.EQ.MAXCP2)RIGHT=RES(IARG9I)
26254      IF(ICOLR.EQ.MAXCP3)RIGHT=YPLOT(IARG9I)
26255      IF(ICOLR.EQ.MAXCP4)RIGHT=XPLOT(IARG9I)
26256      IF(ICOLR.EQ.MAXCP5)RIGHT=X2PLOT(IARG9I)
26257      IF(ICOLR.EQ.MAXCP6)RIGHT=TAGPLO(IARG9I)
26258      NS2=0
26259      DO9250I=1,NIFOR
26260      IF(ISUB(I).EQ.0)GOTO9250
26261      NS2=NS2+1
26262      IJ=MAXN*(ICOLL-1)+I
26263      IF(ICOLL.LE.MAXCOL)V(IJ)=RIGHT
26264      IF(ICOLL.EQ.MAXCP1)PRED(I)=RIGHT
26265      IF(ICOLL.EQ.MAXCP2)RES(I)=RIGHT
26266      IF(ICOLL.EQ.MAXCP3)YPLOT(I)=RIGHT
26267      IF(ICOLL.EQ.MAXCP4)XPLOT(I)=RIGHT
26268      IF(ICOLL.EQ.MAXCP5)X2PLOT(I)=RIGHT
26269      IF(ICOLL.EQ.MAXCP6)TAGPLO(I)=RIGHT
26270      IF(NS2.EQ.1)IROW1=I
26271      IROWN=I
26272 9250 CONTINUE
26273      GOTO10000
26274C
26275 9300 CONTINUE
26276      IPASS=2
26277      IMAX=NIFOR
26278      IF(NINEW.LT.IMAX)IMAX=NINEW
26279      NS2=0
26280      DO9350I=1,IMAX
26281      IF(ISUB(I).EQ.0)GOTO9350
26282      NS2=NS2+1
26283C
26284      IF(NUMPAR.LE.0)GOTO9390
26285      DO9355J=1,NUMPAR
26286      IPJ=IPARN(J)
26287      IPJ2=IPARN2(J)
26288      DO9356K=1,NUMNAM
26289      K2=K
26290      IF(IPJ.EQ.IHNAME(K).AND.IPJ2.EQ.IHNAM2(K).AND.
26291     1IUSE(K).EQ.'P')GOTO9360
26292      IF(IPJ.EQ.IHNAME(K).AND.IPJ2.EQ.IHNAM2(K).AND.
26293     1IUSE(K).EQ.'V')GOTO9370
26294 9356 CONTINUE
26295      GOTO9380
26296C
26297 9360 CONTINUE
26298      PARAM(J)=VALUE(K2)
26299      GOTO9355
26300C
26301 9370 CONTINUE
26302      ICOLK2=IVALUE(K2)
26303      IJ=MAXN*(ICOLK2-1)+I
26304      IF(ICOLK2.LE.MAXCOL)PARAM(J)=V(IJ)
26305      IF(ICOLK2.EQ.MAXCP1)PARAM(J)=PRED(I)
26306      IF(ICOLK2.EQ.MAXCP2)PARAM(J)=RES(I)
26307      IF(ICOLK2.EQ.MAXCP3)PARAM(J)=YPLOT(I)
26308      IF(ICOLK2.EQ.MAXCP4)PARAM(J)=XPLOT(I)
26309      IF(ICOLK2.EQ.MAXCP5)PARAM(J)=X2PLOT(I)
26310      IF(ICOLK2.EQ.MAXCP6)PARAM(J)=TAGPLO(I)
26311 9355 CONTINUE
26312      GOTO9390
26313C
26314 9380 CONTINUE
26315      WRITE(ICOUT,999)
26316      CALL DPWRST('XXX','BUG ')
26317      WRITE(ICOUT,9381)
26318 9381 FORMAT('***** INTERNAL ERROR IN DPFUEV')
26319      CALL DPWRST('XXX','BUG ')
26320      WRITE(ICOUT,9382)
26321 9382 FORMAT('      AT BRANCH POINT 9381--')
26322      CALL DPWRST('XXX','BUG ')
26323      WRITE(ICOUT,9393)
26324 9393 FORMAT('      PARAMETER/VARIABLE NAME FOR FUNCTION ',
26325     1'EVALUATION')
26326      CALL DPWRST('XXX','BUG ')
26327      WRITE(ICOUT,9384)
26328 9384 FORMAT('      NOT FOUND IN INTERNAL LIST.')
26329      CALL DPWRST('XXX','BUG ')
26330      WRITE(ICOUT,9385)IPJ,IPJ2
26331 9385 FORMAT('      PARAMETER/VARIABLE NAME = ',A4,A4)
26332      CALL DPWRST('XXX','BUG ')
26333      WRITE(ICOUT,9386)
26334 9386 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
26335      CALL DPWRST('XXX','BUG ')
26336      IF(IWIDTH.GE.1)WRITE(ICOUT,9387)(IANS(I3),I3=1,IWIDTH)
26337 9387 FORMAT(80A1)
26338      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
26339      IERROR='YES'
26340      GOTO19000
26341C
26342 9390 CONTINUE
26343      CALL COMPIM(IA,NUMCHA,IPASS,PARAM,IPARN,IPARN2,NUMPAR,
26344     1IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,RIGHT,
26345     1IBUGCO,IBUGEV,IERROR)
26346      IF(IERROR.EQ.'YES')GOTO19000
26347      IJ=MAXN*(ICOLL-1)+I
26348      IF(ICOLL.LE.MAXCOL)V(IJ)=RIGHT
26349      IF(ICOLL.EQ.MAXCP1)PRED(I)=RIGHT
26350      IF(ICOLL.EQ.MAXCP2)RES(I)=RIGHT
26351      IF(ICOLL.EQ.MAXCP3)YPLOT(I)=RIGHT
26352      IF(ICOLL.EQ.MAXCP4)XPLOT(I)=RIGHT
26353      IF(ICOLL.EQ.MAXCP5)X2PLOT(I)=RIGHT
26354      IF(ICOLL.EQ.MAXCP6)TAGPLO(I)=RIGHT
26355      IF(NS2.EQ.1)IROW1=I
26356      IROWN=I
26357 9350 CONTINUE
26358      GOTO10000
26359C
26360C               *******************************************
26361C               **  STEP 10--                            **
26362C               **  CARRY OUT THE LIST UPDATING AND      **
26363C               **  GENERATE THE INFORMATIVE PRINTING    **
26364C               **  FOR STEP NUMBERS 7, 8, AND 9 ABOVE.  **
26365C               *******************************************
26366C
2636710000 CONTINUE
26368      IHNAME(ILISTL)=ILEFT
26369      IHNAM2(ILISTL)=ILEFT2
26370      IUSE(ILISTL)='V'
26371      IVALUE(ILISTL)=ICOLL
26372      VALUE(ILISTL)=ICOLL
26373      IN(ILISTL)=NINEW
26374C
26375CCCCC IUSE(ICOLL)='V'
26376CCCCC IVALUE(ICOLL)=ICOLL
26377CCCCC VALUE(ICOLL)=ICOLL
26378CCCCC IN(ICOLL)=NINEW
26379C
26380      IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1
26381      IF(NEWNAM.EQ.'YES')NUMCOL=NUMCOL+1
26382C
26383      DO10100J4=1,NUMNAM
26384      IF(IUSE(J4).EQ.'V'.AND.IVALUE(J4).EQ.ICOLL)GOTO10105
26385      GOTO10100
2638610105 CONTINUE
26387      IUSE(J4)='V'
26388      IVALUE(J4)=ICOLL
26389      VALUE(J4)=ICOLL
26390      IN(J4)=NINEW
2639110100 CONTINUE
26392C
26393      IF(IPRINT.EQ.'OFF')GOTO10099
26394      IF(IFEEDB.EQ.'OFF')GOTO10099
26395      WRITE(ICOUT,999)
26396      CALL DPWRST('XXX','BUG ')
26397      WRITE(ICOUT,10011)ILEFT,ILEFT2,NS2
2639810011 FORMAT('THE NUMBER OF VALUES GENERATED FOR ',
26399     1'THE VARIABLE ',A4,A4,' = ',I8)
26400      CALL DPWRST('XXX','BUG ')
26401      WRITE(ICOUT,999)
26402      CALL DPWRST('XXX','BUG ')
26403      IJ=MAXN*(ICOLL-1)+IROW1
26404      IF(ICOLL.LE.MAXCOL)WRITE(ICOUT,10021)ILEFT,ILEFT2,V(IJ),IROW1
2640510021 FORMAT('THE FIRST          COMPUTED VALUE OF ',A4,A4,
26406     1' = ',E13.6,' (ROW ',I5,')')
26407      IF(ICOLL.LE.MAXCOL)CALL DPWRST('XXX','BUG ')
26408      IF(ICOLL.EQ.MAXCP1)WRITE(ICOUT,10021)ILEFT,ILEFT2,PRED(IROW1),
26409     1IROW1
26410      IF(ICOLL.EQ.MAXCP1)CALL DPWRST('XXX','BUG ')
26411      IF(ICOLL.EQ.MAXCP2)WRITE(ICOUT,10021)ILEFT,ILEFT2,RES(IROW1),IROW1
26412      IF(ICOLL.EQ.MAXCP2)CALL DPWRST('XXX','BUG ')
26413      IF(ICOLL.EQ.MAXCP3)WRITE(ICOUT,10021)ILEFT,ILEFT2,YPLOT(IROW1),
26414     1IROW1
26415      IF(ICOLL.EQ.MAXCP3)CALL DPWRST('XXX','BUG ')
26416      IF(ICOLL.EQ.MAXCP4)WRITE(ICOUT,10021)ILEFT,ILEFT2,XPLOT(IROW1),
26417     1IROW1
26418      IF(ICOLL.EQ.MAXCP4)CALL DPWRST('XXX','BUG ')
26419      IF(ICOLL.EQ.MAXCP5)WRITE(ICOUT,10021)ILEFT,ILEFT2,X2PLOT(IROW1),
26420     1IROW1
26421      IF(ICOLL.EQ.MAXCP5)CALL DPWRST('XXX','BUG ')
26422      IF(ICOLL.EQ.MAXCP6)WRITE(ICOUT,10021)ILEFT,ILEFT2,TAGPLO(IROW1),
26423     1IROW1
26424      IF(ICOLL.EQ.MAXCP6)CALL DPWRST('XXX','BUG ')
26425C
26426      IJ=MAXN*(ICOLL-1)+IROWN
26427      IF(ICOLL.LE.MAXCOL.AND.
26428     1NS2.NE.1)WRITE(ICOUT,10031)NS2,ILEFT,ILEFT2,V(IJ),IROWN
2642910031 FORMAT('THE LAST (',I5,'TH) COMPUTED VALUE OF ',A4,A4,
26430     1' = ',E13.6,' (ROW ',I5,')')
26431      IF(ICOLL.LE.MAXCOL.AND.
26432     1NS2.NE.1)CALL DPWRST('XXX','BUG ')
26433      IF(ICOLL.EQ.MAXCP1.AND.
26434     1NS2.NE.1)WRITE(ICOUT,10031)NS2,ILEFT,ILEFT2,PRED(IROWN),IROWN
26435      IF(ICOLL.EQ.MAXCP1.AND.
26436     1NS2.NE.1)CALL DPWRST('XXX','BUG ')
26437      IF(ICOLL.EQ.MAXCP2.AND.
26438     1NS2.NE.1)WRITE(ICOUT,10031)NS2,ILEFT,ILEFT2,YPLOT(IROWN),IROWN
26439      IF(ICOLL.EQ.MAXCP2.AND.
26440     1NS2.NE.1)CALL DPWRST('XXX','BUG ')
26441      IF(ICOLL.EQ.MAXCP3.AND.
26442     1NS2.NE.1)WRITE(ICOUT,10031)NS2,ILEFT,ILEFT2,XPLOT(IROWN),IROWN
26443      IF(ICOLL.EQ.MAXCP3.AND.
26444     1NS2.NE.1)CALL DPWRST('XXX','BUG ')
26445      IF(ICOLL.EQ.MAXCP4.AND.
26446     1NS2.NE.1)WRITE(ICOUT,10031)NS2,ILEFT,ILEFT2,X2PLOT(IROWN),IROWN
26447      IF(ICOLL.EQ.MAXCP4.AND.
26448     1NS2.NE.1)CALL DPWRST('XXX','BUG ')
26449      IF(ICOLL.EQ.MAXCP5.AND.
26450     1NS2.NE.1)WRITE(ICOUT,10031)NS2,ILEFT,ILEFT2,TAGPLO(IROWN),IROWN
26451      IF(ICOLL.EQ.MAXCP5.AND.
26452     1NS2.NE.1)CALL DPWRST('XXX','BUG ')
26453      IF(ICOLL.EQ.MAXCP6.AND.
26454     1NS2.NE.1)WRITE(ICOUT,10031)NS2,ILEFT,ILEFT2,RES(IROWN),IROWN
26455      IF(ICOLL.EQ.MAXCP6.AND.
26456     1NS2.NE.1)CALL DPWRST('XXX','BUG ')
26457      IF(NS2.NE.1)GOTO10090
26458      WRITE(ICOUT,10041)
2645910041 FORMAT('SINCE THE GENERATED SAMPLE SIZE WAS ONLY 1,')
26460      CALL DPWRST('XXX','BUG ')
26461      WRITE(ICOUT,10042)
2646210042 FORMAT('THE ABOVE VALUE WAS THE SOLE VALUE COMPUTED.')
26463      CALL DPWRST('XXX','BUG ')
2646410090 CONTINUE
26465      WRITE(ICOUT,999)
26466      CALL DPWRST('XXX','BUG ')
26467      WRITE(ICOUT,10092)ILEFT,ILEFT2,ICOLL
2646810092 FORMAT('THE CURRENT COLUMN FOR ',
26469     1'THE VARIABLE ',A4,A4,' = ',I8)
26470      CALL DPWRST('XXX','BUG ')
26471      WRITE(ICOUT,10093)ILEFT,ILEFT2,NINEW
2647210093 FORMAT('THE CURRENT LENGTH OF  ',
26473     1'THE VARIABLE ',A4,A4,' = ',I8)
26474      CALL DPWRST('XXX','BUG ')
26475      WRITE(ICOUT,999)
26476      CALL DPWRST('XXX','BUG ')
2647710099 CONTINUE
26478      GOTO19000
26479C
26480C               *****************
26481C               **  STEP 90--  **
26482C               **  EXIT       **
26483C               *****************
26484C
2648519000 CONTINUE
26486C
26487C  RESTORE ORIGINAL FUNCTION TABLE
26488C
26489      DO19001I=1,NUMCHF
26490        IFUNC(I)=IFSAVE(I)
2649119001 CONTINUE
26492C
26493      IF(IBUGA3.EQ.'OFF')GOTO19090
26494      WRITE(ICOUT,999)
26495      CALL DPWRST('XXX','BUG ')
26496      WRITE(ICOUT,19011)
2649719011 FORMAT('***** AT THE END       OF DPFUEV--')
26498      CALL DPWRST('XXX','BUG ')
26499      WRITE(ICOUT,19012)IBUGA3
2650019012 FORMAT('IBUGA3 = ',A4)
26501      CALL DPWRST('XXX','BUG ')
26502      WRITE(ICOUT,19013)IBUGCO,IBUGEV
2650319013 FORMAT('IBUGCO,IBUGEV = ',A4,2X,A4)
26504      CALL DPWRST('XXX','BUG ')
26505      WRITE(ICOUT,19014)IBUGQ
2650619014 FORMAT('IBUGQ = ',A4)
26507      CALL DPWRST('XXX','BUG ')
26508      WRITE(ICOUT,19015)IANGLU
2650919015 FORMAT('IANGLU = ',A4)
26510      CALL DPWRST('XXX','BUG ')
26511      WRITE(ICOUT,19016)IFOUND,IERROR
2651219016 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
26513      CALL DPWRST('XXX','BUG ')
26514      WRITE(ICOUT,19017)NUMNAM
2651519017 FORMAT('NUMNAM = ',I8)
26516      CALL DPWRST('XXX','BUG ')
26517      WRITE(ICOUT,19018)ICASEQ,ICASIF
2651819018 FORMAT('ICASEQ,ICASIF = ',A4,2X,A4)
26519      CALL DPWRST('XXX','BUG ')
26520      DO19020I=1,NUMNAM
26521      WRITE(ICOUT,19021)I,IHNAME(I),IHNAM2(I),IUSE(I),IVALUE(I),VALUE(I)
2652219021 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVALUE(I),VALUE(I) = ',
26523     1I8,2X,A4,2X,A4,2X,A4,I8,E15.7)
26524      CALL DPWRST('XXX','BUG ')
2652519020 CONTINUE
2652619090 CONTINUE
26527C
26528      RETURN
26529      END
26530