1      SUBROUTINE DPC4HI(IHVAL,IVAL,IBUGA3,IERROR)
2C
3C     PURPOSE--CONVERT A CHARACTER VARIABLE
4C              INTO THE CORRESPONDING INTEGER VALUE.
5C     NOTE--INASMUCH AS THE ASSUMED INPUT WORD HAS 4 CHARACTERS AT MOST,
6C           THEN THE VALID RANGE OF THE OUTPUT INTEGER VARIABLE
7C           IS -999 TO 9999   .
8C
9C     WRITTEN BY--JAMES J. FILLIBEN
10C                 STATISTICAL ENGINEERING DIVISION
11C                 INFORMATION TECHNOLOGY LABORATORY
12C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
13C                 GAITHERSBURG, MD 20899-8980
14C                 PHONE--301-975-2899
15C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
16C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
17C     LANGUAGE--ANSI FORTRAN (1977)
18C     VERSION NUMBER--82/7
19C     ORIGINAL VERSION--JANUARY  1981.
20C     UPDATED         --MAY       1982.
21C
22C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
23C
24      CHARACTER*4 IHVAL
25      CHARACTER*4 IBUGA3
26      CHARACTER*4 IERROR
27C
28      CHARACTER*4 IHTEMP
29      CHARACTER*4 ISIGN
30C
31C---------------------------------------------------------------------
32C
33      DIMENSION IHTEMP(4)
34C
35C---------------------------------------------------------------------
36C
37      INCLUDE 'DPCOP2.INC'
38C
39C-----START POINT-----------------------------------------------------
40C
41      IERROR='NO'
42      NUMASC=4
43      IVAL=0
44C
45      ITERM=0
46C
47      IF(IBUGA3.EQ.'OFF')GOTO90
48      WRITE(ICOUT,999)
49      CALL DPWRST('XXX','BUG ')
50      WRITE(ICOUT,51)
51   51 FORMAT('***** AT THE BEGINNING OF DPC4HI--')
52      CALL DPWRST('XXX','BUG ')
53      WRITE(ICOUT,52)IHVAL,IBUGA3,IERROR
54   52 FORMAT('IHVAL,IBUGA3,IERROR = ',A4,2X,A4,2X,A4)
55      CALL DPWRST('XXX','BUG ')
56   90 CONTINUE
57C
58C               *******************************************
59C               **  STEP 1--                             **
60C               **  DECOMPOSE THE 4-CHARACTERS IN IHVAL  **
61C               **  INTO 4 1-CHARACTER WORDS.            **
62C               *******************************************
63C
64      DO200J=1,NUMASC
65      IHTEMP(J)='    '
66      ISTAR1=NUMBPC*(J-1)
67      CALL DPCHEX(ISTAR1,NUMBPC,IHVAL,0,NUMBPC,IHTEMP(J))
68  200 CONTINUE
69C
70C               ******************************************************
71C               **  STEP 2--                                        **
72C               **  CARRY OUT THE HOLLERITH TO INTEGER CONVERSION.  **
73C               ******************************************************
74C
75      ISIGN='+'
76      NUMSIG=0
77      IDIGI=0
78      ISUM=0
79      DO400I=1,NUMASC
80      IREV=NUMASC-I+1
81      IF(IHTEMP(IREV).EQ.' ')GOTO400
82      IF(IHTEMP(IREV).EQ.'0')GOTO410
83      IF(IHTEMP(IREV).EQ.'1')GOTO411
84      IF(IHTEMP(IREV).EQ.'2')GOTO412
85      IF(IHTEMP(IREV).EQ.'3')GOTO413
86      IF(IHTEMP(IREV).EQ.'4')GOTO414
87      IF(IHTEMP(IREV).EQ.'5')GOTO415
88      IF(IHTEMP(IREV).EQ.'6')GOTO416
89      IF(IHTEMP(IREV).EQ.'7')GOTO417
90      IF(IHTEMP(IREV).EQ.'8')GOTO418
91      IF(IHTEMP(IREV).EQ.'9')GOTO419
92      IF(IHTEMP(IREV).EQ.'+')GOTO420
93      IF(IHTEMP(IREV).EQ.'-')GOTO421
94C
95      WRITE(ICOUT,999)
96      CALL DPWRST('XXX','BUG ')
97      WRITE(ICOUT,431)
98  431 FORMAT('***** ERROR IN DPC4HI--')
99      CALL DPWRST('XXX','BUG ')
100      WRITE(ICOUT,432)
101  432 FORMAT('      CHARACTER ENCOUNTERED IN THE CONVERSION')
102      CALL DPWRST('XXX','BUG ')
103      WRITE(ICOUT,433)
104  433 FORMAT('      WHICH WAS NOT 0 THROUGH 9, +, - OR SPACE.')
105      CALL DPWRST('XXX','BUG ')
106      WRITE(ICOUT,434)IHTEMP(IREV)
107  434 FORMAT('      CHARACTER IN QUESTION IHTEMP(IREV) = ',A4)
108      CALL DPWRST('XXX','BUG ')
109      WRITE(ICOUT,435)IHVAL
110  435 FORMAT('      IHVAL = ',A4)
111      CALL DPWRST('XXX','BUG ')
112      IERROR='YES'
113      GOTO9000
114C
115  410 ITERM=0
116      GOTO425
117  411 ITERM=1
118      GOTO425
119  412 ITERM=2
120      GOTO425
121  413 ITERM=3
122      GOTO425
123  414 ITERM=4
124      GOTO425
125  415 ITERM=5
126      GOTO425
127  416 ITERM=6
128      GOTO425
129  417 ITERM=7
130      GOTO425
131  418 ITERM=8
132      GOTO425
133  419 ITERM=9
134      GOTO425
135  420 NUMSIG=NUMSIG+1
136      GOTO400
137  421 NUMSIG=NUMSIG+1
138      ISIGN='-'
139      GOTO400
140  425 IDIGI=IDIGI+1
141      IEXP=IDIGI-1
142CCCCC ISUM=ISUM+ITERM*(10**IEXP)
143      IJUNK=INT(10.0**IEXP + 0.01)
144      ISUM=ISUM+ITERM*IJUNK
145  400 CONTINUE
146C
147      IF(NUMSIG.LE.1)GOTO459
148      WRITE(ICOUT,999)
149      CALL DPWRST('XXX','BUG ')
150      WRITE(ICOUT,451)
151  451 FORMAT('***** ERROR IN DPC4HI--')
152      CALL DPWRST('XXX','BUG ')
153      WRITE(ICOUT,452)
154  452 FORMAT('      MULTIPLE SIGNS (+/-) ENCOUNTERED')
155      CALL DPWRST('XXX','BUG ')
156      WRITE(ICOUT,453)
157  453 FORMAT('      IN THE CONVERSION.')
158      CALL DPWRST('XXX','BUG ')
159      WRITE(ICOUT,454)NUMSIG
160  454 FORMAT('      NUMBER OF SIGNS NUMSIG = ',I8)
161      CALL DPWRST('XXX','BUG ')
162      WRITE(ICOUT,456)(IHTEMP(J),J=1,NUMASC)
163  456 FORMAT('      (IHTEMP(J),J=1,NUMASC) = ',4A4)
164      CALL DPWRST('XXX','BUG ')
165      WRITE(ICOUT,457)IHVAL
166  457 FORMAT('      IHVAL = ',A4)
167      CALL DPWRST('XXX','BUG ')
168      IERROR='YES'
169      GOTO9000
170  459 CONTINUE
171      IF(ISIGN.EQ.'-')ISUM=-ISUM
172      IVAL=ISUM
173C
174C               ****************
175C               **  STEP 90-- **
176C               **  EXIT.     **
177C               ****************
178C
179 9000 CONTINUE
180      IF(IBUGA3.EQ.'OFF')GOTO9090
181      WRITE(ICOUT,999)
182  999 FORMAT(1X)
183      CALL DPWRST('XXX','BUG ')
184      WRITE(ICOUT,9011)
185 9011 FORMAT('***** AT THE END OF DPC4HI--')
186      CALL DPWRST('XXX','BUG ')
187      WRITE(ICOUT,9012)IHVAL
188 9012 FORMAT('IHVAL = ',A4)
189      CALL DPWRST('XXX','BUG ')
190      WRITE(ICOUT,9014)(IHTEMP(J),J=1,NUMASC)
191 9014 FORMAT('(IHTEMP(J),J=1,NUMASC) = ',4A4)
192      CALL DPWRST('XXX','BUG ')
193      WRITE(ICOUT,9015)NUMASC,ISIGN,NUMSIG,ISUM,ITERM
194 9015 FORMAT('NUMASC,ISIGN,NUMSIG,ISUM,ITERM = ',I8,2X,A4,3I8)
195      CALL DPWRST('XXX','BUG ')
196      WRITE(ICOUT,9016)IBUGA3,IERROR
197 9016 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
198      CALL DPWRST('XXX','BUG ')
199      WRITE(ICOUT,9017)IVAL
200 9017 FORMAT('IVAL = ',I8)
201      CALL DPWRST('XXX','BUG ')
202 9090 CONTINUE
203C
204      RETURN
205      END
206      SUBROUTINE DPC4IH(IVAL,IHVAL,IBUGA3,IERROR)
207C
208C     PURPOSE--CONVERT AN INTEGER VARIABLE
209C              TO A 4-CHARACTER-PER-WORD HOLLERITH STRING.
210C     NOTE--CONVERT ONLY THE FIRST 4 CHARACTERS OF THE
211C           INTEGER VARIABLE (INCLUDING THE NEGATIVE
212C           SIGN, IF EXISTENT).
213C     NOTE--INCORRECT VALUERS WILL RESULT IF THE INPUT INTEGER
214C           IS LARGER THAN 9999 OR SMALLER THAN -999   .
215C
216C     WRITTEN BY--JAMES J. FILLIBEN
217C                 STATISTICAL ENGINEERING DIVISION
218C                 INFORMATION TECHNOLOGY LABORATORY
219C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
220C                 GAITHERSBURG, MD 20899-8980
221C                 PHONE--301-975-2899
222C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
223C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
224C     LANGUAGE--ANSI FORTRAN (1977)
225C     VERSION NUMBER--82/7
226C     ORIGINAL VERSION--JANUARY  1981.
227C     UPDATED         --MARCH     1982.
228C     UPDATED         --MAY       1982.
229C
230C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
231C
232      CHARACTER*4 IHVAL
233      CHARACTER*4 IBUGA3
234      CHARACTER*4 IERROR
235C
236      CHARACTER*4 IHTEMP
237      CHARACTER*4 ISIGN
238      CHARACTER*4 IHDIG
239C
240C---------------------------------------------------------------------
241C
242      DIMENSION IHTEMP(4)
243C
244C---------------------------------------------------------------------
245C
246      INCLUDE 'DPCOP2.INC'
247C
248C-----START POINT-----------------------------------------------------
249C
250      IERROR='NO'
251      NUMASC=4
252      IVAL2=IVAL
253      IHVAL='    '
254C
255      IF(IBUGA3.EQ.'OFF')GOTO90
256      WRITE(ICOUT,999)
257      CALL DPWRST('XXX','BUG ')
258      WRITE(ICOUT,51)
259   51 FORMAT('***** AT THE BEGINNING OF DPC4IH--')
260      CALL DPWRST('XXX','BUG ')
261      WRITE(ICOUT,52)IVAL,IBUGA3,IERROR
262   52 FORMAT('IVAL,IBUGA3,IERROR = ',I8,2X,A4,2X,A4)
263      CALL DPWRST('XXX','BUG ')
264   90 CONTINUE
265C
266C               ***********************
267C               **  STEP 2--         **
268C               **  DETERMINE SIGN.  **
269C               ***********************
270C
271      ISIGN='+'
272      IF(IVAL2.LT.0)ISIGN='-'
273      IVAL2=IABS(IVAL2)
274C
275C               ***********************************
276C               **  STEP 3--                     **
277C               **  DETERMINE NUMBER OF DIGITS.  **
278C               ***********************************
279C
280      IMIN=1
281      IMAX=NUMASC
282      DO300I=IMIN,IMAX
283      IREV=IMAX-I+IMIN
284      IDIV=INT(10.0**(IREV-1) + 0.01)
285      IDIG=IVAL2/IDIV
286      IF(IDIG.NE.0)GOTO350
287  300 CONTINUE
288      NUMDIG=1
289      GOTO390
290  350 CONTINUE
291      NUMDIG=IREV
292  390 CONTINUE
293C
294C               ***************************************
295C               **  STEP 4--                         **
296C               **  IF NEGATIVE,                     **
297C               **  INSERT SIGN INTO OUTPUT VECTOR.  **
298C               ***************************************
299C
300      J=0
301      IF(ISIGN.EQ.'-')J=J+1
302      IF(ISIGN.EQ.'-')IHTEMP(J)='-'
303C
304C               **************************
305C               **  STEP 5--            **
306C               **  INSERT DIGITS INTO  **
307C               **  OUTPUT VECTOR.      **
308C               **************************
309C
310      IMIN=1
311      IMAX=NUMDIG
312      IF(IMAX.GE.NUMASC.AND.ISIGN.EQ.'-')IMAX=NUMASC-1
313      IF(IMAX.GE.NUMASC.AND.ISIGN.EQ.'+')IMAX=NUMASC
314      DO500I=IMIN,IMAX
315      IREV=IMAX-I+IMIN
316      IDIV=INT(10.0**(IREV-1) + 0.01)
317      IDIG=IVAL2/IDIV
318C
319      IF(IDIG.EQ.0)GOTO510
320      IF(IDIG.EQ.1)GOTO511
321      IF(IDIG.EQ.2)GOTO512
322      IF(IDIG.EQ.3)GOTO513
323      IF(IDIG.EQ.4)GOTO514
324      IF(IDIG.EQ.5)GOTO515
325      IF(IDIG.EQ.6)GOTO516
326      IF(IDIG.EQ.7)GOTO517
327      IF(IDIG.EQ.8)GOTO518
328      IF(IDIG.EQ.9)GOTO519
329  510 CONTINUE
330      IHDIG='0'
331      GOTO529
332  511 CONTINUE
333      IHDIG='1'
334      GOTO529
335  512 CONTINUE
336      IHDIG='2'
337      GOTO529
338  513 CONTINUE
339      IHDIG='3'
340      GOTO529
341  514 CONTINUE
342      IHDIG='4'
343      GOTO529
344  515 CONTINUE
345      IHDIG='5'
346      GOTO529
347  516 CONTINUE
348      IHDIG='6'
349      GOTO529
350  517 CONTINUE
351      IHDIG='7'
352      GOTO529
353  518 CONTINUE
354      IHDIG='8'
355      GOTO529
356  519 CONTINUE
357      IHDIG='9'
358      GOTO529
359  529 CONTINUE
360C
361      J=J+1
362      IF(J.GT.NUMASC)GOTO550
363      IHTEMP(J)=IHDIG
364      IVAL2=IVAL2-IDIG*IDIV
365  500 CONTINUE
366C
367      NTEMP=J
368      GOTO590
369C
370  550 CONTINUE
371      NTEMP=J-1
372      GOTO590
373C
374  590 CONTINUE
375C
376C               ***************************************
377C               **  STEP 6--                         **
378C               **  PACK THE CHARACTERS INTO 1 WORD  **
379C               ***************************************
380C
381      IHVAL='    '
382      IMAX=NUMASC
383      IF(NTEMP.LE.IMAX)IMAX=NTEMP
384      IF(IMAX.LE.0)GOTO690
385      DO600J=1,IMAX
386      ISTAR2=NUMBPC*(J-1)
387      CALL DPCHEX(0,NUMBPC,IHTEMP(J),ISTAR2,NUMBPC,IHVAL)
388  600 CONTINUE
389  690 CONTINUE
390C
391C               ****************
392C               **  STEP 90-- **
393C               **  EXIT.     **
394C               ****************
395C
396      IF(IBUGA3.EQ.'ON')THEN
397        WRITE(ICOUT,999)
398  999   FORMAT(1X)
399        CALL DPWRST('XXX','BUG ')
400        WRITE(ICOUT,9011)
401 9011   FORMAT('***** AT THE END OF DPC4IH--')
402        CALL DPWRST('XXX','BUG ')
403        WRITE(ICOUT,9013)ISIGN,NUMDIG,NUMASC,IMAX,IVAL,NTEMP
404 9013   FORMAT('ISIGN,NUMDIG,NUMASC,IMAX,IVAL,NTEMP = ',A4,5I8)
405        CALL DPWRST('XXX','BUG ')
406        WRITE(ICOUT,9015)(IHTEMP(I),I=1,NTEMP)
407 9015   FORMAT('IHTEMP(.) = ',80A1)
408        CALL DPWRST('XXX','BUG ')
409        WRITE(ICOUT,9016)ISTAR2,IHVAL
410 9016   FORMAT('ISTAR2,IHVAL = ',I8,2X,A4)
411        CALL DPWRST('XXX','BUG ')
412        WRITE(ICOUT,9017)IBUGA3,IERROR
413 9017   FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
414        CALL DPWRST('XXX','BUG ')
415      ENDIF
416C
417      RETURN
418      END
419      SUBROUTINE DPCAAN(XTEMP1,MAXNXT,
420     1                  ICASAN,ICAPSW,IFORSW,
421     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
422C
423C     PURPOSE--GENERATE A TABLE OF CAPABILITY ANALYSIS STATISTICS
424C     WRITTEN BY--JAMES J. FILLIBEN
425C                 STATISTICAL ENGINEERING DIVISION
426C                 INFORMATION TECHNOLOGY LABORATORY
427C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
428C                 GAITHERSBURG, MD 20899-8980
429C                 PHONE--301-975-2899
430C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
431C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
432C     LANGUAGE--ANSI FORTRAN (1977)
433C     VERSION NUMBER--90/9
434C     ORIGINAL VERSION--SEPTEMBER 1990.
435C     UPDATED         --APRIL     2001. 1) ARGUMENT LIST TO DPCAA2
436C                                       2) SAVE RESULTS FROM DPCAA2
437C                                          AS INTERNAL PARAMETERS
438C     UPDATED         --MAY       2011. USE DPPARS
439C     UPDATED         --MAY       2011. SUPPORT FOR "MULTIPLE" AND
440C                                       "REPLICATION" OPTIONS
441C     UPDATED         --JUNE      2019. TWEAK TO SCRATCH ARRAYS
442C
443C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
444C
445      CHARACTER*4 ICASAN
446      CHARACTER*4 ICAPSW
447      CHARACTER*4 IFORSW
448      CHARACTER*4 IBUGA2
449      CHARACTER*4 IBUGA3
450      CHARACTER*4 IBUGQ
451      CHARACTER*4 ISUBRO
452      CHARACTER*4 IFOUND
453      CHARACTER*4 IERROR
454C
455      CHARACTER*4 IHWUSE
456      CHARACTER*4 MESSAG
457      CHARACTER*4 IH
458      CHARACTER*4 IH2
459      CHARACTER*4 ISUBN1
460      CHARACTER*4 ISUBN2
461      CHARACTER*4 ISTEPN
462      CHARACTER*4 IREPL
463      CHARACTER*4 IMULT
464      CHARACTER*4 ICTMP1
465      CHARACTER*4 ICTMP2
466      CHARACTER*4 ICTMP3
467      CHARACTER*4 ICTMP4
468      CHARACTER*4 ICASE
469C
470C
471      CHARACTER*4 IFLAGU
472      LOGICAL IFRST
473      LOGICAL ILAST
474C
475      CHARACTER*40 INAME
476      PARAMETER (MAXSPN=30)
477      CHARACTER*4 IVARN1(MAXSPN)
478      CHARACTER*4 IVARN2(MAXSPN)
479      CHARACTER*4 IVARTY(MAXSPN)
480      CHARACTER*4 IVARID(1)
481      CHARACTER*4 IVARI2(1)
482      REAL PVAR(MAXSPN)
483      REAL PID(MAXSPN)
484      INTEGER ILIS(MAXSPN)
485      INTEGER NRIGHT(MAXSPN)
486      INTEGER ICOLR(MAXSPN)
487C
488C---------------------------------------------------------------------
489C
490      INCLUDE 'DPCOPA.INC'
491C
492      DIMENSION XTEMP1(*)
493      DIMENSION W(MAXOBV)
494C
495      DIMENSION XDESGN(MAXOBV,7)
496      DIMENSION XIDTEM(MAXOBV)
497      DIMENSION XIDTE2(MAXOBV)
498      DIMENSION XIDTE3(MAXOBV)
499      DIMENSION XIDTE4(MAXOBV)
500      DIMENSION XIDTE5(MAXOBV)
501      DIMENSION XIDTE6(MAXOBV)
502C
503      DIMENSION TEMP1(MAXOBV)
504      DIMENSION TEMP2(MAXOBV)
505C
506      INCLUDE 'DPCOZZ.INC'
507C
508      EQUIVALENCE (GARBAG(IGARB1),TEMP1(1))
509      EQUIVALENCE (GARBAG(IGARB2),XIDTEM(1))
510      EQUIVALENCE (GARBAG(IGARB3),XIDTE2(1))
511      EQUIVALENCE (GARBAG(IGARB4),XIDTE3(1))
512      EQUIVALENCE (GARBAG(IGARB5),XIDTE4(1))
513      EQUIVALENCE (GARBAG(IGARB6),XIDTE5(1))
514      EQUIVALENCE (GARBAG(IGARB7),XIDTE6(1))
515      EQUIVALENCE (GARBAG(IGARB8),TEMP2(1))
516      EQUIVALENCE (GARBAG(IGARB9),W(1))
517      EQUIVALENCE (GARBAG(IGAR10),XDESGN(1,1))
518C
519C-----COMMON----------------------------------------------------------
520C
521      INCLUDE 'DPCOHK.INC'
522      INCLUDE 'DPCODA.INC'
523      INCLUDE 'DPCOSU.INC'
524      INCLUDE 'DPCOST.INC'
525C
526C-----COMMON VARIABLES (GENERAL)--------------------------------------
527C
528      INCLUDE 'DPCOP2.INC'
529C
530C-----START POINT-----------------------------------------------------
531C
532      IERROR='NO'
533      IFOUND='NO'
534      ICASAN='CAAN'
535      IREPL='OFF'
536      IMULT='OFF'
537      ISUBN1='DPCA'
538      ISUBN2='AN  '
539C
540      MAXCP1=MAXCOL+1
541      MAXCP2=MAXCOL+2
542      MAXCP3=MAXCOL+3
543      MAXCP4=MAXCOL+4
544      MAXCP5=MAXCOL+5
545      MAXCP6=MAXCOL+6
546C
547C               ***********************************************
548C               **  TREAT THE CAPABILITY ANALYSIS    CASE    **
549C               ***********************************************
550C
551      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CAAN')THEN
552        WRITE(ICOUT,999)
553  999   FORMAT(1X)
554        CALL DPWRST('XXX','BUG ')
555        WRITE(ICOUT,51)
556   51   FORMAT('***** AT THE BEGINNING OF DPCAAN--')
557        CALL DPWRST('XXX','BUG ')
558        WRITE(ICOUT,53)IBUGA2,IBUGA3,IBUGQ,ISUBRO,MAXNXT
559   53   FORMAT('IBUGA2,IBUGA3,IBUGQ,ISUBRO,MAXNXT = ',4(A4,2X),I8)
560        CALL DPWRST('XXX','BUG ')
561      ENDIF
562C
563C               ********************************************************
564C               **  STEP 1--                                          **
565C               **  EXTRACT THE COMMAND                               **
566C               **  LOOK FOR ONE OF THE FOLLOWING COMMANDS:           **
567C               **    1) CAPABILITY ANALYSIS Y                        **
568C               **    2) MULTIPLE CAPABILITY ANALYSIS  Y1 ... YK      **
569C               **    3) REPLICATED CAPABILITY ANALYSIS  Y X1 ... XK  **
570C               ********************************************************
571C
572      ISTEPN='1'
573      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CAAN')
574     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
575C
576      ILASTC=9999
577      ILASTZ=9999
578      ICASAN='CAAN'
579C
580      DO100I=0,NUMARG-1
581C
582        IF(I.EQ.0)THEN
583          ICTMP1=ICOM
584        ELSE
585          ICTMP1=IHARG(I)
586        ENDIF
587        ICTMP2=IHARG(I+1)
588        ICTMP3=IHARG(I+2)
589        ICTMP4=IHARG(I+3)
590C
591        IF(ICTMP1.EQ.'=')THEN
592          IFOUND='NO'
593          GOTO9000
594        ELSEIF(ICTMP1.EQ.'CAPA' .AND. ICTMP2.EQ.'ANAL')THEN
595          IFOUND='YES'
596          ICASAN='CAAN'
597          ILASTC=I+1
598          ILASTZ=I+1
599        ELSEIF(ICTMP1.EQ.'CAPA' .OR. ICTMP1.EQ.'CP' .OR.
600     1         ICTMP1.EQ.'CPK')THEN
601          IFOUND='YES'
602          ICASAN='CAAN'
603          ILASTC=I
604          ILASTZ=I
605        ELSEIF(ICTMP1.EQ.'REPL')THEN
606          IREPL='ON'
607          ILASTC=MIN(ILASTC,I)
608          ILASTZ=MAX(ILASTZ,I)
609        ELSEIF(ICTMP1.EQ.'MULT')THEN
610          IMULT='ON'
611          ILASTC=MIN(ILASTC,I)
612          ILASTZ=MAX(ILASTZ,I)
613        ENDIF
614  100 CONTINUE
615C
616      IF(IFOUND.EQ.'NO')GOTO9000
617C
618      ISHIFT=ILASTZ
619      CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
620     1            IBUGA2,IERROR)
621C
622      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CAAN')THEN
623        WRITE(ICOUT,91)ICASAN,IMULT,IREPL,ISHIFT
624   91   FORMAT('DPCAAN: ICASAN,IMULT,IREPL,ISHIFT = ',3(A4,2X),I5)
625        CALL DPWRST('XXX','BUG ')
626      ENDIF
627C
628      IF(IMULT.EQ.'ON')THEN
629        IF(IREPL.EQ.'ON')THEN
630          WRITE(ICOUT,999)
631          CALL DPWRST('XXX','BUG ')
632          WRITE(ICOUT,101)
633  101     FORMAT('***** ERROR IN CAPABILITY ANALYSIS--')
634          CALL DPWRST('XXX','BUG ')
635          WRITE(ICOUT,103)
636  103     FORMAT('      YOU CANNOT SPECIFY BOTH "MULTIPLE" AND ',
637     1           '"REPLICATION"')
638          CALL DPWRST('XXX','BUG ')
639          WRITE(ICOUT,104)
640  104     FORMAT('      FOR THE CAPABILITY ANALYSIS COMMAND.')
641          CALL DPWRST('XXX','BUG ')
642          IERROR='YES'
643          GOTO9000
644        ENDIF
645      ENDIF
646C
647C               *********************************
648C               **  STEP 4--                   **
649C               **  EXTRACT THE VARIABLE LIST  **
650C               *********************************
651C
652      ISTEPN='4'
653      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CAAN')
654     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
655C
656      INAME='CAPABILITY ANALYSIS'
657      MINNA=1
658      MAXNA=100
659      MINN2=2
660      IFLAGE=0
661      IFLAGM=1
662      IF(IREPL.EQ.'ON')THEN
663        IFLAGM=0
664        IFLAGE=1
665      ENDIF
666      IFLAGP=0
667      JMIN=1
668      JMAX=NUMARG
669      MINNVA=1
670      MAXNVA=MAXSPN
671C
672      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
673     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
674     1            JMIN,JMAX,
675     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
676     1            IVARN1,IVARN2,IVARTY,PVAR,
677     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
678     1            MINNVA,MAXNVA,
679     1            IFLAGM,IFLAGP,
680     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
681      IF(IERROR.EQ.'YES')GOTO9000
682C
683      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CAAN')THEN
684        WRITE(ICOUT,999)
685        CALL DPWRST('XXX','BUG ')
686        WRITE(ICOUT,281)
687  281   FORMAT('***** AFTER CALL DPPARS--')
688        CALL DPWRST('XXX','BUG ')
689        WRITE(ICOUT,282)NQ,NUMVAR
690  282   FORMAT('NQ,NUMVAR = ',2I8)
691        CALL DPWRST('XXX','BUG ')
692        IF(NUMVAR.GT.0)THEN
693          DO285I=1,NUMVAR
694            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
695     1                      ICOLR(I)
696  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
697     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
698            CALL DPWRST('XXX','BUG ')
699  285     CONTINUE
700        ENDIF
701      ENDIF
702C
703C               ***********************************************
704C               **  STEP 5--                                 **
705C               **  DETERMINE:                               **
706C               **  1) NUMBER OF REPLICATION VARIABLES (0-6) **
707C               **  2) NUMBER OF RESPONSE    VARIABLES (>= 1)**
708C               ***********************************************
709C
710      ISTEPN='5'
711      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CAAN')
712     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
713C
714      NREPL=0
715      NRESP=0
716      IF(IREPL.EQ.'ON')THEN
717        NRESP=1
718        NREPL=NUMVAR-NRESP
719        IF(NREPL.LT.1 .OR. NREPL.GT.6)THEN
720          WRITE(ICOUT,999)
721          CALL DPWRST('XXX','BUG ')
722          WRITE(ICOUT,101)
723          CALL DPWRST('XXX','BUG ')
724          WRITE(ICOUT,511)
725  511     FORMAT('      FOR THE REPLICATION CASE, THE NUMBER OF ',
726     1           'REPLICATION VARIABLES')
727          CALL DPWRST('XXX','BUG ')
728          WRITE(ICOUT,512)
729  512     FORMAT('      MUST BE BETWEEN ONE AND SIX.')
730          CALL DPWRST('XXX','BUG ')
731          WRITE(ICOUT,513)NREPL
732  513     FORMAT('      THE NUMBER OF REPLICATION VARIABLES = ',I5)
733          CALL DPWRST('XXX','BUG ')
734          IERROR='YES'
735          GOTO9000
736        ENDIF
737      ELSE
738        NRESP=NUMVAR
739        IMULT='ON'
740      ENDIF
741C
742      DO519I=1,MAXOBV
743        W(I)=1.0
744  519 CONTINUE
745C
746      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CAAN')THEN
747        WRITE(ICOUT,521)NRESP,NREPL
748  521   FORMAT('NRESP,NREPL = ',2I5)
749        CALL DPWRST('XXX','BUG ')
750      ENDIF
751C
752C               *********************************************
753C               **  STEP 7--                               **
754C               **  DETERMINE IF THE ANALYST               **
755C               **  HAS SPECIFIED                          **
756C               **      LSL (LOWER SPEC LIMIT)             **
757C               **      USL (UPPER SPEC LIMIT)             **
758C               **      USLCOST (UPPER SPEC LIMIT COST)    **
759C               **      TARGET                             **
760C               *********************************************
761C
762      ISTEPN='7'
763      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CAAN')
764     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
765C
766      CCLSL=CPUMIN
767      IH='LSL '
768      IH2='    '
769      IHWUSE='P'
770      MESSAG='NO'
771      CALL CHECKN(IH,IH2,IHWUSE,
772     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
773     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
774      IF(IERROR.EQ.'NO')CCLSL=VALUE(ILOCP)
775C
776      CCUSL=CPUMIN
777      IH='USL '
778      IH2='    '
779      IHWUSE='P'
780      MESSAG='NO'
781      CALL CHECKN(IH,IH2,IHWUSE,
782     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
783     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
784      IF(IERROR.EQ.'NO')CCUSL=VALUE(ILOCP)
785C
786      CCTARG=CPUMIN
787      IH='TARG'
788      IH2='ET  '
789      IHWUSE='P'
790      MESSAG='NO'
791      CALL CHECKN(IH,IH2,IHWUSE,
792     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
793     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
794      IF(IERROR.EQ.'NO')CCTARG=VALUE(ILOCP)
795C
796      CCUSLC=CPUMIN
797      IH='USLC'
798      IH2='OST '
799      IHWUSE='P'
800      MESSAG='NO'
801      CALL CHECKN(IH,IH2,IHWUSE,
802     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
803     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
804      IF(IERROR.EQ.'NO')CCUSLC=VALUE(ILOCP)
805C
806C               *********************************************************
807C               **  STEP 6--                                           **
808C               **  GENERATE THE CAPABILITY ANALYSIS FOR VARIOUS CASES **
809C               *********************************************************
810C
811      ISTEPN='6'
812      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CAAN')
813     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
814C
815C               ******************************************
816C               **  STEP 8A--                           **
817C               **  CASE 1: NO REPLICATION VARIABLES    **
818C               ******************************************
819C
820      IF(NREPL.LT.1)THEN
821        ISTEPN='8A'
822        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CAAN')
823     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
824C
825C       LOOP THROUGH EACH OF THE RESPONSE VARIABLES
826C
827        NCURVE=0
828        DO810IRESP=1,NRESP
829          NCURVE=NCURVE+1
830C
831          IINDX=ICOLR(IRESP)
832          PID(1)=CPUMIN
833          IVARID(1)=IVARN1(IRESP)
834          IVARI2(1)=IVARN2(IRESP)
835C
836          IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CAAN')THEN
837            WRITE(ICOUT,999)
838            CALL DPWRST('XXX','BUG ')
839            WRITE(ICOUT,811)IRESP,NCURVE
840  811       FORMAT('IRESP,NCURVE = ',2I5)
841            CALL DPWRST('XXX','BUG ')
842          ENDIF
843C
844          ICOL=IRESP
845          NUMVA2=1
846          CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
847     1                INAME,IVARN1,IVARN2,IVARTY,
848     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
849     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
850     1                MAXCP4,MAXCP5,MAXCP6,
851     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
852     1                Y,XTEMP1,XTEMP1,NS1,NLOCA2,NLOCA3,ICASE,
853     1                IBUGA3,ISUBRO,IFOUND,IERROR)
854          IF(IERROR.EQ.'YES')GOTO9000
855C
856C         *****************************************************
857C         **  STEP 8B--                                      **
858C         *****************************************************
859C
860          IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CAAN')THEN
861            ISTEPN='8B'
862            CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
863            WRITE(ICOUT,999)
864            CALL DPWRST('XXX','BUG ')
865            WRITE(ICOUT,822)
866  822       FORMAT('***** FROM THE MIDDLE  OF DPCAAN--')
867            CALL DPWRST('XXX','BUG ')
868            WRITE(ICOUT,823)ICASAN,NUMVAR,NS1
869  823       FORMAT('ICASAN,NUMVAR,NQ = ',A4,2I8)
870            CALL DPWRST('XXX','BUG ')
871            IF(NS1.GE.1)THEN
872              DO825I=1,NS1
873                WRITE(ICOUT,826)I,Y(I)
874  826           FORMAT('I,Y(I) = ',I8,G15.7)
875                CALL DPWRST('XXX','BUG ')
876  825         CONTINUE
877            ENDIF
878          ENDIF
879C
880          CALL DPCAA2(Y,W,NS1,XTEMP1,MAXNXT,
881     1                CCLSL,CCUSL,CCTARG,CCUSLC,
882     1                YCP,YCPLL,YCPUL,YCPK,YCPKLL,YCPKUL,
883     1                YCPL,YCPLLL,YCPLUL,YCPU,YCPULL,YCPUUL,
884     1                YCNPK,YCPM,YCPMLL,YCPMUL,YCC,
885     1                YACTPD,YTHEPD,YACTL,YTHEL,YACTU,YTHEU,YEXPLO,
886     1                ICAPSW,ICAPTY,IFORSW,ICNPKD,
887     1                PID,IVARID,IVARI2,NREPL,
888     1                IBUGA3,ISUBRO,IERROR)
889C
890C               ***************************************
891C               **  STEP 8C--                        **
892C               **  UPDATE INTERNAL DATAPLOT TABLES  **
893C               ***************************************
894C
895          ISTEPN='8C'
896          IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CAAN')
897     1      CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
898C
899          IF(NRESP.GT.1)THEN
900            IFLAGU='FILE'
901          ELSE
902            IFLAGU='ON'
903          ENDIF
904          IFRST=.FALSE.
905          ILAST=.FALSE.
906          IF(IRESP.EQ.1)IFRST=.TRUE.
907          IF(IRESP.EQ.NRESP)ILAST=.TRUE.
908          CALL DPCAA5(CCLSL,CCUSL,CCTARG,CCUSLC,
909     1                YCP,YCPLL,YCPUL,YCPK,YCPKLL,YCPKUL,
910     1                YCPL,YCPLLL,YCPLUL,YCPU,YCPULL,YCPUUL,
911     1                YCNPK,YCPM,YCPMLL,YCPMUL,YCC,
912     1                YACTPD,YTHEPD,YACTL,YTHEL,YACTU,YTHEU,YEXPLO,
913     1                IFLAGU,IFRST,ILAST,
914     1                IBUGA2,IBUGA3,ISUBRO,IERROR)
915  810   CONTINUE
916C
917C               ****************************************************
918C               **  STEP 9A--                                     **
919C               **  CASE 3: ONE OR MORE REPLICATION VARIABLES.    **
920C               **          FOR THIS CASE, THE NUMBER OF RESPONSE **
921C               **          VARIABLES MUST BE EXACTLY 1.          **
922C               **          FOR THIS CASE, ALL VARIABLES MUST     **
923C               **          HAVE THE SAME LENGTH.                 **
924C               ****************************************************
925C
926      ELSEIF(NREPL.GE.1)THEN
927        ISTEPN='9A'
928        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CAAN')
929     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
930C
931        J=0
932        IMAX=NRIGHT(1)
933        IF(NQ.LT.NRIGHT(1))IMAX=NQ
934        DO910I=1,IMAX
935          IF(ISUB(I).EQ.0)GOTO910
936          J=J+1
937C
938C         RESPONSE VARIABLE IN Y
939C
940          ICOLC=1
941          IJ=MAXN*(ICOLR(ICOLC)-1)+I
942          IF(ICOLR(ICOLC).LE.MAXCOL)Y(J)=V(IJ)
943          IF(ICOLR(ICOLC).EQ.MAXCP1)Y(J)=PRED(I)
944          IF(ICOLR(ICOLC).EQ.MAXCP2)Y(J)=RES(I)
945          IF(ICOLR(ICOLC).EQ.MAXCP3)Y(J)=YPLOT(I)
946          IF(ICOLR(ICOLC).EQ.MAXCP4)Y(J)=XPLOT(I)
947          IF(ICOLR(ICOLC).EQ.MAXCP5)Y(J)=X2PLOT(I)
948          IF(ICOLR(ICOLC).EQ.MAXCP6)Y(J)=TAGPLO(I)
949C
950          IF(NREPL.GE.1)THEN
951            DO920IR=1,MIN(NREPL,6)
952              ICOLC=ICOLC+1
953              ICOLT=ICOLR(ICOLC)
954              IJ=MAXN*(ICOLT-1)+I
955              IF(ICOLT.LE.MAXCOL)XDESGN(J,IR)=V(IJ)
956              IF(ICOLT.EQ.MAXCP1)XDESGN(J,IR)=PRED(I)
957              IF(ICOLT.EQ.MAXCP2)XDESGN(J,IR)=RES(I)
958              IF(ICOLT.EQ.MAXCP3)XDESGN(J,IR)=YPLOT(I)
959              IF(ICOLT.EQ.MAXCP4)XDESGN(J,IR)=XPLOT(I)
960              IF(ICOLT.EQ.MAXCP5)XDESGN(J,IR)=X2PLOT(I)
961              IF(ICOLT.EQ.MAXCP6)XDESGN(J,IR)=TAGPLO(I)
962  920       CONTINUE
963          ENDIF
964C
965  910   CONTINUE
966        NLOCAL=J
967C
968C       *****************************************************
969C       **  STEP 9B--                                      **
970C       **  CALL DPSUM2 TO PERFORM SUMMARY.                **
971C       *****************************************************
972C
973C
974        IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CAAN')THEN
975          ISTEPN='9C'
976          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
977          WRITE(ICOUT,999)
978          CALL DPWRST('XXX','BUG ')
979          WRITE(ICOUT,941)
980  941     FORMAT('***** FROM THE MIDDLE  OF DPCAAN--')
981          CALL DPWRST('XXX','BUG ')
982          WRITE(ICOUT,942)ICASAN,NUMVAR,NLOCAL,NREPL
983  942     FORMAT('ICASAN,NUMVAR,NLOCAL,NREPL = ',
984     1           A4,3I8)
985          CALL DPWRST('XXX','BUG ')
986          IF(NLOCAL.GE.1)THEN
987            DO945I=1,NLOCAL
988              WRITE(ICOUT,946)I,Y(I),XDESGN(I,1),XDESGN(I,2)
989  946         FORMAT('I,Y(I),XDESGN(I,1),XDESGN(I,2) = ',
990     1               I8,4F12.5)
991              CALL DPWRST('XXX','BUG ')
992  945       CONTINUE
993          ENDIF
994        ENDIF
995C
996C       *****************************************************
997C       **  STEP 9C--                                      **
998C       **  FIND THE DISTINCT VALUES IN EACH OF THE        **
999C       **  REPLICATION VARIABLES.                         **
1000C       *****************************************************
1001C
1002        CALL DPPP5(XDESGN(1,1),XDESGN(1,2),XDESGN(1,3),
1003     1             XDESGN(1,4),XDESGN(1,5),XDESGN(1,6),
1004     1             NREPL,NLOCAL,MAXOBV,
1005     1             XIDTEM,XIDTE2,XIDTE3,XIDTE4,XIDTE5,XIDTE6,
1006     1             XTEMP1,TEMP2,
1007     1             NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,NUMSE6,
1008     1             IBUGA3,ISUBRO,IERROR)
1009C
1010C       *****************************************************
1011C       **  STEP 9D--                                      **
1012C       **  NOW LOOP THROUGH THE VARIOUS REPLICATIONS      **
1013C       *****************************************************
1014C
1015        NCURVE=0
1016        IADD=1
1017C
1018        IF(NREPL.EQ.1)THEN
1019          J=0
1020          NTOT=NUMSE1
1021          DO1110ISET1=1,NUMSE1
1022            K=0
1023            PID(IADD+1)=XIDTEM(ISET1)
1024            DO1130I=1,NLOCAL
1025              IF(XIDTEM(ISET1).EQ.XDESGN(I,1))THEN
1026                K=K+1
1027                TEMP1(K)=Y(I)
1028              ENDIF
1029 1130       CONTINUE
1030            NTEMP=K
1031            NCURVE=NCURVE+1
1032            IF(NTEMP.GT.0)THEN
1033              CALL DPCAA2(TEMP1,W,NTEMP,XTEMP1,MAXNXT,
1034     1                    CCLSL,CCUSL,CCTARG,CCUSLC,
1035     1                    YCP,YCPLL,YCPUL,YCPK,YCPKLL,YCPKUL,
1036     1                    YCPL,YCPLLL,YCPLUL,YCPU,YCPULL,YCPUUL,
1037     1                    YCNPK,YCPM,YCPMLL,YCPMUL,YCC,
1038     1                    YACTPD,YTHEPD,YACTL,YTHEL,YACTU,YTHEU,YEXPLO,
1039     1                    ICAPSW,ICAPTY,IFORSW,ICNPKD,
1040     1                    PID,IVARN1,IVARN2,NREPL,
1041     1                    IBUGA3,ISUBRO,IERROR)
1042            ENDIF
1043            IFLAGU='FILE'
1044            IFRST=.FALSE.
1045            ILAST=.FALSE.
1046            IF(NCURVE.EQ.1)IFRST=.TRUE.
1047            IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
1048            CALL DPCAA5(CCLSL,CCUSL,CCTARG,CCUSLC,
1049     1                  YCP,YCPLL,YCPUL,YCPK,YCPKLL,YCPKUL,
1050     1                  YCPL,YCPLLL,YCPLUL,YCPU,YCPULL,YCPUUL,
1051     1                  YCNPK,YCPM,YCPMLL,YCPMUL,YCC,
1052     1                  YACTPD,YTHEPD,YACTL,YTHEL,YACTU,YTHEU,YEXPLO,
1053     1                  IFLAGU,IFRST,ILAST,
1054     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
1055 1110     CONTINUE
1056        ELSEIF(NREPL.EQ.2)THEN
1057          J=0
1058          NTOT=NUMSE1*NUMSE2
1059          DO1210ISET1=1,NUMSE1
1060          DO1220ISET2=1,NUMSE2
1061            K=0
1062            PID(1+IADD)=XIDTEM(ISET1)
1063            PID(2+IADD)=XIDTE2(ISET2)
1064            DO1290I=1,NLOCAL
1065              IF(
1066     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
1067     1           XIDTE2(ISET2).EQ.XDESGN(I,2)
1068     1          )THEN
1069                K=K+1
1070                TEMP1(K)=Y(I)
1071              ENDIF
1072 1290       CONTINUE
1073            NTEMP=K
1074            NCURVE=NCURVE+1
1075            IF(NTEMP.GT.0)THEN
1076              CALL DPCAA2(TEMP1,W,NTEMP,XTEMP1,MAXNXT,
1077     1                    CCLSL,CCUSL,CCTARG,CCUSLC,
1078     1                    YCP,YCPLL,YCPUL,YCPK,YCPKLL,YCPKUL,
1079     1                    YCPL,YCPLLL,YCPLUL,YCPU,YCPULL,YCPUUL,
1080     1                    YCNPK,YCPM,YCPMLL,YCPMUL,YCC,
1081     1                    YACTPD,YTHEPD,YACTL,YTHEL,YACTU,YTHEU,YEXPLO,
1082     1                    ICAPSW,ICAPTY,IFORSW,ICNPKD,
1083     1                    PID,IVARN1,IVARN2,NREPL,
1084     1                    IBUGA3,ISUBRO,IERROR)
1085            ENDIF
1086            IFLAGU='FILE'
1087            IFRST=.FALSE.
1088            ILAST=.FALSE.
1089            IF(NCURVE.EQ.1)IFRST=.TRUE.
1090            IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
1091            CALL DPCAA5(CCLSL,CCUSL,CCTARG,CCUSLC,
1092     1                  YCP,YCPLL,YCPUL,YCPK,YCPKLL,YCPKUL,
1093     1                  YCPL,YCPLLL,YCPLUL,YCPU,YCPULL,YCPUUL,
1094     1                  YCNPK,YCPM,YCPMLL,YCPMUL,YCC,
1095     1                  YACTPD,YTHEPD,YACTL,YTHEL,YACTU,YTHEU,YEXPLO,
1096     1                  IFLAGU,IFRST,ILAST,
1097     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
1098 1220     CONTINUE
1099 1210     CONTINUE
1100        ELSEIF(NREPL.EQ.3)THEN
1101          J=0
1102          NTOT=NUMSE1*NUMSE2*NUMSE3
1103          DO1310ISET1=1,NUMSE1
1104          DO1320ISET2=1,NUMSE2
1105          DO1330ISET3=1,NUMSE3
1106            K=0
1107            PID(1+IADD)=XIDTEM(ISET1)
1108            PID(2+IADD)=XIDTE2(ISET2)
1109            PID(3+IADD)=XIDTE3(ISET3)
1110            DO1390I=1,NLOCAL
1111              IF(
1112     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
1113     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
1114     1           XIDTE3(ISET3).EQ.XDESGN(I,3)
1115     1          )THEN
1116                K=K+1
1117                TEMP1(K)=Y(I)
1118              ENDIF
1119 1390       CONTINUE
1120            NTEMP=K
1121            NCURVE=NCURVE+1
1122            NPLOT1=NPLOTP
1123            IF(NTEMP.GT.0)THEN
1124              CALL DPCAA2(TEMP1,W,NTEMP,XTEMP1,MAXNXT,
1125     1                    CCLSL,CCUSL,CCTARG,CCUSLC,
1126     1                    YCP,YCPLL,YCPUL,YCPK,YCPKLL,YCPKUL,
1127     1                    YCPL,YCPLLL,YCPLUL,YCPU,YCPULL,YCPUUL,
1128     1                    YCNPK,YCPM,YCPMLL,YCPMUL,YCC,
1129     1                    YACTPD,YTHEPD,YACTL,YTHEL,YACTU,YTHEU,YEXPLO,
1130     1                    ICAPSW,ICAPTY,IFORSW,ICNPKD,
1131     1                    PID,IVARN1,IVARN2,NREPL,
1132     1                    IBUGA3,ISUBRO,IERROR)
1133            ENDIF
1134            IFLAGU='FILE'
1135            IFRST=.FALSE.
1136            ILAST=.FALSE.
1137            IF(NCURVE.EQ.1)IFRST=.TRUE.
1138            IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
1139            CALL DPCAA5(CCLSL,CCUSL,CCTARG,CCUSLC,
1140     1                  YCP,YCPLL,YCPUL,YCPK,YCPKLL,YCPKUL,
1141     1                  YCPL,YCPLLL,YCPLUL,YCPU,YCPULL,YCPUUL,
1142     1                  YCNPK,YCPM,YCPMLL,YCPMUL,YCC,
1143     1                  YACTPD,YTHEPD,YACTL,YTHEL,YACTU,YTHEU,YEXPLO,
1144     1                  IFLAGU,IFRST,ILAST,
1145     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
1146 1330     CONTINUE
1147 1320     CONTINUE
1148 1310     CONTINUE
1149        ELSEIF(NREPL.EQ.4)THEN
1150          J=0
1151          NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4
1152          DO1410ISET1=1,NUMSE1
1153          DO1420ISET2=1,NUMSE2
1154          DO1430ISET3=1,NUMSE3
1155          DO1440ISET4=1,NUMSE4
1156            K=0
1157            PID(1+IADD)=XIDTEM(ISET1)
1158            PID(2+IADD)=XIDTE2(ISET2)
1159            PID(3+IADD)=XIDTE3(ISET3)
1160            PID(4+IADD)=XIDTE4(ISET4)
1161            DO1490I=1,NLOCAL
1162              IF(
1163     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
1164     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
1165     1           XIDTE3(ISET3).EQ.XDESGN(I,3) .AND.
1166     1           XIDTE4(ISET4).EQ.XDESGN(I,4)
1167     1          )THEN
1168                K=K+1
1169                TEMP1(K)=Y(I)
1170              ENDIF
1171 1490       CONTINUE
1172            NTEMP=K
1173            NCURVE=NCURVE+1
1174            NPLOT1=NPLOTP
1175            IF(NTEMP.GT.0)THEN
1176              CALL DPCAA2(TEMP1,W,NTEMP,XTEMP1,MAXNXT,
1177     1                    CCLSL,CCUSL,CCTARG,CCUSLC,
1178     1                    YCP,YCPLL,YCPUL,YCPK,YCPKLL,YCPKUL,
1179     1                    YCPL,YCPLLL,YCPLUL,YCPU,YCPULL,YCPUUL,
1180     1                    YCNPK,YCPM,YCPMLL,YCPMUL,YCC,
1181     1                    YACTPD,YTHEPD,YACTL,YTHEL,YACTU,YTHEU,YEXPLO,
1182     1                    ICAPSW,ICAPTY,IFORSW,ICNPKD,
1183     1                    PID,IVARN1,IVARN2,NREPL,
1184     1                    IBUGA3,ISUBRO,IERROR)
1185            ENDIF
1186            IFLAGU='FILE'
1187            IFRST=.FALSE.
1188            ILAST=.FALSE.
1189            IF(NCURVE.EQ.1)IFRST=.TRUE.
1190            IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
1191            CALL DPCAA5(CCLSL,CCUSL,CCTARG,CCUSLC,
1192     1                  YCP,YCPLL,YCPUL,YCPK,YCPKLL,YCPKUL,
1193     1                  YCPL,YCPLLL,YCPLUL,YCPU,YCPULL,YCPUUL,
1194     1                  YCNPK,YCPM,YCPMLL,YCPMUL,YCC,
1195     1                  YACTPD,YTHEPD,YACTL,YTHEL,YACTU,YTHEU,YEXPLO,
1196     1                  IFLAGU,IFRST,ILAST,
1197     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
1198 1440     CONTINUE
1199 1430     CONTINUE
1200 1420     CONTINUE
1201 1410     CONTINUE
1202        ELSEIF(NREPL.EQ.5)THEN
1203          J=0
1204          NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5
1205          DO1510ISET1=1,NUMSE1
1206          DO1520ISET2=1,NUMSE2
1207          DO1530ISET3=1,NUMSE3
1208          DO1540ISET4=1,NUMSE4
1209          DO1550ISET5=1,NUMSE5
1210            K=0
1211            PID(1+IADD)=XIDTEM(ISET1)
1212            PID(2+IADD)=XIDTE2(ISET2)
1213            PID(3+IADD)=XIDTE3(ISET3)
1214            PID(4+IADD)=XIDTE4(ISET4)
1215            PID(5+IADD)=XIDTE5(ISET4)
1216            DO1590I=1,NLOCAL
1217              IF(
1218     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
1219     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
1220     1           XIDTE3(ISET3).EQ.XDESGN(I,3) .AND.
1221     1           XIDTE4(ISET4).EQ.XDESGN(I,4) .AND.
1222     1           XIDTE5(ISET5).EQ.XDESGN(I,5)
1223     1          )THEN
1224                K=K+1
1225                TEMP1(K)=Y(I)
1226              ENDIF
1227 1590       CONTINUE
1228            NTEMP=K
1229            NCURVE=NCURVE+1
1230            NPLOT1=NPLOTP
1231            IF(NTEMP.GT.0)THEN
1232              CALL DPCAA2(TEMP1,W,NTEMP,XTEMP1,MAXNXT,
1233     1                    CCLSL,CCUSL,CCTARG,CCUSLC,
1234     1                    YCP,YCPLL,YCPUL,YCPK,YCPKLL,YCPKUL,
1235     1                    YCPL,YCPLLL,YCPLUL,YCPU,YCPULL,YCPUUL,
1236     1                    YCNPK,YCPM,YCPMLL,YCPMUL,YCC,
1237     1                    YACTPD,YTHEPD,YACTL,YTHEL,YACTU,YTHEU,YEXPLO,
1238     1                    ICAPSW,ICAPTY,IFORSW,ICNPKD,
1239     1                    PID,IVARN1,IVARN2,NREPL,
1240     1                    IBUGA3,ISUBRO,IERROR)
1241            ENDIF
1242            IFLAGU='FILE'
1243            IFRST=.FALSE.
1244            ILAST=.FALSE.
1245            IF(NCURVE.EQ.1)IFRST=.TRUE.
1246            IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
1247            CALL DPCAA5(CCLSL,CCUSL,CCTARG,CCUSLC,
1248     1                  YCP,YCPLL,YCPUL,YCPK,YCPKLL,YCPKUL,
1249     1                  YCPL,YCPLLL,YCPLUL,YCPU,YCPULL,YCPUUL,
1250     1                  YCNPK,YCPM,YCPMLL,YCPMUL,YCC,
1251     1                  YACTPD,YTHEPD,YACTL,YTHEL,YACTU,YTHEU,YEXPLO,
1252     1                  IFLAGU,IFRST,ILAST,
1253     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
1254 1550     CONTINUE
1255 1540     CONTINUE
1256 1530     CONTINUE
1257 1520     CONTINUE
1258 1510     CONTINUE
1259        ELSEIF(NREPL.EQ.6)THEN
1260          J=0
1261          NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5*NUMSE6
1262          DO1610ISET1=1,NUMSE1
1263          DO1620ISET2=1,NUMSE2
1264          DO1630ISET3=1,NUMSE3
1265          DO1640ISET4=1,NUMSE4
1266          DO1650ISET5=1,NUMSE5
1267          DO1660ISET6=1,NUMSE6
1268            K=0
1269            PID(1+IADD)=XIDTEM(ISET1)
1270            PID(2+IADD)=XIDTE2(ISET2)
1271            PID(3+IADD)=XIDTE3(ISET3)
1272            PID(4+IADD)=XIDTE4(ISET4)
1273            PID(5+IADD)=XIDTE5(ISET4)
1274            PID(6+IADD)=XIDTE6(ISET4)
1275            DO1690I=1,NLOCAL
1276              IF(
1277     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
1278     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
1279     1           XIDTE3(ISET3).EQ.XDESGN(I,3) .AND.
1280     1           XIDTE4(ISET4).EQ.XDESGN(I,4) .AND.
1281     1           XIDTE5(ISET5).EQ.XDESGN(I,5) .AND.
1282     1           XIDTE6(ISET6).EQ.XDESGN(I,6)
1283     1          )THEN
1284                K=K+1
1285                TEMP1(K)=Y(I)
1286              ENDIF
1287 1690       CONTINUE
1288            NTEMP=K
1289            NCURVE=NCURVE+1
1290            NPLOT1=NPLOTP
1291            IF(NTEMP.GT.0)THEN
1292              CALL DPCAA2(TEMP1,W,NTEMP,XTEMP1,MAXNXT,
1293     1                    CCLSL,CCUSL,CCTARG,CCUSLC,
1294     1                    YCP,YCPLL,YCPUL,YCPK,YCPKLL,YCPKUL,
1295     1                    YCPL,YCPLLL,YCPLUL,YCPU,YCPULL,YCPUUL,
1296     1                    YCNPK,YCPM,YCPMLL,YCPMUL,YCC,
1297     1                    YACTPD,YTHEPD,YACTL,YTHEL,YACTU,YTHEU,YEXPLO,
1298     1                    ICAPSW,ICAPTY,IFORSW,ICNPKD,
1299     1                    PID,IVARN1,IVARN2,NREPL,
1300     1                    IBUGA3,ISUBRO,IERROR)
1301            ENDIF
1302            IFLAGU='FILE'
1303            IFRST=.FALSE.
1304            ILAST=.FALSE.
1305            IF(NCURVE.EQ.1)IFRST=.TRUE.
1306            IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
1307            CALL DPCAA5(CCLSL,CCUSL,CCTARG,CCUSLC,
1308     1                  YCP,YCPLL,YCPUL,YCPK,YCPKLL,YCPKUL,
1309     1                  YCPL,YCPLLL,YCPLUL,YCPU,YCPULL,YCPUUL,
1310     1                  YCNPK,YCPM,YCPMLL,YCPMUL,YCC,
1311     1                  YACTPD,YTHEPD,YACTL,YTHEL,YACTU,YTHEU,YEXPLO,
1312     1                  IFLAGU,IFRST,ILAST,
1313     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
1314 1660     CONTINUE
1315 1650     CONTINUE
1316 1640     CONTINUE
1317 1630     CONTINUE
1318 1620     CONTINUE
1319 1610     CONTINUE
1320        ENDIF
1321C
1322      ENDIF
1323C
1324C               *****************
1325C               **  STEP 90--  **
1326C               **  EXIT       **
1327C               *****************
1328C
1329 9000 CONTINUE
1330C
1331      IF(IERROR.EQ.'YES')THEN
1332        IF(IWIDTH.GE.1)THEN
1333          WRITE(ICOUT,9001)(IANS(I),I=1,MIN(100,IWIDTH))
1334 9001     FORMAT(100A1)
1335          CALL DPWRST('XXX','BUG ')
1336        ENDIF
1337      ENDIF
1338C
1339      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CAAN')THEN
1340        WRITE(ICOUT,999)
1341        CALL DPWRST('XXX','BUG ')
1342        WRITE(ICOUT,9011)
1343 9011   FORMAT('***** AT THE END       OF DPCAAN--')
1344        CALL DPWRST('XXX','BUG ')
1345        WRITE(ICOUT,9012)IFOUND,IERROR,ICASAN
1346 9012   FORMAT('IFOUND,IERROR,ICASAN = ',2(A4,2X),A4)
1347        CALL DPWRST('XXX','BUG ')
1348      ENDIF
1349C
1350      RETURN
1351      END
1352      SUBROUTINE DPCAA2(Y,W,N,XTEMP1,MAXNXT,
1353     1                  CCLSL,CCUSL,CCTARG,CCUSLC,
1354     1                  YCP,YCPLL,YCPUL,YCPK,YCPKLL,YCPKUL,
1355     1                  YCPL,YCPLLL,YCPLUL,YCPU,YCPULL,YCPUUL,
1356     1                  YCNPK,YCPM,YCPMLL,YCPMUL,YCC,
1357     1                  YACTPD,YTHEPD,YACTL,YTHEL,YACTU,YTHEU,YEXPLO,
1358     1                  ICAPSW,ICAPTY,IFORSW,ICNPKD,
1359     1                  PID,IVARID,IVARI2,NREPL,
1360     1                  IBUGA3,ISUBRO,IERROR)
1361C
1362C     PURPOSE--THIS ROUTINE GENERATES A CAPABILITY ANALYSIS
1363C              TABULATION THE DATA IN THE INPUT VECTOR Y.
1364C     NOTE--NORMALITY IS ASSUMED
1365C     INPUT  ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR
1366C                                OF EQUALLY-SPACED OBSERVATIONS
1367C                                TO BE SMOOTHED.
1368C                       N      = THE INTEGER NUMBER OF
1369C                                OBSERVATIONS IN THE VECTOR Y.
1370C     WRITTEN BY--JAMES J. FILLIBEN
1371C                 STATISTICAL ENGINEERING DIVISION
1372C                 INFORMATION TECHNOLOGY LABORATORY
1373C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
1374C                 GAITHERSBURG, MD 20899-8980
1375C                 PHONE--301-975-2899
1376C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
1377C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
1378C     LANGUAGE--ANSI FORTRAN (1977)
1379C     VERSION NUMBER--90/9
1380C     ORIGINAL VERSION--SEPTEMBER 1990.
1381C     UPDATED         --APRIL     2001.  EXPAND TABLE:
1382C                                        1) ADD CC, CPM, CPL, CPU,
1383C                                               CNPK
1384C                                        2) 95% CONFIDENCE INTERVAL
1385C                                           FOR CP, CPK, CPL, CPU, CPM
1386C                                        3) ADD COMPUTED STATS TO
1387C                                           CALL LIST SO THEY CAN BE
1388C                                           SAVED AS INTERNAL
1389C                                           PARAMETERS
1390C     UPDATED         --MAY       2011. USE DPDTA1 AND DPDTA5 TO PRINT
1391C                                       TABLES
1392C     UPDATED         --APRIL     2015. ADD "ICNPKD" TO CNPK CALL LIST
1393C     UPDATED         --APRIL     2015. ADDITIONAL CAPABILITY STATISTICS
1394C     UPDATED         --APRIL     2015. ADD CONFIDENCE LIMITS TABLES
1395C
1396C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
1397C
1398      CHARACTER*4 IVARID(*)
1399      CHARACTER*4 IVARI2(*)
1400C
1401      CHARACTER*4 ICAPSW
1402      CHARACTER*4 ICAPTY
1403      CHARACTER*4 IFORSW
1404      CHARACTER*4 ICNPKD
1405C
1406      CHARACTER*4 ISUBRO
1407      CHARACTER*4 IBUGA3
1408      CHARACTER*4 IERROR
1409C
1410      CHARACTER*4 IWRITE
1411      CHARACTER*4 IFLAG
1412      CHARACTER*4 ISUBN1
1413      CHARACTER*4 ISUBN2
1414      CHARACTER*4 ISTEPN
1415C
1416C---------------------------------------------------------------------
1417C
1418      DIMENSION Y(*)
1419      DIMENSION W(*)
1420      DIMENSION XTEMP1(*)
1421      DIMENSION PID(*)
1422C
1423      PARAMETER (NUMALP=5)
1424      PARAMETER (MAXROW=60)
1425      PARAMETER (NUMCLI=60)
1426      PARAMETER (MAXLIN=2)
1427      CHARACTER*60 ITITLE
1428      CHARACTER*60 ITITLZ
1429      CHARACTER*60 ITITL9
1430      CHARACTER*40 ITEXT(MAXROW)
1431      CHARACTER*4  ALIGN(NUMCLI)
1432      CHARACTER*4  VALIGN(NUMCLI)
1433      REAL         AVALUE(MAXROW)
1434      REAL         ALPHA(NUMALP)
1435      INTEGER      NCTEXT(MAXROW)
1436      INTEGER      IDIGIT(MAXROW)
1437      INTEGER      NTOT(MAXROW)
1438      INTEGER      IWHTML(NUMCLI)
1439      INTEGER      IWRTF(NUMCLI)
1440      CHARACTER*60 ITITL2(MAXLIN,NUMCLI)
1441      CHARACTER*15 IVALUE(MAXROW,NUMCLI)
1442      CHARACTER*4  ITYPCO(NUMCLI)
1443      INTEGER      NCTIT2(MAXLIN,NUMCLI)
1444      INTEGER      NCVALU(MAXROW,NUMCLI)
1445      REAL         AMAT(MAXROW,NUMCLI)
1446      LOGICAL IFRST
1447      LOGICAL ILAST
1448C
1449C---------------------------------------------------------------------
1450C
1451      INCLUDE 'DPCOP2.INC'
1452C
1453      DATA ALPHA /50.0, 80.0, 90.0, 95.0, 99.0/
1454C
1455C-----START POINT-----------------------------------------------------
1456C
1457      ISUBN1='DPCA'
1458      ISUBN2='A2  '
1459C
1460      IERROR='NO'
1461      IWRITE='OFF'
1462C
1463C
1464      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CAA2')THEN
1465        WRITE(ICOUT,999)
1466  999   FORMAT(1X)
1467        CALL DPWRST('XXX','BUG ')
1468        WRITE(ICOUT,51)
1469   51   FORMAT('**** AT THE BEGINNING OF DPCAA2--')
1470        CALL DPWRST('XXX','BUG ')
1471        WRITE(ICOUT,52)IBUGA3,ISUBRO,N,MAXNXT
1472   52   FORMAT('IBUGA3,ISUBRO,N,MAXNXT = ',2(A4,2X),2I8)
1473        CALL DPWRST('XXX','BUG ')
1474        WRITE(ICOUT,54)CCLSL,CCUSL,CCTARG,CCUSLC
1475   54   FORMAT('CCLSL,CCUSL,CCTARG,CCUSLC = ',4G15.7)
1476        CALL DPWRST('XXX','BUG ')
1477        DO56I=1,N
1478          WRITE(ICOUT,57)I,Y(I),W(I)
1479   57     FORMAT('I,Y(I),W(I) = ',I8,2G15.7)
1480          CALL DPWRST('XXX','BUG ')
1481   56   CONTINUE
1482      ENDIF
1483C
1484C               ********************************************
1485C               **  STEP 1--                              **
1486C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
1487C               ********************************************
1488C
1489      ISTEPN='1'
1490      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CAA2')
1491     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1492C
1493      IF(N.LT.2)THEN
1494        WRITE(ICOUT,999)
1495        CALL DPWRST('XXX','BUG ')
1496        WRITE(ICOUT,111)
1497  111   FORMAT('***** ERROR IN CAPABILITY ANALYSIS--')
1498        CALL DPWRST('XXX','BUG ')
1499        WRITE(ICOUT,112)
1500  112   FORMAT('      THE NUMBER OF OBSERVATIONS IN THE RESPONSE ',
1501     1         'VARIABLE IS LESS THAN TWO.')
1502        CALL DPWRST('XXX','BUG ')
1503        WRITE(ICOUT,113)N
1504  113   FORMAT('SAMPLE SIZE = ',I8)
1505        CALL DPWRST('XXX','BUG ')
1506        IERROR='YES'
1507        GOTO9000
1508      ENDIF
1509C
1510      HOLD=Y(1)
1511      DO135I=2,N
1512        IF(Y(I).NE.HOLD)GOTO139
1513  135 CONTINUE
1514      WRITE(ICOUT,999)
1515      CALL DPWRST('XXX','BUG ')
1516      WRITE(ICOUT,111)
1517      CALL DPWRST('XXX','BUG ')
1518      WRITE(ICOUT,131)HOLD
1519  131 FORMAT('      THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7)
1520      CALL DPWRST('XXX','BUG ')
1521      IERROR='YES'
1522      GOTO9000
1523  139 CONTINUE
1524C
1525C               **********************************************
1526C               **  STEP 3--                                **
1527C               **  COMPUTE VARIOUS CAPABILITY STATISTICS-- **
1528C               **     1) CP                                **
1529C               **     2) CPK                               **
1530C               **     3) PERCENT DEFECTIVE                 **
1531C               **     4) EXPECTED LOSS                     **
1532C               **********************************************
1533C
1534      ISTEPN='3'
1535      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CAA2')
1536     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1537C
1538      IFLAG='BOTH'
1539C
1540      CALL MEAN(Y,N,IWRITE,XMEAN,IBUGA3,IERROR)
1541      CALL SD(Y,N,IWRITE,XSD,IBUGA3,IERROR)
1542C
1543      CALL MEDIAN(Y,N,IWRITE,XTEMP1,MAXNXT,XMED,IBUGA3,IERROR)
1544      IF(ICNPKD.EQ.'PEAR')THEN
1545        P=99.865
1546        CALL PERCEN(P,Y,N,IWRITE,XTEMP1,MAXNXT,P995,IBUGA3,IERROR)
1547        P=0.135
1548        CALL PERCEN(P,Y,N,IWRITE,XTEMP1,MAXNXT,P005,IBUGA3,IERROR)
1549      ELSE
1550        P=99.5
1551        CALL PERCEN(P,Y,N,IWRITE,XTEMP1,MAXNXT,P995,IBUGA3,IERROR)
1552        P=0.5
1553        CALL PERCEN(P,Y,N,IWRITE,XTEMP1,MAXNXT,P005,IBUGA3,IERROR)
1554      ENDIF
1555C
1556      YCP=CPUMIN
1557      YCPLL=CPUMIN
1558      YCPUL=CPUMIN
1559      YCPK=CPUMIN
1560      YCPKLL=CPUMIN
1561      YCPKUL=CPUMIN
1562      YCNPK=CPUMIN
1563      YCPL=CPUMIN
1564      YCPLLL=CPUMIN
1565      YCPLUL=CPUMIN
1566      YCPU=CPUMIN
1567      YCPULL=CPUMIN
1568      YCPUUL=CPUMIN
1569      YCC=CPUMIN
1570      YCPM=CPUMIN
1571      YCPMLL=CPUMIN
1572      YCPMUL=CPUMIN
1573      YTHEPD=CPUMIN
1574      YTHEL=CPUMIN
1575      YTHEU=CPUMIN
1576      YACTPD=CPUMIN
1577      YACTL=CPUMIN
1578      YACTU=CPUMIN
1579      YEXPLO=CPUMIN
1580C
1581      IF(CCLSL.NE.CPUMIN.AND.CCUSL.NE.CPUMIN)THEN
1582        CALL CP(Y,N,CCLSL,CCUSL,IWRITE,YCP,YCPLL,YCPUL,
1583     1          IBUGA3,IERROR)
1584        CALL CPL(Y,N,CCLSL,CCUSL,IWRITE,YCPL,YCPLLL,YCPLUL,
1585     1           IBUGA3,IERROR)
1586        CALL CPU(Y,N,CCLSL,CCUSL,IWRITE,YCPU,YCPULL,YCPUUL,
1587     1           IBUGA3,IERROR)
1588        CALL CPK(Y,N,CCLSL,CCUSL,IWRITE,YCPK,YCPKLL,YCPKUL,
1589     1           IBUGA3,IERROR)
1590        CALL CPM(Y,N,CCLSL,CCUSL,CCTARG,IWRITE,YCPM,YCPMLL,YCPMUL,
1591     1           IBUGA3,IERROR)
1592        CALL CPMK(Y,N,CCLSL,CCUSL,CCTARG,IWRITE,YCPMK,YCPMLL,YCPMUL,
1593     1            IBUGA3,IERROR)
1594        CALL CC(Y,N,CCLSL,CCUSL,CCTARG,IWRITE,YCC,
1595     1          IBUGA3,IERROR)
1596        CALL CNP(Y,N,XTEMP1,MAXNXT,CCLSL,CCUSL,IWRITE,ICNPKD,
1597     1           YCNP,IBUGA3,IERROR)
1598        CALL CNPK(Y,N,XTEMP1,MAXNXT,CCLSL,CCUSL,IWRITE,ICNPKD,
1599     1            YCNPK,IBUGA3,IERROR)
1600        CALL CNPM(Y,N,XTEMP1,MAXNXT,CCLSL,CCUSL,CCTARG,IWRITE,ICNPKD,
1601     1            YCNPM,IBUGA3,IERROR)
1602        CALL CNPMK(Y,N,XTEMP1,MAXNXT,CCLSL,CCUSL,CCTARG,IWRITE,ICNPKD,
1603     1             YCNPMK,IBUGA3,IERROR)
1604        CALL PERDEF(Y,N,CCLSL,CCUSL,IWRITE,YACTPD,YTHEPD,
1605     1              YACTL,YTHEL,YACTU,YTHEU,
1606     1              IFLAG,IBUGA3,IERROR)
1607        CALL EXPLOS(Y,N,CCLSL,CCUSL,CCUSLC,IWRITE,YEXPLO,
1608     1              IBUGA3,IERROR)
1609      ENDIF
1610C
1611C               ****************************
1612C               **  STEP 7--              **
1613C               **  WRITE EVERYTHING OUT  **
1614C               ****************************
1615C
1616      ISTEPN='7'
1617      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CAA2')
1618     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1619C
1620      IF(IPRINT.EQ.'OFF')GOTO9000
1621C
1622      NUMDIG=7
1623      IF(IFORSW.EQ.'1')NUMDIG=1
1624      IF(IFORSW.EQ.'2')NUMDIG=2
1625      IF(IFORSW.EQ.'3')NUMDIG=3
1626      IF(IFORSW.EQ.'4')NUMDIG=4
1627      IF(IFORSW.EQ.'5')NUMDIG=5
1628      IF(IFORSW.EQ.'6')NUMDIG=6
1629      IF(IFORSW.EQ.'7')NUMDIG=7
1630      IF(IFORSW.EQ.'8')NUMDIG=8
1631      IF(IFORSW.EQ.'9')NUMDIG=9
1632      IF(IFORSW.EQ.'0')NUMDIG=0
1633      IF(IFORSW.EQ.'E')NUMDIG=-2
1634      IF(IFORSW.EQ.'-2')NUMDIG=-2
1635      IF(IFORSW.EQ.'-3')NUMDIG=-3
1636      IF(IFORSW.EQ.'-4')NUMDIG=-4
1637      IF(IFORSW.EQ.'-5')NUMDIG=-5
1638      IF(IFORSW.EQ.'-6')NUMDIG=-6
1639      IF(IFORSW.EQ.'-7')NUMDIG=-7
1640      IF(IFORSW.EQ.'-8')NUMDIG=-8
1641      IF(IFORSW.EQ.'-9')NUMDIG=-9
1642C
1643      ITITLE='Capability Analysis'
1644      NCTITL=19
1645      ITITLZ=' '
1646      NCTITZ=0
1647C
1648      ICNT=1
1649      ITEXT(ICNT)=' '
1650      NCTEXT(ICNT)=0
1651      AVALUE(ICNT)=0.0
1652      IDIGIT(ICNT)=-1
1653C
1654      ICNT=ICNT+1
1655      ITEXT(ICNT)='Response Variable: '
1656      WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1)(1:4)
1657      WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1)(1:4)
1658      NCTEXT(ICNT)=27
1659      AVALUE(ICNT)=0.0
1660      IDIGIT(ICNT)=-1
1661C
1662      IF(NREPL.GT.0)THEN
1663        IADD=1
1664        DO2101I=1,NREPL
1665          ICNT=ICNT+1
1666          ITEMP=I+IADD
1667          ITEXT(ICNT)='Factor Variable  : '
1668          WRITE(ITEXT(ICNT)(17:17),'(I1)')I
1669          WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(ITEMP)(1:4)
1670          WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(ITEMP)(1:4)
1671          NCTEXT(ICNT)=27
1672          AVALUE(ICNT)=PID(ITEMP)
1673          IDIGIT(ICNT)=NUMDIG
1674 2101   CONTINUE
1675      ENDIF
1676C
1677      ICNT=ICNT+1
1678      ITEXT(ICNT)=' '
1679      NCTEXT(ICNT)=1
1680      AVALUE(ICNT)=0.0
1681      IDIGIT(ICNT)=-1
1682C
1683      ICNT=ICNT+1
1684      ITEXT(ICNT)=' '
1685      NCTEXT(ICNT)=1
1686      AVALUE(ICNT)=0.0
1687      IDIGIT(ICNT)=-1
1688      ICNT=ICNT+1
1689      ITEXT(ICNT)='Summary Statistics:'
1690      NCTEXT(ICNT)=19
1691      AVALUE(ICNT)=0.0
1692      IDIGIT(ICNT)=-1
1693      ICNT=ICNT+1
1694      ITEXT(ICNT)='Number of Observations:'
1695      NCTEXT(ICNT)=23
1696      AVALUE(ICNT)=REAL(N)
1697      IDIGIT(ICNT)=0
1698      ICNT=ICNT+1
1699      ITEXT(ICNT)='Mean:'
1700      NCTEXT(ICNT)=5
1701      AVALUE(ICNT)=XMEAN
1702      IDIGIT(ICNT)=NUMDIG
1703      ICNT=ICNT+1
1704      ITEXT(ICNT)='Standard Deviation:'
1705      NCTEXT(ICNT)=19
1706      AVALUE(ICNT)=XSD
1707      IDIGIT(ICNT)=NUMDIG
1708      ICNT=ICNT+1
1709      ITEXT(ICNT)='Median:'
1710      NCTEXT(ICNT)=7
1711      AVALUE(ICNT)=XMED
1712      IDIGIT(ICNT)=NUMDIG
1713      IF(ICNPKD.EQ.'PEAR')THEN
1714        ICNT=ICNT+1
1715        ITEXT(ICNT)='0.135 Percentile:'
1716        NCTEXT(ICNT)=17
1717        AVALUE(ICNT)=P005
1718        IDIGIT(ICNT)=NUMDIG
1719        ICNT=ICNT+1
1720        ITEXT(ICNT)='99.865 Percentile:'
1721        NCTEXT(ICNT)=18
1722        AVALUE(ICNT)=P995
1723        IDIGIT(ICNT)=NUMDIG
1724      ELSE
1725        ICNT=ICNT+1
1726        ITEXT(ICNT)='0.5 Percentile:'
1727        NCTEXT(ICNT)=15
1728        AVALUE(ICNT)=P005
1729        IDIGIT(ICNT)=NUMDIG
1730        ICNT=ICNT+1
1731        ITEXT(ICNT)='99.5 Percentile:'
1732        NCTEXT(ICNT)=16
1733        AVALUE(ICNT)=P995
1734        IDIGIT(ICNT)=NUMDIG
1735      ENDIF
1736C
1737      ICNT=ICNT+1
1738      ITEXT(ICNT)=' '
1739      NCTEXT(ICNT)=1
1740      AVALUE(ICNT)=0.0
1741      IDIGIT(ICNT)=-1
1742      ICNT=ICNT+1
1743      ITEXT(ICNT)='User Specified Parameters:'
1744      NCTEXT(ICNT)=26
1745      AVALUE(ICNT)=0.0
1746      IDIGIT(ICNT)=-1
1747      ICNT=ICNT+1
1748      ITEXT(ICNT)='Lower Specification Limit (LSL):'
1749      NCTEXT(ICNT)=32
1750      AVALUE(ICNT)=CCLSL
1751      IDIGIT(ICNT)=NUMDIG
1752      ICNT=ICNT+1
1753      ITEXT(ICNT)='Upper Specification Limit (USL):'
1754      NCTEXT(ICNT)=32
1755      AVALUE(ICNT)=CCUSL
1756      IDIGIT(ICNT)=NUMDIG
1757      ICNT=ICNT+1
1758      ITEXT(ICNT)='Target (Target):'
1759      NCTEXT(ICNT)=16
1760      AVALUE(ICNT)=CCTARG
1761      IDIGIT(ICNT)=NUMDIG
1762      ICNT=ICNT+1
1763      ITEXT(ICNT)='USL Cost (USLCOST):'
1764      NCTEXT(ICNT)=19
1765      AVALUE(ICNT)=CCUSLC
1766      IDIGIT(ICNT)=NUMDIG
1767      ICNT=ICNT+1
1768      ITEXT(ICNT)=' '
1769      NCTEXT(ICNT)=1
1770      AVALUE(ICNT)=0.0
1771      IDIGIT(ICNT)=-1
1772C
1773      ICNT=ICNT+1
1774      ITEXT(ICNT)='Normal-Based Capability Statistics:'
1775      NCTEXT(ICNT)=35
1776      AVALUE(ICNT)=0.0
1777      IDIGIT(ICNT)=-1
1778      ICNT=ICNT+1
1779      ITEXT(ICNT)='CP:'
1780      NCTEXT(ICNT)=3
1781      AVALUE(ICNT)=YCP
1782      IDIGIT(ICNT)=NUMDIG
1783      ICNT=ICNT+1
1784      ITEXT(ICNT)='CPL:'
1785      NCTEXT(ICNT)=4
1786      AVALUE(ICNT)=YCPL
1787      IDIGIT(ICNT)=NUMDIG
1788      ICNT=ICNT+1
1789      ITEXT(ICNT)='CPU:'
1790      NCTEXT(ICNT)=4
1791      AVALUE(ICNT)=YCPU
1792      IDIGIT(ICNT)=NUMDIG
1793      ICNT=ICNT+1
1794      ITEXT(ICNT)='CPK:'
1795      NCTEXT(ICNT)=4
1796      AVALUE(ICNT)=YCPK
1797      IDIGIT(ICNT)=NUMDIG
1798      ICNT=ICNT+1
1799      ITEXT(ICNT)='CPM:'
1800      NCTEXT(ICNT)=4
1801      AVALUE(ICNT)=YCPM
1802      IDIGIT(ICNT)=NUMDIG
1803      ICNT=ICNT+1
1804      ITEXT(ICNT)='CPMK:'
1805      NCTEXT(ICNT)=5
1806      AVALUE(ICNT)=YCPMK
1807      IDIGIT(ICNT)=NUMDIG
1808      ICNT=ICNT+1
1809      ITEXT(ICNT)='CC:'
1810      NCTEXT(ICNT)=3
1811      AVALUE(ICNT)=YCC
1812      IDIGIT(ICNT)=NUMDIG
1813      ICNT=ICNT+1
1814      ITEXT(ICNT)=' '
1815      NCTEXT(ICNT)=1
1816      AVALUE(ICNT)=0.0
1817      IDIGIT(ICNT)=-1
1818      ICNT=ICNT+1
1819      ITEXT(ICNT)='Actual Percent Defective:'
1820      NCTEXT(ICNT)=25
1821      AVALUE(ICNT)=YACTPD
1822      IDIGIT(ICNT)=NUMDIG
1823      ICNT=ICNT+1
1824      ITEXT(ICNT)='Theoretical Percent Defective:'
1825      NCTEXT(ICNT)=30
1826      AVALUE(ICNT)=YTHEPD
1827      IDIGIT(ICNT)=NUMDIG
1828      ICNT=ICNT+1
1829      ITEXT(ICNT)='Actual (Below) Percent Defective:'
1830      NCTEXT(ICNT)=33
1831      AVALUE(ICNT)=YACTL
1832      IDIGIT(ICNT)=NUMDIG
1833      ICNT=ICNT+1
1834      ITEXT(ICNT)='Theoretical (Below) Percent Defective:'
1835      NCTEXT(ICNT)=38
1836      AVALUE(ICNT)=YTHEL
1837      IDIGIT(ICNT)=NUMDIG
1838      ICNT=ICNT+1
1839      ITEXT(ICNT)='Actual (Above) Percent Defective:'
1840      NCTEXT(ICNT)=33
1841      AVALUE(ICNT)=YACTU
1842      IDIGIT(ICNT)=NUMDIG
1843      ICNT=ICNT+1
1844      ITEXT(ICNT)='Theoretical (Above) Percent Defective:'
1845      NCTEXT(ICNT)=38
1846      AVALUE(ICNT)=YTHEU
1847      IDIGIT(ICNT)=NUMDIG
1848      ICNT=ICNT+1
1849      ITEXT(ICNT)='Expected Loss:'
1850      NCTEXT(ICNT)=14
1851      AVALUE(ICNT)=YEXPLO
1852      IDIGIT(ICNT)=NUMDIG
1853      ICNT=ICNT+1
1854      ITEXT(ICNT)=' '
1855      NCTEXT(ICNT)=1
1856      AVALUE(ICNT)=0.0
1857      IDIGIT(ICNT)=-1
1858C
1859      ICNT=ICNT+1
1860      ITEXT(ICNT)='Nonparametric Capability Statistics:'
1861      NCTEXT(ICNT)=36
1862      AVALUE(ICNT)=0.0
1863      IDIGIT(ICNT)=-1
1864      ICNT=ICNT+1
1865      ITEXT(ICNT)='CNP:'
1866      NCTEXT(ICNT)=4
1867      AVALUE(ICNT)=YCNP
1868      IDIGIT(ICNT)=NUMDIG
1869      ICNT=ICNT+1
1870      ITEXT(ICNT)='CNPK:'
1871      NCTEXT(ICNT)=5
1872      AVALUE(ICNT)=YCNPK
1873      IDIGIT(ICNT)=NUMDIG
1874      ICNT=ICNT+1
1875      ITEXT(ICNT)='CNPM:'
1876      NCTEXT(ICNT)=5
1877      AVALUE(ICNT)=YCNPM
1878      IDIGIT(ICNT)=NUMDIG
1879      ICNT=ICNT+1
1880      ITEXT(ICNT)='CNPMK:'
1881      NCTEXT(ICNT)=6
1882      AVALUE(ICNT)=YCNPMK
1883      IDIGIT(ICNT)=NUMDIG
1884C
1885      NUMROW=ICNT
1886      DO2110I=1,NUMROW
1887        NTOT(I)=15
1888 2110 CONTINUE
1889C
1890      IFRST=.TRUE.
1891      ILAST=.TRUE.
1892C
1893      ISTEPN='42A'
1894      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FRT2')
1895     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1896C
1897      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
1898     1            AVALUE,IDIGIT,
1899     1            NTOT,NUMROW,
1900     1            ICAPSW,ICAPTY,ILAST,IFRST,
1901     1            ISUBRO,IBUGA3,IERROR)
1902C
1903C     CONFIDENCE LIMITS TABLE FOR CP
1904C
1905      ITITLE=' '
1906      NCTITL=0
1907      ITITL9=' '
1908      NCTIT9=0
1909      NUMLIN=2
1910      NUMROW=NUMALP
1911      NUMCOL=4
1912C
1913      ITITL9='Confidence Limits for Cp Statistic'
1914      NCTIT9=34
1915C
1916      ITITL2(1,1)='Confidence'
1917      NCTIT2(1,1)=10
1918      ITITL2(2,1)='Value (%)'
1919      NCTIT2(2,1)=9
1920      ITITL2(1,2)='Value'
1921      NCTIT2(1,2)=5
1922      ITITL2(2,2)='of Cp'
1923      NCTIT2(2,2)=5
1924      ITITL2(1,3)='Lower'
1925      NCTIT2(1,3)=5
1926      ITITL2(2,3)='Limit'
1927      NCTIT2(2,3)=5
1928      ITITL2(1,4)='Lower'
1929      NCTIT2(1,4)=5
1930      ITITL2(2,4)='Limit'
1931      NCTIT2(2,4)=5
1932C
1933      NMAX=0
1934      DO4221I=1,NUMCOL
1935        VALIGN(I)='b'
1936        ALIGN(I)='r'
1937        NTOT(I)=15
1938        IDIGIT(I)=NUMDIG
1939        ITYPCO(I)='NUME'
1940        IWHTML(I)=150
1941        IF(I.EQ.1)THEN
1942          NTOT(I)=12
1943          IDIGIT(I)=3
1944          IWHTML(1)=75
1945        ENDIF
1946        NMAX=NMAX+NTOT(I)
1947 4221 CONTINUE
1948C
1949      AN=REAL(N)
1950      NV=N-1
1951      AV=REAL(NV)
1952C
1953      DO4223I=1,NUMROW
1954        DO4225J=1,NUMCOL
1955          NCVALU(I,J)=0
1956          IVALUE(I,J)=' '
1957          AMAT(I,J)=0.0
1958 4225   CONTINUE
1959C
1960        PTEMP=ALPHA(I)/100.0
1961        PTEMPL=(1.0 - PTEMP)/2.0
1962        PTEMPU=1.0 - PTEMPL
1963        CALL CHSPPF(PTEMPL,NV,PPFL)
1964        ALOWER=0.0
1965        IF((PPFL/AV).GT.0.0)ALOWER=YCP*SQRT(PPFL/AV)
1966        CALL CHSPPF(PTEMPU,NV,PPFU)
1967        AUPPER=0.0
1968        IF((PPFU/AV).GT.0.0)AUPPER=YCP*SQRT(PPFU/AV)
1969        AMAT(I,1)=ALPHA(I)
1970        AMAT(I,2)=YCP
1971        AMAT(I,3)=ALOWER
1972        AMAT(I,4)=AUPPER
1973 4223 CONTINUE
1974C
1975      IWRTF(1)=800
1976      IWRTF(2)=IWRTF(1)+2000
1977      IWRTF(3)=IWRTF(2)+2000
1978      IWRTF(4)=IWRTF(2)+2000
1979      IFRST=.TRUE.
1980      ILAST=.TRUE.
1981C
1982      ISTEPN='5C'
1983      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CAA2')
1984     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1985C
1986      CALL DPDTA4(ITITL9,NCTIT9,
1987     1            ITITLE,NCTITL,ITITL2,NCTIT2,
1988     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
1989     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW,
1990     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
1991     1            ICAPSW,ICAPTY,IFRST,ILAST,
1992     1            ISUBRO,IBUGA3,IERROR)
1993C
1994C     CONFIDENCE LIMITS TABLE FOR CPL
1995C
1996      ITITL9='Confidence Limits for Cpl Statistic'
1997      NCTIT9=35
1998      ITITL2(2,2)='of Cpl'
1999      NCTIT2(2,2)=6
2000C
2001      DO4323I=1,NUMROW
2002        DO4325J=1,NUMCOL
2003          NCVALU(I,J)=0
2004          IVALUE(I,J)=' '
2005          AMAT(I,J)=0.0
2006 4325   CONTINUE
2007C
2008        PTEMP=ALPHA(I)/100.0
2009        PTEMPL=(1.0 - PTEMP)/2.0
2010        PTEMPU=1.0 - PTEMPL
2011        CALL NORPPF(PTEMPU,PPFU)
2012        ALOWER=0.0
2013        AUPPER=0.0
2014        IF(N.GT.1)THEN
2015          ALOWER=YCPL - PPFU*SQRT((1.0/(9.0*AN)) + YCPL/(2.0*(AN-1.0)))
2016          AUPPER=YCPL + PPFU*SQRT((1.0/(9.0*AN)) + YCPL/(2.0*(AN-1.0)))
2017        ENDIF
2018        AMAT(I,1)=ALPHA(I)
2019        AMAT(I,2)=YCPL
2020        AMAT(I,3)=ALOWER
2021        AMAT(I,4)=AUPPER
2022 4323 CONTINUE
2023C
2024      IWRTF(1)=800
2025      IWRTF(2)=IWRTF(1)+2000
2026      IWRTF(3)=IWRTF(2)+2000
2027      IWRTF(4)=IWRTF(2)+2000
2028      IFRST=.TRUE.
2029      ILAST=.TRUE.
2030C
2031      ISTEPN='5C'
2032      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CAA2')
2033     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2034C
2035      CALL DPDTA4(ITITL9,NCTIT9,
2036     1            ITITLE,NCTITL,ITITL2,NCTIT2,
2037     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
2038     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW,
2039     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
2040     1            ICAPSW,ICAPTY,IFRST,ILAST,
2041     1            ISUBRO,IBUGA3,IERROR)
2042C
2043C     CONFIDENCE LIMITS TABLE FOR CPU
2044C
2045      ITITL9='Confidence Limits for Cpu Statistic'
2046      NCTIT9=35
2047      ITITL2(2,2)='of Cpu'
2048      NCTIT2(2,2)=6
2049C
2050      DO4423I=1,NUMROW
2051        DO4425J=1,NUMCOL
2052          NCVALU(I,J)=0
2053          IVALUE(I,J)=' '
2054          AMAT(I,J)=0.0
2055 4425   CONTINUE
2056C
2057        PTEMP=ALPHA(I)/100.0
2058        PTEMPL=(1.0 - PTEMP)/2.0
2059        PTEMPU=1.0 - PTEMPL
2060        CALL NORPPF(PTEMPU,PPFU)
2061        ALOWER=0.0
2062        AUPPER=0.0
2063        IF(N.GT.1)THEN
2064          ALOWER=YCPU - PPFU*SQRT((1.0/(9.0*AN)) + YCPU/(2.0*(AN-1.0)))
2065          AUPPER=YCPU + PPFU*SQRT((1.0/(9.0*AN)) + YCPU/(2.0*(AN-1.0)))
2066        ENDIF
2067        AMAT(I,1)=ALPHA(I)
2068        AMAT(I,2)=YCPU
2069        AMAT(I,3)=ALOWER
2070        AMAT(I,4)=AUPPER
2071 4423 CONTINUE
2072C
2073      IWRTF(1)=800
2074      IWRTF(2)=IWRTF(1)+2000
2075      IWRTF(3)=IWRTF(2)+2000
2076      IWRTF(4)=IWRTF(2)+2000
2077      IFRST=.TRUE.
2078      ILAST=.TRUE.
2079C
2080      ISTEPN='5C'
2081      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CAA2')
2082     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2083C
2084      CALL DPDTA4(ITITL9,NCTIT9,
2085     1            ITITLE,NCTITL,ITITL2,NCTIT2,
2086     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
2087     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW,
2088     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
2089     1            ICAPSW,ICAPTY,IFRST,ILAST,
2090     1            ISUBRO,IBUGA3,IERROR)
2091C
2092C     CONFIDENCE LIMITS TABLE FOR CPM
2093C
2094      ITITL9='Confidence Limits for Cpm Statistic'
2095      NCTIT9=35
2096      ITITL2(2,2)='of Cpm'
2097      NCTIT2(2,2)=6
2098C
2099      DO4523I=1,NUMROW
2100        DO4525J=1,NUMCOL
2101          NCVALU(I,J)=0
2102          IVALUE(I,J)=' '
2103          AMAT(I,J)=0.0
2104 4525   CONTINUE
2105C
2106        PTEMP=ALPHA(I)/100.0
2107        PTEMPL=(1.0 - PTEMP)/2.0
2108        PTEMPU=1.0 - PTEMPL
2109        CALL CHSPPF(PTEMPL,NV,PPFL)
2110        ALOWER=0.0
2111        IF((PPFL/AV).GT.0.0)ALOWER=YCPM*SQRT(PPFL/AV)
2112        CALL CHSPPF(PTEMPU,NV,PPFU)
2113        AUPPER=0.0
2114        IF((PPFU/AV).GT.0.0)AUPPER=YCPM*SQRT(PPFU/AV)
2115        AMAT(I,1)=ALPHA(I)
2116        AMAT(I,2)=YCPM
2117        AMAT(I,3)=ALOWER
2118        AMAT(I,4)=AUPPER
2119 4523 CONTINUE
2120C
2121      IWRTF(1)=800
2122      IWRTF(2)=IWRTF(1)+2000
2123      IWRTF(3)=IWRTF(2)+2000
2124      IWRTF(4)=IWRTF(2)+2000
2125      IFRST=.TRUE.
2126      ILAST=.TRUE.
2127C
2128      ISTEPN='5C'
2129      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CAA2')
2130     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2131C
2132      CALL DPDTA4(ITITL9,NCTIT9,
2133     1            ITITLE,NCTITL,ITITL2,NCTIT2,
2134     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
2135     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW,
2136     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
2137     1            ICAPSW,ICAPTY,IFRST,ILAST,
2138     1            ISUBRO,IBUGA3,IERROR)
2139C
2140C     CONFIDENCE LIMITS TABLE FOR CPK
2141C
2142      ITITL9='Confidence Limits for Cpk Statistic'
2143      NCTIT9=35
2144      ITITL2(2,2)='of Cpk'
2145      NCTIT2(2,2)=6
2146C
2147      DO4623I=1,NUMROW
2148        DO4625J=1,NUMCOL
2149          NCVALU(I,J)=0
2150          IVALUE(I,J)=' '
2151          AMAT(I,J)=0.0
2152 4625   CONTINUE
2153C
2154        PTEMP=ALPHA(I)/100.0
2155        PTEMPL=(1.0 - PTEMP)/2.0
2156        PTEMPU=1.0 - PTEMPL
2157        ALOWER=0.0
2158        AUPPER=0.0
2159        CALL NORPPF(PTEMPU,PPFU)
2160        TERM1=1.0/(9.0*AN)
2161        TERM2=YCPK*YCPK/(2.0*(AN-1.0))
2162        ALOWER=YCPK - PPFU*SQRT(TERM1 + TERM2)
2163        AUPPER=YCPK + PPFU*SQRT(TERM1 + TERM2)
2164        AMAT(I,1)=ALPHA(I)
2165        AMAT(I,2)=YCPK
2166        AMAT(I,3)=ALOWER
2167        AMAT(I,4)=AUPPER
2168 4623 CONTINUE
2169C
2170      IWRTF(1)=800
2171      IWRTF(2)=IWRTF(1)+2000
2172      IWRTF(3)=IWRTF(2)+2000
2173      IWRTF(4)=IWRTF(2)+2000
2174      IFRST=.TRUE.
2175      ILAST=.TRUE.
2176C
2177      ISTEPN='5C'
2178      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CAA2')
2179     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2180C
2181      CALL DPDTA4(ITITL9,NCTIT9,
2182     1            ITITLE,NCTITL,ITITL2,NCTIT2,
2183     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
2184     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW,
2185     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
2186     1            ICAPSW,ICAPTY,IFRST,ILAST,
2187     1            ISUBRO,IBUGA3,IERROR)
2188C
2189C
2190C               *****************
2191C               **  STEP 90--  **
2192C               **  EXIT       **
2193C               *****************
2194C
2195 9000 CONTINUE
2196      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CAA2')THEN
2197        WRITE(ICOUT,999)
2198        CALL DPWRST('XXX','BUG ')
2199        WRITE(ICOUT,9011)
2200 9011   FORMAT('***** AT THE END       OF DPCAA2--')
2201        CALL DPWRST('XXX','BUG ')
2202        WRITE(ICOUT,9014)IFLAG
2203 9014   FORMAT('IFLAG = ',A4)
2204        CALL DPWRST('XXX','BUG ')
2205      ENDIF
2206C
2207      RETURN
2208      END
2209      SUBROUTINE DPCAA5(CCLSL,CCUSL,CCTARG,CCUSLC,
2210     1                  YCP,YCPLL,YCPUL,YCPK,YCPKLL,YCPKUL,
2211     1                  YCPL,YCPLLL,YCPLUL,YCPU,YCPULL,YCPUUL,
2212     1                  YCNPK,YCPM,YCPMLL,YCPMUL,YCC,
2213     1                  YACTPD,YTHEPD,YACTL,YTHEL,YACTU,YTHEU,YEXPLO,
2214     1                  IFLAGU,IFRST,ILAST,
2215     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
2216C
2217C     PURPOSE--UTILITY ROUTINE USED BY DPCAAN.  THIS ROUTINE
2218C              UPDATES VARIOUS PARAMETERS.
2219C     WRITTEN BY--ALAN HECKERT
2220C                 STATISTICAL ENGINEERING DIVISION
2221C                 INFORMATION TECHNOLOGY LABORAOTRY
2222C                 NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY
2223C                 GAITHERSBURG, MD 20899-8980
2224C                 PHONE--301-975-2899
2225C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
2226C           OF THE NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY.
2227C     LANGUAGE--ANSI FORTRAN (1977)
2228C     VERSION NUMBER--2011/5
2229C     ORIGINAL VERSION--MAY       2011.
2230C     UPDATED         --APRIL     2019. USER CAN SPECIFY NUMBER OF
2231C                                       DECIMAL POINTS FOR AUXILLARY
2232C                                       FILES
2233C
2234C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
2235C
2236      CHARACTER*4 IFLAGU
2237      CHARACTER*4 IBUGA2
2238      CHARACTER*4 IBUGA3
2239      CHARACTER*4 ISUBRO
2240      CHARACTER*4 IERROR
2241C
2242      LOGICAL IFRST
2243      LOGICAL ILAST
2244C
2245      CHARACTER*4 IH
2246      CHARACTER*4 IH2
2247      CHARACTER*4 ISUBN0
2248      CHARACTER*4 ISUBN1
2249      CHARACTER*4 ISUBN2
2250      CHARACTER*4 ISTEPN
2251      CHARACTER*4 IOP
2252      CHARACTER*20 IFORMT
2253C
2254C---------------------------------------------------------------------
2255C
2256      SAVE IOUNI1
2257C
2258C-----COMMON VARIABLES (GENERAL)--------------------------------------
2259C
2260      INCLUDE 'DPCOPA.INC'
2261      INCLUDE 'DPCOHK.INC'
2262      INCLUDE 'DPCOHO.INC'
2263      INCLUDE 'DPCOST.INC'
2264C
2265      INCLUDE 'DPCOP2.INC'
2266C
2267C-----START POINT-----------------------------------------------------
2268C
2269      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CAA5')THEN
2270        ISTEPN='1'
2271        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2272        WRITE(ICOUT,999)
2273  999   FORMAT(1X)
2274        CALL DPWRST('XXX','BUG ')
2275        WRITE(ICOUT,51)
2276   51   FORMAT('***** AT THE BEGINNING OF DPCAA5--')
2277        CALL DPWRST('XXX','BUG ')
2278        WRITE(ICOUT,53)CCLSL,CCUSL,CCTARG,CCUSLC
2279   53   FORMAT('CCLSL,CCUSL,CCTARG,CCUSLC = ',4G15.7)
2280        CALL DPWRST('XXX','BUG ')
2281      ENDIF
2282C
2283      IF(IFLAGU.EQ.'FILE')THEN
2284C
2285        IF(IFRST)THEN
2286          IOP='OPEN'
2287          IFLAG1=1
2288          IFLAG2=0
2289          IFLAG3=0
2290          IFLAG4=0
2291          IFLAG5=0
2292          CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
2293     1                IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
2294     1                IBUGA3,ISUBRO,IERROR)
2295          IF(IERROR.EQ.'YES')GOTO9000
2296C
2297          WRITE(IOUNI1,295)
2298  295     FORMAT(9X,'CPSTAT',11X,'CPLL',11X,'CPUL',
2299     1           8X,'CPKSTAT',10X,'CPKLL',10X,'CPKUL',
2300     1           8X,'CPLSTAT',10X,'CPLLL',10X,'CPLUL',
2301     1           8X,'CPUSTAT',10X,'CPULL',10X,'CPUUL',
2302     1           7X,'CNPKSTAT',
2303     1           8X,'CPMSTAT',10X,'CPMLL',10X,'CPMUL',
2304     1           7X,'ACTUALPD',7X,'ACTUALLL',7X,'ACTUALUL',
2305     1           9X,'CCSTAT',8X,'THEORPD',8X,'THEORLL',
2306     1           8X,'EXPLOSS')
2307        ENDIF
2308C
2309        IFORMT='(23E15.7)'
2310        IF(IAUXDP.NE.7)THEN
2311          IFORMT=' '
2312          IF(IAUXDP.LE.9)THEN
2313            IFORMT='(23Exx.x)'
2314            ITOT=IAUXDP+8
2315            WRITE(IFORMT(5:6),'(I2)')ITOT
2316            WRITE(IFORMT(8:8),'(I1)')IAUXDP
2317          ELSE
2318            IFORMT='(23Exx.xx)'
2319            ITOT=IAUXDP+8
2320            WRITE(IFORMT(5:6),'(I2)')ITOT
2321            WRITE(IFORMT(8:9),'(I2)')IAUXDP
2322          ENDIF
2323        ENDIF
2324C
2325        WRITE(IOUNI1,IFORMT)YCP,YCPLL,YCPUL,YCPK,YCPKLL,YCPKUL,
2326     1                   YCPL,YCPLLL,YCPLUL,YCPU,YCPULL,YCPUUL,
2327     1                   YCNPK,YCPM,YCPMLL,YCPMUL,YACTPD,YACTLL,YACTUL,
2328     1                   YCC,YTHERPD,YTHEL,YEXPLO
2329CC299   FORMAT(23E15.7)
2330      ELSEIF(IFLAGU.EQ.'ON')THEN
2331        IH='CPST'
2332        IH2='AT  '
2333        VALUE0=YCP
2334        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
2335     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
2336     1              IANS,IWIDTH,IBUGA3,IERROR)
2337C
2338        IH='CPLL'
2339        IH2='    '
2340        VALUE0=YCPLL
2341        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
2342     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
2343     1              IANS,IWIDTH,IBUGA3,IERROR)
2344C
2345        IH='CPUL'
2346        IH2='    '
2347        VALUE0=YCPUL
2348        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
2349     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
2350     1              IANS,IWIDTH,IBUGA3,IERROR)
2351C
2352        IH='CPKS'
2353        IH2='TAT '
2354        VALUE0=YCPK
2355        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
2356     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
2357     1              IANS,IWIDTH,IBUGA3,IERROR)
2358C
2359        IH='CPKL'
2360        IH2='L   '
2361        VALUE0=YCPKLL
2362        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
2363     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
2364     1              IANS,IWIDTH,IBUGA3,IERROR)
2365C
2366        IH='CPKU'
2367        IH2='L   '
2368        VALUE0=YCPKUL
2369        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
2370     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
2371     1              IANS,IWIDTH,IBUGA3,IERROR)
2372C
2373        IH='CPLS'
2374        IH2='TAT '
2375        VALUE0=YCPL
2376        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
2377     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
2378     1              IANS,IWIDTH,IBUGA3,IERROR)
2379C
2380        IH='CPLL'
2381        IH2='L   '
2382        VALUE0=YCPLLL
2383        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
2384     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
2385     1              IANS,IWIDTH,IBUGA3,IERROR)
2386C
2387        IH='CPLU'
2388        IH2='L   '
2389        VALUE0=YCPLUL
2390        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
2391     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
2392     1              IANS,IWIDTH,IBUGA3,IERROR)
2393C
2394        IH='CPUS'
2395        IH2='TAT '
2396        VALUE0=YCPU
2397        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
2398     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
2399     1              IANS,IWIDTH,IBUGA3,IERROR)
2400C
2401        IH='CPUL'
2402        IH2='L   '
2403        VALUE0=YCPULL
2404        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
2405     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
2406     1              IANS,IWIDTH,IBUGA3,IERROR)
2407C
2408        IH='CPUU'
2409        IH2='L   '
2410        VALUE0=YCPUUL
2411        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
2412     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
2413     1              IANS,IWIDTH,IBUGA3,IERROR)
2414C
2415        IH='CNPK'
2416        IH2='STAT'
2417        VALUE0=YCNPK
2418        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
2419     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
2420     1              IANS,IWIDTH,IBUGA3,IERROR)
2421C
2422        IH='CPMS'
2423        IH2='TAT '
2424        VALUE0=YCPM
2425        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
2426     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
2427     1              IANS,IWIDTH,IBUGA3,IERROR)
2428C
2429        IH='CPML'
2430        IH2='L   '
2431        VALUE0=YCPMLL
2432        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
2433     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
2434     1              IANS,IWIDTH,IBUGA3,IERROR)
2435C
2436        IH='CPMU'
2437        IH2='L   '
2438        VALUE0=YCPMUL
2439        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
2440     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
2441     1              IANS,IWIDTH,IBUGA3,IERROR)
2442C
2443        IH='CCST'
2444        IH2='AT  '
2445        VALUE0=YCC
2446        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
2447     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
2448     1              IANS,IWIDTH,IBUGA3,IERROR)
2449C
2450        IH='ACTU'
2451        IH2='ALPD'
2452        VALUE0=YACTPD
2453        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
2454     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
2455     1              IANS,IWIDTH,IBUGA3,IERROR)
2456C
2457        IH='THEO'
2458        IH2='RPD '
2459        VALUE0=YTHEPD
2460        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
2461     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
2462     1              IANS,IWIDTH,IBUGA3,IERROR)
2463C
2464        IH='ACTU'
2465        IH2='ALLL'
2466        VALUE0=YACTL
2467        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
2468     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
2469     1              IANS,IWIDTH,IBUGA3,IERROR)
2470C
2471        IH='THEO'
2472        IH2='RLL '
2473        VALUE0=YTHEL
2474        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
2475     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
2476     1              IANS,IWIDTH,IBUGA3,IERROR)
2477C
2478        IH='ACTU'
2479        IH2='ALUL'
2480        VALUE0=YACTU
2481        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
2482     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
2483     1              IANS,IWIDTH,IBUGA3,IERROR)
2484C
2485        IH='THEO'
2486        IH2='RUL '
2487        VALUE0=YTHEU
2488        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
2489     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
2490     1              IANS,IWIDTH,IBUGA3,IERROR)
2491C
2492        IH='EXPL'
2493        IH2='OSS '
2494        VALUE0=YEXPLO
2495        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
2496     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
2497     1              IANS,IWIDTH,IBUGA3,IERROR)
2498C
2499      ENDIF
2500C
2501      IF(IFLAGU.EQ.'FILE')THEN
2502        IF(ILAST)THEN
2503          IOP='CLOS'
2504          IFLAG1=1
2505          IFLAG2=0
2506          IFLAG3=0
2507          IFLAG4=0
2508          IFLAG5=0
2509          CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
2510     1                IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
2511     1                IBUGA3,ISUBRO,IERROR)
2512C
2513          IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CAA5')THEN
2514            ISTEPN='3A'
2515            CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2516            WRITE(ICOUT,999)
2517            CALL DPWRST('XXX','BUG ')
2518            WRITE(ICOUT,301)IERROR
2519  301       FORMAT('AFTER CALL DPCLFI, IERROR = ',A4)
2520            CALL DPWRST('XXX','BUG ')
2521          ENDIF
2522C
2523          IF(IERROR.EQ.'YES')GOTO9000
2524        ENDIF
2525      ENDIF
2526C
2527C               *****************
2528C               **  STEP 90--  **
2529C               **  EXIT       **
2530C               *****************
2531C
2532 9000 CONTINUE
2533C
2534      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CAA5')THEN
2535        WRITE(ICOUT,999)
2536        CALL DPWRST('XXX','BUG ')
2537        WRITE(ICOUT,9011)
2538 9011   FORMAT('***** AT THE END OF DPCAA5--')
2539        CALL DPWRST('XXX','BUG ')
2540      ENDIF
2541C
2542      RETURN
2543      END
2544      SUBROUTINE DPCAPA(IHARG,IARGT,ARG,NUMARG,
2545     1                  PXSTAR,PYSTAR,PXEND,PYEND,
2546     1                  ILINPA,ILINCO,PLINTH,
2547     1                  AREGBA,IREBLI,IREBCO,PREBTH,
2548     1                  IREFSW,IREFCO,
2549     1                  IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
2550     1                  PTEXHE,PTEXWI,PTEXVG,PTEXHG,
2551     1                  IGRASW,IDIASW,
2552     1                  PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
2553     1                  PDIAHE,PDIAWI,PDIAVG,PDIAHG,
2554     1                  NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
2555     1                  IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
2556     1                  IDNVOF,IDNHOF,IDFONT,UNITSW,PDSCAL,
2557     1                  IBUGD2,IFOUND,IERROR)
2558C
2559C     PURPOSE--DRAW ONE OR MORE CAPACITORS (DEPENDING ON HOW MANY NUMBERS ARE
2560C              PROVIDED).  THE COORDINATES ARE IN STANDARDIZED UNITS
2561C              OF 0 TO 100.
2562C     NOTE--THE INPUT COORDINATES DEFINE THE BACK CENTER AND THE FRONT CENTER
2563C           OF THE CAPACITOR.
2564C     NOTE-THE USUAL INPUT NUMBER OF COORDINATES IS 2
2565C          AND THEREFORE THE USUAL INPUT NUMBER OF NUMBERS IS 2*2 = 4.
2566C     NOTE--IF 2 NUMBERS ARE PROVIDED, THEN THE DRAWN CAPACITOR WILL GO FROM
2567C           THE LAST CURSOR POSITION TO THE (X,Y) POINT (EITHER ABSOLUTE OR
2568C           RELATIVE) AS DEFINED BY THE 2 NUMBERS.
2569C     NOTE--IF 4 NUMBERS ARE PROVIDED, THEN THE DRAWN CAPACITOR WILL GO FROM
2570C           THE ABSOLUTE (X,Y) POSITION AS DEFINED BY THE FIRST 2 NUMBERS TO
2571C           THE (X,Y) POINT (EITHER ABSOLUTE OR RELATIVE) AS DEFINED BY THE
2572C           THIRD AND FOURTH NUMBERS.
2573C     NOTE--IF 6 NUMBERS ARE PROVIDED, THEN THE DRAWN CAPACITOR WILL GO FROM
2574C           THE (X,Y) POSITION AS RESULTING FROM THE THIRD AND FOURTH NUMBERS
2575C           TO THE (X,Y) POINT (EITHER ABSOLUTE OR RELATIVE) AS DEFINED BY
2576C           THE FIFTH AND SIXTH NUMBERS.
2577C     NOTE--AND SO FORTH FOR 8, 10, 12, ... NUMBERS.
2578C     INPUT  ARGUMENTS--IHARG
2579C                     --IARGT
2580C                     --ARG
2581C                     --NUMARG
2582C                     --PXSTAR
2583C                     --PYSTAR
2584C     OUTPUT ARGUMENTS--PXEND
2585C                     --PYEND
2586C                     --IFOUND ('YES' OR 'NO' )
2587C                     --IERROR ('YES' OR 'NO' )
2588C     WRITTEN BY--JAMES J. FILLIBEN
2589C                 STATISTICAL ENGINEERING DIVISION
2590C                 INFORMATION TECHNOLOGY LABORATORY
2591C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
2592C                 GAITHERSBURG, MD 20899-8980
2593C                 PHONE--301-975-2899
2594C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
2595C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
2596C     LANGUAGE--ANSI FORTRAN (1977)
2597C     VERSION NUMBER--82/7
2598C     ORIGINAL VERSION--APRIL     1981.
2599C     UPDATED         --MARCH     1982.
2600C     UPDATED         --MAY       1982.
2601C     UPDATED         --NOVEMBER  1982.
2602C     UPDATED         --JANUARY   1989. CALL LIST FOR OFFSET VAR (ALAN)
2603C     UPDATED         --MARCH     1997. SUPPORT FOR DEVICE FONT (ALAN)
2604C     UPDATED         --JULY      1997. SUPPORT FOR "DATA" UNITS (ALAN)
2605C     UPDATED         --DECEMBER  2018. CHECK FOR DISCRETE, NULL, OR
2606C                                       NONE DEVICE
2607C     UPDATED         --DECEMBER  2018. SUPPORT FOR "DEVICE ... SCALE"
2608C                                       COMMAND
2609C
2610C-----NON-COMMON VARIABLES-----------------------------------------
2611C
2612      CHARACTER*4 IHARG
2613      CHARACTER*4 IARGT
2614C
2615      CHARACTER*4 ILINPA
2616      CHARACTER*4 ILINCO
2617C
2618      CHARACTER*4 IREBLI
2619      CHARACTER*4 IREBCO
2620      CHARACTER*4 IREFSW
2621      CHARACTER*4 IREFCO
2622      CHARACTER*4 IREPTY
2623      CHARACTER*4 IREPLI
2624      CHARACTER*4 IREPCO
2625C
2626      CHARACTER*4 IGRASW
2627      CHARACTER*4 IDIASW
2628C
2629      CHARACTER*4 IDMANU
2630      CHARACTER*4 IDMODE
2631      CHARACTER*4 IDMOD2
2632      CHARACTER*4 IDMOD3
2633      CHARACTER*4 IDPOWE
2634      CHARACTER*4 IDCONT
2635      CHARACTER*4 IDCOLO
2636CCCCC ADD FOLLOWING LINE MARCH 1997.
2637      CHARACTER*4 IDFONT
2638CCCCC ADD FOLLOWING LINE JULY 1997.
2639      CHARACTER*4 UNITSW
2640C
2641      CHARACTER*4 IFOUND
2642      CHARACTER*4 IBUGD2
2643      CHARACTER*4 IERROR
2644      CHARACTER*4 ISUBRO
2645C
2646      CHARACTER*4 IFIG
2647      CHARACTER*4 IBELSW
2648      CHARACTER*4 IERASW
2649      CHARACTER*4 IBACCO
2650      CHARACTER*4 ICOPSW
2651      CHARACTER*4 ITYPEO
2652C
2653      DIMENSION IHARG(*)
2654      DIMENSION IARGT(*)
2655      DIMENSION ARG(*)
2656C
2657      DIMENSION ILINPA(*)
2658      DIMENSION ILINCO(*)
2659      DIMENSION PLINTH(*)
2660C
2661      DIMENSION AREGBA(*)
2662      DIMENSION IREBLI(*)
2663      DIMENSION IREBCO(*)
2664      DIMENSION PREBTH(*)
2665      DIMENSION IREFSW(*)
2666      DIMENSION IREFCO(*)
2667      DIMENSION IREPTY(*)
2668      DIMENSION IREPLI(*)
2669      DIMENSION IREPCO(*)
2670      DIMENSION PREPTH(*)
2671      DIMENSION PREPSP(*)
2672      DIMENSION PDSCAL(*)
2673C
2674      DIMENSION IDMANU(*)
2675      DIMENSION IDMODE(*)
2676      DIMENSION IDMOD2(*)
2677      DIMENSION IDMOD3(*)
2678      DIMENSION IDPOWE(*)
2679      DIMENSION IDCONT(*)
2680      DIMENSION IDCOLO(*)
2681CCCCC ADD FOLLOWING LINE MARCH 1997.
2682      DIMENSION IDFONT(*)
2683      DIMENSION IDNVPP(*)
2684      DIMENSION IDNHPP(*)
2685      DIMENSION IDUNIT(*)
2686C
2687      DIMENSION IDNVOF(*)
2688      DIMENSION IDNHOF(*)
2689C
2690C-----COMMON----------------------------------------------------------
2691C
2692      INCLUDE 'DPCOGR.INC'
2693      INCLUDE 'DPCOBE.INC'
2694C
2695C-----COMMON VARIABLES (GENERAL)--------------------------------------
2696C
2697      INCLUDE 'DPCOP2.INC'
2698C
2699C-----START POINT-----------------------------------------------------
2700C
2701      IFOUND='NO'
2702      IERROR='NO'
2703      IERRG4=IERROR
2704CCCCC IBUGG4=IBUGD2
2705CCCCC ISUBG4=ISUBRO
2706C
2707      ILOCFN=0
2708      NUMNUM=0
2709C
2710      X1=0.0
2711      Y1=0.0
2712      X2=0.0
2713      Y2=0.0
2714C
2715      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CAPA')GOTO90
2716      WRITE(ICOUT,999)
2717  999 FORMAT(1X)
2718      CALL DPWRST('XXX','BUG ')
2719      WRITE(ICOUT,51)
2720   51 FORMAT('***** AT THE BEGINNING OF DPCAPA--')
2721      CALL DPWRST('XXX','BUG ')
2722      WRITE(ICOUT,53)NUMARG
2723   53 FORMAT('NUMARG = ',I8)
2724      CALL DPWRST('XXX','BUG ')
2725      DO55I=1,NUMARG
2726      WRITE(ICOUT,56)I,IHARG(I),IARGT(I),ARG(I)
2727   56 FORMAT('I,IHARG(I),IARGT(I),ARG(I) = ',I8,2X,A4,2X,A4,E15.7)
2728      CALL DPWRST('XXX','BUG ')
2729   55 CONTINUE
2730      WRITE(ICOUT,57)PXSTAR,PYSTAR
2731   57 FORMAT('PXSTAR,PYSTAR = ',2E15.7)
2732      CALL DPWRST('XXX','BUG ')
2733      WRITE(ICOUT,58)PXEND,PYEND
2734   58 FORMAT('PXEND,PYEND = ',2E15.7)
2735      CALL DPWRST('XXX','BUG ')
2736      WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1)
2737   61 FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',A4,2X,A4,E15.7)
2738      CALL DPWRST('XXX','BUG ')
2739      WRITE(ICOUT,62)AREGBA(1)
2740   62 FORMAT('AREGBA(1) = ',E15.7)
2741      CALL DPWRST('XXX','BUG ')
2742      WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1)
2743   63 FORMAT('IREBLI(1),IREBCO(1),PREBTH(1) = ',A4,2X,A4,E15.7)
2744      CALL DPWRST('XXX','BUG ')
2745      WRITE(ICOUT,64)IREFSW(1),IREFCO(1)
2746   64 FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4)
2747      CALL DPWRST('XXX','BUG ')
2748      WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1)
2749   65 FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ',
2750     1A4,2X,A4,2X,A4,2E15.7)
2751      CALL DPWRST('XXX','BUG ')
2752      WRITE(ICOUT,69)PTEXHE,PTEXWI
2753   69 FORMAT('PTEXHE,PTEXWI= ',2E15.7)
2754      CALL DPWRST('XXX','BUG ')
2755      WRITE(ICOUT,70)PTEXVG,PTEXHG
2756   70 FORMAT('PTEXVG,PTEXHG= ',2E15.6)
2757      CALL DPWRST('XXX','BUG ')
2758      WRITE(ICOUT,76)IGRASW,IDIASW
2759   76 FORMAT('IGRASW,IDIASW = ',A4,2X,A4)
2760      CALL DPWRST('XXX','BUG ')
2761      WRITE(ICOUT,77)PGRAXF,PGRAYF,PDIAXC,PDIAYC
2762   77 FORMAT('PGRAXF,PGRAYF,PDIAXC,PDIAYC = ',4E15.7)
2763      CALL DPWRST('XXX','BUG ')
2764      WRITE(ICOUT,78)PDIAHE,PDIAWI,PDIAVG,PDIAHG
2765   78 FORMAT('PDIAHE,PDIAWI,PDIAVG,PDIAHG = ',4E15.7)
2766      CALL DPWRST('XXX','BUG ')
2767      WRITE(ICOUT,80)NUMDEV
2768   80 FORMAT('NUMDEV= ',I8)
2769      CALL DPWRST('XXX','BUG ')
2770      DO81I=1,NUMDEV
2771      WRITE(ICOUT,82)IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I)
2772   82 FORMAT('IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I) = ',
2773     1A4,2X,A4,2X,A4,2X,A4)
2774      CALL DPWRST('XXX','BUG ')
2775      WRITE(ICOUT,83)IDPOWE(I),IDCONT(I),IDCOLO(I)
2776   83 FORMAT('IDPOWE(I),IDCONT(I),IDCOLO(I) = ',
2777     1A4,2X,A4,2X,A4)
2778      CALL DPWRST('XXX','BUG ')
2779      WRITE(ICOUT,84)IDNVPP(I),IDNHPP(I),IDUNIT(I)
2780   84 FORMAT('IDNVPP(I),IDNHPP(I),IDUNIT(I) = ',
2781     1I8,I8,I8)
2782      CALL DPWRST('XXX','BUG ')
2783   81 CONTINUE
2784      WRITE(ICOUT,87)IFOUND
2785   87 FORMAT('IFOUND= ',A4)
2786      CALL DPWRST('XXX','BUG ')
2787      WRITE(ICOUT,88)IBUGG4,ISUBG4,IERRG4
2788   88 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
2789      CALL DPWRST('XXX','BUG ')
2790      WRITE(ICOUT,89)IBUGD2,IERROR
2791   89 FORMAT('IBUGD2,IERROR= ',A4,2X,A4)
2792      CALL DPWRST('XXX','BUG ')
2793   90 CONTINUE
2794C
2795      IFIG='CAPA'
2796      NUMPT=2
2797      NUMPT2=2*NUMPT
2798C
2799C               ********************************
2800C               **  STEP 0--                  **
2801C               **  STEP THROUGH EACH DEVICE  **
2802C               ********************************
2803C
2804      IF(NUMDEV.LE.0)GOTO9000
2805      DO8000IDEVIC=1,NUMDEV
2806C
2807      IF(IDPOWE(IDEVIC).EQ.'OFF')GOTO8000
2808      IF(IDMANU(IDEVIC).EQ.'OFF')GOTO8000
2809      IF(IDMANU(IDEVIC).EQ.'NULL')GOTO8000
2810      IF(IDMANU(IDEVIC).EQ.'NONE')GOTO8000
2811      IF(IDMANU(IDEVIC).EQ.'DISC')GOTO8000
2812C
2813      IMANUF=IDMANU(IDEVIC)
2814      IMODEL=IDMODE(IDEVIC)
2815      IMODE2=IDMOD2(IDEVIC)
2816      IMODE3=IDMOD3(IDEVIC)
2817      IGCONT=IDCONT(IDEVIC)
2818      IGCOLO=IDCOLO(IDEVIC)
2819      IGFONT=IDFONT(IDEVIC)
2820      NUMVPP=IDNVPP(IDEVIC)
2821      NUMHPP=IDNHPP(IDEVIC)
2822      ANUMVP=NUMVPP
2823      ANUMHP=NUMHPP
2824      IOFFSV=IDNVOF(IDEVIC)
2825      IOFFSH=IDNHOF(IDEVIC)
2826      IGUNIT=IDUNIT(IDEVIC)
2827      PCHSCA=PDSCAL(IDEVIC)
2828C
2829C               ************************************
2830C               **  STEP 1--                      **
2831C               **  CARRY OUT OPENING OPERATIONS  **
2832C               **  ON THE GRAPHICS DEVICES       **
2833C               ************************************
2834C
2835      CALL DPOPDE
2836C
2837      IBELSW='OFF'
2838      NUMRIN=0
2839      IERASW='OFF'
2840      IBACCO='JUNK'
2841C
2842      CALL DPOPPL(IGRASW,
2843     1IBELSW,NUMRIN,IERASW,
2844     1IBACCO)
2845C
2846C               *****************************************
2847C               **  STEP 2--                           **
2848C               **  SEARCH FOR COMMAND SPECIFICATIONS  **
2849C               *****************************************
2850C
2851      IF(NUMARG.GE.2.AND.
2852     1IARGT(1).EQ.'NUMB'.AND.IARGT(2).EQ.'NUMB')
2853     1GOTO1111
2854      IF(NUMARG.GE.3.AND.IHARG(1).EQ.'ABSO'.AND.
2855     1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB')
2856     1GOTO1112
2857      IF(NUMARG.GE.3.AND.IHARG(1).EQ.'RELA'.AND.
2858     1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB')
2859     1GOTO1113
2860      GOTO1130
2861C
2862 1111 CONTINUE
2863      ITYPEO='ABSO'
2864      ILOCFN=1
2865      GOTO1119
2866C
2867 1112 CONTINUE
2868      ITYPEO='ABSO'
2869      ILOCFN=2
2870      GOTO1119
2871C
2872 1113 CONTINUE
2873      ITYPEO='RELA'
2874      ILOCFN=2
2875      GOTO1119
2876 1119 CONTINUE
2877C
2878      IF(ILOCFN.GT.NUMARG)GOTO1129
2879      DO1120I=ILOCFN,NUMARG
2880      IF(IARGT(I).EQ.'NUMB')GOTO1120
2881      GOTO1129
2882 1120 CONTINUE
2883      IFOUND='YES'
2884      GOTO1149
2885 1129 CONTINUE
2886      GOTO1130
2887C
2888 1130 CONTINUE
2889      IERRG4='YES'
2890      WRITE(ICOUT,1131)
2891 1131 FORMAT('***** ERROR IN DPCAPA--')
2892      CALL DPWRST('XXX','BUG ')
2893      WRITE(ICOUT,1132)
2894 1132 FORMAT('      ILLEGAL FORM FOR DRAW ',
2895     1'COMMAND.')
2896      CALL DPWRST('XXX','BUG ')
2897      WRITE(ICOUT,1134)
2898 1134 FORMAT('      TEST EXAMPLE TO DEMONSTRATE THE ',
2899     1'PROPER FORM--')
2900      CALL DPWRST('XXX','BUG ')
2901      WRITE(ICOUT,1135)
2902 1135 FORMAT('      SUPPOSE IT IS DESIRED TO DRAW A CAPACITOR ')
2903      CALL DPWRST('XXX','BUG ')
2904      WRITE(ICOUT,1136)
2905 1136 FORMAT('      WITH BACK CENTER AT 20 20 ')
2906      CALL DPWRST('XXX','BUG ')
2907      WRITE(ICOUT,1137)
2908 1137 FORMAT('      AND FRONT CENTER AT 40 60')
2909      CALL DPWRST('XXX','BUG ')
2910      WRITE(ICOUT,1141)
2911 1141 FORMAT('      THEN THE ALLOWABLE FORMS ARE--')
2912      CALL DPWRST('XXX','BUG ')
2913      WRITE(ICOUT,1142)
2914 1142 FORMAT('      CAPACITOR 20 20 40 60 ')
2915      CALL DPWRST('XXX','BUG ')
2916      WRITE(ICOUT,1143)
2917 1143 FORMAT('      CAPACITOR ABSOLUTE 20 20 40 60 ')
2918      CALL DPWRST('XXX','BUG ')
2919      GOTO9000
2920 1149 CONTINUE
2921C
2922C               ****************************
2923C               **  STEP 3--              **
2924C               **  DRAW OUT THE LINE(S)  **
2925C               ****************************
2926C
2927      NUMNUM=NUMARG-ILOCFN+1
2928      IF(NUMNUM.LT.NUMPT2)GOTO1151
2929      GOTO1152
2930C
2931 1151 CONTINUE
2932      J=ILOCFN-1
2933      X1=PXSTAR
2934      Y1=PYSTAR
2935      GOTO1159
2936C
2937 1152 CONTINUE
2938      J=ILOCFN
2939      IF(J.GT.NUMARG)GOTO1190
2940      X1=ARG(J)
2941CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997
2942      IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X1,X1,IBUGD2,ISUBRO,IERROR)
2943      J=J+1
2944      IF(J.GT.NUMARG)GOTO1190
2945      Y1=ARG(J)
2946CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997
2947      IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y1,Y1,IBUGD2,ISUBRO,IERROR)
2948      GOTO1159
2949 1159 CONTINUE
2950C
2951 1160 CONTINUE
2952      J=J+1
2953      IF(J.GT.NUMARG)GOTO1190
2954      X2=ARG(J)
2955CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997
2956      IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X2,X2,IBUGD2,ISUBRO,IERROR)
2957      IF(ITYPEO.EQ.'RELA')X2=X1+X2
2958      J=J+1
2959      IF(J.GT.NUMARG)GOTO1190
2960      Y2=ARG(J)
2961CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997
2962      IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y2,Y2,IBUGD2,ISUBRO,IERROR)
2963      IF(ITYPEO.EQ.'RELA')Y2=Y1+Y2
2964C
2965      CALL DPCAP2(X1,Y1,X2,Y2,
2966     1            IFIG,
2967     1            ILINPA,ILINCO,PLINTH,
2968     1            AREGBA,
2969     1            IREBLI,IREBCO,PREBTH,
2970     1            IREFSW,IREFCO,
2971     1            IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
2972     1            PTEXHE,PTEXWI,PTEXVG,PTEXHG)
2973C
2974      X1=X2
2975      Y1=Y2
2976C
2977      GOTO1160
2978 1190 CONTINUE
2979C
2980      PXEND=X2
2981      PYEND=Y2
2982C
2983C               ************************************
2984C               **  STEP 4--                      **
2985C               **  CARRY OUT CLOSING OPERATIONS  **
2986C               **  ON THE GRAPHICS DEVICES       **
2987C               ************************************
2988C
2989      ICOPSW='OFF'
2990      NUMCOP=0
2991      CALL DPCLPL(ICOPSW,NUMCOP,
2992     1PGRAXF,PGRAYF,
2993     1IGRASW,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
2994     1PDIAHE,PDIAWI,PDIAVG,PDIAHG)
2995C
2996      CALL DPCLDE
2997C
2998 8000 CONTINUE
2999C
3000C               *****************
3001C               **  STEP 90--  **
3002C               **  EXIT       **
3003C               *****************
3004C
3005 9000 CONTINUE
3006      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CAPA')GOTO9090
3007      WRITE(ICOUT,999)
3008      CALL DPWRST('XXX','BUG ')
3009      WRITE(ICOUT,9011)
3010 9011 FORMAT('***** AT THE END       OF DPCAPA--')
3011      CALL DPWRST('XXX','BUG ')
3012      WRITE(ICOUT,9012)ILOCFN,NUMNUM
3013 9012 FORMAT('ILOCFN,NUMNUM = ',2I8)
3014      CALL DPWRST('XXX','BUG ')
3015      WRITE(ICOUT,9013)X1,Y1,X2,Y2
3016 9013 FORMAT('X1,Y1,X2,Y2 = ',4E15.7)
3017      CALL DPWRST('XXX','BUG ')
3018      WRITE(ICOUT,9015)PXSTAR,PYSTAR
3019 9015 FORMAT('PXSTAR,PYSTAR = ',2E15.7)
3020      CALL DPWRST('XXX','BUG ')
3021      WRITE(ICOUT,9016)PXEND,PYEND
3022 9016 FORMAT('PXEND,PYEND = ',2E15.7)
3023      CALL DPWRST('XXX','BUG ')
3024      WRITE(ICOUT,9017)IFIG
3025 9017 FORMAT('IFIG = ',A4)
3026      CALL DPWRST('XXX','BUG ')
3027      WRITE(ICOUT,9027)IFOUND
3028 9027 FORMAT('IFOUND = ',A4)
3029      CALL DPWRST('XXX','BUG ')
3030      WRITE(ICOUT,9028)IBUGG4,ISUBG4,IERRG4
3031 9028 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4)
3032      CALL DPWRST('XXX','BUG ')
3033      WRITE(ICOUT,9029)IBUGD2,IERROR
3034 9029 FORMAT('IBUGD2,IERROR = ',A4,2X,A4)
3035      CALL DPWRST('XXX','BUG ')
3036 9090 CONTINUE
3037C
3038      RETURN
3039      END
3040      SUBROUTINE DPCAP2(X1,Y1,X2,Y2,
3041     1IFIG,
3042     1ILINPA,ILINCO,PLINTH,
3043     1AREGBA,
3044     1IREBLI,IREBCO,PREBTH,
3045     1IREFSW,IREFCO,
3046     1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
3047     1PTEXHE,PTEXWI,PTEXVG,PTEXHG)
3048C
3049C     PURPOSE--DRAW AN CAPACITOR
3050C              WITH THE BACK CENTER AT (X1,Y1)
3051C              AND THE FRONT CENTER AT (X2,Y2).
3052C     WRITTEN BY--JAMES J. FILLIBEN
3053C                 STATISTICAL ENGINEERING DIVISION
3054C                 INFORMATION TECHNOLOGY LABORATORY
3055C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
3056C                 GAITHERSBURG, MD 20899-8980
3057C                 PHONE--301-975-2899
3058C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
3059C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
3060C     LANGUAGE--ANSI FORTRAN (1977)
3061C     VERSION NUMBER--82/7
3062C     ORIGINAL VERSION--APRIL     1981.
3063C     UPDATED         --MAY       1982.
3064C     UPDATED         --JANUARY   1989.  MODIFY CALLS TO DPDRPL (ALAN)
3065C
3066C-----NON-COMMON VARIABLES-------------------------------------
3067C
3068      CHARACTER*4 IFIG
3069C
3070      CHARACTER*4 ILINPA
3071      CHARACTER*4 ILINCO
3072C
3073      CHARACTER*4 IREBLI
3074      CHARACTER*4 IREBCO
3075      CHARACTER*4 IREFSW
3076      CHARACTER*4 IREFCO
3077      CHARACTER*4 IREPTY
3078      CHARACTER*4 IREPLI
3079      CHARACTER*4 IREPCO
3080C
3081      CHARACTER*4 IPATT
3082CCCCC CHARACTER*4 ICOLF
3083CCCCC CHARACTER*4 ICOLP
3084      CHARACTER*4 ICOL
3085      CHARACTER*4 IFLAG
3086C
3087      DIMENSION PX(10)
3088      DIMENSION PY(10)
3089CCCCC DIMENSION PX3(10)
3090CCCCC DIMENSION PY3(10)
3091C
3092      DIMENSION ILINPA(*)
3093      DIMENSION ILINCO(*)
3094      DIMENSION PLINTH(*)
3095C
3096      DIMENSION AREGBA(*)
3097      DIMENSION IREBLI(*)
3098      DIMENSION IREBCO(*)
3099      DIMENSION PREBTH(*)
3100      DIMENSION IREFSW(*)
3101      DIMENSION IREFCO(*)
3102      DIMENSION IREPTY(*)
3103      DIMENSION IREPLI(*)
3104      DIMENSION IREPCO(*)
3105      DIMENSION PREPTH(*)
3106      DIMENSION PREPSP(*)
3107C
3108C-----COMMON----------------------------------------------------------
3109C
3110      INCLUDE 'DPCOGR.INC'
3111      INCLUDE 'DPCOBE.INC'
3112C
3113C-----COMMON VARIABLES (GENERAL)--------------------------------------
3114C
3115      INCLUDE 'DPCOP2.INC'
3116C
3117C-----START POINT-----------------------------------------------------
3118C
3119      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CAP2')GOTO90
3120      WRITE(ICOUT,999)
3121  999 FORMAT(1X)
3122      CALL DPWRST('XXX','BUG ')
3123      WRITE(ICOUT,51)
3124   51 FORMAT('***** AT THE BEGINNING OF DPCAP2--')
3125      CALL DPWRST('XXX','BUG ')
3126      WRITE(ICOUT,53)X1,Y1
3127   53 FORMAT('X1,Y1 = ',2E15.7)
3128      CALL DPWRST('XXX','BUG ')
3129      WRITE(ICOUT,54)X2,Y2
3130   54 FORMAT('X2,Y2 = ',2E15.7)
3131      CALL DPWRST('XXX','BUG ')
3132      WRITE(ICOUT,59)IFIG
3133   59 FORMAT('IFIG = ',A4)
3134      CALL DPWRST('XXX','BUG ')
3135      WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1)
3136   61 FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',A4,2X,A4,E15.7)
3137      CALL DPWRST('XXX','BUG ')
3138      WRITE(ICOUT,62)AREGBA(1)
3139   62 FORMAT('AREGBA(1) = ',E15.7)
3140      CALL DPWRST('XXX','BUG ')
3141      WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1)
3142   63 FORMAT('IREBLI(1),IREBCO(1),PREBTH(1) = ',A4,2X,A4,E15.7)
3143      CALL DPWRST('XXX','BUG ')
3144      WRITE(ICOUT,64)IREFSW(1),IREFCO(1)
3145   64 FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4)
3146      CALL DPWRST('XXX','BUG ')
3147      WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1)
3148   65 FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ',
3149     1A4,2X,A4,2X,A4,2E15.7)
3150      CALL DPWRST('XXX','BUG ')
3151      WRITE(ICOUT,69)PTEXHE,PTEXWI
3152   69 FORMAT('PTEXHE,PTEXWI= ',2E15.7)
3153      CALL DPWRST('XXX','BUG ')
3154      WRITE(ICOUT,70)PTEXVG,PTEXHG
3155   70 FORMAT('PTEXVG,PTEXHG= ',2E15.6)
3156      CALL DPWRST('XXX','BUG ')
3157      WRITE(ICOUT,79)IBUGG4,ISUBG4,IERRG4
3158   79 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
3159      CALL DPWRST('XXX','BUG ')
3160   90 CONTINUE
3161C
3162C               *********************************
3163C               **  STEP 1--                   **
3164C               **  DETERMINE THE COORDINATES  **
3165C               **  FOR THE CAPACITOR          **
3166C               *********************************
3167C
3168      DELX=X2-X1
3169      DELY=Y2-Y1
3170      LEN=INT(SQRT((X2-X1)**2+(Y2-Y1)**2))
3171      ALEN=LEN
3172      IF(ABS(DELX).GE.0.00001)THETA=ATAN(DELY/DELX)
3173      IF(ABS(DELX).LT.0.00001.AND.DELY.GE.0.0)THETA=3.1415926/2.0
3174      IF(ABS(DELX).LT.0.00001.AND.DELY.LT.0.0)THETA=-3.1415926/2.0
3175C
3176      AJXMIN=PTEXWI
3177      AJXDEL=PTEXWI
3178      AJYDEL=PTEXHE
3179      AJXMAX=ALEN-AJXDEL
3180C
3181      XMIN=AJXMIN
3182      XDEL=AJXDEL
3183      YDEL=AJYDEL
3184      XMAX=AJXMAX
3185C
3186      K=0
3187C
3188      X=0
3189CCCCC Y=-ALEN/2.0
3190      Y=(-YDEL/2.0)
3191      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
3192      K=K+1
3193      PX(K)=XP
3194      PY(K)=YP
3195C
3196      X=0
3197CCCCC Y=ALEN/2.0
3198      Y=YDEL/2.0
3199      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
3200      K=K+1
3201      PX(K)=XP
3202      PY(K)=YP
3203C
3204      NP=K
3205C
3206      IPATT=ILINPA(1)
3207      PTHICK=PLINTH(1)
3208      ICOL=ILINCO(1)
3209      IFLAG='ON'
3210CCCCC CALL DPDRPL(PX,PY,NP,PX3,PY3,NP3,
3211CCCCC1IFIG,IPATT,PTHICK,ICOL)
3212      CALL DPDRPL(PX,PY,NP,
3213     1IFIG,IPATT,PTHICK,ICOL,
3214     1JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
3215C
3216      K=0
3217C
3218      X=ALEN
3219CCCCC Y=-ALEN/2.0
3220      Y=(-YDEL/2.0)
3221      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
3222      K=K+1
3223      PX(K)=XP
3224      PY(K)=YP
3225C
3226      X=ALEN
3227CCCCC Y=ALEN/2.0
3228      Y=YDEL/2.0
3229      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
3230      K=K+1
3231      PX(K)=XP
3232      PY(K)=YP
3233C
3234      NP=K
3235C
3236      IFLAG='ON'
3237CCCCC CALL DPDRPL(PX,PY,NP,PX3,PY3,NP3,
3238CCCCC1IFIG,IPATT,PTHICK,ICOL)
3239      CALL DPDRPL(PX,PY,NP,
3240     1IFIG,IPATT,PTHICK,ICOL,
3241     1JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
3242C
3243C               *****************
3244C               **  STEP 90--  **
3245C               **  EXIT       **
3246C               *****************
3247C
3248      IF(IBUGG4.EQ.'ON' .OR. ISUBG4.EQ.'CAP2')THEN
3249        WRITE(ICOUT,999)
3250        CALL DPWRST('XXX','BUG ')
3251        WRITE(ICOUT,9011)
3252 9011   FORMAT('***** AT THE END       OF DPCAP2--')
3253        CALL DPWRST('XXX','BUG ')
3254        DO9015I=1,NP
3255          WRITE(ICOUT,9016)I,PX(I),PY(I)
3256 9016     FORMAT('I,PX(I),PY(I) = ',I8,2E15.7)
3257          CALL DPWRST('XXX','BUG ')
3258 9015   CONTINUE
3259        WRITE(ICOUT,9039)IERRG4,NP
3260 9039   FORMAT('IERRG4,NP = ',A4,2X,I8)
3261        CALL DPWRST('XXX','BUG ')
3262      ENDIF
3263C
3264      RETURN
3265      END
3266      SUBROUTINE DPCAPT(ICOM,ICOM2,
3267     1                 ICAPSW,ICAPTY,ICAPSC,IPRDEF,
3268     1                 IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,MAXNAM,
3269     1                 IANSLC,IANS,IWIDTH,
3270     1                 IHARG,IHARG2,IARGT,IARG,ARG,NUMARG,
3271     1                 IOFILE,IBACCO,IGRASW,IDIASW,
3272     1                 PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
3273     1                 PDIAHE,PDIAWI,PDIAVG,PDIAHG,
3274     1                 NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
3275     1                 IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
3276     1                 IDNVOF,IDNHOF,IDFONT,PDSCAL,
3277     1                 IREPCH,IMPSW,
3278     1                 IBUGS2,ISUBRO,IFOUND,IERROR)
3279C
3280C     PURPOSE--INITIATE/TERMINATE A CAPTURE FILE FOR CAPTURING/REDIRECTING
3281C              ALPHANUMERIC OUTPUT (ONLY)--NOT EFFECT GRAPHICS OUTPUT.
3282C              THERE ARE 2 CAPABILITITES IN THIS REGARD--
3283C                 1) TURN THE CAPTURE SWITCH 'ON' WHICH WILL
3284C                    ALLOW A CAPTURE FILE TO BE OPENED.
3285C                 2) TURN THE CAPTURE SWITCH 'OFF' WHICH WILL TERMINATE
3286C                    THE ENTRY OF TEXT OUTPUT INTO THE CAPTURE FILE.
3287C     NOTE--THESE CAPABILITITIES WILL ALLOW THE ALPHANUMERIC OUTPUT (NOT
3288C           GRAPHICS OUTPUT) FROM ANY DATAPLOT COMMAND TO BE CAPTURED
3289C           (OR REDIRECTED) TO ANY FILE.  ALL SUBSEQUENT DATAPLOT
3290C           ALPHANUMERIC OUTPUT ARE AUTOMATICALLY DIVERTED FROM THE SCREEN
3291C           TO THE SPECIFIED SYSTEM FILE OR SUBFILE.  WHEN THE CAPTURE
3292C           SWITCH IS OFF, NO SUCH DIVERSION IS DONE.  THE SPECIFIED
3293C           STATUS (ON/OFF) OF THE CAPTURE WILL BE PLACED IN THE VARIABLE
3294C           ICAPSW.
3295C     INPUT  ARGUMENTS--ICOM
3296C                     --ICOM2
3297C                     --ICAPSW
3298C                     --ICAPTY
3299C                     --IANSLC (A  HOLLERITH VECTOR WHOSE
3300C                              I-TH ELEMENT CONTAINS THE
3301C                              I-TH CHARACTER OF THE
3302C                              ORIGINAL INPUT COMMAND LINE.
3303C                     --IWIDTH (AN INTEGER VARIABLE WHICH
3304C                              CONTAINS THE NUMBER OF CHARACTERS
3305C                              IN THE ORIGINAL COMMAND LINE.
3306C                     --IHARG  (A  HOLLERITH VECTOR)
3307C                     --NUMARG (AN INTEGER VARIABLE)
3308C                     --IBUG   (A HOLLERITH VARIABLE
3309C                               FOR DEBUGGING
3310C     PRIMARY CHANGED VARIABLE--IPR (IN COMMON)
3311C     OUTPUT ARGUMENTS--ICAPSW (AN INTEGER VARIABLE
3312C                              WHICH IF 'ON' INDICATES THAT
3313C                              CURRENT COMMANDS ARE
3314C                              BEING DIVERTED
3315C                              TO A CAPTURE TEXT; AND
3316C                              IF OFF INDICATES THAT
3317C                              A CAPTURE FILE IS NOT BEING CONSTRUCTED.
3318C                     --IFOUND ('YES' OR 'NO' )
3319C                     --IERROR ('YES' OR 'NO' )
3320C     WRITTEN BY--JAMES J. FILLIBEN
3321C                 STATISTICAL ENGINEERING DIVISION
3322C                 INFORMATION TECHNOLOGY LABORATORY
3323C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
3324C                 GAITHERSBURG, MD 20899-8980
3325C                 PHONE--301-975-2899
3326C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
3327C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
3328C     LANGUAGE--ANSI FORTRAN (1977)
3329C     VERSION NUMBER--89/6
3330C     ORIGINAL VERSION--JUNE      1989.
3331C     UPDATED         --JUNE      2002.  ADD SUPPORT FOR:
3332C                                        CAPTURE FLUSH
3333C                                        CAPTURE HTML FILE.
3334C                                        CAPTURE LATEX FILE.
3335C     UPDATED         --JANUARY   2003.  FOR CAPTURE HTML, OPTIONALLY
3336C                                        READ HEADER AND FOOTER FILES
3337C     UPDATED         --JULY      2003.  BUG: FILE NAME < 80
3338C                                        CHARACTERS, BUT COMMAND LINE
3339C                                        > 80 CHARACTERS
3340C     UPDATED         --SEPTEMBER 2003.  START IMPLEMENTING THE LATEX
3341C                                        CODE
3342C     UPDATED         --FEBRUARY  2005.  START IMPLEMENTING THE RTF
3343C                                        CODE
3344C     UPDATED         --DECEMBER  2005.  SUSPEND/RESUME CASES
3345C     UPDATED         --JANUARY   2006.  CAPTURE SCREEN <ON/OFF>
3346C     UPDATED         --FEBRUARY  2006.  ADD EPIC, EEPIC, GRAPHICS
3347C                                        PACKAGES TO LATEX PRE-AMBLE
3348C     UPDATED         --NOVEMBER  2008.  INITIALIZE HTML44 COMMON BLOCK
3349C     UPDATED         --APRIL     2012.  CAPTURE SCRIPT
3350C     UPDATED         --APRIL     2012.  CAPTURE FLUSH ERASE <ON/OFF>
3351C     UPDATED         --AUGUST    2015.  CAPTURE FUNCTION BLOCK
3352C     UPDATED         --DECEMBER  2015.  "NONE" OPTION FOR LATEX/HTML
3353C                                        HEADERS AND FOOTERS
3354C     UPDATED         --DECEMBER  2015.  SET CAPTURE SPLIT ON OPTION
3355C     UPDATED         --AUGUST    2016.  CAPTURE STATISTIC BLOCK
3356C     UPDATED         --DECEMBER  2018.  ADD PDSCAL TO CALL LIST TO DPERAS
3357C
3358C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
3359C
3360      CHARACTER*4 ICOM
3361      CHARACTER*4 ICOM2
3362      CHARACTER*4 ICAPSW
3363      CHARACTER*4 ICAPTY
3364      CHARACTER*4 ICAPSC
3365      CHARACTER*4 IHNAME
3366      CHARACTER*4 IHNAM2
3367      CHARACTER*4 IUSE
3368      CHARACTER*4 IANSLC
3369      CHARACTER*4 IANS
3370      CHARACTER*4 IHARG
3371      CHARACTER*4 IHARG2
3372      CHARACTER*4 IARGT
3373      CHARACTER*4 IOFILE
3374C
3375      CHARACTER*240 IATEMP
3376      CHARACTER*1   ITEMP
3377C
3378      CHARACTER*1 IREPCH
3379      CHARACTER*4 IMPSW
3380C
3381      CHARACTER*4 IBUGS2
3382      CHARACTER*4 ISUBRO
3383      CHARACTER*4 IFOUND
3384      CHARACTER*4 IERROR
3385C
3386      INCLUDE 'DPCOPA.INC'
3387C
3388CCCCC CHARACTER*80 IFILE
3389      CHARACTER (LEN=MAXFNC) :: IFILE
3390      CHARACTER*12 ISTAT
3391      CHARACTER*12 IFORM
3392      CHARACTER*12 IACCES
3393      CHARACTER*12 IPROT
3394      CHARACTER*12 ICURST
3395      CHARACTER*4 IENDFI
3396      CHARACTER*4 IREWIN
3397      CHARACTER*4 ISUBN0
3398      CHARACTER*4 IERRFI
3399C
3400CCCCC CHARACTER*80 IFILE2
3401      CHARACTER (LEN=MAXFNC) :: IFILE2
3402      CHARACTER*12 ISTAT2
3403      CHARACTER*12 IFORM2
3404      CHARACTER*12 IACCE2
3405      CHARACTER*12 IPROT2
3406      CHARACTER*12 ICURS2
3407      CHARACTER*4 IERRF2
3408      CHARACTER*4 IENDF2
3409      CHARACTER*4 IREWI2
3410C
3411      CHARACTER*4 IANSI
3412CCCCC CHARACTER*80 ICANS
3413      CHARACTER*200 ICANS
3414C
3415C ---------------------------------------------------------------------
3416C
3417      DIMENSION IANSLC(*)
3418      DIMENSION IANS(*)
3419      DIMENSION IHARG(*)
3420      DIMENSION IHARG2(*)
3421      DIMENSION IARGT(*)
3422      DIMENSION IARG(*)
3423      DIMENSION ARG(*)
3424C
3425      DIMENSION IHNAME(*)
3426      DIMENSION IHNAM2(*)
3427      DIMENSION IUSE(*)
3428      DIMENSION IVALUE(*)
3429      DIMENSION VALUE(*)
3430C
3431      CHARACTER*4 IBACCO
3432      CHARACTER*4 IGRASW
3433      CHARACTER*4 IDIASW
3434C
3435      CHARACTER*4 IDMANU
3436      CHARACTER*4 IDMODE
3437      CHARACTER*4 IDMOD2
3438      CHARACTER*4 IDMOD3
3439C
3440      CHARACTER*4 IDPOWE
3441      CHARACTER*4 IDCONT
3442      CHARACTER*4 IDCOLO
3443      CHARACTER*4 IDFONT
3444C
3445      CHARACTER*4 IFLAG
3446      CHARACTER*4 ISUBN1
3447      CHARACTER*4 ISUBN2
3448      CHARACTER*4 IH
3449      CHARACTER*4 IH2
3450      CHARACTER*4 ISTEPN
3451      CHARACTER*4 IFILQ2
3452      CHARACTER*1 IBASLC
3453C
3454      DIMENSION IDMANU(*)
3455      DIMENSION IDMODE(*)
3456      DIMENSION IDMOD2(*)
3457      DIMENSION IDMOD3(*)
3458      DIMENSION IDPOWE(*)
3459      DIMENSION IDCONT(*)
3460      DIMENSION IDCOLO(*)
3461      DIMENSION IDFONT(*)
3462      DIMENSION IDNVPP(*)
3463      DIMENSION IDNHPP(*)
3464      DIMENSION IDUNIT(*)
3465      DIMENSION IDNVOF(*)
3466      DIMENSION IDNHOF(*)
3467      DIMENSION PDSCAL(*)
3468C
3469C-----COMMON----------------------------------------------------------
3470C
3471      CHARACTER*4 IRTFMD
3472      COMMON/COMRTF/IRTFMD
3473C
3474      COMMON/HTML44/IFNTSZ
3475      INCLUDE 'DPCOST.INC'
3476      INCLUDE 'DPCOFO.INC'
3477      INCLUDE 'DPCOF2.INC'
3478      INCLUDE 'DPCOFB.INC'
3479      INCLUDE 'DPCOSB.INC'
3480C
3481C-----COMMON VARIABLES (GENERAL)--------------------------------------
3482C
3483      INCLUDE 'DPCOP2.INC'
3484C
3485C-----START POINT-----------------------------------------------------
3486C
3487      ISUBN1='DPCA'
3488      ISUBN2='PT  '
3489      IFOUND='YES'
3490      IERROR='NO'
3491C
3492      IFILQ2=IFILQU
3493      IFILQU='ON'
3494      IH='UNKN'
3495      IH2='UNKN'
3496C
3497      KMIN=0
3498      KDEL=0
3499      KMAX=0
3500      JP3=0
3501      JP4=0
3502      JP5=0
3503      J12=0
3504      J22=0
3505      J32=0
3506      J42=0
3507      J52=0
3508      J62=0
3509      J72=0
3510      J82=0
3511      J92=0
3512      J102=0
3513      IPAR2=0
3514      IPAR3=0
3515      IPAR4=0
3516      IPAR5=0
3517      IPAR6=0
3518      IPAR7=0
3519      IPAR8=0
3520      IPAR9=0
3521      IPAR10=0
3522C
3523      P2=0.0
3524C
3525      CALL DPCONA(92,IBASLC)
3526C
3527      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT')THEN
3528        WRITE(ICOUT,999)
3529  999   FORMAT(1X)
3530        CALL DPWRST('XXX','BUG ')
3531        WRITE(ICOUT,51)
3532   51   FORMAT('***** AT THE BEGINNING OF DPCAPT--')
3533        CALL DPWRST('XXX','BUG ')
3534        WRITE(ICOUT,52)ICAPSW,ICAPTY,ICAPNU,ICAPCS,IPR,IPRDEF,NUMARG
3535   52   FORMAT('ICAPSW,ICAPTY,ICAPNU,ICAPCS,IPR,IPRDEF,NUMARG = ',
3536     1         2(A4,2X),I8,2X,A12,3I8)
3537        CALL DPWRST('XXX','BUG ')
3538        WRITE(ICOUT,54)IBUGS2,IERROR,ICOM,ICOM2,IWIDTH
3539   54   FORMAT('IBUGS2,IERROR,ICOM,ICOM2,IWIDTH = ',4(A4,2X),I8)
3540        CALL DPWRST('XXX','BUG ')
3541        WRITE(ICOUT,55)(IANSLC(I),I=1,MIN(120,IWIDTH))
3542   55   FORMAT('IANSLC(.) = ',120A1)
3543        CALL DPWRST('XXX','BUG ')
3544        IF(NUMARG.GT.0)THEN
3545          DO57I=1,NUMARG
3546            WRITE(ICOUT,58)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I)
3547   58       FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) = ',
3548     1             I8,3(2X,A4),I8,G15.7)
3549            CALL DPWRST('XXX','BUG ')
3550   57     CONTINUE
3551        ENDIF
3552        WRITE(ICOUT,62)NUMNAM,MAXNAM,NUMCHA,ICAPNU
3553   62   FORMAT('NUMNAM,MAXNAM,NUMCHA,ICAPNU = ',4I8)
3554        CALL DPWRST('XXX','BUG ')
3555        DO65I=1,NUMNAM
3556          WRITE(ICOUT,66)I,IHNAME(I),IHNAM2(I),IUSE(I),
3557     1                   IVALUE(I),VALUE(I)
3558   66     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVALUE(I),VALUE(I) = ',
3559     1           I8,3(2X,A4),I8,G15.7)
3560          CALL DPWRST('XXX','BUG ')
3561   65   CONTINUE
3562        WRITE(ICOUT,73)(IA(I),I=1,MIN(100,NUMCHA))
3563   73   FORMAT('(IA(I),I=1,NUMCHA) = ',100A1)
3564        CALL DPWRST('XXX','BUG ')
3565        WRITE(ICOUT,82)ICAPNA
3566   82   FORMAT('ICAPNA = ',A80)
3567        CALL DPWRST('XXX','BUG ')
3568        WRITE(ICOUT,83)ICAPST,ICAPFO,ICAPAC,ICAPFO
3569   83   FORMAT('ICAPST,ICAPFO,ICAPAC,ICAPCO = ',3(A12,2X),A12)
3570        CALL DPWRST('XXX','BUG ')
3571        WRITE(ICOUT,85)(IANS(I),I=1,MIN(100,IWIDTH))
3572   85   FORMAT('IANS(.) = ',100A1)
3573        CALL DPWRST('XXX','BUG ')
3574      ENDIF
3575C
3576C               ****************************************************
3577C               **  STEP 11--                                     **
3578C               **  FOR THE SPECIAL CASE WHEN THE CAPTURING       **
3579C               **  OF ALPHA TEXT HAS JUST BEEN FINISHED, JUMP    **
3580C               **  TO CLOSING THE FILE                           **
3581C               ****************************************************
3582C
3583      ISTEPN='11'
3584      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT')
3585     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3586C
3587      IF(ICAPCS.EQ.'CLO2        ')GOTO5000
3588C
3589C               ***********************************************
3590C               **  STEP 12--                                **
3591C               **  FOR THE SPECIAL CASE WHEN HAVE THE       **
3592C               **  END CAPTURE     COMMAND, OR THE          **
3593C               **  END REDIRECT      COMMAND, OR THE        **
3594C               **  END OF CAPTURE      COMMAND,             **
3595C               **  END OF REDIRECT       COMMAND,           **
3596C               **  JUMP IMMEDIATELY TO THE SECTION OF CODE  **
3597C               **  WHICH PUTS ON AN END OF FILE AND         **
3598C               **  CLOSES THE FILE/SUBFILE.                 **
3599C               ***********************************************
3600C
3601      ISTEPN='12'
3602      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT')
3603     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3604C
3605      IF(ICOM.EQ.'END ')THEN
3606        IF(NUMARG.LE.0)GOTO9000
3607        IF(IHARG(1).EQ.'CAPT')GOTO4000
3608        IF(IHARG(1).EQ.'REDI')GOTO4000
3609        IF(IHARG(1).EQ.'DIVE')GOTO4000
3610        IF(IHARG(1).EQ.'PIPE')GOTO4000
3611        IF(NUMARG.LE.1)GOTO9000
3612        IF(IHARG(1).EQ.'OF  '.AND.IHARG(2).EQ.'CAPT')GOTO4000
3613        IF(IHARG(1).EQ.'OF  '.AND.IHARG(2).EQ.'REDI')GOTO4000
3614        IF(IHARG(1).EQ.'OF  '.AND.IHARG(2).EQ.'DIVE')GOTO4000
3615        IF(IHARG(1).EQ.'OF  '.AND.IHARG(2).EQ.'PIPE')GOTO4000
3616        GOTO9000
3617      ELSEIF(ICOM.EQ.'FLUS')THEN
3618        IF(NUMARG.LE.0)GOTO1290
3619        IF(IHARG(1).EQ.'CAPT')GOTO6000
3620      ELSEIF(ICOM.EQ.'CAPT')THEN
3621        IF(NUMARG.LE.0)GOTO1290
3622        IF(IHARG(1).EQ.'FLUS')GOTO6000
3623      ENDIF
3624C
3625 1290 CONTINUE
3626C
3627C               ********************************************************
3628C               **  STEP 13--                                         **
3629C               **  DETERMINE THE TYPE CASE--                         **
3630C               **       1) CREATE AN EXPLICIT CAPTURE FILE;          **
3631C               **       2) OMIT THE FILE NAME;                       **
3632C               **  NOTE--IOFILE  WILL EQUAL 'YES' ONLY IN FILE CASE. **
3633C               **  IN OTHER WORDS, THIS STEP MAKES SURE              **
3634C               **  THAT A FILE NAME IS EXISTENT AFTER THE            **
3635C               **  CAPTURE   AND   REDIRECT   COMMANDS.              **
3636C               ********************************************************
3637C
3638      ISTEPN='13'
3639      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT')
3640     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3641C
3642      IF(NUMARG.EQ.1 .AND. IHARG(1).EQ.'SUSP')GOTO2000
3643      IF(NUMARG.EQ.1 .AND. IHARG(1).EQ.'OFF ')GOTO2000
3644      IF(NUMARG.EQ.1 .AND. IHARG(1).EQ.'RESU')GOTO2000
3645      IF(NUMARG.EQ.1 .AND. IHARG(1).EQ.'ON  ')GOTO2000
3646      IF(NUMARG.GE.1 .AND. IHARG(1).EQ.'SCRE')GOTO2000
3647      IF(NUMARG.GE.2 .AND. IHARG(1).EQ.'FUNC' .AND.
3648     1   IHARG(2).EQ.'BLOC')GOTO2000
3649      IF(NUMARG.GE.2 .AND. IHARG(1).EQ.'STAT' .AND.
3650     1   IHARG(2).EQ.'BLOC')GOTO2000
3651C
3652C     2015/11: CHECK IF CAPTURE SWITCH IS ALREADY ON
3653C
3654      IF(ICAPSW.EQ.'ON')THEN
3655        WRITE(ICOUT,999)
3656        CALL DPWRST('XXX','BUG ')
3657        IF(IFEEDB.EQ.'ON')THEN
3658          WRITE(ICOUT,1211)
3659 1211     FORMAT('***** WARNING IN CAPTURE--')
3660          CALL DPWRST('XXX','BUG ')
3661          WRITE(ICOUT,1212)
3662 1212     FORMAT('      THE CAPTURE SWITCH IS ALREADY ON.  NOTHING ',
3663     1           'DONE.')
3664          CALL DPWRST('XXX','BUG ')
3665        ENDIF
3666        IERROR='WARN'
3667        GOTO9000
3668      ENDIF
3669C
3670      IWORD=2
3671      IF(IHARG(1).EQ.'HTML'.OR.IHARG(1).EQ.'LATE'.OR.
3672     1   IHARG(1).EQ.'RTF '.OR.IHARG(1).EQ.'SCRI')IWORD=3
3673      CALL DPFILE(IANSLC,IWIDTH,IWORD,
3674     1            IOFILE,IBUGS2,ISUBRO,IERROR)
3675C
3676C               **********************************************
3677C               **  STEP 14--                               **
3678C               **  IF NO FILE NAME GIVEN,                  **
3679C               **  THEN GENERATE AN ERROR MESSAGE.         **
3680C               **********************************************
3681C
3682      ISTEPN='14'
3683      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT')
3684     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3685C
3686      IF(IOFILE.NE.'YES')THEN
3687        IERROR='YES'
3688        WRITE(ICOUT,999)
3689        CALL DPWRST('XXX','BUG ')
3690        WRITE(ICOUT,1411)
3691 1411   FORMAT('***** ERROR IN CAPTURE--')
3692        CALL DPWRST('XXX','BUG ')
3693        WRITE(ICOUT,1412)
3694 1412   FORMAT('      THE DESIRED CAPTURE OPERATION CANNOT BE ',
3695     1         'PERFORMED BECAUSE')
3696        CALL DPWRST('XXX','BUG ')
3697        WRITE(ICOUT,1414)
3698 1414   FORMAT('      NO FILE NAME WAS GIVEN.  ILLUSTRATIVE EXAMPLE')
3699        CALL DPWRST('XXX','BUG ')
3700        WRITE(ICOUT,1416)
3701 1416   FORMAT('      TO DEMONSTRATE THE PROPER FORM--')
3702        CALL DPWRST('XXX','BUG ')
3703        WRITE(ICOUT,1417)
3704 1417   FORMAT('      SUPPOSE THE ANALYST WISHES TO CAPTURE TEXT')
3705        CALL DPWRST('XXX','BUG ')
3706        WRITE(ICOUT,1419)
3707 1419   FORMAT('      OUTPUT TO THE FILE    TEMP1.  ;')
3708        CALL DPWRST('XXX','BUG ')
3709        WRITE(ICOUT,1420)
3710 1420   FORMAT('      THEN THE FOLLOWING COMMAND LINE IS ENTERED--')
3711        CALL DPWRST('XXX','BUG ')
3712        WRITE(ICOUT,1421)
3713 1421   FORMAT('         CAPTURE TEMP1.')
3714        CALL DPWRST('XXX','BUG ')
3715        GOTO9000
3716      ENDIF
3717C
3718C               *************************************
3719C               **  STEP 15--                      **
3720C               **  IF HAVE THE FILE INPUT CASE    **
3721C               **  (WHICH WE MUST HAVE)--         **
3722C               **  COPY OVER VARIABLES            **
3723C               *************************************
3724C
3725      ISTEPN='15'
3726      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT')
3727     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3728C
3729      IOUNIT=ICAPNU
3730      IFILE=ICAPNA
3731      ISTAT=ICAPST
3732      IF(IFILE.EQ.ISYSNA)ISTAT=ISYSST
3733      IF(IFILE.EQ.ILOGNA)ISTAT=ILOGST
3734      IFORM=ICAPFO
3735      IACCES=ICAPAC
3736      IPROT=ICAPPR
3737C     (SEE ADDITIONAL RESETTING OF   IPROT   BELOW
3738C     IF HAVE THE SYSTEM LOGIN AND/OR THE LOCAL LOGIN CAPTURE FILES)
3739      ICURST=ICAPCS
3740C
3741      ISUBN0='CAPT'
3742      IERRFI='NO'
3743C
3744      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT')THEN
3745        WRITE(ICOUT,1513)IOUNIT,ISUBN0,IERRFI
3746 1513   FORMAT('IOUNIT,ISUBN0,IERRFI = ',I8,2(2X,A4))
3747        CALL DPWRST('XXX','BUG ')
3748        WRITE(ICOUT,1514)IFILE
3749 1514   FORMAT('IFILE = ',A80)
3750        CALL DPWRST('XXX','BUG ')
3751        WRITE(ICOUT,1515)ISTAT,IFORM,IACCES,IPROT,ICURST
3752 1515   FORMAT('ISTAT,IFORM,IACCES,IPROT,ICURST = ',4(A12,2X),A12)
3753        CALL DPWRST('XXX','BUG ')
3754      ENDIF
3755C
3756C               ***********************************************
3757C               **  STEP 16--                                **
3758C               **  IF HAVE THE FILE CASE (WHICH WE MUST     **
3759C               **  HAVE)--CHECK TO SEE IF THE CAPTURE FILE  **
3760C               **  MAY EXIST                                **
3761C               ***********************************************
3762C
3763      ISTEPN='16'
3764      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT')
3765     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3766C
3767      IF(ISTAT.EQ.'NONE')THEN
3768        IERROR='YES'
3769        WRITE(ICOUT,999)
3770        CALL DPWRST('XXX','BUG ')
3771        WRITE(ICOUT,1411)
3772        CALL DPWRST('XXX','BUG ')
3773        WRITE(ICOUT,1412)
3774        CALL DPWRST('XXX','BUG ')
3775        WRITE(ICOUT,1614)
3776 1614   FORMAT('      THE INTERNAL VARIABLE   ICAPST   WHICH ALLOWS')
3777        CALL DPWRST('XXX','BUG ')
3778        WRITE(ICOUT,1616)
3779 1616   FORMAT('      SUCH CAPTURE OPERATIONS HAS BEEN SET TO   NONE.')
3780        CALL DPWRST('XXX','BUG ')
3781        WRITE(ICOUT,1617)ISTAT,ICAPST
3782 1617   FORMAT('ISTAT,ICAPST = ',A12,2X,A12)
3783        CALL DPWRST('XXX','BUG ')
3784        WRITE(ICOUT,1618)
3785 1618   FORMAT('      PLEASE CONTACT YOUR DATAPLOT IMPLEMENTOR')
3786        CALL DPWRST('XXX','BUG ')
3787        WRITE(ICOUT,1619)
3788 1619   FORMAT('      TO CORRECT THE SETTING IN SUBROUTINE INITFO.')
3789        CALL DPWRST('XXX','BUG ')
3790        GOTO9000
3791      ENDIF
3792C
3793C               ********************************
3794C               **  STEP 17--                 **
3795C               **  EXTRACT THE FILE NAME.    **
3796C               **  THIS IS NEEDED FOR MOST   **
3797C               **  (BUT NOT ALL) VARIATIONS  **
3798C               **  OF THE CAPTURE COMMAND.   **
3799C               ********************************
3800C
3801      ISTEPN='17'
3802      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT')
3803     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3804C
3805CCCCC JUNE 2002.  CHECK TO SEE IF FIRST ARGUMENT IS:
3806CCCCC             HTML
3807CCCCC             LATEX
3808CCCCC             RTF            (FEBRUARY 2005)
3809CCCCC             SCRIPT         (APRIL    2012)
3810C
3811      NSTRT=1
3812C
3813      IF(IHARG(1).EQ.'HTML')THEN
3814        ICAPTY='HTML'
3815        WRITE(ICOUT,999)
3816        CALL DPWRST('XXX','BUG ')
3817        WRITE(ICOUT,1771)
3818 1771   FORMAT('THE CAPTURE OUTPUT WILL BE WRITTEN IN HTML FORMAT.')
3819        CALL DPWRST('XXX','BUG ')
3820      ELSEIF(IHARG(1).EQ.'LATE')THEN
3821        ICAPTY='LATE'
3822        WRITE(ICOUT,999)
3823        CALL DPWRST('XXX','BUG ')
3824        WRITE(ICOUT,1791)
3825 1791   FORMAT('THE CAPTURE OUTPUT WILL BE WRITTEN IN LATEX FORMAT.')
3826        CALL DPWRST('XXX','BUG ')
3827      ELSEIF(IHARG(1).EQ.'RTF ')THEN
3828        ICAPTY='RTF '
3829        WRITE(ICOUT,999)
3830        CALL DPWRST('XXX','BUG ')
3831        WRITE(ICOUT,1793)
3832 1793   FORMAT('THE CAPTURE OUTPUT WILL BE WRITTEN IN ',
3833     1         'RTF (RICH TEXT FORMAT) FORMAT.')
3834        CALL DPWRST('XXX','BUG ')
3835      ELSEIF(IHARG(1).EQ.'SCRI')THEN
3836        ICAPTY='SCRI'
3837        WRITE(ICOUT,999)
3838        CALL DPWRST('XXX','BUG ')
3839        WRITE(ICOUT,1795)
3840 1795   FORMAT('SCRIPT MODE TURNED ON FOR CAPTURE.  ALL ENTERED ',
3841     1         'COMMANDS WILL BE ECHOED, BUT')
3842        CALL DPWRST('XXX','BUG ')
3843        WRITE(ICOUT,1797)
3844 1797   FORMAT('NOT EXECUTED, TO THE CAPTURE FILE UNTIL AN  ',
3845     1         'END OF CAPTURE  COMMAND IS ENTERED.')
3846        CALL DPWRST('XXX','BUG ')
3847      ENDIF
3848C
3849      DO1710I=1,200
3850        IANSI=IANSLC(I)
3851        ICANS(I:I)=IANSI(1:1)
3852 1710 CONTINUE
3853C
3854      ISTART=1
3855      ISTOP=IWIDTH
3856      IWORD=2
3857      IF(ICAPTY.EQ.'HTML')IWORD=3
3858      IF(ICAPTY.EQ.'LATE')IWORD=3
3859      IF(ICAPTY.EQ.'RTF ')IWORD=3
3860      IF(ICAPTY.EQ.'SCRI')IWORD=3
3861      CALL DPEXWO(ICANS,ISTART,ISTOP,IWORD,
3862     1            ICOL1,ICOL2,IFILE,NCFILE,
3863     1            IBUGS2,ISUBRO,IERROR)
3864      IF(IERROR.EQ.'YES')GOTO9000
3865C
3866      IF(NCFILE.LT.1)THEN
3867        IERROR='YES'
3868        WRITE(ICOUT,999)
3869        CALL DPWRST('XXX','BUG ')
3870        WRITE(ICOUT,1411)
3871        CALL DPWRST('XXX','BUG ')
3872        WRITE(ICOUT,1742)
3873 1742   FORMAT('      A USER FILE NAME IS REQUIRED IN THE ',
3874     1         'CAPTURE/REDIRECT COMMANDS')
3875        CALL DPWRST('XXX','BUG ')
3876        WRITE(ICOUT,1744)
3877 1744   FORMAT('      (FOR EXAMPLE,    CAPTURE TEMP1.)')
3878        CALL DPWRST('XXX','BUG ')
3879        WRITE(ICOUT,1745)
3880 1745   FORMAT('      BUT NONE WAS GIVEN HERE.')
3881        CALL DPWRST('XXX','BUG ')
3882        WRITE(ICOUT,1746)
3883 1746   FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
3884        CALL DPWRST('XXX','BUG ')
3885        IF(IWIDTH.GE.1)THEN
3886          WRITE(ICOUT,1747)(IANSLC(I),I=1,MIN(IWIDTH,100))
3887 1747     FORMAT('      ',100A1)
3888          CALL DPWRST('XXX','BUG ')
3889        ELSE
3890          WRITE(ICOUT,999)
3891          CALL DPWRST('XXX','BUG ')
3892        ENDIF
3893        GOTO9000
3894      ENDIF
3895C
3896      IF(IERROR.EQ.'YES')GOTO9000
3897      IF(IFILE.EQ.ISYSNA)IPROT=ISYSPR
3898      IF(IFILE.EQ.ILOGNA)IPROT=ILOGPR
3899C
3900C               *******************************************
3901C               **  STEP 20--                            **
3902C               **  CHECK THE DESIRED CAPTURE OPERATION  **
3903C               **  (ON, OFF, OR EXECUTE).               **
3904C               *******************************************
3905C
3906 2000 CONTINUE
3907C
3908      ISTEPN='20'
3909      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT')
3910     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3911C
3912      IF(ICOM.EQ.'CAPT' .OR. ICOM.EQ.'REDI' .OR. ICOM.EQ.'DIVE' .OR.
3913     1   ICOM.EQ.'PIPE')THEN
3914        IF(NUMARG.EQ.1 .AND. IHARG(1).EQ.'SUSP')GOTO3800
3915        IF(NUMARG.EQ.1 .AND. IHARG(1).EQ.'OFF ')GOTO3800
3916        IF(NUMARG.EQ.1 .AND. IHARG(1).EQ.'RESU')GOTO3900
3917        IF(NUMARG.EQ.1 .AND. IHARG(1).EQ.'ON  ')GOTO3900
3918C
3919C       2015/08: FUNCTION BLOCK CASE
3920C
3921        IF(NUMARG.GE.2 .AND. IHARG(1).EQ.'FUNC' .AND.
3922     1    IHARG(2).EQ.'BLOC')THEN
3923          ICAPTY='FUNB'
3924          IF(IHARG(3).EQ.'1' .OR. IHARG(3).EQ.'ONE')THEN
3925            IFBLSW='1'
3926          ELSEIF(IHARG(3).EQ.'2' .OR. IHARG(3).EQ.'TWO')THEN
3927            IFBLSW='2'
3928          ELSEIF(IHARG(3).EQ.'3' .OR. IHARG(3).EQ.'THREE')THEN
3929            IFBLSW='3'
3930          ELSE
3931            IFBLSW='OFF'
3932            IERROR='YES'
3933            WRITE(ICOUT,2116)
3934 2116       FORMAT('FOR   CAPTURE FUNCTION BLOCK  COMMAND, THE NEXT')
3935            CALL DPWRST('XXX','BUG ')
3936            WRITE(ICOUT,2117)
3937 2117       FORMAT('ARGUMENT MUST BE ONE OF: ONE (OR 1), TWO (OR 2),',
3938     1             ' OR THREE (OR 3).')
3939            CALL DPWRST('XXX','BUG ')
3940            WRITE(ICOUT,2118)IHARG(4)
3941 2118       FORMAT('THE ENTERED ARGUMENT WAS: ',A4)
3942            CALL DPWRST('XXX','BUG ')
3943            GOTO9000
3944          ENDIF
3945C
3946C         NOW PARSE THE ARGUMENTS
3947C
3948C         FIRST, RETRIEVE THE NAME OF THE FUNCTION BLOCK.
3949C
3950          IF(NUMARG.GE.4)THEN
3951            IF(IFBLSW.EQ.'1')THEN
3952              IFBNA1(1:4)=IHARG(4)
3953              IFBNA1(5:8)=IHARG2(4)
3954            ELSEIF(IFBLSW.EQ.'2')THEN
3955              IFBNA2(1:4)=IHARG(4)
3956              IFBNA2(5:8)=IHARG2(4)
3957            ELSEIF(IFBLSW.EQ.'3')THEN
3958              IFBNA3(1:4)=IHARG(4)
3959              IFBNA3(5:8)=IHARG2(4)
3960            ENDIF
3961          ELSE
3962            IERROR='YES'
3963            IFBLSW='OFF'
3964            WRITE(ICOUT,22116)
396522116       FORMAT('FOR THE  CAPTURE FUNCTION BLOCK  COMMAND, NO ',
3966     1            'NAME WAS SPECIFIED.')
3967            CALL DPWRST('XXX','BUG ')
3968            GOTO9000
3969          ENDIF
3970C
3971C         NEXT, RETRIEVE THE NAME OF THE PARAMETER/VARIABLE THAT WILL
3972C         CONTAIN THE RESPONSE (I.E., THE CALLING ROUTINE WILL EXTRACT
3973C         THE VALUE OF THIS PARAMETER/VARIABLE AFTER EXECUTING THE
3974C         FUNCTION BLOCK).
3975C
3976          IF(NUMARG.GE.5)THEN
3977            IF(IFBLSW.EQ.'1')THEN
3978              IFBAN1(1:4)=IHARG(5)
3979              IFBAN1(5:8)=IHARG2(5)
3980            ELSEIF(IFBLSW.EQ.'2')THEN
3981              IFBAN2(1:4)=IHARG(5)
3982              IFBAN2(5:8)=IHARG2(5)
3983            ELSEIF(IFBLSW.EQ.'3')THEN
3984              IFBAN3(1:4)=IHARG(5)
3985              IFBAN3(5:8)=IHARG2(5)
3986            ENDIF
3987          ELSE
3988            IERROR='YES'
3989            IFBLSW='OFF'
3990            WRITE(ICOUT,23126)
399123126       FORMAT('FOR THE  CAPTURE FUNCTION BLOCK  COMMAND, NO ',
3992     1            'RESPONSE PARAMETER/VARIABLE WAS SPECIFIED.')
3993            CALL DPWRST('XXX','BUG ')
3994            GOTO9000
3995          ENDIF
3996C
3997C         THE REMAINING ARGUMENTS ARE THE PARAMETERS NEEDED BY THE
3998C         FUNCTION BLOCK,
3999C
4000          IF(NUMARG.GE.6)THEN
4001            ICNT=0
4002            DO2150II=6,NUMARG
4003              ICNT=ICNT+1
4004              IF(ICNT.LE.20)THEN
4005                IF(IFBLSW.EQ.'1')THEN
4006                  IFBPL1(ICNT)(1:4)=IHARG(II)
4007                  IFBPL1(ICNT)(5:8)=IHARG2(II)
4008                  IF(II.EQ.NUMARG)IFBCP1=ICNT
4009                ELSEIF(IFBLSW.EQ.'2')THEN
4010                  IFBPL2(ICNT)(1:4)=IHARG(II)
4011                  IFBPL2(ICNT)(5:8)=IHARG2(II)
4012                  IF(II.EQ.NUMARG)IFBCP2=ICNT
4013                ELSEIF(IFBLSW.EQ.'3')THEN
4014                  IFBPL3(ICNT)(1:4)=IHARG(II)
4015                  IFBPL3(ICNT)(5:8)=IHARG2(II)
4016                  IF(II.EQ.NUMARG)IFBCP3=ICNT
4017                ENDIF
4018              ENDIF
4019 2150       CONTINUE
4020            IFBCP1=MIN(ICNT,MAXFBP)
4021            IFBCP2=MIN(ICNT,MAXFBP)
4022            IFBCP3=MIN(ICNT,MAXFBP)
4023          ELSE
4024            IERROR='YES'
4025            IFBLSW='OFF'
4026            WRITE(ICOUT,22136)
402722136       FORMAT('FOR THE  CAPTURE FUNCTION BLOCK  COMMAND, NO ',
4028     1            'PARAMETER LIST WAS SPECIFIED.')
4029            CALL DPWRST('XXX','BUG ')
4030            GOTO9000
4031          ENDIF
4032C
4033          GOTO9000
4034C
4035C         2016/08: STATISTIC BLOCK CASE
4036C
4037        ELSEIF(NUMARG.GE.2 .AND. IHARG(1).EQ.'STAT' .AND.
4038     1    IHARG(2).EQ.'BLOC')THEN
4039          ICAPTY='STAB'
4040          IF(IHARG(3).EQ.'1' .OR. IHARG(3).EQ.'ONE')THEN
4041            ISBLSW='1'
4042          ELSEIF(IHARG(3).EQ.'2' .OR. IHARG(3).EQ.'TWO')THEN
4043            ISBLSW='2'
4044          ELSEIF(IHARG(3).EQ.'3' .OR. IHARG(3).EQ.'THREE')THEN
4045            ISBLSW='3'
4046          ELSE
4047            ISBLSW='OFF'
4048            IERROR='YES'
4049            WRITE(ICOUT,2126)
4050 2126       FORMAT('FOR   CAPTURE STATISTIC BLOCK  COMMAND, THE NEXT')
4051            CALL DPWRST('XXX','BUG ')
4052            WRITE(ICOUT,2127)
4053 2127       FORMAT('ARGUMENT MUST BE ONE OF: ONE (OR 1), TWO (OR 2),',
4054     1             ' OR THREE (OR 3).')
4055            CALL DPWRST('XXX','BUG ')
4056            WRITE(ICOUT,2128)IHARG(4)
4057 2128       FORMAT('THE ENTERED ARGUMENT WAS: ',A4)
4058            CALL DPWRST('XXX','BUG ')
4059            GOTO9000
4060          ENDIF
4061C
4062C         NOW PARSE THE ARGUMENTS
4063C
4064C         FIRST, RETRIEVE THE NAME OF THE STATISTIC BLOCK.
4065C
4066          IF(NUMARG.GE.4)THEN
4067            IF(ISBLSW.EQ.'1')THEN
4068              ISBNA1(1:4)=IHARG(4)
4069              ISBNA1(5:8)=IHARG2(4)
4070            ELSEIF(ISBLSW.EQ.'2')THEN
4071              ISBNA2(1:4)=IHARG(4)
4072              ISBNA2(5:8)=IHARG2(4)
4073            ELSEIF(ISBLSW.EQ.'3')THEN
4074              ISBNA3(1:4)=IHARG(4)
4075              ISBNA3(5:8)=IHARG2(4)
4076            ENDIF
4077          ELSE
4078            IERROR='YES'
4079            ISBLSW='OFF'
4080            WRITE(ICOUT,22126)
408122126       FORMAT('FOR THE  CAPTURE STATISTIC BLOCK  COMMAND, NO ',
4082     1            'NAME WAS SPECIFIED.')
4083            CALL DPWRST('XXX','BUG ')
4084            GOTO9000
4085          ENDIF
4086C
4087C         NEXT, RETRIEVE THE NAME OF THE PARAMETER THAT WILL
4088C         CONTAIN THE RESPONSE (I.E., THE CALLING ROUTINE WILL EXTRACT
4089C         THE VALUE OF THIS PARAMETER AFTER EXECUTING THE
4090C         STATISTIC BLOCK).
4091C
4092          IF(NUMARG.GE.5)THEN
4093            IF(ISBLSW.EQ.'1')THEN
4094              ISBAN1(1:4)=IHARG(5)
4095              ISBAN1(5:8)=IHARG2(5)
4096            ELSEIF(ISBLSW.EQ.'2')THEN
4097              ISBAN2(1:4)=IHARG(5)
4098              ISBAN2(5:8)=IHARG2(5)
4099            ELSEIF(ISBLSW.EQ.'3')THEN
4100              ISBAN3(1:4)=IHARG(5)
4101              ISBAN3(5:8)=IHARG2(5)
4102            ENDIF
4103          ELSE
4104            IERROR='YES'
4105            ISBLSW='OFF'
4106            WRITE(ICOUT,22127)
410722127       FORMAT('FOR THE  CAPTURE STATISTIC BLOCK  COMMAND, NO ',
4108     1            'RESPONSE PARAMETER WAS SPECIFIED.')
4109            CALL DPWRST('XXX','BUG ')
4110            GOTO9000
4111          ENDIF
4112C
4113C         THE REMAINING ARGUMENTS ARE THE PARAMETERS NEEDED BY THE
4114C         STATISTIC BLOCK,
4115C
4116          IF(NUMARG.GE.6)THEN
4117            ICNT=0
4118            DO2180II=6,NUMARG
4119              ICNT=ICNT+1
4120              IF(ICNT.LE.20)THEN
4121                IF(ISBLSW.EQ.'1')THEN
4122                  ISBPL1(ICNT)(1:4)=IHARG(II)
4123                  ISBPL1(ICNT)(5:8)=IHARG2(II)
4124                  ISBCP1=ICNT
4125                ELSEIF(ISBLSW.EQ.'2')THEN
4126                  ISBPL2(ICNT)(1:4)=IHARG(II)
4127                  ISBPL2(ICNT)(5:8)=IHARG2(II)
4128                  ISBCP2=ICNT
4129                ELSEIF(ISBLSW.EQ.'3')THEN
4130                  ISBPL3(ICNT)(1:4)=IHARG(II)
4131                  ISBPL3(ICNT)(5:8)=IHARG2(II)
4132                  ISBCP3=ICNT
4133                ENDIF
4134              ENDIF
4135 2180       CONTINUE
4136            ISBCP1=MIN(ICNT,MAXSBP)
4137            ISBCP2=MIN(ICNT,MAXSBP)
4138            ISBCP3=MIN(ICNT,MAXSBP)
4139          ELSE
4140            IERROR='YES'
4141            ISBLSW='OFF'
4142            WRITE(ICOUT,22236)
414322236       FORMAT('FOR THE  CAPTURE STATISTIC BLOCK  COMMAND, NO ',
4144     1            'PARAMETER LIST WAS SPECIFIED.')
4145            CALL DPWRST('XXX','BUG ')
4146            GOTO9000
4147          ENDIF
4148C
4149          GOTO9000
4150        ENDIF
4151C
4152        IF(NUMARG.GE.1 .AND. IHARG(1).EQ.'SCRE')THEN
4153          ICAPSC='ON'
4154          IF(NUMARG.GE.2 .AND.
4155     1      (IHARG(2).EQ.'OFF ' .OR. IHARG(2).EQ.'END ' .OR.
4156     1       IHARG(2).EQ.'NO  ' .OR. IHARG(2).EQ.'NONE' .OR.
4157     1       IHARG(2).EQ.'CLOS'))ICAPSC='OFF '
4158          WRITE(ICOUT,999)
4159          CALL DPWRST('XXX','BUG ')
4160          IF(IFEEDB.EQ.'ON')THEN
4161            IF(ICAPSC.EQ.'ON')THEN
4162              WRITE(ICOUT,2111)
4163 2111         FORMAT('CAPTURE OUTPUT WILL BE WRITTEN TO BOTH THE ',
4164     1               'CAPTURE FILE AND THE SCREEN.')
4165            ELSE
4166              WRITE(ICOUT,2113)
4167 2113         FORMAT('CAPTURE OUTPUT WILL BE WRITTEN TO THE ',
4168     1              'CAPTURE FILE ONLY.')
4169            ENDIF
4170            CALL DPWRST('XXX','BUG ')
4171          ENDIF
4172          GOTO9000
4173        ENDIF
4174        GOTO3000
4175      ELSEIF(ICOM.EQ.'END '.AND.ICOM2.EQ.'    ')THEN
4176        IF(NUMARG.GE.1 .AND.
4177     1    (IHARG(1).EQ.'CAPT' .OR. IHARG(1).EQ.'REDI' .OR.
4178     1     IHARG(1).EQ.'DIVE' .OR. IHARG(1).EQ.'PIPE'))GOTO4000
4179        IF(NUMARG.GE.1 .AND. IHARG(1).EQ.'OF  ' .AND.
4180     1    (IHARG(1).EQ.'CAPT' .OR. IHARG(1).EQ.'REDI' .OR.
4181     1     IHARG(1).EQ.'DIVE' .OR. IHARG(1).EQ.'PIPE'))GOTO4000
4182      ENDIF
4183C
4184      IERROR='YES'
4185      WRITE(ICOUT,999)
4186      CALL DPWRST('XXX','BUG ')
4187      WRITE(ICOUT,1411)
4188      CALL DPWRST('XXX','BUG ')
4189      WRITE(ICOUT,1412)
4190      CALL DPWRST('XXX','BUG ')
4191      WRITE(ICOUT,2914)
4192 2914 FORMAT('      SPECIFIED OPERATION WAS ILLEGAL.  ILLUSTRATIVE')
4193      CALL DPWRST('XXX','BUG ')
4194      WRITE(ICOUT,2915)
4195 2915 FORMAT('      EXAMPLE TO DEMONSTRATE THE PROPER FORMS--')
4196      CALL DPWRST('XXX','BUG ')
4197      WRITE(ICOUT,2917)
4198 2917 FORMAT('         CAPTURE TEMP1.')
4199      CALL DPWRST('XXX','BUG ')
4200      WRITE(ICOUT,2918)
4201 2918 FORMAT('         END OF CAPTURE')
4202      CALL DPWRST('XXX','BUG ')
4203      GOTO9000
4204C
4205C               ********************************************************
4206C               **  STEP 30--                                         **
4207C               **  TREAT THE CAPTURE CASE.                           **
4208C               **  CARRY OUT WHATEVER SYSTEM OPERATIONS ARE NEEDED   **
4209C               **  IN ORDER TO OPERATE ON THE FILE OR SUBFILE.       **
4210C               **  FOR MOST INSTALLATIONS, THIS REQUIRES             **
4211C               **      1) AN OPENING OF THE FILE OR SUBFILE;         **
4212C               **      2) AN EQUIVALENCING OF THE FILE OR SUBFILE;   **
4213C               **      3) A  REWINDING OF THE FILE OR SUBFILE.       **
4214C               **  THE CODE BELOW OPENS THE FILE OR SUBFILE          **
4215C               **  (VIA @ASG,AX ON THE UNIVAC 1108).  THE CODE ALSO  **
4216C               **  EQUIVALENCES THE FILES OR SUBFILES (VIA @USE O    **
4217C               **  UNIVAC 1108) TO THE FORTRAN LOGICAL UNIT NUMBER   **
4218C               **  DESIGNATION IN THE VARIABLE ICAPNU (IN THE        **
4219C               **  SUBROUINTE INITFO);  THE CODE ALSO REWINDS THE    **
4220C               **  FILE OR SUBFILE. (VIA @REWIND ON THE UNIVAC 1108).**
4221C               ********************************************************
4222C
4223 3000 CONTINUE
4224      ISTEPN='30'
4225      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT')
4226     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4227C
4228      ICAPSW='ON'
4229      IOUNIT=ICAPNU
4230C
4231      ICAPNA=IFILE
4232C
4233      IREWIN='ON'
4234      CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
4235     1IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
4236      IF(IERRFI.EQ.'YES')GOTO9000
4237      ICAPCS=ICURST
4238C
4239C     2015/12: IF "SET CAPTURE SPLIT ON" IS GIVEN, OPEN A SECONDARY
4240C              CAPTURE FILE WITH "_1" APPENDED TO FILE NAME (BEFORE THE
4241C              ".").
4242C
4243      IF(ICAPSP.EQ.'ON')THEN
4244        ICAPCN=1
4245        ICAPN2=' '
4246        ICAPN2(1:80)=ICAPNA(1:80)
4247        ILAST=80
4248        IPEROD=-1
4249        DO3001JJ=80,1,-1
4250          IF(ICAPN2(JJ:JJ).NE.' ')THEN
4251            ILAST=JJ
4252            GOTO3002
4253          ENDIF
4254 3001   CONTINUE
4255 3002   CONTINUE
4256C
4257        DO3006JJ=80,1,-1
4258          IF(ICAPN2(JJ:JJ).EQ.'.')THEN
4259            IPEROD=JJ
4260            GOTO3007
4261          ENDIF
4262 3006   CONTINUE
4263 3007   CONTINUE
4264C
4265        IF(IPEROD.LE.0)THEN
4266          ILAST=ILAST+1
4267          ICAPN2(ILAST:ILAST+1)='.1'
4268        ELSE
4269          DO3008JJ=ILAST,IPEROD,-1
4270            ICAPN2(JJ+2:JJ+2)=ICAPN2(JJ:JJ)
4271 3008     CONTINUE
4272          ICAPN2(IPEROD:IPEROD+1)='_1'
4273        ENDIF
4274        IREWIN='ON'
4275        OPEN(ICPNU2,FILE=ICAPN2,STATUS="UNKNOWN",ACTION="WRITE")
4276        IF(IERRFI.EQ.'YES')GOTO9000
4277      ENDIF
4278C
4279      IF(IFEEDB.EQ.'ON')THEN
4280        IF(ICAPTY.EQ.'RTF ')IRTFMD='OFF'
4281        WRITE(ICOUT,999)
4282        CALL DPWRST('XXX','BUG ')
4283        WRITE(ICOUT,3011)
4284 3011   FORMAT('THE CAPTURE SWITCH HAS JUST BEEN TURNED ON.')
4285        CALL DPWRST('XXX','BUG ')
4286        WRITE(ICOUT,3012)ICAPNA
4287 3012   FORMAT('NAME OF CAPTURE FILE = ',A80)
4288        CALL DPWRST('XXX','BUG ')
4289        WRITE(ICOUT,3013)
4290 3013   FORMAT('ALL SUBSEQUENT TEXT OUTPUT FROM ANY DATAPLOT')
4291        CALL DPWRST('XXX','BUG ')
4292        WRITE(ICOUT,3014)
4293 3014   FORMAT('COMMAND WILL BE CAPTURED/REDIRECTED INTO THIS FILE.')
4294        CALL DPWRST('XXX','BUG ')
4295        WRITE(ICOUT,3015)
4296 3015   FORMAT('ONLY TEXT OUTPUT IS CAPTURED--NOT GRAPHICS OUTPUT.')
4297        CALL DPWRST('XXX','BUG ')
4298        WRITE(ICOUT,3016)
4299 3016   FORMAT('THE CAPTURED INFO WILL OVERWRITE THE PREVIOUS')
4300        CALL DPWRST('XXX','BUG ')
4301        WRITE(ICOUT,3017)
4302 3017   FORMAT('CONTENTS OF THE SPECIFIED FILE.')
4303        CALL DPWRST('XXX','BUG ')
4304        WRITE(ICOUT,3018)
4305 3018   FORMAT('THE TEXT CAPTURING WILL CONTINUE UNTIL YOU ENTER')
4306        CALL DPWRST('XXX','BUG ')
4307        WRITE(ICOUT,3019)
4308 3019   FORMAT('THE COMMAND        END OF CAPTURE')
4309        CALL DPWRST('XXX','BUG ')
4310        IF(ICAPTY.EQ.'RTF ')IRTFMD='VERB'
4311      ENDIF
4312C
4313      IPR=ICAPNU
4314C
4315CCCCC JUNE 2002.  SPECIAL CASE OF GRAPHICS, LATEK, HTML, RTF OR SCRIPT.
4316CCCCC ADD ANY SPECIAL NEEDED INITIALIZATION CODE HERE.
4317C
4318CCCCC JANUARY 2003.  SET HTML HEADER FILE CAN BE USED TO SPECIFY A
4319CCCCC A FILE TO INCORPORATE THE HEADER FILE.
4320C
4321CCCCC DECEMBER 2015.  ADD OPTION "NONE" THAT SPECIFIES THAT NO HEADER
4322CCCCC IS GENERATED.  THIS IS SLIGHTLY DISTINCT FROM "NULL" WHICH
4323CCCCC GENERATES A MINIMAL HEADER.  THE "NONE" OPTION IS INTENDED FOR
4324CCCCC THE CASE WHERE YOU WANT TO INCORPORATE THE HTML CODE INTO A
4325CCCCC LARGER DISTINCT DOCUMENT.
4326C
4327      IF(ICAPTY.EQ.'HTML')THEN
4328        IFNTSZ=0
4329        IF(IHTMHE.EQ.'NONE')THEN
4330          CONTINUE
4331        ELSEIF(IHTMHE.EQ.'NULL')THEN
4332          WRITE(ICOUT,3071)
4333 3071     FORMAT('<HTML>')
4334          CALL DPWRST('XXX','WRIT')
4335          WRITE(ICOUT,3073)
4336 3073     FORMAT('<HEAD>')
4337          CALL DPWRST('XXX','WRIT')
4338          WRITE(ICOUT,3075)
4339 3075     FORMAT('<TITLE>')
4340          CALL DPWRST('XXX','WRIT')
4341          WRITE(ICOUT,3077)
4342 3077     FORMAT('Dataplot Output')
4343          CALL DPWRST('XXX','WRIT')
4344          WRITE(ICOUT,3079)
4345 3079     FORMAT('</TITLE>')
4346          CALL DPWRST('XXX','WRIT')
4347          WRITE(ICOUT,3081)
4348 3081     FORMAT('<META HTTP-EQUIV="Content-Type" CONTENT="text/html;',
4349     1           ' charset=iso-8859-1">')
4350          CALL DPWRST('XXX','WRIT')
4351          WRITE(ICOUT,3083)
4352 3083     FORMAT('</HEAD>')
4353          CALL DPWRST('XXX','WRIT')
4354          WRITE(ICOUT,3085)
4355 3085     FORMAT('<BODY BGCOLOR=#FFFFFF>')
4356          CALL DPWRST('XXX','WRIT')
4357        ELSE
4358          IOUNI2=IST1NU
4359          IFILE2=IHTMHE
4360          ISTAT2='OLD'
4361          IFORM2='FORMATTED'
4362          IACCE2='SEQUENTIAL'
4363          IPROT2='READONLY'
4364          ICURS2='CLOSED'
4365          ISUBN0='CAPT'
4366          IERRF2='NO'
4367C
4368          IREWI2='ON'
4369          CALL DPOPFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2,
4370     1                IREWI2,ISUBN0,IERRF2,IBUGS2,ISUBRO,IERROR)
4371          IF(IERRF2.EQ.'YES')GOTO9000
4372C
4373C  NOW LOOP THROUGH FILE (ASSUME MAXIMUM OF 1,000 LINES).
4374C
4375          DO3091I=1,1000
4376            IATEMP=' '
4377            READ(IOUNI2,3092,END=3099,ERR=3099)IATEMP
4378 3092       FORMAT(A240)
4379            ILAST=1
4380            DO3096J=240,1,-1
4381              IF(IATEMP(J:J).NE.' ')THEN
4382                ILAST=J
4383                GOTO3098
4384              ENDIF
4385 3096       CONTINUE
4386 3098       CONTINUE
4387            WRITE(ICOUT,3094)(IATEMP(J:J),J=1,ILAST)
4388            NCOUT=ILAST
4389 3094       FORMAT(240A1)
4390            CALL DPWRST('XXX','WRIT')
4391 3091     CONTINUE
4392 3099     CONTINUE
4393          IENDF2='OFF'
4394          IREWI2='ON'
4395          CALL DPCLFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2,
4396     1                IENDF2,IREWI2,ISUBN0,IERRF2,IBUGS2,ISUBRO,IERROR)
4397          IF(IERRF2.EQ.'YES')GOTO9000
4398        ENDIF
4399        WRITE(ICOUT,3087)
4400 3087   FORMAT('<PRE>')
4401        CALL DPWRST('XXX','WRIT')
4402      ELSEIF(ICAPTY.EQ.'LATE')THEN
4403C
4404CCCCC DECEMBER 2015.  ADD OPTION "NONE" THAT SPECIFIES THAT NO HEADER
4405CCCCC IS GENERATED.  THIS IS SLIGHTLY DISTINCT FROM "NULL" WHICH
4406CCCCC GENERATES A MINIMAL HEADER.  THE "NONE" OPTION IS INTENDED FOR
4407CCCCC THE CASE WHERE YOU WANT TO INCORPORATE THE LATEX CODE INTO A
4408CCCCC LARGER DISTINCT DOCUMENT.
4409C
4410        IF(ILATHE.EQ.'NONE')THEN
4411          CONTINUE
4412        ELSEIF(ILATHE.EQ.'NULL')THEN
4413          IF(ILATPS.EQ.12)THEN
4414            WRITE(ICOUT,3171)IBASLC
4415 3171       FORMAT(A1,'documentclass[12pt]{article}')
4416            CALL DPWRST('XXX','WRIT')
4417          ELSE
4418            IF(ILATPS.GE.10)THEN
4419              WRITE(ICOUT,3172)IBASLC,ILATPS
4420 3172         FORMAT(A1,'documentclass[',I2,'pt]{article}')
4421              CALL DPWRST('XXX','WRIT')
4422            ELSE
4423              WRITE(ICOUT,33172)IBASLC,ILATPS
442433172         FORMAT(A1,'documentclass[',I1,'pt]{article}')
4425              CALL DPWRST('XXX','WRIT')
4426            ENDIF
4427          ENDIF
4428          WRITE(ICOUT,999)
4429          CALL DPWRST('XXX','WRIT')
4430          WRITE(ICOUT,3173)IBASLC
4431 3173     FORMAT(A1,'usepackage{epsfig}')
4432          CALL DPWRST('XXX','WRIT')
4433          WRITE(ICOUT,3174)IBASLC
4434 3174     FORMAT(A1,'usepackage{epic,eepic}')
4435          CALL DPWRST('XXX','WRIT')
4436          WRITE(ICOUT,3175)IBASLC
4437 3175     FORMAT(A1,'usepackage{graphics,color}')
4438          CALL DPWRST('XXX','WRIT')
4439          WRITE(ICOUT,999)
4440          CALL DPWRST('XXX','WRIT')
4441          WRITE(ICOUT,13171)IBASLC,IBASLC
444213171     FORMAT(A1,'setlength{',A1,'textwidth}{6.25in}')
4443          CALL DPWRST('XXX','WRIT')
4444          WRITE(ICOUT,13172)IBASLC,IBASLC
444513172     FORMAT(A1,'setlength{',A1,'textheight}{9in}')
4446          CALL DPWRST('XXX','WRIT')
4447          WRITE(ICOUT,13173)IBASLC,IBASLC
444813173     FORMAT(A1,'setlength{',A1,'oddsidemargin}{0.25in}')
4449          CALL DPWRST('XXX','WRIT')
4450          WRITE(ICOUT,13174)IBASLC,IBASLC
445113174     FORMAT(A1,'setlength{',A1,'evensidemargin}{0in}')
4452          CALL DPWRST('XXX','WRIT')
4453          WRITE(ICOUT,13175)IBASLC,IBASLC
445413175     FORMAT(A1,'setlength{',A1,'headheight}{0.5in}')
4455          CALL DPWRST('XXX','WRIT')
4456          WRITE(ICOUT,13176)IBASLC,IBASLC
445713176     FORMAT(A1,'setlength{',A1,'headsep}{0.5in}')
4458          CALL DPWRST('XXX','WRIT')
4459          WRITE(ICOUT,13177)IBASLC,IBASLC
446013177     FORMAT(A1,'setlength{',A1,'topmargin}{-1in}')
4461          CALL DPWRST('XXX','WRIT')
4462          WRITE(ICOUT,13178)IBASLC,IBASLC
446313178     FORMAT(A1,'setlength{',A1,'parindent}{0in}')
4464          CALL DPWRST('XXX','WRIT')
4465          WRITE(ICOUT,13179)IBASLC,IBASLC
446613179     FORMAT(A1,'setlength{',A1,'parskip}{10pt}')
4467          CALL DPWRST('XXX','WRIT')
4468          WRITE(ICOUT,13180)IBASLC,IBASLC
446913180     FORMAT(A1,'setlength{',A1,'textfloatsep}{4ex}')
4470          CALL DPWRST('XXX','WRIT')
4471          WRITE(ICOUT,13181)IBASLC,IBASLC
447213181     FORMAT(A1,'addtolength{',A1,'footskip}{0.25in}')
4473          CALL DPWRST('XXX','WRIT')
4474          WRITE(ICOUT,13182)IBASLC
447513182     FORMAT(A1,'overfullrule=0pt')
4476          CALL DPWRST('XXX','WRIT')
4477          WRITE(ICOUT,13183)IBASLC
447813183     FORMAT(A1,'baselineskip=12pt')
4479          CALL DPWRST('XXX','WRIT')
4480          WRITE(ICOUT,999)
4481          CALL DPWRST('XXX','WRIT')
4482          WRITE(ICOUT,3181)IBASLC,IBASLC,IBASLC
4483 3181     FORMAT(A1,'newcommand{',A1,'PGRAPHIC}[1]{',A1,'begin{figure}',
4484     1           '[h]')
4485          CALL DPWRST('XXX','WRIT')
4486          WRITE(ICOUT,3182)IBASLC
4487 3182     FORMAT(23X,A1,'epsfig{file=#1,width=6.0in}')
4488          CALL DPWRST('XXX','WRIT')
4489          WRITE(ICOUT,3183)IBASLC
4490 3183     FORMAT(23X,A1,'end{figure}}')
4491          CALL DPWRST('XXX','WRIT')
4492          WRITE(ICOUT,3186)IBASLC,IBASLC,IBASLC
4493 3186     FORMAT(A1,'newcommand{',A1,'LGRAPHIC}[1]{',A1,'begin{figure}',
4494     1           '[h]')
4495          CALL DPWRST('XXX','WRIT')
4496          WRITE(ICOUT,3187)IBASLC
4497 3187     FORMAT(23X,A1,'epsfig{file=#1,angle=-90,width=6.0in}')
4498          CALL DPWRST('XXX','WRIT')
4499          WRITE(ICOUT,3188)IBASLC
4500 3188     FORMAT(23X,A1,'end{figure}}')
4501          CALL DPWRST('XXX','WRIT')
4502          WRITE(ICOUT,999)
4503          CALL DPWRST('XXX','WRIT')
4504          WRITE(ICOUT,3191)IBASLC
4505 3191     FORMAT(A1,'begin{document}')
4506          CALL DPWRST('XXX','WRIT')
4507          WRITE(ICOUT,999)
4508          CALL DPWRST('XXX','WRIT')
4509          WRITE(ICOUT,3197)IBASLC
4510 3197     FORMAT(A1,'begin{verbatim}')
4511          CALL DPWRST('XXX','WRIT')
4512          WRITE(ICOUT,999)
4513          CALL DPWRST('XXX','WRIT')
4514        ELSE
4515          IOUNI2=IST1NU
4516          IFILE2=ILATHE
4517          ISTAT2='OLD'
4518          IFORM2='FORMATTED'
4519          IACCE2='SEQUENTIAL'
4520          IPROT2='READONLY'
4521          ICURS2='CLOSED'
4522          ISUBN0='CAPT'
4523          IERRF2='NO'
4524C
4525          IREWI2='ON'
4526          CALL DPOPFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2,
4527     1                IREWI2,ISUBN0,IERRF2,IBUGS2,ISUBRO,IERROR)
4528          IF(IERRF2.EQ.'YES')GOTO9000
4529C
4530C  NOW LOOP THROUGH FILE (ASSUME MAXIMUM OF 1,000 LINES).
4531C
4532          DO3291I=1,1000
4533            IATEMP=' '
4534            READ(IOUNI2,3292,END=3299,ERR=3299)IATEMP
4535 3292       FORMAT(A240)
4536            ILAST=1
4537            DO3296J=240,1,-1
4538              IF(IATEMP(J:J).NE.' ')THEN
4539                ILAST=J
4540                GOTO3298
4541              ENDIF
4542 3296       CONTINUE
4543 3298       CONTINUE
4544            WRITE(ICOUT,3294)(IATEMP(J:J),J=1,ILAST)
4545            NCOUT=ILAST
4546 3294       FORMAT(240A1)
4547            CALL DPWRST('WRIT','BUG ')
4548 3291     CONTINUE
4549 3299     CONTINUE
4550          IENDF2='OFF'
4551          IREWI2='ON'
4552          CALL DPCLFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2,
4553     1                IENDF2,IREWI2,ISUBN0,IERRF2,IBUGS2,ISUBRO,IERROR)
4554          IF(IERRF2.EQ.'YES')GOTO9000
4555          WRITE(ICOUT,3197)IBASLC
4556          CALL DPWRST('XXX','WRIT')
4557        ENDIF
4558      ELSEIF(ICAPTY.EQ.'RTF ')THEN
4559        IRTFMD='OFF'
4560CCCCC   IF(IRTFHE.EQ.'NULL')THEN
4561          WRITE(ICOUT,3351)IBASLC,IBASLC,IBASLC
4562 3351     FORMAT('{',A1,'rtf1',A1,'ansi',A1,'deff0')
4563          CALL DPWRST('XXX','WRIT')
4564          WRITE(ICOUT,3361)IBASLC
4565 3361     FORMAT('{',A1,'fonttbl')
4566          CALL DPWRST('XXX','WRIT')
4567          WRITE(ICOUT,3363)IBASLC,IBASLC
4568 3363     FORMAT('{',A1,'f0',A1,'froman Times New Roman;}')
4569          CALL DPWRST('XXX','WRIT')
4570          WRITE(ICOUT,3367)IBASLC,IBASLC
4571 3367     FORMAT('{',A1,'f1',A1,'fmodern Courier New;}')
4572          CALL DPWRST('XXX','WRIT')
4573          WRITE(ICOUT,3369)IBASLC,IBASLC
4574 3369     FORMAT('{',A1,'f2',A1,'froman Arial;}')
4575          CALL DPWRST('XXX','WRIT')
4576          WRITE(ICOUT,3371)IBASLC,IBASLC
4577 3371     FORMAT('{',A1,'f3',A1,'froman Bookman;}')
4578          CALL DPWRST('XXX','WRIT')
4579          WRITE(ICOUT,3373)IBASLC,IBASLC
4580 3373     FORMAT('{',A1,'f4',A1,'froman Georgia;}')
4581          CALL DPWRST('XXX','WRIT')
4582          WRITE(ICOUT,3375)IBASLC,IBASLC
4583 3375     FORMAT('{',A1,'f5',A1,'fswiss Tahoma;}')
4584          CALL DPWRST('XXX','WRIT')
4585          WRITE(ICOUT,3376)IBASLC,IBASLC
4586 3376     FORMAT('{',A1,'f6',A1,'fswiss Lucida Sans;}')
4587          CALL DPWRST('XXX','WRIT')
4588          WRITE(ICOUT,3377)IBASLC,IBASLC
4589 3377     FORMAT('{',A1,'f7',A1,'fswiss Verdana;}')
4590          CALL DPWRST('XXX','WRIT')
4591          WRITE(ICOUT,3378)IBASLC,IBASLC
4592 3378     FORMAT('{',A1,'f8',A1,'fmodern Lucida Console;}')
4593          CALL DPWRST('XXX','WRIT')
4594          WRITE(ICOUT,3379)
4595 3379     FORMAT('}')
4596          CALL DPWRST('XXX','WRIT')
4597C
4598          WRITE(ICOUT,3384)IBASLC
4599 3384     FORMAT('{',A1,'info')
4600          CALL DPWRST('XXX','WRIT')
4601          WRITE(ICOUT,3385)IBASLC
4602 3385     FORMAT('{',A1,'title Dataplot RTF Document}')
4603          CALL DPWRST('XXX','WRIT')
4604          WRITE(ICOUT,3386)IBASLC
4605 3386     FORMAT('{',A1,'author Alan Heckert}')
4606          CALL DPWRST('XXX','WRIT')
4607          WRITE(ICOUT,3387)IBASLC
4608 3387     FORMAT('{',A1,'company Statistical Engineering Division, ',
4609     1           'NIST}')
4610          CALL DPWRST('XXX','WRIT')
4611          WRITE(ICOUT,3379)
4612          CALL DPWRST('XXX','WRIT')
4613C
4614CCCCC     IPTSZ=2*IRTFPS
4615          IPTSZ=IRTFPS
4616          IF(IPTSZ.LT.0 .OR. IPTSZ.GT.99)IPTSZ=20
4617          ITEMP='0'
4618          IF(IRTFFP.EQ.'Arial')ITEMP='2'
4619          IF(IRTFFP.EQ.'Bookman')ITEMP='3'
4620          IF(IRTFFP.EQ.'Georgia')ITEMP='4'
4621          IF(IRTFFP.EQ.'Tahoma')ITEMP='5'
4622          IF(IRTFFP.EQ.'Lucida Sans')ITEMP='6'
4623          IF(IRTFFP.EQ.'Verdana')ITEMP='7'
4624          IF(IPTSZ.LE.9)THEN
4625            WRITE(ICOUT,3381)IBASLC,IBASLC,IBASLC,IBASLC,ITEMP,
4626     1                       IBASLC,IPTSZ
4627 3381       FORMAT(A1,'delang1033',A1,'widowctrl',A1,'plain',
4628     1             A1,'f',A1,A1,'fs',I1)
4629          ELSE
4630            WRITE(ICOUT,3382)IBASLC,IBASLC,IBASLC,IBASLC,ITEMP,
4631     1                       IBASLC,IPTSZ
4632 3382       FORMAT(A1,'delang1033',A1,'widowctrl',A1,'plain',
4633     1             A1,'f',A1,A1,'fs',I2)
4634          ENDIF
4635          CALL DPWRST('XXX','WRIT')
4636C
4637          WRITE(ICOUT,3389)IBASLC
4638 3389     FORMAT('{',A1,'pard')
4639          CALL DPWRST('XXX','WRIT')
4640          IRTFMD='VERB'
4641CCCCC   ELSE
4642CCCCC   ENDIF
4643      ELSEIF(ICAPTY.EQ.'SCRI')THEN
4644        CONTINUE
4645      ENDIF
4646C
4647      GOTO9000
4648C
4649C               ******************************************************
4650C               **  STEP 38--                                       **
4651C               **  TREAT THE CAPTURE SUSPEND CASE.                 **
4652C               **  RESET OUTPUT UNIT TO IPR, BUT DO NOT CLOSE      **
4653C               **  THE CAPTURE FILE.                               **
4654C               ******************************************************
4655C
4656 3800 CONTINUE
4657      ISTEPN='38'
4658      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT')
4659     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4660C
4661      IF(ICAPSW.EQ.'OFF')THEN
4662        WRITE(ICOUT,999)
4663        CALL DPWRST('XXX','BUG ')
4664        WRITE(ICOUT,3811)
4665 3811   FORMAT('****** WARNING: THE CAPTURE SWITCH IS CURRENTLY OFF.')
4666        CALL DPWRST('XXX','BUG ')
4667        WRITE(ICOUT,3813)
4668 3813   FORMAT('       CAPTURE SUSPEND COMMAND IGNORED.')
4669        CALL DPWRST('XXX','BUG ')
4670        GOTO9000
4671      ENDIF
4672C
4673      ICAPSW='OFF'
4674      IOUNIT=ICAPNU
4675      IPR=IPRDEF
4676C
4677      GOTO9000
4678C
4679C               ******************************************************
4680C               **  STEP 39--                                       **
4681C               **  TREAT THE CAPTURE RESUME  CASE.                 **
4682C               **  RESET OUTPUT UNIT TO CAPTURE UNIT, BUT DO NOT   **
4683C               **  REOPEN THE CAPTURE FILE.                        **
4684C               ******************************************************
4685C
4686 3900 CONTINUE
4687      ISTEPN='39'
4688      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT')
4689     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4690C
4691      IF(ICAPSW.EQ.'ON')THEN
4692        WRITE(ICOUT,999)
4693        CALL DPWRST('XXX','BUG ')
4694        WRITE(ICOUT,3911)
4695 3911   FORMAT('****** WARNING: THE CAPTURE SWITCH IS CURRENTLY ON.')
4696        CALL DPWRST('XXX','BUG ')
4697        WRITE(ICOUT,3913)
4698 3913   FORMAT('       CAPTURE RESUME COMMAND IGNORED.')
4699        CALL DPWRST('XXX','BUG ')
4700        GOTO9000
4701      ENDIF
4702C
4703      ICAPSW='ON'
4704      IPR=ICAPNU
4705C
4706      GOTO9000
4707C
4708C               **********************************************************
4709C               **  STEP 40--                                           **
4710C               **  TREAT THE END OF CAPTURE CASE.  CARRY OUT WHATEVER  **
4711C               **  SYSTEM OPERATIONS ARE NEEDED IN ORDER TO OPERATE    **
4712C               **  ON THE FILE OR SUBFILE. FOR MOST INSTALLATIONS,     **
4713C               **  THIS REQUIRES                                       **
4714C               **      1) A PLACING OF AN END MARK OF THE FILE OR      **
4715C               **         SUBFILE;                                     **
4716C               **      2) A FREEING (DEASSIGNING) OF THE FILE OR       **
4717C               **         SUBFILE;                                     **
4718C               **********************************************************
4719C
4720 4000 CONTINUE
4721      ISTEPN='40'
4722      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT')
4723     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4724C
4725      ICAPSW='OFF'
4726C
4727      IF(IFBLSW.NE.'OFF')THEN
4728        ICAPTY='TEXT'
4729        IFBLSW='OFF'
4730        GOTO4090
4731      ENDIF
4732C
4733      IF(ISBLSW.NE.'OFF')THEN
4734        ICAPTY='TEXT'
4735        ISBLSW='OFF'
4736        GOTO4090
4737      ENDIF
4738C
4739CCCCC JUNE 2002.  SPECIAL CASE OF GRAPHICS, LATEK, OR HTML.  ADD
4740CCCCC ANY SPECIAL NEED TERMINATION CODE HERE.
4741C
4742CCCCC DECEMBER 2015.  FOR HTML AND LATEX, ADD "NONE" OPTION FOR FOOTER.
4743CCCCC THIS IS DISTINCT FROM "NULL" WHICH ADDS A MINIMAL FOOTER.  THE
4744CCCCC "NONE" OPTION IS INTENDED FOR THE CASE WHERE THE HTML OR LATEX
4745CCCCC CODE IS TO BE INCORPORATED INTO A LARGER HTML OR LATEX DOCUMENT.
4746C
4747      IF(ICAPTY.EQ.'HTML')THEN
4748        WRITE(ICOUT,4110)
4749 4110   FORMAT('</PRE>')
4750        CALL DPWRST('XXX','WRIT')
4751        IF(IHTMFO.EQ.'NONE')THEN
4752          CONTINUE
4753        ELSEIF(IHTMFO.EQ.'NULL')THEN
4754          WRITE(ICOUT,4112)
4755 4112     FORMAT('</BODY>')
4756          CALL DPWRST('XXX','WRIT')
4757          WRITE(ICOUT,4114)
4758 4114     FORMAT('</HTML>')
4759          CALL DPWRST('XXX','WRIT')
4760        ELSE
4761          IOUNI2=IST1NU
4762          IFILE2=IHTMFO
4763          ISTAT2='OLD'
4764          IFORM2='FORMATTED'
4765          IACCE2='SEQUENTIAL'
4766          IPROT2='READONLY'
4767          ICURS2='CLOSED'
4768          ISUBN0='CAPT'
4769          IERRF2='NO'
4770C
4771          IREWI2='ON'
4772          CALL DPOPFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2,
4773     1                IREWI2,ISUBN0,IERRF2,IBUGS2,ISUBRO,IERROR)
4774          IF(IERRF2.EQ.'YES')GOTO9000
4775C
4776C  NOW LOOP THROUGH FILE (ASSUME MAXIMUM OF 1,000 LINES).
4777C
4778          DO4121I=1,1000
4779            IATEMP=' '
4780            READ(IOUNI2,4122,END=4129,ERR=4129)IATEMP
4781 4122       FORMAT(A240)
4782            ILAST=1
4783            DO4126J=240,1,-1
4784              IF(IATEMP(J:J).NE.' ')THEN
4785                ILAST=J
4786                GOTO4128
4787              ENDIF
4788 4126       CONTINUE
4789 4128       CONTINUE
4790            WRITE(ICOUT,4124)(IATEMP(J:J),J=1,ILAST)
4791            NCOUT=ILAST
4792 4124       FORMAT(240A1)
4793            CALL DPWRST('XXX','WRIT')
4794 4121     CONTINUE
4795 4129     CONTINUE
4796          IENDF2='OFF'
4797          IREWI2='ON'
4798          CALL DPCLFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2,
4799     1                IENDF2,IREWI2,ISUBN0,IERRF2,IBUGS2,ISUBRO,IERROR)
4800          IF(IERRF2.EQ.'YES')GOTO9000
4801        ENDIF
4802      ELSEIF(ICAPTY.EQ.'LATE')THEN
4803        WRITE(ICOUT,999)
4804        CALL DPWRST('XXX','WRIT')
4805        WRITE(ICOUT,4208)IBASLC
4806 4208   FORMAT(A1,'end{verbatim}')
4807        CALL DPWRST('XXX','WRIT')
4808        IF(ILATFO.EQ.'NONE')THEN
4809          CONTINUE
4810        ELSEIF(ILATFO.EQ.'NULL')THEN
4811          WRITE(ICOUT,999)
4812          CALL DPWRST('XXX','WRIT')
4813          WRITE(ICOUT,4210)IBASLC
4814 4210     FORMAT(A1,'end{document}')
4815          CALL DPWRST('XXX','WRIT')
4816        ELSE
4817          IOUNI2=IST1NU
4818          IFILE2=ILATFO
4819          ISTAT2='OLD'
4820          IFORM2='FORMATTED'
4821          IACCE2='SEQUENTIAL'
4822          IPROT2='READONLY'
4823          ICURS2='CLOSED'
4824          ISUBN0='CAPT'
4825          IERRF2='NO'
4826C
4827          IREWI2='ON'
4828          CALL DPOPFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2,
4829     1                IREWI2,ISUBN0,IERRF2,IBUGS2,ISUBRO,IERROR)
4830          IF(IERRF2.EQ.'YES')GOTO9000
4831C
4832C  NOW LOOP THROUGH FILE (ASSUME MAXIMUM OF 1,000 LINES).
4833C
4834          DO4221I=1,1000
4835            IATEMP=' '
4836            READ(IOUNI2,4222,END=4229,ERR=4229)IATEMP
4837 4222       FORMAT(A240)
4838            ILAST=1
4839            DO4226J=240,1,-1
4840              IF(IATEMP(J:J).NE.' ')THEN
4841                ILAST=J
4842                GOTO4228
4843              ENDIF
4844 4226       CONTINUE
4845 4228       CONTINUE
4846            WRITE(ICOUT,4224)(IATEMP(J:J),J=1,ILAST)
4847            NCOUT=ILAST
4848 4224       FORMAT(240A1)
4849            CALL DPWRST('XXX','WRIT')
4850 4221     CONTINUE
4851 4229     CONTINUE
4852          IENDF2='OFF'
4853          IREWI2='ON'
4854          CALL DPCLFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2,
4855     1                IENDF2,IREWI2,ISUBN0,IERRF2,IBUGS2,ISUBRO,IERROR)
4856          IF(IERRF2.EQ.'YES')GOTO9000
4857        ENDIF
4858      ELSEIF(ICAPTY.EQ.'RTF ')THEN
4859        IRTFMD='OFF'
4860        WRITE(ICOUT,4301)IBASLC
4861 4301   FORMAT(A1,'par}')
4862        CALL DPWRST('XXX','WRIT')
4863        WRITE(ICOUT,4303)
4864 4303   FORMAT('}')
4865        CALL DPWRST('XXX','WRIT')
4866      ENDIF
4867C
4868      ICAPTY='TEXT'
4869      IOUNIT=ICAPNU
4870      IPR=IPRDEF
4871C
4872      IENDFI='ON'
4873      IREWIN='ON'
4874      CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
4875     1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
4876      IF(IERRFI.EQ.'YES')GOTO9000
4877C
4878 4090 CONTINUE
4879      IF(IFEEDB.EQ.'ON')THEN
4880        IF(ICAPTY.EQ.'RTF ')IRTFMD='OFF'
4881        WRITE(ICOUT,999)
4882        CALL DPWRST('XXX','BUG ')
4883        WRITE(ICOUT,4011)
4884 4011   FORMAT('THE CAPTURE SWITCH HAS JUST BEEN TURNED OFF.')
4885        CALL DPWRST('XXX','BUG ')
4886        WRITE(ICOUT,4012)ICAPNA
4887 4012   FORMAT('NAME OF (JUST-CLOSED) CAPTURE FILE = ',A80)
4888        CALL DPWRST('XXX','BUG ')
4889        WRITE(ICOUT,4013)
4890 4013   FORMAT('ALL FUTURE TEXT OUTPUT WILL NOW REVERT TO ',
4891     1         'THE SCREEN.')
4892        CALL DPWRST('XXX','BUG ')
4893        IF(ICAPTY.EQ.'RTF ')IRTFMD='VERB'
4894      ENDIF
4895      GOTO9000
4896C
4897C               ****************************************************************
4898C               **  STEP 50--
4899C               **  TREAT THE CAPTURE FILE CLOSE CASE.
4900C               ****************************************************************
4901C
4902 5000 CONTINUE
4903      ISTEPN='50'
4904      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT')
4905     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4906C
4907CCCCC ICAPSW='OFF'
4908CCCCC JUNE 2002. SUPPORT FOR SPECIAL CAPTURE OPERATIONS.
4909CCCCC IF(ICAPTY.EQ.'GRAP')THEN
4910CCCCC   IPR=IPRDEF
4911      IF(ICAPTY.EQ.'HTML')THEN
4912        WRITE(ICOUT,999)
4913        CALL DPWRST('XXX','WRIT')
4914        WRITE(ICOUT,5111)
4915 5111   FORMAT('</PRE>')
4916        CALL DPWRST('XXX','WRIT')
4917        WRITE(ICOUT,5113)
4918 5113   FORMAT('</BODY>')
4919        CALL DPWRST('XXX','WRIT')
4920        WRITE(ICOUT,5115)
4921 5115   FORMAT('</HTML>')
4922        CALL DPWRST('XXX','WRIT')
4923      ELSEIF(ICAPTY.EQ.'LATE')THEN
4924        WRITE(ICOUT,999)
4925        CALL DPWRST('XXX','WRIT')
4926        WRITE(ICOUT,5208)IBASLC
4927 5208   FORMAT(A1,'end{verbatim}')
4928        CALL DPWRST('XXX','WRIT')
4929        WRITE(ICOUT,999)
4930        CALL DPWRST('XXX','WRIT')
4931        WRITE(ICOUT,5210)IBASLC
4932 5210   FORMAT(A1,'end{document}')
4933        CALL DPWRST('XXX','WRIT')
4934      ELSEIF(ICAPTY.EQ.'RTF ')THEN
4935        IRTFMD='OFF'
4936        WRITE(ICOUT,5301)IBASLC
4937 5301   FORMAT(A1,'par}')
4938        CALL DPWRST('XXX','WRIT')
4939        WRITE(ICOUT,5303)
4940 5303   FORMAT('}')
4941        CALL DPWRST('XXX','WRIT')
4942      ENDIF
4943C
4944      ICAPTY='TEXT'
4945      IOUNIT=ICAPNU
4946C
4947      IENDFI='OFF'
4948C     ***** DO WE NEED THE FOLLOWING REWIND ????? *****
4949      IREWIN='ON'
4950      CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
4951     1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
4952      IF(IERRFI.EQ.'YES')GOTO9000
4953C
4954      IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'CAPT')GOTO5019
4955      WRITE(ICOUT,999)
4956      CALL DPWRST('XXX','BUG ')
4957      WRITE(ICOUT,5011)ICAPNU
4958 5011 FORMAT('THE CAPTURE FILE NUMBER ',I8,' HAS JUST BEEN CLOSED')
4959      CALL DPWRST('XXX','BUG ')
4960      WRITE(ICOUT,5012)ICAPNA
4961 5012 FORMAT('NAME OF (JUST-CLOSED) CAPTURE FILE = ',A80)
4962      CALL DPWRST('XXX','BUG ')
4963 5019 CONTINUE
4964      GOTO9000
4965C
4966C     **********************************************************
4967C     **  STEP 60--                                           **
4968C     **  TREAT THE FLUSH  CAPTURE CASE.                      **
4969C     **      1) CLEAR GRAPHICS SCREEN (DPERAS)               **
4970C     **      2) CLOSE CAPTURE FILE (IF CURRENTLY OPEN)       **
4971C     **      3) OPEN THE CAPTURE FILE                        **
4972C     **      4) LOOP THROUGH THE FILE AND CALL DPWRSG        **
4973C     **      5) CLOSE THE CAPTURE FILE                       **
4974C     **      6) RE-OPEN THE CAPTURE FILE                     **
4975C     **********************************************************
4976C
4977 6000 CONTINUE
4978      ISTEPN='40'
4979      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT')
4980     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4981C
4982C
4983C  STEP 2: CLEAR THE GRAPHICS SCREEN
4984C          (SKIP IF MULTIPLOTTING ON)
4985C
4986      IF(IMPSW.NE.'ON' .AND. ICAPFE.EQ.'ON')THEN
4987        CALL DPERAS(IHARG,IARGT,IARG,NUMARG,
4988     1              IBACCO,IGRASW,IDIASW,
4989     1              PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
4990     1              PDIAHE,PDIAWI,PDIAVG,PDIAHG,
4991     1              NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
4992     1              IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
4993     1              IDNVOF,IDNHOF,IDFONT,PDSCAL,
4994     1              ICAPSW,IBUGS2,ISUBRO,IFOUND,IERROR)
4995      ENDIF
4996C
4997C  STEP 2: CLOSE THE FILE
4998C
4999      IOUNIT=ICAPNU
5000      IFILE=ICAPNA
5001      ISTAT=ICAPST
5002      IFORM=ICAPFO
5003      IACCES=ICAPAC
5004      IPROT=ICAPPR
5005      ICURST=ICAPCS
5006      ICURST=ICAPCS
5007      IF(ICAPCS.EQ.'CLOSED')GOTO6090
5008      IENDFI='ON'
5009      IREWIN='ON'
5010      CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
5011     1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
5012      IF(IERRFI.EQ.'YES')GOTO9000
5013C
5014 6090 CONTINUE
5015C
5016C  STEP 3: RE-OPEN THE FILE
5017C
5018      IREWIN='ON'
5019      CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
5020     1IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
5021      IF(IERRFI.EQ.'YES')GOTO9000
5022      ICAPCS=ICURST
5023C
5024C  STEP 4: LOOP THROUGH THE FILE
5025C
5026      ILINE=0
5027      ICOUNT=1
5028      DO6110I=1,10000
5029        ICOUT=' '
5030        READ(ICAPNU,'(A120)',END=6129,ERR=6119)ICOUT
5031        ILINE=ILINE+1
5032        IF(ILINE.GT.ICAPLI(ICOUNT).AND.IMPSW.NE.'ON')THEN
5033          CALL DPERAS(IHARG,IARGT,IARG,NUMARG,
5034     1                IBACCO,IGRASW,IDIASW,
5035     1                PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
5036     1                PDIAHE,PDIAWI,PDIAVG,PDIAHG,
5037     1                NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
5038     1                IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
5039     1                IDNVOF,IDNHOF,IDFONT,PDSCAL,
5040     1                ICAPSW,IBUGS2,ISUBRO,IFOUND,IERROR)
5041          ILINE=1
5042          ICOUNT=ICOUNT+1
5043          IF(ICOUNT.GT.MAXCLI)ICOUNT=1
5044        ENDIF
5045        IF(I.EQ.1)THEN
5046          IFLAG='INIT'
5047        ELSEIF(ILINE.EQ.1)THEN
5048          IFLAG='NEW'
5049        ELSE
5050          IFLAG='OLD'
5051        ENDIF
5052        CALL DPWRSG('XXXX','BUG ',IREPCH,IMPSW,IFLAG,ICAPNM,ICAPBX,
5053     1              ILINE)
5054 6110 CONTINUE
5055 6119 CONTINUE
5056 6129 CONTINUE
5057C
5058C  STEP 5: CLOSE THE FILE
5059C
5060      IENDFI='ON'
5061      IREWIN='ON'
5062      CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
5063     1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
5064      ICAPCS=ICURST
5065      IF(IERRFI.EQ.'YES')GOTO9000
5066C
5067C  STEP 6: RE-OPEN THE FILE
5068C
5069      IFILE=ICAPNA
5070      IOUNIT=ICAPNU
5071      IREWIN='ON'
5072      CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
5073     1IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
5074      IF(IERRFI.EQ.'YES')GOTO9000
5075      ICAPCS=ICURST
5076C
5077      GOTO9000
5078C
5079C               ****************
5080C               **  STEP 90-- **
5081C               **  EXIT.     **
5082C               ****************
5083C
5084 9000 CONTINUE
5085C
5086      IFILQU=IFILQ2
5087C
5088      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT')THEN
5089        WRITE(ICOUT,999)
5090        CALL DPWRST('XXX','BUG ')
5091        WRITE(ICOUT,9011)
5092 9011   FORMAT('***** AT THE END       OF DPCAPT--')
5093        CALL DPWRST('XXX','BUG ')
5094        WRITE(ICOUT,9013)IBUGS2,IFOUND,IERROR
5095 9013   FORMAT('IBUGS2,IFOUND,IERROR = ',2(A4,2X),A4)
5096        CALL DPWRST('XXX','BUG ')
5097        WRITE(ICOUT,9015)ICOM,ICOM2,IOFILE,IWIDTH,IOUNIT
5098 9015   FORMAT('ICOM,ICOM2,IOFILE,IWIDTH,IOUNIT = ',3(A4,2X),2I8)
5099        CALL DPWRST('XXX','BUG ')
5100        WRITE(ICOUT,9017)(IANSLC(I),I=1,MIN(120,IWIDTH))
5101 9017   FORMAT('IANSLC(.) = ',120A1)
5102        CALL DPWRST('XXX','BUG ')
5103        WRITE(ICOUT,9031)JP3,JP4,JP5,KMIN,KDEL,KMAX
5104 9031   FORMAT('JP2,JP3,JP4,KMIN,KDEL,KMAX = ',6I8)
5105        CALL DPWRST('XXX','BUG ')
5106        WRITE(ICOUT,9052)IFILE
5107 9052   FORMAT('IFILE  = ',A80)
5108        CALL DPWRST('XXX','BUG ')
5109        WRITE(ICOUT,9053)ISTAT,IFORM,IACCES,IPROT,ICURST
5110 9053   FORMAT('ISTAT,IFORM,IACCES,IPROT,ICURST  = ',4(A12,2X),A12)
5111        CALL DPWRST('XXX','BUG ')
5112        WRITE(ICOUT,9058)IENDFI,IREWIN,ISUBN0,IERRFI
5113 9058   FORMAT('IENDFI,IREWIN,ISUBN0,IERRFI = ',2(A4,2X),A12,2X,A12)
5114        CALL DPWRST('XXX','BUG ')
5115      ENDIF
5116C
5117      RETURN
5118      END
5119      SUBROUTINE DPCASE(ICOM,IHARG,NUMARG,
5120     1IDEFCA,
5121     1ITEXCA,
5122     1IBUGD2,ISUBRO,IFOUND,IERROR)
5123C
5124C     PURPOSE--DEFINE THE CASE (UPPER OR LOWER) TYPE FOR
5125C              TITLE, LABEL, AND LEGEND SCRIPT
5126C              ON A PLOT.
5127C              THE CASE (UPPER OR LOWER) FOR THE SCRIPT WILL BE PLACED
5128C              IN THE CHARACTER VARIABLE ITEXCA.
5129C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
5130C                     --NUMARG
5131C                     --IDEFCA
5132C                     --IBUGD2
5133C     OUTPUT ARGUMENTS--ITEXCA
5134C                     --IFOUND ('YES' OR 'NO' )
5135C                     --IERROR ('YES' OR 'NO' )
5136C     WRITTEN BY--JAMES J. FILLIBEN
5137C                 STATISTICAL ENGINEERING DIVISION
5138C                 INFORMATION TECHNOLOGY LABORATORY
5139C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
5140C                 GAITHERSBURG, MD 20899-8980
5141C                 PHONE--301-975-2899
5142C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
5143C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
5144C     LANGUAGE--ANSI FORTRAN (1977)
5145C     VERSION NUMBER--82/7
5146C     ORIGINAL VERSION--APRIL     1981.
5147C     UPDATED         --MAY       1982.
5148C     UPDATED         --OCTOBER   1993.  ACCEPT "ASIS" AS ARGUMENT
5149C
5150C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
5151C
5152      CHARACTER*4 ICOM
5153      CHARACTER*4 IHARG
5154      CHARACTER*4 IDEFCA
5155      CHARACTER*4 ITEXCA
5156      CHARACTER*4 IBUGD2
5157      CHARACTER*4 ISUBRO
5158      CHARACTER*4 IFOUND
5159      CHARACTER*4 IERROR
5160C
5161C---------------------------------------------------------------------
5162C
5163      DIMENSION IHARG(*)
5164C
5165C---------------------------------------------------------------------
5166C
5167      INCLUDE 'DPCOP2.INC'
5168C
5169C-----START POINT-----------------------------------------------------
5170C
5171      IFOUND='NO'
5172      IERROR='NO'
5173C
5174      IF(IBUGD2.EQ.'OFF')GOTO90
5175      WRITE(ICOUT,999)
5176  999 FORMAT(1X)
5177      CALL DPWRST('XXX','BUG ')
5178      WRITE(ICOUT,51)
5179   51 FORMAT('***** AT THE BEGINNING OF DPCASE--')
5180      CALL DPWRST('XXX','BUG ')
5181      WRITE(ICOUT,53)ICOM,NUMARG,IDEFCA
5182   53 FORMAT('ICOM,NUMARG,IDEFCA = ',A4,2X,I8,2X,A4)
5183      CALL DPWRST('XXX','BUG ')
5184      DO55I=1,NUMARG
5185      WRITE(ICOUT,56)I,IHARG(I)
5186   56 FORMAT('I,IHARG(I) = ',I8,2X,A4)
5187      CALL DPWRST('XXX','BUG ')
5188   55 CONTINUE
5189   90 CONTINUE
5190C
5191C               ************************************************
5192C               **  TREAT THE CASE (UPPER VERSUS LOWER) CASE  **
5193C               ************************************************
5194C
5195      IF(ICOM.EQ.'CASE')GOTO1120
5196      IF(ICOM.EQ.'UPPE')GOTO1130
5197      IF(ICOM.EQ.'LOWE')GOTO1140
5198CCCCC OCTOBER 1993.  ADD FOLLOWING LINE
5199      IF(ICOM.EQ.'ASIS')GOTO1150
5200      GOTO9000
5201C
5202 1120 CONTINUE
5203      IF(NUMARG.LE.0)GOTO1161
5204      IF(IHARG(NUMARG).EQ.'ON')GOTO1161
5205      IF(IHARG(NUMARG).EQ.'OFF')GOTO1162
5206      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1161
5207      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1165
5208      IF(IHARG(NUMARG).EQ.'UPPE')GOTO1161
5209      IF(IHARG(NUMARG).EQ.'LOWE')GOTO1162
5210CCCCC OCTOBER 1993.  ADD FOLLOWING LINE
5211      IF(IHARG(NUMARG).EQ.'ASIS')GOTO1163
5212      IF(IHARG(NUMARG).EQ.'?')GOTO8100
5213      GOTO1170
5214C
5215 1130 CONTINUE
5216      IF(NUMARG.LE.0)GOTO9000
5217      IF(IHARG(1).NE.'CASE')GOTO9000
5218      IF(NUMARG.LE.1)GOTO1161
5219      IF(IHARG(NUMARG).EQ.'ON')GOTO1161
5220      IF(IHARG(NUMARG).EQ.'OFF')GOTO1162
5221      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1161
5222      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1165
5223      GOTO9000
5224C
5225 1140 CONTINUE
5226      IF(NUMARG.LE.0)GOTO9000
5227      IF(IHARG(1).NE.'CASE')GOTO9000
5228      IF(NUMARG.LE.1)GOTO1162
5229      IF(IHARG(NUMARG).EQ.'ON')GOTO1162
5230      IF(IHARG(NUMARG).EQ.'OFF')GOTO1161
5231      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1162
5232      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1165
5233      GOTO9000
5234CCCCC OCTOBER 1993.  ADD FOLLOWING SECTION
5235C
5236 1150 CONTINUE
5237      IF(NUMARG.LE.0)GOTO9000
5238      IF(IHARG(1).NE.'CASE')GOTO9000
5239      IF(NUMARG.LE.1)GOTO1163
5240      IF(IHARG(NUMARG).EQ.'ON')GOTO1162
5241      IF(IHARG(NUMARG).EQ.'OFF')GOTO1161
5242      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1162
5243      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1165
5244      GOTO9000
5245C
5246 1161 CONTINUE
5247      ITEXCA='UPPE'
5248      GOTO1180
5249C
5250 1162 CONTINUE
5251      ITEXCA='LOWE'
5252      GOTO1180
5253CCCCC OCTOBER 1993.  ADD FOLLOWING SECTION
5254C
5255 1163 CONTINUE
5256      ITEXCA='ASIS'
5257      GOTO1180
5258C
5259 1165 CONTINUE
5260      ITEXCA=IDEFCA
5261      GOTO1180
5262C
5263 1170 CONTINUE
5264      IERROR='YES'
5265      WRITE(ICOUT,1171)
5266 1171 FORMAT('***** ERROR IN DPCASE--')
5267      CALL DPWRST('XXX','BUG ')
5268      WRITE(ICOUT,1172)
5269 1172 FORMAT('      ILLEGAL ENTRY FOR CASE ',
5270     1'COMMAND.')
5271      CALL DPWRST('XXX','BUG ')
5272      WRITE(ICOUT,1173)
5273 1173 FORMAT('      TEST EXAMPLE TO DEMONSTRATE THE ',
5274     1'PROPER FORM--')
5275      CALL DPWRST('XXX','BUG ')
5276      WRITE(ICOUT,1174)
5277 1174 FORMAT('      SUPPOSE THE THE ANALYST WISHES TO HAVE CASE ')
5278      CALL DPWRST('XXX','BUG ')
5279      WRITE(ICOUT,1175)
5280 1175 FORMAT('      FOR ALL PLOT TITLES, LABELS, AND LEGENDS,')
5281      CALL DPWRST('XXX','BUG ')
5282      WRITE(ICOUT,1176)
5283 1176 FORMAT('      THEN ALLOWABLE FORMS ARE--')
5284      CALL DPWRST('XXX','BUG ')
5285      WRITE(ICOUT,1177)
5286 1177 FORMAT('           CASE UPPER')
5287      CALL DPWRST('XXX','BUG ')
5288      WRITE(ICOUT,1178)
5289 1178 FORMAT('           UPPER CASE')
5290      CALL DPWRST('XXX','BUG ')
5291      WRITE(ICOUT,1179)
5292 1179 FORMAT('           CASE')
5293      CALL DPWRST('XXX','BUG ')
5294      GOTO9000
5295C
5296 1180 CONTINUE
5297      IFOUND='YES'
5298C
5299      IF(IFEEDB.EQ.'OFF')GOTO1189
5300      WRITE(ICOUT,999)
5301      CALL DPWRST('XXX','BUG ')
5302      WRITE(ICOUT,1181)
5303 1181 FORMAT('THE CASE (FOR PLOT SCRIPT AND TEXT) ')
5304      CALL DPWRST('XXX','BUG ')
5305      WRITE(ICOUT,1182)ITEXCA
5306 1182 FORMAT('HAS JUST BEEN SET TO ',A4)
5307      CALL DPWRST('XXX','BUG ')
5308 1189 CONTINUE
5309      GOTO9000
5310C
5311C               ********************************************
5312C               **  STEP 81--                             **
5313C               **  TREAT THE    ?    CASE--              **
5314C               **  DUMP OUT CURRENT AND DEFAULT VALUES.  **
5315C               ********************************************
5316C
5317 8100 CONTINUE
5318      IFOUND='YES'
5319      WRITE(ICOUT,999)
5320      CALL DPWRST('XXX','BUG ')
5321      WRITE(ICOUT,8111)ITEXCA
5322 8111 FORMAT('THE CURRENT CASE IS ',A4)
5323      CALL DPWRST('XXX','BUG ')
5324      WRITE(ICOUT,8112)IDEFCA
5325 8112 FORMAT('THE DEFAULT CASE IS ',A4)
5326      CALL DPWRST('XXX','BUG ')
5327      GOTO9000
5328C
5329C               *****************
5330C               **  STEP 90--  **
5331C               **  EXIT       **
5332C               *****************
5333C
5334 9000 CONTINUE
5335      IF(IBUGD2.EQ.'OFF')GOTO9090
5336      WRITE(ICOUT,999)
5337      CALL DPWRST('XXX','BUG ')
5338      WRITE(ICOUT,9011)
5339 9011 FORMAT('***** AT THE END       OF DPCASE--')
5340      CALL DPWRST('XXX','BUG ')
5341      WRITE(ICOUT,9012)IBUGD2,ISUBRO,IFOUND,IERROR
5342 9012 FORMAT('IBUGD2,ISUBRO,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
5343      CALL DPWRST('XXX','BUG ')
5344      WRITE(ICOUT,9013)ITEXCA,IDEFCA
5345 9013 FORMAT('ITEXCA,IDEFCA = ',A4,2X,A4)
5346      CALL DPWRST('XXX','BUG ')
5347 9090 CONTINUE
5348C
5349      RETURN
5350      END
5351      SUBROUTINE DPCC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
5352     1                ICONT,IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
5353C
5354C     PURPOSE--GENERATE ONE OF THE FOLLOWING 12 CONTROL CHARTS--
5355C              1) MEAN
5356C              2) RANGE
5357C              3) STANDARD DEVIATION
5358C              4) CUSUM
5359C              5) P
5360C              6) PN
5361C              7) C
5362C              8) U
5363C              9) EWMA (EXPONENTIALLY WEIGHTED MOVING AVERAGE)
5364C             10) MOVING AVERAGE
5365C             11) MOVING RANGE
5366C             12) MOVING STANDARD DEVIATION
5367C             13) ISO 13528
5368C             14) ISO 13528 CUSUM
5369C     WRITTEN BY--JAMES J. FILLIBEN
5370C                 STATISTICAL ENGINEERING DIVISION
5371C                 INFORMATION TECHNOLOGY LABORATORY
5372C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
5373C                 GAITHERSBURG, MD 20899-8980
5374C                 PHONE--301-975-2899
5375C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
5376C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
5377C     LANGUAGE--ANSI FORTRAN (1977)
5378C     VERSION NUMBER--82/7
5379C     ORIGINAL VERSION--JUNE      1978.
5380C     UPDATED         --JULY      1978.
5381C     UPDATED         --AUGUST    1981.
5382C     UPDATED         --MAY       1982.
5383C     UPDATED         --JANUARY   1988. (P, PN, C, AND U CHARTS)
5384C     UPDATED         --JUNE      1990. TEMPORARY ARRAYS TO GARBAGE COMMON
5385C     UPDATED         --JULY      1990. ADD    R CHART    CHECK
5386C     UPDATED         --JULY      1990. FIX P, NP, C, & U CHARTS
5387C     UPDATED         --SEPTEMBER 1990. LSL, USL, TARGET
5388C     UPDATED         --AUGUST    1991. TURN OFF MESS.--LSL/USL/TARGET
5389C     UPDATED         --MARCH     1997. EWMA, ACTIVATE CUSUM
5390C     UPDATED         --MARCH     1997. MOVING AVERAGE
5391C     UPDATED         --MARCH     1997. MOVING RANGE
5392C     UPDATED         --MARCH     1997. MOVING STANDARD DEVIATION
5393C     UPDATED         --SEPTEMBER 1998. ACTIVATED CUSUM MEAN CHART
5394C     UPDATED         --AUGUST    2010. USE DPPARS
5395C     UPDATED         --JANUARY   2012. SUPPORT HIGHLIGHTED OPTION
5396C     UPDATED         --JANUARY   2012. "MAXSET" OPTION
5397C     UPDATED         --FEBRUARY  2012. ISO 13528
5398C     UPDATED         --FEBRUARY  2012. ISO 13528 CUSUM
5399C     UPDATED         --FEBRUARY  2018. CONFLICT WITH
5400C                                       "MEAN CHARACTER PLOT"
5401C
5402C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
5403C
5404      CHARACTER*4 ICASPL
5405      CHARACTER*4 ICASP2
5406      CHARACTER*4 IAND1
5407      CHARACTER*4 IAND2
5408      CHARACTER*4 ICONT
5409      CHARACTER*4 IBUGG2
5410      CHARACTER*4 IBUGG3
5411      CHARACTER*4 IBUGQ
5412      CHARACTER*4 ISUBRO
5413      CHARACTER*4 IFOUND
5414      CHARACTER*4 IERROR
5415C
5416      CHARACTER*4 IHWUSE
5417      CHARACTER*4 MESSAG
5418      CHARACTER*4 IH
5419      CHARACTER*4 IH2
5420      CHARACTER*4 IERRO2
5421      CHARACTER*4 ISUBN1
5422      CHARACTER*4 ISUBN2
5423      CHARACTER*4 ISTEPN
5424      CHARACTER*4 CARG0
5425      CHARACTER*4 CARG1
5426      CHARACTER*4 CARG2
5427      CHARACTER*4 CARG3
5428      CHARACTER*4 CARG4
5429      CHARACTER*4 CARG11
5430C
5431      CHARACTER*4 IHIGH
5432      CHARACTER*4 IFOUN1
5433      CHARACTER*4 IFOUN2
5434      CHARACTER*40 INAME
5435      PARAMETER (MAXSPN=10)
5436      CHARACTER*4 IVARN1(MAXSPN)
5437      CHARACTER*4 IVARN2(MAXSPN)
5438      CHARACTER*4 IVARTY(MAXSPN)
5439      REAL PVAR(MAXSPN)
5440      INTEGER ILIS(MAXSPN)
5441      INTEGER NRIGHT(MAXSPN)
5442      INTEGER ICOLR(MAXSPN)
5443C
5444C---------------------------------------------------------------------
5445C
5446      INCLUDE 'DPCOPA.INC'
5447      INCLUDE 'DPCOZZ.INC'
5448C
5449      DIMENSION Y1(MAXOBV)
5450      DIMENSION Y2(MAXOBV)
5451      DIMENSION X1(MAXOBV)
5452      DIMENSION XIDTEM(MAXOBV)
5453      DIMENSION TEMP(MAXOBV)
5454      DIMENSION TEMP2(MAXOBV)
5455      DIMENSION XHIGH(MAXOBV)
5456      DIMENSION YPREV(MAXOBV)
5457C
5458      EQUIVALENCE (GARBAG(IGARB1),X1(1))
5459      EQUIVALENCE (GARBAG(IGARB2),Y1(1))
5460      EQUIVALENCE (GARBAG(IGARB3),Y2(1))
5461      EQUIVALENCE (GARBAG(IGARB4),XIDTEM(1))
5462      EQUIVALENCE (GARBAG(IGARB5),TEMP(1))
5463      EQUIVALENCE (GARBAG(IGARB6),TEMP2(1))
5464      EQUIVALENCE (GARBAG(IGARB7),XHIGH(1))
5465      EQUIVALENCE (GARBAG(IGARB8),YPREV(1))
5466C
5467C-----COMMON----------------------------------------------------------
5468C
5469CCCCC ADD FOLLOWING LINE APRIL 1997
5470      INCLUDE 'DPCOST.INC'
5471      INCLUDE 'DPCOHK.INC'
5472      INCLUDE 'DPCODA.INC'
5473C
5474C-----COMMON VARIABLES (GENERAL)--------------------------------------
5475C
5476      INCLUDE 'DPCOP2.INC'
5477C
5478C-----START POINT-----------------------------------------------------
5479C
5480      IERROR='NO'
5481      IFOUND='NO'
5482C
5483      ISUBN1='DPCC'
5484      ISUBN2='    '
5485C
5486      MAXCP1=MAXCOL+1
5487      MAXCP2=MAXCOL+2
5488      MAXCP3=MAXCOL+3
5489      MAXCP4=MAXCOL+4
5490      MAXCP5=MAXCOL+5
5491      MAXCP6=MAXCOL+6
5492C
5493      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'DPCC')THEN
5494        WRITE(ICOUT,999)
5495  999   FORMAT(1X)
5496        CALL DPWRST('XXX','BUG ')
5497        WRITE(ICOUT,51)
5498   51   FORMAT('***** AT THE BEGINNING OF DPCC--')
5499        CALL DPWRST('XXX','BUG ')
5500        WRITE(ICOUT,52)ICASPL,IAND1,IAND2
5501   52   FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4)
5502        CALL DPWRST('XXX','BUG ')
5503        WRITE(ICOUT,53)ICONT,IBUGG2,IBUGG3,IBUGQ,ISUBRO
5504   53   FORMAT('ICONT,IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',4(A4,2X),A4)
5505        CALL DPWRST('XXX','BUG ')
5506      ENDIF
5507C
5508C               ***************************
5509C               **  STEP 1--             **
5510C               **  EXTRACT THE COMMAND  **
5511C               ***************************
5512C
5513C               *************************************************
5514C               **  TREAT THE CONTROL CHART CASE:              **
5515C               **     1) MEAN             CONTROL CHART       **
5516C               **     2) SD               CONTROL CHART       **
5517C               **     3) RANGE            CONTROL CHART       **
5518C               **     4) CUSUM            CONTROL CHART       **
5519C               **     5) P                CONTROL CHART       **
5520C               **     6) PN               CONTROL CHART       **
5521C               **     7) C                CONTROL CHART       **
5522C               **     8) U                CONTROL CHART       **
5523C               **     9) EWMA             CONTROL CHART       **
5524C               **    10) MOVING AVERAGE   CONTROL CHART       **
5525C               **    11) MOVING RANGE     CONTROL CHART       **
5526C               **    12) MOVING SD        CONTROL CHART       **
5527C               **    13) ISO 13528        CONTROL CHART       **
5528C               **    14) ISO 13528 CUSUM  CONTROL CHART       **
5529C               *************************************************
5530C
5531      ISTEPN='1'
5532      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPCC')
5533     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5534C
5535C     CHECK FOR NAME CONFLICTS
5536C
5537      IF(ICOM.EQ.'FLUC')GOTO9000
5538      IF(ICOM.EQ.'TABU')GOTO9000
5539      IF(ICOM.EQ.'JACK')GOTO9000
5540      IF(ICOM.EQ.'BOOT')GOTO9000
5541      IF(ICOM.EQ.'DEX ')GOTO9000
5542      IF(ICOM.EQ.'DEXP')GOTO9000
5543      IF(ICOM.EQ.'DOE ')GOTO9000
5544      IF(ICOM.EQ.'DOX ')GOTO9000
5545      IF(ICOM.EQ.'CROS' .AND. IHARG(1).EQ.'TABU')GOTO9000
5546C
5547      IHIGH='OFF'
5548      IFOUN1='OFF'
5549      IFOUN2='OFF'
5550      IF(ICOM.EQ.'HIGH' .OR. ICOM.EQ.'SUBS')IHIGH='ON'
5551      ILASTC=-9999
5552C
5553      ISTOP=NUMARG-1
5554      DO90I=1,NUMARG
5555        IF(IHARG(I).EQ.'PLOT' .OR. IHARG(I).EQ.'CHAR')THEN
5556          IF(IHARG2(I).EQ.'ACTE')GOTO9000
5557          ISTOP=I
5558          GOTO99
5559        ENDIF
5560   90 CONTINUE
5561   99 CONTINUE
5562C
5563      ICASP2='NONE'
5564      DO100I=0,ISTOP
5565C
5566        IF(I.EQ.0)THEN
5567          CARG0='    '
5568          CARG1=ICOM
5569          CARG2=IHARG(I+1)
5570          CARG3=IHARG(I+2)
5571          CARG4=IHARG(I+3)
5572        ELSE
5573          IF(I.EQ.1)THEN
5574            CARG0=ICOM
5575          ELSE
5576            CARG0=IHARG(I-1)
5577          ENDIF
5578          CARG1=IHARG(I)
5579          CARG11=IHARG2(I)
5580          CARG2=IHARG(I+1)
5581          CARG3=IHARG(I+2)
5582          CARG4=IHARG(I+3)
5583        ENDIF
5584C
5585        IF(IHARG(I).EQ.'=')THEN
5586          IFOUND='NO'
5587          GOTO9000
5588        ELSEIF((CARG1.EQ.'X   ' .OR. CARG1.EQ.'XBAR' .OR.
5589     1          CARG1.EQ.'MEAN' .OR. CARG1.EQ.'AVER') .AND.
5590     1          CARG2.NE.'CUSU' .AND. CARG2.NE.'CUMU' .AND.
5591     1          CARG0.NE.'MOVI')THEN
5592          IFOUN1='YES'
5593          ICASPL='MECC'
5594        ELSEIF((CARG1.EQ.'SD  ' .OR. CARG1.EQ.'S   ') .AND.
5595     1          CARG2.NE.'CUSU' .AND. CARG2.NE.'CUMU' .AND.
5596     1          CARG0.NE.'MOVI')THEN
5597          IFOUN1='YES'
5598          ICASPL='SDCC'
5599        ELSEIF(CARG1.EQ.'STAN' .AND. CARG2.EQ.'DEVI' .AND.
5600     1         CARG3.NE.'CUSU' .AND. CARG3.NE.'CUMU' .AND.
5601     1         CARG0.NE.'MOVI')THEN
5602          IFOUN1='YES'
5603          ICASPL='SDCC'
5604        ELSEIF((CARG1.EQ.'RANG' .OR. CARG1.EQ.'R   ') .AND.
5605     1          CARG2.NE.'CUSU' .AND. CARG2.NE.'CUMU' .AND.
5606     1          CARG0.NE.'MOVI')THEN
5607          IFOUN1='YES'
5608          ICASPL='RACC'
5609        ELSEIF((CARG1.EQ.'MEAN' .OR. CARG1.EQ.'AVER' .OR.
5610     1          CARG1.EQ.'X   ') .AND.
5611     1         (CARG2.EQ.'CUSU' .OR.
5612     1         (CARG2.EQ.'CUMU' .AND. CARG3.EQ.'SUM ')))THEN
5613          IFOUN1='YES'
5614          ICASPL='CUCC'
5615          ICASP2='MEAN'
5616        ELSEIF((CARG1.EQ.'SD  ' .OR. CARG1.EQ.'S   ') .AND.
5617     1         (CARG2.EQ.'CUSU' .OR.
5618     1         (CARG2.EQ.'CUMU' .AND. CARG3.EQ.'SUM ')))THEN
5619          IFOUN1='YES'
5620          ICASPL='CUCC'
5621          ICASP2='SD  '
5622        ELSEIF(CARG1.EQ.'STAN' .AND. CARG2.EQ.'DEVI' .AND.
5623     1         (CARG3.EQ.'CUSU' .OR.
5624     1         (CARG3.EQ.'CUMU' .AND. CARG4.EQ.'SUM ')))THEN
5625          IFOUN1='YES'
5626          ICASPL='CUCC'
5627          ICASP2='SD  '
5628        ELSEIF((CARG1.EQ.'RANG' .OR. CARG1.EQ.'R   ') .AND.
5629     1         (CARG2.EQ.'CUSU' .OR.
5630     1         (CARG2.EQ.'CUMU' .AND. CARG3.EQ.'SUM ')))THEN
5631          IFOUN1='YES'
5632          ICASPL='CUCC'
5633          ICASP2='RANG'
5634        ELSEIF(CARG1.EQ.'CUSU' .AND. ICASPL.NE.'1CUS')THEN
5635          IFOUN1='YES'
5636          ICASPL='CUCC'
5637        ELSEIF(CARG1.EQ.'CUMU' .AND. CARG2.EQ.'SUM ')THEN
5638          IFOUN1='YES'
5639          ICASPL='CUCC'
5640        ELSEIF(CARG1.EQ.'P   ')THEN
5641          IFOUN1='YES'
5642          ICASPL='PCC'
5643        ELSEIF(CARG1.EQ.'PN  ' .OR. CARG1.EQ.'NP  ')THEN
5644          IFOUN1='YES'
5645          ICASPL='PNCC'
5646        ELSEIF(CARG1.EQ.'C   ')THEN
5647          IFOUN1='YES'
5648          ICASPL='CCC'
5649        ELSEIF(CARG1.EQ.'U   ')THEN
5650          IFOUN1='YES'
5651          ICASPL='UCC'
5652        ELSEIF(CARG1.EQ.'EXPO' .AND. CARG2.EQ.'WEIG' .AND.
5653     1         CARG3.EQ.'MOVI' .AND. CARG4.EQ.'AVER')THEN
5654          IFOUN1='YES'
5655          ICASPL='EWCC'
5656        ELSEIF(CARG1.EQ.'EWMA')THEN
5657          IFOUN1='YES'
5658          ICASPL='EWCC'
5659        ELSEIF(CARG1.EQ.'EXPO' .AND. CARG2.EQ.'MOVI' .AND.
5660     1         CARG3.EQ.'AVER')THEN
5661          IFOUN1='YES'
5662          ICASPL='EWCC'
5663        ELSEIF(CARG1.EQ.'EXPO' .AND. CARG2.EQ.'WEIG' .AND.
5664     1         CARG3.EQ.'MOVI')THEN
5665          IFOUN1='YES'
5666          ICASPL='EWCC'
5667        ELSEIF(CARG1.EQ.'EXPO' .AND. CARG2.EQ.'WEIG')THEN
5668          IFOUN1='YES'
5669          ICASPL='EWCC'
5670        ELSEIF(CARG1.EQ.'MOVI' .AND.
5671     1        (CARG2.EQ.'AVER' .OR. CARG2.EQ.'MEAN') .AND.
5672     1         CARG0.NE.'EXPO' .AND. CARG0.NE.'WEIG')THEN
5673          IFOUN1='YES'
5674          ICASPL='MACC'
5675        ELSEIF(CARG1.EQ.'MOVI' .AND. CARG2.EQ.'RANG')THEN
5676          IFOUN1='YES'
5677          ICASPL='MRCC'
5678        ELSEIF(CARG1.EQ.'MOVI' .AND.
5679     1        (CARG2.EQ.'SD  ' .OR. CARG2.EQ.'MSD' .OR.
5680     1         CARG2.EQ.'S   '))THEN
5681          IFOUN1='YES'
5682          ICASPL='MSCC'
5683        ELSEIF(CARG1.EQ.'MOVI' .AND. CARG2.EQ.'STAN' .AND.
5684     1         CARG3.EQ.'DEVI')THEN
5685          IFOUN1='YES'
5686          ICASPL='MSCC'
5687        ELSEIF(CARG1.EQ.'ISO ' .AND. CARG2.EQ.'1352')THEN
5688          IF(CARG3.EQ.'CUSU')THEN
5689            IFOUN1='YES'
5690            ICASPL='1CUS'
5691          ELSE
5692            IFOUN1='YES'
5693            ICASPL='1352'
5694          ENDIF
5695        ELSEIF(CARG1.EQ.'CONT' .AND. CARG2.EQ.'CHAR')THEN
5696          IFOUN2='YES'
5697          ILASTC=MAX(ILASTC,I+1)
5698        ELSEIF(CARG1.EQ.'CONT' .AND. CARG2.EQ.'PLOT')THEN
5699          IFOUN2='YES'
5700          ILASTC=MAX(ILASTC,I+1)
5701        ELSEIF(CARG1.EQ.'CHAR' .AND. CARG0.NE.'CONT')THEN
5702          IF(CARG11.EQ.'ACTE')GOTO9000
5703          IFOUN2='YES'
5704          ILASTC=MAX(ILASTC,I)
5705        ENDIF
5706C
5707  100 CONTINUE
5708C
5709      IF(IFOUN1.EQ.'NO' .AND. IFOUN2.EQ.'YES')THEN
5710        ICASPL='MECC'
5711        IFOUN1='YES'
5712      ENDIF
5713      IF(IFOUN1.EQ.'YES' .AND. IFOUN2.EQ.'YES')IFOUND='YES'
5714      IF(IFOUND.EQ.'NO')GOTO9000
5715C
5716      IF(ILASTC.GE.1)THEN
5717        CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
5718        ILASTC=0
5719      ENDIF
5720C
5721C
5722C               ****************************************
5723C               **  STEP 2--                          **
5724C               **  EXTRACT THE VARIABLE LIST         **
5725C               ****************************************
5726C
5727      ISTEPN='2'
5728      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPCC')
5729     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5730C
5731      INAME='CONTROL CHART'
5732      IF(ICASPL.EQ.'MECC')INAME='MEAN CONTROL CHART'
5733      IF(ICASPL.EQ.'SDCC')INAME='SD CONTROL CHART'
5734      IF(ICASPL.EQ.'RACC')INAME='RANGE CONTROL CHART'
5735      IF(ICASPL.EQ.'CUCC')INAME='CUSUM CONTROL CHART'
5736      IF(ICASPL.EQ.'PCC')INAME='P CONTROL CHART'
5737      IF(ICASPL.EQ.'PNCC')INAME='NP CONTROL CHART'
5738      IF(ICASPL.EQ.'CCC')INAME='C CONTROL CHART'
5739      IF(ICASPL.EQ.'UCC')INAME='U CONTROL CHART'
5740      IF(ICASPL.EQ.'EWCC')INAME='EWMA CONTROL CHART'
5741      IF(ICASPL.EQ.'MACC')INAME='MOVING AVERAGE CONTROL CHART'
5742      IF(ICASPL.EQ.'MRCC')INAME='MOVING RANGE CONTROL CHART'
5743      IF(ICASPL.EQ.'MSCC')INAME='MOVING SD CONTROL CHART'
5744      IF(ICASPL.EQ.'1352')INAME='ISO 13528 CONTROL CHART'
5745      IF(ICASPL.EQ.'1CUS')INAME='ISO 13528 CUSUM CONTROL CHART'
5746      MINNA=1
5747      MAXNA=100
5748      MINN2=2
5749      IFLAGE=1
5750      IFLAGM=0
5751      IF(ICASPL.EQ.'MACC')IFLAGM=1
5752      IF(ICASPL.EQ.'MRCC')IFLAGM=1
5753      IF(ICASPL.EQ.'MSCC')IFLAGM=1
5754      IFLAGP=0
5755      JMIN=1
5756      JMAX=NUMARG
5757      MINNVA=1
5758      MAXNVA=3
5759      IF(IHIGH.EQ.'ON')MAXNVA=MAXNVA+1
5760C
5761      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
5762     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
5763     1            JMIN,JMAX,
5764     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
5765     1            IVARN1,IVARN2,IVARTY,PVAR,
5766     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
5767     1            MINNVA,MAXNVA,
5768     1            IFLAGM,IFLAGP,
5769     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
5770      IF(IERROR.EQ.'YES')GOTO9000
5771C
5772      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPCC')THEN
5773        WRITE(ICOUT,999)
5774        CALL DPWRST('XXX','BUG ')
5775        WRITE(ICOUT,281)
5776  281   FORMAT('***** AFTER CALL DPPARS--')
5777        CALL DPWRST('XXX','BUG ')
5778        WRITE(ICOUT,282)NQ,NUMVAR,IHIGH,ICASPL
5779  282   FORMAT('NQ,NUMVAR,IHIGH,ICASPL = ',2I8,2(2X,A4))
5780        CALL DPWRST('XXX','BUG ')
5781        IF(NUMVAR.GT.0)THEN
5782          DO285I=1,NUMVAR
5783            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
5784     1                      ICOLR(I),IVARTY(I)
5785  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
5786     1             'ICOLR(I),IVARTY(I) = ',I8,2X,A4,A4,2X,3I8,2X,A4)
5787            CALL DPWRST('XXX','BUG ')
5788  285     CONTINUE
5789        ENDIF
5790      ENDIF
5791C
5792      ICOL=1
5793      IF(IHIGH.EQ.'OFF')THEN
5794        CALL DPPAR5(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
5795     1              INAME,IVARN1,IVARN2,IVARTY,
5796     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
5797     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
5798     1              MAXCP4,MAXCP5,MAXCP6,
5799     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
5800     1              Y1,Y2,X1,TEMP,TEMP2,TEMP2,TEMP2,NLOCAL,
5801     1              IBUGG3,ISUBRO,IFOUND,IERROR)
5802        IF(IERROR.EQ.'YES')GOTO9000
5803C
5804        IF(NUMVAR.EQ.2)THEN
5805          DO292II=1,NLOCAL
5806            X1(II)=Y2(II)
5807  292     CONTINUE
5808        ENDIF
5809      ELSE
5810        CALL DPPAR5(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
5811     1              INAME,IVARN1,IVARN2,IVARTY,
5812     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
5813     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
5814     1              MAXCP4,MAXCP5,MAXCP6,
5815     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
5816     1              Y1,Y2,X1,XHIGH,TEMP2,TEMP2,TEMP2,NLOCAL,
5817     1              IBUGG3,ISUBRO,IFOUND,IERROR)
5818        IF(IERROR.EQ.'YES')GOTO9000
5819C
5820        IF(NUMVAR.EQ.3)THEN
5821          DO294II=1,NLOCAL
5822            XHIGH(II)=X1(II)
5823            X1(II)=Y2(II)
5824  294     CONTINUE
5825        ELSEIF(NUMVAR.EQ.2)THEN
5826          DO296II=1,NLOCAL
5827            XHIGH(II)=Y2(II)
5828  296     CONTINUE
5829        ENDIF
5830      ENDIF
5831C
5832C               *******************************************************
5833C               **  STEP 7--                                         **
5834C               **  FOR THE 1-VARIABLE CASE ONLY,                    **
5835C               **  DETERMINE IF THE ANALYST                         **
5836C               **  HAS SPECIFIED    THE GROUP SIZE,                 **
5837C               **  FOR THE CONTROL CHART ANALYSIS.                  **
5838C               **  THE GROUP SIZE SETTING IS DEFINED BY SEARCHING   **
5839C               **  THE INTERNAL TABLE FOR THE PARAMETER NAME  NI ;  **
5840C               **  IF FOUND, USE THE SPECIFIED VALUE.               **
5841C               **  IF NOT FOUND, GENERATE AN ERROR MESSAGE.         **
5842C               *******************************************************
5843C
5844      ISTEPN='7'
5845      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPCC')
5846     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5847C
5848      ISIZE=1
5849      IF((IHIGH.EQ.'OFF'.AND.NUMVAR.LE.1) .OR.
5850     1   (IHIGH.EQ.'ON'.AND.NUMVAR.LE.2))THEN
5851        IH='NI  '
5852        IH2='    '
5853        IHWUSE='P'
5854        MESSAG='NO'
5855        CALL CHECKN(IH,IH2,IHWUSE,
5856     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
5857     1              ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2)
5858        IF(IERRO2.EQ.'YES')THEN
5859          ISIZE=1
5860        ELSE
5861          ISIZE=INT(VALUE(ILOCP)+0.5)
5862        ENDIF
5863      ENDIF
5864C
5865CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEBMER 1990
5866C               ********************************************************
5867C               **  STEP 8--                                          **
5868C               **  DETERMINE IF THE ANALYST                          **
5869C               **  HAS SPECIFIED                                     **
5870C               **      LSL (LOWER SPEC LIMIT)                        **
5871C               **      USL (UPPER SPEC LIMIT)                        **
5872C               **      USLCOST (UPPER SPEC LIMIT COST)               **
5873C               **      TARGET                                        **
5874C               **      P (FOR EWMA CHARTS)                           **
5875C               **      K (FOR UNGROUPED DATA, FILTER WIDTH)          **
5876C               **      WIDTH AS ALTERNATIVE TO K                     **
5877C               **      WEIGHT AS ALTERNATIVE TO P                    **
5878C               **  FOR THE CONTROL CHART ANALYSIS.                   **
5879C               ********************************************************
5880C
5881      ISTEPN='8'
5882      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPCC')
5883     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5884C
5885      CCLSL=CPUMIN
5886      IH='LSL '
5887      IH2='    '
5888      IHWUSE='P'
5889      MESSAG='NO'
5890      CALL CHECKN(IH,IH2,IHWUSE,
5891     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
5892     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2)
5893      IF(IERRO2.EQ.'NO')CCLSL=VALUE(ILOCP)
5894C
5895      CCUSL=CPUMIN
5896      IH='USL '
5897      IH2='    '
5898      IHWUSE='P'
5899      MESSAG='NO'
5900      CALL CHECKN(IH,IH2,IHWUSE,
5901     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
5902     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2)
5903      IF(IERRO2.EQ.'NO')CCUSL=VALUE(ILOCP)
5904C
5905      CCTARG=CPUMIN
5906      IH='TARG'
5907      IH2='ET  '
5908      IHWUSE='P'
5909      MESSAG='NO'
5910      CALL CHECKN(IH,IH2,IHWUSE,
5911     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
5912     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2)
5913      IF(IERRO2.EQ.'NO')CCTARG=VALUE(ILOCP)
5914C
5915      P=CPUMIN
5916      IH='P   '
5917      IH2='    '
5918      IHWUSE='P'
5919      MESSAG='NO'
5920      CALL CHECKN(IH,IH2,IHWUSE,
5921     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
5922     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2)
5923      IF(IERRO2.EQ.'NO')THEN
5924        P=VALUE(ILOCP)
5925      ELSE
5926        IH='WEIG'
5927        IH2='HT  '
5928        IHWUSE='P'
5929        MESSAG='NO'
5930        CALL CHECKN(IH,IH2,IHWUSE,
5931     1  IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
5932     1  ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2)
5933        IF(IERRO2.EQ.'NO')P=VALUE(ILOCP)
5934      ENDIF
5935C
5936      KWIDTH=3
5937      IH='K   '
5938      IH2='    '
5939      IHWUSE='P'
5940      MESSAG='NO'
5941      CALL CHECKN(IH,IH2,IHWUSE,
5942     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
5943     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2)
5944      IF(IERRO2.EQ.'NO')THEN
5945        KWIDTH=INT(VALUE(ILOCP)+0.5)
5946      ELSE
5947        IH='WIDT'
5948        IH2='H   '
5949        IHWUSE='P'
5950        MESSAG='NO'
5951        CALL CHECKN(IH,IH2,IHWUSE,
5952     1  IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
5953     1  ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2)
5954        IF(IERRO2.EQ.'NO')KWIDTH=INT(VALUE(ILOCP)+0.5)
5955      ENDIF
5956C
5957      USRSIG=CPUMIN
5958      IH='SIGM'
5959      IH2='AE  '
5960      IHWUSE='P'
5961      MESSAG='NO'
5962      CALL CHECKN(IH,IH2,IHWUSE,
5963     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
5964     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2)
5965      IF(IERRO2.EQ.'NO')USRSIG=VALUE(ILOCP)
5966C
5967      AK=0.5
5968      IH='K   '
5969      IH2='    '
5970      IHWUSE='P'
5971      MESSAG='NO'
5972      CALL CHECKN(IH,IH2,IHWUSE,
5973     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
5974     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2)
5975      IF(IERRO2.EQ.'NO')AK=VALUE(ILOCP)
5976C
5977      H=5.0
5978      IH='H   '
5979      IH2='    '
5980      IHWUSE='P'
5981      MESSAG='NO'
5982      CALL CHECKN(IH,IH2,IHWUSE,
5983     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
5984     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2)
5985      IF(IERRO2.EQ.'NO')H=VALUE(ILOCP)
5986C
5987      H=5.0
5988      IH='H   '
5989      IH2='    '
5990      IHWUSE='P'
5991      MESSAG='NO'
5992      CALL CHECKN(IH,IH2,IHWUSE,
5993     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
5994     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2)
5995      IF(IERRO2.EQ.'NO')H=VALUE(ILOCP)
5996C
5997      SHI=CPUMIN
5998      IH='SHI '
5999      IH2='    '
6000      IHWUSE='P'
6001      MESSAG='NO'
6002      CALL CHECKN(IH,IH2,IHWUSE,
6003     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
6004     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2)
6005      IF(IERRO2.EQ.'NO')SHI=VALUE(ILOCP)
6006C
6007      SLI=CPUMIN
6008      IH='SLI '
6009      IH2='    '
6010      IHWUSE='P'
6011      MESSAG='NO'
6012      CALL CHECKN(IH,IH2,IHWUSE,
6013     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
6014     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2)
6015      IF(IERRO2.EQ.'NO')SLI=VALUE(ILOCP)
6016C
6017      MAXSET=-99
6018      IH='MAXS'
6019      IH2='ET  '
6020      IHWUSE='P'
6021      MESSAG='NO'
6022      CALL CHECKN(IH,IH2,IHWUSE,
6023     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
6024     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2)
6025      IF(IERRO2.EQ.'NO')MAXSET=INT(VALUE(ILOCP)+0.5)
6026C
6027C               *******************************************************
6028C               **  STEP 9--                                         **
6029C               **  COMPUTE THE APPROPRIATE CONTROL CHART STATISTIC--**
6030C               **  MEAN, STANDARD DEVIATION, RANGE, CUSUM,          **
6031C               **  P, NP, C, U.                                     **
6032C               **  COMPUTE CONFIDENCE LINES.                        **
6033C               **  FORM THE VERTICAL AND HORIZONTAL AXIS            **
6034C               **  VALUES Y(.) AND X(.) FOR THE PLOT.               **
6035C               **  DEFINE THE VECTOR D(.) TO 1'S, 2'S, AND 3'S      **
6036C               **  FOR THE PLOTTED VALUE, THE LOWER CONFIDENCE LINE,**
6037C               **  AND THE UPPER CONFIDENCE LINE.                   **
6038C               **  DEFINE THE NUMBER OF PLOT POINTS    (NPLOTP).    **
6039C               **  DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV).    **
6040C               *******************************************************
6041C
6042      ISTEPN='8'
6043      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPCC')
6044     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6045C
6046      CALL DPCC2(Y1,Y2,X1,XHIGH,NLOCAL,NUMVAR,ICASPL,IHIGH,ISIZE,ICONT,
6047     1           XIDTEM,TEMP,TEMP2,YPREV,
6048     1           CCLSL,CCUSL,CCTARG,P,KWIDTH,
6049     1           ICCHPR,ICCHWT,ICONWC,USRSIG,
6050     1           AK,H,SHI,SLI,MAXSET,
6051     1           Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR)
6052C
6053C               *****************
6054C               **  STEP 90--  **
6055C               **  EXIT       **
6056C               *****************
6057C
6058 9000 CONTINUE
6059      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'DPCC')THEN
6060        WRITE(ICOUT,999)
6061        CALL DPWRST('XXX','BUG ')
6062        WRITE(ICOUT,9011)
6063 9011   FORMAT('***** AT THE END       OF DPCC--')
6064        CALL DPWRST('XXX','BUG ')
6065        WRITE(ICOUT,9012)IFOUND,IERROR,ISIZE
6066 9012   FORMAT('IFOUND,IERROR,ISIZE = ',A4,2X,A4,2X,I8)
6067        CALL DPWRST('XXX','BUG ')
6068        IF(IFOUND.EQ.'YES')THEN
6069          WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
6070 9013     FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',3I8,3(2X,A4))
6071          CALL DPWRST('XXX','BUG ')
6072          IF(NPLOTP.GE.1)THEN
6073            DO9015I=1,NPLOTP
6074              WRITE(ICOUT,9016)I,Y(I),X(I),D(I)
6075 9016         FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5)
6076              CALL DPWRST('XXX','BUG ')
6077 9015       CONTINUE
6078          ENDIF
6079        ENDIF
6080      ENDIF
6081C
6082      RETURN
6083      END
6084      SUBROUTINE DPCC2(Y,YN,X,XHIGH,N,NUMV2,ICASPL,IHIGH,ISIZE,ICONT,
6085     1                 XIDTEM,TEMP,TEMP2,YPREV,
6086     1                 CCLSL,CCUSL,CCTARG,P,KWIDTH,
6087     1                 ICCHPR,ICCHWT,ICONWC,USRSIG,
6088     1                 AK,H,SHI,SLI,MAXSET,
6089     1                 Y2,X2,D2,N2,NPLOTV,IBUGG3,ISUBRO,IERROR)
6090C
6091C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
6092C              THAT WILL DEFINE A CONTROL CHART
6093C              OF THE FOLLOWING TYPES--
6094C                 1) MEAN CONTROL CHART    Y X
6095C                 2) STANDARD DEVIATION CONTROL CHART    Y X
6096C                 3) RANGE CONTROL CHART    Y X
6097C                 4) CUSUM CONTROL CHART    Y X
6098C                 5) P CONTROL CHART    NUMDEF NUMTOT X
6099C                 6) PN CONTROL CHART    NUMDEF NUMTOT X
6100C                 7) U CONTROL CHART    NUMDEF SIZE X
6101C                 8) P CONTROL CHART    NUMDEF SIZE X
6102C                 9) EWMA CONTROL CHART Y X
6103C                10) MOVING AVERAGE CONTROL CHART Y X
6104C                11) MOVING RANGE CONTROL CHART Y X
6105C                12) MOVING STANDARD DEVIATION CONTROL CHART Y X
6106C                13) ISO 13528 CONTROL CHART Y X
6107C                14) ISO 13528 CUSUM CONTROL CHART Y X
6108C     NOTE--USE P AND PN CHARTS IF KNOW HOW MANY ITEMS HAVE DEFECTS
6109C         --USE U AND C CHARTS IF KNOW HOW MANY DEFECTS
6110C     WRITTEN BY--JAMES J. FILLIBEN
6111C                 STATISTICAL ENGINEERING DIVISION
6112C                 INFORMATION TECHNOLOGY LABORATORY
6113C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
6114C                 GAITHERSBURG, MD 20899-8980
6115C                 PHONE--301-975-2899
6116C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
6117C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
6118C     REFERENCE--ASTM MANUAL STP-15D, PAGES 78-84, 100-105
6119C     REFERENCE--ISHIKAWA, GUIDE TO QUALITY CONTROL
6120C     LANGUAGE--ANSI FORTRAN (1977)
6121C     VERSION NUMBER--82/7
6122C     ORIGINAL VERSION--JUNE      1978.
6123C     UPDATED         --OCTOBER   1978.
6124C     UPDATED         --JANUARY   1981.
6125C     UPDATED         --DECEMBER  1981.
6126C     UPDATED         --APRIL     1982.
6127C     UPDATED         --MAY       1982.
6128C     UPDATED         --JANUARY  1988. P, PN, U, AND C CHARTS
6129C     UPDATED         --JULY     1990. FIX P, PN, U, & C CHARTS
6130C     UPDATED         --SEPTEMBER 1990. LSL, USL, TARGET
6131C     UPDATED         --MARCH     1997. EWMA CHART, ACTIVATE CUSUM
6132C     UPDATED         --MARCH     1997. MOVING AVERAGE CHART
6133C     UPDATED         --MARCH     1997. MOVING RANGE CHART
6134C     UPDATED         --MARCH     1997. MOVING STANDARD DEVIATION CHART
6135C     UPDATED         --JANUARY   2012. SUPPORT FOR HIGHLIGHTING OPTION
6136C     UPDATED         --JANUARY   2012. SUPPORT FOR WECO AND ISO 13528
6137C                                       CONTROL LIMITS
6138C     UPDATED         --JANUARY   2012. SUPPORT FOR "MAXSET" OPTION
6139C     UPDATED         --FEBRUARY  2012. ISO 13528 CONTROL CHART
6140C     UPDATED         --FEBRUARY  2012. ISO 13528 CUSUM CONTROL CHART
6141C
6142C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
6143C
6144      CHARACTER*4 ICASPL
6145      CHARACTER*4 IHIGH
6146      CHARACTER*4 ICONT
6147      CHARACTER*4 ICCHPR
6148      CHARACTER*4 ICCHWT
6149      CHARACTER*4 ICONWC
6150      CHARACTER*4 IBUGG3
6151      CHARACTER*4 ISUBRO
6152      CHARACTER*4 IERROR
6153C
6154      CHARACTER*4 ISUBN1
6155      CHARACTER*4 ISUBN2
6156      CHARACTER*4 ISTEPN
6157      CHARACTER*4 IWRITE
6158C
6159C---------------------------------------------------------------------
6160C
6161      DIMENSION Y(*)
6162      DIMENSION YN(*)
6163      DIMENSION X(*)
6164      DIMENSION Y2(*)
6165      DIMENSION X2(*)
6166      DIMENSION D2(*)
6167      DIMENSION XHIGH(*)
6168      DIMENSION YPREV(*)
6169C
6170      DIMENSION XIDTEM(*)
6171      DIMENSION TEMP(*)
6172CCCCC THE FOLLOWING LINE WAS ADDED JULY 1990
6173      DIMENSION TEMP2(*)
6174C
6175      DIMENSION A3(30)
6176      DIMENSION C4(30)
6177      DIMENSION B3(30)
6178      DIMENSION B4(30)
6179      DIMENSION E2(30)
6180      DIMENSION D22(30)
6181      DIMENSION D3(30)
6182      DIMENSION D4(30)
6183C
6184C---------------------------------------------------------------------
6185C
6186      INCLUDE 'DPCOP2.INC'
6187C
6188C-----DATA STATEMENTS-------------------------------------------------
6189C
6190CCCCC DATA(A(I),I=    1,   25)
6191CCCCC1/9.999,2.121,1.732,1.500,1.342,1.225,1.134,1.061,1.000,0.945,
6192CCCCC1 0.905,0.866,0.832,0.802,0.775,0.750,0.723,0.707,0.688,0.671,
6193CCCCC1 0.655,0.640,0.626,0.612,0.600/
6194CCCCC DATA(A0(I),I=    1,   25)
6195CCCCC1/9.999,3.760,3.070,2.914,2.884,2.899,2.935,2.980,3.030,3.085,
6196CCCCC1 3.136,3.189,3.242,3.295,3.347,3.398,3.448,3.497,3.545,3.592,
6197CCCCC1 3.639,3.684,3.729,3.773,3.816/
6198CCCCC DATA(A1(I),I=    1,   25)
6199CCCCC1/9.999,3.760,2.394,1.880,1.596,1.410,1.277,1.175,1.094,1.028,
6200CCCCC1 0.973,0.925,0.884,0.848,0.816,0.788,0.762,0.738,0.717,0.697,
6201CCCCC1 0.679,0.662,0.647,0.632,0.619/
6202CCCCC DATA(A2(I),I=    1,   25)
6203CCCCC1/9.999,1.880,1.023,0.729,0.577,0.483,0.419,0.373,0.337,0.308,
6204CCCCC1 0.285,0.266,0.249,0.235,0.223,0.212,0.203,0.194,0.187,0.180,
6205CCCCC1 0.173,0.167,0.162,0.157,0.153/
6206CCCCC DATA(C2(I),I=    1,   25)
6207CCCCC1/9.9999,0.5642,0.7236,0.7979,0.8407,
6208CCCCC1 0.8686,0.8882,0.9027,0.9139,0.9227,
6209CCCCC1 0.9300,0.9359,0.9410,0.9453,0.9490,
6210CCCCC1 0.9523,0.9551,0.9576,0.9599,0.9619,
6211CCCCC1 0.9638,0.9655,0.9670,0.9684,0.9696/
6212CCCCC DATA(B1(I),I=    1,   25)
6213CCCCC1/0.000,0.000,0.000,0.000,0.000,0.026,0.105,0.167,0.219,0.262,
6214CCCCC1 0.299,0.331,0.359,0.384,0.406,0.427,0.445,0.461,0.477,0.491,
6215CCCCC1 0.504,0.516,0.527,0.538,0.548/
6216CCCCC DATA(B2(I),I=    1,   25)
6217CCCCC1/9.999,1.843,1.858,1.808,1.756,1.711,1.672,1.638,1.609,1.584,
6218CCCCC1 1.561,1.541,1.523,1.507,1.492,1.478,1.465,1.454,1.443,1.433,
6219CCCCC1 1.424,1.415,1.407,1.399,1.392/
6220CCCCC DATA(D1(I),I=    1,   25)
6221CCCCC1/0.000,0.000,0.000,0.000,0.000,0.000,0.205,0.387,0.546,0.687,
6222CCCCC1 0.812,0.924,1.026,1.121,1.207,1.285,1.359,1.426,1.490,1.548,
6223CCCCC1 1.606,1.659,1.710,1.759,1.804/
6224C
6225      DATA(A3(I),I=    1,   25)
6226     1/9.999,2.659,1.954,1.628,1.427,
6227     1 1.287,1.182,1.099,1.032,0.975,
6228     1 0.927,0.886,0.850,0.817,0.789,
6229     1 0.763,0.739,0.718,0.698,0.680,
6230     1 0.663,0.647,0.633,0.619,0.606/
6231      DATA(C4(I),I=    1,   25)
6232     1/9.9999,0.7979,0.8862,0.9213,0.9400,
6233     1 0.9515,0.9594,0.9650,0.9693,0.9727,
6234     1 0.9754,0.9776,0.9794,0.9810,0.9823,
6235     1 0.9835,0.9845,0.9854,0.9862,0.9869,
6236     1 0.9876,0.9882,0.9887,0.9892,0.9896/
6237      DATA(B3(I),I=    1,   25)
6238     1/0.000,0.000,0.000,0.000,0.000,0.030,0.118,0.185,0.239,0.284,
6239     1 0.321,0.354,0.382,0.406,0.428,0.448,0.466,0.482,0.497,0.510,
6240     1 0.523,0.534,0.545,0.555,0.565/
6241      DATA(B4(I),I=    1,   25)
6242     1/9.999,3.267,2.568,2.266,2.089,1.970,1.882,1.815,1.761,1.716,
6243     1 1.679,1.646,1.618,1.594,1.572,1.552,1.534,1.518,1.503,1.490,
6244     1 1.477,1.466,1.455,1.445,1.435/
6245      DATA(E2(I),I=    1,   25)
6246     1/9.999,1.128,1.693,2.059,2.326,2.534,2.704,2.847,2.970,3.078,
6247     1 3.173,3.258,3.336,3.407,3.472,3.532,3.588,3.640,3.689,3.735,
6248     1 3.778,3.819,3.858,3.895,3.931/
6249      DATA(D22(I),I=    1,   25)
6250     1/9.999,3.686,4.358,4.698,4.918,5.078,5.203,5.307,5.394,5.469,
6251     1 5.534,5.592,5.646,5.693,5.737,5.779,5.817,5.854,5.888,5.922,
6252     1 5.950,5.979,6.006,6.031,6.058/
6253      DATA(D3(I),I=    1,   25)
6254     1/0.000,0.000,0.000,0.000,0.000,0.000,0.076,0.136,0.184,0.223,
6255     1 0.256,0.284,0.308,0.329,0.348,0.364,0.379,0.392,0.404,0.414,
6256     1 0.425,0.434,0.443,0.452,0.459/
6257      DATA(D4(I),I=    1,   25)
6258     1/9.999,3.267,2.575,2.282,2.115,2.004,1.924,1.864,1.816,1.777,
6259     1 1.744,1.716,1.692,1.671,1.652,1.636,1.621,1.608,1.596,1.586,
6260     1 1.575,1.566,1.557,1.548,1.541/
6261C
6262C-----START POINT-----------------------------------------------------
6263C
6264      ISUBN1='DPCC'
6265      ISUBN2='2   '
6266      IWRITE='OFF'
6267C
6268      XTMAX=0.0
6269      XTMIN=0.0
6270      D3FACT=0.0D0
6271      D4FACT=0.0D0
6272C
6273      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PCC2')THEN
6274        WRITE(ICOUT,70)
6275   70   FORMAT('AT THE BEGINNING OF DPCC2--')
6276        CALL DPWRST('XXX','BUG ')
6277        WRITE(ICOUT,71)N,NUMV2,ISIZE,MAXSET,ICASPL,ICONT
6278   71   FORMAT('N,NUMV2,ISIZE,MAXSET,ICASPL,ICONT = ',4I8,2(2X,A4))
6279        CALL DPWRST('XXX','BUG ')
6280        WRITE(ICOUT,75)ICCHPR,ICCHWT,ICONWC,USRSIG
6281   75   FORMAT('ICCHPR,ICCHWT,ICONWC,USRSIG = ',3(A4,2X),G15.7)
6282        CALL DPWRST('XXX','BUG ')
6283        DO72I=1,N
6284          WRITE(ICOUT,73)I,Y(I),YN(I),X(I),XHIGH(I)
6285   73     FORMAT('I,Y(I),YN(I),X(I),XHIGH(I) = ',I8,4G15.7)
6286          CALL DPWRST('XXX','BUG ')
6287   72   CONTINUE
6288      ENDIF
6289C
6290      I2=0
6291      ISIZE2=0
6292C
6293      AN=0.0
6294      XBARG=0.0
6295      SDG=0.0
6296      RANGEG=0.0
6297      YUPPER=0.0
6298      YLOWER=0.0
6299C
6300      ANUMSE=0.0
6301      SDI=0.0
6302      SIGMAE=0.0
6303      RANGEE=0.0
6304      SADJ=0.0
6305      RADJ=0.0
6306C
6307C     CHECK THE INPUT ARGUMENTS FOR ERRORS
6308C
6309      IF(N.LE.1)THEN
6310        WRITE(ICOUT,999)
6311  999   FORMAT(1X)
6312        CALL DPWRST('XXX','BUG ')
6313        WRITE(ICOUT,31)
6314   31   FORMAT('***** ERROR IN CONTROL CHART--')
6315        CALL DPWRST('XXX','BUG ')
6316        WRITE(ICOUT,32)
6317   32   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 2;')
6318        CALL DPWRST('XXX','BUG ')
6319        WRITE(ICOUT,34)N
6320   34   FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6)
6321        CALL DPWRST('XXX','BUG ')
6322        WRITE(ICOUT,999)
6323        CALL DPWRST('XXX','BUG ')
6324        IERROR='YES'
6325        GOTO9000
6326      ENDIF
6327C
6328      HOLD=Y(1)
6329      DO60I=1,N
6330      IF(Y(I).NE.HOLD)GOTO69
6331   60 CONTINUE
6332      WRITE(ICOUT,999)
6333      CALL DPWRST('XXX','BUG ')
6334      WRITE(ICOUT,31)
6335      CALL DPWRST('XXX','BUG ')
6336      WRITE(ICOUT,62)HOLD
6337   62 FORMAT('      ALL RESPONSE VARIABLE ELEMENTS ARE IDENTICALLY ',
6338     1       'EQUAL TO ',G15.7)
6339      CALL DPWRST('XXX','BUG ')
6340      WRITE(ICOUT,999)
6341      CALL DPWRST('XXX','BUG ')
6342      IERROR='YES'
6343      GOTO9000
6344   69 CONTINUE
6345C
6346C               ********************************************************
6347C               **  STEP 1--                                          **
6348C               **  DETERMINE THE NUMBER OF DISTINCT VALUES           **
6349C               **  FOR VARIABLE 2 (THE GROUP VARIABLE).              **
6350C               **  IF ALL VALUES ARE DISTINCT, THEN THIS             **
6351C               **  IMPLIES WE HAVE THE NO REPLICATION CASE           **
6352C               **  WHICH IS AN ERROR CONDITION FOR A CONTROL CHART.  **
6353C               ********************************************************
6354C
6355      ISTEPN='1'
6356      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PCC2')
6357     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6358C
6359      IF((IHIGH.EQ.'OFF'.AND.NUMV2.EQ.1) .OR.
6360     1   (IHIGH.EQ.'ON'.AND.NUMV2.EQ.2))THEN
6361C
6362C       WHEN THERE IS NO GROUP-ID VARIABLE, CREATE ONE (BASED ON
6363C       ISIZE).
6364C
6365        NUMSET=0
6366        IF(ISIZE.EQ.1)THEN
6367          DO120I=1,N
6368            XIDTEM(I)=REAL(I)
6369            X(I)=XIDTEM(I)
6370  120     CONTINUE
6371        ELSE
6372          NUMSET=0
6373          ILOOP=N/ISIZE
6374          DO145I=1,ILOOP
6375            NUMSET=NUMSET+1
6376            XIDTEM(NUMSET)=REAL(NUMSET)
6377            ISTART=(I-1)*ISIZE+1
6378            ISTOP=I*ISIZE
6379            DO147J=ISTART,ISTOP
6380              X(J)=XIDTEM(NUMSET)
6381  147       CONTINUE
6382  145     CONTINUE
6383          ILEFT=MOD(N,ISIZE)
6384          IF(ILEFT.NE.0)THEN
6385            ISTART=ILOOP*ISIZE+1
6386            NUMSET=NUMSET+1
6387            XIDTEM(NUMSET)=REAL(NUMSET)
6388            DO148J=ISTART,N
6389              X(J)=XIDTEM(NUMSET)
6390  148       CONTINUE
6391          ENDIF
6392        ENDIF
6393      ENDIF
6394C
6395C     WHEN THERE IS A GROUP-ID VARIABLE, EXTRACT UNIQUE VALUES
6396C
6397      CALL DISTIN(X,N,IWRITE,XIDTEM,NUMSET,IBUGG3,IERROR)
6398C
6399      IF(NUMSET.LT.1)THEN
6400        WRITE(ICOUT,999)
6401        CALL DPWRST('XXX','BUG ')
6402        WRITE(ICOUT,31)
6403        CALL DPWRST('XXX','BUG ')
6404        WRITE(ICOUT,192)
6405  192   FORMAT('      THE NUMBER OF SETS IS EQUAL TO ZERO.')
6406        CALL DPWRST('XXX','BUG ')
6407        IERROR='YES'
6408        GOTO9000
6409      ENDIF
6410C
6411      CALL SORT(XIDTEM,NUMSET,XIDTEM)
6412C
6413      IF((ICASPL.EQ.'MECC' .OR. ICASPL.EQ.'SDCC' .OR.
6414     1   ICASPL.EQ.'RACC') .AND.NUMSET.EQ.N)THEN
6415        WRITE(ICOUT,999)
6416        CALL DPWRST('XXX','BUG ')
6417        WRITE(ICOUT,31)
6418        CALL DPWRST('XXX','BUG ')
6419        WRITE(ICOUT,196)
6420  196   FORMAT('      THE NUMBER OF SETS IS IDENTICAL TO THE NUMBER ',
6421     1         'OF OBSERVATIONS.')
6422        CALL DPWRST('XXX','BUG ')
6423        WRITE(ICOUT,198)NUMSET
6424  198   FORMAT('      THEN  NUMBER OF SETS/OBSERVATIONS  = ',I8)
6425        CALL DPWRST('XXX','BUG ')
6426        IERROR='YES'
6427        GOTO9000
6428      ENDIF
6429C
6430      AN=N
6431      ANUMSE=NUMSET
6432C
6433C               *******************************************
6434C               **  STEP 3.0--                           **
6435C               **  DETERMINE STATISTICS FOR THE ENTIRE  **
6436C               **  DATA SET                             **
6437C               *******************************************
6438C
6439C     NOTE 2012/1: IN SOME CASES, WE MAY WANT TO BASE CONTROL
6440C                  LIMITS ON PORTION OF PLOT THAT IS KNOWN TO
6441C                  BE IN CONTROL (E.G., HISTORICAL DATA).  IF
6442C                  USER HAS SPECIFIED "MAXSET", ONLY USE SETS
6443C                  FROM 1 TO MAXSET IN COMPUTING THESE STATISTICS.
6444C
6445C                  FOR NOW, LIMIT THIS OPTION TO THE SHEWHART
6446C                  CHARTS (MEAN, SD, RANGE).
6447C
6448      ISTEPN='3.0'
6449      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PCC2')
6450     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6451C
6452      SUMXBG=0.0
6453      SUMSDG=0.0
6454      SUMRAG=0.0
6455      SUMSIE=0.0
6456      SUMRIE=0.0
6457C
6458      NUMTMP=NUMSET
6459      IF(MAXSET.GE.1 .AND. MAXSET.LT.NUMSET)THEN
6460        IF(ICASPL.EQ.'MECC' .OR. ICASPL.EQ.'RACC' .OR.
6461     1     ICASPL.EQ.'SDCC' .OR. ICASPL.EQ.'MACC' .OR.
6462     1     ICASPL.EQ.'MSCC' .OR. ICASPL.EQ.'MRCC')THEN
6463
6464          NUMTMP=MAXSET
6465        ENDIF
6466      ENDIF
6467C
6468      J=0
6469      ANTMP=0.0
6470      DO1010ISET=1,NUMTMP
6471        J=J+1
6472C
6473        K=0
6474        DO1020I=1,N
6475          IF(X(I).EQ.XIDTEM(ISET))K=K+1
6476          IF(X(I).EQ.XIDTEM(ISET))TEMP(K)=Y(I)
6477 1020   CONTINUE
6478        NI=K
6479        ANI=NI
6480C
6481        SUM=0.0
6482C
6483        IF(NI.LE.0)THEN
6484          WRITE(ICOUT,999)
6485          CALL DPWRST('XXX','BUG ')
6486          WRITE(ICOUT,31)
6487          CALL DPWRST('XXX','BUG ')
6488          WRITE(ICOUT,1042)
6489 1042     FORMAT('NI FOR SOME CLASS = 0')
6490          CALL DPWRST('XXX','BUG ')
6491          WRITE(ICOUT,1043)ISET,XIDTEM(ISET),NI
6492 1043     FORMAT('ISET,XIDTEM(ISET),NI = ',I8,G15.7,I8)
6493          CALL DPWRST('XXX','BUG ')
6494          IERROR='YES'
6495          GOTO9000
6496        ENDIF
6497C
6498        ANTMP=ANTMP+REAL(NI)
6499        CALL MEAN(TEMP,NI,IWRITE,XBARI,IBUGG3,IERROR)
6500        VARI=0.0
6501        IF(NI.GE.2)THEN
6502          CALL VAR(TEMP,NI,IWRITE,VARI,IBUGG3,IERROR)
6503        ENDIF
6504        SDI=0.0
6505        IF(VARI.GT.0.0)SDI=SQRT(VARI)
6506        XTMIN=TEMP(1)
6507        XTMAX=TEMP(1)
6508        DO1034I=1,NI
6509          IF(TEMP(I).LT.XTMIN)XTMIN=TEMP(I)
6510          IF(TEMP(I).GT.XTMAX)XTMAX=TEMP(I)
6511 1034   CONTINUE
6512        RANGEI=XTMAX-XTMIN
6513        SUMXBG=SUMXBG+ANI*XBARI
6514        SUMSDG=SUMSDG+ANI*SDI
6515        SUMRAG=SUMRAG+ANI*RANGEI
6516C
6517        IF(NI.LE.25)THEN
6518          SUMSIE=SUMSIE+SDI/C4(NI)
6519          SUMRIE=SUMRIE+RANGEI/D22(NI)
6520          AJUNK1=C4(NI)
6521          AJUNK2=D22(NI)
6522        ELSE
6523          C4LARG=1.0
6524          D22LAR=2.0*SQRT(2.0*LOG(2.0*ANI))
6525          SUMSIE=SUMSIE+SDI/C4LARG
6526          SUMRIE=SUMRIE+RANGEI/D22LAR
6527          AJUNK1=C4LARG
6528          AJUNK2=D22LAR
6529        ENDIF
6530C
6531        IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PCC2')THEN
6532          WRITE(ICOUT,1061)ISET,NI,ANI,XBARI
6533 1061     FORMAT('ISET,NI,ANI,XBARI = ',2I8,2G15.7)
6534          CALL DPWRST('XXX','BUG ')
6535          WRITE(ICOUT,1063)SDI,AJUNK1,SUMSIE
6536 1063     FORMAT('SDI,C4,SUMSIE = ',3G15.7)
6537          CALL DPWRST('XXX','BUG ')
6538          WRITE(ICOUT,1064)RANGEI,AJUNK2,SUMRIE
6539 1064     FORMAT('RANGEI,D22,SUMRIE = ',3G15.7)
6540          CALL DPWRST('XXX','BUG ')
6541        ENDIF
6542C
6543 1010 CONTINUE
6544C
6545      XBARG=SUMXBG/ANTMP
6546      SDG=SUMSDG/ANTMP
6547      RANGEG=SUMRAG/ANTMP
6548CCCCC SIGMAE=SUMSIE/REAL(MAXSET)
6549CCCCC RANGEE=SUMRIE/REAL(MAXSET)
6550      SIGMAE=SUMSIE/REAL(NUMTMP)
6551      RANGEE=SUMRIE/REAL(NUMTMP)
6552C
6553C     FOR UNGROUPED DATA, USE THE MOVING RANGE OR THE MOVING STANDARD
6554C     DEVIATION TO COMPUTE AN ESTIMATE FOR SIGMAE.  MARCH 1997.
6555C
6556      RANGEM=0.0
6557      SDM=0.0
6558      IF(N.EQ.NUMSET .AND. ICASPL.NE.'1352' .AND. ICASPL.NE.'1CUS')THEN
6559        IF(KWIDTH.LT.2)KWIDTH=2
6560        IF(KWIDTH.GT.N-1)KWIDTH=N-1
6561        NBEF=KWIDTH/2
6562        NAFT=NBEF
6563        IF(MOD(KWIDTH,2).EQ.0)NAFT=NBEF-1
6564        IF(1+NBEF.GT.NUMSET-NAFT)THEN
6565          WRITE(ICOUT,999)
6566          CALL DPWRST('XXXX','BUG ')
6567          WRITE(ICOUT,31)
6568          CALL DPWRST('XXXX','BUG ')
6569          WRITE(ICOUT,1071)
6570 1071     FORMAT('      THERE ARE NOT ENOUGH DATA POINTS TO FORM THE ',
6571     1           'MOVING RANGE ESTIMATE')
6572          CALL DPWRST('XXXX','BUG ')
6573          WRITE(ICOUT,1072)
6574 1072     FORMAT('      OF THE ERROR STANDARD DEVIATION FOR UNGROUPED ',
6575     1           'DATA.  YOU PROBABLY')
6576          CALL DPWRST('XXXX','BUG ')
6577          WRITE(ICOUT,1073)
6578 1073     FORMAT('      NEED TO SET A SMALLER VALUE FOR THE FILTER ',
6579     1           'WIDTH.  FOR EXAMPLE,')
6580          CALL DPWRST('XXXX','BUG ')
6581          WRITE(ICOUT,999)
6582          CALL DPWRST('XXXX','BUG ')
6583          WRITE(ICOUT,1074)
6584 1074     FORMAT('         LET K = 3')
6585          CALL DPWRST('XXXX','BUG ')
6586          WRITE(ICOUT,999)
6587          CALL DPWRST('XXXX','BUG ')
6588          WRITE(ICOUT,1075)
6589 1075     FORMAT('      THE PARAMETER K DEFINES HOW MANY VALUES ARE ',
6590     1           'USED TO COMUTE THE')
6591          CALL DPWRST('XXXX','BUG ')
6592          WRITE(ICOUT,1076)
6593 1076     FORMAT('      MOVING RANGE (3 IS THE TYPICAL VALUE).  THE ',
6594     1           'CURRENT VALUE')
6595          CALL DPWRST('XXXX','BUG ')
6596          WRITE(ICOUT,1077)KWIDTH
6597 1077     FORMAT('      OF K IS ',I5,'.')
6598          CALL DPWRST('XXXX','BUG ')
6599          IERROR='YES'
6600          GOTO9000
6601        ENDIF
6602C
6603        SUM=0.0
6604        SUM2=0.0
6605        ICOUNT=0
6606CCCCC   DO1083I=1+NBEF,MAXSET-NAFT
6607        DO1083I=1+NBEF,NUMTMP-NAFT
6608          ICOUNT=ICOUNT+1
6609          SUM1=0.0
6610          XTMIN=Y(I-NBEF)
6611          XTMAX=Y(I+NAFT)
6612          DO1086II=I-NBEF,I+NAFT
6613            IF(Y(II).LT.XTMIN)XTMIN=Y(II)
6614            IF(Y(II).GT.XTMAX)XTMAX=Y(II)
6615            SUM1=SUM1+Y(II)
6616 1086     CONTINUE
6617          SUM=SUM+(XTMAX-XTMIN)
6618          XMEAN=SUM1/REAL(KWIDTH)
6619          SUM1=0.0
6620          DO1087II=I-NBEF,I+NAFT
6621            SUM1=SUM1+(Y(II)-XMEAN)**2
6622 1087     CONTINUE
6623          SUM2=SUM2+SQRT(SUM1/REAL(KWIDTH-1))
6624 1083   CONTINUE
6625        RANGEM=SUM/REAL(ICOUNT)
6626        SDM=SUM2/REAL(ICOUNT)
6627      ENDIF
6628C
6629C           *********************************************************
6630C           **  STEP 4--                                           **
6631C           **  IN ORDER TO DETERMINE THE PROPER PLOT COOORDINATES **
6632C           **  FOR THE DESIRED PLOT,                              **
6633C           **  BRANCH TO THE PROPER SUBCASE--                     **
6634C           **         1) MEAN CONTROL CHART                       **
6635C           **         2) STANDARD DEVIATION CONTROL CHART         **
6636C           **         3) RANGE CONTROL CHART                      **
6637C           **         4) CUSUM CONTROL CHART                      **
6638C           **         5) P CONTROL CHART                          **
6639C           **         6) PN CONTROL CHART                         **
6640C           **         7) C CONTROL CHART                          **
6641C           **         8) U CONTROL CHART                          **
6642C           **         9) EWMA CONTROL CHART                       **
6643C           **        10) MOVING AVERAGE  CONTROL CHART            **
6644C           **        11) MOVING RANGE    CONTROL CHART            **
6645C           **        12) MOVING SD       CONTROL CHART            **
6646C           **        13) ISO 13528       CONTROL CHART            **
6647C           **        14) ISO 13528 CUSUM CONTROL CHART            **
6648C           *********************************************************
6649C
6650      ISTEPN='4'
6651      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PCC2')
6652     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6653C
6654      NPREV=0
6655      IF(ICASPL.EQ.'MECC')THEN
6656C
6657C       *****************************************
6658C       **  STEP 5.1--                         **
6659C       **  TREAT THE MEAN CONTROL CHART CASE  **
6660C       *****************************************
6661C
6662        ISTEPN='5.1'
6663        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PCC2')
6664     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6665C
6666        J=0
6667        DO1110ISET=1,NUMSET
6668C
6669          XTAG=0.0
6670          K=0
6671          DO1120I=1,N
6672            IF(X(I).EQ.XIDTEM(ISET))THEN
6673              K=K+1
6674              TEMP(K)=Y(I)
6675              IF(XHIGH(I).GE.0.5)XTAG=1.0
6676            ENDIF
6677 1120     CONTINUE
6678          NI=K
6679          ANI=NI
6680C
6681          IF(NI.LT.1)THEN
6682            WRITE(ICOUT,999)
6683            CALL DPWRST('XXX','BUG ')
6684            WRITE(ICOUT,31)
6685            CALL DPWRST('XXX','BUG ')
6686            WRITE(ICOUT,1132)
6687 1132       FORMAT('FOR SOME CLASS NI= 0')
6688            CALL DPWRST('XXX','BUG ')
6689            WRITE(ICOUT,1133)ISET,XIDTEM(ISET),NI
6690 1133       FORMAT('ISET,XIDTEM(ISET),NI = ',I8,G15.7,I8)
6691            CALL DPWRST('XXX','BUG ')
6692            IERROR='YES'
6693            GOTO9000
6694          ENDIF
6695C
6696          SUM=0.0
6697          DO1140I=1,NI
6698            SUM=SUM+TEMP(I)
6699 1140     CONTINUE
6700          XBARI=SUM/ANI
6701          YMID=XBARG
6702C
6703          IF(NI.GE.26)THEN
6704            C4LARG=1.0
6705            SADJ=C4LARG*SIGMAE
6706            A3LARG=3.0/SQRT(ANI)
6707            YUPPER=XBARG+A3LARG*SADJ
6708            YLOWER=XBARG-A3LARG*SADJ
6709            AJUNK1=C4LARG
6710            AJUNK2=A3LARG
6711          ELSE
6712            SADJ=C4(NI)*SIGMAE
6713            YUPPER=XBARG+A3(NI)*SADJ
6714            YLOWER=XBARG-A3(NI)*SADJ
6715            AJUNK1=C4(NI)
6716            AJUNK2=A3(NI)
6717          ENDIF
6718C
6719          IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PCC2')THEN
6720            WRITE(ICOUT,1161)ISET,NI,ANI,XBARI,XBARG
6721 1161       FORMAT('ISET,NI,ANI,XBARI,XBARG = ',2I8,3G15.7)
6722            CALL DPWRST('XXX','BUG ')
6723            WRITE(ICOUT,1163)SDI,AJUNK1,SIGMAE,SADJ
6724 1163       FORMAT('SDI,AJUNK1,SIGMAE,SADJ = ',4G15.7)
6725            CALL DPWRST('XXX','BUG ')
6726            WRITE(ICOUT,1165)YMID,AJUNK2,YUPPER,YLOWER
6727 1165       FORMAT('YMID,A3,YUPPER,YLOWER = ',4G15.7)
6728            CALL DPWRST('XXX','BUG ')
6729          ENDIF
6730C
6731          CALL DPCC3(ICASPL,J,XBARI,YMID,YLOWER,YUPPER,
6732     1               Y2,X2,D2,XIDTEM(ISET),
6733     1               YPREV,NPREV,IHIGH,XTAG,SIGMAE,
6734     1               CCLSL,CCUSL,CCTARG,ICONWC,
6735     1               IBUGG3,ISUBRO,IERROR)
6736C
6737 1110   CONTINUE
6738      ELSEIF(ICASPL.EQ.'SDCC')THEN
6739C
6740C       ********************************************************
6741C       **  STEP 5.2--                                        **
6742C       **  TREAT THE  STANDARD DEVIATION CONTROL CHART CASE  **
6743C       ********************************************************
6744C
6745        ISTEPN='5.2'
6746        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PCC2')
6747     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6748C
6749        J=0
6750        DO1210ISET=1,NUMSET
6751C
6752          XTAG=0.0
6753          K=0
6754          DO1220I=1,N
6755            IF(X(I).EQ.XIDTEM(ISET))THEN
6756              K=K+1
6757              TEMP(K)=Y(I)
6758              IF(XHIGH(I).GE.0.5)XTAG=1.0
6759            ENDIF
6760 1220     CONTINUE
6761          NI=K
6762          ANI=NI
6763C
6764          IF(NI.LT.1)THEN
6765            WRITE(ICOUT,999)
6766            CALL DPWRST('XXX','BUG ')
6767            WRITE(ICOUT,31)
6768            CALL DPWRST('XXX','BUG ')
6769            WRITE(ICOUT,1132)
6770            CALL DPWRST('XXX','BUG ')
6771            WRITE(ICOUT,1133)ISET,XIDTEM(ISET),NI
6772            CALL DPWRST('XXX','BUG ')
6773            IERROR='YES'
6774            GOTO9000
6775          ENDIF
6776C
6777          SUM=0.0
6778          DO1240I=1,NI
6779            SUM=SUM+TEMP(I)
6780 1240     CONTINUE
6781          XBARI=SUM/ANI
6782C
6783          IF(NI.LE.1)GOTO1210
6784C
6785          SUM=0.0
6786          DO1250I=1,NI
6787            SUM=SUM+(TEMP(I)-XBARI)**2
6788 1250     CONTINUE
6789          DENOM=ANI-1.0
6790          VARI=0.0
6791          IF(NI.GE.2)VARI=SUM/DENOM
6792          SDI=0.0
6793          IF(VARI.GT.0.0)SDI=SQRT(VARI)
6794C
6795          IF(NI.GE.26)THEN
6796            C4LARG=1.0
6797            SADJ=C4LARG*SIGMAE
6798            B4LARG=1.0+3.0/SQRT(2.0*(ANI-1.0))
6799            B3LARG=1.0-3.0/SQRT(2.0*(ANI-1.0))
6800            YUPPER=B4LARG*SADJ
6801            YLOWER=B3LARG*SADJ
6802            AJUNK1=C4LARG
6803            AJUNK2=B4LARG
6804            AJUNK3=B3LARG
6805          ELSE
6806            SADJ=C4(NI)*SIGMAE
6807            YUPPER=B4(NI)*SADJ
6808            YLOWER=B3(NI)*SADJ
6809            AJUNK1=C4(NI)
6810            AJUNK2=B4(NI)
6811            AJUNK3=B3(NI)
6812          ENDIF
6813C
6814          IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PCC2')THEN
6815            WRITE(ICOUT,1261)ISET,NI,ANI,XBARI
6816 1261       FORMAT('ISET,NI,ANI,XBARI = ',2I8,2G15.7)
6817            CALL DPWRST('XXX','BUG ')
6818            WRITE(ICOUT,1263)SDI,AJUNK1,SIGMAE,SADJ,YMID
6819 1263       FORMAT('SDI,C4,SIGMAE,SADJ,YMID = ',5G15.7)
6820            CALL DPWRST('XXX','BUG ')
6821            WRITE(ICOUT,1265)YMID,AJUNK2,AJUNK3,YUPPER,YLOWER
6822 1265       FORMAT('YMID,B4,YUPPER,B3,YLOWER = ',4G15.7)
6823            CALL DPWRST('XXX','BUG ')
6824          ENDIF
6825C
6826          CALL DPCC3(ICASPL,J,SDI,SADJ,YLOWER,YUPPER,
6827     1               Y2,X2,D2,XIDTEM(ISET),
6828     1               YPREV,NPREV,IHIGH,XTAG,SIGMAE,
6829     1               CCLSL,CCUSL,CCTARG,ICONWC,
6830     1               IBUGG3,ISUBRO,IERROR)
6831C
6832 1210   CONTINUE
6833      ELSEIF(ICASPL.EQ.'RACC')THEN
6834C
6835C       ******************************************
6836C       **  STEP 5.3--                          **
6837C       **  TREAT THE RANGE CONTROL CHART CASE  **
6838C       ******************************************
6839C
6840        ISTEPN='5.3'
6841        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PCC2')
6842     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6843C
6844        D4FACT=1.25
6845        D3FACT=1.0/1.25
6846C
6847        J=0
6848        DO1310ISET=1,NUMSET
6849C
6850          XTAG=0.0
6851          K=0
6852          DO1320I=1,N
6853            IF(X(I).EQ.XIDTEM(ISET))THEN
6854              K=K+1
6855              TEMP(K)=Y(I)
6856              IF(XHIGH(I).GE.0.5)XTAG=1.0
6857            ENDIF
6858 1320     CONTINUE
6859          NI=K
6860          ANI=NI
6861C
6862          IF(NI.LT.1)THEN
6863            WRITE(ICOUT,999)
6864            CALL DPWRST('XXX','BUG ')
6865            WRITE(ICOUT,31)
6866            CALL DPWRST('XXX','BUG ')
6867            WRITE(ICOUT,1132)
6868            CALL DPWRST('XXX','BUG ')
6869            WRITE(ICOUT,1133)ISET,XIDTEM(ISET),NI
6870            CALL DPWRST('XXX','BUG ')
6871            IERROR='YES'
6872            GOTO9000
6873          ENDIF
6874C
6875          IF(NI.LE.1)GOTO1310
6876C
6877          XTMIN=TEMP(1)
6878          XTMAX=TEMP(1)
6879          DO1340I=1,NI
6880            IF(TEMP(I).LT.XTMIN)XTMIN=TEMP(I)
6881            IF(TEMP(I).GT.XTMAX)XTMAX=TEMP(I)
6882 1340     CONTINUE
6883          RANGEI=XTMAX-XTMIN
6884C
6885          IF(NI.GE.26)THEN
6886            D22LAR=2.0*SQRT(2.0*LOG(2.0*ANI))
6887            RADJ=D22LAR*RANGEE
6888            D4LARG=1.0+3.0*D4FACT/SQRT(2.0*(ANI-1.0))
6889            D3LARG=1.0-3.0*D3FACT/SQRT(2.0*(ANI-1.0))
6890            YUPPER=D4LARG*RADJ
6891            YLOWER=D3LARG*RADJ
6892            AJUNK1=D22LAR
6893            AJUNK2=D4LARG
6894            AJUNK3=D3LARG
6895          ELSE
6896            RADJ=D22(NI)*RANGEE
6897            YUPPER=D4(NI)*RADJ
6898            YLOWER=D3(NI)*RADJ
6899            AJUNK1=D22(NI)
6900            AJUNK2=D4(NI)
6901            AJUNK3=D3(NI)
6902          ENDIF
6903          YMID=RADJ
6904C
6905          IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PCC2')THEN
6906            WRITE(ICOUT,1361)ISET,NI,ANI,RANGEI,YMID
6907 1361       FORMAT('ISET,NI,ANI,YMID = ',2I8,3G15.7)
6908            CALL DPWRST('XXX','BUG ')
6909            WRITE(ICOUT,1363)RANGEI,AJUNK1,RANGEE,SADJ,RADJ
6910 1363       FORMAT('RANGEI,D22,RANGEE,SADJ,RADJ = ',5G15.7)
6911            CALL DPWRST('XXX','BUG ')
6912            WRITE(ICOUT,1365)NI,ANI,AJUNK2,YUPPER,AJUNK3,YLOWER
6913 1365       FORMAT('NI,ANI,D4,YUPPER,D3,YLOWER = ',I8,5G15.7)
6914            CALL DPWRST('XXX','BUG ')
6915          ENDIF
6916C
6917          CALL DPCC3(ICASPL,J,RANGEI,YMID,YLOWER,YUPPER,
6918     1               Y2,X2,D2,XIDTEM(ISET),
6919     1               YPREV,NPREV,IHIGH,XTAG,RANGEE,
6920     1               CCLSL,CCUSL,CCTARG,ICONWC,
6921     1               IBUGG3,ISUBRO,IERROR)
6922C
6923 1310   CONTINUE
6924      ELSEIF(ICASPL.EQ.'CUCC')THEN
6925C
6926C       ******************************************************
6927C       **  STEP 5.4--                                      **
6928C       **  DETERMINE PLOT COORDINATES                      **
6929C       **  FOR THE CUSUM CONTROL CHART PLOT SUBCASE.       **
6930C       ******************************************************
6931C
6932        ISTEPN='5.4'
6933        IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PCC2')
6934     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6935C
6936        J=0
6937C
6938        SUMH=0.0
6939        SUML=0.0
6940        IF(SHI.NE.CPUMIN)SUMH=SHI
6941        IF(SLI.NE.CPUMIN)SUML=SLI
6942        ZHIGH=3.5
6943        IF(CCUSL.NE.CPUMIN)ZHIGH=CCUSL
6944C
6945        DO1410ISET=1,NUMSET
6946C
6947          K=0
6948          XTAG=0.0
6949          DO1420I=1,N
6950            IF(X(I).EQ.XIDTEM(ISET))K=K+1
6951            IF(X(I).EQ.XIDTEM(ISET))TEMP(K)=Y(I)
6952            IF(XHIGH(I).GE.0.5)XTAG=1.0
6953 1420     CONTINUE
6954          NI=K
6955          ANI=NI
6956C
6957          IF(NI.LT.1)THEN
6958            WRITE(ICOUT,999)
6959            CALL DPWRST('XXX','BUG ')
6960            WRITE(ICOUT,31)
6961            CALL DPWRST('XXX','BUG ')
6962            WRITE(ICOUT,1132)
6963            CALL DPWRST('XXX','BUG ')
6964            WRITE(ICOUT,1133)ISET,XIDTEM(ISET),NI
6965            CALL DPWRST('XXX','BUG ')
6966            IERROR='YES'
6967            GOTO9000
6968          ENDIF
6969C
6970          IF(NI.EQ.1)THEN
6971            ZI=(TEMP(1)-XBARG)/RANGEM
6972          ELSE
6973            SUM=0.0
6974            DO1441I=1,NI
6975              SUM=SUM+TEMP(I)
6976 1441       CONTINUE
6977            XBARI=SUM/ANI
6978            ZI=(XBARI-XBARG)/SIGMAE
6979          ENDIF
6980C
6981          SUMH=MAX(0.0,SUMH+(ZI-AK))
6982          SUML=MAX(0.0,SUML+(-ZI-AK))
6983C
6984          IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PCC2')THEN
6985            WRITE(ICOUT,1461)ISET,NI,ANI,XBARI
6986 1461       FORMAT('ISET,NI,ANI,XBARI = ',2I8,2G15.7)
6987            CALL DPWRST('XXX','BUG ')
6988            WRITE(ICOUT,1463)ZI,SUMH,SUML
6989 1463       FORMAT('ZI,SUMH,SUML = ',3G15.7)
6990            CALL DPWRST('XXX','BUG ')
6991          ENDIF
6992C
6993          YUPPER=H
6994          YLOWER=-H
6995C
6996          J=J+1
6997          Y2(J)=SUMH
6998          X2(J)=XIDTEM(ISET)
6999          D2(J)=1.0
7000C
7001          J=J+1
7002          Y2(J)=-SUML
7003          X2(J)=XIDTEM(ISET)
7004          D2(J)=2.0
7005C
7006          J=J+1
7007          Y2(J)=0.0
7008          X2(J)=XIDTEM(ISET)
7009          D2(J)=3.0
7010C
7011          J=J+1
7012          Y2(J)=YUPPER
7013          X2(J)=XIDTEM(ISET)
7014          D2(J)=4.0
7015C
7016          J=J+1
7017          Y2(J)=YLOWER
7018          X2(J)=XIDTEM(ISET)
7019          D2(J)=5.0
7020C
7021          IF(ZI.LE.ZHIGH)GOTO1472
7022          J=J+1
7023          Y2(J)=SUMH
7024          X2(J)=XIDTEM(ISET)
7025          D2(J)=6.0
7026          J=J+1
7027          Y2(J)=SUML
7028          X2(J)=XIDTEM(ISET)
7029          D2(J)=7.0
7030 1472     CONTINUE
7031C
7032 1410   CONTINUE
7033      ELSEIF(ICASPL.EQ.'PCC')THEN
7034C
7035C       ********************************************************
7036C       **  STEP 5.5--                                        **
7037C       **  TREAT THE  P CONTROL CHART CASE                   **
7038C       **  PROPORTION DEFECTIVE PER BATCH (SUBSAMPLE)        **
7039C       **  NUMBER DEFECTIVE PER BATCH / TOTAL NUMBER IN BATCH**
7040C       **  THE INPUT IS A DUAL SERIES--                      **
7041C       **     1) NUMBER OF DEFECTIVE ITEMS IN THE SUBSAMPLE  **
7042C       **     2) TOTAL NUMBER OF ITEMS IN THE SAMPLE         **
7043C       **  THE CONFIDENCE BAND IS GOTTEN BY ASSUMING BINOMIAL**
7044C       ********************************************************
7045C
7046        ISTEPN='5.5'
7047        IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PCC2')
7048     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7049C
7050        SUM1=0.0
7051        SUM2=0.0
7052        DO1510ISET=1,NUMSET
7053          SUM1=SUM1+Y(ISET)
7054          SUM2=SUM2+YN(ISET)
7055 1510   CONTINUE
7056        CTOTAL=SUM1
7057        ANTOT=SUM2
7058        PBARG=CTOTAL/ANTOT
7059        PRBARG=100.0*PBARG
7060C
7061        J=0
7062        XTAG=0.0
7063        DO1550ISET=1,NUMSET
7064C
7065          CI=Y(ISET)
7066          ANI=YN(ISET)
7067          NI=INT(ANI+0.5)
7068          IF(NI.LE.0)GOTO1550
7069C
7070          PI=CI/ANI
7071          PROPI=100.0*PI
7072          YMID=PRBARG
7073          VARPI=0.0
7074          IF(ANI.GT.0.0)VARPI=PBARG*(1.0-PBARG)/ANI
7075          SDPI=0.0
7076          IF(VARPI.GT.0.0)SDPI=SQRT(VARPI)
7077          SDPRI=100.0*SDPI
7078          YUPPER=YMID+3.0*SDPRI
7079          IF(YUPPER.GT.100.0)YUPPER=100.0
7080          YLOWER=YMID-3.0*SDPRI
7081          IF(YLOWER.LT.0.0)YLOWER=0.0
7082C
7083          CALL DPCC3(ICASPL,J,PROPI,YMID,YLOWER,YUPPER,
7084     1               Y2,X2,D2,XIDTEM(ISET),
7085     1               YPREV,NPREV,IHIGH,XTAG,SIGMAE,
7086     1               CCLSL,CCUSL,CCTARG,ICONWC,
7087     1               IBUGG3,ISUBRO,IERROR)
7088C
7089 1550   CONTINUE
7090C
7091      ELSEIF(ICASPL.EQ.'PNCC')THEN
7092C
7093C       *************************************************************
7094C       **  STEP 5.6--                                             **
7095C       **  TREAT THE PN CONTROL CHART CASE                        **
7096C       **  TOTAL NUMBER DEFECTIVE IN A BATCH (SUBSAMPLE)          **
7097C       **  SUM UP THE NUMBER OF DEFECTIVES PER BATCH (SUBSAMPLE)  **
7098C       **  THE NUMBER WILL BE  A NON-NEGATIVE INTEGER             **
7099C       **  THE INPUT IS A DUAL SERIES--                           **
7100C       **     1) NUMBER OF DEFECTIVE ITEMS IN THE SUBSAMPLE       **
7101C       **     2) TOTAL NUMBER OF ITEMS IN THE SAMPLE              **
7102C       **  THE CONFIDENCE BAND IS GOTTEN BY ASSUMING BINOMIAL     **
7103C       **  NOTE--THE PN CHART SHOULD BE USED ONLY WHEN            **
7104C       **        THE SUBSAMPLE SIZE IS CONSTANT.                  **
7105C       **        FOR VARYING SUBSAMPLE SIZE, USE THE P CHART      **
7106C       **        (ISHIKAWA, GUIDE TO QUALITY CONTROL, PAGE 77)    **
7107C       *************************************************************
7108C
7109        ISTEPN='5.6'
7110        IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PCC2')
7111     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7112C
7113        XTAG=0.0
7114        SUM1=0.0
7115        SUM2=0.0
7116        ANUMSE=NUMSET
7117        DO1610ISET=1,NUMSET
7118          SUM1=SUM1+Y(ISET)
7119          SUM2=SUM2+YN(ISET)
7120 1610   CONTINUE
7121        CTOTAL=SUM1
7122        ANTOT=SUM2
7123        PBARG=CTOTAL/ANTOT
7124        ANBARG=ANTOT/ANUMSE
7125        CBARG=PBARG*ANBARG
7126C
7127        J=0
7128        DO1650ISET=1,NUMSET
7129C
7130          CI=Y(ISET)
7131          ANI=YN(ISET)
7132          NI=INT(ANI+0.5)
7133          IF(NI.LE.0)GOTO1650
7134C
7135          PI=CI/ANI
7136          TAGI=XIDTEM(ISET)
7137          YMID=CBARG
7138          VARCI=0.0
7139          IF(ANBARG.GT.0.0)VARCI=ANBARG*PBARG*(1.0-PBARG)
7140          SDCI=0.0
7141          IF(VARCI.GT.0.0)SDCI=SQRT(VARCI)
7142          YUPPER=YMID+3.0*SDCI
7143          YLOWER=YMID-3.0*SDCI
7144          IF(YLOWER.LT.0.0)YLOWER=0.0
7145C
7146          CALL DPCC3(ICASPL,J,CI,YMID,YLOWER,YUPPER,
7147     1               Y2,X2,D2,XIDTEM(ISET),
7148     1               YPREV,NPREV,IHIGH,XTAG,SIGMAE,
7149     1               CCLSL,CCUSL,CCTARG,ICONWC,
7150     1               IBUGG3,ISUBRO,IERROR)
7151C
7152 1650   CONTINUE
7153      ELSEIF(ICASPL.EQ.'UCC')THEN
7154C
7155C       *********************************************************
7156C       **  STEP 5.7--                                         **
7157C       **  TREAT THE U CONTROL CHART CASE (POISSON)           **
7158C       **  DEFECTIVE PER UNIT                                 **
7159C       **  DEFECTIVE PER UNIT AREA                            **
7160C       **  NUMBER DEFECTIVE PER SUB-BATCH / LENGTH OR AREA    **
7161C       **  THE INPUT IS A DUAL SERIES--                       **
7162C       **     1) NUMBER OF DEFECTIVE ITEMS IN THE SUBSAMPLE   **
7163C       **     2) LENGTH OR AREA OF THE ITEM                   **
7164C       **  THE CONFIDENCE BAND IS GOTTEN BY ASSUMING POISSON  **
7165C       *********************************************************
7166C
7167        ISTEPN='5.7'
7168        IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PCC2')
7169     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7170C
7171        XTAG=0.0
7172        SUM1=0.0
7173        SUM2=0.0
7174        DO1710ISET=1,NUMSET
7175          SUM1=SUM1+Y(ISET)
7176          SUM2=SUM2+YN(ISET)
7177 1710   CONTINUE
7178        CTOTAL=SUM1
7179        SIZTOT=SUM2
7180        CBARG=CTOTAL/SIZTOT
7181C
7182        J=0
7183        DO1750ISET=1,NUMSET
7184C
7185          CI=Y(ISET)
7186          SIZEI=YN(ISET)
7187          NSIZEI=INT(SIZEI+0.5)
7188          IF(NSIZEI.LE.0)GOTO1750
7189          STAT=-1.0
7190          IF(SIZEI.NE.0.0)STAT=CI/SIZEI
7191          YMID=CBARG
7192          VARCI=0.0
7193          IF(ANI.GT.0.0)VARCI=CBARG/SIZEI
7194          SDCI=0.0
7195          IF(VARCI.GT.0.0)SDCI=SQRT(VARCI)
7196          YUPPER=YMID+3.0*SDCI
7197          YLOWER=YMID-3.0*SDCI
7198          IF(YLOWER.LT.0.0)YLOWER=0.0
7199C
7200          CALL DPCC3(ICASPL,J,STAT,YMID,YLOWER,YUPPER,
7201     1               Y2,X2,D2,XIDTEM(ISET),
7202     1               YPREV,NPREV,IHIGH,XTAG,SIGMAE,
7203     1               CCLSL,CCUSL,CCTARG,ICONWC,
7204     1               IBUGG3,ISUBRO,IERROR)
7205C
7206 1750   CONTINUE
7207      ELSEIF(ICASPL.EQ.'CCC')THEN
7208C
7209C       ********************************************************
7210C       **  STEP 5.8--                                        **
7211C       **  TREAT THE C CONTROL CHART CASE (POISSON)          **
7212C       **  TOTAL NUMBER DEFECTIVE IN A BATCH (SUBSAMPLE)     **
7213C       **  SUM OF DEFECTIVES IN A BATCH (SUBSAMPLE)          **
7214C       **  THE INPUT IS USUALLY A SERIES OF INTEGERS         **
7215C       **  THE VALUE WILL BE A NON-NEGATIVE INTEGER          **
7216C       **  THE CONFIDENCE BAND IS GOTTEN BY ASSUMING POISSON **
7217C       **  NOTE--THE C CHART SHOULD BE USED ONLY WHEN        **
7218C       **        THE SUBSAMPLE SIZE IS CONSTANT.             **
7219C       **        FOR VARYING SUBSAMPLE SIZE, USE THE U CHART **
7220C       **        (ISHIKAWA, GUIDE TO QUALITY CONTROL, PAGE 77)*
7221C       ********************************************************
7222C
7223        ISTEPN='5.8'
7224        IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PCC2')
7225     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7226C
7227        XTAG=0.0
7228        SUM1=0.0
7229        SUM2=0.0
7230        ANUMSE=NUMSET
7231        DO1810ISET=1,NUMSET
7232          SUM1=SUM1+Y(ISET)
7233          IF(NUMV2.LE.2)SUM2=SUM2+1
7234          IF(NUMV2.GE.3)SUM2=SUM2+YN(ISET)
7235 1810   CONTINUE
7236        CTOTAL=SUM1
7237        CBARG=CTOTAL/ANUMSE
7238C
7239        J=0
7240        DO1850ISET=1,NUMSET
7241C
7242          CI=Y(ISET)
7243          SIZEI=YN(ISET)
7244          NSIZEI=INT(SIZEI+0.5)
7245          IF(NSIZEI.LE.0)GOTO1850
7246          YMID=CBARG
7247          VARCI=0.0
7248          IF(ANI.GT.0.0)VARCI=CBARG
7249          SDCI=0.0
7250          IF(VARCI.GT.0.0)SDCI=SQRT(VARCI)
7251          YUPPER=YMID+3.0*SDCI
7252          YLOWER=YMID-3.0*SDCI
7253          IF(YLOWER.LT.0.0)YLOWER=0.0
7254C
7255          CALL DPCC3(ICASPL,J,CI,YMID,YLOWER,YUPPER,
7256     1               Y2,X2,D2,XIDTEM(ISET),
7257     1               YPREV,NPREV,IHIGH,XTAG,SIGMAE,
7258     1               CCLSL,CCUSL,CCTARG,ICONWC,
7259     1               IBUGG3,ISUBRO,IERROR)
7260C
7261 1850   CONTINUE
7262      ELSEIF(ICASPL.EQ.'EWCC')THEN
7263C
7264C       *****************************************
7265C       **  STEP 5.9--                         **
7266C       **  TREAT THE EXPONETIALLY WEIGHTED    **
7267C       **  CONTROL CHART CASE                 **
7268C       *****************************************
7269C
7270        ISTEPN='5.9'
7271        IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PCC2')
7272     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7273C
7274        IF(P.GE.1.0 .AND. P.LE.100.)P=P/100.
7275        IF(P.LE.0.0 .OR. P.GE.1.0)THEN
7276          WRITE(ICOUT,999)
7277          CALL DPWRST('XXX','BUG ')
7278          WRITE(ICOUT,31)
7279          CALL DPWRST('XXX','BUG ')
7280          WRITE(ICOUT,1901)
7281 1901     FORMAT('      FOR THE EWMA CONTROL CHARTS, THE WEIGHTING',
7282     1           ' PARAMETER P MUST BE SPECIFIED')
7283          CALL DPWRST('XXX','BUG ')
7284          WRITE(ICOUT,1902)
7285 1902     FORMAT('     AND IN THE RANGE (0,1).  IT IS TYPICALLY ',
7286     1           ' BETWEEN 0.1 AND 0.5 .')
7287          CALL DPWRST('XXX','BUG ')
7288          WRITE(ICOUT,1903)
7289 1903     FORMAT('     FOR EXAMPLE: LET P = 0.2 ')
7290          CALL DPWRST('XXX','BUG ')
7291          IERROR='YES'
7292          GOTO9000
7293        ENDIF
7294C
7295        J=0
7296        IF(CCTARG.NE.CPUMIN)THEN
7297          AK0=CCTARG
7298        ELSE
7299          AK0=XBARG
7300        ENDIF
7301        YMID=AK0
7302C
7303        DO1910ISET=1,NUMSET
7304C
7305          K=0
7306          XTAG=0.0
7307          DO1920I=1,N
7308            IF(X(I).EQ.XIDTEM(ISET))K=K+1
7309            IF(X(I).EQ.XIDTEM(ISET))TEMP(K)=Y(I)
7310            IF(XHIGH(I).GE.0.5)XTAG=1.0
7311 1920     CONTINUE
7312          NI=K
7313          ANI=NI
7314C
7315          IF(NI.LT.1)THEN
7316            WRITE(ICOUT,999)
7317            CALL DPWRST('XXX','BUG ')
7318            WRITE(ICOUT,31)
7319            CALL DPWRST('XXX','BUG ')
7320            WRITE(ICOUT,1132)
7321            CALL DPWRST('XXX','BUG ')
7322            WRITE(ICOUT,1133)ISET,XIDTEM(ISET),NI
7323            CALL DPWRST('XXX','BUG ')
7324            IERROR='YES'
7325            GOTO9000
7326          ENDIF
7327C
7328          SUM=0.0
7329          DO1940I=1,NI
7330            SUM=SUM+TEMP(I)
7331 1940     CONTINUE
7332          XBARI=SUM/ANI
7333C
7334          AK1=P*XBARI + (1.0-P)*AK0
7335          IF(N.NE.NUMSET)THEN
7336            SADJ=SIGMAE*3.0902*SQRT(P/(ANI*(2.0-P)))
7337          ELSE
7338            IF(KWIDTH.LE.25)THEN
7339              SADJ=(RANGEM/E2(KWIDTH))*3.0902*SQRT(P/(ANI*(2.0-P)))
7340            ELSE
7341              SADJ=(RANGEM/E2(25))*3.0902*SQRT(P/(ANI*(2.0-P)))
7342            ENDIF
7343          ENDIF
7344          YUPPER=XBARG+SADJ
7345          YLOWER=XBARG-SADJ
7346C
7347          IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PCC2')THEN
7348            WRITE(ICOUT,1961)ISET,NI,ANI,XBARI
7349 1961       FORMAT('ISET,NI,ANI,XBARI = ',2I8,2G15.7)
7350            CALL DPWRST('XXX','BUG ')
7351            WRITE(ICOUT,1963)SDI,SIGMAE,SADJ,XBARG
7352 1963       FORMAT('SDI,SIGMAE,SADJ,XBARG = ',4G15.7)
7353            CALL DPWRST('XXX','BUG ')
7354            WRITE(ICOUT,1964)AK0,AK1,YLOWER,YUPPER
7355 1964       FORMAT('AK0,AK1,YLOWER,YUPPER = ',4G15.7)
7356            CALL DPWRST('XXX','BUG ')
7357          ENDIF
7358C
7359          CALL DPCC3(ICASPL,J,AK1,XBARG,YLOWER,YUPPER,
7360     1               Y2,X2,D2,XIDTEM(ISET),
7361     1               YPREV,NPREV,IHIGH,XTAG,SIGMAE,
7362     1               CCLSL,CCUSL,CCTARG,ICONWC,
7363     1               IBUGG3,ISUBRO,IERROR)
7364C
7365          AK0=AK1
7366C
7367 1910   CONTINUE
7368      ELSEIF(ICASPL.EQ.'MACC')THEN
7369C
7370C       *****************************************
7371C       **  STEP 5.10--                        **
7372C       **  TREAT THE MOVING AVERAGE           **
7373C       **  CONTROL CHART CASE                 **
7374C       *****************************************
7375C
7376        ISTEPN='5.10'
7377        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PCC2')
7378     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7379C
7380        IF(KWIDTH.LT.2)KWIDTH=2
7381        IF(KWIDTH.GT.N-1)KWIDTH=N-1
7382        AK=REAL(KWIDTH)
7383        NBEF=KWIDTH/2
7384        NAFT=NBEF
7385        IF(MOD(KWIDTH,2).EQ.0)NAFT=NBEF-1
7386C
7387        J=0
7388        XTAG=0.0
7389C
7390C       2 CASES:
7391C         1) UNGROUPED DATA (N=NUMSET)
7392C         2) GROUPED DATA (N> NUMSET).  FOR GROUPED DATA, EACH GROUP
7393C            SHOULD HAVE AT LEAST 2 VALUES.
7394C
7395C       UNGROUPED CASE
7396C
7397        IF(N.EQ.NUMSET)THEN
7398          DO2002ISET=1,N
7399            TEMP2(ISET)=Y(ISET)
7400 2002     CONTINUE
7401        ELSE
7402C
7403C         GROUPED CASE
7404C
7405          DO2010ISET=1,NUMSET
7406C
7407            K=0
7408            DO2020I=1,N
7409              IF(X(I).EQ.XIDTEM(ISET))THEN
7410                K=K+1
7411                TEMP(K)=Y(I)
7412              ENDIF
7413 2020       CONTINUE
7414            NI=K
7415            ANI=NI
7416C
7417            IF(NI.LT.1)THEN
7418              WRITE(ICOUT,999)
7419              CALL DPWRST('XXX','BUG ')
7420              WRITE(ICOUT,31)
7421              CALL DPWRST('XXX','BUG ')
7422              WRITE(ICOUT,2032)
7423 2032         FORMAT('FOR MOVING AVERAGE, FOR SOME CLASS NI < 1')
7424              CALL DPWRST('XXX','BUG ')
7425              WRITE(ICOUT,1133)ISET,XIDTEM(ISET),NI
7426              CALL DPWRST('XXX','BUG ')
7427              IERROR='YES'
7428              GOTO9000
7429            ENDIF
7430C
7431            IF(NI.EQ.1)THEN
7432              TEMP2(ISET)=TEMP(1)
7433            ELSE
7434              SUM=0.0
7435              DO2040I=1,NI
7436                SUM=SUM+TEMP(I)
7437 2040         CONTINUE
7438              TEMP2(ISET)=SUM/ANI
7439            ENDIF
7440C
7441 2010     CONTINUE
7442        ENDIF
7443C
7444        IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PCC2')THEN
7445          WRITE(ICOUT,2061)ISET,NI,ANI,XBARI,XBARG
7446 2061     FORMAT('ISET,NI,ANI,XBARI,XBARG = ',2I8,3G15.7)
7447          CALL DPWRST('XXX','BUG ')
7448          WRITE(ICOUT,2063)SDI,SIGMAE,SADJ
7449 2063     FORMAT('SDI,SIGMAE,SADJ = ',3G15.7)
7450          CALL DPWRST('XXX','BUG ')
7451          WRITE(ICOUT,2064)AK0,AK1,YLOWER,YUPPER
7452 2064     FORMAT('AK0,AK1,YLOWER,YUPPER = ',4G15.7)
7453          CALL DPWRST('XXX','BUG ')
7454        ENDIF
7455C
7456        IF(1+NBEF.GT.NUMSET-NAFT)THEN
7457          WRITE(ICOUT,999)
7458          CALL DPWRST('XXX','BUG ')
7459          WRITE(ICOUT,31)
7460          CALL DPWRST('XXX','BUG ')
7461          WRITE(ICOUT,2065)
7462 2065     FORMAT('      THERE ARE NOT ENOUGH GROUPS TO FORM THE ',
7463     1           'MOVING AVERAGE PLOT.')
7464          CALL DPWRST('XXX','BUG ')
7465          WRITE(ICOUT,2268)KWIDTH,NUMSET
7466          CALL DPWRST('XXX','BUG ')
7467          IERROR='YES'
7468          GOTO9000
7469        ENDIF
7470C
7471        DO2090ISET=1,NUMSET
7472C
7473          IF(N.EQ.NUMSET)THEN
7474            XTAG=0.0
7475            IF(XHIGH(ISET).GE.0.5)XTAG=1.0
7476          ENDIF
7477C
7478          SUM=0.0
7479          ISTRT=ISET-NBEF
7480          ISTOP=ISET+NAFT
7481          DENOM=AK
7482          IF(ISET.LT.1+NBEF)THEN
7483            ISTRT=1
7484            DENOM=REAL(ISET+NAFT)
7485          ELSEIF(ISET.GT.NUMSET-NAFT)THEN
7486            ISTOP=NUMSET
7487            DENOM=REAL(NUMSET-(ISET-NBEF)+1)
7488          ENDIF
7489          DO2092II=ISTRT,ISTOP
7490            SUM=SUM+TEMP2(II)
7491 2092     CONTINUE
7492          YVAL=SUM/DENOM
7493          XVAL=XIDTEM(ISET)
7494          IF(NBEF.NE.NAFT)THEN
7495            IF(ISET.GT.1)THEN
7496              XVAL=(XIDTEM(ISET)+XIDTEM(ISET-1))/2.0
7497            ELSE
7498              XVAL=XIDTEM(1)
7499            ENDIF
7500          ENDIF
7501C
7502          IF(N.NE.NUMSET)THEN
7503            YUPPER=XBARG+3.09*SIGMAE/SQRT(AK)
7504            YLOWER=XBARG-3.09*SIGMAE/SQRT(AK)
7505          ELSE
7506            IF(KWIDTH.LE.25)THEN
7507              YUPPER=XBARG+3.09*RANGEM/(E2(KWIDTH)*SQRT(AK))
7508              YLOWER=XBARG-3.09*RANGEM/(E2(KWIDTH)*SQRT(AK))
7509            ELSE
7510              YUPPER=XBARG+3.09*RANGEM/(E2(25)*SQRT(AK))
7511              YLOWER=XBARG-3.09*RANGEM/(E2(25)*SQRT(AK))
7512            ENDIF
7513          ENDIF
7514C
7515          CALL DPCC3(ICASPL,J,YVAL,XBARG,YLOWER,YUPPER,
7516     1               Y2,X2,D2,XVAL,
7517     1               YPREV,NPREV,IHIGH,XTAG,SIGMAE,
7518     1               CCLSL,CCUSL,CCTARG,ICONWC,
7519     1               IBUGG3,ISUBRO,IERROR)
7520C
7521 2090   CONTINUE
7522      ELSEIF(ICASPL.EQ.'MRCC')THEN
7523C
7524C       *****************************************
7525C       **  STEP 5.11--                        **
7526C       **  TREAT THE MOVING RANGE             **
7527C       **  CONTROL CHART CASE                 **
7528C       *****************************************
7529C
7530        ISTEPN='5.11'
7531        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PCC2')
7532     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7533C
7534        IF(KWIDTH.LT.2)KWIDTH=2
7535        IF(KWIDTH.GT.N-1)KWIDTH=N-1
7536        AK=REAL(KWIDTH)
7537        NBEF=KWIDTH/2
7538        NAFT=NBEF
7539        IF(MOD(KWIDTH,2).EQ.0)NAFT=NBEF-1
7540C
7541        J=0
7542        XTAG=0.0
7543C
7544C       2 CASES:
7545C         1) UNGROUPED DATA (N=NUMSET)
7546C         2) GROUPED DATA (N> NUMSET).  FOR GROUPED DATA, EACH GROUP
7547C            SHOULD HAVE AT LEAST 2 VALUES.
7548C
7549C       UNGROUPED CASE
7550C
7551        IF(N.EQ.NUMSET)THEN
7552          DO2102ISET=1,N
7553            TEMP2(ISET)=Y(ISET)
7554 2102     CONTINUE
7555        ELSE
7556C
7557C         GROUPED CASE
7558C
7559          DO2110ISET=1,NUMSET
7560C
7561            K=0
7562            DO2120I=1,N
7563              IF(X(I).EQ.XIDTEM(ISET))THEN
7564                K=K+1
7565                TEMP(K)=Y(I)
7566              ENDIF
7567 2120       CONTINUE
7568            NI=K
7569            ANI=NI
7570C
7571            IF(NI.LT.2)THEN
7572              WRITE(ICOUT,999)
7573              CALL DPWRST('XXX','BUG ')
7574              WRITE(ICOUT,31)
7575              CALL DPWRST('XXX','BUG ')
7576              WRITE(ICOUT,2132)
7577 2132         FORMAT('FOR MOVING RANGE, FOR SOME CLASS NI < 2')
7578              CALL DPWRST('XXX','BUG ')
7579              WRITE(ICOUT,1133)ISET,XIDTEM(ISET),NI
7580              CALL DPWRST('XXX','BUG ')
7581              IERROR='YES'
7582              GOTO9000
7583            ENDIF
7584C
7585            XTMIN=TEMP(1)
7586            XTMAX=TEMP(1)
7587            DO2140I=1,NI
7588              IF(TEMP(I).LT.XTMIN)XTMIN=TEMP(I)
7589              IF(TEMP(I).GT.XTMAX)XTMAX=TEMP(I)
7590 2140       CONTINUE
7591            TEMP2(ISET)=XTMAX-XTMIN
7592 2110     CONTINUE
7593        ENDIF
7594C
7595        IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PCC2')THEN
7596          WRITE(ICOUT,2161)ISET,NI,ANI,XBARI,XBARG
7597 2161     FORMAT('ISET,NI,ANI,XBARI,XBARG = ',2I8,3G15.7)
7598          CALL DPWRST('XXX','BUG ')
7599          WRITE(ICOUT,2163)SDI,SIGMAE,SADJ
7600 2163     FORMAT('SDI,SIGMAE,SADJ = ',3G15.7)
7601          CALL DPWRST('XXX','BUG ')
7602          WRITE(ICOUT,2164)AK0,AK1,YLOWER,YUPPER
7603 2164     FORMAT('AK0,AK1,YLOWER,YUPPER = ',4G15.7)
7604          CALL DPWRST('XXX','BUG ')
7605        ENDIF
7606C
7607        IF(1+NBEF.GT.NUMSET-NAFT)THEN
7608          WRITE(ICOUT,999)
7609          CALL DPWRST('XXX','BUG ')
7610          WRITE(ICOUT,31)
7611          CALL DPWRST('XXX','BUG ')
7612          WRITE(ICOUT,2165)
7613 2165     FORMAT('      THERE ARE NOT ENOUGH GROUPS TO FORM THE ',
7614     1           'MOVING RANGE PLOT.')
7615          CALL DPWRST('XXX','BUG ')
7616          WRITE(ICOUT,2268)KWIDTH,NUMSET
7617          CALL DPWRST('XXX','BUG ')
7618          IERROR='YES'
7619          GOTO9000
7620        ENDIF
7621C
7622        SUM2=0.0
7623        NUMRAN=0
7624        DO2190ISET=1,NUMSET
7625C
7626C         GROUPED DATA
7627C
7628          IF(N.NE.NUMSET)THEN
7629            SUM=0.0
7630            ISTRT=ISET-NBEF
7631            ISTOP=ISET+NAFT
7632            DENOM=AK
7633            IF(ISET.LT.1+NBEF)THEN
7634              ISTRT=1
7635              DENOM=REAL(ISET+NAFT)
7636            ELSEIF(ISET.GT.NUMSET-NAFT)THEN
7637              ISTOP=NUMSET
7638              DENOM=REAL(NUMSET-(ISET-NBEF)+1)
7639            ENDIF
7640            DO2192II=ISTRT,ISTOP
7641              SUM=SUM+TEMP2(II)
7642 2192       CONTINUE
7643            YVAL=SUM/DENOM
7644C
7645C           UNGROUPED DATA
7646C
7647          ELSE
7648            ISTRT=ISET-NBEF
7649            ISTOP=ISET+NAFT
7650            IF(ISET.LT.1+NBEF)THEN
7651              ISTRT=1
7652            ELSEIF(ISET.GT.NUMSET-NAFT)THEN
7653              ISTOP=NUMSET
7654            ENDIF
7655            XTMIN=TEMP2(ISTRT)
7656            XTMMAX=TEMP2(ISTRT)
7657            DO2182II=ISTRT,ISTOP
7658              IF(TEMP2(II).LT.XTMIN)XTMIN=TEMP2(II)
7659              IF(TEMP2(II).GT.XTMAX)XTMAX=TEMP2(II)
7660 2182       CONTINUE
7661            YVAL=XTMAX-XTMIN
7662            XTAG=0.0
7663            IF(XHIGH(ISET).GE.0.5)XTAG=1.0
7664          ENDIF
7665          XVAL=XIDTEM(ISET)
7666          IF(NBEF.NE.NAFT)XVAL=(XIDTEM(ISET)+XIDTEM(ISET-1))/2.0
7667          IF(KWIDTH.LE.25)THEN
7668            YUPPER=D4(KWIDTH)*RANGEM
7669            YLOWER=D3(KWIDTH)*RANGEM
7670          ELSE
7671            YUPPER=(1.0+3.0*D4FACT/SQRT(2.0*(REAL(KWIDTH)-1.0)))*RANGEM
7672     1             /E2(25)
7673            YLOWER=(1.0-3.0*D3FACT/SQRT(2.0*(REAL(KWIDTH)-1.0)))*RANGEM
7674     1             /E2(25)
7675          ENDIF
7676          IF(YLOWER.LT.0.0)YLOWER=0.0
7677C
7678          CALL DPCC3(ICASPL,J,YVAL,RANGEM,YLOWER,YUPPER,
7679     1               Y2,X2,D2,XVAL,
7680     1               YPREV,NPREV,IHIGH,XTAG,RANGEM,
7681     1               CCLSL,CCUSL,CCTARG,ICONWC,
7682     1               IBUGG3,ISUBRO,IERROR)
7683C
7684 2190   CONTINUE
7685      ELSEIF(ICASPL.EQ.'MSCC')THEN
7686C
7687C       *****************************************
7688C       **  STEP 5.12--                        **
7689C       **  TREAT THE MOVING STANDARD DEVIATION**
7690C       **  CONTROL CHART CASE                 **
7691C       *****************************************
7692C
7693        ISTEPN='5.12'
7694        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PCC2')
7695     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7696C
7697        IF(KWIDTH.LT.2)KWIDTH=2
7698        IF(KWIDTH.GT.N-1)KWIDTH=N-1
7699        AK=REAL(KWIDTH)
7700        NBEF=KWIDTH/2
7701        NAFT=NBEF
7702        IF(MOD(KWIDTH,2).EQ.0)NAFT=NBEF-1
7703C
7704        J=0
7705        XTAG=0.0
7706C
7707C       2 CASES:
7708C         1) UNGROUPED DATA (N=NUMSET)
7709C         2) GROUPED DATA (N> NUMSET).  FOR GROUPED DATA, EACH GROUP
7710C            SHOULD HAVE AT LEAST 2 VALUES.
7711C
7712C       UNGROUPED CASE
7713C
7714        IF(N.EQ.NUMSET)THEN
7715          DO2202ISET=1,N
7716            TEMP2(ISET)=Y(ISET)
7717 2202     CONTINUE
7718        ELSE
7719C
7720C       GROUPED CASE
7721C
7722          DO2210ISET=1,NUMSET
7723C
7724            K=0
7725            XTAG=0.0
7726            DO2220I=1,N
7727              IF(X(I).EQ.XIDTEM(ISET))K=K+1
7728              IF(X(I).EQ.XIDTEM(ISET))TEMP(K)=Y(I)
7729 2220       CONTINUE
7730            NI=K
7731            ANI=NI
7732C
7733            IF(NI.LT.2)THEN
7734              WRITE(ICOUT,999)
7735              CALL DPWRST('XXX','BUG ')
7736              WRITE(ICOUT,31)
7737              CALL DPWRST('XXX','BUG ')
7738              WRITE(ICOUT,2232)
7739 2232         FORMAT('FOR MOVING STANDARD DEVIATION, FOR SOME CLASS ',
7740     1               'NI < 2')
7741              CALL DPWRST('XXX','BUG ')
7742              WRITE(ICOUT,1133)ISET,XIDTEM(ISET),NI
7743              CALL DPWRST('XXX','BUG ')
7744              IERROR='YES'
7745              GOTO9000
7746            ENDIF
7747C
7748            SUM1=0.0
7749            DO2240I=1,NI
7750              SUM1=SUM1+TEMP(I)
7751 2240       CONTINUE
7752            XMEAN=SUM1/ANI
7753            SUM1=0.0
7754            DO2242I=1,NI
7755              SUM1=SUM1+(TEMP(I)-XMEAN)**2
7756 2242       CONTINUE
7757            SD=SQRT(SUM1/(ANI-1.0))
7758            TEMP2(ISET)=SD
7759 2210     CONTINUE
7760        ENDIF
7761C
7762        IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PCC2')THEN
7763          WRITE(ICOUT,2261)ISET,NI,ANI,XBARI,XBARG
7764 2261     FORMAT('ISET,NI,ANI,XBARI,XBARG = ',2I8,3G15.7)
7765          CALL DPWRST('XXX','BUG ')
7766          WRITE(ICOUT,2263)SD,SIGMAE,SADJ
7767 2263     FORMAT('SD,SIGMAE,SADJ = ',3G15.7)
7768          CALL DPWRST('XXX','BUG ')
7769          WRITE(ICOUT,2264)AK0,AK1,YLOWER,YUPPER
7770 2264     FORMAT('AK0,AK1,YLOWER,YUPPER = ',4G15.7)
7771          CALL DPWRST('XXX','BUG ')
7772        ENDIF
7773C
7774        IF(1+NBEF.GT.NUMSET-NAFT)THEN
7775          WRITE(ICOUT,999)
7776          CALL DPWRST('XXX','BUG ')
7777          WRITE(ICOUT,31)
7778          CALL DPWRST('XXX','BUG ')
7779          WRITE(ICOUT,2265)
7780 2265     FORMAT('      THERE ARE NOT ENOUGH GROUPS TO FORM THE ',
7781     1           'MOVING STANDARD DEVAITION PLOT.')
7782          CALL DPWRST('XXX','BUG ')
7783          WRITE(ICOUT,2268)KWIDTH,NUMSET
7784 2268     FORMAT('      THE FILTER WIDTH IS ',I5,' AND THE NUMBER OF ',
7785     1           'GROUPS IS ',I5,'.')
7786          CALL DPWRST('XXX','BUG ')
7787          IERROR='YES'
7788          GOTO9000
7789        ENDIF
7790C
7791        SUM2=0.0
7792        NUMSD=0
7793        DO2290ISET=1,NUMSET
7794C
7795C         GROUPED DATA
7796C
7797          IF(N.NE.NUMSET)THEN
7798            SUM=0.0
7799            ISTRT=ISET-NBEF
7800            ISTOP=ISET+NAFT
7801            DENOM=AK
7802            IF(ISET.LT.1+NBEF)THEN
7803              ISTRT=1
7804              DENOM=REAL(ISET+NAFT)
7805            ELSEIF(ISET.GT.NUMSET-NAFT)THEN
7806              ISTOP=NUMSET
7807              DENOM=REAL(NUMSET-(ISET-NBEF)+1)
7808            ENDIF
7809            DO2292II=ISTRT,ISTOP
7810              SUM=SUM+TEMP2(II)
7811 2292       CONTINUE
7812            YVAL=SUM/DENOM
7813C
7814C         UNGROUPED DATA
7815C
7816          ELSE
7817            ISTRT=ISET-NBEF
7818            ISTOP=ISET+NAFT
7819            IF(ISET.LT.1+NBEF)THEN
7820              ISTRT=1
7821            ELSEIF(ISET.GT.NUMSET-NAFT)THEN
7822              ISTOP=NUMSET
7823            ENDIF
7824            SUM1=0.0
7825            ICOUNT=0
7826            DO2282II=ISTRT,ISTOP
7827              ICOUNT=ICOUNT+1
7828              SUM1=SUM1+TEMP2(II)
7829 2282       CONTINUE
7830            XMEAN=SUM1/REAL(ICOUNT)
7831            SUM1=0.0
7832            DO2283II=ISTRT,ISTOP
7833              SUM1=SUM1+(TEMP2(II)-XMEAN)**2
7834 2283       CONTINUE
7835            IF(ICOUNT.LT.2)GOTO2290
7836            YVAL=SQRT(SUM1/REAL(ICOUNT-1))
7837            XTAG=0.0
7838            IF(XHIGH(ISET).GE.0.5)XTAG=1.0
7839          ENDIF
7840C
7841          XVAL=XIDTEM(ISET)
7842          IF(NBEF.NE.NAFT)XVAL=(XIDTEM(ISET)+XIDTEM(ISET-1))/2.0
7843          IF(KWIDTH.LE.25)THEN
7844            YUPPER=B4(KWIDTH)*SDM
7845            YLOWER=B3(KWIDTH)*SDM
7846          ELSE
7847            YUPPER=(1.0+3.0/SQRT(2.0*(REAL(KWIDTH)-1.0)))*SDM
7848            YLOWER=(1.0-3.0/SQRT(2.0*(REAL(KWIDTH)-1.0)))*SDM
7849          ENDIF
7850          IF(YLOWER.LT.0.0)YLOWER=0.0
7851C
7852          CALL DPCC3(ICASPL,J,YVAL,SDM,YLOWER,YUPPER,
7853     1               Y2,X2,D2,XVAL,
7854     1               YPREV,NPREV,IHIGH,XTAG,SDM,
7855     1               CCLSL,CCUSL,CCTARG,ICONWC,
7856     1               IBUGG3,ISUBRO,IERROR)
7857C
7858 2290   CONTINUE
7859C
7860      ELSEIF(ICASPL.EQ.'1352')THEN
7861C
7862C       **********************************************
7863C       **  STEP 5.13--                             **
7864C       **  TREAT THE ISO 13528 CONTROL CHART CASE  **
7865C       **********************************************
7866C
7867C THE ISO 13528 CONTROL CHART IS BASED ON THE FOLLOWING:
7868C
7869C    1) USE A Z-SCORE AS THE RESPONSE.  SINCE THE STANDARD
7870C       PROVIDES FOR VARIOUS WAYS TO COMPUTE THE Z-SCORE,
7871C       ASSUME THAT THE RESPONSE IS ALREADY IN Z-SCORE FORMAT.
7872C
7873C    2) IF THERE IS REPLICATION, COMPUTE A MEAN FOR EACH
7874C       GROUP.  IF THERE IS NO REPLICATION, THEN JUST USE
7875C       THE DATA VALUE.  UNLIKE THE STANDARD MEAN CONTROL
7876C       CHART, WE DO NOT AVERAGE OVER SEVERAL VALUES FOR
7877C       INDIVIDUAL OBSERVATIONS.
7878C
7879C    3) CONTROL LIMITS ARE AT +/-2 AND +/-3.
7880C
7881C    4) ONE VERSION OF THIS PLOT ALSO PLOTS THE RAW DATA
7882C       VALUES.
7883C
7884C    5) THE MATERIAL-ID CAN BE TREATED AS A "HIGHLIGHTING"
7885C       VARIABLE.  THEREFORE, LET THE HIGHLIGHT VARIABLE
7886C       SPECIFY THE MATERIAL ID RATHER THAN JUST 0/1.
7887C
7888        ISTEPN='5.13'
7889        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PCC2')
7890     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7891C
7892        J=0
7893        ICNT=0
7894        DO2310ISET=1,NUMSET
7895C
7896          K=0
7897          DO2320I=1,N
7898            IF(X(I).EQ.XIDTEM(ISET))THEN
7899              K=K+1
7900              TEMP(K)=Y(I)
7901              TEMP2(K)=XHIGH(I)
7902            ENDIF
7903 2320     CONTINUE
7904          NI=K
7905          ANI=NI
7906C
7907          IF(NI.LT.1)THEN
7908            WRITE(ICOUT,999)
7909            CALL DPWRST('XXX','BUG ')
7910            WRITE(ICOUT,31)
7911            CALL DPWRST('XXX','BUG ')
7912            WRITE(ICOUT,1132)
7913            CALL DPWRST('XXX','BUG ')
7914            WRITE(ICOUT,1133)ISET,XIDTEM(ISET),NI
7915            CALL DPWRST('XXX','BUG ')
7916            IERROR='YES'
7917            GOTO9000
7918          ENDIF
7919C
7920          SUM=0.0
7921          DO2340I=1,NI
7922            SUM=SUM+TEMP(I)
7923 2340     CONTINUE
7924          STAT=SUM/ANI
7925C
7926          ICNT=1
7927          J=J+1
7928          Y2(J)=STAT
7929          X2(J)=XIDTEM(ISET)
7930          D2(J)=REAL(ICNT)
7931C
7932          ICNT=ICNT+1
7933          J=J+1
7934          Y2(J)=0.0
7935          X2(J)=XIDTEM(ISET)
7936          D2(J)=REAL(ICNT)
7937C
7938          ICNT=ICNT+1
7939          J=J+1
7940          Y2(J)=2.0
7941          X2(J)=XIDTEM(ISET)
7942          D2(J)=REAL(ICNT)
7943C
7944          ICNT=ICNT+1
7945          J=J+1
7946          Y2(J)=-2.0
7947          X2(J)=XIDTEM(ISET)
7948          D2(J)=REAL(ICNT)
7949C
7950          ICNT=ICNT+1
7951          J=J+1
7952          Y2(J)=3.0
7953          X2(J)=XIDTEM(ISET)
7954          D2(J)=REAL(ICNT)
7955C
7956          ICNT=ICNT+1
7957          J=J+1
7958          Y2(J)=-3.0
7959          X2(J)=XIDTEM(ISET)
7960          D2(J)=REAL(ICNT)
7961C
7962          ICNT=ICNT+1
7963          DO2350II=1,NI
7964            J=J+1
7965            Y2(J)=TEMP(II)
7966            X2(J)=XIDTEM(ISET)
7967            IF(IHIGH.EQ.'ON')THEN
7968              D2(J)=REAL(ICNT) + TEMP2(II) - 1.0
7969            ELSE
7970              D2(J)=REAL(ICNT)
7971            ENDIF
7972 2350     CONTINUE
7973C
7974 2310   CONTINUE
7975      ELSEIF(ICASPL.EQ.'1CUS')THEN
7976C
7977C       ****************************************************
7978C       **  STEP 5.14--                                   **
7979C       **  TREAT THE ISO 13528 CUSUM CONTROL CHART CASE  **
7980C       ****************************************************
7981C
7982C THE ISO 13528 CUSUM CONTROL CHART IS BASED ON THE FOLLOWING:
7983C
7984C    1) USE A Z-SCORE AS THE RESPONSE.  SINCE THE STANDARD
7985C       PROVIDES FOR VARIOUS WAYS TO COMPUTE THE Z-SCORE,
7986C       ASSUME THAT THE RESPONSE IS ALREADY IN Z-SCORE FORMAT.
7987C
7988C    2) IF THERE IS REPLICATION, COMPUTE A MEAN FOR EACH
7989C       GROUP.  IF THERE IS NO REPLICATION, THEN JUST USE
7990C       THE DATA VALUE.
7991C
7992C    3) SIMPLY PLOT THE CUMULATIVE SUM OF THE Z-SCORES.
7993C       THE TARGET VALUE IS ZERO.
7994C
7995C    4) THERE ARE NO CONTROL LIMITS FOR THIS PLOT.
7996C
7997C    5) THE MATERIAL-ID CAN BE TREATED AS A "HIGHLIGHTING"
7998C       VARIABLE.  THEREFORE, LET THE HIGHLIGHT VARIABLE
7999C       SPECIFY THE MATERIAL ID RATHER THAN JUST 0/1.
8000C
8001        ISTEPN='5.13'
8002        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PCC2')
8003     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8004C
8005        J=0
8006        ICNT=0
8007        CUSUM=0.0
8008        DO2410ISET=1,NUMSET
8009C
8010          K=0
8011          DO2420I=1,N
8012            IF(X(I).EQ.XIDTEM(ISET))THEN
8013              K=K+1
8014              TEMP(K)=Y(I)
8015              TEMP2(K)=XHIGH(I)
8016            ENDIF
8017 2420     CONTINUE
8018          NI=K
8019          ANI=NI
8020C
8021          IF(NI.LT.1)THEN
8022            WRITE(ICOUT,999)
8023            CALL DPWRST('XXX','BUG ')
8024            WRITE(ICOUT,31)
8025            CALL DPWRST('XXX','BUG ')
8026            WRITE(ICOUT,1132)
8027            CALL DPWRST('XXX','BUG ')
8028            WRITE(ICOUT,1133)ISET,XIDTEM(ISET),NI
8029            CALL DPWRST('XXX','BUG ')
8030            IERROR='YES'
8031            GOTO9000
8032          ENDIF
8033C
8034          SUM=0.0
8035          DO2440I=1,NI
8036            SUM=SUM+TEMP(I)
8037 2440     CONTINUE
8038          CUSUM=CUSUM + (SUM/ANI)
8039C
8040          ICNT=1
8041          J=J+1
8042          Y2(J)=CUSUM
8043          X2(J)=XIDTEM(ISET)
8044          D2(J)=REAL(ICNT)
8045C
8046          ICNT=ICNT+1
8047          J=J+1
8048          Y2(J)=0.0
8049          X2(J)=XIDTEM(ISET)
8050          D2(J)=REAL(ICNT)
8051C
8052 2410   CONTINUE
8053      ELSE
8054        WRITE(ICOUT,999)
8055        CALL DPWRST('XXX','BUG ')
8056        WRITE(ICOUT,31)
8057        CALL DPWRST('XXX','BUG ')
8058        WRITE(ICOUT,1053)
8059 1053   FORMAT('      ICASPL NOT EQUAL ONE OF THE ALLOWABLE 12--')
8060        CALL DPWRST('XXX','BUG ')
8061        WRITE(ICOUT,1054)
8062 1054   FORMAT('      MECC, SDCC, RACC, CSCC, PCC, PNCC, UCC, CCC, ',
8063     1         'EWMA, MACC, MSCC, OR MRCC.')
8064        CALL DPWRST('XXX','BUG ')
8065        WRITE(ICOUT,1056)ICASPL
8066 1056   FORMAT('      ICASPL = ',A4)
8067        CALL DPWRST('XXX','BUG ')
8068        IERROR='YES'
8069        GOTO9000
8070      ENDIF
8071C
8072      N2=J
8073      NPLOTV=3
8074C
8075C               ******************
8076C               **   STEP 90--  **
8077C               **   EXIT       **
8078C               ******************
8079C
8080 9000 CONTINUE
8081      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PCC2')THEN
8082        WRITE(ICOUT,999)
8083        CALL DPWRST('XXX','BUG ')
8084        WRITE(ICOUT,9011)
8085 9011   FORMAT('***** AT THE END       OF DPCC2--')
8086        CALL DPWRST('XXX','BUG ')
8087        WRITE(ICOUT,9012)IERROR,ICASPL,N,NUMSET,N2
8088 9012   FORMAT('IERROR,ICASPL,N,NUMSET,N2 = ',2(A4,2X),3I8)
8089        CALL DPWRST('XXX','BUG ')
8090        WRITE(ICOUT,9013)NUMV2,ISIZE
8091 9013   FORMAT('NUMV2,ISIZE = ',2I8)
8092        CALL DPWRST('XXX','BUG ')
8093        WRITE(ICOUT,9014)AN,XBARG,SDG,RANGEG
8094 9014   FORMAT('AN,XBARG,SDG,RANGEG = ',4G15.7)
8095        CALL DPWRST('XXX','BUG ')
8096        WRITE(ICOUT,9015)ANUMSE,SIGMAE,RANGEE
8097 9015   FORMAT('ANUMSE,SIGMAE,RANGEE = ',3G15.7)
8098        CALL DPWRST('XXX','BUG ')
8099        DO9020I=1,N2
8100          WRITE(ICOUT,9021)I,Y2(I),X2(I),D2(I)
8101 9021     FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,3G15.7)
8102          CALL DPWRST('XXX','BUG ')
8103 9020   CONTINUE
8104      ENDIF
8105C
8106      RETURN
8107      END
8108      SUBROUTINE DPCC3(ICASPL,J,STAT,YMID,YLOWER,YUPPER,
8109     1                 Y2,X2,D2,XVAL,
8110     1                 YPREV,NPREV,IHIGH,XHIGH,SIGMA,
8111     1                 CCLSL,CCUSL,CCTARG,ICONWC,
8112     1                 IBUGG3,ISUBRO,IERROR)
8113C
8114C     PURPOSE-UTIITY ROUTINE USED BY DPCC.
8115C     WRITTEN BY--JAMES J. FILLIBEN
8116C                 STATISTICAL ENGINEERING DIVISION
8117C                 INFORMATION TECHNOLOGY LABORATORY
8118C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
8119C                 GAITHERSBURG, MD 20899-8980
8120C                 PHONE--301-975-2899
8121C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
8122C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
8123C     LANGUAGE--ANSI FORTRAN (1977)
8124C     VERSION NUMBER--2012/1
8125C     ORIGINAL VERSION--JANUARY   2012. EXTRACTED FROM DPCC2
8126C
8127C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
8128C
8129      CHARACTER*4 ICASPL
8130      CHARACTER*4 ICONWC
8131      CHARACTER*4 IHIGH
8132      CHARACTER*4 IBUGG3
8133      CHARACTER*4 ISUBRO
8134      CHARACTER*4 IERROR
8135C
8136C---------------------------------------------------------------------
8137C
8138      DIMENSION Y2(*)
8139      DIMENSION X2(*)
8140      DIMENSION D2(*)
8141      DIMENSION YPREV(*)
8142C
8143C---------------------------------------------------------------------
8144C
8145      INCLUDE 'DPCOP2.INC'
8146C
8147C-----START POINT-----------------------------------------------------
8148C
8149      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PCC3')THEN
8150        WRITE(ICOUT,999)
8151  999   FORMAT(1X)
8152        CALL DPWRST('XXX','BUG ')
8153        WRITE(ICOUT,70)
8154   70   FORMAT('AT THE BEGINNING OF DPCC3--')
8155        CALL DPWRST('XXX','BUG ')
8156        WRITE(ICOUT,71)J,STAT,XVAL,ICASPL,ICONWC,ISUBRO
8157   71   FORMAT('J,STAT,XVAL,ICASPL,ICONWC,ISUBRO = ',I8,2G15.7,3(2X,A4))
8158        CALL DPWRST('XXX','BUG ')
8159        WRITE(ICOUT,74)IHIGH,XHIGH,SIGMA
8160   74   FORMAT('IHIGH,XHIGH,SIGMA = ',A4,2X,2G15.7)
8161        CALL DPWRST('XXX','BUG ')
8162      ENDIF
8163C
8164      IERROR='NO'
8165C
8166      ICNT=1
8167      J=J+1
8168      Y2(J)=STAT
8169      X2(J)=XVAL
8170      D2(J)=REAL(ICNT)
8171C
8172C     IF "ISO 13528" CONTROL LIMITS REQUESTED, SPECIFY LIMITS
8173C     AT +/-2 AND +/-3.  THESE ONLY APPLY TO "MEAN CONTROL"
8174C     CHART.
8175C
8176      IF(ICONWC.EQ.'ISO' .AND.
8177     1  (ICASPL.EQ.'MECC' .OR. ICASPL.EQ.'MACC'))THEN
8178C
8179        ICNT=ICNT+1
8180        J=J+1
8181        Y2(J)=0.0
8182        X2(J)=XVAL
8183        D2(J)=REAL(ICNT)
8184C
8185        ICNT=ICNT+1
8186        J=J+1
8187        Y2(J)=2.0
8188        X2(J)=XVAL
8189        D2(J)=REAL(ICNT)
8190C
8191        ICNT=ICNT+1
8192        J=J+1
8193        Y2(J)=-2.0
8194        X2(J)=XVAL
8195        D2(J)=REAL(ICNT)
8196C
8197        ICNT=ICNT+1
8198        J=J+1
8199        Y2(J)=3.0
8200        X2(J)=XVAL
8201        D2(J)=REAL(ICNT)
8202C
8203        ICNT=ICNT+1
8204        J=J+1
8205        Y2(J)=-3.0
8206        X2(J)=XVAL
8207        D2(J)=REAL(ICNT)
8208C
8209      ELSE
8210        ICNT=ICNT+1
8211        J=J+1
8212        Y2(J)=YMID
8213        X2(J)=XVAL
8214        D2(J)=REAL(ICNT)
8215C
8216        ICNT=ICNT+1
8217        J=J+1
8218        Y2(J)=YUPPER
8219        X2(J)=XVAL
8220        D2(J)=REAL(ICNT)
8221C
8222        ICNT=ICNT+1
8223        J=J+1
8224        Y2(J)=YLOWER
8225        X2(J)=XVAL
8226        D2(J)=REAL(ICNT)
8227C
8228C       IMPLEMENT WECO (WESTERN ELECTRIC) RULES FOR MEAN, SD,
8229C       AND RANGE CONTROL CHARTS.  THESE ARE TYPICALLY USED IN
8230C       ADDITION TO THE STANDARD CONTROL LIMITS.  ONE DRAWBACK TO
8231C       THESE RULES IS THAT THEY CAN LEAD TO AN EXCESSIVE NUMBER
8232C       OF FALSE POSITIVES.
8233C
8234C       THESE RULES FLAG THE FOLLOWING (THESE ARE LISTED FOR
8235C       POINTS ABOVE THE CENTER LINE (I.E., YMID).  THERE ARE
8236C       SIMILAR RULES FOR POINTS BELOW THE CENTER LINE.
8237C
8238C          1) ANY POINT > 3*SIGMA
8239C          2) 2 OUT OF LAST 3 POINTS > 2*SIGMA
8240C          3) 4 OUT OF LAST 5 POINTS > 1*SIGMA
8241C          4) 8 CONSECUTIVE POINTS ABOVE CENTER LINE
8242C
8243C       FOR RULE 1, WE DO NOT NEED ANY PAST DATA.  FOR THE OTHERS,
8244C       PASS IN AN ARRAY THAT CONTAINS THE PREVIOUS DATA.
8245C
8246        IF(ICONWC.EQ.'WECO' .AND.
8247     1    (ICASPL.EQ.'MECC' .OR. ICASPL.EQ.'MACC' .OR.
8248     1     ICASPL.EQ.'RACC' .OR. ICASPL.EQ.'MRCC' .OR.
8249     1     ICASPL.EQ.'SDCC' .OR. ICASPL.EQ.'MSCC'))THEN
8250C
8251          ITAG=0
8252          NPREV=NPREV+1
8253          YPREV(NPREV)=STAT
8254C
8255          IF(STAT.GT.YMID + 3.0*SIGMA)THEN
8256            ITAG=1
8257          ELSEIF(STAT.LT.YMID - 3.0*SIGMA)THEN
8258            ITAG=1
8259          ENDIF
8260C
8261          IF(NPREV.GE.3)THEN
8262            ISTRT=NPREV-2
8263            ICNT1=0
8264            ICNT2=0
8265            DO1020I=ISTRT,NPREV
8266              IF(YPREV(I).GT.YMID + 2.0*SIGMA)ICNT1=ICNT1+1
8267              IF(YPREV(I).LT.YMID - 2.0*SIGMA)ICNT2=ICNT2+1
8268 1020       CONTINUE
8269            IF(ICNT1.GE.2 .OR. ICNT2.GE.2)ITAG=1
8270          ENDIF
8271C
8272          IF(NPREV.GE.5)THEN
8273            ISTRT=NPREV-4
8274            ICNT1=0
8275            ICNT2=0
8276            DO1030I=ISTRT,NPREV
8277              IF(YPREV(I).GT.YMID + SIGMA)ICNT1=ICNT1+1
8278              IF(YPREV(I).LT.YMID - SIGMA)ICNT2=ICNT2+1
8279 1030       CONTINUE
8280            IF(ICNT1.GE.2 .OR. ICNT2.GE.2)ITAG=1
8281          ENDIF
8282C
8283          IF(NPREV.GE.8)THEN
8284            ISTRT=NPREV-7
8285            IFLAG=1
8286            IF(STAT.GT.YMID)THEN
8287              DO1040I=ISTRT,NPREV-1
8288                IF(YPREV(I).LT.YMID)IFLAG=0
8289 1040         CONTINUE
8290            ELSEIF(STAT.LT.YMID)THEN
8291              DO1045I=ISTRT,NPREV-1
8292                IF(YPREV(I).GT.YMID)IFLAG=0
8293 1045         CONTINUE
8294            ENDIF
8295            IF(IFLAG.EQ.1)ITAG=1
8296          ENDIF
8297C
8298          IF(ITAG.EQ.1)THEN
8299            ICNT=ICNT+1
8300            J=J+1
8301            Y2(J)=STAT
8302            X2(J)=XVAL
8303            D2(J)=REAL(ICNT)
8304          ENDIF
8305        ENDIF
8306C
8307      ENDIF
8308C
8309      IF(CCTARG.NE.CPUMIN)THEN
8310        ICNT=ICNT+1
8311        J=J+1
8312        Y2(J)=CCTARG
8313        X2(J)=XVAL
8314        D2(J)=REAL(ICNT)
8315      ENDIF
8316C
8317      IF(CCUSL.NE.CPUMIN)THEN
8318        ICNT=ICNT+1
8319        J=J+1
8320        Y2(J)=CCUSL
8321        X2(J)=XVAL
8322        D2(J)=REAL(ICNT)
8323      ENDIF
8324C
8325      IF(CCLSL.NE.CPUMIN)THEN
8326        ICNT=ICNT+1
8327        J=J+1
8328        Y2(J)=CCLSL
8329        X2(J)=XVAL
8330        D2(J)=REAL(ICNT)
8331      ENDIF
8332C
8333      IF(IHIGH.EQ.'ON' .AND. XHIGH.GE.0.5)THEN
8334        ICNT=ICNT+1
8335        J=J+1
8336        Y2(J)=STAT
8337        X2(J)=XVAL
8338        D2(J)=REAL(ICNT)
8339      ENDIF
8340C
8341C               ******************
8342C               **   STEP 90--  **
8343C               **   EXIT       **
8344C               ******************
8345C
8346      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PCC3')THEN
8347        WRITE(ICOUT,999)
8348        CALL DPWRST('XXX','BUG ')
8349        WRITE(ICOUT,9011)
8350 9011   FORMAT('***** AT THE END       OF DPCC3--')
8351        CALL DPWRST('XXX','BUG ')
8352      ENDIF
8353C
8354      RETURN
8355      END
8356      SUBROUTINE DPCD(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
8357     1                IANGLU,DEMOFR,DEMODF,
8358     1                IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
8359C
8360C     PURPOSE--GENERATE ONE OF THE FOLLOWING 2
8361C              COMPLEX DEMODULATION PLOTS--
8362C                   1) AMPLITUDE;
8363C                   2) PHASE;
8364C     WRITTEN BY--JAMES J. FILLIBEN
8365C                 STATISTICAL ENGINEERING DIVISION
8366C                 INFORMATION TECHNOLOGY LABORATORY
8367C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
8368C                 GAITHERSBURG, MD 20899-8980
8369C                 PHONE--301-975-2899
8370C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
8371C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
8372C     LANGUAGE--ANSI FORTRAN (1977)
8373C     VERSION NUMBER--82/7
8374C     ORIGINAL VERSION--JUNE      1978.
8375C     UPDATED         --JULY      1981.
8376C     UPDATED         --JANUARY   1981.
8377C     UPDATED         --NOVEMBER  1981.
8378C     UPDATED         --MARCH     1982.
8379C     UPDATED         --MAY       1982.
8380C     UPDATED         --JUNE      1990. TEMPORARY ARRAYS TO GARBAGE COMMON
8381C     UPDATED         --MARCH     2011. USE DPPARS AND DPPAR3
8382C
8383C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
8384C
8385      CHARACTER*4 ICASPL
8386      CHARACTER*4 IAND1
8387      CHARACTER*4 IAND2
8388      CHARACTER*4 IANGLU
8389      CHARACTER*4 IBUGG2
8390      CHARACTER*4 IBUGG3
8391      CHARACTER*4 IBUGQ
8392      CHARACTER*4 ISUBRO
8393      CHARACTER*4 IFOUND
8394      CHARACTER*4 IERROR
8395C
8396      CHARACTER*4 ISUBN1
8397      CHARACTER*4 ISUBN2
8398      CHARACTER*4 ISTEPN
8399C
8400      CHARACTER*4 ICASE
8401      PARAMETER (MAXSPN=10)
8402      CHARACTER*40 INAME
8403      CHARACTER*4 IVARN1(MAXSPN)
8404      CHARACTER*4 IVARN2(MAXSPN)
8405      CHARACTER*4 IVARTY(MAXSPN)
8406      REAL PVAR(MAXSPN)
8407      INTEGER ILIS(MAXSPN)
8408      INTEGER NRIGHT(MAXSPN)
8409      INTEGER ICOLR(MAXSPN)
8410C
8411C---------------------------------------------------------------------
8412C
8413      INCLUDE 'DPCOPA.INC'
8414C
8415      DIMENSION Y1(MAXOBV)
8416CCCCC FOLLOWING LINES ADDED JUNE, 1990
8417      INCLUDE 'DPCOZZ.INC'
8418      EQUIVALENCE (GARBAG(IGARB1),Y1(1))
8419CCCCC END CHANGE
8420C
8421C-----COMMON----------------------------------------------------------
8422C
8423      INCLUDE 'DPCOHK.INC'
8424      INCLUDE 'DPCODA.INC'
8425C
8426C-----COMMON VARIABLES (GENERAL)--------------------------------------
8427C
8428      INCLUDE 'DPCOP2.INC'
8429C
8430C-----DATA STATEMENTS-------------------------------------------------
8431C
8432      DATA PI/3.141592653/
8433C
8434C-----START POINT-----------------------------------------------------
8435C
8436      IERROR='NO'
8437C
8438      ISUBN1='DPCD'
8439      ISUBN2='    '
8440C
8441      MAXCP1=MAXCOL+1
8442      MAXCP2=MAXCOL+2
8443      MAXCP3=MAXCOL+3
8444      MAXCP4=MAXCOL+4
8445      MAXCP5=MAXCOL+5
8446      MAXCP6=MAXCOL+6
8447C
8448C               ***********************************************
8449C               **  TREAT THE COMPLEX DEMODULATION CASE      **
8450C               ***********************************************
8451C
8452      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'DPCD')THEN
8453        WRITE(ICOUT,999)
8454  999   FORMAT(1X)
8455        CALL DPWRST('XXX','BUG ')
8456        WRITE(ICOUT,51)
8457   51   FORMAT('***** AT THE BEGINNING OF DPCD--')
8458        CALL DPWRST('XXX','BUG ')
8459        WRITE(ICOUT,52)ICASPL,IAND1,IAND2,IANGLU,DEMODF
8460   52   FORMAT('ICASPL,IAND1,IAND2,IANGLU,DEMODF = ',4(A4,2X),G15.7)
8461        CALL DPWRST('XXX','BUG ')
8462        WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ,ISUBRO
8463   53   FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',3(A4,2X),A4)
8464        CALL DPWRST('XXX','BUG ')
8465      ENDIF
8466C
8467C               ***************************
8468C               **  STEP 1--             **
8469C               **  EXTRACT THE COMMAND  **
8470C               ***************************
8471C
8472      ISTEPN='1'
8473      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPCD')
8474     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8475C
8476      IF(NUMARG.GE.3 .AND. ICOM.EQ.'COMP' .AND.
8477     1   IHARG(1).EQ.'DEMO' .AND. IHARG(2).EQ.'AMPL' .AND.
8478     1   IHARG(3).EQ.'PLOT')THEN
8479        ICASPL='CDAM'
8480        ILASTC=3
8481      ELSEIF(NUMARG.GE.3 .AND. ICOM.EQ.'COMP' .AND.
8482     1       IHARG(1).EQ.'DEMO' .AND. IHARG(2).EQ.'PHAS' .AND.
8483     1       IHARG(3).EQ.'PLOT')THEN
8484        ICASPL='CDPH'
8485        ILASTC=3
8486      ELSE
8487        IFOUND='NO'
8488        GOTO9000
8489      ENDIF
8490C
8491      IFOUND='YES'
8492      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
8493C
8494C               ****************************************
8495C               **  STEP 2--                          **
8496C               **  EXTRACT THE VARIABLE LIST         **
8497C               ****************************************
8498C
8499      ISTEPN='2'
8500      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPCD')
8501     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8502C
8503      INAME='COMPLEX DEMODULATION PLOT'
8504      MINNA=1
8505      MAXNA=100
8506      MINN2=2
8507      IFLAGE=1
8508      IFLAGM=1
8509      IFLAGP=0
8510      JMIN=1
8511      JMAX=NUMARG
8512      MINNVA=1
8513      MAXNVA=1
8514C
8515      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
8516     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
8517     1            JMIN,JMAX,
8518     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
8519     1            IVARN1,IVARN2,IVARTY,PVAR,
8520     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
8521     1            MINNVA,MAXNVA,
8522     1            IFLAGM,IFLAGP,
8523     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
8524      IF(IERROR.EQ.'YES')GOTO9000
8525C
8526      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPCD')THEN
8527        WRITE(ICOUT,999)
8528        CALL DPWRST('XXX','BUG ')
8529        WRITE(ICOUT,281)
8530  281   FORMAT('***** AFTER CALL DPPARS--')
8531        CALL DPWRST('XXX','BUG ')
8532        WRITE(ICOUT,282)NQ,NUMVAR,ICASPL
8533  282   FORMAT('NQ,NUMVAR,ICASPL = ',2I8,2X,A4)
8534        CALL DPWRST('XXX','BUG ')
8535        IF(NUMVAR.GT.0)THEN
8536          DO285I=1,NUMVAR
8537            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
8538     1                      ICOLR(I)
8539  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
8540     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
8541            CALL DPWRST('XXX','BUG ')
8542  285     CONTINUE
8543        ENDIF
8544      ENDIF
8545C
8546C     EXTRACT THE VARIABLE.
8547C
8548      ICOL=1
8549      CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
8550     1            INAME,IVARN1,IVARN2,IVARTY,
8551     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
8552     1            MAXCOL,MAXCP1,MAXCP2,MAXCP3,
8553     1            MAXCP4,MAXCP5,MAXCP6,
8554     1            V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
8555     1            Y1,Y1,Y1,NLEFT,NLOCAL,NLOCAL,ICASE,
8556     1            IBUGG3,ISUBRO,IFOUND,IERROR)
8557      IF(IERROR.EQ.'YES')GOTO9000
8558C
8559C               ******************************************************
8560C               **  STEP 7--                                        **
8561C               **  DETERMINE IF THE ANALYST                        **
8562C               **  HAS SPECIFIED    THE DEMODULATION FREQUENCY     **
8563C               **  FOR THE COMPLEX DEMODULATION ANALYSIS.          **
8564C               **  THE FREQUENCY SETTING IS DEFINED BY PRE-USE     **
8565C               **  OF THE DEMODULATION FREQUENCY     COMMAND.      **
8566C               **  IF FOUND, USE THE SPECIFIED VALUE.              **
8567C               **  IF NOT FOUND, GENERATE AN ERROR MESSAGE.        **
8568C               ******************************************************
8569C
8570      ISTEPN='7'
8571      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPCD')
8572     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8573C
8574      DEMOF2=DEMOFR
8575      IF(IANGLU.EQ.'DEGR')DEMOF2=DEMOF2*PI/180.0
8576      IF(IANGLU.EQ.'GRAD')DEMOF2=DEMOF2*PI/200.0
8577CCCCC IF(0.0.LT.DEMOF2.AND.DEMOF2.LT.0.5)GOTO790
8578C
8579      IF(DEMOF2.LE.0.0 .OR. DEMOF2.GE.0.5)THEN
8580        WRITE(ICOUT,999)
8581        CALL DPWRST('XXX','BUG ')
8582        WRITE(ICOUT,741)
8583  741   FORMAT('****** ERROR IN COMPLEX DEMODULATION PLOT--')
8584        CALL DPWRST('XXX','BUG ')
8585        IF(ICASPL.EQ.'CDAM')THEN
8586          WRITE(ICOUT,742)
8587  742     FORMAT('       FOR A COMPLEX DEMODULATION AMPLITUDE PLOT,')
8588          CALL DPWRST('XXX','BUG ')
8589        ELSEIF(ICASPL.EQ.'CDPH')THEN
8590          WRITE(ICOUT,743)
8591  743     FORMAT('       FOR A COMPLEX DEMODULATION PHASE PLOT,')
8592          CALL DPWRST('XXX','BUG ')
8593        ENDIF
8594        WRITE(ICOUT,744)
8595  744   FORMAT('       THE FREQUENCY AT WHICH THE DEMODULATION IS TO')
8596        CALL DPWRST('XXX','BUG ')
8597        WRITE(ICOUT,746)
8598  746   FORMAT('       PERFORMED MUST BE PRE-SPECIFIED BY THE ANALYST,')
8599        CALL DPWRST('XXX','BUG ')
8600        WRITE(ICOUT,747)
8601  747   FORMAT('       AND MUST BE BETWEEN 0 AND 0.5 RADIANS;')
8602        CALL DPWRST('XXX','BUG ')
8603        WRITE(ICOUT,748)
8604  748   FORMAT('       SUCH WAS NOT THE CASE HERE.')
8605        CALL DPWRST('XXX','BUG ')
8606        WRITE(ICOUT,749)DEMOFR,IANGLU
8607  749   FORMAT('       THE DEMODULATION FREQUENCY = ',G15.7,2X,A4)
8608        CALL DPWRST('XXX','BUG ')
8609        IF(IANGLU.NE.'RADI')THEN
8610          WRITE(ICOUT,750)DEMOF2
8611  750     FORMAT('       THE DEMODULATION FREQUENCY = ',G15.7,2X,
8612     1           'RADIANS')
8613          CALL DPWRST('XXX','BUG ')
8614        ENDIF
8615        WRITE(ICOUT,751)
8616  751   FORMAT('       TO DEFINE THE DEMODULATION FREQUENCY, USE THE')
8617        CALL DPWRST('XXX','BUG ')
8618        WRITE(ICOUT,753)
8619  753   FORMAT('       DEMODULATION FREQUENCY     COMMAND, AS IN--')
8620        CALL DPWRST('XXX','BUG ')
8621        WRITE(ICOUT,754)
8622  754   FORMAT('            DEMODULATION FREQUENCY 0.3')
8623        CALL DPWRST('XXX','BUG ')
8624        WRITE(ICOUT,755)
8625  755   FORMAT('            DEMODULATION FREQUENCY 0.155')
8626        CALL DPWRST('XXX','BUG ')
8627        IERROR='YES'
8628        GOTO9000
8629      ENDIF
8630C
8631C               ********************************************************
8632C               **  STEP 8--                                           *
8633C               **  COMPUTE THE APPROPRIATE COMPLEX DEMODULATION       *
8634C               **  PLOT  (AMPLITUDE OR PHASE).                        *
8635C               **  FORM THE VERTICAL AND HORIZONTAL AXIS              *
8636C               **  VALUES Y(.) AND X(.) FOR THE PLOT.                 *
8637C               **  DEFINE THE NUMBER OF PLOT POINTS    (NPLOTP).      *
8638C               **  DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV).      *
8639C               ********************************************************
8640C
8641      ISTEPN='8'
8642      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPCD')
8643     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8644C
8645      CALL DPCD2(Y1,NLEFT,ICASPL,DEMOF2,DEMODF,
8646     1           Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR)
8647C
8648C               *****************
8649C               **  STEP 90--  **
8650C               **  EXIT       **
8651C               *****************
8652C
8653 9000 CONTINUE
8654      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'DPCD')THEN
8655        WRITE(ICOUT,999)
8656        CALL DPWRST('XXX','BUG ')
8657        WRITE(ICOUT,9011)
8658 9011   FORMAT('***** AT THE END       OF DPHIST--')
8659        CALL DPWRST('XXX','BUG ')
8660        WRITE(ICOUT,9012)IFOUND,IERROR
8661 9012   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
8662        CALL DPWRST('XXX','BUG ')
8663        WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
8664 9013   FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',
8665     1         3I8,2X,2(A4,2X),A4)
8666        CALL DPWRST('XXX','BUG ')
8667        WRITE(ICOUT,9014)DEMOFR,IANGLU,DEMOF2
8668 9014   FORMAT('DEMOFR,IANGLU,DEMOF2 = ',G15.7,2X,A4,2X,G15.7)
8669        CALL DPWRST('XXX','BUG ')
8670        IF(NPLOTP.GT.0)THEN
8671          DO9015I=1,NPLOTP
8672            WRITE(ICOUT,9016)I,Y(I),X(I),D(I)
8673 9016       FORMAT('I,Y(I),X(I),D(I) = ',I8,3G15.7)
8674            CALL DPWRST('XXX','BUG ')
8675 9015     CONTINUE
8676        ENDIF
8677      ENDIF
8678C
8679      RETURN
8680      END
8681      SUBROUTINE DPCD2(Y,N,ICASPL,F,DEMODF,
8682     1                 Y2,X2,D2,N2,NPLOTV,IBUGG3,ISUBRO,IERROR)
8683C
8684C     PURPOSE--THIS SUBROUTINE PERFORMS A COMPLEX DEMODULATION
8685C              ON THE DATA IN THE INPUT VECTOR X
8686C              AT THE INPUT DEMODULATION FREQUENCY = F.
8687C              THE COMPLEX DEMODULATION CONSISTS OF THE FOLLOWING--
8688C              1) AN AMPLITUDE VERSUS TIME PLOT;
8689C              2) A PHASE VERSUS TIME PLOT;
8690C              3) AN UPDATED DEMODULATION FREQUENCY ESTIMATE
8691C                 TO ASSIST THE ANALYST IN DETERMINING A
8692C                 MORE APPROPRIATE FREQUENCY AT WHICH
8693C                 TO DEMODULATE IN CASE THE SPECIFIED
8694C                 INPUT DEMODULATION FREQUENCY F
8695C                 DOES NOT FLATTEN SUFFICIENTLY THE
8696C                 PHASE PLOT.
8697C
8698C              THE ALLOWABLE RANGE OF THE INPUT DEMODULATION
8699C              FREQUENCY F IS 0.0 TO 0.5 (EXCLUSIVELY).
8700C              THE INPUT DEMODULATION FREQUENCY F IS MEASURED  OF
8701C              IN UNITS OF CYCLES PER 'DATA POINT' OR,
8702C              MORE PRECISELY, IN CYCLES PER UNIT TIME WHERE
8703C              'UNIT TIME' IS DEFINED AS THE
8704C              ELAPSED TIME BETWEEN ADJACENT OBSERVATIONS.
8705C
8706C     INPUT ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR OF
8707C                               (UNSORTED) OBSERVATIONS.
8708C                      N      = THE INTEGER NUMBER OF OBSERVATIONS
8709C                               IN THE VECTOR X.
8710C                      FREQ   = THE SINGLE PRECISION
8711C                               DEMODULATION FREQUENCY.
8712C                               F IS IN UNITS OF CYCLES PER DATA POINT.
8713C                               F IS BETWEEN 0.0 AND 0.5 (EXCLUSIVELY).
8714C     OUTPUT--2 PAGES OF AUTOMATIC PRINTOUT--
8715C             1) AN AMPLITUDE PLOT;
8716C             2) A PHASE PLOT; AND
8717C             3) AN UPDATED DEMODULATION FREQUENCY ESTIMATE.
8718C     PRINTING--YES.
8719C     RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N
8720C                   FOR THIS SUBROUTINE IS 5000.
8721C                 --THE SAMPLE SIZE N MUST BE GREATER
8722C                   THAN OR EQUAL TO 3.
8723C                 --THE INPUT FREQUENCY F MUST BE
8724C                   GREATER THAN OR EQUAL TO 2/(N-2).
8725C                 --THE INPUT FREQUENCY F MUST BE
8726C                   SMALLER THAN 0.5.
8727C     OTHER DATAPAC   SUBROUTINES NEEDED--PLOTX.
8728C     FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT, SIN, COS, ATAN.
8729C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
8730C     LANGUAGE--ANSI FORTRAN (1977)
8731C     COMMENT--IN ORDER THAT THE RESULTS OF THE COMPLEX DEMODULATION
8732C              BE VALID AND PROPERLY INTERPRETED, THE INPUT DATA
8733C              IN X SHOULD BE EQUI-SPACED IN TIME
8734C              (OR WHATEVER VARIABLE CORRESPONDS TO TIME).
8735C            --IF THE INPUT OBSERVATIONS IN X ARE CONSIDERED
8736C              TO HAVE BEEN COLLECTED 1 SECOND APART IN TIME,
8737C              THEN THE DEMODULATION FREQUENCY F
8738C              WOULD BE IN UNITS OF HERTZ
8739C              (= CYCLES PER SECOND).
8740C            --A FREQUENCY OF 0.0 CORRESPONDS TO A CYCLE
8741C              IN THE DATA OF INFINITE (= 1/(0.0))
8742C              LENGTH OR PERIOD.
8743C              A FREQUENCY OF 0.5 CORRESPONDS TO A CYCLE
8744C              IN THE DATA OF LENGTH = 1/(0.5) = 2 DATA POINTS.
8745C            --IN EXAMINING THE AMPLITUDE AND PHASE PLOTS,
8746C              ATTENTION SHOULD BE PAID NOT ONLY TO THE
8747C              STRUCTURE OF THE PHASE PLOT
8748C              (NEAR-ZERO SLOPE VERSUS NON-ZERO SLOPE)
8749C              BUT ALSO TO THE RANGE
8750C              OF VALUES ON THE VERTICAL AXIS.
8751C              A PLOT WITH MUCH STRUCTURE BUT
8752C              WITH A SMALL RANGE ON THE VERTICAL AXIS
8753C              IS USUALLY MORE INDICATIVE OF A
8754C              DEFINITE CYCLIC COMPONENT AT THE
8755C              SPECIFIED INPUT DEMODULATION FREQUENCY,
8756C              THAN IS A PLOT WITH LESS STRUCTURE BUT
8757C              A WIDER RANGE ON THE VERTICAL AXIS.
8758C            --INTERNAL TO THIS SUBROUTINE, 2 MOVING
8759C              AVERAGES ARE APPLIED, EACH OF LENGTH 1/F.
8760C              HENCE THE AMPLITUDE AND PHASE PLOTS
8761C              HAVE N - 2/F VALUES
8762C              (RATHER THAN N VALUES) ALONG THE
8763C              HORIZONTAL (TIME) AXIS.
8764C              IN ORDER THAT THE AMPLITUDE AND PHASE
8765C              PLOTS BE NON-EMPTY, AN INPUT
8766C              REQUIREMENT ON F FOR THIS SUBROUTINE
8767C              IS THAT THE SAMPLE SIZE N
8768C              AND THE DEMODULATION FREQUENCY F
8769C              MUST BE SUCH THAT
8770C              N - 2/F BE GREATER THAN ZERO.
8771C              FURTHER, SINCE A PLOT WITH BUT
8772C              1 POINT IS MEANINGLESS
8773C              AND OUGHT ALSO BE EXCLUDED,
8774C              THE REQUIREMENT IS EXTENDED
8775C              SO THAT N - 2/F MUST BE GREATER THAN 1.
8776C     REFERENCES--GRANGER AND HATANAKA, PAGES 170 TO 189,
8777C                 ESPECIALLY PAGES 173, 177, AND 182.
8778C     WRITTEN BY--JAMES J. FILLIBEN
8779C                 STATISTICAL ENGINEERING DIVISION
8780C                 INFORMATION TECHNOLOGY LABORATORY
8781C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
8782C                 GAITHERSBURG, MD 20899-8980
8783C                 PHONE--301-975-2899
8784C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
8785C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
8786C     LANGUAGE--ANSI FORTRAN (1966)
8787C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
8788C                          DENOTED BY QUOTES RATHER THAN NH.
8789C     VERSION NUMBER--82/7
8790C     ORIGINAL VERSION--NOVEMBER  1972.
8791C     UPDATED         --NOVEMBER  1975.
8792C     UPDATED         --FEBRUARY  1976.
8793C     UPDATED         --JUNE      1978.
8794C     UPDATED         --JANUARY   1981.
8795C     UPDATED         --MAY       1982.
8796C
8797C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
8798C
8799      CHARACTER*4 ICASPL
8800      CHARACTER*4 IBUGG3
8801      CHARACTER*4 ISUBRO
8802      CHARACTER*4 IERROR
8803C
8804      CHARACTER*4 ISUBN1
8805      CHARACTER*4 ISUBN2
8806C
8807C---------------------------------------------------------------------
8808C
8809      INCLUDE 'DPCOPA.INC'
8810C
8811      DIMENSION Y(*)
8812C
8813      DIMENSION Y2(*)
8814      DIMENSION X2(*)
8815      DIMENSION D2(*)
8816C
8817C---------------------------------------------------------------------
8818C
8819      INCLUDE 'DPCOP2.INC'
8820C
8821C-----DATA STATEMENTS-------------------------------------------------
8822C
8823      DATA PI/3.141592653/
8824C
8825C-----START POINT-----------------------------------------------------
8826C
8827      ISUBN1='DPCD'
8828      ISUBN2='2   '
8829C
8830      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PCD2')THEN
8831        WRITE(ICOUT,999)
8832  999   FORMAT(1X)
8833        CALL DPWRST('XXX','BUG ')
8834        WRITE(ICOUT,51)
8835   51   FORMAT('***** AT THE BEGINNING OF DPCD2--')
8836        CALL DPWRST('XXX','BUG ')
8837        WRITE(ICOUT,52)N,ICASPL
8838   52   FORMAT('N,ICASPL = ',I8,2X,A4)
8839        CALL DPWRST('XXX','BUG ')
8840      ENDIF
8841C
8842      ILOWER=3
8843      IUPPER=MAXOBV
8844      AN=N
8845      FMIN=2.0/(AN-2.0)
8846C
8847C               ********************************************
8848C               **  STEP 0--                              **
8849C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
8850C               ********************************************
8851C
8852      IF(N.LT.ILOWER.OR.N.GT.IUPPER)GOTO50
8853      IF(F.LE.FMIN.OR.F.GE.0.5)GOTO60
8854      HOLD=Y(1)
8855      DO65I=2,N
8856      IF(Y(I).NE.HOLD)GOTO95
8857   65 CONTINUE
8858      WRITE(ICOUT, 9)HOLD
8859      CALL DPWRST('XXX','BUG ')
8860      GOTO9000
8861   50 WRITE(ICOUT,17)ILOWER,IUPPER
8862      CALL DPWRST('XXX','BUG ')
8863      WRITE(ICOUT,47)N
8864      CALL DPWRST('XXX','BUG ')
8865      GOTO9000
8866   60 WRITE(ICOUT,27)FMIN
8867      CALL DPWRST('XXX','BUG ')
8868      WRITE(ICOUT,46)F
8869      CALL DPWRST('XXX','BUG ')
8870      WRITE(ICOUT,28)FMIN,N
8871      CALL DPWRST('XXX','BUG ')
8872      GOTO9000
8873   95 CONTINUE
8874    9 FORMAT('***** WARNING--THE FIRST ARGUMENT ',
8875     1'(A VECTOR) TO THE DPCD2  SUBROUTINE HAS ALL ELEMENTS = ',
8876     1G15.7)
8877   17 FORMAT('***** ERROR--THE SECOND ARGUMENT TO THE ',
8878     1'DPCD2  SUBROUTINE IS OUTSIDE THE ALLOWABLE (',I6,',',I6,') ',
8879     1'INTERVAL')
8880   27 FORMAT('***** ERROR--THE THIRD ARGUMENT TO THE ',
8881     1'DPCD2  SUBROUTINE IS OUTSIDE THE ALLOWABLE (',I6,'0.5) ',
8882     1'INTERVAL')
8883   28 FORMAT('                   THE ABOVE LOWER LIMIT (',F11.8,
8884     1') = 2/(N-2) WHERE N = THE INPUT SAMPLE SIZE = ',I8)
8885   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.8)
8886   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
8887C
8888C               ******************************
8889C               **  STEP 1--                **
8890C               **  FORM THE COSINE SERIES  **
8891C               ******************************
8892C
8893      DO100I=1,N
8894        AI=I
8895        Y2(I)=Y(I)*COS(2.0*PI*F*AI)
8896  100 CONTINUE
8897C
8898C     DEFINE THE LENGTH OF THE 2 MOVING AVERAGES
8899C
8900      LENMA1=INT(1.0/F)
8901      LENMA2=INT(1.0/F)
8902      ALEN1=REAL(LENMA1)
8903      ALEN2=REAL(LENMA2)
8904      IMAX1=N-LENMA1
8905      IMAX2=IMAX1-LENMA2
8906C
8907C               *********************************************************
8908C               **  STEP 2--                                           **
8909C               **  FORM THE FIRST MOVING AVERAGE FOR THE COSINE SERIES**
8910C               *********************************************************
8911C
8912      DO200I=1,IMAX1
8913        ISTART=I+1
8914        IEND=I+LENMA1-1
8915        IENDP1=I+LENMA1
8916        SUM=0.0
8917        DO300J=ISTART,IEND
8918          SUM=SUM+Y2(J)
8919  300   CONTINUE
8920        SUM=SUM+Y2(I)/2.0+Y2(IENDP1)/2.0
8921        D2(I)=SUM/ALEN1
8922  200 CONTINUE
8923C
8924C               ************************************************************
8925C               **  STEP 3--                                              **
8926C               **  FORM THE SECOND MOVING AVERAGE FOR THE COSINE SERIES  **
8927C               ************************************************************
8928C
8929      DO400I=1,IMAX2
8930        ISTART=I+1
8931        IEND=I+LENMA2-1
8932        IENDP1=I+LENMA2
8933        SUM=0.0
8934        DO500J=ISTART,IEND
8935          SUM=SUM+D2(J)
8936  500   CONTINUE
8937        SUM=SUM+D2(I)/2.0+D2(IENDP1)/2.0
8938        Y2(I)=SUM/ALEN2
8939  400 CONTINUE
8940C
8941C               ****************************
8942C               **  STEP 4--              **
8943C               **  FORM THE SINE SERIES  **
8944C               ****************************
8945C
8946      DO700I=1,N
8947        AI=I
8948        X2(I)=Y(I)*SIN(2.0*PI*F*AI)
8949  700 CONTINUE
8950C
8951C               *********************************************************
8952C               **  STEP 5--                                           **
8953C               **  FORM THE FIRST MOVING AVERAGE FOR THE SINE SERIES  **
8954C               *********************************************************
8955C
8956      DO800I=1,IMAX1
8957        ISTART=I+1
8958        IEND=I+LENMA1-1
8959        IENDP1=I+LENMA1
8960        SUM=0.0
8961        DO900J=ISTART,IEND
8962          SUM=SUM+X2(J)
8963  900   CONTINUE
8964        SUM=SUM+X2(I)/2.0+X2(IENDP1)/2.0
8965        D2(I)=SUM/ALEN1
8966  800 CONTINUE
8967C
8968C               **********************************************************
8969C               **  STEP 6--                                            **
8970C               **  FORM THE SECOND MOVING AVERAGE FOR THE SINE SERIES  **
8971C               **********************************************************
8972C
8973      DO1000I=1,IMAX2
8974        ISTART=I+1
8975        IEND=I+LENMA1-1
8976        IENDP1=I+LENMA1
8977        SUM=0.0
8978        DO1100J=ISTART,IEND
8979          SUM=SUM+D2(J)
8980 1100   CONTINUE
8981        SUM=SUM+D2(I)/2.0+D2(IENDP1)/2.0
8982        X2(I)=SUM/ALEN2
8983 1000 CONTINUE
8984C
8985C     CHECK FOR DESIRED CASE
8986C     AND BRANCH ACCORDINGLY.
8987C
8988      IF(ICASPL.EQ.'CDAM')GOTO1400
8989      IF(ICASPL.EQ.'CDPH')GOTO1700
8990C
8991      WRITE(ICOUT,999)
8992      CALL DPWRST('XXX','BUG ')
8993      WRITE(ICOUT,1311)
8994 1311 FORMAT('***** INTERNAL ERROR IN DPCD2 ',
8995     1'AT BRANCH POINT 1311--')
8996      CALL DPWRST('XXX','BUG ')
8997      WRITE(ICOUT,1312)
8998 1312 FORMAT('      ICASPL SHOULD BE EITHER')
8999      CALL DPWRST('XXX','BUG ')
9000      WRITE(ICOUT,1313)
9001 1313 FORMAT('      CDAM   OR    CDPH, BUT IS NEITHER.')
9002      CALL DPWRST('XXX','BUG ')
9003      WRITE(ICOUT,1314)ICASPL
9004 1314 FORMAT('      ICASPL = ',A4)
9005      CALL DPWRST('XXX','BUG ')
9006      IERROR='YES'
9007      GOTO9000
9008C
9009C               *****************************************
9010C               **  STEP 7--                           **
9011C               **  FORM THE AMPLITUDES AND PLOT THEM  **
9012C               *****************************************
9013C
9014 1400 CONTINUE
9015      DO1450I=1,IMAX2
9016      Y2(I)=2.0*SQRT(Y2(I)*Y2(I)+X2(I)*X2(I))
9017      X2(I)=I
9018      D2(I)=1.0
9019 1450 CONTINUE
9020      N2=IMAX2
9021      NPLOTV=2
9022CCCCC WRITE(ICOUT,1451)F
9023C1451 FORMAT(30X, 48HAMPLITUDE PLOT FOR THE DEMODULATION FREQUENCY =
9024CCCCC1 ,F8.6,21H CYCLES PER UNIT TIME)
9025CCCCC CALL DPWRST('XXX','BUG ')
9026C
9027C     COMPUTE THE DIFFERENCE BETWEEN THE MAX AND MIN AMPLITUDES AND WRITE IT OUT
9028C
9029      Y2MIN=Y2(1)
9030      Y2MAX=Y2(1)
9031      DO1600I=1,IMAX2
9032      IF(Y2(I).LT.Y2MIN)Y2MIN=Y2(I)
9033      IF(Y2(I).GT.Y2MAX)Y2MAX=Y2(I)
9034 1600 CONTINUE
9035      RANGE=Y2MAX-Y2MIN
9036CCCCC WRITE(ICOUT,1651)Y2MIN,Y2MAX,RANGE
9037C1651 FORMAT(9X,20HMINIMUM AMPLITUDE = ,E15.8,5X,20HMAXIMUM AMPLITUD
9038CCCCC1E = ,E15.8,5X,22HRANGE OF AMPLITUDES = ,E15.8)
9039CCCCC CALL DPWRST('XXX','BUG ')
9040      GOTO9000
9041C
9042C               *************************************
9043C               **  STEP 8--                       **
9044C               **  FORM THE PHASES AND PLOT THEM  **
9045C               *************************************
9046C
9047 1700 CONTINUE
9048      DO1750I=1,IMAX2
9049        Y2(I)=ATAN(Y2(I)/X2(I))
9050        X2(I)=I
9051        D2(I)=1.0
9052 1750 CONTINUE
9053      N2=IMAX2
9054      NPLOTV=2
9055C
9056CCCCC WRITE(ICOUT,1751)F
9057C1751 FORMAT(32X, 44HPHASE PLOT FOR THE DEMODULATION FREQUENCY = ,F8
9058CCCCC1.6,21H CYCLES PER UNIT TIME)
9059CCCCC CALL DPWRST('XXX','BUG ')
9060C
9061C     COMPUTE A NEW ESTIMATE FOR THE DEMODULATION FREQUENCY AND WRITE IT OUT
9062C
9063      AIMAX2=IMAX2
9064      IMAX2M=IMAX2-1
9065      IFLAG=0
9066      Y2MIN=Y2(1)
9067      Y2MAX=Y2(1)
9068      DO1800I=1,IMAX2M
9069        IP1=I+1
9070        DEL=Y2(IP1)-Y2(I)
9071        IF(DEL.GT.2.5)IFLAG=IFLAG-1
9072        IF(DEL.LT.-2.5)IFLAG=IFLAG+1
9073        AIFLAG=REAL(IFLAG)
9074        Y2NEW=Y2(IP1)+AIFLAG*PI
9075        IF(Y2NEW.LT.Y2MIN)Y2MIN=Y2NEW
9076        IF(Y2NEW.GT.Y2MAX)Y2MAX=Y2NEW
9077 1800 CONTINUE
9078      RANGE=Y2MAX-Y2MIN
9079      SLOPER=RANGE/AIMAX2
9080      SLOPEH=SLOPER/(2.0*PI)
9081      FEST=F+SLOPEH
9082      DEMODF=FEST
9083CCCCC WRITE(ICOUT,2025)Y2MIN,Y2MAX,RANGE
9084C2025 FORMAT(3X,16HMINIMUM PHASE = ,E15.8,11H RADIANS   ,16HMAXIMUM
9085CCCCC1PHASE = ,E15.8,11H RADIANS   ,18HRANGE OF PHASES = ,E15.8,8H RADIA
9086CCCCC1NS)
9087CCCCC CALL DPWRST('XXX','BUG ')
9088CCCCC WRITE(ICOUT,2030)SLOPER,SLOPEH,FEST
9089C2030 FORMAT(8HSLOPE = ,E14.8,11H RADIANS = ,E14.6,52H CYCLES PER UN
9090CCCCC1IT TIME    EST. OF NEW DEMOD. FREQ. = ,E15.8,15H CYC./UNIT TIME)
9091CCCCC CALL DPWRST('XXX','BUG ')
9092C
9093C               *****************
9094C               **  STEP 90--  **
9095C               **  EXIT       **
9096C               *****************
9097C
9098 9000 CONTINUE
9099      RETURN
9100      END
9101      SUBROUTINE DPCDC3(Y,N,ICASA2,ICASA4,ISEED,MAXNXT,
9102     1                  TEMP1,ALPHA,NALPHA,ALOWLM,AUPPLM,
9103     1                  CD,YMED,YAAD,
9104     1                  ISUBRO,IBUGA3,IERROR)
9105C
9106C     PURPOSE--THIS SUBROUTINE COMPUTES CONFIDENCE LIMITS FOR THE
9107C              COEFFIENT OF DISPERSION.  THE COEFFICIENT OF DISPERSION
9108C              IS AN ALTERNATIVE TO THE COEFFICIENT OF VARIATION FOR
9109C              NON-NORMAL DATA.
9110C
9111C              THE FOLLOWING CASES ARE SUPPORTED:
9112C
9113C                 LET A = LOWER COEFFICIENT OF DISPERSION CONFIDENCE LIMIT Y
9114C                 LET A = UPPER COEFFICIENT OF DISPERSION CONFIDENCE LIMIT Y
9115C                 LET A = ONE SIDED LOWER COEFFICIENT OF DISPERSION CONFIDENCE LIMIT Y
9116C                 LET A = ONE SIDED UPPER COEFFICIENT OF DISPERSION CONFIDENCE LIMIT Y
9117C
9118C              THE DATA CONSISTS OF N OBSERVATIONS IN Y.
9119C
9120C              THIS ALGORITHM IS FROM THE BONETT AND SEIER PAPER.
9121C
9122C              THE COEFFICIENT OF DISPERSION IS DEFINED AS:
9123C
9124C                  CD = MEAN ABSOLUTE DEVIATION/MEDIAN
9125C
9126C     INPUT ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR OF
9127C                               (UNSORTED OR SORTED) OBSERVATIONS.
9128C                    --N      = THE INTEGER NUMBER OF OBSERVATIONS
9129C                               IN THE VECTOR Y.
9130C                    --ALPHA  = THE SINGLE PRECISION VECTOR OF CONFIDENCE
9131C                               LEVELS
9132C                      NALPHA = THE INTEGER NUMBER OF ALPHA VALUES
9133C     OUTPUT ARGUMENTS-ALOWLM = THE SINGLE PRECISION VECTOR OF LOWER
9134C                               CONFIDENCE LIMIT VALUES
9135C                     -AUPPLM = THE SINGLE PRECISION VECTOR OF UPPER
9136C                               CONFIDENCE LIMIT VALUES
9137C     OTHER DATAPAC   SUBROUTINES NEEDED--MEDIAN, MEAN, VAR, AAD, SORT.
9138C     FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT.
9139C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
9140C     LANGUAGE--ANSI FORTRAN.
9141C     REFERENCES--BONETT AND SEIER (2006), "CONFIDENCE INTERVAL FOR A
9142C                 COEFFICIENT OF DISPERSION", BIOMETRICAL JOURNAL,
9143C                 VOL. 48, NO. 1, PP. 144-148.
9144C     WRITTEN BY--ALAN HECKERT
9145C                 STATISTICAL ENGINEERING LABORATORY
9146C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
9147C                 GAITHERSBURG, MD 20899-8980
9148C                 PHONE--301-975-2899
9149C     ORIGINAL VERSION--NOVEMBER  2017.
9150C
9151C---------------------------------------------------------------------
9152C
9153      DIMENSION Y(*)
9154      DIMENSION TEMP1(*)
9155      DIMENSION ALOWLM(*)
9156      DIMENSION AUPPLM(*)
9157      DIMENSION ALPHA(*)
9158C
9159      INTEGER ASTAR
9160      INTEGER BSTAR
9161C
9162      CHARACTER*4 ICASA2
9163      CHARACTER*4 ICASA4
9164      CHARACTER*4 ISUBRO
9165      CHARACTER*4 IBUGA3
9166      CHARACTER*4 IERROR
9167C
9168      CHARACTER*4 IWRITE
9169      CHARACTER*4 ISUBN1
9170      CHARACTER*4 ISUBN2
9171      CHARACTER*4 ISTEPN
9172C
9173      INCLUDE 'DPCOP2.INC'
9174C
9175C-----START POINT-----------------------------------------------------
9176C
9177      ISUBN1='CDC3'
9178      ISUBN2='    '
9179      IWRITE='OFF'
9180      IERROR='NO'
9181C
9182      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CDC3')THEN
9183        WRITE(ICOUT,999)
9184  999   FORMAT(1X)
9185        CALL DPWRST('XXX','WRIT')
9186        WRITE(ICOUT,51)
9187   51   FORMAT('**** AT THE BEGINNING OF DPCDC3--')
9188        CALL DPWRST('XXX','WRIT')
9189        WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASA2,ICASA4
9190   52   FORMAT('IBUGA3,ISUBRO,ICASA2,ICASA4 = ',3(A4,2X),A4)
9191        CALL DPWRST('XXX','WRIT')
9192        WRITE(ICOUT,53)N,NALPHA,ISEED,ALPHA(1)
9193   53   FORMAT('N,NALPHA,ISEED,ALPHA(1) = ',3I8,G15.7)
9194        CALL DPWRST('XXX','WRIT')
9195        DO56I=1,N
9196          WRITE(ICOUT,57)I,Y(I)
9197   57     FORMAT('I,Y(I) = ',I8,G15.7)
9198          CALL DPWRST('XXX','WRIT')
9199   56   CONTINUE
9200        DO76I=1,NALPHA
9201          WRITE(ICOUT,77)I,ALPHA(I)
9202   77     FORMAT('I,ALPHA(I) = ',I8,G15.7)
9203          CALL DPWRST('XXX','WRIT')
9204   76   CONTINUE
9205      ENDIF
9206C
9207C               ********************************************
9208C               **  STEP 11--                             **
9209C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
9210C               ********************************************
9211C
9212      ISTEPN='11'
9213      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CDC3')
9214     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9215C
9216      DO110I=1,NALPHA
9217        ALOWLM(I)=CPUMIN
9218        AUPPLM(I)=CPUMIN
9219  110 CONTINUE
9220C
9221      IF(N.LT.3)THEN
9222        WRITE(ICOUT,999)
9223        CALL DPWRST('XXX','WRIT')
9224        WRITE(ICOUT,101)
9225  101   FORMAT('***** ERROR: COEFFICIENT OF DISPERSION CONFIDENCE ',
9226     1         'LIMITS--')
9227        CALL DPWRST('XXX','WRIT')
9228        WRITE(ICOUT,102)
9229  102   FORMAT('      THE NUMBER OF ORIGINAL OBSERVATIONS  IS LESS ',
9230     1         'THAN THREE.')
9231        CALL DPWRST('XXX','WRIT')
9232        WRITE(ICOUT,103)N
9233  103   FORMAT('      SAMPLE SIZE = ',I8)
9234        CALL DPWRST('XXX','WRIT')
9235        IERROR='YES'
9236        GOTO9000
9237      ENDIF
9238C
9239C               ********************************************
9240C               **  STEP 21--                             **
9241C               **  CARRY OUT CALCULATIONS FOR CONFIDENCE **
9242C               **  LIMITS.                               **
9243C               ********************************************
9244C
9245      ISTEPN='21'
9246      IF(IBUGA3.EQ.'ON'.AND.ISUBRO.EQ.'CDC3')
9247     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9248C
9249C     ICASA2:  LOWE     => LOWER LIMIT
9250C              UPPE     => UPPER LIMIT
9251C     ICASA4:  ONES     => ONE-SIDED LIMIT
9252C              TWOS     => TWO-SIDED LIMIT
9253C
9254C     COMPUTE MEDIAN AND MEAN ABSOLUTE DEVIATION FROM MEDIAN
9255C
9256      CALL MEDIAN(Y,N,IWRITE,TEMP1,MAXNXT,YMED,IBUGA3,IERROR)
9257      CALL AAD(Y,N,IWRITE,TEMP1,MAXNXT,YAAD,'MEDI',IBUGA3,IERROR)
9258C
9259      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CDC3')THEN
9260        WRITE(ICOUT,201)YMED,YAAD
9261  201   FORMAT('YMED,YAAD = ',2G15.7)
9262        CALL DPWRST('XXX','WRIT')
9263      ENDIF
9264C
9265      IF(YAAD.EQ.0.0)THEN
9266        WRITE(ICOUT,999)
9267        CALL DPWRST('XXX','WRIT')
9268        WRITE(ICOUT,101)
9269        CALL DPWRST('XXX','WRIT')
9270        WRITE(ICOUT,207)
9271  207   FORMAT('      THE MEAN ABSOLUTE DEVIATION FROM THE MEDIAN IS ',
9272     1         'ZERO.')
9273        CALL DPWRST('XXX','WRIT')
9274        WRITE(ICOUT,209)
9275  209   FORMAT('      THE COEFFICIENT OF DISPERSION CONFIDENCE LIMIT ',
9276     1         'IS NOT COMPUTED IN THIS CASE.')
9277        CALL DPWRST('XXX','WRIT')
9278        IERROR='YES'
9279        GOTO9000
9280      ELSEIF(YMED.LE.0.0)THEN
9281        WRITE(ICOUT,999)
9282        CALL DPWRST('XXX','WRIT')
9283        WRITE(ICOUT,101)
9284        CALL DPWRST('XXX','WRIT')
9285        WRITE(ICOUT,217)
9286  217   FORMAT('      THE MEDIAN OF THE OBSERVATIONS IS NON-POSITIVE.')
9287        CALL DPWRST('XXX','WRIT')
9288        WRITE(ICOUT,209)
9289        CALL DPWRST('XXX','WRIT')
9290        IERROR='YES'
9291        GOTO9000
9292      ENDIF
9293C
9294      CD=YAAD/YMED
9295C
9296      CALL MEAN(Y,N,IWRITE,U,IBUGA3,IERROR)
9297      CALL VAR(Y,N,IWRITE,V,IBUGA3,IERROR)
9298C
9299      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CDC3')THEN
9300        WRITE(ICOUT,220)CD,U,V
9301  220   FORMAT('CD,U,V = ',3G15.7)
9302        CALL DPWRST('XXX','WRIT')
9303      ENDIF
9304C
9305      AN=REAL(N)
9306      DEL=(U-YMED)/YAAD
9307      GAM=V/(YAAD**2)
9308      CALL SORT(Y,N,Y)
9309      C=AN/(AN-1.0)
9310      TERM1=(AN+1.0)/2.0 - SQRT(AN)
9311      ASTAR=INT(TERM1+0.5)
9312      BSTAR=N-ASTAR+1
9313      TERM1=LOG(Y(ASTAR)) - LOG(Y(BSTAR))
9314      VRLETA=(TERM1/4.0)**2
9315      SE1=SQRT(VRLETA)
9316      VRLTAU=(GAM + (DEL**2) - 1.0)/AN
9317      SE2=SQRT(VRLTAU)
9318      CVLTLE=(DEL*SQRT(VRLETA))/SQRT(AN)
9319      AK=SQRT(VRLETA + VRLTAU - 2.0*CVLTLE)/(SE1 + SE2)
9320C
9321      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CDC3')THEN
9322        WRITE(ICOUT,223)DEL,GAMC,VRLETA,SE1,VRLTAU,SE2
9323  223   FORMAT('DEL,GAMC,VRLETA,SE1,VRLTAU,SE2 = ',6G15.7)
9324        CALL DPWRST('XXX','WRIT')
9325        WRITE(ICOUT,225)ASTAR,BSTAR,CVLTLE,AK
9326  225   FORMAT('ASTAR,BSTAR,CVLTLE,AK = ',2I8,2G15.7)
9327        CALL DPWRST('XXX','WRIT')
9328      ENDIF
9329C
9330      DO300I=1,NALPHA
9331C
9332C       GET NORMAL CRITICAL VALUE
9333C
9334        ALP=ALPHA(I)
9335        IF(ALP.GE.1.0 .AND. ALP.LE.100.)ALP=ALP/100.
9336        IF(ALP.LE.0.0 .OR. ALP.GE.1.0)THEN
9337          IF(ICASA4.EQ.'ONES')THEN
9338            Z=1.645
9339          ELSE
9340            Z=1.96
9341          ENDIF
9342        ELSE
9343          IF(ALP.LT.0.5)THEN
9344            ALP=1.0-ALP
9345          ENDIF
9346          ALP=1.0 - ALP
9347          IF(ICASA4.EQ.'ONES')THEN
9348            P1=ALP
9349            P2=1.0-ALP
9350            CALL NORPPF(P2,Z)
9351          ELSE
9352            P1=ALP/2.0
9353            P2=1.0-(ALP/2.0)
9354            CALL NORPPF(P2,Z)
9355          ENDIF
9356        ENDIF
9357C
9358        A=(AN+1)/2.0 - AK*Z*SQRT(AN/4.0)
9359        IA=INT(A+0.5)
9360        IF(IA.LE.0)THEN
9361          ALOWLM(I)=EXP(AL1-AU2STR)
9362          AUPPLM(I)=EXP(AU1 -AL2STR)
9363        ELSE
9364          IB=N - IA + 1
9365          AL2STR=LOG(Y(IA))
9366          AU2STR=LOG(Y(IB))
9367          AL1=LOG(C*YAAD) - AK*Z*SE2
9368          AU1=LOG(C*YAAD) + AK*Z*SE2
9369C
9370C         COMPUTE BOTH UPPER AND LOWER LIMIT.  LET CALLING ROUTINE
9371C         DETERMINE WHICH TO USE.
9372C
9373          ALOWLM(I)=EXP(AL1-AU2STR)
9374          AUPPLM(I)=EXP(AU1 -AL2STR)
9375        ENDIF
9376C
9377        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CDC3')THEN
9378          WRITE(ICOUT,311)I,IA,IB,Z,AL2STR,AU2STR
9379  311     FORMAT('I,IA,IB,Z,AL2STR,AU2STR = ',3I8,3G15.7)
9380          CALL DPWRST('XXX','WRIT')
9381          WRITE(ICOUT,313)AL1,AU1,ALOWLM(I),AUPPLM(I)
9382  313     FORMAT('AL1,AU1,ALOWLM(I),AUPPLM(I) = ',4G15.7)
9383          CALL DPWRST('XXX','WRIT')
9384        ENDIF
9385C
9386  300 CONTINUE
9387C
9388 9000 CONTINUE
9389      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CDC3')THEN
9390        WRITE(ICOUT,999)
9391        CALL DPWRST('XXX','WRIT')
9392        WRITE(ICOUT,9051)
9393 9051   FORMAT('**** AT THE END OF DPCDC3--')
9394        CALL DPWRST('XXX','WRIT')
9395      ENDIF
9396C
9397      RETURN
9398      END
9399      SUBROUTINE DPCDF1(Y,Y2,N,ICASPL,IFLAGD,
9400     1                  SHAPE1,SHAPE2,SHAPE3,SHAPE4,
9401     1                  SHAPE5,SHAPE6,SHAPE7,
9402     1                  YLOWLM,YUPPLM,A,B,MINMAX,
9403     1                  ICAPSW,ICAPTY,
9404     1                  IADEDF,IGEPDF,IMAKDF,IBEIDF,
9405     1                  ILGADF,ISKNDF,IGLDDF,IBGEDF,
9406     1                  IGETDF,ICONDF,IGOMDF,IKATDF,
9407     1                  IGIGDF,IGEODF,
9408     1                  KSLOC,KSSCAL,
9409     1                  IBUGA3,ISUBRO,IERROR)
9410C
9411C     PURPOSE--COMPUTE THE CDF VALUE AT GIVEN SET OF POINTS.  THIS
9412C              WILL BE USED BY VARIOUS K-S AND ANDERSON DARLING
9413C              ROUTINES.  THIS ROUTINE SIMPLY RETURNS THE ARRAY
9414C              OF COMPUTED CDF VALUES.  THE CALLING ROUTINE IS
9415C              RESPONSIBLE FOR CONVERTING THAT INTO A K-S,
9416C              ANDERSON-DARLING, OR SOME OTHER RELEVANT STATISTIC.
9417C
9418C              THIS ROUTINE HANDLES THE UNGROUPED, UNCENSORED CASE.
9419C              IF IFLAGD = 1, THEN DISCRETE DISTRIBUTIONS WILL
9420C              BE SKIPPED.
9421C
9422C     WRITTEN BY--ALAN HECKERT
9423C                 STATISTICAL ENGINEERING DIVISION
9424C                 INFORMATION TECHNOLOGY LABORATORY
9425C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
9426C                 GAITHERSBURG, MD 20899-8980
9427C                 PHONE--301-975-2899
9428C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
9429C           OF THE NATIONAL BUREAU OF STANDARDS.
9430C     LANGUAGE--ANSI FORTRAN (1977)
9431C     VERSION NUMBER--2009/9
9432C     ORIGINAL VERSION--SEPTEMBER 2009.
9433C     UPDATED         --JULY      2010. END EFFECTS WEIBULL
9434C     UPDATED         --AUGUST    2010. BRITTLE FIBER WEIBULL
9435C     UPDATED         --MARCH     2013. COSINE
9436C     UPDATED         --MAY       2014. 3-PARAMETER INVERSE GAUSSIAN
9437C
9438C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
9439C
9440      LOGICAL HYPPNT
9441C
9442      CHARACTER*4 ICASPL
9443      CHARACTER*4 ICAPSW
9444      CHARACTER*4 ICAPTY
9445      CHARACTER*4 IADEDF
9446      CHARACTER*4 IGEPDF
9447      CHARACTER*4 IMAKDF
9448      CHARACTER*4 IBEIDF
9449      CHARACTER*4 ILGADF
9450      CHARACTER*4 ISKNDF
9451      CHARACTER*4 IGLDDF
9452      CHARACTER*4 IBGEDF
9453      CHARACTER*4 IGETDF
9454      CHARACTER*4 ICONDF
9455      CHARACTER*4 IGOMDF
9456      CHARACTER*4 IKATDF
9457      CHARACTER*4 IGIGDF
9458      CHARACTER*4 IGEODF
9459      CHARACTER*4 IBUGA3
9460      CHARACTER*4 ISUBRO
9461      CHARACTER*4 IERROR
9462C
9463      CHARACTER*4 IWRITE
9464      CHARACTER*4 ISUBN1
9465      CHARACTER*4 ISUBN2
9466C
9467      REAL KSLOC
9468      REAL KSSCAL
9469C
9470      DOUBLE PRECISION DXOUT
9471      DOUBLE PRECISION DCDF
9472      DOUBLE PRECISION CDFGLO
9473      DOUBLE PRECISION CDFWAK
9474      DOUBLE PRECISION LANCDF
9475      DOUBLE PRECISION XPAR(5)
9476C
9477C---------------------------------------------------------------------
9478C
9479      DIMENSION Y(*)
9480      DIMENSION Y2(*)
9481C
9482C---------------------------------------------------------------------
9483C
9484      INCLUDE 'DPCOP2.INC'
9485C
9486C-----START POINT-----------------------------------------------------
9487C
9488C
9489      ISUBN1='DPCD'
9490      ISUBN2='F1  '
9491      IERROR='NO'
9492C
9493C               ********************************************
9494C               **  STEP 1--                              **
9495C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
9496C               ********************************************
9497C
9498CCCCC 2013/07: ALLOW ONE VALUE (FOR CALL FROM DPBEF2).
9499C
9500CCCCC IF(N.LT.2)THEN
9501      NMIN=1
9502      IF(N.LT.NMIN)THEN
9503        WRITE(ICOUT,999)
9504  999   FORMAT(1X)
9505        CALL DPWRST('XXX','BUG ')
9506        WRITE(ICOUT,31)
9507   31   FORMAT('***** ERROR IN DPCDF1--')
9508        CALL DPWRST('XXX','BUG ')
9509        WRITE(ICOUT,32)NMIN
9510   32   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST ',
9511     1         I1,'.')
9512        CALL DPWRST('XXX','BUG ')
9513        WRITE(ICOUT,34)N
9514   34   FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I5)
9515        CALL DPWRST('XXX','BUG ')
9516        WRITE(ICOUT,999)
9517        CALL DPWRST('XXX','BUG ')
9518        IERROR='YES'
9519        GOTO9000
9520      ENDIF
9521C
9522      IF(N.GT.1)THEN
9523        HOLD=Y(1)
9524        DO60I=1,N
9525          IF(Y(I).NE.HOLD)GOTO69
9526   60   CONTINUE
9527        WRITE(ICOUT,999)
9528        CALL DPWRST('XXX','BUG ')
9529        WRITE(ICOUT,31)
9530        CALL DPWRST('XXX','BUG ')
9531        WRITE(ICOUT,62)
9532   62   FORMAT('      ALL ELEMENTS IN THE RESPONSE VARIABLE ARE ',
9533     1         'IDENTICALLY EQUAL TO ',G15.7)
9534        CALL DPWRST('XXX','BUG ')
9535        WRITE(ICOUT,999)
9536        CALL DPWRST('XXX','BUG ')
9537        IERROR='YES'
9538        GOTO9000
9539   69   CONTINUE
9540      ENDIF
9541C
9542      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CDF1')THEN
9543        WRITE(ICOUT,999)
9544        CALL DPWRST('XXX','BUG ')
9545        WRITE(ICOUT,71)
9546   71   FORMAT('***** AT THE BEGINNING OF DPCDF1--')
9547        CALL DPWRST('XXX','BUG ')
9548        WRITE(ICOUT,72)ICASPL,ICAPSW,ICAPTY,N,MINMAX
9549   72   FORMAT('ICASPL,ICAPSW,ICAPTY,N,MINMAX = ',3(A4,2X),2I8)
9550        CALL DPWRST('XXX','BUG ')
9551        WRITE(ICOUT,74)KSLOC,KSSCAL,SHAPE1,SHAPE2
9552   74   FORMAT('KSLOC,KSSCAL,SHAPE1,SHAPE2 = ',4G15.7)
9553        CALL DPWRST('XXX','BUG ')
9554        DO85I=1,N
9555          WRITE(ICOUT,86)I,Y(I)
9556   86     FORMAT('I,Y(I) = ',I8,G15.7)
9557          CALL DPWRST('XXX','BUG ')
9558   85   CONTINUE
9559      ENDIF
9560C
9561C               ************************************************
9562C               **  STEP 2.1--                                **
9563C               **  COMPUTE CDF VALUE AT GIVEN POINTS         **
9564C               ************************************************
9565C
9566      ZSCALE=B - A
9567      ZLOC=A
9568      IWRITE='OFF'
9569      CALL MINIM(Y,N,IWRITE,XMIN,IBUGA3,IERROR)
9570      CALL MAXIM(Y,N,IWRITE,XMAX,IBUGA3,IERROR)
9571C
9572      IF(ICASPL.EQ.'UNIF')THEN
9573        DO1010I=1,N
9574          XL=(Y(I) - ZLOC)/ZSCALE
9575          CALL UNICDF(XL,Y2(I))
9576 1010   CONTINUE
9577C
9578      ELSEIF(ICASPL.EQ.'NORM')THEN
9579        DO1020I=1,N
9580          XL=(Y(I) - KSLOC)/KSSCAL
9581          CALL NODCDF(DBLE(XL),DXOUT)
9582          Y2(I)=REAL(DXOUT)
9583 1020   CONTINUE
9584C
9585      ELSEIF(ICASPL.EQ.'LOGI')THEN
9586        DO1030I=1,N
9587          XL=(Y(I) - KSLOC)/KSSCAL
9588          CALL LOGCDF(XL,Y2(I))
9589 1030   CONTINUE
9590C
9591      ELSEIF(ICASPL.EQ.'DEXP')THEN
9592        DO1040I=1,N
9593          XL=(Y(I) - KSLOC)/KSSCAL
9594          CALL DEXCDF(XL,Y2(I))
9595 1040   CONTINUE
9596C
9597      ELSEIF(ICASPL.EQ.'CAUC')THEN
9598        DO1050I=1,N
9599          XL=(Y(I) - KSLOC)/KSSCAL
9600          CALL CAUCDF(XL,Y2(I))
9601 1050   CONTINUE
9602C
9603      ELSEIF(ICASPL.EQ.'TULA')THEN
9604        DO1060I=1,N
9605          XL=(Y(I) - KSLOC)/KSSCAL
9606          CALL LAMCDF(XL,SHAPE1,Y2(I))
9607 1060   CONTINUE
9608C
9609      ELSEIF(ICASPL.EQ.'LOGN' .OR. ICASPL.EQ.'3LGN')THEN
9610        DO1070I=1,N
9611          XL=(Y(I) - KSLOC)/KSSCAL
9612          CALL LGNCDF(XL,SHAPE1,Y2(I))
9613 1070   CONTINUE
9614C
9615      ELSEIF(ICASPL.EQ.'HNOR' .OR. ICASPL.EQ.'1HNO')THEN
9616        DO1080I=1,N
9617          XL=(Y(I) - KSLOC)/KSSCAL
9618          CALL HFNCDF(XL,Y2(I))
9619 1080   CONTINUE
9620C
9621      ELSEIF(ICASPL.EQ.'TPP')THEN
9622        DO1090I=1,N
9623          XL=(Y(I) - KSLOC)/KSSCAL
9624          CALL TCDF(XL,SHAPE1,Y2(I))
9625 1090   CONTINUE
9626C
9627      ELSEIF(ICASPL.EQ.'CHIS')THEN
9628        DO1100I=1,N
9629          XL=(Y(I) - KSLOC)/KSSCAL
9630          CALL CHSCDF(XL,INT(SHAPE1+0.1),Y2(I))
9631 1100   CONTINUE
9632C
9633      ELSEIF(ICASPL.EQ.'FPP')THEN
9634        DO1110I=1,N
9635          XL=(Y(I) - KSLOC)/KSSCAL
9636          CALL FCDF(XL,INT(SHAPE1+0.1),INT(SHAPE2+0.1),Y2(I))
9637 1110   CONTINUE
9638C
9639      ELSEIF(ICASPL.EQ.'EXPO')THEN
9640        DO1120I=1,N
9641          XL=(Y(I) - KSLOC)/KSSCAL
9642          CALL EXPCDF(XL,Y2(I))
9643 1120   CONTINUE
9644C
9645      ELSEIF(ICASPL.EQ.'GAMM' .OR. ICASPL.EQ.'3GAM')THEN
9646        DO1130I=1,N
9647          XL=(Y(I) - KSLOC)/KSSCAL
9648          CALL GAMCDF(XL,SHAPE1,Y2(I))
9649 1130   CONTINUE
9650C
9651      ELSEIF(ICASPL.EQ.'BETA' .OR. ICASPL.EQ.'4BET')THEN
9652        DO1140I=1,N
9653          XL=(Y(I) - ZLOC)/ZSCALE
9654          CALL BETCDF(XL,SHAPE1,SHAPE2,Y2(I))
9655 1140   CONTINUE
9656C
9657      ELSEIF(ICASPL.EQ.'WEIB' .OR. ICASPL.EQ.'3WEI')THEN
9658        DO1150I=1,N
9659          XL=(Y(I) - KSLOC)/KSSCAL
9660          CALL WEICDF(XL,SHAPE1,MINMAX,Y2(I))
9661 1150   CONTINUE
9662C
9663      ELSEIF(ICASPL.EQ.'EV1 ')THEN
9664        DO1160I=1,N
9665          XL=(Y(I) - KSLOC)/KSSCAL
9666          CALL EV1CDF(XL,MINMAX,Y2(I))
9667 1160   CONTINUE
9668C
9669      ELSEIF(ICASPL.EQ.'EV2 ' .OR. ICASPL.EQ.'3EV2')THEN
9670        DO1170I=1,N
9671          XL=(Y(I) - KSLOC)/KSSCAL
9672          CALL EV2CDF(XL,SHAPE1,MINMAX,Y2(I))
9673 1170   CONTINUE
9674C
9675      ELSEIF(ICASPL.EQ.'PARE')THEN
9676        ZLOC=SHAPE2
9677        IF(ZLOC.GT.XMIN)ZLOC=XMIN
9678        DO1180I=1,N
9679          XL=(Y(I) - KSLOC)/KSSCAL
9680          CALL PARCDF(XL,SHAPE1,ZLOC,Y2(I))
9681 1180   CONTINUE
9682C
9683      ELSEIF(ICASPL.EQ.'BINO')THEN
9684        IF(IFLAGD.EQ.1)GOTO8000
9685        DO1190I=1,N
9686          XL=Y(I)
9687          CALL BINCDF(DBLE(XL),DBLE(SHAPE1),INT(SHAPE2+0.1),DXOUT)
9688          Y2(I)=REAL(DXOUT)
9689 1190   CONTINUE
9690C
9691      ELSEIF(ICASPL.EQ.'GEOM')THEN
9692        IF(IFLAGD.EQ.1)GOTO8000
9693        IF(IGEODF.EQ.'DLMF')THEN
9694          DO1200I=1,N
9695            XL=Y(I)
9696            CALL GE2CDF(DBLE(XL),DBLE(SHAPE1),DXOUT)
9697            Y2(I)=REAL(DXOUT)
9698 1200     CONTINUE
9699        ELSE
9700          DO1205I=1,N
9701            XL=Y(I)
9702            CALL GEOCDF(DBLE(XL),DBLE(SHAPE1),DXOUT)
9703            Y2(I)=REAL(DXOUT)
9704 1205     CONTINUE
9705        ENDIF
9706C
9707      ELSEIF(ICASPL.EQ.'POIS')THEN
9708        IF(IFLAGD.EQ.1)GOTO8000
9709        DO1210I=1,N
9710          XL=Y(I)
9711          CALL POICDF(XL,SHAPE1,Y2(I))
9712 1210   CONTINUE
9713C
9714      ELSEIF(ICASPL.EQ.'NEBI')THEN
9715        IF(IFLAGD.EQ.1)GOTO8000
9716        DO1220I=1,N
9717          XL=Y(I)
9718          CALL NBCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT)
9719          Y2(I)=REAL(DXOUT)
9720 1220   CONTINUE
9721C
9722      ELSEIF(ICASPL.EQ.'SEMI')THEN
9723        DO1230I=1,N
9724          XL=Y(I) - KSLOC
9725          CALL SEMCDF(XL,KSSCAL,Y2(I))
9726 1230   CONTINUE
9727C
9728      ELSEIF(ICASPL.EQ.'TRIA')THEN
9729        IF(A.EQ.CPUMIN .OR. B.EQ.CPUMAX)THEN
9730          ZLOWLM=-1.0
9731          ZUPPLM=1.0
9732        ELSE
9733          ZLOWLM=MIN(A,B)
9734          ZUPPLM=MAX(A,B)
9735        ENDIF
9736        IF(ZLOWLM.GT.XMIN)ZLOWLM=XMIN
9737        IF(ZUPPLM.LT.XMAX)ZUPPLM=XMAX
9738        IF(SHAPE1.LT.ZLOWLM .OR. SHAPE1.GT.ZUPPLM)THEN
9739          WRITE(ICOUT,999)
9740          CALL DPWRST('XXX','BUG ')
9741          WRITE(ICOUT,31)
9742          CALL DPWRST('XXX','BUG ')
9743          WRITE(ICOUT,1343)
9744 1343     FORMAT('       FOR THE TRIANGULAR DISTRIBUTION, THE VALUE')
9745          CALL DPWRST('XXX','BUG ')
9746          WRITE(ICOUT,1344)
9747 1344     FORMAT('       OF THE SHAPE PARAMETER IS OUTSIDE THE ',
9748     1           'INTERVAL')
9749          CALL DPWRST('XXX','BUG ')
9750          WRITE(ICOUT,1345)
9751 1345     FORMAT('       OF THE LOWER AND UPPER LIMIT PARAMETERS.')
9752          CALL DPWRST('XXX','BUG ')
9753          WRITE(ICOUT,1346)SHAPE1
9754 1346     FORMAT('       THE VALUE OF THE SHAPE PARAMETER       = ',
9755     1         G15.7)
9756          CALL DPWRST('XXX','BUG ')
9757          WRITE(ICOUT,1347)ZLOWLM
9758 1347     FORMAT('       THE VALUE OF THE LOWER LIMIT PARAMETER = ',
9759     1           G15.7)
9760          CALL DPWRST('XXX','BUG ')
9761          WRITE(ICOUT,1348)ZUPPLM
9762 1348     FORMAT('       THE VALUE OF THE LOWER LIMIT PARAMETER = ',
9763     1           G15.7)
9764          CALL DPWRST('XXX','BUG ')
9765          IERROR='YES'
9766          GOTO9000
9767        ENDIF
9768C
9769        DO1240I=1,N
9770          XL=Y(I)
9771          CALL TRICDF(XL,SHAPE1,ZLOWLM,ZUPPLM,Y2(I))
9772 1240   CONTINUE
9773C
9774      ELSEIF(ICASPL.EQ.'INGA' .OR. ICASPL.EQ.'3IGA')THEN
9775        DO1250I=1,N
9776          XL=(Y(I) - KSLOC)/KSSCAL
9777          CALL IGCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DCDF)
9778          Y2(I)=REAL(DCDF)
9779 1250   CONTINUE
9780C
9781      ELSEIF(ICASPL.EQ.'WALD')THEN
9782        AMU=1.0
9783        DO1260I=1,N
9784          XL=(Y(I) - KSLOC)/KSSCAL
9785          CALL IGCDF(DBLE(XL),DBLE(SHAPE1),DBLE(AMU),DCDF)
9786          Y2(I)=REAL(DCDF)
9787 1260   CONTINUE
9788C
9789      ELSEIF(ICASPL.EQ.'RIGA')THEN
9790        DO1270I=1,N
9791          XL=(Y(I) - KSLOC)/KSSCAL
9792          CALL RIGCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DCDF)
9793          Y2(I)=REAL(DCDF)
9794 1270   CONTINUE
9795C
9796      ELSEIF(ICASPL.EQ.'FATL')THEN
9797        DO1280I=1,N
9798          XL=(Y(I) - KSLOC)/KSSCAL
9799          CALL FLCDF(XL,SHAPE1,Y2(I))
9800 1280   CONTINUE
9801C
9802      ELSEIF(ICASPL.EQ.'GPAR')THEN
9803        DO1290I=1,N
9804          XL=(Y(I) - KSLOC)/KSSCAL
9805          CALL GEPCDF(XL,SHAPE1,MINMAX,IGEPDF,Y2(I))
9806 1290   CONTINUE
9807C
9808      ELSEIF(ICASPL.EQ.'DUNI')THEN
9809        IF(IFLAGD.EQ.1)GOTO8000
9810        DO1300I=1,N
9811          XL=Y(I)
9812          IXL=INT(XL+0.1)
9813          CALL DISCDF(IXL,INT(SHAPE1+0.1),Y2(I))
9814 1300   CONTINUE
9815C
9816      ELSEIF(ICASPL.EQ.'NCT ')THEN
9817        DO1310I=1,N
9818          XL=(Y(I) - KSLOC)/KSSCAL
9819          CALL NCTCDF(XL,SHAPE1,SHAPE2,Y2(I))
9820 1310   CONTINUE
9821C
9822      ELSEIF(ICASPL.EQ.'NCF ')THEN
9823        DO1320I=1,N
9824          XL=(Y(I) - KSLOC)/KSSCAL
9825          CALL NCFCDF(XL,SHAPE1,SHAPE2,SHAPE3,Y2(I))
9826 1320   CONTINUE
9827C
9828      ELSEIF(ICASPL.EQ.'NCCS')THEN
9829        DO1330I=1,N
9830          XL=(Y(I) - KSLOC)/KSSCAL
9831          CALL NCCCDF(XL,SHAPE1,SHAPE2,Y2(I))
9832 1330   CONTINUE
9833C
9834      ELSEIF(ICASPL.EQ.'NCBE')THEN
9835        DO1340I=1,N
9836          XL=(Y(I) - ZLOC)/ZSCALE
9837          CALL NCBCDF(XL,SHAPE1,SHAPE2,SHAPE3,Y2(I))
9838 1340   CONTINUE
9839C
9840      ELSEIF(ICASPL.EQ.'DNCT')THEN
9841        DO1350I=1,N
9842          XL=(Y(I) - KSLOC)/KSSCAL
9843          CALL DNTCDF(XL,SHAPE1,SHAPE2,SHAPE3,Y2(I))
9844 1350   CONTINUE
9845C
9846      ELSEIF(ICASPL.EQ.'DNCF')THEN
9847        DO1360I=1,N
9848          XL=(Y(I) - KSLOC)/KSSCAL
9849          CALL DNFCDF(XL,SHAPE1,SHAPE2,SHAPE3,SHAPE4,Y2(I))
9850 1360   CONTINUE
9851C
9852      ELSEIF(ICASPL.EQ.'HYPG')THEN
9853        IF(IFLAGD.EQ.1)GOTO8000
9854        HYPPNT=.FALSE.
9855        DO1365I=1,N
9856          XL=Y(I)
9857          CALL HYPCDF(INT(XL+0.1),INT(SHAPE1+0.1),INT(SHAPE2+0.1),
9858     1                INT(SHAPE3+0.1),HYPPNT,Y2(I))
9859 1365   CONTINUE
9860C
9861      ELSEIF(ICASPL.EQ.'VONM')THEN
9862        DO1370I=1,N
9863          XL=(Y(I) - KSLOC)/KSSCAL
9864          CALL VONCDF(XL,SHAPE1,Y2(I))
9865 1370   CONTINUE
9866C
9867      ELSEIF(ICASPL.EQ.'POWN')THEN
9868        DO1380I=1,N
9869          XL=(Y(I) - KSLOC)/KSSCAL
9870          CALL PNRCDF(XL,SHAPE1,Y2(I))
9871 1380   CONTINUE
9872C
9873      ELSEIF(ICASPL.EQ.'PLGN')THEN
9874        DO1390I=1,N
9875          XL=(Y(I) - KSLOC)/KSSCAL
9876          CALL PLNCDF(XL,SHAPE1,SHAPE2,Y2(I))
9877 1390   CONTINUE
9878C
9879      ELSEIF(ICASPL.EQ.'ALPH')THEN
9880        DO1400I=1,N
9881          XL=(Y(I) - KSLOC)/KSSCAL
9882          CALL ALPCDF(DBLE(XL),DBLE(SHAPE1),DXOUT)
9883          Y2(I)=REAL(DXOUT)
9884 1400   CONTINUE
9885C
9886      ELSEIF(ICASPL.EQ.'COSI')THEN
9887        DO1410I=1,N
9888          XL=(Y(I) - KSLOC)/KSSCAL
9889          CALL COSCDF(XL,Y2(I))
9890 1410   CONTINUE
9891C
9892      ELSEIF(ICASPL.EQ.'SINE')THEN
9893        DO1415I=1,N
9894          XL=(Y(I) - KSLOC)/KSSCAL
9895          CALL SINCDF(XL,Y2(I))
9896 1415   CONTINUE
9897C
9898      ELSEIF(ICASPL.EQ.'POWF')THEN
9899        DO1420I=1,N
9900          XL=(Y(I) - ZLOC)/ZSCALE
9901          CALL POWCDF(XL,SHAPE1,Y2(I))
9902 1420   CONTINUE
9903C
9904      ELSEIF(ICASPL.EQ.'CHI ')THEN
9905        DO1430I=1,N
9906          XL=(Y(I) - KSLOC)/KSSCAL
9907          CALL CHCDF(XL,SHAPE1,Y2(I))
9908 1430   CONTINUE
9909C
9910      ELSEIF(ICASPL.EQ.'LOGS')THEN
9911        IF(IFLAGD.EQ.1)GOTO8000
9912        DO1435I=1,N
9913          XL=Y(I)
9914          CALL DLGCDF(XL,SHAPE1,Y2(I))
9915 1435   CONTINUE
9916C
9917      ELSEIF(ICASPL.EQ.'LOGL')THEN
9918        DO1440I=1,N
9919          XL=(Y(I) - KSLOC)/KSSCAL
9920          CALL LLGCDF(XL,SHAPE1,Y2(I))
9921 1440   CONTINUE
9922C
9923      ELSEIF(ICASPL.EQ.'GGAM')THEN
9924        DO1450I=1,N
9925          XL=(Y(I) - KSLOC)/KSSCAL
9926          CALL GGDCDF(XL,SHAPE1,SHAPE2,Y2(I))
9927 1450   CONTINUE
9928C
9929      ELSEIF(ICASPL.EQ.'WARI')THEN
9930        IF(IFLAGD.EQ.1)GOTO8000
9931        DO1460I=1,N
9932          XL=Y(I)
9933CCCCC     CALL WARCDF(XL,SHAPE1,SHAPE2,Y2(I),'NOTR')
9934          CALL WARCDF(XL,SHAPE1,SHAPE2,Y2(I))
9935 1460   CONTINUE
9936C
9937      ELSEIF(ICASPL.EQ.'YULE')THEN
9938        IF(IFLAGD.EQ.1)GOTO8000
9939        DO1470I=1,N
9940          XL=Y(I)
9941          CALL YULCDF(DBLE(XL),DBLE(SHAPE1),DXOUT)
9942          Y2(I)=REAL(DXOUT)
9943 1470   CONTINUE
9944C
9945      ELSEIF(ICASPL.EQ.'ANGL')THEN
9946        DO1480I=1,N
9947          XL=(Y(I) - KSLOC)/KSSCAL
9948          CALL ANGCDF(XL,Y2(I))
9949 1480   CONTINUE
9950C
9951      ELSEIF(ICASPL.EQ.'ARSI')THEN
9952        DO1490I=1,N
9953          XL=(Y(I) - KSLOC)/KSSCAL
9954          CALL ARSCDF(XL,Y2(I))
9955 1490   CONTINUE
9956C
9957      ELSEIF(ICASPL.EQ.'FNOR')THEN
9958C
9959C       FOR FOLDED NORMAL, ARE PARAMETERS GIVEN AS LOCATION/SCALE
9960C       OR SHAPE1 AND SHAPE2?
9961C
9962        IF(SHAPE1.NE.CPUMIN .AND. SHAPE2.NE.CPUMIN)THEN
9963          AVAL1=SHAPE1
9964          AVAL2=SHAPE2
9965        ELSEIF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)THEN
9966          AVAL1=KSLOC
9967          AVAL2=KSSCAL
9968        ELSE
9969          AVAL1=0.0
9970          AVAL2=1.0
9971        ENDIF
9972C
9973        DO1500I=1,N
9974CCCCC     XL=(Y(I) - KSLOC)/KSSCAL
9975CCCCC     CALL FNRCDF(XL,KSLOC,KSSCAL,Y2(I))
9976          XL=Y(I)
9977          CALL FNRCDF(XL,AVAL1,AVAL2,Y2(I))
9978 1500   CONTINUE
9979C
9980      ELSEIF(ICASPL.EQ.'TNOR')THEN
9981        DO1510I=1,N
9982          XL=Y(I)
9983          CALL TNRCDF(DBLE(XL),DBLE(A),DBLE(B),
9984     1                DBLE(SHAPE1),DBLE(SHAPE2),DXOUT)
9985          Y2(I)=REAL(DXOUT)
9986 1510   CONTINUE
9987C
9988      ELSEIF(ICASPL.EQ.'LGAM')THEN
9989        DO1520I=1,N
9990          XL=(Y(I) - KSLOC)/KSSCAL
9991          CALL LGACDF(XL,SHAPE1,ILGADF,Y2(I))
9992 1520   CONTINUE
9993C
9994      ELSEIF(ICASPL.EQ.'HSEC')THEN
9995        DO1530I=1,N
9996          XL=(Y(I) - KSLOC)/KSSCAL
9997          CALL HSECDF(XL,Y2(I))
9998 1530   CONTINUE
9999C
10000      ELSEIF(ICASPL.EQ.'GOMP')THEN
10001        DO1540I=1,N
10002          XL=(Y(I) - KSLOC)/KSSCAL
10003          CALL GOMCDF(XL,SHAPE1,SHAPE2,IGOMDF,Y2(I))
10004 1540   CONTINUE
10005C
10006      ELSEIF(ICASPL.EQ.'HCAU')THEN
10007        DO1550I=1,N
10008          XL=(Y(I) - KSLOC)/KSSCAL
10009          CALL HFCCDF(XL,Y2(I))
10010 1550   CONTINUE
10011C
10012      ELSEIF(ICASPL.EQ.'HALO')THEN
10013        SHAPE1=-1.0
10014        DO1560I=1,N
10015          XL=(Y(I) - KSLOC)/KSSCAL
10016          CALL HFLCDF(XL,SHAPE1,Y2(I))
10017 1560   CONTINUE
10018C
10019      ELSEIF(ICASPL.EQ.'GHLO')THEN
10020        DO1570I=1,N
10021          XL=(Y(I) - KSLOC)/KSSCAL
10022          CALL HFLCDF(XL,SHAPE1,Y2(I))
10023 1570   CONTINUE
10024C
10025      ELSEIF(ICASPL.EQ.'GEV ')THEN
10026        DO1580I=1,N
10027          XL=(Y(I) - KSLOC)/KSSCAL
10028          CALL GEVCDF(XL,SHAPE1,MINMAX,Y2(I))
10029 1580   CONTINUE
10030C
10031      ELSEIF(ICASPL.EQ.'PAR2')THEN
10032        ZLOC=SHAPE2
10033        IF(ZLOC.GT.XMIN)ZLOC=XMIN
10034        DO1590I=1,N
10035          XL=(Y(I) - KSLOC)/KSSCAL
10036          CALL PA2CDF(XL,SHAPE1,ZLOC,Y2(I))
10037 1590   CONTINUE
10038C
10039      ELSEIF(ICASPL.EQ.'DWEI')THEN
10040        DO1600I=1,N
10041          XL=(Y(I) - KSLOC)/KSSCAL
10042          CALL DWECDF(XL,SHAPE1,Y2(I))
10043 1600   CONTINUE
10044C
10045      ELSEIF(ICASPL.EQ.'WCAU')THEN
10046        DO1610I=1,N
10047          XL=(Y(I) - KSLOC)/KSSCAL
10048          CALL WCACDF(XL,SHAPE1,Y2(I))
10049 1610   CONTINUE
10050C
10051      ELSEIF(ICASPL.EQ.'EWEI')THEN
10052        IARG1=1
10053        DO1620I=1,N
10054          XL=(Y(I) - KSLOC)/KSSCAL
10055          CALL EWECDF(XL,SHAPE1,SHAPE2,IARG1,Y2(I))
10056 1620   CONTINUE
10057C
10058      ELSEIF(ICASPL.EQ.'TEXP')THEN
10059        DO1630I=1,N
10060          XL=(Y(I) - KSLOC)/KSSCAL
10061          CALL TNECDF(XL,SHAPE1,SHAPE2,SHAPE3,Y2(I))
10062 1630   CONTINUE
10063C
10064      ELSEIF(ICASPL.EQ.'GLOG')THEN
10065        DO1640I=1,N
10066          XL=(Y(I) - KSLOC)/KSSCAL
10067          CALL GLOCDF(XL,SHAPE1,Y2(I))
10068 1640   CONTINUE
10069C
10070      ELSEIF(ICASPL.EQ.'PEXP')THEN
10071        DO1650I=1,N
10072          XL=(Y(I) - KSLOC)/KSSCAL
10073          CALL PEXCDF(DBLE(XL),DBLE(SHAPE1),DXOUT)
10074          Y2(I)=REAL(DXOUT)
10075 1650   CONTINUE
10076C
10077      ELSEIF(ICASPL.EQ.'DGAM')THEN
10078        DO1660I=1,N
10079          XL=(Y(I) - KSLOC)/KSSCAL
10080          CALL DGACDF(XL,SHAPE1,Y2(I))
10081 1660   CONTINUE
10082C
10083      ELSEIF(ICASPL.EQ.'MBKA')THEN
10084        DO1670I=1,N
10085          XL=(Y(I) - KSLOC)/KSSCAL
10086          CALL MIECDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT)
10087          Y2(I)=REAL(DXOUT)
10088 1670   CONTINUE
10089C
10090      ELSEIF(ICASPL.EQ.'FCAU')THEN
10091        DO1680I=1,N
10092          XL=(Y(I) - KSLOC)/KSSCAL
10093          CALL FCACDF(XL,SHAPE1,SHAPE2,Y2(I))
10094 1680   CONTINUE
10095C
10096      ELSEIF(ICASPL.EQ.'BBIN')THEN
10097        IF(IFLAGD.EQ.1)GOTO8000
10098        DO1690I=1,N
10099          XL=Y(I)
10100          CALL BBNCDF(XL,SHAPE1,SHAPE2,INT(SHAPE3+0.1),Y2(I))
10101 1690   CONTINUE
10102C
10103      ELSEIF(ICASPL.EQ.'BRAD')THEN
10104        DO1700I=1,N
10105          XL=(Y(I) - KSLOC)/KSSCAL
10106          CALL BRACDF(XL,SHAPE1,Y2(I))
10107 1700   CONTINUE
10108C
10109      ELSEIF(ICASPL.EQ.'GEXP')THEN
10110        DO1710I=1,N
10111          XL=(Y(I) - KSLOC)/KSSCAL
10112          CALL GEXCDF(XL,SHAPE1,SHAPE2,SHAPE3,Y2(I))
10113 1710   CONTINUE
10114C
10115      ELSEIF(ICASPL.EQ.'RECI')THEN
10116        DO1715I=1,N
10117          XL=(Y(I) - KSLOC)/KSSCAL
10118          CALL RECCDF(XL,SHAPE1,Y2(I))
10119 1715   CONTINUE
10120C
10121      ELSEIF(ICASPL.EQ.'NORX')THEN
10122        DO1720I=1,N
10123          XL=Y(I)
10124          CALL NMXCDF(XL,SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5,
10125     1                Y2(I))
10126 1720   CONTINUE
10127C
10128      ELSEIF(ICASPL.EQ.'IGAM')THEN
10129        DO1730I=1,N
10130          XL=(Y(I) - KSLOC)/KSSCAL
10131          CALL IGACDF(XL,SHAPE1,Y2(I))
10132 1730   CONTINUE
10133C
10134      ELSEIF(ICASPL.EQ.'GTLA')THEN
10135        DO1740I=1,N
10136          XL=(Y(I) - KSLOC)/KSSCAL
10137          CALL GLDCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT,
10138     1                IGLDDF,IWRITE)
10139          Y2(I)=REAL(DXOUT)
10140 1740   CONTINUE
10141C
10142      ELSEIF(ICASPL.EQ.'JOSB')THEN
10143        DO1750I=1,N
10144          XL=(Y(I) - ZLOC)/ZSCALE
10145          CALL JSBCDF(XL,SHAPE1,SHAPE2,Y2(I))
10146 1750   CONTINUE
10147C
10148      ELSEIF(ICASPL.EQ.'JOSU')THEN
10149        DO1760I=1,N
10150          XL=(Y(I) - KSLOC)/KSSCAL
10151          CALL JSUCDF(XL,SHAPE1,SHAPE2,Y2(I))
10152 1760   CONTINUE
10153C
10154      ELSEIF(ICASPL.EQ.'IWEI')THEN
10155        DO1770I=1,N
10156          XL=(Y(I) - KSLOC)/KSSCAL
10157          CALL IWECDF(XL,SHAPE1,Y2(I))
10158 1770   CONTINUE
10159C
10160      ELSEIF(ICASPL.EQ.'LDEX')THEN
10161        DO1780I=1,N
10162          XL=(Y(I) - KSLOC)/KSSCAL
10163          CALL LDECDF(XL,SHAPE1,Y2(I))
10164 1780   CONTINUE
10165C
10166      ELSEIF(ICASPL.EQ.'GEEX')THEN
10167        DO1790I=1,N
10168          XL=(Y(I) - KSLOC)/KSSCAL
10169          CALL GEECDF(XL,SHAPE1,Y2(I))
10170 1790   CONTINUE
10171C
10172      ELSEIF(ICASPL.EQ.'TSPO')THEN
10173        IF(A.EQ.CPUMIN .OR. B.EQ.CPUMAX)THEN
10174          ZLOWLM=0.0
10175          ZUPPLM=1.0
10176        ELSE
10177          ZLOWLM=MIN(A,B)
10178          ZUPPLM=MAX(A,B)
10179        ENDIF
10180        IF(ZLOWLM.GT.XMIN)ZLOWLM=XMIN
10181        IF(ZUPPLM.LT.XMAX)ZUPPLM=XMAX
10182        IF(SHAPE1.LT.ZLOWLM .OR. SHAPE1.GT.ZUPPLM)THEN
10183          WRITE(ICOUT,999)
10184          CALL DPWRST('XXX','BUG ')
10185          WRITE(ICOUT,31)
10186          CALL DPWRST('XXX','BUG ')
10187          WRITE(ICOUT,1943)
10188 1943     FORMAT('       FOR THE TWO-SIDED POWER DISTRIBUTION, THE')
10189          CALL DPWRST('XXX','BUG ')
10190          WRITE(ICOUT,1944)
10191 1944     FORMAT('       VALUE OF THE THETA SHAPE PARAMETER IS ',
10192     1           'OUTSIDE')
10193          CALL DPWRST('XXX','BUG ')
10194          WRITE(ICOUT,1945)
10195 1945     FORMAT('       INTERVAL OF THE LOWER AND UPPER LIMIT ',
10196     1           'PARAMETERS.')
10197          CALL DPWRST('XXX','BUG ')
10198          WRITE(ICOUT,1946)SHAPE1
10199 1946     FORMAT('       THE VALUE OF THE THETA SHAPE PARAMETER = ',
10200     1           G15.7)
10201          CALL DPWRST('XXX','BUG ')
10202          WRITE(ICOUT,1947)ZLOWLM
10203 1947     FORMAT('       THE VALUE OF THE LOWER LIMIT PARAMETER = ',
10204     1           G15.7)
10205          CALL DPWRST('XXX','BUG ')
10206          WRITE(ICOUT,1948)ZUPPLM
10207 1948     FORMAT('       THE VALUE OF THE LOWER LIMIT PARAMETER = ',
10208     1           G15.7)
10209          CALL DPWRST('XXX','BUG ')
10210          IERROR='YES'
10211          GOTO9000
10212        ENDIF
10213C
10214        DO1800I=1,N
10215          XL=Y(I)
10216          CALL TSPCDF(XL,SHAPE1,SHAPE2,A,B,Y2(I))
10217 1800   CONTINUE
10218C
10219      ELSEIF(ICASPL.EQ.'BWEI')THEN
10220        DO1810I=1,N
10221          XL=(Y(I) - KSLOC)/KSSCAL
10222          CALL BWECDF(XL,SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5,
10223     1                Y2(I),DXOUT)
10224 1810   CONTINUE
10225C
10226      ELSEIF(ICASPL.EQ.'GHPP')THEN
10227        DO1820I=1,N
10228          XL=(Y(I) - KSLOC)/KSSCAL
10229          CALL GHCDF(XL,SHAPE1,SHAPE2,Y2(I))
10230 1820   CONTINUE
10231C
10232      ELSEIF(ICASPL.EQ.'GPP')THEN
10233        HTEMP=0.0
10234        DO1821I=1,N
10235          XL=(Y(I) - KSLOC)/KSSCAL
10236          CALL GHCDF(XL,SHAPE1,HTEMP,Y2(I))
10237 1821   CONTINUE
10238C
10239      ELSEIF(ICASPL.EQ.'HPP')THEN
10240        GTEMP=0.0
10241        DO1823I=1,N
10242          XL=(Y(I) - KSLOC)/KSSCAL
10243          CALL GHCDF(XL,GTEMP,SHAPE1,Y2(I))
10244 1823   CONTINUE
10245C
10246      ELSEIF(ICASPL.EQ.'LAND')THEN
10247        DO1830I=1,N
10248          XL=(Y(I) - KSLOC)/KSSCAL
10249          DXOUT=LANCDF(DBLE(XL))
10250          Y2(I)=REAL(DXOUT)
10251 1830   CONTINUE
10252C
10253      ELSEIF(ICASPL.EQ.'ERRO')THEN
10254        DO1840I=1,N
10255          XL=(Y(I) - KSLOC)/KSSCAL
10256          CALL ERRCDF(XL,SHAPE1,Y2(I))
10257 1840   CONTINUE
10258C
10259      ELSEIF(ICASPL.EQ.'TRAP')THEN
10260        DO1850I=1,N
10261          XL=(Y(I) - KSLOC)/KSSCAL
10262          CALL TRACDF(XL,SHAPE1,SHAPE2,SHAPE3,SHAPE4,Y2(I))
10263 1850   CONTINUE
10264C
10265      ELSEIF(ICASPL.EQ.'GTRA')THEN
10266        DO1860I=1,N
10267          XL=(Y(I) - KSLOC)/KSSCAL
10268          CALL GTRCDF(XL,SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5,
10269     1                SHAPE6,SHAPE7,Y2(I))
10270 1860   CONTINUE
10271C
10272      ELSEIF(ICASPL.EQ.'FT  ')THEN
10273        DO1870I=1,N
10274          XL=(Y(I) - KSLOC)/KSSCAL
10275          CALL FTCDF(XL,INT(SHAPE1+0.1),Y2(I))
10276 1870   CONTINUE
10277C
10278      ELSEIF(ICASPL.EQ.'SLAS')THEN
10279        DO1880I=1,N
10280          XL=(Y(I) - KSLOC)/KSSCAL
10281          CALL SLACDF(XL,Y2(I))
10282 1880   CONTINUE
10283C
10284      ELSEIF(ICASPL.EQ.'SNOR')THEN
10285        DO1890I=1,N
10286          XL=(Y(I) - KSLOC)/KSSCAL
10287          CALL SNCDF(XL,SHAPE1,ISKNDF,Y2(I))
10288 1890   CONTINUE
10289C
10290      ELSEIF(ICASPL.EQ.'TSKE')THEN
10291        DO1900I=1,N
10292          XL=(Y(I) - KSLOC)/KSSCAL
10293          CALL STCDF(XL,INT(SHAPE1+0.1),SHAPE2,Y2(I))
10294 1900   CONTINUE
10295C
10296      ELSEIF(ICASPL.EQ.'IBET')THEN
10297        DO1910I=1,N
10298          XL=(Y(I) - KSLOC)/KSSCAL
10299          CALL IBCDF(XL,SHAPE1,SHAPE2,Y2(I))
10300 1910   CONTINUE
10301C
10302      ELSEIF(ICASPL.EQ.'GOMM')THEN
10303        IF(IMAKDF.EQ.'DLMF')THEN
10304          DO1930I=1,N
10305            XL=(Y(I) - KSLOC)/KSSCAL
10306            CALL MAKCDF(XL,SHAPE1,SHAPE2,SHAPE3,Y2(I))
10307 1930     CONTINUE
10308        ELSEIF(IMAKDF.EQ.'MEEK')THEN
10309          XI=SHAPE1/SHAPE3
10310          THETA=SHAPE2/SHAPE1
10311          ALAMB=SHAPE3
10312          DO1935I=1,N
10313            XL=(Y(I) - KSLOC)/KSSCAL
10314            CALL MAKCDF(XL,XI,ALAMBA,THETA,Y2(I))
10315 1935     CONTINUE
10316        ELSEIF(IMAKDF.EQ.'REPA')THEN
10317          DO1938I=1,N
10318            XL=(Y(I) - KSLOC)/KSSCAL
10319            CALL MA2CDF(XL,SHAPE1,SHAPE2,Y2(I))
10320 1938     CONTINUE
10321        ENDIF
10322C
10323      ELSEIF(ICASPL.EQ.'LSNO')THEN
10324        DO1940I=1,N
10325          XL=(Y(I) - KSLOC)/KSSCAL
10326          CALL LSNCDF(XL,SHAPE1,SHAPE2,Y2(I))
10327 1940   CONTINUE
10328C
10329      ELSEIF(ICASPL.EQ.'LSKT')THEN
10330        DO1950I=1,N
10331          XL=(Y(I) - KSLOC)/KSSCAL
10332          CALL LSTCDF(XL,INT(SHAPE1+0.1),SHAPE2,SHAPE3,Y2(I))
10333 1950   CONTINUE
10334C
10335      ELSEIF(ICASPL.EQ.'POLY')THEN
10336        DO1960I=1,N
10337          XL=(Y(I) - KSLOC)/KSSCAL
10338          CALL POLCDF(XL,SHAPE1,SHAPE2,INT(SHAPE3+0.1),Y2(I))
10339 1960   CONTINUE
10340C
10341      ELSEIF(ICASPL.EQ.'HERM')THEN
10342        IF(IFLAGD.EQ.1)GOTO8000
10343        DO1970I=1,N
10344          XL=(Y(I) - KSLOC)/KSSCAL
10345          CALL HERCDF(XL,SHAPE1,SHAPE2,Y2(I))
10346 1970   CONTINUE
10347C
10348      ELSEIF(ICASPL.EQ.'SDEX')THEN
10349        DO1980I=1,N
10350          XL=(Y(I) - KSLOC)/KSSCAL
10351          CALL SDECDF(XL,SHAPE1,Y2(I))
10352 1980   CONTINUE
10353C
10354      ELSEIF(ICASPL.EQ.'ADEX')THEN
10355        DO1990I=1,N
10356          XL=(Y(I) - KSLOC)/KSSCAL
10357          CALL ADECDF(XL,SHAPE1,IADEDF,Y2(I))
10358 1990   CONTINUE
10359C
10360      ELSEIF(ICASPL.EQ.'MAXW' .OR. ICASPL.EQ.'1MAX')THEN
10361        AVAL1=KSLOC
10362        IF(ICASPL.EQ.'1MAX')AVAL1=0.0
10363        DO2000I=1,N
10364          XL=(Y(I) - KSLOC)/KSSCAL
10365          CALL MAXCDF(XL,Y2(I))
10366 2000   CONTINUE
10367C
10368      ELSEIF(ICASPL.EQ.'RAYL')THEN
10369        DO2010I=1,N
10370          XL=(Y(I) - KSLOC)/KSSCAL
10371          CALL RAYCDF(XL,Y2(I))
10372 2010   CONTINUE
10373C
10374      ELSEIF(ICASPL.EQ.'GIGA')THEN
10375        IF(IGIGDF.EQ.'2PAR')THEN
10376          DO2020I=1,N
10377            XL=(Y(I) - KSLOC)/KSSCAL
10378            CALL GI2CDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT)
10379            Y2(I)=REAL(DXOUT)
10380 2020     CONTINUE
10381        ELSE
10382          DO2030I=1,N
10383            XL=(Y(I) - KSLOC)/KSSCAL
10384            CALL GIGCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),
10385     1                  DBLE(SHAPE3),DXOUT)
10386            Y2(I)=REAL(DXOUT)
10387 2030     CONTINUE
10388        ENDIF
10389C
10390      ELSEIF(ICASPL.EQ.'GALP')THEN
10391        DO2040I=1,N
10392          XL=(Y(I) - KSLOC)/KSSCAL
10393          CALL GALCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),IADEDF,DXOUT)
10394          Y2(I)=REAL(DXOUT)
10395 2040   CONTINUE
10396C
10397      ELSEIF(ICASPL.EQ.'MCLE')THEN
10398        DO2050I=1,N
10399          XL=(Y(I) - KSLOC)/KSSCAL
10400          CALL MCLCDF(DBLE(XL),DBLE(SHAPE1),DXOUT)
10401          Y2(I)=REAL(DXOUT)
10402 2050   CONTINUE
10403C
10404      ELSEIF(ICASPL.EQ.'BEIP')THEN
10405        DO2060I=1,N
10406          XL=(Y(I) - KSLOC)/KSSCAL
10407          CALL BEICDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DBLE(SHAPE3),
10408     1                IBEIDF,DXOUT)
10409          Y2(I)=REAL(DXOUT)
10410 2060   CONTINUE
10411C
10412      ELSEIF(ICASPL.EQ.'BEIK')THEN
10413        DO2070I=1,N
10414          XL=(Y(I) - KSLOC)/KSSCAL
10415CCCCC     CALL BEKCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DBLE(SHAPE3),
10416CCCCC1                IBEIDF,DXOUT)
10417CCCCC     Y2(I)=REAL(DXOUT)
10418          Y2(I)=0.0
10419 2070   CONTINUE
10420C
10421      ELSEIF(ICASPL.EQ.'GMCL')THEN
10422        DO2080I=1,N
10423          XL=(Y(I) - KSLOC)/KSSCAL
10424          CALL GMCCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT)
10425          Y2(I)=REAL(DXOUT)
10426 2080   CONTINUE
10427C
10428      ELSEIF(ICASPL.EQ.'G5LO')THEN
10429        XPAR(1)=DBLE(KSLOC)
10430        XPAR(2)=DBLE(KSSCAL)
10431        XPAR(3)=DBLE(SHAPE1)
10432        DO2090I=1,N
10433          XL=Y(I)
10434          DXOUT=CDFGLO(DBLE(XL),XPAR)
10435          Y2(I)=REAL(DXOUT)
10436 2090   CONTINUE
10437C
10438      ELSEIF(ICASPL.EQ.'WAKE')THEN
10439        XPAR(1)=DBLE(KSLOC)
10440        XPAR(2)=DBLE(KSSCAL)
10441        XPAR(3)=DBLE(SHAPE1)
10442        XPAR(4)=DBLE(SHAPE2)
10443        XPAR(5)=DBLE(SHAPE3)
10444        DO2100I=1,N
10445          XL=Y(I)
10446          DXOUT=CDFWAK(DBLE(XL),XPAR)
10447          Y2(I)=REAL(DXOUT)
10448 2100   CONTINUE
10449C
10450      ELSEIF(ICASPL.EQ.'BNOR')THEN
10451        DO2110I=1,N
10452          XL=(Y(I) - KSLOC)/KSSCAL
10453          CALL BNOCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT)
10454          Y2(I)=REAL(DXOUT)
10455 2110   CONTINUE
10456C
10457      ELSEIF(ICASPL.EQ.'G2LO')THEN
10458        DO2120I=1,N
10459          XL=(Y(I) - KSLOC)/KSSCAL
10460          CALL GL2CDF(DBLE(XL),DBLE(SHAPE1),DXOUT)
10461          Y2(I)=REAL(DXOUT)
10462 2120   CONTINUE
10463C
10464      ELSEIF(ICASPL.EQ.'G3LO')THEN
10465        DO2130I=1,N
10466          XL=(Y(I) - KSLOC)/KSSCAL
10467          CALL GL3CDF(DBLE(XL),DBLE(SHAPE1),DXOUT)
10468          Y2(I)=REAL(DXOUT)
10469 2130   CONTINUE
10470C
10471      ELSEIF(ICASPL.EQ.'G4LO')THEN
10472        DO2140I=1,N
10473          XL=(Y(I) - KSLOC)/KSSCAL
10474          CALL GL4CDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT)
10475          Y2(I)=REAL(DXOUT)
10476 2140   CONTINUE
10477C
10478      ELSEIF(ICASPL.EQ.'ALDE')THEN
10479        DO2150I=1,N
10480          XL=(Y(I) - KSLOC)/KSSCAL
10481          CALL ALDCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT)
10482          Y2(I)=REAL(DXOUT)
10483 2150   CONTINUE
10484C
10485      ELSEIF(ICASPL.EQ.'BGEO')THEN
10486        IF(IFLAGD.EQ.1)GOTO8000
10487        IF(IBGEDF.EQ.'UNSH')THEN
10488          DO2160I=1,N
10489            XL=Y(I)
10490            CALL BGECDF(XL,SHAPE1,SHAPE2,Y2(I))
10491 2160     CONTINUE
10492        ELSE
10493          DO2165I=1,N
10494            XL=Y(I)
10495            CALL BG2CDF(XL,SHAPE1,SHAPE2,Y2(I))
10496 2165     CONTINUE
10497        ENDIF
10498C
10499      ELSEIF(ICASPL.EQ.'ZETA')THEN
10500        IF(IFLAGD.EQ.1)GOTO8000
10501        DO2170I=1,N
10502          XL=Y(I)
10503          CALL ZETCDF(XL,SHAPE1,Y2(I))
10504 2170   CONTINUE
10505C
10506      ELSEIF(ICASPL.EQ.'ZIPF')THEN
10507        IF(IFLAGD.EQ.1)GOTO8000
10508        DO2180I=1,N
10509          XL=Y(I)
10510          CALL ZIPCDF(XL,SHAPE1,INT(SHAPE2+0.1),Y2(I))
10511 2180   CONTINUE
10512C
10513      ELSEIF(ICASPL.EQ.'BTAN')THEN
10514        IF(IFLAGD.EQ.1)GOTO8000
10515        DO2190I=1,N
10516          XL=Y(I)
10517          CALL BTACDF(XL,SHAPE1,SHAPE2,Y2(I))
10518 2190   CONTINUE
10519C
10520      ELSEIF(ICASPL.EQ.'BNBI')THEN
10521        IF(IFLAGD.EQ.1)GOTO8000
10522        DO2200I=1,N
10523          XL=Y(I)
10524          CALL GWACDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),
10525     1                DBLE(SHAPE3),DXOUT)
10526          Y2(I)=REAL(DXOUT)
10527 2200   CONTINUE
10528C
10529      ELSEIF(ICASPL.EQ.'LPOI')THEN
10530        IF(IFLAGD.EQ.1)GOTO8000
10531        DO2210I=1,N
10532          XL=Y(I)
10533          CALL LPOCDF(XL,SHAPE1,SHAPE2,Y2(I))
10534 2210   CONTINUE
10535C
10536      ELSEIF(ICASPL.EQ.'LICT')THEN
10537        IF(IFLAGD.EQ.1)GOTO8000
10538        DO2220I=1,N
10539          XL=Y(I)
10540          CALL LCTCDF(XL,INT(SHAPE1+0.1),Y2(I))
10541 2220   CONTINUE
10542C
10543      ELSEIF(ICASPL.EQ.'MATC')THEN
10544        IF(IFLAGD.EQ.1)GOTO8000
10545        DO2230I=1,N
10546          XL=Y(I)
10547          CALL MATCDF(XL,INT(SHAPE1+0.1),Y2(I))
10548 2230   CONTINUE
10549C
10550      ELSEIF(ICASPL.EQ.'LBET')THEN
10551        YLOWLM=SHAPE3
10552        YUPPLM=SHAPE4
10553        EPS=(XMAX-XMIN)*0.01
10554        IF(YLOWLM.GT.XMIN)YLOWLM=XMIN-EPS
10555        IF(YUPPLM.LT.XMAX)YUPPLM=XMAX+EPS
10556        DO2240I=1,N
10557          XL=(Y(I) - KSLOC)/KSSCAL
10558          CALL LBECDF(XL,SHAPE1,SHAPE2,YLOWLM,YUPPLM,Y2(I))
10559 2240   CONTINUE
10560C
10561      ELSEIF(ICASPL.EQ.'AEPP')THEN
10562        IF(IFLAGD.EQ.1)GOTO8000
10563        DO2250I=1,N
10564          XL=Y(I)
10565          CALL PAPCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT)
10566          Y2(I)=REAL(DXOUT)
10567 2250   CONTINUE
10568C
10569      ELSEIF(ICASPL.EQ.'GLOS')THEN
10570        IF(IFLAGD.EQ.1)GOTO8000
10571        DO2270I=1,N
10572          XL=Y(I)
10573          CALL GLSCDF(XL,SHAPE1,SHAPE2,Y2(I))
10574 2270   CONTINUE
10575C
10576      ELSEIF(ICASPL.EQ.'GNBI')THEN
10577        IF(IFLAGD.EQ.1)GOTO8000
10578        DO2280I=1,N
10579          XL=Y(I)
10580          CALL GNBCDF(XL,SHAPE1,SHAPE2,SHAPE3,Y2(I))
10581 2280   CONTINUE
10582C
10583      ELSEIF(ICASPL.EQ.'GEET')THEN
10584        IF(IFLAGD.EQ.1)GOTO8000
10585        DO2290I=1,N
10586          XL=Y(I)
10587          CALL GETCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),
10588     1                IGETDF,DXOUT)
10589          Y2(I)=REAL(DXOUT)
10590 2290   CONTINUE
10591C
10592      ELSEIF(ICASPL.EQ.'QBIN')THEN
10593        IF(IFLAGD.EQ.1)GOTO8000
10594        DO2300I=1,N
10595          XL=Y(I)
10596          CALL QBICDF(XL,SHAPE1,SHAPE2,SHAPE3,Y2(I))
10597 2300   CONTINUE
10598C
10599      ELSEIF(ICASPL.EQ.'CONS')THEN
10600        IF(IFLAGD.EQ.1)GOTO8000
10601        DO2310I=1,N
10602          XL=Y(I)
10603          CALL CONCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),
10604     1                ICONDF,DXOUT)
10605          Y2(I)=REAL(DXOUT)
10606 2310   CONTINUE
10607C
10608      ELSEIF(ICASPL.EQ.'LKAT')THEN
10609        IF(IFLAGD.EQ.1)GOTO8000
10610        DO2320I=1,N
10611          XL=Y(I)
10612          CALL LKCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),
10613     1                DBLE(SHAPE3),DXOUT)
10614          Y2(I)=REAL(DXOUT)
10615 2320   CONTINUE
10616C
10617      ELSEIF(ICASPL.EQ.'KATZ')THEN
10618        IF(IFLAGD.EQ.1)GOTO8000
10619        DO2330I=1,N
10620          XL=Y(I)
10621          CALL KATCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),IKATDF,DXOUT)
10622          Y2(I)=REAL(DXOUT)
10623 2330   CONTINUE
10624C
10625      ELSEIF(ICASPL.EQ.'DISW')THEN
10626        IF(IFLAGD.EQ.1)GOTO8000
10627        DO2340I=1,N
10628          XL=Y(I)
10629          CALL DIWCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT)
10630          Y2(I)=REAL(DXOUT)
10631 2340   CONTINUE
10632C
10633      ELSEIF(ICASPL.EQ.'GLGP')THEN
10634        IF(IFLAGD.EQ.1)GOTO8000
10635        DO2350I=1,N
10636          XL=Y(I)
10637          CALL GLGCDF(XL,SHAPE1,INT(SHAPE2+0.1),SHAPE3,Y2(I))
10638 2350   CONTINUE
10639C
10640      ELSEIF(ICASPL.EQ.'TGNB')THEN
10641        IF(IFLAGD.EQ.1)GOTO8000
10642        DO2360I=1,N
10643          XL=Y(I)
10644          CALL GNTCDF(XL,SHAPE1,SHAPE2,SHAPE3,INT(SHAPE4+0.1),Y2(I))
10645 2360   CONTINUE
10646C
10647      ELSEIF(ICASPL.EQ.'TOPL')THEN
10648        DO2370I=1,N
10649          XL=(Y(I) - KSLOC)/KSSCAL
10650          CALL TOPCDF(DBLE(XL),DBLE(SHAPE1),DXOUT)
10651          Y2(I)=REAL(DXOUT)
10652 2370   CONTINUE
10653C
10654      ELSEIF(ICASPL.EQ.'GTOL')THEN
10655        DO2380I=1,N
10656          XL=Y(I)
10657          CALL GTLCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),
10658     1                DBLE(A),DBLE(B),DXOUT)
10659          Y2(I)=REAL(DXOUT)
10660 2380   CONTINUE
10661C
10662      ELSEIF(ICASPL.EQ.'RGTL')THEN
10663        DO2390I=1,N
10664          XL=Y(I)
10665          CALL RGTCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),
10666     1                DBLE(A),DBLE(B),DXOUT)
10667          Y2(I)=REAL(DXOUT)
10668 2390   CONTINUE
10669C
10670      ELSEIF(ICASPL.EQ.'SLOP')THEN
10671        DO2400I=1,N
10672          XL=(Y(I) - ZLOC)/ZSCALE
10673          CALL SLOCDF(XL,SHAPE1,Y2(I))
10674 2400   CONTINUE
10675C
10676      ELSEIF(ICASPL.EQ.'OGIV')THEN
10677        DO2410I=1,N
10678          XL=(Y(I) - ZLOC)/ZSCALE
10679          CALL OGICDF(DBLE(XL),DBLE(SHAPE1),DXOUT)
10680          Y2(I)=REAL(DXOUT)
10681 2410   CONTINUE
10682C
10683      ELSEIF(ICASPL.EQ.'TSSL')THEN
10684        DO2420I=1,N
10685          XL=Y(I)
10686          CALL TSSCDF(XL,SHAPE1,SHAPE2,
10687     1                A,B,Y2(I))
10688 2420   CONTINUE
10689C
10690      ELSEIF(ICASPL.EQ.'TSOG')THEN
10691        DO2430I=1,N
10692          XL=Y(I)
10693          CALL TSOCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),
10694     1                DBLE(A),DBLE(B),DXOUT)
10695          Y2(I)=REAL(DXOUT)
10696 2430   CONTINUE
10697C
10698      ELSEIF(ICASPL.EQ.'BUR2')THEN
10699        DO2450I=1,N
10700          XL=(Y(I) - KSLOC)/KSSCAL
10701          CALL BU2CDF(DBLE(XL),DBLE(SHAPE1),DXOUT)
10702          Y2(I)=REAL(DXOUT)
10703 2450   CONTINUE
10704C
10705      ELSEIF(ICASPL.EQ.'BUR3')THEN
10706        DO2460I=1,N
10707          XL=(Y(I) - KSLOC)/KSSCAL
10708          CALL BU3CDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT)
10709          Y2(I)=REAL(DXOUT)
10710 2460   CONTINUE
10711C
10712      ELSEIF(ICASPL.EQ.'BUR4')THEN
10713        DO2470I=1,N
10714          XL=(Y(I) - KSLOC)/KSSCAL
10715          CALL BU4CDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT)
10716          Y2(I)=REAL(DXOUT)
10717 2470   CONTINUE
10718C
10719      ELSEIF(ICASPL.EQ.'BUR5')THEN
10720        DO2480I=1,N
10721          XL=(Y(I) - KSLOC)/KSSCAL
10722          CALL BU5CDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT)
10723          Y2(I)=REAL(DXOUT)
10724 2480   CONTINUE
10725C
10726      ELSEIF(ICASPL.EQ.'BUR6')THEN
10727        DO2490I=1,N
10728          XL=(Y(I) - KSLOC)/KSSCAL
10729          CALL BU6CDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT)
10730          Y2(I)=REAL(DXOUT)
10731 2490   CONTINUE
10732C
10733      ELSEIF(ICASPL.EQ.'BUR7')THEN
10734        DO2500I=1,N
10735          XL=(Y(I) - KSLOC)/KSSCAL
10736          CALL BU7CDF(DBLE(XL),DBLE(SHAPE1),DXOUT)
10737          Y2(I)=REAL(DXOUT)
10738 2500   CONTINUE
10739C
10740      ELSEIF(ICASPL.EQ.'BUR8')THEN
10741        DO2510I=1,N
10742          XL=(Y(I) - KSLOC)/KSSCAL
10743          CALL BU8CDF(DBLE(XL),DBLE(SHAPE1),DXOUT)
10744          Y2(I)=REAL(DXOUT)
10745 2510   CONTINUE
10746C
10747      ELSEIF(ICASPL.EQ.'BUR9')THEN
10748        DO2520I=1,N
10749          XL=(Y(I) - KSLOC)/KSSCAL
10750          CALL BU9CDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT)
10751          Y2(I)=REAL(DXOUT)
10752 2520   CONTINUE
10753C
10754      ELSEIF(ICASPL.EQ.'BU10' .OR. ICASPL.EQ.'B10' .OR.
10755     1       ICASPL.EQ.'3B10')THEN
10756        DO2530I=1,N
10757          XL=(Y(I) - KSLOC)/KSSCAL
10758          CALL B10CDF(DBLE(XL),DBLE(SHAPE1),DXOUT)
10759          Y2(I)=REAL(DXOUT)
10760 2530   CONTINUE
10761C
10762      ELSEIF(ICASPL.EQ.'BU11')THEN
10763        DO2540I=1,N
10764          XL=(Y(I) - KSLOC)/KSSCAL
10765          CALL B11CDF(DBLE(XL),DBLE(SHAPE1),DXOUT)
10766          Y2(I)=REAL(DXOUT)
10767 2540   CONTINUE
10768C
10769      ELSEIF(ICASPL.EQ.'BU12')THEN
10770        DO2550I=1,N
10771          XL=(Y(I) - KSLOC)/KSSCAL
10772          CALL B12CDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT)
10773          Y2(I)=REAL(DXOUT)
10774 2550   CONTINUE
10775C
10776      ELSEIF(ICASPL.EQ.'DPUN')THEN
10777        DO2560I=1,N
10778          XL=(Y(I) - KSLOC)/KSSCAL
10779          CALL DPUCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),
10780     1                DBLE(SHAPE3),DBLE(SHAPE4),DXOUT)
10781          Y2(I)=REAL(DXOUT)
10782 2560   CONTINUE
10783C
10784      ELSEIF(ICASPL.EQ.'KUMA')THEN
10785        DO2570I=1,N
10786          XL=(Y(I) - ZLOC)/ZSCALE
10787          CALL KUMCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT)
10788          Y2(I)=REAL(DXOUT)
10789 2570   CONTINUE
10790C
10791      ELSEIF(ICASPL.EQ.'RPOW')THEN
10792        DO2580I=1,N
10793          XL=(Y(I) - ZLOC)/ZSCALE
10794          CALL RPOCDF(XL,SHAPE1,Y2(I))
10795 2580   CONTINUE
10796C
10797      ELSEIF(ICASPL.EQ.'UTSP')THEN
10798        DO2590I=1,N
10799          XL=Y(I)
10800          CALL UTSCDF(XL,SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5,
10801     1                SHAPE6,Y2(I))
10802 2590   CONTINUE
10803C
10804      ELSEIF(ICASPL.EQ.'MUTH')THEN
10805        DO2600I=1,N
10806          XL=(Y(I) - KSLOC)/KSSCAL
10807          CALL MUTCDF(DBLE(XL),DBLE(SHAPE1),DXOUT)
10808          Y2(I)=REAL(DXOUT)
10809 2600   CONTINUE
10810C
10811      ELSEIF(ICASPL.EQ.'LEXP')THEN
10812        DO2610I=1,N
10813          XL=(Y(I) - KSLOC)/KSSCAL
10814          CALL LEXCDF(DBLE(XL),DBLE(SHAPE1),DXOUT)
10815          Y2(I)=REAL(DXOUT)
10816 2610   CONTINUE
10817C
10818      ELSEIF(ICASPL.EQ.'TPAR')THEN
10819        DO2620I=1,N
10820          XL=(Y(I) - KSLOC)/KSSCAL
10821          CALL TNPCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),
10822     1                DBLE(SHAPE3),DXOUT)
10823          Y2(I)=REAL(DXOUT)
10824 2620   CONTINUE
10825C
10826      ELSEIF(ICASPL.EQ.'BFRA')THEN
10827        DO2630I=1,N
10828          XL=(Y(I) - KSLOC)/KSSCAL
10829          CALL BFRCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),
10830     1                DBLE(SHAPE3),DXOUT)
10831          Y2(I)=REAL(DXOUT)
10832 2630   CONTINUE
10833C
10834      ELSEIF(ICASPL.EQ.'L3EX')THEN
10835        DO2640I=1,N
10836          XL=(Y(I) - KSLOC)/KSSCAL
10837          CALL LE3CDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),
10838     1                DBLE(SHAPE3),DXOUT)
10839          Y2(I)=REAL(DXOUT)
10840 2640   CONTINUE
10841C
10842      ELSEIF(ICASPL.EQ.'KAPP')THEN
10843        DO2650I=1,N
10844          XL=(Y(I) - KSLOC)/KSSCAL
10845          CALL KAPCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),
10846     1                DBLE(KSLOC),DBLE(KSSCAL),DXOUT)
10847          Y2(I)=REAL(DXOUT)
10848 2650   CONTINUE
10849C
10850      ELSEIF(ICASPL.EQ.'PEA3')THEN
10851        DO2660I=1,N
10852          XL=(Y(I) - KSLOC)/KSSCAL
10853          CALL PE3CDF(DBLE(XL),DBLE(SHAPE1),
10854     1                DBLE(KSLOC),DBLE(KSSCAL),DXOUT)
10855          Y2(I)=REAL(DXOUT)
10856 2660   CONTINUE
10857C
10858      ELSEIF(ICASPL.EQ.'EEWE')THEN
10859        DO2670I=1,N
10860          XL=Y(I)
10861          CALL EEWCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DBLE(SHAPE3),
10862     1                DBLE(SHAPE4),DBLE(SHAPE5),DXOUT)
10863          Y2(I)=REAL(DXOUT)
10864 2670   CONTINUE
10865C
10866      ELSEIF(ICASPL.EQ.'BFWE')THEN
10867        DO2680I=1,N
10868          XL=(Y(I) - KSLOC)/KSSCAL
10869          CALL BFWCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT)
10870          Y2(I)=REAL(DXOUT)
10871 2680   CONTINUE
10872      ELSE
10873        WRITE(ICOUT,999)
10874        CALL DPWRST('XXX','BUG ')
10875        WRITE(ICOUT,31)
10876        CALL DPWRST('XXX','BUG ')
10877        WRITE(ICOUT,8011)ICASPL
10878 8011   FORMAT('      UNKNOWN DISTRIBUTION -- ',A40)
10879        CALL DPWRST('XXX','BUG ')
10880        IERROR='YES'
10881        GOTO9000
10882      ENDIF
10883C
10884      GOTO9000
10885C
10886C     SET AN ERROR FLAG TO INDICATE A DISCRETE DISTRIBUTION
10887C     IS NOT TO BE PROCESSED.
10888C
10889 8000 CONTINUE
10890      IFLAGD=99
10891      GOTO9000
10892C
10893C               *****************
10894C               **  STEP 90--  **
10895C               **  EXIT       **
10896C               *****************
10897C
10898 9000 CONTINUE
10899      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CDF1')THEN
10900        WRITE(ICOUT,999)
10901        CALL DPWRST('XXX','BUG ')
10902        WRITE(ICOUT,9011)
10903 9011   FORMAT('***** AT THE END       OF DPCDF1--')
10904        CALL DPWRST('XXX','BUG ')
10905        WRITE(ICOUT,9012)ICASPL,N,MINMAX,IERROR
10906 9012   FORMAT('ICASPL,N,MINMAX,IERROR = ',A4,2X,2I8,2X,A4)
10907        CALL DPWRST('XXX','BUG ')
10908        DO9020I=1,N
10909          WRITE(ICOUT,9021)I,Y(I),Y2(I)
10910 9021     FORMAT('I,Y(I),Y2(I), = ',I8,2G15.7)
10911          CALL DPWRST('XXX','BUG ')
10912 9020   CONTINUE
10913      ENDIF
10914C
10915      RETURN
10916      END
10917      SUBROUTINE DPCHAL(ICHAR2,ICHARN,IBUGXX,IFOUND)
10918C
10919C     PURPOSE--CONVERT AN ALPHABETIC CHARACTER
10920C              (A TO Z) INTO A NUMERIC VALUE
10921C              (1 TO 26).
10922C     INPUT  ARGUMENTS--ICHAR2 (A HOLLERITH VARIABLE
10923C                              CONTAINING THE HOLLERITH
10924C                              CHARACTER(S) OF INTEREST.
10925C     OUTPUT ARGUMENTS--ICHARN (AN INTEGER VARIABLE
10926C                              CONTAINING THE NUMERIC
10927C                              DESIGNATION FOR THE
10928C                              ALPHABETIC CHARACTER.
10929C     WRITTEN BY--JAMES J. FILLIBEN
10930C                 STATISTICAL ENGINEERING DIVISION
10931C                 INFORMATION TECHNOLOGY LABORATORY
10932C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
10933C                 GAITHERSBURG, MD 20899-8980
10934C                 PHONE--301-975-2899
10935C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
10936C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
10937C     LANGUAGE--ANSI FORTRAN (1977)
10938C     VERSION NUMBER--82/7
10939C     ORIGINAL VERSION--MARCH     1981.
10940C     UPDATED         --NOVEMBER  1981.
10941C     UPDATED         --MAY       1982.
10942C
10943C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
10944C
10945      CHARACTER*4 ICHAR2
10946      CHARACTER*4 IBUGXX
10947      CHARACTER*4 IFOUND
10948C
10949      CHARACTER*1 ICH1
10950      CHARACTER*1 ICH2
10951C
10952C-----COMMON----------------------------------------------------------
10953C
10954      INCLUDE 'DPCOBE.INC'
10955C
10956C-----COMMON VARIABLES (GENERAL)--------------------------------------
10957C
10958      INCLUDE 'DPCOP2.INC'
10959C
10960C-----START POINT-----------------------------------------------------
10961C
10962      IFOUND='NO'
10963      ICH1='-'
10964      ICH2='-'
10965C
10966      ICH1N=(-999)
10967      ICH2N=(-999)
10968C
10969      IF(IBUGXX.EQ.'ON' .OR. ISUBG4.EQ.'CHAL')THEN
10970        WRITE(ICOUT,999)
10971  999   FORMAT(1X)
10972        CALL DPWRST('XXX','BUG ')
10973        WRITE(ICOUT,51)
10974   51   FORMAT('***** AT THE BEGINNING OF DPCHAL--')
10975        CALL DPWRST('XXX','BUG ')
10976        WRITE(ICOUT,59)IBUGXX,IBUGG4,ISUBG4,ICHAR2
10977   59   FORMAT('IBUGXX,IBUGXX,ISUBG4,ICHAR2 = ',2(A4,2X),A4)
10978        CALL DPWRST('XXX','BUG ')
10979      ENDIF
10980C
10981C               **********************************
10982C               **  STEP 1--                    **
10983C               **  CONVERT THE CHARACTER       **
10984C               **********************************
10985C
10986      ICH2(1:1)=ICHAR2(2:2)
10987CCCCC ICH2N=ICHAR(ICH2)
10988      CALL DPCOAN(ICH2,ICH2N)
10989      IF(ICH2N.EQ.32)GOTO1100
10990      GOTO7900
10991C
10992 1100 CONTINUE
10993      ICH1(1:1)=ICHAR2(1:1)
10994CCCCC ICH1N=ICHAR(ICH1)
10995      CALL DPCOAN(ICH1,ICH1N)
10996      ICHARN=ICH1N-64
10997      IF(1.LE.ICHARN.AND.ICHARN.LE.26)GOTO8000
10998      GOTO7900
10999C
11000 7900 CONTINUE
11001CCCCC WRITE(ICOUT,999)
11002CCCCC CALL DPWRST('XXX','BUG ')
11003CCCCC WRITE(ICOUT,7911)
11004C7911 FORMAT('***** ERROR IN DPCHAL--')
11005CCCCC CALL DPWRST('XXX','BUG ')
11006CCCCC WRITE(ICOUT,7912)
11007C7912 FORMAT('      NO MATCH FOUND FOR INPUT CHARACTER.')
11008CCCCC CALL DPWRST('XXX','BUG ')
11009CCCCC WRITE(ICOUT,7913)ICHAR
11010C7913 FORMAT('      INPUT CHARACTER = ',A4)
11011CCCCC CALL DPWRST('XXX','BUG ')
11012      IFOUND='NO'
11013      GOTO9000
11014C
11015 8000 CONTINUE
11016      IFOUND='YES'
11017      GOTO9000
11018C
11019C               *****************
11020C               **  STEP 90--  **
11021C               **  EXIT       **
11022C               *****************
11023C
11024 9000 CONTINUE
11025      IF(IBUGXX.EQ.'ON' .OR. ISUBG4.EQ.'CHAL')THEN
11026        WRITE(ICOUT,999)
11027        CALL DPWRST('XXX','BUG ')
11028        WRITE(ICOUT,9011)
11029 9011   FORMAT('***** AT THE END       OF DPCHAL--')
11030        CALL DPWRST('XXX','BUG ')
11031        WRITE(ICOUT,9012)ICH1,ICH1N,ICH2,ICH2N
11032 9012   FORMAT('ICH1,ICH1N,ICH2,ICH2N = ',A1,2X,I8,2X,A1,2X,I8)
11033        CALL DPWRST('XXX','BUG ')
11034        WRITE(ICOUT,9014)IFOUND,ICHAR2,ICHARN
11035 9014   FORMAT('IFOUND,ICHAR2,ICHARN = ',2(A4,2X),I8)
11036        CALL DPWRST('XXX','BUG ')
11037      ENDIF
11038C
11039      RETURN
11040      END
11041      SUBROUTINE DPCHAN(MAXCHA,ACHAAN,
11042     1IBUGP2,IBUGQ,IFOUND,IERROR)
11043C
11044C     PURPOSE--DEFINE PLOT CHARACTER ANGLES FOR USE IN MULTI-TRACE PLOTS.
11045C              THE ANGLE FOR THE CHARACTER FOR THE I-TH TRACE
11046C              WILL BE PLACED
11047C              IN THE I-TH ELEMENT OF THE FLOATING POINT
11048C              VECTOR ACHAAN(.).
11049C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
11050C                     --IARGT  (A  HOLLERITH VECTOR)
11051C                     --ARG    (A  HOLLERITH VECTOR)
11052C                     --NUMARG
11053C                     --MAXCHA
11054C     OUTPUT ARGUMENTS--ACHAAN  (A  FLOATING POINT VECTOR
11055C                       WHOSE I-TH ELEMENT IS THE ANGLE
11056C                       FOR THE CHARACTER
11057C                       ASSIGNED TO THE I-TH    TRACE    IN
11058C                       A MULTI-TRACE PLOT.
11059C                     --ACHAAN = CHARACTER ANGLE
11060C                     --IFOUND ('YES' OR 'NO' )
11061C                     --IERROR ('YES' OR 'NO' )
11062C     WRITTEN BY--JAMES J. FILLIBEN
11063C                 STATISTICAL ENGINEERING DIVISION
11064C                 INFORMATION TECHNOLOGY LABORATORY
11065C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
11066C                 GAITHERSBURG, MD 20899-8980
11067C                 PHONE--301-975-2899
11068C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
11069C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
11070C     LANGUAGE--ANSI FORTRAN (1977)
11071C     VERSION NUMBER--86/11
11072C     ORIGINAL VERSION--NOVEMBER  1986.
11073C
11074C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
11075C
11076CCCCC CHARACTER*4 IHARG        DECEMBER 1986
11077CCCCC CHARACTER*4 IARGT        DECEMBER 1986
11078C
11079      CHARACTER*4 IBUGP2
11080      CHARACTER*4 IBUGQ
11081      CHARACTER*4 IFOUND
11082      CHARACTER*4 IERROR
11083C
11084      CHARACTER*4 IHLEFT
11085      CHARACTER*4 IHLEF2
11086      CHARACTER*4 IHWUSE
11087      CHARACTER*4 MESSAG
11088      CHARACTER*4 ISTEPN
11089      CHARACTER*4 ISUBN1
11090      CHARACTER*4 ISUBN2
11091      CHARACTER*4 ICASEQ
11092      CHARACTER*4 IWRITE
11093C
11094C---------------------------------------------------------------------
11095C
11096CCCCC DIMENSION IHARG(*)       DECEMBER 1986
11097CCCCC DIMENSION IARGT(*)       DECEMBER 1986
11098CCCCC DIMENSION IARG(*)        DECEMBER 1986
11099CCCCC DIMENSION ARG(*)         DECEMBER 1986
11100C
11101      DIMENSION ACHAAN(*)
11102C
11103C-----COMMON----------------------------------------------------------
11104C
11105      INCLUDE 'DPCOPA.INC'
11106      INCLUDE 'DPCOHK.INC'
11107      INCLUDE 'DPCODA.INC'
11108C
11109C---------------------------------------------------------------------
11110C
11111      INCLUDE 'DPCOP2.INC'
11112C
11113C-----START POINT-----------------------------------------------------
11114C
11115      ISUBN1='DPCH'
11116      ISUBN2='AN  '
11117      IFOUND='NO'
11118      IERROR='NO'
11119C
11120      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'ANGL')GOTO1160
11121      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'ANGL')GOTO1105
11122      GOTO9000
11123C
11124 1105 CONTINUE
11125      IF(IHARG(NUMARG).EQ.'ON')GOTO1110
11126      IF(IHARG(NUMARG).EQ.'OFF')GOTO1110
11127      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1110
11128      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1110
11129C
11130      IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'ALL')GOTO1160
11131      IF(NUMARG.EQ.2)GOTO1120
11132      IF(NUMARG.GE.3.AND.IHARG(2).EQ.'ALL')GOTO1130
11133      IF(NUMARG.GE.3.AND.IHARG(3).EQ.'ALL')GOTO1140
11134C
11135      IF(NUMARG.GE.3.AND.IHARG(2).EQ.'AUTO')GOTO3000
11136C
11137      GOTO1150
11138C
11139 1110 CONTINUE
11140      DO1115I=1,MAXCHA
11141      ACHAAN(I)=0.0
11142 1115 CONTINUE
11143C
11144      IF(IFEEDB.EQ.'OFF')GOTO1119
11145      WRITE(ICOUT,999)
11146  999 FORMAT(1X)
11147      CALL DPWRST('XXX','BUG ')
11148      I=1
11149      WRITE(ICOUT,1116)ACHAAN(I)
11150 1116 FORMAT('ALL CHARACTER ANGLES HAVE JUST BEEN SET TO ',
11151     1E15.7)
11152      CALL DPWRST('XXX','BUG ')
11153 1119 CONTINUE
11154      GOTO8000
11155C
11156 1120 CONTINUE
11157      I=1
11158      IF(IARGT(2).NE.'NUMB')GOTO1180
11159      ACHAAN(1)=ARG(2)
11160C
11161      IF(IFEEDB.EQ.'OFF')GOTO1129
11162      WRITE(ICOUT,999)
11163      CALL DPWRST('XXX','BUG ')
11164      I=1
11165      WRITE(ICOUT,1126)I,ACHAAN(I)
11166 1126 FORMAT('THE ANGLE FOR CHARACTER ',I6,' HAS JUST BEEN SET TO ',
11167     1E15.7)
11168      CALL DPWRST('XXX','BUG ')
11169 1129 CONTINUE
11170      GOTO8000
11171C
11172 1130 CONTINUE
11173      I=1
11174      IF(IARGT(3).NE.'NUMB')GOTO1180
11175      DO1135I=1,MAXCHA
11176      ACHAAN(I)=ARG(3)
11177 1135 CONTINUE
11178C
11179      IF(IFEEDB.EQ.'OFF')GOTO1139
11180      WRITE(ICOUT,999)
11181      CALL DPWRST('XXX','BUG ')
11182      I=1
11183      WRITE(ICOUT,1116)ACHAAN(I)
11184      CALL DPWRST('XXX','BUG ')
11185 1139 CONTINUE
11186      GOTO8000
11187C
11188 1140 CONTINUE
11189      I=1
11190      IF(IARGT(2).NE.'NUMB')GOTO1180
11191      DO1145I=1,MAXCHA
11192      ACHAAN(I)=ARG(2)
11193 1145 CONTINUE
11194C
11195      IF(IFEEDB.EQ.'OFF')GOTO1149
11196      WRITE(ICOUT,999)
11197      CALL DPWRST('XXX','BUG ')
11198      I=1
11199      WRITE(ICOUT,1116)ACHAAN(I)
11200      CALL DPWRST('XXX','BUG ')
11201 1149 CONTINUE
11202      GOTO8000
11203C
11204 1150 CONTINUE
11205      IMAX=NUMARG-1
11206      IF(MAXCHA.LT.IMAX)IMAX=MAXCHA
11207      DO1155I=1,IMAX
11208      IP1=I+1
11209      IF(IARGT(IP1).NE.'NUMB')GOTO1180
11210      ACHAAN(I)=ARG(IP1)
11211 1155 CONTINUE
11212C
11213      IF(IFEEDB.EQ.'OFF')GOTO1159
11214      WRITE(ICOUT,999)
11215      CALL DPWRST('XXX','BUG ')
11216      DO1156I=1,IMAX
11217      WRITE(ICOUT,1126)I,ACHAAN(I)
11218      CALL DPWRST('XXX','BUG ')
11219 1156 CONTINUE
11220 1159 CONTINUE
11221      GOTO8000
11222C
11223 1160 CONTINUE
11224      DO1165I=1,MAXCHA
11225      ACHAAN(I)=0.0
11226 1165 CONTINUE
11227C
11228      IF(IFEEDB.EQ.'OFF')GOTO1169
11229      WRITE(ICOUT,999)
11230      CALL DPWRST('XXX','BUG ')
11231      I=1
11232      WRITE(ICOUT,1116)ACHAAN(I)
11233      CALL DPWRST('XXX','BUG ')
11234 1169 CONTINUE
11235      GOTO8000
11236C
11237 1180 CONTINUE
11238      IERROR='YES'
11239      WRITE(ICOUT,999)
11240      CALL DPWRST('XXX','BUG ')
11241      WRITE(ICOUT,1181)
11242 1181 FORMAT('***** ERROR IN DPCHAN--')
11243      CALL DPWRST('XXX','BUG ')
11244      WRITE(ICOUT,1182)
11245 1182 FORMAT('CHARACTER ANGLES MUST BE NUMERIC;')
11246      CALL DPWRST('XXX','BUG ')
11247      WRITE(ICOUT,1183)
11248 1183 FORMAT('HOWEVER, THE SPECIFIED CHARACTER ANGLE')
11249      CALL DPWRST('XXX','BUG ')
11250      WRITE(ICOUT,1184)I
11251 1184 FORMAT('FOR CHARACTER ',I6,' WAS NON-NUMERIC.')
11252      CALL DPWRST('XXX','BUG ')
11253      GOTO9000
11254C
11255C               ***********************************************************
11256C               **  STEP 30--                                            **
11257C               **  TREAT THE   CHARACTER ANGLE AUTOMATIC <VARIABLE>  CASE **
11258C               ***********************************************************
11259C
11260 3000 CONTINUE
11261C
11262C               ********************************************
11263C               **  STEP 31--                             **
11264C               **  CHECK THE VALIDITY OF ARGUMENT 3      **
11265C               **  (THIS WILL BE THE RESPONSE VARIABLE)  **
11266C               ********************************************
11267C
11268      ISTEPN='31'
11269      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11270C
11271      IHLEFT=IHARG(3)
11272      IHLEF2=IHARG2(3)
11273      IHWUSE='V'
11274      MESSAG='YES'
11275      CALL CHECKN(IHLEFT,IHLEF2,IHWUSE,
11276     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
11277     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
11278      IF(IERROR.EQ.'YES')GOTO9000
11279      ICOLL=IVALUE(ILOCV)
11280      NLEFT=IN(ILOCV)
11281C
11282C               *****************************************
11283C               **  STEP 32--                          **
11284C               **  CHECK TO SEE THE TYPE CASE--       **
11285C               **    1) UNQUALIFIED (THAT IS, FULL);  **
11286C               **    2) SUBSET/EXCEPT; OR             **
11287C               **    3) FOR.                          **
11288C               *****************************************
11289C
11290      ISTEPN='32'
11291      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11292C
11293      ICASEQ='FULL'
11294      ILOCQ=NUMARG+1
11295      IF(NUMARG.LT.1)GOTO3290
11296      DO3200J=1,NUMARG
11297      J1=J
11298      IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET  ') GOTO3210
11299      IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT  ') GOTO3210
11300      IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.'    ') GOTO3220
11301 3200 CONTINUE
11302      GOTO3290
11303 3210 CONTINUE
11304      ICASEQ='SUBS'
11305      ILOCQ=J1
11306      GOTO3290
11307 3220 CONTINUE
11308      ICASEQ='FOR'
11309      ILOCQ=J1
11310      GOTO3290
11311 3290 CONTINUE
11312      IF(IBUGP2.EQ.'OFF')GOTO3295
11313      WRITE(ICOUT,3291)NUMARG,ILOCQ
11314 3291 FORMAT('NUMARG,ILOCQ = ',2I8)
11315      CALL DPWRST('XXX','BUG ')
11316 3295 CONTINUE
11317C
11318C               *********************************************
11319C               **  STEP 33--                              **
11320C               **  TEMPORARILY FORM THE VARIABLE Y(.)     **
11321C               **  WHICH WILL HOLD THE RESPONSE VARIABLE. **
11322C               **  FORM THIS VARIABLE BY                  **
11323C               **  BRANCHING TO THE APPROPRIATE SUBCASE   **
11324C               **  (FULL, SUBSET, OR FOR).                **
11325C               *********************************************
11326C
11327      ISTEPN='33'
11328      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11329C
11330      IF(ICASEQ.EQ.'FULL')GOTO3310
11331      IF(ICASEQ.EQ.'SUBS')GOTO3320
11332      IF(ICASEQ.EQ.'FOR')GOTO3330
11333C
11334 3310 CONTINUE
11335      DO3315I=1,NLEFT
11336      ISUB(I)=1
11337 3315 CONTINUE
11338      NQ=NLEFT
11339      GOTO3350
11340C
11341 3320 CONTINUE
11342      NIOLD=NLEFT
11343      CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR)
11344      NQ=NIOLD
11345      GOTO3350
11346C
11347 3330 CONTINUE
11348      NIOLD=NLEFT
11349      CALL DPFOR(NIOLD,NFOR,IROW1,IROWN,
11350     1NLOCAL,ILOCS,NS,IBUGQ,IERROR)
11351      NQ=NFOR
11352      GOTO3350
11353C
11354 3350 CONTINUE
11355      MINN2=1
11356      IF(NQ.GE.MINN2)GOTO3360
11357      WRITE(ICOUT,999)
11358      CALL DPWRST('XXX','BUG ')
11359      WRITE(ICOUT,3351)
11360 3351 FORMAT('***** ERROR IN DPCHAN--')
11361      CALL DPWRST('XXX','BUG ')
11362      WRITE(ICOUT,3352)
11363 3352 FORMAT('      AFTER THE APPROPRIATE SUBSET HAS BEEN ',
11364     1'EXTRACTED,')
11365      CALL DPWRST('XXX','BUG ')
11366      WRITE(ICOUT,3353)IHLEFT,IHLEF2
11367 3353 FORMAT('      THE NUMBER OF OBSERVATIONS REMAINING',
11368     1'FROM VARIABLE ',A4,A4)
11369      CALL DPWRST('XXX','BUG ')
11370      WRITE(ICOUT,3354)
11371 3354 FORMAT('      (FOR WHICH CHARACTER ANGLES ')
11372      CALL DPWRST('XXX','BUG ')
11373      WRITE(ICOUT,3355)
11374 3355 FORMAT('      ARE TO BE GENERATED)')
11375      CALL DPWRST('XXX','BUG ')
11376      WRITE(ICOUT,3356)MINN2
11377 3356 FORMAT('      MUST BE ',I8,' OR LARGER;')
11378      CALL DPWRST('XXX','BUG ')
11379      WRITE(ICOUT,3357)
11380 3357 FORMAT('      SUCH WAS NOT THE CASE HERE.')
11381      CALL DPWRST('XXX','BUG ')
11382      WRITE(ICOUT,3358)
11383 3358 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
11384      CALL DPWRST('XXX','BUG ')
11385      IF(IWIDTH.GE.1)WRITE(ICOUT,3359)(IANS(I),I=1,IWIDTH)
11386 3359 FORMAT('      ',80A1)
11387      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
11388      IERROR='YES'
11389      GOTO9000
11390C
11391 3360 CONTINUE
11392      MAXCP1=MAXCOL+1
11393      MAXCP2=MAXCOL+2
11394      MAXCP3=MAXCOL+3
11395      MAXCP4=MAXCOL+4
11396      MAXCP5=MAXCOL+5
11397      MAXCP6=MAXCOL+6
11398      J=0
11399      IMAX=NLEFT
11400      IF(NQ.LT.NLEFT)IMAX=NQ
11401      DO3370I=1,IMAX
11402      IF(ISUB(I).EQ.0)GOTO3370
11403      J=J+1
11404C
11405      IJ=MAXN*(ICOLL-1)+I
11406      IF(ICOLL.LE.MAXCOL)Y(J)=V(IJ)
11407      IF(ICOLL.EQ.MAXCP1)Y(J)=PRED(I)
11408      IF(ICOLL.EQ.MAXCP2)Y(J)=RES(I)
11409      IF(ICOLL.EQ.MAXCP3)Y(J)=YPLOT(I)
11410      IF(ICOLL.EQ.MAXCP4)Y(J)=XPLOT(I)
11411      IF(ICOLL.EQ.MAXCP5)Y(J)=X2PLOT(I)
11412      IF(ICOLL.EQ.MAXCP6)Y(J)=TAGPLO(I)
11413C
11414 3370 CONTINUE
11415      NS=J
11416      NY=J
11417C
11418C               *****************************************
11419C               **  STEP 34--                          **
11420C               **  EXTRACT THE DISTINCT VALUES        **
11421C               **  FROM THE TARGET VARIABLE Y(.)   .  **
11422C               **  STORE THEM IN X(.)   .             **
11423C               *****************************************
11424C
11425      IWRITE='OFF'
11426      CALL DISTIN(Y,NY,IWRITE,X,NX,IBUGP2,IERROR)
11427C
11428C               ***********************************
11429C               **  STEP 35--                    **
11430C               **  SORT THESE DISTINCT VALUES   **
11431C               **  (IN PLACE).                  **
11432C               ***********************************
11433C
11434      CALL SORT(X,NX,X)
11435C
11436C               ******************************************
11437C               **  STEP 36--                           **
11438C               **  COPY    THE NUMERIC VALUES IN X(.)  **
11439C               **  INTO INDIVIDUAL ELEMENTS            **
11440C               **  OF ACHAAN(.)                        **
11441C               **  NOTE--MAX NUMBER OF VALUES  = 100   **
11442C               ******************************************
11443C
11444      IMAX=NX
11445      IF(IMAX.GT.MAXCHA)IMAX=MAXCHA
11446      DO3650I=1,IMAX
11447      ACHAAN(I)=X(I)
11448 3650 CONTINUE
11449C
11450      IF(IFEEDB.EQ.'OFF')GOTO3679
11451      WRITE(ICOUT,999)
11452      CALL DPWRST('XXX','BUG ')
11453      DO3675I=1,IMAX
11454      WRITE(ICOUT,3676)I,ACHAAN(I)
11455 3676 FORMAT('CHARACTER ANGLE ',I6,' HAS JUST BEEN SET TO ',
11456     1E15.7)
11457      CALL DPWRST('XXX','BUG ')
11458 3675 CONTINUE
11459 3679 CONTINUE
11460      GOTO8000
11461C
11462 8000 CONTINUE
11463      IFOUND='YES'
11464      GOTO9000
11465C
11466C               *****************
11467C               **  STEP 90--  **
11468C               **  EXIT       **
11469C               *****************
11470C
11471 9000 CONTINUE
11472      IF(IBUGP2.EQ.'OFF')GOTO9090
11473      WRITE(ICOUT,999)
11474      CALL DPWRST('XXX','BUG ')
11475      WRITE(ICOUT,9011)
11476 9011 FORMAT('***** AT THE END       OF DPCHAR--')
11477      CALL DPWRST('XXX','BUG ')
11478      WRITE(ICOUT,9012)IBUGP2
11479 9012 FORMAT('IBUGP2 = ',A4)
11480      CALL DPWRST('XXX','BUG ')
11481      WRITE(ICOUT,9013)IFOUND,IERROR
11482 9013 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
11483      CALL DPWRST('XXX','BUG ')
11484      WRITE(ICOUT,9014)IMAX
11485 9014 FORMAT('IMAX = ',I8)
11486      CALL DPWRST('XXX','BUG ')
11487      WRITE(ICOUT,9021)NY
11488 9021 FORMAT('NY = ',I8)
11489      CALL DPWRST('XXX','BUG ')
11490      IF(NY.LE.0)GOTO9022
11491      DO9023I=1,NY
11492      WRITE(ICOUT,9024)I,Y(I)
11493 9024 FORMAT('I,Y(I) = ',I8,E15.7)
11494      CALL DPWRST('XXX','BUG ')
11495 9023 CONTINUE
11496 9022 CONTINUE
11497      WRITE(ICOUT,9031)NX
11498 9031 FORMAT('NX = ',I8)
11499      CALL DPWRST('XXX','BUG ')
11500      IF(NX.LE.0)GOTO9032
11501      DO9033I=1,NX
11502      WRITE(ICOUT,9034)I,X(I)
11503 9034 FORMAT('I,X(I) = ',I8,E15.7)
11504      CALL DPWRST('XXX','BUG ')
11505 9033 CONTINUE
11506 9032 CONTINUE
11507      WRITE(ICOUT,9041)MAXCHA
11508 9041 FORMAT('MAXCHA = ',I8)
11509      CALL DPWRST('XXX','BUG ')
11510      IF(NX.LE.0)GOTO9042
11511      DO9043I=1,NX
11512      WRITE(ICOUT,9044)I,ACHAAN(I)
11513 9044 FORMAT('I,ACHAAN(I) = ',I8,2X,A4)
11514      CALL DPWRST('XXX','BUG ')
11515 9043 CONTINUE
11516 9042 CONTINUE
11517 9090 CONTINUE
11518      RETURN
11519      END
11520      SUBROUTINE DPCHAR(MAXCHA,ICHAPA,ICHAPO,
11521     1                  IBUGP2,IBUGQ,ISUBRO,IFOUND,IERROR)
11522C
11523C     PURPOSE--DEFINE PLOT CHARACTERS FOR USE IN MULTI-TRACE PLOTS.
11524C              THE CHARACTER FOR THE I-TH TRACE WILL BE PLACED
11525C              IN THE I-TH ELEMENT OF THE HOLLERITH
11526C              VECTOR ICHAPA(.).
11527C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
11528C                     --NUMARG
11529C                     --MAXCHA
11530C     OUTPUT ARGUMENTS--ICHAPA  (A  HOLLERITH VECTOR
11531C                       WHOSE I-TH ELEMENT IS THE CHARACTER
11532C                       ASSIGNED TO THE I-TH    TRACE    IN
11533C                       A MULTI-TRACE PLOT.
11534C                     --IFOUND ('YES' OR 'NO' )
11535C                     --IERROR ('YES' OR 'NO' )
11536C     WRITTEN BY--JAMES J. FILLIBEN
11537C                 STATISTICAL ENGINEERING DIVISION
11538C                 INFORMATION TECHNOLOGY LABORATORY
11539C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
11540C                 GAITHERSBURG, MD 20899-8980
11541C                 PHONE--301-975-2899
11542C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
11543C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
11544C     LANGUAGE--ANSI FORTRAN (1977)
11545C     VERSION NUMBER--82/7
11546C     ORIGINAL VERSION--DECEMBER  1977
11547C     UPDATED         --SEPTEMBER 1980
11548C     UPDATED         --MARCH     1982
11549C     UPDATED         --MAY       1982
11550C     UPDATED         --JULY      1983
11551C     UPDATED         --NOVEMBER  1986
11552C     UPDATED         --JANAURY   1988 (OMIT SORTING FOR CHAR AUTOMATIC)
11553C     UPDATED         --AUGUST    1987 TUFTE BOX PLOT
11554C     UPDATED         --NOVEMBER  1988 ERROR BAR PLOT
11555C     UPDATED         --JUNE      1989 CHAR AUTOMATIC DISTINCT
11556C     UPDATED         --SEPTEMBER 1990 AUGMENT CONTROL CHART
11557C     UPDATED         --NOVEMBER  1995 SUPPORT CASE ASIS
11558C     UPDATED         --FEBRUARY  1998 CHAR <SAVE/RESTORE>
11559C     UPDATED         --JANUARY   2001 CHAR AUTOMATIC SIGN
11560C     UPDATED         --FEBRUARY  2003 CHAR VIOLIN PLOT
11561C     UPDATED         --JUNE      2010 ALLOW 16 CHARACTERS FOR CHARACTER
11562C                                      PATTERN
11563C     UPDATED         --DECEMBER  2011 CHARACTER AUTOMATIC OFFSET
11564C     UPDATED         --JULY      2012 CHARACTER AUTOMATIC DYNAMIC
11565C     UPDATED         --APRIL     2018 ALLOW 24 CHARACTERS FOR CHARACTER
11566C
11567C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
11568C
11569CCCCC CHARACTER*4 IHARG       DECEMBER 1986
11570CCCCC CHARACTER*4 ICHAPA
11571CCCCC CHARACTER*4 ICHAPO
11572      CHARACTER*24 ICHAPA
11573      CHARACTER*24 ICHAPO
11574      CHARACTER*4 IBUGP2
11575      CHARACTER*4 IBUGQ
11576      CHARACTER*4 ISUBRO
11577      CHARACTER*4 IFOUND
11578      CHARACTER*4 IERROR
11579C
11580      CHARACTER*4 IHLEFT
11581      CHARACTER*4 IHLEF2
11582      CHARACTER*4 IHWUSE
11583      CHARACTER*4 MESSAG
11584      CHARACTER*4 ISTEPN
11585      CHARACTER*4 ISUBN1
11586      CHARACTER*4 ISUBN2
11587      CHARACTER*4 ICASEQ
11588      CHARACTER*4 IWRITE
11589      CHARACTER*4 ICTEXT
11590CCCCC FOLLOWING LINE JANAURY 2001
11591      CHARACTER*4 ISIGNF
11592      CHARACTER*4 IHYPSV
11593C
11594      CHARACTER*80 ISTRIN
11595      CHARACTER*80 ISTRCH
11596C
11597C---------------------------------------------------------------------
11598C
11599CCCCC DIMENSION IHARG(*)      DECEMBER 1986
11600      DIMENSION ICHAPA(*)
11601CCCCC ADD FOLLOWING LINE FEBRUARY 1998.
11602      DIMENSION ICHAPO(*)
11603      DIMENSION ICTEXT(100)
11604C
11605C
11606C-----COMMON----------------------------------------------------------
11607C
11608      INCLUDE 'DPCOPA.INC'
11609      INCLUDE 'DPCOHK.INC'
11610      INCLUDE 'DPCODA.INC'
11611      INCLUDE 'DPCOST.INC'
11612C
11613C---------------------------------------------------------------------
11614C
11615      INCLUDE 'DPCOP2.INC'
11616C
11617C-----START POINT-----------------------------------------------------
11618C
11619      ISUBN1='DPCH'
11620      ISUBN2='AR  '
11621      IFOUND='NO'
11622      IERROR='NO'
11623      ICHAVN='NULL'
11624      IHYPSV=IHYPSW
11625      IHYPSW='OFF'
11626C
11627      NCCHAR=0
11628C
11629      IF(IBUGP2.EQ.'ON' .OR. ISUBRO.EQ.'CHAR')THEN
11630        WRITE(ICOUT,11)ICOM,IHARG(1),IHARG(2),IHARG(3),NUMARG
11631   11   FORMAT('IN DPCHAR: ICOM,IHARG(1),IHARG(2),IHARG(3),NUMARG = ',
11632     1         4(2X,A4),I8)
11633        CALL DPWRST('XXX','BUG ')
11634      ENDIF
11635C
11636      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COLO')GOTO9000
11637      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'SIZE')GOTO9000
11638      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'FILL')GOTO9000
11639      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TYPE')GOTO9000
11640      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TABU')GOTO9000
11641C
11642      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'SAVE')THEN
11643        DO2163I=1,MAXCHA
11644          ICHAPO(I)=ICHAPA(I)
11645 2163   CONTINUE
11646        IF(IFEEDB.EQ.'ON')THEN
11647          WRITE(ICOUT,999)
11648          CALL DPWRST('XXX','BUG ')
11649          WRITE(ICOUT,2164)
11650 2164     FORMAT('THE CURRENT CHARACTER SETTINGS HAVE BEEN SAVED.')
11651          CALL DPWRST('XXX','BUG ')
11652        ENDIF
11653        IFOUND='YES'
11654        GOTO9000
11655      ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'REST')THEN
11656        DO2168I=1,MAXCHA
11657          ICHAPA(I)=ICHAPO(I)
11658 2168   CONTINUE
11659        IF(IFEEDB.EQ.'ON')THEN
11660          WRITE(ICOUT,999)
11661          CALL DPWRST('XXX','BUG ')
11662          WRITE(ICOUT,2169)
11663 2169     FORMAT('THE SAVED CHARACTER SETTINGS HAVE BEEN RESTORED.')
11664          CALL DPWRST('XXX','BUG ')
11665        ENDIF
11666        IFOUND='YES'
11667        GOTO9000
11668      ELSEIF((NUMARG.GE.2.AND.IHARG(1).EQ.'BOX'.AND.
11669     1        IHARG(2).EQ.'PLOT') .OR.
11670     1       (NUMARG.GE.3.AND.IHARG(2).EQ.'BOX'.AND.
11671     1        IHARG(3).EQ.'PLOT'))THEN
11672        IMAX=24
11673        ICHAPA(1)='X'
11674        ICHAPA(2)=' '
11675        ICHAPA(3)=' '
11676        ICHAPA(4)='X'
11677        ICHAPA(5)=' '
11678        ICHAPA(6)=' '
11679        ICHAPA(7)='X'
11680        ICHAPA(8)=' '
11681        ICHAPA(9)=' '
11682        ICHAPA(10)=' '
11683        ICHAPA(11)=' '
11684        ICHAPA(12)=' '
11685        ICHAPA(13)=' '
11686        ICHAPA(14)=' '
11687        ICHAPA(15)=' '
11688        ICHAPA(16)=' '
11689        ICHAPA(17)=' '
11690        ICHAPA(18)=' '
11691        ICHAPA(19)=' '
11692        ICHAPA(20)=' '
11693        ICHAPA(21)='CIRC'
11694        ICHAPA(22)='CIRC'
11695        ICHAPA(23)='CIRC'
11696        ICHAPA(24)='CIRC'
11697        GOTO2170
11698      ELSEIF(NUMARG.GE.3.AND.IHARG(1).EQ.'TUFT'.AND.
11699     1       IHARG(2).EQ.'BOX'.AND.IHARG(3).EQ.'PLOT')THEN
11700        IMAX=24
11701        ICHAPA(1)=' '
11702        ICHAPA(2)=' '
11703        ICHAPA(3)=' '
11704        ICHAPA(4)='X'
11705        ICHAPA(5)=' '
11706        ICHAPA(6)=' '
11707        ICHAPA(7)=' '
11708        ICHAPA(8)=' '
11709        ICHAPA(9)=' '
11710        ICHAPA(10)=' '
11711        ICHAPA(11)=' '
11712        ICHAPA(12)=' '
11713        ICHAPA(13)=' '
11714        ICHAPA(14)=' '
11715        ICHAPA(15)=' '
11716        ICHAPA(16)=' '
11717        ICHAPA(17)=' '
11718        ICHAPA(18)=' '
11719        ICHAPA(19)=' '
11720        ICHAPA(20)=' '
11721        ICHAPA(21)='CIRC'
11722        ICHAPA(22)='CIRC'
11723        ICHAPA(23)='CIRC'
11724        ICHAPA(24)='CIRC'
11725        GOTO2170
11726      ELSEIF(NUMARG.GE.3.AND.IHARG(1).EQ.'ERRO'.AND.
11727     1       IHARG(2).EQ.'BAR'.AND.IHARG(3).EQ.'PLOT')THEN
11728        IMAX=7
11729        ICHAPA(1)='CIRC'
11730        ICHAPA(2)='-'
11731        ICHAPA(3)='-'
11732        ICHAPA(4)='|'
11733        ICHAPA(5)='|'
11734        ICHAPA(6)=' '
11735        ICHAPA(7)=' '
11736        GOTO2170
11737      ELSEIF((NUMARG.GE.2.AND.IHARG(1).EQ.'I'.AND.
11738     1       IHARG(2).EQ.'PLOT') .OR.
11739     1      (NUMARG.GE.3.AND.IHARG(2).EQ.'I'.AND.
11740     1       IHARG(3).EQ.'PLOT'))THEN
11741        IMAX=5
11742        ICHAPA(1)='-'
11743        ICHAPA(2)='X'
11744        ICHAPA(3)='-'
11745        ICHAPA(4)=' '
11746        ICHAPA(5)=' '
11747        GOTO2170
11748      ELSEIF((NUMARG.GE.2.AND.IHARG(1).EQ.'CONT'.AND.
11749     1       IHARG(2).EQ.'CHAR') .OR.
11750     1      (NUMARG.GE.3.AND.IHARG(2).EQ.'CONT'.AND.
11751     1       IHARG(3).EQ.'CHAR'))THEN
11752        IMAX=7
11753        ICHAPA(1)='CIRC'
11754        ICHAPA(2)=' '
11755        ICHAPA(3)=' '
11756        ICHAPA(4)=' '
11757        ICHAPA(5)=' '
11758        ICHAPA(6)=' '
11759        ICHAPA(7)=' '
11760        GOTO2170
11761      ELSEIF((NUMARG.GE.2.AND.IHARG(1).EQ.'VIOL'.AND.
11762     1       IHARG(2).EQ.'PLOT') .OR.
11763     1      (NUMARG.GE.4.AND.IHARG(1).EQ.'VIOL'.AND.
11764     1       IHARG(2).EQ.'TUFT'.AND.IHARG(3).EQ.'BOX'.AND.
11765     1       IHARG(4).EQ.'PLOT'))THEN
11766        IMAX=25
11767        ICHAPA(1)=' '
11768        ICHAPA(2)=' '
11769        ICHAPA(3)=' '
11770        ICHAPA(4)=' '
11771        ICHAPA(5)='X'
11772        ICHAPA(6)=' '
11773        ICHAPA(7)=' '
11774        ICHAPA(8)=' '
11775        ICHAPA(9)=' '
11776        ICHAPA(10)=' '
11777        ICHAPA(11)=' '
11778        ICHAPA(12)=' '
11779        ICHAPA(13)=' '
11780        ICHAPA(14)=' '
11781        ICHAPA(15)=' '
11782        ICHAPA(16)=' '
11783        ICHAPA(17)=' '
11784        ICHAPA(18)=' '
11785        ICHAPA(19)=' '
11786        ICHAPA(20)=' '
11787        ICHAPA(21)=' '
11788        ICHAPA(22)='CIRC'
11789        ICHAPA(23)='CIRC'
11790        ICHAPA(24)='CIRC'
11791        ICHAPA(25)='CIRC'
11792        GOTO2170
11793      ELSEIF(NUMARG.GE.4.AND.IHARG(1).EQ.'VIOL'.AND.
11794     1       IHARG(2).EQ.'BOX'.AND.IHARG(4).EQ.'PLOT')THEN
11795        IMAX=25
11796        ICHAPA(1)=' '
11797        ICHAPA(2)='X'
11798        ICHAPA(3)=' '
11799        ICHAPA(4)=' '
11800        ICHAPA(5)='X'
11801        ICHAPA(6)=' '
11802        ICHAPA(7)=' '
11803        ICHAPA(8)='X'
11804        ICHAPA(9)=' '
11805        ICHAPA(10)=' '
11806        ICHAPA(11)=' '
11807        ICHAPA(12)=' '
11808        ICHAPA(13)=' '
11809        ICHAPA(14)=' '
11810        ICHAPA(15)=' '
11811        ICHAPA(16)=' '
11812        ICHAPA(17)=' '
11813        ICHAPA(18)=' '
11814        ICHAPA(19)=' '
11815        ICHAPA(20)=' '
11816        ICHAPA(21)=' '
11817        ICHAPA(22)='CIRC'
11818        ICHAPA(23)='CIRC'
11819        ICHAPA(24)='CIRC'
11820        ICHAPA(25)='CIRC'
11821        GOTO2170
11822      ENDIF
11823      GOTO1101
11824C
11825 2170 CONTINUE
11826      IF(IFEEDB.EQ.'ON')THEN
11827        WRITE(ICOUT,999)
11828        CALL DPWRST('XXX','BUG ')
11829        DO2175I=1,IMAX
11830          WRITE(ICOUT,2176)I,ICHAPA(I)(1:8)
11831 2176     FORMAT('CHARACTER ',I6,' HAS JUST BEEN SET TO ',A8)
11832          CALL DPWRST('XXX','BUG ')
11833 2175   CONTINUE
11834      ENDIF
11835      GOTO8000
11836C
11837 1101 CONTINUE
11838C
11839      IF(NUMARG.LE.0 .OR.
11840     1   (NUMARG.EQ.1.AND.IHARG(1).EQ.'ALL') .OR.
11841     1   (IHARG(NUMARG).EQ.'OFF') .OR.
11842     1   (IHARG(NUMARG).EQ.'DEFA'))THEN
11843        DO1165I=1,MAXCHA
11844          ICHAPA(I)='    '
11845 1165   CONTINUE
11846C
11847        IF(IFEEDB.EQ.'ON')THEN
11848          WRITE(ICOUT,999)
11849          CALL DPWRST('XXX','BUG ')
11850          I=1
11851          WRITE(ICOUT,1116)ICHAPA(I)(1:8)
11852          CALL DPWRST('XXX','BUG ')
11853        ENDIF
11854        GOTO8000
11855      ELSEIF(IHARG(NUMARG).EQ.'ON' .OR. IHARG(NUMARG).EQ.'AUTO')THEN
11856        DO1115I=1,MAXCHA
11857          ICHAPA(I)='X'
11858 1115   CONTINUE
11859C
11860        IF(IFEEDB.EQ.'ON')THEN
11861          WRITE(ICOUT,999)
11862  999     FORMAT(1X)
11863          CALL DPWRST('XXX','BUG ')
11864          I=1
11865          WRITE(ICOUT,1116)ICHAPA(I)(1:24)
11866 1116     FORMAT('ALL CHARACTERS HAVE JUST BEEN SET TO ',A24)
11867          CALL DPWRST('XXX','BUG ')
11868        ENDIF
11869        GOTO8000
11870C
11871      ELSEIF(NUMARG.EQ.1)THEN
11872        IF(NUMARG.EQ.0)ICHAPA(1)='    '
11873        IF(NUMARG.GE.1)THEN
11874          IF(IHARG(1).EQ.'BOX')THEN
11875            ICHAPA(1)='SQUA'
11876          ELSE
11877            ICHAPA(1)=' '
11878CCCCC       ICHAPA(1)(1:4)=IHARLC(1)
11879CCCCC       ICHAPA(1)(5:8)=IHARL2(1)
11880            ISTART=1
11881            ISTOP=IWIDTH
11882            IWORD=2
11883            NCCHAR=0
11884            ISTRIN=' '
11885            ISTRCH=' '
11886            DO6001II=1,IWIDTH
11887              ISTRIN(II:II)=IANSLC(II)(1:1)
11888 6001       CONTINUE
11889            CALL DPEXWO(ISTRIN,ISTART,ISTOP,IWORD,
11890     1                  ICOL1,ICOL2,ISTRCH,NCCHAR,
11891     1                  IBUGP2,ISUBRO,IERROR)
11892            IF(NCCHAR.GT.24)NCCHAR=24
11893            ICHAPA(1)=' '
11894            ICHAPA(1)(1:NCCHAR)=ISTRCH(1:NCCHAR)
11895          ENDIF
11896        ENDIF
11897C
11898        IF(IFEEDB.EQ.'ON')THEN
11899          WRITE(ICOUT,999)
11900          CALL DPWRST('XXX','BUG ')
11901          I=1
11902          WRITE(ICOUT,1126)I,ICHAPA(I)
11903 1126     FORMAT('CHARACTER ',I6,' HAS JUST BEEN SET TO ',A24)
11904          CALL DPWRST('XXX','BUG ')
11905        ENDIF
11906        GOTO8000
11907      ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'ALL')THEN
11908        DO1135I=1,MAXCHA
11909          ICHAPA(I)=' '
11910          IF(IHARG(2).EQ.'BOX')THEN
11911            ICHAPA(I)='SQUA'
11912          ELSE
11913CCCCC       ICHAPA(I)(1:4)=IHARLC(2)
11914CCCCC       ICHAPA(I)(5:8)=IHARL2(2)
11915            ISTART=1
11916            ISTOP=IWIDTH
11917            IWORD=3
11918            NCCHAR=0
11919            ISTRIN=' '
11920            ISTRCH=' '
11921            DO6003II=1,IWIDTH
11922              ISTRIN(II:II)=IANSLC(II)(1:1)
11923 6003       CONTINUE
11924            CALL DPEXWO(ISTRIN,ISTART,ISTOP,IWORD,
11925     1                  ICOL1,ICOL2,ISTRCH,NCCHAR,
11926     1                  IBUGP2,ISUBRO,IERROR)
11927            IF(NCCHAR.GT.24)NCCHAR=24
11928            ICHAPA(I)=' '
11929            ICHAPA(I)(1:NCCHAR)=ISTRCH(1:NCCHAR)
11930          ENDIF
11931 1135   CONTINUE
11932C
11933        IF(IFEEDB.EQ.'ON')THEN
11934          WRITE(ICOUT,999)
11935          CALL DPWRST('XXX','BUG ')
11936          I=1
11937          WRITE(ICOUT,1116)ICHAPA(I)
11938          CALL DPWRST('XXX','BUG ')
11939        ENDIF
11940        GOTO8000
11941      ELSEIF(NUMARG.GE.2.AND.IHARG(2).EQ.'ALL')THEN
11942        DO1145I=1,MAXCHA
11943          ICHAPA(I)=' '
11944          IF(IHARG(1).EQ.'BOX')THEN
11945            ICHAPA(I)='SQUA'
11946          ELSE
11947CCCCC       ICHAPA(I)(1:4)=IHARLC(1)
11948CCCCC       ICHAPA(I)(5:8)=IHARL2(1)
11949            ISTART=1
11950            ISTOP=IWIDTH
11951            IWORD=2
11952            NCCHAR=0
11953            ISTRIN=' '
11954            ISTRCH=' '
11955            DO6005II=1,IWIDTH
11956              ISTRIN(II:II)=IANSLC(II)(1:1)
11957 6005       CONTINUE
11958            CALL DPEXWO(ISTRIN,ISTART,ISTOP,IWORD,
11959     1                  ICOL1,ICOL2,ISTRCH,NCCHAR,
11960     1                  IBUGP2,ISUBRO,IERROR)
11961            IF(NCCHAR.GT.24)NCCHAR=24
11962            ICHAPA(I)=' '
11963            ICHAPA(I)(1:NCCHAR)=ISTRCH(1:NCCHAR)
11964          ENDIF
11965 1145   CONTINUE
11966C
11967        IF(IFEEDB.EQ.'ON')THEN
11968          WRITE(ICOUT,999)
11969          CALL DPWRST('XXX','BUG ')
11970          I=1
11971          WRITE(ICOUT,1116)ICHAPA(I)
11972          CALL DPWRST('XXX','BUG ')
11973        ENDIF
11974        GOTO8000
11975      ELSEIF((NUMARG.GE.2.AND.IHARG(2).EQ.'SUBS'.AND.
11976     1        IHARG2(2).EQ.'ET  ') .OR.
11977     1       (NUMARG.GE.2.AND.IHARG(2).EQ.'EXCE'.AND.
11978     1        IHARG2(2).EQ.'PT  '))THEN
11979        ICASEQ='SUBS'
11980        GOTO4190
11981      ELSEIF(NUMARG.GE.2.AND.IHARG(2).EQ.'FOR '.AND.
11982     1       IHARG2(2).EQ.'    ')THEN
11983        ICASEQ='FOR'
11984        GOTO4190
11985      ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'AUTO')THEN
11986C
11987C               ***********************************************************
11988C               **  STEP 30--                                            **
11989C               **  TREAT THE    CHARACTERS AUTOMATIC <VARIABLE>   CASE  **
11990C               ***********************************************************
11991C
11992C       NOTE 2012/07: IF A "SET CHARACTER AUTOMATIC DYNAMIC ON" HAS BEEN
11993C                     ENTERED, JUST STORE THE VARIABLE NAME.
11994C
11995C               ********************************************
11996C               **  STEP 31--                             **
11997C               **  CHECK THE VALIDITY OF ARGUMENT 2 (OR 3)**
11998C               **  (THIS WILL BE THE RESPONSE VARIABLE)  **
11999C               ********************************************
12000C
12001        ISTEPN='31'
12002        IF(IBUGP2.EQ.'ON'.OR.ISUBRO.EQ.'CHAR')
12003     1     CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12004C
12005        IHLEFT=IHARG(2)
12006        IHLEF2=IHARG2(2)
12007        IF(IHARG(2).EQ.'DIST'.AND.IHARG2(2).EQ.'INCT')IHLEFT=IHARG(3)
12008        IF(IHARG(2).EQ.'DIST'.AND.IHARG2(2).EQ.'INCT')IHLEF2=IHARG2(3)
12009        ISIGNF='OFF'
12010        IF(IHARG(2).EQ.'SIGN'.AND.IHARG2(2).EQ.'    ')ISIGNF='ON'
12011        IF(IHARG(2).EQ.'SIGN'.AND.IHARG2(2).EQ.'    ')IHLEFT=IHARG(3)
12012        IF(IHARG(2).EQ.'SIGN'.AND.IHARG2(2).EQ.'    ')IHLEF2=IHARG2(3)
12013        IHWUSE='V'
12014        MESSAG='YES'
12015        CALL CHECKN(IHLEFT,IHLEF2,IHWUSE,
12016     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
12017     1              ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
12018        IF(IERROR.EQ.'YES')GOTO9000
12019C
12020        IF(ICHADY.EQ.'ON')THEN
12021          WRITE(ICOUT,3010)ICOLL,NLEFT
12022 3010     FORMAT('CHARACTER AUTOMATIC: ICOLL,NLEFT = ',2I8)
12023          CALL DPWRST('XXX','BUG ')
12024          ICHAVN(1:4)=IHLEFT
12025          ICHAVN(5:8)=IHLEF2
12026          IF(IFEEDB.EQ.'OFF')THEN
12027            WRITE(ICOUT,999)
12028            CALL DPWRST('XXX','BUG ')
12029            WRITE(ICOUT,3003)
12030 3003       FORMAT('CHARACTER SETTINGS WILL BE EXTRACTED FROM ')
12031            CALL DPWRST('XXX','BUG ')
12032            WRITE(ICOUT,3005)ICHAVN
12033 3005       FORMAT('VARIABLE ',A8,' WHEN THE PLOT IS GENERATED.')
12034            CALL DPWRST('XXX','BUG ')
12035          ENDIF
12036          GOTO9000
12037        ENDIF
12038C
12039        ICOLL=IVALUE(ILOCV)
12040        NLEFT=IN(ILOCV)
12041C
12042        IF(IBUGP2.EQ.'ON'.OR.ISUBRO.EQ.'CHAR')THEN
12043          WRITE(ICOUT,3090)ICOLL,NLEFT
12044 3090     FORMAT('CHARACTER AUTOMATIC: ICOLL,NLEFT = ',2I8)
12045          CALL DPWRST('XXX','BUG ')
12046        ENDIF
12047C
12048C               *****************************************
12049C               **  STEP 32--                          **
12050C               **  CHECK TO SEE THE TYPE CASE--       **
12051C               **    1) UNQUALIFIED (THAT IS, FULL);  **
12052C               **    2) SUBSET/EXCEPT; OR             **
12053C               **    3) FOR.                          **
12054C               *****************************************
12055C
12056        ISTEPN='32'
12057        IF(IBUGP2.EQ.'ON'.OR.ISUBRO.EQ.'CHAR')
12058     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12059C
12060        ICASEQ='FULL'
12061        ILOCQ=NUMARG+1
12062        IF(NUMARG.LT.1)GOTO3290
12063        DO3200J=1,NUMARG
12064          J1=J
12065          IF((IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET  ') .OR.
12066     1       (IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT  '))THEN
12067            ICASEQ='SUBS'
12068            ILOCQ=J1
12069            GOTO3290
12070          ELSEIF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.'    ')THEN
12071            ICASEQ='FOR'
12072            ILOCQ=J1
12073            GOTO3290
12074          ENDIF
12075 3200   CONTINUE
12076C
12077 3290   CONTINUE
12078        IF(IBUGP2.EQ.'OFF')THEN
12079          WRITE(ICOUT,3291)NUMARG,ILOCQ
12080 3291     FORMAT('NUMARG,ILOCQ = ',2I8)
12081          CALL DPWRST('XXX','BUG ')
12082        ENDIF
12083C
12084C               *********************************************
12085C               **  STEP 33--                              **
12086C               **  TEMPORARILY FORM THE VARIABLE Y(.)     **
12087C               **  WHICH WILL HOLD THE RESPONSE VARIABLE. **
12088C               **  FORM THIS VARIABLE BY                  **
12089C               **  BRANCHING TO THE APPROPRIATE SUBCASE   **
12090C               **  (FULL, SUBSET, OR FOR).                **
12091C               *********************************************
12092C
12093        ISTEPN='33'
12094        IF(IBUGP2.EQ.'ON'.OR.ISUBRO.EQ.'CHAR')
12095     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12096C
12097        IF(ICASEQ.EQ.'SUBS')THEN
12098          NIOLD=NLEFT
12099          CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR)
12100          NQ=NIOLD
12101        ELSEIF(ICASEQ.EQ.'FOR')THEN
12102          NIOLD=NLEFT
12103          CALL DPFOR(NIOLD,NFOR,IROW1,IROWN,
12104     1               NLOCAL,ILOCS,NS,IBUGQ,IERROR)
12105          NQ=NFOR
12106        ELSE
12107          DO3315I=1,NLEFT
12108            ISUB(I)=1
12109 3315     CONTINUE
12110          NQ=NLEFT
12111        ENDIF
12112C
12113        MINN2=1
12114        IF(NQ.LT.MINN2)THEN
12115          WRITE(ICOUT,999)
12116          CALL DPWRST('XXX','BUG ')
12117          WRITE(ICOUT,3351)
12118 3351     FORMAT('***** ERROR IN DPCHAR--')
12119          CALL DPWRST('XXX','BUG ')
12120          WRITE(ICOUT,3352)
12121 3352     FORMAT('      AFTER THE APPROPRIATE SUBSET HAS BEEN ',
12122     1           'EXTRACTED,')
12123          CALL DPWRST('XXX','BUG ')
12124          WRITE(ICOUT,3353)IHLEFT,IHLEF2
12125 3353     FORMAT('      THE NUMBER OF OBSERVATIONS REMAINING',
12126     1           'FROM VARIABLE ',A4,A4)
12127          CALL DPWRST('XXX','BUG ')
12128          WRITE(ICOUT,3354)
12129 3354     FORMAT('      (FOR WHICH CHARACTER DEFINITIONS ARE TO BE ',
12130     1           'GENERATED)')
12131          CALL DPWRST('XXX','BUG ')
12132          WRITE(ICOUT,3356)MINN2
12133 3356     FORMAT('      MUST BE ',I8,' OR LARGER;  SUCH WAS NOT THE ',
12134     1           'CASE HERE.')
12135          CALL DPWRST('XXX','BUG ')
12136          WRITE(ICOUT,3358)
12137 3358     FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
12138          CALL DPWRST('XXX','BUG ')
12139          IF(IWIDTH.GE.1)THEN
12140            WRITE(ICOUT,3359)(IANS(I),I=1,MIN(IWIDTH,80))
12141 3359       FORMAT('      ',80A1)
12142           CALL DPWRST('XXX','BUG ')
12143          ENDIF
12144          IERROR='YES'
12145          GOTO9000
12146        ENDIF
12147C
12148        MAXCP1=MAXCOL+1
12149        MAXCP2=MAXCOL+2
12150        MAXCP3=MAXCOL+3
12151        MAXCP4=MAXCOL+4
12152        MAXCP5=MAXCOL+5
12153        MAXCP6=MAXCOL+6
12154        J=0
12155        IMAX=NLEFT
12156        IF(NQ.LT.NLEFT)IMAX=NQ
12157        DO3370I=1,IMAX
12158          IF(ISUB(I).EQ.0)GOTO3370
12159          J=J+1
12160C
12161          IJ=MAXN*(ICOLL-1)+I
12162          IF(ICOLL.LE.MAXCOL)Y(J)=V(IJ)
12163          IF(ICOLL.EQ.MAXCP1)Y(J)=PRED(I)
12164          IF(ICOLL.EQ.MAXCP2)Y(J)=RES(I)
12165          IF(ICOLL.EQ.MAXCP3)Y(J)=YPLOT(I)
12166          IF(ICOLL.EQ.MAXCP4)Y(J)=XPLOT(I)
12167          IF(ICOLL.EQ.MAXCP5)Y(J)=X2PLOT(I)
12168          IF(ICOLL.EQ.MAXCP6)Y(J)=TAGPLO(I)
12169          IF(ISIGNF.EQ.'ON')THEN
12170            IF(Y(J).GT.0.0)THEN
12171              ICHAPA(J)='+   '
12172            ELSEIF(Y(J).LT.0.0)THEN
12173              ICHAPA(J)='-   '
12174            ELSEIF(Y(J).EQ.0.0)THEN
12175              ICHAPA(J)='0   '
12176            ELSE
12177              ICHAPA(J)='0   '
12178            ENDIF
12179          ENDIF
12180C
12181          IF(IBUGP2.EQ.'ON'.OR.ISUBRO.EQ.'CHAR')THEN
12182            WRITE(ICOUT,3365)ISIGNF,J,Y(J),ICHAPA(J)
12183 3365       FORMAT('ISIGNF,J,Y(J),ICHAPA(J) = ',A4,2X,I5,G15.7,2X,A24)
12184            CALL DPWRST('XXX','BUG ')
12185          ENDIF
12186C
12187 3370   CONTINUE
12188        NS=J
12189        NY=J
12190        IF(ISIGNF.EQ.'ON')GOTO8000
12191C
12192C               *****************************************
12193C               **  STEP 34--                          **
12194C               **  IF HAVE THE FORM--                 **
12195C               **  CHARACTERS AUTOMATIC DISTINCT X    **
12196C               **  EXTRACT THE DISTINCT VALUES        **
12197C               **  FROM THE TARGET VARIABLE Y(.)   .  **
12198C               **  STORE THEM IN X(.)   .             **
12199C               **  IF HAVE THE FORM--                 **
12200C               **  CHARACTERS AUTOMATIC X             **
12201C               **  DO NOTHING                         **
12202C               *****************************************
12203C
12204        ISTEPN='34'
12205        IF(IBUGP2.EQ.'ON'.OR.ISUBRO.EQ.'CHAR')
12206     1     CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12207C
12208        IF(IHARG(2).EQ.'DIST'.AND.IHARG2(2).EQ.'INCT')THEN
12209          IWRITE='OFF'
12210          CALL DISTIN(Y,NY,IWRITE,X,NX,IBUGP2,IERROR)
12211        ELSE
12212          DO3411I=1,NY
12213            X(I)=Y(I)
12214 3411     CONTINUE
12215          NX=NY
12216        ENDIF
12217C
12218C               ***********************************
12219C               **  STEP 35--                    **
12220C               **  SORT THESE DISTINCT VALUES   **
12221C               **  (IN PLACE).                  **
12222C               ***********************************
12223C
12224CCCCC   CALL SORT(X,NX,X)
12225C
12226C               ******************************************
12227C               **  STEP 36--                           **
12228C               **  CONVERT THE NUMERIC VALUES IN X(.)  **
12229C               **  TO CHARACTER STRINGS.               **
12230C               **  THEN LOAD THESE STRINGS             **
12231C               **  INTO INDIVIDUAL ELEMENTS            **
12232C               **  OF ICHAPA(.)                        **
12233C               **  NOTE--MAX CHARACTERS/STRING = 4     **
12234C               **        MAX NUMBER OF STRINGS = 100   **
12235C               ******************************************
12236C
12237        ISTEPN='36'
12238        IF(IBUGP2.EQ.'ON'.OR.ISUBRO.EQ.'CHAR')
12239     1     CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12240C
12241        IMAX=NX
12242        IF(IMAX+ICHAOF.GT.MAXCHA)IMAX=MAXCHA-ICHAOF
12243        DO3650I=1,IMAX
12244          ICHAPA(I+ICHAOF)=' '
12245          VAL=X(I)
12246          IVAL=INT(VAL+0.5)
12247          IF(VAL.LT.0.0)IVAL=INT(VAL-0.5)
12248          NUMDID=(-1)
12249          CALL DPCON2(IVAL,VAL,ICTEXT,NCTEXT,NUMDID,IBUGP2,IERROR)
12250          JMAX=NCTEXT
12251          IF(JMAX.GT.24)JMAX=24
12252          DO3660J=1,JMAX
12253            ICHAPA(I+ICHAOF)(J:J)=ICTEXT(J)(1:1)
12254 3660     CONTINUE
12255C
12256          IF(IBUGP2.EQ.'ON'.OR.ISUBRO.EQ.'CHAR')THEN
12257            WRITE(ICOUT,3665)I,ICHAOF,ICHAPA(I+ICHAOF)
12258 3665       FORMAT('I,ICHAOF,ICHAPA(I+ICHAOF) = ',2I6,2X,A24)
12259            CALL DPWRST('XXX','BUG ')
12260          ENDIF
12261C
12262 3650   CONTINUE
12263C
12264        IF(IFEEDB.EQ.'ON')THEN
12265          WRITE(ICOUT,999)
12266          CALL DPWRST('XXX','BUG ')
12267          DO3675I=1,IMAX
12268            WRITE(ICOUT,3676)I+ICHAOF,ICHAPA(I+ICHAOF)
12269 3676       FORMAT('CHARACTER ',I6,' HAS JUST BEEN SET TO ',A24)
12270            CALL DPWRST('XXX','BUG ')
12271 3675     CONTINUE
12272        ENDIF
12273        GOTO8000
12274      ELSE
12275        IMAX=NUMARG
12276        IF(MAXCHA.LT.IMAX)IMAX=MAXCHA
12277        DO1155I=1,IMAX
12278          ICHAPA(I)=' '
12279          IF(IHARG(I).EQ.'BOX')THEN
12280            ICHAPA(I)='SQUA'
12281          ELSE
12282CCCCC       ICHAPA(I)(1:4)=IHARLC(I)
12283CCCCC       ICHAPA(I)(5:8)=IHARL2(I)
12284            ISTART=1
12285            ISTOP=IWIDTH
12286            IWORD=I+1
12287            NCCHAR=0
12288            ISTRIN=' '
12289            ISTRCH=' '
12290            DO6007II=1,IWIDTH
12291              ISTRIN(II:II)=IANSLC(II)(1:1)
12292 6007       CONTINUE
12293            CALL DPEXWO(ISTRIN,ISTART,ISTOP,IWORD,
12294     1                  ICOL1,ICOL2,ISTRCH,NCCHAR,
12295     1                  IBUGP2,ISUBRO,IERROR)
12296            IF(NCCHAR.GT.24)NCCHAR=24
12297            ICHAPA(I)=' '
12298            ICHAPA(I)(1:NCCHAR)=ISTRCH(1:NCCHAR)
12299          ENDIF
12300 1155   CONTINUE
12301C
12302        IF(IFEEDB.EQ.'ON')THEN
12303          WRITE(ICOUT,999)
12304          CALL DPWRST('XXX','BUG ')
12305          DO1156I=1,IMAX
12306            WRITE(ICOUT,1126)I,ICHAPA(I)
12307            CALL DPWRST('XXX','BUG ')
12308 1156     CONTINUE
12309        ENDIF
12310        GOTO8000
12311      ENDIF
12312C
12313C               ***********************************************************
12314C               **  STEP 40--                                            **
12315C               **  TREAT THE CHARACTERS ... SUBSET/EXCEPT/FOR CASE      **
12316C               **  FOR REDEFINING SPECIFIED CHARACTERS                  **
12317C               ***********************************************************
12318C
12319C               *****************************************
12320C               **  STEP 41--                          **
12321C               **  DEFINE THE TYPE CASE--             **
12322C               **    1) SUBSET/EXCEPT                 **
12323C               **    2) FOR.                          **
12324C               *****************************************
12325C
12326 4190 CONTINUE
12327C
12328      ISTEPN='41'
12329      IF(IBUGP2.EQ.'ON'.OR.ISUBRO.EQ.'CHAR')
12330     1   CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12331C
12332      ILOCQ=2
12333C
12334      IF(IBUGP2.EQ.'ON'.OR.ISUBRO.EQ.'CHAR')THEN
12335        WRITE(ICOUT,4191)ICASEQ,ILOCQ,NUMARG
12336 4191   FORMAT('ICASEQ,ILOCQ,NUMARG = ',3I8)
12337        CALL DPWRST('XXX','BUG ')
12338      ENDIF
12339C
12340C               *********************************************
12341C               **  STEP 42--                              **
12342C               **  DETERMINE WHICH ELEMENTS ARE           **
12343C               **  TO BE REDEFINED.                       **
12344C               *********************************************
12345C
12346      ISTEPN='42'
12347      IF(IBUGP2.EQ.'ON'.OR.ISUBRO.EQ.'CHAR')
12348     1   CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12349C
12350      NQ=0
12351      IF(ICASEQ.EQ.'SUBS')THEN
12352        NIOLD=MAXCHA
12353        CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR)
12354        NQ=NIOLD
12355      ELSEIF(ICASEQ.EQ.'FOR')THEN
12356        NIOLD=MAXCHA
12357        CALL DPFOR(NIOLD,NFOR,IROW1,IROWN,
12358     1             NLOCAL,ILOCS,NS,IBUGQ,IERROR)
12359        NQ=NFOR
12360      ENDIF
12361C
12362      IF(NQ.LT.1)THEN
12363        WRITE(ICOUT,999)
12364        CALL DPWRST('XXX','BUG ')
12365        WRITE(ICOUT,3351)
12366        CALL DPWRST('XXX','BUG ')
12367        WRITE(ICOUT,4252)
12368 4252   FORMAT('      AFTER THE APPROPRIATE SUBSET HAS BEEN ',
12369     1         'EXTRACTED,')
12370        CALL DPWRST('XXX','BUG ')
12371        WRITE(ICOUT,4253)IHLEFT,IHLEF2
12372 4253   FORMAT('      EXTRACTED, NO CHARACTER ELEMENTS  ',
12373     1         'FROM VARIABLE ',A4,A4)
12374        CALL DPWRST('XXX','BUG ')
12375        WRITE(ICOUT,4254)
12376 4254   FORMAT('      REMAINED TO BE REDEFINED. ')
12377        CALL DPWRST('XXX','BUG ')
12378        WRITE(ICOUT,4255)ICASEQ
12379 4255   FORMAT('ICASEQ = ',A4)
12380        CALL DPWRST('XXX','BUG ')
12381        WRITE(ICOUT,4258)
12382 4258   FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
12383        CALL DPWRST('XXX','BUG ')
12384        IF(IWIDTH.GE.1)THEN
12385          WRITE(ICOUT,4259)(IANS(I),I=1,MIN(80,IWIDTH))
12386 4259     FORMAT('      ',80A1)
12387          CALL DPWRST('XXX','BUG ')
12388        ENDIF
12389        IERROR='YES'
12390        GOTO9000
12391      ENDIF
12392C
12393C               *********************************************
12394C               **  STEP 43--                              **
12395C               **  REDEFINE THE DESIGNATED CHARACTERS.    **
12396C               *********************************************
12397C
12398      ISTEPN='43'
12399      IF(IBUGP2.EQ.'ON'.OR.ISUBRO.EQ.'CHAR')
12400     1   CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12401C
12402      IMAX=MAXCHA
12403      IF(NQ.LT.MAXCHA)IMAX=NQ
12404      DO4310I=1,IMAX
12405        IF(ISUB(I).EQ.0)GOTO4310
12406        ICHAPA(I)=' '
12407CCCCC   ICHAPA(I)(1:4)=IHARLC(1)
12408CCCCC   ICHAPA(I)(5:8)=IHARL2(1)
12409        ISTART=1
12410        ISTOP=IWIDTH
12411        IWORD=2
12412        NCCHAR=0
12413        ISTRIN=' '
12414        ISTRCH=' '
12415        DO6008II=1,IWIDTH
12416          ISTRIN(II:II)=IANSLC(II)(1:1)
12417 6008   CONTINUE
12418        CALL DPEXWO(ISTRIN,ISTART,ISTOP,IWORD,
12419     1              ICOL1,ICOL2,ISTRCH,NCCHAR,
12420     1              IBUGP2,ISUBRO,IERROR)
12421        IF(NCCHAR.GT.24)NCCHAR=24
12422        ICHAPA(I)=' '
12423        ICHAPA(I)(1:NCCHAR)=ISTRCH(1:NCCHAR)
12424 4310 CONTINUE
12425C
12426C               *********************************************
12427C               **  STEP 44--                              **
12428C               **  IF CALLED FOR,                         **
12429C               **  PRINT OUT A MESSAGE.                   **
12430C               *********************************************
12431C
12432      ISTEPN='44'
12433      IF(IBUGP2.EQ.'ON'.OR.ISUBRO.EQ.'CHAR')
12434     1   CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12435C
12436      IF(IFEEDB.EQ.'OFF')THEN
12437        WRITE(ICOUT,999)
12438        CALL DPWRST('XXX','BUG ')
12439        DO4410I=1,IMAX
12440          IF(ISUB(I).EQ.0)GOTO4410
12441          WRITE(ICOUT,4411)I,ICHAPA(I)
12442 4411     FORMAT('CHARACTER ',I6,' HAS JUST BEEN SET TO ',A24)
12443          CALL DPWRST('XXX','BUG ')
12444 4410   CONTINUE
12445      ENDIF
12446      GOTO8000
12447C
12448 8000 CONTINUE
12449      IFOUND='YES'
12450      DO8010I=1,MAXCHA
12451        IF(ICHAPA(I)(1:4).EQ.'BLAN')ICHAPA(I)='BLAN'
12452        IF(ICHAPA(I)(1:4).EQ.'blan')ICHAPA(I)='BLAN'
12453        IF(ICHAPA(I)(1:4).EQ.'NONE')ICHAPA(I)='BLAN'
12454        IF(ICHAPA(I).EQ.'BL')ICHAPA(I)='BLAN'
12455        IF(ICHAPA(I).EQ.'bl')ICHAPA(I)='BLAN'
12456        IF(ICHAPA(I).EQ.'NO')ICHAPA(I)='BLAN'
12457 8010 CONTINUE
12458      GOTO9000
12459C
12460C               *****************
12461C               **  STEP 90--  **
12462C               **  EXIT       **
12463C               *****************
12464C
12465 9000 CONTINUE
12466C
12467      IHYPSW=IHYPSV
12468C
12469      IF(IBUGP2.EQ.'ON' .OR. ISUBRO.EQ.'CHAR')THEN
12470        WRITE(ICOUT,999)
12471        CALL DPWRST('XXX','BUG ')
12472        WRITE(ICOUT,9011)
12473 9011   FORMAT('***** AT THE END       OF DPCHAR--')
12474        CALL DPWRST('XXX','BUG ')
12475        WRITE(ICOUT,9013)IBUGP2,IFOUND,IERROR
12476 9013   FORMAT('IBUGP2,IFOUND,IERROR = ',2(A4,2X),A4)
12477        CALL DPWRST('XXX','BUG ')
12478        WRITE(ICOUT,9014)IMAX,NY,NX,MAXCHA,ICHAOF
12479 9014   FORMAT('IMAX,NY,NX,MAXCHA,ICHAOF = ',5I8)
12480        CALL DPWRST('XXX','BUG ')
12481        IF(NY.GT.0)THEN
12482          DO9023I=1,NY
12483            WRITE(ICOUT,9024)I,Y(I)
12484 9024       FORMAT('I,Y(I) = ',I8,E15.7)
12485            CALL DPWRST('XXX','BUG ')
12486 9023     CONTINUE
12487        ENDIF
12488        IF(NX.GT.0)THEN
12489          DO9033I=1,NX
12490            WRITE(ICOUT,9034)I,X(I),ICHAPA(I)
12491 9034       FORMAT('I,X(I),ICHAPA(I) = ',I8,G15.7,2X,A24)
12492            CALL DPWRST('XXX','BUG ')
12493 9033     CONTINUE
12494        ENDIF
12495      ENDIF
12496C
12497      RETURN
12498      END
12499      SUBROUTINE DPCHCA(IHARG,NUMARG,IDEFCA,MAXCHA,ICHACA,IFOUND,IERROR)
12500C
12501C     PURPOSE--DEFINE PLOT CHARACTER CASES FOR USE IN MULTI-TRACE PLOTS.
12502C              THE CASE FOR THE CHARACTER FOR THE I-TH TRACE
12503C              WILL BE PLACED
12504C              IN THE I-TH ELEMENT OF THE HOLLERITH
12505C              VECTOR ICHACA(.).
12506C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
12507C                     --NUMARG
12508C                     --IDEFCA
12509C                     --MAXCHA
12510C     OUTPUT ARGUMENTS--ICHACA  (A  HOLLERITH VECTOR
12511C                       WHOSE I-TH ELEMENT IS THE CASE
12512C                       FOR THE CHARACTER
12513C                       ASSIGNED TO THE I-TH    TRACE    IN
12514C                       A MULTI-TRACE PLOT.
12515C                     --IFOUND ('YES' OR 'NO' )
12516C                     --IERROR ('YES' OR 'NO' )
12517C     WRITTEN BY--ALAN HECKERT
12518C                 COMPUTER SERVICES DIVISION
12519C                 INFORMATION TECHNOLOGY LABORATORY
12520C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
12521C                 GAITHERSBURG, MD 20899-8980
12522C                 PHONE--301-975-2899
12523C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
12524C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
12525C     LANGUAGE--ANSI FORTRAN (1977)
12526C     VERSION NUMBER--82/7
12527C     ORIGINAL VERSION--DECEMBER  1977.
12528C     UPDATED         --SEPTEMBER 1980.
12529C     UPDATED         --MARCH     1982.
12530C     UPDATED         --MAY       1982.
12531C
12532C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
12533C
12534      CHARACTER*4 IHARG
12535      CHARACTER*4 IDEFCA
12536      CHARACTER*4 ICHACA
12537      CHARACTER*4 IFOUND
12538      CHARACTER*4 IERROR
12539C
12540C---------------------------------------------------------------------
12541C
12542      DIMENSION IHARG(*)
12543      DIMENSION ICHACA(*)
12544C
12545C---------------------------------------------------------------------
12546C
12547      INCLUDE 'DPCOP2.INC'
12548C
12549C-----START POINT-----------------------------------------------------
12550C
12551      IFOUND='NO'
12552      IERROR='NO'
12553C
12554      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'CASE')GOTO1160
12555      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'CASE')GOTO1105
12556      GOTO1199
12557C
12558 1105 CONTINUE
12559      IF(IHARG(NUMARG).EQ.'ON')GOTO1110
12560      IF(IHARG(NUMARG).EQ.'OFF')GOTO1110
12561      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1110
12562      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1110
12563C
12564      IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'ALL')GOTO1160
12565      IF(NUMARG.EQ.2)GOTO1120
12566      IF(NUMARG.GE.3.AND.IHARG(2).EQ.'ALL')GOTO1130
12567      IF(NUMARG.GE.3.AND.IHARG(3).EQ.'ALL')GOTO1140
12568C
12569      GOTO1150
12570C
12571 1110 CONTINUE
12572      DO1115I=1,MAXCHA
12573      ICHACA(I)=IDEFCA
12574 1115 CONTINUE
12575C
12576      IF(IFEEDB.EQ.'OFF')GOTO1119
12577      WRITE(ICOUT,999)
12578  999 FORMAT(1X)
12579      CALL DPWRST('XXX','BUG ')
12580      I=1
12581      WRITE(ICOUT,1116)ICHACA(I)
12582 1116 FORMAT('ALL CHARACTER CASES HAVE JUST BEEN SET TO ',
12583     1A4)
12584      CALL DPWRST('XXX','BUG ')
12585 1119 CONTINUE
12586      GOTO1190
12587C
12588 1120 CONTINUE
12589      ICHACA(1)=IHARG(2)
12590C
12591      IF(IFEEDB.EQ.'OFF')GOTO1129
12592      WRITE(ICOUT,999)
12593      CALL DPWRST('XXX','BUG ')
12594      I=1
12595      WRITE(ICOUT,1126)I,ICHACA(I)
12596 1126 FORMAT('THE CASE FOR CHARACTER ',I6,' HAS JUST BEEN SET TO ',
12597     1A4)
12598      CALL DPWRST('XXX','BUG ')
12599 1129 CONTINUE
12600      GOTO1190
12601C
12602 1130 CONTINUE
12603      DO1135I=1,MAXCHA
12604      ICHACA(I)=IHARG(3)
12605 1135 CONTINUE
12606C
12607      IF(IFEEDB.EQ.'OFF')GOTO1139
12608      WRITE(ICOUT,999)
12609      CALL DPWRST('XXX','BUG ')
12610      I=1
12611      WRITE(ICOUT,1116)ICHACA(I)
12612      CALL DPWRST('XXX','BUG ')
12613 1139 CONTINUE
12614      GOTO1190
12615C
12616 1140 CONTINUE
12617      DO1145I=1,MAXCHA
12618      ICHACA(I)=IHARG(2)
12619 1145 CONTINUE
12620C
12621      IF(IFEEDB.EQ.'OFF')GOTO1149
12622      WRITE(ICOUT,999)
12623      CALL DPWRST('XXX','BUG ')
12624      I=1
12625      WRITE(ICOUT,1116)ICHACA(I)
12626      CALL DPWRST('XXX','BUG ')
12627 1149 CONTINUE
12628      GOTO1190
12629C
12630 1150 CONTINUE
12631      IMAX=NUMARG-1
12632      IF(MAXCHA.LT.IMAX)IMAX=MAXCHA
12633      DO1155I=1,IMAX
12634      IP1=I+1
12635      ICHACA(I)=IHARG(IP1)
12636 1155 CONTINUE
12637C
12638      IF(IFEEDB.EQ.'OFF')GOTO1159
12639      WRITE(ICOUT,999)
12640      CALL DPWRST('XXX','BUG ')
12641      DO1156I=1,IMAX
12642      WRITE(ICOUT,1126)I,ICHACA(I)
12643      CALL DPWRST('XXX','BUG ')
12644 1156 CONTINUE
12645 1159 CONTINUE
12646      GOTO1190
12647C
12648 1160 CONTINUE
12649      DO1165I=1,MAXCHA
12650      ICHACA(I)=IDEFCA
12651 1165 CONTINUE
12652C
12653      IF(IFEEDB.EQ.'OFF')GOTO1169
12654      WRITE(ICOUT,999)
12655      CALL DPWRST('XXX','BUG ')
12656      I=1
12657      WRITE(ICOUT,1116)ICHACA(I)
12658      CALL DPWRST('XXX','BUG ')
12659 1169 CONTINUE
12660      GOTO1190
12661C
12662 1190 CONTINUE
12663      IFOUND='YES'
12664C
12665 1199 CONTINUE
12666      RETURN
12667      END
12668      SUBROUTINE DPCHCL(IHARG,NUMARG,IDEFCO,MAXCHA,ICHACO,IFOUND,IERROR)
12669C
12670C     PURPOSE--DEFINE PLOT CHARACTER COLORS FOR USE IN MULTI-TRACE PLOTS.
12671C              THE COLOR FOR THE CHARACTER FOR THE I-TH TRACE
12672C              WILL BE PLACED
12673C              IN THE I-TH ELEMENT OF THE HOLLERITH
12674C              VECTOR ICHACO(.).
12675C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
12676C                     --NUMARG
12677C                     --IDEFCO
12678C                     --MAXCHA
12679C     OUTPUT ARGUMENTS--ICHACO  (A  HOLLERITH VECTOR
12680C                       WHOSE I-TH ELEMENT IS THE COLOR
12681C                       FOR THE CHARACTER
12682C                       ASSIGNED TO THE I-TH    TRACE    IN
12683C                       A MULTI-TRACE PLOT.
12684C                     --IFOUND ('YES' OR 'NO' )
12685C                     --IERROR ('YES' OR 'NO' )
12686C     WRITTEN BY--JAMES J. FILLIBEN
12687C                 STATISTICAL ENGINEERING DIVISION
12688C                 INFORMATION TECHNOLOGY LABORATORY
12689C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
12690C                 GAITHERSBURG, MD 20899-8980
12691C                 PHONE--301-975-2899
12692C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
12693C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
12694C     LANGUAGE--ANSI FORTRAN (1977)
12695C     VERSION NUMBER--82/7
12696C     ORIGINAL VERSION--DECEMBER  1977.
12697C     UPDATED         --SEPTEMBER 1980.
12698C     UPDATED         --MARCH     1982.
12699C     UPDATED         --MAY       1982.
12700C
12701C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
12702C
12703      CHARACTER*4 IHARG
12704      CHARACTER*4 IDEFCO
12705      CHARACTER*4 ICHACO
12706      CHARACTER*4 IFOUND
12707      CHARACTER*4 IERROR
12708C
12709C---------------------------------------------------------------------
12710C
12711      DIMENSION IHARG(*)
12712      DIMENSION ICHACO(*)
12713C
12714C---------------------------------------------------------------------
12715C
12716      INCLUDE 'DPCOP2.INC'
12717C
12718C-----START POINT-----------------------------------------------------
12719C
12720      IFOUND='NO'
12721      IERROR='NO'
12722C
12723      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'COLO')GOTO1160
12724      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'COLO')GOTO1105
12725      GOTO1199
12726C
12727 1105 CONTINUE
12728      IF(IHARG(NUMARG).EQ.'ON')GOTO1110
12729      IF(IHARG(NUMARG).EQ.'OFF')GOTO1110
12730      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1110
12731      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1110
12732C
12733      IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'ALL')GOTO1160
12734      IF(NUMARG.EQ.2)GOTO1120
12735      IF(NUMARG.GE.3.AND.IHARG(2).EQ.'ALL')GOTO1130
12736      IF(NUMARG.GE.3.AND.IHARG(3).EQ.'ALL')GOTO1140
12737C
12738      GOTO1150
12739C
12740 1110 CONTINUE
12741      DO1115I=1,MAXCHA
12742      ICHACO(I)=IDEFCO
12743 1115 CONTINUE
12744C
12745      IF(IFEEDB.EQ.'OFF')GOTO1119
12746      WRITE(ICOUT,999)
12747  999 FORMAT(1X)
12748      CALL DPWRST('XXX','BUG ')
12749      I=1
12750      WRITE(ICOUT,1116)ICHACO(I)
12751 1116 FORMAT('ALL CHARACTER COLORS HAVE JUST BEEN SET TO ',
12752     1A4)
12753      CALL DPWRST('XXX','BUG ')
12754 1119 CONTINUE
12755      GOTO1190
12756C
12757 1120 CONTINUE
12758      ICHACO(1)=IHARG(2)
12759C
12760      IF(IFEEDB.EQ.'OFF')GOTO1129
12761      WRITE(ICOUT,999)
12762      CALL DPWRST('XXX','BUG ')
12763      I=1
12764      WRITE(ICOUT,1126)I,ICHACO(I)
12765 1126 FORMAT('THE COLOR FOR CHARACTER ',I6,' HAS JUST BEEN SET TO ',
12766     1A4)
12767      CALL DPWRST('XXX','BUG ')
12768 1129 CONTINUE
12769      GOTO1190
12770C
12771 1130 CONTINUE
12772      DO1135I=1,MAXCHA
12773      ICHACO(I)=IHARG(3)
12774 1135 CONTINUE
12775C
12776      IF(IFEEDB.EQ.'OFF')GOTO1139
12777      WRITE(ICOUT,999)
12778      CALL DPWRST('XXX','BUG ')
12779      I=1
12780      WRITE(ICOUT,1116)ICHACO(I)
12781      CALL DPWRST('XXX','BUG ')
12782 1139 CONTINUE
12783      GOTO1190
12784C
12785 1140 CONTINUE
12786      DO1145I=1,MAXCHA
12787      ICHACO(I)=IHARG(2)
12788 1145 CONTINUE
12789C
12790      IF(IFEEDB.EQ.'OFF')GOTO1149
12791      WRITE(ICOUT,999)
12792      CALL DPWRST('XXX','BUG ')
12793      I=1
12794      WRITE(ICOUT,1116)ICHACO(I)
12795      CALL DPWRST('XXX','BUG ')
12796 1149 CONTINUE
12797      GOTO1190
12798C
12799 1150 CONTINUE
12800      IMAX=NUMARG-1
12801      IF(MAXCHA.LT.IMAX)IMAX=MAXCHA
12802      DO1155I=1,IMAX
12803      IP1=I+1
12804      ICHACO(I)=IHARG(IP1)
12805 1155 CONTINUE
12806C
12807      IF(IFEEDB.EQ.'OFF')GOTO1159
12808      WRITE(ICOUT,999)
12809      CALL DPWRST('XXX','BUG ')
12810      DO1156I=1,IMAX
12811      WRITE(ICOUT,1126)I,ICHACO(I)
12812      CALL DPWRST('XXX','BUG ')
12813 1156 CONTINUE
12814 1159 CONTINUE
12815      GOTO1190
12816C
12817 1160 CONTINUE
12818      DO1165I=1,MAXCHA
12819      ICHACO(I)=IDEFCO
12820 1165 CONTINUE
12821C
12822      IF(IFEEDB.EQ.'OFF')GOTO1169
12823      WRITE(ICOUT,999)
12824      CALL DPWRST('XXX','BUG ')
12825      I=1
12826      WRITE(ICOUT,1116)ICHACO(I)
12827      CALL DPWRST('XXX','BUG ')
12828 1169 CONTINUE
12829      GOTO1190
12830C
12831 1190 CONTINUE
12832      IFOUND='YES'
12833C
12834 1199 CONTINUE
12835      RETURN
12836      END
12837      SUBROUTINE DPCHEC(K,IHOL,IHOL2,
12838     1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,
12839     1INT1,FLOAT1,IBUGA3,IERROR)
12840C
12841C     PURPOSE--EXAMINE COMPONENT K OF IHOL(.) AND IHOL2(.).
12842C     IF IT IS A PARAMETER NAME, DETERMINE THE VALUE
12843C     OF THE PARAMETER AND PLACE THIS VALUE
12844C     IN INT1(K) AND FLOAT1(K).
12845C     IF OTHERWISE, DO NOTHING.
12846C     WRITTEN BY--JAMES J. FILLIBEN
12847C                 STATISTICAL ENGINEERING DIVISION
12848C                 INFORMATION TECHNOLOGY LABORATORY
12849C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
12850C                 GAITHERSBURG, MD 20899-8980
12851C                 PHONE--301-975-2899
12852C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
12853C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
12854C     LANGUAGE--ANSI FORTRAN (1977)
12855C     VERSION NUMBER--82/7
12856C     ORIGINAL VERSION--JANUARY   1982.
12857C     UPDATED         --MAY       1982.
12858C
12859C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
12860C
12861      CHARACTER*4 IHOL
12862      CHARACTER*4 IHOL2
12863      CHARACTER*4 IHNAME
12864      CHARACTER*4 IHNAM2
12865      CHARACTER*4 IUSE
12866      CHARACTER*4 IBUGA3
12867      CHARACTER*4 IERROR
12868C
12869      CHARACTER*4 IH
12870      CHARACTER*4 IH2
12871C
12872C---------------------------------------------------------------------
12873C
12874      DIMENSION IHOL(*)
12875      DIMENSION IHOL2(*)
12876C
12877      DIMENSION IHNAME(*)
12878      DIMENSION IHNAM2(*)
12879      DIMENSION IUSE(*)
12880      DIMENSION IVALUE(*)
12881      DIMENSION VALUE(*)
12882C
12883      DIMENSION INT1(*)
12884      DIMENSION FLOAT1(*)
12885C
12886C---------------------------------------------------------------------
12887C
12888      INCLUDE 'DPCOP2.INC'
12889C
12890C-----START POINT-----------------------------------------------------
12891C
12892      IERROR='NO'
12893C
12894      IF(IBUGA3.EQ.'OFF')GOTO90
12895      WRITE(ICOUT,999)
12896  999 FORMAT(1X)
12897      CALL DPWRST('XXX','BUG ')
12898      WRITE(ICOUT,51)
12899   51 FORMAT('****** AT THE BEGINNING OF DPCHEC--')
12900      CALL DPWRST('XXX','BUG ')
12901      WRITE(ICOUT,52)K,IHOL(K),IHOL2(K)
12902   52 FORMAT('K,IHOL(K),IHOL2(K) = ',I8,2X,A4,2X,A4)
12903      CALL DPWRST('XXX','BUG ')
12904      WRITE(ICOUT,53)NUMNAM,IBUGA3,IERROR
12905   53 FORMAT('NUMNAM,IBUGA3,IERROR = ',I8,2X,A4,2X,A4)
12906      CALL DPWRST('XXX','BUG ')
12907      DO55I=1,NUMNAM
12908      WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVALUE(I),VALUE(I)
12909   56 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVALUE(I),VALUE(I) = ',
12910     1I8,2X,A4,2X,A4,2X,A4,I8,E15.7)
12911      CALL DPWRST('XXX','BUG ')
12912   55 CONTINUE
12913      WRITE(ICOUT,57)K,INT1(K),FLOAT1(K)
12914   57 FORMAT('K,INT1(K),FLOAT1(K) = ',I8,I8,E15.7)
12915      CALL DPWRST('XXX','BUG ')
12916   90 CONTINUE
12917C
12918      IH=IHOL(K)
12919      IH2=IHOL2(K)
12920      IF(NUMNAM.LE.0)GOTO2799
12921      DO2795I=1,NUMNAM
12922      IF(IH.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I).AND.
12923     1IUSE(I).EQ.'P')GOTO2796
12924      GOTO2795
12925 2796 CONTINUE
12926      INT1(K)=IVALUE(I)
12927      FLOAT1(K)=VALUE(I)
12928      GOTO2799
12929 2795 CONTINUE
12930 2799 CONTINUE
12931C
12932C               *****************
12933C               **  STEP 90--  **
12934C               **  EXIT.      **
12935C               *****************
12936C
12937      IF(IBUGA3.EQ.'OFF')GOTO9090
12938      WRITE(ICOUT,999)
12939      CALL DPWRST('XXX','BUG ')
12940      WRITE(ICOUT,9011)
12941 9011 FORMAT('****** AT THE END       OF DPCHEC--')
12942      CALL DPWRST('XXX','BUG ')
12943      WRITE(ICOUT,9012)K,IHOL(K),IHOL2(K)
12944 9012 FORMAT('K,IHOL(K),IHOL2(K) = ',I8,2X,A4,2X,A4)
12945      CALL DPWRST('XXX','BUG ')
12946      WRITE(ICOUT,9013)NUMNAM,IBUGA3,IERROR
12947 9013 FORMAT('NUMNAM,IBUGA3,IERROR = ',I8,2X,A4,2X,A4)
12948      CALL DPWRST('XXX','BUG ')
12949      DO9015I=1,NUMNAM
12950      WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),IVALUE(I),VALUE(I)
12951 9016 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVALUE(I),VALUE(I) = ',
12952     1I8,2X,A4,2X,A4,2X,A4,I8,E15.7)
12953      CALL DPWRST('XXX','BUG ')
12954 9015 CONTINUE
12955      WRITE(ICOUT,9017)K,INT1(K),FLOAT1(K)
12956 9017 FORMAT('K,INT1(K),FLOAT1(K) = ',I8,I8,E15.7)
12957      CALL DPWRST('XXX','BUG ')
12958 9090 CONTINUE
12959C
12960      RETURN
12961      END
12962      SUBROUTINE DPCHEX(ISTAR1,ILEN1,IX1,ISTAR2,ILEN2,IX2)
12963C
12964C     PURPOSE--CHARACTER EXTRACTION--
12965C              GIVEN A CHARACTER STRING IN A WORD (IX1),
12966C              MOVE THE BIT STRING WHICH STARTS IN BIT ISTAR1
12967C              (ISTAR1 RANGES FROM 0 TO 35 IN A UNIVAC 1108,
12968C                                  0 TO 31 IN AN IBM 3033,
12969C                                  0 TO 59 IN A CDC 7600, ETC.
12970C              AND IS OF LENGTH ILEN1 BITS)
12971C              INTO BITS STARTING AT ISTAR2 OF LENGTH ILEN2
12972C              (HERE ILEN2 USUALLY = ILEN1) IN THE WORD IX2.
12973C              OUTPUT THE NEW CHARACTER VARIABLE (IX2).
12974C     NOTE--0 DENOTES THE LEFT-MOST (THAT IS, THE HIGH-ORDER) BIT.
12975C     NOTE--ISTAR1 AND ISTAR2 RANGE FROM 0 TO NUMBPW-1
12976C           THAT IS, FROM 0 TO ONE LESS THAN THE TOTLA NUMBER OF BITS PER WORD.
12977C           (FOR EXAMPLE, ON UNIVAC 1100/82--FROM 0 TO 35
12978C                         ON VAX    11/780 --FROM 0 TO 31)
12979C     NOTE--IX1 AND IX2 ARE CHARACTER*4 VARIABLES.
12980C     NOTE--THIS SUBROUTINE HAS BEEN CONSTRAINED SO THAT
12981C           NEITHER ILEN1 NOR ILEN2 ARE EXPLICITELY USED.
12982C           THIS SUBROUTINE, AS CODED, OPERATES ON THE ASSUMPTIONS THAT
12983C              1) ILEN1 = NUMBPC (THAT IS, THE LENGTH
12984C                 OF THE BIT STRING BEING MOVED IS IDENTICAL
12985C                 TO THE NUMBER OF BITS PER CHARACTER ON
12986C                 YOUR COMPUTER).
12987C              2) ILEN2 = ILEN1 (THAT IS, THE LENGTH OF THE OUTPUT STRING =
12988C                 THE LENGTH OF THE INPUT STRING),
12989C              3) ISTAR1 IS SUCH THAT THE START OF THE BIT STRING
12990C                 IS ALWAYS AT THE BEGINNING OF A CHARACTER
12991C           THE NET RESULT IS THAT THIS SUBROUTINE, AS CODED,
12992C           EXTRACTS EXACTLY 1 CHARACTER AND
12993C           MOVES IT TO THE POSITION OF ANOTHER CHARACTER.
12994C           THESE CONSTRAINTS WILL BE ACCEPTABLE FOR ALL USES
12995C           OF THIS SUBROUTINE BY ANY OTHER DATAPLOT SUBROUTINE.
12996C     NOTE--THE VALUES FOR NUMBPC (NUMBER OF BITS PER CHARACTER)
12997C           AND NUMBPW (NUMBER OF BITS PER WORD) ARE SET
12998C           FOR YOUR COMPUTER IN DATAPLOT SUBROUTINE INITMC.
12999C     NOTE--ALGORITHM PROVIDED BY MICHAEL VOGT
13000C                                 INFORMATION TECHNOLOGY LABORATORY
13001C                                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
13002C
13003C     WRITTEN BY--JAMES J. FILLIBEN
13004C                 STATISTICAL ENGINEERING DIVISION
13005C                 INFORMATION TECHNOLOGY LABORATORY
13006C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
13007C                 GAITHERSBURG, MD 20899-8980
13008C                 PHONE--301-975-2899
13009C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
13010C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
13011C     LANGUAGE--ANSI FORTRAN (1977)
13012C     VERSION NUMBER--82/7
13013C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--OCTOBER  1978.
13014C     UPDATED         --JUNE      1981.
13015C     UPDATED         --OCTOBER   1981.
13016C     UPDATED         --MAY       1982.
13017C
13018C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
13019C
13020      CHARACTER*4 IX1
13021      CHARACTER*4 IX2
13022C
13023C---------------------------------------------------------------------
13024C
13025C---------------------------------------------------------------------
13026C
13027      INCLUDE 'DPCOBE.INC'
13028      INCLUDE 'DPCOP2.INC'
13029C
13030C-----START POINT-----------------------------------------------------
13031C
13032C               ********************************************************
13033C               **  THE FOLLOWING CODE WILL CARRY OUT                 **
13034C               **  THE CHARACTER EXTRACTION FOR ALL COMPUTERS        **
13035C               **  WITH AN ANSI 77 FORTRAN COMPILER--IT MAKES        **
13036C               **  USE OF THE ANSI FORTRAN 77 CONSTRUCT--            **
13037C               **  IY(IC:ID)=IX(IA:IB)                               **
13038C               **  WHERE IX AND IY ARE CHARACTER*4 VARIABLES,        **
13039C               **  WHERE IA, IB, IC, AND ID ARE INTEGER VARIABLES,   **
13040C               **  AND WHERE IY(IC:ID)=IX(IA:IB) MEANS               **
13041C               **  TO COPY CHARACTERS IA THROUGH IB OF VARIABLE IX AND
13042C               **  PLACE THEM INTO CHARACTERS IC THROUGH ID OF VARIABLE IY.
13043C               **  WITH ALL OTHER CHARACTERS IN IY BEING UNAFFECTED. **
13044C               **  USUALLY IA, IB, IC, AND ID RANGE FROM 1 TO 4.     **
13045C               ********************************************************
13046C
13047      IF(ISUBG4.EQ.'CHEX')THEN
13048        WRITE(ICOUT,51)ISTAR1,ILEN1,IX1,ISTAR2,ILEN2,IX2
13049   51   FORMAT('FROM DPCHEX: ISTAR1,ILEN1,IX1,ISTAR2,ILEN2,IX2 = ',6I5)
13050        CALL DPWRST('XXX','BUG ')
13051      ENDIF
13052C
13053      IBYTE1=(ISTAR1+NUMBPC)/NUMBPC
13054      IBYTE2=(ISTAR2+NUMBPC)/NUMBPC
13055      IX2(IBYTE2:IBYTE2)=IX1(IBYTE1:IBYTE1)
13056      GOTO9000
13057C
13058C               ****************************************************************
13059C               **  CHARACTER EXTRACTION FOR THE UNIVAC 1100 SERIES. FOR COMPILE
13060C               **  (FORTRAN 1966 COMPILER)
13061C               ****************************************************************
13062C
13063CCCCC ISTAR1=IABS(ISTAR1)
13064CCCCC ISTAR2=IABS(ISTAR2)
13065C
13066CCCCC FLD(ISTAR2,ILEN2,IX2)=FLD(ISTAR1,ILEN1,IX1)
13067C
13068C               ****************************************************************
13069C               **  CHARACTER EXTRACTION FOR THE UNIVAC 1100 SERIES. FTN COMPILE
13070C               **  (FORTRAN 1977 COMPILER)
13071C               ****************************************************************
13072C
13073CCCCC ISTR1P=ISTAR1+1
13074CCCCC ISTR2P=ISTAR2+1
13075C
13076CCCCC BITS(IX2,ISTR2P,ILEN2)=BITS(IX1,ISTR1P,ILEN1)
13077C
13078C               ***********************************************
13079C               **  CHARACTER EXTRACTION FOR THE VAX-11/780  **
13080C               **  (FORTRAN 1966 COMPILER)
13081C               ***********************************************
13082C
13083CCCCC LOGICAL*1 IX1(4)
13084CCCCC LOGICAL*1 IX2(4)
13085C
13086CCCCC I1=(ISTAR1+8)/8
13087CCCCC I2=(ISTAR2+8)/8
13088CCCCC IX2(I2)=IX1(I1)
13089C
13090C               *****************
13091C               **  STEP 90--  **
13092C               **  EXIT       **
13093C               *****************
13094C
13095 9000 CONTINUE
13096      RETURN
13097      END
13098      SUBROUTINE DPCHFI(IHARG,NUMARG,IDEFFI,MAXCHA,ICHAFI,IFOUND,IERROR)
13099C
13100C     PURPOSE--DEFINE PLOT CHARACTER FILL SWITCH FOR USE IN MULTI-TRACE PLOTS.
13101C              THE FILL SWITCH FOR THE CHARACTER FOR THE I-TH TRACE
13102C              WILL BE PLACED
13103C              IN THE I-TH ELEMENT OF THE HOLLERITH
13104C              VECTOR ICHAFI(.).
13105C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
13106C                     --NUMARG
13107C                     --IDEFFI
13108C                     --MAXCHA
13109C     OUTPUT ARGUMENTS--ICHAFI  (A  HOLLERITH VECTOR
13110C                       WHOSE I-TH ELEMENT IS THE FILL SWITCH
13111C                       FOR THE CHARACTER
13112C                       ASSIGNED TO THE I-TH    TRACE    IN
13113C                       A MULTI-TRACE PLOT.
13114C                     --IFOUND ('YES' OR 'NO' )
13115C                     --IERROR ('YES' OR 'NO' )
13116C     WRITTEN BY--JAMES J. FILLIBEN
13117C                 STATISTICAL ENGINEERING DIVISION
13118C                 INFORMATION TECHNOLOGY LABORATORY
13119C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
13120C                 GAITHERSBURG, MD 20899-8980
13121C                 PHONE--301-975-2899
13122C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
13123C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
13124C     LANGUAGE--ANSI FORTRAN (1977)
13125C     VERSION NUMBER--82/7
13126C     ORIGINAL VERSION--DECEMBER  1977.
13127C     UPDATED         --SEPTEMBER 1980.
13128C     UPDATED         --MARCH     1982.
13129C     UPDATED         --MAY       1982.
13130C     UPDATED         --JUNE      1998. CHECK FOR CHARCTER FILL COLOR
13131C                                       (SKIP IF ABOVE FOUND)
13132C
13133C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
13134C
13135      CHARACTER*4 IHARG
13136      CHARACTER*4 IDEFFI
13137      CHARACTER*4 ICHAFI
13138      CHARACTER*4 IFOUND
13139      CHARACTER*4 IERROR
13140C
13141C---------------------------------------------------------------------
13142C
13143      DIMENSION IHARG(*)
13144      DIMENSION ICHAFI(*)
13145C
13146C---------------------------------------------------------------------
13147C
13148      INCLUDE 'DPCOP2.INC'
13149C
13150C-----START POINT-----------------------------------------------------
13151C
13152      IFOUND='NO'
13153      IERROR='NO'
13154C
13155      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'FILL')GOTO1160
13156      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'FILL')GOTO1105
13157      GOTO1199
13158C
13159 1105 CONTINUE
13160CCCCC IF(IHARG(NUMARG).EQ.'ON')GOTO1110
13161CCCCC IF(IHARG(NUMARG).EQ.'OFF')GOTO1110
13162      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1110
13163      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1110
13164CCCCC ADD FOLLOWING LINE  JUNE 1998
13165      IF(IHARG(NUMARG).EQ.'COLO')GOTO1199
13166C
13167      IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'ALL')GOTO1160
13168      IF(NUMARG.EQ.2)GOTO1120
13169      IF(NUMARG.GE.3.AND.IHARG(2).EQ.'ALL')GOTO1130
13170      IF(NUMARG.GE.3.AND.IHARG(3).EQ.'ALL')GOTO1140
13171C
13172      GOTO1150
13173C
13174 1110 CONTINUE
13175      DO1115I=1,MAXCHA
13176      ICHAFI(I)=IDEFFI
13177      IF(IHARG(NUMARG).EQ.'ON')ICHAFI(I)='ON'
13178      IF(IHARG(NUMARG).EQ.'OFF')ICHAFI(I)='OFF'
13179      IF(IHARG(NUMARG).EQ.'AUTO')ICHAFI(I)='ON'
13180 1115 CONTINUE
13181C
13182      IF(IFEEDB.EQ.'OFF')GOTO1119
13183      WRITE(ICOUT,999)
13184  999 FORMAT(1X)
13185      CALL DPWRST('XXX','BUG ')
13186      I=1
13187      WRITE(ICOUT,1116)ICHAFI(I)
13188 1116 FORMAT('ALL CHARACTER FILL SWITCHES HAVE JUST BEEN SET TO ',
13189     1A4)
13190      CALL DPWRST('XXX','BUG ')
13191 1119 CONTINUE
13192      GOTO1190
13193C
13194 1120 CONTINUE
13195      ICHAFI(1)=IHARG(2)
13196C
13197      IF(IFEEDB.EQ.'OFF')GOTO1129
13198      WRITE(ICOUT,999)
13199      CALL DPWRST('XXX','BUG ')
13200      I=1
13201      WRITE(ICOUT,1126)I,ICHAFI(I)
13202 1126 FORMAT('THE FILL SWITCH FOR CHARACTER ',I6,
13203     1' HAS JUST BEEN SET TO ',A4)
13204      CALL DPWRST('XXX','BUG ')
13205 1129 CONTINUE
13206      GOTO1190
13207C
13208 1130 CONTINUE
13209      DO1135I=1,MAXCHA
13210      ICHAFI(I)=IHARG(3)
13211 1135 CONTINUE
13212C
13213      IF(IFEEDB.EQ.'OFF')GOTO1139
13214      WRITE(ICOUT,999)
13215      CALL DPWRST('XXX','BUG ')
13216      I=1
13217      WRITE(ICOUT,1116)ICHAFI(I)
13218      CALL DPWRST('XXX','BUG ')
13219 1139 CONTINUE
13220      GOTO1190
13221C
13222 1140 CONTINUE
13223      DO1145I=1,MAXCHA
13224      ICHAFI(I)=IHARG(2)
13225 1145 CONTINUE
13226C
13227      IF(IFEEDB.EQ.'OFF')GOTO1149
13228      WRITE(ICOUT,999)
13229      CALL DPWRST('XXX','BUG ')
13230      I=1
13231      WRITE(ICOUT,1116)ICHAFI(I)
13232      CALL DPWRST('XXX','BUG ')
13233 1149 CONTINUE
13234      GOTO1190
13235C
13236 1150 CONTINUE
13237      IMAX=NUMARG-1
13238      IF(MAXCHA.LT.IMAX)IMAX=MAXCHA
13239      DO1155I=1,IMAX
13240      IP1=I+1
13241      ICHAFI(I)=IHARG(IP1)
13242 1155 CONTINUE
13243C
13244      IF(IFEEDB.EQ.'OFF')GOTO1159
13245      WRITE(ICOUT,999)
13246      CALL DPWRST('XXX','BUG ')
13247      DO1156I=1,IMAX
13248      WRITE(ICOUT,1126)I,ICHAFI(I)
13249      CALL DPWRST('XXX','BUG ')
13250 1156 CONTINUE
13251 1159 CONTINUE
13252      GOTO1190
13253C
13254 1160 CONTINUE
13255      DO1165I=1,MAXCHA
13256      ICHAFI(I)=IDEFFI
13257      IF(IHARG(1).EQ.'ON')ICHAFI(I)='ON'
13258      IF(IHARG(1).EQ.'OFF')ICHAFI(I)='OFF'
13259      IF(IHARG(1).EQ.'AUTO')ICHAFI(I)='ON'
13260      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'FILL')ICHAFI(I)='ON'
13261 1165 CONTINUE
13262C
13263      IF(IFEEDB.EQ.'OFF')GOTO1169
13264      WRITE(ICOUT,999)
13265      CALL DPWRST('XXX','BUG ')
13266      I=1
13267      WRITE(ICOUT,1116)ICHAFI(I)
13268      CALL DPWRST('XXX','BUG ')
13269 1169 CONTINUE
13270      GOTO1190
13271C
13272 1190 CONTINUE
13273      IFOUND='YES'
13274C
13275 1199 CONTINUE
13276      RETURN
13277      END
13278      SUBROUTINE DPCHFO(IHARG,NUMARG,IDEFFO,MAXCHA,ICHAFO,IFOUND,IERROR)
13279C
13280C     PURPOSE--DEFINE PLOT CHARACTER FONTS FOR USE IN MULTI-TRACE PLOTS.
13281C              THE FONT FOR THE CHARACTER FOR THE I-TH TRACE
13282C              WILL BE PLACED
13283C              IN THE I-TH ELEMENT OF THE HOLLERITH
13284C              VECTOR ICHAFO(.).
13285C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
13286C                     --NUMARG
13287C                     --IDEFFO
13288C                     --MAXCHA
13289C     OUTPUT ARGUMENTS--ICHAFO  (A  HOLLERITH VECTOR
13290C                       WHOSE I-TH ELEMENT IS THE FONT
13291C                       FOR THE CHARACTER
13292C                       ASSIGNED TO THE I-TH    TRACE    IN
13293C                       A MULTI-TRACE PLOT.
13294C                     --IFOUND ('YES' OR 'NO' )
13295C                     --IERROR ('YES' OR 'NO' )
13296C     WRITTEN BY--ALAN HECKERT
13297C                 COMPUTER SERVICES DIVISION
13298C                 INFORMATION TECHNOLOGY LABORATORY
13299C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
13300C                 GAITHERSBURG, MD 20899-8980
13301C                 PHONE--301-975-2899
13302C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
13303C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
13304C     LANGUAGE--ANSI FORTRAN (1977)
13305C     VERSION NUMBER--82/7
13306C     ORIGINAL VERSION--DECEMBER  1977.
13307C     UPDATED         --SEPTEMBER 1980.
13308C     UPDATED         --MARCH     1982.
13309C     UPDATED         --MAY       1982.
13310C
13311C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
13312C
13313      CHARACTER*4 IHARG
13314      CHARACTER*4 IDEFFO
13315      CHARACTER*4 ICHAFO
13316      CHARACTER*4 IFOUND
13317      CHARACTER*4 IERROR
13318C
13319C---------------------------------------------------------------------
13320C
13321      DIMENSION IHARG(*)
13322      DIMENSION ICHAFO(*)
13323C
13324C---------------------------------------------------------------------
13325C
13326      INCLUDE 'DPCOP2.INC'
13327C
13328C-----START POINT-----------------------------------------------------
13329C
13330      IFOUND='NO'
13331      IERROR='NO'
13332C
13333      IF((NUMARG.EQ.1.AND.IHARG(1).EQ.'FONT') .OR.
13334     1   (NUMARG.EQ.2.AND.IHARG(2).EQ.'ALL'))THEN
13335        DO1165I=1,MAXCHA
13336          ICHAFO(I)=IDEFFO
13337 1165   CONTINUE
13338C
13339        IF(IFEEDB.EQ.'ON')THEN
13340          WRITE(ICOUT,999)
13341          CALL DPWRST('XXX','BUG ')
13342          I=1
13343          WRITE(ICOUT,1116)ICHAFO(I)
13344          CALL DPWRST('XXX','BUG ')
13345        ENDIF
13346      ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'FONT')THEN
13347        IF(IHARG(NUMARG).EQ.'ON'   .OR. IHARG(NUMARG).EQ.'OFF' .OR.
13348     1     IHARG(NUMARG).EQ.'AUTO' .OR. IHARG(NUMARG).EQ.'DEFA')THEN
13349          DO1115I=1,MAXCHA
13350            ICHAFO(I)=IDEFFO
13351 1115     CONTINUE
13352C
13353          IF(IFEEDB.EQ.'ON')THEN
13354            WRITE(ICOUT,999)
13355  999       FORMAT(1X)
13356            CALL DPWRST('XXX','BUG ')
13357            I=1
13358            WRITE(ICOUT,1116)ICHAFO(I)
13359 1116       FORMAT('ALL CHARACTER FONTS HAVE JUST BEEN SET TO ',A4)
13360            CALL DPWRST('XXX','BUG ')
13361          ENDIF
13362        ELSEIF(NUMARG.EQ.2)THEN
13363          ICHAFO(1)=IHARG(2)
13364C
13365          IF(IFEEDB.EQ.'ON')THEN
13366            WRITE(ICOUT,999)
13367            CALL DPWRST('XXX','BUG ')
13368            I=1
13369            WRITE(ICOUT,1126)I,ICHAFO(I)
13370 1126       FORMAT('THE FONT FOR CHARACTER ',I6,
13371     1             ' HAS JUST BEEN SET TO ',A4)
13372            CALL DPWRST('XXX','BUG ')
13373          ENDIF
13374        ELSEIF(NUMARG.GE.3.AND.IHARG(2).EQ.'ALL')THEN
13375          DO1135I=1,MAXCHA
13376            ICHAFO(I)=IHARG(3)
13377 1135     CONTINUE
13378C
13379          IF(IFEEDB.EQ.'ON')THEN
13380            WRITE(ICOUT,999)
13381            CALL DPWRST('XXX','BUG ')
13382            I=1
13383            WRITE(ICOUT,1116)ICHAFO(I)
13384            CALL DPWRST('XXX','BUG ')
13385          ENDIF
13386        ELSEIF(NUMARG.GE.3.AND.IHARG(3).EQ.'ALL')THEN
13387          DO1145I=1,MAXCHA
13388            ICHAFO(I)=IHARG(2)
13389 1145     CONTINUE
13390C
13391          IF(IFEEDB.EQ.'ON')THEN
13392            WRITE(ICOUT,999)
13393            CALL DPWRST('XXX','BUG ')
13394            I=1
13395            WRITE(ICOUT,1116)ICHAFO(I)
13396            CALL DPWRST('XXX','BUG ')
13397          ENDIF
13398C
13399        ELSE
13400          IMAX=NUMARG-1
13401          IF(MAXCHA.LT.IMAX)IMAX=MAXCHA
13402          DO1155I=1,IMAX
13403            IP1=I+1
13404            ICHAFO(I)=IHARG(IP1)
13405 1155     CONTINUE
13406C
13407          IF(IFEEDB.EQ.'ON')THEN
13408            WRITE(ICOUT,999)
13409            CALL DPWRST('XXX','BUG ')
13410            DO1156I=1,IMAX
13411              WRITE(ICOUT,1126)I,ICHAFO(I)
13412              CALL DPWRST('XXX','BUG ')
13413 1156       CONTINUE
13414          ENDIF
13415        ENDIF
13416      ENDIF
13417C
13418      IFOUND='YES'
13419C
13420      RETURN
13421      END
13422      SUBROUTINE DPCHGR(ICHAR2,ICHARN,IBUG,IFOUND)
13423C
13424C     PURPOSE--NUMERICALLY CONVERT A GREEK ALPHABETIC CHARACTER.
13425C              CONVERT A PACKED ALPHABETIC STRING
13426C              (PACKED INTO 1 COMPUTER WORD
13427C              WITH ONLY THE FIRST 4 CHARACTERS BEING SIGNIFICANT)
13428C              (ALPH... TO OMEG...) INTO A NUMERIC VALUE
13429C              (1 TO 24).
13430C     INPUT  ARGUMENTS--ICHAR2 (A HOLLERITH VARIABLE
13431C                              CONTAINING THE HOLLERITH
13432C                              CHARACTER(S) OF INTEREST.
13433C     OUTPUT ARGUMENTS--ICHARN (AN INTEGER VARIABLE
13434C                              CONTAINING THE NUMERIC
13435C                              DESIGNATION FOR THE
13436C                              ALPHABETIC CHARACTER.
13437C     WRITTEN BY--JAMES J. FILLIBEN
13438C                 STATISTICAL ENGINEERING DIVISION
13439C                 INFORMATION TECHNOLOGY LABORATORY
13440C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
13441C                 GAITHERSBURG, MD 20899-8980
13442C                 PHONE--301-975-2899
13443C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
13444C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
13445C     LANGUAGE--ANSI FORTRAN (1977)
13446C     VERSION NUMBER--82/7
13447C     ORIGINAL VERSION--MARCH     1981.
13448C     UPDATED         --NOVEMBER  1981.
13449C     UPDATED         --MAY       1982.
13450C
13451C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
13452C
13453      CHARACTER*4 ICHAR2
13454      CHARACTER*4 IBUG
13455      CHARACTER*4 IFOUND
13456C
13457C-----COMMON VARIABLES (BUGS & ERROR)---------------------------------
13458C
13459      CHARACTER*4 IBUGG4
13460      CHARACTER*4 ISUBG4
13461      CHARACTER*4 IERRG4
13462C
13463      COMMON /ICOMBE/IBUGG4,ISUBG4,IERRG4
13464C
13465C---------------------------------------------------------------------
13466C
13467      INCLUDE 'DPCOP2.INC'
13468C
13469C-----START POINT-----------------------------------------------------
13470C
13471      IFOUND='NO'
13472C
13473      IF(IBUG.EQ.'ON' .OR. ISUBG4.EQ.'CHGR')THEN
13474        WRITE(ICOUT,999)
13475  999   FORMAT(1X)
13476        CALL DPWRST('XXX','BUG ')
13477        WRITE(ICOUT,51)
13478   51   FORMAT('***** AT THE BEGINNING OF DPCHGR--')
13479        CALL DPWRST('XXX','BUG ')
13480        WRITE(ICOUT,59)ICHAR2,IBUG,ISUBG4
13481   59   FORMAT('ICHAR2,IBUG,ISUBG4 = ',2(A4,2X),A4)
13482        CALL DPWRST('XXX','BUG ')
13483      ENDIF
13484C
13485C               **********************************
13486C               **  STEP 1--                    **
13487C               **  CONVERT THE CHARACTER       **
13488C               **********************************
13489C
13490      IF(ICHAR2.EQ.'ALPH')GOTO100
13491      IF(ICHAR2.EQ.'BETA')GOTO200
13492      IF(ICHAR2.EQ.'GAMM')GOTO300
13493      IF(ICHAR2.EQ.'DELT')GOTO400
13494      IF(ICHAR2.EQ.'EPSI')GOTO500
13495      IF(ICHAR2.EQ.'ZETA')GOTO600
13496      IF(ICHAR2.EQ.'ETA')GOTO700
13497      IF(ICHAR2.EQ.'THET')GOTO800
13498      IF(ICHAR2.EQ.'IOTA')GOTO900
13499      IF(ICHAR2.EQ.'KAPP')GOTO1000
13500      IF(ICHAR2.EQ.'LAMB')GOTO1100
13501      IF(ICHAR2.EQ.'MU')GOTO1200
13502      IF(ICHAR2.EQ.'NU')GOTO1300
13503      IF(ICHAR2.EQ.'XI')GOTO1400
13504      IF(ICHAR2.EQ.'OMIC')GOTO1500
13505      IF(ICHAR2.EQ.'PI')GOTO1600
13506      IF(ICHAR2.EQ.'RHO')GOTO1700
13507      IF(ICHAR2.EQ.'SIGM')GOTO1800
13508      IF(ICHAR2.EQ.'TAU')GOTO1900
13509      IF(ICHAR2.EQ.'UPSI')GOTO2000
13510      IF(ICHAR2.EQ.'PHI')GOTO2100
13511      IF(ICHAR2.EQ.'CHI')GOTO2200
13512      IF(ICHAR2.EQ.'PSI')GOTO2300
13513      IF(ICHAR2.EQ.'OMEG')GOTO2400
13514      GOTO7900
13515C
13516  100 CONTINUE
13517      ICHARN=1
13518      GOTO8000
13519C
13520  200 CONTINUE
13521      ICHARN=2
13522      GOTO8000
13523C
13524  300 CONTINUE
13525      ICHARN=3
13526      GOTO8000
13527C
13528  400 CONTINUE
13529      ICHARN=4
13530      GOTO8000
13531C
13532  500 CONTINUE
13533      ICHARN=5
13534      GOTO8000
13535C
13536  600 CONTINUE
13537      ICHARN=6
13538      GOTO8000
13539C
13540  700 CONTINUE
13541      ICHARN=7
13542      GOTO8000
13543C
13544  800 CONTINUE
13545      ICHARN=8
13546      GOTO8000
13547C
13548  900 CONTINUE
13549      ICHARN=9
13550      GOTO8000
13551C
13552 1000 CONTINUE
13553      ICHARN=10
13554      GOTO8000
13555C
13556 1100 CONTINUE
13557      ICHARN=11
13558      GOTO8000
13559C
13560 1200 CONTINUE
13561      ICHARN=12
13562      GOTO8000
13563C
13564 1300 CONTINUE
13565      ICHARN=13
13566      GOTO8000
13567C
13568 1400 CONTINUE
13569      ICHARN=14
13570      GOTO8000
13571C
13572 1500 CONTINUE
13573      ICHARN=15
13574      GOTO8000
13575C
13576 1600 CONTINUE
13577      ICHARN=16
13578      GOTO8000
13579C
13580 1700 CONTINUE
13581      ICHARN=17
13582      GOTO8000
13583C
13584 1800 CONTINUE
13585      ICHARN=18
13586      GOTO8000
13587C
13588 1900 CONTINUE
13589      ICHARN=19
13590      GOTO8000
13591C
13592 2000 CONTINUE
13593      ICHARN=20
13594      GOTO8000
13595C
13596 2100 CONTINUE
13597      ICHARN=21
13598      GOTO8000
13599C
13600 2200 CONTINUE
13601      ICHARN=22
13602      GOTO8000
13603C
13604 2300 CONTINUE
13605      ICHARN=23
13606      GOTO8000
13607C
13608 2400 CONTINUE
13609      ICHARN=24
13610      GOTO8000
13611C
13612 7900 CONTINUE
13613CCCCC WRITE(ICOUT,999)
13614CCCCC CALL DPWRST('XXX','BUG ')
13615CCCCC WRITE(ICOUT,7911)
13616C7911 FORMAT('***** ERROR IN DPCHNU--')
13617CCCCC CALL DPWRST('XXX','BUG ')
13618CCCCC WRITE(ICOUT,7912)
13619C7912 FORMAT('      NO MATCH FOUND FOR INPUT CHARACTER.')
13620CCCCC CALL DPWRST('XXX','BUG ')
13621CCCCC WRITE(ICOUT,7913)ICHAR2
13622C7913 FORMAT('      INPUT CHAR2ACTER = ',A4)
13623CCCCC CALL DPWRST('XXX','BUG ')
13624      IFOUND='NO'
13625      GOTO9000
13626C
13627 8000 CONTINUE
13628      IFOUND='YES'
13629      GOTO9000
13630C
13631C               *****************
13632C               **  STEP 90--  **
13633C               **  EXIT       **
13634C               *****************
13635C
13636 9000 CONTINUE
13637      IF(IBUG.EQ.'ON' .OR. ISUBG4.EQ.'CHGR')THEN
13638        WRITE(ICOUT,999)
13639        CALL DPWRST('XXX','BUG ')
13640        WRITE(ICOUT,9011)
13641 9011   FORMAT('***** AT THE END       OF DPCHGR--')
13642        CALL DPWRST('XXX','BUG ')
13643        WRITE(ICOUT,9013)IFOUND,ICHAR2,ICHARN
13644 9013   FORMAT('IFOUND,ICHAR2,ICHARN = ',2(A4,2X),I8)
13645        CALL DPWRST('XXX','BUG ')
13646      ENDIF
13647C
13648      RETURN
13649      END
13650      SUBROUTINE DPCHHW(IHARG,IARGT,ARG,NUMARG,
13651     1                  MAXCHA,
13652     1                  PCHAHE,PCHAWI,PDEFHE,PDEFWI,
13653     1                  IFOUND,IERROR)
13654C
13655C     PURPOSE--DEFINE PLOT CHARACTER HEIGHT AND WIDTH
13656C              FOR USE IN MULTI-TRACE PLOTS.
13657C              THE HEIGHT AND WIDTH FOR THE CHARACTER FOR THE I-TH TRACE
13658C              WILL BE PLACED
13659C              IN THE I-TH ELEMENT OF THE FLOATING POINT
13660C              VECTORS PCHAHE(.) AND PCHAWI(.).
13661C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
13662C                     --IARGT  (A  HOLLERITH VECTOR)
13663C                     --ARG    (A  HOLLERITH VECTOR)
13664C                     --NUMARG
13665C                     --MAXCHA
13666C     OUTPUT ARGUMENTS--PCHAHE  (A  FLOATING POINT VECTOR
13667C                       WHOSE I-TH ELEMENT IS THE HEIGHT
13668C                       FOR THE CHARACTER
13669C                       ASSIGNED TO THE I-TH    TRACE    IN
13670C                       A MULTI-TRACE PLOT.
13671C                     --PCHAWI  (A  FLOATING POINT VECTOR
13672C                       WHOSE I-TH ELEMENT IS THE WIDTH
13673C                       FOR THE CHARACTER
13674C                       ASSIGNED TO THE I-TH    TRACE    IN
13675C                       A MULTI-TRACE PLOT.
13676C                     --PDEFHE  = DEFAULT CHARACTER HEIGHT
13677C                     --PDEFWI  = DEFAULT CHARACTER WIDTH
13678C                     --IFOUND ('YES' OR 'NO' )
13679C                     --IERROR ('YES' OR 'NO' )
13680C     WRITTEN BY--JAMES J. FILLIBEN
13681C                 STATISTICAL ENGINEERING DIVISION
13682C                 INFORMATION TECHNOLOGY LABORATORY
13683C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
13684C                 GAITHERSBURG, MD 20899-8980
13685C                 PHONE--301-975-2899
13686C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
13687C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
13688C     LANGUAGE--ANSI FORTRAN (1977)
13689C     VERSION NUMBER--88/8
13690C     ORIGINAL VERSION--AUGUST    1988.
13691C     UPDATED         --JANUARY   1995. ALLOW ? AS ARGUMENT (FOR HELP)
13692C
13693C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
13694C
13695      CHARACTER*4 IHARG
13696      CHARACTER*4 IARGT
13697      CHARACTER*4 IFOUND
13698      CHARACTER*4 IERROR
13699C
13700C---------------------------------------------------------------------
13701C
13702      DIMENSION IHARG(*)
13703      DIMENSION IARGT(*)
13704      DIMENSION ARG(*)
13705C
13706      DIMENSION PCHAHE(*)
13707      DIMENSION PCHAWI(*)
13708C
13709C---------------------------------------------------------------------
13710C
13711      INCLUDE 'DPCOP2.INC'
13712C
13713C-----START POINT-----------------------------------------------------
13714C
13715      IFOUND='NO'
13716      IERROR='NO'
13717C
13718      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'HW')GOTO1160
13719      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'HW')GOTO1105
13720      GOTO9000
13721C
13722 1105 CONTINUE
13723      IF(IHARG(NUMARG).EQ.'ON')GOTO1110
13724      IF(IHARG(NUMARG).EQ.'OFF')GOTO1110
13725      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1110
13726      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1110
13727      IF(IHARG(NUMARG).EQ.'?')GOTO1200
13728C
13729      IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'ALL')GOTO1160
13730      IF(NUMARG.EQ.3)GOTO1120
13731      IF(NUMARG.GE.4.AND.IHARG(2).EQ.'ALL')GOTO1130
13732      IF(NUMARG.GE.4.AND.IHARG(4).EQ.'ALL')GOTO1140
13733C
13734      GOTO1150
13735C
13736 1110 CONTINUE
13737      DO1115I=1,MAXCHA
13738      PCHAWI(I)=PDEFHE
13739      PCHAHE(I)=PDEFWI
13740 1115 CONTINUE
13741C
13742      IF(IFEEDB.EQ.'OFF')GOTO1119
13743      WRITE(ICOUT,999)
13744  999 FORMAT(1X)
13745      CALL DPWRST('XXX','BUG ')
13746      I=1
13747      WRITE(ICOUT,1116)
13748 1116 FORMAT('THE HEIGHTS AND WIDTHS OF ALL CHARACTERS')
13749      CALL DPWRST('XXX','BUG ')
13750      WRITE(ICOUT,1117)PCHAHE(I),PCHAWI(I)
13751 1117 FORMAT('    HAVE JUST BEEN SET TO ',2E15.7)
13752      CALL DPWRST('XXX','BUG ')
13753 1119 CONTINUE
13754      GOTO2190
13755C
13756 1120 CONTINUE
13757      I=1
13758      IF(IARGT(2).NE.'NUMB'.OR.IARGT(3).NE.'NUMB')GOTO1180
13759      PCHAHE(1)=ARG(2)
13760      PCHAWI(1)=ARG(3)
13761C
13762      IF(IFEEDB.EQ.'OFF')GOTO1129
13763      WRITE(ICOUT,999)
13764      CALL DPWRST('XXX','BUG ')
13765      I=1
13766      WRITE(ICOUT,1126)I
13767 1126 FORMAT('THE HEIGHT AND WIDTH OF CHARACTER ',I6)
13768      CALL DPWRST('XXX','BUG ')
13769      WRITE(ICOUT,1127)PCHAHE(I),PCHAWI(I)
13770 1127 FORMAT('    HAS JUST BEEN SET TO ',2E15.7)
13771      CALL DPWRST('XXX','BUG ')
13772 1129 CONTINUE
13773      GOTO2190
13774C
13775 1130 CONTINUE
13776      I=1
13777      IF(IARGT(3).NE.'NUMB'.OR.IARGT(4).NE.'NUMB')GOTO1180
13778      DO1135I=1,MAXCHA
13779      PCHAHE(I)=ARG(3)
13780      PCHAWI(I)=ARG(4)
13781 1135 CONTINUE
13782C
13783      IF(IFEEDB.EQ.'OFF')GOTO1139
13784      WRITE(ICOUT,999)
13785      CALL DPWRST('XXX','BUG ')
13786      I=1
13787      WRITE(ICOUT,1116)
13788      CALL DPWRST('XXX','BUG ')
13789      WRITE(ICOUT,1117)PCHAHE(I),PCHAWI(I)
13790      CALL DPWRST('XXX','BUG ')
13791 1139 CONTINUE
13792      GOTO2190
13793C
13794 1140 CONTINUE
13795      I=1
13796      IF(IARGT(2).NE.'NUMB'.OR.IARGT(3).NE.'NUMB')GOTO1180
13797      DO1145I=1,MAXCHA
13798      PCHAHE(I)=ARG(2)
13799      PCHAWI(I)=ARG(3)
13800 1145 CONTINUE
13801C
13802      IF(IFEEDB.EQ.'OFF')GOTO1149
13803      WRITE(ICOUT,999)
13804      CALL DPWRST('XXX','BUG ')
13805      I=1
13806      WRITE(ICOUT,1116)
13807      CALL DPWRST('XXX','BUG ')
13808      WRITE(ICOUT,1117)PCHAHE(I),PCHAWI(I)
13809      CALL DPWRST('XXX','BUG ')
13810 1149 CONTINUE
13811      GOTO2190
13812C
13813 1150 CONTINUE
13814      IMAX=NUMARG-1
13815      IF(MAXCHA.LT.IMAX)IMAX=MAXCHA
13816      J=0
13817      DO1155I=1,IMAX,2
13818      IP1=I+1
13819      IP2=I+2
13820      IF(IARGT(IP1).NE.'NUMB')GOTO1180
13821      IF(IARGT(IP2).NE.'NUMB')GOTO1180
13822      J=J+1
13823      PCHAHE(J)=ARG(IP1)
13824      PCHAWI(J)=ARG(IP2)
13825 1155 CONTINUE
13826      JMAX=J
13827C
13828      IF(IFEEDB.EQ.'OFF')GOTO1159
13829      WRITE(ICOUT,999)
13830      CALL DPWRST('XXX','BUG ')
13831      DO1156I=1,JMAX
13832      WRITE(ICOUT,1126)I
13833      CALL DPWRST('XXX','BUG ')
13834      WRITE(ICOUT,1127)PCHAHE(I),PCHAWI(I)
13835      CALL DPWRST('XXX','BUG ')
13836 1156 CONTINUE
13837 1159 CONTINUE
13838      GOTO2190
13839C
13840 1160 CONTINUE
13841      DO1165I=1,MAXCHA
13842      PCHAHE(I)=PDEFHE
13843      PCHAWI(I)=PDEFWI
13844 1165 CONTINUE
13845C
13846      IF(IFEEDB.EQ.'OFF')GOTO1169
13847      WRITE(ICOUT,999)
13848      CALL DPWRST('XXX','BUG ')
13849      I=1
13850      WRITE(ICOUT,1116)
13851      CALL DPWRST('XXX','BUG ')
13852      WRITE(ICOUT,1117)PCHAHE(I),PCHAWI(I)
13853      CALL DPWRST('XXX','BUG ')
13854 1169 CONTINUE
13855      GOTO2190
13856C
13857 1180 CONTINUE
13858      IERROR='YES'
13859      WRITE(ICOUT,999)
13860      CALL DPWRST('XXX','BUG ')
13861      WRITE(ICOUT,1181)
13862 1181 FORMAT('***** ERROR IN DPCHHW--')
13863      CALL DPWRST('XXX','BUG ')
13864      WRITE(ICOUT,1182)
13865 1182 FORMAT('THE HEIGHTS AND WIDTHS OF CHARACTERS MUST BE NUMERIC')
13866      CALL DPWRST('XXX','BUG ')
13867      WRITE(ICOUT,1183)
13868 1183 FORMAT('HOWEVER, THE SPECIFIED CHARACTER HEIGHT AND WIDTH')
13869      CALL DPWRST('XXX','BUG ')
13870      WRITE(ICOUT,1184)I
13871 1184 FORMAT('FOR CHARACTER ',I6,' WAS NON-NUMERIC.')
13872      CALL DPWRST('XXX','BUG ')
13873      GOTO9000
13874C
13875CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY 1995
13876 1200 CONTINUE
13877      IFOUND='YES'
13878      IF(IFEEDB.EQ.'OFF')GOTO1229
13879      WRITE(ICOUT,999)
13880      CALL DPWRST('XXX','BUG ')
13881      I=1
13882      WRITE(ICOUT,1221)I,PCHAHE(I)
13883 1221 FORMAT('THE CURRENT HEIGHT FOR CHARACTER ',I6,' IS ',E15.7)
13884      CALL DPWRST('XXX','BUG ')
13885      WRITE(ICOUT,1222)I,PCHAWI(I)
13886 1222 FORMAT('THE CURRENT WIDTH  FOR CHARACTER ',I6,' IS ',E15.7)
13887      CALL DPWRST('XXX','BUG ')
13888      WRITE(ICOUT,999)
13889      CALL DPWRST('XXX','BUG ')
13890      WRITE(ICOUT,1223)I,PDEFHE
13891 1223 FORMAT('THE DEFAULT HEIGHT FOR CHARACTER ',I6,' IS ',E15.7)
13892      CALL DPWRST('XXX','BUG ')
13893      WRITE(ICOUT,1224)I,PDEFWI
13894 1224 FORMAT('THE DEFAULT WIDTH  FOR CHARACTER ',I6,' IS ',E15.7)
13895      CALL DPWRST('XXX','BUG ')
13896 1229 CONTINUE
13897      GOTO9000
13898C
13899 2190 CONTINUE
13900      IFOUND='YES'
13901C
13902 9000 CONTINUE
13903      RETURN
13904      END
13905      SUBROUTINE DPCHJU(IHARG,NUMARG,MAXCHA,ICHAJU,IFOUND,IERROR)
13906C
13907C     PURPOSE--DEFINE PLOT CHARACTER JUSTIFICATION FOR USE IN MULTI-TRACE PLOTS.
13908C              THE JUSTIFICATION FOR THE CHARACTER FOR THE I-TH TRACE
13909C              WILL BE PLACED
13910C              IN THE I-TH ELEMENT OF THE HOLLERITH
13911C              VECTOR ICHAJU(.).
13912C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
13913C                     --NUMARG
13914C                     --MAXCHA
13915C     OUTPUT ARGUMENTS--ICHAJU  (A  HOLLERITH VECTOR
13916C                       WHOSE I-TH ELEMENT IS THE JUSTIFICATION
13917C                       FOR THE CHARACTER
13918C                       ASSIGNED TO THE I-TH    TRACE    IN
13919C                       A MULTI-TRACE PLOT.
13920C                     --IFOUND ('YES' OR 'NO' )
13921C                     --IERROR ('YES' OR 'NO' )
13922C     WRITTEN BY--JAMES J. FILLIBEN
13923C                 STATISTICAL ENGINEERING DIVISION
13924C                 INFORMATION TECHNOLOGY LABORATORY
13925C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
13926C                 GAITHERSBURG, MD 20899-8980
13927C                 PHONE--301-975-2899
13928C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
13929C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
13930C     LANGUAGE--ANSI FORTRAN (1977)
13931C     VERSION NUMBER--82/7
13932C     ORIGINAL VERSION--NOVEMBER  1986.
13933C
13934C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
13935C
13936      CHARACTER*4 IHARG
13937      CHARACTER*4 ICHAJU
13938      CHARACTER*4 IFOUND
13939      CHARACTER*4 IERROR
13940C
13941C---------------------------------------------------------------------
13942C
13943      DIMENSION IHARG(*)
13944      DIMENSION ICHAJU(*)
13945C
13946C---------------------------------------------------------------------
13947C
13948      INCLUDE 'DPCOP2.INC'
13949C
13950C-----START POINT-----------------------------------------------------
13951C
13952      IFOUND='NO'
13953      IERROR='NO'
13954C
13955      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'JUST')GOTO1160
13956      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'JUST')GOTO1105
13957      GOTO1199
13958C
13959 1105 CONTINUE
13960      IF(IHARG(NUMARG).EQ.'ON')GOTO1110
13961      IF(IHARG(NUMARG).EQ.'OFF')GOTO1110
13962      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1110
13963      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1110
13964C
13965      IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'ALL')GOTO1160
13966      IF(NUMARG.EQ.2)GOTO1120
13967      IF(NUMARG.GE.3.AND.IHARG(2).EQ.'ALL')GOTO1130
13968      IF(NUMARG.GE.3.AND.IHARG(3).EQ.'ALL')GOTO1140
13969C
13970      GOTO1150
13971C
13972 1110 CONTINUE
13973      DO1115I=1,MAXCHA
13974      ICHAJU(I)='CENT'
13975 1115 CONTINUE
13976C
13977      IF(IFEEDB.EQ.'OFF')GOTO1119
13978      WRITE(ICOUT,999)
13979  999 FORMAT(1X)
13980      CALL DPWRST('XXX','BUG ')
13981      I=1
13982      WRITE(ICOUT,1116)ICHAJU(I)
13983 1116 FORMAT('ALL CHARACTER JUSTIFICATIONS HAVE JUST BEEN SET TO ',
13984     1A4)
13985      CALL DPWRST('XXX','BUG ')
13986 1119 CONTINUE
13987      GOTO1190
13988C
13989 1120 CONTINUE
13990      ICHAJU(1)=IHARG(2)
13991C
13992      IF(IFEEDB.EQ.'OFF')GOTO1129
13993      WRITE(ICOUT,999)
13994      CALL DPWRST('XXX','BUG ')
13995      I=1
13996      WRITE(ICOUT,1126)I,ICHAJU(I)
13997 1126 FORMAT('THE JUSTIFICATION FOR CHARACTER ',I6,
13998     1' HAS JUST BEEN SET TO ',A4)
13999      CALL DPWRST('XXX','BUG ')
14000 1129 CONTINUE
14001      GOTO1190
14002C
14003 1130 CONTINUE
14004      DO1135I=1,MAXCHA
14005      ICHAJU(I)=IHARG(3)
14006 1135 CONTINUE
14007C
14008      IF(IFEEDB.EQ.'OFF')GOTO1139
14009      WRITE(ICOUT,999)
14010      CALL DPWRST('XXX','BUG ')
14011      I=1
14012      WRITE(ICOUT,1116)ICHAJU(I)
14013      CALL DPWRST('XXX','BUG ')
14014 1139 CONTINUE
14015      GOTO1190
14016C
14017 1140 CONTINUE
14018      DO1145I=1,MAXCHA
14019      ICHAJU(I)=IHARG(2)
14020 1145 CONTINUE
14021C
14022      IF(IFEEDB.EQ.'OFF')GOTO1149
14023      WRITE(ICOUT,999)
14024      CALL DPWRST('XXX','BUG ')
14025      I=1
14026      WRITE(ICOUT,1116)ICHAJU(I)
14027      CALL DPWRST('XXX','BUG ')
14028 1149 CONTINUE
14029      GOTO1190
14030C
14031 1150 CONTINUE
14032      IMAX=NUMARG-1
14033      IF(MAXCHA.LT.IMAX)IMAX=MAXCHA
14034      DO1155I=1,IMAX
14035      IP1=I+1
14036      ICHAJU(I)=IHARG(IP1)
14037 1155 CONTINUE
14038C
14039      IF(IFEEDB.EQ.'OFF')GOTO1159
14040      WRITE(ICOUT,999)
14041      CALL DPWRST('XXX','BUG ')
14042      DO1156I=1,IMAX
14043      WRITE(ICOUT,1126)I,ICHAJU(I)
14044      CALL DPWRST('XXX','BUG ')
14045 1156 CONTINUE
14046 1159 CONTINUE
14047      GOTO1190
14048C
14049 1160 CONTINUE
14050      DO1165I=1,MAXCHA
14051      ICHAJU(I)='CENT'
14052 1165 CONTINUE
14053C
14054      IF(IFEEDB.EQ.'OFF')GOTO1169
14055      WRITE(ICOUT,999)
14056      CALL DPWRST('XXX','BUG ')
14057      I=1
14058      WRITE(ICOUT,1116)ICHAJU(I)
14059      CALL DPWRST('XXX','BUG ')
14060 1169 CONTINUE
14061      GOTO1190
14062C
14063 1190 CONTINUE
14064      IFOUND='YES'
14065C
14066 1199 CONTINUE
14067      RETURN
14068      END
14069      SUBROUTINE DPCHLI(ICONT,NUMCPL,YSTART,YSTOP,XSTART,XSTOP,
14070     1J,JD,Y2,X2,D2,IERROR)
14071C
14072C     PURPOSE--GENERATE PLOT COORDINATES FOR A POINT
14073C              OR FOR A LINE.
14074C     WRITTEN BY--JAMES J. FILLIBEN
14075C                 STATISTICAL ENGINEERING DIVISION
14076C                 INFORMATION TECHNOLOGY LABORATORY
14077C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
14078C                 GAITHERSBURG, MD 20899-8980
14079C                 PHONE--301-975-2899
14080C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
14081C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
14082C     LANGUAGE--ANSI FORTRAN (1977)
14083C     VERSION NUMBER--82/7
14084C     ORIGINAL VERSION--JANUARY   1981.
14085C     UPDATED         --MAY       1982.
14086C
14087C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
14088C
14089      CHARACTER*4 ICONT
14090      CHARACTER*4 IERROR
14091C
14092C---------------------------------------------------------------------
14093C
14094      DIMENSION Y2(*)
14095      DIMENSION X2(*)
14096      DIMENSION D2(*)
14097C
14098C---------------------------------------------------------------------
14099C
14100      INCLUDE 'DPCOP2.INC'
14101C
14102C-----START POINT-----------------------------------------------------
14103C
14104      IERROR='NO'
14105C
14106      NUMCP2=NUMCPL
14107      IF(ICONT.EQ.'ON')NUMCP2=2
14108      ANUMC2=NUMCP2
14109C
14110      IF(YSTART.EQ.YSTOP)GOTO200
14111      IF(XSTART.EQ.XSTOP)GOTO1300
14112      GOTO1400
14113C
14114  200 CONTINUE
14115      IF(XSTART.EQ.XSTOP)GOTO1100
14116      GOTO1200
14117C
14118C               ***************************
14119C               **  STEP 2.1--           **
14120C               **  TREAT THE CASE WHEN  **
14121C               **  Y HAS NO CHANGE      **
14122C               **  X HAS NO CHANGE      **
14123C               ***************************
14124C
14125 1100 CONTINUE
14126      J=J+1
14127      JD=JD+1
14128      Y2(J)=YSTART
14129      X2(J)=XSTART
14130      D2(J)=JD
14131      GOTO9000
14132C
14133C               ***************************
14134C               **  STEP 2.2--           **
14135C               **  TREAT THE CASE WHEN  **
14136C               **  Y HAS NO CHANGE      **
14137C               **  X HAS    CHANGE      **
14138C               ***************************
14139C
14140 1200 CONTINUE
14141      JD=JD+1
14142      XDEL=XSTOP-XSTART
14143      DO1210I=1,NUMCP2
14144      J=J+1
14145      AI=I
14146      P=(AI-1.0)/(ANUMC2-1.0)
14147      XP=XSTART+P*XDEL
14148      Y2(J)=YSTART
14149      X2(J)=XP
14150      D2(J)=JD
14151 1210 CONTINUE
14152      GOTO9000
14153C
14154C               ***************************
14155C               **  STEP 2.3--           **
14156C               **  TREAT THE CASE WHEN  **
14157C               **  Y HAS    CHANGE      **
14158C               **  X HAS NO CHANGE      **
14159C               ***************************
14160C
14161 1300 CONTINUE
14162      JD=JD+1
14163      YDEL=YSTOP-YSTART
14164      DO1310I=1,NUMCP2
14165      J=J+1
14166      AI=I
14167      P=(AI-1.0)/(ANUMC2-1.0)
14168      YP=YSTART+P*YDEL
14169      Y2(J)=YP
14170      X2(J)=XSTART
14171      D2(J)=JD
14172 1310 CONTINUE
14173      GOTO9000
14174C
14175C               ***************************
14176C               **  STEP 2.4--           **
14177C               **  TREAT THE CASE WHEN  **
14178C               **  Y HAS    CHANGE      **
14179C               **  X HAS    CHANGE      **
14180C               ***************************
14181C
14182 1400 CONTINUE
14183      JD=JD+1
14184      XDEL=XSTOP-XSTART
14185      YDEL=YSTOP-YSTART
14186      DO1410I=1,NUMCP2
14187      J=J+1
14188      AI=I
14189      P=(AI-1.0)/(ANUMC2-1.0)
14190      XP=XSTART+P*XDEL
14191      YP=YSTART+P*YDEL
14192      Y2(J)=YP
14193      X2(J)=XP
14194      D2(J)=JD
14195 1410 CONTINUE
14196      GOTO9000
14197C
14198C               *****************
14199C               **  STEP 90--  **
14200C               **  EXIT       **
14201C               *****************
14202C
14203 9000 CONTINUE
14204      RETURN
14205      END
14206      SUBROUTINE DPCHLR(ISTRIN,NUMCHS,ILOCLP,ILOCRP,IFOULR,IBUG,IERROR)
14207C
14208C     PURPOSE--CHECK FOR A LEFT AND RIGHT PARENTHESIS.
14209C              CHECK FOR A LEFT  PARENTHESIS IN LOCATION ILOCLP.
14210C              CHECK FOR A RIGHT PARENTHESIS IN LOCATION ILOCRP.
14211C     WRITTEN BY--JAMES J. FILLIBEN
14212C                 STATISTICAL ENGINEERING DIVISION
14213C                 INFORMATION TECHNOLOGY LABORATORY
14214C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
14215C                 GAITHERSBURG, MD 20899-8980
14216C                 PHONE--301-975-2899
14217C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
14218C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
14219C     LANGUAGE--ANSI FORTRAN (1977)
14220C     VERSION NUMBER--82/7
14221C     ORIGINAL VERSION--APRIL     1981.
14222C     UPDATED         --FEBRUARY  1982.
14223C     UPDATED         --MAY       1982.
14224C
14225C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
14226C
14227      CHARACTER*4 ISTRIN
14228      CHARACTER*4 IFOULR
14229      CHARACTER*4 IBUG
14230      CHARACTER*4 IERROR
14231C
14232C---------------------------------------------------------------------
14233C
14234      DIMENSION ISTRIN(*)
14235C
14236C-----COMMON----------------------------------------------------------
14237C
14238      INCLUDE 'DPCOBE.INC'
14239      INCLUDE 'DPCOP2.INC'
14240C
14241C-----START POINT-----------------------------------------------------
14242C
14243      IFOULR='NO'
14244      IERROR='NO'
14245C
14246      IF(IBUG.EQ.'ON' .OR. ISUBG4.EQ.'CHLR')THEN
14247        WRITE(ICOUT,999)
14248  999   FORMAT(1X)
14249        CALL DPWRST('XXX','BUG ')
14250        WRITE(ICOUT,51)
14251   51   FORMAT('***** AT THE BEGINNING OF DPCHLR--')
14252        CALL DPWRST('XXX','BUG ')
14253        WRITE(ICOUT,52)NUMCHS,ILOCLP,ILOCRP
14254   52   FORMAT('NUMCHS,ILOCLP,ILOCRP = ',3I8)
14255        CALL DPWRST('XXX','BUG ')
14256        WRITE(ICOUT,53)(ISTRIN(I),I=1,MIN(100,NUMCHS))
14257   53   FORMAT('(ISTRIN(I),I=1,NUMCHS) = ',100A1)
14258        CALL DPWRST('XXX','BUG ')
14259        WRITE(ICOUT,59)IBUG,ISUBG4,IERRG4
14260   59   FORMAT('IBUG,ISUBG4,IERRG4 = ',2(A4,2X),A4)
14261        CALL DPWRST('XXX','BUG ')
14262      ENDIF
14263C
14264      IF(ILOCLP.LT.1)GOTO1200
14265      IF(ILOCLP.GT.NUMCHS)GOTO1200
14266C
14267      IF(ILOCRP.LT.1)GOTO1200
14268      IF(ILOCRP.GT.NUMCHS)GOTO1200
14269C
14270      IF(ISTRIN(ILOCLP).NE.'(')GOTO1200
14271      IF(ISTRIN(ILOCRP).NE.')')GOTO1200
14272C
14273      IFOULR='YES'
14274      GOTO9000
14275C
14276 1200 CONTINUE
14277      IFOULR='NO'
14278      GOTO9000
14279C
14280C               *****************
14281C               **  STEP 90--  **
14282C               **  EXIT       **
14283C               *****************
14284C
14285 9000 CONTINUE
14286      IF(IBUG.EQ.'ON' .OR. ISUBG4.EQ.'CHLR')THEN
14287        WRITE(ICOUT,999)
14288        CALL DPWRST('XXX','BUG ')
14289        WRITE(ICOUT,9011)
14290 9011   FORMAT('***** AT THE END      OF DPCHLR--')
14291        CALL DPWRST('XXX','BUG ')
14292        WRITE(ICOUT,9012)IFOULR,IERRG4
14293 9012   FORMAT('IFOULR,IERRG4 = ',A4,2X,A4)
14294        CALL DPWRST('XXX','BUG ')
14295      ENDIF
14296C
14297      RETURN
14298      END
14299      SUBROUTINE DPCHMA(ICHAR2,ICHARN,IBUG,IFOUND)
14300C
14301C     PURPOSE--CONVERT A MATHEMATICAL SYMBOL
14302C              INTO A NUMERIC VALUE
14303C              (1 TO 66).
14304C     INPUT  ARGUMENTS--ICHAR2 (A HOLLERITH VARIABLE
14305C                              CONTAINING THE HOLLERITH
14306C                              CHARACTER(S) OF INTEREST.
14307C     OUTPUT ARGUMENTS--ICHARN (AN INTEGER VARIABLE
14308C                              CONTAINING THE NUMERIC
14309C                              DESIGNATION FOR THE
14310C                              ALPHABETIC CHARACTER.
14311C     WRITTEN BY--JAMES J. FILLIBEN
14312C                 STATISTICAL ENGINEERING DIVISION
14313C                 INFORMATION TECHNOLOGY LABORATORY
14314C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
14315C                 GAITHERSBURG, MD 20899-8980
14316C                 PHONE--301-975-2899
14317C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
14318C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
14319C     LANGUAGE--ANSI FORTRAN (1977)
14320C     VERSION NUMBER--82/7
14321C     ORIGINAL VERSION--MARCH     1981.
14322C     UPDATED         --NOVEMBER  1981.
14323C     UPDATED         --MAY       1982.
14324C     UPDATED         --APRIL     1987.
14325C     UPDATED         --AUGUST    1992.  ADD SYNONYMS FOR REVERSE
14326C                                        TRIANGLE (TO AGREE WITH
14327C                                        DOCUMENTATION), ADD ARROW CASE
14328C
14329C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
14330C
14331      CHARACTER*4 ICHAR2
14332      CHARACTER*4 IBUG
14333      CHARACTER*4 IFOUND
14334C
14335      CHARACTER*1 IBASLC
14336C
14337C-----COMMON----------------------------------------------------------
14338C
14339      INCLUDE 'DPCOBE.INC'
14340C
14341C-----COMMON VARIABLES (GENERAL)--------------------------------------
14342C
14343      INCLUDE 'DPCOP2.INC'
14344C
14345C-----START POINT-----------------------------------------------------
14346C
14347      IFOUND='NO'
14348C
14349      IF(IBUG.EQ.'ON' .OR. ISUBG4.EQ.'CHMA')THEN
14350        WRITE(ICOUT,999)
14351  999   FORMAT(1X)
14352        CALL DPWRST('XXX','BUG ')
14353        WRITE(ICOUT,51)
14354   51   FORMAT('***** AT THE BEGINNING OF DPCHMA--')
14355        CALL DPWRST('XXX','BUG ')
14356        WRITE(ICOUT,59)ICHAR2,IBUGG4,ISUBG4
14357   59   FORMAT('ICHAR2,IBUGG4,ISUBG4 = ',2(A4,2X),A4)
14358        CALL DPWRST('XXX','BUG ')
14359      ENDIF
14360C
14361C               **********************************
14362C               **  STEP 1--                    **
14363C               **  CONVERT THE CHARACTER       **
14364C               **********************************
14365C
14366      IF(ICHAR2.EQ.'/   ')GOTO100
14367      IF(ICHAR2.EQ.'(   ')GOTO200
14368      IF(ICHAR2.EQ.')   ')GOTO300
14369      IF(ICHAR2.EQ.'[   ')GOTO400
14370      IF(ICHAR2.EQ.'LBRA')GOTO400
14371      IF(ICHAR2.EQ.']   ')GOTO500
14372      IF(ICHAR2.EQ.'RBRA')GOTO500
14373      IF(ICHAR2.EQ.'{   ')GOTO600
14374      IF(ICHAR2.EQ.'LCBR')GOTO600
14375      IF(ICHAR2.EQ.'}   ')GOTO700
14376      IF(ICHAR2.EQ.'RCBR')GOTO700
14377      IF(ICHAR2.EQ.'LELB')GOTO800
14378      IF(ICHAR2.EQ.'RELB')GOTO900
14379      IF(ICHAR2.EQ.'|   ')GOTO1000
14380      IF(ICHAR2.EQ.'VBAR')GOTO1000
14381      IF(ICHAR2.EQ.':   ')GOTO1100
14382      IF(ICHAR2.EQ.'DVBA')GOTO1100
14383      IF(ICHAR2.EQ.'COLO')GOTO1100
14384      IF(ICHAR2.EQ.'-   ')GOTO1200
14385      IF(ICHAR2.EQ.'MINU')GOTO1200
14386      IF(ICHAR2.EQ.'+   ')GOTO1300
14387      IF(ICHAR2.EQ.'PLUS')GOTO1300
14388      IF(ICHAR2.EQ.'CROS')GOTO1300
14389      IF(ICHAR2.EQ.'+-  ')GOTO1400
14390      IF(ICHAR2.EQ.'-+  ')GOTO1500
14391      IF(ICHAR2.EQ.'TIME')GOTO1600
14392      IF(ICHAR2.EQ.'DOTP')GOTO1700
14393      IF(ICHAR2.EQ.'/   ')GOTO1800
14394      IF(ICHAR2.EQ.'DIVI')GOTO1800
14395      IF(ICHAR2.EQ.'SLAS')GOTO1800
14396      IF(ICHAR2.EQ.'=   ')GOTO1900
14397      IF(ICHAR2.EQ.'EQUA')GOTO1900
14398      IF(ICHAR2.EQ.'NOT=')GOTO2000
14399      IF(ICHAR2.EQ.'<>')GOTO2000
14400      IF(ICHAR2.EQ.'><')GOTO2000
14401      IF(ICHAR2.EQ.'EQUI')GOTO2100
14402      IF(ICHAR2.EQ.'<   ')GOTO2200
14403      IF(ICHAR2.EQ.'LT  ')GOTO2200
14404      IF(ICHAR2.EQ.'>   ')GOTO2300
14405      IF(ICHAR2.EQ.'GT  ')GOTO2300
14406      IF(ICHAR2.EQ.'<=  ')GOTO2400
14407      IF(ICHAR2.EQ.'=<  ')GOTO2400
14408      IF(ICHAR2.EQ.'LTEQ')GOTO2400
14409      IF(ICHAR2.EQ.'>=  ')GOTO2500
14410      IF(ICHAR2.EQ.'=>  ')GOTO2500
14411      IF(ICHAR2.EQ.'GTEQ')GOTO2500
14412      IF(ICHAR2.EQ.'VARI')GOTO2600
14413      IF(ICHAR2.EQ.'APPR')GOTO2700
14414      IF(ICHAR2.EQ.'~   ')GOTO2700
14415      IF(ICHAR2.EQ.'TILD')GOTO2700
14416      IF(ICHAR2.EQ.'CARA')GOTO2800
14417      IF(ICHAR2.EQ.'PRIM')GOTO2900
14418      IF(ICHAR2.EQ.'`   ')GOTO3000
14419      IF(ICHAR2.EQ.'LACC')GOTO3000
14420      IF(ICHAR2.EQ.'BREV')GOTO3100
14421      IF(ICHAR2.EQ.'RQUO')GOTO3200
14422      IF(ICHAR2.EQ.'LQUO')GOTO3300
14423      IF(ICHAR2.EQ.'NASP')GOTO3400
14424      IF(ICHAR2.EQ.'IASP')GOTO3500
14425      IF(ICHAR2.EQ.'RADI')GOTO3600
14426      IF(ICHAR2.EQ.'SUBS')GOTO3700
14427      IF(ICHAR2.EQ.'UNIO')GOTO3800
14428      IF(ICHAR2.EQ.'SUPE')GOTO3900
14429      IF(ICHAR2.EQ.'INTR')GOTO4000
14430      IF(ICHAR2.EQ.'ELEM')GOTO4100
14431      IF(ICHAR2.EQ.'RARR')GOTO4200
14432      IF(ICHAR2.EQ.'^   ')GOTO4300
14433      IF(ICHAR2.EQ.'UARR')GOTO4300
14434      IF(ICHAR2.EQ.'LARR')GOTO4400
14435      IF(ICHAR2.EQ.'DARR')GOTO4500
14436      IF(ICHAR2.EQ.'PART')GOTO4600
14437      IF(ICHAR2.EQ.'DEL ')GOTO4700
14438      IF(ICHAR2.EQ.'LRAD')GOTO4800
14439      IF(ICHAR2.EQ.'INTE')GOTO4900
14440      IF(ICHAR2.EQ.'CINT')GOTO5000
14441      IF(ICHAR2.EQ.'INFI')GOTO5100
14442      IF(ICHAR2.EQ.'%   ')GOTO5200
14443      IF(ICHAR2.EQ.'&   ')GOTO5300
14444      IF(ICHAR2.EQ.'@   ')GOTO5400
14445      IF(ICHAR2.EQ.'$   ')GOTO5500
14446      IF(ICHAR2.EQ.'#   ')GOTO5600
14447      IF(ICHAR2.EQ.'PARA')GOTO5700
14448      IF(ICHAR2.EQ.'DAGG')GOTO5800
14449      IF(ICHAR2.EQ.'DDAG')GOTO5900
14450      IF(ICHAR2.EQ.'THEX')GOTO6000
14451      IF(ICHAR2.EQ.'PROD')GOTO6100
14452      IF(ICHAR2.EQ.'SUMM')GOTO6200
14453      IF(ICHAR2.EQ.'THFO')GOTO6300
14454      IF(ICHAR2.EQ.'LVBA')GOTO6400
14455      IF(ICHAR2.EQ.'HBAR')GOTO6500
14456      IF(ICHAR2.EQ.'LHBA')GOTO6600
14457C
14458      IF(ICHAR2.EQ.'.   ')GOTO10100
14459      IF(ICHAR2.EQ.'POIN')GOTO10100
14460      IF(ICHAR2.EQ.'PO  ')GOTO10100
14461      IF(ICHAR2.EQ.'PT  ')GOTO10100
14462      IF(ICHAR2.EQ.'CIRC')GOTO10200
14463      IF(ICHAR2.EQ.'CI  ')GOTO10200
14464      IF(ICHAR2.EQ.'SQUA')GOTO10300
14465      IF(ICHAR2.EQ.'SQ  ')GOTO10300
14466      IF(ICHAR2.EQ.'TRIA')GOTO10400
14467      IF(ICHAR2.EQ.'TR  ')GOTO10400
14468      IF(ICHAR2.EQ.'DIAM')GOTO10500
14469      IF(ICHAR2.EQ.'DI  ')GOTO10500
14470      IF(ICHAR2.EQ.'STAR')GOTO10600
14471      IF(ICHAR2.EQ.'ST  ')GOTO10600
14472      IF(ICHAR2.EQ.'*   ')GOTO10700
14473      IF(ICHAR2.EQ.'ASTE')GOTO10700
14474      IF(ICHAR2.EQ.'AS  ')GOTO10700
14475      IF(ICHAR2.EQ.'TRIR')GOTO10800
14476      IF(ICHAR2.EQ.'TRII')GOTO10800
14477C  AUGUST 1992.  ADD FOLLOWING 2 LINES (TO MAKE DOCUMENTATION CORRECT)
14478      IF(ICHAR2.EQ.'REVT')GOTO10800
14479      IF(ICHAR2.EQ.'RT  ')GOTO10800
14480C
14481      IF(ICHAR2.EQ.'BARU')GOTO10900
14482      IF(ICHAR2.EQ.'BU  ')GOTO10900
14483      IF(ICHAR2.EQ.'BARV')GOTO10900
14484      IF(ICHAR2.EQ.'BV  ')GOTO10900
14485      IF(ICHAR2.EQ.'BARH')GOTO11000
14486      IF(ICHAR2.EQ.'BH  ')GOTO11000
14487      IF(ICHAR2.EQ.'ARRU')GOTO11100
14488      IF(ICHAR2.EQ.'AU  ')GOTO11100
14489      IF(ICHAR2.EQ.'ARRD')GOTO11200
14490      IF(ICHAR2.EQ.'AD  ')GOTO11200
14491      IF(ICHAR2.EQ.'ARRL')GOTO11300
14492      IF(ICHAR2.EQ.'AL  ')GOTO11300
14493      IF(ICHAR2.EQ.'ARRR')GOTO11400
14494      IF(ICHAR2.EQ.'AR  ')GOTO11400
14495      CALL DPCONA(92,IBASLC)
14496      IF(ICHAR2.EQ.IBASLC)GOTO11500
14497      IF(ICHAR2.EQ.'BASL')GOTO11500
14498      IF(ICHAR2.EQ.'BACK')GOTO11500
14499      IF(ICHAR2.EQ.'BS  ')GOTO11500
14500      IF(ICHAR2.EQ.'_   ')GOTO11600
14501      IF(ICHAR2.EQ.'UNDE')GOTO11600
14502      IF(ICHAR2.EQ.'CUBE')GOTO11700
14503      IF(ICHAR2.EQ.'PYRA')GOTO11800
14504C  AUGUST 1992.  ADD AN ARROW OPTION
14505      IF(ICHAR2.EQ.'ARRO')GOTO11900
14506      IF(ICHAR2.EQ.'ARRH')GOTO11900
14507      IF(ICHAR2.EQ.'VECT')GOTO11900
14508C
14509      GOTO17900
14510C
14511  100 CONTINUE
14512      ICHARN=1
14513      GOTO18000
14514C
14515  200 CONTINUE
14516      ICHARN=2
14517      GOTO18000
14518C
14519  300 CONTINUE
14520      ICHARN=3
14521      GOTO18000
14522C
14523  400 CONTINUE
14524      ICHARN=4
14525      GOTO18000
14526C
14527  500 CONTINUE
14528      ICHARN=5
14529      GOTO18000
14530C
14531  600 CONTINUE
14532      ICHARN=6
14533      GOTO18000
14534C
14535  700 CONTINUE
14536      ICHARN=7
14537      GOTO18000
14538C
14539  800 CONTINUE
14540      ICHARN=8
14541      GOTO18000
14542C
14543  900 CONTINUE
14544      ICHARN=9
14545      GOTO18000
14546C
14547 1000 CONTINUE
14548      ICHARN=10
14549      GOTO18000
14550C
14551 1100 CONTINUE
14552      ICHARN=11
14553      GOTO18000
14554C
14555 1200 CONTINUE
14556      ICHARN=12
14557      GOTO18000
14558C
14559 1300 CONTINUE
14560      ICHARN=13
14561      GOTO18000
14562C
14563 1400 CONTINUE
14564      ICHARN=14
14565      GOTO18000
14566C
14567 1500 CONTINUE
14568      ICHARN=15
14569      GOTO18000
14570C
14571 1600 CONTINUE
14572      ICHARN=16
14573      GOTO18000
14574C
14575 1700 CONTINUE
14576      ICHARN=17
14577      GOTO18000
14578C
14579 1800 CONTINUE
14580      ICHARN=18
14581      GOTO18000
14582C
14583 1900 CONTINUE
14584      ICHARN=19
14585      GOTO18000
14586C
14587 2000 CONTINUE
14588      ICHARN=20
14589      GOTO18000
14590C
14591 2100 CONTINUE
14592      ICHARN=21
14593      GOTO18000
14594C
14595 2200 CONTINUE
14596      ICHARN=22
14597      GOTO18000
14598C
14599 2300 CONTINUE
14600      ICHARN=23
14601      GOTO18000
14602C
14603 2400 CONTINUE
14604      ICHARN=24
14605      GOTO18000
14606C
14607 2500 CONTINUE
14608      ICHARN=25
14609      GOTO18000
14610C
14611 2600 CONTINUE
14612      ICHARN=26
14613      GOTO18000
14614C
14615 2700 CONTINUE
14616      ICHARN=27
14617      GOTO18000
14618C
14619 2800 CONTINUE
14620      ICHARN=28
14621      GOTO18000
14622C
14623 2900 CONTINUE
14624      ICHARN=29
14625      GOTO18000
14626C
14627 3000 CONTINUE
14628      ICHARN=30
14629      GOTO18000
14630C
14631 3100 CONTINUE
14632      ICHARN=31
14633      GOTO18000
14634C
14635 3200 CONTINUE
14636      ICHARN=32
14637      GOTO18000
14638C
14639 3300 CONTINUE
14640      ICHARN=33
14641      GOTO18000
14642C
14643 3400 CONTINUE
14644      ICHARN=34
14645      GOTO18000
14646C
14647 3500 CONTINUE
14648      ICHARN=35
14649      GOTO18000
14650C
14651 3600 CONTINUE
14652      ICHARN=36
14653      GOTO18000
14654C
14655 3700 CONTINUE
14656      ICHARN=37
14657      GOTO18000
14658C
14659 3800 CONTINUE
14660      ICHARN=38
14661      GOTO18000
14662C
14663 3900 CONTINUE
14664      ICHARN=39
14665      GOTO18000
14666C
14667 4000 CONTINUE
14668      ICHARN=40
14669      GOTO18000
14670C
14671 4100 CONTINUE
14672      ICHARN=41
14673      GOTO18000
14674C
14675 4200 CONTINUE
14676      ICHARN=42
14677      GOTO18000
14678C
14679 4300 CONTINUE
14680      ICHARN=43
14681      GOTO18000
14682C
14683 4400 CONTINUE
14684      ICHARN=44
14685      GOTO18000
14686C
14687 4500 CONTINUE
14688      ICHARN=45
14689      GOTO18000
14690C
14691 4600 CONTINUE
14692      ICHARN=46
14693      GOTO18000
14694C
14695 4700 CONTINUE
14696      ICHARN=47
14697      GOTO18000
14698C
14699 4800 CONTINUE
14700      ICHARN=48
14701      GOTO18000
14702C
14703 4900 CONTINUE
14704      ICHARN=49
14705      GOTO18000
14706C
14707 5000 CONTINUE
14708      ICHARN=50
14709      GOTO18000
14710C
14711 5100 CONTINUE
14712      ICHARN=51
14713      GOTO18000
14714C
14715 5200 CONTINUE
14716      ICHARN=52
14717      GOTO18000
14718C
14719 5300 CONTINUE
14720      ICHARN=53
14721      GOTO18000
14722C
14723 5400 CONTINUE
14724      ICHARN=54
14725      GOTO18000
14726C
14727 5500 CONTINUE
14728      ICHARN=55
14729      GOTO18000
14730C
14731 5600 CONTINUE
14732      ICHARN=56
14733      GOTO18000
14734C
14735 5700 CONTINUE
14736      ICHARN=57
14737      GOTO18000
14738C
14739 5800 CONTINUE
14740      ICHARN=58
14741      GOTO18000
14742C
14743 5900 CONTINUE
14744      ICHARN=59
14745      GOTO18000
14746C
14747 6000 CONTINUE
14748      ICHARN=60
14749      GOTO18000
14750C
14751 6100 CONTINUE
14752      ICHARN=61
14753      GOTO18000
14754C
14755 6200 CONTINUE
14756      ICHARN=62
14757      GOTO18000
14758C
14759 6300 CONTINUE
14760      ICHARN=63
14761      GOTO18000
14762C
14763 6400 CONTINUE
14764      ICHARN=64
14765      GOTO18000
14766C
14767 6500 CONTINUE
14768      ICHARN=65
14769      GOTO18000
14770C
14771 6600 CONTINUE
14772      ICHARN=66
14773      GOTO18000
14774C
1477510100 CONTINUE
14776      ICHARN=101
14777      GOTO18000
14778C
1477910200 CONTINUE
14780      ICHARN=102
14781      GOTO18000
14782C
1478310300 CONTINUE
14784      ICHARN=103
14785      GOTO18000
14786C
1478710400 CONTINUE
14788      ICHARN=104
14789      GOTO18000
14790C
1479110500 CONTINUE
14792      ICHARN=105
14793      GOTO18000
14794C
1479510600 CONTINUE
14796      ICHARN=106
14797      GOTO18000
14798C
1479910700 CONTINUE
14800      ICHARN=107
14801      GOTO18000
14802C
1480310800 CONTINUE
14804      ICHARN=108
14805      GOTO18000
14806C
1480710900 CONTINUE
14808      ICHARN=109
14809      GOTO18000
14810C
1481111000 CONTINUE
14812      ICHARN=110
14813      GOTO18000
14814C
1481511100 CONTINUE
14816      ICHARN=111
14817      GOTO18000
14818C
1481911200 CONTINUE
14820      ICHARN=112
14821      GOTO18000
14822C
1482311300 CONTINUE
14824      ICHARN=113
14825      GOTO18000
14826C
1482711400 CONTINUE
14828      ICHARN=114
14829      GOTO18000
14830C
1483111500 CONTINUE
14832      ICHARN=115
14833      GOTO18000
14834C
1483511600 CONTINUE
14836      ICHARN=116
14837      GOTO18000
14838C
1483911700 CONTINUE
14840      ICHARN=117
14841      GOTO18000
14842C
1484311800 CONTINUE
14844      ICHARN=118
14845      GOTO18000
14846C  AUGUST 1992.  ADDED FOLLOWING 3 LINES
1484711900 CONTINUE
14848      ICHARN=119
14849      GOTO18000
14850C
1485117900 CONTINUE
14852CCCCC WRITE(ICOUT,999)
14853CCCCC CALL DPWRST('XXX','BUG ')
14854CCCCC WRITE(ICOUT,7911)
14855C7911 FORMAT('***** ERROR IN DPCHMA--')
14856CCCCC CALL DPWRST('XXX','BUG ')
14857CCCCC WRITE(ICOUT,7912)
14858C7912 FORMAT('      NO MATCH FOUND FOR INPUT CHARACTER.')
14859CCCCC CALL DPWRST('XXX','BUG ')
14860CCCCC WRITE(ICOUT,7913)ICHAR2
14861C7913 FORMAT('      INPUT CHARACTER = ',A4)
14862CCCCC CALL DPWRST('XXX','BUG ')
14863      IFOUND='NO'
14864      GOTO19000
14865C
1486618000 CONTINUE
14867      IFOUND='YES'
14868      GOTO19000
14869C
14870C               *****************
14871C               **  STEP 90--  **
14872C               **  EXIT       **
14873C               *****************
14874C
1487519000 CONTINUE
14876      IF(IBUG.EQ.'ON' .OR. ISUBG4.EQ.'CHMA')THEN
14877        WRITE(ICOUT,999)
14878        CALL DPWRST('XXX','BUG ')
14879        WRITE(ICOUT,19011)
1488019011   FORMAT('***** AT THE END       OF DPCHMA--')
14881        CALL DPWRST('XXX','BUG ')
14882        WRITE(ICOUT,19013)IFOUND,ICHAR2,ICHARN
1488319013   FORMAT('IFOUND,ICHAR2,ICHARN = ',2(A4,2X),I8)
14884        CALL DPWRST('XXX','BUG ')
14885      ENDIF
14886C
14887      RETURN
14888      END
14889      SUBROUTINE DPCHNU(ICHAR2,ICHARN,IBUG,IFOUND)
14890C
14891C     PURPOSE--CONVERT AN ALPHABETIC CHARACTER
14892C              (0 TO 9) INTO A NUMERIC VALUE
14893C              (1 TO 10).
14894C     INPUT  ARGUMENTS--ICHAR2 (A HOLLERITH VARIABLE
14895C                              CONTAINING THE HOLLERITH
14896C                              CHARACTER(S) OF INTEREST.
14897C     OUTPUT ARGUMENTS--ICHARN (AN INTEGER VARIABLE
14898C                              CONTAINING THE NUMERIC
14899C                              DESIGNATION FOR THE
14900C                              ALPHABETIC CHARACTER.
14901C     WRITTEN BY--JAMES J. FILLIBEN
14902C                 STATISTICAL ENGINEERING DIVISION
14903C                 INFORMATION TECHNOLOGY LABORATORY
14904C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
14905C                 GAITHERSBURG, MD 20899-8980
14906C                 PHONE--301-975-2899
14907C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
14908C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
14909C     LANGUAGE--ANSI FORTRAN (1977)
14910C     VERSION NUMBER--82/7
14911C     ORIGINAL VERSION--MARCH     1981.
14912C     UPDATED         --NOVEMBER  1981.
14913C     UPDATED         --MAY       1982.
14914C
14915C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
14916C
14917      CHARACTER*4 ICHAR2
14918      CHARACTER*4 IBUG
14919      CHARACTER*4 IFOUND
14920C
14921      CHARACTER*1 ICH1
14922      CHARACTER*1 ICH2
14923C
14924C-----COMMON----------------------------------------------------------
14925C
14926      INCLUDE 'DPCOBE.INC'
14927C
14928C-----COMMON VARIABLES (GENERAL)--------------------------------------
14929C
14930      INCLUDE 'DPCOP2.INC'
14931C
14932C-----START POINT-----------------------------------------------------
14933C
14934      IFOUND='NO'
14935C
14936      ICH1='-'
14937      ICH2='-'
14938C
14939      ICH1N=(-999)
14940      ICH2N=(-999)
14941C
14942      IF(IBUG.EQ.'ON' .OR. ISUBG4.EQ.'CHNU')THEN
14943        WRITE(ICOUT,999)
14944  999   FORMAT(1X)
14945        CALL DPWRST('XXX','BUG ')
14946        WRITE(ICOUT,51)
14947   51   FORMAT('***** AT THE BEGINNING OF DPCHNU--')
14948        CALL DPWRST('XXX','BUG ')
14949        WRITE(ICOUT,59)ICHAR2,IBUGG4,ISUBG4
14950   59   FORMAT('ICHAR2,IBUGG4,ISUBG4 = ',2(A4,2X),A4)
14951        CALL DPWRST('XXX','BUG ')
14952      ENDIF
14953C
14954C               **********************************
14955C               **  STEP 1--                    **
14956C               **  CONVERT THE CHARACTER       **
14957C               **********************************
14958C
14959      ICH2(1:1)=ICHAR2(2:2)
14960CCCCC ICH2N=ICHAR(ICH2)
14961      CALL DPCOAN(ICH2,ICH2N)
14962      IF(ICH2N.EQ.32)GOTO1100
14963      GOTO7900
14964C
14965 1100 CONTINUE
14966      ICH1(1:1)=ICHAR2(1:1)
14967CCCCC ICH1N=ICHAR(ICH1)
14968      CALL DPCOAN(ICH1,ICH1N)
14969      ICHARN=ICH1N-47
14970      IF(1.LE.ICHARN.AND.ICHARN.LE.10)GOTO8000
14971      GOTO7900
14972C
14973 7900 CONTINUE
14974CCCCC WRITE(ICOUT,999)
14975CCCCC CALL DPWRST('XXX','BUG ')
14976CCCCC WRITE(ICOUT,7911)
14977C7911 FORMAT('***** ERROR IN DPCHNU--')
14978CCCCC CALL DPWRST('XXX','BUG ')
14979CCCCC WRITE(ICOUT,7912)
14980C7912 FORMAT('      NO MATCH FOUND FOR INPUT CHARACTER.')
14981CCCCC CALL DPWRST('XXX','BUG ')
14982CCCCC WRITE(ICOUT,7913)ICHAR
14983C7913 FORMAT('      INPUT CHARACTER = ',A4)
14984CCCCC CALL DPWRST('XXX','BUG ')
14985      IFOUND='NO'
14986      GOTO9000
14987C
14988 8000 CONTINUE
14989      IFOUND='YES'
14990      GOTO9000
14991C
14992C               *****************
14993C               **  STEP 90--  **
14994C               **  EXIT       **
14995C               *****************
14996C
14997 9000 CONTINUE
14998      IF(IBUG.EQ.'ON' .OR. ISUBG4.EQ.'CHNU')THEN
14999        WRITE(ICOUT,999)
15000        CALL DPWRST('XXX','BUG ')
15001        WRITE(ICOUT,9011)
15002 9011   FORMAT('***** AT THE END       OF DPCHAL--')
15003        CALL DPWRST('XXX','BUG ')
15004        WRITE(ICOUT,9012)ICH1,ICH1N,ICH2,ICH2N
15005 9012   FORMAT('ICH1,ICH1N,ICH2,ICH2N = ',A1,2X,I8,2X,A1,2X,I8)
15006        CALL DPWRST('XXX','BUG ')
15007        WRITE(ICOUT,9014)IFOUND,ICHAR2,ICHARN
15008 9014   FORMAT('IFOUND,ICHAR2,ICHARN = ',2(A4,2X),I8)
15009        CALL DPWRST('XXX','BUG ')
15010      ENDIF
15011C
15012      RETURN
15013      END
15014      SUBROUTINE DPCHOF(IHARG,IARGT,ARG,NUMARG,
15015     1                  MAXCHA,
15016     1                  PCHAHO,PCHAVO,
15017     1                  IFOUND,IERROR)
15018C
15019C     PURPOSE--DEFINE PLOT CHARACTER (HORIZONTAL AND VERTICAL) OFFSET
15020C              FOR USE IN MULTI-TRACE PLOTS.
15021C              THE OFFSET FOR THE CHARACTER FOR THE I-TH TRACE
15022C              WILL BE PLACED
15023C              IN THE I-TH ELEMENT OF THE FLOATING POINT
15024C              VECTORS PCHAHO(.) AND PCHAVO(.).
15025C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
15026C                     --IARGT  (A  HOLLERITH VECTOR)
15027C                     --ARG    (A  HOLLERITH VECTOR)
15028C                     --NUMARG
15029C                     --MAXCHA
15030C     OUTPUT ARGUMENTS--PCHAHO  (A  FLOATING POINT VECTOR
15031C                       WHOSE I-TH ELEMENT IS THE HORIZONTAL OFFSET
15032C                       FOR THE CHARACTER
15033C                       ASSIGNED TO THE I-TH    TRACE    IN
15034C                       A MULTI-TRACE PLOT.
15035C                     --PCHAVO  (A  FLOATING POINT VECTOR
15036C                       WHOSE I-TH ELEMENT IS THE VERTICAL OFFSET
15037C                       FOR THE CHARACTER
15038C                       ASSIGNED TO THE I-TH    TRACE    IN
15039C                       A MULTI-TRACE PLOT.
15040C                     --PCHAHO = CHARACTER WIDTH
15041C                     --PCHAVG = VERTICAL GAP BETWEEN CHARACTERS
15042C                     --PCHAHG = HORIZONTAL GAP BETWEEN CHARACTERS
15043C                     --IFOUND ('YES' OR 'NO' )
15044C                     --IERROR ('YES' OR 'NO' )
15045C     WRITTEN BY--JAMES J. FILLIBEN
15046C                 STATISTICAL ENGINEERING DIVISION
15047C                 INFORMATION TECHNOLOGY LABORATORY
15048C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
15049C                 GAITHERSBURG, MD 20899-8980
15050C                 PHONE--301-975-2899
15051C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
15052C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
15053C     LANGUAGE--ANSI FORTRAN (1977)
15054C     VERSION NUMBER--82/7
15055C     ORIGINAL VERSION--NOVEMBER  1986.
15056C     UPDATED         --AUGUST    1988.  CORRECTED FORMAT STATEMENT
15057C     UPDATED         --AUGUST    1988.  CORRECTED LOOP LOGIC
15058C
15059C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
15060C
15061      CHARACTER*4 IHARG
15062      CHARACTER*4 IARGT
15063      CHARACTER*4 IFOUND
15064      CHARACTER*4 IERROR
15065C
15066C---------------------------------------------------------------------
15067C
15068      DIMENSION IHARG(*)
15069      DIMENSION IARGT(*)
15070      DIMENSION ARG(*)
15071C
15072      DIMENSION PCHAHO(*)
15073      DIMENSION PCHAVO(*)
15074C
15075C---------------------------------------------------------------------
15076C
15077      INCLUDE 'DPCOP2.INC'
15078C
15079C-----START POINT-----------------------------------------------------
15080C
15081      IFOUND='NO'
15082      IERROR='NO'
15083C
15084      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'OFFS')GOTO1160
15085      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'DISP')GOTO1160
15086      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'OFFS')GOTO1105
15087      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'DISP')GOTO1105
15088      GOTO2199
15089C
15090 1105 CONTINUE
15091      IF(IHARG(NUMARG).EQ.'ON')GOTO1110
15092      IF(IHARG(NUMARG).EQ.'OFF')GOTO1110
15093      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1110
15094      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1110
15095C
15096      IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'ALL')GOTO1160
15097      IF(NUMARG.EQ.3)GOTO1120
15098      IF(NUMARG.GE.4.AND.IHARG(2).EQ.'ALL')GOTO1130
15099      IF(NUMARG.GE.4.AND.IHARG(4).EQ.'ALL')GOTO1140
15100C
15101      GOTO1150
15102C
15103 1110 CONTINUE
15104      DO1115I=1,MAXCHA
15105      PCHAVO(I)=0.0
15106      PCHAHO(I)=0.0
15107 1115 CONTINUE
15108C
15109      IF(IFEEDB.EQ.'OFF')GOTO1119
15110      WRITE(ICOUT,999)
15111  999 FORMAT(1X)
15112      CALL DPWRST('XXX','BUG ')
15113      I=1
15114      WRITE(ICOUT,1116)
15115 1116 FORMAT('ALL CHARACTER (HORIZ. AND VERT.) OFFSETS')
15116      CALL DPWRST('XXX','BUG ')
15117      WRITE(ICOUT,1117)PCHAHO(I),PCHAVO(I)
15118 1117 FORMAT('    HAVE JUST BEEN SET TO ',2E15.7)
15119      CALL DPWRST('XXX','BUG ')
15120 1119 CONTINUE
15121      GOTO2190
15122C
15123 1120 CONTINUE
15124      I=1
15125      IF(IARGT(2).NE.'NUMB'.OR.IARGT(3).NE.'NUMB')GOTO1180
15126      PCHAHO(1)=ARG(2)
15127      PCHAVO(1)=ARG(3)
15128C
15129      IF(IFEEDB.EQ.'OFF')GOTO1129
15130      WRITE(ICOUT,999)
15131      CALL DPWRST('XXX','BUG ')
15132      I=1
15133      WRITE(ICOUT,1126)I
15134 1126 FORMAT('THE (HORIZ. AND VERT.) OFFSET FOR CHARACTER ',I6)
15135      CALL DPWRST('XXX','BUG ')
15136      WRITE(ICOUT,1127)PCHAHO(I),PCHAVO(I)
15137 1127 FORMAT('    HAS JUST BEEN SET TO ',2E15.7)
15138      CALL DPWRST('XXX','BUG ')
15139 1129 CONTINUE
15140      GOTO2190
15141C
15142 1130 CONTINUE
15143      I=1
15144      IF(IARGT(3).NE.'NUMB'.OR.IARGT(4).NE.'NUMB')GOTO1180
15145      DO1135I=1,MAXCHA
15146      PCHAHO(I)=ARG(3)
15147      PCHAVO(I)=ARG(4)
15148 1135 CONTINUE
15149C
15150      IF(IFEEDB.EQ.'OFF')GOTO1139
15151      WRITE(ICOUT,999)
15152      CALL DPWRST('XXX','BUG ')
15153      I=1
15154      WRITE(ICOUT,1116)
15155      CALL DPWRST('XXX','BUG ')
15156      WRITE(ICOUT,1117)PCHAHO(I),PCHAVO(I)
15157      CALL DPWRST('XXX','BUG ')
15158 1139 CONTINUE
15159      GOTO2190
15160C
15161 1140 CONTINUE
15162      I=1
15163      IF(IARGT(2).NE.'NUMB'.OR.IARGT(3).NE.'NUMB')GOTO1180
15164      DO1145I=1,MAXCHA
15165      PCHAHO(I)=ARG(2)
15166      PCHAVO(I)=ARG(3)
15167 1145 CONTINUE
15168C
15169      IF(IFEEDB.EQ.'OFF')GOTO1149
15170      WRITE(ICOUT,999)
15171      CALL DPWRST('XXX','BUG ')
15172      I=1
15173      WRITE(ICOUT,1116)
15174      CALL DPWRST('XXX','BUG ')
15175      WRITE(ICOUT,1117)PCHAHO(I),PCHAVO(I)
15176      CALL DPWRST('XXX','BUG ')
15177 1149 CONTINUE
15178      GOTO2190
15179C
15180 1150 CONTINUE
15181      IMAX=NUMARG-1
15182      IF(MAXCHA.LT.IMAX)IMAX=MAXCHA
15183CCCCC THE FOLLOWING 1 LINE WAS INSERTED IN AUGUST 1988
15184      J=0
15185      DO1155I=1,IMAX,2
15186      IP1=I+1
15187      IP2=I+2
15188      IF(IARGT(IP1).NE.'NUMB')GOTO1180
15189      IF(IARGT(IP2).NE.'NUMB')GOTO1180
15190CCCCC PCHAHO(I)=ARG(IP1)                  AUGUST 1988
15191CCCCC PCHAVO(I)=ARG(IP2)                  AUGUST 1988
15192CCCCC THE FOLLOWING 3 LINES WERE INSERTED IN AUGUST 1988
15193      J=J+1
15194      PCHAHO(J)=ARG(IP1)
15195      PCHAVO(J)=ARG(IP2)
15196 1155 CONTINUE
15197CCCCC THE FOLLOWING 1 LINE WAS INSERTED IN AUGUST 1988
15198      JMAX=J
15199C
15200      IF(IFEEDB.EQ.'OFF')GOTO1159
15201      WRITE(ICOUT,999)
15202      CALL DPWRST('XXX','BUG ')
15203CCCCC DO1156I=1,IMAX                      AUGUST 1988
15204CCCCC THE FOLLOWING 1 LINE WAS INSERTED IN AUGUST 1988
15205      DO1156I=1,JMAX
15206      WRITE(ICOUT,1126)I
15207      CALL DPWRST('XXX','BUG ')
15208CCCCC WRITE(ICOUT,1127)I,PCHAHO(I),PCHAVO(I)             AUGUST 1988
15209CCCCC CALL DPWRST('XXX','BUG ')
15210      WRITE(ICOUT,1127)PCHAHO(I),PCHAVO(I)
15211      CALL DPWRST('XXX','BUG ')
15212 1156 CONTINUE
15213 1159 CONTINUE
15214      GOTO2190
15215C
15216 1160 CONTINUE
15217      DO1165I=1,MAXCHA
15218      PCHAHO(I)=0.0
15219      PCHAVO(I)=0.0
15220 1165 CONTINUE
15221C
15222      IF(IFEEDB.EQ.'OFF')GOTO1169
15223      WRITE(ICOUT,999)
15224      CALL DPWRST('XXX','BUG ')
15225      I=1
15226      WRITE(ICOUT,1116)
15227      CALL DPWRST('XXX','BUG ')
15228      WRITE(ICOUT,1117)PCHAHO(I),PCHAVO(I)
15229      CALL DPWRST('XXX','BUG ')
15230 1169 CONTINUE
15231      GOTO2190
15232C
15233 1180 CONTINUE
15234      IERROR='YES'
15235      WRITE(ICOUT,999)
15236      CALL DPWRST('XXX','BUG ')
15237      WRITE(ICOUT,1181)
15238 1181 FORMAT('***** ERROR IN DPCHOF--')
15239      CALL DPWRST('XXX','BUG ')
15240      WRITE(ICOUT,1182)
15241 1182 FORMAT('CHARACTER (HORIZ. AND VERT.) OFFSETS MUST BE NUMERIC')
15242      CALL DPWRST('XXX','BUG ')
15243      WRITE(ICOUT,1183)
15244 1183 FORMAT('HOWEVER, THE SPECIFIED CHARACTER OFFSET')
15245      CALL DPWRST('XXX','BUG ')
15246      WRITE(ICOUT,1184)I
15247 1184 FORMAT('FOR CHARACTER ',I6,' WAS NON-NUMERIC.')
15248      CALL DPWRST('XXX','BUG ')
15249      GOTO2199
15250C
15251 2190 CONTINUE
15252      IFOUND='YES'
15253C
15254 2199 CONTINUE
15255      RETURN
15256      END
15257      SUBROUTINE DPCHS3(ICASPL,IDIST,NUMSHA,IFORSW,ICASP3,
15258     1                  PID,IVARID,IVARI2,NREPL,
15259     1                  N,XMEAN,XSD,XMIN,XMAX,
15260     1                  A,B,MINMAX,
15261     1                  SHAPE1,SHAPE2,SHAPE3,SHAPE4,
15262     1                  SHAPE5,SHAPE6,SHAPE7,
15263     1                  KSLOC,KSSCAL,ICAPSW,ICAPTY,
15264     1                  STATVA,STATCD,PVAL,NCELLS,IDF,IDISFL,MINSZ,
15265     1                  CDF1,CDF2,CDF3,CDF4,
15266     1                  IBUGA3,ISUBRO,IERROR)
15267C
15268C     PURPOSE--PRINT THE OUTPUT FOR THE CHI-SQUARE TEST (GROUPED,
15269C              UNCENSORED CASE) IN ASCII, HTML, LATEX, OR RTF FORMAT
15270C     WRITTEN BY--ALAN HECKERT
15271C                 STATISTICAL ENGINEERING DIVISION
15272C                 INFORMATION TECHNOLOGY LABORATORY
15273C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
15274C                 GAITHERSBURG, MD 20899-8980
15275C                 PHONE--301-975-2899
15276C         --DATAPLOT IS A REGISTERED TRADEMARK
15277C           OF THE NATIONAL BUREAU OF STANDARDS.
15278C     LANGUAGE--ANSI FORTRAN (1977)
15279C     VERSION NUMBER--2009/12
15280C     ORIGINAL VERSION--DECEMBER  2009.
15281C
15282C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
15283C
15284      REAL PID(*)
15285C
15286      CHARACTER*4 IVARID(*)
15287      CHARACTER*4 IVARI2(*)
15288C
15289      CHARACTER*4 ICASPL
15290      CHARACTER*4 ICASP3
15291      CHARACTER*4 ICAPSW
15292      CHARACTER*4 ICAPTY
15293      CHARACTER*4 IDISFL
15294      CHARACTER*4 IFORSW
15295      CHARACTER*4 IBUGA3
15296      CHARACTER*4 ISUBRO
15297      CHARACTER*4 IWRITE
15298      CHARACTER*4 IERROR
15299C
15300      CHARACTER*60 IDIST
15301C
15302      CHARACTER*4 IRTFMD
15303      COMMON/COMRTF/IRTFMD
15304C
15305      CHARACTER*4 ISUBN1
15306      CHARACTER*4 ISUBN2
15307      CHARACTER*4 ISTEPN
15308C
15309      REAL KSLOC
15310      REAL KSSCAL
15311C
15312C---------------------------------------------------------------------
15313C
15314      PARAMETER (NUMALP=8)
15315      REAL ALPHA(NUMALP)
15316C
15317CCCCC INCLUDE 'DPCOST.INC'
15318C
15319      CHARACTER*1 IBASLC
15320      PARAMETER(NUMCLI=4)
15321      PARAMETER(MAXLIN=2)
15322      PARAMETER (MAXROW=50)
15323      CHARACTER*60 ITITLE
15324      CHARACTER*60  ITITLZ
15325      CHARACTER*60  ITITL9
15326      CHARACTER*60 ITEXT(MAXROW)
15327      CHARACTER*4  ALIGN(NUMCLI)
15328      CHARACTER*4  VALIGN(NUMCLI)
15329      REAL         AVALUE(MAXROW)
15330      INTEGER      NCTEXT(MAXROW)
15331      INTEGER      IDIGIT(MAXROW)
15332      INTEGER      NTOT(MAXROW)
15333      CHARACTER*60 ITITL2(MAXLIN,NUMCLI)
15334      CHARACTER*15 IVALUE(MAXROW,NUMCLI)
15335      CHARACTER*4  ITYPCO(NUMCLI)
15336      INTEGER      NCTIT2(MAXLIN,NUMCLI)
15337      INTEGER      NCVALU(MAXROW,NUMCLI)
15338      INTEGER      IWHTML(NUMCLI)
15339      INTEGER      IWRTF(NUMCLI)
15340      REAL         AMAT(MAXROW,NUMCLI)
15341      LOGICAL IFRST
15342      LOGICAL ILAST
15343C
15344C---------------------------------------------------------------------
15345C
15346      INCLUDE 'DPCOP2.INC'
15347C
15348      DATA ALPHA/
15349     1 0.0, 50.0, 75.0, 90.0, 95.0, 97.5, 99.0, 99.5/
15350C
15351C-----START POINT-----------------------------------------------------
15352C
15353C
15354      ISUBN1='DPCH'
15355      ISUBN2='SQ  '
15356      IERROR='NO'
15357      IWRITE='OFF'
15358      CALL DPCONA(92,IBASLC)
15359C
15360      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CHS3')THEN
15361        WRITE(ICOUT,999)
15362  999   FORMAT(1X)
15363        CALL DPWRST('XXX','BUG ')
15364        WRITE(ICOUT,71)
15365   71   FORMAT('***** AT THE BEGINNING OF DPCHS3--')
15366        CALL DPWRST('XXX','BUG ')
15367        WRITE(ICOUT,72)ICASPL,IDIST
15368   72   FORMAT('ICASPL,IDIST = ',A4,2X,A60)
15369        CALL DPWRST('XXX','BUG ')
15370        WRITE(ICOUT,73)N,MINMAX,XMIN,XMAX,XMEAN,XSD
15371   73   FORMAT('N,MINMAX,XMIN,XMAX,XMEAN,XSD = ',2I8,4G15.7)
15372        CALL DPWRST('XXX','BUG ')
15373        WRITE(ICOUT,75)STATVA,STATCD,PVAL
15374   75   FORMAT('STATVA,STATCD,PVAL = ',3G15.7)
15375        CALL DPWRST('XXX','BUG ')
15376      ENDIF
15377C
15378C               *******************************************
15379C               **   STEP 41--                           **
15380C               **   WRITE OUT INITIAL HEADER TABLE      **
15381C               *******************************************
15382C
15383      ISTEPN='41'
15384      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CHS3')
15385     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15386C
15387      IF(IPRINT.EQ.'OFF')GOTO9000
15388C
15389      NUMDIG=7
15390      IF(IFORSW.EQ.'1')NUMDIG=1
15391      IF(IFORSW.EQ.'2')NUMDIG=2
15392      IF(IFORSW.EQ.'3')NUMDIG=3
15393      IF(IFORSW.EQ.'4')NUMDIG=4
15394      IF(IFORSW.EQ.'5')NUMDIG=5
15395      IF(IFORSW.EQ.'6')NUMDIG=6
15396      IF(IFORSW.EQ.'7')NUMDIG=7
15397      IF(IFORSW.EQ.'8')NUMDIG=8
15398      IF(IFORSW.EQ.'9')NUMDIG=9
15399      IF(IFORSW.EQ.'0')NUMDIG=0
15400      IF(IFORSW.EQ.'E')NUMDIG=-2
15401      IF(IFORSW.EQ.'-2')NUMDIG=-2
15402      IF(IFORSW.EQ.'-3')NUMDIG=-3
15403      IF(IFORSW.EQ.'-4')NUMDIG=-4
15404      IF(IFORSW.EQ.'-5')NUMDIG=-5
15405      IF(IFORSW.EQ.'-6')NUMDIG=-6
15406      IF(IFORSW.EQ.'-7')NUMDIG=-7
15407      IF(IFORSW.EQ.'-8')NUMDIG=-8
15408      IF(IFORSW.EQ.'-9')NUMDIG=-9
15409C
15410      ITITLE='Chi-Square Goodness of Fit Test'
15411      NCTITL=31
15412C
15413      ICNT=1
15414      ITEXT(ICNT)=' '
15415      NCTEXT(ICNT)=0
15416      AVALUE(ICNT)=0.0
15417      IDIGIT(ICNT)=-1
15418      IF(ICASP3.EQ.'RAW')THEN
15419        ICNT=ICNT+1
15420        ITEXT(ICNT)='Response Variable: '
15421        WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1)(1:4)
15422        WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1)(1:4)
15423        NCTEXT(ICNT)=27
15424        AVALUE(ICNT)=0.0
15425        IDIGIT(ICNT)=-1
15426      ELSEIF(ICASP3.EQ.'FREQ')THEN
15427        ICNT=ICNT+1
15428        ITEXT(ICNT)='Bin Frequency Variable: '
15429        WRITE(ITEXT(ICNT)(25:28),'(A4)')IVARID(1)(1:4)
15430        WRITE(ITEXT(ICNT)(29:32),'(A4)')IVARI2(1)(1:4)
15431        NCTEXT(ICNT)=32
15432        AVALUE(ICNT)=0.0
15433        IDIGIT(ICNT)=-1
15434        ICNT=ICNT+1
15435        ITEXT(ICNT)='Bin Midpoint Variable:  '
15436        WRITE(ITEXT(ICNT)(25:28),'(A4)')IVARID(2)(1:4)
15437        WRITE(ITEXT(ICNT)(29:32),'(A4)')IVARI2(2)(1:4)
15438        NCTEXT(ICNT)=32
15439        AVALUE(ICNT)=0.0
15440        IDIGIT(ICNT)=-1
15441      ELSEIF(ICASP3.EQ.'FRE2')THEN
15442        ICNT=ICNT+1
15443        ITEXT(ICNT)='Bin Frequency Variable:       '
15444        WRITE(ITEXT(ICNT)(31:34),'(A4)')IVARID(1)(1:4)
15445        WRITE(ITEXT(ICNT)(35:38),'(A4)')IVARI2(1)(1:4)
15446        NCTEXT(ICNT)=38
15447        AVALUE(ICNT)=0.0
15448        IDIGIT(ICNT)=-1
15449        ICNT=ICNT+1
15450        ITEXT(ICNT)='Bin Lower Boundary Variable: '
15451        WRITE(ITEXT(ICNT)(31:34),'(A4)')IVARID(2)(1:4)
15452        WRITE(ITEXT(ICNT)(35:38),'(A4)')IVARI2(2)(1:4)
15453        NCTEXT(ICNT)=38
15454        AVALUE(ICNT)=0.0
15455        IDIGIT(ICNT)=-1
15456        ICNT=ICNT+1
15457        ITEXT(ICNT)='Bin Upper Boundary Variable: '
15458        WRITE(ITEXT(ICNT)(31:34),'(A4)')IVARID(3)(1:4)
15459        WRITE(ITEXT(ICNT)(35:38),'(A4)')IVARI2(3)(1:4)
15460        NCTEXT(ICNT)=38
15461        AVALUE(ICNT)=0.0
15462        IDIGIT(ICNT)=-1
15463      ENDIF
15464C
15465      DO4101I=1,NREPL
15466        ICNT=ICNT+1
15467        ITEXT(ICNT)='Factor Variable  : '
15468        WRITE(ITEXT(ICNT)(17:17),'(I1)')I
15469        WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(I+1)(1:4)
15470        WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(I+1)(1:4)
15471        NCTEXT(ICNT)=27
15472        AVALUE(ICNT)=PID(I+1)
15473        IDIGIT(ICNT)=NUMDIG
15474 4101 CONTINUE
15475C
15476      ICNT=ICNT+1
15477      ITEXT(ICNT)=' '
15478      NCTEXT(ICNT)=1
15479      AVALUE(ICNT)=0.0
15480      IDIGIT(ICNT)=-1
15481C
15482      ICNT=ICNT+1
15483      ITEXT(ICNT)='H0: The distribution fits the data'
15484      NCTEXT(ICNT)=34
15485      AVALUE(ICNT)=0.0
15486      IDIGIT(ICNT)=-1
15487      ICNT=ICNT+1
15488      ITEXT(ICNT)='Ha: The distribution does not fit the data'
15489      NCTEXT(ICNT)=43
15490      AVALUE(ICNT)=0.0
15491      IDIGIT(ICNT)=-1
15492C
15493      IEND=46
15494      DO4111I=46,1,-1
15495        IF(IDIST(I:I).NE.' ')THEN
15496          IEND=I
15497          GOTO4119
15498        ENDIF
15499 4111 CONTINUE
15500      IEND=1
15501 4119 CONTINUE
15502      CALL EXTBOU(ICASPL,IBOUND)
15503C
15504      ICNT=ICNT+1
15505      ITEXT(ICNT)=' '
15506      NCTEXT(ICNT)=1
15507      AVALUE(ICNT)=0.0
15508      IDIGIT(ICNT)=-1
15509      ICNT=ICNT+1
15510      ITEXT(ICNT)(1:14)='Distribution: '
15511      ISTRT=15
15512      ISTOP=15+IEND-1
15513      ITEXT(ICNT)(ISTRT:ISTOP)=IDIST(1:IEND)
15514      NCTEXT(ICNT)=ISTOP
15515      AVALUE(ICNT)=0.0
15516      IDIGIT(ICNT)=-1
15517C
15518      IF(IDISFL.EQ.'CONT')THEN
15519        IF(IBOUND.EQ.0)THEN
15520          ICNT=ICNT+1
15521          ITEXT(ICNT)='Location Parameter:'
15522          NCTEXT(ICNT)=19
15523          AVALUE(ICNT)=KSLOC
15524          IDIGIT(ICNT)=NUMDIG
15525          ICNT=ICNT+1
15526          ITEXT(ICNT)='Scale Parameter:'
15527          NCTEXT(ICNT)=16
15528          AVALUE(ICNT)=KSSCAL
15529          IDIGIT(ICNT)=NUMDIG
15530        ELSE
15531          ICNT=ICNT+1
15532          ITEXT(ICNT)='Lower Limit Parameter:'
15533          NCTEXT(ICNT)=22
15534          AVALUE(ICNT)=A
15535          IDIGIT(ICNT)=NUMDIG
15536          ICNT=ICNT+1
15537          ITEXT(ICNT)='Upper Limit Parameter:'
15538          NCTEXT(ICNT)=22
15539          AVALUE(ICNT)=B
15540          IDIGIT(ICNT)=NUMDIG
15541        ENDIF
15542      ENDIF
15543C
15544      IF(NUMSHA.GE.1)THEN
15545        DO4140I=1,NUMSHA
15546          ICNT=ICNT+1
15547          ITEXT(ICNT)='Shape Parameter  :'
15548          WRITE(ITEXT(ICNT)(17:17),'(I1)')I
15549          NCTEXT(ICNT)=18
15550          IF(I.EQ.1)THEN
15551            AVALUE(ICNT)=SHAPE1
15552          ELSEIF(I.EQ.2)THEN
15553            AVALUE(ICNT)=SHAPE2
15554          ELSEIF(I.EQ.3)THEN
15555            AVALUE(ICNT)=SHAPE3
15556          ELSEIF(I.EQ.4)THEN
15557            AVALUE(ICNT)=SHAPE4
15558          ELSEIF(I.EQ.5)THEN
15559            AVALUE(ICNT)=SHAPE5
15560          ELSEIF(I.EQ.6)THEN
15561            AVALUE(ICNT)=SHAPE6
15562          ELSEIF(I.EQ.7)THEN
15563            AVALUE(ICNT)=SHAPE7
15564          ENDIF
15565          IDIGIT(ICNT)=NUMDIG
15566 4140   CONTINUE
15567      ENDIF
15568C
15569      ICNT=ICNT+1
15570      ITEXT(ICNT)=' '
15571      NCTEXT(ICNT)=1
15572      AVALUE(ICNT)=0.0
15573      IDIGIT(ICNT)=-1
15574      ICNT=ICNT+1
15575      ITEXT(ICNT)='Summary Statistics:'
15576      NCTEXT(ICNT)=19
15577      AVALUE(ICNT)=0.0
15578      IDIGIT(ICNT)=-1
15579      ICNT=ICNT+1
15580      ITEXT(ICNT)='Total Number of Observations:'
15581      NCTEXT(ICNT)=29
15582      AVALUE(ICNT)=REAL(N)
15583      IDIGIT(ICNT)=0
15584      ICNT=ICNT+1
15585      ITEXT(ICNT)='Minimum Class Frequency'
15586      NCTEXT(ICNT)=24
15587      AVALUE(ICNT)=REAL(MINSZ)
15588      IDIGIT(ICNT)=0
15589      ICNT=ICNT+1
15590      ITEXT(ICNT)='Number of Non-Empty Cells'
15591      NCTEXT(ICNT)=25
15592      AVALUE(ICNT)=REAL(NCELLS)
15593      IDIGIT(ICNT)=0
15594      ICNT=ICNT+1
15595      ITEXT(ICNT)='Degress of Freedom'
15596      NCTEXT(ICNT)=18
15597      AVALUE(ICNT)=REAL(IDF)
15598      IDIGIT(ICNT)=0
15599      ICNT=ICNT+1
15600      ITEXT(ICNT)='Sample Minimum:'
15601      NCTEXT(ICNT)=15
15602      AVALUE(ICNT)=XMIN
15603      IDIGIT(ICNT)=NUMDIG
15604      ICNT=ICNT+1
15605      ITEXT(ICNT)='Sample Maximum:'
15606      NCTEXT(ICNT)=15
15607      AVALUE(ICNT)=XMAX
15608      IDIGIT(ICNT)=NUMDIG
15609      ICNT=ICNT+1
15610      ITEXT(ICNT)='Sample Mean:'
15611      NCTEXT(ICNT)=12
15612      AVALUE(ICNT)=XMEAN
15613      IDIGIT(ICNT)=NUMDIG
15614      ICNT=ICNT+1
15615      ITEXT(ICNT)='Sample SD:'
15616      NCTEXT(ICNT)=10
15617      AVALUE(ICNT)=XSD
15618      IDIGIT(ICNT)=NUMDIG
15619      ICNT=ICNT+1
15620      ITEXT(ICNT)=' '
15621      NCTEXT(ICNT)=1
15622      AVALUE(ICNT)=0.0
15623      IDIGIT(ICNT)=-1
15624      ICNT=ICNT+1
15625      ITEXT(ICNT)='Chi-Square Test Statistic Value:'
15626      NCTEXT(ICNT)=32
15627      AVALUE(ICNT)=STATVA
15628      IDIGIT(ICNT)=NUMDIG
15629      ICNT=ICNT+1
15630      ITEXT(ICNT)='CDF Value:'
15631      NCTEXT(ICNT)=10
15632      AVALUE(ICNT)=STATCD
15633      IDIGIT(ICNT)=NUMDIG
15634      ICNT=ICNT+1
15635      ITEXT(ICNT)='P-Value:'
15636      NCTEXT(ICNT)=7
15637      AVALUE(ICNT)=PVAL
15638      IDIGIT(ICNT)=NUMDIG
15639      ICNT=ICNT+1
15640      ITEXT(ICNT)=' '
15641      NCTEXT(ICNT)=1
15642      AVALUE(ICNT)=0.0
15643      IDIGIT(ICNT)=-1
15644C
15645      NUMROW=ICNT
15646      DO2310I=1,NUMROW
15647        NTOT(I)=15
15648 2310 CONTINUE
15649C
15650      ITITLZ=' '
15651      NCTITZ=0
15652      IFRST=.TRUE.
15653      ILAST=.TRUE.
15654      NCTITZ=0
15655      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
15656     1            AVALUE,IDIGIT,
15657     1            NTOT,NUMROW,
15658     1            ICAPSW,ICAPTY,ILAST,IFRST,
15659     1            ISUBRO,IBUGA3,IERROR)
15660      ITITLE=' '
15661      NCTITL=0
15662      ITITL9=' '
15663      NCTIT9=0
15664C
15665      ITITLE(1:44)='Percent Points of the Reference Distribution'
15666      NCTITL=44
15667      NUMLIN=1
15668      NUMROW=8
15669      NUMCOL=3
15670      ITITL2(1,1)='Percent Point'
15671      ITITL2(1,2)=' '
15672      ITITL2(1,3)='Value'
15673      NCTIT2(1,1)=13
15674      NCTIT2(1,2)=1
15675      NCTIT2(1,3)=5
15676C
15677      NMAX=0
15678      DO2521I=1,NUMCOL
15679        VALIGN(I)='b'
15680        ALIGN(I)='r'
15681        NTOT(I)=15
15682        IF(I.EQ.2)NTOT(I)=5
15683        NMAX=NMAX+NTOT(I)
15684        IDIGIT(I)=NUMDIG
15685        ITYPCO(I)='NUME'
15686 2521 CONTINUE
15687      ITYPCO(2)='ALPH'
15688      IDIGIT(1)=1
15689      IDIGIT(3)=3
15690      DO2523I=1,NUMROW
15691        DO2525J=1,NUMCOL
15692          NCVALU(I,J)=0
15693          IVALUE(I,J)=' '
15694          NCVALU(I,J)=0
15695          AMAT(I,J)=0.0
15696          IF(J.EQ.1)THEN
15697            AMAT(I,J)=ALPHA(I)
15698          ELSEIF(J.EQ.2)THEN
15699            IVALUE(I,J)='='
15700            NCVALU(I,J)=1
15701          ELSEIF(J.EQ.3)THEN
15702            IF(I.GE.2)THEN
15703              P100=ALPHA(I)/100.0
15704              CALL CHSPPF(P100,IDF,XPERC)
15705              XPERC2=RND(XPERC,3)
15706              AMAT(I,J)=XPERC2
15707            ELSE
15708              XPERC=0.0
15709              XPERC2=RND(XPERC,3)
15710              AMAT(I,J)=XPERC2
15711            ENDIF
15712          ENDIF
15713 2525   CONTINUE
15714 2523 CONTINUE
15715C
15716      IWHTML(1)=150
15717      IWHTML(2)=50
15718      IWHTML(3)=150
15719      IWRTF(1)=2000
15720      IWRTF(2)=IWRTF(1)+500
15721      IWRTF(3)=IWRTF(2)+2000
15722      IFRST=.TRUE.
15723      ILAST=.FALSE.
15724C
15725      CALL DPDTA4(ITITL9,NCTIT9,
15726     1            ITITLE,NCTITL,ITITL2,NCTIT2,
15727     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
15728     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW,
15729     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
15730     1            ICAPSW,ICAPTY,IFRST,ILAST,
15731     1            ISUBRO,IBUGA3,IERROR)
15732C
15733      ITITL9=' '
15734      NCTIT9=0
15735      ITITLE='Conclusions (Upper 1-Tailed Test)'
15736      NCTITL=33
15737      NUMLIN=1
15738      NUMROW=4
15739      NUMCOL=4
15740      ITITL2(1,1)='Alpha'
15741      ITITL2(1,2)='CDF'
15742      ITITL2(1,3)='Critical Value'
15743      ITITL2(1,4)='Conclusion'
15744      NCTIT2(1,1)=5
15745      NCTIT2(1,2)=3
15746      NCTIT2(1,3)=14
15747      NCTIT2(1,4)=10
15748C
15749      NMAX=0
15750      DO2821I=1,NUMCOL
15751        VALIGN(I)='b'
15752        ALIGN(I)='r'
15753        NTOT(I)=15
15754        IF(I.EQ.1 .OR. I.EQ.2)NTOT(I)=7
15755        IF(I.EQ.3)NTOT(I)=17
15756        NMAX=NMAX+NTOT(I)
15757CCCCC   IDIGIT(I)=NUMDIG
15758        IDIGIT(I)=3
15759        ITYPCO(I)='ALPH'
15760 2821 CONTINUE
15761      ITYPCO(3)='NUME'
15762      IDIGIT(1)=0
15763      IDIGIT(2)=0
15764      DO2823I=1,NUMROW
15765        DO2825J=1,NUMCOL
15766          NCVALU(I,J)=0
15767          IVALUE(I,J)=' '
15768          NCVALU(I,J)=0
15769          AMAT(I,J)=0.0
15770 2825   CONTINUE
15771 2823 CONTINUE
15772      IVALUE(1,1)='10%'
15773      IVALUE(2,1)='5%'
15774      IVALUE(3,1)='2.5%'
15775      IVALUE(4,1)='1%'
15776      IVALUE(1,2)='90%'
15777      IVALUE(2,2)='95%'
15778      IVALUE(3,2)='97.5%'
15779      IVALUE(4,2)='99%'
15780      NCVALU(1,1)=3
15781      NCVALU(2,1)=2
15782      NCVALU(3,1)=4
15783      NCVALU(4,1)=2
15784      NCVALU(1,2)=3
15785      NCVALU(2,2)=3
15786      NCVALU(3,2)=5
15787      NCVALU(4,2)=3
15788      IVALUE(1,4)='Accept H0'
15789      IVALUE(2,4)='Accept H0'
15790      IVALUE(3,4)='Accept H0'
15791      IVALUE(4,4)='Accept H0'
15792      NCVALU(1,4)=9
15793      NCVALU(2,4)=9
15794      NCVALU(3,4)=9
15795      NCVALU(4,4)=9
15796      CALL CHSPPF(0.90,IDF,CDF1)
15797      CALL CHSPPF(0.95,IDF,CDF2)
15798      CALL CHSPPF(0.975,IDF,CDF3)
15799      CALL CHSPPF(0.99,IDF,CDF4)
15800      IF(STATVA.GT.CDF1)IVALUE(1,4)='Reject H0'
15801      IF(STATVA.GT.CDF2)IVALUE(2,4)='Reject H0'
15802      IF(STATVA.GT.CDF3)IVALUE(3,4)='Reject H0'
15803      IF(STATVA.GT.CDF4)IVALUE(4,4)='Reject H0'
15804      AMAT(1,3)=RND(CDF1,IDIGIT(3))
15805      AMAT(2,3)=RND(CDF2,IDIGIT(3))
15806      AMAT(3,3)=RND(CDF3,IDIGIT(3))
15807      AMAT(4,3)=RND(CDF4,IDIGIT(3))
15808C
15809      IWHTML(1)=150
15810      IWHTML(2)=150
15811      IWHTML(3)=150
15812      IWHTML(4)=150
15813      IWRTF(1)=1500
15814      IWRTF(2)=IWRTF(1)+1500
15815      IWRTF(3)=IWRTF(2)+2000
15816      IWRTF(4)=IWRTF(3)+2000
15817      IFRST=.FALSE.
15818C
15819C     FOR LATEX, WE WANT TO ENSURE THAT TRAILING LINE IS PART
15820C     OF THE TABLE SO THAT IT WILL BE PRINTED IN THE PROPER PLACE.
15821C
15822      IF(ICAPTY.EQ.'LATE')THEN
15823        ILAST=.FALSE.
15824      ELSE
15825        ILAST=.TRUE.
15826      ENDIF
15827C
15828      CALL DPDTA4(ITITL9,NCTIT9,
15829     1            ITITLE,NCTITL,ITITL2,NCTIT2,
15830     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
15831     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW,
15832     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
15833     1            ICAPSW,ICAPTY,IFRST,ILAST,
15834     1            ISUBRO,IBUGA3,IERROR)
15835C
15836C               *****************
15837C               **  STEP 90--  **
15838C               **  EXIT       **
15839C               *****************
15840C
15841 9000 CONTINUE
15842      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CHS3')THEN
15843        WRITE(ICOUT,999)
15844        CALL DPWRST('XXX','BUG ')
15845        WRITE(ICOUT,9011)
15846 9011   FORMAT('***** AT THE END       OF DPCHS3--')
15847        CALL DPWRST('XXX','BUG ')
15848      ENDIF
15849C
15850      RETURN
15851      END
15852      SUBROUTINE DPCHSY(ICHAR2,ICHARN,IBUG,IFOUND)
15853C
15854C     PURPOSE--CONVERT A KEYBOARD SYMBOL
15855C              (. , ; : ETC.) INTO A NUMERIC VALUE
15856C              (1 TO 23).
15857C              (1 TO 24).
15858C     INPUT  ARGUMENTS--ICHAR2 (A HOLLERITH VARIABLE
15859C                              CONTAINING THE HOLLERITH
15860C                              CHARACTER(S) OF INTEREST.
15861C     OUTPUT ARGUMENTS--ICHARN (AN INTEGER VARIABLE
15862C                              CONTAINING THE NUMERIC
15863C                              DESIGNATION FOR THE
15864C                              ALPHABETIC CHARACTER.
15865C     WRITTEN BY--JAMES J. FILLIBEN
15866C                 STATISTICAL ENGINEERING DIVISION
15867C                 INFORMATION TECHNOLOGY LABORATORY
15868C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
15869C                 GAITHERSBURG, MD 20899-8980
15870C                 PHONE--301-975-2899
15871C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
15872C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
15873C     LANGUAGE--ANSI FORTRAN (1977)
15874C     VERSION NUMBER--82/7
15875C     ORIGINAL VERSION--MARCH     1981.
15876C     UPDATED         --NOVEMBER  1981.
15877C     UPDATED         --MAY       1982.
15878C     UPDATED         --MAY       1987.
15879C
15880C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
15881C
15882      CHARACTER*4 ICHAR2
15883      CHARACTER*4 IBUG
15884      CHARACTER*4 IFOUND
15885C
15886C-----COMMON----------------------------------------------------------
15887C
15888      INCLUDE 'DPCOBE.INC'
15889C
15890C-----COMMON VARIABLES (GENERAL)--------------------------------------
15891C
15892      INCLUDE 'DPCOP2.INC'
15893C
15894C-----START POINT-----------------------------------------------------
15895C
15896      IFOUND='NO'
15897C
15898      IF(IBUG.EQ.'ON' .OR. ISUBG4.EQ.'CHSY')THEN
15899        WRITE(ICOUT,999)
15900  999   FORMAT(1X)
15901        CALL DPWRST('XXX','BUG ')
15902        WRITE(ICOUT,51)
15903   51   FORMAT('***** AT THE BEGINNING OF DPCHSY--')
15904        CALL DPWRST('XXX','BUG ')
15905        WRITE(ICOUT,59)ICHAR2,IBUGG4,ISUBG4
15906   59   FORMAT('ICHAR2,IBUGG4,ISUBG4 = ',2(A4,2X),A4)
15907        CALL DPWRST('XXX','BUG ')
15908      ENDIF
15909C
15910C               **********************************
15911C               **  STEP 1--                    **
15912C               **  CONVERT THE CHARACTER       **
15913C               **********************************
15914C
15915      IF(ICHAR2.EQ.'.')GOTO100
15916      IF(ICHAR2.EQ.',')GOTO200
15917      IF(ICHAR2.EQ.':')GOTO300
15918      IF(ICHAR2.EQ.';')GOTO400
15919      IF(ICHAR2.EQ.'!')GOTO500
15920      IF(ICHAR2.EQ.'?')GOTO600
15921      IF(ICHAR2.EQ.'&')GOTO700
15922      IF(ICHAR2.EQ.'$')GOTO800
15923      IF(ICHAR2.EQ.'/')GOTO900
15924      IF(ICHAR2.EQ.'(')GOTO1000
15925      IF(ICHAR2.EQ.')')GOTO1100
15926      IF(ICHAR2.EQ.'*')GOTO1200
15927      IF(ICHAR2.EQ.'-')GOTO1300
15928      IF(ICHAR2.EQ.'+')GOTO1400
15929      IF(ICHAR2.EQ.'=')GOTO1500
15930      IF(ICHAR2.EQ.'''')GOTO1600
15931      IF(ICHAR2.EQ.'"')GOTO1700
15932      IF(ICHAR2.EQ.'DEGR')GOTO1800
15933      IF(ICHAR2.EQ.'NOSP')GOTO1900
15934      IF(ICHAR2.EQ.'HASP')GOTO2000
15935      IF(ICHAR2.EQ.' ')GOTO2100
15936      IF(ICHAR2.EQ.'LAPO')GOTO2200
15937      IF(ICHAR2.EQ.'RAPO')GOTO2300
15938      IF(ICHAR2.EQ.'|')GOTO2400
15939      GOTO7900
15940C
15941  100 CONTINUE
15942      ICHARN=1
15943      GOTO8000
15944C
15945  200 CONTINUE
15946      ICHARN=2
15947      GOTO8000
15948C
15949  300 CONTINUE
15950      ICHARN=3
15951      GOTO8000
15952C
15953  400 CONTINUE
15954      ICHARN=4
15955      GOTO8000
15956C
15957  500 CONTINUE
15958      ICHARN=5
15959      GOTO8000
15960C
15961  600 CONTINUE
15962      ICHARN=6
15963      GOTO8000
15964C
15965  700 CONTINUE
15966      ICHARN=7
15967      GOTO8000
15968C
15969  800 CONTINUE
15970      ICHARN=8
15971      GOTO8000
15972C
15973  900 CONTINUE
15974      ICHARN=9
15975      GOTO8000
15976C
15977 1000 CONTINUE
15978      ICHARN=10
15979      GOTO8000
15980C
15981 1100 CONTINUE
15982      ICHARN=11
15983      GOTO8000
15984C
15985 1200 CONTINUE
15986      ICHARN=12
15987      GOTO8000
15988C
15989 1300 CONTINUE
15990      ICHARN=13
15991      GOTO8000
15992C
15993 1400 CONTINUE
15994      ICHARN=14
15995      GOTO8000
15996C
15997 1500 CONTINUE
15998      ICHARN=15
15999      GOTO8000
16000C
16001 1600 CONTINUE
16002      ICHARN=16
16003      GOTO8000
16004C
16005 1700 CONTINUE
16006      ICHARN=17
16007      GOTO8000
16008C
16009 1800 CONTINUE
16010      ICHARN=18
16011      GOTO8000
16012C
16013 1900 CONTINUE
16014      ICHARN=19
16015      GOTO8000
16016C
16017 2000 CONTINUE
16018      ICHARN=20
16019      GOTO8000
16020C
16021 2100 CONTINUE
16022      ICHARN=21
16023      GOTO8000
16024C
16025 2200 CONTINUE
16026      ICHARN=22
16027      GOTO8000
16028C
16029 2300 CONTINUE
16030      ICHARN=23
16031      GOTO8000
16032C
16033 2400 CONTINUE
16034      ICHARN=24
16035      GOTO8000
16036C
16037 7900 CONTINUE
16038CCCCC WRITE(ICOUT,999)
16039CCCCC CALL DPWRST('XXX','BUG ')
16040CCCCC WRITE(ICOUT,7911)
16041C7911 FORMAT('***** ERROR IN DPCHSY--')
16042CCCCC CALL DPWRST('XXX','BUG ')
16043CCCCC WRITE(ICOUT,7912)
16044C7912 FORMAT('      NO MATCH FOUND FOR INPUT CHARACTER.')
16045CCCCC CALL DPWRST('XXX','BUG ')
16046CCCCC WRITE(ICOUT,7913)ICHAR2
16047C7913 FORMAT('      INPUT CHARACTER = ',A4)
16048CCCCC CALL DPWRST('XXX','BUG ')
16049      IFOUND='NO'
16050      GOTO9000
16051C
16052 8000 CONTINUE
16053      IFOUND='YES'
16054      GOTO9000
16055C
16056C               *****************
16057C               **  STEP 90--  **
16058C               **  EXIT       **
16059C               *****************
16060C
16061 9000 CONTINUE
16062      IF(IBUG.EQ.'ON' .OR. ISUBG4.EQ.'CHSY')THEN
16063        WRITE(ICOUT,999)
16064        CALL DPWRST('XXX','BUG ')
16065        WRITE(ICOUT,9011)
16066 9011   FORMAT('***** AT THE END       OF DPCHSY--')
16067        CALL DPWRST('XXX','BUG ')
16068        WRITE(ICOUT,9013)IFOUND,ICHAR2,ICHARN
16069 9013   FORMAT('IFOUND,ICHAR2,ICHARN = ',2(A4,2X),I8)
16070        CALL DPWRST('XXX','BUG ')
16071      ENDIF
16072C
16073      RETURN
16074      END
16075      SUBROUTINE DPCHSZ(PDEFHE,MAXCHA,
16076     1PCHAHE,PCHAWI,PCHAVG,PCHAHG,
16077     1IBUGP2,IBUGQ,IFOUND,IERROR)
16078C
16079C     PURPOSE--DEFINE PLOT CHARACTER SIZES FOR USE IN MULTI-TRACE PLOTS.
16080C              THE SIZE FOR THE CHARACTER FOR THE I-TH TRACE
16081C              WILL BE PLACED
16082C              IN THE I-TH ELEMENT OF THE FLOATING POINT
16083C              VECTOR PCHAHE(.).
16084C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
16085C                     --IARGT  (A  HOLLERITH VECTOR)
16086C                     --ARG    (A  HOLLERITH VECTOR)
16087C                     --NUMARG
16088C                     --PDEFHE
16089C                     --MAXCHA
16090C     OUTPUT ARGUMENTS--PCHAHE  (A  FLOATING POINT VECTOR
16091C                       WHOSE I-TH ELEMENT IS THE SIZE (= HEIGHT)
16092C                       FOR THE CHARACTER
16093C                       ASSIGNED TO THE I-TH    TRACE    IN
16094C                       A MULTI-TRACE PLOT.
16095C                     --PCHAWI = CHARACTER WIDTH
16096C                     --PCHAVG = VERTICAL GAP BETWEEN CHARACTERS
16097C                     --PCHAHG = HORIZONTAL GAP BETWEEN CHARACTERS
16098C                     --IFOUND ('YES' OR 'NO' )
16099C                     --IERROR ('YES' OR 'NO' )
16100C     WRITTEN BY--JAMES J. FILLIBEN
16101C                 STATISTICAL ENGINEERING DIVISION
16102C                 INFORMATION TECHNOLOGY LABORATORY
16103C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
16104C                 GAITHERSBURG, MD 20899-8980
16105C                 PHONE--301-975-2899
16106C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
16107C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
16108C     LANGUAGE--ANSI FORTRAN (1977)
16109C     VERSION NUMBER--82/7
16110C     ORIGINAL VERSION--DECEMBER  1977.
16111C     UPDATED         --SEPTEMBER 1980.
16112C     UPDATED         --MARCH     1982.
16113C     UPDATED         --MAY       1982.
16114C     UPDATED         --DECEMBER  1982.
16115C     UPDATED         --JANUARY   1995. ALLOW ? AS ARGUMENT (FOR HELP)
16116C
16117C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
16118C
16119CCCCC CHARACTER*4 IHARG          DECEMBER 1986
16120CCCCC CHARACTER*4 IARGT          DECEMBER 1986
16121C
16122      CHARACTER*4 IBUGP2
16123      CHARACTER*4 IBUGQ
16124      CHARACTER*4 IFOUND
16125      CHARACTER*4 IERROR
16126C
16127      CHARACTER*4 IHLEFT
16128      CHARACTER*4 IHLEF2
16129      CHARACTER*4 IHWUSE
16130      CHARACTER*4 MESSAG
16131      CHARACTER*4 ISTEPN
16132      CHARACTER*4 ISUBN1
16133      CHARACTER*4 ISUBN2
16134      CHARACTER*4 ICASEQ
16135      CHARACTER*4 IWRITE
16136C
16137C---------------------------------------------------------------------
16138C
16139CCCCC DIMENSION IHARG(*)          DECEMBER 1986
16140CCCCC DIMENSION IARGT(*)          DECEMBER 1986
16141CCCCC DIMENSION IARG(*)          DECEMBER 1986
16142CCCCC DIMENSION ARG(*)          DECEMBER 1986
16143C
16144      DIMENSION PCHAHE(*)
16145      DIMENSION PCHAWI(*)
16146      DIMENSION PCHAVG(*)
16147      DIMENSION PCHAHG(*)
16148C
16149C-----COMMON----------------------------------------------------------
16150C
16151      INCLUDE 'DPCOPA.INC'
16152      INCLUDE 'DPCOHK.INC'
16153      INCLUDE 'DPCODA.INC'
16154C
16155C---------------------------------------------------------------------
16156C
16157      INCLUDE 'DPCOP2.INC'
16158C
16159C-----START POINT-----------------------------------------------------
16160C
16161      ISUBN1='DPCH'
16162      ISUBN2='SZ  '
16163      IFOUND='NO'
16164      IERROR='NO'
16165C
16166      IF(NUMARG.GE.3.AND.IHARG(1).EQ.'SIZE'.AND.
16167     1IHARG(2).EQ.'BOX'.AND.IHARG(3).EQ.'PLOT')GOTO2110
16168      IF(NUMARG.GE.3.AND.IHARG(1).EQ.'HEIG'.AND.
16169     1IHARG(2).EQ.'BOX'.AND.IHARG(3).EQ.'PLOT')GOTO2110
16170      IF(NUMARG.GE.4.AND.IHARG(2).EQ.'SIZE'.AND.
16171     1IHARG(3).EQ.'BOX'.AND.IHARG(4).EQ.'PLOT')GOTO2110
16172      IF(NUMARG.GE.4.AND.IHARG(2).EQ.'HEIG'.AND.
16173     1IHARG(3).EQ.'BOX'.AND.IHARG(4).EQ.'PLOT')GOTO2110
16174C
16175      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'SIZE')GOTO1160
16176      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'HEIG')GOTO1160
16177      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'SIZE')GOTO1105
16178      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'HEIG')GOTO1105
16179      GOTO9000
16180C
16181 1105 CONTINUE
16182      IF(IHARG(NUMARG).EQ.'ON')GOTO1110
16183      IF(IHARG(NUMARG).EQ.'OFF')GOTO1110
16184      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1110
16185      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1110
16186CCCCC THE FOLLOWING LINE WAS ADDED    JANUARY 1995
16187      IF(IHARG(NUMARG).EQ.'?')GOTO1200
16188C
16189      IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'ALL')GOTO1160
16190      IF(NUMARG.EQ.2)GOTO1120
16191      IF(NUMARG.GE.3.AND.IHARG(2).EQ.'ALL')GOTO1130
16192      IF(NUMARG.GE.3.AND.IHARG(3).EQ.'ALL')GOTO1140
16193C
16194      IF(NUMARG.GE.3.AND.IHARG(2).EQ.'AUTO')GOTO3000
16195C
16196      GOTO1150
16197C
16198 1110 CONTINUE
16199      DO1115I=1,MAXCHA
16200      PCHAHE(I)=PDEFHE
16201 1115 CONTINUE
16202C
16203      IF(IFEEDB.EQ.'OFF')GOTO1119
16204      WRITE(ICOUT,999)
16205  999 FORMAT(1X)
16206      CALL DPWRST('XXX','BUG ')
16207      I=1
16208      WRITE(ICOUT,1116)PCHAHE(I)
16209 1116 FORMAT('ALL CHARACTER SIZES HAVE JUST BEEN SET TO ',
16210     1E15.7)
16211      CALL DPWRST('XXX','BUG ')
16212 1119 CONTINUE
16213      GOTO8000
16214C
16215 1120 CONTINUE
16216      I=1
16217      IF(IARGT(2).NE.'NUMB')GOTO1180
16218      PCHAHE(1)=ARG(2)
16219C
16220      IF(IFEEDB.EQ.'OFF')GOTO1129
16221      WRITE(ICOUT,999)
16222      CALL DPWRST('XXX','BUG ')
16223      I=1
16224      WRITE(ICOUT,1126)I,PCHAHE(I)
16225 1126 FORMAT('THE SIZE FOR CHARACTER ',I6,' HAS JUST BEEN SET TO ',
16226     1E15.7)
16227      CALL DPWRST('XXX','BUG ')
16228 1129 CONTINUE
16229      GOTO8000
16230C
16231 1130 CONTINUE
16232      I=1
16233      IF(IARGT(3).NE.'NUMB')GOTO1180
16234      DO1135I=1,MAXCHA
16235      PCHAHE(I)=ARG(3)
16236 1135 CONTINUE
16237C
16238      IF(IFEEDB.EQ.'OFF')GOTO1139
16239      WRITE(ICOUT,999)
16240      CALL DPWRST('XXX','BUG ')
16241      I=1
16242      WRITE(ICOUT,1116)PCHAHE(I)
16243      CALL DPWRST('XXX','BUG ')
16244 1139 CONTINUE
16245      GOTO8000
16246C
16247 1140 CONTINUE
16248      I=1
16249      IF(IARGT(2).NE.'NUMB')GOTO1180
16250      DO1145I=1,MAXCHA
16251      PCHAHE(I)=ARG(2)
16252 1145 CONTINUE
16253C
16254      IF(IFEEDB.EQ.'OFF')GOTO1149
16255      WRITE(ICOUT,999)
16256      CALL DPWRST('XXX','BUG ')
16257      I=1
16258      WRITE(ICOUT,1116)PCHAHE(I)
16259      CALL DPWRST('XXX','BUG ')
16260 1149 CONTINUE
16261      GOTO8000
16262C
16263 1150 CONTINUE
16264      IMAX=NUMARG-1
16265      IF(MAXCHA.LT.IMAX)IMAX=MAXCHA
16266      DO1155I=1,IMAX
16267      IP1=I+1
16268      IF(IARGT(IP1).NE.'NUMB')GOTO1180
16269      PCHAHE(I)=ARG(IP1)
16270 1155 CONTINUE
16271C
16272      IF(IFEEDB.EQ.'OFF')GOTO1159
16273      WRITE(ICOUT,999)
16274      CALL DPWRST('XXX','BUG ')
16275      DO1156I=1,IMAX
16276      WRITE(ICOUT,1126)I,PCHAHE(I)
16277      CALL DPWRST('XXX','BUG ')
16278 1156 CONTINUE
16279 1159 CONTINUE
16280      GOTO8000
16281C
16282 1160 CONTINUE
16283      DO1165I=1,MAXCHA
16284      PCHAHE(I)=PDEFHE
16285 1165 CONTINUE
16286C
16287      IF(IFEEDB.EQ.'OFF')GOTO1169
16288      WRITE(ICOUT,999)
16289      CALL DPWRST('XXX','BUG ')
16290      I=1
16291      WRITE(ICOUT,1116)PCHAHE(I)
16292      CALL DPWRST('XXX','BUG ')
16293 1169 CONTINUE
16294      GOTO8000
16295C
16296 1180 CONTINUE
16297      IERROR='YES'
16298      WRITE(ICOUT,999)
16299      CALL DPWRST('XXX','BUG ')
16300      WRITE(ICOUT,1181)
16301 1181 FORMAT('***** ERROR IN DPCHSZ--')
16302      CALL DPWRST('XXX','BUG ')
16303      WRITE(ICOUT,1182)
16304 1182 FORMAT('CHARACTER SIZES MUST BE NUMERIC;')
16305      CALL DPWRST('XXX','BUG ')
16306      WRITE(ICOUT,1183)
16307 1183 FORMAT('HOWEVER, THE SPECIFIED CHARACTER SIZE')
16308      CALL DPWRST('XXX','BUG ')
16309      WRITE(ICOUT,1184)I
16310 1184 FORMAT('FOR CHARACTER ',I6,' WAS NON-NUMERIC.')
16311      CALL DPWRST('XXX','BUG ')
16312      GOTO9000
16313C
16314CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY 1995
16315 1200 CONTINUE
16316      IFOUND='YES'
16317      IF(IFEEDB.EQ.'OFF')GOTO1229
16318      WRITE(ICOUT,999)
16319      CALL DPWRST('XXX','BUG ')
16320      I=1
16321      WRITE(ICOUT,1226)I,PCHAHE(I)
16322 1226 FORMAT('THE CURRENT SIZE FOR CHARACTER ',I6,' IS ',E15.7)
16323      CALL DPWRST('XXX','BUG ')
16324      WRITE(ICOUT,1227)I,PDEFHE
16325 1227 FORMAT('THE DEFAULT SIZE FOR CHARACTER ',I6,' IS ',E15.7)
16326      CALL DPWRST('XXX','BUG ')
16327 1229 CONTINUE
16328      GOTO9000
16329C
16330 2110 CONTINUE
16331      IMAX=24
16332      PCHAHE(1)=2.0
16333      PCHAHE(2)=2.0
16334      PCHAHE(3)=2.0
16335      PCHAHE(4)=2.0
16336      PCHAHE(5)=2.0
16337      PCHAHE(6)=2.0
16338      PCHAHE(7)=2.0
16339      PCHAHE(8)=2.0
16340      PCHAHE(9)=2.0
16341      PCHAHE(10)=2.0
16342      PCHAHE(11)=2.0
16343      PCHAHE(12)=2.0
16344      PCHAHE(13)=2.0
16345      PCHAHE(14)=2.0
16346      PCHAHE(15)=2.0
16347      PCHAHE(16)=2.0
16348      PCHAHE(17)=2.0
16349      PCHAHE(18)=2.0
16350      PCHAHE(19)=2.0
16351      PCHAHE(20)=2.0
16352      PCHAHE(21)=3.0
16353      PCHAHE(22)=2.0
16354      PCHAHE(23)=2.0
16355      PCHAHE(24)=3.0
16356      GOTO2170
16357C
16358 2170 CONTINUE
16359      IF(IFEEDB.EQ.'OFF')GOTO2179
16360      WRITE(ICOUT,999)
16361      CALL DPWRST('XXX','BUG ')
16362      DO2175I=1,IMAX
16363      WRITE(ICOUT,2176)I,PCHAHE(I)
16364 2176 FORMAT('THE SIZE FOR CHARACTER ',I6,' HAS JUST BEEN SET TO ',
16365     1E15.7)
16366      CALL DPWRST('XXX','BUG ')
16367 2175 CONTINUE
16368 2179 CONTINUE
16369      GOTO8000
16370C
16371C               ***********************************************************
16372C               **  STEP 30--                                            **
16373C               **  TREAT THE   CHARACTER SIZE AUTOMATIC <VARIABLE>  CASE **
16374C               ***********************************************************
16375C
16376 3000 CONTINUE
16377C
16378C               ********************************************
16379C               **  STEP 31--                             **
16380C               **  CHECK THE VALIDITY OF ARGUMENT 3      **
16381C               **  (THIS WILL BE THE RESPONSE VARIABLE)  **
16382C               ********************************************
16383C
16384      ISTEPN='31'
16385      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16386C
16387      IHLEFT=IHARG(3)
16388      IHLEF2=IHARG2(3)
16389      IHWUSE='V'
16390      MESSAG='YES'
16391      CALL CHECKN(IHLEFT,IHLEF2,IHWUSE,
16392     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
16393     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
16394      IF(IERROR.EQ.'YES')GOTO9000
16395      ICOLL=IVALUE(ILOCV)
16396      NLEFT=IN(ILOCV)
16397C
16398C               *****************************************
16399C               **  STEP 32--                          **
16400C               **  CHECK TO SEE THE TYPE CASE--       **
16401C               **    1) UNQUALIFIED (THAT IS, FULL);  **
16402C               **    2) SUBSET/EXCEPT; OR             **
16403C               **    3) FOR.                          **
16404C               *****************************************
16405C
16406      ISTEPN='32'
16407      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16408C
16409      ICASEQ='FULL'
16410      ILOCQ=NUMARG+1
16411      IF(NUMARG.LT.1)GOTO3290
16412      DO3200J=1,NUMARG
16413      J1=J
16414      IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET  ') GOTO3210
16415      IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT  ') GOTO3210
16416      IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.'    ') GOTO3220
16417 3200 CONTINUE
16418      GOTO3290
16419 3210 CONTINUE
16420      ICASEQ='SUBS'
16421      ILOCQ=J1
16422      GOTO3290
16423 3220 CONTINUE
16424      ICASEQ='FOR'
16425      ILOCQ=J1
16426      GOTO3290
16427 3290 CONTINUE
16428      IF(IBUGP2.EQ.'OFF')GOTO3295
16429      WRITE(ICOUT,3291)NUMARG,ILOCQ
16430 3291 FORMAT('NUMARG,ILOCQ = ',2I8)
16431      CALL DPWRST('XXX','BUG ')
16432 3295 CONTINUE
16433C
16434C               *********************************************
16435C               **  STEP 33--                              **
16436C               **  TEMPORARILY FORM THE VARIABLE Y(.)     **
16437C               **  WHICH WILL HOLD THE RESPONSE VARIABLE. **
16438C               **  FORM THIS VARIABLE BY                  **
16439C               **  BRANCHING TO THE APPROPRIATE SUBCASE   **
16440C               **  (FULL, SUBSET, OR FOR).                **
16441C               *********************************************
16442C
16443      ISTEPN='33'
16444      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16445C
16446      IF(ICASEQ.EQ.'FULL')GOTO3310
16447      IF(ICASEQ.EQ.'SUBS')GOTO3320
16448      IF(ICASEQ.EQ.'FOR')GOTO3330
16449C
16450 3310 CONTINUE
16451      DO3315I=1,NLEFT
16452      ISUB(I)=1
16453 3315 CONTINUE
16454      NQ=NLEFT
16455      GOTO3350
16456C
16457 3320 CONTINUE
16458      NIOLD=NLEFT
16459      CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR)
16460      NQ=NIOLD
16461      GOTO3350
16462C
16463 3330 CONTINUE
16464      NIOLD=NLEFT
16465      CALL DPFOR(NIOLD,NFOR,IROW1,IROWN,
16466     1NLOCAL,ILOCS,NS,IBUGQ,IERROR)
16467      NQ=NFOR
16468      GOTO3350
16469C
16470 3350 CONTINUE
16471      MINN2=1
16472      IF(NQ.GE.MINN2)GOTO3360
16473      WRITE(ICOUT,999)
16474      CALL DPWRST('XXX','BUG ')
16475      WRITE(ICOUT,3351)
16476 3351 FORMAT('***** ERROR IN DPCHSZ--')
16477      CALL DPWRST('XXX','BUG ')
16478      WRITE(ICOUT,3352)
16479 3352 FORMAT('      AFTER THE APPROPRIATE SUBSET HAS BEEN ',
16480     1'EXTRACTED,')
16481      CALL DPWRST('XXX','BUG ')
16482      WRITE(ICOUT,3353)IHLEFT,IHLEF2
16483 3353 FORMAT('      THE NUMBER OF OBSERVATIONS REMAINING',
16484     1'FROM VARIABLE ',A4,A4)
16485      CALL DPWRST('XXX','BUG ')
16486      WRITE(ICOUT,3354)
16487 3354 FORMAT('      (FOR WHICH CHARACTER SIZES ')
16488      CALL DPWRST('XXX','BUG ')
16489      WRITE(ICOUT,3355)
16490 3355 FORMAT('      ARE TO BE GENERATED)')
16491      CALL DPWRST('XXX','BUG ')
16492      WRITE(ICOUT,3356)MINN2
16493 3356 FORMAT('      MUST BE ',I8,' OR LARGER;')
16494      CALL DPWRST('XXX','BUG ')
16495      WRITE(ICOUT,3357)
16496 3357 FORMAT('      SUCH WAS NOT THE CASE HERE.')
16497      CALL DPWRST('XXX','BUG ')
16498      WRITE(ICOUT,3358)
16499 3358 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
16500      CALL DPWRST('XXX','BUG ')
16501      IF(IWIDTH.GE.1)WRITE(ICOUT,3359)(IANS(I),I=1,IWIDTH)
16502 3359 FORMAT('      ',80A1)
16503      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
16504      IERROR='YES'
16505      GOTO9000
16506C
16507 3360 CONTINUE
16508      MAXCP1=MAXCOL+1
16509      MAXCP2=MAXCOL+2
16510      MAXCP3=MAXCOL+3
16511      MAXCP4=MAXCOL+4
16512      MAXCP5=MAXCOL+5
16513      MAXCP6=MAXCOL+6
16514      J=0
16515      IMAX=NLEFT
16516      IF(NQ.LT.NLEFT)IMAX=NQ
16517      DO3370I=1,IMAX
16518      IF(ISUB(I).EQ.0)GOTO3370
16519      J=J+1
16520C
16521      IJ=MAXN*(ICOLL-1)+I
16522      IF(ICOLL.LE.MAXCOL)Y(J)=V(IJ)
16523      IF(ICOLL.EQ.MAXCP1)Y(J)=PRED(I)
16524      IF(ICOLL.EQ.MAXCP2)Y(J)=RES(I)
16525      IF(ICOLL.EQ.MAXCP3)Y(J)=YPLOT(I)
16526      IF(ICOLL.EQ.MAXCP4)Y(J)=XPLOT(I)
16527      IF(ICOLL.EQ.MAXCP5)Y(J)=X2PLOT(I)
16528      IF(ICOLL.EQ.MAXCP6)Y(J)=TAGPLO(I)
16529C
16530 3370 CONTINUE
16531      NS=J
16532      NY=J
16533C
16534C               *****************************************
16535C               **  STEP 34--                          **
16536C               **  EXTRACT THE DISTINCT VALUES        **
16537C               **  FROM THE TARGET VARIABLE Y(.)   .  **
16538C               **  STORE THEM IN X(.)   .             **
16539C               *****************************************
16540C
16541      IWRITE='OFF'
16542      CALL DISTIN(Y,NY,IWRITE,X,NX,IBUGP2,IERROR)
16543C
16544C               ***********************************
16545C               **  STEP 35--                    **
16546C               **  SORT THESE DISTINCT VALUES   **
16547C               **  (IN PLACE).                  **
16548C               ***********************************
16549C
16550      CALL SORT(X,NX,X)
16551C
16552C               ******************************************
16553C               **  STEP 36--                           **
16554C               **  COPY    THE NUMERIC VALUES IN X(.)  **
16555C               **  INTO INDIVIDUAL ELEMENTS            **
16556C               **  OF PCHAHE(.)                        **
16557C               **  NOTE--MAX NUMBER OF VALUES  = 100   **
16558C               ******************************************
16559C
16560      IMAX=NX
16561      IF(IMAX.GT.MAXCHA)IMAX=MAXCHA
16562      DO3650I=1,IMAX
16563      PCHAHE(I)=X(I)
16564 3650 CONTINUE
16565C
16566      IF(IFEEDB.EQ.'OFF')GOTO3679
16567      WRITE(ICOUT,999)
16568      CALL DPWRST('XXX','BUG ')
16569      DO3675I=1,IMAX
16570      WRITE(ICOUT,3676)I,PCHAHE(I)
16571 3676 FORMAT('CHARACTER SIZE ',I6,' HAS JUST BEEN SET TO ',
16572     1E15.7)
16573      CALL DPWRST('XXX','BUG ')
16574 3675 CONTINUE
16575 3679 CONTINUE
16576      GOTO8000
16577C
16578 8000 CONTINUE
16579      IFOUND='YES'
16580      DO8010I=1,MAXCHA
16581      PCHAWI(I)=PCHAHE(I)*0.5
16582      PCHAVG(I)=PCHAHE(I)*0.5
16583      PCHAHG(I)=PCHAWI(I)*0.5
16584 8010 CONTINUE
16585      GOTO9000
16586C
16587C               *****************
16588C               **  STEP 90--  **
16589C               **  EXIT       **
16590C               *****************
16591C
16592 9000 CONTINUE
16593      IF(IBUGP2.EQ.'OFF')GOTO9090
16594      WRITE(ICOUT,999)
16595      CALL DPWRST('XXX','BUG ')
16596      WRITE(ICOUT,9011)
16597 9011 FORMAT('***** AT THE END       OF DPCHAR--')
16598      CALL DPWRST('XXX','BUG ')
16599      WRITE(ICOUT,9012)IBUGP2
16600 9012 FORMAT('IBUGP2 = ',A4)
16601      CALL DPWRST('XXX','BUG ')
16602      WRITE(ICOUT,9013)IFOUND,IERROR
16603 9013 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
16604      CALL DPWRST('XXX','BUG ')
16605      WRITE(ICOUT,9014)PDEFHE,IMAX
16606 9014 FORMAT('PDEFHE,IMAX = ',E15.7,I8)
16607      CALL DPWRST('XXX','BUG ')
16608      WRITE(ICOUT,9021)NY
16609 9021 FORMAT('NY = ',I8)
16610      CALL DPWRST('XXX','BUG ')
16611      IF(NY.LE.0)GOTO9022
16612      DO9023I=1,NY
16613      WRITE(ICOUT,9024)I,Y(I)
16614 9024 FORMAT('I,Y(I) = ',I8,E15.7)
16615      CALL DPWRST('XXX','BUG ')
16616 9023 CONTINUE
16617 9022 CONTINUE
16618      WRITE(ICOUT,9031)NX
16619 9031 FORMAT('NX = ',I8)
16620      CALL DPWRST('XXX','BUG ')
16621      IF(NX.LE.0)GOTO9032
16622      DO9033I=1,NX
16623      WRITE(ICOUT,9034)I,X(I)
16624 9034 FORMAT('I,X(I) = ',I8,E15.7)
16625      CALL DPWRST('XXX','BUG ')
16626 9033 CONTINUE
16627 9032 CONTINUE
16628      WRITE(ICOUT,9041)MAXCHA
16629 9041 FORMAT('MAXCHA = ',I8)
16630      CALL DPWRST('XXX','BUG ')
16631      IF(NX.LE.0)GOTO9042
16632      DO9043I=1,NX
16633      WRITE(ICOUT,9044)I,PCHAHE(I),PCHAWI(I),PCHAVG(I),PCHAHG(I)
16634 9044 FORMAT('I,PCHAHE(I),PCHAWI(I),PCHAVG(I),PCHAHG(I) = ',I8,2X,
16635     14E15.7)
16636      CALL DPWRST('XXX','BUG ')
16637 9043 CONTINUE
16638 9042 CONTINUE
16639 9090 CONTINUE
16640      RETURN
16641      END
16642      SUBROUTINE DPCHTH(IHARG,ARG,NUMARG,PDEFTH,MAXCHA,PCHATH,
16643     1IFOUND,IERROR)
16644C
16645C     PURPOSE--DEFINE PLOT CHARACTER THICKNESSS FOR USE IN MULTI-TRACE PLOTS.
16646C              THE THICKNESS FOR THE CHARACTER FOR THE I-TH TRACE
16647C              WILL BE PLACED
16648C              IN THE I-TH ELEMENT OF THE HOLLERITH
16649C              VECTOR PCHATH(.).
16650C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
16651C                     --ARG    (A REAL VECTOR)
16652C                     --NUMARG
16653C                     --PDEFTH
16654C                     --MAXCHA
16655C     OUTPUT ARGUMENTS--PCHATH  (A  REAL VECTOR
16656C                       WHOSE I-TH ELEMENT IS THE THICKNESS
16657C                       FOR THE CHARACTER
16658C                       ASSIGNED TO THE I-TH    TRACE    IN
16659C                       A MULTI-TRACE PLOT.
16660C                     --IFOUND ('YES' OR 'NO' )
16661C                     --IERROR ('YES' OR 'NO' )
16662C     WRITTEN BY--ALAN HECKERT
16663C                 COMPUTER SERVICES DIVISION
16664C                 INFORMATION TECHNOLOGY LABORATORY
16665C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
16666C                 GAITHERSBURG, MD 20899-8980
16667C                 PHONE--301-975-2899
16668C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
16669C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
16670C     LANGUAGE--ANSI FORTRAN (1977)
16671C     VERSION NUMBER--82/7
16672C     ORIGINAL VERSION--DECEMBER  1977.
16673C     UPDATED         --SEPTEMBER 1980.
16674C     UPDATED         --MARCH     1982.
16675C     UPDATED         --MAY       1982.
16676C
16677C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
16678C
16679      CHARACTER*4 IHARG
16680      CHARACTER*4 IFOUND
16681      CHARACTER*4 IERROR
16682C
16683C---------------------------------------------------------------------
16684C
16685      DIMENSION IHARG(*)
16686      DIMENSION ARG(*)
16687      DIMENSION PCHATH(*)
16688C
16689C---------------------------------------------------------------------
16690C
16691      INCLUDE 'DPCOP2.INC'
16692C
16693C-----START POINT-----------------------------------------------------
16694C
16695      IFOUND='NO'
16696      IERROR='NO'
16697C
16698      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'THIC')GOTO1160
16699      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'THIC')GOTO1105
16700      GOTO1199
16701C
16702 1105 CONTINUE
16703      IF(IHARG(NUMARG).EQ.'ON')GOTO1110
16704      IF(IHARG(NUMARG).EQ.'OFF')GOTO1110
16705      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1110
16706      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1110
16707C
16708      IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'ALL')GOTO1160
16709      IF(NUMARG.EQ.2)GOTO1120
16710      IF(NUMARG.GE.3.AND.IHARG(2).EQ.'ALL')GOTO1130
16711      IF(NUMARG.GE.3.AND.IHARG(3).EQ.'ALL')GOTO1140
16712C
16713      GOTO1150
16714C
16715 1110 CONTINUE
16716      DO1115I=1,MAXCHA
16717      PCHATH(I)=PDEFTH
16718 1115 CONTINUE
16719C
16720      IF(IFEEDB.EQ.'OFF')GOTO1119
16721      WRITE(ICOUT,999)
16722  999 FORMAT(1X)
16723      CALL DPWRST('XXX','BUG ')
16724      I=1
16725      WRITE(ICOUT,1116)PCHATH(I)
16726 1116 FORMAT('ALL CHARACTER THICKNESSS HAVE JUST BEEN SET TO ',
16727     1E15.7)
16728      CALL DPWRST('XXX','BUG ')
16729 1119 CONTINUE
16730      GOTO1190
16731C
16732 1120 CONTINUE
16733      PCHATH(1)=ARG(2)
16734C
16735      IF(IFEEDB.EQ.'OFF')GOTO1129
16736      WRITE(ICOUT,999)
16737      CALL DPWRST('XXX','BUG ')
16738      I=1
16739      WRITE(ICOUT,1126)I,PCHATH(I)
16740 1126 FORMAT('THE THICKNESS FOR CHARACTER ',I6,' HAS JUST BEEN ',
16741     1'SET TO ',E15.7)
16742      CALL DPWRST('XXX','BUG ')
16743 1129 CONTINUE
16744      GOTO1190
16745C
16746 1130 CONTINUE
16747      DO1135I=1,MAXCHA
16748      PCHATH(I)=ARG(3)
16749 1135 CONTINUE
16750C
16751      IF(IFEEDB.EQ.'OFF')GOTO1139
16752      WRITE(ICOUT,999)
16753      CALL DPWRST('XXX','BUG ')
16754      I=1
16755      WRITE(ICOUT,1116)PCHATH(I)
16756      CALL DPWRST('XXX','BUG ')
16757 1139 CONTINUE
16758      GOTO1190
16759C
16760 1140 CONTINUE
16761      DO1145I=1,MAXCHA
16762      PCHATH(I)=ARG(2)
16763 1145 CONTINUE
16764C
16765      IF(IFEEDB.EQ.'OFF')GOTO1149
16766      WRITE(ICOUT,999)
16767      CALL DPWRST('XXX','BUG ')
16768      I=1
16769      WRITE(ICOUT,1116)PCHATH(I)
16770      CALL DPWRST('XXX','BUG ')
16771 1149 CONTINUE
16772      GOTO1190
16773C
16774 1150 CONTINUE
16775      IMAX=NUMARG-1
16776      IF(MAXCHA.LT.IMAX)IMAX=MAXCHA
16777      DO1155I=1,IMAX
16778      IP1=I+1
16779      PCHATH(I)=ARG(IP1)
16780 1155 CONTINUE
16781C
16782      IF(IFEEDB.EQ.'OFF')GOTO1159
16783      WRITE(ICOUT,999)
16784      CALL DPWRST('XXX','BUG ')
16785      DO1156I=1,IMAX
16786      WRITE(ICOUT,1126)I,PCHATH(I)
16787      CALL DPWRST('XXX','BUG ')
16788 1156 CONTINUE
16789 1159 CONTINUE
16790      GOTO1190
16791C
16792 1160 CONTINUE
16793      DO1165I=1,MAXCHA
16794      PCHATH(I)=PDEFTH
16795 1165 CONTINUE
16796C
16797      IF(IFEEDB.EQ.'OFF')GOTO1169
16798      WRITE(ICOUT,999)
16799      CALL DPWRST('XXX','BUG ')
16800      I=1
16801      WRITE(ICOUT,1116)PCHATH(I)
16802      CALL DPWRST('XXX','BUG ')
16803 1169 CONTINUE
16804      GOTO1190
16805C
16806 1190 CONTINUE
16807      IFOUND='YES'
16808C
16809 1199 CONTINUE
16810      RETURN
16811      END
16812      SUBROUTINE DPCHUN(IHARG,NUMARG,MAXCHA,ICHATY,IFOUND,IERROR)
16813C
16814C     PURPOSE--DEFINE PLOT CHARACTER UNITS (DATA OR SCREEN) FOR USE IN
16815C              MULTI-TRACE PLOTS.  THE UNITS FOR THE CHARACTER FOR THE
16816C              I-TH TRACE WILL BE PLACED IN THE I-TH ELEMENT OF THE
16817C              HOLLERITH VECTOR ICHATY(.).
16818C
16819C              THE UNITS ARE SPECIFIED AS:
16820C
16821C                 DD     => X AXIS = DATA UNITS,   Y AXIS = DATA UNITS
16822C                 DS     => X AXIS = DATA UNITS,   Y AXIS = SCREEN UNITS
16823C                 SD     => X AXIS = SCREEN UNITS, Y AXIS = DATA UNITS
16824C                 SS     => X AXIS = SCREEN UNITS, Y AXIS = SCREEN UNITS
16825C                 DATA   => X AXIS = DATA UNITS,   Y AXIS = DATA UNITS
16826C                 SCREEN => X AXIS = SCREEN UNITS, Y AXIS = SCREEN UNITS
16827C
16828C              THE DEFAULT IS DATA UNITS FOR BOTH AXES.
16829C
16830C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
16831C                     --NUMARG
16832C                     --MAXCHA
16833C     OUTPUT ARGUMENTS--ICHATY  (A  HOLLERITH VECTOR WHOSE I-TH ELEMENT
16834C                       IS THE UNITS FOR THE CHARACTER ASSIGNED TO THE
16835C                       I-TH TRACE IN A MULTI-TRACE PLOT.
16836C                     --IFOUND ('YES' OR 'NO' )
16837C                     --IERROR ('YES' OR 'NO' )
16838C     WRITTEN BY--ALAN HECKERT
16839C                 STATISTICAL ENGINEERING DIVISION
16840C                 INFORMATION TECHNOLOGY LABORATORY
16841C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
16842C                 GAITHERSBURG, MD 20899-8980
16843C                 PHONE--301-975-2899
16844C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
16845C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
16846C     LANGUAGE--ANSI FORTRAN (1977)
16847C     VERSION NUMBER--2018/01
16848C     ORIGINAL VERSION--JANUARY   2018.
16849C
16850C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
16851C
16852      CHARACTER*4 IHARG
16853      CHARACTER*4 ICHATY
16854      CHARACTER*4 IFOUND
16855      CHARACTER*4 IERROR
16856C
16857      CHARACTER*4 IDEFTY
16858C
16859C---------------------------------------------------------------------
16860C
16861      DIMENSION IHARG(*)
16862      DIMENSION ICHATY(*)
16863C
16864C---------------------------------------------------------------------
16865C
16866      INCLUDE 'DPCOP2.INC'
16867C
16868C-----START POINT-----------------------------------------------------
16869C
16870      IFOUND='YES'
16871      IERROR='NO'
16872      IDEFTY='DD'
16873C
16874      IF((NUMARG.EQ.1.AND.IHARG(1).EQ.'UNIT') .OR.
16875     1   (NUMARG.EQ.2.AND.IHARG(2).EQ.'ALL'))THEN
16876        DO1165I=1,MAXCHA
16877          ICHATY(I)=IDEFTY
16878 1165   CONTINUE
16879C
16880        IF(IFEEDB.EQ.'ON')THEN
16881          WRITE(ICOUT,999)
16882          CALL DPWRST('XXX','BUG ')
16883          I=1
16884          WRITE(ICOUT,1116)ICHATY(I)
16885          CALL DPWRST('XXX','BUG ')
16886        ENDIF
16887      ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'UNIT')THEN
16888        IF(IHARG(NUMARG).EQ.'ON'   .OR. IHARG(NUMARG).EQ.'OFF' .OR.
16889     1     IHARG(NUMARG).EQ.'AUTO' .OR. IHARG(NUMARG).EQ.'DEFA')THEN
16890          DO1115I=1,MAXCHA
16891            ICHATY(I)=IDEFTY
16892 1115     CONTINUE
16893C
16894          IF(IFEEDB.EQ.'ON')THEN
16895            WRITE(ICOUT,999)
16896  999       FORMAT(1X)
16897            CALL DPWRST('XXX','BUG ')
16898            I=1
16899            WRITE(ICOUT,1116)ICHATY(I)
16900 1116       FORMAT('ALL CHARACTER UNITS HAVE JUST BEEN SET TO ',A4)
16901            CALL DPWRST('XXX','BUG ')
16902          ENDIF
16903        ELSEIF(NUMARG.EQ.2)THEN
16904          ICHATY(1)=IHARG(2)
16905          IF(ICHATY(1).EQ.'SCRE' .OR. ICHATY(1).EQ.'SS  ')THEN
16906            ICHATY(1)='SS  '
16907          ELSEIF(ICHATY(1).EQ.'DATA' .OR. ICHATY(1).EQ.'DD  ')THEN
16908            ICHATY(1)='DD  '
16909          ELSE
16910            IF(ICHATY(1).NE.'DS  ' .AND. ICHATY(1).NE.'SD  ')THEN
16911              ICHATY(1)='DD'
16912            ENDIF
16913          ENDIF
16914C
16915          IF(IFEEDB.EQ.'ON')THEN
16916            WRITE(ICOUT,999)
16917            CALL DPWRST('XXX','BUG ')
16918            I=1
16919            WRITE(ICOUT,1126)I,ICHATY(I)
16920 1126       FORMAT('THE UNITS FOR CHARACTER ',I6,
16921     1             ' HAS JUST BEEN SET TO ',A4)
16922            CALL DPWRST('XXX','BUG ')
16923          ENDIF
16924        ELSEIF(NUMARG.GE.3.AND.IHARG(2).EQ.'ALL')THEN
16925          DO1135I=1,MAXCHA
16926            ICHATY(I)=IHARG(3)
16927            IF(ICHATY(I).EQ.'SCRE' .OR. ICHATY(I).EQ.'SS  ')THEN
16928              ICHATY(I)='SS  '
16929            ELSEIF(ICHATY(I).EQ.'DATA' .OR. ICHATY(I).EQ.'DD  ')THEN
16930              ICHATY(I)='DD  '
16931            ELSE
16932              IF(ICHATY(I).NE.'DS  ' .AND. ICHATY(I).NE.'SD  ')THEN
16933                ICHATY(I)='DD'
16934              ENDIF
16935            ENDIF
16936 1135     CONTINUE
16937C
16938          IF(IFEEDB.EQ.'ON')THEN
16939            WRITE(ICOUT,999)
16940            CALL DPWRST('XXX','BUG ')
16941            I=1
16942            WRITE(ICOUT,1116)ICHATY(I)
16943            CALL DPWRST('XXX','BUG ')
16944          ENDIF
16945        ELSEIF(NUMARG.GE.3.AND.IHARG(3).EQ.'ALL')THEN
16946          DO1145I=1,MAXCHA
16947            ICHATY(I)=IHARG(2)
16948            IF(ICHATY(I).EQ.'SCRE' .OR. ICHATY(I).EQ.'SS  ')THEN
16949              ICHATY(I)='SS  '
16950            ELSEIF(ICHATY(I).EQ.'DATA' .OR. ICHATY(I).EQ.'DD  ')THEN
16951              ICHATY(I)='DD  '
16952            ELSE
16953              IF(ICHATY(I).NE.'DS  ' .AND. ICHATY(I).NE.'SD  ')THEN
16954                ICHATY(I)='DD'
16955              ENDIF
16956            ENDIF
16957 1145     CONTINUE
16958C
16959          IF(IFEEDB.EQ.'ON')THEN
16960            WRITE(ICOUT,999)
16961            CALL DPWRST('XXX','BUG ')
16962            I=1
16963            WRITE(ICOUT,1116)ICHATY(I)
16964            CALL DPWRST('XXX','BUG ')
16965          ENDIF
16966C
16967        ELSE
16968          IMAX=NUMARG-1
16969          IF(MAXCHA.LT.IMAX)IMAX=MAXCHA
16970          DO1155I=1,IMAX
16971            IP1=I+1
16972            ICHATY(I)=IHARG(IP1)
16973            IF(ICHATY(I).EQ.'SCRE' .OR. ICHATY(I).EQ.'SS  ')THEN
16974              ICHATY(I)='SS  '
16975            ELSEIF(ICHATY(I).EQ.'DATA' .OR. ICHATY(I).EQ.'DD  ')THEN
16976              ICHATY(I)='DD  '
16977            ELSE
16978              IF(ICHATY(I).NE.'DS  ' .AND. ICHATY(I).NE.'SD  ')THEN
16979                ICHATY(I)='DD'
16980              ENDIF
16981            ENDIF
16982 1155     CONTINUE
16983C
16984          IF(IFEEDB.EQ.'ON')THEN
16985            WRITE(ICOUT,999)
16986            CALL DPWRST('XXX','BUG ')
16987            DO1156I=1,IMAX
16988              WRITE(ICOUT,1126)I,ICHATY(I)
16989              CALL DPWRST('XXX','BUG ')
16990 1156       CONTINUE
16991          ENDIF
16992        ENDIF
16993      ELSE
16994        IFOUND='NO'
16995      ENDIF
16996C
16997      RETURN
16998      END
16999      SUBROUTINE DPCHIS(MAXNXT,
17000     1                  ICASAN,ICAPSW,IFORSW,
17001     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
17002C
17003C     PURPOSE--COMPUTE THE CHI-SQUARE TEST FOR INDEPENDENCE
17004C     EXAMPLE--CHI-SQUARE INDEPENDENCE TEST Y1 Y2
17005C            --CHI-SQUARE INDEPENDENCE TEST N11 N21 N12 N22
17006C            --CHI-SQUARE INDEPENDENCE TEST M
17007C     REFERENCE--CONOVER (1999), "PRACTICAL NONPARAMETRIC
17008C                STATISTICS", THIRD EDITION, WILEY, PP. 204-216.
17009C     WRITTEN BY--ALAN HECKERT
17010C                 STATISTICAL ENGINEERING DIVISION
17011C                 INFORMATION TECHNOLOGY LABORATORY
17012C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
17013C                 GAITHERSBURG, MD 20899-8980
17014C                 PHONE--301-975-2899
17015C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
17016C           OF THE NATIONAL BUREAU OF STANDARDS.
17017C     LANGUAGE--ANSI FORTRAN (1977)
17018C     VERSION NUMBER--2007/3
17019C     ORIGINAL VERSION--MARCH     2007.
17020C     UPDATED         --JANUARY   2011. USE DPPARS, DPPAR3, DPPAR6
17021C     UPDATED         --JUNE      2019. TWEAK TO SCRATCH STORAGE
17022C
17023C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
17024C
17025      CHARACTER*4 ICASAN
17026      CHARACTER*4 ICAPSW
17027      CHARACTER*4 IFORSW
17028C
17029      CHARACTER*4 IBUGA2
17030      CHARACTER*4 IBUGA3
17031      CHARACTER*4 IBUGQ
17032      CHARACTER*4 ISUBRO
17033      CHARACTER*4 IFOUND
17034      CHARACTER*4 IERROR
17035C
17036      CHARACTER*4 ICASEQ
17037      CHARACTER*4 ISUBN1
17038      CHARACTER*4 ISUBN2
17039      CHARACTER*4 ISTEPN
17040      CHARACTER*4 IH
17041      CHARACTER*4 IH2
17042      CHARACTER*4 IHOST1
17043      CHARACTER*4 ISUBN0
17044      CHARACTER*4 ICASE
17045C
17046      CHARACTER*40 INAME
17047C
17048      PARAMETER (MAXSPN=20)
17049      CHARACTER*4 IVARN1(MAXSPN)
17050      CHARACTER*4 IVARN2(MAXSPN)
17051      CHARACTER*4 IVARTY(MAXSPN)
17052      REAL PVAR(MAXSPN)
17053      INTEGER ILIS(MAXSPN)
17054      INTEGER NRIGHT(MAXSPN)
17055      INTEGER ICOLR(MAXSPN)
17056C
17057C---------------------------------------------------------------------
17058C
17059      PARAMETER(MAXLEV=1000)
17060C
17061      INCLUDE 'DPCOPA.INC'
17062      INCLUDE 'DPCOZZ.INC'
17063      INCLUDE 'DPCOZD.INC'
17064C
17065      REAL TEMP1(MAXOBV)
17066      REAL TEMP2(MAXOBV)
17067      REAL TEMP3(MAXOBV)
17068      REAL XIDTEM(MAXOBV)
17069      REAL XIDTE2(MAXOBV)
17070      REAL XMAT(MAXLEV,MAXLEV)
17071C
17072      DOUBLE PRECISION ROWTOT(MAXOBV)
17073      DOUBLE PRECISION COLTOT(MAXOBV)
17074C
17075      EQUIVALENCE (GARBAG(IGARB1),TEMP1(1))
17076      EQUIVALENCE (GARBAG(IGARB2),TEMP2(1))
17077      EQUIVALENCE (GARBAG(IGARB3),TEMP3(1))
17078      EQUIVALENCE (GARBAG(IGARB4),XIDTEM(1))
17079      EQUIVALENCE (GARBAG(IGARB5),XIDTE2(1))
17080      EQUIVALENCE (GARBAG(IGARB6),XMAT(1,1))
17081C
17082      EQUIVALENCE (DGARBG(IDGAR1),ROWTOT(1))
17083      EQUIVALENCE (DGARBG(IDGAR2),COLTOT(1))
17084C
17085C
17086C-----COMMON----------------------------------------------------------
17087C
17088      INCLUDE 'DPCOHK.INC'
17089      INCLUDE 'DPCOSU.INC'
17090      INCLUDE 'DPCOST.INC'
17091      INCLUDE 'DPCODA.INC'
17092C
17093C-----COMMON VARIABLES (GENERAL)--------------------------------------
17094C
17095      INCLUDE 'DPCOP2.INC'
17096C
17097C-----START POINT-----------------------------------------------------
17098C
17099      ISUBN1='DPCH'
17100      ISUBN2='IS  '
17101C
17102      MAXCP1=MAXCOL+1
17103      MAXCP2=MAXCOL+2
17104      MAXCP3=MAXCOL+3
17105      MAXCP4=MAXCOL+4
17106      MAXCP5=MAXCOL+5
17107      MAXCP6=MAXCOL+6
17108C
17109      IFOUND='NO'
17110      IERROR='NO'
17111C
17112      N11=(-999)
17113      N21=(-999)
17114      N12=(-999)
17115      N22=(-999)
17116      AN11=0.0
17117      AN12=0.0
17118      AN21=0.0
17119      AN22=0.0
17120C
17121      NS1=(-999)
17122      NS2=(-999)
17123      NS3=(-999)
17124      NS4=(-999)
17125C
17126      ICASE='PARA'
17127      MINN2=2
17128C
17129      IFOUND='YES'
17130      ICASEQ='UNKN'
17131C
17132C               ***************************************************
17133C               **  TREAT THE CHI-SQUARE INDEPENDENCE TEST CASE  **
17134C               ***************************************************
17135C
17136      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CHIS')THEN
17137        WRITE(ICOUT,999)
17138  999   FORMAT(1X)
17139        CALL DPWRST('XXX','BUG ')
17140        WRITE(ICOUT,51)
17141   51   FORMAT('***** AT THE BEGINNING OF DPCHIS--')
17142        CALL DPWRST('XXX','BUG ')
17143        WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ,ICASAN
17144   52   FORMAT('IBUGA2,IBUGA3,IBUGQ,ICASAN = ',3(A4,2X),A4)
17145        CALL DPWRST('XXX','BUG ')
17146        WRITE(ICOUT,55)MAXNXT,NUMARG
17147   55   FORMAT('MAXNXT,NUMARG = ',2I8)
17148        CALL DPWRST('XXX','BUG ')
17149        DO59I=1,NUMARG
17150          WRITE(ICOUT,57)I,IHARG(I),IHARG2(I),ARG(I)
17151   57     FORMAT('I,IHARG(I),IHARG2(I),ARG(I) = ',I5,A4,A4,G15.7)
17152   59   CONTINUE
17153      ENDIF
17154C
17155C               *********************************
17156C               **  STEP 4--                   **
17157C               **  EXTRACT THE VARIABLE LIST  **
17158C               *********************************
17159C
17160      ISTEPN='4'
17161      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CHIS')
17162     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17163C
17164      INAME='CHI-SQUARE INDEPENDENCE TEST'
17165      MINNA=1
17166      MAXNA=100
17167      MINN2=2
17168      IFLAGE=0
17169      IFLAGM=9
17170      IFLAGP=9
17171      JMIN=1
17172      JMAX=NUMARG
17173      MINNVA=1
17174      MAXNVA=4
17175C
17176      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
17177     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
17178     1            JMIN,JMAX,
17179     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
17180     1            IVARN1,IVARN2,IVARTY,PVAR,
17181     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
17182     1            MINNVA,MAXNVA,
17183     1            IFLAGM,IFLAGP,
17184     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
17185      IF(IERROR.EQ.'YES')GOTO9000
17186C
17187      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CHIS')THEN
17188        WRITE(ICOUT,999)
17189        CALL DPWRST('XXX','BUG ')
17190        WRITE(ICOUT,281)
17191  281   FORMAT('***** AFTER CALL DPPARS--')
17192        CALL DPWRST('XXX','BUG ')
17193        WRITE(ICOUT,282)NQ,NUMVAR
17194  282   FORMAT('NQ,NUMVAR = ',2I8)
17195        CALL DPWRST('XXX','BUG ')
17196        IF(NUMVAR.GT.0)THEN
17197          DO285I=1,NUMVAR
17198            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
17199     1                      ICOLR(I),PVAR(I)
17200  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
17201     1             'ICOLR(I),PVAR(I) = ',I8,2X,A4,A4,2X,3I8,G15.7)
17202            CALL DPWRST('XXX','BUG ')
17203  285     CONTINUE
17204        ENDIF
17205      ENDIF
17206C
17207C               ***********************************
17208C               **  STEP 22--                    **
17209C               **  CHECK FOR PROPER VALUES FOR  **
17210C               **  INPUT PARAMETERS             **
17211C               ***********************************
17212C
17213      IF(IVARTY(1).EQ.'PARA' .OR. IVARTY(1).EQ.'NUMB')THEN
17214        N11=INT(PVAR(1)+0.5)
17215        N21=INT(PVAR(2)+0.5)
17216        N12=INT(PVAR(3)+0.5)
17217        N22=INT(PVAR(4)+0.5)
17218        AN11=REAL(N11)
17219        AN21=REAL(N21)
17220        AN12=REAL(N12)
17221        AN22=REAL(N22)
17222        ICASE='PARA'
17223C
17224        ISTEPN='22'
17225        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CHIS')
17226     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17227C
17228        IF(N11.LT.0)THEN
17229          WRITE(ICOUT,999)
17230          CALL DPWRST('XXX','BUG ')
17231          WRITE(ICOUT,2201)
17232 2201     FORMAT('***** ERROR FROM CHI-SQUARE INDEPENDENCE TEST--')
17233          CALL DPWRST('XXX','BUG ')
17234          WRITE(ICOUT,2203)
17235 2203     FORMAT('      THE VALUE OF THE FIRST PARAMETER (N11 = THE ',
17236     1           'NUMBER OF SUCCESSES')
17237          CALL DPWRST('XXX','BUG ')
17238          WRITE(ICOUT,2204)
17239 2204     FORMAT('      FOR THE FIRST VARIABLE MUST BE NON-NEGATIVE.')
17240          CALL DPWRST('XXX','BUG ')
17241          WRITE(ICOUT,2205)N11
17242 2205     FORMAT('      N11 = ',I8)
17243          CALL DPWRST('XXX','BUG ')
17244          IERROR='YES'
17245          GOTO9000
17246C
17247        ELSEIF(N21.LT.0)THEN
17248          WRITE(ICOUT,999)
17249          CALL DPWRST('XXX','BUG ')
17250          WRITE(ICOUT,2201)
17251          CALL DPWRST('XXX','BUG ')
17252          WRITE(ICOUT,2303)
17253 2303     FORMAT('      THE VALUE OF THE SECOND PARAMETER (N21 = THE ',
17254     1           'NUMBER OF FAILURES')
17255          CALL DPWRST('XXX','BUG ')
17256          WRITE(ICOUT,2304)
17257 2304     FORMAT('      FOR THE FIRST VARIABLE MUST BE NON-NEGATIVE.')
17258          CALL DPWRST('XXX','BUG ')
17259          WRITE(ICOUT,2305)N21
17260 2305     FORMAT('      N21 = ',I8)
17261          CALL DPWRST('XXX','BUG ')
17262          IERROR='YES'
17263          GOTO9000
17264C
17265        ELSEIF(N12.LT.0)THEN
17266          WRITE(ICOUT,999)
17267          CALL DPWRST('XXX','BUG ')
17268          WRITE(ICOUT,2201)
17269          CALL DPWRST('XXX','BUG ')
17270          WRITE(ICOUT,2403)
17271 2403     FORMAT('      THE VALUE OF THE THIRD PARAMETER (N12 = THE ',
17272     1           'NUMBER OF SUCCESSES')
17273          CALL DPWRST('XXX','BUG ')
17274          WRITE(ICOUT,2404)
17275 2404     FORMAT('      FOR THE SECOND VARIABLE MUST BE NON-NEGATIVE.')
17276          CALL DPWRST('XXX','BUG ')
17277          WRITE(ICOUT,2405)N12
17278 2405     FORMAT('      N12 = ',I8)
17279          CALL DPWRST('XXX','BUG ')
17280          IERROR='YES'
17281          GOTO9000
17282C
17283        ELSEIF(N22.LT.0)THEN
17284          WRITE(ICOUT,999)
17285          CALL DPWRST('XXX','BUG ')
17286          WRITE(ICOUT,2201)
17287          CALL DPWRST('XXX','BUG ')
17288          WRITE(ICOUT,2503)
17289 2503     FORMAT('      THE VALUE OF THE FOURTH PARAMETER (N22 = THE ',
17290     1           'NUMBER OF FAILURES')
17291          CALL DPWRST('XXX','BUG ')
17292          WRITE(ICOUT,2504)
17293 2504     FORMAT('      FOR THE SECOND VARIABLE MUST BE NON-NEGATIVE.')
17294          CALL DPWRST('XXX','BUG ')
17295          WRITE(ICOUT,2505)N22
17296 2505     FORMAT('      N22 = ',I8)
17297          CALL DPWRST('XXX','BUG ')
17298          IERROR='YES'
17299          GOTO9000
17300        ENDIF
17301C
17302      ELSEIF(IVARTY(1).EQ.'VARI')THEN
17303C
17304        ICASE='VARI'
17305        ICOL=1
17306        IF(NUMVAR.GT.2)THEN
17307          WRITE(ICOUT,999)
17308          CALL DPWRST('XXX','BUG ')
17309          WRITE(ICOUT,2201)
17310          CALL DPWRST('XXX','BUG ')
17311          WRITE(ICOUT,2603)
17312 2603     FORMAT('      MORE THAN TWO VARIABLES GIVEN.')
17313          CALL DPWRST('XXX','BUG ')
17314          WRITE(ICOUT,2605)NUMVAR
17315 2605     FORMAT('      THE NUMBER OF VARIABLES GIVEN  = ',I5)
17316          CALL DPWRST('XXX','BUG ')
17317          IERROR='YES'
17318          GOTO9000
17319        ENDIF
17320        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
17321     1              INAME,IVARN1,IVARN2,IVARTY,
17322     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
17323     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
17324     1              MAXCP4,MAXCP5,MAXCP6,
17325     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
17326     1              Y,X,X,NLOCAL,NLOCA2,NLOCA3,ICASE,
17327     1              IBUGA3,ISUBRO,IFOUND,IERROR)
17328        IF(IERROR.EQ.'YES')GOTO9000
17329        NS1=NLOCAL
17330        NS2=NLOCA2
17331C
17332      ELSEIF(IVARTY(1).EQ.'MATR')THEN
17333        ICASE='MATR'
17334        ICOL=1
17335        NUMVAR=1
17336        CALL DPPAR6(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
17337     1              INAME,IVARN1,IVARN2,IVARTY,
17338     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
17339     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
17340     1              MAXCP4,MAXCP5,MAXCP6,
17341     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
17342     1              XMAT,MAXLEV,NROW,NCOL,ICASE,
17343     1              IBUGA3,ISUBRO,IFOUND,IERROR)
17344        ICASE='TABL'
17345        IF(IERROR.EQ.'YES')GOTO9000
17346      ENDIF
17347C
17348C               ***********************************
17349C               **  STEP 61--                    **
17350C               **  COMPUTE THE CHI-SQUARE TEST  **
17351C               ***********************************
17352C
17353      ISTEPN='61'
17354      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CHIS')
17355     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17356C
17357      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CHIS')THEN
17358        WRITE(ICOUT,999)
17359        CALL DPWRST('XXX','BUG ')
17360        WRITE(ICOUT,6111)
17361 6111   FORMAT('***** FROM DPCHIS--READY TO COMPUTE TEST')
17362        CALL DPWRST('XXX','BUG ')
17363        WRITE(ICOUT,6112)AN11,AN21,AN12,AN22
17364 6112   FORMAT('AN11,AN21,AN12,AN22 = ',4G15.7)
17365        CALL DPWRST('XXX','BUG ')
17366      ENDIF
17367C
17368      CALL DPCHI2(Y,NS1,X,NS2,
17369     1            AN11,AN21,AN12,AN22,
17370     1            XMAT,MAXLEV,NROW,NCOL,
17371     1            XIDTEM,XIDTE2,TEMP1,TEMP2,TEMP3,MAXOBW,
17372     1            ROWTOT,COLTOT,
17373     1            ICASE,
17374     1            ICAPSW,ICAPTY,IFORSW,
17375     1            STATVA,CDF,STATV2,CDF2,
17376     1            ISUBRO,IBUGA3,IERROR)
17377C
17378C               ***************************************
17379C               **  STEP 62--                        **
17380C               **  UPDATE INTERNAL DATAPLOT TABLES  **
17381C               ***************************************
17382C
17383      ISTEPN='62'
17384      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CHIS')
17385     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17386C
17387      ISUBN0='CHIS'
17388C
17389      IH='STAT'
17390      IH2='VAL '
17391      VALUE0=STATVA
17392      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
17393     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
17394     1IANS,IWIDTH,IBUGA3,IERROR)
17395C
17396      IH='STAT'
17397      IH2='CDF '
17398      VALUE0=CDF
17399      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
17400     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
17401     1IANS,IWIDTH,IBUGA3,IERROR)
17402C
17403      IH='STAT'
17404      IH2='VAL2'
17405      VALUE0=STATV2
17406      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
17407     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
17408     1IANS,IWIDTH,IBUGA3,IERROR)
17409C
17410      IH='STAT'
17411      IH2='CDF2'
17412      VALUE0=CDF2
17413      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
17414     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
17415     1IANS,IWIDTH,IBUGA3,IERROR)
17416C
17417C               *****************
17418C               **  STEP 90--  **
17419C               **  EXIT       **
17420C               *****************
17421C
17422 9000 CONTINUE
17423      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CHIS')THEN
17424        WRITE(ICOUT,999)
17425        CALL DPWRST('XXX','BUG ')
17426        WRITE(ICOUT,9011)
17427 9011   FORMAT('***** AT THE END       OF DPCHIS--')
17428        CALL DPWRST('XXX','BUG ')
17429        WRITE(ICOUT,9012)IBUGA2,IBUGA3
17430 9012   FORMAT('IBUGA2,IBUGA3 = ',A4,2X,A4)
17431        CALL DPWRST('XXX','BUG ')
17432        WRITE(ICOUT,9016)IERROR
17433 9016   FORMAT('IERROR = ',A4,2X,A4)
17434        CALL DPWRST('XXX','BUG ')
17435      ENDIF
17436C
17437      RETURN
17438      END
17439      SUBROUTINE DPCHI2(Y1,N1,Y2,N2,
17440     1                  AN11,AN21,AN12,AN22,
17441     1                  XMAT,MAXLEV,NROW,NCOL,
17442     1                  XIDTEM,XIDTE2,TEMP1,TEMP2,TEMP3,MAXNXT,
17443     1                  ROWTOT,COLTOT,
17444     1                  ICASE,
17445     1                  ICAPSW,ICAPTY,IFORSW,
17446     1                  STATVA,CDF,STATV2,CDF2,
17447     1                  ISUBRO,IBUGA3,IERROR)
17448C
17449C     PURPOSE--PERFORM A CHI-SQUARE TEST FOR INDEPENDENCE.
17450C              THE INPUT CAN BE ENTERED IN THE FOLLOWING WAYS:
17451C
17452C              1) THE COMMON CASE OF A 2X2 TABLE CAN BE
17453C                 ENTERED AS 4 PARAMETERS:
17454C
17455C                    N11 = NUMBER OF SUCCESSES FOR VARIABLE 1
17456C                    N21 = NUMBER OF FAILURES  FOR VARIABLE 1
17457C                    N12 = NUMBER OF SUCCESSES FOR VARIABLE 2
17458C                    N22 = NUMBER OF SUCCESSES FOR VARIABLE 2
17459C
17460C              2) AS RAW DATA, THAT IS TWO VARIABLES.  A
17461C                 CROSS-TABULATION IS PERFORMED TO GENERATE
17462C                 AN RXC TABLE OF COUNTS.
17463C
17464C              3) AS A MATRIX, I.E., THE RXC TABLE HAS ALREADY
17465C                 BEEN GENERATED.
17466C
17467C              THE CHI-SQUARE TEST CAN THEN BE COMPUTED AS:
17468C
17469C                 CHI-SQUARE = SUM[(f - F)**2/F
17470C
17471C              WHERE THE SUMMATION IS OVER ALL CELLS IN THE
17472C              TABLE AND WHERE
17473C
17474C                 f   = OBSERVED FFEQUENCY OF THE CELL
17475C                 F   = EXPECTED FREQUENCY OF THE CELL
17476C                     = (ROW TOTAL)*(COLUMN TOTAL)/(GRAND TOTAL)
17477C
17478C              SOME ANALYSTS PREFER TO USE THE YATES CONTINUITY
17479C              CORRECTION.  IN THIS CORRECTON, 0.5 IS ADDED TO
17480C              EACH CELL.  DATAPLOT WILL GENERATE THE TEST STATISTIC
17481C              FOR BOTH THE UNCORRECTED AND CORRECTED CASES.
17482C
17483C     EXAMPLE--CHI-SQUARE INDEPENDENCE TEST Y1 Y2
17484C            --CHI-SQUARE INDEPENDENCE TEST N11 N21 N12 N22
17485C            --CHI-SQUARE INDEPENDENCE TEST M
17486C     WRITTEN BY--ALAN HECKERT
17487C                 STATISTICAL ENGINEERING DIVISION
17488C                 INFORMATION TECHNOLOGYU LABORATORY
17489C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
17490C                 GAITHERSBURG, MD 20899-8980
17491C                 PHONE--301-975-2899
17492C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
17493C           OF THE NATIONAL BUREAU OF STANDARDS.
17494C     LANGUAGE--ANSI FORTRAN (1977)
17495C     VERSION NUMBER--2007/3
17496C     ORIGINAL VERSION--MARCH     2007.
17497C     UPDATED         --JANUARY   2011. USE DPAUFI TO OPEN/CLOSE
17498C                                       AUXILLARY FILES
17499C     UPDATED         --JANUARY   2011. USE DPDTA1, DPDT5B TO PRINT
17500C                                       TABLES
17501C     UPDATED         --APRIL     2019. USER CAN SPECIFY NUMBER OF
17502C                                       DECIMAL POINTS FOR AUXILLARY
17503C                                       FILES
17504C
17505C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
17506C
17507      CHARACTER*4 ISUBRO
17508      CHARACTER*4 IBUGA3
17509      CHARACTER*4 IERROR
17510      CHARACTER*4 ICASE
17511      CHARACTER*4 ICAPSW
17512      CHARACTER*4 ICAPTY
17513      CHARACTER*4 IFORSW
17514C
17515      CHARACTER*4 IWRITE
17516      CHARACTER*6 ICONC1
17517      CHARACTER*6 ICONC2
17518      CHARACTER*6 ICONC3
17519      CHARACTER*6 ICONC4
17520      CHARACTER*6 ICONC5
17521      CHARACTER*6 ICONC6
17522      CHARACTER*6 KCONC1
17523      CHARACTER*6 KCONC2
17524      CHARACTER*6 KCONC3
17525      CHARACTER*6 KCONC4
17526      CHARACTER*6 KCONC5
17527      CHARACTER*6 KCONC6
17528C
17529      CHARACTER*4 ISUBN1
17530      CHARACTER*4 ISUBN2
17531      CHARACTER*4 ISTEPN
17532C
17533      CHARACTER*4 IOP
17534      CHARACTER*20 IFORMT
17535C
17536C---------------------------------------------------------------------
17537C
17538      DIMENSION Y1(*)
17539      DIMENSION Y2(*)
17540      DIMENSION TEMP1(*)
17541      DIMENSION TEMP2(*)
17542      DIMENSION TEMP3(*)
17543      DIMENSION XIDTEM(*)
17544      DIMENSION XIDTE2(*)
17545C
17546      DIMENSION XMAT(MAXLEV,MAXLEV)
17547C
17548      DOUBLE PRECISION ROWTOT(*)
17549      DOUBLE PRECISION COLTOT(*)
17550C
17551      PARAMETER (NUMALP=6)
17552CCCCC DIMENSION SIGVAL(NUMALP)
17553CCCCC DIMENSION ALOWCL(NUMALP)
17554CCCCC DIMENSION AUPPCL(NUMALP)
17555CCCCC DIMENSION ALOWC2(NUMALP)
17556CCCCC DIMENSION AUPPC2(NUMALP)
17557C
17558      DOUBLE PRECISION GTOTAL
17559      DOUBLE PRECISION VALTMP
17560      DOUBLE PRECISION EXP
17561      DOUBLE PRECISION CHISQ1
17562      DOUBLE PRECISION CHISQ2
17563C
17564      PARAMETER(NUMCLI=5)
17565      PARAMETER(MAXLIN=3)
17566      PARAMETER (MAXROW=NUMALP)
17567      PARAMETER (MAXRO2=30)
17568      CHARACTER*60 ITITLE
17569      CHARACTER*60 ITITLZ
17570      CHARACTER*60 ITITL9
17571      CHARACTER*60 ITEXT(MAXRO2)
17572      CHARACTER*4  ALIGN(NUMCLI)
17573      CHARACTER*4  VALIGN(NUMCLI)
17574      REAL         AVALUE(MAXRO2)
17575      INTEGER      NCTEXT(MAXRO2)
17576      INTEGER      IDIGIT(MAXRO2)
17577      INTEGER      NTOT(MAXRO2)
17578      CHARACTER*60 ITITL2(MAXLIN,NUMCLI)
17579      CHARACTER*15 IVALUE(MAXROW,NUMCLI)
17580      CHARACTER*4  ITYPCO(NUMCLI)
17581      INTEGER      NCTIT2(MAXLIN,NUMCLI)
17582      INTEGER      NCVALU(MAXROW,NUMCLI)
17583      INTEGER      IWHTML(NUMCLI)
17584      INTEGER      IWRTF(NUMCLI)
17585      REAL         AMAT(MAXROW,NUMCLI)
17586      LOGICAL IFRST
17587      LOGICAL ILAST
17588      LOGICAL IFLAGS
17589      LOGICAL IFLAGE
17590C
17591      INCLUDE 'DPCOST.INC'
17592C
17593C---------------------------------------------------------------------
17594C
17595      INCLUDE 'DPCOP2.INC'
17596C
17597CCCCC DATA SIGVAL /0.50, 0.80, 0.90, 0.95, 0.975, 0.99/
17598C
17599C-----START POINT-----------------------------------------------------
17600C
17601      ISUBN1='DPCH'
17602      ISUBN2='I2  '
17603      IERROR='NO'
17604      IWRITE='NO'
17605C
17606      ICONC1='ACCEPT'
17607      ICONC2='ACCEPT'
17608      ICONC3='ACCEPT'
17609      ICONC4='ACCEPT'
17610      ICONC5='ACCEPT'
17611      ICONC6='ACCEPT'
17612C
17613      IOP='OPEN'
17614      IFLAG1=1
17615      IFLAG2=0
17616      IFLAG3=0
17617      IFLAG4=0
17618      IFLAG5=0
17619      CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
17620     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
17621     1            IBUGA3,ISUBRO,IERROR)
17622      IF(IERROR.EQ.'YES')GOTO9000
17623C
17624      WRITE(IOUNI1,41)
17625   41 FORMAT(5X,'ROW  COLUMN',9X,'ROWTOT',9X,'COLTOT',6X,'EXPECTED',
17626     1      8X,'OBSERVED')
17627C
17628      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CHI2')THEN
17629        WRITE(ICOUT,999)
17630  999   FORMAT(1X)
17631        CALL DPWRST('XXX','WRIT')
17632        WRITE(ICOUT,51)
17633   51   FORMAT('**** AT THE BEGINNING OF DPCHI2--')
17634        CALL DPWRST('XXX','WRIT')
17635        WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASE,MAXNXT
17636   52   FORMAT('IBUGA3,ISUBRO,ICASE,MAXNXT = ',4(A4,2X),I8)
17637        CALL DPWRST('XXX','WRIT')
17638        IF(ICASE.EQ.'VARI')THEN
17639          WRITE(ICOUT,55)N1
17640   55     FORMAT('N1 = ',I8)
17641          CALL DPWRST('XXX','WRIT')
17642          DO56I=1,N1
17643            WRITE(ICOUT,57)I,Y1(I)
17644   57       FORMAT('I,Y1(I) = ',I8,E15.7)
17645            CALL DPWRST('XXX','WRIT')
17646   56     CONTINUE
17647          WRITE(ICOUT,65)N2
17648   65     FORMAT('N2 = ',I8)
17649          CALL DPWRST('XXX','WRIT')
17650          DO66I=1,N2
17651            WRITE(ICOUT,67)I,Y2(I)
17652   67       FORMAT('I,Y2(I) = ',I8,E15.7)
17653            CALL DPWRST('XXX','WRIT')
17654   66     CONTINUE
17655        ELSE
17656          WRITE(ICOUT,75)AN11,AN21,AN12,AN22
17657   75     FORMAT('AN11,AN21,AN12,AN22 = ',4G15.7)
17658          CALL DPWRST('XXX','WRIT')
17659        ENDIF
17660      ENDIF
17661
17662C               ********************************************
17663C               **  STEP 0--                              **
17664C               **  BRANCH TO APPROPRIATE CASE (PARAMETER **
17665C               **  OR VARIABLE)                          **
17666C               ********************************************
17667C
17668      ISTEPN='00'
17669      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CHI2')
17670     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17671C
17672      IF(ICASE.EQ.'PARA')GOTO1000
17673      IF(ICASE.EQ.'VARI')GOTO2000
17674      IF(ICASE.EQ.'TABL')GOTO3000
17675C
17676C               ********************************************
17677C               **  STEP 11--                             **
17678C               **  PARAMETER CASE                        **
17679C               ********************************************
17680C
17681 1000 CONTINUE
17682C
17683      ISTEPN='11'
17684      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CHI2')
17685     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17686C
17687C               ********************************************
17688C               **  STEP 12--                             **
17689C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
17690C               ********************************************
17691C
17692      N11=INT(AN11+0.5)
17693      N21=INT(AN21+0.5)
17694      N12=INT(AN12+0.5)
17695      N22=INT(AN22+0.5)
17696C
17697      ISTEPN='12'
17698      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CHI2')
17699     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17700C
17701      IF(N11.LT.0)THEN
17702        WRITE(ICOUT,999)
17703        CALL DPWRST('XXX','BUG ')
17704        WRITE(ICOUT,1201)
17705 1201   FORMAT('***** ERROR FROM THE CHI-SQUARE INDEPENDENCE TEST--')
17706        CALL DPWRST('XXX','BUG ')
17707        WRITE(ICOUT,1203)
17708 1203   FORMAT('      THE VALUE OF THE FIRST PARAMETER (N11 = THE ',
17709     1         'NUMBER OF SUCCESSES')
17710        CALL DPWRST('XXX','BUG ')
17711        WRITE(ICOUT,1204)
17712 1204   FORMAT('      FOR THE FIRST VARIABLE MUST BE NON-NEGATIVE.')
17713        CALL DPWRST('XXX','BUG ')
17714        WRITE(ICOUT,1205)N11
17715 1205   FORMAT('      N11 = ',I8)
17716        CALL DPWRST('XXX','BUG ')
17717        IERROR='YES'
17718        GOTO9000
17719      ENDIF
17720C
17721      IF(N21.LT.0)THEN
17722        WRITE(ICOUT,999)
17723        CALL DPWRST('XXX','BUG ')
17724        WRITE(ICOUT,1201)
17725        CALL DPWRST('XXX','BUG ')
17726        WRITE(ICOUT,1303)
17727 1303   FORMAT('      THE VALUE OF THE SECOND PARAMETER (N21 = THE ',
17728     1         'NUMBER OF FAILURES')
17729        CALL DPWRST('XXX','BUG ')
17730        WRITE(ICOUT,1304)
17731 1304   FORMAT('      FOR THE FIRST VARIABLE MUST BE NON-NEGATIVE.')
17732        CALL DPWRST('XXX','BUG ')
17733        WRITE(ICOUT,1305)N21
17734 1305   FORMAT('      N21 = ',I8)
17735        CALL DPWRST('XXX','BUG ')
17736        IERROR='YES'
17737        GOTO9000
17738      ENDIF
17739C
17740      IF(N12.LT.0)THEN
17741        WRITE(ICOUT,999)
17742        CALL DPWRST('XXX','BUG ')
17743        WRITE(ICOUT,1201)
17744        CALL DPWRST('XXX','BUG ')
17745        WRITE(ICOUT,1403)
17746 1403   FORMAT('      THE VALUE OF THE THIRD PARAMETER (N12 = THE ',
17747     1         'NUMBER OF SUCCESSES')
17748        CALL DPWRST('XXX','BUG ')
17749        WRITE(ICOUT,1404)
17750 1404   FORMAT('      FOR THE SECOND VARIABLE MUST BE NON-NEGATIVE.')
17751        CALL DPWRST('XXX','BUG ')
17752        WRITE(ICOUT,1405)N12
17753 1405   FORMAT('      N12 = ',I8)
17754        CALL DPWRST('XXX','BUG ')
17755        IERROR='YES'
17756        GOTO9000
17757      ENDIF
17758C
17759      IF(N22.LT.0)THEN
17760        WRITE(ICOUT,999)
17761        CALL DPWRST('XXX','BUG ')
17762        WRITE(ICOUT,1201)
17763        CALL DPWRST('XXX','BUG ')
17764        WRITE(ICOUT,1503)
17765 1503   FORMAT('      THE VALUE OF THE FOURTH PARAMETER (N22 = THE ',
17766     1         'NUMBER OF FAILURES')
17767        CALL DPWRST('XXX','BUG ')
17768        WRITE(ICOUT,1504)
17769 1504   FORMAT('      FOR THE SECOND VARIABLE MUST BE NON-NEGATIVE.')
17770        CALL DPWRST('XXX','BUG ')
17771        WRITE(ICOUT,1505)N22
17772 1505   FORMAT('      N22 = ',I8)
17773        CALL DPWRST('XXX','BUG ')
17774        IERROR='YES'
17775        GOTO9000
17776      ENDIF
17777C
17778C               ********************************************
17779C               **  STEP 12--                             **
17780C               **  COMPUTE THE CHI-SQUARE TEST           **
17781C               ********************************************
17782C
17783C
17784      ROWTOT(1)=DBLE(AN11 + AN12)
17785      ROWTOT(2)=DBLE(AN21 + AN22)
17786      COLTOT(1)=DBLE(AN11 + AN21)
17787      COLTOT(2)=DBLE(AN12 + AN22)
17788      GTOTAL=ROWTOT(1) + ROWTOT(2)
17789      TEMP1(1)=AN11
17790      TEMP1(2)=AN21
17791      TEMP1(3)=AN12
17792      TEMP1(4)=AN22
17793      N1=N11 + N21
17794      N2=N12 + N22
17795      AN1=REAL(N1)
17796      AN2=REAL(N2)
17797C
17798      IFORMT='(2I8,4E15.7)'
17799      IF(IAUXDP.NE.7)THEN
17800        IFORMT=' '
17801        IF(IAUXDP.LE.9)THEN
17802          IFORMT='(2I8,4Exx.x)'
17803          ITOT=IAUXDP+8
17804          WRITE(IFORMT(8:9),'(I2)')ITOT
17805          WRITE(IFORMT(11:11),'(I1)')IAUXDP
17806        ELSE
17807          IFORMT='(2I8,4Exx.xx)'
17808          ITOT=IAUXDP+8
17809          WRITE(IFORMT(8:9),'(I2)')ITOT
17810          WRITE(IFORMT(11:12),'(I2)')IAUXDP
17811        ENDIF
17812      ENDIF
17813C
17814      IINDX=0
17815      CHISQ1=0.0D0
17816      CHISQ2=0.0D0
17817      DO1600J=1,2
17818        DO1610I=1,2
17819          IINDX=IINDX+1
17820          EXP=ROWTOT(I)*COLTOT(J)/GTOTAL
17821          VALTMP=DBLE(TEMP1(IINDX))
17822          CHISQ1=CHISQ1 + (VALTMP - EXP)**2/EXP
17823          VALTMP=DABS(DBLE(TEMP1(IINDX)) - EXP)
17824          VALTMP=(VALTMP - 0.5D0)**2/EXP
17825          CHISQ2=CHISQ2 + VALTMP
17826C
17827          WRITE(IOUNI1,IFORMT)I,J,ROWTOT(I),COLTOT(J),EXP,TEMP1(IINDX)
17828C1605     FORMAT(I8,I8,4E15.7)
17829C
17830 1610   CONTINUE
17831 1600 CONTINUE
17832      NROW=2
17833      NCOL=2
17834C
17835      GOTO4000
17836C
17837C               ********************************************
17838C               **  STEP 20--                             **
17839C               **  VARIABLE  CASE                        **
17840C               ********************************************
17841C
17842 2000 CONTINUE
17843C
17844C               ********************************************
17845C               **  STEP 21--                             **
17846C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
17847C               ********************************************
17848C
17849      ISTEPN='21'
17850      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CHI2')
17851     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17852C
17853      IF(N1.LT.2)THEN
17854        WRITE(ICOUT,999)
17855        CALL DPWRST('XXX','WRIT')
17856        WRITE(ICOUT,1201)
17857        CALL DPWRST('XXX','WRIT')
17858        WRITE(ICOUT,2101)
17859 2101   FORMAT('      THE NUMBER OF OBSERVATIONS FOR VARIABLE 1 ',
17860     1         'IS NON-POSITIVE')
17861        CALL DPWRST('XXX','WRIT')
17862        WRITE(ICOUT,2103)N1
17863 2103   FORMAT('SAMPLE SIZE = ',I8)
17864        CALL DPWRST('XXX','WRIT')
17865        IERROR='YES'
17866        GOTO9000
17867      ENDIF
17868C
17869      IF(N2.LT.2)THEN
17870        WRITE(ICOUT,999)
17871        CALL DPWRST('XXX','WRIT')
17872        WRITE(ICOUT,1201)
17873        CALL DPWRST('XXX','WRIT')
17874        WRITE(ICOUT,2106)
17875 2106   FORMAT('      THE NUMBER OF OBSERVATIONS FOR VARIABLE 2 ',
17876     1         'IS NON-POSITIVE')
17877        CALL DPWRST('XXX','WRIT')
17878        WRITE(ICOUT,2103)N2
17879        CALL DPWRST('XXX','WRIT')
17880        IERROR='YES'
17881        GOTO9000
17882      ENDIF
17883C
17884C               ******************************************************
17885C               **  STEP 2.2--                                      **
17886C               **  DETERMINE THE NUMBER OF DISTINCT VALUES         **
17887C               **  FOR THE GROUP VARIABLES (Y1, Y2).               **
17888C               ******************************************************
17889C
17890      ISTEPN='22'
17891      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CHI2')
17892     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17893C
17894      CALL DISTIN(Y1,N1,IWRITE,XIDTEM,NUMSE1,IBUGA3,IERROR)
17895      CALL SORT(XIDTEM,NUMSE1,XIDTEM)
17896      CALL DISTIN(Y2,N2,IWRITE,XIDTE2,NUMSE2,IBUGA3,IERROR)
17897      CALL SORT(XIDTE2,NUMSE2,XIDTE2)
17898C
17899      IF(NUMSE1.LT.1)THEN
17900        WRITE(ICOUT,999)
17901        CALL DPWRST('XXX','BUG ')
17902        WRITE(ICOUT,2201)
17903 2201   FORMAT('***** ERROR IN CHI-SQUARE INDEPENDENCE TEST--')
17904        CALL DPWRST('XXX','BUG ')
17905        WRITE(ICOUT,2202)
17906 2202   FORMAT('      NUMBER OF SETS    NUMSE1 = 0 ')
17907        CALL DPWRST('XXX','BUG ')
17908        IERROR='YES'
17909        GOTO9000
17910      ENDIF
17911C
17912      IF(NUMSE2.LT.1)THEN
17913        WRITE(ICOUT,999)
17914        CALL DPWRST('XXX','BUG ')
17915        WRITE(ICOUT,2201)
17916        CALL DPWRST('XXX','BUG ')
17917        WRITE(ICOUT,2204)
17918 2204   FORMAT('      NUMBER OF SETS    NUMSE2 = 0 ')
17919        CALL DPWRST('XXX','BUG ')
17920        IERROR='YES'
17921        GOTO9000
17922      ENDIF
17923C
17924      AN1=N1
17925      AN2=N2
17926      ANUMS1=NUMSE1
17927      ANUMS2=NUMSE2
17928C
17929C               ***********************************************
17930C               **  STEP 2.3--                               **
17931C               **  COMPUTE THE CHI-SQUARE STATISTIC         **
17932C               ***********************************************
17933C
17934      ISTEPN='23'
17935      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CHI2')
17936     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17937C
17938      IWRITE='OFF'
17939C
17940C     COMPUTE COUNTS FOR EACH CELL
17941C
17942      J=0
17943      DO2310ISET1=1,NUMSE1
17944        DO2320ISET2=1,NUMSE2
17945C
17946          K=0
17947          DO2330I=1,N1
17948            IF(XIDTEM(ISET1).EQ.Y1(I).AND.XIDTE2(ISET2).EQ.Y2(I))THEN
17949C
17950              K=K+1
17951            ENDIF
17952 2330     CONTINUE
17953          NTEMP=K
17954          J=J+1
17955          TEMP1(J)=REAL(K)
17956          TEMP2(J)=XIDTEM(ISET1)
17957          TEMP3(J)=XIDTE2(ISET2)
17958C
17959 2320   CONTINUE
17960 2310 CONTINUE
17961      NTEMP2=J
17962C
17963C     COMPUTE ROW AND COLUMN TOTALS AND GRAND TOTAL.
17964C
17965      J=0
17966      GTOTAL=0.0D0
17967C
17968      DO2340ISET1=1,NUMSE1
17969        ROWTOT(ISET1)=0.0D0
17970        DO2350ISET2=1,NUMSE2
17971          J=J+1
17972          ROWTOT(ISET1)=ROWTOT(ISET1) + DBLE(TEMP1(J))
17973          GTOTAL=GTOTAL + DBLE(TEMP1(J))
17974 2350   CONTINUE
17975C
17976        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CHI2')THEN
17977          WRITE(ICOUT,2352)ISET1,ROWTOT(ISET1)
17978 2352     FORMAT('ISET1,ROWTOT(ISET1)=',I5,1X,G15.7)
17979          CALL DPWRST('XXX','BUG ')
17980        ENDIF
17981 2340 CONTINUE
17982C
17983      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CHI2')THEN
17984        WRITE(ICOUT,2355)GTOTAL
17985 2355   FORMAT('GTOTAL=',G15.7)
17986        CALL DPWRST('XXX','BUG ')
17987      ENDIF
17988C
17989      DO2360ISET2=1,NUMSE2
17990        COLTOT(ISET2)=0.0D0
17991        VALTMP=XIDTE2(ISET2)
17992        DO2370J=1,NTEMP2
17993          IF(TEMP3(J).EQ.XIDTE2(ISET2))THEN
17994            COLTOT(ISET2)=COLTOT(ISET2) + DBLE(TEMP1(J))
17995          ENDIF
17996 2370   CONTINUE
17997C
17998        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CHI2')THEN
17999          WRITE(ICOUT,2372)ISET2,COLTOT(ISET2)
18000 2372     FORMAT('ISET2,COLTOT(ISET2)=',I5,1X,G15.7)
18001          CALL DPWRST('XXX','BUG ')
18002        ENDIF
18003C
18004 2360 CONTINUE
18005C
18006C     NOW COMPUTE THE CHI-SQUARE TEST STATISTIC
18007C
18008      CHISQ1=0.0D0
18009      CHISQ2=0.0D0
18010      J=0
18011C
18012      IFORMT='(2I8,4E15.7)'
18013      IF(IAUXDP.NE.7)THEN
18014        IFORMT=' '
18015        IF(IAUXDP.LE.9)THEN
18016          IFORMT='(2I8,4Exx.x)'
18017          ITOT=IAUXDP+8
18018          WRITE(IFORMT(8:9),'(I2)')ITOT
18019          WRITE(IFORMT(11:11),'(I1)')IAUXDP
18020        ELSE
18021          IFORMT='(2I8,4Exx.xx)'
18022          ITOT=IAUXDP+8
18023          WRITE(IFORMT(8:9),'(I2)')ITOT
18024          WRITE(IFORMT(11:12),'(I2)')IAUXDP
18025        ENDIF
18026      ENDIF
18027C
18028      DO2380ISET1=1,NUMSE1
18029        DO2390ISET2=1,NUMSE2
18030          J=J+1
18031          EXP=ROWTOT(ISET1)*COLTOT(ISET2)/GTOTAL
18032          VALTMP=(DBLE(TEMP1(J)) - EXP)**2/EXP
18033          CHISQ1=CHISQ1 + VALTMP
18034          VALTMP=DABS(DBLE(TEMP1(J)) - EXP)
18035          VALTMP=(VALTMP - 0.5D0)**2/EXP
18036          CHISQ2=CHISQ2 + VALTMP
18037          WRITE(IOUNI1,IFORMT)ISET1,ISET2,ROWTOT(ISET1),COLTOT(ISET2),
18038     1                        EXP,TEMP1(J)
18039C2385     FORMAT(I8,I8,E15.7,E15.7,E15.7,E15.7)
18040 2390   CONTINUE
18041 2380 CONTINUE
18042      NROW=NUMSE1
18043      NCOL=NUMSE2
18044C
18045      GOTO4000
18046C
18047 3000 CONTINUE
18048C
18049C               ********************************************
18050C               **  STEP 31--                             **
18051C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
18052C               **  ALL TABLE ENTRIES SHOULD BE           **
18053C               **  NON-NEGATIVE INTEGERS.  NEGATIVE      **
18054C               **  VALUES WILL BE FLAGGED AS ERRORS      **
18055C               **  WHILE NON-INTEGER VALUES WILL BE      **
18056C               **  ROUNDED TO NEAREST INTEGER.           **
18057C               **  SINCE WE ARE SCANNING TABLE, COMPUTE  **
18058C               **  ROW AND COLUMN TOTALS.                **
18059C               ********************************************
18060C
18061      ISTEPN='31'
18062      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CHI2')
18063     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18064C
18065      IERROR='NO'
18066      NUMERR=0
18067      MAXERR=10
18068C
18069      DO3001I=1,NROW
18070        ROWTOT(I)=0.0D0
18071 3001 CONTINUE
18072      GTOTAL=0.0D0
18073C
18074      DO3010J=1,NCOL
18075        COLTOT(J)=0.0D0
18076        DO3020I=1,NROW
18077          IF(XMAT(I,J).LT.0.0)THEN
18078            NUMERR=NUMERR+1
18079            IF(NUMERR.GT.MAXERR)GOTO9000
18080            IERROR='YES'
18081            WRITE(ICOUT,999)
18082            CALL DPWRST('XXX','WRIT')
18083            WRITE(ICOUT,1201)
18084            CALL DPWRST('XXX','WRIT')
18085            WRITE(ICOUT,3021)I,J
18086 3021       FORMAT('      ROW ',I8,' AND COLUMN ',I8,
18087     1             ' OF THE INPUT TABLE')
18088            CALL DPWRST('XXX','WRIT')
18089            WRITE(ICOUT,3023)XMAT(I,J)
18090 3023       FORMAT('      IS NEGATIVE.  THE VALIE IS ',G15.7)
18091            CALL DPWRST('XXX','WRIT')
18092          ELSE
18093            ITEMP=INT(XMAT(I,J)+0.5)
18094            XMAT(I,J)=REAL(ITEMP)
18095            COLTOT(J)=COLTOT(J) + DBLE(XMAT(I,J))
18096            ROWTOT(I)=ROWTOT(I) + DBLE(XMAT(I,J))
18097            GTOTAL=GTOTAL + DBLE(XMAT(I,J))
18098          ENDIF
18099 3020   CONTINUE
18100 3010 CONTINUE
18101C
18102      IF(IERROR.EQ.'YES')GOTO9000
18103C
18104C               ********************************************
18105C               **  STEP 32--                             **
18106C               **  COMPUTE THE CHI-SQUARE TEST STATISTIC **
18107C               ********************************************
18108C
18109      ISTEPN='32'
18110      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CHI2')
18111     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18112C
18113      CHISQ1=0.0D0
18114      CHISQ2=0.0D0
18115      ICNT=0
18116C
18117      IFORMT='(2I8,4E15.7)'
18118      IF(IAUXDP.NE.7)THEN
18119        IFORMT=' '
18120        IF(IAUXDP.LE.9)THEN
18121          IFORMT='(2I8,4Exx.x)'
18122          ITOT=IAUXDP+8
18123          WRITE(IFORMT(8:9),'(I2)')ITOT
18124          WRITE(IFORMT(11:11),'(I1)')IAUXDP
18125        ELSE
18126          IFORMT='(2I8,4Exx.xx)'
18127          ITOT=IAUXDP+8
18128          WRITE(IFORMT(8:9),'(I2)')ITOT
18129          WRITE(IFORMT(11:12),'(I2)')IAUXDP
18130        ENDIF
18131      ENDIF
18132C
18133      DO3110J=1,NCOL
18134        DO3120I=1,NROW
18135          ICNT=ICNT+1
18136          EXP=ROWTOT(I)*COLTOT(J)/GTOTAL
18137          VALTMP=(DBLE(XMAT(I,J)) - EXP)**2/EXP
18138          CHISQ1=CHISQ1 + VALTMP
18139          VALTMP=DABS(DBLE(XMAT(I,J)) - EXP)
18140          VALTMP=(VALTMP - 0.5D0)**2/EXP
18141          CHISQ2=CHISQ2 + VALTMP
18142          WRITE(IOUNI1,IFORMT)I,J,ROWTOT(I),COLTOT(J),EXP,XMAT(I,J)
18143C3115     FORMAT(2I8,4E15.7)
18144 3120   CONTINUE
18145 3110 CONTINUE
18146C
18147      AN1=REAL(GTOTAL)
18148      AN2=REAL(GTOTAL)
18149C
18150      GOTO4000
18151C
18152C               ********************************************
18153C               **  STEP 41--                             **
18154C               **  FOR ALL INPUT METHODS (SCALAR,        **
18155C               **  TWO VARIABLES, TABLE), COMPUTE THE    **
18156C               **  CRITIVAL VALUES AND PRINT THE RESULTS.**
18157C               ********************************************
18158C
18159 4000 CONTINUE
18160C
18161      ISTEPN='41'
18162      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CHI2')
18163     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18164C
18165      IOP='CLOS'
18166      CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
18167     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
18168     1            IBUGA3,ISUBRO,IERROR)
18169      IF(IERROR.EQ.'YES')GOTO9000
18170C
18171      STATVA=CHISQ1
18172      STATV2=CHISQ2
18173C
18174      IDF=(NROW-1)*(NCOL-1)
18175      CALL CHSCDF(STATVA,IDF,CDF)
18176      CALL CHSCDF(STATV2,IDF,CDF2)
18177C
18178      IWRITE='OFF'
18179C
18180      ICONC1='REJECT'
18181      ICONC2='REJECT'
18182      ICONC3='REJECT'
18183      ICONC4='REJECT'
18184      ICONC5='REJECT'
18185      ICONC6='REJECT'
18186      KCONC1='REJECT'
18187      KCONC2='REJECT'
18188      KCONC3='REJECT'
18189      KCONC4='REJECT'
18190      KCONC5='REJECT'
18191      KCONC6='REJECT'
18192C
18193      ALPHA=0.50
18194      CALL CHSPPF(ALPHA,IDF,CV1)
18195      ALPHA=0.80
18196      CALL CHSPPF(ALPHA,IDF,CV2)
18197      ALPHA=0.90
18198      CALL CHSPPF(ALPHA,IDF,CV3)
18199      ALPHA=0.95
18200      CALL CHSPPF(ALPHA,IDF,CV4)
18201      ALPHA=0.975
18202      CALL CHSPPF(ALPHA,IDF,CV5)
18203      ALPHA=0.99
18204      CALL CHSPPF(ALPHA,IDF,CV6)
18205C
18206      IF(0.000.LE.CDF.AND.CDF.LE.0.50)ICONC1='ACCEPT'
18207      IF(0.000.LE.CDF.AND.CDF.LE.0.80)ICONC2='ACCEPT'
18208      IF(0.000.LE.CDF.AND.CDF.LE.0.90)ICONC3='ACCEPT'
18209      IF(0.000.LE.CDF.AND.CDF.LE.0.95)ICONC4='ACCEPT'
18210      IF(0.000.LE.CDF.AND.CDF.LE.0.975)ICONC5='ACCEPT'
18211      IF(0.000.LE.CDF.AND.CDF.LE.0.99)ICONC6='ACCEPT'
18212C
18213      IF(0.000.LE.CDF2.AND.CDF2.LE.0.50)KCONC1='ACCEPT'
18214      IF(0.000.LE.CDF2.AND.CDF2.LE.0.80)KCONC2='ACCEPT'
18215      IF(0.000.LE.CDF2.AND.CDF2.LE.0.90)KCONC3='ACCEPT'
18216      IF(0.000.LE.CDF2.AND.CDF2.LE.0.95)KCONC4='ACCEPT'
18217      IF(0.000.LE.CDF2.AND.CDF2.LE.0.975)KCONC5='ACCEPT'
18218      IF(0.000.LE.CDF2.AND.CDF2.LE.0.99)KCONC6='ACCEPT'
18219C
18220C               ******************************
18221C               **   STEP 42--              **
18222C               **   WRITE OUT EVERYTHING   **
18223C               **   FOR CHI-SQUARE   TEST  **
18224C               ******************************
18225C
18226      ISTEPN='42'
18227      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CHI2')
18228     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18229C
18230C     PRINT SUMMARY STATISTICS TABLE
18231C
18232      IF(IPRINT.EQ.'OFF')GOTO9000
18233C
18234      NUMDIG=7
18235      IF(IFORSW.EQ.'1')NUMDIG=1
18236      IF(IFORSW.EQ.'2')NUMDIG=2
18237      IF(IFORSW.EQ.'3')NUMDIG=3
18238      IF(IFORSW.EQ.'4')NUMDIG=4
18239      IF(IFORSW.EQ.'5')NUMDIG=5
18240      IF(IFORSW.EQ.'6')NUMDIG=6
18241      IF(IFORSW.EQ.'7')NUMDIG=7
18242      IF(IFORSW.EQ.'8')NUMDIG=8
18243      IF(IFORSW.EQ.'9')NUMDIG=9
18244      IF(IFORSW.EQ.'0')NUMDIG=0
18245      IF(IFORSW.EQ.'E')NUMDIG=-2
18246      IF(IFORSW.EQ.'-2')NUMDIG=-2
18247      IF(IFORSW.EQ.'-3')NUMDIG=-3
18248      IF(IFORSW.EQ.'-4')NUMDIG=-4
18249      IF(IFORSW.EQ.'-5')NUMDIG=-5
18250      IF(IFORSW.EQ.'-6')NUMDIG=-6
18251      IF(IFORSW.EQ.'-7')NUMDIG=-7
18252      IF(IFORSW.EQ.'-8')NUMDIG=-8
18253      IF(IFORSW.EQ.'-9')NUMDIG=-9
18254C
18255      ITITLE='Chi-Square Test for Independence (RxC Table)'
18256      NCTITL=44
18257      ITITLZ=' '
18258      NCTITZ=0
18259C
18260      ICNT=0
18261      ICNT=ICNT+1
18262      ITEXT(ICNT)=' '
18263      NCTEXT(ICNT)=0
18264      AVALUE(ICNT)=0.0
18265      IDIGIT(ICNT)=-1
18266      ICNT=ICNT+1
18267      ITEXT(ICNT)='H0: The Two Variables Are Independent'
18268      NCTEXT(ICNT)=38
18269      AVALUE(ICNT)=0.0
18270      IDIGIT(ICNT)=-1
18271      ICNT=ICNT+1
18272      ITEXT(ICNT)='Ha: The Two Variables Are Not Independent'
18273      NCTEXT(ICNT)=42
18274      AVALUE(ICNT)=0.0
18275      IDIGIT(ICNT)=-1
18276      ICNT=ICNT+1
18277      ITEXT(ICNT)=' '
18278      NCTEXT(ICNT)=0
18279      AVALUE(ICNT)=0.0
18280      IDIGIT(ICNT)=-1
18281C
18282      ICNT=ICNT+1
18283      ITEXT(ICNT)='Sample 1:'
18284      NCTEXT(ICNT)=9
18285      AVALUE(ICNT)=0.0
18286      IDIGIT(ICNT)=-1
18287      ICNT=ICNT+1
18288      ITEXT(ICNT)='Number of Observations:'
18289      NCTEXT(ICNT)=23
18290      AVALUE(ICNT)=AN1
18291      IDIGIT(ICNT)=0
18292      ICNT=ICNT+1
18293      ITEXT(ICNT)='Number of Levels (Rows):'
18294      NCTEXT(ICNT)=24
18295      AVALUE(ICNT)=REAL(NROW)
18296      IDIGIT(ICNT)=0
18297      ICNT=ICNT+1
18298      ITEXT(ICNT)=' '
18299      NCTEXT(ICNT)=0
18300      AVALUE(ICNT)=0.0
18301      IDIGIT(ICNT)=-1
18302C
18303      ICNT=ICNT+1
18304      ITEXT(ICNT)='Sample 2:'
18305      NCTEXT(ICNT)=9
18306      AVALUE(ICNT)=0.0
18307      IDIGIT(ICNT)=-1
18308      ICNT=ICNT+1
18309      ITEXT(ICNT)='Number of Observations:'
18310      NCTEXT(ICNT)=23
18311      AVALUE(ICNT)=AN2
18312      IDIGIT(ICNT)=0
18313      ICNT=ICNT+1
18314      ITEXT(ICNT)='Number of Levels (Columns):'
18315      NCTEXT(ICNT)=27
18316      AVALUE(ICNT)=REAL(NCOL)
18317      IDIGIT(ICNT)=0
18318      ICNT=ICNT+1
18319      ITEXT(ICNT)=' '
18320      NCTEXT(ICNT)=0
18321      AVALUE(ICNT)=0.0
18322      IDIGIT(ICNT)=-1
18323C
18324      ICNT=ICNT+1
18325      ITEXT(ICNT)='Without Yates Continuity Correction:'
18326      NCTEXT(ICNT)=36
18327      AVALUE(ICNT)=0.0
18328      IDIGIT(ICNT)=-1
18329      ICNT=ICNT+1
18330      ITEXT(ICNT)='Chi-Square Test Statistic:'
18331      NCTEXT(ICNT)=26
18332      AVALUE(ICNT)=STATVA
18333      IDIGIT(ICNT)=NUMDIG
18334      ICNT=ICNT+1
18335      ITEXT(ICNT)='Degrees of Freedom:'
18336      NCTEXT(ICNT)=19
18337      AVALUE(ICNT)=REAL(IDF)
18338      IDIGIT(ICNT)=0
18339      ICNT=ICNT+1
18340      ITEXT(ICNT)='CDF Value of Test Statistic:'
18341      NCTEXT(ICNT)=28
18342      AVALUE(ICNT)=CDF
18343      IDIGIT(ICNT)=NUMDIG
18344      ICNT=ICNT+1
18345      ITEXT(ICNT)=' '
18346      NCTEXT(ICNT)=0
18347      AVALUE(ICNT)=0.0
18348      IDIGIT(ICNT)=-1
18349C
18350      ICNT=ICNT+1
18351      ITEXT(ICNT)='With Yates Continuity Correction:'
18352      NCTEXT(ICNT)=33
18353      AVALUE(ICNT)=0.0
18354      IDIGIT(ICNT)=-1
18355      ICNT=ICNT+1
18356      ITEXT(ICNT)='Chi-Square Test Statistic:'
18357      NCTEXT(ICNT)=26
18358      AVALUE(ICNT)=STATV2
18359      IDIGIT(ICNT)=NUMDIG
18360      ICNT=ICNT+1
18361      ITEXT(ICNT)='Degrees of Freedom:'
18362      NCTEXT(ICNT)=19
18363      AVALUE(ICNT)=REAL(IDF)
18364      IDIGIT(ICNT)=0
18365      ICNT=ICNT+1
18366      ITEXT(ICNT)='CDF Value of Test Statistic:'
18367      NCTEXT(ICNT)=28
18368      AVALUE(ICNT)=CDF2
18369      IDIGIT(ICNT)=NUMDIG
18370      ICNT=ICNT+1
18371      ITEXT(ICNT)=' '
18372      NCTEXT(ICNT)=0
18373      AVALUE(ICNT)=0.0
18374      IDIGIT(ICNT)=-1
18375C
18376      NUMROW=ICNT
18377      DO7310I=1,NUMROW
18378        NTOT(I)=15
18379 7310 CONTINUE
18380C
18381      IFRST=.TRUE.
18382      ILAST=.TRUE.
18383      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,
18384     1            NCTEXT,AVALUE,IDIGIT,
18385     1            NTOT,NUMROW,
18386     1            ICAPSW,ICAPTY,ILAST,IFRST,
18387     1            ISUBRO,IBUGA3,IERROR)
18388C
18389      ITITLE(1:25)='Without Yates Correction:'
18390      NCTITL=25
18391      ITITL9=' '
18392      NCTIT9=0
18393C
18394      ITITL2(1,1)=' '
18395      NCTIT2(1,1)=0
18396      ITITL2(2,1)='Null'
18397      NCTIT2(2,1)=4
18398      ITITL2(3,1)='Hypothesis'
18399      NCTIT2(3,1)=10
18400      ITITL2(1,2)=' '
18401      NCTIT2(1,2)=0
18402      ITITL2(2,2)='Confidence'
18403      NCTIT2(2,2)=10
18404      ITITL2(3,2)='Level'
18405      NCTIT2(3,2)=5
18406      ITITL2(1,3)=' '
18407      NCTIT2(1,3)=0
18408      ITITL2(2,3)='Critical'
18409      NCTIT2(2,3)=8
18410      ITITL2(3,3)='Value'
18411      NCTIT2(3,3)=5
18412      ITITL2(1,4)='Null Hypothesis'
18413      NCTIT2(1,4)=15
18414      ITITL2(2,4)='Acceptance'
18415      NCTIT2(2,4)=10
18416      ITITL2(3,4)='Interval'
18417      NCTIT2(3,4)=8
18418      ITITL2(1,5)='Null'
18419      NCTIT2(1,5)=4
18420      ITITL2(2,5)='Hypothesis'
18421      NCTIT2(2,5)=10
18422      ITITL2(3,5)='Conclusion'
18423      NCTIT2(3,5)=10
18424C
18425      NMAX=0
18426      NUMCOL=5
18427      DO7410I=1,NUMCOL
18428        VALIGN(I)='b'
18429        ALIGN(I)='r'
18430        NTOT(I)=15
18431        NMAX=NMAX+NTOT(I)
18432        IF(I.EQ.3)THEN
18433          ITYPCO(I)='NUME'
18434        ELSE
18435          ITYPCO(I)='ALPH'
18436        ENDIF
18437        IF(I.EQ.2)THEN
18438          IDIGIT(I)=1
18439        ELSEIF(I.EQ.3)THEN
18440          IDIGIT(I)=2
18441        ELSE
18442          IDIGIT(I)=NUMDIG
18443        ENDIF
18444        IWHTML(1)=150
18445        IWHTML(2)=125
18446        IWHTML(3)=125
18447        IWHTML(4)=150
18448        IWHTML(5)=150
18449        IINC=1600
18450        IINC2=1400
18451        IINC3=2200
18452        IWRTF(1)=IINC
18453        IWRTF(2)=IWRTF(1)+IINC
18454        IWRTF(3)=IWRTF(2)+IINC2
18455        IWRTF(4)=IWRTF(3)+IINC3
18456        IWRTF(5)=IWRTF(4)+IINC2
18457C
18458        DO7489J=1,NUMALP
18459          NCVALU(J,1)=0
18460          NCVALU(J,2)=0
18461          NCVALU(J,3)=0
18462          NCVALU(J,4)=0
18463          NCVALU(J,5)=0
18464          IVALUE(J,1)=' '
18465          IVALUE(J,2)=' '
18466          IVALUE(J,3)=' '
18467          IVALUE(J,4)=' '
18468          IVALUE(J,5)=' '
18469          IF(J.EQ.1)THEN
18470            IVALUE(J,2)='50.0%'
18471            NCVALU(J,2)=5
18472            AMAT(J,3)=CV1
18473            IVALUE(J,5)(1:6)=ICONC1(1:6)
18474            NCVALU(J,5)=6
18475            IVALUE(J,4)='(0,0.500)'
18476            NCVALU(J,4)=9
18477          ELSEIF(J.EQ.2)THEN
18478            IVALUE(J,2)='80.0%'
18479            NCVALU(J,2)=5
18480            AMAT(J,3)=CV2
18481            IVALUE(J,5)(1:6)=ICONC2(1:6)
18482            NCVALU(J,5)=6
18483            IVALUE(J,4)='(0,0.800)'
18484            NCVALU(J,4)=9
18485          ELSEIF(J.EQ.3)THEN
18486            IVALUE(J,2)='90.0%'
18487            NCVALU(J,2)=5
18488            AMAT(J,3)=CV3
18489            IVALUE(J,5)(1:6)=ICONC3(1:6)
18490            NCVALU(J,5)=6
18491            IVALUE(J,4)='(0,0.900)'
18492            NCVALU(J,4)=9
18493          ELSEIF(J.EQ.4)THEN
18494            IVALUE(J,2)='95.0%'
18495            NCVALU(J,2)=5
18496            AMAT(J,3)=CV4
18497            IVALUE(J,5)(1:6)=ICONC4(1:6)
18498            NCVALU(J,5)=6
18499            IVALUE(J,4)='(0,0.950)'
18500            NCVALU(J,4)=9
18501          ELSEIF(J.EQ.5)THEN
18502            IVALUE(J,2)='97.5%'
18503            NCVALU(J,2)=5
18504            AMAT(J,3)=CV5
18505            IVALUE(J,5)(1:6)=ICONC5(1:6)
18506            NCVALU(J,5)=6
18507            IVALUE(J,4)='(0,0.975)'
18508            NCVALU(J,4)=9
18509          ELSEIF(J.EQ.6)THEN
18510            IVALUE(J,2)='99.0%'
18511            NCVALU(J,2)=5
18512            AMAT(J,3)=CV6
18513            IVALUE(J,5)(1:6)=ICONC6(1:6)
18514            NCVALU(J,5)=6
18515            IVALUE(J,4)='(0,0.990)'
18516            NCVALU(J,4)=9
18517          ENDIF
18518          AMAT(J,1)=0.0
18519          AMAT(J,2)=0.0
18520          AMAT(J,4)=0.0
18521          AMAT(J,5)=0.0
18522          IVALUE(J,1)='Independent'
18523          NCVALU(J,1)=11
18524 7489   CONTINUE
18525C
18526 7410 CONTINUE
18527C
18528      ICNT=NUMALP
18529      NUMLIN=3
18530      NUMCOL=5
18531      IFRST=.TRUE.
18532      ILAST=.TRUE.
18533      IFLAGS=.TRUE.
18534      IFLAGE=.TRUE.
18535      CALL DPDTA5(ITITLE,NCTITL,
18536     1            ITITL9,NCTIT9,ITITL2,NCTIT2,
18537     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
18538     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
18539     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
18540     1            ICAPSW,ICAPTY,IFRST,ILAST,
18541     1            IFLAGS,IFLAGE,
18542     1            ISUBRO,IBUGA3,IERROR)
18543C
18544      ITITLE(1:30)='With Yates Bias Correction:'
18545      NCTITL=30
18546C
18547      NUMCOL=5
18548      DO7510I=1,NUMCOL
18549C
18550        DO7589J=1,NUMALP
18551          IF(J.EQ.1)THEN
18552            IVALUE(J,5)(1:6)=KCONC1(1:6)
18553            NCVALU(J,5)=6
18554          ELSEIF(J.EQ.2)THEN
18555            IVALUE(J,5)(1:6)=KCONC2(1:6)
18556            NCVALU(J,5)=6
18557          ELSEIF(J.EQ.3)THEN
18558            IVALUE(J,5)(1:6)=KCONC3(1:6)
18559            NCVALU(J,5)=6
18560          ELSEIF(J.EQ.4)THEN
18561            IVALUE(J,5)(1:6)=KCONC4(1:6)
18562            NCVALU(J,5)=6
18563          ELSEIF(J.EQ.5)THEN
18564            IVALUE(J,5)(1:6)=KCONC5(1:6)
18565            NCVALU(J,5)=6
18566          ELSEIF(J.EQ.6)THEN
18567            IVALUE(J,5)(1:6)=KCONC6(1:6)
18568            NCVALU(J,5)=6
18569          ENDIF
18570 7589   CONTINUE
18571C
18572 7510 CONTINUE
18573C
18574      ICNT=NUMALP
18575      NUMLIN=3
18576      NUMCOL=5
18577      IFRST=.TRUE.
18578      ILAST=.TRUE.
18579      IFLAGS=.TRUE.
18580      IFLAGE=.TRUE.
18581      CALL DPDTA5(ITITLE,NCTITL,
18582     1            ITITL9,NCTIT9,ITITL2,NCTIT2,
18583     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
18584     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
18585     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
18586     1            ICAPSW,ICAPTY,IFRST,ILAST,
18587     1            IFLAGS,IFLAGE,
18588     1            ISUBRO,IBUGA3,IERROR)
18589C
18590C               *****************
18591C               **  STEP 90--  **
18592C               **  EXIT       **
18593C               *****************
18594C
18595 9000 CONTINUE
18596      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CHI2')THEN
18597        WRITE(ICOUT,999)
18598        CALL DPWRST('XXX','WRIT')
18599        WRITE(ICOUT,9011)
18600 9011   FORMAT('***** AT THE END       OF DPCHI2--')
18601        CALL DPWRST('XXX','WRIT')
18602        WRITE(ICOUT,9013)AN11,AN21,AN12,AN22
18603 9013   FORMAT('AN11,AN21,AN12,AN22=',4G15.7)
18604        CALL DPWRST('XXX','WRIT')
18605        WRITE(ICOUT,9015)AN1,AN2
18606 9015   FORMAT('AN1,AN2=',2G15.7)
18607        CALL DPWRST('XXX','WRIT')
18608        WRITE(ICOUT,9017)N11,N21,N12,N22
18609 9017   FORMAT('N11,N21,N12,N22=',4I8)
18610        CALL DPWRST('XXX','WRIT')
18611      ENDIF
18612C
18613      RETURN
18614      END
18615      SUBROUTINE DPCHWI(IHARG,IARGT,ARG,NUMARG,
18616     1                  PDEFWI,
18617     1                  MAXCHA,
18618     1                  PCHAWI,PCHAHG,
18619     1                  IFOUND,IERROR)
18620C
18621C     PURPOSE--DEFINE PLOT CHARACTER WIDTHS FOR USE IN MULTI-TRACE PLOTS.
18622C              THE WIDTH FOR THE CHARACTER FOR THE I-TH TRACE
18623C              WILL BE PLACED
18624C              IN THE I-TH ELEMENT OF THE FLOATING POINT
18625C              VECTOR PCHAWI(.).
18626C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
18627C                     --IARGT  (A  HOLLERITH VECTOR)
18628C                     --ARG    (A  HOLLERITH VECTOR)
18629C                     --NUMARG
18630C                     --PDEFWI
18631C                     --MAXCHA
18632C     OUTPUT ARGUMENTS--PCHAWI  (A  FLOATING POINT VECTOR
18633C                       WHOSE I-TH ELEMENT IS THE WIDTH (= WIDTHT)
18634C                       FOR THE CHARACTER
18635C                       ASSIGNED TO THE I-TH    TRACE    IN
18636C                       A MULTI-TRACE PLOT.
18637C                     --PCHAWI = CHARACTER WIDTH
18638C                     --PCHAHG = HORIZONTAL GAP BETWEEN CHARACTERS
18639C                     --IFOUND ('YES' OR 'NO' )
18640C                     --IERROR ('YES' OR 'NO' )
18641C     WRITTEN BY--JAMES J. FILLIBEN
18642C                 STATISTICAL ENGINEERING DIVISION
18643C                 INFORMATION TECHNOLOGY LABORATORY
18644C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
18645C                 GAITHERSBURG, MD 20899-8980
18646C                 PHONE--301-975-2899
18647C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
18648C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
18649C     LANGUAGE--ANSI FORTRAN (1977)
18650C     VERSION NUMBER--82/7
18651C     ORIGINAL VERSION--DECEMBER  1977.
18652C     UPDATED         --SEPTEMBER 1980.
18653C     UPDATED         --MARCH     1982.
18654C     UPDATED         --MAY       1982.
18655C
18656C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
18657C
18658      CHARACTER*4 IHARG
18659      CHARACTER*4 IARGT
18660      CHARACTER*4 IFOUND
18661      CHARACTER*4 IERROR
18662C
18663C---------------------------------------------------------------------
18664C
18665      DIMENSION IHARG(*)
18666      DIMENSION IARGT(*)
18667      DIMENSION ARG(*)
18668C
18669      DIMENSION PCHAWI(*)
18670      DIMENSION PCHAHG(*)
18671C
18672C---------------------------------------------------------------------
18673C
18674      INCLUDE 'DPCOP2.INC'
18675C
18676C-----START POINT-----------------------------------------------------
18677C
18678      IFOUND='NO'
18679      IERROR='NO'
18680C
18681      IF(NUMARG.GE.3.AND.IHARG(1).EQ.'WIDTH'.AND.
18682     1IHARG(2).EQ.'BOX'.AND.IHARG(3).EQ.'PLOT')GOTO2110
18683      IF(NUMARG.GE.3.AND.IHARG(1).EQ.'WIDT'.AND.
18684     1IHARG(2).EQ.'BOX'.AND.IHARG(3).EQ.'PLOT')GOTO2110
18685      IF(NUMARG.GE.4.AND.IHARG(2).EQ.'WIDTH'.AND.
18686     1IHARG(3).EQ.'BOX'.AND.IHARG(4).EQ.'PLOT')GOTO2110
18687      IF(NUMARG.GE.4.AND.IHARG(2).EQ.'WIDT'.AND.
18688     1IHARG(3).EQ.'BOX'.AND.IHARG(4).EQ.'PLOT')GOTO2110
18689C
18690      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'WIDTH')GOTO1160
18691      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'WIDT')GOTO1160
18692      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'WIDTH')GOTO1105
18693      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'WIDT')GOTO1105
18694      GOTO2199
18695C
18696 1105 CONTINUE
18697      IF(IHARG(NUMARG).EQ.'ON')GOTO1110
18698      IF(IHARG(NUMARG).EQ.'OFF')GOTO1110
18699      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1110
18700      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1110
18701C
18702      IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'ALL')GOTO1160
18703      IF(NUMARG.EQ.2)GOTO1120
18704      IF(NUMARG.GE.3.AND.IHARG(2).EQ.'ALL')GOTO1130
18705      IF(NUMARG.GE.3.AND.IHARG(3).EQ.'ALL')GOTO1140
18706C
18707      GOTO1150
18708C
18709 1110 CONTINUE
18710      DO1115I=1,MAXCHA
18711      PCHAWI(I)=PDEFWI
18712 1115 CONTINUE
18713C
18714      IF(IFEEDB.EQ.'OFF')GOTO1119
18715      WRITE(ICOUT,999)
18716  999 FORMAT(1X)
18717      CALL DPWRST('XXX','BUG ')
18718      I=1
18719      WRITE(ICOUT,1116)PCHAWI(I)
18720 1116 FORMAT('ALL CHARACTER WIDTHS HAVE JUST BEEN SET TO ',
18721     1E15.7)
18722      CALL DPWRST('XXX','BUG ')
18723 1119 CONTINUE
18724      GOTO2190
18725C
18726 1120 CONTINUE
18727      I=1
18728      IF(IARGT(2).NE.'NUMB')GOTO1180
18729      PCHAWI(1)=ARG(2)
18730C
18731      IF(IFEEDB.EQ.'OFF')GOTO1129
18732      WRITE(ICOUT,999)
18733      CALL DPWRST('XXX','BUG ')
18734      I=1
18735      WRITE(ICOUT,1126)I,PCHAWI(I)
18736 1126 FORMAT('THE WIDTH FOR CHARACTER ',I6,' HAS JUST BEEN SET TO ',
18737     1E15.7)
18738      CALL DPWRST('XXX','BUG ')
18739 1129 CONTINUE
18740      GOTO2190
18741C
18742 1130 CONTINUE
18743      I=1
18744      IF(IARGT(3).NE.'NUMB')GOTO1180
18745      DO1135I=1,MAXCHA
18746      PCHAWI(I)=ARG(3)
18747 1135 CONTINUE
18748C
18749      IF(IFEEDB.EQ.'OFF')GOTO1139
18750      WRITE(ICOUT,999)
18751      CALL DPWRST('XXX','BUG ')
18752      I=1
18753      WRITE(ICOUT,1116)PCHAWI(I)
18754      CALL DPWRST('XXX','BUG ')
18755 1139 CONTINUE
18756      GOTO2190
18757C
18758 1140 CONTINUE
18759      I=1
18760      IF(IARGT(2).NE.'NUMB')GOTO1180
18761      DO1145I=1,MAXCHA
18762      PCHAWI(I)=ARG(2)
18763 1145 CONTINUE
18764C
18765      IF(IFEEDB.EQ.'OFF')GOTO1149
18766      WRITE(ICOUT,999)
18767      CALL DPWRST('XXX','BUG ')
18768      I=1
18769      WRITE(ICOUT,1116)PCHAWI(I)
18770      CALL DPWRST('XXX','BUG ')
18771 1149 CONTINUE
18772      GOTO2190
18773C
18774 1150 CONTINUE
18775      IMAX=NUMARG-1
18776      IF(MAXCHA.LT.IMAX)IMAX=MAXCHA
18777      DO1155I=1,IMAX
18778      IP1=I+1
18779      IF(IARGT(IP1).NE.'NUMB')GOTO1180
18780      PCHAWI(I)=ARG(IP1)
18781 1155 CONTINUE
18782C
18783      IF(IFEEDB.EQ.'OFF')GOTO1159
18784      WRITE(ICOUT,999)
18785      CALL DPWRST('XXX','BUG ')
18786      DO1156I=1,IMAX
18787      WRITE(ICOUT,1126)I,PCHAWI(I)
18788      CALL DPWRST('XXX','BUG ')
18789 1156 CONTINUE
18790 1159 CONTINUE
18791      GOTO2190
18792C
18793 1160 CONTINUE
18794      DO1165I=1,MAXCHA
18795      PCHAWI(I)=PDEFWI
18796 1165 CONTINUE
18797C
18798      IF(IFEEDB.EQ.'OFF')GOTO1169
18799      WRITE(ICOUT,999)
18800      CALL DPWRST('XXX','BUG ')
18801      I=1
18802      WRITE(ICOUT,1116)PCHAWI(I)
18803      CALL DPWRST('XXX','BUG ')
18804 1169 CONTINUE
18805      GOTO2190
18806C
18807 1180 CONTINUE
18808      IERROR='YES'
18809      WRITE(ICOUT,999)
18810      CALL DPWRST('XXX','BUG ')
18811      WRITE(ICOUT,1181)
18812 1181 FORMAT('***** ERROR IN DPCHWI--')
18813      CALL DPWRST('XXX','BUG ')
18814      WRITE(ICOUT,1182)
18815 1182 FORMAT('CHARACTER WIDTHS MUST BE NUMERIC;')
18816      CALL DPWRST('XXX','BUG ')
18817      WRITE(ICOUT,1183)
18818 1183 FORMAT('HOWEVER, THE SPECIFIED CHARACTER WIDTH')
18819      CALL DPWRST('XXX','BUG ')
18820      WRITE(ICOUT,1184)I
18821 1184 FORMAT('FOR CHARACTER ',I6,' WAS NON-NUMERIC.')
18822      CALL DPWRST('XXX','BUG ')
18823      GOTO2199
18824C
18825 2110 CONTINUE
18826      IMAX=24
18827      PCHAWI(1)=1.0
18828      PCHAWI(2)=1.0
18829      PCHAWI(3)=1.0
18830      PCHAWI(4)=1.0
18831      PCHAWI(5)=1.0
18832      PCHAWI(6)=1.0
18833      PCHAWI(7)=1.0
18834      PCHAWI(8)=1.0
18835      PCHAWI(9)=1.0
18836      PCHAWI(10)=1.0
18837      PCHAWI(11)=1.0
18838      PCHAWI(12)=1.0
18839      PCHAWI(13)=1.0
18840      PCHAWI(14)=1.0
18841      PCHAWI(15)=1.0
18842      PCHAWI(16)=1.0
18843      PCHAWI(17)=1.0
18844      PCHAWI(18)=1.0
18845      PCHAWI(19)=1.0
18846      PCHAWI(20)=1.0
18847      PCHAWI(21)=1.5
18848      PCHAWI(22)=1.0
18849      PCHAWI(23)=1.0
18850      PCHAWI(24)=1.5
18851      GOTO2170
18852C
18853 2170 CONTINUE
18854      IF(IFEEDB.EQ.'OFF')GOTO2179
18855      WRITE(ICOUT,999)
18856      CALL DPWRST('XXX','BUG ')
18857      DO2175I=1,IMAX
18858      WRITE(ICOUT,2176)I,PCHAWI(I)
18859 2176 FORMAT('THE WIDTH FOR CHARACTER ',I6,' HAS JUST BEEN SET TO ',
18860     1E15.7)
18861      CALL DPWRST('XXX','BUG ')
18862 2175 CONTINUE
18863 2179 CONTINUE
18864      GOTO2180
18865C
18866 2180 CONTINUE
18867      IFOUND='YES'
18868      GOTO2190
18869C
18870 2190 CONTINUE
18871      IFOUND='YES'
18872      DO2191I=1,MAXCHA
18873      PCHAHG(I)=PCHAWI(I)*0.25
18874 2191 CONTINUE
18875C
18876 2199 CONTINUE
18877      RETURN
18878      END
18879      SUBROUTINE DPCMAP(IHARG,NUMARG,IDCMAP,ICHMAP,IFOUND,IERROR)
18880C
18881C     PURPOSE--DEFINE PLOT CHARACTER MAPPING
18882C              (BY RANK    OR    BY EXACT)
18883C              WHICH LINKS TRACE ID AND CHARACTER
18884C              (THE CURRENT DEFAULT IS BY RANK).
18885C     EXAMPLE--IF HAVE DATA: X: 1 1 2 2 3 3
18886C                            Y: 1 2 3 4 5 6
18887C                          TAG: 1 1 3 3 5 5
18888C              AND CHARACTERS 1 2 3 4 5
18889C              AND DESIRE TO HAVE THE TRACES SHOW 1 3 AND 5
18890C              THEN CURRENTLY BY DEFAULT WOULD GET
18891C              TRACES SHOWING 1 2 3 (SINCE MAP VIA RANK)
18892C              BUT IF ENTER      CHARACTER MAP EXACT
18893C              THEN WOULD GET TRACES SHOWING 1 3 5 (AS DESIRED)
18894C     COMMAND EXAMPLE--CHARACTER MAP RANK (= DEFAULT)
18895C                      CHARACTER MAP EXACT
18896C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
18897C                     --NUMARG
18898C                     --IDCMAP
18899C     OUTPUT ARGUMENTS--ICHMAP  (A  CHARACTER VARIABLE
18900C                       WHICH DEFINES THE MAP
18901C                       (RANK OR EXAC)
18902C                     --IFOUND ('YES' OR 'NO' )
18903C                     --IERROR ('YES' OR 'NO' )
18904C     WRITTEN BY--JAMES J. FILLIBEN
18905C                 STATISTICAL ENGINEERING DIVISION
18906C                 INFORMATION TECHNOLOGY LABORATORY
18907C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
18908C                 GAITHERSBURG, MD 20899-8980
18909C                 PHONE--301-975-2855
18910C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
18911C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
18912C     LANGUAGE--ANSI FORTRAN (1977)
18913C     VERSION NUMBER--94/12
18914C     ORIGINAL VERSION--DECEMBER  1994.
18915C
18916C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
18917C
18918      CHARACTER*4 IHARG
18919      CHARACTER*4 IDCMAP
18920      CHARACTER*4 ICHMAP
18921      CHARACTER*4 IFOUND
18922      CHARACTER*4 IERROR
18923C
18924C---------------------------------------------------------------------
18925C
18926      DIMENSION IHARG(*)
18927C
18928C---------------------------------------------------------------------
18929C
18930      INCLUDE 'DPCOP2.INC'
18931C
18932C-----START POINT-----------------------------------------------------
18933C
18934      IFOUND='NO'
18935      IERROR='NO'
18936C
18937      IF(NUMARG.EQ.1)THEN
18938         ICHMAP=IDCMAP
18939         GOTO1150
18940      ENDIF
18941C
18942      IF(NUMARG.GE.2)THEN
18943         IF(IHARG(NUMARG).EQ.'ON'.OR.
18944     1   IHARG(NUMARG).EQ.'OFF'.OR.
18945     1   IHARG(NUMARG).EQ.'AUTO'.OR.
18946     1   IHARG(NUMARG).EQ.'DEFA')THEN
18947            ICHMAP=IDCMAP
18948            GOTO1150
18949         ELSE IF(IHARG(NUMARG).EQ.'EXAC'.OR.
18950     1   IHARG(NUMARG).EQ.'1TO1')THEN
18951            ICHMAP='EXAC'
18952            GOTO1150
18953         ELSE IF(IHARG(NUMARG).EQ.'?')THEN
18954            GOTO1160
18955         ELSE
18956            ICHMAP=IHARG(2)
18957            GOTO1150
18958         ENDIF
18959      ENDIF
18960C
18961 1150 CONTINUE
18962      IF(IFEEDB.EQ.'ON')THEN
18963         WRITE(ICOUT,999)
18964  999    FORMAT(1X)
18965         CALL DPWRST('XXX','BUG ')
18966         WRITE(ICOUT,1151)ICHMAP
18967 1151    FORMAT('THE CHARACTER MAPPING HAS JUST BEEN SET TO ',
18968     1   A4)
18969         CALL DPWRST('XXX','BUG ')
18970      ENDIF
18971      IFOUND='YES'
18972      GOTO9000
18973C
18974 1160 CONTINUE
18975      WRITE(ICOUT,999)
18976      CALL DPWRST('XXX','BUG ')
18977      WRITE(ICOUT,1161)
18978 1161 FORMAT('CHARACTER MAPPING HAS 2 POSSIBLE SETTINGS:')
18979      CALL DPWRST('XXX','BUG ')
18980      WRITE(ICOUT,1162)
18981 1162 FORMAT('   RANK   AND   EXACT')
18982      CALL DPWRST('XXX','BUG ')
18983      WRITE(ICOUT,1163)ICHMAP
18984 1163 FORMAT('THE CURRENT CHARACTER MAPPING IS    ',A4)
18985      CALL DPWRST('XXX','BUG ')
18986      IFOUND='YES'
18987      GOTO9000
18988C
18989 9000 CONTINUE
18990      RETURN
18991      END
18992      SUBROUTINE DPCONC(IHARG,NUMARG,
18993     1IDEFCC,
18994     1ICONCH,
18995     1IBUGS2,IFOUND,IERROR)
18996C
18997C     PURPOSE--DEFINE THE CONTINUE CHARACTOR WHICH MAY
18998C              BE USED TO CONTINUE A COMMAND TO A SECOND
18999C              LINE (NO MORE THAN 2 LINES ALLOWED)
19000C              ABOUT THE ONLY PLACE THIS IS NECCESSARY
19001C              IN DATAPLOT IS IN ENTERING TITLES, ESPECIALLY
19002C              IF MANY SHIFTS ARE INCLUDED FOR UPPER, LOWER CASE
19003C              AND SPECIAL SYMBOLS
19004C
19005C              THE CONTINUE CHARACTER CAN BE UP TO 4 CHARACTERS LONG
19006C
19007C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
19008C                     --NUMARG (AN INTEGER VARIABLE)
19009C                     --IDEFCC (A  CHARACTER VARIABLE)
19010C                     --IBUGS2 (A  CHARACTER VARIABLE)
19011C     OUTPUT ARGUMENTS--ICONCH (A CHARACTER VARIABLE)
19012C                     --IFOUND ('YES' OR 'NO' )
19013C                     --IERROR ('YES' OR 'NO' )
19014C     WRITTEN BY--ALAN HECKERT
19015C                 COMPUTER SERVICES DIVISION
19016C                 INFORMATION TECHNOLOGY LABORATORY
19017C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
19018C                 GAITHERSBURG, MD 20899-8980
19019C                 PHONE--301-975-2899
19020C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
19021C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
19022C     LANGUAGE--ANSI FORTRAN (1977)
19023C     VERSION NUMBER--82/7
19024C     ORIGINAL VERSION--NOVEMBER 1980.
19025C     UPDATED         --MAY       1982.
19026C
19027C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
19028C
19029      CHARACTER*4 IHARG
19030      CHARACTER*4 IDEFCC
19031      CHARACTER*4 ICONCH
19032      CHARACTER*4 IBUGS2
19033      CHARACTER*4 IFOUND
19034      CHARACTER*4 IERROR
19035C
19036      CHARACTER*4 IHOLD
19037C
19038C---------------------------------------------------------------------
19039C
19040      DIMENSION IHARG(*)
19041C
19042C---------------------------------------------------------------------
19043C
19044      INCLUDE 'DPCOP2.INC'
19045C
19046C-----START POINT-----------------------------------------------------
19047C
19048      IF(IBUGS2.EQ.'OFF')GOTO90
19049      WRITE(ICOUT,999)
19050  999 FORMAT(1X)
19051      CALL DPWRST('XXX','BUG ')
19052      WRITE(ICOUT,51)
19053   51 FORMAT('***** AT THE BEGINNING OF DPCONC--')
19054      CALL DPWRST('XXX','BUG ')
19055      WRITE(ICOUT,53)IDEFCC
19056   53 FORMAT('IDEFCC = ',A4)
19057      CALL DPWRST('XXX','BUG ')
19058      WRITE(ICOUT,54)NUMARG
19059   54 FORMAT('NUMARG = ',I8)
19060      CALL DPWRST('XXX','BUG ')
19061      DO55I=1,NUMARG
19062      WRITE(ICOUT,56)I,IHARG(I)
19063   56 FORMAT('I,IHARG(I) = ',I8,2X,A4)
19064      CALL DPWRST('XXX','BUG ')
19065   55 CONTINUE
19066   90 CONTINUE
19067C
19068      IFOUND='NO'
19069      IERROR='NO'
19070C
19071      IF(NUMARG.LE.0)GOTO1150
19072      GOTO1110
19073C
19074 1110 CONTINUE
19075      IF(NUMARG.LE.1)GOTO1150
19076      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
19077      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
19078      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
19079      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
19080      GOTO1160
19081C
19082 1150 CONTINUE
19083      IHOLD=IDEFCC
19084      GOTO1180
19085C
19086 1160 CONTINUE
19087      IHOLD=IHARG(NUMARG)
19088      GOTO1180
19089C
19090 1180 CONTINUE
19091      IFOUND='YES'
19092      ICONCH=IHOLD
19093C
19094      IF(IFEEDB.EQ.'OFF')GOTO1189
19095      WRITE(ICOUT,999)
19096      CALL DPWRST('XXX','BUG ')
19097      WRITE(ICOUT,1181)ICONCH
19098 1181 FORMAT('THE CONTINUE CHARACTER HAS JUST BEEN SET TO ',
19099     1A4)
19100      CALL DPWRST('XXX','BUG ')
19101 1189 CONTINUE
19102      GOTO9000
19103C
19104 9000 CONTINUE
19105      IF(IBUGS2.EQ.'OFF')GOTO9090
19106      WRITE(ICOUT,999)
19107      CALL DPWRST('XXX','BUG ')
19108      WRITE(ICOUT,9011)
19109 9011 FORMAT('***** AT THE END       OF DPCONC-')
19110      CALL DPWRST('XXX','BUG ')
19111      WRITE(ICOUT,9012)IBUGS2,IFOUND,IERROR
19112 9012 FORMAT('IBUGS2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
19113      CALL DPWRST('XXX','BUG ')
19114      WRITE(ICOUT,9013)IDEFCC,ICONCH
19115 9013 FORMAT('IDEFCC,ICONCH = ',A4,2X,A4)
19116      CALL DPWRST('XXX','BUG ')
19117 9090 CONTINUE
19118C
19119      RETURN
19120      END
19121