1      SUBROUTINE DPMMPD(YMEAN,YSD,N,
2     1                  Y2,X2,N2,
3     1                  IBUGA3,ISUBRO,IERROR)
4C
5C     PURPOSE--GIVEN N SETS OF MEANS AND STANDARD DEVIATIONS (OR
6C              ANY LOCATION AND ASSOCIATED STANDARD UNCERTAINTY),
7C              COMPUTE THE NORMAL KERNEL DENSITY MIXTURE.
8C     WRITTEN BY--ALAN HECKERT
9C                 STATISTICAL ENGINEERING DIVISION
10C                 INFORMATION TECHNOLOGY LABORATORY
11C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
12C                 GAITHERSBURG, MD 20899-8980
13C                 PHONE--301-975-2899
14C     REFERENCE--DUEWER (2008),"A COMPARISON OF LOCATION ESTIMATORS FOR
15C                INTERLABORATORY DATA CONTAMINATED WITH VALUE AND
16C                UNCERTAINTY OUTLIERS", ACCREDITED QUALITY ASSURANCE,
17C                VOL. 13, PP. 193-216.
18C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
19C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
20C     LANGUAGE--ANSI FORTRAN (1977)
21C     VERSION NUMBER--2017/02
22C     ORIGINAL VERSION--FEBRUARY  2017.
23C
24C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
25C
26      CHARACTER*4 IBUGA3
27      CHARACTER*4 ISUBRO
28      CHARACTER*4 IERROR
29C
30      CHARACTER*4 ISUBN1
31      CHARACTER*4 ISUBN2
32C
33C---------------------------------------------------------------------
34C
35      DIMENSION YMEAN(*)
36      DIMENSION YSD(*)
37      DIMENSION Y2(*)
38      DIMENSION X2(*)
39C
40      DOUBLE PRECISION DSUM1
41      DOUBLE PRECISION DVAL
42      DOUBLE PRECISION DPDF
43C
44C---------------------------------------------------------------------
45C
46      INCLUDE 'DPCOP2.INC'
47C
48C-----START POINT-----------------------------------------------------
49C
50      ISUBN1='DPPE'
51      ISUBN2='AK  '
52      IERROR='NO'
53C
54      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'MMPD')THEN
55        WRITE(ICOUT,999)
56  999   FORMAT(1X)
57        CALL DPWRST('XXX','BUG ')
58        WRITE(ICOUT,20)
59   20   FORMAT('***** AT THE BEGINNING OF DPMMPD--')
60        CALL DPWRST('XXX','BUG ')
61        WRITE(ICOUT,22)N
62   22   FORMAT('N = ',I8)
63        CALL DPWRST('XXX','BUG ')
64        DO23I=1,N
65          WRITE(ICOUT,24)I,YMEAN(I),YSD(I)
66   24     FORMAT('I,YMEAN(I),YSD(I) = ',I8,2G15.7)
67          CALL DPWRST('XXX','BUG ')
68   23   CONTINUE
69      ENDIF
70C
71C               ********************************************
72C               **  STEP 1--                              **
73C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
74C               ********************************************
75C
76      IF(N.LT.1)THEN
77        WRITE(ICOUT,999)
78        CALL DPWRST('XXX','BUG ')
79        WRITE(ICOUT,131)
80  131   FORMAT('***** ERROR IN NORMAL KERNEL DENSITY MIXTURE--')
81        CALL DPWRST('XXX','BUG ')
82        WRITE(ICOUT,132)
83  132   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 2;')
84        CALL DPWRST('XXX','BUG ')
85        WRITE(ICOUT,134)N
86  134   FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS = ',I8)
87        CALL DPWRST('XXX','BUG ')
88        WRITE(ICOUT,999)
89        CALL DPWRST('XXX','BUG ')
90        IERROR='YES'
91        GOTO9000
92      ENDIF
93C
94      DO140I=1,N
95        IF(YSD(I).LE.0.0)THEN
96          WRITE(ICOUT,999)
97          CALL DPWRST('XXX','BUG ')
98          WRITE(ICOUT,131)
99          CALL DPWRST('XXX','BUG ')
100          WRITE(ICOUT,142)I
101  142     FORMAT('      ROW ',I8,' HAS A NON-POSITIVE UNCERTAINTY.')
102          CALL DPWRST('XXX','BUG ')
103          WRITE(ICOUT,144)YSD(I)
104  144     FORMAT('      THE ENTERED UNCERTAINTY = ',G15.7)
105          CALL DPWRST('XXX','BUG ')
106          WRITE(ICOUT,999)
107          CALL DPWRST('XXX','BUG ')
108          IERROR='YES'
109          GOTO9000
110        ENDIF
111  140 CONTINUE
112C
113C               ***************************************************
114C               **  STEP 2--                                     **
115C               **  DETERMINE THE NORMAL KERNEL DENSITY MIXTURE  **
116C               ***************************************************
117C
118C     COMUTE END POINTS FOR EACH ROW (MEAN +/- 4*SD)
119C
120      ALOW=YMEAN(1) - 4.0*YSD(1)
121      AUPP=YMEAN(1) + 4.0*YSD(1)
122      DO200I=2,N
123        ALOWT=YMEAN(I) - 4.0*YSD(I)
124        IF(ALOWT.LT.ALOW)ALOW=ALOWT
125        AUPPT=YMEAN(I) + 4.0*YSD(I)
126        IF(AUPPT.GT.AUPP)AUPP=AUPPT
127  200 CONTINUE
128      NGRID=1000
129      AINC=(AUPP - ALOW)/REAL(NGRID)
130C
131      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'MMPD')THEN
132        WRITE(ICOUT,201)NGRID,ALOW,AUPP,AINC
133  201   FORMAT('NGRID,ALOW,AUPP,AINC = ',I8,3G15.7)
134        CALL DPWRST('XXX','BUG ')
135        WRITE(ICOUT,20)
136      ENDIF
137C
138C     NOW COMPUTE MIXTURE
139C
140      N2=0
141      AVAL=ALOW
142      DO210I=1,NGRID
143        N2=N2+1
144        X2(N2)=AVAL
145        DSUM1=0.0D0
146        DO220J=1,N
147          DVAL=DBLE((AVAL-YMEAN(J))/YSD(J))
148          CALL NODPDF(DVAL,DPDF)
149          DSUM1=DSUM1 + DPDF/DBLE(YSD(J))
150C
151          IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'MMPD')THEN
152            WRITE(ICOUT,211)I,J,AVAL,DVAL,DPDF,DSUM1
153  211       FORMAT('I,J,AVAL,DVAL,DPDF,DSUM1=',2I8,4G15.7)
154            CALL DPWRST('XXX','BUG ')
155          ENDIF
156C
157  220   CONTINUE
158        Y2(N2)=REAL(DSUM1)/REAL(N)
159        AVAL=AVAL+AINC
160  210 CONTINUE
161C
162C               ******************
163C               **   STEP 90--  **
164C               **   EXIT       **
165C               ******************
166C
167 9000 CONTINUE
168      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'MMPD')THEN
169        WRITE(ICOUT,999)
170        CALL DPWRST('XXX','BUG ')
171        WRITE(ICOUT,9011)
172 9011   FORMAT('***** AT THE END       OF DPMMPD--')
173        CALL DPWRST('XXX','BUG ')
174        WRITE(ICOUT,9012)IERROR,N2
175 9012   FORMAT('IERROR,N2 = ',A4,2X,I8)
176        CALL DPWRST('XXX','BUG ')
177        DO9015I=1,N2
178          WRITE(ICOUT,9016)I,X2(I),Y2(I)
179 9016     FORMAT('I,X2(I),Y2(I) = ',I8,2G15.7)
180          CALL DPWRST('XXX','BUG ')
181 9015   CONTINUE
182      ENDIF
183C
184      RETURN
185      END
186      SUBROUTINE DPMNTC(ICOM,IHARG,IARGT,ARG,NUMARG,
187     1X1COMN,X2COMN,Y1COMN,Y2COMN,
188     1NX1CMN,NX2CMN,NY1CMN,NY2CMN,
189     1MAXTIC,
190     1IFOUND,IERROR)
191C
192C     PURPOSE--DEFINE THE MINOR TIC MARK COORDINATES
193C              FOR ANY OF THE 4 FRAME LINES.
194C              THE MINOR TIC MARK COORDINATES ARE GIVEN IN UNITS
195C              OF THE PLOTTED DATA.
196C     ALSO, A SECONDARY PURPOSE IS TO ADJUST ACCORDINGLY
197C              THE TIC MARK SWITCHES
198C              FOR ANY OF THE 4 FRAME LINES.
199C              SUCH TIC MARK SWITCHES TURN ON OR OFF
200C              THE TIC MARKS ON THE 4 FRAME LINES OF A PLOT.
201C              THE CONTENTS OF A TIC MARK SWITCH ARE
202C              ON   OR    OFF
203C              THE TIC MARK SWITCHES DEFINE WHETHER
204C              THE TIC MARKS FOR A GIVEN FRAME SHOULD
205C              BE ON (THAT IS, APPEAR), OR BE OFF (THAT IS,
206C              BE SUPPRESSED.
207C              THE TIC MARK SWITCHES FOR THE 4 FRAME LINES
208C              ARE CONTAINED IN THE 4 VARIABLES
209C     INPUT  ARGUMENTS--ICOM
210C                     --IHARG  (A  HOLLERITH VECTOR)
211C                     --IARGT  (A  HOLLERITH VECTOR)
212C                     --ARG    (A  FLOATING POINT VECTOR)
213C                     --NUMARG
214C                     --MAXTIC
215C     OUTPUT ARGUMENTS--
216C                     --X1COMN,X2COMN,Y1COMN,Y2COMN,
217C                     --NX1CMN,NX2CMN,NY1CMN,NY2CMN,
218C                     --IFOUND ('YES' OR 'NO' )
219C                     --IERROR ('YES' OR 'NO' )
220C     WRITTEN BY--JAMES J. FILLIBEN
221C                 STATISTICAL ENGINEERING DIVISION
222C                 INFORMATION TECHNOLOGY LABORATORY
223C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
224C                 GAITHERSBURG, MD 20899-8980
225C                 PHONE--301-975-2855
226C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
227C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
228C     LANGUAGE--ANSI FORTRAN (1977)
229C     VERSION NUMBER--82/7
230C     ORIGINAL VERSION--SEPTEMBER 1980.
231C     UPDATED         --MAY       1982.
232C
233C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
234C
235      CHARACTER*4 ICOM
236      CHARACTER*4 IHARG
237      CHARACTER*4 IARGT
238C
239      CHARACTER*4 IFOUND
240      CHARACTER*4 IERROR
241C
242C---------------------------------------------------------------------
243C
244      DIMENSION IHARG(*)
245      DIMENSION IARGT(*)
246      DIMENSION ARG(*)
247C
248      DIMENSION X1COMN(*)
249      DIMENSION X2COMN(*)
250      DIMENSION Y1COMN(*)
251      DIMENSION Y2COMN(*)
252C
253C---------------------------------------------------------------------
254C
255      INCLUDE 'DPCOP2.INC'
256C
257C-----START POINT-----------------------------------------------------
258C
259      IFOUND='NO'
260      IERROR='NO'
261C
262      ILOCC=0
263      IF(NUMARG.LE.0)GOTO1900
264      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COOR')ILOCC=1
265      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'COOR')ILOCC=2
266      IF(NUMARG.GE.3.AND.IHARG(2).EQ.'COOR')ILOCC=3
267      ILOCCP=ILOCC+1
268      IF(ILOCC.EQ.0)GOTO1900
269C
270C               *****************************************************
271C               **  TREAT THE CASE WHEN TIC MARK COORDINATES ON    **
272C               **  BOTH HORIZONTAL FRAME LINES ARE TO BE DEFINED  **
273C               *****************************************************
274C
275      IF(ICOM.EQ.'XTIC')GOTO1100
276      GOTO1199
277C
278 1100 CONTINUE
279      IF(ILOCC.EQ.NUMARG)GOTO1110
280      IF(IHARG(ILOCCP).EQ.'ON')GOTO1110
281      IF(IHARG(ILOCCP).EQ.'OFF')GOTO1120
282      IF(IHARG(ILOCCP).EQ.'AUTO')GOTO1110
283      IF(IHARG(ILOCCP).EQ.'DEFA')GOTO1110
284      GOTO1130
285C
286 1110 CONTINUE
287      IFOUND='YES'
288      NX1CMN=-1
289      NX2CMN=-1
290C
291      IF(IFEEDB.EQ.'OFF')GOTO1119
292      WRITE(ICOUT,999)
293  999 FORMAT(1X)
294      CALL DPWRST('XXX','BUG ')
295      WRITE(ICOUT,1115)
296 1115 FORMAT('THE MINOR TIC MARK COORDINATES (FOR BOTH HORIZONTAL ',
297     1'FRAME LINES)')
298      CALL DPWRST('XXX','BUG ')
299      WRITE(ICOUT,1116)
300 1116 FORMAT('HAVE JUST BEEN SET TO AUTOMATIC')
301      CALL DPWRST('XXX','BUG ')
302 1119 CONTINUE
303      GOTO1900
304C
305 1120 CONTINUE
306      IFOUND='YES'
307C
308      IF(IFEEDB.EQ.'OFF')GOTO1129
309      WRITE(ICOUT,999)
310      CALL DPWRST('XXX','BUG ')
311      WRITE(ICOUT,1125)
312 1125 FORMAT('THE MINOR TIC MARK COORDINATES (FOR BOTH HORIZONTAL ',
313     1'FRAME LINES)')
314      CALL DPWRST('XXX','BUG ')
315      WRITE(ICOUT,1126)
316 1126 FORMAT('HAVE JUST BEEN TURNED OFF ')
317      CALL DPWRST('XXX','BUG ')
318      WRITE(ICOUT,1127)
319 1127 FORMAT('(THUS NO MINOR TIC MARKS WILL APPEAR ON THEM')
320      CALL DPWRST('XXX','BUG ')
321 1129 CONTINUE
322      GOTO1900
323C
324 1130 CONTINUE
325C
326      J=0
327      DO1131I=ILOCCP,NUMARG
328      J=J+1
329      IF(J.GT.MAXTIC)GOTO1800
330      IF(IARGT(I).NE.'NUMB')GOTO1850
331      X1COMN(J)=ARG(I)
332      X2COMN(J)=ARG(I)
333 1131 CONTINUE
334      IFOUND='YES'
335      NX1CMN=J
336      NX2CMN=J
337C
338      IF(IFEEDB.EQ.'OFF')GOTO1139
339      WRITE(ICOUT,999)
340      CALL DPWRST('XXX','BUG ')
341      WRITE(ICOUT,1135)
342 1135 FORMAT('THE MINOR TIC MARK COORDINATES (FOR BOTH HORIZONTAL ',
343     1'FRAME LINES)')
344      CALL DPWRST('XXX','BUG ')
345      WRITE(ICOUT,1136)
346 1136 FORMAT('HAVE JUST BEEN MANUALLY SPECIFIED')
347      CALL DPWRST('XXX','BUG ')
348 1139 CONTINUE
349      GOTO1900
350C
351 1199 CONTINUE
352C
353C               **************************************************************
354C               **  TREAT THE CASE WHEN MINOR TIC MARK COORDINATES ON
355C               **  ONLY THE BOTTOM HORIZONTAL FRAME LINE ARE TO BE DEFINED **
356C               **************************************************************
357C
358      IF(ICOM.EQ.'X1TI')GOTO1200
359      GOTO1299
360C
361C
362 1200 CONTINUE
363      IF(ILOCC.EQ.NUMARG)GOTO1210
364      IF(IHARG(ILOCCP).EQ.'ON')GOTO1210
365      IF(IHARG(ILOCCP).EQ.'OFF')GOTO1220
366      IF(IHARG(ILOCCP).EQ.'AUTO')GOTO1210
367      IF(IHARG(ILOCCP).EQ.'DEFA')GOTO1210
368      GOTO1230
369C
370 1210 CONTINUE
371      IFOUND='YES'
372      NX1CMN=-1
373C
374      IF(IFEEDB.EQ.'OFF')GOTO1219
375      WRITE(ICOUT,999)
376      CALL DPWRST('XXX','BUG ')
377      WRITE(ICOUT,1215)
378 1215 FORMAT('THE MINOR TIC COORDINATES (FOR THE BOTTOM ',
379     1'HORIZONTAL FRAME LINE)')
380      CALL DPWRST('XXX','BUG ')
381      WRITE(ICOUT,1216)
382 1216 FORMAT('HAVE JUST BEEN SET TO AUTOMATIC')
383      CALL DPWRST('XXX','BUG ')
384 1219 CONTINUE
385      GOTO1900
386C
387 1220 CONTINUE
388      IFOUND='YES'
389C
390      IF(IFEEDB.EQ.'OFF')GOTO1229
391      WRITE(ICOUT,999)
392      CALL DPWRST('XXX','BUG ')
393      WRITE(ICOUT,1225)
394 1225 FORMAT('THE MINOR TIC COORDINATES (FOR THE BOTTOM ',
395     1'HORIZONTAL FRAME LINE)')
396      CALL DPWRST('XXX','BUG ')
397      WRITE(ICOUT,1226)
398 1226 FORMAT('HAVE JUST BEEN TURNED OFF ')
399      CALL DPWRST('XXX','BUG ')
400      WRITE(ICOUT,1227)
401 1227 FORMAT('(THUS NO MINOR TIC MARKS WILL APPEAR ON IT)')
402      CALL DPWRST('XXX','BUG ')
403 1229 CONTINUE
404      GOTO1900
405C
406 1230 CONTINUE
407C
408      J=0
409      DO1231I=ILOCCP,NUMARG
410      J=J+1
411      IF(J.GT.MAXTIC)GOTO1800
412      IF(IARGT(I).NE.'NUMB')GOTO1850
413      X1COMN(J)=ARG(I)
414 1231 CONTINUE
415      IFOUND='YES'
416      NX1CMN=J
417C
418      IF(IFEEDB.EQ.'OFF')GOTO1239
419      WRITE(ICOUT,999)
420      CALL DPWRST('XXX','BUG ')
421      WRITE(ICOUT,1235)
422 1235 FORMAT('THE MINOR TIC COORDINATES (FOR THE BOTTOM ',
423     1'HORIZONTAL FRAME LINE)')
424      CALL DPWRST('XXX','BUG ')
425      WRITE(ICOUT,1236)
426 1236 FORMAT('HAVE JUST BEEN MANUALLY SPECIFIED')
427      CALL DPWRST('XXX','BUG ')
428 1239 CONTINUE
429      GOTO1900
430C
431 1299 CONTINUE
432C
433C               **************************************************************
434C               **  TREAT THE CASE WHEN MINOR TIC MARK COORDINATES ON
435C               **  ONLY THE TOP    HORIZONTAL FRAME LINE ARE TO BE DEFINED **
436C               **************************************************************
437C
438      IF(ICOM.EQ.'X2TI')GOTO1300
439      GOTO1399
440C
441 1300 CONTINUE
442      IF(ILOCC.EQ.NUMARG)GOTO1310
443      IF(IHARG(ILOCCP).EQ.'ON')GOTO1310
444      IF(IHARG(ILOCCP).EQ.'OFF')GOTO1320
445      IF(IHARG(ILOCCP).EQ.'AUTO')GOTO1310
446      IF(IHARG(ILOCCP).EQ.'DEFA')GOTO1310
447      GOTO1330
448C
449 1310 CONTINUE
450      IFOUND='YES'
451      NX2CMN=-1
452C
453      IF(IFEEDB.EQ.'OFF')GOTO1319
454      WRITE(ICOUT,999)
455      CALL DPWRST('XXX','BUG ')
456      WRITE(ICOUT,1315)
457 1315 FORMAT('THE MINOR TIC COORDINATES (FOR THE TOP ',
458     1'HORIZONTAL FRAME LINE)')
459      CALL DPWRST('XXX','BUG ')
460      WRITE(ICOUT,1316)
461 1316 FORMAT('HAVE JUST BEEN SET TO AUTOMATIC')
462      CALL DPWRST('XXX','BUG ')
463 1319 CONTINUE
464      GOTO1900
465C
466 1320 CONTINUE
467      IFOUND='YES'
468C
469      IF(IFEEDB.EQ.'OFF')GOTO1329
470      WRITE(ICOUT,999)
471      CALL DPWRST('XXX','BUG ')
472      WRITE(ICOUT,1325)
473 1325 FORMAT('THE MINOR TIC COORDINATES (FOR THE TOP ',
474     1'HORIZONTAL FRAME LINE)')
475      CALL DPWRST('XXX','BUG ')
476      WRITE(ICOUT,1326)
477 1326 FORMAT('HAVE JUST BEEN TURNED OFF ')
478      CALL DPWRST('XXX','BUG ')
479      WRITE(ICOUT,1327)
480 1327 FORMAT('(THUS NO MINOR TIC MARKS WILL APPEAR ON IT)')
481      CALL DPWRST('XXX','BUG ')
482 1329 CONTINUE
483      GOTO1900
484C
485 1330 CONTINUE
486C
487      J=0
488      DO1331I=ILOCCP,NUMARG
489      J=J+1
490      IF(J.GT.MAXTIC)GOTO1800
491      IF(IARGT(I).NE.'NUMB')GOTO1850
492      X2COMN(J)=ARG(I)
493 1331 CONTINUE
494      IFOUND='YES'
495      NX2CMN=J
496C
497      IF(IFEEDB.EQ.'OFF')GOTO1339
498      WRITE(ICOUT,999)
499      CALL DPWRST('XXX','BUG ')
500      WRITE(ICOUT,1335)
501 1335 FORMAT('THE MINOR TIC COORDINATES (FOR THE TOP ',
502     1'HORIZONTAL FRAME LINE)')
503      CALL DPWRST('XXX','BUG ')
504      WRITE(ICOUT,1336)
505 1336 FORMAT('HAVE JUST BEEN MANUALLY SPECIFIED')
506      CALL DPWRST('XXX','BUG ')
507 1339 CONTINUE
508      GOTO1900
509C
510 1399 CONTINUE
511C
512C               ***************************************************
513C               **  TREAT THE CASE WHEN MINOR TIC MARK COORDINATES ON  **
514C               **  BOTH VERMINOR TICAL FRAME LINES ARE TO BE DEFINED  **
515C               ***************************************************
516C
517      IF(ICOM.EQ.'YMINOR TIC')GOTO1400
518      GOTO1499
519C
520 1400 CONTINUE
521      IF(ILOCC.EQ.NUMARG)GOTO1410
522      IF(IHARG(ILOCCP).EQ.'ON')GOTO1410
523      IF(IHARG(ILOCCP).EQ.'OFF')GOTO1420
524      IF(IHARG(ILOCCP).EQ.'AUTO')GOTO1410
525      IF(IHARG(ILOCCP).EQ.'DEFA')GOTO1410
526      GOTO1430
527C
528 1410 CONTINUE
529      IFOUND='YES'
530      NY1CMN=-1
531      NY2CMN=-1
532C
533      IF(IFEEDB.EQ.'OFF')GOTO1419
534      WRITE(ICOUT,999)
535      CALL DPWRST('XXX','BUG ')
536      WRITE(ICOUT,1415)
537 1415 FORMAT('THE MINOR TIC MARK COORDINATES (FOR BOTH ',
538     1'VERTICAL FRAME LINES)')
539      CALL DPWRST('XXX','BUG ')
540      WRITE(ICOUT,1416)
541 1416 FORMAT('HAVE JUST BEEN SET TO AUTOMATIC')
542      CALL DPWRST('XXX','BUG ')
543 1419 CONTINUE
544      GOTO1900
545C
546 1420 CONTINUE
547      IFOUND='YES'
548C
549      IF(IFEEDB.EQ.'OFF')GOTO1429
550      WRITE(ICOUT,999)
551      CALL DPWRST('XXX','BUG ')
552      WRITE(ICOUT,1425)
553 1425 FORMAT('THE MINOR TIC MARK COORDINATES (FOR BOTH ',
554     1'VERTICAL FRAME LINES)')
555      CALL DPWRST('XXX','BUG ')
556      WRITE(ICOUT,1426)
557 1426 FORMAT('HAVE JUST BEEN TURNED OFF ')
558      CALL DPWRST('XXX','BUG ')
559      WRITE(ICOUT,1427)
560 1427 FORMAT('(THUS NO MINOR TIC MARKS WILL APPEAR ON THEM')
561      CALL DPWRST('XXX','BUG ')
562 1429 CONTINUE
563      GOTO1900
564C
565 1430 CONTINUE
566C
567      J=0
568      DO1431I=ILOCCP,NUMARG
569      J=J+1
570      IF(J.GT.MAXTIC)GOTO1800
571      IF(IARGT(I).NE.'NUMB')GOTO1850
572      Y1COMN(J)=ARG(I)
573      Y2COMN(J)=ARG(I)
574 1431 CONTINUE
575      IFOUND='YES'
576      NY1CMN=J
577      NY2CMN=J
578C
579      IF(IFEEDB.EQ.'OFF')GOTO1439
580      WRITE(ICOUT,999)
581      CALL DPWRST('XXX','BUG ')
582      WRITE(ICOUT,1435)
583 1435 FORMAT('THE MINOR TIC MARK COORDINATES (FOR BOTH ',
584     1'VERTICAL FRAME LINES)')
585      CALL DPWRST('XXX','BUG ')
586      WRITE(ICOUT,1436)
587 1436 FORMAT('HAVE JUST BEEN MANUALLY SPECIFIED')
588      CALL DPWRST('XXX','BUG ')
589 1439 CONTINUE
590      GOTO1900
591C
592 1499 CONTINUE
593C
594C               **************************************************************
595C               **  TREAT THE CASE WHEN MINOR TIC MARK COORDINATES ON
596C               **  ONLY THE LEFT   VERMINOR TICAL   FRAME LINE ARE TO BE DEFINE
597C               **************************************************************
598C
599      IF(ICOM.EQ.'Y1TI')GOTO1500
600      GOTO1599
601C
602 1500 CONTINUE
603      IF(ILOCC.EQ.NUMARG)GOTO1510
604      IF(IHARG(ILOCCP).EQ.'ON')GOTO1510
605      IF(IHARG(ILOCCP).EQ.'OFF')GOTO1520
606      IF(IHARG(ILOCCP).EQ.'AUTO')GOTO1510
607      IF(IHARG(ILOCCP).EQ.'DEFA')GOTO1510
608      GOTO1530
609C
610 1510 CONTINUE
611      IFOUND='YES'
612      NY1CMN=-1
613C
614      IF(IFEEDB.EQ.'OFF')GOTO1519
615      WRITE(ICOUT,999)
616      CALL DPWRST('XXX','BUG ')
617      WRITE(ICOUT,1515)
618 1515 FORMAT('THE MINOR TIC COORDINATES (FOR THE LEFT ',
619     1'VERTICAL FRAME LINE)')
620      CALL DPWRST('XXX','BUG ')
621      WRITE(ICOUT,1516)
622 1516 FORMAT('HAVE JUST BEEN SET TO AUTOMATIC')
623      CALL DPWRST('XXX','BUG ')
624 1519 CONTINUE
625      GOTO1900
626C
627 1520 CONTINUE
628      IFOUND='YES'
629C
630      IF(IFEEDB.EQ.'OFF')GOTO1529
631      WRITE(ICOUT,999)
632      CALL DPWRST('XXX','BUG ')
633      WRITE(ICOUT,1525)
634 1525 FORMAT('THE MINOR TIC COORDINATE (FOR THE LEFT ',
635     1'VERTICAL FRAME LINE)')
636      CALL DPWRST('XXX','BUG ')
637      WRITE(ICOUT,1526)
638 1526 FORMAT('HAVE JUST BEEN TURNED OFF ')
639      CALL DPWRST('XXX','BUG ')
640      WRITE(ICOUT,1527)
641 1527 FORMAT('(THUS NO MINOR TIC MARKS WILL APPEAR ON IT)')
642      CALL DPWRST('XXX','BUG ')
643 1529 CONTINUE
644      GOTO1900
645C
646 1530 CONTINUE
647C
648      J=0
649      DO1531I=ILOCCP,NUMARG
650      J=J+1
651      IF(J.GT.MAXTIC)GOTO1800
652      IF(IARGT(I).NE.'NUMB')GOTO1850
653      Y1COMN(J)=ARG(I)
654 1531 CONTINUE
655      IFOUND='YES'
656      NY1CMN=J
657C
658      IF(IFEEDB.EQ.'OFF')GOTO1539
659      WRITE(ICOUT,999)
660      CALL DPWRST('XXX','BUG ')
661      WRITE(ICOUT,1535)
662 1535 FORMAT('THE MINOR TIC COORDINATES (FOR THE LEFT ',
663     1'VERTICAL FRAME LINE)')
664      CALL DPWRST('XXX','BUG ')
665      WRITE(ICOUT,1536)
666 1536 FORMAT('HAVE JUST BEEN MANUALLY SPECIFIED')
667      CALL DPWRST('XXX','BUG ')
668 1539 CONTINUE
669      GOTO1900
670C
671 1599 CONTINUE
672C
673C               **************************************************************
674C               **  TREAT THE CASE WHEN MINOR TIC MARK COORDINATES ON
675C               **  ONLY THE RIGHT  VERTCIAL   FRAME LINE ARE TO BE DEFINED **
676C               **************************************************************
677C
678      IF(ICOM.EQ.'Y2TI')GOTO1600
679      GOTO1699
680C
681 1600 CONTINUE
682      IF(ILOCC.EQ.NUMARG)GOTO1610
683      IF(IHARG(ILOCCP).EQ.'ON')GOTO1610
684      IF(IHARG(ILOCCP).EQ.'OFF')GOTO1620
685      IF(IHARG(ILOCCP).EQ.'AUTO')GOTO1610
686      IF(IHARG(ILOCCP).EQ.'DEFA')GOTO1610
687      GOTO1630
688C
689 1610 CONTINUE
690      IFOUND='YES'
691      NY2CMN=-1
692C
693      IF(IFEEDB.EQ.'OFF')GOTO1619
694      WRITE(ICOUT,999)
695      CALL DPWRST('XXX','BUG ')
696      WRITE(ICOUT,1615)
697 1615 FORMAT('THE MINOR TIC COORDINATES (FOR THE RIGHT ',
698     1'VERTICAL FRAME LINE)')
699      CALL DPWRST('XXX','BUG ')
700      WRITE(ICOUT,1616)
701 1616 FORMAT('HAVE JUST BEEN SET TO AUTOMATIC')
702      CALL DPWRST('XXX','BUG ')
703 1619 CONTINUE
704      GOTO1900
705C
706 1620 CONTINUE
707      IFOUND='YES'
708C
709      IF(IFEEDB.EQ.'OFF')GOTO1629
710      WRITE(ICOUT,999)
711      CALL DPWRST('XXX','BUG ')
712      WRITE(ICOUT,1625)
713 1625 FORMAT('THE MINOR TIC COORDINATES (FOR THE RIGHT ',
714     1'VERTICAL FRAME LINE)')
715      CALL DPWRST('XXX','BUG ')
716      WRITE(ICOUT,1626)
717 1626 FORMAT('HAVE JUST BEEN TURNED OFF ')
718      CALL DPWRST('XXX','BUG ')
719      WRITE(ICOUT,1627)
720 1627 FORMAT('(THUS NO MINOR TIC MARKS WILL APPEAR ON IT)')
721      CALL DPWRST('XXX','BUG ')
722 1629 CONTINUE
723      GOTO1900
724C
725 1630 CONTINUE
726C
727      J=0
728      DO1631I=ILOCCP,NUMARG
729      J=J+1
730      IF(J.GT.MAXTIC)GOTO1800
731      IF(IARGT(I).NE.'NUMB')GOTO1850
732      Y1COMN(J)=ARG(I)
733 1631 CONTINUE
734      IFOUND='YES'
735      NY2CMN=J
736C
737      IF(IFEEDB.EQ.'OFF')GOTO1639
738      WRITE(ICOUT,999)
739      CALL DPWRST('XXX','BUG ')
740      WRITE(ICOUT,1635)
741 1635 FORMAT('THE MINOR TIC COORDINATES (FOR THE RIGHT ',
742     1'VERTICAL FRAME LINE)')
743      CALL DPWRST('XXX','BUG ')
744      WRITE(ICOUT,1636)
745 1636 FORMAT('HAVE JUST BEEN MANUALLY SPECIFIED')
746      CALL DPWRST('XXX','BUG ')
747 1639 CONTINUE
748      GOTO1900
749C
750 1699 CONTINUE
751C
752C               **************************************************
753C               **  TREAT THE CASE WHEN MINOR TIC MARK COORDINATES ON **
754C               **  THE ENTIRE 4-SIDED FRAME ARE TO BE DEFINED  **
755C               **************************************************
756C
757      IF(ICOM.EQ.'XYTI')GOTO1700
758      IF(ICOM.EQ.'YXTI')GOTO1700
759      IF(ICOM.EQ.'MINOR TICS')GOTO1700
760      IF(ICOM.EQ.'MINOR TIC ')GOTO1700
761      GOTO1799
762C
763 1700 CONTINUE
764      IF(ILOCC.EQ.NUMARG)GOTO1710
765      IF(IHARG(ILOCCP).EQ.'ON')GOTO1710
766      IF(IHARG(ILOCCP).EQ.'OFF')GOTO1720
767      IF(IHARG(ILOCCP).EQ.'AUTO')GOTO1710
768      IF(IHARG(ILOCCP).EQ.'DEFA')GOTO1710
769      GOTO1730
770C
771 1710 CONTINUE
772      IFOUND='YES'
773      NX1CMN=-1
774      NX2CMN=-1
775      NY1CMN=-1
776      NY2CMN=-1
777C
778      IF(IFEEDB.EQ.'OFF')GOTO1719
779      WRITE(ICOUT,999)
780      CALL DPWRST('XXX','BUG ')
781      WRITE(ICOUT,1715)
782 1715 FORMAT('THE MINOR TIC COORDINATES (FOR ALL 4 ',
783     1'FRAME LINES)')
784      CALL DPWRST('XXX','BUG ')
785      WRITE(ICOUT,1716)
786 1716 FORMAT('HAVE JUST BEEN SET TO AUTOMATIC')
787      CALL DPWRST('XXX','BUG ')
788 1719 CONTINUE
789      GOTO1900
790C
791 1720 CONTINUE
792      IFOUND='YES'
793C
794      IF(IFEEDB.EQ.'OFF')GOTO1729
795      WRITE(ICOUT,999)
796      CALL DPWRST('XXX','BUG ')
797      WRITE(ICOUT,1725)
798 1725 FORMAT('THE MINOR TIC COORDINATES (FOR ALL 4 ',
799     1'FRAME LINES)')
800      CALL DPWRST('XXX','BUG ')
801      WRITE(ICOUT,1726)
802 1726 FORMAT('HAVE JUST BEEN TURNED OFF ')
803      CALL DPWRST('XXX','BUG ')
804      WRITE(ICOUT,1727)
805 1727 FORMAT('(THUS NO MINOR TIC MARKS WILL APPEAR ON ANY ',
806     1'FRAME LINE)')
807      CALL DPWRST('XXX','BUG ')
808 1729 CONTINUE
809      GOTO1900
810C
811 1730 CONTINUE
812C
813      J=0
814      DO1731I=ILOCCP,NUMARG
815      J=J+1
816      IF(J.GT.MAXTIC)GOTO1800
817      IF(IARGT(I).NE.'NUMB')GOTO1850
818      X1COMN(J)=ARG(I)
819      X2COMN(J)=ARG(I)
820      Y1COMN(J)=ARG(I)
821      Y2COMN(J)=ARG(I)
822 1731 CONTINUE
823      IFOUND='YES'
824      NX1CMN=J
825      NX2CMN=J
826      NY1CMN=J
827      NY2CMN=J
828C
829      IF(IFEEDB.EQ.'OFF')GOTO1739
830      WRITE(ICOUT,999)
831      CALL DPWRST('XXX','BUG ')
832      WRITE(ICOUT,1735)
833 1735 FORMAT('THE MINOR TIC COORDINATES (FOR ALL 4 FRAMES)')
834      CALL DPWRST('XXX','BUG ')
835      WRITE(ICOUT,1736)
836 1736 FORMAT('HAVE JUST BEEN MANUALLY SPECIFIED')
837      CALL DPWRST('XXX','BUG ')
838 1739 CONTINUE
839      GOTO1900
840C
841 1799 CONTINUE
842      GOTO1900
843C
844 1800 CONTINUE
845      IERROR='YES'
846      WRITE(ICOUT,999)
847      CALL DPWRST('XXX','BUG ')
848      WRITE(ICOUT,1801)
849 1801 FORMAT('***** ERROR IN DPMNTC--')
850      CALL DPWRST('XXX','BUG ')
851      WRITE(ICOUT,1802)
852 1802 FORMAT('      THE NUMBER OF SPECIFIED')
853      CALL DPWRST('XXX','BUG ')
854      WRITE(ICOUT,1803)
855 1803 FORMAT('      MINOR TIC COORDINATES HAS JUST EXCEEDED ')
856      CALL DPWRST('XXX','BUG ')
857      WRITE(ICOUT,1804)MAXTIC
858 1804 FORMAT('      THE ALLOWABLE MAXIMUM OF ',I8)
859      CALL DPWRST('XXX','BUG ')
860      GOTO1900
861C
862 1850 CONTINUE
863      IERROR='YES'
864      WRITE(ICOUT,999)
865      CALL DPWRST('XXX','BUG ')
866      WRITE(ICOUT,1851)
867 1851 FORMAT('***** ERROR IN DPMNTC--')
868      CALL DPWRST('XXX','BUG ')
869      WRITE(ICOUT,1852)
870 1852 FORMAT('      A SPECIFICATION IN THE')
871      CALL DPWRST('XXX','BUG ')
872      WRITE(ICOUT,1853)
873 1853 FORMAT('      MINOR TIC COORDINATES COMMAND HAS JUST ')
874      CALL DPWRST('XXX','BUG ')
875      WRITE(ICOUT,1854)
876 1854 FORMAT('      BEEN ENCOUNTERED WHICH IS NON-NUMERIC')
877      CALL DPWRST('XXX','BUG ')
878      GOTO1900
879C
880 1900 CONTINUE
881      RETURN
882      END
883      SUBROUTINE DPMORE(NUMLPR,NCPREH,ICPREH,IRESP,IBUGS2,IERROR)
884CCCCC THE IRESP ARGUMENT WAS ADDED JULY 1990
885C
886C     PURPOSE--WRITE OUT A LINE WHICH SAYS     MORE...
887C              AND PAUSE UNTIL RECEIVE A CARRIAGE RETURN
888C              (USED BY HELP AND LIST COMMANDS)
889C     INPUT ARGUMENTS--NUMLPR = NUMBER OF LINE PRINTED ALREADY
890C     OUTPUT ARGUMENTS--IRESP (YES OR NO)
891C     NOTE--IT IS TYPICAL TO HAVE A LINE
892C              IF(NUMLPR.GE.IHELMX)NUMLPR=0
893C           IN THE CALLING ROUTINE IMMEDIATELY AFTER
894C           THE CALL TO DPMORE.
895C     NOTE--THE CALLING ROUTINE ALSO TYPICALLY HAS
896C              NUMLPR=0
897C              IRESP='YES'
898C           EARLY ON IN THE CODE FOR INITIALIZATION.
899C           (IF OMIT   IRESP='YES'    THEN WILL GET MIS-EXECUTION!)
900C     WRITTEN BY--JAMES J. FILLIBEN
901C                 STATISTICAL ENGINEERING DIVISION
902C                 INFORMATION TECHNOLOGY LABORATORY
903C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
904C                 GAITHERSBURG, MD 20899-8980
905C                 PHONE--301-975-2855
906C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
907C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
908C     LANGUAGE--ANSI FORTRAN (1977)
909C     VERSION NUMBER--89/8
910C     ORIGINAL VERSION--JULY      1989.
911C     UPDATED         --JULY      1989.  CHAR*4 STATEMENTS FOR ISUBN1/2
912C     UPDATED         --JULY      1990.   CHANGE MORE... TO MORE...?
913C     UPDATED         --JULY      1990.   ALLOW MORE... TO STOP LIST
914C     UPDATED         --FEBRUARY  1993.   SKIP ALL IF TURBO-C MENU
915C     UPDATED         --SEPTEMBER 1993.   ALLOW ALWAYS-WRITING
916C
917C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
918C
919      CHARACTER*40 ICPREH
920CCCCC CHARACTER*40 ICPOSH
921C
922      CHARACTER*4 IBUGS2
923      CHARACTER*4 IERROR
924C
925CCCCC THE FOLLOWING LINE WAS ADDED JULY 1990
926      CHARACTER*4 IRESP
927C
928CCCCC THE FOLLOWING 2 LINES WERE ADDED JULY 1989
929      CHARACTER*4 ISUBN1
930      CHARACTER*4 ISUBN2
931C
932C-----COMMON----------------------------------------------------------
933C
934CCCCC THE FOLLOWING LINE WAS ADDED FEBRUARY 1993
935      INCLUDE 'DPCODV.INC'
936C
937C-----COMMON VARIABLES (GENERAL)--------------------------------------
938C
939      INCLUDE 'DPCOP2.INC'
940C
941C-----START POINT-----------------------------------------------------
942C
943      ISUBN1='DPMO'
944      ISUBN2='RE  '
945      IERROR='NO'
946C
947      IF(IBUGS2.EQ.'ON')THEN
948        WRITE(ICOUT,999)
949  999   FORMAT(1X)
950        CALL DPWRST('XXX','BUG ')
951        WRITE(ICOUT,51)
952   51   FORMAT('***** AT THE BEGINNING OF DPMORE--')
953        CALL DPWRST('XXX','BUG ')
954        WRITE(ICOUT,53)NUMLPR,TCMENU
955   53   FORMAT('NUMLPR,TCMENU = ',I8,2X,A4)
956        CALL DPWRST('XXX','BUG ')
957      ENDIF
958C
959C               *********************************
960C               **  TREAT THE MORE/PAUSE CASE  **
961C               *********************************
962C
963CCCCC THE FOLLOWING LINE WAS ADDED FEBRUARY 1993
964      IF(TCMENU.EQ.'ON')GOTO9000
965C
966CCCCC THE FOLLOWING LINE WAS ADDED JULY 1990
967      IRESP='YES'
968C
969      WRITE(ICOUT,1101)
970 1101 FORMAT('                                      MORE...?')
971      CALL DPWRST('XXX','WRIT')
972      READ(IRD,1102)IRESP
973 1102 FORMAT(A4)
974      IF(IRESP.EQ.'N' .OR. IRESP.EQ.'n' .OR.
975     1   IRESP.EQ.'no')IRESP='NO'
976      IF(IRESP.EQ.'NO')GOTO9000
977      IF(NCPREH.GE.1)THEN
978        WRITE(ICOUT,1106)(ICPREH(J:J),J=1,NCPREH)
979 1106   FORMAT(80A1)
980        CALL DPWRST('XXX','WRIT')
981      ENDIF
982C
983C               ****************
984C               **  STEP 90-- **
985C               **  EXIT.     **
986C               ****************
987C
988 9000 CONTINUE
989      IF(IBUGS2.EQ.'ON')THEN
990        WRITE(ICOUT,999)
991        CALL DPWRST('XXX','BUG ')
992        WRITE(ICOUT,9011)
993 9011   FORMAT('***** AT THE BEGINNING OF DPMORE--')
994        CALL DPWRST('XXX','BUG ')
995        WRITE(ICOUT,9015)IRESP
996 9015   FORMAT('IRESP = ',A4)
997        CALL DPWRST('XXX','BUG ')
998      ENDIF
999C
1000      RETURN
1001      END
1002      SUBROUTINE DPMOSP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1003     1                  MAXNXT,ISEED,FILWID,
1004     1                  ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
1005C
1006C     PURPOSE--GENERATE ONE OF THE FOLLOWING PLOTS--
1007C
1008C                 <STATISTIC> MOVING     STATISTIC PLOT
1009C                 <STATISTIC> CUMULATIVE STATISTIC PLOT
1010C                 <STATISTIC> WINDOW STATISTIC PLOT
1011C
1012C     WRITTEN BY--ALAN HECKERT
1013C                 STATISTICAL ENGINEERING DIVISION
1014C                 INFORMATION TECHNOLOGY LABORATORY
1015C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
1016C                 GAITHERSBURG, MD 20899-8980
1017C                 PHONE--301-975-2899
1018C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
1019C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
1020C     LANGUAGE--ANSI FORTRAN (1977)
1021C     VERSION NUMBER--2015/5
1022C     ORIGINAL VERSION--MAY       2015.
1023C     UPDATED  VERSION--JUNE      2016. ADDED WINDOW STATISTIC PLOT
1024C     UPDATED  VERSION--JULY      2019. TWEAK SCRATCH STORAGE
1025C
1026C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
1027C
1028      CHARACTER*4 ICASPL
1029      CHARACTER*4 IAND1
1030      CHARACTER*4 IAND2
1031      CHARACTER*4 ISUBRO
1032      CHARACTER*4 IBUGG2
1033      CHARACTER*4 IBUGG3
1034      CHARACTER*4 IBUGQ
1035      CHARACTER*4 IFOUND
1036      CHARACTER*4 IERROR
1037C
1038      CHARACTER*4 IHWUSE
1039      CHARACTER*4 MESSAG
1040      CHARACTER*4 IH
1041      CHARACTER*4 IH2
1042C
1043      PARAMETER (MAXSPN=30)
1044      CHARACTER*4 IVARN1(MAXSPN)
1045      CHARACTER*4 IVARN2(MAXSPN)
1046      CHARACTER*4 IVARTY(MAXSPN)
1047      REAL PVAR(MAXSPN)
1048      INTEGER ILIS(MAXSPN)
1049      INTEGER NRIGHT(MAXSPN)
1050      INTEGER ICOLR(MAXSPN)
1051C
1052      CHARACTER*40 INAME
1053      CHARACTER*60 ISTANM
1054      CHARACTER*4  ISTADF
1055      CHARACTER*4  ICASS7
1056      CHARACTER*4  ICASE
1057C
1058      CHARACTER*4 ISUBN0
1059      CHARACTER*4 ISUBN1
1060      CHARACTER*4 ISUBN2
1061      CHARACTER*4 ISTEPN
1062C
1063C---------------------------------------------------------------------
1064C
1065      INCLUDE 'DPCOPA.INC'
1066C
1067      DIMENSION Y1(MAXOBV)
1068      DIMENSION Y2(MAXOBV)
1069      DIMENSION Y3(MAXOBV)
1070      DIMENSION X1(MAXOBV)
1071      DIMENSION TEMP(MAXOBV)
1072      DIMENSION TEMP2(MAXOBV)
1073      DIMENSION TEMP3(MAXOBV)
1074      DIMENSION TEMP4(MAXOBV)
1075      DIMENSION YOUT(MAXOBV)
1076      DIMENSION XTEMP1(MAXOBV)
1077      DIMENSION XTEMP2(MAXOBV)
1078      DIMENSION XTEMP3(MAXOBV)
1079C
1080      INCLUDE 'DPCOZZ.INC'
1081      EQUIVALENCE (GARBAG(IGARB1),Y1(1))
1082      EQUIVALENCE (GARBAG(IGARB2),Y2(1))
1083      EQUIVALENCE (GARBAG(IGARB3),Y3(1))
1084      EQUIVALENCE (GARBAG(IGARB4),X1(1))
1085      EQUIVALENCE (GARBAG(IGARB5),TEMP(1))
1086      EQUIVALENCE (GARBAG(IGARB6),TEMP2(1))
1087      EQUIVALENCE (GARBAG(IGARB7),TEMP3(1))
1088      EQUIVALENCE (GARBAG(IGARB8),TEMP4(1))
1089      EQUIVALENCE (GARBAG(IGARB9),YOUT(1))
1090      EQUIVALENCE (GARBAG(IGAR10),XTEMP1(1))
1091      EQUIVALENCE (GARBAG(JGAR11),XTEMP2(1))
1092      EQUIVALENCE (GARBAG(JGAR12),XTEMP3(1))
1093C
1094      INCLUDE 'DPCOZI.INC'
1095      INCLUDE 'DPCOZD.INC'
1096C
1097      INTEGER ITEMP1(MAXOBV)
1098      INTEGER ITEMP2(MAXOBV)
1099      INTEGER ITEMP3(MAXOBV)
1100      INTEGER ITEMP4(MAXOBV)
1101      INTEGER ITEMP5(MAXOBV)
1102      INTEGER ITEMP6(MAXOBV)
1103      EQUIVALENCE (IGARBG(IIGAR1),ITEMP1(1))
1104      EQUIVALENCE (IGARBG(IIGAR2),ITEMP2(1))
1105      EQUIVALENCE (IGARBG(IIGAR3),ITEMP3(1))
1106      EQUIVALENCE (IGARBG(IIGAR4),ITEMP4(1))
1107      EQUIVALENCE (IGARBG(IIGAR5),ITEMP5(1))
1108      EQUIVALENCE (IGARBG(IIGAR6),ITEMP6(1))
1109C
1110      DOUBLE PRECISION DTEMP1(MAXOBV)
1111      DOUBLE PRECISION DTEMP2(MAXOBV)
1112      DOUBLE PRECISION DTEMP3(MAXOBV)
1113      EQUIVALENCE (DGARBG(IDGAR1),DTEMP1(1))
1114      EQUIVALENCE (DGARBG(IDGAR2),DTEMP2(1))
1115      EQUIVALENCE (DGARBG(IDGAR3),DTEMP3(1))
1116C
1117C-----COMMON----------------------------------------------------------
1118C
1119      INCLUDE 'DPCOHK.INC'
1120      INCLUDE 'DPCODA.INC'
1121      INCLUDE 'DPCOHO.INC'
1122      INCLUDE 'DPCOST.INC'
1123      INCLUDE 'DPCOP2.INC'
1124C
1125C-----START POINT-----------------------------------------------------
1126C
1127      IERROR='NO'
1128      ISUBN1='DPMO'
1129      ISUBN2='SP  '
1130C
1131      IMININ=0
1132      IMAXIN=0
1133      MAXCP1=MAXCOL+1
1134      MAXCP2=MAXCOL+2
1135      MAXCP3=MAXCOL+3
1136      MAXCP4=MAXCOL+4
1137      MAXCP5=MAXCOL+5
1138      MAXCP6=MAXCOL+6
1139C
1140C               *******************************************************
1141C               **  TREAT THE MOVING/CUMULATIVE STATISTIC PLOT CASE  **
1142C               *******************************************************
1143C
1144      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'MOSP')THEN
1145        WRITE(ICOUT,999)
1146  999   FORMAT(1X)
1147        CALL DPWRST('XXX','BUG ')
1148        WRITE(ICOUT,51)
1149   51   FORMAT('***** AT THE BEGINNING OF DPMOSP--')
1150        CALL DPWRST('XXX','BUG ')
1151        WRITE(ICOUT,52)ISUBRO,IBUGG2,IBUGG3,IBUGQ
1152   52   FORMAT('ISUBRO,IBUGG2,IBUGG3,IBUGQ  = ',3(A4,2X),A4)
1153        CALL DPWRST('XXX','BUG ')
1154        WRITE(ICOUT,53)ICASPL,IAND1,IAND2,NUMARG,MAXNXT
1155   53   FORMAT('ICASPL,IAND1,IAND2,NUMARG,MAXNXT = ',3(A4,2X),2I8)
1156        CALL DPWRST('XXX','BUG ')
1157        DO55I=1,NUMARG
1158          WRITE(ICOUT,57)I,IHARG(I),IHARG2(I)
1159   57     FORMAT('I,IHARG(I),IHARG2(I) = ',I8,2(2X,A4))
1160          CALL DPWRST('XXX','BUG ')
1161   55   CONTINUE
1162      ENDIF
1163C
1164C               ***************************
1165C               **  STEP 1--             **
1166C               **  EXTRACT THE COMMAND  **
1167C               ***************************
1168C
1169      ISTEPN='1'
1170      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'MOSP')
1171     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1172C
1173      IF(NUMARG.LE.1)GOTO9000
1174C
1175C     EXTRACT THE DESIRED STATISTIC
1176C
1177C       2013/04: CHECK FOR CONFLICT BETWEEN "QUANTILE PLOT" AND
1178C                "QUANTILE-QUANTILE PLOT".
1179C
1180      IF(ICOM.EQ.'QUAN' .AND. IHARG(1).EQ.'QUAN')GOTO9000
1181C
1182      JMIN=0
1183      JMAX=NUMARG
1184      IFLAGZ=0
1185      IFLAGU=0
1186C
1187      DO200I=1,NUMARG
1188        IF(I.GE.3)THEN
1189          IF(IHARG(I-2).EQ.'MOVI' .AND. IHARG(I-1).EQ.'STAT' .AND.
1190     1       IHARG(I).EQ.'PLOT')THEN
1191            IFOUND='YES'
1192            ICASPL='MOSP'
1193            IF(JMAX.EQ.NUMARG)JMAX=I-3
1194            ILASTC=I
1195            GOTO209
1196          ELSEIF(IHARG(I-2).EQ.'CUMU' .AND. IHARG(I-1).EQ.'STAT' .AND.
1197     1       IHARG(I).EQ.'PLOT')THEN
1198            IFOUND='YES'
1199            ICASPL='CUSP'
1200            IF(JMAX.EQ.NUMARG)JMAX=I-3
1201            ILASTC=I
1202            GOTO209
1203          ELSEIF(IHARG(I-2).EQ.'WIND' .AND. IHARG(I-1).EQ.'STAT' .AND.
1204     1       IHARG(I).EQ.'PLOT')THEN
1205            IFOUND='YES'
1206            ICASPL='WISP'
1207            IF(JMAX.EQ.NUMARG)JMAX=I-3
1208            ILASTC=I
1209            GOTO209
1210          ENDIF
1211C
1212C       CHECK FOR CONFLICT BETWEEN "QUANTILE PLOT" AND
1213C       "QUANTILE-QUANTILE PLOT"
1214C
1215        ELSEIF(I.GT.1)THEN
1216          IF(IHARG(I).EQ.'QUAN'.AND. IHARG(I-1).EQ.'QUAN')THEN
1217            GOTO9000
1218          ENDIF
1219        ENDIF
1220  200 CONTINUE
1221      GOTO9000
1222  209 CONTINUE
1223C
1224      CALL EXTSTA(ICOM,ICOM2,IHARG,IHARG2,IARGT,ARG,NUMARG,JMIN,JMAX,
1225     1            ICASS7,ISTANM,ISTANR,ISTADF,IFOUND,ILOCV,
1226     1            ISUBRO,IBUGG3,IERROR)
1227C
1228      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'MOSP')THEN
1229        WRITE(ICOUT,999)
1230        CALL DPWRST('XXX','BUG ')
1231        WRITE(ICOUT,251)
1232  251   FORMAT('***** AFTER CALL EXTSTA--')
1233        CALL DPWRST('XXX','BUG ')
1234        WRITE(ICOUT,252)ICASPL,ISTANR,ILOCV,IFOUND
1235  252   FORMAT('ICASPL,ISTANR,ILOCV,IFOUND = ',A4,2I8,2X,A4)
1236        CALL DPWRST('XXX','BUG ')
1237      ENDIF
1238C
1239      IF(IFOUND.EQ.'NO')GOTO9000
1240      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
1241C
1242C               *********************************
1243C               **  STEP 2--                   **
1244C               **  EXTRACT THE VARIABLE LIST  **
1245C               *********************************
1246C
1247      INAME='MOVING STATISTIC PLOT'
1248      IF(ICASPL.EQ.'CUSP') INAME='CUMULATIVE STATISTIC PLOT'
1249      IF(ICASPL.EQ.'WISP') INAME='WINDOW STATISTIC PLOT'
1250      MINNA=1
1251      MAXNA=100
1252      MINN2=2
1253      IFLAGE=1
1254      IFLAGM=0
1255      IFLAGP=0
1256      JMIN=1
1257      JMAX=NUMARG
1258      MINNVA=ISTANR
1259      MAXNVA=ISTANR+1
1260C
1261      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
1262     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
1263     1            JMIN,JMAX,
1264     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
1265     1            IVARN1,IVARN2,IVARTY,PVAR,
1266     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
1267     1            MINNVA,MAXNVA,
1268     1            IFLAGM,IFLAGP,
1269     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1270      IF(IERROR.EQ.'YES')GOTO9000
1271C
1272      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'MOSP')THEN
1273        WRITE(ICOUT,999)
1274        CALL DPWRST('XXX','BUG ')
1275        WRITE(ICOUT,281)
1276  281   FORMAT('***** AFTER CALL DPPARS--')
1277        CALL DPWRST('XXX','BUG ')
1278        WRITE(ICOUT,282)NQ,NUMVAR
1279  282   FORMAT('NQ,NUMVAR = ',2I8)
1280        CALL DPWRST('XXX','BUG ')
1281        IF(NUMVAR.GT.0)THEN
1282          DO285I=1,NUMVAR
1283            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
1284     1                      ICOLR(I)
1285  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
1286     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
1287            CALL DPWRST('XXX','BUG ')
1288  285     CONTINUE
1289        ENDIF
1290      ENDIF
1291C
1292C               *********************************
1293C               **  STEP 3--                   **
1294C               **  EXTRACT THE DATA           **
1295C               *********************************
1296C
1297        ICOL=1
1298        NUMVA2=ISTANR
1299        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
1300     1              INAME,IVARN1,IVARN2,IVARTY,
1301     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
1302     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
1303     1              MAXCP4,MAXCP5,MAXCP6,
1304     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
1305     1              Y1,Y2,Y3,NY,NTEMP,NTEMP,ICASE,
1306     1              IBUGG3,ISUBRO,IFOUND,IERROR)
1307        IF(IERROR.EQ.'YES')GOTO9000
1308C
1309C       IF THERE IS A GROUP-ID VARIABLE, EXTRACT THAT
1310C
1311        NX=0
1312        IF(NUMVAR.EQ.ISTANR+1)THEN
1313          ICOL=ISTANR+1
1314          NUMVA2=1
1315          CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
1316     1                INAME,IVARN1,IVARN2,IVARTY,
1317     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
1318     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
1319     1                MAXCP4,MAXCP5,MAXCP6,
1320     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
1321     1                X1,X1,X1,NX,NTEMP,NTEMP,ICASE,
1322     1                IBUGG3,ISUBRO,IFOUND,IERROR)
1323          IF(IERROR.EQ.'YES')GOTO9000
1324        ENDIF
1325C
1326C               ********************************************************
1327C               **  STEP 4--                                          **
1328C               **  FORM THE VERTICAL AND HORIZONTAL AXIS             **
1329C               **  VALUES Y(.) AND X(.) FOR THE PLOT.                **
1330C               **  DEFINE THE NUMBER OF PLOT POINTS    (NPLOTP).     **
1331C               **  DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV).     **
1332C               ********************************************************
1333C
1334      ISTEPN='4'
1335      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'MOSP')
1336     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1337C
1338      IF(FILWID.EQ.CPUMIN)THEN
1339        IFILWI=3
1340      ELSE
1341        IFILWI=INT(FILWID+0.5)
1342        IF(IFILWI.LT.1)IFILWI=3
1343      ENDIF
1344C
1345      NSIZE=0
1346      IF(ICASPL.EQ.'WISP')THEN
1347        IH='NSIZ'
1348        IH2='E   '
1349        IHWUSE='P'
1350        MESSAG='NO'
1351        CALL CHECKN(IH,IH2,IHWUSE,
1352     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,
1353     1              NUMNAM,MAXNAM,
1354     1              ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR)
1355        IF(IERROR.EQ.'YES')THEN
1356          IF(NY.LE.1000)THEN
1357            NSIZE=NY/10
1358          ELSE
1359            NSIZE=NY/100
1360          ENDIF
1361        ELSE
1362          NSIZE=INT(VALUE(ILOC)+0.5)
1363        ENDIF
1364      ENDIF
1365C
1366      CALL DPMOS2(Y1,Y2,Y3,NY,X1,NX,MAXOBV,ISTANR,
1367     1            ICASPL,ICASS7,
1368     1            TEMP,TEMP2,TEMP3,TEMP4,YOUT,
1369     1            XTEMP1,XTEMP2,XTEMP3,
1370     1            ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
1371     1            DTEMP1,DTEMP2,DTEMP3,
1372     1            IQUAME,IQUASE,PSTAMV,NSIZE,
1373     1            IMOVEP,IMOVDI,IFILWI,ICSTSV,IMOVGR,
1374     1            Y,X,D,NPLOTP,NPLOTV,ISUBRO,IBUGG3,IERROR)
1375C
1376C
1377C               *************************************************
1378C               **  STEP 29--                                  **
1379C               **  SAVE DIFFERENCE BETWEEN HIGHEST VALUE AND  **
1380C               **  LOWEST VALUE OF STATISTIC IN INTERNAL      **
1381C               **  PARAMETER ALOWHIGH                         **
1382C               *************************************************
1383      AMINS=CPUMAX
1384      AMAXS=CPUMIN
1385      DO2910I=1,NPLOTP
1386        IF(D(I).NE.1.0)GOTO2910
1387        IF(Y(I).GT.AMAXS)THEN
1388          AMAXS=Y(I)
1389          IMAXIN=I
1390        ENDIF
1391        IF(Y(I).LT.AMINS)THEN
1392          AMINS=Y(I)
1393          IMININ=I
1394        ENDIF
1395 2910 CONTINUE
1396      ADIFF=AMAXS-AMINS
1397      IF(IMAXIN.GT.IMININ)ADIFF=-ADIFF
1398C
1399      ISUBN0='MOSP'
1400C
1401      IH='ALOW'
1402      IH2='HIGH'
1403      VALUE0=ADIFF
1404      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
1405     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
1406     1IANS,IWIDTH,IBUGG3,IERROR)
1407C
1408C
1409C
1410C               *****************
1411C               **  STEP 90--  **
1412C               **  EXIT       **
1413C               *****************
1414C
1415 9000 CONTINUE
1416      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'MOSP')THEN
1417        WRITE(ICOUT,999)
1418        CALL DPWRST('XXX','BUG ')
1419        WRITE(ICOUT,9011)
1420 9011   FORMAT('***** AT THE END       OF DPMOSP--')
1421        CALL DPWRST('XXX','BUG ')
1422        WRITE(ICOUT,9012)ISUBRO,IBUGG2,IBUGG3,IBUGQ
1423 9012   FORMAT('ISUBRO,IBUGG2,IBUGG3,IBUGQ  = ',3(A4,2X),A4)
1424        CALL DPWRST('XXX','BUG ')
1425        WRITE(ICOUT,9013)IFOUND,IERROR,ICASS7
1426 9013   FORMAT('IFOUND,IERROR,ICASS7 = ',2(A4,2X),A4)
1427        CALL DPWRST('XXX','BUG ')
1428        IF(IFOUND.EQ.'NO')GOTO9099
1429        WRITE(ICOUT,9014)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
1430 9014   FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',
1431     1         I8,I8,I8,2X,A4,2X,A4,2X,A4)
1432        CALL DPWRST('XXX','BUG ')
1433        WRITE(ICOUT,9016)NUMVAR,ISIZE
1434 9016   FORMAT('NUMVAR,ISIZE = ',2I8)
1435        CALL DPWRST('XXX','BUG ')
1436        IF(IFOUND.EQ.'NO'.OR.NPLOTP.LE.0)THEN
1437          DO9025I=1,NPLOTP
1438            WRITE(ICOUT,9026)I,Y(I),X(I),D(I)
1439 9026       FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5)
1440            CALL DPWRST('XXX','BUG ')
1441 9025     CONTINUE
1442        ENDIF
1443      ENDIF
1444 9099 CONTINUE
1445C
1446      RETURN
1447      END
1448      SUBROUTINE DPMOS2(Y1,Y2,Y3,NY,X1,NX,MAXOBV,ISTANR,
1449     1                  ICASPL,ICASS7,
1450     1                  TEMP,TEMPZ,TEMPZ2,XIDTEM,YOUT,
1451     1                  XTEMP1,XTEMP2,XTEMP3,
1452     1                  ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
1453     1                  DTEMP1,DTEMP2,DTEMP3,
1454     1                  IQUAME,IQUASE,PSTAMV,NSIZE,
1455     1                  IMOVEP,IMOVDI,IFILWI,ICSTSV,IMOVGR,
1456     1                  Y,X,D,NPLOTP,NPLOTV,ISUBRO,IBUGG3,IERROR)
1457C
1458C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS THAT WILL DEFINE
1459C
1460C                 <STATISTIC> MOVING     STATISTIC PLOT
1461C                 <STATISTIC> CUMULATIVE STATISTIC PLOT
1462C                 <STATISTIC> WINDOW STATISTIC PLOT
1463C
1464C     WRITTEN BY--ALAN HECKERT
1465C                 STATISTICAL ENGINEERING DIVISION
1466C                 INFORMATION TECHNOLOGY LABORATORY
1467C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
1468C                 GAITHERSBURG, MD 20899-8980
1469C                 PHONE--301-975-2899
1470C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
1471C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
1472C     LANGUAGE--ANSI FORTRAN (1977)
1473C     VERSION NUMBER--2015/5
1474C     ORIGINAL VERSION--MAY       2015.
1475C
1476C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
1477C
1478      CHARACTER*4 ICASPL
1479      CHARACTER*4 ICASS7
1480      CHARACTER*4 ISUBRO
1481      CHARACTER*4 IBUGG3
1482      CHARACTER*4 IERROR
1483C
1484      CHARACTER*4 IWRITE
1485      CHARACTER*4 IQUAME
1486      CHARACTER*4 IQUASE
1487      CHARACTER*4 IMOVEP
1488      CHARACTER*4 IMOVDI
1489      CHARACTER*4 IMOVGR
1490C
1491      CHARACTER*4 ISUBN1
1492      CHARACTER*4 ISUBN2
1493      CHARACTER*4 ISTEPN
1494C
1495C---------------------------------------------------------------------
1496C
1497      DIMENSION Y1(*)
1498      DIMENSION Y2(*)
1499      DIMENSION Y3(*)
1500      DIMENSION X1(*)
1501      DIMENSION Y(*)
1502      DIMENSION X(*)
1503      DIMENSION D(*)
1504C
1505      DIMENSION TEMP(*)
1506      DIMENSION TEMPZ(*)
1507      DIMENSION TEMPZ2(*)
1508      DIMENSION YOUT(*)
1509      DIMENSION XIDTEM(*)
1510      DIMENSION XTEMP1(*)
1511      DIMENSION XTEMP2(*)
1512      DIMENSION XTEMP3(*)
1513C
1514      INTEGER ITEMP1(*)
1515      INTEGER ITEMP2(*)
1516      INTEGER ITEMP3(*)
1517      INTEGER ITEMP4(*)
1518      INTEGER ITEMP5(*)
1519      INTEGER ITEMP6(*)
1520C
1521      DOUBLE PRECISION DTEMP1(*)
1522      DOUBLE PRECISION DTEMP2(*)
1523      DOUBLE PRECISION DTEMP3(*)
1524C
1525C-----COMMON----------------------------------------------------------
1526C
1527C-----COMMON VARIABLES (GENERAL)--------------------------------------
1528C
1529      INCLUDE 'DPCOP2.INC'
1530C
1531C-----START POINT-----------------------------------------------------
1532C
1533      ISUBN1='DPMO'
1534      ISUBN2='S2  '
1535      IWRITE='OFF'
1536C
1537      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'MOS2')THEN
1538        WRITE(ICOUT,70)
1539   70   FORMAT('AT THE BEGINNING OF DPMOS2--')
1540        CALL DPWRST('XXX','BUG ')
1541        WRITE(ICOUT,71)IBUGG3,ISUBRO,ICASPL,ICASS7
1542   71   FORMAT('IBUGG3,ISUBRO,ICASPL,ICASS7 = ',3(A4,2X),A4)
1543        CALL DPWRST('XXX','BUG ')
1544        WRITE(ICOUT,72)NY,NX,NSIZE
1545   72   FORMAT('NY,NX,NSIZE = ',3I8)
1546        CALL DPWRST('XXX','BUG ')
1547        DO73I=1,NY
1548          WRITE(ICOUT,74)I,Y1(I),Y2(I),Y3(I),X1(I)
1549   74     FORMAT('I,Y1(I),Y2(I),Y3(I),X1(I) = ',I8,45G15.7)
1550          CALL DPWRST('XXX','BUG ')
1551   73   CONTINUE
1552      ENDIF
1553C
1554C     CHECK THE INPUT ARGUMENTS FOR ERRORS
1555C
1556      IF(NY.LT.1)THEN
1557        WRITE(ICOUT,999)
1558  999   FORMAT(1X)
1559        CALL DPWRST('XXX','BUG ')
1560        WRITE(ICOUT,31)
1561   31   FORMAT('***** ERROR IN MOVING/CUMULATIVE/WINDOW STATISTIC ',
1562     1         'PLOT--')
1563        CALL DPWRST('XXX','BUG ')
1564        WRITE(ICOUT,32)
1565   32   FORMAT('      THE NUMBER OF OBSERVATIONS IS NON-POSITIVE.')
1566        CALL DPWRST('XXX','BUG ')
1567        WRITE(ICOUT,34)NY
1568   34   FORMAT('      THE NUMBER OF OBSERVATIONS = ',I6)
1569        CALL DPWRST('XXX','BUG ')
1570        WRITE(ICOUT,999)
1571        CALL DPWRST('XXX','BUG ')
1572        IERROR='YES'
1573        GOTO9000
1574      ELSEIF(NX.GT.0 .AND. NY.NE.NX)THEN
1575        WRITE(ICOUT,999)
1576        CALL DPWRST('XXX','BUG ')
1577        WRITE(ICOUT,31)
1578        CALL DPWRST('XXX','BUG ')
1579        WRITE(ICOUT,42)
1580   42   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ',
1581     1         'VARIABLES IS NOT')
1582        CALL DPWRST('XXX','BUG ')
1583        WRITE(ICOUT,43)
1584   43   FORMAT('      EQUAL TO NUMBER OF OBSERVATIONS FOR THE ',
1585     1         'GROUP-ID VARIABLE.')
1586        CALL DPWRST('XXX','BUG ')
1587        WRITE(ICOUT,44)NY
1588   44   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ',
1589     1         'VARIABLE = ',I8)
1590        CALL DPWRST('XXX','BUG ')
1591        WRITE(ICOUT,46)NX
1592   46   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE GROUP-ID ',
1593     1         'VARIABLE = ',I8)
1594        CALL DPWRST('XXX','BUG ')
1595        WRITE(ICOUT,999)
1596        CALL DPWRST('XXX','BUG ')
1597        IERROR='YES'
1598        GOTO9000
1599      ENDIF
1600C
1601C               ********************************************************
1602C               **  STEP 1--                                          **
1603C               **  DETERMINE THE NUMBER OF DISTINCT VALUES           **
1604C               **  FOR THE GROUP VARIABLE (USUALLY VAR. 2)           **
1605C               **  IF ALL VALUES ARE DISTINCT, THEN THIS             **
1606C               **  IMPLIES WE HAVE THE NO REPLICATION CASE           **
1607C               **  WHICH IS AN ERROR CONDITION FOR A PLOT.           **
1608C               ********************************************************
1609C
1610      ISTEPN='1'
1611      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'MOS2')
1612     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1613C
1614      IF(NX.GT.0)THEN
1615        NUMSET=0
1616        DO111I=1,NY
1617          IF(NUMSET.GE.1)THEN
1618            DO112J=1,NUMSET
1619              IF(X1(I).EQ.XIDTEM(J))GOTO111
1620  112       CONTINUE
1621          ENDIF
1622          NUMSET=NUMSET+1
1623          XIDTEM(NUMSET)=X1(I)
1624  111   CONTINUE
1625        CALL SORT(XIDTEM,NUMSET,XIDTEM)
1626C
1627        IF(NUMSET.EQ.NY)THEN
1628          WRITE(ICOUT,999)
1629          CALL DPWRST('XXX','BUG ')
1630          WRITE(ICOUT,135)
1631  135     FORMAT('***** WARNING IN MOVING/CUMULATIVE/WINDOW STATISTIC ',
1632     1           'PLOT--')
1633          CALL DPWRST('XXX','BUG ')
1634          WRITE(ICOUT,136)NUMSET
1635  136     FORMAT('      THE NUMBER OF SETS ',I8,' IS IDENTICAL TO ')
1636          CALL DPWRST('XXX','BUG ')
1637          WRITE(ICOUT,137)NY
1638  137     FORMAT('      THE NUMBER OF OBSERVATIONS  ',I8,'.')
1639          CALL DPWRST('XXX','BUG ')
1640        ENDIF
1641C
1642      ELSE
1643        NUMSET=1
1644      ENDIF
1645C
1646C               ******************************************
1647C               **  STEP 2--                            **
1648C               **  COMPUTE THE SPECIFIED STATISTIC     **
1649C               **  FOR EACH SUBSET OF THE DATA.        **
1650C               ******************************************
1651C
1652      ISTEPN='2'
1653      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'MOS2')
1654     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1655C
1656      ISTRT=0
1657      ISKIP=0
1658      IF(ICASPL.EQ.'CUSP')THEN
1659        ISKIP=ICSTSV-1
1660      ELSEIF(ICASPL.EQ.'MOSP')THEN
1661        IF(IMOVEP.EQ.'SKIP')THEN
1662          IF(IMOVDI.EQ.'LEFT')THEN
1663            ISKIP=0
1664          ELSEIF(IMOVDI.EQ.'RIGH')THEN
1665            ISKIP=IFILWI-1
1666          ELSEIF(IMOVDI.EQ.'CENT')THEN
1667            ISKIP=IFILWI/2
1668          ENDIF
1669        ENDIF
1670      ENDIF
1671C
1672      NPLOTP=0
1673      ITAG=0
1674C
1675      DO1000ISET=1,NUMSET
1676C
1677        IF(NUMSET.EQ.1)THEN
1678          DO1010I=1,NY
1679            TEMP(I)=Y1(I)
1680            TEMPZ(I)=Y2(I)
1681            TEMPZ2(I)=Y3(I)
1682 1010     CONTINUE
1683          NS2=NY
1684        ELSE
1685          K=0
1686          DO1011I=1,NY
1687            IF(X1(I).EQ.XIDTEM(ISET))THEN
1688              K=K+1
1689              TEMP(K)=Y1(I)
1690              TEMPZ(K)=Y2(I)
1691              TEMPZ2(K)=Y3(I)
1692            ENDIF
1693 1011     CONTINUE
1694          NS2=K
1695C
1696          IF(NS2.LT.1)THEN
1697            WRITE(ICOUT,999)
1698            CALL DPWRST('XXX','BUG ')
1699            WRITE(ICOUT,1081)
1700 1081       FORMAT('***** INTERNAL ERROR IN DPMOS2--')
1701            CALL DPWRST('XXX','BUG ')
1702            WRITE(ICOUT,1082)
1703 1082       FORMAT('      NS FOR SOME CLASS = 0')
1704            CALL DPWRST('XXX','BUG ')
1705            WRITE(ICOUT,1083)ISET,XIDTEM(ISET),NS
1706 1083       FORMAT('     ISET,XIDTEM(ISET),NS = ',I8,G15.7,I8)
1707            CALL DPWRST('XXX','BUG ')
1708            IERROR='YES'
1709            GOTO9000
1710          ENDIF
1711C
1712        ENDIF
1713C
1714C       FOR MOVING STATISTIC, USE STATISTIC FOR FULL DATA
1715C       FOR THE CURRENT GROUP AS THE REFERENCE LINE.  FOR THE
1716C       CUMULATIVE STATISTIC AND WINDOW STATISTIC, USE THE AVERAGE
1717C       VALUE OF THE STATISTIC.
1718C
1719        IF(ICASPL.EQ.'MOSP')THEN
1720C
1721          ISTEPN='2A'
1722          IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'MOS2')
1723     1       CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1724C
1725          CALL MOVSTA(TEMP,TEMPZ,TEMPZ2,NS2,ISTANR,ICASS7,MAXOBV,
1726     1                ISEED,IQUAME,IQUASE,PSTAMV,
1727     1                IMOVEP,IMOVDI,IFILWI,
1728     1                XTEMP1,XTEMP2,XTEMP3,
1729     1                ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
1730     1                DTEMP1,DTEMP2,DTEMP3,
1731     1                YOUT,NOUT,
1732     1                ISUBRO,IBUGG3,IERROR)
1733C
1734          ISTEPN='2B'
1735          IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'MOS2')
1736     1       CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1737C
1738          CALL CMPSTA(TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,MAXOBV,
1739     1                NS2,NS2,NS2,ISTANR,ICASS7,ISEED,
1740     1                ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
1741     1                DTEMP1,DTEMP2,DTEMP3,
1742     1                RIGHT,
1743     1                ISUBRO,IBUGG3,IERROR)
1744C
1745        ELSEIF(ICASPL.EQ.'CUSP')THEN
1746C
1747          ISTEPN='2C'
1748          IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'MOS2')
1749     1       CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1750C
1751          CALL CUMSTA(TEMP,TEMPZ,TEMPZ2,NS2,ISTANR,ICASS7,MAXOBV,
1752     1                ISEED,ICSTSV,
1753     1                XTEMP1,XTEMP2,XTEMP3,
1754     1                ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
1755     1                DTEMP1,DTEMP2,DTEMP3,
1756     1                YOUT,NOUT,
1757     1                ISUBRO,IBUGG3,IERROR)
1758C
1759          ISTEPN='2D'
1760          IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'MOS2')
1761     1       CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1762C
1763          CALL MEAN(YOUT,NOUT,IWRITE,RIGHT,IBUGG3,IERROR)
1764C
1765        ELSEIF(ICASPL.EQ.'WISP')THEN
1766C
1767          ISTEPN='2C'
1768          IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'MOS2')
1769     1       CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1770C
1771          CALL WINSTA(TEMP,TEMPZ,TEMPZ2,NS2,ISTANR,ICASS7,MAXOBV,
1772     1                ISEED,NSIZE,
1773     1                XTEMP1,XTEMP2,XTEMP3,
1774     1                ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
1775     1                DTEMP1,DTEMP2,DTEMP3,
1776     1                YOUT,NOUT,
1777     1                ISUBRO,IBUGG3,IERROR)
1778C
1779          ISTEPN='2D'
1780          IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'MOS2')
1781     1       CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1782C
1783          CALL MEAN(YOUT,NOUT,IWRITE,RIGHT,IBUGG3,IERROR)
1784C
1785        ENDIF
1786C
1787        ITAG=ITAG+1
1788        DO1110K=1,NOUT
1789          NPLOTP=NPLOTP+1
1790          IXSTRT=ISTRT+ISKIP+K
1791          X(NPLOTP)=REAL(IXSTRT)
1792          Y(NPLOTP)=YOUT(K)
1793          D(NPLOTP)=REAL(ITAG)
1794 1110   CONTINUE
1795C
1796        IF(IMOVGR.EQ.'STAC' .AND. NUMSET.GT.1)GOTO1119
1797        ITAG=ITAG+1
1798        NPLOTP=NPLOTP+1
1799        X(NPLOTP)=REAL(ISTRT+ISKIP+1)
1800        Y(NPLOTP)=RIGHT
1801        D(NPLOTP)=REAL(ITAG)
1802        IF(ICASPL.EQ.'WISP')THEN
1803          NPLOTP=NPLOTP+1
1804          X(NPLOTP)=REAL(ISTRT+NOUT)
1805          Y(NPLOTP)=RIGHT
1806          D(NPLOTP)=REAL(ITAG)
1807        ELSE
1808          NPLOTP=NPLOTP+1
1809          X(NPLOTP)=REAL(ISTRT+ISKIP+NOUT-1)
1810          Y(NPLOTP)=RIGHT
1811          D(NPLOTP)=REAL(ITAG)
1812        ENDIF
1813 1119   CONTINUE
1814C
1815        IF(IMOVGR.EQ.'DEFA')THEN
1816          ISTRT=ISTRT+NS2
1817        ELSE
1818          ISTRT=0
1819        ENDIF
1820C
1821 1000 CONTINUE
1822C
1823      NPLOTV=3
1824C
1825C               ******************
1826C               **   STEP 90--  **
1827C               **   EXIT       **
1828C               ******************
1829C
1830 9000 CONTINUE
1831      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'MOS2')THEN
1832        WRITE(ICOUT,999)
1833        CALL DPWRST('XXX','BUG ')
1834        WRITE(ICOUT,9011)
1835 9011   FORMAT('***** AT THE END       OF DPMOS2--')
1836        CALL DPWRST('XXX','BUG ')
1837        WRITE(ICOUT,9012)IERROR,NPLOTP
1838 9012   FORMAT('IERROR,NPLOTP = ',A4,2X,I8)
1839        CALL DPWRST('XXX','BUG ')
1840        WRITE(ICOUT,9013)ICASPL,N,NUMSET,N2,IERROR
1841 9013   FORMAT('ICASPL,N,NUMSET,N2,IERROR = ',A4,3I8,2X,A4)
1842        CALL DPWRST('XXX','BUG ')
1843        DO9020I=1,NPLOTP
1844          WRITE(ICOUT,9021)I,Y(I),X(I),D(I)
1845 9021     FORMAT('I,Y(I),X(I),D(I) = ',I8,3G15.7)
1846          CALL DPWRST('XXX','BUG ')
1847 9020   CONTINUE
1848      ENDIF
1849C
1850      RETURN
1851      END
1852      SUBROUTINE DPMOV2(X1,Y1,
1853     1                  IFIG,ILINPA,ILINCO,PLINTH,
1854     1                  AREGBA,IREBLI,IREBCO,PREBTH,
1855     1                  IREFSW,IREFCO,
1856     1                  IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
1857     1                  PTEXHE,PTEXWI,PTEXVG,PTEXHG)
1858C
1859C     PURPOSE--MOVE TO A POINT WITH THE COORDINATES (X1,Y1)
1860C     WRITTEN BY--JAMES J. FILLIBEN
1861C                 STATISTICAL ENGINEERING DIVISION
1862C                 INFORMATION TECHNOLOGY LABORATORY
1863C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
1864C                 GAITHERSBURG, MD 20899-8980
1865C                 PHONE--301-975-2855
1866C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
1867C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
1868C     LANGUAGE--ANSI FORTRAN (1977)
1869C     VERSION NUMBER--82/7
1870C     ORIGINAL VERSION--APRIL     1981.
1871C     UPDATED         --MAY       1982.
1872C     UPDATED         --JANUARY   1989.  MODIFY CALLS TO DPDRPL (ALAN)
1873C     UPDATED         --JANUARY   1989.  MODIFY CALL  TO DPFIRE (ALAN)
1874C
1875C-----NON-COMMON VARIABLES-------------------------------------
1876C
1877      CHARACTER*4 IFIG
1878      CHARACTER*4 IPATT2
1879C
1880      CHARACTER*4 ILINPA
1881      CHARACTER*4 ILINCO
1882C
1883      CHARACTER*4 IREBLI
1884      CHARACTER*4 IREBCO
1885      CHARACTER*4 IREFSW
1886      CHARACTER*4 IREFCO
1887      CHARACTER*4 IREPTY
1888      CHARACTER*4 IREPLI
1889      CHARACTER*4 IREPCO
1890C
1891      CHARACTER*4 IPATT
1892      CHARACTER*4 ICOLF
1893      CHARACTER*4 ICOLP
1894      CHARACTER*4 ICOL
1895      CHARACTER*4 IFLAG
1896C
1897      DIMENSION PX(10)
1898      DIMENSION PY(10)
1899CCCCC DIMENSION PX3(10)
1900CCCCC DIMENSION PY3(10)
1901C
1902      DIMENSION ILINPA(*)
1903      DIMENSION ILINCO(*)
1904      DIMENSION PLINTH(*)
1905C
1906      DIMENSION AREGBA(*)
1907      DIMENSION IREBLI(*)
1908      DIMENSION IREBCO(*)
1909      DIMENSION PREBTH(*)
1910      DIMENSION IREFSW(*)
1911      DIMENSION IREFCO(*)
1912      DIMENSION IREPTY(*)
1913      DIMENSION IREPLI(*)
1914      DIMENSION IREPCO(*)
1915      DIMENSION PREPTH(*)
1916      DIMENSION PREPSP(*)
1917C
1918C-----COMMON----------------------------------------------------------
1919C
1920      INCLUDE 'DPCOGR.INC'
1921      INCLUDE 'DPCOBE.INC'
1922      INCLUDE 'DPCOP2.INC'
1923C
1924C-----START POINT-----------------------------------------------------
1925C
1926      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'MOV2')THEN
1927        WRITE(ICOUT,999)
1928  999   FORMAT(1X)
1929        CALL DPWRST('XXX','BUG ')
1930        WRITE(ICOUT,51)
1931   51   FORMAT('***** AT THE BEGINNING OF DPMOV2--')
1932        CALL DPWRST('XXX','BUG ')
1933        WRITE(ICOUT,53)X1,Y1,IFIG
1934   53   FORMAT('X1,Y1,IFIG = ',2G15.7,2X,A4)
1935        CALL DPWRST('XXX','BUG ')
1936        WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1),AREGBA(1)
1937   61   FORMAT('ILINPA(1),ILINCO(1),PLINTH(1),AREGBA(1) = ',
1938     1         2(A4,2X),2G15.7)
1939        CALL DPWRST('XXX','BUG ')
1940        WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1)
1941   63   FORMAT('IREBLI(1),IREBCO(1),PREBTH(1) = ',2(A4,2X),G15.7)
1942        CALL DPWRST('XXX','BUG ')
1943        WRITE(ICOUT,64)IREFSW(1),IREFCO(1)
1944   64   FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4)
1945        CALL DPWRST('XXX','BUG ')
1946        WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1)
1947   65   FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ',
1948     1         3(A4,2X),2G15.7)
1949        CALL DPWRST('XXX','BUG ')
1950        WRITE(ICOUT,69)PTEXHE,PTEXWI,PTEXVG,PTEXHG
1951   69   FORMAT('PTEXHE,PTEXWI,PTEXVG,PTEXHG= ',4G15.7)
1952        CALL DPWRST('XXX','BUG ')
1953        WRITE(ICOUT,79)IBUGG4,ISUBG4,IERRG4
1954   79   FORMAT('IBUGG4,ISUBG4,IERRG4 = ',2(A4,2X),A4)
1955        CALL DPWRST('XXX','BUG ')
1956      ENDIF
1957C
1958C               *********************************
1959C               **  STEP 1--                   **
1960C               **  DETERMINE THE COORDINATES  **
1961C               **  FOR THE POINT              **
1962C               *********************************
1963C
1964      PX(1)=X1
1965      PY(1)=Y1
1966C
1967      NP=1
1968C
1969C               ***********************
1970C               **  STEP 2--         **
1971C               **  FILL THE FIGURE  **
1972C               **  (IF CALLED FOR)  **
1973C               ***********************
1974C
1975      IF(IREFSW(1).EQ.'ON')THEN
1976        IPATT=IREPTY(1)
1977        IPATT2='SOLI'
1978        PTHICK=PREPTH(1)
1979        PXGAP=PREPSP(1)
1980        PYGAP=PREPSP(1)
1981        ICOLF=IREFCO(1)
1982        ICOLP=IREPCO(1)
1983        CALL DPFIRE(PX,PY,NP,
1984     1              IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,IPATT2)
1985      ENDIF
1986C
1987C               ***************************
1988C               **  STEP 3--             **
1989C               **  DRAW OUT THE FIGURE  **
1990C               ***************************
1991C
1992      IPATT=ILINPA(1)
1993      PTHICK=PLINTH(1)
1994      ICOL=ILINCO(1)
1995      IFLAG='ON'
1996      CALL DPDRPL(PX,PY,NP,
1997     1            IFIG,IPATT,PTHICK,ICOL,
1998     1            JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
1999C
2000C               *****************
2001C               **  STEP 90--  **
2002C               **  EXIT       **
2003C               *****************
2004C
2005      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'MOV2')THEN
2006        WRITE(ICOUT,999)
2007        CALL DPWRST('XXX','BUG ')
2008        WRITE(ICOUT,9011)
2009 9011   FORMAT('***** AT THE END       OF DPMOV2--')
2010        CALL DPWRST('XXX','BUG ')
2011        WRITE(ICOUT,9013)NP
2012 9013   FORMAT('NP = ',I8)
2013        CALL DPWRST('XXX','BUG ')
2014        DO9015I=1,NP
2015          WRITE(ICOUT,9016)I,PX(I),PY(I)
2016 9016     FORMAT('I,PX(I),PY(I) = ',I8,2E15.7)
2017          CALL DPWRST('XXX','BUG ')
2018 9015   CONTINUE
2019        WRITE(ICOUT,9039)IBUGG4,ISUBG4,IERRG4
2020 9039   FORMAT('IBUGG4,ISUBG4,IERRG4 = ',2(A4,2X),A4)
2021        CALL DPWRST('XXX','BUG ')
2022      ENDIF
2023C
2024      RETURN
2025      END
2026      SUBROUTINE DPMOVE(IHARG,IARGT,ARG,NUMARG,PXSTAR,PYSTAR,
2027     1                  PXEND,PYEND,
2028     1                  ILINPA,ILINCO,PLINTH,
2029     1                  AREGBA,IREBLI,IREBCO,PREBTH,
2030     1                  IREFSW,IREFCO,
2031     1                  IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
2032     1                  PTEXHE,PTEXWI,PTEXVG,PTEXHG,
2033     1                  IGRASW,IDIASW,
2034     1                  PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
2035     1                  PDIAHE,PDIAWI,PDIAVG,PDIAHG,
2036     1                  NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
2037     1                  IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
2038     1                  IDNVOF,IDNHOF,IDFONT,PDSCAL,
2039     1                  X1UNIT,Y1UNIT,
2040     1                  IBUGD2,IFOUND,IERROR)
2041C
2042C     PURPOSE--MOVE TO ONE OR MORE POINTS (DEPENDING ON HOW MANY NUMBERS
2043C              ARE PROVIDED).  THE COORDINATES ARE IN STANDARDIZED UNITS
2044C              OF 0 TO 100.
2045C     NOTE--THE INPUT COORDINATES DEFINE THE POINT.
2046C     NOTE-THE USUAL INPUT NUMBER OF COORDINATES IS 1
2047C          AND THEREFORE THE USUAL INPUT NUMBER OF NUMBERS IS 2*1 = 2.
2048C     NOTE--IF NO NUMBERS ARE PROVIDED, THEN THE POINT MOVED TO WILL BE
2049C           AT THE LAST CURSOR POSITION
2050C     NOTE--IF 2 NUMBERS ARE PROVIDED, THEN THE POINT MOVED TO WILL BE
2051C           AT THE ABSOLUTE (X,Y) POSITION AS DEFINED BY THE 2 NUMBERS
2052C     NOTE--AND SO FORTH FOR 2, 3, 4, ... NUMBERS.
2053C     INPUT  ARGUMENTS--IHARG
2054C                     --IARGT
2055C                     --ARG
2056C                     --NUMARG
2057C                     --PXSTAR
2058C                     --PYSTAR
2059C     OUTPUT ARGUMENTS--PXEND
2060C                     --PYEND
2061C                     --IFOUND ('YES' OR 'NO' )
2062C                     --IERROR ('YES' OR 'NO' )
2063C     WRITTEN BY--JAMES J. FILLIBEN
2064C                 STATISTICAL ENGINEERING DIVISION
2065C                 INFORMATION TECHNOLOGY LABORATORY
2066C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
2067C                 GAITHERSBURG, MD 20899-8980
2068C                 PHONE--301-975-2855
2069C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
2070C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
2071C     LANGUAGE--ANSI FORTRAN (1977)
2072C     VERSION NUMBER--82/7
2073C     ORIGINAL VERSION--APRIL     1981.
2074C     UPDATED         --MARCH     1982.
2075C     UPDATED         --MAY       1982.
2076C     UPDATED         --NOVEMBER  1982.
2077C     UPDATED         --JANUARY   1989. CALL LIST FOR OFFSET VAR (ALAN)
2078C     UPDATED         --NOVEMBER  1992. UNITS SWITCH (DATA OR SCREEN)
2079C     UPDATED         --SEPTEMBER 1993. DECLARE DUMMY   ISUBRO
2080C     UPDATED         --SEPTEMBER 1993. FIX BUG FORMAT STATEMENT
2081C     UPDATED         --FEBRUARY  1995. GENERALIZED MOVE.... COMMAND
2082C     UPDATED         --MARCH     1997. SUPPORT FOR DEVICE FONT (ALAN)
2083C     UPDATED         --SEPTEMBER 2009. FIX BUG WITH "RELATIVE" OPTION
2084C     UPDATED         --DECEMBER  2018. CHECK FOR DISCRETE, NULL, OR
2085C                                       NONE DEVICE
2086C     UPDATED         --DECEMBER  2018. SUPPORT FOR "DEVICE ... SCALE"
2087C                                       COMMAND
2088C
2089C-----NON-COMMON VARIABLES-----------------------------------------
2090C
2091      CHARACTER*4 IHARG
2092      CHARACTER*4 IARGT
2093C
2094      CHARACTER*4 ILINPA
2095      CHARACTER*4 ILINCO
2096C
2097      CHARACTER*4 IREBLI
2098      CHARACTER*4 IREBCO
2099      CHARACTER*4 IREFSW
2100      CHARACTER*4 IREFCO
2101      CHARACTER*4 IREPTY
2102      CHARACTER*4 IREPLI
2103      CHARACTER*4 IREPCO
2104C
2105      CHARACTER*4 IGRASW
2106      CHARACTER*4 IDIASW
2107C
2108      CHARACTER*4 IDMANU
2109      CHARACTER*4 IDMODE
2110      CHARACTER*4 IDMOD2
2111      CHARACTER*4 IDMOD3
2112      CHARACTER*4 IDPOWE
2113      CHARACTER*4 IDCONT
2114      CHARACTER*4 IDCOLO
2115CCCCC ADD FOLLOWING LINE MARCH 1997.
2116      CHARACTER*4 IDFONT
2117C
2118      CHARACTER*4 IFOUND
2119      CHARACTER*4 IBUGD2
2120      CHARACTER*4 IERROR
2121C
2122      CHARACTER*4 ISUBRO
2123      CHARACTER*4 IFIG
2124      CHARACTER*4 IBELSW
2125      CHARACTER*4 IERASW
2126      CHARACTER*4 IBACCO
2127      CHARACTER*4 ICOPSW
2128      CHARACTER*4 ITYPEO
2129      CHARACTER*4 X1UNIT
2130      CHARACTER*4 Y1UNIT
2131C
2132      DIMENSION IHARG(*)
2133      DIMENSION IARGT(*)
2134      DIMENSION ARG(*)
2135C
2136      DIMENSION ILINPA(*)
2137      DIMENSION ILINCO(*)
2138      DIMENSION PLINTH(*)
2139C
2140      DIMENSION AREGBA(*)
2141      DIMENSION IREBLI(*)
2142      DIMENSION IREBCO(*)
2143      DIMENSION PREBTH(*)
2144      DIMENSION IREFSW(*)
2145      DIMENSION IREFCO(*)
2146      DIMENSION IREPTY(*)
2147      DIMENSION IREPLI(*)
2148      DIMENSION IREPCO(*)
2149      DIMENSION PREPTH(*)
2150      DIMENSION PREPSP(*)
2151      DIMENSION PDSCAL(*)
2152C
2153      DIMENSION IDMANU(*)
2154      DIMENSION IDMODE(*)
2155      DIMENSION IDMOD2(*)
2156      DIMENSION IDMOD3(*)
2157      DIMENSION IDPOWE(*)
2158      DIMENSION IDCONT(*)
2159      DIMENSION IDCOLO(*)
2160CCCCC ADD FOLLOWING LINE MARCH 1997.
2161      DIMENSION IDFONT(*)
2162      DIMENSION IDNVPP(*)
2163      DIMENSION IDNHPP(*)
2164      DIMENSION IDUNIT(*)
2165C
2166      DIMENSION IDNVOF(*)
2167      DIMENSION IDNHOF(*)
2168C
2169C-----COMMON----------------------------------------------------------
2170C
2171      INCLUDE 'DPCOGR.INC'
2172      INCLUDE 'DPCOBE.INC'
2173      INCLUDE 'DPCOP2.INC'
2174C
2175C-----START POINT-----------------------------------------------------
2176C
2177      IFOUND='NO'
2178      IERROR='NO'
2179      IERRG4=IERROR
2180      ISUBRO='DUMM'
2181C
2182      ILOCFN=0
2183      NUMNUM=0
2184      X1=0.0
2185      Y1=0.0
2186      X2=0.0
2187      Y2=0.0
2188C
2189      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'MOVE'.OR.IBUGD2.EQ.'ON')THEN
2190        WRITE(ICOUT,999)
2191  999   FORMAT(1X)
2192        CALL DPWRST('XXX','BUG ')
2193        WRITE(ICOUT,51)
2194   51   FORMAT('***** AT THE BEGINNING OF DPMOVE--')
2195        CALL DPWRST('XXX','BUG ')
2196        WRITE(ICOUT,53)NUMARG
2197   53   FORMAT('NUMARG = ',I8)
2198        CALL DPWRST('XXX','BUG ')
2199        DO55I=1,NUMARG
2200          WRITE(ICOUT,56)I,IHARG(I),IARGT(I),ARG(I)
2201   56     FORMAT('I,IHARG(I),IARGT(I),ARG(I) = ',I8,2X,A4,2X,A4,E15.7)
2202          CALL DPWRST('XXX','BUG ')
2203   55   CONTINUE
2204        WRITE(ICOUT,57)PXSTAR,PYSTAR,PXEND,PYEND
2205   57   FORMAT('PXSTAR,PYSTAR,PXEND,PYEND = ',4G15.7)
2206        CALL DPWRST('XXX','BUG ')
2207        WRITE(ICOUT,69)PTEXHE,PTEXWI
2208   69   FORMAT('PTEXHE,PTEXWI= ',2E15.7)
2209        CALL DPWRST('XXX','BUG ')
2210        WRITE(ICOUT,70)PTEXVG,PTEXHG
2211   70   FORMAT('PTEXVG,PTEXHG= ',2E15.6)
2212        CALL DPWRST('XXX','BUG ')
2213        WRITE(ICOUT,76)IGRASW,IDIASW
2214   76   FORMAT('IGRASW,IDIASW = ',A4,2X,A4)
2215        CALL DPWRST('XXX','BUG ')
2216        WRITE(ICOUT,77)PGRAXF,PGRAYF,PDIAXC,PDIAYC
2217   77   FORMAT('PGRAXF,PGRAYF,PDIAXC,PDIAYC = ',4E15.7)
2218        CALL DPWRST('XXX','BUG ')
2219        WRITE(ICOUT,78)PDIAHE,PDIAWI,PDIAVG,PDIAHG
2220   78   FORMAT('PDIAHE,PDIAWI,PDIAVG,PDIAHG = ',4E15.7)
2221        CALL DPWRST('XXX','BUG ')
2222        WRITE(ICOUT,80)NUMDEV
2223   80   FORMAT('NUMDEV= ',I8)
2224        CALL DPWRST('XXX','BUG ')
2225        DO81I=1,NUMDEV
2226          WRITE(ICOUT,82)IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I)
2227   82     FORMAT('IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I) = ',
2228     1           A4,2X,A4,2X,A4,2X,A4)
2229          CALL DPWRST('XXX','BUG ')
2230          WRITE(ICOUT,83)IDPOWE(I),IDCONT(I),IDCOLO(I)
2231   83     FORMAT('IDPOWE(I),IDCONT(I),IDCOLO(I) = ',
2232     1           A4,2X,A4,2X,A4)
2233          CALL DPWRST('XXX','BUG ')
2234          WRITE(ICOUT,84)IDNVPP(I),IDNHPP(I),IDUNIT(I)
2235   84     FORMAT('IDNVPP(I),IDNHPP(I),IDUNIT(I) = ',
2236     1           I8,I8,I8)
2237          CALL DPWRST('XXX','BUG ')
2238   81   CONTINUE
2239        WRITE(ICOUT,85)X1UNIT,Y1UNIT
2240   85   FORMAT('X1UNIT, Y1UNIT = ',2A4)
2241        CALL DPWRST('XXX','BUG ')
2242        WRITE(ICOUT,87)IFOUND,IERROR
2243   87   FORMAT('IFOUND,IERROR= ',A4,2X,A4)
2244        CALL DPWRST('XXX','BUG ')
2245        WRITE(ICOUT,88)IBUGG4,ISUBG4,IERRG4,IBUGD2
2246   88   FORMAT('IBUGG4,ISUBG4,IERRG4,IBUGD2 = ',3(A4,2X),A4)
2247        CALL DPWRST('XXX','BUG ')
2248      ENDIF
2249C
2250      IFIG='POIN'
2251      NUMPT=1
2252      NUMPT2=2*NUMPT
2253C
2254C               ********************************
2255C               **  STEP 0--                  **
2256C               **  STEP THROUGH EACH DEVICE  **
2257C               ********************************
2258C
2259      IF(NUMDEV.LE.0)GOTO9000
2260      DO8000IDEVIC=1,NUMDEV
2261C
2262        IF(IDPOWE(IDEVIC).EQ.'OFF')GOTO8000
2263        IF(IDMANU(IDEVIC).EQ.'OFF')GOTO8000
2264        IF(IDMANU(IDEVIC).EQ.'NULL')GOTO8000
2265        IF(IDMANU(IDEVIC).EQ.'NONE')GOTO8000
2266        IF(IDMANU(IDEVIC).EQ.'DISC')GOTO8000
2267C
2268        IMANUF=IDMANU(IDEVIC)
2269        IMODEL=IDMODE(IDEVIC)
2270        IMODE2=IDMOD2(IDEVIC)
2271        IMODE3=IDMOD3(IDEVIC)
2272        IGCONT=IDCONT(IDEVIC)
2273        IGCOLO=IDCOLO(IDEVIC)
2274        IGFONT=IDFONT(IDEVIC)
2275        NUMVPP=IDNVPP(IDEVIC)
2276        NUMHPP=IDNHPP(IDEVIC)
2277        ANUMVP=NUMVPP
2278        ANUMHP=NUMHPP
2279        IOFFSV=IDNVOF(IDEVIC)
2280        IOFFSH=IDNHOF(IDEVIC)
2281        IGUNIT=IDUNIT(IDEVIC)
2282        PCHSCA=PDSCAL(IDEVIC)
2283C
2284C               ************************************
2285C               **  STEP 1--                      **
2286C               **  CARRY OUT OPENING OPERATIONS  **
2287C               **  ON THE GRAPHICS DEVICES       **
2288C               ************************************
2289C
2290        CALL DPOPDE
2291C
2292        IBELSW='OFF'
2293        NUMRIN=0
2294        IERASW='OFF'
2295        IBACCO='JUNK'
2296C
2297        CALL DPOPPL(IGRASW,
2298     1              IBELSW,NUMRIN,IERASW,
2299     1              IBACCO)
2300C
2301C               *****************************************
2302C               **  STEP 2--                           **
2303C               **  SEARCH FOR COMMAND SPECIFICATIONS  **
2304C               *****************************************
2305C
2306        IF(NUMARG.GE.2.AND.
2307     1     IARGT(1).EQ.'NUMB'.AND.IARGT(2).EQ.'NUMB')THEN
2308           ITYPEO='ABSO'
2309           ILOCFN=1
2310        ELSEIF(NUMARG.GE.3.AND.IHARG(1).EQ.'ABSO'.AND.
2311     1     IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB')THEN
2312           ITYPEO='ABSO'
2313           ILOCFN=2
2314        ELSEIF(NUMARG.GE.3.AND.IHARG(1).EQ.'RELA'.AND.
2315     1     IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB')THEN
2316           ITYPEO='RELA'
2317           ILOCFN=2
2318        ELSE
2319          GOTO1130
2320        ENDIF
2321C
2322        IF(ILOCFN.LE.NUMARG)THEN
2323          DO1120I=ILOCFN,NUMARG
2324            IF(IARGT(I).NE.'NUMB')GOTO1130
2325 1120     CONTINUE
2326          IFOUND='YES'
2327          GOTO1149
2328        ENDIF
2329C
2330 1130   CONTINUE
2331        IERRG4='YES'
2332        WRITE(ICOUT,1131)
2333 1131   FORMAT('***** ERROR IN MOVE COMMAND--')
2334        CALL DPWRST('XXX','BUG ')
2335        WRITE(ICOUT,1132)
2336 1132   FORMAT('      ILLEGAL FORM FOR THE MOVE COMMAND.')
2337        CALL DPWRST('XXX','BUG ')
2338        WRITE(ICOUT,1134)
2339 1134   FORMAT('      TEST EXAMPLE TO DEMONSTRATE THE PROPER FORM--')
2340        CALL DPWRST('XXX','BUG ')
2341        WRITE(ICOUT,1135)
2342 1135   FORMAT('      SUPPOSE IT IS DESIRED TO SET THE CURRENT ',
2343     1         'POSITION')
2344        CALL DPWRST('XXX','BUG ')
2345        WRITE(ICOUT,1136)
2346 1136   FORMAT('      TO 20 20, THEN THE ALLOWABLE FORMS ARE--')
2347        CALL DPWRST('XXX','BUG ')
2348        WRITE(ICOUT,1142)
2349 1142   FORMAT('      MOVE 20 20 ')
2350        CALL DPWRST('XXX','BUG ')
2351        WRITE(ICOUT,1143)
2352 1143   FORMAT('      MOVE ABSOLUTE 20 20 ')
2353        CALL DPWRST('XXX','BUG ')
2354        GOTO9000
2355C
2356 1149   CONTINUE
2357C
2358C               ****************************
2359C               **  STEP 3--              **
2360C               **  MOVE TO THE POINT(S)  **
2361C               ****************************
2362C
2363        NUMNUM=NUMARG-ILOCFN+1
2364        IF(NUMNUM.LT.NUMPT2)THEN
2365          J=ILOCFN-1
2366          X1=PXSTAR
2367          Y1=PYSTAR
2368          GOTO1170
2369        ELSE
2370          J=ILOCFN-1
2371          X1=PXSTAR
2372          Y1=PYSTAR
2373          GOTO1160
2374        ENDIF
2375C
2376 1160   CONTINUE
2377        J=J+1
2378        IF(J.GT.NUMARG)GOTO1190
2379        X2=ARG(J)
2380        IF(X1UNIT.EQ.'DATA')CALL DPCODS('X',X2,X2,IBUGD2,ISUBRO,IERROR)
2381        IF(ITYPEO.EQ.'RELA')X2=X1+X2
2382        J=J+1
2383        IF(J.GT.NUMARG)GOTO1190
2384        Y2=ARG(J)
2385        IF(Y1UNIT.EQ.'DATA')CALL DPCODS('Y',Y2,Y2,IBUGD2,ISUBRO,IERROR)
2386        IF(ITYPEO.EQ.'RELA')Y2=Y1+Y2
2387        X1=X2
2388        Y1=Y2
2389C
2390 1170   CONTINUE
2391        CALL DPMOV2(X1,Y1,
2392     1              IFIG,
2393     1              ILINPA,ILINCO,PLINTH,
2394     1              AREGBA,
2395     1              IREBLI,IREBCO,PREBTH,
2396     1              IREFSW,IREFCO,
2397     1              IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
2398     1              PTEXHE,PTEXWI,PTEXVG,PTEXHG)
2399C
2400        X1=X1
2401        Y1=Y1
2402C
2403        GOTO1160
2404 1190   CONTINUE
2405C
2406        PXEND=X1
2407        PYEND=Y1
2408C
2409C               ************************************
2410C               **  STEP 4--                      **
2411C               **  CARRY OUT CLOSING OPERATIONS  **
2412C               **  ON THE GRAPHICS DEVICES       **
2413C               ************************************
2414C
2415        ICOPSW='OFF'
2416        NUMCOP=0
2417        CALL DPCLPL(ICOPSW,NUMCOP,
2418     1              PGRAXF,PGRAYF,
2419     1              IGRASW,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
2420     1              PDIAHE,PDIAWI,PDIAVG,PDIAHG)
2421C
2422        CALL DPCLDE
2423C
2424 8000 CONTINUE
2425C
2426C               *****************
2427C               **  STEP 90--  **
2428C               **  EXIT       **
2429C               *****************
2430C
2431 9000 CONTINUE
2432      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'MOVE'.OR.IBUGD2.EQ.'ON')THEN
2433        WRITE(ICOUT,999)
2434        CALL DPWRST('XXX','BUG ')
2435        WRITE(ICOUT,9011)
2436 9011   FORMAT('***** AT THE END       OF DPMOVE--')
2437        CALL DPWRST('XXX','BUG ')
2438        WRITE(ICOUT,9012)ILOCFN,NUMNUM
2439 9012   FORMAT('ILOCFN,NUMNUM = ',2I8)
2440        CALL DPWRST('XXX','BUG ')
2441        WRITE(ICOUT,9013)X1,Y1
2442 9013   FORMAT('X1,Y1 = ',2E15.7)
2443        CALL DPWRST('XXX','BUG ')
2444        WRITE(ICOUT,9015)PXSTAR,PYSTAR,PXEND,PYEND
2445 9015   FORMAT('PXSTAR,PYSTAR,PXEND,PYEND = ',4G15.7)
2446        CALL DPWRST('XXX','BUG ')
2447        WRITE(ICOUT,9017)IFIG,IFOUND,IERROR
2448 9017   FORMAT('IFIG,IFOUND,IERROR = ',2(A4,2X),A4)
2449        CALL DPWRST('XXX','BUG ')
2450      ENDIF
2451C
2452      RETURN
2453      END
2454      SUBROUTINE DPMPCO(IHARG,NUMARG,IDEMPC,MAXMAR,IMAPCO,
2455     1IBUGP2,IFOUND,IERROR)
2456C
2457C     PURPOSE--DEFINE THE MARKER PATTERN COLORS = THE COLORS
2458C              OF THE LINES MAKING UP A PATTERN WITHIN A MARKER.
2459C              THESE ARE LOCATED IN THE VECTOR IMAPCO(.).
2460C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
2461C                     --NUMARG
2462C                     --IDEMPC
2463C                     --MAXMAR
2464C                     --IBUGP2 ('ON' OR 'OFF' )
2465C     OUTPUT ARGUMENTS--IMAPCO (A CHARACTER VECTOR)
2466C                     --IFOUND ('YES' OR 'NO' )
2467C                     --IERROR ('YES' OR 'NO' )
2468C     WRITTEN BY--JAMES J. FILLIBEN
2469C                 STATISTICAL ENGINEERING DIVISION
2470C                 INFORMATION TECHNOLOGY LABORATORY
2471C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
2472C                 GAITHERSBURG, MD 20899-8980
2473C                 PHONE--301-975-2855
2474C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
2475C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
2476C     LANGUAGE--ANSI FORTRAN (1977)
2477C     VERSION NUMBER--82/7
2478C     ORIGINAL VERSION--DECEMBER  1983.
2479C
2480C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
2481C
2482      CHARACTER*4 IHARG
2483      CHARACTER*4 IDEMPC
2484      CHARACTER*4 IMAPCO
2485C
2486      CHARACTER*4 IBUGP2
2487      CHARACTER*4 IFOUND
2488      CHARACTER*4 IERROR
2489C
2490      CHARACTER*4 IHOLD1
2491      CHARACTER*4 IHOLD2
2492C
2493      CHARACTER*4 ISUBN1
2494      CHARACTER*4 ISUBN2
2495      CHARACTER*4 ISTEPN
2496C
2497      DIMENSION IHARG(*)
2498      DIMENSION IMAPCO(*)
2499C
2500C---------------------------------------------------------------------
2501C
2502      INCLUDE 'DPCOP2.INC'
2503C
2504C-----START POINT-----------------------------------------------------
2505C
2506      IFOUND='NO'
2507      IERROR='NO'
2508      ISUBN1='DPMP'
2509      ISUBN2='CO  '
2510C
2511      NUMMAR=0
2512      IHOLD1='-999'
2513      IHOLD2='-999'
2514C
2515      IF(IBUGP2.EQ.'OFF')GOTO90
2516      WRITE(ICOUT,999)
2517  999 FORMAT(1X)
2518      CALL DPWRST('XXX','BUG ')
2519      WRITE(ICOUT,51)
2520   51 FORMAT('***** AT THE BEGINNING OF DPMPCO--')
2521      CALL DPWRST('XXX','BUG ')
2522      WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR
2523   52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
2524      CALL DPWRST('XXX','BUG ')
2525      WRITE(ICOUT,53)MAXMAR,NUMMAR
2526   53 FORMAT('MAXMAR,NUMMAR = ',I8,I8)
2527      CALL DPWRST('XXX','BUG ')
2528      WRITE(ICOUT,54)IHOLD1,IHOLD2
2529   54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
2530      CALL DPWRST('XXX','BUG ')
2531      WRITE(ICOUT,55)IDEMPC
2532   55 FORMAT('IDEMPC = ',A4)
2533      CALL DPWRST('XXX','BUG ')
2534      WRITE(ICOUT,60)NUMARG
2535   60 FORMAT('NUMARG = ',I8)
2536      CALL DPWRST('XXX','BUG ')
2537      DO65I=1,NUMARG
2538      WRITE(ICOUT,66)IHARG(I)
2539   66 FORMAT('IHARG(I) = ',A4)
2540      CALL DPWRST('XXX','BUG ')
2541   65 CONTINUE
2542      WRITE(ICOUT,70)IMAPCO(1)
2543   70 FORMAT('IMAPCO(1) = ',A4)
2544      CALL DPWRST('XXX','BUG ')
2545      DO75I=1,10
2546      WRITE(ICOUT,76)I,IMAPCO(I)
2547   76 FORMAT('I,IMAPCO(I) = ',I8,2X,A4)
2548      CALL DPWRST('XXX','BUG ')
2549   75 CONTINUE
2550   90 CONTINUE
2551C
2552C               **************************************
2553C               **  STEP 1--                        **
2554C               **  BRANCH TO THE APPROPRIATE CASE  **
2555C               **************************************
2556C
2557      ISTEPN='1'
2558      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2559C
2560      IF(NUMARG.LE.1)GOTO9000
2561      IF(NUMARG.EQ.2)GOTO1120
2562      IF(NUMARG.EQ.3)GOTO1130
2563      IF(NUMARG.EQ.4)GOTO1140
2564      GOTO1150
2565C
2566 1120 CONTINUE
2567      GOTO1200
2568C
2569 1130 CONTINUE
2570      IF(IHARG(3).EQ.'ALL')IHOLD1='    '
2571      IF(IHARG(3).EQ.'ALL')GOTO1300
2572      GOTO1200
2573C
2574 1140 CONTINUE
2575      IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(4)
2576      IF(IHARG(3).EQ.'ALL')GOTO1300
2577      IF(IHARG(4).EQ.'ALL')IHOLD1=IHARG(3)
2578      IF(IHARG(4).EQ.'ALL')GOTO1300
2579      GOTO1200
2580C
2581 1150 CONTINUE
2582      GOTO1200
2583C
2584C               *************************************************
2585C               **  STEP 2--                                   **
2586C               **  TREAT THE SINGLE      SPECIFICATION  CASE  **
2587C               *************************************************
2588C
2589 1200 CONTINUE
2590      ISTEPN='2'
2591      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2592C
2593      IF(NUMARG.LE.2)GOTO1210
2594      GOTO1220
2595C
2596 1210 CONTINUE
2597      NUMMAR=1
2598      IMAPCO(1)=IDEMPC
2599      GOTO1270
2600C
2601 1220 CONTINUE
2602      NUMMAR=NUMARG-2
2603      IF(NUMMAR.GT.MAXMAR)NUMMAR=MAXMAR
2604      DO1225I=1,NUMMAR
2605      J=I+2
2606      IHOLD1=IHARG(J)
2607      IHOLD2=IHOLD1
2608      IF(IHOLD1.EQ.'ON')IHOLD2=IDEMPC
2609      IF(IHOLD1.EQ.'OFF')IHOLD2=IDEMPC
2610      IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEMPC
2611      IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEMPC
2612      IMAPCO(I)=IHOLD2
2613 1225 CONTINUE
2614      GOTO1270
2615C
2616 1270 CONTINUE
2617      IF(IFEEDB.EQ.'OFF')GOTO1279
2618      WRITE(ICOUT,999)
2619      CALL DPWRST('XXX','BUG ')
2620      DO1278I=1,NUMMAR
2621      WRITE(ICOUT,1276)I,IMAPCO(I)
2622 1276 FORMAT('THE COLOR OF MARKER PATTERN ',I6,
2623     1' HAS JUST BEEN SET TO ',A4)
2624      CALL DPWRST('XXX','BUG ')
2625 1278 CONTINUE
2626 1279 CONTINUE
2627      IFOUND='YES'
2628      GOTO9000
2629C
2630C               **************************
2631C               **  STEP 3--            **
2632C               **  TREAT THE ALL CASE  **
2633C               **************************
2634C
2635 1300 CONTINUE
2636      ISTEPN='3'
2637      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2638C
2639      NUMMAR=MAXMAR
2640      IHOLD2=IHOLD1
2641      IF(IHOLD1.EQ.'ON')IHOLD2=IDEMPC
2642      IF(IHOLD1.EQ.'OFF')IHOLD2=IDEMPC
2643      IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEMPC
2644      IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEMPC
2645      DO1315I=1,NUMMAR
2646      IMAPCO(I)=IHOLD2
2647 1315 CONTINUE
2648      GOTO1370
2649C
2650 1370 CONTINUE
2651      IF(IFEEDB.EQ.'OFF')GOTO1319
2652      WRITE(ICOUT,999)
2653      CALL DPWRST('XXX','BUG ')
2654      I=1
2655      WRITE(ICOUT,1316)IMAPCO(I)
2656 1316 FORMAT('THE COLOR OF ALL MARKER PATTERNS',
2657     1' HAS JUST BEEN SET TO ',A4)
2658      CALL DPWRST('XXX','BUG ')
2659 1319 CONTINUE
2660      IFOUND='YES'
2661      GOTO9000
2662C
2663C               *****************
2664C               **  STEP 90--  **
2665C               **  EXIT       **
2666C               *****************
2667C
2668 9000 CONTINUE
2669      IF(IBUGP2.EQ.'OFF')GOTO9090
2670      WRITE(ICOUT,9011)
2671 9011 FORMAT('***** AT THE END       OF DPMPCO--')
2672      CALL DPWRST('XXX','BUG ')
2673      WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR
2674 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
2675      CALL DPWRST('XXX','BUG ')
2676      WRITE(ICOUT,9013)MAXMAR,NUMMAR
2677 9013 FORMAT('MAXMAR,NUMMAR = ',I8,I8)
2678      CALL DPWRST('XXX','BUG ')
2679      WRITE(ICOUT,9014)IHOLD1,IHOLD2
2680 9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
2681      CALL DPWRST('XXX','BUG ')
2682      WRITE(ICOUT,9015)IDEMPC
2683 9015 FORMAT('IDEMPC = ',A4)
2684      CALL DPWRST('XXX','BUG ')
2685      WRITE(ICOUT,9020)NUMARG
2686 9020 FORMAT('NUMARG = ',I8)
2687      CALL DPWRST('XXX','BUG ')
2688      DO9025I=1,NUMARG
2689      WRITE(ICOUT,9026)IHARG(I)
2690 9026 FORMAT('IHARG(I) = ',A4)
2691      CALL DPWRST('XXX','BUG ')
2692 9025 CONTINUE
2693      WRITE(ICOUT,9030)IMAPCO(1)
2694 9030 FORMAT('IMAPCO(1) = ',A4)
2695      CALL DPWRST('XXX','BUG ')
2696      DO9035I=1,10
2697      WRITE(ICOUT,9036)I,IMAPCO(I)
2698 9036 FORMAT('I,IMAPCO(I) = ',I8,2X,A4)
2699      CALL DPWRST('XXX','BUG ')
2700 9035 CONTINUE
2701 9090 CONTINUE
2702C
2703      RETURN
2704      END
2705      SUBROUTINE DPMPLI(IHARG,IHARG2,NUMARG,IDEMPL,MAXMAR,IMAPLI,
2706CCCCC AUGUST 1995.  ADD IHARG2 FOR DASH2, ETC
2707CCCCC SUBROUTINE DPMPLI(IHARG,NUMARG,IDEMPL,MAXMAR,IMAPLI,
2708     1IBUGP2,IFOUND,IERROR)
2709C
2710C     PURPOSE--DEFINE THE PATTERN LINES = THE LINES TYPES
2711C              OF THE PATTERN WITHIN THE MARKERS.
2712C              THESE ARE LOCATED IN THE VECTOR IMAPLI(.).
2713C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
2714C                     --NUMARG
2715C                     --IDEMPL
2716C                     --MAXMAR
2717C                     --IBUGP2 ('ON' OR 'OFF' )
2718C     OUTPUT ARGUMENTS--IMAPLI (A CHARACTER VECTOR)
2719C                     --IFOUND ('YES' OR 'NO' )
2720C                     --IERROR ('YES' OR 'NO' )
2721C     WRITTEN BY--JAMES J. FILLIBEN
2722C                 STATISTICAL ENGINEERING DIVISION
2723C                 INFORMATION TECHNOLOGY LABORATORY
2724C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
2725C                 GAITHERSBURG, MD 20899-8980
2726C                 PHONE--301-975-2855
2727C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
2728C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
2729C     LANGUAGE--ANSI FORTRAN (1977)
2730C     VERSION NUMBER--82/7
2731C     ORIGINAL VERSION--DECEMBER  1983.
2732C     UPDATED         --AUGUST    1995.  DASH2 BUG
2733C
2734C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
2735C
2736      CHARACTER*4 IHARG
2737CCCCC AUGUST 1995.  ADD FOLLOWING LINE
2738      CHARACTER*4 IHARG2
2739      CHARACTER*4 IDEMPL
2740      CHARACTER*4 IMAPLI
2741C
2742      CHARACTER*4 IBUGP2
2743      CHARACTER*4 IFOUND
2744      CHARACTER*4 IERROR
2745C
2746      CHARACTER*4 IHOLD1
2747      CHARACTER*4 IHOLD2
2748C
2749      CHARACTER*4 ISUBN1
2750      CHARACTER*4 ISUBN2
2751      CHARACTER*4 ISTEPN
2752C
2753      DIMENSION IHARG(*)
2754CCCCC AUGUST 1995.  ADD FOLLOWING LINE
2755      DIMENSION IHARG2(*)
2756      DIMENSION IMAPLI(*)
2757C
2758C---------------------------------------------------------------------
2759C
2760      INCLUDE 'DPCOP2.INC'
2761C
2762C-----START POINT-----------------------------------------------------
2763C
2764      IFOUND='NO'
2765      IERROR='NO'
2766      ISUBN1='DPMP'
2767      ISUBN2='LI  '
2768C
2769      NUMMAR=0
2770      IHOLD1='-999'
2771      IHOLD2='-999'
2772C
2773      IF(IBUGP2.EQ.'OFF')GOTO90
2774      WRITE(ICOUT,999)
2775  999 FORMAT(1X)
2776      CALL DPWRST('XXX','BUG ')
2777      WRITE(ICOUT,51)
2778   51 FORMAT('***** AT THE BEGINNING OF DPMPLI--')
2779      CALL DPWRST('XXX','BUG ')
2780      WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR
2781   52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
2782      CALL DPWRST('XXX','BUG ')
2783      WRITE(ICOUT,53)MAXMAR,NUMMAR
2784   53 FORMAT('MAXMAR,NUMMAR = ',I8,I8)
2785      CALL DPWRST('XXX','BUG ')
2786      WRITE(ICOUT,54)IHOLD1,IHOLD2
2787   54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
2788      CALL DPWRST('XXX','BUG ')
2789      WRITE(ICOUT,55)IDEMPL
2790   55 FORMAT('IDEMPL = ',A4)
2791      CALL DPWRST('XXX','BUG ')
2792      WRITE(ICOUT,60)NUMARG
2793   60 FORMAT('NUMARG = ',I8)
2794      CALL DPWRST('XXX','BUG ')
2795      DO65I=1,NUMARG
2796      WRITE(ICOUT,66)IHARG(I)
2797   66 FORMAT('IHARG(I) = ',A4)
2798      CALL DPWRST('XXX','BUG ')
2799   65 CONTINUE
2800      WRITE(ICOUT,70)IMAPLI(1)
2801   70 FORMAT('IMAPLI(1) = ',A4)
2802      CALL DPWRST('XXX','BUG ')
2803      DO75I=1,10
2804      WRITE(ICOUT,76)I,IMAPLI(I)
2805   76 FORMAT('I,IMAPLI(I) = ',I8,2X,A4)
2806      CALL DPWRST('XXX','BUG ')
2807   75 CONTINUE
2808   90 CONTINUE
2809C
2810C               **************************************
2811C               **  STEP 1--                        **
2812C               **  BRANCH TO THE APPROPRIATE CASE  **
2813C               **************************************
2814C
2815      ISTEPN='1'
2816      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2817C
2818      IF(NUMARG.LE.2)GOTO9000
2819      IF(NUMARG.EQ.3)GOTO1130
2820      IF(NUMARG.EQ.4)GOTO1140
2821      IF(NUMARG.EQ.5)GOTO1150
2822      GOTO1160
2823C
2824 1130 CONTINUE
2825      GOTO1200
2826C
2827 1140 CONTINUE
2828      IF(IHARG(5).EQ.'ALL')IHOLD1='    '
2829      IF(IHARG(5).EQ.'ALL')GOTO1300
2830      GOTO1200
2831C
2832 1150 CONTINUE
2833CCCCC APRIL 1996.  IHOLD TO IHOLD1 BELOW
2834      IF(IHARG(5).EQ.'ALL')THEN
2835        IHOLD1=IHARG(6)
2836        IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'2')IHOLD1='DA2'
2837        IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'3')IHOLD1='DA3'
2838        IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'4')IHOLD1='DA4'
2839        IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'5')IHOLD1='DA5'
2840        GOTO1300
2841      ENDIF
2842      IF(IHARG(6).EQ.'ALL')THEN
2843        IHOLD1=IHARG(5)
2844        IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'2')IHOLD1='DA2'
2845        IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'3')IHOLD1='DA3'
2846        IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'4')IHOLD1='DA4'
2847        IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'5')IHOLD1='DA5'
2848        GOTO1300
2849      ENDIF
2850      GOTO1200
2851C
2852 1160 CONTINUE
2853      GOTO1200
2854C
2855C               *************************************************
2856C               **  STEP 2--                                   **
2857C               **  TREAT THE SINGLE     SPECIFICATION  CASE  **
2858C               *************************************************
2859C
2860 1200 CONTINUE
2861      ISTEPN='2'
2862      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2863C
2864      IF(NUMARG.LE.3)GOTO1210
2865      GOTO1220
2866C
2867 1210 CONTINUE
2868      NUMMAR=1
2869      IMAPLI(1)='    '
2870      GOTO1270
2871C
2872 1220 CONTINUE
2873      NUMMAR=NUMARG-3
2874      IF(NUMMAR.GT.MAXMAR)NUMMAR=MAXMAR
2875      DO1225I=1,NUMMAR
2876      J=I+3
2877      IHOLD1=IHARG(J)
2878      IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'2')IHOLD1='DA2'
2879      IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'3')IHOLD1='DA3'
2880      IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'4')IHOLD1='DA4'
2881      IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'5')IHOLD1='DA5'
2882      IHOLD2=IHOLD1
2883      IF(IHOLD1.EQ.'ON')IHOLD2='SOLI'
2884      IF(IHOLD1.EQ.'OFF')IHOLD2='    '
2885      IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEMPL
2886      IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEMPL
2887      IMAPLI(I)=IHOLD2
2888 1225 CONTINUE
2889      GOTO1270
2890C
2891 1270 CONTINUE
2892      IF(IFEEDB.EQ.'OFF')GOTO1279
2893      WRITE(ICOUT,999)
2894      CALL DPWRST('XXX','BUG ')
2895      DO1278I=1,NUMMAR
2896      WRITE(ICOUT,1276)I,IMAPLI(I)
2897 1276 FORMAT('THE LINE TYPE FOR MARKER PATTERN ',I6,
2898     1' HAS JUST BEEN SET TO ',A4)
2899      CALL DPWRST('XXX','BUG ')
2900 1278 CONTINUE
2901 1279 CONTINUE
2902      IFOUND='YES'
2903      GOTO9000
2904C
2905C               **************************
2906C               **  STEP 3--            **
2907C               **  TREAT THE ALL CASE  **
2908C               **************************
2909C
2910 1300 CONTINUE
2911      ISTEPN='3'
2912      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2913C
2914      NUMMAR=MAXMAR
2915      IHOLD2=IHOLD1
2916      IF(IHOLD1.EQ.'ON')IHOLD2='SOLI'
2917      IF(IHOLD1.EQ.'OFF')IHOLD2='    '
2918      IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEMPL
2919      IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEMPL
2920      DO1315I=1,NUMMAR
2921      IMAPLI(I)=IHOLD2
2922 1315 CONTINUE
2923      GOTO1370
2924C
2925 1370 CONTINUE
2926      IF(IFEEDB.EQ.'OFF')GOTO1319
2927      WRITE(ICOUT,999)
2928      CALL DPWRST('XXX','BUG ')
2929      I=1
2930      WRITE(ICOUT,1316)IMAPLI(I)
2931 1316 FORMAT('THE LINE TYPE FOR ALL MARKER PATTERNS',
2932     1' HAS JUST BEEN SET TO ',A4)
2933      CALL DPWRST('XXX','BUG ')
2934 1319 CONTINUE
2935      IFOUND='YES'
2936      GOTO9000
2937C
2938C               *****************
2939C               **  STEP 90--  **
2940C               **  EXIT       **
2941C               *****************
2942C
2943 9000 CONTINUE
2944      IF(IBUGP2.EQ.'OFF')GOTO9090
2945      WRITE(ICOUT,9011)
2946 9011 FORMAT('***** AT THE END       OF DPMPLI--')
2947      CALL DPWRST('XXX','BUG ')
2948      WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR
2949 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
2950      CALL DPWRST('XXX','BUG ')
2951      WRITE(ICOUT,9013)MAXMAR,NUMMAR
2952 9013 FORMAT('MAXMAR,NUMMAR = ',I8,I8)
2953      CALL DPWRST('XXX','BUG ')
2954      WRITE(ICOUT,9014)IHOLD1,IHOLD2
2955 9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
2956      CALL DPWRST('XXX','BUG ')
2957      WRITE(ICOUT,9015)IDEMPL
2958 9015 FORMAT('IDEMPL = ',A4)
2959      CALL DPWRST('XXX','BUG ')
2960      WRITE(ICOUT,9020)NUMARG
2961 9020 FORMAT('NUMARG = ',I8)
2962      CALL DPWRST('XXX','BUG ')
2963      DO9025I=1,NUMARG
2964      WRITE(ICOUT,9026)IHARG(I)
2965 9026 FORMAT('IHARG(I) = ',A4)
2966      CALL DPWRST('XXX','BUG ')
2967 9025 CONTINUE
2968      WRITE(ICOUT,9030)IMAPLI(1)
2969 9030 FORMAT('IMAPLI(1) = ',A4)
2970      CALL DPWRST('XXX','BUG ')
2971      DO9035I=1,10
2972      WRITE(ICOUT,9036)I,IMAPLI(I)
2973 9036 FORMAT('I,IMAPLI(I) = ',I8,2X,A4)
2974      CALL DPWRST('XXX','BUG ')
2975 9035 CONTINUE
2976 9090 CONTINUE
2977C
2978      RETURN
2979      END
2980      SUBROUTINE DPMPSP(IHARG,IARGT,ARG,NUMARG,PDEMPS,MAXMAR,PMAPSP,
2981     1IBUGP2,IFOUND,IERROR)
2982C
2983C     PURPOSE--DEFINE THE MARKER PATTERN SPACINGS = THE SPACINGS
2984C              BETWEEN THE LINES WHICH MAKE UP THE PATTERNS WITHIN THE MARKERS.
2985C              THESE ARE LOCATED IN THE VECTOR PMAPSP(.).
2986C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
2987C                     --IARGT  (A  CHARACTER VECTOR)
2988C                     --ARG
2989C                     --NUMARG
2990C                     --PDEMPS
2991C                     --MAXMAR
2992C                     --IBUGP2 ('ON' OR 'OFF' )
2993C     OUTPUT ARGUMENTS--PMAPSP (A FLOATING POINT VECTOR)
2994C                     --IFOUND ('YES' OR 'NO' )
2995C                     --IERROR ('YES' OR 'NO' )
2996C     WRITTEN BY--JAMES J. FILLIBEN
2997C                 STATISTICAL ENGINEERING DIVISION
2998C                 INFORMATION TECHNOLOGY LABORATORY
2999C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
3000C                 GAITHERSBURG, MD 20899-8980
3001C                 PHONE--301-975-2855
3002C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
3003C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
3004C     LANGUAGE--ANSI FORTRAN (1977)
3005C     VERSION NUMBER--82/7
3006C     ORIGINAL VERSION--DECEMBER  1983.
3007C
3008C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
3009C
3010      CHARACTER*4 IHARG
3011      CHARACTER*4 IARGT
3012C
3013      CHARACTER*4 IBUGP2
3014      CHARACTER*4 IFOUND
3015      CHARACTER*4 IERROR
3016C
3017      CHARACTER*4 IHOLD1
3018C
3019      CHARACTER*4 ISUBN1
3020      CHARACTER*4 ISUBN2
3021      CHARACTER*4 ISTEPN
3022C
3023      DIMENSION IHARG(*)
3024      DIMENSION IARGT(*)
3025      DIMENSION ARG(*)
3026      DIMENSION PMAPSP(*)
3027C
3028C---------------------------------------------------------------------
3029C
3030      INCLUDE 'DPCOP2.INC'
3031C
3032C-----START POINT-----------------------------------------------------
3033C
3034      IFOUND='NO'
3035      IERROR='NO'
3036      ISUBN1='DPMP'
3037      ISUBN2='SP  '
3038C
3039      NUMMAR=0
3040      IHOLD1='-999'
3041      HOLD1=-999.0
3042      HOLD2=-999.0
3043C
3044      IF(IBUGP2.EQ.'OFF')GOTO90
3045      WRITE(ICOUT,999)
3046  999 FORMAT(1X)
3047      CALL DPWRST('XXX','BUG ')
3048      WRITE(ICOUT,51)
3049   51 FORMAT('***** AT THE BEGINNING OF DPMPSP--')
3050      CALL DPWRST('XXX','BUG ')
3051      WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR
3052   52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
3053      CALL DPWRST('XXX','BUG ')
3054      WRITE(ICOUT,53)MAXMAR,NUMMAR
3055   53 FORMAT('MAXMAR,NUMMAR = ',I8,I8)
3056      CALL DPWRST('XXX','BUG ')
3057      WRITE(ICOUT,54)IHOLD1,HOLD1,HOLD2
3058   54 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7)
3059      CALL DPWRST('XXX','BUG ')
3060      WRITE(ICOUT,55)PDEMPS
3061   55 FORMAT('PDEMPS = ',E15.7)
3062      CALL DPWRST('XXX','BUG ')
3063      WRITE(ICOUT,60)NUMARG
3064   60 FORMAT('NUMARG = ',I8)
3065      CALL DPWRST('XXX','BUG ')
3066      DO65I=1,NUMARG
3067      WRITE(ICOUT,66)IHARG(I),IARGT(I),ARG(I)
3068   66 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8)
3069      CALL DPWRST('XXX','BUG ')
3070   65 CONTINUE
3071      WRITE(ICOUT,70)PMAPSP(1)
3072   70 FORMAT('PMAPSP(1) = ',E15.7)
3073      CALL DPWRST('XXX','BUG ')
3074      DO75I=1,10
3075      WRITE(ICOUT,76)I,PMAPSP(I)
3076   76 FORMAT('I,PMAPSP(I) = ',I8,2X,E15.7)
3077      CALL DPWRST('XXX','BUG ')
3078   75 CONTINUE
3079   90 CONTINUE
3080C
3081C               **************************************
3082C               **  STEP 1--                        **
3083C               **  BRANCH TO THE APPROPRIATE CASE  **
3084C               **************************************
3085C
3086      ISTEPN='1'
3087      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3088C
3089      IF(NUMARG.LE.1)GOTO9000
3090      IF(NUMARG.EQ.2)GOTO1120
3091      IF(NUMARG.EQ.3)GOTO1130
3092      IF(NUMARG.EQ.4)GOTO1140
3093      GOTO1150
3094C
3095 1120 CONTINUE
3096      GOTO1200
3097C
3098 1130 CONTINUE
3099      IF(IHARG(3).EQ.'ALL')IHOLD1='    '
3100      IF(IHARG(3).EQ.'ALL')HOLD1=PDEMPS
3101      IF(IHARG(3).EQ.'ALL')GOTO1300
3102      GOTO1200
3103C
3104 1140 CONTINUE
3105      IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(4)
3106      IF(IHARG(3).EQ.'ALL')HOLD1=ARG(4)
3107      IF(IHARG(3).EQ.'ALL')GOTO1300
3108      IF(IHARG(4).EQ.'ALL')IHOLD1=IHARG(3)
3109      IF(IHARG(4).EQ.'ALL')HOLD1=ARG(3)
3110      IF(IHARG(4).EQ.'ALL')GOTO1300
3111      GOTO1200
3112C
3113 1150 CONTINUE
3114      GOTO1200
3115C
3116C               *************************************************
3117C               **  STEP 2--                                   **
3118C               **  TREAT THE SINGLE     SPECIFICATION  CASE  **
3119C               *************************************************
3120C
3121 1200 CONTINUE
3122      ISTEPN='2'
3123      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3124C
3125      IF(NUMARG.LE.2)GOTO1210
3126      GOTO1220
3127C
3128 1210 CONTINUE
3129      NUMMAR=1
3130      PMAPSP(1)=PDEMPS
3131      GOTO1270
3132C
3133 1220 CONTINUE
3134      NUMMAR=NUMARG-2
3135      IF(NUMMAR.GT.MAXMAR)NUMMAR=MAXMAR
3136      DO1225I=1,NUMMAR
3137      J=I+2
3138      IHOLD1=IHARG(J)
3139      HOLD1=ARG(J)
3140      HOLD2=HOLD1
3141      IF(IHOLD1.EQ.'ON')HOLD2=PDEMPS
3142      IF(IHOLD1.EQ.'OFF')HOLD2=PDEMPS
3143      IF(IHOLD1.EQ.'AUTO')HOLD2=PDEMPS
3144      IF(IHOLD1.EQ.'DEFA')HOLD2=PDEMPS
3145      PMAPSP(I)=HOLD2
3146 1225 CONTINUE
3147      GOTO1270
3148C
3149 1270 CONTINUE
3150      IF(IFEEDB.EQ.'OFF')GOTO1279
3151      WRITE(ICOUT,999)
3152      CALL DPWRST('XXX','BUG ')
3153      DO1278I=1,NUMMAR
3154      WRITE(ICOUT,1276)I,PMAPSP(I)
3155 1276 FORMAT('THE SPACING BETWEEN (LINES WITHIN) PATTERN ',I6,
3156     1' HAS JUST BEEN SET TO ',E15.7)
3157      CALL DPWRST('XXX','BUG ')
3158 1278 CONTINUE
3159 1279 CONTINUE
3160      IFOUND='YES'
3161      GOTO9000
3162C
3163C               **************************
3164C               **  STEP 3--            **
3165C               **  TREAT THE ALL CASE  **
3166C               **************************
3167C
3168 1300 CONTINUE
3169      ISTEPN='3'
3170      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3171C
3172      NUMMAR=MAXMAR
3173      HOLD2=HOLD1
3174      IF(IHOLD1.EQ.'ON')HOLD2=PDEMPS
3175      IF(IHOLD1.EQ.'OFF')HOLD2=PDEMPS
3176      IF(IHOLD1.EQ.'AUTO')HOLD2=PDEMPS
3177      IF(IHOLD1.EQ.'DEFA')HOLD2=PDEMPS
3178      DO1315I=1,NUMMAR
3179      PMAPSP(I)=HOLD2
3180 1315 CONTINUE
3181      GOTO1370
3182C
3183 1370 CONTINUE
3184      IF(IFEEDB.EQ.'OFF')GOTO1319
3185      WRITE(ICOUT,999)
3186      CALL DPWRST('XXX','BUG ')
3187      I=1
3188      WRITE(ICOUT,1316)PMAPSP(I)
3189 1316 FORMAT('THE SPACING BETWEEN (LINES WITHIN) ALL PATTERNS',
3190     1' HAS JUST BEEN SET TO ',E15.7)
3191      CALL DPWRST('XXX','BUG ')
3192 1319 CONTINUE
3193      IFOUND='YES'
3194      GOTO9000
3195C
3196C               *****************
3197C               **  STEP 90--  **
3198C               **  EXIT       **
3199C               *****************
3200C
3201 9000 CONTINUE
3202      IF(IBUGP2.EQ.'OFF')GOTO9090
3203      WRITE(ICOUT,9011)
3204 9011 FORMAT('***** AT THE END       OF DPMPSP--')
3205      CALL DPWRST('XXX','BUG ')
3206      WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR
3207 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
3208      CALL DPWRST('XXX','BUG ')
3209      WRITE(ICOUT,9013)MAXMAR,NUMMAR
3210 9013 FORMAT('MAXMAR,NUMMAR = ',I8,I8)
3211      CALL DPWRST('XXX','BUG ')
3212      WRITE(ICOUT,9014)IHOLD1,HOLD1,HOLD2
3213 9014 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7)
3214      CALL DPWRST('XXX','BUG ')
3215      WRITE(ICOUT,9015)PDEMPS
3216 9015 FORMAT('PDEMPS = ',E15.7)
3217      CALL DPWRST('XXX','BUG ')
3218      WRITE(ICOUT,9020)NUMARG
3219 9020 FORMAT('NUMARG = ',I8)
3220      CALL DPWRST('XXX','BUG ')
3221      DO9025I=1,NUMARG
3222      WRITE(ICOUT,9026)IHARG(I),IARGT(I),ARG(I)
3223 9026 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8)
3224      CALL DPWRST('XXX','BUG ')
3225 9025 CONTINUE
3226      WRITE(ICOUT,9030)PMAPSP(1)
3227 9030 FORMAT('PMAPSP(1) = ',E15.7)
3228      CALL DPWRST('XXX','BUG ')
3229      DO9035I=1,10
3230      WRITE(ICOUT,9036)I,PMAPSP(I)
3231 9036 FORMAT('I,PMAPSP(I) = ',I8,2X,E15.7)
3232      CALL DPWRST('XXX','BUG ')
3233 9035 CONTINUE
3234 9090 CONTINUE
3235C
3236      RETURN
3237      END
3238      SUBROUTINE DPMPTH(IHARG,IARGT,ARG,NUMARG,PDEMPT,MAXMAR,PMAPTH,
3239     1IBUGP2,IFOUND,IERROR)
3240C
3241C     PURPOSE--DEFINE THE MARKER PATTERN THICKNESSES = THE THICKNESSES
3242C              OF THE LINES WHICH MAKE UP THE PATTERNS WITHIN THE MARKERS.
3243C              THESE ARE LOCATED IN THE VECTOR PMAPTH(.).
3244C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
3245C                     --IARGT  (A  CHARACTER VECTOR)
3246C                     --ARG
3247C                     --NUMARG
3248C                     --PDEMPT
3249C                     --MAXMAR
3250C                     --IBUGP2 ('ON' OR 'OFF' )
3251C     OUTPUT ARGUMENTS--PMAPTH (A FLOATING POINT VECTOR)
3252C                     --IFOUND ('YES' OR 'NO' )
3253C                     --IERROR ('YES' OR 'NO' )
3254C     WRITTEN BY--JAMES J. FILLIBEN
3255C                 STATISTICAL ENGINEERING DIVISION
3256C                 INFORMATION TECHNOLOGY LABORATORY
3257C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
3258C                 GAITHERSBURG, MD 20899-8980
3259C                 PHONE--301-975-2855
3260C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
3261C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
3262C     LANGUAGE--ANSI FORTRAN (1977)
3263C     VERSION NUMBER--82/7
3264C     ORIGINAL VERSION--DECEMBER  1983.
3265C
3266C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
3267C
3268      CHARACTER*4 IHARG
3269      CHARACTER*4 IARGT
3270C
3271      CHARACTER*4 IBUGP2
3272      CHARACTER*4 IFOUND
3273      CHARACTER*4 IERROR
3274C
3275      CHARACTER*4 IHOLD1
3276C
3277      CHARACTER*4 ISUBN1
3278      CHARACTER*4 ISUBN2
3279      CHARACTER*4 ISTEPN
3280C
3281      DIMENSION IHARG(*)
3282      DIMENSION IARGT(*)
3283      DIMENSION ARG(*)
3284      DIMENSION PMAPTH(*)
3285C
3286C---------------------------------------------------------------------
3287C
3288      INCLUDE 'DPCOP2.INC'
3289C
3290C-----START POINT-----------------------------------------------------
3291C
3292      IFOUND='NO'
3293      IERROR='NO'
3294      ISUBN1='DPMP'
3295      ISUBN2='TH  '
3296C
3297      NUMMAR=0
3298      IHOLD1='-999'
3299      HOLD1=-999.0
3300      HOLD2=-999.0
3301C
3302      IF(IBUGP2.EQ.'OFF')GOTO90
3303      WRITE(ICOUT,999)
3304  999 FORMAT(1X)
3305      CALL DPWRST('XXX','BUG ')
3306      WRITE(ICOUT,51)
3307   51 FORMAT('***** AT THE BEGINNING OF DPMPTH--')
3308      CALL DPWRST('XXX','BUG ')
3309      WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR
3310   52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
3311      CALL DPWRST('XXX','BUG ')
3312      WRITE(ICOUT,53)MAXMAR,NUMMAR
3313   53 FORMAT('MAXMAR,NUMMAR = ',I8,I8)
3314      CALL DPWRST('XXX','BUG ')
3315      WRITE(ICOUT,54)IHOLD1,HOLD1,HOLD2
3316   54 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7)
3317      CALL DPWRST('XXX','BUG ')
3318      WRITE(ICOUT,55)PDEMPT
3319   55 FORMAT('PDEMPT = ',E15.7)
3320      CALL DPWRST('XXX','BUG ')
3321      WRITE(ICOUT,60)NUMARG
3322   60 FORMAT('NUMARG = ',I8)
3323      CALL DPWRST('XXX','BUG ')
3324      DO65I=1,NUMARG
3325      WRITE(ICOUT,66)IHARG(I),IARGT(I),ARG(I)
3326   66 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8)
3327      CALL DPWRST('XXX','BUG ')
3328   65 CONTINUE
3329      WRITE(ICOUT,70)PMAPTH(1)
3330   70 FORMAT('PMAPTH(1) = ',E15.7)
3331      CALL DPWRST('XXX','BUG ')
3332      DO75I=1,10
3333      WRITE(ICOUT,76)I,PMAPTH(I)
3334   76 FORMAT('I,PMAPTH(I) = ',I8,2X,E15.7)
3335      CALL DPWRST('XXX','BUG ')
3336   75 CONTINUE
3337   90 CONTINUE
3338C
3339C               **************************************
3340C               **  STEP 1--                        **
3341C               **  BRANCH TO THE APPROPRIATE CASE  **
3342C               **************************************
3343C
3344      ISTEPN='1'
3345      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3346C
3347      IF(NUMARG.LE.1)GOTO9000
3348      IF(NUMARG.EQ.2)GOTO1120
3349      IF(NUMARG.EQ.3)GOTO1130
3350      IF(NUMARG.EQ.4)GOTO1140
3351      GOTO1150
3352C
3353 1120 CONTINUE
3354      GOTO1200
3355C
3356 1130 CONTINUE
3357      IF(IHARG(3).EQ.'ALL')IHOLD1='    '
3358      IF(IHARG(3).EQ.'ALL')HOLD1=PDEMPT
3359      IF(IHARG(3).EQ.'ALL')GOTO1300
3360      GOTO1200
3361C
3362 1140 CONTINUE
3363      IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(4)
3364      IF(IHARG(3).EQ.'ALL')HOLD1=ARG(4)
3365      IF(IHARG(3).EQ.'ALL')GOTO1300
3366      IF(IHARG(4).EQ.'ALL')IHOLD1=IHARG(3)
3367      IF(IHARG(4).EQ.'ALL')HOLD1=ARG(2)
3368      IF(IHARG(4).EQ.'ALL')GOTO1300
3369      GOTO1200
3370C
3371 1150 CONTINUE
3372      GOTO1200
3373C
3374C               *************************************************
3375C               **  STEP 2--                                   **
3376C               **  TREAT THE SINGLE     SPECIFICATION  CASE  **
3377C               *************************************************
3378C
3379 1200 CONTINUE
3380      ISTEPN='2'
3381      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3382C
3383      IF(NUMARG.LE.2)GOTO1210
3384      GOTO1220
3385C
3386 1210 CONTINUE
3387      NUMMAR=1
3388      PMAPTH(1)=PDEMPT
3389      GOTO1270
3390C
3391 1220 CONTINUE
3392      NUMMAR=NUMARG-2
3393      IF(NUMMAR.GT.MAXMAR)NUMMAR=MAXMAR
3394      DO1225I=1,NUMMAR
3395      J=I+2
3396      IHOLD1=IHARG(J)
3397      HOLD1=ARG(J)
3398      HOLD2=HOLD1
3399      IF(IHOLD1.EQ.'ON')HOLD2=PDEMPT
3400      IF(IHOLD1.EQ.'OFF')HOLD2=PDEMPT
3401      IF(IHOLD1.EQ.'AUTO')HOLD2=PDEMPT
3402      IF(IHOLD1.EQ.'DEFA')HOLD2=PDEMPT
3403      PMAPTH(I)=HOLD2
3404 1225 CONTINUE
3405      GOTO1270
3406C
3407 1270 CONTINUE
3408      IF(IFEEDB.EQ.'OFF')GOTO1279
3409      WRITE(ICOUT,999)
3410      CALL DPWRST('XXX','BUG ')
3411      DO1278I=1,NUMMAR
3412      WRITE(ICOUT,1276)I,PMAPTH(I)
3413 1276 FORMAT('THE THICKNESS OF (LINES WITHIN) PATTERN ',I6,
3414     1' HAS JUST BEEN SET TO ',E15.7)
3415      CALL DPWRST('XXX','BUG ')
3416 1278 CONTINUE
3417 1279 CONTINUE
3418      IFOUND='YES'
3419      GOTO9000
3420C
3421C               **************************
3422C               **  STEP 3--            **
3423C               **  TREAT THE ALL CASE  **
3424C               **************************
3425C
3426 1300 CONTINUE
3427      ISTEPN='3'
3428      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3429C
3430      NUMMAR=MAXMAR
3431      HOLD2=HOLD1
3432      IF(IHOLD1.EQ.'ON')HOLD2=PDEMPT
3433      IF(IHOLD1.EQ.'OFF')HOLD2=PDEMPT
3434      IF(IHOLD1.EQ.'AUTO')HOLD2=PDEMPT
3435      IF(IHOLD1.EQ.'DEFA')HOLD2=PDEMPT
3436      DO1315I=1,NUMMAR
3437      PMAPTH(I)=HOLD2
3438 1315 CONTINUE
3439      GOTO1370
3440C
3441 1370 CONTINUE
3442      IF(IFEEDB.EQ.'OFF')GOTO1319
3443      WRITE(ICOUT,999)
3444      CALL DPWRST('XXX','BUG ')
3445      I=1
3446      WRITE(ICOUT,1316)PMAPTH(I)
3447 1316 FORMAT('THE THICKNESS OF (LINES WITHIN) ALL PATTERNS',
3448     1' HAS JUST BEEN SET TO ',E15.7)
3449      CALL DPWRST('XXX','BUG ')
3450 1319 CONTINUE
3451      IFOUND='YES'
3452      GOTO9000
3453C
3454C               *****************
3455C               **  STEP 90--  **
3456C               **  EXIT       **
3457C               *****************
3458C
3459 9000 CONTINUE
3460      IF(IBUGP2.EQ.'OFF')GOTO9090
3461      WRITE(ICOUT,9011)
3462 9011 FORMAT('***** AT THE END       OF DPMPTH--')
3463      CALL DPWRST('XXX','BUG ')
3464      WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR
3465 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
3466      CALL DPWRST('XXX','BUG ')
3467      WRITE(ICOUT,9013)MAXMAR,NUMMAR
3468 9013 FORMAT('MAXMAR,NUMMAR = ',I8,I8)
3469      CALL DPWRST('XXX','BUG ')
3470      WRITE(ICOUT,9014)IHOLD1,HOLD1,HOLD2
3471 9014 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7)
3472      CALL DPWRST('XXX','BUG ')
3473      WRITE(ICOUT,9015)PDEMPT
3474 9015 FORMAT('PDEMPT = ',E15.7)
3475      CALL DPWRST('XXX','BUG ')
3476      WRITE(ICOUT,9020)NUMARG
3477 9020 FORMAT('NUMARG = ',I8)
3478      CALL DPWRST('XXX','BUG ')
3479      DO9025I=1,NUMARG
3480      WRITE(ICOUT,9026)IHARG(I),IARGT(I),ARG(I)
3481 9026 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8)
3482      CALL DPWRST('XXX','BUG ')
3483 9025 CONTINUE
3484      WRITE(ICOUT,9030)PMAPTH(1)
3485 9030 FORMAT('PMAPTH(1) = ',E15.7)
3486      CALL DPWRST('XXX','BUG ')
3487      DO9035I=1,10
3488      WRITE(ICOUT,9036)I,PMAPTH(I)
3489 9036 FORMAT('I,PMAPTH(I) = ',I8,2X,E15.7)
3490      CALL DPWRST('XXX','BUG ')
3491 9035 CONTINUE
3492 9090 CONTINUE
3493C
3494      RETURN
3495      END
3496      SUBROUTINE DPMPTY(IHARG,NUMARG,IDEMPT,MAXMAR,IMAPTY,
3497     1IBUGP2,IFOUND,IERROR)
3498C
3499C     PURPOSE--DEFINE THE PATTERN TYPES = THE TYPES
3500C              OF THE PATTERN WITHIN THE MARKERS.
3501C              THESE ARE LOCATED IN THE VECTOR IMAPTY(.).
3502C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
3503C                     --NUMARG
3504C                     --IDEMPT
3505C                     --MAXMAR
3506C                     --IBUGP2 ('ON' OR 'OFF' )
3507C     OUTPUT ARGUMENTS--IMAPTY (A CHARACTER VECTOR)
3508C                     --IFOUND ('YES' OR 'NO' )
3509C                     --IERROR ('YES' OR 'NO' )
3510C     WRITTEN BY--JAMES J. FILLIBEN
3511C                 STATISTICAL ENGINEERING DIVISION
3512C                 INFORMATION TECHNOLOGY LABORATORY
3513C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
3514C                 GAITHERSBURG, MD 20899-8980
3515C                 PHONE--301-975-2855
3516C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
3517C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
3518C     LANGUAGE--ANSI FORTRAN (1977)
3519C     VERSION NUMBER--82/7
3520C     ORIGINAL VERSION--DECEMBER  1983.
3521C
3522C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
3523C
3524      CHARACTER*4 IHARG
3525      CHARACTER*4 IDEMPT
3526      CHARACTER*4 IMAPTY
3527C
3528      CHARACTER*4 IBUGP2
3529      CHARACTER*4 IFOUND
3530      CHARACTER*4 IERROR
3531C
3532      CHARACTER*4 IHOLD1
3533      CHARACTER*4 IHOLD2
3534C
3535      CHARACTER*4 ISUBN1
3536      CHARACTER*4 ISUBN2
3537      CHARACTER*4 ISTEPN
3538C
3539      DIMENSION IHARG(*)
3540      DIMENSION IMAPTY(*)
3541C
3542C---------------------------------------------------------------------
3543C
3544      INCLUDE 'DPCOP2.INC'
3545C
3546C-----START POINT-----------------------------------------------------
3547C
3548      IFOUND='NO'
3549      IERROR='NO'
3550      ISUBN1='DPMP'
3551      ISUBN2='TY  '
3552C
3553      NUMMAR=0
3554      IHOLD1='-999'
3555      IHOLD2='-999'
3556C
3557      IF(IBUGP2.EQ.'OFF')GOTO90
3558      WRITE(ICOUT,999)
3559  999 FORMAT(1X)
3560      CALL DPWRST('XXX','BUG ')
3561      WRITE(ICOUT,51)
3562   51 FORMAT('***** AT THE BEGINNING OF DPMPTY--')
3563      CALL DPWRST('XXX','BUG ')
3564      WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR
3565   52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
3566      CALL DPWRST('XXX','BUG ')
3567      WRITE(ICOUT,53)MAXMAR,NUMMAR
3568   53 FORMAT('MAXMAR,NUMMAR = ',I8,I8)
3569      CALL DPWRST('XXX','BUG ')
3570      WRITE(ICOUT,54)IHOLD1,IHOLD2
3571   54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
3572      CALL DPWRST('XXX','BUG ')
3573      WRITE(ICOUT,55)IDEMPT
3574   55 FORMAT('IDEMPT = ',A4)
3575      CALL DPWRST('XXX','BUG ')
3576      WRITE(ICOUT,60)NUMARG
3577   60 FORMAT('NUMARG = ',I8)
3578      CALL DPWRST('XXX','BUG ')
3579      DO65I=1,NUMARG
3580      WRITE(ICOUT,66)IHARG(I)
3581   66 FORMAT('IHARG(I) = ',A4)
3582      CALL DPWRST('XXX','BUG ')
3583   65 CONTINUE
3584      WRITE(ICOUT,70)IMAPTY(1)
3585   70 FORMAT('IMAPTY(1) = ',A4)
3586      CALL DPWRST('XXX','BUG ')
3587      DO75I=1,10
3588      WRITE(ICOUT,76)I,IMAPTY(I)
3589   76 FORMAT('I,IMAPTY(I) = ',I8,2X,A4)
3590      CALL DPWRST('XXX','BUG ')
3591   75 CONTINUE
3592   90 CONTINUE
3593C
3594C               **************************************
3595C               **  STEP 1--                        **
3596C               **  BRANCH TO THE APPROPRIATE CASE  **
3597C               **************************************
3598C
3599      ISTEPN='1'
3600      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3601C
3602      IF(NUMARG.LE.1)GOTO9000
3603      IF(NUMARG.EQ.2)GOTO1120
3604      IF(NUMARG.EQ.3)GOTO1130
3605      IF(NUMARG.EQ.4)GOTO1140
3606      GOTO1150
3607C
3608 1120 CONTINUE
3609      GOTO1200
3610C
3611 1130 CONTINUE
3612      IF(IHARG(3).EQ.'ALL')IHOLD1='    '
3613      IF(IHARG(3).EQ.'ALL')GOTO1300
3614      GOTO1200
3615C
3616 1140 CONTINUE
3617      IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(4)
3618      IF(IHARG(3).EQ.'ALL')GOTO1300
3619      IF(IHARG(4).EQ.'ALL')IHOLD1=IHARG(3)
3620      IF(IHARG(4).EQ.'ALL')GOTO1300
3621      GOTO1200
3622C
3623 1150 CONTINUE
3624      GOTO1200
3625C
3626C               *************************************************
3627C               **  STEP 2--                                   **
3628C               **  TREAT THE SINGLE     SPECIFICATION  CASE  **
3629C               *************************************************
3630C
3631 1200 CONTINUE
3632      ISTEPN='2'
3633      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3634C
3635      IF(NUMARG.LE.2)GOTO1210
3636      GOTO1220
3637C
3638 1210 CONTINUE
3639      NUMMAR=1
3640      IMAPTY(1)='    '
3641      GOTO1270
3642C
3643 1220 CONTINUE
3644      NUMMAR=NUMARG-2
3645      IF(NUMMAR.GT.MAXMAR)NUMMAR=MAXMAR
3646      DO1225I=1,NUMMAR
3647      J=I+2
3648      IHOLD1=IHARG(J)
3649      IHOLD2=IHOLD1
3650      IF(IHOLD1.EQ.'ON')IHOLD2='SOLI'
3651      IF(IHOLD1.EQ.'OFF')IHOLD2='    '
3652      IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEMPT
3653      IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEMPT
3654      IMAPTY(I)=IHOLD2
3655 1225 CONTINUE
3656      GOTO1270
3657C
3658 1270 CONTINUE
3659      IF(IFEEDB.EQ.'OFF')GOTO1279
3660      WRITE(ICOUT,999)
3661      CALL DPWRST('XXX','BUG ')
3662      DO1278I=1,NUMMAR
3663      WRITE(ICOUT,1276)I,IMAPTY(I)
3664 1276 FORMAT('THE TYPE FOR MARKER PATTERN ',I6,
3665     1' HAS JUST BEEN SET TO ',A4)
3666      CALL DPWRST('XXX','BUG ')
3667 1278 CONTINUE
3668 1279 CONTINUE
3669      IFOUND='YES'
3670      GOTO9000
3671C
3672C               **************************
3673C               **  STEP 3--            **
3674C               **  TREAT THE ALL CASE  **
3675C               **************************
3676C
3677 1300 CONTINUE
3678      ISTEPN='3'
3679      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3680C
3681      NUMMAR=MAXMAR
3682      IHOLD2=IHOLD1
3683      IF(IHOLD1.EQ.'ON')IHOLD2='SOLI'
3684      IF(IHOLD1.EQ.'OFF')IHOLD2='    '
3685      IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEMPT
3686      IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEMPT
3687      DO1315I=1,NUMMAR
3688      IMAPTY(I)=IHOLD2
3689 1315 CONTINUE
3690      GOTO1370
3691C
3692 1370 CONTINUE
3693      IF(IFEEDB.EQ.'OFF')GOTO1319
3694      WRITE(ICOUT,999)
3695      CALL DPWRST('XXX','BUG ')
3696      I=1
3697      WRITE(ICOUT,1316)IMAPTY(I)
3698 1316 FORMAT('THE TYPE FOR ALL MARKER PATTERNS',
3699     1' HAS JUST BEEN SET TO ',A4)
3700      CALL DPWRST('XXX','BUG ')
3701 1319 CONTINUE
3702      IFOUND='YES'
3703      GOTO9000
3704C
3705C               *****************
3706C               **  STEP 90--  **
3707C               **  EXIT       **
3708C               *****************
3709C
3710 9000 CONTINUE
3711      IF(IBUGP2.EQ.'OFF')GOTO9090
3712      WRITE(ICOUT,9011)
3713 9011 FORMAT('***** AT THE END       OF DPMPTY--')
3714      CALL DPWRST('XXX','BUG ')
3715      WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR
3716 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
3717      CALL DPWRST('XXX','BUG ')
3718      WRITE(ICOUT,9013)MAXMAR,NUMMAR
3719 9013 FORMAT('MAXMAR,NUMMAR = ',I8,I8)
3720      CALL DPWRST('XXX','BUG ')
3721      WRITE(ICOUT,9014)IHOLD1,IHOLD2
3722 9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
3723      CALL DPWRST('XXX','BUG ')
3724      WRITE(ICOUT,9015)IDEMPT
3725 9015 FORMAT('IDEMPT = ',A4)
3726      CALL DPWRST('XXX','BUG ')
3727      WRITE(ICOUT,9020)NUMARG
3728 9020 FORMAT('NUMARG = ',I8)
3729      CALL DPWRST('XXX','BUG ')
3730      DO9025I=1,NUMARG
3731      WRITE(ICOUT,9026)IHARG(I)
3732 9026 FORMAT('IHARG(I) = ',A4)
3733      CALL DPWRST('XXX','BUG ')
3734 9025 CONTINUE
3735      WRITE(ICOUT,9030)IMAPTY(1)
3736 9030 FORMAT('IMAPTY(1) = ',A4)
3737      CALL DPWRST('XXX','BUG ')
3738      DO9035I=1,10
3739      WRITE(ICOUT,9036)I,IMAPTY(I)
3740 9036 FORMAT('I,IMAPTY(I) = ',I8,2X,A4)
3741      CALL DPWRST('XXX','BUG ')
3742 9035 CONTINUE
3743 9090 CONTINUE
3744C
3745      RETURN
3746      END
3747      SUBROUTINE DPMRCL(ICASAN,ICAPSW,IFORSW,
3748     1                  ISUBRO,IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
3749C
3750C     PURPOSE--GENERATE (SYMMETRIC) CONFIDENCE LIMITS FOR THE MEAN
3751C              FOR PROBABILITY VALUE P = .90, .95, .99, .999, AND .9999.
3752C     WRITTEN BY--JAMES J. FILLIBEN
3753C                 STATISTICAL ENGINEERING DIVISION
3754C                 INFORMATION TECHNOLOGY LABORATORY
3755C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
3756C                 GAITHERSBURG, MD 20899-8980
3757C                 PHONE--301-975-2855
3758C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
3759C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
3760C     LANGUAGE--ANSI FORTRAN (1977)
3761C     VERSION NUMBER--2019/10
3762C     ORIGINAL VERSION--OCTOBER   2019.
3763C
3764C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
3765C
3766      CHARACTER*4 ICASAN
3767      CHARACTER*4 ICAPSW
3768      CHARACTER*4 IFORSW
3769      CHARACTER*4 ISUBRO
3770      CHARACTER*4 IBUGA2
3771      CHARACTER*4 IBUGA3
3772      CHARACTER*4 IBUGQ
3773      CHARACTER*4 IFOUND
3774      CHARACTER*4 IERROR
3775C
3776      CHARACTER*4 ICASE
3777      CHARACTER*4 ISUBN1
3778      CHARACTER*4 ISUBN2
3779      CHARACTER*4 ISTEPN
3780      CHARACTER*4 IFLAGU
3781C
3782      LOGICAL IFRST
3783      LOGICAL ILAST
3784C
3785      CHARACTER*40 INAME
3786      PARAMETER (MAXSPN=30)
3787      CHARACTER*4 IVARN1(MAXSPN)
3788      CHARACTER*4 IVARN2(MAXSPN)
3789      CHARACTER*4 IVARTY(MAXSPN)
3790      CHARACTER*4 IVARID(MAXSPN)
3791      CHARACTER*4 IVARI2(MAXSPN)
3792      REAL PVAR(MAXSPN)
3793      REAL PID(MAXSPN)
3794      INTEGER ILIS(MAXSPN)
3795      INTEGER NRIGHT(MAXSPN)
3796      INTEGER ICOLR(MAXSPN)
3797C
3798C---------------------------------------------------------------------
3799C
3800      INCLUDE 'DPCOPA.INC'
3801C
3802C-----COMMON----------------------------------------------------------
3803C
3804      INCLUDE 'DPCOHK.INC'
3805      INCLUDE 'DPCOSU.INC'
3806      INCLUDE 'DPCODA.INC'
3807      INCLUDE 'DPCOHO.INC'
3808      INCLUDE 'DPCOST.INC'
3809      INCLUDE 'DPCOP2.INC'
3810C
3811C-----START POINT-----------------------------------------------------
3812C
3813      ISUBN1='DPMR'
3814      ISUBN2='CL  '
3815      IFOUND='YES'
3816      IERROR='NO'
3817C
3818      MAXCP1=MAXCOL+1
3819      MAXCP2=MAXCOL+2
3820      MAXCP3=MAXCOL+3
3821      MAXCP4=MAXCOL+4
3822      MAXCP5=MAXCOL+5
3823      MAXCP6=MAXCOL+6
3824C
3825C               ****************************************
3826C               **  TREAT THE CONFIDENCE LIMITS CASE  **
3827C               ****************************************
3828C
3829      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'MRCL')THEN
3830        WRITE(ICOUT,999)
3831  999   FORMAT(1X)
3832        CALL DPWRST('XXX','BUG ')
3833        WRITE(ICOUT,51)
3834   51   FORMAT('***** AT THE BEGINNING OF DPMRCL--')
3835        CALL DPWRST('XXX','BUG ')
3836        WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ,ISUBRO
3837   52   FORMAT('IBUGA2,IBUGA3,IBUGQ,ISUBRO = ',3(A4,2X),A4)
3838        CALL DPWRST('XXX','BUG ')
3839        WRITE(ICOUT,55)MAXNXT,MAXV2
3840   55   FORMAT('MAXNXT,MAXV2 = ',I8,2X,I5)
3841        CALL DPWRST('XXX','BUG ')
3842      ENDIF
3843C
3844C               *********************************
3845C               **  STEP 1--                   **
3846C               **  EXTRACT THE COMMAND        **
3847C               *********************************
3848C
3849      ISTEPN='1'
3850      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MRCL')
3851     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3852C
3853C     THE FOLLOWING COMMANDS ARE ACCEPTED:
3854C
3855C         RATIO OF MEAN CONFIDENCE LIMITS Y X
3856C
3857      IFOUND='NO'
3858      IF(ICOM.EQ.'RATI' .AND. IHARG(1).EQ.'OF  ' .AND.
3859     1   IHARG(2).EQ.'MEAN' .AND. IHARG(3).EQ.'CONF' .AND.
3860     1   (IHARG(4).EQ.'LIMI' .OR. IHARG(4).EQ.'INTE'))THEN
3861        IFOUND='YES'
3862        ISHIFT=4
3863      ELSE
3864        GOTO9000
3865      ENDIF
3866C
3867      CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
3868     1            IBUGA2,IERROR)
3869C
3870C               *********************************
3871C               **  STEP 1--                   **
3872C               **  EXTRACT THE VARIABLE LIST  **
3873C               *********************************
3874C
3875      ISTEPN='1'
3876      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MRCL')
3877     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3878C
3879      INAME='RATIO OF MEANS CONFIDENCE LIMIT'
3880      MINNA=1
3881      MAXNA=100
3882      MINNVA=2
3883      MAXNVA=2
3884      IFLAGP=0
3885      JMIN=1
3886      JMAX=NUMARG
3887      MINN2=3
3888      IFLAGE=1
3889      IFLAGM=2
3890C
3891      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
3892     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
3893     1            JMIN,JMAX,
3894     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
3895     1            IVARN1,IVARN2,IVARTY,PVAR,
3896     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
3897     1            MINNVA,MAXNVA,
3898     1            IFLAGM,IFLAGP,
3899     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
3900      IF(IERROR.EQ.'YES')GOTO9000
3901C
3902      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MRCL')THEN
3903        WRITE(ICOUT,999)
3904        CALL DPWRST('XXX','BUG ')
3905        WRITE(ICOUT,181)
3906  181   FORMAT('***** AFTER CALL DPPARS--')
3907        CALL DPWRST('XXX','BUG ')
3908        WRITE(ICOUT,182)NQ,NUMVAR
3909  182   FORMAT('NQ,NUMVAR = ',2I8)
3910        CALL DPWRST('XXX','BUG ')
3911        IF(NUMVAR.GT.0)THEN
3912          DO185I=1,NUMVAR
3913            WRITE(ICOUT,187)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
3914     1                      ICOLR(I)
3915  187       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
3916     1             'ICOLR(I) = ',I8,2X,2A4,2X,3I8)
3917            CALL DPWRST('XXX','BUG ')
3918  185     CONTINUE
3919        ENDIF
3920      ENDIF
3921C
3922C               *******************************************
3923C               **  STEP 3--                             **
3924C               *******************************************
3925C
3926      ISTEPN='3'
3927      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MRCL')
3928     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3929C
3930      IINDX=ICOLR(1)
3931      PID(1)=CPUMIN
3932      IVARID(1)=IVARN1(1)
3933      IVARI2(1)=IVARN2(1)
3934      PID(2)=CPUMIN
3935      IVARID(2)=IVARN1(2)
3936      IVARI2(2)=IVARN2(2)
3937C
3938      ICOL=1
3939      NUMVA2=2
3940      CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
3941     1            INAME,IVARN1,IVARN2,IVARTY,
3942     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
3943     1            MAXCOL,MAXCP1,MAXCP2,MAXCP3,
3944     1            MAXCP4,MAXCP5,MAXCP6,
3945     1            V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
3946     1            Y,X,X,NLOCAL,NLOCA2,NLOCA3,ICASE,
3947     1            IBUGA3,ISUBRO,IFOUND,IERROR)
3948      IF(IERROR.EQ.'YES')GOTO9000
3949C
3950C         *****************************************************
3951C         **  STEP 3B--                                      **
3952C         *****************************************************
3953C
3954      ISTEPN='3B'
3955      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MRCL')
3956     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3957C
3958      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'MRCL')THEN
3959        WRITE(ICOUT,999)
3960        CALL DPWRST('XXX','BUG ')
3961        WRITE(ICOUT,322)
3962  322   FORMAT('***** FROM THE MIDDLE  OF DPMRCL--')
3963        CALL DPWRST('XXX','BUG ')
3964        WRITE(ICOUT,323)NUMVAR,NLOCAL
3965  323   FORMAT('NUMVAR,NLOCAL = ',2I8)
3966        CALL DPWRST('XXX','BUG ')
3967        IF(NLOCAL.GE.1)THEN
3968          DO325I=1,NLOCAL
3969            WRITE(ICOUT,326)I,Y(I),X(I)
3970  326       FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
3971            CALL DPWRST('XXX','BUG ')
3972  325     CONTINUE
3973        ENDIF
3974      ENDIF
3975C
3976      CALL DPMRC2(Y,X,NLOCAL,IVARID,IVARI2,
3977     1            CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
3978     1            CTL999,CTU999,
3979     1            ICAPSW,ICAPTY,IFORSW,IRATME,
3980     1            ISUBRO,IBUGA3,IERROR)
3981C
3982      ICASAN='MRCL'
3983      IFLAGU='ON'
3984      IFRST=.TRUE.
3985      ILAST=.TRUE.
3986      CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
3987     1            CTL999,CTU999,
3988     1            IFLAGU,IFRST,ILAST,ICASAN,
3989     1            IBUGA2,IBUGA3,ISUBRO,IERROR)
3990C
3991C               *****************
3992C               **  STEP 90--  **
3993C               **  EXIT       **
3994C               *****************
3995C
3996 9000 CONTINUE
3997      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'MRCL')THEN
3998        WRITE(ICOUT,999)
3999        CALL DPWRST('XXX','BUG ')
4000        WRITE(ICOUT,9011)
4001 9011   FORMAT('***** AT THE END       OF DPMRCL--')
4002        CALL DPWRST('XXX','BUG ')
4003        WRITE(ICOUT,9014)NRIGHT(1),NRIGHT(2)
4004 9014   FORMAT('NRIGHT(1),NRIGHT(2) = ',2I8)
4005        CALL DPWRST('XXX','BUG ')
4006        WRITE(ICOUT,9016)IFOUND,IERROR
4007 9016   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
4008        CALL DPWRST('XXX','BUG ')
4009      ENDIF
4010C
4011      RETURN
4012      END
4013      SUBROUTINE DPMRC2(Y,X,N,IVARID,IVARI2,
4014     1                  CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
4015     1                  CTL999,CTU999,
4016     1                  ICAPSW,ICAPTY,IFORSW,IRATME,
4017     1                  ISUBRO,IBUGA3,IERROR)
4018C
4019C     PURPOSE--THIS ROUTINE GENERATES CONFIDENCE LIMITS FOR THE RATIO OF
4020C              TWO MEANS, I.E., E(Y)/E(X) (NOT E(Y/X) FOR THE DATA IN
4021C              THE INPUT VECTORS Y AND X FOR THE PAIRED DATA CASE.
4022C              THREE ANALYTIC METHODS ARE SUPPORTED.  NOTE THAT THESE
4023C              METHODS ASSUME Y AND X ARE BOTH APPROXIMATELY NORMAL.
4024C     INPUT  ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR OF
4025C                                OBSERVATIONS FOR THE NUMERATOR
4026C                                VARIABLE.
4027C                     --X      = THE SINGLE PRECISION VECTOR OF
4028C                                OBSERVATIONS FOR THE DENOMINATOR
4029C                                VARIABLE.
4030C                       N      = THE INTEGER NUMBER OF
4031C                                OBSERVATIONS IN THE VECTOR Y.
4032C     WRITTEN BY--ALAN HECKERT
4033C                 STATISTICAL ENGINEERING DIVISION
4034C                 INFORMATION TECHNOLOGY LABORATORY
4035C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
4036C                 GAITHERSBURG, MD 20899-8980
4037C                 PHONE--301-975-2899
4038C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
4039C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
4040C     LANGUAGE--ANSI FORTRAN (1977)
4041C     VERSION NUMBER--2019/10
4042C     ORIGINAL VERSION--OCTOBER   2019.
4043C
4044C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
4045C
4046      CHARACTER*4 ISUBRO
4047      CHARACTER*4 IBUGA3
4048      CHARACTER*4 IERROR
4049C
4050      CHARACTER*4 IWRITE
4051      CHARACTER*4 ICAPSW
4052      CHARACTER*4 ICAPTY
4053      CHARACTER*4 IFORSW
4054      CHARACTER*4 IRATME
4055C
4056      CHARACTER*4 IVARID(*)
4057      CHARACTER*4 IVARI2(*)
4058C
4059      CHARACTER*4 ISUBN1
4060      CHARACTER*4 ISUBN2
4061      CHARACTER*4 ISTEPN
4062      CHARACTER*4 ICASA2
4063C
4064C---------------------------------------------------------------------
4065C
4066      DIMENSION Y(*)
4067      DIMENSION X(*)
4068C
4069      PARAMETER (NUMALP=8)
4070C
4071      DIMENSION CONF(NUMALP)
4072      DIMENSION T(NUMALP)
4073      DIMENSION TSDM(NUMALP)
4074      DIMENSION ALOWER(NUMALP)
4075      DIMENSION AUPPER(NUMALP)
4076C
4077      PARAMETER(NUMCLI=5)
4078      PARAMETER(MAXLIN=2)
4079      PARAMETER (MAXROW=20)
4080      CHARACTER*60 ITITLE
4081      CHARACTER*60 ITITLZ
4082      CHARACTER*60 ITEXT(MAXROW)
4083      REAL         AVALUE(MAXROW)
4084      INTEGER      NCTEXT(MAXROW)
4085      INTEGER      IDIGIT(MAXROW)
4086      INTEGER      NTOT(MAXROW)
4087      LOGICAL IFRST
4088      LOGICAL ILAST
4089C
4090C---------------------------------------------------------------------
4091C
4092      INCLUDE 'DPCOP2.INC'
4093C
4094C-----START POINT-----------------------------------------------------
4095C
4096      ISUBN1='DPMR'
4097      ISUBN2='C2  '
4098      IERROR='NO'
4099      IWRITE='OFF'
4100C
4101      NUMDIG=7
4102      IF(IFORSW.EQ.'1')NUMDIG=1
4103      IF(IFORSW.EQ.'2')NUMDIG=2
4104      IF(IFORSW.EQ.'3')NUMDIG=3
4105      IF(IFORSW.EQ.'4')NUMDIG=4
4106      IF(IFORSW.EQ.'5')NUMDIG=5
4107      IF(IFORSW.EQ.'6')NUMDIG=6
4108      IF(IFORSW.EQ.'7')NUMDIG=7
4109      IF(IFORSW.EQ.'8')NUMDIG=8
4110      IF(IFORSW.EQ.'9')NUMDIG=9
4111      IF(IFORSW.EQ.'0')NUMDIG=0
4112      IF(IFORSW.EQ.'E')NUMDIG=-2
4113      IF(IFORSW.EQ.'-2')NUMDIG=-2
4114      IF(IFORSW.EQ.'-3')NUMDIG=-3
4115      IF(IFORSW.EQ.'-4')NUMDIG=-4
4116      IF(IFORSW.EQ.'-5')NUMDIG=-5
4117      IF(IFORSW.EQ.'-6')NUMDIG=-6
4118      IF(IFORSW.EQ.'-7')NUMDIG=-7
4119      IF(IFORSW.EQ.'-8')NUMDIG=-8
4120      IF(IFORSW.EQ.'-9')NUMDIG=-9
4121C
4122      CONF(1)=50.0
4123      CONF(2)=75.0
4124      CONF(3)=90.0
4125      CONF(4)=95.0
4126      CONF(5)=99.0
4127      CONF(6)=99.9
4128      CONF(7)=99.99
4129      CONF(8)=99.999
4130C
4131      CUTL90=CPUMIN
4132      CUTU90=CPUMIN
4133      CUTL95=CPUMIN
4134      CUTU95=CPUMIN
4135      CUTL99=CPUMIN
4136      CUTU99=CPUMIN
4137C
4138      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'MRC2')THEN
4139        WRITE(ICOUT,999)
4140  999   FORMAT(1X)
4141        CALL DPWRST('XXX','WRIT')
4142        WRITE(ICOUT,51)
4143   51   FORMAT('**** AT THE BEGINNING OF DPMRC2--')
4144        CALL DPWRST('XXX','WRIT')
4145        WRITE(ICOUT,52)IBUGA3,ISUBRO,IRATME,N
4146   52   FORMAT('IBUGA3,ISUBRO,IRATME,N = ',3(2X,A4),I8)
4147        CALL DPWRST('XXX','WRIT')
4148        DO56I=1,N
4149          WRITE(ICOUT,57)I,Y(I),X(I)
4150   57     FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
4151          CALL DPWRST('XXX','WRIT')
4152   56   CONTINUE
4153      ENDIF
4154C
4155C               ********************************************
4156C               **  STEP 1--                              **
4157C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
4158C               ********************************************
4159C
4160      ISTEPN='6'
4161      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MRC2')
4162     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4163C
4164      NMIN=3
4165      IF(N.LE.NMIN)THEN
4166        WRITE(ICOUT,999)
4167        CALL DPWRST('XXX','WRIT')
4168        WRITE(ICOUT,101)
4169  101   FORMAT('***** ERROR IN RATIO OF MEANS CONFIDENCE LIMITS--')
4170        CALL DPWRST('XXX','WRIT')
4171        WRITE(ICOUT,103)
4172  103   FORMAT('      THE RESPONSE VARIABLES MUST HAVE AT LEAST ',
4173     1         I5,' OBSERVATIONS.')
4174        CALL DPWRST('XXX','WRIT')
4175        WRITE(ICOUT,105)IVARID(1),IVARI2(1),N
4176  105   FORMAT('      SAMPLE SIZE FOR ',A4,A4,' = ',I8)
4177        CALL DPWRST('XXX','WRIT')
4178        WRITE(ICOUT,105)IVARID(2),IVARI2(2),N
4179        CALL DPWRST('XXX','WRIT')
4180        IERROR='YES'
4181        GOTO9000
4182      ENDIF
4183C
4184C               ***************************************
4185C               **  STEP 2--                         **
4186C               **  COMPUTE CONFIDENCE LIMITS        **
4187C               **  FOR VARIOUS PROBABILITY VALUES.  **
4188C               ***************************************
4189C
4190      ISTEPN='8'
4191      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MRC2')
4192     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4193C
4194      IF(IRATME.EQ.'FIEL')THEN
4195        CALL DPMRC3(Y,X,N,CONF,NUMALP,
4196     1              RATIO,ALOWER,AUPPER,
4197     1              YBAR,XBAR,YVAR,XVAR,
4198     1              ISUBRO,IBUGA3,IERROR)
4199      ELSEIF(IRATME.EQ.'LSAM')THEN
4200        CALL DPMRC4(Y,X,N,CONF,NUMALP,
4201     1              RATIO,ALOWER,AUPPER,
4202     1              YBAR,XBAR,YVAR,XVAR,XYCOV,
4203     1              ISUBRO,IBUGA3,IERROR)
4204      ELSEIF(IRATME.EQ.'LRAT')THEN
4205        CALL DPMRC5(Y,X,N,CONF,NUMALP,
4206     1              RATIO,ALOWER,AUPPER,
4207     1              YBAR,XBAR,YVAR,XVAR,XYCOV,
4208     1              ISUBRO,IBUGA3,IERROR)
4209      ENDIF
4210      IF(IERROR.EQ.'YES')GOTO9000
4211C
4212      CALL CORR(Y,X,N,IWRITE,XYCORR,IBUGA3,IERROR)
4213C
4214      CUTL90=ALOWER(3)
4215      CUTU90=AUPPER(3)
4216      CUTL95=ALOWER(4)
4217      CUTU95=AUPPER(4)
4218      CUTL99=ALOWER(5)
4219      CUTU99=AUPPER(5)
4220      CTL999=ALOWER(6)
4221      CTU999=AUPPER(6)
4222C
4223C               ****************************
4224C               **  STEP 3--              **
4225C               **  WRITE EVERYTHING OUT  **
4226C               ****************************
4227C
4228      ISTEPN='3'
4229      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MRC2')
4230     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4231C
4232      IF(IPRINT.EQ.'OFF')GOTO9000
4233C
4234      ITITLE='Confidence Limits for the Ratio of Means'
4235      NCTITL=40
4236      IF(IRATME.EQ.'FIEL')THEN
4237        ITITLZ='(Fieller Method)'
4238        NCTITZ=16
4239      ELSEIF(IRATME.EQ.'LSAM')THEN
4240        ITITLZ='(Large Sample Approximation Method)'
4241        NCTITZ=35
4242      ELSEIF(IRATME.EQ.'LRAT')THEN
4243        ITITLZ='(Log Ratio Method)'
4244        NCTITZ=18
4245      ENDIF
4246C
4247      ICNT=1
4248      ITEXT(ICNT)=' '
4249      NCTEXT(ICNT)=0
4250      AVALUE(ICNT)=0.0
4251      IDIGIT(ICNT)=-1
4252      ICNT=ICNT+1
4253      ITEXT(ICNT)='Numerator Variable:   '
4254      WRITE(ITEXT(ICNT)(23:26),'(A4)')IVARID(1)(1:4)
4255      WRITE(ITEXT(ICNT)(27:30),'(A4)')IVARI2(1)(1:4)
4256      NCTEXT(ICNT)=29
4257      AVALUE(ICNT)=0.0
4258      IDIGIT(ICNT)=-1
4259      ICNT=ICNT+1
4260      ITEXT(ICNT)='Denominator Variable: '
4261      WRITE(ITEXT(ICNT)(23:26),'(A4)')IVARID(2)(1:4)
4262      WRITE(ITEXT(ICNT)(27:30),'(A4)')IVARI2(2)(1:4)
4263      NCTEXT(ICNT)=29
4264      AVALUE(ICNT)=0.0
4265      IDIGIT(ICNT)=-1
4266C
4267      ICNT=ICNT+1
4268      ITEXT(ICNT)=' '
4269      NCTEXT(ICNT)=1
4270      AVALUE(ICNT)=0.0
4271      IDIGIT(ICNT)=-1
4272C
4273      ICNT=ICNT+1
4274      ITEXT(ICNT)=' '
4275      NCTEXT(ICNT)=1
4276      AVALUE(ICNT)=0.0
4277      IDIGIT(ICNT)=-1
4278      ICNT=ICNT+1
4279      ITEXT(ICNT)='Summary Statistics for Numerator Variable:'
4280      NCTEXT(ICNT)=42
4281      AVALUE(ICNT)=0.0
4282      IDIGIT(ICNT)=-1
4283      ICNT=ICNT+1
4284      ITEXT(ICNT)='Number of Observations:'
4285      NCTEXT(ICNT)=23
4286      AVALUE(ICNT)=REAL(N)
4287      IDIGIT(ICNT)=0
4288      ICNT=ICNT+1
4289      ITEXT(ICNT)='Sample Mean:'
4290      NCTEXT(ICNT)=12
4291      AVALUE(ICNT)=YBAR
4292      IDIGIT(ICNT)=NUMDIG
4293      ICNT=ICNT+1
4294      ITEXT(ICNT)='Sample Standard Deviation:'
4295      NCTEXT(ICNT)=26
4296      AVALUE(ICNT)=SQRT(YVAR)
4297      IDIGIT(ICNT)=NUMDIG
4298      ICNT=ICNT+1
4299      ITEXT(ICNT)='Sample Coefficient of Variation:'
4300      NCTEXT(ICNT)=32
4301      AVALUE(ICNT)=SQRT(YVAR)/YBAR
4302      IDIGIT(ICNT)=NUMDIG
4303      ICNT=ICNT+1
4304      ITEXT(ICNT)=' '
4305      NCTEXT(ICNT)=1
4306      AVALUE(ICNT)=0.0
4307      IDIGIT(ICNT)=-1
4308      ICNT=ICNT+1
4309      ITEXT(ICNT)='Summary Statistics for Variable 2:'
4310      NCTEXT(ICNT)=34
4311      AVALUE(ICNT)=0.0
4312      IDIGIT(ICNT)=-1
4313      ICNT=ICNT+1
4314      ITEXT(ICNT)='Number of Observations:'
4315      NCTEXT(ICNT)=23
4316      AVALUE(ICNT)=REAL(N)
4317      IDIGIT(ICNT)=0
4318      ICNT=ICNT+1
4319      ITEXT(ICNT)='Sample Mean:'
4320      NCTEXT(ICNT)=12
4321      AVALUE(ICNT)=XBAR
4322      IDIGIT(ICNT)=NUMDIG
4323      ICNT=ICNT+1
4324      ITEXT(ICNT)='Sample Standard Deviation:'
4325      NCTEXT(ICNT)=26
4326      AVALUE(ICNT)=SQRT(XVAR)
4327      IDIGIT(ICNT)=NUMDIG
4328      ICNT=ICNT+1
4329      ITEXT(ICNT)='Sample Coefficient of Variation:'
4330      NCTEXT(ICNT)=32
4331      AVALUE(ICNT)=SQRT(XVAR)/XBAR
4332      IDIGIT(ICNT)=NUMDIG
4333      ICNT=ICNT+1
4334      ITEXT(ICNT)=' '
4335      NCTEXT(ICNT)=1
4336      AVALUE(ICNT)=0.0
4337      IDIGIT(ICNT)=-1
4338      ICNT=ICNT+1
4339      ITEXT(ICNT)='Correlation:'
4340      NCTEXT(ICNT)=12
4341      AVALUE(ICNT)=XYCORR
4342      IDIGIT(ICNT)=NUMDIG
4343      ICNT=ICNT+1
4344      ITEXT(ICNT)=' '
4345      NCTEXT(ICNT)=1
4346      AVALUE(ICNT)=0.0
4347      IDIGIT(ICNT)=-1
4348C
4349      NUMROW=ICNT
4350      DO5210I=1,NUMROW
4351        NTOT(I)=15
4352 5210 CONTINUE
4353C
4354      IFRST=.TRUE.
4355      ILAST=.TRUE.
4356C
4357      ISTEPN='3B'
4358      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MRC2')
4359     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4360C
4361      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
4362     1            AVALUE,IDIGIT,
4363     1            NTOT,NUMROW,
4364     1            ICAPSW,ICAPTY,ILAST,IFRST,
4365     1            ISUBRO,IBUGA3,IERROR)
4366C
4367      ISTEPN='9B'
4368      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MRC2')
4369     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4370C
4371      ICASA2='MRC2'
4372      DO390II=1,NUMALP
4373        TSDM(II)=RATIO
4374  390 CONTINUE
4375      CALL DPDT11(CONF,T,TSDM,ALOWER,AUPPER,
4376     1            ICASA2,ICAPSW,ICAPTY,NUMDIG,
4377     1            ISUBRO,IBUGA3,IERROR)
4378C
4379      GOTO9000
4380C
4381C               *****************
4382C               **  STEP 90--  **
4383C               **  EXIT       **
4384C               *****************
4385C
4386 9000 CONTINUE
4387      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'MRC2')THEN
4388        WRITE(ICOUT,999)
4389        CALL DPWRST('XXX','WRIT')
4390        WRITE(ICOUT,9011)
4391 9011   FORMAT('***** AT THE END       OF DPMRC2--')
4392        CALL DPWRST('XXX','WRIT')
4393        WRITE(ICOUT,9012)IERROR
4394 9012   FORMAT('IERROR = ',A4)
4395        CALL DPWRST('XXX','WRIT')
4396      ENDIF
4397C
4398      RETURN
4399      END
4400      SUBROUTINE DPMRC3(Y,X,N,ALPHA,NALPHA,
4401     1                  RATIO,ALOWLM,AUPPLM,
4402     1                  YBAR,XBAR,YVAR,XVAR,
4403     1                  ISUBRO,IBUGA3,IERROR)
4404C
4405C     PURPOSE--THIS SUBROUTINE COMPUTES CONFIDENCE LIMITS FOR THE
4406C              RATIO OF TWO MEANS FOR THE PAIRED CASE USING FIELLER'S
4407C              METHOD.
4408C
4409C              FIELLER'S CONFIDENCE LIMITS ARE
4410C
4411C                 (XBAR*YBAR - t**2(q)*COV(XBAR,YBAR) +/-
4412C                 SQRT{(XBAR*YBAR - t**2(q)*COV(XBAR,YBAR)**2 -
4413C                 (XBAR**2 - t**2(q)*S**2(XBAR))*
4414C                 (YBAR**2 - t**2(q)*S**2(YBAR))}
4415C
4416C
4417C              WHERE
4418C
4419C                 XBAR           = MEAN OF X
4420C                 YBAR           = MEAN OF Y
4421C                 RHO            = YBAR/XBAR
4422C                 S**2(XBAR)     = VARIANCE OF XBAR
4423C                                = SUM[i=1 to N][X(i) - XBAR)**2]/
4424C                                  (N*(N-1))
4425C                 S**2(YBAR)     = VARIANCE OF YBAR
4426C                                = SUM[i=1 to N][Y(i) - YBAR)**2]/
4427C                                  (N*(N-1))
4428C                 COV(XBAR,YBAR) = COVARIANCE OF XBAR AND YBAR
4429C                                = SUM[i=1 to N][(Y(i) - YBAR)*
4430C                                                (X(i)-XBAR)]/
4431C                                  (N*(N-1))
4432C                 t(q)           = t PERCENT POINT VALUE WITH
4433C                                  N - 1 DEGREES OF FREEDOM
4434C
4435C              NOTE THAT THE CONFIDENCE LIMITS CAN BE PROBLEMATIC.
4436C              SPECIFICALLY, IF XBAR IS SUFFICIENTLY CLOSE TO ZERO,
4437C              YOU CAN OBTAIN UNBOUNDED VALUES.  THIS CAN OCCUR
4438C              IF XBAR**2/S**2(XBAR) > t**2(q).  NOTE THAT THERE ARE
4439C              TWO CASES THAT RESULT.  IN ONE CASE, THE BOUNDS ABOVE
4440C              ACTUALLY DESCRIBE AN "EXCLUSION ZONE" RATHER THAN AN
4441C              "INCLUSION ZONE".  THAT IS, THE VALUES BETWEEN THE
4442C              BOUNDS ARE WHERE WE ARE CONFIDENT THAT THE RATIO DOES
4443C              NOT LIE RATHER THAN WERE IT DOES LIE.  IN THE SECOND
4444C              CASE, THE CONFIDENCE BOUNDS ARE UNBOUNDED.  FOR
4445C              PRACTICAL PURPOSES, NEITHER OF THESE CASES WILL
4446C              GENERATE USEFUL CONFIDENCE LIMITS, SO JUST REPORT
4447C              AS UNBOUNDED IN EITHER CASE.
4448C
4449C
4450C     INPUT ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR OF
4451C                               OBSERVATIONS FOR THE FIRST RESPONSE
4452C                               (NUMERATOR) VARIABLE.
4453C                    --X      = THE SINGLE PRECISION VECTOR OF
4454C                               OBSERVATIONS FOR THE SECOND RESPONSE
4455C                               (DENOMINATOR) VARIABLE.
4456C                    --N      = THE INTEGER NUMBER OF OBSERVATIONS
4457C                               IN THE VECTORS Y AND X.
4458C                    --ALPHA  = THE SINGLE PRECISION VECTOR OF CONFIDENCE
4459C                               LEVELS
4460C                      NALPHA = THE INTEGER NUMBER OF ALPHA VALUES
4461C     OUTPUT ARGUMENTS-RATIO  = YBAR/XBAR
4462C                     -YLOWLM = THE SINGLE PRECISION VECTOR OF LOWER
4463C                               CONFIDENCE LIMIT VALUES
4464C                     -YUPPLM = THE SINGLE PRECISION VECTOR OF UPPER
4465C                               CONFIDENCE LIMIT VALUES
4466C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
4467C     FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT.
4468C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
4469C     LANGUAGE--ANSI FORTRAN.
4470C     REFERENCES--V. H. FRANZ ((2007), "RATIOS: A SHORT GUIDE TO
4471C                 CONFIDENCE LIMITS AND PROPER USE",
4472C                 arXiv:0710.2024 [stat.AP].
4473C               --E. C. FIELER (1940), "THE BIOLOGICAL STANDARDIZATION
4474C                 OF INSULIN", SUPPLEMENT TO THE JOURNAL OF THE
4475C                 ROYAL STATISTICAL SOCIETY, VOL. 7, NO. 1, PP. 1-64.
4476C               --E. C. FIELER (1940), "A FUNDAMENTAL FORMULA IN THE
4477C                 STATISTICS OF BIOLOGICAL ASSAYS AND SOME
4478C                 APPLICAITONS", QUARTERLY JOURNAL OF PHARMACY AND
4479C                 PHARMACOLOGY, VOL. 17, PP. 117-123.
4480C               --E. C. FIELER (1940), "SOME PROBLEMS IN INTERVAL
4481C                 ESTIMATION", JOURNAL OF THE ROYAL STATISTICAL
4482C                 SOCIETY (B), VOL. 16, NO. 2, PP. 175-185.
4483C     WRITTEN BY--ALAN HECKERT
4484C                 STATISTICAL ENGINEERING LABORATORY
4485C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
4486C                 GAITHERSBURG, MD 20899-8980
4487C                 PHONE--301-975-2899
4488C     ORIGINAL VERSION--SEPTEMBER 2019.
4489C
4490C---------------------------------------------------------------------
4491C
4492      DIMENSION Y(*)
4493      DIMENSION X(*)
4494      DIMENSION ALOWLM(*)
4495      DIMENSION AUPPLM(*)
4496      DIMENSION ALPHA(*)
4497C
4498      CHARACTER*4 ISUBRO
4499      CHARACTER*4 IBUGA3
4500      CHARACTER*4 IERROR
4501C
4502      CHARACTER*4 IWRITE
4503      CHARACTER*4 ISUBN1
4504      CHARACTER*4 ISUBN2
4505      CHARACTER*4 ISTEPN
4506C
4507CCCCC DOUBLE PRECISION DSUM1
4508CCCCC DOUBLE PRECISION DSUM2
4509CCCCC DOUBLE PRECISION DSUM3
4510      DOUBLE PRECISION DN
4511      DOUBLE PRECISION DNM1
4512      DOUBLE PRECISION DVAL
4513      DOUBLE PRECISION DTQ
4514      DOUBLE PRECISION DLOW
4515      DOUBLE PRECISION DUPP
4516CCCCC DOUBLE PRECISION DX
4517CCCCC DOUBLE PRECISION DY
4518      DOUBLE PRECISION DCOVXY
4519      DOUBLE PRECISION DYBAR
4520      DOUBLE PRECISION DXBAR
4521      DOUBLE PRECISION DYVARB
4522      DOUBLE PRECISION DXVARB
4523      DOUBLE PRECISION DRATIO
4524      DOUBLE PRECISION DTERM1
4525      DOUBLE PRECISION DTERM2
4526      DOUBLE PRECISION DTERM3
4527      DOUBLE PRECISION DTERM4
4528      DOUBLE PRECISION DNUML
4529      DOUBLE PRECISION DNUMU
4530C
4531      INCLUDE 'DPCOP2.INC'
4532C
4533C-----START POINT-----------------------------------------------------
4534C
4535      ISUBN1='MRC3'
4536      ISUBN2='    '
4537      IWRITE='OFF'
4538      IERROR='NO'
4539      DO10I=1,NALPHA
4540        ALOWLM(I)=CPUMIN
4541        AUPPLM(I)=CPUMIN
4542   10 CONTINUE
4543      RATIO=CPUMIN
4544C
4545      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MRC3')THEN
4546        WRITE(ICOUT,999)
4547  999   FORMAT(1X)
4548        CALL DPWRST('XXX','WRIT')
4549        WRITE(ICOUT,51)
4550   51   FORMAT('**** AT THE BEGINNING OF DPMRC3--')
4551        CALL DPWRST('XXX','WRIT')
4552        WRITE(ICOUT,52)IBUGA3,ISUBRO,N,NALPHA
4553   52   FORMAT('IBUGA3,ISUBRO,N,NALPHA = ',2(A4,2X),I8,I5)
4554        CALL DPWRST('XXX','WRIT')
4555        DO56I=1,N
4556          WRITE(ICOUT,57)I,Y(I),X(I)
4557   57     FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
4558          CALL DPWRST('XXX','WRIT')
4559   56   CONTINUE
4560        DO76I=1,NALPHA
4561          WRITE(ICOUT,77)I,ALPHA(I)
4562   77     FORMAT('I,ALPHA(I) = ',I8,G15.7)
4563          CALL DPWRST('XXX','WRIT')
4564   76   CONTINUE
4565      ENDIF
4566C
4567C               ********************************************
4568C               **  STEP 1--                              **
4569C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
4570C               ********************************************
4571C
4572      ISTEPN='1'
4573      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MRC3')
4574     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4575C
4576      DO110I=1,NALPHA
4577        ALOWLM(I)=CPUMIN
4578        AUPPLM(I)=CPUMIN
4579  110 CONTINUE
4580C
4581      NMIN=3
4582      IF(NMIN.LT.3)THEN
4583        WRITE(ICOUT,999)
4584        CALL DPWRST('XXX','WRIT')
4585        WRITE(ICOUT,101)
4586  101   FORMAT('***** ERROR: RATIO OF MEANS CONFIDENCE LIMITS--')
4587        CALL DPWRST('XXX','WRIT')
4588        WRITE(ICOUT,102)NMIN
4589  102   FORMAT('      THE NUMBER OF ORIGINAL OBSERVATIONS  IS LESS ',
4590     1         'THAN ',I3,'.')
4591        CALL DPWRST('XXX','WRIT')
4592        WRITE(ICOUT,103)N
4593  103   FORMAT('      SAMPLE SIZE = ',I8)
4594        CALL DPWRST('XXX','WRIT')
4595        IERROR='YES'
4596        GOTO9000
4597      ENDIF
4598C
4599C               ********************************************
4600C               **  STEP 2--                              **
4601C               **  COMPUTE SOME BASIC STATISTICS         **
4602C               ********************************************
4603C
4604      ISTEPN='2'
4605      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MRC3')
4606     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4607C
4608      DN=DBLE(N)
4609      DNM1=DBLE(N-1)
4610      CALL MEAN(Y,N,IWRITE,YBAR,IBUGA3,IERROR)
4611      CALL VAR(Y,N,IWRITE,YVAR,IBUGA3,IERROR)
4612      CALL MEAN(X,N,IWRITE,XBAR,IBUGA3,IERROR)
4613      CALL VAR(X,N,IWRITE,XVAR,IBUGA3,IERROR)
4614      CALL COV(Y,X,N,IWRITE,XYCOV,IBUGA3,IERROR)
4615      DYBAR=DBLE(YBAR)
4616      DXBAR=DBLE(XBAR)
4617      DYVAR=DBLE(YVAR)
4618      DXVAR=DBLE(XVAR)
4619      DYVARB=DYVAR/DN
4620      DXVARB=DXVAR/DN
4621      DCOVXY=DBLE(XYCOV)/DN
4622C
4623C
4624      IF(DYVARB.LE.0.0D0)THEN
4625        WRITE(ICOUT,999)
4626        CALL DPWRST('XXX','WRIT')
4627        WRITE(ICOUT,101)
4628        CALL DPWRST('XXX','WRIT')
4629        WRITE(ICOUT,131)
4630  131   FORMAT('      VARIANCE OF MEAN FOR FIRST (NUMERATOR) RESPONSE ',
4631     1             'IS NON-POSITIVE.')
4632        CALL DPWRST('XXX','WRIT')
4633        IERROR='YES'
4634        GOTO9000
4635      ELSEIF(DXVARB.LE.0.0D0)THEN
4636        WRITE(ICOUT,999)
4637        CALL DPWRST('XXX','WRIT')
4638        WRITE(ICOUT,101)
4639        CALL DPWRST('XXX','WRIT')
4640        WRITE(ICOUT,136)
4641  136   FORMAT('      VARIANCE OF MEAN FOR SECOND (DENOMINATOR) ',
4642     1         'RESPONSE VARIABLE IS NON-POSITIVE.')
4643        CALL DPWRST('XXX','WRIT')
4644        IERROR='YES'
4645        GOTO9000
4646      ELSEIF(DXBAR.EQ.0.0D0)THEN
4647        WRITE(ICOUT,999)
4648        CALL DPWRST('XXX','WRIT')
4649        WRITE(ICOUT,101)
4650        CALL DPWRST('XXX','WRIT')
4651        WRITE(ICOUT,141)
4652  141   FORMAT('      THE MEAN OF THE DENOMINATOR VARIABLE IS ',
4653     1         'EQUAL TO ZERO.')
4654        CALL DPWRST('XXX','WRIT')
4655        IERROR='YES'
4656        GOTO9000
4657      ENDIF
4658C
4659      IF(IBUGA3.EQ.'ON'.AND.ISUBRO.EQ.'MRC3')THEN
4660        WRITE(ICOUT,191)YBAR,XBAR,YVAR,XVAR
4661  191   FORMAT('YBAR,XBAR,YVAR,XVAR = ',4G15.7)
4662        CALL DPWRST('XXX','WRIT')
4663        WRITE(ICOUT,193)DYVARB,DXVARB,XYCOV,DCOVXY
4664  193   FORMAT('DYVARB,DXVARB,XYCOV,DCOVXY = ',G15.7)
4665        CALL DPWRST('XXX','WRIT')
4666      ENDIF
4667C
4668C               ********************************************
4669C               **  STEP 3--                              **
4670C               **  CARRY OUT CALCULATIONS FOR CONFIDENCE **
4671C               **  LIMITS.                               **
4672C               ********************************************
4673C
4674      ISTEPN='3'
4675      IF(IBUGA3.EQ.'ON'.AND.ISUBRO.EQ.'MRC3')
4676     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4677C
4678      DRATIO=DYBAR/DXBAR
4679      RATIO=REAL(DRATIO)
4680      ADF=REAL(N-1)
4681C
4682      DO310II=1,NALPHA
4683        ALPT=ALPHA(II)
4684        IF(ALPT.GT.1.0 .AND. ALPT.LT.100.0)ALPT=ALPT/100.0
4685        IF(ALPT.LE.0.0 .OR. ALPT.GT.1.0)THEN
4686          WRITE(ICOUT,999)
4687          CALL DPWRST('XXX','WRIT')
4688          WRITE(ICOUT,101)
4689          CALL DPWRST('XXX','WRIT')
4690          WRITE(ICOUT,311)ALPHA(II)
4691  311     FORMAT('      INVALID VALUE OF ALPHA (',G15.7,'),')
4692          CALL DPWRST('XXX','WRIT')
4693          IERROR='YES'
4694          GOTO9000
4695        ENDIF
4696        IF(ALPT.LT.0.5)ALPT=1.0 - ALPT
4697        ALPT=(1.0 - ALPT)/2.0
4698        ALPT=1.0 - ALPT
4699        CALL TPPF(ALPT,ADF,TPPFV)
4700        DTQ=DBLE(TPPFV)**2
4701C
4702C       TEST TO SEE IF WE HAVE THE BOUNDED CASE
4703C
4704        DVAL=DXBAR**2/DXVARB
4705        IF(DVAL.LE.DTQ)THEN
4706          IF(IFEEDB.EQ.'ON')THEN
4707            WRITE(ICOUT,999)
4708            CALL DPWRST('XXX','WRIT')
4709            WRITE(ICOUT,315)
4710  315       FORMAT('***** WARNING: RATIO OF MEANS CONFIDENCE LIMITS--')
4711            CALL DPWRST('XXX','WRIT')
4712            WRITE(ICOUT,316)ALPHA(II)
4713  316       FORMAT('      FOR ALPHA (',G15.7,'), THE FIELLER INTERVAL ',
4714     1             'IS UNBOUNDED.')
4715            CALL DPWRST('XXX','WRIT')
4716          ENDIF
4717          GOTO310
4718        ENDIF
4719C
4720C       NOW COMPUTE THE BOUNDS
4721C
4722        DTERM1=DYBAR*DXBAR - DTQ*DCOVXY
4723        DTERM2=(DYBAR*DXBAR - DTQ*DCOVXY)**2
4724        DTERM3=(DXBAR**2 - DTQ*DXVARB)*(DYBAR**2 - DTQ*DYVARB)
4725        DTERM4=DXBAR**2 - DTQ*DXVARB
4726        DNUML=DTERM1 - DSQRT(DTERM2 - DTERM3)
4727        DNUMU=DTERM1 + DSQRT(DTERM2 - DTERM3)
4728        DLOW=DNUML/DTERM4
4729        DUPP=DNUMU/DTERM4
4730        ALOWLM(II)=REAL(DLOW)
4731        AUPPLM(II)=REAL(DUPP)
4732C
4733        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'MRC3')THEN
4734          WRITE(ICOUT,999)
4735          CALL DPWRST('XXX','WRIT')
4736          WRITE(ICOUT,331)DTERM1,DTERM2,DTERM3,DTERM4,DTQ
4737  331     FORMAT('DTERM1,DTERM2,DTERM3,DTERM4,DTQ = ',5G15.7)
4738          CALL DPWRST('XXX','WRIT')
4739          WRITE(ICOUT,333)DNUML,DNUMU,DLOW,DUPP
4740  333     FORMAT('DNUML,DNUMU,DLOW,DUPP = ',4G15.7)
4741          CALL DPWRST('XXX','WRIT')
4742        ENDIF
4743C
4744  310 CONTINUE
4745C
4746 9000 CONTINUE
4747      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'MRC3')THEN
4748        WRITE(ICOUT,999)
4749        CALL DPWRST('XXX','WRIT')
4750        WRITE(ICOUT,9051)
4751 9051   FORMAT('**** AT THE END OF DPMRC3--')
4752        CALL DPWRST('XXX','WRIT')
4753      ENDIF
4754C
4755      RETURN
4756      END
4757      SUBROUTINE DPMRC4(Y,X,N,ALPHA,NALPHA,
4758     1                  RATIO,ALOWLM,AUPPLM,
4759     1                  YBAR,XBAR,YVAR,XVAR,COVXY,
4760     1                  ISUBRO,IBUGA3,IERROR)
4761C
4762C     PURPOSE--THIS SUBROUTINE COMPUTES CONFIDENCE LIMITS FOR THE
4763C              RATIO OF TWO MEANS FOR THE PAIRED CASE USING A LARGE
4764C              SAMPLE APPROXIMATION METHOD.
4765C
4766C              THE CONFIDENCE LIMITS ARE
4767C
4768C                 Ic = R +/- t(alpha/2,n-1)*R*
4769C                      SQRT{C(YBAR,YBAR) + C(XBAR,XBAR) -
4770C                           2*C(YBAR,XBAR)}
4771C
4772C              WHERE
4773C
4774C                 XBAR          = MEAN OF X
4775C                 YBAR          = MEAN OF Y
4776C                 RHO           = YBAR/XBAR
4777C                 C(YBAR,YBAR)  = (S**2(Y)/YBAR**2)/N
4778C                 C(XBAR,XBAR)  = (S**2(X)/XBAR**2)/N
4779C                 C(XBAR,YBAR)  = (S(X,Y)/(XBAR*YBAR)/N
4780C                 S**2(Y)       = VARIANCE OF Y
4781C                 S**2(X)       = VARIANCE OF X
4782C                 S(X,Y)        = COVARIANCE OF Y AND X
4783C                 t             = t PERCENT POINT VALUE WITH
4784C
4785C              NOTE THAT THIS METHOD, UNLIKE FIELER'S METHOD,
4786C              DOES NOT RESULT IN UNBOUNDED CONFIDENCE LIMITS.
4787C
4788C
4789C     INPUT ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR OF
4790C                               OBSERVATIONS FOR THE FIRST RESPONSE
4791C                               (NUMERATOR) VARIABLE.
4792C                    --X      = THE SINGLE PRECISION VECTOR OF
4793C                               OBSERVATIONS FOR THE SECOND RESPONSE
4794C                               (DENOMINATOR) VARIABLE.
4795C                    --N      = THE INTEGER NUMBER OF OBSERVATIONS
4796C                               IN THE VECTORS Y AND X.
4797C                    --ALPHA  = THE SINGLE PRECISION VECTOR OF CONFIDENCE
4798C                               LEVELS
4799C                      NALPHA = THE INTEGER NUMBER OF ALPHA VALUES
4800C     OUTPUT ARGUMENTS-RATIO  = YBAR/XBAR
4801C                     -YLOWLM = THE SINGLE PRECISION VECTOR OF LOWER
4802C                               CONFIDENCE LIMIT VALUES
4803C                     -YUPPLM = THE SINGLE PRECISION VECTOR OF UPPER
4804C                               CONFIDENCE LIMIT VALUES
4805C     OTHER DATAPAC   SUBROUTINES NEEDED--MEAN, VARIANCE, COV.
4806C     FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT.
4807C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
4808C     LANGUAGE--ANSI FORTRAN.
4809C     REFERENCES--SHERMAN, MAITY, AND WANG (2011), "INFERENCES FOR THE
4810C                 RATIO: FIELLER'S INTERVAL, LOG RATIO, AND LARGE
4811C                 SAMPLE BASED CONFIDENCE INTERVALS", AStA Adv Stat Anal
4812C                 95:313–323.
4813C               --COCHRAN (1977), "SAMPLING TECHNIQUES", WILEY, NEW YORK.
4814C               --LOHR (2009), "SAMPLING: DESIGN AND ANALYSIS",
4815C                 Second Edition, BROOKS/COLE, PACIFIC GROVE.
4816C     WRITTEN BY--ALAN HECKERT
4817C                 STATISTICAL ENGINEERING LABORATORY
4818C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
4819C                 GAITHERSBURG, MD 20899-8980
4820C                 PHONE--301-975-2899
4821C     ORIGINAL VERSION--SEPTEMBER 2019.
4822C
4823C---------------------------------------------------------------------
4824C
4825      DIMENSION Y(*)
4826      DIMENSION X(*)
4827      DIMENSION ALOWLM(*)
4828      DIMENSION AUPPLM(*)
4829      DIMENSION ALPHA(*)
4830C
4831      CHARACTER*4 ISUBRO
4832      CHARACTER*4 IBUGA3
4833      CHARACTER*4 IERROR
4834C
4835      CHARACTER*4 IWRITE
4836      CHARACTER*4 ISUBN1
4837      CHARACTER*4 ISUBN2
4838      CHARACTER*4 ISTEPN
4839C
4840      DOUBLE PRECISION DN
4841      DOUBLE PRECISION DR
4842      DOUBLE PRECISION DXBAR
4843      DOUBLE PRECISION DYBAR
4844      DOUBLE PRECISION DXVAR
4845      DOUBLE PRECISION DYVAR
4846      DOUBLE PRECISION DCOV
4847      DOUBLE PRECISION DCXX
4848      DOUBLE PRECISION DCYY
4849      DOUBLE PRECISION DCXY
4850      DOUBLE PRECISION DTERM1
4851C
4852      INCLUDE 'DPCOP2.INC'
4853C
4854C-----START POINT-----------------------------------------------------
4855C
4856      ISUBN1='MRC4'
4857      ISUBN2='    '
4858      IWRITE='OFF'
4859      IERROR='NO'
4860      DO10I=1,NALPHA
4861        ALOWLM(I)=CPUMIN
4862        AUPPLM(I)=CPUMIN
4863   10 CONTINUE
4864      RATIO=CPUMIN
4865      COVXY=CPUMIN
4866C
4867      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MRC4')THEN
4868        WRITE(ICOUT,999)
4869  999   FORMAT(1X)
4870        CALL DPWRST('XXX','WRIT')
4871        WRITE(ICOUT,51)
4872   51   FORMAT('**** AT THE BEGINNING OF DPMRC4--')
4873        CALL DPWRST('XXX','WRIT')
4874        WRITE(ICOUT,52)IBUGA3,ISUBRO,N,NALPHA
4875   52   FORMAT('IBUGA3,ISUBRO,N,NALPHA = ',2(A4,2X),I8,I5)
4876        CALL DPWRST('XXX','WRIT')
4877        DO56I=1,N
4878          WRITE(ICOUT,57)I,Y(I),X(I)
4879   57     FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
4880          CALL DPWRST('XXX','WRIT')
4881   56   CONTINUE
4882        DO76I=1,NALPHA
4883          WRITE(ICOUT,77)I,ALPHA(I)
4884   77     FORMAT('I,ALPHA(I) = ',I8,G15.7)
4885          CALL DPWRST('XXX','WRIT')
4886   76   CONTINUE
4887      ENDIF
4888C
4889C               ********************************************
4890C               **  STEP 1--                              **
4891C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
4892C               ********************************************
4893C
4894      ISTEPN='1'
4895      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MRC4')
4896     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4897C
4898      DO110I=1,NALPHA
4899        ALOWLM(I)=CPUMIN
4900        AUPPLM(I)=CPUMIN
4901  110 CONTINUE
4902C
4903      NMIN=5
4904      IF(NMIN.LT.5)THEN
4905        WRITE(ICOUT,999)
4906        CALL DPWRST('XXX','WRIT')
4907        WRITE(ICOUT,101)
4908  101   FORMAT('***** ERROR: RATIO OF MEANS CONFIDENCE LIMITS--')
4909        CALL DPWRST('XXX','WRIT')
4910        WRITE(ICOUT,102)NMIN
4911  102   FORMAT('      THE NUMBER OF ORIGINAL OBSERVATIONS  IS LESS ',
4912     1         'THAN ',I3,'.')
4913        CALL DPWRST('XXX','WRIT')
4914        WRITE(ICOUT,103)N
4915  103   FORMAT('      SAMPLE SIZE = ',I8)
4916        CALL DPWRST('XXX','WRIT')
4917        IERROR='YES'
4918        GOTO9000
4919      ENDIF
4920C
4921C               ********************************************
4922C               **  STEP 2--                              **
4923C               **  COMPUTE SOME BASIC STATISTICS         **
4924C               ********************************************
4925C
4926      ISTEPN='2'
4927      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MRC4')
4928     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4929C
4930      CALL MEAN(Y,N,IWRITE,YBAR,IBUGA3,IERROR)
4931      CALL VAR(Y,N,IWRITE,YVAR,IBUGA3,IERROR)
4932      CALL MEAN(X,N,IWRITE,XBAR,IBUGA3,IERROR)
4933      CALL VAR(X,N,IWRITE,XVAR,IBUGA3,IERROR)
4934      CALL COV(Y,X,N,IWRITE,XYCOV,IBUGA3,IERROR)
4935C
4936      IF(YVAR.LE.0.0)THEN
4937        WRITE(ICOUT,999)
4938        CALL DPWRST('XXX','WRIT')
4939        WRITE(ICOUT,101)
4940        CALL DPWRST('XXX','WRIT')
4941        WRITE(ICOUT,131)
4942  131   FORMAT('      VARIANCE OF MEAN FOR FIRST (NUMERATOR) RESPONSE ',
4943     1             'IS NON-POSITIVE.')
4944        CALL DPWRST('XXX','WRIT')
4945        IERROR='YES'
4946        GOTO9000
4947      ELSEIF(XVAR.LE.0.0)THEN
4948        WRITE(ICOUT,999)
4949        CALL DPWRST('XXX','WRIT')
4950        WRITE(ICOUT,101)
4951        CALL DPWRST('XXX','WRIT')
4952        WRITE(ICOUT,136)
4953  136   FORMAT('      VARIANCE OF MEAN FOR SECOND (DENOMINATOR) ',
4954     1         'RESPONSE VARIABLE IS NON-POSITIVE.')
4955        CALL DPWRST('XXX','WRIT')
4956        IERROR='YES'
4957        GOTO9000
4958      ELSEIF(XBAR.EQ.0.0)THEN
4959        WRITE(ICOUT,999)
4960        CALL DPWRST('XXX','WRIT')
4961        WRITE(ICOUT,101)
4962        CALL DPWRST('XXX','WRIT')
4963        WRITE(ICOUT,141)
4964  141   FORMAT('      THE MEAN OF THE DENOMINATOR VARIABLE IS ',
4965     1         'EQUAL TO ZERO.')
4966        CALL DPWRST('XXX','WRIT')
4967        IERROR='YES'
4968        GOTO9000
4969      ENDIF
4970C
4971      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MRC4')THEN
4972        WRITE(ICOUT,191)YBAR,YVAR,XBAR,XVAR,XYCOV
4973  191   FORMAT('YBAR,YVAR,XBAR,XVAR,XYCOV = ',5G15.7)
4974        CALL DPWRST('XXX','WRIT')
4975      ENDIF
4976C
4977C               ********************************************
4978C               **  STEP 3--                              **
4979C               **  CARRY OUT CALCULATIONS FOR CONFIDENCE **
4980C               **  LIMITS.                               **
4981C               ********************************************
4982C
4983      ISTEPN='3'
4984      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MRC4')
4985     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4986C
4987      RATIO=YBAR/XBAR
4988      ADF=REAL(N-1)
4989      DN=DBLE(N)
4990      DR=DBLE(RATIO)
4991      DXBAR=DBLE(XBAR)
4992      DYBAR=DBLE(YBAR)
4993      DYVAR=DBLE(YVAR)
4994      DXVAR=DBLE(XVAR)
4995      DCOV=DBLE(XYCOV)
4996      DCYY=(DYVAR/DYBAR**2)/DN
4997      DCXX=(DXVAR/DXBAR**2)/DN
4998      DCXY=(DCOV/(DXBAR*DYBAR))/DN
4999      DTERM1=DR*DSQRT(DCYY + DCXX - 2.0D0*DCXY)
5000C
5001      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'MRC4')THEN
5002        WRITE(ICOUT,999)
5003        CALL DPWRST('XXX','WRIT')
5004        WRITE(ICOUT,301)DR,DCYY,DCXX,DCXY,DTERM1
5005  301   FORMAT('DR,DCYY,DCXX,DCXY,DTERM1 = ',5G15.7)
5006        CALL DPWRST('XXX','WRIT')
5007      ENDIF
5008C
5009      DO310II=1,NALPHA
5010        ALPT=ALPHA(II)
5011        IF(ALPT.GT.1.0 .AND. ALPT.LT.100.0)ALPT=ALPT/100.0
5012        IF(ALPT.LE.0.0 .OR. ALPT.GE.1.0)THEN
5013          WRITE(ICOUT,999)
5014          CALL DPWRST('XXX','WRIT')
5015          WRITE(ICOUT,101)
5016          CALL DPWRST('XXX','WRIT')
5017          WRITE(ICOUT,311)ALPHA(II)
5018  311     FORMAT('      INVALID VALUE OF ALPHA (',G15.7,'),')
5019          CALL DPWRST('XXX','WRIT')
5020          IERROR='YES'
5021          GOTO9000
5022        ENDIF
5023        IF(ALPT.LT.0.5)ALPT=1.0 - ALPT
5024        ALPT=(1.0 - ALPT)/2.0
5025        ALPT=1.0 - ALPT
5026        CALL TPPF(ALPT,ADF,TPPFV)
5027        DT=DBLE(TPPFV)
5028        DLOW=DR - DT*DTERM1
5029        DUPP=DR + DT*DTERM1
5030        ALOWLM(II)=REAL(DLOW)
5031        AUPPLM(II)=REAL(DUPP)
5032C
5033        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'MRC4')THEN
5034          WRITE(ICOUT,999)
5035          CALL DPWRST('XXX','WRIT')
5036          WRITE(ICOUT,333)DT,DLOW,DUPP
5037  333     FORMAT('DT,DLOW,DUPP = ',3G15.7)
5038          CALL DPWRST('XXX','WRIT')
5039        ENDIF
5040C
5041  310 CONTINUE
5042C
5043 9000 CONTINUE
5044      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'MRC4')THEN
5045        WRITE(ICOUT,999)
5046        CALL DPWRST('XXX','WRIT')
5047        WRITE(ICOUT,9051)
5048 9051   FORMAT('**** AT THE END OF DPMRC4--')
5049        CALL DPWRST('XXX','WRIT')
5050      ENDIF
5051C
5052      RETURN
5053      END
5054      SUBROUTINE DPMRC5(Y,X,N,ALPHA,NALPHA,
5055     1                  RATIO,ALOWLM,AUPPLM,
5056     1                  YBAR,XBAR,YVAR,XVAR,XYCOV,
5057     1                  ISUBRO,IBUGA3,IERROR)
5058C
5059C     PURPOSE--THIS SUBROUTINE COMPUTES CONFIDENCE LIMITS FOR THE
5060C              RATIO OF TWO MEANS FOR THE PAIRED CASE USING THE
5061C              LOG RATIO METHOD.
5062C
5063C              THE CONFIDENCE LIMITS ARE
5064C
5065C                 Ilr = (R*EXP{-t(alpha/2,n-1)*
5066C                       SQRT{C(YBAR,YBAR) + C(XBAR,XBAR) -
5067C                           2*C(YBAR,XBAR)},
5068C                        R*EXP{t(alpha/2,n-1)*
5069C                       SQRT{C(YBAR,YBAR) + C(XBAR,XBAR) -
5070C                           2*C(YBAR,XBAR)},
5071C
5072C              WHERE
5073C
5074C                 XBAR           = MEAN OF X
5075C                 YBAR           = MEAN OF Y
5076C                 R              = YBAR/XBAR
5077C                 C(YBAR,YBAR)   = (S**2(Y)/YBAR**2)/N
5078C                 C(XBAR,XBAR)   = (S**2(X)/XBAR**2)/N
5079C                 C(XBAR,YBAR)   = (S(X,Y)/(XBAR*YBAR)/N
5080C                 S**2(Y)        = VARIANCE OF Y
5081C                 S**2(X)        = VARIANCE OF X
5082C                 S(XBAR,YBAR)   = COVARIANCE OF Y AND X
5083C                 t              = t PERCENT POINT VALUE WITH
5084C
5085C              NOTE THAT THIS METHOD, UNLIKE FIELER'S METHOD,
5086C              DOES NOT RESULT IN UNBOUNDED CONFIDENCE LIMITS.
5087C              IT ALSO ALLOWS FOR ASYMMETRIC INTERVALS (UNLIKE
5088C              THE LARGE SAMPLE APPROXIMATION METHOD).
5089C
5090C
5091C     INPUT ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR OF
5092C                               OBSERVATIONS FOR THE FIRST RESPONSE
5093C                               (NUMERATOR) VARIABLE.
5094C                    --X      = THE SINGLE PRECISION VECTOR OF
5095C                               OBSERVATIONS FOR THE SECOND RESPONSE
5096C                               (DENOMINATOR) VARIABLE.
5097C                    --N      = THE INTEGER NUMBER OF OBSERVATIONS
5098C                               IN THE VECTORS Y AND X.
5099C                    --ALPHA  = THE SINGLE PRECISION VECTOR OF CONFIDENCE
5100C                               LEVELS
5101C                      NALPHA = THE INTEGER NUMBER OF ALPHA VALUES
5102C     OUTPUT ARGUMENTS-RATIO  = YBAR/XBAR
5103C                     -YLOWLM = THE SINGLE PRECISION VECTOR OF LOWER
5104C                               CONFIDENCE LIMIT VALUES
5105C                     -YUPPLM = THE SINGLE PRECISION VECTOR OF UPPER
5106C                               CONFIDENCE LIMIT VALUES
5107C     OTHER DATAPAC   SUBROUTINES NEEDED--MEAN, VARIANCE, COV.
5108C     FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT.
5109C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
5110C     LANGUAGE--ANSI FORTRAN.
5111C     REFERENCES--SHERMAN, MAITY, AND WANG (2011), "INFERENCES FOR THE
5112C                 RATIO: FIELLER'S INTERVAL, LOG RATIO, AND LARGE
5113C                 SAMPLE BASED CONFIDENCE INTERVALS", AStA Adv Stat Anal
5114C                 95:313–323.
5115C               --COCHRAN (1977), "SAMPLING TECHNIQUES", WILEY, NEW YORK.
5116C               --LOHR (2009), "SAMPLING: DESIGN AND ANALYSIS",
5117C                 Second Edition, BROOKS/COLE, PACIFIC GROVE.
5118C     WRITTEN BY--ALAN HECKERT
5119C                 STATISTICAL ENGINEERING LABORATORY
5120C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
5121C                 GAITHERSBURG, MD 20899-8980
5122C                 PHONE--301-975-2899
5123C     ORIGINAL VERSION--SEPTEMBER 2019.
5124C
5125C---------------------------------------------------------------------
5126C
5127      DIMENSION Y(*)
5128      DIMENSION X(*)
5129      DIMENSION ALOWLM(*)
5130      DIMENSION AUPPLM(*)
5131      DIMENSION ALPHA(*)
5132C
5133      CHARACTER*4 ISUBRO
5134      CHARACTER*4 IBUGA3
5135      CHARACTER*4 IERROR
5136C
5137      CHARACTER*4 IWRITE
5138      CHARACTER*4 ISUBN1
5139      CHARACTER*4 ISUBN2
5140      CHARACTER*4 ISTEPN
5141C
5142CCCCC DOUBLE PRECISION DSUM1
5143CCCCC DOUBLE PRECISION DSUM2
5144CCCCC DOUBLE PRECISION DSUM3
5145      DOUBLE PRECISION DN
5146CCCCC DOUBLE PRECISION DNM1
5147CCCCC DOUBLE PRECISION DVAL
5148CCCCC DOUBLE PRECISION DTQ
5149      DOUBLE PRECISION DLOW
5150      DOUBLE PRECISION DUPP
5151CCCCC DOUBLE PRECISION DX
5152CCCCC DOUBLE PRECISION DY
5153      DOUBLE PRECISION DTERM1
5154CCCCC DOUBLE PRECISION DTERM2
5155CCCCC DOUBLE PRECISION DTERM3
5156CCCCC DOUBLE PRECISION DTERM4
5157CCCCC DOUBLE PRECISION DTERM5
5158CCCCC DOUBLE PRECISION DTERM6
5159CCCCC DOUBLE PRECISION DTERM7
5160C
5161      INCLUDE 'DPCOP2.INC'
5162C
5163C-----START POINT-----------------------------------------------------
5164C
5165      ISUBN1='MRC5'
5166      ISUBN2='    '
5167      IWRITE='OFF'
5168      IERROR='NO'
5169      DO10I=1,NALPHA
5170        ALOWLM(I)=CPUMIN
5171        AUPPLM(I)=CPUMIN
5172   10 CONTINUE
5173      RATIO=CPUMIN
5174C
5175      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MRC5')THEN
5176        WRITE(ICOUT,999)
5177  999   FORMAT(1X)
5178        CALL DPWRST('XXX','WRIT')
5179        WRITE(ICOUT,51)
5180   51   FORMAT('**** AT THE BEGINNING OF DPMRC5--')
5181        CALL DPWRST('XXX','WRIT')
5182        WRITE(ICOUT,52)IBUGA3,ISUBRO,N,NALPHA
5183   52   FORMAT('IBUGA3,ISUBRO,N,NALPHA = ',2(A4,2X),I8,I5)
5184        CALL DPWRST('XXX','WRIT')
5185        DO56I=1,N
5186          WRITE(ICOUT,57)I,Y(I),X(I)
5187   57     FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
5188          CALL DPWRST('XXX','WRIT')
5189   56   CONTINUE
5190        DO76I=1,NALPHA
5191          WRITE(ICOUT,77)I,ALPHA(I)
5192   77     FORMAT('I,ALPHA(I) = ',I8,G15.7)
5193          CALL DPWRST('XXX','WRIT')
5194   76   CONTINUE
5195      ENDIF
5196C
5197C               ********************************************
5198C               **  STEP 1--                              **
5199C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
5200C               ********************************************
5201C
5202      ISTEPN='1'
5203      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MRC5')
5204     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5205C
5206      DO110I=1,NALPHA
5207        ALOWLM(I)=CPUMIN
5208        AUPPLM(I)=CPUMIN
5209  110 CONTINUE
5210C
5211      NMIN=5
5212      IF(NMIN.LT.5)THEN
5213        WRITE(ICOUT,999)
5214        CALL DPWRST('XXX','WRIT')
5215        WRITE(ICOUT,101)
5216  101   FORMAT('***** ERROR: RATIO OF MEANS CONFIDENCE LIMITS--')
5217        CALL DPWRST('XXX','WRIT')
5218        WRITE(ICOUT,102)NMIN
5219  102   FORMAT('      THE NUMBER OF ORIGINAL OBSERVATIONS  IS LESS ',
5220     1         'THAN ',I3,'.')
5221        CALL DPWRST('XXX','WRIT')
5222        WRITE(ICOUT,103)N
5223  103   FORMAT('      SAMPLE SIZE = ',I8)
5224        CALL DPWRST('XXX','WRIT')
5225        IERROR='YES'
5226        GOTO9000
5227      ENDIF
5228C
5229C               ********************************************
5230C               **  STEP 2--                              **
5231C               **  COMPUTE SOME BASIC STATISTICS         **
5232C               ********************************************
5233C
5234      ISTEPN='2'
5235      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MRC5')
5236     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5237C
5238      CALL MEAN(Y,N,IWRITE,YBAR,IBUGA3,IERROR)
5239      CALL VAR(Y,N,IWRITE,YVAR,IBUGA3,IERROR)
5240      CALL MEAN(X,N,IWRITE,XBAR,IBUGA3,IERROR)
5241      CALL VAR(X,N,IWRITE,XVAR,IBUGA3,IERROR)
5242      CALL COV(Y,X,N,IWRITE,XYCOV,IBUGA3,IERROR)
5243C
5244      IF(YVAR.LE.0.0)THEN
5245        WRITE(ICOUT,999)
5246        CALL DPWRST('XXX','WRIT')
5247        WRITE(ICOUT,101)
5248        CALL DPWRST('XXX','WRIT')
5249        WRITE(ICOUT,131)
5250  131   FORMAT('      VARIANCE OF MEAN FOR FIRST (NUMERATOR) RESPONSE ',
5251     1             'IS NON-POSITIVE.')
5252        CALL DPWRST('XXX','WRIT')
5253        IERROR='YES'
5254        GOTO9000
5255      ELSEIF(XVAR.LE.0.0)THEN
5256        WRITE(ICOUT,999)
5257        CALL DPWRST('XXX','WRIT')
5258        WRITE(ICOUT,101)
5259        CALL DPWRST('XXX','WRIT')
5260        WRITE(ICOUT,136)
5261  136   FORMAT('      VARIANCE OF MEAN FOR SECOND (DENOMINATOR) ',
5262     1         'RESPONSE VARIABLE IS NON-POSITIVE.')
5263        CALL DPWRST('XXX','WRIT')
5264        IERROR='YES'
5265        GOTO9000
5266      ELSEIF(XBAR.EQ.0.0)THEN
5267        WRITE(ICOUT,999)
5268        CALL DPWRST('XXX','WRIT')
5269        WRITE(ICOUT,101)
5270        CALL DPWRST('XXX','WRIT')
5271        WRITE(ICOUT,141)
5272  141   FORMAT('      THE MEAN OF THE DENOMINATOR VARIABLE IS ',
5273     1         'EQUAL TO ZERO.')
5274        CALL DPWRST('XXX','WRIT')
5275        IERROR='YES'
5276        GOTO9000
5277      ENDIF
5278C
5279      IF(IBUGA3.EQ.'ON'.AND.ISUBRO.EQ.'MRC5')THEN
5280        WRITE(ICOUT,191)YBAR,YVAR,XBAR,XVAR,XYCOV
5281  191   FORMAT('YBAR,YVAR,XBAR,XVAR,XYCOV = ',5G15.7)
5282        CALL DPWRST('XXX','WRIT')
5283      ENDIF
5284C
5285C               ********************************************
5286C               **  STEP 3--                              **
5287C               **  CARRY OUT CALCULATIONS FOR CONFIDENCE **
5288C               **  LIMITS.                               **
5289C               ********************************************
5290C
5291      ISTEPN='3'
5292      IF(IBUGA3.EQ.'ON'.AND.ISUBRO.EQ.'MRC5')
5293     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5294C
5295      RATIO=YBAR/XBAR
5296      ADF=REAL(N-1)
5297      DN=DBLE(N)
5298      DR=DBLE(RATIO)
5299      DXBAR=DBLE(XBAR)
5300      DYBAR=DBLE(YBAR)
5301      DYVAR=DBLE(YVAR)
5302      DXVAR=DBLE(XVAR)
5303      DCOV=DBLE(XYCOV)
5304      DCYY=(DYVAR/DYBAR**2)/DN
5305      DCXX=(DXVAR/DXBAR**2)/DN
5306      DCXY=(DCOV/(DXBAR*DYBAR))/DN
5307      DTERM1=DSQRT(DCYY + DCXX - 2.0D0*DCXY)
5308C
5309      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'MRC5')THEN
5310        WRITE(ICOUT,999)
5311        CALL DPWRST('XXX','WRIT')
5312        WRITE(ICOUT,301)DR,DCYY,DCXX,DCXY,DTERM1
5313  301   FORMAT('DR,DCYY,DCXX,DCXY,DTERM1 = ',5G15.7)
5314        CALL DPWRST('XXX','WRIT')
5315      ENDIF
5316C
5317      DO310II=1,NALPHA
5318        ALPT=ALPHA(II)
5319        IF(ALPT.GT.1.0 .AND. ALPT.LT.100.0)ALPT=ALPT/100.0
5320        IF(ALPT.LE.0.0 .OR. ALPT.GT.1.0)THEN
5321          WRITE(ICOUT,999)
5322          CALL DPWRST('XXX','WRIT')
5323          WRITE(ICOUT,101)
5324          CALL DPWRST('XXX','WRIT')
5325          WRITE(ICOUT,311)ALPHA(II)
5326  311     FORMAT('      INVALID VALUE OF ALPHA (',G15.7,'),')
5327          CALL DPWRST('XXX','WRIT')
5328          IERROR='YES'
5329          GOTO9000
5330        ENDIF
5331        IF(ALPT.LT.0.5)ALPT=1.0 - ALPT
5332        ALPT=(1.0 - ALPT)/2.0
5333        ALPT=1.0 - ALPT
5334        CALL TPPF(ALPT,ADF,TPPFV)
5335        DT=DBLE(TPPFV)
5336        DLOW=DR*DEXP((-DT)*DTERM1)
5337        DUPP=DR*DEXP(DT*DTERM1)
5338        ALOWLM(II)=REAL(DLOW)
5339        AUPPLM(II)=REAL(DUPP)
5340C
5341        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'MRC5')THEN
5342          WRITE(ICOUT,999)
5343          CALL DPWRST('XXX','WRIT')
5344          WRITE(ICOUT,333)DT,DLOW,DUPP
5345  333     FORMAT('DT,DLOW,DUPP = ',3G15.7)
5346          CALL DPWRST('XXX','WRIT')
5347        ENDIF
5348C
5349  310 CONTINUE
5350C
5351 9000 CONTINUE
5352      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'MRC5')THEN
5353        WRITE(ICOUT,999)
5354        CALL DPWRST('XXX','WRIT')
5355        WRITE(ICOUT,9051)
5356 9051   FORMAT('**** AT THE END OF DPMRC5--')
5357        CALL DPWRST('XXX','WRIT')
5358      ENDIF
5359C
5360      RETURN
5361      END
5362      SUBROUTINE DPMRFP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
5363     1                  IBUGG2,IBUGG3,ISUBRO,IBUGQ,IFOUND,IERROR)
5364C
5365C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
5366C              THAT WILL DEFINE A MEAN REPAIR FUNCTION PLOT.
5367C              THIS IS USED TO PLOT THE CUMULATIVE NUMBER OF
5368C              REPAIRS AGAINST TIME WHEN THERE ARE MULTIPLE
5369C              SYSTEMS.  IN ADDITION, AN ESTIMATE OF M(T)
5370C              (DUE TO NELSON) BASED ON POOLED ESTIMATION IS
5371C              OVERLAID ON THE PLOT.
5372C     REFERENCE--TOBIAS AND TRINDADE (1995), "APPLIED
5373C                RELIABILITY", SECOND EDITION, CHAPMAN AND HALL,
5374C                PP. 311-315.
5375C              --NELSON (1995), "CONFIDENCE LIMITS FOR RECCURRENCE
5376C                DATA--APPLIED TO COST OR NUMBER OF PRODUCT
5377C                REPAIRS", TECHNOMETRICS, VOL. 37, NO. 2,
5378C                PP. 147-157.
5379C     WRITTEN BY--ALAN HECKERT
5380C                 STATISTICAL ENGINEERING DIVISION
5381C                 INFORMATION TECHNOLOGY LABORATORY
5382C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
5383C                 GAITHERSBURG, MD 20899-8980
5384C                 PHONE--301-975-2899
5385C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
5386C           OF THE NATIONAL BUREAU OF STANDARDS.
5387C     LANGUAGE--ANSI FORTRAN (1977)
5388C     VERSION NUMBER--2006/9
5389C     ORIGINAL VERSION--OCTOBER    2006.
5390C     UPDATED         --APRIL      2011. USE DPPAR AND DPPAR3
5391C
5392C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
5393C
5394      CHARACTER*4 ICASPL
5395      CHARACTER*4 IAND1
5396      CHARACTER*4 IAND2
5397      CHARACTER*4 IBUGG2
5398      CHARACTER*4 IBUGG3
5399      CHARACTER*4 ISUBRO
5400      CHARACTER*4 IBUGQ
5401      CHARACTER*4 IFOUND
5402      CHARACTER*4 IERROR
5403C
5404      CHARACTER*4 ISUBN1
5405      CHARACTER*4 ISUBN2
5406      CHARACTER*4 ISTEPN
5407C
5408      CHARACTER*4 ICASE
5409      PARAMETER (MAXSPN=10)
5410      CHARACTER*40 INAME
5411      CHARACTER*4 IVARN1(MAXSPN)
5412      CHARACTER*4 IVARN2(MAXSPN)
5413      CHARACTER*4 IVARTY(MAXSPN)
5414      REAL PVAR(MAXSPN)
5415      INTEGER ILIS(MAXSPN)
5416      INTEGER NRIGHT(MAXSPN)
5417      INTEGER ICOLR(MAXSPN)
5418C
5419C---------------------------------------------------------------------
5420C
5421      INCLUDE 'DPCOPA.INC'
5422C
5423      DIMENSION Y1(MAXOBV)
5424      DIMENSION X1(MAXOBV)
5425      DIMENSION XCEN(MAXOBV)
5426      DIMENSION TEMP1(MAXOBV)
5427      DIMENSION TEMP2(MAXOBV)
5428      DIMENSION TEMP3(MAXOBV)
5429      DIMENSION TEMP4(MAXOBV)
5430      DIMENSION TEMP5(MAXOBV)
5431C
5432      INCLUDE 'DPCOZZ.INC'
5433      EQUIVALENCE (GARBAG(IGARB1),Y1(1))
5434      EQUIVALENCE (GARBAG(IGARB2),X1(1))
5435      EQUIVALENCE (GARBAG(IGARB3),XCEN(1))
5436      EQUIVALENCE (GARBAG(IGARB4),TEMP1(1))
5437      EQUIVALENCE (GARBAG(IGARB5),TEMP2(1))
5438      EQUIVALENCE (GARBAG(IGARB6),TEMP3(1))
5439      EQUIVALENCE (GARBAG(IGARB7),TEMP4(1))
5440      EQUIVALENCE (GARBAG(IGARB8),TEMP5(1))
5441C
5442C-----COMMON----------------------------------------------------------
5443C
5444      INCLUDE 'DPCOHO.INC'
5445      INCLUDE 'DPCOHK.INC'
5446      INCLUDE 'DPCODA.INC'
5447      INCLUDE 'DPCOP2.INC'
5448C
5449C-----START POINT-----------------------------------------------------
5450C
5451      IFOUND='NO'
5452      IERROR='NO'
5453      ISUBN1='DPMR'
5454      ISUBN2='FP  '
5455C
5456      MAXCP1=MAXCOL+1
5457      MAXCP2=MAXCOL+2
5458      MAXCP3=MAXCOL+3
5459      MAXCP4=MAXCOL+4
5460      MAXCP5=MAXCOL+5
5461      MAXCP6=MAXCOL+6
5462C
5463      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'MRFP')THEN
5464        WRITE(ICOUT,999)
5465  999   FORMAT(1X)
5466        CALL DPWRST('XXX','BUG ')
5467        WRITE(ICOUT,51)
5468   51   FORMAT('***** AT THE BEGINNING OF DPMRFP--')
5469        CALL DPWRST('XXX','BUG ')
5470        WRITE(ICOUT,52)ICASPL,IAND1,IAND2,MAXCOL
5471   52   FORMAT('ICASPL,IAND1,IAND2,MAXCOL = ',3(A4,2X),I8)
5472        CALL DPWRST('XXX','BUG ')
5473        WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ,ISUBRO
5474   53   FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',3(A4,2X),A4)
5475        CALL DPWRST('XXX','BUG ')
5476        WRITE(ICOUT,54)MAXCOL
5477   54   FORMAT('MAXCOL = ',I8)
5478        CALL DPWRST('XXX','BUG ')
5479      ENDIF
5480C
5481C
5482C               *********************************************
5483C               **  TREAT THE MEAN REPAIR FUNCTION PLOT    **
5484C               *********************************************
5485C
5486C               *******************************************
5487C               **  STEP 1--                             **
5488C               **  SEARCH FOR MEAN REPAIR FUNCTION PLOT **
5489C               *******************************************
5490C
5491      ISTEPN='11'
5492      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'MRFP')
5493     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5494C
5495      ICASPL='MRFP'
5496      IF(NUMARG.GE.1.AND.
5497     1  (ICOM.EQ.'MEAN' .OR. ICOM.EQ.'AVER').AND.
5498     1  IHARG(1).EQ.'REPA'.AND.IHARG(2).EQ.'FUNC'.AND.
5499     1  IHARG(3).EQ.'PLOT')THEN
5500        ILASTC=3
5501        CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
5502        IFOUND='YES'
5503      ELSE
5504        ICASPL='    '
5505        IFOUND='NO'
5506        GOTO9000
5507      ENDIF
5508C
5509C               ****************************************
5510C               **  STEP 2--                          **
5511C               **  EXTRACT THE VARIABLE LIST         **
5512C               ****************************************
5513C
5514      ISTEPN='2'
5515      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'MRFP')
5516     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5517C
5518      INAME='MEAN REPAIR FUNCTION PLOT'
5519      MINNA=1
5520      MAXNA=100
5521      MINN2=2
5522      IFLAGE=1
5523      IFLAGM=0
5524      IFLAGP=0
5525      JMIN=1
5526      JMAX=NUMARG
5527      MINNVA=1
5528      MAXNVA=3
5529C
5530      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
5531     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
5532     1            JMIN,JMAX,
5533     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
5534     1            IVARN1,IVARN2,IVARTY,PVAR,
5535     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
5536     1            MINNVA,MAXNVA,
5537     1            IFLAGM,IFLAGP,
5538     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
5539      IF(IERROR.EQ.'YES')GOTO9000
5540C
5541      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'MRFP')THEN
5542        WRITE(ICOUT,999)
5543        CALL DPWRST('XXX','BUG ')
5544        WRITE(ICOUT,281)
5545  281   FORMAT('***** AFTER CALL DPPARS--')
5546        CALL DPWRST('XXX','BUG ')
5547        WRITE(ICOUT,282)NQ,NUMVAR
5548  282   FORMAT('NQ,NUMVAR = ',2I8)
5549        CALL DPWRST('XXX','BUG ')
5550        IF(NUMVAR.GT.0)THEN
5551          DO285I=1,NUMVAR
5552            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
5553     1                      ICOLR(I)
5554  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
5555     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
5556            CALL DPWRST('XXX','BUG ')
5557  285     CONTINUE
5558        ENDIF
5559      ENDIF
5560C
5561C     EXTRACT THE VARIABLES.
5562C
5563      ICOL=1
5564      CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
5565     1            INAME,IVARN1,IVARN2,IVARTY,
5566     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
5567     1            MAXCOL,MAXCP1,MAXCP2,MAXCP3,
5568     1            MAXCP4,MAXCP5,MAXCP6,
5569     1            V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
5570     1            Y1,X1,XCEN,NS,NGROUP,NCENS,ICASE,
5571     1            IBUGG3,ISUBRO,IFOUND,IERROR)
5572      IF(IERROR.EQ.'YES')GOTO9000
5573      IF(NUMVAR.LT.2)NGROUP=0
5574      IF(NUMVAR.LT.3)NCENS=0
5575C
5576C               *****************************************************
5577C               **  STEP 41--                                      **
5578C               **  FORM THE VERTICAL AND HORIZONTAL AXIS          **
5579C               **  VARIABLES (Y(.) AND X(.), RESPECTIVELY) FOR    **
5580C               **  THE PLOT.                                      **
5581C               **  FORM THE CURVE DESIGNATION VARIABLED(.)  .     **
5582C               **  THIS WILL BE ALL ONES.                         **
5583C               **  DEFINE THE NUMBER OF PLOT POINTS   (NPLOTP).   **
5584C               **  DEFINE THE NUMBER OF PLOT VARIABLES(NPLOTV).   **
5585C               *****************************************************
5586C
5587      ISTEPN='41'
5588      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'MRFP')
5589     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5590C
5591      CALL DPMRF2(Y1,NS,X1,NGROUP,XCEN,NCENS,ICASPL,MAXN,
5592     1            TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,
5593     1            Y,X,D,NPLOTP,NPLOTV,
5594     1            IBUGG3,ISUBRO,IERROR)
5595C
5596C               *****************
5597C               **  STEP 90--  **
5598C               **  EXIT       **
5599C               *****************
5600C
5601 9000 CONTINUE
5602      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'MRFP')THEN
5603        WRITE(ICOUT,999)
5604        CALL DPWRST('XXX','BUG ')
5605        WRITE(ICOUT,9011)
5606 9011   FORMAT('***** AT THE END       OF DPMRFP--')
5607        CALL DPWRST('XXX','BUG ')
5608        WRITE(ICOUT,9012)IFOUND,IERROR
5609 9012   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
5610        CALL DPWRST('XXX','BUG ')
5611        WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
5612 9013   FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',
5613     1         3I8,I8,I8,2(2X,A4),A4)
5614        CALL DPWRST('XXX','BUG ')
5615        IF(NPLOTP.GT.0)THEN
5616          DO9015I=1,NPLOTP
5617            WRITE(ICOUT,9016)I,Y(I),X(I),D(I)
5618 9016       FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5)
5619            CALL DPWRST('XXX','BUG ')
5620 9015     CONTINUE
5621        ENDIF
5622      ENDIF
5623C
5624      RETURN
5625      END
5626      SUBROUTINE DPMRF2(Y1,N,X1,NGROUP,XCEN,NCENS,ICASPL,MAXN,
5627     1                  XIDTEM,TEMP2,TEMP3,TEMP4,TEMP5,
5628     1                  Y,X,D,NPLOTP,NPLOTV,
5629     1                  IBUGG3,ISUBRO,IERROR)
5630C
5631C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
5632C              THAT WILL DEFINE A MEAN REPAIR FUNCTION PLOT.
5633C              PLOT THE REPAIR TIMES FOR EACH GROUP, EACH GROUP
5634C              MAY HAVE A SINGLE CENSORING TIME.  NELSON
5635C              DESCRIBES A METHOD FOR CREATING THE MEAN REPAIR
5636C              FUNCTION AND CORRESPONDING CONFIDENCE LIMITS.
5637C     INPUT ARGUMENTS--Y1     = THE SINGLE PRECISION VECTOR OF
5638C                               (UNSORTED) REPAIR/CENSORING TIMES.
5639C                    --X1     = THE OPTIONAL SINGLE PRECISION VECTOR
5640C                               GROUP-ID VALUES
5641C                    --XCENS  = THE OPTIONAL SINGLE PRECISION VECTOR
5642C                               OF CENSOR VALUES (1 = REPAIR
5643C                               TIME, 0 = CENSOR TIME).
5644C                      NY     = THE INTEGER NUMBER OF OBSERVATIONS
5645C                               IN THE VECTOR Y1.
5646C                      NX     = THE INTEGER NUMBER OF OBSERVATIONS
5647C                               IN THE VECTOR X1.
5648C                      NC     = THE INTEGER NUMBER OF OBSERVATIONS
5649C                               IN THE VECTOR XCEN.
5650C     REFERENCE--TOBIAS AND TRINDADE (1995), "APPLIED
5651C                RELIABILITY", SECOND EDITION, CHAPMAN AND HALL,
5652C                PP. 311-315.
5653C              --NELSON (1995), "CONFIDENCE LIMITS FOR RECCURRENCE
5654C                DATA--APPLIED TO COST OR NUMBER OF PRODUCT
5655C                REPAIRS", TECHNOMETRICS, VOL. 37, NO. 2,
5656C                PP. 147-157.
5657C     WRITTEN BY--ALAN HECKERT
5658C                 STATISTICAL ENGINEERING DIVISION
5659C                 INFORMATION TECHNOLOGY LABORATORY
5660C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
5661C                 GAITHERSBURG, MD 20899-8980
5662C                 PHONE--301-975-2899
5663C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
5664C           OF THE NATIONAL BUREAU OF STANDARDS.
5665C     LANGUAGE--ANSI FORTRAN (1977)
5666C     VERSION NUMBER--2006/9
5667C     ORIGINAL VERSION--SEPTEMBER 2006.
5668C
5669C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
5670C
5671      CHARACTER*4 ICASPL
5672      CHARACTER*4 IBUGG3
5673      CHARACTER*4 ISUBRO
5674      CHARACTER*4 IERROR
5675C
5676      CHARACTER*4 ISUBN1
5677      CHARACTER*4 ISUBN2
5678C
5679C---------------------------------------------------------------------
5680C
5681      DIMENSION Y1(*)
5682      DIMENSION X1(*)
5683      DIMENSION XCEN(*)
5684C
5685      DIMENSION XIDTEM(*)
5686      DIMENSION TEMP2(*)
5687      DIMENSION TEMP3(*)
5688      DIMENSION TEMP4(*)
5689      DIMENSION TEMP5(*)
5690C
5691      DIMENSION Y(*)
5692      DIMENSION X(*)
5693      DIMENSION D(*)
5694C
5695C---------------------------------------------------------------------
5696C
5697      INCLUDE 'DPCOP2.INC'
5698C
5699C-----START POINT-----------------------------------------------------
5700C
5701      ISUBN1='DPMR'
5702      ISUBN2='F2  '
5703      IERROR='NO'
5704C
5705      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'MRF2')THEN
5706        WRITE(ICOUT,999)
5707  999   FORMAT(1X)
5708        CALL DPWRST('XXX','BUG ')
5709        WRITE(ICOUT,51)
5710   51   FORMAT('***** AT THE BEGINNING OF DPMRF2--')
5711        CALL DPWRST('XXX','BUG ')
5712        WRITE(ICOUT,52)IBUGG3,ISUBRO,IERROR,ICASPL
5713   52   FORMAT('IBUGG3,ISUBRO,IERROR,ICASPL = ',3(A4,2X),A4)
5714        CALL DPWRST('XXX','BUG ')
5715        WRITE(ICOUT,53)N,NGROUP,NCENS,MAXN
5716   53   FORMAT('N,NGROUP,NCENS,MAXN = ',4I10)
5717        CALL DPWRST('XXX','BUG ')
5718        DO55I=1,N
5719          WRITE(ICOUT,56)I,Y1(I),X1(I),XCEN(I)
5720   56     FORMAT('I, Y1(I),X1(I),XCEN(I) = ',I10,3G15.7)
5721          CALL DPWRST('XXX','BUG ')
5722   55   CONTINUE
5723      ENDIF
5724C
5725C               ********************************************
5726C               **  STEP 1--                              **
5727C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
5728C               ********************************************
5729C
5730      IF(N.LT.2)THEN
5731        WRITE(ICOUT,999)
5732        CALL DPWRST('XXX','BUG ')
5733        WRITE(ICOUT,111)
5734  111   FORMAT('***** ERROR IN MEAN REPAIR FUNCTION PLOT--')
5735        CALL DPWRST('XXX','BUG ')
5736        WRITE(ICOUT,112)
5737  112   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 2;')
5738        CALL DPWRST('XXX','BUG ')
5739        WRITE(ICOUT,114)N
5740  114   FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I8)
5741        CALL DPWRST('XXX','BUG ')
5742        WRITE(ICOUT,999)
5743        CALL DPWRST('XXX','BUG ')
5744        IERROR='YES'
5745        GOTO9000
5746      ENDIF
5747C
5748      HOLD=Y1(1)
5749      DO120I=1,N
5750      IF(Y1(I).NE.HOLD)GOTO129
5751  120 CONTINUE
5752      WRITE(ICOUT,999)
5753      CALL DPWRST('XXX','BUG ')
5754      WRITE(ICOUT,111)
5755      CALL DPWRST('XXX','BUG ')
5756      WRITE(ICOUT,122)HOLD
5757  122 FORMAT('      ALL ELEMENTS IN RESPONSE VARIABLE ARE ',
5758     1       'IDENTICALLY EQUAL TO ',G15.7)
5759      CALL DPWRST('XXX','BUG ')
5760      WRITE(ICOUT,999)
5761      CALL DPWRST('XXX','BUG ')
5762      IERROR='YES'
5763      GOTO9000
5764  129 CONTINUE
5765C
5766C               ****************************************************
5767C               **  STEP 12--                                     **
5768C               **  COMPUTE COORDINATES FOR MEAN REPAIR FUNCTION  **
5769C               **  PLOT                                          **
5770C               ****************************************************
5771C
5772C
5773C     CASE 1: NO GROUP OR CENSORING VARIABLE
5774C
5775      IF(NGROUP.EQ.0 .AND. NCENS.EQ.0)THEN
5776        CALL SORT(Y1,N,Y1)
5777        DO1000I=1,N
5778          Y(I)=REAL(I)
5779          X(I)=Y1(I)
5780          D(I)=1.0
5781 1000   CONTINUE
5782        NPLOTP=N
5783C
5784C       CASE 2: GROUP VARIABLE, BUT NO CENSORING VARIABLE
5785C
5786      ELSEIF(NCENS.EQ.0)THEN
5787C
5788C       STEP 1: DETERMINE UNIQUE GROUPS
5789C
5790        CALL SORTC(Y1,X1,N,TEMP2,TEMP3)
5791        DO1010I=1,N
5792          Y1(I)=TEMP2(I)
5793          X1(I)=TEMP3(I)
5794 1010   CONTINUE
5795C
5796        NUMSET=0
5797        DO1051I=1,N
5798          IF(NUMSET.EQ.0)GOTO1053
5799          DO1052J=1,NUMSET
5800            IF(X1(I).EQ.XIDTEM(J))GOTO1051
5801 1052     CONTINUE
5802 1053     CONTINUE
5803          NUMSET=NUMSET+1
5804          XIDTEM(NUMSET)=X1(I)
5805 1051   CONTINUE
5806        CALL SORT(XIDTEM,NUMSET,XIDTEM)
5807        J=0
5808C
5809C       STEP 2: GENERATE MEAN TRACE
5810C
5811        J=J+1
5812        Y(J)=0.0
5813        X(J)=0.0
5814        D(J)=1.0
5815        DO1060I=1,N
5816          J=J+1
5817          Y(J)=REAL(I)/REAL(NUMSET)
5818          X(J)=Y1(I)
5819          D(J)=1.0
5820 1060   CONTINUE
5821C
5822C       STEP 3: GENERATE TRACES FOR EACH GROUP
5823C
5824        ITRACE=1
5825        DO1090ISET=1,NUMSET
5826C
5827          K=0
5828          DO1091I=1,N
5829            IF(X1(I).EQ.XIDTEM(ISET))THEN
5830              K=K+1
5831              TEMP2(K)=Y1(I)
5832            ENDIF
58331091      CONTINUE
5834          NI=K
5835          CALL SORT(TEMP2,NI,TEMP2)
5836          ITRACE=ITRACE+1
5837          J=J+1
5838          Y(J)=0.0
5839          X(J)=0.0
5840          D(J)=REAL(ITRACE)
5841          DO1096I=1,NI
5842            J=J+1
5843            Y(J)=REAL(I)
5844            X(J)=TEMP2(I)
5845            D(J)=REAL(ITRACE)
58461096      CONTINUE
58471090    CONTINUE
5848        NPLOTP=J
5849C
5850C       CASE 3: BOTH GROUP VARIABLE AND CENSORING VARIABLE
5851C
5852      ELSE
5853C
5854C       STEP 1: DETERMINE UNIQUE GROUPS
5855C
5856        NUMSET=0
5857        DO1111I=1,N
5858          IF(NUMSET.EQ.0)GOTO1113
5859          DO1112J=1,NUMSET
5860            IF(X1(I).EQ.XIDTEM(J))GOTO1111
5861 1112     CONTINUE
5862 1113     CONTINUE
5863          NUMSET=NUMSET+1
5864          XIDTEM(NUMSET)=X1(I)
5865 1111   CONTINUE
5866        CALL SORT(XIDTEM,NUMSET,XIDTEM)
5867C
5868C       STEP 2A: EXTRACT RESPONSE AND CENSORING DATA FOR EACH
5869C                GROUP
5870C
5871        J=0
5872        ITRACE=1
5873        ISETMX=NUMSET
5874        DO1120ISET=1,NUMSET
5875C
5876          K=0
5877          DO1121I=1,N
5878            IF(X1(I).EQ.XIDTEM(ISET))THEN
5879              K=K+1
5880              TEMP2(K)=Y1(I)
5881              TEMP3(K)=XCEN(I)
5882            ENDIF
58831121      CONTINUE
5884          NI=K
5885C
5886C       STEP 2B: PROCESS THE CENSORING VARIABLE.  THERE CAN
5887C                BE AT MOST ONE CENSORING POINT FOR EACH
5888C                GROUP.
5889C
5890          CALL SORTC(TEMP2,TEMP3,NI,TEMP4,TEMP5)
5891          DO1160I=1,NI
5892            TEMP2(I)=TEMP4(I)
5893            TEMP3(I)=TEMP5(I)
5894 1160     CONTINUE
5895          AREP=TEMP3(1)
5896          ACEN=TEMP3(NI)
5897          IF(NI.LE.1)THEN
5898            NTEMPR=1
5899            NTEMPC=0
5900          ELSE
5901            IF(AREP.EQ.ACEN)THEN
5902              NTEMPR=NI
5903              NTEMPC=0
5904              DO1170I=1,NI
5905                IF(TEMP3(I).NE.AREP)THEN
5906                  WRITE(ICOUT,999)
5907                  CALL DPWRST('XXX','BUG ')
5908                  WRITE(ICOUT,111)
5909                  CALL DPWRST('XXX','BUG ')
5910                  WRITE(ICOUT,1171)
5911                  CALL DPWRST('XXX','BUG ')
5912                  WRITE(ICOUT,1172)
5913                  CALL DPWRST('XXX','BUG ')
5914                  WRITE(ICOUT,1173)
5915                  CALL DPWRST('XXX','BUG ')
5916                  WRITE(ICOUT,1174)XIDTEM(ISET)
5917                  CALL DPWRST('XXX','BUG ')
5918                  IERROR='YES'
5919                  GOTO9000
5920                ENDIF
5921 1170         CONTINUE
5922            ELSE
5923              NTEMPR=NI-1
5924              NTEMPC=1
5925              DO1180I=1,NTEMPR
5926                IF(TEMP3(I).NE.AREP)THEN
5927                  WRITE(ICOUT,999)
5928                  CALL DPWRST('XXX','BUG ')
5929                  WRITE(ICOUT,111)
5930                  CALL DPWRST('XXX','BUG ')
5931                  WRITE(ICOUT,1171)
5932                  CALL DPWRST('XXX','BUG ')
5933                  WRITE(ICOUT,1172)
5934                  CALL DPWRST('XXX','BUG ')
5935                  WRITE(ICOUT,1173)
5936                  CALL DPWRST('XXX','BUG ')
5937                  WRITE(ICOUT,1174)XIDTEM(ISET)
5938                  CALL DPWRST('XXX','BUG ')
5939                  IERROR='YES'
5940                  GOTO9000
5941                ENDIF
5942 1180         CONTINUE
5943            ENDIF
5944          ENDIF
5945 1171 FORMAT('      FOR EACH SYSTEM, THERE SHOULD BE AT MOST')
5946 1172 FORMAT('      CENSORING TIME AND IT MUST BE THE MAXIMUM')
5947 1173 FORMAT('      VALUE FOR THAT SYSTEM.')
5948 1174 FORMAT('      SUCH WAS NOT THE CASE FOR SYSTEM ',G15.7)
5949C
5950C       STEP 2C: TRACE 1 IS SIMPLY ALL OF THE REPAIR TIMES
5951C                (I.E., OMIT THE CENSORING TIME).  THEN TRACES
5952C                2 - NUMBER OF SYSTEMS + 1 ARE THE REPAIR PLUS
5953C                CENSORING TIMES FOR EACH SYSTEM.
5954C
5955CCCCC     DO1191I=1,NTEMPR
5956CCCCC       J=J+1
5957CCCCC       Y(J)=XIDTEM(ISET)
5958CCCCC       X(J)=TEMP2(I)
5959CCCCC       D(J)=1.0
5960C1191      CONTINUE
5961C
5962          ITRACE=ITRACE+1
5963          J=J+1
5964          Y(J)=0.0
5965          X(J)=0.0
5966          D(J)=REAL(ITRACE)
5967C
5968          DO1196I=1,NTEMPR
5969            J=J+1
5970            Y(J)=REAL(I)
5971            X(J)=TEMP2(I)
5972            D(J)=REAL(ITRACE)
59731196      CONTINUE
5974          IF(NTEMPC.GT.0)THEN
5975            J=J+1
5976            Y(J)=REAL(NTEMPR)
5977            X(J)=TEMP2(NI)
5978            D(J)=REAL(ITRACE)
5979          ENDIF
5980
5981C
59821120    CONTINUE
5983C
5984        CALL SORTC(Y1,XCEN,N,TEMP4,TEMP5)
5985        J=J+1
5986        Y(J)=0.0
5987        X(J)=0.0
5988        D(J)=1.0
5989        NUMCEN=0
5990        NUMREP=0
5991        AMCF=0.0
5992        DO1198I=1,N
5993          IF(TEMP5(I).LT.0.5)THEN
5994            NUMCEN=NUMCEN+1
5995          ELSE
5996            IF(NUMSET-NUMCEN.GT.0)THEN
5997              AMCF=AMCF + 1.0/REAL(NUMSET-NUMCEN)
5998            ENDIF
5999          ENDIF
6000          J=J+1
6001          Y(J)=AMCF
6002          X(J)=TEMP4(I)
6003          D(J)=1.0
6004 1198   CONTINUE
6005C
6006        NPLOTP=J
6007      ENDIF
6008C
6009      NPLOTV=2
6010C
6011C               ******************
6012C               **   STEP 90--  **
6013C               **   EXIT       **
6014C               ******************
6015C
6016 9000 CONTINUE
6017      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'MRF2')THEN
6018        WRITE(ICOUT,999)
6019        CALL DPWRST('XXX','BUG ')
6020        WRITE(ICOUT,9011)
6021 9011   FORMAT('***** AT THE END       OF DPMRF2--')
6022        CALL DPWRST('XXX','BUG ')
6023        WRITE(ICOUT,9013)IERROR,ICASPL,N,MAXN,NPLOTP,NPLOTV
6024 9013   FORMAT('IERROR,ICASPL,N,MAXN,NPLOTP,NPLOTV = ',2(A4,2X),4I8)
6025        CALL DPWRST('XXX','BUG ')
6026        DO9022I=1,NPLOTP
6027          WRITE(ICOUT,9023)I,Y(I),X(I),D(I)
6028 9023     FORMAT('I,Y(I),X(I),D(I) = ',I8,3G15.7)
6029          CALL DPWRST('XXX','BUG ')
6030 9022  CONTINUE
6031      ENDIF
6032C
6033      RETURN
6034      END
6035      SUBROUTINE DPMSDT(XTEMP1,MAXNXT,
6036     1                  ICASAN,ICAPSW,IFORSW,
6037     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
6038C
6039C     PURPOSE--CARRY OUT MEAN SUCCESSIVE DIFFERENCES TEST FOR RANDOMNESS
6040C     EXAMPLE--MEAN SUCCESSIVE DIFFERENCES TEST Y
6041C     REFERENCE--DEAN V. NEUBAUER, "TESTING FOR RANDOMNESS: THE
6042C                MEAN SUCCESSIVE DIFFERENCE TEST", ASTM STANDARDIZATION
6043C                NEWS, SEPTEMBER/OCTOBER 2012, PP. 12-13.
6044C     WRITTEN BY--ALAN HECKERT
6045C                 STATISTICAL ENGINEERING DIVISION
6046C                 INFORMATION TECHNOLOGY LABORATORY
6047C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
6048C                 Gaithersburg, MD 20899-8980
6049C                 PHONE--301-975-2899
6050C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
6051C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
6052C     LANGUAGE--ANSI FORTRAN (1977)
6053C     VERSION NUMBER--2013/1
6054C     ORIGINAL VERSION--JANUARY   2013.
6055C     UPDATED         --MARCH     2015. ADD ADJACENCY TEST AS SYNONYM
6056C     UPDATED         --JULY      2019. TWEAK SCRATCH STORAGE
6057C
6058C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
6059C
6060      CHARACTER*4 ICASAN
6061      CHARACTER*4 ICAPSW
6062      CHARACTER*4 IFORSW
6063      CHARACTER*4 IBUGA2
6064      CHARACTER*4 IBUGA3
6065      CHARACTER*4 IBUGQ
6066      CHARACTER*4 ISUBRO
6067      CHARACTER*4 IFOUND
6068      CHARACTER*4 IERROR
6069C
6070      CHARACTER*4 ISUBN1
6071      CHARACTER*4 ISUBN2
6072      CHARACTER*4 ISTEPN
6073      CHARACTER*4 IFLAGU
6074      CHARACTER*4 IREPL
6075      CHARACTER*4 IMULT
6076      CHARACTER*4 ICTMP1
6077      CHARACTER*4 ICTMP2
6078      CHARACTER*4 ICTMP3
6079      CHARACTER*4 ICTMP4
6080      CHARACTER*4 ICASE
6081C
6082      LOGICAL IFRST
6083      LOGICAL ILAST
6084C
6085      CHARACTER*40 INAME
6086      PARAMETER (MAXSPN=30)
6087      CHARACTER*4 IVARN1(MAXSPN)
6088      CHARACTER*4 IVARN2(MAXSPN)
6089      CHARACTER*4 IVARTY(MAXSPN)
6090      CHARACTER*4 IVARID(1)
6091      CHARACTER*4 IVARI2(1)
6092      REAL PVAR(MAXSPN)
6093      REAL PID(MAXSPN)
6094      INTEGER ILIS(MAXSPN)
6095      INTEGER NRIGHT(MAXSPN)
6096      INTEGER ICOLR(MAXSPN)
6097C
6098C---------------------------------------------------------------------
6099C
6100      DIMENSION XTEMP1(*)
6101C
6102C-----COMMON----------------------------------------------------------
6103C
6104      INCLUDE 'DPCOPA.INC'
6105      INCLUDE 'DPCOZZ.INC'
6106C
6107      DIMENSION YTEMP1(MAXOBV)
6108      DIMENSION XDESGN(MAXOBV,7)
6109      DIMENSION XIDTEM(MAXOBV)
6110      DIMENSION XIDTE2(MAXOBV)
6111      DIMENSION XIDTE3(MAXOBV)
6112      DIMENSION XIDTE4(MAXOBV)
6113      DIMENSION XIDTE5(MAXOBV)
6114      DIMENSION XIDTE6(MAXOBV)
6115      DIMENSION TEMP1(MAXOBV)
6116      DIMENSION TEMP2(MAXOBV)
6117C
6118      EQUIVALENCE (GARBAG(IGARB1),YTEMP1(1))
6119      EQUIVALENCE (GARBAG(IGARB2),TEMP1(1))
6120      EQUIVALENCE (GARBAG(IGARB3),XIDTEM(1))
6121      EQUIVALENCE (GARBAG(IGARB4),XIDTE2(1))
6122      EQUIVALENCE (GARBAG(IGARB5),XIDTE3(1))
6123      EQUIVALENCE (GARBAG(IGARB6),XIDTE4(1))
6124      EQUIVALENCE (GARBAG(IGARB7),XIDTE5(1))
6125      EQUIVALENCE (GARBAG(IGARB8),XIDTE6(1))
6126      EQUIVALENCE (GARBAG(IGARB9),TEMP2(1))
6127      EQUIVALENCE (GARBAG(IGAR10),XDESGN(1,1))
6128C
6129C-----COMMON VARIABLES (GENERAL)--------------------------------------
6130C
6131      INCLUDE 'DPCOHK.INC'
6132      INCLUDE 'DPCOSU.INC'
6133      INCLUDE 'DPCODA.INC'
6134      INCLUDE 'DPCOST.INC'
6135      INCLUDE 'DPCOP2.INC'
6136C
6137C-----START POINT-----------------------------------------------------
6138C
6139      ISUBN1='DPMS'
6140      ISUBN2='DT  '
6141      ICASAN='MSDT'
6142      IREPL='NO'
6143      IMULT='NO'
6144      IFOUND='NO'
6145      IERROR='NO'
6146C
6147      NTOT=0
6148      MAXCP1=MAXCOL+1
6149      MAXCP2=MAXCOL+2
6150      MAXCP3=MAXCOL+3
6151      MAXCP4=MAXCOL+4
6152      MAXCP5=MAXCOL+5
6153      MAXCP6=MAXCOL+6
6154C
6155C               *******************************************************
6156C               **  TREAT THE MEAN SUCCESSIVE DIFFERENCES TEST CASE  **
6157C               *******************************************************
6158C
6159      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MSDT')THEN
6160        WRITE(ICOUT,999)
6161  999   FORMAT(1X)
6162        CALL DPWRST('XXX','BUG ')
6163        WRITE(ICOUT,51)
6164   51   FORMAT('***** AT THE BEGINNING OF DPMSDT--')
6165        CALL DPWRST('XXX','BUG ')
6166        WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ,ISUBRO,MAXNXT
6167   52   FORMAT('IBUGA2,IBUGA3,IBUGQ,ISUBRO,MAXNXT = ',4(A4,2X),I8)
6168        CALL DPWRST('XXX','BUG ')
6169      ENDIF
6170C
6171C               *****************************************************
6172C               **  STEP 1--                                       **
6173C               **  EXTRACT THE COMMAND                            **
6174C               **  LOOK FOR ONE OF THE FOLLOWING COMMANDS:        **
6175C               **    1) MEAN SUCCESSIVE DIFFERENCES TEST   Y      **
6176C               **    2) MULTIPLE MEAN SUCCESSIVE DIFFERENCES TEST **
6177C               **                Y1 ... YK                        **
6178C               **    3) REPLICATED MEAN SUCCESSIVE DIFFERENCES    **
6179C               **                  TEST   Y X1 ... XK             **
6180C               *****************************************************
6181C
6182      ISTEPN='1'
6183      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MSDT')
6184     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6185C
6186      ILASTC=9999
6187      ILASTZ=9999
6188C
6189      DO100I=0,NUMARG-1
6190C
6191        IF(I.EQ.0)THEN
6192          ICTMP1=ICOM
6193        ELSE
6194          ICTMP1=IHARG(I)
6195        ENDIF
6196        ICTMP2=IHARG(I+1)
6197        ICTMP3=IHARG(I+2)
6198        ICTMP4=IHARG(I+3)
6199C
6200        IF(ICTMP1.EQ.'=')THEN
6201          IFOUND='NO'
6202          GOTO9000
6203        ELSEIF(ICTMP1.EQ.'MEAN' .AND. ICTMP2.EQ.'SUCC' .AND.
6204     1         ICTMP3.EQ.'DIFF' .AND. ICTMP4.EQ.'TEST')THEN
6205          IFOUND='YES'
6206          ILASTC=I
6207          ILASTZ=I+3
6208        ELSEIF(ICTMP1.EQ.'MEAN' .AND. ICTMP2.EQ.'SUCC' .AND.
6209     1         ICTMP3.EQ.'DIFF')THEN
6210          IFOUND='YES'
6211          ILASTC=I
6212          ILASTZ=I+2
6213        ELSEIF(ICTMP1.EQ.'DURB' .AND. ICTMP2.EQ.'WATS' .AND.
6214     1         ICTMP3.EQ.'TEST')THEN
6215          IFOUND='YES'
6216          ILASTC=I
6217          ILASTZ=I+2
6218        ELSEIF(ICTMP1.EQ.'DURB' .AND. ICTMP2.EQ.'WATS')THEN
6219          IFOUND='YES'
6220          ILASTC=I
6221          ILASTZ=I+1
6222        ELSEIF(ICTMP1.EQ.'ADJA' .AND. ICTMP2.EQ.'RAND' .AND.
6223     1         ICTMP3.EQ.'TEST')THEN
6224          IFOUND='YES'
6225          ILASTC=I
6226          ILASTZ=I+2
6227        ELSEIF(ICTMP1.EQ.'ADJA' .AND. ICTMP2.EQ.'RAND')THEN
6228          IFOUND='YES'
6229          ILASTC=I
6230          ILASTZ=I+1
6231        ELSEIF(ICTMP1.EQ.'ADJA' .AND. ICTMP2.EQ.'TEST')THEN
6232          IFOUND='YES'
6233          ILASTC=I
6234          ILASTZ=I+1
6235        ELSEIF(ICTMP1.EQ.'ADJA')THEN
6236          IFOUND='YES'
6237          ILASTC=I
6238          ILASTZ=I
6239        ELSEIF(ICTMP1.EQ.'REPL')THEN
6240          IREPL='ON'
6241          ILASTC=MIN(ILASTC,I)
6242          ILASTZ=MAX(ILASTZ,I)
6243        ELSEIF(ICTMP1.EQ.'MULT')THEN
6244          IMULT='ON'
6245          ILASTC=MIN(ILASTC,I)
6246          ILASTZ=MAX(ILASTZ,I)
6247        ENDIF
6248  100 CONTINUE
6249C
6250      IF(IFOUND.EQ.'NO')GOTO9000
6251C
6252      ISHIFT=ILASTZ
6253      CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
6254     1            IBUGA2,IERROR)
6255C
6256      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MSDT')THEN
6257        WRITE(ICOUT,91)ICASAN,IMULT,IREPL,ISHIFT
6258   91   FORMAT('DPFRTE: ICASAN,IMULT,IREPL,ISHIFT = ',3(A4,2X),I5)
6259        CALL DPWRST('XXX','BUG ')
6260      ENDIF
6261C
6262      IF(IMULT.EQ.'ON')THEN
6263        IF(IREPL.EQ.'ON')THEN
6264          WRITE(ICOUT,999)
6265          CALL DPWRST('XXX','BUG ')
6266          WRITE(ICOUT,101)
6267  101     FORMAT('***** ERROR IN MEAN SUCCESSIVE DIFFERENCES TEST--')
6268          CALL DPWRST('XXX','BUG ')
6269          WRITE(ICOUT,103)
6270  103     FORMAT('      YOU CANNOT SPECIFY BOTH "MULTIPLE" AND ',
6271     1           '"REPLICATION"')
6272          CALL DPWRST('XXX','BUG ')
6273          WRITE(ICOUT,104)
6274  104     FORMAT('      FOR THE MEAN SUCCESSIVE DIFFERENCES TEST ',
6275     1           'COMMAND.')
6276          CALL DPWRST('XXX','BUG ')
6277          IERROR='YES'
6278          GOTO9000
6279        ENDIF
6280      ENDIF
6281C
6282C               *********************************
6283C               **  STEP 4--                   **
6284C               **  EXTRACT THE VARIABLE LIST  **
6285C               *********************************
6286C
6287      ISTEPN='4'
6288      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MSDT')
6289     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6290C
6291      INAME='MEAN SUCCESSIVE DIFFERENCES TEST'
6292      MINNA=1
6293      MAXNA=100
6294      MINN2=2
6295      IFLAGE=0
6296      IFLAGM=1
6297      IF(IREPL.EQ.'ON')THEN
6298        IFLAGM=0
6299        IFLAGE=1
6300      ENDIF
6301      IFLAGP=0
6302      JMIN=1
6303      JMAX=NUMARG
6304      MINNVA=1
6305      MAXNVA=MAXSPN
6306C
6307      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
6308     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
6309     1            JMIN,JMAX,
6310     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
6311     1            IVARN1,IVARN2,IVARTY,PVAR,
6312     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
6313     1            MINNVA,MAXNVA,
6314     1            IFLAGM,IFLAGP,
6315     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
6316      IF(IERROR.EQ.'YES')GOTO9000
6317C
6318      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MSDT')THEN
6319        WRITE(ICOUT,999)
6320        CALL DPWRST('XXX','BUG ')
6321        WRITE(ICOUT,281)
6322  281   FORMAT('***** AFTER CALL DPPARS--')
6323        CALL DPWRST('XXX','BUG ')
6324        WRITE(ICOUT,282)NQ,NUMVAR
6325  282   FORMAT('NQ,NUMVAR = ',2I8)
6326        CALL DPWRST('XXX','BUG ')
6327        IF(NUMVAR.GT.0)THEN
6328          DO285I=1,NUMVAR
6329            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
6330     1                      ICOLR(I)
6331  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
6332     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
6333            CALL DPWRST('XXX','BUG ')
6334  285     CONTINUE
6335        ENDIF
6336      ENDIF
6337C
6338C               ***********************************************
6339C               **  STEP 5--                                 **
6340C               **  DETERMINE:                               **
6341C               **  1) NUMBER OF REPLICATION VARIABLES (0-6) **
6342C               **  2) NUMBER OF RESPONSE    VARIABLES (>= 1)**
6343C               ***********************************************
6344C
6345      ISTEPN='5'
6346      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MSDT')
6347     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6348C
6349      NRESP=0
6350      NREPL=0
6351      IF(IMULT.EQ.'ON')THEN
6352        NRESP=NUMVAR
6353      ELSEIF(IREPL.EQ.'ON')THEN
6354        NRESP=1
6355        NREPL=NUMVAR-NRESP
6356        IF(NREPL.LT.1 .OR. NREPL.GT.6)THEN
6357          WRITE(ICOUT,999)
6358          CALL DPWRST('XXX','BUG ')
6359          WRITE(ICOUT,101)
6360          CALL DPWRST('XXX','BUG ')
6361          WRITE(ICOUT,511)
6362  511     FORMAT('      FOR THE REPLICATION CASE, THE NUMBER OF ',
6363     1           'REPLICATION VARIABLES')
6364          CALL DPWRST('XXX','BUG ')
6365          WRITE(ICOUT,512)
6366  512     FORMAT('      MUST BE BETWEEN ONE AND SIX.')
6367          CALL DPWRST('XXX','BUG ')
6368          WRITE(ICOUT,513)NREPL
6369  513     FORMAT('      THE NUMBER OF REPLICATION VARIABLES = ',I5)
6370          CALL DPWRST('XXX','BUG ')
6371          IERROR='YES'
6372          GOTO9000
6373        ENDIF
6374      ELSE
6375        NRESP=NUMVAR
6376        IMULT='ON'
6377      ENDIF
6378C
6379      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MSDT')THEN
6380        WRITE(ICOUT,521)NRESP,NREPL
6381  521   FORMAT('NRESP,NREPL = ',2I5)
6382        CALL DPWRST('XXX','BUG ')
6383        ISTEPN='6'
6384        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6385      ENDIF
6386C
6387C               ******************************************************
6388C               **  STEP 6--                                        **
6389C               **  GENERATE THE MEAN SUCCESSIVE DIFFERENCES        **
6390C               **  TEST FOR THE  VARIOUS CASES                     **
6391C               ******************************************************
6392C
6393C
6394C               ******************************************
6395C               **  STEP 8A--                           **
6396C               **  CASE 1: NO REPLICATION VARIABLES    **
6397C               ******************************************
6398C
6399      IF(NREPL.LT.1)THEN
6400        ISTEPN='8A'
6401        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MSDT')
6402     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6403C
6404C       LOOP THROUGH EACH OF THE RESPONSE VARIABLES
6405C
6406        NCURVE=0
6407        DO810IRESP=1,NRESP
6408          NCURVE=NCURVE+1
6409C
6410          IINDX=ICOLR(IRESP)
6411          PID(1)=CPUMIN
6412          IVARID(1)=IVARN1(IRESP)
6413          IVARI2(1)=IVARN2(IRESP)
6414C
6415          IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MSDT')THEN
6416            WRITE(ICOUT,999)
6417            CALL DPWRST('XXX','BUG ')
6418            WRITE(ICOUT,811)IRESP,NCURVE
6419  811       FORMAT('IRESP,NCURVE = ',2I5)
6420            CALL DPWRST('XXX','BUG ')
6421          ENDIF
6422C
6423          ICOL=IRESP
6424          NUMVA2=1
6425          CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
6426     1                INAME,IVARN1,IVARN2,IVARTY,
6427     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
6428     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
6429     1                MAXCP4,MAXCP5,MAXCP6,
6430     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
6431     1                Y,XTEMP1,XTEMP1,NS1,NLOCA2,NLOCA3,ICASE,
6432     1                IBUGA3,ISUBRO,IFOUND,IERROR)
6433          IF(IERROR.EQ.'YES')GOTO9000
6434C
6435C         *****************************************************
6436C         **  STEP 8B--                                      **
6437C         *****************************************************
6438C
6439          IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'MSDT')THEN
6440            ISTEPN='8B'
6441            CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6442            WRITE(ICOUT,999)
6443            CALL DPWRST('XXX','BUG ')
6444            WRITE(ICOUT,822)
6445  822       FORMAT('***** FROM THE MIDDLE  OF DPMSDT--')
6446            CALL DPWRST('XXX','BUG ')
6447            WRITE(ICOUT,823)ICASAN,NUMVAR,NS1
6448  823       FORMAT('ICASAN,NUMVAR,NS1 = ',A4,2I8)
6449            CALL DPWRST('XXX','BUG ')
6450            IF(NS1.GE.1)THEN
6451              DO825I=1,NS1
6452                WRITE(ICOUT,826)I,Y(I)
6453  826           FORMAT('I,Y(I) = ',I8,G15.7)
6454                CALL DPWRST('XXX','BUG ')
6455  825         CONTINUE
6456            ENDIF
6457          ENDIF
6458C
6459          CALL DPMSD2(Y,NS1,
6460     1                XTEMP1,MAXNXT,
6461     1                ICAPSW,ICAPTY,IFORSW,ICASAN,
6462     1                PID,IVARID,IVARI2,NREPL,
6463     1                STATVA,STATV2,STATCD,PVAL,
6464     1                CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50,
6465     1                CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50,
6466     1                ISUBRO,IBUGA3,IERROR)
6467C
6468C               ***************************************
6469C               **  STEP 8C--                        **
6470C               **  UPDATE INTERNAL DATAPLOT TABLES  **
6471C               ***************************************
6472C
6473          ISTEPN='8C'
6474          IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MSDT')
6475     1      CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6476C
6477          IF(NRESP.GT.1)THEN
6478            IFLAGU='FILE'
6479          ELSE
6480            IFLAGU='ON'
6481          ENDIF
6482          IFRST=.FALSE.
6483          ILAST=.FALSE.
6484          IF(IRESP.EQ.1)IFRST=.TRUE.
6485          IF(IRESP.EQ.NRESP)ILAST=.TRUE.
6486          CALL DPMSD5(STATVA,STATV2,STATCD,PVAL,
6487     1                CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50,
6488     1                CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50,
6489     1                IFLAGU,IFRST,ILAST,
6490     1                IBUGA2,IBUGA3,ISUBRO,IERROR)
6491  810   CONTINUE
6492C
6493C               ****************************************************
6494C               **  STEP 9A--                                     **
6495C               **  CASE 3: ONE OR MORE REPLICATION VARIABLES.    **
6496C               **          FOR THIS CASE, THE NUMBER OF RESPONSE **
6497C               **          VARIABLES MUST BE EXACTLY 1.          **
6498C               **          FOR THIS CASE, ALL VARIABLES MUST     **
6499C               **          HAVE THE SAME LENGTH.                 **
6500C               ****************************************************
6501C
6502      ELSEIF(NREPL.GE.1)THEN
6503        ISTEPN='9A'
6504        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MSDT')
6505     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6506C
6507        J=0
6508        IMAX=NRIGHT(1)
6509        IF(NQ.LT.NRIGHT(1))IMAX=NQ
6510        DO910I=1,IMAX
6511          IF(ISUB(I).EQ.0)GOTO910
6512          J=J+1
6513C
6514C         RESPONSE VARIABLE IN Y
6515C
6516          ICOLC=1
6517          IJ=MAXN*(ICOLR(ICOLC)-1)+I
6518          IF(ICOLR(ICOLC).LE.MAXCOL)Y(J)=V(IJ)
6519          IF(ICOLR(ICOLC).EQ.MAXCP1)Y(J)=PRED(I)
6520          IF(ICOLR(ICOLC).EQ.MAXCP2)Y(J)=RES(I)
6521          IF(ICOLR(ICOLC).EQ.MAXCP3)Y(J)=YPLOT(I)
6522          IF(ICOLR(ICOLC).EQ.MAXCP4)Y(J)=XPLOT(I)
6523          IF(ICOLR(ICOLC).EQ.MAXCP5)Y(J)=X2PLOT(I)
6524          IF(ICOLR(ICOLC).EQ.MAXCP6)Y(J)=TAGPLO(I)
6525C
6526          IF(NREPL.GE.1)THEN
6527            DO920IR=1,MIN(NREPL,6)
6528              ICOLC=ICOLC+1
6529              ICOLT=ICOLR(ICOLC)
6530              IJ=MAXN*(ICOLT-1)+I
6531              IF(ICOLT.LE.MAXCOL)XDESGN(J,IR)=V(IJ)
6532              IF(ICOLT.EQ.MAXCP1)XDESGN(J,IR)=PRED(I)
6533              IF(ICOLT.EQ.MAXCP2)XDESGN(J,IR)=RES(I)
6534              IF(ICOLT.EQ.MAXCP3)XDESGN(J,IR)=YPLOT(I)
6535              IF(ICOLT.EQ.MAXCP4)XDESGN(J,IR)=XPLOT(I)
6536              IF(ICOLT.EQ.MAXCP5)XDESGN(J,IR)=X2PLOT(I)
6537              IF(ICOLT.EQ.MAXCP6)XDESGN(J,IR)=TAGPLO(I)
6538  920       CONTINUE
6539          ENDIF
6540C
6541  910   CONTINUE
6542        NLOCAL=J
6543C
6544C       ****************************************************************
6545C       **  STEP 9B--                                                 **
6546C       **  CALL DPMSD2 TO PERFORM MEAN SUCCESSIVE DIFFERENCES TEST.  **
6547C       ****************************************************************
6548C
6549C
6550        IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'MSDT')THEN
6551          ISTEPN='9C'
6552          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6553          WRITE(ICOUT,999)
6554          CALL DPWRST('XXX','BUG ')
6555          WRITE(ICOUT,941)
6556  941     FORMAT('***** FROM THE MIDDLE  OF DPMSDT--')
6557          CALL DPWRST('XXX','BUG ')
6558          WRITE(ICOUT,942)ICASAN,NUMVAR,NLOCAL,NREPL
6559  942     FORMAT('ICASAN,NUMVAR,NLOCAL,NREPL = ',
6560     1           A4,3I8)
6561          CALL DPWRST('XXX','BUG ')
6562          IF(NLOCAL.GE.1)THEN
6563            DO945I=1,NLOCAL
6564              WRITE(ICOUT,946)I,Y(I),XDESGN(I,1),XDESGN(I,2)
6565  946         FORMAT('I,Y(I),XDESGN(I,1),XDESGN(I,2) = ',
6566     1               I8,4F12.5)
6567              CALL DPWRST('XXX','BUG ')
6568  945       CONTINUE
6569          ENDIF
6570        ENDIF
6571C
6572C       *****************************************************
6573C       **  STEP 9C--                                      **
6574C       **  FIND THE DISTINCT VALUES IN EACH OF THE        **
6575C       **  REPLICATION VARIABLES.                         **
6576C       *****************************************************
6577C
6578        CALL DPPP5(XDESGN(1,1),XDESGN(1,2),XDESGN(1,3),
6579     1             XDESGN(1,4),XDESGN(1,5),XDESGN(1,6),
6580     1             NREPL,NLOCAL,MAXOBV,
6581     1             XIDTEM,XIDTE2,XIDTE3,XIDTE4,XIDTE5,XIDTE6,
6582     1             XTEMP1,TEMP2,
6583     1             NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,NUMSE6,
6584     1             IBUGA3,ISUBRO,IERROR)
6585C
6586C       *****************************************************
6587C       **  STEP 9D--                                      **
6588C       **  NOW LOOP THROUGH THE VARIOUS REPLICATIONS      **
6589C       *****************************************************
6590C
6591        NCURVE=0
6592        IADD=1
6593C
6594        PID(1)=CPUMIN
6595        IVARID(1)=IVARN1(1)
6596        IVARI2(1)=IVARN2(1)
6597        IADD=1
6598        DO940II=1,NREPL
6599          IVARID(II+IADD)=IVARN1(II+IADD)
6600          IVARI2(II+IADD)=IVARN2(II+IADD)
6601  940   CONTINUE
6602C
6603        IF(NREPL.EQ.1)THEN
6604          J=0
6605          DO1110ISET1=1,NUMSE1
6606            K=0
6607            PID(IADD+1)=XIDTEM(ISET1)
6608            DO1130I=1,NLOCAL
6609              IF(XIDTEM(ISET1).EQ.XDESGN(I,1))THEN
6610                K=K+1
6611                TEMP1(K)=Y(I)
6612              ENDIF
6613 1130       CONTINUE
6614            NTEMP=K
6615            NCURVE=NCURVE+1
6616            IF(NTEMP.GT.0)THEN
6617              CALL DPMSD2(TEMP1,NTEMP,
6618     1                    XTEMP1,MAXNXT,
6619     1                    ICAPSW,ICAPTY,IFORSW,ICASAN,
6620     1                    PID,IVARID,IVARI2,NREPL,
6621     1                    STATVA,STATV2,STATCD,PVAL,
6622     1                    CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50,
6623     1                    CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50,
6624     1                    ISUBRO,IBUGA3,IERROR)
6625            ENDIF
6626            IFLAGU='FILE'
6627            IFRST=.FALSE.
6628            ILAST=.FALSE.
6629            IF(NCURVE.EQ.1)IFRST=.TRUE.
6630            IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
6631            CALL DPMSD5(STATVA,STATV2,STATCD,PVAL,
6632     1                  CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50,
6633     1                  CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50,
6634     1                  IFLAGU,IFRST,ILAST,
6635     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
6636 1110     CONTINUE
6637        ELSEIF(NREPL.EQ.2)THEN
6638          J=0
6639          NTOT=NUMSE1*NUMSE2
6640          DO1210ISET1=1,NUMSE1
6641          DO1220ISET2=1,NUMSE2
6642            K=0
6643            PID(1+IADD)=XIDTEM(ISET1)
6644            PID(2+IADD)=XIDTE2(ISET2)
6645            DO1290I=1,NLOCAL
6646              IF(
6647     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
6648     1           XIDTE2(ISET2).EQ.XDESGN(I,2)
6649     1          )THEN
6650                K=K+1
6651                TEMP1(K)=Y(I)
6652              ENDIF
6653 1290       CONTINUE
6654            NTEMP=K
6655            NCURVE=NCURVE+1
6656            IF(NTEMP.GT.0)THEN
6657              CALL DPMSD2(TEMP1,NTEMP,
6658     1                    XTEMP1,MAXNXT,
6659     1                    ICAPSW,ICAPTY,IFORSW,ICASAN,
6660     1                    PID,IVARID,IVARI2,NREPL,
6661     1                    STATVA,STATV2,STATCD,PVAL,
6662     1                    CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50,
6663     1                    CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50,
6664     1                    ISUBRO,IBUGA3,IERROR)
6665              IFLAGU='FILE'
6666              IFRST=.FALSE.
6667              ILAST=.FALSE.
6668              IF(NCURVE.EQ.1)IFRST=.TRUE.
6669              IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
6670              CALL DPMSD5(STATVA,STATV2,STATCD,PVAL,
6671     1                    CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50,
6672     1                    CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50,
6673     1                    IFLAGU,IFRST,ILAST,
6674     1                    IBUGA2,IBUGA3,ISUBRO,IERROR)
6675            ENDIF
6676 1220     CONTINUE
6677 1210     CONTINUE
6678        ELSEIF(NREPL.EQ.3)THEN
6679          J=0
6680          NTOT=NUMSE1*NUMSE2*NUMSE3
6681          DO1310ISET1=1,NUMSE1
6682          DO1320ISET2=1,NUMSE2
6683          DO1330ISET3=1,NUMSE3
6684            K=0
6685            PID(1+IADD)=XIDTEM(ISET1)
6686            PID(2+IADD)=XIDTE2(ISET2)
6687            PID(3+IADD)=XIDTE3(ISET3)
6688            DO1390I=1,NLOCAL
6689              IF(
6690     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
6691     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
6692     1           XIDTE3(ISET3).EQ.XDESGN(I,3)
6693     1          )THEN
6694                K=K+1
6695                TEMP1(K)=Y(I)
6696              ENDIF
6697 1390       CONTINUE
6698            NTEMP=K
6699            NCURVE=NCURVE+1
6700            NPLOT1=NPLOTP
6701            IF(NTEMP.GT.0)THEN
6702              CALL DPMSD2(TEMP1,NTEMP,
6703     1                    XTEMP1,MAXNXT,
6704     1                    ICAPSW,ICAPTY,IFORSW,ICASAN,
6705     1                    PID,IVARID,IVARI2,NREPL,
6706     1                    STATVA,STATV2,STATCD,PVAL,
6707     1                    CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50,
6708     1                    CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50,
6709     1                    ISUBRO,IBUGA3,IERROR)
6710              IFLAGU='FILE'
6711              IFRST=.FALSE.
6712              ILAST=.FALSE.
6713              IF(NCURVE.EQ.1)IFRST=.TRUE.
6714              IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
6715              CALL DPMSD5(STATVA,STATV2,STATCD,PVAL,
6716     1                    CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50,
6717     1                    CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50,
6718     1                    IFLAGU,IFRST,ILAST,
6719     1                    IBUGA2,IBUGA3,ISUBRO,IERROR)
6720            ENDIF
6721 1330     CONTINUE
6722 1320     CONTINUE
6723 1310     CONTINUE
6724        ELSEIF(NREPL.EQ.4)THEN
6725          J=0
6726          NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4
6727          DO1410ISET1=1,NUMSE1
6728          DO1420ISET2=1,NUMSE2
6729          DO1430ISET3=1,NUMSE3
6730          DO1440ISET4=1,NUMSE4
6731            K=0
6732            PID(1+IADD)=XIDTEM(ISET1)
6733            PID(2+IADD)=XIDTE2(ISET2)
6734            PID(3+IADD)=XIDTE3(ISET3)
6735            PID(4+IADD)=XIDTE4(ISET4)
6736            DO1490I=1,NLOCAL
6737              IF(
6738     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
6739     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
6740     1           XIDTE3(ISET3).EQ.XDESGN(I,3) .AND.
6741     1           XIDTE4(ISET4).EQ.XDESGN(I,4)
6742     1          )THEN
6743                K=K+1
6744                TEMP1(K)=Y(I)
6745              ENDIF
6746 1490       CONTINUE
6747            NTEMP=K
6748            NCURVE=NCURVE+1
6749            NPLOT1=NPLOTP
6750            IF(NTEMP.GT.0)THEN
6751              CALL DPMSD2(TEMP1,NTEMP,
6752     1                    XTEMP1,MAXNXT,
6753     1                    ICAPSW,ICAPTY,IFORSW,ICASAN,
6754     1                    PID,IVARID,IVARI2,NREPL,
6755     1                    STATVA,STATV2,STATCD,PVAL,
6756     1                    CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50,
6757     1                    CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50,
6758     1                    ISUBRO,IBUGA3,IERROR)
6759              IFLAGU='FILE'
6760              IFRST=.FALSE.
6761              ILAST=.FALSE.
6762              IF(NCURVE.EQ.1)IFRST=.TRUE.
6763              IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
6764              CALL DPMSD5(STATVA,STATV2,STATCD,PVAL,
6765     1                    CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50,
6766     1                    CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50,
6767     1                    IFLAGU,IFRST,ILAST,
6768     1                    IBUGA2,IBUGA3,ISUBRO,IERROR)
6769            ENDIF
6770 1440     CONTINUE
6771 1430     CONTINUE
6772 1420     CONTINUE
6773 1410     CONTINUE
6774        ELSEIF(NREPL.EQ.5)THEN
6775          J=0
6776          NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5
6777          DO1510ISET1=1,NUMSE1
6778          DO1520ISET2=1,NUMSE2
6779          DO1530ISET3=1,NUMSE3
6780          DO1540ISET4=1,NUMSE4
6781          DO1550ISET5=1,NUMSE5
6782            K=0
6783            PID(1+IADD)=XIDTEM(ISET1)
6784            PID(2+IADD)=XIDTE2(ISET2)
6785            PID(3+IADD)=XIDTE3(ISET3)
6786            PID(4+IADD)=XIDTE4(ISET4)
6787            PID(5+IADD)=XIDTE5(ISET4)
6788            DO1590I=1,NLOCAL
6789              IF(
6790     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
6791     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
6792     1           XIDTE3(ISET3).EQ.XDESGN(I,3) .AND.
6793     1           XIDTE4(ISET4).EQ.XDESGN(I,4) .AND.
6794     1           XIDTE5(ISET5).EQ.XDESGN(I,5)
6795     1          )THEN
6796                K=K+1
6797                TEMP1(K)=Y(I)
6798              ENDIF
6799 1590       CONTINUE
6800            NTEMP=K
6801            NCURVE=NCURVE+1
6802            NPLOT1=NPLOTP
6803            IF(NTEMP.GT.0)THEN
6804              CALL DPMSD2(TEMP1,NTEMP,
6805     1                    XTEMP1,MAXNXT,
6806     1                    ICAPSW,ICAPTY,IFORSW,ICASAN,
6807     1                    PID,IVARID,IVARI2,NREPL,
6808     1                    STATVA,STATV2,STATCD,PVAL,
6809     1                    CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50,
6810     1                    CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50,
6811     1                    ISUBRO,IBUGA3,IERROR)
6812              IFLAGU='FILE'
6813              IFRST=.FALSE.
6814              ILAST=.FALSE.
6815              IF(NCURVE.EQ.1)IFRST=.TRUE.
6816              IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
6817              CALL DPMSD5(STATVA,STATV2,STATCD,PVAL,
6818     1                    CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50,
6819     1                    CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50,
6820     1                    IFLAGU,IFRST,ILAST,
6821     1                    IBUGA2,IBUGA3,ISUBRO,IERROR)
6822            ENDIF
6823 1550     CONTINUE
6824 1540     CONTINUE
6825 1530     CONTINUE
6826 1520     CONTINUE
6827 1510     CONTINUE
6828        ELSEIF(NREPL.EQ.6)THEN
6829          J=0
6830          NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5*NUMSE6
6831          DO1610ISET1=1,NUMSE1
6832          DO1620ISET2=1,NUMSE2
6833          DO1630ISET3=1,NUMSE3
6834          DO1640ISET4=1,NUMSE4
6835          DO1650ISET5=1,NUMSE5
6836          DO1660ISET6=1,NUMSE6
6837            K=0
6838            PID(1+IADD)=XIDTEM(ISET1)
6839            PID(2+IADD)=XIDTE2(ISET2)
6840            PID(3+IADD)=XIDTE3(ISET3)
6841            PID(4+IADD)=XIDTE4(ISET4)
6842            PID(5+IADD)=XIDTE5(ISET4)
6843            PID(6+IADD)=XIDTE6(ISET4)
6844            DO1690I=1,NLOCAL
6845              IF(
6846     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
6847     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
6848     1           XIDTE3(ISET3).EQ.XDESGN(I,3) .AND.
6849     1           XIDTE4(ISET4).EQ.XDESGN(I,4) .AND.
6850     1           XIDTE5(ISET5).EQ.XDESGN(I,5) .AND.
6851     1           XIDTE6(ISET6).EQ.XDESGN(I,6)
6852     1          )THEN
6853                K=K+1
6854                TEMP1(K)=Y(I)
6855              ENDIF
6856 1690       CONTINUE
6857            NTEMP=K
6858            NCURVE=NCURVE+1
6859            NPLOT1=NPLOTP
6860            IF(NTEMP.GT.0)THEN
6861              CALL DPMSD2(TEMP1,NTEMP,
6862     1                    XTEMP1,MAXNXT,
6863     1                    ICAPSW,ICAPTY,IFORSW,ICASAN,
6864     1                    PID,IVARID,IVARI2,NREPL,
6865     1                    STATVA,STATV2,STATCD,PVAL,
6866     1                    CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50,
6867     1                    CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50,
6868     1                    ISUBRO,IBUGA3,IERROR)
6869              IFLAGU='FILE'
6870              IFRST=.FALSE.
6871              ILAST=.FALSE.
6872              IF(NCURVE.EQ.1)IFRST=.TRUE.
6873              IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
6874              CALL DPMSD5(STATVA,STATV2,STATCD,PVAL,
6875     1                    CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50,
6876     1                    CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50,
6877     1                    IFLAGU,IFRST,ILAST,
6878     1                    IBUGA2,IBUGA3,ISUBRO,IERROR)
6879            ENDIF
6880 1660     CONTINUE
6881 1650     CONTINUE
6882 1640     CONTINUE
6883 1630     CONTINUE
6884 1620     CONTINUE
6885 1610     CONTINUE
6886        ENDIF
6887C
6888      ENDIF
6889C
6890C               *****************
6891C               **  STEP 90--  **
6892C               **  EXIT       **
6893C               *****************
6894C
6895 9000 CONTINUE
6896      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MSDT')THEN
6897        WRITE(ICOUT,999)
6898        CALL DPWRST('XXX','BUG ')
6899        WRITE(ICOUT,9011)
6900 9011   FORMAT('***** AT THE END       OF DPMSDT--')
6901        CALL DPWRST('XXX','BUG ')
6902        WRITE(ICOUT,9016)IFOUND,IERROR
6903 9016   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
6904        CALL DPWRST('XXX','BUG ')
6905      ENDIF
6906C
6907      RETURN
6908      END
6909      SUBROUTINE DPMSD2(Y,N,
6910     1                  XTEMP,MAXNXT,
6911     1                  ICAPSW,ICAPTY,IFORSW,ICASAN,
6912     1                  PID,IVARID,IVARI2,NREPL,
6913     1                  STATVA,STATV2,STATCD,PVAL,
6914     1                  CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50,
6915     1                  CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50,
6916     1                  ISUBRO,IBUGA3,IERROR)
6917C
6918C     PURPOSE--THIS ROUTINE CARRIES OUT THE MEAN SUCCESSIVE DIFFERENCES
6919C              TEST FOR RANDOMNESS.
6920C     EXAMPLE--MEAN SUCCESSIVE DIFFERENCES TEST Y
6921C     REFERENCE--DEAN V. NEUBAUER, "TESTING FOR RANDOMNESS: THE
6922C                MEAN SUCCESSIVE DIFFERENCE TEST", ASTM STANDARDIZATION
6923C                NEWS, SEPTEMBER/OCTOBER 2012, PP. 12-13.
6924C     WRITTEN BY--ALAN HECKERT
6925C                 STATISTICAL ENGINEERING DIVISION
6926C                 INFORMATION TECHNOLOGY LABORATORY
6927C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
6928C                 GAITHERSBURG, MD 20899-8980
6929C                 PHONE--301-975-2899
6930C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
6931C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
6932C     LANGUAGE--ANSI FORTRAN (1977)
6933C     VERSION NUMBER--2013/1
6934C     ORIGINAL VERSION--JANUARY   2013.
6935C
6936C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
6937C
6938      CHARACTER*4 IVARID(*)
6939      CHARACTER*4 IVARI2(*)
6940C
6941      CHARACTER*4 ICAPSW
6942      CHARACTER*4 ICAPTY
6943      CHARACTER*4 IFORSW
6944      CHARACTER*4 ICASAN
6945      CHARACTER*4 ISUBRO
6946      CHARACTER*4 IBUGA3
6947      CHARACTER*4 IERROR
6948C
6949      CHARACTER*4 IWRITE
6950      CHARACTER*40 IDIST
6951      CHARACTER*4 ISUBN1
6952      CHARACTER*4 ISUBN2
6953      CHARACTER*4 ISTEPN
6954C
6955C---------------------------------------------------------------------
6956C
6957      DIMENSION Y(*)
6958      DIMENSION XTEMP(*)
6959      DIMENSION PID(*)
6960C
6961      PARAMETER (NUMALP=6)
6962      DIMENSION ALPHA(NUMALP)
6963      DIMENSION A10LCL(11)
6964      DIMENSION A05LCL(11)
6965      DIMENSION A01LCL(11)
6966      DIMENSION A10UCL(11)
6967      DIMENSION A05UCL(11)
6968      DIMENSION A01UCL(11)
6969C
6970      PARAMETER(NUMCLI=5)
6971      PARAMETER(MAXLIN=3)
6972      PARAMETER (MAXROW=NUMALP)
6973      PARAMETER (MAXRO2=20)
6974      CHARACTER*60 ITITLE
6975      CHARACTER*60 ITITLZ
6976      CHARACTER*60 ITITL9
6977      CHARACTER*60 ITEXT(MAXRO2)
6978      CHARACTER*4  ALIGN(NUMCLI)
6979      CHARACTER*4  VALIGN(NUMCLI)
6980      REAL         AVALUE(MAXRO2)
6981      INTEGER      NCTEXT(MAXRO2)
6982      INTEGER      IDIGIT(MAXRO2)
6983      INTEGER      NTOT(MAXRO2)
6984      CHARACTER*60 ITITL2(MAXLIN,NUMCLI)
6985      CHARACTER*15 IVALUE(MAXROW,NUMCLI)
6986      CHARACTER*4  ITYPCO(NUMCLI)
6987      INTEGER      NCTIT2(MAXLIN,NUMCLI)
6988      INTEGER      NCVALU(MAXROW,NUMCLI)
6989      INTEGER      IWHTML(NUMCLI)
6990      INTEGER      IWRTF(NUMCLI)
6991      REAL         AMAT(MAXROW,NUMCLI)
6992      LOGICAL IFRST
6993      LOGICAL ILAST
6994      LOGICAL IFLAGS
6995      LOGICAL IFLAGE
6996C
6997C---------------------------------------------------------------------
6998C
6999      INCLUDE 'DPCOP2.INC'
7000C
7001      DATA ALPHA/0.50, 0.80, 0.90, 0.95, 0.99, 0.999/
7002      DATA A10LCL/1.251,1.280,1.306,1.329,1.351,1.370,1.388,1.405,
7003     1            1.420,1.434,1.447/
7004      DATA A05LCL/1.062,1.096,1.128,1.156,1.182,1.205,1.227,1.247,
7005     1            1.266,1.283,1.300/
7006      DATA A01LCL/0.752,0.792,0.828,0.862,0.893,0.922,0.949,0.974,
7007     1            0.998,1.020,1.041/
7008      DATA A10UCL/2.749,2.720,2.694,2.671,2.649,2.630,2.612,2.595,
7009     1            2.580,2.566,2.553/
7010      DATA A05UCL/2.938,2.904,2.872,2.844,2.818,2.795,2.773,2.753,
7011     1            2.734,2.717,2.700/
7012      DATA A01UCL/3.248,3.208,3.172,3.138,3.107,3.078,3.051,3.026,
7013     1            3.002,2.980,2.959/
7014C
7015C-----START POINT-----------------------------------------------------
7016C
7017      ISUBN1='DPMS'
7018      ISUBN2='D2  '
7019      IERROR='NO'
7020C
7021      DO11I=1,MAXNXT
7022        XTEMP(I)=0.0
7023   11 CONTINUE
7024C
7025      CTL999=CPUMIN
7026      CUTL99=CPUMIN
7027      CUTL95=CPUMIN
7028      CUTL90=CPUMIN
7029      CUTL80=CPUMIN
7030      CUTL50=CPUMIN
7031      CTU999=CPUMIN
7032      CUTU99=CPUMIN
7033      CUTU95=CPUMIN
7034      CUTU90=CPUMIN
7035      CUTU80=CPUMIN
7036      CUTU50=CPUMIN
7037      STATVA=CPUMIN
7038      STATV2=CPUMIN
7039      STATCD=CPUMIN
7040      PVAL=CPUMIN
7041C
7042      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MSD2')THEN
7043        WRITE(ICOUT,999)
7044  999   FORMAT(1X)
7045        CALL DPWRST('XXX','WRIT')
7046        WRITE(ICOUT,51)
7047   51   FORMAT('**** AT THE BEGINNING OF DPMSD2--')
7048        CALL DPWRST('XXX','WRIT')
7049        WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASAN,N,MAXNXT
7050   52   FORMAT('IBUGA3,ISUBRO,ICASAN,N,MAXNXT = ',3(A4,2X),2I8)
7051        CALL DPWRST('XXX','WRIT')
7052        DO56I=1,N
7053          WRITE(ICOUT,57)I,Y(I)
7054   57     FORMAT('I,Y(I) = ',I8,G15.7)
7055          CALL DPWRST('XXX','WRIT')
7056   56   CONTINUE
7057      ENDIF
7058C
7059C               ********************************************
7060C               **  STEP 11--                             **
7061C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
7062C               ********************************************
7063C
7064      ISTEPN='11'
7065      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MSD2')
7066     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7067C
7068      IF(N.LE.9)THEN
7069        WRITE(ICOUT,999)
7070        CALL DPWRST('XXX','WRIT')
7071        WRITE(ICOUT,1111)
7072 1111   FORMAT('***** ERROR IN MEAN SUCCESSIVE DIFFERENCES TEST.')
7073        CALL DPWRST('XXX','WRIT')
7074        WRITE(ICOUT,1113)
7075 1113   FORMAT('      AT LEAST TEN OBSERVATIONS REQUIRED.')
7076        CALL DPWRST('XXX','WRIT')
7077        WRITE(ICOUT,1115)N
7078 1115   FORMAT('SAMPLE SIZE = ',I8)
7079        CALL DPWRST('XXX','WRIT')
7080        IERROR='YES'
7081        GOTO9000
7082      ENDIF
7083C
7084      HOLD=Y(1)
7085      DO1135I=2,N
7086      IF(Y(I).NE.HOLD)GOTO1139
7087 1135 CONTINUE
7088      WRITE(ICOUT,999)
7089      CALL DPWRST('XXX','WRIT')
7090      WRITE(ICOUT,1111)
7091      CALL DPWRST('XXX','WRIT')
7092      WRITE(ICOUT,1131)HOLD
7093 1131 FORMAT('      THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7)
7094      CALL DPWRST('XXX','WRIT')
7095      IERROR='YES'
7096      GOTO9000
7097 1139 CONTINUE
7098C
7099C               ******************************************************
7100C               **  STEP 2.1--                                      **
7101C               **  COMPUTE THE TEST STATISTIC (DPMSD3)             **
7102C               ******************************************************
7103C
7104      ISTEPN='2.1'
7105      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MSD2')
7106     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7107C
7108      IFLAG=0
7109      IDIST='NULL'
7110      ALPHAT=0.95
7111      CALL SUMRAW(Y,N,IDIST,IFLAG,
7112     1            YMEAN,YVAR,YSD,YMIN,YMAX,
7113     1            ISUBRO,IBUGA3,IERROR)
7114      CALL DPMSD3(Y,N,IWRITE,ALPHAT,
7115     1            STATVA,STATV2,STATCD,PVAL,
7116     1            ISUBRO,IBUGA3,IERROR)
7117C
7118      CALL NORPPF(.0005,CTL999)
7119      CALL NORPPF(.005,CUTL99)
7120      CALL NORPPF(.025,CUTL95)
7121      CALL NORPPF(.05,CUTL90)
7122      CALL NORPPF(.1,CUTL80)
7123      CALL NORPPF(.25,CUTL50)
7124      CALL NORPPF(.75,CUTU50)
7125      CALL NORPPF(.90,CUTU80)
7126      CALL NORPPF(.95,CUTU90)
7127      CALL NORPPF(.975,CUTU95)
7128      CALL NORPPF(.995,CUTU99)
7129      CALL NORPPF(.9995,CTU999)
7130C
7131C               *********************************************
7132C               **   STEP 41--                             **
7133C               **   WRITE OUT EVERYTHING                  **
7134C               **   FOR MEAN SUCCESSIVE DIFFERENCES TEST  **
7135C               *********************************************
7136C
7137      ISTEPN='41'
7138      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MSD2')
7139     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7140C
7141      IF(IPRINT.EQ.'OFF')GOTO9000
7142C
7143      NUMDIG=7
7144      IF(IFORSW.EQ.'1')NUMDIG=1
7145      IF(IFORSW.EQ.'2')NUMDIG=2
7146      IF(IFORSW.EQ.'3')NUMDIG=3
7147      IF(IFORSW.EQ.'4')NUMDIG=4
7148      IF(IFORSW.EQ.'5')NUMDIG=5
7149      IF(IFORSW.EQ.'6')NUMDIG=6
7150      IF(IFORSW.EQ.'7')NUMDIG=7
7151      IF(IFORSW.EQ.'8')NUMDIG=8
7152      IF(IFORSW.EQ.'9')NUMDIG=9
7153      IF(IFORSW.EQ.'0')NUMDIG=0
7154      IF(IFORSW.EQ.'E')NUMDIG=-2
7155      IF(IFORSW.EQ.'-2')NUMDIG=-2
7156      IF(IFORSW.EQ.'-3')NUMDIG=-3
7157      IF(IFORSW.EQ.'-4')NUMDIG=-4
7158      IF(IFORSW.EQ.'-5')NUMDIG=-5
7159      IF(IFORSW.EQ.'-6')NUMDIG=-6
7160      IF(IFORSW.EQ.'-7')NUMDIG=-7
7161      IF(IFORSW.EQ.'-8')NUMDIG=-8
7162      IF(IFORSW.EQ.'-9')NUMDIG=-9
7163C
7164      ITITLE='Mean Successive Differences Test for Randomness'
7165      NCTITL=47
7166      ITITLZ=' '
7167      NCTITZ=0
7168C
7169      ICNT=1
7170      ITEXT(ICNT)=' '
7171      NCTEXT(ICNT)=0
7172      AVALUE(ICNT)=0.0
7173      IDIGIT(ICNT)=-1
7174C
7175      ICNT=ICNT+1
7176      ITEXT(ICNT)='Response Variable: '
7177      WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1)(1:4)
7178      WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1)(1:4)
7179      NCTEXT(ICNT)=27
7180      AVALUE(ICNT)=0.0
7181      IDIGIT(ICNT)=-1
7182C
7183      IF(NREPL.GT.0)THEN
7184        IADD=1
7185        DO2101I=1,NREPL
7186          ICNT=ICNT+1
7187          ITEMP=I+IADD
7188          ITEXT(ICNT)='Factor Variable  : '
7189          WRITE(ITEXT(ICNT)(17:17),'(I1)')I
7190          WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(ITEMP)(1:4)
7191          WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(ITEMP)(1:4)
7192          NCTEXT(ICNT)=27
7193          AVALUE(ICNT)=PID(ITEMP)
7194          IDIGIT(ICNT)=NUMDIG
7195 2101   CONTINUE
7196      ENDIF
7197C
7198      ICNT=ICNT+1
7199      ITEXT(ICNT)=' '
7200      NCTEXT(ICNT)=1
7201      AVALUE(ICNT)=0.0
7202      IDIGIT(ICNT)=-1
7203C
7204      ICNT=ICNT+1
7205      ITEXT(ICNT)='H0: The Data Are Random'
7206      NCTEXT(ICNT)=23
7207      AVALUE(ICNT)=0.0
7208      IDIGIT(ICNT)=-1
7209      ICNT=ICNT+1
7210      ITEXT(ICNT)='Ha: The Data Are Not Random'
7211      NCTEXT(ICNT)=27
7212      AVALUE(ICNT)=0.0
7213      IDIGIT(ICNT)=-1
7214C
7215      ICNT=ICNT+1
7216      ITEXT(ICNT)=' '
7217      NCTEXT(ICNT)=1
7218      AVALUE(ICNT)=0.0
7219      IDIGIT(ICNT)=-1
7220      ICNT=ICNT+1
7221      ITEXT(ICNT)='Summary Statistics:'
7222      NCTEXT(ICNT)=19
7223      AVALUE(ICNT)=0.0
7224      IDIGIT(ICNT)=-1
7225      ICNT=ICNT+1
7226      ITEXT(ICNT)='Number of Observations:'
7227      NCTEXT(ICNT)=23
7228      AVALUE(ICNT)=REAL(N)
7229      IDIGIT(ICNT)=0
7230      ICNT=ICNT+1
7231      ITEXT(ICNT)='Sample Mean:'
7232      NCTEXT(ICNT)=12
7233      AVALUE(ICNT)=YMEAN
7234      IDIGIT(ICNT)=NUMDIG
7235      ICNT=ICNT+1
7236      ITEXT(ICNT)='Sample Standard Deviation:'
7237      NCTEXT(ICNT)=26
7238      AVALUE(ICNT)=YSD
7239      IDIGIT(ICNT)=NUMDIG
7240      ICNT=ICNT+1
7241      ITEXT(ICNT)='Sample Minimum:'
7242      NCTEXT(ICNT)=15
7243      AVALUE(ICNT)=YMIN
7244      IDIGIT(ICNT)=NUMDIG
7245      ICNT=ICNT+1
7246      ITEXT(ICNT)='Sample Maximum:'
7247      NCTEXT(ICNT)=15
7248      AVALUE(ICNT)=YMAX
7249      IDIGIT(ICNT)=NUMDIG
7250      ICNT=ICNT+1
7251      ITEXT(ICNT)=' '
7252      NCTEXT(ICNT)=1
7253      AVALUE(ICNT)=0.0
7254      IDIGIT(ICNT)=-1
7255C
7256      ICNT=ICNT+1
7257      ITEXT(ICNT)='Test Statistic:'
7258      NCTEXT(ICNT)=15
7259      AVALUE(ICNT)=STATVA
7260      IDIGIT(ICNT)=NUMDIG
7261      ICNT=ICNT+1
7262      ITEXT(ICNT)='Normalized Test Statistic:'
7263      NCTEXT(ICNT)=26
7264      AVALUE(ICNT)=STATV2
7265      IDIGIT(ICNT)=NUMDIG
7266      IF(N.GT.20)THEN
7267        ICNT=ICNT+1
7268        ITEXT(ICNT)='CDF Value:'
7269        NCTEXT(ICNT)=10
7270        AVALUE(ICNT)=STATCD
7271        IDIGIT(ICNT)=NUMDIG
7272      ENDIF
7273CCCCC ICNT=ICNT+1
7274CCCCC ITEXT(ICNT)='P-Value:'
7275CCCCC NCTEXT(ICNT)=8
7276CCCCC AVALUE(ICNT)=PVAL
7277CCCCC IDIGIT(ICNT)=NUMDIG
7278      ICNT=ICNT+1
7279      ITEXT(ICNT)=' '
7280      NCTEXT(ICNT)=1
7281      AVALUE(ICNT)=0.0
7282      IDIGIT(ICNT)=-1
7283C
7284      NUMROW=ICNT
7285      DO4110I=1,NUMROW
7286        NTOT(I)=15
7287 4110 CONTINUE
7288C
7289      IFRST=.TRUE.
7290      ILAST=.TRUE.
7291C
7292      ISTEPN='42A'
7293      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MSD2')
7294     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7295C
7296      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
7297     1            AVALUE,IDIGIT,
7298     1            NTOT,NUMROW,
7299     1            ICAPSW,ICAPTY,ILAST,IFRST,
7300     1            ISUBRO,IBUGA3,IERROR)
7301C
7302      ISTEPN='42D'
7303      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MSD2')
7304     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7305C
7306       IF(N.GT.20)THEN
7307         ITITLE='Test Based on Normal Approximation'
7308         NCTITL=34
7309         ITITL9='Conclusions (Two-Tailed Test)'
7310         NCTIT9=29
7311C
7312         DO5030J=1,4
7313           DO5040I=1,3
7314             ITITL2(I,J)=' '
7315             NCTIT2(I,J)=0
7316 5040      CONTINUE
7317 5030    CONTINUE
7318C
7319        ITITL2(2,1)='Significance'
7320        NCTIT2(2,1)=12
7321        ITITL2(3,1)='Level'
7322        NCTIT2(3,1)=5
7323C
7324        ITITL2(2,2)='Test '
7325        NCTIT2(2,2)=4
7326        ITITL2(3,2)='Statistic'
7327        NCTIT2(3,2)=9
7328C
7329        ITITL2(2,3)='Critical'
7330        NCTIT2(2,3)=8
7331        ITITL2(3,3)='Value (+/-)'
7332        NCTIT2(3,3)=11
7333C
7334        ITITL2(1,4)='Null'
7335        NCTIT2(1,4)=4
7336        ITITL2(2,4)='Hypothesis'
7337        NCTIT2(2,4)=10
7338        ITITL2(3,4)='Conclusion'
7339        NCTIT2(3,4)=10
7340C
7341        NMAX=0
7342        NUMCOL=4
7343        DO5150I=1,NUMCOL
7344          VALIGN(I)='b'
7345          ALIGN(I)='r'
7346          NTOT(I)=15
7347          NMAX=NMAX+NTOT(I)
7348          ITYPCO(I)='NUME'
7349          IDIGIT(I)=NUMDIG
7350          IF(I.EQ.1 .OR. I.EQ.4)THEN
7351            ITYPCO(I)='ALPH'
7352          ENDIF
7353 5150   CONTINUE
7354C
7355        IWHTML(1)=125
7356        IWHTML(2)=175
7357        IWHTML(3)=175
7358        IWHTML(4)=175
7359        IINC=1800
7360        IINC2=1400
7361        IWRTF(1)=IINC
7362        IWRTF(2)=IWRTF(1)+IINC
7363        IWRTF(3)=IWRTF(2)+IINC
7364        IWRTF(4)=IWRTF(3)+IINC
7365C
7366        DO5160J=1,NUMALP
7367C
7368          AMAT(J,2)=STATV2
7369          IF(J.EQ.1)THEN
7370            AMAT(J,3)=CUTU50
7371          ELSEIF(J.EQ.2)THEN
7372            AMAT(J,3)=CUTU80
7373          ELSEIF(J.EQ.3)THEN
7374            AMAT(J,3)=CUTU90
7375          ELSEIF(J.EQ.4)THEN
7376            AMAT(J,3)=CUTU95
7377          ELSEIF(J.EQ.5)THEN
7378            AMAT(J,3)=CUTU99
7379          ELSEIF(J.EQ.6)THEN
7380            AMAT(J,3)=CTU999
7381          ENDIF
7382          IVALUE(J,4)(1:6)='REJECT'
7383          IF(ABS(STATV2).LT.AMAT(J,3))THEN
7384            IVALUE(J,4)(1:6)='ACCEPT'
7385          ENDIF
7386          NCVALU(J,4)=6
7387C
7388          ALPHAT=100.0*ALPHA(J)
7389          WRITE(IVALUE(J,1)(1:4),'(F4.1)')ALPHAT
7390          IVALUE(J,1)(5:5)='%'
7391          NCVALU(J,1)=5
7392 5160   CONTINUE
7393C
7394C
7395        ICNT=NUMALP
7396        NUMLIN=3
7397        NUMCOL=4
7398        IFRST=.TRUE.
7399        ILAST=.TRUE.
7400        IFLAGS=.TRUE.
7401        IFLAGE=.TRUE.
7402        CALL DPDTA5(ITITLE,NCTITL,
7403     1              ITITL9,NCTIT9,ITITL2,NCTIT2,
7404     1              MAXLIN,NUMLIN,NUMCLI,NUMCOL,
7405     1              IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
7406     1              IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
7407     1              ICAPSW,ICAPTY,IFRST,ILAST,
7408     1              IFLAGS,IFLAGE,
7409     1              ISUBRO,IBUGA3,IERROR)
7410       ELSEIF(N.GE.10 .AND. N.LE.20)THEN
7411         ITITLE='Test Based on Tabulated Values'
7412         NCTITL=30
7413         ITITL9='Conclusions (Two-Sided Test)'
7414         NCTIT9=28
7415C
7416         DO6030J=1,5
7417           DO6040I=1,3
7418             ITITL2(I,J)=' '
7419             NCTIT2(I,J)=0
7420 6040      CONTINUE
7421 6030    CONTINUE
7422C
7423        ITITL2(2,1)='Significance'
7424        NCTIT2(2,1)=12
7425        ITITL2(3,1)='Level'
7426        NCTIT2(3,1)=5
7427C
7428        ITITL2(2,2)='Test '
7429        NCTIT2(2,2)=4
7430        ITITL2(3,2)='Statistic'
7431        NCTIT2(3,2)=9
7432C
7433        ITITL2(1,3)='Lower'
7434        NCTIT2(1,3)=5
7435        ITITL2(2,3)='Critical'
7436        NCTIT2(2,3)=8
7437        ITITL2(3,3)='Value (<)'
7438        NCTIT2(3,3)=9
7439C
7440        ITITL2(1,4)='Upper'
7441        NCTIT2(1,4)=5
7442        ITITL2(2,4)='Critical'
7443        NCTIT2(2,4)=8
7444        ITITL2(3,4)='Value (>)'
7445        NCTIT2(3,4)=9
7446C
7447        ITITL2(1,5)='Null'
7448        NCTIT2(1,5)=4
7449        ITITL2(2,5)='Hypothesis'
7450        NCTIT2(2,5)=10
7451        ITITL2(3,5)='Conclusion'
7452        NCTIT2(3,5)=10
7453C
7454        NMAX=0
7455        NUMCOL=5
7456        DO6150I=1,NUMCOL
7457          VALIGN(I)='b'
7458          ALIGN(I)='r'
7459          NTOT(I)=15
7460          NMAX=NMAX+NTOT(I)
7461          ITYPCO(I)='NUME'
7462          IDIGIT(I)=NUMDIG
7463          IF(I.EQ.1 .OR. I.EQ.5)THEN
7464            ITYPCO(I)='ALPH'
7465          ENDIF
7466 6150   CONTINUE
7467C
7468        IWHTML(1)=125
7469        IWHTML(2)=175
7470        IWHTML(3)=175
7471        IWHTML(4)=175
7472        IINC=1800
7473        IINC2=1400
7474        IWRTF(1)=IINC
7475        IWRTF(2)=IWRTF(1)+IINC
7476        IWRTF(3)=IWRTF(2)+IINC
7477        IWRTF(4)=IWRTF(3)+IINC
7478C
7479        IINDX=N-9
7480        CUTL90=A10LCL(IINDX)
7481        CUTL95=A05LCL(IINDX)
7482        CUTL99=A01LCL(IINDX)
7483        CUTU90=A10UCL(IINDX)
7484        CUTU95=A05UCL(IINDX)
7485        CUTU99=A01UCL(IINDX)
7486C
7487        DO6160J=1,3
7488C
7489          AMAT(J,2)=STATVA
7490          IF(J.EQ.1)THEN
7491            AMAT(J,3)=CUTL90
7492            AMAT(J,4)=CUTU90
7493            IVALUE(J,1)(1:3)='90%'
7494            NCVALU(J,1)=3
7495          ELSEIF(J.EQ.2)THEN
7496            AMAT(J,3)=CUTL95
7497            AMAT(J,4)=CUTU95
7498            IVALUE(J,1)(1:3)='95%'
7499            NCVALU(J,1)=3
7500          ELSEIF(J.EQ.3)THEN
7501            AMAT(J,3)=CUTL99
7502            AMAT(J,4)=CUTU99
7503            IVALUE(J,1)(1:3)='99%'
7504            NCVALU(J,1)=3
7505          ENDIF
7506          IVALUE(J,5)(1:6)='ACCEPT'
7507          IF(STATVA.LT.AMAT(J,3))THEN
7508            IVALUE(J,5)(1:6)='REJECT'
7509          ELSEIF(STATVA.GT.AMAT(J,4))THEN
7510            IVALUE(J,5)(1:6)='REJECT'
7511          ENDIF
7512          NCVALU(J,5)=6
7513C
7514 6160   CONTINUE
7515C
7516C
7517        ICNT=3
7518        NUMLIN=3
7519        NUMCOL=5
7520        IFRST=.TRUE.
7521        ILAST=.TRUE.
7522        IFLAGS=.TRUE.
7523        IFLAGE=.TRUE.
7524        CALL DPDTA5(ITITLE,NCTITL,
7525     1              ITITL9,NCTIT9,ITITL2,NCTIT2,
7526     1              MAXLIN,NUMLIN,NUMCLI,NUMCOL,
7527     1              IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
7528     1              IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
7529     1              ICAPSW,ICAPTY,IFRST,ILAST,
7530     1              IFLAGS,IFLAGE,
7531     1              ISUBRO,IBUGA3,IERROR)
7532       ENDIF
7533C
7534C               *****************
7535C               **  STEP 90--  **
7536C               **  EXIT       **
7537C               *****************
7538C
7539 9000 CONTINUE
7540      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MSD2')THEN
7541        WRITE(ICOUT,999)
7542        CALL DPWRST('XXX','WRIT')
7543        WRITE(ICOUT,9011)
7544 9011   FORMAT('***** AT THE END       OF DPMSD2--')
7545        CALL DPWRST('XXX','WRIT')
7546        WRITE(ICOUT,9012)IERROR,STATVA,STATCD,PVAL
7547 9012   FORMAT('IERROR,STATVA,STATCD,PVAL = ',A4,2X,3G15.7)
7548        CALL DPWRST('XXX','WRIT')
7549      ENDIF
7550C
7551      RETURN
7552      END
7553      SUBROUTINE DPMSD3(X,N,IWRITE,ALPHA,
7554     1                  STATVA,STATV2,STATCD,PVAL,
7555     1                  ISUBRO,IBUGA3,IERROR)
7556C
7557C     PURPOSE--THIS SUBROUTINE COMPUTES THE MEAN SUCCESSIVE
7558C              DIFFERENCE TEST FOR RANDOMNESS
7559C     REFERENCE--DEAN V. NEUBAUER, "TESTING FOR RANDOMNESS: THE
7560C                MEAN SUCCESSIVE DIFFERENCE TEST", ASTM STANDARDIZATION
7561C                NEWS, SEPTEMBER/OCTOBER 2012, PP. 12-13.
7562C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
7563C                                (UNSORTED OR SORTED) OBSERVATIONS.
7564C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
7565C                                IN THE VECTOR X.
7566C     OUTPUT ARGUMENTS--STATVA = THE SINGLE PRECISION VALUE OF THE
7567C                                COMPUTED STATISTIC.
7568C                     --STATCD = THE SINGLE PRECISION VALUE OF THE
7569C                                COMPUTED CDF OF THE TEST STATISTIC.
7570C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
7571C             TEST STATISTIC.
7572C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
7573C                   OF N FOR THIS SUBROUTINE.
7574C     OTHER DATAPAC   SUBROUTINES NEEDED--DISTIN
7575C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
7576C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
7577C     LANGUAGE--ANSI FORTRAN (1977)
7578C     WRITTEN BY--ALAN HECKERT
7579C                 STATISTICAL ENGINEERING DIVISION
7580C                 INFORMATION TECHNOLOGY LABORATORY
7581C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
7582C                 GAITHERSBURG, MD 20899-8980
7583C                 PHONE--301-975-2899
7584C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
7585C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
7586C     LANGUAGE--ANSI FORTRAN (1977)
7587C     VERSION NUMBER--2013.1
7588C     ORIGINAL VERSION--JANUARY   2013.
7589C
7590C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
7591C
7592      CHARACTER*4 IWRITE
7593      CHARACTER*4 IWRTSV
7594      CHARACTER*4 ISUBRO
7595      CHARACTER*4 IBUGA3
7596      CHARACTER*4 IERROR
7597C
7598      CHARACTER*4 ISUBN1
7599      CHARACTER*4 ISUBN2
7600C
7601C---------------------------------------------------------------------
7602C
7603      DIMENSION X(*)
7604C
7605      DOUBLE PRECISION DSUM1
7606      DOUBLE PRECISION DENOM
7607      DOUBLE PRECISION DN
7608C
7609C---------------------------------------------------------------------
7610C
7611      INCLUDE 'DPCOP2.INC'
7612C
7613C-----START POINT-----------------------------------------------------
7614C
7615      ISUBN1='DPMS'
7616      ISUBN2='D3  '
7617      IERROR='NO'
7618      IWRTSV=IWRITE
7619      IWRITE='OFF'
7620C
7621      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'MSD3')THEN
7622        WRITE(ICOUT,999)
7623  999   FORMAT(1X)
7624        CALL DPWRST('XXX','BUG ')
7625        WRITE(ICOUT,51)
7626   51   FORMAT('***** AT THE BEGINNING OF DPFRT3--')
7627        CALL DPWRST('XXX','BUG ')
7628        WRITE(ICOUT,52)IBUGA3,ISUBRO,N,ALPHA
7629   52   FORMAT('IBUGA3,ISUBRO,N,ALPHA = ',2(A4,2X),I8,G15.7)
7630        CALL DPWRST('XXX','BUG ')
7631        DO55I=1,N
7632          WRITE(ICOUT,56)I,X(I)
7633   56     FORMAT('I,X(I) = ',I8,G15.7)
7634          CALL DPWRST('XXX','BUG ')
7635   55   CONTINUE
7636      ENDIF
7637C
7638C               ****************************************************
7639C               **  COMPUTE MEAN SUCCESSIVE DIFFERENCE STATISTIC  **
7640C               ****************************************************
7641C
7642C               ********************************************
7643C               **  STEP 1--                              **
7644C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
7645C               ********************************************
7646C
7647      STATVA=-99.0
7648      STATCD=-99.0
7649      AN=N
7650C
7651      IF(N.LE.5)THEN
7652        IERROR='YES'
7653        WRITE(ICOUT,999)
7654        CALL DPWRST('XXX','BUG ')
7655        WRITE(ICOUT,111)
7656  111   FORMAT('***** ERROR IN MEAN SUCCESSIVE DIFFERENCE STATISTIC--')
7657        CALL DPWRST('XXX','BUG ')
7658        WRITE(ICOUT,112)
7659  112   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS FOR THE ',
7660     1         'RESPONSE')
7661        CALL DPWRST('XXX','BUG ')
7662        WRITE(ICOUT,113)
7663  113   FORMAT('      VARIABLE MUST BE 6 OR LARGER.')
7664        CALL DPWRST('XXX','BUG ')
7665        WRITE(ICOUT,116)
7666  116   FORMAT('      SUCH WAS NOT THE CASE HERE.')
7667        CALL DPWRST('XXX','BUG ')
7668        WRITE(ICOUT,117)N
7669  117   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS = ',I8,
7670     1         '.')
7671        CALL DPWRST('XXX','BUG ')
7672        GOTO9000
7673      ENDIF
7674C
7675C               *****************************************
7676C               **  STEP 2--                           **
7677C               **  COMPUTE THE FREQUENCY STATISTIC.   **
7678C               *****************************************
7679C
7680C     THE FORMULA FOR THE MEAN SUCCESSIVE DIFFERENCE TEST IS:
7681C
7682C           M = MSD/s^2
7683C             = (1/(N-1))*SUM[i=1 to n-1][(X(i+1)-X(i))**2/
7684C               (1/N-1))*SUM[i=1 to n][(X(i) - XBAR)**2]
7685C             = SUM[i=1 to n-1][(X(i+1)-X(i))**2/
7686C               SUM[i=1 to n][(X(i) - XBAR)**2]
7687C
7688      CALL VAR(X,N,IWRITE,XVAR,IBUGA3,IERROR)
7689      DENOM=DBLE(N-1)*DBLE(XVAR)
7690      DSUM1=0.0D0
7691      DO100I=1,N-1
7692        DSUM1=DSUM1 + (DBLE(X(I+1)) - DBLE(X(I)))**2
7693  100 CONTINUE
7694      STATVA=REAL(DSUM1/DENOM)
7695      DN=DBLE(N)
7696      DENOM=(DN-2.0D0)/((DN-1.0D0)*(DN+1.0D0))
7697      DNUM=1.0D0 - (DBLE(STATVA)/2.0D0)
7698      STATV2=REAL(DNUM/DSQRT(DENOM))
7699C
7700      CALL NORCDF(STATV2,STATCD)
7701      IF(N.GE.21)THEN
7702        IF(STATV2.LE.0.0)THEN
7703          PVAL=2.0*STATCD
7704        ELSE
7705          PVAL=2.0*(1.0 - STATCD)
7706        ENDIF
7707      ENDIF
7708C
7709      IF(IERROR.EQ.'YES')GOTO9000
7710C
7711C               *******************************
7712C               **  STEP 3--                 **
7713C               **  WRITE OUT A LINE         **
7714C               **  OF SUMMARY INFORMATION.  **
7715C               *******************************
7716C
7717      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
7718        WRITE(ICOUT,999)
7719        CALL DPWRST('XXX','BUG ')
7720        WRITE(ICOUT,811)N,STATVA
7721  811   FORMAT('THE VALUE OF THE MEAN SUCCESSIVE DIFFERENCE STATISTIC ',
7722     '         'OF THE ',I8,' OBSERVATIONS = ',G15.7)
7723        CALL DPWRST('XXX','BUG ')
7724      ENDIF
7725C
7726C               *****************
7727C               **  STEP 90--  **
7728C               **  EXIT.      **
7729C               *****************
7730C
7731 9000 CONTINUE
7732C
7733      IWRITE=IWRTSV
7734C
7735      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'MSD3')THEN
7736        WRITE(ICOUT,999)
7737        CALL DPWRST('XXX','BUG ')
7738        WRITE(ICOUT,9011)
7739 9011   FORMAT('***** AT THE END       OF DPMSD3--')
7740        CALL DPWRST('XXX','BUG ')
7741        WRITE(ICOUT,9015)STATVA,STATCD,IERROR
7742 9015   FORMAT('STATVA,STATCD,IERROR = ',2G15.7,2X,A4)
7743        CALL DPWRST('XXX','BUG ')
7744        WRITE(ICOUT,9017)XVAR,DENOM,DSUM1
7745 9017   FORMAT('XVAR,DENOM,DSUM1 = ',3G15.7)
7746        CALL DPWRST('XXX','BUG ')
7747      ENDIF
7748C
7749      RETURN
7750      END
7751      SUBROUTINE DPMSD5(STATVA,STATV2,STATCD,PVAL,
7752     1                  CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50,
7753     1                  CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50,
7754     1                  IFLAGU,IFRST,ILAST,
7755     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
7756C
7757C     PURPOSE--UTILITY ROUTINE USED BY DPMSDT.  THIS ROUTINE
7758C              UPDATES VARIOUS PARAMETERS AFTER A MEAN SUCCESSIVE
7759C              DIFFERENCES TEST.
7760C     WRITTEN BY--ALAN HECKERT
7761C                 STATISTICAL ENGINEERING DIVISION
7762C                 INFORMATION TECHNOLOGY LABORAOTRY
7763C                 NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY
7764C                 GAITHERSBURG, MD 20899-8980
7765C                 PHONE--301-975-2899
7766C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
7767C           OF THE NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY.
7768C     LANGUAGE--ANSI FORTRAN (1977)
7769C     VERSION NUMBER--2013/1
7770C     ORIGINAL VERSION--JANUARY   2013.
7771C     UPDATED         --APRIL     2019. USER CAN SPECIFY NUMBER OF
7772C                                       DECIMAL POINTS FOR AUXILLARY
7773C                                       FILES
7774C
7775C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
7776C
7777      CHARACTER*4 IFLAGU
7778      CHARACTER*4 IBUGA2
7779      CHARACTER*4 IBUGA3
7780      CHARACTER*4 ISUBRO
7781      CHARACTER*4 IERROR
7782C
7783      LOGICAL IFRST
7784      LOGICAL ILAST
7785C
7786      CHARACTER*4 IH
7787      CHARACTER*4 IH2
7788      CHARACTER*4 ISUBN0
7789      CHARACTER*4 ISUBN1
7790      CHARACTER*4 ISUBN2
7791      CHARACTER*4 ISTEPN
7792      CHARACTER*4 IOP
7793      CHARACTER*20 IFORMT
7794C
7795      SAVE IOUNI1
7796C
7797C-----COMMON VARIABLES (GENERAL)--------------------------------------
7798C
7799      INCLUDE 'DPCOPA.INC'
7800      INCLUDE 'DPCOHK.INC'
7801      INCLUDE 'DPCOHO.INC'
7802      INCLUDE 'DPCOST.INC'
7803      INCLUDE 'DPCOP2.INC'
7804C
7805C-----START POINT-----------------------------------------------------
7806C
7807      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'MSD5')THEN
7808        ISTEPN='1'
7809        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7810        WRITE(ICOUT,999)
7811  999   FORMAT(1X)
7812        CALL DPWRST('XXX','BUG ')
7813        WRITE(ICOUT,51)
7814   51   FORMAT('***** AT THE BEGINNING OF DPMSD5--')
7815        CALL DPWRST('XXX','BUG ')
7816        WRITE(ICOUT,53)STATVA,STATV2,STATCD,PVAL
7817   53   FORMAT('STATVA,STATV2,STATCD,PVAL = ',4G15.7)
7818        CALL DPWRST('XXX','BUG ')
7819      ENDIF
7820C
7821      IF(IFLAGU.EQ.'FILE')THEN
7822C
7823        IF(IFRST)THEN
7824          IOP='OPEN'
7825          IFLAG1=1
7826          IFLAG2=0
7827          IFLAG3=0
7828          IFLAG4=0
7829          IFLAG5=0
7830          CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
7831     1                IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
7832     1                IBUGA3,ISUBRO,IERROR)
7833          IF(IERROR.EQ.'YES')GOTO9000
7834C
7835          WRITE(IOUNI1,295)
7836  295     FORMAT(11X,'STATVAL',8X,'STATVAL2',7X,'STATCDF',8X,
7837     1           'PVALUE',7X,
7838     1           'CUTLOW50',7X,'CUTLOW80',7X,'CUTLOW90',7X,
7839     1           'CUTLOW95',7X,'CUTLOW99',7X,'CUTLO999',7X,
7840     1           'CUTUPP50',7X,'CUTUPP80',7X,'CUTUPP90',7X,
7841     1           'CUTUPP95',7X,'CUTUPP99',7X,'CUTUP999')
7842        ENDIF
7843C
7844        IFORMT='(16E15.7)'
7845        IF(IAUXDP.NE.7)THEN
7846          IFORMT=' '
7847          IF(IAUXDP.LE.9)THEN
7848            IFORMT='(16Exx.x)'
7849            ITOT=IAUXDP+8
7850            WRITE(IFORMT(5:6),'(I2)')ITOT
7851            WRITE(IFORMT(8:8),'(I1)')IAUXDP
7852          ELSE
7853            IFORMT='(16Exx.xx)'
7854            ITOT=IAUXDP+8
7855            WRITE(IFORMT(5:6),'(I2)')ITOT
7856            WRITE(IFORMT(8:9),'(I2)')IAUXDP
7857          ENDIF
7858        ENDIF
7859C
7860        WRITE(IOUNI1,IFORMT)STATVA,STATV2,STATCD,PVAL,
7861     1                   CUTL50,CUTL80,CUTL90,CUTL95,CUTL99,CTL999,
7862     1                   CUTU50,CUTU80,CUTU90,CUTU95,CUTU99,CTU999
7863CC299   FORMAT(16E15.7)
7864      ELSEIF(IFLAGU.EQ.'ON')THEN
7865        IF(STATVA.NE.CPUMIN)THEN
7866          IH='STAT'
7867          IH2='VAL '
7868          VALUE0=STATVA
7869          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
7870     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
7871     1                IANS,IWIDTH,IBUGA3,IERROR)
7872        ENDIF
7873C
7874        IF(STATV2.NE.CPUMIN)THEN
7875          IH='STAT'
7876          IH2='VAL2'
7877          VALUE0=STATV2
7878          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
7879     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
7880     1                IANS,IWIDTH,IBUGA3,IERROR)
7881        ENDIF
7882C
7883        IF(STATCD.NE.CPUMIN)THEN
7884          IH='STAT'
7885          IH2='CDF '
7886          VALUE0=STATCD
7887          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
7888     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
7889     1                IANS,IWIDTH,IBUGA3,IERROR)
7890        ENDIF
7891C
7892        IF(PVAL.NE.CPUMIN)THEN
7893          IH='PVAL'
7894          IH2='UE  '
7895          VALUE0=PVAL
7896          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
7897     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
7898     1                IANS,IWIDTH,IBUGA3,IERROR)
7899        ENDIF
7900C
7901        IF(CUTL50.NE.CPUMIN)THEN
7902          IH='CUTL'
7903          IH2='OW50'
7904          VALUE0=CUTL50
7905          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
7906     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
7907     1                IANS,IWIDTH,IBUGA3,IERROR)
7908        ENDIF
7909C
7910        IF(CUTU50.NE.CPUMIN)THEN
7911          IH='CUTU'
7912          IH2='PP50'
7913          VALUE0=CUTU50
7914          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
7915     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
7916     1                IANS,IWIDTH,IBUGA3,IERROR)
7917        ENDIF
7918C
7919        IF(CUTL80.NE.CPUMIN)THEN
7920          IH='CUTL'
7921          IH2='OW80'
7922          VALUE0=CUTL80
7923          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
7924     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
7925     1                IANS,IWIDTH,IBUGA3,IERROR)
7926        ENDIF
7927C
7928        IF(CUTU80.NE.CPUMIN)THEN
7929          IH='CUTU'
7930          IH2='PP80'
7931          VALUE0=CUTU80
7932          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
7933     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
7934     1                IANS,IWIDTH,IBUGA3,IERROR)
7935        ENDIF
7936C
7937        IF(CUTL90.NE.CPUMIN)THEN
7938          IH='CUTL'
7939          IH2='OW90'
7940          VALUE0=CUTL90
7941          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
7942     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
7943     1                IANS,IWIDTH,IBUGA3,IERROR)
7944        ENDIF
7945C
7946        IF(CUTU90.NE.CPUMIN)THEN
7947          IH='CUTU'
7948          IH2='PP90'
7949          VALUE0=CUTU90
7950          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
7951     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
7952     1                IANS,IWIDTH,IBUGA3,IERROR)
7953        ENDIF
7954C
7955        IF(CUTL95.NE.CPUMIN)THEN
7956          IH='CUTL'
7957          IH2='OW95'
7958          VALUE0=CUTL95
7959          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
7960     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
7961     1                IANS,IWIDTH,IBUGA3,IERROR)
7962        ENDIF
7963C
7964        IF(CUTU95.NE.CPUMIN)THEN
7965          IH='CUTU'
7966          IH2='PP95'
7967          VALUE0=CUTU95
7968          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
7969     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
7970     1                IANS,IWIDTH,IBUGA3,IERROR)
7971        ENDIF
7972C
7973        IF(CUTL99.NE.CPUMIN)THEN
7974          IH='CUTL'
7975          IH2='OW99'
7976          VALUE0=CUTL99
7977          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
7978     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
7979     1                IANS,IWIDTH,IBUGA3,IERROR)
7980        ENDIF
7981C
7982        IF(CUTU99.NE.CPUMIN)THEN
7983          IH='CUTU'
7984          IH2='PP99'
7985          VALUE0=CUTU99
7986          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
7987     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
7988     1                IANS,IWIDTH,IBUGA3,IERROR)
7989        ENDIF
7990C
7991        IF(CTL999.NE.CPUMIN)THEN
7992          IH='CUTL'
7993          IH2='O999'
7994          VALUE0=CTL999
7995          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
7996     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
7997     1                IANS,IWIDTH,IBUGA3,IERROR)
7998        ENDIF
7999C
8000        IF(CTU999.NE.CPUMIN)THEN
8001          IH='CUTU'
8002          IH2='P999'
8003          VALUE0=CTU999
8004          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
8005     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
8006     1                IANS,IWIDTH,IBUGA3,IERROR)
8007        ENDIF
8008      ENDIF
8009C
8010      IF(IFLAGU.EQ.'FILE')THEN
8011        IF(ILAST)THEN
8012          IOP='CLOS'
8013          IFLAG1=1
8014          IFLAG2=0
8015          IFLAG3=0
8016          IFLAG4=0
8017          IFLAG5=0
8018          CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
8019     1                IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
8020     1                IBUGA3,ISUBRO,IERROR)
8021C
8022          IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'MSD5')THEN
8023            ISTEPN='3A'
8024            CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8025            WRITE(ICOUT,999)
8026            CALL DPWRST('XXX','BUG ')
8027            WRITE(ICOUT,301)IERROR
8028  301       FORMAT('AFTER CALL DPCLFI, IERROR = ',A4)
8029            CALL DPWRST('XXX','BUG ')
8030          ENDIF
8031C
8032          IF(IERROR.EQ.'YES')GOTO9000
8033        ENDIF
8034      ENDIF
8035C
8036C               *****************
8037C               **  STEP 90--  **
8038C               **  EXIT       **
8039C               *****************
8040C
8041 9000 CONTINUE
8042C
8043      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'MSD5')THEN
8044        WRITE(ICOUT,999)
8045        CALL DPWRST('XXX','BUG ')
8046        WRITE(ICOUT,9011)
8047 9011   FORMAT('***** AT THE END OF DPMSD5--')
8048        CALL DPWRST('XXX','BUG ')
8049      ENDIF
8050C
8051      RETURN
8052      END
8053      SUBROUTINE DPMUCC(IHARG,IHARG2,IARGT,ARG,NUMARG,
8054     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,IANS,IWIDTH,
8055     1PMXMIN,PMXMAX,PMYMIN,PMYMAX,
8056     1IBUGP2,IFOUND,IERROR)
8057C
8058C     PURPOSE--DEFINE THE MULTIPLOT CORNER COORDINATES
8059C              (LOWER LEFT AND UPPER RIGHT)
8060C              WHICH IN TURN WILL DEFINE THE SIZE AND SHAPE
8061C              OF THE TOTAL PLOT FRAME FOR MULTIPLOTS.
8062C              THE 2 PAIRS OF COORDINATES ARE CONTAINED IN THE
8063C              4 VARIABLES    PMXMIN,PMYMIN    AND    PMXMAX,PMYMAX
8064C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
8065C                     --IARGT  (A  HOLLERITH VECTOR)
8066C                     --ARG    (A  FLOATING POINT VECTOR)
8067C                     --NUMARG
8068C     OUTPUT ARGUMENTS--PMXMIN = X COOR. FOR LOWER LEFT  CORNER
8069C                     --PMXMAX = X COOR. FOR UPPER RIGHT CORNER
8070C                     --PMYMIN = Y COOR. FOR LOWER LEFT  CORNER
8071C                     --PMYMAX = Y COOR. FOR UPPER RIGHT CORNER
8072C                     --IFOUND ('YES' OR 'NO' )
8073C                     --IERROR ('YES' OR 'NO' )
8074C     WRITTEN BY--JAMES J. FILLIBEN
8075C                 STATISTICAL ENGINEERING DIVISION
8076C                 INFORMATION TECHNOLOGY LABORATORY
8077C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
8078C                 GAITHERSBURG, MD 20899-8980
8079C                 PHONE--301-975-2855
8080C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
8081C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
8082C     LANGUAGE--ANSI FORTRAN (1977)
8083C     VERSION NUMBER--86/7
8084C     ORIGINAL VERSION--MARCH     1986.
8085C
8086C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
8087C
8088      CHARACTER*4 IHARG
8089      CHARACTER*4 IHARG2
8090      CHARACTER*4 IARGT
8091      CHARACTER*4 IHNAME
8092      CHARACTER*4 IHNAM2
8093      CHARACTER*4 IUSE
8094      CHARACTER*4 IANS
8095      CHARACTER*4 IBUGP2
8096      CHARACTER*4 IFOUND
8097      CHARACTER*4 IERROR
8098C
8099      CHARACTER*4 IHWUSE
8100      CHARACTER*4 MESSAG
8101      CHARACTER*4 IHWORD
8102      CHARACTER*4 IHWOR2
8103C
8104      CHARACTER*4 ISUBN1
8105      CHARACTER*4 ISUBN2
8106C
8107C---------------------------------------------------------------------
8108C
8109      DIMENSION IHARG(*)
8110      DIMENSION IHARG2(*)
8111      DIMENSION IARGT(*)
8112      DIMENSION ARG(*)
8113C
8114      DIMENSION IHNAME(*)
8115      DIMENSION IHNAM2(*)
8116      DIMENSION IUSE(*)
8117      DIMENSION IN(*)
8118      DIMENSION IVALUE(*)
8119      DIMENSION VALUE(*)
8120      DIMENSION IANS(*)
8121C
8122C---------------------------------------------------------------------
8123C
8124      INCLUDE 'DPCOP2.INC'
8125C
8126C-----START POINT-----------------------------------------------------
8127C
8128      ISUBN1='DPMU'
8129      ISUBN2='CC  '
8130      IFOUND='NO'
8131      IERROR='NO'
8132C
8133      IF(IBUGP2.EQ.'OFF')GOTO90
8134      WRITE(ICOUT,999)
8135  999 FORMAT(1X)
8136      CALL DPWRST('XXX','BUG ')
8137      WRITE(ICOUT,51)
8138   51 FORMAT('***** AT THE END       OF DPMUCC--')
8139      CALL DPWRST('XXX','BUG ')
8140      WRITE(ICOUT,52)IFOUND,IERROR
8141   52 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
8142      CALL DPWRST('XXX','BUG ')
8143      WRITE(ICOUT,53)PMXMIN,PMXMAX,PMYMIN,PMYMAX
8144   53 FORMAT('PMXMIN,PMXMAX,PMYMIN,PMYMAX = ',4E15.7)
8145      CALL DPWRST('XXX','BUG ')
8146   90 CONTINUE
8147C
8148C               **************************************************
8149C               **  TREAT THE    MULTIPLOT COORDINATES    CASE  **
8150C               **************************************************
8151C
8152      IF(NUMARG.EQ.1)GOTO1150
8153      GOTO1110
8154C
8155 1110 CONTINUE
8156      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
8157      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
8158      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
8159      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
8160      IF(NUMARG.GE.2)GOTO1175
8161      GOTO1120
8162C
8163 1120 CONTINUE
8164      IERROR='YES'
8165      WRITE(ICOUT,1121)
8166 1121 FORMAT('***** ERROR IN DPMUCC--')
8167      CALL DPWRST('XXX','BUG ')
8168      WRITE(ICOUT,1122)
8169 1122 FORMAT('      ILLEGAL FORM FOR MULTIPLOT COORDINATES ',
8170     1'COMMAND.')
8171      CALL DPWRST('XXX','BUG ')
8172      WRITE(ICOUT,1124)
8173 1124 FORMAT('      TEST EXAMPLE TO DEMONSTRATE THE ',
8174     1'PROPER FORM--')
8175      CALL DPWRST('XXX','BUG ')
8176      WRITE(ICOUT,1125)
8177 1125 FORMAT('      SUPPOSE IT IS DESIRED TO POSITION   ')
8178      CALL DPWRST('XXX','BUG ')
8179      WRITE(ICOUT,1126)
8180 1126 FORMAT('      THE LOWER LEFT CORNER OF THE MULTIPLOT')
8181      CALL DPWRST('XXX','BUG ')
8182      WRITE(ICOUT,1127)
8183 1127 FORMAT('      10% ACROSS THE PAGE AND 20% UP THE PAGE, AND')
8184      CALL DPWRST('XXX','BUG ')
8185      WRITE(ICOUT,1128)
8186 1128 FORMAT('      THE UPPER RIGHT CORNER OF THE MULTIPLOT')
8187      CALL DPWRST('XXX','BUG ')
8188      WRITE(ICOUT,1129)
8189 1129 FORMAT('      90% ACROSS THE PAGE AND 80% UP THE PAGE,')
8190      CALL DPWRST('XXX','BUG ')
8191      WRITE(ICOUT,1130)
8192 1130 FORMAT('      THEN THE ALLOWABLE FORM IS--')
8193      CALL DPWRST('XXX','BUG ')
8194      WRITE(ICOUT,1131)
8195 1131 FORMAT('      MULTIPLOT COORDINATES 10 20 90 80')
8196      CALL DPWRST('XXX','BUG ')
8197      GOTO9000
8198C
8199 1150 CONTINUE
8200      PMXMIN=15.
8201      PMYMIN=20.
8202      PMXMAX=85.
8203      PMYMAX=90.
8204      GOTO1180
8205C
8206 1175 CONTINUE
8207      DO1176J=2,NUMARG
8208      IF(IARGT(J).EQ.'NUMB')GOTO1177
8209      GOTO1178
8210 1177 CONTINUE
8211      IF(J.EQ.2)PMXMIN=ARG(J)
8212      IF(J.EQ.3)PMYMIN=ARG(J)
8213      IF(J.EQ.4)PMXMAX=ARG(J)
8214      IF(J.EQ.5)PMYMAX=ARG(J)
8215      GOTO1176
8216 1178 CONTINUE
8217      IHWORD=IHARG(J)
8218      IHWOR2=IHARG2(J)
8219      IHWUSE='P'
8220      MESSAG='YES'
8221      CALL CHECKN(IHWORD,IHWOR2,IHWUSE,
8222     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
8223     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR)
8224      IF(IERROR.EQ.'YES')GOTO9000
8225      IF(J.EQ.2)PMXMIN=VALUE(ILOC)
8226      IF(J.EQ.3)PMYMIN=VALUE(ILOC)
8227      IF(J.EQ.4)PMXMAX=VALUE(ILOC)
8228      IF(J.EQ.5)PMYMAX=VALUE(ILOC)
8229 1176 CONTINUE
8230      GOTO1180
8231C
8232 1180 CONTINUE
8233      IFOUND='YES'
8234C
8235      IF(IFEEDB.EQ.'OFF')GOTO1189
8236      WRITE(ICOUT,999)
8237      CALL DPWRST('XXX','BUG ')
8238      WRITE(ICOUT,1185)
8239 1185 FORMAT('THE MULTIPLOT COORDINATES HAVE JUST BEEN SET ',
8240     1'AS FOLLOWS--')
8241      CALL DPWRST('XXX','BUG ')
8242      WRITE(ICOUT,1186)PMXMIN,PMYMIN
8243 1186 FORMAT('    (X,Y) FOR LOWER LEFT  CORNER OF MULTIPLOT = ',
8244     12E15.7)
8245      CALL DPWRST('XXX','BUG ')
8246      WRITE(ICOUT,1187)PMXMAX,PMYMAX
8247 1187 FORMAT('    (X,Y) FOR UPPER RIGHT CORNER OF MULTIPLOT = ',
8248     12E15.7)
8249      CALL DPWRST('XXX','BUG ')
8250 1189 CONTINUE
8251      GOTO9000
8252C
8253C               *****************
8254C               **  STEP 90--  **
8255C               **  EXIT       **
8256C               *****************
8257C
8258 9000 CONTINUE
8259      IF(IBUGP2.EQ.'OFF')GOTO9090
8260      WRITE(ICOUT,999)
8261      CALL DPWRST('XXX','BUG ')
8262      WRITE(ICOUT,9011)
8263 9011 FORMAT('***** AT THE END       OF DPMUCC--')
8264      CALL DPWRST('XXX','BUG ')
8265      WRITE(ICOUT,9012)IFOUND,IERROR
8266 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
8267      CALL DPWRST('XXX','BUG ')
8268      WRITE(ICOUT,9013)PMXMIN,PMXMAX,PMYMIN,PMYMAX
8269 9013 FORMAT('PMXMIN,PMXMAX,PMYMIN,PMYMAX = ',4E15.7)
8270      CALL DPWRST('XXX','BUG ')
8271 9090 CONTINUE
8272C
8273      RETURN
8274      END
8275      SUBROUTINE DPMULT(IHARG,IHARG2,IARGT,IARG,ARG,NUMARG,
8276     1                  IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,
8277     1                  NUMNAM,MAXNAM,IANS,IWIDTH,
8278     1                  IMPSW,IMPNR,IMPNC,IMPCO,IMPCO9,
8279     1                  IMPARG,
8280     1                  AMPSCH,AMPSCW,
8281     1                  PMXMIN,PMXMAX,PMYMIN,PMYMAX,
8282     1                  IERASW,
8283     1                  PWXMIN,PWXMAX,PWYMIN,PWYMAX,
8284     1                  IERASV,
8285     1                  PWXMIS,PWXMAS,PWYMIS,PWYMAS,
8286     1                  IBUGP2,IFOUND,IERROR)
8287C
8288C     PURPOSE--DEFINE THE MULTIPLOT PARAMETERS
8289C              WHICH ALLOW PROPER POSITIONING OF
8290C              SUCCEEDING SUB-PLOTS.
8291C              IMPSW = MULTIPLOT SWITCH (OFF OR ON)
8292C              IMPNR = NUMBER OF MULTIPLOT ROWS
8293C              IMPNC = NUMBER OF MULTIPLOT COLUMNS
8294C              IMPCO = CURRENT MULTIPLOT EXISTING SUBPLOT COUNT
8295C              IMPARG= NUMBER OF ARGUMENTS FOR MULTIPLOT
8296C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
8297C                     --IARGT  (A  HOLLERITH VECTOR)
8298C                     --IARG   (AN INTEGER VECTOR)
8299C                     --ARG    (A  FLOATING POINT VECTOR)
8300C                     --NUMARG
8301C     OUTPUT ARGUMENTS/-IMPSW = ON-OFF MULTIPLOT SWITCH
8302C                     --IMPNR = NUMBER OF ROWS OF SUBPLOTS
8303C                     --IMPNC = NUMBER OF COLUMNS OF SUBPLOTS
8304C                     --IMPCO = NUMBER OF ALREADY-EXISTING SUBPLOTS
8305C                     --IFOUND ('YES' OR 'NO' )
8306C                     --IERROR ('YES' OR 'NO' )
8307C     NOTE--MULTIPLOT IS USED IN DPGRAP
8308C     WRITTEN BY--JAMES J. FILLIBEN
8309C                 STATISTICAL ENGINEERING DIVISION
8310C                 INFORMATION TECHNOLOGY LABORATORY
8311C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
8312C                 GAITHERSBURG, MD 20899-8980
8313C                 PHONE--301-975-2855
8314C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
8315C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
8316C     LANGUAGE--ANSI FORTRAN (1977)
8317C     VERSION NUMBER--82/7
8318C     ORIGINAL VERSION--MARCH     1986.
8319C     UPDATED         --MARCH     1988.  ALLOW 4-ARGUMENT FORM
8320C     UPDATED         --NOVEMBER  1991.  MULTIPLOT FREEZE OR HOLD
8321C     UPDATED         --NOVEMBER  1991.  MULTIPLOT UNFREEZE OR UNHOLD
8322C     UPDATED         --SEPTEMBER 1992.  CHECK FOR ARGS = 0
8323C     UPDATED         --SEPTEMBER 1993.  OMIT AUTO-ERASE
8324C     UPDATED         --SEPTEMBER 1993.  FIX FREEZE/UNFREEZE
8325C     UPDATED         --OCTOBER   1993.  FIX OVERWRITE
8326C     UPDATED         --SEPTEMBER 1995.  FIX NO-ARGUMENT BOMB
8327C     UPDATED         --SEPTEMBER 1998.  MULTIPLOT SCALE FACTOR
8328C     UPDATED         --AUGUST    1999.  RETURN NUMBER OF ARGUMENTS
8329C                                        (INITIAL PAGE ERASE SUPPRESSED
8330C                                        FOR 3 AND 4 ARGUMENT VERSION
8331C                                        OF MULTIPLOT)
8332C     UPDATED         --APRIL     2011.  SECOND COUNTER FOR MULTIPLOT
8333C
8334C                                        THIS SECOND COUNTER IS USED
8335C                                        TO ENSURE THAT AN INITIAL PAGE
8336C                                        ERASE IS PERFORMED WHEN USING
8337C                                        THE 3 AND 4 ARGUMENT SYNTAX
8338C                                        OF THE MULTIPLOT COMMAND.
8339C                                        THESE SUPPRESS THE INITIAL
8340C                                        PAGE ERASE IF IMPCO = 1 SINCE
8341C                                        THIS IS NOT NECCESSARILY THE
8342C                                        FIRST PLOT DRAWN.  SET THE
8343C                                        SECOND COUNTER TO 1 WHEN THE
8344C                                        INITIAL TWO ARGUMENT MULTIPLOT
8345C                                        COMMAND IS GIVEN AND THEN
8346C                                        INCREMENT IN DPGRAP.  THE
8347C                                        END OF MULTIPLOT WILL ALSO
8348C                                        RESET THIS SECOND COUNTER.
8349C
8350C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
8351C
8352      CHARACTER*4 IHARG
8353      CHARACTER*4 IHARG2
8354      CHARACTER*4 IARGT
8355      CHARACTER*4 IHNAME
8356      CHARACTER*4 IHNAM2
8357      CHARACTER*4 IUSE
8358      CHARACTER*4 IANS
8359C
8360      CHARACTER*4 IMPSW
8361      CHARACTER*4 IERASV
8362      CHARACTER*4 IERASW
8363      CHARACTER*4 IBUGP2
8364      CHARACTER*4 IFOUND
8365      CHARACTER*4 IERROR
8366C
8367      CHARACTER*4 IHWUSE
8368      CHARACTER*4 MESSAG
8369      CHARACTER*4 IHWORD
8370      CHARACTER*4 IHWOR2
8371C
8372      CHARACTER*4 ISUBN1
8373      CHARACTER*4 ISUBN2
8374C
8375C---------------------------------------------------------------------
8376C
8377      DIMENSION IHARG(*)
8378      DIMENSION IHARG2(*)
8379      DIMENSION IARGT(*)
8380      DIMENSION IARG(*)
8381      DIMENSION ARG(*)
8382C
8383      DIMENSION IHNAME(*)
8384      DIMENSION IHNAM2(*)
8385      DIMENSION IUSE(*)
8386      DIMENSION IN(*)
8387      DIMENSION IVALUE(*)
8388      DIMENSION VALUE(*)
8389      DIMENSION IANS(*)
8390C
8391C---------------------------------------------------------------------
8392C
8393      INCLUDE 'DPCOP2.INC'
8394C
8395C-----START POINT-----------------------------------------------------
8396C
8397      ISUBN1='DPMU'
8398      ISUBN2='LT  '
8399      IFOUND='NO'
8400      IERROR='NO'
8401C
8402      IF(IBUGP2.EQ.'ON')THEN
8403        WRITE(ICOUT,999)
8404  999   FORMAT(1X)
8405        CALL DPWRST('XXX','BUG ')
8406        WRITE(ICOUT,51)
8407   51   FORMAT('***** AT THE BEGINNING OF DPMULT--')
8408        CALL DPWRST('XXX','BUG ')
8409        WRITE(ICOUT,53)IBUGP2,IFOUND,IERROR,IERASW,IERASV,NUMARG
8410   53   FORMAT('IBUGP2,IFOUND,IERROR,IERASW,IERASV,NUMARG = ',
8411     1         5(A4,2X),I8)
8412        CALL DPWRST('XXX','BUG ')
8413        DO70I=1,NUMARG
8414          WRITE(ICOUT,71)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I)
8415   71     FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) = ',
8416     1           I8,3(2X,A4),2X,I8,G15.7)
8417          CALL DPWRST('XXX','BUG ')
8418   70   CONTINUE
8419        WRITE(ICOUT,81)IMPSW,IMPNR,IMPNC,IMPCO
8420   81   FORMAT('IMPSW,IMPNR,IMPNC,IMPCO = ',A4,3I8)
8421        CALL DPWRST('XXX','BUG ')
8422        WRITE(ICOUT,82)PMXMIN,PMXMAX,PMYMIN,PMYMAX
8423   82   FORMAT('PMXMIN,PMXMAX,PMYMIN,PMYMAX = ',4G15.7)
8424        CALL DPWRST('XXX','BUG ')
8425        WRITE(ICOUT,84)PWXMIN,PWXMAX,PWYMIN,PWYMAX
8426   84   FORMAT('PWXMIN,PWXMAX,PWYMIN,PWYMAX = ',4G15.7)
8427        CALL DPWRST('XXX','BUG ')
8428        WRITE(ICOUT,86)PWXMIS,PWXMAS,PWYMIS,PWYMAS
8429   86   FORMAT('PWXMIS,PWXMAS,PWYMIS,PWYMAS = ',4G15.7)
8430        CALL DPWRST('XXX','BUG ')
8431      ENDIF
8432C
8433C               *********************************************
8434C               **  TREAT THE    MULTIPLOT           CASE  **
8435C               *********************************************
8436C
8437C               *************************************************
8438C               **  STEP 1--                                   **
8439C               **  FOR ALL CASES, REGARDLESS OF WHETHER       **
8440C               **  MULTIPLOT IS BEING TURNED ON OR OFF,       **
8441C               **  REDEFINE PWXMIN ETC FROM THE SAVED VALUES  **
8442C               **  SO AS TO AVOID THE PROBLEM OF OVERWRITING  **
8443C               **  THE SAVED VALUES WHEN THE ANALYST          **
8444C               **  ENTERS MULTIPLE   MULTIPLOT ON'S           **
8445C               **  WITHOUT AN INTERMEDIATE   MULTIPLOT OFF  . **
8446C               **  THUS INITIALLY TREAT ALL CASES AS A        **
8447C               **  MULTIPLOT OFF   .                          **
8448C               *************************************************
8449C
8450CCCCC THE FOLLOWING LINE WAS COMMENTED OUT NOVEMBER 1991
8451CCCCC IMPSW='OFF'
8452C
8453CCCCC THE FOLLOWING LINE WAS COMMENTED OUT      SEPTEMBER 1993
8454CCCCC TO FIX PROBLEM OF MULTIPLOT AUTO-ERASE    SEPTEMBER 1993
8455CCCCC EVEN IF PRE-ERASE HAD BEEN SET TO OFF     SEPTEMBER 1993
8456CCCCC IERASW=IERASV
8457C
8458CCCCC THE FOLLOWING IF-CHECK WAS ADDED     SEPTEMBER 1995
8459      IF(NUMARG.GE.1)THEN
8460CCCCC THE FOLLOWING 2 LINES WERE ENTERED    SEPTEMBER 1993
8461         IF(IHARG(NUMARG).EQ.'FREE')GOTO1090
8462         IF(IHARG(NUMARG).EQ.'UNFR')GOTO1090
8463C
8464         PWXMIN=PWXMIS
8465         PWXMAX=PWXMAS
8466         PWYMIN=PWYMIS
8467         PWYMAX=PWYMAS
8468C
8469CCCCC THE FOLLOWING LINE WAS ENTERED    SEPTEMBER 1993
8470 1090    CONTINUE
8471      ENDIF
8472CCCCC ADD FOLLOWING LINE AUGUST 1999.
8473      IMPARG=1
8474C
8475C               *********************************************
8476C               **  STEP 2--                               **
8477C               **  BRANCH TO THE VARIOUS CASES            **
8478C               *********************************************
8479C
8480      IF(NUMARG.LE.0)GOTO1150
8481C
8482CCCCC ADD FOLLOWING LINE SEPTEMBER 1998.
8483      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'SCAL')THEN
8484CCCC    ADD FOLLOWING SECTION  SEPTEMBER 1998: MULTIPLOT SCALE FACTOR
8485        AMPSCH=1.0
8486        AMPSCW=1.0
8487        IF(IHARG(NUMARG).EQ.'SCAL' .OR. IHARG(NUMARG).EQ.'AUTO' .OR.
8488     1     IHARG(NUMARG).EQ.'DEFA' .OR. IHARG(NUMARG).EQ.'ON'   .OR.
8489     1     IHARG(NUMARG).EQ.'OFF')THEN
8490          AMPSCH=1.0
8491          AMPSCW=1.0
8492        ELSEIF(IARGT(NUMARG).EQ.'NUMB'.AND.
8493     1         IARGT(NUMARG-1).EQ.'NUMB')THEN
8494          AMPSCW=ARG(NUMARG)
8495          AMPSCH=ARG(NUMARG-1)
8496          IF(AMPSCW.LE.0.0 .OR. AMPSCW.GE.100.0)AMPSCW=1.0
8497          IF(AMPSCH.LE.0.0 .OR. AMPSCH.GE.100.0)AMPSCH=1.0
8498        ELSEIF(IARGT(NUMARG).EQ.'NUMB')THEN
8499          AMPSCF=ARG(NUMARG)
8500          IF(AMPSCF.LE.0.0 .OR. AMPSCF.GE.100.0)AMPSCF=1.0
8501          AMPSCH=AMPSCF
8502          AMPSCW=AMPSCF
8503        ELSE
8504          AMPSCH=1.0
8505          AMPSCW=1.0
8506        ENDIF
8507        IFOUND='YES'
8508        WRITE(ICOUT,999)
8509        CALL DPWRST('XXX','BUG ')
8510        WRITE(ICOUT,1211)AMPSCH
8511 1211   FORMAT('MULTIPLOT HEIGHT SCALE FACTOR SET TO ',G15.7)
8512        CALL DPWRST('XXX','BUG ')
8513        WRITE(ICOUT,1213)AMPSCW
8514 1213   FORMAT('MULTIPLOT WIDTH  SCALE FACTOR SET TO ',G15.7)
8515        CALL DPWRST('XXX','BUG ')
8516        GOTO9000
8517      ENDIF
8518C
8519      IF(IHARG(NUMARG).EQ.'ON' .OR. IHARG(NUMARG).EQ.'AUTO')GOTO1150
8520      IF(IHARG(NUMARG).EQ.'OFF' .OR. IHARG(NUMARG).EQ.'DEFA')THEN
8521CCCCC   THE FOLLOWING LINE WAS ADDED                  OCTOBER 1993
8522CCCCC   TO SOLVE THE MULTIPLOT OVERWRITING PROBLEM    OCTOBER 1993
8523        IF(IMPSW.EQ.'ON')IERASW=IERASV
8524        IMPSW='OFF'
8525        IMPCO9=1
8526CCCCC   THE FOLLOWING LINE WAS COMMENTED OUT          OCTOBER 1993
8527CCCCC   TO SOLVE THE MULTIPLOT OVERWRITING PROBLEM    OCTOBER 1993
8528CCCCC   IERASW=IERASV
8529        PWXMIN=PWXMIS
8530        PWXMAX=PWXMAS
8531        PWYMIN=PWYMIS
8532        PWYMAX=PWYMAS
8533        GOTO1180
8534      ELSEIF(IHARG(NUMARG).EQ.'FREE' .OR. IHARG(NUMARG).EQ.'HOLD')THEN
8535        IF(IMPSW.EQ.'ON')IMPSW='FREE'
8536        GOTO1180
8537      ELSEIF(IHARG(NUMARG).EQ.'UNFR' .OR. IHARG(NUMARG).EQ.'UNHO')THEN
8538        IF(IMPSW.EQ.'FREE')THEN
8539          IMPSW='ON'
8540          IMPCO=IMPCO+1
8541        ENDIF
8542        GOTO1180
8543      ELSE
8544CCCCC   THE FOLLOWING 2 LINES WERE ADDED              OCTOBER 1993
8545CCCCC   TO SOLVE THE MULTIPLOT OVERWRITING PROBLEM    OCTOBER 1993
8546        IF(IMPSW.EQ.'OFF')IERASV=IERASW
8547        IF(IMPSW.EQ.'ON')IERASW=IERASV
8548        IMPSW='ON'
8549        IMPCO=1
8550CCCCC   THE FOLLOWING LINE WAS COMMENTED OUT          OCTOBER 1993
8551CCCCC   TO SOLVE THE MULTIPLOT OVERWRITING PROBLEM    OCTOBER 1993
8552CCCCC   IERASV=IERASW
8553        PWXMIS=PWXMIN
8554        PWXMAS=PWXMAX
8555        PWYMIS=PWYMIN
8556        PWYMAS=PWYMAX
8557CCCCC   RETURN NUMBER OF ARGUMENTS (IMPARG)    AUGUST 1999
8558        DO1171J=1,NUMARG
8559          IF(IARGT(J).EQ.'NUMB')THEN
8560            IF(J.EQ.1)THEN
8561              IMPNR=IARG(J)
8562              IMPARG=1
8563            ELSEIF(J.EQ.2)THEN
8564              IMPNC=IARG(J)
8565              IMPARG=2
8566              IF(NUMARG.EQ.2)IMPCO9=1
8567CCCCC         IF(J.EQ.3)IMPCO=IARG(J)                     MARCH 1988
8568CCCCC         THE FOLLOWING 3 LINES WERE ADJUSTED/ENTERED MARCH 1988
8569            ELSEIF(J.EQ.3)THEN
8570              IF(NUMARG.EQ.3)THEN
8571                IMPCO=IARG(J)
8572              ELSE
8573                IHOLD3=IARG(J)
8574              ENDIF
8575              IMPARG=3
8576            ELSEIF(J.EQ.4)THEN
8577              IMPCO=(IHOLD3-1)*IMPNC+IARG(J)
8578              IMPARG=4
8579            ENDIF
8580          ELSE
8581            IHWORD=IHARG(J)
8582            IHWOR2=IHARG2(J)
8583            IHWUSE='P'
8584            MESSAG='YES'
8585            CALL CHECKN(IHWORD,IHWOR2,IHWUSE,
8586     1                  IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,
8587     1                  NUMNAM,MAXNAM,
8588     1                  ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR)
8589            IF(IERROR.EQ.'YES')GOTO9000
8590            IF(J.EQ.1)THEN
8591              IMPNR=INT(VALUE(ILOC)+0.5)
8592            ELSEIF(J.EQ.2)THEN
8593              IMPNC=INT(VALUE(ILOC)+0.5)
8594CCCCC         IF(J.EQ.3)IMPCO=VALUE(ILOC)+0.5             MARCH 1988
8595CCCCC         THE FOLLOWING 4 LINES WERE ADJUSTED/ENTERED MARCH 1988
8596            ELSEIF(J.EQ.3)THEN
8597              IF(NUMARG.EQ.3)THEN
8598                IMPCO=INT(VALUE(ILOC)+0.5)
8599              ELSE
8600                IHOLD3=INT(VALUE(ILOC)+0.5)
8601              ENDIF
8602            ELSEIF(J.EQ.4)THEN
8603              IHOLD4=INT(VALUE(ILOC)+0.5)
8604              IMPCO=(IHOLD3-1)*IMPNC+IHOLD4
8605            ENDIF
8606          ENDIF
8607 1171   CONTINUE
8608        GOTO1180
8609      ENDIF
8610C
8611 1150 CONTINUE
8612CCCCC THE FOLLOWING LINE WAS ADDED                  OCTOBER 1993
8613CCCCC TO SOLVE THE MULTIPLOT OVERWRITING PROBLEM    OCTOBER 1993
8614      IF(IMPSW.EQ.'OFF')IERASV=IERASW
8615      IMPSW='ON'
8616      IMPNR=2
8617      IMPNC=2
8618      IMPCO=1
8619      IMPCO9=IMPCO
8620CCCCC THE FOLLOWING LINE WAS COMMENTED OUT          OCTOBER 1993
8621CCCCC TO SOLVE THE MULTIPLOT OVERWRITING PROBLEM    OCTOBER 1993
8622CCCCC IERASV=IERASW
8623      PWXMIS=PWXMIN
8624      PWXMAS=PWXMAX
8625      PWYMIS=PWYMIN
8626      PWYMAS=PWYMAX
8627      GOTO1180
8628C
8629C
8630 1180 CONTINUE
8631      IFOUND='YES'
8632C
8633CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1993
8634      IF(IMPNR.LE.0.OR.IMPNC.LE.0)THEN
8635         WRITE(ICOUT,999)
8636         CALL DPWRST('XXX','BUG ')
8637         WRITE(ICOUT,2011)
8638 2011    FORMAT('***** ERROR IN MULTIPLOT--')
8639         CALL DPWRST('XXX','BUG ')
8640         WRITE(ICOUT,2012)
8641 2012    FORMAT('      NEGATIVE ARGUMENT ENCOUNTERED.')
8642         CALL DPWRST('XXX','BUG ')
8643         WRITE(ICOUT,2013)IMPNR
8644 2013    FORMAT('      ARGUMENT 1 = ',I8)
8645         CALL DPWRST('XXX','BUG ')
8646         WRITE(ICOUT,2014)IMPNC
8647 2014    FORMAT('      ARGUMENT 2 = ',I8)
8648         CALL DPWRST('XXX','BUG ')
8649         IERROR='YES'
8650         GOTO9000
8651      ENDIF
8652C
8653      IF(IFEEDB.EQ.'ON')THEN
8654        WRITE(ICOUT,999)
8655        CALL DPWRST('XXX','BUG ')
8656        WRITE(ICOUT,1181)
8657 1181   FORMAT('THE MULTIPLOT SWITCH HAS JUST BEEN SET ')
8658        CALL DPWRST('XXX','BUG ')
8659        IF(IMPSW.EQ.'OFF')THEN
8660          WRITE(ICOUT,1182)
8661 1182     FORMAT('TO   OFF')
8662          CALL DPWRST('XXX','BUG ')
8663        ELSEIF(IMPSW.EQ.'ON')THEN
8664          WRITE(ICOUT,1183)
8665 1183     FORMAT('TO   ON   WITH THE FOLLOWING SETTINGS--')
8666          CALL DPWRST('XXX','BUG ')
8667          WRITE(ICOUT,1184)IMPNR
8668 1184     FORMAT('      NUMBER OF ROWS    OF PLOTS = ',I8)
8669          CALL DPWRST('XXX','BUG ')
8670          WRITE(ICOUT,1185)IMPNC
8671 1185     FORMAT('      NUMBER OF COLUMNS OF PLOTS = ',I8)
8672          CALL DPWRST('XXX','BUG ')
8673          WRITE(ICOUT,1186)IMPCO
8674 1186     FORMAT('      NEXT PLOT TO BE GENERATED  = ',I8)
8675          CALL DPWRST('XXX','BUG ')
8676        ENDIF
8677      ENDIF
8678C
8679C               *****************
8680C               **  STEP 90--  **
8681C               **  EXIT       **
8682C               *****************
8683C
8684 9000 CONTINUE
8685      IF(IBUGP2.EQ.'ON')THEN
8686        WRITE(ICOUT,999)
8687        CALL DPWRST('XXX','BUG ')
8688        WRITE(ICOUT,9011)
8689 9011   FORMAT('***** AT THE END       OF DPMULT--')
8690        CALL DPWRST('XXX','BUG ')
8691        WRITE(ICOUT,9013)IBUGP2,IFOUND,IERROR,IERASW,IERASV
8692 9013   FORMAT('IBUGP2,IFOUND,IERROR,IERASW,IERASV = ',4(A4,2X),A4)
8693        CALL DPWRST('XXX','BUG ')
8694        WRITE(ICOUT,9041)IMPSW,IMPNR,IMPNC,IMPCO
8695 9041   FORMAT('IMPSW,IMPNR,IMPNC,IMPCO = ',A4,3I8)
8696        CALL DPWRST('XXX','BUG ')
8697        WRITE(ICOUT,9042)PMXMIN,PMXMAX,PMYMIN,PMYMAX
8698 9042   FORMAT('PMXMIN,PMXMAX,PMYMIN,PMYMAX = ',4G15.7)
8699        CALL DPWRST('XXX','BUG ')
8700        WRITE(ICOUT,9044)PWXMIN,PWXMAX,PWYMIN,PWYMAX
8701 9044   FORMAT('PWXMIN,PWXMAX,PWYMIN,PWYMAX = ',4G15.7)
8702        CALL DPWRST('XXX','BUG ')
8703        WRITE(ICOUT,9046)PWXMIS,PWXMAS,PWYMIS,PWYMAS
8704 9046   FORMAT('PWXMIS,PWXMAS,PWYMIS,PWYMAS = ',4G15.7)
8705        CALL DPWRST('XXX','BUG ')
8706      ENDIF
8707C
8708      RETURN
8709      END
8710      SUBROUTINE DPMXRL(IHARG,IARGT,IARG,NUMARG,IDEFRL,NUMRCM,MAXRCL,
8711     1IFOUND,IERROR)
8712C
8713C     PURPOSE--DEFINE THE MAXIMUM RECORD LENGTH FOR READING DATA FILES.
8714C              NOTE THAT THIS CURRENTLY ONLY SPECIFIES THE LENGTH OF
8715C              DATA LINE READ.  IT IS NOT CURRENTLY USED WHEN OPENING
8716C              THE FILE (ALTHOUGH THIS COULD BE ADDED AT A LATER DATE).
8717C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
8718C                     --IARGT  (A  HOLLERITH VECTOR)
8719C                     --IARG   (AN INTEGER VECTOR)
8720C                     --NUMARG
8721C                     --IDEFRL (AN INTEGER DEFINING THE DEFAULT MAXIMUM
8722C                              RECORD LENGTH)
8723C                     --MAXRCL (AN INTEGER DEFINING THE MAXIMUM VALUE THAT
8724C                              THE MAXIMUM RECORD LENGTH CAN BE SET TO)
8725C     OUTPUT ARGUMENTS--NUMRCM (AN INTEGER VARIABLE CONTAINING THE CURRENT
8726C                              SETTING FOR THE MAXIMUM RECORD LENGTH FOR
8727C                              DATA FILES)
8728C                     --IFOUND ('YES' OR 'NO' )
8729C                     --IERROR ('YES' OR 'NO' )
8730C     WRITTEN BY--JAMES J. FILLIBEN
8731C                 STATISTICAL ENGINEERING DIVISION
8732C                 INFORMATION TECHNOLOGY LABORATORY
8733C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
8734C                 GAITHERSBURG, MD 20899-8980
8735C                 PHONE--301-975-2855
8736C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
8737C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
8738C     LANGUAGE--ANSI FORTRAN (1977)
8739C     VERSION NUMBER--2003/2
8740C     ORIGINAL VERSION--FEBRUARY  2003.
8741C
8742C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
8743C
8744      CHARACTER*4 IHARG
8745      CHARACTER*4 IARGT
8746      CHARACTER*4 IFOUND
8747      CHARACTER*4 IERROR
8748C
8749C---------------------------------------------------------------------
8750C
8751      DIMENSION IHARG(*)
8752      DIMENSION IARGT(*)
8753      DIMENSION IARG(*)
8754C
8755C---------------------------------------------------------------------
8756C
8757      INCLUDE 'DPCOP2.INC'
8758C
8759C-----START POINT-----------------------------------------------------
8760C
8761      IFOUND='NO'
8762      IERROR='NO'
8763C
8764      IHOLD1=0
8765C
8766C               ****************************************************
8767C               **  TREAT THE CASE WHEN                           **
8768C               **  THE MAXIMUM RECORD LENGTH IS TO BE CHANGED    **
8769C               ****************************************************
8770C
8771      IF(NUMARG.LE.0)GOTO9000
8772      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'RECO'.AND.IHARG(2).EQ.'LENG')
8773     1GOTO1110
8774      GOTO9000
8775C
8776 1110 CONTINUE
8777      IF(NUMARG.EQ.2)GOTO1120
8778      IF(IHARG(NUMARG).EQ.'ON')GOTO1120
8779      IF(IHARG(NUMARG).EQ.'OFF')GOTO1120
8780      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1120
8781      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1120
8782      IF(IHARG(NUMARG).EQ.'?')GOTO8100
8783      IF(NUMARG.GE.3.AND.IARGT(3).EQ.'NUMB')GOTO1130
8784      GOTO9000
8785C
8786 1120 CONTINUE
8787      IHOLD1=IDEFRL
8788      GOTO1180
8789C
8790 1130 CONTINUE
8791      IHOLD1=IARG(3)
8792      GOTO1180
8793C
8794 1180 CONTINUE
8795      IFOUND='YES'
8796      NUMRCM=IHOLD1
8797C
8798C  CHECK AGAINST MAXIMUM RECORD LENGTH
8799C
8800      IF(NUMRCM.LT.132)NUMRCM=132
8801      IF(NUMRCM.GT.MAXRCL)NUMRCM=MAXRCL
8802C
8803      IF(IFEEDB.EQ.'OFF')GOTO1189
8804      WRITE(ICOUT,999)
8805  999 FORMAT(1X)
8806      CALL DPWRST('XXX','BUG ')
8807      WRITE(ICOUT,1185)
8808 1185 FORMAT('THE MAXIMUM RECORD LENGTH (FOR READ AND SERIAL READ)')
8809      CALL DPWRST('XXX','BUG ')
8810      WRITE(ICOUT,1186)NUMRCM
8811 1186 FORMAT('HAVE JUST BEEN SET TO ',I8)
8812      CALL DPWRST('XXX','BUG ')
8813 1189 CONTINUE
8814      GOTO9000
8815C
8816C               ********************************************
8817C               **  STEP 81--                             **
8818C               **  TREAT THE    ?    CASE--              **
8819C               **  DUMP OUT CURRENT AND DEFAULT VALUES.  **
8820C               ********************************************
8821C
8822 8100 CONTINUE
8823      IFOUND='YES'
8824      WRITE(ICOUT,999)
8825      CALL DPWRST('XXX','BUG ')
8826      WRITE(ICOUT,8111)NUMRCM
8827 8111 FORMAT('THE CURRENT MAXIMUM RECORD LENGTH IS ',I8)
8828      CALL DPWRST('XXX','BUG ')
8829      WRITE(ICOUT,8112)IDEFRL
8830 8112 FORMAT('THE DEFAULT MAXIMUM RECORD LENGTH IS ',I8,I8)
8831      CALL DPWRST('XXX','BUG ')
8832      GOTO9000
8833C
8834C               *****************
8835C               **  STEP 90--  **
8836C               **  EXIT       **
8837C               *****************
8838C
8839 9000 CONTINUE
8840      RETURN
8841      END
8842      SUBROUTINE DPNAME(IHARG,IHARG2,IARGT,IARG,ARG,NUMARG,
8843     1                  IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP,
8844     1                  IVALUE,VALUE,NUMNAM,MAXNAM,IVARLB,
8845     1                  NUMCOL,MAXCOL,MAXN,IANS,IWIDTH,
8846     1                  IBUGS2,IFOUND,IERROR)
8847C
8848C     PURPOSE--TREAT THE NAME/RENAME CASE--
8849C              NAMING OR RENAMING OF COLUMNS.
8850C              EXAMPLE--NAME 7 X
8851C                       RENAME 7 X
8852C                       RENAME PRESSURE Y
8853C     NOTE--THE RECOMMENDED VERB (FOR EASE OF REMEMBRANCE) IS RENAME.
8854C           THE SYNTAX IS    RENAME    EXISTING NAME     NEW NAME
8855C     WRITTEN BY--JAMES J. FILLIBEN
8856C                 STATISTICAL ENGINEERING DIVISION
8857C                 INFORMATION TECHNOLOGY LABORATORY
8858C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
8859C                 GAITHERSBURG, MD 20899-8980
8860C                 PHONE--301-975-2855
8861C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
8862C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
8863C     LANGUAGE--ANSI FORTRAN (1977)
8864C     VERSION NUMBER--82/7
8865C     ORIGINAL VERSION (IN DPLET)--DECEMBER 1977.
8866C     ORIGINAL VERSION AS A SEPARATE SUBROUTINE--MARCH 1978.
8867C     UPDATED         --JUNE      1978.
8868C     UPDATED         --NOVEMBER  1980.
8869C     UPDATED         --JANUARY   1981.
8870C     UPDATED         --NOVEMBER  1986.
8871C     UPDATED         --JANUARY   2000. UPDATE VARIABLE LABEL
8872C
8873C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
8874C
8875      CHARACTER*4 IHARG
8876      CHARACTER*4 IHARG2
8877      CHARACTER*4 IARGT
8878      CHARACTER*4 IHNAME
8879      CHARACTER*4 IHNAM2
8880      CHARACTER*4 IUSE
8881      CHARACTER*40 IVARLB
8882      CHARACTER*4 IANS
8883      CHARACTER*4 IBUGS2
8884      CHARACTER*4 IFOUND
8885      CHARACTER*4 IERROR
8886C
8887      CHARACTER*4 NEWNAM
8888      CHARACTER*4 NEWCOL
8889      CHARACTER*4 IRIGHT
8890      CHARACTER*4 IRIGH2
8891      CHARACTER*4 ILEFT
8892      CHARACTER*4 ILEFT2
8893      CHARACTER*4 ISUBN1
8894      CHARACTER*4 ISUBN2
8895      CHARACTER*4 ISTEPN
8896C
8897C---------------------------------------------------------------------
8898C
8899      DIMENSION IHARG(*)
8900      DIMENSION IHARG2(*)
8901      DIMENSION IARGT(*)
8902      DIMENSION IARG(*)
8903      DIMENSION ARG(*)
8904C
8905      DIMENSION IHNAME(*)
8906      DIMENSION IHNAM2(*)
8907      DIMENSION IUSE(*)
8908      DIMENSION IN(*)
8909      DIMENSION IVSTAR(*)
8910      DIMENSION IVSTOP(*)
8911      DIMENSION IVALUE(*)
8912      DIMENSION VALUE(*)
8913      DIMENSION IVARLB(*)
8914C
8915      DIMENSION IANS(*)
8916C
8917C---------------------------------------------------------------------
8918C
8919      INCLUDE 'DPCOP2.INC'
8920C
8921C-----START POINT-----------------------------------------------------
8922C
8923      ISUBN1='DPNA'
8924      ISUBN2='ME  '
8925      IFOUND='YES'
8926      IERROR='NO'
8927C
8928      IRIGHT='UNKN'
8929      IRIGH2='UNKN'
8930      ILEFT='UNKN'
8931      ILEFT2='UNKN'
8932      NEWNAM='NO'
8933      NEWCOL='NO'
8934C
8935      ICOLL=0
8936      ILISTR=0
8937      ILISTL=0
8938C
8939C               **********************************
8940C               **  TREAT THE NAME/RENAME CASE  **
8941C               **********************************
8942C
8943C               **********************************
8944C               **  STEP 1--                    **
8945C               **  INITIALIZE VARIABLES.      **
8946C               **********************************
8947C
8948      ISTEPN='1'
8949      IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8950C
8951C               *******************************************************
8952C               **  STEP 2--                                         **
8953C               **  CHECK THAT THERE ARE AT LEAST 2 ARGUMENTS.       **
8954C               **  WHEN HAVE MORE THAN 2 ARGUMENTS,                 **
8955C               **  THEN THE FIRST AND THE LAST ARGUMENTS            **
8956C               **  ARE THE ONES WHICH ARE EXAMINED,                 **
8957C               **  (WITH INTERMEDIATE INFORMATION IGNORED).         **
8958C               **  EXAMINE THE 2 ARGUMENTS                          **
8959C               **  AND CHECK TO SEE THAT EXACTLY ONE IS A WORD      **
8960C               **  AND EXACTLY ONE IS A NUMBER.                     **
8961C               *******************************************************
8962C
8963      ISTEPN='2'
8964      IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8965C
8966      MINNA=2
8967      MAXNA=100
8968      CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,
8969     1IERROR)
8970      IF(IERROR.EQ.'YES')GOTO9000
8971C
8972      DO2000IPASS=1,NUMARG,2
8973      IPASSP=IPASS+1
8974C
8975      IF(IARGT(IPASS).EQ.'WORD'.AND.IARGT(IPASSP).EQ.'NUMB')GOTO250
8976      IF(IARGT(IPASS).EQ.'NUMB'.AND.IARGT(IPASSP).EQ.'WORD')GOTO250
8977      IF(IARGT(IPASS).EQ.'WORD'.AND.IARGT(IPASSP).EQ.'WORD')GOTO1250
8978C
8979      WRITE(ICOUT,999)
8980  999 FORMAT(1X)
8981      CALL DPWRST('XXX','BUG ')
8982      WRITE(ICOUT,211)
8983  211 FORMAT('***** ERROR IN DPNAME--')
8984      CALL DPWRST('XXX','BUG ')
8985      WRITE(ICOUT,212)
8986  212 FORMAT('      AT LEAST ONE OF THE ARGUMENTS')
8987      CALL DPWRST('XXX','BUG ')
8988      WRITE(ICOUT,213)
8989  213 FORMAT('      IN THE NAME COMMAND MUST BE A VARIABLE NAME--')
8990      CALL DPWRST('XXX','BUG ')
8991      WRITE(ICOUT,214)
8992  214 FORMAT('      IT IS NOT PERMITTED TO HAVE NUMBERS')
8993      CALL DPWRST('XXX','BUG ')
8994      WRITE(ICOUT,215)
8995  215 FORMAT('      FOR BOTH ARGUMENTS.')
8996      CALL DPWRST('XXX','BUG ')
8997      WRITE(ICOUT,217)
8998  217 FORMAT('      AN ERROR CONDITION EXISTS HERE.')
8999      CALL DPWRST('XXX','BUG ')
9000      WRITE(ICOUT,218)IHARG(IPASS),IHARG2(IPASS),IARGT(IPASS)
9001  218 FORMAT('          FIRST  ARGUMENT = ',2A4,'--A  ',A4)
9002      CALL DPWRST('XXX','BUG ')
9003      WRITE(ICOUT,219)IHARG(2),IHARG2(2),IARGT(2)
9004  219 FORMAT('          SECOND ARGUMENT = ',2A4,'--A  ',A4)
9005      CALL DPWRST('XXX','BUG ')
9006      WRITE(ICOUT,220)
9007  220 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
9008      CALL DPWRST('XXX','BUG ')
9009      IF(IWIDTH.GE.1)WRITE(ICOUT,221)(IANS(I),I=1,IWIDTH)
9010  221 FORMAT(6X,80A1)
9011      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
9012      IERROR='YES'
9013      GOTO9000
9014C
9015  250 CONTINUE
9016      ILOCN=IPASS
9017      ILOCW=IPASSP
9018      IF(IARGT(IPASSP).EQ.'NUMB')ILOCN=IPASSP
9019      IF(IARGT(IPASS).EQ.'WORD')ILOCW=IPASS
9020C
9021      ILEFT=IHARG(ILOCN)
9022      ILEFT2=IHARG2(ILOCN)
9023      IRIGHT=IHARG(ILOCW)
9024      IRIGH2=IHARG2(ILOCW)
9025      ICOLL=IARG(ILOCN)
9026      AVAL=ARG(ILOCN)
9027C
9028C               ********************************************************
9029C               **  STEP 3--                                          **
9030C               **  EXAMINE THE NAME ARGUMENT--                       **
9031C               **  IS THE NAME                                       **
9032C               **  ALREADY IN THE NAME LIST?                         **
9033C               **  NOTE THAT     ILISTR    IS THE LINE IN THE TABLE  **
9034C               **  OF THE NAME.                                      **
9035C               ********************************************************
9036C
9037      ISTEPN='3'
9038      IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9039C
9040      IF(NUMNAM.LE.0)GOTO310
9041      DO300I=1,NUMNAM
9042      I2=I
9043      IF(IRIGHT.EQ.IHNAME(I).AND.IRIGH2.EQ.IHNAM2(I))GOTO380
9044  300 CONTINUE
9045  310 CONTINUE
9046      NEWNAM='YES'
9047      ILISTR=NUMNAM+1
9048      IF(ILISTR.GT.MAXNAM)GOTO320
9049      GOTO390
9050C
9051  320 CONTINUE
9052      WRITE(ICOUT,999)
9053      CALL DPWRST('XXX','BUG ')
9054      WRITE(ICOUT,321)
9055  321 FORMAT('***** ERROR IN DPNAME--')
9056      CALL DPWRST('XXX','BUG ')
9057      WRITE(ICOUT,322)
9058  322 FORMAT('      THE NUMBER OF VARIABLE/PARAMETER/FUNCTION')
9059      CALL DPWRST('XXX','BUG ')
9060      WRITE(ICOUT,323)ILISTR,MAXNAM
9061  323 FORMAT('      NAMES (= ',I8,') HAS JUST EXCEEDED THE ',
9062     1'ALLOWABLE ',I8)
9063      CALL DPWRST('XXX','BUG ')
9064      WRITE(ICOUT,324)
9065  324 FORMAT('      SUGGESTION--ENTER      STAT')
9066      CALL DPWRST('XXX','BUG ')
9067      WRITE(ICOUT,325)
9068  325 FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES,')
9069      CALL DPWRST('XXX','BUG ')
9070      WRITE(ICOUT,326)
9071  326 FORMAT('      AND THEN REDEFINE (REUSE) ONE OF THE')
9072      CALL DPWRST('XXX','BUG ')
9073      WRITE(ICOUT,327)
9074  327 FORMAT('      ALREADY-USED NAMES')
9075      CALL DPWRST('XXX','BUG ')
9076      IERROR='YES'
9077      GOTO9000
9078C
9079  380 CONTINUE
9080      ILISTR=I2
9081  390 CONTINUE
9082C
9083C               ****************************************************************
9084C               **  STEP 4--
9085C               **  EXAMINE THE NUMBER ARGUMENT--
9086C               **  IS IT A VALID COLUMN DESIGNATION (1 TO MAXCOL)?
9087C               **  IS IT AN OLD (PREVIOUSLY-USED) OR NEW COLUMN DESIGNATION?
9088C               **  NOTE THAT     ILISTL    IS THE LINE IN THE TABLE
9089C               **  OF THE NUMBER ARGUMENT.
9090C               **  NOTE THAT     ICOLL    IS THE DATA COLUMN (1 TO MAXCOL)
9091C               **  FOR THE NUMBER ARGUMENT.
9092C               ****************************************************************
9093C
9094      ISTEPN='4'
9095      IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9096C
9097      IF(ICOLL.LE.MAXCOL)GOTO419
9098      WRITE(ICOUT,999)
9099      CALL DPWRST('XXX','BUG ')
9100      WRITE(ICOUT,405)
9101  405 FORMAT('***** ERROR IN DPNAME--')
9102      CALL DPWRST('XXX','BUG ')
9103      WRITE(ICOUT,406)
9104  406 FORMAT('      THE COLUMN SPECIFICATION ON THE RIGHT')
9105      CALL DPWRST('XXX','BUG ')
9106      WRITE(ICOUT,407)MAXCOL
9107  407 FORMAT('      SIDE SHOULD BE BETWEEN 1 AND ',I8,
9108     1' (INCLUSIVE)')
9109      CALL DPWRST('XXX','BUG ')
9110      WRITE(ICOUT,408)
9111  408 FORMAT('      BUT WAS NOT.')
9112      CALL DPWRST('XXX','BUG ')
9113      WRITE(ICOUT,409)ICOLL
9114  409 FORMAT('      THE REFERENCED COLUMN WAS ',I8)
9115      CALL DPWRST('XXX','BUG ')
9116      WRITE(ICOUT,411)
9117  411 FORMAT('      THE COMMAND LINE WAS AS FOLLOWS--')
9118      CALL DPWRST('XXX','BUG ')
9119      WRITE(ICOUT,412)(IANS(I),I=1,IWIDTH)
9120  412 FORMAT(6X,80A1)
9121      CALL DPWRST('XXX','BUG ')
9122      IERROR='YES'
9123      GOTO9000
9124  419 CONTINUE
9125C
9126      IF(NUMNAM.LE.0)GOTO432
9127      DO430I=1,NUMNAM
9128      I2=I
9129CCCCC IF(IN(I).EQ.ICOLL.AND.IUSE(I).EQ.'V')GOTO434
9130      IF(IVALUE(I).EQ.ICOLL.AND.IUSE(I).EQ.'V')GOTO434
9131  430 CONTINUE
9132  432 CONTINUE
9133      NEWCOL='YES'
9134      ILISTL=NUMNAM+1
9135      GOTO439
9136  434 CONTINUE
9137      NEWCOL='NO'
9138      ILISTL=I2
9139      GOTO439
9140  439 CONTINUE
9141C
9142      IF(ILISTL.LE.MAXNAM)GOTO459
9143      WRITE(ICOUT,999)
9144      CALL DPWRST('XXX','BUG ')
9145      WRITE(ICOUT,451)
9146  451 FORMAT('***** ERROR IN DPNAME--')
9147      CALL DPWRST('XXX','BUG ')
9148      WRITE(ICOUT,452)
9149  452 FORMAT('      THE NUMBER OF VARIABLE/PARAMETER/FUNCTION')
9150      CALL DPWRST('XXX','BUG ')
9151      WRITE(ICOUT,453)ILISTR,MAXNAM
9152  453 FORMAT('      NAMES (= ',I8,') HAS JUST EXCEEDED THE ',
9153     1'ALLOWABLE ',I8)
9154      CALL DPWRST('XXX','BUG ')
9155      WRITE(ICOUT,454)
9156  454 FORMAT('      SUGGESTION--ENTER      STAT')
9157      CALL DPWRST('XXX','BUG ')
9158      WRITE(ICOUT,455)
9159  455 FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES,')
9160      CALL DPWRST('XXX','BUG ')
9161      WRITE(ICOUT,456)
9162  456 FORMAT('      AND THEN REDEFINE (REUSE) ONE OF THE')
9163      CALL DPWRST('XXX','BUG ')
9164      WRITE(ICOUT,457)
9165  457 FORMAT('      ALREADY-USED NAMES')
9166      CALL DPWRST('XXX','BUG ')
9167      IERROR='YES'
9168      GOTO9000
9169  459 CONTINUE
9170C
9171C               *************************************************
9172C               **  STEP 5--                                   **
9173C               **  MAKE THE ADJUSTMENTS TO THE INTERNAL LIST  **
9174C               **  ON THE BASIS OF THE LEFT SIDE              **
9175C               **  AND RIGHT SIDE INFORMATION.                **
9176C               *************************************************
9177C
9178      ISTEPN='5'
9179      IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9180C
9181      IHNAME(ILISTR)=IRIGHT
9182      IHNAM2(ILISTR)=IRIGH2
9183      IF(ILISTL.EQ.ILISTR)GOTO511
9184      GOTO512
9185  511 CONTINUE
9186      IUSE(ILISTR)='V'
9187      IVALUE(ILISTR)=ILISTR
9188      VALUE(ILISTR)=ILISTR
9189      GOTO519
9190  512 CONTINUE
9191      IUSE(ILISTR)=IUSE(ILISTL)
9192      IVALUE(ILISTR)=IVALUE(ILISTL)
9193      VALUE(ILISTR)=VALUE(ILISTL)
9194      IN(ILISTR)=IN(ILISTL)
9195      IVARLB(ILISTR)=IVARLB(ILISTL)
9196      GOTO519
9197  519 CONTINUE
9198      IVSTAR(ILISTR)=MAXN*(ICOLL-1)+1
9199      IVSTOP(ILISTR)=MAXN*ICOLL-1
9200      IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1
9201      IF(NEWCOL.EQ.'YES'.AND.ICOLL.GT.NUMCOL)NUMCOL=ICOLL
9202C
9203C               **********************************************
9204C               **  STEP 6--                                **
9205C               **  PRINT OUT A BRIEF MESSAGE               **
9206C               **  INDICATING THAT THE NAME EQUIVALENCING  **
9207C               **  HAS BEEN CARRIED OUT.                   **
9208C               **********************************************
9209C
9210      ISTEPN='6'
9211      IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9212C
9213      IF(IFEEDB.EQ.'OFF')GOTO619
9214      IF(IPASS.EQ.1)WRITE(ICOUT,999)
9215      IF(IPASS.EQ.1)CALL DPWRST('XXX','BUG ')
9216      WRITE(ICOUT,611)ICOLL,IRIGHT,IRIGH2
9217  611 FORMAT('COLUMN ',I8,' HAS JUST BEEN RENAMED ',2A4)
9218      CALL DPWRST('XXX','BUG ')
9219  619 CONTINUE
9220      GOTO2000
9221C
9222C               ********************************************************
9223C               **  STEP 13--                                        **
9224C               **  EXAMINE THE FIRST ARGUMENT--                      **
9225C               **  IS THE NAME                                       **
9226C               **  ALREADY IN THE NAME LIST?                         **
9227C               **  NOTE THAT     ILISTL    IS THE LINE IN THE TABLE  **
9228C               **  OF THE NAME.                                      **
9229C               ********************************************************
9230C
9231 1250 CONTINUE
9232      ISTEPN='13'
9233      IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9234C
9235      ILEFT=IHARG(IPASS)
9236      ILEFT2=IHARG2(IPASS)
9237      IRIGHT=IHARG(IPASSP)
9238      IRIGH2=IHARG2(IPASSP)
9239C
9240      IF(NUMNAM.LE.0)GOTO1310
9241      DO1300I=1,NUMNAM
9242      I2=I
9243      IF(ILEFT.EQ.IHNAME(I).AND.ILEFT2.EQ.IHNAM2(I))GOTO1380
9244 1300 CONTINUE
9245C
9246 1310 CONTINUE
9247      WRITE(ICOUT,999)
9248      CALL DPWRST('XXX','BUG ')
9249      WRITE(ICOUT,1311)
9250 1311 FORMAT('***** ERROR IN DPNAME--')
9251      CALL DPWRST('XXX','BUG ')
9252      WRITE(ICOUT,1312)
9253 1312 FORMAT('      WHEN USING THE RENAME COMMAND')
9254      CALL DPWRST('XXX','BUG ')
9255      WRITE(ICOUT,1313)
9256 1313 FORMAT('      WITH BOTH ARGUMENTS BEING NAMES,')
9257      CALL DPWRST('XXX','BUG ')
9258      WRITE(ICOUT,1314)
9259 1314 FORMAT('      THE FIRST ARGUMENT MUST BE A NAME')
9260      CALL DPWRST('XXX','BUG ')
9261      WRITE(ICOUT,1315)
9262 1315 FORMAT('      OF A PRE-EXISTING VARIABLE/PARAMETER/FUNCTION.')
9263      CALL DPWRST('XXX','BUG ')
9264      WRITE(ICOUT,1316)
9265 1316 FORMAT('      SUCH WAS NOT THE CASE HERE.')
9266      CALL DPWRST('XXX','BUG ')
9267      WRITE(ICOUT,1317)ILEFT,ILEFT2
9268 1317 FORMAT('THE ARGUMENT NAME IS ',A4,A4)
9269      CALL DPWRST('XXX','BUG ')
9270      IERROR='YES'
9271      GOTO9000
9272C
9273 1380 CONTINUE
9274      ILISTL=I2
9275C
9276C               ****************************************************************
9277C               **  STEP 14--
9278C               **  EXAMINE THE SECOND ARGUMENT--
9279C               **  IS THE NAME                                       **
9280C               **  ALREADY IN THE NAME LIST?                         **
9281C               **  NOTE THAT     ILISTR    IS THE LINE IN THE TABLE  **
9282C               **  OF THE NAME.                                      **
9283C               ****************************************************************
9284C
9285      ISTEPN='14'
9286      IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9287C
9288      NEWNAM='NO'
9289      IF(NUMNAM.LE.0)GOTO1410
9290      DO1400I=1,NUMNAM
9291      I2=I
9292      IF(IRIGHT.EQ.IHNAME(I).AND.IRIGH2.EQ.IHNAM2(I))GOTO1480
9293 1400 CONTINUE
9294C
9295 1410 CONTINUE
9296      NEWNAM='YES'
9297      ILISTR=NUMNAM+1
9298      IF(ILISTR.GT.MAXNAM)GOTO1420
9299      GOTO1490
9300C
9301 1420 CONTINUE
9302      WRITE(ICOUT,999)
9303      CALL DPWRST('XXX','BUG ')
9304      WRITE(ICOUT,1421)
9305 1421 FORMAT('***** ERROR IN DPNAME--')
9306      CALL DPWRST('XXX','BUG ')
9307      WRITE(ICOUT,1422)
9308 1422 FORMAT('      THE NUMBER OF VARIABLE/PARAMETER/FUNCTION')
9309      CALL DPWRST('XXX','BUG ')
9310      WRITE(ICOUT,1423)ILISTR,MAXNAM
9311 1423 FORMAT('      NAMES (= ',I8,') HAS JUST EXCEEDED THE ',
9312     1'ALLOWABLE ',I8)
9313      CALL DPWRST('XXX','BUG ')
9314      WRITE(ICOUT,1424)
9315 1424 FORMAT('      SUGGESTION--ENTER      STAT')
9316      CALL DPWRST('XXX','BUG ')
9317      WRITE(ICOUT,1425)
9318 1425 FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES,')
9319      CALL DPWRST('XXX','BUG ')
9320      WRITE(ICOUT,1426)
9321 1426 FORMAT('      AND THEN REDEFINE (REUSE) ONE OF THE')
9322      CALL DPWRST('XXX','BUG ')
9323      WRITE(ICOUT,1427)
9324 1427 FORMAT('      ALREADY-USED NAMES')
9325      CALL DPWRST('XXX','BUG ')
9326      IERROR='YES'
9327      GOTO9000
9328C
9329 1480 CONTINUE
9330      ILISTR=I2
9331 1490 CONTINUE
9332C
9333C               *************************************************
9334C               **  STEP 15--                                  **
9335C               **  MAKE THE ADJUSTMENTS TO THE INTERNAL LIST  **
9336C               **  ON THE BASIS OF THE LEFT SIDE              **
9337C               **  AND RIGHT SIDE INFORMATION.                **
9338C               *************************************************
9339C
9340      ISTEPN='15'
9341      IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9342C
9343      IHNAME(ILISTR)=IRIGHT
9344      IHNAM2(ILISTR)=IRIGH2
9345      IUSE(ILISTR)=IUSE(ILISTL)
9346      IVALUE(ILISTR)=IVALUE(ILISTL)
9347      VALUE(ILISTR)=VALUE(ILISTL)
9348      IN(ILISTR)=IN(ILISTL)
9349      IVSTAR(ILISTR)=IVSTAR(ILISTL)
9350      IVSTOP(ILISTR)=IVSTOP(ILISTL)
9351      IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1
9352C
9353C               **********************************************
9354C               **  STEP 16--                               **
9355C               **  PRINT OUT A BRIEF MESSAGE               **
9356C               **  INDICATING THAT THE NAME EQUIVALENCING  **
9357C               **  HAS BEEN CARRIED OUT.                   **
9358C               **********************************************
9359C
9360      ISTEPN='16'
9361      IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9362C
9363      IF(IFEEDB.EQ.'ON')THEN
9364        IF(IPASS.EQ.1)THEN
9365          WRITE(ICOUT,999)
9366          CALL DPWRST('XXX','BUG ')
9367        ENDIF
9368        WRITE(ICOUT,1611)ILEFT,ILEFT2,IRIGHT,IRIGH2
9369 1611   FORMAT('NAME ',2A4,' HAS JUST BEEN RENAMED ',2A4,'   .')
9370        CALL DPWRST('XXX','BUG ')
9371        WRITE(ICOUT,1612)
9372 1612   FORMAT('NOTE THAT THE ORIGINAL NAME IS NOT DESTROYED;')
9373        CALL DPWRST('XXX','BUG ')
9374        WRITE(ICOUT,1613)
9375 1613   FORMAT('THUS EITHER NAME MAY BE USED TO REFER')
9376        CALL DPWRST('XXX','BUG ')
9377        WRITE(ICOUT,1614)
9378 1614   FORMAT('TO THE ORIGINAL VARIABLE/PARAMETER/FUNCTION.')
9379        CALL DPWRST('XXX','BUG ')
9380      ENDIF
9381C
9382 2000 CONTINUE
9383C
9384C               *****************
9385C               **  STEP 90--  **
9386C               **  EXIT.      **
9387C               *****************
9388C
9389 9000 CONTINUE
9390C
9391      IF(IBUGS2.EQ.'ON')THEN
9392        WRITE(ICOUT,999)
9393        CALL DPWRST('XXX','BUG ')
9394        WRITE(ICOUT,9011)
9395 9011   FORMAT('***** AT THE END       OF DPNAME--')
9396        CALL DPWRST('XXX','BUG ')
9397        WRITE(ICOUT,9012)ILEFT,ILEFT2,IRIGHT,IRIGH2
9398 9012   FORMAT('ILEFT,ILEFT2,IHRIGHT,IHRIG2 = ',3(A4,2X),A4)
9399        CALL DPWRST('XXX','BUG ')
9400        WRITE(ICOUT,9016)NEWCOL,ICOLL,ILISTR,ILISTL,AVAL
9401 9016   FORMAT('NEWCOL,ICOLL,ILISTR,ILISTL,AVAL = ',4I8,G15.7)
9402        CALL DPWRST('XXX','BUG ')
9403        WRITE(ICOUT,9021)ILISTL,ILISTR,NUMNAM,NEWNAM
9404 9021   FORMAT('NUMNAM,NEWNAM,ILISTL,ILISTR = ',3I8,2X,A4)
9405        CALL DPWRST('XXX','BUG ')
9406        DO9025I=1,NUMNAM
9407          WRITE(ICOUT,9026)I,IHNAME(I),IHNAM2(I)
9408 9026     FORMAT('I,IHNAME(I),IHNAM2(I) = ',I8,2(2X,A4))
9409          CALL DPWRST('XXX','BUG ')
9410 9025   CONTINUE
9411        WRITE(ICOUT,999)
9412        CALL DPWRST('XXX','BUG ')
9413        DO9030I=1,NUMNAM
9414          WRITE(ICOUT,9031)I,IUSE(I),IVALUE(I),IN(I)
9415 9031     FORMAT('I,IUSE(I),IVALUE(I),IN(I) = ',I8,2X,A4,2I8)
9416          CALL DPWRST('XXX','BUG ')
9417 9030   CONTINUE
9418      ENDIF
9419C
9420      RETURN
9421      END
9422      SUBROUTINE DPNAN2(X1,Y1,X2,Y2,PX,PY,
9423     1                  IFIG,ILINPA,ILINCO,PLINTH,
9424     1                  AREGBA,IREBLI,IREBCO,PREBTH,
9425     1                  IREFSW,IREFCO,
9426     1                  IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
9427     1                  PTEXHE,PTEXWI,PTEXVG,PTEXHG)
9428C
9429C     PURPOSE--DRAW A LOGICAL NAND (= A NAND BOX) WITH THE MIDDLE OF
9430C              THE FLATTER SIDE AT THE POINT (X1,Y1), AND WITH THE
9431C              MIDDLE OF THE POINTED SIDE AT THE POINT (X2,Y2).
9432C     NOTE--THE HEIGHT OF THE BOX WILL BE EQUAL TO THE ABOVE-DESCRIBED
9433C           WIDTH OF THE BOX (THAT IS, THE HEIGHT OF THE BOX WILL BE
9434C           EQUAL TO THE WIDTH FROM (X1,Y1) TO (X2,Y2).
9435C     WRITTEN BY--JAMES J. FILLIBEN
9436C                 STATISTICAL ENGINEERING DIVISION
9437C                 INFORMATION TECHNOLOGY LABORATORY
9438C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
9439C                 GAITHERSBURG, MD 20899-8980
9440C                 PHONE--301-975-2855
9441C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
9442C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
9443C     LANGUAGE--ANSI FORTRAN (1977)
9444C     VERSION NUMBER--82/7
9445C     ORIGINAL VERSION--APRIL     1981.
9446C     UPDATED         --MAY       1982.
9447C     UPDATED         --JANUARY   1989. MODIFY CALLS TO DPDRPL (ALAN)
9448C     UPDATED         --JANUARY   1989. MODIFY CALL  TO DPFIRE (ALAN)
9449C     UPDATED         --JULY      2019. CREATE SCRATCH STORAGE IN DPNAND
9450C                                       RATHER THAN DPNAN2
9451C
9452C-----NON-COMMON VARIABLES-------------------------------------
9453C
9454      DIMENSION PX(*)
9455      DIMENSION PY(*)
9456C
9457      CHARACTER*4 IFIG
9458      CHARACTER*4 IPATT2
9459C
9460      CHARACTER*4 ILINPA
9461      CHARACTER*4 ILINCO
9462C
9463      CHARACTER*4 IREBLI
9464      CHARACTER*4 IREBCO
9465      CHARACTER*4 IREFSW
9466      CHARACTER*4 IREFCO
9467      CHARACTER*4 IREPTY
9468      CHARACTER*4 IREPLI
9469      CHARACTER*4 IREPCO
9470C
9471      CHARACTER*4 IPATT
9472      CHARACTER*4 ICOLF
9473      CHARACTER*4 ICOLP
9474      CHARACTER*4 ICOL
9475      CHARACTER*4 IFLAG
9476C
9477      DIMENSION ILINPA(*)
9478      DIMENSION ILINCO(*)
9479      DIMENSION PLINTH(*)
9480C
9481      DIMENSION AREGBA(*)
9482      DIMENSION IREBLI(*)
9483      DIMENSION IREBCO(*)
9484      DIMENSION PREBTH(*)
9485      DIMENSION IREFSW(*)
9486      DIMENSION IREFCO(*)
9487      DIMENSION IREPTY(*)
9488      DIMENSION IREPLI(*)
9489      DIMENSION IREPCO(*)
9490      DIMENSION PREPTH(*)
9491      DIMENSION PREPSP(*)
9492C
9493C-----COMMON----------------------------------------------------------
9494C
9495      INCLUDE 'DPCOGR.INC'
9496      INCLUDE 'DPCOBE.INC'
9497      INCLUDE 'DPCOP2.INC'
9498C
9499C-----START POINT-----------------------------------------------------
9500C
9501      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'NAN2')THEN
9502        WRITE(ICOUT,999)
9503  999   FORMAT(1X)
9504        CALL DPWRST('XXX','BUG ')
9505        WRITE(ICOUT,51)
9506   51   FORMAT('***** AT THE BEGINNING OF DPNAN2--')
9507        CALL DPWRST('XXX','BUG ')
9508        WRITE(ICOUT,53)X1,Y1,X2,Y2
9509   53   FORMAT('X1,Y1,X2,Y2 = ',4G15.7)
9510        CALL DPWRST('XXX','BUG ')
9511        WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1)
9512   61   FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',A4,2X,A4,G15.7)
9513        CALL DPWRST('XXX','BUG ')
9514        WRITE(ICOUT,62)IFIG,AREGBA(1)
9515   62   FORMAT('IFIG,AREGBA(1) = ',A4,2X,G15.7)
9516        CALL DPWRST('XXX','BUG ')
9517        WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1)
9518   63   FORMAT('IREBLI(1),IREBCO(1),PREBTH(1) = ',2(A4,2X),G15.7)
9519        CALL DPWRST('XXX','BUG ')
9520        WRITE(ICOUT,64)IREFSW(1),IREFCO(1)
9521   64   FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4)
9522        CALL DPWRST('XXX','BUG ')
9523        WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1)
9524   65   FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ',
9525     1         3(A4,2X),2G15.7)
9526        CALL DPWRST('XXX','BUG ')
9527        WRITE(ICOUT,69)PTEXHE,PTEXWI,PTEXVG,PTEXHG
9528   69   FORMAT('PTEXHE,PTEXWI,PTEXVG,PTEXHG = ',4G15.7)
9529        CALL DPWRST('XXX','BUG ')
9530        WRITE(ICOUT,79)IBUGG4,ISUBG4,IERRG4
9531   79   FORMAT('IBUGG4,ISUBG4,IERRG4 = ',2(A4,2X),A4)
9532        CALL DPWRST('XXX','BUG ')
9533      ENDIF
9534C
9535C               *********************************
9536C               **  STEP 1--                   **
9537C               **  DETERMINE THE COORDINATES  **
9538C               **  FOR THE LOGICAL NAND       **
9539C               *********************************
9540C
9541C
9542      POWER=1.4
9543      FACTOR=0.2
9544C
9545      DELX=X2-X1
9546      DELY=Y2-Y1
9547      ALEN=0.0
9548      TERM=(X2-X1)**2+(Y2-Y1)**2
9549      IF(TERM.GT.0.0)ALEN=SQRT(TERM)
9550      R=ALEN/2.0
9551      IF(ABS(DELX).GE.0.00001)THETA=ATAN(DELY/DELX)
9552      IF(ABS(DELX).LT.0.00001.AND.DELY.GE.0.0)THETA=3.1415926/2.0
9553      IF(ABS(DELX).LT.0.00001.AND.DELY.LT.0.0)THETA=-3.1415926/2.0
9554C
9555      K=0
9556C
9557      X=R
9558      Y=-R
9559      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
9560      K=K+1
9561      PX(K)=XP
9562      PY(K)=YP
9563C
9564      DO5310I=271,451,10
9565      PHI2=I-1
9566      PHI2=PHI2*(2.0*3.1415926)/360.0
9567      ABSCOS=ABS(COS(PHI2))
9568      ABSSIN=ABS(SIN(PHI2))
9569      X=R*(ABSCOS**POWER)
9570      Y=R*(ABSSIN**POWER)
9571      IF(SIN(PHI2).LT.0.0)Y=-Y
9572      X=X+R
9573      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
9574      K=K+1
9575      PX(K)=XP
9576      PY(K)=YP
9577 5310 CONTINUE
9578C
9579      X=0
9580      Y=R
9581      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
9582      K=K+1
9583      PX(K)=XP
9584      PY(K)=YP
9585C
9586      DO5320I=271,451,10
9587      PHI2=I-1
9588      PHI2=360.0-PHI2
9589      PHI2=PHI2*(2.0*3.1415926)/360.0
9590      X=FACTOR*R*COS(PHI2)
9591      Y=R*SIN(PHI2)
9592      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
9593      K=K+1
9594      PX(K)=XP
9595      PY(K)=YP
9596 5320 CONTINUE
9597C
9598      X=R
9599      Y=-R
9600      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
9601      K=K+1
9602      PX(K)=XP
9603      PY(K)=YP
9604C
9605      NP=K
9606C
9607C               ***********************
9608C               **  STEP 2--         **
9609C               **  FILL THE FIGURE  **
9610C               **  (IF CALLED FOR)  **
9611C               ***********************
9612C
9613      IF(IREFSW(1).EQ.'OFF')GOTO2190
9614      IPATT=IREPTY(1)
9615      IPATT2='SOLI'
9616      PTHICK=PREPTH(1)
9617      PXGAP=PREPSP(1)
9618      PYGAP=PREPSP(1)
9619      ICOLF=IREFCO(1)
9620      ICOLP=IREPCO(1)
9621      CALL DPFIRE(PX,PY,NP,
9622     1            IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,IPATT2)
9623 2190 CONTINUE
9624C
9625      IPATT=ILINPA(1)
9626      PTHICK=PLINTH(1)
9627      ICOL=ILINCO(1)
9628      IFLAG='ON'
9629      CALL DPDRPL(PX,PY,NP,
9630     1            IFIG,IPATT,PTHICK,ICOL,
9631     1            JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
9632C
9633      K=0
9634C
9635      X=-0.2*R
9636      Y=R
9637      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
9638      K=K+1
9639      PX(K)=XP
9640      PY(K)=YP
9641C
9642      DO5330I=271,451,10
9643      PHI2=I-1
9644      PHI2=360.0-PHI2
9645      PHI2=PHI2*(2.0*3.1415926)/360.0
9646      X=FACTOR*R*COS(PHI2)
9647      Y=R*SIN(PHI2)
9648      X=X-0.2*R
9649      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
9650      K=K+1
9651      PX(K)=XP
9652      PY(K)=YP
9653 5330 CONTINUE
9654C
9655      NP=K
9656C
9657      IPATT2='SOLI'
9658      IF(IREFSW(1).EQ.'ON')
9659     1CALL DPFIRE(PX,PY,NP,
9660     1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,IPATT2)
9661C
9662      IFLAG='ON'
9663      CALL DPDRPL(PX,PY,NP,
9664     1            IFIG,IPATT,PTHICK,ICOL,
9665     1            JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
9666C
9667C               *****************
9668C               **  STEP 90--  **
9669C               **  EXIT       **
9670C               *****************
9671C
9672      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'NAN2')THEN
9673        WRITE(ICOUT,999)
9674        CALL DPWRST('XXX','BUG ')
9675        WRITE(ICOUT,9011)
9676 9011   FORMAT('***** AT THE END       OF DPNAN2--')
9677        CALL DPWRST('XXX','BUG ')
9678        WRITE(ICOUT,9014)NP,IERRG4
9679 9014   FORMAT('NP,IERRG4 = ',I8,2X,A4)
9680        CALL DPWRST('XXX','BUG ')
9681        DO9015I=1,NP
9682          WRITE(ICOUT,9016)I,PX(I),PY(I)
9683 9016     FORMAT('I,PX(I),PY(I) = ',I8,2G15.7)
9684          CALL DPWRST('XXX','BUG ')
9685 9015   CONTINUE
9686      ENDIF
9687C
9688      RETURN
9689      END
9690      SUBROUTINE DPNAND(IHARG,IARGT,ARG,NUMARG,
9691     1                  PXSTAR,PYSTAR,PXEND,PYEND,
9692     1                  ILINPA,ILINCO,PLINTH,
9693     1                  AREGBA,IREBLI,IREBCO,PREBTH,
9694     1                  IREFSW,IREFCO,
9695     1                  IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
9696     1                  PTEXHE,PTEXWI,PTEXVG,PTEXHG,
9697     1                  IGRASW,IDIASW,
9698     1                  PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
9699     1                  PDIAHE,PDIAWI,PDIAVG,PDIAHG,
9700     1                  NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
9701     1                  IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
9702     1                  IDNVOF,IDNHOF,IDFONT,UNITSW,PDSCAL,
9703     1                  IBUGD2,IFOUND,IERROR)
9704C
9705C     PURPOSE--DRAW ONE OR MORE LOGICAL NANDS (DEPENDING ON HOW MANY
9706C              NUMBERS ARE PROVIDED).  THE COORDINATES ARE IN
9707C              STANDARDIZED UNITS OF 0 TO 100.
9708C     NOTE--THE INPUT COORDINATES DEFINE THE BACK CENTER AND THE FRONT
9709C           CENTER OF THE LOGICAL NAND.
9710C     NOTE-THE USUAL INPUT NUMBER OF COORDINATES IS 2
9711C          AND THEREFORE THE USUAL INPUT NUMBER OF NUMBERS IS 2*2 = 4.
9712C     NOTE--IF 2 NUMBERS ARE PROVIDED, THEN THE DRAWN LOGICAL NAND WILL
9713C           GO FROM THE LAST CURSOR POSITION TO THE (X,Y) POINT (EITHER
9714C           ABSOLUTE OR RELATIVE) AS DEFINED BY THE 2 NUMBERS.
9715C     NOTE--IF 4 NUMBERS ARE PROVIDED, THEN THE DRAWN LOGICAL NAND WILL
9716C           GO FROM THE ABSOLUTE (X,Y) POSITION AS DEFINED BY THE FIRST
9717C           2 NUMBERS TO THE (X,Y) POINT (EITHER ABSOLUTE OR RELATIVE)
9718C           AS DEFINED BY THE THIRD AND FOURTH NUMBERS.
9719C     NOTE--IF 6 NUMBERS ARE PROVIDED, THEN THE DRAWN LOGICAL NAND WILL
9720C           GO FROM THE (X,Y) POSITION AS RESULTING FROM THE THIRD AND
9721C           FOURTH NUMBERS TO THE (X,Y) POINT (EITHER ABSOLUTE OR
9722C           RELATIVE) AS DEFINED BY THE FIFTH AND SIXTH NUMBERS.
9723C     NOTE--AND SO FORTH FOR 8, 10, 12, ... NUMBERS.
9724C     INPUT  ARGUMENTS--IHARG
9725C                     --IARGT
9726C                     --ARG
9727C                     --NUMARG
9728C                     --PXSTAR
9729C                     --PYSTAR
9730C     OUTPUT ARGUMENTS--PXEND
9731C                     --PYEND
9732C                     --IFOUND ('YES' OR 'NO' )
9733C                     --IERROR ('YES' OR 'NO' )
9734C     WRITTEN BY--JAMES J. FILLIBEN
9735C                 STATISTICAL ENGINEERING DIVISION
9736C                 INFORMATION TECHNOLOGY LABORATORY
9737C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
9738C                 GAITHERSBURG, MD 20899-8980
9739C                 PHONE--301-975-2855
9740C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
9741C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
9742C     LANGUAGE--ANSI FORTRAN (1977)
9743C     VERSION NUMBER--82/7
9744C     ORIGINAL VERSION--APRIL     1981.
9745C     UPDATED         --MARCH     1982.
9746C     UPDATED         --MAY       1982.
9747C     UPDATED         --NOVEMBER  1982.
9748C     UPDATED         --JANUARY   1989. CALL LIST FOR OFFSET VAR (ALAN)
9749C     UPDATED         --MARCH     1997. SUPPORT FOR DEVICE FONT (ALAN)
9750C     UPDATED         --JULY      1997. SUPPORT FOR "DATA" UNITS (ALAN)
9751C     UPDATED         --DECEMBER  2018. CHECK FOR DISCRETE, NULL, OR
9752C                                       NONE DEVICE
9753C     UPDATED         --DECEMBER  2018. SUPPORT FOR "DEVICE ... SCALE"
9754C                                       COMMAND
9755C     UPDATED         --JULY      2019. CREATE SCRATCH STORAGE IN DPNAND
9756C                                       RATHER THAN DPNAN2
9757C
9758C-----NON-COMMON VARIABLES-----------------------------------------
9759C
9760      CHARACTER*4 IHARG
9761      CHARACTER*4 IARGT
9762C
9763      CHARACTER*4 ILINPA
9764      CHARACTER*4 ILINCO
9765C
9766      CHARACTER*4 IREBLI
9767      CHARACTER*4 IREBCO
9768      CHARACTER*4 IREFSW
9769      CHARACTER*4 IREFCO
9770      CHARACTER*4 IREPTY
9771      CHARACTER*4 IREPLI
9772      CHARACTER*4 IREPCO
9773C
9774      CHARACTER*4 IGRASW
9775      CHARACTER*4 IDIASW
9776C
9777      CHARACTER*4 IDMANU
9778      CHARACTER*4 IDMODE
9779      CHARACTER*4 IDMOD2
9780      CHARACTER*4 IDMOD3
9781      CHARACTER*4 IDPOWE
9782      CHARACTER*4 IDCONT
9783      CHARACTER*4 IDCOLO
9784      CHARACTER*4 IDFONT
9785      CHARACTER*4 UNITSW
9786C
9787      CHARACTER*4 IFOUND
9788      CHARACTER*4 IBUGD2
9789      CHARACTER*4 IERROR
9790      CHARACTER*4 ISUBRO
9791C
9792      CHARACTER*4 IFIG
9793      CHARACTER*4 IBELSW
9794      CHARACTER*4 IERASW
9795      CHARACTER*4 IBACCO
9796      CHARACTER*4 ICOPSW
9797      CHARACTER*4 ITYPEO
9798C
9799      DIMENSION IHARG(*)
9800      DIMENSION IARGT(*)
9801      DIMENSION ARG(*)
9802C
9803      DIMENSION ILINPA(*)
9804      DIMENSION ILINCO(*)
9805      DIMENSION PLINTH(*)
9806C
9807      DIMENSION AREGBA(*)
9808      DIMENSION IREBLI(*)
9809      DIMENSION IREBCO(*)
9810      DIMENSION PREBTH(*)
9811      DIMENSION IREFSW(*)
9812      DIMENSION IREFCO(*)
9813      DIMENSION IREPTY(*)
9814      DIMENSION IREPLI(*)
9815      DIMENSION IREPCO(*)
9816      DIMENSION PREPTH(*)
9817      DIMENSION PREPSP(*)
9818      DIMENSION PDSCAL(*)
9819C
9820      DIMENSION IDMANU(*)
9821      DIMENSION IDMODE(*)
9822      DIMENSION IDMOD2(*)
9823      DIMENSION IDMOD3(*)
9824      DIMENSION IDPOWE(*)
9825      DIMENSION IDCONT(*)
9826      DIMENSION IDCOLO(*)
9827      DIMENSION IDFONT(*)
9828      DIMENSION IDNVPP(*)
9829      DIMENSION IDNHPP(*)
9830      DIMENSION IDUNIT(*)
9831      DIMENSION IDNVOF(*)
9832      DIMENSION IDNHOF(*)
9833C
9834C-----COMMON----------------------------------------------------------
9835C
9836      INCLUDE 'DPCOPA.INC'
9837      INCLUDE 'DPCOZZ.INC'
9838      DIMENSION PX(1000)
9839      DIMENSION PY(1000)
9840      EQUIVALENCE (GARBAG(IGARB1),PX(1))
9841      EQUIVALENCE (GARBAG(IGARB2),PY(1))
9842C
9843C-----COMMON VARIABLES (GENERAL)--------------------------------------
9844C
9845      INCLUDE 'DPCOGR.INC'
9846      INCLUDE 'DPCOBE.INC'
9847      INCLUDE 'DPCOP2.INC'
9848C
9849C-----START POINT-----------------------------------------------------
9850C
9851      IFOUND='NO'
9852      IERROR='NO'
9853      IERRG4=IERROR
9854C
9855      ILOCFN=0
9856      NUMNUM=0
9857C
9858      X1=0.0
9859      Y1=0.0
9860      X2=0.0
9861      Y2=0.0
9862C
9863      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'NAND')THEN
9864        WRITE(ICOUT,999)
9865  999   FORMAT(1X)
9866        CALL DPWRST('XXX','BUG ')
9867        WRITE(ICOUT,51)
9868   51   FORMAT('***** AT THE BEGINNING OF DPNAND--')
9869        CALL DPWRST('XXX','BUG ')
9870        WRITE(ICOUT,53)NUMARG,NUMDEV
9871   53   FORMAT('NUMARG,NUMDEV = ',2I8)
9872        CALL DPWRST('XXX','BUG ')
9873        DO55I=1,NUMARG
9874          WRITE(ICOUT,56)I,IHARG(I),IARGT(I),ARG(I)
9875   56     FORMAT('I,IHARG(I),IARGT(I),ARG(I) = ',I8,2(2X,A4),G15.7)
9876          CALL DPWRST('XXX','BUG ')
9877   55   CONTINUE
9878        WRITE(ICOUT,57)PXSTAR,PYSTAR,PXEND,PYEND
9879   57   FORMAT('PXSTAR,PYSTAR,PXEND,PYEND = ',4G15.7)
9880        CALL DPWRST('XXX','BUG ')
9881        WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1)
9882   61   FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',2(A4,2X),G15.7)
9883        CALL DPWRST('XXX','BUG ')
9884        WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1),AREGBA(1)
9885   63   FORMAT('IREBLI(1),IREBCO(1),PREBTH(1),AREGBA(1) = ',
9886     1         2(A4,2X),2G15.7)
9887        CALL DPWRST('XXX','BUG ')
9888        WRITE(ICOUT,64)IREFSW(1),IREFCO(1)
9889   64   FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4)
9890        CALL DPWRST('XXX','BUG ')
9891        WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1)
9892   65   FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ',
9893     1         3(A4,2X),2G15.7)
9894        CALL DPWRST('XXX','BUG ')
9895        WRITE(ICOUT,69)PTEXHE,PTEXWI,PTEXVG,PTEXHG
9896   69   FORMAT('PTEXHE,PTEXWI,PTEXVG,PTEXHG= ',4G15.7)
9897        CALL DPWRST('XXX','BUG ')
9898        WRITE(ICOUT,76)IGRASW,IDIASW
9899   76   FORMAT('IGRASW,IDIASW = ',A4,2X,A4)
9900        CALL DPWRST('XXX','BUG ')
9901        WRITE(ICOUT,77)PGRAXF,PGRAYF,PDIAXC,PDIAYC
9902   77   FORMAT('PGRAXF,PGRAYF,PDIAXC,PDIAYC = ',4G15.7)
9903        CALL DPWRST('XXX','BUG ')
9904        WRITE(ICOUT,78)PDIAHE,PDIAWI,PDIAVG,PDIAHG
9905   78   FORMAT('PDIAHE,PDIAWI,PDIAVG,PDIAHG = ',4G15.7)
9906        CALL DPWRST('XXX','BUG ')
9907        DO81I=1,NUMDEV
9908          WRITE(ICOUT,82)IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I)
9909   82     FORMAT('IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I) = ',
9910     1           3(A4,2X),A4)
9911          CALL DPWRST('XXX','BUG ')
9912          WRITE(ICOUT,83)IDPOWE(I),IDCONT(I),IDCOLO(I)
9913   83     FORMAT('IDPOWE(I),IDCONT(I),IDCOLO(I) = ',2(A4,2X),A4)
9914          CALL DPWRST('XXX','BUG ')
9915          WRITE(ICOUT,84)IDNVPP(I),IDNHPP(I),IDUNIT(I)
9916   84     FORMAT('IDNVPP(I),IDNHPP(I),IDUNIT(I) = ',3I8)
9917          CALL DPWRST('XXX','BUG ')
9918   81   CONTINUE
9919        WRITE(ICOUT,88)IBUGG4,IBUGD2,ISUBG4,IERRG4,IFOUND,IERROR
9920   88   FORMAT('IBUGG4,IBUGD2,ISUBG4,IERRG4,IFOUND,IERROR = ',
9921     1         5(A4,2X),A4)
9922        CALL DPWRST('XXX','BUG ')
9923      ENDIF
9924C
9925      IFIG='NAND'
9926      NUMPT=2
9927      NUMPT2=2*NUMPT
9928C
9929C               ********************************
9930C               **  STEP 0--                  **
9931C               **  STEP THROUGH EACH DEVICE  **
9932C               ********************************
9933C
9934      IF(NUMDEV.LE.0)GOTO9000
9935      DO8000IDEVIC=1,NUMDEV
9936C
9937        IF(IDPOWE(IDEVIC).EQ.'OFF')GOTO8000
9938        IF(IDMANU(IDEVIC).EQ.'OFF')GOTO8000
9939        IF(IDMANU(IDEVIC).EQ.'NULL')GOTO8000
9940        IF(IDMANU(IDEVIC).EQ.'NONE')GOTO8000
9941        IF(IDMANU(IDEVIC).EQ.'DISC')GOTO8000
9942C
9943        IMANUF=IDMANU(IDEVIC)
9944        IMODEL=IDMODE(IDEVIC)
9945        IMODE2=IDMOD2(IDEVIC)
9946        IMODE3=IDMOD3(IDEVIC)
9947        IGCONT=IDCONT(IDEVIC)
9948        IGCOLO=IDCOLO(IDEVIC)
9949        IGFONT=IDFONT(IDEVIC)
9950        NUMVPP=IDNVPP(IDEVIC)
9951        NUMHPP=IDNHPP(IDEVIC)
9952        ANUMVP=NUMVPP
9953        ANUMHP=NUMHPP
9954        IOFFSV=IDNVOF(IDEVIC)
9955        IOFFSH=IDNHOF(IDEVIC)
9956        IGUNIT=IDUNIT(IDEVIC)
9957        PCHSCA=PDSCAL(IDEVIC)
9958C
9959C               ************************************
9960C               **  STEP 1--                      **
9961C               **  CARRY OUT OPENING OPERATIONS  **
9962C               **  ON THE GRAPHICS DEVICES       **
9963C               ************************************
9964C
9965        CALL DPOPDE
9966C
9967        IBELSW='OFF'
9968        NUMRIN=0
9969        IERASW='OFF'
9970        IBACCO='JUNK'
9971C
9972        CALL DPOPPL(IGRASW,IBELSW,NUMRIN,IERASW,IBACCO)
9973C
9974C               *****************************************
9975C               **  STEP 2--                           **
9976C               **  SEARCH FOR COMMAND SPECIFICATIONS  **
9977C               *****************************************
9978C
9979        IF(NUMARG.GE.2.AND.
9980     1     IARGT(1).EQ.'NUMB'.AND.IARGT(2).EQ.'NUMB')THEN
9981          ITYPEO='ABSO'
9982          ILOCFN=1
9983        ELSEIF(NUMARG.GE.3.AND.IHARG(1).EQ.'ABSO'.AND.
9984     1         IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB')THEN
9985           ITYPEO='ABSO'
9986           ILOCFN=2
9987        ELSEIF(NUMARG.GE.3.AND.IHARG(1).EQ.'RELA'.AND.
9988     1         IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB')THEN
9989          ITYPEO='RELA'
9990          ILOCFN=2
9991        ELSE
9992          GOTO1130
9993        ENDIF
9994C
9995        IF(ILOCFN.GT.NUMARG)GOTO1130
9996        DO1120I=ILOCFN,NUMARG
9997          IF(IARGT(I).EQ.'NUMB')GOTO1120
9998          GOTO1130
9999 1120   CONTINUE
10000        IFOUND='YES'
10001C
10002C               ****************************
10003C               **  STEP 3--              **
10004C               **  DRAW OUT THE LINE(S)  **
10005C               ****************************
10006C
10007        NUMNUM=NUMARG-ILOCFN+1
10008        IF(NUMNUM.LT.NUMPT2)THEN
10009          J=ILOCFN-1
10010          X1=PXSTAR
10011          Y1=PYSTAR
10012        ELSE
10013          J=ILOCFN
10014          IF(J.GT.NUMARG)GOTO1190
10015          X1=ARG(J)
10016          IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X1,X1,
10017     1       IBUGD2,ISUBRO,IERROR)
10018          J=J+1
10019          IF(J.GT.NUMARG)GOTO1190
10020          Y1=ARG(J)
10021          IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y1,Y1,
10022     1       IBUGD2,ISUBRO,IERROR)
10023        ENDIF
10024C
10025 1160   CONTINUE
10026        J=J+1
10027        IF(J.GT.NUMARG)GOTO1190
10028        X2=ARG(J)
10029        IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X2,X2,IBUGD2,ISUBRO,IERROR)
10030        IF(ITYPEO.EQ.'RELA')X2=X1+X2
10031        J=J+1
10032        IF(J.GT.NUMARG)GOTO1190
10033        Y2=ARG(J)
10034        IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y2,Y2,IBUGD2,ISUBRO,IERROR)
10035        IF(ITYPEO.EQ.'RELA')Y2=Y1+Y2
10036C
10037        CALL DPNAN2(X1,Y1,X2,Y2,PX,PY,
10038     1              IFIG,ILINPA,ILINCO,PLINTH,
10039     1              AREGBA,IREBLI,IREBCO,PREBTH,
10040     1              IREFSW,IREFCO,
10041     1              IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
10042     1              PTEXHE,PTEXWI,PTEXVG,PTEXHG)
10043C
10044        X1=X2
10045        Y1=Y2
10046C
10047        GOTO1160
10048 1190   CONTINUE
10049C
10050        PXEND=X2
10051        PYEND=Y2
10052C
10053C               ************************************
10054C               **  STEP 4--                      **
10055C               **  CARRY OUT CLOSING OPERATIONS  **
10056C               **  ON THE GRAPHICS DEVICES       **
10057C               ************************************
10058C
10059        ICOPSW='OFF'
10060        NUMCOP=0
10061        CALL DPCLPL(ICOPSW,NUMCOP,
10062     1              PGRAXF,PGRAYF,
10063     1              IGRASW,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
10064     1              PDIAHE,PDIAWI,PDIAVG,PDIAHG)
10065C
10066        CALL DPCLDE
10067C
10068 8000 CONTINUE
10069      GOTO9000
10070C
10071 1130 CONTINUE
10072      IERRG4='YES'
10073      WRITE(ICOUT,1131)
10074 1131 FORMAT('***** ERROR IN NAND GATE (DPNAND)--')
10075      CALL DPWRST('XXX','BUG ')
10076      WRITE(ICOUT,1132)
10077 1132 FORMAT('      ILLEGAL FORM FOR NAND COMMAND.')
10078      CALL DPWRST('XXX','BUG ')
10079      WRITE(ICOUT,1134)
10080 1134 FORMAT('      TEST EXAMPLE TO DEMONSTRATE THE PROPER FORM--')
10081      CALL DPWRST('XXX','BUG ')
10082      WRITE(ICOUT,1135)
10083 1135 FORMAT('      SUPPOSE IT IS DESIRED TO DRAW A LOGICAL NAND ')
10084      CALL DPWRST('XXX','BUG ')
10085      WRITE(ICOUT,1136)
10086 1136 FORMAT('      WITH THE MIDDLE OF THE FLATTER SIDE  ',
10087     1'AT THE POINT 20 20 ')
10088      CALL DPWRST('XXX','BUG ')
10089      WRITE(ICOUT,1137)
10090 1137 FORMAT('      AND WITH THE POINTED END AT THE POINT 40 60')
10091      CALL DPWRST('XXX','BUG ')
10092      WRITE(ICOUT,1141)
10093 1141 FORMAT('      THEN THE ALLOWABLE FORMS ARE--')
10094      CALL DPWRST('XXX','BUG ')
10095      WRITE(ICOUT,1142)
10096 1142 FORMAT('      NAND 20 20 40 60 ')
10097      CALL DPWRST('XXX','BUG ')
10098      WRITE(ICOUT,1143)
10099 1143 FORMAT('      NAND ABSOLUTE 20 20 40 60 ')
10100      CALL DPWRST('XXX','BUG ')
10101      WRITE(ICOUT,1145)
10102 1145 FORMAT('      NAND RELATIVE 20 20 40 60 ')
10103      CALL DPWRST('XXX','BUG ')
10104      GOTO9000
10105C               *****************
10106C               **  STEP 90--  **
10107C               **  EXIT       **
10108C               *****************
10109C
10110 9000 CONTINUE
10111      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'NAND')THEN
10112        WRITE(ICOUT,999)
10113        CALL DPWRST('XXX','BUG ')
10114        WRITE(ICOUT,9011)
10115 9011   FORMAT('***** AT THE END       OF DPNAND--')
10116        CALL DPWRST('XXX','BUG ')
10117        WRITE(ICOUT,9012)IFOUND,IERROR,ILOCFN,NUMNUM
10118 9012   FORMAT('IFOUND,IERROR,ILOCFN,NUMNUM = ',2(A4,2X),2I8)
10119        CALL DPWRST('XXX','BUG ')
10120        WRITE(ICOUT,9013)X1,Y1,X2,Y2,X3,Y3
10121 9013   FORMAT('X1,Y1,X2,Y2,X3,Y3 = ',6G15.7)
10122        CALL DPWRST('XXX','BUG ')
10123        WRITE(ICOUT,9015)PXSTAR,PYSTAR,PXEND,PYEND
10124 9015   FORMAT('PXSTAR,PYSTAR,PXEND,PYEND = ',4G15.7)
10125        CALL DPWRST('XXX','BUG ')
10126      ENDIF
10127C
10128      RETURN
10129      END
10130      SUBROUTINE DPNATY(ISUBRO,IBUGA3,IERROR)
10131C
10132C     PURPOSE--RETURN THE TYPE OF THE SPECIFIED NAME.
10133C              THE POSSIBLE OUTCOMES ARE:
10134C
10135C                  NONE         => NAME NOT CURRENTLY DEFINED
10136C                  VARIABLE     => NAME IS A VARIABLE
10137C                  PARAMETER    => NAME IS A PARAMETER
10138C                  FUNCTION     => NAME IS A FUNCTION OR STRING
10139C                  MATRIX       => NAME IS A MATRIX
10140C
10141C     EXAMPLE--LET STYPE = TYPE X
10142C     WRITTEN BY--ALAN HECKERT
10143C                 STATISTICAL ENGINEERING DIVISION
10144C                 INFORMATION TECHNOLOGY LABORATORY
10145C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
10146C                 GAITHERSBURG, MD 20899-8980
10147C                 PHONE--301-975-2899
10148C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
10149C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
10150C     LANGUAGE--ANSI FORTRAN (1977)
10151C     VERSION NUMBER--2014/12
10152C     ORIGINAL VERSION--DECEMBER  2014.
10153C     UPDATED         --MARCH     2015. CALL LIST TO DPINFU
10154C
10155C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
10156C
10157      CHARACTER*4 ISUBRO
10158      CHARACTER*4 IBUGA3
10159      CHARACTER*4 IERROR
10160C
10161      CHARACTER*4 NEWNAM
10162      CHARACTER*4 IHLEFT
10163      CHARACTER*4 IHLEF2
10164      CHARACTER*4 IHRIGH
10165      CHARACTER*4 IHRIG2
10166      CHARACTER*4 ISUBN1
10167      CHARACTER*4 ISUBN2
10168      CHARACTER*4 ISTEPN
10169      CHARACTER*4 IATYPE(9)
10170      CHARACTER*9 IATYP2
10171C
10172C-----COMMON----------------------------------------------------------
10173C
10174      INCLUDE 'DPCOPA.INC'
10175      INCLUDE 'DPCOHK.INC'
10176      INCLUDE 'DPCODA.INC'
10177      INCLUDE 'DPCOP2.INC'
10178C
10179C-----START POINT-----------------------------------------------------
10180C
10181      ISUBN1='DPNA'
10182      ISUBN2='TY  '
10183      NEWNAM='NO'
10184      IATYP2=' '
10185      IERROR='NO'
10186C
10187      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NATY')THEN
10188        WRITE(ICOUT,999)
10189        CALL DPWRST('XXX','BUG ')
10190        WRITE(ICOUT,51)
10191   51   FORMAT('***** AT THE BEGINNING OF DPNATY--')
10192        CALL DPWRST('XXX','BUG ')
10193        WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMNAM
10194   52   FORMAT('IBUGA3,ISUBRO,NUMNAM = ',A4,2X,A4,2X,I8)
10195        CALL DPWRST('XXX','BUG ')
10196        DO55I=1,NUMNAM
10197          WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I)
10198   56     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I)',I8,2X,2A4,2X,A4)
10199          CALL DPWRST('XXX','BUG ')
10200   55   CONTINUE
10201      ENDIF
10202C
10203C               **********************************
10204C               **  STEP 1--                    **
10205C               **  INITIALIZE SOME VARIABLES.  **
10206C               **********************************
10207C
10208      ISTEPN='1'
10209      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NATY')
10210     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10211C
10212C               ******************************************************
10213C               **  STEP 2--                                         *
10214C               **  EXAMINE THE ARGUMENT ON THE                      *
10215C               **  LEFT-HAND SIDE--                                 *
10216C               **  IF THIS IS A PREVIOUSLY DEFINED NAME, IT SHOULD  *
10217C               **  BE A STRING    (IF NOT, REPORT AN ERROR).        *
10218C               ******************************************************
10219C
10220      ISTEPN='2'
10221      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NATY')
10222     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10223C
10224      IHLEFT=IHARG(1)
10225      IHLEF2=IHARG2(1)
10226C
10227      DO2000I=1,NUMNAM
10228        I2=I
10229        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
10230          IF(IUSE(I2).EQ.'F')THEN
10231            ILISTL=I2
10232            GOTO2299
10233          ELSE
10234            WRITE(ICOUT,999)
10235  999       FORMAT(1X)
10236            CALL DPWRST('XXX','BUG ')
10237            WRITE(ICOUT,2001)
10238 2001       FORMAT('***** ERROR IN NAME TYPE--')
10239            CALL DPWRST('XXX','BUG ')
10240            WRITE(ICOUT,2003)IHLEFT,IHLEF2
10241 2003       FORMAT('      THE FIRST NAME ON THE LEFT HAND SIDE (',
10242     1             A4,A4,')')
10243            CALL DPWRST('XXX','BUG ')
10244            WRITE(ICOUT,2005)
10245 2005       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
10246            CALL DPWRST('XXX','BUG ')
10247            IERROR='YES'
10248            GOTO9000
10249          ENDIF
10250        ENDIF
10251 2000 CONTINUE
10252C
10253      NEWNAM='YES'
10254C
10255      ILISTL=NUMNAM+1
10256      IF(ILISTL.GT.MAXNAM)THEN
10257        WRITE(ICOUT,999)
10258        CALL DPWRST('XXX','BUG ')
10259        WRITE(ICOUT,2001)
10260        CALL DPWRST('XXX','BUG ')
10261        WRITE(ICOUT,2202)
10262 2202   FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND ',
10263     1         'FUNCTION')
10264        CALL DPWRST('XXX','BUG ')
10265        WRITE(ICOUT,2203)MAXNAM
10266 2203   FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
10267        CALL DPWRST('XXX','BUG ')
10268        WRITE(ICOUT,2204)
10269 2204   FORMAT('      ENTER      STATUS')
10270        CALL DPWRST('XXX','BUG ')
10271        WRITE(ICOUT,2205)
10272 2205   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES, AND')
10273        CALL DPWRST('XXX','BUG ')
10274        WRITE(ICOUT,2206)
10275 2206   FORMAT('      THEN REDEFINE OR DELETE SOME OF THE ALREADY ',
10276     1         'USED NAMES.')
10277        CALL DPWRST('XXX','BUG ')
10278        IERROR='YES'
10279        GOTO9000
10280      ENDIF
10281C
10282 2299 CONTINUE
10283C
10284C               *****************************************************
10285C               **  STEP 3--                                       **
10286C               **  EXTRACT THE FIRST NAME ON THE RIGHT HAND SIDE  **
10287C               **  AND DETERMINE ITS TYPE                         **
10288C               *****************************************************
10289C
10290      ISTEPN='3A'
10291      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NATY')
10292     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10293C
10294      IHRIGH=IHARG(4)
10295      IHRIG2=IHARG2(4)
10296      DO3000I=1,NUMNAM
10297        IF(IHRIGH.EQ.IHNAME(I).AND.IHRIG2.EQ.IHNAM2(I))THEN
10298          IF(IUSE(I).EQ.'F')THEN
10299            IATYP2='FUNCTION'
10300            IATYPE(1)='F'
10301            IATYPE(2)='U'
10302            IATYPE(3)='N'
10303            IATYPE(4)='C'
10304            IATYPE(5)='T'
10305            IATYPE(6)='I'
10306            IATYPE(7)='O'
10307            IATYPE(8)='N'
10308            ICNT=8
10309            GOTO3099
10310          ELSEIF(IUSE(I).EQ.'V')THEN
10311            IATYP2='VARIABLE'
10312            IATYPE(1)='V'
10313            IATYPE(2)='A'
10314            IATYPE(3)='R'
10315            IATYPE(4)='I'
10316            IATYPE(5)='A'
10317            IATYPE(6)='B'
10318            IATYPE(7)='L'
10319            IATYPE(8)='E'
10320            ICNT=8
10321            GOTO3099
10322          ELSEIF(IUSE(I).EQ.'P')THEN
10323            IATYP2='PARAMETER'
10324            IATYPE(1)='P'
10325            IATYPE(2)='A'
10326            IATYPE(3)='R'
10327            IATYPE(4)='A'
10328            IATYPE(5)='M'
10329            IATYPE(6)='E'
10330            IATYPE(7)='T'
10331            IATYPE(8)='E'
10332            IATYPE(9)='R'
10333            ICNT=9
10334            GOTO3099
10335          ELSEIF(IUSE(I).EQ.'M')THEN
10336            IATYP2='MATRIX'
10337            IATYPE(1)='M'
10338            IATYPE(2)='A'
10339            IATYPE(3)='T'
10340            IATYPE(4)='R'
10341            IATYPE(5)='I'
10342            IATYPE(6)='X'
10343            ICNT=6
10344            GOTO3099
10345          ENDIF
10346        ENDIF
10347 3000 CONTINUE
10348      IATYP2='NONE'
10349      IATYPE(1)='N'
10350      IATYPE(2)='O'
10351      IATYPE(3)='N'
10352      IATYPE(4)='E'
10353      ICNT=4
10354 3099 CONTINUE
10355C
10356C               *****************************************************
10357C               **  STEP 4--                                       **
10358C               **  SAVE TYPE STRING AND PRINT FEEDBACK MESSAGE    **
10359C               *****************************************************
10360C
10361C
10362      ISTEPN='4'
10363      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NATY')
10364     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10365C
10366      CALL DPINFU(IATYPE,ICNT,IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP,
10367     1            NUMNAM,IANS,IWIDTH,IHLEFT,IHLEF2,ILISTL,
10368     1            NEWNAM,MAXNAM,
10369     1            IFUNC,NUMCHF,MAXCHF,IBUGA3,IERROR)
10370      IF(IERROR.EQ.'YES')GOTO9000
10371C
10372      IF(IFEEDB.EQ.'ON' .AND. IPRINT.EQ.'ON')THEN
10373        WRITE(ICOUT,999)
10374        CALL DPWRST('XXX','BUG ')
10375        WRITE(ICOUT,6606)IHRIGH,IHRIG2,IATYP2
10376 6606   FORMAT('THE NAME ',A4,A4,' HAS TYPE ',A9)
10377        CALL DPWRST('XXX','BUG ')
10378        WRITE(ICOUT,999)
10379        CALL DPWRST('XXX','BUG ')
10380C
10381      ENDIF
10382C
10383C
10384C               ****************
10385C               **  STEP 90-- **
10386C               **  EXIT.     **
10387C               ****************
10388C
10389 9000 CONTINUE
10390      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NATY')THEN
10391        WRITE(ICOUT,999)
10392        CALL DPWRST('XXX','BUG ')
10393        WRITE(ICOUT,9011)
10394 9011   FORMAT('***** AT THE END       OF DPNATY--')
10395        CALL DPWRST('XXX','BUG ')
10396        WRITE(ICOUT,9013)NUMNAM,IATYPE
10397 9013   FORMAT('NUMNAM,IATYPE = ',I8,2X,A9)
10398        CALL DPWRST('XXX','BUG ')
10399        DO9015I=1,NUMNAM
10400          WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I)
10401 9016     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I)=',I8,2X,2A4,2X,A4)
10402          CALL DPWRST('XXX','BUG ')
10403 9015   CONTINUE
10404      ENDIF
10405C
10406      RETURN
10407      END
10408      SUBROUTINE DPNDER(ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,
10409     1                  IA,PARAM,IPARN,IPARN2,
10410     1                  IANGLU,IFTEXP,IFTORD,IFORSW,
10411     1                  IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO,IERROR)
10412C
10413C     PURPOSE--TREAT THE LET CASE FOR
10414C              FINDING THE NUMERICAL DERIVATIVE OF AN FUNCTION.
10415C     EXAMPLE--LET A = NUMERICAL DERIVATIVE X**3+2*X**2-4*X+5 FOR X = 1
10416C            --LET X = NUMERICAL DERIVATIVE F1 FOR X = B
10417C     WRITTEN BY--ALAN HECKERT
10418C                 STATISTICAL ENGINEERING DIVISION
10419C                 INFORMATION TECHNOLGY LABORATORY
10420C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
10421C                 GAITHERSBURG, MD 20899-8980
10422C                 PHONE--301-975-2899
10423C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
10424C           OF THE NATIONAL BUREAU OF STANDARDS.
10425C     LANGUAGE--ANSI FORTRAN (1977)
10426C     VERSION NUMBER--2004/1
10427C     ORIGINAL VERSION--JANUARY   2004.
10428C     UPDATED         --SEPTEMBER 2015. SUPPORT FOR FUNCTION BLOCKS
10429C
10430C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
10431C
10432      CHARACTER*4 ITYPEH
10433      CHARACTER*4 IW21HO
10434      CHARACTER*4 IW22HO
10435      CHARACTER*4 IA
10436      CHARACTER*4 IPARN
10437      CHARACTER*4 IPARN2
10438      CHARACTER*4 IANGLU
10439      CHARACTER*4 IFTEXP
10440      CHARACTER*4 IFTORD
10441      CHARACTER*4 IFORSW
10442      CHARACTER*4 IBUGA3
10443      CHARACTER*4 IBUGCO
10444      CHARACTER*4 IBUGEV
10445      CHARACTER*4 IBUGQ
10446      CHARACTER*4 ISUBRO
10447      CHARACTER*4 IERROR
10448C
10449      CHARACTER*4 NEWNAM
10450      CHARACTER*4 IHOUT
10451      CHARACTER*4 IHOUT2
10452      CHARACTER*4 IUOUT
10453      CHARACTER*4 IDUMV
10454      CHARACTER*4 IDUMV2
10455      CHARACTER*4 IHPARN
10456      CHARACTER*4 IHPAR2
10457      CHARACTER*4 IHL
10458      CHARACTER*4 IHL2
10459      CHARACTER*4 IWD1
10460      CHARACTER*4 IWD2
10461      CHARACTER*4 IWD12
10462      CHARACTER*4 IWD22
10463      CHARACTER*4 ILAB
10464      CHARACTER*4 IKEY
10465      CHARACTER*4 IKEY2
10466      CHARACTER*4 INCLUN
10467      CHARACTER*4 IHWUSE
10468      CHARACTER*4 MESSAG
10469      CHARACTER*4 ICASEL
10470      CHARACTER*4 IFOUND
10471      CHARACTER*4 IFOUN1
10472      CHARACTER*4 IFOUN2
10473      CHARACTER*4 IERRO2
10474      CHARACTER*4 IHLEFT
10475      CHARACTER*4 IHLEF2
10476      CHARACTER*4 IOLD
10477      CHARACTER*4 IOLD2
10478      CHARACTER*4 INEW
10479      CHARACTER*4 INEW2
10480C
10481      CHARACTER*4 IHP
10482      CHARACTER*4 IHP2
10483      CHARACTER*4 ISUBN1
10484      CHARACTER*4 ISUBN2
10485      CHARACTER*4 ISTEPN
10486C
10487C---------------------------------------------------------------------
10488C
10489      DIMENSION ITYPEH(*)
10490      DIMENSION IW21HO(*)
10491      DIMENSION IW22HO(*)
10492      DIMENSION W2HOLD(*)
10493C
10494      DIMENSION IA(*)
10495      DIMENSION PARAM(*)
10496      DIMENSION IPARN(*)
10497      DIMENSION IPARN2(*)
10498C
10499      DIMENSION IDUMV(100)
10500      DIMENSION IDUMV2(100)
10501C
10502      DIMENSION ILAB(10)
10503      DIMENSION IOLD(10)
10504      DIMENSION IOLD2(10)
10505      DIMENSION INEW(10)
10506      DIMENSION INEW2(10)
10507C
10508C-----MAKE DUMMY COMMON BLOCK FOR FUNCTION CALL-----------
10509C
10510      PARAMETER (IDUMCH=1000)
10511      PARAMETER (IDUMC2=100)
10512C
10513      CHARACTER*4 IBUGAZ
10514      CHARACTER*4 IZNAME
10515      CHARACTER*4 IZNAM2
10516      CHARACTER*4 ZTYPEH
10517      CHARACTER*4 ZW21HO
10518      CHARACTER*4 ZW22HO
10519      CHARACTER*4 ZIPARN
10520      CHARACTER*4 ZPARN2
10521      CHARACTER*4 ZMODEL
10522      CHARACTER*4 ZIDUMV
10523      CHARACTER*4 ZDUMV2
10524C
10525      DIMENSION ZMODEL(IDUMCH)
10526      DIMENSION ZTYPEH(IDUMCH)
10527      DIMENSION ZW21HO(IDUMCH)
10528      DIMENSION ZW22HO(IDUMCH)
10529      DIMENSION Z2HOLD(IDUMCH)
10530C
10531      DIMENSION ZPARAM(IDUMC2)
10532      DIMENSION ZIPARN(IDUMC2)
10533      DIMENSION ZPARN2(IDUMC2)
10534      DIMENSION ZIDUMV(IDUMC2)
10535      DIMENSION ZDUMV2(IDUMC2)
10536      DIMENSION LOCDUZ(IDUMC2)
10537C
10538      COMMON /DUMCMC/ IBUGAZ, ZTYPEH, ZW21HO, ZW22HO, ZIPARN, ZPARN2,
10539     &                ZIDUMV, ZDUMV2, ZMODEL, IZNAME, IZNAM2, IZNDEX
10540      COMMON /DUMCMR/ ZPARAM, Z2HOLD,
10541     &                NUMCHZ, NUMPVZ, NWHOLZ, NUMDVZ, LOCDUZ
10542CCCCC EXTERNAL OPTFCN
10543C
10544CCCCC THE FOLLOWING LINE WAS ADDED NOVEMBER 1989
10545      DIMENSION BJUNK(1)
10546C
10547C-----COMMON----------------------------------------------------------
10548C
10549      INCLUDE 'DPCOPA.INC'
10550      INCLUDE 'DPCOHK.INC'
10551      INCLUDE 'DPCODA.INC'
10552      INCLUDE 'DPCOFB.INC'
10553C
10554      COMMON/IFBL2/IFLGF2
10555C
10556      INCLUDE 'DPCOZZ.INC'
10557      DIMENSION XFULL(MAXOBV)
10558      DIMENSION YDER(MAXOBV)
10559      EQUIVALENCE (GARBAG(IGARB1),XFULL(1))
10560      EQUIVALENCE (GARBAG(IGARB2),YDER(1))
10561C
10562C-----COMMON VARIABLES (GENERAL)--------------------------------------
10563C
10564      INCLUDE 'DPCOP2.INC'
10565C
10566C-----START POINT-----------------------------------------------------
10567C
10568C               **********************************************
10569C               **  TREAT THE NUMERICAL DERIVATIVE SUBCASE  **
10570C               **  OF THE LET COMMAND                      **
10571C               **********************************************
10572C
10573      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NDER')THEN
10574        WRITE(ICOUT,999)
10575  999   FORMAT(1X)
10576        CALL DPWRST('XXX','BUG ')
10577        WRITE(ICOUT,51)
10578   51   FORMAT('***** AT THE BEGINNING OF DPNDER--')
10579        CALL DPWRST('XXX','BUG ')
10580        WRITE(ICOUT,53)IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO
10581   53   FORMAT('IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO = ',4(A4,2X),A4)
10582        CALL DPWRST('XXX','BUG ')
10583        WRITE(ICOUT,55)IA(1),IA(2),IA(3),IA(4)
10584   55   FORMAT('IA(1),IA(2),IA(3),IA(4) = ',3(A4,2X),A4)
10585        CALL DPWRST('XXX','BUG ')
10586        WRITE(ICOUT,57)IFORSW,IFTORD,IFTEXP,IANGLU
10587   57   FORMAT('IFORSW,IFTORD,IFTEXP,IANGLU = ',3(A4,2X),A4)
10588        CALL DPWRST('XXX','BUG ')
10589      ENDIF
10590C
10591C               **********************************
10592C               **  STEP 1--                    **
10593C               **  INITIALIZE SOME VARIABLES.  **
10594C               **********************************
10595C
10596      ISTEPN='1'
10597      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NDER')
10598     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10599C
10600      ISUBN1='DPND'
10601      ISUBN2='ER  '
10602      IERROR='NO'
10603      IHLEFT='UNKN'
10604      IHLEF2='UNKN'
10605      NEWNAM='NO'
10606C
10607      MAXCP1=MAXCOL+1
10608      MAXCP2=MAXCOL+2
10609      MAXCP3=MAXCOL+3
10610      MAXCP4=MAXCOL+4
10611      MAXCP5=MAXCOL+5
10612      MAXCP6=MAXCOL+6
10613      ILOCMX=0
10614      NUMLIM=0
10615      ILOC3=0
10616      IP=0
10617      IV=0
10618      LOCDUM=0
10619      MAXN2=MAXCHF
10620      MAXN3=MAXCHF
10621      ICOLR=0
10622C
10623C               *******************************************************
10624C               **  STEP 2--                                         **
10625C               **  CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS.  **
10626C               *******************************************************
10627C
10628      ISTEPN='2'
10629      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NDER')
10630     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10631C
10632      MINNA=1
10633      MAXNA=100
10634      CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,
10635     1IERROR)
10636      IF(IERROR.EQ.'YES')GOTO9000
10637C
10638C               ******************************************************
10639C               **  STEP 2--                                         *
10640C               **  EXAMINE THE LEFT-HAND SIDE--                     *
10641C               **  IS THE NAME     NAME TO LEFT OF = SIGN           *
10642C               **  ALREADY IN THE NAME LIST?                        *
10643C               **  NOTE THAT     ILISTL    IS THE LINE IN THE TABLE *
10644C               **  OF THE NAME ON THE LEFT.                         *
10645C               ******************************************************
10646C
10647      ISTEPN='2'
10648      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NDER')
10649     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10650C
10651      IHLEFT=IHARG(1)
10652      IHLEF2=IHARG2(1)
10653      DO2000I=1,NUMNAM
10654        I2=I
10655        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
10656          ILISTL=I2
10657          GOTO2900
10658        ENDIF
10659 2000 CONTINUE
10660      NEWNAM='YES'
10661      ILISTL=NUMNAM+1
10662      IF(ILISTL.GT.MAXNAM)THEN
10663        WRITE(ICOUT,999)
10664        CALL DPWRST('XXX','BUG ')
10665        WRITE(ICOUT,2201)
10666 2201   FORMAT('***** ERROR IN NUMERICAL DERIVATIVE--')
10667        CALL DPWRST('XXX','BUG ')
10668        WRITE(ICOUT,2202)
10669 2202   FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND FUNCTION')
10670        CALL DPWRST('XXX','BUG ')
10671        WRITE(ICOUT,2203)MAXNAM
10672 2203   FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
10673        CALL DPWRST('XXX','BUG ')
10674        WRITE(ICOUT,2204)
10675 2204   FORMAT('      ENTER      STAT')
10676        CALL DPWRST('XXX','BUG ')
10677        WRITE(ICOUT,2205)
10678 2205   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES,')
10679        CALL DPWRST('XXX','BUG ')
10680        WRITE(ICOUT,2206)
10681 2206   FORMAT('      AND THEN REDEFINE (REUSE) SOME OF THE')
10682        CALL DPWRST('XXX','BUG ')
10683        WRITE(ICOUT,2207)
10684 2207   FORMAT('      ALREADY-USED NAMES')
10685        CALL DPWRST('XXX','BUG ')
10686        IERROR='YES'
10687        GOTO9000
10688      ENDIF
10689C
10690 2900 CONTINUE
10691C
10692C               *****************************************************
10693C               **  STEP 3.1--                                     **
10694C               **  EXTRACT THE RIGHT-SIDE FUNCTIONAL              **
10695C               **  EXPRESSION FROM THE INPUT COMMAND LINE         **
10696C               **  (STARTING WITH THE FIRST NON-BLANK LOCATION    **
10697C               **  AFTER THE                                      **
10698C               **  EQUAL SIGN AND ENDING WITH THE END OF THE LINE **
10699C               **  OR WITH THE LAST NON-BLANK CHARACTER BEFORE    **
10700C               **  WRT  .                                         **
10701C               **  PLACE THE FUNCTION IN IFUNC2(.)  .             **
10702C               *****************************************************
10703C
10704      ISTEPN='3.1'
10705      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NDER')
10706     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10707C
10708C     2015/09: CHECK TO SEE IF THE FIRST ARGUMENT ON RHS IS A FUNCTION
10709C              BLOCK NAME.
10710C
10711      IF(IHARG(5).EQ.IFBNA1(1:4) .AND. IHARG2(5).EQ.IFBNA1(5:8))THEN
10712        IFLGFB=1
10713      ELSEIF(IHARG(5).EQ.IFBNA2(1:4) .AND. IHARG2(5).EQ.IFBNA2(5:8))THEN
10714        IFLGFB=2
10715      ELSEIF(IHARG(5).EQ.IFBNA3(1:4) .AND. IHARG2(5).EQ.IFBNA3(5:8))THEN
10716        IFLGFB=3
10717      ELSE
10718        IFLGFB=0
10719      ENDIF
10720      IFLGF2=IFLGFB
10721C
10722      IWD1=IHARG(4)
10723      IWD12=IHARG2(4)
10724      IWD2='WRT '
10725      IWD22='    '
10726      CALL DPEXST(IANS,IWIDTH,IWD1,IWD12,IWD2,IWD22,MAXN2,
10727     1            IFUNC2,N2,IBUGA3,IFOUND,IERROR)
10728      IF(IERROR.EQ.'YES')GOTO9000
10729C
10730      IF(IFOUND.EQ.'NO')THEN
10731        IWD1=IHARG(4)
10732        IWD12=IHARG2(4)
10733        IWD2='FOR '
10734        IWD22='    '
10735        CALL DPEXST(IANS,IWIDTH,IWD1,IWD12,IWD2,IWD22,MAXN2,
10736     1              IFUNC2,N2,IBUGA3,IFOUND,IERROR)
10737        IF(IERROR.EQ.'YES')GOTO9000
10738        IF(IFOUND.EQ.'NO')THEN
10739          WRITE(ICOUT,999)
10740          CALL DPWRST('XXX','BUG ')
10741          WRITE(ICOUT,2201)
10742          CALL DPWRST('XXX','BUG ')
10743          WRITE(ICOUT,3102)
10744 3102     FORMAT('      INVALID COMMAND FORM FOR INTEGRATION.')
10745          CALL DPWRST('XXX','BUG ')
10746          WRITE(ICOUT,3103)
10747 3103     FORMAT('      GENERAL FORM--')
10748          CALL DPWRST('XXX','BUG ')
10749          WRITE(ICOUT,3104)
10750 3104     FORMAT('      LET ... = NUMERICAL DERIVATIVE ... WRT  ... ',
10751     1           'FOR ... = ...')
10752          CALL DPWRST('XXX','BUG ')
10753          WRITE(ICOUT,3105)
10754 3105     FORMAT('      THE ENTIRE COMMAND LINE WAS AS FOLLOWS--')
10755          CALL DPWRST('XXX','BUG ')
10756          IF(IWIDTH.GE.1)THEN
10757            WRITE(ICOUT,3106)(IANS(I),I=1,MIN(100,IWIDTH))
10758 3106       FORMAT('      ',100A1)
10759            CALL DPWRST('XXX','BUG ')
10760          ENDIF
10761          IERROR='YES'
10762          GOTO9000
10763        ENDIF
10764      ENDIF
10765C
10766C               ******************************************************
10767C               **  STEP 4--                                        **
10768C               **  DETERMINE IF THE EXPRESSION HAS ANY FUNCTION    **
10769C               **  NAMES.  INBEDDED.  IF SO, REPLACE THE FUNCTION  **
10770C               **  NAMES  BY EACH                                  **
10771C               **  FUNCTION'S DEFINITION.  DO SO REPEATEDLY        **
10772C               **  UNTIL ALL FUNCTION REFERENCES HAVE BEEN         **
10773C               **  ANNIHILATED AND THE EXPRESSION IS LEFT ONLY WITH**
10774C               **  CONSTANTS, PARAMETERS, AND VARIABLES--NO        **
10775C               **  FUNCTIONS.  PLACE THE                           **
10776C               **  RESULTING FUNCTIONAL EXPRESSION INTO IFUNC3(.)  **
10777C               ******************************************************
10778C
10779      ISTEPN='4'
10780      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NDER')
10781     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10782C
10783      IF(IFLGFB.LE.0)THEN
10784        CALL DPEXFU(IFUNC2,N2,IHNAME,IHNAM2,IUSE,IVSTAR,IVSTOP,
10785     1              NUMNAM,IANS,IWIDTH,IFUNC,NUMCHF,MAXCHF,
10786     1              IFUNC3,N3,MAXN3,
10787     1              IBUGA3,IERROR)
10788        IF(IERROR.EQ.'YES')GOTO9000
10789C
10790        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NDER')THEN
10791          WRITE(ICOUT,999)
10792          CALL DPWRST('XXX','BUG ')
10793          ILAB(1)='INPU'
10794          ILAB(2)='T FU'
10795          ILAB(3)='NCTI'
10796          ILAB(4)='ON  '
10797          ILAB(5)='    '
10798          ILAB(6)='  = '
10799          NUMWDL=6
10800          CALL DPPRIF(ILAB,NUMWDL,IFUNC3,N3,IBUGA3)
10801          WRITE(ICOUT,5081)IDUMV(1),IDUMV2(1)
10802 5081     FORMAT('DIFFERATION VARIABLE  = ',A4,A4)
10803          CALL DPWRST('XXX','BUG ')
10804        ENDIF
10805C
10806      ENDIF
10807C
10808C               *************************************
10809C               **  STEP 5--                       **
10810C               **  EXTRACT QUALIFIER INFORMATION. **
10811C               *************************************
10812C
10813      ISTEPN='5'
10814      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NDER')
10815     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10816C
10817C               *************************************************
10818C               **  STEP 5.1--                                 **
10819C               **  DETERMINE THE DUMMY VARIABLE FOR THE       **
10820C               **  DIFFERENTIATION.                           **
10821C               *************************************************
10822C
10823      ISTEPN='5.1'
10824      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NDER')
10825     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10826C
10827      NRIGHT=-1
10828C
10829      IKEY='WRT '
10830      IKEY2='    '
10831      ISHIFT=1
10832      ILOCA=1
10833      ILOCB=NUMARG
10834      INCLUN='NO'
10835      CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB,
10836     1            IHARG,IHARG2,NUMARG,
10837     1            INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,
10838     1            IUSE,IN,NUMNAM,
10839     1            IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT,IVOUT,
10840     1            VOUT,IUOUT,
10841     1            INOUT,IBUGA3,IERROR)
10842      IF(IFOUN1.EQ.'NO'.OR.IFOUN2.EQ.'NO')GOTO5119
10843      IDUMV(1)=IHOUT
10844      IDUMV2(1)=IHOUT2
10845      IZNAME=IDUMV(1)
10846      IZNAM2=IDUMV2(1)
10847C
10848C  CHECK TO SEE IF DUMMY VARIABLE IS ALREADY DEFINED AS A
10849C  VARIABLE (USE THESE VALUES IF NO FOR CLAUSE SPECIFIED)
10850C
10851      IHWUSE='V'
10852      MESSAG='NO'
10853      CALL CHECKN(IZNAME,IZNAM2,IHWUSE,
10854     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
10855     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
10856      IF(IERROR.EQ.'NO')THEN
10857        ICOLR=IVALUE(ILOCV)
10858        NRIGHT=IN(ILOCV)
10859      ENDIF
10860C
10861      NUMDV=1
10862      GOTO5190
10863 5119 CONTINUE
10864C
10865      IKEY='FOR '
10866      IKEY2='    '
10867      ISHIFT=1
10868      ILOCA=1
10869      ILOCB=NUMARG
10870      INCLUN='NO'
10871      CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB,
10872     1            IHARG,IHARG2,NUMARG,
10873     1            INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,
10874     1            IUSE,IN,NUMNAM,
10875     1            IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT,
10876     1            IVOUT,VOUT,IUOUT,
10877     1            INOUT,IBUGA3,IERROR)
10878      IF(IFOUN1.EQ.'NO'.OR.IFOUN2.EQ.'NO')GOTO5129
10879      IDUMV(1)=IHOUT
10880      IDUMV2(1)=IHOUT2
10881      IZNAME=IDUMV(1)
10882      IZNAM2=IDUMV2(1)
10883C
10884C  CHECK TO SEE IF DUMMY VARIABLE IS ALREADY DEFINED AS A
10885C  VARIABLE (USE THESE VALUES IF NO FOR CLAUSE SPECIFIED)
10886C
10887      IHWUSE='V'
10888      MESSAG='NO'
10889      CALL CHECKN(IZNAME,IZNAM2,IHWUSE,
10890     1            IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
10891     1            ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
10892      IF(IERROR.EQ.'NO')THEN
10893        ICOLR=IVALUE(ILOCV)
10894        NRIGHT=IN(ILOCV)
10895      ENDIF
10896C
10897      NUMDV=1
10898      GOTO5190
10899 5129 CONTINUE
10900C
10901      WRITE(ICOUT,999)
10902      CALL DPWRST('XXX','BUG ')
10903      WRITE(ICOUT,2201)
10904      CALL DPWRST('XXX','BUG ')
10905      WRITE(ICOUT,3102)
10906      CALL DPWRST('XXX','BUG ')
10907      WRITE(ICOUT,5183)
10908 5183 FORMAT('      NO VARIABLE OF DIFFERENTIATION DEFINED.')
10909      CALL DPWRST('XXX','BUG ')
10910      WRITE(ICOUT,3103)
10911      CALL DPWRST('XXX','BUG ')
10912      WRITE(ICOUT,3104)
10913      CALL DPWRST('XXX','BUG ')
10914      WRITE(ICOUT,3105)
10915      CALL DPWRST('XXX','BUG ')
10916      IF(IWIDTH.GE.1)THEN
10917        WRITE(ICOUT,3106)(IANS(I),I=1,MIN(100,IWIDTH))
10918        CALL DPWRST('XXX','BUG ')
10919      ENDIF
10920      IERROR='YES'
10921      GOTO9000
10922 5190 CONTINUE
10923C
10924C               **************************************************
10925C               **  STEP 5.2--                                  **
10926C               **  DETERMINE THE POINT AT WHICH TO COMPUTE THE **
10927C               **  DERIVATIVE.                                 **
10928C               **************************************************
10929C
10930      ISTEPN='5.2'
10931      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NDER')
10932     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10933C
10934      NUMLIM=0
10935C
10936      IKEY='FOR '
10937      IKEY2='    '
10938      ISHIFT=3
10939      ILOCA=1
10940      ILOCB=NUMARG
10941      INCLUN='NO'
10942      CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB,
10943     1            IHARG,IHARG2,NUMARG,
10944     1            INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,
10945     1            IUSE,IN,NUMNAM,
10946     1            IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT,IVOUT,
10947     1            VOUT,IUOUT,
10948     1            INOUT,IBUGA3,IERROR)
10949      IF(IFOUN1.EQ.'NO'.AND.IFOUN2.EQ.'NO')THEN
10950        IF(NRIGHT.GT.0)THEN
10951          DO5215J=1,NRIGHT
10952            IJ=MAXN*(ICOLR-1)+J
10953            IF(ICOLR.LE.MAXCOL)XFULL(J)=V(IJ)
10954            IF(ICOLR.EQ.MAXCP1)XFULL(J)=PRED(I)
10955            IF(ICOLR.EQ.MAXCP2)XFULL(J)=RES(I)
10956            IF(ICOLR.EQ.MAXCP3)XFULL(J)=YPLOT(I)
10957            IF(ICOLR.EQ.MAXCP4)XFULL(J)=XPLOT(I)
10958            IF(ICOLR.EQ.MAXCP5)XFULL(J)=X2PLOT(I)
10959            IF(ICOLR.EQ.MAXCP6)XFULL(J)=TAGPLO(I)
10960 5215     CONTINUE
10961        ELSE
10962          GOTO5219
10963        ENDIF
10964      ENDIF
10965      X0=VOUT
10966      NUMLIM=NUMLIM+1
10967      ILOCMX=ILOC2
10968 5219 CONTINUE
10969C
10970CCCCC CHECK TO SEE IF DIFFERENTIATION VARIABLE HAS BEEN PREVIOUSLY
10971CCCCC DEFINED.
10972C
10973      IF(NUMLIM.LT.1)THEN
10974        WRITE(ICOUT,999)
10975        CALL DPWRST('XXX','BUG ')
10976        WRITE(ICOUT,2201)
10977        CALL DPWRST('XXX','BUG ')
10978        WRITE(ICOUT,3102)
10979        CALL DPWRST('XXX','BUG ')
10980        WRITE(ICOUT,5283)
10981 5283   FORMAT('      THE POINT AT WHICH TO COMPUTE THE NUMERICAL ',
10982     1         'DERIVATIVE IS NOT DEFINED.')
10983        CALL DPWRST('XXX','BUG ')
10984        WRITE(ICOUT,3103)
10985        CALL DPWRST('XXX','BUG ')
10986        WRITE(ICOUT,3104)
10987        CALL DPWRST('XXX','BUG ')
10988        WRITE(ICOUT,3105)
10989        CALL DPWRST('XXX','BUG ')
10990        IF(IWIDTH.GE.1)THEN
10991          WRITE(ICOUT,3106)(IANS(I),I=1,MIN(100,IWIDTH))
10992          CALL DPWRST('XXX','BUG ')
10993        ENDIF
10994        IERROR='YES'
10995        GOTO9000
10996      ENDIF
10997C
10998C               **********************************************
10999C               **  STEP 6.3--                              **
11000C               **  SCAN THE QUALIFIERS FOR VARIABLE,       **
11001C               **  PARAMETER, FUNCTION, AND VALUE CHANGES  **
11002C               **  IN THE FUNCTION.                        **
11003C               **********************************************
11004C
11005      ISTEPN='6.3'
11006      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NDER')
11007     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11008C
11009      NCHANG=0
11010      DO6300IFORI=1,10
11011C
11012        IKEY='FOR '
11013        IKEY2='    '
11014        ISHIFT=1
11015        IF(IFORI.EQ.1)ILOCA=ILOCMX
11016        IF(IFORI.NE.1)ILOCA=ILOC3
11017        ILOCB=NUMARG
11018        INCLUN='NO'
11019        CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB,
11020     1              IHARG,IHARG2,NUMARG,
11021     1              INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,
11022     1              IUSE,IN,NUMNAM,
11023     1              IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT,IVOUT,
11024     1              VOUT,IUOUT,
11025     1              INOUT,IBUGA3,IERROR)
11026        IF(IFOUN1.EQ.'NO'.OR.IFOUN2.EQ.'NO'.AND.IERROR.EQ.'NO')GOTO6350
11027C
11028        ILOC3=ILOC2+2
11029        IF(IERROR.EQ.'YES' .OR. ILOC3.GT.NUMARG)THEN
11030          WRITE(ICOUT,999)
11031          CALL DPWRST('XXX','BUG ')
11032          WRITE(ICOUT,2201)
11033          CALL DPWRST('XXX','BUG ')
11034          WRITE(ICOUT,3102)
11035          CALL DPWRST('XXX','BUG ')
11036          WRITE(ICOUT,3103)
11037          CALL DPWRST('XXX','BUG ')
11038          WRITE(ICOUT,3104)
11039          CALL DPWRST('XXX','BUG ')
11040          WRITE(ICOUT,3105)
11041          CALL DPWRST('XXX','BUG ')
11042          IF(IWIDTH.GE.1)THEN
11043            WRITE(ICOUT,3106)(IANS(I),I=1,MIN(100,IWIDTH))
11044            CALL DPWRST('XXX','BUG ')
11045          ENDIF
11046          IERROR='YES'
11047          GOTO9000
11048        ENDIF
11049        NCHANG=NCHANG+1
11050        IOLD(NCHANG)=IHARG(ILOC2)
11051        IOLD2(NCHANG)=IHARG2(ILOC2)
11052        INEW(NCHANG)=IHARG(ILOC3)
11053        INEW2(NCHANG)=IHARG2(ILOC3)
11054C
11055 6300 CONTINUE
11056 6350 CONTINUE
11057C
11058C               **********************************************
11059C               **  STEP 6.4--                              **
11060C               **  CARRY OUT THE VARIABLE,                 **
11061C               **  PARAMETER, AND FUNCTION CHANGES         **
11062C               **  AND THEN PRINT OUT A BRIEF MESSAGE      **
11063C               **  INDICATING THAT THE CHANGES             **
11064C               **  HAVE BEEN MADE.                         **
11065C               **********************************************
11066C
11067      ISTEPN='6.4'
11068      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NDER')
11069     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11070C
11071      IF(IPRINT.EQ.'ON' .AND. IFEEDB.EQ.'ON' .AND. NCHANG.GT.0 .AND.
11072     1   IFLGFB.LE.0)THEN
11073C
11074        WRITE(ICOUT,999)
11075        CALL DPWRST('XXX','BUG ')
11076        ILAB(1)='PRE '
11077        ILAB(2)='-CHA'
11078        ILAB(3)='NGE '
11079        ILAB(4)='FUNC'
11080        ILAB(5)='TION'
11081        ILAB(6)='  = '
11082        NUMWDL=6
11083        CALL DPPRIF(ILAB,NUMWDL,IFUNC3,N3,IBUGA3)
11084C
11085        CALL COMPIC(IFUNC3,N3,IOLD,IOLD2,INEW,INEW2,NCHANG,IFUNC3,N3,
11086     1              IBUGA3,IERROR)
11087        IF(IERROR.EQ.'YES')GOTO9000
11088C
11089        ILAB(1)='POST'
11090        ILAB(2)='-CHA'
11091        ILAB(3)='NGE '
11092        ILAB(4)='FUNC'
11093        ILAB(5)='TION'
11094        ILAB(6)='  = '
11095        NUMWDL=6
11096        CALL DPPRIF(ILAB,NUMWDL,IFUNC3,N3,IBUGA3)
11097C
11098      ENDIF
11099C
11100C               *******************************************************
11101C               **  STEP 6.7--                                       **
11102C               **  MAKE A NON-CALCULATING PASS AT THE FUNCTION      **
11103C               **  SO AS TO EXTRACT ALL PARAMETER AND VARIABLE NAMES.*
11104C               *******************************************************
11105C
11106      ISTEPN='6.8'
11107      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NDER')
11108     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11109C
11110      IPASS=1
11111      IF(IFLGFB.LE.0)THEN
11112        CALL COMPIM(IFUNC3,N3,IPASS,PARAM,IPARN,IPARN2,NUMPV,
11113     1              IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,AJUNK,
11114     1              IBUGCO,IBUGEV,IERROR)
11115        IF(IERROR.EQ.'YES')GOTO9000
11116C
11117        IZNDEX=1
11118        DO6493I=1,NUMPV
11119          IF(IPARN(I).EQ.IZNAME .AND. IPARN2(I).EQ.IZNAM2)THEN
11120            IZNDEX=I
11121            GOTO6499
11122          ENDIF
11123 6493   CONTINUE
11124 6499   CONTINUE
11125      ELSE
11126        GOTO7650
11127      ENDIF
11128C
11129C               ***********************************************
11130C               **  STEP 7--                                 **
11131C               **  CHECK THAT ALL PARAMETERS                **
11132C               **  IN THE FUNCTION ARE ALREADY PRESENT      **
11133C               **  IN THE AVAILABLE NAME LIST IHNAME(.).    **
11134C               ***********************************************
11135C
11136      ISTEPN='7'
11137      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NDER')
11138     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11139C
11140      IP=0
11141      IV=0
11142      IF(NUMPV.LE.0)GOTO7650
11143      DO7600J=1,NUMPV
11144        IHPARN=IPARN(J)
11145        IHPAR2=IPARN2(J)
11146        IF(IHPARN.EQ.IDUMV(1).AND.IHPAR2.EQ.IDUMV2(1))THEN
11147          IV=IV+1
11148          LOCDUM=J
11149          GOTO7600
11150        ENDIF
11151        IHWUSE='P'
11152        MESSAG='YES'
11153        CALL CHECKN(IHPARN,IHPAR2,IHWUSE,
11154     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
11155     1              ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2)
11156        IF(IERRO2.EQ.'YES')THEN
11157C
11158          WRITE(ICOUT,999)
11159          CALL DPWRST('XXX','BUG ')
11160          WRITE(ICOUT,2201)
11161          CALL DPWRST('XXX','BUG ')
11162          WRITE(ICOUT,7612)
11163 7612     FORMAT('      A PARAMETER/FUNCTION HAS BEEN ENCOUNTERED')
11164          CALL DPWRST('XXX','BUG ')
11165          WRITE(ICOUT,7613)
11166 7613     FORMAT('      IN THE FUNCTION TO BE DIFFERENTIATED')
11167          CALL DPWRST('XXX','BUG ')
11168          WRITE(ICOUT,7614)
11169 7614     FORMAT('      WHICH HAS NOT YET BEEN DEFINED')
11170          CALL DPWRST('XXX','BUG ')
11171          WRITE(ICOUT,7615)
11172 7615     FORMAT('      THE UNKNOWN PARAMETER/FUNCTION = ',A4,A4)
11173          CALL DPWRST('XXX','BUG ')
11174          WRITE(ICOUT,3105)
11175          CALL DPWRST('XXX','BUG ')
11176          IF(IWIDTH.GE.1)THEN
11177            WRITE(ICOUT,3106)(IANS(I),I=1,MIN(100,IWIDTH))
11178            CALL DPWRST('XXX','BUG ')
11179          ENDIF
11180          IERROR='YES'
11181          GOTO9000
11182        ENDIF
11183C
11184        IP=IP+1
11185        PARAM(J)=VALUE(ILOCP)
11186 7600 CONTINUE
11187 7650 CONTINUE
11188C
11189C               ******************************
11190C               **  STEP 8--                **
11191C               **  COMPUTE THE DERIVATIVE  **
11192C               ******************************
11193C
11194      ISTEPN='8'
11195      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NDER')
11196     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11197C
11198      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NDER')THEN
11199        WRITE(ICOUT,999)
11200        CALL DPWRST('XXX','BUG ')
11201        WRITE(ICOUT,7711)
11202 7711   FORMAT('***** FROM DPNDER, IMMEDIATELY BEFORE CALLING ',
11203     1         'DPNDE2--')
11204        CALL DPWRST('XXX','BUG ')
11205        WRITE(ICOUT,7712)N3,NUMPV
11206 7712   FORMAT('N3,NUMPV = ',I8,I8)
11207        CALL DPWRST('XXX','BUG ')
11208        WRITE(ICOUT,7713)NUMDV,X0,XDER,NRIGHT
11209 7713   FORMAT('NUMDV,X0,XDER,NRIGHT = ',I8,2G15.7,I8)
11210        CALL DPWRST('XXX','BUG ')
11211        DO7714I=1,NUMDV
11212          WRITE(ICOUT,7715)I,IDUMV(I),IDUMV2(I)
11213 7715     FORMAT('I,IDUMV(I),IDUMV2(I) = ',I8,2X,A4,A4)
11214          CALL DPWRST('XXX','BUG ')
11215 7714   CONTINUE
11216        WRITE(ICOUT,7716)IBUGA3,IBUGCO,IBUGEV
11217 7716   FORMAT('IBUGA3,IBUGCO,IBUGEV = ',A4,2X,A4,2X,A4)
11218        CALL DPWRST('XXX','BUG ')
11219      ENDIF
11220C
11221C  COPY OVER DUMMY COMMON BLOCKS FOR DUMFUN ROUTINE
11222C
11223      DO7805KK=1,MAXF3
11224        ZMODEL(KK)=IFUNC3(KK)
11225 7805 CONTINUE
11226      DO7810KK=1,IDUMCH
11227        ZTYPEH(KK)=ITYPEH(KK)
11228        ZW21HO(KK)=IW21HO(KK)
11229        ZW22HO(KK)=IW22HO(KK)
11230        Z2HOLD(KK)=W2HOLD(KK)
11231 7810 CONTINUE
11232      DO7820KK=1,IDUMC2
11233        ZPARAM(KK)=PARAM(KK)
11234        ZIPARN(KK)=IPARN(KK)
11235        ZPARN2(KK)=IPARN2(KK)
11236        ZIDUMV(KK)=IDUMV(KK)
11237        ZDUMV2(KK)=IDUMV2(KK)
11238 7820 CONTINUE
11239      NUMCHZ=N3
11240      NUMPVZ=NUMPV
11241      NWHOLZ=NWHOLD
11242      NUMDVZ=NUMDV
11243      IBUGAZ=IBUGA3
11244C
11245      IHP='XMIN'
11246      IHP2='    '
11247      IHWUSE='P'
11248      MESSAG='NO'
11249      CALL CHECKN(IHP,IHP2,IHWUSE,
11250     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
11251     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
11252      IF(IERROR.EQ.'YES')THEN
11253        XMIN=CPUMIN
11254      ELSE
11255        XMIN=VALUE(ILOCP)
11256      ENDIF
11257C
11258      IHP='XMAX'
11259      IHP2='    '
11260      IHWUSE='P'
11261      MESSAG='NO'
11262      CALL CHECKN(IHP,IHP2,IHWUSE,
11263     1            IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
11264     1            ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
11265      IF(IERROR.EQ.'YES')THEN
11266        XMAX=CPUMAX
11267      ELSE
11268        XMAX=VALUE(ILOCP)
11269      ENDIF
11270C
11271      IHP='XERR'
11272      IHP2='OR  '
11273      IHWUSE='P'
11274      MESSAG='NO'
11275      CALL CHECKN(IHP,IHP2,IHWUSE,
11276     1            IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
11277     1            ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
11278      IF(IERROR.EQ.'YES')THEN
11279        XERROR=CPUMIN
11280      ELSE
11281        XERROR=VALUE(ILOCP)
11282      ENDIF
11283C
11284      DO7889I=1,MAXOBV
11285        YDER(I)=0.0
11286 7889 CONTINUE
11287C
11288      CALL DPNDE2(X0,XDER,XMIN,XMAX,XERROR,
11289     1            XFULL,YDER,NRIGHT,
11290     1            IBUGA3,IBUGCO,IBUGEV,ISUBRO,IERROR)
11291C
11292C               *****************************************************
11293C               **  STEP 9--                                       **
11294C               **  ENTER THE DERIVATIVE VALUE INTO THE DATAPLOT   **
11295C               **  HOUSEKEEPING ARRAY                             **
11296C               *****************************************************
11297C
11298      ISTEPN='9'
11299      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NDER')
11300     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11301C
11302      IHL=IHLEFT
11303      IHL2=IHLEF2
11304      ICASEL='P'
11305      IF(NRIGHT.GT.0)THEN
11306        ICASEL='V'
11307        XDER=YDER(1)
11308        IXDER=INT(XDER+0.5)
11309        CALL DPINVP(IHL,IHL2,ICASEL,YDER,NRIGHT,XDER,IXDER,
11310     1              ISUBN1,ISUBN2,IBUGA3,IERROR)
11311      ELSE
11312        ICASEL='P'
11313        IXDER=INT(XDER+0.5)
11314        BJUNK(1)=AJUNK
11315        NJUNK=1
11316        CALL DPINVP(IHL,IHL2,ICASEL,BJUNK,NJUNK,XDER,IXDER,
11317     1              ISUBN1,ISUBN2,IBUGA3,IERROR)
11318      ENDIF
11319C
11320C               ****************
11321C               **  STEP 90-- **
11322C               **  EXIT      **
11323C               ****************
11324C
11325 9000 CONTINUE
11326      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NDER')THEN
11327        WRITE(ICOUT,999)
11328        CALL DPWRST('XXX','BUG ')
11329        WRITE(ICOUT,9011)
11330 9011   FORMAT('***** AT THE END OF DPNDER--')
11331        CALL DPWRST('XXX','BUG ')
11332        DO9015I=1,NUMNAM
11333        WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),
11334     1                   IVSTAR(I),IVSTOP(I)
11335 9016   FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),IVSTOP(I)=',
11336     1         I8,2X,A4,A4,2X,A4,I8,I8)
11337        CALL DPWRST('XXX','BUG ')
11338 9015   CONTINUE
11339        WRITE(ICOUT,9017)NUMCHF,MAXCHF,IWIDTH,N2,N3,NUMPV
11340 9017   FORMAT('NUMCHF,MAXCHF,IWIDTH,N2,N3,NUMPV = ',6I8)
11341        CALL DPWRST('XXX','BUG ')
11342        WRITE(ICOUT,9018)(IFUNC(I),I=1,IWIDTH)
11343 9018   FORMAT('IFUNC(.) = ',115A1)
11344        CALL DPWRST('XXX','BUG ')
11345        WRITE(ICOUT,9019)(IFUNC2(I),I=1,N2)
11346 9019   FORMAT('IFUNC2(.) = ',115A1)
11347        CALL DPWRST('XXX','BUG ')
11348        WRITE(ICOUT,9021)(IFUNC3(I),I=1,N3)
11349 9021   FORMAT('IFUNC3(.) = ',115A1)
11350        CALL DPWRST('XXX','BUG ')
11351        WRITE(ICOUT,9023)IP,IV,IDUMV(1),IDUMV2(1),LOCDUM
11352 9023   FORMAT('IP,IV,IDUMV(1),IDUMV2(1),LOCDUM = ',I8,I8,2X,A4,A4,I8)
11353        CALL DPWRST('XXX','BUG ')
11354        WRITE(ICOUT,9024)IHLEFT,IHLEF2
11355 9024   FORMAT('IHLEFT,IHLEF2 = ',A4,A4)
11356        CALL DPWRST('XXX','BUG ')
11357        WRITE(ICOUT,9025)ICASEL,IFOUND,IERROR
11358 9025   FORMAT('ICASEL,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
11359        CALL DPWRST('XXX','BUG ')
11360        WRITE(ICOUT,9026)XMIN,XMAX,XDER
11361 9026   FORMAT('XMIN,XMAX,XDER = ',3G15.7)
11362        CALL DPWRST('XXX','BUG ')
11363      ENDIF
11364C
11365      RETURN
11366      END
11367      SUBROUTINE DPNDE2(X0,XDER,XMIN,XMAX,XERROR,
11368     1                  XFULL,YDER,N,
11369     1                  IBUGA3,IBUGCO,IBUGEV,ISUBRO,IERROR)
11370C
11371C     PURPOSE--COMPUTE THE DERIVATIVE OF A FUNCTION AT THE POINT X0.
11372C     WRITTEN BY--ALAN HECKERT
11373C                 STATISTICAL ENGINEERING DIVISION
11374C                 INFORMATION TECHNOLOGY LABORATORY
11375C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
11376C                 GAITHERSBURG, MD 20899-8980
11377C                 PHONE--301-975-2899
11378C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
11379C           OF THE NATIONAL BUREAU OF STANDARDS.
11380C     LANGUAGE--ANSI FORTRAN (1977)
11381C     VERSION NUMBER--2004/1
11382C     ORIGINAL VERSION--JANUARY   2004.
11383C     UPDATED         --SEPTEMBER 2015. SUPPORT FOR FUNCTION BLOCKS
11384C
11385C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
11386C
11387      CHARACTER*4 IBUGA3
11388      CHARACTER*4 IBUGCO
11389      CHARACTER*4 IBUGEV
11390      CHARACTER*4 ISUBRO
11391      CHARACTER*4 IERROR
11392C
11393      CHARACTER*4 ISUBN1
11394      CHARACTER*4 ISUBN2
11395C
11396C---------------------------------------------------------------------
11397C
11398      REAL XFULL(*)
11399      REAL YDER(*)
11400C
11401      REAL DUMFUN
11402      EXTERNAL DUMFUN
11403C
11404C---------------------------------------------------------------------
11405C
11406      INCLUDE 'DPCOP2.INC'
11407C
11408C-----START POINT-----------------------------------------------------
11409C
11410      ISUBN1='DPND'
11411      ISUBN2='E2  '
11412C
11413      IORD=1
11414      IF(XERROR.EQ.CPUMIN)THEN
11415        EPS=0.0001
11416      ELSE
11417        EPS=XERROR
11418      ENDIF
11419      ACCUR=0.0
11420      IFAIL=0
11421C
11422      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NDE2')THEN
11423        WRITE(ICOUT,999)
11424  999   FORMAT(1X)
11425        CALL DPWRST('XXX','BUG ')
11426        WRITE(ICOUT,51)
11427   51   FORMAT('***** AT THE BEGINNING OF DPNDE2--')
11428        CALL DPWRST('XXX','BUG ')
11429        WRITE(ICOUT,52)IBUGA3,IBUGCO,IBUGEV,ISUBRO
11430   52   FORMAT('IBUGA3,IBUGCO,IBUGEV,ISUBRO = ',3(A4,2X),A4)
11431        CALL DPWRST('XXX','BUG ')
11432        WRITE(ICOUT,62)X0,EPS,N
11433   62   FORMAT('X0,EPS,N = ',2G15.7,I9)
11434        CALL DPWRST('XXX','BUG ')
11435      ENDIF
11436C
11437C               ***************************************************
11438C               **  STEP 1--                                     **
11439C               **  CALL DIFF ROUTINE (FROM CMLIB) TO COMPUTE    **
11440C               **  THE DERIVATIVE.                              **
11441C               ***************************************************
11442C
11443      IF(N.LE.0)THEN
11444        CALL DIFF(IORD,X0,XMIN,XMAX,DUMFUN,EPS,ACCUR,XDER,ERROR,IFAIL)
11445C
11446        IF(IFAIL.EQ.1)THEN
11447          WRITE(ICOUT,999)
11448          CALL DPWRST('XXX','BUG ')
11449          WRITE(ICOUT,301)
11450  301     FORMAT('***** WARNING IN NUMERICAL DERIVATIVE--')
11451          CALL DPWRST('XXX','BUG ')
11452          WRITE(ICOUT,303)
11453  303     FORMAT('      THE ESTIMATED ERROR IN THE RESULT EXCEEDS THE')
11454          CALL DPWRST('XXX','BUG ')
11455          WRITE(ICOUT,305)
11456  305     FORMAT('      REQUESTED ERROR, BUT THE MOST ACCURATE RESULT')
11457          CALL DPWRST('XXX','BUG ')
11458          WRITE(ICOUT,307)
11459  307     FORMAT('      POSSIBLE HAS BEEN RETURNED.')
11460          CALL DPWRST('XXX','BUG ')
11461        ELSEIF(IFAIL.EQ.2)THEN
11462          WRITE(ICOUT,999)
11463          CALL DPWRST('XXX','BUG ')
11464          WRITE(ICOUT,311)
11465  311     FORMAT('***** ERROR IN NUMERICAL DERIVATIVE--')
11466          CALL DPWRST('XXX','BUG ')
11467          WRITE(ICOUT,313)
11468  313     FORMAT('      ERROR IN THE INPUT TO THE DIFF ROUTINE.')
11469          CALL DPWRST('XXX','BUG ')
11470          XDER=0.0
11471          ERROR=0.0
11472          IERROR='YES'
11473          GOTO9000
11474        ELSEIF(IFAIL.EQ.3)THEN
11475          WRITE(ICOUT,999)
11476          CALL DPWRST('XXX','BUG ')
11477          WRITE(ICOUT,321)
11478  321     FORMAT('***** ERROR IN NUMERICAL DERIVATIVE--')
11479          CALL DPWRST('XXX','BUG ')
11480          WRITE(ICOUT,323)
11481  323     FORMAT('      THE INTERVAL FOR DIFFERENTIATION, (',G15.7,
11482     1           ',',G15.7,')')
11483          CALL DPWRST('XXX','BUG ')
11484          WRITE(ICOUT,325)
11485  325     FORMAT('      IS TOO SMALL.')
11486          CALL DPWRST('XXX','BUG ')
11487          XDER=0.0
11488          ERROR=0.0
11489          IERROR='YES'
11490          GOTO9000
11491        ENDIF
11492      ELSE
11493        DO400I=1,N
11494          X0=XFULL(I)
11495          CALL DIFF(IORD,X0,XMIN,XMAX,DUMFUN,EPS,ACCUR,XDER,
11496     1              ERROR,IFAIL)
11497          YDER(I)=XDER
11498C
11499          IF(IFAIL.EQ.1)THEN
11500            WRITE(ICOUT,999)
11501            CALL DPWRST('XXX','BUG ')
11502            WRITE(ICOUT,401)X0
11503  401       FORMAT('***** WARNING IN NUMERICAL DERIVATIVE AT ',G15.7)
11504            CALL DPWRST('XXX','BUG ')
11505            WRITE(ICOUT,403)
11506  403       FORMAT('      THE ESTIMATED ERROR IN THE RESULT EXCEEDS ',
11507     1             'THE')
11508            CALL DPWRST('XXX','BUG ')
11509            WRITE(ICOUT,405)
11510  405       FORMAT('      REQUESTED ERROR, BUT THE MOST ACCURATE ',
11511     1             'RESULT')
11512            CALL DPWRST('XXX','BUG ')
11513            WRITE(ICOUT,407)
11514  407       FORMAT('      POSSIBLE HAS BEEN RETURNED.')
11515            CALL DPWRST('XXX','BUG ')
11516          ELSEIF(IFAIL.EQ.2)THEN
11517            WRITE(ICOUT,999)
11518            CALL DPWRST('XXX','BUG ')
11519            WRITE(ICOUT,411)X0
11520  411       FORMAT('***** ERROR IN NUMERICAL DERIVATIVE AT ',G15.7)
11521            CALL DPWRST('XXX','BUG ')
11522            WRITE(ICOUT,413)
11523  413       FORMAT('      ERROR IN THE INPUT TO THE DIFF ROUTINE.')
11524            CALL DPWRST('XXX','BUG ')
11525          ELSEIF(IFAIL.EQ.4)THEN
11526            WRITE(ICOUT,999)
11527            CALL DPWRST('XXX','BUG ')
11528            WRITE(ICOUT,421)X0
11529  421       FORMAT('***** ERROR IN NUMERICAL DERIVATIVE AT ',G15.7)
11530            CALL DPWRST('XXX','BUG ')
11531            WRITE(ICOUT,423)
11532  423       FORMAT('      THE INTERVAL FOR DIFFERENTIATION, (',G15.7,
11533     1           ',',G15.7,')')
11534            CALL DPWRST('XXX','BUG ')
11535            WRITE(ICOUT,425)
11536  425       FORMAT('      IS TOO SMALL.')
11537            CALL DPWRST('XXX','BUG ')
11538          ENDIF
11539  400   CONTINUE
11540      ENDIF
11541C
11542      IF(IFEEDB.EQ.'ON' .AND. N.LE.0)THEN
11543        WRITE(ICOUT,999)
11544        CALL DPWRST('XXX','BUG ')
11545        WRITE(ICOUT,3511)X0,XDER
11546 3511   FORMAT('AT X0 = ',G15.7,' THE DERIVATIVE VALUE  = ',G15.7)
11547        CALL DPWRST('XXX','BUG ')
11548        WRITE(ICOUT,3513)ERROR
11549 3513   FORMAT('(WITH ESTIMATED ERROR = ',G15.7,')')
11550        CALL DPWRST('XXX','BUG ')
11551        WRITE(ICOUT,999)
11552        CALL DPWRST('XXX','BUG ')
11553      ENDIF
11554C
11555C               *****************
11556C               **  STEP 90--  **
11557C               **  EXIT       **
11558C               *****************
11559C
11560 9000 CONTINUE
11561      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NDE2')THEN
11562        WRITE(ICOUT,999)
11563        CALL DPWRST('XXX','BUG ')
11564        WRITE(ICOUT,9011)
11565 9011   FORMAT('***** AT THE END       OF DPNDE2--')
11566        CALL DPWRST('XXX','BUG ')
11567        WRITE(ICOUT,9012)ERROR,XMIN,XMAX,X0,XDER
11568 9012   FORMAT('ERROR,XMIN,XMAX,X0,XDER = ',5G15.7)
11569        CALL DPWRST('XXX','BUG ')
11570        WRITE(ICOUT,9014)IERROR
11571 9014   FORMAT('IERROR = ',A4)
11572        CALL DPWRST('XXX','BUG ')
11573      ENDIF
11574C
11575      RETURN
11576      END
11577      SUBROUTINE DPNEGA(IHARG,NUMARG,INEGSW,IFOUND,IERROR)
11578C
11579C     PURPOSE--DEFINE THE NEGATIVE SWITCH INEGSW
11580C              (WHICH IS USEFUL, FOR EXAMPLE, IN GENERATING
11581C              HANGING HISTOGRAMS).
11582C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
11583C                     --NUMARG
11584C     OUTPUT ARGUMENTS--INEGSW  ('ON'  OR 'OFF')
11585C                     --IFOUND ('YES' OR 'NO' )
11586C                     --IERROR ('YES' OR 'NO' )
11587C     WRITTEN BY--JAMES J. FILLIBEN
11588C                 STATISTICAL ENGINEERING DIVISION
11589C                 INFORMATION TECHNOLOGY LABORATORY
11590C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
11591C                 GAITHERSBURG, MD 20899-8980
11592C                 PHONE--301-975-2855
11593C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
11594C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
11595C     LANGUAGE--ANSI FORTRAN (1977)
11596C     VERSION NUMBER--82/7
11597C     ORIGINAL VERSION--NOVEMBER  1978.
11598C     UPDATED         --SEPTEMBER 1980.
11599C     UPDATED         --MAY       1982.
11600C
11601C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
11602C
11603      CHARACTER*4 IHARG
11604      CHARACTER*4 INEGSW
11605      CHARACTER*4 IFOUND
11606      CHARACTER*4 IERROR
11607C
11608C---------------------------------------------------------------------
11609C
11610      DIMENSION IHARG(*)
11611C
11612C---------------------------------------------------------------------
11613C
11614      INCLUDE 'DPCOP2.INC'
11615C
11616C-----START POINT-----------------------------------------------------
11617C
11618      IFOUND='NO'
11619      IERROR='NO'
11620C
11621      IF(NUMARG.EQ.0)GOTO1150
11622      IF(NUMARG.GE.1)GOTO1110
11623      GOTO1199
11624C
11625 1110 CONTINUE
11626      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
11627      IF(IHARG(NUMARG).EQ.'OFF')GOTO1160
11628      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
11629      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1160
11630      GOTO1199
11631C
11632 1150 CONTINUE
11633      INEGSW='ON'
11634      GOTO1180
11635C
11636 1160 CONTINUE
11637      INEGSW='OFF'
11638      GOTO1180
11639C
11640 1180 CONTINUE
11641      IFOUND='YES'
11642C
11643      IF(IFEEDB.EQ.'OFF')GOTO1189
11644      WRITE(ICOUT,999)
11645  999 FORMAT(1X)
11646      CALL DPWRST('XXX','BUG ')
11647      WRITE(ICOUT,1181)INEGSW
11648 1181 FORMAT('THE NEGATIVE SWITCH HAS JUST BEEN TURNED ',
11649     1A4)
11650      CALL DPWRST('XXX','BUG ')
11651 1189 CONTINUE
11652      GOTO1199
11653C
11654 1199 CONTINUE
11655      RETURN
11656      END
11657      SUBROUTINE DPNEWS(IBUGS2,ISUBRO,IFOUND,IERROR)
11658C
11659C     PURPOSE--DISPLAY DATAPLOT NEWS
11660C     WRITTEN BY--JAMES J. FILLIBEN
11661C                 STATISTICAL ENGINEERING DIVISION
11662C                 INFORMATION TECHNOLOGY LABORATORY
11663C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
11664C                 GAITHERSBURG, MD 20899-8980
11665C                 PHONE--301-975-2855
11666C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
11667C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
11668C     LANGUAGE--ANSI FORTRAN (1977)
11669C     VERSION NUMBER--86/1
11670C     ORIGINAL VERSION--OCTOBER   1981.
11671C     UPDATED         --NOVEMBER  1981.
11672C     UPDATED         --MAY       1982.
11673C     UPDATED         --DECEMBER  1985.
11674C
11675C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
11676C
11677      CHARACTER*4 IBUGS2
11678      CHARACTER*4 ISUBRO
11679      CHARACTER*4 IFOUND
11680      CHARACTER*4 IERROR
11681C
11682      INCLUDE 'DPCOPA.INC'
11683C
11684CCCCC CHARACTER*80 IFILE
11685      CHARACTER (LEN=MAXFNC) :: IFILE
11686      CHARACTER*12 ISTAT
11687      CHARACTER*12 IFORM
11688      CHARACTER*12 IACCES
11689      CHARACTER*12 IPROT
11690      CHARACTER*12 ICURST
11691      CHARACTER*4 IENDFI
11692      CHARACTER*4 IREWIN
11693      CHARACTER*4 ISUBN0
11694      CHARACTER*4 IERRFI
11695C
11696      CHARACTER*4 ISUBN1
11697      CHARACTER*4 ISUBN2
11698      CHARACTER*4 ISTEPN
11699C
11700      CHARACTER*80 ISTRIN
11701C
11702C-----COMMON----------------------------------------------------------
11703C
11704      INCLUDE 'DPCOF2.INC'
11705      INCLUDE 'DPCOP2.INC'
11706C
11707C-----START POINT-----------------------------------------------------
11708C
11709      ISUBN1='DPNE'
11710      ISUBN2='WS  '
11711      IFOUND='YES'
11712      IERROR='NO'
11713C
11714      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'NEWS')THEN
11715        WRITE(ICOUT,999)
11716  999   FORMAT(1X)
11717        CALL DPWRST('XXX','BUG ')
11718        WRITE(ICOUT,51)
11719   51   FORMAT('***** AT THE BEGINNING OF DPNEWS--')
11720        CALL DPWRST('XXX','BUG ')
11721        WRITE(ICOUT,53)IBUGS2,ISUBRO,IERROR,INNEWNU
11722   53   FORMAT('IBUGS2,ISUBRO,IERROR,INEWNU = ',3(A4,2X),I5)
11723        CALL DPWRST('XXX','BUG ')
11724        WRITE(ICOUT,62)INEWNA(1:80)
11725   62   FORMAT('INEWNA = ',A80)
11726        CALL DPWRST('XXX','BUG ')
11727        WRITE(ICOUT,63)INEWST,INEWFO,INEWAC,INEWFO,INEWCS
11728   63   FORMAT('INEWST,INEWFO,INEWAC,INEWFO,INEWCS = ',4(A12,2X),A12)
11729        CALL DPWRST('XXX','BUG ')
11730      ENDIF
11731C
11732C               **************************
11733C               **  STEP 11--           **
11734C               **  COPY OVER VARIABLES **
11735C               **************************
11736C
11737      ISTEPN='11'
11738      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'NEWS')
11739     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11740C
11741      IOUNIT=INEWNU
11742      IFILE=INEWNA
11743      ISTAT=INEWST
11744      IFORM=INEWFO
11745      IACCES=INEWAC
11746      IPROT=INEWPR
11747      ICURST=INEWCS
11748C
11749      ISUBN0='NEWS'
11750      IERRFI='NO'
11751C
11752      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'NEWS')THEN
11753        WRITE(ICOUT,1193)ISUBN0,IERRFI,IOUNIT
11754 1193   FORMAT('ISUBN0,IERRFI,IOUNIT = ',2(A4,2X),I8)
11755        CALL DPWRST('XXX','BUG ')
11756        WRITE(ICOUT,1194)IFILE(1:80)
11757 1194   FORMAT('IFILE = ',A80)
11758        CALL DPWRST('XXX','BUG ')
11759        WRITE(ICOUT,1195)ISTAT,IFORM,IACCES,IPROT,ICURST
11760 1195   FORMAT('ISTAT,IFORM,IACCES,IPROT,ICURST = ',4(A12,2X),A12)
11761        CALL DPWRST('XXX','BUG ')
11762      ENDIF
11763C
11764C               ****************************************
11765C               **  STEP 12--                         **
11766C               **  CHECK TO SEE IF NEWS FILE EXISTS  **
11767C               ****************************************
11768C
11769      ISTEPN='12'
11770      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'NEWS')
11771     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11772C
11773      IF(ISTAT.EQ.'NONE')THEN
11774        IERROR='YES'
11775        WRITE(ICOUT,999)
11776        CALL DPWRST('XXX','BUG ')
11777        WRITE(ICOUT,1211)
11778 1211   FORMAT('***** ERROR IN DPNEWS--')
11779        CALL DPWRST('XXX','BUG ')
11780        WRITE(ICOUT,1212)
11781 1212   FORMAT('      THE DESIRED NEWS CANNOT BE GIVEN BECAUSE THE')
11782        CALL DPWRST('XXX','BUG ')
11783        WRITE(ICOUT,1214)
11784 1214   FORMAT('      REQUIRED SYSTEM MASS STORAGE FILE WHICH STORES ',
11785     1         'SUCH')
11786        CALL DPWRST('XXX','BUG ')
11787        WRITE(ICOUT,1216)
11788 1216   FORMAT('      NEWS IS NOT AVAILABLE AT THIS INSTALLATION.')
11789        CALL DPWRST('XXX','BUG ')
11790        WRITE(ICOUT,1217)ISTAT,INEWST
11791 1217   FORMAT('ISTAT,INEWST = ',A12,2X,A12)
11792        CALL DPWRST('XXX','BUG ')
11793        GOTO9000
11794      ENDIF
11795C
11796C               *********************
11797C               **  STEP 31--      **
11798C               **  OPEN THE FILE  **
11799C               *********************
11800C
11801      ISTEPN='31'
11802      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'NEWS')
11803     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11804C
11805      IREWIN='ON'
11806      CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
11807     1IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
11808      IF(IERRFI.EQ.'YES')GOTO9000
11809C
11810C               ******************************
11811C               **  STEP 41--               **
11812C               **  READ THE FILE.          **
11813C               **  WRITE OUT THE NEWS.     **
11814C               ******************************
11815C
11816      ISTEPN='41'
11817      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'MESS')
11818     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11819C
11820      ANUMLI=0.0
11821      READ(IOUNIT,4111,END=4190)ANUMLI
11822 4111 FORMAT(F10.0)
11823      NUMLIN=INT(ANUMLI+0.5)
11824C
11825      IF(NUMLIN.LE.0)GOTO4190
11826      DO4120I=1,NUMLIN
11827        READ(IOUNIT,4121,END=4190)(ISTRIN(J:J),J=1,80)
11828 4121   FORMAT(80A1)
11829        NMAX=80
11830        CALL DPDB80(ISTRIN,JMAX,NMAX,IBUGS2,ISUBRO,IERROR)
11831        IF(JMAX.GE.1)THEN
11832          WRITE(ICOUT,4122)(ISTRIN(J:J),J=1,JMAX)
11833 4122     FORMAT(5X,80A1)
11834          CALL DPWRST('XXX','BUG ')
11835        ELSE
11836          WRITE(ICOUT,999)
11837          CALL DPWRST('XXX','BUG ')
11838        ENDIF
11839 4120 CONTINUE
11840 4190 CONTINUE
11841C
11842C               ***********************
11843C               **  STEP 51--        **
11844C               **  CLOSE THE FILE.  **
11845C               ***********************
11846C
11847      ISTEPN='51'
11848      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'NEWS')
11849     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11850C
11851      IENDFI='OFF'
11852      IREWIN='ON'
11853      CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
11854     1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
11855C
11856C               ****************
11857C               **  STEP 90-- **
11858C               **  EXIT.     **
11859C               ****************
11860C
11861 9000 CONTINUE
11862      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'NEWS')THEN
11863        WRITE(ICOUT,999)
11864        CALL DPWRST('XXX','BUG ')
11865        WRITE(ICOUT,9011)
11866 9011   FORMAT('***** AT THE END       OF DPNEWS--')
11867        CALL DPWRST('XXX','BUG ')
11868        WRITE(ICOUT,9012)IERROR,IOUNIT
11869 9012   FORMAT('IERROR,IOUNIT = ',A4,2X,I8)
11870        CALL DPWRST('XXX','BUG ')
11871        WRITE(ICOUT,9022)IFILE(1:80)
11872 9022   FORMAT('IFILE  = ',A80)
11873        CALL DPWRST('XXX','BUG ')
11874        WRITE(ICOUT,9023)ISTAT,IFORM,IACCES,IPROT,ICURST
11875 9023   FORMAT('ISTAT,IFORM,IACCES,IPROT,ICURST  = ',4(A12,2X),A12)
11876        CALL DPWRST('XXX','BUG ')
11877        WRITE(ICOUT,9028)IENDFI,IREWIN,ISUBN0,IERRFI
11878 9028   FORMAT('IENDFI,IREWIN,ISUBN0,IERRFI = ',3(A4,2X),A4)
11879        CALL DPWRST('XXX','BUG ')
11880      ENDIF
11881C
11882      RETURN
11883      END
11884      SUBROUTINE DPNMI2(YA,NROW,NCOL,NCLUST,
11885     1                  WORK1,WORK2,WORK3,WORK4,IWORK,
11886     1                  IVARN1,IVARN2,RLAB,
11887     1                  ICAPTY,ICAPSW,IFORSW,
11888     1                  ISUBRO,IBUGA3,IERROR)
11889C
11890C     PURPOSE--PERFORM A NORMAL MIXTURE CLUSTER ANALYSIS USING HARTIGAN'S
11891C              CLUSTER ANALYSIS ROUTINE MIX.
11892C     REFERENCES--JOHN HARTIGAN (1975), "CLUSTERING ALGORITHMS",
11893C                 JOHN WILEY, PP. 113-129.
11894C     WRITTEN BY--ALAN HECKERT
11895C                 STATISTICAL ENGINEERING DIVISION
11896C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
11897C                 GAITHERSBURG, MD 20899-8980
11898C                 PHONE--301-975-2899
11899C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
11900C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
11901C     LANGUAGE--ANSI FORTRAN (1977)
11902C     VERSION NUMBER--2017/04
11903C     ORIGINAL VERSION--APRIL       2017.
11904C
11905C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
11906C
11907      DIMENSION YA(NROW,NCOL)
11908      DIMENSION WORK1(2*NROW+NCOL+1,*)
11909      DIMENSION WORK2(NCOL,NCOL+1,*)
11910      DIMENSION WORK3(NCOL,*)
11911      DIMENSION WORK4(*)
11912C
11913      INTEGER IWORK(*)
11914C
11915      CHARACTER*4 IVARN1(*)
11916      CHARACTER*4 IVARN2(*)
11917      CHARACTER*8 RLAB(*)
11918C
11919      CHARACTER*4 ICAPTY
11920      CHARACTER*4 ICAPSW
11921      CHARACTER*4 IFORSW
11922      CHARACTER*4 ISUBRO
11923      CHARACTER*4 IBUGA3
11924      CHARACTER*4 IERROR
11925C
11926      CHARACTER*4 IWRITE
11927      CHARACTER*4 ISUBN1
11928      CHARACTER*4 ISUBN2
11929      CHARACTER*4 ISTEPN
11930      CHARACTER*4 IOP
11931      CHARACTER*10 ITITLE
11932      CHARACTER*25 IFORMT
11933C
11934C-----COMMON----------------------------------------------------------
11935C
11936      INCLUDE 'DPCOST.INC'
11937      INCLUDE 'DPCOP2.INC'
11938C
11939C-----START POINT-----------------------------------------------------
11940C
11941      ISUBN1='DPNM'
11942      ISUBN2='I2  '
11943      IWRITE='OFF'
11944C
11945      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NMI2')THEN
11946        WRITE(ICOUT,999)
11947  999   FORMAT(1X)
11948        CALL DPWRST('XXX','BUG ')
11949        WRITE(ICOUT,70)
11950   70   FORMAT('AT THE BEGINNING OF DPNMI2--')
11951        CALL DPWRST('XXX','BUG ')
11952        WRITE(ICOUT,72)NROW,NCOL,NCLUST
11953   72   FORMAT('NROW,NCOL,NCLUST = ',3I8)
11954        CALL DPWRST('XXX','BUG ')
11955        DO75I=1,NROW
11956          WRITE(ICOUT,77)I,(YA(I,J),J=1,MIN(NCOL,3))
11957   77     FORMAT('I,YA(I,1),YA(I,2),YA(I,3) = ',I8,2X,3G15.7)
11958          CALL DPWRST('XXX','BUG ')
11959   75   CONTINUE
11960      ENDIF
11961C
11962C               ******************************
11963C               **   STEP 1A--              **
11964C               **   SCALE IF REQUESTED     **
11965C               ******************************
11966C
11967      ISTEPN='1'
11968      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NMI2')
11969     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11970C
11971      IF(INMCSC.EQ.'OFF')GOTO109
11972      DO101JJ=1,NCOL
11973        DO103II=1,NROW
11974          WORK4(II)=YA(II,JJ)
11975  103   CONTINUE
11976        IF(ISTALO.EQ.'MEAN')THEN
11977          CALL MEAN(WORK4,NROW,IWRITE,XMEAN,IBUGA3,IERROR)
11978        ELSEIF(ISTALO.EQ.'MEDI')THEN
11979          CALL MEDIAN(WORK4,NROW,IWRITE,WORK3,MAXNXT,XMEAN,
11980     1                IBUGA3,IERROR)
11981        ELSEIF(ISTALO.EQ.'MIDM')THEN
11982          CALL MIDMEA(WORK4,NROW,IWRITE,WORK3,MAXNXT,XMEAN,
11983     1                IBUGA3,IERROR)
11984        ELSEIF(ISTALO.EQ.'HARM')THEN
11985          CALL HARMEA(WORK4,NROW,IWRITE,XMEAN,IBUGA3,IERROR)
11986        ELSEIF(ISTALO.EQ.'MINI')THEN
11987          CALL MINIM(WORK4,NROW,IWRITE,XMEAN,IBUGA3,IERROR)
11988        ELSEIF(ISTALO.EQ.'GEOM')THEN
11989          CALL GEOMEA(WORK4,NROW,IWRITE,XMEAN,IBUGA3,IERROR)
11990        ELSEIF(ISTALO.EQ.'BILO')THEN
11991          CALL BIWLOC(WORK4,NROW,IWRITE,WORK2,WORK3,MAXNXT,XMEAN,
11992     1                IBUGA3,IERROR)
11993        ELSEIF(ISTALO.EQ.'H15 ')THEN
11994          NCUT=0
11995          C=1.5
11996          CALL H15(WORK4,NROW,C,NCUT,XMEAN,XSC,WORK2,WORK3,MAXNXT,
11997     1                IBUGA3,IERROR)
11998        ELSEIF(ISTALO.EQ.'H10 ')THEN
11999          NCUT=0
12000          C=1.0
12001          CALL H15(WORK4,NROW,C,NCUT,XMEAN,XSC,WORK2,WORK3,MAXNXT,
12002     1                IBUGA3,IERROR)
12003        ELSEIF(ISTALO.EQ.'H12 ')THEN
12004          NCUT=0
12005          C=1.2
12006          CALL H15(WORK4,NROW,C,NCUT,XMEAN,XSC,WORK2,WORK3,MAXNXT,
12007     1                IBUGA3,IERROR)
12008        ELSEIF(ISTALO.EQ.'H17 ')THEN
12009          NCUT=0
12010          C=1.7
12011          CALL H15(WORK4,NROW,C,NCUT,XMEAN,XSC,WORK2,WORK3,MAXNXT,
12012     1                IBUGA3,IERROR)
12013        ELSEIF(ISTALO.EQ.'H20 ')THEN
12014          NCUT=0
12015          C=2.0
12016          CALL H15(WORK4,NROW,C,NCUT,XMEAN,XSC,WORK2,WORK3,MAXNXT,
12017     1                IBUGA3,IERROR)
12018        ELSE
12019          CALL MEAN(WORK4,NROW,IWRITE,XMEAN,IBUGA3,IERROR)
12020        ENDIF
12021C
12022        IF(ISTASC.EQ.'SD  ')THEN
12023          CALL SD(WORK4,NROW,IWRITE,XSD,IBUGA3,IERROR)
12024        ELSEIF(ISTASC.EQ.'H15S')THEN
12025          NCUT=0
12026          C=1.5
12027          CALL H15(WORK4,NROW,C,NCUT,XLOC,XSD,WORK2,WORK3,MAXNXT,
12028     1                IBUGA3,IERROR)
12029        ELSEIF(ISTASC.EQ.'H10S')THEN
12030          NCUT=0
12031          C=1.0
12032          CALL H15(WORK4,NROW,C,NCUT,XLOC,XSD,WORK2,WORK3,MAXNXT,
12033     1                IBUGA3,IERROR)
12034        ELSEIF(ISTASC.EQ.'H12S')THEN
12035          NCUT=0
12036          C=1.2
12037          CALL H15(WORK4,NROW,C,NCUT,XLOC,XSD,WORK2,WORK3,MAXNXT,
12038     1                IBUGA3,IERROR)
12039        ELSEIF(ISTASC.EQ.'H17S')THEN
12040          NCUT=0
12041          C=1.7
12042          CALL H15(WORK4,NROW,C,NCUT,XLOC,XSD,WORK2,WORK3,MAXNXT,
12043     1                IBUGA3,IERROR)
12044        ELSEIF(ISTASC.EQ.'H20S')THEN
12045          NCUT=0
12046          C=2.0
12047          CALL H15(WORK4,NROW,C,NCUT,XLOC,XSD,WORK2,WORK3,MAXNXT,
12048     1                IBUGA3,IERROR)
12049        ELSEIF(ISTASC.EQ.'BISC')THEN
12050          CALL BIWSCA(WORK4,NROW,IWRITE,WORK2,WORK3,MAXNXT,XSD,
12051     1                IBUGA3,IERROR)
12052        ELSEIF(ISTASC.EQ.'MAD ')THEN
12053          CALL MAD(WORK4,NROW,IWRITE,WORK2,WORK3,MAXNXT,XSD,
12054     1             IBUGA3,IERROR)
12055        ELSEIF(ISTASC.EQ.'MADN')THEN
12056          CALL MAD(WORK4,NROW,IWRITE,WORK2,WORK3,MAXNXT,XSD,
12057     1             IBUGA3,IERROR)
12058          XSD=XSD/0.67449
12059        ELSEIF(ISTASC.EQ.'AAD ')THEN
12060          CALL AAD(WORK4,NROW,IWRITE,WORK3,MAXNXT,XSD,'MEAN',
12061     1             IBUGA3,IERROR)
12062        ELSEIF(ISTASC.EQ.'IQRA')THEN
12063          CALL LOWQUA(WORK4,NROW,IWRITE,WORK3,MAXNXT,RIGH1,
12064     1                IBUGA3,IERROR)
12065          CALL UPPQUA(WORK4,NROW,IWRITE,WORK3,MAXNXT,RIGH2,
12066     1                IBUGA3,IERROR)
12067          XSD=RIGH2-RIGH1
12068        ELSEIF(ISTASC.EQ.'NIQR')THEN
12069          CALL LOWQUA(WORK4,NROW,IWRITE,WORK3,MAXNXT,RIGH1,
12070     1                IBUGA3,IERROR)
12071          CALL UPPQUA(WORK4,NROW,IWRITE,WORK3,MAXNXT,RIGH2,
12072     1                IBUGA3,IERROR)
12073          XSD=0.7413*(RIGH2-RIGH1)
12074        ELSEIF(ISTASC.EQ.'SNSC')THEN
12075          XSD=SN(WORK4,NROW,WORK1,WORK2,WORK3)
12076        ELSEIF(ISTASC.EQ.'MAXI')THEN
12077          CALL MINIM(WORK4,NROW,IWRITE,XMIN,IBUGA3,IERROR)
12078          CALL MAXIM(WORK4,NROW,IWRITE,XMAX,IBUGA3,IERROR)
12079          XSD=XMAX - XMIN
12080        ELSE
12081          CALL SD(WORK4,NROW,IWRITE,XMEAN,IBUGA3,IERROR)
12082        ENDIF
12083C
12084        IF(XSD.LE.0.0)THEN
12085          WRITE(ICOUT,211)
12086          CALL DPWRST('XXX','BUG ')
12087          WRITE(ICOUT,106)JJ
12088  106     FORMAT('       VARIABLE ',I4,' HAS ZERO STANDARD DEVIATION ',
12089     1           'WHEN SCALING REQUESTED.')
12090          CALL DPWRST('XXX','BUG ')
12091          IERROR='YES'
12092          GOTO9000
12093        ENDIF
12094        DO105II=1,NROW
12095          AVAL=(YA(II,JJ)-XMEAN)/XSD
12096          YA(II,JJ)=AVAL
12097  105   CONTINUE
12098  101 CONTINUE
12099  109 CONTINUE
12100C
12101C               ************************************
12102C               **   STEP 2--                     **
12103C               **   PERFORM THE CLUSTER ANALYSIS **
12104C               ************************************
12105C
12106      ITER=50
12107      NCOV=1
12108      IFAULT=0
12109      IDMWRK=2*NROW + NCOL + 1
12110      IDMWR1=NCOL
12111      IDMWR2=NCOL+1
12112      IDMWR3=NCOL
12113C
12114      IF(INMCTI(1:4).EQ.'NULL')THEN
12115        ITITLE=' '
12116      ELSE
12117        ITITLE=INMCTI
12118      ENDIF
12119C
12120      CALL MIX(NROW,NROW,NCOL,YA,
12121     1         IVARN1,IVARN2,RLAB,ITITLE,NCLUST,ITER,NCOV,
12122     1         IDMWRK,WORK1,IDMWR1,IDMWR2,WORK2,IDMWR3,WORK3,IWORK,
12123     1         ICAPTY,ICAPSW,IFORSW,IFAULT)
12124C
12125      IF(IFAULT.GT.0)THEN
12126        WRITE(ICOUT,211)
12127  211   FORMAT('****** ERROR IN NORMAL MIXTURE CLUSTERING--')
12128        CALL DPWRST('XXX','BUG ')
12129        WRITE(ICOUT,213)IFAULT
12130  213   FORMAT('       THE ',I5,'-TH PIVOT BLOCK OF ONE OF THE ',
12131     1         'COVARIANCE')
12132        CALL DPWRST('XXX','BUG ')
12133        WRITE(ICOUT,215)
12134  215   FORMAT('       WAS SINGULAR AND THEREFORE AN INVERSE MATRIX ',
12135     1         'COULD NOT BE COMPUTED.')
12136        CALL DPWRST('XXX','BUG ')
12137        IERROR='YES'
12138        GOTO9000
12139      ENDIF
12140C
12141C               ************************************
12142C               **   STEP 3--                     **
12143C               **   WRITE INFORMATION TO FILES   **
12144C               ************************************
12145C
12146      ISTEPN='3'
12147      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NMI2')
12148     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12149C
12150      IOP='OPEN'
12151      IFLG11=1
12152      IFLG21=1
12153      IFLG31=1
12154      IFLAG4=0
12155      IFLAG5=0
12156      CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLAG4,IFLAG5,
12157     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
12158     1            IBUGA3,ISUBRO,IERROR)
12159      IF(IERROR.EQ.'YES')GOTO9000
12160C
12161C     POSITIONING IN THE WORK ARRAY DETERMINED FROM "COVOUT" ROUTINE
12162C
12163      IP=0
12164      IU=IP+NROW
12165      PMIX=IU+NCOL+1
12166      IT=INT(PMIX)
12167      MAXCLU=MIN(30,NCLUST)
12168C
12169C     CLUSTER MEANS
12170C
12171      IFORMT='(  F12.4,2X,2A4)'
12172      WRITE(IFORMT(2:3),'(I2)')MAXCLU
12173      DO8010J=1,NCOL
12174        WRITE(IOUNI2,IFORMT)(WORK1(IU+J,KK),KK=1,MAXCLU),
12175     1                      IVARN1(KK),IVARN2(KK)
12176 8010 CONTINUE
12177C
12178C     CLUSTER PROBABILITIES
12179C
12180      IFORMT='(  F12.6,2X,A8)'
12181      WRITE(IFORMT(2:3),'(I2)')MAXCLU
12182      DO8030I=1,NROW
12183        WRITE(IOUNI1,IFORMT)(WORK1(IP+I,KK),KK=1,NCLUST),RLAB(I)(1:8)
12184 8030 CONTINUE
12185C
12186C     WITHIN CLUSTER VARIANCES AND COVARIANCES
12187C
12188      IFORMT='(  F12.4,2X,2A4,2X,2A4)'
12189      WRITE(IFORMT(2:3),'(I2)')MAXCLU
12190      DO8020I=1,NCOL
12191        DO8025J=1,NCOL
12192          DO8027KK=1,NCLUST
12193            Z=WORK2(I,I,KK)*WORK2(J,J,KK)
12194            WORK1(KK,1)=WORK2(I,J,KK)
12195            IF(I.EQ.J)Z=0.
12196            IF(Z.NE.0.) WORK1(KK,1)=WORK2(I,J,KK)*Z**(-0.5)
12197 8027     CONTINUE
12198          WRITE(IOUNI3,IFORMT)(WORK1(KK,1),KK=1,NCLUST),
12199     1                        IVARN1(I),IVARN2(I),IVARN1(J),IVARN2(J)
12200 8025   CONTINUE
12201 8020 CONTINUE
12202C
12203      IOP='CLOS'
12204      CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLAG4,IFLAG5,
12205     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
12206     1            IBUGA3,ISUBRO,IERROR)
12207C
12208      IF(IFEEDB.EQ.'ON')THEN
12209        WRITE(ICOUT,999)
12210        CALL DPWRST('XXX','BUG ')
12211        WRITE(ICOUT,8091)
12212 8091   FORMAT('THE CLUSTER PROBABILITIES ARE WRITTEN TO dpst1f.dat')
12213        CALL DPWRST('XXX','BUG ')
12214        WRITE(ICOUT,8093)
12215 8093   FORMAT('THE CLUSTER MEANS ARE WRITTEN TO dpst2f.dat')
12216        CALL DPWRST('XXX','BUG ')
12217        WRITE(ICOUT,8097)
12218 8097   FORMAT('THE WITHIN-CLUSTER VARIANCES AND CORRELATIONS ARE ',
12219     1         'WRITTEN TO dpst3f.dat')
12220        CALL DPWRST('XXX','BUG ')
12221      ENDIF
12222C
12223C               ******************
12224C               **   STEP 90--  **
12225C               **   EXIT       **
12226C               ******************
12227C
12228 9000 CONTINUE
12229      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NMI2')THEN
12230        WRITE(ICOUT,999)
12231        CALL DPWRST('XXX','BUG ')
12232        WRITE(ICOUT,9011)
12233 9011   FORMAT('***** AT THE END       OF DPNMI2--')
12234        CALL DPWRST('XXX','BUG ')
12235      ENDIF
12236C
12237      RETURN
12238      END
12239      SUBROUTINE DPNMPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
12240     1                  IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
12241C
12242C     PURPOSE--GIVEN A LIST OF MEANS AND STANDARD DEVIATIONS, PLOT
12243C              A NORMAL KERNEL DENSITY MIXTURE FOR EACH LABORATORY
12244C              AND FOR THE MIXTURE OF ALL THE LABORATORIES.
12245C     REFERENCE--DUEWER (2008),"A COMPARISON OF LOCATION ESTIMATORS FOR
12246C                INTERLABORATORY DATA CONTAMINATED WITH VALUE AND
12247C                UNCERTAINTY OUTLIERS", ACCREDITED QUALITY ASSURANCE,
12248C                VOL. 13, PP. 193-216.
12249C     WRITTEN BY--ALAN HECKERT
12250C                 STATISTICAL ENGINEERING DIVISION
12251C                 INFORMATION TECHNOLOGY LABORATORY
12252C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
12253C                 GAITHERSBURG, MD 20899-8980
12254C                 PHONE--301-975-2855
12255C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
12256C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
12257C     LANGUAGE--ANSI FORTRAN (1977)
12258C     VERSION NUMBER--2017/07
12259C     ORIGINAL VERSION--JULY      2017 .
12260C
12261C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
12262C
12263      CHARACTER*4 ICASPL
12264      CHARACTER*4 IAND1
12265      CHARACTER*4 IAND2
12266      CHARACTER*4 IBUGG2
12267      CHARACTER*4 IBUGG3
12268      CHARACTER*4 IBUGQ
12269      CHARACTER*4 ISUBRO
12270      CHARACTER*4 IFOUND
12271      CHARACTER*4 IERROR
12272C
12273      CHARACTER*4 ISUBN1
12274      CHARACTER*4 ISUBN2
12275      CHARACTER*4 ISTEPN
12276      CHARACTER*4 ICASE
12277C
12278      CHARACTER*40 INAME
12279      PARAMETER (MAXSPN=20)
12280      CHARACTER*4 IVARN1(MAXSPN)
12281      CHARACTER*4 IVARN2(MAXSPN)
12282      CHARACTER*4 IVARTY(MAXSPN)
12283      REAL PVAR(MAXSPN)
12284      INTEGER ILIS(MAXSPN)
12285      INTEGER NRIGHT(MAXSPN)
12286      INTEGER ICOLR(MAXSPN)
12287C
12288C---------------------------------------------------------------------
12289C
12290      INCLUDE 'DPCOPA.INC'
12291      DIMENSION YMEAN(MAXOBV)
12292      DIMENSION YSD(MAXOBV)
12293      DIMENSION XTEMP(MAXOBV)
12294      DIMENSION YTEMP(MAXOBV)
12295C
12296      INCLUDE 'DPCOZZ.INC'
12297      EQUIVALENCE (GARBAG(IGARB1),YMEAN(1))
12298      EQUIVALENCE (GARBAG(IGARB2),YSD(1))
12299      EQUIVALENCE (GARBAG(IGARB3),XTEMP(1))
12300      EQUIVALENCE (GARBAG(IGARB4),YTEMP(1))
12301C
12302C-----COMMON----------------------------------------------------------
12303C
12304      INCLUDE 'DPCOHK.INC'
12305      INCLUDE 'DPCODA.INC'
12306      INCLUDE 'DPCOST.INC'
12307      INCLUDE 'DPCOP2.INC'
12308C
12309C-----START POINT-----------------------------------------------------
12310C
12311      ISUBN1='DPNM'
12312      ISUBN2='PL  '
12313      IFOUND='NO'
12314      IERROR='NO'
12315C
12316      MAXCP1=MAXCOL+1
12317      MAXCP2=MAXCOL+2
12318      MAXCP3=MAXCOL+3
12319      MAXCP4=MAXCOL+4
12320      MAXCP5=MAXCOL+5
12321      MAXCP6=MAXCOL+6
12322C
12323      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'NMPL')THEN
12324        WRITE(ICOUT,999)
12325  999   FORMAT(1X)
12326        CALL DPWRST('XXX','BUG ')
12327        WRITE(ICOUT,51)
12328   51   FORMAT('***** AT THE BEGINNING OF DPNMPL--')
12329        CALL DPWRST('XXX','BUG ')
12330        WRITE(ICOUT,53)ICASPL,IAND1,IAND2,IFOUND,IERROR
12331   53   FORMAT('ICASPL,IAND1,IAND2,IFOUND,IERROR = ',4(A4,2X),A4)
12332        CALL DPWRST('XXX','BUG ')
12333        WRITE(ICOUT,54)IANGLU,IBUGG2,IBUGG3,IBUGQ,ISUBRO
12334   54   FORMAT('IANGLU,IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',4(A4,2X),A4)
12335        CALL DPWRST('XXX','BUG ')
12336      ENDIF
12337C
12338C               *****************************************************
12339C               **  TREAT THE NORMAL KERNEL DENSITY MIXTURE   CASE **
12340C               *****************************************************
12341C
12342C               ***************************
12343C               **  STEP 11--            **
12344C               **  EXTRACT THE COMMAND  **
12345C               ***************************
12346C
12347      ISTEPN='11'
12348      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'NMPL')
12349     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12350C
12351      IF(ICOM.EQ.'NORM' .AND. IHARG(1).EQ.'KERN' .AND.
12352     1   IHARG(2).EQ.'DENS' .AND. IHARG(3).EQ.'MIXT' .AND.
12353     1   IHARG(4).EQ.'PLOT')THEN
12354          ILASTC=4
12355      ELSE
12356        GOTO9000
12357      ENDIF
12358C
12359      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
12360      IFOUND='YES'
12361      ICASPL='NMPL'
12362C
12363C               ****************************************
12364C               **  STEP 2--                          **
12365C               **  EXTRACT THE VARIABLE LIST         **
12366C               ****************************************
12367C
12368      ISTEPN='2'
12369      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'NMPL')
12370     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12371C
12372      INAME='NORMAL KERNEL DENSITY MIXTURE PLOT'
12373      MAXNA=100
12374      MINN2=2
12375      IFLAGE=1
12376      IFLAGM=0
12377      IFLAGP=0
12378      JMIN=1
12379      JMAX=NUMARG
12380      MINNA=2
12381      MINNVA=2
12382      MAXNVA=2
12383C
12384      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
12385     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
12386     1            JMIN,JMAX,
12387     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
12388     1            IVARN1,IVARN2,IVARTY,PVAR,
12389     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
12390     1            MINNVA,MAXNVA,
12391     1            IFLAGM,IFLAGP,
12392     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
12393      IF(IERROR.EQ.'YES')GOTO9000
12394C
12395      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'NMPL')THEN
12396        WRITE(ICOUT,999)
12397        CALL DPWRST('XXX','BUG ')
12398        WRITE(ICOUT,281)
12399  281   FORMAT('***** AFTER CALL DPPARS--')
12400        CALL DPWRST('XXX','BUG ')
12401        WRITE(ICOUT,282)NQ,NUMVAR
12402  282   FORMAT('NQ,NUMVAR = ',2I8)
12403        CALL DPWRST('XXX','BUG ')
12404        IF(NUMVAR.GT.0)THEN
12405          DO285I=1,NUMVAR
12406            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
12407     1                      ICOLR(I)
12408  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
12409     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
12410            CALL DPWRST('XXX','BUG ')
12411  285     CONTINUE
12412        ENDIF
12413      ENDIF
12414C
12415      NUMVA2=2
12416      ICOL=1
12417      CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
12418     1            INAME,IVARN1,IVARN2,IVARTY,
12419     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
12420     1            MAXCOL,MAXCP1,MAXCP2,MAXCP3,
12421     1            MAXCP4,MAXCP5,MAXCP6,
12422     1            V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
12423     1            YMEAN,YSD,YTEMP,NS1,NTEMP,NTEMP,ICASE,
12424     1            IBUGG3,ISUBRO,IFOUND,IERROR)
12425        IF(IERROR.EQ.'YES')GOTO9000
12426C
12427C               ****************************************************
12428C               **  STEP 41--                                      *
12429C               **  FORM THE VERTICAL AND HORIZONTAL AXIS          *
12430C               **  VARIABLES (Y(.) AND X(.), RESPECTIVELY) FOR    *
12431C               **   THE PLOT.                                     *
12432C               **  FORM THE CURVE DESIGNATION VARIABLE D(.)  .    *
12433C               **  THIS WILL BE BOTH ONES FOR BOTH CASES          *
12434C               **  DEFINE THE NUMBER OF PLOT POINTS    (NPLOTP).  *
12435C               **  DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV).  *
12436C               ****************************************************
12437C
12438      ISTEPN='41'
12439      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'NMPL')
12440     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12441C
12442      CALL DPNMP2(YMEAN,YSD,NS1,XTEMP,YTEMP,PNKDEF,
12443     1            Y,X,D,NPLOTP,NPLOTV,
12444     1            IBUGG3,ISUBRO,IERROR)
12445C
12446C               *****************
12447C               **  STEP 90--  **
12448C               **  EXIT       **
12449C               *****************
12450C
12451 9000 CONTINUE
12452      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'NMPL')THEN
12453        WRITE(ICOUT,999)
12454        CALL DPWRST('XXX','BUG ')
12455        WRITE(ICOUT,9011)
12456 9011   FORMAT('***** AT THE END       OF DPNMPL--')
12457        CALL DPWRST('XXX','BUG ')
12458        WRITE(ICOUT,9012)IFOUND,IERROR
12459 9012   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
12460        CALL DPWRST('XXX','BUG ')
12461        WRITE(ICOUT,9013)NPLOTV,NPLOTP,NUMVAR,NS,ICASPL,IAND1,IAND2
12462 9013   FORMAT('NPLOTV,NPLOTP,NUMVAR,NS,ICASPL,IAND1,IAND2 = ',
12463     1         4I8,2X,2(A4,2X),A4)
12464        CALL DPWRST('XXX','BUG ')
12465        IF(NPLOTP.GE.1)THEN
12466          DO9020I=1,NPLOTP
12467            WRITE(ICOUT,9021)I,Y(I),X(I),D(I)
12468 9021       FORMAT('I,Y(I),X(I),D(I) = ',I8,3G15.7)
12469            CALL DPWRST('XXX','BUG ')
12470 9020     CONTINUE
12471        ENDIF
12472      ENDIF
12473C
12474      RETURN
12475      END
12476      SUBROUTINE DPNMP2(YMEAN,YSD,N,XTEMP,YTEMP,PNKDEF,
12477     1                  Y2,X2,D2,NPLOTP,NPLOTV,
12478     1                  IBUGG3,ISUBRO,IERROR)
12479C
12480C     PURPOSE--GIVEN A LIST OF MEANS AND STANDARD DEVIATIONS, PLOT
12481C              A NORMAL KERNEL DENSITY MIXTURE FOR EACH LABORATORY
12482C              AND FOR THE MIXTURE OF ALL THE LABORATORIES.
12483C     REFERENCE--DUEWER (2008),"A COMPARISON OF LOCATION ESTIMATORS FOR
12484C                INTERLABORATORY DATA CONTAMINATED WITH VALUE AND
12485C                UNCERTAINTY OUTLIERS", ACCREDITED QUALITY ASSURANCE,
12486C                VOL. 13, PP. 193-216.
12487C     WRITTEN BY--ALAN HECKERT
12488C                 STATISTICAL ENGINEERING DIVISION
12489C                 INFORMATION TECHNOLOGY LABORATORY
12490C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
12491C                 GAITHERSBURG, MD 20899-8980
12492C                 PHONE--301-975-2899
12493C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
12494C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
12495C     LANGUAGE--ANSI FORTRAN (1977)
12496C     VERSION NUMBER--2017/07
12497C     ORIGINAL VERSION--JULY      2017.
12498C
12499C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
12500C
12501      CHARACTER*4 IBUGG3
12502      CHARACTER*4 ISUBRO
12503      CHARACTER*4 IERROR
12504C
12505      CHARACTER*4 ISUBN1
12506      CHARACTER*4 ISUBN2
12507      CHARACTER*4 ISTEPN
12508      CHARACTER*4 IWRITE
12509C
12510C---------------------------------------------------------------------
12511C
12512      DIMENSION YMEAN(*)
12513      DIMENSION YSD(*)
12514      DIMENSION XTEMP(*)
12515      DIMENSION YTEMP(*)
12516      DIMENSION Y2(*)
12517      DIMENSION X2(*)
12518      DIMENSION D2(*)
12519C
12520      DOUBLE PRECISION DVAL
12521      DOUBLE PRECISION DPDF
12522C
12523C---------------------------------------------------------------------
12524C
12525      INCLUDE 'DPCOP2.INC'
12526C
12527C-----START POINT-----------------------------------------------------
12528C
12529      ISUBN1='DPNM'
12530      ISUBN2='P2  '
12531      IERROR='NO'
12532      IWRITE='OFF'
12533C
12534      AFACT=1.0
12535C
12536      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NMP2')THEN
12537        WRITE(ICOUT,999)
12538  999   FORMAT(1X)
12539        CALL DPWRST('XXX','BUG ')
12540        WRITE(ICOUT,51)
12541   51   FORMAT('***** AT THE BEGINNING OF DPNMP2--')
12542        CALL DPWRST('XXX','BUG ')
12543        WRITE(ICOUT,52)IBUGG3,ISUBRO,N
12544   52   FORMAT('IBUGG3,ISUBRO,N = ',2(A4,2X),I8)
12545        CALL DPWRST('XXX','BUG ')
12546        DO61I=1,N
12547          WRITE(ICOUT,62)I,YMEAN(I),YSD(I)
12548   62     FORMAT('I,YMEAN(I),YSD(I) = ',I8,2G15.7)
12549          CALL DPWRST('XXX','BUG ')
12550   61   CONTINUE
12551      ENDIF
12552C
12553C               ********************************************
12554C               **  STEP 11--                             **
12555C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
12556C               ********************************************
12557C
12558      IF(N.LT.2)THEN
12559        WRITE(ICOUT,999)
12560        CALL DPWRST('XXX','BUG ')
12561        WRITE(ICOUT,101)
12562  101   FORMAT('***** ERROR IN NORMAL KERNEL DENSITY MIXTURE PLOT--')
12563        CALL DPWRST('XXX','BUG ')
12564        WRITE(ICOUT,102)
12565  102   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 2.')
12566        CALL DPWRST('XXX','BUG ')
12567        WRITE(ICOUT,104)N
12568  104   FORMAT('      THE NUMBER OF OBSERVATIONS = ',I6)
12569        CALL DPWRST('XXX','BUG ')
12570        IERROR='YES'
12571        GOTO9000
12572      ENDIF
12573C
12574      DO110I=1,N
12575        IF(YSD(I).LE.0.0)THEN
12576          WRITE(ICOUT,999)
12577          CALL DPWRST('XXX','BUG ')
12578          WRITE(ICOUT,101)
12579          CALL DPWRST('XXX','BUG ')
12580          WRITE(ICOUT,115)I
12581  115     FORMAT('      ROW ',I8,' HAS A NON-POSITIVE STANDARD ',
12582     1           'DEVIATION.')
12583          CALL DPWRST('XXX','BUG ')
12584          WRITE(ICOUT,116)YSD(I)
12585  116     FORMAT('      THE STANDARD DEVIATION IS ',G15.7)
12586          CALL DPWRST('XXX','BUG ')
12587          IERROR='YES'
12588          GOTO9000
12589        ENDIF
12590  110 CONTINUE
12591C
12592C               ****************************************************
12593C               **  STEP 21--PLOT THE MEANS AS TRACE 1            **
12594C               ****************************************************
12595C
12596      ISTEPN='21'
12597      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NMP2')
12598     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12599C
12600      ITAG=1
12601      NPLOTP=0
12602      DO210I=1,N
12603        NPLOTP=NPLOTP+1
12604        X2(NPLOTP)=YMEAN(I)
12605        Y2(NPLOTP)=REAL(I)
12606        D2(NPLOTP)=REAL(ITAG)
12607  210 CONTINUE
12608C
12609C               ****************************************************
12610C               **  STEP 22--PLOT THE COMBINED DENSITY CURVE      **
12611C               **           AS TRACE 2                           **
12612C               ****************************************************
12613C
12614      ISTEPN='22'
12615      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NMP2')
12616     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12617C
12618      CALL DPMMPD(YMEAN,YSD,N,
12619     1            YTEMP,XTEMP,NTEMP,
12620     1            IBUGG3,ISUBRO,IERROR)
12621C
12622C     IF MAXIMUM VALUE IS < 2.8, SCALE MAXIMUM VALUE TO 1 FOR BETTER
12623C     VISUAL RESOLUTION.
12624C
12625      AMAX=YTEMP(1)
12626      DO220I=2,NTEMP
12627        IF(YTEMP(I).GT.AMAX)AMAX=YTEMP(I)
12628  220 CONTINUE
12629      IF(AMAX.LT.2.8)THEN
12630        AFACT=3.0/AMAX
12631      ENDIF
12632C
12633      ITAG=ITAG+1
12634      DO225I=1,NTEMP
12635        NPLOTP=NPLOTP+1
12636        X2(NPLOTP)=XTEMP(I)
12637        Y2(NPLOTP)=AFACT*YTEMP(I) + REAL(N+1)
12638        D2(NPLOTP)=REAL(ITAG)
12639  225 CONTINUE
12640C
12641C               ****************************************************
12642C               **  STEP 23--NOW GENERATE THE CURVES FOR THE      **
12643C               **           INDIVIDUAL LABS                      **
12644C               ****************************************************
12645C
12646      ISTEPN='23'
12647      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NMP2')
12648     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12649C
12650      NGRID=100
12651      DO230I=1,N
12652C
12653        XLOW=YMEAN(I) - 2.0*YSD(I)
12654        XUPP=YMEAN(I) + 2.0*YSD(I)
12655        ALOW=YMEAN(I) - 3.0*YSD(I)
12656        AUPP=YMEAN(I) + 3.0*YSD(I)
12657C
12658        AINC=(AUPP - ALOW)/REAL(NGRID)
12659C
12660C       POINTS FOR DENSITY CURVE FIRST
12661C
12662        ITAG=ITAG+1
12663        AVAL=ALOW
12664        DO240J=1,NGRID
12665          NPLOTP=NPLOTP+1
12666          X2(NPLOTP)=AVAL
12667          DVAL=DBLE((AVAL - YMEAN(I))/YSD(I))
12668          CALL NODPDF(DVAL,DPDF)
12669          AVAL2=REAL(DPDF/DBLE(YSD(I)))
12670          AVAL2=PNKDEF*AVAL2
12671          Y2(NPLOTP)=AVAL2 + REAL(I)
12672          D2(NPLOTP)=REAL(ITAG)
12673          AVAL=AVAL+AINC
12674  240   CONTINUE
12675C
12676C       POINTS FOR +/- 2*SD
12677C
12678        ITAG=ITAG+1
12679        NPLOTP=NPLOTP+1
12680        X2(NPLOTP)=XLOW
12681        Y2(NPLOTP)=REAL(I)
12682        D2(NPLOTP)=REAL(ITAG)
12683        NPLOTP=NPLOTP+1
12684        X2(NPLOTP)=XUPP
12685        Y2(NPLOTP)=REAL(I)
12686        D2(NPLOTP)=REAL(ITAG)
12687C
12688  230 CONTINUE
12689C
12690      NPLOTV=3
12691C
12692C               *****************
12693C               **  STEP 90--  **
12694C               **  EXIT       **
12695C               *****************
12696C
12697 9000 CONTINUE
12698      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'NMP2')THEN
12699        WRITE(ICOUT,999)
12700        CALL DPWRST('XXX','BUG ')
12701        WRITE(ICOUT,9011)
12702 9011   FORMAT('***** AT THE END       OF DPNMP2--')
12703        CALL DPWRST('XXX','BUG ')
12704        WRITE(ICOUT,9012)IERROR,NPLOTP
12705 9012   FORMAT('IERROR,NPLOTP = ',A4,2X,I8)
12706        CALL DPWRST('XXX','BUG ')
12707        DO9015I=1,NPLOTP
12708          WRITE(ICOUT,9016)I,Y2(I),X2(I),D2(I)
12709 9016     FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2G15.7,F7.1)
12710          CALL DPWRST('XXX','BUG ')
12711 9015   CONTINUE
12712      ENDIF
12713C
12714      RETURN
12715      END
12716      SUBROUTINE DPNORM(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
12717     1                  IANGLU,MAXNPP,
12718     1                  IX1TSC,IX2TSC,IY1TSC,IY2TSC,
12719     1                  IX1TSV,IX2TSV,IY1TSV,IY2TSV,
12720     1                  IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
12721C
12722C     PURPOSE--FORM A NORMAL PLOT (= A NORMAL PROBABILITY PLOT
12723C              BUT WITH DATA ON HORIZONTAL AXIS AND WITH NEAT
12724C              PROBABILITY VALUES ON THE VERTICAL AXIS).
12725C     EXAMPLE--NORMAL PLOT Y
12726C              NORMAL PLOT Y TAG
12727C     NOTE--TYPICALLY THIS COMMAND HAS 1 ARGUMENT WHERE ARGUMENT 1 IS
12728C           THE RESPONSE VARIABLE.  IF THERE IS ONLY ONE ARGUMENT, THIS
12729C           IS THE NO CENSORING CASE (I.E., ALL THE DATA IS INCLUDED).
12730C           IF THERE IS A SECOND ARGUMENT, THIS IS THE CENSORING
12731C           VARIABLE.
12732C     WRITTEN BY--JAMES J. FILLIBEN
12733C                 STATISTICAL ENGINEERING DIVISION
12734C                 INFORMATION TECHNOLOGY LABORATORY
12735C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
12736C                 GAITHERSBURG, MD 20899-8980
12737C                 PHONE--301-975-2855
12738C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
12739C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
12740C     LANGUAGE--ANSI FORTRAN (1977)
12741C     VERSION NUMBER--90/6
12742C     ORIGINAL VERSION--MAY       1990.
12743C     UPDATED         --APRIL     1992. DEFINE CUTOFF (ALAN)
12744C     UPDATED         --APRIL     1992. SPLIT 'SIGMA'
12745C     UPDATED         --APRIL     1992. COMMENT OUT IHRI3./4.
12746C     UPDATED         --MAY       1995. ADD LINE TO EQUIVALENCE
12747C     UPDATED         --FEBRUARY  2011. USE DPPARS, DPPAR3
12748C     UPDATED         --FEBRUARY  2011. SUPPORT FOR "HIGHLIGHTED" OPTION
12749C     UPDATED         --JULY      2014. OPTION TO REVERSE X AND Y AXES
12750C
12751C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
12752C
12753      CHARACTER*4 ICASPL
12754      CHARACTER*4 IAND1
12755      CHARACTER*4 IAND2
12756C
12757      CHARACTER*4 IX1TSC
12758      CHARACTER*4 IX2TSC
12759      CHARACTER*4 IY1TSC
12760      CHARACTER*4 IY2TSC
12761C
12762      CHARACTER*4 IX1TSV
12763      CHARACTER*4 IX2TSV
12764      CHARACTER*4 IY1TSV
12765      CHARACTER*4 IY2TSV
12766C
12767      CHARACTER*4 IANGLU
12768      CHARACTER*4 IBUGG2
12769      CHARACTER*4 IBUGG3
12770      CHARACTER*4 IBUGQ
12771      CHARACTER*4 ISUBRO
12772      CHARACTER*4 IFOUND
12773      CHARACTER*4 IERROR
12774C
12775      CHARACTER*4 ICASE
12776      CHARACTER*4 IHIGH
12777      CHARACTER*4 IH
12778      CHARACTER*4 IH2
12779      CHARACTER*4 ISUBN1
12780      CHARACTER*4 ISUBN2
12781      CHARACTER*4 ISTEPN
12782C
12783      PARAMETER (MAXSPN=10)
12784      CHARACTER*4 IVARN1(MAXSPN)
12785      CHARACTER*4 IVARN2(MAXSPN)
12786      CHARACTER*4 IVARTY(MAXSPN)
12787      REAL PVAR(MAXSPN)
12788      INTEGER ILIS(MAXSPN)
12789      INTEGER NRIGHT(MAXSPN)
12790      INTEGER ICOLR(MAXSPN)
12791      CHARACTER*40 INAME
12792C
12793C---------------------------------------------------------------------
12794C
12795      INCLUDE 'DPCOPA.INC'
12796      INCLUDE 'DPCOHO.INC'
12797      INCLUDE 'DPCOZZ.INC'
12798      INCLUDE 'DPCOZI.INC'
12799C
12800      DIMENSION Y1(MAXOBV)
12801      DIMENSION Y2(MAXOBV)
12802      DIMENSION YS(MAXOBV)
12803      DIMENSION TAGC2(MAXOBV)
12804      DIMENSION ITAGC2(MAXOBV)
12805      DIMENSION WAR(MAXOBV)
12806      DIMENSION WMR(MAXOBV)
12807      DIMENSION WMRT(MAXOBV)
12808      DIMENSION YST(MAXOBV)
12809      DIMENSION XHIGH(MAXOBV)
12810      DIMENSION XDIST(MAXOBV)
12811      EQUIVALENCE (GARBAG(IGARB1),Y1(1))
12812      EQUIVALENCE (GARBAG(IGARB2),Y2(1))
12813      EQUIVALENCE (GARBAG(IGARB3),YS(1))
12814      EQUIVALENCE (GARBAG(IGARB4),TAGC2(1))
12815      EQUIVALENCE (GARBAG(IGARB5),YST(1))
12816      EQUIVALENCE (GARBAG(IGARB6),WAR(1))
12817      EQUIVALENCE (GARBAG(IGARB7),WMRT(1))
12818      EQUIVALENCE (GARBAG(IGARB8),WMR(1))
12819      EQUIVALENCE (GARBAG(IGARB9),XHIGH(1))
12820      EQUIVALENCE (GARBAG(IGAR10),XDIST(1))
12821      EQUIVALENCE (IGARBG(IIGAR1),ITAGC2(1))
12822C
12823C-----COMMON----------------------------------------------------------
12824C
12825      INCLUDE 'DPCOST.INC'
12826      INCLUDE 'DPCOHK.INC'
12827      INCLUDE 'DPCODA.INC'
12828      INCLUDE 'DPCOP2.INC'
12829C
12830C-----START POINT-----------------------------------------------------
12831C
12832      ISUBN1='DPNO'
12833      ISUBN2='RM  '
12834      IFOUND='NO'
12835      IERROR='NO'
12836C
12837      MAXCP1=MAXCOL+1
12838      MAXCP2=MAXCOL+2
12839      MAXCP3=MAXCOL+3
12840      MAXCP4=MAXCOL+4
12841      MAXCP5=MAXCOL+5
12842      MAXCP6=MAXCOL+6
12843C
12844      SIGMA=(-999.0)
12845      AMU=(-999.0)
12846      SDSIGM=(-999.0)
12847      SDAMU=(-999.0)
12848      BPT1=(-999.0)
12849      BPT5=(-999.0)
12850      B1=(-999.0)
12851      B5=(-999.0)
12852      B10=(-999.0)
12853      B20=(-999.0)
12854      B50=(-999.0)
12855      B80=(-999.0)
12856      B90=(-999.0)
12857      B95=(-999.0)
12858      B99=(-999.0)
12859      B995=(-999.0)
12860      B999=(-999.0)
12861      IVAL=0
12862C
12863CCCCC THE FOLLOWING 4 LINES WERE ADDED   APRIL 1992
12864      ICUTMX=NUMBPW
12865      IF(IHOST1.EQ.'CDC '.OR.IHOST1.EQ.'CYBE')ICUTMX=48
12866      IF(IHOST1.EQ.'205 ')ICUTMX=48
12867      CUTOFF=2**(ICUTMX-3)
12868C
12869      IF(IBUGG2.EQ.'ON'. OR. ISUBRO.EQ.'NORM')THEN
12870        WRITE(ICOUT,999)
12871  999   FORMAT(1X)
12872        CALL DPWRST('XXX','BUG ')
12873        WRITE(ICOUT,51)
12874   51   FORMAT('***** AT THE BEGINNING OF DPNORM--')
12875        CALL DPWRST('XXX','BUG ')
12876        WRITE(ICOUT,53)ICASPL,IAND1,IAND2
12877   53   FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4)
12878        CALL DPWRST('XXX','BUG ')
12879        WRITE(ICOUT,54)IANGLU,IBUGG2,IBUGG3,IBUGQ
12880   54   FORMAT('IANGLU,IBUGG2,IBUGG3,IBUGQ = ',
12881     1         A4,2X,A4,2X,A4,2X,A4)
12882        CALL DPWRST('XXX','BUG ')
12883        WRITE(ICOUT,56)ICASPL,MAXN,MAXNPP
12884   56   FORMAT('ICASPL,MAXN,MAXNPP = ',A4,2I8)
12885        CALL DPWRST('XXX','BUG ')
12886        WRITE(ICOUT,57)IFOUND,IERROR
12887   57   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
12888        CALL DPWRST('XXX','BUG ')
12889        WRITE(ICOUT,61)IX1TSC,IX2TSC,IY1TSC,IY2TSC
12890   61   FORMAT('IX1TSC,IX2TSC,IY1TSC,IY2TSC = ',A4,2X,A4,2X,A4,2X,A4)
12891        CALL DPWRST('XXX','BUG ')
12892        WRITE(ICOUT,62)IX1TSV,IX2TSV,IY1TSV,IY2TSV
12893   62   FORMAT('IX1TSV,IX2TSV,IY1TSV,IY2TSV = ',A4,2X,A4,2X,A4,2X,A4)
12894        CALL DPWRST('XXX','BUG ')
12895      ENDIF
12896C
12897C               ***************************
12898C               **  STEP 11--            **
12899C               **  EXTRACT THE COMMAND  **
12900C               ***************************
12901C
12902      ISTEPN='11'
12903      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'NORM')
12904     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12905C
12906      IFOUND='NO'
12907      IHIGH='OFF'
12908      IF(ICOM.EQ.'NORM')THEN
12909        IF(IHARG(1).EQ.'HIGH' .AND. IHARG(2).EQ.'PLOT')THEN
12910          ILASTC=2
12911          IFOUND='YES'
12912          IHIGH='ON'
12913        ELSEIF(IHARG(1).EQ.'PLOT')THEN
12914          ILASTC=1
12915          IFOUND='YES'
12916        ENDIF
12917      ELSEIF(ICOM.EQ.'HIGH' .OR. ICOM.EQ.'SUBS')THEN
12918        IF(IHARG(1).EQ.'NORM' .AND. IHARG(2).EQ.'PLOT')THEN
12919          ILASTC=2
12920          IFOUND='YES'
12921          IHIGH='ON'
12922        ENDIF
12923      ENDIF
12924C
12925      IF(IFOUND.EQ.'NO')GOTO9000
12926C
12927      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
12928      ICASPL='NORM'
12929C
12930C               ****************************************
12931C               **  STEP 2--                          **
12932C               **  EXTRACT THE VARIABLE LIST         **
12933C               ****************************************
12934C
12935      ISTEPN='2'
12936      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'NORM')
12937     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12938C
12939      INAME='NORM PLOT'
12940      MINNA=1
12941      MAXNA=100
12942CCCCC MINN2=2
12943      MINN2=1
12944      IFLAGE=1
12945      IFLAGM=1
12946      IFLAGP=0
12947      JMIN=1
12948      JMAX=NUMARG
12949      MINNVA=1
12950      MAXNVA=2
12951      IF(IHIGH.EQ.'ON')THEN
12952        MINNVA=2
12953        MAXNVA=3
12954      ENDIF
12955C
12956      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
12957     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
12958     1            JMIN,JMAX,
12959     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
12960     1            IVARN1,IVARN2,IVARTY,PVAR,
12961     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
12962     1            MINNVA,MAXNVA,
12963     1            IFLAGM,IFLAGP,
12964     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
12965      IF(IERROR.EQ.'YES')GOTO9000
12966C
12967      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'NORM')THEN
12968        WRITE(ICOUT,999)
12969        CALL DPWRST('XXX','BUG ')
12970        WRITE(ICOUT,281)
12971  281   FORMAT('***** AFTER CALL DPPARS--')
12972        CALL DPWRST('XXX','BUG ')
12973        WRITE(ICOUT,282)NQ,NUMVAR
12974  282   FORMAT('NQ,NUMVAR = ',2I8)
12975        CALL DPWRST('XXX','BUG ')
12976        IF(NUMVAR.GT.0)THEN
12977          DO285I=1,NUMVAR
12978            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
12979     1                      ICOLR(I)
12980  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
12981     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
12982            CALL DPWRST('XXX','BUG ')
12983  285     CONTINUE
12984        ENDIF
12985      ENDIF
12986C
12987      DO290I=1,NRIGHT(1)
12988        Y2(I)=1.0
12989        XHIGH(I)=1.0
12990  290 CONTINUE
12991      ICOL=1
12992      CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
12993     1            INAME,IVARN1,IVARN2,IVARTY,
12994     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
12995     1            MAXCOL,MAXCP1,MAXCP2,MAXCP3,
12996     1            MAXCP4,MAXCP5,MAXCP6,
12997     1            V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
12998     1            Y1,Y2,XHIGH,NS,NLOCA2,NLOCA3,ICASE,
12999     1            IBUGG3,ISUBRO,IFOUND,IERROR)
13000      IF(IERROR.EQ.'YES')GOTO9000
13001C
13002      IF(IHIGH.EQ.'ON' .AND. NUMVAR.EQ.2)THEN
13003        DO299I=1,NS
13004          XHIGH(I)=Y2(I)
13005          Y2(I)=1.0
13006  299   CONTINUE
13007      ENDIF
13008C
13009C               *********************************************
13010C               **  STEP 34--                              **
13011C               **  CHECK TO MAKE SURE THAT THE            **
13012C               **  COMBINATION OF CENSORING AND           **
13013C               **  SUBSETTING DOES NOT RESULT IN TOO FEW  **
13014C               **  DATA POINTS RESULTING (AT LEAST TWO)   **
13015C               **  WITH WHICH TO FORM A NORMAL PLOT.      **
13016C               *********************************************
13017C
13018      ISTEPN='34'
13019      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'NORM')
13020     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
13021C
13022      ICOUNT=0
13023      DO3400I=1,NS
13024        IF(Y2(I).LE.-0.000001.OR.Y2(I).GE.0.0001)ICOUNT=ICOUNT+1
13025 3400 CONTINUE
13026C
13027      IF(ICOUNT.LT.MINN2)THEN
13028        WRITE(ICOUT,999)
13029        CALL DPWRST('XXX','BUG ')
13030        WRITE(ICOUT,3451)
13031 3451   FORMAT('***** ERROR IN NORMAL PLOT--')
13032        CALL DPWRST('XXX','BUG ')
13033        WRITE(ICOUT,3452)
13034 3452   FORMAT('      AFTER THE SPECIFIED CENSORING AND SUBSETTING ',
13035     1         'HAS BEEN DONE,')
13036        CALL DPWRST('XXX','BUG ')
13037        WRITE(ICOUT,3454)IVARN1(1),IVARN2(1)
13038 3454   FORMAT('      THE NUMBER OF OBSERVATIONS REMAINING FROM ',
13039     1         'VARIABLE ',A4,A4)
13040        CALL DPWRST('XXX','BUG ')
13041        WRITE(ICOUT,3455)
13042 3455   FORMAT('      (FOR WHICH A NORMAL PLOT IS TO BE FORMED)')
13043        CALL DPWRST('XXX','BUG ')
13044        WRITE(ICOUT,3457)MINN2
13045 3457   FORMAT('      MUST BE ',I8,' OR LARGER;')
13046        CALL DPWRST('XXX','BUG ')
13047        WRITE(ICOUT,3458)ICOUNT
13048 3458   FORMAT('      SUCH WAS NOT THE CASE HERE (ICOUNT = ',I8,')')
13049        CALL DPWRST('XXX','BUG ')
13050        WRITE(ICOUT,3459)
13051 3459   FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
13052        CALL DPWRST('XXX','BUG ')
13053        IF(IWIDTH.GE.1)THEN
13054          WRITE(ICOUT,3460)(IANS(I),I=1,MIN(80,IWIDTH))
13055 3460     FORMAT('      ',80A1)
13056          CALL DPWRST('XXX','BUG ')
13057        ENDIF
13058        IERROR='YES'
13059        GOTO9000
13060C
13061      ENDIF
13062C
13063C               ****************************************************************
13064C               **  STEP 41--                                                  *
13065C               **  FORM THE VERTICAL AND HORIZONTAL AXIS                      *
13066C               **  VARIABLES (Y(.) AND X(.), RESPECTIVELY) FOR THE PLOT.      *
13067C               **  FORM THE CURVE DESIGNATION VARIABLE D(.)  .                *
13068C               **  THIS WILL BE BOTH ONES FOR BOTH CASES                      *
13069C               **  DEFINE THE NUMBER OF PLOT POINTS    (NPLOTP).              *
13070C               **  DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV).              *
13071C               ****************************************************************
13072C
13073      ISTEPN='41'
13074      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'NORM')
13075     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
13076C
13077      CALL DPNOM2(Y1,Y2,XHIGH,NS,ICASPL,MAXN,IHIGH,INPLAX,
13078     1            IX1TSC,IX2TSC,IY1TSC,IY2TSC,
13079     1            IX1TSV,IX2TSV,IY1TSV,IY2TSV,
13080     1            SIGMA,AMU,SDSIGM,SDAMU,
13081     1            BPT1,BPT5,B1,B5,B10,B20,B50,B80,
13082     1            B90,B95,B99,B995,B999,
13083     1            Y,X,D,NPLOTP,NPLOTV,
13084     1            YS,TAGC2,ITAGC2,WAR,WMR,WMRT,YST,XDIST,
13085     1            IBUGG3,ISUBRO,IERROR)
13086C
13087C               ***************************************
13088C               **  STEP 51--                        **
13089C               **  UPDATE INTERNAL DATAPLOT TABLES  **
13090C               ***************************************
13091C
13092      ISTEPN='51'
13093      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'NORM')
13094     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
13095C
13096      DO5100IPASS=1,17
13097        IF(IPASS.EQ.1)THEN
13098          IH='SIGM'
13099          IH2='A   '
13100        ELSEIF(IPASS.EQ.2)THEN
13101          IH='MU '
13102          IH2='    '
13103        ELSEIF(IPASS.EQ.3)THEN
13104          IH='SDSI'
13105          IH2='GMA '
13106        ELSEIF(IPASS.EQ.4)THEN
13107          IH='SDMU'
13108          IH2='    '
13109C
13110        ELSEIF(IPASS.EQ.5)THEN
13111          IH='BPT1'
13112          IH2='    '
13113        ELSEIF(IPASS.EQ.6)THEN
13114          IH='BPT5'
13115          IH2='    '
13116        ELSEIF(IPASS.EQ.7)THEN
13117          IH='B1  '
13118          IH2='    '
13119        ELSEIF(IPASS.EQ.8)THEN
13120          IH='B5  '
13121          IH2='    '
13122        ELSEIF(IPASS.EQ.9)THEN
13123          IH='B10 '
13124          IH2='    '
13125        ELSEIF(IPASS.EQ.10)THEN
13126          IH='B20 '
13127          IH2='    '
13128        ELSEIF(IPASS.EQ.11)THEN
13129          IH='B50 '
13130        ELSEIF(IPASS.EQ.11)THEN
13131          IH2='    '
13132        ELSEIF(IPASS.EQ.12)THEN
13133          IH='B80 '
13134          IH2='    '
13135        ELSEIF(IPASS.EQ.13)THEN
13136          IH='B90 '
13137          IH2='    '
13138        ELSEIF(IPASS.EQ.14)THEN
13139          IH='B95 '
13140          IH2='    '
13141        ELSEIF(IPASS.EQ.15)THEN
13142          IH='B99 '
13143          IH2='    '
13144        ELSEIF(IPASS.EQ.16)THEN
13145          IH='B995'
13146          IH2='    '
13147        ELSEIF(IPASS.EQ.17)THEN
13148          IH='B999'
13149          IH2='    '
13150        ENDIF
13151C
13152        DO5150I=1,NUMNAM
13153          I2=I
13154          IF(IH.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I).AND.
13155     1       IUSE(I).EQ.'P')THEN
13156            ILOC=I2
13157            GOTO5180
13158          ENDIF
13159 5150   CONTINUE
13160C
13161        IF(NUMNAM.GE.MAXNAM)THEN
13162          WRITE(ICOUT,3451)
13163          CALL DPWRST('XXX','BUG ')
13164          WRITE(ICOUT,5151)MAXNAM
13165 5151     FORMAT('      THE MAXIMUM ALLOWABLE NUMBER OF NAMES (',
13166     1           I8,')')
13167          CALL DPWRST('XXX','BUG ')
13168          WRITE(ICOUT,5153)
13169 5153     FORMAT('      HAS JUST BEEN EXCEEDED.')
13170          CALL DPWRST('XXX','BUG ')
13171          IF(IWIDTH.GE.1)THEN
13172            WRITE(ICOUT,3460)(IANS(I),I=1,MIN(80,IWIDTH))
13173            CALL DPWRST('XXX','BUG ')
13174          ENDIF
13175          IERROR='YES'
13176          GOTO9000
13177        ENDIF
13178C
13179        NUMNAM=NUMNAM+1
13180        ILOC=NUMNAM
13181        IHNAME(ILOC)=IH
13182        IHNAM2(ILOC)=IH2
13183        IUSE(ILOC)='P'
13184C
13185 5180   CONTINUE
13186        IF(IPASS.EQ.1)VALUE(ILOC)=SIGMA
13187        IF(IPASS.EQ.2)VALUE(ILOC)=AMU
13188        IF(IPASS.EQ.3)VALUE(ILOC)=SDSIGM
13189        IF(IPASS.EQ.4)VALUE(ILOC)=SDAMU
13190        IF(IPASS.EQ.5)VALUE(ILOC)=BPT1
13191        IF(IPASS.EQ.6)VALUE(ILOC)=BPT5
13192        IF(IPASS.EQ.7)VALUE(ILOC)=B1
13193        IF(IPASS.EQ.8)VALUE(ILOC)=B5
13194        IF(IPASS.EQ.9)VALUE(ILOC)=B10
13195        IF(IPASS.EQ.10)VALUE(ILOC)=B20
13196        IF(IPASS.EQ.11)VALUE(ILOC)=B50
13197        IF(IPASS.EQ.12)VALUE(ILOC)=B80
13198        IF(IPASS.EQ.13)VALUE(ILOC)=B90
13199        IF(IPASS.EQ.14)VALUE(ILOC)=B95
13200        IF(IPASS.EQ.15)VALUE(ILOC)=B99
13201        IF(IPASS.EQ.16)VALUE(ILOC)=B995
13202        IF(IPASS.EQ.17)VALUE(ILOC)=B999
13203        VAL=VALUE(ILOC)
13204        IF((-CUTOFF).LE.VAL.AND.VAL.LE.CUTOFF)IVAL=INT(VAL+0.5)
13205        IF(VAL.GT.CUTOFF)IVAL=INT(CUTOFF)
13206        IF(VAL.LT.(-CUTOFF))IVAL=INT(-CUTOFF)
13207        IVALUE(ILOC)=IVAL
13208C
13209 5100 CONTINUE
13210C
13211C               *****************
13212C               **  STEP 90--  **
13213C               **  EXIT       **
13214C               *****************
13215C
13216 9000 CONTINUE
13217      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'NORM')THEN
13218        WRITE(ICOUT,999)
13219        CALL DPWRST('XXX','BUG ')
13220        WRITE(ICOUT,9011)
13221 9011   FORMAT('***** AT THE END       OF DPNORM--')
13222        CALL DPWRST('XXX','BUG ')
13223        WRITE(ICOUT,9012)IFOUND,IERROR
13224 9012   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
13225        CALL DPWRST('XXX','BUG ')
13226        WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
13227 9013   FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',
13228     1         I8,I8,I8,2X,A4,2X,A4,2X,A4)
13229        CALL DPWRST('XXX','BUG ')
13230        WRITE(ICOUT,9014)ICASPL,MAXN,NUMVAR
13231 9014   FORMAT('ICASPL,MAXN,NUMVAR = ',A4,2I8)
13232        CALL DPWRST('XXX','BUG ')
13233        WRITE(ICOUT,9016)NLOCAL,NQ,MINN2,ICOUNT
13234 9016   FORMAT('NLOCAL,NQ,MINN2,ICOUNT = ',4I8)
13235        CALL DPWRST('XXX','BUG ')
13236        IF(NPLOTP.GE.1)THEN
13237          DO9020I=1,NPLOTP
13238            WRITE(ICOUT,9021)I,Y(I),X(I),D(I)
13239 9021       FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5)
13240            CALL DPWRST('XXX','BUG ')
13241 9020     CONTINUE
13242        ENDIF
13243        WRITE(ICOUT,9041)IX1TSC,IX2TSC,IY1TSC,IY2TSC
13244 9041   FORMAT('IX1TSC,IX2TSC,IY1TSC,IY2TSC = ',A4,2X,A4,2X,A4,2X,A4)
13245        CALL DPWRST('XXX','BUG ')
13246        WRITE(ICOUT,9042)IX1TSV,IX2TSV,IY1TSV,IY2TSV
13247 9042   FORMAT('IX1TSV,IX2TSV,IY1TSV,IY2TSV = ',A4,2X,A4,2X,A4,2X,A4)
13248        CALL DPWRST('XXX','BUG ')
13249        WRITE(ICOUT,9043)SIGMA,AMU,SDSIGM,SDAMU
13250 9043   FORMAT('SIGMA,AMU,SDSIGM,SDAMU = ',4G15.7)
13251        CALL DPWRST('XXX','BUG ')
13252        DO9050I=1,NS
13253          WRITE(ICOUT,9051)I,Y1(I),Y2(I),ISUB(I)
13254 9051     FORMAT('I,Y1(I),Y2(I),ISUB(I) = ',I8,2G15.7,I8)
13255          CALL DPWRST('XXX','BUG ')
13256 9050   CONTINUE
13257      ENDIF
13258C
13259      RETURN
13260      END
13261      SUBROUTINE DPNOM2(Y,TAGC,XHIGH,N,ICASPL,MAXN,IHIGH,INPLAX,
13262     1                  IX1TSC,IX2TSC,IY1TSC,IY2TSC,
13263     1                  IX1TSV,IX2TSV,IY1TSV,IY2TSV,
13264     1                  SIGMA,AMU,SDSIGM,SDAMU,
13265     1                  BPT1,BPT5,B1,B5,B10,B20,B50,B80,
13266     1                  B90,B95,B99,B995,B999,
13267     1                  Y2,X2,D2,N2,NPLOTV,
13268     1                  YS,TAGC2,ITAGC2,WAR,WMR,WMRT,YST,XDIST,
13269     1                  IBUGG3,ISUBRO,IERROR)
13270C
13271CCCCC NOTE--THIS SUBROUTINE WAS BASED ON DPWEI2--ITS WEIBULL ANALOGUE.
13272C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
13273C              THAT WILL DEFINE
13274C              A NORMAL PLOT.
13275C              THE PLOT WILL CONSIST OF 6 COMPONENTS--
13276C                  1) THE RAW DATA
13277C                  2) THE FITTED LINE
13278C                  3) THE HORIZONTAL 50% LINE
13279C                  4) THE VERTICAL   50% LINE
13280C                  5) 95% CONFIDENCE LIMITS
13281C                  6) 99% CONFIDENCE LIMITS
13282C     WRITTEN BY--JAMES J. FILLIBEN
13283C                 STATISTICAL ENGINEERING DIVISION
13284C                 INFORMATION TECHNOLOGY LABORATORY
13285C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
13286C                 GAITHERSBURG, MD 20899-8980
13287C                 PHONE--301-975-2855
13288C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
13289C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
13290C     LANGUAGE--ANSI FORTRAN (1977)
13291C     VERSION NUMBER--87/6
13292C     ORIGINAL VERSION--MAY       1990.
13293C     UPDATED         --DECEMBER  1996. FIX VERTICAL 50% LINE LIMITS
13294C     UPDATED         --FEBRUARY  2011. SUPPORT FOR HIGHLIGHT OPTION
13295C     UPDATED         --JULY      2014. OPTION TO REVERSE X AND Y AXES
13296C
13297C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
13298C
13299      CHARACTER*4 ICASPL
13300      CHARACTER*4 IHIGH
13301      CHARACTER*4 INPLAX
13302c
13303      CHARACTER*4 IX1TSC
13304      CHARACTER*4 IX2TSC
13305      CHARACTER*4 IY1TSC
13306      CHARACTER*4 IY2TSC
13307C
13308      CHARACTER*4 IX1TSV
13309      CHARACTER*4 IX2TSV
13310      CHARACTER*4 IY1TSV
13311      CHARACTER*4 IY2TSV
13312C
13313      CHARACTER*4 IBUGG3
13314      CHARACTER*4 ISUBRO
13315      CHARACTER*4 IERROR
13316C
13317      CHARACTER*4 IWRITE
13318      CHARACTER*4 ISUBN1
13319      CHARACTER*4 ISUBN2
13320C
13321C---------------------------------------------------------------------
13322C
13323      DIMENSION Y(*)
13324      DIMENSION TAGC(*)
13325      DIMENSION XHIGH(*)
13326C
13327      DIMENSION Y2(*)
13328      DIMENSION X2(*)
13329      DIMENSION D2(*)
13330C
13331      DIMENSION YS(*)
13332      DIMENSION TAGC2(*)
13333      DIMENSION ITAGC2(*)
13334      DIMENSION WAR(*)
13335      DIMENSION WMR(*)
13336      DIMENSION WMRT(*)
13337      DIMENSION YST(*)
13338      DIMENSION XDIST(*)
13339C
13340C---------------------------------------------------------------------
13341C
13342      INCLUDE 'DPCOP2.INC'
13343C
13344C-----START POINT-----------------------------------------------------
13345C
13346      ISUBN1='DPNO'
13347      ISUBN2='M2  '
13348      IWRITE='OFF'
13349      IERROR='NO'
13350C
13351      AN=N
13352C
13353      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'NOM2')THEN
13354        WRITE(ICOUT,999)
13355  999   FORMAT(1X)
13356        CALL DPWRST('XXX','BUG ')
13357        WRITE(ICOUT,51)
13358   51   FORMAT('***** AT THE BEGINNING OF DPNOM2--')
13359        CALL DPWRST('XXX','BUG ')
13360        WRITE(ICOUT,52)IBUGG3,ISUBRO,IHIGH
13361   52   FORMAT('IBUGG3,ISUBRO,IHIGH = ',2(A4,2X),A4)
13362        CALL DPWRST('XXX','BUG ')
13363        WRITE(ICOUT,53)ICASPL,MAXN,N,NPLOTV
13364   53   FORMAT('ICASPL,MAXN,N,NPLOTV = ',A4,2X,I8,I8,I8)
13365        CALL DPWRST('XXX','BUG ')
13366        IF(N.GE.1)THEN
13367          DO60I=1,N
13368            WRITE(ICOUT,61)I,Y(I),TAGC(I),XHIGH(I)
13369   61       FORMAT('I,Y(I),TAGC(I),XHIGH(I) = ',I8,3G15.7)
13370            CALL DPWRST('XXX','BUG ')
13371   60     CONTINUE
13372        ENDIF
13373        WRITE(ICOUT,71)IX1TSC,IX2TSC,IY1TSC,IY2TSC
13374   71   FORMAT('IX1TSC,IX2TSC,IY1TSC,IY2TSC = ',A4,2X,A4,2X,A4,2X,A4)
13375        CALL DPWRST('XXX','BUG ')
13376        WRITE(ICOUT,72)IX1TSV,IX2TSV,IY1TSV,IY2TSV
13377   72   FORMAT('IX1TSV,IX2TSV,IY1TSV,IY2TSV = ',A4,2X,A4,2X,A4,2X,A4)
13378        CALL DPWRST('XXX','BUG ')
13379      ENDIF
13380C
13381C               ********************************************
13382C               **  STEP 11--                             **
13383C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
13384C               ********************************************
13385C
13386      IF(N.LT.3)THEN
13387        WRITE(ICOUT,999)
13388        CALL DPWRST('XXX','BUG ')
13389        WRITE(ICOUT,1111)
13390 1111   FORMAT('***** ERROR IN NORMAL PLOT--')
13391        CALL DPWRST('XXX','BUG ')
13392        WRITE(ICOUT,1112)
13393 1112   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 3;')
13394        CALL DPWRST('XXX','BUG ')
13395        WRITE(ICOUT,1114)N
13396 1114   FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6)
13397        CALL DPWRST('XXX','BUG ')
13398        IERROR='YES'
13399        GOTO9000
13400      ENDIF
13401C
13402      HOLD=Y(1)
13403      DO1130I=1,N
13404        IF(Y(I).NE.HOLD)GOTO1139
13405 1130 CONTINUE
13406      WRITE(ICOUT,999)
13407      CALL DPWRST('XXX','BUG ')
13408      WRITE(ICOUT,1111)
13409      CALL DPWRST('XXX','BUG ')
13410      WRITE(ICOUT,1132)
13411 1132 FORMAT('      ALL THE INPUT RESPONSE VARIABLE ELEMENTS ARE')
13412      CALL DPWRST('XXX','BUG ')
13413      WRITE(ICOUT,1133)HOLD
13414 1133 FORMAT('      IDENTICALLY EQUAL TO ',G15.7)
13415      CALL DPWRST('XXX','BUG ')
13416      WRITE(ICOUT,999)
13417      CALL DPWRST('XXX','BUG ')
13418      IERROR='YES'
13419      GOTO9000
13420 1139 CONTINUE
13421C
13422      DO1140I=1,N
13423        IF(Y(I).NE.0.0)GOTO1149
13424 1140 CONTINUE
13425      WRITE(ICOUT,999)
13426      CALL DPWRST('XXX','BUG ')
13427      WRITE(ICOUT,1111)
13428      CALL DPWRST('XXX','BUG ')
13429      WRITE(ICOUT,1142)
13430 1142 FORMAT('      ALL INPUT TAG VARIABLE ELEMENTS')
13431      CALL DPWRST('XXX','BUG ')
13432      WRITE(ICOUT,1143)
13433 1143 FORMAT('      ARE IDENTICALLY EQUAL TO 0.0;')
13434      CALL DPWRST('XXX','BUG ')
13435      WRITE(ICOUT,1144)
13436 1144 FORMAT('      THUS THERE ARE NO RESPONSE VARIABLE VALUES ')
13437      CALL DPWRST('XXX','BUG ')
13438      WRITE(ICOUT,1145)
13439 1145 FORMAT('      REMAINING UPON WHICH TO DO A NORMAL ANALYSIS.')
13440      CALL DPWRST('XXX','BUG ')
13441      WRITE(ICOUT,999)
13442      CALL DPWRST('XXX','BUG ')
13443      IERROR='YES'
13444      GOTO9000
13445 1149 CONTINUE
13446C
13447C               ***********************************************
13448C               **  STEP 21--                                **
13449C               **  SORT THE DATA AND CARRY ALONG THE TAG    **
13450C               ***********************************************
13451C
13452      IF(IHIGH.EQ.'ON')THEN
13453        CALL SORTC(Y,XHIGH,N,YS,TAGC2)
13454        DO2010I=1,N
13455          XHIGH(I)=TAGC2(I)
13456 2010   CONTINUE
13457        CALL DISTIN(XHIGH,N,IWRITE,XDIST,NDIST,IBUGG3,IERROR)
13458        IF(IERROR.EQ.'YES')GOTO9000
13459      ELSE
13460        NDIST=1
13461        DO2013I=1,N
13462          XHIGH(I)=1.0
13463 2013   CONTINUE
13464      ENDIF
13465C
13466      CALL SORTC(Y,TAGC,N,YS,TAGC2)
13467C
13468      DO2100I=1,N
13469        ITAGC2(I)=INT(TAGC2(I)+0.1)
13470 2100 CONTINUE
13471C
13472C
13473C               ***********************************************
13474C               **  STEP 22--                                **
13475C               **  COMPUTE NORMAL  ADUSTED RANKS            **
13476C               ***********************************************
13477C
13478C               -----------------------------------------------
13479C               SET INITIAL VALUE FOR SAVED ADJUSTED RANK.
13480C               SET INITIAL VALUE FOR RANK INCREMENT.
13481C               -----------------------------------------------
13482C
13483      SAVEAR=0.0
13484C
13485      I=0
13486      ANUM=(AN+1.0)-SAVEAR
13487      ADENOM=1+(N-I)
13488      RANINC=ANUM/ADENOM
13489C
13490      NVALID=0
13491      DO2200I=1,N
13492        IF(ITAGC2(I).EQ.1)THEN
13493C
13494C          -----------------------------------------------
13495C          TREAT THE VALID (TO BE INCLUDED) ITEM CASE.
13496C          COMPUTE THE ADJUSTED RANK.
13497C          SAVE THE ADJUSTED RANK.
13498C          DO NOT RECOMPUTE THE RANK INCREMENT.
13499C          -----------------------------------------------
13500C
13501          NVALID=NVALID+1
13502          WAR(I)=SAVEAR+RANINC
13503          SAVEAR=WAR(I)
13504C
13505          IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NOM2')THEN
13506            WRITE(ICOUT,2211)I,YS(I),TAGC2(I),ITAGC2(I),WAR(I)
13507 2211       FORMAT('I,YS(I),TAGC2(I),ITAGC2(I),WAR(I) = ',I8,2G15.7,
13508     1             I8,G15.7)
13509            CALL DPWRST('XXX','BUG ')
13510          ENDIF
13511C
13512        ELSE
13513C
13514C         -----------------------------------------------
13515C         TREAT THE SUSPENDED (= CENSORED) ITEM CASE
13516C         RECOMPUTE THE RANK INCREMENT.
13517C         DO NOT RECOMPUTE THE SAVED ADJUSTED RANK.
13518C         -----------------------------------------------
13519C
13520          ANUM=(AN+1.0)-SAVEAR
13521          ADENOM=1+(N-I)
13522          RANINC=ANUM/ADENOM
13523        ENDIF
13524C
13525 2200 CONTINUE
13526C
13527C               ************************************
13528C               **  STEP 23--                     **
13529C               **  DETERMINE THE NUMBER OF       **
13530C               **  "GOOD"                        **
13531C               **  = NON-CENSORED/NON-SUSPENDED  **
13532C               **  DATA VALUES.                  **
13533C               ************************************
13534C
13535      NSUB=0
13536      DO2300I=1,N
13537        IF(ITAGC2(I).NE.0)NSUB=NSUB+1
13538 2300 CONTINUE
13539      ANSUB=NSUB
13540C
13541C               ****************************************
13542C               **  STEP 24--                         **
13543C               **  COMPUTE NORMAL  MEDIAN RANKS      **
13544C               **  (FOR THE GOOD DATA ONLY)          **
13545C               ****************************************
13546C
13547      DO2400I=1,N
13548        WMR(I)=(-999.0)
13549        IF(ITAGC2(I).EQ.0)GOTO2400
13550CCCCC   WMR(I)=100.0*(WAR(I)-0.3)/(AN+0.4)
13551        IWARI=INT(WAR(I)+0.1)
13552        CALL UNIME2(N,IWARI,POUT)
13553        WMR(I)=100.0*POUT
13554C
13555        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NOM2')THEN
13556          WRITE(ICOUT,2411)I,WAR(I),WMR(I)
13557 2411     FORMAT('I,WAR(I),WMR(I) = ',I8,2G15.7)
13558          CALL DPWRST('XXX','BUG ')
13559        ENDIF
13560C
13561 2400 CONTINUE
13562C
13563C               ****************************************
13564C               **  STEP 30--                         **
13565C               **  FIT THE DATA TO ESTIMATE          **
13566C               **  SIGMA (= SCALE PARAMETER) AND      **
13567C               **  AMU  (= LOCATION PARAMETER)      **
13568C               ****************************************
13569C
13570C               ******************************************
13571C               **  STEP 31--                           **
13572C               **  TRANSFORM THE NORMAL  MEDIAN RANKS  **
13573C               ******************************************
13574C
13575      DO3100I=1,N
13576        WMRT(I)=(-999.0)
13577        IF(ITAGC2(I).EQ.0)GOTO3100
13578        ARG1=WMR(I)/100.0
13579        CALL NORPPF(ARG1,WMRT(I))
13580C
13581        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NOM2')THEN
13582          WRITE(ICOUT,3111)I,ITAGC2(I),WMR(I),WMRT(I)
13583 3111     FORMAT('I,ITAGC2(I),WMR(I),WMRT(I) = ',2I8,2G15.7)
13584          CALL DPWRST('XXX','BUG ')
13585        ENDIF
13586C
13587 3100 CONTINUE
13588C
13589C               ******************************************
13590C               **  STEP 32--                           **
13591C               **  TRANSFORM THE SORTED DATA           **
13592C               ******************************************
13593C
13594      DO3200I=1,N
13595        YST(I)=YS(I)
13596C
13597        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NOM2')THEN
13598          WRITE(ICOUT,3221)I,ITAGC2(I),YS(I),YST(I)
13599 3221     FORMAT('I,ITAGC2(I),YS(I),YST(I) = ',2I8,2G15.7)
13600          CALL DPWRST('XXX','BUG ')
13601        ENDIF
13602C
13603 3200 CONTINUE
13604C
13605C               ******************************************
13606C               **  STEP 33--                           **
13607C               **  CARRY OUT THE FIT OF                **
13608C               **  TRANSFORMED SORTED DATA VERSUS      **
13609C               **  TRANSFORMED NORMAL  MEDIAN RANKS    **
13610C               ******************************************
13611C
13612      SUMX=0.0
13613      SUMY=0.0
13614      DO3310I=1,N
13615C
13616        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NOM2')THEN
13617          WRITE(ICOUT,3311)I,ITAGC2(I),YST(I),WMRT(I)
13618 3311     FORMAT('I,ITAGC2(I),YST(I),WMRT(I) = ',2I8,2G15.7)
13619          CALL DPWRST('XXX','BUG ')
13620        ENDIF
13621C
13622        IF(ITAGC2(I).EQ.0)GOTO3310
13623        SUMX=SUMX+WMRT(I)
13624        SUMY=SUMY+YST(I)
13625 3310 CONTINUE
13626      XBAR=SUMX/ANSUB
13627      YBAR=SUMY/ANSUB
13628C
13629      SUMXX=0.0
13630      SUMYY=0.0
13631      SUMXY=0.0
13632      DO3320I=1,N
13633        IF(ITAGC2(I).EQ.0)GOTO3320
13634        SUMXX=SUMXX+(WMRT(I)-XBAR)*(WMRT(I)-XBAR)
13635        SUMYY=SUMYY+(YST(I)-YBAR)*(YST(I)-YBAR)
13636        SUMXY=SUMXY+(WMRT(I)-XBAR)*(YST(I)-YBAR)
13637 3320 CONTINUE
13638      ASLOPE=0.0
13639      IF(SUMXX.GT.0.0)ASLOPE=SUMXY/SUMXX
13640      AINTER=YBAR-ASLOPE*XBAR
13641C
13642      SUMRR=0.0
13643      SUMX2=0.0
13644      DO3330I=1,N
13645        IF(ITAGC2(I).EQ.0)GOTO3330
13646        RES=YST(I)-(AINTER+ASLOPE*WMRT(I))
13647        SUMRR=SUMRR+RES*RES
13648        SUMX2=SUMX2+WMRT(I)*WMRT(I)
13649 3330 CONTINUE
13650      RESVAR=SUMRR/(AN-2.0)
13651      RESSD=0.0
13652      IF(RESVAR.GT.0.0)RESSD=SQRT(RESVAR)
13653      SDINTE=RESSD*SQRT(SUMX2/(AN*SUMXX))
13654      SDSLOP=RESSD*SQRT(1.0/SUMXX)
13655C
13656C               ****************************************
13657C               **  STEP 34--                         **
13658C               **  FORM ESTIMATES FOR                **
13659C               **  SIGMA (= SCALE PARAMETER) AND     **
13660C               **  AMU  (= LOCATION PARAMETER)       **
13661C               ****************************************
13662C
13663      IF(ASLOPE.LE.0.0)THEN
13664        WRITE(ICOUT,999)
13665        CALL DPWRST('XXX','BUG ')
13666        WRITE(ICOUT,1111)
13667        CALL DPWRST('XXX','BUG ')
13668        WRITE(ICOUT,3332)
13669 3332   FORMAT('      THE FITTED SLOPE IS ZERO OR NEGATIVE WHICH WOULD')
13670        CALL DPWRST('XXX','BUG ')
13671        WRITE(ICOUT,3335)
13672 3335   FORMAT('      YIELD AN IMPOSSIBLE VALUE FOR SIGMA = 1/SLOPE.')
13673        CALL DPWRST('XXX','BUG ')
13674        WRITE(ICOUT,3336)ASLOPE,AINTER
13675 3336   FORMAT('      ASLOPE,AINTER = ',2E15.7)
13676        CALL DPWRST('XXX','BUG ')
13677        WRITE(ICOUT,3337)SUMX,SUMY,SUMXX,SUMYY,SUMXY
13678 3337   FORMAT('      SUMX,SUMY,SUMXX,SUMYY,SUMXY = ',5E15.7)
13679        CALL DPWRST('XXX','BUG ')
13680        IERROR='YES'
13681        GOTO9000
13682      ENDIF
13683      SIGMA=ASLOPE
13684      AMU=AINTER
13685      SDSIGM=SDSLOP
13686      SDAMU=SDINTE
13687C
13688C               ************************************************
13689C               **  STEP 35--                                 **
13690C               **  FORM ESTIMATES FOR                        **
13691C               **     BPT1= .1%   POINT OF BEST-FIT DIST.    **
13692C               **     BPT5= .5%   POINT OF BEST-FIT DIST.    **
13693C               **     B1  =  1%   POINT OF BEST-FIT DIST.    **
13694C               **     B5  =  5%   POINT OF BEST-FIT DIST.    **
13695C               **     B10 = 10%   POINT OF BEST-FIT DIST.    **
13696C               **     B20 = 20%   POINT OF BEST-FIT DIST.    **
13697C               **     B50 = 50%   POINT OF BEST-FIT DIST.    **
13698C               **     B80 = 80%   POINT OF BEST-FIT DIST.    **
13699C               **     B90 = 90%   POINT OF BEST-FIT DIST.    **
13700C               **     B95 = 95%   POINT OF BEST-FIT DIST.    **
13701C               **     B99 = 99%   POINT OF BEST-FIT DIST.    **
13702C               **     B995= 99.5% POINT OF BEST-FIT DIST.    **
13703C               **     B999= 99.9% POINT OF BEST-FIT DIST.    **
13704C               ************************************************
13705C
13706      P=.001
13707      CALL NORPPF(P,XOUT)
13708      BPT1=AMU+XOUT*SIGMA
13709      P=.005
13710      CALL NORPPF(P,XOUT)
13711      BPT5=AMU+XOUT*SIGMA
13712      P=.01
13713      CALL NORPPF(P,XOUT)
13714      B1=AMU+XOUT*SIGMA
13715      P=.05
13716      CALL NORPPF(P,XOUT)
13717      B5=AMU+XOUT*SIGMA
13718      P=.10
13719      CALL NORPPF(P,XOUT)
13720      B10=AMU+XOUT*SIGMA
13721      P=.20
13722      CALL NORPPF(P,XOUT)
13723      B20=AMU+XOUT*SIGMA
13724      P=.50
13725      CALL NORPPF(P,XOUT)
13726      B50=AMU+XOUT*SIGMA
13727      P=.80
13728      CALL NORPPF(P,XOUT)
13729      B80=AMU+XOUT*SIGMA
13730      P=.90
13731      CALL NORPPF(P,XOUT)
13732      B90=AMU+XOUT*SIGMA
13733      P=.95
13734      CALL NORPPF(P,XOUT)
13735      B95=AMU+XOUT*SIGMA
13736      P=.99
13737      CALL NORPPF(P,XOUT)
13738      B99=AMU+XOUT*SIGMA
13739      P=.995
13740      CALL NORPPF(P,XOUT)
13741      B995=AMU+XOUT*SIGMA
13742      P=.999
13743      CALL NORPPF(P,XOUT)
13744      B999=AMU+XOUT*SIGMA
13745C
13746C               ****************************************
13747C               **  STEP 41--                         **
13748C               **  SAVE OLD SETTINGS FOR             **
13749C               **     HORIZONTAL AXIS PLOT SCALE     **
13750C               **     VERTICAL AXIS PLOT SCALE       **
13751C               **  CHANGE                            **
13752C               **     HORIZONTAL AXIS PLOT SCALE     **
13753C               **     TO LOG                         **
13754C               **  CHANGE                            **
13755C               **     VERTICAL AXIS PLOT SCALE       **
13756C               **     TO NORMAL                      **
13757C               ****************************************
13758
13759      IX1TSV=IX1TSC
13760      IX2TSV=IX2TSC
13761      IY1TSV=IY1TSC
13762      IY2TSV=IY2TSC
13763C
13764      IF(INPLAX.EQ.'REVE')THEN
13765        IX1TSC='NORM'
13766        IX2TSC='NORM'
13767        IY1TSC='LINE'
13768        IY2TSC='LINE'
13769      ELSE
13770        IX1TSC='LINE'
13771        IX2TSC='LINE'
13772        IY1TSC='NORM'
13773        IY2TSC='NORM'
13774      ENDIF
13775C
13776C               ****************************************
13777C               **  STEP 42--                         **
13778C               **  DETERMINE PLOT LIMITS FOR         **
13779C               **  PREDICTED LINE                    **
13780C               ****************************************
13781C
13782      P2=0.1
13783      P=P2/100.0
13784      CALL NORPPF(P,TERM)
13785      PPF=AMU+TERM*SIGMA
13786      XMIN=PPF
13787C
13788      P2=99.9
13789      P=P2/100.0
13790      CALL NORPPF(P,TERM)
13791      PPF=AMU+TERM*SIGMA
13792      XMAX=PPF
13793C
13794      XINC=(XMAX-XMIN)/100.0
13795C
13796      XMIN2=XMIN
13797      IF(XMIN2.GE.0.0)XMIN3=AINT(XMIN2)
13798      IF(XMIN2.LT.0.0)XMIN3=(-AINT(-XMIN2+1.0))
13799      XMIN4=XMIN3+0.001
13800C
13801      XMAX3=0.0
13802      XMAX2=XMAX
13803      IF(XMAX2.GE.0.0)XMAX3=AINT(XMAX2)
13804      IF(XMAX2.LT.0.0)XMAX3=(-AINT(-XMAX2+1.0))
13805      XMAX3=XMAX3+1.0
13806      XMAX4=XMAX3-0.001
13807C
13808      X50=AMU
13809C
13810C               ****************************************
13811C               **  STEP 51--                         **
13812C               **  FORM PLOT COORDINATES             **
13813C               **     RAW (GOOD) DATA                **
13814C               **     PREDICTED LINE                 **
13815C               **     HORIZONTAL 50% LINE            **
13816C               **     VERTICAL   50% LINE            **
13817C               **     95% CONFIDENCE BAND            **
13818C               **     99% CONFIDENCE BAND            **
13819C               ****************************************
13820C
13821      J=0
13822      DO5110I=1,N
13823        IF(ITAGC2(I).EQ.0)GOTO5110
13824        J=J+1
13825        Y2(J)=WMR(I)
13826        X2(J)=YS(I)
13827        IF(NDIST.EQ.1)THEN
13828          D2(J)=1.0
13829        ELSE
13830          IINDX=1
13831          DO5115K=1,NDIST
13832            IF(XHIGH(I).EQ.XDIST(K))THEN
13833              IINDX=K
13834              GOTO5119
13835            ENDIF
13836 5115     CONTINUE
13837 5119     CONTINUE
13838          D2(J)=REAL(IINDX)
13839        ENDIF
13840 5110 CONTINUE
13841C
13842      X=XMIN-XINC
13843      DO5120I=1,10000
13844        X=X+XINC
13845        IF(X.GT.XMAX)GOTO5129
13846CCCCC   PRED=100.0*(1.0-EXP(-((X/MU)**SIGMA)))
13847        ARG=(X-AMU)/SIGMA
13848        CALL NORCDF(ARG,POUT)
13849        PRED=100.0*POUT
13850        J=J+1
13851        Y2(J)=PRED
13852        X2(J)=X
13853        D2(J)=REAL(NDIST+1)
13854 5120 CONTINUE
13855 5129 CONTINUE
13856C
13857      J=J+1
13858      Y2(J)=50.0
13859      X2(J)=XMIN4
13860      D2(J)=REAL(NDIST+2)
13861      J=J+1
13862      Y2(J)=50.0
13863      X2(J)=XMAX4
13864      D2(J)=REAL(NDIST+2)
13865C
13866      J=J+1
13867CCCCC THE FOLLOWING LINE WAS CHANGED   DECEMBER 1996
13868CCCCC Y2(J)=99.9
13869      Y2(J)=99.5
13870      X2(J)=X50
13871      D2(J)=REAL(NDIST+3)
13872      J=J+1
13873CCCCC THE FOLLOWING LINE WAS CHANGED   DECEMBER 1996
13874CCCCC Y2(J)=0.1
13875      Y2(J)=0.5
13876      X2(J)=X50
13877      D2(J)=REAL(NDIST+3)
13878C
13879      N2=J
13880      NPLOTV=3
13881C
13882      IF(INPLAX.EQ.'REVE')THEN
13883        DO6010I=1,N2
13884          ATEMP=X2(I)
13885          X2(I)=Y2(I)
13886          Y2(I)=ATEMP
13887 6010   CONTINUE
13888      ENDIF
13889C
13890C               ****************************************
13891C               **  STEP 61--                         **
13892C               **  RESTORE OLD SETTINGS FOR          **
13893C               **     HORIZONTAL AXIS PLOT SCALE     **
13894C               **     VERTICAL AXIS PLOT SCALE       **
13895C               ****************************************
13896C
13897CCCCC IX1TSC=IX1TSV
13898CCCCC IX2TSC=IX2TSV
13899CCCCC IY1TSC=IY1TSV
13900CCCCC IY2TSC=IY2TSV
13901C     (THIS RESTORATION MUST BE DONE IN MAIN)
13902C
13903C
13904C               *****************
13905C               **  STEP 90--  **
13906C               **  EXIT       **
13907C               *****************
13908C
13909 9000 CONTINUE
13910      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'NOM2')THEN
13911        WRITE(ICOUT,999)
13912        CALL DPWRST('XXX','BUG ')
13913        WRITE(ICOUT,9011)
13914 9011   FORMAT('***** AT THE END       OF DPNOM2--')
13915        CALL DPWRST('XXX','BUG ')
13916        WRITE(ICOUT,9012)ICASPL,MAXN,N2,IERROR
13917 9012   FORMAT('ICASPL,MAXN,N2,IERROR = ',A4,I8,I8,2X,A4)
13918        CALL DPWRST('XXX','BUG ')
13919        DO9015I=1,N2
13920          WRITE(ICOUT,9016)I,Y2(I),X2(I),D2(I)
13921 9016     FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2G15.7,F9.2)
13922          CALL DPWRST('XXX','BUG ')
13923 9015   CONTINUE
13924        WRITE(ICOUT,9021)IX1TSC,IX2TSC,IY1TSC,IY2TSC
13925 9021   FORMAT('IX1TSC,IX2TSC,IY1TSC,IY2TSC = ',A4,2X,A4,2X,A4,2X,A4)
13926        CALL DPWRST('XXX','BUG ')
13927        WRITE(ICOUT,9022)IX1TSV,IX2TSV,IY1TSV,IY2TSV
13928 9022   FORMAT('IX1TSV,IX2TSV,IY1TSV,IY2TSV = ',A4,2X,A4,2X,A4,2X,A4)
13929        CALL DPWRST('XXX','BUG ')
13930        WRITE(ICOUT,9031)AINTER,ASLOPE,SDINTE,SDSLOP
13931 9031   FORMAT('AINTER,ASLOPE,SDINTE,SDSLOP = ',4G15.7)
13932        CALL DPWRST('XXX','BUG ')
13933        WRITE(ICOUT,9032)SIGMA,AMU,SDSIGM,SDAMU
13934 9032   FORMAT('SIGMA,AMU,SDSIGM,SDAMU = ',4G15.7)
13935        CALL DPWRST('XXX','BUG ')
13936        WRITE(ICOUT,9034)BPT1,BPT5,B1,B5
13937 9034   FORMAT('BPT1,BPT5,B1,B5 = ',4G15.7)
13938        CALL DPWRST('XXX','BUG ')
13939        WRITE(ICOUT,9035)B10,B20,B50,B80,B90
13940 9035   FORMAT(' B10,B20,B50,B80,B90 = ',5G15.7)
13941        CALL DPWRST('XXX','BUG ')
13942        WRITE(ICOUT,9036)B95,B99,B995,B999
13943 9036   FORMAT('B95,B99,B995,B999 = ',4G15.7)
13944        CALL DPWRST('XXX','BUG ')
13945        WRITE(ICOUT,9041)XMIN,XMIN2,XMIN3,XMIN4
13946 9041   FORMAT('XMIN,XMIN2,XMIN3,XMIN4 = ',4E15.7)
13947        CALL DPWRST('XXX','BUG ')
13948        WRITE(ICOUT,9042)XINC,RESSD,AMU,X50
13949 9042   FORMAT('XINC,RESSD,AMU,X50 = ',4G15.7)
13950        CALL DPWRST('XXX','BUG ')
13951        WRITE(ICOUT,9043)XMIN,XMIN2,XMIN3,XMIN4
13952 9043   FORMAT('XMIN,XMIN2,XMIN3,XMIN4 = ',4E15.7)
13953        CALL DPWRST('XXX','BUG ')
13954      ENDIF
13955C
13956      RETURN
13957      END
13958      SUBROUTINE DPNOR(IHARG,IARGT,ARG,NUMARG,
13959     1                 PXSTAR,PYSTAR,PXEND,PYEND,
13960     1                 ILINPA,ILINCO,PLINTH,
13961     1                 AREGBA,IREBLI,IREBCO,PREBTH,
13962     1                 IREFSW,IREFCO,
13963     1                 IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
13964     1                 PTEXHE,PTEXWI,PTEXVG,PTEXHG,
13965     1                 IGRASW,IDIASW,
13966     1                 PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
13967     1                 PDIAHE,PDIAWI,PDIAVG,PDIAHG,
13968     1                 NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
13969     1                 IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
13970     1                 IDNVOF,IDNHOF,IDFONT,UNITSW,PDSCAL,
13971     1                 IBUGD2,IFOUND,IERROR)
13972C
13973C     PURPOSE--DRAW ONE OR MORE LOGICAL NORS (DEPENDING ON HOW MANY
13974C              NUMBERS ARE PROVIDED).  THE COORDINATES ARE IN
13975C              STANDARDIZED UNITS OF 0 TO 100.
13976C     NOTE--THE INPUT COORDINATES DEFINE THE BACK CENTER AND THE FRONT
13977C           CENTER OF THE LOGICAL NOR.  NOTE-THE USUAL INPUT NUMBER OF
13978C           COORDINATES IS 2 AND THEREFORE THE USUAL INPUT NUMBER OF
13979C           NUMBERS IS 2*2 = 4.
13980C     NOTE--IF 2 NUMBERS ARE PROVIDED, THEN THE DRAWN LOGICAL NOR WILL
13981C           GO FROM THE LAST CURSOR POSITION TO THE (X,Y) POINT (EITHER
13982C           ABSOLUTE OR RELATIVE) AS DEFINED BY THE 2 NUMBERS.
13983C     NOTE--IF 4 NUMBERS ARE PROVIDED, THEN THE DRAWN LOGICAL NOR WILL
13984C           GO FROM THE ABSOLUTE (X,Y) POSITION AS DEFINED BY THE FIRST
13985C           2 NUMBERS TO THE (X,Y) POINT (EITHER ABSOLUTE OR RELATIVE)
13986C           AS DEFINED BY THE THIRD AND FOURTH NUMBERS.
13987C     NOTE--IF 6 NUMBERS ARE PROVIDED, THEN THE DRAWN LOGICAL NOR WILL
13988C           GO FROM THE (X,Y) POSITION AS RESULTING FROM THE THIRD AND
13989C           FOURTH NUMBERS TO THE (X,Y) POINT (EITHER ABSOLUTE OR
13990C           RELATIVE) AS DEFINED BY THE FIFTH AND SIXTH NUMBERS.
13991C     NOTE--AND SO FORTH FOR 8, 10, 12, ... NUMBERS.
13992C     INPUT  ARGUMENTS--IHARG
13993C                     --IARGT
13994C                     --ARG
13995C                     --NUMARG
13996C                     --PXSTAR
13997C                     --PYSTAR
13998C     OUTPUT ARGUMENTS--PXEND
13999C                     --PYEND
14000C                     --IFOUND ('YES' OR 'NO' )
14001C                     --IERROR ('YES' OR 'NO' )
14002C     WRITTEN BY--JAMES J. FILLIBEN
14003C                 STATISTICAL ENGINEERING DIVISION
14004C                 INFORMATION TECHNOLOGY LABORATORY
14005C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
14006C                 GAITHERSBURG, MD 20899-8980
14007C                 PHONE--301-975-2855
14008C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
14009C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
14010C     LANGUAGE--ANSI FORTRAN (1977)
14011C     VERSION NUMBER--82/7
14012C     ORIGINAL VERSION--APRIL     1981.
14013C     UPDATED         --MARCH     1982.
14014C     UPDATED         --MAY       1982.
14015C     UPDATED         --NOVEMBER  1982.
14016C     UPDATED         --JANUARY   1989. CALL LIST FOR OFFSET VAR (ALAN)
14017C     UPDATED         --MARCH     1997. SUPPORT FOR DEVICE FONT (ALAN)
14018C     UPDATED         --JULY      1997. SUPPORT FOR "DATA" UNITS (ALAN)
14019C     UPDATED         --DECEMBER  2018. CHECK FOR DISCRETE, NULL, OR
14020C                                       NONE DEVICE
14021C     UPDATED         --DECEMBER  2018. SUPPORT FOR "DEVICE ... SCALE"
14022C                                       COMMAND
14023C     UPDATED         --JULY      2019. CREATE SCRATCH STORAGE IN DPNOR
14024C                                       RATHER THAN DPNOR2
14025C
14026C-----NON-COMMON VARIABLES-----------------------------------------
14027C
14028      CHARACTER*4 IHARG
14029      CHARACTER*4 IARGT
14030C
14031      CHARACTER*4 ILINPA
14032      CHARACTER*4 ILINCO
14033C
14034      CHARACTER*4 IREBLI
14035      CHARACTER*4 IREBCO
14036      CHARACTER*4 IREFSW
14037      CHARACTER*4 IREFCO
14038      CHARACTER*4 IREPTY
14039      CHARACTER*4 IREPLI
14040      CHARACTER*4 IREPCO
14041C
14042      CHARACTER*4 IGRASW
14043      CHARACTER*4 IDIASW
14044C
14045      CHARACTER*4 IDMANU
14046      CHARACTER*4 IDMODE
14047      CHARACTER*4 IDMOD2
14048      CHARACTER*4 IDMOD3
14049      CHARACTER*4 IDPOWE
14050      CHARACTER*4 IDCONT
14051      CHARACTER*4 IDCOLO
14052      CHARACTER*4 IDFONT
14053      CHARACTER*4 UNITSW
14054C
14055      CHARACTER*4 IFOUND
14056      CHARACTER*4 IBUGD2
14057      CHARACTER*4 IERROR
14058      CHARACTER*4 ISUBRO
14059C
14060      CHARACTER*4 IFIG
14061      CHARACTER*4 IBELSW
14062      CHARACTER*4 IERASW
14063      CHARACTER*4 IBACCO
14064      CHARACTER*4 ICOPSW
14065      CHARACTER*4 ITYPEO
14066C
14067      DIMENSION IHARG(*)
14068      DIMENSION IARGT(*)
14069      DIMENSION ARG(*)
14070C
14071      DIMENSION ILINPA(*)
14072      DIMENSION ILINCO(*)
14073      DIMENSION PLINTH(*)
14074C
14075      DIMENSION AREGBA(*)
14076      DIMENSION IREBLI(*)
14077      DIMENSION IREBCO(*)
14078      DIMENSION PREBTH(*)
14079      DIMENSION IREFSW(*)
14080      DIMENSION IREFCO(*)
14081      DIMENSION IREPTY(*)
14082      DIMENSION IREPLI(*)
14083      DIMENSION IREPCO(*)
14084      DIMENSION PREPTH(*)
14085      DIMENSION PREPSP(*)
14086      DIMENSION PDSCAL(*)
14087C
14088      DIMENSION IDMANU(*)
14089      DIMENSION IDMODE(*)
14090      DIMENSION IDMOD2(*)
14091      DIMENSION IDMOD3(*)
14092      DIMENSION IDPOWE(*)
14093      DIMENSION IDCONT(*)
14094      DIMENSION IDCOLO(*)
14095      DIMENSION IDFONT(*)
14096      DIMENSION IDNVPP(*)
14097      DIMENSION IDNHPP(*)
14098      DIMENSION IDUNIT(*)
14099      DIMENSION IDNVOF(*)
14100      DIMENSION IDNHOF(*)
14101C
14102C-----COMMON----------------------------------------------------------
14103C
14104      INCLUDE 'DPCOPA.INC'
14105      INCLUDE 'DPCOZZ.INC'
14106      DIMENSION PX(1000)
14107      DIMENSION PY(1000)
14108      EQUIVALENCE (GARBAG(IGARB1),PX(1))
14109      EQUIVALENCE (GARBAG(IGARB2),PY(1))
14110C
14111C-----COMMON VARIABLES (GENERAL)--------------------------------------
14112C
14113      INCLUDE 'DPCOGR.INC'
14114      INCLUDE 'DPCOBE.INC'
14115      INCLUDE 'DPCOP2.INC'
14116C
14117C-----START POINT-----------------------------------------------------
14118C
14119      IFOUND='NO'
14120      IERROR='NO'
14121      IERRG4=IERROR
14122C
14123      ILOCFN=0
14124      NUMNUM=0
14125C
14126      X1=0.0
14127      Y1=0.0
14128      X2=0.0
14129      Y2=0.0
14130C
14131      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'NOR')THEN
14132        WRITE(ICOUT,999)
14133  999   FORMAT(1X)
14134        CALL DPWRST('XXX','BUG ')
14135        WRITE(ICOUT,51)
14136   51   FORMAT('***** AT THE BEGINNING OF DPNOR--')
14137        CALL DPWRST('XXX','BUG ')
14138        WRITE(ICOUT,53)NUMARG,NUMDEV
14139   53   FORMAT('NUMARG,NUMDEV = ',2I8)
14140        CALL DPWRST('XXX','BUG ')
14141        DO55I=1,NUMARG
14142          WRITE(ICOUT,56)I,IHARG(I),IARGT(I),ARG(I)
14143   56     FORMAT('I,IHARG(I),IARGT(I),ARG(I) = ',I8,2(2X,A4),G15.7)
14144          CALL DPWRST('XXX','BUG ')
14145   55   CONTINUE
14146        WRITE(ICOUT,57)PXSTAR,PYSTAR,PXEND,PYEND
14147   57   FORMAT('PXSTAR,PYSTAR,PXEND,PYEND = ',4G15.7)
14148        CALL DPWRST('XXX','BUG ')
14149        WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1)
14150   61   FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',2(A4,2X),G15.7)
14151        CALL DPWRST('XXX','BUG ')
14152        WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1),AREGBA(1)
14153   63   FORMAT('IREBLI(1),IREBCO(1),PREBTH(1),AREGBA(1) = ',
14154     1         2(A4,2X),2G15.7)
14155        CALL DPWRST('XXX','BUG ')
14156        WRITE(ICOUT,64)IREFSW(1),IREFCO(1)
14157   64   FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4)
14158        CALL DPWRST('XXX','BUG ')
14159        WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1)
14160   65   FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ',
14161     1         3(A4,2X),2G15.7)
14162        CALL DPWRST('XXX','BUG ')
14163        WRITE(ICOUT,69)PTEXHE,PTEXWI,PTEXVG,PTEXHG
14164   69   FORMAT('PTEXHE,PTEXWI,PTEXVG,PTEXHG= ',4G15.7)
14165        CALL DPWRST('XXX','BUG ')
14166        WRITE(ICOUT,76)IGRASW,IDIASW
14167   76   FORMAT('IGRASW,IDIASW = ',A4,2X,A4)
14168        CALL DPWRST('XXX','BUG ')
14169        WRITE(ICOUT,77)PGRAXF,PGRAYF,PDIAXC,PDIAYC
14170   77   FORMAT('PGRAXF,PGRAYF,PDIAXC,PDIAYC = ',4G15.7)
14171        CALL DPWRST('XXX','BUG ')
14172        WRITE(ICOUT,78)PDIAHE,PDIAWI,PDIAVG,PDIAHG
14173   78   FORMAT('PDIAHE,PDIAWI,PDIAVG,PDIAHG = ',4G15.7)
14174        CALL DPWRST('XXX','BUG ')
14175        DO81I=1,NUMDEV
14176          WRITE(ICOUT,82)IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I)
14177   82     FORMAT('IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I) = ',
14178     1           3(A4,2X),A4)
14179          CALL DPWRST('XXX','BUG ')
14180          WRITE(ICOUT,83)IDPOWE(I),IDCONT(I),IDCOLO(I)
14181   83     FORMAT('IDPOWE(I),IDCONT(I),IDCOLO(I) = ',2(A4,2X),A4)
14182          CALL DPWRST('XXX','BUG ')
14183          WRITE(ICOUT,84)IDNVPP(I),IDNHPP(I),IDUNIT(I)
14184   84     FORMAT('IDNVPP(I),IDNHPP(I),IDUNIT(I) = ',3I8)
14185          CALL DPWRST('XXX','BUG ')
14186   81   CONTINUE
14187        WRITE(ICOUT,88)IBUGG4,IBUGD2,ISUBG4,IERRG4,IFOUND,IERROR
14188   88   FORMAT('IBUGG4,IBUGD2,ISUBG4,IERRG4,IFOUND,IERROR = ',
14189     1         5(A4,2X),A4)
14190        CALL DPWRST('XXX','BUG ')
14191      ENDIF
14192C
14193      IFIG='NOR'
14194      NUMPT=2
14195      NUMPT2=2*NUMPT
14196C
14197C               ********************************
14198C               **  STEP 0--                  **
14199C               **  STEP THROUGH EACH DEVICE  **
14200C               ********************************
14201C
14202      IF(NUMDEV.LE.0)GOTO9000
14203      DO8000IDEVIC=1,NUMDEV
14204C
14205        IF(IDPOWE(IDEVIC).EQ.'OFF')GOTO8000
14206        IF(IDMANU(IDEVIC).EQ.'OFF')GOTO8000
14207        IF(IDMANU(IDEVIC).EQ.'NULL')GOTO8000
14208        IF(IDMANU(IDEVIC).EQ.'NONE')GOTO8000
14209        IF(IDMANU(IDEVIC).EQ.'DISC')GOTO8000
14210C
14211        IMANUF=IDMANU(IDEVIC)
14212        IMODEL=IDMODE(IDEVIC)
14213        IMODE2=IDMOD2(IDEVIC)
14214        IMODE3=IDMOD3(IDEVIC)
14215        IGCONT=IDCONT(IDEVIC)
14216        IGCOLO=IDCOLO(IDEVIC)
14217        IGFONT=IDFONT(IDEVIC)
14218        NUMVPP=IDNVPP(IDEVIC)
14219        NUMHPP=IDNHPP(IDEVIC)
14220        ANUMVP=NUMVPP
14221        ANUMHP=NUMHPP
14222        IOFFSV=IDNVOF(IDEVIC)
14223        IOFFSH=IDNHOF(IDEVIC)
14224        IGUNIT=IDUNIT(IDEVIC)
14225        PCHSCA=PDSCAL(IDEVIC)
14226C
14227C               ************************************
14228C               **  STEP 1--                      **
14229C               **  CARRY OUT OPENING OPERATIONS  **
14230C               **  ON THE GRAPHICS DEVICES       **
14231C               ************************************
14232C
14233        CALL DPOPDE
14234C
14235        IBELSW='OFF'
14236        NUMRIN=0
14237        IERASW='OFF'
14238        IBACCO='JUNK'
14239C
14240        CALL DPOPPL(IGRASW,IBELSW,NUMRIN,IERASW,IBACCO)
14241C
14242C               *****************************************
14243C               **  STEP 2--                           **
14244C               **  SEARCH FOR COMMAND SPECIFICATIONS  **
14245C               *****************************************
14246C
14247        IF(NUMARG.GE.2.AND.
14248     1     IARGT(1).EQ.'NUMB'.AND.IARGT(2).EQ.'NUMB')THEN
14249          ITYPEO='ABSO'
14250          ILOCFN=1
14251        ELSEIF(NUMARG.GE.3.AND.IHARG(1).EQ.'ABSO'.AND.
14252     1         IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB')THEN
14253          ITYPEO='ABSO'
14254          ILOCFN=2
14255        ELSEIF(NUMARG.GE.3.AND.IHARG(1).EQ.'RELA'.AND.
14256     1         IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB')THEN
14257          ITYPEO='RELA'
14258          ILOCFN=2
14259        ELSE
14260          GOTO1130
14261        ENDIF
14262C
14263        IF(ILOCFN.GT.NUMARG)GOTO1130
14264        DO1120I=ILOCFN,NUMARG
14265          IF(IARGT(I).NE.'NUMB')GOTO1130
14266 1120   CONTINUE
14267        IFOUND='YES'
14268C
14269C               ****************************
14270C               **  STEP 3--              **
14271C               **  DRAW OUT THE LINE(S)  **
14272C               ****************************
14273C
14274        NUMNUM=NUMARG-ILOCFN+1
14275        IF(NUMNUM.LT.NUMPT2)THEN
14276          J=ILOCFN-1
14277          X1=PXSTAR
14278          Y1=PYSTAR
14279        ELSE
14280          J=ILOCFN
14281          IF(J.GT.NUMARG)GOTO1190
14282          X1=ARG(J)
14283          IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X1,X1,
14284     1       IBUGD2,ISUBRO,IERROR)
14285          J=J+1
14286          IF(J.GT.NUMARG)GOTO1190
14287          Y1=ARG(J)
14288          IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y1,Y1,
14289     1       IBUGD2,ISUBRO,IERROR)
14290        ENDIF
14291C
14292 1160   CONTINUE
14293        J=J+1
14294        IF(J.GT.NUMARG)GOTO1190
14295        X2=ARG(J)
14296        IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X2,X2,IBUGD2,ISUBRO,IERROR)
14297        IF(ITYPEO.EQ.'RELA')X2=X1+X2
14298        J=J+1
14299        IF(J.GT.NUMARG)GOTO1190
14300        Y2=ARG(J)
14301        IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y2,Y2,IBUGD2,ISUBRO,IERROR)
14302        IF(ITYPEO.EQ.'RELA')Y2=Y1+Y2
14303C
14304        CALL DPNOR2(X1,Y1,X2,Y2,PX,PY,
14305     1              IFIG,ILINPA,ILINCO,PLINTH,
14306     1              AREGBA,IREBLI,IREBCO,PREBTH,
14307     1              IREFSW,IREFCO,
14308     1              IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
14309     1              PTEXHE,PTEXWI,PTEXVG,PTEXHG)
14310C
14311        X1=X2
14312        Y1=Y2
14313C
14314        GOTO1160
14315 1190   CONTINUE
14316C
14317        PXEND=X2
14318        PYEND=Y2
14319C
14320C               ************************************
14321C               **  STEP 4--                      **
14322C               **  CARRY OUT CLOSING OPERATIONS  **
14323C               **  ON THE GRAPHICS DEVICES       **
14324C               ************************************
14325C
14326        ICOPSW='OFF'
14327        NUMCOP=0
14328        CALL DPCLPL(ICOPSW,NUMCOP,
14329     1              PGRAXF,PGRAYF,
14330     1              IGRASW,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
14331     1              PDIAHE,PDIAWI,PDIAVG,PDIAHG)
14332C
14333        CALL DPCLDE
14334C
14335 8000 CONTINUE
14336      GOTO9000
14337C
14338 1130 CONTINUE
14339      IERRG4='YES'
14340      WRITE(ICOUT,1131)
14341 1131 FORMAT('***** ERROR IN NOR GATE (DPNOR)--')
14342      CALL DPWRST('XXX','BUG ')
14343      WRITE(ICOUT,1132)
14344 1132 FORMAT('      ILLEGAL FORM FOR NOR COMMAND.')
14345      CALL DPWRST('XXX','BUG ')
14346      WRITE(ICOUT,1134)
14347 1134 FORMAT('      TEST EXAMPLE TO DEMONSTRATE THE PROPER FORM--')
14348      CALL DPWRST('XXX','BUG ')
14349      WRITE(ICOUT,1135)
14350 1135 FORMAT('      SUPPOSE IT IS DESIRED TO DRAW A LOGICAL NOR ')
14351      CALL DPWRST('XXX','BUG ')
14352      WRITE(ICOUT,1136)
14353 1136 FORMAT('      WITH THE MIDDLE OF THE FLATTER SIDE  ',
14354     1'AT THE POINT 20 20 ')
14355      CALL DPWRST('XXX','BUG ')
14356      WRITE(ICOUT,1137)
14357 1137 FORMAT('      AND WITH THE POINTED END AT THE POINT 40 60')
14358      CALL DPWRST('XXX','BUG ')
14359      WRITE(ICOUT,1141)
14360 1141 FORMAT('      THEN THE ALLOWABLE FORMS ARE--')
14361      CALL DPWRST('XXX','BUG ')
14362      WRITE(ICOUT,1142)
14363 1142 FORMAT('      NOR 20 20 40 60 ')
14364      CALL DPWRST('XXX','BUG ')
14365      WRITE(ICOUT,1143)
14366 1143 FORMAT('      NOR ABSOLUTE 20 20 40 60 ')
14367      CALL DPWRST('XXX','BUG ')
14368      WRITE(ICOUT,1145)
14369 1145 FORMAT('      NOR RELATIVE 20 20 40 60 ')
14370      CALL DPWRST('XXX','BUG ')
14371C
14372C               *****************
14373C               **  STEP 90--  **
14374C               **  EXIT       **
14375C               *****************
14376C
14377 9000 CONTINUE
14378      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'NOR')THEN
14379        WRITE(ICOUT,999)
14380        CALL DPWRST('XXX','BUG ')
14381        WRITE(ICOUT,9011)
14382 9011   FORMAT('***** AT THE END       OF DPNOR--')
14383        CALL DPWRST('XXX','BUG ')
14384        WRITE(ICOUT,9012)IFOUND,IERROR,ILOCFN,NUMNUM
14385 9012   FORMAT('IFOUND,IERROR,ILOCFN,NUMNUM = ',2(A4,2X),2I8)
14386        CALL DPWRST('XXX','BUG ')
14387        WRITE(ICOUT,9013)X1,Y1,X2,Y2
14388 9013   FORMAT('X1,Y1,X2,Y2 = ',4G15.7)
14389        CALL DPWRST('XXX','BUG ')
14390        WRITE(ICOUT,9015)PXSTAR,PYSTAR,PXEND,PYEND
14391 9015   FORMAT('PXSTAR,PYSTAR,PXEND,PYEND = ',4G15.7)
14392        CALL DPWRST('XXX','BUG ')
14393      ENDIF
14394C
14395      RETURN
14396      END
14397      SUBROUTINE DPNOR2(X1,Y1,X2,Y2,PX,PY,
14398     1                  IFIG,ILINPA,ILINCO,PLINTH,
14399     1                  AREGBA,IREBLI,IREBCO,PREBTH,
14400     1                  IREFSW,IREFCO,
14401     1                  IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
14402     1                  PTEXHE,PTEXWI,PTEXVG,PTEXHG)
14403C
14404C     PURPOSE--DRAW A LOGICAL NOR(= A NOR BOX) WITH THE MIDDLE OF THE
14405C              FLATTER SIDE AT THE POINT (X1,Y1), AND WITH THE MIDDLE OF
14406C              THE POINTED SIDE AT THE POINT (X2,Y2).
14407C     NOTE--THE HEIGHT OF THE BOX WILL BE EQUAL TO THE ABOVE-DESCRIBED
14408C           WIDTH OF THE BOX (THAT IS, THE HEIGHT OF THE BOX WILL BE
14409C           EQUAL TO THE WIDTH FROM (X1,Y1) TO (X2,Y2).
14410C     WRITTEN BY--JAMES J. FILLIBEN
14411C                 STATISTICAL ENGINEERING DIVISION
14412C                 INFORMATION TECHNOLOGY LABORATORY
14413C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
14414C                 GAITHERSBURG, MD 20899-8980
14415C                 PHONE--301-975-2855
14416C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
14417C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
14418C     LANGUAGE--ANSI FORTRAN (1977)
14419C     VERSION NUMBER--82/7
14420C     ORIGINAL VERSION--APRIL     1981.
14421C     UPDATED         --MAY       1982.
14422C     UPDATED         --JANUARY   1989. MODIFY CALLS TO DPDRPL (ALAN)
14423C     UPDATED         --JANUARY   1989. MODIFY CALL  TO DPFIRE (ALAN)
14424C     UPDATED         --JULY      2019. CREATE SCRATCH STORAGE IN DPNOR
14425C                                       RATHER THAN DPNOR2
14426C
14427C-----NON-COMMON VARIABLES-------------------------------------
14428C
14429      DIMENSION PX(*)
14430      DIMENSION PY(*)
14431C
14432      CHARACTER*4 IFIG
14433      CHARACTER*4 IPATT2
14434C
14435      CHARACTER*4 ILINPA
14436      CHARACTER*4 ILINCO
14437C
14438      CHARACTER*4 IREBLI
14439      CHARACTER*4 IREBCO
14440      CHARACTER*4 IREFSW
14441      CHARACTER*4 IREFCO
14442      CHARACTER*4 IREPTY
14443      CHARACTER*4 IREPLI
14444      CHARACTER*4 IREPCO
14445C
14446      CHARACTER*4 IPATT
14447      CHARACTER*4 ICOLF
14448      CHARACTER*4 ICOLP
14449      CHARACTER*4 ICOL
14450      CHARACTER*4 IFLAG
14451C
14452      DIMENSION ILINPA(*)
14453      DIMENSION ILINCO(*)
14454      DIMENSION PLINTH(*)
14455C
14456      DIMENSION AREGBA(*)
14457      DIMENSION IREBLI(*)
14458      DIMENSION IREBCO(*)
14459      DIMENSION PREBTH(*)
14460      DIMENSION IREFSW(*)
14461      DIMENSION IREFCO(*)
14462      DIMENSION IREPTY(*)
14463      DIMENSION IREPLI(*)
14464      DIMENSION IREPCO(*)
14465      DIMENSION PREPTH(*)
14466      DIMENSION PREPSP(*)
14467C
14468C-----COMMON----------------------------------------------------------
14469C
14470      INCLUDE 'DPCOGR.INC'
14471      INCLUDE 'DPCOBE.INC'
14472      INCLUDE 'DPCOP2.INC'
14473C
14474C-----START POINT-----------------------------------------------------
14475C
14476      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'NOR2')THEN
14477        WRITE(ICOUT,999)
14478  999   FORMAT(1X)
14479        CALL DPWRST('XXX','BUG ')
14480        WRITE(ICOUT,51)
14481   51   FORMAT('***** AT THE BEGINNING OF DPNOR2--')
14482        CALL DPWRST('XXX','BUG ')
14483        WRITE(ICOUT,53)X1,Y1,X2,Y2
14484   53   FORMAT('X1,Y1,X2,Y2 = ',4G15.7)
14485        CALL DPWRST('XXX','BUG ')
14486        WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1)
14487   61   FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',A4,2X,A4,G15.7)
14488        CALL DPWRST('XXX','BUG ')
14489        WRITE(ICOUT,62)IFIG,AREGBA(1)
14490   62   FORMAT('IFIG,AREGBA(1) = ',A4,2X,G15.7)
14491        CALL DPWRST('XXX','BUG ')
14492        WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1)
14493   63   FORMAT('IREBLI(1),IREBCO(1),PREBTH(1) = ',2(A4,2X),G15.7)
14494        CALL DPWRST('XXX','BUG ')
14495        WRITE(ICOUT,64)IREFSW(1),IREFCO(1)
14496   64   FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4)
14497        CALL DPWRST('XXX','BUG ')
14498        WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1)
14499   65   FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ',
14500     1         3(A4,2X),2G15.7)
14501        CALL DPWRST('XXX','BUG ')
14502        WRITE(ICOUT,69)PTEXHE,PTEXWI,PTEXHG,PTEXVG
14503   69   FORMAT('PTEXHE,PTEXWI,PTEXHG,PTEXVG = ',4G15.7)
14504        CALL DPWRST('XXX','BUG ')
14505        WRITE(ICOUT,79)IBUGG4,ISUBG4,IERRG4
14506   79   FORMAT('IBUGG4,ISUBG4,IERRG4 = ',2(A4,2X),A4)
14507        CALL DPWRST('XXX','BUG ')
14508      ENDIF
14509C
14510C               *********************************
14511C               **  STEP 1--                   **
14512C               **  DETERMINE THE COORDINATES  **
14513C               **  FOR THE LOGICAL NOR        **
14514C               *********************************
14515C
14516C
14517      POWER=1.4
14518      FACTOR=0.2
14519C
14520      DELX=X2-X1
14521      DELY=Y2-Y1
14522      ALEN=0.0
14523      TERM=(X2-X1)**2+(Y2-Y1)**2
14524      IF(TERM.GT.0.0)ALEN=SQRT(TERM)
14525      R=ALEN/2.0
14526      IF(ABS(DELX).GE.0.00001)THETA=ATAN(DELY/DELX)
14527      IF(ABS(DELX).LT.0.00001.AND.DELY.GE.0.0)THETA=3.1415926/2.0
14528      IF(ABS(DELX).LT.0.00001.AND.DELY.LT.0.0)THETA=-3.1415926/2.0
14529C
14530      K=0
14531C
14532      X=R
14533      Y=-R
14534      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
14535      K=K+1
14536      PX(K)=XP
14537      PY(K)=YP
14538C
14539      DO5310I=271,451,10
14540      PHI2=I-1
14541      PHI2=PHI2*(2.0*3.1415926)/360.0
14542      ABSCOS=ABS(COS(PHI2))
14543      ABSSIN=ABS(SIN(PHI2))
14544      X=R*(ABSCOS**POWER)
14545      Y=R*(ABSSIN**POWER)
14546      IF(SIN(PHI2).LT.0.0)Y=-Y
14547      X=X+R
14548      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
14549      K=K+1
14550      PX(K)=XP
14551      PY(K)=YP
14552 5310 CONTINUE
14553C
14554      X=0
14555      Y=R
14556      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
14557      K=K+1
14558      PX(K)=XP
14559      PY(K)=YP
14560C
14561      DO5320I=271,451,10
14562      PHI2=I-1
14563      PHI2=360.0-PHI2
14564      PHI2=PHI2*(2.0*3.1415926)/360.0
14565      X=FACTOR*R*COS(PHI2)
14566      Y=R*SIN(PHI2)
14567      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
14568      K=K+1
14569      PX(K)=XP
14570      PY(K)=YP
14571 5320 CONTINUE
14572C
14573      X=R
14574      Y=-R
14575      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
14576      K=K+1
14577      PX(K)=XP
14578      PY(K)=YP
14579C
14580      NP=K
14581C
14582C               ***********************
14583C               **  STEP 2--         **
14584C               **  FILL THE FIGURE  **
14585C               **  (IF CALLED FOR)  **
14586C               ***********************
14587C
14588      IF(IREFSW(1).EQ.'OFF')GOTO2190
14589      IPATT=IREPTY(1)
14590      IPATT2='SOLI'
14591      PTHICK=PREPTH(1)
14592      PXGAP=PREPSP(1)
14593      PYGAP=PREPSP(1)
14594      ICOLF=IREFCO(1)
14595      ICOLP=IREPCO(1)
14596      CALL DPFIRE(PX,PY,NP,
14597     1            IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,IPATT2)
14598 2190 CONTINUE
14599C
14600      IPATT=ILINPA(1)
14601      PTHICK=PLINTH(1)
14602      ICOL=ILINCO(1)
14603      IFLAG='ON'
14604      CALL DPDRPL(PX,PY,NP,
14605     1            IFIG,IPATT,PTHICK,ICOL,
14606     1            JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
14607C
14608      K=0
14609C
14610      X=-0.2*R
14611      Y=R
14612      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
14613      K=K+1
14614      PX(K)=XP
14615      PY(K)=YP
14616C
14617      DO5330I=271,451,10
14618      PHI2=I-1
14619      PHI2=360.0-PHI2
14620      PHI2=PHI2*(2.0*3.1415926)/360.0
14621      X=FACTOR*R*COS(PHI2)
14622      Y=R*SIN(PHI2)
14623      X=X-0.2*R
14624      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
14625      K=K+1
14626      PX(K)=XP
14627      PY(K)=YP
14628 5330 CONTINUE
14629C
14630      NP=K
14631C
14632      IPATT2='SOLI'
14633      IF(IREFSW(1).EQ.'ON')
14634     1CALL DPFIRE(PX,PY,NP,
14635     1            IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,IPATT2)
14636C
14637C
14638      IFLAG='ON'
14639      CALL DPDRPL(PX,PY,NP,
14640     1            IFIG,IPATT,PTHICK,ICOL,
14641     1            JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
14642C
14643C               *****************
14644C               **  STEP 90--  **
14645C               **  EXIT       **
14646C               *****************
14647C
14648      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'NOR2')THEN
14649        WRITE(ICOUT,999)
14650        CALL DPWRST('XXX','BUG ')
14651        WRITE(ICOUT,9011)
14652 9011   FORMAT('***** AT THE END       OF DPNOR2--')
14653        CALL DPWRST('XXX','BUG ')
14654        WRITE(ICOUT,9014)NP,IERRG4
14655 9014   FORMAT('NP,IERRG4 = ',I8,2X,A4)
14656        CALL DPWRST('XXX','BUG ')
14657        DO9015I=1,NP
14658          WRITE(ICOUT,9016)I,PX(I),PY(I)
14659 9016     FORMAT('I,PX(I),PY(I) = ',I8,2G15.7)
14660          CALL DPWRST('XXX','BUG ')
14661 9015   CONTINUE
14662      ENDIF
14663C
14664      RETURN
14665      END
14666      SUBROUTINE DPNOSM(IBUGA3,IBUGQ,IFOUND,IERROR)
14667C
14668C     PURPOSE--GENERATE NORMAL ORDER STATISTIC MEDIANS
14669C     WRITTEN BY--JAMES J. FILLIBEN
14670C                 STATISTICAL ENGINEERING DIVISION
14671C                 INFORMATION TECHNOLOGY LABORATORY
14672C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
14673C                 GAITHERSBURG, MD 20899-8980
14674C                 PHONE--301-975-2855
14675C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
14676C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
14677C     LANGUAGE--ANSI FORTRAN (1977)
14678C     VERSION NUMBER--82/7
14679C     ORIGINAL VERSION--APRIL     1986.
14680C
14681C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
14682C
14683      CHARACTER*4 IBUGA3
14684      CHARACTER*4 IBUGQ
14685      CHARACTER*4 IFOUND
14686      CHARACTER*4 IERROR
14687C
14688      CHARACTER*4 NEWNAM
14689      CHARACTER*4 NEWCOL
14690      CHARACTER*4 ICASEQ
14691      CHARACTER*4 ILEFT
14692      CHARACTER*4 ILEFT2
14693C
14694      CHARACTER*4 ISUBN1
14695      CHARACTER*4 ISUBN2
14696      CHARACTER*4 ISTEPN
14697C
14698C-----COMMON----------------------------------------------------------
14699C
14700      INCLUDE 'DPCOPA.INC'
14701      INCLUDE 'DPCOHK.INC'
14702      INCLUDE 'DPCODA.INC'
14703      INCLUDE 'DPCOP2.INC'
14704C
14705C-----START POINT-----------------------------------------------------
14706C
14707      ISUBN1='DPUO'
14708      ISUBN2='SM  '
14709      IFOUND='NO'
14710      IERROR='NO'
14711C
14712      MAXCP1=MAXCOL+1
14713      MAXCP2=MAXCOL+2
14714      MAXCP3=MAXCOL+3
14715      MAXCP4=MAXCOL+4
14716      MAXCP5=MAXCOL+5
14717      MAXCP6=MAXCOL+6
14718      NS2=0
14719C
14720C               ***********************************************
14721C               **  TREAT THE NORMAL ORDER STATISTIC MEDIANS CASE  **
14722C               **       1) FOR A FULL VARIABLE, OR          **
14723C               **       2) FOR PART OF A VARIABLE.          **
14724C               ***********************************************
14725C
14726      IF(IBUGA3.EQ.'OFF')GOTO90
14727      WRITE(ICOUT,999)
14728  999 FORMAT(1X)
14729      CALL DPWRST('XXX','BUG ')
14730      WRITE(ICOUT,51)
14731   51 FORMAT('***** AT THE BEGINNING OF DPNOSM--')
14732      CALL DPWRST('XXX','BUG ')
14733      WRITE(ICOUT,52)IBUGA3,IBUGQ
14734   52 FORMAT('IBUGA3,IBUGQ = ',A4,2X,A4)
14735      CALL DPWRST('XXX','BUG ')
14736   90 CONTINUE
14737C
14738C               **********************************
14739C               **  STEP 1--                    **
14740C               **  INITIALIZE SOME VARIABLES.  **
14741C               **********************************
14742C
14743      ISTEPN='1'
14744      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14745C
14746      NEWNAM='NO'
14747      NEWCOL='NO'
14748C
14749C               *******************************************************
14750C               **  STEP 2--                                         **
14751C               **  CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS.  **
14752C               *******************************************************
14753C
14754      ISTEPN='2'
14755      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14756C
14757      MINNA=3
14758      MAXNA=100
14759      CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,
14760     1IERROR)
14761      IF(IERROR.EQ.'YES')GOTO9000
14762C
14763C               ****************************************************************
14764C               **  STEP 3--                                                   *
14765C               **  EXAMINE THE LEFT-HAND SIDE--                               *
14766C               **  IS THE PARAMETER OR VARIABLE NAME TO LEFT OF = SIGN        *
14767C               **  ALREADY IN THE NAME LIST?                                  *
14768C               **  NOTE THAT     ILEFT      IS THE NAME OF THE VARIABLE       *
14769C               **  ON THE LEFT.                                               *
14770C               **  NOTE THAT     ILISTL    IS THE LINE IN THE TABLE           *
14771C               **  OF THE NAME ON THE LEFT.                                   *
14772C               **  NOTE THAT     ICOLL    IS THE DATA COLUMN (1 TO 12)        *
14773C               **  FOR THE NAME OF THE LEFT.                                  *
14774C               ****************************************************************
14775C
14776      ISTEPN='3'
14777      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14778C
14779CCCCC ILEFT=IHOL(2)
14780CCCCC ILEFT2=IHOL2(2)
14781      ILEFT=IHARG(1)
14782      ILEFT2=IHARG2(1)
14783      DO310I=1,NUMNAM
14784      I2=I
14785      IF(ILEFT.EQ.IHNAME(I).AND.ILEFT2.EQ.IHNAM2(I).AND.
14786     1IUSE(I).EQ.'P')GOTO329
14787      IF(ILEFT.EQ.IHNAME(I).AND.ILEFT2.EQ.IHNAM2(I).AND.
14788     1IUSE(I).EQ.'V')GOTO380
14789  310 CONTINUE
14790      NEWNAM='YES'
14791      ILISTL=NUMNAM+1
14792      IF(ILISTL.GT.MAXNAM)GOTO320
14793      GOTO330
14794C
14795  320 CONTINUE
14796      WRITE(ICOUT,999)
14797      CALL DPWRST('XXX','BUG ')
14798      WRITE(ICOUT,321)
14799  321 FORMAT('***** ERROR IN DPNOSM--')
14800      CALL DPWRST('XXX','BUG ')
14801      WRITE(ICOUT,322)
14802  322 FORMAT('      THE NUMBER OF VARIABLE AND/OR PARAMETER')
14803      CALL DPWRST('XXX','BUG ')
14804      WRITE(ICOUT,323)MAXNAM
14805  323 FORMAT('      NAMES HAS JUST EXCEEDED THE MAX ALLOWABLE ',
14806     1I8,'  .')
14807      CALL DPWRST('XXX','BUG ')
14808      WRITE(ICOUT,324)
14809  324 FORMAT('      SUGGESTED ACTION--')
14810      CALL DPWRST('XXX','BUG ')
14811      WRITE(ICOUT,325)
14812  325 FORMAT('      ENTER      STAT')
14813      CALL DPWRST('XXX','BUG ')
14814      WRITE(ICOUT,326)
14815  326 FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES,')
14816      CALL DPWRST('XXX','BUG ')
14817      WRITE(ICOUT,327)
14818  327 FORMAT('      AND THEN REDEFINE (REUSE) SOME OF THE')
14819      CALL DPWRST('XXX','BUG ')
14820      WRITE(ICOUT,328)
14821  328 FORMAT('      ALREADY-USED NAMES')
14822      CALL DPWRST('XXX','BUG ')
14823      IERROR='YES'
14824      GOTO9000
14825C
14826  329 CONTINUE
14827      ILISTL=I2
14828      GOTO330
14829C
14830  330 CONTINUE
14831      NLEFT=0
14832      ICOLL=NUMCOL+1
14833      IF(ICOLL.GT.MAXCOL)GOTO340
14834      GOTO390
14835C
14836  340 CONTINUE
14837      WRITE(ICOUT,341)
14838  341 FORMAT('***** ERROR IN DPNOSM--')
14839      CALL DPWRST('XXX','BUG ')
14840      WRITE(ICOUT,342)
14841  342 FORMAT('      THE NUMBER OF DATA COLUMNS')
14842      CALL DPWRST('XXX','BUG ')
14843      WRITE(ICOUT,343)MAXCOL
14844  343 FORMAT('      HAS JUST EXCEEDED THE MAX ALLOWABLE ',I8,'  .')
14845      CALL DPWRST('XXX','BUG ')
14846      WRITE(ICOUT,344)
14847  344 FORMAT('      SUGGESTED ACTION--')
14848      CALL DPWRST('XXX','BUG ')
14849      WRITE(ICOUT,345)
14850  345 FORMAT('      ENTER      STAT')
14851      CALL DPWRST('XXX','BUG ')
14852      WRITE(ICOUT,346)
14853  346 FORMAT('      TO FIND OUT THE FULL LIST OF USED COLUMNS')
14854      CALL DPWRST('XXX','BUG ')
14855      WRITE(ICOUT,347)
14856  347 FORMAT('      AND THEN OVERWRITE SOME COLUMNS.   EXAMPLE--')
14857      CALL DPWRST('XXX','BUG ')
14858      WRITE(ICOUT,348)
14859  348 FORMAT('      IF       LET X(I) = 3.14         FAILED')
14860      CALL DPWRST('XXX','BUG ')
14861      WRITE(ICOUT,349)
14862  349 FORMAT('      THEN ONE MIGHT ENTER     NAME X 7')
14863      CALL DPWRST('XXX','BUG ')
14864      WRITE(ICOUT,350)
14865  350 FORMAT('      (THEREBY EQUATING THE NAME X WITH COLUMN 7')
14866      CALL DPWRST('XXX','BUG ')
14867      WRITE(ICOUT,351)
14868  351 FORMAT('      FOLLOWED BY              LET X = 3.14')
14869      CALL DPWRST('XXX','BUG ')
14870      WRITE(ICOUT,352)
14871  352 FORMAT('      (WHICH WILL ACTUALLY OVERWRITE COLUMN 7')
14872      CALL DPWRST('XXX','BUG ')
14873      WRITE(ICOUT,353)
14874  353 FORMAT('      WITH THE NUMERIC CONSTANTS 3.14)')
14875      CALL DPWRST('XXX','BUG ')
14876      IERROR='YES'
14877      GOTO9000
14878C
14879  380 CONTINUE
14880      ILISTL=I2
14881      ICOLL=IVALUE(ILISTL)
14882      NLEFT=IN(ILISTL)
14883C
14884  390 CONTINUE
14885C
14886C               *****************************************
14887C               **  STEP 6--                           **
14888C               **  CHECK TO SEE THE TYPE SUBCASE      **
14889C               **  (BASED ON THE QUALIFIER)           **
14890C               **    1) UNQUALIFIED (THAT IS, FULL);  **
14891C               **    2) SUBSET/EXCEPT; OR             **
14892C               **    3) FOR.                          **
14893C               *****************************************
14894C
14895      ISTEPN='6'
14896      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14897C
14898      ICASEQ='FULL'
14899      ILOCQ=NUMARG+1
14900      IF(NUMARG.LT.1)GOTO670
14901      DO610J=1,NUMARG
14902      J1=J
14903      IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET  ')GOTO620
14904      IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT  ')GOTO620
14905      IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.'    ')GOTO630
14906  610 CONTINUE
14907      GOTO680
14908C
14909  620 CONTINUE
14910      ICASEQ='SUBS'
14911      ILOCQ=J1
14912      GOTO680
14913C
14914  630 CONTINUE
14915      ICASEQ='FOR'
14916      ILOCQ=J1
14917      GOTO680
14918C
14919  670 CONTINUE
14920      WRITE(ICOUT,999)
14921      CALL DPWRST('XXX','BUG ')
14922      WRITE(ICOUT,671)
14923  671 FORMAT('***** INTERNAL ERROR IN DPNOSM')
14924      CALL DPWRST('XXX','BUG ')
14925      WRITE(ICOUT,672)
14926  672 FORMAT('      AT BRANCH POINT 5081--')
14927      CALL DPWRST('XXX','BUG ')
14928      WRITE(ICOUT,673)
14929  673 FORMAT('      NUMARG LESS THAN 1 EVEN THOUGH')
14930      CALL DPWRST('XXX','BUG ')
14931      WRITE(ICOUT,674)
14932  674 FORMAT('      NUMARG HAD PREVIOUSLY PASSED THIS TEST')
14933      CALL DPWRST('XXX','BUG ')
14934      WRITE(ICOUT,675)NUMARG
14935  675 FORMAT('      ONCE ALREADY.  VALUE OF NUMARG = ',I8)
14936      CALL DPWRST('XXX','BUG ')
14937      WRITE(ICOUT,676)
14938  676 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
14939      CALL DPWRST('XXX','BUG ')
14940      IF(IWIDTH.GE.1)WRITE(ICOUT,677)(IANS(I),I=1,IWIDTH)
14941  677 FORMAT(80A1)
14942      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
14943      IERROR='YES'
14944      GOTO9000
14945C
14946  680 CONTINUE
14947      IF(IBUGA3.EQ.'OFF')GOTO690
14948      WRITE(ICOUT,681)NUMARG,ILOCQ,ICASEQ
14949  681 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4)
14950      CALL DPWRST('XXX','BUG ')
14951C
14952  690 CONTINUE
14953C
14954C               ******************************************************
14955C               **  STEP 7--                                        **
14956C               **  BRANCH TO THE APPROPRIATE SUBCASE               **
14957C               **  (BASED ON THE QUALIFIER);                       **
14958C               **  DETERMINE THE NUMBER (= NNOSM)                   **
14959C               **  OF NORMAL ORDER STATISTIC MEDIANS TO BE GENERATED.
14960C               **  NOTE THAT THE VARIABLE NIISUB                   **
14961C               **  IS THE LENGTH OF THE RESULTING                  **
14962C               **  VARIABLE ISUB(.).                               **
14963C               **  NOTE THAT DPFOR AUTOMATICALLY EXTENDS           **
14964C               **  THE INPUT LENGTH OF ISUB(.) IF NECESSARY.       **
14965C               **  (HENCE THE REDEFINITION OF NIISUB TO NINEW      **
14966C               **  AFTER THE CALL TO DPFOR.                        **
14967C               ******************************************************
14968C
14969      ISTEPN='7'
14970      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14971C
14972      IF(ICASEQ.EQ.'FULL')GOTO710
14973      IF(ICASEQ.EQ.'SUBS')GOTO720
14974      IF(ICASEQ.EQ.'FOR')GOTO730
14975C
14976  710 CONTINUE
14977      IF(NEWNAM.EQ.'NO')NIISUB=NLEFT
14978      IF(NEWNAM.EQ.'YES')NIISUB=MAXN
14979      DO715I=1,NIISUB
14980      ISUB(I)=1
14981  715 CONTINUE
14982      NNOSM=NIISUB
14983      GOTO750
14984C
14985  720 CONTINUE
14986      NIISUB=MAXN
14987      CALL DPSUBS(NIISUB,ILOCS,NS,IBUGQ,IERROR)
14988      NNOSM=NS
14989      GOTO750
14990C
14991  730 CONTINUE
14992      IF(NEWNAM.EQ.'NO')NIISUB=NLEFT
14993      IF(NEWNAM.EQ.'YES')NIISUB=MAXN
14994      CALL DPFOR(NIISUB,NINEW,IROW1,IROWN,
14995     1NLOCAL,ILOCS,NS,IBUGQ,IERROR)
14996      NIISUB=NINEW
14997      NNOSM=NS
14998      GOTO750
14999C
15000  750 CONTINUE
15001C
15002C               ******************************************
15003C               **  STEP 8--                            **
15004C               **  GENERATE    NNOSM    NORMAL ORDER   **
15005C               **  STATISTIC MEDIANS.                  **
15006C               **  STORE THEM TEMPORARILY IN           **
15007C               **  THE VECTOR Y(.).                    **
15008C               ******************************************
15009C
15010      ISTEPN='8'
15011      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15012C
15013      CALL UNIMED(NNOSM,Y)
15014C
15015      DO800I=1,NNOSM
15016      CALL NORPPF(Y(I),Y(I))
15017  800 CONTINUE
15018C
15019C               ***********************************************************
15020C               **  STEP 8--                                             **
15021C               **  IF CALLED FOR (THAT IS, IF IBUGA3 IS ON),      **
15022C               **  PRINT OUT THE INTERMEDIATE VARIABLE Y(.).            **
15023C               **  THIS IS USEFUL FOR DIAGNOSTIC PURPOSES               **
15024C               **  IN REVIEWING THE OUTPUT FROM THIS SUBROUTINE.        **
15025C               ***********************************************************
15026C
15027      ISTEPN='9'
15028      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15029C
15030      IF(IBUGA3.EQ.'OFF')GOTO2090
15031      WRITE(ICOUT,2051)
15032 2051 FORMAT('OUTPUT FROM MIDDLE OF DPNOSM AFTER UNIMED ',
15033     1'HAS BEEN CALLED--')
15034      CALL DPWRST('XXX','BUG ')
15035      WRITE(ICOUT,2052)NNOSM
15036 2052 FORMAT('NNOSM = ',I8)
15037      CALL DPWRST('XXX','BUG ')
15038      IF(NNOSM.LE.0)GOTO2090
15039      DO2054I=1,NNOSM
15040      WRITE(ICOUT,2055)I,Y(I)
15041 2055 FORMAT('I,Y(I) = ',I8,F12.5)
15042      CALL DPWRST('XXX','BUG ')
15043 2054 CONTINUE
15044C
15045 2090 CONTINUE
15046C
15047C               ******************************************************
15048C               **  STEP 9--                                        **
15049C               **  COPY THE ORDER STATISTIC MEDIANS                **
15050C               **  FROM THE INTERMEDIATE VECTOR Y(.)               **
15051C               **  TO THE APPROPRIATE COLUMN                       **
15052C               **  (BASED ON THE QUALIFIER--FULL, SUBSET, OR FOR)  **
15053C               **  IN THE INTERNAL DATAPLOT DATA TABLE.            **
15054C               ******************************************************
15055C
15056      ISTEPN='10'
15057      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15058C
15059      NS2=0
15060      DO2100I=1,NIISUB
15061      IJ=MAXN*(ICOLL-1)+I
15062      IF(ISUB(I).EQ.0)GOTO2100
15063      NS2=NS2+1
15064      IF(ICOLL.LE.MAXCOL)V(IJ)=Y(NS2)
15065      IF(ICOLL.EQ.MAXCP1)PRED(I)=Y(NS2)
15066      IF(ICOLL.EQ.MAXCP2)RES(I)=Y(NS2)
15067      IF(ICOLL.EQ.MAXCP3)YPLOT(I)=Y(NS2)
15068      IF(ICOLL.EQ.MAXCP4)XPLOT(I)=Y(NS2)
15069      IF(ICOLL.EQ.MAXCP5)X2PLOT(I)=Y(NS2)
15070      IF(ICOLL.EQ.MAXCP6)TAGPLO(I)=Y(NS2)
15071      IF(NS2.EQ.1)IROW1=I
15072      IROWN=I
15073 2100 CONTINUE
15074C
15075C               *******************************************
15076C               **  STEP 10--                            **
15077C               **  CARRY OUT THE LIST UPDATING AND      **
15078C               **  GENERATE THE INFORMATIVE PRINTING.   **
15079C               *******************************************
15080C
15081      ISTEPN='11'
15082      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15083C
15084      IF(ICASEQ.EQ.'FULL'.AND.NEWNAM.EQ.'NO')NINEW=NLEFT
15085      IF(ICASEQ.EQ.'FULL'.AND.NEWNAM.EQ.'YES')NINEW=MAXN
15086      IF(ICASEQ.EQ.'SUBS'.AND.NEWNAM.EQ.'NO'.AND.
15087     1NLEFT.GE.IROWN)NINEW=NLEFT
15088      IF(ICASEQ.EQ.'SUBS'.AND.NEWNAM.EQ.'NO'.AND.
15089     1NLEFT.LT.IROWN)NINEW=IROWN
15090      IF(ICASEQ.EQ.'SUBS'.AND.NEWNAM.EQ.'YES')NINEW=IROWN
15091      IF(ICASEQ.EQ.'FOR'.AND.NEWNAM.EQ.'NO'.AND.
15092     1NLEFT.GE.IROWN)NINEW=NLEFT
15093      IF(ICASEQ.EQ.'FOR'.AND.NEWNAM.EQ.'NO'.AND.
15094     1NLEFT.LT.IROWN)NINEW=IROWN
15095      IF(ICASEQ.EQ.'FOR'.AND.NEWNAM.EQ.'YES')NINEW=IROWN
15096C
15097      IHNAME(ILISTL)=ILEFT
15098      IHNAM2(ILISTL)=ILEFT2
15099      IUSE(ILISTL)='V'
15100      IVALUE(ILISTL)=ICOLL
15101      VALUE(ILISTL)=ICOLL
15102      IN(ILISTL)=NINEW
15103C
15104CCCCC IUSE(ICOLL)='V'
15105CCCCC IVALUE(ICOLL)=ICOLL
15106CCCCC VALUE(ICOLL)=ICOLL
15107CCCCC IN(ICOLL)=NINEW
15108C
15109      IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1
15110      IF(NEWNAM.EQ.'YES')NUMCOL=NUMCOL+1
15111C
15112      DO4100J4=1,NUMNAM
15113      IF(IUSE(J4).EQ.'V'.AND.IVALUE(J4).EQ.ICOLL)GOTO4105
15114      GOTO4100
15115 4105 CONTINUE
15116      IUSE(J4)='V'
15117      IVALUE(J4)=ICOLL
15118      VALUE(J4)=ICOLL
15119      IN(J4)=NINEW
15120 4100 CONTINUE
15121C
15122      IF(IPRINT.EQ.'OFF')GOTO4059
15123      IF(IFEEDB.EQ.'OFF')GOTO4059
15124      WRITE(ICOUT,999)
15125      CALL DPWRST('XXX','BUG ')
15126      WRITE(ICOUT,4011)ILEFT,ILEFT2,NS2
15127 4011 FORMAT('THE NUMBER OF VALUES GENERATED FOR ',
15128     1'THE VARIABLE ',A4,A4,' = ',I8)
15129      CALL DPWRST('XXX','BUG ')
15130      WRITE(ICOUT,999)
15131      CALL DPWRST('XXX','BUG ')
15132C
15133      IJ=MAXN*(ICOLL-1)+IROW1
15134      IF(ICOLL.LE.MAXCOL)WRITE(ICOUT,4021)ILEFT,ILEFT2,V(IJ),IROW1
15135 4021 FORMAT('THE FIRST           COMPUTED VALUE OF ',A4,A4,
15136     1' = ',E15.7,'   (ROW ',I6,')')
15137      IF(ICOLL.LE.MAXCOL)CALL DPWRST('XXX','BUG ')
15138      IF(ICOLL.EQ.MAXCP1)WRITE(ICOUT,4021)ILEFT,ILEFT2,PRED(IROW1),
15139     1IROW1
15140      IF(ICOLL.EQ.MAXCP1)CALL DPWRST('XXX','BUG ')
15141      IF(ICOLL.EQ.MAXCP2)WRITE(ICOUT,4021)ILEFT,ILEFT2,RES(IROW1),IROW1
15142      IF(ICOLL.EQ.MAXCP2)CALL DPWRST('XXX','BUG ')
15143      IF(ICOLL.EQ.MAXCP3)WRITE(ICOUT,4021)ILEFT,ILEFT2,YPLOT(IROW1),
15144     1IROW1
15145      IF(ICOLL.EQ.MAXCP3)CALL DPWRST('XXX','BUG ')
15146      IF(ICOLL.EQ.MAXCP4)WRITE(ICOUT,4021)ILEFT,ILEFT2,XPLOT(IROW1),
15147     1IROW1
15148      IF(ICOLL.EQ.MAXCP4)CALL DPWRST('XXX','BUG ')
15149      IF(ICOLL.EQ.MAXCP5)WRITE(ICOUT,4021)ILEFT,ILEFT2,X2PLOT(IROW1),
15150     1IROW1
15151      IF(ICOLL.EQ.MAXCP5)CALL DPWRST('XXX','BUG ')
15152      IF(ICOLL.EQ.MAXCP6)WRITE(ICOUT,4021)ILEFT,ILEFT2,TAGPLO(IROW1),
15153     1IROW1
15154      IF(ICOLL.EQ.MAXCP6)CALL DPWRST('XXX','BUG ')
15155C
15156      IJ=MAXN*(ICOLL-1)+IROWN
15157      IF(ICOLL.LE.MAXCOL.AND.
15158     1NS2.NE.1)WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,V(IJ),IROWN
15159 4031 FORMAT('THE LAST (',I5,'-TH) COMPUTED VALUE OF ',A4,A4,
15160     1' = ',E15.7,'   (ROW ',I6,')')
15161      IF(ICOLL.LE.MAXCOL.AND.
15162     1NS2.NE.1)CALL DPWRST('XXX','BUG ')
15163      IF(ICOLL.EQ.MAXCP1.AND.
15164     1NS2.NE.1)WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,PRED(IROWN),IROWN
15165      IF(ICOLL.EQ.MAXCP1.AND.
15166     1NS2.NE.1)CALL DPWRST('XXX','BUG ')
15167      IF(ICOLL.EQ.MAXCP2.AND.
15168     1NS2.NE.1)WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,RES(IROWN),IROWN
15169      IF(ICOLL.EQ.MAXCP2.AND.
15170     1NS2.NE.1)CALL DPWRST('XXX','BUG ')
15171      IF(ICOLL.EQ.MAXCP3.AND.
15172     1NS2.NE.1)WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,YPLOT(IROWN),IROWN
15173      IF(ICOLL.EQ.MAXCP3.AND.
15174     1NS2.NE.1)CALL DPWRST('XXX','BUG ')
15175      IF(ICOLL.EQ.MAXCP4.AND.
15176     1NS2.NE.1)WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,XPLOT(IROWN),IROWN
15177      IF(ICOLL.EQ.MAXCP4.AND.
15178     1NS2.NE.1)CALL DPWRST('XXX','BUG ')
15179      IF(ICOLL.EQ.MAXCP5.AND.
15180     1NS2.NE.1)WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,X2PLOT(IROWN),IROWN
15181      IF(ICOLL.EQ.MAXCP5.AND.
15182     1NS2.NE.1)CALL DPWRST('XXX','BUG ')
15183      IF(ICOLL.EQ.MAXCP6.AND.
15184     1NS2.NE.1)WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,TAGPLO(IROWN),IROWN
15185      IF(ICOLL.EQ.MAXCP6.AND.
15186     1NS2.NE.1)CALL DPWRST('XXX','BUG ')
15187      IF(NS2.NE.1)GOTO4090
15188      WRITE(ICOUT,4041)
15189 4041 FORMAT('SINCE THE GENERATED SAMPLE SIZE WAS ONLY 1,')
15190      CALL DPWRST('XXX','BUG ')
15191      WRITE(ICOUT,4042)
15192 4042 FORMAT('THE ABOVE VALUE WAS THE SOLE VALUE COMPUTED.')
15193      CALL DPWRST('XXX','BUG ')
15194 4090 CONTINUE
15195      WRITE(ICOUT,999)
15196      CALL DPWRST('XXX','BUG ')
15197      WRITE(ICOUT,4112)ILEFT,ILEFT2,ICOLL
15198 4112 FORMAT('THE CURRENT COLUMN FOR ',
15199     1'THE VARIABLE ',A4,A4,' = ',I8)
15200      CALL DPWRST('XXX','BUG ')
15201      WRITE(ICOUT,4113)ILEFT,ILEFT2,NINEW
15202 4113 FORMAT('THE CURRENT LENGTH OF  ',
15203     1'THE VARIABLE ',A4,A4,' = ',I8)
15204      CALL DPWRST('XXX','BUG ')
15205      WRITE(ICOUT,999)
15206      CALL DPWRST('XXX','BUG ')
15207      WRITE(ICOUT,999)
15208      CALL DPWRST('XXX','BUG ')
15209 4059 CONTINUE
15210C
15211C               *****************
15212C               **  STEP 90--  **
15213C               **  EXIT       **
15214C               *****************
15215C
15216 9000 CONTINUE
15217      IF(IBUGA3.EQ.'OFF')GOTO9090
15218      WRITE(ICOUT,999)
15219      CALL DPWRST('XXX','BUG ')
15220      WRITE(ICOUT,9011)
15221 9011 FORMAT('***** AT THE END       OF DPNOSM--')
15222      CALL DPWRST('XXX','BUG ')
15223      WRITE(ICOUT,9012)IFOUND,IERROR
15224 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
15225      CALL DPWRST('XXX','BUG ')
15226      WRITE(ICOUT,9013)IBUGA3,IBUGQ
15227 9013 FORMAT('IBUGA3,IBUGQ = ',A4,2X,A4)
15228      CALL DPWRST('XXX','BUG ')
15229      WRITE(ICOUT,9015)NS2
15230 9015 FORMAT('NS2 = ',I8)
15231      CALL DPWRST('XXX','BUG ')
15232      WRITE(ICOUT,9016)NS,NIISUB,NNOSM
15233 9016 FORMAT('NS,NIISUB,NNOSM = ',I8,I8,I8)
15234      CALL DPWRST('XXX','BUG ')
15235 9090 CONTINUE
15236C
15237      RETURN
15238      END
15239      FUNCTION DPNTLI (X1,Y1,X2,Y2,S,IBUGA3)
15240C
15241C     PURPOSE--COMPUTE THE PERPINDICULAR DISTANCE BETWEEN THE
15242C              POINT (X1,Y1) AND THE LINE DEFINED BY
15243C              THE POINT (X2,Y2) WITH SLOPE S.
15244C
15245C              THE FORMULA IS:
15246C
15247C                  D = |M*X1 - Y1 + B|/SQRT(M**2 + 1)
15248C
15249C              WHERE THE LINE IS DEFINED AS
15250C
15251C                  Y = M*X + B
15252C
15253C     WRITTEN BY--ALAN HECKERT
15254C                 STATISTICAL ENGINEERING DIVISION
15255C                 INFORMATION TECHNOLOGY LABORATORY
15256C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
15257C                 GAITHERSBURG, MD 20899-8980
15258C                 PHONE--301-975-2899
15259C     REFERENCE--BOWYER AND WOODWARK (1983), "A PROGRAMMER'S
15260C                GEOMETRY", BUTTERWORTHS, PP. 12-13.
15261C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
15262C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
15263C     LANGUAGE--ANSI FORTRAN (1977)
15264C     VERSION NUMBER--2012.10
15265C     ORIGINAL VERSION--OCTOBER   2012.
15266C     UPDATED--APRIL     1992.  GIVE VALUES TO X1 AND Y1
15267C
15268C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------
15269C
15270      CHARACTER*4 IBUGA3
15271C
15272C-----COMMON VARIABLES (GENERAL)--------------------------------------
15273C
15274      INCLUDE 'DPCOP2.INC'
15275C
15276C-----START POINT-----------------------------------------------------
15277C
15278      IF(IBUGA3.EQ.'ON')THEN
15279        WRITE(ICOUT,51)
15280   51   FORMAT('AT THE BEGININNING OF DPNTLI')
15281        CALL DPWRST('XXX','BUG ')
15282        WRITE(ICOUT,53)X1,Y1,X2,Y2,S
15283   53   FORMAT('X1,Y1,X2,Y2,S = ',5G15.7)
15284        CALL DPWRST('XXX','BUG ')
15285      ENDIF
15286C
15287      B=Y2 - S*X2
15288      ANUM=S*X1 - Y1 + B
15289      DENOM=S**2 + 1.0
15290      DPNTLI=ABS(ANUM)/DENOM
15291C
15292      IF(IBUGA3.EQ.'ON')THEN
15293        WRITE(ICOUT,9051)
15294 9051   FORMAT('AT THE END OF DPNTLI')
15295        CALL DPWRST('XXX','BUG ')
15296        WRITE(ICOUT,9053)B,ANUM,DENOM,DPNTLI
15297 9053   FORMAT('B,ANUM,DENOM,DPNTLI = ',4G15.7)
15298        CALL DPWRST('XXX','BUG ')
15299      ENDIF
15300C
15301      RETURN
15302      END
15303      SUBROUTINE DPNUST(IFORSW,ISUBRO,IBUGA3,IERROR)
15304C
15305C     PURPOSE--CONVERT A SINGLE PARAMETER TO A STRING.  USE
15306C              THE "SET WRITE DECIMAL" COMMAND TO DETERMINE
15307C              HOW TO FORMAT THE STRING.  THIS IS USEFUL IN
15308C              CONJUNCTION WITH THE TEXT STRING WHICH TENDS
15309C              TO TRUNCATE TRAILING DIGITS.
15310C     EXAMPLE--LET SOUT = NUMBER TO STRING A
15311C     WRITTEN BY--ALAN HECKERT
15312C                 STATISTICAL ENGINEERING DIVISION
15313C                 INFORMATION TECHNOLOGY LABORATORY
15314C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
15315C                 GAITHERSBURG, MD 20899-8980
15316C                 PHONE--301-975-2899
15317C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
15318C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
15319C     LANGUAGE--ANSI FORTRAN (1977)
15320C     VERSION NUMBER--2015/06
15321C     ORIGINAL VERSION--JUNE      2015.
15322C
15323C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
15324C
15325      CHARACTER*4 IFORSW
15326      CHARACTER*4 ISUBRO
15327      CHARACTER*4 IBUGA3
15328      CHARACTER*4 IERROR
15329C
15330      CHARACTER*4 NEWNAM
15331      CHARACTER*4 NEWCOL
15332      CHARACTER*4 ICASEL
15333      CHARACTER*4 ICASER
15334      CHARACTER*4 IHLEFT
15335      CHARACTER*4 IHLEF2
15336      CHARACTER*4 IHRIGH
15337      CHARACTER*4 IHRIG2
15338C
15339      CHARACTER*4 ISUBN1
15340      CHARACTER*4 ISUBN2
15341      CHARACTER*4 ISTEPN
15342C
15343      CHARACTER*20  IFORMT
15344      CHARACTER*240 ISTR
15345C
15346      CHARACTER*4 ILAB(10)
15347C
15348C---------------------------------------------------------------------
15349C
15350C-----COMMON----------------------------------------------------------
15351C
15352      INCLUDE 'DPCOPA.INC'
15353      INCLUDE 'DPCOHK.INC'
15354      INCLUDE 'DPCODA.INC'
15355      INCLUDE 'DPCOP2.INC'
15356C
15357C-----START POINT-----------------------------------------------------
15358C
15359      ISUBN1='DPNU'
15360      ISUBN2='ST  '
15361      IERROR='NO'
15362C
15363      ILOC3=0
15364C
15365      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NUST')THEN
15366        WRITE(ICOUT,999)
15367        CALL DPWRST('XXX','BUG ')
15368        WRITE(ICOUT,51)
15369   51   FORMAT('***** AT THE BEGINNING OF DPNUST--')
15370        CALL DPWRST('XXX','BUG ')
15371        WRITE(ICOUT,52)IBUGA3,ISUBRO,IFORSW,NUMNAM,NUMCHF,MAXCHF
15372   52   FORMAT('IBUGA3,ISUBRO,IFORSW,NUMNAM,NUMCHF,MAXCHF = ',
15373     1         3(A4,2X),3I8)
15374        CALL DPWRST('XXX','BUG ')
15375        DO55I=1,NUMNAM
15376          WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),
15377     1                   IVSTOP(I)
15378   56     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
15379     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
15380          CALL DPWRST('XXX','BUG ')
15381   55   CONTINUE
15382        WRITE(ICOUT,60)(IFUNC(I),I=1,MIN(120,MAXCHF))
15383   60   FORMAT('IFUNC(.)  = ',120A1)
15384        CALL DPWRST('XXX','BUG ')
15385      ENDIF
15386C
15387C               **********************************
15388C               **  STEP 1--                    **
15389C               **  INITIALIZE SOME VARIABLES.  **
15390C               **********************************
15391C
15392      ISTEPN='1'
15393      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NUST')
15394     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15395C
15396      NEWNAM='NO'
15397      NEWCOL='NO'
15398      ICASEL='UNKN'
15399      NIOLD1=0
15400      ICOLL=0
15401C
15402C               ******************************************************
15403C               **  STEP 2--                                         *
15404C               **  EXAMINE THE ARGUMENT ON THE                      *
15405C               **  LEFT-HAND SIDE--                                 *
15406C               **  IF THIS IS A PREVIOUSLY DEFINED NAME, IT SHOULD  *
15407C               **  BE A STRING    (IF NOT, REPORT AN ERROR).        *
15408C               ******************************************************
15409C
15410      ISTEPN='2'
15411      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NUST')
15412     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15413C
15414      ISTRT=1
15415      IF(IHARG(1).EQ.'STRI' .AND. IHARG(2).EQ.'NG  ')ISTRT=2
15416      IHLEFT=IHARG(ISTRT)
15417      IHLEF2=IHARG2(ISTRT)
15418C
15419      DO2000I=1,NUMNAM
15420        I2=I
15421        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
15422          IF(IUSE(I2).EQ.'F')THEN
15423            ICASEL='STRI'
15424            ILISTL=I2
15425            GOTO2299
15426          ELSE
15427            WRITE(ICOUT,999)
15428  999       FORMAT(1X)
15429            CALL DPWRST('XXX','BUG ')
15430            WRITE(ICOUT,2001)
15431 2001       FORMAT('***** ERROR IN NUMBER TO STRING--')
15432            CALL DPWRST('XXX','BUG ')
15433            WRITE(ICOUT,2003)IHLEFT,IHLEF2
15434 2003       FORMAT('      THE FIRST NAME ON THE LEFT HAND SIDE (',
15435     1             A4,A4,')')
15436            CALL DPWRST('XXX','BUG ')
15437            WRITE(ICOUT,2005)
15438 2005       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
15439            CALL DPWRST('XXX','BUG ')
15440            IERROR='YES'
15441            GOTO9000
15442          ENDIF
15443        ENDIF
15444 2000 CONTINUE
15445C
15446      NEWNAM='YES'
15447      IF(ICASEL.EQ.'UNKN')ICASEL='STRI'
15448C
15449      ILISTL=NUMNAM+1
15450      IF(ILISTL.GT.MAXNAM)THEN
15451        WRITE(ICOUT,999)
15452        CALL DPWRST('XXX','BUG ')
15453        WRITE(ICOUT,2001)
15454        CALL DPWRST('XXX','BUG ')
15455        WRITE(ICOUT,2202)
15456 2202   FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND ',
15457     1         'FUNCTION')
15458        CALL DPWRST('XXX','BUG ')
15459        WRITE(ICOUT,2203)MAXNAM
15460 2203   FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
15461        CALL DPWRST('XXX','BUG ')
15462        WRITE(ICOUT,2204)
15463 2204   FORMAT('      ENTER      STATUS')
15464        CALL DPWRST('XXX','BUG ')
15465        WRITE(ICOUT,2205)
15466 2205   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES, AND')
15467        CALL DPWRST('XXX','BUG ')
15468        WRITE(ICOUT,2206)
15469 2206   FORMAT('      THEN REDEFINE OR DELETE SOME OF THE ALREADY ',
15470     1         'USED NAMES.')
15471        CALL DPWRST('XXX','BUG ')
15472        IERROR='YES'
15473        GOTO9000
15474      ENDIF
15475C
15476 2299 CONTINUE
15477C
15478C               *****************************************************
15479C               **  STEP 3--                                       **
15480C               **  EXTRACT THE FIRST NAME ON THE RIGHT HAND SIDE  **
15481C               *****************************************************
15482C
15483      ISTEPN='3A'
15484      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NUST')
15485     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15486C
15487      ISTRT=ISTRT+5
15488      IHRIGH=IHARG(ISTRT)
15489      IHRIG2=IHARG2(ISTRT)
15490      DO3000I=1,NUMNAM
15491        I4=I
15492        IF(IHRIGH.EQ.IHNAME(I).AND.IHRIG2.EQ.IHNAM2(I))THEN
15493          IF(IUSE(I4).EQ.'P')THEN
15494            ICASER='PARA'
15495            ILISTR=I4
15496            AVAL=VALUE(ILISTR)
15497            NIOLD=1
15498            GOTO3099
15499          ELSE
15500            WRITE(ICOUT,999)
15501            CALL DPWRST('XXX','BUG ')
15502            WRITE(ICOUT,2001)
15503            CALL DPWRST('XXX','BUG ')
15504            WRITE(ICOUT,3003)IHRIGH,IHRIG2
15505 3003       FORMAT('      THE NAME ON THE RIGHT HAND SIDE (',
15506     1             A4,A4,')')
15507            CALL DPWRST('XXX','BUG ')
15508            WRITE(ICOUT,3005)
15509 3005       FORMAT('      ALREADY EXISTS, BUT NOT AS A PARAMETER.')
15510            CALL DPWRST('XXX','BUG ')
15511            IERROR='YES'
15512            GOTO9000
15513          ENDIF
15514        ENDIF
15515 3000 CONTINUE
15516C
15517      IF(NUMARG.GE.ISTRT)THEN
15518        IF(IARGT(ISTRT).EQ.'NUMB')THEN
15519          AVAL=ARG(ISTRT)
15520          ICASER='PARA'
15521          GOTO3099
15522        ENDIF
15523      ENDIF
15524C
15525      WRITE(ICOUT,999)
15526      CALL DPWRST('XXX','BUG ')
15527      WRITE(ICOUT,2001)
15528      CALL DPWRST('XXX','BUG ')
15529      WRITE(ICOUT,3003)IHRIGH,IHRIG2
15530      CALL DPWRST('XXX','BUG ')
15531      WRITE(ICOUT,3015)
15532 3015 FORMAT('      WAS NOT FOUND IN THE CURRENT NAME LIST.')
15533      CALL DPWRST('XXX','BUG ')
15534      IERROR='YES'
15535      GOTO9000
15536C
15537 3099 CONTINUE
15538C
15539C               *****************************************************
15540C               **  STEP 4--                                       **
15541C               **  CREATE THE STRING                              **
15542C               *****************************************************
15543C
15544      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NUST')THEN
15545        ISTEPN='4'
15546        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15547        WRITE(ICOUT,4011)ILISTR,NIOLD
15548 4011   FORMAT('ILISTR,NIOLD = ',2I8)
15549        CALL DPWRST('XXX','BUG ')
15550        WRITE(ICOUT,4013)ICASEL,ICASER
15551 4013   FORMAT('ICASEL,ICASER = ',A4,2X,A4)
15552        CALL DPWRST('XXX','BUG ')
15553      ENDIF
15554C
15555      NUMDIG=7
15556      IF(IFORSW.EQ.'1')NUMDIG=1
15557      IF(IFORSW.EQ.'2')NUMDIG=2
15558      IF(IFORSW.EQ.'3')NUMDIG=3
15559      IF(IFORSW.EQ.'4')NUMDIG=4
15560      IF(IFORSW.EQ.'5')NUMDIG=5
15561      IF(IFORSW.EQ.'6')NUMDIG=6
15562      IF(IFORSW.EQ.'7')NUMDIG=7
15563      IF(IFORSW.EQ.'8')NUMDIG=8
15564      IF(IFORSW.EQ.'9')NUMDIG=9
15565      IF(IFORSW.EQ.'0')NUMDIG=0
15566      IF(IFORSW.EQ.'E')NUMDIG=-2
15567      IF(IFORSW.EQ.'-2')NUMDIG=-2
15568      IF(IFORSW.EQ.'-3')NUMDIG=-3
15569      IF(IFORSW.EQ.'-4')NUMDIG=-4
15570      IF(IFORSW.EQ.'-5')NUMDIG=-5
15571      IF(IFORSW.EQ.'-6')NUMDIG=-6
15572      IF(IFORSW.EQ.'-7')NUMDIG=-7
15573      IF(IFORSW.EQ.'-8')NUMDIG=-8
15574      IF(IFORSW.EQ.'-9')NUMDIG=-9
15575C
15576C     SUPPORT THE FOLLOWING FORMATTING OPTIONS
15577C
15578C         NUMDIG > 0          => Fyy.xx FORMAT
15579C         NUMDIG = 0          => I12 FORMAT
15580C         NUMDIG = -1         => BLANK
15581C         NUMDIG = -3 to -20  => Eyy.xx
15582C         NUMDIG = -99        => '**'
15583C
15584C     START WITH NCHTOT = 20 AND THEN AFTER STRING IS
15585C     CREATED REMOVE THE LEADING BLANKS
15586C
15587      ISTR=' '
15588      NCSTR=0
15589      NCHTOT=20
15590C
15591      IF(NUMDIG.GT.0)THEN
15592        NCHDEC=NUMDIG
15593        CALL GRTRRE(AVAL,NCHTOT,NCHDEC,ISTR,NCSTR)
15594      ELSEIF(NUMDIG.EQ.0)THEN
15595        IF(AVAL.GE.0.0)THEN
15596          ITEMP=INT(AVAL+0.5)
15597        ELSE
15598          ITEMP=INT(AVAL-0.5)
15599        ENDIF
15600        CALL GRTRIN(ITEMP,NCHTOT,ISTR,NCSTR)
15601      ELSEIF(NUMDIG.EQ.-1)THEN
15602        NCSTR=NCSTR+1
15603        ISTR(NCSTR:NCSTR)=' '
15604      ELSEIF(NUMDIG.LE.-2 .AND. NUMDIG.GT.-20)THEN
15605        IXX=ABS(NUMDIG)
15606        IYY=IXX+8
15607        NCSTR=NCSTR+1
15608        NCSTR2=NCSTR+IYY-1
15609        IFORMT='(E  .  )'
15610        WRITE(IFORMT(3:4),'(I2)')IYY
15611        WRITE(IFORMT(6:7),'(I2)')IXX
15612        WRITE(ISTR(NCSTR:NCSTR2),IFORMT)AVAL
15613        NCSTR=NCSTR2
15614      ELSEIF(NUMDIG.EQ.-99)THEN
15615        NCSTR=2
15616        ISTR(1:NCSTR)='**'
15617        NCHTOT=2
15618      ELSE
15619        NCSTR=NCSTR+1
15620        ISTR(NCSTR:NCSTR)=' '
15621        NCHTOT=1
15622      ENDIF
15623C
15624      IF(NCHTOT.GT.2)THEN
15625        DO4110I=1,NCHTOT
15626          IF(ISTR(I:I).NE.' ')THEN
15627            IFRST=I
15628            GOTO4119
15629          ENDIF
15630 4110   CONTINUE
15631        NCHTOT=1
15632        IFRST=1
15633 4119   CONTINUE
15634      ELSE
15635        IFRST=1
15636      ENDIF
15637C
15638      IF(NCHTOT.GT.2)THEN
15639        DO4120I=NCHTOT,IFRST,-1
15640          IF(ISTR(I:I).NE.' ')THEN
15641            ILAST=I
15642            GOTO4129
15643          ENDIF
15644 4120   CONTINUE
15645        ILAST=IFRST
15646 4129   CONTINUE
15647      ELSE
15648        ILAST=NCHTOT
15649      ENDIF
15650C
15651      ICNT=0
15652      DO4130I=IFRST,ILAST
15653        ICNT=ICNT+1
15654        IFUNC2(ICNT)(1:1)=ISTR(I:I)
15655 4130 CONTINUE
15656C
15657C               *****************************************************
15658C               **  STEP 5--                                       **
15659C               **  SAVE STRING AND PRINT FEEDBACK MESSAGE         **
15660C               *****************************************************
15661C
15662C
15663      IF(ICASEL.EQ.'STRI')THEN
15664C
15665        ISTEPN='5'
15666        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NUST')
15667     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15668C
15669        CALL DPINFU(IFUNC2,ICNT,IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP,
15670     1              NUMNAM,IANS,IWIDTH,IHLEFT,IHLEF2,ILISTL,
15671     1              NEWNAM,MAXNAM,
15672     1              IFUNC,NUMCHF,MAXCHF,IBUGA3,IERROR)
15673        IF(IERROR.EQ.'YES')GOTO9000
15674C
15675        IF(IFEEDB.EQ.'ON' .AND. IPRINT.EQ.'ON')THEN
15676          WRITE(ICOUT,999)
15677          CALL DPWRST('XXX','BUG ')
15678          WRITE(ICOUT,6606)IHLEFT,IHLEF2
15679 6606     FORMAT('THE NAME ',A4,A4,' HAS JUST BEEN EQUIVALENCED ')
15680          CALL DPWRST('XXX','BUG ')
15681          ILAB(1)='TO T'
15682          ILAB(2)='HE F'
15683          ILAB(3)='UNCT'
15684          ILAB(4)='ION '
15685          ILAB(5)='    '
15686          ILAB(6)=' -- '
15687          NUMWDL=6
15688          CALL DPPRIF(ILAB,NUMWDL,IFUNC2,ICNT,IBUGA3)
15689C
15690          WRITE(ICOUT,999)
15691          CALL DPWRST('XXX','BUG ')
15692C
15693        ENDIF
15694      ENDIF
15695C
15696C
15697C               ****************
15698C               **  STEP 90-- **
15699C               **  EXIT.     **
15700C               ****************
15701C
15702 9000 CONTINUE
15703      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NUST')THEN
15704        WRITE(ICOUT,999)
15705        CALL DPWRST('XXX','BUG ')
15706        WRITE(ICOUT,9011)
15707 9011   FORMAT('***** AT THE END       OF DPNUST--')
15708        CALL DPWRST('XXX','BUG ')
15709        WRITE(ICOUT,9013)NUMNAM,AVAL
15710 9013   FORMAT('NUMNAM,AVAL = ',I8,2X,G15.7)
15711        CALL DPWRST('XXX','BUG ')
15712        DO9015I=1,NUMNAM
15713          WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),
15714     1                     IVSTAR(I),IVSTOP(I)
15715 9016     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
15716     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
15717          CALL DPWRST('XXX','BUG ')
15718 9015   CONTINUE
15719      ENDIF
15720C
15721      RETURN
15722      END
15723      SUBROUTINE DPNUWO(ISTRIN,ISTART,ISTOP,NWORD,
15724     1                  IBUGS2,ISUBRO,IERROR)
15725C
15726C     PURPOSE--SCAN ISTRIN BETWEEN COLUMNS ISTART TO ISTOP AND DETERMINE
15727C              THE NUMBER OF WORDS IN THE STRING.  NOTE THAT THIS CAN
15728C              GIVE A DIFFERENT RESULT THAT DPTYPE.  THIS IS PRIMARILY
15729C              A UTILITY ROUTINE USED BY DPMACR WHEN PARSING COMMAND
15730C              LINE ARGUMENTS.  SPECIFICALLY,
15731C
15732C                 1. WANT TO TREAT
15733C
15734C                      FRAME="FOR I = 1 1 50"
15735C                      "FRAME=FOR I = 1 1 50"
15736C
15737C                    THIS IS A PRIMARY DIFFERENCE WITH DPTYPE SINCE
15738C                    DPTYPE DOES NOT RESTRICT ITEMS WITHIN QUOTES TO
15739C                    A SINGLE QUOTE.
15740C
15741C                 2. SO TREAT SPACE AND COMMAS AS THE DELIMITERS.
15742C                    HOWEVER, SPACES AND COMMAS WITHIN QUOTES ARE
15743C                    NOT TREATED AS DELIMITERS.
15744C
15745C                 3. A QUOTE PRECEEDED BY AN "=" IS NOT A DELIMITER.
15746C                    OTHERWISE, IT IS A WORD DELIMITER.
15747C
15748C              NOTE THAT THIS ROUTINE DOES NOT RETURN THE VALUES FOR
15749C              ANY OF THESE WORDS.  IT JUST RETURNS THE NUMBER OF
15750C              WORDS.
15751C
15752C     WRITTEN BY--ALAN HECKERT
15753C                 STATISTICAL ENGINEERING DIVISION
15754C                 INFORMATION TECHNOLOGY LABORATORY
15755C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
15756C                 GAITHERSBURG, MD 20899-8980
15757C                 PHONE--301-975-2899
15758C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
15759C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
15760C     LANGUAGE--ANSI FORTRAN (1977)
15761C     VERSION NUMBER--2018/04
15762C     ORIGINAL VERSION--APRIL     2018.
15763C
15764C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
15765C
15766      CHARACTER*(*) ISTRIN
15767      CHARACTER*4 IBUGS2
15768      CHARACTER*4 ISUBRO
15769      CHARACTER*4 IERROR
15770C
15771      CHARACTER*4 ISUBN1
15772      CHARACTER*4 ISUBN2
15773      CHARACTER*4 ISTEPN
15774      CHARACTER*1 IQUOTE
15775      CHARACTER*1 ACURR
15776      CHARACTER*1 APREV
15777C
15778C-----COMMON VARIABLES (GENERAL)--------------------------------------
15779C
15780      INCLUDE 'DPCOP2.INC'
15781C
15782C-----START POINT-----------------------------------------------------
15783C
15784      ISUBN1='DPNU'
15785      ISUBN2='WO  '
15786      IERROR='NO'
15787      IQUOTE='"'
15788      NWORD=0
15789C
15790      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'NUWO')THEN
15791        WRITE(ICOUT,999)
15792  999   FORMAT(1X)
15793        CALL DPWRST('XXX','BUG ')
15794        WRITE(ICOUT,51)
15795   51   FORMAT('***** AT THE BEGINNING OF DPNUWO--')
15796        CALL DPWRST('XXX','BUG ')
15797        WRITE(ICOUT,53)IBUGS2,ISUBRO,IERROR,IQUOTE
15798   53   FORMAT('IBUGS2,ISUBRO,IERROR,IQUOTE = ',3(A4,2X),A1)
15799        CALL DPWRST('XXX','BUG ')
15800        WRITE(ICOUT,54)(ISTRIN(J:J),J=1,MIN(100,ISTOP))
15801   54   FORMAT('(ISTRIN(J:J),J=1,100) = ',100A1)
15802        CALL DPWRST('XXX','BUG ')
15803        WRITE(ICOUT,55)ISTART,ISTOP
15804   55   FORMAT('ISTART,ISTOP= ',2I8)
15805        CALL DPWRST('XXX','BUG ')
15806      ENDIF
15807C
15808C               **************************************
15809C               **  STEP 11--                       **
15810C               **  INITIALIZE THE OUTPUT VARIABLES **
15811C               **************************************
15812C
15813      ISTEPN='11'
15814      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'NUWO')
15815     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15816C
15817C               *******************************************
15818C               **  STEP 12--                            **
15819C               **  CHECK THE INPUT ARGUMENTS            **
15820C               *******************************************
15821C
15822      ISTEPN='12'
15823      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'NUWO')
15824     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15825C
15826      IF(ISTART.LT.1)THEN
15827        WRITE(ICOUT,999)
15828        CALL DPWRST('XXX','BUG ')
15829        WRITE(ICOUT,1211)
15830 1211   FORMAT('***** ERROR IN DPNUWO--')
15831        CALL DPWRST('XXX','BUG ')
15832        WRITE(ICOUT,1212)
15833 1212   FORMAT('      ISTART IS < 1. ')
15834        CALL DPWRST('XXX','BUG ')
15835        WRITE(ICOUT,1213)ISTART
15836 1213   FORMAT('      ISTART  = ',I8)
15837        CALL DPWRST('XXX','BUG ')
15838        IERROR='YES'
15839        GOTO9000
15840C
15841      ELSEIF(ISTART.GT.ISTOP)THEN
15842        WRITE(ICOUT,999)
15843        CALL DPWRST('XXX','BUG ')
15844        WRITE(ICOUT,1211)
15845        CALL DPWRST('XXX','BUG ')
15846        WRITE(ICOUT,1222)
15847 1222   FORMAT('      ISTART EXCEEDS ISTOP')
15848        CALL DPWRST('XXX','BUG ')
15849        WRITE(ICOUT,1213)ISTART
15850        CALL DPWRST('XXX','BUG ')
15851        WRITE(ICOUT,1224)ISTOP
15852 1224   FORMAT('      ISTOP  = ',I8)
15853        CALL DPWRST('XXX','BUG ')
15854        WRITE(ICOUT,1226)(ISTRIN(I:I),I=1,MIN(100,ISTOP))
15855 1226   FORMAT('      (ISTRIN(I:I),I=1,100) = ',100A1)
15856        CALL DPWRST('XXX','BUG ')
15857        IERROR='YES'
15858        GOTO9000
15859      ENDIF
15860C
15861C               ************************************************
15862C               **  STEP 21--                                 **
15863C               **  DETERMINE THE NUMBER OF WORDS             **
15864C               ************************************************
15865C
15866C     FIND LAST NON-BLANK CHARACTER AND RESET VALUE OF ISTOP
15867C
15868      DO2010I=ISTOP,1,-1
15869        IF(ISTRIN(I:I).NE.' ')THEN
15870          ISTOP2=I
15871          GOTO2019
15872        ENDIF
15873 2010 CONTINUE
15874      ISTOP2=ISTOP
15875 2019 CONTINUE
15876C
15877      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'NUWO')THEN
15878        WRITE(ICOUT,2021)ISTOP2
15879 2021   FORMAT('AFTER 2019: ISTOP2 = ',I8)
15880        CALL DPWRST('XXX','BUG ')
15881      ENDIF
15882C
15883C     IFLAGQ = 0 => NO CURRENT QUOTE
15884C            = 1 => CURRENTLY IN A QUOTE STRING
15885C
15886      IFLAGQ=0
15887      APREV=' '
15888      ACURR=' '
15889C
15890      DO2110I=ISTART,ISTOP2
15891C
15892        ACURR=ISTRIN(I:I)
15893        IF(IFLAGQ.EQ.0)THEN
15894C
15895C         CURRENT CHARACTER IS A QUOUTE, SO NEW WORD UNLESS
15896C         PREVIOUS CHARACTER IS AN EQUAL OR AN ESCAPE (\) CHARACTER.
15897C
15898          IF(ACURR.EQ.IQUOTE)THEN
15899            IF(APREV.EQ.'=')THEN
15900              IFLAGQ=1
15901            ELSEIF(APREV.EQ.'\')THEN
15902              CONTINUE
15903            ELSE
15904              NWORD=NWORD+1
15905              IFLAGQ=1
15906            ENDIF
15907C
15908C         NEW WORD IF PREVIOUS CHARACTER IS A SPACE OR COMMA AND
15909C         CURRENT CHARACTER IS NOT A SPACE OR COMMA.
15910C
15911          ELSEIF(APREV.EQ.' ' .OR. APREV.EQ.',')THEN
15912            IF(ACURR.NE.' ' .AND. ACURR.NE.',')THEN
15913              NWORD=NWORD+1
15914            ENDIF
15915          ENDIF
15916C
15917C       IF CURRENTLY IN A QUOTED STRING, JUST LOOKING FOR
15918C       CLOSING QUOTE TO END WORD.
15919C
15920        ELSE
15921          IF(ACURR.EQ.IQUOTE)IFLAGQ=0
15922        ENDIF
15923        APREV=ACURR
15924 2110 CONTINUE
15925C
15926C               ****************
15927C               **  STEP 90-- **
15928C               **  EXIT.     **
15929C               ****************
15930C
15931 9000 CONTINUE
15932      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'NUWO')THEN
15933        WRITE(ICOUT,999)
15934        CALL DPWRST('XXX','BUG ')
15935        WRITE(ICOUT,9011)
15936 9011   FORMAT('***** AT THE END       OF DPNUWO--')
15937        CALL DPWRST('XXX','BUG ')
15938        WRITE(ICOUT,9015)IERROR,NWORD
15939 9015   FORMAT('IERROR,NWORD = ',A4,2X,I5)
15940        CALL DPWRST('XXX','BUG ')
15941      ENDIF
15942C
15943      RETURN
15944      END
15945      SUBROUTINE DPODCH(XTEMP1,XTEMP2,MAXNXT,
15946     1                  ICASAN,ICAPSW,IFORSW,
15947     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
15948C
15949C     PURPOSE--COMPUTE ODDS RATIO CHI-SQUARE TEST.
15950C     EXAMPLE--ODDS RATIO CHI-SQUARE TEST Y1 Y2
15951C            --ODDS RATIO CHI-SQUARE TEST Y1 Y2 GROUPID
15952C            --ODDS RATIO CHI-SQUARE TEST Y1 GROUPID1 Y2 GROUPID2
15953C     REFERENCE--FLEISS, LEVIN, AND PAIK (2003), "STATISTICAL
15954C                METHODS FOR RATES AND PROPORTIONS", THIRD
15955C                EDITION, WILEY, PP. 250-253.
15956C     WRITTEN BY--ALAN HECKERT
15957C                 STATISTICAL ENGINEERING DIVISION
15958C                 INFORMATION TECHNOLOGY LABORATORY
15959C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
15960C                 GAITHERSBURG, MD 20899-8980
15961C                 PHONE--301-975-2899
15962C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
15963C           OF THE NATIONAL BUREAU OF STANDARDS.
15964C     LANGUAGE--ANSI FORTRAN (1977)
15965C     VERSION NUMBER--2007/5
15966C     ORIGINAL VERSION--MAY       2007.
15967C     UPDATED         --JANUARY   2011. USE DPPARS, DPPAR3
15968C     UPDATED         --APRIL     2019. USER CAN SPECIFY NUMBER OF
15969C                                       DECIMAL POINTS FOR AUXILLARY
15970C                                       FILES
15971C     UPDATED         --JULY      2019. TWEAK SCRATCH STORAGE
15972C
15973C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
15974C
15975      CHARACTER*4 ICASAN
15976      CHARACTER*4 ICAPSW
15977      CHARACTER*4 IFORSW
15978C
15979      CHARACTER*4 IBUGA2
15980      CHARACTER*4 IBUGA3
15981      CHARACTER*4 IBUGQ
15982      CHARACTER*4 ISUBRO
15983      CHARACTER*4 IFOUND
15984      CHARACTER*4 IERROR
15985C
15986      CHARACTER*4 ICASEQ
15987      CHARACTER*4 ISUBN1
15988      CHARACTER*4 ISUBN2
15989      CHARACTER*4 ISTEPN
15990      CHARACTER*4 IH
15991      CHARACTER*4 IH2
15992      CHARACTER*4 IHOST1
15993      CHARACTER*4 ISUBN0
15994      CHARACTER*4 ICASE
15995C
15996      CHARACTER*40 INAME
15997C
15998      PARAMETER (MAXSPN=20)
15999      CHARACTER*4 IVARN1(MAXSPN)
16000      CHARACTER*4 IVARN2(MAXSPN)
16001      CHARACTER*4 IVARTY(MAXSPN)
16002      REAL PVAR(MAXSPN)
16003      INTEGER ILIS(MAXSPN)
16004      INTEGER NRIGHT(MAXSPN)
16005      INTEGER ICOLR(MAXSPN)
16006C
16007C---------------------------------------------------------------------
16008C
16009      DIMENSION XTEMP1(*)
16010      DIMENSION XTEMP2(*)
16011C
16012C-----COMMON----------------------------------------------------------
16013C
16014      INCLUDE 'DPCOPA.INC'
16015      INCLUDE 'DPCOZZ.INC'
16016C
16017      REAL TEMP1(MAXOBV)
16018      REAL TEMP2(MAXOBV)
16019      REAL TEMP3(MAXOBV)
16020      REAL TEMP4(MAXOBV)
16021      REAL TEMP5(MAXOBV)
16022      REAL XIDTEM(MAXOBV)
16023      REAL XIDTE2(MAXOBV)
16024      REAL Y1(MAXOBV)
16025      REAL Y2(MAXOBV)
16026      REAL XGROU1(MAXOBV)
16027      REAL XGROU2(MAXOBV)
16028      REAL WEIGH(MAXOBV)
16029C
16030      EQUIVALENCE (GARBAG(IGARB1),TEMP1(1))
16031      EQUIVALENCE (GARBAG(IGARB2),TEMP2(1))
16032      EQUIVALENCE (GARBAG(IGARB3),TEMP3(1))
16033      EQUIVALENCE (GARBAG(IGARB4),XIDTEM(1))
16034      EQUIVALENCE (GARBAG(IGARB5),XIDTE2(1))
16035      EQUIVALENCE (GARBAG(IGARB6),Y1(1))
16036      EQUIVALENCE (GARBAG(IGARB7),Y2(1))
16037      EQUIVALENCE (GARBAG(IGARB8),WEIGH(1))
16038      EQUIVALENCE (GARBAG(IGARB9),XGROU1(1))
16039      EQUIVALENCE (GARBAG(IGAR10),XGROU2(1))
16040      EQUIVALENCE (GARBAG(JGAR11),TEMP4(1))
16041      EQUIVALENCE (GARBAG(JGAR12),TEMP5(1))
16042C
16043C-----COMMON VARIABLES (GENERAL)--------------------------------------
16044C
16045      INCLUDE 'DPCOHK.INC'
16046      INCLUDE 'DPCOSU.INC'
16047      INCLUDE 'DPCOST.INC'
16048      INCLUDE 'DPCODA.INC'
16049      INCLUDE 'DPCOP2.INC'
16050C
16051C-----START POINT-----------------------------------------------------
16052C
16053      ISUBN1='DPOD'
16054      ISUBN2='CH  '
16055      IFOUND='NO'
16056      IERROR='NO'
16057      IFOUND='YES'
16058      ICASEQ='UNKN'
16059      ICASE='RAW '
16060C
16061      MAXCP1=MAXCOL+1
16062      MAXCP2=MAXCOL+2
16063      MAXCP3=MAXCOL+3
16064      MAXCP4=MAXCOL+4
16065      MAXCP5=MAXCOL+5
16066      MAXCP6=MAXCOL+6
16067      MINN2=2
16068C
16069      DO11I=1,MAXNXT
16070        XTEMP1(I)=0.0
16071        XTEMP2(I)=0.0
16072   11 CONTINUE
16073C
16074C               *************************************************
16075C               **  TREAT THE ODDS RATIO CHI-SQUARE TEST CASE  **
16076C               *************************************************
16077C
16078      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ODCH')THEN
16079        WRITE(ICOUT,999)
16080  999   FORMAT(1X)
16081        CALL DPWRST('XXX','BUG ')
16082        WRITE(ICOUT,51)
16083   51   FORMAT('***** AT THE BEGINNING OF DPODCH--')
16084        CALL DPWRST('XXX','BUG ')
16085        WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ
16086   52   FORMAT('IBUGA2,IBUGA3,IBUGQ = ',A4,2X,A4,2X,A4)
16087        CALL DPWRST('XXX','BUG ')
16088        WRITE(ICOUT,56)MAXNXT,NUMARG
16089   56   FORMAT('MAXNXT,NUMARG = ',2I8)
16090        CALL DPWRST('XXX','BUG ')
16091        DO59I=1,NUMARG
16092          WRITE(ICOUT,57)I,IHARG(I),IHARG2(I),ARG(I)
16093   57     FORMAT('I,IHARG(I),IHARG2(I),ARG(I) = ',I5,A4,A4,G15.7)
16094   59   CONTINUE
16095      ENDIF
16096C
16097C               *********************************
16098C               **  STEP 4--                   **
16099C               **  EXTRACT THE VARIABLE LIST  **
16100C               *********************************
16101C
16102      ISTEPN='4'
16103      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ODCH')
16104     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16105C
16106      INAME='ODDS RATIO CHI-SQUARE TEST'
16107      MINNA=2
16108      MAXNA=100
16109      MINN2=2
16110      IFLAGE=19
16111      IFLAGM=0
16112      IFLAGP=0
16113      JMIN=1
16114      JMAX=NUMARG
16115      MINNVA=2
16116      MAXNVA=4
16117C
16118      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
16119     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
16120     1            JMIN,JMAX,
16121     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
16122     1            IVARN1,IVARN2,IVARTY,PVAR,
16123     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
16124     1            MINNVA,MAXNVA,
16125     1            IFLAGM,IFLAGP,
16126     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
16127      IF(IERROR.EQ.'YES')GOTO9000
16128C
16129      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ODCH')THEN
16130        WRITE(ICOUT,999)
16131        CALL DPWRST('XXX','BUG ')
16132        WRITE(ICOUT,281)
16133  281   FORMAT('***** AFTER CALL DPPARS--')
16134        CALL DPWRST('XXX','BUG ')
16135        WRITE(ICOUT,282)NQ,NUMVAR
16136  282   FORMAT('NQ,NUMVAR = ',2I8)
16137        CALL DPWRST('XXX','BUG ')
16138        IF(NUMVAR.GT.0)THEN
16139          DO285I=1,NUMVAR
16140            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
16141     1                      ICOLR(I),PVAR(I)
16142  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
16143     1             'ICOLR(I),PVAR(I) = ',I8,2X,A4,A4,2X,3I8,G15.7)
16144            CALL DPWRST('XXX','BUG ')
16145  285     CONTINUE
16146        ENDIF
16147      ENDIF
16148C
16149C     NOTE: THE NUMBER OF VARIABLES DETERMINES HOW THE
16150C           ARGUMENTS ARE DETERMINED:
16151C
16152C           NUMVAR = 2: BOTH VARIABLES ARE RESPONSE VARIABLES
16153C                       (Y1 AND Y2)
16154C           NUMVAR = 3: VARIABLES 1 AND 2 ARE THE RESPONSE
16155C                       VARIABLES (Y1 AND Y2) AND VARIABLE 3
16156C                       IS THE GROUP ID VARIABLE (XGROU1).
16157C           NUMVAR = 4: VARIABLE 1 = FIRST RESPONSE VARIABLE
16158C                       VARIABLE 2 = FIRST GROUP ID VARIABLE
16159C                       VARIABLE 3 = SECOND RESPONSE VARIABLE
16160C                       VARIABLE 2 = SECOND GROUP ID VARIABLE
16161C
16162      IF(NUMVAR.EQ.2)THEN
16163        ICASE='VARI'
16164        ICOL=1
16165        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
16166     1              INAME,IVARN1,IVARN2,IVARTY,
16167     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
16168     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
16169     1              MAXCP4,MAXCP5,MAXCP6,
16170     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
16171     1              Y1,Y2,TEMP1,NLOCAL,NLOCA2,NLOCA3,ICASE,
16172     1              IBUGA3,ISUBRO,IFOUND,IERROR)
16173        IF(IERROR.EQ.'YES')GOTO9000
16174        NS1=NLOCAL
16175        NS2=0
16176      ELSEIF(NUMVAR.EQ.3)THEN
16177        ICASE='VARI'
16178        ICOL=1
16179        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
16180     1              INAME,IVARN1,IVARN2,IVARTY,
16181     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
16182     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
16183     1              MAXCP4,MAXCP5,MAXCP6,
16184     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
16185     1              Y1,Y2,XGROU1,NLOCAL,NLOCA2,NLOCA3,ICASE,
16186     1              IBUGA3,ISUBRO,IFOUND,IERROR)
16187        IF(IERROR.EQ.'YES')GOTO9000
16188        NS1=NLOCAL
16189        NS2=0
16190      ELSEIF(NUMVAR.EQ.4)THEN
16191        ICOL=1
16192        CALL DPPAR7(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
16193     1              INAME,IVARN1,IVARN2,IVARTY,
16194     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
16195     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
16196     1              MAXCP4,MAXCP5,MAXCP6,
16197     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
16198     1              Y1,XGROU1,Y2,XGROU2,NLOCAL,NLOCA2,NLOCA3,NLOCA4,
16199     1              IBUGA3,ISUBRO,IFOUND,IERROR)
16200        IF(IERROR.EQ.'YES')GOTO9000
16201        NS1=NLOCAL
16202        NS2=NLOCA3
16203      ENDIF
16204C
16205C               ***********************************
16206C               **  STEP 61--                    **
16207C               **  COMPUTE THE ODDS RATIO TEST  **
16208C               ***********************************
16209C
16210      ISTEPN='61'
16211      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ODCH')
16212     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16213C
16214      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'ODCH')THEN
16215        WRITE(ICOUT,999)
16216        CALL DPWRST('XXX','BUG ')
16217        WRITE(ICOUT,6111)
16218 6111   FORMAT('***** FROM DPODCH--READY TO COMPUTE TEST')
16219        CALL DPWRST('XXX','BUG ')
16220        WRITE(ICOUT,6112)NS1
16221 6112   FORMAT('NS1 = ',I8)
16222        CALL DPWRST('XXX','BUG ')
16223        DO6120I=1,MIN(500,NS1)
16224          WRITE(ICOUT,6122)I,Y1(I),Y2(I),XGROU1(I),XGROU2(I)
16225 6122     FORMAT('I,Y1(I),Y2(I),XGROU1(I),XGROU2(I) = ',I8,4G15.7)
16226          CALL DPWRST('XXX','BUG ')
16227 6120   CONTINUE
16228      ENDIF
16229C
16230      CALL DPODC2(Y1,XGROU1,NS1,Y2,XGROU2,NS2,NUMVAR,
16231     1            XIDTEM,XIDTE2,WEIGH,
16232     1            TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,MAXOBV,
16233     1            ICASE,ICASAN,
16234     1            ICAPSW,ICAPTY,IFORSW,
16235     1            STATTO,CDFTOT,STATAS,CDFASS,STATHO,CDFHO,
16236     1            ISUBRO,IBUGA3,IERROR)
16237C
16238C               ***************************************
16239C               **  STEP 62--                        **
16240C               **  UPDATE INTERNAL DATAPLOT TABLES  **
16241C               ***************************************
16242C
16243      ISTEPN='62'
16244      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ODCH')
16245     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16246C
16247      ISUBN0='ODCH'
16248C
16249      IH='STAT'
16250      IH2='TOT '
16251      VALUE0=STATTO
16252      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
16253     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
16254     1IANS,IWIDTH,IBUGA3,IERROR)
16255C
16256      IH='CDFT'
16257      IH2='OTAL'
16258      VALUE0=CDFTOT
16259      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
16260     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
16261     1IANS,IWIDTH,IBUGA3,IERROR)
16262C
16263      IH='STAT'
16264      IH2='ASSO'
16265      VALUE0=STATAS
16266      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
16267     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
16268     1IANS,IWIDTH,IBUGA3,IERROR)
16269C
16270      IH='CDFA'
16271      IH2='SSOC'
16272      VALUE0=CDFASS
16273      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
16274     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
16275     1IANS,IWIDTH,IBUGA3,IERROR)
16276C
16277      IH='STAT'
16278      IH2='HOMO'
16279      VALUE0=STATHO
16280      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
16281     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
16282     1IANS,IWIDTH,IBUGA3,IERROR)
16283C
16284      IH='CDFH'
16285      IH2='OMOG'
16286      VALUE0=CDFHO
16287      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
16288     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
16289     1IANS,IWIDTH,IBUGA3,IERROR)
16290C
16291C               *****************
16292C               **  STEP 90--  **
16293C               **  EXIT       **
16294C               *****************
16295C
16296 9000 CONTINUE
16297      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ODCH')THEN
16298        WRITE(ICOUT,999)
16299        CALL DPWRST('XXX','BUG ')
16300        WRITE(ICOUT,9011)
16301 9011   FORMAT('***** AT THE END       OF DPODCH--')
16302        CALL DPWRST('XXX','BUG ')
16303        WRITE(ICOUT,9012)IBUGA2,IBUGA3,IERROR
16304 9012   FORMAT('IBUGA2,IBUGA3,IERROR = ',2(A4,2X),A4)
16305        CALL DPWRST('XXX','BUG ')
16306      ENDIF
16307C
16308      RETURN
16309      END
16310      SUBROUTINE DPODC2(Y1,X1,N1,Y2,X2,N2,NUMVAR,
16311     1                  XIDTEM,XIDTE2,WEIGH,
16312     1                  TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,MAXNXT,
16313     1                  ICASE,ICASAN,
16314     1                  ICAPSW,ICAPTY,IFORSW,
16315     1                  STATTO,CDFTOT,STATAS,CDFASS,STATHO,CDFHO,
16316     1                  ISUBRO,IBUGA3,IERROR)
16317C
16318C     PURPOSE--PERFORM AN ODDS RATIO CHI-SQUARE TEST
16319C              THE INPUT CAN EITHER BE RAW DATA OR SUMMARY DATA:
16320C
16321C                  1) RAW DATA - EQUAL SAMPLE SIZES
16322C
16323C                     IN THIS CASE, THERE ARE THREE VARIABLES.
16324C                     THE FIRST TWO OF THESE VARIABLES SHOULD CONTAIN
16325C                     1'S (FOR SUCCESS) OR 0'S (FAILURES).  THE THIRD
16326C                     VARIABLE IS A GROUP-ID VARIABLE.
16327C
16328C                     IN THIS CASE, THE FIRST TASK IS TO
16329C                     CROSS TABULATE THE FIRST TWO VARIABLES
16330C                     INTO THE K TABLES.
16331C
16332C                     THIS CASE CAN HANDLE UNEQUAL SAMPLE SIZES
16333C                     BY SPECIFYING MISSING VALUES (USING THE
16334C                     SET STATISTIC MISSING VALUE COMMAND TO
16335C                     SPECIFY WHAT VALUE IS INTERPRETED AS THE
16336C                     MISSING VALUE).
16337C
16338C                  2) RAW DATA - UNEQUAL SAMPLE SIZES
16339C
16340C                     IN THIS CASE, THERE ARE FOUR VARIABLES.
16341C
16342C                     VARIABLE 1 = RESPONSE VARIABLE FOR SAMPLE 1
16343C                                  (SHOULD CONTAIN 1's TO DENOTE
16344C                                  SUCCESS AND 0's TO DENOTE
16345C                                  FAILURE).
16346C                     VARIABLE 2 = GROUP ID VARIABLE FOR SAMPLE 1.
16347C                     VARIABLE 3 = RESPONSE VARIABLE FOR SAMPLE 2
16348C                                  (SHOULD CONTAIN 1's TO DENOTE
16349C                                  SUCCESS AND 0's TO DENOTE
16350C                                  FAILURE).
16351C                     VARIABLE 4 = GROUP ID VARIABLE FOR SAMPLE 2.
16352C
16353C                     IN THIS CASE, THE FIRST TASK IS TO
16354C                     CROSS TABULATE THE FIRST TWO VARIABLES
16355C                     INTO THE K TABLES.
16356C
16357C                  3) SUMMARY DATA
16358C
16359C                     IN THIS CASE, THERE ARE TWO VARIABLES.
16360C                     THE VARIABLES CONTAIN A SERIES 2X2 TABLES.
16361C                     THAT IS, ROWS 1 AND 2 DEFINE TABLE 1,
16362C                     ROWS 3 AND 4 DEFINE TABLE 2, AND SO ON.
16363C
16364C              ULTIMATELY, WE SHOULD END UP WITH K TABLES WHERE
16365C              THE ITH TABLE LOOKS LIKE:
16366C
16367C                  X(I)         R(I)-X(I)             | R(I)
16368C                  C(I)-X(i)    N(I)-R(I)-C(I)+X(I)   | N(I)-R(I)
16369C                  ==============================================
16370C                  C(I)         N(I)-C(I)             | N(I)
16371C
16372C              THIS ROUTINE IMPLEMENTS THE CHI-SQUARE
16373C              DECOMPOSITION DOCUMENTED IN SECTIONS 1 AND 2,
16374C              CHAPTER 10 OF THE FLEIS, LEVIN, AND PAIK BOOK
16375C              CITED BELOW.  SEE THIS REFERENCE FOR THE DETAILS
16376C              OF THE METHOD.
16377C
16378C     EXAMPLE--ODDS RATIO CHI-SQUARE TEST Y1 Y2
16379C            --ODDS RATIO CHI-SQUARE TEST Y1 Y2 GROUPID
16380C            --ODDS RATIO CHI-SQUARE TEST Y1 GROUPID1 Y2 GROUPID2
16381C     REFERENCE--FLEISS, LEVIN, AND PAIK (2003), "STATISTICAL
16382C                METHODS FOR RATES AND PROPORTIONS", THIRD
16383C                EDITION, WILEY, PP. 250-253.
16384C     WRITTEN BY--ALAN HECKERT
16385C                 STATISTICAL ENGINEERING DIVISION
16386C                 INFORMATION TECHNOLOGYU LABORATORY
16387C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
16388C                 GAITHERSBURG, MD 20899-8980
16389C                 PHONE--301-975-2899
16390C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
16391C           OF THE NATIONAL BUREAU OF STANDARDS.
16392C     LANGUAGE--ANSI FORTRAN (1977)
16393C     VERSION NUMBER--2007/5
16394C     ORIGINAL VERSION--MAY       2007.
16395C     UPDATED         --FEBRUARY  2011. USE DPAUFI TO OPEN/CLOSE
16396C                                       AUXILLARY FILES
16397C     UPDATED         --FEBRUARY  2011. USE DPDTA1, DPDT5B TO PRINT
16398C                                       TABLES
16399C
16400C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
16401C
16402      CHARACTER*4 ISUBRO
16403      CHARACTER*4 IBUGA3
16404      CHARACTER*4 IERROR
16405      CHARACTER*4 ICASE
16406      CHARACTER*4 ICASAN
16407      CHARACTER*4 ICAPSW
16408      CHARACTER*4 ICAPTY
16409      CHARACTER*4 IFORSW
16410C
16411      CHARACTER*4 IWRITE
16412      CHARACTER*6 ICONC1
16413      CHARACTER*6 ICONC2
16414      CHARACTER*6 ICONC3
16415      CHARACTER*6 ICONC4
16416      CHARACTER*6 ICONC5
16417      CHARACTER*6 ICONC6
16418      CHARACTER*4 ISUBN1
16419      CHARACTER*4 ISUBN2
16420      CHARACTER*4 ISTEPN
16421      CHARACTER*4 IOP
16422      CHARACTER*20 IFORMT
16423C
16424C---------------------------------------------------------------------
16425C
16426      DOUBLE PRECISION DSUM1
16427      DOUBLE PRECISION DSUM2
16428      DOUBLE PRECISION DSUM3
16429      DOUBLE PRECISION DSUM4
16430C
16431      DIMENSION Y1(*)
16432      DIMENSION Y2(*)
16433      DIMENSION X1(*)
16434      DIMENSION X2(*)
16435      DIMENSION TEMP1(*)
16436      DIMENSION TEMP2(*)
16437      DIMENSION TEMP3(*)
16438      DIMENSION TEMP4(*)
16439      DIMENSION TEMP5(*)
16440      DIMENSION XIDTEM(*)
16441      DIMENSION XIDTE2(*)
16442      DIMENSION WEIGH(*)
16443C
16444      PARAMETER (NUMALP=6)
16445      DIMENSION SIGVAL(NUMALP)
16446      DIMENSION ALOWCL(NUMALP)
16447      DIMENSION AUPPCL(NUMALP)
16448      DIMENSION ALOWC2(NUMALP)
16449      DIMENSION AUPPC2(NUMALP)
16450C
16451      PARAMETER(NUMCLI=7)
16452      PARAMETER(MAXLIN=4)
16453      PARAMETER (MAXROW=NUMALP)
16454      PARAMETER (MAXRO2=30)
16455      CHARACTER*60 ITITLE
16456      CHARACTER*60 ITITLZ
16457      CHARACTER*60 ITITL9
16458      CHARACTER*60 ITEXT(MAXRO2)
16459      CHARACTER*4  ALIGN(NUMCLI)
16460      CHARACTER*4  VALIGN(NUMCLI)
16461      REAL         AVALUE(MAXRO2)
16462      INTEGER      NCTEXT(MAXRO2)
16463      INTEGER      IDIGIT(MAXRO2)
16464      INTEGER      IDIGI2(MAXRO2,NUMCLI)
16465      INTEGER      NTOT(MAXRO2)
16466      CHARACTER*60 ITITL2(MAXLIN,NUMCLI)
16467      CHARACTER*15 IVALUE(MAXRO2,NUMCLI)
16468      CHARACTER*4  ITYPCO(NUMCLI)
16469      INTEGER      NCTIT2(MAXLIN,NUMCLI)
16470      INTEGER      NCVALU(MAXRO2,NUMCLI)
16471      INTEGER      NCOLSP(MAXLIN,NUMCLI)
16472      INTEGER      ROWSEP(MAXRO2)
16473      INTEGER      IWHTML(NUMCLI)
16474      INTEGER      IWRTF(NUMCLI)
16475      REAL         AMAT(MAXRO2,NUMCLI)
16476      LOGICAL IFRST
16477      LOGICAL ILAST
16478      LOGICAL IFLAGS
16479      LOGICAL IFLAGE
16480C
16481C---------------------------------------------------------------------
16482C
16483      INCLUDE 'DPCOST.INC'
16484      INCLUDE 'DPCOP2.INC'
16485C
16486      DATA SIGVAL /0.50, 0.80, 0.90, 0.95, 0.975, 0.99/
16487C
16488C-----START POINT-----------------------------------------------------
16489C
16490      ISUBN1='DPOD'
16491      ISUBN2='C2  '
16492      IERROR='NO'
16493      IWRITE='NO'
16494C
16495      ICONC1='ACCEPT'
16496      ICONC2='ACCEPT'
16497      ICONC3='ACCEPT'
16498      ICONC4='ACCEPT'
16499      ICONC5='ACCEPT'
16500      ICONC6='ACCEPT'
16501C
16502      NSUMM=0
16503C
16504      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ODC2')THEN
16505        WRITE(ICOUT,999)
16506  999   FORMAT(1X)
16507        CALL DPWRST('XXX','WRIT')
16508        WRITE(ICOUT,51)
16509   51   FORMAT('**** AT THE BEGINNING OF DPODC2--')
16510        CALL DPWRST('XXX','WRIT')
16511        WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASE
16512   52   FORMAT('IBUGA3,ISUBRO,ICASE = ',3(A4,2X))
16513        CALL DPWRST('XXX','WRIT')
16514        WRITE(ICOUT,53)PSTAMV
16515   53   FORMAT('PSTAMV = ',G15.7)
16516        CALL DPWRST('XXX','WRIT')
16517        WRITE(ICOUT,55)N1,N2,NUMVAR,MAXNXT
16518   55   FORMAT('N1,N2,NUMVAR,MAXNXT = ',4I8)
16519        CALL DPWRST('XXX','WRIT')
16520        DO56I=1,N1
16521          WRITE(ICOUT,57)I,Y1(I),Y2(I),X1(I),X2(I)
16522   57     FORMAT('I,Y1(I),Y2(I),X1(I),X2(I) = ',I8,4G15.7)
16523          CALL DPWRST('XXX','WRIT')
16524   56   CONTINUE
16525      ENDIF
16526C
16527C               ********************************************
16528C               **  STEP 0--                              **
16529C               **  IF ONLY TWO VARIABLES GIVEN, CREATE   **
16530C               **  THE GROUP-ID VARIABLE.  FOR THREE     **
16531C               **  VARIABLES, CHECK WHETHER WE HAVE RAW  **
16532C               **  DATA OR SUMMARY DATA.                 **
16533C               ********************************************
16534C
16535      ISTEPN='0'
16536      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'ODC2')
16537     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16538C
16539      IF(NUMVAR.EQ.2)THEN
16540        ICASE='SUMM'
16541        NGROUP=0
16542        DO100I=1,N1
16543          ITEMP=MOD(I,2)
16544          IF(ITEMP.EQ.1)THEN
16545            NGROUP=NGROUP+1
16546          ENDIF
16547          X1(I)=REAL(NGROUP)
16548          X2(I)=REAL(NGROUP)
16549  100   CONTINUE
16550C
16551        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'ODC2')THEN
16552          WRITE(ICOUT,151)NGROUP
16553  151     FORMAT('TWO-VARIABLE CASE: NGROUPS = ',I8)
16554          CALL DPWRST('XXX','WRIT')
16555        ENDIF
16556C
16557      ELSEIF(NUMVAR.EQ.3)THEN
16558        ICASE='SUMM'
16559        CALL DISTIN(X1,N1,IWRITE,XIDTEM,NGROUP,IBUGA3,IERROR)
16560        CALL SORT(XIDTEM,NGROUP,XIDTEM)
16561        DO200K=1,NGROUP
16562          HOLD=XIDTEM(K)
16563          L=0
16564          DO210I=1,N1
16565            IF(X1(I).EQ.HOLD)THEN
16566              L=L+1
16567            ENDIF
16568  210     CONTINUE
16569          IF(L.NE.2)THEN
16570            ICASE='RAW'
16571            GOTO299
16572          ENDIF
16573  200   CONTINUE
16574C
16575      ELSEIF(NUMVAR.EQ.4)THEN
16576        ICASE='SUMM'
16577        CALL DISTIN(X1,N1,IWRITE,XIDTEM,NGROU1,IBUGA3,IERROR)
16578        CALL SORT(XIDTEM,NGROU2,XIDTEM)
16579        CALL DISTIN(X2,N2,IWRITE,XIDTE2,NGROU2,IBUGA3,IERROR)
16580        CALL SORT(XIDTE2,NGROU2,XIDTE2)
16581C
16582        IF(NGROU1.NE.NGROU2)THEN
16583          WRITE(ICOUT,999)
16584          CALL DPWRST('XXX','WRIT')
16585          WRITE(ICOUT,1101)
16586          CALL DPWRST('XXX','WRIT')
16587          WRITE(ICOUT,231)
16588  231     FORMAT('     THE NUMBER OF GROUPS IS DIFFERENT FOR ',
16589     1           'SAMPLE ONE AND SAMPLE TWO.')
16590          CALL DPWRST('XXX','WRIT')
16591          WRITE(ICOUT,233)NGROU1
16592  233     FORMAT('     SAMPLE ONE HAS ',I8,' GROUPS.')
16593          CALL DPWRST('XXX','WRIT')
16594          WRITE(ICOUT,235)NGROU2
16595  235     FORMAT('     SAMPLE TWO HAS ',I8,' GROUPS.')
16596          CALL DPWRST('XXX','WRIT')
16597          IERROR='YES'
16598          GOTO9000
16599        ENDIF
16600C
16601        EPS=0.01
16602        DO240K=1,NGROU1
16603          DIFF=ABS(XIDTEM(K) - XIDTE2(K))
16604          IF(DIFF.GT.EPS)THEN
16605             WRITE(ICOUT,999)
16606             CALL DPWRST('XXX','WRIT')
16607             WRITE(ICOUT,1101)
16608             CALL DPWRST('XXX','WRIT')
16609             WRITE(ICOUT,241)
16610  241        FORMAT('     THE GROUP IDs DIFFER FOR THE TWO ',
16611     1              'SAMPLES.')
16612             CALL DPWRST('XXX','WRIT')
16613             IERROR='YES'
16614             GOTO9000
16615          ENDIF
16616  240   CONTINUE
16617C
16618C       CHECK BOTH GROUP-ID VARIABLES.  CURRENTLY, BOTH SAMPLES
16619C       SHOULD BE THE SAME (I.E., EITHER BOTH SUMMARY DATA OR
16620C       BOTH RAW DATA, BUT NOT ONE RAW AND THE OTHER SUMMARY).
16621C
16622        DO250K=1,NGROU1
16623          HOLD=XIDTEM(K)
16624          L=0
16625          DO260I=1,N1
16626            IF(X1(I).EQ.HOLD)THEN
16627              L=L+1
16628            ENDIF
16629  260     CONTINUE
16630          IF(L.NE.2)THEN
16631            ICASE='RAW'
16632            GOTO299
16633          ENDIF
16634  250   CONTINUE
16635C
16636        DO270K=1,NGROU2
16637          HOLD=XIDTE2(K)
16638          L=0
16639          DO280I=1,N1
16640            IF(X2(I).EQ.HOLD)THEN
16641              L=L+1
16642            ENDIF
16643  280     CONTINUE
16644          IF(L.NE.2)THEN
16645            ICASE='RAW'
16646            GOTO299
16647          ENDIF
16648  270   CONTINUE
16649C
16650      ENDIF
16651C
16652  299 CONTINUE
16653C
16654C               ********************************************
16655C               **  STEP 1--                              **
16656C               **  FOR RAW DATA CASE, CROSS TABULATE     **
16657C               **  THE DATA.  PUT SUMMARY DATA IN TEMP1  **
16658C               **  AND TEMP2.                            **
16659C               ********************************************
16660C
16661C
16662C
16663C               ********************************************
16664C               **  STEP 11--                             **
16665C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
16666C               ********************************************
16667C
16668      ISTEPN='11'
16669      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'ODC2')THEN
16670        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16671        WRITE(ICOUT,251)ICASAN,ICASE
16672  251   FORMAT('THREE-VARIABLE CASE: ICASAN, ICASE = ',A4,2X,A4)
16673        CALL DPWRST('XXX','WRIT')
16674      ENDIF
16675C
16676      IF(N1.LT.2)THEN
16677        WRITE(ICOUT,999)
16678        CALL DPWRST('XXX','WRIT')
16679        WRITE(ICOUT,1101)
16680 1101   FORMAT('***** ERROR IN ODDS RATIO CHI-SQUARE TEST--')
16681        CALL DPWRST('XXX','WRIT')
16682        WRITE(ICOUT,1103)
16683 1103   FORMAT('      THE NUMBER OF OBSERVATIONS  IS < 2.')
16684        CALL DPWRST('XXX','WRIT')
16685        WRITE(ICOUT,1105)N1
16686 1105   FORMAT('SAMPLE SIZE = ',I8)
16687        CALL DPWRST('XXX','WRIT')
16688        IERROR='YES'
16689        GOTO9000
16690      ENDIF
16691C
16692      IF(ICASE.EQ.'SUMM')THEN
16693        DO300I=1,N1
16694          TEMP1(I)=Y1(I)
16695          TEMP2(I)=Y2(I)
16696  300   CONTINUE
16697        NSUMM=N1
16698        NGROUP=N1/2
16699C
16700C       CASE WHERE SAMPLES HAVE EQUAL SIZES FOR EACH GROUP
16701C
16702      ELSEIF(NUMVAR.EQ.3)THEN
16703C
16704        EPS=0.01
16705        ICNT2=0
16706        DO400K=1,NGROUP
16707          HOLD=XIDTEM(K)
16708          ICNT=0
16709          DO410I=1,N1
16710            DIFF=ABS(HOLD-X1(I))
16711            IF(DIFF.LE.EPS)THEN
16712              ICNT=ICNT+1
16713              TEMP3(ICNT)=Y1(I)
16714              TEMP4(ICNT)=Y2(I)
16715            ENDIF
16716  410     CONTINUE
16717C
16718          IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ODC2')THEN
16719            WRITE(ICOUT,401)K,ICNT,HOLD
16720  401       FORMAT('K,ICNT,HOLD = ',2I8,G15.7)
16721            CALL DPWRST('XXX','WRIT')
16722          ENDIF
16723C
16724          CALL ODDDIS(TEMP3,ICNT,PSTAMV,IWRITE,TEMP5,N11,N21,NOUT,
16725     1                IBUGA3,IERROR)
16726          IF(IERROR.EQ.'YES')GOTO9000
16727          CALL ODDDIS(TEMP4,ICNT,PSTAMV,IWRITE,TEMP5,N12,N22,NOUT,
16728     1                IBUGA3,IERROR)
16729          IF(IERROR.EQ.'YES')GOTO9000
16730C
16731          IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ODC2')THEN
16732            WRITE(ICOUT,411)N11,N21,N12,N22
16733  411       FORMAT('N11,N21,N12,N22 = ',4I8)
16734            CALL DPWRST('XXX','WRIT')
16735          ENDIF
16736C
16737          ICNT2=ICNT2+1
16738          TEMP1(ICNT2)=REAL(N11)
16739          TEMP2(ICNT2)=REAL(N12)
16740C
16741          IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ODC2')THEN
16742            WRITE(ICOUT,413)ICNT2,TEMP1(ICNT2),TEMP2(ICNT2)
16743  413       FORMAT('ICNT2,TEMP1(ICNT2),TEMP2(ICNT2) = ',I8,2G15.7)
16744            CALL DPWRST('XXX','WRIT')
16745          ENDIF
16746C
16747          ICNT2=ICNT2+1
16748          TEMP1(ICNT2)=REAL(N21)
16749          TEMP2(ICNT2)=REAL(N22)
16750C
16751          IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ODC2')THEN
16752            WRITE(ICOUT,413)ICNT2,TEMP1(ICNT2),TEMP2(ICNT2)
16753            CALL DPWRST('XXX','WRIT')
16754          ENDIF
16755C
16756  400   CONTINUE
16757        NSUMM=ICNT2
16758C
16759      ELSEIF(NUMVAR.EQ.4)THEN
16760C
16761        EPS=0.01
16762        ICNT2=0
16763        DO500K=1,NGROU1
16764          HOLD=XIDTEM(K)
16765          ICNT=0
16766          DO510I=1,N1
16767            DIFF=ABS(HOLD-X1(I))
16768            IF(DIFF.LE.EPS)THEN
16769              ICNT=ICNT+1
16770              TEMP3(ICNT)=Y1(I)
16771            ENDIF
16772  510     CONTINUE
16773C
16774          IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ODC2')THEN
16775            WRITE(ICOUT,501)K,ICNT,HOLD
16776  501       FORMAT('K,ICNT,HOLD = ',2I8,G15.7)
16777            CALL DPWRST('XXX','WRIT')
16778          ENDIF
16779C
16780          CALL ODDDIS(TEMP3,ICNT,PSTAMV,IWRITE,TEMP5,N11,N21,NOUT,
16781     1                IBUGA3,IERROR)
16782          IF(IERROR.EQ.'YES')GOTO9000
16783          ICNT2=ICNT2+1
16784          TEMP1(ICNT2)=REAL(N11)
16785          ICNT2=ICNT2+1
16786          TEMP1(ICNT2)=REAL(N21)
16787  500   CONTINUE
16788C
16789        ICNT2=0
16790        DO550K=1,NGROU2
16791          HOLD=XIDTE2(K)
16792          ICNT=0
16793          DO560I=1,N2
16794            DIFF=ABS(HOLD-X2(I))
16795            IF(DIFF.LE.EPS)THEN
16796              ICNT=ICNT+1
16797              TEMP4(ICNT)=Y2(I)
16798            ENDIF
16799  560     CONTINUE
16800C
16801          IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ODC2')THEN
16802            WRITE(ICOUT,561)K,ICNT,HOLD
16803  561       FORMAT('K,ICNT,HOLD = ',2I8,G15.7)
16804            CALL DPWRST('XXX','WRIT')
16805          ENDIF
16806C
16807          CALL ODDDIS(TEMP4,ICNT,PSTAMV,IWRITE,TEMP5,N12,N22,NOUT,
16808     1                IBUGA3,IERROR)
16809          IF(IERROR.EQ.'YES')GOTO9000
16810          ICNT2=ICNT2+1
16811          TEMP2(ICNT2)=REAL(N12)
16812          ICNT2=ICNT2+1
16813          TEMP2(ICNT2)=REAL(N22)
16814  550   CONTINUE
16815C
16816        NSUMM=ICNT2
16817        NGROUP=NGROU1
16818C
16819      ENDIF
16820C
16821C               ********************************************
16822C               **  STEP 14--                             **
16823C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
16824C               **  ALL TABLE ENTRIES SHOULD BE           **
16825C               **  NON-NEGATIVE INTEGERS.  NEGATIVE      **
16826C               **  VALUES WILL BE FLAGGED AS ERRORS      **
16827C               **  WHILE NON-INTEGER VALUES WILL BE      **
16828C               **  ROUNDED TO NEAREST INTEGER.           **
16829C               ********************************************
16830C
16831      ISTEPN='14'
16832      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'ODC2')
16833     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16834C
16835      IERROR='NO'
16836C
16837      NTEMP=MOD(NSUMM,2)
16838      IF(NTEMP.EQ.1)THEN
16839        WRITE(ICOUT,999)
16840        CALL DPWRST('XXX','WRIT')
16841        WRITE(ICOUT,1101)
16842        CALL DPWRST('XXX','WRIT')
16843        WRITE(ICOUT,1411)
16844 1411   FORMAT('      FOR THE SUMMARY DATA, THE NUMBER OF ROWS')
16845        CALL DPWRST('XXX','WRIT')
16846        WRITE(ICOUT,1413)
16847 1413   FORMAT('      SHOULD BE EVEN;  SUCH WAS NOT THE CASE HERE.')
16848        CALL DPWRST('XXX','WRIT')
16849        WRITE(ICOUT,1415)NSUMM
16850 1415   FORMAT('      THE NUMBER OF ROWS = ',I8)
16851        CALL DPWRST('XXX','WRIT')
16852        IERROR='YES'
16853        GOTO9000
16854      ENDIF
16855C
16856      DO1420I=1,NSUMM
16857C
16858        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ODC2')THEN
16859          WRITE(ICOUT,1401)I,TEMP1(I),TEMP2(I)
16860 1401     FORMAT('I,TEMP1(I),TEMP2(I) = ',I8,2G15.7)
16861          CALL DPWRST('XXX','WRIT')
16862        ENDIF
16863C
16864        ITEMP=INT(TEMP1(I)+0.5)
16865        IF(ITEMP.LT.0)THEN
16866          WRITE(ICOUT,999)
16867          CALL DPWRST('XXX','WRIT')
16868          WRITE(ICOUT,1101)
16869          CALL DPWRST('XXX','WRIT')
16870          WRITE(ICOUT,1421)
16871 1421     FORMAT('      FOR THE SUMMARY DATA, THE DATA VALUES ',
16872     1          'DENOTE COUNTS.')
16873          CALL DPWRST('XXX','WRIT')
16874          WRITE(ICOUT,1423)I
16875 1423     FORMAT('      A NEGATIVE COUNT WAS ENCOUNTERED FOR ',
16876     1           'RESPONSE VARIABLE ONE FOR ROW ',I8)
16877          CALL DPWRST('XXX','WRIT')
16878          IERROR='YES'
16879          GOTO9000
16880        ENDIF
16881        TEMP1(I)=REAL(ITEMP)
16882C
16883        ITEMP=INT(TEMP2(I)+0.5)
16884        IF(ITEMP.LT.0)THEN
16885          WRITE(ICOUT,999)
16886          CALL DPWRST('XXX','WRIT')
16887          WRITE(ICOUT,1101)
16888          CALL DPWRST('XXX','WRIT')
16889          WRITE(ICOUT,1431)
16890 1431     FORMAT('      FOR THE SUMMARY DATA CASE, THE DATA VALUES ',
16891     1          'DENOTE COUNTS.')
16892          CALL DPWRST('XXX','WRIT')
16893          WRITE(ICOUT,1433)I
16894 1433     FORMAT('      A NEGATIVE COUNT WAS ENCOUNTERED FOR ',
16895     1           'RESPONSE VARIABLE TWO FOR ROW ',I8)
16896          CALL DPWRST('XXX','WRIT')
16897          IERROR='YES'
16898          GOTO9000
16899        ENDIF
16900        TEMP2(I)=REAL(ITEMP)
16901 1420 CONTINUE
16902C
16903C               ********************************************
16904C               **  STEP 20--                             **
16905C               **  GENERATE THE LOG ODDS RATIO TABLE     **
16906C               **  AND COMPUTE THE CHI-SQUARE ANALYSIS   **
16907C               **  OF THE LOG ODDS RATIO.                **
16908C               ********************************************
16909C
16910      ISTEPN='20'
16911      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'ODC2')
16912     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16913C
16914      NTEMP=2
16915      MAXGRP=10000
16916      DO2010K=1,NGROUP
16917        ISTRT=(K-1)*2+1
16918        CALL ODDRAT(TEMP1(ISTRT),NTEMP,TEMP2(ISTRT),NTEMP,PSTAMV,
16919     1              IWRITE,TEMP5,STAT,
16920     1              IBUGA3,IERROR)
16921        TEMP3(K)=STAT
16922        CALL LOGIT(TEMP1(ISTRT),NTEMP,TEMP2(ISTRT),NTEMP,PSTAMV,
16923     1              IWRITE,TEMP5,STAT,
16924     1              IBUGA3,IERROR)
16925        TEMP3(MAXGRP+K)=STAT
16926        CALL LOGISE(TEMP1(ISTRT),NTEMP,TEMP2(ISTRT),NTEMP,PSTAMV,
16927     1              IWRITE,TEMP5,STAT,
16928     1              IBUGA3,IERROR)
16929        TEMP3(2*MAXGRP+K)=STAT
16930        WEIGH(K)=1.0/(TEMP3(2*MAXGRP+K)**2)
16931 2010 CONTINUE
16932C
16933C     PRINT SUMMARY OF LOG(ODDS RATIO) TABLE
16934C
16935      IF(IPRINT.EQ.'OFF')GOTO9000
16936C
16937      NUMDIG=7
16938      IF(IFORSW.EQ.'1')NUMDIG=1
16939      IF(IFORSW.EQ.'2')NUMDIG=2
16940      IF(IFORSW.EQ.'3')NUMDIG=3
16941      IF(IFORSW.EQ.'4')NUMDIG=4
16942      IF(IFORSW.EQ.'5')NUMDIG=5
16943      IF(IFORSW.EQ.'6')NUMDIG=6
16944      IF(IFORSW.EQ.'7')NUMDIG=7
16945      IF(IFORSW.EQ.'8')NUMDIG=8
16946      IF(IFORSW.EQ.'9')NUMDIG=9
16947      IF(IFORSW.EQ.'0')NUMDIG=0
16948      IF(IFORSW.EQ.'E')NUMDIG=-2
16949      IF(IFORSW.EQ.'-2')NUMDIG=-2
16950      IF(IFORSW.EQ.'-3')NUMDIG=-3
16951      IF(IFORSW.EQ.'-4')NUMDIG=-4
16952      IF(IFORSW.EQ.'-5')NUMDIG=-5
16953      IF(IFORSW.EQ.'-6')NUMDIG=-6
16954      IF(IFORSW.EQ.'-7')NUMDIG=-7
16955      IF(IFORSW.EQ.'-8')NUMDIG=-8
16956      IF(IFORSW.EQ.'-9')NUMDIG=-9
16957C
16958      ITITLE(1:26)='Summary of Log(Odds Ratio)'
16959      NCTITL=26
16960      ITITL9=' '
16961      NCTIT9=0
16962C
16963      ITITL2(1,1)=' '
16964      NCTIT2(1,1)=0
16965      ITITL2(2,1)=' '
16966      NCTIT2(2,1)=0
16967      ITITL2(3,1)='Group'
16968      NCTIT2(3,1)=5
16969C
16970      ITITL2(1,2)=' | '
16971      NCTIT2(1,2)=3
16972      ITITL2(2,2)=' | '
16973      NCTIT2(2,2)=3
16974      ITITL2(3,2)=' | '
16975      NCTIT2(3,2)=3
16976C
16977      ITITL2(1,3)=' '
16978      NCTIT2(1,3)=0
16979      ITITL2(2,3)='Odds Ratio'
16980      NCTIT2(2,3)=10
16981      ITITL2(3,3)='O(i)'
16982      NCTIT2(3,3)=4
16983C
16984      ITITL2(1,4)='Log of'
16985      NCTIT2(1,4)=6
16986      ITITL2(2,4)='Odds Ratio'
16987      NCTIT2(2,4)=10
16988      ITITL2(3,4)='L(i)'
16989      NCTIT2(3,4)=4
16990C
16991      ITITL2(1,5)='Standard'
16992      NCTIT2(1,5)=8
16993      ITITL2(2,5)='Error'
16994      NCTIT2(2,5)=5
16995      ITITL2(3,5)='SE(L(i))'
16996      NCTIT2(3,5)=8
16997C
16998      ITITL2(1,6)=' '
16999      NCTIT2(1,6)=0
17000      ITITL2(2,6)='1/SE(L(i))**2'
17001      NCTIT2(2,6)=13
17002      ITITL2(3,6)='w(i)'
17003      NCTIT2(3,6)=4
17004C
17005      ITITL2(1,7)=' '
17006      NCTIT2(1,7)=0
17007      ITITL2(2,7)='w(i)*'
17008      NCTIT2(2,7)=5
17009      ITITL2(3,7)='L(i)**2'
17010      NCTIT2(3,7)=7
17011C
17012      NMAX=0
17013      NUMCOL=7
17014      DO4010I=1,NUMCOL
17015        VALIGN(I)='b'
17016        ALIGN(I)='r'
17017        ITYPCO(I)='NUME'
17018        NTOT(I)=15
17019        NCOLSP(1,I)=1
17020        NCOLSP(2,I)=1
17021        NCOLSP(3,I)=1
17022        IF(I.EQ.2)THEN
17023          ITYPCO(I)='ALPH'
17024          NTOT(I)=3
17025        ELSEIF(I.EQ.1)THEN
17026          ITYPCO(I)='ALPH'
17027        ENDIF
17028        NMAX=NMAX+NTOT(I)
17029 4010 CONTINUE
17030      IWHTML(1)=125
17031      IWHTML(2)=50
17032      IWHTML(3)=150
17033      IWHTML(4)=150
17034      IWHTML(5)=150
17035      IWHTML(6)=150
17036      IWHTML(7)=150
17037      IINC=1600
17038      IINC2=200
17039      IINC3=1000
17040      IWRTF(1)=IINC3
17041      IWRTF(2)=IWRTF(1)+IINC2
17042      IWRTF(3)=IWRTF(2)+IINC
17043      IWRTF(4)=IWRTF(3)+IINC
17044      IWRTF(5)=IWRTF(4)+IINC
17045      IWRTF(6)=IWRTF(5)+IINC
17046      IWRTF(7)=IWRTF(6)+IINC
17047C
17048      DSUM1=0.0D0
17049      DSUM2=0.0D0
17050      DSUM3=0.0D0
17051      DSUM4=0.0D0
17052C
17053      DO4081J=1,NGROUP
17054        ATEMP=WEIGH(J)*TEMP3(MAXGRP+J)**2
17055        ATEMP2=WEIGH(J)*TEMP3(MAXGRP+J)
17056        DSUM1=DSUM1 + DBLE(WEIGH(J))
17057        DSUM2=DSUM2 + DBLE(ATEMP)
17058        DSUM3=DSUM3 + DBLE(TEMP3(MAXGRP+J))
17059        DSUM4=DSUM4 + DBLE(ATEMP2)
17060        DO4083I=1,NUMCOL
17061          IVALUE(J,I)=' '
17062          NCVALU(J,I)=0
17063          AMAT(J,I)=0.0
17064          IF(I.EQ.1)THEN
17065            IDIGI2(J,I)=0
17066          ELSE
17067            IDIGI2(J,I)=NUMDIG
17068          ENDIF
17069 4083   CONTINUE
17070        IVALUE(J,2)=' | '
17071        NCVALU(J,2)=3
17072        IJUNK=INT(XIDTEM(J)+0.5)
17073        IF(IJUNK.LE.9)THEN
17074          WRITE(IVALUE(J,1)(1:1),'(I1)')IJUNK
17075          NCVALU(J,1)=1
17076        ELSEIF(IJUNK.LE.99)THEN
17077          WRITE(IVALUE(J,1)(1:2),'(I2)')IJUNK
17078          NCVALU(J,1)=2
17079        ELSEIF(IJUNK.LE.999)THEN
17080          WRITE(IVALUE(J,1)(1:3),'(I3)')IJUNK
17081          NCVALU(J,1)=3
17082        ELSEIF(IJUNK.LE.9999)THEN
17083          WRITE(IVALUE(J,1)(1:4),'(I4)')IJUNK
17084          NCVALU(J,1)=4
17085        ELSEIF(IJUNK.LE.99999)THEN
17086          WRITE(IVALUE(J,1)(1:5),'(I5)')IJUNK
17087          NCVALU(J,1)=5
17088        ELSEIF(IJUNK.LE.999999)THEN
17089          WRITE(IVALUE(J,1)(1:6),'(I6)')IJUNK
17090          NCVALU(J,1)=6
17091        ELSE
17092          NCVALU(J,1)=0
17093        ENDIF
17094CCCCC   AMAT(J,1)=XIDTEM(J)
17095        AMAT(J,3)=TEMP3(J)
17096        AMAT(J,4)=TEMP3(MAXGRP+J)
17097        AMAT(J,5)=TEMP3(2*MAXGRP+J)
17098        AMAT(J,6)=WEIGH(J)
17099        AMAT(J,7)=ATEMP
17100        ROWSEP(J)=0
17101 4081 CONTINUE
17102      J=NGROUP+1
17103      DO4093I=1,NUMCOL
17104        IVALUE(J,I)=' '
17105        NCVALU(J,I)=0
17106        AMAT(J,I)=0.0
17107        IF(I.EQ.1)THEN
17108            IDIGI2(J,I)=0
17109        ELSEIF(I.GE.3 .AND. I.LE.5)THEN
17110            IDIGI2(J,I)=-1
17111        ELSE
17112          IDIGI2(J,I)=NUMDIG
17113        ENDIF
17114 4093 CONTINUE
17115      IVALUE(J,1)='Total'
17116      NCVALU(J,1)=5
17117      IVALUE(J,2)=' | '
17118      NCVALU(J,2)=3
17119      AMAT(J,3)=CPUMIN
17120      AMAT(J,4)=CPUMIN
17121      AMAT(J,5)=CPUMIN
17122      AMAT(J,6)=REAL(DSUM1)
17123      AMAT(J,7)=REAL(DSUM2)
17124      ROWSEP(J-1)=1
17125      ROWSEP(J)=0
17126C
17127      ICNT=NGROUP+1
17128      NUMLIN=3
17129      IFRST=.TRUE.
17130      ILAST=.TRUE.
17131      IFLAGS=.TRUE.
17132      IFLAGE=.TRUE.
17133      CALL DPDT5B(ITITLE,NCTITL,
17134     1            ITITL9,NCTIT9,ITITL2,NCTIT2,
17135     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
17136     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXRO2,ICNT,
17137     1            IDIGI2,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
17138     1            NCOLSP,ROWSEP,
17139     1            ICAPSW,ICAPTY,IFRST,ILAST,
17140     1            IFLAGS,IFLAGE,
17141     1            ISUBRO,IBUGA3,IERROR)
17142C
17143      ODDRCO=REAL(DSUM4/DSUM1)
17144      ODDRSE=REAL(1.0D0/DSQRT(DSUM1))
17145      STATTO=REAL(DSUM2)
17146      IDFTO=NGROUP
17147      CALL CHSCDF(STATTO,IDFTO,CDFTOT)
17148      STATAS=(ODDRCO/ODDRSE)**2
17149      IDFAS=1
17150      CALL CHSCDF(STATAS,IDFAS,CDFASS)
17151      STATHO=STATTO - STATAS
17152      IDFHO=NGROUP - 1
17153      CALL CHSCDF(STATHO,IDFAS,CDFHO)
17154C
17155      ITITLE='Chi-Square Analysis of Log(Odds Ratio)'
17156      NCTITL=38
17157      ITITLZ=' '
17158      NCTITZ=0
17159C
17160      ICNT=0
17161      ICNT=ICNT+1
17162      ITEXT(ICNT)=' '
17163      NCTEXT(ICNT)=0
17164      AVALUE(ICNT)=0.0
17165      IDIGIT(ICNT)=-1
17166      ICNT=ICNT+1
17167      ITEXT(ICNT)='Number of Groups:'
17168      NCTEXT(ICNT)=17
17169      AVALUE(ICNT)=REAL(NGROUP)
17170      IDIGIT(ICNT)=0
17171      ICNT=ICNT+1
17172      ITEXT(ICNT)='Estimate of Combined Log(Odds Ratio):'
17173      NCTEXT(ICNT)=37
17174      AVALUE(ICNT)=ODDRCO
17175      IDIGIT(ICNT)=NUMDIG
17176      ICNT=ICNT+1
17177      ITEXT(ICNT)='Standard Error of Combined Log(Odds Ratio):'
17178      NCTEXT(ICNT)=43
17179      AVALUE(ICNT)=ODDRSE
17180      IDIGIT(ICNT)=NUMDIG
17181      ICNT=ICNT+1
17182      ITEXT(ICNT)=' '
17183      NCTEXT(ICNT)=0
17184      AVALUE(ICNT)=0.0
17185      IDIGIT(ICNT)=-1
17186C
17187      ICNT=ICNT+1
17188      ITEXT(ICNT)='Chi-Square Test Statistic (Total):'
17189      NCTEXT(ICNT)=34
17190      AVALUE(ICNT)=STATTO
17191      IDIGIT(ICNT)=NUMDIG
17192      ICNT=ICNT+1
17193      ITEXT(ICNT)='Degrees of Freeedom:'
17194      NCTEXT(ICNT)=20
17195      AVALUE(ICNT)=REAL(IDFTO)
17196      IDIGIT(ICNT)=0
17197      ICNT=ICNT+1
17198      ITEXT(ICNT)='CDF of Test Statistic:'
17199      NCTEXT(ICNT)=22
17200      AVALUE(ICNT)=CDFTOT
17201      IDIGIT(ICNT)=NUMDIG
17202      ICNT=ICNT+1
17203      ITEXT(ICNT)=' '
17204      NCTEXT(ICNT)=0
17205      AVALUE(ICNT)=0.0
17206      IDIGIT(ICNT)=-1
17207C
17208      ICNT=ICNT+1
17209      ITEXT(ICNT)='Chi-Square Test Statistic (Association):'
17210      NCTEXT(ICNT)=40
17211      AVALUE(ICNT)=STATAS
17212      IDIGIT(ICNT)=NUMDIG
17213      ICNT=ICNT+1
17214      ITEXT(ICNT)='Degrees of Freedom:'
17215      NCTEXT(ICNT)=19
17216      AVALUE(ICNT)=REAL(IDFAS)
17217      IDIGIT(ICNT)=0
17218      ICNT=ICNT+1
17219      ITEXT(ICNT)='CDF of Test Statistic:'
17220      NCTEXT(ICNT)=22
17221      AVALUE(ICNT)=CDFASS
17222      IDIGIT(ICNT)=NUMDIG
17223      ICNT=ICNT+1
17224      ITEXT(ICNT)=' '
17225      NCTEXT(ICNT)=0
17226      AVALUE(ICNT)=0.0
17227      IDIGIT(ICNT)=-1
17228C
17229      ICNT=ICNT+1
17230      ITEXT(ICNT)='Chi-Square Test Statistic (Homogeneity):'
17231      NCTEXT(ICNT)=40
17232      AVALUE(ICNT)=STATHO
17233      IDIGIT(ICNT)=NUMDIG
17234      ICNT=ICNT+1
17235      ITEXT(ICNT)='Degrees of Freedom:'
17236      NCTEXT(ICNT)=19
17237      AVALUE(ICNT)=REAL(IDFHO)
17238      IDIGIT(ICNT)=0
17239      ICNT=ICNT+1
17240      ITEXT(ICNT)='CDF of Test Statistic:'
17241      NCTEXT(ICNT)=22
17242      AVALUE(ICNT)=CDFHO
17243      IDIGIT(ICNT)=NUMDIG
17244      ICNT=ICNT+1
17245      ITEXT(ICNT)=' '
17246      NCTEXT(ICNT)=0
17247      AVALUE(ICNT)=0.0
17248      IDIGIT(ICNT)=-1
17249C
17250      NUMROW=ICNT
17251      DO4090I=1,NUMROW
17252        NTOT(I)=15
17253 4090 CONTINUE
17254C
17255      IFRST=.TRUE.
17256      ILAST=.TRUE.
17257      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,
17258     1            NCTEXT,AVALUE,IDIGIT,
17259     1            NTOT,NUMROW,
17260     1            ICAPSW,ICAPTY,ILAST,IFRST,
17261     1            ISUBRO,IBUGA3,IERROR)
17262C
17263C               ********************************************
17264C               **  STEP 22--                             **
17265C               **  PRINT TABLE FOR HOMOGENEITY TEST      **
17266C               ********************************************
17267C
17268      ISTEPN='22'
17269      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'ODC2')
17270     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17271C
17272      ICONC1='REJECT'
17273      ICONC2='REJECT'
17274      ICONC3='REJECT'
17275      ICONC4='REJECT'
17276      ICONC5='REJECT'
17277      ICONC6='REJECT'
17278C
17279      CALL CHSPPF(SIGVAL(1),IDFHO,CV1)
17280      CALL CHSPPF(SIGVAL(2),IDFHO,CV2)
17281      CALL CHSPPF(SIGVAL(3),IDFHO,CV3)
17282      CALL CHSPPF(SIGVAL(4),IDFHO,CV4)
17283      CALL CHSPPF(SIGVAL(5),IDFHO,CV5)
17284      CALL CHSPPF(SIGVAL(6),IDFHO,CV6)
17285C
17286      IF(0.000.LE.CDFHO.AND.CDFHO.LE.SIGVAL(1))ICONC1='ACCEPT'
17287      IF(0.000.LE.CDFHO.AND.CDFHO.LE.SIGVAL(2))ICONC2='ACCEPT'
17288      IF(0.000.LE.CDFHO.AND.CDFHO.LE.SIGVAL(3))ICONC3='ACCEPT'
17289      IF(0.000.LE.CDFHO.AND.CDFHO.LE.SIGVAL(4))ICONC4='ACCEPT'
17290      IF(0.000.LE.CDFHO.AND.CDFHO.LE.SIGVAL(5))ICONC5='ACCEPT'
17291      IF(0.000.LE.CDFHO.AND.CDFHO.LE.SIGVAL(6))ICONC6='ACCEPT'
17292C
17293      ITITLE(1:34)='Chi-Square Test for Consistency of'
17294      ITITLE(35:60)=' Association (Homogeneity)'
17295      NCTITL=60
17296      ITITL9=' '
17297      NCTIT9=0
17298C
17299      ITITL2(1,1)=' '
17300      NCTIT2(1,1)=0
17301      ITITL2(2,1)='Null'
17302      NCTIT2(2,1)=4
17303      ITITL2(3,1)='Hypothesis'
17304      NCTIT2(3,1)=10
17305C
17306      ITITL2(1,2)=' '
17307      NCTIT2(1,2)=0
17308      ITITL2(2,2)='Confidence'
17309      NCTIT2(2,2)=10
17310      ITITL2(3,2)='Level'
17311      NCTIT2(3,2)=5
17312C
17313      ITITL2(1,3)=' '
17314      NCTIT2(1,3)=0
17315      ITITL2(2,3)='Critical'
17316      NCTIT2(2,3)=8
17317      ITITL2(3,3)='Value'
17318      NCTIT2(3,3)=5
17319C
17320      ITITL2(1,4)='Null Hypothesis'
17321      NCTIT2(1,4)=15
17322      ITITL2(2,4)='Acceptance'
17323      NCTIT2(2,4)=10
17324      ITITL2(3,4)='Interval'
17325      NCTIT2(3,4)=8
17326C
17327      ITITL2(1,5)='Null'
17328      NCTIT2(1,5)=4
17329      ITITL2(2,5)='Hypothesis'
17330      NCTIT2(2,5)=10
17331      ITITL2(3,5)='Conclusion'
17332      NCTIT2(3,5)=10
17333C
17334      NMAX=0
17335      NUMCOL=5
17336      DO4110I=1,NUMCOL
17337        VALIGN(I)='b'
17338        ALIGN(I)='r'
17339        NTOT(I)=15
17340        NMAX=NMAX+NTOT(I)
17341        IF(I.EQ.3)THEN
17342          ITYPCO(I)='NUME'
17343        ELSE
17344          ITYPCO(I)='ALPH'
17345        ENDIF
17346        IF(I.EQ.2)THEN
17347          IDIGIT(I)=1
17348        ELSEIF(I.EQ.3)THEN
17349          IDIGIT(I)=2
17350        ELSE
17351          IDIGIT(I)=NUMDIG
17352        ENDIF
17353        DO4111J=1,NUMALP
17354          NCVALU(J,I)=0
17355 4111   CONTINUE
17356 4110 CONTINUE
17357C
17358      IWHTML(1)=150
17359      IWHTML(2)=125
17360      IWHTML(3)=125
17361      IWHTML(4)=150
17362      IWHTML(5)=150
17363      IINC=1600
17364      IINC2=1400
17365      IINC3=2200
17366      IWRTF(1)=IINC
17367      IWRTF(2)=IWRTF(1)+IINC
17368      IWRTF(3)=IWRTF(2)+IINC2
17369      IWRTF(4)=IWRTF(3)+IINC3
17370      IWRTF(5)=IWRTF(4)+IINC2
17371C
17372      IVALUE(1,2)='50.0%'
17373      NCVALU(1,2)=5
17374      AMAT(1,3)=CV1
17375      IVALUE(1,4)='(0,0.500)'
17376      NCVALU(1,4)=9
17377      IVALUE(1,5)(1:6)=ICONC1(1:6)
17378      NCVALU(1,5)=6
17379C
17380      IVALUE(2,2)='80.0%'
17381      NCVALU(2,2)=5
17382      AMAT(2,3)=CV2
17383      IVALUE(2,4)='(0,0.800)'
17384      NCVALU(2,4)=9
17385      IVALUE(2,5)(1:6)=ICONC2(1:6)
17386      NCVALU(2,5)=6
17387C
17388      IVALUE(3,2)='90.0%'
17389      NCVALU(3,2)=5
17390      AMAT(3,3)=CV3
17391      IVALUE(3,4)='(0,0.900)'
17392      NCVALU(3,4)=9
17393      IVALUE(3,5)(1:6)=ICONC3(1:6)
17394      NCVALU(3,5)=6
17395C
17396      IVALUE(4,2)='95.0%'
17397      NCVALU(4,2)=5
17398      AMAT(4,3)=CV4
17399      IVALUE(4,4)='(0,0.950)'
17400      NCVALU(4,4)=9
17401      IVALUE(4,5)(1:6)=ICONC4(1:6)
17402      NCVALU(4,5)=6
17403C
17404      IVALUE(5,2)='97.5%'
17405      NCVALU(5,2)=5
17406      AMAT(5,3)=CV5
17407      IVALUE(5,4)='(0,0.975)'
17408      NCVALU(5,4)=9
17409      IVALUE(5,5)(1:6)=ICONC5(1:6)
17410      NCVALU(5,5)=6
17411C
17412      IVALUE(6,2)='99.0%'
17413      NCVALU(6,2)=5
17414      AMAT(6,3)=CV6
17415      IVALUE(6,4)='(0,0.990)'
17416      NCVALU(6,4)=9
17417      IVALUE(6,5)(1:6)=ICONC6(1:6)
17418      NCVALU(6,5)=6
17419C
17420      DO4120J=1,NUMALP
17421        AMAT(J,1)=0.0
17422        AMAT(J,2)=0.0
17423        AMAT(J,4)=0.0
17424        AMAT(J,5)=0.0
17425        IVALUE(J,1)='Consistent'
17426        NCVALU(J,1)=10
17427 4120 CONTINUE
17428C
17429      ICNT=NUMALP
17430      NUMLIN=3
17431      NUMCOL=5
17432      IFRST=.TRUE.
17433      ILAST=.TRUE.
17434      IFLAGS=.TRUE.
17435      IFLAGE=.TRUE.
17436C
17437      CALL DPDTA5(ITITLE,NCTITL,
17438     1            ITITL9,NCTIT9,ITITL2,NCTIT2,
17439     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
17440     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXRO2,ICNT,
17441     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
17442     1            ICAPSW,ICAPTY,IFRST,ILAST,
17443     1            IFLAGS,IFLAGE,
17444     1            ISUBRO,IBUGA3,IERROR)
17445C
17446C               ************************************************
17447C               **  STEP 23--                                 **
17448C               **  PRINT TABLE FOR OVERALL ASSOCIATION TEST  **
17449C               ************************************************
17450C
17451      ISTEPN='23'
17452      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'ODC2')
17453     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17454C
17455      ICONC1='REJECT'
17456      ICONC2='REJECT'
17457      ICONC3='REJECT'
17458      ICONC4='REJECT'
17459      ICONC5='REJECT'
17460      ICONC6='REJECT'
17461C
17462      CALL CHSPPF(SIGVAL(1),IDFAS,CV1)
17463      CALL CHSPPF(SIGVAL(2),IDFAS,CV2)
17464      CALL CHSPPF(SIGVAL(3),IDFAS,CV3)
17465      CALL CHSPPF(SIGVAL(4),IDFAS,CV4)
17466      CALL CHSPPF(SIGVAL(5),IDFAS,CV5)
17467      CALL CHSPPF(SIGVAL(6),IDFAS,CV6)
17468C
17469      IF(0.000.LE.CDFASS.AND.CDFASS.LE.SIGVAL(1))ICONC1='ACCEPT'
17470      IF(0.000.LE.CDFASS.AND.CDFASS.LE.SIGVAL(2))ICONC2='ACCEPT'
17471      IF(0.000.LE.CDFASS.AND.CDFASS.LE.SIGVAL(3))ICONC3='ACCEPT'
17472      IF(0.000.LE.CDFASS.AND.CDFASS.LE.SIGVAL(4))ICONC4='ACCEPT'
17473      IF(0.000.LE.CDFASS.AND.CDFASS.LE.SIGVAL(5))ICONC5='ACCEPT'
17474      IF(0.000.LE.CDFASS.AND.CDFASS.LE.SIGVAL(6))ICONC6='ACCEPT'
17475C
17476      ITITLE(1:34)='Chi-Square Test for Overall Degree'
17477      ITITLE(35:49)=' of Association'
17478      NCTITL=49
17479      ITITL9=' '
17480      NCTIT9=0
17481C
17482      AMAT(1,3)=CV1
17483      IVALUE(1,5)(1:6)=ICONC1(1:6)
17484C
17485      AMAT(2,3)=CV2
17486      IVALUE(2,5)(1:6)=ICONC2(1:6)
17487C
17488      AMAT(3,3)=CV3
17489      IVALUE(3,5)(1:6)=ICONC3(1:6)
17490C
17491      AMAT(4,3)=CV4
17492      IVALUE(4,5)(1:6)=ICONC4(1:6)
17493C
17494      AMAT(5,3)=CV5
17495      IVALUE(5,5)(1:6)=ICONC5(1:6)
17496C
17497      AMAT(6,3)=CV6
17498      IVALUE(6,5)(1:6)=ICONC6(1:6)
17499C
17500      DO4210J=1,NUMALP
17501        IVALUE(J,1)='No Association'
17502        NCVALU(J,1)=14
17503 4210 CONTINUE
17504C
17505      ICNT=NUMALP
17506      NUMLIN=3
17507      NUMCOL=5
17508      IFRST=.TRUE.
17509      ILAST=.TRUE.
17510      IFLAGS=.TRUE.
17511      IFLAGE=.TRUE.
17512      CALL DPDTA5(ITITLE,NCTITL,
17513     1            ITITL9,NCTIT9,ITITL2,NCTIT2,
17514     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
17515     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXRO2,ICNT,
17516     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
17517     1            ICAPSW,ICAPTY,IFRST,ILAST,
17518     1            IFLAGS,IFLAGE,
17519     1            ISUBRO,IBUGA3,IERROR)
17520C
17521C               ************************************************
17522C               **  STEP 24--                                 **
17523C               **  PRINT TABLE FOR CONFIDENCE INTERVAL FOR   **
17524C               **  COMMON LOG(ODDS RATIO)                    **
17525C               ************************************************
17526C
17527      ISTEPN='24'
17528      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'ODC2')
17529     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17530C
17531      IOP='OPEN'
17532      IFLAG1=1
17533      IFLAG2=0
17534      IFLAG3=0
17535      IFLAG4=0
17536      IFLAG5=0
17537      CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
17538     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
17539     1            IBUGA3,ISUBRO,IERROR)
17540      IF(IERROR.EQ.'YES')GOTO9000
17541C
17542      IFORMT='(F10.5,1X,4E15.7)'
17543      IF(IAUXDP.NE.7)THEN
17544        IFORMT=' '
17545        IF(IAUXDP.LE.9)THEN
17546          IFORMT='(F10.5,1X,4Exx.x)'
17547          ITOT=IAUXDP+8
17548          WRITE(IFORMT(13:14),'(I2)')ITOT
17549          WRITE(IFORMT(16:16),'(I1)')IAUXDP
17550        ELSE
17551          IFORMT='(F10.5,1X,4Exx.xx)'
17552          ITOT=IAUXDP+8
17553          WRITE(IFORMT(13:14),'(I2)')ITOT
17554          WRITE(IFORMT(16:17),'(I2)')IAUXDP
17555        ENDIF
17556      ENDIF
17557C
17558      DO4310I=1,NUMALP
17559        ALPHA=(1.0 - SIGVAL(I))/2.0
17560        CALL NORPPF(ALPHA,CV)
17561        ALOWCL(I)=ODDRCO + CV*ODDRSE
17562        AUPPCL(I)=ODDRCO - CV*ODDRSE
17563        ALOWC2(I)=EXP(ALOWCL(I))
17564        AUPPC2(I)=EXP(AUPPCL(I))
17565        WRITE(IOUNI1,IFORMT)ALPHA,ALOWCL(I),AUPPCL(I),
17566     1                      ALOWC2(I),AUPPC2(I)
17567C4311   FORMAT(F10.5,1X,4E15.7)
17568 4310 CONTINUE
17569C
17570      IOP='CLOS'
17571      CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
17572     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
17573     1            IBUGA3,ISUBRO,IERROR)
17574      IF(IERROR.EQ.'YES')GOTO9000
17575C
17576      ITITLE(1:33)='Large Sample Confidence Interval '
17577      ITITLE(34:52)='for Log(Odds Ratio)'
17578      NCTITL=52
17579      ITITL9=' '
17580      NCTIT9=0
17581C
17582      ITITL2(1,1)=' '
17583      NCTIT2(1,1)=0
17584      NCOLSP(1,1)=1
17585      ITITL2(2,1)=' '
17586      NCTIT2(2,1)=0
17587      NCOLSP(2,1)=1
17588      ITITL2(3,1)='Confidence'
17589      NCTIT2(3,1)=10
17590      NCOLSP(3,1)=1
17591      ITITL2(4,1)='Value (%)'
17592      NCTIT2(4,1)=9
17593      NCOLSP(4,1)=1
17594C
17595      ITITL2(1,2)='Log(Odds Ratio)'
17596      NCTIT2(1,2)=15
17597      NCOLSP(1,2)=2
17598      ITITL2(2,2)='(               )'
17599      WRITE(ITITL2(2,2)(2:16),'(G15.7)')ODDRCO
17600      NCTIT2(2,2)=17
17601      NCOLSP(2,2)=2
17602      ITITL2(3,2)='Lower'
17603      NCTIT2(3,2)=5
17604      NCOLSP(3,2)=1
17605      ITITL2(4,2)='Limit'
17606      NCTIT2(4,2)=5
17607      NCOLSP(4,2)=1
17608C
17609      ITITL2(1,3)=' '
17610      NCTIT2(1,3)=0
17611      NCOLSP(1,3)=0
17612      ITITL2(2,3)=' '
17613      NCTIT2(2,3)=0
17614      NCOLSP(2,3)=0
17615      ITITL2(3,3)='Upper'
17616      NCTIT2(3,3)=5
17617      NCOLSP(3,3)=1
17618      ITITL2(4,3)='Limit'
17619      NCTIT2(4,3)=5
17620      NCOLSP(4,3)=1
17621C
17622      ITITL2(1,4)='Odds Ratio'
17623      NCTIT2(1,4)=10
17624      NCOLSP(1,4)=2
17625      ITITL2(2,4)='(               )'
17626      WRITE(ITITL2(2,4)(2:16),'(G15.7)')EXP(ODDRCO)
17627      NCTIT2(2,4)=17
17628      NCOLSP(2,4)=2
17629      ITITL2(3,4)='Lower'
17630      NCTIT2(3,4)=5
17631      NCOLSP(3,4)=1
17632      ITITL2(4,4)='Limit'
17633      NCTIT2(4,4)=5
17634      NCOLSP(4,4)=1
17635C
17636      ITITL2(1,5)=' '
17637      NCTIT2(1,5)=0
17638      NCOLSP(1,5)=0
17639      ITITL2(2,5)=' '
17640      NCTIT2(2,5)=0
17641      NCOLSP(2,5)=0
17642      ITITL2(3,5)='Upper'
17643      NCTIT2(3,5)=5
17644      NCOLSP(3,5)=1
17645      ITITL2(4,5)='Limit'
17646      NCTIT2(4,5)=5
17647      NCOLSP(4,5)=1
17648C
17649      NMAX=0
17650      DO4410I=1,NUMCLI
17651        VALIGN(I)='b'
17652        ALIGN(I)='r'
17653        NTOT(I)=15
17654        NMAX=NMAX+NTOT(I)
17655        ITYPCO(I)='NUME'
17656        DO4420J=1,MAXROW
17657          IF(I.EQ.1)THEN
17658            IDIGI2(J,I)=2
17659          ELSE
17660            IDIGI2(J,I)=NUMDIG
17661          ENDIF
17662 4420   CONTINUE
17663        IWHTML(1)=75
17664        IWHTML(2)=150
17665        IWHTML(3)=150
17666        IWHTML(4)=150
17667        IWHTML(5)=150
17668        IINC=1400
17669        IWRTF(1)=IINC
17670        IWRTF(2)=IWRTF(1)+IINC
17671        IWRTF(3)=IWRTF(2)+IINC
17672        IWRTF(4)=IWRTF(3)+IINC
17673        IWRTF(5)=IWRTF(4)+IINC
17674        IFRST=.TRUE.
17675        ILAST=.TRUE.
17676C
17677        DO4430J=1,NUMALP
17678          ATEMP=100.0*SIGVAL(J)
17679          AMAT(J,1)=ATEMP
17680          AMAT(J,2)=ALOWCL(J)
17681          AMAT(J,3)=AUPPCL(J)
17682          AMAT(J,4)=ALOWC2(J)
17683          AMAT(J,5)=AUPPC2(J)
17684          IVALUE(J,1)=' '
17685          IVALUE(J,2)=' '
17686          IVALUE(J,3)=' '
17687          IVALUE(J,4)=' '
17688          IVALUE(J,5)=' '
17689          NCVALU(J,1)=0
17690          NCVALU(J,2)=0
17691          NCVALU(J,3)=0
17692          NCVALU(J,4)=0
17693          NCVALU(J,5)=0
17694          ROWSEP(J)=0
17695 4430   CONTINUE
17696C
17697 4410 CONTINUE
17698C
17699      NUMLIN=4
17700      NUMCOL=5
17701      ICNT=NUMALP
17702      IFLAGS=.TRUE.
17703      IFLAGE=.TRUE.
17704      CALL DPDT5B(ITITLE,NCTITL,
17705     1            ITITL9,NCTIT9,ITITL2,NCTIT2,
17706     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
17707     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXRO2,ICNT,
17708     1            IDIGI2,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
17709     1            NCOLSP,ROWSEP,
17710     1            ICAPSW,ICAPTY,IFRST,ILAST,
17711     1            IFLAGS,IFLAGE,
17712     1            ISUBRO,IBUGA3,IERROR)
17713C
17714C               *****************
17715C               **  STEP 90--  **
17716C               **  EXIT       **
17717C               *****************
17718C
17719 9000 CONTINUE
17720      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ODC2')THEN
17721        WRITE(ICOUT,999)
17722        CALL DPWRST('XXX','WRIT')
17723        WRITE(ICOUT,9011)
17724 9011   FORMAT('***** AT THE END       OF DPODC2--')
17725        CALL DPWRST('XXX','WRIT')
17726        WRITE(ICOUT,9013)AN11,AN21,AN12,AN22
17727 9013   FORMAT('AN11,AN21,AN12,AN22=',4G15.7)
17728        CALL DPWRST('XXX','WRIT')
17729        WRITE(ICOUT,9015)AN1,AN2
17730 9015   FORMAT('AN1,AN2=',2G15.7)
17731        CALL DPWRST('XXX','WRIT')
17732        WRITE(ICOUT,9017)N11,N21,N12,N22
17733 9017   FORMAT('N11,N21,N12,N22=',4I8)
17734        CALL DPWRST('XXX','WRIT')
17735      ENDIF
17736C
17737      RETURN
17738      END
17739      SUBROUTINE DPODI(A,LDA,N,DET,JOB)
17740C***BEGIN PROLOGUE  DPODI
17741C***DATE WRITTEN   780814   (YYMMDD)
17742C***REVISION DATE  820801   (YYMMDD)
17743C***CATEGORY NO.  D2B1B,D3B1B
17744C***KEYWORDS  DETERMINANT,DOUBLE PRECISION,FACTOR,INVERSE,
17745C             LINEAR ALGEBRA,LINPACK,MATRIX,POSITIVE DEFINITE
17746C***AUTHOR  MOLER, C. B., (U. OF NEW MEXICO)
17747C***PURPOSE  COMPUTES THE DETERMINANT AND INVERSE OF A CERTAIN DOUBLE
17748C            PRECISION SYMMETRIC POSITIVE DEFINITE MATRIX (SEE ABSTRACT)
17749C            USING THE FACTORS COMPUTED BY DPOCO, DPOFA OR DQRDC.
17750C***DESCRIPTION
17751C     DPODI COMPUTES THE DETERMINANT AND INVERSE OF A CERTAIN
17752C     DOUBLE PRECISION SYMMETRIC POSITIVE DEFINITE MATRIX (SEE BELOW)
17753C     USING THE FACTORS COMPUTED BY DPOCO, DPOFA OR DQRDC.
17754C     ON ENTRY
17755C        A       DOUBLE PRECISION(LDA, N)
17756C                THE OUTPUT  A  FROM DPOCO OR DPOFA
17757C                OR THE OUTPUT  X  FROM DQRDC.
17758C        LDA     INTEGER
17759C                THE LEADING DIMENSION OF THE ARRAY  A .
17760C        N       INTEGER
17761C                THE ORDER OF THE MATRIX  A .
17762C        JOB     INTEGER
17763C                = 11   BOTH DETERMINANT AND INVERSE.
17764C                = 01   INVERSE ONLY.
17765C                = 10   DETERMINANT ONLY.
17766C     ON RETURN
17767C        A       IF DPOCO OR DPOFA WAS USED TO FACTOR  A , THEN
17768C                DPODI PRODUCES THE UPPER HALF OF INVERSE(A) .
17769C                IF DQRDC WAS USED TO DECOMPOSE  X , THEN
17770C                DPODI PRODUCES THE UPPER HALF OF INVERSE(TRANS(X)*X)
17771C                WHERE TRANS(X) IS THE TRANSPOSE.
17772C                ELEMENTS OF  A  BELOW THE DIAGONAL ARE UNCHANGED.
17773C                IF THE UNITS DIGIT OF JOB IS ZERO,  A  IS UNCHANGED.
17774C        DET     DOUBLE PRECISION(2)
17775C                DETERMINANT OF  A  OR OF  TRANS(X)*X  IF REQUESTED.
17776C                OTHERWISE NOT REFERENCED.
17777C                DETERMINANT = DET(1) * 10.0**DET(2)
17778C                WITH  1.0 .LE. DET(1) .LT. 10.0
17779C                OR  DET(1) .EQ. 0.0 .
17780C     ERROR CONDITION
17781C        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS
17782C        A ZERO ON THE DIAGONAL AND THE INVERSE IS REQUESTED.
17783C        IT WILL NOT OCCUR IF THE SUBROUTINES ARE CALLED CORRECTLY
17784C        AND IF DPOCO OR DPOFA HAS SET INFO .EQ. 0 .
17785C     LINPACK.  THIS VERSION DATED 08/14/78 .
17786C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
17787C***REFERENCES  DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W.,
17788C                 *LINPACK USERS  GUIDE*, SIAM, 1979.
17789C***ROUTINES CALLED  DAXPY,DSCAL
17790C***END PROLOGUE  DPODI
17791
17792C...SCALAR ARGUMENTS
17793      INTEGER JOB,LDA,N
17794
17795C...ARRAY ARGUMENTS
17796      DOUBLE PRECISION A(LDA,*),DET(*)
17797
17798C...LOCAL SCALARS
17799      DOUBLE PRECISION S,T
17800      INTEGER I,J,JM1,K,KP1
17801
17802C...EXTERNAL SUBROUTINES
17803      EXTERNAL DAXPY,DSCAL
17804
17805C...INTRINSIC FUNCTIONS
17806      INTRINSIC MOD
17807
17808
17809C***FIRST EXECUTABLE STATEMENT  DPODI
17810
17811
17812      IF (JOB/10 .EQ. 0) GO TO 70
17813         DET(1) = 1.0D0
17814         DET(2) = 0.0D0
17815         S = 10.0D0
17816         DO 50 I = 1, N
17817            DET(1) = A(I,I)**2*DET(1)
17818C        ...EXIT
17819            IF (DET(1) .EQ. 0.0D0) GO TO 60
17820   10       IF (DET(1) .GE. 1.0D0) GO TO 20
17821               DET(1) = S*DET(1)
17822               DET(2) = DET(2) - 1.0D0
17823            GO TO 10
17824   20       CONTINUE
17825   30       IF (DET(1) .LT. S) GO TO 40
17826               DET(1) = DET(1)/S
17827               DET(2) = DET(2) + 1.0D0
17828            GO TO 30
17829   40       CONTINUE
17830   50    CONTINUE
17831   60    CONTINUE
17832   70 CONTINUE
17833
17834C     COMPUTE INVERSE(R)
17835
17836      IF (MOD(JOB,10) .EQ. 0) GO TO 140
17837         DO 100 K = 1, N
17838            A(K,K) = 1.0D0/A(K,K)
17839            T = -A(K,K)
17840            CALL DSCAL(K-1,T,A(1,K),1)
17841            KP1 = K + 1
17842            IF (N .LT. KP1) GO TO 90
17843            DO 80 J = KP1, N
17844               T = A(K,J)
17845               A(K,J) = 0.0D0
17846               CALL DAXPY(K,T,A(1,K),1,A(1,J),1)
17847   80       CONTINUE
17848   90       CONTINUE
17849  100    CONTINUE
17850
17851C        FORM  INVERSE(R) * TRANS(INVERSE(R))
17852
17853         DO 130 J = 1, N
17854            JM1 = J - 1
17855            IF (JM1 .LT. 1) GO TO 120
17856            DO 110 K = 1, JM1
17857               T = A(K,J)
17858               CALL DAXPY(K,T,A(1,J),1,A(1,K),1)
17859  110       CONTINUE
17860  120       CONTINUE
17861            T = A(J,J)
17862            CALL DSCAL(J,T,A(1,J),1)
17863  130    CONTINUE
17864  140 CONTINUE
17865      RETURN
17866      END
17867      SUBROUTINE DPODRA(XTEMP1,XTEMP2,MAXNXT,
17868     1                  ICASAN,ICAPSW,IFORSW,
17869     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
17870C
17871C     PURPOSE--COMPUTE LOG ODDS RATIO TEST.
17872C     EXAMPLE--ODDS RATIO INDEPENDENCE TEST Y1 Y2
17873C            --ODDS RATIO INDEPENDENCE TEST N11 N21 N12 N22
17874C            --ODDS RATIO INDEPENDENCE TEST M
17875C     REFERENCE--ANDREW RUKHIN, PRIVATE COMMUNICATION
17876C     WRITTEN BY--ALAN HECKERT
17877C                 STATISTICAL ENGINEERING DIVISION
17878C                 INFORMATION TECHNOLOGY LABORATORY
17879C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
17880C                 GAITHERSBURG, MD 20899-8980
17881C                 PHONE--301-975-2899
17882C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
17883C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
17884C     LANGUAGE--ANSI FORTRAN (1977)
17885C     VERSION NUMBER--2007/2
17886C     ORIGINAL VERSION--FEBRUARY  2007.
17887C     UPDATED         --JANUARY   2011. USE DPPARS, DPPAR3, DPPAR6
17888C     UPDATED         --JULY      2019. TWEAK TO SCRATCH STORAGE
17889C
17890C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
17891C
17892      CHARACTER*4 ICASAN
17893      CHARACTER*4 ICAPSW
17894      CHARACTER*4 IFORSW
17895C
17896      CHARACTER*4 IBUGA2
17897      CHARACTER*4 IBUGA3
17898      CHARACTER*4 IBUGQ
17899      CHARACTER*4 ISUBRO
17900      CHARACTER*4 IFOUND
17901      CHARACTER*4 IERROR
17902C
17903      CHARACTER*4 ICASEQ
17904      CHARACTER*4 ISUBN1
17905      CHARACTER*4 ISUBN2
17906      CHARACTER*4 ISTEPN
17907      CHARACTER*4 IH
17908      CHARACTER*4 IH2
17909      CHARACTER*4 IHOST1
17910      CHARACTER*4 ISUBN0
17911      CHARACTER*4 ICASE
17912C
17913      CHARACTER*40 INAME
17914C
17915      PARAMETER (MAXSPN=20)
17916      CHARACTER*4 IVARN1(MAXSPN)
17917      CHARACTER*4 IVARN2(MAXSPN)
17918      CHARACTER*4 IVARTY(MAXSPN)
17919      REAL PVAR(MAXSPN)
17920      INTEGER ILIS(MAXSPN)
17921      INTEGER NRIGHT(MAXSPN)
17922      INTEGER ICOLR(MAXSPN)
17923C
17924C---------------------------------------------------------------------
17925C
17926      DIMENSION XTEMP1(*)
17927      DIMENSION XTEMP2(*)
17928C
17929C-----COMMON----------------------------------------------------------
17930C
17931      PARAMETER (MAXLEV=1000)
17932C
17933      INCLUDE 'DPCOPA.INC'
17934      INCLUDE 'DPCOZZ.INC'
17935C
17936      REAL TEMP1(MAXOBV)
17937      REAL TEMP2(MAXOBV)
17938      REAL TEMP3(MAXOBV)
17939      REAL XIDTEM(MAXOBV)
17940      REAL XIDTE2(MAXOBV)
17941      REAL XMAT(MAXLEV,MAXLEV)
17942C
17943      EQUIVALENCE (GARBAG(IGARB1),TEMP1(1))
17944      EQUIVALENCE (GARBAG(IGARB2),TEMP2(1))
17945      EQUIVALENCE (GARBAG(IGARB3),TEMP3(1))
17946      EQUIVALENCE (GARBAG(IGARB4),XIDTEM(1))
17947      EQUIVALENCE (GARBAG(IGARB5),XIDTE2(1))
17948      EQUIVALENCE (GARBAG(IGARB6),XMAT(1,1))
17949C
17950C-----COMMON VARIABLES (GENERAL)--------------------------------------
17951C
17952      INCLUDE 'DPCOHK.INC'
17953      INCLUDE 'DPCOSU.INC'
17954      INCLUDE 'DPCOST.INC'
17955      INCLUDE 'DPCODA.INC'
17956      INCLUDE 'DPCOP2.INC'
17957C
17958C-----START POINT-----------------------------------------------------
17959C
17960      ISUBN1='DPOD'
17961      ISUBN2='RA  '
17962      IFOUND='NO'
17963      IERROR='NO'
17964      ICASE='PARA'
17965      IFOUND='YES'
17966      ICASEQ='UNKN'
17967C
17968      MAXCP1=MAXCOL+1
17969      MAXCP2=MAXCOL+2
17970      MAXCP3=MAXCOL+3
17971      MAXCP4=MAXCOL+4
17972      MAXCP5=MAXCOL+5
17973      MAXCP6=MAXCOL+6
17974C
17975      MINN2=2
17976      N11=(-999)
17977      N21=(-999)
17978      N12=(-999)
17979      N22=(-999)
17980      AN11=0.0
17981      AN21=0.0
17982      AN12=0.0
17983      AN22=0.0
17984C
17985      NS1=(-999)
17986      NS2=(-999)
17987      NS3=(-999)
17988      NS4=(-999)
17989C
17990      DO11I=1,MAXNXT
17991        XTEMP1(I)=0.0
17992        XTEMP2(I)=0.0
17993   11 CONTINUE
17994C
17995C               ***************************************************
17996C               **  TREAT THE ODDS RATIO INDEPENDENCE TEST CASE  **
17997C               ***************************************************
17998C
17999      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ODRA')THEN
18000        WRITE(ICOUT,999)
18001  999   FORMAT(1X)
18002        CALL DPWRST('XXX','BUG ')
18003        WRITE(ICOUT,51)
18004   51   FORMAT('***** AT THE BEGINNING OF DPODRA--')
18005        CALL DPWRST('XXX','BUG ')
18006        WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ,ICASAN
18007   52   FORMAT('IBUGA2,IBUGA3,IBUGQ,ICASAN = ',3(A4,2X),A4)
18008        CALL DPWRST('XXX','BUG ')
18009        WRITE(ICOUT,55)MAXNXT,NUMARG
18010   55   FORMAT('MAXNXT,NUMARG = ',2I8)
18011        CALL DPWRST('XXX','BUG ')
18012        DO59I=1,NUMARG
18013          WRITE(ICOUT,57)I,IHARG(I),IHARG2(I),ARG(I)
18014   57     FORMAT('I,IHARG(I),IHARG2(I),ARG(I) = ',I5,A4,A4,G15.7)
18015   59   CONTINUE
18016      ENDIF
18017C
18018C               *********************************
18019C               **  STEP 4--                   **
18020C               **  EXTRACT THE VARIABLE LIST  **
18021C               *********************************
18022C
18023      ISTEPN='4'
18024      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ODRA')
18025     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18026C
18027      INAME='ODDS RATIO INDEPENDENCE TEST'
18028      MINNA=1
18029      MAXNA=100
18030      MINN2=2
18031      IFLAGE=0
18032      IFLAGM=9
18033      IFLAGP=9
18034      JMIN=1
18035      JMAX=NUMARG
18036      MINNVA=1
18037      MAXNVA=4
18038C
18039      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
18040     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
18041     1            JMIN,JMAX,
18042     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
18043     1            IVARN1,IVARN2,IVARTY,PVAR,
18044     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
18045     1            MINNVA,MAXNVA,
18046     1            IFLAGM,IFLAGP,
18047     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
18048      IF(IERROR.EQ.'YES')GOTO9000
18049C
18050      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ODRA')THEN
18051        WRITE(ICOUT,999)
18052        CALL DPWRST('XXX','BUG ')
18053        WRITE(ICOUT,281)
18054  281   FORMAT('***** AFTER CALL DPPARS--')
18055        CALL DPWRST('XXX','BUG ')
18056        WRITE(ICOUT,282)NQ,NUMVAR
18057  282   FORMAT('NQ,NUMVAR = ',2I8)
18058        CALL DPWRST('XXX','BUG ')
18059        IF(NUMVAR.GT.0)THEN
18060          DO285I=1,NUMVAR
18061            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
18062     1                      ICOLR(I),PVAR(I)
18063  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
18064     1             'ICOLR(I),PVAR(I) = ',I8,2X,A4,A4,2X,3I8,G15.7)
18065            CALL DPWRST('XXX','BUG ')
18066  285     CONTINUE
18067        ENDIF
18068      ENDIF
18069C
18070C               ***********************************
18071C               **  STEP 22--                    **
18072C               **  CHECK FOR PROPER VALUES FOR  **
18073C               **  INPUT PARAMETERS             **
18074C               ***********************************
18075C
18076      IF(IVARTY(1).EQ.'PARA' .OR. IVARTY(1).EQ.'NUMB')THEN
18077        N11=INT(PVAR(1)+0.5)
18078        N21=INT(PVAR(2)+0.5)
18079        N12=INT(PVAR(3)+0.5)
18080        N22=INT(PVAR(4)+0.5)
18081        AN11=REAL(N11)
18082        AN21=REAL(N21)
18083        AN12=REAL(N12)
18084        AN22=REAL(N22)
18085        ICASE='PARA'
18086C
18087        ISTEPN='22'
18088        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ODRA')
18089     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18090C
18091        IF(N11.LT.0)THEN
18092          WRITE(ICOUT,999)
18093          CALL DPWRST('XXX','BUG ')
18094          WRITE(ICOUT,2201)
18095 2201     FORMAT('***** ERROR FROM ODDS RATIO INDEPENDENCE TEST--')
18096          CALL DPWRST('XXX','BUG ')
18097          WRITE(ICOUT,2203)
18098 2203     FORMAT('      THE VALUE OF THE FIRST PARAMETER (N11 = THE ',
18099     1           'NUMBER OF SUCCESSES')
18100          CALL DPWRST('XXX','BUG ')
18101          WRITE(ICOUT,2204)
18102 2204     FORMAT('      FOR THE FIRST VARIABLE MUST BE NON-NEGATIVE.')
18103          CALL DPWRST('XXX','BUG ')
18104          WRITE(ICOUT,2205)N11
18105 2205     FORMAT('      N11 = ',I8)
18106          CALL DPWRST('XXX','BUG ')
18107          IERROR='YES'
18108          GOTO9000
18109C
18110        ELSEIF(N21.LT.0)THEN
18111          WRITE(ICOUT,999)
18112          CALL DPWRST('XXX','BUG ')
18113          WRITE(ICOUT,2201)
18114          CALL DPWRST('XXX','BUG ')
18115          WRITE(ICOUT,2303)
18116 2303     FORMAT('      THE VALUE OF THE SECOND PARAMETER (N21 = THE ',
18117     1           'NUMBER OF FAILURES')
18118          CALL DPWRST('XXX','BUG ')
18119          WRITE(ICOUT,2304)
18120 2304     FORMAT('      FOR THE FIRST VARIABLE MUST BE NON-NEGATIVE.')
18121          CALL DPWRST('XXX','BUG ')
18122          WRITE(ICOUT,2305)N21
18123 2305     FORMAT('      N21 = ',I8)
18124          CALL DPWRST('XXX','BUG ')
18125          IERROR='YES'
18126          GOTO9000
18127C
18128        ELSEIF(N12.LT.0)THEN
18129          WRITE(ICOUT,999)
18130          CALL DPWRST('XXX','BUG ')
18131          WRITE(ICOUT,2201)
18132          CALL DPWRST('XXX','BUG ')
18133          WRITE(ICOUT,2403)
18134 2403     FORMAT('      THE VALUE OF THE THIRD PARAMETER (N12 = THE ',
18135     1           'NUMBER OF SUCCESSES')
18136          CALL DPWRST('XXX','BUG ')
18137          WRITE(ICOUT,2404)
18138 2404     FORMAT('      FOR THE SECOND VARIABLE MUST BE NON-NEGATIVE.')
18139          CALL DPWRST('XXX','BUG ')
18140          WRITE(ICOUT,2405)N12
18141 2405     FORMAT('      N12 = ',I8)
18142          CALL DPWRST('XXX','BUG ')
18143          IERROR='YES'
18144          GOTO9000
18145C
18146        ELSEIF(N22.LT.0)THEN
18147          WRITE(ICOUT,999)
18148          CALL DPWRST('XXX','BUG ')
18149          WRITE(ICOUT,2201)
18150          CALL DPWRST('XXX','BUG ')
18151          WRITE(ICOUT,2503)
18152 2503     FORMAT('      THE VALUE OF THE FOURTH PARAMETER (N22 = THE ',
18153     1           'NUMBER OF FAILURES')
18154          CALL DPWRST('XXX','BUG ')
18155          WRITE(ICOUT,2504)
18156 2504     FORMAT('      FOR THE SECOND VARIABLE MUST BE NON-NEGATIVE.')
18157          CALL DPWRST('XXX','BUG ')
18158          WRITE(ICOUT,2505)N22
18159 2505     FORMAT('      N22 = ',I8)
18160          CALL DPWRST('XXX','BUG ')
18161          IERROR='YES'
18162          GOTO9000
18163        ENDIF
18164C
18165      ELSEIF(IVARTY(1).EQ.'VARI')THEN
18166C
18167        ICASE='VARI'
18168        ICOL=1
18169        IF(NUMVAR.GT.2)THEN
18170          WRITE(ICOUT,999)
18171          CALL DPWRST('XXX','BUG ')
18172          WRITE(ICOUT,2201)
18173          CALL DPWRST('XXX','BUG ')
18174          WRITE(ICOUT,2603)
18175 2603     FORMAT('      MORE THAN TWO VARIABLES GIVEN.')
18176          CALL DPWRST('XXX','BUG ')
18177          WRITE(ICOUT,2605)NUMVAR
18178 2605     FORMAT('      THE NUMBER OF VARIABLES GIVEN  = ',I5)
18179          CALL DPWRST('XXX','BUG ')
18180          IERROR='YES'
18181          GOTO9000
18182        ENDIF
18183        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
18184     1              INAME,IVARN1,IVARN2,IVARTY,
18185     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
18186     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
18187     1              MAXCP4,MAXCP5,MAXCP6,
18188     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
18189     1              Y,X,X,NLOCAL,NLOCA2,NLOCA3,ICASE,
18190     1              IBUGA3,ISUBRO,IFOUND,IERROR)
18191        IF(IERROR.EQ.'YES')GOTO9000
18192        NS1=NLOCAL
18193        NS2=NLOCA2
18194C
18195      ELSEIF(IVARTY(1).EQ.'MATR')THEN
18196        ICASE='MATR'
18197        ICOL=1
18198        NUMVAR=1
18199        CALL DPPAR6(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
18200     1              INAME,IVARN1,IVARN2,IVARTY,
18201     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
18202     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
18203     1              MAXCP4,MAXCP5,MAXCP6,
18204     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
18205     1              XMAT,MAXLEV,NROW,NCOL,ICASE,
18206     1              IBUGA3,ISUBRO,IFOUND,IERROR)
18207        ICASE='TABL'
18208        IF(IERROR.EQ.'YES')GOTO9000
18209      ENDIF
18210C
18211C               ***********************************
18212C               **  STEP 61--                    **
18213C               **  COMPUTE THE ODDS RATIO TEST  **
18214C               ***********************************
18215C
18216      ISTEPN='61'
18217      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ODRA')
18218     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18219C
18220      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'ODRA')THEN
18221        WRITE(ICOUT,999)
18222        CALL DPWRST('XXX','BUG ')
18223        WRITE(ICOUT,6111)
18224 6111   FORMAT('***** FROM DPODRA--READY TO COMPUTE TEST')
18225        CALL DPWRST('XXX','BUG ')
18226        WRITE(ICOUT,6112)AN11,AN21,AN12,AN22
18227 6112   FORMAT('AN11,AN21,AN12,AN22 = ',4G15.7)
18228        CALL DPWRST('XXX','BUG ')
18229      ENDIF
18230C
18231      CALL DPODR2(Y,NS1,X,NS2,
18232     1            AN11,AN21,AN12,AN22,
18233     1            XMAT,MAXLEV,NROW,NCOL,
18234     1            XIDTEM,XIDTE2,TEMP1,TEMP2,TEMP3,MAXOBV,
18235     1            ICASE,
18236     1            ICAPSW,ICAPTY,IFORSW,
18237     1            ODDRAT,ODDRSE,ODDRBC,ORBCSE,
18238     1            STATVA,STATV2,CDF,CDF2,
18239     1            ISUBRO,IBUGA3,IERROR)
18240C
18241C               ***************************************
18242C               **  STEP 62--                        **
18243C               **  UPDATE INTERNAL DATAPLOT TABLES  **
18244C               ***************************************
18245C
18246      ISTEPN='62'
18247      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ODRA')
18248     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18249C
18250      ISUBN0='ODRA'
18251C
18252      IH='STAT'
18253      IH2='VAL '
18254      VALUE0=STATVA
18255      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
18256     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
18257     1IANS,IWIDTH,IBUGA3,IERROR)
18258C
18259      IH='STAT'
18260      IH2='VALY'
18261      VALUE0=STATV2
18262      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
18263     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
18264     1IANS,IWIDTH,IBUGA3,IERROR)
18265C
18266      IH='STAT'
18267      IH2='CDF '
18268      VALUE0=CDF
18269      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
18270     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
18271     1IANS,IWIDTH,IBUGA3,IERROR)
18272C
18273      IH='STAT'
18274      IH2='CDFY'
18275      VALUE0=CDF2
18276      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
18277     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
18278     1IANS,IWIDTH,IBUGA3,IERROR)
18279C
18280      IH='ODDS'
18281      IH2='RATI'
18282      VALUE0=ODDRAT
18283      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
18284     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
18285     1IANS,IWIDTH,IBUGA3,IERROR)
18286C
18287      IH='ODDS'
18288      IH2='RASE'
18289      VALUE0=ODDRSE
18290      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
18291     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
18292     1IANS,IWIDTH,IBUGA3,IERROR)
18293C
18294      IH='ODDS'
18295      IH2='RABC'
18296      VALUE0=ODDRBC
18297      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
18298     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
18299     1IANS,IWIDTH,IBUGA3,IERROR)
18300C
18301      IH='ODDS'
18302      IH2='BCSE'
18303      VALUE0=ORBCSE
18304      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
18305     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
18306     1IANS,IWIDTH,IBUGA3,IERROR)
18307C
18308C               *****************
18309C               **  STEP 90--  **
18310C               **  EXIT       **
18311C               *****************
18312C
18313 9000 CONTINUE
18314      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ODRA')THEN
18315        WRITE(ICOUT,999)
18316        CALL DPWRST('XXX','BUG ')
18317        WRITE(ICOUT,9011)
18318 9011   FORMAT('***** AT THE END       OF DPODRA--')
18319        CALL DPWRST('XXX','BUG ')
18320        WRITE(ICOUT,9012)IBUGA2,IBUGA3
18321 9012   FORMAT('IBUGA2,IBUGA3 = ',A4,2X,A4)
18322        CALL DPWRST('XXX','BUG ')
18323        WRITE(ICOUT,9016)IERROR
18324 9016   FORMAT('IERROR = ',A4,2X,A4)
18325        CALL DPWRST('XXX','BUG ')
18326      ENDIF
18327C
18328      RETURN
18329      END
18330      SUBROUTINE DPODR2(Y1,N1,Y2,N2,
18331     1                  AN11,AN21,AN12,AN22,
18332     1                  XMAT,MAXLEV,NROW,NCOL,
18333     1                  XIDTEM,XIDTE2,TEMP1,TEMP2,TEMP3,MAXNXT,
18334     1                  ICASE,
18335     1                  ICAPSW,ICAPTY,IFORSW,
18336     1                  ODDRAT,ODDRSE,ODDRBC,ORBCSE,
18337     1                  STATVA,STATV2,CDF,CDF2,
18338     1                  ISUBRO,IBUGA3,IERROR)
18339C
18340C     PURPOSE--PERFORM A LOG-ODDS RATIO TEST FOR INDEPENDENCE.
18341C              THE INPUT CAN EITHER BE ENTERED AS TWO VARIABLES
18342C              CONTAINING 1's (FOR SUCCESS) AND 0's (FOR FAILURES)
18343C              OR AS FOUR PARAMETERS:
18344C                 N11 = NUMBER OF SUCCESSES FOR VARIABLE 1
18345C                 N21 = NUMBER OF FAILURES  FOR VARIABLE 1
18346C                 N12 = NUMBER OF SUCCESSES FOR VARIABLE 2
18347C                 N22 = NUMBER OF SUCCESSES FOR VARIABLE 2
18348C
18349C              WE THEN USE N1 = N11 + N21 AND N2 = N12 + N22
18350C              THE TEST STATISTIC IS:
18351C
18352C                 (N1 + N2)*(N11*N22 - N12*N21)**2/
18353C                 {N1*N2*(N11+N12)*(N21+N22)}
18354C
18355C              SOME ANALYSTS PREFER THE YATES VERSION OF THE
18356C              STATISTIC:
18357C
18358C                 (N1 + N2)*(|N11*N22 - N12*N21| - 0.5*(N1 + N2))**2/
18359C                 {N1*N2*(N11+N12)*(N21+N22)}
18360C
18361C              DATAPLOT WILL GENERATE THE TEST FOR BOTH CASES.
18362C
18363C     EXAMPLE--ODDS RATIO INDEPENDENCE TEST Y1 Y2
18364C              SAMPLE 1 IS IN INPUT VECTOR Y1 (WITH N1 OBSERVATIONS).
18365C              SAMPLE 2 IS IN INPUT VECTOR Y2 (WITH N2 OBSERVATIONS).
18366C            --ODDS RATIO INDEPENDENCE TEST N11 N21 N12 N22
18367C     WRITTEN BY--ALAN HECKERT
18368C                 STATISTICAL ENGINEERING DIVISION
18369C                 INFORMATION TECHNOLOGYU LABORATORY
18370C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
18371C                 GAITHERSBURG, MD 20899-8980
18372C                 PHONE--301-975-2899
18373C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
18374C           OF THE NATIONAL BUREAU OF STANDARDS.
18375C     LANGUAGE--ANSI FORTRAN (1977)
18376C     VERSION NUMBER--2007/2
18377C     ORIGINAL VERSION--FEBRUARY  2007.
18378C     UPDATED         --JANUARY   2011. USE DPAUFI TO OPEN/CLOSE
18379C                                       AUXILLARY FILES
18380C     UPDATED         --JANUARY   2011. USE DPDTA1, DPDT5B TO PRINT
18381C                                       TABLES
18382C     UPDATED         --APRIL     2019. USER CAN SPECIFY NUMBER OF
18383C                                       DECIMAL POINTS FOR AUXILLARY
18384C                                       FILES
18385C
18386C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
18387C
18388      CHARACTER*4 ISUBRO
18389      CHARACTER*4 IBUGA3
18390      CHARACTER*4 IERROR
18391      CHARACTER*4 ICASE
18392      CHARACTER*4 ICAPSW
18393      CHARACTER*4 ICAPTY
18394      CHARACTER*4 IFORSW
18395C
18396      CHARACTER*4 IWRITE
18397C
18398      CHARACTER*6 ICONC1
18399      CHARACTER*6 ICONC2
18400      CHARACTER*6 ICONC3
18401      CHARACTER*6 ICONC4
18402      CHARACTER*6 ICONC5
18403      CHARACTER*6 ICONC6
18404C
18405      CHARACTER*6 KCONC1
18406      CHARACTER*6 KCONC2
18407      CHARACTER*6 KCONC3
18408      CHARACTER*6 KCONC4
18409      CHARACTER*6 KCONC5
18410      CHARACTER*6 KCONC6
18411C
18412      CHARACTER*4 ISUBN1
18413      CHARACTER*4 ISUBN2
18414      CHARACTER*4 ISTEPN
18415C
18416      CHARACTER*4 IOP
18417      CHARACTER*20 IFORMT
18418C
18419C---------------------------------------------------------------------
18420C
18421      DIMENSION Y1(*)
18422      DIMENSION Y2(*)
18423      DIMENSION TEMP1(*)
18424      DIMENSION TEMP2(*)
18425      DIMENSION TEMP3(*)
18426      DIMENSION XIDTEM(*)
18427      DIMENSION XIDTE2(*)
18428C
18429      DIMENSION XMAT(MAXLEV,MAXLEV)
18430C
18431C
18432      PARAMETER (NUMALP=6)
18433      DIMENSION SIGVAL(NUMALP)
18434      DIMENSION ALOWCL(NUMALP)
18435      DIMENSION AUPPCL(NUMALP)
18436      DIMENSION ALOWC2(NUMALP)
18437      DIMENSION AUPPC2(NUMALP)
18438C
18439      PARAMETER(NUMCLI=5)
18440      PARAMETER(MAXLIN=4)
18441      PARAMETER (MAXROW=NUMALP)
18442      PARAMETER (MAXRO2=30)
18443      CHARACTER*60 ITITLE
18444      CHARACTER*60 ITITLZ
18445      CHARACTER*60 ITITL9
18446      CHARACTER*60 ITEXT(MAXRO2)
18447      CHARACTER*4  ALIGN(NUMCLI)
18448      CHARACTER*4  VALIGN(NUMCLI)
18449      REAL         AVALUE(MAXRO2)
18450      INTEGER      NCTEXT(MAXRO2)
18451      INTEGER      IDIGIT(MAXRO2)
18452      INTEGER      IDIGI2(MAXROW,NUMCLI)
18453      INTEGER      NTOT(MAXRO2)
18454      CHARACTER*60 ITITL2(MAXLIN,NUMCLI)
18455      CHARACTER*15 IVALUE(MAXROW,NUMCLI)
18456      CHARACTER*4  ITYPCO(NUMCLI)
18457      INTEGER      NCTIT2(MAXLIN,NUMCLI)
18458      INTEGER      NCVALU(MAXROW,NUMCLI)
18459      INTEGER      NCOLSP(MAXLIN,NUMCLI)
18460      INTEGER      ROWSEP(MAXROW)
18461      INTEGER      IWHTML(NUMCLI)
18462      INTEGER      IWRTF(NUMCLI)
18463      REAL         AMAT(MAXROW,NUMCLI)
18464      LOGICAL IFRST
18465      LOGICAL ILAST
18466      LOGICAL IFLAGS
18467      LOGICAL IFLAGE
18468C
18469C-----COMMON----------------------------------------------------------
18470C
18471      INCLUDE 'DPCOST.INC'
18472      INCLUDE 'DPCOP2.INC'
18473C
18474      DATA SIGVAL /0.50, 0.80, 0.90, 0.95, 0.975, 0.99/
18475C
18476C-----START POINT-----------------------------------------------------
18477C
18478      ISUBN1='DPOD'
18479      IWRITE='NO'
18480      ISUBN2='R2  '
18481      IERROR='NO'
18482C
18483      DO11I=1,MAXNXT
18484        XIDTEM(I)=0.0
18485        XIDTE2(I)=0.0
18486        TEMP1(I)=0.0
18487        TEMP2(I)=0.0
18488        TEMP3(I)=0.0
18489   11 CONTINUE
18490C
18491      ICONC1='ACCEPT'
18492      ICONC2='ACCEPT'
18493      ICONC3='ACCEPT'
18494      ICONC4='ACCEPT'
18495      ICONC5='ACCEPT'
18496      ICONC6='ACCEPT'
18497C
18498      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ODR2')THEN
18499        WRITE(ICOUT,999)
18500  999   FORMAT(1X)
18501        CALL DPWRST('XXX','WRIT')
18502        WRITE(ICOUT,51)
18503   51   FORMAT('**** AT THE BEGINNING OF DPODR2--')
18504        CALL DPWRST('XXX','WRIT')
18505        WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASE,IBINCC,MAXNXT
18506   52   FORMAT('IBUGA3,ISUBRO,ICASE,IBINCC,MAXNXT = ',4(A4,2X),I8)
18507        CALL DPWRST('XXX','WRIT')
18508        IF(ICASE.EQ.'VARI')THEN
18509          WRITE(ICOUT,55)N1
18510   55     FORMAT('N1 = ',I8)
18511          CALL DPWRST('XXX','WRIT')
18512          DO56I=1,N1
18513            WRITE(ICOUT,57)I,Y1(I)
18514   57       FORMAT('I,Y1(I) = ',I8,G15.7)
18515            CALL DPWRST('XXX','WRIT')
18516   56     CONTINUE
18517          WRITE(ICOUT,65)N2
18518   65     FORMAT('N2 = ',I8)
18519          CALL DPWRST('XXX','WRIT')
18520          DO66I=1,N2
18521            WRITE(ICOUT,67)I,Y2(I)
18522   67       FORMAT('I,Y2(I) = ',I8,E15.7)
18523            CALL DPWRST('XXX','WRIT')
18524   66     CONTINUE
18525        ELSE
18526          WRITE(ICOUT,75)AN11,AN21,AN12,AN22
18527   75     FORMAT('AN11,AN21,AN12,AN22 = ',4G15.7)
18528          CALL DPWRST('XXX','WRIT')
18529        ENDIF
18530      ENDIF
18531C
18532C               ********************************************
18533C               **  STEP 0--                              **
18534C               **  BRANCH TO APPROPRIATE CASE (PARAMETER **
18535C               **  OR VARIABLE)                          **
18536C               ********************************************
18537C
18538      ISTEPN='00'
18539      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'ODR2')
18540     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18541C
18542      IF(ICASE.EQ.'PARA')GOTO1000
18543      IF(ICASE.EQ.'VARI')GOTO2000
18544      IF(ICASE.EQ.'TABL')GOTO3000
18545C
18546C               ********************************************
18547C               **  STEP 11--                             **
18548C               **  PARAMETER CASE                        **
18549C               ********************************************
18550C
18551 1000 CONTINUE
18552C
18553      ISTEPN='11'
18554      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'ODR2')
18555     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18556C
18557C               ********************************************
18558C               **  STEP 12--                             **
18559C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
18560C               ********************************************
18561C
18562      N11=INT(AN11+0.5)
18563      N21=INT(AN21+0.5)
18564      N12=INT(AN12+0.5)
18565      N22=INT(AN22+0.5)
18566C
18567      ISTEPN='12'
18568      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'ODR2')
18569     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18570C
18571      IF(N11.LT.0)THEN
18572        WRITE(ICOUT,999)
18573        CALL DPWRST('XXX','BUG ')
18574        WRITE(ICOUT,1201)
18575 1201   FORMAT('***** ERROR FROM THE ODDS RATIO INDEPENDENCE TEST--')
18576        CALL DPWRST('XXX','BUG ')
18577        WRITE(ICOUT,1203)
18578 1203   FORMAT('      THE VALUE OF THE FIRST PARAMETER (N11 = THE ',
18579     1         'NUMBER OF SUCCESSES')
18580        CALL DPWRST('XXX','BUG ')
18581        WRITE(ICOUT,1204)
18582 1204   FORMAT('      FOR THE FIRST VARIABLE MUST BE NON-NEGATIVE.')
18583        CALL DPWRST('XXX','BUG ')
18584        WRITE(ICOUT,1205)N11
18585 1205   FORMAT('      N11 = ',I8)
18586        CALL DPWRST('XXX','BUG ')
18587        IERROR='YES'
18588        GOTO9000
18589      ENDIF
18590C
18591      IF(N21.LT.0)THEN
18592        WRITE(ICOUT,999)
18593        CALL DPWRST('XXX','BUG ')
18594        WRITE(ICOUT,1201)
18595        CALL DPWRST('XXX','BUG ')
18596        WRITE(ICOUT,1303)
18597 1303   FORMAT('      THE VALUE OF THE SECOND PARAMETER (N21 = THE ',
18598     1         'NUMBER OF FAILURES')
18599        CALL DPWRST('XXX','BUG ')
18600        WRITE(ICOUT,1304)
18601 1304   FORMAT('      FOR THE FIRST VARIABLE MUST BE NON-NEGATIVE.')
18602        CALL DPWRST('XXX','BUG ')
18603        WRITE(ICOUT,1305)N21
18604 1305   FORMAT('      N21 = ',I8)
18605        CALL DPWRST('XXX','BUG ')
18606        IERROR='YES'
18607        GOTO9000
18608      ENDIF
18609C
18610      IF(N12.LT.0)THEN
18611        WRITE(ICOUT,999)
18612        CALL DPWRST('XXX','BUG ')
18613        WRITE(ICOUT,1201)
18614        CALL DPWRST('XXX','BUG ')
18615        WRITE(ICOUT,1403)
18616 1403   FORMAT('      THE VALUE OF THE THIRD PARAMETER (N12 = THE ',
18617     1         'NUMBER OF SUCCESSES')
18618        CALL DPWRST('XXX','BUG ')
18619        WRITE(ICOUT,1404)
18620 1404   FORMAT('      FOR THE SECOND VARIABLE MUST BE NON-NEGATIVE.')
18621        CALL DPWRST('XXX','BUG ')
18622        WRITE(ICOUT,1405)N12
18623 1405   FORMAT('      N12 = ',I8)
18624        CALL DPWRST('XXX','BUG ')
18625        IERROR='YES'
18626        GOTO9000
18627      ENDIF
18628C
18629      IF(N22.LT.0)THEN
18630        WRITE(ICOUT,999)
18631        CALL DPWRST('XXX','BUG ')
18632        WRITE(ICOUT,1201)
18633        CALL DPWRST('XXX','BUG ')
18634        WRITE(ICOUT,1503)
18635 1503   FORMAT('      THE VALUE OF THE FOURTH PARAMETER (N22 = THE ',
18636     1         'NUMBER OF FAILURES')
18637        CALL DPWRST('XXX','BUG ')
18638        WRITE(ICOUT,1504)
18639 1504   FORMAT('      FOR THE SECOND VARIABLE MUST BE NON-NEGATIVE.')
18640        CALL DPWRST('XXX','BUG ')
18641        WRITE(ICOUT,1505)N22
18642 1505   FORMAT('      N22 = ',I8)
18643        CALL DPWRST('XXX','BUG ')
18644        IERROR='YES'
18645        GOTO9000
18646      ENDIF
18647C
18648C               ********************************************
18649C               **  STEP 12--                             **
18650C               **  COMPUTE THE LOG ODDS RATIO TEST       **
18651C               ********************************************
18652C
18653C
18654      GOTO4000
18655C
18656C               ********************************************
18657C               **  STEP 20--                             **
18658C               **  VARIABLE  CASE                        **
18659C               ********************************************
18660C
18661 2000 CONTINUE
18662C
18663C               ********************************************
18664C               **  STEP 21--                             **
18665C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
18666C               ********************************************
18667C
18668      ISTEPN='21'
18669      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'ODR2')
18670     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18671C
18672      IF(N1.LT.2)THEN
18673        WRITE(ICOUT,999)
18674        CALL DPWRST('XXX','WRIT')
18675        WRITE(ICOUT,1201)
18676        CALL DPWRST('XXX','WRIT')
18677        WRITE(ICOUT,2101)
18678 2101   FORMAT('      THE NUMBER OF OBSERVATIONS FOR VARIABLE 1 ',
18679     1         'IS NON-POSITIVE')
18680        CALL DPWRST('XXX','WRIT')
18681        WRITE(ICOUT,2103)N1
18682 2103   FORMAT('SAMPLE SIZE = ',I8)
18683        CALL DPWRST('XXX','WRIT')
18684        IERROR='YES'
18685        GOTO9000
18686      ENDIF
18687C
18688      IF(N2.LT.2)THEN
18689        WRITE(ICOUT,999)
18690        CALL DPWRST('XXX','WRIT')
18691        WRITE(ICOUT,1201)
18692        CALL DPWRST('XXX','WRIT')
18693        WRITE(ICOUT,2106)
18694 2106   FORMAT('      THE NUMBER OF OBSERVATIONS FOR VARIABLE 2 ',
18695     1         'IS NON-POSITIVE')
18696        CALL DPWRST('XXX','WRIT')
18697        WRITE(ICOUT,2103)N2
18698        CALL DPWRST('XXX','WRIT')
18699        IERROR='YES'
18700        GOTO9000
18701      ENDIF
18702C
18703C               ********************************************
18704C               **  STEP 22--                             **
18705C               **  CHECK THAT THE VARIABLES HAVE AT MOST **
18706C               **  TWO DISTINCT VALUES (1 INDICATES A    **
18707C               **  SUCCESS, 0 INDICATES A FAILURE).      **
18708C               ********************************************
18709C
18710      ISTEPN='22'
18711      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'ODR2')
18712     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18713C
18714      CALL DISTIN(Y1,N1,IWRITE,XIDTEM,NDIST,IBUGA3,IERROR)
18715      IF(NDIST.EQ.1)THEN
18716        AVAL=XIDTEM(1)
18717        IF(ABS(AVAL).LE.0.5)THEN
18718          AVAL=0.0
18719        ELSE
18720          AVAL=1.0
18721        ENDIF
18722        DO2202I=1,N1
18723          Y1(I)=1.0
18724 2202   CONTINUE
18725      ELSEIF(NDIST.EQ.2)THEN
18726        IF(XIDTEM(1).EQ.1.0 .OR. XIDTEM(2).EQ.1.0)THEN
18727          DO2203I=1,N1
18728            IF(Y1(I).NE.1.0)Y1(I)=0.0
18729 2203     CONTINUE
18730        ELSE
18731          ATEMP1=MIN(XIDTEM(1),XIDTEM(2))
18732          ATEMP2=MAX(XIDTEM(1),XIDTEM(2))
18733          DO2208I=1,N1
18734            IF(Y1(I).EQ.ATEMP1)Y1(I)=0.0
18735            IF(Y1(I).EQ.ATEMP2)Y1(I)=1.0
18736 2208     CONTINUE
18737        ENDIF
18738      ELSE
18739        WRITE(ICOUT,999)
18740        CALL DPWRST('XXX','BUG ')
18741        WRITE(ICOUT,1201)
18742        CALL DPWRST('XXX','BUG ')
18743        WRITE(ICOUT,2211)
18744 2211   FORMAT('      RESPONSE VARIABLE ONE SHOULD CONTAIN AT MOST')
18745        CALL DPWRST('XXX','BUG ')
18746        WRITE(ICOUT,2213)
18747 2213   FORMAT('      TWO DISTINCT VALUES.')
18748        CALL DPWRST('XXX','BUG ')
18749        WRITE(ICOUT,2215)NDIST
18750 2215   FORMAT('      ',I8,' DISTINCT VALUES FOUND.')
18751        CALL DPWRST('XXX','BUG ')
18752        IERROR='YES'
18753        GOTO9000
18754      ENDIF
18755C
18756      CALL DISTIN(Y2,N2,IWRITE,XIDTEM,NDIST,IBUGA3,IERROR)
18757      IF(NDIST.EQ.1)THEN
18758        AVAL=XIDTEM(1)
18759        IF(ABS(AVAL).LE.0.5)THEN
18760          AVAL=0.0
18761        ELSE
18762          AVAL=1.0
18763        ENDIF
18764        DO2302I=1,N2
18765          Y2(I)=1.0
18766 2302   CONTINUE
18767      ELSEIF(NDIST.EQ.2)THEN
18768        IF(XIDTEM(1).EQ.1.0 .OR. XIDTEM(2).EQ.1.0)THEN
18769          DO2303I=1,N2
18770            IF(Y2(I).NE.1.0)Y2(I)=0.0
18771 2303     CONTINUE
18772        ELSE
18773          ATEMP1=MIN(XIDTEM(1),XIDTEM(2))
18774          ATEMP2=MAX(XIDTEM(1),XIDTEM(2))
18775          DO2308I=1,N2
18776            IF(Y2(I).EQ.ATEMP1)Y2(I)=0.0
18777            IF(Y2(I).EQ.ATEMP2)Y2(I)=1.0
18778 2308     CONTINUE
18779        ENDIF
18780      ELSE
18781        WRITE(ICOUT,999)
18782        CALL DPWRST('XXX','BUG ')
18783        WRITE(ICOUT,1201)
18784        CALL DPWRST('XXX','BUG ')
18785        WRITE(ICOUT,2311)
18786 2311   FORMAT('      RESPONSE VARIABLE TWO SHOULD CONTAIN AT MOST')
18787        CALL DPWRST('XXX','BUG ')
18788        WRITE(ICOUT,2313)
18789 2313   FORMAT('      TWO DISTINCT VALUES.')
18790        CALL DPWRST('XXX','BUG ')
18791        WRITE(ICOUT,2315)NDIST
18792 2315   FORMAT('      ',I8,' DISTINCT VALUES FOUND.')
18793        CALL DPWRST('XXX','BUG ')
18794        IERROR='YES'
18795        GOTO9000
18796      ENDIF
18797C
18798      N11=0
18799      N12=0
18800      N21=0
18801      N22=0
18802      CALL SUMDP(Y1,N1,IWRITE,XSUM,IBUGA3,IERROR)
18803      N11=INT(XSUM+0.5)
18804      N21=N1 - N11
18805      CALL SUMDP(Y2,N2,IWRITE,XSUM,IBUGA3,IERROR)
18806      N12=INT(XSUM+0.5)
18807      N22=N2 - N12
18808C
18809      AN11=REAL(N11)
18810      AN22=REAL(N22)
18811      AN12=REAL(N12)
18812      AN21=REAL(N21)
18813C
18814      GOTO4000
18815C
18816 3000 CONTINUE
18817C
18818C               ********************************************
18819C               **  STEP 31--                             **
18820C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
18821C               **  ALL TABLE ENTRIES SHOULD BE           **
18822C               **  NON-NEGATIVE INTEGERS.  NEGATIVE      **
18823C               **  VALUES WILL BE FLAGGED AS ERRORS      **
18824C               **  WHILE NON-INTEGER VALUES WILL BE      **
18825C               **  ROUNDED TO NEAREST INTEGER.           **
18826C               **  SINCE WE ARE SCANNING TABLE, COMPUTE  **
18827C               **  ROW AND COLUMN TOTALS.                **
18828C               **  NOTE THAT FOR THIS COMMAND IS         **
18829C               **  COMPUTED ON A 2X2 CONTINGENCY TABLE.  **
18830C               **  THEREFORE:                            **
18831C               **  1) IF NUMBER OF COLUMNS NOT EQUAL     **
18832C               **     TWO, FLAG AN ERROR.                **
18833C               **  2) IF NUMBER OF ROWS EQUAL TWO, THEN  **
18834C               **     EXTRACT THE RELEVANT 4 VALUES AND  **
18835C               **     GO TO THE PARAMETER CASE.          **
18836C               **  3) IF NUMBER OF ROWS GREATER THAN     **
18837C               **     TWO, THEN NEED TO CROSS-TABULATE   **
18838C               **     (I.E., HAVE THE VARIABLE CASE).    **
18839C               ********************************************
18840C
18841      ISTEPN='31'
18842      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'ODR2')
18843     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18844C
18845      IERROR='NO'
18846C
18847      IF(NCOL.NE.2)THEN
18848        WRITE(ICOUT,999)
18849        CALL DPWRST('XXX','WRIT')
18850        WRITE(ICOUT,1201)
18851        CALL DPWRST('XXX','WRIT')
18852        WRITE(ICOUT,3101)
18853 3101   FORMAT('      THE NUMBER OF COLUMNS IN THE INPUT MATRIX')
18854        CALL DPWRST('XXX','WRIT')
18855        WRITE(ICOUT,3103)
18856 3103   FORMAT('      MUST BE EXACTLY TWO; SUCH WAS NOT THE CASE ',
18857     1         'HERE.')
18858        CALL DPWRST('XXX','WRIT')
18859        WRITE(ICOUT,3105)NCOL
18860 3105   FORMAT('      THE NUMBER OF COLUMNS = ',I8)
18861        CALL DPWRST('XXX','WRIT')
18862        IERROR='YES'
18863        GOTO9000
18864      ENDIF
18865C
18866      IF(NROW.EQ.2)THEN
18867        AN11=XMAT(1,1)
18868        AN21=XMAT(2,1)
18869        AN12=XMAT(1,2)
18870        AN22=XMAT(2,2)
18871        GOTO1000
18872      ELSE
18873        DO3120I=1,NROW
18874          Y1(NROW)=XMAT(I,1)
18875          Y2(NROW)=XMAT(I,2)
18876 3120   CONTINUE
18877        N1=NROW
18878        N2=NROW
18879        GOTO2000
18880      ENDIF
18881C
18882 4000 CONTINUE
18883C
18884      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'ODR2')
18885     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18886C
18887C     COMPUTE THE LOG OF THE ODDS RATIO AND ITS STANDARD
18888C     ERROR.  FLEISS PROVIDES A MODIFIED VERSION THAT REDUCES
18889C     THE BIAS.  COMPUTE BOTH THE UNCORRECTED AND THE BIASED
18890C     REDUCED FORM AND THE CORRESPONDING STANDARD ERRORS.
18891C
18892C     IF ANY OF N11, N21, N12, OR N22 IS ZERO, THEN ONLY
18893C     THE BIAS REDUCED FORM IS GENERATED.
18894C
18895      AN1=AN11+AN21
18896      AN2=AN12+AN22
18897      AN=AN1 + AN2
18898C
18899      P11=AN11/AN1
18900      P21=AN21/AN1
18901      P12=AN12/AN2
18902      P22=AN22/AN2
18903C
18904      IF(P11.GT.0.0 .AND. P21.GT.0.0 .AND.
18905     1   P12.GT.0.0 .AND. P22.GT.0.0)THEN
18906        ODDRAT=LOG(P11*P22/(P12*P21))
18907        ODDRSE=SQRT((1.0/AN11) + (1.0/AN21) + (1.0/AN12) + (1.0/AN22))
18908      ELSE
18909        ODDRAT=CPUMIN
18910        ODDRSE=CPUMIN
18911      ENDIF
18912      ODDRBC=LOG((AN11+0.5)*(AN22+0.5)/((AN12+0.5)*(AN21+0.5)))
18913      ORBCSE=SQRT((1.0/(AN11+0.5)) + (1.0/(AN21+0.5)) +
18914     1            (1.0/(AN12+0.5)) + (1.0/(AN22+0.5)))
18915C
18916      ANUM=AN*(AN11*AN22 - AN12*AN21)**2
18917      ADENOM=AN1*AN2*(AN11+AN12)*(AN21+AN22)
18918      IF(ADENOM.NE.0.0)THEN
18919        STATVA=ANUM/ADENOM
18920        ANUM=AN*(ABS(AN11*AN22 - AN12*AN21) - 0.5*AN)**2
18921        STATV2=ANUM/ADENOM
18922      ELSE
18923        STATVA=-99.0
18924        STATV2=-99.0
18925        CDF=1.0
18926        CDF2=1.0
18927      ENDIF
18928C
18929      IWRITE='OFF'
18930C
18931      CALL NORCDF(STATVA,CDF)
18932      CALL NORCDF(STATV2,CDF2)
18933C
18934      ICONC1='REJECT'
18935      ICONC2='REJECT'
18936      ICONC3='REJECT'
18937      ICONC4='REJECT'
18938      ICONC5='REJECT'
18939      ICONC6='REJECT'
18940      KCONC1='REJECT'
18941      KCONC2='REJECT'
18942      KCONC3='REJECT'
18943      KCONC4='REJECT'
18944      KCONC5='REJECT'
18945      KCONC6='REJECT'
18946      ALPHA=0.50
18947      CALL NORPPF(ALPHA,CV1)
18948      ALPHA=0.80
18949      CALL NORPPF(ALPHA,CV2)
18950      ALPHA=0.90
18951      CALL NORPPF(ALPHA,CV3)
18952      ALPHA=0.95
18953      CALL NORPPF(ALPHA,CV4)
18954      ALPHA=0.975
18955      CALL NORPPF(ALPHA,CV5)
18956      ALPHA=0.99
18957      CALL NORPPF(ALPHA,CV6)
18958C
18959      IF(0.000.LE.CDF.AND.CDF.LE.0.50)ICONC1='ACCEPT'
18960      IF(0.000.LE.CDF.AND.CDF.LE.0.80)ICONC2='ACCEPT'
18961      IF(0.000.LE.CDF.AND.CDF.LE.0.90)ICONC3='ACCEPT'
18962      IF(0.000.LE.CDF.AND.CDF.LE.0.95)ICONC4='ACCEPT'
18963      IF(0.000.LE.CDF.AND.CDF.LE.0.975)ICONC5='ACCEPT'
18964      IF(0.000.LE.CDF.AND.CDF.LE.0.99)ICONC6='ACCEPT'
18965C
18966      IF(0.000.LE.CDF2.AND.CDF2.LE.0.50)KCONC1='ACCEPT'
18967      IF(0.000.LE.CDF2.AND.CDF2.LE.0.80)KCONC2='ACCEPT'
18968      IF(0.000.LE.CDF2.AND.CDF2.LE.0.90)KCONC3='ACCEPT'
18969      IF(0.000.LE.CDF2.AND.CDF2.LE.0.95)KCONC4='ACCEPT'
18970      IF(0.000.LE.CDF2.AND.CDF2.LE.0.975)KCONC5='ACCEPT'
18971      IF(0.000.LE.CDF2.AND.CDF2.LE.0.99)KCONC6='ACCEPT'
18972C
18973      IOP='OPEN'
18974      IFLAG1=1
18975      IFLAG2=0
18976      IFLAG3=0
18977      IFLAG4=0
18978      IFLAG5=0
18979      CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
18980     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
18981     1            IBUGA3,ISUBRO,IERROR)
18982      IF(IERROR.EQ.'YES')GOTO9000
18983C
18984      IFORMT='(F10.5,1X,4E15.7)'
18985      IF(IAUXDP.NE.7)THEN
18986        IFORMT=' '
18987        IF(IAUXDP.LE.9)THEN
18988          IFORMT='(F10.5,1X,4Exx.x)'
18989          ITOT=IAUXDP+8
18990          WRITE(IFORMT(13:14),'(I2)')ITOT
18991          WRITE(IFORMT(16:16),'(I1)')IAUXDP
18992        ELSE
18993          IFORMT='(F10.5,1X,4Exx.xx)'
18994          ITOT=IAUXDP+8
18995          WRITE(IFORMT(13:14),'(I2)')ITOT
18996          WRITE(IFORMT(16:17),'(I2)')IAUXDP
18997        ENDIF
18998      ENDIF
18999C
19000      DO4010I=1,NUMALP
19001        ALPHA=SIGVAL(I)
19002        CALL NORPPF(ALPHA,CV)
19003        IF(ODDRAT.NE.CPUMIN)THEN
19004          ALOWCL(I)=ODDRAT - CV*ODDRSE
19005          AUPPCL(I)=ODDRAT + CV*ODDRSE
19006        ELSE
19007          ALOWCL(I)=-99.0
19008          AUPPCL(I)=-99.0
19009        ENDIF
19010        ALOWC2(I)=ODDRBC - CV*ORBCSE
19011        AUPPC2(I)=ODDRBC + CV*ORBCSE
19012        WRITE(IOUNI1,IFORMT)ALPHA,ALOWCL(I),AUPPCL(I),
19013     1                    ALOWC2(I),AUPPC2(I)
19014C4011   FORMAT(F10.5,1X,4E15.7)
19015 4010 CONTINUE
19016C
19017      IOP='CLOS'
19018      CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
19019     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
19020     1            IBUGA3,ISUBRO,IERROR)
19021      IF(IERROR.EQ.'YES')GOTO9000
19022C
19023C
19024C               ******************************
19025C               **   STEP 42--              **
19026C               **   WRITE OUT EVERYTHING   **
19027C               **   FOR ODDS RATIO   TEST  **
19028C               ******************************
19029C
19030      ISTEPN='42'
19031      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'ODR2')
19032     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19033C
19034C     PRINT SUMMARY STATISTICS TABLE
19035C
19036      IF(IPRINT.EQ.'OFF')GOTO9000
19037C
19038      NUMDIG=7
19039      IF(IFORSW.EQ.'1')NUMDIG=1
19040      IF(IFORSW.EQ.'2')NUMDIG=2
19041      IF(IFORSW.EQ.'3')NUMDIG=3
19042      IF(IFORSW.EQ.'4')NUMDIG=4
19043      IF(IFORSW.EQ.'5')NUMDIG=5
19044      IF(IFORSW.EQ.'6')NUMDIG=6
19045      IF(IFORSW.EQ.'7')NUMDIG=7
19046      IF(IFORSW.EQ.'8')NUMDIG=8
19047      IF(IFORSW.EQ.'9')NUMDIG=9
19048      IF(IFORSW.EQ.'0')NUMDIG=0
19049      IF(IFORSW.EQ.'E')NUMDIG=-2
19050      IF(IFORSW.EQ.'-2')NUMDIG=-2
19051      IF(IFORSW.EQ.'-3')NUMDIG=-3
19052      IF(IFORSW.EQ.'-4')NUMDIG=-4
19053      IF(IFORSW.EQ.'-5')NUMDIG=-5
19054      IF(IFORSW.EQ.'-6')NUMDIG=-6
19055      IF(IFORSW.EQ.'-7')NUMDIG=-7
19056      IF(IFORSW.EQ.'-8')NUMDIG=-8
19057      IF(IFORSW.EQ.'-9')NUMDIG=-9
19058C
19059      ITITLE='Log(Odds Ratio) Test for Independence'
19060      NCTITL=38
19061      ITITLZ='2x2 Table (Log(Odds Ratio) = 0)'
19062      NCTITZ=31
19063C
19064      ICNT=0
19065      ICNT=ICNT+1
19066      ITEXT(ICNT)=' '
19067      NCTEXT(ICNT)=0
19068      AVALUE(ICNT)=0.0
19069      IDIGIT(ICNT)=-1
19070      ICNT=ICNT+1
19071      ITEXT(ICNT)='H0: The Two Variables Are Independent'
19072      NCTEXT(ICNT)=38
19073      AVALUE(ICNT)=0.0
19074      IDIGIT(ICNT)=-1
19075      ICNT=ICNT+1
19076      ITEXT(ICNT)='Ha: The Two Variables Are Not Independent'
19077      NCTEXT(ICNT)=42
19078      AVALUE(ICNT)=0.0
19079      IDIGIT(ICNT)=-1
19080      ICNT=ICNT+1
19081      ITEXT(ICNT)=' '
19082      NCTEXT(ICNT)=0
19083      AVALUE(ICNT)=0.0
19084      IDIGIT(ICNT)=-1
19085C
19086      ICNT=ICNT+1
19087      ITEXT(ICNT)='Sample 1:'
19088      NCTEXT(ICNT)=9
19089      AVALUE(ICNT)=0.0
19090      IDIGIT(ICNT)=-1
19091      ICNT=ICNT+1
19092      ITEXT(ICNT)='Number of Observations:'
19093      NCTEXT(ICNT)=23
19094      AVALUE(ICNT)=AN1
19095      IDIGIT(ICNT)=0
19096      ICNT=ICNT+1
19097      ITEXT(ICNT)='Number of Successes:'
19098      NCTEXT(ICNT)=20
19099      AVALUE(ICNT)=REAL(N11)
19100      IDIGIT(ICNT)=0
19101      ICNT=ICNT+1
19102      ITEXT(ICNT)='Number of Failures:'
19103      NCTEXT(ICNT)=19
19104      AVALUE(ICNT)=REAL(N21)
19105      IDIGIT(ICNT)=0
19106      ICNT=ICNT+1
19107      ITEXT(ICNT)='Probability of Success:'
19108      NCTEXT(ICNT)=23
19109      AVALUE(ICNT)=P11
19110      IDIGIT(ICNT)=NUMDIG
19111      ICNT=ICNT+1
19112      ITEXT(ICNT)='Probability of Failure:'
19113      NCTEXT(ICNT)=23
19114      AVALUE(ICNT)=P21
19115      IDIGIT(ICNT)=NUMDIG
19116      ICNT=ICNT+1
19117      ITEXT(ICNT)=' '
19118      NCTEXT(ICNT)=0
19119      AVALUE(ICNT)=0.0
19120      IDIGIT(ICNT)=-1
19121C
19122      ICNT=ICNT+1
19123      ITEXT(ICNT)='Sample 2:'
19124      NCTEXT(ICNT)=9
19125      AVALUE(ICNT)=0.0
19126      IDIGIT(ICNT)=-1
19127      ICNT=ICNT+1
19128      ITEXT(ICNT)='Number of Observations:'
19129      NCTEXT(ICNT)=23
19130      AVALUE(ICNT)=AN2
19131      IDIGIT(ICNT)=0
19132      ICNT=ICNT+1
19133      ITEXT(ICNT)='Number of Successes:'
19134      NCTEXT(ICNT)=20
19135      AVALUE(ICNT)=REAL(N12)
19136      IDIGIT(ICNT)=0
19137      ICNT=ICNT+1
19138      ITEXT(ICNT)='Number of Failures:'
19139      NCTEXT(ICNT)=19
19140      AVALUE(ICNT)=REAL(N22)
19141      IDIGIT(ICNT)=0
19142      ICNT=ICNT+1
19143      ITEXT(ICNT)='Probability of Success:'
19144      NCTEXT(ICNT)=23
19145      AVALUE(ICNT)=P12
19146      IDIGIT(ICNT)=NUMDIG
19147      ICNT=ICNT+1
19148      ITEXT(ICNT)='Probability of Failure:'
19149      NCTEXT(ICNT)=23
19150      AVALUE(ICNT)=P22
19151      IDIGIT(ICNT)=NUMDIG
19152      ICNT=ICNT+1
19153      ITEXT(ICNT)=' '
19154      NCTEXT(ICNT)=0
19155      AVALUE(ICNT)=0.0
19156      IDIGIT(ICNT)=-1
19157      ICNT=ICNT+1
19158      ITEXT(ICNT)='Log(Odds Ratio) = Log(n11*n22/(n12*n21)):'
19159      NCTEXT(ICNT)=42
19160      AVALUE(ICNT)=0.0
19161      IDIGIT(ICNT)=-1
19162      IF(ODDRAT.GT.CPUMIN)THEN
19163        ICNT=ICNT+1
19164        ITEXT(ICNT)='Log(Odds Ratio):'
19165        NCTEXT(ICNT)=16
19166        AVALUE(ICNT)=ODDRAT
19167        IDIGIT(ICNT)=NUMDIG
19168        ICNT=ICNT+1
19169        ITEXT(ICNT)='Standard Error of Log(Odds Ratio):'
19170        NCTEXT(ICNT)=34
19171        AVALUE(ICNT)=ODDRSE
19172        IDIGIT(ICNT)=NUMDIG
19173        ICNT=ICNT+1
19174        ITEXT(ICNT)=' '
19175        NCTEXT(ICNT)=0
19176        AVALUE(ICNT)=0.0
19177        IDIGIT(ICNT)=-1
19178      ENDIF
19179      ICNT=ICNT+1
19180      ITEXT(ICNT)='Log(Odds Ratio) (Bias Corrected):'
19181      NCTEXT(ICNT)=33
19182      AVALUE(ICNT)=ODDRBC
19183      IDIGIT(ICNT)=NUMDIG
19184      ICNT=ICNT+1
19185      ITEXT(ICNT)='Standard Error (Bias Corrected):'
19186      NCTEXT(ICNT)=32
19187      AVALUE(ICNT)=ORBCSE
19188      IDIGIT(ICNT)=NUMDIG
19189C
19190      NUMROW=ICNT
19191      DO2310I=1,NUMROW
19192        NTOT(I)=15
19193 2310 CONTINUE
19194C
19195      IFRST=.TRUE.
19196      ILAST=.TRUE.
19197      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,
19198     1            NCTEXT,AVALUE,IDIGIT,
19199     1            NTOT,NUMROW,
19200     1            ICAPSW,ICAPTY,ILAST,IFRST,
19201     1            ISUBRO,IBUGA3,IERROR)
19202C
19203      ITITLE(1:33)='Large Sample Confidence Interval '
19204      ITITLE(34:52)='for Log(Odds Ratio)'
19205      NCTITL=52
19206      ITITL9=' '
19207      NCTIT9=0
19208C
19209      ITITL2(1,1)=' '
19210      NCTIT2(1,1)=0
19211      NCOLSP(1,1)=1
19212      ITITL2(2,1)=' '
19213      NCTIT2(2,1)=0
19214      NCOLSP(2,1)=1
19215      ITITL2(3,1)='Confidence'
19216      NCTIT2(3,1)=10
19217      NCOLSP(3,1)=1
19218      ITITL2(4,1)='Value (%)'
19219      NCTIT2(4,1)=9
19220      NCOLSP(4,1)=1
19221C
19222      ITITL2(1,2)='Uncorrected Ratio'
19223      NCTIT2(1,2)=17
19224      NCOLSP(1,2)=2
19225      ITITL2(2,2)='(               )'
19226      WRITE(ITITL2(2,2)(2:16),'(G15.7)')ODDRAT
19227      NCTIT2(2,2)=17
19228      NCOLSP(2,2)=2
19229      ITITL2(3,2)='Lower'
19230      NCTIT2(3,2)=5
19231      NCOLSP(3,2)=1
19232      ITITL2(4,2)='Limit'
19233      NCTIT2(4,2)=5
19234      NCOLSP(4,2)=1
19235      ITITL2(1,3)=' '
19236      NCTIT2(1,3)=0
19237      NCOLSP(1,3)=0
19238      ITITL2(2,3)=' '
19239      NCTIT2(2,3)=0
19240      NCOLSP(2,3)=0
19241      ITITL2(3,3)='Upper'
19242      NCTIT2(3,3)=5
19243      NCOLSP(3,3)=1
19244      ITITL2(4,3)='Limit'
19245      NCTIT2(4,3)=5
19246      NCOLSP(4,3)=1
19247C
19248      ITITL2(1,4)='Bias Corrected Ratio'
19249      NCTIT2(1,4)=20
19250      NCOLSP(1,4)=2
19251      ITITL2(2,4)='(               )'
19252      WRITE(ITITL2(2,4)(2:16),'(G15.7)')ODDRBC
19253      NCTIT2(2,4)=17
19254      NCOLSP(2,4)=2
19255      ITITL2(3,4)='Lower'
19256      NCTIT2(3,4)=5
19257      NCOLSP(3,4)=1
19258      ITITL2(4,4)='Limit'
19259      NCTIT2(4,4)=5
19260      NCOLSP(4,4)=1
19261      ITITL2(1,5)=' '
19262      NCTIT2(1,5)=0
19263      NCOLSP(1,5)=0
19264      ITITL2(2,5)=' '
19265      NCTIT2(2,5)=0
19266      NCOLSP(2,5)=0
19267      ITITL2(3,5)='Upper'
19268      NCTIT2(3,5)=5
19269      NCOLSP(3,5)=1
19270      ITITL2(4,5)='Limit'
19271      NCTIT2(4,5)=5
19272      NCOLSP(4,5)=1
19273C
19274      NMAX=0
19275      DO4210I=1,NUMCLI
19276        VALIGN(I)='b'
19277        ALIGN(I)='r'
19278        NTOT(I)=15
19279        NMAX=NMAX+NTOT(I)
19280        ITYPCO(I)='NUME'
19281        DO4213J=1,MAXROW
19282          IF(I.EQ.1)THEN
19283            IDIGI2(J,I)=2
19284          ELSE
19285            IDIGI2(J,I)=NUMDIG
19286          ENDIF
19287 4213   CONTINUE
19288        IWHTML(1)=75
19289        IWHTML(2)=150
19290        IWHTML(3)=150
19291        IWHTML(4)=150
19292        IWHTML(5)=150
19293        IINC=1400
19294        IWRTF(1)=IINC
19295        IWRTF(2)=IWRTF(1)+IINC
19296        IWRTF(3)=IWRTF(2)+IINC
19297        IWRTF(4)=IWRTF(3)+IINC
19298        IWRTF(5)=IWRTF(4)+IINC
19299        IFRST=.TRUE.
19300        ILAST=.TRUE.
19301C
19302        DO4289J=1,NUMALP
19303          ATEMP=100.0*SIGVAL(J)
19304          AMAT(J,1)=ATEMP
19305          AMAT(J,2)=ALOWCL(J)
19306          AMAT(J,3)=AUPPCL(J)
19307          AMAT(J,4)=ALOWC2(J)
19308          AMAT(J,5)=AUPPC2(J)
19309          IVALUE(J,1)=' '
19310          IVALUE(J,2)=' '
19311          IVALUE(J,3)=' '
19312          IVALUE(J,4)=' '
19313          IVALUE(J,5)=' '
19314          NCVALU(J,1)=0
19315          NCVALU(J,2)=0
19316          NCVALU(J,3)=0
19317          NCVALU(J,4)=0
19318          NCVALU(J,5)=0
19319          ROWSEP(J)=0
19320 4289   CONTINUE
19321C
19322 4210 CONTINUE
19323C
19324      NUMLIN=4
19325      NUMCOL=5
19326      ICNT=NUMALP
19327      IFLAGS=.TRUE.
19328      IFLAGE=.TRUE.
19329      CALL DPDT5B(ITITLE,NCTITL,
19330     1            ITITL9,NCTIT9,ITITL2,NCTIT2,
19331     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
19332     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
19333     1            IDIGI2,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
19334     1            NCOLSP,ROWSEP,
19335     1            ICAPSW,ICAPTY,IFRST,ILAST,
19336     1            IFLAGS,IFLAGE,
19337     1            ISUBRO,IBUGA3,IERROR)
19338C
19339      ITITLE=' '
19340      NCTITL=0
19341      ITITLZ=' '
19342      NCTITZ=0
19343C
19344      ICNT=0
19345      ICNT=ICNT+1
19346      ITEXT(ICNT)='Test for Independence:'
19347      NCTEXT(ICNT)=22
19348      AVALUE(ICNT)=0.0
19349      IDIGIT(ICNT)=0
19350      IF(STATVA.LE.-90.0)THEN
19351        ICNT=ICNT+1
19352        ITEXT(ICNT)='Unable to compute the chi-square test statistic.'
19353        NCTEXT(ICNT)=48
19354        AVALUE(ICNT)=0.0
19355        IDIGIT(ICNT)=0
19356        ICNT=ICNT+1
19357        ITEXT(ICNT)='This is due to either zero failures for both'
19358        NCTEXT(ICNT)=44
19359        AVALUE(ICNT)=0.0
19360        IDIGIT(ICNT)=0
19361        ICNT=ICNT+1
19362        ITEXT(ICNT)='variables or zero successes for both variables.'
19363        NCTEXT(ICNT)=47
19364        AVALUE(ICNT)=0.0
19365        IDIGIT(ICNT)=0
19366        GOTO4259
19367      ENDIF
19368      ICNT=ICNT+1
19369      ITEXT(ICNT)='Chi-Square Test Statistic:'
19370      NCTEXT(ICNT)=26
19371      AVALUE(ICNT)=STATVA
19372      IDIGIT(ICNT)=NUMDIG
19373      ICNT=ICNT+1
19374      ITEXT(ICNT)='CDF of Test Statistic:'
19375      NCTEXT(ICNT)=22
19376      AVALUE(ICNT)=CDF
19377      IDIGIT(ICNT)=NUMDIG
19378      ICNT=ICNT+1
19379      ITEXT(ICNT)=' '
19380      NCTEXT(ICNT)=0
19381      AVALUE(ICNT)=0.0
19382      IDIGIT(ICNT)=-1
19383      ICNT=ICNT+1
19384      ITEXT(ICNT)='Test Statistic with Yates Correction:'
19385      NCTEXT(ICNT)=37
19386      AVALUE(ICNT)=STATV2
19387      IDIGIT(ICNT)=NUMDIG
19388      ICNT=ICNT+1
19389      ITEXT(ICNT)='CDF of Test Statistic with Yates Correction:'
19390      NCTEXT(ICNT)=44
19391      AVALUE(ICNT)=CDF2
19392      IDIGIT(ICNT)=NUMDIG
19393C
19394      NUMROW=ICNT
19395      DO4310I=1,NUMROW
19396        NTOT(I)=15
19397 4310 CONTINUE
19398C
19399      IFRST=.TRUE.
19400      ILAST=.TRUE.
19401      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,
19402     1            NCTEXT,AVALUE,IDIGIT,
19403     1            NTOT,NUMROW,
19404     1            ICAPSW,ICAPTY,ILAST,IFRST,
19405     1            ISUBRO,IBUGA3,IERROR)
19406C
19407      ITITLE(1:25)='Without Yates Correction:'
19408      NCTITL=25
19409      ITITL9=' '
19410      NCTIT9=0
19411C
19412      ITITL2(1,1)=' '
19413      NCTIT2(1,1)=0
19414      ITITL2(2,1)='Null'
19415      NCTIT2(2,1)=4
19416      ITITL2(3,1)='Hypothesis'
19417      NCTIT2(3,1)=10
19418      ITITL2(1,2)=' '
19419      NCTIT2(1,2)=0
19420      ITITL2(2,2)='Confidence'
19421      NCTIT2(2,2)=10
19422      ITITL2(3,2)='Level'
19423      NCTIT2(3,2)=5
19424      ITITL2(1,3)=' '
19425      NCTIT2(1,3)=0
19426      ITITL2(2,3)='Critical'
19427      NCTIT2(2,3)=8
19428      ITITL2(3,3)='Value'
19429      NCTIT2(3,3)=5
19430      ITITL2(1,4)='Null Hypothesis'
19431      NCTIT2(1,4)=15
19432      ITITL2(2,4)='Acceptance'
19433      NCTIT2(2,4)=10
19434      ITITL2(3,4)='Interval'
19435      NCTIT2(3,4)=8
19436      ITITL2(1,5)='Null'
19437      NCTIT2(1,5)=4
19438      ITITL2(2,5)='Hypothesis'
19439      NCTIT2(2,5)=10
19440      ITITL2(3,5)='Conclusion'
19441      NCTIT2(3,5)=10
19442C
19443      NMAX=0
19444      NUMCOL=5
19445      DO5210I=1,NUMCOL
19446        VALIGN(I)='b'
19447        ALIGN(I)='r'
19448        NTOT(I)=15
19449        NMAX=NMAX+NTOT(I)
19450        IF(I.EQ.3)THEN
19451          ITYPCO(I)='NUME'
19452        ELSE
19453          ITYPCO(I)='ALPH'
19454        ENDIF
19455        IF(I.EQ.2)THEN
19456          IDIGIT(I)=1
19457        ELSEIF(I.EQ.3)THEN
19458          IDIGIT(I)=2
19459        ELSE
19460          IDIGIT(I)=NUMDIG
19461        ENDIF
19462        IWHTML(1)=150
19463        IWHTML(2)=125
19464        IWHTML(3)=125
19465        IWHTML(4)=150
19466        IWHTML(5)=150
19467        IINC=1600
19468        IINC2=1400
19469        IINC3=2200
19470        IWRTF(1)=IINC
19471        IWRTF(2)=IWRTF(1)+IINC
19472        IWRTF(3)=IWRTF(2)+IINC2
19473        IWRTF(4)=IWRTF(3)+IINC3
19474        IWRTF(5)=IWRTF(4)+IINC2
19475C
19476        DO5289J=1,NUMALP
19477          IF(J.EQ.1)THEN
19478            IVALUE(J,2)='50.0%'
19479            NCVALU(J,2)=5
19480            AMAT(J,3)=CV1
19481            IVALUE(J,5)(1:6)=ICONC1(1:6)
19482            NCVALU(J,5)=6
19483            IVALUE(J,4)='(0,0.500)'
19484            NCVALU(J,4)=9
19485          ELSEIF(J.EQ.2)THEN
19486            IVALUE(J,2)='80.0%'
19487            NCVALU(J,2)=5
19488            AMAT(J,3)=CV2
19489            IVALUE(J,5)(1:6)=ICONC2(1:6)
19490            NCVALU(J,5)=6
19491            IVALUE(J,4)='(0,0.800)'
19492            NCVALU(J,4)=9
19493          ELSEIF(J.EQ.3)THEN
19494            IVALUE(J,2)='90.0%'
19495            NCVALU(J,2)=5
19496            AMAT(J,3)=CV3
19497            IVALUE(J,5)(1:6)=ICONC3(1:6)
19498            NCVALU(J,5)=6
19499            IVALUE(J,4)='(0,0.900)'
19500            NCVALU(J,4)=9
19501          ELSEIF(J.EQ.4)THEN
19502            IVALUE(J,2)='95.0%'
19503            NCVALU(J,2)=5
19504            AMAT(J,3)=CV4
19505            IVALUE(J,5)(1:6)=ICONC4(1:6)
19506            NCVALU(J,5)=6
19507            IVALUE(J,4)='(0,0.950)'
19508            NCVALU(J,4)=9
19509          ELSEIF(J.EQ.5)THEN
19510            IVALUE(J,2)='97.5%'
19511            NCVALU(J,2)=5
19512            AMAT(J,3)=CV5
19513            IVALUE(J,5)(1:6)=ICONC5(1:6)
19514            NCVALU(J,5)=6
19515            IVALUE(J,4)='(0,0.975)'
19516            NCVALU(J,4)=9
19517          ELSEIF(J.EQ.6)THEN
19518            IVALUE(J,2)='99.0%'
19519            NCVALU(J,2)=5
19520            AMAT(J,3)=CV6
19521            IVALUE(J,5)(1:6)=ICONC6(1:6)
19522            NCVALU(J,5)=6
19523            IVALUE(J,4)='(0,0.990)'
19524            NCVALU(J,4)=9
19525          ENDIF
19526          AMAT(J,1)=0.0
19527          AMAT(J,2)=0.0
19528          AMAT(J,4)=0.0
19529          AMAT(J,5)=0.0
19530          IVALUE(J,1)='Independent'
19531          NCVALU(J,1)=11
19532 5289   CONTINUE
19533C
19534 5210 CONTINUE
19535C
19536      ICNT=NUMALP
19537      NUMLIN=3
19538      NUMCOL=5
19539      IFRST=.TRUE.
19540      ILAST=.TRUE.
19541      IFLAGS=.TRUE.
19542      IFLAGE=.TRUE.
19543      CALL DPDTA5(ITITLE,NCTITL,
19544     1            ITITL9,NCTIT9,ITITL2,NCTIT2,
19545     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
19546     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
19547     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
19548     1            ICAPSW,ICAPTY,IFRST,ILAST,
19549     1            IFLAGS,IFLAGE,
19550     1            ISUBRO,IBUGA3,IERROR)
19551C
19552 4259 CONTINUE
19553C
19554      ITITLE(1:30)='With Yates Bias Correction:'
19555      NCTITL=30
19556C
19557      NUMCOL=5
19558      DO5310I=1,NUMCOL
19559C
19560        DO5389J=1,NUMALP
19561          IF(J.EQ.1)THEN
19562            IVALUE(J,5)(1:6)=KCONC1(1:6)
19563            NCVALU(J,5)=6
19564          ELSEIF(J.EQ.2)THEN
19565            IVALUE(J,5)(1:6)=KCONC2(1:6)
19566            NCVALU(J,5)=6
19567          ELSEIF(J.EQ.3)THEN
19568            IVALUE(J,5)(1:6)=KCONC3(1:6)
19569            NCVALU(J,5)=6
19570          ELSEIF(J.EQ.4)THEN
19571            IVALUE(J,5)(1:6)=KCONC4(1:6)
19572            NCVALU(J,5)=6
19573          ELSEIF(J.EQ.5)THEN
19574            IVALUE(J,5)(1:6)=KCONC5(1:6)
19575            NCVALU(J,5)=6
19576          ELSEIF(J.EQ.6)THEN
19577            IVALUE(J,5)(1:6)=KCONC6(1:6)
19578            NCVALU(J,5)=6
19579          ENDIF
19580 5389   CONTINUE
19581C
19582 5310 CONTINUE
19583C
19584      ICNT=NUMALP
19585      NUMLIN=3
19586      NUMCOL=5
19587      IFRST=.TRUE.
19588      ILAST=.TRUE.
19589      IFLAGS=.TRUE.
19590      IFLAGE=.TRUE.
19591      CALL DPDTA5(ITITLE,NCTITL,
19592     1            ITITL9,NCTIT9,ITITL2,NCTIT2,
19593     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
19594     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
19595     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
19596     1            ICAPSW,ICAPTY,IFRST,ILAST,
19597     1            IFLAGS,IFLAGE,
19598     1            ISUBRO,IBUGA3,IERROR)
19599C
19600 9000 CONTINUE
19601      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ODR2')THEN
19602        WRITE(ICOUT,999)
19603        CALL DPWRST('XXX','WRIT')
19604        WRITE(ICOUT,9011)
19605 9011   FORMAT('***** AT THE END       OF DPODR2--')
19606        CALL DPWRST('XXX','WRIT')
19607        WRITE(ICOUT,9013)AN11,AN21,AN12,AN22
19608 9013   FORMAT('AN11,AN21,AN12,AN22=',4G15.7)
19609        CALL DPWRST('XXX','WRIT')
19610        WRITE(ICOUT,9015)AN1,AN2
19611 9015   FORMAT('AN1,AN2=',2G15.7)
19612        CALL DPWRST('XXX','WRIT')
19613        WRITE(ICOUT,9017)N11,N21,N12,N22
19614 9017   FORMAT('N11,N21,N12,N22=',4I8)
19615        CALL DPWRST('XXX','WRIT')
19616      ENDIF
19617C
19618      RETURN
19619      END
19620      SUBROUTINE DPOPAC(IHARG,IARGT,ARG,NUMARG,DEFOAC,
19621     1OPTACC,IFOUND,IERROR)
19622C
19623C     PURPOSE--DEFINE THE OPTIMIZATION TOLERANCE.
19624C              ROUGHLY SPEAKING, THIS DEFINES THE DESIRED LENGTH
19625C              OF THE FINAL UNCERTAINTY REGION.
19626C              THE SPECIFIED OPTIMIZATION TOLERANCE VALUE WILL BE PLACED
19627C              IN THE FLOATING POINT VARIABLE OPTACC.
19628C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
19629C                     --IARGT  (A  HOLLERITH VECTOR)
19630C                     --ARG    (A  FLOATING POINT VECTOR)
19631C                     --NUMARG (AN INTEGER VARIABLE)
19632C                     --DEFOAC (A  FLOATING POINT VARIABLE)
19633C     OUTPUT ARGUMENTS--OPTACC  (A  FLOATING POINT VARIABLE)
19634C                     --IFOUND ('YES' OR 'NO' )
19635C                     --IERROR ('YES' OR 'NO' )
19636C     WRITTEN BY--JAMES J. FILLIBEN
19637C                 STATISTICAL ENGINEERING DIVISION
19638C                 INFORMATION TECHNOLOGY LABORATORY
19639C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
19640C                 GAITHERSBURG, MD 20899-8980
19641C                 PHONE--301-975-2855
19642C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
19643C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
19644C     LANGUAGE--ANSI FORTRAN (1977)
19645C     VERSION NUMBER--94/7
19646C     ORIGINAL VERSION--JUNE      1994.
19647C
19648C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
19649C
19650      CHARACTER*4 IHARG
19651      CHARACTER*4 IARGT
19652      CHARACTER*4 IFOUND
19653      CHARACTER*4 IERROR
19654C
19655C---------------------------------------------------------------------
19656C
19657      DIMENSION IHARG(*)
19658      DIMENSION IARGT(*)
19659      DIMENSION ARG(*)
19660C
19661C---------------------------------------------------------------------
19662C
19663      INCLUDE 'DPCOP2.INC'
19664C
19665C-----START POINT-----------------------------------------------------
19666C
19667      IFOUND='NO'
19668      IERROR='NO'
19669C
19670      IF(NUMARG.EQ.0)GOTO1199
19671      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'=')GOTO1199
19672      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'ACCU')GOTO1110
19673      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TOLE')GOTO1110
19674      GOTO1199
19675C
19676 1110 CONTINUE
19677      IF(IHARG(NUMARG).EQ.'ACCU')GOTO1150
19678      IF(IHARG(NUMARG).EQ.'TOLE')GOTO1150
19679      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
19680      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
19681      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
19682      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
19683      IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160
19684      GOTO1120
19685C
19686 1120 CONTINUE
19687      IERROR='YES'
19688      WRITE(ICOUT,1121)
19689 1121 FORMAT('***** ERROR IN DPOPAC--')
19690      CALL DPWRST('XXX','BUG ')
19691      WRITE(ICOUT,1122)
19692 1122 FORMAT('      ILLEGAL FORM FOR OPTIMIZATION TOLERANCE ',
19693     1'COMMAND.')
19694      CALL DPWRST('XXX','BUG ')
19695      WRITE(ICOUT,1124)
19696 1124 FORMAT('      TEST EXAMPLE TO DEMONSTRATE THE ',
19697     1'PROPER FORM--')
19698      CALL DPWRST('XXX','BUG ')
19699      WRITE(ICOUT,1125)
19700 1125 FORMAT('      SUPPOSE THE THE ANALYST WILL BE CARRYING OUT  ')
19701      CALL DPWRST('XXX','BUG ')
19702      WRITE(ICOUT,1126)
19703 1126 FORMAT('      AN OPTIMIZATION, ')
19704      CALL DPWRST('XXX','BUG ')
19705      WRITE(ICOUT,1127)
19706 1127 FORMAT('      AND SUPPOSE THE ANALYST WISHES THE FINAL  ')
19707      CALL DPWRST('XXX','BUG ')
19708      WRITE(ICOUT,1128)
19709 1128 FORMAT('      UNCERTAINITY INTERVAL TO BE .00001 OR SMALLER')
19710      CALL DPWRST('XXX','BUG ')
19711      WRITE(ICOUT,1130)
19712 1130 FORMAT('      THEN THE ALLOWABLE FORM IS--')
19713      CALL DPWRST('XXX','BUG ')
19714      WRITE(ICOUT,1131)
19715 1131 FORMAT('      OPTIMIZATION TOLERANCE .00001 ')
19716      CALL DPWRST('XXX','BUG ')
19717      GOTO1199
19718C
19719 1150 CONTINUE
19720      HOLD=DEFOAC
19721      GOTO1180
19722C
19723 1160 CONTINUE
19724      HOLD=ARG(NUMARG)
19725      GOTO1180
19726C
19727 1180 CONTINUE
19728      IFOUND='YES'
19729      OPTACC=HOLD
19730C
19731      IF(IFEEDB.EQ.'OFF')GOTO1189
19732      WRITE(ICOUT,999)
19733  999 FORMAT(1X)
19734      CALL DPWRST('XXX','BUG ')
19735      WRITE(ICOUT,1181)OPTACC
19736 1181 FORMAT('THE OPTIMIZATION TOLERANCE HAS JUST BEEN SET TO ',
19737     1E15.7)
19738      CALL DPWRST('XXX','BUG ')
19739 1189 CONTINUE
19740      GOTO1199
19741C
19742 1199 CONTINUE
19743      RETURN
19744      END
19745      SUBROUTINE DPOPDE
19746C
19747C     PURPOSE--OPEN A GRAPHICS DEVICE
19748C
19749C     WRITTEN BY--JAMES J. FILLIBEN
19750C                 STATISTICAL ENGINEERING DIVISION
19751C                 INFORMATION TECHNOLOGY LABORATORY
19752C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
19753C                 GAITHERSBURG, MD 20899-8980
19754C                 PHONE--301-975-2855
19755C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
19756C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
19757C     LANGUAGE--ANSI FORTRAN (1977)
19758C     VERSION NUMBER--83.6
19759C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY       1983.
19760C
19761C
19762C-----COMMON----------------------------------------------------------
19763C
19764      INCLUDE 'DPCOGR.INC'
19765      INCLUDE 'DPCOBE.INC'
19766      INCLUDE 'DPCOP2.INC'
19767C
19768C-----START POINT-----------------------------------------------------
19769C
19770      IERRG4='NO'
19771C
19772      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'OPDE')THEN
19773        WRITE(ICOUT,999)
19774  999   FORMAT(1X)
19775        CALL DPWRST('XXX','BUG ')
19776        WRITE(ICOUT,51)
19777   51   FORMAT('***** AT THE BEGINNING OF DPOPDE--')
19778        CALL DPWRST('XXX','BUG ')
19779        WRITE(ICOUT,52)IMANUF,IMODEL,IMODE2,IMODE3
19780   52   FORMAT('IMANUF,IMODEL,IMODE2,IMODE3 = ',3(A4,2X),A4)
19781        CALL DPWRST('XXX','BUG ')
19782        WRITE(ICOUT,54)ISOFT,ISOFT2,ISOFT3,IGCODE
19783   54   FORMAT('ISOFT,ISOFT2,ISOFT3,IGCODE = ',3(A4,2X),A4)
19784        CALL DPWRST('XXX','BUG ')
19785        WRITE(ICOUT,55)IGUNIT,IGBAUD
19786   55   FORMAT('IGUNIT,IGBAUD = ',2I8)
19787        CALL DPWRST('XXX','BUG ')
19788        WRITE(ICOUT,56)IBUGG4,ISUBG4,IERRG4
19789   56   FORMAT('IBUGG4,ISUBG4,IERRG4 = ',2(A4,2X),A4)
19790        CALL DPWRST('XXX','BUG ')
19791      ENDIF
19792C
19793C               *****************************
19794C               **  STEP 1--               **
19795C               **  OPEN GRAPHICS DEVICES  **
19796C               *****************************
19797C
19798      CALL GROPDE
19799C
19800C               ******************************
19801C               **  STEP 2--                **
19802C               **  OPEN GRAPHICS SOFTWARE  **
19803C               ******************************
19804C
19805CCCCC CALL GROPSO
19806C
19807C               *****************
19808C               **  STEP 90--  **
19809C               **  EXIT       **
19810C               *****************
19811C
19812      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'OPDE')THEN
19813        WRITE(ICOUT,999)
19814        CALL DPWRST('XXX','BUG ')
19815        WRITE(ICOUT,9011)
19816 9011   FORMAT('***** AT THE END       OF DPOPDE--')
19817        CALL DPWRST('XXX','BUG ')
19818      ENDIF
19819C
19820      RETURN
19821      END
19822      SUBROUTINE DPOPF0(IFILNU,IBUGS2,ISUBRO,IERROR)
19823C
19824C     PURPOSE--OPEN ONE OF THE GENERAL DATAPLOT FILES.
19825C              IN PARTICULAR, OPEN THE FILE WITH
19826C              NUMERIC DESIGNATION IFILNU
19827C              WHERE IFILNU MAY BE THE UNIT NUMBER FOR
19828C                 THE PLOT-1 FILE,
19829C                 THE PLOT-2 FILE,
19830C                 THE CONCLUSIONS FILE.
19831C
19832C     WRITTEN BY--JAMES J. FILLIBEN
19833C                 STATISTICAL ENGINEERING DIVISION
19834C                 INFORMATION TECHNOLOGY LABORATORY
19835C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
19836C                 GAITHERSBURG, MD 20899-8980
19837C                 PHONE--301-975-2855
19838C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
19839C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
19840C     LANGUAGE--ANSI FORTRAN (1977)
19841C     VERSION NUMBER--86/1
19842C     ORIGINAL VERSION--JANUARY   1986.
19843C
19844C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
19845C
19846      CHARACTER*4 IBUGS2
19847      CHARACTER*4 ISUBRO
19848      CHARACTER*4 IFOUND
19849      CHARACTER*4 IERROR
19850C
19851      INCLUDE 'DPCOPA.INC'
19852C
19853CCCCC CHARACTER*80 IFILE
19854      CHARACTER (LEN=MAXFNC) :: IFILE
19855      CHARACTER*12 ISTAT
19856      CHARACTER*12 IFORM
19857      CHARACTER*12 IACCES
19858      CHARACTER*12 IPROT
19859      CHARACTER*12 ICURST
19860CCCCC CHARACTER*4 IENDFI
19861      CHARACTER*4 IREWIN
19862      CHARACTER*4 ISUBN0
19863      CHARACTER*4 IERRFI
19864C
19865      CHARACTER*4 ISUBN1
19866      CHARACTER*4 ISUBN2
19867      CHARACTER*4 ISTEPN
19868C
19869C-----COMMON----------------------------------------------------------
19870C
19871      INCLUDE 'DPCOF2.INC'
19872      INCLUDE 'DPCOP2.INC'
19873C
19874C-----START POINT-----------------------------------------------------
19875C
19876      ISUBN1='DPOP'
19877      ISUBN2='F0  '
19878      IFOUND='YES'
19879      IERROR='NO'
19880C
19881      IF(IBUGS2.EQ.'ON' .OR. ISUBRO.EQ.'OPF0')THEN
19882        WRITE(ICOUT,999)
19883  999   FORMAT(1X)
19884        CALL DPWRST('XXX','BUG ')
19885        WRITE(ICOUT,51)
19886   51   FORMAT('***** AT THE BEGINNING OF DPOPF0--')
19887        CALL DPWRST('XXX','BUG ')
19888        WRITE(ICOUT,52)IBUGS2,ISUBRO,IERROR,IFILNU
19889   52   FORMAT('IBUGS2,ISUBRO,IERROR,IFILNU = ',3(A4,2X),I8)
19890        CALL DPWRST('XXX','BUG ')
19891        WRITE(ICOUT,54)IPL1NU,IPL1ST
19892   54   FORMAT('IPL1NU,IPL1ST = ',I8,2X,A12)
19893        CALL DPWRST('XXX','BUG ')
19894        WRITE(ICOUT,55)IPL2NU,IPL2ST
19895   55   FORMAT('IPL2NU,IPL2ST = ',I8,2X,A12)
19896        CALL DPWRST('XXX','BUG ')
19897        WRITE(ICOUT,56)ICONNU,ICONST
19898   56   FORMAT('ICONNU,ICONST = ',I8,2X,A12)
19899        CALL DPWRST('XXX','BUG ')
19900      ENDIF
19901C
19902C               ***************************************
19903C               **  STEP 11--                        **
19904C               **  BRANCH TO THE APPROPRIATE CASE   **
19905C               **  TO COPY OVER VARIABLES.          **
19906C               ***************************************
19907C
19908      ISTEPN='11'
19909      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'OPF0')
19910     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19911C
19912      IF(IFILNU.EQ.IPL1NU)GOTO1110
19913      IF(IFILNU.EQ.IPL2NU)GOTO1120
19914      IF(IFILNU.EQ.ICONNU)GOTO1130
19915      GOTO1200
19916C
19917 1110 CONTINUE
19918      IOUNIT=IPL1NU
19919      IFILE=IPL1NA
19920      ISTAT=IPL1ST
19921      IFORM=IPL1FO
19922      IACCES=IPL1AC
19923      IPROT=IPL1PR
19924      ICURST=IPL1CS
19925      ISUBN0='OPF0'
19926      IERRFI='NO'
19927      GOTO1190
19928C
19929 1120 CONTINUE
19930      IOUNIT=IPL2NU
19931      IFILE=IPL2NA
19932      ISTAT=IPL2ST
19933      IFORM=IPL2FO
19934      IACCES=IPL2AC
19935      IPROT=IPL2PR
19936      ICURST=IPL2CS
19937      ISUBN0='OPF0'
19938      IERRFI='NO'
19939      GOTO1190
19940C
19941 1130 CONTINUE
19942      IOUNIT=ICONNU
19943      IFILE=ICONNA
19944      ISTAT=ICONST
19945      IFORM=ICONFO
19946      IACCES=ICONAC
19947      IPROT=ICONPR
19948      ICURST=ICONCS
19949      ISUBN0='OPF0'
19950      IERRFI='NO'
19951      GOTO1190
19952C
19953 1190 CONTINUE
19954      IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'OPF0')GOTO1199
19955      WRITE(ICOUT,1193)IOUNIT
19956 1193 FORMAT('IOUNIT = ',I8)
19957      CALL DPWRST('XXX','BUG ')
19958      WRITE(ICOUT,1194)IFILE
19959 1194 FORMAT('IFILE = ',A80)
19960      CALL DPWRST('XXX','BUG ')
19961      WRITE(ICOUT,1195)ISTAT,IFORM,IACCES,IPROT,ICURST
19962 1195 FORMAT('ISTAT,IFORM,IACCES,IPROT,ICURST = ',
19963     1A12,2X,A12,2X,A12,2X,A12,2X,A12)
19964      CALL DPWRST('XXX','BUG ')
19965      WRITE(ICOUT,1196)ISUBN0,IERRFI
19966 1196 FORMAT('ISUBN0,IERRFI = ',A4,2X,A4)
19967      CALL DPWRST('XXX','BUG ')
19968 1199 CONTINUE
19969      GOTO1300
19970C
19971C               ****************************************
19972C               **  STEP 12--                         **
19973C               **  IF NO MATCH FOUND FOR CASE,       **
19974C               **  THEN WRITE OUT AN ERROR MESSAGE   **
19975C               ****************************************
19976C
19977 1200 CONTINUE
19978      ISTEPN='12'
19979      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'OPF0')
19980     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19981C
19982      IERROR='YES'
19983      WRITE(ICOUT,999)
19984      CALL DPWRST('XXX','BUG ')
19985      WRITE(ICOUT,1211)
19986 1211 FORMAT('***** INTERNAL ERROR IN DPOPF0--')
19987      CALL DPWRST('XXX','BUG ')
19988      WRITE(ICOUT,1212)IFILNU
19989 1212 FORMAT('      THE FILE WITH LOGICAL UNIT NUMBER = ',I8)
19990      CALL DPWRST('XXX','BUG ')
19991      WRITE(ICOUT,1213)
19992 1213 FORMAT('      WAS NOT OPENED BECAUSE')
19993      CALL DPWRST('XXX','BUG ')
19994      WRITE(ICOUT,1214)
19995 1214 FORMAT('      THIS LOGICAL UNIT NUMBER DID NOT MATCH')
19996      CALL DPWRST('XXX','BUG ')
19997      WRITE(ICOUT,1215)
19998 1215 FORMAT('      THE LOGICAL UNIT NUMBER OF ANY OF')
19999      CALL DPWRST('XXX','BUG ')
20000      WRITE(ICOUT,1216)
20001 1216 FORMAT('      THE DATAPLOT GENERAL FILES.')
20002      CALL DPWRST('XXX','BUG ')
20003      WRITE(ICOUT,1217)IPL1NU,IPL2NU,ICONNU
20004 1217 FORMAT('      IPL1NU,IPL2NU,ICONNU = ',3I8)
20005      CALL DPWRST('XXX','BUG ')
20006      GOTO9000
20007C
20008C               ****************************************
20009C               **  STEP 13--                         **
20010C               **  CHECK TO SEE IF FILE MAY EXIST    **
20011C               ****************************************
20012C
20013 1300 CONTINUE
20014      ISTEPN='13'
20015      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'OPF0')
20016     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20017C
20018      IF(ISTAT.EQ.'NONE')GOTO1310
20019      GOTO1390
20020 1310 CONTINUE
20021      IERROR='YES'
20022      WRITE(ICOUT,999)
20023      CALL DPWRST('XXX','BUG ')
20024      WRITE(ICOUT,1311)
20025 1311 FORMAT('***** IMPLEMENTATION ERROR IN DPOPF0--')
20026      CALL DPWRST('XXX','BUG ')
20027      WRITE(ICOUT,1312)
20028 1312 FORMAT('      THE DESIRED FILE')
20029      CALL DPWRST('XXX','BUG ')
20030      WRITE(ICOUT,1313)
20031 1313 FORMAT('      WAS NOT OPENED BECAUSE')
20032      CALL DPWRST('XXX','BUG ')
20033      WRITE(ICOUT,1314)
20034 1314 FORMAT('      THE STATUS VARIABLE    ISTAT')
20035      CALL DPWRST('XXX','BUG ')
20036      WRITE(ICOUT,1315)
20037 1315 FORMAT('      (AS SET IN SUBROUTINE   INITFO)')
20038      CALL DPWRST('XXX','BUG ')
20039      WRITE(ICOUT,1316)
20040 1316 FORMAT('      HAS THE SETTING   NONE   .')
20041      CALL DPWRST('XXX','BUG ')
20042      WRITE(ICOUT,1317)IFILNU,ISTAT
20043 1317 FORMAT('      IFILNU,ISTAT = ',I8,2X,A12)
20044      CALL DPWRST('XXX','BUG ')
20045      WRITE(ICOUT,1318)
20046 1318 FORMAT('      CONTACT THE DATAPLOT IMPLEMENTOR')
20047      CALL DPWRST('XXX','BUG ')
20048      WRITE(ICOUT,1319)IFILNU
20049 1319 FORMAT('      AND HAVE THIS VARIABLE FOR FILE ',I8)
20050      CALL DPWRST('XXX','BUG ')
20051      WRITE(ICOUT,1320)
20052 1320 FORMAT('      SET TO THE PROPER VALUE (E.G.,')
20053      CALL DPWRST('XXX','BUG ')
20054      WRITE(ICOUT,1321)
20055 1321 FORMAT('      OLD, NEW, UNKNOWN)')
20056      CALL DPWRST('XXX','BUG ')
20057      GOTO9000
20058 1390 CONTINUE
20059C
20060C               *********************
20061C               **  STEP 31--      **
20062C               **  OPEN THE FILE  **
20063C               *********************
20064C
20065      ISTEPN='31'
20066      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'OPF0')
20067     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20068C
20069      IREWIN='ON'
20070      CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
20071     1IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
20072      IF(IERRFI.EQ.'YES')GOTO9000
20073C
20074C               ****************
20075C               **  STEP 90-- **
20076C               **  EXIT.     **
20077C               ****************
20078C
20079 9000 CONTINUE
20080      IF(IBUGS2.EQ.'ON' .OR. ISUBRO.EQ.'OPF0')THEN
20081        WRITE(ICOUT,999)
20082        CALL DPWRST('XXX','BUG ')
20083        WRITE(ICOUT,9011)
20084 9011   FORMAT('***** AT THE END       OF DPOPF0--')
20085        CALL DPWRST('XXX','BUG ')
20086        WRITE(ICOUT,9012)IERROR,IREWIN,IERRFI,ISUBN0,IOUNIT
20087 9012   FORMAT('IERROR,IREWIN,IERRFI,ISUBN0,IOUNIT = ',4(A4,2X),I5)
20088        CALL DPWRST('XXX','BUG ')
20089        WRITE(ICOUT,9022)IFILE(1:80)
20090 9022   FORMAT('IFILE  = ',A80)
20091        CALL DPWRST('XXX','BUG ')
20092        WRITE(ICOUT,9023)ISTAT,IFORM,IACCES,IPROT,ICURST
20093 9023   FORMAT('ISTAT,IFORM,IACCES,IPROT,ICURST = ',4(A12,2X),A12)
20094        CALL DPWRST('XXX','BUG ')
20095      ENDIF
20096C
20097      RETURN
20098      END
20099      SUBROUTINE DPOPME(IHARG,NUMARG,IDEFOM,IDEFHS,IOPTME,IOPTHE,
20100     1                  IBUGS2,IFOUND,IERROR)
20101C
20102C     PURPOSE--DEFINE THE OPTIMIZATION METHOD
20103C              CAN BE:
20104C                   <LINE/HOOK/DOGLEG>  <FINITE/BFGS>
20105C              WHERE THE FIRST ARGUMENT DEFINES THE STEP SELECTION
20106C              STRATEGY AND THE SECOND ARGUMENT DEFINES THE TYPE
20107C              OF HESSIAN APPROXIMATION.
20108C
20109C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
20110C                     --NUMARG (AN INTEGER VARIABLE)
20111C                     --IDEFOM (A  CHARACTER VARIABLE)
20112C                     --IDEFHS (A  CHARACTER VARIABLE)
20113C                     --IBUGS2 (A  CHARACTER VARIABLE)
20114C     OUTPUT ARGUMENTS--IOPTME (A CHARACTER VARIABLE)
20115C                     --IOPTME (A CHARACTER VARIABLE)
20116C                     --IFOUND ('YES' OR 'NO' )
20117C                     --IERROR ('YES' OR 'NO' )
20118C     WRITTEN BY--JAMES J. FILLIBEN
20119C                 STATISTICAL ENGINEERING DIVISION
20120C                 INFORMATION TECHNOLOGY LABORATORY
20121C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
20122C                 GAITHERSBURG, MD 20899-8980
20123C                 PHONE--301-975-2855
20124C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
20125C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
20126C     LANGUAGE--ANSI FORTRAN (1977)
20127C     VERSION NUMBER--95/2
20128C     ORIGINAL VERSION--FEBRUARY 1995.
20129C
20130C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
20131C
20132      CHARACTER*4 IHARG
20133      CHARACTER*4 IDEFOM
20134      CHARACTER*4 IDEFHS
20135      CHARACTER*4 IOPTME
20136      CHARACTER*4 IOPTHE
20137      CHARACTER*4 IBUGS2
20138      CHARACTER*4 IFOUND
20139      CHARACTER*4 IERROR
20140C
20141      CHARACTER*4 IHOLD1
20142      CHARACTER*4 IHOLD2
20143C
20144C---------------------------------------------------------------------
20145C
20146      DIMENSION IHARG(*)
20147C
20148C---------------------------------------------------------------------
20149C
20150      INCLUDE 'DPCOP2.INC'
20151C
20152C-----START POINT-----------------------------------------------------
20153C
20154      IF(IBUGS2.EQ.'OFF')GOTO90
20155      WRITE(ICOUT,999)
20156  999 FORMAT(1X)
20157      CALL DPWRST('XXX','BUG ')
20158      WRITE(ICOUT,51)
20159   51 FORMAT('***** AT THE BEGINNING OF DPOPME--')
20160      CALL DPWRST('XXX','BUG ')
20161      WRITE(ICOUT,53)IDEFOM,IDEFHS
20162   53 FORMAT('IDEFOM, IDEFHS = ',A4,1X,A4)
20163      CALL DPWRST('XXX','BUG ')
20164      WRITE(ICOUT,54)NUMARG
20165   54 FORMAT('NUMARG = ',I8)
20166      CALL DPWRST('XXX','BUG ')
20167      DO55I=1,NUMARG
20168      WRITE(ICOUT,56)I,IHARG(I)
20169   56 FORMAT('I,IHARG(I) = ',I8,2X,A4)
20170      CALL DPWRST('XXX','BUG ')
20171   55 CONTINUE
20172   90 CONTINUE
20173C
20174      IFOUND='NO'
20175      IERROR='NO'
20176      IHOLD1='    '
20177      IHOLD2='    '
20178C
20179      IF(NUMARG.LE.1)GOTO1150
20180      IF(NUMARG.EQ.2)GOTO1110
20181      IF(NUMARG.EQ.3)GOTO1120
20182      IF(NUMARG.GE.4)GOTO9000
20183C
20184 1110 CONTINUE
20185      IHOLD1=IDEFOM
20186      IF(IHARG(2).EQ.'LINE')IHOLD1='LINE'
20187      IF(IHARG(2).EQ.'DOGL')IHOLD1='DOGL'
20188      IF(IHARG(2).EQ.'DOUB')IHOLD1='DOGL'
20189      IF(IHARG(2).EQ.'HOOK')IHOLD1='HOOK'
20190      GOTO1180
20191C
20192 1120 CONTINUE
20193      IHOLD1=IDEFOM
20194      IF(IHARG(2).EQ.'LINE')IHOLD1='LINE'
20195      IF(IHARG(2).EQ.'DOGL')IHOLD1='DOGL'
20196      IF(IHARG(2).EQ.'DOUB')IHOLD1='DOGL'
20197      IF(IHARG(2).EQ.'HOOK')IHOLD1='HOOK'
20198      IHOLD2=IDEFHS
20199      IF(IHARG(3).EQ.'FINI')IHOLD2='FINI'
20200      IF(IHARG(3).EQ.'DIFF')IHOLD2='FINI'
20201      IF(IHARG(3).EQ.'BFGS')IHOLD2='BFGS'
20202      GOTO1180
20203C
20204 1150 CONTINUE
20205      IHOLD1=IDEFOM
20206      IHOLD2=IDEFHS
20207      GOTO1180
20208C
20209 1180 CONTINUE
20210      IFOUND='YES'
20211      IOPTME=IHOLD1
20212      IOPTHE=IHOLD2
20213C
20214      IF(IFEEDB.EQ.'OFF')GOTO1189
20215      WRITE(ICOUT,999)
20216      CALL DPWRST('XXX','BUG ')
20217      WRITE(ICOUT,1181)IOPTME
20218 1181 FORMAT(
20219     1'THE OPTIMIZATION STEP SELECTION STRATEGY HAS JUST BEEN SET TO ',
20220     1A4)
20221      CALL DPWRST('XXX','BUG ')
20222      WRITE(ICOUT,1182)IOPTHE
20223 1182 FORMAT(
20224     1'THE OPTIMIZATION HESSIAN APPROXIMATION METHOD HAS JUST BEEN ',
20225     1'SET TO ',A4)
20226      CALL DPWRST('XXX','BUG ')
20227 1189 CONTINUE
20228      GOTO9000
20229C
20230 9000 CONTINUE
20231      IF(IBUGS2.EQ.'OFF')GOTO9090
20232      WRITE(ICOUT,999)
20233      CALL DPWRST('XXX','BUG ')
20234      WRITE(ICOUT,9011)
20235 9011 FORMAT('***** AT THE END       OF DPOPME')
20236      CALL DPWRST('XXX','BUG ')
20237      WRITE(ICOUT,9012)IBUGS2,IFOUND,IERROR
20238 9012 FORMAT('IBUGS2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
20239      CALL DPWRST('XXX','BUG ')
20240      WRITE(ICOUT,9013)IDEFOM,IDEFHS
20241 9013 FORMAT('IDEFOM, IDEFHS = ',A4,1X,A4)
20242      CALL DPWRST('XXX','BUG ')
20243      WRITE(ICOUT,9014)IOPTME,IOPTHE
20244 9014 FORMAT('IOPTME, IOPTHE = ',A4,1X,A4)
20245      CALL DPWRST('XXX','BUG ')
20246 9090 CONTINUE
20247C
20248      RETURN
20249      END
20250      SUBROUTINE DPOPPL(IGRASW,
20251     1IBELSW,NUMRIN,IERASW,
20252     1IBACCO)
20253C
20254C     PURPOSE--CARRY OUT OPENING OPERATIONS
20255C              PRIOR TO THE GENERATION OF A PLOT.
20256C
20257C     WRITTEN BY--JAMES J. FILLIBEN
20258C                 STATISTICAL ENGINEERING DIVISION
20259C                 INFORMATION TECHNOLOGY LABORATORY
20260C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
20261C                 GAITHERSBURG, MD 20899-8980
20262C                 PHONE--301-975-2855
20263C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
20264C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
20265C     LANGUAGE--ANSI FORTRAN (1977)
20266C     VERSION NUMBER--83.6
20267C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY       1983.
20268C
20269C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
20270C
20271      CHARACTER*4 IGRASW
20272      CHARACTER*4 IBELSW
20273      CHARACTER*4 IERASW
20274      CHARACTER*4 IBACCO
20275C
20276C
20277C-----COMMON----------------------------------------------------------
20278C
20279      INCLUDE 'DPCOGR.INC'
20280      INCLUDE 'DPCOBE.INC'
20281      INCLUDE 'DPCOP2.INC'
20282C
20283C-----START POINT-----------------------------------------------------
20284C
20285      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'OPPL')GOTO90
20286      WRITE(ICOUT,999)
20287  999 FORMAT(1X)
20288      CALL DPWRST('XXX','BUG ')
20289      WRITE(ICOUT,51)
20290   51 FORMAT('***** AT THE BEGINNING OF DPOPPL--')
20291      CALL DPWRST('XXX','BUG ')
20292      WRITE(ICOUT,52)IMANUF,IMODEL,IMODE2,IMODE3
20293   52 FORMAT('IMANUF,IMODEL,IMODE2,IMODE3 = ',A4,2X,A4,2X,A4,2X,A4)
20294      CALL DPWRST('XXX','BUG ')
20295      WRITE(ICOUT,53)IGUNIT,IGCODE
20296   53 FORMAT('IGUNIT,IGCODE = ',I8,2X,A4)
20297      CALL DPWRST('XXX','BUG ')
20298      WRITE(ICOUT,54)ISOFT,ISOFT2,ISOFT3
20299   54 FORMAT('ISOFT,ISOFT2,ISOFT3 = ',A4,2X,A4,2X,A4)
20300      CALL DPWRST('XXX','BUG ')
20301      WRITE(ICOUT,55)IGBAUD
20302   55 FORMAT('IGBAUD = ',I8)
20303      CALL DPWRST('XXX','BUG ')
20304      WRITE(ICOUT,61)IGRASW
20305   61 FORMAT('IGRASW= ',A4)
20306      CALL DPWRST('XXX','BUG ')
20307      WRITE(ICOUT,62)IBELSW,NUMRIN
20308   62 FORMAT('IBELSW,NUMRIN= ',A4,I8)
20309      CALL DPWRST('XXX','BUG ')
20310      WRITE(ICOUT,63)IERASW
20311   63 FORMAT('IERASW= ',A4)
20312      CALL DPWRST('XXX','BUG ')
20313      WRITE(ICOUT,64)IBACCO
20314   64 FORMAT('IBACCO= ',A4)
20315      CALL DPWRST('XXX','BUG ')
20316      WRITE(ICOUT,69)IBUGG4,ISUBG4,IERRG4
20317   69 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
20318      CALL DPWRST('XXX','BUG ')
20319   90 CONTINUE
20320C
20321C               ************************
20322C               **  STEP 1--          **
20323C               **  KILL THE PROMPT,  **
20324C               **  IF ONE EXISTS     **
20325C               ************************
20326C
20327CCCCC CALL GRKIPR
20328C
20329C               ****************************************************************
20330C               **  STEP 2--
20331C               **  EXIT OUT OF THE DIALOGUE (= MONITOR) MODE
20332C               **  AND MOVE TO GRAPHICS MODE.
20333C               **  THE GRAPHICS MODE ON VARIOUS TERMINALS
20334C               **  IS USUALLY OF 3 TYPES--
20335C               **     1. FOR TERMINALS WITH NO FORMAL GRAPHICS REGION AND
20336C               **        NO SEPARATE GRAPHICS PLANE
20337C               **        (AND THUS SUCCEDING GRAPHICS OUTPUT WILL
20338C               **        OVERWRITE THE NON-GRAPHICS DIALOGUE OUTPUT ON THE SCRE
20339C               **        THEN DO NOTHING.
20340C               **     2. FOR THOSE TERMINALS IN WHICH THE SCREEN
20341C               **        IS SHARED BETWEEN A GRAPHICS REGION AND
20342C               **        A DIALOGUE (= MONITOR) REGION (USUALLY AT THE BOTTOM),
20343C               **        THEN GO TO THE GRAPHICS REGION.
20344C               **     3. FOR TERMINALS WITH A FULL-SCREEN FOREGROUND
20345C               **        GRAPHICS PLANE THAT THE USER CAN FLIP-FLOP TO
20346C               **        AND WHICH IS INDEPENDENT OF THE DIALOGUE PLANE,
20347C               **        THEN GO TO THE GRAPHICS PLANE.
20348C               ****************************************************************
20349C
20350      IGRASW='ON'
20351      CALL GRSEMO(IGRASW,PDIAXC,PDIAYC)
20352C
20353C               ************************
20354C               **  STEP 3--          **
20355C               **  ERASE THE SCREEN  **
20356C               **  (IF CALLED FOR)   **
20357C               ************************
20358C
20359      IF(IERASW.EQ.'ON')CALL DPERSC(IBACCO)
20360C
20361C               *************************************
20362C               **  STEP 4--                       **
20363C               **  RING THE BELL (IF CALLED FOR)  **
20364C               **  TO SIGNAL A SCREEN ERASURE     **
20365C               *************************************
20366C
20367      IF(IBELSW.EQ.'OFF')GOTO1390
20368      IF(NUMRIN.LE.0)GOTO1390
20369      DO1300I=1,NUMRIN
20370      CALL GRRIBE
20371 1300 CONTINUE
20372 1390 CONTINUE
20373C
20374C               *****************
20375C               **  STEP 90--  **
20376C               **  EXIT       **
20377C               *****************
20378C
20379      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'OPPL')GOTO9090
20380      WRITE(ICOUT,999)
20381      CALL DPWRST('XXX','BUG ')
20382      WRITE(ICOUT,9011)
20383 9011 FORMAT('***** AT THE END       OF DPOPPL--')
20384      CALL DPWRST('XXX','BUG ')
20385      WRITE(ICOUT,9012)IMANUF,IMODEL,IMODE2,IMODE3
20386 9012 FORMAT('IMANUF,IMODEL,IMODE2,IMODE3 = ',A4,2X,A4,2X,A4,2X,A4)
20387      CALL DPWRST('XXX','BUG ')
20388      WRITE(ICOUT,9013)IGUNIT,IGCODE
20389 9013 FORMAT('IGUNIT,IGCODE = ',I8,2X,A4)
20390      CALL DPWRST('XXX','BUG ')
20391      WRITE(ICOUT,9014)ISOFT,ISOFT2,ISOFT3
20392 9014 FORMAT('ISOFT,ISOFT2,ISOFT3 = ',A4,2X,A4,2X,A4)
20393      CALL DPWRST('XXX','BUG ')
20394      WRITE(ICOUT,9015)IGBAUD
20395 9015 FORMAT('IGBAUD = ',I8)
20396      CALL DPWRST('XXX','BUG ')
20397      WRITE(ICOUT,9021)IGRASW
20398 9021 FORMAT('IGRASW= ',A4)
20399      CALL DPWRST('XXX','BUG ')
20400      WRITE(ICOUT,9022)IBELSW,NUMRIN
20401 9022 FORMAT('IBELSW,NUMRIN= ',A4,I8)
20402      CALL DPWRST('XXX','BUG ')
20403      WRITE(ICOUT,9023)IERASW
20404 9023 FORMAT('IERASW= ',A4)
20405      CALL DPWRST('XXX','BUG ')
20406      WRITE(ICOUT,9024)IBACCO
20407 9024 FORMAT('IBACCO= ',A4)
20408      CALL DPWRST('XXX','BUG ')
20409      WRITE(ICOUT,9029)IBUGG4,ISUBG4,IERRG4
20410 9029 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
20411      CALL DPWRST('XXX','BUG ')
20412 9090 CONTINUE
20413C
20414      RETURN
20415      END
20416      SUBROUTINE DPOPT(ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,
20417     1                 IA,PARAM,IPARN,IPARN2,
20418     1                 OPTACC,IOPTME,IOPTHE,
20419     1                 IFTEXP,IFTORD,IFORSW,IANGLU,
20420     1                 ISUBRO,IBUGA3,IBUGCO,IBUGEV,IBUGQ,IERROR)
20421C
20422C     PURPOSE--TREAT THE LET CASE FOR
20423C              FINDING THE MINIMUM OF A FUNCTION.
20424C     EXAMPLE--UNIVARIATE CASE:
20425C            --LET A = OPTIMIZE X**3+2*X**2-4*X+5 WRT X FOR X = -100 200
20426C            --LET A = F1 WRT X FOR X = 0 B
20427C            --USES FMIN ROUTINE FROM "NUMERICAL METHODS AND SOFTWARE",
20428C              BY KAHANER, MOLER, AND NASH
20429C     EXAMPLE--MULTIVARIATE CASE:
20430C            --(START VALUE FROM X(1) AND Y(1))
20431C            --LET A = OPTIMIZE X**2+Y**2-X*Y WRT X Y
20432C            --LET A = F1 WRT X Y
20433C            --USES UNCMIN PACKAGE OF ROBERT SCHNABEL AND BARRY WEISS
20434C     WRITTEN BY--ALAN HECKERT
20435C                 STATISTICAL ENGINEERING DIVISION
20436C                 INFORMATION TECHNOLOGY LABORATORY
20437C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
20438C                 GAITHERSBURG, MD 20899-8980
20439C                 PHONE--301-975-2899
20440C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
20441C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
20442C     LANGUAGE--ANSI FORTRAN (1977)
20443C     VERSION NUMBER--94/6
20444C     ORIGINAL VERSION--JUNE      1994.
20445C     UPDATED         --MAY       1995. BUGS IN DECLARATIONS
20446C     UPDATED         --SEPTEMBER 2015. SUPPORT FOR FUNCTION BLOCKS
20447C     UPDATED         --SEPTEMBER 2015. SUPPORT FOR IOPTMM (SPECIFY
20448C                                       WHETHER MINIMIZING OR
20449C                                       MAXIMIZING THE FUNCTION
20450C     UPDATED         --APRIL     2019. USER CAN SPECIFY NUMBER OF
20451C                                       DECIMAL POINTS FOR AUXILLARY
20452C                                       FILES
20453C
20454C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
20455C
20456      CHARACTER*4 ITYPEH
20457      CHARACTER*4 IW21HO
20458      CHARACTER*4 IW22HO
20459      CHARACTER*4 IA
20460      CHARACTER*4 IPARN
20461      CHARACTER*4 IPARN2
20462      CHARACTER*4 IFTEXP
20463      CHARACTER*4 IFTORD
20464      CHARACTER*4 IFORSW
20465      CHARACTER*4 IANGLU
20466      CHARACTER*4 ISUBRO
20467      CHARACTER*4 IBUGA3
20468      CHARACTER*4 IBUGCO
20469      CHARACTER*4 IBUGEV
20470      CHARACTER*4 IBUGQ
20471      CHARACTER*4 IERROR
20472      CHARACTER*4 IHP
20473      CHARACTER*4 IHP2
20474C
20475      CHARACTER*4 NEWNAM
20476      CHARACTER*4 IWD1
20477      CHARACTER*4 IWD12
20478      CHARACTER*4 IWD2
20479      CHARACTER*4 IWD22
20480      CHARACTER*4 ILAB
20481      CHARACTER*4 IKEY
20482      CHARACTER*4 IKEY2
20483      CHARACTER*4 INCLUN
20484      CHARACTER*4 IHWUSE
20485      CHARACTER*4 MESSAG
20486      CHARACTER*4 ICASUP
20487      CHARACTER*4 IERRO2
20488      CHARACTER*4 IHLEFT
20489      CHARACTER*4 IFOUN1
20490      CHARACTER*4 IFOUN2
20491      CHARACTER*4 IOLD
20492      CHARACTER*4 IOLD2
20493      CHARACTER*4 INEW
20494      CHARACTER*4 INEW2
20495      CHARACTER*4 IHPARN
20496      CHARACTER*4 IHPAR2
20497      CHARACTER*4 IHL
20498      CHARACTER*4 IHL2
20499      CHARACTER*4 IDUMV
20500      CHARACTER*4 IDUMV2
20501      CHARACTER*4 IHOUT
20502      CHARACTER*4 IHOUT2
20503      CHARACTER*4 IUOUT
20504      CHARACTER*4 IHLEF2
20505      CHARACTER*4 IFOUND
20506C
20507      CHARACTER*4 ISUBN1
20508      CHARACTER*4 ISUBN2
20509      CHARACTER*4 ISTEPN
20510      CHARACTER*4 IOPTME
20511      CHARACTER*4 IOPTHE
20512      CHARACTER*4 ICASE
20513      CHARACTER*4 IOP
20514      CHARACTER*20 IFORMT
20515C
20516C---------------------------------------------------------------------
20517C
20518      DIMENSION ITYPEH(*)
20519      DIMENSION IW21HO(*)
20520      DIMENSION IW22HO(*)
20521      DIMENSION W2HOLD(*)
20522C
20523      DIMENSION IA(*)
20524      DIMENSION PARAM(*)
20525      DIMENSION IPARN(*)
20526      DIMENSION IPARN2(*)
20527C
20528      PARAMETER (MAXOPT=100)
20529      DIMENSION IDUMV(MAXOPT)
20530      DIMENSION IDUMV2(MAXOPT)
20531C
20532      DIMENSION ILAB(10)
20533      DIMENSION IOLD(10)
20534      DIMENSION IOLD2(10)
20535      DIMENSION INEW(10)
20536      DIMENSION INEW2(10)
20537      DIMENSION VJUNK(1)
20538C
20539      INCLUDE 'DPCOPA.INC'
20540      INCLUDE 'DPCOZZ.INC'
20541      INCLUDE 'DPCOZD.INC'
20542C
20543      DOUBLE PRECISION TYPSIZ(MAXOPT)
20544      DOUBLE PRECISION XSTART(MAXOPT)
20545      DOUBLE PRECISION XPLS(MAXOPT)
20546      DOUBLE PRECISION GPLS(MAXOPT)
20547      DOUBLE PRECISION A(MAXOPT,MAXOPT)
20548      DOUBLE PRECISION WORK(MAXOPT,8)
20549      REAL XVALUE(MAXOPT)
20550C
20551      EQUIVALENCE (DGARBG(IDGAR1),A(1,1))
20552      EQUIVALENCE (DGARBG(IDGAR2),WORK(1,1))
20553      EQUIVALENCE (DGARBG(IDGAR3),TYPSIZ(1))
20554      EQUIVALENCE (DGARBG(IDGAR3+1000),XSTART(1))
20555      EQUIVALENCE (DGARBG(IDGAR3+2000),XPLS(1))
20556      EQUIVALENCE (DGARBG(IDGAR3+3000),GPLS(1))
20557      EQUIVALENCE (GARBAG(IGARB1),XVALUE(1))
20558C
20559C-----COMMON----------------------------------------------------------
20560C
20561      INCLUDE 'DPCOHK.INC'
20562      INCLUDE 'DPCODA.INC'
20563      INCLUDE 'DPCOF2.INC'
20564      INCLUDE 'DPCOFB.INC'
20565      INCLUDE 'DPCOST.INC'
20566      INCLUDE 'DPCOMC.INC'
20567C
20568C-----MAKE DUMMY COMMON BLOCK FOR MULTIVARIATE MINIMIZATION-----------
20569C
20570      PARAMETER (IOPTCH=1000)
20571      PARAMETER (IOPTC2=100)
20572C
20573      CHARACTER*4 IBUGAZ
20574      CHARACTER*4 ZTYPEH
20575      CHARACTER*4 ZW21HO
20576      CHARACTER*4 ZW22HO
20577      CHARACTER*4 ZIPARN
20578      CHARACTER*4 ZPARN2
20579      CHARACTER*4 ZMODEL
20580      CHARACTER*4 ZIDUMV
20581      CHARACTER*4 ZDUMV2
20582C
20583      DIMENSION ZMODEL(IOPTCH)
20584      DIMENSION ZTYPEH(IOPTCH)
20585      DIMENSION ZW21HO(IOPTCH)
20586      DIMENSION ZW22HO(IOPTCH)
20587      DIMENSION Z2HOLD(IOPTCH)
20588C
20589      DIMENSION ZPARAM(IOPTC2)
20590      DIMENSION ZIPARN(IOPTC2)
20591      DIMENSION ZPARN2(IOPTC2)
20592      DIMENSION ZIDUMV(IOPTC2)
20593      DIMENSION ZDUMV2(IOPTC2)
20594      DIMENSION LOCDUM(IOPTC2)
20595C
20596      COMMON /OPTCMC/ IBUGAZ, ZTYPEH, ZW21HO, ZW22HO, ZIPARN, ZPARN2,
20597     &                ZIDUMV, ZDUMV2, ZMODEL
20598      COMMON /OPTCMR/ ZPARAM, Z2HOLD,
20599     &                NUMCHZ, NUMPVZ, NWHOLZ, NUMDVZ, LOCDUM
20600CCCCC EXTERNAL OPTFCN
20601C
20602C-----COMMON VARIABLES (GENERAL)--------------------------------------
20603C
20604      INCLUDE 'DPCOP2.INC'
20605C
20606C-----START POINT-----------------------------------------------------
20607C
20608C               **************************************
20609C               **  TREAT THE OPTIMIZATION SUBCASE  **
20610C               **  OF THE LET COMMAND              **
20611C               **************************************
20612C
20613      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'POPT')THEN
20614        WRITE(ICOUT,999)
20615  999   FORMAT(1X)
20616        CALL DPWRST('XXX','BUG ')
20617        WRITE(ICOUT,51)
20618   51   FORMAT('***** AT THE BEGINNING OF DPOPT--')
20619        CALL DPWRST('XXX','BUG ')
20620        WRITE(ICOUT,53)IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO
20621   53   FORMAT('IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO = ',4(A4,2X),A4)
20622        CALL DPWRST('XXX','BUG ')
20623        WRITE(ICOUT,55)IOPTME,IOPTHE,OPTACC
20624   55   FORMAT('IOPTME,IOPTHE,OPTACC = ',2(A4,2X),G15.7)
20625        CALL DPWRST('XXX','BUG ')
20626        WRITE(ICOUT,57)IA(1),IA(2),IA(3)
20627   57   FORMAT('IA(1),IA(2),IA(3) = ',2(A4,2X),A4)
20628        CALL DPWRST('XXX','BUG ')
20629      ENDIF
20630C
20631C               **********************************
20632C               **  STEP 1--                    **
20633C               **  INITIALIZE SOME VARIABLES.  **
20634C               **********************************
20635C
20636      ISTEPN='1'
20637      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'POPT')
20638     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20639C
20640      ISUBN1='DPOP'
20641      ISUBN2='T   '
20642      IFOUND='NO'
20643      IERROR='NO'
20644      NEWNAM='NO'
20645C
20646      MAXCP1=MAXCOL+1
20647      MAXCP2=MAXCOL+2
20648      MAXCP3=MAXCOL+3
20649      MAXCP4=MAXCOL+4
20650      MAXCP5=MAXCOL+5
20651      MAXCP6=MAXCOL+6
20652      ILOCMX=0
20653      NUMLIM=0
20654      ILOC3=0
20655      MAXN2=MAXCHF
20656      MAXN3=MAXCHF
20657C
20658C               *******************************************************
20659C               **  STEP 2--                                          *
20660C               **  EXAMINE THE LEFT-HAND SIDE--                      *
20661C               **  IS THE VARIABLE NAME TO LEFT OF = SIGN            *
20662C               **  ALREADY IN THE NAME LIST?                         *
20663C               **  NOTE THAT     ILISTL    IS THE LINE IN THE TABLE  *
20664C               **  OF THE NAME ON THE LEFT.                          *
20665C               *******************************************************
20666C
20667      ISTEPN='2'
20668      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'POPT')
20669     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20670C
20671      IHLEFT=IHARG(1)
20672      IHLEF2=IHARG2(1)
20673      DO2000I=1,NUMNAM
20674        I2=I
20675        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
20676          ILISTL=I2
20677          GOTO2900
20678        ENDIF
20679 2000 CONTINUE
20680      NEWNAM='YES'
20681      ILISTL=NUMNAM+1
20682      IF(ILISTL.GT.MAXNAM)THEN
20683        WRITE(ICOUT,999)
20684        CALL DPWRST('XXX','BUG ')
20685        WRITE(ICOUT,2201)
20686 2201   FORMAT('***** ERROR IN OPTIMIZATION--')
20687        CALL DPWRST('XXX','BUG ')
20688        WRITE(ICOUT,2202)
20689 2202   FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND FUNCTION')
20690        CALL DPWRST('XXX','BUG ')
20691        WRITE(ICOUT,2203)MAXNAM
20692 2203   FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
20693        CALL DPWRST('XXX','BUG ')
20694        WRITE(ICOUT,2204)
20695 2204   FORMAT('      ENTER      STATUS')
20696        CALL DPWRST('XXX','BUG ')
20697        WRITE(ICOUT,2205)
20698 2205   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES, AND')
20699        CALL DPWRST('XXX','BUG ')
20700        WRITE(ICOUT,2206)
20701 2206   FORMAT('      THEN REDEFINE (REUSE) SOME OF THE ALREADY USED ',
20702     1         'NAMES')
20703        CALL DPWRST('XXX','BUG ')
20704        IERROR='YES'
20705        GOTO9000
20706      ENDIF
20707C
20708 2900 CONTINUE
20709C
20710C               ******************************************************
20711C               **  STEP 3.1--                                      **
20712C               **  EXTRACT THE RIGHT-SIDE FUNCTIONAL EXPRESSION    **
20713C               **  FROM THE INPUT COMMAND LINE (STARTING WITH THE  **
20714C               **  FIRST NON-BLANK LOCATION AFTER THE EQUAL SIGN   **
20715C               **  AND ENDING WITH THE END OF THE LINE OR WITH     **
20716C               **  THE LAST NON-BLANK CHARACTER BEFORE  WRT.       **
20717C               **  PLACE THE FUNCTION IN IFUNC2(.)  .              **
20718C               ******************************************************
20719C
20720      ISTEPN='3.1'
20721      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'POPT')
20722     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20723C
20724C
20725C     2015/09: CHECK TO SEE IF THE FIRST ARGUMENT ON RHS IS A FUNCTION
20726C              BLOCK NAME.
20727C
20728      IF(IHARG(4).EQ.IFBNA1(1:4) .AND. IHARG2(4).EQ.IFBNA1(5:8))THEN
20729        IFLGFB=1
20730      ELSEIF(IHARG(4).EQ.IFBNA2(1:4) .AND. IHARG2(4).EQ.IFBNA2(5:8))THEN
20731        IFLGFB=2
20732      ELSEIF(IHARG(4).EQ.IFBNA3(1:4) .AND. IHARG2(4).EQ.IFBNA3(5:8))THEN
20733        IFLGFB=3
20734      ELSE
20735        IFLGFB=0
20736      ENDIF
20737C
20738      IWD1=IHARG(3)
20739      IWD12=IHARG2(3)
20740      IWD2='WRT '
20741      IWD22='    '
20742      CALL DPEXST(IANS,IWIDTH,IWD1,IWD12,IWD2,IWD22,MAXN2,
20743     1IFUNC2,N2,IBUGA3,IFOUND,IERROR)
20744      IF(IERROR.EQ.'YES')GOTO9000
20745      IF(IFOUND.EQ.'NO')THEN
20746        IWD1=IHARG(3)
20747        IWD12=IHARG2(3)
20748        IWD2='FOR '
20749        IWD22='    '
20750        CALL DPEXST(IANS,IWIDTH,IWD1,IWD12,IWD2,IWD22,MAXN2,
20751     1              IFUNC2,N2,IBUGA3,IFOUND,IERROR)
20752        IF(IERROR.EQ.'YES')GOTO9000
20753        IF(IFOUND.EQ.'NO')THEN
20754          WRITE(ICOUT,999)
20755          CALL DPWRST('XXX','BUG ')
20756          WRITE(ICOUT,2201)
20757          CALL DPWRST('XXX','BUG ')
20758          WRITE(ICOUT,3102)
20759 3102     FORMAT('      INVALID COMMAND FORM FOR OPTIMIZATION.')
20760          CALL DPWRST('XXX','BUG ')
20761          WRITE(ICOUT,3103)
20762 3103     FORMAT('      GENERAL FORM--')
20763          CALL DPWRST('XXX','BUG ')
20764          WRITE(ICOUT,3104)
20765 3104     FORMAT('      LET ... = OPTIMIZATION ... WRT  ... ',
20766     1           'FOR ... = ... TO ...')
20767          CALL DPWRST('XXX','BUG ')
20768          WRITE(ICOUT,3105)
20769 3105     FORMAT('      THE ENTIRE COMMAND LINE WAS AS FOLLOWS--')
20770          CALL DPWRST('XXX','BUG ')
20771          IF(IWIDTH.GE.1)THEN
20772            WRITE(ICOUT,3106)(IANS(I),I=1,MIN(100,IWIDTH))
20773 3106       FORMAT('      ',100A1)
20774            CALL DPWRST('XXX','BUG ')
20775          ENDIF
20776          IERROR='YES'
20777          GOTO9000
20778        ENDIF
20779      ENDIF
20780C
20781C               *****************************************************
20782C               **  STEP 3.2--                                     **
20783C               **  DETERMINE IF THE RIGHT-HAND SIDE IS            **
20784C               **  IN FUNCTION FORM OR IS IN EQUATION FORM.       **
20785C               **  IF IN EQUATION FORM, CONVERT TO FUNCTION FORM  **
20786C               **  BY REPLACING THE EQUAL SIGN BY A MINUS SIGN    **
20787C               **  AND ENCLOSING THE REST OF THE EXPRESSION IN    **
20788C               **  PARENTHESES.                                   **
20789C               **  PLACE THE OUTPUT FUNCTION BACK IN IFUNC2(.)    **
20790C               *****************************************************
20791C
20792      ISTEPN='3.2'
20793      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'POPT')
20794     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20795C
20796      DO3600I=1,N2
20797        I2=I
20798        IF(IFUNC2(I).EQ.'=')THEN
20799          ILOCE2=I2
20800          IMIN=ILOCE2+1
20801          IF(IMIN.LE.N2)THEN
20802            DO3650II=IMIN,N2
20803              IREV=N2-II+IMIN
20804              IREVP1=IREV+1
20805              IFUNC2(IREVP1)=IFUNC2(IREV)
20806 3650       CONTINUE
20807            J=ILOCE2
20808            IFUNC2(J)='-'
20809            J=ILOCE2+1
20810            IFUNC2(J)='('
20811            J=N2+2
20812            IFUNC2(J)=')'
20813            N2=J
20814          ENDIF
20815        ENDIF
20816 3600 CONTINUE
20817C
20818C
20819C               *******************************************************
20820C               **  STEP 4--                                         **
20821C               **  DETERMINE IF THE EXPRESSION HAS ANY FUNCTION NAMES*
20822C               **  INBEDDED.  IF SO, REPLACE THE FUNCTION NAMES     **
20823C               **  BY EACH FUNCTION'S DEFINITION.  DO SO REPEATEDLY **
20824C               **  UNTIL ALL FUNCTION REFERENCES HAVE BEEN ANNIHILATED
20825C               **  AND THE EXPRESSION IS LEFT ONLY WITH             **
20826C               **  CONSTANTS, PARAMETERS, AND VARIABLES--NO FUNCTIONS.
20827C               **  PLACE THE RESULTING FUNCTIONAL EXPRESSION INTO   **
20828C               **   IFUNC3(.)                                       **
20829C               *******************************************************
20830C
20831      ISTEPN='4'
20832      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'POPT')
20833     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20834C
20835      IF(IFLGFB.LE.0)THEN
20836        CALL DPEXFU(IFUNC2,N2,IHNAME,IHNAM2,IUSE,IVSTAR,IVSTOP,
20837     1              NUMNAM,IANS,IWIDTH,IFUNC,NUMCHF,MAXCHF,IFUNC3,
20838     1              N3,MAXN3,
20839     1              IBUGA3,IERROR)
20840        IF(IERROR.EQ.'YES')GOTO9000
20841C
20842        IF(IBUGA3.EQ.'ON')THEN
20843          WRITE(ICOUT,999)
20844          CALL DPWRST('XXX','BUG ')
20845          ILAB(1)='INPU'
20846          ILAB(2)='T FU'
20847          ILAB(3)='NCTI'
20848          ILAB(4)='ON  '
20849          ILAB(5)='    '
20850          ILAB(6)='  = '
20851          NUMWDL=6
20852          CALL DPPRIF(ILAB,NUMWDL,IFUNC3,N3,IBUGA3)
20853          WRITE(ICOUT,5081)IDUMV(1),IDUMV2(1)
20854 5081     FORMAT('OPTIMIZATION VARIABLE         = ',A4,A4)
20855          CALL DPWRST('XXX','BUG ')
20856        ENDIF
20857C
20858      ENDIF
20859C
20860C               *************************************
20861C               **  STEP 5--                       **
20862C               **  EXTRACT QUALIFIER INFORMATION. **
20863C               *************************************
20864C
20865      ISTEPN='5'
20866      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'POPT')
20867     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20868C
20869C               ******************************************************
20870C               **  STEP 5.1--                                      **
20871C               **  DETERMINE THE DUMMY VARIABLE FOR THE OPTIMIZATION*
20872C               ******************************************************
20873C
20874CCCCC FEBRUARY 1995.  AT THIS STEP, CHECK FOR UNIVARIATE OR
20875CCCCC MULTIVARIATE CASE.  DO THIS BY CHECKING TO SEE IF THERE IS
20876CCCCC A "FOR" CLAUSE.  IF YES, THEN UNIVARIATE CASE.  IF NO, THEN
20877CCCCC HAVE A MULTIVARIATE CASE.
20878C
20879      ISTEPN='5.1'
20880      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'POPT')
20881     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20882C
20883      ICASE='UNIV'
20884C
20885CCCCC FOLLOWING BLOCK ADDED FEBRUARY 1995.
20886      IKEY='FOR '
20887      IKEY2='    '
20888      ISHIFT=1
20889      ILOCA=1
20890      ILOCB=NUMARG
20891      INCLUN='NO'
20892      CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB,
20893     1IHARG,IHARG2,NUMARG,
20894     1INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,IUSE,IN,NUMNAM,
20895     1IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT,IVOUT,VOUT,IUOUT,
20896     1INOUT,IBUGA3,IERROR)
20897      IBUGA3='OFF'
20898      IF(IFOUN1.EQ.'NO'.OR.IFOUN2.EQ.'NO')GOTO5300
20899C
20900CCCCC END ADDITION.
20901C
20902      IKEY='WRT '
20903      IKEY2='    '
20904      ISHIFT=1
20905      ILOCA=1
20906      ILOCB=NUMARG
20907      INCLUN='NO'
20908      CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB,
20909     1IHARG,IHARG2,NUMARG,
20910     1INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,IUSE,IN,NUMNAM,
20911     1IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT,IVOUT,VOUT,IUOUT,
20912     1INOUT,IBUGA3,IERROR)
20913      IF(IFOUN1.EQ.'NO'.OR.IFOUN2.EQ.'NO')GOTO5119
20914      IDUMV(1)=IHOUT
20915      IDUMV2(1)=IHOUT2
20916      NUMDV=1
20917      GOTO5190
20918 5119 CONTINUE
20919C
20920      IKEY='FOR '
20921      IKEY2='    '
20922      ISHIFT=1
20923      ILOCA=1
20924      ILOCB=NUMARG
20925      INCLUN='NO'
20926      CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB,
20927     1IHARG,IHARG2,NUMARG,
20928     1INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,IUSE,IN,NUMNAM,
20929     1IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT,IVOUT,VOUT,IUOUT,
20930     1INOUT,IBUGA3,IERROR)
20931      IF(IFOUN1.EQ.'NO'.OR.IFOUN2.EQ.'NO')GOTO5129
20932      IDUMV(1)=IHOUT
20933      IDUMV2(1)=IHOUT2
20934      NUMDV=1
20935      GOTO5190
20936 5129 CONTINUE
20937C
20938      WRITE(ICOUT,999)
20939      CALL DPWRST('XXX','BUG ')
20940      WRITE(ICOUT,2201)
20941      CALL DPWRST('XXX','BUG ')
20942      WRITE(ICOUT,3102)
20943      CALL DPWRST('XXX','BUG ')
20944      WRITE(ICOUT,5183)
20945 5183 FORMAT('      NO VARIABLE FOR OPTIMIZATION DEFINED.')
20946      CALL DPWRST('XXX','BUG ')
20947      WRITE(ICOUT,3103)
20948      CALL DPWRST('XXX','BUG ')
20949      WRITE(ICOUT,3104)
20950      CALL DPWRST('XXX','BUG ')
20951      WRITE(ICOUT,3105)
20952      CALL DPWRST('XXX','BUG ')
20953      IF(IWIDTH.GE.1)THEN
20954        WRITE(ICOUT,3106)(IANS(I),I=1,IWIDTH)
20955        CALL DPWRST('XXX','BUG ')
20956      ENDIF
20957      IERROR='YES'
20958      GOTO9000
20959C
20960 5190 CONTINUE
20961C
20962C               **************************************************
20963C               **  STEP 5.2--                                  **
20964C               **  DETERMINE THE LIMITS FOR THE OPTIMIZATION.  **
20965C               **************************************************
20966C
20967      ISTEPN='5.2'
20968      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'POPT')
20969     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20970C
20971      NUMLIM=0
20972C
20973      IKEY='FOR '
20974      IKEY2='    '
20975      ISHIFT=3
20976      ILOCA=1
20977      ILOCB=NUMARG
20978      INCLUN='NO'
20979      CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB,
20980     1IHARG,IHARG2,NUMARG,
20981     1INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,IUSE,IN,NUMNAM,
20982     1IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT,IVOUT,VOUT,IUOUT,
20983     1INOUT,IBUGA3,IERROR)
20984      IF(IFOUN1.EQ.'NO'.OR.IFOUN2.EQ.'NO')GOTO5219
20985      XMIN=VOUT
20986      NUMLIM=NUMLIM+1
20987 5219 CONTINUE
20988C
20989      IKEY='FOR '
20990      IKEY2='    '
20991      ISHIFT=4
20992      ILOCA=1
20993      ILOCB=NUMARG
20994      INCLUN='NO'
20995      CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB,
20996     1IHARG,IHARG2,NUMARG,
20997     1INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,IUSE,IN,NUMNAM,
20998     1IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT,IVOUT,VOUT,IUOUT,
20999     1INOUT,IBUGA3,IERROR)
21000      IF(IFOUN1.EQ.'NO'.OR.IFOUN2.EQ.'NO')GOTO5239
21001      IF(IHOUT.EQ.'TO  '.AND.IHOUT2.EQ.'    ')GOTO5229
21002      XMAX=VOUT
21003      ILOCMX=ILOC2
21004      NUMLIM=NUMLIM+1
21005 5229 CONTINUE
21006C
21007      IF(NUMLIM.EQ.2)GOTO5239
21008      IKEY='FOR '
21009      IKEY2='    '
21010      ISHIFT=5
21011      ILOCA=1
21012      ILOCB=NUMARG
21013      INCLUN='NO'
21014      CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB,
21015     1IHARG,IHARG2,NUMARG,
21016     1INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,IUSE,IN,NUMNAM,
21017     1IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT,IVOUT,VOUT,IUOUT,
21018     1INOUT,IBUGA3,IERROR)
21019      IF(IFOUN1.EQ.'NO'.OR.IFOUN2.EQ.'NO')GOTO5239
21020      XMAX=VOUT
21021      ILOCMX=ILOC2
21022      NUMLIM=NUMLIM+1
21023 5239 CONTINUE
21024C
21025      IF(NUMLIM.NE.2)THEN
21026        WRITE(ICOUT,999)
21027        CALL DPWRST('XXX','BUG ')
21028        WRITE(ICOUT,2201)
21029        CALL DPWRST('XXX','BUG ')
21030        WRITE(ICOUT,3102)
21031        CALL DPWRST('XXX','BUG ')
21032        IF(NUMLIM.EQ.0)THEN
21033          WRITE(ICOUT,5283)
21034 5283     FORMAT('      NO LIMITS FOR OPTIMIZATION DEFINED.')
21035          CALL DPWRST('XXX','BUG ')
21036        ELSEIF(NUMLIM.EQ.1)THEN
21037          WRITE(ICOUT,5284)
21038 5284     FORMAT('      ONLY ONE LIMIT FOR OPTIMIZATION DEFINED.')
21039          CALL DPWRST('XXX','BUG ')
21040        ELSE
21041          WRITE(ICOUT,5285)NUMLIM
21042 5285     FORMAT('      NUMBER OF LIMITS DEFINED = ',I8)
21043          CALL DPWRST('XXX','BUG ')
21044        ENDIF
21045        WRITE(ICOUT,3103)
21046        CALL DPWRST('XXX','BUG ')
21047        WRITE(ICOUT,3104)
21048        CALL DPWRST('XXX','BUG ')
21049        WRITE(ICOUT,3105)
21050        CALL DPWRST('XXX','BUG ')
21051        IF(IWIDTH.GE.1)THEN
21052          WRITE(ICOUT,3106)(IANS(I),I=1,MIN(100,IWIDTH))
21053          CALL DPWRST('XXX','BUG ')
21054        ENDIF
21055        IERROR='YES'
21056        GOTO9000
21057      ENDIF
21058C
21059      GOTO5999
21060C
21061C               ******************************************************
21062C               **  STEP 5.3--                                      **
21063C               **  MULTIVARIATE CASE-EXTRACT LIST OF VARIABLES     **
21064C               ******************************************************
21065C
21066 5300 CONTINUE
21067C
21068      ICASE='MULT'
21069C
21070      IKEY='WRT '
21071      IKEY2='    '
21072      ISHIFT=1
21073      ILOCA=1
21074      ILOCB=NUMARG
21075      INCLUN='NO'
21076      CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB,
21077     1IHARG,IHARG2,NUMARG,
21078     1INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,IUSE,IN,NUMNAM,
21079     1IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT,IVOUT,VOUT,IUOUT,
21080     1INOUT,IBUGA3,IERROR)
21081      IF(IFOUN1.EQ.'NO'.OR.IFOUN2.EQ.'NO')THEN
21082        WRITE(ICOUT,999)
21083        CALL DPWRST('XXX','BUG ')
21084        WRITE(ICOUT,2201)
21085        CALL DPWRST('XXX','BUG ')
21086        WRITE(ICOUT,3102)
21087        CALL DPWRST('XXX','BUG ')
21088        WRITE(ICOUT,5313)
21089 5313   FORMAT('      NO WRT CLAUSE DEFINED.')
21090        CALL DPWRST('XXX','BUG ')
21091        WRITE(ICOUT,3103)
21092        CALL DPWRST('XXX','BUG ')
21093        WRITE(ICOUT,3104)
21094        CALL DPWRST('XXX','BUG ')
21095        WRITE(ICOUT,3105)
21096        CALL DPWRST('XXX','BUG ')
21097        IF(IWIDTH.GE.1)THEN
21098          WRITE(ICOUT,5319)(IANS(I),I=1,IWIDTH)
21099 5319     FORMAT('      ',100A1)
21100          CALL DPWRST('XXX','BUG ')
21101          IERROR='YES'
21102          GOTO9000
21103        ENDIF
21104      ENDIF
21105C
21106      IF(IUOUT.EQ.'V')THEN
21107        WRITE(ICOUT,999)
21108        CALL DPWRST('XXX','BUG ')
21109        WRITE(ICOUT,2201)
21110        CALL DPWRST('XXX','BUG ')
21111        WRITE(ICOUT,5412)IHOUT,IHOUT2
21112 5412   FORMAT('      DUMMY VARIABLE ',A4,A4,' WAS PREVIOUSLY ',
21113     1         'DEFINED AS A VARIABLE RATHER THAN A PARAMETER.')
21114        CALL DPWRST('XXX','BUG ')
21115        IERROR='YES'
21116        GOTO9000
21117      ELSE
21118        IDUMV(1)=IHOUT
21119        IDUMV2(1)=IHOUT2
21120        NUMDV=1
21121        XSTART(1)=VOUT
21122      ENDIF
21123C
21124      JMIN=ILOC1
21125      NUMDV=NUMARG-JMIN
21126      IF(NUMDV.LE.1)THEN
21127        WRITE(ICOUT,999)
21128        CALL DPWRST('XXX','BUG ')
21129        WRITE(ICOUT,2201)
21130        CALL DPWRST('XXX','BUG ')
21131        WRITE(ICOUT,5512)
21132 5512   FORMAT('      NO FOR CLAUSE FOUND FOR 1-DIMENSIONAL CASE.')
21133        CALL DPWRST('XXX','BUG ')
21134        WRITE(ICOUT,3103)
21135        CALL DPWRST('XXX','BUG ')
21136        WRITE(ICOUT,3104)
21137        CALL DPWRST('XXX','BUG ')
21138        WRITE(ICOUT,3105)
21139        CALL DPWRST('XXX','BUG ')
21140        IF(IWIDTH.GE.1)THEN
21141          WRITE(ICOUT,3106)(IANS(I),I=1,MIN(100,IWIDTH))
21142          CALL DPWRST('XXX','BUG ')
21143          IERROR='YES'
21144          GOTO9000
21145        ENDIF
21146      ENDIF
21147C
21148      ICOUNT=1
21149      ILOCA=JMIN
21150      ILOCB=NUMARG
21151      DO5600J=JMIN+2,NUMARG
21152      IKEY='WRT '
21153      IKEY2='    '
21154      ICOUNT=ICOUNT+1
21155      ISHIFT=ICOUNT
21156      INCLUN='NO'
21157      CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB,
21158     1IHARG,IHARG2,NUMARG,
21159     1INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,IUSE,IN,NUMNAM,
21160     1IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT,IVOUT,VOUT,IUOUT,
21161     1INOUT,IBUGA3,IERROR)
21162      IF(IERROR.EQ.'YES')GOTO9000
21163      IF(IUOUT.EQ.'V')THEN
21164        WRITE(ICOUT,999)
21165        CALL DPWRST('XXX','BUG ')
21166        WRITE(ICOUT,2201)
21167        CALL DPWRST('XXX','BUG ')
21168        WRITE(ICOUT,5612)IHOUT,IHOUT2
21169 5612   FORMAT('      DUMMY VARIABLE ',A4,A4,' WAS PREVIOUSLY ',
21170     1         'DEFINED AS A VARIABLE RATHER THAN A PARAMETER.')
21171        CALL DPWRST('XXX','BUG ')
21172        IERROR='YES'
21173        GOTO9000
21174      ELSE
21175        IDUMV(ICOUNT)=IHOUT
21176        IDUMV2(ICOUNT)=IHOUT2
21177        XSTART(ICOUNT)=VOUT
21178      ENDIF
21179 5600 CONTINUE
21180C
21181      GOTO6390
21182C
21183 5999 CONTINUE
21184C
21185C               **********************************************
21186C               **  STEP 6.3--                              **
21187C               **  SCAN THE QUALIFIERS FOR VARIABLE,       **
21188C               **  PARAMETER, FUNCTION, AND VALUE CHANGES  **
21189C               **  IN THE FUNCTION.                        **
21190C               **********************************************
21191C
21192      ISTEPN='6.3'
21193      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'POPT')
21194     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21195C
21196      NCHANG=0
21197      DO6300IFORI=1,10
21198C
21199        IKEY='FOR '
21200        IKEY2='    '
21201        ISHIFT=1
21202        IF(IFORI.EQ.1)ILOCA=ILOCMX
21203        IF(IFORI.NE.1)ILOCA=ILOC3
21204        ILOCB=NUMARG
21205        INCLUN='NO'
21206        CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB,
21207     1              IHARG,IHARG2,NUMARG,
21208     1              INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,
21209     1              IUSE,IN,NUMNAM,
21210     1              IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT,IVOUT,
21211     1              VOUT,IUOUT,
21212     1              INOUT,IBUGA3,IERROR)
21213        IF(IERROR.EQ.'YES')GOTO6380
21214        IF(IFOUN1.EQ.'NO'.OR.IFOUN2.EQ.'NO')GOTO6350
21215C
21216        ILOC3=ILOC2+2
21217        IF(ILOC3.GT.NUMARG)GOTO6380
21218        NCHANG=NCHANG+1
21219        IOLD(NCHANG)=IHARG(ILOC2)
21220        IOLD2(NCHANG)=IHARG2(ILOC2)
21221        INEW(NCHANG)=IHARG(ILOC3)
21222        INEW2(NCHANG)=IHARG2(ILOC3)
21223C
21224 6300 CONTINUE
21225 6350 CONTINUE
21226      GOTO6390
21227C
21228 6380 CONTINUE
21229      WRITE(ICOUT,999)
21230      CALL DPWRST('XXX','BUG ')
21231      WRITE(ICOUT,2201)
21232      CALL DPWRST('XXX','BUG ')
21233      WRITE(ICOUT,3102)
21234      CALL DPWRST('XXX','BUG ')
21235      WRITE(ICOUT,3103)
21236      CALL DPWRST('XXX','BUG ')
21237      WRITE(ICOUT,3104)
21238      CALL DPWRST('XXX','BUG ')
21239      WRITE(ICOUT,3105)
21240      CALL DPWRST('XXX','BUG ')
21241      IF(IWIDTH.GE.1)THEN
21242        WRITE(ICOUT,3106)(IANS(I),I=1,MIN(100,IWIDTH))
21243        CALL DPWRST('XXX','BUG ')
21244      ENDIF
21245      IERROR='YES'
21246      GOTO9000
21247C
21248 6390 CONTINUE
21249C
21250C               **********************************************
21251C               **  STEP 6.4--                              **
21252C               **  CARRY OUT THE VARIABLE,                 **
21253C               **  PARAMETER, AND FUNCTION CHANGES         **
21254C               **  AND THEN PRINT OUT A BRIEF MESSAGE      **
21255C               **  INDICATING THAT THE CHANGES             **
21256C               **  HAVE BEEN MADE.                         **
21257C               **********************************************
21258C
21259      ISTEPN='6.4'
21260      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'POPT')
21261     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21262C
21263      IF(IPRINT.EQ.'ON' .AND. IFEEDB.EQ.'ON' .AND. NCHANG.GT.0 .AND.
21264     1   IFLGFB.LE.0)THEN
21265C
21266        WRITE(ICOUT,999)
21267        CALL DPWRST('XXX','BUG ')
21268        ILAB(1)='PRE '
21269        ILAB(2)='-CHA'
21270        ILAB(3)='NGE '
21271        ILAB(4)='FUNC'
21272        ILAB(5)='TION'
21273        ILAB(6)='  = '
21274        NUMWDL=6
21275        CALL DPPRIF(ILAB,NUMWDL,IFUNC3,N3,IBUGA3)
21276C
21277        CALL COMPIC(IFUNC3,N3,IOLD,IOLD2,INEW,INEW2,NCHANG,IFUNC3,N3,
21278     1              IBUGA3,IERROR)
21279        IF(IERROR.EQ.'YES')GOTO9000
21280C
21281        ILAB(1)='POST'
21282        ILAB(2)='-CHA'
21283        ILAB(3)='NGE '
21284        ILAB(4)='FUNC'
21285        ILAB(5)='TION'
21286        ILAB(6)='  = '
21287        NUMWDL=6
21288        CALL DPPRIF(ILAB,NUMWDL,IFUNC3,N3,IBUGA3)
21289C
21290      ENDIF
21291C
21292C               *******************************************************
21293C               **  STEP 6.7--                                       **
21294C               **  MAKE A NON-CALCULATING PASS AT THE FUNCTION      **
21295C               **  SO AS TO EXTRACT ALL PARAMETER AND VARIABLE NAMES.*
21296C               *******************************************************
21297C
21298      ISTEPN='6.8'
21299      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'POPT')
21300     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21301C
21302      IF(IFLGFB.LE.0)THEN
21303        IPASS=1
21304        CALL COMPIM(IFUNC3,N3,IPASS,PARAM,IPARN,IPARN2,NUMPV,
21305     1              IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,AJUNK,
21306     1              IBUGCO,IBUGEV,IERROR)
21307        IF(IERROR.EQ.'YES')GOTO9000
21308      ELSE
21309        GOTO7701
21310      ENDIF
21311C
21312C               ***********************************************
21313C               **  STEP 7--                                 **
21314C               **  CHECK THAT ALL PARAMETERS                **
21315C               **  IN THE FUNCTION ARE ALREADY PRESENT      **
21316C               **  IN THE AVAILABLE NAME LIST IHNAME(.).    **
21317C               **  ALSO CHECK THAT THE VARIABLE NAME        **
21318C               **  THAT FOLLOWS FOR (THAT IS, THE DUMMY     **
21319C               **  VARIABLE IS IN THE FUNCTION.             **
21320C               **  NOTE--ALL PARAMETERS AND VARIABLES       **
21321C               **  THAT ARE NOT FOUND IN IHNAME(.)          **
21322C               **  WILL BE AUTOMATICALLY SET TO 0.0         **
21323C               **  (BUT ONLY TEMPORARILY);                  **
21324C               **  THIS CONVENTION ALLOWS AN AUTOMATIC      **
21325C               **  SOLUTION TO THE PROBLEM OF OPTIMIZING    **
21326C               **  EQUATIONS (AS OPPOSED TO FUNCTIONS)      **
21327C               **  SINCE 'Y' WILL TYPICALLY BE SET TO ZERO  **
21328C               **  AS ONE WOULD WANT FOR OPTIMIZING         **
21329C               ***********************************************
21330C
21331      ISTEPN='7'
21332      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'POPT')
21333     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21334C
21335      IP=0
21336      IV=0
21337      IF(NUMPV.GT.0)THEN
21338        DO7600J=1,NUMPV
21339          IHPARN=IPARN(J)
21340          IHPAR2=IPARN2(J)
21341          DO7602JJ=1,NUMDV
21342            IF(IHPARN.EQ.IDUMV(JJ).AND.IHPAR2.EQ.IDUMV2(JJ))THEN
21343              IV=IV+1
21344              LOCDUM(IV)=J
21345              PARAM(J)=VALUE(LOCDUM(IV))
21346              GOTO7600
21347            ENDIF
21348 7602     CONTINUE
21349C
21350          IHWUSE='P'
21351          MESSAG='YES'
21352          CALL CHECKN(IHPARN,IHPAR2,IHWUSE,
21353     1                IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
21354     1                ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2)
21355          IF(IERRO2.EQ.'YES')THEN
21356            IP=IP+1
21357            PARAM(J)=0.0
21358            WRITE(ICOUT,999)
21359            CALL DPWRST('XXX','BUG ')
21360            WRITE(ICOUT,7606)IHPARN,IHPAR2
21361 7606       FORMAT('NOTE--',A4,A4,' HAS BEEN TEMPORARILY SET TO ZERO')
21362            CALL DPWRST('XXX','BUG ')
21363            WRITE(ICOUT,7607)
21364 7607       FORMAT('             FOR THE OPTIMIZATION PROCESS.')
21365            CALL DPWRST('XXX','BUG ')
21366          ELSE
21367            IP=IP+1
21368            PARAM(J)=VALUE(ILOCP)
21369          ENDIF
21370C
21371 7600   CONTINUE
21372      ENDIF
21373C
21374C               *********************************
21375C               **  STEP 8--                   **
21376C               **  DETERMINE THE OPTIMIZATION **
21377C               *********************************
21378C
21379 7701 CONTINUE
21380C
21381      ISTEPN='8'
21382      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'POPT')
21383     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21384C
21385      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'POPT')THEN
21386        WRITE(ICOUT,999)
21387        CALL DPWRST('XXX','BUG ')
21388        WRITE(ICOUT,7711)
21389 7711   FORMAT('***** FROM DPOPT, IMMEDIATELY BEFORE CALLING ',
21390     1         'OPTIMIZATION--')
21391        CALL DPWRST('XXX','BUG ')
21392        WRITE(ICOUT,7713)N3,NUMPV,NUMDV,XMIN,XMAX
21393 7713   FORMAT('N3,NUMPV,NUMDV,XMIN,XMAX = ',3I8,2E15.7)
21394        CALL DPWRST('XXX','BUG ')
21395        DO7714I=1,NUMDV
21396          WRITE(ICOUT,7715)I,IDUMV(I),IDUMV2(I)
21397 7715     FORMAT('I,IDUMV(I),IDUMV2(I) = ',I8,2X,A4,A4)
21398          CALL DPWRST('XXX','BUG ')
21399 7714   CONTINUE
21400      ENDIF
21401C
21402      IF(ICASE.EQ.'MULT')THEN
21403C
21404C  COPY OVER DUMMY COMMON BLOCKS FOR OPTFUN ROUTINE
21405C
21406        DO7803KK=1,IOPTCH
21407          ZMODEL(KK)=' '
21408          ZTYPEH(KK)=' '
21409          ZW21HO(KK)=' '
21410          ZW22HO(KK)=' '
21411 7803   CONTINUE
21412C
21413        DO7805KK=1,MAXF3
21414          ZMODEL(KK)=IFUNC3(KK)
21415 7805   CONTINUE
21416        DO7810KK=1,IOPTCH
21417          ZTYPEH(KK)=ITYPEH(KK)
21418          ZW21HO(KK)=IW21HO(KK)
21419          ZW22HO(KK)=IW22HO(KK)
21420          Z2HOLD(KK)=W2HOLD(KK)
21421 7810   CONTINUE
21422        DO7820KK=1,IOPTC2
21423          ZPARAM(KK)=PARAM(KK)
21424          ZIPARN(KK)=IPARN(KK)
21425          ZPARN2(KK)=IPARN2(KK)
21426          ZIDUMV(KK)=IDUMV(KK)
21427          ZDUMV2(KK)=IDUMV2(KK)
21428 7820   CONTINUE
21429        NUMCHZ=N3
21430        NUMPVZ=NUMPV
21431        NWHOLZ=NWHOLD
21432        NUMDVZ=NUMDV
21433        IBUGAZ=IBUGA3
21434C
21435        EPSM=R1MACH(4)
21436        IHP='OPTS'
21437        IHP2='CALE'
21438        IHWUSE='P'
21439        MESSAG='NO'
21440        CALL CHECKN(IHP,IHP2,IHWUSE,
21441     1  IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
21442     1  ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
21443        IF(IERROR.EQ.'YES')THEN
21444          FSCALE=1.0
21445        ELSE
21446          FSCALE=VALUE(ILOCP)
21447        ENDIF
21448C
21449        IHP='OPTM'
21450        IHP2='SG  '
21451        IHWUSE='P'
21452        MESSAG='NO'
21453        CALL CHECKN(IHP,IHP2,IHWUSE,
21454     1  IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
21455     1  ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
21456        IF(IERROR.EQ.'YES')THEN
21457          MSG=8
21458        ELSE
21459          MSG=INT(VALUE(ILOCP)+0.5)
21460        ENDIF
21461C
21462        IHP='OPTI'
21463        IHP2='TER '
21464        IHWUSE='P'
21465        MESSAG='NO'
21466        CALL CHECKN(IHP,IHP2,IHWUSE,
21467     1  IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
21468     1  ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
21469        IF(IERROR.EQ.'YES')THEN
21470          ITNLIM=300
21471        ELSE
21472          ITNLIM=INT(VALUE(ILOCP)+0.5)
21473        ENDIF
21474C
21475        IHP='OPTD'
21476        IHP2='LT  '
21477        IHWUSE='P'
21478        MESSAG='NO'
21479        CALL CHECKN(IHP,IHP2,IHWUSE,
21480     1  IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
21481     1  ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
21482        IF(IERROR.EQ.'YES')THEN
21483          DLT=-1.0
21484        ELSE
21485          DLT=VALUE(ILOCP)
21486        ENDIF
21487C
21488        IHP='OPTG'
21489        IHP2='RDTL'
21490        IHWUSE='P'
21491        MESSAG='NO'
21492        CALL CHECKN(IHP,IHP2,IHWUSE,
21493     1  IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
21494     1  ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
21495        IF(IERROR.EQ.'YES')THEN
21496CCCCC     GRADTL=0.0
21497          GRADTL=EPSM**(1.0/3.0)
21498        ELSE
21499          GRADTL=VALUE(ILOCP)
21500        ENDIF
21501C
21502        IHP='OPTS'
21503        IHP2='PMX '
21504        IHWUSE='P'
21505        MESSAG='NO'
21506        CALL CHECKN(IHP,IHP2,IHWUSE,
21507     1  IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
21508     1  ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
21509        IF(IERROR.EQ.'YES')THEN
21510          STEPMX=0.0
21511        ELSE
21512          STEPMX=VALUE(ILOCP)
21513        ENDIF
21514C
21515        IHP='OPTS'
21516        IHP2='TPTL'
21517        IHWUSE='P'
21518        MESSAG='NO'
21519        CALL CHECKN(IHP,IHP2,IHWUSE,
21520     1  IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
21521     1  ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
21522        IF(IERROR.EQ.'YES')THEN
21523          STEPTL=SQRT(EPSM)
21524        ELSE
21525          STEPTL=VALUE(ILOCP)
21526        ENDIF
21527C
21528        IOP='OPEN'
21529        IFLG11=1
21530        IFLG21=1
21531        IFLG31=0
21532        IFLAG4=0
21533        IFLAG5=0
21534        CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLAG4,IFLAG5,
21535     1              IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
21536     1              IBUGA3,ISUBRO,IERROR)
21537        IF(IERROR.EQ.'YES')GOTO9000
21538C
21539        CALL DPOPT3(TYPSIZ,XSTART,XPLS,GPLS,A,WORK,NUMDV,
21540     1              OPTACC,IOPTME,IOPTHE,IFLGFB,
21541     1              ITNLIM,DLT,GRADTL,STEPMX,STEPTL,FSCALE,MSG,
21542     1              FPLS,IANGLU,IFTEXP,IFTORD,IFORSW,IOPTMM,
21543     1              IPARN,IPARN2,
21544     1              ISUBRO,IBUGA3,IBUGCO,IBUGEV,IERROR)
21545        IF(IERROR.EQ.'YES')GOTO9000
21546        DO7900I=1,NUMDV
21547          XVALUE(I)=SNGL(XPLS(I))
21548 7900   CONTINUE
21549C
21550        IFORMT='(1X,E15.7)'
21551        IF(IAUXDP.NE.7)THEN
21552          IFORMT=' '
21553          IF(IAUXDP.LE.9)THEN
21554            IFORMT='(1X,Exx.x)'
21555            ITOT=IAUXDP+8
21556            WRITE(IFORMT(6:7),'(I2)')ITOT
21557            WRITE(IFORMT(9:9),'(I1)')IAUXDP
21558          ELSE
21559            IFORMT='(1X,Exx.xx)'
21560            ITOT=IAUXDP+8
21561            WRITE(IFORMT(6:7),'(I2)')ITOT
21562            WRITE(IFORMT(9:10),'(I2)')IAUXDP
21563          ENDIF
21564        ENDIF
21565C
21566        DO7910I=1,NUMDV
21567          WRITE(IOUNI1,IFORMT)SNGL(GPLS(I))
21568C7911     FORMAT(1X,E15.7)
21569 7910   CONTINUE
21570        IF(IFEEDB.EQ.'ON')THEN
21571          WRITE(ICOUT,7914)
21572 7914     FORMAT(6X,'GRADIENTS WRITTEN OUT TO FILE DPST1F.DAT')
21573          CALL DPWRST('XXX','WRIT')
21574          WRITE(ICOUT,7916)
21575 7916     FORMAT(6X,'HESSIAN MATRIX WRITTEN OUT TO FILE DPST2F.DAT')
21576          CALL DPWRST('XXX','WRIT')
21577        ENDIF
21578C
21579        IOP='CLOS'
21580        CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLAG4,IFLAG5,
21581     1              IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
21582     1              IBUGA3,ISUBRO,IERROR)
21583C
21584      ELSE
21585        CALL DPOPT2(IFUNC3,N3,PARAM,IPARN,IPARN2,NUMPV,
21586     1              ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,
21587     1              IDUMV,IDUMV2,NUMDV,XMIN,XMAX,OPTVAL,FVAL,
21588     1              OPTACC,IFLGFB,IOPTMM,
21589     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,MAXCOL,
21590     1              NUMNAM,MAXNAM,IANGLU,IFTEXP,IFTORD,IFORSW,
21591     1              PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,V,MAXN,
21592     1              ISUBRO,IBUGA3,IBUGCO,IBUGEV,IERROR)
21593      ENDIF
21594C
21595C               *****************************************
21596C               **  STEP 9--                           **
21597C               **  ENTER THE OPTIMIZED VALUE  INTO THE**
21598C               **  DATAPLOT PARAMETER TABLE.          **
21599C               **  FOR UNIVARIATE CASE, SAVE SINGLE   **
21600C               **  PARAMETER VALUE.  FOR MULTIVARIATE,**
21601C               **  SAVE INDIVIDUAL PARAMETERS AND ALSO**
21602C               **  A VARIABLE CONTAINING THESE VALUES **
21603C               *****************************************
21604C
21605      ISTEPN='9'
21606      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'POPT')
21607     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21608C
21609      IF(ICASE.EQ.'MULT')THEN
21610        NJUNK=NUMDV
21611        IHL=IHLEFT
21612        IHL2=IHLEF2
21613        ICASUP='V'
21614        CALL DPINVP(IHL,IHL2,ICASUP,XVALUE,NUMDV,FPLS,NJUNK,
21615     1  ISUBN1,ISUBN2,IBUGA3,IERROR)
21616        IHL='OPTV'
21617        IHL2='ALUE'
21618        ICASUP='P'
21619        VJUNK(1)=REAL(XPLS(1))
21620        CALL DPINVP(IHL,IHL2,ICASUP,VJUNK,NUMDV,FPLS,NJUNK,
21621     1  ISUBN1,ISUBN2,IBUGA3,IERROR)
21622        DO8000I=1,NUMDV
21623          IHL=IDUMV(I)
21624          IHL2=IDUMV2(I)
21625          ICASUP='P'
21626          VALTMP=REAL(XPLS(I))
21627          VJUNK(1)=VALTMP
21628          CALL DPINVP(IHL,IHL2,ICASUP,VJUNK,NUMDV,VALTMP,NJUNK,
21629     1    ISUBN1,ISUBN2,IBUGA3,IERROR)
21630 8000   CONTINUE
21631C
21632      ELSE
21633        IHL=IHLEFT
21634        IHL2=IHLEF2
21635        ICASUP='P'
21636        NJUNK=1
21637        VJUNK(1)=OPTVAL
21638        CALL DPINVP(IHL,IHL2,ICASUP,VJUNK,NJUNK,OPTVAL,NJUNK,
21639     1              ISUBN1,ISUBN2,IBUGA3,IERROR)
21640        IHL='FVAL'
21641        IHL2='UE  '
21642        ICASUP='P'
21643        NJUNK=1
21644        VJUNK(1)=FVAL
21645        CALL DPINVP(IHL,IHL2,ICASUP,VJUNK,NJUNK,FVAL,NJUNK,
21646     1              ISUBN1,ISUBN2,IBUGA3,IERROR)
21647      ENDIF
21648C
21649C               ****************
21650C               **  STEP 90-- **
21651C               **  EXIT      **
21652C               ****************
21653C
21654 9000 CONTINUE
21655      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'POPT')THEN
21656        WRITE(ICOUT,999)
21657        CALL DPWRST('XXX','BUG ')
21658        WRITE(ICOUT,9011)
21659 9011   FORMAT('***** AT THE END OF DPOPT--')
21660        CALL DPWRST('XXX','BUG ')
21661        DO9015I=1,NUMNAM
21662          WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),
21663     1                     IVSTAR(I),IVSTOP(I)
21664 9016     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),IVSTOP(I)=',
21665     1           I8,2X,2A4,2X,A4,2I8)
21666          CALL DPWRST('XXX','BUG ')
21667 9015   CONTINUE
21668        WRITE(ICOUT,9017)NUMCHF,MAXCHF,IWIDTH,N2,N3,NUMPV
21669 9017   FORMAT('NUMCHF,MAXCHF,IWIDTH,N2,N3,NUMPV = ',6I8)
21670        CALL DPWRST('XXX','BUG ')
21671        WRITE(ICOUT,9018)(IFUNC(I),I=1,MIN(115,IWIDTH))
21672 9018   FORMAT('IFUNC(.) = ',115A1)
21673        CALL DPWRST('XXX','BUG ')
21674        WRITE(ICOUT,9019)(IFUNC2(I),I=1,MIN(115,N2))
21675 9019   FORMAT('IFUNC2(.) = ',115A1)
21676        CALL DPWRST('XXX','BUG ')
21677        WRITE(ICOUT,9021)(IFUNC3(I),I=1,MIN(120,N3))
21678 9021   FORMAT('IFUNC3(.) = ',120A1)
21679        CALL DPWRST('XXX','BUG ')
21680        WRITE(ICOUT,9023)IHLEFT,IHLEF2
21681 9023   FORMAT('IHLEFT, IHLEF2 = ',A4,A4)
21682        CALL DPWRST('XXX','BUG ')
21683        DO9120I=1,NUMDV
21684          WRITE(ICOUT,9123)I,IDUMV(I),IDUMV2(I)
21685 9123     FORMAT('I,IDUMV(I),IDUMV2(I) = ',I3,2X,A4,A4)
21686          CALL DPWRST('XXX','BUG ')
21687 9120   CONTINUE
21688        WRITE(ICOUT,9024)ICASUP,IFOUND,IERROR
21689 9024   FORMAT('ICASUP,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
21690        CALL DPWRST('XXX','BUG ')
21691        WRITE(ICOUT,9025)XMIN,XMAX
21692 9025   FORMAT('XMIN,XMAX = ',2E15.7)
21693        CALL DPWRST('XXX','BUG ')
21694      ENDIF
21695C
21696      RETURN
21697      END
21698      SUBROUTINE DPOPT2(MODEL,NUMCHA,PARAM,IPARN,IPARN2,NUMPV,
21699     1                  ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,
21700     1                  IVARN,IVARN2,NUMVAR,XMIN,XMAX,FMIN,FVAL,
21701     1                  OPTACC,IFLGFB,IOPTMM,
21702     1                  IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,MAXCOL,
21703     1                  NUMNAM,MAXNAM,IANGLU,IFTEXP,IFTORD,IFORSW,
21704     1                  PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,VTEMP,MAXN,
21705     1                  ISUBRO,IBUGA3,IBUGCO,IBUGEV,IERROR)
21706C
21707C     PURPOSE--COMPUTE THE MINIMUM OF A FUNCTION
21708C              BETWEEN THE LIMITS XMIN AND XMAX.
21709C     WRITTEN BY--ALAN HECKERT
21710C                 STATISTICAL ENGINEERING DIVISION
21711C                 INFORMATION TECHNOLOGY LABORATORY
21712C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
21713C                 GAITHERSBURG, MD 20899-8980
21714C                 PHONE--301-975-2899
21715C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
21716C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
21717C     NOTE--THIS ROUTINE USES THE FMIN ALGORITHM FOR THE BOOK
21718C           "NUMERICAL METHODS AND SOFTWARE" BY KAHANER, MOLER, NASH.
21719C           THE CODE IS "ILINED" INTO THIS ROUTINE RATHER THAN BEING
21720C           CALLED AS A SEPARATE FUNCTION.  THE FOLLOWING IS THE
21721C           PROLOGUE OF THE FMIN ROUTINE, WHICH DOCUMENTS THE METHOD.
21722C
21723C***BEGIN PROLOGUE  FMIN
21724C***DATE WRITTEN   730101  (YYMMDD)
21725C***REVISION DATE  730101  (YYMMDD)
21726C***CATEGORY NO.  G1A2
21727C***KEYWORDS  ONE-DIMENSIONAL MINIMIZATION, UNIMODAL FUNCTION
21728C***AUTHOR  BRENT, R.
21729C***PURPOSE  An approximation to the point where F attains a minimum on
21730C            the interval (AX,BX) is determined as the value of the
21731C            function FMIN.
21732C***DESCRIPTION
21733C
21734C     From the book, "Numerical Methods and Software" by
21735C                D. Kahaner, C. Moler, S. Nash
21736C                Prentice Hall, 1988
21737C
21738C     The method used is a combination of golden section search and
21739C     successive parabolic interpolation.  Convergence is never much
21740C     slower than that for a Fibonacci search.  If F has a continuous
21741C     second derivative which is positive at the minimum (which is not
21742C     at AX or BX), then convergence is superlinear, and usually of the
21743C     order of about 1.324....
21744C
21745C     The function F is never evaluated at two points closer together
21746C     than EPS*ABS(FMIN) + (TOL/3), where EPS is approximately the
21747C     square root of the relative machine precision.  If F is a unimodal
21748C     function and the computed values of F are always unimodal when
21749C     separated by at least EPS*ABS(XSTAR) + (TOL/3), then FMIN
21750C     approximates the abcissa of the global minimum of F on the
21751C     interval AX,BX with an error less than 3*EPS*ABS(FMIN) + TOL.
21752C     If F is not unimodal, then FMIN may approximate a local, but
21753C     perhaps non-global, minimum to the same accuracy.
21754C
21755C     This function subprogram is a slightly modified version of the
21756C     ALGOL 60 procedure LOCALMIN given in Richard Brent, Algorithms for
21757C     Minimization Without Derivatives, Prentice-Hall, Inc. (1973).
21758C
21759C INPUT PARAMETERS
21760C
21761C  AX    (real)  left endpoint of initial interval
21762C  BX    (real) right endpoint of initial interval
21763C  F     Real function of the form REAL FUNCTION F(X) which evaluates
21764C          F(X)  for any  X in the interval  (AX,BX)
21765C        Must be declared EXTERNAL in calling routine.
21766C  TOL   (real) desired length of the interval of uncertainty of the
21767C        final result ( .ge. 0.0)
21768C
21769C
21770C OUTPUT PARAMETERS
21771C
21772C FMIN   abcissa approximating the minimizer of F
21773C AX     lower bound for minimizer
21774C BX     upper bound for minimizer
21775C
21776C***REFERENCES  RICHARD BRENT, ALGORITHMS FOR MINIMIZATION WITHOUT
21777C                 DERIVATIVES, PRENTICE-HALL, INC. (1973).
21778C***ROUTINES CALLED  (NONE)
21779C***END PROLOGUE  FMIN
21780      REAL  TOL
21781      REAL  A,B,C,D,E,EPS,XM,P,Q,R,TOL1,TOL2,U,V,W
21782      REAL  FU,FV,FW,FX,X
21783      REAL  ABS,SQRT,SIGN
21784C
21785C     LANGUAGE--ANSI FORTRAN (1977)
21786C     VERSION NUMBER--94/6
21787C     ORIGINAL VERSION--JUNE      1994.
21788C
21789C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
21790C
21791      CHARACTER*4 MODEL
21792      CHARACTER*4 IPARN
21793      CHARACTER*4 IPARN2
21794      CHARACTER*4 ITYPEH
21795      CHARACTER*4 IW21HO
21796      CHARACTER*4 IW22HO
21797      CHARACTER*4 IVARN
21798      CHARACTER*4 IVARN2
21799      CHARACTER*4 IOPTMM
21800      CHARACTER*4 IANGLU
21801      CHARACTER*4 IFTEXP
21802      CHARACTER*4 IFTORD
21803      CHARACTER*4 IFORSW
21804      CHARACTER*4 IBUGA3
21805      CHARACTER*4 IBUGCO
21806      CHARACTER*4 IBUGEV
21807      CHARACTER*4 IERROR
21808C
21809      CHARACTER*4 ILAB
21810      CHARACTER*4 IH
21811      CHARACTER*4 IH2
21812C
21813      CHARACTER*4 ISUBN1
21814      CHARACTER*4 ISUBN2
21815      CHARACTER*4 ISTEPN
21816CCCCC OCTOBER 1994.  ADD FOLLOWING LINE
21817      CHARACTER*4 ISUBRO
21818      CHARACTER*4 IFOUND
21819C
21820C---------------------------------------------------------------------
21821C
21822      DIMENSION MODEL(*)
21823      DIMENSION PARAM(*)
21824      DIMENSION IPARN(*)
21825      DIMENSION IPARN2(*)
21826      DIMENSION IVARN(*)
21827      DIMENSION IVARN2(*)
21828C
21829      DIMENSION ITYPEH(*)
21830      DIMENSION IW21HO(*)
21831      DIMENSION IW22HO(*)
21832      DIMENSION W2HOLD(*)
21833C
21834      DIMENSION PRED(*)
21835      DIMENSION RES(*)
21836      DIMENSION XPLOT(*)
21837      DIMENSION YPLOT(*)
21838      DIMENSION X2PLOT(*)
21839      DIMENSION TAGPLO(*)
21840      DIMENSION VTEMP(*)
21841C
21842      DIMENSION IN(*)
21843      DIMENSION IVALUE(*)
21844      DIMENSION VALUE(*)
21845C
21846      CHARACTER*4 IHNAME(*)
21847      CHARACTER*4 IHNAM2(*)
21848      CHARACTER*4 IUSE(*)
21849C
21850      DIMENSION ILOCV(10)
21851      DIMENSION ILAB(10)
21852C
21853C     2015/08: FUNCTION BLOCK
21854C
21855      INCLUDE 'DPCOFB.INC'
21856C
21857      CHARACTER*8 IFBNAM
21858      CHARACTER*8 IFBANS
21859C
21860      CHARACTER*4 IFEESV
21861      COMMON/IFEED/IFEESV
21862C
21863C---------------------------------------------------------------------
21864C
21865      INCLUDE 'DPCOP2.INC'
21866C
21867C-----START POINT-----------------------------------------------------
21868C
21869      ISUBN1='DPOP'
21870      ISUBN2='T2  '
21871      IERROR='NO'
21872      IFOUND='NO'
21873C
21874      J2=0
21875      IPASS=2
21876      MAXCP1=MAXCOL+1
21877      MAXCP2=MAXCOL+2
21878      MAXCP3=MAXCOL+3
21879      MAXCP4=MAXCOL+4
21880      MAXCP5=MAXCOL+5
21881      MAXCP6=MAXCOL+6
21882C
21883      D=0.0
21884      E=0.0
21885      P=0.0
21886      Q=0.0
21887      R=0.0
21888C
21889      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'OPT2')THEN
21890        WRITE(ICOUT,999)
21891  999   FORMAT(1X)
21892        CALL DPWRST('XXX','BUG ')
21893        WRITE(ICOUT,51)
21894   51   FORMAT('AT THE BEGINNING OF DPOPT2--')
21895        CALL DPWRST('XXX','BUG ')
21896        WRITE(ICOUT,52)IBUGA3,IBUGCO,IBUGEV,ISUBRO
21897   52   FORMAT('IBUGA3,IBUGCO,IBUGEV,ISUBRO = ',3(A4,2X),A4)
21898        CALL DPWRST('XXX','BUG ')
21899        WRITE(ICOUT,53)NUMCHA,NUMPV,NUMVAR,IFLGFB
21900   53   FORMAT('NUMCHA,NUMPV,NUMVAR,IFLGFB = ',4I8)
21901        CALL DPWRST('XXX','BUG ')
21902        IF(IFLGFB.LE.0)THEN
21903          WRITE(ICOUT,54)(MODEL(J),J=1,MIN(100,NUMCHA))
21904   54     FORMAT('MODEL(I) = ',100A1)
21905          CALL DPWRST('XXX','BUG ')
21906          DO55I=1,NUMPV
21907            WRITE(ICOUT,56)I,PARAM(I),IPARN(I),IPARN2(I)
21908   56       FORMAT('I,PARAM(I),IPARN(I),IPARN2(I) = ',I8,G15.7,A4,A4)
21909            CALL DPWRST('XXX','BUG ')
21910   55     CONTINUE
21911          DO59I=1,NUMVAR
21912            WRITE(ICOUT,61)I,IVARN(I),IVARN2(I)
21913   61       FORMAT('I, IVARN(I),IVARN2(I) = ',I8,2X,A4,A4)
21914            CALL DPWRST('XXX','BUG ')
21915   59     CONTINUE
21916        ENDIF
21917        WRITE(ICOUT,62)XMIN,XMAX,NUMNAM
21918   62   FORMAT('XMIN,XMAX,NUMNAM = ',2G15.7,I8)
21919        CALL DPWRST('XXX','BUG ')
21920        DO67I=1,NUMNAM
21921          WRITE(ICOUT,68)I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),IVALUE(I),
21922     1                   VALUE(I)
21923   68     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),IVALUE(I)',
21924     1           'VALUE(I) = ',I8,2X,A4,A4,2X,A4,2I8,G15.7)
21925          CALL DPWRST('XXX','BUG ')
21926   67   CONTINUE
21927      ENDIF
21928C
21929C               ***************************************************
21930C               **  STEP 1--                                     **
21931C               **  DETERMINE THE LOCATIONS (IN THE LIST IPARN)  **
21932C               **  OF THE VARIABLES OF THE FUNCTION.            **
21933C               ***************************************************
21934C
21935      ISTEPN='1'
21936      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'OPT2')
21937     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21938C
21939      IFBNAM=' '
21940      IFBANS=' '
21941C
21942      IF(IFLGFB.LE.0)THEN
21943        DO100I=1,NUMVAR
21944          IH=IVARN(I)
21945          IH2=IVARN2(I)
21946          DO200J=1,NUMPV
21947            J2=J
21948            IF(IPARN(J).EQ.IH.AND.IPARN2(J).EQ.IH2)GOTO210
21949  200     CONTINUE
21950  210     CONTINUE
21951          ILOCV(I)=J2
21952  100   CONTINUE
21953      ELSE
21954        IF(IFLGFB.EQ.1)THEN
21955          IFBNAM=IFBNA1
21956          IFBANS=IFBAN1
21957          IH=IFBPL1(1)(1:4)
21958          IH2=IFBPL1(1)(5:8)
21959        ELSEIF(IFLGFB.EQ.2)THEN
21960          IFBNAM=IFBNA2
21961          IFBANS=IFBAN2
21962          IH=IFBPL2(1)(1:4)
21963          IH2=IFBPL2(1)(5:8)
21964        ELSEIF(IFLGFB.EQ.3)THEN
21965          IFBNAM=IFBNA3
21966          IFBANS=IFBAN3
21967          IH=IFBPL3(1)(1:4)
21968          IH2=IFBPL3(1)(5:8)
21969        ENDIF
21970      ENDIF
21971C
21972C               *************************************************
21973C               **  STEP 2--                                   **
21974C               **  WRITE OUT PRELIMINARY SUMMARY INFORMATION  **
21975C               *************************************************
21976C
21977      ISTEPN='2'
21978      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'OPT2')
21979     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21980C
21981      IF(IPRINT.EQ.'ON' .AND. IFEEDB.EQ.'ON')THEN
21982        WRITE(ICOUT,999)
21983        CALL DPWRST('XXX','BUG ')
21984        WRITE(ICOUT,401)
21985  401   FORMAT('MINIMUM OF A FUNCTION')
21986        CALL DPWRST('XXX','BUG ')
21987        IF(IFLGFB.LE.0)THEN
21988          ILAB(1)='    '
21989          ILAB(2)='  FU'
21990          ILAB(3)='NCTI'
21991          ILAB(4)='ON--'
21992          NUMWDL=4
21993          CALL DPPRIF(ILAB,NUMWDL,MODEL,NUMCHA,IBUGA3)
21994        ENDIF
21995C
21996        WRITE(ICOUT,402)IVARN(1),IVARN2(1)
21997  402   FORMAT('      OPTIMIZATION VARIABLE             = ',A4,A4)
21998        CALL DPWRST('XXX','BUG ')
21999C
22000        WRITE(ICOUT,403)XMIN
22001  403   FORMAT('      SPECIFIED LOWER LIMIT OF INTERVAL = ',F20.10)
22002        CALL DPWRST('XXX','BUG ')
22003        WRITE(ICOUT,404)XMAX
22004  404   FORMAT('      SPECIFIED UPPER LIMIT OF INTERVAL = ',F20.10)
22005        CALL DPWRST('XXX','BUG ')
22006      ENDIF
22007C
22008C               ***************************
22009C               **  STEP 3--             **
22010C               **  FMIN CODE TO FIND    **
22011C               **  THE MINIMUM          **
22012C               ***************************
22013C
22014      ISTEPN='3'
22015      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'OPT2')
22016     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22017C
22018      IF(OPTACC.GT.0.0)THEN
22019        TOL = OPTACC
22020      ELSE
22021        TOL = 1.0E-5
22022      ENDIF
22023      C = 0.5*(3. - SQRT(5.0))
22024C
22025C  C is the squared inverse of the golden ratio
22026C
22027C  EPS is approximately the square root of the relative machine
22028C  precision.
22029C
22030      EPS = 1.0
22031   10 EPS = EPS/2.0
22032      TOL1 = 1.0 + EPS
22033      IF (TOL1 .GT. 1.0) GO TO 10
22034      EPS = SQRT(EPS)
22035C
22036C  initialization
22037C
22038CCCCC A = AX
22039CCCCC B = BX
22040      A = AMIN1(XMIN,XMAX)
22041      B = AMAX1(XMIN,XMAX)
22042      V = A + C*(B - A)
22043      W = V
22044      X = V
22045      E = 0.0
22046CCCCC FX = F(X)
22047C
22048C
22049      IF(IFLGFB.LE.0)THEN
22050        DO9100K=1,NUMVAR
22051          JLOC=ILOCV(K)
22052          PARAM(JLOC)=X
22053 9100   CONTINUE
22054        CALL COMPIM(MODEL,NUMCHA,IPASS,PARAM,IPARN,IPARN2,NUMPV,
22055     1              IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,FX,
22056     1              IBUGCO,IBUGEV,IERROR)
22057        IF(IOPTMM.EQ.'MAXI')FX=-FX
22058      ELSE
22059C
22060C         FUNCTION BLOCK CASE:
22061C
22062C            STEP 1: COMPUTE FUNCTION BLOCK (BUT FIRST SET CURRENT
22063C                    VALUE OF DESIRED PARAMETER)
22064C
22065          DO1105II=1,NUMNAM
22066            IF(IH.EQ.IHNAME(II) .AND. IH2.EQ.IHNAM2(II) .AND.
22067     1         IUSE(II).EQ.'P')THEN
22068              VALUE(II)=X
22069              IVALUE(II)=INT(X+0.5)
22070              GOTO1109
22071            ENDIF
22072 1105     CONTINUE
22073C
22074C         PARAMETER NAME NOT FOUND IN CURRENT LIST, SO NEED TO ADD
22075C         TO NAME LIST
22076C
22077          IF(NUMNAM.LT.MAXNAM)THEN
22078            NUMNAM=NUMNAM+1
22079            IHNAME(NUMNAM)=IH
22080            IHNAM2(NUMNAM)=IH2
22081            IUSE(NUMNAM)='P'
22082            VALUE(NUMNAM)=X
22083            IVALUE(NUMNAM)=INT(X + 0.5)
22084          ELSE
22085            WRITE(ICOUT,999)
22086            CALL DPWRST('XXX','BUG ')
22087            WRITE(ICOUT,1106)
22088 1106       FORMAT('***** ERROR IN UNIVARIATE OPTIMATION--')
22089            CALL DPWRST('XXX','BUG ')
22090            WRITE(ICOUT,1107)
22091 1107       FORMAT('      THE MAXIMUM NUMBER OF NAMES EXCEEDED.')
22092            CALL DPWRST('XXX','BUG ')
22093          ENDIF
22094C
22095 1109     CONTINUE
22096C
22097          IFEEDB='OFF'
22098          CALL DPFBEX(IFBNAM,IANGLU,ISEED,IFTEXP,IFTORD,IFORSW,
22099     1                IBUGA3,IBUGA3,IBUGCO,IBUGEV,IBUGEV,
22100     1                ISUBRO,IFOUND,IERROR)
22101          IFEEDB=IFEESV
22102          IF(IERROR.EQ.'YES')GOTO9000
22103C
22104C            STEP 2: RETRIEVE RESPONSE
22105C
22106          DO1120II=1,NUMNAM
22107            IF(IFBANS(1:4).EQ.IHNAME(II) .AND.
22108     1         IFBANS(5:8).EQ.IHNAM2(II))THEN
22109              IF(IUSE(II).EQ.'P')THEN
22110                FX=VALUE(II)
22111                GOTO1129
22112              ELSEIF(IUSE(II).EQ.'V')THEN
22113                ICOLR=IVALUE(II)
22114                IJ=MAXN*(ICOLR-1)+1
22115                IF(ICOLR.LE.MAXCOL)FX=VTEMP(IJ)
22116                IF(ICOLR.EQ.MAXCP1)FX=PRED(1)
22117                IF(ICOLR.EQ.MAXCP2)FX=RES(1)
22118                IF(ICOLR.EQ.MAXCP3)FX=YPLOT(1)
22119                IF(ICOLR.EQ.MAXCP4)FX=XPLOT(1)
22120                IF(ICOLR.EQ.MAXCP5)FX=X2PLOT(1)
22121                IF(ICOLR.EQ.MAXCP6)FX=TAGPLO(1)
22122                GOTO1129
22123              ENDIF
22124            ENDIF
22125 1120     CONTINUE
22126C
22127C         PARAMETER/VARIABLE NAME NOT FOUND
22128C
22129          WRITE(ICOUT,1106)
22130          CALL DPWRST('XXX','BUG ')
22131          WRITE(ICOUT,1121)
22132 1121     FORMAT('      EXPECTED PARAMETER/VARIABLE NOT FOUND IN NAME ',
22133     1           'TABLE.')
22134          CALL DPWRST('XXX','BUG ')
22135          WRITE(ICOUT,1123)IFBANS
22136 1123     FORMAT('      EXPECTED NAME = ',A8)
22137          CALL DPWRST('XXX','BUG ')
22138C
22139 1129     CONTINUE
22140          IF(IOPTMM.EQ.'MAXI')FX=-FX
22141C
22142      ENDIF
22143C
22144      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'OPT2')THEN
22145        WRITE(ICOUT,9103)X,FX
22146 9103   FORMAT('X,FX = ',2G15.7)
22147        CALL DPWRST('XXX','BUG ')
22148      ENDIF
22149C
22150      FV = FX
22151      FW = FX
22152C
22153C  main loop starts here
22154C
22155   20 XM = 0.5*(A + B)
22156      TOL1 = EPS*ABS(X) + TOL/3.0
22157      TOL2 = 2.0*TOL1
22158C
22159C  check stopping criterion
22160C
22161      IF (ABS(X - XM) .LE. (TOL2 - 0.5*(B - A))) GO TO 90
22162C
22163C is golden-section necessary
22164C
22165      IF (ABS(E) .LE. TOL1) GO TO 40
22166C
22167C  fit parabola
22168C
22169      R = (X - W)*(FX - FV)
22170      Q = (X - V)*(FX - FW)
22171      P = (X - V)*Q - (X - W)*R
22172      Q = 2.0*(Q - R)
22173      IF (Q .GT. 0.0) P = -P
22174      Q = ABS(Q)
22175      R = E
22176      E = D
22177C
22178C  is parabola acceptable
22179C
22180      IF (ABS(P) .GE. ABS(0.5*Q*R)) GO TO 40
22181      IF (P .LE. Q*(A - X)) GO TO 40
22182      IF (P .GE. Q*(B - X)) GO TO 40
22183C
22184C  a parabolic interpolation step
22185C
22186      D = P/Q
22187      U = X + D
22188C
22189C  F must not be evaluated too close to AX or BX
22190C
22191      IF ((U - A) .LT. TOL2) D = SIGN(TOL1, XM - X)
22192      IF ((B - U) .LT. TOL2) D = SIGN(TOL1, XM - X)
22193      GO TO 50
22194C
22195C  a golden-section step
22196C
22197   40 IF (X .GE. XM) E = A - X
22198      IF (X .LT. XM) E = B - X
22199      D = C*E
22200C
22201C  F must not be evaluated too close to X
22202C
22203   50 IF (ABS(D) .GE. TOL1) U = X + D
22204      IF (ABS(D) .LT. TOL1) U = X + SIGN(TOL1, D)
22205CCCCC FU = F(U)
22206C
22207      IF(IFLGFB.LE.0)THEN
22208        DO9200K=1,NUMVAR
22209          JLOC=ILOCV(K)
22210          PARAM(JLOC)=U
22211 9200   CONTINUE
22212        CALL COMPIM(MODEL,NUMCHA,IPASS,PARAM,IPARN,IPARN2,NUMPV,
22213     1              IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,FU,
22214     1              IBUGCO,IBUGEV,IERROR)
22215        IF(IOPTMM.EQ.'MAXI')FU=-FU
22216      ELSE
22217C
22218C       FUNCTION BLOCK CASE:
22219C
22220C       STEP 1: COMPUTE FUNCTION BLOCK (BUT FIRST SET CURRENT
22221C               VALUE OF DESIRED PARAMETER)
22222C
22223        DO1205II=1,NUMNAM
22224          IF(IH.EQ.IHNAME(II) .AND. IH2.EQ.IHNAM2(II) .AND.
22225     1       IUSE(II).EQ.'P')THEN
22226            VALUE(II)=U
22227            IVALUE(II)=INT(U+0.5)
22228            GOTO1209
22229          ENDIF
22230 1205   CONTINUE
22231C
22232C       PARAMETER NAME NOT FOUND IN CURRENT LIST, SO NEED TO ADD
22233C       TO NAME LIST
22234C
22235        IF(NUMNAM.LT.MAXNAM)THEN
22236          NUMNAM=NUMNAM+1
22237          IHNAME(NUMNAM)=IH
22238          IHNAM2(NUMNAM)=IH2
22239          IUSE(NUMNAM)='P'
22240          VALUE(NUMNAM)=U
22241          IVALUE(NUMNAM)=INT(U+0.5)
22242        ELSE
22243          WRITE(ICOUT,999)
22244          CALL DPWRST('XXX','BUG ')
22245          WRITE(ICOUT,1106)
22246          CALL DPWRST('XXX','BUG ')
22247          WRITE(ICOUT,1107)
22248          CALL DPWRST('XXX','BUG ')
22249        ENDIF
22250C
22251 1209   CONTINUE
22252C
22253        IFEEDB='OFF'
22254        CALL DPFBEX(IFBNAM,IANGLU,ISEED,IFTEXP,IFTORD,IFORSW,
22255     1              IBUGA3,IBUGA3,IBUGCO,IBUGEV,IBUGEV,
22256     1              ISUBRO,IFOUND,IERROR)
22257        IFEEDB=IFEESV
22258        IF(IERROR.EQ.'YES')GOTO9000
22259C
22260C       STEP 2: RETRIEVE RESPONSE
22261C
22262        DO1220II=1,NUMNAM
22263          IF(IFBANS(1:4).EQ.IHNAME(II) .AND.
22264     1       IFBANS(5:8).EQ.IHNAM2(II))THEN
22265            IF(IUSE(II).EQ.'P')THEN
22266              FU=VALUE(II)
22267              GOTO1229
22268            ELSEIF(IUSE(II).EQ.'V')THEN
22269              ICOLR=IVALUE(II)
22270              IJ=MAXN*(ICOLR-1)+1
22271              IF(ICOLR.LE.MAXCOL)FU=VTEMP(IJ)
22272              IF(ICOLR.EQ.MAXCP1)FU=PRED(1)
22273              IF(ICOLR.EQ.MAXCP2)FU=RES(1)
22274              IF(ICOLR.EQ.MAXCP3)FU=YPLOT(1)
22275              IF(ICOLR.EQ.MAXCP4)FU=XPLOT(1)
22276              IF(ICOLR.EQ.MAXCP5)FU=X2PLOT(1)
22277              IF(ICOLR.EQ.MAXCP6)FU=TAGPLO(1)
22278              GOTO1229
22279            ENDIF
22280          ENDIF
22281 1220   CONTINUE
22282C
22283C       PARAMETER/VARIABLE NAME NOT FOUND
22284C
22285        WRITE(ICOUT,1106)
22286        CALL DPWRST('XXX','BUG ')
22287        WRITE(ICOUT,1121)
22288        CALL DPWRST('XXX','BUG ')
22289        WRITE(ICOUT,1123)IFBANS
22290        CALL DPWRST('XXX','BUG ')
22291C
22292 1229   CONTINUE
22293        IF(IOPTMM.EQ.'MAXI')FU=-FU
22294C
22295      ENDIF
22296C
22297      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'OPT2')THEN
22298        WRITE(ICOUT,9203)U,FU
22299 9203   FORMAT('U,FU = ',2G15.7)
22300        CALL DPWRST('XXX','BUG ')
22301      ENDIF
22302C
22303C  update  A, B, V, W, and X
22304C
22305      IF (FU .GT. FX) GO TO 60
22306      IF (U .GE. X) A = X
22307      IF (U .LT. X) B = X
22308      V = W
22309      FV = FW
22310      W = X
22311      FW = FX
22312      X = U
22313      FX = FU
22314      GO TO 20
22315   60 IF (U .LT. X) A = U
22316      IF (U .GE. X) B = U
22317      IF (FU .LE. FW) GO TO 70
22318      IF (W .EQ. X) GO TO 70
22319      IF (FU .LE. FV) GO TO 80
22320      IF (V .EQ. X) GO TO 80
22321      IF (V .EQ. W) GO TO 80
22322      GO TO 20
22323   70 V = W
22324      FV = FW
22325      W = U
22326      FW = FU
22327      GO TO 20
22328   80 V = U
22329      FV = FU
22330      GO TO 20
22331C
22332C  end of main loop
22333C
22334   90 CONTINUE
22335      FMIN = X
22336      FVAL = FX
22337C
22338C               ***************************
22339C               **  STEP 5--             **
22340C               **  WRITE OUT THE MINIMUM**
22341C               ***************************
22342C
22343      ISTEPN='5'
22344      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'OPT2')
22345     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22346C
22347      IF(IPRINT.EQ.'ON' .AND. IFEEDB.EQ.'ON')THEN
22348        WRITE(ICOUT,999)
22349        CALL DPWRST('XXX','BUG ')
22350        WRITE(ICOUT,1405)FMIN
22351 1405   FORMAT('      THE MINIMUM VALUE OCCURS AT = ',E15.7)
22352        CALL DPWRST('XXX','BUG ')
22353        WRITE(ICOUT,999)
22354        CALL DPWRST('XXX','BUG ')
22355      ENDIF
22356C
22357C               *****************
22358C               **  STEP 90--  **
22359C               **  EXIT       **
22360C               *****************
22361C
22362 9000 CONTINUE
22363      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'OPT2')THEN
22364        WRITE(ICOUT,9011)
22365 9011   FORMAT('***** AT THE END      OF DPOPT2--')
22366        CALL DPWRST('XXX','BUG ')
22367        WRITE(ICOUT,9021)IERROR
22368 9021   FORMAT('IERROR = ',A4)
22369        CALL DPWRST('XXX','BUG ')
22370      ENDIF
22371C
22372      RETURN
22373      END
22374      SUBROUTINE DPOPT3(TYPSIZ,XSTART,XPLS,GPLS,A,WORK,
22375     1                  NUMDV,OPTACC,IOPTME,IOPTHE,IFLGFB,
22376     1                  ITNLIM,ADLT,AGRDTL,ASTPMX,ASTPTL,AFSCLE,MSG,
22377     1                  AFPLS,IANGLU,IFTEXP,IFTORD,IFORSW,IOPTMM,
22378     1                  IPARN,IPARN2,
22379     1                  ISUBRO,IBUGA3,IBUGCO,IBUGEV,IERROR)
22380C
22381C     PURPOSE--COMPUTE THE MINIMUM OF A FUNCTION
22382C              BETWEEN THE LIMITS XMIN AND XMAX.
22383C     WRITTEN BY--ALAN HECKERT
22384C                 STATISTICAL ENGINEERING DIVISION
22385C                 INFORMATION TECHNOLOGY LABORATORY
22386C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
22387C                 GAITHERSBURG, MD 20899-8980
22388C                 PHONE--301-975-2899
22389C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
22390C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
22391C     NOTE--THIS ROUTINE USES THE UNCMIN PACKAGE DESCIRBED IN THE
22392C           ARTICLE "A MODULAR SYSTEM OF ALGORITHMS FOR UNCONSTRAINED
22393C           MINIMIZATION" BY SCHNABEL, KOONTZ, AND WEISS.  THIS CODE
22394C           IS DESIGNED IN A MODULAR FASHION TO SUPPORT A LARGE
22395C           NUMBER OF POTENTIAL OPTIMIZATION METHODS.  IN PARTICULAR,
22396C           THE 3 MAIN CHOICES ARE:
22397C             1) STEP SELECTION - LINE, DOGLEG, HOOK STEP
22398C             2) GRADIENTS      - NUMERIC OR ANALYTIC
22399C             3) HESSIAN        - ANALYTIC, BFGS UPDATE, OR FINITE
22400C                                 DIFFERENCES
22401C           THESE MAY BE COMBINED FOR A TOTAL OF 18 ALGORITHMS
22402C           (ACTUALLY 15 SINCE ANALYTIC HESSIANS WITH A NUMERICAL
22403C           FIRST DERIVATIVE IS NOT REALISTIC).  AT THIS TIME,
22404C           DATAPLOT DOES NOT SUPPORT ANALYTIC GRADIENTS OR HESSIANS.
22405C           IN ADDITION, THE FUNCTION TO BE OPTIMIZED MUST BE
22406C           WRITTEN IN DATAPLOT'S FUNCTIONAL FORM.  THAT IS, THERE
22407C           IS CURRENTLY NO PROVISION FOR A USER WRITTEN FUNCTION.
22408C
22409C     NOTE--THIS FUNCTION DOES MINIMIZATION.  TO MAXIMIZE, FIND THE
22410C           MINIMUM OF THE NEGATIVE OF THE FUNCTION.
22411C
22412C     LANGUAGE--ANSI FORTRAN (1977)
22413C     VERSION NUMBER--94/6
22414C     ORIGINAL VERSION--JUNE      1994.
22415C     UPDATED         --SEPTEMBER 2015. SUPPORT FOR FUNCTION BLOCKS
22416C     UPDATED         --SEPTEMBER 2015. SUPPORT FOR IOPTMM (SPECIFY
22417C                                       WHETHER MINIMIZING OR
22418C                                       MAXIMIZING THE FUNCTION)
22419C
22420C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
22421C
22422      CHARACTER*4 IFTEXP
22423      CHARACTER*4 IFTORD
22424      CHARACTER*4 IFORSW
22425      CHARACTER*4 IANGLU
22426      CHARACTER*4 IOPTMM
22427C
22428      CHARACTER*4 IPARN(*)
22429      CHARACTER*4 IPARN2(*)
22430C
22431      CHARACTER*4 IBUGA3
22432      CHARACTER*4 IBUGCO
22433      CHARACTER*4 IBUGEV
22434      CHARACTER*4 IERROR
22435C
22436      CHARACTER*4 ISUBN1
22437      CHARACTER*4 ISUBN2
22438      CHARACTER*4 ISTEPN
22439      CHARACTER*4 ISUBRO
22440C
22441CCCCC MAY 1995.  ADD FOLLOWING LINES
22442      CHARACTER*4 IOPTME
22443      CHARACTER*4 IOPTHE
22444C
22445C---------------------------------------------------------------------
22446C
22447      PARAMETER (MAXOPT=100)
22448C
22449      DOUBLE PRECISION TYPSIZ(MAXOPT)
22450      DOUBLE PRECISION XSTART(MAXOPT)
22451      DOUBLE PRECISION XPLS(MAXOPT)
22452      DOUBLE PRECISION GPLS(MAXOPT)
22453      DOUBLE PRECISION A(MAXOPT,MAXOPT)
22454      DOUBLE PRECISION WORK(MAXOPT,8)
22455      DOUBLE PRECISION DLT
22456      DOUBLE PRECISION GRADTL
22457      DOUBLE PRECISION STEPMX
22458      DOUBLE PRECISION STEPTL
22459      DOUBLE PRECISION FPLS
22460      DOUBLE PRECISION EPSM
22461      DOUBLE PRECISION FSCALE
22462C
22463      INCLUDE 'DPCOMC.INC'
22464C
22465C     2015/08: FUNCTION BLOCK
22466C
22467      INCLUDE 'DPCOFB.INC'
22468C
22469      COMMON/IFBL2/IFLGF2
22470C
22471      CHARACTER*4 IFEESV
22472      COMMON/IFEED/IFEESV
22473C
22474C---------------------------------------------------------------------
22475C
22476      INCLUDE 'DPCOP2.INC'
22477C
22478C-----START POINT-----------------------------------------------------
22479C
22480      ISUBN1='DPOP'
22481      ISUBN2='T3  '
22482      IERROR='NO'
22483C
22484      IFLGF2=IFLGFB
22485C
22486      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'OPT3')THEN
22487        WRITE(ICOUT,999)
22488  999   FORMAT(1X)
22489        CALL DPWRST('XXX','BUG ')
22490        WRITE(ICOUT,51)
22491   51   FORMAT('AT THE BEGINNING OF DPOPT3--')
22492        CALL DPWRST('XXX','BUG ')
22493        WRITE(ICOUT,52)IBUGA3,IBUGCO,IBUGEV,ISUBRO,IANGLU,IFLGFB
22494   52   FORMAT('IBUGA3,IBUGCO,IBUGEV,ISUBRO,IFLGFB = ',4(A4,2X),I5)
22495        CALL DPWRST('XXX','BUG ')
22496        WRITE(ICOUT,53)IANGLU,IFORSW,IFTEXP,IFTORD
22497   53   FORMAT('IANGLU,IFORSW,IFTEXP,IFTORD = ',3(A4,2X),A4)
22498        CALL DPWRST('XXX','BUG ')
22499        WRITE(ICOUT,54)IOPTHE,IOPTMM,OPTACC
22500   54   FORMAT('IOPTHE,IOPTMM,OPTACC = ',2(A4,2X),G15.7)
22501        CALL DPWRST('XXX','BUG ')
22502      ENDIF
22503C
22504C               ***************************
22505C               **  STEP 1--             **
22506C               **  DEFINE DEFAULT VALUES**
22507C               ***************************
22508C
22509C PARAMETERS
22510C ----------
22511C N            --> DIMENSION OF PROBLEM
22512C XSTART(N)    --> INITIAL GUESS TO SOLUTION (TO COMPUTE MAX STEP SIZE)
22513C TYPSIZ(N)   <--  TYPICAL SIZE FOR EACH COMPONENT OF X
22514C FSCALE      <--  ESTIMATE OF SCALE OF MINIMIZATION FUNCTION
22515C METHOD      <--  ALGORITHM TO USE TO SOLVE MINIMIZATION PROBLEM
22516C IEXP        <--  =0 IF MINIMIZATION FUNCTION NOT EXPENSIVE TO EVALUATE
22517C MSG         <--  MESSAGE TO INHIBIT CERTAIN AUTOMATIC CHECKS + OUTPUT
22518C NDIGIT      <--  NUMBER OF GOOD DIGITS IN MINIMIZATION FUNCTION
22519C ITNLIM      <--  MAXIMUM NUMBER OF ALLOWABLE ITERATIONS
22520C IAGFLG      <--  =0 IF ANALYTIC GRADIENT NOT SUPPLIED
22521C IAHFLG      <--  =0 IF ANALYTIC HESSIAN NOT SUPPLIED
22522C IPR         <--  DEVICE TO WHICH TO SEND OUTPUT
22523C DLT         <--  TRUST REGION RADIUS
22524C GRADTL      <--  TOLERANCE AT WHICH GRADIENT CONSIDERED CLOSE ENOUGH
22525C                  TO ZERO TO TERMINATE ALGORITHM
22526C STEPMX      <--  VALUE OF ZERO TO TRIP DEFAULT MAXIMUM IN OPTCHK
22527C STEPTL      <--  TOLERANCE AT WHICH SUCCESSIVE ITERATES CONSIDERED
22528C                  CLOSE ENOUGH TO TERMINATE ALGORITHM
22529C
22530C SET TYPICAL SIZE OF X AND MINIMIZATION FUNCTION
22531CCCCC APRIL 1996.  CHANGE FOLLOWiNG LINE
22532CCCCC DO 10 I=1,N
22533      DO 10 I=1,MAXOPT
22534        TYPSIZ(I)=1.0D0
22535   10 CONTINUE
22536      IF(AFSCLE.NE.0.0)THEN
22537        FSCALE=DBLE(AFSCLE)
22538      ELSE
22539        FSCALE=1.0D0
22540      ENDIF
22541C
22542C SET TOLERANCES
22543C
22544      EPSM=DBLE(R1MACH(4))
22545CCCCC EPSM=D1MACH(4)
22546      IF(ADLT.NE.0.0)THEN
22547        DLT=DBLE(ADLT)
22548      ELSE
22549        DLT=-1.0D0
22550      ENDIF
22551      IF(AGRDTL.NE.0.0)THEN
22552        GRADTL=DBLE(AGRDTL)
22553      ELSE
22554        GRADTL=EPSM**(1.0D0/3.0D0)
22555      ENDIF
22556      IF(ASTPMX.NE.0.0)THEN
22557        STEPMX=DBLE(ASTPMX)
22558      ELSE
22559        STEPMX=0.0D0
22560      ENDIF
22561      IF(ASTPTL.NE.0.0)THEN
22562        STEPTL=DBLE(ASTPTL)
22563      ELSE
22564        STEPTL=DSQRT(EPSM)
22565      ENDIF
22566C
22567C SET FLAGS
22568      METHOD=1
22569      IF(IOPTME.EQ.'DOGL')METHOD=2
22570      IF(IOPTME.EQ.'HOOK')METHOD=3
22571      IEXP=1
22572CCCCC IF(IOPTHE.EQ.'FINI')IEXP=0
22573CCCCC IF(IOPTHE.EQ.'BFGS')IEXP=1
22574CCCCC DATAPLOT NOTE.  THE UNCMIN ROUTINE IS DOUBLE PRECISION.
22575CCCCC HOWEVER, DATAPLOT'S FUNCTION EVALUATION IS ONLY SINGLE
22576CCCCC PRECISION.  USE THE DEFAULT METHOD FROM OPTCHK, BUT USE
22577CCCCC SINGLE PRECISION VALUE RATHER THAN DOUBLE PRECISION.
22578CCCCC NDIGIT=-1
22579CCCCC NDIGIT=-LOG10(R1MACH(4))
22580CCCCC NDIGIT=-LOG10(D1MACH(4))
22581      NDIGIT=-1
22582C
22583      ITNLIM=150
22584      IAGFLG=0
22585      IAHFLG=0
22586      IPR2=IPR
22587      MSG=9
22588C
22589      DO207JJ=1,8
22590        DO209II=1,MAXOPT
22591          WORK(II,JJ)=1.0D0
22592  209   CONTINUE
22593  207 CONTINUE
22594C
22595      CALL OPTIF9(MAXOPT,NUMDV,XSTART,TYPSIZ,FSCALE,
22596     1            METHOD,IEXP,MSG,NDIGIT,ITNLIM,IAGFLG,IAHFLG,IPR2,
22597     1            DLT,GRADTL,STEPMX,STEPTL,
22598     1            XPLS,FPLS,GPLS,ITRMCD,A,WORK)
22599      AFPLS=SNGL(FPLS)
22600CCCCC IF(ITRMCD.EQ.0)THEN
22601CCCCC   IERROR='YES'
22602CCCCC   WRITE(ICOUT,999)
22603CCCCC   CALL DPWRST('XXX','BUG ')
22604CCCCC   WRITE(ICOUT,1000)
22605CCCCC   CALL DPWRST('XXX','BUG ')
22606CCCCC   WRITE(ICOUT,1011)
22607C1011   FORMAT('     ERRONEOUS INPUT DATA DETECTED BY OPTIF9 ROUTINE.')
22608CCCCC   CALL DPWRST('XXX','BUG ')
22609      IF(ITRMCD.EQ.1)THEN
22610        IERROR='NO'
22611C
22612C       FOR NOW, DON'T PRINT THIS MESSAGE.
22613C
22614        IF(IPRINT.EQ.'ON' .OR.IFEEDB.EQ.'ON')THEN
22615CCCCC     WRITE(ICOUT,999)
22616CCCCC     CALL DPWRST('XXX','BUG ')
22617CCCCC     WRITE(ICOUT,1031)
22618C1031     FORMAT('**** RELATIVE GRADIENT IS CLOSE TO ZERO.  THE ',
22619CCCCC1           'CURRENT ITERATE IS PROBABLY A SOLUTION.')
22620CCCCC     CALL DPWRST('XXX','BUG ')
22621        ENDIF
22622      ELSEIF(ITRMCD.EQ.2)THEN
22623        IERROR='NO'
22624        IF(IPRINT.EQ.'ON' .OR.IFEEDB.EQ.'ON')THEN
22625          WRITE(ICOUT,999)
22626          CALL DPWRST('XXX','BUG ')
22627          WRITE(ICOUT,1041)
22628 1041     FORMAT('**** SUCCESSIVE ITERATES WITHIN TOLERANCE.  THE ',
22629     1           'CURRENT ITERATE IS PROBABLY A SOLUTION.')
22630          CALL DPWRST('XXX','BUG ')
22631        ENDIF
22632      ELSEIF(ITRMCD.EQ.3)THEN
22633        IERROR='NO'
22634        IF(IPRINT.EQ.'ON' .OR.IFEEDB.EQ.'ON')THEN
22635          WRITE(ICOUT,999)
22636          CALL DPWRST('XXX','BUG ')
22637          WRITE(ICOUT,1051)
22638 1051     FORMAT('**** LAST GLOBAL STEP FAILED TO LOCATE A POINT LOWER',
22639     1           ' THAN CURRENT ITERATE.  EITHER IT IS A ')
22640          CALL DPWRST('XXX','BUG ')
22641          WRITE(ICOUT,1052)
22642 1052     FORMAT('     APPROXIMATE LOCAL MINIMUM OF THE FUNCTION, THE ',
22643     1           'FUNCTION IS TOO NON-LINEAR FOR')
22644          CALL DPWRST('XXX','BUG ')
22645          WRITE(ICOUT,1053)STEPTL
22646 1053     FORMAT('     THIS ALGORITHM, OR THE STEP TOLERANCE (',G15.7,
22647     1           ') IS TOO LARGE (CAN ')
22648          CALL DPWRST('XXX','BUG ')
22649          WRITE(ICOUT,1054)
22650 1054     FORMAT('     CHANGE WITH: LET OPTSTPTL = <VALUE>')
22651          CALL DPWRST('XXX','BUG ')
22652        ENDIF
22653      ELSEIF(ITRMCD.EQ.4)THEN
22654        IERROR='YES'
22655        WRITE(ICOUT,999)
22656        CALL DPWRST('XXX','BUG ')
22657        WRITE(ICOUT,1000)
22658 1000   FORMAT('**** ERROR FROM MULTI-VARIABLE OPTIMIZATION--')
22659        WRITE(ICOUT,1001)ITNLIM
22660 1001   FORMAT('     MAXIMUM NUMBER OF ITERATIONS (',I5,') EXCEEDED.')
22661        CALL DPWRST('XXX','BUG ')
22662      ELSEIF(ITRMCD.EQ.5)THEN
22663        IERROR='YES'
22664        WRITE(ICOUT,999)
22665        CALL DPWRST('XXX','BUG ')
22666        WRITE(ICOUT,1000)
22667        CALL DPWRST('XXX','BUG ')
22668        WRITE(ICOUT,1021)
22669 1021   FORMAT('     MAXIMUM STEP SIZE (',G15.7,') EXCEEDED ')
22670        CALL DPWRST('XXX','BUG ')
22671        WRITE(ICOUT,1022)
22672 1022   FORMAT('     5 CONSECUTIVE TIMES.  EITHER THE FUNCTION IS ',
22673     1         'UNBOUNDED FROM BELOW, BECOMES ASYMPTOTIC')
22674        CALL DPWRST('XXX','BUG ')
22675        WRITE(ICOUT,1023)
22676 1023   FORMAT('     TO A FINIT LIMIT FROM ABOVE, OR THE MAXIMIM ',
22677     1         'STEP SIZE IS TOO SMALL (LET OPTSTMX = <VALUE> TO ',
22678     1         'CHANGE).')
22679        CALL DPWRST('XXX','BUG ')
22680      ENDIF
22681C
22682C               ***************************
22683C               **  STEP 5--             **
22684C               **  WRITE OUT THE MINIMUM**
22685C               ***************************
22686C
22687      ISTEPN='5'
22688      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'OPT3')
22689     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22690C
22691      IF(IPRINT.EQ.'ON' .OR. IFEEDB.EQ.'ON')THEN
22692        WRITE(ICOUT,999)
22693        CALL DPWRST('XXX','BUG ')
22694        IF(IFLGFB.LE.0)THEN
22695          DO1401KK=1,NUMDV
22696            WRITE(ICOUT,1405)IPARN(KK),IPARN2(KK),XPLS(KK)
22697 1405       FORMAT('      THE MINIMUM VALUE OCCURS AT = ',2A4,1X,G15.7)
22698            CALL DPWRST('XXX','BUG ')
22699 1401     CONTINUE
22700        ELSE
22701          IF(IFLGFB.EQ.1)THEN
22702            DO1511KK=1,IFBCP1
22703              WRITE(ICOUT,1515)IFBPL1(KK),XPLS(KK)
22704 1515         FORMAT('      THE MINIMUM VALUE OCCURS AT = ',A8,1X,G15.7)
22705              CALL DPWRST('XXX','BUG ')
22706 1511       CONTINUE
22707          ELSEIF(IFLGFB.EQ.2)THEN
22708            DO1521KK=1,IFBCP2
22709              WRITE(ICOUT,1515)IFBPL2(KK),XPLS(KK)
22710              CALL DPWRST('XXX','BUG ')
22711 1521       CONTINUE
22712          ELSEIF(IFLGFB.EQ.3)THEN
22713            DO1531KK=1,IFBCP3
22714              WRITE(ICOUT,1515)IFBPL3(KK),XPLS(KK)
22715              CALL DPWRST('XXX','BUG ')
22716 1531       CONTINUE
22717          ENDIF
22718        ENDIF
22719        WRITE(ICOUT,999)
22720        CALL DPWRST('XXX','BUG ')
22721      ENDIF
22722C
22723C               *****************
22724C               **  STEP 90--  **
22725C               **  EXIT       **
22726C               *****************
22727C
22728      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'OPT3')THEN
22729        WRITE(ICOUT,9011)
22730 9011   FORMAT('***** AT THE END      OF DPOPT3--')
22731        CALL DPWRST('XXX','BUG ')
22732        WRITE(ICOUT,9021)IERROR
22733 9021   FORMAT('IERROR = ',A4)
22734        CALL DPWRST('XXX','BUG ')
22735      ENDIF
22736C
22737      RETURN
22738      END
22739      SUBROUTINE DPOR(IHARG,IARGT,ARG,NUMARG,
22740     1                PXSTAR,PYSTAR,PXEND,PYEND,
22741     1                ILINPA,ILINCO,PLINTH,
22742     1                AREGBA,IREBLI,IREBCO,PREBTH,
22743     1                IREFSW,IREFCO,
22744     1                IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
22745     1                PTEXHE,PTEXWI,PTEXVG,PTEXHG,
22746     1                IGRASW,IDIASW,
22747     1                PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
22748     1                PDIAHE,PDIAWI,PDIAVG,PDIAHG,
22749     1                NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
22750     1                IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
22751     1                IDNVOF,IDNHOF,IDFONT,UNITSW,PDSCAL,
22752     1                IBUGD2,IFOUND,IERROR)
22753C
22754C     PURPOSE--DRAW ONE OR MORE LOGICAL ORS (DEPENDING ON HOW MANY
22755C              NUMBERS ARE PROVIDED).  THE COORDINATES ARE IN
22756C              STANDARDIZED UNITS OF 0 TO 100.
22757C     NOTE--THE INPUT COORDINATES DEFINE THE BACK CENTER AND THE FRONT
22758C           CENTER OF THE LOGICAL OR.
22759C     NOTE-THE USUAL INPUT NUMBER OF COORDINATES IS 2
22760C          AND THEREFORE THE USUAL INPUT NUMBER OF NUMBERS IS 2*2 = 4.
22761C     NOTE--IF 2 NUMBERS ARE PROVIDED, THEN THE DRAWN LOGICAL OR WILL GO
22762C           FROM THE LAST CURSOR POSITION TO THE (X,Y) POINT (EITHER
22763C           ABSOLUTE OR RELATIVE) AS DEFINED BY THE 2 NUMBERS.
22764C     NOTE--IF 4 NUMBERS ARE PROVIDED, THEN THE DRAWN LOGICAL OR WILL GO
22765C           FROM THE ABSOLUTE (X,Y) POSITION AS DEFINED BY THE FIRST 2
22766C           NUMBERS TO THE (X,Y) POINT (EITHER ABSOLUTE OR RELATIVE)
22767C           AS DEFINED BY THE THIRD AND FOURTH NUMBERS.
22768C     NOTE--IF 6 NUMBERS ARE PROVIDED, THEN THE DRAWN LOGICAL OR WILL GO
22769C           FROM THE (X,Y) POSITION AS RESULTING FROM THE THIRD AND
22770C           FOURTH NUMBERS TO THE (X,Y) POINT (EITHER ABSOLUTE OR
22771C           RELATIVE) AS DEFINED BY THE FIFTH AND SIXTH NUMBERS.
22772C     NOTE--AND SO FORTH FOR 8, 10, 12, ... NUMBERS.
22773C     INPUT  ARGUMENTS--IHARG
22774C                     --IARGT
22775C                     --ARG
22776C                     --NUMARG
22777C                     --PXSTAR
22778C                     --PYSTAR
22779C     OUTPUT ARGUMENTS--PXEND
22780C                     --PYEND
22781C                     --IFOUND ('YES' OR 'NO' )
22782C                     --IERROR ('YES' OR 'NO' )
22783C     WRITTEN BY--JAMES J. FILLIBEN
22784C                 STATISTICAL ENGINEERING DIVISION
22785C                 INFORMATION TECHNOLOGY LABORATORY
22786C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
22787C                 GAITHERSBURG, MD 20899-8980
22788C                 PHONE--301-975-2855
22789C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
22790C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
22791C     LANGUAGE--ANSI FORTRAN (1977)
22792C     VERSION NUMBER--82/7
22793C     ORIGINAL VERSION--APRIL     1981.
22794C     UPDATED         --MARCH     1982.
22795C     UPDATED         --MAY       1982.
22796C     UPDATED         --NOVEMBER  1982.
22797C     UPDATED         --JANUARY   1989. CALL LIST FOR OFFSET VAR (ALAN)
22798C     UPDATED         --MARCH     1997. SUPPORT FOR DEVICE FONT (ALAN)
22799C     UPDATED         --JULY      1997. SUPPORT FOR "DATA" UNITS (ALAN)
22800C     UPDATED         --DECEMBER  2018. CHECK FOR DISCRETE, NULL, OR
22801C                                       NONE DEVICE
22802C     UPDATED         --DECEMBER  2018. SUPPORT FOR "DEVICE ... SCALE"
22803C                                       COMMAND
22804C     UPDATED         --JULY      2019. CREATE SCRATCH STORAGE IN DPOR
22805C                                       RATHER THAN DPOR2
22806C
22807C-----NON-COMMON VARIABLES-----------------------------------------
22808C
22809      CHARACTER*4 IHARG
22810      CHARACTER*4 IARGT
22811C
22812      CHARACTER*4 ILINPA
22813      CHARACTER*4 ILINCO
22814C
22815      CHARACTER*4 IREBLI
22816      CHARACTER*4 IREBCO
22817      CHARACTER*4 IREFSW
22818      CHARACTER*4 IREFCO
22819      CHARACTER*4 IREPTY
22820      CHARACTER*4 IREPLI
22821      CHARACTER*4 IREPCO
22822C
22823      CHARACTER*4 IGRASW
22824      CHARACTER*4 IDIASW
22825C
22826      CHARACTER*4 IDMANU
22827      CHARACTER*4 IDMODE
22828      CHARACTER*4 IDMOD2
22829      CHARACTER*4 IDMOD3
22830      CHARACTER*4 IDPOWE
22831      CHARACTER*4 IDCONT
22832      CHARACTER*4 IDCOLO
22833      CHARACTER*4 IDFONT
22834      CHARACTER*4 UNITSW
22835C
22836      CHARACTER*4 IFOUND
22837      CHARACTER*4 IBUGD2
22838      CHARACTER*4 IERROR
22839      CHARACTER*4 ISUBRO
22840C
22841      CHARACTER*4 IFIG
22842      CHARACTER*4 IBELSW
22843      CHARACTER*4 IERASW
22844      CHARACTER*4 IBACCO
22845      CHARACTER*4 ICOPSW
22846      CHARACTER*4 ITYPEO
22847C
22848      DIMENSION IHARG(*)
22849      DIMENSION IARGT(*)
22850      DIMENSION ARG(*)
22851C
22852      DIMENSION ILINPA(*)
22853      DIMENSION ILINCO(*)
22854      DIMENSION PLINTH(*)
22855C
22856      DIMENSION AREGBA(*)
22857      DIMENSION IREBLI(*)
22858      DIMENSION IREBCO(*)
22859      DIMENSION PREBTH(*)
22860      DIMENSION IREFSW(*)
22861      DIMENSION IREFCO(*)
22862      DIMENSION IREPTY(*)
22863      DIMENSION IREPLI(*)
22864      DIMENSION IREPCO(*)
22865      DIMENSION PREPTH(*)
22866      DIMENSION PREPSP(*)
22867      DIMENSION PDSCAL(*)
22868C
22869      DIMENSION IDMANU(*)
22870      DIMENSION IDMODE(*)
22871      DIMENSION IDMOD2(*)
22872      DIMENSION IDMOD3(*)
22873      DIMENSION IDPOWE(*)
22874      DIMENSION IDCONT(*)
22875      DIMENSION IDCOLO(*)
22876      DIMENSION IDFONT(*)
22877      DIMENSION IDNVPP(*)
22878      DIMENSION IDNHPP(*)
22879      DIMENSION IDUNIT(*)
22880      DIMENSION IDNVOF(*)
22881      DIMENSION IDNHOF(*)
22882C
22883C-----COMMON----------------------------------------------------------
22884C
22885      INCLUDE 'DPCOPA.INC'
22886      INCLUDE 'DPCOZZ.INC'
22887      DIMENSION PX(1000)
22888      DIMENSION PY(1000)
22889      EQUIVALENCE (GARBAG(IGARB1),PX(1))
22890      EQUIVALENCE (GARBAG(IGARB2),PY(1))
22891C
22892C-----COMMON VARIABLES (GENERAL)--------------------------------------
22893C
22894      INCLUDE 'DPCOGR.INC'
22895      INCLUDE 'DPCOBE.INC'
22896      INCLUDE 'DPCOP2.INC'
22897C
22898C-----START POINT-----------------------------------------------------
22899C
22900      IFOUND='NO'
22901      IERROR='NO'
22902      IERRG4=IERROR
22903C
22904      ILOCFN=0
22905      NUMNUM=0
22906C
22907      X1=0.0
22908      Y1=0.0
22909      X2=0.0
22910      Y2=0.0
22911C
22912      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'OR')THEN
22913        WRITE(ICOUT,999)
22914  999   FORMAT(1X)
22915        CALL DPWRST('XXX','BUG ')
22916        WRITE(ICOUT,51)
22917   51   FORMAT('***** AT THE BEGINNING OF DPOR--')
22918        CALL DPWRST('XXX','BUG ')
22919        WRITE(ICOUT,53)NUMARG,NUMDEV
22920   53   FORMAT('NUMARG,NUMDEV = ',2I8)
22921        CALL DPWRST('XXX','BUG ')
22922        DO55I=1,NUMARG
22923          WRITE(ICOUT,56)I,IHARG(I),IARGT(I),ARG(I)
22924   56     FORMAT('I,IHARG(I),IARGT(I),ARG(I) = ',I8,2(2X,A4),G15.7)
22925          CALL DPWRST('XXX','BUG ')
22926   55   CONTINUE
22927        WRITE(ICOUT,57)PXSTAR,PYSTAR,PXEND,PYEND
22928   57   FORMAT('PXSTAR,PYSTAR,PXEND,PYEND = ',4G15.7)
22929        CALL DPWRST('XXX','BUG ')
22930        WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1)
22931   61   FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',2(A4,2X),G15.7)
22932        CALL DPWRST('XXX','BUG ')
22933        WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1),AREGBA(1)
22934   63   FORMAT('IREBLI(1),IREBCO(1),PREBTH(1),AREGBA(1) = ',
22935     1         2(A4,2X),2G15.7)
22936        CALL DPWRST('XXX','BUG ')
22937        WRITE(ICOUT,64)IREFSW(1),IREFCO(1)
22938   64   FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4)
22939        CALL DPWRST('XXX','BUG ')
22940        WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1)
22941   65   FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ',
22942     1         3(A4,2X),2G15.7)
22943        CALL DPWRST('XXX','BUG ')
22944        WRITE(ICOUT,69)PTEXHE,PTEXWI,PTEXVG,PTEXHG
22945   69   FORMAT('PTEXHE,PTEXWI,PTEXVG,PTEXHG= ',4G15.7)
22946        CALL DPWRST('XXX','BUG ')
22947        WRITE(ICOUT,76)IGRASW,IDIASW
22948   76   FORMAT('IGRASW,IDIASW = ',A4,2X,A4)
22949        CALL DPWRST('XXX','BUG ')
22950        WRITE(ICOUT,77)PGRAXF,PGRAYF,PDIAXC,PDIAYC
22951   77   FORMAT('PGRAXF,PGRAYF,PDIAXC,PDIAYC = ',4G15.7)
22952        CALL DPWRST('XXX','BUG ')
22953        WRITE(ICOUT,78)PDIAHE,PDIAWI,PDIAVG,PDIAHG
22954   78   FORMAT('PDIAHE,PDIAWI,PDIAVG,PDIAHG = ',4G15.7)
22955        CALL DPWRST('XXX','BUG ')
22956        DO81I=1,NUMDEV
22957          WRITE(ICOUT,82)IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I)
22958   82     FORMAT('IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I) = ',
22959     1           3(A4,2X),A4)
22960          CALL DPWRST('XXX','BUG ')
22961          WRITE(ICOUT,83)IDPOWE(I),IDCONT(I),IDCOLO(I)
22962   83     FORMAT('IDPOWE(I),IDCONT(I),IDCOLO(I) = ',2(A4,2X),A4)
22963          CALL DPWRST('XXX','BUG ')
22964          WRITE(ICOUT,84)IDNVPP(I),IDNHPP(I),IDUNIT(I)
22965   84     FORMAT('IDNVPP(I),IDNHPP(I),IDUNIT(I) = ',3I8)
22966          CALL DPWRST('XXX','BUG ')
22967   81   CONTINUE
22968        WRITE(ICOUT,88)IBUGG4,IBUGD2,ISUBG4,IERRG4,IFOUND,IERROR
22969   88   FORMAT('IBUGG4,IBUGD2,ISUBG4,IERRG4,IFOUND,IERROR = ',
22970     1         5(A4,2X),A4)
22971        CALL DPWRST('XXX','BUG ')
22972      ENDIF
22973C
22974      IFIG='OR'
22975      NUMPT=2
22976      NUMPT2=2*NUMPT
22977C
22978C               ********************************
22979C               **  STEP 0--                  **
22980C               **  STEP THROUGH EACH DEVICE  **
22981C               ********************************
22982C
22983      IF(NUMDEV.LE.0)GOTO9000
22984      DO8000IDEVIC=1,NUMDEV
22985C
22986        IF(IDPOWE(IDEVIC).EQ.'OFF')GOTO8000
22987        IF(IDMANU(IDEVIC).EQ.'OFF')GOTO8000
22988        IF(IDMANU(IDEVIC).EQ.'NULL')GOTO8000
22989        IF(IDMANU(IDEVIC).EQ.'NONE')GOTO8000
22990        IF(IDMANU(IDEVIC).EQ.'DISC')GOTO8000
22991C
22992        IMANUF=IDMANU(IDEVIC)
22993        IMODEL=IDMODE(IDEVIC)
22994        IMODE2=IDMOD2(IDEVIC)
22995        IMODE3=IDMOD3(IDEVIC)
22996        IGCONT=IDCONT(IDEVIC)
22997        IGCOLO=IDCOLO(IDEVIC)
22998        IGFONT=IDFONT(IDEVIC)
22999        NUMVPP=IDNVPP(IDEVIC)
23000        NUMHPP=IDNHPP(IDEVIC)
23001        ANUMVP=NUMVPP
23002        ANUMHP=NUMHPP
23003        IOFFSV=IDNVOF(IDEVIC)
23004        IOFFSH=IDNHOF(IDEVIC)
23005        IGUNIT=IDUNIT(IDEVIC)
23006        PCHSCA=PDSCAL(IDEVIC)
23007C
23008C               ************************************
23009C               **  STEP 1--                      **
23010C               **  CARRY OUT OPENING OPERATIONS  **
23011C               **  ON THE GRAPHICS DEVICES       **
23012C               ************************************
23013C
23014        CALL DPOPDE
23015C
23016        IBELSW='OFF'
23017        NUMRIN=0
23018        IERASW='OFF'
23019        IBACCO='JUNK'
23020C
23021        CALL DPOPPL(IGRASW,IBELSW,NUMRIN,IERASW,IBACCO)
23022C
23023C               *****************************************
23024C               **  STEP 2--                           **
23025C               **  SEARCH FOR COMMAND SPECIFICATIONS  **
23026C               *****************************************
23027C
23028        IF(NUMARG.GE.2.AND.
23029     1     IARGT(1).EQ.'NUMB'.AND.IARGT(2).EQ.'NUMB')THEN
23030          ITYPEO='ABSO'
23031          ILOCFN=1
23032        ELSEIF(NUMARG.GE.3.AND.IHARG(1).EQ.'ABSO'.AND.
23033     1         IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB')THEN
23034          ITYPEO='ABSO'
23035          ILOCFN=2
23036        ELSEIF(NUMARG.GE.3.AND.IHARG(1).EQ.'RELA'.AND.
23037     1         IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB')THEN
23038          ITYPEO='RELA'
23039          ILOCFN=2
23040        ELSE
23041          GOTO1130
23042        ENDIF
23043C
23044        IF(ILOCFN.GT.NUMARG)GOTO1130
23045        DO1120I=ILOCFN,NUMARG
23046          IF(IARGT(I).NE.'NUMB')GOTO1130
23047 1120   CONTINUE
23048        IFOUND='YES'
23049C
23050C               ****************************
23051C               **  STEP 3--              **
23052C               **  DRAW OUT THE LINE(S)  **
23053C               ****************************
23054C
23055        NUMNUM=NUMARG-ILOCFN+1
23056        IF(NUMNUM.LT.NUMPT2)THEN
23057          J=ILOCFN-1
23058          X1=PXSTAR
23059          Y1=PYSTAR
23060        ELSE
23061          J=ILOCFN
23062          IF(J.GT.NUMARG)GOTO1190
23063          X1=ARG(J)
23064          IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X1,X1,
23065     1       IBUGD2,ISUBRO,IERROR)
23066          J=J+1
23067          IF(J.GT.NUMARG)GOTO1190
23068          Y1=ARG(J)
23069          IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y1,Y1,
23070     1       IBUGD2,ISUBRO,IERROR)
23071        ENDIF
23072C
23073 1160   CONTINUE
23074        J=J+1
23075        IF(J.GT.NUMARG)GOTO1190
23076        X2=ARG(J)
23077        IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X2,X2,IBUGD2,ISUBRO,IERROR)
23078        IF(ITYPEO.EQ.'RELA')X2=X1+X2
23079        J=J+1
23080        IF(J.GT.NUMARG)GOTO1190
23081        Y2=ARG(J)
23082        IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y2,Y2,IBUGD2,ISUBRO,IERROR)
23083        IF(ITYPEO.EQ.'RELA')Y2=Y1+Y2
23084C
23085        CALL DPOR2(X1,Y1,X2,Y2,PX,PY,
23086     1             IFIG,ILINPA,ILINCO,PLINTH,
23087     1             AREGBA,IREBLI,IREBCO,PREBTH,
23088     1             IREFSW,IREFCO,
23089     1             IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
23090     1             PTEXHE,PTEXWI,PTEXVG,PTEXHG)
23091C
23092        X1=X2
23093        Y1=Y2
23094C
23095        GOTO1160
23096 1190   CONTINUE
23097C
23098        PXEND=X2
23099        PYEND=Y2
23100C
23101C               ************************************
23102C               **  STEP 4--                      **
23103C               **  CARRY OUT CLOSING OPERATIONS  **
23104C               **  ON THE GRAPHICS DEVICES       **
23105C               ************************************
23106C
23107        ICOPSW='OFF'
23108        NUMCOP=0
23109        CALL DPCLPL(ICOPSW,NUMCOP,
23110     1              PGRAXF,PGRAYF,
23111     1              IGRASW,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
23112     1              PDIAHE,PDIAWI,PDIAVG,PDIAHG)
23113C
23114        CALL DPCLDE
23115C
23116 8000 CONTINUE
23117      GOTO9000
23118C
23119 1130 CONTINUE
23120      IERRG4='YES'
23121      WRITE(ICOUT,1131)
23122 1131 FORMAT('***** ERROR IN DPOR--')
23123      CALL DPWRST('XXX','BUG ')
23124      WRITE(ICOUT,1132)
23125 1132 FORMAT('      ILLEGAL FORM FOR THE OR COMMAND.')
23126      CALL DPWRST('XXX','BUG ')
23127      WRITE(ICOUT,1134)
23128 1134 FORMAT('      TEST EXAMPLE TO DEMONSTRATE THE PROPER FORM--')
23129      CALL DPWRST('XXX','BUG ')
23130      WRITE(ICOUT,1135)
23131 1135 FORMAT('      SUPPOSE IT IS DESIRED TO DRAW A LOGICAL OR ')
23132      CALL DPWRST('XXX','BUG ')
23133      WRITE(ICOUT,1136)
23134 1136 FORMAT('      WITH THE MIDDLE OF THE FLATTER SIDE  ',
23135     1'AT THE POINT 20 20 ')
23136      CALL DPWRST('XXX','BUG ')
23137      WRITE(ICOUT,1137)
23138 1137 FORMAT('      AND WITH THE POINTED END AT THE POINT 40 60')
23139      CALL DPWRST('XXX','BUG ')
23140      WRITE(ICOUT,1141)
23141 1141 FORMAT('      THEN THE ALLOWABLE FORMS ARE--')
23142      CALL DPWRST('XXX','BUG ')
23143      WRITE(ICOUT,1142)
23144 1142 FORMAT('      OR 20 20 40 60 ')
23145      CALL DPWRST('XXX','BUG ')
23146      WRITE(ICOUT,1143)
23147 1143 FORMAT('      OR ABSOLUTE 20 20 40 60 ')
23148      CALL DPWRST('XXX','BUG ')
23149      WRITE(ICOUT,1145)
23150 1145 FORMAT('      OR RELATIVE 20 20 40 60 ')
23151      CALL DPWRST('XXX','BUG ')
23152C
23153C               *****************
23154C               **  STEP 90--  **
23155C               **  EXIT       **
23156C               *****************
23157C
23158 9000 CONTINUE
23159      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'OR')THEN
23160        WRITE(ICOUT,999)
23161        CALL DPWRST('XXX','BUG ')
23162        WRITE(ICOUT,9011)
23163 9011   FORMAT('***** AT THE END       OF DPOR--')
23164        CALL DPWRST('XXX','BUG ')
23165        WRITE(ICOUT,9012)IFOUND,IERROR,ILOCFN,NUMNUM
23166 9012   FORMAT('IFOUND,IERROR,ILOCFN,NUMNUM = ',2(A4,2X),2I8)
23167        CALL DPWRST('XXX','BUG ')
23168        WRITE(ICOUT,9013)X1,Y1,X2,Y2,X3,Y3
23169 9013   FORMAT('X1,Y1,X2,Y2,X3,Y3 = ',6G15.7)
23170        CALL DPWRST('XXX','BUG ')
23171        WRITE(ICOUT,9015)PXSTAR,PYSTAR,PXEND,PYEND
23172 9015   FORMAT('PXSTAR,PYSTAR,PXEND,PYEND = ',4G15.7)
23173        CALL DPWRST('XXX','BUG ')
23174      ENDIF
23175C
23176      RETURN
23177      END
23178      SUBROUTINE DPOR2(X1,Y1,X2,Y2,PX,PY,
23179     1                 IFIG,ILINPA,ILINCO,PLINTH,
23180     1                 AREGBA,IREBLI,IREBCO,PREBTH,
23181     1                 IREFSW,IREFCO,
23182     1                 IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
23183     1                 PTEXHE,PTEXWI,PTEXVG,PTEXHG)
23184C
23185C     PURPOSE--DRAW A LOGICAL OR (= AN OR BOX) WITH THE MIDDLE OF THE
23186C              FLATTER SIDE AT THE POINT (X1,Y1), AND WITH THE MIDDLE OF
23187C              THE POINTED SIDE AT THE POINT (X2,Y2).
23188C     NOTE--THE HEIGHT OF THE BOX WILL BE EQUAL TO THE ABOVE-DESCRIBED
23189C           WIDTH OF THE BOX (THAT IS, THE HEIGHT OF THE BOX WILL BE
23190C           EQUAL TO THE WIDTH FROM (X1,Y1) TO (X2,Y2).
23191C     WRITTEN BY--JAMES J. FILLIBEN
23192C                 STATISTICAL ENGINEERING DIVISION
23193C                 INFORMATION TECHNOLOGY LABORATORY
23194C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
23195C                 GAITHERSBURG, MD 20899-8980
23196C                 PHONE--301-975-2855
23197C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
23198C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
23199C     LANGUAGE--ANSI FORTRAN (1977)
23200C     VERSION NUMBER--82/7
23201C     ORIGINAL VERSION--APRIL     1981.
23202C     UPDATED         --MAY       1982.
23203C     UPDATED         --JANUARY   1989.  MODIFY CALLS TO DPDRPL (ALAN)
23204C     UPDATED         --JANUARY   1989.  MODIFY CALL  TO DPFIRE (ALAN)
23205C     UPDATED         --JULY      2019. CREATE SCRATCH STORAGE IN DPARC
23206C                                       RATHER THAN DPARC2
23207C
23208C-----NON-COMMON VARIABLES-------------------------------------
23209C
23210      DIMENSION PX(*)
23211      DIMENSION PY(*)
23212C
23213      CHARACTER*4 IFIG
23214      CHARACTER*4 IPATT2
23215C
23216      CHARACTER*4 ILINPA
23217      CHARACTER*4 ILINCO
23218C
23219      CHARACTER*4 IREBLI
23220      CHARACTER*4 IREBCO
23221      CHARACTER*4 IREFSW
23222      CHARACTER*4 IREFCO
23223      CHARACTER*4 IREPTY
23224      CHARACTER*4 IREPLI
23225      CHARACTER*4 IREPCO
23226C
23227      CHARACTER*4 IPATT
23228      CHARACTER*4 ICOLF
23229      CHARACTER*4 ICOLP
23230      CHARACTER*4 ICOL
23231      CHARACTER*4 IFLAG
23232C
23233      DIMENSION ILINPA(*)
23234      DIMENSION ILINCO(*)
23235      DIMENSION PLINTH(*)
23236C
23237      DIMENSION AREGBA(*)
23238      DIMENSION IREBLI(*)
23239      DIMENSION IREBCO(*)
23240      DIMENSION PREBTH(*)
23241      DIMENSION IREFSW(*)
23242      DIMENSION IREFCO(*)
23243      DIMENSION IREPTY(*)
23244      DIMENSION IREPLI(*)
23245      DIMENSION IREPCO(*)
23246      DIMENSION PREPTH(*)
23247      DIMENSION PREPSP(*)
23248C
23249C-----COMMON----------------------------------------------------------
23250C
23251      INCLUDE 'DPCOGR.INC'
23252      INCLUDE 'DPCOBE.INC'
23253      INCLUDE 'DPCOP2.INC'
23254C
23255C-----START POINT-----------------------------------------------------
23256C
23257      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'OR2')THEN
23258        WRITE(ICOUT,999)
23259  999   FORMAT(1X)
23260        CALL DPWRST('XXX','BUG ')
23261        WRITE(ICOUT,51)
23262   51   FORMAT('***** AT THE BEGINNING OF DPOR2--')
23263        CALL DPWRST('XXX','BUG ')
23264        WRITE(ICOUT,53)X1,Y1,X2,Y2
23265   53   FORMAT('X1,Y1,X2,Y2 = ',4G15.7)
23266        CALL DPWRST('XXX','BUG ')
23267        WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1)
23268   61   FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',A4,2X,A4,G15.7)
23269        CALL DPWRST('XXX','BUG ')
23270        WRITE(ICOUT,62)IFIG,AREGBA(1)
23271   62   FORMAT('IFIG,AREGBA(1) = ',A4,2X,G15.7)
23272        CALL DPWRST('XXX','BUG ')
23273        WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1)
23274   63   FORMAT('IREBLI(1),IREBCO(1),PREBTH(1) = ',2(A4,2X),G15.7)
23275        CALL DPWRST('XXX','BUG ')
23276        WRITE(ICOUT,64)IREFSW(1),IREFCO(1)
23277   64   FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4)
23278        CALL DPWRST('XXX','BUG ')
23279        WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1)
23280   65   FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ',
23281     1         3(A4,2X),2G15.7)
23282        CALL DPWRST('XXX','BUG ')
23283        WRITE(ICOUT,69)PTEXHE,PTEXWI,PTEXHG,PTEXVG
23284   69   FORMAT('PTEXHE,PTEXWI,PTEXHG,PTEXVG = ',4G15.7)
23285        CALL DPWRST('XXX','BUG ')
23286        WRITE(ICOUT,79)IBUGG4,ISUBG4,IERRG4
23287   79   FORMAT('IBUGG4,ISUBG4,IERRG4 = ',2(A4,2X),A4)
23288        CALL DPWRST('XXX','BUG ')
23289      ENDIF
23290C
23291C               *********************************
23292C               **  STEP 1--                   **
23293C               **  DETERMINE THE COORDINATES  **
23294C               **  FOR THE LOGICAL OR        **
23295C               *********************************
23296C
23297      POWER=1.4
23298      FACTOR=0.2
23299C
23300      DELX=X2-X1
23301      DELY=Y2-Y1
23302      ALEN=0.0
23303      TERM=(X2-X1)**2+(Y2-Y1)**2
23304      IF(TERM.GT.0.0)ALEN=SQRT(TERM)
23305      R=ALEN/2.0
23306      IF(ABS(DELX).GE.0.00001)THETA=ATAN(DELY/DELX)
23307      IF(ABS(DELX).LT.0.00001.AND.DELY.GE.0.0)THETA=3.1415926/2.0
23308      IF(ABS(DELX).LT.0.00001.AND.DELY.LT.0.0)THETA=-3.1415926/2.0
23309C
23310      K=0
23311C
23312      X=R
23313      Y=-R
23314      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
23315      K=K+1
23316      PX(K)=XP
23317      PY(K)=YP
23318C
23319      DO5210I=271,451,5
23320      PHI2=I-1
23321      PHI2=PHI2*(2.0*3.1415926)/360.0
23322      ABSCOS=ABS(COS(PHI2))
23323      ABSSIN=ABS(SIN(PHI2))
23324      X=R*(ABSCOS**POWER)
23325      Y=R*(ABSSIN**POWER)
23326      IF(SIN(PHI2).LT.0.0)Y=-Y
23327      X=X+R
23328      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
23329      K=K+1
23330      PX(K)=XP
23331      PY(K)=YP
23332 5210 CONTINUE
23333C
23334      X=0
23335      X=X-FACTOR*R
23336      Y=R
23337      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
23338      K=K+1
23339      PX(K)=XP
23340      PY(K)=YP
23341C
23342      DO5220I=271,451,5
23343      PHI2=I-1
23344      PHI2=360.0-PHI2
23345      PHI2=PHI2*(2.0*3.1415926)/360.0
23346      X=FACTOR*R*COS(PHI2)
23347      X=X-FACTOR*R
23348      Y=R*SIN(PHI2)
23349      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
23350      K=K+1
23351      PX(K)=XP
23352      PY(K)=YP
23353 5220 CONTINUE
23354C
23355      X=R
23356      Y=-R
23357      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
23358      K=K+1
23359      PX(K)=XP
23360      PY(K)=YP
23361C
23362      NP=K
23363C
23364C               ***********************
23365C               **  STEP 2--         **
23366C               **  FILL THE FIGURE  **
23367C               **  (IF CALLED FOR)  **
23368C               ***********************
23369C
23370      IF(IREFSW(1).EQ.'OFF')GOTO2190
23371      IPATT=IREPTY(1)
23372      IPATT2='SOLI'
23373      PTHICK=PREPTH(1)
23374      PXGAP=PREPSP(1)
23375      PYGAP=PREPSP(1)
23376      ICOLF=IREFCO(1)
23377      ICOLP=IREPCO(1)
23378      CALL DPFIRE(PX,PY,NP,
23379     1            IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,IPATT2)
23380 2190 CONTINUE
23381C
23382C               *********************************
23383C               **  STEP 3--                   **
23384C               **  DRAW OUT THE FIGURE  OR   **
23385C               *********************************
23386C
23387      IPATT=ILINPA(1)
23388      PTHICK=PLINTH(1)
23389      ICOL=ILINCO(1)
23390      IFLAG='ON'
23391      CALL DPDRPL(PX,PY,NP,
23392     1            IFIG,IPATT,PTHICK,ICOL,
23393     1            JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
23394C
23395C               *****************
23396C               **  STEP 90--  **
23397C               **  EXIT       **
23398C               *****************
23399C
23400      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'OR2')THEN
23401        WRITE(ICOUT,999)
23402        CALL DPWRST('XXX','BUG ')
23403        WRITE(ICOUT,9011)
23404 9011   FORMAT('***** AT THE END       OF DPOR2--')
23405        CALL DPWRST('XXX','BUG ')
23406        WRITE(ICOUT,9014)NP,IERRG4
23407 9014   FORMAT('NP,IERRG4 = ',I8,2X,A4)
23408        CALL DPWRST('XXX','BUG ')
23409        DO9015I=1,NP
23410          WRITE(ICOUT,9016)I,PX(I),PY(I)
23411 9016     FORMAT('I,PX(I),PY(I) = ',I8,2G15.7)
23412          CALL DPWRST('XXX','BUG ')
23413 9015   CONTINUE
23414      ENDIF
23415C
23416      RETURN
23417      END
23418      SUBROUTINE DPORCO(IHARG,IARGT,ARG,NUMARG,
23419     1AORIXC,AORIYC,AORIZC,
23420     1IFOUND,IERROR)
23421C
23422C     PURPOSE--DEFINE THE (X,Y,Z) ORIGIN COORDINATES CONTAINED IN THE
23423C              3 VARAIBLES AORIXC,AORIYC,AORIZC
23424C              SUCH ORIGIN COORDINATES ARE USED IN 3-DIMENSIONAL PLOTS.
23425C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
23426C                     --IARGT  (A  HOLLERITH VECTOR)
23427C                     --ARG    (A  FLOATING POINT VECTOR)
23428C                     --NUMARG
23429C     OUTPUT ARGUMENTS--AORIXC  = X-COORDINATE OF ORIGIN
23430C                     --AORIYC  = Y-COORDINATE OF ORIGIN
23431C                     --AORIZC  = Z-COORDINATE OF ORIGIN
23432C                     --IFOUND ('YES' OR 'NO' )
23433C                     --IERROR ('YES' OR 'NO' )
23434C     WRITTEN BY--JAMES J. FILLIBEN
23435C                 STATISTICAL ENGINEERING DIVISION
23436C                 INFORMATION TECHNOLOGY LABORATORY
23437C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
23438C                 GAITHERSBURG, MD 20899-8980
23439C                 PHONE--301-975-2855
23440C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
23441C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
23442C     LANGUAGE--ANSI FORTRAN (1977)
23443C     VERSION NUMBER--82/7
23444C     ORIGINAL VERSION--NOVEMBER  1978.
23445C     UPDATED         --SEPTEMBER 1980.
23446C     UPDATED         --MAY       1982.
23447C
23448C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
23449C
23450      CHARACTER*4 IHARG
23451      CHARACTER*4 IARGT
23452      CHARACTER*4 IFOUND
23453      CHARACTER*4 IERROR
23454C
23455C---------------------------------------------------------------------
23456C
23457      DIMENSION IHARG(*)
23458      DIMENSION IARGT(*)
23459      DIMENSION ARG(*)
23460C
23461C---------------------------------------------------------------------
23462C
23463      INCLUDE 'DPCOP2.INC'
23464C
23465C-----START POINT-----------------------------------------------------
23466C
23467      IFOUND='NO'
23468      IERROR='NO'
23469C
23470      IF(NUMARG.LE.0)GOTO1199
23471      IF(IHARG(1).NE.'COOR')GOTO1199
23472      IF(NUMARG.EQ.1)GOTO1150
23473      IF(IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB'.AND.
23474     1IARGT(4).EQ.'NUMB')GOTO1160
23475      GOTO1110
23476C
23477 1110 CONTINUE
23478      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
23479      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
23480      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
23481      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
23482C
23483      IERROR='YES'
23484      WRITE(ICOUT,1121)
23485 1121 FORMAT('***** ERROR IN DPEYCO--')
23486      CALL DPWRST('XXX','BUG ')
23487      WRITE(ICOUT,1122)
23488 1122 FORMAT('      ILLEGAL FORM FOR ORIGIN COORDINATES ',
23489     1'COMMAND.')
23490      CALL DPWRST('XXX','BUG ')
23491      WRITE(ICOUT,1124)
23492 1124 FORMAT('      TEST EXAMPLE TO DEMONSTRATE THE ',
23493     1'PROPER FORM--')
23494      CALL DPWRST('XXX','BUG ')
23495      WRITE(ICOUT,1125)
23496 1125 FORMAT('      SUPPOSE IT IS DESIRED TO POSITION ')
23497      CALL DPWRST('XXX','BUG ')
23498      WRITE(ICOUT,1126)
23499 1126 FORMAT('      THE AXES ORIGIN FOR A 3 DIMENSIONAL PLOT')
23500      CALL DPWRST('XXX','BUG ')
23501      WRITE(ICOUT,1127)
23502 1127 FORMAT('      AT (IN UNITS OF THE PLOTTED DATA)--')
23503      CALL DPWRST('XXX','BUG ')
23504      WRITE(ICOUT,1128)
23505 1128 FORMAT('      (X=500, Y=25000, Z=.03)')
23506      CALL DPWRST('XXX','BUG ')
23507      WRITE(ICOUT,1129)
23508 1129 FORMAT('      THEN THE ALLOWABLE FORM IS--')
23509      CALL DPWRST('XXX','BUG ')
23510      WRITE(ICOUT,1130)
23511 1130 FORMAT('      ORIGIN COORDINATES 500 2500 .03')
23512      CALL DPWRST('XXX','BUG ')
23513      GOTO1199
23514C
23515 1150 CONTINUE
23516      AORIXC=CPUMIN
23517      AORIYC=CPUMIN
23518      AORIZC=CPUMIN
23519      GOTO1180
23520C
23521 1160 CONTINUE
23522      AORIXC=ARG(2)
23523      AORIYC=ARG(3)
23524      AORIZC=ARG(4)
23525      GOTO1180
23526C
23527 1180 CONTINUE
23528      IFOUND='YES'
23529C
23530      IF(IFEEDB.EQ.'OFF')GOTO1189
23531      WRITE(ICOUT,999)
23532  999 FORMAT(1X)
23533      CALL DPWRST('XXX','BUG ')
23534      WRITE(ICOUT,1185)
23535 1185 FORMAT('THE (X,Y,Z) ORIGIN COORDINATES HAVE JUST BEEN SET TO')
23536      CALL DPWRST('XXX','BUG ')
23537      WRITE(ICOUT,1186)AORIXC
23538 1186 FORMAT('            --X = ',E15.7)
23539      CALL DPWRST('XXX','BUG ')
23540      WRITE(ICOUT,1187)AORIYC
23541 1187 FORMAT('            --Y = ',E15.7)
23542      CALL DPWRST('XXX','BUG ')
23543      WRITE(ICOUT,1188)AORIZC
23544 1188 FORMAT('            --Z = ',E15.7)
23545      CALL DPWRST('XXX','BUG ')
23546 1189 CONTINUE
23547      GOTO1199
23548C
23549 1199 CONTINUE
23550      RETURN
23551      END
23552      SUBROUTINE DPORD(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
23553     1                 CLLIMI,CLWIDT,
23554     1                 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
23555C
23556C     PURPOSE--GENERATE THE FOLLOWING PLOT:
23557C              ORD PLOT Y X
23558C              ORD PLOT Y
23559C     REFERENCE--MICHAEL FRIENDLY (200), "VISUALIZING CATEGORICAL
23560C                DATA", SAS PUBLISHING, PP. 46-49.
23561C     WRITTEN BY--ALAN HECKERT
23562C                 STATISTICAL ENGINEERING DIVISION
23563C                 INFORMATION TECHNOLOGY LABORATROY
23564C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
23565C                 GAITHERSBURG, MD 20899-8980
23566C                 PHONE--301-975-2899
23567C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
23568C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
23569C     LANGUAGE--ANSI FORTRAN (1977)
23570C     VERSION NUMBER--2007/5
23571C     ORIGINAL VERSION--MAY       2007.
23572C     UPDATED         --JANUARY   2012.
23573C
23574C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
23575C
23576      CHARACTER*4 ICASPL
23577      CHARACTER*4 IAND1
23578      CHARACTER*4 IAND2
23579      CHARACTER*4 IBUGG2
23580      CHARACTER*4 IBUGG3
23581      CHARACTER*4 IBUGQ
23582      CHARACTER*4 ISUBRO
23583      CHARACTER*4 IFOUND
23584      CHARACTER*4 IERROR
23585C
23586      CHARACTER*4 IDATSW
23587      CHARACTER*4 ISUBN1
23588      CHARACTER*4 ISUBN2
23589      CHARACTER*4 ISUBN0
23590      CHARACTER*4 ISTEPN
23591      CHARACTER*4 IH
23592      CHARACTER*4 IH2
23593C
23594      CHARACTER*4 ICASE
23595      CHARACTER*40 INAME
23596      PARAMETER (MAXSPN=10)
23597      CHARACTER*4 IVARN1(MAXSPN)
23598      CHARACTER*4 IVARN2(MAXSPN)
23599      CHARACTER*4 IVARTY(MAXSPN)
23600      REAL PVAR(MAXSPN)
23601      INTEGER ILIS(MAXSPN)
23602      INTEGER NRIGHT(MAXSPN)
23603      INTEGER ICOLR(MAXSPN)
23604C
23605C---------------------------------------------------------------------
23606C
23607      INCLUDE 'DPCOPA.INC'
23608      INCLUDE 'DPCOZZ.INC'
23609C
23610      DIMENSION CLLIMI(*)
23611      DIMENSION CLWIDT(*)
23612C
23613      DIMENSION Y1(MAXOBV)
23614      DIMENSION X1(MAXOBV)
23615      DIMENSION TEMP1(MAXOBV)
23616      DIMENSION TEMP2(MAXOBV)
23617      DIMENSION WEIGHH(MAXOBV)
23618      DIMENSION WEIGHV(MAXOBV)
23619C
23620      EQUIVALENCE (GARBAG(IGARB1),X1(1))
23621      EQUIVALENCE (GARBAG(IGARB2),Y1(1))
23622      EQUIVALENCE (GARBAG(IGARB3),TEMP1(1))
23623      EQUIVALENCE (GARBAG(IGARB4),TEMP2(1))
23624      EQUIVALENCE (GARBAG(IGARB5),WEIGHH(1))
23625      EQUIVALENCE (GARBAG(IGARB6),WEIGHV(1))
23626C
23627C-----COMMON----------------------------------------------------------
23628C
23629      INCLUDE 'DPCOST.INC'
23630      INCLUDE 'DPCOHK.INC'
23631      INCLUDE 'DPCOHO.INC'
23632      INCLUDE 'DPCODA.INC'
23633      INCLUDE 'DPCOP2.INC'
23634C
23635C-----START POINT-----------------------------------------------------
23636C
23637      IFOUND='NO'
23638      IERROR='NO'
23639      ISUBN1='DPOR'
23640      ISUBN2='D   '
23641C
23642      MAXCP1=MAXCOL+1
23643      MAXCP2=MAXCOL+2
23644      MAXCP3=MAXCOL+3
23645      MAXCP4=MAXCOL+4
23646      MAXCP5=MAXCOL+5
23647      MAXCP6=MAXCOL+6
23648C
23649C               ************************************
23650C               **  TREAT THE ORD           PLOT  **
23651C               ************************************
23652C
23653      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'ORD ')THEN
23654        WRITE(ICOUT,999)
23655  999   FORMAT(1X)
23656        CALL DPWRST('XXX','BUG ')
23657        WRITE(ICOUT,51)
23658   51   FORMAT('***** AT THE BEGINNING OF DPORD--')
23659        CALL DPWRST('XXX','BUG ')
23660        WRITE(ICOUT,52)ICASPL,IAND1,IAND2
23661   52   FORMAT('ICASPL,IAND1,IAND2 = ',2(A4,2X),A4)
23662        CALL DPWRST('XXX','BUG ')
23663        WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ,ISUBRO
23664   53   FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',3(A4,2X),A4)
23665        CALL DPWRST('XXX','BUG ')
23666      ENDIF
23667C
23668C               ***************************
23669C               **  STEP 1--             **
23670C               **  EXTRACT THE COMMAND  **
23671C               ***************************
23672C
23673      ISTEPN='1'
23674      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'ORD')
23675     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23676C
23677      IF(NUMARG.GE.2.AND.ICOM.EQ.'ORD '.AND.IHARG(1).EQ.'PLOT')THEN
23678        ILASTC=1
23679        CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
23680        IFOUND='YES'
23681        ICASPL='ORD '
23682      ELSE
23683        IFOUND='NO'
23684        GOTO9000
23685      ENDIF
23686C
23687C               ****************************************
23688C               **  STEP 2--                          **
23689C               **  EXTRACT THE VARIABLE LIST         **
23690C               ****************************************
23691C
23692      ISTEPN='2'
23693      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'ORD')
23694     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23695C
23696      INAME='ORD PLOT'
23697      MINNA=1
23698      MAXNA=100
23699      MINN2=1
23700      IFLAGE=1
23701      IFLAGM=0
23702      IFLAGP=0
23703      JMIN=1
23704      JMAX=NUMARG
23705      MINNVA=1
23706      MAXNVA=2
23707C
23708      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
23709     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
23710     1            JMIN,JMAX,
23711     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
23712     1            IVARN1,IVARN2,IVARTY,PVAR,
23713     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
23714     1            MINNVA,MAXNVA,
23715     1            IFLAGM,IFLAGP,
23716     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
23717      IF(IERROR.EQ.'YES')GOTO9000
23718C
23719      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'ORD')THEN
23720        WRITE(ICOUT,999)
23721        CALL DPWRST('XXX','BUG ')
23722        WRITE(ICOUT,281)
23723  281   FORMAT('***** AFTER CALL DPPARS--')
23724        CALL DPWRST('XXX','BUG ')
23725        WRITE(ICOUT,282)NQ,NUMVAR
23726  282   FORMAT('NQ,NUMVAR = ',2I8)
23727        CALL DPWRST('XXX','BUG ')
23728        IF(NUMVAR.GT.0)THEN
23729          DO285I=1,NUMVAR
23730            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
23731     1                      ICOLR(I)
23732  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
23733     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
23734            CALL DPWRST('XXX','BUG ')
23735  285     CONTINUE
23736        ENDIF
23737      ENDIF
23738C
23739      ICOL=1
23740      IF(NUMVAR.EQ.1)THEN
23741        IDATSW='RAW'
23742        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
23743     1              INAME,IVARN1,IVARN2,IVARTY,
23744     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
23745     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
23746     1              MAXCP4,MAXCP5,MAXCP6,
23747     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
23748     1              X1,X1,X1,NLOCAL,NLOCAL,NLOCAL,ICASE,
23749     1              IBUGG3,ISUBRO,IFOUND,IERROR)
23750      ELSE
23751        IDATSW='FREQ'
23752        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
23753     1              INAME,IVARN1,IVARN2,IVARTY,
23754     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
23755     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
23756     1              MAXCP4,MAXCP5,MAXCP6,
23757     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
23758     1              Y1,X1,X1,NLOCAL,NLOCAL,NLOCAL,ICASE,
23759     1              IBUGG3,ISUBRO,IFOUND,IERROR)
23760      ENDIF
23761      IF(IERROR.EQ.'YES')GOTO9000
23762C
23763C               ****************************************************
23764C               **  STEP 7--                                      **
23765C               **  DETERMINE IF THE ANALYST                      **
23766C               **  HAS SPECIFIED    1)  THE CLASS WIDTH,         **
23767C               **                   2)  THE MIN POINT OF THE     **
23768C               **                       FIRST CELL,              **
23769C               **                   3)  THE MAX POINT OF THE     **
23770C               **                       LAST  CELL,              **
23771C               **  FOR THE DISTRIBUTIONAL ANALYSIS.              **
23772C               **  IF NON-DEFAULT, USE THE SPECIFIED VALUES.     **
23773C               **  IF DEFAULT, USE THE DEFAULT VALUES--          **
23774C               **     1)  CLASS WIDTH = .3 OF A SAMPLE STANDARD  **
23775C               **         DEVIATION;                             **
23776C               **     2)  START = SAMPLE MEAN - 6*(SAMPLE        **
23777C               **         STANDARD DEVIATION);                   **
23778C               **     3)  STOP  = SAMPLE MEAN + 6*(SAMPLE        **
23779C               **         STANDARD DEVIATION);                   **
23780C               **  NOTE THAT THE DEFAULT SETTINGS ARE IN FACT    **
23781C               ****************************************************
23782C
23783      ISTEPN='7'
23784      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'ORD')
23785     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23786C
23787      CLWID=CLWIDT(1)
23788      XSTART=CLLIMI(1)
23789      XSTOP=CLLIMI(2)
23790C
23791C               *****************************************************
23792C               **  STEP 8--                                       **
23793C               **  FORM THE VERTICAL AND HORIZONTAL AXIS          **
23794C               **  VALUES Y(.) AND X(.) FOR THE PLOT.             **
23795C               **  RESET THE VECTOR D(.) TO ALL ONES.             **
23796C               **  DEFINE THE NUMBER OF PLOT POINTS    (NPLOTP).  **
23797C               **  DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV).  **
23798C               *****************************************************
23799C
23800      CALL DPORD2(Y1,X1,NLOCAL,NUMVAR,
23801     1            WEIGHH,WEIGHV,TEMP1,TEMP2,
23802     1            IDATSW,
23803     1            PPA0,PPA1,
23804     1            Y,X,D,NPLOTP,NPLOTV,ISUBRO,IBUGG3,IERROR)
23805C
23806      IH='PPA0'
23807      IH2='    '
23808      VALUE0=PPA0
23809      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
23810     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
23811     1IANS,IWIDTH,IBUGG3,IERROR)
23812C
23813      IH='PPA1'
23814      IH2='    '
23815      VALUE0=PPA1
23816      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
23817     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
23818     1IANS,IWIDTH,IBUGG3,IERROR)
23819C
23820C               *****************
23821C               **  STEP 90--  **
23822C               **  EXIT       **
23823C               *****************
23824C
23825 9000 CONTINUE
23826      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'ORD')THEN
23827        WRITE(ICOUT,999)
23828        CALL DPWRST('XXX','BUG ')
23829        WRITE(ICOUT,9011)
23830 9011   FORMAT('***** AT THE END       OF DPORD--')
23831        CALL DPWRST('XXX','BUG ')
23832        WRITE(ICOUT,9012)IFOUND,IERROR
23833 9012   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
23834        CALL DPWRST('XXX','BUG ')
23835        WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
23836 9013   FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',3I8,2(2X,A4))
23837        CALL DPWRST('XXX','BUG ')
23838        WRITE(ICOUT,9014)CLWID,XSTART,XSTOP
23839 9014   FORMAT('CLWID,XSTART,XSTOP = ',3G15.7)
23840        CALL DPWRST('XXX','BUG ')
23841        IF(NPLOTP.GE.1)THEN
23842          DO9015I=1,NPLOTP
23843            WRITE(ICOUT,9016)I,Y(I),X(I),D(I)
23844 9016       FORMAT('I,Y(I),X(I),D(I) = ',I8,3G15.7)
23845            CALL DPWRST('XXX','BUG ')
23846 9015     CONTINUE
23847        ENDIF
23848      ENDIF
23849C
23850      RETURN
23851      END
23852      SUBROUTINE DPORD2(Y,X,N,NVAR,
23853     1                  WEIGHH,WEIGHV,TEMP1,TEMP2,
23854     1                  IDATSW,
23855     1                  PPA0,PPA1,
23856     1                  Y2,X2,D2,N2,NPLOTV,ISUBRO,IBUGG3,IERROR)
23857C
23858C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
23859C              THAT WILL DEFINE A ORD PLOT
23860C     REFERENCE--MICHAEL FRIENDLY (200), "VISUALIZING CATEGORICAL
23861C                DATA", SAS PUBLISHING, PP. 46-49.
23862C     WRITTEN BY--ALAN HECKERT
23863C                 STATISTICAL ENGINEERING DIVISION
23864C                 INFORMATION TECHNOLOGY LABORATROY
23865C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
23866C                 GAITHERSBURG, MD 20899-8980
23867C                 PHONE--301-975-2899
23868C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
23869C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
23870C     LANGUAGE--ANSI FORTRAN (1977)
23871C     VERSION NUMBER--2007/5
23872C     ORIGINAL VERSION--MAY       2007.
23873C
23874C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
23875C
23876      CHARACTER*4 IDATSW
23877      CHARACTER*4 ISUBRO
23878      CHARACTER*4 IBUGG3
23879      CHARACTER*4 IERROR
23880C
23881      CHARACTER*4 IRELAT
23882      CHARACTER*4 IRHSTG
23883      CHARACTER*4 ISUBN1
23884      CHARACTER*4 ISUBN2
23885      CHARACTER*4 ISTEPN
23886C
23887C---------------------------------------------------------------------
23888C
23889      DIMENSION Y(*)
23890      DIMENSION X(*)
23891      DIMENSION WEIGHH(*)
23892      DIMENSION WEIGHV(*)
23893      DIMENSION TEMP1(*)
23894      DIMENSION TEMP2(*)
23895      DIMENSION Y2(*)
23896      DIMENSION X2(*)
23897      DIMENSION D2(*)
23898C
23899C---------------------------------------------------------------------
23900C
23901      INCLUDE 'DPCOP2.INC'
23902C
23903C-----START POINT-----------------------------------------------------
23904C
23905      ISUBN1='DPOR'
23906      ISUBN2='D2  '
23907      IERROR='NO'
23908C
23909      NPLOTV=0
23910C
23911      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'ORD2')THEN
23912        WRITE(ICOUT,999)
23913  999   FORMAT(1X)
23914        CALL DPWRST('XXX','BUG ')
23915        WRITE(ICOUT,70)
23916   70   FORMAT('***** AT THE BEGINNING OF DPORD2--')
23917        CALL DPWRST('XXX','BUG ')
23918        WRITE(ICOUT,71)IDATSW,N,NVAR
23919   71   FORMAT('IDATSW,N,NVAR = ',A4,2X,2I8)
23920        CALL DPWRST('XXX','BUG ')
23921        DO73I=1,N
23922          WRITE(ICOUT,74)I,Y(I),X(I)
23923   74     FORMAT('I, Y(I), X(I) = ',I8,2G15.7)
23924          CALL DPWRST('XXX','BUG ')
23925   73   CONTINUE
23926      ENDIF
23927C
23928C               ********************************************
23929C               **  STEP 11--                             **
23930C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
23931C               ********************************************
23932C
23933      ISTEPN='11'
23934      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'ORD2')
23935     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23936C
23937      IF(NVAR.EQ.1)THEN
23938        HOLD=Y(1)
23939        DO1135I=2,N
23940          IF(Y(I).NE.HOLD)GOTO1139
23941 1135   CONTINUE
23942        WRITE(ICOUT,999)
23943        CALL DPWRST('XXX','WRIT')
23944        WRITE(ICOUT,1111)
23945 1111   FORMAT('***** ERROR IN ORD PLOT--')
23946        CALL DPWRST('XXX','WRIT')
23947        WRITE(ICOUT,1133)HOLD
23948 1133   FORMAT('      HAS ALL ELEMENTS = ',G15.7)
23949        CALL DPWRST('XXX','WRIT')
23950        IERROR='YES'
23951        GOTO9000
23952 1139   CONTINUE
23953C
23954        DO1145I=1,N
23955          IF(Y(I).LT.0.0)THEN
23956            WRITE(ICOUT,999)
23957            CALL DPWRST('XXX','WRIT')
23958            WRITE(ICOUT,1111)
23959            CALL DPWRST('XXX','WRIT')
23960            WRITE(ICOUT,1148)I,Y(I)
23961 1148       FORMAT('      ROW ',I8,' IS NON-POSITIVE (VALUE = ',
23962     1             G15.7,')')
23963            CALL DPWRST('XXX','WRIT')
23964            IERROR='YES'
23965            GOTO9000
23966          ENDIF
23967 1145   CONTINUE
23968C
23969        CALL SORT(Y,N,TEMP2)
23970        DO1160I=1,N
23971          Y(I)=TEMP2(I)
23972 1160   CONTINUE
23973C
23974        IRELAT='OFF'
23975        IRHSTG='OFF'
23976        XMIN=Y(1)
23977        XMAX=Y(N)
23978        XSTART=XMIN-0.5
23979        XSTOP=XMAX+0.5
23980        CLWID=1.0
23981        CALL DPBINI(Y,N,IRELAT,CLWID,XSTART,XSTOP,IRHSTG,
23982     1              TEMP2,TEMP1,N2,IBUGG3,IERROR)
23983        NTOT=N
23984        ICNT=0
23985        DO101I=1,N2
23986          IF(TEMP2(I).GT.0)THEN
23987            ICNT=ICNT+1
23988            Y(ICNT)=TEMP2(I)
23989            X(ICNT)=TEMP1(I)
23990          ENDIF
23991 101    CONTINUE
23992        N2=ICNT
23993        IF(IERROR.EQ.'YES')GOTO9000
23994C
23995      ELSEIF(NVAR.EQ.2)THEN
23996        CALL SORTC(X,Y,N,TEMP1,TEMP2)
23997        NTOT=0
23998        DO1210I=1,N
23999          X(I)=TEMP1(I)
24000          Y(I)=TEMP2(I)
24001          NTOT=NTOT + INT(Y(I))
24002 1210   CONTINUE
24003        N2=N
24004C
24005        DO1220I=1,N
24006          IF(Y(I).LT.0.0)THEN
24007            WRITE(ICOUT,999)
24008            CALL DPWRST('XXX','WRIT')
24009            WRITE(ICOUT,1111)
24010            CALL DPWRST('XXX','WRIT')
24011            WRITE(ICOUT,1223)
24012 1223       FORMAT('      A NEGATIVE FREQUENCY WAS SPECIFIED.')
24013            CALL DPWRST('XXX','WRIT')
24014            WRITE(ICOUT,1225)I,Y(I)
24015 1225       FORMAT('      ROW ',I8,' (AFTER SORTING) HAS FREQUENCY ',
24016     1             G15.7)
24017            CALL DPWRST('XXX','WRIT')
24018          ENDIF
24019 1220   CONTINUE
24020      ENDIF
24021C
24022C               ****************************************************
24023C               **  STEP 2.0--                                    **
24024C               **  GENERATE ORD PLOT:                            **
24025C               **     PLOT K*N(K)/N(K-1) VERSUS K                **
24026C               **  IF LINEAR, THEN   A+ B*X                      **
24027C               **  CAN SUGGEST POISSON, BINOMIAL,                **
24028C               **  NEGATIVE BINOMIAL, OR LOGARITHNIC SERIES      **
24029C               **  BASED ON THE VALUES OF A AND B.               **
24030C               **  SLOPE   INTERCEPT   DISTRIBUTION  ESTIMATE    **
24031C               **  ============================================= **
24032C               **    0        +        POISSON       LAMBDA = A  **
24033C               **    -        +        BINOMIAL      P = B/(B-1) **
24034C               **    +        +        NEG. BIN.     P = 1 - B   **
24035C               **    +        -        LOG SERIES    THETA = -A  **
24036C               ****************************************************
24037C
24038C     NOTE; FORMULA BELOW DEPENDS ON THE FREQUENCY FOR
24039C           (X-1) BEING POSITIVE.  SO IF THIS FREQUENCY IS
24040C           0, POINT WILL NOT BE INCLUDED IN THE PLOT.
24041C
24042      ISTEPN='2'
24043      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'ORD2')
24044     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24045C
24046      ICNT=0
24047      DO2000I=2,N2
24048        AK=X(I)
24049        AKM1=X(I-1)
24050        ANK=Y(I)
24051        ANKM1=Y(I-1)
24052        ATEMP=ABS(AK - AKM1 - 1.0)
24053        IF(ATEMP.LT.0.00001 .AND. ANKM1.GT.0.0)THEN
24054          ICNT=ICNT+1
24055          Y2(ICNT)=AK*ANK/ANKM1
24056          X2(ICNT)=AK
24057          D2(ICNT)=1.0
24058          WEIGHH(ICNT)=1.0
24059          WEIGHV(ICNT)=SQRT(ANK - 1.0)
24060        ENDIF
24061C
24062        IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'ORD2')THEN
24063          WRITE(ICOUT,2011)I,AK,AKM1,ANK,ANKM1
24064 2011     FORMAT('I,AK,AKM1,ANK,ANKM1 = ',I8,4G15.7)
24065          CALL DPWRST('XXX','BUG ')
24066          WRITE(ICOUT,2013)ICNT,Y2(ICNT),X2(ICNT)
24067 2013     FORMAT('ICNT,Y2(ICNT),X2(ICNT) = ',I8,2G15.7)
24068          CALL DPWRST('XXX','BUG ')
24069        ENDIF
24070C
24071 2000 CONTINUE
24072C
24073       N2=ICNT
24074C
24075C               ****************************************************
24076C               **  STEP 3.0--                                    **
24077C               **  NOW FIT A LINE TO THE POINTS ON THE PLOT.     **
24078C               **  USE FRIENDLY'S SUGGESTION OF WEIGHTING THE    **
24079C               **  POINTS WITH SQRT(N(K) - 1)                    **
24080C               ****************************************************
24081C
24082      ISTEPN='3'
24083      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'ORD2')
24084     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24085C
24086      IT=1
24087      I1=1
24088      I2=N2
24089      I3=1
24090      I4=N2
24091      XMAXHF=1.0
24092C
24093      CALL LINEAR(IT,I1,I2,X2,Y2,WEIGHH,WEIGHV,N2,XMAXHF,I3,I4,
24094     1            PPA0,PPA1,TEMP1,TEMP2,
24095     1            ISUBRO,IBUGG3,IERROR)
24096C
24097      NTEMP=N2
24098      DO3010I=1,NTEMP
24099        N2=N2+1
24100        Y2(N2)=TEMP1(I)
24101        X2(N2)=X2(I)
24102        D2(N2)=2.0
24103 3010 CONTINUE
24104C
24105C               ******************
24106C               **   STEP 90--  **
24107C               **   EXIT       **
24108C               ******************
24109C
24110 9000 CONTINUE
24111      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'ORD2')THEN
24112        WRITE(ICOUT,999)
24113        CALL DPWRST('XXX','BUG ')
24114        WRITE(ICOUT,9011)
24115 9011   FORMAT('***** AT THE END       OF DPORD2--')
24116        CALL DPWRST('XXX','BUG ')
24117        WRITE(ICOUT,9013)IDATSW,AN3,DENOM,N2
24118 9013   FORMAT('IDATSW,AN3,DENOM,N2 = ',A4,2X,2G15.7,I8)
24119        CALL DPWRST('XXX','BUG ')
24120        DO9015I=1,N2
24121          WRITE(ICOUT,9016)I,Y2(I),X2(I),D2(I)
24122 9016     FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,3G15.7)
24123          CALL DPWRST('XXX','BUG ')
24124 9015   CONTINUE
24125      ENDIF
24126C
24127      RETURN
24128      END
24129      SUBROUTINE DPORDE(IHARG,IHARG2,NUMARG,
24130     1IODRD1,IODRD2,IODRD3,IODRD4,IWEIN1,IWEIN2,
24131     1ICASOD,IFOUND,IERROR)
24132C
24133C     PURPOSE--DEFINE THE USER VARIABLE NAMES THAT DEFINE THE
24134C              DELTAS FOR ORTHOGONAL DISTANCE FITS.  NOTE THAT THERE
24135C              ARE THREE SETS OF VARIABLES FOR THE DELTAS:
24136C              1) YOU CAN DEFINE FROM 1 TO 20 VARIABLE NAMES
24137C                 THAT SPECIFY THE WEIGHTS FOR THE DELTAS.
24138C              2) YOU CAN DEFINE FROM 1 TO 20 VARIABLE NAMES
24139C                 THAT SPECIFY STARTING VALUES FOR THE DELTAS.
24140C                 NOTE THAT FOR MANY PROBLEMS, IT IS NOT NECESSARY
24141C                 TO SPECIFY STARTING VALUES.
24142C              IF IODRD1(1) = 'OFF', ALL DELTA WEIGHTS ARE
24143C              SET TO ZERO.  ONE VARIABLE CAN BE DEFINED TO SET
24144C              A UNIQUE DELTA WEIGHT FOR EACH COLUMN OR A SEPARATE
24145C              WEIGHT DELTA WEIGHT VARIABLE CAN BE DEFINED FOR EACH
24146C              COLUMN.  MULTIPLE VARIABLE NAMES IMPLIES EACH ELEMENT
24147C              OF THE DESIGN MATRIX HAS ITS OWN DELTA WEIGHT
24148C              VARIABLE DEFINED.  STARTING VALUES FOR THE DELTAS
24149C              THEMSELVES CAN ONLY BE SPECIFIED AS VARIABLE
24150C              NAMES (I.E., ONE VARIABLE FOR EACH COLUMN OF THE
24151C              DESIGN MATRIX).
24152C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
24153C                     --IHARG2 (A  HOLLERITH VECTOR)
24154C                     --NUMARG (AN INTEGER VARIABLE)
24155C     OUTPUT ARGUMENTS--IODRD1 (A  HOLLERITH VARIABLE)
24156C                     --IODRD2 (A  HOLLERITH VARIABLE)
24157C                     --IODRD3 (A  HOLLERITH VARIABLE)
24158C                     --IODRD4 (A  HOLLERITH VARIABLE)
24159C                     --IWEIN1 (A  HOLLERITH VARIABLE)
24160C                     --IWEIN2 (A  HOLLERITH VARIABLE)
24161C                     --IFOUND ('YES' OR 'NO' )
24162C                     --IERROR ('YES' OR 'NO' )
24163C     WRITTEN BY--JAMES J. FILLIBEN
24164C                 STATISTICAL ENGINEERING DIVISION
24165C                 INFORMATION TECHNOLOGY LABORATORY
24166C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
24167C                 GAITHERSBURG, MD 20899-8980
24168C                 PHONE--301-975-2855
24169C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
24170C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
24171C     LANGUAGE--ANSI FORTRAN (1977)
24172C     VERSION NUMBER--2001/4
24173C     ORIGINAL VERSION--APRIL     2001.
24174C
24175C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
24176C
24177      PARAMETER (MAXDEL=20)
24178      CHARACTER*4 IHARG
24179      CHARACTER*4 IHARG2
24180      CHARACTER*4 IODRD1(MAXDEL)
24181      CHARACTER*4 IODRD2(MAXDEL)
24182      CHARACTER*4 IODRD3(MAXDEL)
24183      CHARACTER*4 IODRD4(MAXDEL)
24184      CHARACTER*4 IWEIN1(MAXDEL)
24185      CHARACTER*4 IWEIN2(MAXDEL)
24186      CHARACTER*4 ICASOD
24187      CHARACTER*4 IFOUND
24188      CHARACTER*4 IERROR
24189C
24190C---------------------------------------------------------------------
24191C
24192      DIMENSION IHARG(*)
24193      DIMENSION IHARG2(*)
24194C
24195C---------------------------------------------------------------------
24196C
24197      INCLUDE 'DPCOP2.INC'
24198C
24199C-----START POINT-----------------------------------------------------
24200C
24201      IFOUND='NO'
24202      IERROR='NO'
24203C
24204C
24205C  TWO CASES:
24206C  1) DELTA WEIGHT VARIABLES
24207C  2) DELTA STARTING POINT VARIABLES
24208C
24209      IF(ICASOD.EQ.'DELT'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'WEIG')THEN
24210C
24211        DO1010I=1,MAXDEL
24212          IODRD1(I)='OFF'
24213          IODRD2(I)='   '
24214 1010   CONTINUE
24215C
24216        IF(IHARG(2).EQ.'OFF')GOTO1040
24217        IF(NUMARG.GT.1)GOTO1110
24218        IF(NUMARG.LE.1)GOTO1040
24219        GOTO1060
24220C
24221 1040   CONTINUE
24222        IODRD1(1)='OFF '
24223        IODRD2(1)='    '
24224        DO1045I=2,MAXDEL
24225          IODRD1(1)='OFF '
24226          IODRD2(1)='    '
24227 1045   CONTINUE
24228        GOTO1080
24229C
24230 1060   CONTINUE
24231        IODRD1(1)=IHARG(NUMARG)
24232        IODRD2(1)=IHARG2(NUMARG)
24233        GOTO1080
24234C
24235 1080   CONTINUE
24236        IFOUND='YES'
24237C
24238        IF(IFEEDB.EQ.'OFF')GOTO1089
24239        WRITE(ICOUT,999)
24240        CALL DPWRST('XXX','BUG ')
24241        WRITE(ICOUT,1081)IODRD1(1),IODRD2(2)
24242 1081   FORMAT('THE ORTHOGONAL DISTANCE DELTA WEIGHT VARIABLE(S) HAS ',
24243     1         'JUST BEEN DESIGNATED AS ', A4,A4)
24244        CALL DPWRST('XXX','BUG ')
24245 1089   CONTINUE
24246        GOTO1199
24247C
24248 1110   CONTINUE
24249        IFOUND='YES'
24250        IF(NUMARG.LT.2)GOTO1199
24251        DO1115J=2,MIN(NUMARG,MAXDEL+1)
24252          JM1=J-1
24253          IODRD1(JM1)=IHARG(J)
24254          IODRD2(JM1)=IHARG2(J)
24255C
24256          IF(IFEEDB.EQ.'OFF')GOTO1115
24257          WRITE(ICOUT,999)
24258  999     FORMAT(1X)
24259          CALL DPWRST('XXX','BUG ')
24260          WRITE(ICOUT,1181)JM1,IODRD1(JM1),IODRD2(JM1)
24261 1181     FORMAT('THE ORTHOGONAL DISTANCE DELTA WEIGHT VARIABLE ',I4,
24262     1           ' HAS JUST BEEN DESIGNATED AS ', A4,A4)
24263          CALL DPWRST('XXX','BUG ')
24264 1115   CONTINUE
24265        GOTO1199
24266C
24267 1199   CONTINUE
24268C
24269      ELSEIF(ICASOD.EQ.'DELT')THEN
24270C
24271        DO2010I=1,MAXDEL
24272          IODRD3(I)='OFF '
24273          IODRD4(I)='    '
24274 2010   CONTINUE
24275C
24276        IF(IHARG(1).EQ.'OFF')GOTO2040
24277        GOTO2110
24278C
24279 2040   CONTINUE
24280        DO2045I=1,MAXDEL
24281          IODRD3(1)='OFF '
24282          IODRD4(1)='    '
24283 2045   CONTINUE
24284        IFOUND='YES'
24285C
24286        IF(IFEEDB.EQ.'OFF')GOTO2089
24287        WRITE(ICOUT,999)
24288        CALL DPWRST('XXX','BUG ')
24289        WRITE(ICOUT,2081)IODRD3(1),IODRD4(2)
24290 2081   FORMAT('THE ORTHOGONAL DISTANCE DELTA STARTING VALUE ',
24291     1         'VARIABLE(S) HAS ',
24292     1         'JUST BEEN DESIGNATED AS ', A4,A4)
24293        CALL DPWRST('XXX','BUG ')
24294 2089   CONTINUE
24295        GOTO2199
24296C
24297 2110   CONTINUE
24298        IFOUND='YES'
24299        IF(NUMARG.LT.1)GOTO2199
24300        DO2115J=1,MIN(MAXDEL,NUMARG)
24301          IODRD3(J)=IHARG(J)
24302          IODRD4(J)=IHARG2(J)
24303C
24304          IF(IFEEDB.EQ.'OFF')GOTO2115
24305          WRITE(ICOUT,999)
24306          CALL DPWRST('XXX','BUG ')
24307          WRITE(ICOUT,2181)J,IODRD3(J),IODRD4(J)
24308 2181     FORMAT('THE ORTHOGONAL DISTANCE DELTA STARTING VALUES ',
24309     1           'VARIABLE ',I4,' HAS JUST BEEN DESIGNATED AS ', A4,A4)
24310          CALL DPWRST('XXX','BUG ')
24311 2115   CONTINUE
24312        GOTO2199
24313C
24314 2199   CONTINUE
24315      ELSEIF(ICASOD.EQ.'Y')THEN
24316C
24317        DO4010I=1,MAXDEL
24318          IWEIN1(I)='OFF '
24319          IWEIN2(I)='    '
24320 4010   CONTINUE
24321C
24322        IF(IHARG(2).EQ.'OFF')GOTO4040
24323        IF(NUMARG.GT.1)GOTO4110
24324        IF(NUMARG.LE.1)GOTO4040
24325        GOTO4060
24326C
24327 4040   CONTINUE
24328        IWEIN1(1)='OFF '
24329        IWEIN2(1)='    '
24330        DO4045I=2,MAXDEL
24331          IWEIN1(1)='OFF '
24332          IWEIN2(1)='    '
24333 4045   CONTINUE
24334        GOTO4080
24335C
24336 4060   CONTINUE
24337        IWEIN1(1)=IHARG(NUMARG)
24338        IWEIN2(1)=IHARG2(NUMARG)
24339        GOTO4080
24340C
24341 4080   CONTINUE
24342        IFOUND='YES'
24343C
24344        IF(IFEEDB.EQ.'OFF')GOTO4089
24345        WRITE(ICOUT,999)
24346        CALL DPWRST('XXX','BUG ')
24347        WRITE(ICOUT,4081)IWEIN1(1),IWEIN2(2)
24348 4081   FORMAT('THE ORTHOGONAL DISTANCE Y WIEGHTS VARIABLE(S) HAS ',
24349     1         'JUST BEEN DESIGNATED AS ', A4,A4)
24350        CALL DPWRST('XXX','BUG ')
24351 4089   CONTINUE
24352        GOTO4199
24353C
24354 4110   CONTINUE
24355        IFOUND='YES'
24356        IF(NUMARG.LT.2)GOTO4199
24357        DO4115J=2,MIN(NUMARG,MAXDEL+1)
24358          JM1=J-1
24359          IWEIN1(JM1)=IHARG(J)
24360          IWEIN2(JM1)=IHARG2(J)
24361C
24362          IF(IFEEDB.EQ.'OFF')GOTO4115
24363          WRITE(ICOUT,999)
24364          CALL DPWRST('XXX','BUG ')
24365          WRITE(ICOUT,4181)JM1,IWEIN1(JM1),IWEIN2(JM1)
24366 4181     FORMAT('THE ORTHOGONAL DISTANCE Y WEIGHTS VARIABLE ',I4,
24367     1           ' HAS JUST BEEN DESIGNATED AS ', A4,A4)
24368          CALL DPWRST('XXX','BUG ')
24369 4115   CONTINUE
24370        GOTO4199
24371C
24372 4199   CONTINUE
24373      ENDIF
24374      RETURN
24375      END
24376      SUBROUTINE DPORER(IHARG,IHARG2,NUMARG,
24377     1IODRE1,IODRE2,IFOUND,IERROR)
24378C
24379C     PURPOSE--DEFINE THE USER VARIABLE NAME THAT DETERMINES WHICH
24380C              COLUMNS OF THE DESIGN MATRIX ARE TREATED AS
24381C              FIXED (I.E., NO ERRORS) OR HAVE ERRORS.  THE
24382C              CHOICES ARE:
24383C                 IODRE1 = 'ON':  ALL COLUMNS HAVE ERRORS
24384C                 IODRE1 = 'OFF': NO COLUMNS HAVE ERRORS (I.E.,
24385C                                 STANDARD LEAST SQUARES WILL BE USED)
24386C              OTHERWISE, IODRE1 AND IODRE2 DEFINE A VARIABLE
24387C              THAT CONTAINS 0 (FOR NO ERRORS) OR 1 (FOR ERRORS).
24388C              THAT IS, THE FIRST ROW OF THE VARIABLE APPLIES TO
24389C              THE FIRST VARIABLE IN THE FIT, THE SECOND ROW OF THE
24390C              VARIABLE APPLLIES TO THE SECOND VARIABLE IN THE FIT,
24391C              ETC.  NOTE THAT ODRPACK ACTUALLY ALLOWS EACH ELEMENT,
24392C              NOT JUST COLUMN, OF THE DESIGN MATRIX TO BE SET.
24393C              HOWEVER, DATAPLOT LIMITS THE CHOICE ON A COLUMN
24394C              BASIS.
24395C              NOTE: UPDATED TO ALLOW A LIST OF VARIABLE NAMES.
24396C                    THIS ALLOWS THE DELTAS TO VE FIXED OR UNFIXED
24397C                    AT THE OBSERVATION LEVEL AS OPPOSED TO THE
24398C                    COLUMN LEVEL.
24399C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
24400C                     --IHARG2 (A  HOLLERITH VECTOR)
24401C                     --NUMARG (AN INTEGER VARIABLE)
24402C     OUTPUT ARGUMENTS--IODRE1 (A  HOLLERITH VARIABLE)
24403C                     --IODRE2 (A  HOLLERITH VARIABLE)
24404C                     --IFOUND ('YES' OR 'NO' )
24405C                     --IERROR ('YES' OR 'NO' )
24406C     WRITTEN BY--JAMES J. FILLIBEN
24407C                 STATISTICAL ENGINEERING DIVISION
24408C                 INFORMATION TECHNOLOGY LABORATORY
24409C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
24410C                 GAITHERSBURG, MD 20899-8980
24411C                 PHONE--301-975-2855
24412C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
24413C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
24414C     LANGUAGE--ANSI FORTRAN (1977)
24415C     VERSION NUMBER--2001/4
24416C     ORIGINAL VERSION--APRIL     2001.
24417C
24418C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
24419C
24420      PARAMETER (MAXDEL=20)
24421      CHARACTER*4 IHARG
24422      CHARACTER*4 IHARG2
24423      CHARACTER*4 IODRE1(MAXDEL)
24424      CHARACTER*4 IODRE2(MAXDEL)
24425      CHARACTER*4 IFOUND
24426      CHARACTER*4 IERROR
24427C
24428C---------------------------------------------------------------------
24429C
24430      DIMENSION IHARG(*)
24431      DIMENSION IHARG2(*)
24432C
24433C---------------------------------------------------------------------
24434C
24435      INCLUDE 'DPCOP2.INC'
24436C
24437C-----START POINT-----------------------------------------------------
24438C
24439      IFOUND='NO'
24440      IERROR='NO'
24441C
24442      IF(NUMARG.LE.1)THEN
24443        IF(NUMARG.EQ.0)THEN
24444          DO1140I=1,MAXDEL
24445            IODRE1(I)='ON  '
24446            IODRE2(I)='    '
24447 1140     CONTINUE
24448          IF(IFEEDB.EQ.'ON')THEN
24449            WRITE(ICOUT,999)
24450            CALL DPWRST('XXX','BUG ')
24451            WRITE(ICOUT,1141)
24452 1141       FORMAT('THE ORTHOGONAL DISTANCE FIT WILL ASSUME ALL ',
24453     1             'INDEPENDENT VARIABLES HAVE ERRORS.')
24454            CALL DPWRST('XXX','BUG ')
24455          ENDIF
24456        ELSEIF(IHARG(1).EQ.'ON' .OR. IHARG(1).EQ.'YES' .OR.
24457     1    IHARG(1).EQ.'AUTO' .OR. IHARG(1).EQ.'DEFA')THEN
24458          IFOUND='YES'
24459          DO1150I=1,MAXDEL
24460            IODRE1(I)='ON  '
24461            IODRE2(I)='    '
24462 1150     CONTINUE
24463          IF(IFEEDB.EQ.'ON')THEN
24464            WRITE(ICOUT,999)
24465  999       FORMAT(1X)
24466            CALL DPWRST('XXX','BUG ')
24467            WRITE(ICOUT,1151)
24468 1151       FORMAT('THE ORTHOGONAL DISTANCE FIT WILL ASSUME ALL ',
24469     1             'INDEPENDENT VARIABLES HAVE ERRORS.')
24470            CALL DPWRST('XXX','BUG ')
24471          ENDIF
24472        ELSEIF(IHARG(1).EQ.'OFF' .OR. IHARG(1).EQ.'NO' .OR.
24473     1    IHARG(1).EQ.'NONE')THEN
24474          IFOUND='YES'
24475          DO1170I=1,MAXDEL
24476            IODRE1(I)='OFF '
24477            IODRE2(I)='    '
24478 1170     CONTINUE
24479          IF(IFEEDB.EQ.'ON')THEN
24480            WRITE(ICOUT,999)
24481            CALL DPWRST('XXX','BUG ')
24482            WRITE(ICOUT,1171)
24483 1171       FORMAT('THE ORTHOGONAL DISTANCE FIT WILL ASSUME ALL ',
24484     1             'INDEPENDENT VARIABLES ARE FIXED.')
24485            CALL DPWRST('XXX','BUG ')
24486          ENDIF
24487        ELSE
24488          IFOUND='YES'
24489          IODRE1(1)=IHARG(1)
24490          IODRE2(1)=IHARG2(1)
24491          IF(IFEEDB.EQ.'ON')THEN
24492            WRITE(ICOUT,999)
24493            CALL DPWRST('XXX','BUG ')
24494            WRITE(ICOUT,1181)IODRE1(1),IODRE2(2)
24495 1181       FORMAT('THE VARIABLE ',A4,A4,' WILL DEFINE WHICH ',
24496     1             'INDEPENDENT VARIABLES ARE FIXED')
24497            CALL DPWRST('XXX','BUG ')
24498            WRITE(ICOUT,1183)
24499 1183       FORMAT('AND WHICH ARE ASSUMED TO HAVE ERRORS IN ',
24500     1             'ORTHOGONAL DISTANCE FITS.')
24501            CALL DPWRST('XXX','BUG ')
24502          ENDIF
24503        ENDIF
24504      ELSEIF(NUMARG.GT.1)THEN
24505        IFOUND='YES'
24506C
24507        DO3010I=1,MAXDEL
24508          IODRE1(I)='OFF '
24509          IODRE2(I)='    '
24510 3010   CONTINUE
24511C
24512        DO3115J=1,MIN(NUMARG,MAXDEL)
24513          IODRE1(J)=IHARG(J)
24514          IODRE2(J)=IHARG2(J)
24515C
24516          IF(IFEEDB.EQ.'OFF')GOTO3115
24517          WRITE(ICOUT,999)
24518          CALL DPWRST('XXX','BUG ')
24519          WRITE(ICOUT,3181)J,IODRE1(J),IODRE2(J)
24520 3181     FORMAT('THE ORTHOGONAL DISTANCE FIXED VARIABLE ',I4,
24521     1           ' HAS JUST BEEN DESIGNATED AS ', A4,A4)
24522          CALL DPWRST('XXX','BUG ')
24523 3115   CONTINUE
24524        GOTO3199
24525C
24526 3199   CONTINUE
24527      ENDIF
24528C
24529      RETURN
24530      END
24531      SUBROUTINE DPORSW(IHARG,NUMARG,IFOUND,IERROR)
24532C
24533C     PURPOSE--DEFINE THE ORIENTATION SWITCH IORNSW
24534C              (DETERMINES PAGE ORIENTATION.  FOR EXAMPLE,
24535C              POSTSCRIPT, QUIC AND OTHER LASER PRINTERS TYPICALLY
24536C              SUPPORT A "PORTRAIT" AND "LANDSCAPE" MODE.  ALSO INCLUDE
24537C              "POSTER" MODE FOR CALCOMP TYPE PLOTTERS THAT CAN SUPPORT
24538C              A "LARGE" PAPER SIZE.
24539C              FOR POSTSCRIPT, ADD "LANDSCAPE WORDPERFECT" OPTION.
24540C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
24541C                     --NUMARG
24542C                     --IFOUND ('YES' OR 'NO' )
24543C                     --IERROR ('YES' OR 'NO' )
24544C     WRITTEN BY--ALAN HECKERT
24545C                 COMPUTER SERVICES DIVISION
24546C                 INFORMATION TECHNOLOGY LABORATORY
24547C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
24548C                 GAITHERSBURG, MD 20899-8980
24549C                 PHONE--301-975-2899
24550C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
24551C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
24552C     LANGUAGE--ANSI FORTRAN (1977)
24553C     VERSION NUMBER--89/2
24554C     ORIGINAL VERSION--JANUARY   1989.
24555C     UPADATED        --MARCH     1990. (ADDED SQUARE OPTION, ALAN)
24556C     UPADATED        --NOVEMBER  1996. ADD "LANDSCAPE WORDPERFECT"
24557C     UPADATED        --MARCH     2006. BUG FIX: GRSEPP AUTOMATICALLY
24558C                                       TURNS DEVICE ON, SO DON'T
24559C                                       CALL GRSEPP IF DEVICE IS OFF.
24560C
24561C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
24562C
24563      CHARACTER*4 IHARG
24564      CHARACTER*4 IFOUND
24565      CHARACTER*4 IFOUN2
24566      CHARACTER*4 IERROR
24567CCCCC CHARACTER*4 IPOWER
24568      CHARACTER*4 IBUGO2
24569C
24570C---------------------------------------------------------------------
24571C
24572      DIMENSION IHARG(*)
24573C
24574C-----COMMON----------------------------------------------------------
24575C
24576      INCLUDE 'DPCOPA.INC'
24577      INCLUDE 'DPCOST.INC'
24578      INCLUDE 'DPCOGR.INC'
24579      INCLUDE 'DPCOPC.INC'
24580      INCLUDE 'DPCOF2.INC'
24581      INCLUDE 'DPCOP2.INC'
24582C
24583C-----START POINT-----------------------------------------------------
24584C
24585      IFOUND='NO'
24586      IERROR='NO'
24587      IBUGO2='OFF'
24588C
24589      IF(NUMARG.LT.1)GOTO1199
24590C
24591      IF(IHARG(NUMARG).EQ.'SQUA')GOTO1140
24592      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
24593      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
24594      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
24595      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
24596      IF(IHARG(NUMARG).EQ.'FULL')GOTO1150
24597      IF(IHARG(NUMARG).EQ.'MAXI')GOTO1150
24598      IF(IHARG(NUMARG).EQ.'LAND')GOTO1160
24599      IF(IHARG(NUMARG).EQ.'HORI')GOTO1160
24600      IF(IHARG(NUMARG).EQ.'VERT')GOTO1170
24601      IF(IHARG(NUMARG).EQ.'PORT')GOTO1170
24602      IF(IHARG(NUMARG).EQ.'POST')GOTO1175
24603CCCCC ADD FOLLOWING LINE FOR LANDSCAPE WORDPERFECT, NOVEMBER 1996.
24604      IF(IHARG(NUMARG).EQ.'WORD')GOTO1178
24605      GOTO1199
24606C
24607 1140 CONTINUE
24608      IORNSW='SQUA'
24609      GOTO1180
24610C
24611 1150 CONTINUE
24612      IORNSW='FULL'
24613      GOTO1180
24614C
24615 1160 CONTINUE
24616      IORNSW='LAND'
24617      GOTO1180
24618C
24619 1170 CONTINUE
24620      IORNSW='PORT'
24621      GOTO1180
24622C
24623 1175 CONTINUE
24624      IORNSW='POST'
24625      GOTO1180
24626C
24627 1178 CONTINUE
24628      IORNSW='LAN2'
24629      GOTO1180
24630C
24631 1180 CONTINUE
24632      IFOUND='YES'
24633C
24634C               ********************************************
24635C               **  STEP 20--                             **
24636C               **  CALL GRSEPP FOR EACH DEVICE           **
24637C               ********************************************
24638C
24639      DO2000IDEV=1,NUMDEV
24640C
24641C     MARCH 2006 BUG FIX:  ONLY CALL GRSEPP IF DEVICE IS ON.
24642C
24643      IF(IDPOWE(IDEV).NE.'ON')GOTO2000
24644C
24645      IFOUN2='NO'
24646      CALL GRSEPP(IDEV,
24647     1            IDMANU,IDMODE,IDMOD2,IDMOD3,
24648     1            IDPOWE,IDCONT,IDCOLO,IDFONT,IDNVPP,IDNHPP,IDUNIT,
24649     1            IDNVOF,IDNHOF,
24650     1            IBUGO2,IFOUN2,IERROR)
24651 2000 CONTINUE
24652C
24653      IF(IFEEDB.EQ.'OFF')GOTO1189
24654      WRITE(ICOUT,999)
24655  999 FORMAT(1X)
24656      CALL DPWRST('XXX','BUG ')
24657      WRITE(ICOUT,1181)IORNSW
24658 1181 FORMAT('THE ORIENTATION SWITCH HAS JUST BEEN SET TO ',
24659     1A4)
24660      CALL DPWRST('XXX','BUG ')
24661      WRITE(ICOUT,1182)
24662 1182 FORMAT('NOTE: THE EFFECT OF THIS COMMAND IS DEVICE DEPENDENT')
24663      CALL DPWRST('XXX','BUG ')
24664 1189 CONTINUE
24665      GOTO1199
24666C
24667 1199 CONTINUE
24668      RETURN
24669      END
24670      SUBROUTINE DPORTH(IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO,
24671     1                  IFOUND,IERROR)
24672C
24673C     PURPOSE--CARRY OUT AN ORTHOGONAL DISTANCE (ERROR IN VARIABLES)
24674C              FIT (BASED ON ODRPACK CODE)
24675C              FOR LINEAR AND NON-LINEAR MODELS.
24676C     WRITTEN BY--ALAN HECKERT
24677C                 STATISTICAL ENGINEERING DIVISION
24678C                 INFORMATION TECHNOLOGY LABORATORY
24679C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
24680C                 GAITHERSBURG, MD 20899-8980
24681C                 PHONE--301-975-2899
24682C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
24683C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
24684C     LANGUAGE--ANSI FORTRAN (1977)
24685C     VERSION NUMBER--2001/4
24686C     ORIGINAL VERSION--APRIL      2001.
24687C     UPDATED         --SEPTEMBER  2015. SUPPORT FUNCTION BLOCKS
24688C     UPDATED         --APRIL      2019. USER CAN SPECIFY NUMBER OF
24689C                                        DECIMAL POINTS FOR AUXILLARY
24690C                                        FILES
24691C     UPDATED         --JULY       2019. TWEAK SCRATCH SPACE
24692C
24693C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
24694C
24695      PARAMETER (MAXDEL=20)
24696C
24697      CHARACTER*4 IBUGA2
24698      CHARACTER*4 IBUGA3
24699      CHARACTER*4 IBUGCO
24700      CHARACTER*4 IBUGEV
24701      CHARACTER*4 IBUGQ
24702      CHARACTER*4 ISUBRO
24703      CHARACTER*4 IFOUND
24704      CHARACTER*4 IERROR
24705C
24706      CHARACTER*4 ICASFI
24707      CHARACTER*4 IH
24708      CHARACTER*4 IH2
24709      CHARACTER*4 ICASEQ
24710      CHARACTER*4 IKEY
24711      CHARACTER*4 IWD1
24712      CHARACTER*4 IWD2
24713      CHARACTER*4 IWD12
24714      CHARACTER*4 IWD22
24715      CHARACTER*4 IHPARN
24716      CHARACTER*4 IHPAR2
24717      CHARACTER*4 IREPU
24718      CHARACTER*4 IRESU
24719      CHARACTER*4 IHWUSE
24720      CHARACTER*4 MESSAG
24721      CHARACTER*4 IHRESP(MAXDEL)
24722      CHARACTER*4 IHRES2(MAXDEL)
24723      CHARACTER*4 IREP
24724      CHARACTER*4 IMPFLG
24725      CHARACTER*4 CTEMP1
24726      CHARACTER*4 CTEMP2
24727      CHARACTER*4 IHLEFT
24728      CHARACTER*4 IHLEF2
24729      CHARACTER*4 IPART1
24730      CHARACTER*4 IPART2
24731C
24732      DIMENSION IPART1(100)
24733      DIMENSION IPART2(100)
24734      DIMENSION PARTMP(100)
24735C
24736      CHARACTER*4 ISUBN1
24737      CHARACTER*4 ISUBN2
24738      CHARACTER*4 ISTEPN
24739C
24740C---------------------------------------------------------------------
24741C
24742      INCLUDE 'DPCOPA.INC'
24743      INCLUDE 'DPCOHO.INC'
24744      INCLUDE 'DPCODA.INC'
24745      INCLUDE 'DPCOZZ.INC'
24746      INCLUDE 'DPCOZ3.INC'
24747      INCLUDE 'DPCOZD.INC'
24748      INCLUDE 'DPCOZI.INC'
24749C
24750      PARAMETER (MAXFAC=20)
24751      PARAMETER (MAXOB2=MAXOBV/2)
24752C
24753      DIMENSION IPAROC(100)
24754C
24755      REAL RES2(MAXOB2)
24756      REAL PRED2(MAXOB2)
24757      DOUBLE PRECISION W(MAXOB2)
24758      DOUBLE PRECISION YTEMP(MAXOB2)
24759      DOUBLE PRECISION XMAT(10*MAXOBV)
24760      DOUBLE PRECISION RHO(20*MAXOB2)
24761      DOUBLE PRECISION WORK(35*MAXOB2)
24762C
24763      DIMENSION PARAM3(100)
24764      DIMENSION ICOLV3(100)
24765      DIMENSION NIV(100)
24766C
24767      INTEGER IFIX(MAXOB2*MAXDEL)
24768      INTEGER IWORK(MAXOBV)
24769      DIMENSION ILOCD(MAXDEL)
24770      DIMENSION ICOLD(MAXDEL)
24771      DIMENSION NDELTA(MAXDEL)
24772      DIMENSION ILOCD2(MAXDEL)
24773      DIMENSION ICOLD2(MAXDEL)
24774      DIMENSION NDELT2(MAXDEL)
24775      DIMENSION ILOCRV(MAXDEL)
24776      DIMENSION ICOLRV(MAXDEL)
24777      DIMENSION ILOCWR(MAXDEL)
24778      DIMENSION ICOLWR(MAXDEL)
24779      DIMENSION NRWEIG(MAXDEL)
24780      DIMENSION ILOCE(MAXDEL)
24781      DIMENSION ICOLE(MAXDEL)
24782      DIMENSION NERROR(MAXDEL)
24783      CHARACTER*4 IDLFLG
24784C
24785C-----COMMON----------------------------------------------------------
24786C
24787      INCLUDE 'DPCOST.INC'
24788      INCLUDE 'DPCOMC.INC'
24789      INCLUDE 'DPCOHK.INC'
24790      INCLUDE 'DPCOSU.INC'
24791C
24792C-----COMMON VARIABLES (GENERAL)--------------------------------------
24793C
24794      EQUIVALENCE (W(1),G3RBAG(KGARB1))
24795      EQUIVALENCE (PRED2(1),G3RBAG(KGARB2))
24796      EQUIVALENCE (RES2(1),G3RBAG(KGARB3))
24797      EQUIVALENCE (YTEMP(1),G3RBAG(KGARB4))
24798C
24799      EQUIVALENCE (RHO(1),Y(1))
24800      EQUIVALENCE (WORK(1),GARBAG(IGARB1))
24801      EQUIVALENCE (DGARBG(IDGAR1),XMAT(1))
24802C
24803      EQUIVALENCE (IGARBG(IIGAR1),IFIX(1))
24804      EQUIVALENCE (IGARBG(IIGR17),IWORK(1))
24805C
24806      PARAMETER (IODRCH=1000)
24807      PARAMETER (IODRC2=100)
24808      PARAMETER (MAXNQ=5)
24809C
24810      CHARACTER*4 IBUGAZ
24811      CHARACTER*4 ZTYPEH
24812      CHARACTER*4 ZW21HO
24813      CHARACTER*4 ZW22HO
24814      CHARACTER*4 ZIPARN
24815      CHARACTER*4 ZPARN2
24816      CHARACTER*4 ZMODEL
24817      CHARACTER*4 ZIDUMV
24818      CHARACTER*4 ZDUMV2
24819C
24820      DIMENSION ZPARAM(IODRC2,MAXNQ)
24821      DIMENSION ZIPARN(IODRC2,MAXNQ)
24822      DIMENSION ZPARN2(IODRC2,MAXNQ)
24823      DIMENSION ZIDUMV(IODRC2,MAXNQ)
24824      DIMENSION ZDUMV2(IODRC2,MAXNQ)
24825      DIMENSION LOCDUM(IODRC2,MAXNQ)
24826C
24827      DIMENSION ZMODEL(IODRCH,MAXNQ)
24828      DIMENSION ZTYPEH(IODRCH,MAXNQ)
24829      DIMENSION ZW21HO(IODRCH,MAXNQ)
24830      DIMENSION ZW22HO(IODRCH,MAXNQ)
24831      DIMENSION Z2HOLD(IODRCH,MAXNQ)
24832C
24833      INTEGER NUMCHZ(MAXNQ)
24834      INTEGER NUMPAZ(MAXNQ)
24835      INTEGER NWHOLZ(MAXNQ)
24836      INTEGER NUMVAZ(MAXNQ)
24837C
24838      COMMON /ODRCMC/ IBUGAZ, ZTYPEH, ZW21HO, ZW22HO, ZIPARN, ZPARN2,
24839     &                ZIDUMV, ZDUMV2, ZMODEL
24840      COMMON /ODRCMR/ ZPARAM, Z2HOLD,
24841     &                NUMCHZ, NUMPAZ, NWHOLZ, NUMVAZ, LOCDUM
24842C
24843      CHARACTER*4 IPAROC
24844      CHARACTER*4 IPARO3
24845      CHARACTER*4 IPARN3
24846      CHARACTER*4 IPARN4
24847      CHARACTER*4 IVARN3
24848      CHARACTER*4 IVARN4
24849      DIMENSION IPARN3(100)
24850      DIMENSION IPARN4(100)
24851      DIMENSION ICON3(100)
24852      DIMENSION IPARO3(100)
24853      DIMENSION PARLI3(100)
24854      DIMENSION IVARN3(100)
24855      DIMENSION IVARN4(100)
24856C
24857      COMMON /ODRCM2/ IPAROC, IPARO3, IPARN3, IPARN4, IVARN3, IVARN4
24858      COMMON /ODRCR2/ ICON3, PARLI3, NUMPAR, NUMVAR
24859C
24860C---------------------------------------------------------------------
24861C
24862      INCLUDE 'DPCOP2.INC'
24863C
24864C-----START POINT-----------------------------------------------------
24865C
24866      ISUBN1='DPOR'
24867      ISUBN2='TH  '
24868      IERROR='NO'
24869      IMPFLG='OFF'
24870      IPAROC(1)='NONE'
24871C
24872      MAXCP1=MAXCOL+1
24873      MAXCP2=MAXCOL+2
24874      MAXCP3=MAXCOL+3
24875      MAXCP4=MAXCOL+4
24876      MAXCP5=MAXCOL+5
24877      MAXCP6=MAXCOL+6
24878      MAXV2=MAXDEL
24879      MAXYV2=5
24880      MINN2=2
24881      NQ=1
24882      MAXITS=IFITIT
24883      MAXN2=MAXCHF
24884      MAXN3=MAXCHF
24885      MAXN4=MAXCHF
24886C
24887      NUMPV=(-999)
24888      IP=(-999)
24889      IV=(-999)
24890      IWIDMO=(-999)
24891      NUMIND=(-999)
24892      ILOCE2=0
24893      ICOL1=0
24894      ICOLL=0
24895      ILOCV=0
24896C
24897C               **************************
24898C               **  TREAT THE FIT CASE  **
24899C               **************************
24900C
24901      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH')THEN
24902        WRITE(ICOUT,999)
24903  999   FORMAT(1X)
24904        CALL DPWRST('XXX','BUG ')
24905        WRITE(ICOUT,51)
24906   51   FORMAT('***** AT THE BEGINNING OF DPORTH--')
24907        CALL DPWRST('XXX','BUG ')
24908        WRITE(ICOUT,53)IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO
24909   53   FORMAT('IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO = ',
24910     1         5(A4,2X),A4)
24911        CALL DPWRST('XXX','BUG ')
24912        WRITE(ICOUT,56)NUMNAM
24913   56   FORMAT('NUMNAM = ',I8)
24914        CALL DPWRST('XXX','BUG ')
24915      ENDIF
24916C
24917C               ***************************
24918C               **  STEP 1--             **
24919C               **  EXTRACT THE COMMAND  **
24920C               ***************************
24921C
24922      ISTEPN='1'
24923      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH')
24924     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24925C
24926      IF(ICOM.EQ.'ORTH'.AND.IHARG(1).EQ.'DIST'.AND.
24927     1   IHARG(2).EQ.'FIT ')THEN
24928        ILASTC=2
24929      ELSEIF(ICOM.EQ.'ORTH'.AND.IHARG(1).EQ.'DIST'.AND.
24930     1   IHARG(2).EQ.'REGR')THEN
24931        ILASTC=2
24932      ELSEIF(ICOM.EQ.'ERRO'.AND.IHARG(1).EQ.'IN  '.AND.
24933     1   IHARG(2).EQ.'VARI'.AND.IHARG(3).EQ.'FIT ')THEN
24934        ILASTC=3
24935      ELSEIF(ICOM.EQ.'ERRO'.AND.IHARG(1).EQ.'IN  '.AND.
24936     1   IHARG(2).EQ.'VARI'.AND.IHARG(3).EQ.'REGR')THEN
24937        ILASTC=3
24938      ELSE
24939        IFOUND='NO'
24940        GOTO9000
24941      ENDIF
24942C
24943      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
24944      IFOUND='YES'
24945      ICASFI='ORTF'
24946C
24947      IF(ICASFI.EQ.'    ')GOTO9000
24948C
24949C               *******************************************************
24950C               **  STEP 2--                                         **
24951C               **  CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS.  **
24952C               *******************************************************
24953C
24954      ISTEPN='2'
24955      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH')
24956     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24957C
24958      MINNA=0
24959      MAXNA=100
24960      CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,
24961     1IERROR)
24962      IF(IERROR.EQ.'YES')GOTO9000
24963C
24964C               ******************************************************
24965C               **  STEP 3--                                        **
24966C               **  FOR THE CASES WHEN HAVE FIT Y = SOME EXPRESSION **
24967C               **  DETERMINE IF WE HAVE A VALID FUNCTIONAL         **
24968C               **  EXPRESSION--IN PARTICULAR, CHECK THAT THE NUMBER**
24969C               **  OF ARGUMENTS IS AT LEAST 1, AND ALSO CHECK      **
24970C               **  THAT THERE IS EXACTLY 1 EQUAL SIGN AND THAT     **
24971C               **  THIS EQUAL SIGN OCCURS AS THE SECOND ARGUMENT.  **
24972C               ******************************************************
24973C
24974      ISTEPN='3'
24975      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH')
24976     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24977C
24978      IF(NUMARG.LT.1)THEN
24979        WRITE(ICOUT,2001)
24980 2001   FORMAT('***** ERROR IN ORTHOGONAL DISTANCE REGRESSION--')
24981        CALL DPWRST('XXX','BUG ')
24982        WRITE(ICOUT,2002)
24983 2002   FORMAT('      NUMBER OF ARGUMENTS DETECTED = 0.')
24984        CALL DPWRST('XXX','BUG ')
24985        WRITE(ICOUT,2007)
24986 2007   FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
24987        CALL DPWRST('XXX','BUG ')
24988        IF(IWIDTH.GE.1)THEN
24989          WRITE(ICOUT,2008)(IANS(J),J=1,MIN(100,IWIDTH))
24990 2008     FORMAT('      COMMAND LINE--',100A1)
24991          CALL DPWRST('XXX','BUG ')
24992        ENDIF
24993        IERROR='YES'
24994        GOTO9000
24995      ENDIF
24996C
24997      DO2100J=1,NUMARG
24998        J1=J
24999        IF((IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET  ') .OR.
25000     1     (IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT  ') .OR.
25001     1     (IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.'    '))THEN
25002          ILOCQ=J1
25003          GOTO2120
25004        ENDIF
25005 2100 CONTINUE
25006      ILOCQ=NUMARG+1
25007 2120 CONTINUE
25008C
25009      IF(ICASFI.EQ.'ORTF')THEN
25010        NUMEQ=0
25011        IMAX=ILOCQ-1
25012        DO2130I=1,IMAX
25013          IF(IHARG(I).EQ.'=   '.AND.IHARG2(I).EQ.'    ')THEN
25014            NUMEQ=NUMEQ+1
25015            NQ=I-1
25016            ILOCE2=I
25017          ENDIF
25018 2130   CONTINUE
25019C
25020        IF(NUMEQ.GT.1)THEN
25021          WRITE(ICOUT,2001)
25022          CALL DPWRST('XXX','BUG ')
25023          WRITE(ICOUT,2132)
25024 2132     FORMAT('      NUMBER OF EQUAL SIGNS DETECTED')
25025          CALL DPWRST('XXX','BUG ')
25026          WRITE(ICOUT,2133)NUMEQ
25027 2133     FORMAT('      IN MODEL GREATER THAN 1.  NUMEQ = ',I6)
25028          CALL DPWRST('XXX','BUG ')
25029          WRITE(ICOUT,2134)NUMARG,IMAX
25030 2134     FORMAT('      NUMARG, IMAX = ',2I10)
25031          CALL DPWRST('XXX','BUG ')
25032          DO2135I=1,NUMARG
25033            WRITE(ICOUT,2136)I,IHARG(I),IHARG2(I)
25034 2136       FORMAT('I,IHARG(I),IHARG2(I) = ',I8,A4,A4)
25035            CALL DPWRST('XXX','BUG ')
25036 2135     CONTINUE
25037          WRITE(ICOUT,2007)
25038          CALL DPWRST('XXX','BUG ')
25039          IF(IWIDTH.GE.1)THEN
25040            WRITE(ICOUT,2008)(IANS(J),J=1,MIN(100,IWIDTH))
25041            CALL DPWRST('XXX','BUG ')
25042          ENDIF
25043          IERROR='YES'
25044          GOTO9000
25045        ELSEIF(NUMEQ.EQ.0)THEN
25046          IMPFLG='ON'
25047        ENDIF
25048C
25049        IF(NQ.GT.1)THEN
25050          WRITE(ICOUT,999)
25051          CALL DPWRST('XXX','BUG ')
25052          WRITE(ICOUT,2141)
25053 2141     FORMAT('FOR ORTHOGONAL DISTANCE FIT, MULTIPLE RESPONSE ',
25054     1           'VARIABLES CASE DETECTED.')
25055          CALL DPWRST('XXX','BUG ')
25056          WRITE(ICOUT,2143)NQ
25057 2143     FORMAT('NUMBER OF RESPONSE VARIABLES = ',I5)
25058          CALL DPWRST('XXX','BUG ')
25059          IF(NQ.GT.MAXDEL)THEN
25060            WRITE(ICOUT,999)
25061            CALL DPWRST('XXX','BUG ')
25062            WRITE(ICOUT,2001)
25063            CALL DPWRST('XXX','BUG ')
25064            WRITE(ICOUT,2145)MAXDEL
25065 2145       FORMAT('      MAXIMIUM NUMBER OF RESPONSE VARIABLES,',
25066     1             I5,', EXCEEDED.')
25067            CALL DPWRST('XXX','BUG ')
25068            IERROR='YES'
25069            GOTO9000
25070          ENDIF
25071        ENDIF
25072      ENDIF
25073C
25074      IF(ICASFI.EQ.'ORTF'.AND.IHARG(2).NE.'='.AND.
25075     1   NQ.EQ.1.AND.IMPFLG.EQ.'OFF')THEN
25076        WRITE(ICOUT,999)
25077        CALL DPWRST('XXX','BUG ')
25078        WRITE(ICOUT,2001)
25079        CALL DPWRST('XXX','BUG ')
25080        WRITE(ICOUT,2202)
25081 2202   FORMAT('      WHEN FITTING GENERAL EXPRESSIONS,')
25082        CALL DPWRST('XXX','BUG ')
25083        WRITE(ICOUT,2203)
25084 2203   FORMAT('      THE SECOND ARGUMENT AFTER THE WORD     FIT')
25085        CALL DPWRST('XXX','BUG ')
25086        WRITE(ICOUT,2204)
25087 2204   FORMAT('      SHOULD BE (BUT WAS NOT) AN EQUAL SIGN.')
25088        CALL DPWRST('XXX','BUG ')
25089        IF(ICASFI.EQ.'ORTF')THEN
25090          WRITE(ICOUT,2205)IHARG(2),IHARG2(2)
25091 2205     FORMAT('     THE ARGUMENT WAS ',A4,A4)
25092          CALL DPWRST('XXX','BUG ')
25093        ENDIF
25094        WRITE(ICOUT,2007)
25095        CALL DPWRST('XXX','BUG ')
25096        IF(IWIDTH.GE.1)THEN
25097          WRITE(ICOUT,2008)(IANS(J),J=1,MIN(100,IWIDTH))
25098          CALL DPWRST('XXX','BUG ')
25099        ENDIF
25100        IERROR='YES'
25101        GOTO9000
25102      ENDIF
25103C
25104C               ****************************************************
25105C               **  STEP 4--                                      **
25106C               **  FOR ALL VARIATIONS OF THE COMMAND,            **
25107C               **  THE WORD AFTER  FIT  SHOULD BE THE RESPONSE   **
25108C               **  VARIABLE (= THE DEPENDENT VARIABLE).          **
25109C               **  EXTRACT THE RESPONSE VARIABLE AND DETERMINE   **
25110C               **  IF IT IS ALREADY IN THE NAME LIST AND IS, IN  **
25111C               **  FACT, A VARIABLE (AS OPPOSED TO A PARAMETER). **
25112C               **  NOTE: FOR IMPLICIT MODEL, NO RESPONSE         **
25113C               **        VARIABLE.                               **
25114C               ****************************************************
25115C
25116      ISTEPN='4'
25117      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH')
25118     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25119C
25120      IF(IMPFLG.EQ.'ON')THEN
25121        I2=0
25122        NLEFT=-1
25123        IHLEFT='    '
25124        IHLEF2='    '
25125        GOTO2390
25126      ENDIF
25127C
25128      I2=0
25129C
25130      ILOCFI=I2
25131C
25132      DO2310J=1,NQ
25133        ILOCF1=ILOCFI+1
25134        IF(J.EQ.1)THEN
25135          IHLEFT=IHARG(ILOCF1)
25136          IHLEF2=IHARG2(ILOCF1)
25137        ENDIF
25138        IHRESP(J)=IHARG(ILOCF1)
25139        IHRES2(J)=IHARG2(ILOCF1)
25140        DO2350I=1,NUMNAM
25141          I2=I
25142          IF(IHRESP(J).EQ.IHNAME(I2).AND.IHRES2(J).EQ.IHNAM2(I2).AND.
25143     1       IUSE(I2).EQ.'V')GOTO2379
25144 2350   CONTINUE
25145C
25146        WRITE(ICOUT,2001)
25147        CALL DPWRST('XXX','BUG ')
25148        WRITE(ICOUT,2362)
25149 2362   FORMAT('      A NAME BETWEEN THE WORD FIT AND THE "=" SIGN')
25150        CALL DPWRST('XXX','BUG ')
25151        WRITE(ICOUT,2363)
25152 2363   FORMAT('      (WHICH SHOULD BE A RESPONSE VARIABLE)')
25153        CALL DPWRST('XXX','BUG ')
25154        WRITE(ICOUT,2364)
25155 2364   FORMAT('      EITHER DOES NOT EXIST OR IS A PARAMETER ',
25156     1         '(AS OPPOSED')
25157        CALL DPWRST('XXX','BUG ')
25158        WRITE(ICOUT,2366)
25159 2366   FORMAT('      TO A VARIABLE) IN THE CURRENT LIST OF')
25160        CALL DPWRST('XXX','BUG ')
25161        WRITE(ICOUT,2367)
25162 2367   FORMAT('      AVAILABLE VARIABLE AND PARAMETER NAMES.')
25163        CALL DPWRST('XXX','BUG ')
25164        WRITE(ICOUT,999)
25165        CALL DPWRST('XXX','BUG ')
25166        WRITE(ICOUT,2369)IHRESP(J),IHRES2(J)
25167 2369   FORMAT('      NAME AFTER THE WORD FIT = ',A4,A4)
25168        CALL DPWRST('XXX','BUG ')
25169        WRITE(ICOUT,2007)
25170        CALL DPWRST('XXX','BUG ')
25171        IF(IWIDTH.GE.1)THEN
25172          WRITE(ICOUT,2008)(IANS(JJ),JJ=1,MIN(100,IWIDTH))
25173          CALL DPWRST('XXX','BUG ')
25174        ENDIF
25175        IERROR='YES'
25176        GOTO9000
25177C
25178 2379   CONTINUE
25179        IF(J.EQ.1)THEN
25180          ILOCV=I2
25181          ICOLL=IVALUE(ILOCV)
25182          NLEFT=IN(ILOCV)
25183        ELSE
25184          ILOCRV(J)=I2
25185          ICOLRV(J)=IVALUE(ILOCV)
25186          NTEMP=IN(ILOCV)
25187          IF(NTEMP.NE.NLEFT)THEN
25188            WRITE(ICOUT,2001)
25189            CALL DPWRST('XXX','BUG ')
25190            WRITE(ICOUT,2383)
25191 2383       FORMAT('      ALL RESPONSE VARIABLES MUST HAVE THE SAME',
25192     1             'NUMBER OF OBSERVATIONS.')
25193            CALL DPWRST('XXX','BUG ')
25194            WRITE(ICOUT,2385)IHRESP(J),IHRES2(J),NTEMP
25195 2385       FORMAT('      RESPONSE VARIABLE ',A4,A4,' HAS ',I8,
25196     1             'OBSERVATIONS.')
25197            CALL DPWRST('XXX','BUG ')
25198            WRITE(ICOUT,2387)NLEFT
25199 2387       FORMAT('      NUMBER OF OBSEVATIONS EXPECTED: ',I8)
25200            CALL DPWRST('XXX','BUG ')
25201            WRITE(ICOUT,2007)
25202            CALL DPWRST('XXX','BUG ')
25203            IF(IWIDTH.GE.1)THEN
25204              WRITE(ICOUT,2008)(IANS(JJ),JJ=1,MIN(100,IWIDTH))
25205              CALL DPWRST('XXX','BUG ')
25206            ENDIF
25207            IERROR='YES'
25208            GOTO9000
25209          ENDIF
25210        ENDIF
25211 2310 CONTINUE
25212C
25213 2390 CONTINUE
25214C
25215C               ****************************************************
25216C               **  STEP 5--                                      **
25217C               **  FOR ALL VARIATIONS OF THE COMMAND, CHECK THAT **
25218C               **  THE INPUT NUMBER OF OBSERVATIONS (NLEFT)      **
25219C               **  FOR THE RESPONSE VARIABLE IS 2 OR LARGER AND  **
25220C               **  LESS THAN MAXOB2.                             **
25221C               ****************************************************
25222C
25223      ISTEPN='5'
25224      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH')
25225     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25226C
25227      IF(IMPFLG.NE.'ON' .AND.
25228     1   (NLEFT.LT.MINN2 .OR. NLEFT.GT.MAXOB2))THEN
25229        WRITE(ICOUT,999)
25230        CALL DPWRST('XXX','BUG ')
25231        WRITE(ICOUT,2001)
25232        CALL DPWRST('XXX','BUG ')
25233        WRITE(ICOUT,312)IHLEFT,IHLEF2
25234  312   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS (FOR WHICH AN ',
25235     1         '(IN VARIABLE ',A4,A4,')')
25236        CALL DPWRST('XXX','BUG ')
25237        WRITE(ICOUT,313)
25238  313   FORMAT('      ORTHOGONAL DISTANCE FIT WAS TO HAVE BEEN')
25239        CALL DPWRST('XXX','BUG ')
25240        WRITE(ICOUT,315)MINN2
25241  315   FORMAT('      PERFORMED MUST BE AT LEAST ',I8,' AND NO MORE')
25242        CALL DPWRST('XXX','BUG ')
25243        WRITE(ICOUT,316)
25244  316   FORMAT('      THAN ',I8,';  SUCH WAS NOT THE CASE HERE.')
25245        CALL DPWRST('XXX','BUG ')
25246        WRITE(ICOUT,317)NLEFT
25247  317   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS = ',I8)
25248        CALL DPWRST('XXX','BUG ')
25249        WRITE(ICOUT,2007)
25250        CALL DPWRST('XXX','BUG ')
25251        IF(IWIDTH.GE.1)THEN
25252          WRITE(ICOUT,2008)(IANS(J),J=1,MIN(100,IWIDTH))
25253          CALL DPWRST('XXX','BUG ')
25254        ENDIF
25255        IERROR='YES'
25256        GOTO9000
25257      ENDIF
25258C
25259C               ************************************************
25260C               **  STEP 5.1--                                **
25261C               **  CHECK TO SEE IF HAVE A WEIGHTS VARIABLE.  **
25262C               **  IF DO HAVE, CHECK TO SEE IF A VARIABLE    **
25263C               **  (AS OPPOSED TO A PARAMETER).              **
25264C               **  NOTE: TWO WAYS TO DEFINE WEIGHT VARIABLES:**
25265C               **  1) WEIGHTS COMMAND   - FOR SINGLE         **
25266C               **     RESPONSE CASE ONLY.                    **
25267C               **  2) ORTOGONAL DISTANCE Y WEIGHTS - FOR     **
25268C               **     EITHER SINGLE RESPONSE OR              **
25269C               **     MULTI-RESPONSE CASES.                  **
25270C               **  NOTE THAT IF BOTH SPECIFIED FOR SINGLE    **
25271C               **  RESPONSE CASE, THEN METHOD 2 OVERRIDES.   **
25272C               ************************************************
25273C
25274      ISTEPN='5.1'
25275      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH')
25276     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25277C
25278      ILOCW=-99
25279      ICOLW=-99
25280      NWEIGH=-99
25281      DO2405I=1,MAXDEL
25282        ILOCWR(I)=-99
25283        ICOLWR(I)=-99
25284        NRWEIG(I)=-99
25285 2405 CONTINUE
25286C
25287      IF(IMPFLG.EQ.'ON')GOTO2490
25288      IF(IWEIGH.EQ.'OFF'.AND.IWEIN1(1).EQ.'OFF')GOTO2490
25289C
25290      IF(NQ.EQ.1.AND.J.EQ.1 .AND. IWEIN1(1).EQ.'OFF')THEN
25291        CTEMP1=IWEIG1
25292        CTEMP2=IWEIG2
25293        DO2420I=1,NUMNAM
25294          I2=I
25295          IF(IWEIG1.EQ.IHNAME(I2).AND.IWEIG2.EQ.IHNAM2(I2).AND.
25296     1       IUSE(I2).EQ.'V')THEN
25297             ILOCW=I2
25298             ICOLW=IVALUE(ILOCW)
25299             NWEIGH=IN(ILOCW)
25300             ILOCWR(1)=ILOCW
25301             ICOLWR(1)=ICOLW
25302             NRWEIG(1)=NWEIGH
25303             IF(NWEIGH.NE.NLEFT)GOTO2481
25304             GOTO2490
25305          ENDIF
25306 2420   CONTINUE
25307        GOTO2460
25308      ENDIF
25309C
25310      DO2410J=1,NQ
25311C
25312        CTEMP1=IWEIN1(J)
25313        CTEMP2=IWEIN2(J)
25314        DO2450I=1,NUMNAM
25315          I2=I
25316          IF(IWEIN1(J).EQ.IHNAME(I2).AND.IWEIN2(J).EQ.IHNAM2(I2).AND.
25317     1         IUSE(I2).EQ.'V')THEN
25318            ILOCWR(J)=I2
25319            ICOLWR(J)=IVALUE(ILOCWR(J))
25320            NRWEIG(J)=IN(ILOCWR(J))
25321            IF(NRWEIG(J).NE.NLEFT)GOTO2481
25322            GOTO2490
25323          ENDIF
25324 2450   CONTINUE
25325C
25326 2410 CONTINUE
25327C
25328 2460 CONTINUE
25329      WRITE(ICOUT,999)
25330      CALL DPWRST('XXX','BUG ')
25331      WRITE(ICOUT,2001)
25332      CALL DPWRST('XXX','BUG ')
25333      WRITE(ICOUT,2461)
25334 2461 FORMAT('      A WEIGHT VARIABLE FOR THE RESPONSE VARIABLE')
25335      CALL DPWRST('XXX','BUG ')
25336      WRITE(ICOUT,2463)
25337 2463 FORMAT('      (AS SPECIFIED VIA THE WEIGHTS COMMAND OR THE ',
25338     1       'ORTHOGONAL DISTANCE Y WEIGHTS COMMAND)')
25339      CALL DPWRST('XXX','BUG ')
25340      WRITE(ICOUT,2465)
25341 2465 FORMAT('      EITHER DOES NOT EXIST OR IS A PARAMETER (AS ',
25342     1       'OPPOSED TO A VARIABLE)')
25343      CALL DPWRST('XXX','BUG ')
25344      WRITE(ICOUT,2466)
25345 2466 FORMAT('      IN THE CURRENT LIST OF AVAILABLE VARIABLE AND ',
25346     1       'PARAMETER NAMES.')
25347      CALL DPWRST('XXX','BUG ')
25348      WRITE(ICOUT,2469)CTEMP1,CTEMP2
25349 2469 FORMAT('      NAME OF SPECIFIED WEIGHTS VARIABLE = ',A4,A4)
25350      CALL DPWRST('XXX','BUG ')
25351      WRITE(ICOUT,2007)
25352      CALL DPWRST('XXX','BUG ')
25353      IF(IWIDTH.GE.1)THEN
25354        WRITE(ICOUT,2008)(IANS(J),J=1,MIN(100,IWIDTH))
25355        CALL DPWRST('XXX','BUG ')
25356      ENDIF
25357      IERROR='YES'
25358      GOTO9000
25359C
25360 2481 CONTINUE
25361      WRITE(ICOUT,999)
25362      CALL DPWRST('XXX','BUG ')
25363      WRITE(ICOUT,2001)
25364      CALL DPWRST('XXX','BUG ')
25365      WRITE(ICOUT,2483)
25366 2483 FORMAT('      A WEIGHT VARIABLE FOR THE RESPONSE VARIABLE')
25367      CALL DPWRST('XXX','BUG ')
25368      WRITE(ICOUT,2485)
25369 2485 FORMAT('      DOES NOT HAVE THE SAME NUMBER OF OBSERVATIONS ',
25370     1       'AS THE RESPONSE VARIABLE')
25371      CALL DPWRST('XXX','BUG ')
25372      WRITE(ICOUT,2487)CTEMP1,CTEMP2,NRWEIG(J)
25373 2487 FORMAT('      WEIGHT VARIABLE, ',A4,A4,' HAS ',I8,
25374     1       'OBSEVATIONS.')
25375      CALL DPWRST('XXX','BUG ')
25376      WRITE(ICOUT,2489)NLEFT
25377 2489 FORMAT('      NUMBER OF OBSEVATIONS EXPECTED: ',I8)
25378      CALL DPWRST('XXX','BUG ')
25379      WRITE(ICOUT,2007)
25380      CALL DPWRST('XXX','BUG ')
25381      IF(IWIDTH.GE.1)THEN
25382        WRITE(ICOUT,2008)(IANS(J),J=1,MIN(100,IWIDTH))
25383        CALL DPWRST('XXX','BUG ')
25384      ENDIF
25385      IERROR='YES'
25386      GOTO9000
25387C
25388 2490 CONTINUE
25389C
25390C               ************************************************
25391C               **  STEP 5.2--                                **
25392C               **  CHECK TO SEE IF HAVE A "ERROR" VARIABLE.  **
25393C               **  IF DO HAVE, CHECK TO SEE IF A VARIABLE    **
25394C               **  (AS OPPOSED TO A PARAMETER).              **
25395C               ************************************************
25396C
25397      ISTEPN='5.2'
25398      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH')
25399     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25400C
25401      DO2510I=1,MAXDEL
25402        ILOCE(I)=-99
25403        ICOLE(I)=-99
25404        NERROR(I)=-99
25405 2510 CONTINUE
25406      NUMERR=0
25407C
25408      IF(IODRE1(1).EQ.'ON')THEN
25409        CONTINUE
25410      ELSEIF(IODRE1(1).NE.'OFF')THEN
25411        DO2540J=1,MAXDEL
25412          IF(IODRE1(J).EQ.'OFF' .OR. IODRE1(J).EQ.'ON')GOTO2549
25413          DO2550I=1,NUMNAM
25414            I2=I
25415            IF(IODRE1(J).EQ.IHNAME(I2).AND.IODRE2(J).EQ.IHNAM2(I2).AND.
25416     1         IUSE(I2).EQ.'V')THEN
25417              NUMERR=NUMERR+1
25418              ILOCE(J)=I2
25419              ICOLE(J)=IVALUE(ILOCE(J))
25420              NERROR(J)=IN(ILOCE(J))
25421              GOTO2540
25422            ENDIF
25423 2550     CONTINUE
25424C
25425          WRITE(ICOUT,999)
25426          CALL DPWRST('XXX','BUG ')
25427          WRITE(ICOUT,2001)
25428          CALL DPWRST('XXX','BUG ')
25429          WRITE(ICOUT,2561)
25430 2561     FORMAT('      ONE OF THE ERRORS VARIABLE (AS SPECIFIED VIA')
25431          CALL DPWRST('XXX','BUG ')
25432          WRITE(ICOUT,2563)
25433 2563     FORMAT('      THE ORTHOGONAL DISTANCE ERROR COMMAND) EITHER ',
25434     1           'DOES NOT')
25435          CALL DPWRST('XXX','BUG ')
25436          WRITE(ICOUT,2565)
25437 2565     FORMAT('      EXIST OR IS A PARAMETER (AS OPPOSED TO A',
25438     1           ' VARIABLE) IN')
25439          CALL DPWRST('XXX','BUG ')
25440          WRITE(ICOUT,2566)
25441 2566     FORMAT('      THE CURRENT LIST OF AVAILABLE ',
25442     1           'VARIABLE AND PARAMETER NAMES.')
25443          CALL DPWRST('XXX','BUG ')
25444          WRITE(ICOUT,2569)IODRE1(J),IODRE2(J)
25445 2569     FORMAT('      NAME OF SPECIFIED ERRORS VARIABLE = ',A4,A4)
25446          CALL DPWRST('XXX','BUG ')
25447          WRITE(ICOUT,2007)
25448          CALL DPWRST('XXX','BUG ')
25449          IF(IWIDTH.GE.1)THEN
25450            WRITE(ICOUT,2008)(IANS(KK),KK=1,MIN(100,IWIDTH))
25451            CALL DPWRST('XXX','BUG ')
25452          ENDIF
25453          IERROR='YES'
25454          GOTO9000
25455C
25456 2540   CONTINUE
25457 2549   CONTINUE
25458      ENDIF
25459C
25460C               ************************************************
25461C               **  STEP 5.3--                                **
25462C               **  CHECK TO SEE IF HAVE ONE OR MORE  DELTA   **
25463C               **  WEIGHT VARIABLE(S).                       **
25464C               **  IF DO HAVE, CHECK TO SEE IF A VARIABLE    **
25465C               **  (AS OPPOSED TO A PARAMETER).              **
25466C               ************************************************
25467C
25468      ISTEPN='5.3'
25469      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH')
25470     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25471C
25472      IDLFLG='OFF'
25473      NUMDEL=0
25474C
25475      DO2610I=1,MAXDEL
25476        ILOCD(I)=-99
25477        ICOLD(I)=-99
25478        NDELTA(I)=-99
25479 2610 CONTINUE
25480C
25481      IF(IODRD1(1).EQ.'OFF')GOTO2699
25482      IF(IODRD1(1).EQ.'ON')THEN
25483        IDLFLG='DEFA'
25484      ELSEIF(IODRD1(1).NE.'OFF')THEN
25485        DO2640J=1,MAXDEL
25486          IF(IODRD1(J).EQ.'OFF')GOTO2649
25487          DO2650I=1,NUMNAM
25488            I2=I
25489            IF(IODRD1(J).EQ.IHNAME(I2).AND.IODRD2(J).EQ.IHNAM2(I2).AND.
25490     1      IUSE(I2).EQ.'V')GOTO2679
25491 2650     CONTINUE
25492          WRITE(ICOUT,999)
25493          CALL DPWRST('XXX','BUG ')
25494          WRITE(ICOUT,2661)
25495 2661 FORMAT('***** ERROR IN DPORTH--ONE OF THE DELTA WEIGHT VARIABLES',
25496     1       ' (AS SPECIFIED')
25497          CALL DPWRST('XXX','BUG ')
25498          WRITE(ICOUT,2663)
25499 2663 FORMAT('      VIA THE ORTHOGONAL DISTANCE DELTA COMMAND) EITHER')
25500          CALL DPWRST('XXX','BUG ')
25501          WRITE(ICOUT,2665)
25502 2665 FORMAT('      DOES NOT EXIST OR IS A PARAMETER (AS OPPOSED TO A')
25503          CALL DPWRST('XXX','BUG ')
25504          WRITE(ICOUT,2666)
25505 2666 FORMAT('      VARIABLE) IN THE CURRENT LIST OF AVAILABLE ',
25506     1       'VARIABLE')
25507          CALL DPWRST('XXX','BUG ')
25508          WRITE(ICOUT,2667)
25509 2667 FORMAT('      AND PARAMETER NAMES.')
25510          CALL DPWRST('XXX','BUG ')
25511          WRITE(ICOUT,2669)IODRD1(J),IODRD2(J)
25512 2669 FORMAT('      NAME OF SPECIFIED ERRORS VARIABLE = ',A4,A4)
25513          CALL DPWRST('XXX','BUG ')
25514          IF(IWIDTH.GE.1)THEN
25515            WRITE(ICOUT,2678)(IANS(JJ),JJ=1,MIN(100,IWIDTH))
25516 2678 FORMAT('      COMMAND LINE--',100A1)
25517            CALL DPWRST('XXX','BUG ')
25518          ENDIF
25519          IERROR='YES'
25520          GOTO9000
25521 2679     CONTINUE
25522          NUMDEL=NUMDEL+1
25523          ILOCD(J)=I2
25524          ICOLD(J)=IVALUE(ILOCD(J))
25525          NDELTA(J)=IN(ILOCD(J))
25526 2640   CONTINUE
25527 2649   CONTINUE
25528      ENDIF
25529C
25530 2699 CONTINUE
25531C
25532C               ************************************************
25533C               **  STEP 5.4--                                **
25534C               **  CHECK TO SEE IF HAVE ONE OR MORE DELTA    **
25535C               **  STARTING VALUE VARIABLE(S).               **
25536C               **  IF DO HAVE, CHECK TO SEE IF A VARIABLE    **
25537C               **  (AS OPPOSED TO A PARAMETER).              **
25538C               ************************************************
25539C
25540      ISTEPN='5.4'
25541      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH')
25542     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25543C
25544C
25545      DO2710I=1,MAXDEL
25546        ILOCD2(I)=-99
25547        ICOLD2(I)=-99
25548        NDELT2(I)=-99
25549 2710 CONTINUE
25550      NUMDE2=0
25551C
25552      IF(IODRD3(1).EQ.'OFF')GOTO2749
25553      IF(IODRD3(1).EQ.'ON')GOTO2749
25554C
25555      DO2740J=1,MAXDEL
25556        IF(IODRD3(J).EQ.'OFF')GOTO2749
25557        DO2750I=1,NUMNAM
25558          I2=I
25559          IF(IODRD3(J).EQ.IHNAME(I2).AND.IODRD4(J).EQ.IHNAM2(I2).AND.
25560     1       IUSE(I2).EQ.'V')THEN
25561            NUMDE2=NUMDE2+1
25562            ILOCD2(J)=I2
25563            ICOLD2(J)=IVALUE(ILOCD2(J))
25564            NDELT2(J)=IN(ILOCD2(J))
25565            GOTO2740
25566          ENDIF
25567 2750   CONTINUE
25568C
25569        WRITE(ICOUT,999)
25570        CALL DPWRST('XXX','BUG ')
25571        WRITE(ICOUT,2001)
25572        CALL DPWRST('XXX','BUG ')
25573        WRITE(ICOUT,2761)
25574 2761   FORMAT('      ONE OF THE DELTA STARTING VALUE VARIABLES ',
25575     1         'AS SPECIFIED')
25576        CALL DPWRST('XXX','BUG ')
25577        WRITE(ICOUT,2763)
25578 2763   FORMAT('      VIA THE ORTHOGONAL DISTANCE DELTA COMMAND) ',
25579     1         'EITHER')
25580        CALL DPWRST('XXX','BUG ')
25581        WRITE(ICOUT,2765)
25582 2765   FORMAT('      DOES NOT EXIST OR IS A PARAMETER (AS OPPOSED ',
25583     1         'TO A')
25584        CALL DPWRST('XXX','BUG ')
25585        WRITE(ICOUT,2766)
25586 2766   FORMAT('      VARIABLE) IN THE CURRENT LIST OF AVAILABLE ',
25587     1         'VARIABLE')
25588        CALL DPWRST('XXX','BUG ')
25589        WRITE(ICOUT,2767)
25590 2767   FORMAT('      AND PARAMETER NAMES.')
25591        CALL DPWRST('XXX','BUG ')
25592        WRITE(ICOUT,2769)IODRD3(J),IODRD4(J)
25593 2769   FORMAT('      NAME OF SPECIFIED ERRORS VARIABLE = ',A4,A4)
25594        CALL DPWRST('XXX','BUG ')
25595        WRITE(ICOUT,2007)
25596        CALL DPWRST('XXX','BUG ')
25597        IF(IWIDTH.GE.1)THEN
25598          WRITE(ICOUT,2008)(IANS(JJ),JJ=1,MIN(100,IWIDTH))
25599          CALL DPWRST('XXX','BUG ')
25600        ENDIF
25601        IERROR='YES'
25602        GOTO9000
25603C
25604 2740 CONTINUE
25605 2749 CONTINUE
25606C
25607C               ******************************************************
25608C               **  STEP 6.1--                                      **
25609C               **  FOR THE CASES WHEN HAVE FIT Y = SOME EXPRESSION **
25610C               **  EXTRACT THE ENTIRE (LEFT AND RIGHT SIDE) FUNCTIONAL
25611C               **  EXPRESSION FROM THE INPUT COMMAND LINE.         **
25612C               **  COPY OUT TO IWIDTH, OR OUT TO 'SUBS' (EXCLUSIVE),*
25613C               **  OR OUT THE 'EXCE' (EXCLUSIVE)                   **
25614C               **  FIRST, FOR MULTI-RESPONSE CASE, CHECK THAT      **
25615C               **  HAVE A LIST OF NQ FUNCTION NAMES ON RHS.        **
25616C               ******************************************************
25617C
25618      ISTEPN='6.1'
25619      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH')
25620     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25621C
25622      IF(NQ.GT.1)THEN
25623C
25624        ISTRT=ILOCE2+1
25625        ILAST=ILOCQ-1
25626        NUMF=0
25627C
25628        DO3010I=ISTRT,ILAST
25629          DO3020J=1,NUMNAM
25630            IF(IHARG(I).EQ.IHNAME(J).AND.IHARG2(I).EQ.IHNAM2(J))THEN
25631              IF(IUSE(J).EQ.'F')THEN
25632                NUMF=NUMF+1
25633                GOTO3010
25634              ELSE
25635                WRITE(ICOUT,999)
25636                CALL DPWRST('XXX','BUG ')
25637                WRITE(ICOUT,2001)
25638                CALL DPWRST('XXX','BUG ')
25639                WRITE(ICOUT,3021)IHARG(I),IHARG2(I)
25640                CALL DPWRST('XXX','BUG ')
25641                WRITE(ICOUT,3023)
25642                CALL DPWRST('XXX','BUG ')
25643                WRITE(ICOUT,3025)
25644                CALL DPWRST('XXX','BUG ')
25645                WRITE(ICOUT,2007)
25646                CALL DPWRST('XXX','BUG ')
25647                IF(IWIDTH.GE.1)THEN
25648                  WRITE(ICOUT,2008)(IANS(JJ),JJ=1,MIN(100,IWIDTH))
25649                  CALL DPWRST('XXX','BUG ')
25650                ENDIF
25651                IERROR='YES'
25652                GOTO9000
25653              ENDIF
25654            ENDIF
25655 3020     CONTINUE
25656C
25657          WRITE(ICOUT,999)
25658          CALL DPWRST('XXX','BUG ')
25659          WRITE(ICOUT,2001)
25660          CALL DPWRST('XXX','BUG ')
25661          WRITE(ICOUT,3011)IHARG(I),IHARG2(I)
25662          CALL DPWRST('XXX','BUG ')
25663          WRITE(ICOUT,3013)
25664          CALL DPWRST('XXX','BUG ')
25665          WRITE(ICOUT,2007)
25666          CALL DPWRST('XXX','BUG ')
25667          IF(IWIDTH.GE.1)THEN
25668            WRITE(ICOUT,2008)(IANS(JJ),JJ=1,MIN(100,IWIDTH))
25669            CALL DPWRST('XXX','BUG ')
25670          ENDIF
25671          IERROR='YES'
25672          GOTO9000
25673 3010   CONTINUE
25674C
25675        IF(NQ.NE.NUMF)THEN
25676          WRITE(ICOUT,999)
25677          CALL DPWRST('XXX','BUG ')
25678          WRITE(ICOUT,2001)
25679          CALL DPWRST('XXX','BUG ')
25680          WRITE(ICOUT,3031)
25681          CALL DPWRST('XXX','BUG ')
25682          WRITE(ICOUT,3033)
25683          CALL DPWRST('XXX','BUG ')
25684          WRITE(ICOUT,3035)
25685          CALL DPWRST('XXX','BUG ')
25686          WRITE(ICOUT,3037)NUMF
25687          CALL DPWRST('XXX','BUG ')
25688          WRITE(ICOUT,3039)NQ
25689          CALL DPWRST('XXX','BUG ')
25690          WRITE(ICOUT,2007)
25691          CALL DPWRST('XXX','BUG ')
25692          IF(IWIDTH.GE.1)THEN
25693            WRITE(ICOUT,2008)(IANS(JJ),JJ=1,MIN(100,IWIDTH))
25694            CALL DPWRST('XXX','BUG ')
25695          ENDIF
25696          IERROR='YES'
25697          GOTO9000
25698        ENDIF
25699C
25700        DO3040L=1,NQ
25701C
25702          ISTRT=ILOCE2+1
25703          LL=L+ISTRT-1
25704          DO3041II=1,4
25705            IFUNC2(II)=IHARG(LL)(II:II)
25706            IFUNC2(II+4)=IHARG2(LL)(II:II)
25707 3041     CONTINUE
25708          N2=8
25709C
25710          CALL DPEXFU(IFUNC2,N2,IHNAME,IHNAM2,IUSE,IVSTAR,IVSTOP,
25711     1    NUMNAM,IANS,IWIDTH,IFUNC,NUMCHF,MAXCHF,IFUNC3,N3,MAXN3,
25712     1    IBUGA3,IERROR)
25713          IF(IERROR.EQ.'YES')GOTO9000
25714C
25715          J=0
25716          DO3050I=1,N3
25717            J=J+1
25718            ZMODEL(I,L)=IFUNC3(I)
25719 3050     CONTINUE
25720          NUMCHZ(L)=J
25721 3040   CONTINUE
25722        GOTO4190
25723      ENDIF
25724C
25725 3011 FORMAT('      FOR THE MULTI-RESPONSE CASE, ARGUMENT ',2A4)
25726 3013 FORMAT('      WAS NOT FOUND IN THE CURRENT LIST OF AVAILABLE ',
25727     1       'NAMES.')
25728C
25729 3021 FORMAT('      FOR THE MULTI-RESPONSE CASE, ARGUMENT ',2A4)
25730 3023 FORMAT('      WAS FOUND IN THE CURRENT LIST OF AVAILABLE ',
25731     1       'NAMES.   HOWEVER, IT WAS EXPECTED')
25732 3025 FORMAT('      TO BE THE NAME OF A FUNTCION AND IT IS NOT.')
25733C
25734 3031 FORMAT('      FOR THE MULTI-RESPONSE CASE, THE NUMBER OF ',
25735     1       'FUNCTION')
25736 3033 FORMAT('      NAMES ON THE RIGHT OF THE EQUAL SIGN MUST EQUAL ',
25737     1       'THE NUMBER OF RESPONSE')
25738 3035 FORMAT('      VARIABLES ON THE LEFT OF THE EQUAL SIGN.')
25739 3037 FORMAT('      NUMBER OF FUNCTION NAMES       = ',I5)
25740 3039 FORMAT('      NUMBER OF RESPONSE VARIABLES   = ',I5)
25741C
25742      IF(ICASFI.EQ.'ORTF')GOTO4100
25743      GOTO4190
25744 4100 CONTINUE
25745      IF(NUMARG.EQ.0)GOTO4160
25746      IF(IHARG(1).EQ.'SUBS'.AND.IHARG2(1).EQ.'ET  ')GOTO4160
25747      IF(IHARG(1).EQ.'EXCE'.AND.IHARG2(1).EQ.'PT  ')GOTO4160
25748      IF(IHARG(1).EQ.'FOR '.AND.IHARG2(1).EQ.'    ')GOTO4160
25749      ISTART=-99
25750      ISTOP=-99
25751      DO4110I=1,IWIDTH
25752        IP1=I+1
25753        IP2=I+2
25754        IP3=I+3
25755        IP4=I+4
25756        IP5=I+5
25757        IP6=I+6
25758        IP7=I+7
25759        IP8=I+8
25760        IP9=I+9
25761        IP10=I+10
25762C
25763        IF(IP2.GT.IWIDTH)GOTO4120
25764        IF(IANS(I).EQ.'F'.AND.IANS(IP1).EQ.'I'
25765     1    .AND.IANS(IP2).EQ.'T')THEN
25766          ISTART=IP3
25767          IWD1='FIT '
25768          IWD12='    '
25769          GOTO4101
25770        ENDIF
25771C
25772        IF(IP9.GT.IWIDTH)GOTO4102
25773        IF(IANS(I).EQ.'R'.AND.IANS(IP1).EQ.'E'.AND.IANS(IP2).EQ.'G'.AND.
25774     1     IANS(IP3).EQ.'R'.AND.IANS(IP4).EQ.'E'.AND.
25775     1     IANS(IP5).EQ.'S'.AND.IANS(IP6).EQ.'S'.AND.
25776     1     IANS(IP7).EQ.'I'.AND.IANS(IP8).EQ.'O'.AND.
25777     1     IANS(IP9).EQ.' ')THEN
25778           ISTART=IP9
25779           IWD1='REGR'
25780           IWD12='ESSI'
25781           GOTO4101
25782        ENDIF
25783 4102   CONTINUE
25784        IF(IP8.GT.IWIDTH)GOTO4103
25785        IF(IANS(I).EQ.'R'.AND.IANS(IP1).EQ.'E'.AND.IANS(IP2).EQ.'G'.AND.
25786     1     IANS(IP3).EQ.'R'.AND.IANS(IP4).EQ.'E'.AND.
25787     1     IANS(IP5).EQ.'S'.AND.IANS(IP6).EQ.'S'.AND.
25788     1     IANS(IP7).EQ.'I'.AND.IANS(IP8).EQ.' ')THEN
25789           ISTART=IP8
25790           IWD1='REGR'
25791           IWD12='ESS '
25792           GOTO4101
25793        ENDIF
25794 4103   CONTINUE
25795        IF(IP7.GT.IWIDTH)GOTO4104
25796        IF(IANS(I).EQ.'R'.AND.IANS(IP1).EQ.'E'.AND.IANS(IP2).EQ.'G'.AND.
25797     1     IANS(IP3).EQ.'R'.AND.IANS(IP4).EQ.'E'.AND.
25798     1     IANS(IP5).EQ.'S'.AND.IANS(IP6).EQ.'S'.AND.
25799     1     IANS(IP7).EQ.' ')THEN
25800           ISTART=IP7
25801           IWD1='REGR'
25802           IWD12='ES  '
25803           GOTO4101
25804        ENDIF
25805 4104   CONTINUE
25806        IF(IP6.GT.IWIDTH)GOTO4105
25807        IF(IANS(I).EQ.'R'.AND.IANS(IP1).EQ.'E'.AND.IANS(IP2).EQ.'G'.AND.
25808     1     IANS(IP3).EQ.'R'.AND.IANS(IP4).EQ.'E'.AND.
25809     1     IANS(IP5).EQ.'S'.AND.IANS(IP6).EQ.' ')THEN
25810           ISTART=IP6
25811           IWD1='REGR'
25812           IWD12='E   '
25813           GOTO4101
25814        ENDIF
25815 4105   CONTINUE
25816        IF(IP5.GT.IWIDTH)GOTO4106
25817        IF(IANS(I).EQ.'R'.AND.IANS(IP1).EQ.'E'.AND.IANS(IP2).EQ.'G'.AND.
25818     1     IANS(IP3).EQ.'R'.AND.IANS(IP4).EQ.'E'.AND.
25819     1     IANS(IP5).EQ.' ')THEN
25820           ISTART=IP5
25821           IWD1='REGR'
25822           IWD12='    '
25823           GOTO4101
25824        ENDIF
25825 4106   CONTINUE
25826        IF(IP4.GT.IWIDTH)GOTO4107
25827        IF(IANS(I).EQ.'R'.AND.IANS(IP1).EQ.'E'.AND.IANS(IP2).EQ.'G'.AND.
25828     1     IANS(IP3).EQ.'R'.AND.IANS(IP4).EQ.' ')THEN
25829           ISTART=IP4
25830           GOTO4101
25831        ENDIF
25832 4107   CONTINUE
25833C
25834 4101   CONTINUE
25835C
25836        IF(IP4.GT.IWIDTH)GOTO4108
25837        IF(IANS(I).EQ.' '.AND.IANS(IP1).EQ.'F'.
25838     1  AND.IANS(IP2).EQ.'O'.AND.IANS(IP3).EQ.'R'.
25839     1  AND.IANS(IP4).EQ.' ')ISTOP=I
25840 4108   CONTINUE
25841C
25842        IF(IP7.GT.IWIDTH)GOTO4110
25843        IF(IANS(I).EQ.' '.AND.IANS(IP1).EQ.'S'.
25844     1  AND.IANS(IP2).EQ.'U'.AND.IANS(IP3).EQ.'B'.
25845     1  AND.IANS(IP4).EQ.'S'.AND.IANS(IP5).EQ.'E'.
25846     1  AND.IANS(IP6).EQ.'T'.AND.IANS(IP7).EQ.' ')ISTOP=I
25847C
25848 4110 CONTINUE
25849 4120 CONTINUE
25850C
25851      IF(ISTART.GE.1)GOTO4129
25852      IBRAN=4120
25853      WRITE(ICOUT,4121)IBRAN
25854 4121 FORMAT('*****INTERNAL ERROR IN DPORTH--',
25855     1'IMPOSSIBLE CONDITION AT BRANCH POINT = ',I8)
25856      CALL DPWRST('XXX','BUG ')
25857      WRITE(ICOUT,4122)
25858 4122 FORMAT('THE STRING    FIT  (OR REGRESSION)  NOT FOUND FOR ',
25859     1       'MODEL EXTRACTION')
25860      CALL DPWRST('XXX','BUG ')
25861      WRITE(ICOUT,2007)
25862      CALL DPWRST('XXX','BUG ')
25863      IF(IWIDTH.GE.1)THEN
25864        WRITE(ICOUT,2008)(IANS(I),I=1,MIN(100,IWIDTH))
25865        CALL DPWRST('XXX','BUG ')
25866      ENDIF
25867      IERROR='YES'
25868      GOTO9000
25869 4129 CONTINUE
25870C
25871      IF(ISTOP.EQ.-99)ISTOP=IWIDTH
25872      IF(ISTART.LE.ISTOP)GOTO4139
25873      IBRAN=4130
25874      WRITE(ICOUT,4131)IBRAN
25875 4131 FORMAT('INTERNAL ERROR IN DPORTH--AT BRANCH POINT = ',I8)
25876      CALL DPWRST('XXX','BUG ')
25877      WRITE(ICOUT,4133)
25878 4133 FORMAT('ISTART GREATER THAN ISTOP FOR MODEL EXTRACTION')
25879      CALL DPWRST('XXX','BUG ')
25880      WRITE(ICOUT,4134)ISTART,ISTOP
25881 4134 FORMAT('ISTART, ISTOP = ',2I8)
25882      CALL DPWRST('XXX','BUG ')
25883       WRITE(ICOUT,2007)
25884      CALL DPWRST('XXX','BUG ')
25885      IF(IWIDTH.GE.1)THEN
25886        WRITE(ICOUT,2008)(IANS(I),I=1,MIN(100,IWIDTH))
25887        CALL DPWRST('XXX','BUG ')
25888      ENDIF
25889      IERROR='YES'
25890      GOTO9000
25891 4139 CONTINUE
25892C
25893      J=0
25894      DO4150I=ISTART,ISTOP
25895        J=J+1
25896        ZMODEL(J,1)=IANS(I)
25897 4150 CONTINUE
25898      NUMCHZ(1)=ISTOP-ISTART+1
25899 4160 CONTINUE
25900 4190 CONTINUE
25901C
25902C               **********************************************
25903C               **  STEP 6.3--                              **
25904C               **  FOR ALL VARIATIONS OF THE FIT COMMAND,  **
25905C               **  CHECK TO SEE THE TYPE CASE--            **
25906C               **    1) UNQUALIFIED (THAT IS, FULL);       **
25907C               **    2) SUBSET/EXCEPT; OR                  **
25908C               **    3) FOR.                               **
25909C               **********************************************
25910C
25911      ISTEPN='6.3'
25912      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH')
25913     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25914C
25915      ICASEQ='FULL'
25916      ILOCQ=NUMARG+1
25917      IF(NUMARG.LT.1)GOTO490
25918      DO400J=1,NUMARG
25919        J1=J
25920        IF((IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET  ') .OR.
25921     1     (IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT  '))THEN
25922          ICASEQ='SUBS'
25923          IKEY='SUBS'
25924          IF(IHARG(J1).EQ.'EXCE')IKEY='EXCE'
25925          ILOCQ=J1
25926          GOTO490
25927        ELSEIF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.'    ')THEN
25928          ICASEQ='FOR'
25929          ILOCQ=J1
25930          GOTO490
25931        ENDIF
25932  400 CONTINUE
25933  490 CONTINUE
25934C
25935      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH')THEN
25936        WRITE(ICOUT,491)NUMARG,ILOCQ
25937  491   FORMAT('NUMARG,ILOCQ = ',2I8)
25938        CALL DPWRST('XXX','BUG ')
25939      ENDIF
25940C
25941C               **********************************************
25942C               **  STEP 6.4--                              **
25943C               **  FOR SOME VARIATIONS OF THE FIT COMMAND, **
25944C               **  EXTRACT THE UNDERLYING FUNCTION         **
25945C               **  FROM FUNCTION DEFINITIONS.              **
25946C               **********************************************
25947C
25948C
25949      ISTEPN='6.4'
25950      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH')
25951     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25952C
25953      IF(NQ.LE.1 .AND. ICASFI.EQ.'ORTF')THEN
25954C
25955        IF(IMPFLG.EQ.'ON')THEN
25956          ILOCEQ=0
25957          GOTO5176
25958        ENDIF
25959C
25960        DO5170I=1,NUMCHZ(1)
25961          I2=I
25962          IF(ZMODEL(I,1).EQ.'=')THEN
25963            ILOCEQ=I2
25964            IWD1='=   '
25965            IWD12='    '
25966            GOTO5176
25967          ENDIF
25968 5170   CONTINUE
25969C
25970        IBRAN=5170
25971        WRITE(ICOUT,2001)
25972        CALL DPWRST('XXX','BUG ')
25973        WRITE(ICOUT,5171)IBRAN
25974 5171   FORMAT('     IMPOSSIBLE CONDITION AT BRANCH POINT = ',I8)
25975        CALL DPWRST('XXX','BUG ')
25976        WRITE(ICOUT,5172)
25977 5172   FORMAT('     NO EQUAL SIGN FOUND FOR MODEL EXTRACTION')
25978        CALL DPWRST('XXX','BUG ')
25979        WRITE(ICOUT,2007)
25980        CALL DPWRST('XXX','BUG ')
25981        IF(IWIDTH.GE.1)THEN
25982          WRITE(ICOUT,2008)(IANS(I),I=1,MIN(100,IWIDTH))
25983          CALL DPWRST('XXX','BUG ')
25984        ENDIF
25985        IERROR='YES'
25986        GOTO9000
25987C
25988 5176   CONTINUE
25989        IF(ICASEQ.EQ.'FULL')THEN
25990           IWD2='    '
25991           IWD22='    '
25992        ELSEIF(ICASEQ.EQ.'SUBS'.AND.IKEY.EQ.'SUBS')THEN
25993          IWD2='SUBS'
25994          IWD22='ET  '
25995        ELSEIF(ICASEQ.EQ.'SUBS'.AND.IKEY.EQ.'EXCE')THEN
25996          IWD2='EXCE'
25997          IWD22='PT  '
25998        ELSEIF(ICASEQ.EQ.'FOR')THEN
25999          IWD2='FOR '
26000          IWD22='    '
26001        ENDIF
26002C
26003        IF(ICASFI.EQ.'ORTF')
26004     1     CALL DPEXST(IANS,IWIDTH,IWD1,IWD12,IWD2,IWD22,MAXN2,
26005     1                 IFUNC2,N2,IBUGA3,IFOUND,IERROR)
26006        IF(IERROR.EQ.'YES')GOTO9000
26007        IF(IFOUND.EQ.'YES')GOTO3379
26008C
26009        WRITE(ICOUT,999)
26010        CALL DPWRST('XXX','BUG ')
26011        WRITE(ICOUT,2001)
26012        CALL DPWRST('XXX','BUG ')
26013        WRITE(ICOUT,3371)
26014 3371   FORMAT('      INVALID COMMAND FORM FOR FITTING.')
26015        CALL DPWRST('XXX','BUG ')
26016        WRITE(ICOUT,3373)
26017 3373   FORMAT('      GENERAL FORM--')
26018        CALL DPWRST('XXX','BUG ')
26019        WRITE(ICOUT,3374)
26020 3374   FORMAT('      ORTHOGONAL DISTANCE FIT ... = ...  ',
26021     1         'SUBSET ... ... ...')
26022        CALL DPWRST('XXX','BUG ')
26023        WRITE(ICOUT,3375)
26024 3375   FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
26025        CALL DPWRST('XXX','BUG ')
26026        IF(IWIDTH.GE.1)THEN
26027          WRITE(ICOUT,3376)(IANS(I),I=1,MIN(100,IWIDTH))
26028 3376     FORMAT('      ',100A1)
26029          CALL DPWRST('XXX','BUG ')
26030        ENDIF
26031        IERROR='YES'
26032        GOTO9000
26033C
26034 3379   CONTINUE
26035C
26036        CALL DPEXFU(IFUNC2,N2,IHNAME,IHNAM2,IUSE,IVSTAR,IVSTOP,
26037     1              NUMNAM,IANS,IWIDTH,IFUNC,NUMCHF,MAXCHF,IFUNC3,
26038     1              N3,MAXN3,
26039     1              IBUGA3,IERROR)
26040        IF(IERROR.EQ.'YES')GOTO9000
26041C
26042        J=ILOCEQ
26043        DO5180I=1,N3
26044          J=J+1
26045          ZMODEL(J,1)=IFUNC3(I)
26046 5180   CONTINUE
26047        NUMCHZ(1)=J
26048C
26049      ENDIF
26050C
26051C               *****************************************************
26052C               **  STEP 7--                                       **
26053C               **  MAKE A NON-CALCULATING PASS AT THE MODEL       **
26054C               **  SO AS TO EXTRACT ALL PARAMETER AND VARIABLE    **
26055C               **  NAMES.                                         **
26056C               *****************************************************
26057C
26058      ISTEPN='7'
26059      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH')
26060     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26061C
26062      NUMF=1
26063      IF(NQ.GT.1)NUMF=NQ
26064      DO4499L=1,NUMF
26065        IPASS=1
26066        CALL COMPIM(ZMODEL(1,L),NUMCHZ(L),IPASS,
26067     1              PARTMP,IPART1,IPART2,NUMPV,
26068     1              IANGLU,ZTYPEH(1,L),ZW21HO(1,L),ZW22HO(1,L),
26069     1              Z2HOLD(1,L),NWHOLZ(L),AJUNK,
26070     1              IBUGCO,IBUGEV,IERROR)
26071        IF(IERROR.EQ.'YES')GOTO9000
26072C
26073C               ********************************************
26074C               **  STEP 8--                              **
26075C               **  CHECK TO MAKE SURE THAT THE COMBINED  **
26076C               **  NUMBER OF PARAMETERS AND VARIABLES    **
26077C               **  IN THE MODEL IS AT LEAST 1.           **
26078C               ********************************************
26079C
26080        ISTEPN='8'
26081        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH')
26082     1     CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26083C
26084        IF(NUMPV.LE.0)THEN
26085          WRITE(ICOUT,2001)
26086          CALL DPWRST('XXX','BUG ')
26087          WRITE(ICOUT,4401)
26088 4401     FORMAT('      COMBINED NUMBER OF PARAMETERS AND VARIABLES')
26089          CALL DPWRST('XXX','BUG ')
26090          WRITE(ICOUT,4403)NUMPV
26091 4403     FORMAT('      DETECTED IN THE MODEL FOR FUNCTION ',I5,
26092     1           ' IS 0.','  NUMPV = ',I8)
26093          CALL DPWRST('XXX','BUG ')
26094          WRITE(ICOUT,4407)NUMCHZ(L)
26095 4407     FORMAT('      NUMBER OF CHARACTERS IN MODEL = ',I8)
26096          CALL DPWRST('XXX','BUG ')
26097          IF(NUMCHZ(L).GE.1)THEN
26098            WRITE(ICOUT,4408)(ZMODEL(J,L),J=1,MIN(100,NUMCHZ(L)))
26099 4408       FORMAT('      MODEL--',100A1)
26100            CALL DPWRST('XXX','BUG ')
26101          ENDIF
26102          IERROR='YES'
26103          GOTO9000
26104        ENDIF
26105C
26106C               ******************************************************
26107C               **  STEP 9--                                        **
26108C               **  CHECK THAT ALL VARIABLES                        **
26109C               **  IN THE MODEL ARE ALREADY PRESENT                **
26110C               **  IN THE AVAILABLE NAME LIST IHNAME(.) AND        **
26111C               **  IHNAM2(.).  CHECK THAT ALL PARAMETERS           **
26112C               **  IN THE MODEL ARE ALREADY PRESENT IN THE         **
26113C               **  AVAILABLE NAME LIST IHNAME(.) AND IHNAM2(.).    **
26114C               **  ALL NAMES IN THE MODEL THAT ARE NOT             **
26115C               **  IN THE NAME LIST AT ALL WILL BE ADDED           **
26116C               **  TO THE LIST, DEFINED AS PARAMETERS,             **
26117C               **  AND GIVEN A VALUE OF 1.0.                       **
26118C               **  THIS ALLOWS US TO MAKE AN INITIAL FIT           **
26119C               **  WITHOUT HAVING TO DEFINE STARTING VALUES AT ALL **
26120C               **  (THEY WILL BE AUTOMATICALLY SET TO 1.0).  ALSO, **
26121C               **  FORM A NEW VECTOR WHICH HAS ONLY PARAMETER NAMES**
26122C               **  AND ANOTHER VECTOR WHICH HAS ONLY VARIABLE NAMES.*
26123C               ******************************************************
26124C
26125        ISTEPN='9'
26126        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH')
26127     1     CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26128C
26129        IP=0
26130        IV=0
26131        DO7965J=1,NUMPV
26132          IHPARN=IPART1(J)
26133          IHPAR2=IPART2(J)
26134          DO7966I=1,NUMNAM
26135            I2=I
26136            IF(IHPARN.EQ.IHNAME(I).AND.IHPAR2.EQ.IHNAM2(I).AND.
26137     1         IUSE(I).EQ.'V')THEN
26138              IV=IV+1
26139              ZIDUMV(IV,L)=IHPARN
26140              ZDUMV2(IV,L)=IHPAR2
26141              LOCDUM(IV,L)=IVALUE(I2)
26142              NIV(IV)=IN(I2)
26143              GOTO7965
26144            ELSEIF(IHPARN.EQ.IHNAME(I).AND.IHPAR2.EQ.IHNAM2(I).AND.
26145     1        IUSE(I).EQ.'P')THEN
26146              IP=IP+1
26147              ZIPARN(IP,L)=IHPARN
26148              ZPARN2(IP,L)=IHPAR2
26149              ZPARAM(IP,L)=VALUE(I2)
26150              GOTO7965
26151            ENDIF
26152 7966     CONTINUE
26153C
26154          IP=IP+1
26155          ZIPARN(IP,L)=IHPARN
26156          ZPARN2(IP,L)=IHPAR2
26157          ZPARAM(IP,L)=1.0
26158C
26159          IF(NUMNAM.GE.MAXNAM)THEN
26160            WRITE(ICOUT,2001)
26161            CALL DPWRST('XXX','BUG ')
26162            WRITE(ICOUT,7751)
26163 7751       FORMAT('      THE TOTAL NUMBER OF (VARIABLE + ',
26164     1             'PARAMETER) NAMES MUST')
26165            CALL DPWRST('XXX','BUG ')
26166            WRITE(ICOUT,7753)MAXNAM
26167 7753       FORMAT('      BE AT MOST ',I8,'.  THE MAXIMUM ALLOWABLE',
26168     1             'NUMBER')
26169            CALL DPWRST('XXX','BUG ')
26170            WRITE(ICOUT,7755)
26171 7755       FORMAT('      OF NAMES WAS JUST EXCEEDED.  SUGGESTED ',
26172     1             'ACTION--')
26173            CALL DPWRST('XXX','BUG ')
26174            WRITE(ICOUT,7757)
26175 7757       FORMAT('      ENTER   STATUS   TO DETERMINE THE ',
26176     1             'IMPORTANT VARIABLES')
26177            CALL DPWRST('XXX','BUG ')
26178            WRITE(ICOUT,7760)
26179 7760       FORMAT('      AND PARAMETERS, AND THEN REUSE SOME OF ',
26180     1             'THE NAMES.')
26181            CALL DPWRST('XXX','BUG ')
26182            WRITE(ICOUT,2007)
26183            CALL DPWRST('XXX','BUG ')
26184            IF(IWIDTH.GE.1)THEN
26185              WRITE(ICOUT,2008)(IANS(JJ),JJ=1,MIN(100,IWIDTH))
26186              CALL DPWRST('XXX','BUG ')
26187            ENDIF
26188            IERROR='YES'
26189            GOTO9000
26190          ENDIF
26191C
26192          I2=NUMNAM+1
26193          IHNAME(I2)=IHPARN
26194          IHNAM2(I2)=IHPAR2
26195          IUSE(I2)='P'
26196          IVALUE(I2)=1
26197          VALUE(I2)=1.0
26198          IN(I2)=1
26199          NUMNAM=I2
26200C
26201          IF(IFEEDB.EQ.'ON')THEN
26202            WRITE(ICOUT,999)
26203            CALL DPWRST('XXX','BUG ')
26204            WRITE(ICOUT,7852)
26205 7852       FORMAT('      NOTE--A NAME USED IN AN EXPRESSION HAS')
26206            CALL DPWRST('XXX','BUG ')
26207            WRITE(ICOUT,7853)ZIPARN(IP,L),ZPARN2(IP,L)
26208 7853       FORMAT('      NOT YET BEEN DEFINED.  NAME = ',2A4)
26209            CALL DPWRST('XXX','BUG ')
26210            WRITE(ICOUT,7855)
26211 7855       FORMAT('      THIS NAME HAS BEEN ADDED TO THE LIST, ',
26212     1             'SPECIFIED')
26213            CALL DPWRST('XXX','BUG ')
26214            WRITE(ICOUT,7857)
26215 7857       FORMAT('      AS A PARAMETER AND GIVEN THE VALUE 1.0 .')
26216            CALL DPWRST('XXX','BUG ')
26217            WRITE(ICOUT,7858)(ZMODEL(I,L),I=1,MIN(100,NUMCHZ(L)))
26218 7858       FORMAT('      FUNCTION EXPRESSION--',100A1)
26219            CALL DPWRST('XXX','BUG ')
26220          ENDIF
26221C
26222 7965   CONTINUE
26223        NUMPAZ(L)=IP
26224        NUMVAZ(L)=IV
26225C
26226C               *******************************************
26227C               **  STEP 10--                            **
26228C               **  CHECK FOR A VALID NUMBER             **
26229C               **  OF INDEPENDENT VARIABLES (1 TO 20).  **
26230C               **  CHECK THE VALIDITY OF EACH           **
26231C               **  OF THE INDEPENDENT VARIABLES.        **
26232C               **  DOES THE NAME EXIST IN THE TABLE?    **
26233C               **  DOES THE NUMBER OF ELEMENTS          **
26234C               **  AGREE WITH THE NUMBER OF ELEMENTS    **
26235C               **  IN THE RESPONSE VARIABLE?            **
26236C               *******************************************
26237C
26238        ISTEPN='10'
26239        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH')
26240     1     CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26241C
26242        IF(NUMVAZ(L).LT.1.OR.NUMVAZ(L).GT.MAXV2)THEN
26243          WRITE(ICOUT,999)
26244          CALL DPWRST('XXX','BUG ')
26245          WRITE(ICOUT,2001)
26246          CALL DPWRST('XXX','BUG ')
26247          WRITE(ICOUT,4251)
26248 4251     FORMAT('      FOR AN ORTHOGONAL DISTANCE FIT THE NUMBER OF')
26249          CALL DPWRST('XXX','BUG ')
26250          WRITE(ICOUT,4253)
26251 4253     FORMAT('      INDEPENDENT VARIABLES MUST BE AT LEAST 1 AND')
26252          CALL DPWRST('XXX','BUG ')
26253          WRITE(ICOUT,4254)MAXV2,L
26254 4254     FORMAT('      AT MOST ',I8,'.  FOR FUNCTION ',I5,' THE')
26255          CALL DPWRST('XXX','BUG ')
26256          WRITE(ICOUT,4257)NUMVAZ(L)
26257 4257     FORMAT('        SPECIFIED NUMBER OF INDEPENDENT VARIABLES ',
26258     1           'WAS ',I8)
26259          CALL DPWRST('XXX','BUG ')
26260          WRITE(ICOUT,2007)
26261          CALL DPWRST('XXX','BUG ')
26262          IF(IWIDTH.GE.1)THEN
26263            WRITE(ICOUT,2008)(IANS(JJ),JJ=1,MIN(100,IWIDTH))
26264            CALL DPWRST('XXX','BUG ')
26265          ENDIF
26266          WRITE(ICOUT,999)
26267          CALL DPWRST('XXX','BUG ')
26268          WRITE(ICOUT,4267)NUMCHZ(L)
26269 4267     FORMAT('      NUMBER OF CHARACTERS IN MODEL = ',I8)
26270          CALL DPWRST('XXX','BUG ')
26271          WRITE(ICOUT,4268)(ZMODEL(JJ,L),JJ=1,MIN(100,NUMCHZ(L)))
26272 4268     FORMAT('      MODEL--',100A1)
26273          CALL DPWRST('XXX','BUG ')
26274          WRITE(ICOUT,4264)
26275 4264     FORMAT('      VARIABLES EXTRACTED FROM MODEL--')
26276          CALL DPWRST('XXX','BUG ')
26277          DO4265JJ=1,NUMVAZ(L)
26278            WRITE(ICOUT,4266)JJ,ZIDUMV(JJ,L),ZDUMV2(JJ,L),
26279     1                       LOCDUM(JJ,L)
26280 4266       FORMAT('I,IVARN3(I),IVARN4(I),ICOLV3(I) = ',
26281     1             I8,2X,A4,A4,2X,I8)
26282            CALL DPWRST('XXX','BUG ')
26283 4265     CONTINUE
26284          IERROR='YES'
26285          GOTO9000
26286        ENDIF
26287C
26288        IF(IMPFLG.EQ.'ON')THEN
26289          NTEMP=NIV(1)
26290          DO542JJ=1,NUMVAZ(L)
26291            IF(NIV(JJ).NE.NTEMP)THEN
26292              WRITE(ICOUT,999)
26293              CALL DPWRST('XXX','BUG ')
26294              WRITE(ICOUT,2001)
26295              CALL DPWRST('XXX','BUG ')
26296              WRITE(ICOUT,546)
26297  546         FORMAT('      FOR AN IMPLICIT ORTHOGONAL DISTANCE ',
26298     1               'FIT, THE NUMBER')
26299              CALL DPWRST('XXX','BUG ')
26300              WRITE(ICOUT,547)
26301  547         FORMAT('      OF ELEMENTS IN EACH INDEPENDENT ',
26302     1               'VARIABLE SHOULD BE THE SAME.')
26303              CALL DPWRST('XXX','BUG ')
26304              WRITE(ICOUT,548)NTEMP
26305  548         FORMAT('      SUCH WAS NOT THE CASE HERE.')
26306              CALL DPWRST('XXX','BUG ')
26307              WRITE(ICOUT,999)
26308              CALL DPWRST('XXX','BUG ')
26309              WRITE(ICOUT,549)
26310  549         FORMAT('      INDEPENDENT VARIABLES           --')
26311              CALL DPWRST('XXX','BUG ')
26312              DO550KK=1,NUMVAZ(L)
26313                WRITE(ICOUT,552)ZIDUMV(KK,L),ZDUMV2(KK,L),NIV(KK)
26314  552           FORMAT('                  ',A4,A4,'  HAS ',
26315     1                 I8,' ELEMENTS')
26316                CALL DPWRST('XXX','BUG ')
26317  550         CONTINUE
26318              WRITE(ICOUT,999)
26319              CALL DPWRST('XXX','BUG ')
26320              WRITE(ICOUT,2007)
26321              CALL DPWRST('XXX','BUG ')
26322              IF(IWIDTH.GE.1)THEN
26323                WRITE(ICOUT,2008)(IANS(KK),KK=1,MIN(100,IWIDTH))
26324                CALL DPWRST('XXX','BUG ')
26325              ENDIF
26326              IERROR='YES'
26327              GOTO9000
26328            ENDIF
26329  542     CONTINUE
26330          GOTO590
26331        ELSE
26332          NTEMP=NLEFT
26333          DO540JJ=1,NUMVAZ(L)
26334            IF(NIV(JJ).NE.NTEMP)THEN
26335              WRITE(ICOUT,999)
26336              CALL DPWRST('XXX','BUG ')
26337              WRITE(ICOUT,2001)
26338              CALL DPWRST('XXX','BUG ')
26339              WRITE(ICOUT,561)
26340  561         FORMAT('      FOR AN ORTHOGONAL DISTANCE FIT, THE ',
26341     1               'NUMBER OF ELEMENTS')
26342              CALL DPWRST('XXX','BUG ')
26343              WRITE(ICOUT,564)
26344  564         FORMAT('      IN EACH INDEPENDENT VARIABLE SHOULD BE')
26345              CALL DPWRST('XXX','BUG ')
26346              WRITE(ICOUT,565)
26347  565         FORMAT('      THE SAME AS THE NUMBER OF ELEMENTS IN')
26348              CALL DPWRST('XXX','BUG ')
26349              WRITE(ICOUT,566)
26350  566         FORMAT('      THE DEPENDENT VARIABLE (RESPONSE);  ',
26351     1               'SUCH WAS')
26352              CALL DPWRST('XXX','BUG ')
26353              WRITE(ICOUT,999)
26354              CALL DPWRST('XXX','BUG ')
26355              WRITE(ICOUT,571)
26356  571         FORMAT('      NOT THE CASE HERE.  DEPENDENT VARIABLE ',
26357     1               '(RESPONSE)--')
26358              CALL DPWRST('XXX','BUG ')
26359              WRITE(ICOUT,572)IHLEFT,IHLEF2,NLEFT
26360  572         FORMAT('                  ',2A4,'  HAS ',I8,' ELEMENTS')
26361              CALL DPWRST('XXX','BUG ')
26362              WRITE(ICOUT,999)
26363              CALL DPWRST('XXX','BUG ')
26364              WRITE(ICOUT,576)
26365  576         FORMAT('      INDEPENDENT VARIABLES           --')
26366              CALL DPWRST('XXX','BUG ')
26367              DO580KK=1,NUMVAZ(L)
26368                WRITE(ICOUT,578)ZIDUMV(KK,L),ZDUMV2(KK,L),NIV(KK)
26369  578           FORMAT('                  ',A4,A4,'  HAS ',I8,
26370     1                 ' ELEMENTS')
26371                CALL DPWRST('XXX','BUG ')
26372  580         CONTINUE
26373              WRITE(ICOUT,999)
26374              CALL DPWRST('XXX','BUG ')
26375              WRITE(ICOUT,2007)
26376              CALL DPWRST('XXX','BUG ')
26377              IF(IWIDTH.GE.1)THEN
26378                WRITE(ICOUT,2008)(IANS(KK),KK=1,MIN(100,IWIDTH))
26379                CALL DPWRST('XXX','BUG ')
26380              ENDIF
26381              IERROR='YES'
26382              GOTO9000
26383            ENDIF
26384  540     CONTINUE
26385          GOTO590
26386        ENDIF
26387C
26388  590   CONTINUE
26389C
26390C       UPDATE PARAMETER AND VARIABLE NAME LIST
26391C
26392        IF(L.EQ.1)THEN
26393          DO4481JJ=1,NUMPAZ(1)
26394            IPARN3(JJ)=ZIPARN(JJ,1)
26395            IPARN4(JJ)=ZPARN2(JJ,1)
26396            PARAM3(JJ)=ZPARAM(JJ,1)
26397 4481     CONTINUE
26398C
26399          DO4483JJ=1,NUMVAZ(1)
26400            IVARN3(JJ)=ZIDUMV(JJ,1)
26401            IVARN4(JJ)=ZDUMV2(JJ,1)
26402            ICOLV3(JJ)=LOCDUM(JJ,1)
26403 4483     CONTINUE
26404          NUMPAR=NUMPAZ(1)
26405          NUMVAR=NUMVAZ(1)
26406        ELSE
26407          DO4491JJ=1,NUMPAZ(L)
26408            DO4493KK=1,NUMPAR
26409              IF(ZIPARN(KK,L).EQ.IPARN3(KK).AND.
26410     1           ZPARN2(KK,L).EQ.IPARN4(KK))GOTO4494
26411 4493       CONTINUE
26412            NUMPAR=NUMPAR+1
26413            IPARN3(NUMPAR)=ZIPARN(JJ,L)
26414            IPARN4(NUMPAR)=ZPARN2(JJ,L)
26415            PARAM3(NUMPAR)=ZPARAM(JJ,L)
26416 4494     CONTINUE
26417 4491     CONTINUE
26418C
26419          DO4495JJ=1,NUMVAZ(L)
26420            DO4496KK=1,NUMVAR
26421              IF(ZIDUMV(KK,L).EQ.IVARN3(KK).AND.
26422     1           ZDUMV2(KK,L).EQ.IVARN4(KK))GOTO4497
26423 4496       CONTINUE
26424            NUMVAR=NUMVAR+1
26425            IVARN3(NUMVAR)=ZIDUMV(JJ,L)
26426            IVARN4(NUMVAR)=ZDUMV2(JJ,L)
26427            ICOLV3(NUMVAR)=LOCDUM(JJ,L)
26428 4497     CONTINUE
26429 4495     CONTINUE
26430        ENDIF
26431C
26432 4499 CONTINUE
26433C
26434      DO4498JJ=1,NUMVAR
26435        IPARN3(NUMPAR+JJ)=IVARN3(JJ)
26436        IPARN4(NUMPAR+JJ)=IVARN4(JJ)
26437 4498 CONTINUE
26438C
26439C               ******************************************************
26440C               **  STEP 11--                                       **
26441C               **  CHECK FOR ADEQUATE AMOUNT OF SCRATCH SPACE      **
26442C               ******************************************************
26443C
26444      ISTEPN='11'
26445      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH')
26446     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26447C
26448      M=NUMVAR
26449      NP=NUMPAR
26450      N=NLEFT
26451      IF(IMPFLG.EQ.'ON')THEN
26452        N=NIV(1)
26453      ENDIF
26454C
26455      IREQ=18 + 11*NP + NP**2 + M + M**2 + 4*N*NQ + 6*N*M +
26456     1     2*N*NQ*M + 2*N*NQ*NP + NQ**2 + 5*NQ + NQ*(NP+M) + (N*1)*NQ
26457CCCCC LWORK=46*MAXOBV/2
26458      LWORK=35*MAXOBV/2
26459      IF(IREQ.GT.LWORK)THEN
26460        WRITE(ICOUT,999)
26461        CALL DPWRST('XXX','BUG ')
26462        WRITE(ICOUT,2001)
26463        CALL DPWRST('XXX','BUG ')
26464        WRITE(ICOUT,591)
26465  591   FORMAT('      NOT ENOUGH SCRATCH STORAGE AVAILABLE.')
26466        CALL DPWRST('XXX','BUG ')
26467        WRITE(ICOUT,593)IREQ,LWORK
26468  593   FORMAT('      AVAILABLE STORAGE = ',I8,' AND REQUIRED ',
26469     1         'STORAGE = ',I8,'.')
26470        CALL DPWRST('XXX','BUG ')
26471        WRITE(ICOUT,595)
26472  595   FORMAT('      REMEDY: REDUCE EITHER THE NUMBER OF VARIABLES')
26473        CALL DPWRST('XXX','BUG ')
26474        WRITE(ICOUT,597)
26475  597   FORMAT('      OR THE NUMBER OF OBSERVATIONS IN THE MODEL.')
26476        CALL DPWRST('XXX','BUG ')
26477        IERROR='YES'
26478        GOTO9000
26479      ENDIF
26480C
26481C               ******************************************************
26482C               **  STEP 11B--                                      **
26483C               **  CHECK DELTA WEIGHT VARIABLES FOR APPROPRIATE    **
26484C               **  SIZES.  (IF NOT EQUAL 'OFF').  CASES:           **
26485C               **  1) IF MORE THAN ONE VARIABLE, THEN SIZE OF EACH **
26486C               **     VARIABLE MUST EQUAL SIZE OF RESPONSE VARIABLE**
26487C               **  2) IF EXACTLY ONE VARIABLE, THEN CHECK          **
26488C               **     VARIABLE MUST EQUAL SIZE OF RESPONSE VARIABLE**
26489C               **     OR EQUAL NUMBER OF INDEPENDENT VARIABLES     **
26490C               ******************************************************
26491C
26492      ISTEPN='11B'
26493      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH')
26494     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26495C
26496      IF(IDLFLG.EQ.'OFF' .OR. IDLFLG.EQ.'DEFA')GOTO729
26497C
26498      IF(NUMDEL.EQ.1)THEN
26499        IF(NDELTA(1).EQ.N .OR. NDELTA(1).EQ.M)GOTO729
26500        WRITE(ICOUT,999)
26501        CALL DPWRST('XXX','BUG ')
26502        WRITE(ICOUT,2001)
26503        CALL DPWRST('XXX','BUG ')
26504        WRITE(ICOUT,711)
26505  711   FORMAT('      IF EXACTLY ONE DELTA VARIABLE SPECIFIED,')
26506        CALL DPWRST('XXX','BUG ')
26507        WRITE(ICOUT,713)
26508  713   FORMAT('      THE NUMBER OF ELEMENTS MUST EQUAL EITHER THE')
26509        CALL DPWRST('XXX','BUG ')
26510        WRITE(ICOUT,715)N
26511  715   FORMAT('      NUMBER OF ELEMENTS IN THE RESPONSE VARIABLE (',
26512     1         I8,')')
26513        CALL DPWRST('XXX','BUG ')
26514        WRITE(ICOUT,717)M
26515  717   FORMAT('      OR THE NUMBER OF RESPONSE VARIABLES (',I8,').')
26516        CALL DPWRST('XXX','BUG ')
26517        WRITE(ICOUT,719)IODRD1(1),IODRD2(1),NDELTA(1)
26518  719   FORMAT('      DELTA VARIABLE ',A4,A4,' HAS ',I8,' ELEMENTS.')
26519        IERROR='YES'
26520        GOTO9000
26521      ELSEIF(NUMDEL.GT.1)THEN
26522        DO720JJ=1,NUMDEL
26523          NTEMP=NLEFT
26524          IF(IMPFLG.EQ.'ON')NTEMP=NIV(1)
26525          IF(NDELTA(JJ).NE.NTEMP)THEN
26526            WRITE(ICOUT,999)
26527            CALL DPWRST('XXX','BUG ')
26528            WRITE(ICOUT,2001)
26529            CALL DPWRST('XXX','BUG ')
26530            WRITE(ICOUT,721)IODRD1(JJ),IODRD2(JJ),NDELTA(JJ)
26531  721       FORMAT('      DELTA VARIABLE ',2A4,' HAS ',I8,' ELEMENTS.')
26532            CALL DPWRST('XXX','BUG ')
26533            WRITE(ICOUT,722)
26534  722       FORMAT('      HOWEVER, IT SHOULD HAVE THE SAME NUMBER OF ',
26535     1             'ELEMENTS AS THE')
26536            CALL DPWRST('XXX','BUG ')
26537            WRITE(ICOUT,723)N
26538  723       FORMAT('      INDEPENDENT VARIABLE(S).')
26539            CALL DPWRST('XXX','BUG ')
26540            WRITE(ICOUT,725)IVARN3(1),IVARN4(1),NTEMP
26541  725       FORMAT('      FIRST INDEPENDENT VARIABLE ',
26542     1             A4,A4,'  HAS ',I8,' ELEMENTS')
26543            CALL DPWRST('XXX','BUG ')
26544            WRITE(ICOUT,999)
26545            CALL DPWRST('XXX','BUG ')
26546            WRITE(ICOUT,2007)
26547            CALL DPWRST('XXX','BUG ')
26548            IF(IWIDTH.GE.1)THEN
26549              WRITE(ICOUT,2008)(IANS(I),I=1,MIN(100,IWIDTH))
26550              CALL DPWRST('XXX','BUG ')
26551            ENDIF
26552            IERROR='YES'
26553            GOTO9000
26554          ENDIF
26555  720   CONTINUE
26556      ELSE
26557        GOTO729
26558      ENDIF
26559C
26560  729 CONTINUE
26561C
26562C               ******************************************************
26563C               **  STEP 11C--                                      **
26564C               **  CHECK DELTA FIXED  VARIABLES FOR APPROPRIATE    **
26565C               **  SIZES.  (IF NOT EQUAL 'OFF').  CASES:           **
26566C               **  1) IF MORE THAN ONE VARIABLE, THEN SIZE OF EACH **
26567C               **     VARIABLE MUST EQUAL SIZE OF RESPONSE VARIABLE**
26568C               **  2) IF EXACTLY ONE VARIABLE, THEN CHECK          **
26569C               **     VARIABLE MUST EQUAL SIZE OF RESPONSE VARIABLE**
26570C               **     OR EQUAL NUMBER OF INDEPENDENT VARIABLES     **
26571C               ******************************************************
26572C
26573      ISTEPN='11C'
26574      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH')
26575     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26576C
26577      IF(IODRE1(1).EQ.'OFF' .OR. NUMERR.EQ.0)GOTO749
26578C
26579      IF(NUMERR.EQ.1)THEN
26580        IF(NERROR(1).EQ.N .OR. NERROR(1).EQ.M)GOTO749
26581        WRITE(ICOUT,999)
26582        CALL DPWRST('XXX','BUG ')
26583        WRITE(ICOUT,2001)
26584        CALL DPWRST('XXX','BUG ')
26585        WRITE(ICOUT,731)
26586  731   FORMAT('      IF EXACTLY ONE ERROR VARIABLE SPECIFIED,')
26587        CALL DPWRST('XXX','BUG ')
26588        WRITE(ICOUT,733)
26589  733   FORMAT('      THE NUMBER OF ELEMENTS MUST EQUAL EITHER THE')
26590        CALL DPWRST('XXX','BUG ')
26591        WRITE(ICOUT,735)N
26592  735   FORMAT('      NUMBER OF ELEMENTS IN THE RESPONSE VARIABLE (',
26593     1         I8,')')
26594        CALL DPWRST('XXX','BUG ')
26595        WRITE(ICOUT,737)M
26596  737   FORMAT('      OR THE NUMBER OF RESPONSE VARIABLES (',I8,').')
26597        CALL DPWRST('XXX','BUG ')
26598        WRITE(ICOUT,739)IODRE1(1),IODRE2(1),NERROR(1)
26599  739   FORMAT('      ERROR VARIABLE ',A4,A4,' HAS ',I8,' ELEMENTS.')
26600        IERROR='YES'
26601        GOTO9000
26602      ELSEIF(NUMERR.GT.1)THEN
26603        DO740JJ=1,NUMERR
26604          NTEMP=NLEFT
26605          IF(IMPFLG.EQ.'ON')NTEMP=NIV(1)
26606          IF(NERROR(JJ).NE.NTEMP)THEN
26607            WRITE(ICOUT,999)
26608            CALL DPWRST('XXX','BUG ')
26609            WRITE(ICOUT,2001)
26610            CALL DPWRST('XXX','BUG ')
26611            WRITE(ICOUT,741)IODRE1(JJ),IODRE2(JJ),NDELTA(JJ)
26612  741       FORMAT('      ERROR VARIABLE ',2A4,' HAS ',I8,' ELEMENTS.')
26613            CALL DPWRST('XXX','BUG ')
26614            WRITE(ICOUT,742)
26615  742       FORMAT('      HOWEVER, IT SHOULD HAVE THE SAME NUMBER OF ',
26616     1             'ELEMENTS AS THE')
26617            CALL DPWRST('XXX','BUG ')
26618            WRITE(ICOUT,743)N
26619  743       FORMAT('      INDEPENDENT VARIABLE(S).')
26620            CALL DPWRST('XXX','BUG ')
26621            WRITE(ICOUT,745)IVARN3(1),IVARN4(1),NTEMP
26622  745       FORMAT('      FIRST INDEPENDENT VARIABLE ',
26623     1             A4,A4,'  HAS ',I8,' ELEMENTS')
26624            CALL DPWRST('XXX','BUG ')
26625            WRITE(ICOUT,999)
26626            CALL DPWRST('XXX','BUG ')
26627            WRITE(ICOUT,2007)
26628            CALL DPWRST('XXX','BUG ')
26629            IF(IWIDTH.GE.1)THEN
26630              WRITE(ICOUT,2008)(IANS(I),I=1,MIN(100,IWIDTH))
26631              CALL DPWRST('XXX','BUG ')
26632            ENDIF
26633            IERROR='YES'
26634            GOTO9000
26635          ENDIF
26636  740   CONTINUE
26637      ELSE
26638        GOTO749
26639      ENDIF
26640C
26641  749 CONTINUE
26642C
26643C               ******************************************************
26644C               **  STEP 11D--                                      **
26645C               **  CHECK DELTA STARTING VALUE VARIABLES FOR        **
26646C               **  APPROPRIATE SIZES.  (IF NOT EQUAL 'OFF').       **
26647C               ******************************************************
26648C
26649      ISTEPN='11D'
26650      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH')
26651     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26652C
26653      IF(IODRD3(3).EQ.'OFF')GOTO779
26654      IF(IODRD3(3).EQ.'ON')GOTO779
26655      IF(NUMDE2.LT.1)GOTO779
26656C
26657      NTEMP=NLEFT
26658      IF(IMPFLG.EQ.'ON')NTEMP=NIV(1)
26659      DO770J=1,NUMDE2
26660        IF(NDELT2(J).NE.NTEMP)THEN
26661          WRITE(ICOUT,999)
26662          CALL DPWRST('XXX','BUG ')
26663          WRITE(ICOUT,2001)
26664          CALL DPWRST('XXX','BUG ')
26665          WRITE(ICOUT,771)IODRD3(J),IODRD4(J),NDELT2(J)
26666  771     FORMAT('      DELTA STARTING VALUE VARIABLE ',2A4,' HAS ',
26667     1           I8,' ELEMENTS.')
26668          CALL DPWRST('XXX','BUG ')
26669          WRITE(ICOUT,772)
26670  772     FORMAT('      HOWEVER, IT SHOULD HAVE THE SAME NUMBER OF ',
26671     1           'ELEMENTS AS THE')
26672          CALL DPWRST('XXX','BUG ')
26673          WRITE(ICOUT,773)N
26674  773     FORMAT('      INDEPENDENT VARIABLE(S).')
26675          CALL DPWRST('XXX','BUG ')
26676          WRITE(ICOUT,775)IVARN3(1),IVARN4(1),NTEMP
26677  775     FORMAT('      FIRST INDEPENDENT VARIABLE ',
26678     1           A4,A4,'  HAS ',I8,' ELEMENTS')
26679          CALL DPWRST('XXX','BUG ')
26680          WRITE(ICOUT,999)
26681          CALL DPWRST('XXX','BUG ')
26682          WRITE(ICOUT,2007)
26683          CALL DPWRST('XXX','BUG ')
26684          IF(IWIDTH.GE.1)THEN
26685            WRITE(ICOUT,2008)(IANS(I),I=1,MIN(100,IWIDTH))
26686            CALL DPWRST('XXX','BUG ')
26687          ENDIF
26688          IERROR='YES'
26689          GOTO9000
26690        ENDIF
26691  770 CONTINUE
26692C
26693  779 CONTINUE
26694C
26695C               *****************************************************
26696C               **  STEP 12--                                      **
26697C               **  BRANCH TO THE APPROPRIATE SUBCASE; THEN        **
26698C               **  COPY OVER THE RESPONSE VECTOR TO BE USED IN    **
26699C               **  THE MODEL INTO THE VECTOR Y; AND               **
26700C               **  COPY OVER THE WEIGHTS INTO THE VECTOR W; COPY  **
26701C               **  OVER THE VECTORS THAT WERE USED IN THE MODEL   **
26702C               **  INTO XMAT, COPY OVER THE DELTAS INTO RHO, AND  **
26703C               **  THE ERROR VARIABLE INTO IFIX.                  **
26704C               *****************************************************
26705C
26706      ISTEPN='12'
26707      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH')
26708     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26709C
26710      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH')THEN
26711        WRITE(ICOUT,601)N,NUMVAR
26712  601   FORMAT('N,NUMVAR = ',2I8)
26713        CALL DPWRST('XXX','BUG ')
26714      ENDIF
26715C
26716      NTEMP=NLEFT
26717      IF(IMPFLG.EQ.'ON')NTEMP=NIV(1)
26718C
26719      IF(ICASEQ.EQ.'FULL')THEN
26720        DO615I=1,NTEMP
26721          ISUB(I)=1
26722  615   CONTINUE
26723        NQZ=NTEMP
26724      ELSEIF(ICASEQ.EQ.'SUBS')THEN
26725        NIOLD=NTEMP
26726        CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR)
26727        NQZ=NIOLD
26728      ELSEIF(ICASEQ.EQ.'FOR')THEN
26729        NIOLD=NTEMP
26730        CALL DPFOR(NIOLD,NFOR,IROW1,IROWN,
26731     1             NLOCAL,ILOCS,NS,IBUGQ,IERROR)
26732        NQZ=NFOR
26733      ENDIF
26734C
26735      IF(IMPFLG.NE.'ON')THEN
26736        K=ICOLL
26737        J=0
26738        LDX=0
26739        DO4500I=1,NTEMP
26740          IF(ISUB(I).EQ.0)GOTO4500
26741          LDX=LDX+1
26742          J=J+1
26743          IJ=MAXN*(K-1)+I
26744          IF(K.LE.MAXCOL)YTEMP(J)=V(IJ)
26745          IF(K.EQ.MAXCP1)YTEMP(J)=PRED(I)
26746          IF(K.EQ.MAXCP2)YTEMP(J)=RES(I)
26747          IF(K.EQ.MAXCP3)YTEMP(J)=YPLOT(I)
26748          IF(K.EQ.MAXCP4)YTEMP(J)=XPLOT(I)
26749          IF(K.EQ.MAXCP5)YTEMP(J)=X2PLOT(I)
26750          IF(K.EQ.MAXCP6)YTEMP(J)=TAGPLO(I)
26751 4500   CONTINUE
26752        IF(NQ.GT.1)THEN
26753          IF(NQ*LDX.GT.MAXOB2)THEN
26754            WRITE(ICOUT,999)
26755            CALL DPWRST('XXX','BUG ')
26756            WRITE(ICOUT,2001)
26757            CALL DPWRST('XXX','BUG ')
26758            WRITE(ICOUT,4511)NQ*LDX
26759 4511       FORMAT('      TOTAL NUMBER OF RESPONSE VALUES (= ',I8,')')
26760            CALL DPWRST('XXX','BUG ')
26761            WRITE(ICOUT,4513)MAXOB2
26762 4513       FORMAT('      EXCEEDS THE MAXIMUM ALLOWED OF (',I8,').')
26763            CALL DPWRST('XXX','BUG ')
26764            IERROR='YES'
26765            GOTO9000
26766          ENDIF
26767C
26768          DO4505JJ=2,NQ
26769            J=(JJ-1)*LDX
26770            K=ICOLRV(JJ)
26771            DO4508I=1,NTEMP
26772              IF(ISUB(I).EQ.0)GOTO4508
26773              J=J+1
26774              IJ=MAXN*(K-1)+I
26775              IF(K.LE.MAXCOL)YTEMP(J)=V(IJ)
26776              IF(K.EQ.MAXCP1)YTEMP(J)=PRED(I)
26777              IF(K.EQ.MAXCP2)YTEMP(J)=RES(I)
26778              IF(K.EQ.MAXCP3)YTEMP(J)=YPLOT(I)
26779              IF(K.EQ.MAXCP4)YTEMP(J)=XPLOT(I)
26780              IF(K.EQ.MAXCP5)YTEMP(J)=X2PLOT(I)
26781              IF(K.EQ.MAXCP6)YTEMP(J)=TAGPLO(I)
26782 4508       CONTINUE
26783 4505     CONTINUE
26784        ENDIF
26785      ELSE
26786        LDX=0
26787        DO4501I=1,NTEMP
26788          IF(ISUB(I).EQ.0)GOTO4501
26789          LDX=LDX+1
26790          J=J+1
26791          YTEMP(J)=0.0D0
26792 4501   CONTINUE
26793      ENDIF
26794C
26795      IF(IMPFLG.NE.'ON')THEN
26796        W(1)=-1.0D0
26797        K=ICOLWR(1)
26798        J=0
26799        DO4580I=1,NTEMP
26800          IF(ISUB(I).EQ.0)GOTO4580
26801          J=J+1
26802          IF(K.LE.0)THEN
26803            W(J)=-1.0D0
26804          ELSE
26805            IJ=MAXN*(K-1)+I
26806            IF(K.LE.MAXCOL)W(J)=V(IJ)
26807            IF(K.EQ.MAXCP1)W(J)=PRED(I)
26808            IF(K.EQ.MAXCP2)W(J)=RES(I)
26809            IF(K.EQ.MAXCP3)W(J)=YPLOT(I)
26810            IF(K.EQ.MAXCP4)W(J)=XPLOT(I)
26811            IF(K.EQ.MAXCP5)W(J)=X2PLOT(I)
26812            IF(K.EQ.MAXCP6)W(J)=TAGPLO(I)
26813          ENDIF
26814 4580   CONTINUE
26815        IF(NQ.GT.1)THEN
26816          DO4585JJ=2,NQ
26817            J=(JJ-1)*LDX
26818            K=ICOLWR(JJ)
26819            DO4588I=1,NTEMP
26820              IF(ISUB(I).EQ.0)GOTO4588
26821              J=J+1
26822              IF(K.LE.0)THEN
26823                W(J)=1.0
26824              ELSE
26825                IJ=MAXN*(K-1)+I
26826                IF(K.LE.MAXCOL)W(J)=V(IJ)
26827                IF(K.EQ.MAXCP1)W(J)=PRED(I)
26828                IF(K.EQ.MAXCP2)W(J)=RES(I)
26829                IF(K.EQ.MAXCP3)W(J)=YPLOT(I)
26830                IF(K.EQ.MAXCP4)W(J)=XPLOT(I)
26831                IF(K.EQ.MAXCP5)W(J)=X2PLOT(I)
26832                IF(K.EQ.MAXCP6)W(J)=TAGPLO(I)
26833              ENDIF
26834 4588       CONTINUE
26835 4585     CONTINUE
26836        ENDIF
26837      ELSE
26838        W(1)=-1.0D0
26839      ENDIF
26840C
26841      LDIFX=1
26842      IF(IODRE1(1).EQ.'OFF')THEN
26843        DO381J=1,M
26844          IFIX(J)=0
26845  381   CONTINUE
26846      ELSEIF(IODRE1(1).EQ.'ON')THEN
26847        DO382J=1,M
26848          IFIX(J)=1
26849  382   CONTINUE
26850      ELSEIF(NUMERR.GE.1 .AND. NERROR(1).EQ.N)THEN
26851        LDIFX=LDX
26852        DO4591L=1,NUMERR
26853          K=ICOLE(L)
26854          J=(L-1)*LDX
26855          DO4593I=1,NERROR(L)
26856            J=J+1
26857            IJ=MAXN*(K-1)+I
26858            IF(K.LE.MAXCOL)IFIX(J)=INT(ABS(V(IJ))+0.5)
26859            IF(K.EQ.MAXCP1)IFIX(J)=INT(ABS(PRED(I))+0.5)
26860            IF(K.EQ.MAXCP2)IFIX(J)=INT(ABS(RES(I))+0.5)
26861            IF(K.EQ.MAXCP3)IFIX(J)=INT(ABS(YPLOT(I))+0.5)
26862            IF(K.EQ.MAXCP4)IFIX(J)=INT(ABS(XPLOT(I))+0.5)
26863            IF(K.EQ.MAXCP5)IFIX(J)=INT(ABS(X2PLOT(I))+0.5)
26864            IF(K.EQ.MAXCP6)IFIX(J)=INT(ABS(TAGPLO(I))+0.5)
26865 4593     CONTINUE
26866 4591   CONTINUE
26867      ELSEIF(NUMERR.GE.1 .AND. NERROR(1).EQ.M)THEN
26868        LDIFX=1
26869        K=ICOLE(1)
26870        J=0
26871        DO4597I=1,NERROR(1)
26872          J=J+1
26873          IJ=MAXN*(K-1)+I
26874          IF(K.LE.MAXCOL)IFIX(J)=INT(ABS(V(IJ))+0.5)
26875          IF(K.EQ.MAXCP1)IFIX(J)=INT(ABS(PRED(I))+0.5)
26876          IF(K.EQ.MAXCP2)IFIX(J)=INT(ABS(RES(I))+0.5)
26877          IF(K.EQ.MAXCP3)IFIX(J)=INT(ABS(YPLOT(I))+0.5)
26878          IF(K.EQ.MAXCP4)IFIX(J)=INT(ABS(XPLOT(I))+0.5)
26879          IF(K.EQ.MAXCP5)IFIX(J)=INT(ABS(X2PLOT(I))+0.5)
26880          IF(K.EQ.MAXCP6)IFIX(J)=INT(ABS(TAGPLO(I))+0.5)
26881 4597   CONTINUE
26882      ELSE
26883        IFIX(1)=-1
26884        LDIFX=1
26885      ENDIF
26886C
26887      IF(NUMVAR.GE.1)THEN
26888        DO385L=1,NUMVAR
26889          K=ICOLV3(L)
26890          J=(L-1)*LDX
26891          DO386I=1,NTEMP
26892            IF(ISUB(I).EQ.0)GOTO386
26893            J=J+1
26894            IJ=MAXN*(K-1)+I
26895            IF(K.LE.MAXCOL)XMAT(J)=V(IJ)
26896            IF(K.EQ.MAXCP1)XMAT(J)=PRED(I)
26897            IF(K.EQ.MAXCP2)XMAT(J)=RES(I)
26898            IF(K.EQ.MAXCP3)XMAT(J)=YPLOT(I)
26899            IF(K.EQ.MAXCP4)XMAT(J)=XPLOT(I)
26900            IF(K.EQ.MAXCP5)XMAT(J)=X2PLOT(I)
26901            IF(K.EQ.MAXCP6)XMAT(J)=TAGPLO(I)
26902  386     CONTINUE
26903  385   CONTINUE
26904      ENDIF
26905      IF(IMPFLG.EQ.'ON')N=LDX
26906C
26907      IF(NUMDEL.GE.1.AND.NDELTA(1).EQ.N)THEN
26908        LDRHO=LDX
26909        DO395L=1,NUMDEL
26910          K=ICOLD(L)
26911          J=(L-1)*LDX
26912          DO396I=1,NTEMP
26913            IF(ISUB(I).EQ.0)GOTO396
26914            J=J+1
26915            IJ=MAXN*(K-1)+I
26916            IF(K.LE.MAXCOL)RHO(J)=V(IJ)
26917            IF(K.EQ.MAXCP1)RHO(J)=PRED(I)
26918            IF(K.EQ.MAXCP2)RHO(J)=RES(I)
26919            IF(K.EQ.MAXCP3)RHO(J)=YPLOT(I)
26920            IF(K.EQ.MAXCP4)RHO(J)=XPLOT(I)
26921            IF(K.EQ.MAXCP5)RHO(J)=X2PLOT(I)
26922            IF(K.EQ.MAXCP6)RHO(J)=TAGPLO(I)
26923  396     CONTINUE
26924  395   CONTINUE
26925      ELSEIF(NUMDEL.EQ.1.AND.NDELTA(1).EQ.M)THEN
26926        LDRHO=1
26927        J=0
26928        K=ICOLD(1)
26929        DO398I=1,M
26930          J=J+1
26931          IJ=MAXN*(K-1)+I
26932          IF(K.LE.MAXCOL)RHO(J)=V(IJ)
26933          IF(K.EQ.MAXCP1)RHO(J)=PRED(I)
26934          IF(K.EQ.MAXCP2)RHO(J)=RES(I)
26935          IF(K.EQ.MAXCP3)RHO(J)=YPLOT(I)
26936          IF(K.EQ.MAXCP4)RHO(J)=XPLOT(I)
26937          IF(K.EQ.MAXCP5)RHO(J)=X2PLOT(I)
26938          IF(K.EQ.MAXCP6)RHO(J)=TAGPLO(I)
26939  398   CONTINUE
26940        DO399I=M+1,N*M
26941          RHO(I)=0.0D0
26942  399   CONTINUE
26943      ELSE
26944        LDRHO=1
26945        RHO(1)=-1.0
26946      ENDIF
26947C
26948      IF(NUMDE2.GE.1.AND.(IODRD3(1).NE.'OFF'.AND.IODRD3(1).NE.'ON'))THEN
26949        DO405L=1,NUMDE2
26950          K=ICOLD2(L)
26951          J=(L-1)*LDX
26952          DO406I=1,NTEMP
26953            IF(ISUB(I).EQ.0)GOTO406
26954            J=J+1
26955            IJ=MAXN*(K-1)+I
26956            IF(K.LE.MAXCOL)WORK(J)=V(IJ)
26957            IF(K.EQ.MAXCP1)WORK(J)=PRED(I)
26958            IF(K.EQ.MAXCP2)WORK(J)=RES(I)
26959            IF(K.EQ.MAXCP3)WORK(J)=YPLOT(I)
26960            IF(K.EQ.MAXCP4)WORK(J)=XPLOT(I)
26961            IF(K.EQ.MAXCP5)WORK(J)=X2PLOT(I)
26962            IF(K.EQ.MAXCP6)WORK(J)=TAGPLO(I)
26963  406     CONTINUE
26964  405   CONTINUE
26965      ELSE
26966        DO408I=1,N*M
26967          WORK(I)=0.0D0
26968  408   CONTINUE
26969      ENDIF
26970C
26971C               ******************************************************
26972C               **  STEP 13--                                       **
26973C               **  PREPARE FOR ENTRANCE INTO DPORTH2               **
26974C               **  SET THE ICON3 VECTOR                            **
26975C               **  (WHICH INDICATES WHICH PARAMETERS ARE TO BE HELD**
26976C               **  CONSTANT) EQUAL TO 0 THROUGHOUT.                **
26977C               **  DEFINE CONSTRAINTS AND LIMITS.                  **
26978C               ******************************************************
26979C
26980      ISTEPN='13'
26981      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH')
26982     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26983C
26984      DO4195I=1,NUMPAR
26985        ICON3(I)=0
26986 4195 CONTINUE
26987C
26988      IF(NUMCON.NE.0)THEN
26989        DO4700I=1,NUMPAR
26990          DO4800J=1,NUMCON
26991            J2=J
26992            IF(IPARN3(I).EQ.IPARNC(J).AND.IPARN4(I).EQ.IPANC2(J))THEN
26993              IPARO3(I)=IPAROC(J2)
26994              PARLI3(I)=PARLIM(J2)
26995              GOTO4700
26996            ENDIF
26997 4800     CONTINUE
26998          IPARO3(I)='NONE'
26999 4700   CONTINUE
27000      ENDIF
27001C
27002C               ******************************************************
27003C               **  STEP 14--                                       **
27004C               **  CARRY OUT THE ACTUAL FIT                        **
27005C               **  VIA CALLING                                     **
27006C               **  DPORTH2 (FOR GENERAL MODELS), OR                **
27007C               ******************************************************
27008C
27009      ISTEPN='14'
27010      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH')
27011     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
27012      IBUGAZ=IBUGA3
27013C
27014      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH')THEN
27015        WRITE(ICOUT,999)
27016        CALL DPWRST('XXX','BUG ')
27017        WRITE(ICOUT,6081)
27018 6081   FORMAT('***** FROM DPORTH, AS ABOUT TO CALL DPORT2--')
27019        CALL DPWRST('XXX','BUG ')
27020        DO6083I=1,NS
27021          WRITE(ICOUT,6084)I,Y(I),XMAT(I),W(I),RHO(I),IFIX(I)
27022 6084     FORMAT('I,Y(I),XMAT(I),W(I) = ',I6,2X,4F10.5,2X,I6)
27023          CALL DPWRST('XXX','BUG ')
27024 6083   CONTINUE
27025        DO6185L=1,MAX(NQ,1)
27026          WRITE(ICOUT,6082)NUMCHZ(L),NLEFT,MAXN,NS,NUMPAZ(L),NUMVAZ(L)
27027 6082     FORMAT('NUMCHA,NLEFT,MAXN,NS,NUMPAR,NUMVAR = ',7I8)
27028          CALL DPWRST('XXX','BUG ')
27029          WRITE(ICOUT,6187)L,NUMCHZ(L)
27030 6187     FORMAT('L,NUMCHZ(L) = ',I5,I5)
27031          WRITE(ICOUT,6085)(ZMODEL(I,L),I=1,MIN(120,NUMCHZ(L)))
27032 6085     FORMAT('MODEL(.)--',120A1)
27033          CALL DPWRST('XXX','BUG ')
27034 6185   CONTINUE
27035        DO6286L=1,MAX(NQ,1)
27036          DO6086J=1,NUMPAZ(L)
27037            WRITE(ICOUT,6087)J,ZIPARN(J,L),ZPARN2(J,L),
27038     1                       PARAM3(J),ICON3(J)
27039 6087       FORMAT('I,ZIPARN(I),ZPARN2(I),PARAM3(I),ICON3(I) = ',
27040     1             I8,2X,A4,A4,E15.7,A4)
27041            CALL DPWRST('XXX','BUG ')
27042 6086     CONTINUE
27043          DO6088J=1,NUMVAZ(L)
27044            WRITE(ICOUT,6089)J,ZIDUMV(J,L),ZDUMV2(J,L),LOCDUM(J,L)
27045 6089       FORMAT('I,ZIDUMV(I,L),ZDUMV2(I,L),LOCDUM(I,L) = ',
27046     1             I8,2X,A4,A4,2X,I8)
27047            CALL DPWRST('XXX','BUG ')
27048 6088     CONTINUE
27049 6286   CONTINUE
27050        WRITE(ICOUT,6091)IBUGA3,IBUGCO,IBUGEV,NUMIND
27051 6091   FORMAT('IBUGA3,IBUGCO,IBUGEV,NUMIND = ',A4,2X,A4,2X,A4,I8)
27052        CALL DPWRST('XXX','BUG ')
27053      ENDIF
27054C
27055      LIWORK=MAXOBV
27056C
27057      CALL DPORT2(YTEMP,N,XMAT,LDX,RHO,LDRHO,IFIX,LDIFX,NP,M,NQ,
27058     1            WORK,LWORK,IWORK,LIWORK,W,
27059     1            PARAM3,IPARN3,IPARN4,MAXITS,
27060     1            IREP,REPSD,REPDF,RESSD,RESDF,PRED2,RES2,ALFCDF,
27061     1            PODRTF,PODRST,PODRPT,IODRPO,IODRE1,
27062     1            IMPFLG,IAUXDP,
27063     1            IBUGA3,ISUBRO,IERROR)
27064      IF(IERROR.EQ.'YES')GOTO9000
27065C
27066C               ***************************************
27067C               **  STEP 15--                        **
27068C               **  UPDATE INTERNAL DATAPLOT TABLES  **
27069C               ***************************************
27070C
27071      ISTEPN='15'
27072      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH')
27073     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
27074C
27075      ICOLPR=MAXCP1
27076      ICOLRE=MAXCP2
27077      IREPU='OFF'
27078      IRESU='ON'
27079      REPSD=0.0
27080      REPDF=0.0
27081C
27082      CALL UPDAPR(ICOLPR,ICOLRE,PRED2,RES2,PRED,RES,ISUB,NLEFT,
27083     1            IREPU,REPSD,REPDF,IRESU,RESSD,RESDF,ALFCDF,
27084     1            IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
27085     1            IANS,IWIDTH,ILOCN,IBUGA3,IERROR)
27086C
27087C               *************************************************
27088C               **  STEP 17--                                  **
27089C               **  COPY THE FINAL ESTIMATES FROM THE FIT      **
27090C               **  BACK INTO THE PARAMETERS.                  **
27091C               **  THESE FINAL ESTIMATES WILL THUS OVERWRITE  **
27092C               **  THE STARTING VALUES THAT WERE              **
27093C               **  ORIGINALLY ASSIGNED TO THE PARAMETERS.     **
27094C               *************************************************
27095C
27096      ISTEPN='17'
27097      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH')
27098     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
27099C
27100      IF(NUMPAR.GE.1)THEN
27101        DO6100J=1,NUMPAR
27102          IH=IPARN3(J)
27103          IH2=IPARN4(J)
27104          IHWUSE='P'
27105          MESSAG='YES'
27106          CALL CHECKN(IH,IH2,IHWUSE,
27107     1                IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
27108     1                ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
27109          IF(IERROR.EQ.'YES')GOTO9000
27110          VALUE(ILOCP)=PARAM3(J)
27111 6100   CONTINUE
27112      ENDIF
27113C
27114C               *****************
27115C               **  STEP 90--  **
27116C               **  EXIT       **
27117C               *****************
27118C
27119 9000 CONTINUE
27120      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH')THEN
27121        WRITE(ICOUT,999)
27122        CALL DPWRST('XXX','BUG ')
27123        WRITE(ICOUT,9011)
27124 9011   FORMAT('***** AT THE END       OF DPORTH--')
27125        CALL DPWRST('XXX','BUG ')
27126        WRITE(ICOUT,9015)NS,NUMNAM,ICASFI,ICASEQ
27127 9015   FORMAT('NS,NUMNAM,ICASFI,ICASEQ = ',2I8,2(2X,A4))
27128        CALL DPWRST('XXX','BUG ')
27129        DO9017I=1,NUMNAM
27130          WRITE(ICOUT,9018)I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),
27131     1                     IVALUE(I),VALUE(I)
27132 9018     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),IVALUE(I)',
27133     1           'VALUE(I) = ',I8,2X,A4,A4,2X,A4,I8,I8,G15.7)
27134          CALL DPWRST('XXX','BUG ')
27135 9017   CONTINUE
27136        WRITE(ICOUT,9051)MAXN2,NLEFT,NS,V(1),PRED(1),RES(1)
27137 9051   FORMAT('MAXN2,NLEFT,NS,V(1),PRED(1),RES(1) = ',3I8,3G15.7)
27138        CALL DPWRST('XXX','BUG ')
27139        WRITE(ICOUT,9053)ICOLW,NWEIGH,IWIDTH,IWEIGH
27140 9053   FORMAT('ICOLW,NWEIGH,IWIDTH,IWEIGH = ',3I8,2X,A4)
27141        CALL DPWRST('XXX','BUG ')
27142        IF(IWIDTH.GE.1)THEN
27143          WRITE(ICOUT,9062)(IANS(I),I=1,MIN(100,IWIDTH))
27144 9062     FORMAT('(IANS(I),I=1,IWIDTH) = ',100A1)
27145          CALL DPWRST('XXX','BUG ')
27146        ENDIF
27147        WRITE(ICOUT,9069)IFOUND,IERROR
27148 9069   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
27149        CALL DPWRST('XXX','BUG ')
27150      ENDIF
27151C
27152      RETURN
27153      END
27154      SUBROUTINE DPORT2(Y,N,XMAT,LDX,RHO,LDRHO,IFIX,LDIFX,NP,M,NQ,
27155     1                  WORK,LWORK,IWORK,LIWORK,W,
27156     1                  PARAM3,IPARN3,IPARN4,MAXITS,
27157     1                  IREP,REPSD,REPDF,RESSD,RESDF,PRED2,RES2,ALFCDF,
27158     1                  PODRTF,PODRST,PODRPT,IODRPO,IODRE1,
27159     1                  IMPFLG,IAUXDP,
27160     1                  IBUGA3,ISUBRO,IERROR)
27161C
27162C     USE ODRPACK TO COMPUTE ORTHOGONAL DISTANCE REGRESSION (ALSO
27163C     CALLED ERRORS IN VARIABLES REGRESSION).
27164C
27165C
27166C     WRITTEN BY--ALAN HECKERT
27167C                 STATISTICAL ENGINEERING DIVISION
27168C                 INFORMATION TECHNOLOGY LABORATORY
27169C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
27170C                 GAITHERSBURG, MD 20899-8980
27171C                 PHONE--301-975-2899
27172C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
27173C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
27174C     LANGUAGE--ANSI FORTRAN (1977)
27175C     VERSION NUMBER--2001/4
27176C     ORIGINAL VERSION--APRIL     2001.
27177C     UPDATED         --APRIL     2019. USER CAN SPECIFY NUMBER OF
27178C                                       DECIMAL POINTS FOR AUXILLARY
27179C                                       FILES
27180C
27181C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
27182C
27183      CHARACTER*4 IODRE1(*)
27184      CHARACTER*4 IODRPO
27185      CHARACTER*4 IREP
27186      CHARACTER*4 IMPFLG
27187      CHARACTER*4 IBUGA3
27188      CHARACTER*4 ISUBRO
27189      CHARACTER*4 IERROR
27190C
27191      CHARACTER*4 ISUBN1
27192      CHARACTER*4 ISUBN2
27193      CHARACTER*4 ISTEPN
27194C
27195      CHARACTER*4 IOP
27196      CHARACTER*30 IFORMT
27197C
27198C---------------------------------------------------------------------
27199C
27200      INTEGER N, NQ, M, NP
27201C
27202      INTEGER IFIXB(1)
27203      INTEGER IFIX(LDIFX,M)
27204      INTEGER IWORK(*)
27205C
27206      DOUBLE PRECISION SCLD(1,1)
27207      DOUBLE PRECISION SCLB(1)
27208      DOUBLE PRECISION STPB(1)
27209      DOUBLE PRECISION STPD(1,1)
27210      DOUBLE PRECISION BETA(100)
27211      DOUBLE PRECISION TAUFAC
27212      DOUBLE PRECISION SSTOL
27213      DOUBLE PRECISION PARTOL
27214C
27215      DOUBLE PRECISION XMAT(LDX,M)
27216      DOUBLE PRECISION RHO(LDRHO,1,M)
27217      DOUBLE PRECISION WORK(*)
27218      DOUBLE PRECISION Y(N,NQ)
27219      DOUBLE PRECISION W(N,1,NQ)
27220      REAL PRED2(*)
27221      REAL RES2(*)
27222C
27223      INTEGER DELTAI, EPSI, XPLUSI, FNI, SDI, VCVI
27224      INTEGER RVARI, WSSI, WSSDEI, WSSEPI, RCONDI, ETAI
27225      INTEGER OLMAVI, TAUI, ALPHAI, ACTRSI, PNORMI, RNORSI, PRERSI
27226      INTEGER PARTLI, SSTOLI, TAUFCI, EPSMAI
27227      INTEGER BETA0I, BETACI, BETASI, BETANI, SI, SSI, SSFI, QRAUXI, UI
27228      INTEGER FSI, FJACBI, WE1I, DIFFI
27229      INTEGER DELTSI, DELTNI, TI, TTI, OMEGAI, FJACDI
27230      INTEGER WRK1I, WRK2I, WRK3I, WRK4I, WRK5I, WRK6I, WRK7I
27231      INTEGER LWKMN
27232C
27233      INTEGER
27234     1    MSGBI, MSGDI, IFIX2I, ISTOPI,
27235     1    NNZWI, NPPI, IDFI,
27236     1    JOBI, IPRINI, LUNERI, LUNRPI,
27237     1    NROWI, NTOLI, NETAI,
27238     1    MAXITI, NITERI, NFEVI, NJEVI, INT2I, IRANKI, LDTTI,
27239     1    LIWKMN
27240C
27241      INTEGER LDRHO, LD2WD, LDWE, LD2WE
27242C
27243      LOGICAL ISODR
27244C
27245C---------------------------------------------------------------------
27246C
27247      CHARACTER*4 IPARN3
27248      CHARACTER*4 IPARN4
27249      DIMENSION IPARN3(*)
27250      DIMENSION IPARN4(*)
27251      DIMENSION PARAM3(*)
27252C
27253      EXTERNAL FUN
27254C
27255C---------------------------------------------------------------------
27256C
27257      INCLUDE 'DPCOP2.INC'
27258C
27259C-----START POINT-----------------------------------------------------
27260C
27261      ISUBN1='DPOR'
27262      ISUBN2='T2  '
27263      IERROR='NO'
27264C
27265      ALFCDF=0.0
27266      REPSD=0.0
27267      REPDF=0.0
27268C
27269      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'ORT2')THEN
27270        WRITE(ICOUT,999)
27271  999   FORMAT(1X)
27272        CALL DPWRST('XXX','BUG ')
27273        WRITE(ICOUT,51)
27274   51   FORMAT('***** AT THE BEGINNING OF DPORT2--')
27275        CALL DPWRST('XXX','BUG ')
27276        WRITE(ICOUT,52)N,NP,M,NQ
27277   52   FORMAT('N,NP,M,NQ = ',4I8)
27278        CALL DPWRST('XXX','BUG ')
27279        WRITE(ICOUT,53)LDX,LDIFX,LDRHO,IREP
27280   53   FORMAT('LDX,LDIFX,LDRHO,IREP = ',3I8,2X,A4)
27281        CALL DPWRST('XXX','BUG ')
27282        DO55I=1,N
27283          WRITE(ICOUT,56)I,Y(I,1),XMAT(I,1),RHO(I,1,1),W(I,1,1)
27284   56     FORMAT('I,Y(I,1),XMAT(I,1),RHO(I,1,1),W(I,1) = ',
27285     1           I5,4G15.7)
27286          CALL DPWRST('XXX','BUG ')
27287   55   CONTINUE
27288        DO63J=1,MAX(LDIFX,M)
27289          WRITE(ICOUT,64)J,(IFIX(J,L),L=1,M)
27290   64     FORMAT('I,IFIX(I,L),L=1,M) = ',20I3)
27291          CALL DPWRST('XXX','BUG ')
27292   63   CONTINUE
27293        DO76J=1,N*M
27294          WRITE(ICOUT,77)J,WORK(J)
27295   77     FORMAT('J,WORK(J) =',I8,G15.7)
27296          CALL DPWRST('XXX','BUG ')
27297   76   CONTINUE
27298      ENDIF
27299C
27300C               **************************************************
27301C               **  STEP 0.5--                                  **
27302C               **   OPEN THE STORAGE FILES                     **
27303C               **************************************************
27304C
27305      ISTEPN='0.5'
27306      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIT2')
27307     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
27308C
27309      IOP='OPEN'
27310      IFLAG1=1
27311      IFLAG2=1
27312      IFLAG3=1
27313      IFLAG4=1
27314      IFLAG5=0
27315      CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
27316     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
27317     1            IBUGA3,ISUBRO,IERROR)
27318      IF(IERROR.EQ.'YES')GOTO9000
27319C
27320C               *****************************************************
27321C               **  STEP 2--                                       **
27322C               **  DEFINE NEED VALUES AND THEN CALL ODRPACK       **
27323C               **  DRIVER ROUTINE (DODRC).                        **
27324C               **  INITIALIZE VALUES THAT USE DEFAULT VALUES.     **
27325C               *****************************************************
27326C
27327      ISTEPN='2'
27328      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'ORT2')
27329     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
27330C
27331C  DEFINE STARTING VALUES FOR FUNCTION PARAMETERS
27332      DO110I=1,MIN(NP,100)
27333        BETA(I)=DBLE(PARAM3(I))
27334  110 CONTINUE
27335      LDNP=NP
27336C
27337C  DEPENDENT AND EXPLANATORY VARIABLES
27338      LDY=LDX
27339      LDN=LDX
27340C
27341C  WEIGHTS
27342      LDWE=LDY
27343      IF(IMPFLG.EQ.'ON')THEN
27344        LDWE=1
27345        W(1,1,1)=-1.0D0
27346      ENDIF
27347      LD2WE=1
27348      LD2WD=1
27349C
27350C  PARAMETER AND VARIABLE FIXING
27351      IFIXB(1)=-1
27352C
27353C  COMPUTATION AND INITIALIZATION CONTROL
27354      ISODR=.TRUE.
27355      IF(IMPFLG.EQ.'ON')THEN
27356        IDIG1=1
27357      ELSE
27358        IDIG1=0
27359        IF(IODRE1(1).EQ.'OFF')THEN
27360          IDIG1=2
27361          ISODR=.FALSE.
27362        ENDIF
27363      ENDIF
27364      IDIG2=1
27365      IF(IMPFLG.EQ.'ON')IDIG2=0
27366      IDIG3=0
27367      IDIG4=0
27368      IF(WORK(1).NE.0.0D0)IDIG4=1
27369      IDIG5=0
27370      JOB=IDIG1 + 10*IDIG2 + 100*IDIG3 + 1000*IDIG4 + 10000*IDIG5
27371      NDIGIT=-1
27372      TAUFAC=PODRTF
27373C
27374C  STOPPING CRITIERION
27375      SSTOL=PODRST
27376      PARTOL=PODRPT
27377      MAXITF=MAXITS
27378C
27379C  PRINT CONTROL
27380      LUNERR=IPR
27381      LUNRPT=IPR
27382      IF(IODRPO.EQ.'FULL')THEN
27383        IPRNT=2212
27384      ELSEIF(IODRPO.EQ.'INTE')THEN
27385        IPRNT=1111
27386      ELSEIF(IODRPO.EQ.'SHOR')THEN
27387        IPRNT=1001
27388      ELSE
27389        IPRNT=1111
27390      ENDIF
27391C
27392C  DERIVATIVE STEP SIZES
27393      STPD(1,1)=-1.0D0
27394      STPB(1)=-1.0D0
27395      LDSTPD=1
27396C
27397C  SCALING
27398      SCLD(1,1)=-1.0D0
27399      LDSCLD=1
27400      SCLB(1)=-1.0D0
27401C
27402C  STOPPING CONDITION
27403C
27404CCCCC FOLLOWING LINES WERE TEMPORARY DEBUGGING
27405ccccc print *,'n,m,np,nq=',n,m,np,nq
27406ccccc print *,'beta = ',(beta(i),i=1,np)
27407ccccc print *,'y = ',(Y(i,1),i=1,n)
27408ccccc print *,'ldy,ldx,ldwe,ld2we=',ldy,ldx,ldwe,ld2we
27409ccccc print *,'xmat=',((xmat(i,j),i=1,n),j=1,m)
27410ccccc print *,'w=',(w(i,1,1),i=1,n)
27411ccccc print *,'rho=',(rho(i,1,1),i=1,n)
27412ccccc print *,'ifixb(1)=',ifixb(1)
27413ccccc print *,'ifix=',((ifix(i,j),i=1,n),j=1,m)
27414ccccc print *,'ldifx,ldrho,ld2wd=',ldifx,ldrho,ld2wd
27415ccccc print *,'job,ndigit,taufac=',job,ndigit,taufac
27416ccccc print *,'sstol,partol,maxitf=',sstol,partol,maxitf
27417ccccc print *,'iprnt,lunerr,lunrpt=',iprnt,lunerr,lunrpt
27418ccccc print *,'stpb,stpd,ldstpd=',stpb(1),stpd(1,1),ldstpd
27419ccccc print *,'sclb,scld,ldscd=',sclb(1),scld(1,1),ldscld
27420ccccc print *,'work=',(work(i),i=1,n*m)
27421ccccc print *,'lwork.liwork=',lwork,liwork
27422ccccc print *,'info=',info
27423C
27424      CALL DODRC(
27425     1    FUN,
27426     1    N, M, NP, NQ,
27427     1    BETA,
27428     1    Y, LDY, XMAT, LDX,
27429     1    W, LDWE, LD2WE, RHO, LDRHO, LD2WD,
27430     1    IFIXB, IFIX, LDIFX,
27431     1    JOB, NDIGIT, TAUFAC,
27432     1    SSTOL, PARTOL, MAXITF,
27433     1    IPRNT,LUNERR,LUNRPT,
27434     1    STPB, STPD, LDSTPD,
27435     1    SCLB, SCLD,LDSCLD,
27436     1    WORK, LWORK, IWORK, LIWORK,
27437     1    INFO)
27438C
27439      DO120I=1,MIN(NP,100)
27440        PARAM3(I)=REAL(BETA(I))
27441  120 CONTINUE
27442C
27443C  CHECK FOR ERROR MESSAGES
27444C
27445      IF(INFO.GE.0)THEN
27446        IDIG5 = MOD(INFO,100000)/10000
27447        IDIG4 = MOD(INFO,10000)/1000
27448        IDIG3 = MOD(INFO,1000)/100
27449        IDIG2 = MOD(INFO,100)/10
27450        IDIG1 = MOD(INFO,10)
27451      ENDIF
27452C
27453      IF(INFO.LT.0)THEN
27454        WRITE(ICOUT,999)
27455        CALL DPWRST('XXX','BUG ')
27456        WRITE(ICOUT,999)
27457        CALL DPWRST('XXX','BUG ')
27458        WRITE(ICOUT,208)
27459 208    FORMAT('***** ERROR FROM DPORT2--COMPUTATIONS STOPPED IN ',
27460     1         'FUNCTION EVALUATION ROUTINE.')
27461        CALL DPWRST('XXX','BUG ')
27462        IERROR='YES'
27463        GOTO9000
27464      ELSEIF(INFO.GE.1 .AND. INFO.LE.4)THEN
27465        WRITE(ICOUT,999)
27466        CALL DPWRST('XXX','BUG ')
27467        WRITE(ICOUT,999)
27468        CALL DPWRST('XXX','BUG ')
27469        WRITE(ICOUT,210)
27470 210    FORMAT('***** ODRPACK CONVERGED SUCCESSFULLY.')
27471        CALL DPWRST('XXX','BUG ')
27472        IF(INFO.EQ.1)WRITE(ICOUT,211)
27473        IF(INFO.EQ.2)WRITE(ICOUT,212)
27474        IF(INFO.EQ.3)WRITE(ICOUT,213)
27475 211    FORMAT('      SUM-OF-SQUARES CONVERGENCE.')
27476 212    FORMAT('      PARAMETER CONVERGENCE.')
27477 213    FORMAT('      BOTH SUM-OF-SQUARES CONVERGENCE AND PARAMETER ',
27478     1         'CONVERGENCE.')
27479        CALL DPWRST('XXX','BUG ')
27480      ELSEIF(INFO.EQ.4)THEN
27481        WRITE(ICOUT,999)
27482        CALL DPWRST('XXX','BUG ')
27483        WRITE(ICOUT,999)
27484        CALL DPWRST('XXX','BUG ')
27485        WRITE(ICOUT,410)MAXITF
27486 410    FORMAT('***** WARNING: ODRPACK REACHED MAXIMUM NUMBER OF ',
27487     1         'ITERATIONS,',I8,' WITHOUT CONVERGING.')
27488        CALL DPWRST('XXX','BUG ')
27489      ELSEIF(INFO.GT.4 .AND. IDIG5.EQ.0)THEN
27490        WRITE(ICOUT,999)
27491        CALL DPWRST('XXX','BUG ')
27492        WRITE(ICOUT,999)
27493        CALL DPWRST('XXX','BUG ')
27494        WRITE(ICOUT,510)
27495 510    FORMAT('***** WARNING: ODRPACK RESULTS QUESTIONABLE.')
27496        CALL DPWRST('XXX','BUG ')
27497        IF(IDIG4.GE.1)THEN
27498          WRITE(ICOUT,502)
27499 502      FORMAT('      DERIVATIVES POSSIBLY NOT CORRECT.')
27500          CALL DPWRST('XXX','BUG ')
27501        ELSEIF(IDIG3.GE.1 )THEN
27502          WRITE(ICOUT,511)
27503 511      FORMAT('      LAST FUNCTION EVALUATION RETURNED AN ERROR.')
27504          CALL DPWRST('XXX','BUG ')
27505        ELSEIF(IDIG2.GE.2)THEN
27506          WRITE(ICOUT,513)
27507 513      FORMAT('      PROBLEM IS NOT FULL RANK AT SOLUTION.')
27508          CALL DPWRST('XXX','BUG ')
27509        ENDIF
27510      ELSEIF(INFO.GT.4 .AND. IDIG5.GE.1)THEN
27511        WRITE(ICOUT,999)
27512        CALL DPWRST('XXX','BUG ')
27513        WRITE(ICOUT,999)
27514        CALL DPWRST('XXX','BUG ')
27515        WRITE(ICOUT,610)
27516 610    FORMAT('***** ERROR: ODRPACK DETECTED FATAL ERRORS IN ',
27517     1         'USER INPUT.')
27518        CALL DPWRST('XXX','BUG ')
27519        IF(IDIG5.EQ.1 .AND. IDIG4.GE.1)THEN
27520          WRITE(ICOUT,620)
27521 620      FORMAT('      NUMBER OF OBSERVATIONS LESS THAN 1.')
27522          CALL DPWRST('XXX','BUG ')
27523          IERROR='YES'
27524          GOTO9000
27525        ELSEIF(IDIG5.EQ.1 .AND. IDIG3.GE.1)THEN
27526          WRITE(ICOUT,630)
27527 630      FORMAT('      NUMBER OF INDEPENDENT VARIABLES LESS THAN ',
27528     1           '1.')
27529          CALL DPWRST('XXX','BUG ')
27530          IERROR='YES'
27531          GOTO9000
27532        ELSEIF(IDIG5.EQ.1 .AND. IDIG2.GE.1)THEN
27533          WRITE(ICOUT,640)
27534 640      FORMAT('      NUMBER OF PARAMETERS LESS THAN 1 OR GREATER',
27535     1           'THAN NUMBER OF OBSERVATIONS.')
27536          CALL DPWRST('XXX','BUG ')
27537          IERROR='YES'
27538          GOTO9000
27539        ELSEIF(IDIG5.EQ.1 .AND. IDIG1.GE.1)THEN
27540          WRITE(ICOUT,650)
27541 650      FORMAT('      NUMBER OR RESPONSE VARIABLES IS LESS THAN 1.')
27542          CALL DPWRST('XXX','BUG ')
27543          IERROR='YES'
27544          GOTO9000
27545        ELSEIF(IDIG5.EQ.2 .AND. IDIG4.GE.1)THEN
27546          WRITE(ICOUT,660)
27547 660      FORMAT('      NUMBER OF OBSERVATIONS IN INDEPENDENT ',
27548     1           'VARIABLES LESS THAN NUMBER OF')
27549          CALL DPWRST('XXX','BUG ')
27550          WRITE(ICOUT,662)
27551 662      FORMAT('      OBSERVATIONS IN DEDEPENDENT VARIABLE.')
27552          CALL DPWRST('XXX','BUG ')
27553          IERROR='YES'
27554          GOTO9000
27555        ELSEIF(IDIG5.EQ.2 .AND. IDIG2.GE.2)THEN
27556          WRITE(ICOUT,665)
27557 665      FORMAT('      BAD DIMENSION FOR LDWE, LD2WE, LDWD OR LD2WD.')
27558          CALL DPWRST('XXX','BUG ')
27559          IERROR='YES'
27560          GOTO9000
27561        ELSEIF(IDIG5.EQ.2 .AND. IDIG2.GE.1)THEN
27562          WRITE(ICOUT,670)
27563 670      FORMAT('      BAD DIMENSION FOR LDIFX, LDSCLD, OR LDRHO.')
27564          CALL DPWRST('XXX','BUG ')
27565          IERROR='YES'
27566          GOTO9000
27567        ELSEIF(IDIG5.EQ.3 .AND. IDIG4.GE.1)THEN
27568          WRITE(ICOUT,680)
27569 680      FORMAT('      STPB OR STPD INCORRECT.')
27570          CALL DPWRST('XXX','BUG ')
27571          IERROR='YES'
27572          GOTO9000
27573        ELSEIF(IDIG5.EQ.3 .AND. IDIG3.GE.1)THEN
27574          WRITE(ICOUT,690)
27575 690      FORMAT('      SCLB OR SCLD INCORRECT.')
27576          CALL DPWRST('XXX','BUG ')
27577          IERROR='YES'
27578          GOTO9000
27579        ELSEIF(IDIG5.EQ.3 .AND. IDIG2.GE.1)THEN
27580          WRITE(ICOUT,700)
27581 700      FORMAT('      WEIGHTS FOR RESPONSE VARIABLE INCORRECT.')
27582          CALL DPWRST('XXX','BUG ')
27583          IERROR='YES'
27584          GOTO9000
27585        ELSEIF(IDIG5.EQ.3 .AND. IDIG1.GE.1)THEN
27586          WRITE(ICOUT,710)
27587 710      FORMAT('      WEIGHTS FOR INDPENDENT VARIABLES INCORRECT.')
27588          CALL DPWRST('XXX','BUG ')
27589          IERROR='YES'
27590          GOTO9000
27591        ELSEIF(IDIG5.EQ.4)THEN
27592          WRITE(ICOUT,720)
27593 720      FORMAT('      ERROR IN DERIVATIVES.')
27594          CALL DPWRST('XXX','BUG ')
27595          IERROR='YES'
27596          GOTO9000
27597        ELSEIF(IDIG5.EQ.5)THEN
27598          WRITE(ICOUT,730)
27599 730      FORMAT('      LAST FUNCTION EVALUATION INCORRECT.')
27600          CALL DPWRST('XXX','BUG ')
27601          IERROR='YES'
27602          GOTO9000
27603        ELSEIF(IDIG5.EQ.6)THEN
27604          WRITE(ICOUT,740)
27605 740      FORMAT('      NUMERICAL ERROR ENCOUNTERED.')
27606          CALL DPWRST('XXX','BUG ')
27607          WRITE(ICOUT,742)
27608 742      FORMAT('      SOME POSSIBLE CAUSES:')
27609          CALL DPWRST('XXX','BUG ')
27610          WRITE(ICOUT,744)
27611 744      FORMAT('      1. USER INPUT POSSIBLY INCORRECT.')
27612          CALL DPWRST('XXX','BUG ')
27613          WRITE(ICOUT,746)
27614 746      FORMAT('      2. POOR CHOICE OF WEIGHTS OR SCALING.')
27615          CALL DPWRST('XXX','BUG ')
27616          IERROR='YES'
27617          GOTO9000
27618        ENDIF
27619      ENDIF
27620C
27621      CALL DWINF
27622     1    (N,M,NP,NQ,LDWE,LD2WE,ISODR,
27623     1     DELTAI, EPSI, XPLUSI, FNI, SDI, VCVI,
27624     1     RVARI, WSSI, WSSDEI, WSSEPI, RCONDI, ETAI,
27625     1     OLMAVI, TAUI, ALPHAI, ACTRSI, PNORMI, RNORSI, PRERSI,
27626     1     PARTLI, SSTOLI, TAUFCI, EPSMAI,
27627     1     BETA0I, BETACI, BETASI, BETANI, SI, SSI, SSFI, QRAUXI, UI,
27628     1     FSI, FJACBI, WE1I, DIFFI,
27629     1     DELTSI, DELTNI, TI, TTI, OMEGAI, FJACDI,
27630     1     WRK1I, WRK2I, WRK3I, WRK4I, WRK5I, WRK6I, WRK7I,
27631     1     LWKMN)
27632C
27633      CALL DIWINF
27634     1    (M,NP,NQ,
27635     1    MSGBI, MSGDI, IFIX2I, ISTOPI,
27636     1    NNZWI, NPPI, IDFI,
27637     1    JOBI, IPRINI, LUNERI, LUNRPI,
27638     1    NROWI, NTOLI, NETAI,
27639     1    MAXITI, NITERI, NFEVI, NJEVI, INT2I, IRANKI, LDTTI,
27640     1    LIWKMN)
27641C
27642C               ****************************************************
27643C               **  STEP 81--                                     **
27644C               **  WRITE INFO OUT TO FILES--                     **
27645C               **     1) DPST1F.DAT--COEF COEFSD                 **
27646C               **     2) DPST2F.DAT--PARAMETER COVARIANCE MATRIX **
27647C               **     3) DPST3F.DAT--PREDICTED X (X+DELTA)       **
27648C               **     4) DPST4F.DAT--ERROR IN X (DELTA)          **
27649C               ****************************************************
27650C
27651      ISTEPN='81'
27652      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'ORT2')
27653     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
27654C
27655      DO935L=1,NQ
27656        DO930I=1,N
27657          RES2(I+(L-1)*N)=REAL(WORK(EPSI-1+I+(L-1)*N))
27658          PRED2(I+(L-1)*N)=REAL(WORK(FNI-1+I+(L-1)*N))
27659  930   CONTINUE
27660  935 CONTINUE
27661C
27662      IFORMT='(20(E15.7,1X))'
27663      IF(IAUXDP.NE.7)THEN
27664        IFORMT=' '
27665        IF(IAUXDP.LE.9)THEN
27666          IFORMT='(20(Exx.x,1X))'
27667          ITOT=IAUXDP+8
27668          WRITE(IFORMT(6:7),'(I2)')ITOT
27669          WRITE(IFORMT(9:9),'(I1)')IAUXDP
27670        ELSE
27671          IFORMT='(20(Exx.xx,1X))'
27672          ITOT=IAUXDP+8
27673          WRITE(IFORMT(6:7),'(I2)')ITOT
27674          WRITE(IFORMT(9:10),'(I2)')IAUXDP
27675        ENDIF
27676      ENDIF
27677C
27678      DO940I=1,N
27679        WRITE(IOUNI3,IFORMT) (WORK(XPLUSI-1+I+(J-1)*N),J=1,M)
27680        WRITE(IOUNI4,IFORMT) (WORK(DELTAI-1+I+(J-1)*N),J=1,M)
27681  940 CONTINUE
27682C
27683      RESVAR=REAL(WORK(RVARI))
27684      RESSD=0.0
27685      IF(RESVAR.GT.0.0)RESSD=SQRT(RESVAR)
27686      RESDF=REAL(IWORK(IDFI))
27687      DO950I=1,NP
27688        DO955J=1,NP
27689          WORK(VCVI-1+I+(J-1)*N)=DBLE(RESVAR)*WORK(VCVI-1+I+(J-1)*NP)
27690  955   CONTINUE
27691        WRITE(IOUNI2,IFORMT)
27692     1       (REAL(WORK(VCVI-1+I+(J-1)*NP)),J=1,NP)
27693  950 CONTINUE
27694C
27695      IFORMT='(E15.7,1X,E15.7,10X,A4,A4)'
27696      IF(IAUXDP.NE.7)THEN
27697        IFORMT=' '
27698        IF(IAUXDP.LE.9)THEN
27699          IFORMT='(Exx.x,1X,Exx.x,10X,2A4)'
27700          ITOT=IAUXDP+8
27701          WRITE(IFORMT(3:4),'(I2)')ITOT
27702          WRITE(IFORMT(6:6),'(I1)')IAUXDP
27703          WRITE(IFORMT(12:13),'(I2)')ITOT
27704          WRITE(IFORMT(15:15),'(I1)')IAUXDP
27705        ELSE
27706          IFORMT='(Exx.xx,1X,Exx.xx,10X,2A4)'
27707          ITOT=IAUXDP+8
27708          WRITE(IFORMT(3:4),'(I2)')ITOT
27709          WRITE(IFORMT(6:7),'(I2)')IAUXDP
27710          WRITE(IFORMT(13:14),'(I2)')ITOT
27711          WRITE(IFORMT(16:17),'(I2)')IAUXDP
27712        ENDIF
27713      ENDIF
27714C
27715      DO8110I=1,NP
27716        PARAM3(I)=REAL(BETA(I))
27717        ASD=REAL(WORK(SDI-1+I))
27718        WRITE(IOUNI1,IFORMT)PARAM3(I),ASD,IPARN3(I),IPARN4(I)
27719C8111   FORMAT(E15.7,1X,E15.7,10X,A4,A4)
27720 8110 CONTINUE
27721C
27722      IF(IPRINT.EQ.'ON')THEN
27723        WRITE(ICOUT,8112)
27724 8112   FORMAT(6X,'COEF AND SD(COEF) WRITTEN TO FILE DPST1F.DAT')
27725        CALL DPWRST('XXX','BUG ')
27726        WRITE(ICOUT,8113)
27727 8113   FORMAT(6X,'PARAMETER VARIANCE-COVARIANCE MATRIX WRITTEN TO ',
27728     1         'FILE DPST2F.DAT')
27729        CALL DPWRST('XXX','BUG ')
27730        WRITE(ICOUT,8114)
27731 8114   FORMAT(6X,'PREDICTED INDEPENDENT VARIABLE ARRAY WRITTEN TO ',
27732     1        'FILE DPST3F.DAT')
27733        CALL DPWRST('XXX','BUG ')
27734        WRITE(ICOUT,8116)
27735 8116   FORMAT(6X,'ERROR IN INDPENDENT VARIABLE ARRAY WRITTEN TO ',
27736     1         'FILE DPST4F.DAT')
27737        CALL DPWRST('XXX','BUG ')
27738      ENDIF
27739C
27740C               **************************************
27741C               **  STEP 82--                       **
27742C               **  CLOSE       THE STORAGE FILES.  **
27743C               **************************************
27744C
27745      ISTEPN='82'
27746      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIT2')
27747     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
27748C
27749      IOP='CLOS'
27750      CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
27751     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
27752     1            IBUGA3,ISUBRO,IERROR)
27753      IF(IERROR.EQ.'YES')GOTO9000
27754C
27755C               *****************
27756C               **  STEP 90--  **
27757C               **  EXIT       **
27758C               *****************
27759C
27760 9000 CONTINUE
27761      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'ORT2')THEN
27762        WRITE(ICOUT,999)
27763        CALL DPWRST('XXX','BUG ')
27764        WRITE(ICOUT,9011)
27765 9011   FORMAT('***** AT THE END       OF DPORT2--')
27766        CALL DPWRST('XXX','BUG ')
27767        WRITE(ICOUT,9012)IERROR
27768 9012   FORMAT('IERROR = ',A4)
27769        CALL DPWRST('XXX','BUG ')
27770      ENDIF
27771C
27772      RETURN
27773      END
27774      SUBROUTINE DPOSM(ICASLE,IBUGA3,IBUGQ,IFOUND,IERROR)
27775C
27776C     PURPOSE--GENERATE ORDER STATISTIC MEDIANS FOR
27777C              UNIFORM DISTRIBUTION
27778C              NORMAL DISTRIBUTION
27779C              HALFNORMAL DISTRIBUTION
27780C              EV1 (GUMBEL) DISTRIBUTION
27781C              EV2 (FRECHET) DISTRIBUTION
27782C              WEIBULL DISTRIBUTION
27783C     WRITTEN BY--JAMES J. FILLIBEN
27784C                 STATISTICAL ENGINEERING DIVISION
27785C                 INFORMATION TECHNOLOGY LABORATORY
27786C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
27787C                 GAITHERSBURG, MD 20899-8980
27788C                 PHONE--301-975-2855
27789C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
27790C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
27791C     LANGUAGE--ANSI FORTRAN (1977)
27792C     VERSION NUMBER--91/11
27793C     ORIGINAL VERSION--OCTOBER 1991.
27794C     UPDATED         --MAY     1993. EV1, EV2, WEIBULL
27795C
27796C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
27797C
27798      CHARACTER*4 ICASLE
27799      CHARACTER*4 IBUGA3
27800      CHARACTER*4 IBUGQ
27801      CHARACTER*4 IFOUND
27802      CHARACTER*4 IERROR
27803C
27804      CHARACTER*4 NEWNAM
27805      CHARACTER*4 NEWCOL
27806      CHARACTER*4 ICASEQ
27807      CHARACTER*4 ILEFT
27808      CHARACTER*4 ILEFT2
27809C
27810CCCCC THE FOLLOWING 4 LINES WERE ADDED   MAY 1993
27811      CHARACTER*4 IHP
27812      CHARACTER*4 IHP2
27813      CHARACTER*4 IHWUSE
27814      CHARACTER*4 MESSAG
27815C
27816      CHARACTER*4 ISUBN1
27817      CHARACTER*4 ISUBN2
27818      CHARACTER*4 ISTEPN
27819C
27820C-----COMMON----------------------------------------------------------
27821C
27822      INCLUDE 'DPCOPA.INC'
27823      INCLUDE 'DPCOHK.INC'
27824      INCLUDE 'DPCODA.INC'
27825      INCLUDE 'DPCOP2.INC'
27826C
27827C-----START POINT-----------------------------------------------------
27828C
27829      ISUBN1='DPOS'
27830      ISUBN2='M   '
27831      IFOUND='NO'
27832      IERROR='NO'
27833C
27834      MAXCP1=MAXCOL+1
27835      MAXCP2=MAXCOL+2
27836      MAXCP3=MAXCOL+3
27837      MAXCP4=MAXCOL+4
27838      MAXCP5=MAXCOL+5
27839      MAXCP6=MAXCOL+6
27840      NS2=0
27841C
27842C               ***********************************************
27843C               **  TREAT THE ORDER STATISTIC MEDIANS CASE  **
27844C               **       1) FOR A FULL VARIABLE, OR          **
27845C               **       2) FOR PART OF A VARIABLE.          **
27846C               ***********************************************
27847C
27848      IF(IBUGA3.EQ.'ON')THEN
27849        WRITE(ICOUT,999)
27850  999   FORMAT(1X)
27851        CALL DPWRST('XXX','BUG ')
27852        WRITE(ICOUT,51)
27853   51   FORMAT('***** AT THE BEGINNING OF DPOSM--')
27854        CALL DPWRST('XXX','BUG ')
27855        WRITE(ICOUT,52)ICASLE,IBUGA3,IBUGQ
27856   52   FORMAT('ICASLE,IBUGA3,IBUGQ = ',A4,2X,A4,2X,A4)
27857        CALL DPWRST('XXX','BUG ')
27858      ENDIF
27859C
27860C               **********************************
27861C               **  STEP 1--                    **
27862C               **  INITIALIZE SOME VARIABLES.  **
27863C               **********************************
27864C
27865      ISTEPN='1'
27866      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
27867C
27868      NEWNAM='NO'
27869      NEWCOL='NO'
27870C
27871C               *******************************************************
27872C               **  STEP 2--                                         **
27873C               **  CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS.  **
27874C               *******************************************************
27875C
27876      ISTEPN='2'
27877      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
27878C
27879      MINNA=3
27880      MAXNA=100
27881      CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,
27882     1IERROR)
27883      IF(IERROR.EQ.'YES')GOTO9000
27884C
27885C               ****************************************************************
27886C               **  STEP 3--                                                   *
27887C               **  EXAMINE THE LEFT-HAND SIDE--                               *
27888C               **  IS THE PARAMETER OR VARIABLE NAME TO LEFT OF = SIGN        *
27889C               **  ALREADY IN THE NAME LIST?                                  *
27890C               **  NOTE THAT     ILEFT      IS THE NAME OF THE VARIABLE       *
27891C               **  ON THE LEFT.                                               *
27892C               **  NOTE THAT     ILISTL    IS THE LINE IN THE TABLE           *
27893C               **  OF THE NAME ON THE LEFT.                                   *
27894C               **  NOTE THAT     ICOLL    IS THE DATA COLUMN (1 TO 12)        *
27895C               **  FOR THE NAME OF THE LEFT.                                  *
27896C               ****************************************************************
27897C
27898      ISTEPN='3'
27899      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
27900C
27901      ILEFT=IHARG(1)
27902      ILEFT2=IHARG2(1)
27903      DO310I=1,NUMNAM
27904        I2=I
27905        IF(ILEFT.EQ.IHNAME(I).AND.ILEFT2.EQ.IHNAM2(I).AND.
27906     1     IUSE(I).EQ.'P')GOTO329
27907        IF(ILEFT.EQ.IHNAME(I).AND.ILEFT2.EQ.IHNAM2(I).AND.
27908     1     IUSE(I).EQ.'V')GOTO380
27909  310 CONTINUE
27910      NEWNAM='YES'
27911      ILISTL=NUMNAM+1
27912      IF(ILISTL.GT.MAXNAM)GOTO320
27913      GOTO330
27914C
27915  320 CONTINUE
27916      WRITE(ICOUT,999)
27917      CALL DPWRST('XXX','BUG ')
27918      WRITE(ICOUT,321)
27919  321 FORMAT('***** ERROR IN DPOSM--')
27920      CALL DPWRST('XXX','BUG ')
27921      WRITE(ICOUT,322)
27922  322 FORMAT('      THE NUMBER OF VARIABLE AND/OR PARAMETER')
27923      CALL DPWRST('XXX','BUG ')
27924      WRITE(ICOUT,323)MAXNAM
27925  323 FORMAT('      NAMES HAS JUST EXCEEDED THE MAX ALLOWABLE ',
27926     1I8,'  .')
27927      CALL DPWRST('XXX','BUG ')
27928      WRITE(ICOUT,324)
27929  324 FORMAT('      SUGGESTED ACTION--')
27930      CALL DPWRST('XXX','BUG ')
27931      WRITE(ICOUT,325)
27932  325 FORMAT('      ENTER      STAT')
27933      CALL DPWRST('XXX','BUG ')
27934      WRITE(ICOUT,326)
27935  326 FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES,')
27936      CALL DPWRST('XXX','BUG ')
27937      WRITE(ICOUT,327)
27938  327 FORMAT('      AND THEN REDEFINE (REUSE) SOME OF THE')
27939      CALL DPWRST('XXX','BUG ')
27940      WRITE(ICOUT,328)
27941  328 FORMAT('      ALREADY-USED NAMES')
27942      CALL DPWRST('XXX','BUG ')
27943      IERROR='YES'
27944      GOTO9000
27945C
27946  329 CONTINUE
27947      ILISTL=I2
27948      GOTO330
27949C
27950  330 CONTINUE
27951      NLEFT=0
27952      ICOLL=NUMCOL+1
27953      IF(ICOLL.GT.MAXCOL)GOTO340
27954      GOTO390
27955C
27956  340 CONTINUE
27957      WRITE(ICOUT,341)
27958  341 FORMAT('***** ERROR IN DPOSM--')
27959      CALL DPWRST('XXX','BUG ')
27960      WRITE(ICOUT,342)
27961  342 FORMAT('      THE NUMBER OF DATA COLUMNS')
27962      CALL DPWRST('XXX','BUG ')
27963      WRITE(ICOUT,343)MAXCOL
27964  343 FORMAT('      HAS JUST EXCEEDED THE MAX ALLOWABLE ',I8,'  .')
27965      CALL DPWRST('XXX','BUG ')
27966      WRITE(ICOUT,344)
27967  344 FORMAT('      SUGGESTED ACTION--')
27968      CALL DPWRST('XXX','BUG ')
27969      WRITE(ICOUT,345)
27970  345 FORMAT('      ENTER      STAT')
27971      CALL DPWRST('XXX','BUG ')
27972      WRITE(ICOUT,346)
27973  346 FORMAT('      TO FIND OUT THE FULL LIST OF USED COLUMNS')
27974      CALL DPWRST('XXX','BUG ')
27975      WRITE(ICOUT,347)
27976  347 FORMAT('      AND THEN OVERWRITE SOME COLUMNS.   EXAMPLE--')
27977      CALL DPWRST('XXX','BUG ')
27978      WRITE(ICOUT,348)
27979  348 FORMAT('      IF       LET X(I) = 3.14         FAILED')
27980      CALL DPWRST('XXX','BUG ')
27981      WRITE(ICOUT,349)
27982  349 FORMAT('      THEN ONE MIGHT ENTER     NAME X 7')
27983      CALL DPWRST('XXX','BUG ')
27984      WRITE(ICOUT,350)
27985  350 FORMAT('      (THEREBY EQUATING THE NAME X WITH COLUMN 7')
27986      CALL DPWRST('XXX','BUG ')
27987      WRITE(ICOUT,351)
27988  351 FORMAT('      FOLLOWED BY              LET X = 3.14')
27989      CALL DPWRST('XXX','BUG ')
27990      WRITE(ICOUT,352)
27991  352 FORMAT('      (WHICH WILL ACTUALLY OVERWRITE COLUMN 7')
27992      CALL DPWRST('XXX','BUG ')
27993      WRITE(ICOUT,353)
27994  353 FORMAT('      WITH THE NUMERIC CONSTANTS 3.14)')
27995      CALL DPWRST('XXX','BUG ')
27996      IERROR='YES'
27997      GOTO9000
27998C
27999  380 CONTINUE
28000      ILISTL=I2
28001      ICOLL=IVALUE(ILISTL)
28002      NLEFT=IN(ILISTL)
28003C
28004  390 CONTINUE
28005C
28006C               *****************************************
28007C               **  STEP 6--                           **
28008C               **  CHECK TO SEE THE TYPE SUBCASE      **
28009C               **  (BASED ON THE QUALIFIER)           **
28010C               **    1) UNQUALIFIED (THAT IS, FULL);  **
28011C               **    2) SUBSET/EXCEPT; OR             **
28012C               **    3) FOR.                          **
28013C               *****************************************
28014C
28015      ISTEPN='6'
28016      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28017C
28018      ICASEQ='FULL'
28019      ILOCQ=NUMARG+1
28020      IF(NUMARG.LT.1)GOTO670
28021      DO610J=1,NUMARG
28022      J1=J
28023      IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET  ')GOTO620
28024      IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT  ')GOTO620
28025      IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.'    ')GOTO630
28026  610 CONTINUE
28027      GOTO680
28028C
28029  620 CONTINUE
28030      ICASEQ='SUBS'
28031      ILOCQ=J1
28032      GOTO680
28033C
28034  630 CONTINUE
28035      ICASEQ='FOR'
28036      ILOCQ=J1
28037      GOTO680
28038C
28039  670 CONTINUE
28040      WRITE(ICOUT,999)
28041      CALL DPWRST('XXX','BUG ')
28042      WRITE(ICOUT,671)
28043  671 FORMAT('***** INTERNAL ERROR IN DPOSM')
28044      CALL DPWRST('XXX','BUG ')
28045      WRITE(ICOUT,672)
28046  672 FORMAT('      AT BRANCH POINT 5081--')
28047      CALL DPWRST('XXX','BUG ')
28048      WRITE(ICOUT,673)
28049  673 FORMAT('      NUMARG LESS THAN 1 EVEN THOUGH')
28050      CALL DPWRST('XXX','BUG ')
28051      WRITE(ICOUT,674)
28052  674 FORMAT('      NUMARG HAD PREVIOUSLY PASSED THIS TEST')
28053      CALL DPWRST('XXX','BUG ')
28054      WRITE(ICOUT,675)NUMARG
28055  675 FORMAT('      ONCE ALREADY.  VALUE OF NUMARG = ',I8)
28056      CALL DPWRST('XXX','BUG ')
28057      WRITE(ICOUT,676)
28058  676 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
28059      CALL DPWRST('XXX','BUG ')
28060      IF(IWIDTH.GE.1)WRITE(ICOUT,677)(IANS(I),I=1,IWIDTH)
28061  677 FORMAT(80A1)
28062      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
28063      IERROR='YES'
28064      GOTO9000
28065C
28066  680 CONTINUE
28067      IF(IBUGA3.EQ.'OFF')GOTO690
28068      WRITE(ICOUT,681)NUMARG,ILOCQ,ICASEQ
28069  681 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4)
28070      CALL DPWRST('XXX','BUG ')
28071C
28072  690 CONTINUE
28073C
28074C               ******************************************************
28075C               **  STEP 7--                                        **
28076C               **  BRANCH TO THE APPROPRIATE SUBCASE               **
28077C               **  (BASED ON THE QUALIFIER);                       **
28078C               **  DETERMINE THE NUMBER (= NOSM)                   **
28079C               **  OF ORDER STATISTIC MEDIANS TO BE GENERATED.
28080C               **  NOTE THAT THE VARIABLE NIISUB                   **
28081C               **  IS THE LENGTH OF THE RESULTING                  **
28082C               **  VARIABLE ISUB(.).                               **
28083C               **  NOTE THAT DPFOR AUTOMATICALLY EXTENDS           **
28084C               **  THE INPUT LENGTH OF ISUB(.) IF NECESSARY.       **
28085C               **  (HENCE THE REDEFINITION OF NIISUB TO NINEW      **
28086C               **  AFTER THE CALL TO DPFOR.                        **
28087C               ******************************************************
28088C
28089      ISTEPN='7'
28090      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28091C
28092      IF(ICASEQ.EQ.'FULL')GOTO710
28093      IF(ICASEQ.EQ.'SUBS')GOTO720
28094      IF(ICASEQ.EQ.'FOR')GOTO730
28095C
28096  710 CONTINUE
28097      IF(NEWNAM.EQ.'NO')NIISUB=NLEFT
28098      IF(NEWNAM.EQ.'YES')NIISUB=MAXN
28099      DO715I=1,NIISUB
28100      ISUB(I)=1
28101  715 CONTINUE
28102      NOSM=NIISUB
28103      GOTO750
28104C
28105  720 CONTINUE
28106      NIISUB=MAXN
28107      CALL DPSUBS(NIISUB,ILOCS,NS,IBUGQ,IERROR)
28108      NOSM=NS
28109      GOTO750
28110C
28111  730 CONTINUE
28112      IF(NEWNAM.EQ.'NO')NIISUB=NLEFT
28113      IF(NEWNAM.EQ.'YES')NIISUB=MAXN
28114      CALL DPFOR(NIISUB,NINEW,IROW1,IROWN,
28115     1NLOCAL,ILOCS,NS,IBUGQ,IERROR)
28116      NIISUB=NINEW
28117      NOSM=NS
28118      GOTO750
28119C
28120  750 CONTINUE
28121C
28122C               ******************************************
28123C               **  STEP 8--                            **
28124C               **  GENERATE    NOSM    ORDER           **
28125C               **  STATISTIC MEDIANS.                  **
28126C               **  STORE THEM TEMPORARILY IN           **
28127C               **  THE VECTOR Y(.).                    **
28128C               ******************************************
28129C
28130      ISTEPN='8'
28131      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28132C
28133      CALL UNIMED(NOSM,Y)
28134C
28135      IF(ICASLE.EQ.'UOSM')GOTO890
28136      IF(ICASLE.EQ.'NOSM')GOTO820
28137      IF(ICASLE.EQ.'HOSM')GOTO830
28138C
28139CCCCC THE FOLLOWING SECTION WAS ADDED   MAY 1993
28140      IF(ICASLE.EQ.'E1OM'.OR.ICASLE.EQ.'E2OM'.OR.ICASLE.EQ.'WOSM')THEN
28141         IHP='GAMM'
28142         IHP2='A   '
28143         IHWUSE='P'
28144         MESSAG='YES'
28145         CALL CHECKN(IHP,IHP2,IHWUSE,
28146     1   IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
28147     1   ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
28148         IF(IERROR.EQ.'YES')GOTO9000
28149         GAMMA=VALUE(ILOCP)
28150C
28151         IF(GAMMA.LE.0.0)THEN
28152           WRITE(ICOUT,999)
28153           CALL DPWRST('XXX','BUG ')
28154           WRITE(ICOUT,1511)
28155 1511      FORMAT('***** ERROR IN DPOSM--')
28156           CALL DPWRST('XXX','BUG ')
28157           WRITE(ICOUT,1512)
28158 1512      FORMAT('      THE SPECIFIED SHAPE PARAMETER GAMMA FOR THE ',
28159     1            'EV1/EV2/WEIBULL')
28160           CALL DPWRST('XXX','BUG ')
28161           WRITE(ICOUT,1513)
28162 1513      FORMAT('      DISTRIBUTIONS MUST BE STRICTLY LARGER THAN 0;')
28163           CALL DPWRST('XXX','BUG ')
28164           WRITE(ICOUT,1515)
28165 1515      FORMAT('      SUCH WAS NOT THE CASE HERE.')
28166           CALL DPWRST('XXX','BUG ')
28167           WRITE(ICOUT,1516)GAMMA
28168 1516      FORMAT('      THE SPECIFIED VALUE OF GAMMA = ',G15.7)
28169           CALL DPWRST('XXX','BUG ')
28170           IERROR='YES'
28171           GOTO9000
28172        ENDIF
28173      ENDIF
28174C
28175CCCCC THE FOLLOWING 3 LINES WERE ADDED    MAY 1993
28176      IF(ICASLE.EQ.'E1OM')GOTO840
28177      IF(ICASLE.EQ.'E2OM')GOTO850
28178      IF(ICASLE.EQ.'WOSM')GOTO860
28179C
28180  820 CONTINUE
28181      DO821I=1,NOSM
28182      CALL NORPPF(Y(I),Y(I))
28183  821 CONTINUE
28184      GOTO890
28185C
28186  830 CONTINUE
28187      DO831I=1,NOSM
28188      CALL HFNPPF(Y(I),Y(I))
28189  831 CONTINUE
28190      GOTO890
28191C
28192  840 CONTINUE
28193      DO841I=1,NOSM
28194      CALL EV1PPF(Y(I),MINMAX,Y(I))
28195  841 CONTINUE
28196      GOTO890
28197C
28198  850 CONTINUE
28199      DO851I=1,NOSM
28200      CALL EV2PPF(Y(I),GAMMA,MINMAX,Y(I))
28201  851 CONTINUE
28202      GOTO890
28203C
28204  860 CONTINUE
28205      DO861I=1,NOSM
28206      CALL WEIPPF(Y(I),GAMMA,MINMAX,Y(I))
28207  861 CONTINUE
28208      GOTO890
28209C
28210  890 CONTINUE
28211C
28212C               ***********************************************************
28213C               **  STEP 8--                                             **
28214C               **  IF CALLED FOR (THAT IS, IF IBUGA3 IS ON),      **
28215C               **  PRINT OUT THE INTERMEDIATE VARIABLE Y(.).            **
28216C               **  THIS IS USEFUL FOR DIAGNOSTIC PURPOSES               **
28217C               **  IN REVIEWING THE OUTPUT FROM THIS SUBROUTINE.        **
28218C               ***********************************************************
28219C
28220      ISTEPN='9'
28221      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28222C
28223      IF(IBUGA3.EQ.'ON')THEN
28224        WRITE(ICOUT,2051)NOSM
28225 2051   FORMAT('IN DPOSM AFTER UNIMED HAS BEEN CALLED--NOSM = ',I8)
28226        CALL DPWRST('XXX','BUG ')
28227        IF(NOSM.GT.0)THEN
28228          DO2054I=1,NOSM
28229            WRITE(ICOUT,2055)I,Y(I)
28230 2055       FORMAT('I,Y(I) = ',I8,F12.5)
28231            CALL DPWRST('XXX','BUG ')
28232 2054     CONTINUE
28233        ENDIF
28234      ENDIF
28235C
28236C               ******************************************************
28237C               **  STEP 9--                                        **
28238C               **  COPY THE ORDER STATISTIC MEDIANS                **
28239C               **  FROM THE INTERMEDIATE VECTOR Y(.)               **
28240C               **  TO THE APPROPRIATE COLUMN                       **
28241C               **  (BASED ON THE QUALIFIER--FULL, SUBSET, OR FOR)  **
28242C               **  IN THE INTERNAL DATAPLOT DATA TABLE.            **
28243C               ******************************************************
28244C
28245      ISTEPN='10'
28246      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28247C
28248      NS2=0
28249      DO2100I=1,NIISUB
28250      IJ=MAXN*(ICOLL-1)+I
28251      IF(ISUB(I).EQ.0)GOTO2100
28252      NS2=NS2+1
28253      IF(ICOLL.LE.MAXCOL)V(IJ)=Y(NS2)
28254      IF(ICOLL.EQ.MAXCP1)PRED(I)=Y(NS2)
28255      IF(ICOLL.EQ.MAXCP2)RES(I)=Y(NS2)
28256      IF(ICOLL.EQ.MAXCP3)YPLOT(I)=Y(NS2)
28257      IF(ICOLL.EQ.MAXCP4)XPLOT(I)=Y(NS2)
28258      IF(ICOLL.EQ.MAXCP5)X2PLOT(I)=Y(NS2)
28259      IF(ICOLL.EQ.MAXCP6)TAGPLO(I)=Y(NS2)
28260      IF(NS2.EQ.1)IROW1=I
28261      IROWN=I
28262 2100 CONTINUE
28263C
28264C               *******************************************
28265C               **  STEP 10--                            **
28266C               **  CARRY OUT THE LIST UPDATING AND      **
28267C               **  GENERATE THE INFORMATIVE PRINTING.   **
28268C               *******************************************
28269C
28270      ISTEPN='11'
28271      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28272C
28273      IF(ICASEQ.EQ.'FULL'.AND.NEWNAM.EQ.'NO')NINEW=NLEFT
28274      IF(ICASEQ.EQ.'FULL'.AND.NEWNAM.EQ.'YES')NINEW=MAXN
28275      IF(ICASEQ.EQ.'SUBS'.AND.NEWNAM.EQ.'NO'.AND.
28276     1NLEFT.GE.IROWN)NINEW=NLEFT
28277      IF(ICASEQ.EQ.'SUBS'.AND.NEWNAM.EQ.'NO'.AND.
28278     1NLEFT.LT.IROWN)NINEW=IROWN
28279      IF(ICASEQ.EQ.'SUBS'.AND.NEWNAM.EQ.'YES')NINEW=IROWN
28280      IF(ICASEQ.EQ.'FOR'.AND.NEWNAM.EQ.'NO'.AND.
28281     1NLEFT.GE.IROWN)NINEW=NLEFT
28282      IF(ICASEQ.EQ.'FOR'.AND.NEWNAM.EQ.'NO'.AND.
28283     1NLEFT.LT.IROWN)NINEW=IROWN
28284      IF(ICASEQ.EQ.'FOR'.AND.NEWNAM.EQ.'YES')NINEW=IROWN
28285C
28286      IHNAME(ILISTL)=ILEFT
28287      IHNAM2(ILISTL)=ILEFT2
28288      IUSE(ILISTL)='V'
28289      IVALUE(ILISTL)=ICOLL
28290      VALUE(ILISTL)=ICOLL
28291      IN(ILISTL)=NINEW
28292C
28293CCCCC IUSE(ICOLL)='V'
28294CCCCC IVALUE(ICOLL)=ICOLL
28295CCCCC VALUE(ICOLL)=ICOLL
28296CCCCC IN(ICOLL)=NINEW
28297C
28298      IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1
28299      IF(NEWNAM.EQ.'YES')NUMCOL=NUMCOL+1
28300C
28301      DO4100J4=1,NUMNAM
28302      IF(IUSE(J4).EQ.'V'.AND.IVALUE(J4).EQ.ICOLL)GOTO4105
28303      GOTO4100
28304 4105 CONTINUE
28305      IUSE(J4)='V'
28306      IVALUE(J4)=ICOLL
28307      VALUE(J4)=ICOLL
28308      IN(J4)=NINEW
28309 4100 CONTINUE
28310C
28311      IF(IPRINT.EQ.'OFF')GOTO4059
28312      IF(IFEEDB.EQ.'OFF')GOTO4059
28313      WRITE(ICOUT,999)
28314      CALL DPWRST('XXX','BUG ')
28315      WRITE(ICOUT,4011)ILEFT,ILEFT2,NS2
28316 4011 FORMAT('THE NUMBER OF VALUES GENERATED FOR ',
28317     1'THE VARIABLE ',A4,A4,' = ',I8)
28318      CALL DPWRST('XXX','BUG ')
28319      WRITE(ICOUT,999)
28320      CALL DPWRST('XXX','BUG ')
28321      IJ=MAXN*(ICOLL-1)+IROW1
28322      IF(ICOLL.LE.MAXCOL)WRITE(ICOUT,4021)ILEFT,ILEFT2,V(IJ),
28323     1IROW1
28324      IF(ICOLL.LE.MAXCOL)CALL DPWRST('XXX','BUG ')
28325      IF(ICOLL.EQ.MAXCP1)WRITE(ICOUT,4021)ILEFT,ILEFT2,PRED(IROW1),
28326     1IROW1
28327      IF(ICOLL.EQ.MAXCP1)CALL DPWRST('XXX','BUG ')
28328      IF(ICOLL.EQ.MAXCP2)WRITE(ICOUT,4021)ILEFT,ILEFT2,RES(IROW1),
28329     1IROW1
28330      IF(ICOLL.EQ.MAXCP2)CALL DPWRST('XXX','BUG ')
28331      IF(ICOLL.EQ.MAXCP3)WRITE(ICOUT,4021)ILEFT,ILEFT2,YPLOT(IROW1),
28332     1IROW1
28333      IF(ICOLL.EQ.MAXCP3)CALL DPWRST('XXX','BUG ')
28334      IF(ICOLL.EQ.MAXCP4)WRITE(ICOUT,4021)ILEFT,ILEFT2,XPLOT(IROW1),
28335     1IROW1
28336      IF(ICOLL.EQ.MAXCP4)CALL DPWRST('XXX','BUG ')
28337      IF(ICOLL.EQ.MAXCP5)WRITE(ICOUT,4021)ILEFT,ILEFT2,X2PLOT(IROW1),
28338     1IROW1
28339      IF(ICOLL.EQ.MAXCP5)CALL DPWRST('XXX','BUG ')
28340      IF(ICOLL.EQ.MAXCP6)WRITE(ICOUT,4021)ILEFT,ILEFT2,TAGPLO(IROW1),
28341     1IROW1
28342 4021 FORMAT('THE FIRST           COMPUTED VALUE OF ',A4,A4,
28343     1' = ',E15.7,'   (ROW ',I6,')')
28344      IF(ICOLL.EQ.MAXCP6)CALL DPWRST('XXX','BUG ')
28345C
28346      IJ=MAXN*(ICOLL-1)+IROWN
28347      IF(ICOLL.LE.MAXCOL.AND.
28348     1NS2.NE.1)WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,V(IJ),IROWN
28349 4031 FORMAT('THE LAST (',I5,'-TH) COMPUTED VALUE OF ',A4,A4,
28350     1' = ',E15.7,'   (ROW ',I6,')')
28351      IF(ICOLL.LE.MAXCOL.AND.
28352     1NS2.NE.1)CALL DPWRST('XXX','BUG ')
28353      IF(ICOLL.EQ.MAXCP1.AND.
28354     1NS2.NE.1)WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,PRED(IROWN),IROWN
28355      IF(ICOLL.EQ.MAXCP1.AND.
28356     1NS2.NE.1)CALL DPWRST('XXX','BUG ')
28357      IF(ICOLL.EQ.MAXCP2.AND.
28358     1NS2.NE.1)WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,RES(IROWN),IROWN
28359      IF(ICOLL.EQ.MAXCP2.AND.
28360     1NS2.NE.1)CALL DPWRST('XXX','BUG ')
28361      IF(ICOLL.EQ.MAXCP3.AND.
28362     1NS2.NE.1)WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,YPLOT(IROWN),IROWN
28363      IF(ICOLL.EQ.MAXCP3.AND.
28364     1NS2.NE.1)CALL DPWRST('XXX','BUG ')
28365      IF(ICOLL.EQ.MAXCP4.AND.
28366     1NS2.NE.1)WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,XPLOT(IROWN),IROWN
28367      IF(ICOLL.EQ.MAXCP4.AND.
28368     1NS2.NE.1)CALL DPWRST('XXX','BUG ')
28369      IF(ICOLL.EQ.MAXCP5.AND.
28370     1NS2.NE.1)WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,X2PLOT(IROWN),IROWN
28371      IF(ICOLL.EQ.MAXCP5.AND.
28372     1NS2.NE.1)CALL DPWRST('XXX','BUG ')
28373      IF(ICOLL.EQ.MAXCP6.AND.
28374     1NS2.NE.1)WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,TAGPLO(IROWN),IROWN
28375      IF(ICOLL.EQ.MAXCP6.AND.
28376     1NS2.NE.1)CALL DPWRST('XXX','BUG ')
28377      IF(NS2.NE.1)GOTO4090
28378      WRITE(ICOUT,4041)
28379 4041 FORMAT('SINCE THE GENERATED SAMPLE SIZE WAS ONLY 1,')
28380      CALL DPWRST('XXX','BUG ')
28381      WRITE(ICOUT,4042)
28382 4042 FORMAT('THE ABOVE VALUE WAS THE SOLE VALUE COMPUTED.')
28383      CALL DPWRST('XXX','BUG ')
28384 4090 CONTINUE
28385      WRITE(ICOUT,999)
28386      CALL DPWRST('XXX','BUG ')
28387      WRITE(ICOUT,4112)ILEFT,ILEFT2,ICOLL
28388 4112 FORMAT('THE CURRENT COLUMN FOR ',
28389     1'THE VARIABLE ',A4,A4,' = ',I8)
28390      CALL DPWRST('XXX','BUG ')
28391      WRITE(ICOUT,4113)ILEFT,ILEFT2,NINEW
28392 4113 FORMAT('THE CURRENT LENGTH OF  ',
28393     1'THE VARIABLE ',A4,A4,' = ',I8)
28394      CALL DPWRST('XXX','BUG ')
28395      WRITE(ICOUT,999)
28396      CALL DPWRST('XXX','BUG ')
28397      WRITE(ICOUT,999)
28398      CALL DPWRST('XXX','BUG ')
28399 4059 CONTINUE
28400C
28401C               *****************
28402C               **  STEP 90--  **
28403C               **  EXIT       **
28404C               *****************
28405C
28406 9000 CONTINUE
28407      IF(IBUGA3.EQ.'ON')THEN
28408        WRITE(ICOUT,999)
28409        CALL DPWRST('XXX','BUG ')
28410        WRITE(ICOUT,9011)
28411 9011   FORMAT('***** AT THE END       OF DPOSM--')
28412        CALL DPWRST('XXX','BUG ')
28413        WRITE(ICOUT,9012)IFOUND,IERROR
28414 9012   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
28415        CALL DPWRST('XXX','BUG ')
28416        WRITE(ICOUT,9013)ICASLE,IBUGA3,IBUGQ
28417 9013   FORMAT('ICASLE,IBUGA3,IBUGQ = ',2(A4,2X),A4)
28418        CALL DPWRST('XXX','BUG ')
28419        WRITE(ICOUT,9016)NS2,NS,NIISUB,NOSM
28420 9016   FORMAT('NS2,NS,NIISUB,NOSM = ',4I8)
28421        CALL DPWRST('XXX','BUG ')
28422      ENDIF
28423C
28424      RETURN
28425      END
28426      SUBROUTINE DPOUTP(ICAPSW,IBUGO2,ISUBRO,IFOUND,IERROR)
28427C
28428C     PURPOSE--THE COMMAND
28429C
28430C                 OUTPUT <NAME>
28431C
28432C              WILL GENERATE THE FOLLOWING COMMANDS:
28433C
28434C                 DEVICE 2 CLOSE
28435C                 SET IPL1NA <NAME>.PS
28436C                 DEVICE 2 POSTSCRIPT
28437C
28438C     WRITTEN BY--ALAN HECKERT
28439C                 STATISTICAL ENGINEERING DIVISION
28440C                 INFORMATION TECHNOLOGY LABORATORY
28441C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
28442C                 GAITHERSBURG, MD 20899
28443C                 PHONE--301-975-2899
28444C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
28445C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
28446C     LANGUAGE--ANSI FORTRAN (1977)
28447C     VERSION NUMBER--2020/04
28448C     ORIGINAL VERSION--APRIL     2020.
28449C
28450C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
28451C
28452      CHARACTER*4 ICAPSW
28453      CHARACTER*4 IBUGO2
28454      CHARACTER*4 ISUBRO
28455      CHARACTER*4 IFOUND
28456      CHARACTER*4 IERROR
28457C
28458      INCLUDE 'DPCOPA.INC'
28459C
28460      CHARACTER (LEN=MAXFNC) :: IFILE
28461      CHARACTER (LEN=MAXSTR) :: ICANS
28462      CHARACTER*4 IANSDC(14)
28463      CHARACTER*4 IANSDO(18)
28464      CHARACTER*4 ISTEPN
28465      CHARACTER*4 ISUBN1
28466      CHARACTER*4 ISUBN2
28467CCCCC CHARACTER*4 IOP
28468C
28469C-----COMMON----------------------------------------------------------
28470C
28471      INCLUDE 'DPCOHK.INC'
28472      INCLUDE 'DPCODA.INC'
28473      INCLUDE 'DPCOPC.INC'
28474      INCLUDE 'DPCOF2.INC'
28475      INCLUDE 'DPCOP2.INC'
28476C
28477C-----DATA STATEMENTS-------------------------------------------------
28478C
28479      DATA (IANSDC(I),I=1,14)
28480     1/'D   ','E   ','V   ','I   ','C   ','E   ','    ','2   ',
28481     1 '    ','C   ','L   ','O   ','S   ', 'E   '/
28482      DATA (IANSDO(I),I=1,18)
28483     1/'D   ','E   ','V   ','I   ','C   ','E   ','    ','2   ',
28484     1 '    ','P   ','O   ','S   ','T   ','S   ','R   ','I   ',
28485     1 'P   ','T   '/
28486C
28487C-----START POINT-----------------------------------------------------
28488C
28489      IFOUND='YES'
28490      IERROR='NO'
28491      ISUBN1='DPOU'
28492      ISUBN2='TP  '
28493C
28494      NCDC=14
28495      NCDO=18
28496C
28497C               ******************************************
28498C               **  TREAT THE OUTPUT <NAME>       CASE  **
28499C               ******************************************
28500C
28501      IF(IBUGO2.EQ.'ON' .OR. ISUBRO.EQ.'OUTP')THEN
28502        WRITE(ICOUT,999)
28503  999   FORMAT(1X)
28504        CALL DPWRST('XXX','BUG ')
28505        WRITE(ICOUT,51)
28506   51   FORMAT('***** AT THE BEGINNING OF DPOUTP--')
28507        CALL DPWRST('XXX','BUG ')
28508        WRITE(ICOUT,53)IBUGO2,ISUBRO,NUMARG
28509   53   FORMAT('IBUGO2,ISUBRO,NUMARG = ',2(A4,2X),I8)
28510        CALL DPWRST('XXX','BUG ')
28511        IF(NUMARG.GE.1)THEN
28512          DO61I=1,NUMARG
28513            WRITE(ICOUT,62)I,IHARG(I),IARGT(I)
28514   62       FORMAT('I,IHARG(I),IARGT(I) = ',I8,2(2X,A4))
28515            CALL DPWRST('XXX','BUG ')
28516   61     CONTINUE
28517        ENDIF
28518        DO65I=1,IWIDTH
28519          WRITE(ICOUT,67)I,IANSLC(I)
28520   67     FORMAT('I,IANSLC(I) = ',I5,2X,A4)
28521          CALL DPWRST('XXX','BUG ')
28522   65   CONTINUE
28523      ENDIF
28524C
28525C               **************************************************
28526C               **  STEP 1--                                    **
28527C               **  EXTRACT THE FILE NAME                       **
28528C               **************************************************
28529C
28530      ISTEPN='1'
28531      IF(IBUGO2.EQ.'ON'.OR.ISUBRO.EQ.'OUTP')
28532     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28533C
28534      IF(NUMARG.LT.1)THEN
28535        WRITE(ICOUT,999)
28536        CALL DPWRST('XXX','BUG ')
28537        WRITE(ICOUT,1011)
28538 1011   FORMAT('***** ERROR IN OUTPUT (DPOUTP) COMMAND--')
28539        CALL DPWRST('XXX','BUG ')
28540        WRITE(ICOUT,1021)
28541 1021   FORMAT('      NO FILE NAME GIVEN ON THE COMMAND.')
28542        CALL DPWRST('XXX','BUG ')
28543        IF(IWIDTH.GE.1)THEN
28544          WRITE(ICOUT,1029)(IANSLC(I),I=1,MIN(100,IWIDTH))
28545 1029     FORMAT('      ',100A1)
28546          CALL DPWRST('XXX','BUG ')
28547        ELSE
28548          WRITE(ICOUT,999)
28549          CALL DPWRST('XXX','BUG ')
28550        ENDIF
28551        IERROR='YES'
28552        GOTO9000
28553      ENDIF
28554C
28555      ICANS=' '
28556      DO1031I=1,IWIDTH
28557        ICANS(I:I)=IANSLC(I)(1:1)
28558 1031 CONTINUE
28559C
28560      ISTART=1
28561      ISTOP=IWIDTH
28562      IWORD=2
28563      CALL DPEXWO(ICANS,ISTART,ISTOP,IWORD,
28564     1            ICOL1,ICOL2,IFILE,NCFILE,
28565     1            IBUGO2,ISUBRO,IERROR)
28566C
28567      IF(IBUGO2.EQ.'ON' .OR. ISUBRO.EQ.'OUTP')THEN
28568        WRITE(ICOUT,1046)NCFILE,IFILE(1:80)
28569 1046   FORMAT('AFTER DPEXWO: NCFILE,IFILE(1:80) = ',I5,2X,A80)
28570        CALL DPWRST('XXX','BUG ')
28571        WRITE(ICOUT,53)IBUGO2,ISUBRO,NUMARG
28572      ENDIF
28573C
28574      IF(NCFILE.LT.1)THEN
28575        WRITE(ICOUT,999)
28576        CALL DPWRST('XXX','BUG ')
28577        WRITE(ICOUT,1011)
28578        CALL DPWRST('XXX','BUG ')
28579        WRITE(ICOUT,1052)
28580 1052   FORMAT('      A USER FILE NAME IS REQUIRED IN THE OUTPUT ',
28581     1         'COMMAND')
28582        CALL DPWRST('XXX','BUG ')
28583        WRITE(ICOUT,1054)
28584 1054   FORMAT('      (FOR EXAMPLE,    OUTPUT   DATAPLOT_OUTPUT)')
28585        CALL DPWRST('XXX','BUG ')
28586        WRITE(ICOUT,1055)
28587 1055   FORMAT('      BUT NONE WAS GIVEN HERE.')
28588        CALL DPWRST('XXX','BUG ')
28589        WRITE(ICOUT,1056)
28590 1056   FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
28591        CALL DPWRST('XXX','BUG ')
28592        IF(IWIDTH.GE.1)THEN
28593          WRITE(ICOUT,1029)(IANSLC(I),I=1,MIN(100,IWIDTH))
28594          CALL DPWRST('XXX','BUG ')
28595        ELSE
28596          WRITE(ICOUT,999)
28597          CALL DPWRST('XXX','BUG ')
28598        ENDIF
28599        IERROR='YES'
28600        GOTO9000
28601      ENDIF
28602C
28603C     STRIP OFF LEADING/TRAILING QUOTES
28604C
28605      IF(IFILE(1:1).EQ.'"' .AND. IFILE(NCFILE:NCFILE).EQ.'"')THEN
28606        IFILE(1:NCFILE-2)=IFILE(2:NCFILE-1)
28607        NCFILE=NCFILE-2
28608      ENDIF
28609C
28610C     ADD ".ps" TO FILE NAME
28611C
28612      IF(NCFILE.GE.3)THEN
28613        IF(IFILE(NCFILE-2:NCFILE).NE.'.PS' .AND.
28614     1     IFILE(NCFILE-2:NCFILE).NE.'.ps')THEN
28615#ifdef LINUX
28616          IFILE(NCFILE+1:NCFILE+3)='.ps'
28617          NCFILE=NCFILE+3
28618#else
28619          IFILE(NCFILE+1:NCFILE+3)='.PS'
28620          NCFILE=NCFILE+3
28621#endif
28622        ENDIF
28623      ELSE
28624#ifdef LINUX
28625        IFILE(NCFILE+1:NCFILE+3)='.ps'
28626        NCFILE=NCFILE+3
28627#else
28628        IFILE(NCFILE+1:NCFILE+3)='.PS'
28629        NCFILE=NCFILE+3
28630#endif
28631      ENDIF
28632C
28633      IF(IBUGO2.EQ.'ON' .OR. ISUBRO.EQ.'OUTP')THEN
28634        WRITE(ICOUT,1091)NCFILE,IFILE(1:80)
28635 1091   FORMAT('NCFILE,IFILE(1:80) = ',I5,2X,A80)
28636        CALL DPWRST('XXX','BUG ')
28637        WRITE(ICOUT,53)IBUGO2,ISUBRO,NUMARG
28638      ENDIF
28639C
28640C               **************************************************
28641C               **   STEP 21--                                  **
28642C               **   GENERATE THE DEVICE 2 CLOSE COMMAND        **
28643C               **************************************************
28644C
28645      ISTEPN='21'
28646      IF(IBUGO2.EQ.'ON'.OR.ISUBRO.EQ.'OUTP')
28647     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28648C
28649      IWIDTH=NCDC
28650      DO2110II=1,NCDC
28651        IANS(II)=IANSDC(II)
28652 2110 CONTINUE
28653C
28654      IF(IDPOWE(2).EQ.'ON')THEN
28655        ICOM='DEVI'
28656        ICOM2='CE  '
28657        IHARG(1)='2   '
28658        IHARG2(1)='    '
28659        IARGT(1)='NUMB'
28660        IARG(1)=2
28661        ARG(1)=2.0
28662        IHARG(2)='CLOS'
28663        IHARG2(2)='E   '
28664        IARGT(2)='WORD'
28665        NUMARG=2
28666        CALL DPDEMN(IHARG,IHARG2,IARGT,IARG,NUMARG,
28667     1              IPL1NU,IPL1NA,
28668     1              IPL2NU,IPL2NA,
28669     1              IPL1CS,IPL2CS,
28670     1              IDEFMA,IDEFMO,IDEFM2,IDEFM3,
28671     1              IDEFPO,IDEFCN,IDEFDC,IDEFVP,IDEFHP,IDEFUN,
28672     1              NUMDEV,MAXDEV,
28673     1              IDMANU,IDMODE,IDMOD2,IDMOD3,
28674     1              IDPOWE,IDCONT,IDCOLO,IDFONT,IDNVPP,IDNHPP,IDUNIT,
28675     1              IDNVOF,IDNHOF,
28676     1              ICAPSW,ICAPNU,
28677     1              IANS,IWIDTH,IBUGO2,ISUBRO,IFOUND,IERROR)
28678        IF(IERROR.EQ.'YES')GOTO9000
28679      ENDIF
28680C
28681C               **************************************************
28682C               **   STEP 22--                                  **
28683C               **   SET THE DEVICE 2 FILE NAME                 **
28684C               **************************************************
28685C
28686      ISTEPN='22'
28687      IF(IBUGO2.EQ.'ON'.OR.ISUBRO.EQ.'OUTP')
28688     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28689C
28690      IPL1NA=' '
28691      IPL1NA(1:NCFILE)=IFILE(1:NCFILE)
28692C
28693      IF(IBUGO2.EQ.'ON' .OR. ISUBRO.EQ.'OUTP')THEN
28694        WRITE(ICOUT,2291)IPL1NA(1:80)
28695 2291   FORMAT('IPL1NA(1:80) = ',A80)
28696        CALL DPWRST('XXX','BUG ')
28697      ENDIF
28698C
28699C               **************************************************
28700C               **   STEP 23--                                  **
28701C               **   GENERATE THE DEVICE 2 OPEN  COMMAND        **
28702C               **************************************************
28703C
28704      ISTEPN='23'
28705      IF(IBUGO2.EQ.'ON'.OR.ISUBRO.EQ.'OUTP')
28706     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28707C
28708      IWIDTH=NCDO
28709      DO2310II=1,NCDO
28710        IANS(II)=IANSDO(II)
28711 2310 CONTINUE
28712C
28713      ICOM='DEVI'
28714      ICOM2='CE  '
28715      IHARG(1)='2   '
28716      IHARG2(1)='    '
28717      IARGT(1)='NUMB'
28718      IARG(1)=2
28719      ARG(1)=2.0
28720      IHARG(2)='POST'
28721      IHARG2(2)='SCRI'
28722      IARGT(2)='WORD'
28723      NUMARG=2
28724      CALL DPDEMN(IHARG,IHARG2,IARGT,IARG,NUMARG,
28725     1            IPL1NU,IPL1NA,
28726     1            IPL2NU,IPL2NA,
28727     1            IPL1CS,IPL2CS,
28728     1            IDEFMA,IDEFMO,IDEFM2,IDEFM3,
28729     1            IDEFPO,IDEFCN,IDEFDC,IDEFVP,IDEFHP,IDEFUN,
28730     1            NUMDEV,MAXDEV,
28731     1            IDMANU,IDMODE,IDMOD2,IDMOD3,
28732     1            IDPOWE,IDCONT,IDCOLO,IDFONT,IDNVPP,IDNHPP,IDUNIT,
28733     1            IDNVOF,IDNHOF,
28734     1            ICAPSW,ICAPNU,
28735     1            IANS,IWIDTH,IBUGO2,ISUBRO,IFOUND,IERROR)
28736      IF(IERROR.EQ.'YES')GOTO9000
28737C
28738C               *****************
28739C               **  STEP 90--  **
28740C               **  EXIT       **
28741C               *****************
28742C
28743 9000 CONTINUE
28744      IFOUND='YES'
28745      IF(IBUGO2.EQ.'ON' .OR. ISUBRO.EQ.'OUTP')THEN
28746        WRITE(ICOUT,999)
28747        CALL DPWRST('XXX','BUG ')
28748        WRITE(ICOUT,9011)
28749 9011   FORMAT('***** AT THE END       OF DPOUTP--')
28750        CALL DPWRST('XXX','BUG ')
28751        WRITE(ICOUT,9012)IFOUND,IERROR
28752 9012   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
28753        CALL DPWRST('XXX','BUG ')
28754        WRITE(ICOUT,9014)IPL1NA(1:80)
28755 9014   FORMAT('IPL1NA(1:80) = ',A80)
28756        CALL DPWRST('XXX','BUG ')
28757      ENDIF
28758C
28759      RETURN
28760      END
28761      SUBROUTINE DPOVA2(X1,Y1,X2,Y2,X3,Y3,PX,PY,
28762     1                  IFIG,ILINPA,ILINCO,PLINTH,
28763     1                  AREGBA,IREBLI,IREBCO,PREBTH,
28764     1                  IREFSW,IREFCO,
28765     1                  IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
28766     1                  PTEXHE,PTEXWI,PTEXVG,PTEXHG)
28767C
28768C     PURPOSE--DRAW A OVAL WITH ONE END OF THE MAJOR AXIS AT (X1,Y1)
28769C              WITH ONE END OF THE MINOR AXIS AT (X2,Y2)
28770C              AND THE OTHER END OF MAJOR AXIS AT (X3,Y3).
28771C     WRITTEN BY--JAMES J. FILLIBEN
28772C                 STATISTICAL ENGINEERING DIVISION
28773C                 INFORMATION TECHNOLOGY LABORATORY
28774C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
28775C                 GAITHERSBURG, MD 20899-8980
28776C                 PHONE--301-975-2855
28777C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
28778C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
28779C     LANGUAGE--ANSI FORTRAN (1977)
28780C     VERSION NUMBER--82/7
28781C     ORIGINAL VERSION--APRIL     1981.
28782C     UPDATED         --MAY       1982.
28783C     UPDATED         --JANUARY   1989.  MODIFY CALLS TO DPDRPL (ALAN)
28784C     UPDATED         --JANUARY   1989.  MODIFY CALL  TO DPFIRE (ALAN)
28785C     UPDATED         --JULY      2019. CREATE SCRATCH STORAGE IN DPOVAL
28786C                                       RATHER THAN DPOVA2
28787C
28788C-----NON-COMMON VARIABLES-------------------------------------
28789C
28790      DIMENSION PX(*)
28791      DIMENSION PY(*)
28792C
28793      CHARACTER*4 IFIG
28794      CHARACTER*4 IPATT2
28795C
28796      CHARACTER*4 ILINPA
28797      CHARACTER*4 ILINCO
28798C
28799      CHARACTER*4 IREBLI
28800      CHARACTER*4 IREBCO
28801      CHARACTER*4 IREFSW
28802      CHARACTER*4 IREFCO
28803      CHARACTER*4 IREPTY
28804      CHARACTER*4 IREPLI
28805      CHARACTER*4 IREPCO
28806C
28807      CHARACTER*4 IPATT
28808      CHARACTER*4 ICOLF
28809      CHARACTER*4 ICOLP
28810      CHARACTER*4 ICOL
28811      CHARACTER*4 IFLAG
28812C
28813      DIMENSION ILINPA(*)
28814      DIMENSION ILINCO(*)
28815      DIMENSION PLINTH(*)
28816C
28817      DIMENSION AREGBA(*)
28818      DIMENSION IREBLI(*)
28819      DIMENSION IREBCO(*)
28820      DIMENSION PREBTH(*)
28821      DIMENSION IREFSW(*)
28822      DIMENSION IREFCO(*)
28823      DIMENSION IREPTY(*)
28824      DIMENSION IREPLI(*)
28825      DIMENSION IREPCO(*)
28826      DIMENSION PREPTH(*)
28827      DIMENSION PREPSP(*)
28828C
28829C-----COMMON----------------------------------------------------------
28830C
28831      INCLUDE 'DPCOGR.INC'
28832      INCLUDE 'DPCOBE.INC'
28833      INCLUDE 'DPCOP2.INC'
28834C
28835C-----START POINT-----------------------------------------------------
28836C
28837      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'OVA2')THEN
28838        WRITE(ICOUT,999)
28839  999   FORMAT(1X)
28840        CALL DPWRST('XXX','BUG ')
28841        WRITE(ICOUT,51)
28842   51   FORMAT('***** AT THE BEGINNING OF DPOVA2--')
28843        CALL DPWRST('XXX','BUG ')
28844        WRITE(ICOUT,53)X1,Y1,X2,Y2
28845   53   FORMAT('X1,Y1,X2,Y2 = ',4G15.7)
28846        CALL DPWRST('XXX','BUG ')
28847        WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1)
28848   61   FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',A4,2X,A4,G15.7)
28849        CALL DPWRST('XXX','BUG ')
28850        WRITE(ICOUT,62)IFIG,AREGBA(1)
28851   62   FORMAT('IFIG,AREGBA(1) = ',A4,2X,G15.7)
28852        CALL DPWRST('XXX','BUG ')
28853        WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1)
28854   63   FORMAT('IREBLI(1),IREBCO(1),PREBTH(1) = ',2(A4,2X),G15.7)
28855        CALL DPWRST('XXX','BUG ')
28856        WRITE(ICOUT,64)IREFSW(1),IREFCO(1)
28857   64   FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4)
28858        CALL DPWRST('XXX','BUG ')
28859        WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1)
28860   65   FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ',
28861     1         3(A4,2X),2G15.7)
28862        CALL DPWRST('XXX','BUG ')
28863        WRITE(ICOUT,69)PTEXHE,PTEXWI,PTEXHG,PTEXVG
28864   69   FORMAT('PTEXHE,PTEXWI,PTEXHG,PTEXVG = ',4G15.7)
28865        CALL DPWRST('XXX','BUG ')
28866        WRITE(ICOUT,79)IBUGG4,ISUBG4,IERRG4
28867   79   FORMAT('IBUGG4,ISUBG4,IERRG4 = ',2(A4,2X),A4)
28868        CALL DPWRST('XXX','BUG ')
28869      ENDIF
28870C
28871C               *********************************
28872C               **  STEP 1--                   **
28873C               **  DETERMINE THE COORDINATES  **
28874C               **  FOR THE OVAL               **
28875C               *********************************
28876C
28877      PI=3.1415926
28878C
28879C               ****************************************************
28880C               **  STEP 1.1--                                      **
28881C               **  FIND THE ANGLE OF ROTATION OF THE MAJOR AXIS  **
28882C               **  FIND THE RADIUS OF THE MAJOR AXIS              **
28883C               ****************************************************
28884C
28885      DELX=X3-X1
28886      DELY=Y3-Y1
28887      ALEN=0.0
28888      TERM=DELX**2+DELY**2
28889      IF(TERM.GT.0.0)ALEN=SQRT(TERM)
28890      A=ALEN/2.0
28891C
28892      IF(ABS(DELX).GE.0.00001)THETA=ATAN(DELY/DELX)
28893      IF(ABS(DELX).LT.0.00001.AND.DELY.GE.0.0)THETA=PI/2.0
28894      IF(ABS(DELX).LT.0.00001.AND.DELY.LT.0.0)THETA=-PI/2.0
28895C
28896      IF(IBUGG4.EQ.'ON')THEN
28897        WRITE(ICOUT,776)ALEN,A,THETA
28898  776   FORMAT('ALEN,A,THETA = ',3G15.7)
28899        CALL DPWRST('XXX','BUG ')
28900      ENDIF
28901C
28902C               ***********************************
28903C               **  STEP 1.2--                   **
28904C               **  FIND THE CENTER OF THE OVAL  **
28905C               ***********************************
28906C
28907      XCENT=(X1+X3)/2.0
28908      YCENT=(Y1+Y3)/2.0
28909C
28910      IF(IBUGG4.EQ.'ON')THEN
28911        WRITE(ICOUT,777)XCENT,YCENT
28912  777   FORMAT('XCENT,YCENT = ',2G15.7)
28913        CALL DPWRST('XXX','BUG ')
28914      ENDIF
28915C
28916C               *****************************************
28917C               **  STEP 1.3--                         **
28918C               **  FIND THE RADIUS OF THE MINOR AXIS  **
28919C               *****************************************
28920C
28921      DELX2=2.0*(X2-XCENT)
28922      DELY2=2.0*(Y2-YCENT)
28923      ALENMI=0.0
28924      TERM=DELX2**2+DELY2**2
28925      IF(TERM.GT.0.0)ALENMI=SQRT(TERM)
28926      B=ALENMI/2.0
28927C
28928      IF(IBUGG4.EQ.'ON')THEN
28929        WRITE(ICOUT,778)ALENMI,B
28930  778   FORMAT('ALENMI,B = ',2G15.7)
28931        CALL DPWRST('XXX','BUG ')
28932      ENDIF
28933C
28934C               *********************
28935C               **  STEP 1.4--     **
28936C               **  DRAW THE OVAL  **
28937C               *********************
28938C
28939      K=0
28940      X=0
28941      Y=0
28942      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
28943      K=K+1
28944      PX(K)=XP
28945      PY(K)=YP
28946C
28947C               ******************************************
28948C               **  STEP 1.5--                          **
28949C               **  DRAW THE UPPER LEFT QUARTER-CIRCLE  **
28950C               ******************************************
28951C
28952      X=0
28953      Y=0
28954      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
28955      AJX3=XP
28956      AJY3=YP
28957      X=(1.0-SQRT(0.5))*B
28958      Y=SQRT(0.5)*B
28959      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
28960      AJX4=XP
28961      AJY4=YP
28962      X=B
28963      Y=B
28964      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
28965      AJX5=XP
28966      AJY5=YP
28967      CALL DPOVA3(AJX3,AJY3,AJX4,AJY4,AJX5,AJY5,PX,PY,K)
28968C
28969C               *************************************
28970C               **  STEP 1.6--                     **
28971C               **  DRAW THE STRAIGHT TOP SECTION  **
28972C               *************************************
28973C
28974      X=ALEN-B
28975      Y=B
28976      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
28977      K=K+1
28978      PX(K)=XP
28979      PY(K)=YP
28980C
28981C               *******************************************
28982C               **  STEP 1.7--                           **
28983C               **  DRAW THE UPPER-RIGHT QUARTER-CIRCLE  **
28984C               *******************************************
28985C
28986      X=ALEN-B
28987      Y=B
28988      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
28989      AJX3=XP
28990      AJY3=YP
28991      X=ALEN-((1.0-SQRT(0.5))*B)
28992      Y=SQRT(0.5)*B
28993      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
28994      AJX4=XP
28995      AJY4=YP
28996      X=ALEN
28997      Y=0
28998      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
28999      AJX5=XP
29000      AJY5=YP
29001      CALL DPOVA3(AJX3,AJY3,AJX4,AJY4,AJX5,AJY5,PX,PY,K)
29002C
29003C               *******************************************
29004C               **  STEP 1.8--                           **
29005C               **  DRAW THE LOWER-RIGHT QUARTER-CIRCLE  **
29006C               *******************************************
29007C
29008      X=ALEN
29009      Y=0
29010      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
29011      AJX3=XP
29012      AJY3=YP
29013      X=ALEN-((1.0-SQRT(0.5))*B)
29014      Y=-SQRT(0.5)*B
29015      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
29016      AJX4=XP
29017      AJY4=YP
29018      X=ALEN-B
29019      Y=-B
29020      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
29021      AJX5=XP
29022      AJY5=YP
29023      CALL DPOVA3(AJX3,AJY3,AJX4,AJY4,AJX5,AJY5,PX,PY,K)
29024C
29025C               ****************************************
29026C               **  STEP 1.9--                        **
29027C               **  DRAW THE BOTTOM STRAIGHT SECTION  **
29028C               ****************************************
29029C
29030      X=B
29031      Y=-B
29032      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
29033      K=K+1
29034      PX(K)=XP
29035      PY(K)=YP
29036C
29037C               ******************************************
29038C               **  STEP 1.10--                         **
29039C               **  DRAW THE LOWER-LEFT QUARTER-CIRCLE  **
29040C               ******************************************
29041C
29042      X=B
29043      Y=-B
29044      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
29045      AJX3=XP
29046      AJY3=YP
29047      X=(1.0-SQRT(0.5))*B
29048      Y=-SQRT(0.5)*B
29049      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
29050      AJX4=XP
29051      AJY4=YP
29052      X=0
29053      Y=0
29054      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
29055      AJX5=XP
29056      AJY5=YP
29057      CALL DPOVA3(AJX3,AJY3,AJX4,AJY4,AJX5,AJY5,PX,PY,K)
29058C
29059      NP=K
29060C
29061C               ***********************
29062C               **  STEP 2--         **
29063C               **  FILL THE FIGURE  **
29064C               **  (IF CALLED FOR)  **
29065C               ***********************
29066C
29067      IF(IREFSW(1).EQ.'OFF')GOTO2190
29068      IPATT=IREPTY(1)
29069      IPATT2='SOLI'
29070      PTHICK=PREPTH(1)
29071      PXGAP=PREPSP(1)
29072      PYGAP=PREPSP(1)
29073      ICOLF=IREFCO(1)
29074      ICOLP=IREPCO(1)
29075      CALL DPFIRE(PX,PY,NP,
29076     1            IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,IPATT2)
29077 2190 CONTINUE
29078C
29079C               ***************************
29080C               **  STEP 3--             **
29081C               **  DRAW OUT THE FIGURE  **
29082C               ***************************
29083C
29084      IPATT=ILINPA(1)
29085      PTHICK=PLINTH(1)
29086      ICOL=ILINCO(1)
29087      IFLAG='ON'
29088      CALL DPDRPL(PX,PY,NP,
29089     1            IFIG,IPATT,PTHICK,ICOL,
29090     1            JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
29091C
29092C               *****************
29093C               **  STEP 90--  **
29094C               **  EXIT       **
29095C               *****************
29096C
29097      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'OVA2')THEN
29098        WRITE(ICOUT,999)
29099        CALL DPWRST('XXX','BUG ')
29100        WRITE(ICOUT,9011)
29101 9011   FORMAT('***** AT THE END       OF DPOVA2--')
29102        CALL DPWRST('XXX','BUG ')
29103        WRITE(ICOUT,9012)NP,IERRG4,DELX,DELY
29104 9012   FORMAT('NP,IERRG4,DELX,DELY = ',I8,2X,A4,2G15.7)
29105        CALL DPWRST('XXX','BUG ')
29106        WRITE(ICOUT,9013)XCENT,YCENT,A,B
29107 9013   FORMAT('XCENT,YCENT,A,B = ',4G15.7)
29108        CALL DPWRST('XXX','BUG ')
29109        DO9015I=1,NP
29110          WRITE(ICOUT,9016)I,PX(I),PY(I)
29111 9016     FORMAT('I,PX(I),PY(I) = ',I8,2G15.7)
29112          CALL DPWRST('XXX','BUG ')
29113 9015   CONTINUE
29114      ENDIF
29115C
29116      RETURN
29117      END
29118      SUBROUTINE DPOVA3(X1,Y1,X2,Y2,X3,Y3,PX,PY,K)
29119C
29120C     PURPOSE--DRAW AN ARC (AS PART OF AN OVAL)
29121C              WITH ONE END OF THE ARC AT (X1,Y1)
29122C              SOME MIDDLE POINT AT (X2,Y2),
29123C              AND THE OTHER END OF THE ARC AT (X3,Y3).
29124C     WRITTEN BY--JAMES J. FILLIBEN
29125C                 STATISTICAL ENGINEERING DIVISION
29126C                 INFORMATION TECHNOLOGY LABORATORY
29127C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
29128C                 GAITHERSBURG, MD 20899-8980
29129C                 PHONE--301-975-2855
29130C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
29131C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
29132C     LANGUAGE--ANSI FORTRAN (1977)
29133C     VERSION NUMBER--82/7
29134C     ORIGINAL VERSION--APRIL     1981.
29135C     UPDATED         --MAY       1982.
29136C
29137C-----NON-COMMON VARIABLES-------------------------------------
29138C
29139      DIMENSION PX(*)
29140      DIMENSION PY(*)
29141C
29142C-----COMMON----------------------------------------------------------
29143C
29144      INCLUDE 'DPCOGR.INC'
29145      INCLUDE 'DPCOBE.INC'
29146      INCLUDE 'DPCOP2.INC'
29147C
29148C-----START POINT-----------------------------------------------------
29149C
29150      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'OVA3')THEN
29151        WRITE(ICOUT,999)
29152  999   FORMAT(1X)
29153        CALL DPWRST('XXX','BUG ')
29154        WRITE(ICOUT,51)
29155   51   FORMAT('***** AT THE BEGINNING OF DPOVA3--')
29156        CALL DPWRST('XXX','BUG ')
29157        WRITE(ICOUT,53)X1,Y1,X2,Y2,X3,Y3
29158   53   FORMAT('X1,Y1,X2,Y2,X3,Y3 = ',6G15.7)
29159        CALL DPWRST('XXX','BUG ')
29160        WRITE(ICOUT,56)K
29161   56   FORMAT('K = ',I8)
29162        CALL DPWRST('XXX','BUG ')
29163        WRITE(ICOUT,79)IBUGG4,ISUBG4,IERRG4
29164   79   FORMAT('IBUGG4,ISUBG4,IERRG4 = ',2(A4,2X),A4)
29165        CALL DPWRST('XXX','BUG ')
29166      ENDIF
29167C
29168C               *********************************
29169C               **  STEP 1--                   **
29170C               **  DETERMINE THE COORDINATES  **
29171C               **  FOR THE ARC                **
29172C               *********************************
29173C
29174      PI=3.1415926
29175C
29176      THETA=0.0
29177      THETA1=0.0
29178      THETA2=0.0
29179      THETA3=0.0
29180C
29181C               ********************************************************
29182C               **  STEP 1.1--                                        **
29183C               **  COMPUTE THE INTERCEPT AND SLOPE OF THE LINE       **
29184C               **  THROUGH THE MIDPOINT OF POINTS 1 AND 2 AND        **
29185C               **  PERPENDICULAR TO THE SEGMENT BETWEEN POINTS 1 AND 2*
29186C               ********************************************************
29187C
29188      DELX12=X2-X1
29189      DELY12=Y2-Y1
29190C
29191      IF(DELX12.EQ.0.0)THEN
29192        AM12=CPUMAX
29193        B12=CPUMAX
29194        AM12P=0.0
29195        B12P=Y1
29196      ELSEIF(DELY12.EQ.0.0)THEN
29197        AM12=0.0
29198        B12=Y1
29199        AM12P=CPUMAX
29200        B12P=CPUMAX
29201      ELSE
29202        AM12=DELY12/DELX12
29203        B12=-AM12*X1+Y1
29204        X12=(X1+X2)/2.0
29205        Y12=(Y1+Y2)/2.0
29206        AM12P=-1.0/AM12
29207        B12P=-AM12P*X12+Y12
29208      ENDIF
29209C
29210      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'OVA3')THEN
29211        WRITE(ICOUT,716)DELX12,DELY12,B12,AM12,B12P,AM12P
29212  716   FORMAT('DELX12,DELY12,B12,AM12,B12P,AM12P = ',6G15.7)
29213        CALL DPWRST('XXX','BUG ')
29214      ENDIF
29215C
29216C               ********************************************************
29217C               **  STEP 1.2--                                        **
29218C               **  COMPUTE THE INTERCEPT AND SLOPE OF THE LINE       **
29219C               **  THROUGH THE MIDPOINT OF POINTS 2 AND 3            **
29220C               **  AND PERPENDICULAR TO THE SEGMENT BETWEEN POINTS 2 **
29221C               **  AND 3.                                            **
29222C               ********************************************************
29223C
29224      DELX23=X3-X2
29225      DELY23=Y3-Y2
29226C
29227      IF(DELX23.EQ.0.0)THEN
29228        AM23=CPUMAX
29229        B23=CPUMAX
29230        AM23P=0.0
29231        B23P=Y2
29232      ELSEIF(DELY23.EQ.0.0)THEN
29233        AM23=0.0
29234        B23=Y2
29235        AM23P=CPUMAX
29236        B23P=CPUMAX
29237      ELSE
29238        AM23=DELY23/DELX23
29239        B23=-AM23*X2+Y2
29240        X23=(X2+X3)/2.0
29241        Y23=(Y2+Y3)/2.0
29242        AM23P=-1.0/AM23
29243        B23P=-AM23P*X23+Y23
29244      ENDIF
29245C
29246      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'OVA3')THEN
29247        WRITE(ICOUT,726)DELX23,DELY23,B23,AM23,B23P,AM23P
29248  726   FORMAT('DELX23,DELY23,B23,AM23,B23P,AM23P = ',6G15.7)
29249        CALL DPWRST('XXX','BUG ')
29250      ENDIF
29251C
29252C               ***************************************************
29253C               **  STEP 1.3--                                   **
29254C               **  COMPUTE THE COORDINATES OF THE CENTER POINT  **
29255C               **  OF THE CIRCLE DEFINED BY THE 3 ARC POINTS.   **
29256C               ***************************************************
29257C
29258      ANUM=-(B12P-B23P)
29259      ADEN=AM12P-AM23P
29260      XCENT=CPUMAX
29261      IF(ADEN.NE.0.0)XCENT=ANUM/ADEN
29262      YCENT=AM12P*XCENT+B12P
29263C
29264      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'OVA3')THEN
29265         WRITE(ICOUT,731)ANUM,ADEN,XCENT,YCENT
29266  731    FORMAT('ANUM,ADEN,XCENT,YCENT = ',4G15.7)
29267         CALL DPWRST('XXX','BUG ')
29268      ENDIF
29269C
29270C               ****************************************************
29271C               **  STEP 1.4--                                    **
29272C               **  COMPUTE THE ANGLE OF ROTATION OF THE FIGURE.  **
29273C               ****************************************************
29274C
29275      DELX=X3-X1
29276      DELY=Y3-Y1
29277C
29278      IF(ABS(DELX).GE.0.00001.AND.DELX.LT.0.0)
29279     1THETA=PI+ATAN(DELY/DELX)
29280      IF(ABS(DELX).GE.0.00001.AND.DELX.GT.0.0)
29281     1THETA=ATAN(DELY/DELX)
29282C
29283      IF(ABS(DELX).LT.0.00001.AND.DELY.LT.0.0)
29284     1THETA=1.5*(PI/2.0)
29285      IF(ABS(DELX).LT.0.00001.AND.DELX.EQ.0.0)
29286     1THETA=PI/2.0
29287      IF(ABS(DELX).LT.0.00001.AND.DELY.GT.0.0)
29288     1THETA=PI/2.0
29289C
29290      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'OVA3')THEN
29291        WRITE(ICOUT,741)DELX,DELY,THETA
29292  741   FORMAT('DELX,DELY,THETA = ',3G15.7)
29293        CALL DPWRST('XXX','BUG ')
29294      ENDIF
29295C
29296C               ********************************************************
29297C               **  STEP 1.5--                                        **
29298C               **  COMPUTE THE RADIUS OF THE CIRCLE.                 **
29299C               **  COMPUTE THE ANGLE FROM THE CENTER POINT TO POINT 1**
29300C               ********************************************************
29301C
29302      DELXC1=2.0*(X1-XCENT)
29303      DELYC1=2.0*(Y1-YCENT)
29304      ALEN=0.0
29305      TERM=DELXC1**2+DELYC1**2
29306      IF(TERM.GT.0.0)ALEN=SQRT(TERM)
29307      R=ALEN/2.0
29308      IF(ABS(DELXC1).GE.0.00001.AND.DELXC1.GE.0.0)
29309     1THETA1=ATAN(DELYC1/DELXC1)
29310      IF(ABS(DELXC1).GE.0.00001.AND.DELXC1.LT.0.0)
29311     1THETA1=PI+ATAN(DELYC1/DELXC1)
29312      IF(ABS(DELXC1).LT.0.00001.AND.DELYC1.GE.0.0)
29313     1THETA1=PI/2.0
29314      IF(ABS(DELXC1).LT.0.00001.AND.DELYC1.LT.0.0)
29315     1THETA1=1.5*(PI/2.0)
29316      IF(THETA1.LT.0.0)THETA1=THETA1+2.0*PI
29317C
29318      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'OVA3')THEN
29319        WRITE(ICOUT,752)ALEN,R,DELXC1,DELYC1,THETA1
29320  752   FORMAT('ALEN,R,DELXC1,DELYC1,THETA1 = ',3G15.7)
29321        CALL DPWRST('XXX','BUG ')
29322      ENDIF
29323C
29324C               ********************************************************
29325C               **  STEP 1.6--                                        **
29326C               **  COMPUTE THE ANGLE FROM THE CENTER POINT TO POINT 2.*
29327C               ********************************************************
29328C
29329      DELXC2=2.0*(X2-XCENT)
29330      DELYC2=2.0*(Y2-YCENT)
29331      IF(ABS(DELXC2).GE.0.00001.AND.DELXC2.GE.0.0)
29332     1THETA2=ATAN(DELYC2/DELXC2)
29333      IF(ABS(DELXC2).GE.0.00001.AND.DELXC2.LT.0.0)
29334     1THETA2=PI+ATAN(DELYC2/DELXC2)
29335      IF(ABS(DELXC2).LT.0.00001.AND.DELYC2.GE.0.0)
29336     1THETA2=PI/2.0
29337      IF(ABS(DELXC2).LT.0.00001.AND.DELYC2.LT.0.0)
29338     1THETA2=1.5*(PI/2.0)
29339      IF(THETA2.LT.0.0)THETA2=THETA2+2.0*PI
29340C
29341      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'OVA3')THEN
29342        WRITE(ICOUT,761)DELXC2,DELYC2,THETA2
29343  761   FORMAT('DELXC2,DELYC2,THETA2 = ',3G15.7)
29344        CALL DPWRST('XXX','BUG ')
29345      ENDIF
29346C
29347C               ********************************************************
29348C               **  STEP 1.7--                                        **
29349C               **  COMPUTE THE ANGLE FROM THE CENTER POINT TO POINT 3.*
29350C               ********************************************************
29351C
29352      DELXC3=2.0*(X3-XCENT)
29353      DELYC3=2.0*(Y3-YCENT)
29354      IF(ABS(DELXC3).GE.0.00001.AND.DELXC3.GE.0.0)
29355     1THETA3=ATAN(DELYC3/DELXC3)
29356      IF(ABS(DELXC3).GE.0.00001.AND.DELXC3.LT.0.0)
29357     1THETA3=PI+ATAN(DELYC3/DELXC3)
29358      IF(ABS(DELXC3).LT.0.00001.AND.DELYC3.GE.0.0)
29359     1THETA3=PI/2.0
29360      IF(ABS(DELXC3).LT.0.00001.AND.DELYC3.LT.0.0)
29361     1THETA3=1.5*(PI/2.0)
29362      IF(THETA3.LT.0.0)THETA3=THETA3+2.0*PI
29363C
29364      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'OVA3')THEN
29365        WRITE(ICOUT,771)DELXC3,DELYC3,THETA3
29366  771   FORMAT('DELXC3,DELYC3,THETA3 = ',3G15.7)
29367        CALL DPWRST('XXX','BUG ')
29368      ENDIF
29369C
29370C               ******************************
29371C               **  STEP 1.8--              **
29372C               **  COMPUTE THE ARC POINTS  **
29373C               ******************************
29374C
29375      K=K+1
29376      PX(K)=X1
29377      PY(K)=Y1
29378C
29379      IF(THETA1.LE.THETA3.AND.THETA3.LE.THETA2)THEN
29380        THETA1=THETA1+2.0*PI
29381      ELSEIF(THETA2.LE.THETA1.AND.THETA1.LE.THETA3)THEN
29382        THETA1=THETA1+2.0*PI
29383        THETA2=THETA2+2.0*PI
29384      ELSEIF(THETA3.LE.THETA1.AND.THETA1.LE.THETA2)THEN
29385        THETA1=THETA1+2.0*PI
29386      ELSEIF(THETA2.LE.THETA3.AND.THETA3.LE.THETA1)THEN
29387        THETA2=THETA2+2.0*PI
29388        THETA3=THETA3+2.0*PI
29389      ENDIF
29390C
29391      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'OVA3')THEN
29392        WRITE(ICOUT,3009)THETA1,THETA2,THETA3
29393 3009   FORMAT('THETA1,THETA2,THETA3 = ',3G15.7)
29394        CALL DPWRST('XXX','BUG ')
29395      ENDIF
29396C
29397      DELTHE=THETA3-THETA1
29398      IMAX=101
29399      AIMAX=IMAX
29400      DO3010I=1,IMAX
29401        AI=I
29402        P=(AI-1.0)/(AIMAX-1.0)
29403        PHI2=THETA1+P*DELTHE
29404        X=XCENT+R*COS(PHI2)
29405        Y=YCENT+R*SIN(PHI2)
29406        K=K+1
29407        PX(K)=X
29408        PY(K)=Y
29409 3010 CONTINUE
29410C
29411C               *****************
29412C               **  STEP 90--  **
29413C               **  EXIT       **
29414C               *****************
29415C
29416      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'IND2')THEN
29417        WRITE(ICOUT,999)
29418        CALL DPWRST('XXX','BUG ')
29419        WRITE(ICOUT,9011)
29420 9011   FORMAT('***** AT THE END       OF DPOVA3--')
29421        CALL DPWRST('XXX','BUG ')
29422        WRITE(ICOUT,9012)XCENT,YCENT,R,K,IERRG4
29423 9012   FORMAT('XCENT,YCENT,R,K,IERRG4 = ',3G15.7,I8,2X,A4)
29424        CALL DPWRST('XXX','BUG ')
29425        DO9015I=1,K
29426          WRITE(ICOUT,9016)I,PX(I),PY(I)
29427 9016     FORMAT('I,PX(I),PY(I) = ',I8,2G15.7)
29428          CALL DPWRST('XXX','BUG ')
29429 9015   CONTINUE
29430      ENDIF
29431C
29432      RETURN
29433      END
29434      SUBROUTINE DPOVAL(IHARG,IARGT,ARG,NUMARG,
29435     1                  PXSTAR,PYSTAR,PXEND,PYEND,
29436     1                  ILINPA,ILINCO,PLINTH,
29437     1                  AREGBA,IREBLI,IREBCO,PREBTH,
29438     1                  IREFSW,IREFCO,
29439     1                  IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
29440     1                  PTEXHE,PTEXWI,PTEXVG,PTEXHG,
29441     1                  IGRASW,IDIASW,
29442     1                  PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
29443     1                  PDIAHE,PDIAWI,PDIAVG,PDIAHG,
29444     1                  NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
29445     1                  IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
29446     1                  IDNVOF,IDNHOF,IDFONT,UNITSW,PDSCAL,
29447     1                  IBUGD2,IFOUND,IERROR)
29448C
29449C     PURPOSE--DRAW ONE OR MORE OVALS (DEPENDING ON HOW MANY NUMBERS ARE
29450C              PROVIDED).  THE COORDINATES ARE IN STANDARDIZED UNITS
29451C              OF 0 TO 100.
29452C     NOTE--THE INPUT COORDINATES DEFINE 3 SUCCESSIVE POINTS AROUND THE
29453C           OVAL--AT THE ENDS OF AXES.
29454C     NOTE-THE USUAL INPUT NUMBER OF COORDINATES IS 3
29455C          AND THEREFORE THE USUAL INPUT NUMBER OF NUMBERS IS 2*3 = 6.
29456C     NOTE--IF 4 NUMBERS ARE PROVIDED, THEN THE DRAWN OVAL WILL GO FROM
29457C           THE LAST CURSOR POSITION (ASSUMED TO BE AT ONE END OF MAJOR
29458C           AXIS) THROUGH THE (X,Y) POINT (EITHER ABSOLUTE OR RELATIVE)
29459C           AS DEFINED BY THE FIRST AND SECOND NUMBERS (ASSUMED TO BE AT
29460C           ONE END OF MINOR AXIS), TO THE (X,Y) POINT (EITHER ABSOLUTE
29461C           OR RELATIVE) AS DEFINED BY THE THIRD AND FOURTH NUMBERS
29462C           (ASSUMED TO BE AT THE OTHER END OF MAJOR AXIS),
29463C           AND THEN BACK TO THE OTHER END OF THE MINOR AXIS,
29464C           AND CONTINUING BACK THE START POINT TO CLOSE THE OVAL.
29465C     NOTE--IF 6 NUMBERS ARE PROVIDED, THEN THE DRAWN OVAL WILL GO FROM
29466C           THE ABSOLUTE (X,Y) POSITION AS RESULTING FORM THE FIRST AND
29467C           SECOND NUMBERS (ASSUMED TO BE AT ONE END OF MAJOR AXIS),
29468C           THROUGH THE (X,Y) POINT (EITHER ABSOLUTE OR RELATIVE)
29469C           AS DEFINED BY THE THIRD AND FOURTH NUMBERS (ASSUMED TO BE AT
29470C           ONE END OF MINOR AXIS), TO THE (X,Y) POINT (EITHER ABSOLUTE
29471C           OR RELATIVE) AS DEFINED BY THE FIFTH AND SIXTH NUMBERS
29472C           (ASSUMED TO BE AT THE OTHER END OF MAJOR AXIS),
29473C           AND THEN BACK TO THE OTHER END OF THE MINOR AXIS,
29474C           AND CONTINUING BACK THE START POINT TO CLOSE THE OVAL.
29475C     NOTE--AND SO FORTH FOR 10, 14, 18, ... NUMBERS.
29476C     INPUT  ARGUMENTS--IHARG
29477C                     --IARGT
29478C                     --ARG
29479C                     --NUMARG
29480C                     --PXSTAR
29481C                     --PYSTAR
29482C     OUTPUT ARGUMENTS--PXEND
29483C                     --PYEND
29484C                     --IFOUND ('YES' OR 'NO' )
29485C                     --IERROR ('YES' OR 'NO' )
29486C     WRITTEN BY--JAMES J. FILLIBEN
29487C                 STATISTICAL ENGINEERING DIVISION
29488C                 INFORMATION TECHNOLOGY LABORATORY
29489C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
29490C                 GAITHERSBURG, MD 20899-8980
29491C                 PHONE--301-975-2855
29492C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
29493C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
29494C     LANGUAGE--ANSI FORTRAN (1977)
29495C     VERSION NUMBER--82/7
29496C     ORIGINAL VERSION--APRIL     1981.
29497C     UPDATED         --MARCH     1982.
29498C     UPDATED         --MAY       1982.
29499C     UPDATED         --NOVEMBER  1982.
29500C     UPDATED         --JANUARY   1989. CALL LIST FOR OFFSET VAR (ALAN)
29501C     UPDATED         --MARCH     1997. SUPPORT FOR DEVICE FONT (ALAN)
29502C     UPDATED         --JULY      1997. SUPPORT FOR "DATA" UNITS (ALAN)
29503C     UPDATED         --DECEMBER  2018. CHECK FOR DISCRETE, NULL, OR
29504C                                       NONE DEVICE
29505C     UPDATED         --DECEMBER  2018. SUPPORT FOR "DEVICE ... SCALE"
29506C                                       COMMAND
29507C     UPDATED         --JULY      2019. CREATE SCRATCH STORAGE IN DPOVAL
29508C                                       RATHER THAN DPOVA2
29509C
29510C-----NON-COMMON VARIABLES-----------------------------------------
29511C
29512      CHARACTER*4 IHARG
29513      CHARACTER*4 IARGT
29514C
29515      CHARACTER*4 ILINPA
29516      CHARACTER*4 ILINCO
29517C
29518      CHARACTER*4 IREBLI
29519      CHARACTER*4 IREBCO
29520      CHARACTER*4 IREFSW
29521      CHARACTER*4 IREFCO
29522      CHARACTER*4 IREPTY
29523      CHARACTER*4 IREPLI
29524      CHARACTER*4 IREPCO
29525C
29526      CHARACTER*4 IGRASW
29527      CHARACTER*4 IDIASW
29528C
29529      CHARACTER*4 IDMANU
29530      CHARACTER*4 IDMODE
29531      CHARACTER*4 IDMOD2
29532      CHARACTER*4 IDMOD3
29533      CHARACTER*4 IDPOWE
29534      CHARACTER*4 IDCONT
29535      CHARACTER*4 IDCOLO
29536      CHARACTER*4 IDFONT
29537      CHARACTER*4 UNITSW
29538C
29539      CHARACTER*4 IFOUND
29540      CHARACTER*4 IBUGD2
29541      CHARACTER*4 IERROR
29542      CHARACTER*4 ISUBRO
29543C
29544      CHARACTER*4 IFIG
29545      CHARACTER*4 IBELSW
29546      CHARACTER*4 IERASW
29547      CHARACTER*4 IBACCO
29548      CHARACTER*4 ICOPSW
29549      CHARACTER*4 ITYPEO
29550C
29551      DIMENSION IHARG(*)
29552      DIMENSION IARGT(*)
29553      DIMENSION ARG(*)
29554C
29555      DIMENSION ILINPA(*)
29556      DIMENSION ILINCO(*)
29557      DIMENSION PLINTH(*)
29558C
29559      DIMENSION AREGBA(*)
29560      DIMENSION IREBLI(*)
29561      DIMENSION IREBCO(*)
29562      DIMENSION PREBTH(*)
29563      DIMENSION IREFSW(*)
29564      DIMENSION IREFCO(*)
29565      DIMENSION IREPTY(*)
29566      DIMENSION IREPLI(*)
29567      DIMENSION IREPCO(*)
29568      DIMENSION PREPTH(*)
29569      DIMENSION PREPSP(*)
29570      DIMENSION PDSCAL(*)
29571C
29572      DIMENSION IDMANU(*)
29573      DIMENSION IDMODE(*)
29574      DIMENSION IDMOD2(*)
29575      DIMENSION IDMOD3(*)
29576      DIMENSION IDPOWE(*)
29577      DIMENSION IDCONT(*)
29578      DIMENSION IDCOLO(*)
29579      DIMENSION IDFONT(*)
29580      DIMENSION IDNVPP(*)
29581      DIMENSION IDNHPP(*)
29582      DIMENSION IDUNIT(*)
29583      DIMENSION IDNVOF(*)
29584      DIMENSION IDNHOF(*)
29585C
29586C-----COMMON----------------------------------------------------------
29587C
29588      INCLUDE 'DPCOPA.INC'
29589      INCLUDE 'DPCOZZ.INC'
29590      DIMENSION PX(1000)
29591      DIMENSION PY(1000)
29592      EQUIVALENCE (GARBAG(IGARB1),PX(1))
29593      EQUIVALENCE (GARBAG(IGARB2),PY(1))
29594C
29595C-----COMMON VARIABLES (GENERAL)--------------------------------------
29596C
29597      INCLUDE 'DPCOGR.INC'
29598      INCLUDE 'DPCOBE.INC'
29599      INCLUDE 'DPCOP2.INC'
29600C
29601C-----START POINT-----------------------------------------------------
29602C
29603      IFOUND='NO'
29604      IERROR='NO'
29605      IERRG4=IERROR
29606C
29607      ILOCFN=0
29608      NUMNUM=0
29609C
29610      X1=0.0
29611      Y1=0.0
29612      X2=0.0
29613      Y2=0.0
29614C
29615      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'OVAL')THEN
29616        WRITE(ICOUT,999)
29617  999   FORMAT(1X)
29618        CALL DPWRST('XXX','BUG ')
29619        WRITE(ICOUT,51)
29620   51   FORMAT('***** AT THE BEGINNING OF DPOVAL--')
29621        CALL DPWRST('XXX','BUG ')
29622        WRITE(ICOUT,53)NUMARG,NUMDEV
29623   53   FORMAT('NUMARG,NUMDEV = ',2I8)
29624        CALL DPWRST('XXX','BUG ')
29625        DO55I=1,NUMARG
29626          WRITE(ICOUT,56)I,IHARG(I),IARGT(I),ARG(I)
29627   56     FORMAT('I,IHARG(I),IARGT(I),ARG(I) = ',I8,2(2X,A4),G15.7)
29628          CALL DPWRST('XXX','BUG ')
29629   55   CONTINUE
29630        WRITE(ICOUT,57)PXSTAR,PYSTAR,PXEND,PYEND
29631   57   FORMAT('PXSTAR,PYSTAR,PXEND,PYEND = ',4G15.7)
29632        CALL DPWRST('XXX','BUG ')
29633        WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1)
29634   61   FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',2(A4,2X),G15.7)
29635        CALL DPWRST('XXX','BUG ')
29636        WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1),AREGBA(1)
29637   63   FORMAT('IREBLI(1),IREBCO(1),PREBTH(1),AREGBA(1) = ',
29638     1         2(A4,2X),2G15.7)
29639        CALL DPWRST('XXX','BUG ')
29640        WRITE(ICOUT,64)IREFSW(1),IREFCO(1)
29641   64   FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4)
29642        CALL DPWRST('XXX','BUG ')
29643        WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1)
29644   65   FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ',
29645     1         3(A4,2X),2G15.7)
29646        CALL DPWRST('XXX','BUG ')
29647        WRITE(ICOUT,69)PTEXHE,PTEXWI,PTEXVG,PTEXHG
29648   69   FORMAT('PTEXHE,PTEXWI,PTEXVG,PTEXHG= ',4G15.7)
29649        CALL DPWRST('XXX','BUG ')
29650        WRITE(ICOUT,76)IGRASW,IDIASW
29651   76   FORMAT('IGRASW,IDIASW = ',A4,2X,A4)
29652        CALL DPWRST('XXX','BUG ')
29653        WRITE(ICOUT,77)PGRAXF,PGRAYF,PDIAXC,PDIAYC
29654   77   FORMAT('PGRAXF,PGRAYF,PDIAXC,PDIAYC = ',4G15.7)
29655        CALL DPWRST('XXX','BUG ')
29656        WRITE(ICOUT,78)PDIAHE,PDIAWI,PDIAVG,PDIAHG
29657   78   FORMAT('PDIAHE,PDIAWI,PDIAVG,PDIAHG = ',4G15.7)
29658        CALL DPWRST('XXX','BUG ')
29659        DO81I=1,NUMDEV
29660          WRITE(ICOUT,82)IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I)
29661   82     FORMAT('IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I) = ',
29662     1           3(A4,2X),A4)
29663          CALL DPWRST('XXX','BUG ')
29664          WRITE(ICOUT,83)IDPOWE(I),IDCONT(I),IDCOLO(I)
29665   83     FORMAT('IDPOWE(I),IDCONT(I),IDCOLO(I) = ',2(A4,2X),A4)
29666          CALL DPWRST('XXX','BUG ')
29667          WRITE(ICOUT,84)IDNVPP(I),IDNHPP(I),IDUNIT(I)
29668   84     FORMAT('IDNVPP(I),IDNHPP(I),IDUNIT(I) = ',3I8)
29669          CALL DPWRST('XXX','BUG ')
29670   81   CONTINUE
29671        WRITE(ICOUT,88)IBUGG4,IBUGD2,ISUBG4,IERRG4,IFOUND,IERROR
29672   88   FORMAT('IBUGG4,IBUGD2,ISUBG4,IERRG4,IFOUND,IERROR = ',
29673     1         5(A4,2X),A4)
29674        CALL DPWRST('XXX','BUG ')
29675      ENDIF
29676C
29677      IFIG='OVAL'
29678      NUMPT=3
29679      NUMPT2=2*NUMPT
29680C
29681C               ********************************
29682C               **  STEP 0--                  **
29683C               **  STEP THROUGH EACH DEVICE  **
29684C               ********************************
29685C
29686      IF(NUMDEV.LE.0)GOTO9000
29687      DO8000IDEVIC=1,NUMDEV
29688C
29689        IF(IDPOWE(IDEVIC).EQ.'OFF')GOTO8000
29690        IF(IDMANU(IDEVIC).EQ.'OFF')GOTO8000
29691        IF(IDMANU(IDEVIC).EQ.'NULL')GOTO8000
29692        IF(IDMANU(IDEVIC).EQ.'NONE')GOTO8000
29693        IF(IDMANU(IDEVIC).EQ.'DISC')GOTO8000
29694C
29695        IMANUF=IDMANU(IDEVIC)
29696        IMODEL=IDMODE(IDEVIC)
29697        IMODE2=IDMOD2(IDEVIC)
29698        IMODE3=IDMOD3(IDEVIC)
29699        IGCONT=IDCONT(IDEVIC)
29700        IGCOLO=IDCOLO(IDEVIC)
29701        IGFONT=IDFONT(IDEVIC)
29702        NUMVPP=IDNVPP(IDEVIC)
29703        NUMHPP=IDNHPP(IDEVIC)
29704        ANUMVP=NUMVPP
29705        ANUMHP=NUMHPP
29706        IOFFSV=IDNVOF(IDEVIC)
29707        IOFFSH=IDNHOF(IDEVIC)
29708        IGUNIT=IDUNIT(IDEVIC)
29709        PCHSCA=PDSCAL(IDEVIC)
29710C
29711C               ************************************
29712C               **  STEP 1--                      **
29713C               **  CARRY OUT OPENING OPERATIONS  **
29714C               **  ON THE GRAPHICS DEVICES       **
29715C               ************************************
29716C
29717        CALL DPOPDE
29718C
29719        IBELSW='OFF'
29720        NUMRIN=0
29721        IERASW='OFF'
29722        IBACCO='JUNK'
29723C
29724        CALL DPOPPL(IGRASW,IBELSW,NUMRIN,IERASW,IBACCO)
29725C
29726C               *****************************************
29727C               **  STEP 2--                           **
29728C               **  SEARCH FOR COMMAND SPECIFICATIONS  **
29729C               *****************************************
29730C
29731        IF(NUMARG.GE.2.AND.
29732     1     IARGT(1).EQ.'NUMB'.AND.IARGT(2).EQ.'NUMB')THEN
29733          ITYPEO='ABSO'
29734          ILOCFN=1
29735        ELSEIF(NUMARG.GE.3.AND.IHARG(1).EQ.'ABSO'.AND.
29736     1         IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB')THEN
29737          ITYPEO='ABSO'
29738          ILOCFN=2
29739        ELSEIF(NUMARG.GE.3.AND.IHARG(1).EQ.'RELA'.AND.
29740     1         IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB')THEN
29741          ITYPEO='RELA'
29742          ILOCFN=2
29743        ELSE
29744          GOTO1130
29745        ENDIF
29746C
29747        IF(ILOCFN.GT.NUMARG)GOTO1130
29748        DO1120I=ILOCFN,NUMARG
29749          IF(IARGT(I).NE.'NUMB')GOTO1130
29750 1120   CONTINUE
29751        IFOUND='YES'
29752C
29753C               ****************************
29754C               **  STEP 3--              **
29755C               **  DRAW OUT THE LINE(S)  **
29756C               ****************************
29757C
29758        NUMNUM=NUMARG-ILOCFN+1
29759        IF(NUMNUM.LT.NUMPT2)THEN
29760          J=ILOCFN-1
29761          X1=PXSTAR
29762          Y1=PYSTAR
29763        ELSE
29764          J=ILOCFN
29765          IF(J.GT.NUMARG)GOTO1190
29766          X1=ARG(J)
29767          IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X1,X1,
29768     1       IBUGD2,ISUBRO,IERROR)
29769          J=J+1
29770          IF(J.GT.NUMARG)GOTO1190
29771          Y1=ARG(J)
29772          IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y1,Y1,
29773     1       IBUGD2,ISUBRO,IERROR)
29774        ENDIF
29775C
29776 1160   CONTINUE
29777        J=J+1
29778        IF(J.GT.NUMARG)GOTO1190
29779        X2=ARG(J)
29780        IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X2,X2,IBUGD2,ISUBRO,IERROR)
29781        IF(ITYPEO.EQ.'RELA')X2=X1+X2
29782        J=J+1
29783        IF(J.GT.NUMARG)GOTO1190
29784        Y2=ARG(J)
29785        IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y2,Y2,IBUGD2,ISUBRO,IERROR)
29786        IF(ITYPEO.EQ.'RELA')Y2=Y1+Y2
29787C
29788        J=J+1
29789        IF(J.GT.NUMARG)GOTO1190
29790        X3=ARG(J)
29791        IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X3,X3,IBUGD2,ISUBRO,IERROR)
29792        IF(ITYPEO.EQ.'RELA')X3=X2+X3
29793        J=J+1
29794        IF(J.GT.NUMARG)GOTO1190
29795        Y3=ARG(J)
29796        IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y3,Y3,IBUGD2,ISUBRO,IERROR)
29797        IF(ITYPEO.EQ.'RELA')Y3=Y2+Y3
29798C
29799        CALL DPOVA2(X1,Y1,X2,Y2,X3,Y3,PX,PY,
29800     1              IFIG,ILINPA,ILINCO,PLINTH,
29801     1              AREGBA,IREBLI,IREBCO,PREBTH,
29802     1              IREFSW,IREFCO,
29803     1              IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
29804     1              PTEXHE,PTEXWI,PTEXVG,PTEXHG)
29805C
29806        X1=X3
29807        Y1=Y3
29808C
29809        GOTO1160
29810 1190   CONTINUE
29811C
29812        PXEND=X3
29813        PYEND=Y3
29814C
29815C               ************************************
29816C               **  STEP 4--                      **
29817C               **  CARRY OUT CLOSING OPERATIONS  **
29818C               **  ON THE GRAPHICS DEVICES       **
29819C               ************************************
29820C
29821        ICOPSW='OFF'
29822        NUMCOP=0
29823        CALL DPCLPL(ICOPSW,NUMCOP,
29824     1              PGRAXF,PGRAYF,
29825     1              IGRASW,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
29826     1              PDIAHE,PDIAWI,PDIAVG,PDIAHG)
29827C
29828        CALL DPCLDE
29829C
29830 8000 CONTINUE
29831      GOTO9000
29832C
29833 1130 CONTINUE
29834      IERRG4='YES'
29835      WRITE(ICOUT,1131)
29836 1131 FORMAT('***** ERROR IN DPOVAL--')
29837      CALL DPWRST('XXX','BUG ')
29838      WRITE(ICOUT,1132)
29839 1132 FORMAT('      ILLEGAL FORM FOR THE OVAL COMMAND.')
29840      CALL DPWRST('XXX','BUG ')
29841      WRITE(ICOUT,1134)
29842 1134 FORMAT('      TEST EXAMPLE TO DEMONSTRATE THE PROPER FORM--')
29843      CALL DPWRST('XXX','BUG ')
29844      WRITE(ICOUT,1135)
29845 1135 FORMAT('      SUPPOSE IT IS DESIRED TO DRAW AN OVAL ')
29846      CALL DPWRST('XXX','BUG ')
29847      WRITE(ICOUT,1136)
29848 1136 FORMAT('      WITH ONE END OF MAJOR AXIS AT THE POINT 20 20 ')
29849      CALL DPWRST('XXX','BUG ')
29850      WRITE(ICOUT,1137)
29851 1137 FORMAT('      ONE END OF THE MINOR AXIS AT THE POINT 30 10')
29852      CALL DPWRST('XXX','BUG ')
29853      WRITE(ICOUT,1138)
29854 1138 FORMAT('      AND WITH THE OTHER END OF THE MAJOR AXIS')
29855      CALL DPWRST('XXX','BUG ')
29856      WRITE(ICOUT,1139)
29857 1139 FORMAT('      AT THE POINT 40 20')
29858      CALL DPWRST('XXX','BUG ')
29859      WRITE(ICOUT,1141)
29860 1141 FORMAT('      THEN THE ALLOWABLE FORMS ARE--')
29861      CALL DPWRST('XXX','BUG ')
29862      WRITE(ICOUT,1142)
29863 1142 FORMAT('      OVAL 20 20 30 10 40 20 ')
29864      CALL DPWRST('XXX','BUG ')
29865      WRITE(ICOUT,1143)
29866 1143 FORMAT('      OVAL ABSOLUTE 20 20 30 10 40 20 ')
29867      CALL DPWRST('XXX','BUG ')
29868      WRITE(ICOUT,1145)
29869 1145 FORMAT('      OVAL RELATIVE 20 20 30 10 40 20 ')
29870      CALL DPWRST('XXX','BUG ')
29871C
29872C               *****************
29873C               **  STEP 90--  **
29874C               **  EXIT       **
29875C               *****************
29876C
29877 9000 CONTINUE
29878      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'OVAL')THEN
29879        WRITE(ICOUT,999)
29880        CALL DPWRST('XXX','BUG ')
29881        WRITE(ICOUT,9011)
29882 9011   FORMAT('***** AT THE END       OF DPOVAL--')
29883        CALL DPWRST('XXX','BUG ')
29884        WRITE(ICOUT,9012)IFOUND,IERROR,ILOCFN,NUMNUM
29885 9012   FORMAT('IFOUND,IERROR,ILOCFN,NUMNUM = ',2(A4,2X),2I8)
29886        CALL DPWRST('XXX','BUG ')
29887        WRITE(ICOUT,9013)X1,Y1,X2,Y2,X3,Y3
29888 9013   FORMAT('X1,Y1,X2,Y2,X3,Y3 = ',6G15.7)
29889        CALL DPWRST('XXX','BUG ')
29890        WRITE(ICOUT,9015)PXSTAR,PYSTAR,PXEND,PYEND
29891 9015   FORMAT('PXSTAR,PYSTAR,PXEND,PYEND = ',4G15.7)
29892        CALL DPWRST('XXX','BUG ')
29893      ENDIF
29894C
29895      RETURN
29896      END
29897      SUBROUTINE DPPACO(IHARG,NUMARG,IDEFPC,MAXPAT,IPATCO,
29898     1IBUGP2,IFOUND,IERROR)
29899C
29900C     PURPOSE--DEFINE THE PATTERN COLORS.
29901C              THESE ARE LOCATED IN THE VECTOR IPATCO(.).
29902C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
29903C                     --NUMARG
29904C                     --IDEFPC
29905C                     --MAXPAT
29906C                     --IBUGP2 ('ON' OR 'OFF' )
29907C     OUTPUT ARGUMENTS--IPATCO (A CHARACTER VECTOR)
29908C                     --IFOUND ('YES' OR 'NO' )
29909C                     --IERROR ('YES' OR 'NO' )
29910C     WRITTEN BY--JAMES J. FILLIBEN
29911C                 STATISTICAL ENGINEERING DIVISION
29912C                 INFORMATION TECHNOLOGY LABORATORY
29913C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
29914C                 GAITHERSBURG, MD 20899-8980
29915C                 PHONE--301-975-2899
29916C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
29917C           OF THE NATIONAL BUREAU OF STANDARDS.
29918C     LANGUAGE--ANSI FORTRAN (1977)
29919C     VERSION NUMBER--82/7
29920C     ORIGINAL VERSION--DECEMBER  1983.
29921C
29922C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
29923C
29924      CHARACTER*4 IHARG
29925      CHARACTER*4 IDEFPC
29926      CHARACTER*4 IPATCO
29927C
29928      CHARACTER*4 IBUGP2
29929      CHARACTER*4 IFOUND
29930      CHARACTER*4 IERROR
29931C
29932      CHARACTER*4 IHOLD1
29933      CHARACTER*4 IHOLD2
29934C
29935      CHARACTER*4 ISUBN1
29936      CHARACTER*4 ISUBN2
29937      CHARACTER*4 ISTEPN
29938C
29939      DIMENSION IHARG(*)
29940      DIMENSION IPATCO(*)
29941C
29942C---------------------------------------------------------------------
29943C
29944      INCLUDE 'DPCOP2.INC'
29945C
29946C-----START POINT-----------------------------------------------------
29947C
29948      IFOUND='NO'
29949      IERROR='NO'
29950      ISUBN1='DPPA'
29951      ISUBN2='CO  '
29952C
29953      NUMPAT=0
29954      IHOLD1='-999'
29955      IHOLD2='-999'
29956C
29957      IF(IBUGP2.EQ.'OFF')GOTO90
29958      WRITE(ICOUT,999)
29959  999 FORMAT(1X)
29960      CALL DPWRST('XXX','BUG ')
29961      WRITE(ICOUT,51)
29962   51 FORMAT('***** AT THE BEGINNING OF DPPACO--')
29963      CALL DPWRST('XXX','BUG ')
29964      WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR
29965   52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
29966      CALL DPWRST('XXX','BUG ')
29967      WRITE(ICOUT,53)MAXPAT,NUMPAT
29968   53 FORMAT('MAXPAT,NUMPAT = ',I8,I8)
29969      CALL DPWRST('XXX','BUG ')
29970      WRITE(ICOUT,54)IHOLD1,IHOLD2
29971   54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
29972      CALL DPWRST('XXX','BUG ')
29973      WRITE(ICOUT,55)IDEFPC
29974   55 FORMAT('IDEFPC = ',A4)
29975      CALL DPWRST('XXX','BUG ')
29976      WRITE(ICOUT,60)NUMARG
29977   60 FORMAT('NUMARG = ',I8)
29978      CALL DPWRST('XXX','BUG ')
29979      DO65I=1,NUMARG
29980      WRITE(ICOUT,66)IHARG(I)
29981   66 FORMAT('IHARG(I) = ',A4)
29982      CALL DPWRST('XXX','BUG ')
29983   65 CONTINUE
29984      WRITE(ICOUT,70)IPATCO(1)
29985   70 FORMAT('IPATCO(1) = ',A4)
29986      CALL DPWRST('XXX','BUG ')
29987      DO75I=1,10
29988      WRITE(ICOUT,76)I,IPATCO(I)
29989   76 FORMAT('I,IPATCO(I) = ',I8,2X,A4)
29990      CALL DPWRST('XXX','BUG ')
29991   75 CONTINUE
29992   90 CONTINUE
29993C
29994C               **************************************
29995C               **  STEP 1--                        **
29996C               **  BRANCH TO THE APPROPRIATE CASE  **
29997C               **************************************
29998C
29999      ISTEPN='1'
30000      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30001C
30002      IF(NUMARG.LE.0)GOTO9000
30003      IF(NUMARG.EQ.1)GOTO1110
30004      IF(NUMARG.EQ.2)GOTO1120
30005      IF(NUMARG.EQ.3)GOTO1130
30006      GOTO1140
30007C
30008 1110 CONTINUE
30009      GOTO1200
30010C
30011 1120 CONTINUE
30012      IF(IHARG(2).EQ.'ALL')IHOLD1=IDEFPC
30013      IF(IHARG(2).EQ.'ALL')GOTO1300
30014      GOTO1200
30015C
30016 1130 CONTINUE
30017      IF(IHARG(2).EQ.'ALL')IHOLD1=IHARG(3)
30018      IF(IHARG(2).EQ.'ALL')GOTO1300
30019      IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(2)
30020      IF(IHARG(3).EQ.'ALL')GOTO1300
30021      GOTO1200
30022C
30023 1140 CONTINUE
30024      GOTO1200
30025C
30026C               *************************************************
30027C               **  STEP 2--                                   **
30028C               **  TREAT THE INDIVIDUAL SPECIFICATIONS CASE  **
30029C               *************************************************
30030C
30031 1200 CONTINUE
30032      ISTEPN='2'
30033      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30034C
30035      IF(NUMARG.LE.1)GOTO1210
30036      GOTO1220
30037C
30038 1210 CONTINUE
30039      NUMPAT=1
30040      IPATCO(1)=IDEFPC
30041      GOTO1270
30042C
30043 1220 CONTINUE
30044      NUMPAT=NUMARG-1
30045      IF(NUMPAT.GT.MAXPAT)NUMPAT=MAXPAT
30046      DO1225I=1,NUMPAT
30047      J=I+1
30048      IHOLD1=IHARG(J)
30049      IHOLD2=IHOLD1
30050      IF(IHOLD1.EQ.'ON')IHOLD2=IDEFPC
30051      IF(IHOLD1.EQ.'OFF')IHOLD2=IDEFPC
30052      IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEFPC
30053      IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEFPC
30054      IPATCO(I)=IHOLD2
30055 1225 CONTINUE
30056      GOTO1270
30057C
30058 1270 CONTINUE
30059      IF(IFEEDB.EQ.'OFF')GOTO1279
30060      WRITE(ICOUT,999)
30061      CALL DPWRST('XXX','BUG ')
30062      DO1278I=1,NUMPAT
30063      WRITE(ICOUT,1276)I,IPATCO(I)
30064 1276 FORMAT('PATTERN COLOR ',I6,' HAS JUST BEEN SET TO ',
30065     1A4)
30066      CALL DPWRST('XXX','BUG ')
30067 1278 CONTINUE
30068 1279 CONTINUE
30069      IFOUND='YES'
30070      GOTO9000
30071C
30072C               **************************
30073C               **  STEP 2--            **
30074C               **  TREAT THE ALL CASE  **
30075C               **************************
30076C
30077 1300 CONTINUE
30078      ISTEPN='3'
30079      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30080C
30081      NUMPAT=MAXPAT
30082      IHOLD2=IHOLD1
30083      IF(IHOLD1.EQ.'ON')IHOLD2=IDEFPC
30084      IF(IHOLD1.EQ.'OFF')IHOLD2=IDEFPC
30085      IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEFPC
30086      IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEFPC
30087      DO1315I=1,NUMPAT
30088      IPATCO(I)=IHOLD2
30089 1315 CONTINUE
30090      GOTO1370
30091C
30092 1370 CONTINUE
30093      IF(IFEEDB.EQ.'OFF')GOTO1319
30094      WRITE(ICOUT,999)
30095      CALL DPWRST('XXX','BUG ')
30096      I=1
30097      WRITE(ICOUT,1316)IPATCO(I)
30098 1316 FORMAT('ALL PATTERN COLORS HAVE JUST BEEN SET TO ',
30099     1A4)
30100      CALL DPWRST('XXX','BUG ')
30101 1319 CONTINUE
30102      IFOUND='YES'
30103      GOTO9000
30104C
30105C               *****************
30106C               **  STEP 90--  **
30107C               **  EXIT       **
30108C               *****************
30109C
30110 9000 CONTINUE
30111      IF(IBUGP2.EQ.'OFF')GOTO9090
30112      WRITE(ICOUT,9011)
30113 9011 FORMAT('***** AT THE END       OF DPPACO--')
30114      CALL DPWRST('XXX','BUG ')
30115      WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR
30116 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
30117      CALL DPWRST('XXX','BUG ')
30118      WRITE(ICOUT,9013)MAXPAT,NUMPAT
30119 9013 FORMAT('MAXPAT,NUMPAT = ',I8,I8)
30120      CALL DPWRST('XXX','BUG ')
30121      WRITE(ICOUT,9014)IHOLD1,IHOLD2
30122 9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
30123      CALL DPWRST('XXX','BUG ')
30124      WRITE(ICOUT,9015)IDEFPC
30125 9015 FORMAT('IDEFPC = ',A4)
30126      CALL DPWRST('XXX','BUG ')
30127      WRITE(ICOUT,9020)NUMARG
30128 9020 FORMAT('NUMARG = ',I8)
30129      CALL DPWRST('XXX','BUG ')
30130      DO9025I=1,NUMARG
30131      WRITE(ICOUT,9026)IHARG(I)
30132 9026 FORMAT('IHARG(I) = ',A4)
30133      CALL DPWRST('XXX','BUG ')
30134 9025 CONTINUE
30135      WRITE(ICOUT,9030)IPATCO(1)
30136 9030 FORMAT('IPATCO(1) = ',A4)
30137      CALL DPWRST('XXX','BUG ')
30138      DO9035I=1,10
30139      WRITE(ICOUT,9036)I,IPATCO(I)
30140 9036 FORMAT('I,IPATCO(I) = ',I8,2X,A4)
30141      CALL DPWRST('XXX','BUG ')
30142 9035 CONTINUE
30143 9090 CONTINUE
30144C
30145      RETURN
30146      END
30147      SUBROUTINE DPPAGE(TEMP1,TEMP2,MAXNXT,
30148     1                  ICAPSW,IFORSW,IMULT,
30149     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
30150C
30151C     PURPOSE--CARRY OUT PAGE TEST NON-PARAMETRIC TWO-WAY ANOVA
30152C              (ORDERED CASE)
30153C     EXAMPLE--PAGE TEST Y X1 X2
30154C     REFERENCE--CONOVER (1999), "PRACTICAL NONPARAMETRIC STATISTICS",
30155C                THIRD EDITION, WILEY, PP. 380-381.
30156C     WRITTEN BY--ALAN HECKERT
30157C                 STATISTICAL ENGINEERING DIVISION
30158C                 INFORMATION TECHNOLOGY LABORATORY
30159C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
30160C                 GAITHERSBURG, MD 20899-8980
30161C                 PHONE--301-975-2899
30162C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
30163C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
30164C     LANGUAGE--ANSI FORTRAN (1977)
30165C     VERSION NUMBER--2013/02
30166C     ORIGINAL VERSION--FEBRUARY  2013.
30167C
30168C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
30169C
30170      CHARACTER*4 ICAPSW
30171      CHARACTER*4 IFORSW
30172      CHARACTER*4 IMULT
30173      CHARACTER*4 IBUGA2
30174      CHARACTER*4 IBUGA3
30175      CHARACTER*4 IBUGQ
30176      CHARACTER*4 ISUBRO
30177      CHARACTER*4 IFOUND
30178      CHARACTER*4 IERROR
30179C
30180      CHARACTER*4 ISUBN1
30181      CHARACTER*4 ISUBN2
30182      CHARACTER*4 ISTEPN
30183C
30184      LOGICAL IFRST
30185      LOGICAL ILAST
30186      CHARACTER*4 IFLAGU
30187      CHARACTER*4 ICASE
30188      CHARACTER*40 INAME
30189      PARAMETER (MAXSPN=30)
30190      CHARACTER*4 IVARN1(MAXSPN)
30191      CHARACTER*4 IVARN2(MAXSPN)
30192      CHARACTER*4 IVARTY(MAXSPN)
30193      REAL PVAR(MAXSPN)
30194      INTEGER ILIS(MAXSPN)
30195      INTEGER NRIGHT(MAXSPN)
30196      INTEGER ICOLR(MAXSPN)
30197C
30198C---------------------------------------------------------------------
30199C
30200      DIMENSION TEMP1(*)
30201      DIMENSION TEMP2(*)
30202C
30203C-----COMMON----------------------------------------------------------
30204C
30205      INCLUDE 'DPCOPA.INC'
30206      INCLUDE 'DPCOZZ.INC'
30207      INCLUDE 'DPCOZD.INC'
30208C
30209      DIMENSION XTEMP2(MAXOBV)
30210      DIMENSION DBLOCK(MAXOBV)
30211      DIMENSION DTREAT(MAXOBV)
30212      DIMENSION RJ(MAXOBV)
30213      DOUBLE PRECISION YRANK(MAXOBV)
30214C
30215      EQUIVALENCE(GARBAG(IGARB1),XTEMP2(1))
30216      EQUIVALENCE(GARBAG(IGARB2),DBLOCK(1))
30217      EQUIVALENCE(GARBAG(IGARB3),DTREAT(1))
30218      EQUIVALENCE(GARBAG(IGARB4),RJ(1))
30219      EQUIVALENCE(DGARBG(IDGAR1),YRANK(1))
30220C
30221C-----COMMON VARIABLES (GENERAL)--------------------------------------
30222C
30223      INCLUDE 'DPCOHK.INC'
30224      INCLUDE 'DPCOSU.INC'
30225      INCLUDE 'DPCODA.INC'
30226      INCLUDE 'DPCOP2.INC'
30227C
30228C-----START POINT-----------------------------------------------------
30229C
30230      ISUBN1='DPPA'
30231      ISUBN2='GE  '
30232      IFOUND='YES'
30233      IERROR='NO'
30234C
30235      MAXCP1=MAXCOL+1
30236      MAXCP2=MAXCOL+2
30237      MAXCP3=MAXCOL+3
30238      MAXCP4=MAXCOL+4
30239      MAXCP5=MAXCOL+5
30240      MAXCP6=MAXCOL+6
30241C
30242C               ******************************************
30243C               **  TREAT THE PAGE     TEST CASE        **
30244C               ******************************************
30245C
30246      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PAGE')THEN
30247        WRITE(ICOUT,999)
30248  999   FORMAT(1X)
30249        CALL DPWRST('XXX','BUG ')
30250        WRITE(ICOUT,51)
30251   51   FORMAT('***** AT THE BEGINNING OF DPPAGE--')
30252        CALL DPWRST('XXX','BUG ')
30253        WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ,ISUBRO,MAXNXT
30254   52   FORMAT('IBUGA2,IBUGA3,IBUBQ,ISUBRO,MAXNXT = ',4(A4,2X),I8)
30255        CALL DPWRST('XXX','BUG ')
30256        WRITE(ICOUT,53)ICAPSW,ICAPTY,IFORSW
30257   53   FORMAT('ICAPSW,ICAPTY,IFORSW = ',2(A4,2X),A4)
30258        CALL DPWRST('XXX','BUG ')
30259      ENDIF
30260C
30261C               *********************************
30262C               **  STEP 1--                   **
30263C               **  EXTRACT THE VARIABLE LIST  **
30264C               *********************************
30265C
30266      ISTEPN='1'
30267      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PAGE')
30268     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30269C
30270      IMULT='OFF'
30271      INAME='PAGE TEST'
30272      MAXNA=100
30273      MINNVA=1
30274      MAXNVA=MAXSPN
30275      MINNA=1
30276      IFLAGE=1
30277      IFLAGM=0
30278      IF(IMULT.EQ.'ON')THEN
30279        IFLAGM=0
30280      ENDIF
30281      MINN2=2
30282      IFLAGP=0
30283      JMIN=1
30284      JMAX=NUMARG
30285C
30286      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
30287     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
30288     1            JMIN,JMAX,
30289     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
30290     1            IVARN1,IVARN2,IVARTY,PVAR,
30291     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
30292     1            MINNVA,MAXNVA,
30293     1            IFLAGM,IFLAGP,
30294     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
30295      IF(IERROR.EQ.'YES')GOTO9000
30296C
30297      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PAGE')THEN
30298        WRITE(ICOUT,999)
30299        CALL DPWRST('XXX','BUG ')
30300        WRITE(ICOUT,181)
30301  181   FORMAT('***** AFTER CALL DPPARS--')
30302        CALL DPWRST('XXX','BUG ')
30303        WRITE(ICOUT,182)NQ,NUMVAR,IMULT
30304  182   FORMAT('NQ,NUMVAR,IMULT = ',2I8,2X,A4)
30305        CALL DPWRST('XXX','BUG ')
30306        IF(NUMVAR.GT.0)THEN
30307          DO185I=1,NUMVAR
30308            WRITE(ICOUT,187)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
30309     1                      ICOLR(I)
30310  187       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
30311     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
30312            CALL DPWRST('XXX','BUG ')
30313  185     CONTINUE
30314        ENDIF
30315      ENDIF
30316C
30317C               **********************************
30318C               **  STEP 3--                    **
30319C               **  CARRY OUT THE PAGE     TEST **
30320C               **********************************
30321C
30322      ISTEPN='3'
30323      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PAGE')
30324     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30325C
30326C               *****************************************
30327C               **  STEP 3A--                          **
30328C               **  CASE 1: THREE RESPONSE VARIABLES   **
30329C               **          NO MATRIX, NO MULTIPLE     **
30330C               *****************************************
30331C
30332      IF(IMULT.EQ.'OFF')THEN
30333        ISTEPN='3A'
30334        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PAGE')
30335     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30336C
30337        ICOL=1
30338        NUMVA2=3
30339        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
30340     1              INAME,IVARN1,IVARN2,IVARTY,
30341     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
30342     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
30343     1              MAXCP4,MAXCP5,MAXCP6,
30344     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
30345     1              Y,X,XTEMP2,NS1,NS1,NS1,ICASE,
30346     1              IBUGA3,ISUBRO,IFOUND,IERROR)
30347        IF(IERROR.EQ.'YES')GOTO9000
30348C
30349        IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'PAGE')THEN
30350          WRITE(ICOUT,999)
30351          CALL DPWRST('XXX','BUG ')
30352          WRITE(ICOUT,5211)
30353 5211     FORMAT('***** FROM DPPAGE, AS WE ARE ABOUT TO CALL DPPAG2--')
30354          CALL DPWRST('XXX','BUG ')
30355          WRITE(ICOUT,5212)NS1
30356 5212     FORMAT('NS1 = ',I8)
30357          CALL DPWRST('XXX','BUG ')
30358          DO5215I=1,NS1
30359            WRITE(ICOUT,5216)I,Y(I),X(I),XTEMP2(I)
30360 5216       FORMAT('I,Y(I),X(I),XTEMP2(I) = ',I8,3G15.7)
30361            CALL DPWRST('XXX','BUG ')
30362 5215     CONTINUE
30363        ENDIF
30364C
30365        CALL DPPAG2(Y,X,XTEMP2,NS1,IVARN1,IVARN2,
30366     1              DBLOCK,DTREAT,YRANK,RJ,
30367     1              TEMP1,TEMP2,MAXNXT,
30368     1              STATVA,STATV2,STATCD,PVAL,
30369     1              CUT50,CUT75,CUT90,CUT95,CUT99,CUT999,
30370     1              ICAPSW,ICAPTY,IFORSW,IMULT,
30371     1              IBUGA3,ISUBRO,IERROR)
30372C
30373C               ***************************************
30374C               **  STEP 61--                        **
30375C               **  UPDATE INTERNAL DATAPLOT TABLES  **
30376C               ***************************************
30377C
30378        ISTEPN='61'
30379        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PAGE')
30380     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30381C
30382        IFLAGU='ON'
30383        IFRST=.TRUE.
30384        ILAST=.TRUE.
30385        CALL DPPAG5(STATVA,STATCD,PVAL,
30386     1              CUT0,CUT50,CUT75,CUT90,CUT95,
30387     1              CUT975,CUT99,CUT999,
30388     1              IFLAGU,IFRST,ILAST,
30389     1              IBUGA2,IBUGA3,ISUBRO,IERROR)
30390      ENDIF
30391C
30392C               *****************
30393C               **  STEP 90--  **
30394C               **  EXIT       **
30395C               *****************
30396C
30397 9000 CONTINUE
30398      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'PAGE')THEN
30399        WRITE(ICOUT,999)
30400        CALL DPWRST('XXX','BUG ')
30401        WRITE(ICOUT,9011)
30402 9011   FORMAT('***** AT THE END       OF DPPAGE--')
30403        CALL DPWRST('XXX','BUG ')
30404        WRITE(ICOUT,9016)IFOUND,IERROR,STATVA,STATCD
30405 9016   FORMAT('IFOUND,IERROR,STATVA,STATCD = ',2(A4,2X),2G15.7)
30406        CALL DPWRST('XXX','BUG ')
30407      ENDIF
30408C
30409      RETURN
30410      END
30411      SUBROUTINE DPPAG2(Y,BLOCK,TREAT,N,IVARID,IVARI2,
30412     1                  DBLOCK,DTREAT,YRANK,RJ,
30413     1                  TEMP1,TEMP2,MAXNXT,
30414     1                  STATVA,STATV2,STATCD,PVAL,
30415     1                  CUT50,CUT75,CUT90,CUT95,CUT99,CUT999,
30416     1                  ICAPSW,ICAPTY,IFORSW,IMULT,
30417     1                  IBUGA3,ISUBRO,IERROR)
30418C
30419C     PURPOSE--THIS ROUTINE CARRIES OUT PAGE'S NON-PARAMETRIC TEST
30420C              FOR TWO-WAY COMPLETE RANDOMIZED BLOCK DESIGNS WHERE
30421C              ORDER IS SIGNIFICANT.
30422C     EXAMPLE--FRIEDMAN TEST Y BLOCK TREAT
30423C     REFERENCE--CONOVER (1999), "PRACTICAL NONPARAMETRIC STATISTICS",
30424C                THIRD EDITION, WILEY, PP. 380-381.
30425C     WRITTEN BY--ALAN HECKERT
30426C                 STATISTICAL ENGINEERING DIVISION
30427C                 INFORMATION TECHNOLOGY LABORATORY
30428C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
30429C                 GAITHERSBURG, MD 20899-8980
30430C                 PHONE--301-975-2899
30431C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
30432C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
30433C     LANGUAGE--ANSI FORTRAN (1977)
30434C     VERSION NUMBER--2013/02
30435C     ORIGINAL VERSION--FEBRUARY  2013.
30436C
30437C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
30438C
30439      CHARACTER*4 ICAPSW
30440      CHARACTER*4 ICAPTY
30441      CHARACTER*4 IFORSW
30442      CHARACTER*4 IMULT
30443      CHARACTER*4 IBUGA3
30444      CHARACTER*4 ISUBRO
30445      CHARACTER*4 IERROR
30446      CHARACTER*4 IVARID(*)
30447      CHARACTER*4 IVARI2(*)
30448C
30449      CHARACTER*4 IWRITE
30450      CHARACTER*4 ISUBN1
30451      CHARACTER*4 ISUBN2
30452      CHARACTER*4 ISTEPN
30453C
30454C---------------------------------------------------------------------
30455C
30456      DIMENSION Y(*)
30457      DIMENSION BLOCK(*)
30458      DIMENSION TREAT(*)
30459      DIMENSION RJ(*)
30460      DIMENSION DBLOCK(*)
30461      DIMENSION DTREAT(*)
30462      DIMENSION TEMP1(*)
30463      DIMENSION TEMP2(*)
30464C
30465      DOUBLE PRECISION YRANK(*)
30466C
30467      PARAMETER (NUMALP=7)
30468      REAL ALPHA(NUMALP)
30469C
30470      PARAMETER(NUMCLI=6)
30471      PARAMETER(MAXLIN=2)
30472      PARAMETER (MAXROW=50)
30473      CHARACTER*60 ITITLE
30474      CHARACTER*60 ITITLZ
30475      CHARACTER*1  ITITL9
30476      CHARACTER*60 ITEXT(MAXROW)
30477      CHARACTER*4  ALIGN(NUMCLI)
30478      CHARACTER*4  VALIGN(NUMCLI)
30479      REAL         AVALUE(MAXROW)
30480      INTEGER      NCTEXT(MAXROW)
30481      INTEGER      IDIGIT(MAXROW)
30482      INTEGER      NTOT(MAXROW)
30483      CHARACTER*60 ITITL2(MAXLIN,NUMCLI)
30484      CHARACTER*15 IVALUE(MAXROW,NUMCLI)
30485      CHARACTER*4  ITYPCO(NUMCLI)
30486      INTEGER      NCTIT2(MAXLIN,NUMCLI)
30487      INTEGER      NCVALU(MAXROW,NUMCLI)
30488      INTEGER      IWHTML(NUMCLI)
30489      INTEGER      IWRTF(NUMCLI)
30490      REAL         AMAT(MAXROW,NUMCLI)
30491      LOGICAL IFRST
30492      LOGICAL ILAST
30493C
30494C---------------------------------------------------------------------
30495C
30496      INCLUDE 'DPCOP2.INC'
30497C
30498C-----START POINT-----------------------------------------------------
30499C
30500      DATA ALPHA/
30501     1 50.0, 75.0, 90.0, 95.0, 97.5, 99.0, 99.9/
30502C
30503      ISUBN1='DPPA'
30504      ISUBN2='G2  '
30505      IERROR='NO'
30506      IWRITE='OFF'
30507C
30508      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PAG2')THEN
30509        WRITE(ICOUT,999)
30510  999   FORMAT(1X)
30511        CALL DPWRST('XXX','WRIT')
30512        WRITE(ICOUT,51)
30513   51   FORMAT('**** AT THE BEGINNING OF DPPAG2--')
30514        CALL DPWRST('XXX','WRIT')
30515        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
30516   52   FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8)
30517        CALL DPWRST('XXX','WRIT')
30518        DO56I=1,N
30519          WRITE(ICOUT,57)I,Y(I),BLOCK(I),TREAT(I)
30520   57     FORMAT('I,Y(I),BLOCK(I),TREAT(I) = ',I8,3G15.7)
30521          CALL DPWRST('XXX','WRIT')
30522   56   CONTINUE
30523      ENDIF
30524C
30525      MAXNX2=MAXNXT
30526      CALL DPPAG3(Y,BLOCK,TREAT,N,
30527     1            DBLOCK,DTREAT,RJ,TEMP1,TEMP2,YRANK,
30528     1            MAXNXT,MAXNX2,
30529     1            STATVA,STATV2,STATCD,PVAL,
30530     1            NBLOCK,NTREAT,
30531     1            IBUGA3,ISUBRO,IERROR)
30532      IF(IERROR.EQ.'YES')GOTO9000
30533C
30534      CALL NORPPF(.50,CUT50)
30535      CALL NORPPF(.75,CUT75)
30536      CALL NORPPF(.90,CUT90)
30537      CALL NORPPF(.95,CUT95)
30538      CALL NORPPF(.975,CUT975)
30539      CALL NORPPF(.99,CUT99)
30540      CALL NORPPF(.999,CUT999)
30541C
30542      ANB=REAL(NBLOCK)
30543      AK=REAL(NTREAT)
30544C
30545C               *****************************
30546C               **   STEP 42-              **
30547C               **   WRITE OUT THE TABLE   **
30548C               *****************************
30549C
30550      ISTEPN='42'
30551      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PAG2')
30552     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30553C
30554C               ******************************
30555C               **   STEP 43--              **
30556C               **   WRITE OUT EVERYTHING   **
30557C               **   FOR FRIEDMAN TEST      **
30558C               ******************************
30559C
30560      ISTEPN='43'
30561      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PAG2')
30562     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30563C
30564      IF(IPRINT.EQ.'OFF')GOTO9000
30565C
30566      NUMDIG=7
30567      IF(IFORSW.EQ.'1')NUMDIG=1
30568      IF(IFORSW.EQ.'2')NUMDIG=2
30569      IF(IFORSW.EQ.'3')NUMDIG=3
30570      IF(IFORSW.EQ.'4')NUMDIG=4
30571      IF(IFORSW.EQ.'5')NUMDIG=5
30572      IF(IFORSW.EQ.'6')NUMDIG=6
30573      IF(IFORSW.EQ.'7')NUMDIG=7
30574      IF(IFORSW.EQ.'8')NUMDIG=8
30575      IF(IFORSW.EQ.'9')NUMDIG=9
30576      IF(IFORSW.EQ.'0')NUMDIG=0
30577      IF(IFORSW.EQ.'E')NUMDIG=-2
30578      IF(IFORSW.EQ.'-2')NUMDIG=-2
30579      IF(IFORSW.EQ.'-3')NUMDIG=-3
30580      IF(IFORSW.EQ.'-4')NUMDIG=-4
30581      IF(IFORSW.EQ.'-5')NUMDIG=-5
30582      IF(IFORSW.EQ.'-6')NUMDIG=-6
30583      IF(IFORSW.EQ.'-7')NUMDIG=-7
30584      IF(IFORSW.EQ.'-8')NUMDIG=-8
30585      IF(IFORSW.EQ.'-9')NUMDIG=-9
30586C
30587      ITITLE='Page Two Factor Test'
30588      NCTITL=24
30589      ITITLZ=' '
30590      NCTITZ=0
30591C
30592      ICNT=1
30593      ITEXT(ICNT)=' '
30594      NCTEXT(ICNT)=0
30595      AVALUE(ICNT)=0.0
30596      IDIGIT(ICNT)=-1
30597      ICNT=ICNT+1
30598      ITEXT(ICNT)='Response Variable: '
30599      WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1)(1:4)
30600      WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1)(1:4)
30601      NCTEXT(ICNT)=27
30602      AVALUE(ICNT)=0.0
30603      IDIGIT(ICNT)=-1
30604C
30605      IF(IMULT.EQ.'OFF')THEN
30606C
30607        ICNT=ICNT+1
30608        ITEXT(ICNT)='Group-ID Variable (Block): '
30609        WRITE(ITEXT(ICNT)(28:31),'(A4)')IVARID(2)(1:4)
30610        WRITE(ITEXT(ICNT)(32:35),'(A4)')IVARI2(2)(1:4)
30611        NCTEXT(ICNT)=35
30612        AVALUE(ICNT)=0.0
30613        IDIGIT(ICNT)=-1
30614C
30615        ICNT=ICNT+1
30616        ITEXT(ICNT)='Group-ID Variable (Treatment): '
30617        WRITE(ITEXT(ICNT)(32:35),'(A4)')IVARID(3)(1:4)
30618        WRITE(ITEXT(ICNT)(36:39),'(A4)')IVARI2(3)(1:4)
30619        NCTEXT(ICNT)=39
30620        AVALUE(ICNT)=0.0
30621        IDIGIT(ICNT)=-1
30622C
30623      ELSE
30624      ENDIF
30625C
30626      ICNT=ICNT+1
30627      ITEXT(ICNT)=' '
30628      NCTEXT(ICNT)=1
30629      AVALUE(ICNT)=0.0
30630      IDIGIT(ICNT)=-1
30631C
30632      ICNT=ICNT+1
30633      ITEXT(ICNT)='H0: u1 = u2 = ... = uk'
30634      NCTEXT(ICNT)=22
30635      AVALUE(ICNT)=0.0
30636      IDIGIT(ICNT)=-1
30637      ICNT=ICNT+1
30638      ITEXT(ICNT)='Ha: u1 <= u2 <= ... <= uk'
30639      NCTEXT(ICNT)=25
30640      AVALUE(ICNT)=0.0
30641      IDIGIT(ICNT)=-1
30642C
30643      ICNT=ICNT+1
30644      ITEXT(ICNT)=' '
30645      NCTEXT(ICNT)=1
30646      AVALUE(ICNT)=0.0
30647      IDIGIT(ICNT)=-1
30648C
30649      ICNT=ICNT+1
30650      ITEXT(ICNT)='Summary Statistics:'
30651      NCTEXT(ICNT)=19
30652      AVALUE(ICNT)=0.0
30653      IDIGIT(ICNT)=-1
30654      ICNT=ICNT+1
30655      ITEXT(ICNT)='Total Number of Observations:'
30656      NCTEXT(ICNT)=29
30657      AVALUE(ICNT)=REAL(N)
30658      IDIGIT(ICNT)=0
30659      ICNT=ICNT+1
30660      ITEXT(ICNT)='Number of Blocks:'
30661      NCTEXT(ICNT)=17
30662      AVALUE(ICNT)=REAL(NBLOCK)
30663      IDIGIT(ICNT)=0
30664      ICNT=ICNT+1
30665      ITEXT(ICNT)='Number of Treatments:'
30666      NCTEXT(ICNT)=21
30667      AVALUE(ICNT)=REAL(NTREAT)
30668      IDIGIT(ICNT)=0
30669      ICNT=ICNT+1
30670      ITEXT(ICNT)=' '
30671      NCTEXT(ICNT)=1
30672      AVALUE(ICNT)=0.0
30673      IDIGIT(ICNT)=-1
30674C
30675      ICNT=ICNT+1
30676      ITEXT(ICNT)='Test:'
30677      NCTEXT(ICNT)=5
30678      AVALUE(ICNT)=0.0
30679      IDIGIT(ICNT)=-1
30680      ICNT=ICNT+1
30681      ITEXT(ICNT)='Page Test Statistic:'
30682      NCTEXT(ICNT)=20
30683      AVALUE(ICNT)=STATVA
30684      IDIGIT(ICNT)=NUMDIG
30685      ICNT=ICNT+1
30686      ITEXT(ICNT)='Page Normalized Test Statistic:'
30687      NCTEXT(ICNT)=31
30688      AVALUE(ICNT)=STATV2
30689      IDIGIT(ICNT)=NUMDIG
30690      ICNT=ICNT+1
30691      ITEXT(ICNT)='CDF of Test Statistic:'
30692      NCTEXT(ICNT)=22
30693      AVALUE(ICNT)=STATCD
30694      IDIGIT(ICNT)=NUMDIG
30695      ICNT=ICNT+1
30696      ITEXT(ICNT)='P-Value:'
30697      NCTEXT(ICNT)=8
30698      AVALUE(ICNT)=PVAL
30699      IDIGIT(ICNT)=NUMDIG
30700C
30701      NUMROW=ICNT
30702      DO4210I=1,NUMROW
30703        NTOT(I)=15
30704 4210 CONTINUE
30705C
30706      IFRST=.TRUE.
30707      ILAST=.TRUE.
30708C
30709      ISTEPN='42A'
30710      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PAG2')
30711     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30712C
30713      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
30714     1            AVALUE,IDIGIT,
30715     1            NTOT,NUMROW,
30716     1            ICAPSW,ICAPTY,ILAST,IFRST,
30717     1            ISUBRO,IBUGA3,IERROR)
30718C
30719      ITITLE=' '
30720      NCTITL=0
30721      ITITL9=' '
30722      NCTIT9=0
30723      ITITLE='Percent Points of the Normal Reference Distribution'
30724      NCTITL=51
30725      NUMLIN=1
30726      NUMROW=7
30727      NUMCOL=3
30728      ITITL2(1,1)='Percent Point'
30729      ITITL2(1,2)=' '
30730      ITITL2(1,3)='Value'
30731      NCTIT2(1,1)=13
30732      NCTIT2(1,2)=1
30733      NCTIT2(1,3)=5
30734C
30735      NMAX=0
30736      DO4221I=1,NUMCOL
30737        VALIGN(I)='b'
30738        ALIGN(I)='r'
30739        NTOT(I)=15
30740        IF(I.EQ.2)NTOT(I)=5
30741        NMAX=NMAX+NTOT(I)
30742        IDIGIT(I)=NUMDIG
30743        ITYPCO(I)='NUME'
30744 4221 CONTINUE
30745      ITYPCO(2)='ALPH'
30746      IDIGIT(1)=1
30747      IDIGIT(3)=3
30748      DO4223I=1,NUMROW
30749        DO4225J=1,NUMCOL
30750          NCVALU(I,J)=0
30751          IVALUE(I,J)=' '
30752          NCVALU(I,J)=0
30753          AMAT(I,J)=0.0
30754          IF(J.EQ.1)THEN
30755            AMAT(I,J)=ALPHA(I)
30756          ELSEIF(J.EQ.2)THEN
30757            IVALUE(I,J)='='
30758            NCVALU(I,J)=1
30759          ELSEIF(J.EQ.3)THEN
30760            IF(I.EQ.1)THEN
30761              AMAT(I,J)=RND(CUT50,IDIGIT(J))
30762            ELSEIF(I.EQ.2)THEN
30763              AMAT(I,J)=RND(CUT75,IDIGIT(J))
30764            ELSEIF(I.EQ.3)THEN
30765              AMAT(I,J)=RND(CUT90,IDIGIT(J))
30766            ELSEIF(I.EQ.4)THEN
30767              AMAT(I,J)=RND(CUT95,IDIGIT(J))
30768            ELSEIF(I.EQ.5)THEN
30769              AMAT(I,J)=RND(CUT975,IDIGIT(J))
30770            ELSEIF(I.EQ.6)THEN
30771              AMAT(I,J)=RND(CUT99,IDIGIT(J))
30772            ELSEIF(I.EQ.7)THEN
30773              AMAT(I,J)=RND(CUT999,IDIGIT(J))
30774            ENDIF
30775          ENDIF
30776 4225   CONTINUE
30777 4223 CONTINUE
30778C
30779      IWHTML(1)=150
30780      IWHTML(2)=50
30781      IWHTML(3)=150
30782      IWRTF(1)=2000
30783      IWRTF(2)=IWRTF(1)+500
30784      IWRTF(3)=IWRTF(2)+2000
30785      IFRST=.TRUE.
30786      ILAST=.TRUE.
30787C
30788      ISTEPN='42C'
30789      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PAG2')
30790     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30791C
30792      CALL DPDTA4(ITITL9,NCTIT9,
30793     1            ITITLE,NCTITL,ITITL2,NCTIT2,
30794     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
30795     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW,
30796     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
30797     1            ICAPSW,ICAPTY,IFRST,ILAST,
30798     1            ISUBRO,IBUGA3,IERROR)
30799C
30800      CDF1=CUT90
30801      CDF2=CUT95
30802      CDF3=CUT975
30803      CDF4=CUT99
30804C
30805      ITITL9=' '
30806      NCTIT9=0
30807      ITITLE='Conclusions (Upper 1-Tailed Test)'
30808      NCTITL=33
30809      NUMLIN=1
30810      NUMROW=4
30811      NUMCOL=4
30812      ITITL2(1,1)='Alpha'
30813      ITITL2(1,2)='CDF'
30814      ITITL2(1,3)='Critical Value'
30815      ITITL2(1,4)='Conclusion'
30816      NCTIT2(1,1)=5
30817      NCTIT2(1,2)=3
30818      NCTIT2(1,3)=14
30819      NCTIT2(1,4)=10
30820C
30821      NMAX=0
30822      DO4321I=1,NUMCOL
30823        VALIGN(I)='b'
30824        ALIGN(I)='r'
30825        NTOT(I)=15
30826        IF(I.EQ.1 .OR. I.EQ.2)NTOT(I)=7
30827        IF(I.EQ.3)NTOT(I)=17
30828        NMAX=NMAX+NTOT(I)
30829        IDIGIT(I)=3
30830        ITYPCO(I)='ALPH'
30831 4321 CONTINUE
30832      ITYPCO(3)='NUME'
30833      IDIGIT(1)=0
30834      IDIGIT(2)=0
30835      DO4323I=1,NUMROW
30836        DO4325J=1,NUMCOL
30837          NCVALU(I,J)=0
30838          IVALUE(I,J)=' '
30839          NCVALU(I,J)=0
30840          AMAT(I,J)=0.0
30841 4325   CONTINUE
30842 4323 CONTINUE
30843      IVALUE(1,1)='10%'
30844      IVALUE(2,1)='5%'
30845      IVALUE(3,1)='2.5%'
30846      IVALUE(4,1)='1%'
30847      IVALUE(1,2)='90%'
30848      IVALUE(2,2)='95%'
30849      IVALUE(3,2)='97.5%'
30850      IVALUE(4,2)='99%'
30851      NCVALU(1,1)=3
30852      NCVALU(2,1)=2
30853      NCVALU(3,1)=4
30854      NCVALU(4,1)=2
30855      NCVALU(1,2)=3
30856      NCVALU(2,2)=3
30857      NCVALU(3,2)=5
30858      NCVALU(4,2)=3
30859      IVALUE(1,4)='Accept H0'
30860      IVALUE(2,4)='Accept H0'
30861      IVALUE(3,4)='Accept H0'
30862      IVALUE(4,4)='Accept H0'
30863      NCVALU(1,4)=9
30864      NCVALU(2,4)=9
30865      NCVALU(3,4)=9
30866      NCVALU(4,4)=9
30867      IF(STATV2.GT.CUT90)IVALUE(1,4)='Reject H0'
30868      IF(STATV2.GT.CUT95)IVALUE(2,4)='Reject H0'
30869      IF(STATV2.GT.CUT975)IVALUE(3,4)='Reject H0'
30870      IF(STATV2.GT.CUT99)IVALUE(4,4)='Reject H0'
30871      AMAT(1,3)=RND(CUT90,IDIGIT(3))
30872      AMAT(2,3)=RND(CUT95,IDIGIT(3))
30873      AMAT(3,3)=RND(CUT975,IDIGIT(3))
30874      AMAT(4,3)=RND(CUT99,IDIGIT(3))
30875C
30876      IWHTML(1)=150
30877      IWHTML(2)=150
30878      IWHTML(3)=150
30879      IWHTML(4)=150
30880      IWRTF(1)=1500
30881      IWRTF(2)=IWRTF(1)+1500
30882      IWRTF(3)=IWRTF(2)+2000
30883      IWRTF(4)=IWRTF(3)+2000
30884      IFRST=.FALSE.
30885      ILAST=.TRUE.
30886C
30887      ISTEPN='42E'
30888      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'KRU2')
30889     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30890C
30891      CALL DPDTA4(ITITL9,NCTIT9,
30892     1            ITITLE,NCTITL,ITITL2,NCTIT2,
30893     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
30894     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW,
30895     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
30896     1            ICAPSW,ICAPTY,IFRST,ILAST,
30897     1            ISUBRO,IBUGA3,IERROR)
30898C
30899C
30900C               *****************
30901C               **  STEP 90--  **
30902C               **  EXIT       **
30903C               *****************
30904C
30905 9000 CONTINUE
30906      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PAG2')THEN
30907        WRITE(ICOUT,999)
30908        CALL DPWRST('XXX','WRIT')
30909        WRITE(ICOUT,9011)
30910 9011   FORMAT('***** AT THE END       OF DPPAG2--')
30911        CALL DPWRST('XXX','WRIT')
30912        WRITE(ICOUT,9012)STATVA,STATV2,STATCD,PVAL
30913 9012   FORMAT('STATVA,STATV2,STATCD,PVAL = ',4G15.7)
30914        CALL DPWRST('XXX','WRIT')
30915      ENDIF
30916C
30917      RETURN
30918      END
30919      SUBROUTINE DPPAG3(Y,BLOCK,TREAT,N,
30920     1                  DBLOCK,DTREAT,RJ,TEMP1,TEMP2,YRANK,
30921     1                  MAXNXT,MAXNX2,
30922     1                  STATVA,STATV2,STATCD,PVAL,
30923     1                  NBLOCK,NTREAT,
30924     1                  IBUGA3,ISUBRO,IERROR)
30925C
30926C     PURPOSE--THIS ROUTINE CARRIES OUT PAGE'S TEST
30927C              NON-PARAMETRIC TWO-WAY ANOVA FOR ORDERED
30928C              ALTERNATIVES
30929C     EXAMPLE--PAGE TEST Y BLOCK TREAT
30930C     REFERENCE--CONOVER (1999), "PRACTICAL NONPARAMETRIC STATISTICS",
30931C                THIRD EDITION, WILEY, PP. 369-372.
30932C     WRITTEN BY--ALAN HECKERT
30933C                 STATISTICAL ENGINEERING DIVISION
30934C                 INFORMATION TECHNOLOGY LABORATORY
30935C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
30936C                 GAITHERSBURG, MD 20899-8980
30937C                 PHONE--301-975-2899
30938C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
30939C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
30940C     LANGUAGE--ANSI FORTRAN (1977)
30941C     VERSION NUMBER--2012/6
30942C     ORIGINAL VERSION--FEBRUARY  2013
30943C
30944C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
30945C
30946      CHARACTER*4 IBUGA3
30947      CHARACTER*4 ISUBRO
30948      CHARACTER*4 IERROR
30949C
30950      CHARACTER*4 IWRITE
30951      CHARACTER*4 ISUBN1
30952      CHARACTER*4 ISUBN2
30953      CHARACTER*4 ISTEPN
30954C
30955      DOUBLE PRECISION DSUM1
30956      DOUBLE PRECISION DNUM
30957      DOUBLE PRECISION DENOM
30958      DOUBLE PRECISION DK
30959      DOUBLE PRECISION DNB
30960C
30961C---------------------------------------------------------------------
30962C
30963      DIMENSION Y(*)
30964      DIMENSION BLOCK(*)
30965      DIMENSION TREAT(*)
30966      DIMENSION RJ(*)
30967      DIMENSION DBLOCK(*)
30968      DIMENSION DTREAT(*)
30969      DIMENSION TEMP1(*)
30970      DIMENSION TEMP2(*)
30971      DOUBLE PRECISION YRANK(*)
30972C
30973C---------------------------------------------------------------------
30974C
30975      INCLUDE 'DPCOP2.INC'
30976C
30977C-----START POINT-----------------------------------------------------
30978C
30979      ISUBN1='DPFR'
30980      ISUBN2='I3  '
30981      IERROR='NO'
30982      IWRITE='OFF'
30983C
30984      STATVA=CPUMIN
30985      STATV2=CPUMIN
30986      STATCD=CPUMIN
30987      PVAL=CPUMIN
30988C
30989      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PAG3')THEN
30990        WRITE(ICOUT,999)
30991  999   FORMAT(1X)
30992        CALL DPWRST('XXX','WRIT')
30993        WRITE(ICOUT,51)
30994   51   FORMAT('**** AT THE BEGINNING OF DPPAG3--')
30995        CALL DPWRST('XXX','WRIT')
30996        WRITE(ICOUT,52)IBUGA3,ISUBRO,N,MAXNXT
30997   52   FORMAT('IBUGA3,ISUBRO,N,MAXNXT = ',2(A4,2X),2I8)
30998        CALL DPWRST('XXX','WRIT')
30999        DO56I=1,N
31000          WRITE(ICOUT,57)I,Y(I),BLOCK(I),TREAT(I)
31001   57     FORMAT('I,Y(I),BLOCK(I),TREAT(I) = ',I8,3G15.7)
31002          CALL DPWRST('XXX','WRIT')
31003   56   CONTINUE
31004      ENDIF
31005C
31006C               ********************************************
31007C               **  STEP 11--                             **
31008C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
31009C               ********************************************
31010C
31011      ISTEPN='11'
31012      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PAG3')
31013     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31014C
31015      HOLD=Y(1)
31016      DO1135I=2,N
31017      IF(Y(I).NE.HOLD)GOTO1139
31018 1135 CONTINUE
31019      WRITE(ICOUT,999)
31020      CALL DPWRST('XXX','WRIT')
31021      WRITE(ICOUT,1131)
31022 1131 FORMAT('***** ERROR FROM PAGE TEST--')
31023      CALL DPWRST('XXX','WRIT')
31024      WRITE(ICOUT,1133)HOLD
31025 1133 FORMAT('      THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7)
31026      CALL DPWRST('XXX','WRIT')
31027      IERROR='YES'
31028      GOTO9000
31029 1139 CONTINUE
31030C
31031      HOLD=BLOCK(1)
31032      DO1235I=2,N
31033      IF(BLOCK(I).NE.HOLD)GOTO1239
31034 1235 CONTINUE
31035      WRITE(ICOUT,999)
31036      CALL DPWRST('XXX','WRIT')
31037      WRITE(ICOUT,1131)
31038      CALL DPWRST('XXX','WRIT')
31039      WRITE(ICOUT,1231)HOLD
31040 1231 FORMAT('      THE FIRST FACTOR VARIABLE HAS ALL ELEMENTS = ',
31041     1       G15.7)
31042      CALL DPWRST('XXX','WRIT')
31043      IERROR='YES'
31044      GOTO9000
31045 1239 CONTINUE
31046C
31047      HOLD=TREAT(1)
31048      DO1335I=2,N
31049      IF(TREAT(I).NE.HOLD)GOTO1339
31050 1335 CONTINUE
31051      WRITE(ICOUT,999)
31052      CALL DPWRST('XXX','WRIT')
31053      WRITE(ICOUT,1131)
31054      CALL DPWRST('XXX','WRIT')
31055      WRITE(ICOUT,1331)HOLD
31056 1331 FORMAT('      THE SECOND FACTOR VARIABLE HAS ALL ELEMENTS = ',
31057     1       G15.7)
31058      CALL DPWRST('XXX','WRIT')
31059      GOTO9000
31060 1339 CONTINUE
31061C
31062C               ******************************
31063C               **  STEP 2--                **
31064C               **  CARRY OUT CALCULATIONS  **
31065C               **  FOR PAGE TEST           **
31066C               ******************************
31067C
31068      ISTEPN='2'
31069      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PAG3')
31070     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31071C
31072C  STEP 2A: COMPUTE NUMBER OF DISTINCT BLOCKS AND TREATMENTS
31073C
31074      CALL DISTIN(BLOCK,N,IWRITE,DBLOCK,NBLOCK,IBUGA3,IERROR)
31075      IF(IERROR.EQ.'YES')GOTO9000
31076      IF(NBLOCK.GT.MAXNX2)THEN
31077        WRITE(ICOUT,999)
31078        CALL DPWRST('XXX','BUG ')
31079        WRITE(ICOUT,1131)
31080        CALL DPWRST('XXX','BUG ')
31081        WRITE(ICOUT,1232)NBLOCK,MAXNX2
31082 1232     FORMAT('      THE NUMBER OF BLOCKS (',I8,') IS GREATER ',
31083     1           'THAN',I8)
31084          CALL DPWRST('XXX','BUG ')
31085          IERROR='YES'
31086          GOTO9000
31087      ENDIF
31088      CALL DISTIN(TREAT,N,IWRITE,DTREAT,NTREAT,IBUGA3,IERROR)
31089      IF(IERROR.EQ.'YES')GOTO9000
31090      IF(NTREAT.GT.MAXNX2)THEN
31091        WRITE(ICOUT,999)
31092        CALL DPWRST('XXX','BUG ')
31093        WRITE(ICOUT,1131)
31094        CALL DPWRST('XXX','BUG ')
31095        WRITE(ICOUT,1237)NTREAT,MAXNX2
31096 1237   FORMAT('      THE NUMBER OF TREATMENTS (',I8,') IS GREATER ',
31097     1         'THAN ',I8)
31098        CALL DPWRST('XXX','BUG ')
31099        IERROR='YES'
31100        GOTO9000
31101      ENDIF
31102C
31103C           CHECK THAT ALL CELL SIZES EQUAL ONE.
31104C
31105      NTEMP=NBLOCK*NTREAT
31106      IF(NTEMP.NE.N)THEN
31107        WRITE(ICOUT,999)
31108        CALL DPWRST('XXX','BUG ')
31109        WRITE(ICOUT,1131)
31110        CALL DPWRST('XXX','BUG ')
31111        WRITE(ICOUT,1301)
31112 1301   FORMAT('      THE NUMBER OF TREATMENTS TIMES THE NUMBER OF ',
31113     1         'BLOCKS')
31114        WRITE(ICOUT,1303)
31115 1303   FORMAT('      IS NOT EQUAL TO THE NUMBER OF OBSERVATIONS.')
31116        CALL DPWRST('XXX','BUG ')
31117        WRITE(ICOUT,1305)NTREAT
31118 1305   FORMAT('      THE NUMBER OF TREATMENTS    = ',I8)
31119        CALL DPWRST('XXX','BUG ')
31120        WRITE(ICOUT,1306)NBLOCK
31121 1306   FORMAT('      THE NUMBER OF BLOCKS        = ',I8)
31122        CALL DPWRST('XXX','BUG ')
31123        WRITE(ICOUT,1307)N
31124 1307   FORMAT('      THE NUMBER OF OBSERVATIONS  = ',I8)
31125        CALL DPWRST('XXX','BUG ')
31126        IERROR='YES'
31127        GOTO9000
31128      ENDIF
31129C
31130      DO1401I=1,N
31131        TEMP1(I)=0.0
31132 1401 CONTINUE
31133C
31134      DO1420I=1,N
31135        HOLD=Y(I)
31136        DO1430II=1,NBLOCK
31137          HOLD1=DBLOCK(II)
31138          DO1440JJ=1,NTREAT
31139            HOLD2=DTREAT(JJ)
31140            IF(BLOCK(I).EQ.HOLD1 .AND. TREAT(I).EQ.HOLD2)THEN
31141              IINDX=(II-1)*NTREAT + JJ
31142              TEMP1(IINDX)=TEMP1(IINDX) + 1.0
31143              IF(TEMP1(IINDX).GT.1.5)THEN
31144                WRITE(ICOUT,999)
31145                CALL DPWRST('XXX','BUG ')
31146                WRITE(ICOUT,1131)
31147                CALL DPWRST('XXX','BUG ')
31148                WRITE(ICOUT,1441)INT(HOLD1),INT(HOLD2)
31149 1441           FORMAT('      BLOCK ',I6,' TREATMENT ',I6,' HAS MORE ',
31150     1                 'THAN ONE OBSERVATION')
31151                IERROR='YES'
31152                GOTO9000
31153              ENDIF
31154            ENDIF
31155 1440     CONTINUE
31156 1430     CONTINUE
31157 1420     CONTINUE
31158C
31159C  STEP 2B: COMPUTE TREATMENT RANKS WITHIN EACH BLOCK
31160C
31161      ISTEPN='2B'
31162      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PAG3')
31163     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31164C
31165      DO2010I=1,N
31166        YRANK(I)=-1.0D0
31167 2010 CONTINUE
31168C
31169      DO2110I=1,NBLOCK
31170        HOLD=DBLOCK(I)
31171        ICOUNT=0
31172        DO2120J=1,N
31173          IF(BLOCK(J).EQ.HOLD)THEN
31174            ICOUNT=ICOUNT+1
31175            RJ(ICOUNT)=Y(J)
31176          ENDIF
31177 2120   CONTINUE
31178        CALL RANK(RJ,ICOUNT,IWRITE,TEMP1,TEMP2,MAXNX2,
31179     1            IBUGA3,IERROR)
31180        IF(IERROR.EQ.'YES')GOTO9000
31181        ICOUNT=0
31182        DO2130J=1,N
31183          IF(BLOCK(J).EQ.HOLD)THEN
31184            ICOUNT=ICOUNT+1
31185            YRANK(J)=DBLE(TEMP1(ICOUNT))
31186          ENDIF
31187 2130   CONTINUE
31188 2110 CONTINUE
31189C
31190      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PAG3')THEN
31191        DO2140I=1,N
31192          WRITE(ICOUT,2142)I,Y(I),YRANK(I)
31193 2142     FORMAT('I,Y(I),YRANK(I) = ',I8,G15.7,F12.2)
31194          CALL DPWRST('XXX','BUG ')
31195 2140   CONTINUE
31196      ENDIF
31197C
31198C  STEP 2C: NOW COMPUTE RANK SUMS FOR EACH TREATMENT
31199C
31200      ISTEPN='2C'
31201      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PAG3')
31202     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31203C
31204      DO2210I=1,NTREAT
31205        HOLD=DTREAT(I)
31206        DSUM1=0.0D0
31207        DO2220J=1,N
31208          IF(TREAT(J).EQ.HOLD)THEN
31209            DSUM1=DSUM1 + YRANK(J)
31210          ENDIF
31211 2220   CONTINUE
31212        RJ(I)=REAL(DSUM1)
31213 2210 CONTINUE
31214C
31215      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PAG3')THEN
31216        DO2240I=1,NTREAT
31217          WRITE(ICOUT,2242)I,RJ(I)
31218 2242     FORMAT('I,RJ(I) = ',I8,G15.7)
31219          CALL DPWRST('XXX','BUG ')
31220 2240   CONTINUE
31221      ENDIF
31222C
31223C  STEP 4: NOW COMPUTE VARIOUS QUANTITIES BASED ON RJ
31224C
31225      DNB=REAL(NBLOCK)
31226      DK=REAL(NTREAT)
31227      DSUM1=0.0D0
31228      DO2310I=1,NTREAT
31229        DSUM1=DSUM1 + DBLE(I)*DBLE(RJ(I))
31230 2310 CONTINUE
31231      STATVA=REAL(DSUM1)
31232      DNUM=DSUM1 - DNB*DK*(DK+1.0)**2/4.0D0
31233      DENOM=DSQRT(DNB*(DK**3 - DK)**2/(144.0D0*(DK - 1.0D0)))
31234      STATV2=REAL(DNUM/DENOM)
31235C
31236      CALL NORCDF(STATV2,STATCD)
31237      PVAL=1.0 - STATCD
31238C
31239C               *****************
31240C               **  STEP 90--  **
31241C               **  EXIT       **
31242C               *****************
31243C
31244 9000 CONTINUE
31245      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PAG3')THEN
31246        WRITE(ICOUT,999)
31247        CALL DPWRST('XXX','WRIT')
31248        WRITE(ICOUT,9011)
31249 9011   FORMAT('***** AT THE END       OF DPPAG3--')
31250        CALL DPWRST('XXX','WRIT')
31251        WRITE(ICOUT,9012)STATVA,STATV2,STATCD,PVAL
31252 9012   FORMAT('STATVA,STATV2,STATCD,PVAL = ',4G15.7)
31253        CALL DPWRST('XXX','WRIT')
31254      ENDIF
31255C
31256      RETURN
31257      END
31258      SUBROUTINE DPPAG5(STATVA,STATV2,STATCD,PVAL,
31259     1                  CUT50,CUT75,CUT90,CUT95,
31260     1                  CUT975,CUT99,CUT999,
31261     1                  IFLAGU,IFRST,ILAST,
31262     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
31263C
31264C     PURPOSE--UTILITY ROUTINE USED BY DPPAGE.  THIS ROUTINE
31265C              UPDATES THE PARAMETERS "STATVAL", "STATCDF", AND
31266C              "PVALUE" AND VARIOUS CUTOFF POINTS AFTER A FREQUENCY TEST.
31267C
31268C              THIS ROUTINE MAY ALSO BE CALLED BY OTHER ROUTINES AS
31269C              WELL.
31270C
31271C     WRITTEN BY--ALAN HECKERT
31272C                 STATISTICAL ENGINEERING DIVISION
31273C                 INFORMATION TECHNOLOGY LABORAOTRY
31274C                 NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY
31275C                 GAITHERSBURG, MD 20899-8980
31276C                 PHONE--301-975-2899
31277C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
31278C           OF THE NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY.
31279C     LANGUAGE--ANSI FORTRAN (1977)
31280C     VERSION NUMBER--2013/2
31281C     ORIGINAL VERSION--FEBRUARY  2013.
31282C     UPDATED         --APRIL     2019. USER CAN SPECIFY NUMBER OF
31283C                                       DECIMAL POINTS FOR AUXILLARY
31284C                                       FILES
31285C
31286C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
31287C
31288      CHARACTER*4 IFLAGU
31289      CHARACTER*4 IBUGA2
31290      CHARACTER*4 IBUGA3
31291      CHARACTER*4 ISUBRO
31292      CHARACTER*4 IERROR
31293C
31294      LOGICAL IFRST
31295      LOGICAL ILAST
31296C
31297      CHARACTER*4 IH
31298      CHARACTER*4 IH2
31299      CHARACTER*4 ISUBN0
31300      CHARACTER*4 ISUBN1
31301      CHARACTER*4 ISUBN2
31302      CHARACTER*4 ISTEPN
31303      CHARACTER*4 IOP
31304      CHARACTER*20 IFORMT
31305C
31306      SAVE IOUNI1
31307C
31308C-----COMMON VARIABLES (GENERAL)--------------------------------------
31309C
31310      INCLUDE 'DPCOPA.INC'
31311      INCLUDE 'DPCOHK.INC'
31312      INCLUDE 'DPCOHO.INC'
31313      INCLUDE 'DPCOST.INC'
31314      INCLUDE 'DPCOP2.INC'
31315C
31316C-----START POINT-----------------------------------------------------
31317C
31318      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'PAG5')THEN
31319        ISTEPN='1'
31320        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31321        WRITE(ICOUT,999)
31322  999   FORMAT(1X)
31323        CALL DPWRST('XXX','BUG ')
31324        WRITE(ICOUT,51)
31325   51   FORMAT('***** AT THE BEGINNING OF DPPAG5--')
31326        CALL DPWRST('XXX','BUG ')
31327        WRITE(ICOUT,53)STATVA,STATV2,STATCD,PVAL
31328   53   FORMAT('STATVA,STATV2,STATCD,PVAL = ',4G15.7)
31329        CALL DPWRST('XXX','BUG ')
31330        WRITE(ICOUT,54)CUT50,CUT75,CUT90
31331   54   FORMAT('CUT50,CUT75,CUT90 = ',3G15.7)
31332        CALL DPWRST('XXX','BUG ')
31333        WRITE(ICOUT,55)CUT95,CUT975,CUT99,CUT999
31334   55   FORMAT('CUT95,CUT975,CUT99 = ',4G15.7)
31335        CALL DPWRST('XXX','BUG ')
31336      ENDIF
31337C
31338      IF(IFLAGU.EQ.'FILE')THEN
31339C
31340        IF(IFRST)THEN
31341          IOP='OPEN'
31342          IFLAG1=1
31343          IFLAG2=0
31344          IFLAG3=0
31345          IFLAG4=0
31346          IFLAG5=0
31347          CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
31348     1                IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
31349     1                IBUGA3,ISUBRO,IERROR)
31350          IF(IERROR.EQ.'YES')GOTO9000
31351C
31352          WRITE(IOUNI1,295)
31353  295     FORMAT(11X,'STATVAL',8X,'STATVAL2',7X,'STATCDF',8X,'PVALUE',
31354     1           7X,'CUTOFF0',7X,'CUTOFF50',7X,'CUTOFF75',
31355     1           7X,'CUTOFF90',7X,'CUTOFF95',7X,'CUTOF975',
31356     1           7X,'CUTOFF99',7X,'CUTOF999')
31357        ENDIF
31358C
31359        IFORMT='(11E15.7)'
31360        IF(IAUXDP.NE.7)THEN
31361          IFORMT=' '
31362          IF(IAUXDP.LE.9)THEN
31363            IFORMT='(11Exx.x)'
31364            ITOT=IAUXDP+8
31365            WRITE(IFORMT(5:6),'(I2)')ITOT
31366            WRITE(IFORMT(8:8),'(I1)')IAUXDP
31367          ELSE
31368            IFORMT='(11Exx.xx)'
31369            ITOT=IAUXDP+8
31370            WRITE(IFORMT(5:6),'(I2)')ITOT
31371            WRITE(IFORMT(8:9),'(I2)')IAUXDP
31372          ENDIF
31373        ENDIF
31374C
31375        WRITE(IOUNI1,IFORMT)STATVA,STATV2,STATCD,PVAL,CUT50,CUT75,
31376     1                      CUT90,CUT95,CUT975,CUT99,CUT999
31377CC299   FORMAT(11E15.7)
31378      ELSEIF(IFLAGU.EQ.'ON')THEN
31379        IF(STATVA.NE.CPUMIN)THEN
31380          IH='STAT'
31381          IH2='VAL '
31382          VALUE0=STATVA
31383          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
31384     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
31385     1                IANS,IWIDTH,IBUGA3,IERROR)
31386        ENDIF
31387C
31388        IF(STATV2.NE.CPUMIN)THEN
31389          IH='STAT'
31390          IH2='VAL2'
31391          VALUE0=STATV2
31392          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
31393     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
31394     1                IANS,IWIDTH,IBUGA3,IERROR)
31395        ENDIF
31396C
31397        IF(STATCD.NE.CPUMIN)THEN
31398          IH='STAT'
31399          IH2='CDF '
31400          VALUE0=STATCD
31401          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
31402     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
31403     1                IANS,IWIDTH,IBUGA3,IERROR)
31404        ENDIF
31405C
31406        IF(PVAL.NE.CPUMIN)THEN
31407          IH='PVAL'
31408          IH2='UE  '
31409          VALUE0=PVAL
31410          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
31411     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
31412     1                IANS,IWIDTH,IBUGA3,IERROR)
31413        ENDIF
31414C
31415        IF(CUT50.NE.CPUMIN)THEN
31416          IH='CUTO'
31417          IH2='FF50'
31418          VALUE0=CUT50
31419          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
31420     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
31421     1                IANS,IWIDTH,IBUGA3,IERROR)
31422        ENDIF
31423C
31424        IF(CUT75.NE.CPUMIN)THEN
31425          IH='CUTO'
31426          IH2='FF75'
31427          VALUE0=CUT75
31428          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
31429     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
31430     1                IANS,IWIDTH,IBUGA3,IERROR)
31431        ENDIF
31432C
31433        IF(CUT90.NE.CPUMIN)THEN
31434          IH='CUTO'
31435          IH2='FF90'
31436          VALUE0=CUT90
31437          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
31438     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
31439     1                IANS,IWIDTH,IBUGA3,IERROR)
31440        ENDIF
31441C
31442        IF(CUT95.NE.CPUMIN)THEN
31443          IH='CUTO'
31444          IH2='FF95'
31445          VALUE0=CUT95
31446          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
31447     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
31448     1                IANS,IWIDTH,IBUGA3,IERROR)
31449        ENDIF
31450C
31451        IF(CUT975.NE.CPUMIN)THEN
31452          IH='CUTO'
31453          IH2='F975'
31454          VALUE0=CUT975
31455          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
31456     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
31457     1                IANS,IWIDTH,IBUGA3,IERROR)
31458        ENDIF
31459C
31460        IF(CUT99.NE.CPUMIN)THEN
31461          IH='CUTO'
31462          IH2='FF99'
31463          VALUE0=CUT99
31464          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
31465     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
31466     1                IANS,IWIDTH,IBUGA3,IERROR)
31467        ENDIF
31468C
31469        IF(CUT999.NE.CPUMIN)THEN
31470          IH='CUTO'
31471          IH2='F999'
31472          VALUE0=CUT999
31473          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
31474     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
31475     1                IANS,IWIDTH,IBUGA3,IERROR)
31476        ENDIF
31477C
31478      ENDIF
31479C
31480      IF(IFLAGU.EQ.'FILE')THEN
31481        IF(ILAST)THEN
31482          IOP='CLOS'
31483          IFLAG1=1
31484          IFLAG2=0
31485          IFLAG3=0
31486          IFLAG4=0
31487          IFLAG5=0
31488          CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
31489     1                IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
31490     1                IBUGA3,ISUBRO,IERROR)
31491C
31492          IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'PAG5')THEN
31493            ISTEPN='3A'
31494            CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31495            WRITE(ICOUT,999)
31496            CALL DPWRST('XXX','BUG ')
31497            WRITE(ICOUT,301)IERROR
31498  301       FORMAT('AFTER CALL DPCLFI, IERROR = ',A4)
31499            CALL DPWRST('XXX','BUG ')
31500          ENDIF
31501C
31502          IF(IERROR.EQ.'YES')GOTO9000
31503        ENDIF
31504      ENDIF
31505C
31506C               *****************
31507C               **  STEP 90--  **
31508C               **  EXIT       **
31509C               *****************
31510C
31511 9000 CONTINUE
31512C
31513      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'PAG5')THEN
31514        WRITE(ICOUT,999)
31515        CALL DPWRST('XXX','BUG ')
31516        WRITE(ICOUT,9011)
31517 9011   FORMAT('***** AT THE END OF DPPAG5--')
31518        CALL DPWRST('XXX','BUG ')
31519      ENDIF
31520C
31521      RETURN
31522      END
31523      SUBROUTINE DPPAHE(IHARG,IARGT,ARG,NUMARG,PDEFPH,MAXPAT,PPATHE,
31524     1IBUGP2,IFOUND,IERROR)
31525C
31526C     PURPOSE--DEFINE THE PATTERN HEIGHTS.
31527C              THESE ARE LOCATED IN THE VECTOR PPATHE(.).
31528C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
31529C                     --IARGT  (A  CHARACTER VECTOR)
31530C                     --ARG
31531C                     --NUMARG
31532C                     --PDEFPH
31533C                     --MAXPAT
31534C                     --IBUGP2 ('ON' OR 'OFF' )
31535C     OUTPUT ARGUMENTS--PPATHE (A FLOATING POINT VECTOR)
31536C                     --IFOUND ('YES' OR 'NO' )
31537C                     --IERROR ('YES' OR 'NO' )
31538C     WRITTEN BY--JAMES J. FILLIBEN
31539C                 STATISTICAL ENGINEERING DIVISION
31540C                 INFORMATION TECHNOLOGY LABORATORY
31541C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
31542C                 GAITHERSBURG, MD 20899-8980
31543C                 PHONE--301-975-2899
31544C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
31545C           OF THE NATIONAL BUREAU OF STANDARDS.
31546C     LANGUAGE--ANSI FORTRAN (1977)
31547C     VERSION NUMBER--82/7
31548C     ORIGINAL VERSION--DECEMBER  1983.
31549C
31550C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
31551C
31552      CHARACTER*4 IHARG
31553      CHARACTER*4 IARGT
31554C
31555      CHARACTER*4 IBUGP2
31556      CHARACTER*4 IFOUND
31557      CHARACTER*4 IERROR
31558C
31559      CHARACTER*4 IHOLD1
31560C
31561      CHARACTER*4 ISUBN1
31562      CHARACTER*4 ISUBN2
31563      CHARACTER*4 ISTEPN
31564C
31565      DIMENSION IHARG(*)
31566      DIMENSION IARGT(*)
31567      DIMENSION ARG(*)
31568      DIMENSION PPATHE(*)
31569C
31570C---------------------------------------------------------------------
31571C
31572      INCLUDE 'DPCOP2.INC'
31573C
31574C-----START POINT-----------------------------------------------------
31575C
31576      IFOUND='NO'
31577      IERROR='NO'
31578      ISUBN1='DPPA'
31579      ISUBN2='HE  '
31580C
31581      NUMPAT=0
31582      IHOLD1='-999'
31583      HOLD1=-999.0
31584      HOLD2=-999.0
31585C
31586      IF(IBUGP2.EQ.'OFF')GOTO90
31587      WRITE(ICOUT,999)
31588  999 FORMAT(1X)
31589      CALL DPWRST('XXX','BUG ')
31590      WRITE(ICOUT,51)
31591   51 FORMAT('***** AT THE BEGINNING OF DPPAHE--')
31592      CALL DPWRST('XXX','BUG ')
31593      WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR
31594   52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
31595      CALL DPWRST('XXX','BUG ')
31596      WRITE(ICOUT,53)MAXPAT,NUMPAT
31597   53 FORMAT('MAXPAT,NUMPAT = ',I8,I8)
31598      CALL DPWRST('XXX','BUG ')
31599      WRITE(ICOUT,54)IHOLD1,HOLD1,HOLD2
31600   54 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7)
31601      CALL DPWRST('XXX','BUG ')
31602      WRITE(ICOUT,55)PDEFPH
31603   55 FORMAT('PDEFPH = ',E15.7)
31604      CALL DPWRST('XXX','BUG ')
31605      WRITE(ICOUT,60)NUMARG
31606   60 FORMAT('NUMARG = ',I8)
31607      CALL DPWRST('XXX','BUG ')
31608      DO65I=1,NUMARG
31609      WRITE(ICOUT,66)IHARG(I),IARGT(I),ARG(I)
31610   66 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8)
31611      CALL DPWRST('XXX','BUG ')
31612   65 CONTINUE
31613      WRITE(ICOUT,70)PPATHE(1)
31614   70 FORMAT('PPATHE(1) = ',E15.7)
31615      CALL DPWRST('XXX','BUG ')
31616      DO75I=1,10
31617      WRITE(ICOUT,76)I,PPATHE(I)
31618   76 FORMAT('I,PPATHE(I) = ',I8,2X,E15.7)
31619      CALL DPWRST('XXX','BUG ')
31620   75 CONTINUE
31621   90 CONTINUE
31622C
31623C               **************************************
31624C               **  STEP 1--                        **
31625C               **  BRANCH TO THE APPROPRIATE CASE  **
31626C               **************************************
31627C
31628      ISTEPN='1'
31629      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31630C
31631      IF(NUMARG.LE.0)GOTO9000
31632      IF(NUMARG.EQ.1)GOTO1110
31633      IF(NUMARG.EQ.2)GOTO1120
31634      IF(NUMARG.EQ.3)GOTO1130
31635      GOTO1140
31636C
31637 1110 CONTINUE
31638      GOTO1200
31639C
31640 1120 CONTINUE
31641      IF(IHARG(2).EQ.'ALL')IHOLD1='    '
31642      IF(IHARG(2).EQ.'ALL')HOLD1=PDEFPH
31643      IF(IHARG(2).EQ.'ALL')GOTO1300
31644      GOTO1200
31645C
31646 1130 CONTINUE
31647      IF(IHARG(2).EQ.'ALL')IHOLD1=IHARG(3)
31648      IF(IHARG(2).EQ.'ALL')HOLD1=ARG(3)
31649      IF(IHARG(2).EQ.'ALL')GOTO1300
31650      IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(2)
31651      IF(IHARG(3).EQ.'ALL')HOLD1=ARG(2)
31652      IF(IHARG(3).EQ.'ALL')GOTO1300
31653      GOTO1200
31654C
31655 1140 CONTINUE
31656      GOTO1200
31657C
31658C               *************************************************
31659C               **  STEP 2--                                   **
31660C               **  TREAT THE INDIVIDUAL SPECIFICATIONS CASE  **
31661C               *************************************************
31662C
31663 1200 CONTINUE
31664      ISTEPN='2'
31665      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31666C
31667      IF(NUMARG.LE.1)GOTO1210
31668      GOTO1220
31669C
31670 1210 CONTINUE
31671      NUMPAT=1
31672      PPATHE(1)=PDEFPH
31673      GOTO1270
31674C
31675 1220 CONTINUE
31676      NUMPAT=NUMARG-1
31677      IF(NUMPAT.GT.MAXPAT)NUMPAT=MAXPAT
31678      DO1225I=1,NUMPAT
31679      J=I+1
31680      IHOLD1=IHARG(J)
31681      HOLD1=ARG(J)
31682      HOLD2=HOLD1
31683      IF(IHOLD1.EQ.'ON')HOLD2=PDEFPH
31684      IF(IHOLD1.EQ.'OFF')HOLD2=PDEFPH
31685      IF(IHOLD1.EQ.'AUTO')HOLD2=PDEFPH
31686      IF(IHOLD1.EQ.'DEFA')HOLD2=PDEFPH
31687      PPATHE(I)=HOLD2
31688 1225 CONTINUE
31689      GOTO1270
31690C
31691 1270 CONTINUE
31692      IF(IFEEDB.EQ.'OFF')GOTO1279
31693      WRITE(ICOUT,999)
31694      CALL DPWRST('XXX','BUG ')
31695      DO1278I=1,NUMPAT
31696      WRITE(ICOUT,1276)I,PPATHE(I)
31697 1276 FORMAT('PATTERN HEIGHT ',I6,' HAS JUST BEEN SET TO ',
31698     1E15.7)
31699      CALL DPWRST('XXX','BUG ')
31700 1278 CONTINUE
31701 1279 CONTINUE
31702      IFOUND='YES'
31703      GOTO9000
31704C
31705C               **************************
31706C               **  STEP 2--            **
31707C               **  TREAT THE ALL CASE  **
31708C               **************************
31709C
31710 1300 CONTINUE
31711      ISTEPN='3'
31712      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31713C
31714      NUMPAT=MAXPAT
31715      HOLD2=HOLD1
31716      IF(IHOLD1.EQ.'ON')HOLD2=PDEFPH
31717      IF(IHOLD1.EQ.'OFF')HOLD2=PDEFPH
31718      IF(IHOLD1.EQ.'AUTO')HOLD2=PDEFPH
31719      IF(IHOLD1.EQ.'DEFA')HOLD2=PDEFPH
31720      DO1315I=1,NUMPAT
31721      PPATHE(I)=HOLD2
31722 1315 CONTINUE
31723      GOTO1370
31724C
31725 1370 CONTINUE
31726      IF(IFEEDB.EQ.'OFF')GOTO1319
31727      WRITE(ICOUT,999)
31728      CALL DPWRST('XXX','BUG ')
31729      I=1
31730      WRITE(ICOUT,1316)PPATHE(I)
31731 1316 FORMAT('ALL PATTERN HEIGHTS HAVE JUST BEEN SET TO ',
31732     1A4)
31733      CALL DPWRST('XXX','BUG ')
31734 1319 CONTINUE
31735      IFOUND='YES'
31736      GOTO9000
31737C
31738C               *****************
31739C               **  STEP 90--  **
31740C               **  EXIT       **
31741C               *****************
31742C
31743 9000 CONTINUE
31744      IF(IBUGP2.EQ.'OFF')GOTO9090
31745      WRITE(ICOUT,9011)
31746 9011 FORMAT('***** AT THE END       OF DPPAHE--')
31747      CALL DPWRST('XXX','BUG ')
31748      WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR
31749 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
31750      CALL DPWRST('XXX','BUG ')
31751      WRITE(ICOUT,9013)MAXPAT,NUMPAT
31752 9013 FORMAT('MAXPAT,NUMPAT = ',I8,I8)
31753      CALL DPWRST('XXX','BUG ')
31754      WRITE(ICOUT,9014)IHOLD1,HOLD1,HOLD2
31755 9014 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7)
31756      CALL DPWRST('XXX','BUG ')
31757      WRITE(ICOUT,9015)PDEFPH
31758 9015 FORMAT('PDEFPH = ',E15.7)
31759      CALL DPWRST('XXX','BUG ')
31760      WRITE(ICOUT,9020)NUMARG
31761 9020 FORMAT('NUMARG = ',I8)
31762      CALL DPWRST('XXX','BUG ')
31763      DO9025I=1,NUMARG
31764      WRITE(ICOUT,9026)IHARG(I),IARGT(I),ARG(I)
31765 9026 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8)
31766      CALL DPWRST('XXX','BUG ')
31767 9025 CONTINUE
31768      WRITE(ICOUT,9030)PPATHE(1)
31769 9030 FORMAT('PPATHE(1) = ',E15.7)
31770      CALL DPWRST('XXX','BUG ')
31771      DO9035I=1,10
31772      WRITE(ICOUT,9036)I,PPATHE(I)
31773 9036 FORMAT('I,PPATHE(I) = ',I8,2X,E15.7)
31774      CALL DPWRST('XXX','BUG ')
31775 9035 CONTINUE
31776 9090 CONTINUE
31777C
31778      RETURN
31779      END
31780      SUBROUTINE DPPALI(IHARG,NUMARG,IDEFPL,MAXPAT,IPATLI,
31781     1IBUGP2,IFOUND,IERROR)
31782C
31783C     PURPOSE--DEFINE THE PATTERN LINE TYPES.
31784C              THESE ARE LOCATED IN THE VECTOR IPATLI(.).
31785C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
31786C                     --NUMARG
31787C                     --IDEFPL
31788C                     --MAXPAT
31789C                     --IBUGP2 ('ON' OR 'OFF' )
31790C     OUTPUT ARGUMENTS--IPATLI (A CHARACTER VECTOR)
31791C                     --IFOUND ('YES' OR 'NO' )
31792C                     --IERROR ('YES' OR 'NO' )
31793C     WRITTEN BY--JAMES J. FILLIBEN
31794C                 STATISTICAL ENGINEERING DIVISION
31795C                 INFORMATION TECHNOLOGY LABORATORY
31796C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
31797C                 GAITHERSBURG, MD 20899-8980
31798C                 PHONE--301-975-2899
31799C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
31800C           OF THE NATIONAL BUREAU OF STANDARDS.
31801C     LANGUAGE--ANSI FORTRAN (1977)
31802C     VERSION NUMBER--82/7
31803C     ORIGINAL VERSION--DECEMBER  1983.
31804C
31805C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
31806C
31807      CHARACTER*4 IHARG
31808      CHARACTER*4 IDEFPL
31809      CHARACTER*4 IPATLI
31810C
31811      CHARACTER*4 IBUGP2
31812      CHARACTER*4 IFOUND
31813      CHARACTER*4 IERROR
31814C
31815      CHARACTER*4 IHOLD1
31816      CHARACTER*4 IHOLD2
31817C
31818      CHARACTER*4 ISUBN1
31819      CHARACTER*4 ISUBN2
31820      CHARACTER*4 ISTEPN
31821C
31822      DIMENSION IHARG(*)
31823      DIMENSION IPATLI(*)
31824C
31825C---------------------------------------------------------------------
31826C
31827      INCLUDE 'DPCOP2.INC'
31828C
31829C-----START POINT-----------------------------------------------------
31830C
31831      IFOUND='NO'
31832      IERROR='NO'
31833      ISUBN1='DPPA'
31834      ISUBN2='LI  '
31835      IHOLD1='-999'
31836      IHOLD2='-999'
31837C
31838      NUMPAT=0
31839C
31840      IF(IBUGP2.EQ.'ON')THEN
31841        WRITE(ICOUT,999)
31842  999   FORMAT(1X)
31843        CALL DPWRST('XXX','BUG ')
31844        WRITE(ICOUT,51)
31845   51   FORMAT('***** AT THE BEGINNING OF DPPALI--')
31846        CALL DPWRST('XXX','BUG ')
31847        WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR,IHOLD1,IHOLD2,IDEFPL
31848   52   FORMAT('IBUGP2,IFOUND,IERROR,IHOLD1,IHOLD2,IDEFPL = ',
31849     1         5(A4,2X),A4)
31850        CALL DPWRST('XXX','BUG ')
31851        WRITE(ICOUT,53)MAXPAT,NUMPAT,NUMARG
31852   53   FORMAT('MAXPAT,NUMPAT,NUMARG = ',3I8)
31853        CALL DPWRST('XXX','BUG ')
31854        DO65I=1,NUMARG
31855          WRITE(ICOUT,66)IHARG(I)
31856   66     FORMAT('IHARG(I) = ',A4)
31857          CALL DPWRST('XXX','BUG ')
31858   65   CONTINUE
31859        DO75I=1,10
31860          WRITE(ICOUT,76)I,IPATLI(I)
31861   76     FORMAT('I,IPATLI(I) = ',I8,2X,A4)
31862          CALL DPWRST('XXX','BUG ')
31863   75   CONTINUE
31864      ENDIF
31865C
31866C               **************************************
31867C               **  STEP 1--                        **
31868C               **  BRANCH TO THE APPROPRIATE CASE  **
31869C               **************************************
31870C
31871      ISTEPN='1'
31872      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31873C
31874      IF(NUMARG.LE.0)GOTO9000
31875      IF(NUMARG.EQ.1)THEN
31876        GOTO1200
31877      ELSEIF(NUMARG.EQ.2)THEN
31878        IF(IHARG(2).EQ.'ALL')IHOLD1='    '
31879        IF(IHARG(2).EQ.'ALL')GOTO1300
31880        GOTO1200
31881      ELSEIF(NUMARG.EQ.3)THEN
31882        IF(IHARG(2).EQ.'ALL')IHOLD1=IHARG(3)
31883        IF(IHARG(2).EQ.'ALL')GOTO1300
31884        IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(2)
31885        IF(IHARG(3).EQ.'ALL')GOTO1300
31886        GOTO1200
31887      ELSE
31888        GOTO1200
31889      ENDIF
31890C
31891C               *************************************************
31892C               **  STEP 2--                                   **
31893C               **  TREAT THE INDIVIDUAL SPECIFICATIONS CASE  **
31894C               *************************************************
31895C
31896 1200 CONTINUE
31897      ISTEPN='2'
31898      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31899C
31900      IF(NUMARG.LE.1)THEN
31901        NUMPAT=1
31902        IPATLI(1)='    '
31903      ELSE
31904        NUMPAT=NUMARG-1
31905        IF(NUMPAT.GT.MAXPAT)NUMPAT=MAXPAT
31906        DO1225I=1,NUMPAT
31907          J=I+1
31908          IHOLD1=IHARG(J)
31909          IHOLD2=IHOLD1
31910          IF(IHOLD1.EQ.'ON')IHOLD2='SOLI'
31911          IF(IHOLD1.EQ.'OFF')IHOLD2='    '
31912          IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEFPL
31913          IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEFPL
31914          IPATLI(I)=IHOLD2
31915 1225   CONTINUE
31916      ENDIF
31917C
31918      IF(IFEEDB.EQ.'ON')THEN
31919        WRITE(ICOUT,999)
31920        CALL DPWRST('XXX','BUG ')
31921        DO1278I=1,NUMPAT
31922          WRITE(ICOUT,1276)I,IPATLI(I)
31923 1276     FORMAT('PATTERN LINE ',I6,' HAS JUST BEEN SET TO ',A4)
31924          CALL DPWRST('XXX','BUG ')
31925 1278   CONTINUE
31926      ENDIF
31927      IFOUND='YES'
31928      GOTO9000
31929C
31930C               **************************
31931C               **  STEP 2--            **
31932C               **  TREAT THE ALL CASE  **
31933C               **************************
31934C
31935 1300 CONTINUE
31936      ISTEPN='3'
31937      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31938C
31939      NUMPAT=MAXPAT
31940      IHOLD2=IHOLD1
31941      IF(IHOLD1.EQ.'ON')IHOLD2='SOLI'
31942      IF(IHOLD1.EQ.'OFF')IHOLD2='    '
31943      IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEFPL
31944      IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEFPL
31945      DO1315I=1,NUMPAT
31946        IPATLI(I)=IHOLD2
31947 1315 CONTINUE
31948C
31949      IF(IFEEDB.EQ.'ON')THEN
31950        WRITE(ICOUT,999)
31951        CALL DPWRST('XXX','BUG ')
31952        I=1
31953        WRITE(ICOUT,1316)IPATLI(I)
31954 1316   FORMAT('ALL PATTERN LINES HAVE JUST BEEN SET TO ',A4)
31955        CALL DPWRST('XXX','BUG ')
31956      ENDIF
31957      IFOUND='YES'
31958      GOTO9000
31959C
31960C               *****************
31961C               **  STEP 90--  **
31962C               **  EXIT       **
31963C               *****************
31964C
31965 9000 CONTINUE
31966      IF(IBUGP2.EQ.'ON')THEN
31967        WRITE(ICOUT,9011)
31968 9011   FORMAT('***** AT THE END       OF DPPALI--')
31969        CALL DPWRST('XXX','BUG ')
31970        WRITE(ICOUT,9012)IFOUND,IERROR,IHOLD1,IHOLD2
31971 9012   FORMAT('IFOUND,IERROR,IHOLD1,IHOLD2 = ',3(A4,2X),A4)
31972        CALL DPWRST('XXX','BUG ')
31973      ENDIF
31974C
31975      RETURN
31976      END
31977      SUBROUTINE DPPAM2(X,NROW,NCOL,NCLUST,IVARN1,IVARN2,
31978     1                  DYS,DYSMA,DYSMB,TTD,RADUS,DVEC,DAMER,SEPAR,
31979     1                  NSEL,NREPR,NSEND,NCLUV,NELEM,
31980     1                  ICAPSW,ICAPTY,IFORSW,MAXNXT,
31981     1                  ISUBRO,IBUGA3,IERROR)
31982C
31983C     PURPOSE--PERFORM A K-MEDIODS CLUSTER ANALYSIS FOR <= 100 ROWS USING
31984C              KAUFFMAN AND ROUSSEEUW "PAM" ALGORITHM (FOR > 100
31985C              ROWS, USE THE "CLARA" ALGORITHM.
31986C     REFERENCES--KAUFMAN AND ROUSSEEUW (1990), "FINDING GROUPS IN DATA:
31987C                 AN INTRODUCTION TO CLUSTER ANALYSIS", WILEY.
31988C               --ROUSSEEUW (1987), "SILHOUETTES: A GRAPHICAL AID TO THE
31989C                 INTERPRETATION AND VALIDATION OF CLUSTER ANALYSIS",
31990C                 JOURNAL OF COMPUTATIONAL AND APPLIED MATHEMATICS,
31991C                 VOL. 20, PP. 53-65, NORTH HOLLAND.
31992C     WRITTEN BY--ALAN HECKERT
31993C                 STATISTICAL ENGINEERING DIVISION
31994C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
31995C                 GAITHERSBURG, MD 20899-8980
31996C                 PHONE--301-975-2899
31997C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
31998C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
31999C     REFERENCE--ASTM MANUAL STP-15D, PAGES 78-84, 100-105
32000C     LANGUAGE--ANSI FORTRAN (1977)
32001C     VERSION NUMBER--2017/08
32002C     ORIGINAL VERSION--AUGUST      2017.
32003C
32004C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
32005C
32006      DIMENSION X(NROW,NCOL)
32007      DIMENSION DYS(*)
32008      DIMENSION DYSMA(*)
32009      DIMENSION DYSMB(*)
32010      DIMENSION DVEC(*)
32011      DIMENSION RADUS(*)
32012      DIMENSION DAMER(*)
32013      DIMENSION TTD(*)
32014      DIMENSION SEPAR(*)
32015C
32016      INTEGER NSEL(*)
32017      INTEGER NREPR(*)
32018      INTEGER NCLUV(*)
32019      INTEGER NSEND(*)
32020      INTEGER NELEM(*)
32021C
32022      CHARACTER*4 IVARN1(*)
32023      CHARACTER*4 IVARN2(*)
32024      CHARACTER*4 ICAPSW
32025      CHARACTER*4 ICAPTY
32026      CHARACTER*4 IFORSW
32027      CHARACTER*4 ISUBRO
32028      CHARACTER*4 IBUGA3
32029      CHARACTER*4 IERROR
32030C
32031      CHARACTER*4 IWRITE
32032      CHARACTER*4 IFLAG
32033      CHARACTER*4 ISUBN1
32034      CHARACTER*4 ISUBN2
32035      CHARACTER*4 ISTEPN
32036      CHARACTER*4 ICASPL
32037      CHARACTER*4 ITYP3
32038      CHARACTER*4 IOP
32039      CHARACTER*20 IFORMT
32040      CHARACTER*3 LAB1
32041C
32042C---------------------------------------------------------------------
32043C
32044      INCLUDE 'DPCOST.INC'
32045      INCLUDE 'DPCOP2.INC'
32046C
32047C-----START POINT-----------------------------------------------------
32048C
32049      ISUBN1='DPPA'
32050      ISUBN2='M2  '
32051      IWRITE='OFF'
32052      IFLAGO=0
32053C
32054      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PAM2')THEN
32055        WRITE(ICOUT,999)
32056  999   FORMAT(1X)
32057        CALL DPWRST('XXX','BUG ')
32058        WRITE(ICOUT,70)
32059   70   FORMAT('AT THE BEGINNING OF DPPAM2--')
32060        CALL DPWRST('XXX','BUG ')
32061        WRITE(ICOUT,72)NROW,NCOL,NCLUST,IKMDSC,IKMDDI,IKMDTY
32062   72   FORMAT('NROW,NCOL,NCLUST,IKMDSC,IKMDDI,IKMDTY = ',3I8,3(2X,A4))
32063        CALL DPWRST('XXX','BUG ')
32064        WRITE(ICOUT,73)ICAPSW,ICAPTY,IFORSW
32065   73   FORMAT('ICAPSW,ICAPTY,IFORSW = ',2(A4,2X),A4)
32066        CALL DPWRST('XXX','BUG ')
32067        DO75I=1,NROW
32068          WRITE(ICOUT,77)I,X(I,1),X(I,2),X(I,3)
32069   77     FORMAT('I,X(I,1),X(I,2),X(I,3) = ',I8,2X,3G15.7)
32070          CALL DPWRST('XXX','BUG ')
32071   75   CONTINUE
32072      ENDIF
32073C
32074C               ********************************
32075C               **   STEP 1--                 **
32076C               **   CHECK FOR MISSING VALUES **
32077C               ********************************
32078C
32079      ISTEPN='1'
32080      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PAM2')
32081     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
32082C
32083C     FIRST CHECK WHETHER ANY ROWS OR COLUMNS CONTAIN ONLY
32084C     MISSING DATA.  THIS WILL BE TREATED AS AN ERROR CONDITION.
32085C
32086C     CHECK ROWS FIRST
32087C
32088      DO80I=1,NROW
32089        DO90J=1,NCOL
32090          IF(X(I,J).NE.PSTAMV)GOTO99
32091   90   CONTINUE
32092        WRITE(ICOUT,999)
32093        CALL DPWRST('XXX','BUG ')
32094        WRITE(ICOUT,91)
32095   91   FORMAT('****** ERROR IN PAM CLUSTERING--')
32096        CALL DPWRST('XXX','BUG ')
32097        WRITE(ICOUT,93)I
32098   93   FORMAT('       ROW (OBSERVATION) ',I8,' CONTAINS ONLY ',
32099     1         'MISSING DATA.')
32100        CALL DPWRST('XXX','BUG ')
32101        IERROR='YES'
32102        GOTO9000
32103   99   CONTINUE
32104   80 CONTINUE
32105C
32106C     NOW CHECK COLUMNS
32107C
32108      NMISS=0
32109      NMAT=0
32110C
32111      DO730J=1,NCOL
32112        NMISSV=0
32113        DO740I=1,NROW
32114          IF(X(I,J).EQ.PSTAMV)THEN
32115            NMISSV=NMISSV + 1
32116          ENDIF
32117  740   CONTINUE
32118        IF(NMISSV.EQ.NROW)THEN
32119          WRITE(ICOUT,999)
32120          CALL DPWRST('XXX','BUG ')
32121          WRITE(ICOUT,91)
32122          CALL DPWRST('XXX','BUG ')
32123          WRITE(ICOUT,743)J
32124  743     FORMAT('       COLUMN (VARIABLE) ',I8,' CONTAINS ONLY ',
32125     1           'MISSING DATA.')
32126          CALL DPWRST('XXX','BUG ')
32127          IERROR='YES'
32128          GOTO9000
32129        ELSEIF(NMISSV.EQ.0)THEN
32130          NMAT=1
32131        ELSE
32132          WRITE(ICOUT,999)
32133          CALL DPWRST('XXX','BUG ')
32134          WRITE(ICOUT,746)IVARN1(J),IVARN2(J),NMISSV
32135  746     FORMAT('VARIABLE ',2A4,' CONTAINS ',I8,' MISSING VALUES.')
32136          CALL DPWRST('XXX','BUG ')
32137          WRITE(ICOUT,743)J
32138        ENDIF
32139        NMISS=NMISS + NMISSV
32140  730 CONTINUE
32141C
32142      IF(NMISS.GT.0)THEN
32143        WRITE(ICOUT,999)
32144        CALL DPWRST('XXX','BUG ')
32145        WRITE(ICOUT,163)
32146  163   FORMAT('THE TOTAL NUMBER OF MISSING VALUES IS ',I8)
32147        CALL DPWRST('XXX','BUG ')
32148        IF(NMAT.EQ.0)THEN
32149          WRITE(ICOUT,999)
32150          CALL DPWRST('XXX','BUG ')
32151          WRITE(ICOUT,165)
32152  165     FORMAT('****** WARNING IN PAM CLUSTERING--')
32153          CALL DPWRST('XXX','BUG ')
32154          WRITE(ICOUT,167)
32155  167     FORMAT('       NO VARIABLES ARE DEFINED FOR ALL ',
32156     1           'OBSERVATIONS.')
32157          CALL DPWRST('XXX','BUG ')
32158        ENDIF
32159      ENDIF
32160C
32161C               ******************************
32162C               **   STEP 2--               **
32163C               **   SCALE IF REQUESTED     **
32164C               ******************************
32165C
32166      ISTEPN='1'
32167      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PAM2')THEN
32168        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
32169        WRITE(ICOUT,168)NMISS,PSTAMV
32170  168   FORMAT('NMISS,PSTAMV = ',I8,2X,G15.7)
32171        CALL DPWRST('XXX','BUG ')
32172      ENDIF
32173C
32174C     IF NROW = NCOL, ASSUME OUR DATA IS A DISSIMILARITY MATRIX.
32175C     OTHERWISE, ASSUME OUR DATA IS MEASUREMENT DATA.  DO NOT SCALE
32176C     DISSIMILARITY DATA EVEN IF SCALING OPTION TURNED ON.
32177C
32178      IF(NROW.EQ.NCOL .AND. IKMDTY.EQ.'DISS')THEN
32179        JDYSS=1
32180      ELSE
32181        JDYSS=0
32182      ENDIF
32183      NSTAN=0
32184      IF(JDYSS.EQ.1)GOTO299
32185      IF(IKMDSC.EQ.'OFF')GOTO299
32186C
32187      NSTAN=1
32188      DO201JJ=1,NCOL
32189        NROWT=0
32190        DO203II=1,NROW
32191          IF(X(II,JJ).NE.PSTAMV)THEN
32192            NROWT=NROWT+1
32193            DYS(NROWT)=X(II,JJ)
32194          ENDIF
32195  203   CONTINUE
32196        IF(ISTALO.EQ.'MEAN')THEN
32197          CALL MEAN(DYS,NROWT,IWRITE,XMEAN,IBUGA3,IERROR)
32198        ELSEIF(ISTALO.EQ.'MEDI')THEN
32199          CALL MEDIAN(DYS,NROWT,IWRITE,DYSMB,MAXNXT,XMEAN,
32200     1                IBUGA3,IERROR)
32201        ELSEIF(ISTALO.EQ.'MIDM')THEN
32202          CALL MIDMEA(DYS,NROWT,IWRITE,DYSMB,MAXNXT,XMEAN,
32203     1                IBUGA3,IERROR)
32204        ELSEIF(ISTALO.EQ.'HARM')THEN
32205          CALL HARMEA(DYS,NROWT,IWRITE,XMEAN,IBUGA3,IERROR)
32206        ELSEIF(ISTALO.EQ.'MINI')THEN
32207          CALL MINIM(DYS,NROWT,IWRITE,XMEAN,IBUGA3,IERROR)
32208        ELSEIF(ISTALO.EQ.'GEOM')THEN
32209          CALL GEOMEA(DYS,NROWT,IWRITE,XMEAN,IBUGA3,IERROR)
32210        ELSEIF(ISTALO.EQ.'BILO')THEN
32211          CALL BIWLOC(DYS,NROWT,IWRITE,DYSMA,DYSMB,MAXNXT,XMEAN,
32212     1                IBUGA3,IERROR)
32213        ELSEIF(ISTALO.EQ.'H15 ')THEN
32214          NCUT=0
32215          C=1.5
32216          CALL H15(DYS,NROWT,C,NCUT,XMEAN,XSC,DYSMA,DYSMB,MAXNXT,
32217     1                IBUGA3,IERROR)
32218        ELSEIF(ISTALO.EQ.'H10 ')THEN
32219          NCUT=0
32220          C=1.0
32221          CALL H15(DYS,NROWT,C,NCUT,XMEAN,XSC,DYSMA,DYSMB,MAXNXT,
32222     1                IBUGA3,IERROR)
32223        ELSEIF(ISTALO.EQ.'H12 ')THEN
32224          NCUT=0
32225          C=1.2
32226          CALL H15(DYS,NROWT,C,NCUT,XMEAN,XSC,DYSMA,DYSMB,MAXNXT,
32227     1                IBUGA3,IERROR)
32228        ELSEIF(ISTALO.EQ.'H17 ')THEN
32229          NCUT=0
32230          C=1.7
32231          CALL H15(DYS,NROWT,C,NCUT,XMEAN,XSC,DYSMA,DYSMB,MAXNXT,
32232     1                IBUGA3,IERROR)
32233        ELSEIF(ISTALO.EQ.'H20 ')THEN
32234          NCUT=0
32235          C=2.0
32236          CALL H15(DYS,NROWT,C,NCUT,XMEAN,XSC,DYSMA,DYSMB,MAXNXT,
32237     1                IBUGA3,IERROR)
32238        ELSE
32239          CALL MEAN(DYS,NROWT,IWRITE,XMEAN,IBUGA3,IERROR)
32240        ENDIF
32241C
32242        IF(ISTASC.EQ.'SD  ')THEN
32243          CALL SD(DYS,NROWT,IWRITE,XSD,IBUGA3,IERROR)
32244        ELSEIF(ISTASC.EQ.'H15S')THEN
32245          NCUT=0
32246          C=1.5
32247          CALL H15(DYS,NROWT,C,NCUT,XLOC,XSD,DYSMA,DYSMB,MAXNXT,
32248     1                IBUGA3,IERROR)
32249        ELSEIF(ISTASC.EQ.'H10S')THEN
32250          NCUT=0
32251          C=1.0
32252          CALL H15(DYS,NROWT,C,NCUT,XLOC,XSD,DYSMA,DYSMB,MAXNXT,
32253     1                IBUGA3,IERROR)
32254        ELSEIF(ISTASC.EQ.'H12S')THEN
32255          NCUT=0
32256          C=1.2
32257          CALL H15(DYS,NROWT,C,NCUT,XLOC,XSD,DYSMA,DYSMB,MAXNXT,
32258     1                IBUGA3,IERROR)
32259        ELSEIF(ISTASC.EQ.'H17S')THEN
32260          NCUT=0
32261          C=1.7
32262          CALL H15(DYS,NROWT,C,NCUT,XLOC,XSD,DYSMA,DYSMB,MAXNXT,
32263     1                IBUGA3,IERROR)
32264        ELSEIF(ISTASC.EQ.'H20S')THEN
32265          NCUT=0
32266          C=2.0
32267          CALL H15(DYS,NROWT,C,NCUT,XLOC,XSD,DYSMA,DYSMB,MAXNXT,
32268     1                IBUGA3,IERROR)
32269        ELSEIF(ISTASC.EQ.'BISC')THEN
32270          CALL BIWSCA(DYS,NROWT,IWRITE,DYSMA,DYSMB,MAXNXT,XSD,
32271     1                IBUGA3,IERROR)
32272        ELSEIF(ISTASC.EQ.'MAD ')THEN
32273          CALL MAD(DYS,NROWT,IWRITE,DYSMA,DYSMB,MAXNXT,XSD,
32274     1             IBUGA3,IERROR)
32275        ELSEIF(ISTASC.EQ.'MADN')THEN
32276          CALL MAD(DYS,NROWT,IWRITE,DYSMA,DYSMB,MAXNXT,XSD,
32277     1             IBUGA3,IERROR)
32278          XSD=XSD/0.67449
32279        ELSEIF(ISTASC.EQ.'AAD ')THEN
32280          CALL AAD(DYS,NROWT,IWRITE,DYSMA,MAXNXT,XSD,'MEAN',
32281     1             IBUGA3,IERROR)
32282        ELSEIF(ISTASC.EQ.'IQRA')THEN
32283          CALL LOWQUA(DYS,NROWT,IWRITE,DYSMA,MAXNXT,RIGH1,
32284     1                IBUGA3,IERROR)
32285          CALL UPPQUA(DYS,NROWT,IWRITE,DYSMA,MAXNXT,RIGH2,
32286     1                IBUGA3,IERROR)
32287          XSD=RIGH2-RIGH1
32288        ELSEIF(ISTASC.EQ.'NIQR')THEN
32289          CALL LOWQUA(DYS,NROWT,IWRITE,DYSMA,MAXNXT,RIGH1,
32290     1                IBUGA3,IERROR)
32291          CALL UPPQUA(DYS,NROWT,IWRITE,DYSMA,MAXNXT,RIGH2,
32292     1                IBUGA3,IERROR)
32293          XSD=0.7413*(RIGH2-RIGH1)
32294        ELSEIF(ISTASC.EQ.'SNSC')THEN
32295          XSD=SN(DYS,NROWT,RADUS,DAMER,TTD)
32296        ELSEIF(ISTASC.EQ.'MAXI')THEN
32297          CALL MINIM(DYS,NROWT,IWRITE,XMIN,IBUGA3,IERROR)
32298          CALL MAXIM(DYS,NROWT,IWRITE,XMAX,IBUGA3,IERROR)
32299          XSD=XMAX - XMIN
32300        ELSE
32301          CALL SD(DYS,NROWT,IWRITE,XMEAN,IBUGA3,IERROR)
32302        ENDIF
32303C
32304        IF(XSD.LE.0.0)THEN
32305          WRITE(ICOUT,91)
32306          CALL DPWRST('XXX','BUG ')
32307          WRITE(ICOUT,206)JJ
32308  206     FORMAT('       VARIABLE ',I4,' HAS ZERO STANDARD DEVIATION ',
32309     1           'WHEN SCALING REQUESTED.')
32310          CALL DPWRST('XXX','BUG ')
32311          IERROR='YES'
32312          GOTO9000
32313        ENDIF
32314        DO205II=1,NROW
32315          IF(X(II,JJ).NE.PSTAMV)THEN
32316            AVAL=(X(II,JJ)-XMEAN)/XSD
32317            X(II,JJ)=AVAL
32318          ENDIF
32319  205   CONTINUE
32320  201 CONTINUE
32321C
32322  299 CONTINUE
32323C
32324C     OPEN THE AUXILLARY FILES
32325C
32326      IFLAGO=1
32327      IOP='OPEN'
32328      IFLG11=1
32329      IFLG21=1
32330      IFLG31=1
32331      IFLAG4=1
32332      IFLAG5=0
32333      CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLAG4,IFLAG5,
32334     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
32335     1            IBUGA3,ISUBRO,IERROR)
32336      IF(IERROR.EQ.'YES')GOTO9000
32337C
32338C               ************************************
32339C               **   STEP 3--                     **
32340C               **   PERFORM THE CLUSTER ANALYSIS **
32341C               ************************************
32342C
32343C      THIS CODE IS A SOMEWHAT MODIFED VERSION OF CODE IN THE
32344C      PAM MAIN ROUTINE.
32345C
32346      JHALT=0
32347      NN=NROW
32348      JPP=NCOL
32349      RNN=REAL(NN)
32350      IFLAG='PAM'
32351C
32352C       NDYST = 1 => EUCLIDEAN DISTANCES
32353C             = 2 => MANHATTAN DISTANCES
32354C
32355      NDYST=2
32356      IF(IKMDDI.EQ.'EUCL')NDYST=1
32357C
32358      IF(IKMDPR.EQ.'ALL')THEN
32359        LARGE=2
32360      ELSEIF(IKMDPR.EQ.'FINA')THEN
32361        LARGE=1
32362      ELSEIF(IKMDPR.EQ.'MINI')THEN
32363        LARGE=0
32364      ELSE
32365        LARGE=2
32366      ENDIF
32367C
32368      ISTEPN='2'
32369      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PAM2')THEN
32370        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
32371        WRITE(ICOUT,169)NCLUST,NN,JPP,NDYST,LARGE,JDYSS
32372  169   FORMAT('NCLUST,NN,JPP,NDYST,LARGE,JDYSS = ',6I8)
32373        CALL DPWRST('XXX','BUG ')
32374      ENDIF
32375C
32376      IF(IPRINT.EQ.'ON')THEN
32377        WRITE(ICOUT,999)
32378        CALL DPWRST('XXX','BUG ')
32379        WRITE(ICOUT,999)
32380        CALL DPWRST('XXX','BUG ')
32381        WRITE(ICOUT,301)
32382  301   FORMAT(10X,'**********************************************')
32383        CALL DPWRST('XXX','BUG ')
32384        WRITE(ICOUT,302)
32385  302   FORMAT(10X,'*                                            *')
32386        CALL DPWRST('XXX','BUG ')
32387        WRITE(ICOUT,303)
32388  303   FORMAT(10X,'*  ROUSSEEUW/KAUFFMAN K-MEDOID CLUSTERING    *')
32389        CALL DPWRST('XXX','BUG ')
32390        WRITE(ICOUT,304)
32391  304   FORMAT(10X,'*  (USING THE PAM ROUTINE).                  *')
32392        CALL DPWRST('XXX','BUG ')
32393        WRITE(ICOUT,302)
32394        CALL DPWRST('XXX','BUG ')
32395        WRITE(ICOUT,301)
32396        CALL DPWRST('XXX','BUG ')
32397        WRITE(ICOUT,999)
32398        CALL DPWRST('XXX','BUG ')
32399      ENDIF
32400C
32401      DO311II=1,NN
32402        NSEL(II)=II
32403  311 CONTINUE
32404      IF(JDYSS.EQ.0)THEN
32405        CALL DYSTAP(NN,NCOL,NROW,NCOL,X,DYS,NDYST,PSTAMV,JHALT,
32406     1             ISUBRO,IBUGA3)
32407      ELSE
32408        DYS(1)=0.0
32409        DO990L=2,NN
32410          LSUBT=L-1
32411          DO991J=1,L-1
32412            DVEC(J)=X(L,J)
32413            IF(DVEC(J).LT.0.)THEN
32414              WRITE(ICOUT,999)
32415              CALL DPWRST('XXX','BUG ')
32416              WRITE(ICOUT,91)
32417              CALL DPWRST('XXX','BUG ')
32418              WRITE(ICOUT,996)L,J
32419  996         FORMAT('       THE DISSIMILARITY BETWEEN OBJECT ',I5,
32420     1               ' AND OBJECT ',I5,' IS NEGATIVE.')
32421              CALL DPWRST('XXX','BUG ')
32422              WRITE(ICOUT,997)X(L,J)
32423  997         FORMAT('       THE DISSIMILARITY IS ',G15.7)
32424              CALL DPWRST('XXX','BUG ')
32425              IERROR='YES'
32426              GOTO9000
32427            ENDIF
32428  991     CONTINUE
32429          DO980J=1,LSUBT
32430            NLJ=MEET(L,J)
32431            DYS(NLJ)=DVEC(J)
32432  980     CONTINUE
32433  990   CONTINUE
32434      ENDIF
32435C
32436      ISTEPN='3D'
32437      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PAM2')
32438     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
32439C
32440      IF(JHALT.EQ.1)GO TO 9000
32441C
32442      IF(IPRINT.EQ.'ON' .AND. LARGE.GE.1)THEN
32443CNIST   WRITE(LUB,9060)
32444C9060   FORMAT(//' DISSIMILARITY MATRIX'/1X,20(1H-)/)
32445CNIST   WRITE(LUB,9033)LAB(1,1),LAB(2,1),LAB(3,1)
32446C9033   FORMAT(1X,3A1,2X,8F9.2)
32447        WRITE(ICOUT,999)
32448        CALL DPWRST('XXX','BUG ')
32449        WRITE(ICOUT,999)
32450        CALL DPWRST('XXX','BUG ')
32451        WRITE(ICOUT,9060)
32452 9060   FORMAT('DISSIMILARITY MATRIX')
32453        CALL DPWRST('XXX','BUG ')
32454        WRITE(ICOUT,9061)
32455 9061   FORMAT('--------------------')
32456        CALL DPWRST('XXX','BUG ')
32457        LAB1='  1'
32458        WRITE(ICOUT,9062)LAB1
32459 9062   FORMAT(1X,A3)
32460        CALL DPWRST('XXX','BUG ')
32461C
32462        DO 120 L=2,NN
32463          LSUBT=L-1
32464          JPEND=LSUBT
32465          IF(LSUBT.GT.8)JPEND=8
32466          DO 110 J=1,LSUBT
32467            NLJ=MEET(L,J)
32468            DVEC(J)=DYS(NLJ)
32469  110     CONTINUE
32470CNIST     WRITE(LUB,9033)LAB(1,L),LAB(2,L),LAB(3,L),(DVEC(J),J=1,JPEND)
32471CNIST     IF(LSUBT.GT.8)WRITE(LUB,9040)(DVEC(J),J=9,LSUBT)
32472C9040     FORMAT(6X,8F9.2)
32473          IFORMT='(A3,   F9.2)'
32474          WRITE(IFORMT(5:7),'(I3)')LSUBT
32475          LAB1='000'
32476          WRITE(LAB1,'(I3)')L
32477          WRITE(IOUNI3,IFORMT)LAB1,(DVEC(JJ),JJ=1,LSUBT)
32478          ILOOP=LSUBT/8
32479          IREM=MOD(LSUBT,8)
32480          IF(IREM.GT.0)ILOOP=ILOOP+1
32481          DO125J=1,ILOOP
32482            ISTRT=(J-1)*8 + 1
32483            ISTOP=J*8
32484            IF(ISTOP.GT.LSUBT)ISTOP=LSUBT
32485            IF(J.EQ.1)THEN
32486              LAB1='000'
32487              IF(IPRINT.EQ.'ON')THEN
32488                WRITE(LAB1,'(I3)')L
32489                WRITE(ICOUT,9041)LAB1,(DVEC(JJ),JJ=ISTRT,ISTOP)
32490 9041           FORMAT(1X,A3,2X,8F9.2)
32491                CALL DPWRST('XXX','BUG ')
32492              ENDIF
32493            ELSE
32494              IF(IPRINT.EQ.'ON')THEN
32495                WRITE(ICOUT,9040)(DVEC(JJ),JJ=ISTRT,ISTOP)
32496 9040           FORMAT(6X,8F9.2)
32497                CALL DPWRST('XXX','BUG ')
32498              ENDIF
32499            ENDIF
32500  125     CONTINUE
32501  120   CONTINUE
32502      ENDIF
32503C
32504      S=0.0
32505      L=1
32506      NHALF=NN*(NN-1)/2 + 1
32507C
32508  130 CONTINUE
32509      L=L+1
32510      IF(DYS(L).GT.S)S=DYS(L)
32511      IF(L.LT.NHALF)GO TO 130
32512C
32513C     PAM CODE ALLOWS USER TO SPECIFY MINIMUM AND MAXIMUM VALUES
32514C     FOR THE CLUSTER.  FOR DATAPLOT, CURRENTLY RESTRICT TO A
32515C     SINGLE VALUE FOR THE NUMBER OF CLUSTERS.
32516C
32517CNIST DO 140 KK=KBEG,KEND
32518      DO 140 KK=NCLUST,NCLUST
32519        KMP=KK-1
32520        WRITE(ICOUT,999)
32521        CALL DPWRST('XXX','BUG ')
32522        WRITE(ICOUT,999)
32523        CALL DPWRST('XXX','BUG ')
32524        WRITE(ICOUT,9070)
32525 9070   FORMAT('**********************************************')
32526        CALL DPWRST('XXX','BUG ')
32527        WRITE(ICOUT,9071)
32528 9071   FORMAT('*',44X,'*')
32529        CALL DPWRST('XXX','BUG ')
32530        WRITE(ICOUT,9072)KK
32531 9072   FORMAT('*  NUMBER OF REPRESENTATIVE OBJECTS',I6,4X,'*')
32532        CALL DPWRST('XXX','BUG ')
32533        WRITE(ICOUT,9071)
32534        CALL DPWRST('XXX','BUG ')
32535        WRITE(ICOUT,9070)
32536        CALL DPWRST('XXX','BUG ')
32537C
32538        ISTEPN='3E'
32539        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PAM2')
32540     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
32541C
32542        CALL BSWAP(KK,NN,NREPR,RADUS,DAMER,TTD,DYS,SKY,S,IFLAG,
32543     1             LARGE,ISUBRO,IBUGA3)
32544C
32545        ISTEPN='3F'
32546        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PAM2')
32547     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
32548C
32549        WRITE(ICOUT,999)
32550        CALL DPWRST('XXX','BUG ')
32551        WRITE(ICOUT,9075)
32552 9075   FORMAT('FINAL RESULTS')
32553        CALL DPWRST('XXX','BUG ')
32554        RNN=NN
32555        ASKY=SKY/RNN
32556        WRITE(ICOUT,999)
32557        CALL DPWRST('XXX','BUG ')
32558        WRITE(ICOUT,9080)ASKY
32559 9080   FORMAT('  AVERAGE DISSIMILARITY = ',F12.3)
32560        CALL DPWRST('XXX','BUG ')
32561C
32562        ISTEPN='3G'
32563        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PAM2')
32564     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
32565C
32566CCCCC   CALL CSTAT(KK,NN,NSEND,NREPR,RADUS,DAMER,TTD,SEPAR,SKY,S,
32567        CALL CSTAT(KK,NN,NSEND,NREPR,RADUS,DAMER,TTD,SEPAR,S,
32568     1             DYS,NCLUV,NELEM,JPP,NROW,NCOL,X,JDYSS,NSTAN,
32569     1             IOUNI2,ISUBRO,IBUGA3)
32570C
32571        ISTEPN='3H'
32572        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PAM2')
32573     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
32574C
32575  140 CONTINUE
32576C
32577C               *****************************************
32578C               **   STEP 4B--                         **
32579C               **   CREATE VALUES FOR SILHOUETTE PLOT **
32580C               *****************************************
32581C
32582      ISTEPN='4B'
32583      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CWS2')
32584     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
32585C
32586C     COMPUTE THE s(i) VALUE AS
32587C
32588C        s(i) = (b(i) - a(i))/max{a(i),b(i)}
32589C
32590C     WHERE
32591C
32592C        a(i)   = AVERAGE DISSIMILARITY OF THE i-TH POINT WITH
32593C                 ALL OTHER POINTS IN THE CLUSTER TO WHICH IT
32594C                 BELONGS
32595C
32596C        b(i)   = LOWEST AVERAGE DISSIMILARITY OF THE i-TH POINT
32597C                 WITH ALL OTHER CLUSTERS.
32598C
32599C     USE ONE-PASS MEAN ALGORITHMS TO KEEP TRACK OF AVERAGE
32600C     DISSIMILARITY OF ALL CLUSTERS.  THE ONE-PASS FORMUALA IS
32601C
32602C         M(K)=X1                            K = 1
32603C             =M(K-1) + (X(K) - M(K-1))/K    K = 2, ...., N
32604C
32605      IF(JDYSS.EQ.1)THEN
32606C
32607        WRITE(IOUNI4,8101)
32608 8101   FORMAT(10X,'INDEX',8X,'CLUSTER',5X,'SILHOUETTE',7X,'NEIGHBOR')
32609C
32610        DO8105II=1,NROW
32611          WRITE(IOUNI1,'(I5)')NCLUV(II)
32612 8105   CONTINUE
32613C
32614C       CASE WHERE INPUT DATA IS A DISSIMILARITY MATRIX
32615C
32616        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PAM2')THEN
32617          WRITE(ICOUT,8111)NROW
32618 8111     FORMAT('DISSIMILARITY CASE: NROW = ',I5)
32619          CALL DPWRST('XXX','BUG ')
32620        ENDIF
32621C
32622        DO8110II=1,NROW
32623          ICLUS1=NCLUV(II)
32624C
32625          DO8114KK=1,NCLUST
32626            NSEND(KK)=0
32627 8114     CONTINUE
32628C
32629          DO8120JJ=1,NROW
32630            IF(II.EQ.JJ)GOTO8120
32631            ICLUS2=NCLUV(JJ)
32632            ADIST=X(II,JJ)
32633C
32634            IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PAM2')THEN
32635              WRITE(ICOUT,8117)II,JJ,ICLUS1,ICLUS2,ADIST
32636 8117         FORMAT('II,JJ,ICLUS1,ICLUS2,ADIST = ',4I5,G15.7)
32637              CALL DPWRST('XXX','BUG ')
32638            ENDIF
32639C
32640            IF(ICLUS1.EQ.ICLUS2)THEN
32641C
32642C             COMPUTE A(I) TERM
32643C
32644              NSEND(ICLUS1)=NSEND(ICLUS1)+1
32645              IF(NSEND(ICLUS1).EQ.1)THEN
32646                DVEC(ICLUS1)=ADIST
32647              ELSE
32648                TERM1=(ADIST - DVEC(ICLUS1))/REAL(NSEND(ICLUS1))
32649                DVEC(ICLUS1)=DVEC(ICLUS1) + TERM1
32650              ENDIF
32651            ELSE
32652              NSEND(ICLUS2)=NSEND(ICLUS2)+1
32653              IF(NSEND(ICLUS2).EQ.1)THEN
32654                DVEC(ICLUS2)=ADIST
32655              ELSE
32656                TERM1=(ADIST - DVEC(ICLUS2))/REAL(NSEND(ICLUS2))
32657                DVEC(ICLUS2)=DVEC(ICLUS2) + TERM1
32658              ENDIF
32659            ENDIF
32660 8120     CONTINUE
32661C
32662          AI=DVEC(ICLUS1)
32663          BI=CPUMAX
32664          NEIGH=-1
32665          DO8130JJ=1,NCLUST
32666            IF(JJ.EQ.ICLUS1)GOTO8130
32667            IF(DVEC(JJ).LT.BI)THEN
32668              BI=DVEC(JJ)
32669              NEIGH=JJ
32670            ENDIF
32671 8130     CONTINUE
32672          SYL=0.0
32673          IF(AI.LT.BI)THEN
32674            SYL=1.0 - (AI/BI)
32675          ELSEIF(AI.GT.BI)THEN
32676            SYL=(BI/AI) - 1.0
32677          ENDIF
32678CCCCC     SYL=(BI - AI)/MAX(AI,BI)
32679C
32680          WRITE(IOUNI4,'(4E15.7)')REAL(II),REAL(NCLUV(II)),SYL,
32681     1                            REAL(NEIGH)
32682C
32683          IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PAM2')THEN
32684            WRITE(ICOUT,8131)II,NCLUV(II),AI,BI,SYL
32685 8131       FORMAT('II,NCLUV(II),AI,BI,SYL = ',2I6,3G15.7)
32686            CALL DPWRST('XXX','BUG ')
32687          ENDIF
32688C
32689 8110   CONTINUE
32690      ELSE
32691C
32692        WRITE(IOUNI4,8201)
32693 8201   FORMAT(8X,'CLUSTER',5X,'SILHOUETTE',7X,'NEIGHBOR')
32694C
32695        DO8205II=1,NROW
32696          WRITE(IOUNI1,'(I5)')NCLUV(II)
32697 8205   CONTINUE
32698C
32699        DO8210II=1,NROW
32700          ICLUS1=NCLUV(II)
32701          DO8212JJ=1,NCOL
32702            DYSMA(JJ)=X(II,JJ)
32703 8212     CONTINUE
32704          ICASPL='VEDI'
32705          DO8214KK=1,NCLUST
32706            DVEC(KK)=CPUMIN
32707            NSEL(KK)=0
32708 8214     CONTINUE
32709C
32710          DO8220JJ=1,NROW
32711            IF(II.EQ.JJ)GOTO8220
32712            ICLUS2=NCLUV(JJ)
32713            DO8222KK=1,NCOL
32714              DYSMB(KK)=X(JJ,KK)
32715 8222       CONTINUE
32716            CALL VECARI(DYSMA,DYSMB,NCOL,ICASPL,IWRITE,
32717     1                  SEPAR,N3,ADIST,ITYP3,
32718     1                  IBUGA3,ISUBRO,IERROR)
32719            IF(ICLUS1.EQ.ICLUS2)THEN
32720              NSEL(ICLUS1)=NSEL(ICLUS1)+1
32721              IF(NSEL(ICLUS1).EQ.1)THEN
32722                DVEC(ICLUS1)=ADIST
32723              ELSE
32724                TERM1=(ADIST - DVEC(ICLUS1))/REAL(NSEL(ICLUS1))
32725                DVEC(ICLUS1)=DVEC(ICLUS1) + TERM1
32726              ENDIF
32727            ELSE
32728              NSEL(ICLUS2)=NSEL(ICLUS2)+1
32729              IF(NSEL(ICLUS2).EQ.1)THEN
32730                DVEC(ICLUS2)=ADIST
32731              ELSE
32732                TERM1=(ADIST - DVEC(ICLUS2))/REAL(NSEL(ICLUS2))
32733                DVEC(ICLUS2)=DVEC(ICLUS2) + TERM1
32734              ENDIF
32735            ENDIF
32736 8220     CONTINUE
32737C
32738          AI=DVEC(ICLUS1)
32739          BI=CPUMAX
32740          NEIGH=-1
32741          DO8230JJ=1,NCLUST
32742            IF(JJ.EQ.ICLUS1)GOTO8230
32743            IF(DVEC(JJ).LT.BI)THEN
32744              BI=DVEC(JJ)
32745              NEIGH=JJ
32746            ENDIF
32747 8230     CONTINUE
32748          SYL=(BI - AI)/MAX(AI,BI)
32749          WRITE(IOUNI4,'(3E15.7)')REAL(NCLUV(II)),SYL,REAL(NEIGH)
32750C
32751 8210   CONTINUE
32752      ENDIF
32753C
32754      IF(IFEEDB.EQ.'ON')THEN
32755        WRITE(ICOUT,999)
32756        CALL DPWRST('XXX','BUG ')
32757        WRITE(ICOUT,9085)
32758 9085   FORMAT('THIS RUN HAS BEEN SUCCESSFULLY COMPLETED.')
32759        CALL DPWRST('XXX','BUG ')
32760        WRITE(ICOUT,8091)
32761 8091   FORMAT('THE CLUSTER ID VALUES ARE WRITTEN TO dpst1f.dat')
32762        CALL DPWRST('XXX','BUG ')
32763CNIST   WRITE(ICOUT,8093)
32764C8093   FORMAT('THE WITHIN-CLUSTER SUM OF SQUARES AND ',
32765CNIST1         'THE NUMBER OF POINTS')
32766CNIST   CALL DPWRST('XXX','BUG ')
32767        WRITE(ICOUT,8095)
32768 8095   FORMAT('COORDINATES OF MEDOIDS ARE WRITTEN TO dpst2f.dat')
32769        CALL DPWRST('XXX','BUG ')
32770        WRITE(ICOUT,8097)
32771 8097   FORMAT('THE DISSIMILARITY MATRIX IS WRITTEN TO dpst3f.dat')
32772        CALL DPWRST('XXX','BUG ')
32773        IF(NROW*NCOL.LE.2*MAXNXT)THEN
32774          WRITE(ICOUT,8099)
32775 8099     FORMAT('THE SILHOUETTE VALUES ARE WRITTEN TO dpst4f.dat')
32776          CALL DPWRST('XXX','BUG ')
32777        ENDIF
32778      ENDIF
32779C
32780C               ******************
32781C               **   STEP 90--  **
32782C               **   EXIT       **
32783C               ******************
32784C
32785 9000 CONTINUE
32786C
32787      IF(IFLAGO.EQ.1)THEN
32788        IOP='CLOS'
32789        CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLAG4,IFLAG5,
32790     1              IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
32791     1              IBUGA3,ISUBRO,IERROR)
32792      ENDIF
32793C
32794      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PAM2')THEN
32795        WRITE(ICOUT,999)
32796        CALL DPWRST('XXX','BUG ')
32797        WRITE(ICOUT,9011)
32798 9011   FORMAT('***** AT THE END       OF DPPAM2--')
32799        CALL DPWRST('XXX','BUG ')
32800      ENDIF
32801C
32802      RETURN
32803      END
32804      SUBROUTINE DPPAPA(IHARG,NUMARG,IDEFPP,MAXPAT,IPATPA,
32805     1IBUGP2,IFOUND,IERROR)
32806C
32807C     PURPOSE--DEFINE THE PATTERN (PATTERNS).
32808C              THESE ARE LOCATED IN THE VECTOR IPATPA(.).
32809C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
32810C                     --NUMARG
32811C                     --IDEFPP
32812C                     --MAXPAT
32813C                     --IBUGP2 ('ON' OR 'OFF' )
32814C     OUTPUT ARGUMENTS--IPATPA (A CHARACTER VECTOR)
32815C                     --IFOUND ('YES' OR 'NO' )
32816C                     --IERROR ('YES' OR 'NO' )
32817C     WRITTEN BY--JAMES J. FILLIBEN
32818C                 STATISTICAL ENGINEERING DIVISION
32819C                 INFORMATION TECHNOLOGY LABORATORY
32820C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
32821C                 GAITHERSBURG, MD 20899-8980
32822C                 PHONE--301-975-2899
32823C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
32824C           OF THE NATIONAL BUREAU OF STANDARDS.
32825C     LANGUAGE--ANSI FORTRAN (1977)
32826C     VERSION NUMBER--82/7
32827C     ORIGINAL VERSION--DECEMBER  1983.
32828C
32829C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
32830C
32831      CHARACTER*4 IHARG
32832      CHARACTER*4 IDEFPP
32833      CHARACTER*4 IPATPA
32834C
32835      CHARACTER*4 IBUGP2
32836      CHARACTER*4 IFOUND
32837      CHARACTER*4 IERROR
32838C
32839      CHARACTER*4 IHOLD1
32840      CHARACTER*4 IHOLD2
32841C
32842      CHARACTER*4 ISUBN1
32843      CHARACTER*4 ISUBN2
32844      CHARACTER*4 ISTEPN
32845C
32846      DIMENSION IHARG(*)
32847      DIMENSION IPATPA(*)
32848C
32849C---------------------------------------------------------------------
32850C
32851      INCLUDE 'DPCOP2.INC'
32852C
32853C-----START POINT-----------------------------------------------------
32854C
32855      IFOUND='NO'
32856      IERROR='NO'
32857      ISUBN1='DPPA'
32858      ISUBN2='PA  '
32859C
32860      NUMPAT=0
32861      IHOLD1='-999'
32862      IHOLD2='-999'
32863C
32864      IF(IBUGP2.EQ.'OFF')GOTO90
32865      WRITE(ICOUT,999)
32866  999 FORMAT(1X)
32867      CALL DPWRST('XXX','BUG ')
32868      WRITE(ICOUT,51)
32869   51 FORMAT('***** AT THE BEGINNING OF DPPAPA--')
32870      CALL DPWRST('XXX','BUG ')
32871      WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR
32872   52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
32873      CALL DPWRST('XXX','BUG ')
32874      WRITE(ICOUT,53)MAXPAT,NUMPAT
32875   53 FORMAT('MAXPAT,NUMPAT = ',I8,I8)
32876      CALL DPWRST('XXX','BUG ')
32877      WRITE(ICOUT,54)IHOLD1,IHOLD2
32878   54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
32879      CALL DPWRST('XXX','BUG ')
32880      WRITE(ICOUT,55)IDEFPP
32881   55 FORMAT('IDEFPP = ',A4)
32882      CALL DPWRST('XXX','BUG ')
32883      WRITE(ICOUT,60)NUMARG
32884   60 FORMAT('NUMARG = ',I8)
32885      CALL DPWRST('XXX','BUG ')
32886      DO65I=1,NUMARG
32887      WRITE(ICOUT,66)IHARG(I)
32888   66 FORMAT('IHARG(I) = ',A4)
32889      CALL DPWRST('XXX','BUG ')
32890   65 CONTINUE
32891      WRITE(ICOUT,70)IPATPA(1)
32892   70 FORMAT('IPATPA(1) = ',A4)
32893      CALL DPWRST('XXX','BUG ')
32894      DO75I=1,10
32895      WRITE(ICOUT,76)I,IPATPA(I)
32896   76 FORMAT('I,IPATPA(I) = ',I8,2X,A4)
32897      CALL DPWRST('XXX','BUG ')
32898   75 CONTINUE
32899   90 CONTINUE
32900C
32901C               **************************************
32902C               **  STEP 1--                        **
32903C               **  BRANCH TO THE APPROPRIATE CASE  **
32904C               **************************************
32905C
32906      ISTEPN='1'
32907      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
32908C
32909      IF(NUMARG.LE.0)GOTO1100
32910      IF(NUMARG.EQ.1)GOTO1110
32911      IF(NUMARG.EQ.2)GOTO1120
32912      GOTO1130
32913C
32914 1100 CONTINUE
32915      GOTO1200
32916C
32917 1110 CONTINUE
32918      IF(IHARG(1).EQ.'ALL')IHOLD1='    '
32919      IF(IHARG(1).EQ.'ALL')GOTO1300
32920      GOTO1200
32921C
32922 1120 CONTINUE
32923      IF(IHARG(1).EQ.'ALL')IHOLD1=IHARG(2)
32924      IF(IHARG(1).EQ.'ALL')GOTO1300
32925      IF(IHARG(2).EQ.'ALL')IHOLD1=IHARG(1)
32926      IF(IHARG(2).EQ.'ALL')GOTO1300
32927      GOTO1200
32928C
32929 1130 CONTINUE
32930      GOTO1200
32931C
32932C               *************************************************
32933C               **  STEP 2--                                   **
32934C               **  TREAT THE INDIVIDUAL SPECIFICATIONS CASE  **
32935C               *************************************************
32936C
32937 1200 CONTINUE
32938      ISTEPN='2'
32939      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
32940C
32941      IF(NUMARG.LE.0)GOTO1210
32942      GOTO1220
32943C
32944 1210 CONTINUE
32945      NUMPAT=1
32946      IPATPA(1)='    '
32947      GOTO1270
32948C
32949 1220 CONTINUE
32950      NUMPAT=NUMARG
32951      IF(NUMPAT.GT.MAXPAT)NUMPAT=MAXPAT
32952      DO1225I=1,NUMPAT
32953      J=I
32954      IHOLD1=IHARG(J)
32955      IHOLD2=IHOLD1
32956      IF(IHOLD1.EQ.'ON')IHOLD2='SOLI'
32957      IF(IHOLD1.EQ.'OFF')IHOLD2='    '
32958      IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEFPP
32959      IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEFPP
32960      IPATPA(I)=IHOLD2
32961 1225 CONTINUE
32962      GOTO1270
32963C
32964 1270 CONTINUE
32965      IF(IFEEDB.EQ.'OFF')GOTO1279
32966      WRITE(ICOUT,999)
32967      CALL DPWRST('XXX','BUG ')
32968      DO1278I=1,NUMPAT
32969      WRITE(ICOUT,1276)I,IPATPA(I)
32970 1276 FORMAT('PATTERN ',I6,' HAS JUST BEEN SET TO ',
32971     1A4)
32972      CALL DPWRST('XXX','BUG ')
32973 1278 CONTINUE
32974 1279 CONTINUE
32975      IFOUND='YES'
32976      GOTO9000
32977C
32978C               **************************
32979C               **  STEP 2--            **
32980C               **  TREAT THE ALL CASE  **
32981C               **************************
32982C
32983 1300 CONTINUE
32984      ISTEPN='3'
32985      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
32986C
32987      NUMPAT=MAXPAT
32988      IHOLD2=IHOLD1
32989      IF(IHOLD1.EQ.'ON')IHOLD2='SOLI'
32990      IF(IHOLD1.EQ.'OFF')IHOLD2='    '
32991      IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEFPP
32992      IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEFPP
32993      DO1315I=1,NUMPAT
32994      IPATPA(I)=IHOLD2
32995 1315 CONTINUE
32996      GOTO1370
32997C
32998 1370 CONTINUE
32999      IF(IFEEDB.EQ.'OFF')GOTO1319
33000      WRITE(ICOUT,999)
33001      CALL DPWRST('XXX','BUG ')
33002      I=1
33003      WRITE(ICOUT,1316)IPATPA(I)
33004 1316 FORMAT('ALL PATTERNS HAVE JUST BEEN SET TO ',
33005     1A4)
33006      CALL DPWRST('XXX','BUG ')
33007 1319 CONTINUE
33008      IFOUND='YES'
33009      GOTO9000
33010C
33011C               *****************
33012C               **  STEP 90--  **
33013C               **  EXIT       **
33014C               *****************
33015C
33016 9000 CONTINUE
33017      IF(IBUGP2.EQ.'OFF')GOTO9090
33018      WRITE(ICOUT,9011)
33019 9011 FORMAT('***** AT THE END       OF DPPAPA--')
33020      CALL DPWRST('XXX','BUG ')
33021      WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR
33022 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
33023      CALL DPWRST('XXX','BUG ')
33024      WRITE(ICOUT,9013)MAXPAT,NUMPAT
33025 9013 FORMAT('MAXPAT,NUMPAT = ',I8,I8)
33026      CALL DPWRST('XXX','BUG ')
33027      WRITE(ICOUT,9014)IHOLD1,IHOLD2
33028 9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
33029      CALL DPWRST('XXX','BUG ')
33030      WRITE(ICOUT,9015)IDEFPP
33031 9015 FORMAT('IDEFPP = ',A4)
33032      CALL DPWRST('XXX','BUG ')
33033      WRITE(ICOUT,9020)NUMARG
33034 9020 FORMAT('NUMARG = ',I8)
33035      CALL DPWRST('XXX','BUG ')
33036      DO9025I=1,NUMARG
33037      WRITE(ICOUT,9026)IHARG(I)
33038 9026 FORMAT('IHARG(I) = ',A4)
33039      CALL DPWRST('XXX','BUG ')
33040 9025 CONTINUE
33041      WRITE(ICOUT,9030)IPATPA(1)
33042 9030 FORMAT('IPATPA(1) = ',A4)
33043      CALL DPWRST('XXX','BUG ')
33044      DO9035I=1,10
33045      WRITE(ICOUT,9036)I,IPATPA(I)
33046 9036 FORMAT('I,IPATPA(I) = ',I8,2X,A4)
33047      CALL DPWRST('XXX','BUG ')
33048 9035 CONTINUE
33049 9090 CONTINUE
33050C
33051      RETURN
33052      END
33053      SUBROUTINE DPPARE(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
33054CCCCC1ICONT,IDIREC,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
33055     1ICONT,IDIREC,ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
33056C
33057C     PURPOSE--GENERATE A PARETO PLOT
33058C              (AN ORDERED--HIGH TO LOW) PLOT)
33059C     WRITTEN BY--JAMES J. FILLIBEN
33060C                 STATISTICAL ENGINEERING DIVISION
33061C                 INFORMATION TECHNOLOGY LABORATORY
33062C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
33063C                 GAITHERSBURG, MD 20899-8980
33064C                 PHONE--301-975-2899
33065C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
33066C           OF THE NATIONAL BUREAU OF STANDARDS.
33067C     LANGUAGE--ANSI FORTRAN (1977)
33068C     VERSION NUMBER--88/8
33069C     ORIGINAL VERSION--AUGUST    1988.
33070C     UPDATED         --JUNE      1990. TEMPORARY ARRAYS TO GARBAGE COMMON
33071C
33072C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
33073C
33074      CHARACTER*4 ICASPL
33075      CHARACTER*4 IAND1
33076      CHARACTER*4 IAND2
33077      CHARACTER*4 ICONT
33078      CHARACTER*4 IDIREC
33079CCCCC THE FOLLOWING LINE WAS ADDED     DECEMBER 1994
33080      CHARACTER*4 ISUBRO
33081      CHARACTER*4 IBUGG2
33082      CHARACTER*4 IBUGG3
33083      CHARACTER*4 IBUGQ
33084      CHARACTER*4 IFOUND
33085      CHARACTER*4 IERROR
33086C
33087      CHARACTER*4 IHLEFT
33088      CHARACTER*4 IHLEF2
33089      CHARACTER*4 IHHOR
33090      CHARACTER*4 IHHOR2
33091      CHARACTER*4 IHWUSE
33092      CHARACTER*4 MESSAG
33093      CHARACTER*4 ICASEQ
33094CCCCC CHARACTER*4 IH
33095CCCCC CHARACTER*4 IH2
33096CCCCC CHARACTER*4 IERRO2
33097C
33098      CHARACTER*4 ISUBN1
33099      CHARACTER*4 ISUBN2
33100      CHARACTER*4 ISTEPN
33101C
33102C---------------------------------------------------------------------
33103C
33104      INCLUDE 'DPCOPA.INC'
33105C
33106      DIMENSION Y1(MAXOBV)
33107      DIMENSION X1(MAXOBV)
33108C
33109      DIMENSION XIDTEM(MAXOBV)
33110      DIMENSION TEMP(MAXOBV)
33111CCCCC FOLLOWING LINES ADDED JUNE, 1990
33112      INCLUDE 'DPCOZZ.INC'
33113      EQUIVALENCE (GARBAG(IGARB1),X1(1))
33114      EQUIVALENCE (GARBAG(IGARB2),Y1(1))
33115      EQUIVALENCE (GARBAG(IGARB3),XIDTEM(1))
33116      EQUIVALENCE (GARBAG(IGARB4),TEMP(1))
33117CCCCC END CHANGE
33118C
33119C-----COMMON----------------------------------------------------------
33120C
33121      INCLUDE 'DPCOHK.INC'
33122      INCLUDE 'DPCODA.INC'
33123      INCLUDE 'DPCOP2.INC'
33124C
33125C-----START POINT-----------------------------------------------------
33126C
33127      IERROR='NO'
33128      ISUBN1='DPPA'
33129      ISUBN2='RE  '
33130C
33131      MAXCP1=MAXCOL+1
33132      MAXCP2=MAXCOL+2
33133      MAXCP3=MAXCOL+3
33134      MAXCP4=MAXCOL+4
33135      MAXCP5=MAXCOL+5
33136      MAXCP6=MAXCOL+6
33137C
33138      MAXV2=2
33139      MINN2=2
33140      ICOLH=0
33141C
33142C               **********************************
33143C               **  TREAT THE PARETO PLOT CASE  **
33144C               **********************************
33145C
33146      IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'PARE')GOTO90
33147      WRITE(ICOUT,999)
33148  999 FORMAT(1X)
33149      CALL DPWRST('XXX','BUG ')
33150      WRITE(ICOUT,51)
33151   51 FORMAT('***** AT THE BEGINNING OF DPPARE--')
33152      CALL DPWRST('XXX','BUG ')
33153      WRITE(ICOUT,52)ICASPL,IAND1,IAND2
33154   52 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4)
33155      CALL DPWRST('XXX','BUG ')
33156      WRITE(ICOUT,53)ICONT,IBUGG2,IBUGG3,IBUGQ
33157   53 FORMAT('ICONT,IBUGG2,IBUGG3,IBUGQ = ',A4,2X,A4,2X,A4,2X,A4)
33158      CALL DPWRST('XXX','BUG ')
33159      WRITE(ICOUT,54)IDIREC
33160   54 FORMAT('IDIREC = ',A4)
33161      CALL DPWRST('XXX','BUG ')
33162   90 CONTINUE
33163C
33164C               ***************************
33165C               **  STEP 1--             **
33166C               **  EXTRACT THE COMMAND  **
33167C               ***************************
33168C
33169      ISTEPN='1'
33170      IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
33171C
33172      ICASPL='PAPL'
33173      IF(NUMARG.GE.1.AND.
33174     1ICOM.EQ.'PARE'.AND.IHARG(1).EQ.'PLOT')
33175     1GOTO111
33176C
33177      ICASPL='    '
33178      IFOUND='NO'
33179      GOTO9000
33180C
33181  111 CONTINUE
33182      ILASTC=1
33183      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
33184      IFOUND='YES'
33185      GOTO190
33186C
33187  190 CONTINUE
33188C
33189C               ***********************************************************
33190C               **  STEP 1--                                             **
33191C               **  CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS.      **
33192C               ***********************************************************
33193C
33194      ISTEPN='1'
33195      IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
33196C
33197      MINNA=1
33198      MAXNA=100
33199      CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR)
33200      IF(IERROR.EQ.'YES')GOTO9000
33201C
33202C               ********************************************
33203C               **  STEP 2--                              **
33204C               **  CHECK THE VALIDITY OF ARGUMENT 1      **
33205C               **  (THIS WILL BE THE RESPONSE VARIABLE)  **
33206C               ********************************************
33207C
33208      ISTEPN='2'
33209      IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
33210C
33211      IHLEFT=IHARG(1)
33212      IHLEF2=IHARG2(1)
33213      IHWUSE='V'
33214      MESSAG='YES'
33215      CALL CHECKN(IHLEFT,IHLEF2,IHWUSE,
33216     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
33217     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
33218      IF(IERROR.EQ.'YES')GOTO9000
33219      ICOLL=IVALUE(ILOCV)
33220      NLEFT=IN(ILOCV)
33221      IF(IBUGG2.EQ.'ON')WRITE(ICOUT,211)IHLEFT,ICOLL,NLEFT
33222  211 FORMAT('IHLEFT,ICOLL,NLEFT = ',A4,I8,I8)
33223      IF(IBUGG2.EQ.'ON')CALL DPWRST('XXX','BUG ')
33224C
33225C               ***************************************************************
33226C               **  STEP 3--                                                 **
33227C               **  CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (NLEFT)      **
33228C               **  FOR THE RESPONSE VARIABLE IS 2 OR LARGER.                **
33229C               ***************************************************************
33230C
33231      ISTEPN='3'
33232      IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
33233C
33234      IF(NLEFT.GE.MINN2)GOTO390
33235      WRITE(ICOUT,999)
33236      CALL DPWRST('XXX','BUG ')
33237      WRITE(ICOUT,311)
33238  311 FORMAT('***** ERROR IN DPPARE--')
33239      CALL DPWRST('XXX','BUG ')
33240      WRITE(ICOUT,312)
33241  312 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
33242      CALL DPWRST('XXX','BUG ')
33243      WRITE(ICOUT,321)
33244  321 FORMAT('      (FOR WHICH A PARETO PLOT ')
33245      CALL DPWRST('XXX','BUG ')
33246      WRITE(ICOUT,314)
33247  314 FORMAT('      WAS TO HAVE BEEN FORMED)')
33248      CALL DPWRST('XXX','BUG ')
33249      WRITE(ICOUT,315)MINN2
33250  315 FORMAT('      MUST BE ',I8,' OR LARGER;')
33251      CALL DPWRST('XXX','BUG ')
33252      WRITE(ICOUT,316)
33253  316 FORMAT('      SUCH WAS NOT THE CASE HERE.')
33254      CALL DPWRST('XXX','BUG ')
33255      WRITE(ICOUT,317)
33256  317 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
33257      CALL DPWRST('XXX','BUG ')
33258      IF(IWIDTH.GE.1)WRITE(ICOUT,318)(IANS(I),I=1,IWIDTH)
33259  318 FORMAT('      ',80A1)
33260      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
33261      IERROR='YES'
33262      GOTO9000
33263  390 CONTINUE
33264C
33265C               *****************************************
33266C               **  STEP 4--                           **
33267C               **  CHECK TO SEE THE TYPE SUBCASE      **
33268C               **  (BASED ON THE QUALIFIER)--         **
33269C               **    1) UNQUALIFIED (THAT IS, FULL);  **
33270C               **    2) SUBSET/EXCEPT; OR             **
33271C               **    3) FOR.                          **
33272C               *****************************************
33273C
33274      ISTEPN='4'
33275      IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
33276C
33277      ICASEQ='FULL'
33278      ILOCQ=NUMARG+1
33279      IF(NUMARG.LT.1)GOTO480
33280      DO400J=1,NUMARG
33281      J1=J
33282      IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET  ') GOTO410
33283      IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT  ') GOTO410
33284      IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.'    ') GOTO420
33285  400 CONTINUE
33286      GOTO490
33287  410 CONTINUE
33288      ICASEQ='SUBS'
33289      ILOCQ=J1
33290      GOTO490
33291  420 CONTINUE
33292      ICASEQ='FOR'
33293      ILOCQ=J1
33294      GOTO490
33295C
33296  480 CONTINUE
33297      WRITE(ICOUT,999)
33298      CALL DPWRST('XXX','BUG ')
33299      WRITE(ICOUT,481)
33300  481 FORMAT('***** INTERNAL ERROR IN DPPARE')
33301      CALL DPWRST('XXX','BUG ')
33302      WRITE(ICOUT,482)
33303  482 FORMAT('      AT BRANCH POINT 481--')
33304      CALL DPWRST('XXX','BUG ')
33305      WRITE(ICOUT,483)
33306  483 FORMAT('      NUMARG LESS THAN 1 EVEN THOUGH')
33307      CALL DPWRST('XXX','BUG ')
33308      WRITE(ICOUT,484)
33309  484 FORMAT('      NUMARG HAD PREVIOUSLY PASSED THIS TEST')
33310      CALL DPWRST('XXX','BUG ')
33311      WRITE(ICOUT,485)NUMARG
33312  485 FORMAT('      ONCE ALREADY.  VALUE OF NUMARG = ',I8)
33313      CALL DPWRST('XXX','BUG ')
33314      WRITE(ICOUT,486)
33315  486 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
33316      CALL DPWRST('XXX','BUG ')
33317      IF(IWIDTH.GE.1)WRITE(ICOUT,487)(IANS(I),I=1,IWIDTH)
33318  487 FORMAT('      ',80A1)
33319      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
33320      IERROR='YES'
33321      GOTO9000
33322C
33323  490 CONTINUE
33324      IF(IBUGG2.EQ.'OFF')GOTO495
33325      WRITE(ICOUT,491)NUMARG,ILOCQ,ICASEQ
33326  491 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4)
33327      CALL DPWRST('XXX','BUG ')
33328  495 CONTINUE
33329C
33330C               ************************************************************
33331C               **  STEP 5--                                              **
33332C               **  IF A SECOND ARGUMENT EXISTS, THEN THIS                **
33333C               **  IS BOTH THE HORIZONTAL AXIS VARIABLE VALUE, AND       **
33334C               **  THE CHARACTER TAG.                                    **
33335C               **  THE VALUES IN THE SECOND VARIABLE                     **
33336C               **  NEED NOT HAVE BEEN PREVIOUSLY                         **
33337C               **  SORTED OR HAVE COMMON VALUES ADJACENT.                **
33338C               **  IF WE HAVE THE 2-VARIABLE CASE,                       **
33339C               **  CHECK THE VALIDITY OF THE SECOND (X) VARIABLE.        **
33340C               ************************************************************
33341C
33342      ISTEPN='5'
33343      IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
33344C
33345      NUMV2=ILOCQ-1
33346      IF(NUMV2.EQ.1)GOTO590
33347      IF(NUMV2.EQ.2)GOTO530
33348      GOTO510
33349C
33350  510 CONTINUE
33351      WRITE(ICOUT,999)
33352      CALL DPWRST('XXX','BUG ')
33353      WRITE(ICOUT,511)
33354  511 FORMAT('***** ERROR IN DPPARE--')
33355      CALL DPWRST('XXX','BUG ')
33356      WRITE(ICOUT,512)
33357  512 FORMAT('      FOR A PARETO PLOT, ')
33358      CALL DPWRST('XXX','BUG ')
33359      WRITE(ICOUT,518)
33360  518 FORMAT('      THE NUMBER OF VARIABLES ')
33361      CALL DPWRST('XXX','BUG ')
33362      WRITE(ICOUT,519)
33363  519 FORMAT('      MUST BE EITHER 1 OR 2  ;')
33364      CALL DPWRST('XXX','BUG ')
33365      WRITE(ICOUT,520)
33366  520 FORMAT('      SUCH WAS NOT THE CASE HERE;')
33367      CALL DPWRST('XXX','BUG ')
33368      WRITE(ICOUT,521)
33369  521 FORMAT('      THE SPECIFIED NUMBER')
33370      CALL DPWRST('XXX','BUG ')
33371      WRITE(ICOUT,522)NUMV2
33372  522 FORMAT('      OF VARIABLES WAS ',I8)
33373      CALL DPWRST('XXX','BUG ')
33374      WRITE(ICOUT,523)
33375  523 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
33376      CALL DPWRST('XXX','BUG ')
33377      IF(IWIDTH.GE.1)WRITE(ICOUT,524)(IANS(I),I=1,IWIDTH)
33378  524 FORMAT('      ',80A1)
33379      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
33380      IERROR='YES'
33381      GOTO9000
33382C
33383  530 CONTINUE
33384      IHHOR=IHARG(2)
33385      IHHOR2=IHARG2(2)
33386      IHWUSE='V'
33387      MESSAG='YES'
33388      CALL CHECKN(IHHOR,IHHOR2,IHWUSE,
33389     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
33390     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
33391      IF(IERROR.EQ.'YES')GOTO9000
33392      ICOLH=IVALUE(ILOCV)
33393      NHOR=IN(ILOCV)
33394      IF(IBUGG2.EQ.'ON')WRITE(ICOUT,531)IHHOR,ICOLH,NHOR
33395  531 FORMAT('IHHOR,ICOLH,NHOR   = ',A4,I8,I8)
33396      IF(IBUGG2.EQ.'ON')CALL DPWRST('XXX','BUG ')
33397C
33398      IF(NHOR.NE.NLEFT)GOTO570
33399      GOTO590
33400C
33401  570 CONTINUE
33402      WRITE(ICOUT,999)
33403      CALL DPWRST('XXX','BUG ')
33404      WRITE(ICOUT,571)
33405  571 FORMAT('***** ERROR IN DPPARE--')
33406      CALL DPWRST('XXX','BUG ')
33407      WRITE(ICOUT,572)
33408  572 FORMAT('      FOR A PARETO PLOT, ')
33409      CALL DPWRST('XXX','BUG ')
33410      WRITE(ICOUT,578)
33411  578 FORMAT('      WHEN HAVE 2 VARAIBLES SPECIFIED, ')
33412      CALL DPWRST('XXX','BUG ')
33413      WRITE(ICOUT,579)
33414  579 FORMAT('      THE NUMBER OF ELEMENTS')
33415      CALL DPWRST('XXX','BUG ')
33416      WRITE(ICOUT,580)
33417  580 FORMAT('      IN THE 2 VARIABLES ')
33418      CALL DPWRST('XXX','BUG ')
33419      WRITE(ICOUT,581)
33420  581 FORMAT('      MUST BE THE SAME; ')
33421      CALL DPWRST('XXX','BUG ')
33422      WRITE(ICOUT,582)
33423  582 FORMAT('      SUCH WAS NOT THE CASE HERE.')
33424      CALL DPWRST('XXX','BUG ')
33425      WRITE(ICOUT,999)
33426      CALL DPWRST('XXX','BUG ')
33427      WRITE(ICOUT,583)
33428  583 FORMAT('      THE FIRST  VARIABLE  (RESPONSE VALUES)--')
33429      CALL DPWRST('XXX','BUG ')
33430      WRITE(ICOUT,584)IHLEFT,NLEFT
33431  584 FORMAT('                  ',A4,'  HAS ',I8,' ELEMENTS')
33432      CALL DPWRST('XXX','BUG ')
33433      WRITE(ICOUT,585)
33434  585 FORMAT('      THE SECOND VARIABLE  (HORIZ. AXIS VALUES)--')
33435      CALL DPWRST('XXX','BUG ')
33436      WRITE(ICOUT,586)IHHOR,NHOR
33437  586 FORMAT('                  ',A4,'  HAS ',I8,' ELEMENTS')
33438      CALL DPWRST('XXX','BUG ')
33439      WRITE(ICOUT,999)
33440      CALL DPWRST('XXX','BUG ')
33441      WRITE(ICOUT,587)
33442  587 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
33443      CALL DPWRST('XXX','BUG ')
33444      IF(IWIDTH.GE.1)WRITE(ICOUT,588)(IANS(I),I=1,IWIDTH)
33445  588 FORMAT('      ',80A1)
33446      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
33447      IERROR='YES'
33448      GOTO9000
33449C
33450  590 CONTINUE
33451C
33452C               *************************************************
33453C               **  STEP 6--                                   **
33454C               **  BRANCH TO THE APPROPRIATE SUBCASE;         **
33455C               **  (BASED ON THE QUALIFIER)                   **
33456C               **  THEN FORM THE RESPONSE VARIABLE            **
33457C               **  AND THE SECOND VARIABLE (IF EXISTENT)      **
33458C               *************************************************
33459C
33460      ISTEPN='6'
33461      IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
33462C
33463      IF(ICASEQ.EQ.'FULL')GOTO610
33464      IF(ICASEQ.EQ.'SUBS')GOTO620
33465      IF(ICASEQ.EQ.'FOR')GOTO630
33466C
33467  610 CONTINUE
33468      DO615I=1,NLEFT
33469      ISUB(I)=1
33470  615 CONTINUE
33471      NQ=NLEFT
33472      GOTO650
33473C
33474  620 CONTINUE
33475      NIOLD=NLEFT
33476      CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR)
33477      NQ=NIOLD
33478      GOTO650
33479C
33480  630 CONTINUE
33481      NIOLD=NLEFT
33482      CALL DPFOR(NIOLD,NFOR,IROW1,IROWN,
33483     1NLOCAL,ILOCS,NS,IBUGQ,IERROR)
33484      NQ=NFOR
33485      GOTO650
33486C
33487  650 CONTINUE
33488      J=0
33489      IMAX=NLEFT
33490      IF(NQ.LT.NLEFT)IMAX=NQ
33491      DO660I=1,IMAX
33492      IF(ISUB(I).EQ.0)GOTO660
33493      J=J+1
33494C
33495      IJ=MAXN*(ICOLL-1)+I
33496      IF(ICOLL.LE.MAXCOL)Y1(J)=V(IJ)
33497      IF(ICOLL.EQ.MAXCP1)Y1(J)=PRED(I)
33498      IF(ICOLL.EQ.MAXCP2)Y1(J)=RES(I)
33499      IF(ICOLL.EQ.MAXCP3)Y1(J)=YPLOT(I)
33500      IF(ICOLL.EQ.MAXCP4)Y1(J)=XPLOT(I)
33501      IF(ICOLL.EQ.MAXCP5)Y1(J)=X2PLOT(I)
33502      IF(ICOLL.EQ.MAXCP6)Y1(J)=TAGPLO(I)
33503      IF(NUMV2.LE.1)GOTO660
33504C
33505      IJ=MAXN*(ICOLH-1)+I
33506      IF(ICOLH.LE.MAXCOL)X1(J)=V(IJ)
33507      IF(ICOLH.EQ.MAXCP1)X1(J)=PRED(I)
33508      IF(ICOLH.EQ.MAXCP2)X1(J)=RES(I)
33509      IF(ICOLH.EQ.MAXCP3)X1(J)=YPLOT(I)
33510      IF(ICOLH.EQ.MAXCP4)X1(J)=XPLOT(I)
33511      IF(ICOLH.EQ.MAXCP5)X1(J)=X2PLOT(I)
33512      IF(ICOLH.EQ.MAXCP6)X1(J)=TAGPLO(I)
33513C
33514  660 CONTINUE
33515      NLOCAL=J
33516C
33517C               *************************************************************
33518C               **  STEP 8--                                               **
33519C               **  FORM THE VERTICAL AND HORIZONTAL AXIS                  **
33520C               **  VALUES Y(.) AND X(.) FOR THE PLOT.                     **
33521C               **  DEFINE THE VECTOR D(.) TO 1'S, 2'S, AND 3'S            **
33522C               **  FOR THE PLOTTED VALUE, THE LOWER CONFIDENCE LINE,      **
33523C               **  AND THE UPPER CONFIDENCE LINE.                         **
33524C               **  DEFINE THE NUMBER OF PLOT POINTS    (NPLOTP).          **
33525C               **  DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV).          **
33526C               *************************************************************
33527C
33528      ISTEPN='8'
33529      IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
33530C
33531C
33532CCCCC THE FOLLOWING SECTION WAS ADDED DECEMBER 1994
33533      MAXTAG=NLOCAL
33534      IF(NUMV2.GE.2)THEN
33535         MAXTAG=INT(X1(1) + 0.1)
33536         DO820I=1,NLOCAL
33537            IF(X1(I).GT.MAXTAG)MAXTAG=INT(X1(I)+0.1)
33538  820    CONTINUE
33539      ENDIF
33540C
33541CCCCC MAXTAG WAS ADDED AS AN ARGUMENT BELOW     DECEMBER 1994
33542CCCCC ISUBRO WAS ADDED AS AN ARGUMENT BELOW     DECEMBER 1994
33543      CALL DPPAR2(Y1,X1,NLOCAL,NUMV2,MAXTAG,ICASPL,ICONT,IDIREC,
33544CCCCC1Y,X,D,NPLOTP,NPLOTV,IBUGG3,IERROR)
33545     1Y,X,D,NPLOTP,NPLOTV,ISUBRO,IBUGG3,IERROR)
33546C
33547C               *****************
33548C               **  STEP 90--  **
33549C               **  EXIT       **
33550C               *****************
33551C
33552 9000 CONTINUE
33553      IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'PARE')GOTO9090
33554      WRITE(ICOUT,999)
33555      CALL DPWRST('XXX','BUG ')
33556      WRITE(ICOUT,9011)
33557 9011 FORMAT('***** AT THE END       OF DPPARE--')
33558      CALL DPWRST('XXX','BUG ')
33559      WRITE(ICOUT,9012)IFOUND,IERROR
33560 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
33561      CALL DPWRST('XXX','BUG ')
33562      WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
33563 9013 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',
33564     1I8,I8,I8,2X,A4,2X,A4,2X,A4)
33565      CALL DPWRST('XXX','BUG ')
33566      WRITE(ICOUT,9014)IDIREC
33567 9014 FORMAT('IDIREC = ',A4)
33568      CALL DPWRST('XXX','BUG ')
33569      IF(NPLOTP.LE.0)GOTO9090
33570      DO9015I=1,NPLOTP
33571      WRITE(ICOUT,9016)I,Y(I),X(I),D(I)
33572 9016 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5)
33573      CALL DPWRST('XXX','BUG ')
33574 9015 CONTINUE
33575 9090 CONTINUE
33576C
33577      RETURN
33578      END
33579      SUBROUTINE DPPAR2(Y,X,N,NUMV2,MAXTAG,ICASPL,ICONT,IDIREC,
33580CCCCC1Y2,X2,D2,N2,NPLOTV,IBUGG3,IERROR)
33581     1Y2,X2,D2,N2,NPLOTV,ISUBRO,IBUGG3,IERROR)
33582CCCCC MAXTAG WAS ADDED TO THE ABOVE LIST DECEMBER 1994
33583CCCCC ISUBRO WAS ADDED TO THE ABOVE LIST DECEMBER 1994
33584C
33585C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
33586C              THAT WILL DEFINE A PARETO PLOT.
33587C     WRITTEN BY--JAMES J. FILLIBEN
33588C                 STATISTICAL ENGINEERING DIVISION
33589C                 INFORMATION TECHNOLOGY LABORATORY
33590C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
33591C                 GAITHERSBURG, MD 20899-8980
33592C                 PHONE--301-975-2899
33593C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
33594C           OF THE NATIONAL BUREAU OF STANDARDS.
33595C     LANGUAGE--ANSI FORTRAN (1977)
33596C     VERSION NUMBER--88/8
33597C     ORIGINAL VERSION--AUGUST    1988.
33598C     UPDATED         --APRIL     1992. NUMSET TO NUMV2
33599C     UPDATED         --DECEMBER  1994. ADD MAXTAG FOR 2-ARG
33600C     UPDATED         --DECEMBER  1994. REWRITE MOST OF CODE
33601C
33602C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
33603C
33604      CHARACTER*4 ICASPL
33605      CHARACTER*4 ICONT
33606      CHARACTER*4 IDIREC
33607      CHARACTER*4 ISUBRO
33608      CHARACTER*4 IBUGG3
33609      CHARACTER*4 IERROR
33610C
33611      CHARACTER*4 ISUBN1
33612      CHARACTER*4 ISUBN2
33613CCCCC CHARACTER*4 ISTEPN
33614C
33615C---------------------------------------------------------------------
33616C
33617      INCLUDE 'DPCOPA.INC'
33618C
33619      DIMENSION Y(*)
33620      DIMENSION X(*)
33621      DIMENSION Y2(*)
33622      DIMENSION X2(*)
33623      DIMENSION D2(*)
33624C
33625C---------------------------------------------------------------------
33626C
33627      INCLUDE 'DPCOP2.INC'
33628C
33629C-----START POINT-----------------------------------------------------
33630C
33631      ISUBN1='DPPA'
33632      ISUBN2='R2  '
33633C
33634CCCCC THE FOLLOWING SECTION WAS ADDED     DECEMBER 1994
33635      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'PAR2')GOTO90
33636      WRITE(ICOUT,999)
33637  999 FORMAT(1X)
33638      CALL DPWRST('XXX','BUG ')
33639      WRITE(ICOUT,51)
33640   51 FORMAT('***** AT THE BEGINNING OF DPPAR2--')
33641      CALL DPWRST('XXX','BUG ')
33642      WRITE(ICOUT,52)ICASPL,N,NUMV2,MAXTAG,IERROR
33643   52 FORMAT('ICASPL,N,NUMV2,MAXTAG,IERROR = ',A4,3I8,2X,A4)
33644      CALL DPWRST('XXX','BUG ')
33645      WRITE(ICOUT,53)IDIREC,ICONT
33646   53 FORMAT('IDIREC,ICONT = ',A4,2X,A4)
33647      CALL DPWRST('XXX','BUG ')
33648      WRITE(ICOUT,54)N,N2,NPLOTV
33649   54 FORMAT('N,N2,NPLOTV = ',3I8)
33650      CALL DPWRST('XXX','BUG ')
33651      WRITE(ICOUT,999)
33652      DO81I=1,N
33653      WRITE(ICOUT,82)I,Y(I),X(I)
33654   82 FORMAT('I,Y(I),X(I) = ',I8,2E15.7)
33655      CALL DPWRST('XXX','BUG ')
33656   81 CONTINUE
33657      DO85I=1,N2
33658      WRITE(ICOUT,999)
33659      WRITE(ICOUT,86)I,Y2(I),X2(I),D2(I)
33660   86 FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2)
33661      CALL DPWRST('XXX','BUG ')
33662   85 CONTINUE
33663   90 CONTINUE
33664C
33665      IF(NUMV2.EQ.1)THEN
33666         DO1112I=1,N
33667            X(I)=I
33668 1112    CONTINUE
33669      ENDIF
33670C
33671      IF(IDIREC.EQ.'DECR')THEN
33672         DO1120I=1,N
33673            Y(I)=(-Y(I))
33674 1120    CONTINUE
33675      ENDIF
33676C
33677      CALL SORTC(Y,X,N,Y2,D2)
33678C
33679      IF(IDIREC.EQ.'DECR')THEN
33680         DO1130I=1,N
33681            Y2(I)=(-Y2(I))
33682 1130    CONTINUE
33683      ENDIF
33684C
33685CCCCC IF(NUMV2.EQ.1)THEN
33686         DO1140I=1,N
33687            X2(I)=I
33688 1140    CONTINUE
33689CCCCC ENDIF
33690C
33691      K=N
33692      DO1150I=1,N
33693         K=K+1
33694         Y2(K)=Y2(I)
33695         X2(K)=X2(I)
33696CCCCC THE FOLLOWING LINE WAS FIXED   DECEMBER 1994
33697CCCCC    D2(K)=N+1
33698         D2(K)=MAXTAG+1
33699 1150 CONTINUE
33700C
33701      N2=K
33702      NPLOTV=3
33703      GOTO9000
33704C
33705C               ******************
33706C               **   STEP 90--  **
33707C               **   EXIT       **
33708C               ******************
33709C
33710 9000 CONTINUE
33711      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'PAR2')GOTO9090
33712      WRITE(ICOUT,999)
33713      CALL DPWRST('XXX','BUG ')
33714      WRITE(ICOUT,9011)
33715 9011 FORMAT('***** AT THE END       OF DPPAR2--')
33716      CALL DPWRST('XXX','BUG ')
33717CCCCC THE FOLLOWING 2 LINES WERE FIXED   APRIL 1992
33718CCCCC WRITE(ICOUT,9012)ICASPL,N,NUMSET,IERROR
33719C9012 FORMAT('ICASPL,N,NUMSET,IERROR = ',A4,2I8,2X,A4)
33720CCCCC CALL DPWRST('XXX','BUG ')
33721CCCCC THE FOLLOWING 2 LINES WERE AUGMENTED   DECEMBER 1994
33722CCCCC WRITE(ICOUT,9012)ICASPL,N,NUMV2,IERROR
33723C9012 FORMAT('ICASPL,N,NUMV2,IERROR = ',A4,2I8,2X,A4)
33724      WRITE(ICOUT,9012)ICASPL,N,NUMV2,MAXTAG,IERROR
33725 9012 FORMAT('ICASPL,N,NUMV2,MAXTAG,IERROR = ',A4,3I8,2X,A4)
33726      CALL DPWRST('XXX','BUG ')
33727      WRITE(ICOUT,9013)IDIREC
33728 9013 FORMAT('IDIREC = ',A4)
33729      CALL DPWRST('XXX','BUG ')
33730      WRITE(ICOUT,9014)N2,NPLOTV
33731 9014 FORMAT('N2,NPLOTV = ',I8,2X,I8)
33732      CALL DPWRST('XXX','BUG ')
33733      DO9035I=1,N2
33734      WRITE(ICOUT,9036)I,Y2(I),X2(I),D2(I)
33735 9036 FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2)
33736      CALL DPWRST('XXX','BUG ')
33737 9035 CONTINUE
33738 9090 CONTINUE
33739C
33740      RETURN
33741      END
33742      SUBROUTINE DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
33743     1                  IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
33744     1                  JMIN,JMAX,
33745     1                  MINN2,MINNA,MAXNA,MAXVAR,IFLAGE,INAME,
33746     1                  IVARN1,IVARN2,IVARTY,PVAR,
33747     1                  ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
33748     1                  MINNVA,MAXNVA,
33749     1                  IFLAGM,IFLAGP,
33750     1                  IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
33751C
33752C     PURPOSE--PARSE A DATAPLOT COMMAND LINE AND DO THE FOLLOWING:
33753C
33754C              1) CHECK FOR A VALID NUMBER OF ARGUMENTS.
33755C
33756C              2) CHECK FOR LOCATION, IF ANY, OF SUBSET/EXCEPT,FOR CLAUSE.
33757C
33758C              3) EXTRACT THE LIST OF VARIABLE NAMES.
33759C
33760C              4) CHECK FOR MINIMUM SAMPLE SIZE.
33761C
33762C              5) CHECK FOR EQUAL SAMPLE SIZES (IF APPLICABLE).
33763C
33764C              6) CREATE THE SUBSET VARIABLE.
33765C
33766C              7) IF REQUESTED, CHECK TO SEE IF A VALID NUMBER OF
33767C                 VARIABLES WERE SPECIFIED.
33768C
33769C              8) CHECK TO SEE IF EACH NAME IS A VALID VARIABLE.
33770C
33771C     WRITTEN BY--ALAN HECKERT
33772C                 STATISTICAL ENGINEERING DIVISION
33773C                 INFORMATION TECHNOLOGY LABORATORY
33774C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
33775C                 GAITHERSBURG, MD 20899-8980
33776C                 PHONE--301-975-2899
33777C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
33778C           OF THE NATIONAL BUREAU OF STANDARDS.
33779C     LANGUAGE--ANSI FORTRAN (1977)
33780C     VERSION NUMBER--2009/3
33781C     ORIGINAL VERSION--MARCH     2009.
33782C     UPDATED         --APRIL     2009. CHECK FOR VALID NUMBER OF
33783C                                       VARIABLES (OPTIONAL)
33784C     UPDATED         --SEPTEMBER 2009. ADD SUPPORT FOR PARAMETER
33785C                                       AND MATRIX NAMES (PLACEHOLDER
33786C                                       FOR NOW, WILL IMPLEMENT LATER)
33787C     UPDATED         --SEPTEMBER 2009. FOR A NUMBER OF COMMANDS,
33788C                                       ALL VARIABLES EXCEPT LAST MUST
33789C                                       HAVE SAME NUMBER OF ELEMENTS
33790C     UPDATED         --DECEMBER  2010. FOR A NUMBER OF COMMANDS, CAN
33791C                                       HAVE EITHER A MATRIX, 4 PARAMETERS,
33792C                                       OR TWO VARIABLES.  TO HANDLE THIS,
33793C                                       SET IFLAGM = 9 TO ALLOW FIRST ARGUMENT
33794C                                       TO BE A MATRIX AND SET IFLAGP = 9 TO
33795C                                       ALLOW ARGUMENTS ONE TO FOUR TO BE
33796C                                       PARAMETERS.
33797C     UPDATED         --JANUARY   2011. FOR SOME COMMANDS, HAVE THE
33798C                                       FOLLOWING:
33799C                                       1) TWO VARIABLES - CAN BE
33800C                                          UNEQUAL SIZE
33801C                                       2) THREE VARIABLES - MUST BE
33802C                                          SAME SIZE
33803C                                       3) FOUR VARIABLES - ONE AND TWO
33804C                                          MUST BE SAME SIZE AND THREE
33805C                                          AND FOUR MUST BE SAME SIZE
33806C                                       SET IFLAGE = 19 TO SPECIFY
33807C                                       THIS CASE
33808C     UPDATED         --MARCH     2011. FOR SOME COMMANDS, ARGUMENTS
33809C                                       MUST EITHER ALL BE VARIABLES
33810C                                       OR ALL BE MATRICES.
33811C     UPDATED         --APRIL     2011. FOR SOME COMMANDS, EITHER THE
33812C                                       FIRST OR LAST ARGUMENT MAY BE
33813C                                       A PARAMETER, BUT ALL OTHER
33814C                                       ARGUMENTS MUST BE VARIABLES.
33815C                                       SET IFLAGP TO 29 TO HANDLE
33816C                                       THIS CASE.
33817C     UPDATED         --AUGUST    2011. SET IFLAGP = 19 FOR CASE WHERE
33818C                                       ARGUMENTS CAN EITHER BE ALL
33819C                                       PARAMETERS OR ALL VARIABLES (BUT
33820C                                       NOT A MIX)
33821C     UPDATED         --FEBRUARY  2012. FOR SOME COMMANDS, THE FIRST AND LAST
33822C                                       VARIABLES MAY BE OF DIFFERENT SIZE THAN
33823C                                       THE REST.  SET IFLAGE = 98 TO IDENTIFY
33824C                                       THIS CASE.
33825C     UPDATED         --JUNE      2015. FOR A NUMBER OF COMMANDS, CAN
33826C                                       HAVE EITHER A MATRIX OR THREE
33827C                                       VARIABLES.  TO HANDLE THIS, SET
33828C                                       IFLAGM = 8 TO ALLOW FIRST ARGUMENT
33829C                                       TO BE A MATRIX (AND CHECK THAT
33830C                                       THERE IS EXACTLY ONE RESPONSE
33831C                                       VARIABLE GIVEN).
33832C     UPDATED         --JULY      2018. IFLAGM = 7 FOR CASE WHERE FIRST
33833C                                       ARGUMENT CAN BE A VARIABLE AND
33834C                                       SECOND ARGUMENT CAN BE A MATRIX
33835C                                       OR A LIST OF VARIABLES
33836C
33837C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
33838C
33839      INTEGER ILIS(*)
33840      INTEGER ISUB(*)
33841      INTEGER NRIGHT(*)
33842      INTEGER ICOLR(*)
33843      INTEGER IN(*)
33844      INTEGER IVALUE(*)
33845C
33846      REAL VALUE(*)
33847C
33848      CHARACTER*4 IANS(*)
33849      CHARACTER*4 IHARG(*)
33850      CHARACTER*4 IHARG2(*)
33851      CHARACTER*4 IARGT(*)
33852      CHARACTER*4 IHNAME(*)
33853      CHARACTER*4 IHNAM2(*)
33854      CHARACTER*4 IVARN1(*)
33855      CHARACTER*4 IVARN2(*)
33856      CHARACTER*4 IVARTY(*)
33857      CHARACTER*4 IUSE(*)
33858C
33859      CHARACTER*40 INAME
33860C
33861      CHARACTER*4 IBUGG3
33862      CHARACTER*4 IBUGQ
33863      CHARACTER*4 ISUBRO
33864      CHARACTER*4 IFOUND
33865      CHARACTER*4 IERROR
33866C
33867      CHARACTER*4 IHWUSE
33868      CHARACTER*4 MESSAG
33869      CHARACTER*4 ICASEQ
33870      CHARACTER*4 IHRIGH
33871      CHARACTER*4 IHRIG2
33872      CHARACTER*4 ISUBN1
33873      CHARACTER*4 ISUBN2
33874      CHARACTER*4 ISTEPN
33875C
33876      REAL ARG(*)
33877      REAL PVAR(*)
33878C
33879C-----COMMON VARIABLES (GENERAL)--------------------------------------
33880C
33881      INCLUDE 'DPCOP2.INC'
33882C
33883C-----START POINT-----------------------------------------------------
33884C
33885      IERROR='NO'
33886      ISUBN1='DPPA'
33887      ISUBN2='RS  '
33888C
33889      NTEMP=0
33890C
33891      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PARS')THEN
33892        WRITE(ICOUT,999)
33893  999   FORMAT(1X)
33894        CALL DPWRST('XXX','BUG ')
33895        WRITE(ICOUT,51)
33896   51   FORMAT('***** AT THE BEGINNING OF DPPARS--')
33897        CALL DPWRST('XXX','BUG ')
33898        WRITE(ICOUT,52)IBUGG3,IBUGQ,ISUBRO
33899   52   FORMAT('IBUGG3,IBUGQ,ISUBRO = ',A4,2X,A4,2X,A4,2X,A4)
33900        CALL DPWRST('XXX','BUG ')
33901        WRITE(ICOUT,53)MINN2,MINNA,MAXNA,MAXVAR
33902   53   FORMAT('MINN2,MINNA,MAXNA,MAXVAR = ',4I8,2X,A40)
33903        CALL DPWRST('XXX','BUG ')
33904        WRITE(ICOUT,54)INAME
33905   54   FORMAT('INAME = ',A40)
33906        CALL DPWRST('XXX','BUG ')
33907      ENDIF
33908C
33909C               *******************************************************
33910C               **  STEP 1--                                         **
33911C               **  CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS.  **
33912C               *******************************************************
33913C
33914      ISTEPN='1'
33915      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PARS')
33916     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
33917C
33918      CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR)
33919      IF(IERROR.EQ.'YES')GOTO9000
33920C
33921C               *****************************************
33922C               **  STEP 2--                           **
33923C               **  CHECK TO SEE THE TYPE SUBCASE      **
33924C               **  (BASED ON THE QUALIFIER)--         **
33925C               **    1) UNQUALIFIED (THAT IS, FULL);  **
33926C               **    2) SUBSET/EXCEPT; OR             **
33927C               **    3) FOR.                          **
33928C               *****************************************
33929C
33930      ISTEPN='2'
33931      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PARS')
33932     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
33933C
33934      ICASEQ='FULL'
33935      ILOCQ=NUMARG+1
33936      IF(NUMARG.GE.1)THEN
33937        DO201J=1,NUMARG
33938          J1=J
33939          IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET  ')THEN
33940            ICASEQ='SUBS'
33941            ILOCQ=J1
33942            GOTO206
33943          ELSEIF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT  ')THEN
33944            ICASEQ='SUBS'
33945            ILOCQ=J1
33946            GOTO206
33947          ELSEIF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.'    ')THEN
33948            ICASEQ='FOR'
33949            ILOCQ=J1
33950            GOTO206
33951          ENDIF
33952  201   CONTINUE
33953      ENDIF
33954C
33955  206 CONTINUE
33956      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PARS')THEN
33957        WRITE(ICOUT,208)NUMARG,ILOCQ,ICASEQ
33958  208   FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4)
33959        CALL DPWRST('XXX','BUG ')
33960      ENDIF
33961C
33962C               **************************************************
33963C               **  STEP 3--                                    **
33964C               **  EXTRACT THE VARIABLE NAMES FROM THE         **
33965C               **  COMMAND LINE.                               **
33966C               **************************************************
33967C
33968      ISTEPN='3'
33969      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PARS')
33970     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
33971C
33972      JMAX=ILOCQ-1
33973      IF(IFLAGP.EQ.1 .OR. IFLAGM.EQ.1 .OR. IFLAGM.EQ.2 .OR.
33974     1   IFLAGP.EQ.9 .OR. IFLAGP.EQ.19 .OR.IFLAGM.EQ.9 .OR.
33975     1   IFLAGP.EQ.29 .OR. IFLAGM.EQ.8)THEN
33976        IFLAGT=0
33977        CALL EXTVA2(IHARG,IHARG2,IARGT,ARG,NUMARG,JMIN,JMAX,MAXVAR,
33978     1              IHNAME,IHNAM2,IUSE,NUMNAM,
33979     1              IVARN1,IVARN2,IVARTY,PVAR,NUMVAR,
33980     1              IFLAGM,IFLAGP,IFLAGT,
33981     1              IBUGG3,ISUBRO,IERROR)
33982         IF(IERROR.EQ.'YES')GOTO9000
33983C
33984C     2010/12: IF IFLAGM = 9 OR IFLAGM=8, IF FIRST AGRUMENT IS A MATRIX,
33985C              THEN THAT SHOULD BE THE ONLY ARGUMENT.
33986C
33987C              IF IFLAGP = 9, FOUR PARAMETERS IS PERMISSABLE, BUT NO
33988C              VARIABLE OR PARAMETER NAMES PERMITTED.
33989C
33990C     2011/03: IF IFLAGM = 2, IF FIRST AGRUMENT IS A MATRIX, THEN
33991C              ALL ARGUMENTS SHOULD BE MATRICES.
33992C
33993C     2011/04: IF IFLAGP = 29, EITHER FIRST OR LAST ARGUMENT MAY BE
33994C              A PARAMETER.
33995C
33996C     2011/05: IF IFLAGP = 39, ALL ARGUMENTS AFTER THE FIRST ARGUMENT
33997C              SHOULD BE PARAMETERS.
33998C
33999C     2011/08: IF IFLAGP = 19, ARGUMENTS CAN BE EITHER ALL PARAMETERS OR
34000C              ALL VARIABLES, BUT NOT A MIX
34001C
34002C     2018/07: IF IFLAGM = 7, FIRST ARGUMENT MUST BE A VARIABLE.  THE
34003C              SECOND ARGUMENT CAN BE A MATRIX OR A LIST OF ONE OR MORE
34004C              VARIABLES (BUT NO MATRICES)
34005C
34006        IF(IVARTY(1).EQ.'MATR' .AND.
34007     1    (IFLAGM.EQ.9 .OR. IFLAGM.EQ.8))THEN
34008          IF(NUMVAR.GT.1)THEN
34009            WRITE(ICOUT,999)
34010            CALL DPWRST('XXX','BUG ')
34011            WRITE(ICOUT,411)INAME
34012            CALL DPWRST('XXX','BUG ')
34013            WRITE(ICOUT,211)
34014  211       FORMAT('      IF THE FIRST ARGUMENT IS A MATRIX, THEN ',
34015     1             'IT SHOULD BE THE ONLY ARGUMENT.')
34016            CALL DPWRST('XXX','BUG ')
34017            WRITE(ICOUT,213)NUMVAR
34018  213       FORMAT('      THE NUMBER OF VARIABLES EXTRACTED  = ',I8)
34019            CALL DPWRST('XXX','BUG ')
34020            IERROR='YES'
34021            GOTO9000
34022          ENDIF
34023        ELSEIF(IVARTY(1).EQ.'PARA' .AND. IFLAGP.EQ.9)THEN
34024          IF(NUMVAR.EQ.4)THEN
34025            DO220I=2,NUMVAR
34026              IF(IVARTY(I).NE.'PARA')THEN
34027                WRITE(ICOUT,999)
34028                CALL DPWRST('XXX','BUG ')
34029                WRITE(ICOUT,411)INAME
34030                CALL DPWRST('XXX','BUG ')
34031                WRITE(ICOUT,221)I
34032  221           FORMAT('      IF THE FIRST ARGUMENT IS A PARAMETER, ',
34033     1             'THEN ARGUMENT ',I5,' MUST BE AS WELL.')
34034                CALL DPWRST('XXX','BUG ')
34035                WRITE(ICOUT,223)I,IVARTY(I)
34036  223           FORMAT('      THE TYPE OF ARGUMENT ',I5,' IS ',A4)
34037                CALL DPWRST('XXX','BUG ')
34038                IERROR='YES'
34039                GOTO9000
34040              ENDIF
34041  220       CONTINUE
34042          ELSE
34043            WRITE(ICOUT,999)
34044            CALL DPWRST('XXX','BUG ')
34045            WRITE(ICOUT,411)INAME
34046            CALL DPWRST('XXX','BUG ')
34047            WRITE(ICOUT,216)
34048  216       FORMAT('      IF THE FIRST ARGUMENT IS A PARAMETER, THEN ',
34049     1             'THERE SHOULD BE EXACTLY FOUR ARGUMENTS.')
34050            CALL DPWRST('XXX','BUG ')
34051            WRITE(ICOUT,213)NUMVAR
34052            CALL DPWRST('XXX','BUG ')
34053            IERROR='YES'
34054            GOTO9000
34055          ENDIF
34056        ELSEIF(IVARTY(1).EQ.'VARI' .AND. IFLAGM.EQ.9 .AND.
34057     1         IFLAGP.EQ.9)THEN
34058          DO230I=1,NUMVAR
34059            IF(IVARTY(I).NE.'VARI')THEN
34060              WRITE(ICOUT,999)
34061              CALL DPWRST('XXX','BUG ')
34062              WRITE(ICOUT,411)INAME
34063              CALL DPWRST('XXX','BUG ')
34064              WRITE(ICOUT,231)I
34065  231         FORMAT('      IF THE FIRST ARGUMENT IS A VARIABLE, THEN ',
34066     1             'ARGUMENT ',I5,' SHOULD ALSO BE A VARIABLE.')
34067              CALL DPWRST('XXX','BUG ')
34068              WRITE(ICOUT,223)I,IVARTY(I)
34069              CALL DPWRST('XXX','BUG ')
34070              IERROR='YES'
34071              GOTO9000
34072            ENDIF
34073  230     CONTINUE
34074        ELSEIF(IVARTY(1).EQ.'VARI' .AND. IFLAGM.EQ.8)THEN
34075          DO235I=1,NUMVAR
34076            IF(IVARTY(I).NE.'VARI')THEN
34077              WRITE(ICOUT,999)
34078              CALL DPWRST('XXX','BUG ')
34079              WRITE(ICOUT,411)INAME
34080              CALL DPWRST('XXX','BUG ')
34081              WRITE(ICOUT,231)I
34082              CALL DPWRST('XXX','BUG ')
34083              WRITE(ICOUT,223)I,IVARTY(I)
34084              CALL DPWRST('XXX','BUG ')
34085              IERROR='YES'
34086              GOTO9000
34087            ENDIF
34088  235     CONTINUE
34089        ELSEIF(IFLAGM.EQ.2)THEN
34090          IF(NUMVAR.GT.1 .AND. IVARTY(1).EQ.'VARI')THEN
34091            DO240I=2,NUMVAR
34092              IF(IVARTY(I).EQ.'MATR')THEN
34093                WRITE(ICOUT,999)
34094                CALL DPWRST('XXX','BUG ')
34095                WRITE(ICOUT,411)INAME
34096                CALL DPWRST('XXX','BUG ')
34097                WRITE(ICOUT,241)
34098  241           FORMAT('      IF THE FIRST ARGUMENT IS A VARIABLE, ',
34099     1                 'THEN ALL REMAINING')
34100                CALL DPWRST('XXX','BUG ')
34101                WRITE(ICOUT,243)
34102  243           FORMAT('      ARGUMENTS MUST BE VARIABLES.  ARGUMENT ',
34103     1                 I5,' IS A MATRIX.')
34104                CALL DPWRST('XXX','BUG ')
34105                IERROR='YES'
34106                GOTO9000
34107              ENDIF
34108  240       CONTINUE
34109          ELSEIF(NUMVAR.GT.1 .AND. IVARTY(1).EQ.'MATR')THEN
34110            DO250I=2,NUMVAR
34111              IF(IVARTY(I).NE.'MATR')THEN
34112                WRITE(ICOUT,999)
34113                CALL DPWRST('XXX','BUG ')
34114                WRITE(ICOUT,411)INAME
34115                CALL DPWRST('XXX','BUG ')
34116                WRITE(ICOUT,251)
34117  251           FORMAT('      IF THE FIRST ARGUMENT IS A MATRIX, ',
34118     1                 'THEN ALL REMAINING')
34119                CALL DPWRST('XXX','BUG ')
34120                WRITE(ICOUT,253)
34121  253           FORMAT('      ARGUMENTS MUST BE MATRICES.  ARGUMENT ',
34122     1                 I5,' IS A VARIABLE.')
34123                CALL DPWRST('XXX','BUG ')
34124                IERROR='YES'
34125                GOTO9000
34126              ENDIF
34127  250       CONTINUE
34128          ENDIF
34129C
34130        ELSEIF(IFLAGM.EQ.7)THEN
34131          IF(IVARTY(1).NE.'VARI')THEN
34132            WRITE(ICOUT,999)
34133            CALL DPWRST('XXX','BUG ')
34134            WRITE(ICOUT,411)INAME
34135            CALL DPWRST('XXX','BUG ')
34136            WRITE(ICOUT,2221)
34137 2221       FORMAT('      THE FIRST ARGUMENT MUST BE A VARIABLE.')
34138            CALL DPWRST('XXX','BUG ')
34139            WRITE(ICOUT,2223)IVARTY(1)
34140 2223       FORMAT('      IT IS OF TYPE ',A4)
34141            CALL DPWRST('XXX','BUG ')
34142            IERROR='YES'
34143            GOTO9000
34144          ELSEIF(IVARTY(2).EQ.'MATR')THEN
34145            IF(NUMVAR.GT.2)THEN
34146              WRITE(ICOUT,999)
34147              CALL DPWRST('XXX','BUG ')
34148              WRITE(ICOUT,411)INAME
34149              CALL DPWRST('XXX','BUG ')
34150              WRITE(ICOUT,2231)
34151 2231         FORMAT('      IF THE SECOND ARGUMENT IS A MATRIX, ',
34152     1               'THEN IT SHOULD BE THE LAST ARGUMENT.')
34153              CALL DPWRST('XXX','BUG ')
34154              WRITE(ICOUT,2233)NUMVAR
34155 2233         FORMAT('      THERE ARE ',I5,' ARGUMENTS.')
34156              CALL DPWRST('XXX','BUG ')
34157              IERROR='YES'
34158              GOTO9000
34159            ENDIF
34160          ELSEIF(IVARTY(2).EQ.'VARI')THEN
34161            IF(NUMVAR.GE.3)THEN
34162              DO2240I=3,NUMVAR
34163                IF(IVARTY(I).NE.'VARI')THEN
34164                  WRITE(ICOUT,999)
34165                  CALL DPWRST('XXX','BUG ')
34166                  WRITE(ICOUT,411)INAME
34167                  CALL DPWRST('XXX','BUG ')
34168                  WRITE(ICOUT,2241)
34169 2241             FORMAT('      IF THE SECOND ARGUMENT IS A VARIABLE, ',
34170     1                   'THEN ALL REMAINING')
34171                  CALL DPWRST('XXX','BUG ')
34172                  WRITE(ICOUT,2243)I
34173 2243             FORMAT('      ARGUMENTS MUST BE VARIABLES.  ',
34174     1                   'ARGUMENT ',I5,' IS NOT A VARIABLE.')
34175                  CALL DPWRST('XXX','BUG ')
34176                  IERROR='YES'
34177                  GOTO9000
34178                ENDIF
34179 2240         CONTINUE
34180            ENDIF
34181          ENDIF
34182        ELSEIF(IFLAGP.EQ.29)THEN
34183          DO260I=1,NUMVAR
34184            IF(I.EQ.1 .OR. I.EQ.NUMVAR)GOTO260
34185            IF(IVARTY(I).EQ.'PARA')THEN
34186              WRITE(ICOUT,999)
34187              CALL DPWRST('XXX','BUG ')
34188              WRITE(ICOUT,411)INAME
34189              CALL DPWRST('XXX','BUG ')
34190              WRITE(ICOUT,261)I
34191  261         FORMAT('      ARGUMENT ',I5,' CANNOT BE A PARAMETER.')
34192              CALL DPWRST('XXX','BUG ')
34193              IERROR='YES'
34194              GOTO9000
34195            ENDIF
34196  260     CONTINUE
34197C
34198          IF(IVARTY(1).EQ.'PARA' .AND. IVARTY(2).EQ.'PARA')THEN
34199            WRITE(ICOUT,999)
34200            CALL DPWRST('XXX','BUG ')
34201            WRITE(ICOUT,411)INAME
34202            CALL DPWRST('XXX','BUG ')
34203            WRITE(ICOUT,266)
34204  266       FORMAT('      THE FIRST AND LAST ARGUMENTS CANNOT BOTH ',
34205     1             'BOTH BE PARAMETERS.')
34206            CALL DPWRST('XXX','BUG ')
34207            IERROR='YES'
34208            GOTO9000
34209          ENDIF
34210        ELSEIF(IFLAGP.EQ.39)THEN
34211          DO270I=1,NUMVAR
34212            IF(I.EQ.1 .AND. IVARTY(I).EQ.'PARA')THEN
34213              WRITE(ICOUT,999)
34214              CALL DPWRST('XXX','BUG ')
34215              WRITE(ICOUT,411)INAME
34216              CALL DPWRST('XXX','BUG ')
34217              WRITE(ICOUT,271)I
34218  271         FORMAT('      ARGUMENT ',I5,' CANNOT BE A PARAMETER.')
34219              CALL DPWRST('XXX','BUG ')
34220              IERROR='YES'
34221              GOTO9000
34222            ELSEIF(I.GT.1 .AND. IVARTY(I).NE.'PARA')THEN
34223              WRITE(ICOUT,999)
34224              CALL DPWRST('XXX','BUG ')
34225              WRITE(ICOUT,411)INAME
34226              CALL DPWRST('XXX','BUG ')
34227              WRITE(ICOUT,276)I
34228  276         FORMAT('      ARGUMENT ',I5,' MUST BE A PARAMETER.')
34229              CALL DPWRST('XXX','BUG ')
34230              WRITE(ICOUT,277)I,IVARTY(I)
34231  277         FORMAT('      ARGUMENT ',I5,' MUST BE A PARAMETER.')
34232              CALL DPWRST('XXX','BUG ')
34233              IERROR='YES'
34234              GOTO9000
34235            ENDIF
34236  270     CONTINUE
34237C
34238        ELSEIF(IFLAGP.EQ.19)THEN
34239          IF(IVARTY(1).EQ.'PARA')THEN
34240            DO280I=2,NUMVAR
34241              IF(IVARTY(I).NE.'PARA')THEN
34242                WRITE(ICOUT,999)
34243                CALL DPWRST('XXX','BUG ')
34244                WRITE(ICOUT,411)INAME
34245                CALL DPWRST('XXX','BUG ')
34246                WRITE(ICOUT,221)I
34247                CALL DPWRST('XXX','BUG ')
34248                WRITE(ICOUT,223)I,IVARTY(I)
34249                CALL DPWRST('XXX','BUG ')
34250                IERROR='YES'
34251                GOTO9000
34252              ENDIF
34253  280       CONTINUE
34254          ELSEIF(IVARTY(1).EQ.'VARI')THEN
34255            DO290I=2,NUMVAR
34256              IF(IVARTY(I).NE.'VARI')THEN
34257                WRITE(ICOUT,999)
34258                CALL DPWRST('XXX','BUG ')
34259                WRITE(ICOUT,411)INAME
34260                CALL DPWRST('XXX','BUG ')
34261                WRITE(ICOUT,291)I
34262  291           FORMAT('      IF THE FIRST ARGUMENT IS A VARIABLE, ',
34263     1             'THEN ARGUMENT ',I5,' MUST BE AS WELL.')
34264                CALL DPWRST('XXX','BUG ')
34265                WRITE(ICOUT,223)I,IVARTY(I)
34266                CALL DPWRST('XXX','BUG ')
34267                IERROR='YES'
34268                GOTO9000
34269              ENDIF
34270  290       CONTINUE
34271          ENDIF
34272        ENDIF
34273C
34274      ELSE
34275        CALL EXTVAR(IHARG,IHARG2,NUMARG,JMIN,JMAX,MAXVAR,
34276     1              IHNAME,IHNAM2,IUSE,NUMNAM,
34277     1              IVARN1,IVARN2,NUMVAR,IBUGG3,ISUBRO,IERROR)
34278C
34279C       SET VARIABLE TYPE TO VARIABLE FOR ALL ARGUMENTS.
34280C
34281        DO293I=1,NUMVAR
34282          IVARTY(I)='VARI'
34283  293   CONTINUE
34284C
34285      ENDIF
34286C
34287      IF(IERROR.EQ.'YES')GOTO9000
34288C
34289C               *****************************************
34290C               **  STEP 4--                           **
34291C               **  CHECK THE VALIDITY OF EACH OF THE  **
34292C               **  VARIABLES.  ALSO CHECK TO ASSURE   **
34293C               **  THAT EACH OF THE VARIABLES HAS AT  **
34294C               **  LEAST "MINN2" OBSERVATIONS.        **
34295C               **  BUT FIRST CHECK THAT A VALID       **
34296C               **  NUMBER OF VARIABLES WERE GIVEN.    **
34297C               *****************************************
34298C
34299      ISTEPN='4'
34300      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PARS')
34301     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
34302C
34303      IF(MINNVA.GE.1 .AND. MAXNVA.GE.MINNVA)THEN
34304        IF(IFLAGM.EQ.8 .AND. IVARTY(1).EQ.'MATR')THEN
34305          MINNVA=1
34306          MAXNVA=1
34307        ENDIF
34308        IF(NUMVAR.LT.MINNVA .OR. NUMVAR.GT.MAXNVA)THEN
34309          WRITE(ICOUT,999)
34310          CALL DPWRST('XXX','BUG ')
34311          WRITE(ICOUT,411)INAME
34312          CALL DPWRST('XXX','BUG ')
34313          WRITE(ICOUT,312)MINNVA
34314  312     FORMAT('      THE NUMBER OF VARIABLES MUST BE AT ',
34315     1           'LEAST ',I8)
34316          CALL DPWRST('XXX','BUG ')
34317          WRITE(ICOUT,314)MAXNVA
34318  314     FORMAT('      AND AT MOST ',I8,'.  SUCH WAS NOT THE CASE ',
34319     1           'HERE.')
34320          CALL DPWRST('XXX','BUG ')
34321          WRITE(ICOUT,317)NUMVAR
34322  317     FORMAT('      THE SPECIFIED NUMBER OF VARIABLES WAS ',I8)
34323          CALL DPWRST('XXX','BUG ')
34324          WRITE(ICOUT,415)
34325          CALL DPWRST('XXX','BUG ')
34326          IF(IWIDTH.GE.1)THEN
34327            WRITE(ICOUT,416)(IANS(J),J=1,MIN(80,IWIDTH))
34328            CALL DPWRST('XXX','BUG ')
34329          ENDIF
34330          IERROR='YES'
34331          GOTO9000
34332        ENDIF
34333      ENDIF
34334C
34335C     NOTE 7/2010: IFLAGP=99 IS USED WHEN ONLY THE LAST ARGUMENT
34336C                  IS ALLOWED TO BE A PARAMETER.
34337C
34338      IFLAG=0
34339      DO400I=1,NUMVAR
34340C
34341        IHRIGH=IVARN1(I)
34342        IHRIG2=IVARN2(I)
34343C
34344        IF((IFLAGP.EQ.1 .OR. IFLAGP.EQ.9 .OR. IFLAGP.EQ.19 .OR.
34345     1      IFLAGP.EQ.29) .AND. IVARTY(I).EQ.'PARA')THEN
34346          IHWUSE='P'
34347          MESSAG='YES'
34348          CALL CHECKN(IHRIGH,IHRIG2,IHWUSE,
34349     1                IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,
34350     1                NUMNAM,MAXNAM,
34351     1                ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
34352          IF(IERROR.EQ.'YES')GOTO9000
34353          ILIS(I)=ILOCV
34354          NRIGHT(I)=0
34355          ICOLR(I)=IVALUE(ILOCV)
34356          PVAR(I)=VALUE(ILOCV)
34357        ELSEIF(IFLAGP.EQ.99 .AND. I.EQ.NUMVAR .AND.
34358     1         IVARTY(I).EQ.'PARA')THEN
34359          IHWUSE='P'
34360          MESSAG='YES'
34361          CALL CHECKN(IHRIGH,IHRIG2,IHWUSE,
34362     1                IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,
34363     1                NUMNAM,MAXNAM,
34364     1                ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
34365          IF(IERROR.EQ.'YES')GOTO9000
34366          ILIS(I)=ILOCV
34367          NRIGHT(I)=0
34368          ICOLR(I)=IVALUE(ILOCV)
34369          PVAR(I)=VALUE(ILOCV)
34370        ELSEIF((IFLAGM.EQ.1 .OR. IFLAGM.EQ.2 .OR. IFLAGM.EQ.9 .OR.
34371     1          IFLAGM.EQ.8) .AND.
34372     1          IVARTY(I).EQ.'MATR')THEN
34373          IHWUSE='M'
34374          MESSAG='YES'
34375          CALL CHECKN(IHRIGH,IHRIG2,IHWUSE,
34376     1                IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,
34377     1                NUMNAM,MAXNAM,
34378     1                ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
34379          IF(IERROR.EQ.'YES')GOTO9000
34380          ILIS(I)=ILOCV
34381          NRIGHT(I)=IN(ILOCV)
34382          ICOLR(I)=IVALUE(ILOCV)
34383          PVAR(I)=VALUE(ILOCV)
34384        ELSEIF(IVARTY(I).EQ.'NUMB')THEN
34385          NRIGHT(I)=0
34386        ELSE
34387          IHRIGH=IVARN1(I)
34388          IHRIG2=IVARN2(I)
34389          IHWUSE='V'
34390          MESSAG='YES'
34391          CALL CHECKN(IHRIGH,IHRIG2,IHWUSE,
34392     1                IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,
34393     1                NUMNAM,MAXNAM,
34394     1                  ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
34395          IF(IERROR.EQ.'YES')GOTO9000
34396C
34397          ILIS(I)=ILOCV
34398          NRIGHT(I)=IN(ILOCV)
34399          ICOLR(I)=IVALUE(ILOCV)
34400          IF(I.EQ.1 .AND. IFLAGE.NE.98)THEN
34401            NTEMP=NRIGHT(I)
34402          ELSEIF(I.EQ.2 .AND. IFLAGE.EQ.98)THEN
34403            NTEMP=NRIGHT(I)
34404          ELSE
34405            IF(IFLAGE.EQ.99)THEN
34406              IF(I.LT.NUMVAR.AND.NRIGHT(I).NE.NTEMP)IFLAG=1
34407            ELSEIF(IFLAGE.EQ.98)THEN
34408              IF(I.GT.1 .AND. I.LT.NUMVAR .AND.
34409     1           NRIGHT(I).NE.NTEMP)IFLAG=1
34410            ELSE
34411              IF(NRIGHT(I).NE.NTEMP)IFLAG=1
34412            ENDIF
34413          ENDIF
34414C
34415          IF(I.EQ.NUMVAR .AND. IFLAGE.EQ.99)GOTO419
34416          IF(I.EQ.NUMVAR .AND. IFLAGE.EQ.98)GOTO419
34417          IF(I.EQ.1      .AND. IFLAGE.EQ.98)GOTO419
34418          IF(NRIGHT(I).LT.MINN2)THEN
34419            WRITE(ICOUT,999)
34420            CALL DPWRST('XXX','BUG ')
34421            WRITE(ICOUT,411)INAME
34422  411       FORMAT('***** ERROR IN ',A40)
34423            CALL DPWRST('XXX','BUG ')
34424            WRITE(ICOUT,412)IHRIGH,IHRIG2
34425  412       FORMAT('      FOR RESPONSE VARIABLE ',2A4,
34426     1             ' THE INPUT NUMBER')
34427            CALL DPWRST('XXX','BUG ')
34428            WRITE(ICOUT,413)MINN2
34429  413       FORMAT('      OF OBSERVATIONS MUST BE ',I8,' OR LARGER.')
34430            CALL DPWRST('XXX','BUG ')
34431            WRITE(ICOUT,414)
34432  414       FORMAT('      SUCH WAS NOT THE CASE HERE.')
34433            CALL DPWRST('XXX','BUG ')
34434            WRITE(ICOUT,415)
34435  415       FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
34436            CALL DPWRST('XXX','BUG ')
34437            IF(IWIDTH.GE.1)THEN
34438              WRITE(ICOUT,416)(IANS(J),J=1,MIN(80,IWIDTH))
34439  416         FORMAT('      ',80A1)
34440              CALL DPWRST('XXX','BUG ')
34441            ENDIF
34442            IERROR='YES'
34443            GOTO9000
34444          ENDIF
34445C
34446  419     CONTINUE
34447C
34448        ENDIF
34449C
34450  400 CONTINUE
34451C
34452C               ******************************************************
34453C               **  STEP 5--                                        **
34454C               **  CHECK THAT VARIABLES HAVE THE SAME NUMBER OF    **
34455C               **  ELEMENTS.                                       **
34456C               ******************************************************
34457C
34458      ISTEPN='5'
34459      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PARS')
34460     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
34461C
34462      IF(IFLAGE.EQ.1 .AND. IFLAG.EQ.1)THEN
34463        WRITE(ICOUT,411)INAME
34464        CALL DPWRST('XXX','BUG ')
34465        WRITE(ICOUT,512)
34466  512   FORMAT('      THE NUMBER OF OBSERVATIONS IN ALL VARIABLES')
34467        CALL DPWRST('XXX','BUG ')
34468        WRITE(ICOUT,513)
34469  513   FORMAT('      MUST BE THE SAME.  SUCH WAS NOT THE CASE HERE.')
34470        CALL DPWRST('XXX','BUG ')
34471        DO517I=1,NUMVAR
34472          I2=ILIS(I)
34473          WRITE(ICOUT,516)IVARN1(I2),IVARN2(I2),IN(I2)
34474  516     FORMAT('           VARIABLE ',A4,A4,' HAS ',I8,
34475     1           ' OBSERVATIONS;')
34476          CALL DPWRST('XXX','BUG ')
34477  517   CONTINUE
34478        IF(IWIDTH.GE.1)THEN
34479          WRITE(ICOUT,416)(IANS(J),J=1,MIN(80,IWIDTH))
34480          CALL DPWRST('XXX','BUG ')
34481          IERROR='YES'
34482          GOTO9000
34483        ENDIF
34484        IERROR='YES'
34485        GOTO9000
34486      ELSEIF(IFLAGE.EQ.99 .AND. IFLAG.EQ.1)THEN
34487        WRITE(ICOUT,411)INAME
34488        CALL DPWRST('XXX','BUG ')
34489        WRITE(ICOUT,522)
34490  522   FORMAT('      THE NUMBER OF OBSERVATIONS IN ALL VARIABLES ',
34491     1         '(EXCEPT THE LAST)')
34492        CALL DPWRST('XXX','BUG ')
34493        WRITE(ICOUT,513)
34494        CALL DPWRST('XXX','BUG ')
34495        DO527I=1,NUMVAR
34496          I2=ILIS(I)
34497          WRITE(ICOUT,516)IVARN1(I2),IVARN2(I2),IN(I2)
34498          CALL DPWRST('XXX','BUG ')
34499  527   CONTINUE
34500        IF(IWIDTH.GE.1)THEN
34501          WRITE(ICOUT,416)(IANS(J),J=1,MIN(80,IWIDTH))
34502          CALL DPWRST('XXX','BUG ')
34503          IERROR='YES'
34504          GOTO9000
34505        ENDIF
34506        IERROR='YES'
34507        GOTO9000
34508      ELSEIF(IFLAGE.EQ.19)THEN
34509        IF((NUMVAR.EQ.2 .OR. NUMVAR.EQ.3) .AND. IFLAG.EQ.1)THEN
34510          WRITE(ICOUT,411)INAME
34511          CALL DPWRST('XXX','BUG ')
34512          WRITE(ICOUT,542)
34513  542     FORMAT('      WHEN THERE ARE TWO OR THREE VARIABLES, THEY')
34514          CALL DPWRST('XXX','BUG ')
34515          WRITE(ICOUT,543)
34516  543     FORMAT('      MUST HAVE THE SAME NUMBER OF OBSERVATIONS.')
34517          CALL DPWRST('XXX','BUG ')
34518          DO547I=1,NUMVAR
34519            I2=ILIS(I)
34520            WRITE(ICOUT,516)IVARN1(I2),IVARN2(I2),IN(I2)
34521            CALL DPWRST('XXX','BUG ')
34522  547     CONTINUE
34523          IF(IWIDTH.GE.1)THEN
34524            WRITE(ICOUT,416)(IANS(J),J=1,MIN(80,IWIDTH))
34525            CALL DPWRST('XXX','BUG ')
34526          ENDIF
34527          IERROR='YES'
34528          GOTO9000
34529        ELSEIF(NUMVAR.EQ.4)THEN
34530          IF(NRIGHT(1).NE.NRIGHT(2))THEN
34531            WRITE(ICOUT,411)INAME
34532            CALL DPWRST('XXX','BUG ')
34533            WRITE(ICOUT,552)
34534  552       FORMAT('      WHEN THERE ARE EXACTLY FOUR VARIABLES, ',
34535     1             'THE FIRST AND')
34536            CALL DPWRST('XXX','BUG ')
34537            WRITE(ICOUT,553)
34538  553       FORMAT('      SECOND VARIABLES MUST HAVE THE SAME NUMBER ',
34539     1             'OF OBSERVATIONS.')
34540            CALL DPWRST('XXX','BUG ')
34541            DO557I=1,2
34542              I2=ILIS(I)
34543              WRITE(ICOUT,516)IVARN1(I2),IVARN2(I2),IN(I2)
34544              CALL DPWRST('XXX','BUG ')
34545  557       CONTINUE
34546            IF(IWIDTH.GE.1)THEN
34547              WRITE(ICOUT,416)(IANS(J),J=1,MIN(80,IWIDTH))
34548              CALL DPWRST('XXX','BUG ')
34549            ENDIF
34550            IERROR='YES'
34551            GOTO9000
34552          ELSEIF(NRIGHT(3).NE.NRIGHT(4))THEN
34553            WRITE(ICOUT,411)INAME
34554            CALL DPWRST('XXX','BUG ')
34555            WRITE(ICOUT,562)
34556  562       FORMAT('      WHEN THERE ARE EXACTLY FOUR VARIABLES, ',
34557     1             'THE THIRD AND')
34558            CALL DPWRST('XXX','BUG ')
34559            WRITE(ICOUT,563)
34560  563       FORMAT('      FOURTH VARIABLES MUST HAVE THE SAME NUMBER ',
34561     1             'OF OBSERVATIONS.')
34562            CALL DPWRST('XXX','BUG ')
34563            DO567I=3,4
34564              I2=ILIS(I)
34565              WRITE(ICOUT,516)IVARN1(I2),IVARN2(I2),IN(I2)
34566              CALL DPWRST('XXX','BUG ')
34567  567       CONTINUE
34568            IF(IWIDTH.GE.1)THEN
34569              WRITE(ICOUT,416)(IANS(J),J=1,MIN(80,IWIDTH))
34570              CALL DPWRST('XXX','BUG ')
34571            ENDIF
34572            IERROR='YES'
34573            GOTO9000
34574          ENDIF
34575        ENDIF
34576      ENDIF
34577C
34578C               **************************************************
34579C               **  STEP 6--                                    **
34580C               **  BRANCH TO THE APPROPRIATE SUBCASE (BASED    **
34581C               **  ON THE QUALIFIER) AND CREATE THE            **
34582C               **  APPROPRIATE SUBSET VARIABLE (ISUB).         **
34583C               *************************************************
34584C
34585      ISTEPN='6'
34586      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PARS')
34587     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
34588C
34589      NIOLD=NRIGHT(1)
34590      IF(NUMVAR.GT.1)THEN
34591        DO603II=2,NUMVAR
34592          NIOLD=MAX(NIOLD,NRIGHT(II))
34593  603   CONTINUE
34594      ENDIF
34595C
34596      IF(ICASEQ.EQ.'SUBS')THEN
34597        NIOLD=NRIGHT(1)
34598        CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR)
34599        NQ=NIOLD
34600      ELSEIF(ICASEQ.EQ.'FOR')THEN
34601        NIOLD=NRIGHT(1)
34602        CALL DPFOR(NIOLD,NFOR,IROW1,IROWN,NLOCAL,ILOCS,NS,IBUGQ,IERROR)
34603        NQ=NFOR
34604      ELSE
34605        DO610I=1,NIOLD
34606          ISUB(I)=1
34607  610   CONTINUE
34608        NQ=NIOLD
34609      ENDIF
34610C
34611C               *****************
34612C               **  STEP 90--  **
34613C               **  EXIT       **
34614C               *****************
34615C
34616 9000 CONTINUE
34617      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PARS')THEN
34618        WRITE(ICOUT,999)
34619        CALL DPWRST('XXX','BUG ')
34620        WRITE(ICOUT,9011)
34621 9011   FORMAT('***** AT THE END       OF DPPARS--')
34622        CALL DPWRST('XXX','BUG ')
34623        WRITE(ICOUT,9013)IFOUND,IERROR,NQ,NUMVAR
34624 9013   FORMAT('IFOUND,IERROR,NQ,NUMVAR = ',A4,2X,A4,2X,2I8)
34625        CALL DPWRST('XXX','BUG ')
34626        IF(NUMVAR.GE.1)THEN
34627          DO9022I=1,NUMVAR
34628            WRITE(ICOUT,9023)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I)
34629 9023       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I) = ',
34630     1             I8,2X,A4,2X,A4,2X,2I8)
34631            CALL DPWRST('XXX','BUG ')
34632 9022     CONTINUE
34633        ENDIF
34634      ENDIF
34635C
34636      RETURN
34637      END
34638      SUBROUTINE DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
34639     1                  INAME,IVARN1,IVARN2,IVARTY,
34640     1                  ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
34641     1                  MAXCOL,MAXCP1,MAXCP2,MAXCP3,
34642     1                  MAXCP4,MAXCP5,MAXCP6,
34643     1                  V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
34644     1                  Y,X,XHIGH,NLOCAL,NLOCA2,NLOCA3,ICASE,
34645     1                  IBUGG3,ISUBRO,IFOUND,IERROR)
34646C
34647C     PURPOSE--A UTILITY ROUTINE FOR PARSING A COMMAND LINE.  FOR
34648C              CASE WHERE COMMAND CAN TAKE EITHER A VARIABLE OR A
34649C              MATRIX ARGUMENT, EXTRACT THE DATA.
34650C     WRITTEN BY--ALAN HECKERT
34651C                 STATISTICAL ENGINEERING DIVISION
34652C                 INFORMATION TECHNOLOGY LABORATORY
34653C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
34654C                 GAITHERSBURG, MD 20899-8980
34655C                 PHONE--301-975-2899
34656C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
34657C           OF THE NATIONAL BUREAU OF STANDARDS.
34658C     LANGUAGE--ANSI FORTRAN (1977)
34659C     VERSION NUMBER--2010/3
34660C     ORIGINAL VERSION--MARCH     2010.
34661C
34662C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
34663C
34664      INTEGER IVALUE(*)
34665      INTEGER IVALU2(*)
34666      INTEGER IN(*)
34667      INTEGER ILIS(*)
34668      INTEGER ISUB(*)
34669      INTEGER NRIGHT(*)
34670      INTEGER ICOLR(*)
34671C
34672      REAL    V(*)
34673      REAL    PRED(*)
34674      REAL    RES(*)
34675      REAL    YPLOT(*)
34676      REAL    XPLOT(*)
34677      REAL    X2PLOT(*)
34678      REAL    TAGPLO(*)
34679C
34680      REAL    Y(*)
34681      REAL    X(*)
34682      REAL    XHIGH(*)
34683C
34684      CHARACTER*4 IVARN1(*)
34685      CHARACTER*4 IVARN2(*)
34686      CHARACTER*4 IVARTY(*)
34687C
34688      CHARACTER*4  ICASE
34689      CHARACTER*40 INAME
34690C
34691      CHARACTER*4 IBUGG3
34692      CHARACTER*4 ISUBRO
34693      CHARACTER*4 IFOUND
34694      CHARACTER*4 IERROR
34695C
34696      CHARACTER*4 ISUBN1
34697      CHARACTER*4 ISUBN2
34698C
34699C-----COMMON----------------------------------------------------------
34700C
34701C-----COMMON VARIABLES (GENERAL)--------------------------------------
34702C
34703      INCLUDE 'DPCOP2.INC'
34704C
34705C-----START POINT-----------------------------------------------------
34706C
34707      IERROR='NO'
34708      ISUBN1='DPPA'
34709      ISUBN2='R3  '
34710C
34711      N1=0
34712      NCOL=0
34713      ICOL1=0
34714      ICOL2=0
34715C
34716      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PAR3')THEN
34717        WRITE(ICOUT,999)
34718  999   FORMAT(1X)
34719        CALL DPWRST('XXX','BUG ')
34720        WRITE(ICOUT,51)
34721   51   FORMAT('***** AT THE BEGINNING OF DPPAR3--')
34722        CALL DPWRST('XXX','BUG ')
34723        WRITE(ICOUT,52)IBUGG3,ISUBRO,INAME
34724   52   FORMAT('IBUGG3,ISUBRO = ',A4,2X,A4,2X,A40)
34725        CALL DPWRST('XXX','BUG ')
34726        WRITE(ICOUT,54)ICOL,NUMVAR,NQ,NRIGHT(1)
34727   54   FORMAT('ICOL,NUMVAR,NQ,NRIGHT(1) = ',4I8)
34728        CALL DPWRST('XXX','BUG ')
34729        WRITE(ICOUT,56)IVARN1(ICOL),IVARN2(ICOL),ICOLR(ICOL)
34730   56   FORMAT('IVARN1(ICOL),IVARN2(ICOL),ICOLR(ICOL) = ',A4,2X,A4,I8)
34731        CALL DPWRST('XXX','BUG ')
34732      ENDIF
34733C
34734      IF(NUMVAR.GE.2)THEN
34735        IF(IVARTY(ICOL+1).NE.'VARI')THEN
34736          WRITE(ICOUT,101)INAME
34737  101     FORMAT('***** ERROR IN ',A40)
34738          CALL DPWRST('XXX','BUG ')
34739          WRITE(ICOUT,103)
34740  103     FORMAT('      THE SECOND RESPONSE VARIABLE MUST BE A ',
34741     1           'VARIABLE')
34742          CALL DPWRST('XXX','BUG ')
34743          WRITE(ICOUT,105)
34744  105     FORMAT('      (AS OPPOSSED TO A MATRIX OR A PARAMETER).')
34745          CALL DPWRST('XXX','BUG ')
34746          IERROR='YES'
34747          GOTO9000
34748        ENDIF
34749      ENDIF
34750C
34751      IF(NUMVAR.GE.3)THEN
34752        IF(IVARTY(ICOL+2).NE.'VARI')THEN
34753          WRITE(ICOUT,101)INAME
34754          CALL DPWRST('XXX','BUG ')
34755          WRITE(ICOUT,113)
34756  113     FORMAT('      THE THIRD RESPONSE VARIABLE MUST BE A VARIABLE')
34757          CALL DPWRST('XXX','BUG ')
34758          WRITE(ICOUT,105)
34759          CALL DPWRST('XXX','BUG ')
34760          IERROR='YES'
34761          GOTO9000
34762        ENDIF
34763      ENDIF
34764C
34765      IF(IVARTY(ICOL).EQ.'MATR')THEN
34766        ICASE='MATR'
34767        ILISR=ILIS(ICOL)
34768        ICOL1=IVALUE(ILISR)
34769        ICOL2=IVALU2(ILISR)
34770        N1=IN(ILISR)
34771        NCOL=(ICOL2 - ICOL1) + 1
34772      ELSE
34773        ICASE='VARI'
34774      ENDIF
34775C
34776      NLEFT=NRIGHT(ICOL)
34777C
34778      IF(ICASE.EQ.'VARI')THEN
34779        J=0
34780        IMAX=NLEFT
34781        IF(NQ.LT.NLEFT)IMAX=NQ
34782        DO210I=1,IMAX
34783C
34784          IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PAR3')THEN
34785            WRITE(ICOUT,211)I,ISUB(I)
34786  211       FORMAT('AT 210: I,ISUB(I) = ',2I8)
34787            CALL DPWRST('XXX','BUG ')
34788          ENDIF
34789C
34790          IF(ISUB(I).EQ.0)GOTO210
34791          J=J+1
34792          IJ=MAXN*(ICOLR(ICOL)-1)+I
34793          IF(ICOLR(ICOL).LE.MAXCOL)Y(J)=V(IJ)
34794          IF(ICOLR(ICOL).EQ.MAXCP1)Y(J)=PRED(I)
34795          IF(ICOLR(ICOL).EQ.MAXCP2)Y(J)=RES(I)
34796          IF(ICOLR(ICOL).EQ.MAXCP3)Y(J)=YPLOT(I)
34797          IF(ICOLR(ICOL).EQ.MAXCP4)Y(J)=XPLOT(I)
34798          IF(ICOLR(ICOL).EQ.MAXCP5)Y(J)=X2PLOT(I)
34799          IF(ICOLR(ICOL).EQ.MAXCP6)Y(J)=TAGPLO(I)
34800C
34801  210   CONTINUE
34802        NLOCAL=J
34803c
34804      ELSEIF(ICASE.EQ.'MATR')THEN
34805C
34806C       NOTE: FOR MATRIX CASE, ONLY FIRST ARGUMENT IS ALLOWED
34807C             TO BE MATRIX (SECOND AND THIRD VARIABLES ARE USED
34808C             TO DEFINE THE BIN BOUNDARIES).
34809C
34810        NLOOP=NCOL
34811        IF(NLOOP.LT.1)NLOOP=1
34812        IMAX=N1
34813        IF(NQ.LT.N1)IMAX=NQ
34814C
34815        ICNT=0
34816C
34817        DO310JLOOP=1,NLOOP
34818          DO320I=1,IMAX
34819            IF(ISUB(I).EQ.0)GOTO320
34820            ICNT=ICNT+1
34821C
34822            IF(ICNT.GT.MAXOBV)THEN
34823              WRITE(ICOUT,999)
34824              CALL DPWRST('XXX','BUG ')
34825              WRITE(ICOUT,101)
34826              CALL DPWRST('XXX','BUG ')
34827              WRITE(ICOUT,322)
34828  322         FORMAT('      FOR THE MATRIX CASE, THE MAXIMUM NUMBER')
34829              CALL DPWRST('XXX','BUG ')
34830              WRITE(ICOUT,324)
34831  324         FORMAT('      OF OBSERVATIONS HAS BEEN EXCEEDED.')
34832              CALL DPWRST('XXX','BUG ')
34833              WRITE(ICOUT,326)MAXCNT
34834  326         FORMAT('      THE MAXIMUM NUMBER OF OBSERVATIONS = ',I10)
34835              CALL DPWRST('XXX','BUG ')
34836              IERROR='YES'
34837              GOTO9000
34838            ENDIF
34839C
34840            ICOLT=ICOL1+JLOOP-1
34841            IJ=MAXN*(ICOLT-1)+I
34842C
34843            IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PAR3')THEN
34844              WRITE(ICOUT,331)JLOOP,ICOLT,ICNT,IJ
34845  331         FORMAT('JLOOP,ICOLT,ICNT,IJ = ',4I8)
34846              CALL DPWRST('XXX','BUG ')
34847            ENDIF
34848C
34849            IF(ICOLT.LE.MAXCOL)Y(ICNT)=V(IJ)
34850            IF(ICOLT.EQ.MAXCP1)Y(ICNT)=PRED(I)
34851            IF(ICOLT.EQ.MAXCP2)Y(ICNT)=RES(I)
34852            IF(ICOLT.EQ.MAXCP3)Y(ICNT)=YPLOT(I)
34853            IF(ICOLT.EQ.MAXCP4)Y(ICNT)=XPLOT(I)
34854            IF(ICOLT.EQ.MAXCP5)Y(ICNT)=X2PLOT(I)
34855            IF(ICOLT.EQ.MAXCP6)Y(ICNT)=TAGPLO(I)
34856C
34857  320     CONTINUE
34858  310   CONTINUE
34859        NLOCAL=ICNT
34860      ENDIF
34861C
34862      IF(NUMVAR.GE.2)THEN
34863        NLEFT=NRIGHT(ICOL+1)
34864        J=0
34865        IMAX=NLEFT
34866        IF(NQ.LT.NLEFT)IMAX=NQ
34867        DO410I=1,IMAX
34868          IF(ISUB(I).EQ.0)GOTO410
34869          J=J+1
34870C
34871          IF(NUMVAR.GE.2)THEN
34872            IJ=MAXN*(ICOLR(ICOL+1)-1)+I
34873            IF(ICOLR(ICOL+1).LE.MAXCOL)X(J)=V(IJ)
34874            IF(ICOLR(ICOL+1).EQ.MAXCP1)X(J)=PRED(I)
34875            IF(ICOLR(ICOL+1).EQ.MAXCP2)X(J)=RES(I)
34876            IF(ICOLR(ICOL+1).EQ.MAXCP3)X(J)=YPLOT(I)
34877            IF(ICOLR(ICOL+1).EQ.MAXCP4)X(J)=XPLOT(I)
34878            IF(ICOLR(ICOL+1).EQ.MAXCP5)X(J)=X2PLOT(I)
34879            IF(ICOLR(ICOL+1).EQ.MAXCP6)X(J)=TAGPLO(I)
34880          ENDIF
34881C
34882  410   CONTINUE
34883        NLOCA2=J
34884      ENDIF
34885C
34886      IF(NUMVAR.GE.3)THEN
34887        J=0
34888        NLEFT=NRIGHT(ICOL+2)
34889        IMAX=NLEFT
34890        IF(NQ.LT.NLEFT)IMAX=NQ
34891        DO510I=1,IMAX
34892          IF(ISUB(I).EQ.0)GOTO510
34893          J=J+1
34894C
34895          IF(NUMVAR.GE.3)THEN
34896            IJ=MAXN*(ICOLR(ICOL+2)-1)+I
34897            IF(ICOLR(ICOL+2).LE.MAXCOL)XHIGH(J)=V(IJ)
34898            IF(ICOLR(ICOL+2).EQ.MAXCP1)XHIGH(J)=PRED(I)
34899            IF(ICOLR(ICOL+2).EQ.MAXCP2)XHIGH(J)=RES(I)
34900            IF(ICOLR(ICOL+2).EQ.MAXCP3)XHIGH(J)=YPLOT(I)
34901            IF(ICOLR(ICOL+2).EQ.MAXCP4)XHIGH(J)=XPLOT(I)
34902            IF(ICOLR(ICOL+2).EQ.MAXCP5)XHIGH(J)=X2PLOT(I)
34903            IF(ICOLR(ICOL+2).EQ.MAXCP6)XHIGH(J)=TAGPLO(I)
34904          ENDIF
34905C
34906  510   CONTINUE
34907        NLOCA3=J
34908      ENDIF
34909C
34910C               *****************
34911C               **  STEP 90--  **
34912C               **  EXIT       **
34913C               *****************
34914C
34915 9000 CONTINUE
34916      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PAR3')THEN
34917        WRITE(ICOUT,999)
34918        CALL DPWRST('XXX','BUG ')
34919        WRITE(ICOUT,9011)
34920 9011   FORMAT('***** AT THE END       OF DPPAR2--')
34921        CALL DPWRST('XXX','BUG ')
34922        WRITE(ICOUT,9013)IFOUND,IERROR,NQ,NUMVAR,NLEFT,NLOCAL
34923 9013   FORMAT('IFOUND,IERROR,NQ,NUMVAR,NLEFT,NLOCAL = ',
34924     1         A4,2X,A4,2X,4I8)
34925        CALL DPWRST('XXX','BUG ')
34926        DO9022I=1,NLOCAL
34927          WRITE(ICOUT,9023)I,Y(I),X(I),XHIGH(I)
34928 9023     FORMAT('I,Y(I),X(I),XHIGH(I) = ',I8,3G15.7)
34929          CALL DPWRST('XXX','BUG ')
34930 9022   CONTINUE
34931      ENDIF
34932C
34933      RETURN
34934      END
34935      SUBROUTINE DPPAR4(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
34936     1                  INAME,IVARN1,IVARN2,IVARTY,
34937     1                  ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
34938     1                  MAXCOL,MAXCP1,MAXCP2,MAXCP3,
34939     1                  MAXCP4,MAXCP5,MAXCP6,
34940     1                  V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
34941     1                  Y,X,NLOCAL,NLOCA2,IFLAGM,IFLAGE,
34942     1                  IBUGG3,ISUBRO,IFOUND,IERROR)
34943C
34944C     PURPOSE--A UTILITY ROUTINE FOR PARSING A COMMAND LINE.  FOR
34945C              CASE WHERE COMMAND TAKES TWO VARIABLE ARGUMENTS OF
34946C              THE SAME LENGTH (E.G., RESPONSE AND LAB-ID).  AS A
34947C              NUMBER OF COMMANDS HAVE THIS FORMAT, WE HAVE EXTRACTED
34948C              THIS TO A DISTINCT SUBROUTINE.
34949C
34950C              THERE ARE 2 OPTIONS:
34951C
34952C                1) THE PARAMETER "IFLAGM" SPECIFIES WHETHER OR
34953C                   NOT MATRIX ARGUMENTS ARE ACCEPTED.
34954C
34955C                2) THE PARAMETER "IFLAGE" SPECIFIES WHETHER OR
34956C                   NOT THE RESPONSE VARIABLES MUST HAVE THE SAME
34957C                   NUMBER OF OBSERVATIONS OR NOT.
34958C
34959C              COMMANDS WHERE THE SECOND VARIABLE IS A GROUP-ID
34960C              VARIABLE (E.G., BOX PLOT) WILL TYPICALLY SET BOTH
34961C              OF THESE OPTIONS OFF.  COMMANDS WHERE THE TWO VARIABLES
34962C              ARE BOTH RESPONSE VARIABLES WILL TYPICALLY ALLOW MATRIX
34963C              ARGUMENTS.  EQUAL SAMPLE SIZES DEPENDS ON WHETHER THE
34964C              ROWS ARE PAIRED OR NOT.
34965C
34966C     WRITTEN BY--ALAN HECKERT
34967C                 STATISTICAL ENGINEERING DIVISION
34968C                 INFORMATION TECHNOLOGY LABORATORY
34969C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
34970C                 GAITHERSBURG, MD 20899-8980
34971C                 PHONE--301-975-2899
34972C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
34973C           OF THE NATIONAL BUREAU OF STANDARDS.
34974C     LANGUAGE--ANSI FORTRAN (1977)
34975C     VERSION NUMBER--2010/5
34976C     ORIGINAL VERSION--MAY       2010.
34977C
34978C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
34979C
34980      INTEGER IVALUE(*)
34981      INTEGER IVALU2(*)
34982      INTEGER IN(*)
34983      INTEGER ILIS(*)
34984      INTEGER ISUB(*)
34985      INTEGER NRIGHT(*)
34986      INTEGER ICOLR(*)
34987C
34988      REAL    V(*)
34989      REAL    PRED(*)
34990      REAL    RES(*)
34991      REAL    YPLOT(*)
34992      REAL    XPLOT(*)
34993      REAL    X2PLOT(*)
34994      REAL    TAGPLO(*)
34995C
34996      REAL    Y(*)
34997      REAL    X(*)
34998C
34999      CHARACTER*4 IVARN1(*)
35000      CHARACTER*4 IVARN2(*)
35001      CHARACTER*4 IVARTY(*)
35002C
35003      CHARACTER*4  ICASE
35004      CHARACTER*40 INAME
35005C
35006      CHARACTER*4 IBUGG3
35007      CHARACTER*4 ISUBRO
35008      CHARACTER*4 IFOUND
35009      CHARACTER*4 IERROR
35010C
35011      CHARACTER*4 ISUBN1
35012      CHARACTER*4 ISUBN2
35013C
35014C-----COMMON VARIABLES (GENERAL)--------------------------------------
35015C
35016      INCLUDE 'DPCOP2.INC'
35017C
35018C-----START POINT-----------------------------------------------------
35019C
35020      IERROR='NO'
35021      ISUBN1='DPPA'
35022      ISUBN2='R4  '
35023C
35024      N1=0
35025      NCOL=0
35026      ICOL1=0
35027      ICOL2=0
35028C
35029      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PAR4')THEN
35030        WRITE(ICOUT,999)
35031  999   FORMAT(1X)
35032        CALL DPWRST('XXX','BUG ')
35033        WRITE(ICOUT,51)
35034   51   FORMAT('***** AT THE BEGINNING OF DPPAR4--')
35035        CALL DPWRST('XXX','BUG ')
35036        WRITE(ICOUT,52)IBUGG3,ISUBRO,INAME
35037   52   FORMAT('IBUGG3,ISUBRO = ',A4,2X,A4,2X,A40)
35038        CALL DPWRST('XXX','BUG ')
35039        WRITE(ICOUT,54)ICOL,NUMVAR,NQ,NRIGHT(1),IFLAGE
35040   54   FORMAT('ICOL,NUMVAR,NQ,NRIGHT(1),IFLAGE = ',5I8)
35041        CALL DPWRST('XXX','BUG ')
35042        WRITE(ICOUT,56)IVARN1(ICOL),IVARN2(ICOL),ICOLR(ICOL)
35043   56   FORMAT('IVARN1(ICOL),IVARN2(ICOL),ICOLR(ICOL) = ',2(A4,2X),I8)
35044        CALL DPWRST('XXX','BUG ')
35045      ENDIF
35046C
35047      IF(IFLAGM.EQ.0)THEN
35048        DO100I=1,NUMVAR
35049          ITEMP=ICOL+I-1
35050          IF(IVARTY(ITEMP).NE.'VARI')THEN
35051            WRITE(ICOUT,101)INAME
35052  101       FORMAT('***** ERROR IN ',A40)
35053            CALL DPWRST('XXX','BUG ')
35054            WRITE(ICOUT,103)IVARN1(ITEMP),IVARN1(ITEMP)
35055  103       FORMAT('      RESPONSE VARIABLE ',A4,A4,' MUST BE A ',
35056     1             'VARIABLE')
35057            CALL DPWRST('XXX','BUG ')
35058            WRITE(ICOUT,105)
35059  105       FORMAT('      (AS OPPOSSED TO A MATRIX OR A PARAMETER).')
35060            CALL DPWRST('XXX','BUG ')
35061            IERROR='YES'
35062            GOTO9000
35063          ENDIF
35064  100   CONTINUE
35065      ENDIF
35066C
35067      DO200II=1,NUMVAR
35068        ITEMP=ICOL+II-1
35069        IF(IVARTY(ITEMP).EQ.'MATR')THEN
35070          ICASE='MATR'
35071          ILISR=ILIS(ITEMP)
35072          ICOL1=IVALUE(ILISR)
35073          ICOL2=IVALU2(ILISR)
35074          N1=IN(ILISR)
35075          NCOL=(ICOL2 - ICOL1) + 1
35076        ELSE
35077          ICASE='VARI'
35078        ENDIF
35079C
35080        NLEFT=NRIGHT(ITEMP)
35081C
35082        IF(ICASE.EQ.'VARI')THEN
35083          J=0
35084          IMAX=NLEFT
35085          IF(NQ.LT.NLEFT)IMAX=NQ
35086          DO210I=1,IMAX
35087C
35088            IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PAR4')THEN
35089              WRITE(ICOUT,211)I,ISUB(I)
35090  211         FORMAT('AT 210: I,ISUB(I) = ',2I8)
35091              CALL DPWRST('XXX','BUG ')
35092            ENDIF
35093C
35094            IF(ISUB(I).EQ.0)GOTO210
35095            J=J+1
35096            IJ=MAXN*(ICOLR(ITEMP)-1)+I
35097            IF(II.EQ.1)THEN
35098              IF(ICOLR(ITEMP).LE.MAXCOL)Y(J)=V(IJ)
35099              IF(ICOLR(ITEMP).EQ.MAXCP1)Y(J)=PRED(I)
35100              IF(ICOLR(ITEMP).EQ.MAXCP2)Y(J)=RES(I)
35101              IF(ICOLR(ITEMP).EQ.MAXCP3)Y(J)=YPLOT(I)
35102              IF(ICOLR(ITEMP).EQ.MAXCP4)Y(J)=XPLOT(I)
35103              IF(ICOLR(ITEMP).EQ.MAXCP5)Y(J)=X2PLOT(I)
35104              IF(ICOLR(ITEMP).EQ.MAXCP6)Y(J)=TAGPLO(I)
35105            ELSEIF(II.EQ.2)THEN
35106              IF(ICOLR(ITEMP).LE.MAXCOL)X(J)=V(IJ)
35107              IF(ICOLR(ITEMP).EQ.MAXCP1)X(J)=PRED(I)
35108              IF(ICOLR(ITEMP).EQ.MAXCP2)X(J)=RES(I)
35109              IF(ICOLR(ITEMP).EQ.MAXCP3)X(J)=YPLOT(I)
35110              IF(ICOLR(ITEMP).EQ.MAXCP4)X(J)=XPLOT(I)
35111              IF(ICOLR(ITEMP).EQ.MAXCP5)X(J)=X2PLOT(I)
35112              IF(ICOLR(ITEMP).EQ.MAXCP6)X(J)=TAGPLO(I)
35113            ENDIF
35114C
35115  210     CONTINUE
35116          IF(II.EQ.1)THEN
35117            NLOCAL=J
35118          ELSE
35119            NLOCA2=J
35120          ENDIF
35121C
35122        ELSEIF(ICASE.EQ.'MATR')THEN
35123C
35124          NLOOP=NCOL
35125          IF(NLOOP.LT.1)NLOOP=1
35126          IMAX=N1
35127          IF(NQ.LT.N1)IMAX=NQ
35128C
35129          ICNT=0
35130C
35131          DO310JLOOP=1,NLOOP
35132            DO320I=1,IMAX
35133              IF(ISUB(I).EQ.0)GOTO320
35134              ICNT=ICNT+1
35135C
35136              IF(ICNT.GT.MAXOBV)THEN
35137                WRITE(ICOUT,999)
35138                CALL DPWRST('XXX','BUG ')
35139                WRITE(ICOUT,101)INAME
35140                CALL DPWRST('XXX','BUG ')
35141                WRITE(ICOUT,322)
35142  322           FORMAT('      FOR THE MATRIX CASE, THE MAXIMUM NUMBER')
35143                CALL DPWRST('XXX','BUG ')
35144                WRITE(ICOUT,324)
35145  324           FORMAT('      OF OBSERVATIONS HAS BEEN EXCEEDED.')
35146                CALL DPWRST('XXX','BUG ')
35147                WRITE(ICOUT,326)MAXCNT
35148  326           FORMAT('      THE MAXIMUM NUMBER OF OBSERVATIONS = ',
35149     1                 I10)
35150                CALL DPWRST('XXX','BUG ')
35151                IERROR='YES'
35152                GOTO9000
35153              ENDIF
35154C
35155              ICOLT=ICOL1+JLOOP-1
35156              IJ=MAXN*(ICOLT-1)+I
35157C
35158              IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PAR4')THEN
35159                WRITE(ICOUT,331)JLOOP,ICOLT,ICNT,IJ
35160  331           FORMAT('JLOOP,ICOLT,ICNT,IJ = ',4I8)
35161                CALL DPWRST('XXX','BUG ')
35162              ENDIF
35163C
35164              IF(II.EQ.1)THEN
35165                IF(ICOLT.LE.MAXCOL)Y(ICNT)=V(IJ)
35166                IF(ICOLT.EQ.MAXCP1)Y(ICNT)=PRED(I)
35167                IF(ICOLT.EQ.MAXCP2)Y(ICNT)=RES(I)
35168                IF(ICOLT.EQ.MAXCP3)Y(ICNT)=YPLOT(I)
35169                IF(ICOLT.EQ.MAXCP4)Y(ICNT)=XPLOT(I)
35170                IF(ICOLT.EQ.MAXCP5)Y(ICNT)=X2PLOT(I)
35171                IF(ICOLT.EQ.MAXCP6)Y(ICNT)=TAGPLO(I)
35172              ELSEIF(II.EQ.2)THEN
35173                IF(ICOLT.LE.MAXCOL)X(ICNT)=V(IJ)
35174                IF(ICOLT.EQ.MAXCP1)X(ICNT)=PRED(I)
35175                IF(ICOLT.EQ.MAXCP2)X(ICNT)=RES(I)
35176                IF(ICOLT.EQ.MAXCP3)X(ICNT)=YPLOT(I)
35177                IF(ICOLT.EQ.MAXCP4)X(ICNT)=XPLOT(I)
35178                IF(ICOLT.EQ.MAXCP5)X(ICNT)=X2PLOT(I)
35179                IF(ICOLT.EQ.MAXCP6)X(ICNT)=TAGPLO(I)
35180              ENDIF
35181C
35182  320       CONTINUE
35183  310     CONTINUE
35184          IF(II.EQ.1)THEN
35185            NLOCAL=ICNT
35186          ELSE
35187            NLOCA2=ICNT
35188          ENDIF
35189        ENDIF
35190  200 CONTINUE
35191C
35192C               *****************
35193C               **  STEP 90--  **
35194C               **  EXIT       **
35195C               *****************
35196C
35197 9000 CONTINUE
35198      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PAR4')THEN
35199        WRITE(ICOUT,999)
35200        CALL DPWRST('XXX','BUG ')
35201        WRITE(ICOUT,9011)
35202 9011   FORMAT('***** AT THE END       OF DPPAR4--')
35203        CALL DPWRST('XXX','BUG ')
35204        WRITE(ICOUT,9013)IFOUND,IERROR,NQ,NUMVAR,NLEFT,NLOCAL
35205 9013   FORMAT('IFOUND,IERROR,NQ,NUMVAR,NLEFT,NLOCAL = ',
35206     1         A4,2X,A4,2X,4I8)
35207        CALL DPWRST('XXX','BUG ')
35208        DO9022I=1,MIN(NLOCAL,100)
35209          WRITE(ICOUT,9023)I,Y(I),X(I)
35210 9023     FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
35211          CALL DPWRST('XXX','BUG ')
35212 9022   CONTINUE
35213      ENDIF
35214C
35215      RETURN
35216      END
35217      SUBROUTINE DPPAR5(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
35218     1                  INAME,IVARN1,IVARN2,IVARTY,
35219     1                  ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
35220     1                  MAXCOL,MAXCP1,MAXCP2,MAXCP3,
35221     1                  MAXCP4,MAXCP5,MAXCP6,
35222     1                  V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
35223     1                  Y,X1,X2,X3,X4,X5,X6,NLOCAL,
35224     1                  IBUGG3,ISUBRO,IFOUND,IERROR)
35225C
35226C     PURPOSE--A VARIANT OF DPPAR3 THAT CAN ACCEPT UP TO SEVEN
35227C              VARIABLES (INSTEAD OF THREE).  NOTE THAT THIS
35228C              VERSION DOES NOT ACCEPT MATRIX ARGUMENTS.
35229C     WRITTEN BY--ALAN HECKERT
35230C                 STATISTICAL ENGINEERING DIVISION
35231C                 INFORMATION TECHNOLOGY LABORATORY
35232C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
35233C                 GAITHERSBURG, MD 20899-8980
35234C                 PHONE--301-975-2899
35235C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
35236C           OF THE NATIONAL BUREAU OF STANDARDS.
35237C     LANGUAGE--ANSI FORTRAN (1977)
35238C     VERSION NUMBER--2010/6
35239C     ORIGINAL VERSION--JUNE      2010.
35240C
35241C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
35242C
35243      INTEGER IVALUE(*)
35244      INTEGER IVALU2(*)
35245      INTEGER IN(*)
35246      INTEGER ILIS(*)
35247      INTEGER ISUB(*)
35248      INTEGER NRIGHT(*)
35249      INTEGER ICOLR(*)
35250C
35251      REAL    V(*)
35252      REAL    PRED(*)
35253      REAL    RES(*)
35254      REAL    YPLOT(*)
35255      REAL    XPLOT(*)
35256      REAL    X2PLOT(*)
35257      REAL    TAGPLO(*)
35258C
35259      REAL    Y(*)
35260      REAL    X1(*)
35261      REAL    X2(*)
35262      REAL    X3(*)
35263      REAL    X4(*)
35264      REAL    X5(*)
35265      REAL    X6(*)
35266C
35267      CHARACTER*4 IVARN1(*)
35268      CHARACTER*4 IVARN2(*)
35269      CHARACTER*4 IVARTY(*)
35270C
35271      CHARACTER*40 INAME
35272C
35273      CHARACTER*4 IBUGG3
35274      CHARACTER*4 ISUBRO
35275      CHARACTER*4 IFOUND
35276      CHARACTER*4 IERROR
35277C
35278      CHARACTER*4 ISUBN1
35279      CHARACTER*4 ISUBN2
35280C
35281C
35282C-----COMMON VARIABLES (GENERAL)--------------------------------------
35283C
35284      INCLUDE 'DPCOP2.INC'
35285C
35286C-----START POINT-----------------------------------------------------
35287C
35288      IERROR='NO'
35289      ISUBN1='DPPA'
35290      ISUBN2='R5  '
35291C
35292      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PAR5')THEN
35293        WRITE(ICOUT,999)
35294  999   FORMAT(1X)
35295        CALL DPWRST('XXX','BUG ')
35296        WRITE(ICOUT,51)
35297   51   FORMAT('***** AT THE BEGINNING OF DPPAR5--')
35298        CALL DPWRST('XXX','BUG ')
35299        WRITE(ICOUT,52)IBUGG3,ISUBRO,INAME
35300   52   FORMAT('IBUGG3,ISUBRO = ',A4,2X,A4,2X,A40)
35301        CALL DPWRST('XXX','BUG ')
35302        WRITE(ICOUT,54)ICOL,NUMVAR,NQ,NRIGHT(1),ILIS(1),MAXOBV
35303   54   FORMAT('ICOL,NUMVAR,NQ,NRIGHT(1),ILIS(1),MAXOBV = ',6I8)
35304        CALL DPWRST('XXX','BUG ')
35305        WRITE(ICOUT,56)IVARN1(ICOL),IVARN2(ICOL),ICOLR(ICOL)
35306   56   FORMAT('IVARN1(ICOL),IVARN2(ICOL),ICOLR(ICOL) = ',2(A4,2X),I8)
35307        CALL DPWRST('XXX','BUG ')
35308        DO67I=1,10
35309          WRITE(ICOUT,68)I,IN(I),IVALUE(I),IVALU2(I)
35310   68     FORMAT('I,IN(I),IVALUE(I),IVALU2(I) = ',4I8)
35311          CALL DPWRST('XXX','BUG ')
35312   67   CONTINUE
35313      ENDIF
35314C
35315      DO100I=1,NUMVAR
35316        IF(IVARTY(ICOL+I-1).NE.'VARI')THEN
35317          WRITE(ICOUT,101)INAME
35318  101     FORMAT('***** ERROR IN ',A40)
35319          CALL DPWRST('XXX','BUG ')
35320          WRITE(ICOUT,103)I
35321  103     FORMAT('      RESPONSE VARIABLE ',I5,' MUST BE A ',
35322     1           'VARIABLE')
35323          CALL DPWRST('XXX','BUG ')
35324          WRITE(ICOUT,105)
35325  105     FORMAT('      (AS OPPOSSED TO A MATRIX OR A PARAMETER).')
35326          CALL DPWRST('XXX','BUG ')
35327          IERROR='YES'
35328          GOTO9000
35329        ENDIF
35330  100 CONTINUE
35331C
35332      NLEFT=NRIGHT(ICOL)
35333C
35334      J=0
35335      IMAX=NLEFT
35336      IF(NQ.LT.NLEFT)IMAX=NQ
35337      DO210I=1,IMAX
35338C
35339        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PAR5')THEN
35340          WRITE(ICOUT,211)I,ISUB(I)
35341  211     FORMAT('AT 210: I,ISUB(I) = ',2I8)
35342          CALL DPWRST('XXX','BUG ')
35343        ENDIF
35344C
35345        IF(ISUB(I).EQ.0)GOTO210
35346        J=J+1
35347        IJ=MAXN*(ICOLR(ICOL)-1)+I
35348        IF(ICOLR(ICOL).LE.MAXCOL)Y(J)=V(IJ)
35349        IF(ICOLR(ICOL).EQ.MAXCP1)Y(J)=PRED(I)
35350        IF(ICOLR(ICOL).EQ.MAXCP2)Y(J)=RES(I)
35351        IF(ICOLR(ICOL).EQ.MAXCP3)Y(J)=YPLOT(I)
35352        IF(ICOLR(ICOL).EQ.MAXCP4)Y(J)=XPLOT(I)
35353        IF(ICOLR(ICOL).EQ.MAXCP5)Y(J)=X2PLOT(I)
35354        IF(ICOLR(ICOL).EQ.MAXCP6)Y(J)=TAGPLO(I)
35355C
35356        IF(NUMVAR.GE.2)THEN
35357          IJ=MAXN*(ICOLR(ICOL+1)-1)+I
35358          IF(ICOLR(ICOL+1).LE.MAXCOL)X1(J)=V(IJ)
35359          IF(ICOLR(ICOL+1).EQ.MAXCP1)X1(J)=PRED(I)
35360          IF(ICOLR(ICOL+1).EQ.MAXCP2)X1(J)=RES(I)
35361          IF(ICOLR(ICOL+1).EQ.MAXCP3)X1(J)=YPLOT(I)
35362          IF(ICOLR(ICOL+1).EQ.MAXCP4)X1(J)=XPLOT(I)
35363          IF(ICOLR(ICOL+1).EQ.MAXCP5)X1(J)=X2PLOT(I)
35364          IF(ICOLR(ICOL+1).EQ.MAXCP6)X1(J)=TAGPLO(I)
35365        ENDIF
35366C
35367        IF(NUMVAR.GE.3)THEN
35368          IJ=MAXN*(ICOLR(ICOL+2)-1)+I
35369          IF(ICOLR(ICOL+1).LE.MAXCOL)X2(J)=V(IJ)
35370          IF(ICOLR(ICOL+1).EQ.MAXCP1)X2(J)=PRED(I)
35371          IF(ICOLR(ICOL+1).EQ.MAXCP2)X2(J)=RES(I)
35372          IF(ICOLR(ICOL+1).EQ.MAXCP3)X2(J)=YPLOT(I)
35373          IF(ICOLR(ICOL+1).EQ.MAXCP4)X2(J)=XPLOT(I)
35374          IF(ICOLR(ICOL+1).EQ.MAXCP5)X2(J)=X2PLOT(I)
35375          IF(ICOLR(ICOL+1).EQ.MAXCP6)X2(J)=TAGPLO(I)
35376        ENDIF
35377C
35378        IF(NUMVAR.GE.4)THEN
35379          IJ=MAXN*(ICOLR(ICOL+3)-1)+I
35380          IF(ICOLR(ICOL+1).LE.MAXCOL)X3(J)=V(IJ)
35381          IF(ICOLR(ICOL+1).EQ.MAXCP1)X3(J)=PRED(I)
35382          IF(ICOLR(ICOL+1).EQ.MAXCP2)X3(J)=RES(I)
35383          IF(ICOLR(ICOL+1).EQ.MAXCP3)X3(J)=YPLOT(I)
35384          IF(ICOLR(ICOL+1).EQ.MAXCP4)X3(J)=XPLOT(I)
35385          IF(ICOLR(ICOL+1).EQ.MAXCP5)X3(J)=X2PLOT(I)
35386          IF(ICOLR(ICOL+1).EQ.MAXCP6)X3(J)=TAGPLO(I)
35387        ENDIF
35388C
35389        IF(NUMVAR.GE.5)THEN
35390          IJ=MAXN*(ICOLR(ICOL+4)-1)+I
35391          IF(ICOLR(ICOL+1).LE.MAXCOL)X4(J)=V(IJ)
35392          IF(ICOLR(ICOL+1).EQ.MAXCP1)X4(J)=PRED(I)
35393          IF(ICOLR(ICOL+1).EQ.MAXCP2)X4(J)=RES(I)
35394          IF(ICOLR(ICOL+1).EQ.MAXCP3)X4(J)=YPLOT(I)
35395          IF(ICOLR(ICOL+1).EQ.MAXCP4)X4(J)=XPLOT(I)
35396          IF(ICOLR(ICOL+1).EQ.MAXCP5)X4(J)=X2PLOT(I)
35397          IF(ICOLR(ICOL+1).EQ.MAXCP6)X4(J)=TAGPLO(I)
35398        ENDIF
35399C
35400        IF(NUMVAR.GE.6)THEN
35401          IJ=MAXN*(ICOLR(ICOL+5)-1)+I
35402          IF(ICOLR(ICOL+1).LE.MAXCOL)X5(J)=V(IJ)
35403          IF(ICOLR(ICOL+1).EQ.MAXCP1)X5(J)=PRED(I)
35404          IF(ICOLR(ICOL+1).EQ.MAXCP2)X5(J)=RES(I)
35405          IF(ICOLR(ICOL+1).EQ.MAXCP3)X5(J)=YPLOT(I)
35406          IF(ICOLR(ICOL+1).EQ.MAXCP4)X5(J)=XPLOT(I)
35407          IF(ICOLR(ICOL+1).EQ.MAXCP5)X5(J)=X2PLOT(I)
35408          IF(ICOLR(ICOL+1).EQ.MAXCP6)X5(J)=TAGPLO(I)
35409        ENDIF
35410C
35411        IF(NUMVAR.GE.7)THEN
35412          IJ=MAXN*(ICOLR(ICOL+6)-1)+I
35413          IF(ICOLR(ICOL+1).LE.MAXCOL)X6(J)=V(IJ)
35414          IF(ICOLR(ICOL+1).EQ.MAXCP1)X6(J)=PRED(I)
35415          IF(ICOLR(ICOL+1).EQ.MAXCP2)X6(J)=RES(I)
35416          IF(ICOLR(ICOL+1).EQ.MAXCP3)X6(J)=YPLOT(I)
35417          IF(ICOLR(ICOL+1).EQ.MAXCP4)X6(J)=XPLOT(I)
35418          IF(ICOLR(ICOL+1).EQ.MAXCP5)X6(J)=X2PLOT(I)
35419          IF(ICOLR(ICOL+1).EQ.MAXCP6)X6(J)=TAGPLO(I)
35420        ENDIF
35421C
35422  210 CONTINUE
35423      NLOCAL=J
35424c
35425C               *****************
35426C               **  STEP 90--  **
35427C               **  EXIT       **
35428C               *****************
35429C
35430 9000 CONTINUE
35431      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PAR5')THEN
35432        WRITE(ICOUT,999)
35433        CALL DPWRST('XXX','BUG ')
35434        WRITE(ICOUT,9011)
35435 9011   FORMAT('***** AT THE END       OF DPPAR2--')
35436        CALL DPWRST('XXX','BUG ')
35437        WRITE(ICOUT,9013)IFOUND,IERROR,NQ,NUMVAR,NLEFT,NLOCAL
35438 9013   FORMAT('IFOUND,IERROR,NQ,NUMVAR,NLEFT,NLOCAL = ',
35439     1         A4,2X,A4,2X,4I8)
35440        CALL DPWRST('XXX','BUG ')
35441        DO9022I=1,NLOCAL
35442          WRITE(ICOUT,9023)I,Y(I),X1(I),X2(I),X3(I),X4(I)
35443 9023     FORMAT('I,Y(I),X1(I),X2(I),X3(I),X4(I) = ',I8,5G15.7)
35444          CALL DPWRST('XXX','BUG ')
35445 9022   CONTINUE
35446      ENDIF
35447C
35448      RETURN
35449      END
35450      SUBROUTINE DPPAR6(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
35451     1                  INAME,IVARN1,IVARN2,IVARTY,
35452     1                  ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
35453     1                  MAXCOL,MAXCP1,MAXCP2,MAXCP3,
35454     1                  MAXCP4,MAXCP5,MAXCP6,
35455     1                  V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
35456     1                  XMAT,MAXROW,N1,NCOL,ICASE,
35457     1                  IBUGG3,ISUBRO,IFOUND,IERROR)
35458C
35459C     PURPOSE--A UTILITY ROUTINE FOR PARSING A COMMAND LINE.  FOR
35460C              CASE WHERE COMMAND CAN TAKE A SINGLE MATRIX.  THIS
35461C              DIFFERS FROM DPPAR3 WHERE THE MATRIX IS EXTRACTED
35462C              INTO A SINGLE VARIABLE, THIS COMMAND EXTRACTS
35463C              THE MATRIX AS A MATRIX.
35464C     WRITTEN BY--ALAN HECKERT
35465C                 STATISTICAL ENGINEERING DIVISION
35466C                 INFORMATION TECHNOLOGY LABORATORY
35467C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
35468C                 GAITHERSBURG, MD 20899-8980
35469C                 PHONE--301-975-2899
35470C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
35471C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
35472C     LANGUAGE--ANSI FORTRAN (1977)
35473C     VERSION NUMBER--2010/12
35474C     ORIGINAL VERSION--DECEMBER  2010.
35475C
35476C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
35477C
35478      INTEGER IVALUE(*)
35479      INTEGER IVALU2(*)
35480      INTEGER IN(*)
35481      INTEGER ILIS(*)
35482      INTEGER ISUB(*)
35483      INTEGER NRIGHT(*)
35484      INTEGER ICOLR(*)
35485C
35486      REAL    V(*)
35487      REAL    PRED(*)
35488      REAL    RES(*)
35489      REAL    YPLOT(*)
35490      REAL    XPLOT(*)
35491      REAL    X2PLOT(*)
35492      REAL    TAGPLO(*)
35493C
35494      REAL    XMAT(MAXROW,NCOL)
35495C
35496      CHARACTER*4 IVARN1(*)
35497      CHARACTER*4 IVARN2(*)
35498      CHARACTER*4 IVARTY(*)
35499C
35500      CHARACTER*4  ICASE
35501      CHARACTER*40 INAME
35502C
35503      CHARACTER*4 IBUGG3
35504      CHARACTER*4 ISUBRO
35505      CHARACTER*4 IFOUND
35506      CHARACTER*4 IERROR
35507C
35508      CHARACTER*4 ISUBN1
35509      CHARACTER*4 ISUBN2
35510C
35511C-----COMMON----------------------------------------------------------
35512C
35513C-----COMMON VARIABLES (GENERAL)--------------------------------------
35514C
35515      INCLUDE 'DPCOP2.INC'
35516C
35517C-----START POINT-----------------------------------------------------
35518C
35519      IERROR='NO'
35520      ISUBN1='DPPA'
35521      ISUBN2='R4  '
35522C
35523      ICOL1=0
35524C
35525      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PAR6')THEN
35526        WRITE(ICOUT,999)
35527  999   FORMAT(1X)
35528        CALL DPWRST('XXX','BUG ')
35529        WRITE(ICOUT,51)
35530   51   FORMAT('***** AT THE BEGINNING OF DPPAR6--')
35531        CALL DPWRST('XXX','BUG ')
35532        WRITE(ICOUT,52)IBUGG3,ISUBRO,INAME
35533   52   FORMAT('IBUGG3,ISUBRO = ',A4,2X,A4,2X,A40)
35534        CALL DPWRST('XXX','BUG ')
35535        WRITE(ICOUT,54)ICOL,NUMVAR,NQ,NRIGHT(1)
35536   54   FORMAT('ICOL,NUMVAR,NQ,NRIGHT(1) = ',4I8)
35537        CALL DPWRST('XXX','BUG ')
35538        WRITE(ICOUT,56)IVARN1(ICOL),IVARN2(ICOL),ICOLR(ICOL)
35539   56   FORMAT('IVARN1(ICOL),IVARN2(ICOL),ICOLR(ICOL) = ',A4,2X,A4,I8)
35540        CALL DPWRST('XXX','BUG ')
35541      ENDIF
35542C
35543      IF(IVARTY(ICOL).EQ.'MATR')THEN
35544        ICASE='MATR'
35545        ILISR=ILIS(ICOL)
35546        ICOL1=IVALUE(ILISR)
35547        ICOL2=IVALU2(ILISR)
35548        N1=IN(ILISR)
35549        NCOL=(ICOL2 - ICOL1) + 1
35550      ELSE
35551        ICASE='VARI'
35552      ENDIF
35553C
35554      NLEFT=NRIGHT(ICOL)
35555C
35556      IF(ICASE.EQ.'VARI')THEN
35557        J=0
35558        IMAX=NLEFT
35559        IF(NQ.LT.NLEFT)IMAX=NQ
35560        DO210I=1,IMAX
35561C
35562          IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PAR6')THEN
35563            WRITE(ICOUT,211)I,ISUB(I)
35564  211       FORMAT('AT 210: I,ISUB(I) = ',2I8)
35565            CALL DPWRST('XXX','BUG ')
35566          ENDIF
35567C
35568          IF(ISUB(I).EQ.0)GOTO210
35569          J=J+1
35570          IJ=MAXN*(ICOLR(ICOL)-1)+I
35571          IF(ICOLR(ICOL).LE.MAXCOL)XMAT(J,1)=V(IJ)
35572          IF(ICOLR(ICOL).EQ.MAXCP1)XMAT(J,1)=PRED(I)
35573          IF(ICOLR(ICOL).EQ.MAXCP2)XMAT(J,1)=RES(I)
35574          IF(ICOLR(ICOL).EQ.MAXCP3)XMAT(J,1)=YPLOT(I)
35575          IF(ICOLR(ICOL).EQ.MAXCP4)XMAT(J,1)=XPLOT(I)
35576          IF(ICOLR(ICOL).EQ.MAXCP5)XMAT(J,1)=X2PLOT(I)
35577          IF(ICOLR(ICOL).EQ.MAXCP6)XMAT(J,1)=TAGPLO(I)
35578C
35579  210   CONTINUE
35580        NLOCAL=J
35581c
35582      ELSEIF(ICASE.EQ.'MATR')THEN
35583C
35584        NLOOP=NCOL
35585        IF(NLOOP.LT.1)NLOOP=1
35586        IMAX=N1
35587        IF(NQ.LT.N1)IMAX=NQ
35588C
35589        DO310JLOOP=1,NLOOP
35590          ICNT=0
35591          DO320I=1,IMAX
35592            IF(ISUB(I).EQ.0)GOTO320
35593            ICNT=ICNT+1
35594C
35595            IF(ICNT.GT.MAXOBV)THEN
35596              WRITE(ICOUT,999)
35597              CALL DPWRST('XXX','BUG ')
35598              WRITE(ICOUT,101)INAME
35599  101         FORMAT('****** ERROR IN ',A40)
35600              CALL DPWRST('XXX','BUG ')
35601              WRITE(ICOUT,322)
35602  322         FORMAT('      FOR THE MATRIX CASE, THE MAXIMUM NUMBER')
35603              CALL DPWRST('XXX','BUG ')
35604              WRITE(ICOUT,324)
35605  324         FORMAT('      OF OBSERVATIONS HAS BEEN EXCEEDED.')
35606              CALL DPWRST('XXX','BUG ')
35607              WRITE(ICOUT,326)MAXCNT
35608  326         FORMAT('      THE MAXIMUM NUMBER OF OBSERVATIONS = ',I10)
35609              CALL DPWRST('XXX','BUG ')
35610              IERROR='YES'
35611              GOTO9000
35612            ENDIF
35613C
35614            ICOLT=ICOL1+JLOOP-1
35615            IJ=MAXN*(ICOLT-1)+I
35616C
35617            IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PAR6')THEN
35618              WRITE(ICOUT,331)JLOOP,ICOLT,ICNT,IJ
35619  331         FORMAT('JLOOP,ICOLT,ICNT,IJ = ',4I8)
35620              CALL DPWRST('XXX','BUG ')
35621            ENDIF
35622C
35623            IF(ICOLT.LE.MAXCOL)XMAT(ICNT,JLOOP)=V(IJ)
35624            IF(ICOLT.EQ.MAXCP1)XMAT(ICNT,JLOOP)=PRED(I)
35625            IF(ICOLT.EQ.MAXCP2)XMAT(ICNT,JLOOP)=RES(I)
35626            IF(ICOLT.EQ.MAXCP3)XMAT(ICNT,JLOOP)=YPLOT(I)
35627            IF(ICOLT.EQ.MAXCP4)XMAT(ICNT,JLOOP)=XPLOT(I)
35628            IF(ICOLT.EQ.MAXCP5)XMAT(ICNT,JLOOP)=X2PLOT(I)
35629            IF(ICOLT.EQ.MAXCP6)XMAT(ICNT,JLOOP)=TAGPLO(I)
35630C
35631  320     CONTINUE
35632          NROW=ICNT
35633  310   CONTINUE
35634      ENDIF
35635C
35636C               *****************
35637C               **  STEP 90--  **
35638C               **  EXIT       **
35639C               *****************
35640C
35641 9000 CONTINUE
35642      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PAR6')THEN
35643        WRITE(ICOUT,999)
35644        CALL DPWRST('XXX','BUG ')
35645        WRITE(ICOUT,9011)
35646 9011   FORMAT('***** AT THE END       OF DPPAR6--')
35647        CALL DPWRST('XXX','BUG ')
35648        WRITE(ICOUT,9013)IFOUND,IERROR,NQ,NUMVAR,NLEFT,NROW
35649 9013   FORMAT('IFOUND,IERROR,NQ,NUMVAR,NLEFT,NROW = ',
35650     1        A4,2X,A4,2X,4I8)
35651        CALL DPWRST('XXX','BUG ')
35652        DO9022I=1,NROW
35653          WRITE(ICOUT,9023)I,(XMAT(I,J),J=1,MAX(5,NCOL))
35654 9023     FORMAT('I,XMAT(I,J) = ',I8,5G15.7)
35655          CALL DPWRST('XXX','BUG ')
35656 9022   CONTINUE
35657      ENDIF
35658C
35659      RETURN
35660      END
35661      SUBROUTINE DPPAR7(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
35662     1                  INAME,IVARN1,IVARN2,IVARTY,
35663     1                  ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
35664     1                  MAXCOL,MAXCP1,MAXCP2,MAXCP3,
35665     1                  MAXCP4,MAXCP5,MAXCP6,
35666     1                  V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
35667     1                  Y1,Y2,Y3,Y4,NLOCAL,NLOCA2,NLOCA3,NLOCA4,
35668     1                  IBUGG3,ISUBRO,IFOUND,IERROR)
35669C
35670C     PURPOSE--A UTILITY ROUTINE FOR PARSING A COMMAND LINE.  FOR
35671C              CASE WHERE COMMAND CAN TAKE FROM ONE TO FOUR VARIABLES,
35672C              NOT NECESSARILY OF THE SAME LENGTH.  THIS ROUTINE DOES
35673C              ACCEPT MATRIX ARGUMENTS.
35674C     WRITTEN BY--ALAN HECKERT
35675C                 STATISTICAL ENGINEERING DIVISION
35676C                 INFORMATION TECHNOLOGY LABORATORY
35677C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
35678C                 GAITHERSBURG, MD 20899-8980
35679C                 PHONE--301-975-2899
35680C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
35681C           OF THE NATIONAL BUREAU OF STANDARDS.
35682C     LANGUAGE--ANSI FORTRAN (1977)
35683C     VERSION NUMBER--2011/1
35684C     ORIGINAL VERSION--JANUARY   2011.
35685C     UPDATED         --JUNE      2016. BUG FIX
35686C
35687C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
35688C
35689      INTEGER IVALUE(*)
35690      INTEGER IVALU2(*)
35691      INTEGER IN(*)
35692      INTEGER ILIS(*)
35693      INTEGER ISUB(*)
35694      INTEGER NRIGHT(*)
35695      INTEGER ICOLR(*)
35696C
35697      REAL    V(*)
35698      REAL    PRED(*)
35699      REAL    RES(*)
35700      REAL    YPLOT(*)
35701      REAL    XPLOT(*)
35702      REAL    X2PLOT(*)
35703      REAL    TAGPLO(*)
35704C
35705      REAL    Y1(*)
35706      REAL    Y2(*)
35707      REAL    Y3(*)
35708      REAL    Y4(*)
35709C
35710      CHARACTER*4 IVARN1(*)
35711      CHARACTER*4 IVARN2(*)
35712      CHARACTER*4 IVARTY(*)
35713C
35714      CHARACTER*40 INAME
35715      CHARACTER*4 IBUGG3
35716      CHARACTER*4 ISUBRO
35717      CHARACTER*4 IFOUND
35718      CHARACTER*4 IERROR
35719      CHARACTER*4 ISUBN1
35720      CHARACTER*4 ISUBN2
35721C
35722C-----COMMON VARIABLES (GENERAL)--------------------------------------
35723C
35724      INCLUDE 'DPCOP2.INC'
35725C
35726C-----START POINT-----------------------------------------------------
35727C
35728      IERROR='NO'
35729      ISUBN1='DPPA'
35730      ISUBN2='R7  '
35731C
35732      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PAR7')THEN
35733        WRITE(ICOUT,999)
35734  999   FORMAT(1X)
35735        CALL DPWRST('XXX','BUG ')
35736        WRITE(ICOUT,51)
35737   51   FORMAT('***** AT THE BEGINNING OF DPPAR7--')
35738        CALL DPWRST('XXX','BUG ')
35739        WRITE(ICOUT,52)IBUGG3,ISUBRO,INAME
35740   52   FORMAT('IBUGG3,ISUBRO,INAME = ',A4,2X,A4,2X,A40)
35741        CALL DPWRST('XXX','BUG ')
35742        WRITE(ICOUT,54)ICOL,NUMVAR,NQ,NRIGHT(1),ILIS(1),NUMNAM,MAXOBV
35743   54   FORMAT('ICOL,NUMVAR,NQ,NRIGHT(1),ILIS(1),NUMNAM,MAXOBV = ',7I8)
35744        CALL DPWRST('XXX','BUG ')
35745        WRITE(ICOUT,56)IVARN1(ICOL),IVARN2(ICOL),ICOLR(ICOL)
35746   56   FORMAT('IVARN1(ICOL),IVARN2(ICOL),ICOLR(ICOL) = ',A4,2X,A4,I8)
35747        CALL DPWRST('XXX','BUG ')
35748        DO67I=1,10
35749          WRITE(ICOUT,68)I,IN(I),IVALUE(I),IVALU2(I)
35750   68     FORMAT('I,IN(I),IVALUE(I)IVALU2(I) = ',4I8)
35751          CALL DPWRST('XXX','BUG ')
35752   67   CONTINUE
35753      ENDIF
35754C
35755      DO100I=1,NUMVAR
35756CCCCC   2016/06: CORRECT FOLLOWING LINE
35757CCCCC   IF(IVARTY(ICOL+I).NE.'VARI')THEN
35758        IF(IVARTY(ICOL+I-1).NE.'VARI')THEN
35759          WRITE(ICOUT,101)INAME
35760  101     FORMAT('***** ERROR IN ',A40)
35761          CALL DPWRST('XXX','BUG ')
35762          WRITE(ICOUT,103)I
35763  103     FORMAT('      RESPONSE VARIABLE ',I3,' MUST BE A ',
35764     1           'VARIABLE')
35765          CALL DPWRST('XXX','BUG ')
35766          WRITE(ICOUT,105)
35767  105     FORMAT('      (AS OPPOSSED TO A MATRIX OR A PARAMETER).')
35768          CALL DPWRST('XXX','BUG ')
35769          IERROR='YES'
35770          GOTO9000
35771        ENDIF
35772  100 CONTINUE
35773C
35774      NLEFT=NRIGHT(ICOL)
35775C
35776      J=0
35777      IMAX=NLEFT
35778      IF(NQ.LT.NLEFT)IMAX=NQ
35779      DO210I=1,IMAX
35780C
35781        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PAR7')THEN
35782          WRITE(ICOUT,211)I,ISUB(I)
35783  211     FORMAT('AT 210: I,ISUB(I) = ',2I8)
35784          CALL DPWRST('XXX','BUG ')
35785        ENDIF
35786C
35787        IF(ISUB(I).EQ.0)GOTO210
35788        J=J+1
35789        IJ=MAXN*(ICOLR(ICOL)-1)+I
35790        IF(ICOLR(ICOL).LE.MAXCOL)Y1(J)=V(IJ)
35791        IF(ICOLR(ICOL).EQ.MAXCP1)Y1(J)=PRED(I)
35792        IF(ICOLR(ICOL).EQ.MAXCP2)Y1(J)=RES(I)
35793        IF(ICOLR(ICOL).EQ.MAXCP3)Y1(J)=YPLOT(I)
35794        IF(ICOLR(ICOL).EQ.MAXCP4)Y1(J)=XPLOT(I)
35795        IF(ICOLR(ICOL).EQ.MAXCP5)Y1(J)=X2PLOT(I)
35796        IF(ICOLR(ICOL).EQ.MAXCP6)Y1(J)=TAGPLO(I)
35797C
35798  210 CONTINUE
35799      NLOCAL=J
35800C
35801      IF(NUMVAR.GE.2)THEN
35802        NLEFT=NRIGHT(ICOL+1)
35803        J=0
35804        IMAX=NLEFT
35805        IF(NQ.LT.NLEFT)IMAX=NQ
35806        DO410I=1,IMAX
35807          IF(ISUB(I).EQ.0)GOTO410
35808          J=J+1
35809C
35810          IJ=MAXN*(ICOLR(ICOL+1)-1)+I
35811          IF(ICOLR(ICOL+1).LE.MAXCOL)Y2(J)=V(IJ)
35812          IF(ICOLR(ICOL+1).EQ.MAXCP1)Y2(J)=PRED(I)
35813          IF(ICOLR(ICOL+1).EQ.MAXCP2)Y2(J)=RES(I)
35814          IF(ICOLR(ICOL+1).EQ.MAXCP3)Y2(J)=YPLOT(I)
35815          IF(ICOLR(ICOL+1).EQ.MAXCP4)Y2(J)=XPLOT(I)
35816          IF(ICOLR(ICOL+1).EQ.MAXCP5)Y2(J)=X2PLOT(I)
35817          IF(ICOLR(ICOL+1).EQ.MAXCP6)Y2(J)=TAGPLO(I)
35818C
35819  410   CONTINUE
35820        NLOCA2=J
35821      ENDIF
35822C
35823      IF(NUMVAR.GE.3)THEN
35824        J=0
35825        NLEFT=NRIGHT(ICOL+2)
35826        IMAX=NLEFT
35827        IF(NQ.LT.NLEFT)IMAX=NQ
35828        DO510I=1,IMAX
35829          IF(ISUB(I).EQ.0)GOTO510
35830          J=J+1
35831C
35832          IJ=MAXN*(ICOLR(ICOL+2)-1)+I
35833          IF(ICOLR(ICOL+2).LE.MAXCOL)Y3(J)=V(IJ)
35834          IF(ICOLR(ICOL+2).EQ.MAXCP1)Y3(J)=PRED(I)
35835          IF(ICOLR(ICOL+2).EQ.MAXCP2)Y3(J)=RES(I)
35836          IF(ICOLR(ICOL+2).EQ.MAXCP3)Y3(J)=YPLOT(I)
35837          IF(ICOLR(ICOL+2).EQ.MAXCP4)Y3(J)=XPLOT(I)
35838          IF(ICOLR(ICOL+2).EQ.MAXCP5)Y3(J)=X2PLOT(I)
35839          IF(ICOLR(ICOL+2).EQ.MAXCP6)Y3(J)=TAGPLO(I)
35840C
35841  510   CONTINUE
35842        NLOCA3=J
35843      ENDIF
35844C
35845      IF(NUMVAR.GE.4)THEN
35846        J=0
35847        NLEFT=NRIGHT(ICOL+3)
35848        IMAX=NLEFT
35849        IF(NQ.LT.NLEFT)IMAX=NQ
35850        DO610I=1,IMAX
35851          IF(ISUB(I).EQ.0)GOTO610
35852          J=J+1
35853C
35854          IJ=MAXN*(ICOLR(ICOL+3)-1)+I
35855          IF(ICOLR(ICOL+3).LE.MAXCOL)Y4(J)=V(IJ)
35856          IF(ICOLR(ICOL+3).EQ.MAXCP1)Y4(J)=PRED(I)
35857          IF(ICOLR(ICOL+3).EQ.MAXCP2)Y4(J)=RES(I)
35858          IF(ICOLR(ICOL+3).EQ.MAXCP3)Y4(J)=YPLOT(I)
35859          IF(ICOLR(ICOL+3).EQ.MAXCP4)Y4(J)=XPLOT(I)
35860          IF(ICOLR(ICOL+3).EQ.MAXCP5)Y4(J)=X2PLOT(I)
35861          IF(ICOLR(ICOL+3).EQ.MAXCP6)Y4(J)=TAGPLO(I)
35862C
35863  610   CONTINUE
35864        NLOCA4=J
35865      ENDIF
35866C
35867C               *****************
35868C               **  STEP 90--  **
35869C               **  EXIT       **
35870C               *****************
35871C
35872 9000 CONTINUE
35873      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PAR7')THEN
35874        WRITE(ICOUT,999)
35875        CALL DPWRST('XXX','BUG ')
35876        WRITE(ICOUT,9011)
35877 9011   FORMAT('***** AT THE END       OF DPPAR7--')
35878        CALL DPWRST('XXX','BUG ')
35879        WRITE(ICOUT,9013)IFOUND,IERROR,NQ,NUMVAR,NLEFT,NLOCAL
35880 9013   FORMAT('IFOUND,IERROR,NQ,NUMVAR,NLEFT,NLOCAL = ',
35881     1         A4,2X,A4,2X,4I8)
35882        CALL DPWRST('XXX','BUG ')
35883        DO9022I=1,NLOCAL
35884          WRITE(ICOUT,9023)I,Y1(I),Y2(I),Y3(I),Y4(I)
35885 9023     FORMAT('I,Y1(I),Y2(I),Y3(I),Y4(I) = ',I8,4G15.7)
35886          CALL DPWRST('XXX','BUG ')
35887 9022   CONTINUE
35888      ENDIF
35889C
35890      RETURN
35891      END
35892      SUBROUTINE DPPAR8(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
35893     1                  INAME,IVARN1,IVARN2,IVARTY,
35894     1                  ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
35895     1                  MAXCOL,MAXCP1,MAXCP2,MAXCP3,
35896     1                  MAXCP4,MAXCP5,MAXCP6,
35897     1                  V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
35898     1                  XTEMP,Y,X,NLOCAL,ICASE,
35899     1                  IBUGG3,ISUBRO,IFOUND,IERROR)
35900C
35901C     PURPOSE--A UTILITY ROUTINE FOR PARSING A COMMAND LINE.  THIS
35902C              IS USED FOR THE "MULTIPLE" CASE WHERE WE WANT TO
35903C              END UP WITH A "Y  X" OUTPUT.  FOR EXAMPLE,
35904C
35905C                  MULTIPLE BOX PLOT Y1 TO Y10
35906C
35907C     WRITTEN BY--ALAN HECKERT
35908C                 STATISTICAL ENGINEERING DIVISION
35909C                 INFORMATION TECHNOLOGY LABORATORY
35910C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
35911C                 GAITHERSBURG, MD 20899-8980
35912C                 PHONE--301-975-2899
35913C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
35914C           OF THE NATIONAL BUREAU OF STANDARDS.
35915C     LANGUAGE--ANSI FORTRAN (1977)
35916C     VERSION NUMBER--2011/2
35917C     ORIGINAL VERSION--FEBRUARY  2011.
35918C
35919C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
35920C
35921      INTEGER IVALUE(*)
35922      INTEGER IVALU2(*)
35923      INTEGER IN(*)
35924      INTEGER ILIS(*)
35925      INTEGER ISUB(*)
35926      INTEGER NRIGHT(*)
35927      INTEGER ICOLR(*)
35928C
35929      REAL    V(*)
35930      REAL    PRED(*)
35931      REAL    RES(*)
35932      REAL    YPLOT(*)
35933      REAL    XPLOT(*)
35934      REAL    X2PLOT(*)
35935      REAL    TAGPLO(*)
35936C
35937      REAL    XTEMP(*)
35938      REAL    Y(*)
35939      REAL    X(*)
35940C
35941      CHARACTER*4 IVARN1(*)
35942      CHARACTER*4 IVARN2(*)
35943      CHARACTER*4 IVARTY(*)
35944C
35945      CHARACTER*4  ICASE
35946      CHARACTER*40 INAME
35947C
35948      CHARACTER*4 IBUGG3
35949      CHARACTER*4 ISUBRO
35950      CHARACTER*4 IFOUND
35951      CHARACTER*4 IERROR
35952C
35953      CHARACTER*4 ISUBN1
35954      CHARACTER*4 ISUBN2
35955C
35956C-----COMMON VARIABLES (GENERAL)--------------------------------------
35957C
35958      INCLUDE 'DPCOP2.INC'
35959C
35960C-----START POINT-----------------------------------------------------
35961C
35962      IERROR='NO'
35963      ISUBN1='DPPA'
35964      ISUBN2='R8  '
35965C
35966      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PAR8')THEN
35967        WRITE(ICOUT,999)
35968  999   FORMAT(1X)
35969        CALL DPWRST('XXX','BUG ')
35970        WRITE(ICOUT,51)
35971   51   FORMAT('***** AT THE BEGINNING OF DPPAR8--')
35972        CALL DPWRST('XXX','BUG ')
35973        WRITE(ICOUT,52)IBUGG3,ISUBRO,INAME
35974   52   FORMAT('IBUGG3,ISUBRO = ',A4,2X,A4,2X,A40)
35975        CALL DPWRST('XXX','BUG ')
35976        WRITE(ICOUT,54)ICOL,NUMVAR,NQ,NRIGHT(ICOL)
35977   54   FORMAT('ICOL,NUMVAR,NQ,NRIGHT(ICOL) = ',4I8)
35978        CALL DPWRST('XXX','BUG ')
35979        WRITE(ICOUT,56)IVARN1(ICOL),IVARN2(ICOL),ICOLR(ICOL)
35980   56   FORMAT('IVARN1(ICOL),IVARN2(ICOL),ICOLR(ICOL) = ',A4,2X,A4,I8)
35981        CALL DPWRST('XXX','BUG ')
35982      ENDIF
35983C
35984        NCURVE=0
35985        ICNT=0
35986        DO410IRESP=1,NUMVAR
35987          NCURVE=NCURVE+1
35988          IINDX=ICOLR(IRESP)
35989C
35990          ICOL=IRESP
35991          NUMVA2=1
35992          CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
35993     1                INAME,IVARN1,IVARN2,IVARTY,
35994     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
35995     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
35996     1                MAXCP4,MAXCP5,MAXCP6,
35997     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
35998     1                XTEMP,XTEMP,XTEMP,NLOCAL,NLOCA2,NLOCA2,ICASE,
35999     1                IBUGG3,ISUBRO,IFOUND,IERROR)
36000C
36001          IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PAR8')THEN
36002            WRITE(ICOUT,999)
36003            CALL DPWRST('XXX','BUG ')
36004            WRITE(ICOUT,411)IRESP,NCURVE,NRIGHT(IRESP),NLOCAL
36005  411       FORMAT('IRESP,NCURVE,NRIGHT(IRESP),NLOCAL = ',2I5,2I8)
36006            CALL DPWRST('XXX','BUG ')
36007          ENDIF
36008C
36009          IF(IERROR.EQ.'YES')GOTO9000
36010          DO420IROW=1,NLOCAL
36011            ICNT=ICNT+1
36012C
36013            IF(ICNT.GT.MAXOBV)THEN
36014              WRITE(ICOUT,999)
36015              CALL DPWRST('XXX','BUG ')
36016              WRITE(ICOUT,431)INAME
36017  431         FORMAT('***** ERROR IN ',A40)
36018              CALL DPWRST('XXX','BUG ')
36019              WRITE(ICOUT,433)
36020  433         FORMAT('      FOR THE MULTIPLE CASE, THE MAXIMUM ',
36021     1               'TOTAL NUMBER OF VALUES')
36022              CALL DPWRST('XXX','BUG ')
36023              WRITE(ICOUT,435)IVARN1(IRESP),IVARN2(IRESP)
36024  435         FORMAT('      HAS JUST BEEN EXCEEDED WHILE PROCESSING ',
36025     1               'VARIABLE ',A4,A4)
36026              CALL DPWRST('XXX','BUG ')
36027              WRITE(ICOUT,437)MAXOBV
36028  437         FORMAT('      MAXIMUM NUMBER OF ALLOWED VALUES  = ',I8)
36029              CALL DPWRST('XXX','BUG ')
36030              IERROR='YES'
36031              GOTO9000
36032            ENDIF
36033C
36034            Y(ICNT)=XTEMP(IROW)
36035            X(ICNT)=REAL(NCURVE)
36036  420     CONTINUE
36037C
36038  410   CONTINUE
36039        NLOCAL=ICNT
36040C
36041C               *****************
36042C               **  STEP 90--  **
36043C               **  EXIT       **
36044C               *****************
36045C
36046 9000 CONTINUE
36047      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PAR8')THEN
36048        WRITE(ICOUT,999)
36049        CALL DPWRST('XXX','BUG ')
36050        WRITE(ICOUT,9011)
36051 9011   FORMAT('***** AT THE END       OF DPPAR8--')
36052        CALL DPWRST('XXX','BUG ')
36053        WRITE(ICOUT,9013)IFOUND,IERROR,NQ,NUMVAR,NLEFT,NLOCAL
36054 9013   FORMAT('IFOUND,IERROR,NQ,NUMVAR,NLEFT,NLOCAL = ',
36055     1         A4,2X,A4,2X,4I8)
36056        CALL DPWRST('XXX','BUG ')
36057        DO9022I=1,NLOCAL
36058          WRITE(ICOUT,9023)I,Y(I),X(I)
36059 9023     FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
36060          CALL DPWRST('XXX','BUG ')
36061 9022   CONTINUE
36062      ENDIF
36063C
36064      RETURN
36065      END
36066      SUBROUTINE DPPAR9(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,IROW,JCOL,
36067     1                  INAME,IVARN1,IVARN2,IVARTY,
36068     1                  ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
36069     1                  MAXCOL,MAXCP1,MAXCP2,MAXCP3,
36070     1                  MAXCP4,MAXCP5,MAXCP6,
36071     1                  V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
36072     1                  AVAL,NCOL,ICASE,
36073     1                  IBUGG3,ISUBRO,IERROR)
36074C
36075C     PURPOSE--A UTILITY ROUTINE FOR PARSING A COMMAND LINE.  THIS
36076C              IS FOR THE CASE WHEN THE INPUT CAN BE EITHER A MATRIX
36077C              OR A VARIABLE.  THE ROW/COLUMN IS SPECIFIED AND A
36078C              SINGLE VALUE IS RETURNED.
36079C     WRITTEN BY--ALAN HECKERT
36080C                 STATISTICAL ENGINEERING DIVISION
36081C                 INFORMATION TECHNOLOGY LABORATORY
36082C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
36083C                 GAITHERSBURG, MD 20899-8980
36084C                 PHONE--301-975-2899
36085C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
36086C           OF THE NATIONAL BUREAU OF STANDARDS.
36087C     LANGUAGE--ANSI FORTRAN (1977)
36088C     VERSION NUMBER--2011/9
36089C     ORIGINAL VERSION--SEPTEMBER 2011.
36090C
36091C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
36092C
36093      INTEGER IVALUE(*)
36094      INTEGER IVALU2(*)
36095      INTEGER IN(*)
36096      INTEGER ILIS(*)
36097      INTEGER ISUB(*)
36098      INTEGER NRIGHT(*)
36099      INTEGER ICOLR(*)
36100C
36101      REAL    V(*)
36102      REAL    PRED(*)
36103      REAL    RES(*)
36104      REAL    YPLOT(*)
36105      REAL    XPLOT(*)
36106      REAL    X2PLOT(*)
36107      REAL    TAGPLO(*)
36108C
36109      CHARACTER*4 IVARN1(*)
36110      CHARACTER*4 IVARN2(*)
36111      CHARACTER*4 IVARTY(*)
36112C
36113      CHARACTER*4  ICASE
36114      CHARACTER*40 INAME
36115C
36116      CHARACTER*4 IBUGG3
36117      CHARACTER*4 ISUBRO
36118      CHARACTER*4 IERROR
36119C
36120      CHARACTER*4 ISUBN1
36121      CHARACTER*4 ISUBN2
36122C
36123C-----COMMON VARIABLES (GENERAL)--------------------------------------
36124C
36125      INCLUDE 'DPCOP2.INC'
36126C
36127C-----START POINT-----------------------------------------------------
36128C
36129      IERROR='NO'
36130      ISUBN1='DPPA'
36131      ISUBN2='R9  '
36132C
36133      AVAL=CPUMIN
36134      ICOL1=0
36135C
36136      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PAR9')THEN
36137        WRITE(ICOUT,999)
36138  999   FORMAT(1X)
36139        CALL DPWRST('XXX','BUG ')
36140        WRITE(ICOUT,51)
36141   51   FORMAT('***** AT THE BEGINNING OF DPPAR9--')
36142        CALL DPWRST('XXX','BUG ')
36143        WRITE(ICOUT,52)IBUGG3,ISUBRO,INAME
36144   52   FORMAT('IBUGG3,ISUBRO = ',A4,2X,A4,2X,A40)
36145        CALL DPWRST('XXX','BUG ')
36146        WRITE(ICOUT,54)ICOL,NUMVAR,NQ,NRIGHT(1),MAXN
36147   54   FORMAT('ICOL,NUMVAR,NQ,NRIGHT(1),MAXN = ',5I8)
36148        CALL DPWRST('XXX','BUG ')
36149        WRITE(ICOUT,55)IN(1),MAXOBV
36150   55   FORMAT('IN(1),MAXOBV = ',2I8)
36151        CALL DPWRST('XXX','BUG ')
36152        WRITE(ICOUT,56)IVARN1(ICOL),IVARN2(ICOL),ICOLR(ICOL)
36153   56   FORMAT('IVARN1(ICOL),IVARN2(ICOL),ICOLR(ICOL) = ',A4,2X,A4,I8)
36154        CALL DPWRST('XXX','BUG ')
36155      ENDIF
36156C
36157      IF(IVARTY(ICOL).EQ.'MATR')THEN
36158        ICASE='MATR'
36159        ILISR=ILIS(ICOL)
36160        ICOL1=IVALUE(ILISR)
36161        ICOL2=IVALU2(ILISR)
36162        NCOL=(ICOL2 - ICOL1) + 1
36163      ELSE
36164        ICASE='VARI'
36165        ILISR=ILIS(ICOL)
36166      ENDIF
36167C
36168      NLEFT=NRIGHT(ICOL)
36169C
36170      IF(ICASE.EQ.'VARI')THEN
36171        J=0
36172        IMAX=NLEFT
36173        IF(NQ.LT.NLEFT)IMAX=NQ
36174        I=IROW
36175        IF(I.GT.IMAX)THEN
36176          WRITE(ICOUT,999)
36177          CALL DPWRST('XXX','BUG ')
36178          WRITE(ICOUT,201)INAME
36179  201     FORMAT('***** ERROR IN ',A40)
36180          CALL DPWRST('XXX','BUG ')
36181          WRITE(ICOUT,203)
36182  203     FORMAT('      MAXIMUM ROW NUMBER EXCEEDED.')
36183          CALL DPWRST('XXX','BUG ')
36184          IERROR='YES'
36185          GOTO9000
36186        ENDIF
36187C
36188        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PAR9')THEN
36189          WRITE(ICOUT,211)I,ISUB(I)
36190  211     FORMAT('AT 210: I,ISUB(I) = ',2I8)
36191          CALL DPWRST('XXX','BUG ')
36192        ENDIF
36193C
36194        IF(ISUB(I).EQ.0)GOTO210
36195        J=J+1
36196        IJ=MAXN*(ICOLR(ICOL)-1)+I
36197        IF(ICOLR(ICOL).LE.MAXCOL)AVAL=V(IJ)
36198        IF(ICOLR(ICOL).EQ.MAXCP1)AVAL=PRED(I)
36199        IF(ICOLR(ICOL).EQ.MAXCP2)AVAL=RES(I)
36200        IF(ICOLR(ICOL).EQ.MAXCP3)AVAL=YPLOT(I)
36201        IF(ICOLR(ICOL).EQ.MAXCP4)AVAL=XPLOT(I)
36202        IF(ICOLR(ICOL).EQ.MAXCP5)AVAL=X2PLOT(I)
36203        IF(ICOLR(ICOL).EQ.MAXCP6)AVAL=TAGPLO(I)
36204C
36205  210   CONTINUE
36206c
36207      ELSEIF(ICASE.EQ.'MATR')THEN
36208C
36209        NLOOP=NCOL
36210        IF(NLOOP.LT.1)NLOOP=1
36211        IMAX=NLEFT
36212        IF(NQ.LT.NLEFT)IMAX=NQ
36213C
36214        ICNT=0
36215C
36216        JLOOP=JCOL
36217        I=IROW
36218        IF(JLOOP.GT.NLOOP)THEN
36219          WRITE(ICOUT,999)
36220          CALL DPWRST('XXX','BUG ')
36221          WRITE(ICOUT,201)INAME
36222          CALL DPWRST('XXX','BUG ')
36223          WRITE(ICOUT,303)
36224  303     FORMAT('      MAXIMUM COLUMN NUMBER IN MATRIX EXCEEDED.')
36225          CALL DPWRST('XXX','BUG ')
36226          IERROR='YES'
36227          GOTO9000
36228        ENDIF
36229        IF(I.GT.IMAX)THEN
36230          WRITE(ICOUT,999)
36231          CALL DPWRST('XXX','BUG ')
36232          WRITE(ICOUT,201)INAME
36233          CALL DPWRST('XXX','BUG ')
36234          WRITE(ICOUT,203)
36235          CALL DPWRST('XXX','BUG ')
36236          IERROR='YES'
36237          GOTO9000
36238        ENDIF
36239C
36240        IF(ISUB(I).EQ.0)GOTO320
36241C
36242        ICOLT=ICOL1+JLOOP-1
36243        IJ=MAXN*(ICOLT-1)+I
36244C
36245        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PAR9')THEN
36246          WRITE(ICOUT,331)JLOOP,ICOLT,IJ
36247  331     FORMAT('JLOOP,ICOLT,IJ = ',3I8)
36248          CALL DPWRST('XXX','BUG ')
36249        ENDIF
36250C
36251        IF(ICOLT.LE.MAXCOL)AVAL=V(IJ)
36252        IF(ICOLT.EQ.MAXCP1)AVAL=PRED(I)
36253        IF(ICOLT.EQ.MAXCP2)AVAL=RES(I)
36254        IF(ICOLT.EQ.MAXCP3)AVAL=YPLOT(I)
36255        IF(ICOLT.EQ.MAXCP4)AVAL=XPLOT(I)
36256        IF(ICOLT.EQ.MAXCP5)AVAL=X2PLOT(I)
36257        IF(ICOLT.EQ.MAXCP6)AVAL=TAGPLO(I)
36258C
36259  320   CONTINUE
36260      ENDIF
36261C
36262C               *****************
36263C               **  STEP 90--  **
36264C               **  EXIT       **
36265C               *****************
36266C
36267 9000 CONTINUE
36268      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PAR9')THEN
36269        WRITE(ICOUT,999)
36270        CALL DPWRST('XXX','BUG ')
36271        WRITE(ICOUT,9011)
36272 9011   FORMAT('***** AT THE END       OF DPPAR9--')
36273        CALL DPWRST('XXX','BUG ')
36274        WRITE(ICOUT,9013)IERROR,NQ,NUMVAR,NLEFT,NLOCAL
36275 9013   FORMAT('IERROR,NQ,NUMVAR,NLEFT,NLOCAL = ',
36276     1         A4,2X,4I8)
36277        CALL DPWRST('XXX','BUG ')
36278      ENDIF
36279C
36280      RETURN
36281      END
36282      SUBROUTINE DPPARY(ICOL,IVALUE,IVALU2,IN,MAXN,MAXNXT,
36283     1                  INAME,IVARN1,IVARN2,IVARTY,
36284     1                  ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
36285     1                  MAXCOL,MAXCP1,MAXCP2,MAXCP3,
36286     1                  MAXCP4,MAXCP5,MAXCP6,
36287     1                  V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
36288     1                  Y,NLOCAL,NROW,NCOL,
36289     1                  IBUGG3,ISUBRO,IFOUND,IERROR)
36290C
36291C     PURPOSE--A UTILITY ROUTINE FOR PARSING A COMMAND LINE.  FOR
36292C              CASE WHERE COMMAND CAN TAKE EITHER A VARIABLE OR A
36293C              MATRIX ARGUMENT, EXTRACT THE DATA.
36294C     WRITTEN BY--ALAN HECKERT
36295C                 STATISTICAL ENGINEERING DIVISION
36296C                 INFORMATION TECHNOLOGY LABORATORY
36297C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
36298C                 GAITHERSBURG, MD 20899-8980
36299C                 PHONE--301-975-2899
36300C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
36301C           OF THE NATIONAL BUREAU OF STANDARDS.
36302C     LANGUAGE--ANSI FORTRAN (1977)
36303C     VERSION NUMBER--2017/3
36304C     ORIGINAL VERSION--MARCH     2017.
36305C
36306C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
36307C
36308      INTEGER IVALUE(*)
36309      INTEGER IVALU2(*)
36310      INTEGER IN(*)
36311      INTEGER ILIS(*)
36312      INTEGER ISUB(*)
36313      INTEGER NRIGHT(*)
36314      INTEGER ICOLR(*)
36315C
36316      REAL    V(*)
36317      REAL    PRED(*)
36318      REAL    RES(*)
36319      REAL    YPLOT(*)
36320      REAL    XPLOT(*)
36321      REAL    X2PLOT(*)
36322      REAL    TAGPLO(*)
36323      REAL    Y(*)
36324C
36325      CHARACTER*4 IVARN1(*)
36326      CHARACTER*4 IVARN2(*)
36327      CHARACTER*4 IVARTY(*)
36328C
36329      CHARACTER*4  ICASE
36330      CHARACTER*40 INAME
36331C
36332      CHARACTER*4 IBUGG3
36333      CHARACTER*4 ISUBRO
36334      CHARACTER*4 IFOUND
36335      CHARACTER*4 IERROR
36336C
36337      CHARACTER*4 ISUBN1
36338      CHARACTER*4 ISUBN2
36339C
36340C-----COMMON VARIABLES (GENERAL)--------------------------------------
36341C
36342      INCLUDE 'DPCOP2.INC'
36343C
36344C-----START POINT-----------------------------------------------------
36345C
36346      IERROR='NO'
36347      ISUBN1='DPPA'
36348      ISUBN2='RY  '
36349C
36350      N1=0
36351      ICOL1=0
36352      ICOL2=0
36353C
36354      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PARY')THEN
36355        WRITE(ICOUT,999)
36356  999   FORMAT(1X)
36357        CALL DPWRST('XXX','BUG ')
36358        WRITE(ICOUT,51)
36359   51   FORMAT('***** AT THE BEGINNING OF DPPARY--')
36360        CALL DPWRST('XXX','BUG ')
36361        WRITE(ICOUT,52)IBUGG3,ISUBRO,INAME
36362   52   FORMAT('IBUGG3,ISUBRO = ',A4,2X,A4,2X,A40)
36363        CALL DPWRST('XXX','BUG ')
36364        WRITE(ICOUT,54)ICOL,NUMVAR,NQ,NRIGHT(1)
36365   54   FORMAT('ICOL,NUMVAR,NQ,NRIGHT(1) = ',4I8)
36366        CALL DPWRST('XXX','BUG ')
36367        WRITE(ICOUT,56)IVARN1(ICOL),IVARN2(ICOL),ICOLR(ICOL)
36368   56   FORMAT('IVARN1(ICOL),IVARN2(ICOL),ICOLR(ICOL) = ',A4,2X,A4,I8)
36369        CALL DPWRST('XXX','BUG ')
36370      ENDIF
36371C
36372      IF(NUMVAR.GE.2)THEN
36373        DO100II=2,NUMVAR
36374          IF(IVARTY(ICOL+II-1).NE.'VARI')THEN
36375            WRITE(ICOUT,101)INAME
36376  101       FORMAT('***** ERROR IN ',A40)
36377            CALL DPWRST('XXX','BUG ')
36378            WRITE(ICOUT,103)II
36379  103       FORMAT('      RESPONSE VARIABLE ',I2,' MUST BE A ',
36380     1           'VARIABLE')
36381            CALL DPWRST('XXX','BUG ')
36382            WRITE(ICOUT,105)
36383  105       FORMAT('      (AS OPPOSSED TO A MATRIX OR A PARAMETER).')
36384            CALL DPWRST('XXX','BUG ')
36385            IERROR='YES'
36386            GOTO9000
36387          ENDIF
36388  100   CONTINUE
36389      ENDIF
36390C
36391      IF(IVARTY(ICOL).EQ.'MATR')THEN
36392        ICASE='MATR'
36393        ILISR=ILIS(ICOL)
36394        ICOL1=IVALUE(ILISR)
36395        ICOL2=IVALU2(ILISR)
36396        N1=IN(ILISR)
36397        NCOL=(ICOL2 - ICOL1) + 1
36398        NROW=N1
36399      ELSE
36400        ICASE='VARI'
36401      ENDIF
36402C
36403      NLEFT=NRIGHT(ICOL)
36404C
36405      IF(ICASE.EQ.'VARI')THEN
36406        NCOL=NUMVAR
36407        J=0
36408        IMAX=NLEFT
36409        IF(NQ.LT.NLEFT)IMAX=NQ
36410        DO200JJ=1,NUMVAR
36411          DO210I=1,IMAX
36412C
36413            IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PARY')THEN
36414              WRITE(ICOUT,211)J,I,ISUB(I)
36415  211         FORMAT('AT 210: J,I,ISUB(I) = ',3I8)
36416              CALL DPWRST('XXX','BUG ')
36417            ENDIF
36418C
36419            IF(ISUB(I).EQ.0)GOTO210
36420            J=J+1
36421C
36422            IF(J.GT.MAXNXT)THEN
36423              WRITE(ICOUT,999)
36424              CALL DPWRST('XXX','BUG ')
36425              WRITE(ICOUT,101)
36426              CALL DPWRST('XXX','BUG ')
36427              WRITE(ICOUT,222)
36428  222         FORMAT('      FOR THE VARIABLE CASE, THE MAXIMUM NUMBER')
36429              CALL DPWRST('XXX','BUG ')
36430              WRITE(ICOUT,324)
36431              CALL DPWRST('XXX','BUG ')
36432              WRITE(ICOUT,326)MAXNXT
36433              CALL DPWRST('XXX','BUG ')
36434              IERROR='YES'
36435              GOTO9000
36436            ENDIF
36437C
36438            ICOLT=ICOLR(ICOL)+JJ-1
36439            IJ=MAXN*(ICOLT-1)+I
36440            IF(ICOLR(ICOLT).LE.MAXCOL)Y(J)=V(IJ)
36441            IF(ICOLR(ICOLT).EQ.MAXCP1)Y(J)=PRED(I)
36442            IF(ICOLR(ICOLT).EQ.MAXCP2)Y(J)=RES(I)
36443            IF(ICOLR(ICOLT).EQ.MAXCP3)Y(J)=YPLOT(I)
36444            IF(ICOLR(ICOLT).EQ.MAXCP4)Y(J)=XPLOT(I)
36445            IF(ICOLR(ICOLT).EQ.MAXCP5)Y(J)=X2PLOT(I)
36446            IF(ICOLR(ICOLT).EQ.MAXCP6)Y(J)=TAGPLO(I)
36447C
36448  210     CONTINUE
36449          IF(JJ.EQ.1)NROW=J
36450  200   CONTINUE
36451        NLOCAL=J
36452c
36453      ELSEIF(ICASE.EQ.'MATR')THEN
36454C
36455        NLOOP=NCOL
36456        IF(NLOOP.LT.1)NLOOP=1
36457        IMAX=N1
36458        IF(NQ.LT.N1)IMAX=NQ
36459C
36460        ICNT=0
36461C
36462        DO310JLOOP=1,NLOOP
36463          DO320I=1,IMAX
36464            IF(ISUB(I).EQ.0)GOTO320
36465            ICNT=ICNT+1
36466C
36467            IF(ICNT.GT.MAXNXT)THEN
36468              WRITE(ICOUT,999)
36469              CALL DPWRST('XXX','BUG ')
36470              WRITE(ICOUT,101)
36471              CALL DPWRST('XXX','BUG ')
36472              WRITE(ICOUT,322)
36473  322         FORMAT('      FOR THE MATRIX CASE, THE MAXIMUM NUMBER')
36474              CALL DPWRST('XXX','BUG ')
36475              WRITE(ICOUT,324)
36476  324         FORMAT('      OF OBSERVATIONS HAS BEEN EXCEEDED.')
36477              CALL DPWRST('XXX','BUG ')
36478              WRITE(ICOUT,326)MAXNXT
36479  326         FORMAT('      THE MAXIMUM NUMBER OF OBSERVATIONS = ',I10)
36480              CALL DPWRST('XXX','BUG ')
36481              IERROR='YES'
36482              GOTO9000
36483            ENDIF
36484C
36485            ICOLT=ICOL1+JLOOP-1
36486            IJ=MAXN*(ICOLT-1)+I
36487C
36488            IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PARY')THEN
36489              WRITE(ICOUT,331)JLOOP,ICOLT,ICNT,IJ
36490  331         FORMAT('JLOOP,ICOLT,ICNT,IJ = ',4I8)
36491              CALL DPWRST('XXX','BUG ')
36492            ENDIF
36493C
36494            IF(ICOLT.LE.MAXCOL)Y(ICNT)=V(IJ)
36495            IF(ICOLT.EQ.MAXCP1)Y(ICNT)=PRED(I)
36496            IF(ICOLT.EQ.MAXCP2)Y(ICNT)=RES(I)
36497            IF(ICOLT.EQ.MAXCP3)Y(ICNT)=YPLOT(I)
36498            IF(ICOLT.EQ.MAXCP4)Y(ICNT)=XPLOT(I)
36499            IF(ICOLT.EQ.MAXCP5)Y(ICNT)=X2PLOT(I)
36500            IF(ICOLT.EQ.MAXCP6)Y(ICNT)=TAGPLO(I)
36501C
36502  320     CONTINUE
36503  310   CONTINUE
36504        NLOCAL=ICNT
36505      ENDIF
36506C
36507C               *****************
36508C               **  STEP 90--  **
36509C               **  EXIT       **
36510C               *****************
36511C
36512 9000 CONTINUE
36513      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PARY')THEN
36514        WRITE(ICOUT,999)
36515        CALL DPWRST('XXX','BUG ')
36516        WRITE(ICOUT,9011)
36517 9011   FORMAT('***** AT THE END       OF DPPARY--')
36518        CALL DPWRST('XXX','BUG ')
36519        WRITE(ICOUT,9013)IFOUND,IERROR,NQ,NUMVAR,NLEFT,NLOCAL
36520 9013   FORMAT('IFOUND,IERROR,NQ,NUMVAR,NLEFT,NLOCAL = ',
36521     1         A4,2X,A4,2X,4I8)
36522        CALL DPWRST('XXX','BUG ')
36523        DO9022I=1,NLOCAL
36524          WRITE(ICOUT,9023)I,Y(I)
36525 9023     FORMAT('I,Y(I) = ',I8,G15.7)
36526          CALL DPWRST('XXX','BUG ')
36527 9022   CONTINUE
36528      ENDIF
36529C
36530      RETURN
36531      END
36532      SUBROUTINE DPPARZ(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
36533     1                  INAME,IVARN1,IVARN2,IVARTY,
36534     1                  ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
36535     1                  MAXCOL,MAXCP1,MAXCP2,MAXCP3,
36536     1                  MAXCP4,MAXCP5,MAXCP6,
36537     1                  V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
36538     1                  Y,ROWID,COLID,N1,
36539     1                  IBUGG3,ISUBRO,IFOUND,IERROR)
36540C
36541C     PURPOSE--A UTILITY ROUTINE FOR PARSING A COMMAND LINE.  FOR
36542C              CASE WHERE COMMAND CAN TAKE A SINGLE MATRIX.  THIS
36543C              DIFFERS FROM DPPAR3 AND DPPAR6 WHERE THE MATRIX IS
36544C              EXTRACTED INTO A SINGLE VARIABLE OR A SINGLE MATRIX,
36545C              RESPECTIVELY. THIS COMMAND EXTRACTS THE MATRIX INTO A
36546C              RESPONSE VARIABLE, A ROW-ID VARIABLE, AND A COLUMN-ID
36547C              VARIABLE.
36548C     WRITTEN BY--ALAN HECKERT
36549C                 STATISTICAL ENGINEERING DIVISION
36550C                 INFORMATION TECHNOLOGY LABORATORY
36551C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
36552C                 GAITHERSBURG, MD 20899-8980
36553C                 PHONE--301-975-2899
36554C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
36555C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
36556C     LANGUAGE--ANSI FORTRAN (1977)
36557C     VERSION NUMBER--2015/JUNE
36558C     ORIGINAL VERSION--JUNE      2015.
36559C
36560C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
36561C
36562      INTEGER IVALUE(*)
36563      INTEGER IVALU2(*)
36564      INTEGER IN(*)
36565      INTEGER ILIS(*)
36566      INTEGER ISUB(*)
36567      INTEGER NRIGHT(*)
36568      INTEGER ICOLR(*)
36569C
36570      REAL    V(*)
36571      REAL    PRED(*)
36572      REAL    RES(*)
36573      REAL    YPLOT(*)
36574      REAL    XPLOT(*)
36575      REAL    X2PLOT(*)
36576      REAL    TAGPLO(*)
36577C
36578      REAL    Y(*)
36579      REAL    ROWID(*)
36580      REAL    COLID(*)
36581C
36582      CHARACTER*4 IVARN1(*)
36583      CHARACTER*4 IVARN2(*)
36584      CHARACTER*4 IVARTY(*)
36585C
36586      CHARACTER*4  ICASE
36587      CHARACTER*40 INAME
36588C
36589      CHARACTER*4 IBUGG3
36590      CHARACTER*4 ISUBRO
36591      CHARACTER*4 IFOUND
36592      CHARACTER*4 IERROR
36593C
36594      CHARACTER*4 ISUBN1
36595      CHARACTER*4 ISUBN2
36596C
36597C-----COMMON VARIABLES (GENERAL)--------------------------------------
36598C
36599      INCLUDE 'DPCOP2.INC'
36600C
36601C-----START POINT-----------------------------------------------------
36602C
36603      IERROR='NO'
36604      ISUBN1='DPPA'
36605      ISUBN2='RZ  '
36606C
36607      ICNT=0
36608C
36609      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PARZ')THEN
36610        WRITE(ICOUT,999)
36611  999   FORMAT(1X)
36612        CALL DPWRST('XXX','BUG ')
36613        WRITE(ICOUT,51)
36614   51   FORMAT('***** AT THE BEGINNING OF DPPARZ--')
36615        CALL DPWRST('XXX','BUG ')
36616        WRITE(ICOUT,52)IBUGG3,ISUBRO,INAME
36617   52   FORMAT('IBUGG3,ISUBRO = ',A4,2X,A4,2X,A40)
36618        CALL DPWRST('XXX','BUG ')
36619        WRITE(ICOUT,54)ICOL,NUMVAR,NQ,NRIGHT(1)
36620   54   FORMAT('ICOL,NUMVAR,NQ,NRIGHT(1) = ',4I8)
36621        CALL DPWRST('XXX','BUG ')
36622        WRITE(ICOUT,56)IVARN1(ICOL),IVARN2(ICOL),ICOLR(ICOL)
36623   56   FORMAT('IVARN1(ICOL),IVARN2(ICOL),ICOLR(ICOL) = ',A4,2X,A4,I8)
36624        CALL DPWRST('XXX','BUG ')
36625      ENDIF
36626C
36627      IF(IVARTY(ICOL).EQ.'MATR')THEN
36628        ICASE='MATR'
36629        ILISR=ILIS(ICOL)
36630        ICOL1=IVALUE(ILISR)
36631        ICOL2=IVALU2(ILISR)
36632        N1=IN(ILISR)
36633        NCOL=(ICOL2 - ICOL1) + 1
36634      ELSE
36635        ICASE='VARI'
36636        IERROR='YES'
36637        GOTO9000
36638      ENDIF
36639C
36640      NLEFT=NRIGHT(ICOL)
36641      IF(ICASE.EQ.'MATR')THEN
36642C
36643        NLOOP=NCOL
36644        IF(NLOOP.LT.1)NLOOP=1
36645        IMAX=N1
36646        IF(NQ.LT.N1)IMAX=NQ
36647C
36648        ICNT=0
36649        DO310JLOOP=1,NLOOP
36650          ICNT2=0
36651          DO320I=1,IMAX
36652            IF(ISUB(I).EQ.0)GOTO320
36653            ICNT=ICNT+1
36654            ICNT2=ICNT2+1
36655C
36656            IF(ICNT.GT.MAXOBV)THEN
36657              WRITE(ICOUT,999)
36658              CALL DPWRST('XXX','BUG ')
36659              WRITE(ICOUT,101)INAME
36660  101         FORMAT('****** ERROR IN ',A40)
36661              CALL DPWRST('XXX','BUG ')
36662              WRITE(ICOUT,322)
36663  322         FORMAT('      FOR THE MATRIX CASE, THE MAXIMUM NUMBER')
36664              CALL DPWRST('XXX','BUG ')
36665              WRITE(ICOUT,324)
36666  324         FORMAT('      OF OBSERVATIONS HAS BEEN EXCEEDED.')
36667              CALL DPWRST('XXX','BUG ')
36668              WRITE(ICOUT,326)MAXCNT
36669  326         FORMAT('      THE MAXIMUM NUMBER OF OBSERVATIONS = ',I10)
36670              CALL DPWRST('XXX','BUG ')
36671              IERROR='YES'
36672              GOTO9000
36673            ENDIF
36674C
36675            ICOLT=ICOL1+JLOOP-1
36676            IJ=MAXN*(ICOLT-1)+I
36677C
36678            IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PARZ')THEN
36679              WRITE(ICOUT,331)JLOOP,ICOLT,ICNT,IJ
36680  331         FORMAT('JLOOP,ICOLT,ICNT,IJ = ',4I8)
36681              CALL DPWRST('XXX','BUG ')
36682            ENDIF
36683C
36684            IF(ICOLT.LE.MAXCOL)Y(ICNT)=V(IJ)
36685            IF(ICOLT.EQ.MAXCP1)Y(ICNT)=PRED(I)
36686            IF(ICOLT.EQ.MAXCP2)Y(ICNT)=RES(I)
36687            IF(ICOLT.EQ.MAXCP3)Y(ICNT)=YPLOT(I)
36688            IF(ICOLT.EQ.MAXCP4)Y(ICNT)=XPLOT(I)
36689            IF(ICOLT.EQ.MAXCP5)Y(ICNT)=X2PLOT(I)
36690            IF(ICOLT.EQ.MAXCP6)Y(ICNT)=TAGPLO(I)
36691C
36692            COLID(ICNT)=REAL(JLOOP)
36693            ROWID(ICNT)=REAL(ICNT2)
36694C
36695  320     CONTINUE
36696  310   CONTINUE
36697        N1=ICNT
36698      ENDIF
36699C
36700C               *****************
36701C               **  STEP 90--  **
36702C               **  EXIT       **
36703C               *****************
36704C
36705 9000 CONTINUE
36706      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PARZ')THEN
36707        WRITE(ICOUT,999)
36708        CALL DPWRST('XXX','BUG ')
36709        WRITE(ICOUT,9011)
36710 9011   FORMAT('***** AT THE END       OF DPPARZ--')
36711        CALL DPWRST('XXX','BUG ')
36712        WRITE(ICOUT,9013)IFOUND,IERROR,NQ,NUMVAR,NLEFT,N1
36713 9013   FORMAT('IFOUND,IERROR,NQ,NUMVAR,NLEFT,N1 = ',
36714     1        A4,2X,A4,2X,4I8)
36715        CALL DPWRST('XXX','BUG ')
36716        DO9022I=1,N1
36717          WRITE(ICOUT,9023)I,Y(I),ROWID(I),COLID(I)
36718 9023     FORMAT('I,Y(I),ROWID(I),COLID(I) = ',I8,3G15.7)
36719          CALL DPWRST('XXX','BUG ')
36720 9022   CONTINUE
36721      ENDIF
36722C
36723      RETURN
36724      END
36725      SUBROUTINE DPPASP(IHARG,IARGT,ARG,NUMARG,
36726     1                  PDEFPG,MAXPAT,PPATSP,
36727     1                  IBUGP2,IFOUND,IERROR)
36728C
36729C     PURPOSE--DEFINE THE PATTERN SPACINGS.
36730C              THESE ARE LOCATED IN THE VECTOR PPATSP(.).
36731C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
36732C                     --IARGT  (A  CHARACTER VECTOR)
36733C                     --ARG
36734C                     --NUMARG
36735C                     --PDEFPG
36736C                     --MAXPAT
36737C                     --IBUGP2 ('ON' OR 'OFF' )
36738C     OUTPUT ARGUMENTS--PPATSP (A FLOATING POINT VECTOR)
36739C                     --IFOUND ('YES' OR 'NO' )
36740C                     --IERROR ('YES' OR 'NO' )
36741C     WRITTEN BY--JAMES J. FILLIBEN
36742C                 STATISTICAL ENGINEERING DIVISION
36743C                 INFORMATION TECHNOLOGY LABORATORY
36744C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
36745C                 GAITHERSBURG, MD 20899-8980
36746C                 PHONE--301-975-2899
36747C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
36748C           OF THE NATIONAL BUREAU OF STANDARDS.
36749C     LANGUAGE--ANSI FORTRAN (1977)
36750C     VERSION NUMBER--82/7
36751C     ORIGINAL VERSION--DECEMBER  1983.
36752C
36753C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
36754C
36755      CHARACTER*4 IHARG
36756      CHARACTER*4 IARGT
36757C
36758      CHARACTER*4 IBUGP2
36759      CHARACTER*4 IFOUND
36760      CHARACTER*4 IERROR
36761C
36762      CHARACTER*4 IHOLD1
36763C
36764      CHARACTER*4 ISUBN1
36765      CHARACTER*4 ISUBN2
36766      CHARACTER*4 ISTEPN
36767C
36768      DIMENSION IHARG(*)
36769      DIMENSION IARGT(*)
36770      DIMENSION ARG(*)
36771      DIMENSION PPATSP(*)
36772C
36773C---------------------------------------------------------------------
36774C
36775      INCLUDE 'DPCOP2.INC'
36776C
36777C-----START POINT-----------------------------------------------------
36778C
36779      IFOUND='NO'
36780      IERROR='NO'
36781      ISUBN1='DPPA'
36782      ISUBN2='SP  '
36783C
36784      NUMPAT=0
36785      IHOLD1='-999'
36786      HOLD1=-999.0
36787      HOLD2=-999.0
36788C
36789      IF(IBUGP2.EQ.'ON')THEN
36790        WRITE(ICOUT,999)
36791  999   FORMAT(1X)
36792        CALL DPWRST('XXX','BUG ')
36793        WRITE(ICOUT,51)
36794   51   FORMAT('***** AT THE BEGINNING OF DPPASP--')
36795        CALL DPWRST('XXX','BUG ')
36796        WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR,MAXPAT,NUMPAT
36797   52   FORMAT('IBUGP2,IFOUND,IERROR,MAXPAT,NUMPAT = ',3(A4,2X),2I8)
36798        CALL DPWRST('XXX','BUG ')
36799        WRITE(ICOUT,55)PDEFPG,NUMARG
36800   55   FORMAT('PDEFPG,NUMARG = ',G15.7,I8)
36801        CALL DPWRST('XXX','BUG ')
36802        DO65I=1,NUMARG
36803          WRITE(ICOUT,66)IHARG(I),IARGT(I),ARG(I)
36804   66     FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8)
36805          CALL DPWRST('XXX','BUG ')
36806   65   CONTINUE
36807        DO75I=1,10
36808          WRITE(ICOUT,76)I,PPATSP(I)
36809   76     FORMAT('I,PPATSP(I) = ',I8,2X,E15.7)
36810          CALL DPWRST('XXX','BUG ')
36811   75   CONTINUE
36812      ENDIF
36813C
36814C               **************************************
36815C               **  STEP 1--                        **
36816C               **  BRANCH TO THE APPROPRIATE CASE  **
36817C               **************************************
36818C
36819      ISTEPN='1'
36820      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
36821C
36822      IF(NUMARG.LE.0)GOTO9000
36823      IF(NUMARG.EQ.1)GOTO1110
36824      IF(NUMARG.EQ.2)GOTO1120
36825      IF(NUMARG.EQ.3)GOTO1130
36826      GOTO1140
36827C
36828 1110 CONTINUE
36829      GOTO1200
36830C
36831 1120 CONTINUE
36832      IF(IHARG(2).EQ.'ALL')IHOLD1='    '
36833      IF(IHARG(2).EQ.'ALL')HOLD1=PDEFPG
36834      IF(IHARG(2).EQ.'ALL')GOTO1300
36835      GOTO1200
36836C
36837 1130 CONTINUE
36838      IF(IHARG(2).EQ.'ALL')IHOLD1=IHARG(3)
36839      IF(IHARG(2).EQ.'ALL')HOLD1=ARG(3)
36840      IF(IHARG(2).EQ.'ALL')GOTO1300
36841      IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(2)
36842      IF(IHARG(3).EQ.'ALL')HOLD1=ARG(2)
36843      IF(IHARG(3).EQ.'ALL')GOTO1300
36844      GOTO1200
36845C
36846 1140 CONTINUE
36847      GOTO1200
36848C
36849C               *************************************************
36850C               **  STEP 2--                                   **
36851C               **  TREAT THE INDIVIDUAL SPECIFICATIONS CASE   **
36852C               *************************************************
36853C
36854 1200 CONTINUE
36855      ISTEPN='2'
36856      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
36857C
36858      IF(NUMARG.LE.1)GOTO1210
36859      GOTO1220
36860C
36861 1210 CONTINUE
36862      NUMPAT=1
36863      PPATSP(1)=PDEFPG
36864      GOTO1270
36865C
36866 1220 CONTINUE
36867      NUMPAT=NUMARG-1
36868      IF(NUMPAT.GT.MAXPAT)NUMPAT=MAXPAT
36869      DO1225I=1,NUMPAT
36870      J=I+1
36871      IHOLD1=IHARG(J)
36872      HOLD1=ARG(J)
36873      HOLD2=HOLD1
36874      IF(IHOLD1.EQ.'ON')HOLD2=PDEFPG
36875      IF(IHOLD1.EQ.'OFF')HOLD2=PDEFPG
36876      IF(IHOLD1.EQ.'AUTO')HOLD2=PDEFPG
36877      IF(IHOLD1.EQ.'DEFA')HOLD2=PDEFPG
36878      PPATSP(I)=HOLD2
36879 1225 CONTINUE
36880      GOTO1270
36881C
36882 1270 CONTINUE
36883      IF(IFEEDB.EQ.'ON')THEN
36884        WRITE(ICOUT,999)
36885        CALL DPWRST('XXX','BUG ')
36886        DO1278I=1,NUMPAT
36887          WRITE(ICOUT,1276)I,PPATSP(I)
36888 1276     FORMAT('PATTERN SPACING ',I6,' HAS JUST BEEN SET TO ',
36889     1           G15.7)
36890          CALL DPWRST('XXX','BUG ')
36891 1278   CONTINUE
36892      ENDIF
36893      IFOUND='YES'
36894      GOTO9000
36895C
36896C               **************************
36897C               **  STEP 2--            **
36898C               **  TREAT THE ALL CASE  **
36899C               **************************
36900C
36901 1300 CONTINUE
36902      ISTEPN='3'
36903      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
36904C
36905      NUMPAT=MAXPAT
36906      HOLD2=HOLD1
36907      IF(IHOLD1.EQ.'ON')HOLD2=PDEFPG
36908      IF(IHOLD1.EQ.'OFF')HOLD2=PDEFPG
36909      IF(IHOLD1.EQ.'AUTO')HOLD2=PDEFPG
36910      IF(IHOLD1.EQ.'DEFA')HOLD2=PDEFPG
36911      DO1315I=1,NUMPAT
36912      PPATSP(I)=HOLD2
36913 1315 CONTINUE
36914      GOTO1370
36915C
36916 1370 CONTINUE
36917      IF(IFEEDB.EQ.'ON')THEN
36918        WRITE(ICOUT,999)
36919        CALL DPWRST('XXX','BUG ')
36920        I=1
36921        WRITE(ICOUT,1316)PPATSP(I)
36922 1316   FORMAT('ALL PATTERN SPACINGS HAVE JUST BEEN SET TO ',
36923     1         A4)
36924        CALL DPWRST('XXX','BUG ')
36925      ENDIF
36926      IFOUND='YES'
36927      GOTO9000
36928C
36929C               *****************
36930C               **  STEP 90--  **
36931C               **  EXIT       **
36932C               *****************
36933C
36934 9000 CONTINUE
36935      IF(IBUGP2.EQ.'ON')THEN
36936        WRITE(ICOUT,9011)
36937 9011   FORMAT('***** AT THE END       OF DPPASP--')
36938        CALL DPWRST('XXX','BUG ')
36939        WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR
36940 9012   FORMAT('IBUGP2,IFOUND,IERROR = ',2(A4,2X),A4)
36941        CALL DPWRST('XXX','BUG ')
36942        WRITE(ICOUT,9014)IHOLD1,HOLD1,HOLD2
36943 9014   FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7)
36944        CALL DPWRST('XXX','BUG ')
36945        DO9035I=1,10
36946          WRITE(ICOUT,9036)I,PPATSP(I)
36947 9036     FORMAT('I,PPATSP(I) = ',I8,2X,E15.7)
36948          CALL DPWRST('XXX','BUG ')
36949 9035   CONTINUE
36950      ENDIF
36951C
36952      RETURN
36953      END
36954      SUBROUTINE DPPASW(IHARG,NUMARG,IDEFPS,MAXPAT,IPATSW,
36955     1IBUGP2,IFOUND,IERROR)
36956C
36957C     PURPOSE--DEFINE THE PATTERN SWITCHES.
36958C              THESE ARE LOCATED IN THE VECTOR IPATSW(.).
36959C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
36960C                     --NUMARG
36961C                     --IDEFPS
36962C                     --MAXPAT
36963C                     --IBUGP2 ('ON' OR 'OFF' )
36964C     OUTPUT ARGUMENTS--IPATSW (A CHARACTER VECTOR)
36965C                     --IFOUND ('YES' OR 'NO' )
36966C                     --IERROR ('YES' OR 'NO' )
36967C     WRITTEN BY--JAMES J. FILLIBEN
36968C                 STATISTICAL ENGINEERING DIVISION
36969C                 INFORMATION TECHNOLOGY LABORATORY
36970C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
36971C                 GAITHERSBURG, MD 20899-8980
36972C                 PHONE--301-975-2899
36973C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
36974C           OF THE NATIONAL BUREAU OF STANDARDS.
36975C     LANGUAGE--ANSI FORTRAN (1977)
36976C     VERSION NUMBER--82/7
36977C     ORIGINAL VERSION--DECEMBER  1983.
36978C
36979C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
36980C
36981      CHARACTER*4 IHARG
36982      CHARACTER*4 IDEFPS
36983      CHARACTER*4 IPATSW
36984C
36985      CHARACTER*4 IBUGP2
36986      CHARACTER*4 IFOUND
36987      CHARACTER*4 IERROR
36988C
36989      CHARACTER*4 IHOLD1
36990      CHARACTER*4 IHOLD2
36991C
36992      CHARACTER*4 ISUBN1
36993      CHARACTER*4 ISUBN2
36994      CHARACTER*4 ISTEPN
36995C
36996      DIMENSION IHARG(*)
36997      DIMENSION IPATSW(*)
36998C
36999C---------------------------------------------------------------------
37000C
37001      INCLUDE 'DPCOP2.INC'
37002C
37003C-----START POINT-----------------------------------------------------
37004C
37005      IFOUND='NO'
37006      IERROR='NO'
37007      ISUBN1='DPPA'
37008      ISUBN2='SW  '
37009C
37010      NUMPAT=0
37011      IHOLD1='-999'
37012      IHOLD2='-999'
37013C
37014      IF(IBUGP2.EQ.'OFF')GOTO90
37015      WRITE(ICOUT,999)
37016  999 FORMAT(1X)
37017      CALL DPWRST('XXX','BUG ')
37018      WRITE(ICOUT,51)
37019   51 FORMAT('***** AT THE BEGINNING OF DPPASW--')
37020      CALL DPWRST('XXX','BUG ')
37021      WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR
37022   52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
37023      CALL DPWRST('XXX','BUG ')
37024      WRITE(ICOUT,53)MAXPAT,NUMPAT
37025   53 FORMAT('MAXPAT,NUMPAT = ',I8,I8)
37026      CALL DPWRST('XXX','BUG ')
37027      WRITE(ICOUT,54)IHOLD1,IHOLD2
37028   54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
37029      CALL DPWRST('XXX','BUG ')
37030      WRITE(ICOUT,55)IDEFPS
37031   55 FORMAT('IDEFPS = ',A4)
37032      CALL DPWRST('XXX','BUG ')
37033      WRITE(ICOUT,60)NUMARG
37034   60 FORMAT('NUMARG = ',I8)
37035      CALL DPWRST('XXX','BUG ')
37036      DO65I=1,NUMARG
37037      WRITE(ICOUT,66)IHARG(I)
37038   66 FORMAT('IHARG(I) = ',A4)
37039      CALL DPWRST('XXX','BUG ')
37040   65 CONTINUE
37041      WRITE(ICOUT,70)IPATSW(1)
37042   70 FORMAT('IPATSW(1) = ',A4)
37043      CALL DPWRST('XXX','BUG ')
37044      DO75I=1,10
37045      WRITE(ICOUT,76)I,IPATSW(I)
37046   76 FORMAT('I,IPATSW(I) = ',I8,2X,A4)
37047      CALL DPWRST('XXX','BUG ')
37048   75 CONTINUE
37049   90 CONTINUE
37050C
37051C               **************************************
37052C               **  STEP 1--                        **
37053C               **  BRANCH TO THE APPROPRIATE CASE  **
37054C               **************************************
37055C
37056      ISTEPN='1'
37057      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
37058C
37059      IF(NUMARG.LE.0)GOTO1100
37060      IF(NUMARG.EQ.1)GOTO1110
37061      IF(NUMARG.EQ.2)GOTO1120
37062      GOTO1130
37063C
37064 1100 CONTINUE
37065      GOTO1200
37066C
37067 1110 CONTINUE
37068      IF(IHARG(1).EQ.'ALL')IHOLD1='ON'
37069      IF(IHARG(1).EQ.'ALL')GOTO1300
37070      GOTO1200
37071C
37072 1120 CONTINUE
37073      IF(IHARG(1).EQ.'ALL')IHOLD1=IHARG(2)
37074      IF(IHARG(1).EQ.'ALL')GOTO1300
37075      IF(IHARG(2).EQ.'ALL')IHOLD1=IHARG(1)
37076      IF(IHARG(2).EQ.'ALL')GOTO1300
37077      GOTO1200
37078C
37079 1130 CONTINUE
37080      GOTO1200
37081C
37082C               *************************************************
37083C               **  STEP 2--                                   **
37084C               **  TREAT THE INDIVIDUAL SPECIFICATIONS CASE  **
37085C               *************************************************
37086C
37087 1200 CONTINUE
37088      ISTEPN='2'
37089      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
37090C
37091      IF(NUMARG.LE.0)GOTO1210
37092      GOTO1220
37093C
37094 1210 CONTINUE
37095      NUMPAT=1
37096      IPATSW(1)='ON'
37097      GOTO1270
37098C
37099 1220 CONTINUE
37100      NUMPAT=NUMARG
37101      IF(NUMPAT.GT.MAXPAT)NUMPAT=MAXPAT
37102      DO1225I=1,NUMPAT
37103      J=I
37104      IHOLD1=IHARG(J)
37105      IHOLD2=IHOLD1
37106      IF(IHOLD1.EQ.'ON')IHOLD2='ON'
37107      IF(IHOLD1.EQ.'OFF')IHOLD2='OFF'
37108CCCCC IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEFPS
37109CCCCC IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEFPS
37110      IPATSW(I)=IHOLD2
37111 1225 CONTINUE
37112      GOTO1270
37113C
37114 1270 CONTINUE
37115      IF(IFEEDB.EQ.'OFF')GOTO1279
37116      WRITE(ICOUT,999)
37117      CALL DPWRST('XXX','BUG ')
37118      DO1278I=1,NUMPAT
37119      WRITE(ICOUT,1276)I,IPATSW(I)
37120 1276 FORMAT('PATTERN ',I6,' HAS JUST BEEN SET TO ',
37121     1A4)
37122      CALL DPWRST('XXX','BUG ')
37123 1278 CONTINUE
37124 1279 CONTINUE
37125      IFOUND='YES'
37126      GOTO9000
37127C
37128C               **************************
37129C               **  STEP 2--            **
37130C               **  TREAT THE ALL CASE  **
37131C               **************************
37132C
37133 1300 CONTINUE
37134      ISTEPN='3'
37135      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
37136C
37137      NUMPAT=MAXPAT
37138      IHOLD2=IHOLD1
37139      IF(IHOLD1.EQ.'ON')IHOLD2='ON'
37140      IF(IHOLD1.EQ.'OFF')IHOLD2='OFF'
37141CCCCC IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEFPS
37142CCCCC IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEFPS
37143      DO1315I=1,NUMPAT
37144      IPATSW(I)=IHOLD2
37145 1315 CONTINUE
37146      GOTO1370
37147C
37148 1370 CONTINUE
37149      IF(IFEEDB.EQ.'OFF')GOTO1319
37150      WRITE(ICOUT,999)
37151      CALL DPWRST('XXX','BUG ')
37152      I=1
37153      WRITE(ICOUT,1316)IPATSW(I)
37154 1316 FORMAT('ALL PATTERNS HAVE JUST BEEN SET TO ',
37155     1A4)
37156      CALL DPWRST('XXX','BUG ')
37157 1319 CONTINUE
37158      IFOUND='YES'
37159      GOTO9000
37160C
37161C               *****************
37162C               **  STEP 90--  **
37163C               **  EXIT       **
37164C               *****************
37165C
37166 9000 CONTINUE
37167      IF(IBUGP2.EQ.'OFF')GOTO9090
37168      WRITE(ICOUT,9011)
37169 9011 FORMAT('***** AT THE END       OF DPPASW--')
37170      CALL DPWRST('XXX','BUG ')
37171      WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR
37172 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
37173      CALL DPWRST('XXX','BUG ')
37174      WRITE(ICOUT,9013)MAXPAT,NUMPAT
37175 9013 FORMAT('MAXPAT,NUMPAT = ',I8,I8)
37176      CALL DPWRST('XXX','BUG ')
37177      WRITE(ICOUT,9014)IHOLD1,IHOLD2
37178 9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
37179      CALL DPWRST('XXX','BUG ')
37180      WRITE(ICOUT,9015)IDEFPS
37181 9015 FORMAT('IDEFPS = ',A4)
37182      CALL DPWRST('XXX','BUG ')
37183      WRITE(ICOUT,9020)NUMARG
37184 9020 FORMAT('NUMARG = ',I8)
37185      CALL DPWRST('XXX','BUG ')
37186      DO9025I=1,NUMARG
37187      WRITE(ICOUT,9026)IHARG(I)
37188 9026 FORMAT('IHARG(I) = ',A4)
37189      CALL DPWRST('XXX','BUG ')
37190 9025 CONTINUE
37191      WRITE(ICOUT,9030)IPATSW(1)
37192 9030 FORMAT('IPATSW(1) = ',A4)
37193      CALL DPWRST('XXX','BUG ')
37194      DO9035I=1,10
37195      WRITE(ICOUT,9036)I,IPATSW(I)
37196 9036 FORMAT('I,IPATSW(I) = ',I8,2X,A4)
37197      CALL DPWRST('XXX','BUG ')
37198 9035 CONTINUE
37199 9090 CONTINUE
37200C
37201      RETURN
37202      END
37203      SUBROUTINE DPPAT(IBUGA3,IBUGQ,IFOUND,IERROR)
37204C
37205C     PURPOSE--GENERATE A PATTERN.
37206C              GENERATE ELEMENTS OF A PATTERN
37207C              BY THE FORM (FOR EXAMPLE) LET Y = PATTERN 1 1 2 2 3 3
37208C              (FOR A FULL VARIABLE OR PART OF A VARIABLE).
37209C     OUTPUT--NECESSARILY A VARIABLE.
37210C              EXAMPLE--LET Y    = 1 1 2 2 3 3                  (A FULL VARIABLE
37211C                     --LET Y    = 1 1 2 2 3 3  SUBSET 2 3 5    (A PARTIAL VAR.)
37212C                     --LET Y    = 1 1 2 2 3 3  FOR I = 1 2 10  (A PARTIAL VAR.)
37213C     WRITTEN BY--JAMES J. FILLIBEN
37214C                 STATISTICAL ENGINEERING DIVISION
37215C                 INFORMATION TECHNOLOGY LABORATORY
37216C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
37217C                 GAITHERSBURG, MD 20899-8980
37218C                 PHONE--301-975-2899
37219C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
37220C           OF THE NATIONAL BUREAU OF STANDARDS.
37221C     LANGUAGE--ANSI FORTRAN (1977)
37222C     VERSION NUMBER--82/7
37223C     ORIGINAL VERSION--JULY      1981.
37224C     UPDATED         --OCTOBER   1981.
37225C     UPDATED         --NOVEMBER  1981.
37226C     UPDATED         --MAY       1982.
37227C
37228C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
37229C
37230      CHARACTER*4 IBUGA3
37231      CHARACTER*4 IBUGQ
37232      CHARACTER*4 IFOUND
37233      CHARACTER*4 IERROR
37234C
37235      CHARACTER*4 NEWNAM
37236      CHARACTER*4 NEWCOL
37237      CHARACTER*4 IHWUSE
37238      CHARACTER*4 MESSAG
37239      CHARACTER*4 ICASEQ
37240      CHARACTER*4 ILEFT
37241      CHARACTER*4 ILEFT2
37242      CHARACTER*4 IH
37243      CHARACTER*4 IH2
37244C
37245      CHARACTER*4 ISUBN1
37246      CHARACTER*4 ISUBN2
37247      CHARACTER*4 ISTEPN
37248C
37249C-----COMMON----------------------------------------------------------
37250C
37251      INCLUDE 'DPCOPA.INC'
37252      INCLUDE 'DPCOHK.INC'
37253      INCLUDE 'DPCODA.INC'
37254      INCLUDE 'DPCOP2.INC'
37255C
37256C-----START POINT-----------------------------------------------------
37257C
37258      ISUBN1='DPPA'
37259      ISUBN2='TT  '
37260      IFOUND='NO'
37261      IERROR='NO'
37262C
37263      MAXCP1=MAXCOL+1
37264      MAXCP2=MAXCOL+2
37265      MAXCP3=MAXCOL+3
37266      MAXCP4=MAXCOL+4
37267      MAXCP5=MAXCOL+5
37268      MAXCP6=MAXCOL+6
37269C
37270      NLEFT=0
37271      ICOLL=0
37272      NRAWPA=0
37273      NNUM=0
37274      NS2=0
37275      NS2MOD=0
37276C
37277      ILEFT='UNKN'
37278      ILEFT2='UNKN'
37279C
37280C
37281C               ********************************************************
37282C               **  TREAT THE SUBCASE OF GENERATING A PATTERN         **
37283C               **       1) FOR A FULL VARIABLE, OR                   **
37284C               **       2) FOR PART OF A VARIABLE.                   **
37285C               ********************************************************
37286C
37287      IF(IBUGA3.EQ.'OFF')GOTO90
37288      WRITE(ICOUT,999)
37289  999 FORMAT(1X)
37290      CALL DPWRST('XXX','BUG ')
37291      WRITE(ICOUT,51)
37292   51 FORMAT('***** AT THE BEGINNING OF DPPAT--')
37293      CALL DPWRST('XXX','BUG ')
37294      WRITE(ICOUT,52)IBUGA3,IBUGQ
37295   52 FORMAT('IBUGA3,IBUGQ = ',A4,2X,A4)
37296      CALL DPWRST('XXX','BUG ')
37297   90 CONTINUE
37298C
37299C               **********************************
37300C               **  STEP 1--                    **
37301C               **  INITIALIZE SOME VARIABLES.  **
37302C               **********************************
37303C
37304      ISTEPN='1'
37305      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
37306C
37307      NEWNAM='NO'
37308      NEWCOL='NO'
37309C
37310C               *******************************************************
37311C               **  STEP 2--                                         **
37312C               **  CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS.  **
37313C               *******************************************************
37314C
37315      ISTEPN='2'
37316      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
37317C
37318      MINNA=4
37319      MAXNA=1000
37320      CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,
37321     1IERROR)
37322      IF(IERROR.EQ.'YES')GOTO9000
37323C
37324C               ****************************************************************
37325C               **  STEP 3--                                                   *
37326C               **  EXAMINE THE LEFT-HAND SIDE--                               *
37327C               **  IS THE PARAMETER OR VARIABLE NAME TO LEFT OF = SIGN        *
37328C               **  ALREADY IN THE NAME LIST?                                  *
37329C               **  NOTE THAT     ILEFT      IS THE NAME OF THE VARIABLE       *
37330C               **  ON THE LEFT.                                               *
37331C               **  NOTE THAT     ILISTL    IS THE LINE IN THE TABLE           *
37332C               **  OF THE NAME ON THE LEFT.                                   *
37333C               **  NOTE THAT     ICOLL    IS THE DATA COLUMN (1 TO 12)        *
37334C               **  FOR THE NAME OF THE LEFT.                                  *
37335C               ****************************************************************
37336C
37337      ISTEPN='3'
37338      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
37339C
37340CCCCC ILEFT=IHOL(2)
37341CCCCC ILEFT2=IHOL2(2)
37342      ILEFT=IHARG(1)
37343      ILEFT2=IHARG2(1)
37344      DO310I=1,NUMNAM
37345      I2=I
37346      IF(ILEFT.EQ.IHNAME(I).AND.ILEFT2.EQ.IHNAM2(I).AND.
37347     1IUSE(I).EQ.'P')GOTO329
37348      IF(ILEFT.EQ.IHNAME(I).AND.ILEFT2.EQ.IHNAM2(I).AND.
37349     1IUSE(I).EQ.'V')GOTO380
37350  310 CONTINUE
37351      NEWNAM='YES'
37352      ILISTL=NUMNAM+1
37353      IF(ILISTL.GT.MAXNAM)GOTO320
37354      GOTO330
37355C
37356  320 CONTINUE
37357      WRITE(ICOUT,999)
37358      CALL DPWRST('XXX','BUG ')
37359      WRITE(ICOUT,321)
37360  321 FORMAT('***** ERROR IN DPPAT--')
37361      CALL DPWRST('XXX','BUG ')
37362      WRITE(ICOUT,322)
37363  322 FORMAT('      THE NUMBER OF VARIABLE AND/OR PARAMETER')
37364      CALL DPWRST('XXX','BUG ')
37365      WRITE(ICOUT,323)MAXNAM
37366  323 FORMAT('      NAMES HAS JUST EXCEEDED THE MAX ALLOWABLE ',
37367     1I8,'  .')
37368      CALL DPWRST('XXX','BUG ')
37369      WRITE(ICOUT,324)
37370  324 FORMAT('      SUGGESTED ACTION--')
37371      CALL DPWRST('XXX','BUG ')
37372      WRITE(ICOUT,325)
37373  325 FORMAT('      ENTER      STAT')
37374      CALL DPWRST('XXX','BUG ')
37375      WRITE(ICOUT,326)
37376  326 FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES,')
37377      CALL DPWRST('XXX','BUG ')
37378      WRITE(ICOUT,327)
37379  327 FORMAT('      AND THEN REDEFINE (REUSE) SOME OF THE')
37380      CALL DPWRST('XXX','BUG ')
37381      WRITE(ICOUT,328)
37382  328 FORMAT('      ALREADY-USED NAMES')
37383      CALL DPWRST('XXX','BUG ')
37384      IERROR='YES'
37385      GOTO9000
37386C
37387  329 CONTINUE
37388      ILISTL=I2
37389      GOTO330
37390C
37391  330 CONTINUE
37392      NLEFT=0
37393      ICOLL=NUMCOL+1
37394      IF(ICOLL.GT.MAXCOL)GOTO340
37395      GOTO390
37396C
37397  340 CONTINUE
37398      WRITE(ICOUT,341)
37399  341 FORMAT('***** ERROR IN DPPAT--')
37400      CALL DPWRST('XXX','BUG ')
37401      WRITE(ICOUT,342)
37402  342 FORMAT('      THE NUMBER OF DATA COLUMNS')
37403      CALL DPWRST('XXX','BUG ')
37404      WRITE(ICOUT,343)MAXCOL
37405  343 FORMAT('      HAS JUST EXCEEDED THE MAX ALLOWABLE ',I8,'  .')
37406      CALL DPWRST('XXX','BUG ')
37407      WRITE(ICOUT,344)
37408  344 FORMAT('      SUGGESTED ACTION--')
37409      CALL DPWRST('XXX','BUG ')
37410      WRITE(ICOUT,345)
37411  345 FORMAT('      ENTER      STAT')
37412      CALL DPWRST('XXX','BUG ')
37413      WRITE(ICOUT,346)
37414  346 FORMAT('      TO FIND OUT THE FULL LIST OF USED COLUMNS')
37415      CALL DPWRST('XXX','BUG ')
37416      WRITE(ICOUT,347)
37417  347 FORMAT('      AND THEN OVERWRITE SOME COLUMNS.   EXAMPLE--')
37418      CALL DPWRST('XXX','BUG ')
37419      WRITE(ICOUT,348)
37420  348 FORMAT('      IF       LET X = 1 2 9         FAILED')
37421      CALL DPWRST('XXX','BUG ')
37422      WRITE(ICOUT,349)
37423  349 FORMAT('      THEN ONE MIGHT ENTER     NAME X 7')
37424      CALL DPWRST('XXX','BUG ')
37425      WRITE(ICOUT,350)
37426  350 FORMAT('      (THEREBY EQUATING THE NAME X WITH COLUMN 7')
37427      CALL DPWRST('XXX','BUG ')
37428      WRITE(ICOUT,351)
37429  351 FORMAT('      FOLLOWED BY              LET X = 1 2 9')
37430      CALL DPWRST('XXX','BUG ')
37431      WRITE(ICOUT,352)
37432  352 FORMAT('      (WHICH WILL ACTUALLY OVERWRITE COLUMN 7')
37433      CALL DPWRST('XXX','BUG ')
37434      WRITE(ICOUT,353)
37435  353 FORMAT('      WITH THE NUMERIC CONSTANTS 3.14)')
37436      CALL DPWRST('XXX','BUG ')
37437      IERROR='YES'
37438      GOTO9000
37439C
37440  380 CONTINUE
37441      ILISTL=I2
37442      ICOLL=IVALUE(ILISTL)
37443      NLEFT=IN(ILISTL)
37444C
37445  390 CONTINUE
37446C
37447C               *************************************************
37448C               **  STEP 4--                                   **
37449C               **  EXAMINE THE RIGHT-HAND SIDE--              **
37450C               **  DO WE HAVE A SERIES OF CONSTANTS,          **
37451C               **  OR A SERIES OF PARAMETERS,                 **
37452C               **  OR A MIXTURE OF CONSTANTS AND PARAMETERS?  **
37453C               **  (ALL OF THE ABOVE ARE ALLOWED.)            **
37454C               *************************************************
37455C
37456      ISTEPN='4'
37457      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
37458C
37459      IF(NUMARG.GE.4)GOTO1290
37460      WRITE(ICOUT,1211)
37461 1211 FORMAT('***** ERROR IN DPPAT--')
37462      CALL DPWRST('XXX','BUG ')
37463      WRITE(ICOUT,1212)
37464 1212 FORMAT('      ILLEGAL SYNTAX FOR LET COMMAND')
37465      CALL DPWRST('XXX','BUG ')
37466      WRITE(ICOUT,1213)
37467 1213 FORMAT('      THERE SHOULD BE AT LEAST 1')
37468      CALL DPWRST('XXX','BUG ')
37469      WRITE(ICOUT,1214)
37470 1214 FORMAT('      NUMBER OR WORD')
37471      CALL DPWRST('XXX','BUG ')
37472      WRITE(ICOUT,1215)
37473 1215 FORMAT('      TO THE RIGHT OF THE WORD    PATTERN')
37474      CALL DPWRST('XXX','BUG ')
37475      WRITE(ICOUT,1216)
37476 1216 FORMAT('      FOR THIS TYPE OF LET COMMAND.')
37477      CALL DPWRST('XXX','BUG ')
37478      WRITE(ICOUT,1217)
37479 1217 FORMAT('      SUCH WAS NOT THE CASE HERE.')
37480      CALL DPWRST('XXX','BUG ')
37481      NUMAM3=NUMARG-3
37482      WRITE(ICOUT,1218)NUMAM3
37483 1218 FORMAT('      NUMBER OF SUCH NUMBERS/WORDS FOUND = ',I8)
37484      CALL DPWRST('XXX','BUG ')
37485      WRITE(ICOUT,1219)
37486 1219 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
37487      CALL DPWRST('XXX','BUG ')
37488      IF(IWIDTH.GE.1)WRITE(ICOUT,1220)(IANS(I),I=1,IWIDTH)
37489 1220 FORMAT('      ',80A1)
37490      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
37491      IERROR='YES'
37492      GOTO9000
37493 1290 CONTINUE
37494C
37495C               *************************************************
37496C               **  STEP 5--                                   **
37497C               **  GENERATE    NRAWPA         NUMBERS         **
37498C               **  IN   THE RAW PATTERN.                      **
37499C               **  STORE THEM TEMPORARILY IN                  **
37500C               **  THE VECTOR Y(.).                           **
37501C               *************************************************
37502C
37503      ISTEPN='5'
37504      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
37505C
37506      K=0
37507      NRAWPA=0
37508      DO1310J=4,NUMARG
37509      J2=J
37510      K=K+1
37511      IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET  ')GOTO1370
37512      IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT  ')GOTO1370
37513      IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.'    ')GOTO1370
37514      IF(IARGT(J).EQ.'NUMB')GOTO1311
37515      IF(IARGT(J).EQ.'WORD')GOTO1312
37516      GOTO1360
37517 1311 CONTINUE
37518      Y(K)=ARG(J)
37519      GOTO1310
37520 1312 CONTINUE
37521      IH=IHARG(J)
37522      IH2=IHARG2(J)
37523      IHWUSE='P'
37524      MESSAG='YES'
37525      CALL CHECKN(IH,IH2,IHWUSE,
37526     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
37527     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR)
37528      IF(IERROR.EQ.'YES')GOTO9000
37529      Y(K)=VALUE(ILOC)
37530      GOTO1310
37531 1310 CONTINUE
37532      NRAWPA=K
37533      GOTO1380
37534C
37535 1360 CONTINUE
37536      WRITE(ICOUT,1361)
37537 1361 FORMAT('***** INTERNAL ERROR IN DPPAT--')
37538      CALL DPWRST('XXX','BUG ')
37539      WRITE(ICOUT,1362)
37540 1362 FORMAT('      AN ARGUMENT TYPE WHICH SHOULD BE ')
37541      CALL DPWRST('XXX','BUG ')
37542      WRITE(ICOUT,1363)
37543 1363 FORMAT('      EITHER A NUMBER OR A WORD, IS NEITHER.')
37544      CALL DPWRST('XXX','BUG ')
37545      WRITE(ICOUT,1364)IHARG(J2),IHARG2(J2)
37546 1364 FORMAT('      ARGUMENT                  = ',A4,A4)
37547      CALL DPWRST('XXX','BUG ')
37548      WRITE(ICOUT,1365)J2
37549 1365 FORMAT('      LOCATION IN ARGUMENT LIST = ',I8)
37550      CALL DPWRST('XXX','BUG ')
37551      WRITE(ICOUT,1366)IARGT(J2)
37552 1366 FORMAT('      ARGUMENT TYPE             = ',A4,A4)
37553      CALL DPWRST('XXX','BUG ')
37554      WRITE(ICOUT,1367)
37555 1367 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
37556      CALL DPWRST('XXX','BUG ')
37557      IF(IWIDTH.GE.1)WRITE(ICOUT,1368)(IANS(I),I=1,IWIDTH)
37558 1368 FORMAT('      ',100A1)
37559      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
37560      IERROR='YES'
37561      GOTO9000
37562C
37563 1370 CONTINUE
37564      NRAWPA=K-1
37565      GOTO1380
37566C
37567 1380 CONTINUE
37568      IFOUND='YES'
37569      IF(NRAWPA.GE.1)GOTO1390
37570      WRITE(ICOUT,999)
37571      CALL DPWRST('XXX','BUG ')
37572      WRITE(ICOUT,1381)
37573 1381 FORMAT('***** ERROR IN DPPAT--')
37574      CALL DPWRST('XXX','BUG ')
37575      WRITE(ICOUT,1382)
37576 1382 FORMAT('      ILLEGAL FORM FOR THE LET COMMAND.')
37577      CALL DPWRST('XXX','BUG ')
37578      WRITE(ICOUT,1383)
37579 1383 FORMAT('      THERE ARE NO ELEMENTS IN THE PATTERN.')
37580      CALL DPWRST('XXX','BUG ')
37581      WRITE(ICOUT,1384)
37582 1384 FORMAT('      THIS IS CAUSED BY EITHER THE WORD   PATTERN')
37583      CALL DPWRST('XXX','BUG ')
37584      WRITE(ICOUT,1385)
37585 1385 FORMAT('      BEING THE LAST WORD ON THE COMMAND LINE, OR')
37586      CALL DPWRST('XXX','BUG ')
37587      WRITE(ICOUT,1386)
37588 1386 FORMAT('      BY THE WORDS    SUBSET  OR  FOR   IMMEDIATELY')
37589      CALL DPWRST('XXX','BUG ')
37590      WRITE(ICOUT,1387)
37591 1387 FORMAT('      FOLLOWING THE WORD   PATTERN   ON THE COMMAND ',
37592     1'LINE.')
37593      CALL DPWRST('XXX','BUG ')
37594      WRITE(ICOUT,1388)
37595 1388 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
37596      CALL DPWRST('XXX','BUG ')
37597      IF(IWIDTH.GE.1)WRITE(ICOUT,1389)(IANS(I),I=1,IWIDTH)
37598 1389 FORMAT('      ',100A1)
37599      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
37600      IERROR='YES'
37601      GOTO9000
37602C
37603 1390 CONTINUE
37604C
37605C               ***********************************************************
37606C               **  STEP 7--                                             **
37607C               **  IF CALLED FOR (THAT IS, IF IBUGA3 IS ON),      **
37608C               **  PRINT OUT THE INTERMEDIATE VARIABLE Y(.).            **
37609C               **  THIS IS USEFUL FOR DIAGNOSTIC PURPOSES               **
37610C               **  IN REVIEWING THE OUTPUT FROM THIS SUBROUTINE.        **
37611C               ***********************************************************
37612C
37613      ISTEPN='7'
37614      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
37615C
37616      IF(IBUGA3.EQ.'OFF')GOTO1590
37617      WRITE(ICOUT,1551)
37618 1551 FORMAT('OUTPUT FROM MIDDLE OF DPPAT AFTER THE RAW PATTERN ',
37619     1'HAS BEEN GENERATED--')
37620      CALL DPWRST('XXX','BUG ')
37621      WRITE(ICOUT,1552)NRAWPA
37622 1552 FORMAT('NRAWPA = ',I8)
37623      CALL DPWRST('XXX','BUG ')
37624      IF(NRAWPA.LE.0)GOTO1590
37625      DO1554I=1,NRAWPA
37626      WRITE(ICOUT,1555)I,Y(I)
37627 1555 FORMAT('I,Y(I) = ',I8,F12.5)
37628      CALL DPWRST('XXX','BUG ')
37629 1554 CONTINUE
37630C
37631 1590 CONTINUE
37632C
37633C               *****************************************
37634C               **  STEP 8--                           **
37635C               **  CHECK TO SEE THE TYPE SUBCASE      **
37636C               **  (BASED ON THE QUALIFIER)           **
37637C               **    1) UNQUALIFIED (THAT IS, FULL);  **
37638C               **    2) SUBSET/EXCEPT; OR             **
37639C               **    3) FOR.                          **
37640C               *****************************************
37641C
37642      ISTEPN='8'
37643      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
37644C
37645      ICASEQ='FULL'
37646      ILOCQ=NUMARG+1
37647      IF(NUMARG.LT.1)GOTO1670
37648      DO1610J=1,NUMARG
37649      J1=J
37650      IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET  ')GOTO1620
37651      IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT  ')GOTO1620
37652      IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.'    ')GOTO1630
37653 1610 CONTINUE
37654      GOTO1680
37655C
37656 1620 CONTINUE
37657      ICASEQ='SUBS'
37658      ILOCQ=J1
37659      GOTO1680
37660C
37661 1630 CONTINUE
37662      ICASEQ='FOR'
37663      ILOCQ=J1
37664      GOTO1680
37665C
37666 1670 CONTINUE
37667      WRITE(ICOUT,999)
37668      CALL DPWRST('XXX','BUG ')
37669      WRITE(ICOUT,1671)
37670 1671 FORMAT('***** INTERNAL ERROR IN DPPAT')
37671      CALL DPWRST('XXX','BUG ')
37672      WRITE(ICOUT,1672)
37673 1672 FORMAT('      AT BRANCH POINT 1671--')
37674      CALL DPWRST('XXX','BUG ')
37675      WRITE(ICOUT,1673)
37676 1673 FORMAT('      NUMARG LESS THAN 1 EVEN THOUGH')
37677      CALL DPWRST('XXX','BUG ')
37678      WRITE(ICOUT,1674)
37679 1674 FORMAT('      NUMARG HAD PREVIOUSLY PASSED THIS TEST')
37680      CALL DPWRST('XXX','BUG ')
37681      WRITE(ICOUT,1675)NUMARG
37682 1675 FORMAT('      ONCE ALREADY.  VALUE OF NUMARG = ',I8)
37683      CALL DPWRST('XXX','BUG ')
37684      WRITE(ICOUT,1676)
37685 1676 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
37686      CALL DPWRST('XXX','BUG ')
37687      IF(IWIDTH.GE.1)WRITE(ICOUT,1677)(IANS(I),I=1,IWIDTH)
37688 1677 FORMAT(80A1)
37689      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
37690      IERROR='YES'
37691      GOTO9000
37692C
37693 1680 CONTINUE
37694      IF(IBUGA3.EQ.'OFF')GOTO1690
37695      WRITE(ICOUT,1681)NUMARG,ILOCQ,ICASEQ
37696 1681 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4)
37697      CALL DPWRST('XXX','BUG ')
37698C
37699 1690 CONTINUE
37700C
37701C               ******************************************************
37702C               **  STEP 9--                                        **
37703C               **  BRANCH TO THE APPROPRIATE SUBCASE               **
37704C               **  (BASED ON THE QUALIFIER);                       **
37705C               **  DETERMINE THE NUMBER (= NNUM)                   **
37706C               **  OF        NUMBERS TO BE GENERATED.              **
37707C               **  NOTE THAT THE VARIABLE NIISUB                   **
37708C               **  IS THE LENGTH OF THE RESULTING                  **
37709C               **  VARIABLE ISUB(.).                               **
37710C               **  NOTE THAT DPFOR AUTOMATICALLY EXTENDS           **
37711C               **  THE INPUT LENGTH OF ISUB(.) IF NECESSARY.       **
37712C               **  (HENCE THE REDEFINITION OF NIISUB TO NINEW      **
37713C               **  AFTER THE CALL TO DPFOR.                        **
37714C               ******************************************************
37715C
37716      ISTEPN='9'
37717      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
37718C
37719      IF(ICASEQ.EQ.'FULL')GOTO1710
37720      IF(ICASEQ.EQ.'SUBS')GOTO1720
37721      IF(ICASEQ.EQ.'FOR')GOTO1730
37722C
37723 1710 CONTINUE
37724CCCCC IF(NEWNAM.EQ.'NO')NIISUB=NLEFT
37725CCCCC IF(NEWNAM.EQ.'YES')NIISUB=NRAWPA
37726      NIISUB=NRAWPA
37727      DO1715I=1,NIISUB
37728      ISUB(I)=1
37729 1715 CONTINUE
37730      NS=NIISUB
37731      NNUM=NIISUB
37732      GOTO1750
37733C
37734 1720 CONTINUE
37735      NIISUB=MAXN
37736      CALL DPSUBS(NIISUB,ILOCS,NS,IBUGQ,IERROR)
37737      NNUM=NS
37738      GOTO1750
37739C
37740 1730 CONTINUE
37741      IF(NEWNAM.EQ.'NO')NIISUB=NLEFT
37742      IF(NEWNAM.EQ.'YES')NIISUB=MAXN
37743      CALL DPFOR(NIISUB,NINEW,IROW1,IROWN,
37744     1NLOCAL,ILOCS,NS,IBUGQ,IERROR)
37745      NIISUB=NINEW
37746      NNUM=NS
37747      GOTO1750
37748C
37749 1750 CONTINUE
37750C
37751C               ******************************************************
37752C               **  STEP 10--                                       **
37753C               **  COPY THE        PATTERN                        **
37754C               **  FROM THE INTERMEDIATE VECTOR Y(.)               **
37755C               **  TO THE APPROPRIATE COLUMN                       **
37756C               **  (BASED ON THE QUALIFIER--FULL, SUBSET, OR FOR)  **
37757C               **  IN THE INTERNAL DATAPLOT DATA TABLE.            **
37758C               ******************************************************
37759C
37760      ISTEPN='10'
37761      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
37762C
37763      NS2=0
37764      NS2MOD=0
37765      DO2100I=1,NIISUB
37766      IJ=MAXN*(ICOLL-1)+I
37767      IF(ISUB(I).EQ.0)GOTO2100
37768      NS2=NS2+1
37769      NS2MOD=NS2MOD+1
37770      IF(NS2.EQ.1)IROW1=I
37771      IF(NS2MOD.GT.NRAWPA)NS2MOD=NS2MOD-NRAWPA
37772      IF(ICOLL.LE.MAXCOL)V(IJ)=Y(NS2MOD)
37773      IF(ICOLL.EQ.MAXCP1)PRED(I)=Y(NS2MOD)
37774      IF(ICOLL.EQ.MAXCP2)RES(I)=Y(NS2MOD)
37775      IF(ICOLL.EQ.MAXCP3)YPLOT(I)=Y(NS2MOD)
37776      IF(ICOLL.EQ.MAXCP4)XPLOT(I)=Y(NS2MOD)
37777      IF(ICOLL.EQ.MAXCP5)X2PLOT(I)=Y(NS2MOD)
37778      IF(ICOLL.EQ.MAXCP6)TAGPLO(I)=Y(NS2MOD)
37779      IROWN=I
37780 2100 CONTINUE
37781      NNUM=NS2
37782C
37783C               *******************************************
37784C               **  STEP 11--                            **
37785C               **  CARRY OUT THE LIST UPDATING AND      **
37786C               **  GENERATE THE INFORMATIVE PRINTING.   **
37787C               *******************************************
37788C
37789      ISTEPN='11'
37790      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
37791C
37792      IF(ICASEQ.EQ.'FULL'.AND.NEWNAM.EQ.'NO'.AND.
37793     1NLEFT.GE.NRAWPA)NINEW=NLEFT
37794      IF(ICASEQ.EQ.'FULL'.AND.NEWNAM.EQ.'NO'.AND.
37795     1NLEFT.LT.NRAWPA)NINEW=NRAWPA
37796      IF(ICASEQ.EQ.'FULL'.AND.NEWNAM.EQ.'YES')NINEW=NIISUB
37797      IF(ICASEQ.EQ.'SUBS'.AND.NEWNAM.EQ.'NO'.AND.
37798     1NLEFT.GE.IROWN)NINEW=NLEFT
37799      IF(ICASEQ.EQ.'SUBS'.AND.NEWNAM.EQ.'NO'.AND.
37800     1NLEFT.LT.IROWN)NINEW=IROWN
37801      IF(ICASEQ.EQ.'SUBS'.AND.NEWNAM.EQ.'YES')NINEW=IROWN
37802      IF(ICASEQ.EQ.'FOR'.AND.NEWNAM.EQ.'NO'.AND.
37803     1NLEFT.GE.IROWN)NINEW=NLEFT
37804      IF(ICASEQ.EQ.'FOR'.AND.NEWNAM.EQ.'NO'.AND.
37805     1NLEFT.LT.IROWN)NINEW=IROWN
37806      IF(ICASEQ.EQ.'FOR'.AND.NEWNAM.EQ.'YES')NINEW=IROWN
37807C
37808      IHNAME(ILISTL)=ILEFT
37809      IHNAM2(ILISTL)=ILEFT2
37810      IUSE(ILISTL)='V'
37811      IVALUE(ILISTL)=ICOLL
37812      VALUE(ILISTL)=ICOLL
37813      IN(ILISTL)=NINEW
37814C
37815CCCCC IUSE(ICOLL)='V'
37816CCCCC IVALUE(ICOLL)=ICOLL
37817CCCCC VALUE(ICOLL)=ICOLL
37818CCCCC IN(ICOLL)=NINEW
37819C
37820      IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1
37821      IF(NEWNAM.EQ.'YES')NUMCOL=NUMCOL+1
37822C
37823      DO2400J4=1,NUMNAM
37824      IF(IUSE(J4).EQ.'V'.AND.IVALUE(J4).EQ.ICOLL)GOTO2405
37825      GOTO2400
37826 2405 CONTINUE
37827      IUSE(J4)='V'
37828      IVALUE(J4)=ICOLL
37829      VALUE(J4)=ICOLL
37830      IN(J4)=NINEW
37831 2400 CONTINUE
37832C
37833      IF(IPRINT.EQ.'OFF')GOTO2459
37834      IF(IFEEDB.EQ.'OFF')GOTO2459
37835      WRITE(ICOUT,999)
37836      CALL DPWRST('XXX','BUG ')
37837      WRITE(ICOUT,2411)ILEFT,ILEFT2,NNUM
37838 2411 FORMAT('THE NUMBER OF VALUES GENERATED FOR ',
37839     1'THE VARIABLE ',A4,A4,' = ',I8)
37840      CALL DPWRST('XXX','BUG ')
37841C
37842      WRITE(ICOUT,999)
37843      CALL DPWRST('XXX','BUG ')
37844      IJ=MAXN*(ICOLL-1)+IROW1
37845      IF(ICOLL.LE.MAXCOL)THEN
37846         WRITE(ICOUT,2421)ILEFT,ILEFT2,V(IJ),IROW1
37847 2421    FORMAT('THE FIRST           COMPUTED VALUE OF ',
37848     1   A4,A4,' = ',E15.7,'   (ROW ',I6,')')
37849         CALL DPWRST('XXX','BUG ')
37850      ELSE IF(ICOLL.EQ.MAXCP1)THEN
37851         WRITE(ICOUT,2421)ILEFT,ILEFT2,PRED(IROW1),IROW1
37852         CALL DPWRST('XXX','BUG ')
37853      ELSE IF(ICOLL.EQ.MAXCP2)THEN
37854         WRITE(ICOUT,2421)ILEFT,ILEFT2,RES(IROW1),IROW1
37855         CALL DPWRST('XXX','BUG ')
37856      ELSE IF(ICOLL.EQ.MAXCP3)THEN
37857         WRITE(ICOUT,2421)ILEFT,ILEFT2,YPLOT(IROW1),IROW1
37858         CALL DPWRST('XXX','BUG ')
37859      ELSE IF(ICOLL.EQ.MAXCP4)THEN
37860         WRITE(ICOUT,2421)ILEFT,ILEFT2,XPLOT(IROW1),IROW1
37861         CALL DPWRST('XXX','BUG ')
37862      ELSE IF(ICOLL.EQ.MAXCP5)THEN
37863         WRITE(ICOUT,2421)ILEFT,ILEFT2,X2PLOT(IROW1),IROW1
37864         CALL DPWRST('XXX','BUG ')
37865      ELSE IF(ICOLL.EQ.MAXCP6)THEN
37866         WRITE(ICOUT,2421)ILEFT,ILEFT2,TAGPLO(IROW1),IROW1
37867         CALL DPWRST('XXX','BUG ')
37868      ENDIF
37869C
37870      IJ=MAXN*(ICOLL-1)+IROWN
37871      IF(ICOLL.LE.MAXCOL.AND.
37872     1NNUM.NE.1)WRITE(ICOUT,2431)NNUM,ILEFT,ILEFT2,V(IJ),IROWN
37873 2431 FORMAT('THE LAST (',I5,'-TH) COMPUTED VALUE OF ',A4,A4,
37874     1' = ',E15.7,'   (ROW ',I6,')')
37875      IF(ICOLL.LE.MAXCOL.AND.
37876     1NNUM.NE.1)CALL DPWRST('XXX','BUG ')
37877      IF(ICOLL.EQ.MAXCP1.AND.
37878     1NNUM.NE.1)WRITE(ICOUT,2431)NNUM,ILEFT,ILEFT2,PRED(IROWN),IROWN
37879      IF(ICOLL.EQ.MAXCP1.AND.
37880     1NNUM.NE.1)CALL DPWRST('XXX','BUG ')
37881      IF(ICOLL.EQ.MAXCP2.AND.
37882     1NNUM.NE.1)WRITE(ICOUT,2431)NNUM,ILEFT,ILEFT2,RES(IROWN),IROWN
37883      IF(ICOLL.EQ.MAXCP2.AND.
37884     1NNUM.NE.1)CALL DPWRST('XXX','BUG ')
37885      IF(ICOLL.EQ.MAXCP3.AND.
37886     1NNUM.NE.1)WRITE(ICOUT,2431)NNUM,ILEFT,ILEFT2,YPLOT(IROWN),IROWN
37887      IF(ICOLL.EQ.MAXCP3.AND.
37888     1NNUM.NE.1)CALL DPWRST('XXX','BUG ')
37889      IF(ICOLL.EQ.MAXCP4.AND.
37890     1NNUM.NE.1)WRITE(ICOUT,2431)NNUM,ILEFT,ILEFT2,XPLOT(IROWN),IROWN
37891      IF(ICOLL.EQ.MAXCP4.AND.
37892     1NNUM.NE.1)CALL DPWRST('XXX','BUG ')
37893      IF(ICOLL.EQ.MAXCP5.AND.
37894     1NNUM.NE.1)WRITE(ICOUT,2431)NNUM,ILEFT,ILEFT2,X2PLOT(IROWN),IROWN
37895      IF(ICOLL.EQ.MAXCP5.AND.
37896     1NNUM.NE.1)CALL DPWRST('XXX','BUG ')
37897      IF(ICOLL.EQ.MAXCP6.AND.
37898     1NNUM.NE.1)WRITE(ICOUT,2431)NNUM,ILEFT,ILEFT2,TAGPLO(IROWN),IROWN
37899      IF(ICOLL.EQ.MAXCP6.AND.
37900     1NNUM.NE.1)CALL DPWRST('XXX','BUG ')
37901      IF(NNUM.NE.1)GOTO2449
37902      WRITE(ICOUT,2441)
37903 2441 FORMAT('SINCE THE GENERATED SAMPLE SIZE WAS ONLY 1,')
37904      CALL DPWRST('XXX','BUG ')
37905      WRITE(ICOUT,2442)
37906 2442 FORMAT('THE ABOVE VALUE WAS THE SOLE VALUE COMPUTED.')
37907      CALL DPWRST('XXX','BUG ')
37908 2449 CONTINUE
37909C
37910      WRITE(ICOUT,999)
37911      CALL DPWRST('XXX','BUG ')
37912      WRITE(ICOUT,2451)ILEFT,ILEFT2,ICOLL
37913 2451 FORMAT('THE CURRENT COLUMN FOR ',
37914     1'THE VARIABLE ',A4,A4,' = ',I8)
37915      CALL DPWRST('XXX','BUG ')
37916      WRITE(ICOUT,2453)ILEFT,ILEFT2,NINEW
37917 2453 FORMAT('THE CURRENT LENGTH OF  ',
37918     1'THE VARIABLE ',A4,A4,' = ',I8)
37919      CALL DPWRST('XXX','BUG ')
37920      WRITE(ICOUT,999)
37921      CALL DPWRST('XXX','BUG ')
37922 2459 CONTINUE
37923C
37924C               *****************
37925C               **  STEP 90--  **
37926C               **  EXIT       **
37927C               *****************
37928C
37929 9000 CONTINUE
37930      IF(IBUGA3.EQ.'OFF')GOTO9090
37931      WRITE(ICOUT,999)
37932      CALL DPWRST('XXX','BUG ')
37933      WRITE(ICOUT,9011)
37934 9011 FORMAT('***** AT THE END       OF DPPAT--')
37935      CALL DPWRST('XXX','BUG ')
37936      WRITE(ICOUT,9012)IFOUND,IERROR
37937 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
37938      CALL DPWRST('XXX','BUG ')
37939      WRITE(ICOUT,9013)IBUGA3,IBUGQ
37940 9013 FORMAT('IBUGA3,IBUGQ = ',A4,2X,A4)
37941      CALL DPWRST('XXX','BUG ')
37942      WRITE(ICOUT,9015)MAXN,NRAWPA,NS2,NS2MOD,NNUM
37943 9015 FORMAT('MAXN,NRAWPA,NS2,NS2MOD,NNUM = ',5I8)
37944      CALL DPWRST('XXX','BUG ')
37945      WRITE(ICOUT,9016)NS,NIISUB,NNUM
37946 9016 FORMAT('NS,NIISUB,NNUM = ',I8,I8,I8)
37947      CALL DPWRST('XXX','BUG ')
37948      WRITE(ICOUT,9018)NLEFT,NRAWPA,NIISUB,IROW1,IROWN,NINEW
37949 9018 FORMAT('NLEFT,NRAWPA,NIISUB,IROW1,IROWN,NINEW = ',6I8)
37950      CALL DPWRST('XXX','BUG ')
37951      WRITE(ICOUT,9019)ILEFT,ILEFT2,NEWNAM,ICOLL,NINEW
37952 9019 FORMAT('ILEFT,ILEFT2,NEWNAM,ICOLL,NINEW = ',A4,A4,2X,A4,I8,I8)
37953      CALL DPWRST('XXX','BUG ')
37954 9090 CONTINUE
37955C
37956      RETURN
37957      END
37958      SUBROUTINE DPPATH(IHARG,IARGT,ARG,NUMARG,PDEFPT,MAXPAT,PPATTH,
37959     1IBUGP2,IFOUND,IERROR)
37960C
37961C     PURPOSE--DEFINE THE PATTERN THICKNESSES.
37962C              THESE ARE LOCATED IN THE VECTOR PPATTH(.).
37963C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
37964C                     --IARGT  (A  CHARACTER VECTOR)
37965C                     --ARG
37966C                     --NUMARG
37967C                     --PDEFPT
37968C                     --MAXPAT
37969C                     --IBUGP2 ('ON' OR 'OFF' )
37970C     OUTPUT ARGUMENTS--PPATTH (A FLOATING POINT VECTOR)
37971C                     --IFOUND ('YES' OR 'NO' )
37972C                     --IERROR ('YES' OR 'NO' )
37973C     WRITTEN BY--JAMES J. FILLIBEN
37974C                 STATISTICAL ENGINEERING DIVISION
37975C                 INFORMATION TECHNOLOGY LABORATORY
37976C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
37977C                 GAITHERSBURG, MD 20899-8980
37978C                 PHONE--301-975-2899
37979C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
37980C           OF THE NATIONAL BUREAU OF STANDARDS.
37981C     LANGUAGE--ANSI FORTRAN (1977)
37982C     VERSION NUMBER--82/7
37983C     ORIGINAL VERSION--DECEMBER  1983.
37984C
37985C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
37986C
37987      CHARACTER*4 IHARG
37988      CHARACTER*4 IARGT
37989C
37990      CHARACTER*4 IBUGP2
37991      CHARACTER*4 IFOUND
37992      CHARACTER*4 IERROR
37993C
37994      CHARACTER*4 IHOLD1
37995C
37996      CHARACTER*4 ISUBN1
37997      CHARACTER*4 ISUBN2
37998      CHARACTER*4 ISTEPN
37999C
38000      DIMENSION IHARG(*)
38001      DIMENSION IARGT(*)
38002      DIMENSION ARG(*)
38003      DIMENSION PPATTH(*)
38004C
38005C---------------------------------------------------------------------
38006C
38007      INCLUDE 'DPCOP2.INC'
38008C
38009C-----START POINT-----------------------------------------------------
38010C
38011      ISUBN1='DPPA'
38012      ISUBN2='TH  '
38013      IFOUND='NO'
38014      IERROR='NO'
38015C
38016      NUMPAT=0
38017      IHOLD1='-999'
38018      HOLD1=-999.0
38019      HOLD2=-999.0
38020C
38021      IF(IBUGP2.EQ.'OFF')GOTO90
38022      WRITE(ICOUT,999)
38023  999 FORMAT(1X)
38024      CALL DPWRST('XXX','BUG ')
38025      WRITE(ICOUT,51)
38026   51 FORMAT('***** AT THE BEGINNING OF DPPATH--')
38027      CALL DPWRST('XXX','BUG ')
38028      WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR
38029   52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
38030      CALL DPWRST('XXX','BUG ')
38031      WRITE(ICOUT,53)MAXPAT,NUMPAT
38032   53 FORMAT('MAXPAT,NUMPAT = ',I8,I8)
38033      CALL DPWRST('XXX','BUG ')
38034      WRITE(ICOUT,54)IHOLD1,HOLD1,HOLD2
38035   54 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7)
38036      CALL DPWRST('XXX','BUG ')
38037      WRITE(ICOUT,55)PDEFPT
38038   55 FORMAT('PDEFPT = ',E15.7)
38039      CALL DPWRST('XXX','BUG ')
38040      WRITE(ICOUT,60)NUMARG
38041   60 FORMAT('NUMARG = ',I8)
38042      CALL DPWRST('XXX','BUG ')
38043      DO65I=1,NUMARG
38044      WRITE(ICOUT,66)IHARG(I),IARGT(I),ARG(I)
38045   66 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8)
38046      CALL DPWRST('XXX','BUG ')
38047   65 CONTINUE
38048      WRITE(ICOUT,70)PPATTH(1)
38049   70 FORMAT('PPATTH(1) = ',E15.7)
38050      CALL DPWRST('XXX','BUG ')
38051      DO75I=1,10
38052      WRITE(ICOUT,76)I,PPATTH(I)
38053   76 FORMAT('I,PPATTH(I) = ',I8,2X,E15.7)
38054      CALL DPWRST('XXX','BUG ')
38055   75 CONTINUE
38056   90 CONTINUE
38057C
38058C               **************************************
38059C               **  STEP 1--                        **
38060C               **  BRANCH TO THE APPROPRIATE CASE  **
38061C               **************************************
38062C
38063      ISTEPN='1'
38064      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
38065C
38066      IF(NUMARG.LE.0)GOTO9000
38067      IF(NUMARG.EQ.1)GOTO1110
38068      IF(NUMARG.EQ.2)GOTO1120
38069      IF(NUMARG.EQ.3)GOTO1130
38070      GOTO1140
38071C
38072 1110 CONTINUE
38073      GOTO1200
38074C
38075 1120 CONTINUE
38076      IF(IHARG(2).EQ.'ALL')IHOLD1='    '
38077      IF(IHARG(2).EQ.'ALL')HOLD1=PDEFPT
38078      IF(IHARG(2).EQ.'ALL')GOTO1300
38079      GOTO1200
38080C
38081 1130 CONTINUE
38082      IF(IHARG(2).EQ.'ALL')IHOLD1=IHARG(3)
38083      IF(IHARG(2).EQ.'ALL')HOLD1=ARG(3)
38084      IF(IHARG(2).EQ.'ALL')GOTO1300
38085      IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(2)
38086      IF(IHARG(3).EQ.'ALL')HOLD1=ARG(2)
38087      IF(IHARG(3).EQ.'ALL')GOTO1300
38088      GOTO1200
38089C
38090 1140 CONTINUE
38091      GOTO1200
38092C
38093C               *************************************************
38094C               **  STEP 2--                                   **
38095C               **  TREAT THE INDIVIDUAL SPECIFICATIONS CASE  **
38096C               *************************************************
38097C
38098 1200 CONTINUE
38099      ISTEPN='2'
38100      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
38101C
38102      IF(NUMARG.LE.1)GOTO1210
38103      GOTO1220
38104C
38105 1210 CONTINUE
38106      NUMPAT=1
38107      PPATTH(1)=PDEFPT
38108      GOTO1270
38109C
38110 1220 CONTINUE
38111      NUMPAT=NUMARG-1
38112      IF(NUMPAT.GT.MAXPAT)NUMPAT=MAXPAT
38113      DO1225I=1,NUMPAT
38114      J=I+1
38115      IHOLD1=IHARG(J)
38116      HOLD1=ARG(J)
38117      HOLD2=HOLD1
38118      IF(IHOLD1.EQ.'ON')HOLD2=PDEFPT
38119      IF(IHOLD1.EQ.'OFF')HOLD2=PDEFPT
38120      IF(IHOLD1.EQ.'AUTO')HOLD2=PDEFPT
38121      IF(IHOLD1.EQ.'DEFA')HOLD2=PDEFPT
38122      PPATTH(I)=HOLD2
38123 1225 CONTINUE
38124      GOTO1270
38125C
38126 1270 CONTINUE
38127      IF(IFEEDB.EQ.'OFF')GOTO1279
38128      WRITE(ICOUT,999)
38129      CALL DPWRST('XXX','BUG ')
38130      DO1278I=1,NUMPAT
38131      WRITE(ICOUT,1276)I,PPATTH(I)
38132 1276 FORMAT('PATTERN THICKNESS ',I6,' HAS JUST BEEN SET TO ',
38133     1E15.7)
38134      CALL DPWRST('XXX','BUG ')
38135 1278 CONTINUE
38136 1279 CONTINUE
38137      IFOUND='YES'
38138      GOTO9000
38139C
38140C               **************************
38141C               **  STEP 2--            **
38142C               **  TREAT THE ALL CASE  **
38143C               **************************
38144C
38145 1300 CONTINUE
38146      ISTEPN='3'
38147      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
38148C
38149      NUMPAT=MAXPAT
38150      HOLD2=HOLD1
38151      IF(IHOLD1.EQ.'ON')HOLD2=PDEFPT
38152      IF(IHOLD1.EQ.'OFF')HOLD2=PDEFPT
38153      IF(IHOLD1.EQ.'AUTO')HOLD2=PDEFPT
38154      IF(IHOLD1.EQ.'DEFA')HOLD2=PDEFPT
38155      DO1315I=1,NUMPAT
38156      PPATTH(I)=HOLD2
38157 1315 CONTINUE
38158      GOTO1370
38159C
38160 1370 CONTINUE
38161      IF(IFEEDB.EQ.'OFF')GOTO1319
38162      WRITE(ICOUT,999)
38163      CALL DPWRST('XXX','BUG ')
38164      I=1
38165      WRITE(ICOUT,1316)PPATTH(I)
38166 1316 FORMAT('ALL PATTERN THICKNESSES HAVE JUST BEEN SET TO ',
38167     1A4)
38168      CALL DPWRST('XXX','BUG ')
38169 1319 CONTINUE
38170      IFOUND='YES'
38171      GOTO9000
38172C
38173C               *****************
38174C               **  STEP 90--  **
38175C               **  EXIT       **
38176C               *****************
38177C
38178 9000 CONTINUE
38179      IF(IBUGP2.EQ.'OFF')GOTO9090
38180      WRITE(ICOUT,9011)
38181 9011 FORMAT('***** AT THE END       OF DPPATH--')
38182      CALL DPWRST('XXX','BUG ')
38183      WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR
38184 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
38185      CALL DPWRST('XXX','BUG ')
38186      WRITE(ICOUT,9013)MAXPAT,NUMPAT
38187 9013 FORMAT('MAXPAT,NUMPAT = ',I8,I8)
38188      CALL DPWRST('XXX','BUG ')
38189      WRITE(ICOUT,9014)IHOLD1,HOLD1,HOLD2
38190 9014 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7)
38191      CALL DPWRST('XXX','BUG ')
38192      WRITE(ICOUT,9015)PDEFPT
38193 9015 FORMAT('PDEFPT = ',E15.7)
38194      CALL DPWRST('XXX','BUG ')
38195      WRITE(ICOUT,9020)NUMARG
38196 9020 FORMAT('NUMARG = ',I8)
38197      CALL DPWRST('XXX','BUG ')
38198      DO9025I=1,NUMARG
38199      WRITE(ICOUT,9026)IHARG(I),IARGT(I),ARG(I)
38200 9026 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8)
38201      CALL DPWRST('XXX','BUG ')
38202 9025 CONTINUE
38203      WRITE(ICOUT,9030)PPATTH(1)
38204 9030 FORMAT('PPATTH(1) = ',E15.7)
38205      CALL DPWRST('XXX','BUG ')
38206      DO9035I=1,10
38207      WRITE(ICOUT,9036)I,PPATTH(I)
38208 9036 FORMAT('I,PPATTH(I) = ',I8,2X,E15.7)
38209      CALL DPWRST('XXX','BUG ')
38210 9035 CONTINUE
38211 9090 CONTINUE
38212C
38213      RETURN
38214      END
38215      SUBROUTINE DPPATT(IHARG,NUMARG,
38216     1IDEFPA,
38217     1ITEXPA,
38218     1IBUGD2,ISUBRO,IFOUND,IERROR)
38219C
38220C     PURPOSE--DEFINE THE PATTERN FOR THE LINES
38221C              IN TEXT AND FIGURES.
38222C              THE PATTERN WILL BE PLACED
38223C              IN THE CHARACTER VARIABLE ITEXPA.
38224C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
38225C                     --NUMARG
38226C                     --IDEFPA
38227C     OUTPUT ARGUMENTS--ITEXPA
38228C                     --IBUGD2
38229C                     --IFOUND ('YES' OR 'NO' )
38230C                     --IERROR ('YES' OR 'NO' )
38231C     WRITTEN BY--JAMES J. FILLIBEN
38232C                 STATISTICAL ENGINEERING DIVISION
38233C                 INFORMATION TECHNOLOGY LABORATORY
38234C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
38235C                 GAITHERSBURG, MD 20899-8980
38236C                 PHONE--301-975-2899
38237C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
38238C           OF THE NATIONAL BUREAU OF STANDARDS.
38239C     LANGUAGE--ANSI FORTRAN (1977)
38240C     VERSION NUMBER--82/7
38241C     ORIGINAL VERSION--DECEMBER  1982.
38242C
38243C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
38244C
38245      CHARACTER*4 IHARG
38246      CHARACTER*4 IDEFPA
38247      CHARACTER*4 ITEXPA
38248      CHARACTER*4 IBUGD2
38249      CHARACTER*4 ISUBRO
38250      CHARACTER*4 IFOUND
38251      CHARACTER*4 IERROR
38252C
38253C---------------------------------------------------------------------
38254C
38255      DIMENSION IHARG(*)
38256C
38257C---------------------------------------------------------------------
38258C
38259      INCLUDE 'DPCOP2.INC'
38260C
38261C-----START POINT-----------------------------------------------------
38262C
38263      IFOUND='NO'
38264      IERROR='NO'
38265C
38266      IF(IBUGD2.EQ.'OFF')GOTO90
38267      WRITE(ICOUT,999)
38268  999 FORMAT(1X)
38269      CALL DPWRST('XXX','BUG ')
38270      WRITE(ICOUT,51)
38271   51 FORMAT('***** AT THE BEGINNING OF DPPATT--')
38272      CALL DPWRST('XXX','BUG ')
38273      WRITE(ICOUT,53)IDEFPA
38274   53 FORMAT('IDEFPA = ',A4)
38275      CALL DPWRST('XXX','BUG ')
38276      WRITE(ICOUT,54)NUMARG
38277   54 FORMAT('NUMARG = ',I8)
38278      CALL DPWRST('XXX','BUG ')
38279      DO55I=1,NUMARG
38280      WRITE(ICOUT,56)I,IHARG(I)
38281   56 FORMAT('I,IHARG(I) = ',I8,2X,A4)
38282      CALL DPWRST('XXX','BUG ')
38283   55 CONTINUE
38284   90 CONTINUE
38285C
38286      IF(NUMARG.EQ.0)GOTO1140
38287      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
38288      IF(IHARG(NUMARG).EQ.'OFF')GOTO1140
38289      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1160
38290      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1160
38291      GOTO1170
38292C
38293 1140 CONTINUE
38294      ITEXPA='    '
38295      GOTO1180
38296C
38297 1150 CONTINUE
38298      ITEXPA='SOLI'
38299      GOTO1180
38300C
38301 1160 CONTINUE
38302      ITEXPA=IDEFPA
38303      GOTO1180
38304C
38305 1170 CONTINUE
38306      ITEXPA=IHARG(NUMARG)
38307      GOTO1180
38308C
38309 1180 CONTINUE
38310      IFOUND='YES'
38311C
38312      IF(IFEEDB.EQ.'OFF')GOTO1189
38313      WRITE(ICOUT,999)
38314      CALL DPWRST('XXX','BUG ')
38315      WRITE(ICOUT,1181)
38316 1181 FORMAT('THE PATTERN (FOR LINES IN TEXT AND FIGURES)')
38317      CALL DPWRST('XXX','BUG ')
38318      WRITE(ICOUT,1182)ITEXPA
38319 1182 FORMAT('HAS JUST BEEN SET TO ',A4)
38320      CALL DPWRST('XXX','BUG ')
38321 1189 CONTINUE
38322      GOTO9000
38323C
38324 9000 CONTINUE
38325      IF(IBUGD2.EQ.'OFF')GOTO9090
38326      WRITE(ICOUT,999)
38327      CALL DPWRST('XXX','BUG ')
38328      WRITE(ICOUT,9011)
38329 9011 FORMAT('***** AT THE END       OF DPPATT--')
38330      CALL DPWRST('XXX','BUG ')
38331      WRITE(ICOUT,9012)IBUGD2,ISUBRO,IFOUND,IERROR
38332 9012 FORMAT('IBUGD2,ISUBRO,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
38333      CALL DPWRST('XXX','BUG ')
38334      WRITE(ICOUT,9013)IDEFPA,ITEXPA
38335 9013 FORMAT('IDEFPA,ITEXPA = ',A4,2X,A4)
38336      CALL DPWRST('XXX','BUG ')
38337 9090 CONTINUE
38338C
38339      RETURN
38340      END
38341      SUBROUTINE DPPAUS(IBUGS2,IFOUND,IERROR)
38342C
38343C     PURPOSE--READ A LINE FROM THE TERMINAL
38344C              (THIS HAS THE NET EFFECT OF CAUSING
38345C              A PROGRAM TO PAUSE UNTIL THIS JUNK LINE IS READ).
38346C
38347C     WRITTEN BY--JAMES J. FILLIBEN
38348C                 STATISTICAL ENGINEERING DIVISION
38349C                 INFORMATION TECHNOLOGY LABORATORY
38350C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
38351C                 GAITHERSBURG, MD 20899-8980
38352C                 PHONE--301-975-2899
38353C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
38354C           OF THE NATIONAL BUREAU OF STANDARDS.
38355C     LANGUAGE--ANSI FORTRAN (1977)
38356C     VERSION NUMBER--83.6
38357C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY       1983.
38358C     UPDATED         --MAY       2008. IGNORE PAUSE WHEN RUNNING
38359C                                       THE GUI
38360C
38361C-----NON-COMMON VARIABLES------------------------------------------------------
38362C
38363      CHARACTER*4 IBUGS2
38364      CHARACTER*4 IFOUND
38365      CHARACTER*4 IERROR
38366C
38367      CHARACTER*1 IJUNK
38368C
38369C-----COMMON VARIABLES (GENERAL)-----------------------------------------
38370C
38371      INCLUDE 'DPCOST.INC'
38372      INCLUDE 'DPCOP2.INC'
38373C
38374C-----START POINT-----------------------------------------------------
38375C
38376      IFOUND='YES'
38377      IERROR='NO'
38378C
38379      IF(IBUGS2.EQ.'ON')THEN
38380        WRITE(ICOUT,999)
38381  999   FORMAT(1X)
38382        CALL DPWRST('XXX','BUG ')
38383        WRITE(ICOUT,51)
38384   51   FORMAT('***** AT THE BEGINNING OF DPPAUS--')
38385        CALL DPWRST('XXX','BUG ')
38386        WRITE(ICOUT,52)IBUGS2,IFOUND,IERROR,IRD
38387   52   FORMAT('IBUGS2,IFOUND,IERROR,IRD = ',3(A4,2X),I8)
38388        CALL DPWRST('XXX','BUG ')
38389      ENDIF
38390C
38391C               **********************************************
38392C               **  STEP 1--                                **
38393C               **   READ IN A JUNK LINE FROM THE TERMINAL  **
38394C               **********************************************
38395C
38396      IF(IGUIFL.EQ.'ON')THEN
38397        WRITE(ICOUT,999)
38398        CALL DPWRST('XXX','BUG ')
38399        WRITE(ICOUT,111)
38400  111   FORMAT('***** PAUSE COMMAND WILL BE IGNORED WHEN THE ',
38401     1         'WHEN RUNNING THE DATAPLOT GUI.')
38402        CALL DPWRST('XXX','BUG ')
38403      ELSE
38404        READ(IRD,1105)IJUNK
38405 1105   FORMAT(A1)
38406      ENDIF
38407C
38408C               *****************
38409C               **  STEP 90--  **
38410C               **  EXIT       **
38411C               *****************
38412C
38413      IF(IBUGS2.EQ.'ON')THEN
38414        WRITE(ICOUT,999)
38415        CALL DPWRST('XXX','BUG ')
38416        WRITE(ICOUT,9011)
38417 9011   FORMAT('***** AT THE END       OF DPPAUS--')
38418        CALL DPWRST('XXX','BUG ')
38419        WRITE(ICOUT,9012)IBUGS2,IFOUND,IERROR
38420 9012   FORMAT('IBUGS2,IFOUND,IERROR = ',2(A4,2X),A4)
38421        CALL DPWRST('XXX','BUG ')
38422      ENDIF
38423C
38424      RETURN
38425      END
38426      SUBROUTINE DPPAWI(IHARG,IARGT,ARG,NUMARG,PDEFPW,MAXPAT,PPATWI,
38427     1IBUGP2,IFOUND,IERROR)
38428C
38429C     PURPOSE--DEFINE THE PATTERN WIDTHS.
38430C              THESE ARE LOCATED IN THE VECTOR PPATWI(.).
38431C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
38432C                     --IARGT  (A  CHARACTER VECTOR)
38433C                     --ARG
38434C                     --NUMARG
38435C                     --PDEFPW
38436C                     --MAXPAT
38437C                     --IBUGP2 ('ON' OR 'OFF' )
38438C     OUTPUT ARGUMENTS--PPATWI (A FLOATING POINT VECTOR)
38439C                     --IFOUND ('YES' OR 'NO' )
38440C                     --IERROR ('YES' OR 'NO' )
38441C     WRITTEN BY--JAMES J. FILLIBEN
38442C                 STATISTICAL ENGINEERING DIVISION
38443C                 INFORMATION TECHNOLOGY LABORATORY
38444C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
38445C                 GAITHERSBURG, MD 20899-8980
38446C                 PHONE--301-975-2899
38447C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
38448C           OF THE NATIONAL BUREAU OF STANDARDS.
38449C     LANGUAGE--ANSI FORTRAN (1977)
38450C     VERSION NUMBER--82/7
38451C     ORIGINAL VERSION--DECEMBER  1983.
38452C
38453C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
38454C
38455      CHARACTER*4 IHARG
38456      CHARACTER*4 IARGT
38457C
38458      CHARACTER*4 IBUGP2
38459      CHARACTER*4 IFOUND
38460      CHARACTER*4 IERROR
38461C
38462      CHARACTER*4 IHOLD1
38463C
38464      CHARACTER*4 ISUBN1
38465      CHARACTER*4 ISUBN2
38466      CHARACTER*4 ISTEPN
38467C
38468      DIMENSION IHARG(*)
38469      DIMENSION IARGT(*)
38470      DIMENSION ARG(*)
38471      DIMENSION PPATWI(*)
38472C
38473C---------------------------------------------------------------------
38474C
38475      INCLUDE 'DPCOP2.INC'
38476C
38477C-----START POINT-----------------------------------------------------
38478C
38479      IFOUND='NO'
38480      IERROR='NO'
38481      ISUBN1='DPPA'
38482      ISUBN2='WI  '
38483C
38484      NUMPAT=0
38485      IHOLD1='-999'
38486      HOLD1=-999.0
38487      HOLD2=-999.0
38488C
38489      IF(IBUGP2.EQ.'OFF')GOTO90
38490      WRITE(ICOUT,999)
38491  999 FORMAT(1X)
38492      CALL DPWRST('XXX','BUG ')
38493      WRITE(ICOUT,51)
38494   51 FORMAT('***** AT THE BEGINNING OF DPPAWI--')
38495      CALL DPWRST('XXX','BUG ')
38496      WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR
38497   52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
38498      CALL DPWRST('XXX','BUG ')
38499      WRITE(ICOUT,53)MAXPAT,NUMPAT
38500   53 FORMAT('MAXPAT,NUMPAT = ',I8,I8)
38501      CALL DPWRST('XXX','BUG ')
38502      WRITE(ICOUT,54)IHOLD1,HOLD1,HOLD2
38503   54 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7)
38504      CALL DPWRST('XXX','BUG ')
38505      WRITE(ICOUT,55)PDEFPW
38506   55 FORMAT('PDEFPW = ',E15.7)
38507      CALL DPWRST('XXX','BUG ')
38508      WRITE(ICOUT,60)NUMARG
38509   60 FORMAT('NUMARG = ',I8)
38510      CALL DPWRST('XXX','BUG ')
38511      DO65I=1,NUMARG
38512      WRITE(ICOUT,66)IHARG(I),IARGT(I),ARG(I)
38513   66 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8)
38514      CALL DPWRST('XXX','BUG ')
38515   65 CONTINUE
38516      WRITE(ICOUT,70)PPATWI(1)
38517   70 FORMAT('PPATWI(1) = ',E15.7)
38518      CALL DPWRST('XXX','BUG ')
38519      DO75I=1,10
38520      WRITE(ICOUT,76)I,PPATWI(I)
38521   76 FORMAT('I,PPATWI(I) = ',I8,2X,E15.7)
38522      CALL DPWRST('XXX','BUG ')
38523   75 CONTINUE
38524   90 CONTINUE
38525C
38526C               **************************************
38527C               **  STEP 1--                        **
38528C               **  BRANCH TO THE APPROPRIATE CASE  **
38529C               **************************************
38530C
38531      ISTEPN='1'
38532      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
38533C
38534      IF(NUMARG.LE.0)GOTO9000
38535      IF(NUMARG.EQ.1)GOTO1110
38536      IF(NUMARG.EQ.2)GOTO1120
38537      IF(NUMARG.EQ.3)GOTO1130
38538      GOTO1140
38539C
38540 1110 CONTINUE
38541      GOTO1200
38542C
38543 1120 CONTINUE
38544      IF(IHARG(2).EQ.'ALL')IHOLD1='    '
38545      IF(IHARG(2).EQ.'ALL')HOLD1=PDEFPW
38546      IF(IHARG(2).EQ.'ALL')GOTO1300
38547      GOTO1200
38548C
38549 1130 CONTINUE
38550      IF(IHARG(2).EQ.'ALL')IHOLD1=IHARG(3)
38551      IF(IHARG(2).EQ.'ALL')HOLD1=ARG(3)
38552      IF(IHARG(2).EQ.'ALL')GOTO1300
38553      IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(2)
38554      IF(IHARG(3).EQ.'ALL')HOLD1=ARG(2)
38555      IF(IHARG(3).EQ.'ALL')GOTO1300
38556      GOTO1200
38557C
38558 1140 CONTINUE
38559      GOTO1200
38560C
38561C               *************************************************
38562C               **  STEP 2--                                   **
38563C               **  TREAT THE INDIVIDUAL SPECIFICATIONS CASE  **
38564C               *************************************************
38565C
38566 1200 CONTINUE
38567      ISTEPN='2'
38568      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
38569C
38570      IF(NUMARG.LE.1)GOTO1210
38571      GOTO1220
38572C
38573 1210 CONTINUE
38574      NUMPAT=1
38575      PPATWI(1)=PDEFPW
38576      GOTO1270
38577C
38578 1220 CONTINUE
38579      NUMPAT=NUMARG-1
38580      IF(NUMPAT.GT.MAXPAT)NUMPAT=MAXPAT
38581      DO1225I=1,NUMPAT
38582      J=I+1
38583      IHOLD1=IHARG(J)
38584      HOLD1=ARG(J)
38585      HOLD2=HOLD1
38586      IF(IHOLD1.EQ.'ON')HOLD2=PDEFPW
38587      IF(IHOLD1.EQ.'OFF')HOLD2=PDEFPW
38588      IF(IHOLD1.EQ.'AUTO')HOLD2=PDEFPW
38589      IF(IHOLD1.EQ.'DEFA')HOLD2=PDEFPW
38590      PPATWI(I)=HOLD2
38591 1225 CONTINUE
38592      GOTO1270
38593C
38594 1270 CONTINUE
38595      IF(IFEEDB.EQ.'OFF')GOTO1279
38596      WRITE(ICOUT,999)
38597      CALL DPWRST('XXX','BUG ')
38598      DO1278I=1,NUMPAT
38599      WRITE(ICOUT,1276)I,PPATWI(I)
38600 1276 FORMAT('PATTERN WIDTH ',I6,' HAS JUST BEEN SET TO ',
38601     1E15.7)
38602      CALL DPWRST('XXX','BUG ')
38603 1278 CONTINUE
38604 1279 CONTINUE
38605      IFOUND='YES'
38606      GOTO9000
38607C
38608C               **************************
38609C               **  STEP 2--            **
38610C               **  TREAT THE ALL CASE  **
38611C               **************************
38612C
38613 1300 CONTINUE
38614      ISTEPN='3'
38615      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
38616C
38617      NUMPAT=MAXPAT
38618      HOLD2=HOLD1
38619      IF(IHOLD1.EQ.'ON')HOLD2=PDEFPW
38620      IF(IHOLD1.EQ.'OFF')HOLD2=PDEFPW
38621      IF(IHOLD1.EQ.'AUTO')HOLD2=PDEFPW
38622      IF(IHOLD1.EQ.'DEFA')HOLD2=PDEFPW
38623      DO1315I=1,NUMPAT
38624      PPATWI(I)=HOLD2
38625 1315 CONTINUE
38626      GOTO1370
38627C
38628 1370 CONTINUE
38629      IF(IFEEDB.EQ.'OFF')GOTO1319
38630      WRITE(ICOUT,999)
38631      CALL DPWRST('XXX','BUG ')
38632      I=1
38633      WRITE(ICOUT,1316)PPATWI(I)
38634 1316 FORMAT('ALL PATTERN WIDTHS HAVE JUST BEEN SET TO ',
38635     1A4)
38636      CALL DPWRST('XXX','BUG ')
38637 1319 CONTINUE
38638      IFOUND='YES'
38639      GOTO9000
38640C
38641C               *****************
38642C               **  STEP 90--  **
38643C               **  EXIT       **
38644C               *****************
38645C
38646 9000 CONTINUE
38647      IF(IBUGP2.EQ.'OFF')GOTO9090
38648      WRITE(ICOUT,9011)
38649 9011 FORMAT('***** AT THE END       OF DPPAWI--')
38650      CALL DPWRST('XXX','BUG ')
38651      WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR
38652 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
38653      CALL DPWRST('XXX','BUG ')
38654      WRITE(ICOUT,9013)MAXPAT,NUMPAT
38655 9013 FORMAT('MAXPAT,NUMPAT = ',I8,I8)
38656      CALL DPWRST('XXX','BUG ')
38657      WRITE(ICOUT,9014)IHOLD1,HOLD1,HOLD2
38658 9014 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7)
38659      CALL DPWRST('XXX','BUG ')
38660      WRITE(ICOUT,9015)PDEFPW
38661 9015 FORMAT('PDEFPW = ',E15.7)
38662      CALL DPWRST('XXX','BUG ')
38663      WRITE(ICOUT,9020)NUMARG
38664 9020 FORMAT('NUMARG = ',I8)
38665      CALL DPWRST('XXX','BUG ')
38666      DO9025I=1,NUMARG
38667      WRITE(ICOUT,9026)IHARG(I),IARGT(I),ARG(I)
38668 9026 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8)
38669      CALL DPWRST('XXX','BUG ')
38670 9025 CONTINUE
38671      WRITE(ICOUT,9030)PPATWI(1)
38672 9030 FORMAT('PPATWI(1) = ',E15.7)
38673      CALL DPWRST('XXX','BUG ')
38674      DO9035I=1,10
38675      WRITE(ICOUT,9036)I,PPATWI(I)
38676 9036 FORMAT('I,PPATWI(I) = ',I8,2X,E15.7)
38677      CALL DPWRST('XXX','BUG ')
38678 9035 CONTINUE
38679 9090 CONTINUE
38680C
38681      RETURN
38682      END
38683      SUBROUTINE DPPCPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
38684     1                  IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
38685C
38686C     PURPOSE--GENERATE A PARALLEL COORDINATES PLOT--
38687C              A PARALLEL COORDINATES PLOT DOES THE FOLLOWING:
38688C              1) STANDARDIZE ALL VARIABLES
38689C              2) FOR P VARIABLES AND N POINTS, LET X(I,J) = THE
38690C                 STANDARDIZED VALUE OF OBSERVATION (ROW) I AND
38691C                 VARIABLE (COLUMN) J.
38692C              3) GENERATE THE FOLLOWING PLOT COORDINATES:
38693C                    (X(I-1,K-1), K-1) - (X(I,K),K) FOR I = 2, ..., N
38694C                                                   FOR K = 2, ..., P
38695C     WRITTEN BY--ALAN HECKERT
38696C                 INFORMATION TECHNOLOGY LABORATORY
38697C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
38698C                 GAITHERSBURG, MD 20899-8980
38699C                 PHONE--301-975-2899
38700C     REFERENCE--ED WEGMAN, xxxxx
38701C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
38702C           OF THE NATIONAL BUREAU OF STANDARDS.
38703C     LANGUAGE--ANSI FORTRAN (1977)
38704C     VERSION NUMBER--2003/3
38705C     ORIGINAL VERSION--MARCH     2003.
38706C     UPDATED         --MAY       2003. GROUP PARALLEL COORDINATES
38707C                                       PLOT
38708C     UPDATED         --JANUARY   2007. CALL LIST TO CODE
38709C     UPDATED         --FEBRUARY  2011. USE DPPARS AND DPPAR3
38710C     UPDATED         --JULY      2019. TWEAK SCRATCH SPACE
38711C
38712C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
38713C
38714      CHARACTER*4 ICASPL
38715      CHARACTER*4 IAND1
38716      CHARACTER*4 IAND2
38717      CHARACTER*4 IBUGG2
38718      CHARACTER*4 IBUGG3
38719      CHARACTER*4 IBUGQ
38720      CHARACTER*4 ISUBRO
38721      CHARACTER*4 IFOUND
38722      CHARACTER*4 IERROR
38723C
38724      CHARACTER*4 ISUBN1
38725      CHARACTER*4 ISUBN2
38726      CHARACTER*4 ISTEPN
38727C
38728      CHARACTER*40 INAME
38729C
38730C---------------------------------------------------------------------
38731C
38732      INCLUDE 'DPCOPA.INC'
38733C
38734C  MAXPCC IS THE MAXIMUM NUMBER OF VARIABLES TO USE IN CREATING THE
38735C  PARALLEL COORDINATES PLOT
38736C
38737      PARAMETER(MAXPCC=30)
38738C
38739      CHARACTER*4 ICASE
38740      CHARACTER*4 IVARN1(MAXPCC)
38741      CHARACTER*4 IVARN2(MAXPCC)
38742      CHARACTER*4 IVARTY(MAXPCC)
38743      DIMENSION PVAR(MAXPCC)
38744      DIMENSION ILIS(MAXPCC)
38745      DIMENSION NRIGHT(MAXPCC)
38746      DIMENSION ICOLR(MAXPCC)
38747C
38748      DIMENSION Z(MAXOBV,MAXPCC)
38749      DIMENSION TEMP(MAXOBV)
38750      DIMENSION TEMP2(MAXOBV)
38751      DIMENSION XIDTEM(MAXOBV)
38752      INCLUDE 'DPCOZZ.INC'
38753      EQUIVALENCE (GARBAG(IGARB1),TEMP(1))
38754      EQUIVALENCE (GARBAG(IGARB2),XIDTEM(1))
38755      EQUIVALENCE (GARBAG(IGARB3),TEMP2(1))
38756      EQUIVALENCE (GARBAG(IGARB4),Z(1,1))
38757C
38758C-----COMMON----------------------------------------------------------
38759C
38760      INCLUDE 'DPCOHK.INC'
38761      INCLUDE 'DPCODA.INC'
38762      INCLUDE 'DPCOST.INC'
38763      INCLUDE 'DPCOP2.INC'
38764C
38765C-----START POINT-----------------------------------------------------
38766C
38767      IERROR='NO'
38768      IFOUND='NO'
38769      ISUBN1='DPPC'
38770      ISUBN2='PL  '
38771C
38772      MAXCP1=MAXCOL+1
38773      MAXCP2=MAXCOL+2
38774      MAXCP3=MAXCOL+3
38775      MAXCP4=MAXCOL+4
38776      MAXCP5=MAXCOL+5
38777      MAXCP6=MAXCOL+6
38778C
38779C               ************************************************
38780C               **  TREAT THE PARALLEL COORDINATES PLOT CASE  **
38781C               ************************************************
38782C
38783      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PCPL')THEN
38784        WRITE(ICOUT,999)
38785  999   FORMAT(1X)
38786        CALL DPWRST('XXX','BUG ')
38787        WRITE(ICOUT,51)
38788   51   FORMAT('***** AT THE BEGINNING OF DPPCPL--')
38789        CALL DPWRST('XXX','BUG ')
38790        WRITE(ICOUT,52)IBUGG2,IBUGG3,IBUGQ,ISUBRO
38791   52   FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',3(A4,2X),A4)
38792        CALL DPWRST('XXX','BUG ')
38793        WRITE(ICOUT,53)ICASPL,IAND1,IAND2
38794   53   FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4)
38795        CALL DPWRST('XXX','BUG ')
38796      ENDIF
38797C
38798C               ***************************
38799C               **  STEP 1--             **
38800C               **  EXTRACT THE COMMAND  **
38801C               ***************************
38802C
38803      ISTEPN='11'
38804      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PCPL')
38805     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
38806C
38807      ICASPL='PCPL'
38808C
38809      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'COOR'.AND.IHARG(2).EQ.'PLOT')THEN
38810        ILASTC=2
38811        ICASPL='PCPL'
38812      ELSEIF(NUMARG.GE.3.AND.IHARG(1).EQ.'PARA'.AND.
38813     1  IHARG(2).EQ.'COOR'.AND.IHARG(3).EQ.'PLOT')THEN
38814        ILASTC=3
38815        ICASPL='PCPG'
38816      ELSE
38817        GOTO9000
38818      ENDIF
38819C
38820      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
38821      IFOUND='YES'
38822C
38823C               *********************************
38824C               **  STEP 2--                   **
38825C               **  EXTRACT THE VARIABLE LIST  **
38826C               *********************************
38827C
38828      INAME='PARALLEL COORDINATES PLOT'
38829      MINNA=1
38830      MAXNA=100
38831      MINN2=2
38832      IFLAGE=1
38833      IFLAGM=1
38834      IFLAGP=0
38835      JMIN=1
38836      JMAX=NUMARG
38837C
38838      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
38839     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
38840     1            JMIN,JMAX,
38841     1            MINN2,MINNA,MAXNA,MAXAND,IFLAGE,INAME,
38842     1            IVARN1,IVARN2,IVARTY,PVAR,
38843     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
38844     1            MINNA,MAXPCC,
38845     1            IFLAGM,IFLAGP,
38846     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
38847      IF(IERROR.EQ.'YES')GOTO9000
38848C
38849C               ***************************************************
38850C               **  STEP 3--                                     **
38851C               **  FOR EACH OF THE RESPONSE VARIABLES, EXTRACT  **
38852C               **  THE DATA SUBSET.                             **
38853C               ***************************************************
38854C
38855      ISTEPN='3'
38856      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PCPL')
38857     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
38858C
38859      DO300K=1,NUMVAR
38860C
38861        ICOL=K
38862        NUMVA2=1
38863        IF(ICASPL.EQ.'PCPG'.AND.K.EQ.NUMVAR)THEN
38864          CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
38865     1                INAME,IVARN1,IVARN2,IVARTY,
38866     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
38867     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
38868     1                MAXCP4,MAXCP5,MAXCP6,
38869     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
38870     1                XIDTEM,TEMP2,TEMP2,NLOCAL,NLOCA2,NLOCA3,ICASE,
38871     1                IBUGG3,ISUBRO,IFOUND,IERROR)
38872        ELSE
38873          CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
38874     1                INAME,IVARN1,IVARN2,IVARTY,
38875     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
38876     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
38877     1                MAXCP4,MAXCP5,MAXCP6,
38878     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
38879     1                Z(1,K),TEMP2,TEMP2,NLOCAL,NLOCA2,NLOCA3,ICASE,
38880     1                IBUGG3,ISUBRO,IFOUND,IERROR)
38881        ENDIF
38882C
38883        IF(K.EQ.1)THEN
38884          NSAVE=NLOCAL
38885        ELSE
38886          IF(NLOCAL.NE.NSAVE)THEN
38887            WRITE(ICOUT,301)
38888  301       FORMAT('****** ERROR IN PARALLEL COORDINATES PLOT--')
38889            CALL DPWRST('XXX','BUG ')
38890            WRITE(ICOUT,303)IVARN1(K),IVARN2(K)
38891  303       FORMAT('       VARIABLE ',A4,A4,' DOES NOT HAVE THE ',
38892     1             'EXPECTED NUMBER OF OBSERVATIONS.')
38893            CALL DPWRST('XXX','BUG ')
38894            WRITE(ICOUT,305)NLOCAL
38895  305       FORMAT('       NUMBER OF OBSERVATIONS          = ',I8)
38896            CALL DPWRST('XXX','BUG ')
38897            WRITE(ICOUT,307)NSAVE
38898  307       FORMAT('       NUMBER OF OBSERVATIONS EXPECTED = ',I8)
38899            CALL DPWRST('XXX','BUG ')
38900            IERROR='YES'
38901            GOTO9000
38902          ENDIF
38903        ENDIF
38904C
38905  300 CONTINUE
38906      NZ=NUMVAR
38907      IF(ICASPL.EQ.'PCPG')NZ=NZ-1
38908C
38909C               *******************************************************
38910C               **  STEP 31--                                        **
38911C               **  FORM THE VERTICAL AND HORIZONTAL AXIS            **
38912C               **  VALUES Y(.) AND X(.) FOR THE PLOT.               **
38913C               **  DEFINE THE VECTOR D(.) SO THAT EACH ANDREW'S     **
38914C               **  CURVE HAS ITS OWNS TAG NUMBER.                   **
38915C               **  DEFINE THE NUMBER OF PLOT POINTS    (NPLOTP).    **
38916C               **  DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV).    **
38917C               *******************************************************
38918C
38919      ISTEPN='8'
38920      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PCPL')
38921     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
38922C
38923      CALL DPPCP2(Z,NZ,XIDTEM,TEMP,TEMP2,DFILL,ICASPL,IPCCST,
38924     1            NLOCAL,MAXOBV,MAXPCC,MAXPOP,
38925     1            Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR)
38926C
38927C               *****************
38928C               **  STEP 90--  **
38929C               **  EXIT       **
38930C               *****************
38931C
38932 9000 CONTINUE
38933      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PCPL')THEN
38934        WRITE(ICOUT,999)
38935        CALL DPWRST('XXX','BUG ')
38936        WRITE(ICOUT,9011)
38937 9011   FORMAT('***** AT THE END       OF DPPCPL--')
38938        CALL DPWRST('XXX','BUG ')
38939        WRITE(ICOUT,9013)IFOUND,IERROR
38940 9013   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
38941        CALL DPWRST('XXX','BUG ')
38942        WRITE(ICOUT,9014)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
38943 9014   FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',
38944     1         3I8,2X,2(A4,2X),A4)
38945        CALL DPWRST('XXX','BUG ')
38946        WRITE(ICOUT,9021)NZ
38947 9021   FORMAT('NZ = ',I8)
38948        CALL DPWRST('XXX','BUG ')
38949        IF(NPLOTP.GE.1)THEN
38950          DO9052I=1,NPLOTP
38951            WRITE(ICOUT,9053)I,Y(I),X(I),D(I)
38952 9053       FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5)
38953            CALL DPWRST('XXX','BUG ')
38954 9052     CONTINUE
38955        ENDIF
38956      ENDIF
38957C
38958      RETURN
38959      END
38960      SUBROUTINE DPPCP2(Z,NZ,XIDTEM,TEMP,TEMP2,DFILL,ICASPL,IPCCST,
38961     1NOBS,MAXOBV,MAXPCC,MAXPOP,
38962     1Y2,X2,D2,N2,NPLOTV,IBUGG3,ISUBRO,IERROR)
38963C
38964C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
38965C              THAT WILL DEFINE
38966C              A ANDREWS PLOT
38967C              (USEFUL FOR MULTIVARIATE ANALYSIS).
38968C     WRITTEN BY--ALAN HECKERT
38969C                 INFORMATION TECHNOLOGY LABORATORY
38970C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
38971C                 GAITHERSBURG, MD 20899-8980
38972C                 PHONE--301-975-2899
38973C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
38974C           OF THE NATIONAL BUREAU OF STANDARDS.
38975C     LANGUAGE--ANSI FORTRAN (1977)
38976C     VERSION NUMBER--2003/3
38977C     ORIGINAL VERSION--MARCH     2003.
38978C     UPDATED         --MAY       2003. SUPPORT FOR "GROUP" CASE
38979C     UPDATED         --JANUARY   2007. CALL LIST TO CODE
38980C
38981C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
38982C
38983      CHARACTER*4 ICASPL
38984      CHARACTER*4 IPCCST
38985      CHARACTER*4 IBUGG3
38986      CHARACTER*4 ISUBRO
38987      CHARACTER*4 IERROR
38988C
38989      CHARACTER*4 IWRITE
38990      CHARACTER*4 ISUBN1
38991      CHARACTER*4 ISUBN2
38992C
38993C---------------------------------------------------------------------
38994C
38995      DIMENSION Z(MAXOBV,MAXPCC)
38996C
38997      DIMENSION XIDTEM(*)
38998      DIMENSION TEMP(*)
38999      DIMENSION TEMP2(*)
39000      DIMENSION DFILL(*)
39001C
39002      DIMENSION Y2(*)
39003      DIMENSION X2(*)
39004      DIMENSION D2(*)
39005C
39006C---------------------------------------------------------------------
39007C
39008      INCLUDE 'DPCOP2.INC'
39009C
39010C-----START POINT-----------------------------------------------------
39011C
39012      ISUBN1='DPPC'
39013      ISUBN2='P2  '
39014      IERROR='NO'
39015C
39016C               ********************************************
39017C               **  STEP 1--                              **
39018C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
39019C               ********************************************
39020C
39021      IF(NOBS.LT.1)THEN
39022        WRITE(ICOUT,999)
39023  999   FORMAT(1X)
39024        CALL DPWRST('XXX','BUG ')
39025        WRITE(ICOUT,31)
39026   31   FORMAT('***** ERROR IN PARALLEL COORDINATES PLOT--')
39027        CALL DPWRST('XXX','BUG ')
39028        WRITE(ICOUT,32)
39029   32   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 1;')
39030        CALL DPWRST('XXX','BUG ')
39031        WRITE(ICOUT,34)NZ
39032   34   FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6)
39033        CALL DPWRST('XXX','BUG ')
39034        WRITE(ICOUT,999)
39035        CALL DPWRST('XXX','BUG ')
39036        IERROR='YES'
39037        GOTO9000
39038      ENDIF
39039C
39040      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PCP2')THEN
39041        WRITE(ICOUT,999)
39042        CALL DPWRST('XXX','BUG ')
39043        WRITE(ICOUT,71)
39044   71   FORMAT('***** AT THE BEGINNING OF DPPCP2--')
39045        CALL DPWRST('XXX','BUG ')
39046        WRITE(ICOUT,72)ICASPL,NZ,NOBS,NPLOTV
39047   72   FORMAT('ICASPL,NZ,NOBS,NPLOTV = ',A4,2X,3I8)
39048        CALL DPWRST('XXX','BUG ')
39049        IF(NZ.GT.0)THEN
39050          DO81I=1,NZ
39051            WRITE(ICOUT,82)I,(Z(I,K),K=1,NZ)
39052   82       FORMAT('I,Z(I,K) = ',I8,20E12.5)
39053            CALL DPWRST('XXX','BUG ')
39054   81     CONTINUE
39055        ENDIF
39056      ENDIF
39057C
39058C               ****************************************
39059C               **  STEP 11--                         **
39060C               **  DETERMINE PLOT COORDINATES        **
39061C               ****************************************
39062C
39063      IWRITE='OFF'
39064C
39065      IF(ICASPL.EQ.'PCPG')THEN
39066        CALL CODE(XIDTEM,NOBS,IWRITE,TEMP,TEMP2,MAXOBV,IBUGG3,IERROR)
39067        DO110I=1,NOBS
39068          XIDTEM(I)=TEMP(I)
39069  110   CONTINUE
39070      ENDIF
39071C
39072      DO200J=1,NZ
39073        IF(IPCCST.EQ.'ZSCO')THEN
39074          DO210I=1,NOBS
39075            TEMP(I)=Z(I,J)
39076  210     CONTINUE
39077          CALL MEAN(TEMP,NOBS,IWRITE,XMEAN,IBUGG3,IERROR)
39078          CALL SD(TEMP,NOBS,IWRITE,XSD,IBUGG3,IERROR)
39079          DO220I=1,NOBS
39080            Z(I,J)=0.0
39081            IF(XSD.GT.0.0)Z(I,J)=(TEMP(I)-XMEAN)/XSD
39082  220     CONTINUE
39083        ELSEIF(IPCCST.EQ.'USCO')THEN
39084          DO310I=1,NOBS
39085            TEMP(I)=Z(I,J)
39086  310     CONTINUE
39087          CALL MINIM(TEMP,NOBS,IWRITE,XMIN,IBUGG3,IERROR)
39088          CALL RANGDP(TEMP,NOBS,IWRITE,XRANGE,IBUGG3,IERROR)
39089          DO320I=1,NOBS
39090            Z(I,J)=0.0
39091            IF(XRANGE.GT.0.0)Z(I,J)=(TEMP(I)-XMIN)/XRANGE
39092  320     CONTINUE
39093        ENDIF
39094  200 CONTINUE
39095C
39096      ICOUNT=0
39097      DO600ICASE=1,NOBS
39098C
39099        IF(ICOUNT.GT.MAXPOP-2)THEN
39100          WRITE(ICOUT,601)
39101 601      FORMAT('****** ERROR IN PARALLEL COORDINATES PLOT.')
39102          CALL DPWRST('XXX','BUG ')
39103          WRITE(ICOUT,602)
39104 602      FORMAT('       MAXIMUM NUMBER OF PLOT POINTS EXCEEDED.')
39105          CALL DPWRST('XXX','BUG ')
39106          IERROR='YES'
39107          GOTO9000
39108        ENDIF
39109C
39110        DO700J=2,NZ
39111          XCOOR1=Z(ICASE,J-1)
39112          XCOOR2=Z(ICASE,J)
39113          YCOOR1=REAL(J-1) - 1.0
39114          YCOOR2=YCOOR1+1.0
39115          ICOUNT=ICOUNT+1
39116C
39117          X2(ICOUNT)=XCOOR1
39118          Y2(ICOUNT)=YCOOR1
39119          D2(ICOUNT)=REAL(ICASE)
39120          DFILL(ICOUNT)=XIDTEM(ICASE)
39121C
39122          ICOUNT=ICOUNT+1
39123          X2(ICOUNT)=XCOOR2
39124          Y2(ICOUNT)=YCOOR2
39125          D2(ICOUNT)=REAL(ICASE)
39126          DFILL(ICOUNT)=XIDTEM(ICASE)
39127  700   CONTINUE
39128  600 CONTINUE
39129C
39130      N2=ICOUNT
39131      NPLOTV=2
39132      GOTO9000
39133C
39134C               *****************
39135C               **  STEP 90--  **
39136C               **  EXIT       **
39137C               *****************
39138C
39139 9000 CONTINUE
39140      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PCP2')THEN
39141        WRITE(ICOUT,999)
39142        CALL DPWRST('XXX','BUG ')
39143        WRITE(ICOUT,9011)
39144 9011   FORMAT('***** AT THE END       OF DPPCP2--')
39145        CALL DPWRST('XXX','BUG ')
39146        WRITE(ICOUT,9012)ICASPL,NZ,N2,IERROR
39147 9012   FORMAT('ICASPL,NZ,N2,IERROR = ',A4,2I8,2X,A4)
39148        CALL DPWRST('XXX','BUG ')
39149        WRITE(ICOUT,9031)N2,NPLOTV
39150 9031   FORMAT('N2,NPLOTV = ',2I8)
39151        CALL DPWRST('XXX','BUG ')
39152        DO9035I=1,N2
39153          WRITE(ICOUT,9036)I,Y2(I),X2(I),D2(I)
39154 9036     FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2)
39155          CALL DPWRST('XXX','BUG ')
39156 9035   CONTINUE
39157      ENDIF
39158C
39159      RETURN
39160      END
39161      SUBROUTINE DPPCTY(IHARG,NUMARG,
39162     1IDEFPT,
39163     1IPCMTY,
39164     1IBUGS2,IFOUND,IERROR)
39165C
39166C     PURPOSE--DEFINE THE PRINCIPLE COMPONENT TYPE
39167C              CAN BE:
39168C                   DATA         COVARIANCE   (DACV)
39169C                   DATA         CORRELATION  (DACR)
39170C                   COVARIANCE   COVARIANCE   (CVCV)
39171C                   COVARIANCE   CORRELATION  (CVCR)
39172C                   CORRELATION  COVARIANCE   (CRCV)
39173C                   CORRELATION  CORRELATION  (CRCR)
39174C              THIS SWITCH CONTROLS HOW THE PRINCIPLE COMPONENTS ARE
39175C              COMPUTED.
39176C
39177C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
39178C                     --NUMARG (AN INTEGER VARIABLE)
39179C                     --IDEFPT (A  CHARACTER VARIABLE)
39180C                     --IBUGS2 (A  CHARACTER VARIABLE)
39181C     OUTPUT ARGUMENTS--IPCMTY (A CHARACTER VARIABLE)
39182C                     --IFOUND ('YES' OR 'NO' )
39183C                     --IERROR ('YES' OR 'NO' )
39184C     WRITTEN BY--JAMES J. FILLIBEN
39185C                 STATISTICAL ENGINEERING DIVISION
39186C                 INFORMATION TECHNOLOGY LABORATORY
39187C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
39188C                 GAITHERSBURG, MD 20899-8980
39189C                 PHONE--301-975-2855
39190C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
39191C           OF THE NATIONAL BUREAU OF STANDARDS.
39192C     LANGUAGE--ANSI FORTRAN (1977)
39193C     VERSION NUMBER--93/7
39194C     ORIGINAL VERSION--JULY     1993.
39195C
39196C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
39197C
39198      CHARACTER*4 IHARG
39199      CHARACTER*4 IDEFPT
39200      CHARACTER*4 IPCMTY
39201      CHARACTER*4 IBUGS2
39202      CHARACTER*4 IFOUND
39203      CHARACTER*4 IERROR
39204C
39205      CHARACTER*4 IHOLD
39206C
39207C---------------------------------------------------------------------
39208C
39209      DIMENSION IHARG(*)
39210C
39211C---------------------------------------------------------------------
39212C
39213      INCLUDE 'DPCOP2.INC'
39214C
39215C-----START POINT-----------------------------------------------------
39216C
39217      IF(IBUGS2.EQ.'OFF')GOTO90
39218      WRITE(ICOUT,999)
39219  999 FORMAT(1X)
39220      CALL DPWRST('XXX','BUG ')
39221      WRITE(ICOUT,51)
39222   51 FORMAT('***** AT THE BEGINNING OF DPPCTY--')
39223      CALL DPWRST('XXX','BUG ')
39224      WRITE(ICOUT,53)IDEFPT
39225   53 FORMAT('IDEFPT = ',A4)
39226      CALL DPWRST('XXX','BUG ')
39227      WRITE(ICOUT,54)NUMARG
39228   54 FORMAT('NUMARG = ',I8)
39229      CALL DPWRST('XXX','BUG ')
39230      DO55I=1,NUMARG
39231      WRITE(ICOUT,56)I,IHARG(I)
39232   56 FORMAT('I,IHARG(I) = ',I8,2X,A4)
39233      CALL DPWRST('XXX','BUG ')
39234   55 CONTINUE
39235   90 CONTINUE
39236C
39237      IFOUND='NO'
39238      IERROR='NO'
39239C
39240      IF(NUMARG.LE.2)GOTO1150
39241      IF(NUMARG.EQ.3)GOTO1120
39242      IF(NUMARG.EQ.4)GOTO1110
39243      IF(NUMARG.GT.4)GOTO9000
39244C
39245 1110 CONTINUE
39246      IF(IHARG(3).EQ.'DATA'.AND.IHARG(4).EQ.'COVA')THEN
39247        IHOLD='DACV'
39248      ELSEIF(IHARG(3).EQ.'DATA'.AND.IHARG(4).EQ.'CORR')THEN
39249        IHOLD='DACR'
39250      ELSEIF(IHARG(3).EQ.'CORR'.AND.IHARG(4).EQ.'CORR')THEN
39251        IHOLD='CRCR'
39252      ELSEIF(IHARG(3).EQ.'CORR'.AND.IHARG(4).EQ.'COVA')THEN
39253        IHOLD='CRCV'
39254      ELSEIF(IHARG(3).EQ.'COVA'.AND.IHARG(4).EQ.'COVA')THEN
39255        IHOLD='CVCV'
39256      ELSEIF(IHARG(3).EQ.'COVA'.AND.IHARG(4).EQ.'CORR')THEN
39257        IHOLD='CVCR'
39258      ELSE
39259        IERROR='YES'
39260        IFOUND='YES'
39261        WRITE(ICOUT,1111)IHARG(3),IHARG(4)
39262 1111   FORMAT('THE PRINCIPLE COMPONENT TYPE ',A4,A4,
39263     1  ' IS NOT RECOGNIZED')
39264        CALL DPWRST('XXX','BUG ')
39265        GOTO9000
39266      ENDIF
39267      GOTO1180
39268C
39269 1120 CONTINUE
39270      IF(IHARG(2).EQ.'AUTO')GOTO1150
39271      IF(IHARG(2).EQ.'DEFA')GOTO1150
39272      GOTO1160
39273C
39274 1150 CONTINUE
39275      IHOLD=IDEFPT
39276      GOTO1180
39277C
39278 1160 CONTINUE
39279      IHOLD=IHARG(3)
39280      IF(IHOLD.EQ.'DACV')GOTO1180
39281      IF(IHOLD.EQ.'DACR')GOTO1180
39282      IF(IHOLD.EQ.'CRCR')GOTO1180
39283      IF(IHOLD.EQ.'CRCV')GOTO1180
39284      IF(IHOLD.EQ.'CVCV')GOTO1180
39285      IF(IHOLD.EQ.'CVCR')GOTO1180
39286      GOTO1170
39287C
39288 1170 CONTINUE
39289      IERROR='YES'
39290      IFOUND='YES'
39291      WRITE(ICOUT,1171)IHOLD
39292 1171 FORMAT('THE PRINCIPLE COMPONENT TYPE SWITCH ',A4,
39293     1' IS NOT RECOGNIZED')
39294      CALL DPWRST('XXX','BUG ')
39295      GOTO9000
39296C
39297 1180 CONTINUE
39298      IFOUND='YES'
39299      IPCMTY=IHOLD
39300C
39301      IF(IFEEDB.EQ.'OFF')GOTO1189
39302      WRITE(ICOUT,999)
39303      CALL DPWRST('XXX','BUG ')
39304      WRITE(ICOUT,1181)IPCMTY
39305 1181 FORMAT(
39306     1'THE PRINCIPLE COMPONENT TYPE SWITCH HAS JUST BEEN SET TO ',A4)
39307      CALL DPWRST('XXX','BUG ')
39308 1189 CONTINUE
39309      GOTO9000
39310C
39311 9000 CONTINUE
39312      IF(IBUGS2.EQ.'OFF')GOTO9090
39313      WRITE(ICOUT,999)
39314      CALL DPWRST('XXX','BUG ')
39315      WRITE(ICOUT,9011)
39316 9011 FORMAT('***** AT THE END       OF DPPCTY')
39317      CALL DPWRST('XXX','BUG ')
39318      WRITE(ICOUT,9012)IBUGS2,IFOUND,IERROR
39319 9012 FORMAT('IBUGS2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
39320      CALL DPWRST('XXX','BUG ')
39321      WRITE(ICOUT,9013)IDEFPT,IPCMTY
39322 9013 FORMAT('IDEFPT,IPCMTY = ',A4,2X,A4)
39323      CALL DPWRST('XXX','BUG ')
39324 9090 CONTINUE
39325C
39326      RETURN
39327      END
39328      SUBROUTINE DPPDF1(Y,Y2,N,ICASPL,
39329     1                  SHAPE1,SHAPE2,SHAPE3,SHAPE4,
39330     1                  SHAPE5,SHAPE6,SHAPE7,
39331     1                  YLOWLM,YUPPLM,A,B,MINMAX,
39332     1                  ICAPSW,ICAPTY,
39333     1                  IADEDF,IGEPDF,IMAKDF,IBEIDF,
39334     1                  ILGADF,ISKNDF,IGLDDF,IBGEDF,
39335     1                  IGETDF,ICONDF,IGOMDF,IKATDF,
39336     1                  IGIGDF,IGEODF,
39337     1                  KSLOC,KSSCAL,
39338     1                  IBUGA3,ISUBRO,IERROR)
39339C
39340C     PURPOSE--COMPUTE THE PDF VALUE AT GIVEN SET OF POINTS.  THIS
39341C              CAN BE USED TO COMPUTE THE LOG-LIKEIHOOD FUNCTION:
39342C
39343C                 LOG-LIKE = SUM[i=1 to n][LOG(f(x(i);theta)]
39344C
39345C              WITH theta DENOTING THE PARAMETERS FOR THE
39346C              DISTRIBUTION.  THE VALUE OF THE LOG-LIKELIHOOD
39347C              CAN IN TURN BE USED TO COMPUTE THE AIC, AICC, AND
39348C              BIC GOODNESS OF FIT STATISTICS.
39349C
39350C              THIS ROUTINE HANDLES THE UNGROUPED, UNCENSORED CASE.
39351C
39352C     WRITTEN BY--ALAN HECKERT
39353C                 STATISTICAL ENGINEERING DIVISION
39354C                 INFORMATION TECHNOLOGY LABORATORY
39355C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
39356C                 GAITHERSBURG, MD 20899-8980
39357C                 PHONE--301-975-2899
39358C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
39359C           OF THE NATIONAL BUREAU OF STANDARDS.
39360C     LANGUAGE--ANSI FORTRAN (1977)
39361C     VERSION NUMBER--2009/9
39362C     ORIGINAL VERSION--SEPTEMBER 2009.
39363C     UPDATED         --JULY      2010. END EFFECTS WEIBULL
39364C     UPDATED         --AUGUST    2010. BRITTLE FIBER WEIBULL
39365C     UPDATED         --JANUARY   2013. ONLY REQUIRE SINGLE OBSERVATION
39366C     UPDATED         --JANUARY   2013. CHECK FOR OUT OF RANGE DATA,
39367C                                       SET TO CPUMIN IF FOUND
39368C     UPDATED         --MARCH     2013. SINE
39369C
39370C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
39371C
39372      CHARACTER*4 ICASPL
39373      CHARACTER*4 IBUGA3
39374      CHARACTER*4 ISUBRO
39375      CHARACTER*4 IWRITE
39376      CHARACTER*4 IADEDF
39377      CHARACTER*4 IGEPDF
39378      CHARACTER*4 IMAKDF
39379      CHARACTER*4 IBEIDF
39380      CHARACTER*4 ILGADF
39381      CHARACTER*4 ISKNDF
39382      CHARACTER*4 IGLDDF
39383      CHARACTER*4 IBGEDF
39384      CHARACTER*4 IGETDF
39385      CHARACTER*4 ICONDF
39386      CHARACTER*4 IGOMDF
39387      CHARACTER*4 IKATDF
39388      CHARACTER*4 IGIGDF
39389      CHARACTER*4 IGEODF
39390      CHARACTER*4 ICAPSW
39391      CHARACTER*4 ICAPTY
39392      CHARACTER*4 IERROR
39393C
39394      CHARACTER*4 ISUBN1
39395      CHARACTER*4 ISUBN2
39396C
39397      REAL KSLOC
39398      REAL KSLOCT
39399      REAL KSSCAL
39400      REAL KSLOC2
39401      REAL KSSCA2
39402C
39403      DOUBLE PRECISION LANPDF
39404      DOUBLE PRECISION DPDF
39405      DOUBLE PRECISION DXOUT
39406      DOUBLE PRECISION DXOUT1
39407      DOUBLE PRECISION DXOUT2
39408      DOUBLE PRECISION DTERM1
39409      DOUBLE PRECISION DTERM2
39410      DOUBLE PRECISION PDFWAK
39411      DOUBLE PRECISION XPAR(5)
39412C
39413C---------------------------------------------------------------------
39414C
39415      DIMENSION Y(*)
39416      DIMENSION Y2(*)
39417C
39418C---------------------------------------------------------------------
39419C
39420      INCLUDE 'DPCOP2.INC'
39421C
39422C-----START POINT-----------------------------------------------------
39423C
39424      DATA PI / 3.1415926535 /
39425C
39426      ISUBN1='DPPD'
39427      ISUBN2='F1  '
39428      IERROR='NO'
39429C
39430      IFLAGD=0
39431      KSLOC2=KSLOC
39432      KSSCA2=KSSCAL
39433      DTERM1=REAL(CPUMIN)
39434      DTERM2=REAL(CPUMIN)
39435C
39436      IF(KSLOC.EQ.CPUMIN)KSLOC=0.0
39437      IF(KSSCAL.EQ.CPUMIN)KSSCAL=1.0
39438      IWRITE='OFF'
39439      CALL MINIM(Y,N,IWRITE,XMIN,IBUGA3,IERROR)
39440      CALL MAXIM(Y,N,IWRITE,XMAX,IBUGA3,IERROR)
39441C
39442C               ********************************************
39443C               **  STEP 1--                              **
39444C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
39445C               ********************************************
39446C
39447      IF(N.LT.1)THEN
39448        WRITE(ICOUT,999)
39449  999   FORMAT(1X)
39450        CALL DPWRST('XXX','BUG ')
39451        WRITE(ICOUT,31)
39452   31   FORMAT('***** ERROR IN DPPDF1--')
39453        CALL DPWRST('XXX','BUG ')
39454        WRITE(ICOUT,32)
39455   32   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 1.')
39456        CALL DPWRST('XXX','BUG ')
39457        WRITE(ICOUT,34)N
39458   34   FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6)
39459        CALL DPWRST('XXX','BUG ')
39460        WRITE(ICOUT,999)
39461        CALL DPWRST('XXX','BUG ')
39462        IERROR='YES'
39463        GOTO9000
39464      ENDIF
39465C
39466      IF(N.EQ.1)GOTO69
39467      HOLD=Y(1)
39468      DO60I=1,N
39469        IF(Y(I).NE.HOLD)GOTO69
39470   60 CONTINUE
39471      WRITE(ICOUT,999)
39472      CALL DPWRST('XXX','BUG ')
39473      WRITE(ICOUT,31)
39474      CALL DPWRST('XXX','BUG ')
39475      WRITE(ICOUT,62)
39476   62 FORMAT('      ALL ELEMENTS IN THE RESPONSE VARIABLE ARE ',
39477     1       'IDENTICALLY EQUAL TO ',G15.7)
39478      CALL DPWRST('XXX','BUG ')
39479      WRITE(ICOUT,999)
39480      CALL DPWRST('XXX','BUG ')
39481      IERROR='YES'
39482      GOTO9000
39483C
39484   69 CONTINUE
39485C
39486      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PDF1')THEN
39487        WRITE(ICOUT,999)
39488        CALL DPWRST('XXX','BUG ')
39489        WRITE(ICOUT,71)
39490   71   FORMAT('***** AT THE BEGINNING OF DPPDF1--')
39491        CALL DPWRST('XXX','BUG ')
39492        WRITE(ICOUT,72)ICASPL,N,MINMAX,A,B
39493   72   FORMAT('ICASPL,N,MINMAX,A,B = ',A4,2X,2I8,2G15.7)
39494        CALL DPWRST('XXX','BUG ')
39495        WRITE(ICOUT,73)KSLOC,KSSCAL,SHAPE1,SHAPE2
39496   73   FORMAT('KSLOC,KSSCAL,SHAPE1,SHAPE2 = ',4G15.7)
39497        CALL DPWRST('XXX','BUG ')
39498        WRITE(ICOUT,75)ICAPSW,ICAPTY
39499   75   FORMAT('ICAPSW,ICAPTY = ',A4,2X,A4)
39500        CALL DPWRST('XXX','BUG ')
39501        DO85I=1,N
39502          WRITE(ICOUT,86)I,Y(I)
39503   86     FORMAT('I,Y(I) = ',I8,G15.7)
39504          CALL DPWRST('XXX','BUG ')
39505   85   CONTINUE
39506      ENDIF
39507C
39508C               ************************************************
39509C               **  STEP 2.1--                                **
39510C               **  COMPUTE PDF VALUE AT GIVEN POINTS         **
39511C               ************************************************
39512C
39513      ZSCALE=B - A
39514      ZLOC=A
39515C
39516C     INITIALZ
39517      DO100I=1,N
39518        Y2(I)=CPUMIN
39519  100 CONTINUE
39520C
39521      IF(ICASPL.EQ.'UNIF')THEN
39522        DO1010I=1,N
39523          XL=(Y(I) - ZLOC)/ZSCALE
39524          IF(XL.GE.0.0 .AND. XL.LE.1.0)THEN
39525            CALL UNIPDF(XL,Y2(I))
39526            Y2(I)=Y2(I)/ZSCALE
39527          ENDIF
39528 1010   CONTINUE
39529C
39530      ELSEIF(ICASPL.EQ.'NORM')THEN
39531        DO1020I=1,N
39532          XL=(Y(I) - KSLOC)/KSSCAL
39533          CALL NODPDF(DBLE(XL),DXOUT)
39534          Y2(I)=REAL(DXOUT)
39535          Y2(I)=Y2(I)/KSSCAL
39536 1020   CONTINUE
39537C
39538      ELSEIF(ICASPL.EQ.'LOGI')THEN
39539        DO1030I=1,N
39540          XL=(Y(I) - KSLOC)/KSSCAL
39541          CALL LOGPDF(XL,Y2(I))
39542          Y2(I)=Y2(I)/KSSCAL
39543 1030   CONTINUE
39544C
39545      ELSEIF(ICASPL.EQ.'DEXP')THEN
39546        DO1040I=1,N
39547          XL=(Y(I) - KSLOC)/KSSCAL
39548          CALL DEXPDF(XL,Y2(I))
39549          Y2(I)=Y2(I)/KSSCAL
39550 1040   CONTINUE
39551C
39552      ELSEIF(ICASPL.EQ.'CAUC')THEN
39553        DO1050I=1,N
39554          XL=(Y(I) - KSLOC)/KSSCAL
39555          CALL CAUPDF(XL,Y2(I))
39556          Y2(I)=Y2(I)/KSSCAL
39557 1050   CONTINUE
39558C
39559      ELSEIF(ICASPL.EQ.'TULA')THEN
39560        ZMIN=-1.0/SHAPE1
39561        ZMAX=1.0/SHAPE1
39562        DO1060I=1,N
39563          XL=(Y(I) - KSLOC)/KSSCAL
39564          IF(SHAPE1.GT.0.0 .AND. XL.LT.ZMIN)THEN
39565            Y2(I)=0.0
39566          ELSEIF(SHAPE1.GT.0.0 .AND. XL.GT.ZMAX)THEN
39567            Y2(I)=1.0
39568          ELSE
39569            CALL LAMPDF(XL,SHAPE1,Y2(I))
39570            Y2(I)=Y2(I)/KSSCAL
39571          ENDIF
39572 1060   CONTINUE
39573C
39574      ELSEIF(ICASPL.EQ.'LOGN')THEN
39575        DO1070I=1,N
39576          XL=(Y(I) - KSLOC)/KSSCAL
39577          IF(XL.GE.0.0)THEN
39578            CALL LGNPDF(XL,SHAPE1,Y2(I))
39579            Y2(I)=Y2(I)/KSSCAL
39580          ENDIF
39581 1070   CONTINUE
39582C
39583      ELSEIF(ICASPL.EQ.'HNOR' .OR. ICASPL.EQ.'1HNO')THEN
39584        KSLOCT=KSLOC
39585        IF(ICASPL.EQ.'1HNO')KSLOCT=0.0
39586        DO1080I=1,N
39587          XL=(Y(I) - KSLOCT)/KSSCAL
39588          IF(XL.GE.0.0)THEN
39589            CALL HFNPDF(XL,Y2(I))
39590            Y2(I)=Y2(I)/KSSCAL
39591          ENDIF
39592 1080   CONTINUE
39593C
39594      ELSEIF(ICASPL.EQ.'TPP')THEN
39595        DO1090I=1,N
39596          XL=(Y(I) - KSLOC)/KSSCAL
39597          CALL TPDF(XL,SHAPE1,Y2(I))
39598          Y2(I)=Y2(I)/KSSCAL
39599 1090   CONTINUE
39600C
39601      ELSEIF(ICASPL.EQ.'CHIS')THEN
39602        DO1100I=1,N
39603          XL=(Y(I) - KSLOC)/KSSCAL
39604          IF(XL.GE.0.0)THEN
39605            CALL CHSPDF(XL,INT(SHAPE1+0.1),Y2(I))
39606            Y2(I)=Y2(I)/KSSCAL
39607          ENDIF
39608 1100   CONTINUE
39609C
39610      ELSEIF(ICASPL.EQ.'FPP')THEN
39611        DO1110I=1,N
39612          XL=(Y(I) - KSLOC)/KSSCAL
39613          IF(XL.GE.0.0)THEN
39614            CALL FPDF(XL,INT(SHAPE1+0.1),INT(SHAPE2+0.1),Y2(I))
39615            Y2(I)=Y2(I)/KSSCAL
39616          ENDIF
39617 1110   CONTINUE
39618C
39619      ELSEIF(ICASPL.EQ.'EXPO')THEN
39620        DO1120I=1,N
39621          XL=(Y(I) - KSLOC)/KSSCAL
39622          IF(XL.GE.0.0)THEN
39623            CALL EXPPDF(XL,Y2(I))
39624            Y2(I)=Y2(I)/KSSCAL
39625          ENDIF
39626 1120   CONTINUE
39627C
39628      ELSEIF(ICASPL.EQ.'GAMM')THEN
39629        DO1130I=1,N
39630          XL=(Y(I) - KSLOC)/KSSCAL
39631          IF(XL.GE.0.0)THEN
39632            CALL GAMPDF(XL,SHAPE1,Y2(I))
39633            Y2(I)=Y2(I)/KSSCAL
39634          ENDIF
39635 1130   CONTINUE
39636C
39637      ELSEIF(ICASPL.EQ.'BETA' .OR. ICASPL.EQ.'4BET')THEN
39638        DO1140I=1,N
39639          XL=(Y(I) - ZLOC)/ZSCALE
39640          IF(XL.GE.0.0 .AND. XL.LE.1.0)THEN
39641            CALL BETPDF(XL,SHAPE1,SHAPE2,Y2(I))
39642            Y2(I)=Y2(I)/ZSCALE
39643          ENDIF
39644 1140   CONTINUE
39645C
39646      ELSEIF(ICASPL.EQ.'WEIB' .OR. ICASPL.EQ.'3WEI')THEN
39647        DO1150I=1,N
39648          XL=(Y(I) - KSLOC)/KSSCAL
39649          IF(MINMAX.EQ.1 .AND. XL.GE.0.0)THEN
39650            CALL WEIPDF(XL,SHAPE1,MINMAX,Y2(I))
39651            Y2(I)=Y2(I)/KSSCAL
39652          ELSEIF((MINMAX.EQ.0.OR.MINMAX.EQ.2) .AND. XL.LE.0.0)THEN
39653            CALL WEIPDF(XL,SHAPE1,MINMAX,Y2(I))
39654            Y2(I)=Y2(I)/KSSCAL
39655          ENDIF
39656 1150   CONTINUE
39657C
39658      ELSEIF(ICASPL.EQ.'EV1 ')THEN
39659        DO1160I=1,N
39660          XL=(Y(I) - KSLOC)/KSSCAL
39661          CALL EV1PDF(XL,MINMAX,Y2(I))
39662          Y2(I)=Y2(I)/KSSCAL
39663 1160   CONTINUE
39664C
39665      ELSEIF(ICASPL.EQ.'EV2 ')THEN
39666        DO1170I=1,N
39667          XL=(Y(I) - KSLOC)/KSSCAL
39668          IF((MINMAX.EQ.2.OR.MINMAX.EQ.0).AND.XL.GE.0.0)THEN
39669            CALL EV2PDF(XL,SHAPE1,MINMAX,Y2(I))
39670            Y2(I)=Y2(I)/KSSCAL
39671          ELSEIF(MINMAX.EQ.1.AND.XL.LE.0.0)THEN
39672            CALL EV2PDF(XL,SHAPE1,MINMAX,Y2(I))
39673            Y2(I)=Y2(I)/KSSCAL
39674          ENDIF
39675 1170   CONTINUE
39676C
39677      ELSEIF(ICASPL.EQ.'PARE')THEN
39678        ZLOC=SHAPE2
39679        IF(ZLOC.GT.XMIN)ZLOC=XMIN
39680        DO1180I=1,N
39681          XL=(Y(I) - KSLOC)/KSSCAL
39682          IF(XL.GT.0.0 .AND. ZLOC.GT.0.0)THEN
39683            CALL PARPDF(XL,SHAPE1,ZLOC,Y2(I))
39684            Y2(I)=Y2(I)/KSSCAL
39685          ENDIF
39686 1180   CONTINUE
39687C
39688      ELSEIF(ICASPL.EQ.'BINO')THEN
39689        IF(IFLAGD.EQ.1)GOTO8000
39690        DO1190I=1,N
39691          XL=Y(I)
39692          CALL BINPDF(DBLE(XL),DBLE(SHAPE1),INT(SHAPE2+0.1),DXOUT)
39693          Y2(I)=REAL(DXOUT)
39694 1190   CONTINUE
39695C
39696      ELSEIF(ICASPL.EQ.'GEOM')THEN
39697        IF(IFLAGD.EQ.1)GOTO8000
39698        IF(IGEODF.EQ.'DLMF')THEN
39699          DO1200I=1,N
39700            XL=Y(I)
39701            CALL GE2PDF(DBLE(XL),DBLE(SHAPE1),DXOUT)
39702            Y2(I)=REAL(DXOUT)
39703 1200     CONTINUE
39704        ELSE
39705          DO1205I=1,N
39706            XL=Y(I)
39707            CALL GEOPDF(DBLE(XL),DBLE(SHAPE1),DXOUT)
39708            Y2(I)=REAL(DXOUT)
39709 1205     CONTINUE
39710        ENDIF
39711C
39712      ELSEIF(ICASPL.EQ.'POIS')THEN
39713        IF(IFLAGD.EQ.1)GOTO8000
39714        DO1210I=1,N
39715          XL=Y(I)
39716CCCCC     CALL POIPDF(XL,SHAPE1,Y2(I))
39717 1210   CONTINUE
39718C
39719      ELSEIF(ICASPL.EQ.'NEBI')THEN
39720        IF(IFLAGD.EQ.1)GOTO8000
39721        DO1220I=1,N
39722          XL=Y(I)
39723          CALL NBPDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT)
39724          Y2(I)=REAL(DXOUT)
39725 1220   CONTINUE
39726C
39727      ELSEIF(ICASPL.EQ.'SEMI')THEN
39728        DO1230I=1,N
39729          XL=Y(I) - KSLOC
39730          IF(ABS(XL).LE.KSSCAL)THEN
39731            CALL SEMPDF(XL,KSSCAL,Y2(I))
39732          ENDIF
39733 1230   CONTINUE
39734C
39735      ELSEIF(ICASPL.EQ.'TRIA')THEN
39736        IF(A.EQ.CPUMIN .OR. B.EQ.CPUMAX)THEN
39737          ZLOWLM=-1.0
39738          ZUPPLM=1.0
39739        ELSE
39740          ZLOWLM=MIN(A,B)
39741          ZUPPLM=MAX(A,B)
39742        ENDIF
39743        IF(ZLOWLM.GT.XMIN)ZLOWLM=XMIN
39744        IF(ZUPPLM.LT.XMAX)ZUPPLM=XMAX
39745        IF(SHAPE1.LT.ZLOWLM .OR. SHAPE1.GT.ZUPPLM)THEN
39746          WRITE(ICOUT,999)
39747          CALL DPWRST('XXX','BUG ')
39748          WRITE(ICOUT,31)
39749          CALL DPWRST('XXX','BUG ')
39750          WRITE(ICOUT,1343)
39751 1343     FORMAT('       FOR THE TRIANGULAR DISTRIBUTION, THE VALUE')
39752          CALL DPWRST('XXX','BUG ')
39753          WRITE(ICOUT,1344)
39754 1344     FORMAT('       OF THE SHAPE PARAMETER IS OUTSIDE THE ',
39755     1           'INTERVAL')
39756          CALL DPWRST('XXX','BUG ')
39757          WRITE(ICOUT,1345)
39758 1345     FORMAT('       OF THE LOWER AND UPPER LIMIT PARAMETERS.')
39759          CALL DPWRST('XXX','BUG ')
39760          WRITE(ICOUT,1346)SHAPE1
39761 1346     FORMAT('       THE VALUE OF THE SHAPE PARAMETER       = ',
39762     1         G15.7)
39763          CALL DPWRST('XXX','BUG ')
39764          WRITE(ICOUT,1347)ZLOWLM
39765 1347     FORMAT('       THE VALUE OF THE LOWER LIMIT PARAMETER = ',
39766     1           G15.7)
39767          CALL DPWRST('XXX','BUG ')
39768          WRITE(ICOUT,1348)ZUPPLM
39769 1348     FORMAT('       THE VALUE OF THE LOWER LIMIT PARAMETER = ',
39770     1           G15.7)
39771          CALL DPWRST('XXX','BUG ')
39772          IERROR='YES'
39773          GOTO9000
39774        ENDIF
39775C
39776        DO1240I=1,N
39777          XL=Y(I)
39778          CALL TRIPDF(XL,SHAPE1,ZLOWLM,ZUPPLM,Y2(I))
39779 1240   CONTINUE
39780C
39781      ELSEIF(ICASPL.EQ.'INGA')THEN
39782        DO1250I=1,N
39783          XL=(Y(I) - KSLOC)/KSSCAL
39784          IF(XL.GE.0.0)THEN
39785            CALL IGPDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DPDF)
39786            Y2(I)=REAL(DPDF)/KSSCAL
39787          ENDIF
39788 1250   CONTINUE
39789C
39790      ELSEIF(ICASPL.EQ.'WALD')THEN
39791        AMU=1.0
39792        DO1260I=1,N
39793          XL=(Y(I) - KSLOC)/KSSCAL
39794          IF(XL.GE.0.0)THEN
39795            CALL IGPDF(DBLE(XL),DBLE(SHAPE1),DBLE(AMU),DPDF)
39796            Y2(I)=REAL(DPDF)/KSSCAL
39797          ENDIF
39798 1260   CONTINUE
39799C
39800      ELSEIF(ICASPL.EQ.'RIGA')THEN
39801        DO1270I=1,N
39802          XL=(Y(I) - KSLOC)/KSSCAL
39803          IF(XL.GE.0.0)THEN
39804            CALL RIGPDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DPDF)
39805            Y2(I)=REAL(DPDF)/KSSCAL
39806          ENDIF
39807 1270   CONTINUE
39808C
39809      ELSEIF(ICASPL.EQ.'FATL')THEN
39810        DO1280I=1,N
39811          XL=(Y(I) - KSLOC)/KSSCAL
39812          IF(XL.GE.0.0)THEN
39813            CALL FLPDF(XL,SHAPE1,Y2(I))
39814            Y2(I)=Y2(I)/KSSCAL
39815          ENDIF
39816 1280   CONTINUE
39817C
39818      ELSEIF(ICASPL.EQ.'GPAR')THEN
39819        DO1290I=1,N
39820          XL=(Y(I) - KSLOC)/KSSCAL
39821          CALL GEPPDF(XL,SHAPE1,MINMAX,IGEPDF,Y2(I))
39822          Y2(I)=Y2(I)/KSSCAL
39823 1290   CONTINUE
39824C
39825      ELSEIF(ICASPL.EQ.'DUNI')THEN
39826        IF(IFLAGD.EQ.1)GOTO8000
39827        DO1300I=1,N
39828          XL=Y(I)
39829          CALL DISPDF(INT(XL+0.5),INT(SHAPE1+0.1),Y2(I))
39830 1300   CONTINUE
39831C
39832      ELSEIF(ICASPL.EQ.'NCT ')THEN
39833        DO1310I=1,N
39834          XL=(Y(I) - KSLOC)/KSSCAL
39835          CALL NCTPDF(XL,SHAPE1,SHAPE2,Y2(I))
39836          Y2(I)=Y2(I)/KSSCAL
39837 1310   CONTINUE
39838C
39839      ELSEIF(ICASPL.EQ.'NCF ')THEN
39840        DO1320I=1,N
39841          XL=(Y(I) - KSLOC)/KSSCAL
39842          IF(XL.GE.0.0)THEN
39843            CALL NCFPDF(XL,SHAPE1,SHAPE2,SHAPE3,Y2(I))
39844            Y2(I)=Y2(I)/KSSCAL
39845          ENDIF
39846 1320   CONTINUE
39847C
39848      ELSEIF(ICASPL.EQ.'NCCS')THEN
39849        DO1330I=1,N
39850          XL=(Y(I) - KSLOC)/KSSCAL
39851          IF(XL.GE.0.0)THEN
39852            CALL NCCPDF(XL,SHAPE1,SHAPE2,Y2(I))
39853            Y2(I)=Y2(I)/KSSCAL
39854          ENDIF
39855 1330   CONTINUE
39856C
39857      ELSEIF(ICASPL.EQ.'NCBE')THEN
39858        DO1340I=1,N
39859          XL=(Y(I) - ZLOC)/ZSCALE
39860          IF(XL.GE.0.0 .AND. XL.LE.1.0)THEN
39861            CALL NCBPDF(XL,SHAPE1,SHAPE2,SHAPE3,Y2(I))
39862            Y2(I)=Y2(I)/ZSCALE
39863          ENDIF
39864 1340   CONTINUE
39865C
39866      ELSEIF(ICASPL.EQ.'DNCT')THEN
39867        DO1350I=1,N
39868          XL=(Y(I) - KSLOC)/KSSCAL
39869          IF(XL.GE.0.0)THEN
39870            CALL DNTPDF(XL,SHAPE1,SHAPE2,SHAPE3,Y2(I))
39871            Y2(I)=Y2(I)/KSSCAL
39872          ENDIF
39873 1350   CONTINUE
39874C
39875      ELSEIF(ICASPL.EQ.'DNCF')THEN
39876        DO1360I=1,N
39877          XL=(Y(I) - KSLOC)/KSSCAL
39878          IF(XL.GE.0.0)THEN
39879            CALL DNFPDF(XL,SHAPE1,SHAPE2,SHAPE3,SHAPE4,Y2(I))
39880            Y2(I)=Y2(I)/KSSCAL
39881          ENDIF
39882 1360   CONTINUE
39883C
39884      ELSEIF(ICASPL.EQ.'HYPG')THEN
39885        IF(IFLAGD.EQ.1)GOTO8000
39886        DO1365I=1,N
39887          XL=Y(I)
39888CCCCC     CALL HYPPDF(XL,INT(SHAPE1+0.1),INT(SHAPE2+0.1),
39889CCCCC1                INT(SHAPE3+0.1),Y2(I))
39890 1365   CONTINUE
39891C
39892      ELSEIF(ICASPL.EQ.'VONM')THEN
39893        DO1370I=1,N
39894          XL=(Y(I) - KSLOC)/KSSCAL
39895          CALL VONPDF(XL,SHAPE1,Y2(I))
39896          Y2(I)=Y2(I)/KSSCAL
39897 1370   CONTINUE
39898C
39899      ELSEIF(ICASPL.EQ.'POWN')THEN
39900        DO1380I=1,N
39901          XL=(Y(I) - KSLOC)/KSSCAL
39902          IF(XL.GE.0.0 .AND. XL.LE.1.0)THEN
39903            CALL PNRPDF(XL,SHAPE1,Y2(I))
39904            Y2(I)=Y2(I)/KSSCAL
39905          ENDIF
39906 1380   CONTINUE
39907C
39908      ELSEIF(ICASPL.EQ.'PLGN')THEN
39909        DO1390I=1,N
39910          XL=(Y(I) - KSLOC)/KSSCAL
39911          IF(XL.GE.0.0)THEN
39912            CALL PLNPDF(XL,SHAPE1,SHAPE2,Y2(I))
39913            Y2(I)=Y2(I)/KSSCAL
39914          ENDIF
39915 1390   CONTINUE
39916C
39917      ELSEIF(ICASPL.EQ.'ALPH')THEN
39918        DO1400I=1,N
39919          XL=(Y(I) - KSLOC)/KSSCAL
39920          IF(XL.GE.0.0)THEN
39921            CALL ALPPDF(DBLE(XL),DBLE(SHAPE1),DXOUT)
39922            Y2(I)=REAL(DXOUT)
39923            Y2(I)=Y2(I)/KSSCAL
39924          ENDIF
39925 1400   CONTINUE
39926C
39927      ELSEIF(ICASPL.EQ.'COSI')THEN
39928        DO1410I=1,N
39929          XL=(Y(I) - KSLOC)/KSSCAL
39930          IF(XL.GE.-PI .AND. XL.LE.PI)THEN
39931            CALL COSPDF(XL,Y2(I))
39932            Y2(I)=Y2(I)/KSSCAL
39933          ENDIF
39934 1410   CONTINUE
39935C
39936      ELSEIF(ICASPL.EQ.'SINE')THEN
39937        DO1415I=1,N
39938          XL=(Y(I) - KSLOC)/KSSCAL
39939          IF(XL.GE.-(PI/2.0) .AND. XL.LE.(PI/2.0))THEN
39940            CALL SINPDF(XL,Y2(I))
39941            Y2(I)=Y2(I)/KSSCAL
39942          ENDIF
39943 1415   CONTINUE
39944C
39945      ELSEIF(ICASPL.EQ.'POWF')THEN
39946        DO1420I=1,N
39947          XL=(Y(I) - ZLOC)/ZSCALE
39948          IF(XL.LT.0.0)XL=1.0E-12
39949          IF(XL.GE.1.0)XL=1.0 - 1.0E-12
39950          CALL POWPDF(XL,SHAPE1,Y2(I))
39951          Y2(I)=Y2(I)/ZSCALE
39952 1420   CONTINUE
39953C
39954      ELSEIF(ICASPL.EQ.'CHI ')THEN
39955        DO1430I=1,N
39956          XL=(Y(I) - KSLOC)/KSSCAL
39957          IF(XL.GE.0.0)THEN
39958            CALL CHPDF(XL,SHAPE1,Y2(I))
39959            Y2(I)=Y2(I)/KSSCAL
39960          ENDIF
39961 1430   CONTINUE
39962C
39963      ELSEIF(ICASPL.EQ.'LOGS')THEN
39964        IF(IFLAGD.EQ.1)GOTO8000
39965        DO1435I=1,N
39966          XL=Y(I)
39967          CALL DLGPDF(XL,SHAPE1,Y2(I))
39968 1435   CONTINUE
39969C
39970      ELSEIF(ICASPL.EQ.'LOGL')THEN
39971        DO1440I=1,N
39972          XL=(Y(I) - KSLOC)/KSSCAL
39973          IF(XL.GE.0.0)THEN
39974            CALL LLGPDF(XL,SHAPE1,Y2(I))
39975            Y2(I)=Y2(I)/KSSCAL
39976          ENDIF
39977 1440   CONTINUE
39978C
39979      ELSEIF(ICASPL.EQ.'GGAM')THEN
39980        DO1450I=1,N
39981          XL=(Y(I) - KSLOC)/KSSCAL
39982          IF(XL.GE.0.0)THEN
39983            CALL GGDPDF(XL,SHAPE1,SHAPE2,Y2(I))
39984            Y2(I)=Y2(I)/KSSCAL
39985          ENDIF
39986 1450   CONTINUE
39987C
39988      ELSEIF(ICASPL.EQ.'WARI')THEN
39989        IF(IFLAGD.EQ.1)GOTO8000
39990        DO1460I=1,N
39991          XL=Y(I)
39992CCCCC     CALL WARPDF(XL,SHAPE1,SHAPE2,Y2(I),'NOTR')
39993          CALL WARPDF(XL,SHAPE1,SHAPE2,Y2(I))
39994 1460   CONTINUE
39995C
39996      ELSEIF(ICASPL.EQ.'YULE')THEN
39997        IF(IFLAGD.EQ.1)GOTO8000
39998        DO1470I=1,N
39999          XL=Y(I)
40000          CALL YULPDF(XL,SHAPE1,Y2(I))
40001 1470   CONTINUE
40002C
40003      ELSEIF(ICASPL.EQ.'ANGL')THEN
40004        DO1480I=1,N
40005          XL=(Y(I) - KSLOC)/KSSCAL
40006          IF(XL.GE.-PI/4.0 .OR. XL.LE.PI/4.0)THEN
40007            CALL ANGPDF(XL,Y2(I))
40008            Y2(I)=Y2(I)/KSSCAL
40009          ENDIF
40010 1480   CONTINUE
40011C
40012      ELSEIF(ICASPL.EQ.'ARSI')THEN
40013        DO1490I=1,N
40014          XL=(Y(I) - KSLOC)/KSSCAL
40015          IF(XL.GT.0.0 .AND. XL.LT.1.0)THEN
40016            CALL ARSPDF(XL,Y2(I))
40017            Y2(I)=Y2(I)/KSSCAL
40018          ENDIF
40019 1490   CONTINUE
40020C
40021      ELSEIF(ICASPL.EQ.'FNOR')THEN
40022C
40023C       FOR FOLDED NORMAL, ARE PARAMETERS GIVEN AS
40024C       LOCATION/SCALE OR SHAPE1 AND SHAPE2?
40025C
40026        IF(SHAPE1.NE.CPUMIN .AND. SHAPE2.NE.CPUMIN)THEN
40027          AVAL1=SHAPE1
40028          AVAL2=SHAPE2
40029        ELSEIF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)THEN
40030          AVAL1=KSLOC
40031          AVAL2=KSSCAL
40032        ELSE
40033          AVAL1=0.0
40034          AVAL2=1.0
40035        ENDIF
40036C
40037        DO1500I=1,N
40038CCCCC     XL=(Y(I) - KSLOC)/KSSCAL
40039CCCCC     CALL FNRPDF(XL,SHAPE1,SHAPE2,Y2(I))
40040CCCCC     Y2(I)=Y2(I)/KSSCAL
40041          XL=Y(I)
40042          IF(XL.GE.0.0)THEN
40043            CALL FNRPDF(XL,AVAL1,AVAL2,Y2(I))
40044            Y2(I)=Y2(I)
40045          ENDIF
40046 1500   CONTINUE
40047C
40048      ELSEIF(ICASPL.EQ.'TNOR')THEN
40049        DO1510I=1,N
40050          XL=Y(I)
40051          IF(XL.GE.A .AND. XL.LE.B)THEN
40052            CALL TNRPDF(DBLE(XL),DBLE(A),DBLE(B),
40053     1                  DBLE(SHAPE1),DBLE(SHAPE2),DXOUT)
40054            Y2(I)=REAL(DXOUT)
40055            Y2(I)=Y2(I)/KSSCAL
40056          ENDIF
40057 1510   CONTINUE
40058C
40059      ELSEIF(ICASPL.EQ.'LGAM')THEN
40060        DO1520I=1,N
40061          XL=(Y(I) - KSLOC)/KSSCAL
40062          IF(XL.GE.0.0)THEN
40063            CALL LGAPDF(XL,SHAPE1,ILGADF,Y2(I))
40064            Y2(I)=Y2(I)/KSSCAL
40065          ENDIF
40066 1520   CONTINUE
40067C
40068      ELSEIF(ICASPL.EQ.'HSEC')THEN
40069        DO1530I=1,N
40070          XL=(Y(I) - KSLOC)/KSSCAL
40071          CALL HSEPDF(XL,Y2(I))
40072          Y2(I)=Y2(I)/KSSCAL
40073 1530   CONTINUE
40074C
40075      ELSEIF(ICASPL.EQ.'GOMP')THEN
40076        DO1540I=1,N
40077          XL=(Y(I) - KSLOC)/KSSCAL
40078          IF(XL.GE.0.0)THEN
40079            CALL GOMPDF(XL,SHAPE1,SHAPE2,IGOMDF,Y2(I))
40080            Y2(I)=Y2(I)/KSSCAL
40081          ENDIF
40082 1540   CONTINUE
40083C
40084      ELSEIF(ICASPL.EQ.'HCAU')THEN
40085        DO1550I=1,N
40086          XL=(Y(I) - KSLOC)/KSSCAL
40087          IF(XL.GE.0.0)THEN
40088            CALL HFCPDF(XL,Y2(I))
40089            Y2(I)=Y2(I)/KSSCAL
40090          ENDIF
40091 1550   CONTINUE
40092C
40093      ELSEIF(ICASPL.EQ.'HALO')THEN
40094        SHAPE1=-1.0
40095        DO1560I=1,N
40096          XL=(Y(I) - KSLOC)/KSSCAL
40097          IF(XL.GE.0.0)THEN
40098            CALL HFLPDF(XL,SHAPE1,Y2(I))
40099            Y2(I)=Y2(I)/KSSCAL
40100          ENDIF
40101 1560   CONTINUE
40102C
40103      ELSEIF(ICASPL.EQ.'GHLO')THEN
40104        DO1570I=1,N
40105          XL=(Y(I) - KSLOC)/KSSCAL
40106          IF(XL.GE.0.0)THEN
40107            CALL HFLPDF(XL,SHAPE1,Y2(I))
40108            Y2(I)=Y2(I)/KSSCAL
40109          ENDIF
40110 1570   CONTINUE
40111C
40112      ELSEIF(ICASPL.EQ.'GEV ')THEN
40113        DO1580I=1,N
40114          XL=(Y(I) - KSLOC)/KSSCAL
40115          CALL GEVPDF(XL,SHAPE1,MINMAX,Y2(I))
40116          Y2(I)=Y2(I)/KSSCAL
40117 1580   CONTINUE
40118C
40119      ELSEIF(ICASPL.EQ.'PAR2')THEN
40120        ZLOC=SHAPE2
40121        IF(ZLOC.GT.XMIN)ZLOC=XMIN
40122        DO1590I=1,N
40123          XL=(Y(I) - KSLOC)/KSSCAL
40124          CALL PA2PDF(XL,SHAPE1,ZLOC,Y2(I))
40125          Y2(I)=Y2(I)/KSSCAL
40126 1590   CONTINUE
40127C
40128      ELSEIF(ICASPL.EQ.'DWEI')THEN
40129        DO1600I=1,N
40130          XL=(Y(I) - KSLOC)/KSSCAL
40131          CALL DWEPDF(XL,SHAPE1,Y2(I))
40132          Y2(I)=Y2(I)/KSSCAL
40133 1600   CONTINUE
40134C
40135      ELSEIF(ICASPL.EQ.'WCAU')THEN
40136        DO1610I=1,N
40137          XL=(Y(I) - KSLOC)/KSSCAL
40138          IF(XL.GE.0.0 .AND. XL.LE.2.0*PI)THEN
40139            CALL WCAPDF(XL,SHAPE1,Y2(I))
40140            Y2(I)=Y2(I)/KSSCAL
40141          ENDIF
40142 1610   CONTINUE
40143C
40144      ELSEIF(ICASPL.EQ.'EWEI')THEN
40145        IARG1=1
40146        DO1620I=1,N
40147          XL=(Y(I) - KSLOC)/KSSCAL
40148          IF(XL.GE.0.0)THEN
40149            CALL EWEPDF(XL,SHAPE1,SHAPE2,IARG1,Y2(I))
40150            Y2(I)=Y2(I)/KSSCAL
40151          ENDIF
40152 1620   CONTINUE
40153C
40154      ELSEIF(ICASPL.EQ.'TEXP')THEN
40155        DO1630I=1,N
40156          XL=(Y(I) - KSLOC)/KSSCAL
40157          IF(XL.GE.SHAPE2 .AND. XL.LE.SHAPE3)THEN
40158            CALL TNEPDF(XL,SHAPE1,SHAPE2,SHAPE3,Y2(I))
40159            Y2(I)=Y2(I)/KSSCAL
40160          ENDIF
40161 1630   CONTINUE
40162C
40163      ELSEIF(ICASPL.EQ.'GLOG')THEN
40164        DO1640I=1,N
40165          XL=(Y(I) - KSLOC)/KSSCAL
40166          CALL GLOPDF(XL,SHAPE1,Y2(I))
40167          Y2(I)=Y2(I)/KSSCAL
40168 1640   CONTINUE
40169C
40170      ELSEIF(ICASPL.EQ.'PEXP')THEN
40171        DO1650I=1,N
40172          XL=(Y(I) - KSLOC)/KSSCAL
40173          CALL PEXPDF(DBLE(XL),DBLE(SHAPE1),DXOUT)
40174          IF(SHAPE1.GE.1.0)THEN
40175            IF(XL.GE.0.0)THEN
40176              Y2(I)=REAL(DXOUT)
40177              Y2(I)=Y2(I)/KSSCAL
40178            ENDIF
40179          ELSE
40180            IF(XL.GT.0.0)THEN
40181              Y2(I)=REAL(DXOUT)
40182              Y2(I)=Y2(I)/KSSCAL
40183            ENDIF
40184          ENDIF
40185 1650   CONTINUE
40186C
40187      ELSEIF(ICASPL.EQ.'DGAM')THEN
40188        DO1660I=1,N
40189          XL=(Y(I) - KSLOC)/KSSCAL
40190          CALL DGAPDF(XL,SHAPE1,Y2(I))
40191          Y2(I)=Y2(I)/KSSCAL
40192 1660   CONTINUE
40193C
40194      ELSEIF(ICASPL.EQ.'MBKA')THEN
40195        DO1670I=1,N
40196          XL=(Y(I) - KSLOC)/KSSCAL
40197          IF(XL.GT.0.0)THEN
40198            CALL MIEPDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT)
40199            Y2(I)=REAL(DXOUT)
40200            Y2(I)=Y2(I)/KSSCAL
40201          ENDIF
40202 1670   CONTINUE
40203C
40204      ELSEIF(ICASPL.EQ.'FCAU')THEN
40205        DO1680I=1,N
40206          XL=(Y(I) - KSLOC)/KSSCAL
40207          IF(XL.GE.0.0)THEN
40208            CALL FCAPDF(XL,SHAPE1,SHAPE2,Y2(I))
40209            Y2(I)=Y2(I)/KSSCAL
40210          ENDIF
40211 1680   CONTINUE
40212C
40213      ELSEIF(ICASPL.EQ.'BBIN')THEN
40214        IF(IFLAGD.EQ.1)GOTO8000
40215        DO1690I=1,N
40216          XL=Y(I)
40217          CALL BBNPDF(XL,SHAPE1,SHAPE2,INT(SHAPE3+0.1),Y2(I))
40218 1690   CONTINUE
40219C
40220      ELSEIF(ICASPL.EQ.'BRAD')THEN
40221        DO1700I=1,N
40222          XL=(Y(I) - KSLOC)/KSSCAL
40223          IF(XL.GT.0.0 .AND. XL.LT.1.0)THEN
40224            CALL BRAPDF(XL,SHAPE1,Y2(I))
40225            Y2(I)=Y2(I)/KSSCAL
40226          ENDIF
40227 1700   CONTINUE
40228C
40229      ELSEIF(ICASPL.EQ.'GEXP')THEN
40230        DO1710I=1,N
40231          XL=(Y(I) - KSLOC)/KSSCAL
40232          IF(XL.GE.0.0)THEN
40233            CALL GEXPDF(XL,SHAPE1,SHAPE2,SHAPE3,Y2(I))
40234            Y2(I)=Y2(I)/KSSCAL
40235          ENDIF
40236 1710   CONTINUE
40237C
40238      ELSEIF(ICASPL.EQ.'RECI')THEN
40239        DO1715I=1,N
40240          XL=(Y(I) - KSLOC)/KSSCAL
40241          IF(XL.GE.(1.0/SHAPE1) .AND. XL.LT.1.0)THEN
40242            CALL RECPDF(XL,SHAPE1,Y2(I))
40243            Y2(I)=Y2(I)/KSSCAL
40244          ENDIF
40245 1715   CONTINUE
40246C
40247      ELSEIF(ICASPL.EQ.'NORX')THEN
40248        DO1720I=1,N
40249          XL=(Y(I) - SHAPE1)/SHAPE2
40250          CALL NODPDF(DBLE(XL),DXOUT1)
40251          DXOUT1=DXOUT1/DBLE(SHAPE2)
40252          XL=(Y(I) - SHAPE3)/SHAPE4
40253          CALL NODPDF(DBLE(XL),DXOUT2)
40254          DXOUT2=DXOUT2/DBLE(SHAPE4)
40255          DXOUT=DBLE(SHAPE5)*DXOUT1 + DBLE(1.0 - SHAPE5)*DXOUT2
40256          Y2(I)=REAL(DXOUT)
40257 1720   CONTINUE
40258C
40259      ELSEIF(ICASPL.EQ.'IGAM')THEN
40260        DO1730I=1,N
40261          XL=(Y(I) - KSLOC)/KSSCAL
40262          IF(XL.GT.0.0)THEN
40263            CALL IGAPDF(XL,SHAPE1,Y2(I))
40264            Y2(I)=Y2(I)/KSSCAL
40265          ENDIF
40266 1730   CONTINUE
40267C
40268      ELSEIF(ICASPL.EQ.'GTLA')THEN
40269        DO1740I=1,N
40270          XL=(Y(I) - KSLOC)/KSSCAL
40271          CALL GLDPDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT,
40272     1                IGLDDF,IWRITE)
40273          Y2(I)=REAL(DXOUT)
40274          Y2(I)=Y2(I)/KSSCAL
40275 1740   CONTINUE
40276C
40277      ELSEIF(ICASPL.EQ.'JOSB')THEN
40278        DO1750I=1,N
40279          XL=(Y(I) - ZLOC)/ZSCALE
40280          IF(XL.GE.0.0 .AND. XL.LE.1.0)THEN
40281            CALL JSBPDF(XL,SHAPE1,SHAPE2,Y2(I))
40282            Y2(I)=Y2(I)/ZSCALE
40283          ENDIF
40284 1750   CONTINUE
40285C
40286      ELSEIF(ICASPL.EQ.'JOSU')THEN
40287        DO1760I=1,N
40288          XL=(Y(I) - KSLOC)/KSSCAL
40289          CALL JSUPDF(XL,SHAPE1,SHAPE2,Y2(I))
40290          Y2(I)=Y2(I)/KSSCAL
40291 1760   CONTINUE
40292C
40293      ELSEIF(ICASPL.EQ.'IWEI')THEN
40294        DO1770I=1,N
40295          XL=(Y(I) - KSLOC)/KSSCAL
40296          IF(XL.GE.0.0)THEN
40297            CALL IWEPDF(XL,SHAPE1,Y2(I))
40298            Y2(I)=Y2(I)/KSSCAL
40299          ENDIF
40300 1770   CONTINUE
40301C
40302      ELSEIF(ICASPL.EQ.'LDEX')THEN
40303        DO1780I=1,N
40304          XL=(Y(I) - KSLOC)/KSSCAL
40305          IF(XL.GT.0.0)THEN
40306            CALL LDEPDF(XL,SHAPE1,Y2(I))
40307            Y2(I)=Y2(I)/KSSCAL
40308          ENDIF
40309 1780   CONTINUE
40310C
40311      ELSEIF(ICASPL.EQ.'GEEX')THEN
40312        DO1790I=1,N
40313          XL=(Y(I) - KSLOC)/KSSCAL
40314          IF(XL.GE.0.0)THEN
40315            CALL GEEPDF(XL,SHAPE1,Y2(I))
40316            Y2(I)=Y2(I)/KSSCAL
40317          ENDIF
40318 1790   CONTINUE
40319C
40320      ELSEIF(ICASPL.EQ.'TSPO')THEN
40321        IF(A.EQ.CPUMIN .OR. B.EQ.CPUMAX)THEN
40322          ZLOWLM=0.0
40323          ZUPPLM=1.0
40324        ELSE
40325          ZLOWLM=MIN(A,B)
40326          ZUPPLM=MAX(A,B)
40327        ENDIF
40328        IF(ZLOWLM.GT.XMIN)ZLOWLM=XMIN
40329        IF(ZUPPLM.LT.XMAX)ZUPPLM=XMAX
40330        IF(SHAPE1.LT.ZLOWLM .OR. SHAPE1.GT.ZUPPLM)THEN
40331          WRITE(ICOUT,999)
40332          CALL DPWRST('XXX','BUG ')
40333          WRITE(ICOUT,31)
40334          CALL DPWRST('XXX','BUG ')
40335          WRITE(ICOUT,1943)
40336 1943     FORMAT('       FOR THE TWO-SIDED POWER DISTRIBUTION, THE')
40337          CALL DPWRST('XXX','BUG ')
40338          WRITE(ICOUT,1944)
40339 1944     FORMAT('       VALUE OF THE THETA SHAPE PARAMETER IS ',
40340     1           'OUTSIDE')
40341          CALL DPWRST('XXX','BUG ')
40342          WRITE(ICOUT,1945)
40343 1945     FORMAT('       INTERVAL OF THE LOWER AND UPPER LIMIT ',
40344     1           'PARAMETERS.')
40345          CALL DPWRST('XXX','BUG ')
40346          WRITE(ICOUT,1946)SHAPE1
40347 1946     FORMAT('       THE VALUE OF THE THETA SHAPE PARAMETER = ',
40348     1           G15.7)
40349          CALL DPWRST('XXX','BUG ')
40350          WRITE(ICOUT,1947)ZLOWLM
40351 1947     FORMAT('       THE VALUE OF THE LOWER LIMIT PARAMETER = ',
40352     1           G15.7)
40353          CALL DPWRST('XXX','BUG ')
40354          WRITE(ICOUT,1948)ZUPPLM
40355 1948     FORMAT('       THE VALUE OF THE LOWER LIMIT PARAMETER = ',
40356     1           G15.7)
40357          CALL DPWRST('XXX','BUG ')
40358          IERROR='YES'
40359          GOTO9000
40360        ENDIF
40361C
40362        DO1800I=1,N
40363          XL=Y(I)
40364          CALL TSPPDF(XL,SHAPE1,SHAPE2,A,B,Y2(I))
40365 1800   CONTINUE
40366C
40367      ELSEIF(ICASPL.EQ.'BWEI')THEN
40368        DO1810I=1,N
40369          XL=(Y(I) - KSLOC)/KSSCAL
40370          IF(XL.GE.0.0)THEN
40371            CALL BWECDF(XL,SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5,
40372     1                  Y2(I),DXOUT)
40373            CALL BWEHAZ(XL,SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5,
40374     1                  Y2(I),DXOUT)
40375            DXOUT=DTERM2*(1.0D0 - DTERM1)/DBLE(KSSCAL)
40376            Y2(I)=REAL(DXOUT)
40377            Y2(I)=Y2(I)/KSSCAL
40378          ENDIF
40379 1810   CONTINUE
40380C
40381      ELSEIF(ICASPL.EQ.'GHPP')THEN
40382        DO1820I=1,N
40383          XL=(Y(I) - KSLOC)/KSSCAL
40384          CALL GHPDF(XL,SHAPE1,SHAPE2,Y2(I))
40385          Y2(I)=Y2(I)/KSSCAL
40386 1820   CONTINUE
40387C
40388      ELSEIF(ICASPL.EQ.'GPP')THEN
40389        HTEMP=0.0
40390        DO1821I=1,N
40391          XL=(Y(I) - KSLOC)/KSSCAL
40392          CALL GHPDF(XL,SHAPE1,HTEMP,Y2(I))
40393          Y2(I)=Y2(I)/KSSCAL
40394 1821   CONTINUE
40395C
40396      ELSEIF(ICASPL.EQ.'HPP')THEN
40397        GTEMP=0.0
40398        DO1823I=1,N
40399          XL=(Y(I) - KSLOC)/KSSCAL
40400          CALL GHPDF(XL,GTEMP,SHAPE1,Y2(I))
40401          Y2(I)=Y2(I)/KSSCAL
40402 1823   CONTINUE
40403      ELSEIF(ICASPL.EQ.'LAND')THEN
40404        DO1830I=1,N
40405          XL=(Y(I) - KSLOC)/KSSCAL
40406          DXOUT=LANPDF(DBLE(XL))
40407          Y2(I)=REAL(DXOUT)
40408          Y2(I)=Y2(I)/KSSCAL
40409 1830   CONTINUE
40410C
40411      ELSEIF(ICASPL.EQ.'ERRO')THEN
40412        DO1840I=1,N
40413          XL=(Y(I) - KSLOC)/KSSCAL
40414          CALL ERRPDF(XL,SHAPE1,Y2(I))
40415          Y2(I)=Y2(I)/KSSCAL
40416 1840   CONTINUE
40417C
40418      ELSEIF(ICASPL.EQ.'TRAP')THEN
40419        DO1850I=1,N
40420          XL=(Y(I) - KSLOC)/KSSCAL
40421          CALL TRAPDF(XL,SHAPE1,SHAPE2,SHAPE3,SHAPE4,Y2(I))
40422          Y2(I)=Y2(I)/KSSCAL
40423 1850   CONTINUE
40424C
40425      ELSEIF(ICASPL.EQ.'GTRA')THEN
40426        DO1860I=1,N
40427          XL=(Y(I) - KSLOC)/KSSCAL
40428          CALL GTRPDF(XL,SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5,
40429     1                SHAPE6,SHAPE7,Y2(I))
40430          Y2(I)=Y2(I)/KSSCAL
40431 1860   CONTINUE
40432C
40433      ELSEIF(ICASPL.EQ.'FT  ')THEN
40434        DO1870I=1,N
40435          XL=(Y(I) - KSLOC)/KSSCAL
40436          IF(XL.GE.0.0)THEN
40437            CALL FTPDF(XL,INT(SHAPE1+0.1),Y2(I))
40438            Y2(I)=Y2(I)/KSSCAL
40439          ENDIF
40440 1870   CONTINUE
40441C
40442      ELSEIF(ICASPL.EQ.'SLAS')THEN
40443        DO1880I=1,N
40444          XL=(Y(I) - KSLOC)/KSSCAL
40445          CALL SLAPDF(XL,Y2(I))
40446          Y2(I)=Y2(I)/KSSCAL
40447 1880   CONTINUE
40448C
40449      ELSEIF(ICASPL.EQ.'SNOR')THEN
40450        DO1890I=1,N
40451          XL=(Y(I) - KSLOC)/KSSCAL
40452          CALL SNPDF(XL,SHAPE1,ISKNDF,Y2(I))
40453          Y2(I)=Y2(I)/KSSCAL
40454 1890   CONTINUE
40455C
40456      ELSEIF(ICASPL.EQ.'TSKE')THEN
40457        DO1900I=1,N
40458          XL=(Y(I) - KSLOC)/KSSCAL
40459          CALL STPDF(XL,INT(SHAPE1+0.1),SHAPE2,Y2(I))
40460          Y2(I)=Y2(I)/KSSCAL
40461 1900   CONTINUE
40462C
40463      ELSEIF(ICASPL.EQ.'IBET')THEN
40464        DO1910I=1,N
40465          XL=(Y(I) - KSLOC)/KSSCAL
40466          IF(XL.GT.0.0)THEN
40467            CALL IBPDF(XL,SHAPE1,SHAPE2,Y2(I))
40468            Y2(I)=Y2(I)/KSSCAL
40469          ENDIF
40470 1910   CONTINUE
40471C
40472      ELSEIF(ICASPL.EQ.'GOMM')THEN
40473        IF(IMAKDF.EQ.'DLMF')THEN
40474          DO1930I=1,N
40475            XL=(Y(I) - KSLOC)/KSSCAL
40476            IF(XL.GT.0.0)THEN
40477              CALL MAKPDF(XL,SHAPE1,SHAPE2,SHAPE3,Y2(I))
40478              Y2(I)=Y2(I)/KSSCAL
40479            ENDIF
40480 1930     CONTINUE
40481        ELSEIF(IMAKDF.EQ.'MEEK')THEN
40482          XI=SHAPE1/SHAPE3
40483          THETA=SHAPE2/SHAPE1
40484          ALAMB=SHAPE3
40485          DO1935I=1,N
40486            XL=(Y(I) - KSLOC)/KSSCAL
40487            IF(XL.GT.0.0)THEN
40488              CALL MAKPDF(XL,XI,ALAMBA,THETA,Y2(I))
40489              Y2(I)=Y2(I)/KSSCAL
40490            ENDIF
40491 1935     CONTINUE
40492        ELSEIF(IMAKDF.EQ.'REPA')THEN
40493          DO1938I=1,N
40494            XL=(Y(I) - KSLOC)/KSSCAL
40495            IF(XL.GT.0.0)THEN
40496              CALL MA2PDF(XL,SHAPE1,SHAPE2,Y2(I))
40497              Y2(I)=Y2(I)/KSSCAL
40498            ENDIF
40499 1938     CONTINUE
40500        ENDIF
40501C
40502      ELSEIF(ICASPL.EQ.'LSNO')THEN
40503        DO1940I=1,N
40504          XL=(Y(I) - KSLOC)/KSSCAL
40505          IF(XL.GT.0.0)THEN
40506            CALL LSNPDF(XL,SHAPE1,SHAPE2,Y2(I))
40507            Y2(I)=Y2(I)/KSSCAL
40508          ENDIF
40509 1940   CONTINUE
40510C
40511      ELSEIF(ICASPL.EQ.'LSKT')THEN
40512        DO1950I=1,N
40513          XL=(Y(I) - KSLOC)/KSSCAL
40514          IF(XL.GT.0.0)THEN
40515            CALL LSTPDF(XL,INT(SHAPE1+0.1),SHAPE2,SHAPE3,Y2(I))
40516            Y2(I)=Y2(I)/KSSCAL
40517          ENDIF
40518 1950   CONTINUE
40519C
40520      ELSEIF(ICASPL.EQ.'POLY')THEN
40521        DO1960I=1,N
40522          XL=(Y(I) - KSLOC)/KSSCAL
40523          CALL POLPDF(XL,SHAPE1,SHAPE2,SHAPE3,INT(SHAPE4+0.1),Y2(I))
40524 1960   CONTINUE
40525C
40526      ELSEIF(ICASPL.EQ.'HERM')THEN
40527        IF(IFLAGD.EQ.1)GOTO8000
40528        DO1970I=1,N
40529          XL=(Y(I) - KSLOC)/KSSCAL
40530          CALL HERPDF(XL,SHAPE1,SHAPE2,Y2(I))
40531 1970   CONTINUE
40532C
40533      ELSEIF(ICASPL.EQ.'SDEX')THEN
40534        DO1980I=1,N
40535          XL=(Y(I) - KSLOC)/KSSCAL
40536          IF(XL.GT.0.0)THEN
40537            CALL SDEPDF(XL,SHAPE1,Y2(I))
40538            Y2(I)=Y2(I)/KSSCAL
40539          ENDIF
40540 1980   CONTINUE
40541C
40542      ELSEIF(ICASPL.EQ.'ADEX')THEN
40543        DO1990I=1,N
40544          XL=(Y(I) - KSLOC)/KSSCAL
40545          CALL ADEPDF(XL,SHAPE1,IADEDF,Y2(I))
40546          Y2(I)=Y2(I)/KSSCAL
40547 1990   CONTINUE
40548C
40549      ELSEIF(ICASPL.EQ.'MAXW')THEN
40550        DO2000I=1,N
40551          XL=(Y(I) - KSLOC)/KSSCAL
40552          IF(XL.GE.0.0)THEN
40553            CALL MAXPDF(XL,Y2(I))
40554            Y2(I)=Y2(I)/KSSCAL
40555          ENDIF
40556 2000   CONTINUE
40557C
40558      ELSEIF(ICASPL.EQ.'1MAX')THEN
40559        DO2005I=1,N
40560          XL=Y(I)/KSSCAL
40561          IF(XL.GE.0.0)THEN
40562            CALL MAXPDF(XL,Y2(I))
40563            Y2(I)=Y2(I)/KSSCAL
40564          ENDIF
40565 2005   CONTINUE
40566C
40567      ELSEIF(ICASPL.EQ.'RAYL')THEN
40568        DO2010I=1,N
40569          XL=(Y(I) - KSLOC)/KSSCAL
40570          IF(XL.GE.0.0)THEN
40571            CALL RAYPDF(XL,Y2(I))
40572            Y2(I)=Y2(I)/KSSCAL
40573          ENDIF
40574 2010   CONTINUE
40575C
40576      ELSEIF(ICASPL.EQ.'GIGA')THEN
40577        IF(IGIGDF.EQ.'2PAR')THEN
40578          DO2020I=1,N
40579            XL=(Y(I) - KSLOC)/KSSCAL
40580            IF(XL.GE.0.0)THEN
40581              CALL GI2PDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT)
40582              Y2(I)=REAL(DXOUT)
40583              Y2(I)=Y2(I)/KSSCAL
40584            ENDIF
40585 2020     CONTINUE
40586        ELSE
40587          DO2030I=1,N
40588            XL=(Y(I) - KSLOC)/KSSCAL
40589            IF(XL.GE.0.0)THEN
40590              CALL GIGPDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),
40591     1                    DBLE(SHAPE3),DXOUT)
40592              Y2(I)=REAL(DXOUT)
40593              Y2(I)=Y2(I)/KSSCAL
40594            ENDIF
40595 2030     CONTINUE
40596        ENDIF
40597C
40598      ELSEIF(ICASPL.EQ.'GALP')THEN
40599        DO2040I=1,N
40600          XL=(Y(I) - KSLOC)/KSSCAL
40601          CALL GALPDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),IADEDF,DXOUT)
40602          Y2(I)=REAL(DXOUT)
40603          Y2(I)=Y2(I)/KSSCAL
40604 2040   CONTINUE
40605C
40606      ELSEIF(ICASPL.EQ.'MCLE')THEN
40607        DO2050I=1,N
40608          XL=(Y(I) - KSLOC)/KSSCAL
40609          CALL MCLPDF(DBLE(XL),DBLE(SHAPE1),DXOUT)
40610          Y2(I)=REAL(DXOUT)
40611          Y2(I)=Y2(I)/KSSCAL
40612 2050   CONTINUE
40613C
40614      ELSEIF(ICASPL.EQ.'BEIP')THEN
40615        DO2060I=1,N
40616          XL=(Y(I) - KSLOC)/KSSCAL
40617          CALL BEIPDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DBLE(SHAPE3),
40618     1                IBEIDF,DXOUT)
40619          Y2(I)=REAL(DXOUT)
40620          Y2(I)=Y2(I)/KSSCAL
40621 2060   CONTINUE
40622C
40623      ELSEIF(ICASPL.EQ.'BEIK')THEN
40624        DO2070I=1,N
40625          XL=(Y(I) - KSLOC)/KSSCAL
40626CCCCC     CALL BEKPDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DBLE(SHAPE3),
40627CCCCC1                IBEIDF,DXOUT)
40628          DXOUT=0.0D0
40629          Y2(I)=REAL(DXOUT)
40630          Y2(I)=Y2(I)/KSSCAL
40631 2070   CONTINUE
40632C
40633      ELSEIF(ICASPL.EQ.'GMCL')THEN
40634        DO2080I=1,N
40635          XL=(Y(I) - KSLOC)/KSSCAL
40636          CALL GMCPDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT)
40637          Y2(I)=REAL(DXOUT)
40638          Y2(I)=Y2(I)/KSSCAL
40639 2080   CONTINUE
40640C
40641      ELSEIF(ICASPL.EQ.'G5LO')THEN
40642        DO2090I=1,N
40643          XL=(Y(I)-KSLOC)/KSSCAL
40644          IF(SHAPE1.EQ.0.0)THEN
40645            CALL GL5PDF(DBLE(XL),DBLE(SHAPE1),DXOUT)
40646            Y2(I)=REAL(DXOUT)
40647            Y2(I)=Y2(I)/KSSCAL
40648          ELSEIF(SHAPE1.GT.0.0)THEN
40649            IF(XL.LE.1.0/SHAPE1)THEN
40650              CALL GL5PDF(DBLE(XL),DBLE(SHAPE1),DXOUT)
40651              Y2(I)=REAL(DXOUT)
40652              Y2(I)=Y2(I)/KSSCAL
40653            ENDIF
40654          ELSEIF(SHAPE1.LT.0.0)THEN
40655            IF(XL.GE.1.0/SHAPE1)THEN
40656              CALL GL5PDF(DBLE(XL),DBLE(SHAPE1),DXOUT)
40657              Y2(I)=REAL(DXOUT)
40658              Y2(I)=Y2(I)/KSSCAL
40659            ENDIF
40660          ENDIF
40661 2090   CONTINUE
40662C
40663      ELSEIF(ICASPL.EQ.'WAKE')THEN
40664        XPAR(1)=DBLE(KSLOC)
40665        XPAR(2)=DBLE(KSSCAL)
40666        XPAR(3)=DBLE(SHAPE1)
40667        XPAR(4)=DBLE(SHAPE2)
40668        XPAR(5)=DBLE(SHAPE3)
40669        DO2100I=1,N
40670          XL=Y(I)
40671          DXOUT=PDFWAK(DBLE(XL),XPAR)
40672          Y2(I)=REAL(DXOUT)
40673 2100   CONTINUE
40674C
40675      ELSEIF(ICASPL.EQ.'BNOR')THEN
40676        DO2110I=1,N
40677          XL=(Y(I) - KSLOC)/KSSCAL
40678          CALL BNOPDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT)
40679          Y2(I)=REAL(DXOUT)
40680          Y2(I)=Y2(I)/KSSCAL
40681 2110   CONTINUE
40682C
40683      ELSEIF(ICASPL.EQ.'G2LO')THEN
40684        DO2120I=1,N
40685          XL=(Y(I) - KSLOC)/KSSCAL
40686          CALL GL2PDF(DBLE(XL),DBLE(SHAPE1),DXOUT)
40687          Y2(I)=REAL(DXOUT)
40688          Y2(I)=Y2(I)/KSSCAL
40689 2120   CONTINUE
40690C
40691      ELSEIF(ICASPL.EQ.'G3LO')THEN
40692        DO2130I=1,N
40693          XL=(Y(I) - KSLOC)/KSSCAL
40694          CALL GL3PDF(DBLE(XL),DBLE(SHAPE1),DXOUT)
40695          Y2(I)=REAL(DXOUT)
40696          Y2(I)=Y2(I)/KSSCAL
40697 2130   CONTINUE
40698C
40699      ELSEIF(ICASPL.EQ.'G4LO')THEN
40700        DO2140I=1,N
40701          XL=(Y(I) - KSLOC)/KSSCAL
40702          CALL GL4PDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT)
40703          Y2(I)=REAL(DXOUT)
40704          Y2(I)=Y2(I)/KSSCAL
40705 2140   CONTINUE
40706C
40707      ELSEIF(ICASPL.EQ.'ALDE')THEN
40708        DO2150I=1,N
40709          XL=(Y(I) - KSLOC)/KSSCAL
40710          IF(XL.GT.0.0)THEN
40711            CALL ALDPDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT)
40712            Y2(I)=REAL(DXOUT)
40713            Y2(I)=Y2(I)/KSSCAL
40714          ENDIF
40715 2150   CONTINUE
40716C
40717      ELSEIF(ICASPL.EQ.'BGEO')THEN
40718        IF(IFLAGD.EQ.1)GOTO8000
40719        IF(IBGEDF.EQ.'UNSH')THEN
40720          DO2160I=1,N
40721            XL=Y(I)
40722            CALL BGEPDF(XL,SHAPE1,SHAPE2,Y2(I))
40723 2160     CONTINUE
40724        ELSE
40725          DO2165I=1,N
40726            XL=Y(I)
40727            CALL BG2PDF(XL,SHAPE1,SHAPE2,Y2(I))
40728 2165     CONTINUE
40729        ENDIF
40730C
40731      ELSEIF(ICASPL.EQ.'ZETA')THEN
40732        IF(IFLAGD.EQ.1)GOTO8000
40733        DO2170I=1,N
40734          XL=Y(I)
40735          CALL ZETPDF(XL,SHAPE1,Y2(I))
40736 2170   CONTINUE
40737C
40738      ELSEIF(ICASPL.EQ.'ZIPF')THEN
40739        IF(IFLAGD.EQ.1)GOTO8000
40740        DO2180I=1,N
40741          XL=Y(I)
40742          CALL ZIPPDF(XL,SHAPE1,INT(SHAPE2+0.1),Y2(I))
40743 2180   CONTINUE
40744C
40745      ELSEIF(ICASPL.EQ.'BTAN')THEN
40746        IF(IFLAGD.EQ.1)GOTO8000
40747        DO2190I=1,N
40748          XL=Y(I)
40749          CALL BTAPDF(XL,SHAPE1,SHAPE2,Y2(I))
40750 2190   CONTINUE
40751C
40752      ELSEIF(ICASPL.EQ.'BNBI')THEN
40753        IF(IFLAGD.EQ.1)GOTO8000
40754        DO2200I=1,N
40755          XL=Y(I)
40756          CALL GWAPDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),
40757     1                DBLE(SHAPE3),DXOUT)
40758          Y2(I)=REAL(DXOUT)
40759 2200   CONTINUE
40760C
40761      ELSEIF(ICASPL.EQ.'LPOI')THEN
40762        IF(IFLAGD.EQ.1)GOTO8000
40763        DO2210I=1,N
40764          XL=Y(I)
40765          CALL LPOPDF(XL,SHAPE1,SHAPE2,Y2(I))
40766 2210   CONTINUE
40767C
40768      ELSEIF(ICASPL.EQ.'LICT')THEN
40769        IF(IFLAGD.EQ.1)GOTO8000
40770        DO2220I=1,N
40771          XL=Y(I)
40772          CALL LCTPDF(XL,INT(SHAPE1+0.1),Y2(I))
40773 2220   CONTINUE
40774C
40775      ELSEIF(ICASPL.EQ.'MATC')THEN
40776        IF(IFLAGD.EQ.1)GOTO8000
40777        DO2230I=1,N
40778          XL=Y(I)
40779          CALL MATPDF(XL,INT(SHAPE1+0.1),Y2(I))
40780 2230   CONTINUE
40781C
40782      ELSEIF(ICASPL.EQ.'LBET')THEN
40783        YLOWLM=SHAPE3
40784        YUPPLM=SHAPE4
40785        EPS=(XMAX-XMIN)*0.01
40786        IF(YLOWLM.GT.XMIN)YLOWLM=XMIN-EPS
40787        IF(YUPPLM.LT.XMAX)YUPPLM=XMAX+EPS
40788        DO2240I=1,N
40789          XL=(Y(I) - KSLOC)/KSSCAL
40790          CALL LBEPDF(XL,SHAPE1,SHAPE2,YLOWLM,YUPPLM,Y2(I))
40791          Y2(I)=Y2(I)/KSSCAL
40792 2240   CONTINUE
40793C
40794      ELSEIF(ICASPL.EQ.'AEPP')THEN
40795        IF(IFLAGD.EQ.1)GOTO8000
40796        DO2250I=1,N
40797          XL=Y(I)
40798          CALL PAPPDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT)
40799          Y2(I)=REAL(DXOUT)
40800 2250   CONTINUE
40801C
40802      ELSEIF(ICASPL.EQ.'GLOS')THEN
40803        IF(IFLAGD.EQ.1)GOTO8000
40804        DO2270I=1,N
40805          XL=Y(I)
40806          CALL GLSPDF(XL,SHAPE1,SHAPE2,Y2(I))
40807 2270   CONTINUE
40808C
40809      ELSEIF(ICASPL.EQ.'GNBI')THEN
40810        IF(IFLAGD.EQ.1)GOTO8000
40811        DO2280I=1,N
40812          XL=Y(I)
40813          CALL GNBPDF(XL,SHAPE1,SHAPE2,SHAPE3,Y2(I))
40814 2280   CONTINUE
40815C
40816      ELSEIF(ICASPL.EQ.'GEET')THEN
40817        IF(IFLAGD.EQ.1)GOTO8000
40818        DO2290I=1,N
40819          XL=Y(I)
40820          CALL GETPDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),
40821     1                IGETDF,DXOUT)
40822          Y2(I)=REAL(DXOUT)
40823 2290   CONTINUE
40824C
40825      ELSEIF(ICASPL.EQ.'QBIN')THEN
40826        IF(IFLAGD.EQ.1)GOTO8000
40827        DO2300I=1,N
40828          XL=Y(I)
40829          CALL QBIPDF(XL,SHAPE1,SHAPE2,SHAPE3,Y2(I))
40830 2300   CONTINUE
40831C
40832      ELSEIF(ICASPL.EQ.'CONS')THEN
40833        IF(IFLAGD.EQ.1)GOTO8000
40834        DO2310I=1,N
40835          XL=Y(I)
40836          CALL CONPDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),
40837     1                ICONDF,DXOUT)
40838          Y2(I)=REAL(DXOUT)
40839 2310   CONTINUE
40840C
40841      ELSEIF(ICASPL.EQ.'LKAT')THEN
40842        IF(IFLAGD.EQ.1)GOTO8000
40843        DO2320I=1,N
40844          XL=Y(I)
40845          CALL LKPDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),
40846     1                DBLE(SHAPE3),DXOUT)
40847          Y2(I)=REAL(DXOUT)
40848 2320   CONTINUE
40849C
40850      ELSEIF(ICASPL.EQ.'KATZ')THEN
40851        IF(IFLAGD.EQ.1)GOTO8000
40852        DO2330I=1,N
40853          XL=Y(I)
40854          CALL KATPDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),IKATDF,DXOUT)
40855          Y2(I)=REAL(DXOUT)
40856 2330   CONTINUE
40857C
40858      ELSEIF(ICASPL.EQ.'DISW')THEN
40859        IF(IFLAGD.EQ.1)GOTO8000
40860        DO2340I=1,N
40861          XL=Y(I)
40862          CALL DIWPDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT)
40863          Y2(I)=REAL(DXOUT)
40864 2340   CONTINUE
40865C
40866      ELSEIF(ICASPL.EQ.'GLGP')THEN
40867        IF(IFLAGD.EQ.1)GOTO8000
40868        DO2350I=1,N
40869          XL=Y(I)
40870          CALL GLGPDF(XL,SHAPE1,INT(SHAPE2+0.1),SHAPE3,Y2(I))
40871 2350   CONTINUE
40872C
40873      ELSEIF(ICASPL.EQ.'TGNB')THEN
40874        IF(IFLAGD.EQ.1)GOTO8000
40875        DO2360I=1,N
40876          XL=Y(I)
40877          CALL GNTPDF(XL,SHAPE1,SHAPE2,SHAPE3,INT(SHAPE4+0.1),Y2(I))
40878 2360   CONTINUE
40879C
40880      ELSEIF(ICASPL.EQ.'TOPL')THEN
40881        DO2370I=1,N
40882          XL=(Y(I) - ZLOC)/ZSCALE
40883          IF(XL.GE.0.0 .AND. XL.LE.1.0)THEN
40884            CALL TOPPDF(DBLE(XL),DBLE(SHAPE1),DXOUT)
40885            Y2(I)=REAL(DXOUT)
40886            Y2(I)=Y2(I)/ZSCALE
40887          ENDIF
40888 2370   CONTINUE
40889C
40890      ELSEIF(ICASPL.EQ.'GTOL')THEN
40891        DO2380I=1,N
40892          XL=Y(I)
40893          IF(XL.GE.A .AND. XL.LE.B)THEN
40894            CALL GTLPDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),
40895     1                  DBLE(A),DBLE(B),DXOUT)
40896            Y2(I)=REAL(DXOUT)
40897          ENDIF
40898 2380   CONTINUE
40899C
40900      ELSEIF(ICASPL.EQ.'RGTL')THEN
40901        DO2390I=1,N
40902          XL=Y(I)
40903          IF(XL.GE.A .AND. XL.LE.B)THEN
40904            CALL RGTPDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),
40905     1                  DBLE(A),DBLE(B),DXOUT)
40906            Y2(I)=REAL(DXOUT)
40907          ENDIF
40908 2390   CONTINUE
40909C
40910      ELSEIF(ICASPL.EQ.'SLOP')THEN
40911        DO2400I=1,N
40912          XL=(Y(I) - ZLOC)/ZSCALE
40913          IF(XL.GE.0.0 .AND. XL.LE.1.0)THEN
40914            CALL SLOPDF(XL,SHAPE1,Y2(I))
40915            Y2(I)=Y2(I)/ZSCALE
40916          ENDIF
40917 2400   CONTINUE
40918C
40919      ELSEIF(ICASPL.EQ.'OGIV')THEN
40920        DO2410I=1,N
40921          XL=(Y(I) - ZLOC)/ZSCALE
40922          IF(XL.GE.0.0 .AND. XL.LE.1.0)THEN
40923            CALL OGIPDF(DBLE(XL),DBLE(SHAPE1),DXOUT)
40924            Y2(I)=REAL(DXOUT)
40925            Y2(I)=Y2(I)/ZSCALE
40926          ENDIF
40927 2410   CONTINUE
40928C
40929      ELSEIF(ICASPL.EQ.'TSSL')THEN
40930        DO2420I=1,N
40931          XL=Y(I)
40932          IF(XL.GE.0.0 .AND. XL.LE.1.0)THEN
40933            CALL TSSPDF(XL,SHAPE1,SHAPE2,
40934     1                  A,B,Y2(I))
40935          ENDIF
40936 2420   CONTINUE
40937C
40938      ELSEIF(ICASPL.EQ.'TSOG')THEN
40939        DO2430I=1,N
40940          XL=Y(I)
40941          IF(XL.GE.0.0 .AND. XL.LE.1.0)THEN
40942            CALL TSOPDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),
40943     1                  DBLE(A),DBLE(B),DXOUT)
40944            Y2(I)=REAL(DXOUT)
40945          ENDIF
40946 2430   CONTINUE
40947C
40948      ELSEIF(ICASPL.EQ.'BUR2')THEN
40949        DO2450I=1,N
40950          XL=(Y(I) - KSLOC)/KSSCAL
40951          CALL BU2PDF(DBLE(XL),DBLE(SHAPE1),DXOUT)
40952          Y2(I)=REAL(DXOUT)
40953          Y2(I)=Y2(I)/KSSCAL
40954 2450   CONTINUE
40955C
40956      ELSEIF(ICASPL.EQ.'BUR3')THEN
40957        DO2460I=1,N
40958          XL=(Y(I) - KSLOC)/KSSCAL
40959          IF(XL.GT.0.0)THEN
40960            CALL BU3PDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT)
40961            Y2(I)=REAL(DXOUT)
40962            Y2(I)=Y2(I)/KSSCAL
40963          ENDIF
40964 2460   CONTINUE
40965C
40966      ELSEIF(ICASPL.EQ.'BUR4')THEN
40967        DO2470I=1,N
40968          XL=(Y(I) - KSLOC)/KSSCAL
40969CCCCC     CALL BU4PDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT)
40970CCCCC     Y2(I)=REAL(DXOUT)
40971CCCCC     Y2(I)=Y2(I)/KSSCAL
40972          Y2(I)=0.0
40973 2470   CONTINUE
40974C
40975      ELSEIF(ICASPL.EQ.'BUR5')THEN
40976        DO2480I=1,N
40977          XL=(Y(I) - KSLOC)/KSSCAL
40978          IF(XL.GT.0.0)THEN
40979            CALL BU5PDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT)
40980            Y2(I)=REAL(DXOUT)
40981            Y2(I)=Y2(I)/KSSCAL
40982          ENDIF
40983 2480   CONTINUE
40984C
40985      ELSEIF(ICASPL.EQ.'BUR6')THEN
40986        DO2490I=1,N
40987          XL=(Y(I) - KSLOC)/KSSCAL
40988          CALL BU6PDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT)
40989          Y2(I)=REAL(DXOUT)
40990          Y2(I)=Y2(I)/KSSCAL
40991 2490   CONTINUE
40992C
40993      ELSEIF(ICASPL.EQ.'BUR7')THEN
40994        DO2500I=1,N
40995          XL=(Y(I) - KSLOC)/KSSCAL
40996          CALL BU7PDF(DBLE(XL),DBLE(SHAPE1),DXOUT)
40997          Y2(I)=REAL(DXOUT)
40998          Y2(I)=Y2(I)/KSSCAL
40999 2500   CONTINUE
41000C
41001      ELSEIF(ICASPL.EQ.'BUR8')THEN
41002        DO2510I=1,N
41003          XL=(Y(I) - KSLOC)/KSSCAL
41004          CALL BU8PDF(DBLE(XL),DBLE(SHAPE1),DXOUT)
41005          Y2(I)=REAL(DXOUT)
41006          Y2(I)=Y2(I)/KSSCAL
41007 2510   CONTINUE
41008C
41009      ELSEIF(ICASPL.EQ.'BUR9')THEN
41010        DO2520I=1,N
41011          XL=(Y(I) - KSLOC)/KSSCAL
41012          CALL BU9PDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT)
41013          Y2(I)=REAL(DXOUT)
41014          Y2(I)=Y2(I)/KSSCAL
41015 2520   CONTINUE
41016C
41017      ELSEIF(ICASPL.EQ.'BU10')THEN
41018        DO2530I=1,N
41019          XL=(Y(I) - KSLOC)/KSSCAL
41020          IF(XL.GT.0.0)THEN
41021            CALL B10PDF(DBLE(XL),DBLE(SHAPE1),DXOUT)
41022            Y2(I)=REAL(DXOUT)
41023            Y2(I)=Y2(I)/KSSCAL
41024          ENDIF
41025 2530   CONTINUE
41026C
41027      ELSEIF(ICASPL.EQ.'BU11')THEN
41028        DO2540I=1,N
41029          XL=(Y(I) - KSLOC)/KSSCAL
41030          IF(XL.GT.0.0 .AND. XL.LT.1.0)THEN
41031            CALL B11PDF(DBLE(XL),DBLE(SHAPE1),DXOUT)
41032            Y2(I)=REAL(DXOUT)
41033            Y2(I)=Y2(I)/KSSCAL
41034          ENDIF
41035 2540   CONTINUE
41036C
41037      ELSEIF(ICASPL.EQ.'BU12')THEN
41038        DO2550I=1,N
41039          XL=(Y(I) - KSLOC)/KSSCAL
41040          IF(XL.GT.0.0)THEN
41041            CALL B12PDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT)
41042            Y2(I)=REAL(DXOUT)
41043            Y2(I)=Y2(I)/KSSCAL
41044          ENDIF
41045 2550   CONTINUE
41046C
41047      ELSEIF(ICASPL.EQ.'DPUN')THEN
41048        DO2560I=1,N
41049          XL=(Y(I) - KSLOC)/KSSCAL
41050          CALL DPUPDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),
41051     1                DBLE(SHAPE3),DBLE(SHAPE4),DXOUT)
41052          Y2(I)=REAL(DXOUT)
41053          Y2(I)=Y2(I)/KSSCAL
41054 2560   CONTINUE
41055C
41056      ELSEIF(ICASPL.EQ.'KUMA')THEN
41057        DO2570I=1,N
41058          XL=(Y(I) - ZLOC)/ZSCALE
41059          IF(XL.GE.0.0 .AND. XL.LE.1.0)THEN
41060            CALL KUMPDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT)
41061            Y2(I)=REAL(DXOUT)
41062            Y2(I)=Y2(I)/ZSCALE
41063          ENDIF
41064 2570   CONTINUE
41065C
41066      ELSEIF(ICASPL.EQ.'RPOW')THEN
41067        DO2580I=1,N
41068          XL=(Y(I) - ZLOC)/ZSCALE
41069          IF(XL.LT.0.0)XL=1.0E-12
41070          IF(XL.GE.1.0)XL=1.0 - 1.0E-12
41071          CALL RPOPDF(XL,SHAPE1,Y2(I))
41072          Y2(I)=Y2(I)/ZSCALE
41073 2580   CONTINUE
41074C
41075      ELSEIF(ICASPL.EQ.'UTSP')THEN
41076        DO2590I=1,N
41077          XL=Y(I)
41078          CALL UTSPDF(XL,SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5,
41079     1                SHAPE6,Y2(I))
41080 2590   CONTINUE
41081C
41082      ELSEIF(ICASPL.EQ.'MUTH')THEN
41083        DO2600I=1,N
41084          XL=(Y(I) - KSLOC)/KSSCAL
41085          IF(XL.GT.0.0)THEN
41086            CALL MUTPDF(DBLE(XL),DBLE(SHAPE1),DXOUT)
41087            Y2(I)=REAL(DXOUT)
41088            Y2(I)=Y2(I)/KSSCAL
41089          ENDIF
41090 2600   CONTINUE
41091C
41092      ELSEIF(ICASPL.EQ.'LEXP')THEN
41093        DO2610I=1,N
41094          XL=(Y(I) - KSLOC)/KSSCAL
41095          IF(SHAPE1.LT.1.0)THEN
41096            IF(XL.GT.0.0)THEN
41097              CALL LEXPDF(DBLE(XL),DBLE(SHAPE1),DXOUT)
41098              Y2(I)=REAL(DXOUT)
41099              Y2(I)=Y2(I)/KSSCAL
41100            ENDIF
41101          ELSE
41102            IF(XL.GE.0.0)THEN
41103              CALL LEXPDF(DBLE(XL),DBLE(SHAPE1),DXOUT)
41104              Y2(I)=REAL(DXOUT)
41105              Y2(I)=Y2(I)/KSSCAL
41106            ENDIF
41107          ENDIF
41108 2610   CONTINUE
41109C
41110      ELSEIF(ICASPL.EQ.'TPAR')THEN
41111        DO2620I=1,N
41112          XL=(Y(I) - KSLOC)/KSSCAL
41113          CALL TNPPDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),
41114     1                DBLE(SHAPE3),DXOUT)
41115          Y2(I)=REAL(DXOUT)
41116          Y2(I)=Y2(I)/KSSCAL
41117 2620   CONTINUE
41118C
41119      ELSEIF(ICASPL.EQ.'BFRA')THEN
41120        DO2630I=1,N
41121          XL=(Y(I) - KSLOC)/KSSCAL
41122          IF(XL.GT.0.0)THEN
41123            CALL BFRPDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),
41124     1                DBLE(SHAPE3),DXOUT)
41125            Y2(I)=REAL(DXOUT)
41126            Y2(I)=Y2(I)/KSSCAL
41127          ENDIF
41128 2630   CONTINUE
41129C
41130      ELSEIF(ICASPL.EQ.'L3EX')THEN
41131        DO2640I=1,N
41132          XL=(Y(I) - KSLOC)/KSSCAL
41133          IF(SHAPE1.LT.1.0)THEN
41134            IF(XL.GT.0.0)THEN
41135              CALL LE3PDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),
41136     1                    DBLE(SHAPE3),DXOUT)
41137              Y2(I)=REAL(DXOUT)
41138              Y2(I)=Y2(I)/KSSCAL
41139            ENDIF
41140          ELSE
41141            IF(XL.GE.0.0)THEN
41142              CALL LE3PDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),
41143     1                    DBLE(SHAPE3),DXOUT)
41144              Y2(I)=REAL(DXOUT)
41145              Y2(I)=Y2(I)/KSSCAL
41146            ENDIF
41147          ENDIF
41148 2640   CONTINUE
41149C
41150      ELSEIF(ICASPL.EQ.'KAPP')THEN
41151        DO2650I=1,N
41152          XL=(Y(I) - KSLOC)/KSSCAL
41153          CALL KAPPDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),
41154     1                DBLE(KSLOC),DBLE(KSSCAL),DXOUT)
41155          Y2(I)=REAL(DXOUT)
41156          Y2(I)=Y2(I)/KSSCAL
41157 2650   CONTINUE
41158C
41159      ELSEIF(ICASPL.EQ.'PEA3')THEN
41160        DO2660I=1,N
41161          XL=(Y(I) - KSLOC)/KSSCAL
41162          CALL PE3PDF(DBLE(XL),DBLE(SHAPE1),DBLE(KSLOC),DBLE(KSSCAL),
41163     1                DXOUT)
41164          Y2(I)=REAL(DXOUT)
41165          Y2(I)=Y2(I)/KSSCAL
41166 2660   CONTINUE
41167C
41168      ELSEIF(ICASPL.EQ.'EEWE')THEN
41169        DO2670I=1,N
41170          XL=Y(I)
41171          IF(XL.GT.0.0)THEN
41172            CALL EEWPDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DBLE(SHAPE3),
41173     1                  DBLE(SHAPE4),DBLE(SHAPE5),DXOUT)
41174            Y2(I)=REAL(DXOUT)
41175          ENDIF
41176 2670   CONTINUE
41177C
41178      ELSEIF(ICASPL.EQ.'BFWE')THEN
41179        DO2680I=1,N
41180          XL=(Y(I) - KSLOC)/KSSCAL
41181          IF(XL.GE.0.0)THEN
41182            CALL BFWPDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT)
41183            Y2(I)=REAL(DXOUT)/KSSCAL
41184          ENDIF
41185 2680   CONTINUE
41186C
41187      ELSE
41188        WRITE(ICOUT,999)
41189        CALL DPWRST('XXX','BUG ')
41190        WRITE(ICOUT,31)
41191        CALL DPWRST('XXX','BUG ')
41192        WRITE(ICOUT,8011)ICASPL
41193 8011   FORMAT('      UNKNOWN DISTRIBUTION -- ',A40)
41194        CALL DPWRST('XXX','BUG ')
41195        IERROR='YES'
41196        GOTO9000
41197      ENDIF
41198C
41199      GOTO9000
41200C
41201C     SET AN ERROR FLAG TO INDICATE A DISCRETE DISTRIBUTION
41202C     IS NOT TO BE PROCESSED.
41203C
41204 8000 CONTINUE
41205      IFLAGD=99
41206      GOTO9000
41207C
41208C               *****************
41209C               **  STEP 90--  **
41210C               **  EXIT       **
41211C               *****************
41212C
41213 9000 CONTINUE
41214C
41215      KSLOC=KSLOC2
41216      KSSCAL=KSSCA2
41217C
41218      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PDF1')THEN
41219        WRITE(ICOUT,999)
41220        CALL DPWRST('XXX','BUG ')
41221        WRITE(ICOUT,9011)
41222 9011   FORMAT('***** AT THE END       OF DPPDF1--')
41223        CALL DPWRST('XXX','BUG ')
41224        WRITE(ICOUT,9012)ICASPL,N,MINMAX,IERROR
41225 9012   FORMAT('ICASPL,N,MINMAX,IERROR = ',A4,2X,2I8,2X,A4)
41226        CALL DPWRST('XXX','BUG ')
41227        DO9020I=1,N
41228          WRITE(ICOUT,9021)I,Y(I),Y2(I)
41229 9021     FORMAT('I,Y(I),Y2(I), = ',I8,2G15.7)
41230          CALL DPWRST('XXX','BUG ')
41231 9020   CONTINUE
41232      ENDIF
41233C
41234      RETURN
41235      END
41236      SUBROUTINE DPPDTE(XTEMP1,XTEMP2,MAXNXT,
41237     1                  ICAPSW,ICASAN,IFORSW,
41238     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
41239C
41240C     PURPOSE--PERFORM A POISSON DISPERSION TEST.  THIS CAN BE
41241C              APPLIED TO EITHER RAW DATA OR TO FREQUENCY DATA.
41242C     EXAMPLE--POISSON DISPERSION TEST Y
41243C              POISSON DISPERSION TEST Y X
41244C     WRITTEN BY--ALAN HECKERT
41245C                 STATISTICAL ENGINEERING DIVISION
41246C                 INFORMATION TECHNOLOGY LABORATORY
41247C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
41248C                 GAITHERSBURG, MD 20899-8980
41249C                 PHONE--301-975-2899
41250C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
41251C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
41252C     LANGUAGE--ANSI FORTRAN (1977)
41253C     VERSION NUMBER--2013/11
41254C     ORIGINAL VERSION--NOVEMBER  2013.
41255C     UPDATED         --JULY      2019. TWEAK TO SCRATCH SPACE
41256C
41257C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
41258C
41259      CHARACTER*4 ICAPSW
41260      CHARACTER*4 IFORSW
41261      CHARACTER*4 IBUGA2
41262      CHARACTER*4 IBUGA3
41263      CHARACTER*4 IBUGQ
41264      CHARACTER*4 ISUBRO
41265      CHARACTER*4 IFOUND
41266      CHARACTER*4 IERROR
41267C
41268      CHARACTER*4 ICASAN
41269      CHARACTER*4 ICTMP1
41270      CHARACTER*4 ICTMP2
41271      CHARACTER*4 ICTMP3
41272      CHARACTER*4 IREPL
41273      CHARACTER*4 IMULT
41274      CHARACTER*4 ISUBN1
41275      CHARACTER*4 ISUBN2
41276      CHARACTER*4 ISTEPN
41277C
41278      CHARACTER*4 ICASE
41279      CHARACTER*4 ICASET
41280      CHARACTER*40 INAME
41281      PARAMETER (MAXSPN=30)
41282      CHARACTER*4 IVARN1(MAXSPN)
41283      CHARACTER*4 IVARN2(MAXSPN)
41284      CHARACTER*4 IVARTY(MAXSPN)
41285      CHARACTER*4 IVARID(2)
41286      CHARACTER*4 IVARI2(2)
41287      REAL PVAR(MAXSPN)
41288      REAL PID(MAXSPN)
41289      INTEGER ILIS(MAXSPN)
41290      INTEGER NRIGHT(MAXSPN)
41291      INTEGER ICOLR(MAXSPN)
41292C
41293      CHARACTER*4 IFLAGU
41294      LOGICAL IFRST
41295      LOGICAL ILAST
41296C
41297C---------------------------------------------------------------------
41298C
41299      DIMENSION XTEMP1(*)
41300      DIMENSION XTEMP2(*)
41301C
41302C-----COMMON----------------------------------------------------------
41303C
41304      INCLUDE 'DPCOPA.INC'
41305C
41306      DIMENSION XDESGN(MAXOBV,7)
41307      DIMENSION XIDTEM(MAXOBV)
41308      DIMENSION XIDTE2(MAXOBV)
41309      DIMENSION XIDTE3(MAXOBV)
41310      DIMENSION XIDTE4(MAXOBV)
41311      DIMENSION XIDTE5(MAXOBV)
41312      DIMENSION XIDTE6(MAXOBV)
41313C
41314      DIMENSION TEMP1(MAXOBV)
41315      DIMENSION TEMP2(MAXOBV)
41316C
41317      INCLUDE 'DPCOZZ.INC'
41318C
41319      EQUIVALENCE (GARBAG(IGARB1),TEMP1(1))
41320      EQUIVALENCE (GARBAG(IGARB2),TEMP2(1))
41321      EQUIVALENCE (GARBAG(IGARB3),XIDTEM(1))
41322      EQUIVALENCE (GARBAG(IGARB4),XIDTE2(1))
41323      EQUIVALENCE (GARBAG(IGARB5),XIDTE3(1))
41324      EQUIVALENCE (GARBAG(IGARB6),XIDTE4(1))
41325      EQUIVALENCE (GARBAG(IGARB7),XIDTE5(1))
41326      EQUIVALENCE (GARBAG(IGARB8),XIDTE6(1))
41327      EQUIVALENCE (GARBAG(IGARB9),XDESGN(1,1))
41328C
41329      INCLUDE 'DPCOHK.INC'
41330      INCLUDE 'DPCOSU.INC'
41331      INCLUDE 'DPCODA.INC'
41332      INCLUDE 'DPCOHO.INC'
41333      INCLUDE 'DPCOST.INC'
41334      INCLUDE 'DPCOP2.INC'
41335C
41336C-----START POINT-----------------------------------------------------
41337C
41338      ISUBN1='DPPD'
41339      ISUBN2='TE  '
41340      IFOUND='NO'
41341      IERROR='NO'
41342C
41343      MAXCP1=MAXCOL+1
41344      MAXCP2=MAXCOL+2
41345      MAXCP3=MAXCOL+3
41346      MAXCP4=MAXCOL+4
41347      MAXCP5=MAXCOL+5
41348      MAXCP6=MAXCOL+6
41349C
41350C               **********************************************
41351C               **  TREAT THE POISSON DISPERSION TEST CASE  **
41352C               **********************************************
41353C
41354      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'PDTE')THEN
41355        WRITE(ICOUT,999)
41356  999   FORMAT(1X)
41357        CALL DPWRST('XXX','BUG ')
41358        WRITE(ICOUT,51)
41359   51   FORMAT('***** AT THE BEGINNING OF DPPDTE--')
41360        CALL DPWRST('XXX','BUG ')
41361        WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ,ISUBRO,MAXNXT
41362   52   FORMAT('IBUGA2,IBUGA3,IBUGQ,ISUBRO = ',4(A4,2X),I8)
41363        CALL DPWRST('XXX','BUG ')
41364      ENDIF
41365C
41366C               *********************************************************
41367C               **  STEP 1--                                           **
41368C               **  EXTRACT THE COMMAND                                **
41369C               *********************************************************
41370C
41371      ISTEPN='1'
41372      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PDTE')
41373     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
41374C
41375      ILASTC=9999
41376      ILASTZ=9999
41377      ICASAN='PDTE'
41378      IREPL='OFF'
41379      IMULT='OFF'
41380C
41381C     LOOK FOR:
41382C
41383C          POISON DISPERSION TEST
41384C          MULTIPLE
41385C          REPLICATED
41386C
41387      DO100I=0,NUMARG-1
41388C
41389        IF(I.EQ.0)THEN
41390          ICTMP1=ICOM
41391        ELSE
41392          ICTMP1=IHARG(I)
41393        ENDIF
41394        ICTMP2=IHARG(I+1)
41395        ICTMP3=IHARG(I+2)
41396C
41397        IF(ICTMP1.EQ.'=')THEN
41398          IFOUND='NO'
41399          GOTO9000
41400        ELSEIF(ICTMP1.EQ.'POIS' .AND. ICTMP2.EQ.'DISP' .AND.
41401     1         ICTMP3.EQ.'TEST')THEN
41402          IFOUND='YES'
41403          ICASAN='PDTE'
41404          ILASTC=I
41405          ILASTZ=I+2
41406        ELSEIF(ICTMP1.EQ.'REPL')THEN
41407          IREPL='ON'
41408          ILASTC=MIN(ILASTC,I)
41409          ILASTZ=MAX(ILASTZ,I)
41410        ELSEIF(ICTMP1.EQ.'MULT')THEN
41411          IMULT='ON'
41412          ILASTC=MIN(ILASTC,I)
41413          ILASTZ=MAX(ILASTZ,I)
41414        ENDIF
41415  100 CONTINUE
41416C
41417      IF(IFOUND.EQ.'NO')GOTO9000
41418C
41419      ISHIFT=ILASTZ
41420      CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
41421     1            IBUGA2,IERROR)
41422C
41423      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PDTE')THEN
41424        WRITE(ICOUT,91)ICASAN,ICASA2,IMULT,IREPL,ISHIFT
41425   91   FORMAT('DPPDTE: ICASAN,ICASA2,IMULT,IREPL,ISHIFT = ',
41426     1         4(A4,2X),I5)
41427        CALL DPWRST('XXX','BUG ')
41428      ENDIF
41429C
41430      IF(IFOUND.EQ.'NO')GOTO9000
41431      IF(IMULT.EQ.'ON')THEN
41432        IF(IREPL.EQ.'ON')THEN
41433          WRITE(ICOUT,999)
41434          CALL DPWRST('XXX','BUG ')
41435          WRITE(ICOUT,101)
41436  101     FORMAT('***** ERROR IN POISSON DISPERSION TEST--')
41437          CALL DPWRST('XXX','BUG ')
41438          WRITE(ICOUT,102)
41439  102     FORMAT('      YOU CANNOT SPECIFY BOTH "MULTIPLE" AND ',
41440     1           '"REPLICATION"')
41441          CALL DPWRST('XXX','BUG ')
41442          WRITE(ICOUT,103)
41443  103     FORMAT('      FOR THE POISSON DISPERSION TEST COMMAND.')
41444          CALL DPWRST('XXX','BUG ')
41445          IERROR='YES'
41446          GOTO9000
41447        ENDIF
41448      ENDIF
41449C
41450C               ****************************************
41451C               **  STEP 2--                          **
41452C               **  EXTRACT THE VARIABLE LIST         **
41453C               ****************************************
41454C
41455      ISTEPN='2'
41456      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PDTE')
41457     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
41458C
41459      INAME='POISSON DISPERSION TEST'
41460      MINNA=1
41461      MAXNA=100
41462      MINN2=2
41463      IFLAGE=1
41464      IFLAGM=1
41465      MINNVA=1
41466      MAXNVA=2
41467      IFLAGP=0
41468      IF(IREPL.EQ.'ON')THEN
41469        IFLAGE=1
41470        IFLAGM=0
41471        MAXNVA=7
41472      ELSEIF(IMULT.EQ.'ON')THEN
41473        IFLAGE=0
41474        IFLAGM=1
41475        MAXNVA=MAXSPN
41476      ENDIF
41477      JMIN=1
41478      JMAX=NUMARG
41479C
41480      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
41481     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
41482     1            JMIN,JMAX,
41483     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
41484     1            IVARN1,IVARN2,IVARTY,PVAR,
41485     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
41486     1            MINNVA,MAXNVA,
41487     1            IFLAGM,IFLAGP,
41488     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
41489      IF(IERROR.EQ.'YES')GOTO9000
41490C
41491      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PDTE')THEN
41492        WRITE(ICOUT,999)
41493        CALL DPWRST('XXX','BUG ')
41494        WRITE(ICOUT,281)
41495  281   FORMAT('***** AFTER CALL DPPARS--')
41496        CALL DPWRST('XXX','BUG ')
41497        WRITE(ICOUT,282)NQ,NUMVAR
41498  282   FORMAT('NQ,NUMVAR = ',2I8)
41499        CALL DPWRST('XXX','BUG ')
41500        IF(NUMVAR.GT.0)THEN
41501          DO285I=1,NUMVAR
41502            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
41503     1                      ICOLR(I)
41504  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
41505     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
41506            CALL DPWRST('XXX','BUG ')
41507  285     CONTINUE
41508        ENDIF
41509      ENDIF
41510C
41511C               ***********************************************
41512C               **  STEP 5--                                 **
41513C               **  DETERMINE:                               **
41514C               **  1) NUMBER OF REPLICATION VARIABLES (0-6) **
41515C               **  2) NUMBER OF RESPONSE    VARIABLES (>= 1)**
41516C               ***********************************************
41517C
41518      ISTEPN='5'
41519      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PDTE')
41520     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
41521C
41522      NRESP=0
41523      NREPL=0
41524      IF(IMULT.EQ.'ON')THEN
41525        NRESP=NUMVAR
41526        ICASE='RAW'
41527      ELSEIF(IREPL.EQ.'ON')THEN
41528        NRESP=1
41529        NREPL=NUMVAR-NRESP
41530        ICASE='RAW'
41531        IF(NREPL.LT.1 .OR. NREPL.GT.6)THEN
41532          WRITE(ICOUT,999)
41533          CALL DPWRST('XXX','BUG ')
41534          WRITE(ICOUT,101)
41535          CALL DPWRST('XXX','BUG ')
41536          WRITE(ICOUT,511)
41537  511     FORMAT('      FOR THE REPLICATION CASE, THE NUMBER OF ',
41538     1           'REPLICATION VARIABLES')
41539          CALL DPWRST('XXX','BUG ')
41540          WRITE(ICOUT,512)
41541  512     FORMAT('      MUST BE BETWEEN ONE AND SIX.')
41542          CALL DPWRST('XXX','BUG ')
41543          WRITE(ICOUT,513)NREPL
41544  513     FORMAT('      THE NUMBER OF REPLICATION VARIABLES = ',I5)
41545          CALL DPWRST('XXX','BUG ')
41546          IERROR='YES'
41547          GOTO9000
41548        ENDIF
41549      ELSE
41550        NRESP=NUMVAR
41551        ICASE='RAW'
41552        IF(NUMVAR.EQ.2)ICASE='GROU'
41553      ENDIF
41554C
41555      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PDTE')THEN
41556        WRITE(ICOUT,521)NRESP,NREPL
41557  521   FORMAT('NRESP,NREPL = ',2I5)
41558        CALL DPWRST('XXX','BUG ')
41559      ENDIF
41560C
41561C               ******************************************************
41562C               **  STEP 6--                                        **
41563C               **  GENERATE THE POISSON DISPERSION TEST FOR THE    **
41564C               **  VARIOUS CASES                                   **
41565C               ******************************************************
41566C
41567      ISTEPN='6'
41568      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PDTE')
41569     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
41570C
41571C               ******************************************
41572C               **  STEP 8A--                           **
41573C               **  CASE 1: NO REPLICATION VARIABLES    **
41574C               ******************************************
41575C
41576      PVALLT=CPUMIN
41577      PVALUT=CPUMIN
41578      PVAL=CPUMIN
41579C
41580      IF(NREPL.LT.1)THEN
41581        ISTEPN='8A'
41582        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PDTE')
41583     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
41584C
41585C       LOOP THROUGH EACH OF THE RESPONSE VARIABLES.  NEED
41586C       TO HANDLE FREQUENCY DATA CASE.
41587C
41588        NCURVE=0
41589        NUMVA2=1
41590        NLAST=NUMVAR
41591        IF(ICASE.EQ.'GROU')THEN
41592          NUMVA2=2
41593          NLAST=1
41594        ENDIF
41595C
41596        DO810IRESP=1,NLAST
41597          NCURVE=NCURVE+1
41598C
41599          IINDX=ICOLR(IRESP)
41600          PID(1)=CPUMIN
41601          IVARID(1)=IVARN1(IRESP)
41602          IVARI2(1)=IVARN2(IRESP)
41603          IF(ICASE.EQ.'GROU')THEN
41604            IINDX=ICOLR(IRESP+1)
41605            PID(2)=CPUMIN
41606            IVARID(2)=IVARN1(IRESP+1)
41607            IVARI2(2)=IVARN2(IRESP+1)
41608          ENDIF
41609C
41610          IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PDTE')THEN
41611            WRITE(ICOUT,999)
41612            CALL DPWRST('XXX','BUG ')
41613            WRITE(ICOUT,811)IRESP,NCURVE
41614  811       FORMAT('IRESP,NCURVE = ',2I5)
41615            CALL DPWRST('XXX','BUG ')
41616          ENDIF
41617C
41618          ICOL=IRESP
41619          CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
41620     1                INAME,IVARN1,IVARN2,IVARTY,
41621     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
41622     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
41623     1                MAXCP4,MAXCP5,MAXCP6,
41624     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
41625     1                Y,X,XTEMP1,NLOCAL,NLOCA2,NLOCA3,ICASET,
41626     1                IBUGA3,ISUBRO,IFOUND,IERROR)
41627          IF(IERROR.EQ.'YES')GOTO9000
41628C
41629C         *****************************************************
41630C         **  STEP 8B--                                      **
41631C         *****************************************************
41632C
41633          IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'PDTE')THEN
41634            ISTEPN='8B'
41635            CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
41636            WRITE(ICOUT,999)
41637            CALL DPWRST('XXX','BUG ')
41638            WRITE(ICOUT,822)
41639  822       FORMAT('***** FROM THE MIDDLE  OF DPPDTE--')
41640            CALL DPWRST('XXX','BUG ')
41641            WRITE(ICOUT,823)ICASAN,NUMVAR,NLOCAL
41642  823       FORMAT('ICASAN,NUMVAR,NQ = ',A4,2X,2I8)
41643            CALL DPWRST('XXX','BUG ')
41644            IF(NLOCAL.GE.1)THEN
41645              DO825I=1,NLOCAL
41646                WRITE(ICOUT,826)I,Y(I),X(I)
41647  826           FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
41648                CALL DPWRST('XXX','BUG ')
41649  825         CONTINUE
41650            ENDIF
41651          ENDIF
41652C
41653          CALL DPPDT2(Y,X,NLOCAL,ICASE,
41654     1                XTEMP1,XTEMP2,MAXNXT,
41655     1                ICAPSW,ICAPTY,IFORSW,
41656     1                IVARID,IVARI2,
41657     1                STATVA,STATCD,STATNU,PVAL,
41658     1                CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50,
41659     1                CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50,
41660     1                IBUGA3,ISUBRO,IERROR)
41661          IF(IERROR.EQ.'YES')GOTO9000
41662C
41663C               ***************************************
41664C               **  STEP 8C--                        **
41665C               **  UPDATE INTERNAL DATAPLOT TABLES  **
41666C               ***************************************
41667C
41668          ISTEPN='8C'
41669          IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PDTE')
41670     1      CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
41671C
41672          IF(ICASE.EQ.'RAW' .AND. NRESP.GT.1)THEN
41673            IFLAGU='FILE'
41674          ELSEIF(ICASE.EQ.'GROU' .AND. NRESP.GT.2)THEN
41675            IFLAGU='FILE'
41676          ELSE
41677            IFLAGU='ON'
41678          ENDIF
41679          IFRST=.FALSE.
41680          ILAST=.FALSE.
41681          IF(IRESP.EQ.1)IFRST=.TRUE.
41682          IF(IRESP.EQ.NRESP)ILAST=.TRUE.
41683          CALL DPTTE5(ICASAN,STATVA,STATCD,STATNU,
41684     1                STATVA,STATCD,STATNU,
41685     1                PVAL,PVALLT,PVALUT,
41686     1                CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50,
41687     1                CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50,
41688     1                IFLAGU,IFRST,ILAST,
41689     1                IBUGA2,IBUGA3,ISUBRO,IERROR)
41690C
41691  810   CONTINUE
41692C
41693C               ****************************************************
41694C               **  STEP 9A--                                     **
41695C               **  CASE 3: ONE OR MORE REPLICATION VARIABLES.    **
41696C               **          FOR THIS CASE, THE NUMBER OF RESPONSE **
41697C               **          VARIABLES MUST BE EXACTLY 1.          **
41698C               **          FOR THIS CASE, ALL VARIABLES MUST     **
41699C               **          HAVE THE SAME LENGTH.                 **
41700C               ****************************************************
41701C
41702      ELSEIF(IREPL.EQ.'ON')THEN
41703        ISTEPN='9A'
41704        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PDTE')
41705     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
41706C
41707        J=0
41708        IMAX=NRIGHT(1)
41709        IF(NQ.LT.NRIGHT(1))IMAX=NQ
41710        DO910I=1,IMAX
41711          IF(ISUB(I).EQ.0)GOTO910
41712          J=J+1
41713C
41714C         RESPONSE VARIABLE IN Y
41715C
41716          ICOLC=1
41717          IJ=MAXN*(ICOLR(ICOLC)-1)+I
41718          IF(ICOLR(ICOLC).LE.MAXCOL)Y(J)=V(IJ)
41719          IF(ICOLR(ICOLC).EQ.MAXCP1)Y(J)=PRED(I)
41720          IF(ICOLR(ICOLC).EQ.MAXCP2)Y(J)=RES(I)
41721          IF(ICOLR(ICOLC).EQ.MAXCP3)Y(J)=YPLOT(I)
41722          IF(ICOLR(ICOLC).EQ.MAXCP4)Y(J)=XPLOT(I)
41723          IF(ICOLR(ICOLC).EQ.MAXCP5)Y(J)=X2PLOT(I)
41724          IF(ICOLR(ICOLC).EQ.MAXCP6)Y(J)=TAGPLO(I)
41725C
41726          IF(NREPL.GE.1)THEN
41727            DO920IR=1,MIN(NREPL,6)
41728              ICOLC=ICOLC+1
41729              ICOLT=ICOLR(ICOLC)
41730              IJ=MAXN*(ICOLT-1)+I
41731              IF(ICOLT.LE.MAXCOL)XDESGN(J,IR)=V(IJ)
41732              IF(ICOLT.EQ.MAXCP1)XDESGN(J,IR)=PRED(I)
41733              IF(ICOLT.EQ.MAXCP2)XDESGN(J,IR)=RES(I)
41734              IF(ICOLT.EQ.MAXCP3)XDESGN(J,IR)=YPLOT(I)
41735              IF(ICOLT.EQ.MAXCP4)XDESGN(J,IR)=XPLOT(I)
41736              IF(ICOLT.EQ.MAXCP5)XDESGN(J,IR)=X2PLOT(I)
41737              IF(ICOLT.EQ.MAXCP6)XDESGN(J,IR)=TAGPLO(I)
41738  920       CONTINUE
41739          ENDIF
41740C
41741  910   CONTINUE
41742        NLOCAL=J
41743C
41744C       *****************************************************
41745C       **  STEP 9B--                                      **
41746C       **  CALL DPPDT2 TO PERFORM POISSON DISPERSION TEST.**
41747C       *****************************************************
41748C
41749C
41750        IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'PDTE')THEN
41751          ISTEPN='9C'
41752          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
41753          WRITE(ICOUT,999)
41754          CALL DPWRST('XXX','BUG ')
41755          WRITE(ICOUT,941)
41756  941     FORMAT('***** FROM THE MIDDLE  OF DPPDTE--')
41757          CALL DPWRST('XXX','BUG ')
41758          WRITE(ICOUT,942)ICASAN,NUMVAR,NLOCAL,NREPL
41759  942     FORMAT('ICASAN,NUMVAR,NLOCAL,NREPL = ',A4,2X,3I8)
41760          CALL DPWRST('XXX','BUG ')
41761          IF(NLOCAL.GE.1)THEN
41762            DO945I=1,NLOCAL
41763              WRITE(ICOUT,946)I,Y(I),XDESGN(I,1),XDESGN(I,2)
41764  946         FORMAT('I,Y(I),XDESGN(I,1),XDESGN(I,2) = ',
41765     1               I8,4F12.5)
41766              CALL DPWRST('XXX','BUG ')
41767  945       CONTINUE
41768          ENDIF
41769        ENDIF
41770C
41771C       *****************************************************
41772C       **  STEP 9C--                                      **
41773C       **  FIND THE DISTINCT VALUES IN EACH OF THE        **
41774C       **  REPLICATION VARIABLES.                         **
41775C       *****************************************************
41776C
41777        CALL DPPP5(XDESGN(1,1),XDESGN(1,2),XDESGN(1,3),
41778     1             XDESGN(1,4),XDESGN(1,5),XDESGN(1,6),
41779     1             NREPL,NLOCAL,MAXOBV,
41780     1             XIDTEM,XIDTE2,XIDTE3,XIDTE4,XIDTE5,XIDTE6,
41781     1             XTEMP1,XTEMP2,
41782     1             NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,NUMSE6,
41783     1             IBUGA3,ISUBRO,IERROR)
41784C
41785C       *****************************************************
41786C       **  STEP 9D--                                      **
41787C       **  NOW LOOP THROUGH THE VARIOUS REPLICATIONS      **
41788C       *****************************************************
41789C
41790        NPLOTP=0
41791        NCURVE=0
41792        IADD=1
41793C
41794        IF(NREPL.EQ.1)THEN
41795          J=0
41796          DO1110ISET1=1,NUMSE1
41797            K=0
41798            PID(IADD+1)=XIDTEM(ISET1)
41799            DO1130I=1,NLOCAL
41800              IF(XIDTEM(ISET1).EQ.XDESGN(I,1))THEN
41801                K=K+1
41802                TEMP1(K)=Y(I)
41803              ENDIF
41804 1130       CONTINUE
41805            NTEMP=K
41806            NCURVE=NCURVE+1
41807            NPLOT1=NPLOTP
41808            IF(NTEMP.GT.0)THEN
41809              CALL DPPDT2(TEMP1,X,NLOCAL,ICASE,
41810     1                    XTEMP1,XTEMP2,MAXNXT,
41811     1                    ICAPSW,ICAPTY,IFORSW,
41812     1                    IVARID,IVARI2,
41813     1                    STATVA,STATCD,STATNU,PVAL,
41814     1                    CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50,
41815     1                    CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50,
41816     1                    IBUGA3,ISUBRO,IERROR)
41817              IF(IERROR.EQ.'YES')GOTO9000
41818            ENDIF
41819            NPLOT2=NPLOTP
41820            IFLAGU='FILE'
41821            IFRST=.FALSE.
41822            ILAST=.FALSE.
41823            IF(NCURVE.EQ.1)IFRST=.TRUE.
41824            IF(NCURVE.EQ.NUMSE1)ILAST=.TRUE.
41825            NPTEMP=NPLOT2-NPLOT1
41826            CALL DPTTE5(ICASAN,STATVA,STATCD,STATNU,
41827     1                  STATVA,STATCD,STATNU,
41828     1                  PVAL,PVALLT,PVALUT,
41829     1                  CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50,
41830     1                  CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50,
41831     1                  IFLAGU,IFRST,ILAST,
41832     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
41833 1110     CONTINUE
41834        ELSEIF(NREPL.EQ.2)THEN
41835          J=0
41836          NTOT=NUMSE1*NUMSE2
41837          DO1210ISET1=1,NUMSE1
41838          DO1220ISET2=1,NUMSE2
41839            K=0
41840            PID(1+IADD)=XIDTEM(ISET1)
41841            PID(2+IADD)=XIDTE2(ISET2)
41842            DO1290I=1,NLOCAL
41843              IF(
41844     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
41845     1           XIDTE2(ISET2).EQ.XDESGN(I,2)
41846     1          )THEN
41847                K=K+1
41848                TEMP1(K)=Y(I)
41849              ENDIF
41850 1290       CONTINUE
41851            NTEMP=K
41852            NCURVE=NCURVE+1
41853            NPLOT1=NPLOTP
41854            IF(NTEMP.GT.0)THEN
41855              CALL DPPDT2(TEMP1,X,NLOCAL,ICASE,
41856     1                    XTEMP1,XTEMP2,MAXNXT,
41857     1                    ICAPSW,ICAPTY,IFORSW,
41858     1                    IVARID,IVARI2,
41859     1                    STATVA,STATCD,STATNU,PVAL,
41860     1                    CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50,
41861     1                    CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50,
41862     1                    IBUGA3,ISUBRO,IERROR)
41863              IF(IERROR.EQ.'YES')GOTO9000
41864            ENDIF
41865            NPLOT2=NPLOTP
41866            IFLAGU='FILE'
41867            IFRST=.FALSE.
41868            ILAST=.FALSE.
41869            IF(NCURVE.EQ.1)IFRST=.TRUE.
41870            IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
41871            NPTEMP=NPLOT2-NPLOT1
41872            CALL DPTTE5(ICASAN,STATVA,STATCD,STATNU,
41873     1                  STATVA,STATCD,STATNU,
41874     1                  PVAL,PVALLT,PVALUT,
41875     1                  CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50,
41876     1                  CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50,
41877     1                  IFLAGU,IFRST,ILAST,
41878     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
41879 1220     CONTINUE
41880 1210     CONTINUE
41881        ELSEIF(NREPL.EQ.3)THEN
41882          J=0
41883          NTOT=NUMSE1*NUMSE2*NUMSE3
41884          DO1310ISET1=1,NUMSE1
41885          DO1320ISET2=1,NUMSE2
41886          DO1330ISET3=1,NUMSE3
41887            K=0
41888            PID(1+IADD)=XIDTEM(ISET1)
41889            PID(2+IADD)=XIDTE2(ISET2)
41890            PID(3+IADD)=XIDTE3(ISET3)
41891            DO1390I=1,NLOCAL
41892              IF(
41893     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
41894     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
41895     1           XIDTE3(ISET3).EQ.XDESGN(I,3)
41896     1          )THEN
41897                K=K+1
41898                TEMP1(K)=Y(I)
41899              ENDIF
41900 1390       CONTINUE
41901            NTEMP=K
41902            NCURVE=NCURVE+1
41903            NPLOT1=NPLOTP
41904            IF(NTEMP.GT.0)THEN
41905              CALL DPPDT2(TEMP1,X,NLOCAL,ICASE,
41906     1                    XTEMP1,XTEMP2,MAXNXT,
41907     1                    ICAPSW,ICAPTY,IFORSW,
41908     1                    IVARID,IVARI2,
41909     1                    STATVA,STATCD,STATNU,PVAL,
41910     1                    CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50,
41911     1                    CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50,
41912     1                    IBUGA3,ISUBRO,IERROR)
41913              IF(IERROR.EQ.'YES')GOTO9000
41914            ENDIF
41915            NPLOT2=NPLOTP
41916            IFLAGU='FILE'
41917            IFRST=.FALSE.
41918            ILAST=.FALSE.
41919            IF(NCURVE.EQ.1)IFRST=.TRUE.
41920            IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
41921            NPTEMP=NPLOT2-NPLOT1
41922            CALL DPTTE5(ICASAN,STATVA,STATCD,STATNU,
41923     1                  STATVA,STATCD,STATNU,
41924     1                  PVAL,PVALLT,PVALUT,
41925     1                  CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50,
41926     1                  CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50,
41927     1                  IFLAGU,IFRST,ILAST,
41928     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
41929 1330     CONTINUE
41930 1320     CONTINUE
41931 1310     CONTINUE
41932        ELSEIF(NREPL.EQ.4)THEN
41933          J=0
41934          NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4
41935          DO1410ISET1=1,NUMSE1
41936          DO1420ISET2=1,NUMSE2
41937          DO1430ISET3=1,NUMSE3
41938          DO1440ISET4=1,NUMSE4
41939            K=0
41940            PID(1+IADD)=XIDTEM(ISET1)
41941            PID(2+IADD)=XIDTE2(ISET2)
41942            PID(3+IADD)=XIDTE3(ISET3)
41943            PID(4+IADD)=XIDTE4(ISET4)
41944            DO1490I=1,NLOCAL
41945              IF(
41946     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
41947     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
41948     1           XIDTE3(ISET3).EQ.XDESGN(I,3) .AND.
41949     1           XIDTE4(ISET4).EQ.XDESGN(I,4)
41950     1          )THEN
41951                K=K+1
41952                TEMP1(K)=Y(I)
41953              ENDIF
41954 1490       CONTINUE
41955            NTEMP=K
41956            NCURVE=NCURVE+1
41957            NPLOT1=NPLOTP
41958            IF(NTEMP.GT.0)THEN
41959              CALL DPPDT2(TEMP1,X,NLOCAL,ICASE,
41960     1                    XTEMP1,XTEMP2,MAXNXT,
41961     1                    ICAPSW,ICAPTY,IFORSW,
41962     1                    IVARID,IVARI2,
41963     1                    STATVA,STATCD,STATNU,PVAL,
41964     1                    CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50,
41965     1                    CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50,
41966     1                    IBUGA3,ISUBRO,IERROR)
41967              IF(IERROR.EQ.'YES')GOTO9000
41968            ENDIF
41969            NPLOT2=NPLOTP
41970            IFLAGU='FILE'
41971            IFRST=.FALSE.
41972            ILAST=.FALSE.
41973            IF(NCURVE.EQ.1)IFRST=.TRUE.
41974            IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
41975            NPTEMP=NPLOT2-NPLOT1
41976            CALL DPWSH4(STATVA,PVAL,
41977     1                  IFLAGU,IFRST,ILAST,ICASAN,
41978     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
41979 1440     CONTINUE
41980 1430     CONTINUE
41981 1420     CONTINUE
41982 1410     CONTINUE
41983        ELSEIF(NREPL.EQ.5)THEN
41984          J=0
41985          NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5
41986          DO1510ISET1=1,NUMSE1
41987          DO1520ISET2=1,NUMSE2
41988          DO1530ISET3=1,NUMSE3
41989          DO1540ISET4=1,NUMSE4
41990          DO1550ISET5=1,NUMSE5
41991            K=0
41992            PID(1+IADD)=XIDTEM(ISET1)
41993            PID(2+IADD)=XIDTE2(ISET2)
41994            PID(3+IADD)=XIDTE3(ISET3)
41995            PID(4+IADD)=XIDTE4(ISET4)
41996            PID(5+IADD)=XIDTE5(ISET4)
41997            DO1590I=1,NLOCAL
41998              IF(
41999     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
42000     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
42001     1           XIDTE3(ISET3).EQ.XDESGN(I,3) .AND.
42002     1           XIDTE4(ISET4).EQ.XDESGN(I,4) .AND.
42003     1           XIDTE5(ISET5).EQ.XDESGN(I,5)
42004     1          )THEN
42005                K=K+1
42006                TEMP1(K)=Y(I)
42007              ENDIF
42008 1590       CONTINUE
42009            NTEMP=K
42010            NCURVE=NCURVE+1
42011            NPLOT1=NPLOTP
42012            IF(NTEMP.GT.0)THEN
42013              CALL DPPDT2(TEMP1,X,NLOCAL,ICASE,
42014     1                    XTEMP1,XTEMP2,MAXNXT,
42015     1                    ICAPSW,ICAPTY,IFORSW,
42016     1                    IVARID,IVARI2,
42017     1                    STATVA,STATCD,STATNU,PVAL,
42018     1                    CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50,
42019     1                    CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50,
42020     1                    IBUGA3,ISUBRO,IERROR)
42021              IF(IERROR.EQ.'YES')GOTO9000
42022            ENDIF
42023            NPLOT2=NPLOTP
42024            IFLAGU='FILE'
42025            IFRST=.FALSE.
42026            ILAST=.FALSE.
42027            IF(NCURVE.EQ.1)IFRST=.TRUE.
42028            IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
42029            NPTEMP=NPLOT2-NPLOT1
42030            CALL DPTTE5(ICASAN,STATVA,STATCD,STATNU,
42031     1                  STATVA,STATCD,STATNU,
42032     1                  PVAL,PVALLT,PVALUT,
42033     1                  CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50,
42034     1                  CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50,
42035     1                  IFLAGU,IFRST,ILAST,
42036     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
42037 1550     CONTINUE
42038 1540     CONTINUE
42039 1530     CONTINUE
42040 1520     CONTINUE
42041 1510     CONTINUE
42042        ELSEIF(NREPL.EQ.6)THEN
42043          J=0
42044          NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5*NUMSE6
42045          DO1610ISET1=1,NUMSE1
42046          DO1620ISET2=1,NUMSE2
42047          DO1630ISET3=1,NUMSE3
42048          DO1640ISET4=1,NUMSE4
42049          DO1650ISET5=1,NUMSE5
42050          DO1660ISET6=1,NUMSE6
42051            K=0
42052            PID(1+IADD)=XIDTEM(ISET1)
42053            PID(2+IADD)=XIDTE2(ISET2)
42054            PID(3+IADD)=XIDTE3(ISET3)
42055            PID(4+IADD)=XIDTE4(ISET4)
42056            PID(5+IADD)=XIDTE5(ISET4)
42057            PID(6+IADD)=XIDTE6(ISET4)
42058            DO1690I=1,NLOCAL
42059              IF(
42060     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
42061     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
42062     1           XIDTE3(ISET3).EQ.XDESGN(I,3) .AND.
42063     1           XIDTE4(ISET4).EQ.XDESGN(I,4) .AND.
42064     1           XIDTE5(ISET5).EQ.XDESGN(I,5) .AND.
42065     1           XIDTE6(ISET6).EQ.XDESGN(I,6)
42066     1          )THEN
42067                K=K+1
42068                TEMP1(K)=Y(I)
42069              ENDIF
42070 1690       CONTINUE
42071            NTEMP=K
42072            NCURVE=NCURVE+1
42073            NPLOT1=NPLOTP
42074            IF(NTEMP.GT.0)THEN
42075              CALL DPPDT2(TEMP1,X,NLOCAL,ICASE,
42076     1                    XTEMP1,XTEMP2,MAXNXT,
42077     1                    ICAPSW,ICAPTY,IFORSW,
42078     1                    IVARID,IVARI2,
42079     1                    STATVA,STATCD,STATNU,PVAL,
42080     1                    CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50,
42081     1                    CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50,
42082     1                    IBUGA3,ISUBRO,IERROR)
42083              IF(IERROR.EQ.'YES')GOTO9000
42084            ENDIF
42085            NPLOT2=NPLOTP
42086            IFLAGU='FILE'
42087            IFRST=.FALSE.
42088            ILAST=.FALSE.
42089            IF(NCURVE.EQ.1)IFRST=.TRUE.
42090            IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
42091            NPTEMP=NPLOT2-NPLOT1
42092            CALL DPTTE5(ICASAN,STATVA,STATCD,STATNU,
42093     1                  STATVA,STATCD,STATNU,
42094     1                  PVAL,PVALLT,PVALUT,
42095     1                  CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50,
42096     1                  CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50,
42097     1                  IFLAGU,IFRST,ILAST,
42098     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
42099 1660     CONTINUE
42100 1650     CONTINUE
42101 1640     CONTINUE
42102 1630     CONTINUE
42103 1620     CONTINUE
42104 1610     CONTINUE
42105        ENDIF
42106C
42107      ENDIF
42108C
42109C               *****************
42110C               **  STEP 90--  **
42111C               **  EXIT       **
42112C               *****************
42113C
42114 9000 CONTINUE
42115      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'PDTE')THEN
42116        WRITE(ICOUT,999)
42117        CALL DPWRST('XXX','BUG ')
42118        WRITE(ICOUT,9011)
42119 9011   FORMAT('***** AT THE END       OF DPPDTE--')
42120        CALL DPWRST('XXX','BUG ')
42121        WRITE(ICOUT,9016)IFOUND,IERROR
42122 9016   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
42123        CALL DPWRST('XXX','BUG ')
42124      ENDIF
42125C
42126      RETURN
42127      END
42128      SUBROUTINE DPPDT2(Y,X,N,ICASE,
42129     1                  XTEMP1,XTEMP2,MAXNXT,
42130     1                  ICAPSW,ICAPTY,IFORSW,
42131     1                  IVARID,IVARI2,
42132     1                  STATVA,STATCD,STATNU,PVALUE,
42133     1                  CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50,
42134     1                  CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50,
42135     1                  IBUGA3,ISUBRO,IERROR)
42136C
42137C     PURPOSE--THIS ROUTINE CARRIES OUT A POISSON DISPERSION TEST
42138C              (EITHER RAW DATA OR FREQUENCY DATA).
42139C     EXAMPLE--POISSON DISPERSION TEST Y
42140C              POISSON DISPERSION TEST Y X
42141C     WRITTEN BY--ALAN HECKERT
42142C                 STATISTICAL ENGINEERING DIVISION
42143C                 INFORMATION TECHNOLOGY LABORATORY
42144C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
42145C                 GAITHERSBURG, MD 20899-8980
42146C                 PHONE--301-975-2899
42147C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
42148C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
42149C     LANGUAGE--ANSI FORTRAN (1977)
42150C     VERSION NUMBER--2013/11
42151C     ORIGINAL VERSION--NOVEMBER  2013.
42152C
42153C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
42154C
42155      CHARACTER*4 IVARID(2)
42156      CHARACTER*4 IVARI2(2)
42157      CHARACTER*4 ICAPSW
42158      CHARACTER*4 ICAPTY
42159      CHARACTER*4 IFORSW
42160      CHARACTER*4 ICASE
42161      CHARACTER*4 IBUGA3
42162      CHARACTER*4 ISUBRO
42163      CHARACTER*4 IERROR
42164C
42165      CHARACTER*4 IWRITE
42166C
42167      CHARACTER*4 ISUBN1
42168      CHARACTER*4 ISUBN2
42169      CHARACTER*4 ISTEPN
42170C
42171C---------------------------------------------------------------------
42172C
42173      DIMENSION Y(*)
42174      DIMENSION X(*)
42175      DIMENSION XTEMP1(*)
42176      DIMENSION XTEMP2(*)
42177C
42178      PARAMETER (NUMALP=6)
42179      REAL ALPHA(NUMALP)
42180      REAL LOWLIM(NUMALP)
42181      REAL UPPLIM(NUMALP)
42182C
42183      PARAMETER(NUMCLI=5)
42184      PARAMETER(MAXLIN=3)
42185      PARAMETER (MAXROW=NUMALP)
42186      PARAMETER (MAXRO2=40)
42187      CHARACTER*60 ITITLE
42188      CHARACTER*60 ITITLZ
42189      CHARACTER*60 ITITL9
42190      CHARACTER*60 ITEXT(MAXRO2)
42191      CHARACTER*4  ALIGN(NUMCLI)
42192      CHARACTER*4  VALIGN(NUMCLI)
42193      REAL         AVALUE(MAXRO2)
42194      INTEGER      NCTEXT(MAXRO2)
42195      INTEGER      IDIGIT(MAXRO2)
42196      INTEGER      NTOT(MAXRO2)
42197      CHARACTER*60 ITITL2(MAXLIN,NUMCLI)
42198      CHARACTER*15 IVALUE(MAXROW,NUMCLI)
42199      CHARACTER*4  ITYPCO(NUMCLI)
42200      INTEGER      NCTIT2(MAXLIN,NUMCLI)
42201      INTEGER      NCVALU(MAXROW,NUMCLI)
42202      INTEGER      IWHTML(NUMCLI)
42203      INTEGER      IWRTF(NUMCLI)
42204      REAL         AMAT(MAXROW,NUMCLI)
42205      LOGICAL IFRST
42206      LOGICAL ILAST
42207      LOGICAL IFLAGS
42208      LOGICAL IFLAGE
42209C
42210C---------------------------------------------------------------------
42211C
42212      INCLUDE 'DPCOP2.INC'
42213C
42214      DATA ALPHA/0.50, 0.80, 0.90, 0.95, 0.99, 0.999/
42215C
42216C-----START POINT-----------------------------------------------------
42217C
42218      ISUBN1='DPPD'
42219      ISUBN2='T2  '
42220      IERROR='NO'
42221      IWRITE='OFF'
42222C
42223      DO11I=1,MAXNXT
42224        XTEMP1(I)=0.0
42225        XTEMP2(I)=0.0
42226   11 CONTINUE
42227C
42228      NUMDIG=7
42229      IF(IFORSW.EQ.'1')NUMDIG=1
42230      IF(IFORSW.EQ.'2')NUMDIG=2
42231      IF(IFORSW.EQ.'3')NUMDIG=3
42232      IF(IFORSW.EQ.'4')NUMDIG=4
42233      IF(IFORSW.EQ.'5')NUMDIG=5
42234      IF(IFORSW.EQ.'6')NUMDIG=6
42235      IF(IFORSW.EQ.'7')NUMDIG=7
42236      IF(IFORSW.EQ.'8')NUMDIG=8
42237      IF(IFORSW.EQ.'9')NUMDIG=9
42238      IF(IFORSW.EQ.'0')NUMDIG=0
42239      IF(IFORSW.EQ.'E')NUMDIG=-2
42240      IF(IFORSW.EQ.'-2')NUMDIG=-2
42241      IF(IFORSW.EQ.'-3')NUMDIG=-3
42242      IF(IFORSW.EQ.'-4')NUMDIG=-4
42243      IF(IFORSW.EQ.'-5')NUMDIG=-5
42244      IF(IFORSW.EQ.'-6')NUMDIG=-6
42245      IF(IFORSW.EQ.'-7')NUMDIG=-7
42246      IF(IFORSW.EQ.'-8')NUMDIG=-8
42247      IF(IFORSW.EQ.'-9')NUMDIG=-9
42248C
42249      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PDT2')THEN
42250        WRITE(ICOUT,999)
42251  999   FORMAT(1X)
42252        CALL DPWRST('XXX','WRIT')
42253        WRITE(ICOUT,51)
42254   51   FORMAT('**** AT THE BEGINNING OF DPPDT2--')
42255        CALL DPWRST('XXX','WRIT')
42256        WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASAN,ICASE,N,MAXNXT
42257   52   FORMAT('IBUGA3,ISUBRO,ICASAN,ICASE,N,MAXNXT = ',4(A4,2X),2I8)
42258        CALL DPWRST('XXX','WRIT')
42259        IF(N.GE.1)THEN
42260          DO56I=1,N
42261            WRITE(ICOUT,57)I,Y(I),X(I)
42262   57       FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
42263            CALL DPWRST('XXX','WRIT')
42264   56     CONTINUE
42265        ENDIF
42266      ENDIF
42267C
42268C               ************************************
42269C               **   STEP 1--                     **
42270C               ************************************
42271C
42272      ISTEPN='1'
42273      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PDT2')
42274     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
42275C
42276C               ***********************************
42277C               **  STEP 21--                    **
42278C               **  CARRY OUT CALCULATIONS FOR A **
42279C               **  POISSON DISPERSION TEST      **
42280C               ***********************************
42281C
42282      ISTEPN='21'
42283      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PDT2')
42284     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
42285C
42286      CALL DPPDT3(Y,X,N,ICASE,
42287     1            STATVA,STATCD,STATNU,PVALUE,
42288     1            YMEAN,YSD,
42289     1            ISUBRO,IBUGA3,IERROR)
42290C
42291      IDF=INT(STATNU+0.1)
42292C
42293      CALL CHSPPF(.0005,IDF,CTL999)
42294      CALL CHSPPF(.005,IDF,CUTL99)
42295      CALL CHSPPF(.025,IDF,CUTL95)
42296      CALL CHSPPF(.05,IDF,CUTL90)
42297      CALL CHSPPF(.1,IDF,CUTL80)
42298      CALL CHSPPF(.25,IDF,CUTL50)
42299      CALL CHSPPF(.75,IDF,CUTU50)
42300      CALL CHSPPF(.90,IDF,CUTU80)
42301      CALL CHSPPF(.95,IDF,CUTU90)
42302      CALL CHSPPF(.975,IDF,CUTU95)
42303      CALL CHSPPF(.995,IDF,CUTU99)
42304      CALL CHSPPF(.9995,IDF,CTU999)
42305C
42306      DO200I=1,NUMALP
42307        ALPHAT=ALPHA(I)
42308        ALPHAL=(1.0 - ALPHAT)/2.0
42309        ALPHAU=1.0 - ALPHAL
42310        CALL CHSPPF(ALPHAL,IDF,CUTLOW)
42311        LOWLIM(I)=CUTLOW
42312        CALL CHSPPF(ALPHAU,IDF,CUTUPP)
42313        UPPLIM(I)=CUTUPP
42314  200 CONTINUE
42315C
42316C               *********************************
42317C               **   STEP 22--                 **
42318C               **   WRITE OUT EVERYTHING FOR  **
42319C               **   POISSON DISPERSION TEST   **
42320C               *********************************
42321C
42322      ISTEPN='22'
42323      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PDT2')
42324     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
42325C
42326      IF(IPRINT.EQ.'OFF')GOTO9000
42327C
42328      ITITLE='Poisson Dispersion Test'
42329      NCTITL=24
42330      ITITLZ=' '
42331      NCTITZ=0
42332C
42333      ICNT=1
42334      ITEXT(ICNT)=' '
42335      NCTEXT(ICNT)=0
42336      AVALUE(ICNT)=0.0
42337      IDIGIT(ICNT)=-1
42338C
42339      IF(ICASE.EQ.'RAW')THEN
42340        ICNT=ICNT+1
42341        ITEXT(ICNT)='Response Variable: '
42342        WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1)(1:4)
42343        WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1)(1:4)
42344        NCTEXT(ICNT)=27
42345        AVALUE(ICNT)=0.0
42346        IDIGIT(ICNT)=-1
42347      ELSE
42348        ICNT=ICNT+1
42349        ITEXT(ICNT)='Frequency Variable:       '
42350        WRITE(ITEXT(ICNT)(27:30),'(A4)')IVARID(1)(1:4)
42351        WRITE(ITEXT(ICNT)(31:35),'(A4)')IVARI2(1)(1:4)
42352        NCTEXT(ICNT)=35
42353        AVALUE(ICNT)=0.0
42354        IDIGIT(ICNT)=-1
42355        ICNT=ICNT+1
42356        ITEXT(ICNT)='Class Mid-Point Variable: '
42357        WRITE(ITEXT(ICNT)(27:30),'(A4)')IVARID(2)(1:4)
42358        WRITE(ITEXT(ICNT)(31:35),'(A4)')IVARI2(2)(1:4)
42359        NCTEXT(ICNT)=35
42360        AVALUE(ICNT)=0.0
42361        IDIGIT(ICNT)=-1
42362      ENDIF
42363C
42364      ICNT=ICNT+1
42365      ITEXT(ICNT)=' '
42366      NCTEXT(ICNT)=1
42367      AVALUE(ICNT)=0.0
42368      IDIGIT(ICNT)=-1
42369C
42370      ICNT=ICNT+1
42371      ITEXT(ICNT)='H0: Data Are Poisson Distributed'
42372      NCTEXT(ICNT)=32
42373      AVALUE(ICNT)=0.0
42374      IDIGIT(ICNT)=-1
42375      ICNT=ICNT+1
42376      ITEXT(ICNT)='Ha: Data Are Not Poisson Distributed'
42377      NCTEXT(ICNT)=36
42378      AVALUE(ICNT)=0.0
42379      IDIGIT(ICNT)=-1
42380C
42381      ICNT=ICNT+1
42382      ITEXT(ICNT)=' '
42383      NCTEXT(ICNT)=1
42384      AVALUE(ICNT)=0.0
42385      IDIGIT(ICNT)=-1
42386      ICNT=ICNT+1
42387      ITEXT(ICNT)='Summary Statistics:'
42388      NCTEXT(ICNT)=19
42389      AVALUE(ICNT)=0.0
42390      IDIGIT(ICNT)=-1
42391      ICNT=ICNT+1
42392      ITEXT(ICNT)='Number of Observations:'
42393      NCTEXT(ICNT)=23
42394      AVALUE(ICNT)=STATNU+1.0
42395      IDIGIT(ICNT)=0
42396      ICNT=ICNT+1
42397      ITEXT(ICNT)='Sample Mean:'
42398      NCTEXT(ICNT)=12
42399      AVALUE(ICNT)=YMEAN
42400      IDIGIT(ICNT)=NUMDIG
42401      ICNT=ICNT+1
42402      ITEXT(ICNT)='Sample Standard Deviation:'
42403      NCTEXT(ICNT)=26
42404      AVALUE(ICNT)=YSD
42405      IDIGIT(ICNT)=NUMDIG
42406      ICNT=ICNT+1
42407      ITEXT(ICNT)='Sample Variance:'
42408      NCTEXT(ICNT)=16
42409      AVALUE(ICNT)=YSD**2
42410      IDIGIT(ICNT)=NUMDIG
42411      ICNT=ICNT+1
42412      ITEXT(ICNT)=' '
42413      NCTEXT(ICNT)=1
42414      AVALUE(ICNT)=0.0
42415      IDIGIT(ICNT)=-1
42416C
42417      ICNT=ICNT+1
42418      ITEXT(ICNT)='Test Statistic Value:'
42419      NCTEXT(ICNT)=21
42420      AVALUE(ICNT)=STATVA
42421      IDIGIT(ICNT)=NUMDIG
42422      ICNT=ICNT+1
42423      ITEXT(ICNT)='Degrees of Freedom:'
42424      NCTEXT(ICNT)=19
42425      AVALUE(ICNT)=INT(STATNU+0.1)
42426      IDIGIT(ICNT)=0
42427      ICNT=ICNT+1
42428      ITEXT(ICNT)='CDF Value:'
42429      NCTEXT(ICNT)=10
42430      AVALUE(ICNT)=STATCD
42431      IDIGIT(ICNT)=NUMDIG
42432      ICNT=ICNT+1
42433      ITEXT(ICNT)='P-Value (2-tailed test):'
42434      NCTEXT(ICNT)=24
42435      AVALUE(ICNT)=PVALUE
42436      IDIGIT(ICNT)=NUMDIG
42437C
42438      NUMROW=ICNT
42439      DO2110I=1,NUMROW
42440        NTOT(I)=15
42441 2110 CONTINUE
42442C
42443      IFRST=.TRUE.
42444      ILAST=.TRUE.
42445C
42446      ISTEPN='21A'
42447      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PDT2')
42448     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
42449C
42450      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
42451     1            AVALUE,IDIGIT,
42452     1            NTOT,NUMROW,
42453     1            ICAPSW,ICAPTY,ILAST,IFRST,
42454     1            ISUBRO,IBUGA3,IERROR)
42455C
42456      ISTEPN='21B'
42457      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PDT2')
42458     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
42459C
42460      ITITLE='Two-Tailed Test'
42461      NCTITL=15
42462      ITITL9='H0: Poisson; Ha: Not Poisson'
42463      NCTIT9=28
42464C
42465      DO2130J=1,5
42466        DO2140I=1,3
42467          ITITL2(I,J)=' '
42468          NCTIT2(I,J)=0
42469 2140   CONTINUE
42470 2130 CONTINUE
42471C
42472      ITITL2(2,1)='Significance'
42473      NCTIT2(2,1)=12
42474      ITITL2(3,1)='Level'
42475      NCTIT2(3,1)=5
42476C
42477      ITITL2(2,2)='Test '
42478      NCTIT2(2,2)=4
42479      ITITL2(3,2)='Statistic'
42480      NCTIT2(3,2)=9
42481C
42482      ITITL2(1,3)='Lower'
42483      NCTIT2(1,3)=5
42484      ITITL2(2,3)='Critical'
42485      NCTIT2(2,3)=8
42486      ITITL2(3,3)='Value'
42487      NCTIT2(3,3)=5
42488C
42489      ITITL2(1,4)='Upper'
42490      NCTIT2(1,4)=5
42491      ITITL2(2,4)='Critical'
42492      NCTIT2(2,4)=8
42493      ITITL2(3,4)='Value'
42494      NCTIT2(3,4)=5
42495C
42496      ITITL2(1,5)='Null'
42497      NCTIT2(1,5)=4
42498      ITITL2(2,5)='Hypothesis'
42499      NCTIT2(2,5)=10
42500      ITITL2(3,5)='Conclusion'
42501      NCTIT2(3,5)=10
42502C
42503      NMAX=0
42504      NUMCOL=5
42505      DO2150I=1,NUMCOL
42506        VALIGN(I)='b'
42507        ALIGN(I)='r'
42508        NTOT(I)=15
42509        NMAX=NMAX+NTOT(I)
42510        ITYPCO(I)='NUME'
42511        IDIGIT(I)=NUMDIG
42512        IF(I.EQ.1 .OR. I.EQ.5)THEN
42513          ITYPCO(I)='ALPH'
42514        ENDIF
42515 2150 CONTINUE
42516C
42517      IWHTML(1)=125
42518      IWHTML(2)=175
42519      IWHTML(3)=175
42520      IWHTML(4)=175
42521      IWHTML(5)=175
42522      IINC=1800
42523      IINC2=1400
42524      IWRTF(1)=IINC
42525      IWRTF(2)=IWRTF(1)+IINC
42526      IWRTF(3)=IWRTF(2)+IINC
42527      IWRTF(4)=IWRTF(3)+IINC
42528      IWRTF(5)=IWRTF(4)+IINC
42529C
42530      DO2160J=1,NUMALP
42531C
42532        AMAT(J,2)=STATVA
42533        AMAT(J,3)=LOWLIM(J)
42534        AMAT(J,4)=UPPLIM(J)
42535        IVALUE(J,5)(1:6)='REJECT'
42536        IF(STATVA.GE.LOWLIM(J) .AND. STATVA.LE.UPPLIM(J))THEN
42537          IVALUE(J,5)(1:6)='ACCEPT'
42538        ENDIF
42539        NCVALU(J,5)=6
42540C
42541        ALPHAT=100.0*ALPHA(J)
42542        WRITE(IVALUE(J,1)(1:4),'(F4.1)')ALPHAT
42543        IVALUE(J,1)(5:5)='%'
42544        NCVALU(J,1)=5
42545 2160 CONTINUE
42546C
42547      ICNT=NUMALP
42548      NUMLIN=3
42549      NUMCOL=5
42550      IFRST=.TRUE.
42551      ILAST=.TRUE.
42552      IFLAGS=.TRUE.
42553      IFLAGE=.TRUE.
42554      CALL DPDTA5(ITITLE,NCTITL,
42555     1            ITITL9,NCTIT9,ITITL2,NCTIT2,
42556     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
42557     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
42558     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
42559     1            ICAPSW,ICAPTY,IFRST,ILAST,
42560     1            IFLAGS,IFLAGE,
42561     1            ISUBRO,IBUGA3,IERROR)
42562C
42563C               *****************
42564C               **  STEP 90--  **
42565C               **  EXIT       **
42566C               *****************
42567C
42568 9000 CONTINUE
42569      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PDT2')THEN
42570        WRITE(ICOUT,999)
42571        CALL DPWRST('XXX','WRIT')
42572        WRITE(ICOUT,9011)
42573 9011   FORMAT('***** AT THE END       OF DPPDT2--')
42574        CALL DPWRST('XXX','WRIT')
42575        WRITE(ICOUT,9013)STATVA,STATCD,PVALUE
42576 9013   FORMAT('STATVA,STATCD,PVALUE = ',3G15.7)
42577        CALL DPWRST('XXX','WRIT')
42578      ENDIF
42579C
42580      RETURN
42581      END
42582      SUBROUTINE DPPDT3(Y,X,N,ICASE,
42583     1                  STATVA,STATCD,STATNU,PVALUE,
42584     1                  YMEAN,YSD,
42585     1                  ISUBRO,IBUGA3,IERROR)
42586C
42587C     PURPOSE--THIS SUBROUTINE COMPUTES THE POISSON DISPERSION TEST.
42588C              THIS TEST IS DEFINED AS:
42589C
42590C                 D = SUM[i=1 to N][(X(i) - XBAR)**2/XBAR]
42591C
42592C              THIS TEST FOLLOWS AN APPROXIMATELY CHI-SQUARE
42593C              DISTRIBITION WITH (N-1) DEGREES OF FREEDOM.
42594C
42595C              NOTE THAT THIS TEST CAN BE COMPUTED FOR BOTH GROUPED
42596C              AND UNGROUPED DATA (DETERMINED BY ICASE).
42597C     INPUT  ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR OF
42598C                                OBSERVATIONS.  THIS IS THE RESPONSE
42599C                                VARIABLE FOR UNGROUPED DATA AND THE
42600C                                FREQUENCY FOR GROUPED DATA.
42601C                     --X      = THE SINGLE PRECISION VECTOR OF CLASS
42602C                                MID-POINTS FOR GROUPED DATA (IGNORED
42603C                                FOR UNGROUPED DATA).
42604C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
42605C                                IN THE VECTOR Y.
42606C                     --ICASE  = A CHARACTER VARIABLE THAT SPECIFIES
42607C                                WHETHER GROUPED OR UNGROUPED DATA IS
42608C                                BEING GIVEN.
42609C     OUTPUT ARGUMENTS--STATVA = THE SINGLE PRECISION VALUE OF THE
42610C                                COMPUTED STATISTIC.
42611C                     --STATCD = THE SINGLE PRECISION VALUE OF THE
42612C                                COMPUTED CDF OF THE TEST STATISTIC.
42613C                     --STATNU = THE SINGLE PRECISION VALUE OF THE
42614C                                CHI-SQUARE DEGREES OF FREEDOM.
42615C                     --PVALUE = THE SINGLE PRECISION VALUE OF THE
42616C                                COMPUTED P-VALUE.
42617C     REFERENCE--SPINELLI AND STEPHENS (1997), "CRAMER-VON MISES TESTS
42618C                OF FIT FOR THE POISSON DISTRIBUTION", CANADIAN JOURNAL
42619C                OF STATISTICS, VOL. 25(2), pp. 257-267.
42620C              --KENDELL AND STUART (1979), "THE ADVANCED THEORY OF
42621C                STATISTICS: VOLUME 2", FOURTH EDITION, GRIFFIN,
42622C                LONDON.
42623C     OTHER DATAPAC   SUBROUTINES NEEDED--MEAN, SD.
42624C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
42625C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
42626C     LANGUAGE--ANSI FORTRAN (1977)
42627C     WRITTEN BY--ALAN HECKERT
42628C                 STATISTICAL ENGINEERING DIVISION
42629C                 INFORMATION TECHNOLOGY LABORATORY
42630C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
42631C                 GAITHERSBURG, MD 20899-8980
42632C                 PHONE--301-975-2899
42633C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
42634C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
42635C     LANGUAGE--ANSI FORTRAN (1977)
42636C     VERSION NUMBER--2009.2
42637C     ORIGINAL VERSION--FEBRUARY  2009.
42638C
42639C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
42640C
42641      CHARACTER*4 ICASE
42642      CHARACTER*4 ISUBRO
42643      CHARACTER*4 IBUGA3
42644      CHARACTER*4 IERROR
42645C
42646      CHARACTER*4 IWRITE
42647      CHARACTER*4 ISUBN1
42648      CHARACTER*4 ISUBN2
42649C
42650C---------------------------------------------------------------------
42651C
42652      DIMENSION Y(*)
42653      DIMENSION X(*)
42654C
42655      DOUBLE PRECISION DSUM
42656      DOUBLE PRECISION DY
42657      DOUBLE PRECISION DX
42658      DOUBLE PRECISION DMEAN
42659C
42660C---------------------------------------------------------------------
42661C
42662      INCLUDE 'DPCOP2.INC'
42663C
42664C-----START POINT-----------------------------------------------------
42665C
42666      ISUBN1='DPPD'
42667      ISUBN2='T3  '
42668      IWRITE='OFF'
42669      IERROR='NO'
42670C
42671      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PDT3')THEN
42672        WRITE(ICOUT,999)
42673  999   FORMAT(1X)
42674        CALL DPWRST('XXX','BUG ')
42675        WRITE(ICOUT,51)
42676   51   FORMAT('***** AT THE BEGINNING OF DPPDT3--')
42677        CALL DPWRST('XXX','BUG ')
42678        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
42679   52   FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8)
42680        CALL DPWRST('XXX','BUG ')
42681        DO55I=1,N
42682          WRITE(ICOUT,56)I,Y(I),X(I)
42683   56     FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
42684          CALL DPWRST('XXX','BUG ')
42685   55   CONTINUE
42686      ENDIF
42687C
42688      STATVA=CPUMIN
42689      STATCD=CPUMIN
42690      STATNU=CPUMIN
42691      PVALUE=CPUMIN
42692      YMEAN=CPUMIN
42693      YSD=CPUMIN
42694C
42695C               *******************************************
42696C               **  COMPUTE THE POISSON DISPERSION TEST  **
42697C               **  FOR THE RAW DATA CASE                **
42698C               *******************************************
42699C
42700      IF(ICASE.EQ.'RAW')THEN
42701C
42702C               ********************************************
42703C               **  STEP 1--                              **
42704C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
42705C               ********************************************
42706C
42707        IF(N.LE.1)THEN
42708          WRITE(ICOUT,999)
42709          CALL DPWRST('XXX','BUG ')
42710          WRITE(ICOUT,111)
42711  111     FORMAT('***** ERROR IN POISSON DISPERSION TEST--')
42712          CALL DPWRST('XXX','BUG ')
42713          WRITE(ICOUT,112)
42714  112     FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ',
42715     1           'VARIABLE IS LESS THAN TWO.')
42716          CALL DPWRST('XXX','BUG ')
42717          WRITE(ICOUT,117)N
42718  117     FORMAT('      THE NUMBER OF OBSERVATIONS = ',I8,'.')
42719          CALL DPWRST('XXX','BUG ')
42720          IERROR='YES'
42721          GOTO9000
42722        ENDIF
42723C
42724C               ********************************************
42725C               **  STEP 2--                              **
42726C               **  COMPUTE THE STATISTIC                 **
42727C               ********************************************
42728C
42729        CALL MEAN(Y,N,IWRITE,YMEAN,IBUGA3,IERROR)
42730        CALL SD(Y,N,IWRITE,YSD,IBUGA3,IERROR)
42731        DSUM=0.0D0
42732        DMEAN=DBLE(YMEAN)
42733        DO200I=1,N
42734          DY=DBLE(Y(I))
42735          DSUM=DSUM + (DY - DMEAN)**2
42736  200   CONTINUE
42737        DSUM=DSUM/DMEAN
42738        STATVA=REAL(DSUM)
42739        IDF=N-1
42740        STATNU=REAL(IDF)
42741        CALL CHSCDF(STATVA,IDF,STATCD)
42742C
42743        PVALLT=STATCD
42744        PVALUT=1.0 - STATCD
42745        IF(STATCD.LE.0.5)THEN
42746          PVALUE=2.0*PVALLT
42747        ELSE
42748          PVALUE=2.0*PVALUT
42749        ENDIF
42750C
42751C               *******************************************
42752C               **  COMPUTE THE POISSON DISPERSION TEST  **
42753C               **  FOR THE GROUPED DATA CASE            **
42754C               *******************************************
42755C
42756      ELSEIF(ICASE.EQ.'GROU')THEN
42757C
42758C               ********************************************
42759C               **  STEP 1--                              **
42760C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
42761C               ********************************************
42762C
42763        IF(N.LE.1)THEN
42764          WRITE(ICOUT,999)
42765          CALL DPWRST('XXX','BUG ')
42766          WRITE(ICOUT,111)
42767          CALL DPWRST('XXX','BUG ')
42768          WRITE(ICOUT,312)
42769  312     FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ',
42770     1           'VARIABLES IS LESS THAN TWO.')
42771          CALL DPWRST('XXX','BUG ')
42772          WRITE(ICOUT,117)N
42773          CALL DPWRST('XXX','BUG ')
42774          IERROR='YES'
42775          GOTO9000
42776        ENDIF
42777C
42778        DO320I=1,N
42779          IF(Y(I).LT.0.0)THEN
42780            WRITE(ICOUT,999)
42781            CALL DPWRST('XXX','BUG ')
42782            WRITE(ICOUT,111)
42783            CALL DPWRST('XXX','BUG ')
42784            WRITE(ICOUT,322)I,Y(I)
42785  322       FORMAT('      ROW ',I8,' HAS A NON-POSITIVE FREQUENCY (',
42786     1             G15.7,')')
42787            CALL DPWRST('XXX','BUG ')
42788            IERROR='YES'
42789            GOTO9000
42790          ENDIF
42791  320   CONTINUE
42792C
42793C               ********************************************
42794C               **  STEP 2--                              **
42795C               **  COMPUTE THE STATISTIC                 **
42796C               ********************************************
42797C
42798        CALL WEMEAN(X,Y,N,IWRITE,YMEAN,IBUGA3,IERROR)
42799        CALL WESD(X,Y,N,IWRITE,YSD,IBUGA3,IERROR)
42800C
42801        DSUM=0.0D0
42802        DMEAN=DBLE(YMEAN)
42803        IDF=0
42804        DO400I=1,N
42805          ITEMP=INT(Y(I)+0.001)
42806          IDF=IDF + ITEMP
42807          DY=DBLE(ITEMP)
42808          DX=DBLE(X(I))
42809          DSUM=DSUM + DY*(DX - DMEAN)**2
42810  400   CONTINUE
42811        DSUM=DSUM/DMEAN
42812        STATVA=REAL(DSUM)
42813        IDF=IDF-1
42814        STATNU=REAL(IDF)
42815        CALL CHSCDF(STATVA,IDF,STATCD)
42816C
42817        PVALLT=STATCD
42818        PVALUT=1.0 - STATCD
42819        IF(STATCD.LE.0.5)THEN
42820          PVALUE=2.0*PVALLT
42821        ELSE
42822          PVALUE=2.0*PVALUT
42823        ENDIF
42824C
42825      ENDIF
42826C
42827C               *****************
42828C               **  STEP 90--  **
42829C               **  EXIT.      **
42830C               *****************
42831C
42832 9000 CONTINUE
42833C
42834      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PDT3')THEN
42835        WRITE(ICOUT,999)
42836        CALL DPWRST('XXX','BUG ')
42837        WRITE(ICOUT,9011)
42838 9011   FORMAT('***** AT THE END       OF DPPDT3--')
42839        CALL DPWRST('XXX','BUG ')
42840        WRITE(ICOUT,9015)STATVA,STATCD,PVALUE,IERROR
42841 9015   FORMAT('STATVA,STATCD,PVALUE,IERROR = ',3G15.7,2X,A4)
42842        CALL DPWRST('XXX','BUG ')
42843        WRITE(ICOUT,9016)YMEAN,YSD
42844 9016   FORMAT('YMEAN,YSD = ',2G15.7)
42845        CALL DPWRST('XXX','BUG ')
42846      ENDIF
42847C
42848      RETURN
42849      END
42850      SUBROUTINE DPPEAK(Y,X,N,
42851     1                  Y2,X2,AREA,N2,IBUGG3,ISUBRO,IERROR)
42852C
42853C     PURPOSE--GIVEN A SET OF POINTS (Y,X), FILTER THE POINTS TO RETURN
42854C              THE PEAKS OF THE DATA.  IN ADDITION, RETURN THE AREAS
42855C              OF THE TRIANGLES FORMED BY THESE PEAK POINTS.
42856C     WRITTEN BY--ALAN HECKERT
42857C                 STATISTICAL ENGINEERING DIVISION
42858C                 INFORMATION TECHNOLOGY LABORATORY
42859C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
42860C                 GAITHERSBURG, MD 20899-8980
42861C                 PHONE--301-975-2899
42862C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
42863C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
42864C     LANGUAGE--ANSI FORTRAN (1977)
42865C     VERSION NUMBER--2013/8
42866C     ORIGINAL VERSION--AUGUST    2013.
42867C
42868C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
42869C
42870      CHARACTER*4 IBUGG3
42871      CHARACTER*4 ISUBRO
42872      CHARACTER*4 IERROR
42873C
42874      CHARACTER*4 IDIR
42875      CHARACTER*4 ISUBN1
42876      CHARACTER*4 ISUBN2
42877C
42878C---------------------------------------------------------------------
42879C
42880      DIMENSION Y(*)
42881      DIMENSION X(*)
42882      DIMENSION Y2(*)
42883      DIMENSION X2(*)
42884      DIMENSION AREA(*)
42885C
42886C---------------------------------------------------------------------
42887C
42888      INCLUDE 'DPCOP2.INC'
42889C
42890C-----START POINT-----------------------------------------------------
42891C
42892      ISUBN1='DPPE'
42893      ISUBN2='AK  '
42894      IERROR='NO'
42895C
42896      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'BINP')THEN
42897        WRITE(ICOUT,999)
42898  999   FORMAT(1X)
42899        CALL DPWRST('XXX','BUG ')
42900        WRITE(ICOUT,20)
42901   20   FORMAT('***** AT THE BEGINNING OF DPPEAK--')
42902        CALL DPWRST('XXX','BUG ')
42903        WRITE(ICOUT,22)N
42904   22   FORMAT('N = ',I8)
42905        CALL DPWRST('XXX','BUG ')
42906        DO23I=1,N
42907          WRITE(ICOUT,24)I,X(I),Y(I)
42908   24     FORMAT('I,X(I),Y(I) = ',I8,2G15.7)
42909          CALL DPWRST('XXX','BUG ')
42910   23   CONTINUE
42911      ENDIF
42912C
42913C               ********************************************
42914C               **  STEP 1--                              **
42915C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
42916C               ********************************************
42917C
42918      IF(N.LT.5)THEN
42919        WRITE(ICOUT,999)
42920        CALL DPWRST('XXX','BUG ')
42921        WRITE(ICOUT,31)
42922   31   FORMAT('***** ERROR IN PEAKS--')
42923        CALL DPWRST('XXX','BUG ')
42924        WRITE(ICOUT,32)
42925   32   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 5;')
42926        CALL DPWRST('XXX','BUG ')
42927        WRITE(ICOUT,34)N
42928   34   FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I8)
42929        CALL DPWRST('XXX','BUG ')
42930        WRITE(ICOUT,999)
42931        CALL DPWRST('XXX','BUG ')
42932        IERROR='YES'
42933        GOTO9000
42934      ENDIF
42935C
42936C     SORT THE DATA BASED ON X AND THEN BE SURE THAT ALL
42937C     X POINTS ARE DISTINCT.
42938C
42939      CALL SORTC(X,Y,N,X,Y)
42940C
42941      DO60I=2,N
42942        IF(X(I).EQ.X(I-1))THEN
42943          WRITE(ICOUT,999)
42944          CALL DPWRST('XXX','BUG ')
42945          WRITE(ICOUT,31)
42946          CALL DPWRST('XXX','BUG ')
42947          WRITE(ICOUT,62)
42948   62     FORMAT('      THE POINTS IN THE X VECTOR ARE NOT ALL ',
42949     1           'DISTINCT.')
42950          CALL DPWRST('XXX','BUG ')
42951          WRITE(ICOUT,999)
42952          CALL DPWRST('XXX','BUG ')
42953          IERROR='YES'
42954          GOTO9000
42955        ENDIF
42956   60 CONTINUE
42957C
42958C               **********************************************
42959C               **  STEP 2--                                **
42960C               **  DETERMINE THE PEAKS                     **
42961C               **********************************************
42962C
42963C
42964      X2(1)=X(1)
42965      Y2(1)=Y(1)
42966      AREA(1)=0.0
42967      N2=1
42968      IDIR='NULL'
42969C
42970      DO100I=2,N-1
42971        IF(Y(I).GT.Y(I-1) .AND. Y(I).GT.Y(I+1))THEN
42972          N2=N2+1
42973          Y2(N2)=Y(I)
42974          X2(N2)=X(I)
42975          H=Y(I) - Y2(N2-1)
42976          BASE=X(I) - X2(N2-1)
42977          AREA(N2)=H*BASE/2.0
42978          IDIR='NULL'
42979        ELSEIF(Y(I).LT.Y(I-1) .AND. Y(I).LT.Y(I+1))THEN
42980          N2=N2+1
42981          Y2(N2)=Y(I)
42982          X2(N2)=X(I)
42983          H=ABS(Y(I) - Y2(N2-1))
42984          BASE=X(I) - X2(N2-1)
42985          AREA(N2)=H*BASE/2.0
42986          IDIR='NULL'
42987        ELSEIF(IDIR.EQ.'UP' .AND.
42988     1         Y(I).GE.Y(I-1) .AND. Y(I).GT.Y(I+1))THEN
42989          N2=N2+1
42990          Y2(N2)=Y(I)
42991          X2(N2)=X(I)
42992          H=Y(I) - Y2(N2-1)
42993          BASE=X(I) - X2(N2-1)
42994          AREA(N2)=H*BASE/2.0
42995          IDIR='NULL'
42996        ELSEIF(IDIR.EQ.'DOWN' .AND.
42997     1         Y(I).LE.Y(I-1) .AND. Y(I).LT.Y(I+1))THEN
42998          N2=N2+1
42999          Y2(N2)=Y(I)
43000          X2(N2)=X(I)
43001          H=ABS(Y(I) - Y2(N2-1))
43002          BASE=X(I) - X2(N2-1)
43003          AREA(N2)=H*BASE/2.0
43004          IDIR='NULL'
43005        ELSEIF(IDIR.EQ.'NULL' .AND.
43006     1         Y(I).GT.Y(I-1) .AND. Y(I).EQ.Y(I+1))THEN
43007          IDIR='UP'
43008        ELSEIF(IDIR.EQ.'NULL' .AND.
43009     1         Y(I).LT.Y(I-1) .AND. Y(I).EQ.Y(I+1))THEN
43010          IDIR='DOWN'
43011        ENDIF
43012  100 CONTINUE
43013      N2=N2+1
43014      Y2(N2)=Y(N)
43015      X2(N2)=X(N)
43016      H=ABS(Y(N) - Y2(N2-1))
43017      BASE=X(N) - X2(N2-1)
43018      AREA(N2)=H*BASE/2.0
43019C
43020C               ******************
43021C               **   STEP 90--  **
43022C               **   EXIT       **
43023C               ******************
43024C
43025 9000 CONTINUE
43026      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PEAK')THEN
43027        WRITE(ICOUT,999)
43028        CALL DPWRST('XXX','BUG ')
43029        WRITE(ICOUT,9011)
43030 9011   FORMAT('***** AT THE END       OF DPEAK--')
43031        CALL DPWRST('XXX','BUG ')
43032        WRITE(ICOUT,9012)IERROR,N2
43033 9012   FORMAT('IERROR,N2 = ',A4,2X,I8)
43034        CALL DPWRST('XXX','BUG ')
43035        DO9015I=1,N2
43036          WRITE(ICOUT,9016)I,X2(I),Y2(I),AREA(I)
43037 9016     FORMAT('I,X2(I),Y2(I),AREA(I) = ',I8,3G15.7)
43038          CALL DPWRST('XXX','BUG ')
43039 9015   CONTINUE
43040      ENDIF
43041C
43042      RETURN
43043      END
43044      SUBROUTINE DPPEBA(IHARG,IARGT,ARG,NUMARG,
43045     1DEPBA,APEDBA,
43046     1IFOUND,IERROR)
43047C
43048C     PURPOSE--DEFINE THE BASE
43049C              FOR THE 3-D PEDESTAL.
43050C              THE BASE FOR THE PEDESTAL WILL BE PLACED
43051C              IN THE FLOATING POINT VARIABLE APEDBA.
43052C              THE BASE FOR THE PEDESTAL WILL BE
43053C              IN UNITS OF THE Z AXIS VARIABLE.
43054C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
43055C                     --NUMARG
43056C                     --DEPBA
43057C     OUTPUT ARGUMENTS--APEDBA
43058C                     --IFOUND ('YES' OR 'NO' )
43059C                     --IERROR ('YES' OR 'NO' )
43060C     NOTE--THIS SUBROUTINE ASSUMES A
43061C           COMPLICATED-TO-SIMPLE CHECKING ORDER
43062C           (IN MAIPC4) OF THE VARIOUS PEDESTAL COMMANDS.
43063C     WRITTEN BY--JAMES J. FILLIBEN
43064C                 STATISTICAL ENGINEERING DIVISION
43065C                 INFORMATION TECHNOLOGY LABORATORY
43066C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
43067C                 GAITHERSBURG, MD 20899-8980
43068C                 PHONE--301-975-2899
43069C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
43070C           OF THE NATIONAL BUREAU OF STANDARDS.
43071C     LANGUAGE--ANSI FORTRAN (1977)
43072C     VERSION NUMBER--88/10
43073C     ORIGINAL VERSION--SEPTEMBER 1988.
43074C
43075C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
43076C
43077      CHARACTER*4 IHARG
43078      CHARACTER*4 IARGT
43079      CHARACTER*4 IFOUND
43080      CHARACTER*4 IERROR
43081C
43082C---------------------------------------------------------------------
43083C
43084      DIMENSION IHARG(*)
43085      DIMENSION IARGT(*)
43086      DIMENSION ARG(*)
43087C
43088C---------------------------------------------------------------------
43089C
43090      INCLUDE 'DPCOP2.INC'
43091C
43092C-----START POINT-----------------------------------------------------
43093C
43094      IFOUND='NO'
43095      IERROR='NO'
43096C
43097      IF(NUMARG.EQ.0)GOTO1199
43098      IF(NUMARG.EQ.1)GOTO1150
43099C
43100      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
43101      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
43102      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
43103      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
43104      IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160
43105      GOTO1120
43106C
43107 1120 CONTINUE
43108      IERROR='YES'
43109      WRITE(ICOUT,1121)
43110 1121 FORMAT('***** ERROR IN DPPEBA--')
43111      CALL DPWRST('XXX','BUG ')
43112      WRITE(ICOUT,1122)
43113 1122 FORMAT('      ILLEGAL SYNTAX FOR THE PEDESTAL BASE ',
43114     1'COMMAND.')
43115      CALL DPWRST('XXX','BUG ')
43116      WRITE(ICOUT,1124)
43117 1124 FORMAT('      TEST EXAMPLE TO DEMONSTRATE THE ',
43118     1'PROPER SYNTAX--')
43119      CALL DPWRST('XXX','BUG ')
43120      WRITE(ICOUT,1125)
43121 1125 FORMAT('      SUPPOSE THE Z AXIS DATA RANGES FROM ')
43122      CALL DPWRST('XXX','BUG ')
43123      WRITE(ICOUT,1126)
43124 1126 FORMAT('      500 TO 2000 ,')
43125      CALL DPWRST('XXX','BUG ')
43126      WRITE(ICOUT,1127)
43127 1127 FORMAT('      AND SUPPOSE THE ANALYST WISHES THE  ')
43128      CALL DPWRST('XXX','BUG ')
43129      WRITE(ICOUT,1128)
43130 1128 FORMAT('      PLOT PEDESTAL TO HAVE A BASE AT ')
43131      CALL DPWRST('XXX','BUG ')
43132      WRITE(ICOUT,1129)
43133 1129 FORMAT('      Z = 100; ')
43134      CALL DPWRST('XXX','BUG ')
43135      WRITE(ICOUT,1130)
43136 1130 FORMAT('      THEN THE PROPER SYNTAX IS--')
43137      CALL DPWRST('XXX','BUG ')
43138      WRITE(ICOUT,1131)
43139 1131 FORMAT('         PEDESTAL BASE 100 ')
43140      CALL DPWRST('XXX','BUG ')
43141      GOTO1199
43142C
43143 1150 CONTINUE
43144      APEDBA=DEPBA
43145      GOTO1180
43146C
43147 1160 CONTINUE
43148      APEDBA=ARG(NUMARG)
43149      GOTO1180
43150C
43151 1180 CONTINUE
43152      IFOUND='YES'
43153C
43154      IF(IFEEDB.EQ.'OFF')GOTO1189
43155      WRITE(ICOUT,999)
43156  999 FORMAT(1X)
43157      CALL DPWRST('XXX','BUG ')
43158      WRITE(ICOUT,1181)APEDBA
43159 1181 FORMAT('THE (3-D) PEDESTAL BASE ',
43160     1'HAS JUST BEEN SET TO ',E15.7)
43161      CALL DPWRST('XXX','BUG ')
43162 1189 CONTINUE
43163      GOTO1199
43164C
43165 1199 CONTINUE
43166      RETURN
43167      END
43168      SUBROUTINE DPPECL(IHARG,NUMARG,IDEPCO,IPEDCO,IFOUND,IERROR)
43169C
43170C     PURPOSE--DEFINE THE COLOR FOR THE 3-D PEDESTAL.
43171C              THE COLOR FOR THE PEDESTAL WILL BE PLACED
43172C              IN THE CHARACTER VARIABLE IPEDCO.
43173C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
43174C                     --NUMARG
43175C                     --IDEPCO
43176C     OUTPUT ARGUMENTS--IPEDCO
43177C                     --IFOUND ('YES' OR 'NO' )
43178C                     --IERROR ('YES' OR 'NO' )
43179C     NOTE--THIS SUBROUTINE ASSUMES A
43180C           COMPLICATED-TO-SIMPLE CHECKING ORDER
43181C           (IN MAIPC4) OF THE VARIOUS PEDESTAL COMMANDS.
43182C     WRITTEN BY--JAMES J. FILLIBEN
43183C                 STATISTICAL ENGINEERING DIVISION
43184C                 INFORMATION TECHNOLOGY LABORATORY
43185C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
43186C                 GAITHERSBURG, MD 20899-8980
43187C                 PHONE--301-975-2899
43188C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
43189C           OF THE NATIONAL BUREAU OF STANDARDS.
43190C     LANGUAGE--ANSI FORTRAN (1977)
43191C     VERSION NUMBER--82/7
43192C     ORIGINAL VERSION--SEPTEMBER 1980.
43193C     UPDATED         --MAY       1982.
43194C     UPDATED         --SEPTEMBER 1988. (WITH GENERAL 3-D UPDATE)
43195C
43196C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
43197C
43198      CHARACTER*4 IHARG
43199      CHARACTER*4 IDEPCO
43200      CHARACTER*4 IPEDCO
43201      CHARACTER*4 IFOUND
43202      CHARACTER*4 IERROR
43203C
43204C---------------------------------------------------------------------
43205C
43206      DIMENSION IHARG(*)
43207C
43208C---------------------------------------------------------------------
43209C
43210      INCLUDE 'DPCOP2.INC'
43211C
43212C-----START POINT-----------------------------------------------------
43213C
43214      IFOUND='NO'
43215      IERROR='NO'
43216C
43217      IF(NUMARG.EQ.0)GOTO1199
43218      IF(NUMARG.EQ.1)GOTO1150
43219C
43220      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
43221      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
43222      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
43223      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
43224      GOTO1160
43225C
43226 1150 CONTINUE
43227      IPEDCO=IDEPCO
43228      GOTO1180
43229C
43230 1160 CONTINUE
43231      IPEDCO=IHARG(NUMARG)
43232      GOTO1180
43233C
43234 1180 CONTINUE
43235      IFOUND='YES'
43236C
43237      IF(IFEEDB.EQ.'OFF')GOTO1189
43238      WRITE(ICOUT,999)
43239  999 FORMAT(1X)
43240      CALL DPWRST('XXX','BUG ')
43241      WRITE(ICOUT,1181)IPEDCO
43242 1181 FORMAT('THE (3-D) PEDESTAL COLOR ',
43243     1'HAS JUST BEEN SET TO ',A4)
43244      CALL DPWRST('XXX','BUG ')
43245 1189 CONTINUE
43246      GOTO1199
43247C
43248 1199 CONTINUE
43249      RETURN
43250      END
43251      SUBROUTINE DPPED(IHARG,NUMARG,IPEDSW,IFOUND,IERROR)
43252C
43253C     PURPOSE--DEFINE THE 3-D PEDESTAL SWITCH IPEDSW.
43254C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
43255C                     --NUMARG
43256C     OUTPUT ARGUMENTS--IPEDSW   ('ON'  OR 'OFF')
43257C                     --IFOUND ('YES' OR 'NO' )
43258C                     --IERROR ('YES' OR 'NO' )
43259C     NOTE--THIS SUBROUTINE ASSUMES A
43260C           COMPLICATED-TO-SIMPLE CHECKING ORDER
43261C           (IN MAIPC4) OF THE VARIOUS PEDESTAL COMMANDS.
43262C     WRITTEN BY--JAMES J. FILLIBEN
43263C                 STATISTICAL ENGINEERING DIVISION
43264C                 INFORMATION TECHNOLOGY LABORATORY
43265C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
43266C                 GAITHERSBURG, MD 20899-8980
43267C                 PHONE--301-975-2899
43268C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
43269C           OF THE NATIONAL BUREAU OF STANDARDS.
43270C     LANGUAGE--ANSI FORTRAN (1977)
43271C     VERSION NUMBER--82/7
43272C     ORIGINAL VERSION--SEPTEMBER 1980.
43273C     UPDATED         --FEBRUARY  1982.
43274C     UPDATED         --MAY       1982.
43275C     UPDATED         --SEPTEMBER 1988. (WITH GENERAL 3-D UPDATE)
43276C
43277C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
43278C
43279      CHARACTER*4 IHARG
43280      CHARACTER*4 IPEDSW
43281      CHARACTER*4 IFOUND
43282      CHARACTER*4 IERROR
43283C
43284C---------------------------------------------------------------------
43285C
43286      DIMENSION IHARG(*)
43287C
43288C---------------------------------------------------------------------
43289C
43290      INCLUDE 'DPCOP2.INC'
43291C
43292C-----START POINT-----------------------------------------------------
43293C
43294      IFOUND='NO'
43295      IERROR='NO'
43296C
43297      IF(NUMARG.EQ.0)GOTO1150
43298C
43299      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
43300      IF(IHARG(NUMARG).EQ.'OFF')GOTO1160
43301      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
43302      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1160
43303      GOTO1199
43304C
43305 1150 CONTINUE
43306      IPEDSW='ON'
43307      GOTO1180
43308C
43309 1160 CONTINUE
43310      IPEDSW='OFF'
43311      GOTO1180
43312C
43313 1180 CONTINUE
43314      IFOUND='YES'
43315C
43316      IF(IFEEDB.EQ.'OFF')GOTO1189
43317      WRITE(ICOUT,999)
43318  999 FORMAT(1X)
43319      CALL DPWRST('XXX','BUG ')
43320      WRITE(ICOUT,1181)IPEDSW
43321 1181 FORMAT('THE (3-D) PEDESTAL SWITCH ',
43322     1'HAS JUST BEEN SET TO ',A4)
43323      CALL DPWRST('XXX','BUG ')
43324 1189 CONTINUE
43325      GOTO1199
43326C
43327 1199 CONTINUE
43328      RETURN
43329      END
43330      SUBROUTINE DPPEGC(IHARG,NUMARG,IDEPGC,IPEDGC,IFOUND,IERROR)
43331C
43332C     PURPOSE--DEFINE THE COLOR FOR THE 3-D PEDESTAL GRID.
43333C              THE COLOR FOR THE PEDESTAL GRID WILL BE PLACED
43334C              IN THE CHARACTER VARIABLE IPEDGC.
43335C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
43336C                     --NUMARG
43337C                     --IDEPGC
43338C     OUTPUT ARGUMENTS--IPEDGC
43339C                     --IFOUND ('YES' OR 'NO' )
43340C                     --IERROR ('YES' OR 'NO' )
43341C     NOTE--THIS SUBROUTINE ASSUMES A
43342C           COMPLICATED-TO-SIMPLE CHECKING ORDER
43343C           (IN MAIPC4) OF THE VARIOUS PEDESTAL COMMANDS.
43344C     WRITTEN BY--JAMES J. FILLIBEN
43345C                 STATISTICAL ENGINEERING DIVISION
43346C                 INFORMATION TECHNOLOGY LABORATORY
43347C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
43348C                 WASHINGPON, D. C. 20234
43349C                 PHONE--301-975-2899
43350C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
43351C           OF THE NATIONAL BUREAU OF STANDARDS.
43352C     LANGUAGE--ANSI FORTRAN (1977)
43353C     VERSION NUMBER--88/10
43354C     ORIGINAL VERSION--SEPTEMBER 1988.
43355C
43356C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
43357C
43358      CHARACTER*4 IHARG
43359      CHARACTER*4 IDEPGC
43360      CHARACTER*4 IPEDGC
43361      CHARACTER*4 IFOUND
43362      CHARACTER*4 IERROR
43363C
43364C---------------------------------------------------------------------
43365C
43366      DIMENSION IHARG(*)
43367C
43368C---------------------------------------------------------------------
43369C
43370      INCLUDE 'DPCOP2.INC'
43371C
43372C-----START POINT-----------------------------------------------------
43373C
43374      IFOUND='NO'
43375      IERROR='NO'
43376C
43377      IF(NUMARG.LE.1)GOTO1199
43378      IF(NUMARG.EQ.2)GOTO1150
43379C
43380      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
43381      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
43382      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
43383      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
43384      GOTO1160
43385C
43386 1150 CONTINUE
43387      IPEDGC=IDEPGC
43388      GOTO1180
43389C
43390 1160 CONTINUE
43391      IPEDGC=IHARG(NUMARG)
43392      GOTO1180
43393C
43394 1180 CONTINUE
43395      IFOUND='YES'
43396C
43397      IF(IFEEDB.EQ.'OFF')GOTO1189
43398      WRITE(ICOUT,999)
43399  999 FORMAT(1X)
43400      CALL DPWRST('XXX','BUG ')
43401      WRITE(ICOUT,1181)IPEDGC
43402 1181 FORMAT('THE (3-D) PEDESTAL GRID COLOR ',
43403     1'HAS JUST BEEN SET TO ',A4)
43404      CALL DPWRST('XXX','BUG ')
43405 1189 CONTINUE
43406      GOTO1199
43407C
43408 1199 CONTINUE
43409      RETURN
43410      END
43411      SUBROUTINE DPPEGP(IHARG,NUMARG,IDEPGP,IPEDGP,IFOUND,IERROR)
43412C
43413C     PURPOSE--DEFINE THE PATTERN FOR THE 3-D PEDESTAL GRID.
43414C              THE PATTERN FOR THE PEDESTAL GRID WILL BE PLACED
43415C              IN THE CHARACTER VARIABLE IPEDGP.
43416C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
43417C                     --NUMARG
43418C                     --IDEPGP
43419C     OUTPUT ARGUMENTS--IPEDGP
43420C                     --IFOUND ('YES' OR 'NO' )
43421C                     --IERROR ('YES' OR 'NO' )
43422C     NOTE--THIS SUBROUTINE ASSUMES A
43423C           COMPLICATED-TO-SIMPLE CHECKING ORDER
43424C           (IN MAIPC4) OF THE VARIOUS PEDESTAL COMMANDS.
43425C     WRITTEN BY--JAMES J. FILLIBEN
43426C                 STATISTICAL ENGINEERING DIVISION
43427C                 INFORMATION TECHNOLOGY LABORATORY
43428C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
43429C                 WASHINGPON, D. C. 20234
43430C                 PHONE--301-975-2899
43431C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
43432C           OF THE NATIONAL BUREAU OF STANDARDS.
43433C     LANGUAGE--ANSI FORTRAN (1977)
43434C     VERSION NUMBER--88/10
43435C     ORIGINAL VERSION--SEPTEMBER 1988.
43436C
43437C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
43438C
43439      CHARACTER*4 IHARG
43440      CHARACTER*4 IDEPGP
43441      CHARACTER*4 IPEDGP
43442      CHARACTER*4 IFOUND
43443      CHARACTER*4 IERROR
43444C
43445C---------------------------------------------------------------------
43446C
43447      DIMENSION IHARG(*)
43448C
43449C---------------------------------------------------------------------
43450C
43451      INCLUDE 'DPCOP2.INC'
43452C
43453C-----START POINT-----------------------------------------------------
43454C
43455      IFOUND='NO'
43456      IERROR='NO'
43457C
43458      IF(NUMARG.LE.1)GOTO1199
43459      IF(NUMARG.EQ.2)GOTO1160
43460C
43461      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
43462      IF(IHARG(NUMARG).EQ.'OFF')GOTO1160
43463      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
43464      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1170
43465      GOTO1175
43466C
43467 1150 CONTINUE
43468      IPEDGP='SOLI'
43469      GOTO1180
43470C
43471 1160 CONTINUE
43472      IPEDGP='BLAN'
43473      GOTO1180
43474C
43475 1170 CONTINUE
43476      IPEDGP=IDEPGP
43477      GOTO1180
43478C
43479 1175 CONTINUE
43480      IPEDGP=IHARG(NUMARG)
43481      GOTO1180
43482C
43483 1180 CONTINUE
43484      IFOUND='YES'
43485C
43486      IF(IFEEDB.EQ.'OFF')GOTO1189
43487      WRITE(ICOUT,999)
43488  999 FORMAT(1X)
43489      CALL DPWRST('XXX','BUG ')
43490      WRITE(ICOUT,1181)IPEDGP
43491 1181 FORMAT('THE (3-D) PEDESTAL GRID PATTERN ',
43492     1'HAS JUST BEEN SET TO ',A4)
43493      CALL DPWRST('XXX','BUG ')
43494 1189 CONTINUE
43495      GOTO1199
43496C
43497 1199 CONTINUE
43498      RETURN
43499      END
43500      SUBROUTINE DPPEGR(IHARG,NUMARG,IDEPGR,IPEDGR,IFOUND,IERROR)
43501C
43502C     PURPOSE--DEFINE THE 3-D PEDESTAL GRID SWITCH IPEDGR.
43503C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
43504C                     --NUMARG
43505C                     --IDEPGR
43506C     OUTPUT ARGUMENTS--IPEDGR   ('ON'  OR 'OFF')
43507C                     --IFOUND ('YES' OR 'NO' )
43508C                     --IERROR ('YES' OR 'NO' )
43509C     NOTE--THIS SUBROUTINE ASSUMES A
43510C           COMPLICATED-TO-SIMPLE CHECKING ORDER
43511C           (IN MAIPC4) OF THE VARIOUS PEDESTAL COMMANDS.
43512C     WRITTEN BY--JAMES J. FILLIBEN
43513C                 STATISTICAL ENGINEERING DIVISION
43514C                 INFORMATION TECHNOLOGY LABORATORY
43515C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
43516C                 GAITHERSBURG, MD 20899-8980
43517C                 PHONE--301-975-2899
43518C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
43519C           OF THE NATIONAL BUREAU OF STANDARDS.
43520C     LANGUAGE--ANSI FORTRAN (1977)
43521C     VERSION NUMBER--88/11
43522C     ORIGINAL VERSION--SEPTEMBER 1988.
43523C
43524C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
43525C
43526      CHARACTER*4 IHARG
43527      CHARACTER*4 IDEPGR
43528      CHARACTER*4 IPEDGR
43529      CHARACTER*4 IFOUND
43530      CHARACTER*4 IERROR
43531C
43532C---------------------------------------------------------------------
43533C
43534      DIMENSION IHARG(*)
43535C
43536C---------------------------------------------------------------------
43537C
43538      INCLUDE 'DPCOP2.INC'
43539C
43540C-----START POINT-----------------------------------------------------
43541C
43542      IFOUND='NO'
43543      IERROR='NO'
43544C
43545      IF(NUMARG.EQ.0)GOTO1199
43546      IF(NUMARG.EQ.1)GOTO1150
43547C
43548      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
43549      IF(IHARG(NUMARG).EQ.'OFF')GOTO1160
43550      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
43551      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1170
43552      GOTO1199
43553C
43554 1150 CONTINUE
43555      IPEDGR='ON'
43556      GOTO1180
43557C
43558 1160 CONTINUE
43559      IPEDGR='OFF'
43560      GOTO1180
43561C
43562 1170 CONTINUE
43563      IPEDGR=IDEPGR
43564      GOTO1180
43565C
43566 1180 CONTINUE
43567      IFOUND='YES'
43568C
43569      IF(IFEEDB.EQ.'OFF')GOTO1189
43570      WRITE(ICOUT,999)
43571  999 FORMAT(1X)
43572      CALL DPWRST('XXX','BUG ')
43573      WRITE(ICOUT,1181)IPEDGR
43574 1181 FORMAT('THE (3-D) PEDESTAL GRID SWITCH ',
43575     1'HAS JUST BEEN SET TO ',A4)
43576      CALL DPWRST('XXX','BUG ')
43577 1189 CONTINUE
43578      GOTO1199
43579C
43580 1199 CONTINUE
43581      RETURN
43582      END
43583      SUBROUTINE DPPER2(Y,X,XHIGH,N,IDATSW,NUMVAR,NCURVE,
43584     1                  CLWID,XSTART,XSTOP,IHSTCW,IHSTOU,MAXNXT,
43585     1                  IPPTBI,NHIGH,
43586     1                  TAG1,XTEMP1,XTEMP2,
43587     1                  Y2,X2,D2,N2,NPLOTV,IBUGG3,ISUBRO,IERROR)
43588C
43589C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
43590C              THAT WILL DEFINE A PERCENT POINT PLOT
43591C     WRITTEN BY--JAMES J. FILLIBEN
43592C                 STATISTICAL ENGINEERING DIVISION
43593C                 INFORMATION TECHNOLOGY LABORATORY
43594C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
43595C                 GAITHERSBURG, MD 20899-8980
43596C                 PHONE--301-975-2899
43597C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
43598C           OF THE NATIONAL BUREAU OF STANDARDS.
43599C     LANGUAGE--ANSI FORTRAN (1977)
43600C     VERSION NUMBER--82/7
43601C     ORIGINAL VERSION--APRIL     1978.
43602C     UPDATED         --MAY       1978.
43603C     UPDATED         --JUNE      1978.
43604C     UPDATED         --OCTOBER   1978.
43605C     UPDATED         --MARCH     1979.
43606C     UPDATED         --APRIL     1979.
43607C     UPDATED         --JANUARY   1981.
43608C     UPDATED         --AUGUST    1981.
43609C     UPDATED         --OCTOBER   1981.
43610C     UPDATED         --DECEMBER  1981.
43611C     UPDATED         --APRIL     1982.
43612C     UPDATED         --MAY       1982.
43613C     UPDATED         --SEPTEMBER 1998. OPTION TO NOT BIN THE DATA
43614C
43615C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
43616C
43617      CHARACTER*4 IDATSW
43618      CHARACTER*4 IPPTBI
43619      CHARACTER*4 IHSTCW
43620      CHARACTER*4 IHSTOU
43621      CHARACTER*4 IBUGG3
43622      CHARACTER*4 ISUBRO
43623      CHARACTER*4 IERROR
43624C
43625      CHARACTER*4 ISUBN1
43626      CHARACTER*4 ISUBN2
43627C
43628C---------------------------------------------------------------------
43629C
43630CCCCC DOUBLE PRECISION DSUM
43631CCCCC DOUBLE PRECISION DN
43632      DOUBLE PRECISION DVAL1
43633      DOUBLE PRECISION DVAL2
43634      DOUBLE PRECISION DVAL3
43635C
43636      DIMENSION Y(*)
43637      DIMENSION X(*)
43638      DIMENSION XHIGH(*)
43639      DIMENSION XTEMP1(*)
43640      DIMENSION XTEMP2(*)
43641      DIMENSION TAG1(*)
43642      DIMENSION Y2(*)
43643      DIMENSION X2(*)
43644      DIMENSION D2(*)
43645C
43646C---------------------------------------------------------------------
43647C
43648      INCLUDE 'DPCOP2.INC'
43649C
43650C-----START POINT-----------------------------------------------------
43651C
43652      ISUBN1='DPPE'
43653      ISUBN2='R2  '
43654      IERROR='NO'
43655C
43656      DVAL3=0.0D0
43657      DXSTAR=0.0D0
43658      DXSTOP=0.0D0
43659C
43660      AN3=0.0
43661      DENOM=0.0
43662C
43663C               ********************************************
43664C               **  STEP 1--                              **
43665C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
43666C               ********************************************
43667C
43668      IF(N.LE.2)THEN
43669        WRITE(ICOUT,999)
43670  999   FORMAT(1X)
43671        CALL DPWRST('XXX','BUG ')
43672        WRITE(ICOUT,31)
43673   31   FORMAT('***** ERROR IN PERCENT POINT PLOT--')
43674        CALL DPWRST('XXX','BUG ')
43675        WRITE(ICOUT,32)
43676   32   FORMAT('      THE NUMBER OF OBSERVATIONS IS LESS THAN THREE;')
43677        CALL DPWRST('XXX','BUG ')
43678        WRITE(ICOUT,34)N
43679   34   FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6)
43680        CALL DPWRST('XXX','BUG ')
43681        WRITE(ICOUT,999)
43682        CALL DPWRST('XXX','BUG ')
43683        IERROR='YES'
43684        GOTO9000
43685      ENDIF
43686C
43687      NMIN=2
43688      NJUNK=0
43689      MAXGRP=50000
43690C
43691      IF(IDATSW.EQ.'RAW')THEN
43692        HOLD=X(1)
43693        DO60I=1,N
43694          IF(X(I).NE.HOLD)GOTO69
43695   60   CONTINUE
43696        WRITE(ICOUT,999)
43697        CALL DPWRST('XXX','BUG ')
43698        WRITE(ICOUT,31)
43699        CALL DPWRST('XXX','BUG ')
43700        WRITE(ICOUT,62)
43701   62   FORMAT('      ALL INPUT HORIZONTAL AXIS ELEMENTS')
43702        CALL DPWRST('XXX','BUG ')
43703        WRITE(ICOUT,63)HOLD
43704   63   FORMAT('      ARE IDENTICALLY EQUAL TO ',G15.7)
43705        CALL DPWRST('XXX','BUG ')
43706        WRITE(ICOUT,999)
43707        CALL DPWRST('XXX','BUG ')
43708        IERROR='YES'
43709        GOTO9000
43710   69   CONTINUE
43711      ELSEIF(IDATSW.EQ.'FREQ')THEN
43712        CALL CKDIS2(Y,X,XTEMP1,N,MAXGRP,NMIN,XTEMP2,NJUNK,NTOT2,
43713     1              ISUBRO,IBUGG3,IERROR)
43714        IF(IERROR.EQ.'YES')GOTO9000
43715      ELSEIF(IDATSW.EQ.'FRE2')THEN
43716        CALL CKDIS3(Y,X,XHIGH,XTEMP1,N,MAXGRP,NMIN,XTEMP2,NJUNK,NTOT2,
43717     1              ISUBRO,IBUGG3,IERROR)
43718        IF(IERROR.EQ.'YES')GOTO9000
43719      ENDIF
43720C
43721      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PER2')THEN
43722        WRITE(ICOUT,999)
43723        CALL DPWRST('XXX','BUG ')
43724        WRITE(ICOUT,40)
43725   40   FORMAT('***** AT THE BEGINNING OF DPPER2--')
43726        CALL DPWRST('XXX','BUG ')
43727        WRITE(ICOUT,41)IDATSW,IPPTBI,IHSTCW,IHSTOU
43728   41   FORMAT('IDATSW,IPPTBI,IHSTCW,IHSTOU = ',3(A4,2X),A4)
43729        CALL DPWRST('XXX','BUG ')
43730        WRITE(ICOUT,42)N,N2,NUMVAR,MAXNXT,NCURVE,NHIGH
43731   42   FORMAT('N,N2,NUMVAR,MAXNXT,NCURVE,NHIGH = ',6I8)
43732        CALL DPWRST('XXX','BUG ')
43733        WRITE(ICOUT,43)CLWID,XSTART,XSTOP
43734   43   FORMAT('CLWID,XSTART,XSTOP = ',3G15.7)
43735        CALL DPWRST('XXX','BUG ')
43736        DO48I=1,N
43737          WRITE(ICOUT,44)I,Y(I),X(I),XHIGH(I)
43738   44     FORMAT('I,Y(I),X(I),XHIGH(I) = ',I8,3G15.7)
43739          CALL DPWRST('XXX','BUG ')
43740   48   CONTINUE
43741      ENDIF
43742C
43743C               **********************************************
43744C               **  STEP 2.0--                              **
43745C               **  HANDLE CASE FOR UNBINNED DATA           **
43746C               **********************************************
43747C
43748C     2011/2: ADD SUPPORT FOR ONE OR TWO "HIGHLIGHTING" VARIABLES
43749C
43750      IF(IPPTBI.EQ.'UNBI')THEN
43751        IF(NHIGH.GE.1)THEN
43752          CALL SORTC(X,TAG1,N,X,XTEMP1)
43753          DO76I=1,N
43754            N2=N2+1
43755            Y2(N2)=X(I)
43756            X2(N2)=100.0*REAL(I)/N
43757            D2(N2)=XTEMP1(I)
43758   76     CONTINUE
43759        ELSE
43760          CALL SORT(X,N,X)
43761          DO91I=1,N
43762            N2=N2+1
43763            Y2(N2)=X(I)
43764            X2(N2)=100.0*REAL(I)/REAL(N)
43765            D2(N2)=REAL(NCURVE)
43766   91     CONTINUE
43767        ENDIF
43768        GOTO9000
43769      ENDIF
43770C
43771C               **********************************************
43772C               **  STEP 2--                                **
43773C               **  IF NECESSARY,                           **
43774C               **  DETERMINE CLASS WIDTH,                  **
43775C               **  START VALUE, STOP VALUE,                **
43776C               **  AND NUMBER OF CLASSES.                  **
43777C               **********************************************
43778C
43779      IF(IDATSW.EQ.'RAW')THEN
43780        CALL DPBINZ(X,N,CLWID,XSTART,XSTOP,
43781     1              XTEMP1,MAXNXT,IHSTCW,IHSTOU,
43782     1              DVAL1,DVAL2,DVAL3,
43783     1              ISUBRO,IBUGG3,IERROR)
43784        DCLWID=REAL(DVAL1)
43785        DXSTAR=REAL(DVAL2)
43786        DXSTOP=REAL(DVAL3)
43787        CLWID=DCLWID
43788      ELSEIF(IDATSW.EQ.'FREQ')THEN
43789        CALL SORT(X,N,XTEMP1)
43790        NM1=N-1
43791        CLWID=XTEMP1(2)-XTEMP1(1)
43792        DO160I=1,NM1
43793          IP1=I+1
43794          DELI=XTEMP1(IP1)-XTEMP1(I)
43795          IF(DELI.LT.CLWID)CLWID=DELI
43796  160   CONTINUE
43797        DXSTAR=XTEMP1(1)-(CLWID/2.0)
43798        DXSTOP=XTEMP1(N)+(CLWID/2.0)
43799      ELSEIF(IDATSW.EQ.'FRE2')THEN
43800        DXSTAR=X(1)
43801        DXSTOP=XHIGH(N)
43802      ENDIF
43803C
43804      XSTART=DXSTAR
43805      XSTOP=DXSTOP
43806C
43807      IF(IDATSW.EQ.'FRE2')THEN
43808        NUMCLA=N
43809      ELSE
43810        TOTWID=XSTOP-XSTART
43811        ANUMCL=TOTWID/CLWID
43812        NUMCLA=INT(ANUMCL+1.0)
43813C
43814        J=NUMCLA-1
43815        AJ=J
43816        CLMAXJ=XSTART+AJ*CLWID
43817        ABSDEL=ABS(CLMAXJ-XSTOP)
43818        IF(ABSDEL.LE.0.0001)NUMCLA=NUMCLA-1
43819      ENDIF
43820C
43821C               *******************************************************
43822C               **  STEP 3--                                         **
43823C               **  DETERMINE THE FREQUENCY (COUNTS) FOR EACH CLASS  **
43824C               *******************************************************
43825C
43826      DO300J=1,NUMCLA
43827        XTEMP1(J)=0.0
43828  300 CONTINUE
43829C
43830      IF(IDATSW.EQ.'RAW')THEN
43831        DO420I=1,N
43832          DO430J=1,NUMCLA
43833            J2=J
43834            AJ=J
43835            CLMINJ=XSTART+(AJ-1.0)*CLWID
43836            CLMAXJ=XSTART+AJ*CLWID
43837            IF(CLMAXJ.GT.XSTOP)CLMAXJ=XSTOP
43838            IF(CLMINJ.LE.X(I).AND.X(I).LT.CLMAXJ)THEN
43839              XTEMP1(J2)=XTEMP1(J2)+1.0
43840              GOTO420
43841            ENDIF
43842  430     CONTINUE
43843  420   CONTINUE
43844C
43845C       FOR THIS RAW DATA CASE,
43846C       TREAT THE SPECIAL CASE OF EQUALITY
43847C       WITH THE UPPER LIMIT OF THE LAST (RIGHT-MOST) CLASS
43848C
43849        J=NUMCLA
43850        DO450I=1,N
43851          AJ=J
43852          CLMAXJ=XSTART+AJ*CLWID
43853          IF(CLMAXJ.GT.XSTOP)CLMAXJ=XSTOP
43854          IF(X(I).EQ.CLMAXJ)XTEMP1(J)=XTEMP1(J)+1.0
43855  450   CONTINUE
43856      ELSEIF(IDATSW.EQ.'FREQ')THEN
43857        DO520I=1,N
43858          DO530J=1,NUMCLA
43859            J2=J
43860            AJ=J
43861            CLMINJ=XSTART+(AJ-1.0)*CLWID
43862            CLMAXJ=XSTART+AJ*CLWID
43863            IF(CLMAXJ.GT.XSTOP)CLMAXJ=XSTOP
43864            IF(CLMINJ.LE.X(I).AND.X(I).LT.CLMAXJ)THEN
43865              XTEMP1(J2)=XTEMP1(J2)+Y(I)
43866              GOTO520
43867            ENDIF
43868  530     CONTINUE
43869  520   CONTINUE
43870C
43871C       FOR THIS FREQUENCY DATA CASE,
43872C       TREAT THE SPECIAL CASE OF EQUALITY
43873C       WITH THE UPPER LIMIT OF THE LAST (RIGHT-MOST) CLASS
43874C       (ALTHOUGH THIS SHOULD NOT HAPPEN WITH THE IDATSW = 'FREQ' CASE.)
43875C
43876        J=NUMCLA
43877        DO550I=1,N
43878          AJ=J
43879          CLMAXJ=XSTART+AJ*CLWID
43880          IF(CLMAXJ.GT.XSTOP)CLMAXJ=XSTOP
43881          IF(X(I).EQ.CLMAXJ)XTEMP1(J)=XTEMP1(J)+Y(I)
43882  550   CONTINUE
43883      ELSEIF(IDATSW.EQ.'FRE2')THEN
43884        DO620I=1,N
43885          DO630J=1,NUMCLA
43886            J2=J
43887            XTEMP1(J2)=XTEMP1(J2)+Y(I)
43888  630     CONTINUE
43889  620   CONTINUE
43890      ENDIF
43891C
43892      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PER2')THEN
43893        WRITE(ICOUT,999)
43894        CALL DPWRST('XXX','BUG ')
43895        WRITE(ICOUT,591)
43896  591   FORMAT('***** IN THE MIDDLE    OF DPPER2--')
43897        CALL DPWRST('XXX','BUG ')
43898        WRITE(ICOUT,592)CLWID,XSTART,XSTOP,TOTWID,ANUMCL,NUMCLA
43899  592   FORMAT('CLWID,XSTART,XSTOP,TOTWID,ANUMCL,NUMCLA= ',5E11.4,I8)
43900        CALL DPWRST('XXX','BUG ')
43901        DO593J=1,NUMCLA
43902          IF(IDATSW.NE.'FRE2')THEN
43903            AJ=J
43904            CLMINJ=XSTART+(AJ-1.0)*CLWID
43905            CLMAXJ=XSTART+AJ*CLWID
43906            IF(CLMAXJ.GT.XSTOP)CLMAXJ=XSTOP
43907            FJ=XTEMP1(J)
43908          ELSE
43909            CLMINJ=X(J)
43910            CLMAXJ=XHIGH(J)
43911            FJ=XTEMP1(J)
43912          ENDIF
43913          WRITE(ICOUT,594)J,CLMINJ,CLMAXJ,FJ
43914  594     FORMAT('J,CLMINJ,CLMAXJ,FJ = ',I8,3G15.7)
43915          CALL DPWRST('XXX','BUG ')
43916  593   CONTINUE
43917      ENDIF
43918C
43919C               **********************************
43920C               **  STEP 4--                    **
43921C               **  DETERMINE PLOT COORDINATES  **
43922C               **********************************
43923C
43924      SUM=0.0
43925      DO1110J=1,NUMCLA
43926        FJ=XTEMP1(J)
43927        SUM=SUM+FJ
43928 1110 CONTINUE
43929      AN3=SUM
43930C
43931      DENOM=AN3
43932C
43933      K=N2
43934      SUM=0.0
43935      DO1120J=1,NUMCLA
43936        K=K+1
43937        IF(IDATSW.NE.'FRE2')THEN
43938          AJ=J
43939          CLMINJ=XSTART+(AJ-1.0)*CLWID
43940          CLMAXJ=XSTART+AJ*CLWID
43941        ELSE
43942          CLMINJ=X(J)
43943          CLMAXJ=XHIGH(J)
43944        ENDIF
43945        IF(CLMAXJ.GT.XSTOP)CLMAXJ=XSTOP
43946        FJ=XTEMP1(J)
43947        SUM=SUM+FJ
43948        CUMFJ=SUM
43949        X2(K)=100.0*(CUMFJ/DENOM)
43950        Y2(K)=(CLMINJ+CLMAXJ)/2.0
43951        D2(K)=REAL(NCURVE)
43952 1120 CONTINUE
43953      N2=K
43954      NPLOTV=2
43955C
43956C               ******************
43957C               **   STEP 90--  **
43958C               **   EXIT       **
43959C               ******************
43960C
43961 9000 CONTINUE
43962      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PER2')THEN
43963        WRITE(ICOUT,999)
43964        CALL DPWRST('XXX','BUG ')
43965        WRITE(ICOUT,9011)
43966 9011   FORMAT('***** AT THE END       OF DPPER2--')
43967        CALL DPWRST('XXX','BUG ')
43968        WRITE(ICOUT,9012)N2
43969 9012   FORMAT('N2 = ',I8)
43970        CALL DPWRST('XXX','BUG ')
43971        WRITE(ICOUT,9013)IDATSW,AN3,DENOM,NUMCLA
43972 9013   FORMAT('IDATSW,AN3,DENOM,NUMCLA = ',A4,2X,2G15.7,I8)
43973        CALL DPWRST('XXX','BUG ')
43974        DO9015I=1,N2
43975          WRITE(ICOUT,9016)I,Y2(I),X2(I),D2(I)
43976 9016     FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,3G15.7)
43977          CALL DPWRST('XXX','BUG ')
43978 9015   CONTINUE
43979      ENDIF
43980C
43981      RETURN
43982      END
43983      SUBROUTINE DPPERC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
43984     1                  CLLIMI,CLWIDT,
43985     1                  IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
43986C
43987C     PURPOSE--GENERATE A PERCENT POINT PLOT;
43988C     WRITTEN BY--JAMES J. FILLIBEN
43989C                 STATISTICAL ENGINEERING DIVISION
43990C                 INFORMATION TECHNOLOGY LABORATORY
43991C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
43992C                 GAITHERSBURG, MD 20899-8980
43993C                 PHONE--301-975-2899
43994C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
43995C           OF THE NATIONAL BUREAU OF STANDARDS.
43996C     LANGUAGE--ANSI FORTRAN (1977)
43997C     VERSION NUMBER--82/7
43998C     ORIGINAL VERSION--APRIL     1978.
43999C     UPDATED         --JUNE      1978.
44000C     UPDATED         --JULY      1978.
44001C     UPDATED         --OCTOBER   1978.
44002C     UPDATED         --APRIL     1979.
44003C     UPDATED         --JANUARY   1981.
44004C     UPDATED         --OCTOBER   1981.
44005C     UPDATED         --MAY       1982.
44006C     UPDATED         --JUNE      1990. TEMPORARY ARRAYS TO GARBAGE COMMON
44007C     UPDATED         --SEPTEMBER 1998. OPTION TO NOT BIN THE DATA
44008C     UPDATED         --FEBRUARY  2011. RE-WRITE:
44009C                                       1) USE DPPARS TO PERFORM
44010C                                          SOME OF THE PARSING
44011C                                       2) SUPPORT "REPLICATION" AND
44012C                                          "MULTIPLE" KEYWORDS
44013C                                       3) SUPPORT "HIGHLIGHT" OPTION
44014C
44015C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
44016C
44017      CHARACTER*4 ICASPL
44018      CHARACTER*4 IAND1
44019      CHARACTER*4 IAND2
44020      CHARACTER*4 IBUGG2
44021      CHARACTER*4 IBUGG3
44022      CHARACTER*4 IBUGQ
44023      CHARACTER*4 ISUBRO
44024      CHARACTER*4 IFOUND
44025      CHARACTER*4 IERROR
44026C
44027      CHARACTER*4 IDATSW
44028      CHARACTER*4 IREPL
44029      CHARACTER*4 IHIGH
44030      CHARACTER*4 IWRITE
44031      CHARACTER*4 IMULT
44032      CHARACTER*4 ITERM1
44033      CHARACTER*4 ITERM2
44034      CHARACTER*4 ITERM3
44035      CHARACTER*4 ISUBN1
44036      CHARACTER*4 ISUBN2
44037      CHARACTER*4 ISTEPN
44038      CHARACTER*4 ICASE
44039      CHARACTER*4 IPPTSV
44040C
44041      CHARACTER*40 INAME
44042      PARAMETER (MAXSPN=30)
44043      CHARACTER*4 IVARN1(MAXSPN)
44044      CHARACTER*4 IVARN2(MAXSPN)
44045      CHARACTER*4 IVARTY(MAXSPN)
44046      REAL PVAR(MAXSPN)
44047      INTEGER ILIS(MAXSPN)
44048      INTEGER NRIGHT(MAXSPN)
44049      INTEGER ICOLR(MAXSPN)
44050C
44051C---------------------------------------------------------------------
44052C
44053      INCLUDE 'DPCOPA.INC'
44054C
44055      DIMENSION CLLIMI(*)
44056      DIMENSION CLWIDT(*)
44057C
44058      DIMENSION Y1(MAXOBV)
44059      DIMENSION X1(MAXOBV)
44060      DIMENSION XHIGH(MAXOBV)
44061      DIMENSION XTEMP1(MAXOBV)
44062      DIMENSION XTEMP2(MAXOBV)
44063      DIMENSION XTEMP3(MAXOBV)
44064      DIMENSION XTEMP4(MAXOBV)
44065      DIMENSION XDESGN(MAXOBV,6)
44066      DIMENSION XIDTEM(MAXOBV)
44067      DIMENSION XIDTE2(MAXOBV)
44068      DIMENSION ZY(MAXOBV)
44069      DIMENSION TAG1(MAXOBV)
44070CCCCC FOLLOWING LINES ADDED JUNE, 1990
44071      INCLUDE 'DPCOZZ.INC'
44072      EQUIVALENCE (GARBAG(IGARB1),X1(1))
44073      EQUIVALENCE (GARBAG(IGARB2),Y1(1))
44074      EQUIVALENCE (GARBAG(IGARB3),XHIGH(1))
44075      EQUIVALENCE (GARBAG(IGARB4),XTEMP1(1))
44076      EQUIVALENCE (GARBAG(IGARB5),XTEMP2(1))
44077      EQUIVALENCE (GARBAG(IGARB6),XTEMP3(1))
44078      EQUIVALENCE (GARBAG(IGARB7),XTEMP4(1))
44079      EQUIVALENCE (GARBAG(IGARB8),XIDTEM(1))
44080      EQUIVALENCE (GARBAG(IGARB9),XIDTE2(1))
44081      EQUIVALENCE (GARBAG(IGAR10),ZY(1))
44082      EQUIVALENCE (GARBAG(JGAR11),TAG1(1))
44083      EQUIVALENCE (GARBAG(JGAR13),XDESGN(1,1))
44084CCCCC END CHANGE
44085C
44086C-----COMMON----------------------------------------------------------
44087C
44088CCCCC ADD FOLLOWING LINE  SEPTEMBER 1998.
44089      INCLUDE 'DPCOST.INC'
44090      INCLUDE 'DPCOHK.INC'
44091      INCLUDE 'DPCODA.INC'
44092      INCLUDE 'DPCOP2.INC'
44093C
44094C-----START POINT-----------------------------------------------------
44095C
44096      IFOUND='NO'
44097      IERROR='NO'
44098      ISUBN1='DPPE'
44099      ISUBN2='RC  '
44100      IHIGH='OFF'
44101      IMULT='OFF'
44102      IREPL='OFF'
44103C
44104      N2=0
44105      IPPTSV=IPPTBI
44106      MAXCP1=MAXCOL+1
44107      MAXCP2=MAXCOL+2
44108      MAXCP3=MAXCOL+3
44109      MAXCP4=MAXCOL+4
44110      MAXCP5=MAXCOL+5
44111      MAXCP6=MAXCOL+6
44112C
44113C               ************************************
44114C               **  TREAT THE PERCENT POINT PLOT  **
44115C               ************************************
44116C
44117      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'PERC')THEN
44118        WRITE(ICOUT,999)
44119  999   FORMAT(1X)
44120        CALL DPWRST('XXX','BUG ')
44121        WRITE(ICOUT,51)
44122   51   FORMAT('***** AT THE BEGINNING OF DPPERC--')
44123        CALL DPWRST('XXX','BUG ')
44124        WRITE(ICOUT,52)ICASPL,IAND1,IAND2,NS
44125   52   FORMAT('ICASPL,IAND1,IAND2,NS = ',3(A4,2X),I8)
44126        CALL DPWRST('XXX','BUG ')
44127        WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ
44128   53   FORMAT('IBUGG2,IBUGG3,IBUGQ = ',A4,2X,A4,2X,A4)
44129        CALL DPWRST('XXX','BUG ')
44130      ENDIF
44131C
44132C               ***************************
44133C               **  STEP 1--             **
44134C               **  EXTRACT THE COMMAND  **
44135C               ***************************
44136C
44137C     LOOK FOR THE WORDS "PERCENT POINT PLOT".  ALSO LOOK
44138C     FOR THE KEYWORDS "MULTIPLE", "REPLICATION", OR "HIGHLIGHT".
44139C
44140      ISTEPN='1'
44141      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PERC')
44142     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
44143C
44144      ILASTC=-9999
44145      ILASTZ=-9999
44146      DO100I=0,NUMARG-1
44147C
44148        IF(I.EQ.0)THEN
44149          ITERM1=ICOM
44150          ITERM2=IHARG(I+1)
44151          ITERM3=IHARG(I+2)
44152        ELSE
44153          ITERM1=IHARG(I)
44154          ITERM2=IHARG(I+1)
44155          ITERM3=IHARG(I+2)
44156        ENDIF
44157C
44158        IF(ITERM1.EQ.'=   ')THEN
44159           IFOUND='NO'
44160           GOTO9000
44161        ENDIF
44162C
44163        IF(ITERM1.EQ.'PERC' .AND. ITERM2.EQ.'POIN' .AND.
44164     1     ITERM3.EQ.'PLOT')THEN
44165          IFOUND='YES'
44166          ILASTC=MAX(ILASTC,I+2)
44167          ILASTZ=ILASTI+1
44168        ELSEIF(ITERM1.EQ.'REPL')THEN
44169          IREPL='ON'
44170          ILASTC=MAX(ILASTC,I)
44171        ELSEIF(ITERM1.EQ.'MULT')THEN
44172          IMULT='ON'
44173          ILASTC=MAX(ILASTC,I)
44174        ELSEIF(ITERM1.EQ.'HIGH')THEN
44175          IHIGH='ON'
44176          ILASTC=MAX(ILASTC,I)
44177        ELSEIF(ITERM1.EQ.'GROU' .OR. ITERM1.EQ.'BINN')THEN
44178          IHIGH='ON'
44179          ILASTC=MAX(ILASTC,I)
44180        ENDIF
44181  100 CONTINUE
44182C
44183      IF(IFOUND.EQ.'NO')GOTO9000
44184      IF(IMULT.EQ.'ON')THEN
44185        IF(IREPL.EQ.'ON')THEN
44186          WRITE(ICOUT,999)
44187          CALL DPWRST('XXX','BUG ')
44188          WRITE(ICOUT,101)
44189  101     FORMAT('***** ERROR IN PERCENT POINT PLOT--')
44190          CALL DPWRST('XXX','BUG ')
44191          WRITE(ICOUT,102)
44192  102     FORMAT('      YOU CANNOT SPECIFY BOTH "MULTIPLE" AND ',
44193     1           '"REPLICATION" FOR THE PERCENT POINT PLOT.')
44194          CALL DPWRST('XXX','BUG ')
44195          IERROR='YES'
44196          GOTO9000
44197        ELSEIF(IHIGH.EQ.'ON')THEN
44198          WRITE(ICOUT,999)
44199          CALL DPWRST('XXX','BUG ')
44200          WRITE(ICOUT,101)
44201          CALL DPWRST('XXX','BUG ')
44202          WRITE(ICOUT,122)
44203  122     FORMAT('      YOU CANNOT SPECIFY BOTH "MULTIPLE" AND ',
44204     1           '"HIGHTLIGHTED" FOR THE PERCENT POINT PLOT.')
44205          CALL DPWRST('XXX','BUG ')
44206          IERROR='YES'
44207          GOTO9000
44208        ENDIF
44209      ENDIF
44210C
44211      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
44212      IFOUND='YES'
44213      ICASPL='PERC'
44214C
44215C               *********************************
44216C               **  STEP 2--                   **
44217C               **  EXTRACT THE VARIABLE LIST  **
44218C               *********************************
44219C
44220      ISTEPN='4'
44221      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PERC')
44222     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
44223C
44224      INAME='PERCENT POINT PLOT'
44225      MINNA=1
44226      MAXNA=100
44227      MINN2=2
44228      IFLAGE=1
44229      IFLAGM=0
44230      IF(IMULT.EQ.'ON')THEN
44231        IFLAGE=0
44232        IFLAGM=1
44233      ELSE
44234         IF(IREPL.EQ.'OFF' .AND. IHIGH.EQ.'OFF')IFLAGM=1
44235      ENDIF
44236      IFLAGP=0
44237      JMIN=1
44238      JMAX=NUMARG
44239      IF(IMULT.EQ.'OFF' .AND. IHIGH.EQ.'OFF' .AND. IREPL.EQ.'OFF')THEN
44240        MINNVA=1
44241        MAXNVA=3
44242        IFLAGM=1
44243      ELSEIF(IHIGH.EQ.'ON')THEN
44244        MINNVA=2
44245        MAXNVA=3
44246        IFLAGM=0
44247      ELSE
44248        MINNVA=-99
44249        MAXNVA=-99
44250      ENDIF
44251C
44252      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
44253     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
44254     1            JMIN,JMAX,
44255     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
44256     1            IVARN1,IVARN2,IVARTY,PVAR,
44257     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
44258     1            MINNVA,MAXNVA,
44259     1            IFLAGM,IFLAGP,
44260     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
44261      IF(IERROR.EQ.'YES')GOTO9000
44262C
44263      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PERC')THEN
44264        WRITE(ICOUT,999)
44265        CALL DPWRST('XXX','BUG ')
44266        WRITE(ICOUT,281)
44267  281   FORMAT('***** AFTER CALL DPPARS--')
44268        CALL DPWRST('XXX','BUG ')
44269        WRITE(ICOUT,282)NQ,NUMVAR
44270  282   FORMAT('NQ,NUMVAR = ',2I8)
44271        CALL DPWRST('XXX','BUG ')
44272        IF(NUMVAR.GT.0)THEN
44273          DO285I=1,NUMVAR
44274            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
44275     1                      ICOLR(I)
44276  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
44277     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
44278            CALL DPWRST('XXX','BUG ')
44279  285     CONTINUE
44280        ENDIF
44281      ENDIF
44282C
44283C               ***********************************************
44284C               **  STEP 3--                                 **
44285C               **  DETERMINE:                               **
44286C               **  1) NUMBER OF REPLICATION VARIABLES (0-2) **
44287C               **  2) NUMBER OF GROUPING    VARIABLES (0-2) **
44288C               **  3) NUMBER OF RESPONSE    VARIABLES (>= 1)**
44289C               **  4) NUMBER OF HIGHLIGHT   VARIABLES (0-2) **
44290C               ***********************************************
44291C
44292      ISTEPN='5'
44293      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PERC')
44294     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
44295C
44296      NRESP=0
44297      NREPL=0
44298      NGROUP=0
44299      NHIGH=0
44300      IDATSW='RAW'
44301      IF(IMULT.EQ.'ON')THEN
44302        NRESP=NUMVAR
44303      ELSEIF(IHIGH.EQ.'ON')THEN
44304        NRESP=1
44305        NHIGH=NUMVAR-1
44306        IF(NHIGH.LT.1 .OR. NHIGH.GT.2)THEN
44307          WRITE(ICOUT,999)
44308          CALL DPWRST('XXX','BUG ')
44309          WRITE(ICOUT,101)
44310          CALL DPWRST('XXX','BUG ')
44311          WRITE(ICOUT,501)
44312  501     FORMAT('      FOR THE HIGHLIGHTED CASE, THE NUMBER OF ',
44313     1           'HIGHLIGHT VARIABLES')
44314          CALL DPWRST('XXX','BUG ')
44315          WRITE(ICOUT,502)
44316  502     FORMAT('      MUST BE ONE OR TWO;  SUCH WAS NOT THE ',
44317     1           'CASE HERE.')
44318          CALL DPWRST('XXX','BUG ')
44319          WRITE(ICOUT,503)NHIGH
44320  503     FORMAT('      THE NUMBER OF HIGHLIGHT VARIABLES = ',I5)
44321          CALL DPWRST('XXX','BUG ')
44322          IERROR='YES'
44323          GOTO9000
44324        ENDIF
44325      ELSEIF(IREPL.EQ.'ON')THEN
44326        NRESP=1
44327        NREPL=NUMVAR-NRESP
44328        IF(NREPL.LT.1 .OR. NREPL.GT.2)THEN
44329          WRITE(ICOUT,999)
44330          CALL DPWRST('XXX','BUG ')
44331          WRITE(ICOUT,101)
44332          CALL DPWRST('XXX','BUG ')
44333          WRITE(ICOUT,511)
44334  511     FORMAT('      FOR THE REPLICATION CASE, THE NUMBER OF ',
44335     1           'REPLICATION VARIABLES')
44336          CALL DPWRST('XXX','BUG ')
44337          WRITE(ICOUT,512)
44338  512     FORMAT('      MUST BE BETWEEN 1 AND 2;  SUCH WAS NOT THE ',
44339     1           'CASE HERE.')
44340          CALL DPWRST('XXX','BUG ')
44341          WRITE(ICOUT,513)NREPL
44342  513     FORMAT('      THE NUMBER OF REPLICATION VARIABLES = ',I5)
44343          CALL DPWRST('XXX','BUG ')
44344          IERROR='YES'
44345          GOTO9000
44346        ENDIF
44347      ENDIF
44348C
44349C               ********************************************************
44350C               **  STEP 7--                                          **
44351C               **  DETERMINE IF THE ANALYST HAS SPECIFIED            **
44352C               **     1)  THE CLASS WIDTH,                           **
44353C               **     2)  THE MIN POINT OF THE FIRST CELL,           **
44354C               **     3)  THE MAX POINT OF THE LAST  CELL,           **
44355C               **  FOR THE DISTRIBUTIONAL ANALYSIS.                  **
44356C               **  IF NON-DEFAULT, USE THE SPECIFIED VALUES.         **
44357C               **  IF DEFAULT, USE THE DEFAULT VALUES--              **
44358C               **     1)  CLASS WIDTH = .3 OF A SAMPLE SD;           **
44359C               **     2)  START = SAMPLE MEAN - 6*(SAMPLE SD);       **
44360C               **     3)  STOP  = SAMPLE MEAN + 6*(SAMPLE SD);       **
44361C               ********************************************************
44362C
44363      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PERC')THEN
44364        ISTEPN='7'
44365        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
44366        WRITE(ICOUT,591)NRESP,NHIGH,NREPL
44367  591   FORMAT('NRESP,NHIGH,NREPL = ',3I8)
44368        CALL DPWRST('XXX','BUG ')
44369      ENDIF
44370C
44371      CLWID=CLWIDT(1)
44372      XSTART=CLLIMI(1)
44373      XSTOP=CLLIMI(2)
44374C
44375C               *********************************************
44376C               **  STEP 7A--                              **
44377C               **  CASE 1: NO REPLICATION, NO MULTIPLE,   **
44378C               **          AND NO HIGHLIGHTING            **
44379C               *********************************************
44380C
44381C     FOR THIS CASE, CAN HAVE ONE TO THREE RESPONSE VARIABLES
44382C     (DEPDENDING ON WHETHER WE HAVE BINNED DATA OR RAW DATA).
44383C
44384C     FOR THIS CASE, ONLY SUPPORT MATRIX ARGUMENT FOR RAW DATA
44385C     NUMBER OF OBSERVATIONS MUST BE THE SAME FOR ALL VARIABLES.
44386C
44387      IF(IMULT.EQ.'OFF' .AND. NREPL.EQ.0 .AND. NHIGH.EQ.0)THEN
44388        ISTEPN='7A'
44389        IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PERC')
44390     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
44391C
44392        ICOL=1
44393        IF(NUMVAR.EQ.1)THEN
44394          IDATSW='RAW'
44395          CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
44396     1                INAME,IVARN1,IVARN2,IVARTY,
44397     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
44398     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
44399     1                MAXCP4,MAXCP5,MAXCP6,
44400     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
44401     1                X1,Y1,XHIGH,NLOCAL,NLOCA2,NLOCA3,ICASE,
44402     1                IBUGG3,ISUBRO,IFOUND,IERROR)
44403        ELSEIF(NUMVAR.GE.2)THEN
44404          IDATSW='FREQ'
44405          IF(NUMVAR.EQ.3)IDATSW='FRE2'
44406          CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
44407     1                INAME,IVARN1,IVARN2,IVARTY,
44408     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
44409     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
44410     1                MAXCP4,MAXCP5,MAXCP6,
44411     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
44412     1                Y1,X1,XHIGH,NLOCAL,NLOCA2,NLOCA3,ICASE,
44413     1                IBUGG3,ISUBRO,IFOUND,IERROR)
44414        ENDIF
44415        IF(ICASE.EQ.'MATR' .AND. NUMVAR.GT.1)THEN
44416          WRITE(ICOUT,999)
44417          CALL DPWRST('XXX','BUG ')
44418          WRITE(ICOUT,101)
44419          CALL DPWRST('XXX','BUG ')
44420          WRITE(ICOUT,701)
44421  701     FORMAT('      MATRIX ARGUMENTS ARE ONLY SUPPORTED FOR THE')
44422          CALL DPWRST('XXX','BUG ')
44423          WRITE(ICOUT,703)
44424  703     FORMAT('      RAW DATA CASE.')
44425          CALL DPWRST('XXX','BUG ')
44426          IERROR='YES'
44427          GOTO9000
44428        ELSEIF(NUMVAR.EQ.2 .AND. NLOCAL.NE.NLOCA2)THEN
44429          WRITE(ICOUT,999)
44430          CALL DPWRST('XXX','BUG ')
44431          WRITE(ICOUT,101)
44432          CALL DPWRST('XXX','BUG ')
44433          WRITE(ICOUT,711)
44434  711     FORMAT('      FOR THE FREQUENCY CASE, THE NUMBER OF ',
44435     1           'OBSERVATIONS FOR')
44436          CALL DPWRST('XXX','BUG ')
44437          WRITE(ICOUT,713)
44438  713     FORMAT('      THE TWO VARIABLES MUST BE EQUAL.')
44439          CALL DPWRST('XXX','BUG ')
44440          WRITE(ICOUT,715)IVARN1(1),IVARN2(1),NLOCAL
44441  715     FORMAT('      ',A4,A4,' HAS ',I8,' OBSERVATIONS.')
44442          CALL DPWRST('XXX','BUG ')
44443          WRITE(ICOUT,715)IVARN1(2),IVARN2(2),NLOCA2
44444          CALL DPWRST('XXX','BUG ')
44445          IERROR='YES'
44446          GOTO9000
44447        ELSEIF(NUMVAR.EQ.3 .AND.
44448     1         (NLOCAL.NE.NLOCA2 .OR. NLOCAL.NE.NLOCA3))THEN
44449          WRITE(ICOUT,999)
44450          CALL DPWRST('XXX','BUG ')
44451          WRITE(ICOUT,101)
44452          CALL DPWRST('XXX','BUG ')
44453          WRITE(ICOUT,711)
44454          CALL DPWRST('XXX','BUG ')
44455          WRITE(ICOUT,723)
44456  723     FORMAT('      THE THREE VARIABLES MUST BE EQUAL.')
44457          CALL DPWRST('XXX','BUG ')
44458          WRITE(ICOUT,715)IVARN1(1),IVARN2(1),NLOCAL
44459          CALL DPWRST('XXX','BUG ')
44460          WRITE(ICOUT,715)IVARN1(2),IVARN2(2),NLOCA2
44461          CALL DPWRST('XXX','BUG ')
44462          WRITE(ICOUT,715)IVARN1(3),IVARN2(3),NLOCA3
44463          CALL DPWRST('XXX','BUG ')
44464          IERROR='YES'
44465          GOTO9000
44466        ENDIF
44467C
44468C       *****************************************************
44469C       **  STEP 7B--                                      **
44470C       **  FORM THE VERTICAL AND HORIZONTAL AXIS          **
44471C       **  VALUES Y(.) AND X(.) FOR THE PLOT.             **
44472C       **  RESET THE VECTOR D(.) TO ALL ONES.             **
44473C       **  DEFINE THE NUMBER OF PLOT POINTS    (NPLOTP).  **
44474C       **  DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV).  **
44475C       *****************************************************
44476C
44477C
44478        IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'PERC')THEN
44479          ISTEPN='7B'
44480          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
44481          WRITE(ICOUT,999)
44482          CALL DPWRST('XXX','BUG ')
44483          WRITE(ICOUT,731)
44484  731     FORMAT('***** FROM THE MIDDLE  OF DPPERC--')
44485          CALL DPWRST('XXX','BUG ')
44486          WRITE(ICOUT,732)ICASPL,NUMVAR,IDATSW,NLOCAL
44487  732     FORMAT('ICASPL,NUMVAR,IDATSW,NLOCAL = ',
44488     1           A4,I8,2X,A4,I8)
44489          CALL DPWRST('XXX','BUG ')
44490          IF(NLOCAL.GE.1)THEN
44491            DO735I=1,NLOCAL
44492              WRITE(ICOUT,736)I,Y1(I),X1(I),XHIGH(I)
44493  736         FORMAT('I,Y1(I),X1(I),XHIGH(I) = ',I8,4F12.5)
44494              CALL DPWRST('XXX','BUG ')
44495  735       CONTINUE
44496          ENDIF
44497        ENDIF
44498C
44499        N2=0
44500        NCURVE=1
44501        CALL DPPER2(Y1,X1,XHIGH,NLOCAL,IDATSW,NUMVAR,NCURVE,
44502     1              CLWID,XSTART,XSTOP,IHSTCW,IHSTOU,MAXOBV,
44503     1              IPPTBI,NHIGH,
44504     1              TAG1,XTEMP1,XTEMP2,
44505     1              Y,X,D,N2,NPLOTV,IBUGG3,ISUBRO,IERROR)
44506C
44507C               ******************************************
44508C               **  STEP 8A--                           **
44509C               **  CASE 2: MULTIPLE RESPONSE VARIABLES **
44510C               **          NOTE THAT HIGHLIGHTING AND  **
44511C               **          GROUPING ARE NOT SUPPORTED  **
44512C               **          FOR THIS CASE.              **
44513C               ******************************************
44514C
44515      ELSEIF(IMULT.EQ.'ON')THEN
44516        ISTEPN='8A'
44517        IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PERC')
44518     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
44519C
44520C       LOOP THROUGH EACH OF THE RESPONSE VARIABLES
44521C
44522        N2=0
44523        NCURVE=0
44524        DO810IRESP=1,NRESP
44525          NCURVE=NCURVE+1
44526C
44527          IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PERC')THEN
44528            WRITE(ICOUT,999)
44529            CALL DPWRST('XXX','BUG ')
44530            WRITE(ICOUT,811)IRESP,NCURVE
44531  811       FORMAT('IRESP,NCURVE = ',2I5)
44532            CALL DPWRST('XXX','BUG ')
44533          ENDIF
44534C
44535          ICOL=IRESP
44536          NUMVA2=1
44537          CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
44538     1                INAME,IVARN1,IVARN2,IVARTY,
44539     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
44540     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
44541     1                MAXCP4,MAXCP5,MAXCP6,
44542     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
44543     1                X1,XTEMP1,XTEMP2,NLOCAL,NLOCA2,NLOCA3,ICASE,
44544     1                IBUGG3,ISUBRO,IFOUND,IERROR)
44545C
44546C         *****************************************************
44547C         **  STEP 8B--                                      **
44548C         **  FORM THE VERTICAL AND HORIZONTAL AXIS          **
44549C         **  VALUES Y(.) AND X(.) FOR THE PLOT.             **
44550C         **  RESET THE VECTOR D(.) TO ALL ONES.             **
44551C         **  DEFINE THE NUMBER OF PLOT POINTS    (NPLOTP).  **
44552C         **  DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV).  **
44553C         *****************************************************
44554C
44555C
44556          IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'PERC')THEN
44557            ISTEPN='8B'
44558            CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
44559            WRITE(ICOUT,999)
44560            CALL DPWRST('XXX','BUG ')
44561            WRITE(ICOUT,822)
44562  822       FORMAT('***** FROM THE MIDDLE  OF DPPERC--')
44563            CALL DPWRST('XXX','BUG ')
44564            WRITE(ICOUT,823)ICASPL,NUMVAR,IDATSW,NLOCAL
44565  823       FORMAT('ICASPL,NUMVAR,IDATSW,NQ = ',
44566     1             A4,I8,2X,A4,I8)
44567            CALL DPWRST('XXX','BUG ')
44568            IF(NLOCAL.GE.1)THEN
44569              DO825I=1,NLOCAL
44570                WRITE(ICOUT,826)I,X1(I)
44571  826           FORMAT('I,X1(I) = ',I8,G15.7)
44572                CALL DPWRST('XXX','BUG ')
44573  825         CONTINUE
44574            ENDIF
44575          ENDIF
44576C
44577          CALL DPPER2(Y1,X1,XHIGH,NLOCAL,IDATSW,NUMVA2,NCURVE,
44578     1                CLWID,XSTART,XSTOP,IHSTCW,IHSTOU,MAXOBV,
44579     1                IPPTBI,NHIGH,
44580     1                TAG1,XTEMP1,XTEMP2,
44581     1                Y,X,D,N2,NPLOTV,IBUGG3,ISUBRO,IERROR)
44582  810   CONTINUE
44583C
44584C               ***************************************************
44585C               **  STEP 9A--                                    **
44586C               **  CASE 3: ONE OR MORE REPLICATION VARIABLES.   **
44587C               **          CURRENTLY, ONLY SUPPORT THIS OPTION  **
44588C               **          FOR UNBINNED DATA.  MAY UPDATE       **
44589C               **          SYNTAX AT A LATER TIME, SO SOME CODE **
44590C               **          HERE IS IN CASE WE IMPLEMENT THIS    **
44591C               **          AT A LATER TIME.                     **
44592C               ***************************************************
44593C
44594      ELSEIF(NRESP.GE.1 .AND. NREPL.GE.1)THEN
44595        ISTEPN='9A'
44596        IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PERC')
44597     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
44598C
44599        J=0
44600        IMAX=NRIGHT(1)
44601        IF(NQ.LT.NRIGHT(1))IMAX=NQ
44602        DO910I=1,IMAX
44603          IF(ISUB(I).EQ.0)GOTO910
44604          J=J+1
44605C
44606C         RESPONSE VARIABLE IN X1 (OR Y1 IF GROUPED DATA)
44607C
44608          IJ=MAXN*(ICOLR(1)-1)+I
44609          IF(ICOLR(1).LE.MAXCOL)Y1(J)=V(IJ)
44610          IF(ICOLR(1).EQ.MAXCP1)Y1(J)=PRED(I)
44611          IF(ICOLR(1).EQ.MAXCP2)Y1(J)=RES(I)
44612          IF(ICOLR(1).EQ.MAXCP3)Y1(J)=YPLOT(I)
44613          IF(ICOLR(1).EQ.MAXCP4)Y1(J)=XPLOT(I)
44614          IF(ICOLR(1).EQ.MAXCP5)Y1(J)=X2PLOT(I)
44615          IF(ICOLR(1).EQ.MAXCP6)Y1(J)=TAGPLO(I)
44616          ICOLC=1
44617C
44618C         CLASS VARIABLE IN X1 FOR FREQUENCY DATA
44619C
44620          IF(NGROUP.GE.1)THEN
44621            ICOLC=1
44622            IJ=MAXN*(ICOLR(1)-1)+I
44623            IF(ICOLR(1).LE.MAXCOL)Y1(J)=V(IJ)
44624            IF(ICOLR(1).EQ.MAXCP1)Y1(J)=PRED(I)
44625            IF(ICOLR(1).EQ.MAXCP2)Y1(J)=RES(I)
44626            IF(ICOLR(1).EQ.MAXCP3)Y1(J)=YPLOT(I)
44627            IF(ICOLR(1).EQ.MAXCP4)Y1(J)=XPLOT(I)
44628            IF(ICOLR(1).EQ.MAXCP5)Y1(J)=X2PLOT(I)
44629            IF(ICOLR(1).EQ.MAXCP6)Y1(J)=TAGPLO(I)
44630            ICOLC=ICOLC+1
44631            ICOLT=ICOLR(ICOLC)
44632            IJ=MAXN*(ICOLT-1)+I
44633            IF(ICOLT.LE.MAXCOL)X1(J)=V(IJ)
44634            IF(ICOLT.EQ.MAXCP1)X1(J)=PRED(I)
44635            IF(ICOLT.EQ.MAXCP2)X1(J)=RES(I)
44636            IF(ICOLT.EQ.MAXCP3)X1(J)=YPLOT(I)
44637            IF(ICOLT.EQ.MAXCP4)X1(J)=XPLOT(I)
44638            IF(ICOLT.EQ.MAXCP5)X1(J)=X2PLOT(I)
44639            IF(ICOLT.EQ.MAXCP6)X1(J)=TAGPLO(I)
44640          ENDIF
44641C
44642C         IF FREQUENCY DATA GIVEN WITH LOWER AND UPPER CLASS LIMITS,
44643C         THEN UPPER CLASS LIMIT VARIABLE IN XHIGH
44644C
44645          IF(NGROUP.EQ.2)THEN
44646            ICOLC=ICOLC+1
44647            ICOLT=ICOLR(ICOLC)
44648            IJ=MAXN*(ICOLT-1)+I
44649            IF(ICOLT.LE.MAXCOL)XHIGH(J)=V(IJ)
44650            IF(ICOLT.EQ.MAXCP1)XHIGH(J)=PRED(I)
44651            IF(ICOLT.EQ.MAXCP2)XHIGH(J)=RES(I)
44652            IF(ICOLT.EQ.MAXCP3)XHIGH(J)=YPLOT(I)
44653            IF(ICOLT.EQ.MAXCP4)XHIGH(J)=XPLOT(I)
44654            IF(ICOLT.EQ.MAXCP5)XHIGH(J)=X2PLOT(I)
44655            IF(ICOLT.EQ.MAXCP6)XHIGH(J)=TAGPLO(I)
44656          ENDIF
44657C
44658          DO920IR=1,MIN(NREPL,2)
44659            ICOLC=ICOLC+1
44660            ICOLT=ICOLR(ICOLC)
44661            IJ=MAXN*(ICOLT-1)+I
44662            IF(ICOLT.LE.MAXCOL)XDESGN(J,IR)=V(IJ)
44663            IF(ICOLT.EQ.MAXCP1)XDESGN(J,IR)=PRED(I)
44664            IF(ICOLT.EQ.MAXCP2)XDESGN(J,IR)=RES(I)
44665            IF(ICOLT.EQ.MAXCP3)XDESGN(J,IR)=YPLOT(I)
44666            IF(ICOLT.EQ.MAXCP4)XDESGN(J,IR)=XPLOT(I)
44667            IF(ICOLT.EQ.MAXCP5)XDESGN(J,IR)=X2PLOT(I)
44668            IF(ICOLT.EQ.MAXCP6)XDESGN(J,IR)=TAGPLO(I)
44669  920     CONTINUE
44670C
44671  910   CONTINUE
44672        NLOCAL=J
44673C
44674C       *****************************************************
44675C       **  STEP 9B--                                      **
44676C       **  FORM THE VERTICAL AND HORIZONTAL AXIS          **
44677C       **  VALUES Y(.) AND X(.) FOR THE PLOT.             **
44678C       **                                                 **
44679C       **  FOR THIS CASE, WE NEED TO LOOP THROUGH THE     **
44680C       **  VARIOUS REPLICATIONS.                          **
44681C       *****************************************************
44682C
44683        IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'PERC')THEN
44684          ISTEPN='9B'
44685          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
44686          WRITE(ICOUT,999)
44687          CALL DPWRST('XXX','BUG ')
44688          WRITE(ICOUT,931)
44689  931     FORMAT('***** FROM THE MIDDLE  OF DPPP--')
44690          CALL DPWRST('XXX','BUG ')
44691          WRITE(ICOUT,932)ICASPL,NUMVAR,IDATSW,NLOCAL
44692  932     FORMAT('ICASPL,NUMVAR,IDATSW,NQ = ',
44693     1           A4,I8,2X,A4,I8)
44694          CALL DPWRST('XXX','BUG ')
44695          IF(NLOCAL.GE.1)THEN
44696            DO935I=1,NLOCAL
44697              WRITE(ICOUT,936)I,Y1(I),XDESGN(I,1),XDESGN(I,2)
44698  936         FORMAT('I,Y1(I),XDESGN(I,1),XDESGN(I,2)=',I8,3G15.7)
44699              CALL DPWRST('XXX','BUG ')
44700  935       CONTINUE
44701          ENDIF
44702        ENDIF
44703C
44704C       *****************************************************
44705C       **  STEP 9C--                                      **
44706C       **  FIND THE DISTINCT VALUES IN EACH OF THE        **
44707C       **  REPLICATION VARIABLES.                         **
44708C       *****************************************************
44709C
44710        CALL DPPP5(XDESGN(1,1),XDESGN(1,2),XDESGN(1,3),
44711     1             XDESGN(1,4),XDESGN(1,5),XDESGN(1,6),
44712     1             NREPL,NLOCAL,MAXOBV,
44713     1             XIDTEM,XIDTE2,XIDTE2,XIDTE2,XIDTE2,XIDTE2,
44714     1             XTEMP1,XTEMP2,
44715     1             NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,NUMSE6,
44716     1             IBUGG3,ISUBRO,IERROR)
44717C
44718C       *****************************************************
44719C       **  STEP 9D--                                      **
44720C       **  NOW LOOP THROUGH THE VARIOUS REPLICATIONS      **
44721C       *****************************************************
44722C
44723        N2=0
44724        NCURVE=0
44725        IF(NREPL.EQ.1)THEN
44726          J=0
44727          DO1110ISET1=1,NUMSE1
44728            K=0
44729            DO1130I=1,NLOCAL
44730              IF(XIDTEM(ISET1).EQ.XDESGN(I,1))THEN
44731                K=K+1
44732                ZY(K)=Y1(I)
44733              ENDIF
44734 1130       CONTINUE
44735            NTEMP=K
44736            NCURVE=NCURVE+1
44737            NUMVA2=1
44738            IF(NTEMP.GT.0)THEN
44739              CALL DPPER2(Y1,ZY,XHIGH,NTEMP,IDATSW,NUMVA2,NCURVE,
44740     1                    CLWID,XSTART,XSTOP,IHSTCW,IHSTOU,MAXOBV,
44741     1                    IPPTBI,NHIGH,
44742     1                    TAG1,XTEMP1,XTEMP2,
44743     1                    Y,X,D,N2,NPLOTV,IBUGG3,ISUBRO,IERROR)
44744            ENDIF
44745 1110     CONTINUE
44746        ELSEIF(NREPL.EQ.2)THEN
44747          J=0
44748          NTOT=NUMSE1*NUMSE2
44749          DO1210ISET1=1,NUMSE1
44750          DO1220ISET2=1,NUMSE2
44751            K=0
44752            DO1290I=1,NLOCAL
44753              IF(
44754     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
44755     1           XIDTE2(ISET2).EQ.XDESGN(I,2)
44756     1          )THEN
44757                K=K+1
44758                ZY(K)=Y1(I)
44759              ENDIF
44760 1290       CONTINUE
44761            NTEMP=K
44762            NCURVE=NCURVE+1
44763            NUMVA2=1
44764            IF(NTEMP.GT.0)THEN
44765              CALL DPPER2(Y1,ZY,XHIGH,NTEMP,IDATSW,NUMVA2,NCURVE,
44766     1                    CLWID,XSTART,XSTOP,IHSTCW,IHSTOU,MAXOBV,
44767     1                    IPPTBI,NHIGH,
44768     1                    TAG1,XTEMP1,XTEMP2,
44769     1                    Y,X,D,N2,NPLOTV,IBUGG3,ISUBRO,IERROR)
44770            ENDIF
44771 1220     CONTINUE
44772 1210     CONTINUE
44773        ENDIF
44774C
44775C               ***************************************************
44776C               **  STEP 10A--                                   **
44777C               **  CASE 4: ONE OR TWO HIGHLIGHT VARIABLES.      **
44778C               **          THIS CASE SUPPORTS CENSORING, BUT    **
44779C               **          NOT GROUPING.  FOR THIS CASE, ALL    **
44780C               **          VARIABLES MUST HAVE THE SAME LENGTH. **
44781C               ***************************************************
44782C
44783      ELSEIF(NRESP.EQ.1 .AND. NHIGH.GE.1)THEN
44784        ISTEPN='10A'
44785        IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PERC')
44786     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
44787C
44788        IPPTBI='UNBI'
44789        J=0
44790        IMAX=NRIGHT(1)
44791        IF(NQ.LT.NRIGHT(1))IMAX=NQ
44792        DO1710I=1,IMAX
44793          IF(ISUB(I).EQ.0)GOTO1710
44794          J=J+1
44795C
44796C         RESPONSE VARIABLE IN Y1
44797C
44798          IJ=MAXN*(ICOLR(1)-1)+I
44799          IF(ICOLR(1).LE.MAXCOL)Y1(J)=V(IJ)
44800          IF(ICOLR(1).EQ.MAXCP1)Y1(J)=PRED(I)
44801          IF(ICOLR(1).EQ.MAXCP2)Y1(J)=RES(I)
44802          IF(ICOLR(1).EQ.MAXCP3)Y1(J)=YPLOT(I)
44803          IF(ICOLR(1).EQ.MAXCP4)Y1(J)=XPLOT(I)
44804          IF(ICOLR(1).EQ.MAXCP5)Y1(J)=X2PLOT(I)
44805          IF(ICOLR(1).EQ.MAXCP6)Y1(J)=TAGPLO(I)
44806          ICOLC=1
44807C
44808C         HIGHLIGHT VARIABLE ONE IN X1
44809C
44810          IF(NHIGH.GE.1)THEN
44811            ICOLC=ICOLC+1
44812            ICOLT=ICOLR(ICOLC)
44813            IJ=MAXN*(ICOLT-1)+I
44814            IF(ICOLT.LE.MAXCOL)X1(J)=V(IJ)
44815            IF(ICOLT.EQ.MAXCP1)X1(J)=PRED(I)
44816            IF(ICOLT.EQ.MAXCP2)X1(J)=RES(I)
44817            IF(ICOLT.EQ.MAXCP3)X1(J)=YPLOT(I)
44818            IF(ICOLT.EQ.MAXCP4)X1(J)=XPLOT(I)
44819            IF(ICOLT.EQ.MAXCP5)X1(J)=X2PLOT(I)
44820            IF(ICOLT.EQ.MAXCP6)X1(J)=TAGPLO(I)
44821          ENDIF
44822C
44823C         HIGHLIGHT VARIABLE TWO IN XHIGH
44824C
44825          IF(NHIGH.GE.2)THEN
44826            ICOLC=ICOLC+1
44827            ICOLT=ICOLR(ICOLC)
44828            IJ=MAXN*(ICOLT-1)+I
44829            IF(ICOLT.LE.MAXCOL)XHIGH(J)=V(IJ)
44830            IF(ICOLT.EQ.MAXCP1)XHIGH(J)=PRED(I)
44831            IF(ICOLT.EQ.MAXCP2)XHIGH(J)=RES(I)
44832            IF(ICOLT.EQ.MAXCP3)XHIGH(J)=YPLOT(I)
44833            IF(ICOLT.EQ.MAXCP4)XHIGH(J)=XPLOT(I)
44834            IF(ICOLT.EQ.MAXCP5)XHIGH(J)=X2PLOT(I)
44835            IF(ICOLT.EQ.MAXCP6)XHIGH(J)=TAGPLO(I)
44836          ENDIF
44837C
44838 1710   CONTINUE
44839        NLOCAL=J
44840C
44841        IF(NHIGH.EQ.1)THEN
44842          CALL CODE(X1,NLOCAL,IWRITE,TAG1,XTEMP1,MAXOBV,
44843     1              IBUGG3,IERROR)
44844        ELSE
44845          ICCTOF=0
44846          ICCTG1=0
44847          CALL CODCT2(X1,XHIGH,NLOCAL,ICCTOF,ICCTG1,IWRITE,
44848     1                TAG1,XTEMP1,XTEMP2,
44849     1                IBUGG3,ISUBRO,IERROR)
44850        ENDIF
44851C
44852        DO1720I=1,N
44853          X1(I)=Y1(I)
44854 1720   CONTINUE
44855C
44856C       *****************************************************
44857C       **  STEP 10B--                                     **
44858C       **  FORM THE VERTICAL AND HORIZONTAL AXIS          **
44859C       **  VALUES Y(.) AND X(.) FOR THE PLOT.             **
44860C       **                                                 **
44861C       **  FOR THIS CASE, WE NEED TO LOOP THROUGH THE     **
44862C       **  VARIOUS REPLICATIONS.                          **
44863C       *****************************************************
44864C
44865        IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'PERC')THEN
44866          ISTEPN='10B'
44867          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
44868          WRITE(ICOUT,999)
44869          CALL DPWRST('XXX','BUG ')
44870          WRITE(ICOUT,1731)
44871 1731     FORMAT('***** FROM THE MIDDLE  OF DPPERC--')
44872          CALL DPWRST('XXX','BUG ')
44873          WRITE(ICOUT,1732)ICASPL,NUMVAR,IDATSW,NLOCAL
44874 1732     FORMAT('ICASPL,NUMVAR,IDATSW,NQ = ',
44875     1           A4,I8,2X,A4,I8)
44876          CALL DPWRST('XXX','BUG ')
44877          IF(NLOCAL.GE.1)THEN
44878            DO1735I=1,NLOCAL
44879              WRITE(ICOUT,1736)I,Y1(I),TAG1(I)
44880 1736         FORMAT('I,Y1(I),TAG1(I) = ',I8,2G15.7)
44881              CALL DPWRST('XXX','BUG ')
44882 1735       CONTINUE
44883          ENDIF
44884        ENDIF
44885C
44886C       *******************************************************
44887C       **  STEP 10C--                                       **
44888C       **  GENERATE THE PERCENT POINT PLOT (RAW DATA CASE   **
44889C       **  ONLY).                                           **
44890C       *******************************************************
44891C
44892        N2=0
44893        NCURVE=1
44894        CALL DPPER2(Y1,X1,XHIGH,NLOCAL,IDATSW,NUMVA2,NCURVE,
44895     1              CLWID,XSTART,XSTOP,IHSTCW,IHSTOU,MAXOBV,
44896     1              IPPTBI,NHIGH,
44897     1              TAG1,XTEMP1,XTEMP2,
44898     1              Y,X,D,N2,NPLOTV,IBUGG3,ISUBRO,IERROR)
44899C
44900      ENDIF
44901C
44902C               *****************
44903C               **  STEP 90--  **
44904C               **  EXIT       **
44905C               *****************
44906C
44907 9000 CONTINUE
44908      NPLOTP=N2
44909      IPPTBI=IPPTSV
44910      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'PERC')THEN
44911        WRITE(ICOUT,999)
44912        CALL DPWRST('XXX','BUG ')
44913        WRITE(ICOUT,9011)
44914 9011   FORMAT('***** AT THE END       OF DPPERC--')
44915        CALL DPWRST('XXX','BUG ')
44916        WRITE(ICOUT,9012)IFOUND,IERROR
44917 9012   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
44918        CALL DPWRST('XXX','BUG ')
44919        WRITE(ICOUT,9013)NPLOTV,NPLOTP,N2,ICASPL,IAND1,IAND2
44920 9013   FORMAT('NPLOTV,NPLOTP,N2,ICASPL,IAND1,IAND2 = ',
44921     1         3I8,2(2X,A4),2X,A4)
44922        CALL DPWRST('XXX','BUG ')
44923        WRITE(ICOUT,9014)CLWID,XSTART,XSTOP
44924 9014   FORMAT('CLWID,XSTART,XSTOP = ',3G15.7)
44925        CALL DPWRST('XXX','BUG ')
44926        IF(NPLOTP.GE.1)THEN
44927          DO9015I=1,NPLOTP
44928            WRITE(ICOUT,9016)I,Y(I),X(I),D(I)
44929 9016       FORMAT('I,Y(I),X(I),D(I) = ',I8,3G15.7)
44930            CALL DPWRST('XXX','BUG ')
44931 9015     CONTINUE
44932        ENDIF
44933      ENDIF
44934C
44935      RETURN
44936      END
44937      SUBROUTINE DPPESZ(IHARG,IARGT,ARG,NUMARG,
44938     1PDEPSZ,PPEDSZ,
44939     1IFOUND,IERROR)
44940C
44941C     PURPOSE--DEFINE THE SIZE FOR THE 3-D PEDESTAL.
44942C              THE SIZE FOR THE PEDESTAL WILL BE PLACED
44943C              IN THE FLOATING POINT VARIABLE PPEDSZ.
44944C              THE SIZE FOR THE PEDESTAL WILL BE
44945C              IN UNITS OF THE Z AXIS VARIABLE.
44946C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
44947C                     --NUMARG
44948C                     --PDEPSZ
44949C     OUTPUT ARGUMENTS--PPEDSZ
44950C                     --IFOUND ('YES' OR 'NO' )
44951C                     --IERROR ('YES' OR 'NO' )
44952C     NOTE--THIS SUBROUTINE ASSUMES A
44953C           COMPLICATED-TO-SIMPLE CHECKING ORDER
44954C           (IN MAIPC4) OF THE VARIOUS PEDESTAL COMMANDS.
44955C     WRITTEN BY--JAMES J. FILLIBEN
44956C                 STATISTICAL ENGINEERING DIVISION
44957C                 INFORMATION TECHNOLOGY LABORATORY
44958C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
44959C                 GAITHERSBURG, MD 20899-8980
44960C                 PHONE--301-975-2899
44961C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
44962C           OF THE NATIONAL BUREAU OF STANDARDS.
44963C     LANGUAGE--ANSI FORTRAN (1977)
44964C     VERSION NUMBER--82/7
44965C     ORIGINAL VERSION--SEPTEMBER 1980.
44966C     UPDATED         --MAY       1982.
44967C
44968C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
44969C
44970      CHARACTER*4 IHARG
44971      CHARACTER*4 IARGT
44972      CHARACTER*4 IFOUND
44973      CHARACTER*4 IERROR
44974C
44975C---------------------------------------------------------------------
44976C
44977      DIMENSION IHARG(*)
44978      DIMENSION IARGT(*)
44979      DIMENSION ARG(*)
44980C
44981C---------------------------------------------------------------------
44982C
44983      INCLUDE 'DPCOP2.INC'
44984C
44985C-----START POINT-----------------------------------------------------
44986C
44987      IFOUND='NO'
44988      IERROR='NO'
44989C
44990      IF(NUMARG.EQ.0)GOTO1199
44991      IF(NUMARG.EQ.1)GOTO1150
44992C
44993      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
44994      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
44995      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
44996      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
44997      IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160
44998      GOTO1120
44999C
45000 1120 CONTINUE
45001      IERROR='YES'
45002      WRITE(ICOUT,1121)
45003 1121 FORMAT('***** ERROR IN DPPESZ--')
45004      CALL DPWRST('XXX','BUG ')
45005      WRITE(ICOUT,1122)
45006 1122 FORMAT('      ILLEGAL SYNTAX FOR THE PEDESTAL SIZE ',
45007     1'COMMAND.')
45008      CALL DPWRST('XXX','BUG ')
45009      WRITE(ICOUT,1124)
45010 1124 FORMAT('      TEST EXAMPLE TO DEMONSTRATE THE ',
45011     1'PROPER SYNTAX--')
45012      CALL DPWRST('XXX','BUG ')
45013      WRITE(ICOUT,1125)
45014 1125 FORMAT('      SUPPOSE THE Z AXIS DATA RANGES FROM ')
45015      CALL DPWRST('XXX','BUG ')
45016      WRITE(ICOUT,1126)
45017 1126 FORMAT('      500 TO 2000 (FOR A DIFFERENCE OF 1500 UNITS), ')
45018      CALL DPWRST('XXX','BUG ')
45019      WRITE(ICOUT,1127)
45020 1127 FORMAT('      AND SUPPOSE THE ANALYST WISHES THE  ')
45021      CALL DPWRST('XXX','BUG ')
45022      WRITE(ICOUT,1128)
45023 1128 FORMAT('      PLOT PEDESTAL TO HAVE A HEIGHT OF ABOUT ')
45024      CALL DPWRST('XXX','BUG ')
45025      WRITE(ICOUT,1129)
45026 1129 FORMAT('      200 SUCH UNITS; ')
45027      CALL DPWRST('XXX','BUG ')
45028      WRITE(ICOUT,1130)
45029 1130 FORMAT('      THEN THE PROPER SYNTAX IS--')
45030      CALL DPWRST('XXX','BUG ')
45031      WRITE(ICOUT,1131)
45032 1131 FORMAT('         PEDESTAL SIZE 200 ')
45033      CALL DPWRST('XXX','BUG ')
45034      GOTO1199
45035C
45036 1150 CONTINUE
45037      PPEDSZ=PDEPSZ
45038      GOTO1180
45039C
45040 1160 CONTINUE
45041      PPEDSZ=ARG(NUMARG)
45042      GOTO1180
45043C
45044 1180 CONTINUE
45045      IFOUND='YES'
45046C
45047      IF(IFEEDB.EQ.'OFF')GOTO1189
45048      WRITE(ICOUT,999)
45049  999 FORMAT(1X)
45050      CALL DPWRST('XXX','BUG ')
45051      WRITE(ICOUT,1181)PPEDSZ
45052 1181 FORMAT('THE (3-D) PEDESTAL SIZE (HEIGHT) ',
45053     1'HAS JUST BEEN SET TO ',E15.7)
45054      CALL DPWRST('XXX','BUG ')
45055 1189 CONTINUE
45056      GOTO1199
45057C
45058 1199 CONTINUE
45059      RETURN
45060      END
45061      SUBROUTINE DPPID(IPID,IBUGS2,ISUBRO,IFOUND,IERROR)
45062C
45063C     PURPOSE--RETURN THE PROCESS-ID.
45064C     WRITTEN BY--ALAN HECKERT
45065C                 STATISTICAL ENGINEERING DIVISION
45066C                 INFORMATION TECHNOLOGY LABORATORY
45067C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
45068C                 GAITHERSBURG, MD 20899-8980
45069C                 PHONE--301-975-2899
45070C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
45071C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
45072C     LANGUAGE--ANSI FORTRAN (1977)
45073C               HOST DEPENDENT
45074C     VERSION NUMBER--2006.3
45075C     ORIGINAL VERSION--MARCH      2006.
45076C
45077C-----NON-COMMON VARIABLES (GRAPHICS)---------------------------------
45078C
45079      CHARACTER*4 IBUGS2
45080      CHARACTER*4 ISUBRO
45081      CHARACTER*4 IFOUND
45082      CHARACTER*4 IERROR
45083C
45084C-----COMMON----------------------------------------------------------
45085C
45086      INCLUDE 'DPCOHO.INC'
45087      INCLUDE 'DPCOP2.INC'
45088C
45089C-----START POINT-----------------------------------------------------
45090C
45091C
45092      IFOUND='NO'
45093      IERROR='NO'
45094C
45095      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'PPID')THEN
45096        WRITE(ICOUT,999)
45097  999   FORMAT(1X)
45098        CALL DPWRST('XXX','BUG ')
45099        WRITE(ICOUT,51)
45100   51   FORMAT('***** AT THE BEGINNING OF DPPID--')
45101        CALL DPWRST('XXX','BUG ')
45102        WRITE(ICOUT,81)IBUGS2,ISUBRO,IFOUND,IERROR
45103   81   FORMAT('IBUGS2,ISUBRO,IFOUND,IERROR = ',3(A4,2X),A4)
45104        CALL DPWRST('XXX','BUG ')
45105      ENDIF
45106C
45107      IFOUND='YES'
45108      CALL DPPID2(IPID,ISUBRO,IERROR)
45109C
45110      WRITE(ICOUT,999)
45111      CALL DPWRST('XXX','BUG ')
45112      WRITE(ICOUT,1011)IPID
45113 1011 FORMAT('***** PROCESS ID: ',I8,' SAVED IN INTERNAL ',
45114     1       'PARAMETER   PID')
45115      CALL DPWRST('XXX','BUG ')
45116C
45117C               *****************
45118C               **  STEP 90--  **
45119C               **  EXIT       **
45120C               *****************
45121C
45122      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'PPID')THEN
45123        WRITE(ICOUT,999)
45124        CALL DPWRST('XXX','BUG ')
45125        WRITE(ICOUT,9011)
45126 9011   FORMAT('***** AT THE END       OF DPPID--')
45127        CALL DPWRST('XXX','BUG ')
45128        WRITE(ICOUT,9021)IPID,IERROR
45129 9021   FORMAT('IPID,IERROR = ',I8,2X,A4)
45130        CALL DPWRST('XXX','BUG ')
45131      ENDIF
45132C
45133      RETURN
45134      END
45135      SUBROUTINE DPPIE(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
45136     1                 CLLIMI,CLWIDT,
45137     1                 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
45138C
45139C     PURPOSE--GENERATE A PIE CHART
45140C     WRITTEN BY--JAMES J. FILLIBEN
45141C                 STATISTICAL ENGINEERING DIVISION
45142C                 INFORMATION TECHNOLOGY LABORATORY
45143C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
45144C                 GAITHERSBURG, MD 20899-8980
45145C                 PHONE--301-975-2899
45146C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
45147C           OF THE NATIONAL BUREAU OF STANDARDS.
45148C     LANGUAGE--ANSI FORTRAN (1977)
45149C     VERSION NUMBER--82/7
45150C     ORIGINAL VERSION--APRIL     1978.
45151C     UPDATED         --JUNE      1978.
45152C     UPDATED         --JULY      1978.
45153C     UPDATED         --OCTOBER   1978.
45154C     UPDATED         --APRIL     1979.
45155C     UPDATED         --JANUARY   1981.
45156C     UPDATED         --OCTOBER   1981.
45157C     UPDATED         --MAY       1982.
45158C     UPDATED         --JUNE      1990. TEMPORARY ARRAYS TO GARBAGE COMMON
45159C     UPDATED         --NOVEMBER  1993. ADDITIONAL ARRAY FOR DPPIE2
45160C     UPDATED         --FEBRUARY  2012. USE DPPARS
45161C
45162C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
45163C
45164      CHARACTER*4 ICASPL
45165      CHARACTER*4 IAND1
45166      CHARACTER*4 IAND2
45167      CHARACTER*4 IBUGG2
45168      CHARACTER*4 IBUGG3
45169      CHARACTER*4 IBUGQ
45170      CHARACTER*4 ISUBRO
45171      CHARACTER*4 IFOUND
45172      CHARACTER*4 IERROR
45173C
45174      CHARACTER*4 IDATSW
45175      CHARACTER*4 ISUBN1
45176      CHARACTER*4 ISUBN2
45177      CHARACTER*4 ISTEPN
45178C
45179      CHARACTER*4 ICASE
45180      CHARACTER*40 INAME
45181      PARAMETER (MAXSPN=10)
45182      CHARACTER*4 IVARN1(MAXSPN)
45183      CHARACTER*4 IVARN2(MAXSPN)
45184      CHARACTER*4 IVARTY(MAXSPN)
45185      REAL PVAR(MAXSPN)
45186      INTEGER ILIS(MAXSPN)
45187      INTEGER NRIGHT(MAXSPN)
45188      INTEGER ICOLR(MAXSPN)
45189C
45190C---------------------------------------------------------------------
45191C
45192      INCLUDE 'DPCOPA.INC'
45193      INCLUDE 'DPCOZZ.INC'
45194C
45195      DIMENSION CLLIMI(*)
45196      DIMENSION CLWIDT(*)
45197C
45198      DIMENSION Y1(MAXOBV)
45199      DIMENSION X1(MAXOBV)
45200      DIMENSION X2(MAXOBV)
45201      DIMENSION YTEMP(MAXOBV)
45202      DIMENSION XTEMP1(MAXOBV)
45203      DIMENSION XTEMP2(MAXOBV)
45204      EQUIVALENCE (GARBAG(IGARB1),X1(1))
45205      EQUIVALENCE (GARBAG(IGARB2),X2(1))
45206      EQUIVALENCE (GARBAG(IGARB3),Y1(1))
45207      EQUIVALENCE (GARBAG(IGARB4),YTEMP(1))
45208      EQUIVALENCE (GARBAG(IGARB5),XTEMP1(1))
45209      EQUIVALENCE (GARBAG(IGARB6),XTEMP2(1))
45210C
45211C-----COMMON----------------------------------------------------------
45212C
45213      INCLUDE 'DPCOHK.INC'
45214      INCLUDE 'DPCODA.INC'
45215      INCLUDE 'DPCOST.INC'
45216      INCLUDE 'DPCOP2.INC'
45217C
45218C-----START POINT-----------------------------------------------------
45219C
45220      IFOUND='NO'
45221      IERROR='NO'
45222C
45223      ISUBN1='DPPI'
45224      ISUBN2='E   '
45225C
45226      MAXCP1=MAXCOL+1
45227      MAXCP2=MAXCOL+2
45228      MAXCP3=MAXCOL+3
45229      MAXCP4=MAXCOL+4
45230      MAXCP5=MAXCOL+5
45231      MAXCP6=MAXCOL+6
45232C
45233C               ***************************
45234C               **  TREAT THE PIE CHART  **
45235C               ***************************
45236C
45237      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PPIE')THEN
45238        WRITE(ICOUT,999)
45239  999   FORMAT(1X)
45240        CALL DPWRST('XXX','BUG ')
45241        WRITE(ICOUT,51)
45242   51   FORMAT('***** AT THE BEGINNING OF DPPIE--')
45243        CALL DPWRST('XXX','BUG ')
45244        WRITE(ICOUT,52)ICASPL,IAND1,IAND2
45245   52   FORMAT('ICASPL,IAND1,IAND2 = ',2(A4,2X),A4)
45246        CALL DPWRST('XXX','BUG ')
45247        WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ,ISUBRO
45248   53   FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',3(A4,2X),A4)
45249        CALL DPWRST('XXX','BUG ')
45250      ENDIF
45251C
45252C               ***************************
45253C               **  STEP 1--             **
45254C               **  EXTRACT THE COMMAND  **
45255C               ***************************
45256C
45257      ISTEPN='1'
45258      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PPIE')
45259     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
45260C
45261      IF(NUMARG.GE.1.AND.
45262     1   ICOM.EQ.'PIE'.AND.IHARG(1).EQ.'CHAR')THEN
45263        ILASTC=1
45264      ELSE
45265        IFOUND='NO'
45266        GOTO9000
45267      ENDIF
45268C
45269      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
45270      IFOUND='YES'
45271      ICASPL='PIEC'
45272C
45273C               ****************************************
45274C               **  STEP 2--                          **
45275C               **  EXTRACT THE VARIABLE LIST         **
45276C               ****************************************
45277C
45278      ISTEPN='2'
45279      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PPIE')
45280     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
45281C
45282      INAME='PIE CHART'
45283      MINNA=1
45284      MAXNA=100
45285      MINN2=2
45286      IFLAGE=1
45287      IFLAGM=0
45288      IFLAGP=0
45289      JMIN=1
45290      JMAX=NUMARG
45291      MINNVA=1
45292      MAXNVA=3
45293      IF(IPIEBI.EQ.'UNBI')MAXNVA=3
45294C
45295      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
45296     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
45297     1            JMIN,JMAX,
45298     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
45299     1            IVARN1,IVARN2,IVARTY,PVAR,
45300     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
45301     1            MINNVA,MAXNVA,
45302     1            IFLAGM,IFLAGP,
45303     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
45304      IF(IERROR.EQ.'YES')GOTO9000
45305C
45306      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PPIE')THEN
45307        WRITE(ICOUT,999)
45308        CALL DPWRST('XXX','BUG ')
45309        WRITE(ICOUT,281)
45310  281   FORMAT('***** AFTER CALL DPPARS--')
45311        CALL DPWRST('XXX','BUG ')
45312        WRITE(ICOUT,282)NQ,NUMVAR
45313  282   FORMAT('NQ,NUMVAR = ',2I8)
45314        CALL DPWRST('XXX','BUG ')
45315        IF(NUMVAR.GT.0)THEN
45316          DO285I=1,NUMVAR
45317            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
45318     1                      ICOLR(I)
45319  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
45320     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
45321            CALL DPWRST('XXX','BUG ')
45322  285     CONTINUE
45323        ENDIF
45324      ENDIF
45325C
45326      ICOL=1
45327      CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
45328     1            INAME,IVARN1,IVARN2,IVARTY,
45329     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
45330     1            MAXCOL,MAXCP1,MAXCP2,MAXCP3,
45331     1            MAXCP4,MAXCP5,MAXCP6,
45332     1            V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
45333     1            Y1,X1,X2,NLOCAL,NLOCAL,NLOCAL,ICASE,
45334     1            IBUGG3,ISUBRO,IFOUND,IERROR)
45335      IF(IERROR.EQ.'YES')GOTO9000
45336C
45337      IDATSW='RAW'
45338      IF(NUMVAR.EQ.2)IDATSW='FREQ'
45339      IF(NUMVAR.EQ.3)IDATSW='FRE2'
45340C
45341C
45342C         **************************************************************
45343C         **  STEP 7--                                                **
45344C         **  DETERMINE IF THE ANALYST                                **
45345C         **  HAS SPECIFIED    1)  THE CLASS WIDTH,                   **
45346C         **                   2)  THE MIN POINT OF THE FIRST CELL,   **
45347C         **                   3)  THE MAX POINT OF THE LAST  CELL,   **
45348C         **  FOR THE DISTRIBUTIONAL ANALYSIS.                        **
45349C         **  IF NON-DEFAULT, USE THE SPECIFIED VALUES.               **
45350C         **  IF DEFAULT, USE THE DEFAULT VALUES--                    **
45351C         **     1)  CLASS WIDTH = .3 OF A SAMPLE STANDARD DEVIATION; **
45352C         **     2)  START = SAMPLE MEAN - 6*(SAMPLE SD);             **
45353C         **     3)  STOP  = SAMPLE MEAN + 6*(SAMPLE SD);             **
45354C         **  NOTE THAT THE DEFAULT SETTINGS ARE IN FACT              **
45355C         **************************************************************
45356C
45357      ISTEPN='7'
45358      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PPIE')
45359     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
45360C
45361      CLWID=CLWIDT(1)
45362      XSTART=CLLIMI(1)
45363      XSTOP=CLLIMI(2)
45364C
45365C               *****************************************************
45366C               **  STEP 8--                                       **
45367C               **  FORM THE VERTICAL AND HORIZONTAL AXIS          **
45368C               **  VALUES Y(.) AND X(.) FOR THE PLOT.             **
45369C               **  RESET THE VECTOR D(.) TO ALL ONES.             **
45370C               **  DEFINE THE NUMBER OF PLOT POINTS    (NPLOTP).  **
45371C               **  DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV).  **
45372C               *****************************************************
45373C
45374      CALL DPPIE2(Y1,X1,X2,NLOCAL,
45375     1            YTEMP,XTEMP1,XTEMP2,
45376     1            IDATSW,IPIEBI,
45377     1            CLWID,XSTART,XSTOP,IHSTCW,IHSTOU,MAXNXT,
45378     1            Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR)
45379C
45380C               *****************
45381C               **  STEP 90--  **
45382C               **  EXIT       **
45383C               *****************
45384C
45385 9000 CONTINUE
45386      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'PPIE')THEN
45387        WRITE(ICOUT,999)
45388        CALL DPWRST('XXX','BUG ')
45389        WRITE(ICOUT,9011)
45390 9011   FORMAT('***** AT THE END       OF DPPIE--')
45391        CALL DPWRST('XXX','BUG ')
45392        WRITE(ICOUT,9012)IFOUND,IERROR,CLWID,XSTART,XSTOP
45393 9012   FORMAT('IFOUND,IERROR,CLWID,XSTART,XSTOP = ',2(A4,2X),3G15.7)
45394        CALL DPWRST('XXX','BUG ')
45395        WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
45396 9013   FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',3I8,3(2X,A4))
45397        CALL DPWRST('XXX','BUG ')
45398        IF(NPLOTP.GT.0)THEN
45399          DO9015I=1,NPLOTP
45400           WRITE(ICOUT,9016)I,Y(I),X(I),D(I)
45401 9016      FORMAT('I,Y(I),X(I),D(I) = ',I8,3G15.7)
45402           CALL DPWRST('XXX','BUG ')
45403 9015     CONTINUE
45404        ENDIF
45405      ENDIF
45406C
45407      RETURN
45408      END
45409      SUBROUTINE DPPIE2(Y,X,XHIGH,N,
45410     1                  YTEMP,XTEMP1,XTEMP2,
45411     1                  IDATSW,IPIEBI,
45412     1                  CLWID,XSTART,XSTOP,IHSTCW,IHSTOU,MAXNXT,
45413     1                  Y2,X2,D2,N2,NPLOTV,IBUGG3,ISUBRO,IERROR)
45414C
45415C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
45416C              THAT WILL DEFINE A PIE CHART
45417C     WRITTEN BY--JAMES J. FILLIBEN
45418C                 STATISTICAL ENGINEERING DIVISION
45419C                 INFORMATION TECHNOLOGY LABORATORY
45420C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
45421C                 GAITHERSBURG, MD 20899-8980
45422C                 PHONE--301-975-2899
45423C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
45424C           OF THE NATIONAL BUREAU OF STANDARDS.
45425C     LANGUAGE--ANSI FORTRAN (1977)
45426C     VERSION NUMBER--82/7
45427C     ORIGINAL VERSION--APRIL     1978.
45428C     UPDATED         --MAY       1978.
45429C     UPDATED         --JUNE      1978.
45430C     UPDATED         --OCTOBER   1978.
45431C     UPDATED         --MARCH     1979.
45432C     UPDATED         --APRIL     1979.
45433C     UPDATED         --JANUARY   1981.
45434C     UPDATED         --AUGUST    1981.
45435C     UPDATED         --DECEMBER  1981.
45436C     UPDATED         --MAY       1982.
45437C     UPDATED         --NOVEMBER  1993. EACH SLICE HAS SAME TAG TO
45438C                                       ALLOW ATTRIBUTE SETTING (ALAN)
45439C
45440C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
45441C
45442      CHARACTER*4 IDATSW
45443      CHARACTER*4 IPIEBI
45444      CHARACTER*4 IHSTCW
45445      CHARACTER*4 IHSTOU
45446      CHARACTER*4 IBUGG3
45447      CHARACTER*4 ISUBRO
45448      CHARACTER*4 IERROR
45449C
45450      CHARACTER*4 ISUBN1
45451      CHARACTER*4 ISUBN2
45452C
45453C---------------------------------------------------------------------
45454C
45455      DIMENSION Y(*)
45456      DIMENSION X(*)
45457      DIMENSION XHIGH(*)
45458      DIMENSION Y2(*)
45459      DIMENSION X2(*)
45460      DIMENSION D2(*)
45461CCCCC NOVEMBER 1993.  ADD FOLLOWING LINE
45462      DIMENSION YTEMP(*)
45463      DIMENSION XTEMP1(*)
45464      DIMENSION XTEMP2(*)
45465C
45466      DOUBLE PRECISION DXSTAR
45467      DOUBLE PRECISION DXSTOP
45468      DOUBLE PRECISION DCLWID
45469C
45470C---------------------------------------------------------------------
45471C
45472      INCLUDE 'DPCOP2.INC'
45473C
45474C-----DATA STATEMENTS-------------------------------------------------
45475C
45476      DATA PI/3.1415926535878/
45477C
45478C-----START POINT-----------------------------------------------------
45479C
45480      ISUBN1='DPPI'
45481      ISUBN2='E2  '
45482      IERROR='NO'
45483C
45484      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PIE2')THEN
45485        WRITE(ICOUT,999)
45486        CALL DPWRST('XXX','BUG ')
45487        WRITE(ICOUT,70)
45488   70   FORMAT('***** AT THE BEGINNING OF DPPIE2--')
45489        CALL DPWRST('XXX','BUG ')
45490        WRITE(ICOUT,72)N,CLWID,XSTART,XSTOP,IDATSW
45491   72   FORMAT('N,CLWID,XSTART,XSTOP,IDATSW = ',I6,3G15.7,2X,A4)
45492        CALL DPWRST('XXX','BUG ')
45493        DO73I=1,N
45494          WRITE(ICOUT,74)I,Y(I),X(I),XHIGH(I)
45495   74     FORMAT('I,Y(I),X(I),XHIGH(I) = ',I8,3G15.7)
45496          CALL DPWRST('XXX','BUG ')
45497   73   CONTINUE
45498      ENDIF
45499C
45500      KP1=0
45501      NWITHI=0
45502      JWITHI=0
45503      DXSTAR=0.0D0
45504      DXSTOP=0.0D0
45505C
45506C               ********************************************
45507C               **  STEP 1--                              **
45508C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
45509C               ********************************************
45510C
45511      IF(N.LT.2)THEN
45512        WRITE(ICOUT,999)
45513  999   FORMAT(1X)
45514        CALL DPWRST('XXX','BUG ')
45515        WRITE(ICOUT,31)
45516   31   FORMAT('***** ERROR IN PIE CHART--')
45517        CALL DPWRST('XXX','BUG ')
45518        WRITE(ICOUT,32)
45519   32   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 2.')
45520        CALL DPWRST('XXX','BUG ')
45521        WRITE(ICOUT,34)N
45522   34   FORMAT('      THE NUMBER OF OBSERVATIONS = ',I6)
45523        CALL DPWRST('XXX','BUG ')
45524        WRITE(ICOUT,999)
45525        CALL DPWRST('XXX','BUG ')
45526        IERROR='YES'
45527        GOTO9000
45528      ENDIF
45529C
45530      NMIN=2
45531      NJUNK=0
45532      MAXGRP=50000
45533      IF(IDATSW.EQ.'FREQ')THEN
45534        CALL CKDIS2(Y,X,XTEMP1,N,MAXGRP,NMIN,XTEMP2,NJUNK,NTOT2,
45535     1              ISUBRO,IBUGG3,IERROR)
45536        IF(IERROR.EQ.'YES')GOTO9000
45537      ELSEIF(IDATSW.EQ.'FRE2')THEN
45538        CALL CKDIS3(Y,X,XHIGH,XTEMP1,N,MAXGRP,NMIN,XTEMP2,NJUNK,NTOT2,
45539     1              ISUBRO,IBUGG3,IERROR)
45540        IF(IERROR.EQ.'YES')GOTO9000
45541      ENDIF
45542C
45543C               **********************************************
45544C               **  STEP 2--                                **
45545C               **  IF NECESSARY,                           **
45546C               **  DETERMINE CLASS WIDTH,                  **
45547C               **  START VALUE, STOP VALUE,                **
45548C               **  AND NUMBER OF CLASSES.                  **
45549C               **********************************************
45550C
45551C
45552      DXSTAR=0.0D0
45553      DXSTOP=0.0D0
45554      IF(IPIEBI.EQ.'UNBI')THEN
45555        XSTART=1.0
45556        XSTOP=REAL(N)
45557        CLWID=1.0
45558        SUM1=0.0
45559        DO91I=1,N
45560          SUM1=SUM1+Y(I)
45561   91   CONTINUE
45562        DO96I=1,N
45563          XTEMP1(I)=Y(I)/SUM1
45564   96   CONTINUE
45565        NUMCLA=N
45566        GOTO1100
45567      ELSEIF(IDATSW.EQ.'RAW')THEN
45568        CALL DPBINZ(Y,N,CLWID,XSTART,XSTOP,
45569     1              XTEMP1,MAXNXT,IHSTCW,IHSTOU,
45570     1              DCLWID,DXSTAR,DXSTOP,
45571     1              ISUBRO,IBUGG3,IERROR)
45572        CLWID=DCLWID
45573      ELSEIF(IDATSW.EQ.'FREQ')THEN
45574        CALL SORT(X,N,XTEMP1)
45575        NM1=N-1
45576        CLWID=XTEMP1(2)-XTEMP1(1)
45577        DO160I=1,NM1
45578          IP1=I+1
45579          DELI=XTEMP1(IP1)-XTEMP1(I)
45580          IF(DELI.LT.CLWID)CLWID=DELI
45581  160   CONTINUE
45582        DXSTAR=XTEMP1(1)-(CLWID/2.0)
45583        DXSTOP=XTEMP1(N)+(CLWID/2.0)
45584      ELSEIF(IDATSW.EQ.'FRE2')THEN
45585        DXSTAR=X(1)
45586        DXSTOP=XHIGH(N)
45587      ENDIF
45588C
45589      XSTART=DXSTAR
45590      XSTOP=DXSTOP
45591C
45592      IF(IDATSW.EQ.'FRE2')THEN
45593        NUMCLA=N
45594      ELSE
45595        TOTWID=XSTOP-XSTART
45596        ANUMCL=TOTWID/CLWID
45597        NUMCLA=INT(ANUMCL+1.0)
45598C
45599        J=NUMCLA-1
45600        AJ=J
45601        CLMAXJ=XSTART+AJ*CLWID
45602        ABSDEL=ABS(CLMAXJ-XSTOP)
45603        IF(ABSDEL.LE.0.0001)NUMCLA=NUMCLA-1
45604      ENDIF
45605C
45606C               *******************************************************
45607C               **  STEP 3--                                         **
45608C               **  DETERMINE THE FREQUENCY (COUNTS) FOR EACH CLASS  **
45609C               *******************************************************
45610C
45611      DO300J=1,NUMCLA
45612        XTEMP1(J)=0.0
45613  300 CONTINUE
45614C
45615      IF(IDATSW.EQ.'RAW')THEN
45616        DO420I=1,N
45617          DO430J=1,NUMCLA
45618            J2=J
45619            AJ=J
45620            CLMINJ=XSTART+(AJ-1.0)*CLWID
45621            CLMAXJ=XSTART+AJ*CLWID
45622            IF(CLMAXJ.GT.XSTOP)CLMAXJ=XSTOP
45623            IF(CLMINJ.LE.Y(I).AND.Y(I).LT.CLMAXJ)THEN
45624              XTEMP1(J2)=XTEMP1(J2)+1.0
45625              GOTO420
45626            ENDIF
45627  430     CONTINUE
45628  420   CONTINUE
45629C
45630C       FOR THIS RAW DATA CASE,
45631C       TREAT THE SPECIAL CASE OF EQUALITY
45632C       WITH THE UPPER LIMIT OF THE LAST (RIGHT-MOST) CLASS
45633C
45634        J=NUMCLA
45635        DO450I=1,N
45636          AJ=J
45637          CLMAXJ=XSTART+AJ*CLWID
45638          IF(CLMAXJ.GT.XSTOP)CLMAXJ=XSTOP
45639          IF(Y(I).EQ.CLMAXJ)XTEMP1(J)=XTEMP1(J)+1.0
45640  450   CONTINUE
45641      ELSEIF(IDATSW.EQ.'FREQ')THEN
45642        DO520I=1,N
45643          DO530J=1,NUMCLA
45644            J2=J
45645            AJ=J
45646            CLMINJ=XSTART+(AJ-1.0)*CLWID
45647            CLMAXJ=XSTART+AJ*CLWID
45648            IF(CLMAXJ.GT.XSTOP)CLMAXJ=XSTOP
45649            IF(CLMINJ.LE.X(I).AND.X(I).LT.CLMAXJ)THEN
45650              XTEMP1(J2)=XTEMP1(J2)+Y(I)
45651              GOTO520
45652            ENDIF
45653  530     CONTINUE
45654  520   CONTINUE
45655C
45656C       FOR THIS FREQUENCY DATA CASE,
45657C       TREAT THE SPECIAL CASE OF EQUALITY
45658C       WITH THE UPPER LIMIT OF THE LAST (RIGHT-MOST) CLASS
45659C       (ALTHOUGH THIS SHOULD NOT HAPPEN WITH THE IDATSW = 'FREQ' CASE.)
45660C
45661        J=NUMCLA
45662        DO550I=1,N
45663          AJ=J
45664          CLMAXJ=XSTART+AJ*CLWID
45665          IF(CLMAXJ.GT.XSTOP)CLMAXJ=XSTOP
45666          IF(X(I).EQ.CLMAXJ)XTEMP1(J)=XTEMP1(J)+Y(I)
45667  550   CONTINUE
45668      ELSEIF(IDATSW.EQ.'FRE2')THEN
45669        DO620I=1,N
45670          DO630J=1,NUMCLA
45671            J2=J
45672            XTEMP1(J2)=XTEMP1(J2)+Y(I)
45673  630     CONTINUE
45674  620   CONTINUE
45675      ENDIF
45676C
45677      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PER2')THEN
45678        WRITE(ICOUT,999)
45679        CALL DPWRST('XXX','BUG ')
45680        WRITE(ICOUT,591)
45681  591   FORMAT('***** IN THE MIDDLE    OF DPPIE2--')
45682        CALL DPWRST('XXX','BUG ')
45683        WRITE(ICOUT,592)CLWID,XSTART,XSTOP,TOTWID,ANUMCL,NUMCLA
45684  592   FORMAT('CLWID,XSTART,XSTOP,TOTWID,ANUMCL,NUMCLA= ',5E11.4,I8)
45685        CALL DPWRST('XXX','BUG ')
45686        DO593J=1,NUMCLA
45687          IF(IDATSW.NE.'FRE2')THEN
45688            AJ=J
45689            CLMINJ=XSTART+(AJ-1.0)*CLWID
45690            CLMAXJ=XSTART+AJ*CLWID
45691            IF(CLMAXJ.GT.XSTOP)CLMAXJ=XSTOP
45692            FJ=XTEMP1(J)
45693          ELSE
45694            CLMINJ=X(J)
45695            CLMAXJ=XHIGH(J)
45696            FJ=XTEMP1(J)
45697          ENDIF
45698          WRITE(ICOUT,594)J,CLMINJ,CLMAXJ,FJ
45699  594     FORMAT('J,CLMINJ,CLMAXJ,FJ = ',I8,3G15.7)
45700          CALL DPWRST('XXX','BUG ')
45701  593   CONTINUE
45702      ENDIF
45703C
45704C               **********************************
45705C               **  STEP 4--                    **
45706C               **  DETERMINE PLOT COORDINATES  **
45707C               **********************************
45708C
45709 1100 CONTINUE
45710      SUM=0.0
45711      DO1110J=1,NUMCLA
45712        SUM=SUM+XTEMP1(J)
45713 1110 CONTINUE
45714      AN2=SUM
45715C
45716CCCCC NOVEMBER, 1993.  FOLLOWING SECTION MODIFIED TO MAKE PIE SEGMENTS
45717CCCCC HAVE A COMMON "TAG".  THIS WILL ALLOW REGION ATTRIBUTES TO BE
45718CCCCC SET (E.G., FILL, COLOR, FILL PATTERN) INDIVIDUALLY FOR EACH PIE
45719CCCCC SLICE (PREVIOUSLY, SETTING REGION ATTRIBUTES CAUSED VERY
45720CCCCC STRANGE AND UNDESIRABLE RESULTS).
45721      SUM=0.0
45722      DO1115J=1,NUMCLA
45723        FJ=XTEMP1(J)
45724        SUM=SUM+FJ
45725        CUMFJ=SUM
45726        FRACT=CUMFJ/AN2
45727        YTEMP(J)=FRACT
45728 1115 CONTINUE
45729CCCCC JANUARY 1998.  ON SOME PLATFORMS, THE FOLLOWING:
45730CCCCC     LET Y = DATA 2 8 10
45731CCCCC     LET X = DATA 1 2 3
45732CCCCC     PIE CHART Y X
45733CCCCC CAUSES A PROBLEM.  IN THIS CASE, THE BOTTOM HALF OF THE
45734CCCCC PIE CHART IS A SINGLE SEMI-CIRCLE (I.E., 50% OF DATA),
45735CCCCC ALGORITHM BELOW RECOGNIZED RADOLD AS EQUAL TO RAD2.  BASE
45736CCCCC COMPARISON BELOW (WHICH IS USED TO SKIP EMPTY SLICES) ON
45737CCCCC VALUES OF FRACT INSTEAD.
45738CCCCC RADOLD=-999.0
45739C
45740      RADOLD=0.0
45741      FRACTO=-1.0
45742      K=0
45743      J2=0
45744      DO1120J=1,NUMCLA
45745C
45746        FRACT=YTEMP(J)
45747        RAD=FRACT*(2.0*PI)
45748        IF(RAD.LE.PI)THEN
45749          RAD2=PI-RAD
45750        ELSE
45751          RAD2=3.0*PI-RAD
45752        ENDIF
45753C
45754        IF(FRACT.EQ.FRACTO)GOTO1120
45755C
45756        K=K+1
45757        J2=J2+1
45758C
45759        X2(K)=0.0
45760        Y2(K)=0.0
45761        D2(K)=J2
45762C
45763        K=K+1
45764        X2(K)=COS(RAD2)
45765        Y2(K)=SIN(RAD2)
45766        D2(K)=J2
45767C
45768        RADTMP=RAD
45769 1125   CONTINUE
45770          RADTMP=RADTMP-0.015
45771          IF(RADTMP.LT.RADOLD)GOTO1129
45772          IF(RADTMP.LE.PI)RAD2=PI-RADTMP
45773          IF(RADTMP.GT.PI)RAD2=3.0*PI-RADTMP
45774          K=K+1
45775          X2(K)=COS(RAD2)
45776          Y2(K)=SIN(RAD2)
45777          D2(K)=J2
45778        GOTO1125
45779C
45780 1129   CONTINUE
45781        K=K+1
45782        IF(RADOLD.LE.PI)RAD2=PI-RADOLD
45783        IF(RADOLD.GT.PI)RAD2=3.0*PI-RADOLD
45784        X2(K)=COS(RAD2)
45785        Y2(K)=SIN(RAD2)
45786        D2(K)=J2
45787C
45788        K=K+1
45789        X2(K)=0.0
45790        Y2(K)=0.0
45791        D2(K)=J2
45792        RADOLD=RAD
45793C
45794        IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PIE2')THEN
45795          WRITE(ICOUT,1121)J,J2,KP1,RAD2,RAD,PI,FRACT,
45796     1                     CUMFJ,FJ,AN2,NUMCLA
45797 1121     FORMAT('J,J2,KP1,RAD2,RAD,PI,FRACT,CUMFJ,FJ,AN2,NUMCLA = ',
45798     1           3I3,7F9.3,I6)
45799          CALL DPWRST('XXX','BUG ')
45800        ENDIF
45801C
45802 1120 CONTINUE
45803C
45804      N2=K
45805      NPLOTV=3
45806      GOTO9000
45807C
45808C               ******************
45809C               **   STEP 90--  **
45810C               **   EXIT       **
45811C               ******************
45812C
45813 9000 CONTINUE
45814      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PIE2')THEN
45815        WRITE(ICOUT,999)
45816        CALL DPWRST('XXX','BUG ')
45817        WRITE(ICOUT,9011)
45818 9011   FORMAT('***** AT THE END       OF DPPIE2--')
45819        CALL DPWRST('XXX','BUG ')
45820        WRITE(ICOUT,9013)N2,JWITHI,NWITHI
45821 9013   FORMAT('N2,JWITHI,NWITHI = ',3I8)
45822        CALL DPWRST('XXX','BUG ')
45823        DO9015I=1,N2
45824          WRITE(ICOUT,9016)I,Y2(I),X2(I),D2(I)
45825 9016     FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,3G15.7)
45826          CALL DPWRST('XXX','BUG ')
45827 9015   CONTINUE
45828      ENDIF
45829C
45830      RETURN
45831      END
45832      SUBROUTINE DPPLIN (X1,Y1,X2,Y2,X3,Y3,
45833     1                   X4,Y4,S1,S2,DIST,
45834     1                   ISUBRO,IBUGA3)
45835C
45836C     PURPOSE--GIVEN A LINE SEGMENT (X1,Y1), (X2,Y2), FIND
45837C              THE LINE PERPINDICULAR TO THIS LINE SEGMENT THAT
45838C              CONTIANS THE POINT (X3,Y3).  RETURN THE SLOPE OF
45839C              BOTH LINES, AND SECOND POINT ON THE PERPINDICULAR
45840C              LINE (THIS IS AN ARBITRARY POINT), AND THE DISTANCE
45841C              BETWEEN THE POINT AND THE ORIGINAL LINE.
45842C     WRITTEN BY--ALAN HECKERT
45843C                 STATISTICAL ENGINEERING DIVISION
45844C                 INFORMATION TECHNOLOGY LABORATORY
45845C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
45846C                 GAITHERSBURG, MD 20899-8980
45847C                 PHONE--301-975-2899
45848C     REFERENCE--BOWYER AND WOODWARK (1983), "A PROGRAMMER'S
45849C                GEOMETRY", BUTTERWORTHS, PP. 12-13.
45850C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
45851C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
45852C     LANGUAGE--ANSI FORTRAN (1977)
45853C     VERSION NUMBER--2012.10
45854C     ORIGINAL VERSION--OCTOBER   2012.
45855C     UPDATED--APRIL     1992.  GIVE VALUES TO X1 AND Y1
45856C
45857C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------
45858C
45859      CHARACTER*4 IBUGA3
45860      CHARACTER*4 ISUBRO
45861C
45862C-----COMMON VARIABLES (GENERAL)--------------------------------------
45863C
45864      INCLUDE 'DPCOP2.INC'
45865C
45866C-----START POINT-----------------------------------------------------
45867C
45868      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PLIN')THEN
45869        WRITE(ICOUT,51)
45870   51   FORMAT('AT THE BEGININNING OF DPPLIN')
45871        CALL DPWRST('XXX','BUG ')
45872        WRITE(ICOUT,53)X1,Y1,X2,Y2,X3,Y3
45873   53   FORMAT('X1,Y1,X2,Y2,X3,Y3 = ',6G15.7)
45874        CALL DPWRST('XXX','BUG ')
45875      ENDIF
45876C
45877C     CASE 1: VERTICAL LINE
45878C
45879      IF(X1.EQ.X2)THEN
45880        S1=CPUMAX
45881        S2=0.0
45882        DIST=X3 - X1
45883        X4=X1
45884        Y4=Y3
45885C
45886C     CASE 2: HORIZONTAL LINE
45887C
45888      ELSEIF(Y1.EQ.Y2)THEN
45889        S1=0.0
45890        S2=CPUMAX
45891        DIST=Y3 - Y1
45892        X4=X3
45893        Y4=Y1
45894C
45895C     CASE 3: NEITHER HORIZONTAL OR VERTICAL LINE
45896C
45897      ELSE
45898        S1=(Y2-Y1)/(X2-X1)
45899        S2=-1.0/S1
45900        B=Y1-S1*X1
45901        ANUM=S1*X3 - Y3 + B
45902        DENOM=S1**2 + 1.0
45903        DIST=ABS(ANUM/DENOM)
45904        YINT=Y3 - S2*X3
45905        X4=X3 + 1.0
45906        Y4=S2*X4 + YINT
45907      ENDIF
45908C
45909      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PLIN')THEN
45910        WRITE(ICOUT,9051)
45911 9051   FORMAT('AT THE END OF DPPLIN')
45912        CALL DPWRST('XXX','BUG ')
45913        WRITE(ICOUT,9053)X4,Y4,DIST,S1,S2
45914 9053   FORMAT('X4,Y4,DIST,S1,S2 = ',5G15.7)
45915        CALL DPWRST('XXX','BUG ')
45916      ENDIF
45917C
45918      RETURN
45919      END
45920