1      SUBROUTINE MAINGR(ANOPL1,ANOPL2,NPLOTV,NPLOTP,NS,ICASPL,
2     1                  MAXNPP,ISEED,IBOOSS,
3     1                  IX1TSV,IX2TSV,IY1TSV,IY2TSV,
4     1                  IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV,
5     1                  BARHEF,BARWEF,
6     1                  IRHSTG,IHSTCW,IHSTEB,IHSTOU,IASHWT,
7     1                  IHSTMC,IHSTOP,
8     1                  ICAPSW,IFORSW,IGUIFL,IERRFA,
9     1                  IAND1,IAND2,ICONT,NUMHPP,NUMVPP,MAXNXT,
10     1                  ISUBRO,IFOUND,IERROR)
11C
12C     PURPOSE--THIS IS SUBROUTING MAINGR.
13C              (THE   GR    AT THE END OF    MAINGR   STANDS FOR   GRAPHICS)
14C              THIS SUBROUTINE SEARCHES FOR AND EXECUTES GRAPHICS COMMANDS.
15C              THE GRAPHICS COMMANDS SEARCHED FOR BY MAINGR ARE AS FOLLOWS--
16C
17C                     ANOP PLOT (= PROPORTION PLOT)
18C                     ... BOX PLOT
19C                     BOX-COX NORMALITY PLOT
20C                     BOX-COX HOMOSCEDASTICITY PLOT
21C                     BOX-COX SYMMETRY PLOT (NOT DONE)
22C                     BOX-COX LINEARITY PLOT
23C                     BOX-COX STANDARDIZED EFFECTS PLOT (NOT DONE)
24C                     COMPLEX DEMODULATION ... PLOT
25C                     CONTOUR PLOT
26C                     ... CONTROL CHART
27C                     ... CORRELATION PLOT
28C                     ... FFT PLOT             (NOT DONE)
29C                     ... FREQUENCY PLOT
30C                     ... HISTOGRAM
31C                     ... HOMOSCEDASTICITY PLOT
32C                     ... I PLOT
33C                     INTERACTION PLOT
34C                     LAG ... PLOT
35C                     ... NORMALITY PLOT
36C                     PERCENT POINT PLOT
37C                     ... PERIODOGRAM
38C                     PIE CHART
39C                     PLOT
40C                     ... PROBABILITY PLOT
41C                     ... PPCC (PROBABILITY PLOT CORRELATION
42C                              COEFFICIENT) PLOT
43C                     ... ROOTOGRAM
44C                     RUN SEQUENCE PLOT
45C                     RUNS ... PLOT
46C                     ... SPECTRAL PLOT
47C                     3-D PLOT
48C                     3-D ... FREQUENCY  PLOT   (NOT DONE)
49C                     3-D ... HISTOGRAM         (NOT DONE)
50C                     4-PLOT ... ANALYSIS (DONE IN MAIN)
51C                     BAR CHART
52C                     STEM AND LEAF DIAGRAM
53C                     ... STATISTIC PLOT
54C                     YOUDEN PLOT
55C                     ... BIHISTOGRAM
56C                     ERROR BAR PLOT    OCTOBER 1988
57C                     FRACTAL PLOT      DECEMBER 1988
58C                     POINCARE PLOT     DECEMBER 1988
59C                     (REPLACED BY PHASE PLANE DIAGRAM  JULY 1989)
60C                     JACKNIFE ... STATISTIC PLOT   JANUARY 1989
61C                     BOOTSTRAP ... STATISTIC PLOT  JANUARY 1989
62C                     DEX/DOE EXP DESIGN ... PLOT MAY       1989
63C                     TAIL AREA PLOT                        1989
64C                     NORMAL PLOT                 MAY       1990
65C                     PHD PLOT (KER-CHAU LIE)     OCTOBER   1991
66C                         (NOT IMPLEMENTED YET)
67C                     BLOCK  PLOT                 APRIL     1992.
68C                     <STAT> BLOCK                JUNE      1992.
69C                     SYMBOL PLOT                 AUGUST    1992.
70C                     VECTOR PLOT                 AUGUST    1992
71C                     ANDREWS PLOT                NOVEMBER  1992
72C                     PARTIAL AUTOCORR. PLOT      FEBRUARY  1993
73C                     Q ... CONTROL CHART         DECEMBER  1993
74C                     CME (CONT. MEAN EXCEEDANCE) PLOT DECEMBER 1993
75C                     CONDITIONAL ... PLOT        DECEMBER  1993
76C                     ... COMOVEMENT  PLOT        OCTOBER   1997
77C                     KAPLAN MEIER    PLOT        MAY       1998
78C                     DUANE           PLOT        MAY       1998
79C                     EMPIRICAL CDF   PLOT        MAY       1998
80C                     EXPONENTIAL HAZARD PLOT     MAY       1998
81C                     NORMAL      HAZARD PLOT     MAY       1998
82C                     LOGNORMAL   HAZARD PLOT     MAY       1998
83C                     WEIBULL     HAZARD PLOT     MAY       1998
84C                     HOTELLING CONTROL CHART     MAY       1998
85C                     SEASONAL SUBSERIES PLOT     FEBRUARY  1999
86C                     SPREAD-LOCATION PLOT        AUGUST    1999
87C                     TUKEY MEAN-DIFFERENCE PLOT  SEPTEMBER 1999
88C                     INTERACTION   PLOT          OCTOBER   1999
89C                     ... INTERACTION STAT PLOT   OCTOBER   1999
90C                     CROSS TABULATE <STAT> PLOT  DECEMBER  1999
91C                     DEX CONTOUR PLOT            JANUARY   2000
92C                     YATES CUBE  PLOT            JANUARY   2000
93C                     BAG PLOT                    JANUARY   2001
94C                         (NOT IMPLEMENTED YET)
95C                     KERNEL DENSITY PLOT         AUGUST    2001
96C                     CONSENSUS MEAN PLOT         AUGUST    2001
97C                     PARTIAL RESIDUAL PLOT       JUNE      2002
98C                     PARTIAL REGRESSION PLOT     JUNE      2002
99C                     PARTIAL LEVERAGE PLOT       JUNE      2002
100C                     CCPR PLOT                   JUNE      2002
101C                     INFLUENCE CURVE <STAT> PLOT JULY      2002
102C                     SHIFT PLOT                  FEBRUARY  2003
103C                     VIOLIN PLOT                 FEBRUARY  2003
104C                     PARALLEL COORDINATES PLOT   MARCH     2003
105C                     PEAKS OVER THRESHOLD PLOT   APRIL     2005
106C                     REPAIR PLOT                 OCTOBER   2006
107C                     MEAN REPAIR FUNCTION PLOT   OCTOBER   2006
108C                     TRILINEAR PLOT              DECEMBER  2006
109C                     ROC CURVE                   APRIL     2007
110C                     ROSE PLOT                   APRIL     2007
111C                     BIVARIATE NORMAL TOLERANCE
112C                         REGION PLOT             MAY       2007
113C                     BIVARIATE NORMAL CONFIDENCE
114C                         REGION PLOT             NOVEMBER  2013
115C                     BINARY <TYPE> PLOT          MAY       2007
116C                     ORD PLOT                    MAY       2007
117C                     POISSON PLOT                MAY       2007
118C                     BINOMIAL PLOT               MAY       2007
119C                     NEGATIVE BINOMIAL PLOT      MAY       2007
120C                     GEOMETRIC PLOT              MAY       2007
121C                     LOGARITHMIC SERIES PLOT     MAY       2007
122C                     ASSOCIATION PLOT            JUNE      2007
123C                     SIEVE PLOT                  JUNE      2007
124C                     PSUEDO ROC CURVE            JULY      2007
125C                     LEVEL PLOT                  MARCH     2008
126C                     (DISCRETE CONTOUR PLOT)
127C                     IMAGE PLOT                  MARCH     2008
128C                     SPATIAL DISTRIBUTION PLOT   APRIL     2008
129C                     (UNDER DEVELOPMENT)
130C                     FLUCUATION PLOT             MAY       2008
131C                     STRIP PLOT                  OCTOBER   2008
132C                     DETECTIION LIMIT PLOT       DECEMBER  2008
133C                     (UNDER DEVELOPMENT)
134C                     TABULATION PLOT             SEPTEMBER 2009
135C                     ISO 13528 PLOT              FEBRUARY  2012
136C                     ISO 13528 ZSCORE PLOT       FEBRUARY  2012
137C                     ISO 13528 JSCORE PLOT       FEBRUARY  2012
138C                     ISO 13528 RLP PLOT          FEBRUARY  2012
139C                     FRECHET PLOT                OCTOBER   2013
140C                     DISTRIBUTIONAL FIT PLOT     AUGUST    2014
141C                     LORENZ CURVE                FEBRUARY  2015
142C                     H CONSISTENCY PLOT          MAY       2015
143C                     K CONSISTENCY PLOT          MAY       2015
144C                     COCHRAN VARIANCE PLOT       MAY       2015
145C                     MOVING STATISTIC PLOT       MAY       2015
146C                     CUMULATIVE STATISTIC PLOT   MAY       2015
147C                     TWO-WAY <ROW/COLUMN> PLOT   JUNE      2015
148C                     TWO FACTOR PLOT             JUNE      2015
149C                     EMPIRICAL QUANTILE PLOT     FEBRUARY  2017
150C                     TIQ PLOT                    MARCH     2017
151C                     QUANTILE BOX PLOT           MARCH     2017
152C                     BLAND ALTMAN PLOT           JULY      2017
153C                     NORM KERN DENSITY MIXT PLOT JULY      2017
154C                     DEX ORDER PLOT              FEBRUARY  2018
155C                     CLASSIFICATION ... PLOT     FEBRUARY  2019
156C
157C     WRITTEN BY--JAMES J. FILLIBEN
158C                 STATISTICAL ENGINEERING DIVISION
159C                 INFORMATION TECHNOLOGY LABORATORY
160C                 GAITHERSBURG, MD 20899-8980
161C                 PHONE--301-975-2855
162C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
163C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
164C     LANGUAGE--ANSI FORTRAN (1977)
165C     VERSION NUMBER--82.6
166C     ORIGINAL VERSION--NOVEMBER  1980.
167C     UPDATED         --JANUARY   1981.
168C     UPDATED         --MARCH     1981.
169C     UPDATED         --AUGUST    1981.
170C     UPDATED         --SEPTEMBER 1981.
171C     UPDATED         --OCTOBER   1981.
172C     UPDATED         --DECEMBER  1981.
173C     UPDATED         --MAY       1982.
174C        ETC.
175C     UPDATED         --AUGUST    1987. BOX-COX STANDARDIZED EFFECTS PLOT
176C     UPDATED         --JANUARY   1988. (... STATISTIC PLOTS)
177C     UPDATED         --JANUARY   1988. (... CHARTS)
178C     UPDATED         --FEBRUARY  1988. PROFILE PLOT
179C     UPDATED         --FEBRUARY  1988. STAR PLOT
180C     UPDATED         --AUGUST    1988. CONTOUR PLOT
181C     UPDATED         --AUGUST    1988. PARETO PLOT
182C     UPDATED         --SEPTEMBER 1988. EQUATE PROPROTION PLOT TO ANOP PLOT
183C     UPDATED         --SEPTEMBER 1988. YOUDEN PLOT (= PLOT WITH 3 ARGS)
184C     UPDATED         --SEPTEMBER 1988. BIHISTOGRAM
185C     UPDATED         --NOVEMBER  1988. ERROR BAR PLOT
186C     UPDATED         --DECEMBER  1988. ISEED ARGUMENT--FRACTAL PLOT
187C     UPDATED         --DECEMBER  1988. POINCARE PLOT
188C     UPDATED         --JANUARY   1989. JACKNIFE ... STAT PLOTS
189C     UPDATED         --JANUARY   1989. BOOTSTRAP ... STAT PLOTS
190C     UPDATED         --FEBRUARY  1989. CONTINUE CHARACTER CONFLICT (ALAN)
191C     UPDATED         --APRIL     1989. SCATTER PLOT (= SYNONYM FOR PLOT)
192C     UPDATED         --MAY       1989. DEX/DOE ... PLOT
193C     UPDATED         --MAY       1989. TAIL AREA PLOT
194C     UPDATED         --JULY      1989. POINCARE PLOT TO PHASE PLANE DIAG
195C     UPDATED         --MAY       1990. NORMAL PLOT
196C     UPDATED         --OCTOBER   1991. PHD PLOT (NOT DONE YET)
197C     UPDATED         --APRIL     1992. BLOCK PLOT
198C     UPDATED         --JUNE      1992. <STAT> BLOCK PLOT
199C     UPDATED         --AUGUST    1992. VECTOR PLOT, SYMBOL PLOT
200C     UPDATED         --NOVEMBER  1992. ANDREWS PLOT
201C     UPDATED         --FEBRUARY  1993. PARTIAL AUTOCORRELATION PLOT
202C     UPDATED         --JULY      1993. ARGUMENTS TO FRACTAL PLOT
203C     UPDATED         --AUGUST    1993. CONFLICT WITH MEDIAN POLISH
204C     UPDATED         --DECEMBER  1993. ADD ARG IN CALL DPPP()
205C     UPDATED         --DECEMBER  1993. Q ... CONTROL CHART
206C     UPDATED         --DECEMBER  1993. CME PLOT
207C     UPDATED         --DECEMBER  1993. COND. ... EXCEEDANCE PLOT
208C     UPDATED         --DECEMBER  1994. AUGMENT DPPARE() ARG. LIST
209C     UPDATED         --MARCH     1995. ADD MAXNXT TO DPBLOC
210C     UPDATED         --MARCH     1996. ADD IRHSTG TO DPHIST
211C     UPDATED         --OCTOBER   1997. COMOVEMENT PLOT
212C     UPDATED         --OCTOBER   1997. AUTO COMOVEMENT PLOT
213C     UPDATED         --MAY       1998. KAPLAN MEIER PLOT
214C     UPDATED         --MAY       1998. DUANE PLOT
215C     UPDATED         --MAY       1998. EMPIRICAL CDF PLOT
216C     UPDATED         --SEPTEMBER 1998. HOTELLING CONTROL CHART
217C     UPDATED         --FEBRUARY  1999. SEASONAL SUBSERIES PLOT
218C     UPDATED         --AUGUST    1999. SPREAD-LOCATION PLOT
219C     UPDATED         --SEPTEMBER 1999. TUKEY MEAN-DIFFERENCE PLOT
220C     UPDATED         --OCTOBER   1999. INTERACTION PLOT
221C     UPDATED         --OCTOBER   1999. INTERACTION STATISTIC PLOT
222C     UPDATED         --DECEMBER  1999. IMPLEMENT SUB-REGIONS
223C     UPDATED         --DECEMBER  1999. SAVE SOME INTERNAL PARAMETERS
224C                                       FOR ALL PLOTS
225C     UPDATED         --DECEMBER  1999. CROSS TABULATE PLOT
226C     UPDATED         --JANUARY   2000. DEX CONTOUR PLOT
227C     UPDATED         --JANUARY   2001. BAG PLOT (NOT WORKING)
228C     UPDATED         --AUGUST    2001. KERNEL DENSITY PLOT
229C     UPDATED         --AUGUST    2001. CONSENSUS MEAN PLOT
230C     UPDATED         --MARCH     2002. ROBUSTNESS PLOT SYNONUM
231C                                       FOR BLOCK PLOT
232C     UPDATED         --JULY      2002. INFLUENCE CURVE
233C     UPDATED         --OCTOBER   2002. CALL LIST TO CONSENUSE MEAN
234C                                       PLOT
235C     UPDATED         --FEBRUARY  2003. SHIFT PLOT
236C     UPDATED         --FEBRUARY  2003. VIOLIN PLOT
237C     UPDATED         --MARCH     2003. PARALLEL COORDINATES PLOT
238C     UPDATED         --SEPTEMBER 2003. BCA <BOOTSTRAP/JACKINFE>
239C     UPDATED         --MAY       2004. KOLMOGOROV SMIRNOV PLOT AS
240C                                       VARIANT OF PPCC PLOT
241C     UPDATED         --SEPTEMBER 2004. CALL LIST TO DPHIST
242C     UPDATED         --APRIL     2005. PEAKS OVER THRESHOLD PLOT
243C     UPDATED         --MARCH     2006. ADD IFORSW TO CONSENSUS MEAN
244C                                       PLOT
245C     UPDATED         --OCTOBER   2006. REPAIR PLOT
246C     UPDATED         --OCTOBER   2006. MEAN REPAIR FUNCTION PLOT
247C     UPDATED         --DECEMBER  2006. TRILINEAR PLOT
248C     UPDATED         --APRIL     2007. ROC CURVE
249C     UPDATED         --APRIL     2007. ROSE PLOT
250C     UPDATED         --MAY       2007. BIVARIATE NORMAL TOLERANCE
251C                                       REGION PLOT
252C     UPDATED         --MAY       2007. BINARY PLOT
253C     UPDATED         --MAY       2007. ORD PLOT
254C     UPDATED         --JUNE      2007. ASSOCIATION PLOT
255C     UPDATED         --JUNE      2007. SIEVE PLOT
256C     UPDATED         --AUGUST    2007. MOVE SOME ARRAY STORAGE TO
257C                                       COMMON
258C     UPDATED         --JANUARY   2008. ADJUST USE OF DPCOZ3.INC
259C                                       STORAGE
260C     UPDATED         --MARCH     2008. LEVEL (DISCRETE CONTOUR) PLOT
261C     UPDATED         --MARCH     2008. IMAGE PLOT
262C     UPDATED         --APRIL     2008. SPATIAL DISTRIBUTION PLOT
263C                                       (STILL UNDER DEVELOPMENT)
264C     UPDATED         --MAY       2008. FLUCUATION PLOT
265C     UPDATED         --OCTOBER   2008. STRIP PLOT
266C     UPDATED         --SEPTEMBER 2009. TABLE <STAT> PLOT
267C     UPDATED         --OCTOBER   2009. "BATCH MULTIPLE" OPTION
268C                                       FOR STRIP PLOT
269C     UPDATED         --JANUARY   2010. CALL LIST TO DPHIST
270C     UPDATED         --FEBRUARY  2012. ISO 13528 PLOT
271C     UPDATED         --FEBRUARY  2012. ISO 13528 ZSCORE PLOT
272C     UPDATED         --FEBRUARY  2012. ISO 13528 JSCORE PLOT
273C     UPDATED         --FEBRUARY  2012. ISO 13528 RLP PLOT
274C     UPDATED         --OCTOBER   2013. FRECHET PLOT
275C     UPDATED         --NOVEMBER  2013. BIVARIATE NORMAL CONFIDENCE
276C                                       REGION PLOT
277C     UPDATED         --AUGUST    2014. DISTRIBUTIONAL FIT PLOT
278C     UPDATED         --FEBRUARY  2015. LORENZ CURVE
279C     UPDATED         --MAY       2015. H CONSISTENCY PLOT
280C     UPDATED         --MAY       2015. K CONSISTENCY PLOT
281C     UPDATED         --MAY       2015. COCHRAN VARIANCE PLOT
282C     UPDATED         --MAY       2015. <stat> CUMULATIVE STATISTIC PLOT
283C     UPDATED         --MAY       2015. <stat> MOVING STATISTIC PLOT
284C     UPDATED         --JUNE      2015. TWO WAY <ROW/COLUMN> PLOT
285C     UPDATED         --JUNE      2015. TWO FACTOR PLOT
286C     UPDATED         --JUNE      2016. <stat> WINDOW STATISTIC PLOT
287C     UPDATED         --FEBRUARY  2017. EMPIRICAL QUANTILE PLOT
288C     UPDATED         --MARCH     2017. TIQ PLOT
289C     UPDATED         --JULY      2017. BLAND ALTMAN PLOT
290C     UPDATED         --JULY      2017. NORMAL KERNEL DENSITY MIXTURE PLOT
291C     UPDATED         --FEBRUARY  2018. DEX ORDER PLOT
292C     UPDATED         --FEBRUARY  2019. CLASSIFICATION ... PLOT
293C     UPDATED         --MARCH     2019. CALL LIST TO DPBLOC
294C
295C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
296C
297      CHARACTER*4 ICASPL
298      CHARACTER*4 ICASP2
299      CHARACTER*4 ICAPSW
300      CHARACTER*4 IFORSW
301CCCCC CHARACTER*4 ICASSW
302      CHARACTER*4 IX1TSV
303      CHARACTER*4 IX2TSV
304      CHARACTER*4 IY1TSV
305      CHARACTER*4 IY2TSV
306      CHARACTER*4 IX1ZSV
307      CHARACTER*4 IX2ZSV
308      CHARACTER*4 IY1ZSV
309      CHARACTER*4 IY2ZSV
310      CHARACTER*4 IAND1
311      CHARACTER*4 IAND2
312      CHARACTER*4 ICONT
313      CHARACTER*4 IDIREC
314      CHARACTER*4 IWRITE
315      CHARACTER*4 IH
316      CHARACTER*4 IH2
317      CHARACTER*4 ISUBN0
318      CHARACTER*4 ISUBRO
319      CHARACTER*4 IFOUND
320      CHARACTER*4 IERROR
321      CHARACTER*4 IRHSTG
322      CHARACTER*4 IBCABT
323      CHARACTER*4 IHSTCW
324      CHARACTER*4 IHSTEB
325      CHARACTER*4 IHSTOU
326      CHARACTER*4 IHSTOP
327      CHARACTER*4 IASHWT
328      CHARACTER*4 IGUIFL
329      CHARACTER*4 IERRFA
330      CHARACTER*4 ISUBN1
331      CHARACTER*4 ISUBN2
332C
333CCCCC DIMENSION TEMP(*)
334CCCCC DIMENSION TEMP2(*)
335CCCCC DIMENSION TEMP3(*)
336CCCCC DIMENSION XTEMP1(*)
337CCCCC DIMENSION XTEMP2(*)
338C
339C-----COMMON----------------------------------------------------------
340C
341      INCLUDE 'DPCOPA.INC'
342      INCLUDE 'DPCOMC.INC'
343      INCLUDE 'DPCODB.INC'
344      INCLUDE 'DPCOHK.INC'
345      INCLUDE 'DPCOPC.INC'
346      INCLUDE 'DPCOSU.INC'
347      INCLUDE 'DPCODA.INC'
348      INCLUDE 'DPCOCO.INC'
349      INCLUDE 'DPCOHO.INC'
350C
351CCCCC TO AVOID NAME CONFLICTS, ONLY BRING IN THE SPECIFIC
352CCCCC COMMON BLOCK (NOT ALL OF DPCOST.INC)
353C
354      CHARACTER*4  IERRST
355      COMMON/CSETG/IERRST
356C
357C
358      INCLUDE 'DPCOZ3.INC'
359C
360      DIMENSION TEMP(MAXOBV)
361      DIMENSION TEMP2(MAXOBV)
362      EQUIVALENCE (G3RBAG(KGARB5),TEMP(1))
363      EQUIVALENCE (G3RBAG(KGARB6),TEMP2(1))
364C
365C-----COMMON VARIABLES (GENERAL)--------------------------------------
366C
367      INCLUDE 'DPCOP2.INC'
368C
369C-----START POINT-----------------------------------------------------
370C
371CCCCC ICONT=IDEVCN(1)
372CCCCC ICOLOR=IDEVCL(1)
373CCCCC NUMHPP=IDEVPP(1,1)
374CCCCC NUMVPP=IDEVPP(1,2)
375      ISUBN1='MAIN'
376      ISUBN2='GR  '
377C
378      NACC=0
379      NREJ=0
380      NTOT=0
381C
382      IF(IBUGGR.EQ.'ON'.OR.ISUBRO.EQ.'INGR')THEN
383        WRITE(ICOUT,999)
384  999   FORMAT(1X)
385        CALL DPWRST('XXX','BUG ')
386        WRITE(ICOUT,51)
387   51   FORMAT('***** AT THE BEGINNING OF MAINGR--')
388        CALL DPWRST('XXX','BUG ')
389        WRITE(ICOUT,52)ICONT,ICOLOR,NUMHPP,NUMVPP
390   52   FORMAT('ICONT,ICOLOR,NUMHPP,NUMVPP = ',2(A4,2X),2I8)
391        CALL DPWRST('XXX','BUG ')
392        WRITE(ICOUT,53)IBUGGR,IBUGG2,IBUGG3
393   53   FORMAT('IBUGGR,IBUGG2,IBUGG3 = ',2(A4,2X),A4)
394        CALL DPWRST('XXX','BUG ')
395        WRITE(ICOUT,54)IBUGPL,IBUGP,IBUGP1,IBUGP2,IBUGP3
396   54   FORMAT('IBUGPL,IBUGP,IBUGP1,IBUGP2,IBUGP3 = ',4(A4,2X),A4)
397        CALL DPWRST('XXX','BUG ')
398        WRITE(ICOUT,55)IBUGCO,IBUGEV,IBUGQ,ISUBRO
399   55   FORMAT('IBUGCO,IBUGEV,IBUGQ,ISUBRO = ',3(A4,2X),A4)
400        CALL DPWRST('XXX','BUG ')
401        WRITE(ICOUT,57)IANGLU,MAXNPP,ISEED,IBOOSS
402   57   FORMAT('IANGLU,MAXNPP,ISEED,IBOOSS = ',A4,3I8)
403        CALL DPWRST('XXX','BUG ')
404        WRITE(ICOUT,59)ICASPL,IAND1,IAND2,IFENSW
405   59   FORMAT('ICASPL,IAND1,IAND2,IFENSW = ',3(A4,2X),A4)
406        CALL DPWRST('XXX','BUG ')
407        WRITE(ICOUT,60)IFOUND,IERROR,ICOM,ICOM2
408   60   FORMAT('IFOUND,IERROR,ICOM,ICOM2 = ',3(A4,2X),A4)
409        CALL DPWRST('XXX','BUG ')
410        WRITE(ICOUT,68)NUMARG,MAXNPP,ANOPL1,ANOPL2
411   68   FORMAT('NUMARG,MAXNPP,ANOPL1,ANOPL2 = ',2I8,2G15.7)
412        CALL DPWRST('XXX','BUG ')
413        DO70I=1,NUMARG
414          WRITE(ICOUT,71)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I)
415   71     FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) = ',
416     1           I8,3(2X,A4),2X,I8,G15.7)
417          CALL DPWRST('XXX','BUG ')
418   70   CONTINUE
419        WRITE(ICOUT,81)IX1TSC,IX2TSC,IY1TSC,IY2TSC
420   81   FORMAT('IX1TSC,IX2TSC,IY1TSC,IY2TSC = ',3(A4,2X),A4)
421        CALL DPWRST('XXX','BUG ')
422        WRITE(ICOUT,82)IX1TSV,IX2TSV,IY1TSV,IY2TSV
423   82   FORMAT('IX1TSV,IX2TSV,IY1TSV,IY2TSV = ',3(A4,2X),A4)
424        CALL DPWRST('XXX','BUG ')
425      ENDIF
426C
427      IFOUND='NO'
428      IERROR='NO'
429      IF(ICOM.EQ.'LET ')GOTO9000
430      IBCABT='OFF'
431C
432C               ***********************************************
433C               **  TREAT THE EMPIRICAL QUANTILE PLOT  CASE  **
434C               **            QUANTILE BOX PLOT        CASE  **
435C               ***********************************************
436C
437      IF((ICOM.EQ.'EMPI' .AND. IHARG(1).EQ.'QUAN') .OR.
438     1   (IHARG(1).EQ.'EMPI' .AND. IHARG(2).EQ.'QUAN'))THEN
439        CALL DPEQFU(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
440     1              ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
441        IF(IFOUND.EQ.'YES')GOTO9000
442      ELSEIF(ICOM.EQ.'QUAN' .AND. IHARG(1).EQ.'BOX ' .AND.
443     1       IHARG(2).EQ.'PLOT')THEN
444        CALL DPEQFU(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
445     1              ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
446        IF(IFOUND.EQ.'YES')GOTO9000
447      ENDIF
448C
449C               *******************************
450C               **  TREAT THE BOX PLOT CASE  **
451C               *******************************
452C
453      IF(
454     1  ICOM.EQ.'BOX' .OR. IHARG(1).EQ.'BOX' .OR.
455     1  IHARG(2).EQ.'BOX')THEN
456        CALL DPBOX(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
457     1             ICONT,IFENSW,IBUGG2,IBUGG3,IBUGQ,ISUBRO,
458     1             IFOUND,IERROR)
459        IF(IFOUND.EQ.'YES')GOTO9000
460      ENDIF
461C
462C               **********************************************
463C               **  TREAT THE DISTRIBUTIONAL FIT PLOT CASE  **
464C               **********************************************
465C
466      IF(ICOM.EQ.'DIST' .AND. IHARG(1).EQ.'FIT ' .AND.
467     1  IHARG(2).EQ.'PLOT')THEN
468        CALL DPDFPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,ISEED,
469     1              IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
470        IF(IFOUND.EQ.'YES')GOTO9000
471      ELSEIF(IHARG(1).EQ.'DIST' .AND. IHARG(2).EQ.'FIT ' .AND.
472     1  IHARG(3).EQ.'PLOT')THEN
473        CALL DPDFPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,ISEED,
474     1              IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
475        IF(IFOUND.EQ.'YES')GOTO9000
476      ENDIF
477C
478C               **********************************
479C               **  TREAT THE VIOLIN PLOT CASE  **
480C               **********************************
481C
482      IF(
483     1  ICOM.EQ.'VIOL' .OR. IHARG(1).EQ.'VIOL' .OR.
484     1  IHARG(2).EQ.'VIOL')THEN
485        CALL DPVIOL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
486     1              ICONT,IFENSW,IKDETY,IKDENP,PKDEWI,
487     1              ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
488        IF(IFOUND.EQ.'YES')GOTO9000
489      ENDIF
490C
491C               ****************************************************
492C               **  TREAT THE COMPLEX DEMODULATION ... PLOT CASE  **
493C               ****************************************************
494C
495CCCCC IF(ICOM.EQ.'COMP')GOTO200
496      IF(ICOM.EQ.'COMP'.AND.NUMARG.GE.1.AND.
497     1IHARG(1).EQ.'DEMO')THEN
498        CALL DPCD(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
499     1            IANGLU,DEMOFR,DEMODF,
500     1            IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
501        IF(IFOUND.EQ.'YES')GOTO9000
502      ENDIF
503C
504C               ****************************************
505C               **  TREAT THE ... CONTROL CHART CASE  **
506C               ****************************************
507C
508CCCCC THE FOLLOWING LINE WAS COMMENTED OUT                FEBRUARY 1989
509CCCCC AND REPLACED BY THE SUCCEEDING LINE                 FEBRUARY 1989
510CCCCC TO AVOID A CONFLICT WITH THE CONTINUE CHARACTER     FEBRUARY 1989
511CCCCC IF(ICOM.EQ.'CONT')GOTO300
512CCCCC ADD HOTELLING CONTROL CHART (= MULTIVARIATE CONTROL
513CCCCC CHART)                                             SEPTEMBER 1998
514CCCCC SUPPORT FOUR DISTINCT CASES FOR HOTELLING CONTROL  FEBRUARY 2003
515CCCCC CHART:
516CCCCC   1) PHASE I HOTELLING CONTROL CHART
517CCCCC   2) PHASE I HOTELLING INDIVIDUAL CONTROL CHART
518CCCCC   3) PHASE II HOTELLING CONTROL CHART
519CCCCC   4) PHASE II HOTELLING INDIVIDUAL CONTROL CHART
520CCCCC IF PHASE <I/II> OMITTED, ASSUME A PHASE I CHART.
521C
522      IF(ICOM.EQ.'CONT'.AND.ICOM2.NE.'INUE')GOTO300
523      IF(ICOM.EQ.'CONT'.AND.ICOM2.NE.'OUR ')GOTO300
524      IF(ICOM.EQ.'CONT'.AND.IHARG(1).NE.'LOOP')GOTO300
525C
526      IF(ICOM.EQ.'PHAS')THEN
527        IF(IHARG(1).EQ.'I'.OR.IHARG(1).EQ.'ONE'.OR.IHARG(1).EQ.'1')THEN
528          CALL DPHTCC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
529     1                ICONT,IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
530          IF(IFOUND.EQ.'YES')GOTO9000
531        ELSEIF(IHARG(1).EQ.'II'.OR.IHARG(1).EQ.'TWO'.OR.
532     1         IHARG(1).EQ.'2')THEN
533          CALL DPHTCC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
534     1                ICONT,IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
535          IF(IFOUND.EQ.'YES')GOTO9000
536        ENDIF
537      ELSEIF(ICOM.EQ.'HOTE'.OR.
538     1  (ICOM.EQ.'MULT'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'CONT'))THEN
539        CALL DPHTCC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
540     1  ICONT,IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
541        IF(IFOUND.EQ.'YES')GOTO9000
542      ENDIF
543C
544C     2015/09: CHECK FOR CONFLICT WITH CONTOUR OR DEX CONTOUR
545C
546      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CONT'.AND.
547     1   IHARG2(1).NE.'OUR ')GOTO300
548      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CHAR')GOTO300
549      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'CONT'.AND.
550     1   IHARG2(2).NE.'OUR ')GOTO300
551      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'CHAR')GOTO300
552      IF(NUMARG.GE.3.AND.IHARG(3).EQ.'CONT'.AND.
553     1   IHARG2(3).NE.'OUR ')GOTO300
554      IF(NUMARG.GE.3.AND.IHARG(3).EQ.'CHAR')GOTO300
555      GOTO399
556C
557  300 CONTINUE
558      CALL DPCC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
559     1          ICONT,IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
560      IF(IFOUND.EQ.'YES')GOTO9000
561C
562  399 CONTINUE
563C
564C               *******************************************
565C               **  TREAT THE ... CORRELATION PLOT CASE  **
566C               *******************************************
567C
568C 2012/1: FOLD IN COMOVEMENT PLOT IN WITH CORRELATION PLOT.
569C
570      IF(ICOM.EQ.'AUTO' .OR. ICOM.EQ.'CROS' .OR.
571     1   ICOM.EQ.'PART' .OR. ICOM.EQ.'COMO' .OR.
572     1   IHARG(1).EQ.'AUTO' .OR. IHARG(2).EQ.'CROS' .OR.
573     1   IHARG(1).EQ.'PART' .OR. IHARG(1).EQ.'COMO')THEN
574        CALL DPCORR(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
575     1              IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
576        IF(IFOUND.EQ.'YES')GOTO9000
577      ENDIF
578C
579C               *****************************************
580C               **  TREAT THE ... FREQUENCY PLOT CASE  **
581C               *****************************************
582C
583      IF(ICOM.EQ.'FREQ' .OR. IHARG(1).EQ.'FREQ' .OR.
584     1   IHARG(2).EQ.'FREQ' .OR. IHARG(3).EQ.'FREQ' .OR.
585     1   IHARG(4).EQ.'FREQ')THEN
586        CALL DPFREQ(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
587     1              CLLIMI,CLWIDT,
588     1              IRHSTG,IHSTCW,IHSTEB,IHSTOU,
589     1              IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
590        IF(IFOUND.EQ.'YES')GOTO9000
591      ENDIF
592C
593C               ************************************
594C               **  TREAT THE ... HISTOGRAM CASE  **
595C               ************************************
596C
597      IF(ICOM.EQ.'HIST' .OR. ICOM.EQ.'ASH ')GOTO600
598      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'HIST')GOTO600
599      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'HIST')GOTO600
600      GOTO699
601C
602  600 CONTINUE
603      CALL DPHIST(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
604     1CLLIMI,CLWIDT,
605CCCCC MARCH 1996.  ADD FOLLOWING LINE
606     1IRHSTG,IHSTCW,IASHWT,IHSTEB,IHSTOU,IHSTMC,IHSTOP,
607     1IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
608      IF(IFOUND.EQ.'YES')GOTO9000
609C
610  699 CONTINUE
611C
612C               *****************************
613C               **  TREAT THE I PLOT CASE  **
614C               *****************************
615C
616C     10/18/2013: THERE ARE A NUMBER OF NEW VARIANTS TO THIS
617C                 COMMAND.  SO CALL THIS ROUTINE AND LET DPI
618C                 DETERMINE IF A VALID I PLOT COMMAND HAS BEEN
619C                 ENTERED.
620C
621CCCCC IF(
622CCCCC1  ICOM.EQ.'I' .OR. IHARG(1).EQ.'I' .OR.
623CCCCC1  IHARG(2).EQ.'I' .OR. IHARG(3).EQ.'I')THEN
624        CALL DPI(NPLOTV,NPLOTP,NS,ICASPL,ISEED,IAND1,IAND2,
625     1           ICONT,IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
626        IF(IFOUND.EQ.'YES')GOTO9000
627CCCCC ENDIF
628C
629C               ***********************************
630C               **  TREAT THE LAG ... PLOT CASE  **
631C               ***********************************
632C
633      IF(ICOM.EQ.'LAG' .OR. IHARG(1).EQ.'LAG')THEN
634        CALL DPLAG(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
635     1             IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
636        IF(IFOUND.EQ.'YES')GOTO9000
637      ENDIF
638C
639C               *****************************************
640C               **  TREAT THE PERCENT POINT PLOT CASE  **
641C               *****************************************
642C
643      IMAX=NUMARG-1
644      IF(IMAX.LE.0)GOTO1099
645      IFLAG1=0
646      IFLAG2=0
647      IFLAG3=0
648      IF(ICOM.EQ.'PERC' .AND. ICOM2.NE.'ENTI')IFLAG1=1
649      DO1010I=1,NUMARG
650        IF(IHARG(I).EQ.'PERC' .AND. IHARG2(I).NE.'ENTI')IFLAG1=1
651        IF(IHARG(I).EQ.'POIN')IFLAG2=1
652        IF(IHARG(I).EQ.'PLOT')IFLAG3=1
653 1010 CONTINUE
654      IF(IFLAG1*IFLAG2*IFLAG3.EQ.1)THEN
655        CALL DPPERC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
656     1              CLLIMI,CLWIDT,
657     1              IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
658        IF(IFOUND.EQ.'YES')GOTO9000
659      ENDIF
660C
661 1099 CONTINUE
662C
663C               **************************************
664C               **  TREAT THE ... PERIODOGRAM CASE  **
665C               **************************************
666C
667CCCCC 2012/1: HANDLE WITH SPECTRAL PLOT
668C
669CCCCC IF(NUMARG.GE.4.AND.IHARG(4).EQ.'ASD')GOTO9399
670CCCCC IF(ICOM.EQ.'PERI')GOTO1100
671CCCCC IF(ICOM2.EQ.'PERI')GOTO1100
672CCCCC IF(ICOM2.EQ.'SPER')GOTO1100
673CCCCC IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PERI')GOTO1100
674CCCCC GOTO1199
675C
676C1100 CONTINUE
677CCCCC CALL DPPERI(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
678CCCCC1IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
679CCCCC IF(IFOUND.EQ.'YES')GOTO9000
680C
681C1199 CONTINUE
682C
683C               ********************************
684C               **  TREAT THE PIE CHART CASE  **
685C               ********************************
686C
687      IF(ICOM.EQ.'PIE')THEN
688        CALL DPPIE(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
689     1             CLLIMI,CLWIDT,
690     1             IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
691        IF(IFOUND.EQ.'YES')GOTO9000
692      ENDIF
693C
694C               ************************************
695C               **  TREAT THE PLOT CASE.          **
696C               **  TREAT THE YOUDEN PLOT         **
697C               **  AS A SPECIAL CASE OF PLOT     **
698C               **  (PLOT WITH 3 ARGUMENTS).      **
699C               **  TREAT THE SCATTER PLOT        **
700C               **  AS A SYNONYM FOR PLOT         **
701C               ************************************
702C
703      IF((ICOM.EQ.'YOUD' .OR. ICOM.EQ.'SCAT') .AND.
704     1   IHARG(1).NE.'INDE')THEN
705        ISHIFT=1
706        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
707     1              IBUGA2,IERROR)
708      ELSEIF(ICOM.NE.'PLOT')THEN
709        GOTO1399
710      ENDIF
711C
712      IAND1=IAND2
713      CALL DPPLOT(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
714     1            IANGLU,MAXNPP,
715     1            IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ,ISUBRO,
716     1            IFOUND,IERROR)
717C
718      IF(IBUGGR.EQ.'ON'.OR.ISUBRO.EQ.'INGR')THEN
719        WRITE(ICOUT,333)IFOUND,IERROR,IAND1,IAND2
720  333   FORMAT('IFOUND,IERROR,IAND1,IAND2 = ',3(A4,2X),A4)
721        CALL DPWRST('XXX','BUG ')
722      ENDIF
723C
724      IF(IFOUND.EQ.'YES')GOTO9000
725CCCCC IF(IAND2.EQ.'YES')GOTO100
726CCCCC IF(IAND2.EQ.'NO')GOTO9000
727C
728 1399 CONTINUE
729C
730C               ****************************************************
731C               **  TREAT THE ... MOVING     STATISTIC PLOT CASE **
732C               **  TREAT THE ... CUMULATIVE STATISTIC PLOT CASE **
733C               **  TREAT THE ... WINDOW     STATISTIC PLOT CASE **
734C               ***************************************************
735C
736      IF(ICOM.EQ.'FLUC')GOTO6399
737      DO6302I=1,NUMARG
738        IF(IHARG(I).EQ.'INTE'.AND.IHARG2(I).EQ.'RACT')GOTO6399
739        IF(IHARG(I).EQ.'INFL'.AND.IHARG2(I).EQ.'UENC')GOTO6399
740        IF(IHARG(I).EQ.'BLOC')GOTO6399
741 6302 CONTINUE
742      DO6303I=1,NUMARG-1
743        IF(IHARG(I).EQ.'PROB' .AND. IHARG(I+1).EQ.'PLOT')GOTO6399
744        IF(IHARG(I).EQ.'PPCC' .AND. IHARG(I+1).EQ.'PLOT')GOTO6399
745 6303 CONTINUE
746C
747      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')GOTO6300
748      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'PLOT')GOTO6300
749      IF(NUMARG.GE.3.AND.IHARG(3).EQ.'PLOT')GOTO6300
750      IF(NUMARG.GE.4.AND.IHARG(4).EQ.'PLOT')GOTO6300
751      IF(NUMARG.GE.5.AND.IHARG(5).EQ.'PLOT')GOTO6300
752      IF(NUMARG.GE.6.AND.IHARG(6).EQ.'PLOT')GOTO6300
753      GOTO6399
754C
755 6300 CONTINUE
756      CALL DPMOSP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
757     1            MAXNXT,ISEED,FILWID,
758     1            ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
759      IF(IFOUND.EQ.'YES')GOTO9000
760C
761 6399 CONTINUE
762C
763C               ***********************************************
764C               **  TREAT THE <DIST> TIQP        PLOT  CASE  **
765C               ***********************************************
766C
767      IF(ICOM.EQ.'TIQ ' .OR. IHARG(1).EQ.'TIQ ' .OR.
768     1   IHARG(2).EQ.'TIQ ' .OR. IHARG(3).EQ.'TIQ ')THEN
769        CALL DPTIQP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
770     1              ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
771        IF(IFOUND.EQ.'YES')GOTO9000
772      ELSEIF(ICOM.EQ.'TRUN' .AND. IHARG(1).EQ.'INFO' .AND.
773     1   IHARG(2).EQ.'QUAN')THEN
774        CALL DPTIQP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
775     1              ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
776        IF(IFOUND.EQ.'YES')GOTO9000
777      ELSEIF(IHARG(1).EQ.'TRUN' .OR. IHARG(2).EQ.'TRUN' .OR.
778     1   IHARG(3).EQ.'TRUN' .OR. IHARG(4).EQ.'TRUN')THEN
779        CALL DPTIQP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
780     1              ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
781        IF(IFOUND.EQ.'YES')GOTO9000
782      ENDIF
783C
784C               ****************************************
785C               **  TREAT THE ... STATISTIC PLOT CASE **
786C               ****************************************
787C
788      IF(ICOM.EQ.'FLUC')GOTO6699
789      DO6602I=1,NUMARG
790        IF(IHARG(I).EQ.'INTE'.AND.IHARG2(I).EQ.'RACT')GOTO6699
791        IF(IHARG(I).EQ.'INFL'.AND.IHARG2(I).EQ.'UENC')GOTO6699
792        IF(IHARG(I).EQ.'BLOC')GOTO6699
793 6602 CONTINUE
794      DO6603I=1,NUMARG-1
795        IF(IHARG(I).EQ.'PROB' .AND. IHARG(I+1).EQ.'PLOT')GOTO6699
796        IF(IHARG(I).EQ.'PPCC' .AND. IHARG(I+1).EQ.'PLOT')GOTO6699
797 6603 CONTINUE
798C
799      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')GOTO6600
800      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'PLOT')GOTO6600
801      IF(NUMARG.GE.3.AND.IHARG(3).EQ.'PLOT')GOTO6600
802      IF(NUMARG.GE.4.AND.IHARG(4).EQ.'PLOT')GOTO6600
803      IF(NUMARG.GE.5.AND.IHARG(5).EQ.'PLOT')GOTO6600
804      IF(NUMARG.GE.6.AND.IHARG(6).EQ.'PLOT')GOTO6600
805      GOTO6699
806C
807 6600 CONTINUE
808      CALL DPSP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
809CCCCC1TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT,
810     1MAXNXT,
811CCCCC JULY 2002. ADD ISEED FOR HODGES-LEHMAN PLOT
812     1ISEED,
813     1ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
814      IF(IFOUND.EQ.'YES')GOTO9000
815C
816 6699 CONTINUE
817C
818C               *******************************************
819C               **  TREAT THE ... PROBABILITY PLOT CASE  **
820C               *******************************************
821C
822      IMAX=NUMARG-1
823      IF(IMAX.GT.1)THEN
824        DO1410I=1,NUMARG
825          IF(IHARG(I).EQ.'PROB')THEN
826            CALL DPPP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
827     1                IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
828            IF(IFOUND.EQ.'YES')GOTO9000
829          ENDIF
830 1410   CONTINUE
831      ENDIF
832C
833C               ************************************
834C               **  TREAT THE ... PPCC PLOT CASE  **
835C               ************************************
836C
837C     SINCE A NUMBER OF GOODNESS-OF-FIT STATISTICS ARE NOW
838C     SUPPORTED, JUST CALL THIS COMMAND AND SEE IF DPPPCC
839C     RECOGNIZES ONE OF THE SUPPORTED STATISTICS.  NO NEED TO
840C     DUPLICATE HERE.
841C
842      CALL DPPPCC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
843     1ICASP2,
844     1IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
845      IF(IFOUND.EQ.'YES')GOTO9000
846C
847C               ****************************************
848C               **  TREAT THE RUN SEQUENCE PLOT CASE  **
849C               ****************************************
850C
851      IF((ICOM.EQ.'RUN'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'SEQU') .OR.
852     1  (IHARG(1).EQ.'RUN'.AND.IHARG(2).EQ.'SEQU') .OR.
853     1  (IHARG(2).EQ.'RUN'.AND.IHARG(3).EQ.'SEQU'))THEN
854        CALL DPRUNS(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
855     1              IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
856        IF(IFOUND.EQ.'YES')GOTO9000
857      ENDIF
858C
859C               ************************************
860C               **  TREAT THE RUNS ... PLOT CASE  **
861C               ************************************
862C
863      IF(ICOM.EQ.'RUNS'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')THEN
864        CALL DPRUPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
865     1              IANGLU,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
866        IF(IFOUND.EQ.'YES')GOTO9000
867      ENDIF
868C
869C               ****************************************
870C               **  TREAT THE ... SPECTRAL PLOT CASE  **
871C               ****************************************
872C
873      IF(ICOM.EQ.'CHAR' .AND. IHARG(1).EQ.'AUTO')GOTO1899
874      IF(ICOM.EQ.'PHAS' .AND. IHARG(1).EQ.'PLAN')GOTO1899
875      IF(ICOM.EQ.'PHAS' .AND. IHARG(1).EQ.'I   ')GOTO1899
876      IF(ICOM.EQ.'PHAS' .AND. IHARG(1).EQ.'1   ')GOTO1899
877      IF(ICOM.EQ.'PHAS' .AND. IHARG(1).EQ.'ONE ')GOTO1899
878      IF(ICOM.EQ.'PHAS' .AND. IHARG(1).EQ.'II  ')GOTO1899
879      IF(ICOM.EQ.'PHAS' .AND. IHARG(1).EQ.'2   ')GOTO1899
880      IF(ICOM.EQ.'PHAS' .AND. IHARG(1).EQ.'TWO ')GOTO1899
881      IF(ICOM.EQ.'QUAD' .AND. IHARG(1).EQ.'SPLIN')GOTO1899
882      IF(ICOM.EQ.'QUAD' .AND. IHARG(1).EQ.'FIT')GOTO1899
883C
884      IF(ICOM.EQ.'AUTO' .OR. IHARG(1).EQ.'AUTO')GOTO1800
885      IF(ICOM.EQ.'SPEC' .OR. IHARG(1).EQ.'SPEC')GOTO1800
886      IF(ICOM.EQ.'PERI' .OR. IHARG(1).EQ.'PERI')GOTO1800
887      IF(ICOM.EQ.'COSP' .OR. IHARG(1).EQ.'COSP')GOTO1800
888      IF(ICOM.EQ.'QUAD' .AND. IHARG(1).EQ.'SPEC')GOTO1800
889      IF(IHARG(1).EQ.'QUAD' .AND. IHARG(2).EQ.'SPEC')GOTO1800
890      IF(ICOM.EQ.'CROS'.AND.IHARG(1).EQ.'SPEC')GOTO1800
891      IF(IHARG(1).EQ.'CROS'.AND.IHARG(2).EQ.'SPEC')GOTO1800
892      IF(ICOM.EQ.'COHE' .OR. IHARG(1).EQ.'COHE')GOTO1800
893      IF(ICOM.EQ.'AMPL' .OR. IHARG(1).EQ.'AMPL')GOTO1800
894      IF(ICOM.EQ.'PHAS' .OR. IHARG(1).EQ.'PHAS')GOTO1800
895      IF(ICOM.EQ.'GAIN' .OR. IHARG(1).EQ.'GAIN')GOTO1800
896      IF(ICOM.EQ.'ARGA' .OR. IHARG(1).EQ.'ARGA')GOTO1800
897      GOTO1899
898C
899 1800 CONTINUE
900      CALL DPSPEC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
901     1            IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
902      IF(IFOUND.EQ.'YES')GOTO9000
903C
904 1899 CONTINUE
905C
906C               *********************************************
907C               **  TREAT THE 3-D ... FREQUENCY PLOT CASE  **
908C               *********************************************
909C
910C  NOTE: THIS COMMAND IS NOT IMPLEMENTED YET.
911C
912CCCCC IF(ICOM.EQ.'3D' .AND. IHARG(1).EQ.'FREQ')THEN
913C
914CCCCC   CALL DP3DFR(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
915CCCCC1              IANGLU,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
916CCCCC ENDIF
917CCCCC IF(IFOUND.EQ.'YES')GOTO9000
918C
919C2099 CONTINUE
920C
921C               ****************************************
922C               **  TREAT THE 3-D ... HISTOGRAM CASE  **
923C               ****************************************
924C
925C  NOTE: THIS COMMAND IS NOT IMPLEMENTED YET.
926C
927CCCCC IF(ICOM.EQ.'3D' .AND. IHARG(1).EQ.'HIST')THEN
928CCCCC   CALL DP3DHI(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
929CCCCC1              IANGLU,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
930CCCCC ENDIF
931CCCCC IF(IFOUND.EQ.'YES')GOTO9000
932C
933C2199 CONTINUE
934C
935C               *******************************
936C               **  TREAT THE 3-D PLOT CASE  **
937C               *******************************
938C
939      IF(ICOM.EQ.'3D' .OR. ICOM.EQ.'3DPL' .OR.
940     1  (ICOM.EQ.'3' .AND. IHARG(1).NE.'PARA'))THEN
941        CALL DP3DPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
942     1              IANGLU,IFORSW,MAXNPP,
943     1              IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ,ISUBRO,
944     1              IFOUND,IERROR)
945C
946        IF(IBUGGR.EQ.'ON'.OR.ISUBRO.EQ.'INGR')THEN
947          WRITE(ICOUT,1933)IFOUND,IERROR,IAND1,IAND2
948 1933     FORMAT('IFOUND,IERROR,IAND1,IAND2 = ',3(A4,2X),A4)
949          CALL DPWRST('XXX','BUG ')
950        ENDIF
951      ENDIF
952      IF(IFOUND.EQ.'YES')GOTO9000
953CCCCC IF(IAND2.EQ.'YES')GOTO100
954CCCCC IF(IAND2.EQ.'NO')GOTO9000
955C
956C               ***********************************************
957C               **  TREAT THE BOX-COX NORMALITY        PLOT  **
958C               **  TREAT THE BOX-COX LINEARITY        PLOT  **
959C               **  TREAT THE BOX-COX HOMOSCEDASTICITY PLOT  **
960C               ***********************************************
961C
962      IF(
963     1  (ICOM.EQ.'BOX' .AND. IHARG(1).EQ.'COX') .OR.
964     1   (IHARG(1).EQ.'BOX' .AND. IHARG(2).EQ.'COX'))THEN
965         CALL DPBCNP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
966     1               IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
967         IF(IFOUND.EQ.'YES')GOTO9000
968      ENDIF
969C
970C               **************************************
971C               **  TREAT THE PROPORTION PLOT CASE  **
972C               **  = THE ANOP PLOT CASE            **
973C               **************************************
974C
975      IF(
976     1  (ICOM.EQ.'PROP'.AND.IHARG(1).EQ.'PLOT') .OR.
977     1  (ICOM.EQ.'ANOP'.AND.IHARG(1).EQ.'PLOT') .OR.
978     1  (ICOM.EQ.'ANAL'.AND.IHARG(1).EQ.'OF  ' .AND.
979     1   IHARG(2).EQ.'PROP'.AND.IHARG(3).EQ.'PLOT') .OR.
980     1  ICOM.EQ.'MULT')THEN
981C
982        CALL DPANPP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
983     1              IANGLU,MAXNPP,
984     1              ANOPL1,ANOPL2,
985     1              IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
986         IF(IFOUND.EQ.'YES')GOTO9000
987C
988      ENDIF
989C
990C               ************************************
991C               **  TREAT THE BAR PLOT CASE       **
992C               ************************************
993C
994      IF(ICOM.EQ.'BAR'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')
995     1GOTO2600
996      IF(ICOM.EQ.'BAR'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'CHAR')
997     1GOTO2600
998      GOTO2699
999C
1000 2600 CONTINUE
1001      CALL DPBARP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1002     1IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
1003      IF(IFOUND.EQ.'YES')GOTO9000
1004C
1005 2699 CONTINUE
1006C
1007C               *******************************
1008C               **  TREAT THE FFT PLOT CASE  **
1009C               *******************************
1010C
1011CCCCC IF(ICOM.EQ.'FFT'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')
1012CCCCC1GOTO2700
1013CCCCC GOTO2799
1014C
1015C2700 CONTINUE
1016CCCCC CALL DPFFTP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1017CCCCC1IANGLU,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
1018CCCCC IF(IFOUND.EQ.'YES')GOTO9000
1019C
1020C2799 CONTINUE
1021C
1022C               ************************************
1023C               **  TREAT THE ... ROOTOGRAM CASE  **
1024C               ************************************
1025C
1026      IF(ICOM.EQ.'ROOT')GOTO2800
1027      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'ROOT')GOTO2800
1028      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'ROOT')GOTO2800
1029      GOTO2899
1030C
1031 2800 CONTINUE
1032CCCCC CALL DPROGR(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1033CCCCC1CLLIMI,CLWIDT,
1034CCCCC1IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
1035      CALL DPHIST(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1036     1CLLIMI,CLWIDT,
1037     1IRHSTG,IHSTCW,IASHWT,IHSTEB,IHSTOU,IHSTMC,IHSTOP,
1038     1IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1039      IF(IFOUND.EQ.'YES')GOTO9000
1040C
1041 2899 CONTINUE
1042C
1043C               ********************************************
1044C               **  TREAT THE STEM AND LEAF DIAGRAM CASE  **
1045C               ********************************************
1046C
1047      IF(ICOM.EQ.'STEM')THEN
1048        CALL DPSTEM(IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
1049        IF(IFOUND.EQ.'YES')GOTO9000
1050      ENDIF
1051C
1052C               *****************************************************
1053C               **  TREAT THE ALLAN VARIANCE PLOT CASE             **
1054C               **  TREAT THE ALLAN STANDARD DEVIATION PLOT CASE   **
1055C               *****************************************************
1056C
1057      IF(ICOM.EQ.'ALLA' .OR. ICOM.EQ.'AV' .OR. ICOM.EQ.'ASD' .OR.
1058     1   ICOM.EQ.'AS  ' .OR.
1059     1   IHARG(1).EQ.'ALLA' .OR. IHARG(1).EQ.'AV  ' .OR.
1060     1   IHARG(1).EQ.'ASD ' .OR. IHARG(1).EQ.'AS  ')THEN
1061        CALL DPALLA(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1062     1              IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1063        IF(IFOUND.EQ.'YES')GOTO9000
1064      ENDIF
1065C
1066C               ****************************************************
1067C               **  TREAT THE COMPLEX REMODULATION PLOT CASE      **
1068C               ****************************************************
1069C
1070      IF(ICOM.EQ.'REMO')GOTO3300
1071      IF(ICOM.EQ.'COMP'.AND.NUMARG.GE.1.AND.
1072     1IHARG(1).EQ.'REMO')GOTO3300
1073      GOTO3399
1074C
1075 3300 CONTINUE
1076      CALL DPREMO(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1077     1IANGLU,DEMOFR,DEMODF,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
1078      IF(IFOUND.EQ.'YES')GOTO9000
1079C
1080 3399 CONTINUE
1081C
1082C               ************************************
1083C               **  TREAT THE SYMMETRY PLOT CASE  **
1084C               ************************************
1085C
1086      IF(ICOM.EQ.'SYMM' .OR. IHARG(1).EQ.'SYMM')THEN
1087        CALL DPSYMM(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1088     1              IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1089        IF(IFOUND.EQ.'YES')GOTO9000
1090      ENDIF
1091C
1092C               ********************************************
1093C               **  TREAT THE BOX-COX SYMMETRY PLOT CASE  **
1094C               ********************************************
1095C
1096CNNNN IF(NUMARG.GE.2.AND.ICOM.EQ.'BOX'.AND.
1097CNNNN1IHARG(1).EQ.'COX'.AND.IHARG(2).EQ.'SYMM')GOTO4200
1098CNNNN GOTO4299
1099C
1100C4200 CONTINUE
1101CNNNN CALL DPBCSP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1102CNNNN1IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
1103CNNNN IF(IFOUND.EQ.'YES')GOTO9000
1104C
1105C4299 CONTINUE
1106C
1107C               *********************************************
1108C               **  TREAT THE QUANTILE-QUANTILE PLOT CASE  **
1109C               *********************************************
1110C
1111      IF(ICOM.EQ.'QUAN' .OR.
1112     1  ((ICOM.EQ.'HIGH'.OR.ICOM.EQ.'SUBS') .AND.
1113     1    IHARG(1).EQ.'QUAN'))THEN
1114        CALL DPQUAN(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1115     1              IANGLU,MAXNPP,IBOOSS,ISEED,
1116     1              IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1117        IF(IFOUND.EQ.'YES')GOTO9000
1118      ENDIF
1119C
1120C               *********************************************
1121C               **  TREAT THE BAG               PLOT CASE  **
1122C               *********************************************
1123C
1124C     THIS IS NOT YET IMPLEMENTED.
1125C
1126      IF(ICOM.EQ.'BAG ')THEN
1127CCCCC   CALL DPBAGP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1128CCCCC1              ISEED,MAXNPP,
1129CCCCC1              IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1130CCCCC   IF(IFOUND.EQ.'YES')GOTO9000
1131      ENDIF
1132C
1133C               ********************************************
1134C               **  TREAT THE HOMOSCEDASTICITY PLOT CASE  **
1135C               ********************************************
1136C
1137      IF(ICOM.EQ.'HOMO')GOTO4400
1138      IF(ICOM.EQ.'SUBS'.AND.IHARG(1).EQ.'HOMO')GOTO4400
1139      IF(ICOM.EQ.'HIGH'.AND.IHARG(1).EQ.'HOMO')GOTO4400
1140      IF(ICOM.EQ.'SUMM'.AND.IHARG(1).EQ.'HOMO')GOTO4400
1141      IF(ICOM.EQ.'REPL'.AND.IHARG(1).EQ.'HOMO')GOTO4400
1142      IF(ICOM.EQ.'MULT'.AND.IHARG(1).EQ.'HOMO')GOTO4400
1143      IF(ICOM.EQ.'SUBS'.AND.IHARG(1).EQ.'SUMM'.AND.
1144     1   IHARG(2).EQ.'HOMO')GOTO4400
1145      IF(ICOM.EQ.'SUBS'.AND.IHARG(1).EQ.'HOMO'.AND.
1146     1   IHARG(2).EQ.'SUMM')GOTO4400
1147      IF(ICOM.EQ.'SUMM'.AND.IHARG(1).EQ.'SUBS'.AND.
1148     1   IHARG(2).EQ.'HOMO')GOTO4400
1149      IF(ICOM.EQ.'HIGH'.AND.IHARG(1).EQ.'SUMM'.AND.
1150     1   IHARG(2).EQ.'HOMO')GOTO4400
1151      IF(ICOM.EQ.'HIGH'.AND.IHARG(1).EQ.'HOMO'.AND.
1152     1   IHARG(2).EQ.'SUMM')GOTO4400
1153      IF(ICOM.EQ.'SUMM'.AND.IHARG(1).EQ.'HIGH'.AND.
1154     1   IHARG(2).EQ.'HOMO')GOTO4400
1155      IF(ICOM.EQ.'SUMM'.AND.IHARG(1).EQ.'HOMO'.AND.
1156     1   IHARG(2).EQ.'HIGH')GOTO4400
1157      IF(ICOM.EQ.'SUMM'.AND.IHARG(1).EQ.'HOMO'.AND.
1158     1   IHARG(2).EQ.'SUBS')GOTO4400
1159      GOTO4499
1160C
1161 4400 CONTINUE
1162      CALL DPHOMO(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1163     1ISEED,
1164     1IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1165      IF(IFOUND.EQ.'YES')GOTO9000
1166C
1167 4499 CONTINUE
1168C
1169C               ***************************************
1170C               **  TREAT THE BIHISTOGRAM PLOT CASE  **
1171C               ***************************************
1172C
1173      IF(ICOM.EQ.'BIHI' .OR. IHARG(1).EQ.'BIHI' .OR.
1174     1   IHARG(2).EQ.'BIHI' .OR. IHARG(3).EQ.'BIHI' .OR.
1175     1   ICOM.EQ.'BIRO' .OR. IHARG(1).EQ.'BIRO' .OR.
1176     1   IHARG(2).EQ.'BIRO' .OR. IHARG(3).EQ.'BIRO' .OR.
1177     1   (ICOM.EQ.'BIAS' .AND. ICOM2.EQ.'H   ') .OR.
1178     1   IHARG(1).EQ.'BIAS' .OR. IHARG(2).EQ.'BIAS')THEN
1179        CALL DPBIHI(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1180     1              CLLIMI,CLWIDT,
1181     1              IRHSTG,IHSTCW,IASHWT,IHSTEB,IHSTOU,
1182     1              IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1183        IF(IFOUND.EQ.'YES')GOTO9000
1184      ENDIF
1185C
1186C               ************************************
1187C               **  TREAT THE YOUDEN PLOT CASE    **
1188C               ************************************
1189C
1190CNNNN IF(ICOM.EQ.'YOUDEN')GOTO4700
1191CNNNN GOTO4799
1192C
1193C4700 CONTINUE
1194CNNNN CALL DPYOUD(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1195CNNNN1IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
1196CNNNN IF(IFOUND.EQ.'YES')GOTO9000
1197C
1198C4799 CONTINUE
1199C
1200C               ************************************
1201C               **  TREAT THE GANOVA PLOT CASE    **
1202C               ************************************
1203C
1204CNNNN IF(ICOM.EQ.'GANO'.AND.ICOM2.EQ.'VA  ')GOTO4800
1205CNNNN GOTO4899
1206C
1207C4800 CONTINUE
1208CNNNN CALL DPGANO(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1209CNNNN1IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
1210CNNNN IF(IFOUND.EQ.'YES')GOTO9000
1211C
1212C4899 CONTINUE
1213C
1214C               *************************************
1215C               **  TREAT THE DRAFTSMAN PLOT CASE  **
1216C               *************************************
1217C
1218CNNNN IF(ICOM.EQ.'DRSF')GOTO6100
1219CNNNN GOTO6199
1220C
1221C6100 CONTINUE
1222CNNNN CALL DPDRAF(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1223CNNNN1IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
1224CNNNN IF(IFOUND.EQ.'YES')GOTO9000
1225C
1226C6199 CONTINUE
1227C
1228C               ***********************************
1229C               **  TREAT THE CONTOUR PLOT CASE  **
1230C               ***********************************
1231C
1232      IF(ICOM.EQ.'CONT'.AND.IHARG(1).EQ.'PLOT')THEN
1233        CALL DPCOPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1234     1              IANGLU,MAXNPP,
1235     1              IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1236C
1237        IF(IBUGGR.EQ.'ON'.OR.ISUBRO.EQ.'INGR')THEN
1238           WRITE(ICOUT,6233)IFOUND,IERROR,IAND1,IAND2
1239 6233      FORMAT('IFOUND,IERROR,IAND1,IAND2 = ',3(A4,2X),A4)
1240           CALL DPWRST('XXX','BUG ')
1241        ENDIF
1242        IF(IFOUND.EQ.'YES')GOTO9000
1243      ENDIF
1244C
1245C               *********************************************************
1246C               **  TREAT THE BOX-COX  STANDARDIZED EFFECTS PLOT CASE  **
1247C               *********************************************************
1248C
1249      IF(NUMARG.GE.3.AND.ICOM.EQ.'BOX'.AND.
1250     1IHARG(1).EQ.'COX'.AND.IHARG(2).EQ.'STAN'.AND.
1251     1IHARG(3).EQ.'EFFE')GOTO6400
1252      GOTO6499
1253C
1254 6400 CONTINUE
1255CCCCC CALL DPBCSE(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1256CCCCC1IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1257CCCCC IF(IFOUND.EQ.'YES')GOTO9000
1258C
1259 6499 CONTINUE
1260C
1261C               ************************************
1262C               **  TREAT THE WEIBULL  PLOT CASE  **
1263C               ************************************
1264C
1265C     OCTOBER 2013: ADD FRECHET PLOT
1266C
1267      IF((ICOM.EQ.'WEIB' .OR. ICOM.EQ.'FREC') .AND.
1268     1   IHARG(1).EQ.'PLOT')GOTO6510
1269      IF(ICOM.EQ.'HIGH' .AND.
1270     1   (IHARG(1).EQ.'WEIB' .OR. IHARG(1).EQ.'FREC') .AND.
1271     1   IHARG(2).EQ.'PLOT')GOTO6510
1272      IF(ICOM.EQ.'SUBS' .AND.
1273     1   (IHARG(1).EQ.'WEIB' .OR. IHARG(1).EQ.'FREC') .AND.
1274     1   IHARG(2).EQ.'PLOT')GOTO6510
1275      GOTO6599
1276C
1277 6510 CONTINUE
1278      CALL DPWEIB(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1279     1            IANGLU,MAXNPP,
1280     1            IX1TSC,IX2TSC,IY1TSC,IY2TSC,
1281     1            IX1TSV,IX2TSV,IY1TSV,IY2TSV,
1282     1            IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1283      IF(IFOUND.EQ.'YES')GOTO9000
1284C
1285 6599 CONTINUE
1286C
1287CCCCCC ADD FOLLOWING COMMAND DECEMBER 1999.
1288C               ****************************************************
1289C               **  TREAT THE CROSS TABULATE <STATISTIC> PLOT CASE**
1290C               ****************************************************
1291C
1292      IF(NUMARG.GE.2.AND.ICOM.EQ.'CROS'.AND.IHARG(1).EQ.'TABU')THEN
1293        DO16602I=2,NUMARG
1294          IF(IHARG(I).EQ.'PLOT')GOTO16600
129516602   CONTINUE
1296        GOTO16699
1297C
129816600   CONTINUE
1299        CALL DPCRPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1300CCCCC1    TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT,
1301     1    MAXNXT,
1302     1    ISEED,
1303     1    ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
1304        IF(IFOUND.EQ.'YES')GOTO9000
1305      ENDIF
1306C
130716699 CONTINUE
1308C
1309C               ***********************************
1310C               **  TREAT THE PROFILE PLOT CASE  **
1311C               ***********************************
1312C
1313      IF(ICOM.EQ.'PROF')GOTO6700
1314      GOTO6799
1315C
1316 6700 CONTINUE
1317      CALL DPPROF(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1318     1IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1319      IF(IFOUND.EQ.'YES')GOTO9000
1320C
1321 6799 CONTINUE
1322C
1323C               ***********************************
1324C               **  TREAT THE STAR    PLOT CASE  **
1325C               ***********************************
1326C
1327      IF(ICOM.EQ.'STAR')GOTO6800
1328      GOTO6899
1329C
1330 6800 CONTINUE
1331      CALL DPSTAR(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1332     1IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1333      IF(IFOUND.EQ.'YES')GOTO9000
1334C
1335 6899 CONTINUE
1336C
1337C               **********************************
1338C               **  TREAT THE PARETO PLOT CASE  **
1339C               **********************************
1340C
1341      IF(ICOM.EQ.'PARE'.AND.NUMARG.GE.1.AND.
1342     1IHARG(1).EQ.'PLOT')GOTO6900
1343      GOTO6999
1344C
1345 6900 CONTINUE
1346      IDIREC='DECR'
1347CCCCC THE FOLLOWING ARGUMENT LIST WAS AUGMENTED   DECEMBER 1994
1348      CALL DPPARE(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1349CCCCC1ICONT,IDIREC,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
1350     1ICONT,IDIREC,ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
1351      IF(IFOUND.EQ.'YES')GOTO9000
1352C
1353 6999 CONTINUE
1354C
1355C               *************************************
1356C               **  TREAT THE ERROR BAR PLOT CASE  **
1357C               *************************************
1358C
1359      IF(ICOM.EQ.'ERRO')GOTO7100
1360      GOTO7199
1361C
1362 7100 CONTINUE
1363      IF(IHARG(1).EQ.'PROB' .AND. IHARG(2).EQ.'PLOT')GOTO7199
1364      IF(IHARG(1).EQ.'PPCC' .AND. IHARG(2).EQ.'PLOT')GOTO7199
1365      IF(IHARG(1).EQ.'KOLM' .AND. IHARG(2).EQ.'SMIR')GOTO7199
1366      IF(IHARG(1).EQ.'CHI ' .AND. IHARG(2).EQ.'SQUA')GOTO7199
1367      IF(IHARG(1).EQ.'CHIS' .AND. IHARG(2).EQ.'GOOD')GOTO7199
1368      CALL DPERBA(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,ICONT,
1369     1IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1370      IF(IFOUND.EQ.'YES')GOTO9000
1371C
1372 7199 CONTINUE
1373C
1374C               *************************************
1375C               **  TREAT THE FRACTAL PLOT CASE    **
1376C               *************************************
1377C
1378      IF(ICOM.EQ.'FRAC' .AND.
1379     1  (IHARG(1).EQ.'ITER' .OR. IHARG(1).EQ.'TYPE'))THEN
1380        CALL DPFRAC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,ICONT,
1381     1              IANGLU,ISEED,
1382CCCCC               JULY 1993.  ADD FOLLOWING LINE
1383     1              IFRAIT,IFRATY,
1384     1              IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1385        IF(IFOUND.EQ.'YES')GOTO9000
1386      ENDIF
1387C
1388CCCCC THE FOLLOWING SECTION WAS CHANGED FROM POINCARE PLOT   JULY 1989
1389CCCCC TO PHASE PLANE DIAGRAM                                 JULY 1989
1390C               ******************************************
1391C               **  TREAT THE PHASE PLANE DIAGRAM CASE  **
1392C               ******************************************
1393C
1394      IF(NUMARG.GE.2.AND.ICOM.EQ.'PHAS'.AND. IHARG(1).EQ.'PLAN' .AND.
1395     1  (IHARG(2).EQ.'DIAG' .OR. IHARG(2).EQ.'PLOT'))THEN
1396        CALL DPPPD(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1397     1             IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1398        IF(IFOUND.EQ.'YES')GOTO9000
1399      ENDIF
1400C
1401C               **************************************************
1402C               **  TREAT THE JACKNIFE  ... STATISTIC PLOT CASE **
1403C               **  AND   THE BOOTSTRAP ... STATISTIC PLOT CASE **
1404C               **************************************************
1405C
1406CCCCC SEPTEMBER 2003: ADD BCA BOOTSTRAP/JACKNIFE
1407C
1408      IF(ICOM.EQ.'JACK')GOTO7400
1409      IF(ICOM.EQ.'BOOT')GOTO7400
1410      IF(ICOM.EQ.'BCA'.AND.
1411     1  (IHARG(1).EQ.'BOOT'.OR.IHARG(1).EQ.'JACK'))GOTO7400
1412      GOTO7499
1413C
1414 7400 CONTINUE
1415      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'FIT')GOTO7499
1416C
1417      IF(ICOM.EQ.'BCA')THEN
1418        ICOM=IHARG(1)
1419        ISHIFT=1
1420        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
1421     1              IBUGG2,IERROR)
1422        IBCABT='ON'
1423      ENDIF
1424C
1425      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'PLOT')GOTO7410
1426      IF(NUMARG.GE.3.AND.IHARG(3).EQ.'PLOT')GOTO7410
1427      IF(NUMARG.GE.4.AND.IHARG(4).EQ.'PLOT')GOTO7410
1428      IF(NUMARG.GE.5.AND.IHARG(5).EQ.'PLOT')GOTO7410
1429      IF(NUMARG.GE.6.AND.IHARG(6).EQ.'PLOT')GOTO7410
1430      IF(NUMARG.GE.7.AND.IHARG(7).EQ.'PLOT')GOTO7410
1431      IF(NUMARG.GE.8.AND.IHARG(8).EQ.'PLOT')GOTO7410
1432      IF(NUMARG.GE.9.AND.IHARG(9).EQ.'PLOT')GOTO7410
1433      IF(NUMARG.GE.10.AND.IHARG(10).EQ.'PLOT')GOTO7410
1434      GOTO7499
1435 7410 CONTINUE
1436      CALL DPJBSP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1437     1IBOOSS,ISEED,IBCABT,
1438CCCCC1TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT,
1439     1MAXNXT,
1440     1ICAPSW,ICAPTY,IFORSW,
1441     1CLLIMI,CLWIDT,
1442     1ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
1443      IF(IFOUND.EQ.'YES')GOTO9000
1444C
1445 7499 CONTINUE
1446C
1447C               ****************************************
1448C               **  TREAT THE DEX CONTOUR PLOT CASE   **
1449C               ****************************************
1450C
1451      IF(ICOM.EQ.'DEX'.AND.NUMARG.GE.2.AND.IHARG(1).EQ.'CONT'.AND.
1452     1   IHARG(2).EQ.'PLOT')THEN
1453        CALL DPDCNT(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1454     1              ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
1455        IF(IFOUND.EQ.'YES')GOTO9000
1456      ENDIF
1457C
1458C               ****************************************
1459C               **  TREAT THE YATES CUBE  PLOT CASE   **
1460C               ****************************************
1461C
1462      IF((ICOM.EQ.'DEX'.OR.ICOM.EQ.'YATE').AND.NUMARG.GE.2.AND.
1463     1   IHARG(1).EQ.'CUBE'.AND.IHARG(2).EQ.'PLOT')THEN
1464        CALL DPYACB(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1465     1              ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
1466        IF(IFOUND.EQ.'YES')GOTO9000
1467      ENDIF
1468C
1469C               ****************************************
1470C               **  TREAT THE DEX/DOE ... PLOT CASE   **
1471C               ****************************************
1472C
1473      IF(ICOM.EQ.'DEX ' .OR. ICOM.EQ.'DEXP' .OR. ICOM.EQ.'DOE ' .OR.
1474     1   ICOM.EQ.'DOX ' .OR. ICOM.EQ.'CLAS')THEN
1475        CALL DPDEXP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1476     1              MAXNXT,ISEED,ICONT,
1477     1              ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
1478        IF(IFOUND.EQ.'YES')GOTO9000
1479      ENDIF
1480C
1481C               ****************************************
1482C               **  TREAT THE TAIL AREA PLOT CASE     **
1483C               **  (A SYNONYM IS SURVIVAL PLOT)      **
1484C               **  (MAY 1989)                        **
1485C               ****************************************
1486C
1487      IF(ICOM.EQ.'TAIL' .OR. ICOM.EQ.'SURV' .OR.
1488     1   IHARG(1).EQ.'TAIL' .OR. IHARG(1).EQ.'SURV')THEN
1489        CALL DPTAIL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1490     1              IBUGG2,IBUGG3,ISUBRO,IBUGQ,IFOUND,IERROR)
1491        IF(IFOUND.EQ.'YES')GOTO9000
1492      ENDIF
1493C
1494CCCCC THE FOLLOWING SECTION WAS ADDED JULY 2017
1495C               **************************************************
1496C               **  TREAT THE NORMAL KERNEL DENSITY MIXTURE     **
1497C               **  PLOT CASE                                   **
1498C               **************************************************
1499C
1500      IF(ICOM.EQ.'NORM' .AND. IHARG(1).EQ.'KERN' .AND.
1501     1   IHARG(2).EQ.'DENS' .AND. IHARG(3).EQ.'MIXT' .AND.
1502     1   IHARG(4).EQ.'PLOT')THEN
1503          CALL DPNMPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1504     1                IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1505          IF(IFOUND.EQ.'YES')GOTO9000
1506      ENDIF
1507C
1508CCCCC THE FOLLOWING SECTION WAS ADDED MAY 1998
1509C               **************************************************
1510C               **  TREAT THE <NORMAL/LOGNORMAL/WEIBULL/HAZARD> **
1511C               **  PLOT CASE                                   **
1512C               **************************************************
1513C
1514      IF(ICOM.EQ.'NORM'.OR.ICOM.EQ.'LOGN'.OR.ICOM.EQ.'EXPO'.OR.
1515     1  ICOM.EQ.'WEIB'.OR.ICOM.EQ.'GUMB')THEN
1516        IF(NUMARG.GE.2.AND.IHARG(1).EQ.'HAZA'.AND.
1517     1     IHARG(2).EQ.'PLOT')THEN
1518          CALL DPHAZA(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1519     1                IANGLU,MAXNPP,
1520     1                IX1TSC,IX2TSC,IY1TSC,IY2TSC,
1521     1                IX1TSV,IX2TSV,IY1TSV,IY2TSV,
1522     1                IX1ZFM,IX2ZFM,IY1ZFM,IY2ZFM,
1523     1                IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV,
1524     1                IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1525          IF(IFOUND.EQ.'YES')GOTO9000
1526        ENDIF
1527      ENDIF
1528C
1529      IF(ICOM.EQ.'EXTR'.AND.IHARG(1).EQ.'VALU')THEN
1530        IF(NUMARG.GE.3.AND.IHARG(2).EQ.'HAZA'.AND.
1531     1     IHARG(3).EQ.'PLOT')THEN
1532          CALL DPHAZA(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1533     1                IANGLU,MAXNPP,
1534     1                IX1TSC,IX2TSC,IY1TSC,IY2TSC,
1535     1                IX1TSV,IX2TSV,IY1TSV,IY2TSV,
1536     1                IX1ZFM,IX2ZFM,IY1ZFM,IY2ZFM,
1537     1                IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV,
1538     1                IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1539          IF(IFOUND.EQ.'YES')GOTO9000
1540        ENDIF
1541      ENDIF
1542C
1543CCCCC THE FOLLOWING SECTION WAS ADDED MAY 1990
1544C               ************************************
1545C               **  TREAT THE NORMAL   PLOT CASE  **
1546C               ************************************
1547C
1548      IF(ICOM.EQ.'NORM' .AND. IHARG(1).EQ.'PLOT')GOTO7710
1549      IF(ICOM.EQ.'HIGH' .AND. IHARG(1).EQ.'NORM' .AND.
1550     1   IHARG(2).EQ.'PLOT')GOTO7710
1551      IF(ICOM.EQ.'SUBS' .AND. IHARG(1).EQ.'NORM' .AND.
1552     1   IHARG(2).EQ.'PLOT')GOTO7710
1553      GOTO7799
1554C
1555 7710 CONTINUE
1556      CALL DPNORM(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1557     1            IANGLU,MAXNPP,
1558     1            IX1TSC,IX2TSC,IY1TSC,IY2TSC,
1559     1            IX1TSV,IX2TSV,IY1TSV,IY2TSV,
1560     1            IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1561      IF(IFOUND.EQ.'YES')GOTO9000
1562C
1563 7799 CONTINUE
1564C
1565CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 1992 (JJF)
1566C               *********************************
1567C               **  TREAT THE BLOCK PLOT CASE  **
1568C               *********************************
1569C
1570CCCCC THE FOLLOWING 3 LINES WERE COMMENTED OUT   JUNE 1992  JJF
1571CCCCC TO ACCOMODATE THE <STAT> BLOCK PLOTS   JUNE 1992   JJF
1572CCCCC IF(NUMARG.GE.1.AND.ICOM.EQ.'BLOC'.AND.
1573CCCCC1IHARG(1).EQ.'PLOT')GOTO7800
1574CCCCC GOTO7899
1575C
1576CCCCC THE FOLLOWING 10 LINES WERE ADDED TO AVOID     AUGUST 1993
1577CCCCC A CONFLICT WITH   MEIDAN POLISH   COMMAND      AUGUST 1993
1578      IF(ICOM.EQ.'ROBU'.AND.IHARG(1).EQ.'SMOO')GOTO7899
1579      IF(NUMARG.GE.1)THEN
1580         IF((ICOM.EQ.'BLOC'.OR.ICOM.EQ.'ROBU').AND.
1581     1      IHARG(1).EQ.'PLOT')GOTO7800
1582      ENDIF
1583      IF(NUMARG.GE.2)THEN
1584         IF((IHARG(1).EQ.'BLOC'.OR.IHARG(1).EQ.'ROBU').AND.
1585     1     IHARG(2).EQ.'PLOT')GOTO7800
1586      ENDIF
1587      IF(NUMARG.GE.3)THEN
1588         IF((IHARG(2).EQ.'BLOC'.OR.IHARG(2).EQ.'ROBU').AND.
1589     1     IHARG(3).EQ.'PLOT')GOTO7800
1590      ENDIF
1591CCCCC FOLLOWING 3 LINES ADDED MARCH 1995.
1592      IF(NUMARG.GE.4)THEN
1593         IF((IHARG(3).EQ.'BLOC'.OR.IHARG(3).EQ.'ROBU').AND.
1594     1      IHARG(4).EQ.'PLOT')GOTO7800
1595      ENDIF
1596      GOTO7899
1597C
1598 7800 CONTINUE
1599CCCCC MARCH 1995.  ADD MAXNXT TO ARGUMENT LIST.
1600CCCCC MARCH 2019.  ADD ICHMAP TO ARGUMENT LIST.
1601      CALL DPBLOC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1602     1            BARHEF,BARWEF,MAXNXT,ISEED,ICHMAP,ICONT,
1603     1            IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1604      IF(IFOUND.EQ.'YES')GOTO9000
1605C
1606 7899 CONTINUE
1607C
1608CCCCC THE FOLLOWING SECTION WAS ADDED OCTOBER 1991 (JJF)
1609C               *********************************
1610C               **  TREAT THE PHD PLOT CASE    **
1611C               *********************************
1612C
1613      IF(NUMARG.GE.1.AND.ICOM.EQ.'PHD'.AND.
1614     1IHARG(1).EQ.'PLOT')THEN
1615CCCCC   CALL DPPHDP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1616CCCCC1              TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT,
1617CCCCC1              ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
1618        IF(IFOUND.EQ.'YES')GOTO9000
1619      ENDIF
1620C
1621CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 1992 (ALAN)
1622C               *********************************
1623C               **  TREAT THE VECTOR PLOT CASE **
1624C               *********************************
1625C
1626      IF(NUMARG.GE.1.AND.ICOM.EQ.'VECT'.AND.
1627     1   IHARG(1).EQ.'PLOT')THEN
1628        CALL DPVECT(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1629     1              IVCFMT,IVCARR,IANGLU,
1630     1              IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1631        IF(IFOUND.EQ.'YES')GOTO9000
1632      ENDIF
1633C
1634CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 1992 (ALAN)
1635C               *********************************
1636C               **  TREAT THE SYMBOL PLOT CASE **
1637C               *********************************
1638C
1639      IF(NUMARG.GE.1.AND.ICOM.EQ.'SYMB'.AND.
1640     1   IHARG(1).EQ.'PLOT')THEN
1641        CALL DPPLSY(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1642     1              IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1643        IF(IFOUND.EQ.'YES')GOTO9000
1644      ENDIF
1645C
1646CCCCC THE FOLLOWING SECTION WAS ADDED    NOVEMBER 1992 (ALAN)
1647C               **********************************
1648C               **  TREAT THE ANDREWS PLOT CASE **
1649C               **********************************
1650C
1651      IF(NUMARG.GE.1.AND.ICOM.EQ.'ANDR'.AND.
1652     1   IHARG(1).EQ.'PLOT')THEN
1653CCCCC   PANINC=0.1
1654        CALL DPANDR(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,ANDINC,
1655     1              IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1656        IF(IFOUND.EQ.'YES')GOTO9000
1657      ENDIF
1658C
1659CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2003 (ALAN)
1660C               ***********************************************
1661C               **  TREAT THE PARALLEL COORDINATES PLOT CASE **
1662C               ***********************************************
1663C
1664      IF(NUMARG.GE.2.AND.ICOM.EQ.'PARA'.AND.
1665     1IHARG(1).EQ.'COOR'.AND.IHARG(2).EQ.'PLOT')THEN
1666        CALL DPPCPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1667     1              IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1668        IF(IFOUND.EQ.'YES')GOTO9000
1669      ELSEIF(NUMARG.GE.3.AND.ICOM.EQ.'GROU'.AND.
1670     1       IHARG(1).EQ.'PARA'.AND. IHARG(2).EQ.'COOR'.AND.
1671     1       IHARG(3).EQ.'PLOT')THEN
1672        CALL DPPCPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1673     1              IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1674        IF(IFOUND.EQ.'YES')GOTO9000
1675      ENDIF
1676C
1677CCCCC THE FOLLOWING SECTION WAS ADDED      DECEMBER 1993
1678C               ******************************************
1679C               **  TREAT THE Q ... CONTROL CHART CASE  **
1680C               ******************************************
1681C
1682      IF(ICOM.EQ.'Q' .AND. IHARG(1).NE.'QUAN')THEN
1683        CALL DPQCC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1684     1             ICONT,IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1685        IF(IFOUND.EQ.'YES')GOTO9000
1686      ENDIF
1687C
1688CCCCC THE FOLLOWING SECTION WAS ADDED      DECEMBER 1993
1689C               ************************************************
1690C               **  TREAT THE CME PLOT CASE                   **
1691C               **  TREAT THE COND. ... EXCEEDANCE PLOT CASE  **
1692C               ************************************************
1693C
1694C  MAY 1998.  CHECK FOR CONFLICT WITH "CME ESTIMATE" OR
1695C             "CME GENERALIZED PARETO".
1696      IF(ICOM.EQ.'CME')GOTO8500
1697      IF(ICOM.EQ.'COND')GOTO8500
1698      IF(ICOM.EQ.'YANG')GOTO8500
1699      IF(ICOM.EQ.'LIFE')GOTO8500
1700      IF(ICOM.EQ.'MEAN')GOTO8500
1701      GOTO8599
1702C
1703 8500 CONTINUE
1704      IF(NUMARG.GE.1.AND.(IHARG(1).EQ.'ESTI'.OR.IHARG(1).EQ.'GENE'))
1705     1GOTO8599
1706      CALL DPCME(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1707     1IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1708      IF(IFOUND.EQ.'YES')GOTO9000
1709C
1710 8599 CONTINUE
1711C
1712C               *******************************************
1713C               **  TREAT THE ... COMOVEMENT  PLOT CASE  **
1714C               *******************************************
1715C
1716C NOTE: FOLD COMOVEMENT PLOT IN WITH CORRELATION PLOT.
1717C
1718CCCCC IF(ICOM.EQ.'AUTO' .OR. ICOM.EQ.'CROS' .OR. ICOM.EQ.'COMO' .OR.
1719CCCCC1   IHARG(1).EQ.'AUTO' .OR. IHARG(1).EQ.'CROS' .OR.
1720CCCCC1   IHARG(1).EQ.'COMO')THEN
1721CCCCC   CALL DPCOMV(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1722CCCCC1              IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1723CCCCC   IF(IFOUND.EQ.'YES')GOTO9000
1724CCCCC ENDIF
1725C
1726C               ****************************************
1727C               **  TREAT THE KAPLAN MEIER PLOT CASE  **
1728C               **  (MAY 1998)                        **
1729C               ****************************************
1730C
1731      IF(ICOM.EQ.'KAPL' .OR. ICOM.EQ.'MODI')THEN
1732        CALL DPKAPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1733     1              IBUGG2,IBUGG3,ISUBRO,IBUGQ,IFOUND,IERROR)
1734        IF(IFOUND.EQ.'YES')GOTO9000
1735      ENDIF
1736C
1737C               ****************************************
1738C               **  TREAT THE DUANE        PLOT CASE  **
1739C               **  (MAY 1998)                        **
1740C               ****************************************
1741C
1742      IF(ICOM.EQ.'DUAN')THEN
1743        CALL DPDUAN(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1744     1              IBUGG2,IBUGG3,ISUBRO,IBUGQ,IFOUND,IERROR)
1745        IF(IFOUND.EQ.'YES')GOTO9000
1746      ENDIF
1747C
1748C               ****************************************
1749C               **  TREAT THE EMPIRICAL CDF PLOT CASE **
1750C               **  (MAY 1998)                        **
1751C               ****************************************
1752C
1753      IF(ICOM.EQ.'EMPI' .OR. ICOM.EQ.'ECDF')THEN
1754        CALL DPECDF(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1755     1              IBUGG2,IBUGG3,ISUBRO,IBUGQ,IFOUND,IERROR)
1756        IF(IFOUND.EQ.'YES')GOTO9000
1757      ENDIF
1758C
1759C               *********************************************
1760C               **  TREAT THE SEASONAL SUBSERIES PLOT CASE **
1761C               **  (FEBRUARY 1999)                        **
1762C               *********************************************
1763C
1764      IF(ICOM.EQ.'SEAS' .OR. IHARG(1).EQ.'SEAS')THEN
1765        CALL DPSESB(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1766     1              IBUGG2,IBUGG3,ISUBRO,IBUGQ,IFOUND,IERROR)
1767        IF(IFOUND.EQ.'YES')GOTO9000
1768      ENDIF
1769C
1770C               *********************************************
1771C               **  TREAT THE SPREAD-LOCATION    PLOT CASE **
1772C               **  (AUGUST   1999)                        **
1773C               *********************************************
1774C
1775      IF(ICOM.EQ.'SPRE' .OR. IHARG(1).EQ.'SPRE')THEN
1776        CALL DPSLOC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1777     1              IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1778        IF(IFOUND.EQ.'YES')GOTO9000
1779      ENDIF
1780C
1781C               ************************************************
1782C               **  TREAT THE TUKEY MEAN-DIFFERENCE PLOT CASE **
1783C               ************************************************
1784C
1785      IF((ICOM.EQ.'TUKE'.AND.IHARG(1).NE.'LAMB') .OR.
1786     1   (ICOM.EQ.'HIGH'.AND.IHARG(1).EQ.'TUKE') .OR.
1787     1   (ICOM.EQ.'SUBS'.AND.IHARG(1).EQ.'TUKE'))THEN
1788        CALL DPTUMD(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1789     1              IANGLU,MAXNPP,
1790     1              IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1791        IF(IFOUND.EQ.'YES')GOTO9000
1792      ENDIF
1793C
1794C               ************************************************
1795C               **  TREAT THE SHIFT                 PLOT CASE **
1796C               ************************************************
1797C
1798      IF(ICOM.EQ.'SHIF' .OR.
1799     1  (ICOM.EQ.'HIGH' .AND. IHARG(1).EQ.'SHIF') .OR.
1800     1  (ICOM.EQ.'SUBS' .AND. IHARG(1).EQ.'SHIF'))THEN
1801        CALL DPSHPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1802     1              IANGLU,MAXNPP,
1803     1              IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1804        IF(IFOUND.EQ.'YES' .OR. IERROR.EQ.'YES')GOTO9000
1805      ENDIF
1806C
1807C               ************************************************
1808C               **  TREAT THE BLAND ALTMAN          PLOT CASE **
1809C               ************************************************
1810C
1811      IF((ICOM.EQ.'BLAN'.AND.IHARG(1).EQ.'ALTM') .OR.
1812     1   (ICOM.EQ.'HIGH'.AND.IHARG(1).EQ.'BLAN') .OR.
1813     1   (ICOM.EQ.'SUBS'.AND.IHARG(1).EQ.'BLAN'))THEN
1814        CALL DPBAPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1815     1              IANGLU,ISEED,IBOOSS,MAXNPP,
1816     1              IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1817        IF(IFOUND.EQ.'YES')GOTO9000
1818      ENDIF
1819C
1820C               ************************************************
1821C               **  TREAT THE INTERACTION           PLOT CASE **
1822C               ************************************************
1823C
1824      IF(ICOM.EQ.'INTE'.AND.NUMARG.GE.1.AND.
1825     1IHARG(1).EQ.'PLOT')GOTO9500
1826      GOTO9599
1827C
1828 9500 CONTINUE
1829      ISHIFT=1
1830      CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
1831     1IBUGG2,IERROR)
1832      CALL DPINPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1833     1MAXNPP,
1834     1ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
1835      IF(IFOUND.EQ.'YES')GOTO9000
1836C
1837 9599 CONTINUE
1838C
1839C               ****************************************************
1840C               **  TREAT THE ... STATISTIC INTERACTION PLOT CASE **
1841C               ****************************************************
1842C
1843      IF(NUMARG.LT.2)GOTO9699
1844      DO9602I=1,NUMARG-1
1845        IF(IHARG(I).EQ.'INTE'.AND.IHARG(I+1).EQ.'PLOT')GOTO9600
1846 9602 CONTINUE
1847      IF(NUMARG.LT.3)GOTO9699
1848      DO9604I=1,NUMARG-2
1849        IF(IHARG(I).EQ.'INTE'.AND.IHARG(I+1).EQ.'STAT'.AND.
1850     1     IHARG(I+2).EQ.'PLOT')GOTO9600
1851 9604 CONTINUE
1852      GOTO9699
1853C
1854 9600 CONTINUE
1855      CALL DPISP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1856CCCCC1TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT,
1857     1MAXNXT,
1858     1ISEED,
1859     1ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
1860      IF(IFOUND.EQ.'YES')GOTO9000
1861C
1862 9699 CONTINUE
1863C
1864C               *******************************************
1865C               **  TREAT THE KERNEL DENSITY PLOT  CASE  **
1866C               *******************************************
1867C
1868      IF((ICOM.EQ.'KERN' .OR. ICOM.EQ.'DENS') .OR.
1869     1   IHARG(1).EQ.'KERN' .OR. IHARG(2).EQ.'KERN' .OR.
1870     1   IHARG(3).EQ.'KERN')THEN
1871        CALL DPKDEN(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1872     1              IKDENP,PKDEWI,ISEED,
1873     1              ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
1874        IF(IFOUND.EQ.'YES')GOTO9000
1875      ENDIF
1876C
1877C               *******************************************
1878C               **  TREAT THE LORENZ CURVE         CASE  **
1879C               *******************************************
1880C
1881      IF(ICOM.EQ.'LORE' .OR.
1882     1   IHARG(1).EQ.'LORE' .OR. IHARG(2).EQ.'LORE' .OR.
1883     1   IHARG(3).EQ.'LORE')THEN
1884        CALL DPLORE(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1885     1              ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
1886        IF(IFOUND.EQ.'YES')GOTO9000
1887      ENDIF
1888C
1889C               *******************************************
1890C               **  TREAT THE H CONSISTENCY PLOT   CASE  **
1891C               *******************************************
1892C
1893      IF(
1894     1  (ICOM.EQ.'H   ' .AND. IHARG(1).EQ.'CONS' .AND.
1895     1   IHARG(2).EQ.'PLOT') .OR.
1896     1  (ICOM.EQ.'K   ' .AND. IHARG(1).EQ.'CONS' .AND.
1897     1   IHARG(2).EQ.'PLOT') .OR.
1898     1  (ICOM.EQ.'COCH' .AND. IHARG(1).EQ.'VARI' .AND.
1899     1   IHARG(2).EQ.'PLOT')
1900     1  )THEN
1901        CALL DPHKCP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1902     1              IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1903        IF(IFOUND.EQ.'YES')GOTO9000
1904      ENDIF
1905C
1906C               *******************************************
1907C               **  TREAT THE TWO FACTOR    PLOT   CASE  **
1908C               *******************************************
1909C
1910      IF(ICOM.EQ.'TWO ' .AND. IHARG(1).EQ.'FACT' .AND.
1911     1   IHARG(2).EQ.'PLOT')THEN
1912        CALL DPTWFP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1913     1              IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1914        IF(IFOUND.EQ.'YES')GOTO9000
1915      ENDIF
1916C
1917C               *******************************************
1918C               **  TREAT THE CONSENSUS MEAN PLOT  CASE  **
1919C               *******************************************
1920C
1921      IF(ICOM.EQ.'CONS')THEN
1922        IF(NUMARG.GE.2.AND.
1923     1    IHARG(1).EQ.'MEAN'.AND.IHARG(2).EQ.'PLOT')THEN
1924          CALL DPCMPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1925     1                ICAPSW,ICAPTY,
1926     1                IFORSW,ISEED,IBOOSS,
1927     1                ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
1928          IF(IFOUND.EQ.'YES')GOTO9000
1929        ENDIF
1930      ENDIF
1931C
1932C               *********************************************
1933C               **  TREAT THE PARTIAL REGRESSION PLOT CASE **
1934C               **  TREAT THE PARTIAL RESIDUAL   PLOT CASE **
1935C               **  TREAT THE PARTIAL LEVERAGE   PLOT CASE **
1936C               *********************************************
1937C
1938      IF(ICOM.EQ.'PART')THEN
1939        IF(NUMARG.GE.2.AND.
1940     1    (IHARG(1).EQ.'REGR'.AND.IHARG(2).EQ.'PLOT') .OR.
1941     1    (IHARG(1).EQ.'RESI'.AND.IHARG(2).EQ.'PLOT') .OR.
1942     1    (IHARG(1).EQ.'LEVE'.AND.IHARG(2).EQ.'PLOT'))THEN
1943          ICASPL='PREG'
1944          CALL DPPREG(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1945     1                IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1946          IF(IFOUND.EQ.'YES')GOTO9000
1947        ENDIF
1948      ELSEIF(ICOM.EQ.'ADDE')THEN
1949        ICASPL='PREG'
1950        IF(NUMARG.GE.2.AND.
1951     1    IHARG(1).EQ.'VARI'.AND.IHARG(2).EQ.'PLOT')THEN
1952          CALL DPPREG(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1953     1                IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1954          IF(IFOUND.EQ.'YES')GOTO9000
1955        ENDIF
1956      ELSEIF(ICOM.EQ.'COMP')THEN
1957        ICASPL='PREG'
1958        IF(NUMARG.GE.3.AND.
1959     1    IHARG(1).EQ.'PLUS'.AND.IHARG(2).EQ.'RESI'.AND.
1960     1    IHARG(3).EQ.'PLOT')THEN
1961          CALL DPPREG(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1962     1                IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1963          IF(IFOUND.EQ.'YES')GOTO9000
1964        ENDIF
1965      ELSEIF(ICOM.EQ.'CCPR')THEN
1966        IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')THEN
1967          ICASPL='CCPR'
1968          CALL DPPREG(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1969     1                IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1970          IF(IFOUND.EQ.'YES')GOTO9000
1971        ENDIF
1972      ENDIF
1973C
1974C               *****************************************
1975C               **  TREAT THE ... INFLUENCE CURVE CASE **
1976C               *****************************************
1977C
1978      IF(NUMARG.GE.2)THEN
1979        DO9710I=1,NUMARG-1
1980          IF(IHARG(I).EQ.'INFL' .AND. IHARG(I+1).EQ.'CURV')THEN
1981            CALL DPINCU(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1982CCCCC1           TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT,
1983     1           MAXNXT,
1984     1           ISEED,
1985     1           ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
1986            IF(IFOUND.EQ.'YES')GOTO9000
1987            GOTO9719
1988          ENDIF
1989 9710   CONTINUE
1990      ENDIF
1991 9719 CONTINUE
1992C
1993CCCCC THE FOLLOWING SECTION WAS ADDED      APRIL    2005
1994C               ************************************************
1995C               **  TREAT THE PEAKS OVER THRESHOLD PLOT  CASE **
1996C               **            POT                  PLOT       **
1997C               ************************************************
1998C
1999      IF(ICOM.EQ.'PEAK')THEN
2000        IF(NUMARG.GE.3.AND.IHARG(1).EQ.'OVER'.AND.
2001     1     IHARG(2).EQ.'THRE'.AND.IHARG(3).EQ.'PLOT')THEN
2002          CALL DPPOTP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
2003     1                IBOOSS,ISEED,
2004     1                ICAPSW,ICAPTY,IFORSW,
2005     1                IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
2006          IF(IFOUND.EQ.'YES')GOTO9000
2007        ENDIF
2008      ELSEIF(ICOM.EQ.'POT ')THEN
2009        IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')THEN
2010          CALL DPPOTP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
2011     1                IBOOSS,ISEED,
2012     1                ICAPSW,ICAPTY,IFORSW,
2013     1                IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
2014          IF(IFOUND.EQ.'YES')GOTO9000
2015        ENDIF
2016      ENDIF
2017C
2018C               *************************************************
2019C               **  TREAT THE REPAIR PLOT CASE                 **
2020C               **  (OCTOBER  2006)                            **
2021C               *************************************************
2022C
2023      IF(ICOM.EQ.'REPA')THEN
2024        CALL DPRPLO(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
2025     1              IBUGG2,IBUGG3,ISUBRO,IBUGQ,IFOUND,IERROR)
2026        IF(IFOUND.EQ.'YES')GOTO9000
2027      ENDIF
2028C
2029C               *************************************************
2030C               **  TREAT THE MEAN REPAIR  FUNCTION PLOT CASE  **
2031C               **  (OCTOBER  2006)                            **
2032C               *************************************************
2033C
2034      IF(ICOM.EQ.'MEAN' .OR. ICOM.EQ.'AVER')THEN
2035        CALL DPMRFP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
2036     1              IBUGG2,IBUGG3,ISUBRO,IBUGQ,IFOUND,IERROR)
2037        IF(IFOUND.EQ.'YES')GOTO9000
2038      ENDIF
2039C
2040C               **************************************
2041C               **  TREAT THE TRILINEAR PLOT CASE.  **
2042C               **************************************
2043C
2044      IF(ICOM.EQ.'TRIL' .AND. IHARG(1).EQ.'PLOT')THEN
2045        CALL DPTRPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
2046     1              IBUGG2,IBUGG3,ISUBRO,IBUGQ,IFOUND,IERROR)
2047        IF(IFOUND.EQ.'YES')GOTO9000
2048      ENDIF
2049C
2050C               ****************************************
2051C               **  TREAT THE ROC         PLOT CASE.  **
2052C               **  TREAT THE PSUEDO ROC  PLOT CASE.  **
2053C               ****************************************
2054C
2055      IF(ICOM.EQ.'ROC ')THEN
2056        CALL DPROC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
2057     1             IBUGG2,IBUGG3,ISUBRO,IBUGQ,IFOUND,IERROR)
2058        IF(IFOUND.EQ.'YES')GOTO9000
2059      ELSEIF(ICOM.EQ.'PSUE' .AND. IHARG(1).EQ.'ROC ')THEN
2060        CALL DPROC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
2061     1             IBUGG2,IBUGG3,ISUBRO,IBUGQ,IFOUND,IERROR)
2062        IF(IFOUND.EQ.'YES')GOTO9000
2063      ENDIF
2064C
2065C               **************************************
2066C               **  TREAT THE ROSE      PLOT CASE.  **
2067C               **************************************
2068C
2069      IF(ICOM.EQ.'ROSE')THEN
2070        CALL DPROSE(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
2071     1             IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
2072        IF(IFOUND.EQ.'YES')GOTO9000
2073      ENDIF
2074C
2075C               *******************************************
2076C               **  TREAT THE BIVARIATE NORMAL TOLERANCE **
2077C               **  REGION   PLOT CASE.                  **
2078C               *******************************************
2079C
2080      IF(ICOM.EQ.'BIVA' .OR. ICOM.EQ.'POIN')THEN
2081        CALL DPBNTR(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
2082     1             IBUGG2,IBUGG3,ISUBRO,IBUGQ,IFOUND,IERROR)
2083        IF(IFOUND.EQ.'YES')GOTO9000
2084      ENDIF
2085C
2086C               **************************************
2087C               **  TREAT THE BINARY    PLOT CASE.  **
2088C               **************************************
2089C
2090      IF(ICOM.EQ.'BINA' .AND. IHARG(1).NE.'TABU')THEN
2091        CALL DPBIPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
2092     1             IBUGG2,IBUGG3,ISUBRO,IBUGQ,IFOUND,IERROR)
2093        IF(IFOUND.EQ.'YES')GOTO9000
2094      ENDIF
2095C
2096C               *****************************************
2097C               **  TREAT THE ORD           PLOT CASE  **
2098C               *****************************************
2099C
2100      IF(ICOM.EQ.'ORD ')THEN
2101        CALL DPORD(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
2102     1             CLLIMI,CLWIDT,
2103     1             IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
2104        IF(IFOUND.EQ.'YES')GOTO9000
2105      ENDIF
2106C
2107C               *****************************************
2108C               **  TREAT THE POISSON       PLOT CASE  **
2109C               *****************************************
2110C
2111      IF(ICOM.EQ.'POIS' .AND. IHARG(1).EQ.'PLOT')THEN
2112        CALL DPPOIS(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
2113     1             CLLIMI,CLWIDT,
2114     1             IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
2115        IF(IFOUND.EQ.'YES')GOTO9000
2116      ELSEIF(ICOM.EQ.'GEOM' .AND. IHARG(1).EQ.'PLOT')THEN
2117        CALL DPPOIS(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
2118     1             CLLIMI,CLWIDT,
2119     1             IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
2120        IF(IFOUND.EQ.'YES')GOTO9000
2121      ELSEIF(ICOM.EQ.'BINO' .AND. IHARG(1).EQ.'PLOT')THEN
2122        CALL DPPOIS(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
2123     1             CLLIMI,CLWIDT,
2124     1             IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
2125        IF(IFOUND.EQ.'YES')GOTO9000
2126      ELSEIF(ICOM.EQ.'LOGA' .AND. IHARG(1).EQ.'SERI' .AND.
2127     1       IHARG(2).EQ.'PLOT')THEN
2128        CALL DPPOIS(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
2129     1             CLLIMI,CLWIDT,
2130     1             IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
2131        IF(IFOUND.EQ.'YES')GOTO9000
2132      ELSEIF(ICOM.EQ.'NEGA' .AND. IHARG(1).EQ.'BINO' .AND.
2133     1       IHARG(2).EQ.'PLOT')THEN
2134        CALL DPPOIS(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
2135     1             CLLIMI,CLWIDT,
2136     1             IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
2137        IF(IFOUND.EQ.'YES')GOTO9000
2138      ENDIF
2139C
2140C               *****************************************
2141C               **  TREAT THE ASSOCIATION   PLOT CASE  **
2142C               *****************************************
2143C
2144      IF(ICOM.EQ.'ASSO' .AND. IHARG(1).EQ.'PLOT')THEN
2145        CALL DPASSO(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
2146     1             IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
2147        IF(IFOUND.EQ.'YES')GOTO9000
2148      ENDIF
2149C
2150C               *****************************************
2151C               **  TREAT THE SIEVE         PLOT CASE  **
2152C               *****************************************
2153C
2154      IF(ICOM.EQ.'SIEV' .AND. IHARG(1).EQ.'PLOT')THEN
2155        CALL DPSIEV(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
2156     1             IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
2157        IF(IFOUND.EQ.'YES')GOTO9000
2158      ENDIF
2159C
2160C               *****************************************
2161C               **  TREAT THE LEVEL         PLOT CASE  **
2162C               *****************************************
2163C
2164      IF(ICOM.EQ.'LEVE' .AND. IHARG(1).EQ.'PLOT')THEN
2165        ISHIFT=1
2166        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
2167     1              IBUGG2,IERROR)
2168        CALL DPLEPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
2169     1             IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
2170        IF(IFOUND.EQ.'YES')GOTO9000
2171      ELSEIF(ICOM.EQ.'DISC' .AND. IHARG(1).EQ.'CONT' .AND.
2172     1  IHARG(2).EQ.'PLOT')THEN
2173        ISHIFT=2
2174        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
2175     1              IBUGG2,IERROR)
2176        CALL DPLEPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
2177     1             IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
2178        IF(IFOUND.EQ.'YES')GOTO9000
2179      ENDIF
2180C
2181C               *****************************************
2182C               **  TREAT THE IMAGE         PLOT CASE  **
2183C               *****************************************
2184C
2185      IF(ICOM.EQ.'IMAG' .AND. IHARG(1).EQ.'PLOT')THEN
2186        ISHIFT=1
2187        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
2188     1              IBUGG2,IERROR)
2189        CALL DPIMAG(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
2190     1             IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
2191        IF(IFOUND.EQ.'YES')GOTO9000
2192      ENDIF
2193C
2194C               *************************************************
2195C               **  TREAT THE SPATIAL DISTRIBUTION  PLOT CASE  **
2196C               *************************************************
2197C
2198      IF(ICOM.EQ.'SPAT' .AND. IHARG(1).EQ.'DIST' .AND.
2199     1   IHARG(2).EQ.'PLOT')THEN
2200        ISHIFT=2
2201        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
2202     1              IBUGG2,IERROR)
2203        CALL DPSDPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
2204     1             IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
2205        IF(IFOUND.EQ.'YES')GOTO9000
2206      ENDIF
2207C
2208C               *****************************************
2209C               **  TREAT THE FLUCUATION    PLOT CASE  **
2210C               *****************************************
2211C
2212      IF(ICOM.EQ.'FLUC')THEN
2213        CALL DPFLUC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
2214     1             IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
2215        IF(IFOUND.EQ.'YES')GOTO9000
2216      ENDIF
2217C
2218C               *****************************************
2219C               **  TREAT THE STRIP         PLOT CASE  **
2220C               *****************************************
2221C
2222      IF(ICOM.EQ.'STRI'.AND.IHARG(1).EQ.'PLOT')THEN
2223        CALL DPSTRI(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,ISEED,
2224     1              ISUBRO,IBUGG2,IBUGG3,IBUGQ,
2225     1              IFOUND,IERROR)
2226        IF(IFOUND.EQ.'YES')GOTO9000
2227      ELSEIF(ICOM.EQ.'BATC'.AND.IHARG(1).EQ.'STRI'.AND.
2228     1       IHARG(2).EQ.'PLOT')THEN
2229        CALL DPSTRI(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,ISEED,
2230     1              ISUBRO,IBUGG2,IBUGG3,IBUGQ,
2231     1              IFOUND,IERROR)
2232        IF(IFOUND.EQ.'YES')GOTO9000
2233C
2234C     FOLLOWING SECTION ADDED TO SUPPORT "BATCH MULTIPLE"
2235C     OPTION FOR STRIP PLOT--10/2009
2236C
2237      ELSEIF(ICOM.EQ.'BATC'.AND.IHARG(1).EQ.'MULT'.AND.
2238     1       IHARG(2).EQ.'STRI'.AND.IHARG(3).EQ.'PLOT')THEN
2239        CALL DPSTRI(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,ISEED,
2240     1              ISUBRO,IBUGG2,IBUGG3,IBUGQ,
2241     1              IFOUND,IERROR)
2242        IF(IFOUND.EQ.'YES')GOTO9000
2243      ELSEIF(ICOM.EQ.'MULT'.AND.IHARG(1).EQ.'BATC'.AND.
2244     1       IHARG(2).EQ.'STRI'.AND.IHARG(3).EQ.'PLOT')THEN
2245        CALL DPSTRI(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,ISEED,
2246     1              ISUBRO,IBUGG2,IBUGG3,IBUGQ,
2247     1              IFOUND,IERROR)
2248        IF(IFOUND.EQ.'YES')GOTO9000
2249      ENDIF
2250C
2251C               *******************************************
2252C               **  TREAT THE DETECTION LIMIT PLOT CASE  **
2253C               *******************************************
2254C
2255      IF(ICOM.EQ.'DETE'.AND.IHARG(1).EQ.'LIMI'.AND.
2256     1   IHARG(2).EQ.'PLOT')THEN
2257        CALL DPDLPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,ISEED,
2258     1              ISUBRO,IBUGG2,IBUGG3,IBUGQ,
2259     1              IFOUND,IERROR)
2260        IF(IFOUND.EQ.'YES')GOTO9000
2261      ELSEIF(ICOM.EQ.'NORM'.AND.IHARG(1).EQ.'DETE'.AND.
2262     1       IHARG(2).EQ.'LIMI'.AND.IHARG(3).EQ.'PLOT')THEN
2263        CALL DPDLPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,ISEED,
2264     1              ISUBRO,IBUGG2,IBUGG3,IBUGQ,
2265     1              IFOUND,IERROR)
2266        IF(IFOUND.EQ.'YES')GOTO9000
2267      ENDIF
2268C
2269C               *****************************************
2270C               **  TREAT THE TABULATION    PLOT CASE  **
2271C               *****************************************
2272C
2273      IF(ICOM.EQ.'TABU' .OR.
2274     1   (ICOM.EQ.'CHAR' .AND. IHARG(1).EQ.'TABU'))THEN
2275        CALL DPTAPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
2276     1             IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
2277        IF(IFOUND.EQ.'YES')GOTO9000
2278      ENDIF
2279C
2280C               ********************************************
2281C               **  TREAT THE ISO 13528 ZSCORE PLOT CASE  **
2282C               **            ISO 13528 JSCORE PLOT CASE  **
2283C               ********************************************
2284C
2285      IF(ICOM.EQ.'ISO ' .AND. IHARG(1).EQ.'1352' .AND.
2286     1  (IHARG(2).EQ.'ZSCO' .OR. IHARG(2).EQ.'JSCO').AND.
2287     1   IHARG(3).EQ.'PLOT')THEN
2288        CALL DPZSCC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
2289     1              IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
2290        IF(IFOUND.EQ.'YES')GOTO9000
2291      ENDIF
2292C
2293C               *****************************************
2294C               **  TREAT THE ISO 13528     PLOT CASE  **
2295C               *****************************************
2296C
2297      IF(ICOM.EQ.'ISO ' .AND. IHARG(1).EQ.'1352' .AND.
2298     1   IHARG(2).EQ.'PLOT')THEN
2299        CALL DPISOP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
2300     1              IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
2301        IF(IFOUND.EQ.'YES')GOTO9000
2302      ENDIF
2303C
2304C               ******************************************
2305C               **  TREAT THE ISO 13528 RLP PLOT  CASE  **
2306C               ******************************************
2307C
2308      IF(ICOM.EQ.'ISO ' .AND. IHARG(1).EQ.'1352' .AND.
2309     1   IHARG(2).EQ.'RLP' .AND. IHARG(3).EQ.'PLOT')THEN
2310        CALL DPRLPP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
2311     1              IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
2312        IF(IFOUND.EQ.'YES')GOTO9000
2313      ENDIF
2314C
2315C               *************************************************
2316C               **  TREAT THE TWO-WAY <ROW/COLUMN> PLOT  CASE  **
2317C               *************************************************
2318C
2319      IF(ICOM.EQ.'TWO ' .AND. IHARG(1).EQ.'WAY ')THEN
2320        CALL DPTWPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
2321     1              ICAPSW,ICAPTY,IFORSW,
2322     1              IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
2323        IF(IFOUND.EQ.'YES')GOTO9000
2324      ENDIF
2325C
2326C               *******************************************
2327C               **  END OF SEARCH FOR GRAPHICS COMMANDS  **
2328C               *******************************************
2329      IFOUND='NO'
2330      IERROR='NO'
2331      GOTO9001
2332C
2333C               *******************************************
2334C               **  STEP 90A--                           **
2335C               **  DO THE FOLLOWING FOR ALL PLOTS:      **
2336C               **  1) SAVE SOME INTERNAL PARAMETERS     **
2337C               **  2) IMPLEMENT SUB-REGIONS             **
2338C               *******************************************
2339C
2340 9000 CONTINUE
2341      IF(IFOUND.EQ.'NO')GOTO9001
2342      IF(IERROR.EQ.'YES')GOTO9001
2343      IF(NPLOTP.LT.1)GOTO9001
2344      IF(ICASPL(1:2).EQ.'3D')GOTO9001
2345C
2346C  FIND PLOT MIN AND MAX AND CORRESPONDING INDEX AND SAVE AS
2347C  INTERNAL PARAMETERS.
2348C
2349      AYMIN=CPUMAX
2350      AYMAX=CPUMIN
2351      AXMIN=CPUMAX
2352      AXMAX=CPUMIN
2353      IYMIN=0
2354      IYMAX=0
2355      IXMIN=0
2356      IXMAX=0
2357      DO10001I=1,NPLOTP
2358        IF(Y(I).LT.AYMIN)THEN
2359          AYMIN=Y(I)
2360          IYMIN=I
2361        ENDIF
2362        IF(Y(I).GT.AYMAX)THEN
2363          AYMAX=Y(I)
2364          IYMAX=I
2365        ENDIF
2366        IF(X(I).LT.AXMIN)THEN
2367          AXMIN=X(I)
2368          IXMIN=I
2369        ENDIF
2370        IF(X(I).GT.AXMAX)THEN
2371          AXMAX=X(I)
2372          IXMAX=I
2373        ENDIF
237410001 CONTINUE
2375      ISUBN0='INGR'
2376      IH='PLOT'
2377      IH2='YMAX'
2378      VALUE0=AYMAX
2379      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
2380     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
2381     1IANS,IWIDTH,IBUGG3,IERROR)
2382      IH='YMAX'
2383      IH2='INDE'
2384      VALUE0=REAL(IYMAX)
2385      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
2386     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
2387     1IANS,IWIDTH,IBUGG3,IERROR)
2388      IH='PLOT'
2389      IH2='YMIN'
2390      VALUE0=AYMIN
2391      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
2392     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
2393     1IANS,IWIDTH,IBUGG3,IERROR)
2394      IH='YMIN'
2395      IH2='INDE'
2396      VALUE0=REAL(IYMIN)
2397      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
2398     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
2399     1IANS,IWIDTH,IBUGG3,IERROR)
2400      IH='PLOT'
2401      IH2='XMAX'
2402      VALUE0=AXMAX
2403      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
2404     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
2405     1IANS,IWIDTH,IBUGG3,IERROR)
2406      IH='XMAX'
2407      IH2='INDE'
2408      VALUE0=REAL(IXMAX)
2409      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
2410     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
2411     1IANS,IWIDTH,IBUGG3,IERROR)
2412      IH='PLOT'
2413      IH2='XMIN'
2414      VALUE0=AXMIN
2415      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
2416     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
2417     1IANS,IWIDTH,IBUGG3,IERROR)
2418      IH='XMIN'
2419      IH2='INDE'
2420      VALUE0=REAL(IXMIN)
2421      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
2422     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
2423     1IANS,IWIDTH,IBUGG3,IERROR)
2424C
2425C  FIND CORRELATION OF PLOT POINTS.  FIND 2 CORRELATIIONS:
2426C  ONE WITH ALL POINTS, ONE WITH TAGPLO=1.
2427C
2428      IWRITE='OFF'
2429      CALL CORR(Y,X,NPLOTP,IWRITE,ACORR,IBUGG3,IERROR)
2430      IH='PLOT'
2431      IH2='CORR'
2432      VALUE0=ACORR
2433      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
2434     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
2435     1IANS,IWIDTH,IBUGG3,IERROR)
2436      J=0
2437      DO10101I=1,NPLOTP
2438        IF(D(I).EQ.1.0)THEN
2439          J=J+1
2440          TEMP(J)=Y(I)
2441          TEMP2(J)=X(I)
2442        ENDIF
244310101 CONTINUE
2444      ACORR=0.0
2445      IF(J.GE.1)CALL CORR(TEMP,TEMP2,J,IWRITE,ACORR,IBUGG3,IERROR)
2446      IH='PLOT'
2447      IH2='COR1'
2448      VALUE0=ACORR
2449      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
2450     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
2451     1IANS,IWIDTH,IBUGG3,IERROR)
2452C
2453C  IMPLEMENT SUB-REGIONS
2454C
2455      NUMSBR=0
2456      DO10200I=MAXSUB,1,-1
2457        IF(ISUBSW(I).EQ.'ON')THEN
2458          NUMSBR=NUMSBR+1
2459          IF(NPLOTP+5.GT.MAXPOP)THEN
2460            WRITE(ICOUT,999)
2461            CALL DPWRST('XXX','BUG ')
2462            WRITE(ICOUT,10205)
246310205       FORMAT('***** FROM MAINGR--')
2464            CALL DPWRST('XXX','BUG ')
2465            WRITE(ICOUT,10208)I
246610208       FORMAT('      UNABLE TO IMPLEMENT SUB-REGION ',I5)
2467            CALL DPWRST('XXX','BUG ')
2468            WRITE(ICOUT,10212)MAXPOP
246910212       FORMAT('      THE NUMBER OF PLOT POINTS WOULD EXCEED ',
2470     1             'MAXIMUM OF ',I8,'.')
2471            CALL DPWRST('XXX','BUG ')
2472            WRITE(ICOUT,10214)NPLOTP
247310214       FORMAT('      THE CURRENT NUMBER OF PLOT POINTS = ',I8)
2474            CALL DPWRST('XXX','BUG ')
2475            GOTO10299
2476          ELSE
2477            DO10220II=NPLOTP,1,-1
2478              X(II+5)=X(II)
2479              Y(II+5)=Y(II)
2480              X3D(II+5)=X3D(II)
2481              DSIZE(II+5)=DSIZE(II)
2482              DSYMB(II+5)=DSYMB(II)
2483              DCOLOR(II+5)=DCOLOR(II)
2484              DFILL(II+5)=DFILL(II)
2485              D(II+5)=D(II)+1.0
248610220       CONTINUE
2487            NPLOTP=NPLOTP+5
2488            X(1)=ASUBXL(I)
2489            IF(X(1).EQ.CPUMIN)X(1)=AXMIN
2490            X(2)=ASUBXU(I)
2491            IF(X(2).EQ.CPUMAX)X(2)=AXMAX
2492            X(3)=ASUBXU(I)
2493            IF(X(3).EQ.CPUMAX)X(3)=AXMAX
2494            X(4)=ASUBXL(I)
2495            IF(X(4).EQ.CPUMIN)X(4)=AXMIN
2496            Y(1)=ASUBYL(I)
2497            IF(Y(1).EQ.CPUMIN)Y(1)=AYMIN
2498            Y(2)=ASUBYL(I)
2499            IF(Y(2).EQ.CPUMIN)Y(2)=AYMIN
2500            Y(3)=ASUBYU(I)
2501            IF(Y(3).EQ.CPUMAX)Y(3)=AYMAX
2502            Y(4)=ASUBYU(I)
2503            IF(Y(4).EQ.CPUMAX)Y(4)=AYMAX
2504            X(5)=X(1)
2505            Y(5)=Y(1)
2506            DO10225JJ=1,5
2507              X3D(JJ)=1.0
2508              DSIZE(JJ)=1.0
2509              DSYMB(JJ)=1.0
2510              DCOLOR(JJ)=1.0
2511              DFILL(JJ)=1.0
2512              D(JJ)=1.0
251310225       CONTINUE
2514          ENDIF
2515        ENDIF
251610200 CONTINUE
2517      NACC=0
2518      NREJ=0
2519      NTOT=0
2520      IF(NUMSBR.GT.0)THEN
2521        NSTRT=NUMSBR*4+1
2522        IF(NSTRT.GT.NPLOTP)GOTO10299
2523        NTOT=0
2524        NACC=0
2525        NREJ=0
2526        XLOW=X(1)
2527        XHIGH=X(2)
2528        YLOW=Y(1)
2529        YHIGH=Y(4)
2530        DO10260I=NSTRT,NPLOTP
2531          NTOT=NTOT+1
2532          XPNT=X(I)
2533          YPNT=Y(I)
2534          IF(
2535     1      (XPNT.LT.XLOW.OR. XPNT.GT.XHIGH) .OR.
2536     1      (YPNT.LT.YLOW.OR.YPNT.GT.YHIGH)
2537     1       )THEN
2538            NREJ=NREJ+1
2539          ELSE
2540            NACC=NACC+1
2541          ENDIF
254210260   CONTINUE
2543      ENDIF
254410299 CONTINUE
2545      IH='NACC'
2546      IH2='EPT '
2547      VALUE0=REAL(NACC)
2548      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
2549     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
2550     1IANS,IWIDTH,IBUGG3,IERROR)
2551      IH='NREJ'
2552      IH2='ECT '
2553      VALUE0=REAL(NREJ)
2554      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
2555     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
2556     1IANS,IWIDTH,IBUGG3,IERROR)
2557      IH='NTOT'
2558      IH2='AL  '
2559      VALUE0=REAL(NTOT)
2560      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
2561     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
2562     1IANS,IWIDTH,IBUGG3,IERROR)
2563C
2564C               *****************
2565C               **  STEP 90--  **
2566C               **  EXIT       **
2567C               *****************
2568C
2569 9001 CONTINUE
2570C
2571C     APRIL 2007.  CHECK FOR FATAL ERROR
2572C
2573      IERRST=IERROR
2574C
2575      IF(IERROR.EQ.'YES')THEN
2576        CALL DPERRO(IERRFA,IANSLC,IWIDTH,IGUIFL,
2577     1              ISUBN1,ISUBN2,ICASPL,
2578     1              IBUGG2,ISUBRO,IERROR)
2579      ENDIF
2580C
2581      IF(IBUGGR.EQ.'ON'.OR.ISUBRO.EQ.'INGR')THEN
2582        WRITE(ICOUT,999)
2583        CALL DPWRST('XXX','BUG ')
2584        WRITE(ICOUT,9011)
2585 9011   FORMAT('***** AT THE END       OF MAINGR--')
2586        CALL DPWRST('XXX','BUG ')
2587        WRITE(ICOUT,9020)IFOUND,IERROR
2588 9020   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
2589        CALL DPWRST('XXX','BUG ')
2590      ENDIF
2591C
2592      RETURN
2593      END
2594      SUBROUTINE MAININ(IBUGIN,ICOMHO,ICOMH2,IRSCNT)
2595C
2596C     PURPOSE--THIS IS SUBROUTINE MAININ.
2597C              (THE   IN    AT THE END OF    MAINPC   STANDS FOR   INITIAL
2598C              THIS SUBROUTINE INITIALIZES ALL NEEDED CONSTANTS
2599C              FOR THE   AREAS--MC = MACHINE CONSTANTS
2600C                             --DB = DEBUGGING
2601C                             --HK = HOUSEKEEPING
2602C                             --PC = PLOT CONTROL
2603C                             --OD = OUTPUT DEVICES
2604C                             --SU = SUPPORT
2605C                             --GR = GRAPHICS
2606C                             --AN = ANALYSIS
2607C                             --DA = DATA
2608C                             --DG = DIAGRAMMATIC GRAPHICS
2609C                             --H2 = HOUSEKEEPING (PART 2)
2610C                             --3D = 3-DIMENSIONAL
2611C     THIS ROUTINE IS TYPICALLY CALLED ONLY ONCE PER DATAPLOT RUN
2612C     (IMMEDIATELY AFTER SIGN-ON).
2613C
2614C     WRITTEN BY--JAMES J. FILLIBEN
2615C                 STATISTICAL ENGINEERING DIVISION
2616C                 INFORMATION TECHNOLOGY LABORATORY
2617C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
2618C                 GAITHERSBURG, MD 20899-8980
2619C                 PHONE--301-975-2855
2620C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
2621C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
2622C     LANGUAGE--ANSI FORTRAN (1977)
2623C     VERSION NUMBER--86/1
2624C     ORIGINAL VERSION--NOVEMBER  1980.
2625C     UPDATED         --FEBRUARY  1981.
2626C     UPDATED         --MAY       1981.
2627C     UPDATED         --AUGUST    1981.
2628C     UPDATED         --OCTOBER   1981.
2629C     UPDATED         --NOVEMBER  1981.
2630C     UPDATED         --MAY       1982.
2631C     UPDATED         --DECEMBER  1986.
2632C     UPDATED         --SEPTEMBER 1988. GENERAL 3-D
2633C     UPDATED         --DECEMBER  1988. RESET2
2634C     UPDATED         --MAY       1989. INITIALIZE DES. OF EXP. COMMON
2635C     UPDATED         --AUGUST    1990. INITIALIZE WINDOW SYSTEM
2636C     UPDATED         --DECEMBER  2015. ADD "IRSCNT".  IF IRSCNT > 0,
2637C                                       DO NOT RESET DEVICE 1 UNDER
2638C                                       WINDOWS (THIS CAUSES A CRASH
2639C                                       WITH THE QWIN DEVICE).
2640C
2641C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
2642C
2643      CHARACTER*4 IBUGIN
2644      CHARACTER*4 ICOMHO
2645      CHARACTER*4 ICOMH2
2646C
2647C-----COMMON----------------------------------------------------------
2648C
2649      INCLUDE 'DPCOPA.INC'
2650      INCLUDE 'DPCOHK.INC'
2651      INCLUDE 'DPCODA.INC'
2652      INCLUDE 'DPCOHO.INC'
2653      INCLUDE 'DPCO3D.INC'
2654      INCLUDE 'DPCOP2.INC'
2655C
2656C-----START POINT-----------------------------------------------------
2657C
2658      IF(IBUGIN.EQ.'ON')THEN
2659        WRITE(ICOUT,999)
2660  999   FORMAT(1X)
2661        CALL DPWRST('XXX','BUG ')
2662        WRITE(ICOUT,51)
2663   51   FORMAT('AT THE BEGINNING OF MAININ--')
2664        CALL DPWRST('XXX','BUG ')
2665        WRITE(ICOUT,53)IBUGPC,ICOMHO,ICOMH2,IRSCNT
2666   53   FORMAT('IBUGPC,ICOMHO,ICONH2,IRSCNT = ',3(A4,2X),I8)
2667        CALL DPWRST('XXX','BUG ')
2668      ENDIF
2669C
2670C               ****************************************************************
2671C               **  STEP 1--
2672C               **  INITIALIZE VARIABLES AND PARAMETERS.
2673C               **  11 INITIALIZATION SUBROUTINES ARE CALLED--
2674C               **        INITMC--INITIALIZE MACHINE CONSTANTS
2675C               **        INITFO--INITIALIZE FILE OPERATIONS
2676C               **        INITHK--INITIALIZE HOUSEKEEPING           VARIABLES AN
2677C               **        INITDA--INITIALIZE DATA                   VARIABLES.
2678C               **        INITPC--INITIALIZE PLOT CONTROL  COMMANDS VARIABLES AN
2679C               **        INITDG--INITIALIZE DIAGRAMMATIC GRAPHICS  COMMANDS VAR
2680C               **        INITOD--INITIALIZE OUTPUT DEVICE COMMANDS VARIABLES AN
2681C               **        INITSU--INITIALIZE SUPPORT       COMMANDS VARIABLES AN
2682C               **        INITH2--INITIALIZE HOUSEKEEPING (PART 2)  VARIABLES AN
2683C               **        INITDB--INITIALIZE DEBUGGING              VARIABLES.
2684C               **        INIT3D--INITIALIZE 3-DIMENSIONAL          VARIABLES.
2685C               ****************************************************************
2686C
2687      IBUGIN='OFF'
2688      IFLAG=0
2689      IF(ICOMHO.EQ.'RESE'.AND.ICOMH2.EQ.'T2  ')IFLAG=1
2690      IF(IFLAG.EQ.0)THEN
2691        CALL INITMC(IBUGIN)
2692        CALL INITFO(IBUGIN)
2693      ENDIF
2694C
2695      CALL INITHK(IBUGIN)
2696      CALL INITDA(IBUGIN)
2697      CALL INITPC(IBUGIN)
2698CCCCC CALL INITDG(IBUGIN)
2699C     DIAGRAMMATIC GRAPHICS INITIALIZATION  IS NOW DONE (NOV 1983)
2700C     IN INITPC
2701C
2702      IF(IFLAG.EQ.0 .AND. IRSCNT.EQ.0)THEN
2703        CALL INITOD(IBUGIN)
2704      ENDIF
2705C
2706      CALL INITSU(IBUGIN)
2707CCCCC THE FOLLOWING DES. OF EXP. LINE WAS ADDED MAY 1989
2708      CALL INITDE(IBUGIN)
2709      CALL INIT3D(IBUGIN)
2710CCCCC THE FOLLOWING LINE WAS ADDED AUGUST 1990
2711CCCCC CALL INITWI(IBUGIN)
2712C
2713      CALL INITH2(IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP,
2714     1IVALUE,VALUE,NUMNAM,MAXN,MAXCOL,IBUGIN)
2715      CALL INITDB
2716C
2717C               *****************
2718C               **  STEP 90--  **
2719C               **  EXIT       **
2720C               *****************
2721C
2722      IF(IBUGIN.EQ.'ON')THEN
2723        WRITE(ICOUT,999)
2724        CALL DPWRST('XXX','BUG ')
2725        WRITE(ICOUT,9011)
2726 9011   FORMAT('AT THE END       OF MAININ--')
2727        CALL DPWRST('XXX','BUG ')
2728        WRITE(ICOUT,9013)IBUGIN
2729 9013   FORMAT('IBUGIN = ',A4)
2730        CALL DPWRST('XXX','BUG ')
2731      ENDIF
2732C
2733      RETURN
2734      END
2735      SUBROUTINE MAINOD(IBUGOD,IBUGO2,ISUBRO,
2736     1                  ICAPSW,
2737     1                  IFOUND,IERROR)
2738C
2739C     PURPOSE--THIS IS SUBROUTING MAINOD.
2740C              (THE   OD    AT THE END OF    MAINOD   STANDS FOR   OUTPUT DEVICE
2741C              THIS SUBROUTINE SEARCHES FOR AND EXECUTES OUTPUT DEVICE COMMANDS.
2742C              THE OUTPUT DEVICE COMMANDS SEARCHED FOR BY MAINOD ARE AS FOLLOWS-
2743C
2744C                   1) DEVICE ... POWER                  ON/OFF
2745C                   2) DEVICE ... MANUFACTURER           A MANUFACTURER AND MODE
2746C                   3) DEVICE ... CONTINUOUS             ON/OFF
2747C                   4) DEVICE ... COLOR                  ON/OFF
2748C                   5) DEVICE ... PICTURE POINTS         2 NUMBERS
2749C                   6) DEVICE ... UNIT NUMBER            A NUMBER
2750C
2751C                   7) TERMINAL   POWER                  ON/OFF
2752C                   8) TERMINAL   MANUFACTURER           A MANUFACTURER AND MODE
2753C                   8) TERMINAL   CONTINUOUS             ON/OFF
2754C                   9) TERMINAL   COLOR                  ON/OFF
2755C                  10) TERMINAL   PICTURE POINTS         2 NUMBERS
2756C                   6) TERMINAL UNIT NUMBER            A NUMBER
2757C
2758C                  11) POWER                             ON/OFF
2759C                  12) MANUFACTURER                      A MANUFACTURER AND MODE
2760C                  13) CONTINUOUS                        ON/OFF
2761C                  14) COLOR                             ON/OFF
2762C                  15) PICTURE POINTS                    2 NUMBERS
2763C                   16) UNIT NUMBER            A NUMBER
2764C
2765C                  16) DISCRETE                          ON/OFF
2766C                  17) DISCRETE NARROW-WIDTH             ON/OFF
2767C                  18) DISCRETE WIDE-CARRIAGE            ON/OFF
2768C                  19) BATCH                             ON/OFF
2769C
2770C                  20) FILE                              ON/OFF
2771C                  20) CALCOMP                           ON/OFF
2772C                  21) VERSATEC                          ON/OFF
2773C                  22) ZETA                              ON/OFF
2774C
2775C                  22) METAFILE                              ON/OFF
2776C
2777C                  23) HARDCOPY                          ON/OFF AND OPTIONALLY A
2778C                  24) PENPLOTTER                        ON/OFF AND OPTIONALLY A
2779C
2780C     WRITTEN BY--JAMES J. FILLIBEN
2781C                 STATISTICAL ENGINEERING DIVISION
2782C                 INFORMATION TECHNOLOGY LABORATORY
2783C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
2784C                 GAITHERSBURG, MD 20899-8980
2785C                 PHONE--301-975-2855
2786C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
2787C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
2788C     LANGUAGE--ANSI FORTRAN (1977)
2789C     VERSION NUMBER--82.6
2790C     ORIGINAL VERSION--SEPTEMBER 1980.
2791C     UPDATED         --MARCH     1981.
2792C     UPDATED         --SEPTEMBER 1981.
2793C     UPDATED         --NOVEMBER  1981.
2794C     UPDATED         --FEBRUARY  1982.
2795C     UPDATED         --MARCH     1982.
2796C     UPDATED         --MAY       1982.
2797C     UPDATED         --FEBRUARY  1989.  2 OFFSET ARGUMENTS IN CALLS TO DPDEMN
2798C     UPDATED         --FEBRUARY  1989.  ADD CHECKS FOR NEW DEVICES (ALAN)--
2799C                                           GENERAL CGM (OR CGM)
2800C                                           QUIC (OR QMS)
2801C                                           POSTSCRIPT
2802C                                           PCL (OR LASERJET)
2803C                                           DICOMED
2804C     UPDATED         --MARCH     1990.   ADD CHECK FOR X11 DEVICE
2805C     UPDATED         --MAY       1990.   CHECK FOR [HPGL/ZETA/CALC] PEN MAP,
2806C                                         DISTINGUISH BETWEEN ON/OFF AND
2807C                                         OPEN/CLOSE
2808C     UPDATED         --JANUARY   1991.   ADD REGIS TO PEN MAP COMMAND
2809C     UPDATED         --MAY       1991.   ADD TURBO-C/VGA (JJF)
2810C     UPDATED         --JUNE      1991.   ADD X11 TO PEN MAP COMMAND
2811C     UPDATED         --OCTOBER   1991.   ADD "POSTSCRIPT SHOW FONT" COMMAND
2812C     UPDATED         --APRIL     1992.   PRINT PLOT, P, PP
2813C     UPDATED         --MAY       1992.   POSTSCRIPT BLANK PAGE SWITCH
2814C     UPDATED         --JUNE      1992.   ARGUMENT LIST TO DPDEMN
2815C     UPDATED         --AUGUST    1992.   ADD "SHOW COLORS" COMMAND.
2816C     UPDATED         --APRIL     1993.   CHECK FOR CONFLICT WITH
2817C                                         P CONTROL CHART (ALAN)
2818C     UPDATED         --OCTOBER   1993.   BUG FOR DISCRETE ON
2819C     UPDATED         --DECEMBER   1993.  COMMENT OUT   GENERAL
2820C     UPDATED         --MAY        1994.  CHECK CONFLICT BETWEEN REGIS
2821C                                         AND REGION
2822C     UPDATED         --SEPTEMBER  1994.  CHECK CONFLICT BETWEEN DISCR
2823C                                         AND DISCR UNIFORM PROB PLOT
2824C     UPDATED         --APRIL      1995.  CHECK CONFLICT BETWEEN POWER
2825C                                         AND POWER NORMAL AND POWER
2826C                                         LOGNORMAL (PROB PLOT, PPCC
2827C                                         PLOT)
2828C     UPDATED         --OCTOBER    1995.  CHECK CONFLICT BETWEEN GENERAL
2829C                                         AND GENERALIZED EXTREME VALUE
2830C                                         AND GENERALIZED HALF LOGISTIC
2831C                                         (PROB AND PPCC PLOTS)
2832C     UPDATED         --DECEMBER   1995.  CHECK CONFLICT BETWEEN GENERAL
2833C                                         AND GENERALIZED LOGISTIC
2834C     UPDATED         --FEBRUARY   1996.  CHECK CONFLICT BETWEEN GENERAL
2835C                                         AND GENERALIZED EXPONENTIAL
2836C     UPDATED         --JULY       1996.  DEVICE ... FONT COMMAND
2837C     UPDATED         --OCTOBER    1996.  ADD CHECKS FOR NEW DEVICES (ALAN)--
2838C                                           MICROSOFT QUICKWIN
2839C                                           PBM (PORTABLE BIT MAP)
2840C     UPDATED         --JUNE       1998.  NAME CONFLICT WITH POWER MLE
2841C     UPDATED         --JUNE       2000.  ADD CHECKS FOR NEW DEVICES (ALAN)--
2842C                                           OPEN-GL
2843C                                           GD JPEG
2844C                                           GD PNG
2845C                                           GD WBMP
2846C                                           WINDOWS BITMAP
2847C     UPDATED         --MARCH      2002.  ADD CHECKS FOR NEW DEVICES (ALAN)--
2848C                                           SVG
2849C     UPDATED         --SEPTEMBER  2002.  ICAPSW FOR DPDEMN, DPDEPW
2850C     UPDATED         --SEPTEMBER  2007.  IERRST
2851C     UPDATED         --SEPTEMBER  2011.  VIEW PLOT COMMAND
2852C     UPDATED         --OCTOBER    2016.  UPDATES TO VIEW PLOT COMMAND
2853C     UPDATED         --DECEMBER   2018.  DEVICE SCALE
2854C
2855C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
2856C
2857      CHARACTER*4 IOP
2858      CHARACTER*4 ICAPSW
2859C
2860      CHARACTER*4 IBUGOD
2861      CHARACTER*4 IBUGO2
2862      CHARACTER*4 ISUBRO
2863C
2864      CHARACTER*4 IFOUND
2865      CHARACTER*4 IERROR
2866C
2867      INCLUDE 'DPCOPA.INC'
2868C
2869      CHARACTER*4 IFTYPE
2870      CHARACTER*4 ICASE2
2871      CHARACTER*4 ICASE3
2872      CHARACTER*4 ISUBN1
2873      CHARACTER*4 ISUBN2
2874      CHARACTER*4 ISTEPN
2875      CHARACTER*4 ICASEZ
2876C
2877      CHARACTER (LEN=MAXSTR) :: ICANS
2878      CHARACTER (LEN=MAXSTR) :: ISTRIN
2879      CHARACTER (LEN=MAXFNC) :: ICMDTI
2880      CHARACTER (LEN=MAXFNC) :: IFILEZ
2881      CHARACTER (LEN=MAXFNC) :: ITEMP
2882C
2883C-----COMMON----------------------------------------------------------
2884C
2885      INCLUDE 'DPCOHK.INC'
2886      INCLUDE 'DPCOPC.INC'
2887      INCLUDE 'DPCOF2.INC'
2888CCCCC THE FOLLOWING LINE WAS ADDED   MAY 1992 (JJF)
2889      INCLUDE 'DPCODV.INC'
2890      INCLUDE 'DPCOST.INC'
2891      INCLUDE 'DPCOP2.INC'
2892C
2893C-----START POINT-----------------------------------------------------
2894C
2895      I=1
2896      IOP='-999'
2897      ISUBN1='MAIN'
2898      ISUBN2='OD  '
2899      IFOUND='NO'
2900      IERROR='NO'
2901C
2902      IF(IBUGOD.EQ.'ON'.OR.ISUBRO.EQ.'INOD')THEN
2903        WRITE(ICOUT,999)
2904  999   FORMAT(1X)
2905        CALL DPWRST('XXX','BUG ')
2906        WRITE(ICOUT,51)
2907   51   FORMAT('***** AT THE BEGINNING OF MAINOD--')
2908        CALL DPWRST('XXX','BUG ')
2909        WRITE(ICOUT,53)IBUGOD,IBUGO2,ISUBRO
2910   53   FORMAT('IBUGOD,IBUGO2,ISUBRO = ',3(A4,2X),A4)
2911        CALL DPWRST('XXX','BUG ')
2912        WRITE(ICOUT,60)IFOUND,IERROR,ICOM,ICOM2,IPSTBP,NUMARG
2913   60   FORMAT('IFOUND,IERROR,ICOM,ICOM2,IPSTBP,NUMARG = ',
2914     1         5(A4,2X),G15.7)
2915        CALL DPWRST('XXX','BUG ')
2916        DO70I=1,NUMARG
2917          WRITE(ICOUT,71)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I)
2918   71     FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) = ',
2919     1           I8,3(2X,A4),2X,I8,G15.7)
2920          CALL DPWRST('XXX','BUG ')
2921   70   CONTINUE
2922      ENDIF
2923C
2924C               *****************************************************
2925C               **  TREAT THE GENERAL (= DEVICE-INDEPENDENT) CASE  **
2926C               *****************************************************
2927C
2928C     CHECK FOR NAME CONFLICTS WITH "GENERAL"
2929C
2930      IF(NUMARG.GE.2)THEN
2931        IF(IHARG(2).EQ.'PROB')GOTO9000
2932        IF(IHARG(2).EQ.'PPCC')GOTO9000
2933      ELSEIF(NUMARG.GE.1)THEN
2934        IF(IHARG(1).EQ.'JACC')GOTO9000
2935        IF(IHARG(1).EQ.'PARE')GOTO9000
2936        IF(IHARG(1).EQ.'LOGI')GOTO9000
2937        IF(IHARG(1).EQ.'PPCC')GOTO9000
2938        IF(IHARG(1).EQ.'PROB')GOTO9000
2939        IF(IHARG(1).EQ.'GAMM')GOTO9000
2940        IF(IHARG(1).EQ.'EXTR')GOTO9000
2941        IF(IHARG(1).EQ.'HALF')GOTO9000
2942        IF(IHARG(1).EQ.'LOGI')GOTO9000
2943        IF(IHARG(1).EQ.'EXPO')GOTO9000
2944        IF(IHARG(1).EQ.'LAMB')GOTO9000
2945        IF(IHARG(1).EQ.'TRAP')GOTO9000
2946        IF(IHARG(1).EQ.'MCLE')GOTO9000
2947        IF(IHARG(1).EQ.'INVE'.AND.IHARG(2).EQ.'GAUS')GOTO9000
2948        IF(IHARG(1).EQ.'ASYM'.AND.IHARG(2).EQ.'LAPL')GOTO9000
2949        IF(IHARG(1).EQ.'ASYM'.AND.IHARG(2).EQ.'DOUB')GOTO9000
2950        IF(IHARG(1).EQ.'TUKE'.AND.IHARG(2).EQ.'LAMB')GOTO9000
2951        IF(IHARG(1).EQ.'LOGA'.AND.IHARG(2).EQ.'SERI')GOTO9000
2952        IF(IHARG(1).EQ.'NEGA'.AND.IHARG(2).EQ.'BINO')GOTO9000
2953        IF(IHARG(1).EQ.'LOST'.AND.IHARG(2).EQ.'GAME')GOTO9000
2954        IF(IHARG(1).EQ.'TOPP'.AND.IHARG(2).EQ.'LEON')GOTO9000
2955        IF(IHARG(1).EQ.'TOPP'.AND.IHARG(2).EQ.'AND '.AND.
2956     1       IHARG(3).EQ.'LEON')GOTO9000
2957      ENDIF
2958C
2959C     DEVICE PEN MAP CASE
2960C
2961      IF((ICOM.EQ.'HPGL'.AND.IHARG(1).EQ.'MAP')  .OR.
2962     1   (ICOM.EQ.'HPGL'.AND.IHARG(1).EQ.'PEN')  .OR.
2963     1   (ICOM.EQ.'HP-G'.AND.IHARG(1).EQ.'PEN')  .OR.
2964     1   (ICOM.EQ.'HP-G'.AND.IHARG(1).EQ.'MAP')  .OR.
2965     1   (ICOM.EQ.'ZETA'.AND.IHARG(1).EQ.'PEN')  .OR.
2966     1   (ICOM.EQ.'ZETA'.AND.IHARG(1).EQ.'MAP')  .OR.
2967     1   (ICOM.EQ.'CALC'.AND.IHARG(1).EQ.'PEN')  .OR.
2968     1   (ICOM.EQ.'CALC'.AND.IHARG(1).EQ.'MAP')  .OR.
2969     1   (ICOM.EQ.'HPGL'.AND.IHARG(1).EQ.'COLO') .OR.
2970     1   (ICOM.EQ.'HP-G'.AND.IHARG(1).EQ.'COLO') .OR.
2971     1   (ICOM.EQ.'ZETA'.AND.IHARG(1).EQ.'COLO') .OR.
2972     1   (ICOM.EQ.'CALC'.AND.IHARG(1).EQ.'COLO') .OR.
2973     1   (ICOM.EQ.'REGI'.AND.ICOM2.EQ.'S   '.AND.
2974     1    IHARG(1).EQ.'MAP')                     .OR.
2975     1   (ICOM.EQ.'REGI'.AND.ICOM2.EQ.'S   '.AND.
2976     1    IHARG(1).EQ.'PEN')                     .OR.
2977     1   (ICOM.EQ.'REGI'.AND.ICOM2.EQ.'S   '.AND.
2978     1    IHARG(1).EQ.'COLO')                    .OR.
2979     1   (ICOM.EQ.'X11 '.AND.IHARG(1).EQ.'MAP')  .OR.
2980     1   (ICOM.EQ.'X11 '.AND.IHARG(1).EQ.'PEN')  .OR.
2981     1   (ICOM.EQ.'X11 '.AND.IHARG(1).EQ.'COLO'))THEN
2982        CALL DPDEPM(ICOM,IHARG,IHARG2,IARGT,IARG,NUMARG,
2983     1              IBUGO2,ISUBRO,IFOUND,IERROR)
2984        GOTO9000
2985C
2986C     FOLLOWING LINES ADDED OCTOBER, 1991.  ADD "POSTSCRIPT SHOW FONTS" COMMAND
2987C
2988      ELSEIF((ICOM.EQ.'POST'.AND.IHARG(1).EQ.'SHOW') .OR.
2989     1       (ICOM.EQ.'POST'.AND.IHARG(1).EQ.'LIST') .OR.
2990     1       (ICOM.EQ.'POST'.AND.IHARG(1).EQ.'PRIN') .OR.
2991     1       (ICOM.EQ.'POST'.AND.IHARG(1).EQ.'FONT') .OR.
2992     1       (ICOM.EQ.'SHOW' .AND. IHARG(1).EQ.'FONT'))THEN
2993        CALL DPDEFN(ICOM,IHARG,IHARG2,IARGT,IARG,NUMARG,
2994     1              IBUGO2,ISUBRO,IFOUND,IERROR)
2995        GOTO9000
2996C
2997C     SHOW COLORS CASE
2998C
2999      ELSEIF(ICOM.EQ.'SHOW' .AND. IHARG(1).EQ.'COLO')THEN
3000        CALL DPDEPM(ICOM,IHARG,IHARG2,IARGT,IARG,NUMARG,
3001     1              IBUGO2,ISUBRO,IFOUND,IERROR)
3002      GOTO9000
3003C
3004C     GENERAL DEVICE (METAFILE)
3005C
3006      ELSEIF((ICOM.EQ.'GENE' .AND. NUMARG.LT.1) .OR.
3007     1        ICOM.EQ.'CGM ' .OR.
3008     1       (ICOM.EQ.'DEVI'.AND.NUMARG.GE.1.AND.
3009     1        IHARG(1).EQ.'GENE') .OR.
3010     1       (ICOM.EQ.'DEVI'.AND.NUMARG.GE.1.AND.
3011     1        IHARG(1).EQ.'INDE'))THEN
3012        IOP='ON'
3013        IF(NUMARG.GE.1.AND.IHARG(NUMARG).EQ.'OFF')IOP='OFF'
3014        ICOM='DEVI'
3015        ICOM2='CE  '
3016C
3017        ISHIFT=2
3018        CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
3019     1              IBUGO2,IERROR)
3020        IHARG(1)='1   '
3021        IHARG2(1)='    '
3022        IARGT(1)='NUMB'
3023        IARG(1)=1
3024C
3025        IF(IOP.EQ.'ON')THEN
3026          IHARG(2)='MANU'
3027          IHARG2(2)='FACT'
3028          IARGT(2)='WORD'
3029          IHARG(3)='GENE'
3030          IHARG2(3)='RAL '
3031          IARGT(3)='WORD'
3032          NUMARG=3
3033          IF(IHARG(4).EQ.'CODE')NUMARG=4
3034          IF(IHARG(4).EQ.'CGM')NUMARG=4
3035          CALL DPDEMN(IHARG,IHARG2,IARGT,IARG,NUMARG,
3036     1                IPL1NU,IPL1NA,IPL2NU,IPL2NA,
3037     1                IPL1CS,IPL2CS,
3038     1                IDEFMA,IDEFMO,IDEFM2,IDEFM3,
3039     1                IDEFPO,IDEFCN,IDEFDC,IDEFVP,IDEFHP,IDEFUN,
3040     1                NUMDEV,MAXDEV,
3041     1                IDMANU,IDMODE,IDMOD2,IDMOD3,
3042     1                IDPOWE,IDCONT,IDCOLO,IDFONT,IDNVPP,IDNHPP,IDUNIT,
3043     1                IDNVOF,IDNHOF,
3044     1                ICAPSW,ICAPNU,
3045     1                IANS,IWIDTH,IBUGO2,ISUBRO,IFOUND,IERROR)
3046          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
3047        ELSE
3048          IHARG(2)='POWE'
3049          IHARG2(2)='R   '
3050          IARGT(2)='WORD'
3051          IHARG(3)='OFF '
3052          IHARG2(3)='    '
3053          IARGT(3)='WORD'
3054          NUMARG=3
3055          CALL DPDEPW(IHARG,IHARG2,IARGT,IARG,NUMARG,
3056     1                IPL1NU,IPL1NA,IPL2NU,IPL2NA,
3057     1                IDEFPO,
3058     1                NUMDEV,MAXDEV,
3059     1                IDMANU,IDMODE,IDMOD2,IDMOD3,
3060     1                IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
3061     1                IDNVOF,IDNHOF,
3062     1                ICAPSW,ICAPNU,
3063     1                IANS,IWIDTH,IBUGO2,ISUBRO,IFOUND,IERROR)
3064          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
3065        ENDIF
3066        GOTO1099
3067C
3068      ELSE
3069        GOTO1099
3070      ENDIF
3071C
3072 1099 CONTINUE
3073C
3074CCCCC THE FOLLOWING SECTION  WAS ADDED   APRIL 1992  (JJF)
3075C               ****************************************
3076C               **  TREAT THE P CASE                  **
3077C               **  TREAT THE PP CASE                 **
3078C               **  TREAT THE PRINT PLOT CASE         **
3079C               ****************************************
3080C
3081      ISTEPN='2'
3082      IF(IBUGOD.EQ.'ON'.OR.ISUBRO.EQ.'INOD')
3083     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3084C
3085CCCCC APRIL 1993    CHECK FOR CONFLICT WITH P CHART
3086CCCCC APRIL 1993    AND P CONTROL CHART (ALAN)
3087      IF(ICOM.EQ.'P'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'CONT')GOTO9000
3088      IF(ICOM.EQ.'P'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'CHAR')GOTO9000
3089C
3090      IF(ICOM.EQ.'P' .OR. ICOM.EQ.'PP' .OR.
3091     1  (NUMARG.GE.1 .AND. ICOM.EQ.'PRIN' .AND.
3092     1   IHARG(1).EQ.'PLOT' .AND. IHARG2(1).EQ.'    '))THEN
3093C
3094        IFOUND='YES'
3095        IF(IPL2CS.NE.'CLOS')THEN
3096           CALL DPDEV(3,'CLOS','POST',ICAPSW,IBUGOD,ISUBRO,IERROR)
3097           IF(IERROR.EQ.'YES')THEN
3098              WRITE(ICOUT,999)
3099              CALL DPWRST('XXX','BUG ')
3100              WRITE(ICOUT,7011)
3101 7011         FORMAT('***** ERROR IN MAINOD')
3102              CALL DPWRST('XXX','BUG ')
3103              WRITE(ICOUT,7012)
3104 7012         FORMAT('      IN ATTEMPTING TO CLOSE DEVICE 3')
3105              CALL DPWRST('XXX','BUG ')
3106              GOTO9000
3107           ENDIF
3108        ENDIF
3109        IFTYPE='POST'
3110        CALL PRINFI(IPL2NA,IFTYPE,IBUGO2,ISUBRO,IERROR)
3111        GOTO9000
3112C
3113      ENDIF
3114C
3115CCCCC THE FOLLOWING SECTION  WAS ADDED   SEPTEMBER 2011
3116C               ****************************************
3117C               **  TREAT THE PSVIEW CASE             **
3118C               **  (VIEWS DPPL2F.DAT FILE)           **
3119C               ****************************************
3120C
3121      IF(ICOM.EQ.'PSVI' .OR.
3122     1  (NUMARG.EQ.0 .AND. ICOM.EQ.'SHOW'))THEN
3123        IFOUND='YES'
3124C
3125C       VIEW DEVICE 3 OUTPUT
3126C
3127        IF(NUMARG.LE.0)THEN
3128          IF(IPL2CS.NE.'CLOS')THEN
3129             CALL DPDEV(3,'CLOS','POST',ICAPSW,IBUGOD,ISUBRO,IERROR)
3130             IF(IERROR.EQ.'YES')THEN
3131               WRITE(ICOUT,999)
3132               CALL DPWRST('XXX','BUG ')
3133               WRITE(ICOUT,7011)
3134               CALL DPWRST('XXX','BUG ')
3135               WRITE(ICOUT,7012)
3136               CALL DPWRST('XXX','BUG ')
3137               GOTO9000
3138             ENDIF
3139          ENDIF
3140          ICASE3='IPL2'
3141          CALL VIEWFI(IPL2NA,ICASE3,IBUGO2,ISUBRO,IERROR)
3142          GOTO9000
3143        ELSEIF((IHARG(1).LE.'DEVI' .AND. IHARG(2).EQ.'2') .OR.
3144     1         (IHARG(1).EQ.'DPPL' .AND. IHARG2(1)(1:2).EQ.'1F') .OR.
3145     1         (IHARG(1).EQ.'IPL1' .AND. IHARG2(1).EQ.'NA  '))THEN
3146C
3147C       VIEW DEVICE 2 OUTPUT.  SET PSVIEW CLOSE FILE COMMAND SPECIFIES
3148C       WHETHER USER WANTS TO CLOSE FILE OR NOT.
3149C
3150          IF(IPSVCL.EQ.'ON')THEN
3151            IF(IPL1CS.NE.'CLOS')THEN
3152              CALL DPDEV(2,'CLOS','POST',ICAPSW,IBUGOD,ISUBRO,IERROR)
3153              IF(IERROR.EQ.'YES')THEN
3154                WRITE(ICOUT,999)
3155                CALL DPWRST('XXX','BUG ')
3156                WRITE(ICOUT,7011)
3157                CALL DPWRST('XXX','BUG ')
3158                WRITE(ICOUT,7014)
3159 7014           FORMAT('      IN ATTEMPTING TO CLOSE DEVICE 2')
3160                CALL DPWRST('XXX','BUG ')
3161                GOTO9000
3162              ELSE
3163                IF(IFEEDB.EQ.'ON')THEN
3164                  WRITE(ICOUT,999)
3165                  CALL DPWRST('XXX','BUG ')
3166                  WRITE(ICOUT,7016)
3167 7016             FORMAT('      DEVICE 2 OUTPUT FILE HAS BEEN CLOSED.')
3168                  CALL DPWRST('XXX','BUG ')
3169                ENDIF
3170              ENDIF
3171            ENDIF
3172          ELSE
3173            IF(IFEEDB.EQ.'ON')THEN
3174              WRITE(ICOUT,999)
3175              CALL DPWRST('XXX','BUG ')
3176              WRITE(ICOUT,7018)
3177 7018         FORMAT('      DEVICE 2 OUTPUT FILE HAS NOT BEEN ',
3178     1               'CLOSED.')
3179              CALL DPWRST('XXX','BUG ')
3180              WRITE(ICOUT,7019)
3181 7019         FORMAT('      THE LAST PLOT MAY NOT BE COMPLETE.')
3182              CALL DPWRST('XXX','BUG ')
3183            ENDIF
3184          ENDIF
3185          ICASE3='IPL1'
3186          CALL VIEWFI(IPL1NA,ICASE3,IBUGO2,ISUBRO,IERROR)
3187          GOTO9000
3188        ELSEIF(NUMARG.GE.1)THEN
3189C
3190C         ARBITRARY FILE NAME
3191C
3192          IWORD=2
3193          MAXTMP=80
3194          ICASEZ='NULL'
3195          ICMDTI='THE POSTSCRIPT FILE NAME FOR THE PSVIEW COMMAND = '
3196          CALL DPEXFN(IANS,IANSLC,ICANS,MAXTMP,IWIDTH,NUMARG,
3197     1                ISTRIN,IWORD,ICMDTI,ITEMP,
3198     1                ICASEZ,IFILEZ,NCFILE,
3199     1                IBUGO2,ISUBRO,IFOUND,IERROR)
3200          IF(NCFILE.LE.80)THEN
3201            ICASE3='FILE'
3202            CALL VIEWFI(ISTRIN,ICASE3,IBUGO2,ISUBRO,IERROR)
3203          ELSE
3204            WRITE(ICOUT,999)
3205            CALL DPWRST('XXX','BUG ')
3206            WRITE(ICOUT,7013)
3207 7013       FORMAT('      THE SPECIFIED FILE NAME HAS MORE THAN 80 ',
3208     1             'CHARACTERS.')
3209            IERROR='YES'
3210          ENDIF
3211          GOTO9000
3212        ENDIF
3213      ENDIF
3214C
3215C               ***********************************
3216C               **  PRE-TREAT THE TERMINAL CASE  **
3217C               ***********************************
3218C
3219      IF(ICOM.EQ.'TERM'.AND.IHARG(1).EQ.'CHAR')GOTO9000
3220      IF(ICOM.EQ.'TERM')THEN
3221        ISHIFT=1
3222        CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
3223     1              IBUGO2,IERROR)
3224        IHARG(1)='1   '
3225        IHARG2(1)='    '
3226        IARGT(1)='NUMB'
3227        IARG(1)=1
3228      ENDIF
3229C
3230C               ************************************************
3231C               **  TREAT THE DEVICE ... POWER CASE           **
3232C               **  TREAT THE DEVICE ... CONTINUOUS CASE      **
3233C               **  TREAT THE DEVICE ... COLOR      CASE      **
3234C               **  TREAT THE DEVICE ... PICTURE POINTS CASE  **
3235C               **  TREAT THE DEVICE ... UNIT        CASE     **
3236C               **  TREAT THE DEVICE ... FONT       CASE      **
3237C               **  TREAT THE DEVICE ... SCALE      CASE      **
3238C               **  TREAT THE DEVICE ...  (MANUFACTURER) CASE **
3239C               ************************************************
3240C
3241      IF(ICOM.EQ.'DEVI' .OR. ICOM.EQ.'TERM')THEN
3242        CALL DPDEPW(IHARG,IHARG2,IARGT,IARG,NUMARG,
3243     1              IPL1NU,IPL1NA,
3244     1              IPL2NU,IPL2NA,
3245     1              IDEFPO,
3246     1              NUMDEV,MAXDEV,
3247     1              IDMANU,IDMODE,IDMOD2,IDMOD3,
3248     1              IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
3249     1              IDNVOF,IDNHOF,
3250     1              ICAPSW,ICAPNU,
3251     1              IANS,IWIDTH,IBUGO2,ISUBRO,IFOUND,IERROR)
3252        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
3253C
3254        CALL DPDECN(IHARG,IARGT,IARG,NUMARG,
3255     1              IDEFCN,
3256     1              NUMDEV,MAXDEV,
3257     1              IDMANU,IDMODE,IDMOD2,IDMOD3,
3258     1              IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
3259     1              IFOUND,IERROR)
3260        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
3261C
3262        CALL DPDECL(IHARG,IARGT,IARG,NUMARG,
3263     1              IDEFDC,
3264     1              NUMDEV,MAXDEV,
3265     1              IDMANU,IDMODE,IDMOD2,IDMOD3,
3266     1              IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
3267     1              IFOUND,IERROR)
3268        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
3269C
3270        CALL DPDEPP(IHARG,IARGT,IARG,NUMARG,
3271     1              IDEFVP,IDEFHP,
3272     1              NUMDEV,MAXDEV,
3273     1              IDMANU,IDMODE,IDMOD2,IDMOD3,
3274     1              IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
3275     1              IFOUND,IERROR)
3276        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
3277C
3278        CALL DPDEUN(IHARG,IARGT,IARG,NUMARG,
3279     1              IDEFUN,
3280     1              NUMDEV,MAXDEV,
3281     1              IDMANU,IDMODE,IDMOD2,IDMOD3,
3282     1              IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
3283     1              IFOUND,IERROR)
3284        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
3285C
3286        CALL DPDEFT(IHARG,IARGT,IARG,NUMARG,
3287     1              IDEFFN,NUMDEV,MAXDEV,
3288     1              IDMANU,IDMODE,IDMOD2,IDMOD3,IDPOWE,
3289     1              IDCONT,IDCOLO,IDFONT,IDNVPP,IDNHPP,IDUNIT,
3290     1              IFOUND,IERROR)
3291        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
3292C
3293        CALL DPDESC(IHARG,IARGT,IARG,ARG,NUMARG,
3294     1              NUMDEV,MAXDEV,
3295     1              IDMANU,IDMODE,IDMOD2,IDMOD3,IDPOWE,
3296     1              IDCONT,IDCOLO,IDFONT,IDNVPP,IDNHPP,IDUNIT,
3297     1              PDSCAL,
3298     1              IFOUND,IERROR)
3299        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
3300C
3301        CALL DPDEMN(IHARG,IHARG2,IARGT,IARG,NUMARG,
3302     1              IPL1NU,IPL1NA,
3303     1              IPL2NU,IPL2NA,
3304     1              IPL1CS,IPL2CS,
3305     1              IDEFMA,IDEFMO,IDEFM2,IDEFM3,
3306     1              IDEFPO,IDEFCN,IDEFDC,IDEFVP,IDEFHP,IDEFUN,
3307     1              NUMDEV,MAXDEV,
3308     1              IDMANU,IDMODE,IDMOD2,IDMOD3,
3309     1              IDPOWE,IDCONT,IDCOLO,IDFONT,IDNVPP,IDNHPP,IDUNIT,
3310     1              IDNVOF,IDNHOF,
3311     1              ICAPSW,ICAPNU,
3312     1              IANS,IWIDTH,IBUGO2,ISUBRO,IFOUND,IERROR)
3313        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
3314      ENDIF
3315C
3316CCCCC THE FOLLOWING SECTION WAS INSERTED BY ALAN.  FEBRUARY 1989
3317CCCCC MAY, 1990. DISTINGUISH BETWEEN ON/OFF AND OPEN/CLOSE
3318C               *****************************************************
3319C               **  TREAT THE DEVICE ... ON/OFF (OR OPEN/CLOSE) CASE*
3320C               *****************************************************
3321C
3322      IF(NUMARG.GE.1)THEN
3323        IF((ICOM.EQ.'DEVI'.OR.ICOM.EQ.'TERM').AND.NUMARG.GE.1.AND.
3324     1     IHARG(NUMARG).EQ.'OFF')THEN
3325          IOP='OFF'
3326        ELSEIF((ICOM.EQ.'DEVI'.OR.ICOM.EQ.'TERM').AND.NUMARG.GE.1.AND.
3327     1     IHARG(NUMARG).EQ.'CLOS')THEN
3328          IOP='CLOS'
3329        ELSEIF((ICOM.EQ.'DEVI'.OR.ICOM.EQ.'TERM').AND.NUMARG.GE.1.AND.
3330     1     IHARG(NUMARG).EQ.'ON')THEN
3331          IOP='ON'
3332        ELSEIF((ICOM.EQ.'DEVI'.OR.ICOM.EQ.'TERM').AND.NUMARG.GE.1.AND.
3333     1     IHARG(NUMARG).EQ.'OPEN')THEN
3334          IOP='OPEN'
3335        ELSE
3336          GOTO1799
3337        ENDIF
3338C
3339        IF(NUMARG.LE.1)THEN
3340          ISHIFT=1
3341          CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
3342     1                IBUGO2,IERROR)
3343          IHARG(1)='1   '
3344          IHARG2(1)='    '
3345          IARGT(1)='NUMB'
3346          IARG(1)=1
3347        ELSE
3348          ISHIFT=1
3349          CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
3350     1                IBUGO2,IERROR)
3351          IHARG(1)=IHARG(2)
3352          IHARG2(1)=IHARG2(2)
3353          IARGT(1)=IARGT(2)
3354          IARG(1)=IARG(2)
3355        ENDIF
3356C
3357        IHARG(2)='POWE'
3358        IHARG2(2)='ER  '
3359        IARGT(2)='WORD'
3360        IHARG(3)=IOP
3361        IHARG2(3)='    '
3362        IARGT(3)='WORD'
3363        NUMARG=3
3364        CALL DPDEPW(IHARG,IHARG2,IARGT,IARG,NUMARG,
3365     1              IPL1NU,IPL1NA,
3366     1              IPL2NU,IPL2NA,
3367     1              IDEFPO,
3368     1              NUMDEV,MAXDEV,
3369     1              IDMANU,IDMODE,IDMOD2,IDMOD3,
3370     1              IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
3371     1              IDNVOF,IDNHOF,
3372     1              ICAPSW,ICAPNU,
3373     1              IANS,IWIDTH,IBUGO2,ISUBRO,IFOUND,IERROR)
3374        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
3375C
3376      ENDIF
3377C
3378 1799 CONTINUE
3379C
3380C               ****************************
3381C               **  TREAT THE POWER CASE  **
3382C               ****************************
3383C
3384CCCCC MAY 1995.  CHECK NAME CONFLICTS
3385      IF(ICOM.EQ.'POWE'.AND.IHARG(1).EQ.'NORM')GOTO9000
3386      IF(ICOM.EQ.'POWE'.AND.IHARG(1).EQ.'LOGN')GOTO9000
3387      IF(ICOM.EQ.'POWE'.AND.IHARG(1).EQ.'EXPO')GOTO9000
3388      IF(ICOM.EQ.'POWE'.AND.IHARG(1).EQ.'LOG ')GOTO9000
3389      IF(ICOM.EQ.'POWE'.AND.IHARG(1).EQ.'FUNC')GOTO9000
3390      IF(ICOM.EQ.'POWE'.AND.IHARG(1).EQ.'PROB')GOTO9000
3391      IF(ICOM.EQ.'POWE'.AND.IHARG(1).EQ.'PPCC')GOTO9000
3392      IF(ICOM.EQ.'POWE'.AND.IHARG(1).EQ.'MAXI')GOTO9000
3393      IF(ICOM.EQ.'POWE'.AND.IHARG(1).EQ.'MLE ')GOTO9000
3394      IF(ICOM.EQ.'POWE'.AND.IHARG(1).EQ.'KS  ')GOTO9000
3395      IF(ICOM.EQ.'POWE'.AND.IHARG(1).EQ.'KOLM')GOTO9000
3396      IF(ICOM.EQ.'POWE'.AND.IHARG(1).EQ.'LAW ')GOTO9000
3397      IF(ICOM.EQ.'POWE'.AND.IHARG(1).EQ.'CHI ')GOTO9000
3398      IF(ICOM.EQ.'POWE'.AND.IHARG(1).EQ.'CHIS')GOTO9000
3399C
3400      IF(ICOM.EQ.'POWE')THEN
3401        ISHIFT=2
3402        CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
3403     1              IBUGO2,IERROR)
3404        IHARG(1)='1   '
3405        IHARG2(1)='    '
3406        IARGT(1)='NUMB'
3407        IARG(1)=1
3408        IHARG(2)=ICOM
3409        IHARG2(2)=ICOM2
3410        IARGT(2)='WORD'
3411        CALL DPDEPW(IHARG,IHARG2,IARGT,IARG,NUMARG,
3412     1              IPL1NU,IPL1NA,IPL2NU,IPL2NA,
3413     1              IDEFPO,
3414     1              NUMDEV,MAXDEV,
3415     1              IDMANU,IDMODE,IDMOD2,IDMOD3,
3416     1              IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
3417     1              IDNVOF,IDNHOF,
3418     1              ICAPSW,ICAPNU,
3419     1              IANS,IWIDTH,IBUGO2,ISUBRO,IFOUND,IERROR)
3420        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
3421      ENDIF
3422C
3423C               *********************************
3424C               **  TREAT THE CONTINUITY CASE  **
3425C               *********************************
3426C
3427      IF((ICOM.EQ.'CONT'.AND.ICOM2.EQ.'INUO') .OR.
3428     1   (ICOM.EQ.'CONT'.AND.ICOM2.EQ.'INUI'))THEN
3429        ISHIFT=2
3430        CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
3431     1              IBUGO2,IERROR)
3432        IHARG(1)='1   '
3433        IHARG2(1)='    '
3434        IARGT(1)='NUMB'
3435        IARG(1)=1
3436        IHARG(2)=ICOM
3437        IHARG2(2)=ICOM2
3438        IARGT(2)='WORD'
3439        CALL DPDECN(IHARG,IARGT,IARG,NUMARG,
3440     1              IDEFCN,
3441     1              NUMDEV,MAXDEV,
3442     1              IDMANU,IDMODE,IDMOD2,IDMOD3,
3443     1              IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
3444     1              IFOUND,IERROR)
3445        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
3446      ENDIF
3447C
3448C               ****************************
3449C               **  TREAT THE COLOR CASE  **
3450C               ****************************
3451C
3452      IF(ICOM.EQ.'COLO')THEN
3453        ISHIFT=2
3454        CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
3455     1              IBUGO2,IERROR)
3456        IHARG(1)='1   '
3457        IHARG2(1)='    '
3458        IARGT(1)='NUMB'
3459        IARG(1)=1
3460        IHARG(2)=ICOM
3461        IHARG2(2)=ICOM2
3462        IARGT(2)='WORD'
3463        CALL DPDECL(IHARG,IARGT,IARG,NUMARG,
3464     1              IDEFDC,
3465     1              NUMDEV,MAXDEV,
3466     1              IDMANU,IDMODE,IDMOD2,IDMOD3,
3467     1              IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
3468     1              IFOUND,IERROR)
3469        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
3470      ENDIF
3471C
3472C               *************************************
3473C               **  TREAT THE PICTURE POINTS CASE  **
3474C               *************************************
3475C
3476      IF(ICOM.EQ.'PICT' .OR. ICOM.EQ.'PP')THEN
3477        ISHIFT=2
3478        IF(ICOM.EQ.'PP')ISHIFT=3
3479        CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
3480     1              IBUGO2,IERROR)
3481        IHARG(1)='1   '
3482        IHARG2(1)='    '
3483        IARGT(1)='NUMB'
3484        IARG(1)=1
3485        IHARG(2)='PICT'
3486        IHARG2(2)='TURE'
3487        IARGT(2)='WORD'
3488        IF(ICOM.EQ.'NE')THEN
3489          IHARG(3)='POIN'
3490          IHARG2(3)='TS  '
3491          IARGT(3)='WORD'
3492        ENDIF
3493        CALL DPDEPP(IHARG,IARGT,IARG,NUMARG,
3494     1              IDEFVP,IDEFHP,
3495     1              NUMDEV,MAXDEV,
3496     1              IDMANU,IDMODE,IDMOD2,IDMOD3,
3497     1              IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
3498     1              IFOUND,IERROR)
3499        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
3500      ENDIF
3501C
3502C               *************************************
3503C               **  TREAT THE UNIT NUMBER CASE  **
3504C               *************************************
3505C
3506      IF(ICOM.EQ.'UNIT')THEN
3507        ISHIFT=2
3508        CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
3509     1              IBUGO2,IERROR)
3510        IHARG(1)='1   '
3511        IHARG2(1)='    '
3512        IARGT(1)='NUMB'
3513        IARG(1)=1
3514        IHARG(2)=ICOM
3515        IHARG2(2)=ICOM2
3516        IARGT(2)='WORD'
3517        CALL DPDEUN(IHARG,IARGT,IARG,NUMARG,
3518     1              IDEFUN,
3519     1              NUMDEV,MAXDEV,
3520     1              IDMANU,IDMODE,IDMOD2,IDMOD3,
3521     1              IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
3522     1              IFOUND,IERROR)
3523        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
3524      ENDIF
3525C
3526C               *********************************************
3527C               **  TREAT THE EXPLICIT MANUFACTURER CASE   **
3528C               **  (FOR A SUBSET OF AVAILABLE TERMINALS)  **
3529C               *********************************************
3530C
3531      IF(ICOM.EQ.'TEKT'.AND.IHARG(1).NE.'META')GOTO3600
3532      IF(ICOM.EQ.'HEWL')GOTO3600
3533      IF(ICOM.EQ.'HP')GOTO3600
3534      IF(ICOM.EQ.'HPGL')GOTO3600
3535      IF(ICOM.EQ.'RAMT')GOTO3600
3536      IF(ICOM.EQ.'TELE')GOTO3600
3537      IF(ICOM.EQ.'VT')GOTO3600
3538      IF(ICOM.EQ.'DEC')GOTO3600
3539CCCCC MAY, 1994.  CHECK FOR CONFLICT WITH REGION COMMAND.
3540CCCCC IF(ICOM.EQ.'REGI')GOTO3600
3541      IF(ICOM.EQ.'REGI'.AND.ICOM2.EQ.'S   ')GOTO3600
3542      IF(ICOM.EQ.'RAMT')GOTO3600
3543CCCCC THE FOLLOWING 5 LINES WERE ADDED BY ALAN.  FEBRUARY 1989
3544      IF(ICOM.EQ.'SUN')GOTO3600
3545      IF(ICOM.EQ.'PCL')GOTO3600
3546      IF(ICOM.EQ.'POST')GOTO3600
3547CCCCC MARCH 1995.  ADD FOLLOWING 3 LINES
3548      IF(ICOM.EQ.'ENCA')THEN
3549        IF(IHARG(1).EQ.'POST'.OR.IHARG(1).EQ.'PS')THEN
3550          ICOM='POST'
3551          IHARG(1)='ENCA'
3552        ELSE
3553          ISHIFT=1
3554          CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
3555     1    IBUGO2,IERROR)
3556          ICOM='POST'
3557          IHARG(1)='ENCA'
3558          IHARG2(1)='    '
3559          IARGT(1)='WORD'
3560        ENDIF
3561        GOTO3600
3562      ENDIF
3563CCCCC OCTOBER 1996.  ADD FOLLOWING LINES
3564      IF(ICOM.EQ.'DISP')THEN
3565        IF(IHARG(1).EQ.'POST'.OR.IHARG(1).EQ.'PS')THEN
3566          ICOM='POST'
3567          IHARG(1)='DISP'
3568          GOTO3600
3569        ENDIF
3570      ENDIF
3571C
3572      IF(ICOM.EQ.'PS  ')THEN
3573        ICOM='POST'
3574        GOTO3600
3575      ENDIF
3576      IF(ICOM.EQ.'EPS ')THEN
3577        IF(IHARG(1).EQ.'POST')THEN
3578          ICOM='POST'
3579          IHARG(1)='ENCA'
3580        ELSE
3581          ISHIFT=1
3582          CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
3583     1    IBUGO2,IERROR)
3584          ICOM='POST'
3585          IHARG(1)='ENCA'
3586          IHARG2(1)='    '
3587          IARGT(1)='WORD'
3588        ENDIF
3589        GOTO3600
3590      ENDIF
3591C
3592      IF(ICOM.EQ.'DICO')GOTO3600
3593      IF((ICOM.EQ.'QUIC'.AND.ICOM2.EQ.'KWIN').OR.
3594     1 (ICOM.EQ.'QUIC'.AND.ICOM2.EQ.'K-WI').OR.
3595     1 (ICOM.EQ.'MS'.AND.IHARG(1).EQ.'WIND').OR.
3596     1 (ICOM.EQ.'MICR'.AND.IHARG(1).EQ.'WIND'))THEN
3597        ICOM='QWIN'
3598        IHARG(1)='    '
3599        IARGT(1)='WORD'
3600        GOTO3600
3601      ENDIF
3602      IF(ICOM.EQ.'QUIC')GOTO3600
3603CCCCC FOLLOWING LINE ADDED MARCH 1990 BY ALAN.
3604      IF(ICOM.EQ.'X11 ')GOTO3600
3605CCCCC FOLLOWING 2 LINES ADDED FOR CONFLICT WITH DISCRET UNIFORM
3606CCCCC PROBABILITY PLOT.   SEPTEMBER 1994.
3607      IF(NUMARG.GE.2.AND.ICOM.EQ.'DISC'.AND.IHARG(1).EQ.'UNIF')GOTO9000
3608      IF(NUMARG.GE.2.AND.ICOM.EQ.'DISC'.AND.IHARG(1).EQ.'PROB')GOTO9000
3609      IF(NUMARG.GE.2.AND.ICOM.EQ.'DISC'.AND.IHARG(1).EQ.'ARCS')GOTO9000
3610      IF(NUMARG.GE.2.AND.ICOM.EQ.'DISC'.AND.IHARG(1).EQ.'WEIB')GOTO9000
3611      IF(NUMARG.GE.2.AND.ICOM.EQ.'DISC'.AND.IHARG(1).EQ.'CONT'.AND.
3612     1   IHARG(2).EQ.'PLOT')GOTO9000
3613      IF(ICOM.EQ.'DISC')GOTO3600
3614CCCCC NOVEMBER 2008: CHECK FOR CONFLICT WITH "BATCH STRIP PLOT"
3615      IF(NUMARG.GE.2.AND.ICOM.EQ.'BATC'.AND.IHARG(1).EQ.'STRI'.AND.
3616     1   IHARG(2).EQ.'PLOT')GOTO9000
3617      IF(NUMARG.GE.3.AND.ICOM.EQ.'BATC'.AND.IHARG(1).EQ.'MULT'.AND.
3618     1   IHARG(2).EQ.'STRI'.AND.IHARG(3).EQ.'PLOT')GOTO9000
3619      IF(ICOM.EQ.'BATC')GOTO3600
3620CCCCC SEPTEMBER 1997.  CHECK FOR CONFLICT WITH ANDERSON DARLING TEST
3621CCCCC IF(ICOM.EQ.'ANDE')GOTO3600
3622      IF(ICOM.EQ.'ANDE')THEN
3623        IF(NUMARG.GE.1.AND.IHARG(1).EQ.'DARL')GOTO9000
3624        IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')GOTO9000
3625        IF(NUMARG.GE.1.AND.IHARG(1).EQ.'NORM')GOTO9000
3626        IF(NUMARG.GE.1.AND.IHARG(1).EQ.'WEIB')GOTO9000
3627        IF(NUMARG.GE.1.AND.IHARG(1).EQ.'EXPO')GOTO9000
3628        IF(NUMARG.GE.1.AND.IHARG(1).EQ.'LOGI')GOTO9000
3629        IF(NUMARG.GE.1.AND.IHARG(1).EQ.'EXPO')GOTO9000
3630        GOTO3600
3631      ENDIF
3632      IF(ICOM.EQ.'AJ')GOTO3600
3633      IF(ICOM.EQ.'HAZE')GOTO3600
3634      IF(ICOM.EQ.'OMRO')GOTO3600
3635      IF(ICOM.EQ.'TERM'.AND.ICOM2.EQ.'INET')GOTO3600
3636      IF(ICOM.EQ.'TEXA')GOTO3600
3637      IF(ICOM.EQ.'TI')GOTO3600
3638CCCCC THE FOLLOWING 4 LINES WERE ADDED MAY 1991 (JJF)
3639
3640      IF(ICOM.EQ.'TURB')GOTO3600
3641      IF(ICOM.EQ.'TC')GOTO3600
3642      IF(ICOM.EQ.'VGA')GOTO3600
3643      IF(ICOM.EQ.'EGA')GOTO3600
3644      IF(ICOM.EQ.'LAHE ')THEN
3645        IF(NUMARG.GE.1.AND.IHARG(1).EQ.'INTE')THEN
3646          ICOM='INTE'
3647          IHARG(1)='    '
3648          NUMARG=0
3649        ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'WINT')THEN
3650          ICOM='WINT'
3651          IHARG(1)='    '
3652          NUMARG=0
3653        ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'WIN '.AND.
3654     1         IHARG(2).EQ.'INTE')THEN
3655          ICOM='WINT'
3656          IHARG(1)='    '
3657          IHARG(2)='    '
3658          NUMARG=0
3659        ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'WIND'.AND.
3660     1         IHARG(2).EQ.'INTE')THEN
3661          ICOM='WINT'
3662          IHARG(1)='    '
3663          IHARG(2)='    '
3664          NUMARG=0
3665        ELSE
3666          ISHIFT=1
3667          CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
3668     1    IBUGO2,IERROR)
3669          ICOM='POST'
3670          IHARG(1)='ENCA'
3671          IHARG2(1)='    '
3672          IARGT(1)='WORD'
3673        ENDIF
3674        GOTO3600
3675      ENDIF
3676C
3677      IF(ICOM.EQ.'GKS ')GOTO3600
3678      IF(ICOM.EQ.'GD  ')GOTO3600
3679      IF(ICOM.EQ.'SVG ')GOTO3600
3680      IF(ICOM.EQ.'OPEN'.AND.ICOM2.EQ.'GL  ')THEN
3681          ICOM='OPGL'
3682          GOTO3600
3683      ENDIF
3684      IF(ICOM.EQ.'OPEN'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'GL  ')THEN
3685          ICOM='OPGL'
3686          ISHIFT=1
3687          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
3688     1                IBUGO2,IERROR)
3689          GOTO3600
3690      ENDIF
3691C
3692      GOTO3699
3693C
3694 3600 CONTINUE
3695C
3696      ISHIFT=2
3697      CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
3698     1IBUGO2,IERROR)
3699      IHARG(1)='1   '
3700      IHARG2(1)='    '
3701      IARGT(1)='NUMB'
3702      IARG(1)=1
3703      IHARG(2)=ICOM
3704      IHARG2(2)=ICOM2
3705      IARGT(2)='WORD'
3706CCCCC OCTOBER 1993.  FIX BUG WHERE DISCRETE ON, BATCH ON ACT
3707CCCCC LIKE DISCRETE OFF, ETC.  STRIP OFF ON ARGUMENT.
3708      IF(IHARG(2).EQ.'DISC'.OR.IHARG(2).EQ.'BATC')THEN
3709        IF(NUMARG.GE.3.AND.IHARG(NUMARG).EQ.'ON')THEN
3710          IHARG(NUMARG)='    '
3711          NUMARG=NUMARG-1
3712        ENDIF
3713      ENDIF
3714CCCCC END CHANGE
3715      CALL DPDEMN(IHARG,IHARG2,IARGT,IARG,NUMARG,
3716     1IPL1NU,IPL1NA,
3717     1IPL2NU,IPL2NA,
3718     1IPL1CS,IPL2CS,
3719     1IDEFMA,IDEFMO,IDEFM2,IDEFM3,
3720     1IDEFPO,IDEFCN,IDEFDC,IDEFVP,IDEFHP,IDEFUN,
3721     1NUMDEV,MAXDEV,
3722     1IDMANU,IDMODE,IDMOD2,IDMOD3,
3723     1IDPOWE,IDCONT,IDCOLO,IDFONT,IDNVPP,IDNHPP,IDUNIT,
3724     1IDNVOF,IDNHOF,
3725     1ICAPSW,ICAPNU,
3726     1IANS,IWIDTH,IBUGO2,ISUBRO,IFOUND,IERROR)
3727      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
3728C
3729 3699 CONTINUE
3730C
3731C               *********************************************
3732C               **  TREAT THE DISCRETE CASE                **
3733C               **  TREAT THE DISCRETE NARROW-WIDTH CASE   **
3734C               **  TREAT THE DISCRETE WIDE-CARRIAGE CASE  **
3735C               **  TREAT THE BATCH    CASE                **
3736C               *********************************************
3737C
3738      IF(ICOM.EQ.'DISC')GOTO4100
3739      IF(ICOM.EQ.'BATC')GOTO4100
3740      GOTO4199
3741C
3742 4100 CONTINUE
3743      ISHIFT=3
3744      CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
3745     1IBUGO2,IERROR)
3746      IHARG(1)='1   '
3747      IHARG2(1)='    '
3748      IARGT(1)='NUMB'
3749      IARG(1)=1
3750      IHARG(2)='MANU'
3751      IHARG2(2)='FACT'
3752      IARGT(2)='WORD'
3753      IHARG(3)=ICOM
3754      IHARG2(3)=ICOM2
3755      IARGT(3)='WORD'
3756CCCCC OCTOBER 1993.  FIX BUG WHERE DISCRETE ON, BATCH ON ACT
3757CCCCC LIKE DISCRETE OFF, ETC.  STRIP OFF ON ARGUMENT.
3758      IF(IHARG(2).EQ.'DISC'.OR.IHARG(2).EQ.'BATC')THEN
3759        IF(NUMARG.GE.3.AND.IHARG(NUMARG).EQ.'ON')THEN
3760          IHARG(NUMARG)='    '
3761          NUMARG=NUMARG-1
3762        ENDIF
3763      ENDIF
3764CCCCC END CHANGE
3765      CALL DPDEMN(IHARG,IHARG2,IARGT,IARG,NUMARG,
3766     1IPL1NU,IPL1NA,
3767     1IPL2NU,IPL2NA,
3768     1IPL1CS,IPL2CS,
3769     1IDEFMA,IDEFMO,IDEFM2,IDEFM3,
3770     1IDEFPO,IDEFCN,IDEFDC,IDEFVP,IDEFHP,IDEFUN,
3771     1NUMDEV,MAXDEV,
3772     1IDMANU,IDMODE,IDMOD2,IDMOD3,
3773     1IDPOWE,IDCONT,IDCOLO,IDFONT,IDNVPP,IDNHPP,IDUNIT,
3774     1IDNVOF,IDNHOF,
3775     1ICAPSW,ICAPNU,
3776     1IANS,IWIDTH,IBUGO2,ISUBRO,IFOUND,IERROR)
3777      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
3778C
3779 4199 CONTINUE
3780C
3781C
3782C               *********************************
3783C               **  TREAT THE PENPLOTTER CASE  **
3784C               *********************************
3785C
3786      IF(ICOM.EQ.'PENP')GOTO4200
3787      GOTO4299
3788C
3789 4200 CONTINUE
3790      IF(NUMARG.LE.0)IOP='ON'
3791      IF(NUMARG.GE.1)IOP=IHARG(1)
3792      IF(IOP.EQ.'OPEN')IOP='ON'
3793      IF(IOP.EQ.'AUTO')IOP='ON'
3794      IF(IOP.EQ.'DEFA')IOP='ON'
3795      IF(IOP.EQ.'CLOS')IOP='OFF'
3796C
3797      ISHIFT=2
3798      CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
3799     1IBUGO2,IERROR)
3800      IHARG(1)='1   '
3801      IHARG2(1)='    '
3802      IARGT(1)='NUMB'
3803      IARG(1)=1
3804C
3805      IF(IOP.EQ.'ON')GOTO4210
3806      GOTO4220
3807C
3808 4210 CONTINUE
3809      IHARG(2)='MANU'
3810      IHARG2(2)='FACT'
3811      IARGT(2)='WORD'
3812      IHARG(3)='TEKT'
3813      IHARG2(3)='RONI'
3814      IARGT(3)='WORD'
3815      IHARG(4)='4662'
3816      IHARG2(I)='    '
3817      IARGT(4)='WORD'
3818      NUMARG=4
3819      CALL DPDEMN(IHARG,IHARG2,IARGT,IARG,NUMARG,
3820     1IPL1NU,IPL1NA,
3821     1IPL2NU,IPL2NA,
3822     1IPL1CS,IPL2CS,
3823     1IDEFMA,IDEFMO,IDEFM2,IDEFM3,
3824     1IDEFPO,IDEFCN,IDEFDC,IDEFVP,IDEFHP,IDEFUN,
3825     1NUMDEV,MAXDEV,
3826     1IDMANU,IDMODE,IDMOD2,IDMOD3,
3827     1IDPOWE,IDCONT,IDCOLO,IDFONT,IDNVPP,IDNHPP,IDUNIT,
3828     1IDNVOF,IDNHOF,
3829     1ICAPSW,ICAPNU,
3830     1IANS,IWIDTH,IBUGO2,ISUBRO,IFOUND,IERROR)
3831      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
3832      GOTO4299
3833C
3834 4220 CONTINUE
3835      IHARG(2)='POWE'
3836      IHARG2(2)='R   '
3837      IARGT(2)='WORD'
3838      IHARG(3)='OFF '
3839      IHARG2(3)='    '
3840      IARGT(3)='WORD'
3841      NUMARG=3
3842      CALL DPDEPW(IHARG,IHARG2,IARGT,IARG,NUMARG,
3843     1IPL1NU,IPL1NA,
3844     1IPL2NU,IPL2NA,
3845     1IDEFPO,
3846     1NUMDEV,MAXDEV,
3847     1IDMANU,IDMODE,IDMOD2,IDMOD3,
3848     1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
3849     1IDNVOF,IDNHOF,
3850     1ICAPSW,ICAPNU,
3851     1IANS,IWIDTH,IBUGO2,ISUBRO,IFOUND,IERROR)
3852      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
3853      GOTO4299
3854C
3855 4299 CONTINUE
3856C
3857C               *******************************
3858C               **  TREAT THE HARDCOPY CASE  **
3859C               *******************************
3860C
3861      IF(ICOM.EQ.'HARD')GOTO4300
3862      GOTO4399
3863C
3864 4300 CONTINUE
3865      CALL DPHAPW(IHARG,IHARG2,IARGT,IARG,NUMARG,
3866     1            ICOPSW,NUMCOP,
3867     1            IBUGO2,ISUBRO,IFOUND,IERROR)
3868      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
3869C
3870 4399 CONTINUE
3871C
3872C               ******************************
3873C               **  TREAT THE FILE   CASE  **
3874C               **  TREAT THE CALCOMP CASE  **
3875C               **  TREAT THE VERSATEC CASE  **
3876C               **  TREAT THE ZETA     CASE  **
3877C               ******************************
3878C
3879      IF(ICOM.EQ.'TEKT'.AND.IHARG(1).EQ.'META')GOTO5100
3880      IF(ICOM.EQ.'CALC')GOTO5100
3881      IF(ICOM.EQ.'VERS')GOTO5100
3882      IF(ICOM.EQ.'ZETA'.AND.IHARG(1).EQ.'CHI ')GOTO9000
3883      IF(ICOM.EQ.'ZETA'.AND.IHARG(1).EQ.'CHIS')GOTO9000
3884      IF(ICOM.EQ.'ZETA'.AND.IHARG(1).EQ.'KS  ')GOTO9000
3885      IF(ICOM.EQ.'ZETA'.AND.IHARG(1).EQ.'KOLM')GOTO9000
3886      IF(ICOM.EQ.'ZETA'.AND.IHARG(1).EQ.'PROB')GOTO9000
3887      IF(ICOM.EQ.'ZETA'.AND.IHARG(1).EQ.'PPCC')GOTO9000
3888      IF(ICOM.EQ.'ZETA'.AND.IHARG(1).EQ.'MLE ')GOTO9000
3889      IF(ICOM.EQ.'ZETA'.AND.IHARG(1).EQ.'MAXI')GOTO9000
3890      IF(ICOM.EQ.'ZETA')GOTO5100
3891      GOTO5199
3892C
3893 5100 CONTINUE
3894      IDMANU(1)=ICOM
3895      IDMODE(1)='    '
3896      IDMOD2(1)='    '
3897      IDMOD3(1)='    '
3898      IF(NUMARG.LE.0)IOP='ON'
3899      IF(NUMARG.GE.1)IOP=IHARG(1)
3900      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'META')IOP='ON'
3901      IF(IOP.EQ.'OPEN')IOP='ON'
3902      IF(IOP.EQ.'AUTO')IOP='ON'
3903      IF(IOP.EQ.'DEFA')IOP='ON'
3904      IF(IOP.EQ.'CLOS')IOP='OFF'
3905C
3906      ISHIFT=2
3907      CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
3908     1IBUGO2,IERROR)
3909      IHARG(1)='2   '
3910      IHARG2(1)='    '
3911      IARGT(1)='NUMB'
3912      IARG(1)=2
3913C
3914      IF(IOP.EQ.'ON')GOTO5110
3915      GOTO5120
3916C
3917 5110 CONTINUE
3918      IHARG(2)='MANU'
3919      IHARG2(2)='FACT'
3920      IARGT(2)='WORD'
3921      IHARG(3)=IDMANU(1)
3922      IHARG2(3)='    '
3923      IARGT(3)='WORD'
3924      IHARG(4)=IDMODE(1)
3925      IHARG2(4)='    '
3926      IARGT(4)='WORD'
3927      IHARG(5)=IDMOD2(1)
3928      IHARG2(5)='    '
3929      IARGT(5)='WORD'
3930      IHARG(6)=IDMOD3(1)
3931      IHARG2(6)='    '
3932      IARGT(6)='WORD'
3933      NUMARG=6
3934      CALL DPDEMN(IHARG,IHARG2,IARGT,IARG,NUMARG,
3935     1IPL1NU,IPL1NA,
3936     1IPL2NU,IPL2NA,
3937     1IPL1CS,IPL2CS,
3938     1IDEFMA,IDEFMO,IDEFM2,IDEFM3,
3939     1IDEFPO,IDEFCN,IDEFDC,IDEFVP,IDEFHP,IDEFUN,
3940     1NUMDEV,MAXDEV,
3941     1IDMANU,IDMODE,IDMOD2,IDMOD3,
3942     1IDPOWE,IDCONT,IDCOLO,IDFONT,IDNVPP,IDNHPP,IDUNIT,
3943     1IDNVOF,IDNHOF,
3944     1ICAPSW,ICAPNU,
3945     1IANS,IWIDTH,IBUGO2,ISUBRO,IFOUND,IERROR)
3946      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
3947      GOTO5199
3948C
3949 5120 CONTINUE
3950      IHARG(2)='POWE'
3951      IHARG2(2)='R   '
3952      IARGT(2)='WORD'
3953      IHARG(3)='OFF '
3954      IHARG2(3)='    '
3955      IARGT(3)='WORD'
3956      NUMARG=3
3957      CALL DPDEPW(IHARG,IHARG2,IARGT,IARG,NUMARG,
3958     1IPL1NU,IPL1NA,
3959     1IPL2NU,IPL2NA,
3960     1IDEFPO,
3961     1NUMDEV,MAXDEV,
3962     1IDMANU,IDMODE,IDMOD2,IDMOD3,
3963     1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
3964     1IDNVOF,IDNHOF,
3965     1ICAPSW,ICAPNU,
3966     1IANS,IWIDTH,IBUGO2,ISUBRO,IFOUND,IERROR)
3967      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
3968      GOTO5199
3969C
3970 5199 CONTINUE
3971C
3972C               ******************************
3973C               **  TREAT THE GENERAL METAFILE   CASE  **
3974C               ******************************
3975C
3976      IF(ICOM.EQ.'META')GOTO5200
3977      IF(ICOM.EQ.'GENE'.AND.IHARG(1).EQ.'META')GOTO5200
3978      GOTO5299
3979C
3980 5200 CONTINUE
3981      IF(NUMARG.LE.0)IOP='ON'
3982      IF(NUMARG.GE.1)IOP=IHARG(1)
3983      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'META')IOP='ON'
3984      IF(IOP.EQ.'OPEN')IOP='ON'
3985      IF(IOP.EQ.'AUTO')IOP='ON'
3986      IF(IOP.EQ.'DEFA')IOP='ON'
3987      IF(IOP.EQ.'CLOS')IOP='OFF'
3988C
3989      ISHIFT=2
3990      CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
3991     1IBUGO2,IERROR)
3992      IHARG(1)='3   '
3993      IHARG2(1)='    '
3994      IARGT(1)='NUMB'
3995      IARG(1)=3
3996C
3997      IF(IOP.EQ.'ON')GOTO5210
3998      GOTO5220
3999C
4000 5210 CONTINUE
4001      IHARG(2)='MANU'
4002      IHARG2(2)='FACT'
4003      IARGT(2)='WORD'
4004      IHARG(3)='META'
4005      IHARG2(3)='FILE'
4006      IARGT(3)='WORD'
4007      NUMARG=3
4008      CALL DPDEMN(IHARG,IHARG2,IARGT,IARG,NUMARG,
4009     1IPL1NU,IPL1NA,
4010     1IPL2NU,IPL2NA,
4011     1IPL1CS,IPL2CS,
4012     1IDEFMA,IDEFMO,IDEFM2,IDEFM3,
4013     1IDEFPO,IDEFCN,IDEFDC,IDEFVP,IDEFHP,IDEFUN,
4014     1NUMDEV,MAXDEV,
4015     1IDMANU,IDMODE,IDMOD2,IDMOD3,
4016     1IDPOWE,IDCONT,IDCOLO,IDFONT,IDNVPP,IDNHPP,IDUNIT,
4017     1IDNVOF,IDNHOF,
4018     1ICAPSW,ICAPNU,
4019     1IANS,IWIDTH,IBUGO2,ISUBRO,IFOUND,IERROR)
4020      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4021      GOTO5299
4022C
4023 5220 CONTINUE
4024      IHARG(2)='POWE'
4025      IHARG2(2)='R   '
4026      IARGT(2)='WORD'
4027      IHARG(3)='OFF '
4028      IHARG2(3)='    '
4029      IARGT(3)='WORD'
4030      NUMARG=3
4031      CALL DPDEPW(IHARG,IHARG2,IARGT,IARG,NUMARG,
4032     1IPL1NU,IPL1NA,
4033     1IPL2NU,IPL2NA,
4034     1IDEFPO,
4035     1NUMDEV,MAXDEV,
4036     1IDMANU,IDMODE,IDMOD2,IDMOD3,
4037     1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
4038     1IDNVOF,IDNHOF,
4039     1ICAPSW,ICAPNU,
4040     1IANS,IWIDTH,IBUGO2,ISUBRO,IFOUND,IERROR)
4041      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4042      GOTO5299
4043C
4044 5299 CONTINUE
4045C
4046CCCCC THE FOLLOWING SECTION WAS ADDED   MAY 1992 (JJF)
4047C               *********************************
4048C               **  TREAT THE BLANK PAGE CASE  **
4049C               *********************************
4050C
4051      IF(ICOM.EQ.'BLAN' .AND. IHARG(1).NE.'ALTM')THEN
4052        CALL DPBLPA(IHARG,NUMARG,
4053     1              IPSTBP,IFOUND,IERROR)
4054        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4055      ENDIF
4056C
4057C               *****************************************
4058C               **  OUTPUT DEVICE COMMAND NOT FOUND--  **
4059C               **  BRANCH TO EXIT.                    **
4060C               *****************************************
4061C
4062      GOTO9000
4063C
4064C               *****************
4065C               **  STEP 90--  **
4066C               **  EXIT       **
4067C               *****************
4068C
4069 9000 CONTINUE
4070C
4071      IERRST=IERROR
4072C
4073C     SEPTEMBER 2012.  CHECK FOR FATAL ERROR
4074C
4075      IF(IERROR.EQ.'YES')THEN
4076        ICASE2='DEVI'
4077        CALL DPERRO(IERRFA,IANSLC,IWIDTH,IGUIFL,
4078     1              ISUBN1,ISUBN2,ICASE2,
4079     1              IBUGO2,ISUBRO,IERROR)
4080      ENDIF
4081C
4082C
4083      IF(IBUGOD.EQ.'ON'.OR.ISUBRO.EQ.'INOD')THEN
4084        WRITE(ICOUT,999)
4085        CALL DPWRST('XXX','BUG ')
4086        WRITE(ICOUT,9011)
4087 9011   FORMAT('***** AT THE END       OF MAINOD--')
4088        CALL DPWRST('XXX','BUG ')
4089        WRITE(ICOUT,9020)IFOUND,IERROR
4090 9020   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
4091        CALL DPWRST('XXX','BUG ')
4092      ENDIF
4093C
4094      RETURN
4095      END
4096      SUBROUTINE MAINPC(IBUGPC,IBUGP2,IBUGQ,ISUBRO,
4097     1                  IVGMSW,IHGMSW,
4098     1                  IMPSW,IMPNR,IMPNC,IMPCO,IMPCO9,
4099CCCCC ADD FOLLOWING LINE AUGUST 1999.
4100     1                  IMPARG,
4101     1                  PMXMIN,PMXMAX,PMYMIN,PMYMAX,
4102     1                  IERASV,
4103     1                  PWXMIS,PWXMAS,PWYMIS,PWYMAS,
4104CCCCC THE FOLLOWING LINE WAS ADDED    APRIL 1992
4105     1                  BARHEF,BARWEF,
4106CCCCC THE FOLLOWING LINE WAS ADDED AUGUST 1992
4107     1                  ITIAUT,IX1AUT,IX2AUT,IX3AUT,IY1AUT,IY2AUT,
4108     1                  IFOUND,IERROR)
4109C
4110C     PURPOSE--THIS IS SUBROUTING MAINPC.
4111C              (THE   PC    AT THE END OF    MAINPC   STANDS FOR   PLOT
4112C              THIS SUBROUTINE SEARCHES FOR AND EXECUTES PLOT CONTROL CO
4113C              THE PLOT CONTROL COMMANDS SEARCHED FOR BY MAINPC ARE AS F
4114C
4115C                      ARROW ... COLOR                   A COLOR
4116C                      ARROW ... COORDINATES             2 NUMBERS
4117C                      BACKGROUND COLOR                  A COLOR
4118C                      BELL                              ON/OFF
4119C                      BOX ... COLOR                     A COLOR
4120C                      BOX ... CORNER COORDINATES        4 NUMBERS
4121C                      CHARACTERS                        A LIST OF CHARA
4122C                      CHARACTER COLORS                  A LIST OF COLOR
4123C                      CHARACTER SIZES                   A LIST OF NUMBE
4124C                      CHARACTER FILL                    A LIST OF ON/OF
4125C                      EYE COORDINATES                   3 NUMBERS
4126C                      ...FRAME                          ON/OFF
4127C                      ...FRAME COLOR                    A COLOR
4128C                      FRAME CORNER COORDINATES          4 NUMBERS
4129C                      WINDOW CORNER COORDINATES         4 NUMBERS
4130C                      ...GRID                           ON/OFF
4131C                      GRID COLOR                        A COLOR
4132C                      GRID PATTERN                      PATTERN
4133C                      ...LABEL                          A STRING OF CHA
4134C                      LABEL COLOR                       A COLOR
4135C                      LABEL SIZE                        A NUMBER
4136C                      LEGEND ...                        A STRING OF CHA
4137C                      LEGEND ... COLOR                  A COLOR
4138C                      LEGEND ... COORDINATES            2 NUMBERS
4139C                      LEGEND ... SIZE                   A NUMBER
4140C                      ...LIMITS                         2 NUMBERS
4141C                      LINES                             A LIST OF LINE
4142C                      LINE  COLORS                      A LIST OF COLOR
4143C                      LINE  THICKNESSES                 A LIST OF THICK
4144C                      ...LOG                            ON/OFF
4145C                      MARGIN COLOR                      A COLOR
4146C                      ...MAXIMUM                        A NUMBER
4147C                      ...MINIMUM                        A NUMBER
4148C                      NEGATE                            ON/OFF
4149C                      ORIGIN COORDINATES                3 NUMBERS
4150C                      PEDESTAL                          ON/OFF
4151C                      PEDESTAL COLOR                    A COLOR
4152C                      PEDESTAL HEIGHT                   A NUMBER
4153C                      PRE-SORT                          ON/OFF
4154C                      SEGMENT ... COLOR                 A COLOR
4155C                      SEGMENT ... COORDINATES           2 NUMBERS
4156C                      SEQUENCE                          ON/OFF
4157C                      ...TIC                            ON/OFF
4158CCCCCC                 ...TIC COLOR                      A COLOR
4159CCCCCC                 ...TIC DECIMALS                   A NUMBER
4160CCCCCC                 ...TIC COORDINATES                A LIST OF NUMBE
4161C                      ...TIC POSITION (JUSTIFICATION)   INSIDE/OUTSIDE/
4162C                      ...TIC SIZE                       A NUMBER
4163C                      ...TIC LABELS                     ON/OFF
4164C                      ...TIC LABEL COLOR                A COLOR
4165C                      ...TIC LABEL SIZE                 A NUMBER
4166C                      TITLE                             A STRING OF CHA
4167C                      TITLE COLOR                       A COLOR
4168C                      TITLE SIZE                        A NUMBER
4169C                      VISIBLE                           ON/OFF
4170C
4171C                      BAR SWITCH                        A SERIES OF ON/
4172C                      BAR WIDTH                         A SERIES OF NUM
4173C                      BAR BASE                          A SERIES OF NUM
4174C                      BAR BORDER COLOR                  A SERIES OF COL
4175C                      BAR BORDER THICKNESS              A SERIES OF NUM
4176C                      BAR BORDER LINE                   A SERIES OF LIN
4177C                      BAR FILL SWITCH                   A SERIES OF ON/
4178C                      BAR FILL COLOR                    A SERIES OF COL
4179C                      BAR PATTERN TYPE                  A SERIES OF PAT
4180C                      BAR PATTERN COLOR                 A SERIES OF COL
4181C                      BAR PATTERN SPACING               A SERIES OF NUM
4182C                      BAR PATTERN THICKNESS             A SERIES OF NUM
4183C                      BAR PATTERN LINE                  A SERIES OF LIN
4184C                      BAR TYPES                         A SERIES OF NUMBERS
4185C
4186C                      BAR EXPANSION FACTORS             2 NUMBERS
4187C
4188C                      REGION BASE                       A SERIES OF NUM
4189C                      REGION BORDER COLOR               A SERIES OF COL
4190C                      REGION BORDER THICKNESS           A SERIES OF NUM
4191C                      REGION BORDER LINE                A SERIES OF LIN
4192C                      REGION FILL SWITCH                A SERIES OF ON/
4193C                      REGION FILL COLOR                 A SERIES OF COL
4194C                      REGION PATTERN TYPE               A SERIES OF PAT
4195C                      REGION PATTERN COLOR              A SERIES OF COL
4196C                      REGION PATTERN SPACING            A SERIES OF NUM
4197C                      REGION PATTERN THICKNESS          A SERIES OF NUM
4198C                      REGION PATTERN LINE               A SERIES OF LIN
4199C
4200C                      TEXT BORDER COLOR                 A SERIES OF COL
4201C                      TEXT BORDER THICKNESS             A SERIES OF NUM
4202C                      TEXT BORDER LINE                  A SERIES OF LIN
4203C                      TEXT FILL SWITCH                  A SERIES OF ON/
4204C                      TEXT FILL COLOR                   A SERIES OF COL
4205C                      TEXT PATTERN TYPE                 A SERIES OF PAT
4206C                      TEXT PATTERN COLOR                A SERIES OF COL
4207C                      TEXT PATTERN SPACING              A SERIES OF NUM
4208C                      TEXT PATTERN THICKNESS            A SERIES OF NUM
4209C                      TEXT PATTERN LINE                 A SERIES OF LIN
4210C
4211C                      MAJOR ...TIC MARK NUMBER          A NUMBER
4212C                      MINOR ...TIC MARK NUMBER          A NUMBER
4213C
4214C     WRITTEN BY--JAMES J. FILLIBEN
4215C                 STATISTICAL ENGINEERING DIVISION
4216C                 INFORMATION TECHNOLOGY LABORATORY
4217C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
4218C                 GAITHERSBURG, MD 20899-8980
4219C                 PHONE--301-975-2855
4220C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
4221C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
4222C     LANGUAGE--ANSI FORTRAN (1977)
4223C     VERSION NUMBER--82.6
4224C     ORIGINAL VERSION--SEPTEMBER 1980.
4225C     UPDATED         --MARCH     1981.
4226C     UPDATED         --APRIL     1981.
4227C     UPDATED         --AUGUST    1981.
4228C     UPDATED         --SEPTEMBER 1981.
4229C     UPDATED         --NOVEMBER  1981.
4230C     UPDATED         --MAY       1982.
4231C     UPDATED         --JULY      1986.
4232C     UPDATED         --SEPTEMBER 1988. 3D PROJECTION (ORTHOGRAP./PERSPECT.)
4233C     UPDATED         --SEPTEMBER 1988. INCLUDE DPCO3D.INC
4234C     UPDATED         --APRIL     1992. BAR EXPANSION FACTORS ... ...
4235C     UPDATED         --AUGUST    1992. ADD SWITCHES FOR AUTOMATIC
4236C     UPDATED         --SEPTEMBER 1993. CHAR*4 FOR AUTOMATIC SWITCHES
4237C     UPDATED         --AUGUST    1999. ARGUMENT LIST TO MAIPC2
4238C     UPDATED         --SEPTEMBER 2007. IERRST
4239C     UPDATED         --SEPTEMBER 2012. SET FATAL ERROR
4240C
4241C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
4242C
4243      CHARACTER*4 IBUGPC
4244      CHARACTER*4 IBUGP2
4245      CHARACTER*4 IBUGQ
4246      CHARACTER*4 ISUBRO
4247C
4248      CHARACTER*4 IVGMSW
4249      CHARACTER*4 IHGMSW
4250C
4251      CHARACTER*4 IMPSW
4252      CHARACTER*4 IERASV
4253C
4254CCCCC THE FOLLOWING 6 LINES WERE ADDED    SEPTEMBER 1993
4255      CHARACTER*4 ITIAUT
4256      CHARACTER*4 IX1AUT
4257      CHARACTER*4 IX2AUT
4258      CHARACTER*4 IX3AUT
4259      CHARACTER*4 IY1AUT
4260      CHARACTER*4 IY2AUT
4261C
4262      CHARACTER*4 IFOUND
4263      CHARACTER*4 IERROR
4264C
4265      CHARACTER*4 ICASE2
4266      CHARACTER*4 ISUBN1
4267      CHARACTER*4 ISUBN2
4268C
4269C-----COMMON----------------------------------------------------------
4270C
4271      INCLUDE 'DPCOPA.INC'
4272      INCLUDE 'DPCOHK.INC'
4273      INCLUDE 'DPCOPC.INC'
4274      INCLUDE 'DPCO3D.INC'
4275      INCLUDE 'DPCOSU.INC'
4276      INCLUDE 'DPCODA.INC'
4277      INCLUDE 'DPCOST.INC'
4278      INCLUDE 'DPCOP2.INC'
4279C
4280C-----START POINT-----------------------------------------------------
4281C
4282      IF(IBUGPC.EQ.'ON' .OR. ISUBRO.EQ.'INPC')THEN
4283        WRITE(ICOUT,999)
4284  999   FORMAT(1X)
4285        CALL DPWRST('XXX','BUG ')
4286        WRITE(ICOUT,51)
4287   51   FORMAT('***** AT THE BEGINNING OF MAINPC--')
4288        CALL DPWRST('XXX','BUG ')
4289        WRITE(ICOUT,53)IBUGPC,IBUGP2,ISUBRO,IANGLU
4290   53   FORMAT('IBUGPC,IBUGP2,ISUBRO,IANGLU = ',3(A4,2X),A4)
4291        CALL DPWRST('XXX','BUG ')
4292        WRITE(ICOUT,67)ICOM,ICOM2,NUMARG
4293   67   FORMAT('ICOM,ICOM2,NUMARG = ',2(A4,2X),I8)
4294        CALL DPWRST('XXX','BUG ')
4295        DO70I=1,NUMARG
4296          WRITE(ICOUT,71)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I)
4297   71     FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) = ',
4298     1           I8,3(2X,A4),2X,I8,G15.7)
4299          CALL DPWRST('XXX','BUG ')
4300   70   CONTINUE
4301        WRITE(ICOUT,81)IMPSW,IMPNR,IMPNC,IMPCO
4302   81   FORMAT('IMPSW,IMPNR,IMPNC,IMPCO = ',A4,3I8)
4303        CALL DPWRST('XXX','BUG ')
4304        WRITE(ICOUT,82)PMXMIN,PMXMAX,PMYMIN,PMYMAX
4305   82   FORMAT('PMXMIN,PMXMAX,PMYMIN,PMYMAX = ',4G15.7)
4306        CALL DPWRST('XXX','BUG ')
4307        WRITE(ICOUT,83)IERASV,I3DPRO,IERASW
4308   83   FORMAT('IERASV,I3DPRO,IERASW = ',2(A4,2X),A4)
4309        CALL DPWRST('XXX','BUG ')
4310        WRITE(ICOUT,84)PWXMIS,PWXMAS,PWYMIS,PWYMAS
4311   84   FORMAT('PWXMIS,PWXMAS,PWYMIS,PWYMAS = ',4G15.7)
4312        CALL DPWRST('XXX','BUG ')
4313        WRITE(ICOUT,86)PWXMIN,PWXMAX,PWYMIN,PWYMAX
4314   86   FORMAT('PWXMIN,PWXMAX,PWYMIN,PWYMAX = ',4G15.7)
4315        CALL DPWRST('XXX','BUG ')
4316        WRITE(ICOUT,87)PXMIN,PXMAX,PYMIN,PYMAX
4317   87   FORMAT('PXMIN,PXMAX,PYMIN,PYMAX = ',4G15.7)
4318        CALL DPWRST('XXX','BUG ')
4319      ENDIF
4320C
4321      IFOUND='NO'
4322      IERROR='NO'
4323C
4324      CALL MAIPC1(IBUGPC,IBUGP2,IBUGQ,ISUBRO,
4325     1            IVGMSW,IHGMSW,
4326     1            IMPSW,IMPNR,IMPNC,IMPCO,
4327     1            PMXMIN,PMXMAX,PMYMIN,PMYMAX,
4328     1            IERASV,ICHAOF,ICHADY,ICHAVN,
4329     1            PWXMIS,PWXMAS,PWYMIS,PWYMAS,
4330CCCCC THE FOLLOWING LINE WAS ADDED AUGUST 1992
4331     1            IX1AUT,IX2AUT,IX3AUT,IY1AUT,IY2AUT,
4332     1            IFOUND,IERROR)
4333      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4334C
4335      CALL MAIPC2(IBUGPC,IBUGP2,ISUBRO,
4336     1            IVGMSW,IHGMSW,
4337     1            IMPSW,IMPNR,IMPNC,IMPCO,IMPCO9,
4338CCCCC ADD FOLLOWING LINE AUGUST 1999.
4339     1            IMPARG,
4340     1            PMXMIN,PMXMAX,PMYMIN,PMYMAX,
4341     1            IERASV,
4342     1            PWXMIS,PWXMAS,PWYMIS,PWYMAS,
4343CCCCC THE FOLLOWING LINE WAS ADDED AUGUST 1992
4344     1            ITIAUT,
4345     1            IFOUND,IERROR)
4346      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4347C
4348      CALL MAIPC3(IBUGPC,IBUGP2,ISUBRO,
4349     1            IVGMSW,IHGMSW,
4350     1            IMPSW,IMPNR,IMPNC,IMPCO,
4351     1            PMXMIN,PMXMAX,PMYMIN,PMYMAX,
4352     1            IERASV,
4353     1            PWXMIS,PWXMAS,PWYMIS,PWYMAS,
4354CCCCC THE FOLLOWING LINE WAS ADDED    APRIL 1992
4355     1            BARHEF,BARWEF,
4356     1            IFOUND,IERROR)
4357      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4358C
4359      CALL MAIPC4(IBUGPC,IBUGP2,ISUBRO,IFOUND,IERROR)
4360      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4361C
4362C               *****************
4363C               **  STEP 90--  **
4364C               **  EXIT       **
4365C               *****************
4366C
4367 9000 CONTINUE
4368C
4369      IERRST=IERROR
4370C
4371C     SEPTEMBER 2012.  CHECK FOR FATAL ERROR
4372C
4373      IF(IERROR.EQ.'YES')THEN
4374        ISUBN1='MAIN'
4375        ISUBN2='IN  '
4376        ICASE2='INPC'
4377        CALL DPERRO(IERRFA,IANSLC,IWIDTH,IGUIFL,
4378     1              ISUBN1,ISUBN2,ICASE2,
4379     1              IBUGP2,ISUBRO,IERROR)
4380      ENDIF
4381C
4382C
4383      IF(IBUGPC.EQ.'ON' .OR. ISUBRO.EQ.'INPC')THEN
4384        WRITE(ICOUT,999)
4385        CALL DPWRST('XXX','BUG ')
4386        WRITE(ICOUT,9031)
4387 9031   FORMAT('***** AT THE END       OF MAINPC--')
4388        CALL DPWRST('XXX','BUG ')
4389        WRITE(ICOUT,9033)IFOUND,IERROR,IANGLU
4390 9033   FORMAT('IFOUND,IERROR,IANGLU = ',2(A4,2X),A4)
4391        CALL DPWRST('XXX','BUG ')
4392        WRITE(ICOUT,9041)IMPSW,IMPNR,IMPNC,IMPCO
4393 9041   FORMAT('IMPSW,IMPNR,IMPNC,IMPCO = ',A4,3I8)
4394        CALL DPWRST('XXX','BUG ')
4395        WRITE(ICOUT,9042)PMXMIN,PMXMAX,PMYMIN,PMYMAX
4396 9042   FORMAT('PMXMIN,PMXMAX,PMYMIN,PMYMAX = ',4G15.7)
4397        CALL DPWRST('XXX','BUG ')
4398        WRITE(ICOUT,9043)IERASV,I3DPRO,IERASW
4399 9043   FORMAT('IERASV,I3DPRO,IERASW = ',2(A4,2X),A4)
4400        CALL DPWRST('XXX','BUG ')
4401        WRITE(ICOUT,9044)PWXMIS,PWXMAS,PWYMIS,PWYMAS
4402 9044   FORMAT('PWXMIS,PWXMAS,PWYMIS,PWYMAS = ',4E15.7)
4403        CALL DPWRST('XXX','BUG ')
4404        WRITE(ICOUT,9046)PWXMIN,PWXMAX,PWYMIN,PWYMAX
4405 9046   FORMAT('PWXMIN,PWXMAX,PWYMIN,PWYMAX = ',4G15.7)
4406        CALL DPWRST('XXX','BUG ')
4407        WRITE(ICOUT,9047)PXMIN,PXMAX,PYMIN,PYMAX
4408 9047   FORMAT('PXMIN,PXMAX,PYMIN,PYMAX = ',4G15.7)
4409        CALL DPWRST('XXX','BUG ')
4410CCCCC   THE FOLLOWING 2 LINES WERE ADDED    APRIL 1992
4411        WRITE(ICOUT,9048)BARHEF,BARWEF
4412 9048   FORMAT('BARHEF,BARWEF = ',2G15.7)
4413        CALL DPWRST('XXX','BUG ')
4414      ENDIF
4415      RETURN
4416      END
4417      SUBROUTINE MAIPC1(IBUGPC,IBUGP2,IBUGQ,ISUBRO,
4418     1                  IVGMSW,IHGMSW,
4419     1                  IMPSW,IMPNR,IMPNC,IMPCO,
4420     1                  PMXMIN,PMXMAX,PMYMIN,PMYMAX,
4421     1                  IERASV,ICHAOF,ICHADY,ICHAVN,
4422     1                  PWXMIS,PWXMAS,PWYMIS,PWYMAS,
4423CCCCC THE FOLLOWING LINE WAS ADDED AUGUST 1992
4424     1                  IX1AUT,IX2AUT,IX3AUT,IY1AUT,IY2AUT,
4425     1                  IFOUND,IERROR)
4426C
4427C     PURPOSE--THIS IS SUBROUTING MAIPC1.
4428C              (THE   PC    AT THE END OF    MAIPC1   STANDS FOR PLOT CONTROL
4429C              THIS SUBROUTINE SEARCHES FOR AND EXECUTES
4430C              PLOT CONTROL COMMANDS (PART 1).
4431C              THE PLOT CONTROL COMMANDS SEARCHED FOR BY MAIPC1 ARE AS F
4432C
4433C     WRITTEN BY--JAMES J. FILLIBEN
4434C                 STATISTICAL ENGINEERING DIVISION
4435C                 INFORMATION TECHNOLOGY LABORATORY
4436C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
4437C                 GAITHERSBURG, MD 20899-8980
4438C                 PHONE--301-975-2855
4439C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
4440C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
4441C     LANGUAGE--ANSI FORTRAN (1977)
4442C     VERSION NUMBER--82.6
4443C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--JULY 1986.
4444C     UPDATED--JULY 1987        LEGEND HW
4445C     UPDATED--FEBRUARY      1988 FURTHER RESOLVE CONFLICT--MIN VS MIN PLOT
4446C                                                           AND MAX VS MAX PLO
4447C     UPDATED--MARCH     1988.  FURTHER RESOLVE CONFLICT--MIN VS MIN PLOT
4448C                                                         AND MAX VS MAX PLO
4449C     UPDATED--SEPTEMBER 1988.  MOVE EYE/ORIGIN/PEDESTAL COMMANDS
4450C                               TO MAIPC4 FOR GENERAL 3-D.
4451C     UPDATED         --SEPTEMBER 1988.  CHANGE 'BACK' TO 'BACKGROU'
4452C     UPDATED         --DECEMBER  1988.  LABEL AND LEGEND DEFAULT WIDTH
4453C     UPDATED         --FEBRUARY  1989.  ADD MANY ATTRIBUTE COMMANDS (ALAN)
4454C     UPDATED         --MAY       1989.  DES. OF EXP. WIDTH/DEPTH/HOR. AXIS
4455C     UPDATED         --JULY      1989.  ...LABEL DISPLACEMENT
4456C     UPDATED         --FEBRUARY  1992. FIX LEGEND DIRECTION CONFLICT
4457C     UPDATED         --APRIL     1992. IDEXHO TO IDEXHA
4458C     UPDATED         --AUGUST    1992. ADD SWITCHES FOR AUTOMATIC
4459C     UPDATED         --AUGUST    1992. BOX SHADOW HEIGHT/WIDTH
4460C     UPDATED         --AUGUST    1992. BOX FILL COLOR
4461C     UPDATED         --AUGUST    1992. BOX FILL PATTERN
4462C     UPDATED         --AUGUST    1992. BOX FILL THICK
4463C     UPDATED         --AUGUST    1992. BOX FILL GAP
4464C     UPDATED         --MARCH     1993. BUG IN CALL TO DPBOTH
4465C     UPDATED         --SEPTEMBER 1993. LOWER CASE LABELS
4466C     UPDATED         --SEPTEMBER 1993. LOWER CASE LEGENDS
4467C     UPDATED         --SEPTEMBER 1993. 3-D FRAME SWITCH
4468C     UPDATED         --SEPTEMBER 1993. CHAR*4 FOR AUTOMATIC SWITCHES
4469C     UPDATED         --OCTOBER   1993. BACKGROUND COLOR SETS THE
4470C                                       MARGIN COLOR AS WELL
4471C     UPDATED         --DECEMBER  1994. EXACT CHARACTER MAPPING
4472C     UPDATED         --JANUARY   1995. FIX DEFAULT CHAR SIZE
4473C     UPDATED         --APRIL     1995. CHECK FOR COMMAND CONFLICT
4474C     UPDATED         --AUGUST    1995. SEGMENT PATTERN, FRAME PATTERN,
4475C                                       BUG (DASH2, ETC)
4476C     UPDATED         --NOVEMBER  1997. CALL TO DPLIM
4477C     UPDATED         --JANUARY   1998. NAME CONFLICTS FOR MAXI, MINI
4478C     UPDATED         --FEBRUARY  1998. LINE/CHAR <SAVE/RESTORE>
4479C     UPDATED         --OCTOBER   1999. LABEL JUSTIFICIATION
4480C     UPDATED         --OCTOBER   1999. LABEL OFFSET
4481C     UPDATED         --DECEMBER  1999. LEGEND UNITS
4482C     UPDATED         --OCTOBER   2018. LABEL COORDINATES
4483C
4484C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
4485C
4486      CHARACTER*4 ICHADY
4487      CHARACTER*8 ICHAVN
4488      CHARACTER*4 IBUGPC
4489      CHARACTER*4 IBUGP2
4490      CHARACTER*4 IBUGQ
4491      CHARACTER*4 ISUBRO
4492C
4493      CHARACTER*4 IVGMSW
4494      CHARACTER*4 IHGMSW
4495      CHARACTER*4 IMPSW
4496      CHARACTER*4 IERASV
4497C
4498CCCCC THE FOLLOWING 5 LINES WERE ADDED   SEPTEMBER 1993
4499      CHARACTER*4 IX1AUT
4500      CHARACTER*4 IX2AUT
4501      CHARACTER*4 IX3AUT
4502      CHARACTER*4 IY1AUT
4503      CHARACTER*4 IY2AUT
4504C
4505      CHARACTER*4 IFOUND
4506      CHARACTER*4 IERROR
4507C
4508C-----COMMON----------------------------------------------------------
4509C
4510      INCLUDE 'DPCOPA.INC'
4511      INCLUDE 'DPCOHK.INC'
4512      INCLUDE 'DPCOPC.INC'
4513      INCLUDE 'DPCOSU.INC'
4514      INCLUDE 'DPCODA.INC'
4515CCCCC THE FOLLOWING DES. OF EXP. LINE WAS ADDED MAY 1989
4516      INCLUDE 'DPCODE.INC'
4517CCCCC THE FOLLOWING 3D LINE WAS ADDED SEPTEMBER 1993
4518      INCLUDE 'DPCO3D.INC'
4519      INCLUDE 'DPCOP2.INC'
4520C
4521C-----START POINT-----------------------------------------------------
4522C
4523      IF(IBUGPC.EQ.'ON' .OR. ISUBRO.EQ.'IPC1')THEN
4524        WRITE(ICOUT,999)
4525  999   FORMAT(1X)
4526        CALL DPWRST('XXX','BUG ')
4527        WRITE(ICOUT,51)
4528   51   FORMAT('***** AT THE BEGINNING OF MAIPC1--')
4529        CALL DPWRST('XXX','BUG ')
4530        WRITE(ICOUT,53)IBUGPC,IBUGP2,ISUBRO,IANGLU,IERASV
4531   53   FORMAT('IBUGPC,IBUGP2,ISUBRO,IANGLU,IERASV = ',4(A4,2X),A4)
4532        CALL DPWRST('XXX','BUG ')
4533        WRITE(ICOUT,67)ICOM,ICOM2,NUMARG
4534   67   FORMAT('ICOM,ICOM2,NUMARG = ',2(A4,2X),I8)
4535        CALL DPWRST('XXX','BUG ')
4536        WRITE(ICOUT,68)ICHADY,ICHAOF,ICHAVN
4537   68   FORMAT('ICHADY,ICHAOF,ICHAVN = ',2(A4,2X),A8)
4538        CALL DPWRST('XXX','BUG ')
4539        DO70I=1,NUMARG
4540          WRITE(ICOUT,71)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I)
4541   71     FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) = ',
4542     1           I8,3(2X,A4),2X,I8,G15.7)
4543          CALL DPWRST('XXX','BUG ')
4544   70   CONTINUE
4545        WRITE(ICOUT,81)IMPSW,IMPNR,IMPNC,IMPCO,IMPCO2
4546   81   FORMAT('IMPSW,IMPNR,IMPNC,IMPCO,IMPCO2 = ',A4,4I8)
4547        CALL DPWRST('XXX','BUG ')
4548        WRITE(ICOUT,82)PMXMIN,PMXMAX,PMYMIN,PMYMAX
4549   82   FORMAT('PMXMIN,PMXMAX,PMYMIN,PMYMAX = ',4G15.7)
4550        CALL DPWRST('XXX','BUG ')
4551        WRITE(ICOUT,84)PWXMIS,PWXMAS,PWYMIS,PWYMAS
4552   84   FORMAT('PWXMIS,PWXMAS,PWYMIS,PWYMAS = ',4G15.7)
4553        CALL DPWRST('XXX','BUG ')
4554        WRITE(ICOUT,86)PWXMIN,PWXMAX,PWYMIN,PWYMAX
4555   86   FORMAT('PWXMIN,PWXMAX,PWYMIN,PWYMAX = ',4G15.7)
4556        CALL DPWRST('XXX','BUG ')
4557        WRITE(ICOUT,87)PXMIN,PXMAX,PYMIN,PYMAX
4558   87   FORMAT('PXMIN,PXMAX,PYMIN,PYMAX = ',4G15.7)
4559        CALL DPWRST('XXX','BUG ')
4560        WRITE(ICOUT,88)IVGMSW,IHGMSW
4561   88   FORMAT('IVGMSW,IHGMSW = ',A4,2X,A4)
4562        CALL DPWRST('XXX','BUG ')
4563      ENDIF
4564C
4565      IFOUND='NO'
4566      IERROR='NO'
4567C
4568C               ********************************************
4569C               **  TREAT THE ARROW ... COLOR CASE        **
4570C               **            ARROW ... PATTERN CASE      **
4571C               **            ARROW ... THICKNESS CASE    **
4572C               **            ARROW ... COORDINATES CASE  **
4573C               ********************************************
4574C
4575      IF(ICOM.EQ.'ARRO')THEN
4576        CALL DPARCL(IHARG,IARGT,IARG,NUMARG,IDEFCO,
4577     1              MAXARR,IARRCO,IFOUND,IERROR)
4578        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4579C
4580        CALL DPARPA(IHARG,IHARG2,IARGT,IARG,NUMARG,IDEFPA,
4581     1              MAXARR,IARRPA,IFOUND,IERROR)
4582        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4583C
4584        CALL DPARTH(IHARG,IARGT,IARG,ARG,NUMARG,PDEFTH,
4585     1              MAXARR,PARRTH,IFOUND,IERROR)
4586        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4587C
4588        CALL DPARCO(IHARG,IHARG2,IARGT,IARG,ARG,NUMARG,
4589     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,
4590     1              MAXNAM,IANS,IWIDTH,
4591     1              MAXARR,PARRXC,PARRYC,NUMARR,IBUGP2,IFOUND,IERROR)
4592        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4593C
4594      ENDIF
4595C
4596C               ***************************************
4597C               **  TREAT THE BACKGROUND COLOR CASE  **
4598C               ***************************************
4599C
4600      IF(ICOM.EQ.'BACK'.AND.ICOM2.EQ.'GROU')THEN
4601        CALL DPBACL(IHARG,NUMARG,IDEFBK,IBACCO,IFOUND,IERROR)
4602CCCCC   OCTOBER 1993.  HAVE THE MARGIN BE THE SAME AS THE BACKGROUND
4603CCCCC   (USER CAN OVERRIDE WITH SUBSEQUENT MARGIN COLOR COMMAND)
4604        IF(IERROR.EQ.'NO')IMARCO=IBACCO
4605        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4606      ENDIF
4607C
4608C               ***************************
4609C               **  TREAT THE BELL CASE  **
4610C               ***************************
4611C
4612      IF(ICOM.EQ.'BELL')THEN
4613        CALL DPBELL(IHARG,NUMARG,IBELSW,IFOUND,IERROR)
4614        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4615      ENDIF
4616C
4617C               *************************************************
4618C               **  TREAT THE BOX ... CORNER COORDINATES CASE  **
4619C               **            BOX ... COLOR CASE               **
4620C               **            BOX ... PATTERN CASE             **
4621C               **            BOX ... THICKNESS CASE           **
4622C               **            BOX ... FILL COLOR CASE          **
4623C               **            BOX ... FILL PATTTERN CASE       **
4624C               **            BOX ... FILL LINE     CASE       **
4625C               **            BOX ... FILL THICKNESS CASE      **
4626C               **            BOX ... FILL GAP       CASE      **
4627C               **            BOX ... SHADOW HW CASE           **
4628C               *************************************************
4629C
4630      IF(ICOM.EQ.'BOX')THEN
4631C
4632        IF((NUMARG.GE.1.AND.IHARG(1).EQ.'COOR') .OR.
4633     1     (NUMARG.GE.2.AND.IHARG(2).EQ.'COOR') .OR.
4634     1     (NUMARG.GE.2.AND.IHARG(1).EQ.'CORN'.AND.
4635     1      IHARG(2).EQ.'COOR') .OR.
4636     1     (NUMARG.GE.3.AND.IHARG(2).EQ.'CORN'.AND.
4637     1      IHARG(3).EQ.'COOR'))THEN
4638          CALL DPBOCC(IHARG,IHARG2,IARGT,IARG,ARG,NUMARG,
4639     1                IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,
4640     1                MAXNAM,IANS,IWIDTH,
4641     1                MAXBOX,PBOXXC,PBOXYC,NUMBOX,IBUGP2,
4642     1                IFOUND,IERROR)
4643          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4644        ENDIF
4645C
4646        IF((NUMARG.GE.1.AND.IHARG(1).EQ.'COLO') .OR.
4647     1     (NUMARG.GE.2.AND.IHARG(2).EQ.'COLO'.AND.
4648     1      IHARG(1).NE.'FILL'))THEN
4649          CALL DPBOCL(IHARG,IARGT,IARG,NUMARG,IDEFCO,
4650     1                MAXBOX,IBOBCO,IFOUND,IERROR)
4651          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4652        ENDIF
4653C
4654        IF((NUMARG.GE.1.AND.IHARG(1).EQ.'PATT') .OR.
4655     1     (NUMARG.GE.2.AND.IHARG(2).EQ.'PATT'.AND.
4656     1      IHARG(1).NE.'FILL'))THEN
4657          CALL DPBOPA(IHARG,IHARG2,IARGT,IARG,NUMARG,IDEFFI,
4658     1                MAXBOX,IBOBPA,IFOUND,IERROR)
4659          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4660        ENDIF
4661C
4662        IF((NUMARG.GE.1.AND.IHARG(1).EQ.'THIC') .OR.
4663     1     (NUMARG.GE.2.AND.IHARG(2).EQ.'THIC'.AND.
4664     1      IHARG(1).NE.'FILL'))THEN
4665          CALL DPBOTH(IHARG,IARGT,IARG,ARG,NUMARG,PDEFTH,
4666     1                MAXBOX,PBOPTH,IFOUND,IERROR)
4667          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4668        ENDIF
4669C
4670        IF(NUMARG.GE.2)THEN
4671          IF(IHARG(1).EQ.'FILL'.AND.IHARG(2).EQ.'COLO')THEN
4672            CALL DPBOFC(IHARG,IARGT,IARG,NUMARG,IDEFXC,
4673     1                  MAXBOX,IBOFCO,IFOUND,IERROR)
4674            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4675          ENDIF
4676        ENDIF
4677        IF(NUMARG.GE.3)THEN
4678          IF(IHARG(2).EQ.'FILL'.AND.IHARG(3).EQ.'COLO')THEN
4679            CALL DPBOFC(IHARG,IARGT,IARG,NUMARG,IDEFXC,
4680     1                  MAXBOX,IBOFCO,IFOUND,IERROR)
4681            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4682          ENDIF
4683        ENDIF
4684C
4685        IF(NUMARG.GE.2)THEN
4686          IF(IHARG(1).EQ.'FILL'.AND.IHARG(2).EQ.'PATT')THEN
4687            CALL DPBOFP(IHARG,IARGT,IARG,NUMARG,IDEFFI,
4688     1                  MAXBOX,IBOFPA,IFOUND,IERROR)
4689            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4690          ENDIF
4691        ENDIF
4692        IF(NUMARG.GE.3)THEN
4693          IF(IHARG(2).EQ.'FILL'.AND.IHARG(3).EQ.'PATT')THEN
4694            CALL DPBOFP(IHARG,IARGT,IARG,NUMARG,IDEFFI,
4695     1                  MAXBOX,IBOFPA,IFOUND,IERROR)
4696            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4697          ENDIF
4698        ENDIF
4699C
4700C
4701        IF(NUMARG.GE.2)THEN
4702          IF(IHARG(1).EQ.'FILL'.AND.IHARG(2).EQ.'LINE')THEN
4703            CALL DPBOFL(IHARG,IHARG2,IARGT,IARG,NUMARG,IDEFPA,
4704     1                  MAXBOX,IBOPPA,IFOUND,IERROR)
4705            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4706          ENDIF
4707        ENDIF
4708        IF(NUMARG.GE.3)THEN
4709          IF(IHARG(2).EQ.'FILL'.AND.IHARG(3).EQ.'LINE')THEN
4710            CALL DPBOFL(IHARG,IHARG2,IARGT,IARG,NUMARG,IDEFPA,
4711     1                  MAXBOX,IBOPPA,IFOUND,IERROR)
4712            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4713          ENDIF
4714        ENDIF
4715C
4716        IF(NUMARG.GE.2)THEN
4717          IF(IHARG(1).EQ.'FILL'.AND.IHARG(2).EQ.'THIC')THEN
4718            CALL DPBOFT(IHARG,IARGT,IARG,ARG,NUMARG,PDEFTH,
4719     1                  MAXBOX,PBOFTH,IFOUND,IERROR)
4720            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4721          ENDIF
4722        ENDIF
4723        IF(NUMARG.GE.3)THEN
4724          IF(IHARG(2).EQ.'FILL'.AND.IHARG(3).EQ.'THIC')THEN
4725            CALL DPBOFT(IHARG,IARGT,IARG,ARG,NUMARG,PDEFTH,
4726     1                  MAXBOX,PBOFTH,IFOUND,IERROR)
4727            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4728          ENDIF
4729        ENDIF
4730C
4731        IF(NUMARG.GE.2)THEN
4732          IF(IHARG(1).EQ.'FILL'.AND.IHARG(2).EQ.'GAP')THEN
4733            CALL DPBOFG(IHARG,IARGT,IARG,ARG,NUMARG,PDEFGA,
4734     1                  MAXBOX,PBOPGA,IFOUND,IERROR)
4735            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4736          ENDIF
4737        ENDIF
4738        IF(NUMARG.GE.3)THEN
4739          IF(IHARG(2).EQ.'FILL'.AND.IHARG(3).EQ.'GAP')THEN
4740            CALL DPBOFG(IHARG,IARGT,IARG,ARG,NUMARG,PDEFGA,
4741     1                  MAXBOX,PBOPGA,IFOUND,IERROR)
4742            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4743          ENDIF
4744        ENDIF
4745C
4746        IF(NUMARG.GE.1)THEN
4747          IF(IHARG(1).EQ.'SHAD')THEN
4748             CALL DPBSHW(IHARG,IARGT,IARG,ARG,NUMARG,PDEFSH,PDEFSW,
4749     1                   MAXBOX,PBOSHE,PBOSWI,IFOUND,IERROR)
4750             IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4751          ENDIF
4752        ENDIF
4753        IF(NUMARG.GE.2)THEN
4754          IF(IHARG(2).EQ.'SHAD')THEN
4755            CALL DPBSHW(IHARG,IARGT,IARG,ARG,NUMARG,PDEFSH,PDEFSW,
4756     1                  MAXBOX,PBOSHE,PBOSWI,IFOUND,IERROR)
4757            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4758          ENDIF
4759        ENDIF
4760C
4761      ENDIF
4762C
4763C               *************************************************
4764C               **  TREAT THE FRAME (CORNER) COORDINATES CASE  **
4765C               *************************************************
4766C
4767      IF(ICOM.EQ.'FRAM')THEN
4768        IF(NUMARG.GE.2.AND.IHARG(1).EQ.'CORN'.AND.
4769     1     IHARG(2).EQ.'COOR')THEN
4770          ISHIFT=1
4771          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
4772     1                IBUGP2,IERROR)
4773        ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'COOR')THEN
4774          CONTINUE
4775        ELSE
4776          GOTO1299
4777        ENDIF
4778        CALL DPFRCC(IHARG,IHARG2,IARGT,ARG,NUMARG,
4779     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,
4780     1              MAXNAM,IANS,IWIDTH,
4781     1              PXMIN,PXMAX,PYMIN,PYMAX,
4782     1              IBUGP2,IFOUND,IERROR)
4783        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4784      ENDIF
4785C
4786 1299 CONTINUE
4787C
4788C               **************************************
4789C               **  TREAT THE FRAME COLOR CASE      **
4790C               **            FRAME PATTERN CASE    **
4791C               **            FRAME THICKNESS CASE  **
4792C               **            FRAME CASE            **
4793C               **************************************
4794C
4795      IF(ICOM.EQ.'XFRA' .OR. ICOM.EQ.'X1FR' .OR. ICOM.EQ.'X2FR' .OR.
4796     1   ICOM.EQ.'YFRA' .OR. ICOM.EQ.'Y1FR' .OR. ICOM.EQ.'Y2FR' .OR.
4797     1   ICOM.EQ.'XYFR' .OR. ICOM.EQ.'YXFR' .OR. ICOM.EQ.'FRAM' .OR.
4798     1   ICOM.EQ.'3DFR')THEN
4799C
4800        IF(ICOM.EQ.'3DFR')GOTO1310
4801C
4802        IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COLO')THEN
4803          CALL DPFRCL(ICOM,IHARG,NUMARG,
4804     1                IDEFCO,IX1FCO,IX2FCO,IY1FCO,IY2FCO,
4805     1                IFOUND,IERROR)
4806          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4807C
4808        ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'PATT')THEN
4809          CALL DPFRPA(ICOM,IHARG,IHARG2,NUMARG,
4810     1                IDEFPA,IX1FPA,IX2FPA,IY1FPA,IY2FPA,
4811     1                IFOUND,IERROR)
4812          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4813C
4814        ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'THIC')THEN
4815          CALL DPFRTH(ICOM,IHARG,ARG,NUMARG,
4816     1                PDEFTH,PFRATH,
4817     1                IFOUND,IERROR)
4818          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4819        ENDIF
4820C
4821 1310   CONTINUE
4822C
4823        CALL DPFRAM(ICOM,IHARG,NUMARG,
4824     1              IX1FSW,IX2FSW,IY1FSW,IY2FSW,FRAM3D,
4825     1              IFOUND,IERROR)
4826        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4827      ENDIF
4828C
4829C               **************************************
4830C               **  TREAT THE GRID  THICKNESS CASE  **
4831C               **            GRID  COLOR CASE      **
4832C               **            GRID  PATTERN CASE    **
4833C               **            GRID CASE             **
4834C               **************************************
4835C
4836      IF(ICOM.EQ.'XGRI' .OR. ICOM.EQ.'YGRI' .OR. ICOM.EQ.'XYGR' .OR.
4837     1   ICOM.EQ.'YXGR' .OR. ICOM.EQ.'GRID')THEN
4838C
4839        IF(NUMARG.GE.1.AND.IHARG(1).EQ.'THIC')THEN
4840          CALL DPGRTH(ICOM,IHARG,ARG,NUMARG,
4841     1                PDEFTH,PVGRTH,PHGRTH,
4842     1                IFOUND,IERROR)
4843          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4844C
4845        ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'COLO')THEN
4846          CALL DPGRCL(ICOM,IHARG,NUMARG,
4847     1                IDEFCO,IVGRCO,IHGRCO,
4848     1                IFOUND,IERROR)
4849          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4850        ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'PATT')THEN
4851          CALL DPGRPA(ICOM,IHARG,IHARG2,NUMARG,
4852     1                IDEFPA,IVGRPA,IHGRPA,
4853     1                IFOUND,IERROR)
4854          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4855        ELSE
4856C
4857          CALL DPGRID(ICOM,IHARG,NUMARG,IVGRSW,IHGRSW,IFOUND,IERROR)
4858          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4859C
4860        ENDIF
4861C
4862      ENDIF
4863C
4864C               ********************************************
4865C               **  TREAT THE LABEL FONT            CASE  **
4866C               **            LABEL CASE            CASE  **
4867C               **            LABEL FILL            CASE  **
4868C               **            LABEL JUSTIFICATION   CASE  **
4869C               **            LABEL THICKNESS       CASE  **
4870C               **            LABEL DISPLACEMENT    CASE  **
4871C               **            LABEL OFFSET          CASE  **
4872C               **            LABEL ANGLE           CASE  **
4873C               **            LABEL DIRECTION       CASE  **
4874C               **            LABEL COLORS          CASE  **
4875C               **            LABEL SIZES           CASE  **
4876C               **            LABEL REFERENCE POINT CASE  **
4877C               **            LABEL                 CASE  **
4878C               ********************************************
4879C
4880      IF(ICOM.EQ.'LABE' .OR. ICOM.EQ.'XLAB' .OR. ICOM.EQ.'X1LA' .OR.
4881     1   ICOM.EQ.'X2LA' .OR. ICOM.EQ.'X3LA' .OR. ICOM.EQ.'YLAB' .OR.
4882     1   ICOM.EQ.'Y1LA' .OR. ICOM.EQ.'Y2LA')THEN
4883C
4884        CALL DPLAFO(ICOM,IHARG,NUMARG,
4885     1              IDEFFO,IX1LFO,IX2LFO,IX3LFO,IY1LFO,IY2LFO,
4886     1              IFOUND,IERROR)
4887        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4888C
4889        CALL DPLACA(ICOM,IHARG,NUMARG,
4890     1              IDEFCA,IX1LCA,IX2LCA,IX3LCA,IY1LCA,IY2LCA,
4891     1              IFOUND,IERROR)
4892         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4893C
4894        CALL DPLAFI(ICOM,IHARG,NUMARG,
4895     1              IDEFFI,IX1LFI,IX2LFI,IX3LFI,IY1LFI,IY2LFI,
4896     1              IFOUND,IERROR)
4897        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4898C
4899        CALL DPLAJU(ICOM,IHARG,NUMARG,
4900     1              IDEFJU,IX1LJU,IX2LJU,IX3LJU,IY1LJU,IY2LJU,
4901     1              IBUGPC,IFOUND,IERROR)
4902        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4903C
4904        CALL DPLATH(ICOM,IHARG,ARG,NUMARG,
4905     1              PDEFTH,PX1LTH,PX2LTH,PX3LTH,PY1LTH,PY2LTH,
4906     1              IFOUND,IERROR)
4907        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4908C
4909        CALL DPLADS(ICOM,IHARG,ARG,NUMARG,
4910     1              PDEFDS,PX1LDS,PX2LDS,PX3LDS,PY1LDS,PY2LDS,
4911     1              IFOUND,IERROR)
4912        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4913C
4914        CALL DPLAOF(ICOM,IHARG,IARGT,ARG,NUMARG,
4915     1              PDEFOF,PX1LOF,PX2LOF,PX3LOF,PY1LOF,PY2LOF,
4916     1              IFOUND,IERROR)
4917        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4918C
4919        CALL DPLAAN(ICOM,IHARG,IARGT,ARG,NUMARG,
4920     1              ADEFAN,PX1LAN,PX2LAN,PX3LAN,PY1LAN,PY2LAN,
4921     1              IFOUND,IERROR)
4922        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4923C
4924        CALL DPLADI(ICOM,IHARG,NUMARG,
4925     1              IDEFDI,IX1LDI,IX2LDI,IX3LDI,IY1LDI,IY2LDI,
4926     1              IFOUND,IERROR)
4927        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4928C
4929        CALL DPLACL(ICOM,IHARG,NUMARG,
4930     1              IDEFCO,IX1LCO,IX2LCO,IX3LCO,IY1LCO,IY2LCO,
4931     1              IFOUND,IERROR)
4932        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4933C
4934        CALL DPLASZ(ICOM,IHARG,IARGT,ARG,NUMARG,
4935     1              PDEFHE,PDEFWI,
4936     1              PX1LHE,PX1LWI,PX1LVG,PX1LHG,
4937     1              PX2LHE,PX2LWI,PX2LVG,PX2LHG,
4938     1              PX3LHE,PX3LWI,PX3LVG,PX3LHG,
4939     1              PY1LHE,PY1LWI,PY1LVG,PY1LHG,
4940     1              PY2LHE,PY2LWI,PY2LVG,PY2LHG,
4941     1              IFOUND,IERROR)
4942        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4943C
4944        CALL DPLACO(ICOM,IHARG,IARGT,ARG,NUMARG,
4945     1              PX1LXC,PX1LYC,PX2LXC,PX2LYC,PX3LXC,PX3LYC,
4946     1              PY1LXC,PY1LYC,PY2LXC,PY2LYC,
4947     1              IFOUND,IERROR)
4948        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4949C
4950        CALL DPLAB(IANS,IANSLC,IWIDTH,IHARG,IHARG2,NUMARG,
4951     1             IX1LTE,NCX1LA,IX1AUT,
4952     1             IX2LTE,NCX2LA,IX2AUT,
4953     1             IX3LTE,NCX3LA,IX3AUT,
4954     1             IY1LTE,NCY1LA,IY1AUT,
4955     1             IY2LTE,NCY2LA,IY2AUT,
4956     1             IBUGP2,IFOUND,IERROR)
4957        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4958C
4959      ENDIF
4960C
4961C               ***********************************************
4962C               **  TREAT THE LEGEND ... FONT          CASE  **
4963C               **            LEGEND ... CASE          CASE  **
4964C               **            LEGEND ... JUSTIFICATION CASE  **
4965C               **            LEGEND ... DIRECTION     CASE  **
4966C               **            LEGEND ... UNITS         CASE  **
4967C               **            LEGEND ... FILL          CASE  **
4968C               **            LEGEND ... THICKNESS     CASE  **
4969C               **            LEGEND ... ANGLE         CASE  **
4970C               **            LEGEND ... COLORS        CASE  **
4971C               **            LEGEND ... COORDINATES   CASE  **
4972C               **            LEGEND ... SIZES         CASE  **
4973C               **            LEGEND ... HW            CASE  **
4974C               **            LEGEND ...               CASE  **
4975C               ***********************************************
4976C
4977      IF(ICOM.EQ.'LEGE')THEN
4978C
4979        CALL DPLEFO(IHARG,IARGT,IARG,NUMARG,IDEFFO,
4980     1              MAXLEG,ILEGFO,IFOUND,IERROR)
4981        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4982C
4983        CALL DPLECA(IHARG,IARGT,IARG,NUMARG,IDEFCA,
4984     1              MAXLEG,ILEGCA,IFOUND,IERROR)
4985        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4986C
4987        CALL DPLEJU(IHARG,IARGT,IARG,NUMARG,IDEFJU,
4988     1              MAXLEG,ILEGJU,IFOUND,IERROR)
4989        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4990C
4991        CALL DPLEDI(IHARG,IHARG2,IARGT,IARG,NUMARG,IDEFDI,
4992     1              MAXLEG,ILEGDI,IFOUND,IERROR)
4993        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4994C
4995        CALL DPLEUN(IHARG,IARGT,IARG,NUMARG,IDEFUZ,
4996     1              MAXLEG,ILEGUN,IFOUND,IERROR)
4997        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
4998C
4999        CALL DPLEFI(IHARG,IARGT,IARG,NUMARG,IDEFFI,
5000     1              MAXLEG,ILEGFI,IFOUND,IERROR)
5001        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5002C
5003        CALL DPLETH(IHARG,IARGT,IARG,ARG,NUMARG,PDEFTH,
5004     1              MAXLEG,PLEGTH,IFOUND,IERROR)
5005        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5006C
5007        CALL DPLEAN(IHARG,IARGT,IARG,ARG,NUMARG,ADEFAN,
5008     1              MAXLEG,ALEGAN,IFOUND,IERROR)
5009        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5010C
5011        CALL DPLECL(IHARG,IARGT,IARG,NUMARG,IDEFCO,
5012     1              MAXLEG,ILEGCO,IFOUND,IERROR)
5013        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5014C
5015        CALL DPLECO(IHARG,IHARG2,IARGT,IARG,ARG,NUMARG,
5016     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,
5017     1              MAXNAM,IANS,IWIDTH,
5018     1              MAXLEG,PLEGXC,PLEGYC,IBUGP2,IFOUND,IERROR)
5019        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5020C
5021        CALL DPLESZ(IHARG,IARGT,IARG,ARG,NUMARG,
5022     1              PDEFHE,PDEFWI,MAXLEG,
5023     1              PLEGHE,PLEGWI,PLEGVG,PLEGHG,
5024     1              IFOUND,IERROR)
5025        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5026C
5027        CALL DPLEHW(IHARG,IARGT,IARG,ARG,NUMARG,
5028     1              PDEFHE,MAXLEG,PLEGHE,PLEGWI,PLEGVG,PLEGHG,
5029     1              IFOUND,IERROR)
5030        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5031C
5032        CALL DPLEG(IHARG,IARG,ARG,IARGT,NUMARG,IANS,IANSLC,IWIDTH,
5033     1             ILEGNA,ILEGST,ILEGSP,NUMLEG,MAXLEG,
5034     1             ILEGTE,NCLEG,MXCLEG,IFOUND,IERROR,IBUGP2)
5035        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5036C
5037      ENDIF
5038C
5039C               ********************************
5040C               **  TREAT THE ...LIMITS CASE  **
5041C               ********************************
5042C
5043      IF(ICOM.EQ.'XLIM' .OR. ICOM.EQ.'X1LI' .OR. ICOM.EQ.'X2LI' .OR.
5044     1   ICOM.EQ.'YLIM' .OR. ICOM.EQ.'Y1LI' .OR. ICOM.EQ.'Y2LI' .OR.
5045     1   ICOM.EQ.'XYLI' .OR. ICOM.EQ.'YXLI' .OR. ICOM.EQ.'LIMI')THEN
5046C
5047        IF(IHARG(1).EQ.'OF  '.AND.IHARG(2).EQ.'DETE')GOTO2499
5048C
5049        CALL DPLIM(ICOM,IHARG,IARGT,ARG,NUMARG,
5050     1             GX1MIN,GX1MAX,GY1MIN,GY1MAX,
5051     1             GX2MIN,GX2MAX,GY2MIN,GY2MAX,
5052     1             FX1MIN,FX1MAX,FY1MIN,FY1MAX,
5053     1             FX2MIN,FX2MAX,FY2MIN,FY2MAX,
5054     1             IX1MIN,IX1MAX,IY1MIN,IY1MAX,
5055     1             IX2MIN,IX2MAX,IY2MIN,IY2MAX,
5056     1             FX1MNZ,FX1MXZ,FX2MNZ,FX2MXZ,
5057     1             FY1MNZ,FY1MXZ,FY2MNZ,FY2MXZ,
5058     1             IFOUND,IERROR)
5059        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5060C
5061      ENDIF
5062C
5063 2499 CONTINUE
5064C
5065C               ****************************************
5066C               **  TREAT THE LINE COLORS       CASE  **
5067C               **  TREAT THE LINE THICKNESS    CASE  **
5068C               **  TREAT THE LINE UNITS        CASE  **
5069C               **  TREAT THE LINE              CASE  **
5070C               ****************************************
5071C
5072      IF(ICOM.EQ.'LINE')THEN
5073C
5074        IF(IHARG(1).EQ.'COLO')THEN
5075          CALL DPLICL(IHARG,NUMARG,IDEFCO,MAXLIN,ILINCO,IFOUND,IERROR)
5076          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5077C
5078        ELSEIF(IHARG(1).EQ.'UNIT')THEN
5079          CALL DPLIUN(IHARG,NUMARG,MAXLIN,ILINTY,IFOUND,IERROR)
5080          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5081C
5082        ELSEIF(IHARG(1).EQ.'THIC')THEN
5083          CALL DPLITH(IHARG,IARGT,ARG,NUMARG,PDEFLT,MAXLIN,PLINTH,
5084     1                IBUGP2,IFOUND,IERROR)
5085          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5086C
5087        ELSE
5088          IF(ICOM2.NE.'AR  ')THEN
5089            CALL DPLINE(IHARG,IHARG2,NUMARG,MAXLIN,ILINPA,ILINPO,
5090     1                  IFOUND,IERROR)
5091            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5092          ENDIF
5093        ENDIF
5094C
5095      ENDIF
5096C
5097C               *****************************
5098C               **  TREAT THE ...LOG CASE  **
5099C               *****************************
5100C
5101      IF(ICOM.EQ.'XLOG' .OR. ICOM.EQ.'X1LO' .OR. ICOM.EQ.'X2LO' .OR.
5102     1   ICOM.EQ.'YLOG' .OR. ICOM.EQ.'Y1LO' .OR. ICOM.EQ.'Y2LO' .OR.
5103     1   ICOM.EQ.'LOG ' .OR. ICOM.EQ.'LOGL' .OR.
5104     1  (ICOM.EQ.'XYLO'.AND.ICOM2.EQ.'G   ') .OR.
5105     1  (ICOM.EQ.'YXLO'.AND.ICOM2.EQ.'G   '))THEN
5106C
5107CCCCC   APRIL 1995.  CHECK FOR LOG LOGISTIC PROB PLOT, LOG LOGISTIC PPCC
5108CCCCC                PLOT (ALSO ENTERED AS LOGLOGISTIC PROB PLOT)
5109CCCCC   SEPTEMBER 2001.  CHECK FOR LOG DOUBLE EXPO PROB PLOT,
5110CCCCC                    LOG DOUBLE EPXO PPCC PLOT
5111C
5112        IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PROB')GOTO2899
5113        IF(NUMARG.GE.2.AND.IHARG(2).EQ.'PROB')GOTO2899
5114        IF(NUMARG.GE.3.AND.IHARG(3).EQ.'PROB')GOTO2899
5115        IF(NUMARG.GE.4.AND.IHARG(4).EQ.'PROB')GOTO2899
5116        IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PPCC')GOTO2899
5117        IF(NUMARG.GE.2.AND.IHARG(2).EQ.'PPCC')GOTO2899
5118        IF(NUMARG.GE.3.AND.IHARG(3).EQ.'PPCC')GOTO2899
5119        IF(NUMARG.GE.4.AND.IHARG(4).EQ.'PPCC')GOTO2899
5120        IF(NUMARG.GE.1.AND.IHARG(1).EQ.'KOLM')GOTO2899
5121        IF(NUMARG.GE.2.AND.IHARG(2).EQ.'KOLM')GOTO2899
5122        IF(NUMARG.GE.3.AND.IHARG(3).EQ.'KOLM')GOTO2899
5123        IF(NUMARG.GE.4.AND.IHARG(4).EQ.'KOLM')GOTO2899
5124        IF(NUMARG.GE.1.AND.IHARG(1).EQ.'KS  ')GOTO2899
5125        IF(NUMARG.GE.2.AND.IHARG(2).EQ.'KS  ')GOTO2899
5126        IF(NUMARG.GE.3.AND.IHARG(3).EQ.'KS  ')GOTO2899
5127        IF(NUMARG.GE.4.AND.IHARG(4).EQ.'KS  ')GOTO2899
5128        IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CHI ')GOTO2899
5129        IF(NUMARG.GE.2.AND.IHARG(2).EQ.'CHI ')GOTO2899
5130        IF(NUMARG.GE.3.AND.IHARG(3).EQ.'CHI ')GOTO2899
5131        IF(NUMARG.GE.4.AND.IHARG(4).EQ.'CHI ')GOTO2899
5132        IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CHIS')GOTO2899
5133        IF(NUMARG.GE.2.AND.IHARG(2).EQ.'CHIS')GOTO2899
5134        IF(NUMARG.GE.3.AND.IHARG(3).EQ.'CHIS')GOTO2899
5135        IF(NUMARG.GE.4.AND.IHARG(4).EQ.'CHIS')GOTO2899
5136        IF(NUMARG.GE.1.AND.IHARG(1).EQ.'BETA')GOTO2899
5137C
5138        CALL DPTISC(ICOM,IHARG,NUMARG,
5139     1              IX1TSC,IX2TSC,IY1TSC,IY2TSC,
5140     1              IFOUND,IERROR)
5141        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5142C
5143      ENDIF
5144C
5145 2899 CONTINUE
5146C
5147C               ***********************************
5148C               **  TREAT THE MARGIN COLOR CASE  **
5149C               ***********************************
5150C
5151      IF(ICOM.EQ.'MARG'.AND.IHARG(1).EQ.'COLO')THEN
5152        CALL DPMACL(IHARG,NUMARG,IDEFMC,IMARCO,IFOUND,IERROR)
5153        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5154      ENDIF
5155C
5156C               *********************************
5157C               **  TREAT THE ...MAXIMUM CASE  **
5158C               *********************************
5159C
5160      IF(ICOM.EQ.'XMAX' .OR. ICOM.EQ.'X1MA' .OR. ICOM.EQ.'X2MA' .OR.
5161     1   ICOM.EQ.'YMAX' .OR. ICOM.EQ.'Y1MA' .OR. ICOM.EQ.'Y2MA' .OR.
5162     1   ICOM.EQ.'XYMA' .OR. ICOM.EQ.'YXMA' .OR. ICOM.EQ.'MAXI' .OR.
5163     1   ICOM.EQ.'MAX ')THEN
5164        IF(NUMARG.GE.1.AND.ICOM.EQ.'MAXI')THEN
5165          IF(NUMARG.GE.2.AND.IHARG(1).EQ.'STAT'.AND.IHARG(2).EQ.'PLOT')
5166     1      GOTO3099
5167          IF(NUMARG.GE.2.AND.IHARG(1).EQ.'BLOC'.AND.IHARG(2).EQ.'PLOT')
5168     1      GOTO3099
5169          IF(NUMARG.GE.3.AND.IHARG(1).EQ.'WIND'.AND.IHARG(2).EQ.'STAT'
5170     1      .AND.IHARG(3).EQ.'PLOT')GOTO3199
5171          IF(NUMARG.GE.3.AND.IHARG(1).EQ.'CUMU'.AND.IHARG(2).EQ.'STAT'
5172     1      .AND.IHARG(3).EQ.'PLOT')GOTO3199
5173          IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MOVI'.AND.IHARG(2).EQ.'STAT'
5174     1      .AND.IHARG(3).EQ.'PLOT')GOTO3199
5175          IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')GOTO3099
5176          IF(NUMARG.GE.1.AND.IHARG(1).EQ.'GRUB')GOTO3099
5177          IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TIET')GOTO3099
5178          IF(NUMARG.GE.1.AND.IHARG(1).EQ.'DIXO')GOTO3099
5179          IF(NUMARG.GE.2.AND.IHARG(2).EQ.'GRUB')GOTO3099
5180          IF(NUMARG.GE.2.AND.IHARG(2).EQ.'TIET')GOTO3099
5181          IF(NUMARG.GE.2.AND.IHARG(2).EQ.'DIXO')GOTO3099
5182          IF(NUMARG.GE.2.AND.IHARG(1).EQ.'RECO'.AND.IHARG(2).EQ.'LENG')
5183     1      GOTO3099
5184        ENDIF
5185C
5186        CALL DPMAX(ICOM,IHARG,IARGT,ARG,NUMARG,
5187     1             GX1MAX,GY1MAX,GX2MAX,GY2MAX,
5188     1             IX1MAX,IY1MAX,IX2MAX,IY2MAX,
5189     1             IFOUND,IERROR)
5190        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5191C
5192      ENDIF
5193C
5194 3099 CONTINUE
5195C
5196C               *********************************
5197C               **  TREAT THE ...MINIMUM CASE  **
5198C               *********************************
5199C
5200      IF(ICOM.EQ.'XMIN' .OR. ICOM.EQ.'X1MI' .OR. ICOM.EQ.'X2MI' .OR.
5201     1   ICOM.EQ.'YMIN' .OR. ICOM.EQ.'Y1MI' .OR. ICOM.EQ.'Y2MI' .OR.
5202     1   ICOM.EQ.'XYMI' .OR. ICOM.EQ.'YXMI' .OR. ICOM.EQ.'MINI' .OR.
5203     1   ICOM.EQ.'MIN ')THEN
5204C
5205        IF(NUMARG.GE.1.AND.ICOM.EQ.'MINI')THEN
5206          IF(NUMARG.GE.2.AND.IHARG(1).EQ.'STAT'.AND.IHARG(2).EQ.'PLOT')
5207     1      GOTO3199
5208          IF(NUMARG.GE.2.AND.IHARG(1).EQ.'BLOC'.AND.IHARG(2).EQ.'PLOT')
5209     1      GOTO3199
5210          IF(NUMARG.GE.3.AND.IHARG(1).EQ.'WIND'.AND.IHARG(2).EQ.'STAT'
5211     1      .AND.IHARG(3).EQ.'PLOT')GOTO3199
5212          IF(NUMARG.GE.3.AND.IHARG(1).EQ.'CUMU'.AND.IHARG(2).EQ.'STAT'
5213     1      .AND.IHARG(3).EQ.'PLOT')GOTO3199
5214          IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MOVI'.AND.IHARG(2).EQ.'STAT'
5215     1      .AND.IHARG(3).EQ.'PLOT')GOTO3199
5216          IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')GOTO3199
5217          IF(NUMARG.GE.1.AND.IHARG(1).EQ.'GRUB')GOTO3199
5218          IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TIET')GOTO3199
5219          IF(NUMARG.GE.1.AND.IHARG(1).EQ.'DIXO')GOTO3199
5220          IF(NUMARG.GE.2.AND.IHARG(2).EQ.'GRUB')GOTO3199
5221          IF(NUMARG.GE.2.AND.IHARG(2).EQ.'TIET')GOTO3199
5222          IF(NUMARG.GE.2.AND.IHARG(2).EQ.'DIXO')GOTO3199
5223        ENDIF
5224C
5225        CALL DPMIN(ICOM,IHARG,IARGT,ARG,NUMARG,
5226     1             GX1MIN,GY1MIN,GX2MIN,GY2MIN,
5227     1             IX1MIN,IY1MIN,IX2MIN,IY2MIN,
5228     1             IFOUND,IERROR)
5229        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5230C
5231      ENDIF
5232C
5233 3199 CONTINUE
5234C
5235C               *******************************
5236C               **  TREAT THE PRE-SORT CASE  **
5237C               *******************************
5238C
5239      IF(ICOM.EQ.'PRE')THEN
5240        CALL DPPRES(IHARG,NUMARG,ISORSW,IFOUND,IERROR)
5241        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5242      ENDIF
5243C
5244C               *******************************************
5245C               **  TREAT THE ...WEIB (SCALE) AXIS CASE  **
5246C               *******************************************
5247C
5248      IF(ICOM.EQ.'XWEI' .OR. ICOM.EQ.'X1WE' .OR. ICOM.EQ.'X2WE' .OR.
5249     1   ICOM.EQ.'YWEI' .OR. ICOM.EQ.'Y1WE' .OR. ICOM.EQ.'Y2WE' .OR.
5250     1  (ICOM.EQ.'XYWE'.AND.ICOM2.EQ.'IB  ') .OR.
5251     1  (ICOM.EQ.'YXWE'.AND.ICOM2.EQ.'IB  '))THEN
5252C
5253        CALL DPTIS2(ICOM,IHARG,NUMARG,
5254     1              IX1TSC,IX2TSC,IY1TSC,IY2TSC,
5255     1              IFOUND,IERROR)
5256        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5257C
5258      ENDIF
5259C
5260C               *********************************************
5261C               **  TREAT THE SEGMENT ... COLOR CASE       **
5262C               **            SEGMENT ... PATTERN CASE     **
5263C               **            SEGMENT ... THICKNESS CASE   **
5264C               **            SEGMENT ... COORDINATES CASE **
5265C               *********************************************
5266C
5267      IF(ICOM.EQ.'SEGM')THEN
5268        CALL DPSECL(IHARG,IARGT,IARG,NUMARG,IDEFCO,
5269     1              MAXSEG,ISEGCO,IFOUND,IERROR)
5270        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5271C
5272        CALL DPSEPA(IHARG,IHARG2,IARGT,IARG,NUMARG,IDEFPA,
5273     1              MAXSEG,ISEGPA,IFOUND,IERROR)
5274        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5275C
5276        CALL DPSETH(IHARG,IARGT,IARG,ARG,NUMARG,PDEFTH,
5277     1              MAXSEG,PSEGTH,IFOUND,IERROR)
5278        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5279C
5280        CALL DPSECO(IHARG,IHARG2,IARGT,IARG,ARG,NUMARG,
5281     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
5282     1              IANS,IWIDTH,
5283     1              MAXSEG,PSEGXC,PSEGYC,NUMSEG,IBUGP2,IFOUND,IERROR)
5284        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5285C
5286      ENDIF
5287C
5288C               *******************************
5289C               **  TREAT THE SEQUENCE CASE  **
5290C               *******************************
5291C
5292      IF(ICOM.EQ.'SEQU')THEN
5293        CALL DPSEQ(IHARG,IARGT,IARG,NUMARG,
5294     1             ISEQSW,NUMSEQ,IFOUND,IERROR)
5295        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5296      ENDIF
5297C
5298C               ***************************************************
5299C               **  TREAT THE CHARACTER COLORS CASE              **
5300C               **            CHARACTER FONT   CASE              **
5301C               **            CHARACTER CASE   CASE              **
5302C               **            CHARACTER MAPPING CASE             **
5303C               **            CHARACTER THICKNESS CASE           **
5304C               **            CHARACTER SIZES CASE               **
5305C               **            CHARACTER FILL   CASE              **
5306C               **            CHARACTER WIDTH CASE               **
5307C               **            CHARACTER JUSTIFICATION CASE       **
5308C               **            CHARACTER OFFSET CASE              **
5309C               **            CHARACTER ANGLE CASE               **
5310C               **            CHARACTER HW (HEIGHT & WIDTH) CASE **
5311C               **            CHARACTER UNIT   CASE              **
5312C               **            CHARACTERS CASE                    **
5313C               ***************************************************
5314C
5315      IF(ICOM.EQ.'CHAR')THEN
5316        IF(IHARG(1).EQ.'COLO')THEN
5317          CALL DPCHCL(IHARG,NUMARG,IDEFCO,MAXCHA,ICHACO,IFOUND,IERROR)
5318          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5319        ELSEIF(IHARG(1).EQ.'FONT')THEN
5320          CALL DPCHFO(IHARG,NUMARG,IDEFFO,MAXCHA,ICHAFO,IFOUND,IERROR)
5321          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5322        ELSEIF(IHARG(1).EQ.'CASE')THEN
5323          CALL DPCHCA(IHARG,NUMARG,IDEFCA,MAXCHA,ICHACA,IFOUND,IERROR)
5324          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5325        ELSEIF(IHARG(1).EQ.'MAP'.OR.IHARG(1).EQ.'MAPP')THEN
5326          CALL DPCMAP(IHARG,NUMARG,IDCMAP,ICHMAP,IFOUND,IERROR)
5327          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5328        ELSEIF(IHARG(1).EQ.'THIC')THEN
5329          CALL DPCHTH(IHARG,ARG,NUMARG,PDEFTH,MAXCHA,PCHATH,
5330     1                IFOUND,IERROR)
5331          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5332        ELSEIF(IHARG(1).EQ.'SIZE' .OR. IHARG(1).EQ.'HEIG')THEN
5333          CALL DPCHSZ(PDEFHE,MAXCHA,PCHAHE,PCHAWI,PCHAVG,PCHAHG,
5334     1                IBUGP2,IBUGQ,IFOUND,IERROR)
5335          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5336        ELSEIF(IHARG(1).EQ.'FILL')THEN
5337          CALL DPCHFI(IHARG,NUMARG,IDEFFI,MAXCHA,ICHAFI,IFOUND,IERROR)
5338          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5339        ELSEIF(IHARG(1).EQ.'WIDT'.OR.IHARG(2).EQ.'WIDT')THEN
5340          CALL DPCHWI(IHARG,IARGT,ARG,NUMARG,
5341     1                PDEFWI,MAXCHA,PCHAWI,PCHAHG,
5342     1                IFOUND,IERROR)
5343          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5344        ELSEIF(IHARG(1).EQ.'JUST'.AND.IHARG2(1).EQ.'IFIC')THEN
5345          CALL DPCHJU(IHARG,NUMARG,MAXCHA,ICHAJU,IFOUND,IERROR)
5346          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5347        ELSEIF((IHARG(1).EQ.'OFFS'.AND.IHARG2(1).EQ.'ET  ').OR.
5348     1         (IHARG(1).EQ.'DISP'.AND.IHARG2(1).EQ.'LACE'))THEN
5349          CALL DPCHOF(IHARG,IARGT,ARG,NUMARG,
5350     1                MAXCHA,PCHAHO,PCHAVO,
5351     1                IFOUND,IERROR)
5352          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5353        ELSEIF(IHARG(1).EQ.'ANGL'.AND.IHARG2(1).EQ.'E   ')THEN
5354          CALL DPCHAN(MAXCHA,ACHAAN,IBUGP2,IBUGQ,IFOUND,IERROR)
5355          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5356        ELSEIF(IHARG(1).EQ.'HW')THEN
5357          CALL DPCHHW(IHARG,IARGT,ARG,NUMARG,
5358     1                MAXCHA,PCHAHE,PCHAWI,PDEFHE,PDEFWI,
5359     1                IFOUND,IERROR)
5360          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5361        ELSEIF(IHARG(1).EQ.'UNIT')THEN
5362          CALL DPCHUN(IHARG,NUMARG,MAXCHA,ICHATY,IFOUND,IERROR)
5363          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5364        ELSE
5365          CALL DPCHAR(MAXCHA,ICHAPA,ICHAPO,
5366     1                IBUGP2,IBUGQ,ISUBRO,IFOUND,IERROR)
5367          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5368        ENDIF
5369      ENDIF
5370C
5371CCCCC THE FOLLOWING ANIMATION SWITCH CHUNK WAS ADDED APRIL 1989
5372C               **************************************************
5373C               **  TREAT THE ANIMATION SWITCH CASE             **
5374C               **************************************************
5375C
5376      IF(ICOM.EQ.'ANIM' .OR. ICOM.EQ.'UNDR')THEN
5377        CALL DPANIM(IHARG,NUMARG,IANISW,IFOUND,IERROR)
5378        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5379      ENDIF
5380C
5381CCCCC THE FOLLOWING 3 DES. FOP EXP. SECTIONS WERE ADDED MAY 1989
5382C               ******************************************
5383C               **  TREAT THE DEX WIDTH            CASE **
5384C               **            DEX DEPTH            CASE **
5385C               **            DEX HORIZONTAL AXIS  CASE **
5386C               ******************************************
5387C
5388      IF(ICOM.EQ.'DEX')THEN
5389C
5390        IF(NUMARG.GE.1.AND.IHARG(1).EQ.'WIDT')THEN
5391          CALL DPDEWI(IHARG,ARG,NUMARG,DEFDEW,
5392     1                DEXWID,IFOUND,IERROR)
5393          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5394C
5395        ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'DEPT')THEN
5396          CALL DPDEDE(IHARG,IARG,NUMARG,IDEDED,
5397     1                IDEXDE,IFOUND,IERROR)
5398          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5399C
5400        ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'HORI'.AND.
5401     1         IHARG(2).EQ.'AXIS')THEN
5402          CALL DPDEHA(IHARG,NUMARG,IDEFHA,
5403     1                IDEXHA,IFOUND,IERROR)
5404          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5405C
5406        ENDIF
5407      ENDIF
5408C
5409C               *****************
5410C               **  STEP 90--  **
5411C               **  EXIT       **
5412C               *****************
5413C
5414 9000 CONTINUE
5415      IF(IBUGPC.EQ.'ON' .OR. ISUBRO.EQ.'IPC1')THEN
5416        WRITE(ICOUT,999)
5417        CALL DPWRST('XXX','BUG ')
5418        WRITE(ICOUT,9011)
5419 9011   FORMAT('***** AT THE END       OF MAIPC1--')
5420        CALL DPWRST('XXX','BUG ')
5421        WRITE(ICOUT,9020)IFOUND,IERROR
5422 9020   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
5423        CALL DPWRST('XXX','BUG ')
5424        WRITE(ICOUT,9051)DEXWID,IDEXDE,IDEXHA
5425 9051   FORMAT('DEXWID,IDEXDE,IDEXHA = ',E15.7,I8,2X,A4)
5426        CALL DPWRST('XXX','BUG ')
5427      ENDIF
5428C
5429      RETURN
5430      END
5431      SUBROUTINE MAIPC2(IBUGPC,IBUGP2,ISUBRO,
5432     1                  IVGMSW,IHGMSW,
5433     1                  IMPSW,IMPNR,IMPNC,IMPCO,IMPCO2,
5434CCCCC ADD FOLLOWING LINE AUGUST 1999.
5435     1                  IMPARG,
5436     1                  PMXMIN,PMXMAX,PMYMIN,PMYMAX,
5437     1                  IERASV,
5438     1                  PWXMIS,PWXMAS,PWYMIS,PWYMAS,
5439CCCCC THE FOLLOWING LINE WAS ADDED AUGUST 1992
5440     1                  ITIAUT,
5441     1                  IFOUND,IERROR)
5442C
5443C     PURPOSE--THIS IS SUBROUTING MAIPC2.
5444C              (THE   PC    AT THE END OF    MAIPC2   STANDS FOR PLOT CONTROL
5445C              THIS SUBROUTINE SEARCHES FOR AND EXECUTES
5446C              PLOT CONTROL COMMANDS (PART 2).
5447C
5448C     WRITTEN BY--JAMES J. FILLIBEN
5449C                 STATISTICAL ENGINEERING DIVISION
5450C                 INFORMATION TECHNOLOGY LABORATORY
5451C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
5452C                 GAITHERSBURG, MD 20899-8980
5453C                 PHONE--301-975-2855
5454C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
5455C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
5456C     LANGUAGE--ANSI FORTRAN (1977)
5457C     VERSION NUMBER--82.6
5458C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--JULY 1986.
5459C     UPDATED  JANUARY    1988.  (OPTIONAL OMISSION OF WORD  MAJOR)
5460C     UPDATED         --SEPTEMBER 1988. 3D PROJECTION (ORTHOGRAP./PERSPECT.)
5461C     UPDATED         --SEPTEMBER 1988. PROJECTION (ORTHOGRAPHIC/PERSPECTIVE)
5462C                       MOVED TO MAIPC4 FOR GENERAL 3-D.
5463C     UPDATED         --SEPTEMBER 1988.  VISIBLE
5464C                       MOVED TO MAIPC4 FOR GENERAL 3-D.
5465C     UPDATED         --DECEMBER 1988.  TIC/TIC LABEL/TITLE SIZE DEFAULT WIDTH
5466C     UPDATED         --FEBRUARY 1989.  ADDED MANY ATTRIBUTE COMMANDS (ALAN)
5467C     UPDATED         --JULY     1989.  TITLE DISPLACEMENT
5468C     UPDATED         --MAY      1990.  TIC MARK OFFSET
5469C     UPDATED         --AUGUST   1990.  MP FOR MULTIPLOT
5470C     UPDATED         --AUGUST   1990.  WINDOW SYSTEM
5471C     UPDATED         --AUGUST   1990.  WINDOW POINTER
5472C     UPDATED         --AUGUST   1990.  WINDOW SYSTEM COMMON
5473C     UPDATED         --AUGUST   1991.  TIC LABEL DISPLACEMENT
5474C     UPDATED         --APRIL    1992.  GRID PATTERN CODE REDUNDANT
5475C     UPDATED         --AUGUST   1992.  ADD TITLE SWITCH FOR AUTOMATIC
5476C     UPDATED         --DECEMBER 1992.  FIX CALL TO DPTLDS
5477C     UPDATED         --SEPTEMBER 1993. LOWER CASE--TIC LABEL CONTENTS
5478C     UPDATED         --SEPTEMBER 1993. LOWER CASE FOR TITLE
5479C     UPDATED         --SEPTEMBER 1993. CHAR*4 FOR ITIAUT
5480C     UPDATED         --AUGUST    1995. DASH2 BUG (VARIOUS)
5481C     UPDATED         --APRIL     1997. PIXMAP TITLE COMMAND
5482C     UPDATED         --SEPTEMBER 1998. CALL TO DPMULT
5483C     UPDATED         --AUGUST    1999. CALL TO DPMULT
5484C     UPDATED         --NOVEMBER  1999. SUBREGION SWITCH
5485C     UPDATED         --MAY       2015. EMBED
5486C                                       EMBDED HW
5487C                                       EMBDED CORNER COORDINATES
5488C                                       EMBDED POSITION
5489C                                       EMBDED HORIZONTAL JUSTIFICATION
5490C                                       EMBDED VERTICAL JUSTIFICATION
5491C
5492C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
5493C
5494      CHARACTER*4 IBUGPC
5495      CHARACTER*4 IBUGP2
5496      CHARACTER*4 ISUBRO
5497C
5498      CHARACTER*4 IVGMSW
5499      CHARACTER*4 IHGMSW
5500C
5501      CHARACTER*4 IMPSW
5502      CHARACTER*4 IERASV
5503C
5504CCCCC THE FOLLOWING LINE WAS ADDED    SEPTEMBER 1993
5505      CHARACTER*4 ITIAUT
5506CCCCC OCTOBER 1996
5507CCCCC CHARACTER*4 IWINPO
5508C
5509      CHARACTER*4 IFOUND
5510      CHARACTER*4 IERROR
5511C
5512C-----COMMON----------------------------------------------------------
5513C
5514      INCLUDE 'DPCOPA.INC'
5515      INCLUDE 'DPCOHK.INC'
5516      INCLUDE 'DPCOPC.INC'
5517      INCLUDE 'DPCOSU.INC'
5518      INCLUDE 'DPCODA.INC'
5519CCCCC THE FOLLOWING WINDOW SYSTEM COMMON WAS ADDED AUGUST 1990
5520      INCLUDE 'DPCOWI.INC'
5521      INCLUDE 'DPCOP2.INC'
5522C
5523C-----START POINT-----------------------------------------------------
5524C
5525      IF(IBUGPC.EQ.'ON' .OR. ISUBRO.EQ.'IPC2')THEN
5526        WRITE(ICOUT,999)
5527  999   FORMAT(1X)
5528        CALL DPWRST('XXX','BUG ')
5529        WRITE(ICOUT,51)
5530   51   FORMAT('***** AT THE BEGINNING OF MAIPC2--')
5531        CALL DPWRST('XXX','BUG ')
5532        WRITE(ICOUT,53)IBUGPC,IBUGP2,ISUBRO,IANGLU,IERASV
5533   53   FORMAT('IBUGPC,IBUGP2,ISUBRO,IANGLU,IERASV = ',4(A4,2X),A4)
5534        CALL DPWRST('XXX','BUG ')
5535        WRITE(ICOUT,67)ICOM,ICOM2,NUMARG
5536   67   FORMAT('ICOM,ICOM2,NUMARG = ',2(A4,2X),I8)
5537        CALL DPWRST('XXX','BUG ')
5538        DO70I=1,NUMARG
5539          WRITE(ICOUT,71)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I)
5540   71     FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) = ',
5541     1           I8,3(2X,A4),2X,I8,G15.7)
5542          CALL DPWRST('XXX','BUG ')
5543   70   CONTINUE
5544        WRITE(ICOUT,81)IMPSW,IMPNR,IMPNC,IMPCO,IMPCO2
5545   81   FORMAT('IMPSW,IMPNR,IMPNC,IMPCO,IMPCO2 = ',A4,4I8)
5546        CALL DPWRST('XXX','BUG ')
5547        WRITE(ICOUT,82)PMXMIN,PMXMAX,PMYMIN,PMYMAX
5548   82   FORMAT('PMXMIN,PMXMAX,PMYMIN,PMYMAX = ',4G15.7)
5549        CALL DPWRST('XXX','BUG ')
5550        WRITE(ICOUT,84)PWXMIS,PWXMAS,PWYMIS,PWYMAS
5551   84   FORMAT('PWXMIS,PWXMAS,PWYMIS,PWYMAS = ',4G15.7)
5552        CALL DPWRST('XXX','BUG ')
5553        WRITE(ICOUT,86)PWXMIN,PWXMAX,PWYMIN,PWYMAX
5554   86   FORMAT('PWXMIN,PWXMAX,PWYMIN,PWYMAX = ',4G15.7)
5555        CALL DPWRST('XXX','BUG ')
5556        WRITE(ICOUT,87)PXMIN,PXMAX,PYMIN,PYMAX
5557   87   FORMAT('PXMIN,PXMAX,PYMIN,PYMAX = ',4G15.7)
5558        CALL DPWRST('XXX','BUG ')
5559      ENDIF
5560C
5561      IFOUND='NO'
5562      IERROR='NO'
5563C
5564C
5565C
5566C               **************************************
5567C               **  TREAT THE ...TIC PATTERN CASE   **
5568C               **************************************
5569C NOTE: THIS CASE NOT STORED IN COMMON BLOCKS (INCLUDE FILE "DPCOPC")
5570C       OR IMPLEMENTED IN CODE
5571C
5572C
5573CCCCC IF(ICOM.EQ.'XTIC')GOTO4220
5574CCCCC IF(ICOM.EQ.'X1TI')GOTO4220
5575CCCCC IF(ICOM.EQ.'X2TI')GOTO4220
5576CCCCC IF(ICOM.EQ.'YTIC')GOTO4220
5577CCCCC IF(ICOM.EQ.'Y1TI')GOTO4220
5578CCCCC IF(ICOM.EQ.'Y2TI')GOTO4220
5579CCCCC IF(ICOM.EQ.'TIC')GOTO4220
5580CCCCC IF(ICOM.EQ.'TICS')GOTO4220
5581CCCCC IF(ICOM.EQ.'XYTI')GOTO4220
5582CCCCC IF(ICOM.EQ.'YXTI')GOTO4220
5583CCCCC GOTO4229
5584C
5585C4220 CONTINUE
5586CCCCC CALL DPTCPA(ICOM,IHARG,NUMARG,
5587CCCCC1IDEFPA,
5588CCCCC1IX1TPA,IX2TPA,IY1TPA,IY2TPA,
5589CCCCC1IFOUND,IERROR)
5590CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5591C
5592C4229 CONTINUE
5593C
5594C               ****************************************
5595C               **  TREAT THE ...TIC THICKNESS CASE   **
5596C               ****************************************
5597C
5598      IF(ICOM.EQ.'XTIC')GOTO4230
5599      IF(ICOM.EQ.'X1TI')GOTO4230
5600      IF(ICOM.EQ.'X2TI')GOTO4230
5601      IF(ICOM.EQ.'YTIC')GOTO4230
5602      IF(ICOM.EQ.'Y1TI')GOTO4230
5603      IF(ICOM.EQ.'Y2TI')GOTO4230
5604      IF(ICOM.EQ.'TIC')GOTO4230
5605      IF(ICOM.EQ.'TICS')GOTO4230
5606      IF(ICOM.EQ.'XYTI')GOTO4230
5607      IF(ICOM.EQ.'YXTI')GOTO4230
5608      GOTO4239
5609C
5610 4230 CONTINUE
5611      CALL DPTCTH(ICOM,IHARG,ARG,NUMARG,
5612     1PDEFTH,
5613     1PTICTH,
5614     1IFOUND,IERROR)
5615      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5616C
5617 4239 CONTINUE
5618C               *****************************
5619C               **  TREAT THE ...TIC  CASE **
5620C               *****************************
5621C
5622      IF(ICOM.EQ.'XTIC')GOTO4100
5623      IF(ICOM.EQ.'X1TI')GOTO4100
5624      IF(ICOM.EQ.'X2TI')GOTO4100
5625      IF(ICOM.EQ.'YTIC')GOTO4100
5626      IF(ICOM.EQ.'Y1TI')GOTO4100
5627      IF(ICOM.EQ.'Y2TI')GOTO4100
5628      IF(ICOM.EQ.'TIC ')GOTO4100
5629      IF(ICOM.EQ.'TICS')GOTO4100
5630      IF(ICOM.EQ.'XYTI')GOTO4100
5631      IF(ICOM.EQ.'YXTI')GOTO4100
5632      GOTO4199
5633C
5634 4100 CONTINUE
5635      CALL DPTIC(ICOM,IHARG,NUMARG,
5636     1IX1TSW,IX2TSW,IY1TSW,IY2TSW,
5637     1IFOUND,IERROR)
5638      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5639C
5640 4199 CONTINUE
5641C
5642C               ************************************
5643C               **  TREAT THE ...TIC COLOR CASE   **
5644C               ************************************
5645C
5646      IF(ICOM.EQ.'XTIC')GOTO4200
5647      IF(ICOM.EQ.'X1TI')GOTO4200
5648      IF(ICOM.EQ.'X2TI')GOTO4200
5649      IF(ICOM.EQ.'YTIC')GOTO4200
5650      IF(ICOM.EQ.'Y1TI')GOTO4200
5651      IF(ICOM.EQ.'Y2TI')GOTO4200
5652      IF(ICOM.EQ.'TIC')GOTO4200
5653      IF(ICOM.EQ.'TICS')GOTO4200
5654      IF(ICOM.EQ.'XYTI')GOTO4200
5655      IF(ICOM.EQ.'YXTI')GOTO4200
5656      GOTO4299
5657C
5658 4200 CONTINUE
5659      CALL DPTCCL(ICOM,IHARG,NUMARG,
5660     1IDEFCO,
5661     1IX1TCO,IX2TCO,IY1TCO,IY2TCO,
5662     1IFOUND,IERROR)
5663      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5664C
5665 4299 CONTINUE
5666C
5667C               ************************************
5668C               **  TREAT THE ...TIC DECIMALS CASE**
5669C               ************************************
5670C
5671      IF(ICOM.EQ.'XTIC')GOTO4300
5672      IF(ICOM.EQ.'X1TI')GOTO4300
5673      IF(ICOM.EQ.'X2TI')GOTO4300
5674      IF(ICOM.EQ.'YTIC')GOTO4300
5675      IF(ICOM.EQ.'Y1TI')GOTO4300
5676      IF(ICOM.EQ.'Y2TI')GOTO4300
5677      IF(ICOM.EQ.'TIC')GOTO4300
5678      IF(ICOM.EQ.'TICS')GOTO4300
5679      IF(ICOM.EQ.'XYTI')GOTO4300
5680      IF(ICOM.EQ.'YXTI')GOTO4300
5681      GOTO4399
5682C
5683 4300 CONTINUE
5684      CALL DPTCDP(ICOM,IHARG,IARG,NUMARG,
5685     1            IDEFDP,
5686     1            IX1ZDP,IX2ZDP,IY1ZDP,IY2ZDP,
5687     1            IFOUND,IERROR)
5688      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5689C
5690 4399 CONTINUE
5691C
5692C               ***************************************
5693C               **  TREAT THE ...TIC POSITION CASE   **
5694C               ***************************************
5695C
5696      IF(ICOM.EQ.'XTIC')GOTO4400
5697      IF(ICOM.EQ.'X1TI')GOTO4400
5698      IF(ICOM.EQ.'X2TI')GOTO4400
5699      IF(ICOM.EQ.'YTIC')GOTO4400
5700      IF(ICOM.EQ.'Y1TI')GOTO4400
5701      IF(ICOM.EQ.'Y2TI')GOTO4400
5702      IF(ICOM.EQ.'TIC')GOTO4400
5703      IF(ICOM.EQ.'TICS')GOTO4400
5704      IF(ICOM.EQ.'XYTI')GOTO4400
5705      IF(ICOM.EQ.'YXTI')GOTO4400
5706      GOTO4499
5707C
5708 4400 CONTINUE
5709      CALL DPTCJU(ICOM,IHARG,NUMARG,
5710     1IX1TJU,IX2TJU,IY1TJU,IY2TJU,
5711     1IFOUND,IERROR)
5712      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5713C
5714 4499 CONTINUE
5715C
5716C               *************************************
5717C               **  TREAT THE ...TIC SIZE CASE     **
5718C               *************************************
5719C
5720      IF(ICOM.EQ.'XTIC')GOTO4500
5721      IF(ICOM.EQ.'X1TI')GOTO4500
5722      IF(ICOM.EQ.'X2TI')GOTO4500
5723      IF(ICOM.EQ.'YTIC')GOTO4500
5724      IF(ICOM.EQ.'Y1TI')GOTO4500
5725      IF(ICOM.EQ.'Y2TI')GOTO4500
5726      IF(ICOM.EQ.'TIC')GOTO4500
5727      IF(ICOM.EQ.'TICS')GOTO4500
5728      IF(ICOM.EQ.'XYTI')GOTO4500
5729      IF(ICOM.EQ.'YXTI')GOTO4500
5730      GOTO4599
5731C
5732 4500 CONTINUE
5733      CALL DPTCSZ(ICOM,IHARG,IARGT,ARG,NUMARG,
5734     1DEFTL,
5735     1PX1TLE,PX2TLE,PY1TLE,PY2TLE,
5736     1IFOUND,IERROR)
5737      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5738C
5739 4599 CONTINUE
5740C
5741C               *************************************
5742C               **  TREAT THE ...TIC OFFSET CASE   **
5743C               *************************************
5744C
5745      IF(ICOM.EQ.'XTIC')GOTO9400
5746      IF(ICOM.EQ.'X1TI')GOTO9400
5747      IF(ICOM.EQ.'X2TI')GOTO9400
5748      IF(ICOM.EQ.'YTIC')GOTO9400
5749      IF(ICOM.EQ.'Y1TI')GOTO9400
5750      IF(ICOM.EQ.'Y2TI')GOTO9400
5751      IF(ICOM.EQ.'TIC')GOTO9400
5752      IF(ICOM.EQ.'TICS')GOTO9400
5753      IF(ICOM.EQ.'XYTI')GOTO9400
5754      IF(ICOM.EQ.'YXTI')GOTO9400
5755      GOTO9499
5756C
5757 9400 CONTINUE
5758      CALL DPTCOF(ICOM,IHARG,IARGT,ARG,NUMARG,
5759     1DEFTOF,IDEFTU,
5760     1ITICUN,
5761     1PX1TOL,PX2TOL,PY1TOB,PY2TOB,
5762     1PX1TOR,PX2TOR,PY1TOT,PY2TOT,
5763     1IFOUND,IERROR)
5764      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5765C
5766 9499 CONTINUE
5767C
5768C
5769C               *************************************************
5770C               **  TREAT THE ...TIC LABEL DISPLACEMENT  CASE  **
5771C               *************************************************
5772C
5773      IF(ICOM.EQ.'XTIC')GOTO4700
5774      IF(ICOM.EQ.'X1TI')GOTO4700
5775      IF(ICOM.EQ.'X2TI')GOTO4700
5776      IF(ICOM.EQ.'YTIC')GOTO4700
5777      IF(ICOM.EQ.'Y1TI')GOTO4700
5778      IF(ICOM.EQ.'Y2TI')GOTO4700
5779      IF(ICOM.EQ.'TIC')GOTO4700
5780      IF(ICOM.EQ.'TICS')GOTO4700
5781      IF(ICOM.EQ.'XYTI')GOTO4700
5782      IF(ICOM.EQ.'YXTI')GOTO4700
5783      GOTO4709
5784C
5785CCCCC DECEMBER 1992.  FIX BUG.  PDEFHG AND PDEFVG ARE THE DEFAULT
5786CCCCC HORIZONTAL AND VERTICAL GAPS, NOT THE DEFAULT DISPLACEMENT.
5787 4700 CONTINUE
5788CCCCC FOLLOWING LINE ADDED DECEMBER 1992.  (DEFAULT VERTICAL DISPLACEMENT
5789CCCCC DISPLACEMENT IS 0.5 GREATER THAN DEFAULT HORIZONTAL.
5790      PJUNK=PDEFDS-0.5
5791      CALL DPTLDS(ICOM,IHARG,IARGT,ARG,NUMARG,
5792CCCCC FOLLOWING LINE MODIFIED DECEMBER 1992.
5793CCCCC1PDEFHG,PDEFVG,
5794     1PDEFDS,PJUNK,
5795     1PX1ZDS,PX2ZDS,PY1ZDS,PY2ZDS,
5796     1IFOUND,IERROR)
5797      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5798C
5799 4709 CONTINUE
5800C
5801C               *****************************************
5802C               **  TREAT THE ...TIC LABEL FONT  CASE  **
5803C               *****************************************
5804C
5805      IF(ICOM.EQ.'XTIC')GOTO4710
5806      IF(ICOM.EQ.'X1TI')GOTO4710
5807      IF(ICOM.EQ.'X2TI')GOTO4710
5808      IF(ICOM.EQ.'YTIC')GOTO4710
5809      IF(ICOM.EQ.'Y1TI')GOTO4710
5810      IF(ICOM.EQ.'Y2TI')GOTO4710
5811      IF(ICOM.EQ.'TIC')GOTO4710
5812      IF(ICOM.EQ.'TICS')GOTO4710
5813      IF(ICOM.EQ.'XYTI')GOTO4710
5814      IF(ICOM.EQ.'YXTI')GOTO4710
5815      GOTO4719
5816C
5817 4710 CONTINUE
5818      CALL DPTLFO(ICOM,IHARG,NUMARG,
5819     1IDEFFO,
5820     1IX1ZFO,IX2ZFO,IY1ZFO,IY2ZFO,
5821     1IFOUND,IERROR)
5822      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5823C
5824 4719 CONTINUE
5825C
5826C               *****************************************
5827C               **  TREAT THE ...TIC LABEL CASE  CASE  **
5828C               *****************************************
5829C
5830      IF(ICOM.EQ.'XTIC')GOTO4720
5831      IF(ICOM.EQ.'X1TI')GOTO4720
5832      IF(ICOM.EQ.'X2TI')GOTO4720
5833      IF(ICOM.EQ.'YTIC')GOTO4720
5834      IF(ICOM.EQ.'Y1TI')GOTO4720
5835      IF(ICOM.EQ.'Y2TI')GOTO4720
5836      IF(ICOM.EQ.'TIC')GOTO4720
5837      IF(ICOM.EQ.'TICS')GOTO4720
5838      IF(ICOM.EQ.'XYTI')GOTO4720
5839      IF(ICOM.EQ.'YXTI')GOTO4720
5840      GOTO4729
5841C
5842 4720 CONTINUE
5843      CALL DPTLCA(ICOM,IHARG,NUMARG,
5844     1IDEFCA,
5845     1IX1ZCA,IX2ZCA,IY1ZCA,IY2ZCA,
5846     1IFOUND,IERROR)
5847      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5848C
5849 4729 CONTINUE
5850C
5851C               *************************************************
5852C               **  TREAT THE ...TIC LABEL JUSTIFICATION CASE  **
5853C               *************************************************
5854C
5855      IF(ICOM.EQ.'XTIC')GOTO4730
5856      IF(ICOM.EQ.'X1TI')GOTO4730
5857      IF(ICOM.EQ.'X2TI')GOTO4730
5858      IF(ICOM.EQ.'YTIC')GOTO4730
5859      IF(ICOM.EQ.'Y1TI')GOTO4730
5860      IF(ICOM.EQ.'Y2TI')GOTO4730
5861      IF(ICOM.EQ.'TIC')GOTO4730
5862      IF(ICOM.EQ.'TICS')GOTO4730
5863      IF(ICOM.EQ.'XYTI')GOTO4730
5864      IF(ICOM.EQ.'YXTI')GOTO4730
5865      GOTO4739
5866C
5867 4730 CONTINUE
5868      CALL DPTLJU(ICOM,IHARG,NUMARG,
5869     1IDEFJU,
5870     1IX1ZJU,IX2ZJU,IY1ZJU,IY2ZJU,
5871     1IFOUND,IERROR)
5872      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5873C
5874 4739 CONTINUE
5875C
5876C               *********************************************
5877C               **  TREAT THE ...TIC LABEL DIRECTION CASE  **
5878C               *********************************************
5879C
5880      IF(ICOM.EQ.'XTIC')GOTO4740
5881      IF(ICOM.EQ.'X1TI')GOTO4740
5882      IF(ICOM.EQ.'X2TI')GOTO4740
5883      IF(ICOM.EQ.'YTIC')GOTO4740
5884      IF(ICOM.EQ.'Y1TI')GOTO4740
5885      IF(ICOM.EQ.'Y2TI')GOTO4740
5886      IF(ICOM.EQ.'TIC')GOTO4740
5887      IF(ICOM.EQ.'TICS')GOTO4740
5888      IF(ICOM.EQ.'XYTI')GOTO4740
5889      IF(ICOM.EQ.'YXTI')GOTO4740
5890      GOTO4749
5891C
5892 4740 CONTINUE
5893      CALL DPTLDI(ICOM,IHARG,NUMARG,
5894     1IDEFDI,
5895     1IX1ZDI,IX2ZDI,IY1ZDI,IY2ZDI,
5896     1IFOUND,IERROR)
5897      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5898C
5899 4749 CONTINUE
5900C
5901C               *****************************************
5902C               **  TREAT THE ...TIC LABEL FILL  CASE  **
5903C               *****************************************
5904C
5905      IF(ICOM.EQ.'XTIC')GOTO4750
5906      IF(ICOM.EQ.'X1TI')GOTO4750
5907      IF(ICOM.EQ.'X2TI')GOTO4750
5908      IF(ICOM.EQ.'YTIC')GOTO4750
5909      IF(ICOM.EQ.'Y1TI')GOTO4750
5910      IF(ICOM.EQ.'Y2TI')GOTO4750
5911      IF(ICOM.EQ.'TIC')GOTO4750
5912      IF(ICOM.EQ.'TICS')GOTO4750
5913      IF(ICOM.EQ.'XYTI')GOTO4750
5914      IF(ICOM.EQ.'YXTI')GOTO4750
5915      GOTO4759
5916C
5917 4750 CONTINUE
5918      CALL DPTLFI(ICOM,IHARG,NUMARG,
5919     1IDEFFI,
5920     1IX1ZFI,IX2ZFI,IY1ZFI,IY2ZFI,
5921     1IFOUND,IERROR)
5922      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5923C
5924 4759 CONTINUE
5925C
5926C               *********************************************
5927C               **  TREAT THE ...TIC LABEL THICKNESS CASE  **
5928C               *********************************************
5929C
5930      IF(ICOM.EQ.'XTIC')GOTO4760
5931      IF(ICOM.EQ.'X1TI')GOTO4760
5932      IF(ICOM.EQ.'X2TI')GOTO4760
5933      IF(ICOM.EQ.'YTIC')GOTO4760
5934      IF(ICOM.EQ.'Y1TI')GOTO4760
5935      IF(ICOM.EQ.'Y2TI')GOTO4760
5936      IF(ICOM.EQ.'TIC')GOTO4760
5937      IF(ICOM.EQ.'TICS')GOTO4760
5938      IF(ICOM.EQ.'XYTI')GOTO4760
5939      IF(ICOM.EQ.'YXTI')GOTO4760
5940      GOTO4769
5941C
5942 4760 CONTINUE
5943      CALL DPTLTH(ICOM,IHARG,ARG,NUMARG,
5944     1PDEFTH,
5945     1PTIZTH,
5946     1IFOUND,IERROR)
5947      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5948C
5949 4769 CONTINUE
5950C
5951C               *****************************************
5952C               **  TREAT THE ...TIC LABEL ANGLE CASE  **
5953C               *****************************************
5954C
5955      IF(ICOM.EQ.'XTIC')GOTO4770
5956      IF(ICOM.EQ.'X1TI')GOTO4770
5957      IF(ICOM.EQ.'X2TI')GOTO4770
5958      IF(ICOM.EQ.'YTIC')GOTO4770
5959      IF(ICOM.EQ.'Y1TI')GOTO4770
5960      IF(ICOM.EQ.'Y2TI')GOTO4770
5961      IF(ICOM.EQ.'TIC')GOTO4770
5962      IF(ICOM.EQ.'TICS')GOTO4770
5963      IF(ICOM.EQ.'XYTI')GOTO4770
5964      IF(ICOM.EQ.'YXTI')GOTO4770
5965      GOTO4779
5966C
5967 4770 CONTINUE
5968      CALL DPTLAN(ICOM,IHARG,ARG,NUMARG,
5969     1ADEFAN,
5970     1AX1ZAN,AX2ZAN,AY1ZAN,AY2ZAN,
5971     1IFOUND,IERROR)
5972      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5973C
5974 4779 CONTINUE
5975C               *************************************
5976C               **  TREAT THE ...TIC LABEL  CASE   **
5977C               *************************************
5978C
5979      IF(ICOM.EQ.'XTIC')GOTO4780
5980      IF(ICOM.EQ.'X1TI')GOTO4780
5981      IF(ICOM.EQ.'X2TI')GOTO4780
5982      IF(ICOM.EQ.'YTIC')GOTO4780
5983      IF(ICOM.EQ.'Y1TI')GOTO4780
5984      IF(ICOM.EQ.'Y2TI')GOTO4780
5985      IF(ICOM.EQ.'TIC')GOTO4780
5986      IF(ICOM.EQ.'TICS')GOTO4780
5987      IF(ICOM.EQ.'XYTI')GOTO4780
5988      IF(ICOM.EQ.'YXTI')GOTO4780
5989      GOTO4789
5990C
5991 4780 CONTINUE
5992      CALL DPTL(ICOM,IHARG,NUMARG,
5993     1IX1ZSW,IX2ZSW,IY1ZSW,IY2ZSW,
5994     1IFOUND,IERROR)
5995      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
5996C
5997 4789 CONTINUE
5998C
5999C               *****************************************
6000C               **  TREAT THE ...TIC LABEL COLOR CASE  **
6001C               *****************************************
6002C
6003      IF(ICOM.EQ.'XTIC')GOTO4790
6004      IF(ICOM.EQ.'X1TI')GOTO4790
6005      IF(ICOM.EQ.'X2TI')GOTO4790
6006      IF(ICOM.EQ.'YTIC')GOTO4790
6007      IF(ICOM.EQ.'Y1TI')GOTO4790
6008      IF(ICOM.EQ.'Y2TI')GOTO4790
6009      IF(ICOM.EQ.'TIC')GOTO4790
6010      IF(ICOM.EQ.'TICS')GOTO4790
6011      IF(ICOM.EQ.'XYTI')GOTO4790
6012      IF(ICOM.EQ.'YXTI')GOTO4790
6013      GOTO4799
6014C
6015 4790 CONTINUE
6016      CALL DPTLCL(ICOM,IHARG,NUMARG,
6017     1IDEFCO,
6018     1IX1ZCO,IX2ZCO,IY1ZCO,IY2ZCO,
6019     1IFOUND,IERROR)
6020      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6021C
6022 4799 CONTINUE
6023C
6024C               *****************************************
6025C               **  TREAT THE ...TIC LABEL SIZE  CASE  **
6026C               *****************************************
6027C
6028      IF(ICOM.EQ.'XTIC')GOTO4800
6029      IF(ICOM.EQ.'X1TI')GOTO4800
6030      IF(ICOM.EQ.'X2TI')GOTO4800
6031      IF(ICOM.EQ.'YTIC')GOTO4800
6032      IF(ICOM.EQ.'Y1TI')GOTO4800
6033      IF(ICOM.EQ.'Y2TI')GOTO4800
6034      IF(ICOM.EQ.'TIC')GOTO4800
6035      IF(ICOM.EQ.'TICS')GOTO4800
6036      IF(ICOM.EQ.'XYTI')GOTO4800
6037      IF(ICOM.EQ.'YXTI')GOTO4800
6038      GOTO4809
6039C
6040 4800 CONTINUE
6041      CALL DPTLSZ(ICOM,IHARG,IARGT,ARG,NUMARG,
6042     1PDEFHE,PDEFWI,
6043     1PX1ZHE,PX1ZWI,PX1ZVG,PX1ZHG,
6044     1PX2ZHE,PX2ZWI,PX2ZVG,PX2ZHG,
6045     1PY1ZHE,PY1ZWI,PY1ZVG,PY1ZHG,
6046     1PY2ZHE,PY2ZWI,PY2ZVG,PY2ZHG,
6047     1IFOUND,IERROR)
6048      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6049C
6050 4809 CONTINUE
6051C
6052C               *****************************************
6053C               **  TREAT THE ...TIC LABEL FORMAT CASE **
6054C               *****************************************
6055C
6056      IF(ICOM.EQ.'XTIC')GOTO4810
6057      IF(ICOM.EQ.'X1TI')GOTO4810
6058      IF(ICOM.EQ.'X2TI')GOTO4810
6059      IF(ICOM.EQ.'YTIC')GOTO4810
6060      IF(ICOM.EQ.'Y1TI')GOTO4810
6061      IF(ICOM.EQ.'Y2TI')GOTO4810
6062      IF(ICOM.EQ.'TIC')GOTO4810
6063      IF(ICOM.EQ.'TICS')GOTO4810
6064      IF(ICOM.EQ.'XYTI')GOTO4810
6065      IF(ICOM.EQ.'YXTI')GOTO4810
6066      GOTO4819
6067C
6068 4810 CONTINUE
6069      CALL DPTLFM(ICOM,IHARG,NUMARG,
6070     1IDETLF,
6071     1IX1ZFM,IX2ZFM,IY1ZFM,IY2ZFM,
6072     1IFOUND,IERROR)
6073      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6074C
6075 4819 CONTINUE
6076C
6077C               *******************************************
6078C               **  TREAT THE ...TIC LABEL CONTENTS CASE **
6079C               *******************************************
6080C
6081      IF(ICOM.EQ.'XTIC')GOTO4820
6082      IF(ICOM.EQ.'X1TI')GOTO4820
6083      IF(ICOM.EQ.'X2TI')GOTO4820
6084      IF(ICOM.EQ.'YTIC')GOTO4820
6085      IF(ICOM.EQ.'Y1TI')GOTO4820
6086      IF(ICOM.EQ.'Y2TI')GOTO4820
6087      IF(ICOM.EQ.'TIC')GOTO4820
6088      IF(ICOM.EQ.'TICS')GOTO4820
6089      IF(ICOM.EQ.'XYTI')GOTO4820
6090      IF(ICOM.EQ.'YXTI')GOTO4820
6091      GOTO4829
6092C
6093 4820 CONTINUE
6094      CALL DPTLCN(ICOM,IHARG,NUMARG,
6095CCCCC THE FOLLOWING LINE WAS AUGMENTED       SEPTEMBER 1993
6096CCCCC SO AS TO ALLOW LOWER CASE              SEPTEMBER 1993
6097CCCCC1IANS,IWIDTH,
6098     1IANS,IANSLC,IWIDTH,
6099     1IX1ZCN,IX2ZCN,IY1ZCN,IY2ZCN,
6100     1IFOUND,IERROR)
6101      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6102C
6103 4829 CONTINUE
6104C
6105C     2019/02: ADD TIC MARK LABEL GAP COMMAND
6106C
6107C               *************************************************
6108C               **  TREAT THE ...TIC LABEL GAP  CASE           **
6109C               *************************************************
6110C
6111      IF(ICOM.EQ.'XTIC')GOTO4830
6112      IF(ICOM.EQ.'X1TI')GOTO4830
6113      IF(ICOM.EQ.'X2TI')GOTO4830
6114      IF(ICOM.EQ.'YTIC')GOTO4830
6115      IF(ICOM.EQ.'Y1TI')GOTO4830
6116      IF(ICOM.EQ.'Y2TI')GOTO4830
6117      IF(ICOM.EQ.'TIC')GOTO4830
6118      IF(ICOM.EQ.'TICS')GOTO4830
6119      IF(ICOM.EQ.'XYTI')GOTO4830
6120      IF(ICOM.EQ.'YXTI')GOTO4830
6121      GOTO4839
6122C
6123 4830 CONTINUE
6124CCCCC CALL DPTLGA(ICOM,IHARG,IARGT,ARG,NUMARG,
6125CCCCC1            PX1ZGA,PX2ZGA,PY1ZGA,PY2ZGA,
6126CCCCC1            IFOUND,IERROR)
6127      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6128C
6129 4839 CONTINUE
6130C
6131C               **********************************
6132C               **  TREAT THE TITLE FONT  CASE  **
6133C               **********************************
6134C
6135      IF(ICOM.EQ.'TITL')THEN
6136        CALL DPTIFO(IHARG,NUMARG,IDEFFO,ITITFO,IFOUND,IERROR)
6137        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6138C
6139C               **********************************
6140C               **  TREAT THE TITLE CASE  CASE  **
6141C               **********************************
6142C
6143        CALL DPTICA(IHARG,NUMARG,IDEFCA,ITITCA,IFOUND,IERROR)
6144        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6145C
6146C               **************************************
6147C               **  TREAT THE TITLE THICKNESS CASE  **
6148C               **************************************
6149C
6150        CALL DPTITH(IHARG,ARG,NUMARG,PDEFTH,PTITTH,IFOUND,IERROR)
6151        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6152C
6153CCCCC   THE FOLLOWING SECTION WAS ADDED JULY 1989
6154C               **************************************
6155C               **  TREAT THE TITLE DISPLACEMENT CASE  **
6156C               **************************************
6157C
6158        CALL DPTIDS(IHARG,ARG,NUMARG,PDEFDS,PTITDS,IFOUND,IERROR)
6159        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6160C
6161C               ****************************
6162C               **  TREAT THE TITLE CASE  **
6163C               ****************************
6164C
6165        CALL DPTIT(IANS,IANSLC,IWIDTH,IHARG,IHARG2,NUMARG,
6166     1             ITITTE,NCTITL,ITIAUT,IBUGP2,IFOUND,IERROR)
6167        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6168C
6169C               **********************************
6170C               **  TREAT THE TITLE COLOR CASE  **
6171C               **********************************
6172C
6173        CALL DPTICL(IHARG,NUMARG,IDEFCO,ITITCO,IFOUND,IERROR)
6174        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6175C
6176C               **********************************
6177C               **  TREAT THE TITLE SIZE  CASE  **
6178C               **********************************
6179C
6180        CALL DPTISZ(IHARG,IARGT,ARG,NUMARG,
6181     1             PDEFHE,PDEFWI,
6182     1             PTITHE,PTITWI,PTITVG,PTITHG,
6183     1             IFOUND,IERROR)
6184        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6185C
6186      ENDIF
6187C
6188C               *****************************
6189C               **  TREAT THE NEGATE CASE  **
6190C               *****************************
6191C
6192      IF(ICOM.EQ.'NEGA')THEN
6193        CALL DPNEGA(IHARG,NUMARG,INEGSW,IFOUND,IERROR)
6194        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6195      ENDIF
6196C
6197C               *************************************************
6198C               **  TREAT THE WINDOW (CORNER) COORDINATES CASE **
6199C               *************************************************
6200C
6201      IF(ICOM.EQ.'WIND')GOTO5400
6202      GOTO5499
6203C
6204 5400 CONTINUE
6205      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'CORN'.AND.
6206     1IHARG(2).EQ.'COOR')GOTO5411
6207      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COOR')
6208     1GOTO5430
6209      GOTO5499
6210 5411 CONTINUE
6211      ISHIFT=1
6212      GOTO5420
6213 5420 CONTINUE
6214      CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
6215     1IBUGP2,IERROR)
6216      GOTO5430
6217 5430 CONTINUE
6218      CALL DPWICC(IHARG,IHARG2,IARGT,ARG,NUMARG,
6219     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,IANS,IWIDTH,
6220     1PWXMIN,PWXMAX,PWYMIN,PWYMAX,
6221     1IBUGP2,IFOUND,IERROR)
6222      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6223C
6224 5499 CONTINUE
6225C
6226C               *********************************
6227C               **  TREAT THE HORIZONTAL CASE  **
6228C               *********************************
6229C
6230      IF(ICOM.EQ.'HORI'.AND.IHARG(1).EQ.'SWIT')THEN
6231        CALL DPHRIZ(IHARG,NUMARG,IHORSW,IFOUND,IERROR)
6232        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6233      ENDIF
6234C
6235C               **********************************************
6236C               **  TREAT THE MAJOR TIC MARK NUMBER   CASE  **
6237C               **********************************************
6238C
6239      IF(ICOM.EQ.'MAJO')GOTO5800
6240C  FEBRUARY, 1988: CHECK FOR "MINOR TIC MARK NUMBER"
6241      IF(ICOM.EQ.'MINO')GOTO5899
6242C  END CHANGE
6243      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'NUMB')GOTO5800
6244      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'NUMB')GOTO5800
6245      IF(NUMARG.GE.3.AND.IHARG(3).EQ.'NUMB')GOTO5800
6246      IF(NUMARG.GE.4.AND.IHARG(4).EQ.'NUMB')GOTO5800
6247      GOTO5899
6248C
6249 5800 CONTINUE
6250      CALL DPMATN(ICOM,IHARG,IARGT,IARG,NUMARG,
6251     1IX1JSW,IX2JSW,IY1JSW,IY2JSW,
6252     1NMJX1T,NMJX2T,NMJY1T,NMJY2T,
6253     1IFOUND,IERROR)
6254      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6255
6256 5899 CONTINUE
6257C
6258C               **********************************************
6259C               **  TREAT THE MINOR TIC MARK NUMBER   CASE  **
6260C               **********************************************
6261C
6262      IF(ICOM.EQ.'MINO')GOTO5900
6263      GOTO5999
6264C
6265 5900 CONTINUE
6266      CALL DPMITN(IHARG,IARGT,IARG,NUMARG,
6267     1IX1NSW,IX2NSW,IY1NSW,IY2NSW,
6268     1NMNX1T,NMNX2T,NMNY1T,NMNY2T,
6269     1IFOUND,IERROR)
6270      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6271C
6272 5999 CONTINUE
6273C
6274C               *****************************************
6275C               **  TREAT THE ...TIC LABEL HW    CASE  **
6276C               *****************************************
6277C
6278      IF(ICOM.EQ.'XTIC')GOTO6000
6279      IF(ICOM.EQ.'X1TI')GOTO6000
6280      IF(ICOM.EQ.'X2TI')GOTO6000
6281      IF(ICOM.EQ.'YTIC')GOTO6000
6282      IF(ICOM.EQ.'Y1TI')GOTO6000
6283      IF(ICOM.EQ.'Y2TI')GOTO6000
6284      IF(ICOM.EQ.'TIC')GOTO6000
6285      IF(ICOM.EQ.'TICS')GOTO6000
6286      IF(ICOM.EQ.'XYTI')GOTO6000
6287      IF(ICOM.EQ.'YXTI')GOTO6000
6288      GOTO6099
6289C
6290 6000 CONTINUE
6291      CALL DPTLHW(ICOM,IHARG,IARGT,ARG,NUMARG,
6292     1PDEFHE,PDEFWI,
6293     1PX1ZHE,PX1ZWI,PX1ZVG,PX1ZHG,
6294     1PX2ZHE,PX2ZWI,PX2ZVG,PX2ZHG,
6295     1PY1ZHE,PY1ZWI,PY1ZVG,PY1ZHG,
6296     1PY2ZHE,PY2ZWI,PY2ZVG,PY2ZHG,
6297     1IFOUND,IERROR)
6298      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6299C
6300 6099 CONTINUE
6301C
6302C               ********************************************
6303C               **  TREAT THE MAJOR TIC COORDINATES CASE  **
6304C               ********************************************
6305C
6306      IF(ICOM.EQ.'MAJO')THEN
6307        CALL DPMJTC(ICOM,IHARG,IARGT,ARG,NUMARG,
6308     1              IX1TSW,IX2TSW,IY1TSW,IY2TSW,
6309     1              X1COOR,X2COOR,Y1COOR,Y2COOR,
6310     1              NX1COO,NX2COO,NY1COO,NY2COO,
6311     1              MAXTIC,
6312     1              IFOUND,IERROR)
6313        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6314      ENDIF
6315C
6316C               ********************************************
6317C               **  TREAT THE MINOR TIC COORDINATES CASE  **
6318C               ********************************************
6319C
6320      IF(ICOM.EQ.'MINO')THEN
6321        CALL DPMNTC(ICOM,IHARG,IARGT,ARG,NUMARG,
6322     1              X1COMN,X2COMN,Y1COMN,Y2COMN,
6323     1              NX1CMN,NX2CMN,NY1CMN,NY2CMN,
6324     1              MAXTIC,
6325     1              IFOUND,IERROR)
6326        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6327      ENDIF
6328C
6329C               ***********************************
6330C               **  TREAT THE FILL  COLORS CASE  **
6331C               ***********************************
6332C
6333CCCCC IF(ICOM.EQ.'FILL'.AND.IHARG(1).EQ.'COLO')GOTO6500
6334CCCCC GOTO6599
6335C
6336C6500 CONTINUE
6337CCCCC CALL DPFICO(IHARG,NUMARG,IDEFFC,MAXFIL,IFILCO,
6338CCCCC1IBUGP2,IFOUND,IERROR)
6339CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6340C
6341C6599 CONTINUE
6342C
6343C               ***********************************
6344C               **  TREAT THE FILL SPACING CASE  **
6345C               ***********************************
6346C
6347CCCCC IF(ICOM.EQ.'FILL'.AND.IHARG(1).EQ.'SPAC')GOTO6600
6348CCCCC GOTO6699
6349C
6350C6600 CONTINUE
6351CCCCC CALL DPFISP(IHARG,IARGT,ARG,NUMARG,PDPFFG,MAXFIL,PFILSP,
6352CCCCC1IBUGP2,IFOUND,IERROR)
6353CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6354C
6355C6699 CONTINUE
6356C
6357C               *************************************
6358C               **  TREAT THE FILL THICKNESS CASE  **
6359C               *************************************
6360C
6361CCCCC IF(ICOM.EQ.'FILL'.AND.IHARG(1).EQ.'THIC')GOTO6700
6362CCCCC GOTO6799
6363C
6364C6700 CONTINUE
6365CCCCC CALL DPFITH(IHARG,IARGT,ARG,NUMARG,PDEFFT,MAXFIL,PFILTH,
6366CCCCC1IBUGP2,IFOUND,IERROR)
6367CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6368C
6369C6799 CONTINUE
6370C
6371C               ********************************
6372C               **  TREAT THE FILL  BASE CASE **
6373C               ********************************
6374C
6375CCCCC IF(ICOM.EQ.'FILL'.AND.IHARG(1).EQ.'BASE')GOTO6800
6376CCCCC IF(ICOM.EQ.'FILL'.AND.IHARG(1).EQ.'REFE')GOTO6800
6377CCCCC1 GOTO6899
6378C
6379C6800 CONTINUE
6380CCCCC CALL DPFIBA(IHARG,IARGT,ARG,NUMARG,ADEFFB,MAXFIL,AFILBA,
6381CCCCC1IBUGP2,IFOUND,IERROR)
6382CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6383C
6384C6899 CONTINUE
6385C
6386C               ***********************************
6387C               **  TREAT THE FILL (SWITCH) CASE **
6388C               ***********************************
6389C
6390CCCCC IF(ICOM.EQ.'FILL')GOTO6900
6391CCCCC GOTO6999
6392C
6393C6900 CONTINUE
6394CCCCC IF(IHARG(1).EQ.'ON')GOTO6910
6395CCCCC IF(IHARG(2).EQ.'ON')GOTO6910
6396CCCCC IF(IHARG(1).EQ.'OFF')GOTO6910
6397CCCCC IF(IHARG(2).EQ.'OFF')GOTO6910
6398CCCCC GOTO6999
6399C6910 CONTINUE
6400CCCCC CALL DPFISW(IHARG,NUMARG,IDEFFS,MAXFIL,IFILSW,
6401CCCCC1IBUGP2,IFOUND,IERROR)
6402CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6403C
6404C6999 CONTINUE
6405C
6406C               *************************************
6407C               **  TREAT THE FILL (PATTERN) CASE  **
6408C               *************************************
6409C
6410CCCCC IF(ICOM.EQ.'FILL')GOTO7000
6411CCCCC GOTO7099
6412C
6413C7000 CONTINUE
6414CCCCC CALL DPFIPA(IHARG,NUMARG,IDEFFP,MAXFIL,IFILPA,
6415CCCCC1IBUGP2,IFOUND,IERROR)
6416CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6417C
6418C7099 CONTINUE
6419C
6420C               *************************************
6421C               **  TREAT THE PATTERN LINE   CASE  **
6422C               *************************************
6423C
6424      IF(ICOM.EQ.'PATT'.AND.IHARG(1).EQ.'LINE')GOTO7100
6425      GOTO7199
6426C
6427 7100 CONTINUE
6428      CALL DPPALI(IHARG,NUMARG,IDEFPL,MAXPAT,IPATLI,
6429     1IBUGP2,IFOUND,IERROR)
6430      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6431C
6432 7199 CONTINUE
6433C
6434C               **************************************
6435C               **  TREAT THE PATTERN SPACING CASE  **
6436C               **************************************
6437C
6438      IF(ICOM.EQ.'PATT'.AND.IHARG(1).EQ.'SPAC')GOTO7200
6439      GOTO7299
6440C
6441 7200 CONTINUE
6442      CALL DPPASP(IHARG,IARGT,ARG,NUMARG,
6443     1            PDEFPG,MAXPAT,PPATSP,
6444     1            IBUGP2,IFOUND,IERROR)
6445      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6446C
6447 7299 CONTINUE
6448C
6449C               ****************************************
6450C               **  TREAT THE PATTERN THICKNESS CASE  **
6451C               ****************************************
6452C
6453      IF(ICOM.EQ.'PATT'.AND.IHARG(1).EQ.'THIC')GOTO7300
6454      GOTO7399
6455C
6456 7300 CONTINUE
6457      CALL DPPATH(IHARG,IARGT,ARG,NUMARG,PDEFPT,MAXPAT,PPATTH,
6458     1IBUGP2,IFOUND,IERROR)
6459      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6460C
6461 7399 CONTINUE
6462C
6463C               ****************************************
6464C               **  TREAT THE PATTERN HEIGHT    CASE  **
6465C               ****************************************
6466C
6467      IF(ICOM.EQ.'PATT'.AND.IHARG(1).EQ.'HEIG')GOTO7400
6468      GOTO7499
6469C
6470 7400 CONTINUE
6471      CALL DPPAHE(IHARG,IARGT,ARG,NUMARG,PDEFPH,MAXPAT,PPATHE,
6472     1IBUGP2,IFOUND,IERROR)
6473      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6474C
6475 7499 CONTINUE
6476C
6477C               ****************************************
6478C               **  TREAT THE PATTERN WIDTH     CASE  **
6479C               ****************************************
6480C
6481      IF(ICOM.EQ.'PATT'.AND.IHARG(1).EQ.'WIDT')GOTO7500
6482      GOTO7599
6483C
6484 7500 CONTINUE
6485      CALL DPPAWI(IHARG,IARGT,ARG,NUMARG,PDEFPW,MAXPAT,PPATWI,
6486     1IBUGP2,IFOUND,IERROR)
6487      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6488C
6489 7599 CONTINUE
6490C
6491C               *************************************
6492C               **  TREAT THE PATTERN COLOR  CASE  **
6493C               *************************************
6494C
6495      IF(ICOM.EQ.'PATT'.AND.IHARG(1).EQ.'COLO')GOTO7600
6496      GOTO7699
6497C
6498 7600 CONTINUE
6499      CALL DPPACO(IHARG,NUMARG,IDEFPC,MAXPAT,IPATCO,
6500     1IBUGP2,IFOUND,IERROR)
6501      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6502C
6503 7699 CONTINUE
6504C
6505C               **************************************
6506C               **  TREAT THE PATTERN (SWITCH) CASE **
6507C               **************************************
6508C
6509      IF(ICOM.EQ.'PATT')GOTO7700
6510      GOTO7799
6511C
6512 7700 CONTINUE
6513      IF(IHARG(1).EQ.'ON')GOTO7710
6514      IF(IHARG(2).EQ.'ON')GOTO7710
6515      IF(IHARG(1).EQ.'OFF')GOTO7710
6516      IF(IHARG(2).EQ.'OFF')GOTO7710
6517      GOTO7799
6518 7710 CONTINUE
6519      CALL DPPASW(IHARG,NUMARG,IDEFPS,MAXPAT,IPATSW,
6520     1IBUGP2,IFOUND,IERROR)
6521      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6522C
6523 7799 CONTINUE
6524C
6525C               ****************************************
6526C               **  TREAT THE PATTERN (PATTERN) CASE  **
6527C               ****************************************
6528C
6529      IF(ICOM.EQ.'PATT')GOTO7800
6530      GOTO7899
6531C
6532 7800 CONTINUE
6533      CALL DPPAPA(IHARG,NUMARG,IDEFPP,MAXPAT,IPATPA,
6534     1IBUGP2,IFOUND,IERROR)
6535      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6536C
6537 7899 CONTINUE
6538C
6539C               ***********************************
6540C               **  TREAT THE SPIKE COLORS CASE  **
6541C               ***********************************
6542C
6543      IF(ICOM.EQ.'SPIK'.AND.IHARG(1).EQ.'COLO')GOTO8100
6544      GOTO8199
6545C
6546 8100 CONTINUE
6547      CALL DPSPCO(IHARG,NUMARG,IDEFSC,MAXSPI,ISPICO,
6548     1IBUGP2,IFOUND,IERROR)
6549      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6550C
6551 8199 CONTINUE
6552C
6553C               *************************************
6554C               **  TREAT THE SPIKE THICKNESS CASE **
6555C               *************************************
6556C
6557      IF(ICOM.EQ.'SPIK'.AND.IHARG(1).EQ.'THIC')GOTO8200
6558      GOTO8299
6559C
6560 8200 CONTINUE
6561      CALL DPSPTH(IHARG,IARGT,ARG,NUMARG,PDEFST,MAXSPI,PSPITH,
6562     1IBUGP2,IFOUND,IERROR)
6563      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6564C
6565 8299 CONTINUE
6566C
6567C               *************************************
6568C               **  TREAT THE SPIKE LINE      CASE **
6569C               *************************************
6570C
6571      IF(ICOM.EQ.'SPIK'.AND.IHARG(1).EQ.'LINE')GOTO8300
6572      GOTO8399
6573C
6574 8300 CONTINUE
6575CCCCC AUGUST 1995.  ADD IHARG2 FOR DASH2, ETC
6576CCCCC CALL DPSPLI(IHARG,NUMARG,IDEFSL,MAXSPI,ISPILI,
6577      CALL DPSPLI(IHARG,IHARG2,NUMARG,IDEFSL,MAXSPI,ISPILI,
6578     1IBUGP2,IFOUND,IERROR)
6579      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6580C
6581 8399 CONTINUE
6582C
6583C               ********************************
6584C               **  TREAT THE SPIKE BASE CASE **
6585C               ********************************
6586C
6587      IF(ICOM.EQ.'SPIK'.AND.IHARG(1).EQ.'BASE')GOTO8400
6588      IF(ICOM.EQ.'SPIK'.AND.IHARG(1).EQ.'REFE')GOTO8400
6589      GOTO8499
6590C
6591 8400 CONTINUE
6592CCCCC CALL DPSPBA(IHARG,IARGT,ARG,NUMARG,ADEFSB,MAXSPI,ASPIBA,
6593      CALL DPSPBA(ADEFSB,MAXSPI,ASPIBA,
6594     1IBUGP2,IFOUND,IERROR)
6595      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6596C
6597 8499 CONTINUE
6598C
6599C               **************************************
6600C               **  TREAT THE SPIKE DIRECTION CASE  **
6601C               **************************************
6602C
6603      IF(ICOM.EQ.'SPIK'.AND.IHARG(1).EQ.'DIRE')GOTO8500
6604      GOTO8599
6605C
6606 8500 CONTINUE
6607      CALL DPSPDI(IHARG,NUMARG,IDEFSD,MAXSPI,ISPIDI,
6608     1IBUGP2,IFOUND,IERROR)
6609      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6610C
6611 8599 CONTINUE
6612C
6613C               ***********************************
6614C               **  TREAT THE SPIKE (SWITCH) CASE**
6615C               ***********************************
6616C
6617      IF(ICOM.EQ.'SPIK')GOTO8600
6618      GOTO8699
6619C
6620 8600 CONTINUE
6621      IF(IHARG(1).EQ.'ON')GOTO8610
6622      IF(IHARG(2).EQ.'ON')GOTO8610
6623      IF(IHARG(1).EQ.'OFF')GOTO8610
6624      IF(IHARG(2).EQ.'OFF')GOTO8610
6625      GOTO8699
6626 8610 CONTINUE
6627      CALL DPSPSW(IHARG,NUMARG,IDEFSS,MAXSPI,ISPISW,
6628     1IBUGP2,IFOUND,IERROR)
6629      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6630C
6631 8699 CONTINUE
6632C
6633C               *************************************
6634C               **  TREAT THE SPIKE (PATTERN) CASE **
6635C               **  (SAME AS SPIKE LINES CASE)     **
6636C               *************************************
6637C
6638      IF(ICOM.EQ.'SPIK')GOTO8700
6639      GOTO8799
6640C
6641 8700 CONTINUE
6642CCCCC AUGUST 1995.  ADD IHARG2 FOR DASH2, ETC
6643CCCCC CALL DPSPPA(IHARG,NUMARG,IDEFSL,MAXSPI,ISPILI,
6644      CALL DPSPPA(IHARG,IHARG2,NUMARG,IDEFSL,MAXSPI,ISPILI,
6645     1IBUGP2,IFOUND,IERROR)
6646      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6647C
6648 8799 CONTINUE
6649C
6650C               ***************************************
6651C               **  TREAT THE SUBREGION (SWITCH) CASE**
6652C               ***************************************
6653C
6654      IF(ICOM.EQ.'SUBR')THEN
6655        IF(IHARG(1).EQ.'ON'.OR.IHARG(2).EQ.'ON'.OR.
6656     1     IHARG(1).EQ.'OFF'.OR.IHARG(2).EQ.'OFF')THEN
6657          CALL DPSBSW(IHARG,NUMARG,IDEFSB,MAXSUB,ISUBSW,
6658     1                IBUGP2,IFOUND,IERROR)
6659          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6660        ENDIF
6661      ENDIF
6662C
6663C               ***************************************
6664C               **  TREAT THE SUBREGION LIMITS   CASE**
6665C               ***************************************
6666C
6667      IF(ICOM.EQ.'SUBR')THEN
6668        CALL DPSBLI(ICOM,IHARG,IARGT,ARG,NUMARG,
6669     1              ASUBXL,ASUBXU,ASUBYL,ASUBYU,
6670     1              MAXSUB,
6671     1              IFOUND,IERROR)
6672          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6673      ENDIF
6674C
6675C
6676C               ***************************
6677C               **  TREAT THE MINOR GRID CASE  **
6678C               ***************************
6679C
6680      IF(ICOM.EQ.'XGMI')GOTO8800
6681      IF(ICOM.EQ.'YGMI')GOTO8800
6682      IF(ICOM.EQ.'XYGM')GOTO8800
6683      IF(ICOM.EQ.'YXGM')GOTO8800
6684      IF(ICOM.EQ.'GMIN')GOTO8800
6685      IF(ICOM.EQ.'MINO')GOTO8800
6686      GOTO8899
6687C
6688 8800 CONTINUE
6689      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COLO')GOTO8899
6690      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PATT')GOTO8899
6691      CALL DPGRMN(ICOM,IHARG,NUMARG,IVGMSW,IHGMSW,IFOUND,IERROR)
6692      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6693C
6694 8899 CONTINUE
6695C
6696C               ****************************************************
6697C               **  TREAT THE MULTIPLOT (CORNER) COORDINATES CASE **
6698C               ****************************************************
6699C
6700      IF((ICOM.EQ.'MULT' .AND. IHARG(1).EQ.'CORN') .OR.
6701     1   (ICOM.EQ.'MULT' .AND. IHARG(1).EQ.'COOR') .OR.
6702     1   (ICOM.EQ.'MP  ' .AND. IHARG(1).EQ.'CORN') .OR.
6703     1   (ICOM.EQ.'MP  ' .AND. IHARG(1).EQ.'COOR'))THEN
6704C
6705        IF(NUMARG.GE.2.AND.IHARG(1).EQ.'CORN'.AND.
6706     1     IHARG(2).EQ.'COOR')THEN
6707          ISHIFT=1
6708          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
6709     1                IBUGP2,IERROR)
6710        ENDIF
6711C
6712        CALL DPMUCC(IHARG,IHARG2,IARGT,ARG,NUMARG,
6713     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,
6714     1              NUMNAM,MAXNAM,IANS,IWIDTH,
6715     1              PMXMIN,PMXMAX,PMYMIN,PMYMAX,
6716     1              IBUGP2,IFOUND,IERROR)
6717        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6718C
6719      ENDIF
6720C
6721C               ****************************************************
6722C               **  TREAT THE    END OF MULTIPLOT    CASE         **
6723C               ****************************************************
6724C
6725      IF(ICOM.EQ.'END')GOTO9200
6726CCCCC THE FOLLOWING 2 LINES WERE ADDED AUGUST 1990
6727      IF(ICOM.EQ.'EOMP')GOTO9210
6728      IF(ICOM.EQ.'EMP')GOTO9210
6729      GOTO9299
6730C
6731 9200 CONTINUE
6732      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'OF'.AND.
6733     1IHARG(2).EQ.'MULT')GOTO9210
6734      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MULT')
6735     1GOTO9210
6736      GOTO9299
6737 9210 CONTINUE
6738      CALL DPENMU(IMPSW,
6739     1IERASV,
6740     1PWXMIS,PWXMAS,PWYMIS,PWYMAS,
6741     1IERASW,
6742     1PWXMIN,PWXMAX,PWYMIN,PWYMAX,
6743     1IBUGP2,IFOUND,IERROR)
6744      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6745C
6746 9299 CONTINUE
6747C
6748C               ****************************************************
6749C               **  TREAT THE MULTIPLOT CASE                      **
6750C               ****************************************************
6751C
6752      IF(ICOM.EQ.'MULT' .OR. ICOM.EQ.'MP')GOTO9300
6753      GOTO9399
6754C
6755 9300 CONTINUE
6756      IF(ICOM2.EQ.'IPLE')GOTO9399
6757      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CONT')GOTO9399
6758      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'GRUB')GOTO9399
6759      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TIET')GOTO9399
6760      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'ESD ')GOTO9399
6761      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'FREQ')GOTO9399
6762      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'FREQ')GOTO9399
6763      IF(NUMARG.GE.3.AND.IHARG(3).EQ.'FREQ')GOTO9399
6764      IF(NUMARG.GE.4.AND.IHARG(4).EQ.'FREQ')GOTO9399
6765      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'KERN')GOTO9399
6766      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'KERN')GOTO9399
6767      IF(NUMARG.GE.3.AND.IHARG(3).EQ.'KERN')GOTO9399
6768      IF(NUMARG.GE.4.AND.IHARG(4).EQ.'KERN')GOTO9399
6769      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'LORE')GOTO9399
6770      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'LORE')GOTO9399
6771      IF(NUMARG.GE.3.AND.IHARG(3).EQ.'LORE')GOTO9399
6772      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'ADJA')GOTO9399
6773      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'ADJA')GOTO9399
6774      IF(NUMARG.GE.3.AND.IHARG(3).EQ.'ADJA')GOTO9399
6775      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'ALLA')GOTO9399
6776      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'ALLA')GOTO9399
6777      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'AV')GOTO9399
6778      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'AV')GOTO9399
6779      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'AS')GOTO9399
6780      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'AS')GOTO9399
6781      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'ASD')GOTO9399
6782      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'ASD')GOTO9399
6783      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'SPEC')GOTO9399
6784      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PERI')GOTO9399
6785      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'AUTO')GOTO9399
6786      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PART')GOTO9399
6787      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CO  ')GOTO9399
6788      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COSP')GOTO9399
6789      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'QUAD')GOTO9399
6790      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CROS')GOTO9399
6791      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COHE')GOTO9399
6792      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'AMPL')GOTO9399
6793      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PHAS')GOTO9399
6794      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'GAIN')GOTO9399
6795      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'ARGA')GOTO9399
6796      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TAIL')GOTO9399
6797      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'SURV')GOTO9399
6798      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CONF')GOTO9399
6799      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'DIFF')GOTO9399
6800      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'LEVE')GOTO9399
6801      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COCH')GOTO9399
6802      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PROP')GOTO9399
6803      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'ANOP')GOTO9399
6804      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'ANAL')GOTO9399
6805      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'COMM' .AND.
6806     1   IHARG(2).EQ.'WEIB')GOTO9399
6807      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'EMPI' .AND.
6808     1   IHARG(2).EQ.'QUAN')GOTO9399
6809      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'CUMU' .AND.
6810     1   IHARG(2).EQ.'SUM')GOTO9399
6811      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'LJUN' .AND.
6812     1   IHARG(2).EQ.'BOX')GOTO9399
6813      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'BOX' .AND.
6814     1   IHARG(2).EQ.'COX')GOTO9399
6815      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'BOX')GOTO9399
6816      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'BOX')GOTO9399
6817      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'SYMM')GOTO9399
6818C
6819      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'I')GOTO9399
6820      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'I')GOTO9399
6821      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MEAN'.AND.
6822     1   IHARG(2).EQ.'CONF')GOTO9399
6823      IF(NUMARG.GE.3.AND.IHARG(2).EQ.'MEAN'.AND.
6824     1   IHARG(3).EQ.'CONF')GOTO9399
6825      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MEDI'.AND.
6826     1   IHARG(2).EQ.'CONF')GOTO9399
6827      IF(NUMARG.GE.3.AND.IHARG(2).EQ.'MEDI'.AND.
6828     1   IHARG(3).EQ.'CONF')GOTO9399
6829      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'TRIM'.AND.
6830     1   IHARG(2).EQ.'MEAN')GOTO9399
6831      IF(NUMARG.GE.3.AND.IHARG(2).EQ.'TRIM'.AND.
6832     1   IHARG(3).EQ.'MEAN')GOTO9399
6833      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'BIWE'.AND.
6834     1   IHARG(2).EQ.'CONF')GOTO9399
6835      IF(NUMARG.GE.3.AND.IHARG(2).EQ.'BIWE'.AND.
6836     1   IHARG(3).EQ.'CONF')GOTO9399
6837      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'QUAN'.AND.
6838     1   IHARG(2).EQ.'CONF')GOTO9399
6839      IF(NUMARG.GE.3.AND.IHARG(2).EQ.'QUAN'.AND.
6840     1   IHARG(3).EQ.'CONF')GOTO9399
6841      IF(NUMARG.GE.3.AND.IHARG(1).EQ.'ONE '.AND.
6842     1   IHARG(2).EQ.'STAN'.AND.IHARG(3).EQ.'ERRO')GOTO9399
6843      IF(NUMARG.GE.4.AND.IHARG(2).EQ.'ONE '.AND.
6844     1   IHARG(3).EQ.'STAN'.AND.IHARG(4).EQ.'ERRO')GOTO9399
6845      IF(NUMARG.GE.3.AND.IHARG(1).EQ.'TWO '.AND.
6846     1   IHARG(2).EQ.'STAN'.AND.IHARG(3).EQ.'ERRO')GOTO9399
6847      IF(NUMARG.GE.4.AND.IHARG(2).EQ.'TWO '.AND.
6848     1   IHARG(3).EQ.'STAN'.AND.IHARG(4).EQ.'ERRO')GOTO9399
6849      IF(NUMARG.GE.3.AND.IHARG(1).EQ.'ONE '.AND.
6850     1   IHARG(2).EQ.'STAN'.AND.IHARG(3).EQ.'DEVI')GOTO9399
6851      IF(NUMARG.GE.4.AND.IHARG(2).EQ.'ONE '.AND.
6852     1   IHARG(3).EQ.'STAN'.AND.IHARG(4).EQ.'DEVI')GOTO9399
6853      IF(NUMARG.GE.3.AND.IHARG(1).EQ.'TWO '.AND.
6854     1   IHARG(2).EQ.'STAN'.AND.IHARG(3).EQ.'DEVI')GOTO9399
6855      IF(NUMARG.GE.4.AND.IHARG(2).EQ.'TWO '.AND.
6856     1   IHARG(3).EQ.'STAN'.AND.IHARG(4).EQ.'DEVI')GOTO9399
6857      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'NORM'.AND.
6858     1   IHARG(2).EQ.'TOLE')GOTO9399
6859      IF(NUMARG.GE.3.AND.IHARG(2).EQ.'NORM'.AND.
6860     1   IHARG(3).EQ.'TOLE')GOTO9399
6861      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'NORM'.AND.
6862     1   IHARG(2).EQ.'PRED')GOTO9399
6863      IF(NUMARG.GE.3.AND.IHARG(2).EQ.'NORM'.AND.
6864     1   IHARG(3).EQ.'PRED')GOTO9399
6865      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'AGRE'.AND.
6866     1   IHARG(2).EQ.'COUL')GOTO9399
6867      IF(NUMARG.GE.3.AND.IHARG(2).EQ.'AGRE'.AND.
6868     1   IHARG(3).EQ.'COUL')GOTO9399
6869C
6870      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'VIOL')GOTO9399
6871      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'VIOL')GOTO9399
6872      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'HOMO')GOTO9399
6873      IF(NUMARG.GE.3.AND.IHARG(1).EQ.'PERC'.AND.
6874     1   IHARG(2).EQ.'POIN'.AND.IHARG(3).EQ.'PLOT')GOTO9399
6875      IF(NUMARG.GE.3.AND.IHARG(1).EQ.'BEST' .AND.
6876     1   IHARG(2).EQ.'DIST'.AND.IHARG(3).EQ.'FIT')GOTO9399
6877      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'RUN ' .AND.
6878     1   IHARG(2).EQ.'SEQU')GOTO9399
6879      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'KRUS' .AND.
6880     1   IHARG(2).EQ.'WALL')GOTO9399
6881      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'SQUA' .AND.
6882     1   IHARG(2).EQ.'RANK')GOTO9399
6883      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MEDI' .AND.
6884     1   IHARG(2).EQ.'TEST')GOTO9399
6885      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'ANDE' .AND.
6886     1   IHARG(2).EQ.'DARL')GOTO9399
6887      IF(NUMARG.GE.3.AND.IHARG(1).EQ.'VAN ' .AND.
6888     1   IHARG(2).EQ.'DER '.AND.IHARG(3).EQ.'WAER')GOTO9399
6889      IF(NUMARG.GE.3.AND.IHARG(1).EQ.'ONE ' .AND.
6890     1   IHARG(2).EQ.'WAY '.AND.IHARG(3).EQ.'NORM')GOTO9399
6891      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'WILK' .AND.
6892     1   IHARG(2).EQ.'SHAP')GOTO9399
6893      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'SHAP' .AND.
6894     1   IHARG(2).EQ.'WILK')GOTO9399
6895      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'NORM' .AND.
6896     1   IHARG(2).EQ.'TOLE')GOTO9399
6897      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'NONP' .AND.
6898     1   IHARG(2).EQ.'TOLE')GOTO9399
6899      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TOLE')GOTO9399
6900      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'BEST' .AND.
6901     1   IHARG(2).EQ.'DIST')GOTO9399
6902      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'T   '.AND.
6903     1   IHARG(2).EQ.'TEST')GOTO9399
6904      IF(NUMARG.GE.3.AND.IHARG(2).EQ.'T   '.AND.
6905     1   IHARG(3).EQ.'TEST')GOTO9399
6906      IF(NUMARG.GE.4.AND.IHARG(3).EQ.'T   '.AND.
6907     1   IHARG(4).EQ.'TEST')GOTO9399
6908      IF(NUMARG.GE.5.AND.IHARG(4).EQ.'T   '.AND.
6909     1   IHARG(5).EQ.'TEST')GOTO9399
6910      IF(NUMARG.GE.6.AND.IHARG(5).EQ.'T   '.AND.
6911     1   IHARG(6).EQ.'TEST')GOTO9399
6912      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'BART'.AND.
6913     1   IHARG(2).EQ.'TEST')GOTO9399
6914      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'DM  '.AND.
6915     1   IHARG(2).EQ.'BART')GOTO9399
6916      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'DIXO' .AND.
6917     1   IHARG(2).EQ.'MASS'.AND.IHARG(3).EQ.'BART')GOTO9399
6918      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'F   '.AND.
6919     1   IHARG(2).EQ.'LOC ')GOTO9399
6920      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'SUMM')GOTO9399
6921      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CAPA')GOTO9399
6922      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'RUNS')GOTO9399
6923      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'JARQ'.AND.
6924     1   IHARG(2).EQ.'BERA')GOTO9399
6925      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PRED')GOTO9399
6926      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'LOWE')GOTO9399
6927      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'UPPE')GOTO9399
6928      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'SD  ' .AND.
6929     1   IHARG(2).EQ.'CONF')GOTO9399
6930      IF(NUMARG.GE.3.AND.IHARG(1).EQ.'STAN' .AND.
6931     1   IHARG(2).EQ.'DEVI'.AND.IHARG(3).EQ.'CONF')GOTO9399
6932      IF(NUMARG.GE.3.AND.IHARG(1).EQ.'STAN' .AND.
6933     1   IHARG(2).EQ.'DEVI'.AND.IHARG(3).EQ.'PRED')GOTO9399
6934      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'ONE ' .AND.
6935     1   IHARG(2).EQ.'SIDE')GOTO9399
6936      IF(NUMARG.GE.3.AND.IHARG(1).EQ.'DIST' .AND.
6937     1   IHARG(2).EQ.'FIT '.AND.IHARG(3).EQ.'PLOT')GOTO9399
6938      IF(NUMARG.GE.4.AND.IHARG(1).EQ.'COEF' .AND.
6939     1   IHARG(2).EQ.'OF  '.AND. IHARG(3).EQ.'VARI' .AND.
6940     1   IHARG(4).EQ.'CONF')GOTO9399
6941      IF(NUMARG.GE.4.AND.IHARG(1).EQ.'COEF' .AND.
6942     1   IHARG(2).EQ.'OF  '.AND. IHARG(3).EQ.'DISP' .AND.
6943     1   IHARG(4).EQ.'CONF')GOTO9399
6944      IF(NUMARG.GE.4.AND.IHARG(1).EQ.'COEF' .AND.
6945     1   IHARG(2).EQ.'OF  '.AND.IHARG(3).EQ.'QUAR' .AND.
6946     1   IHARG(4).EQ.'DISP'.AND.IHARG(5).EQ.'CONF')GOTO9399
6947      IF(NUMARG.GE.4.AND.IHARG(1).EQ.'COEF' .AND.
6948     1   IHARG(2).EQ.'OF  '.AND.IHARG(3).EQ.'QUAR' .AND.
6949     1   IHARG(4).EQ.'VARI'.AND.IHARG(5).EQ.'CONF')GOTO9399
6950      IF(NUMARG.GE.4.AND.IHARG(1).EQ.'QUAR' .AND.
6951     1   IHARG(2).EQ.'COEF'.AND.IHARG(3).EQ.'OF  ' .AND.
6952     1   IHARG(4).EQ.'DISP'.AND.IHARG(5).EQ.'CONF')GOTO9399
6953      IF(NUMARG.GE.4.AND.IHARG(1).EQ.'QUAR' .AND.
6954     1   IHARG(2).EQ.'COEF'.AND.IHARG(3).EQ.'OF  ' .AND.
6955     1   IHARG(4).EQ.'VARI'.AND.IHARG(5).EQ.'CONF')GOTO9399
6956C
6957      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT'.AND.
6958     1IHARG2(1).EQ.'    ')
6959     1GOTO9311
6960      GOTO9330
6961 9311 CONTINUE
6962      ISHIFT=1
6963      GOTO9320
6964 9320 CONTINUE
6965      CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
6966     1IBUGP2,IERROR)
6967      GOTO9330
6968 9330 CONTINUE
6969      CALL DPMULT(IHARG,IHARG2,IARGT,IARG,ARG,NUMARG,
6970     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,IANS,IWIDTH,
6971     1IMPSW,IMPNR,IMPNC,IMPCO,IMPCO9,
6972CCCCC ADD FOLLOWING LINE.  AUGUST 1999.
6973     1IMPARG,
6974CCCCC ADD FOLLOWING LINE.  SEPTEMBER 1998.
6975     1AMPSCH,AMPSCW,
6976     1PMXMIN,PMXMAX,PMYMIN,PMYMAX,
6977     1IERASW,
6978     1PWXMIN,PWXMAX,PWYMIN,PWYMAX,
6979     1IERASV,
6980     1PWXMIS,PWXMAS,PWYMIS,PWYMAS,
6981     1IBUGP2,IFOUND,IERROR)
6982      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6983C
6984 9399 CONTINUE
6985C
6986C               ****************************************************
6987C               **  TREAT THE EMBED     CASE                      **
6988C               ****************************************************
6989C
6990      IF(ICOM.EQ.'EMBE')THEN
6991        CALL DPEMBE(IHARG,IHARG2,IARGT,IARG,ARG,NUMARG,ICOM,IERASW,
6992     1              IEMBSW,IEMCNT,PEMXC1,PEMXC2,PEMYC1,PEMYC2,
6993     1              PWXMIN,PWXMAX,PWYMIN,PWYMAX,
6994     1              IBUGP2,ISUBRO,IFOUND,IERROR)
6995        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
6996      ENDIF
6997C
6998CCCCC THE FOLLOWING SECTION WAS ADDED AUGUST 1990
6999C               *************************************
7000C               **  TREAT THE WINDOW SYSTEM   CASE **
7001C               *************************************
7002C
7003CCCCC  IF(ICOM.EQ.'WIND'.AND.IHARG(1).EQ.'SYST')GOTO11100
7004CCCCC  IF(ICOM.EQ.'WIND'.AND.IHARG(1).EQ.'MANA')GOTO11100
7005CCCCC  GOTO11199
7006C
7007C11100 CONTINUE
7008CCCCC  CALL DPWISY(IHARG,NUMARG,IDEFWS,IWINSY,
7009CCCCC 1IBUGP2,IFOUND,IERROR)
7010CCCCC  IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
7011C
7012C11199 CONTINUE
7013C
7014CCCCC THE FOLLOWING SECTION WAS ADDED AUGUST 1990
7015C               *************************************
7016C               **  TREAT THE WINDOW POINTER CASE  **
7017C               *************************************
7018C
7019CCCCC  IF(ICOM.EQ.'WIND'.AND.IHARG(1).EQ.'POIN')GOTO11200
7020CCCCC  IF(ICOM.EQ.'WIND'.AND.IHARG(1).EQ.'SELE')GOTO11200
7021CCCCC  GOTO11299
7022C
7023C11200 CONTINUE
7024CCCCC  CALL DPWIPO(IHARG,NUMARG,IDEFWP,IWINPO,
7025CCCCC 1IBUGP2,IFOUND,IERROR)
7026CCCCC  IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
7027C
7028C               ***********************************
7029C               **  TREAT THE PIXMAP TITLE CASE  **
7030C               ***********************************
7031C
7032      IF(ICOM.EQ.'PIXM'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'TITL')THEN
7033        CALL DPPMTI(IANS,IANSLC,IWIDTH,IHARG,IHARG2,NUMARG,
7034     1              IBUGP2,IFOUND,IERROR)
7035        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
7036      ENDIF
7037C
7038C               *****************
7039C               **  STEP 90--  **
7040C               **  EXIT       **
7041C               *****************
7042C
7043 9000 CONTINUE
7044      IF(IBUGPC.EQ.'ON' .OR. ISUBRO.EQ.'IPC2')THEN
7045        WRITE(ICOUT,999)
7046        CALL DPWRST('XXX','BUG ')
7047        WRITE(ICOUT,9011)
7048 9011   FORMAT('***** AT THE END       OF MAIPC2--')
7049        CALL DPWRST('XXX','BUG ')
7050        WRITE(ICOUT,9020)IFOUND,IERROR
7051 9020   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
7052        CALL DPWRST('XXX','BUG ')
7053      ENDIF
7054C
7055      RETURN
7056      END
7057      SUBROUTINE MAIPC3(IBUGPC,IBUGP2,ISUBRO,
7058     1                  IVGMSW,IHGMSW,
7059     1                  IMPSW,IMPNR,IMPNC,IMPCO,
7060     1                  PMXMIN,PMXMAX,PMYMIN,PMYMAX,
7061     1                  IERASV,
7062     1                  PWXMIS,PWXMAS,PWYMIS,PWYMAS,
7063CCCCC THE FOLLOWING LINE WAS ADDED APRIL 1992
7064     1                  BARHEF,BARWEF,
7065     1                  IFOUND,IERROR)
7066C
7067C     PURPOSE--THIS IS SUBROUTING MAIPC3.
7068C              (THE   PC    AT THE END OF    MAIPC3   STANDS FOR PLOT CONTROL
7069C              THIS SUBROUTINE SEARCHES FOR AND EXECUTES
7070C              PLOT CONTROL COMMANDS (PART 3).
7071C
7072C     WRITTEN BY--JAMES J. FILLIBEN
7073C                 STATISTICAL ENGINEERING DIVISION
7074C                 INFORMATION TECHNOLOGY LABORATORY
7075C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
7076C                 GAITHERSBURG, MD 20899-8980
7077C                 PHONE--301-975-2855
7078C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
7079C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
7080C     LANGUAGE--ANSI FORTRAN (1977)
7081C     VERSION NUMBER--82.6
7082C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--JULY 1986.
7083C     UPDATED        --APRIL  1992.  BAR EXPANSION FACTORS ... ...
7084C     UPDATED        --OCTOBER1993.  ARGUMENTS TO BAR BASE (DPBABA)
7085C     UPDATED        --OCTOBER1993.  ARGUMENTS TO REGION BASE (DPREBA)
7086C     UPDATED        --MARCH  1994.  ARGUMENTS TO REGION BASE (DPREBA)
7087C     UPDATED        --AUGUST    1995. DASH2 BUG (VARIOUS)
7088C
7089C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
7090C
7091      CHARACTER*4 IBUGPC
7092      CHARACTER*4 IBUGP2
7093      CHARACTER*4 ISUBRO
7094C
7095      CHARACTER*4 IVGMSW
7096      CHARACTER*4 IHGMSW
7097C
7098      CHARACTER*4 IMPSW
7099      CHARACTER*4 IERASV
7100      CHARACTER*4 ICASCL
7101C
7102      CHARACTER*4 IFOUND
7103      CHARACTER*4 IERROR
7104C
7105C-----COMMON----------------------------------------------------------
7106C
7107      INCLUDE 'DPCOPA.INC'
7108      INCLUDE 'DPCOHK.INC'
7109      INCLUDE 'DPCOPC.INC'
7110      INCLUDE 'DPCOSU.INC'
7111      INCLUDE 'DPCODA.INC'
7112      INCLUDE 'DPCOP2.INC'
7113C
7114C-----START POINT-----------------------------------------------------
7115C
7116      IF(IBUGPC.EQ.'ON' .OR. ISUBRO.EQ.'IPC3')THEN
7117        WRITE(ICOUT,999)
7118  999   FORMAT(1X)
7119        CALL DPWRST('XXX','BUG ')
7120        WRITE(ICOUT,51)
7121   51   FORMAT('***** AT THE BEGINNING OF MAIPC3--')
7122        CALL DPWRST('XXX','BUG ')
7123        WRITE(ICOUT,53)IBUGPC,IBUGP2,ISUBRO,IANGLU,IERASV
7124   53   FORMAT('IBUGPC,IBUGP2,ISUBRO,IANGLU,IERASV = ',4(A4,2X),A4)
7125        CALL DPWRST('XXX','BUG ')
7126        WRITE(ICOUT,67)ICOM,ICOM2,NUMARG
7127   67   FORMAT('ICOM,ICOM2,NUMARG = ',2(A4,2X),I8)
7128        CALL DPWRST('XXX','BUG ')
7129        DO70I=1,NUMARG
7130          WRITE(ICOUT,71)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I)
7131   71     FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) = ',
7132     1           I8,3(2X,A4),2X,I8,G15.7)
7133          CALL DPWRST('XXX','BUG ')
7134   70   CONTINUE
7135        WRITE(ICOUT,81)IMPSW,IMPNR,IMPNC,IMPCO
7136   81   FORMAT('IMPSW,IMPNR,IMPNC,IMPCO = ',A4,3I8)
7137        CALL DPWRST('XXX','BUG ')
7138        WRITE(ICOUT,82)PMXMIN,PMXMAX,PMYMIN,PMYMAX
7139   82   FORMAT('PMXMIN,PMXMAX,PMYMIN,PMYMAX = ',4G15.7)
7140        CALL DPWRST('XXX','BUG ')
7141        WRITE(ICOUT,84)PWXMIS,PWXMAS,PWYMIS,PWYMAS
7142   84   FORMAT('PWXMIS,PWXMAS,PWYMIS,PWYMAS = ',4G15.7)
7143        CALL DPWRST('XXX','BUG ')
7144        WRITE(ICOUT,86)PWXMIN,PWXMAX,PWYMIN,PWYMAX
7145   86   FORMAT('PWXMIN,PWXMAX,PWYMIN,PWYMAX = ',4G15.7)
7146        CALL DPWRST('XXX','BUG ')
7147        WRITE(ICOUT,87)PXMIN,PXMAX,PYMIN,PYMAX
7148   87   FORMAT('PXMIN,PXMAX,PYMIN,PYMAX = ',4G15.7)
7149        CALL DPWRST('XXX','BUG ')
7150        WRITE(ICOUT,88)IVGMSW,IHGMSW
7151   88   FORMAT('IVGMSW,IHGMSW = ',A4,2X,A4)
7152        CALL DPWRST('XXX','BUG ')
7153      ENDIF
7154C
7155      IFOUND='NO'
7156      IERROR='NO'
7157C
7158C               *****************************************
7159C               **  TREAT THE ORIENTATION SWITCH CASE  **
7160C               *****************************************
7161C
7162C
7163      IF(ICOM.EQ.'ORIE')THEN
7164        CALL DPORSW(IHARG,NUMARG,IFOUND,IERROR)
7165        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
7166      ENDIF
7167C
7168C     ----------BARS--------------------------------------------------
7169C
7170C               ******************************************
7171C               **  STEP XX--                           **
7172C               **  TREAT THE VARIOUS BAR ... COMMANDS  **
7173C               ******************************************
7174C
7175      IF(ICOM.EQ.'BAR')GOTO11000
7176      GOTO19999
717711000 CONTINUE
7178C
7179C               **********************************************
7180C               **  TREAT THE BAR PATTERN LINE (TYPE)  CASE **
7181C               **********************************************
7182C
7183      IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'PATT'.AND.
7184     1IHARG(2).EQ.'LINE'.AND.IHARG(3).EQ.'TYPE')GOTO11120
7185      IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'PATT'.AND.
7186     1IHARG(2).EQ.'LINE')GOTO11100
7187      GOTO11199
7188C
718911100 CONTINUE
7190      ISHIFT=1
7191      CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
7192     1IBUGP2,IERROR)
7193      IHARG(3)='TYPE'
7194      IHARG2(3)='    '
719511120 CONTINUE
7196CCCCC AUGUST 1995.  ADD IHARG2 FOR DASH2, ETC
7197CCCCC CALL DPBPLI(IHARG,NUMARG,IDEBPL,MAXBAR,IBAPLI,
7198      CALL DPBPLI(IHARG,IHARG2,NUMARG,IDEBPL,MAXBAR,IBAPLI,
7199     1IBUGP2,IFOUND,IERROR)
7200      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
7201C
720211199 CONTINUE
7203C
7204C               ****************************************
7205C               **  TREAT THE BAR PATTERN COLOR  CASE **
7206C               ****************************************
7207C
7208      IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'PATT'.AND.
7209     1IHARG(2).EQ.'COLO')GOTO11200
7210      GOTO11299
7211C
721211200 CONTINUE
7213      CALL DPBPCO(IHARG,NUMARG,IDEBPC,MAXBAR,IBAPCO,
7214     1IBUGP2,IFOUND,IERROR)
7215      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
7216C
721711299 CONTINUE
7218C
7219C               ********************************************
7220C               **  TREAT THE BAR PATTERN THICKNESS  CASE **
7221C               ********************************************
7222C
7223      IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'PATT'.AND.
7224     1IHARG(2).EQ.'THIC')GOTO11300
7225      GOTO11399
7226C
722711300 CONTINUE
7228      CALL DPBPTH(IHARG,IARGT,ARG,NUMARG,PDEBPT,MAXBAR,PBAPTH,
7229     1IBUGP2,IFOUND,IERROR)
7230      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
7231C
723211399 CONTINUE
7233C
7234C               ********************************************
7235C               **  TREAT THE BAR PATTERN SPACING    CASE **
7236C               ********************************************
7237C
7238      IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'PATT'.AND.
7239     1IHARG(2).EQ.'SPAC')GOTO11420
7240      IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'SPAC')GOTO11400
7241      GOTO11499
7242C
724311400 CONTINUE
7244      ISHIFT=1
7245      CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
7246     1IBUGP2,IERROR)
7247      IHARG(2)='PATT'
7248      IHARG2(2)='ERN '
724911420 CONTINUE
7250      CALL DPBPSP(IHARG,IARGT,ARG,NUMARG,PDEBPS,MAXBAR,PBAPSP,
7251     1IBUGP2,IFOUND,IERROR)
7252      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
7253C
725411499 CONTINUE
7255C
7256C               *******************************************
7257C               **  TREAT THE BAR PATTERN (TYPE)  CASE   **
7258C               *******************************************
7259C
7260      IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'PATT'.AND.
7261     1IHARG(2).EQ.'TYPE')GOTO11520
7262      IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'PATT')GOTO11500
7263      GOTO11599
7264C
726511500 CONTINUE
7266      ISHIFT=1
7267      CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
7268     1IBUGP2,IERROR)
7269      IHARG(2)='TYPE'
7270      IHARG2(2)='    '
727111520 CONTINUE
7272      CALL DPBPTY(IHARG,NUMARG,IDEBPT,MAXBAR,IBAPTY,
7273     1IBUGP2,IFOUND,IERROR)
7274      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
7275C
727611599 CONTINUE
7277C
7278C               *************************************
7279C               **  TREAT THE BAR FILL COLOR  CASE **
7280C               *************************************
7281C
7282      IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'FILL'.AND.
7283     1IHARG(2).EQ.'COLO')GOTO11750
7284      IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'COLO')GOTO11710
7285      GOTO11799
7286C
728711710 CONTINUE
7288      ISHIFT=1
7289      CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
7290     1IBUGP2,IERROR)
7291      IHARG(1)='FILL'
7292      IHARG2(1)='    '
7293      IHARG(2)='COLO'
7294      IHARG2(2)='    '
7295      GOTO11750
7296C
729711750 CONTINUE
7298      CALL DPBFCO(IHARG,NUMARG,IDEBFC,MAXBAR,IBAFCO,
7299     1IBUGP2,IFOUND,IERROR)
7300      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
7301C
730211799 CONTINUE
7303C
7304C               ****************************************
7305C               **  TREAT THE BAR FILL (SWITCH) CASE  **
7306C               ****************************************
7307C
7308      IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'FILL'.AND.
7309     1IHARG(2).EQ.'SWIT')GOTO11820
7310      IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'FILL')GOTO11800
7311      GOTO11899
7312C
731311800 CONTINUE
7314CCCCC IF(IHARG(1).EQ.'ON')GOTO11810    MAY 5, 1987   FOR BAR SHADING
7315CCCCC IF(IHARG(2).EQ.'ON')GOTO11810    MAY 5, 1987   FOR BAR SHADING
7316CCCCC IF(IHARG(1).EQ.'OFF')GOTO11810    MAY 5, 1987   FOR BAR SHADING
7317CCCCC IF(IHARG(2).EQ.'OFF')GOTO11810    MAY 5, 1987   FOR BAR SHADING
7318CCCCC GOTO11899                       MAY 5, 1987 FOR BAR SHADING
7319      GOTO11810
732011810 CONTINUE
7321      ISHIFT=1
7322      CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
7323     1IBUGP2,IERROR)
7324      IHARG(2)='SWIT'
7325      IHARG2(2)='CH  '
732611820 CONTINUE
7327      CALL DPBFSW(IHARG,NUMARG,IDEBFS,MAXBAR,IBAFSW,
7328     1IBUGP2,IFOUND,IERROR)
7329      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
7330C
733111899 CONTINUE
7332C
7333C               ***************************************
7334C               **  TREAT THE BAR BORDER COLOR  CASE **
7335C               ***************************************
7336C
7337      IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'BORD'.AND.
7338     1IHARG(2).EQ.'COLO')GOTO12100
7339      GOTO12199
7340C
734112100 CONTINUE
7342      CALL DPBBCO(IHARG,NUMARG,IDEBBC,MAXBAR,IBABCO,
7343     1IBUGP2,IFOUND,IERROR)
7344      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
7345C
734612199 CONTINUE
7347C
7348C               *******************************************
7349C               **  TREAT THE BAR BORDER THICKNESS  CASE **
7350C               *******************************************
7351C
7352      IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'BORD'.AND.
7353     1IHARG(2).EQ.'THIC')GOTO12200
7354      GOTO12299
7355C
735612200 CONTINUE
7357      CALL DPBBTH(IHARG,IARGT,ARG,NUMARG,PDEBBT,MAXBAR,PBABTH,
7358     1IBUGP2,IFOUND,IERROR)
7359      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
7360C
736112299 CONTINUE
7362C
7363C               ***********************************************
7364C               **  TREAT THE BAR BORDER LINE (TYPE)  CASE   **
7365C               ***********************************************
7366C
7367      IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'BORD'.AND.
7368     1IHARG(2).EQ.'LINE'.AND.IHARG(3).EQ.'TYPE')GOTO12330
7369      IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'BORD'.AND.
7370     1IHARG(2).EQ.'TYPE')GOTO12320
7371      IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'BORD'.AND.
7372     1IHARG(2).EQ.'LINE')GOTO12320
7373      IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'BORD')GOTO12310
7374      GOTO12399
7375C
737612310 CONTINUE
7377      ISHIFT=2
7378      CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
7379     1IBUGP2,IERROR)
7380      IHARG(2)='LINE'
7381      IHARG2(2)='    '
7382      IHARG(3)='TYPE'
7383      IHARG2(3)='    '
7384      GOTO12330
7385C
738612320 CONTINUE
7387      ISHIFT=1
7388      CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
7389     1IBUGP2,IERROR)
7390      IHARG(2)='LINE'
7391      IHARG2(2)='    '
7392      IHARG(3)='TYPE'
7393      IHARG2(3)='    '
7394      GOTO12330
7395C
739612330 CONTINUE
7397CCCCC AUGUST 1995.  ADD IHARG2 FOR DASH2, ETC
7398CCCCC CALL DPBBLI(IHARG,NUMARG,IDEBBL,MAXBAR,IBABLI,
7399      CALL DPBBLI(IHARG,IHARG2,NUMARG,IDEBBL,MAXBAR,IBABLI,
7400     1IBUGP2,IFOUND,IERROR)
7401      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
7402C
740312399 CONTINUE
7404C
7405C               *************************************
7406C               **  TREAT THE BAR   WIDTH     CASE **
7407C               *************************************
7408C
7409      IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'WIDT')GOTO12500
7410      GOTO12599
7411C
741212500 CONTINUE
7413CCCCC CALL DPBAWI(IHARG,IARGT,ARG,NUMARG,ADEBWI,MAXBAR,ABARWI,
7414      CALL DPBAWI(ADEBWI,MAXBAR,ABARWI,
7415     1IBUGP2,IFOUND,IERROR)
7416      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
7417C
741812599 CONTINUE
7419C
7420C               ********************************
7421C               **  TREAT THE BAR   BASE CASE **
7422C               ********************************
7423C
7424      IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'BASE')GOTO12600
7425      IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'REFE')GOTO12600
7426      GOTO12699
7427C
742812600 CONTINUE
7429CCCCC OCTOBER 1993.  MODIFY CALL LIST (DPCOHK.INC NOW IN SUBROUTINE)
7430CCCCC CALL DPBABA(IHARG,IARGT,ARG,NUMARG,ADEBBA,MAXBAR,ABARBA,
7431      CALL DPBABA(ADEBBA,MAXBAR,ABARBA,
7432     1IBUGP2,IFOUND,IERROR)
7433      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
7434C
743512699 CONTINUE
7436C
7437C               ***********************************
7438C               **  TREAT THE BAR   (SWITCH) CASE**
7439C               ***********************************
7440C
7441      IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'SWIT')GOTO12720
7442      IF(ICOM.EQ.'BAR')GOTO12700
7443      GOTO12799
7444C
744512700 CONTINUE
7446      IF(IHARG(1).EQ.'ON')GOTO12710
7447      IF(IHARG(2).EQ.'ON')GOTO12710
7448      IF(IHARG(1).EQ.'OFF')GOTO12710
7449      IF(IHARG(2).EQ.'OFF')GOTO12710
7450      GOTO12799
745112710 CONTINUE
7452      ISHIFT=1
7453      CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
7454     1IBUGP2,IERROR)
7455      IHARG(1)='SWIT'
7456      IHARG2(1)='CH  '
745712720 CONTINUE
7458      CALL DPBASW(IHARG,NUMARG,IDEBSW,MAXBAR,IBARSW,
7459     1IBUGP2,IFOUND,IERROR)
7460      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
7461C
746212799 CONTINUE
7463C
7464C               *************************************
7465C               **  TREAT THE BAR  DIMENSION  CASE **
7466C               *************************************
7467C
7468      IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'DIME')GOTO12800
7469      GOTO12899
7470C
747112800 CONTINUE
7472      CALL DPBATY(IHARG,NUMARG,IDEBTY,MAXBAR,IBARTY,
7473     1IBUGP2,IFOUND,IERROR)
7474      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
7475C
747612899 CONTINUE
7477C
7478C               ****************************************
7479C               **  TREAT THE BAR   DIRECTION    CASE **
7480C               ****************************************
7481C
7482      IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'DIRE')GOTO12900
7483      GOTO12999
7484C
748512900 CONTINUE
7486      CALL DPBADI(IHARG,NUMARG,IDEBDI,MAXBAR,IBARDI,
7487     1IBUGP2,IFOUND,IERROR)
7488      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
7489C
749012999 CONTINUE
7491C
7492CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 1992
7493C               **********************************************
7494C               **  TREAT THE BAR   EXPANSION FACTORS  CASE **
7495C               **  (USED ONLY BY BLOCK PLOT COMMAND)       **
7496C               **********************************************
7497C
7498      IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'EXPA')GOTO13000
7499      IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'FACT')GOTO13000
7500      GOTO13099
7501C
750213000 CONTINUE
7503      CALL DPBAEF(IHARG,IARGT,ARG,NUMARG,BARHEF,BARWEF,
7504     1IBUGP2,IFOUND,IERROR)
7505      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
7506C
750713099 CONTINUE
7508C
7509C               **********************************
7510C               **  END POINT FOR BAR COMMANDS  **
7511C               **********************************
7512C
751319999 CONTINUE
7514C
7515C     ----------END OF BARS---------------------------------------
7516C
7517C     ----------REGIONS-----------------------------------------------
7518C
7519C               ********************************************
7520C               **  STEP XX--                             **
7521C               **  TREAT THE VARIOUS REGION ... COMMANDS **
7522C               ********************************************
7523C
7524      IF(ICOM.EQ.'REGI')GOTO21000
7525      GOTO22999
752621000 CONTINUE
7527C
7528C               *************************************************
7529C               **  TREAT THE REGION PATTERN LINE (TYPE)  CASE **
7530C               *************************************************
7531C
7532      IF(ICOM.EQ.'REGI'.AND.IHARG(1).EQ.'PATT'.AND.
7533     1IHARG(2).EQ.'LINE'.AND.IHARG(3).EQ.'TYPE')GOTO21120
7534      IF(ICOM.EQ.'REGI'.AND.IHARG(1).EQ.'PATT'.AND.
7535     1IHARG(2).EQ.'LINE')GOTO21100
7536      GOTO21199
7537C
753821100 CONTINUE
7539      ISHIFT=1
7540      CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
7541     1IBUGP2,IERROR)
7542      IHARG(3)='TYPE'
7543      IHARG2(3)='    '
754421120 CONTINUE
7545CCCCC AUGUST 1995.  ADD IHARG2 FOR DASH2, ETC
7546CCCCC CALL DPRPLI(IHARG,NUMARG,IDERPL,MAXREG,IREPLI,
7547      CALL DPRPLI(IHARG,IHARG2,NUMARG,IDERPL,MAXREG,IREPLI,
7548     1IBUGP2,IFOUND,IERROR)
7549      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
7550C
755121199 CONTINUE
7552C
7553C               *******************************************
7554C               **  TREAT THE REGION PATTERN COLOR  CASE **
7555C               *******************************************
7556C
7557      IF(ICOM.EQ.'REGI'.AND.IHARG(1).EQ.'PATT'.AND.
7558     1IHARG(2).EQ.'COLO')GOTO21200
7559      GOTO21299
7560C
756121200 CONTINUE
7562      CALL DPRPCO(IHARG,NUMARG,IDERPC,MAXREG,IREPCO,
7563     1IBUGP2,IFOUND,IERROR)
7564      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
7565C
756621299 CONTINUE
7567C
7568C               ***********************************************
7569C               **  TREAT THE REGION PATTERN THICKNESS  CASE **
7570C               ***********************************************
7571C
7572      IF(ICOM.EQ.'REGI'.AND.IHARG(1).EQ.'PATT'.AND.
7573     1IHARG(2).EQ.'THIC')GOTO21300
7574      GOTO21399
7575C
757621300 CONTINUE
7577      CALL DPRPTH(IHARG,IARGT,ARG,NUMARG,PDERPT,MAXREG,PREPTH,
7578     1IBUGP2,IFOUND,IERROR)
7579      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
7580C
758121399 CONTINUE
7582C
7583C               ***********************************************
7584C               **  TREAT THE REGION PATTERN SPACING    CASE **
7585C               ***********************************************
7586C
7587      IF(ICOM.EQ.'REGI'.AND.IHARG(1).EQ.'PATT'.AND.
7588     1IHARG(2).EQ.'SPAC')GOTO21400
7589      GOTO21499
7590C
759121400 CONTINUE
7592      CALL DPRPSP(IHARG,IARGT,ARG,NUMARG,PDERPS,MAXREG,PREPSP,
7593     1IBUGP2,IFOUND,IERROR)
7594      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
7595C
759621499 CONTINUE
7597C
7598C               **********************************************
7599C               **  TREAT THE REGION PATTERN (TYPE)  CASE   **
7600C               **********************************************
7601C
7602      IF(ICOM.EQ.'REGI'.AND.IHARG(1).EQ.'PATT'.AND.
7603     1IHARG(2).EQ.'TYPE')GOTO21520
7604      IF(ICOM.EQ.'REGI'.AND.IHARG(1).EQ.'PATT')GOTO21500
7605      GOTO21599
7606C
760721500 CONTINUE
7608      ISHIFT=1
7609      CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
7610     1IBUGP2,IERROR)
7611      IHARG(2)='TYPE'
7612      IHARG2(2)='    '
761321520 CONTINUE
7614      CALL DPRPTY(IHARG,NUMARG,IDERPT,MAXREG,IREPTY,
7615     1IBUGP2,IFOUND,IERROR)
7616      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
7617C
761821599 CONTINUE
7619C
7620C               ****************************************
7621C               **  TREAT THE REGION FILL COLOR  CASE **
7622C               ****************************************
7623C
7624CCCCC JANUARY, 1991.  CHECK FOR "REGIS COLOR" COMMAND.
7625      IF(ICOM.EQ.'REGI' .AND. ICOM2.EQ.'S   ')GOTO21799
7626C
7627      IF(ICOM.EQ.'REGI'.AND.IHARG(1).EQ.'FILL'.AND.
7628     1  IHARG(2).EQ.'COLO')THEN
7629        ICASCL='STAN'
7630      ELSEIF(ICOM.EQ.'REGI'.AND.IHARG(1).EQ.'FILL'.AND.
7631     1  IHARG(2).EQ.'RGB '.AND.IHARG(3).EQ.'COLO')THEN
7632        ICASCL='RGB'
7633        ISHIFT=1
7634        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
7635     1              IBUGP2,IERROR)
7636        IHARG(1)='FILL'
7637        IHARG2(1)='    '
7638        IHARG(2)='COLO'
7639        IHARG2(2)='    '
7640      ELSEIF(ICOM.EQ.'REGI'.AND.IHARG(1).EQ.'COLO')THEN
7641        ICASCL='STAN'
7642        ISHIFT=1
7643        CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
7644     1              IBUGP2,IERROR)
7645        IHARG(1)='FILL'
7646        IHARG2(1)='    '
7647        IHARG(2)='COLO'
7648        IHARG2(2)='    '
7649      ELSE
7650        GOTO21799
7651      ENDIF
7652C
7653      CALL DPRFCO(IHARG,IARG,NUMARG,IDERFC,MAXREG,IREFCO,
7654     1            ICASCL,IREFC2,
7655     1            IBUGP2,ISUBRO,IFOUND,IERROR)
7656      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
7657C
765821799 CONTINUE
7659C
7660C               *******************************************
7661C               **  TREAT THE REGION FILL (SWITCH) CASE  **
7662C               *******************************************
7663C
7664      IF(ICOM.EQ.'REGI'.AND.IHARG(1).EQ.'FILL'.AND.
7665     1IHARG(2).EQ.'SWIT')GOTO21820
7666      IF(ICOM.EQ.'REGI'.AND.IHARG(1).EQ.'FILL')GOTO21800
7667      GOTO21899
7668C
766921800 CONTINUE
7670CCCCC IF(IHARG(1).EQ.'ON')GOTO21810      MAY 5, 1987 FOR 3D FIGURES
7671CCCCC IF(IHARG(2).EQ.'ON')GOTO21810      MAY 5, 1987 FOR 3D FIGURES
7672CCCCC IF(IHARG(1).EQ.'OFF')GOTO21810      MAY 5, 1987 FOR 3D FIGURES
7673CCCCC IF(IHARG(2).EQ.'OFF')GOTO21810      MAY 5, 1987 FOR 3D FIGURES
7674CCCCC GOTO21899                            MAY 5, 1987 FOR 3D FIGURES
7675      GOTO21810
767621810 CONTINUE
7677      ISHIFT=1
7678      CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
7679     1IBUGP2,IERROR)
7680      IHARG(2)='SWIT'
7681      IHARG2(2)='CH  '
768221820 CONTINUE
7683      CALL DPRFSW(IHARG,NUMARG,IDERFS,MAXREG,IREFSW,
7684     1IBUGP2,IFOUND,IERROR)
7685      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
7686C
768721899 CONTINUE
7688C
7689C               ******************************************
7690C               **  TREAT THE REGION BORDER COLOR  CASE **
7691C               ******************************************
7692C
7693      IF(ICOM.EQ.'REGI'.AND.IHARG(1).EQ.'BORD'.AND.
7694     1IHARG(2).EQ.'COLO')GOTO22100
7695      GOTO22199
7696C
769722100 CONTINUE
7698      CALL DPRBCO(IHARG,NUMARG,IDERBC,MAXREG,IREBCO,
7699     1IBUGP2,IFOUND,IERROR)
7700      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
7701C
770222199 CONTINUE
7703C
7704C               **********************************************
7705C               **  TREAT THE REGION BORDER THICKNESS  CASE **
7706C               **********************************************
7707C
7708      IF(ICOM.EQ.'REGI'.AND.IHARG(1).EQ.'BORD'.AND.
7709     1IHARG(2).EQ.'THIC')GOTO22200
7710      GOTO22299
7711C
771222200 CONTINUE
7713      CALL DPRBTH(IHARG,IARGT,ARG,NUMARG,PDERBT,MAXREG,PREBTH,
7714     1IBUGP2,IFOUND,IERROR)
7715      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
7716C
771722299 CONTINUE
7718C
7719C               **************************************************
7720C               **  TREAT THE REGION BORDER LINE (TYPE)  CASE   **
7721C               **************************************************
7722C
7723      IF(ICOM.EQ.'REGI'.AND.IHARG(1).EQ.'BORD'.AND.
7724     1IHARG(2).EQ.'LINE'.AND.IHARG(3).EQ.'TYPE')GOTO22330
7725      IF(ICOM.EQ.'REGI'.AND.IHARG(1).EQ.'BORD'.AND.
7726     1IHARG(2).EQ.'TYPE')GOTO22320
7727      IF(ICOM.EQ.'REGI'.AND.IHARG(1).EQ.'BORD'.AND.
7728     1IHARG(2).EQ.'LINE')GOTO22320
7729      IF(ICOM.EQ.'REGI'.AND.IHARG(1).EQ.'BORD')GOTO22310
7730      GOTO22399
7731C
773222310 CONTINUE
7733      ISHIFT=2
7734      CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
7735     1IBUGP2,IERROR)
7736      IHARG(2)='LINE'
7737      IHARG2(2)='    '
7738      IHARG(3)='TYPE'
7739      IHARG2(3)='    '
7740      GOTO22330
7741C
774222320 CONTINUE
7743      ISHIFT=1
7744      CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
7745     1IBUGP2,IERROR)
7746      IHARG(2)='LINE'
7747      IHARG2(2)='    '
7748      IHARG(3)='TYPE'
7749      IHARG2(3)='    '
7750      GOTO22330
7751C
775222330 CONTINUE
7753CCCCC AUGUST 1995.  ADD IHARG2 FOR DASH2, ETC
7754CCCCC CALL DPRBLI(IHARG,NUMARG,IDERBL,MAXREG,IREBLI,
7755      CALL DPRBLI(IHARG,IHARG2,NUMARG,IDERBL,MAXREG,IREBLI,
7756     1IBUGP2,IFOUND,IERROR)
7757      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
7758C
775922399 CONTINUE
7760C
7761C               ***********************************
7762C               **  TREAT THE REGION   BASE CASE **
7763C               ***********************************
7764C
7765      IF(ICOM.EQ.'REGI'.AND.IHARG(1).EQ.'BASE')GOTO22600
7766      IF(ICOM.EQ.'REGI'.AND.IHARG(1).EQ.'REFE')GOTO22600
7767      GOTO22699
7768C
776922600 CONTINUE
7770CCCCC OCTOBER 1993.  CHANGE ARGUMENT LIST (INCLUDE FILES IN SUBROUTINE)
7771CCCCC MARCH 1994.    ADD IREBPL TO ARGUMENT LIST.
7772      CALL DPREBA(ADERBA,MAXREG,AREGBA,IREBIN,IREBPL,
7773CCCCC CALL DPREBA(ADERBA,MAXREG,AREGBA,IREBIN,
7774CCCCC CALL DPREBA(IHARG,IARGT,ARG,NUMARG,ADERBA,MAXREG,AREGBA,
7775     1IBUGP2,IFOUND,IERROR)
7776      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
7777C
777822699 CONTINUE
7779C
7780C               *************************************
7781C               **  END POINT FOR REGION COMMANDS  **
7782C               *************************************
7783C
778422999 CONTINUE
7785C
7786C     ----------END OF REGIONS------------------------------------------
7787C
7788C     ----------MARKERS-------------------------------------------------
7789C
7790C               *********************************************
7791C               **  STEP XX--                              **
7792C               **  TREAT THE VARIOUS MARKER ... COMMANDS  **
7793C               *********************************************
7794C
7795      IF(ICOM.EQ.'MARK')GOTO31000
7796      GOTO32999
779731000 CONTINUE
7798C
7799C               *************************************************
7800C               **  TREAT THE MARKER PATTERN LINE (TYPE)  CASE **
7801C               *************************************************
7802C
7803      IF(ICOM.EQ.'MARK'.AND.IHARG(1).EQ.'PATT'.AND.
7804     1IHARG(2).EQ.'LINE'.AND.IHARG(3).EQ.'TYPE')GOTO31120
7805      IF(ICOM.EQ.'MARK'.AND.IHARG(1).EQ.'PATT'.AND.
7806     1IHARG(2).EQ.'LINE')GOTO31100
7807      GOTO31199
7808C
780931100 CONTINUE
7810      ISHIFT=1
7811      CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
7812     1IBUGP2,IERROR)
7813      IHARG(3)='TYPE'
7814      IHARG2(3)='    '
781531120 CONTINUE
7816CCCCC AUGUST 1995.  ADD IHARG2 FOR DASH2, ETC
7817CCCCC CALL DPMPLI(IHARG,NUMARG,IDEMPL,MAXMAR,IMAPLI,
7818      CALL DPMPLI(IHARG,IHARG2,NUMARG,IDEMPL,MAXMAR,IMAPLI,
7819     1IBUGP2,IFOUND,IERROR)
7820      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
7821C
782231199 CONTINUE
7823C
7824C               *******************************************
7825C               **  TREAT THE MARKER PATTERN COLOR  CASE **
7826C               *******************************************
7827C
7828      IF(ICOM.EQ.'MARK'.AND.IHARG(1).EQ.'PATT'.AND.
7829     1IHARG(2).EQ.'COLO')GOTO31200
7830      GOTO31299
7831C
783231200 CONTINUE
7833      CALL DPMPCO(IHARG,NUMARG,IDEMPC,MAXMAR,IMAPCO,
7834     1IBUGP2,IFOUND,IERROR)
7835      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
7836C
783731299 CONTINUE
7838C
7839C               ***********************************************
7840C               **  TREAT THE MARKER PATTERN THICKNESS  CASE **
7841C               ***********************************************
7842C
7843      IF(ICOM.EQ.'MARK'.AND.IHARG(1).EQ.'PATT'.AND.
7844     1IHARG(2).EQ.'THIC')GOTO31300
7845      GOTO31399
7846C
784731300 CONTINUE
7848      CALL DPMPTH(IHARG,IARGT,ARG,NUMARG,PDEMPT,MAXMAR,PMAPTH,
7849     1IBUGP2,IFOUND,IERROR)
7850      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
7851C
785231399 CONTINUE
7853C
7854C               ***********************************************
7855C               **  TREAT THE MARKER PATTERN SPACING    CASE **
7856C               ***********************************************
7857C
7858      IF(ICOM.EQ.'MARK'.AND.IHARG(1).EQ.'PATT'.AND.
7859     1IHARG(2).EQ.'SPAC')GOTO31400
7860      GOTO31499
7861C
786231400 CONTINUE
7863      CALL DPMPSP(IHARG,IARGT,ARG,NUMARG,PDEMPS,MAXMAR,PMAPSP,
7864     1IBUGP2,IFOUND,IERROR)
7865      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
7866C
786731499 CONTINUE
7868C
7869C               **********************************************
7870C               **  TREAT THE MARKER PATTERN (TYPE)  CASE   **
7871C               **********************************************
7872C
7873      IF(ICOM.EQ.'MARK'.AND.IHARG(1).EQ.'PATT'.AND.
7874     1IHARG(2).EQ.'TYPE')GOTO31520
7875      IF(ICOM.EQ.'MARK'.AND.IHARG(1).EQ.'PATT')GOTO31500
7876      GOTO31599
7877C
787831500 CONTINUE
7879      ISHIFT=1
7880      CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
7881     1IBUGP2,IERROR)
7882      IHARG(2)='TYPE'
7883      IHARG2(2)='    '
788431520 CONTINUE
7885      CALL DPMPTY(IHARG,NUMARG,IDEMPT,MAXMAR,IMAPTY,
7886     1IBUGP2,IFOUND,IERROR)
7887      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
7888C
788931599 CONTINUE
7890C
7891C               ****************************************
7892C               **  TREAT THE MARKER FILL COLOR  CASE **
7893C               ****************************************
7894C
7895      IF(ICOM.EQ.'MARK'.AND.IHARG(1).EQ.'FILL'.AND.
7896     1IHARG(2).EQ.'COLO')GOTO31750
7897      IF(ICOM.EQ.'MARK'.AND.IHARG(1).EQ.'COLO')GOTO31710
7898      GOTO31799
7899C
790031710 CONTINUE
7901      ISHIFT=1
7902      CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
7903     1IBUGP2,IERROR)
7904      IHARG(1)='FILL'
7905      IHARG2(1)='    '
7906      IHARG(2)='COLO'
7907      IHARG2(2)='    '
7908      GOTO31750
7909C
791031750 CONTINUE
7911      CALL DPMFCO(IHARG,NUMARG,IDEMFC,MAXMAR,IMAFCO,
7912     1IBUGP2,IFOUND,IERROR)
7913      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
7914C
791531799 CONTINUE
7916C
7917C               *******************************************
7918C               **  TREAT THE MARKER FILL (SWITCH) CASE  **
7919C               *******************************************
7920C
7921      IF(ICOM.EQ.'MARK'.AND.IHARG(1).EQ.'FILL'.AND.
7922     1IHARG(2).EQ.'SWIT')GOTO31820
7923      IF(ICOM.EQ.'MARK'.AND.IHARG(1).EQ.'FILL')GOTO31800
7924      GOTO31899
7925C
792631800 CONTINUE
7927      IF(IHARG(1).EQ.'ON')GOTO31810
7928      IF(IHARG(2).EQ.'ON')GOTO31810
7929      IF(IHARG(1).EQ.'OFF')GOTO31810
7930      IF(IHARG(2).EQ.'OFF')GOTO31810
7931      GOTO31899
793231810 CONTINUE
7933      ISHIFT=1
7934      CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
7935     1IBUGP2,IERROR)
7936      IHARG(2)='SWIT'
7937      IHARG2(2)='CH  '
793831820 CONTINUE
7939      CALL DPMFSW(IHARG,NUMARG,IDEMFS,MAXMAR,IMAFSW,
7940     1IBUGP2,IFOUND,IERROR)
7941      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
7942C
794331899 CONTINUE
7944C
7945C               ******************************************
7946C               **  TREAT THE MARKER BORDER COLOR  CASE **
7947C               ******************************************
7948C
7949      IF(ICOM.EQ.'MARK'.AND.IHARG(1).EQ.'BORD'.AND.
7950     1IHARG(2).EQ.'COLO')GOTO32100
7951      GOTO32199
7952C
795332100 CONTINUE
7954      CALL DPMBCO(IHARG,NUMARG,IDEMBC,MAXMAR,IMABCO,
7955     1IBUGP2,IFOUND,IERROR)
7956      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
7957C
795832199 CONTINUE
7959C
7960C               **********************************************
7961C               **  TREAT THE MARKER BORDER THICKNESS  CASE **
7962C               **********************************************
7963C
7964      IF(ICOM.EQ.'MARK'.AND.IHARG(1).EQ.'BORD'.AND.
7965     1IHARG(2).EQ.'THIC')GOTO32200
7966      GOTO32299
7967C
796832200 CONTINUE
7969      CALL DPMBTH(IHARG,IARGT,ARG,NUMARG,PDEMBT,MAXMAR,PMABTH,
7970     1IBUGP2,IFOUND,IERROR)
7971      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
7972C
797332299 CONTINUE
7974C
7975C               **************************************************
7976C               **  TREAT THE MARKER BORDER LINE (TYPE)  CASE   **
7977C               **************************************************
7978C
7979      IF(ICOM.EQ.'MARK'.AND.IHARG(1).EQ.'BORD'.AND.
7980     1IHARG(2).EQ.'LINE'.AND.IHARG(3).EQ.'TYPE')GOTO32330
7981      IF(ICOM.EQ.'MARK'.AND.IHARG(1).EQ.'BORD'.AND.
7982     1IHARG(2).EQ.'TYPE')GOTO32320
7983      IF(ICOM.EQ.'MARK'.AND.IHARG(1).EQ.'BORD'.AND.
7984     1IHARG(2).EQ.'LINE')GOTO32320
7985      IF(ICOM.EQ.'MARK'.AND.IHARG(1).EQ.'BORD')GOTO32310
7986      GOTO32399
7987C
798832310 CONTINUE
7989      ISHIFT=2
7990      CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
7991     1IBUGP2,IERROR)
7992      IHARG(2)='LINE'
7993      IHARG2(2)='    '
7994      IHARG(3)='TYPE'
7995      IHARG2(3)='    '
7996      GOTO32330
7997C
799832320 CONTINUE
7999      ISHIFT=1
8000      CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
8001     1IBUGP2,IERROR)
8002      IHARG(2)='LINE'
8003      IHARG2(2)='    '
8004      IHARG(3)='TYPE'
8005      IHARG2(3)='    '
8006      GOTO32330
8007C
800832330 CONTINUE
8009CCCCC AUGUST 1995.  ADD IHARG2 FOR DASH2, ETC
8010CCCCC CALL DPMBLI(IHARG,NUMARG,IDEMBL,MAXMAR,IMABLI,
8011      CALL DPMBLI(IHARG,IHARG2,NUMARG,IDEMBL,MAXMAR,IMABLI,
8012     1IBUGP2,IFOUND,IERROR)
8013      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8014C
801532399 CONTINUE
8016C
8017C               ***********************************
8018C               **  TREAT THE MARKER   BASE CASE **
8019C               ***********************************
8020C
8021      IF(ICOM.EQ.'MARK'.AND.IHARG(1).EQ.'BASE')GOTO32600
8022      IF(ICOM.EQ.'MARK'.AND.IHARG(1).EQ.'REFE')GOTO32600
8023      GOTO32699
8024C
802532600 CONTINUE
8026      CALL DPMABA(IHARG,IARGT,ARG,NUMARG,ADEMBA,MAXMAR,AMARBA,
8027     1IBUGP2,IFOUND,IERROR)
8028      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8029C
803032699 CONTINUE
8031C
8032C               *************************************
8033C               **  END POINT FOR MARKER COMMANDS  **
8034C               *************************************
8035C
803632999 CONTINUE
8037C
8038C     ----------END OF MARKERS---------------------------------------
8039C
8040C     ----------TEXTS--------------------------------------------------
8041C
8042C               ***********************************************
8043C               **  STEP XX--                                **
8044C               **  TREAT THE VARIOUS TEXT ... COMMANDS      **
8045C               **  TREAT THE TEXT PATTERN LINE (TYPE)  CASE **
8046C               **  TREAT THE TEXT PATTERN COLOR        CASE **
8047C               **  TREAT THE TEXT PATTERN THICKNESS    CASE **
8048C               **  TREAT THE TEXT PATTERN SPACING      CASE **
8049C               **  TREAT THE TEXT PATTERN (TYPE)       CASE **
8050C               **  TREAT THE TEXT FILL COLOR           CASE **
8051C               **  TREAT THE TEXT FILL (SWITCH)        CASE **
8052C               **  TREAT THE TEXT BORDER COLOR         CASE **
8053C               **  TREAT THE TEXT BORDER THICKNESS     CASE **
8054C               **  TREAT THE TEXT BORDER LINE (TYPE)   CASE **
8055C               **  TREAT THE TEXT BASE                 CASE **
8056C               ***********************************************
8057C
8058      IF(ICOM.EQ.'TEXT')THEN
8059C
8060        IF(IHARG(1).EQ.'PATT'.AND.IHARG(2).EQ.'LINE'.AND.
8061     1     IHARG(3).EQ.'TYPE')THEN
8062          CALL DPTPLI(IHARG,IHARG2,NUMARG,IDETPL,MAXTEX,ITEPLI,
8063     1                IBUGP2,IFOUND,IERROR)
8064          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8065        ELSEIF(IHARG(1).EQ.'PATT'.AND.IHARG(2).EQ.'LINE')THEN
8066          ISHIFT=1
8067          CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
8068     1                IBUGP2,IERROR)
8069          IHARG(3)='TYPE'
8070          IHARG2(3)='    '
8071          CALL DPTPLI(IHARG,IHARG2,NUMARG,IDETPL,MAXTEX,ITEPLI,
8072     1                IBUGP2,IFOUND,IERROR)
8073          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8074C
8075        ELSEIF(IHARG(1).EQ.'PATT'.AND.IHARG(2).EQ.'COLO'.AND.
8076     1         IHARG2(2).EQ.'R   ')THEN
8077          CALL DPTPCO(IHARG,NUMARG,IDETPC,MAXTEX,ITEPCO,
8078     1                IBUGP2,IFOUND,IERROR)
8079          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8080C
8081        ELSEIF(IHARG(1).EQ.'PATT'.AND.IHARG(2).EQ.'THIC')THEN
8082          CALL DPTPTH(IHARG,IARGT,ARG,NUMARG,PDETPT,MAXTEX,PTEPTH,
8083     1                IBUGP2,IFOUND,IERROR)
8084          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8085C
8086        ELSEIF(IHARG(1).EQ.'PATT'.AND.IHARG(2).EQ.'SPAC')THEN
8087          CALL DPTPSP(IHARG,IARGT,ARG,NUMARG,PDETPS,MAXTEX,PTEPSP,
8088     1                IBUGP2,IFOUND,IERROR)
8089          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8090C
8091        ELSEIF(IHARG(1).EQ.'PATT'.AND.IHARG(2).EQ.'TYPE')THEN
8092          CALL DPTPTY(IHARG,NUMARG,IDETPT,MAXTEX,ITEPTY,
8093     1                IBUGP2,IFOUND,IERROR)
8094          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8095        ELSEIF(IHARG(1).EQ.'PATT')THEN
8096          ISHIFT=1
8097          CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
8098     1                IBUGP2,IERROR)
8099          IHARG(2)='TYPE'
8100          IHARG2(2)='    '
8101          CALL DPTPTY(IHARG,NUMARG,IDETPT,MAXTEX,ITEPTY,
8102     1                IBUGP2,IFOUND,IERROR)
8103          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8104C
8105        ELSEIF(IHARG(1).EQ.'FILL'.AND.IHARG(2).EQ.'COLO'.AND.
8106     1         IHARG2(2).EQ.'R   ')THEN
8107          CALL DPTFCO(IHARG,NUMARG,IDETFC,MAXTEX,ITEFCO,
8108     1                IBUGP2,IFOUND,IERROR)
8109          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8110        ELSEIF(IHARG(1).EQ.'COLO'.AND.IHARG2(1).EQ.'R   ')THEN
8111          ISHIFT=1
8112          CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
8113     1                IBUGP2,IERROR)
8114          IHARG(1)='FILL'
8115          IHARG2(1)='    '
8116          IHARG(2)='COLO'
8117          IHARG2(2)='    '
8118          CALL DPTFCO(IHARG,NUMARG,IDETFC,MAXTEX,ITEFCO,
8119     1                IBUGP2,IFOUND,IERROR)
8120          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8121C
8122        ELSEIF(IHARG(1).EQ.'FILL'.AND.IHARG(2).EQ.'SWIT')THEN
8123          CALL DPTFSW(IHARG,NUMARG,IDETFS,MAXTEX,ITEFSW,
8124     1                IBUGP2,IFOUND,IERROR)
8125          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8126        ELSEIF(IHARG(1).EQ.'FILL')THEN
8127          IF(IHARG(1).EQ.'ON'.OR.IHARG(2).EQ.'ON'.OR.
8128     1       IHARG(1).EQ.'OFF'.OR.IHARG(2).EQ.'OFF')THEN
8129            ISHIFT=1
8130            CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
8131     1                  IBUGP2,IERROR)
8132            IHARG(2)='SWIT'
8133            IHARG2(2)='CH  '
8134            CALL DPTFSW(IHARG,NUMARG,IDETFS,MAXTEX,ITEFSW,
8135     1                  IBUGP2,IFOUND,IERROR)
8136            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8137          ENDIF
8138C
8139        ELSEIF(IHARG(1).EQ.'BORD'.AND.IHARG(2).EQ.'COLO'.AND.
8140     1         IHARG2(2).EQ.'R   ')THEN
8141          CALL DPTBCO(IHARG,NUMARG,IDETBC,MAXTEX,ITEBCO,
8142     1                IBUGP2,IFOUND,IERROR)
8143          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8144C
8145        ELSEIF(IHARG(1).EQ.'BORD'.AND.IHARG(2).EQ.'THIC')THEN
8146          CALL DPTBTH(IHARG,IARGT,ARG,NUMARG,PDETBT,MAXTEX,PTEBTH,
8147     1                IBUGP2,IFOUND,IERROR)
8148          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8149C
8150        ELSEIF(IHARG(1).EQ.'BORD'.AND.IHARG(2).EQ.'LINE'.AND.
8151     1         IHARG(3).EQ.'TYPE')THEN
8152          CALL DPTBLI(IHARG,IHARG2,NUMARG,IDETBL,MAXTEX,ITEBLI,
8153     1                IBUGP2,IFOUND,IERROR)
8154          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8155        ELSEIF(IHARG(1).EQ.'BORD'.AND.
8156     1        (IHARG(2).EQ.'LINE' .OR. IHARG(2).EQ.'TYPE'))THEN
8157          ISHIFT=1
8158          CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
8159     1                IBUGP2,IERROR)
8160          IHARG(2)='LINE'
8161          IHARG2(2)='    '
8162          IHARG(3)='TYPE'
8163          IHARG2(3)='    '
8164          CALL DPTBLI(IHARG,IHARG2,NUMARG,IDETBL,MAXTEX,ITEBLI,
8165     1                IBUGP2,IFOUND,IERROR)
8166          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8167        ELSEIF(ICOM.EQ.'TEXT'.AND.IHARG(1).EQ.'BORD')THEN
8168          ISHIFT=2
8169          CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
8170     1                IBUGP2,IERROR)
8171          IHARG(2)='LINE'
8172          IHARG2(2)='    '
8173          IHARG(3)='TYPE'
8174          IHARG2(3)='    '
8175          CALL DPTBLI(IHARG,IHARG2,NUMARG,IDETBL,MAXTEX,ITEBLI,
8176     1                IBUGP2,IFOUND,IERROR)
8177          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8178C
8179CCCCC   ELSEIF(IHARG(1).EQ.'BASE'.OR.IHARG(1).EQ.'REFE')THEN
8180CCCCC     CALL DPTEBA(IHARG,IARGT,ARG,NUMARG,ADETBA,MAXTEX,ATEXBA,
8181CCCCC1                IBUGP2,IFOUND,IERROR)
8182CCCCC     IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8183        ENDIF
8184      ENDIF
8185C
8186C               ***********************************
8187C               **  END POINT FOR TEXT COMMANDS  **
8188C               ***********************************
8189C
8190C
8191C     ----------END OF TEXTS---------------------------------------
8192C
8193C               *****************
8194C               **  STEP 90--  **
8195C               **  EXIT       **
8196C               *****************
8197C
8198 9000 CONTINUE
8199      IF(IBUGPC.EQ.'ON' .OR. ISUBRO.EQ.'IPC3')THEN
8200        WRITE(ICOUT,999)
8201        CALL DPWRST('XXX','BUG ')
8202        WRITE(ICOUT,9011)
8203 9011   FORMAT('***** AT THE END       OF MAIPC3--')
8204        CALL DPWRST('XXX','BUG ')
8205        WRITE(ICOUT,9020)IFOUND,IERROR
8206 9020   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
8207        CALL DPWRST('XXX','BUG ')
8208      ENDIF
8209C
8210      RETURN
8211      END
8212      SUBROUTINE MAIPC4(IBUGPC,IBUGP2,ISUBRO,IFOUND,IERROR)
8213C
8214C     PURPOSE--THIS IS SUBROUTING MAIPC4.
8215C              (THE   PC    AT THE END OF    MAIPC4   STANDS FOR PLOT CONTROL
8216C              THIS SUBROUTINE SEARCHES FOR AND EXECUTES
8217C              PLOT CONTROL COMMANDS (PART 1).
8218C              THE PLOT CONTROL COMMANDS SEARCHED FOR BY MAIPC4
8219C              ARE THE FOLLOWING 3D-RELATED COMMANDS--
8220C
8221C                 EYE (COORDINATES)
8222C                 ORIGIN COORDINATES
8223C                 VISIBLE (HIDDENLINES, BACKLINES)
8224C                 PROJECTION
8225C
8226C                 PEDESTAL ON/OFF
8227C                 PEDESTAL BASE
8228C                 PEDESTAL SIZE
8229C                 PEDESTAL COLOR
8230C                 PEDESTAL GRID
8231C                 PEDESTAL GRID PATTERN
8232C                 PEDESTAL GRID COLOR
8233C
8234C                 BASEPLANE ON/OFF
8235C                 BASEPLANE COLOR
8236C                 BASEPLANE GRID
8237C                 BASEPLANE GRID PATTERN
8238C                 BASEPLANE GRID COLOR
8239C
8240C                 BACKPLANE ON/OFF
8241C                 BACKPLANE COLOR
8242C                 BACKPLANE GRID
8243C                 BACKPLANE GRID PATTERN
8244C                 BACKPLANE GRID COLOR
8245C
8246C                 SIDEFACE ON/OFF
8247C                 SIDEFACE COLOR
8248C                 SIDEFACE GRID
8249C                 SIDEFACE GRID PATTERN
8250C                 SIDEFACE GRID COLOR
8251C
8252C                 TIC PLANE
8253C
8254C                 ROTATE EYE
8255C
8256C     WRITTEN BY--JAMES J. FILLIBEN
8257C                 STATISTICAL ENGINEERING DIVISION
8258C                 INFORMATION TECHNOLOGY LABORATORY
8259C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
8260C                 GAITHERSBURG, MD 20899-8980
8261C                 PHONE--301-975-2855
8262C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
8263C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
8264C     LANGUAGE--ANSI FORTRAN (1977)
8265C     VERSION NUMBER  --88.10
8266C     ORIGINAL VERSION--SEPTEMBER 1988.
8267C     UPDATED         --APRIL     1992. DEPBA=DEFBA COMMENTED OUT
8268C     UPDATED         --SEPTEMBER 1993. ALLOW EYE FOR EYE COOR
8269C     UPDATED         --SEPTEMBER 1993. NEW COMMAND--ROTATE EYE
8270C
8271C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
8272C
8273      CHARACTER*4 IBUGPC
8274      CHARACTER*4 IBUGP2
8275      CHARACTER*4 ISUBRO
8276      CHARACTER*4 IFOUND
8277      CHARACTER*4 IERROR
8278C
8279C-----COMMON----------------------------------------------------------
8280C
8281      INCLUDE 'DPCOPA.INC'
8282      INCLUDE 'DPCOHK.INC'
8283      INCLUDE 'DPCOPC.INC'
8284      INCLUDE 'DPCO3D.INC'
8285      INCLUDE 'DPCOSU.INC'
8286      INCLUDE 'DPCODA.INC'
8287      INCLUDE 'DPCOP2.INC'
8288C
8289C-----START POINT-----------------------------------------------------
8290C
8291      IF(IBUGPC.EQ.'ON' .OR. ISUBRO.EQ.'IPC4')THEN
8292        WRITE(ICOUT,999)
8293  999   FORMAT(1X)
8294        CALL DPWRST('XXX','BUG ')
8295        WRITE(ICOUT,51)
8296   51   FORMAT('***** AT THE BEGINNING OF MAIPC4--')
8297        CALL DPWRST('XXX','BUG ')
8298        WRITE(ICOUT,53)IBUGPC,IBUGP2,ISUBRO
8299   53   FORMAT('IBUGPC,IBUGP2,ISUBRO = ',2(A4,2X),A4)
8300        CALL DPWRST('XXX','BUG ')
8301        WRITE(ICOUT,67)ICOM,ICOM2,NUMARG
8302   67   FORMAT('ICOM,ICOM2,NUMARG = ',2(A4,2X),I8)
8303        CALL DPWRST('XXX','BUG ')
8304        DO70I=1,NUMARG
8305          WRITE(ICOUT,71)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I)
8306   71     FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) = ',
8307     1           I8,3(2X,A4),2X,I8,G15.7)
8308          CALL DPWRST('XXX','BUG ')
8309   70   CONTINUE
8310      ENDIF
8311C
8312      IFOUND='NO'
8313      IERROR='NO'
8314C
8315CCCCC THE FOLLOWING SECTION WAS REWRITTEN    SEPTEMBER 1993
8316C               ***************************************
8317C               **  TREAT THE EYE (COORDINATES) CASE **
8318C               ***************************************
8319C
8320      IF(ICOM.EQ.'EYE')THEN
8321         IF(NUMARG.GE.1)THEN
8322            IF(IHARG(1).EQ.'COOR')THEN
8323               ISHIFT=1
8324               CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,
8325     1         IARGT,NUMARG,IBUGPC,IERROR)
8326            ENDIF
8327         ENDIF
8328         CALL DPEYCO(IHARG,IARGT,ARG,NUMARG,
8329     1   AEYEXC,AEYEYC,AEYEZC,
8330     1   X3DEYE,Y3DEYE,Z3DEYE,
8331     1   IFOUND,IERROR)
8332         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8333      ENDIF
8334C
8335C               *****************************************
8336C               **  TREAT THE ORIGIN COORDINATES CASE  **
8337C               *****************************************
8338C
8339      IF(ICOM.EQ.'ORIG')THEN
8340        CALL DPORCO(IHARG,IARGT,ARG,NUMARG,
8341     1              AORIXC,AORIYC,AORIZC,
8342     1              IFOUND,IERROR)
8343        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8344      ENDIF
8345C
8346C               *******************************
8347C               **  TREAT THE VISIBLE CASE   **
8348C               **  HIDDEN LINES, BACKLINES  **
8349C               *******************************
8350C
8351      IF(ICOM.EQ.'VISI')GOTO1300
8352      IF(ICOM.EQ.'HIDD')GOTO1300
8353      IF(ICOM.EQ.'BACK'.AND.ICOM2.EQ.'LINE')GOTO1300
8354      IF(ICOM.EQ.'BACK'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'LINE')
8355     1GOTO1300
8356      GOTO1399
8357C
8358 1300 CONTINUE
8359      CALL DPVIS(IHARG,NUMARG,IVISSW,IFOUND,IERROR)
8360      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8361C
8362 1399 CONTINUE
8363C
8364C               **************************************************
8365C               **  TREAT THE PROJECTION CASE (3D)              **
8366C               **************************************************
8367C
8368      IF(ICOM.EQ.'PROJ')GOTO1400
8369      IF(ICOM.EQ.'ORTH')GOTO1400
8370      IF(ICOM.EQ.'PERS')GOTO1400
8371      GOTO1499
8372C
8373 1400 CONTINUE
8374      CALL DPPROJ(ICOM,IHARG,NUMARG,I3DPRO,
8375     1IFOUND,IERROR)
8376      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8377C
8378 1499 CONTINUE
8379C
8380CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1993
8381C               **************************************
8382C               **  TREAT THE ROTATE EYE CASE       **
8383C               **************************************
8384C
8385      IF(ICOM.EQ.'ROTA')THEN
8386         CALL DPROEY(IHARG,IARGT,ARG,NUMARG,
8387     1   X3DEYE,Y3DEYE,Z3DEYE,
8388     1   X3DMID,Y3DMID,Z3DMID,
8389     1   AEYEXC,AEYEYC,AEYEZC,
8390     1   IFOUND,IERROR)
8391         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8392      ENDIF
8393C
8394C     -----PEDESTAL-----
8395C
8396C               ******************************************
8397C               **  TREAT THE PEDESTAL GRID COLOR CASE  **
8398C               ******************************************
8399C
8400      IF(ICOM.EQ.'PEDE')GOTO2100
8401      GOTO2199
8402C
8403 2100 CONTINUE
8404      IF(NUMARG.GE.2.AND.
8405     1IHARG(1).EQ.'GRID'.AND.IHARG(2).EQ.'COLO')GOTO2110
8406      GOTO2199
8407 2110 CONTINUE
8408      CALL DPPEGC(IHARG,NUMARG,IDEPGC,IPEDGC,IFOUND,IERROR)
8409      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8410C
8411 2199 CONTINUE
8412C
8413C               *********************************************
8414C               **  TREAT THE PEDESTAL GRID PATTERN  CASE  **
8415C               *********************************************
8416C
8417      IF(ICOM.EQ.'PEDE')GOTO2200
8418      GOTO2299
8419C
8420 2200 CONTINUE
8421      IF(NUMARG.GE.2.AND.
8422     1IHARG(1).EQ.'GRID'.AND.IHARG(2).EQ.'PATT')GOTO2210
8423      GOTO2299
8424 2210 CONTINUE
8425      CALL DPPEGP(IHARG,NUMARG,IDEPGP,IPEDGP,IFOUND,IERROR)
8426      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8427C
8428 2299 CONTINUE
8429C
8430C               *************************************
8431C               **  TREAT THE PEDESTAL GRID  CASE  **
8432C               *************************************
8433C
8434      IF(ICOM.EQ.'PEDE')GOTO2300
8435      GOTO2399
8436C
8437 2300 CONTINUE
8438      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'GRID')GOTO2310
8439      GOTO2399
8440 2310 CONTINUE
8441      CALL DPPEGR(IHARG,NUMARG,IDEPGR,IPEDGR,IFOUND,IERROR)
8442      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8443C
8444 2399 CONTINUE
8445C
8446C               *************************************
8447C               **  TREAT THE PEDESTAL COLOR CASE  **
8448C               *************************************
8449C
8450      IF(ICOM.EQ.'PEDE')GOTO2400
8451      GOTO2499
8452C
8453 2400 CONTINUE
8454      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COLO')GOTO2410
8455      GOTO2499
8456 2410 CONTINUE
8457      CALL DPPECL(IHARG,NUMARG,IDEPCO,IPEDCO,IFOUND,IERROR)
8458      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8459C
8460 2499 CONTINUE
8461C
8462C               **************************************
8463C               **  TREAT THE PEDESTAL SIZE   CASE  **
8464C               **************************************
8465C
8466      IF(ICOM.EQ.'PEDE')GOTO2500
8467      GOTO2599
8468C
8469 2500 CONTINUE
8470      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'SIZE')GOTO2510
8471      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'HEIG')GOTO2510
8472      GOTO2599
8473 2510 CONTINUE
8474      CALL DPPESZ(IHARG,IARGT,ARG,NUMARG,
8475     1ADEPSZ,APEDSZ,
8476     1IFOUND,IERROR)
8477      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8478C
8479 2599 CONTINUE
8480C
8481C               *************************************
8482C               **  TREAT THE PEDESTAL BASE  CASE  **
8483C               *************************************
8484C
8485      IF(ICOM.EQ.'PEDE')GOTO2600
8486      GOTO2699
8487C
8488 2600 CONTINUE
8489      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'BASE')GOTO2610
8490      GOTO2699
8491 2610 CONTINUE
8492CCCCC THE FOLLOWING LINE WAS COMMENTED OUT   APRIL 1992 (ALAN)
8493CCCCC DEPBA=DEFBA
8494      CALL DPPEBA(IHARG,IARGT,ARG,NUMARG,
8495     1ADEPBA,APEDBA,
8496     1IFOUND,IERROR)
8497      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8498C
8499 2699 CONTINUE
8500C
8501C               *******************************
8502C               **  TREAT THE PEDESTAL CASE  **
8503C               *******************************
8504C
8505      IF(ICOM.EQ.'PEDE')GOTO2700
8506      GOTO2799
8507C
8508 2700 CONTINUE
8509      CALL DPPED(IHARG,NUMARG,IPEDSW,IFOUND,IERROR)
8510      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8511C
8512 2799 CONTINUE
8513C
8514C     -----BASEPLANE-----
8515C
8516C               ******************************************
8517C               **  TREAT THE BASEPLANE GRID COLOR CASE **
8518C               ******************************************
8519C
8520      IF(ICOM.EQ.'BASE')GOTO3100
8521      GOTO3199
8522C
8523 3100 CONTINUE
8524      IF(NUMARG.GE.2.AND.
8525     1IHARG(1).EQ.'GRID'.AND.IHARG(2).EQ.'COLO')GOTO3110
8526      GOTO3199
8527 3110 CONTINUE
8528      CALL DPBSGC(IHARG,NUMARG,IDBSGC,IBSPGC,IFOUND,IERROR)
8529      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8530C
8531 3199 CONTINUE
8532C
8533C               *********************************************
8534C               **  TREAT THE BASEPLANE GRID PATTERN  CASE **
8535C               *********************************************
8536C
8537      IF(ICOM.EQ.'BASE')GOTO3200
8538      GOTO3299
8539C
8540 3200 CONTINUE
8541      IF(NUMARG.GE.2.AND.
8542     1IHARG(1).EQ.'GRID'.AND.IHARG(2).EQ.'PATT')GOTO3210
8543      GOTO3299
8544 3210 CONTINUE
8545      CALL DPBSGP(IHARG,NUMARG,IDBSGP,IBSPGP,IFOUND,IERROR)
8546      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8547C
8548 3299 CONTINUE
8549C
8550C               *************************************
8551C               **  TREAT THE BASEPLANE GRID  CASE **
8552C               *************************************
8553C
8554      IF(ICOM.EQ.'BASE')GOTO3300
8555      GOTO3399
8556C
8557 3300 CONTINUE
8558      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'GRID')GOTO3310
8559      GOTO3399
8560 3310 CONTINUE
8561      CALL DPBSGR(IHARG,NUMARG,IDBSGR,IBSPGR,IFOUND,IERROR)
8562      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8563C
8564 3399 CONTINUE
8565C
8566C               *************************************
8567C               **  TREAT THE BASEPLANE COLOR CASE **
8568C               *************************************
8569C
8570      IF(ICOM.EQ.'BASE')GOTO3400
8571      GOTO3499
8572C
8573 3400 CONTINUE
8574      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COLO')GOTO3410
8575      GOTO3499
8576 3410 CONTINUE
8577      CALL DPBSCL(IHARG,NUMARG,IDBSCO,IBSPCO,IFOUND,IERROR)
8578      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8579C
8580 3499 CONTINUE
8581C
8582C               *******************************
8583C               **  TREAT THE BASEPLANE CASE **
8584C               *******************************
8585C
8586      IF(ICOM.EQ.'BASE')GOTO3500
8587      GOTO3599
8588C
8589 3500 CONTINUE
8590      CALL DPBSP(IHARG,NUMARG,IBSPSW,IFOUND,IERROR)
8591      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8592C
8593 3599 CONTINUE
8594C
8595C     -----BACKPLANE-----
8596C
8597C               ******************************************
8598C               **  TREAT THE BACKPLANE GRID COLOR CASE **
8599C               ******************************************
8600C
8601      IF(ICOM.EQ.'BACK'.AND.ICOM2.EQ.'PLAN')GOTO4100
8602      GOTO4199
8603C
8604 4100 CONTINUE
8605      IF(NUMARG.GE.2.AND.
8606     1IHARG(1).EQ.'GRID'.AND.IHARG(2).EQ.'COLO')GOTO4110
8607      GOTO4199
8608 4110 CONTINUE
8609      CALL DPBKGC(IHARG,NUMARG,IDBKGC,IBKPGC,IFOUND,IERROR)
8610      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8611C
8612 4199 CONTINUE
8613C
8614C               *********************************************
8615C               **  TREAT THE BACKPLANE GRID PATTERN  CASE **
8616C               *********************************************
8617C
8618      IF(ICOM.EQ.'BACK'.AND.ICOM2.EQ.'PLAN')GOTO4200
8619      GOTO4299
8620C
8621 4200 CONTINUE
8622      IF(NUMARG.GE.2.AND.
8623     1IHARG(1).EQ.'GRID'.AND.IHARG(2).EQ.'PATT')GOTO4210
8624      GOTO4299
8625 4210 CONTINUE
8626      CALL DPBKGP(IHARG,NUMARG,IDBKGP,IBKPGP,IFOUND,IERROR)
8627      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8628C
8629 4299 CONTINUE
8630C
8631C               *************************************
8632C               **  TREAT THE BACKPLANE GRID  CASE **
8633C               *************************************
8634C
8635      IF(ICOM.EQ.'BACK'.AND.ICOM2.EQ.'PLAN')GOTO4300
8636      GOTO4399
8637C
8638 4300 CONTINUE
8639      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'GRID')GOTO4310
8640      GOTO4399
8641 4310 CONTINUE
8642      CALL DPBKGR(IHARG,NUMARG,IDBKGR,IBKPGR,IFOUND,IERROR)
8643      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8644C
8645 4399 CONTINUE
8646C
8647C               *************************************
8648C               **  TREAT THE BACKPLANE COLOR CASE **
8649C               *************************************
8650C
8651      IF(ICOM.EQ.'BACK'.AND.ICOM2.EQ.'PLAN')GOTO4400
8652      GOTO4499
8653C
8654 4400 CONTINUE
8655      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COLO')GOTO4410
8656      GOTO4499
8657 4410 CONTINUE
8658      CALL DPBKCL(IHARG,NUMARG,IDBKCO,IBKPCO,IFOUND,IERROR)
8659      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8660C
8661 4499 CONTINUE
8662C
8663C               *******************************
8664C               **  TREAT THE BACKPLANE CASE **
8665C               *******************************
8666C
8667      IF(ICOM.EQ.'BACK'.AND.ICOM2.EQ.'PLAN')GOTO4500
8668      GOTO4599
8669C
8670 4500 CONTINUE
8671      CALL DPBKP(IHARG,NUMARG,IBKPSW,IFOUND,IERROR)
8672      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8673C
8674 4599 CONTINUE
8675C
8676C     -----SIDEFACE-----
8677C
8678C               ******************************************
8679C               **  TREAT THE SIDEFACE GRID COLOR CASE  **
8680C               ******************************************
8681C
8682      IF(ICOM.EQ.'SIDE')GOTO5100
8683      GOTO5199
8684C
8685 5100 CONTINUE
8686      IF(NUMARG.GE.2.AND.
8687     1IHARG(1).EQ.'GRID'.AND.IHARG(2).EQ.'COLO')GOTO5110
8688      GOTO5199
8689 5110 CONTINUE
8690      CALL DPSDGC(IHARG,NUMARG,IDSDGC,ISDFGC,IFOUND,IERROR)
8691      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8692C
8693 5199 CONTINUE
8694C
8695C               *********************************************
8696C               **  TREAT THE SIDEFACE GRID PATTERN  CASE  **
8697C               *********************************************
8698C
8699      IF(ICOM.EQ.'SIDE')GOTO5200
8700      GOTO5299
8701C
8702 5200 CONTINUE
8703      IF(NUMARG.GE.2.AND.
8704     1IHARG(1).EQ.'GRID'.AND.IHARG(2).EQ.'PATT')GOTO5210
8705      GOTO5299
8706 5210 CONTINUE
8707      CALL DPSDGP(IHARG,NUMARG,IDSDGP,ISDFGP,IFOUND,IERROR)
8708      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8709C
8710 5299 CONTINUE
8711C
8712C               *************************************
8713C               **  TREAT THE SIDEFACE GRID  CASE  **
8714C               *************************************
8715C
8716      IF(ICOM.EQ.'SIDE')GOTO5300
8717      GOTO5399
8718C
8719 5300 CONTINUE
8720      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'GRID')GOTO5310
8721      GOTO5399
8722 5310 CONTINUE
8723      CALL DPSDGR(IHARG,NUMARG,IDSDGR,ISDFGR,IFOUND,IERROR)
8724      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8725C
8726 5399 CONTINUE
8727C
8728C               *************************************
8729C               **  TREAT THE SIDEFACE COLOR CASE  **
8730C               *************************************
8731C
8732      IF(ICOM.EQ.'SIDE')GOTO5400
8733      GOTO5499
8734C
8735 5400 CONTINUE
8736      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COLO')GOTO5410
8737      GOTO5499
8738 5410 CONTINUE
8739      CALL DPSDCL(IHARG,NUMARG,IDSDCO,ISDFCO,IFOUND,IERROR)
8740      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8741C
8742 5499 CONTINUE
8743C
8744C               *******************************
8745C               **  TREAT THE SIDEFACE CASE  **
8746C               *******************************
8747C
8748      IF(ICOM.EQ.'SIDE')GOTO5500
8749      GOTO5599
8750C
8751 5500 CONTINUE
8752      CALL DPSDF(IHARG,NUMARG,ISDFSW,IFOUND,IERROR)
8753      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
8754C
8755 5599 CONTINUE
8756C
8757C               *****************
8758C               **  STEP 90--  **
8759C               **  EXIT       **
8760C               *****************
8761C
8762 9000 CONTINUE
8763      IF(IBUGPC.EQ.'ON' .OR. ISUBRO.EQ.'IPC4')THEN
8764        WRITE(ICOUT,999)
8765        CALL DPWRST('XXX','BUG ')
8766        WRITE(ICOUT,9011)
8767 9011   FORMAT('***** AT THE END       OF MAIPC4--')
8768        CALL DPWRST('XXX','BUG ')
8769        WRITE(ICOUT,9020)IFOUND,IERROR
8770 9020   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
8771        CALL DPWRST('XXX','BUG ')
8772      ENDIF
8773C
8774      RETURN
8775      END
8776      SUBROUTINE MAINSU(IDEFSE,ISEED,ANOPL1,ANOPL2,
8777     1                  ISQUAR,IBOOSS,IDEBOO,
8778     1                  IANSSV,IREPMX,ILISMX,IPOINT,
8779     1                  ISACNC,IAUTSW,IAUTEX,ITOPIC,MAXNXT,IPROSW,
8780     1                  IMACRO,IMACNU,IMACCS,IMACL1,IMACL2,IMACLR,
8781     1                  IOFILE,IMALEV,IPROGR,ICONCL,
8782     1                  ICOM3,ICOM4,ICOM5,NUMCOM,NCOM5,
8783     1                  ICTRA1,NCTRA1,ICTRA2,NCTRA2,NUMTRA,
8784     1                  IBASLC,IREPCH,IOSW,ICAPSW,IPRDEF,
8785     1                  IBUGUG,IBUGU2,IBUGU3,IBUGU4,ISUBRO,
8786     1                  IBUGEX,IBUGE2,IBUGHE,IBUGH2,IBUGLO,
8787     1                  ICPREH,NCPREH,ICPOSH,NCPOSH,IOUTTY,IPRITY,
8788     1                  IHELMX,IFTEXP,IFTORD,ALOWFR,ALOWDG,
8789     1                  IFORSW,ICREAF,NCREAF,ICWRIF,NCWRIF,
8790     1                  IREARW,IWRIRW,
8791     1                  IUNFOF,IUNFNR,IUNFMC,
8792     1                  IRHSTG,IMPSW,IERRFA,IGUIFL,IGUIFB,
8793     1                  ITABTI,NCTABT,ITABBR,ITABSP,ITABWD,ITABHT,
8794     1                  IANSLO,ILOOST,ILOOLI,NUMLIL,NUMLOS,IWIDLL,
8795     1                  IIFSW,NUMIF,
8796     1                  NPLOTP,IFOUND,IERROR)
8797C
8798CCCCC IBASLC WAS ADDED TO ABOVE INPUT ARGUMENT LIST       JUNE 1989
8799CCCCC ICAPSW AND IPRDEF WERE ADDED TO ABOVE ARGUMENT LIST JUNE 1989
8800CCCCC ADD "LOOP" ARGUMENTS (FOR READ COMMAND) JANUARY 2015.
8801C
8802C     PURPOSE--THIS IS SUBROUTING MAINSU.
8803C
8804C              (THE   SU    AT THE END OF    MAINSU   STANDS FOR   SUPPORT)
8805C              THIS SUBROUTINE SEARCHES FOR AND EXECUTES SUPPORT COMMANDS.
8806C              THE SUPPORT COMMANDS SEARCHED FOR BY MAINSU ARE AS FOLLOWS--
8807C
8808C                     ADD                            N/A                 ADD CAL
8809C                     ANOP LIMITS (= PROPORTION LIMITS)     +-INFINITY
8810C                     BAUD                           9600                BAUD 12
8811C                     BUGS                           N/A                 BUGS
8812C                     CLASS ... LOWER                AUTOMATIC           CLASS L
8813C                     CLASS ... UPPER                AUTOMATIC FROM DATA CLASS U
8814C                     CLASS ... WIDTH                AUTOMATIC FROM DATA CLASS W
8815C                     COLUMN LIMITS                  1 132               COLUMN
8816C                     COMMENT                        N/A                 COMMENT
8817C                     CURSOR SIZE                    1.0                 CURSOR
8818C                     DEFAULT COMMAND                NO COMMAND          DEFAULT
8819C                     DELETE                         N/A                 DELETE
8820C                     DEMODULATION FREQUENCY         0.25                DEMODUL
8821C                     DIMENSION                      1000 ROWS 10 COLS   DIMENSI
8822C                     DOUBLE PRECISION               OFF = SING. PREC.   DOUBLE
8823C                     ECHO                           OFF = NO ECHO       ECHO ON
8824C                     END                            N/A                 END
8825C                     ERASE DELAY                    1                   ERASE D
8826C                     FEEDBACK                       ON = FEEDBACK       FEEDBAC
8827C                     FILTER WIDTH                   3                   FILTER
8828C                     FIT CONSTRAINT                 ALL UNCONSTRAINED   FIT CON
8829C                     FIT ITERATIONS                 50                  FIT ITE
8830C                     FIT STANDARD DEVIATION         .000005             FIT STA
8831C                     HARDCOPY DELAY                 1                   HARDCOP
8832C                     HELP                           N/A                 HELP PL
8833C                     HOST                           THE    LOCAL    HOST    HOS
8834C                     HOST LINK                      THE    LOCAL    HOST    HOS
8835C                     IMPLEMENT                      ORIG. INITIALIZ.     IMPLEM
8836C                     KNOTS                          OFF = NO KNOTS      KNOTS K
8837C                     MACRO (CREATE)                 OFF                 MACRO
8838C                     MAIL                           N/A                 MAIL JO
8839C                     MAXIMUM RECORD LENGTH          N/A                 MAIL JO
8840C                     NAME                           N/A                 NAME Y
8841C                     NEWS                           N/A                 NEWS
8842C                     OPERATOR                       N/A                 OPERAT
8843C                     POLYNOMIAL DEGREE              1 = LINEAR          POLYNOM
8844C                     PRECISION                      SINGLE              PRECISI
8845C                     PRE-ERASE                      ON = PRE-ERASE      PRE-ERA
8846C                     PRINTING                       ON = PRINTING       PRINTIN
8847C                     PROBE                          N/A                 PROBE N
8848C                     QUADRUPLE PRECISION            OFF = SING. PREC.   QUADRUP
8849C                     QUERY                          N/A                 QUERY H
8850C                     READ                           N/A                 READ CA
8851C                     RESET                          N/A                 RESET
8852C                     RESTORE                        N/A                 RESTORE
8853C                     RETAIN                         N/A                 RETAIN
8854C                     ROW LIMITS                     1 INFINITY          ROW LIM
8855C                     SAVE                           N/A                 SAVE SC
8856C                     SEED                           20867350019         SEED
8857C                     TERMIANATOR CHARACTER          ;                   SEPAR
8858C                     SERIAL READ                    N/A                 SERIAL
8859C                     SET                            OFF                 SET IBU
8860C                     SINGLE PRECISION               ON                  SINGLE
8861C                     SKIP                           0 = NO LINES        SKIP 5
8862C                     STATUS                         N/A                 STATUS
8863C                     TIME                           N/A                 TIME
8864C                     TRIPLE PRECISION               OFF = SING. PREC.   TRIPLE
8865C                     WEIGHTS                        OFF = EQUI-WEIGHTED WEIGHTS
8866C                     WRITE                          N/A                 WRITE C
8867C                     .                              N/A                 . CARRY
8868C                     CONTINUE CHARACTER             ...                 CONTI
8869C                     PRINTER FORMAT ASCII/POSTSCRIPT
8870C                     FILE FORMAT ASCII/POSTSCRIPT
8871C
8872C                     VECTOR FORMAT <ANGLE/POINT/DELTA>
8873C                     VECTOR ARROW  <FIXED/VARIABLE>
8874C                     VECTOR ARROW  <OPEN/CLOSED>
8875C                     ANDREWS INCREMENT
8876C                     OPTIMIZATION METHOD
8877C                     WEB HELP
8878C                     RECIPE SATTERWAITE APPROXIMATION
8879C                     RECIPE OUTPUT
8880C                     RECIPE PROBABILITY CONTENT (OR RECIPE CONTENT)
8881C                     RECIPE CONFIDENCE
8882C                     RECIPE FIT DEGREE (OR RECIPE DEGREE)
8883C                     RECIPE ANOVA FACTORS (OR RECIPE FACTORS)
8884C                     RECIPE CORRELATION
8885C                     RECIPE SIMCOV REPLICATES
8886C                     RECIPE SIMPVT REPLICATES
8887C
8888C                     GUI WRITE/PRINT
8889C                     GUI STATUS
8890C                     GUI PLOT CONTROL <N>
8891C
8892C                     VARIABLE LABEL
8893C
8894C                     ORTHOGONAL DISTANCE ERROR
8895C                     ORTHOGONAL DISTANCE DELTA
8896C
8897C                     KERNEL DENSITY WIDTH
8898C                     KERNEL DENSITY POINTS
8899C
8900C                     AUTO TEXT
8901C
8902C                     SYSTEM
8903C                     PROCES ID (OR PID)
8904C                     CPU TIME
8905C                     PWD       (OR GETCWD, CURRENT DIRECTORY)
8906C                     CLIPBOARD CLEAR (OR CLEAR CLIPBOARD)
8907C                     CLIPBOARD
8908C
8909C     WRITTEN BY--JAMES J. FILLIBEN
8910C                 STATISTICAL ENGINEERING DIVISION
8911C                 INFORMATION TECHNOLOGY LABORATORY
8912C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
8913C                 GAITHERSBURG, MD 20899-8980
8914C                 PHONE--301-975-2855
8915C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
8916C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
8917C     LANGUAGE--ANSI FORTRAN (1977)
8918C     VERSION NUMBER--82.6
8919C     ORIGINAL VERSION--NOVEMBER  1980.
8920C     UPDATED         --MARCH     1981.
8921C     UPDATED         --AUGUST    1981.
8922C     UPDATED         --SEPTEMBER 1981.
8923C     UPDATED         --OCTOBER   1981.
8924C     UPDATED         --JANUARY   1982.
8925C     UPDATED         --FEBRUARY  1982.
8926C     UPDATED         --MARCH     1982.
8927C     UPDATED         --MAY       1982.
8928C     UPDATED         --SEPTEMBER 1983.
8929C     UPDATED         --JANUARY   1986.
8930C     UPDATED         --OCTOBER   1987. (ISUBRO FOR DPAPPE AND DPEXTE)
8931C     UPDATED         --AUGUST    1988. EQUATE PROPORTION LIMITS WITH ANOP LIM
8932C     UPDATED         --DECEMBER  1988. ADJUST RESET FOR RESET2
8933C     UPDATED         --DECEMBER  1988. RESET DATA, IO, PC, ETC.
8934C     UPDATED         --DECEMBER  1988. SET WRITE FORMAT
8935C     UPDATED         --DECEMBER  1988.  SET READ  REWIND
8936C     UPDATED         --DECEMBER  1988.  SET WRITE REWIND
8937C     UPDATED         --DECEMBER  1988.  LOWESS FRACTION
8938C     UPDATED         --DECEMBER  1988.  READ/WRITE DECI, FORMAT, REWIND
8939C     UPDATED         --JANUARY   1989.  BOOTSTRAP SAMPLE SIZE
8940C     UPDATED         --FEBRUARY  1989.  CONTINUE CHARACTER (ALAN)
8941C     UPDATED         --FEBRUARY  1989.  SOFT-CODED LIMITS FOR IANSSV (ALAN)
8942C     UPDATED         --FEBRUARY  1989.  SYSTEM COMMAND (ALAN)
8943C     UPDATED         --JUNE      1989.  REPLACEMENT/SUBSTITUTION CHARACTER
8944C     UPDATED         --JUNE      1989.  CAPTURE (TEXT OUTPUT)
8945C     UPDATED         --JULY      1989.  MORE/PAUSE TO LIST
8946C     UPDATED         --NOVEMBER  1989.  COLUMN RULER
8947C     UPDATED         --NOVEMBER  1989.  NLIST
8948C     UPDATED         --NOVEMBER  1989.  ADD ARG TO CALL TO DPSYST
8949C     UPDATED         --MARCH     1990.  ADD ARGUMENT TO SYSTEM COMMAND (ALAN)
8950C     UPDATED         --MAY       1990.  ADD ARGUMENTS TO DPREAD, DPREAL
8951C     UPDATED         --MAY       1990.  COMMENT CHARACTER COMMAND
8952C     UPDATED         --JUNE      1990.  IBUGD2 TO IBUGS2 IN CALL TO DPSYST
8953C     UPDATED         --JULY      1990.  ICOMFL RENAMED AS ICOMSW
8954C     UPDATED         --SEPTEMBER 1990.  DOS, UNIX, ETC. FOR SYSTEM
8955C     UPDATED         --SEPTEMBER 1990.  DATE SYNONYM FOR TIME
8956C     UPDATED         --MARCH     1992.  PRINTER FORMAT ASCI/POST
8957C     UPDATED         --MARCH     1992.  FILE FORMAT ASCI/POST
8958C     UPDATED         --APRIL     1992.  ADD NPLOTP TO ARGS
8959C     UPDATED         --AUGUST    1992.  VECTOR FORMAT, VECTOR ARROW
8960C     UPDATED         --SEPTEMBER 1992.  LIST SYNONYMS: VIEW/PREVIEW
8961C     UPDATED         --NOVEMBER  1992.  ANDREWS INCREMENT
8962C     UPDATED         --JULY      1993.  FRACTAL ITERATIONS
8963C     UPDATED         --JULY      1993.  FRACTAL TYPE
8964C     UPDATED         --JULY      1993.  PRINCIPLE COMPONENT TYPE
8965C     UPDATED         --JULY      1993.  ADD ARGS TO DPLICO: MORE
8966C     UPDATED         --SEPTEMBER 1993.  REWRITE CODE AROUND DPLICO
8967C     UPDATED         --DECEMBER  1993.  CHECK FOR "SAVE" AND "S CHART"
8968C                                        CONFLICT.
8969C     UPDATED         --JANUARY   1994.  SEARCH1
8970C     UPDATED         --MAY       1994.  COPY FILE => COPY
8971C     UPDATED         --JUNE      1994.  OPTIMIZATION TOLERANCE
8972C     UPDATED         --AUGUST    1994.  EXECUTE SUBSET OF MACRO
8973C     UPDATED         --SEPTEMBER 1994.  CHECK FOR NAME CONFLICT
8974C     UPDATED         --NOVEMBER  1994.  DECLARE NEWNAM (BOMB ON VAX)
8975C     UPDATED         --FEBRUARY  1995.  OPTIMIZATION METHOD
8976C     UPDATED         --APRIL     1995.  IUNFOF, IUNFNR, IUNFMC
8977C     UPDATED         --AUGUST    1995.  ADD IFTORD
8978C     UPDATED         --SEPTEMBER 1995.  ISUBRO ADDED TO CALL DPDELE
8979C     UPDATED         --SEPTEMBER 1995.  INIT COMMAND (FOR DEBUGGING)
8980C     UPDATED         --OCTOBER   1995.  NAME CONFLICT WITH DOUBLE
8981C     UPDATED         --MARCH     1997.  SUPPORT FOR DEVICE FONT (ALAN)
8982C     UPDATED         --APRIL     1997.  WEB HELP COMMAND (ALAN)
8983C     UPDATED         --APRIL     1997.  LIST GRAPH (ALAN)
8984C     UPDATED         --APRIL     1997.  SAVE GRAPH (ALAN)
8985C     UPDATED         --APRIL     1997.  REPEAT GRAPH (ALAN)
8986C     UPDATED         --APRIL     1997.  CYCLE GRAPH (ALAN)
8987C     UPDATED         --AUGUST    1997.  SLEEP (= PAUSE <n>)
8988C     UPDATED         --AUGUST    1997.  CD COMMAND
8989C     UPDATED         --AUGUST    1997.  6 RECIPE COMMANDS
8990C     UPDATED         --NOVEMBER  1997.  GUI PRINT/WRITE
8991C     UPDATED         --NOVEMBER  1997.  GUI STATUS
8992C     UPDATED         --NOVEMBER  1997.  GUI SAVE PLOT CONTROL
8993C     UPDATED         --JANUARY   1998.  CALL TO DPDIME
8994C     UPDATED         --NOVEMBER  1998.  CALL LIST TO DPSET, DPPROB
8995C     UPDATED         --MARCH     1998.  NAME CONFLICT WITH CP AND CP PLOT
8996C     UPDATED         --APRIL     1997.  RECIPE FIT FACTORS COMMANDS
8997C     UPDATED         --MARCH     1999.  NAME CONFLICT FOR SINGLE
8998C     UPDATED         --NOVEMBER  1999.  VARIABLE LABEL
8999C     UPDATED         --APRIL     2001.  ORTHOGONAL DISTANCE ERROR
9000C     UPDATED         --APRIL     2001.  ORTHOGONAL DISTANCE DELTA
9001C     UPDATED         --AUGUST    2001.  KERNEL DENSITY WIDTH/POINTS
9002C     UPDATED         --JUNE      2002.  ICAPTY IN DPCAPT CALL
9003C     UPDATED         --FEBRUARY  2003.  CALL TO DPREAD, DPSERI
9004C     UPDATED         --FEBRUARY  2003.  CALL TO DPCOLL
9005C     UPDATED         --FEBRUARY  2003.  ADD: MAXIMUM RECORD LENGTH
9006C     UPDATED         --FEBRUARY  2003.  CALL LIST TO DPSEAR
9007C     UPDATED         --SEPTEMBER 2003.  CALL LIST TO DPWRIT
9008C     UPDATED         --SEPTEMBER 2005.  CALL LIST TO DPMACR
9009C     UPDATED         --SEPTEMBER 2005.  MACRO SUBSTITUTION CHARACTER
9010C     UPDATED         --JANUARY   2006.  ARGUMENT LIST TO DPCAPT
9011C     UPDATED         --MARCH     2006.  PROCESS ID
9012C     UPDATED         --AUGUST    2007.  USER-DEFINED ACTION ON
9013C                                        ERROR
9014C     UPDATED         --SEPTEMBER 2007.  IERRST
9015C     UPDATED         --MAY       2008.  GUI FEEDBACK SWITCH
9016C     UPDATED         --APRIL     2009.  TABLE WIDTH COMMAND
9017C     UPDATED         --APRIL     2009.  CALL LIST TO DPWRIT
9018C     UPDATED         --MAY       2009.  ADD CPU TIME COMMAND
9019C     UPDATED         --MAY       2010.  REMOVE "MAIL" AND "QUERY"
9020C                                        COMMANDS
9021C     UPDATED         --JANUARY   2011.  ADD PWD COMMAND
9022C     UPDATED         --NOVEMBER  2014.  CLIPBOARD CLEAR
9023C     UPDATED         --NOVEMBER  2014.  CLIPBOARD RUN
9024C     UPDATED         --JANUARY   2015. LOOP ARGUMENTS TO DPREAD
9025C     UPDATED         --MARCH     2015. CALL LIST TO DPINFU
9026C     UPDATED         --MARCH     2015. CALL LIST TO UPDATF
9027C     UPDATED         --NOVEMBER  2015. CALL LIST TO DPMACR
9028C     UPDATED         --DECEMBER  2015. CALL LIST TO MAININ
9029C     UPDATED         --JULY      2016. STREAM READ
9030C     UPDATED         --JULY      2017. CALL LIST TO DPMACR,
9031C                                       CALL LIST TO MAINSU
9032C     UPDATED         --JULY      2017. INSERT CALL ARGUMENTS COMMAND
9033C     UPDATED         --JULY      2017. ISSUE WITH COMMAND LINE
9034C                                       ARGUMENTS IN LOOP STORE MODE,
9035C                                       DO COMMAND LINE SUBSTITUTION
9036C                                       FOR FILE NAME, BUT NOT ARGUMENTS
9037C     UPDATED         --APRIL     2018. CALL LISTS TO DPHELW, DPHANW,
9038C                                       DPWEB
9039C     UPDATED         --DECEMBER  2018. SUPPORT FOR "DEVICE ... SCALE"
9040C                                       COMMAND
9041C     UPDATED         --FEBRUARY  2019. SUPPORT FOR "CALL CLIPBOARD"
9042C     UPDATED         --SEPTEMBER 2019. SUPPORT FOR "GREP" AS SEARCH
9043C                                       OPTION
9044C     UPDATED         --SEPTEMBER 2019. ADD "RM" AND "RMDIR" COMMANDS
9045C     UPDATED         --SEPTEMBER 2019. ADD "MKDIR" COMMAND
9046C     UPDATED         --SEPTEMBER 2019. ADD "CAT" COMMAND
9047C     UPDATED         --SEPTEMBER 2019. ADD "DIR" COMMAND
9048C     UPDATED         --SEPTEMBER 2019. FOR LIST AND SAVE, CHECK IF
9049C                                       FIRST ARGUMENT IS "="
9050C     UPDATED         --OCTOBER   2019. "HEAD" AND "TAIL" OPTIONS FOR
9051C                                       WRITE COMMAND
9052C     UPDATED         --NOVEMBER  2019. "RSCRIPT" AND "PYTHON"
9053C                                       COMMANDS
9054C     UPDATED         --FEBRUARY  2020. FOR "CLIPBOARD" COMMANDS,
9055C                                       CHECK IF "CLIPBOARD" ARGUMENT
9056C                                       IS ACTUALLY A FILE NAME.
9057C
9058C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
9059C
9060      INCLUDE 'DPCOPA.INC'
9061C
9062      CHARACTER*4 IMPSW
9063      CHARACTER*4 ILOOST
9064      CHARACTER*4 IIFSW
9065C
9066      CHARACTER*4 ISQUAR
9067      CHARACTER*4 ITOPIC
9068      CHARACTER*4 IPROSW
9069C
9070      CHARACTER*4 IMACRO
9071      CHARACTER*12 IMACCS
9072      CHARACTER*4 IOFILE
9073C
9074      CHARACTER*4 IPROGR
9075      CHARACTER*4 ICONCL
9076C
9077      CHARACTER*4 ICOM3
9078      CHARACTER*4 ICOM4
9079      CHARACTER*40 ICOM5
9080C
9081      CHARACTER*30 ICTRA1
9082      CHARACTER*30 ICTRA2
9083C
9084      CHARACTER*1 IBASLC
9085      CHARACTER*1 IREPCH
9086      CHARACTER*4 IOSW
9087      CHARACTER*4 IBUGUG
9088      CHARACTER*4 IBUGU2
9089      CHARACTER*4 IBUGU3
9090      CHARACTER*4 IBUGU4
9091      CHARACTER*4 IBUGEX
9092      CHARACTER*4 IBUGE2
9093      CHARACTER*4 IBUGHE
9094      CHARACTER*4 IBUGH2
9095      CHARACTER*4 IBUGLO
9096C
9097      CHARACTER*40 ICPREH
9098      CHARACTER*40 ICPOSH
9099C
9100CCCCC THE FOLLOWING 2 LINES WERE ADDED    MARCH 1992
9101      CHARACTER*4 IPRITY
9102      CHARACTER*4 IOUTTY
9103C
9104      CHARACTER*4 IFTEXP
9105CCCCC AUGUST 1995.  ADD FOLLOWING LINE
9106      CHARACTER*4 IFTORD
9107C
9108      CHARACTER*4 IFORSW
9109      CHARACTER*80 ICREAF
9110      CHARACTER*80 ICWRIF
9111C
9112      CHARACTER*4 IREARW
9113      CHARACTER*4 IWRIRW
9114      CHARACTER*4 ISUBRO
9115      CHARACTER*4 IFOUND
9116      CHARACTER*4 IERROR
9117C
9118      CHARACTER*4 IDEFHL
9119      CHARACTER*4 IHOSLI
9120C
9121      CHARACTER*1 IANSSV
9122CCCCC CHARACTER*80 ISACNC
9123      CHARACTER (LEN=MAXFNC) :: ISACNC
9124C
9125      CHARACTER*4 IAUTSW
9126      CHARACTER*4 IAUTEX
9127      CHARACTER*4 IBELSJ
9128      CHARACTER*4 IERASJ
9129      CHARACTER*4 IBACCJ
9130      CHARACTER*4 ICOPSJ
9131C
9132      CHARACTER*4 ISEART
9133C
9134CCCCC THE FOLLOWING LINE WAS ADDED JUNE 1989
9135      CHARACTER*4 ICAPSW
9136C
9137CCCCC THE FOLLOWING 5 LINES WERE ADDED FEBRUARY 1993
9138      CHARACTER*24 CURRTI
9139      CHARACTER*24 CURRDA
9140      CHARACTER*4 IC4
9141      CHARACTER*4 IFOUNN
9142      CHARACTER*4 IERRON
9143C
9144CCCCC THE FOLLOWING LINE NOVEMBER 1994
9145      CHARACTER*4 NEWNAM
9146CCCCC THE FOLLOWING 2 LINES WERE ADDED SEPTEMBER 1995
9147      CHARACTER*4 ICOMHO
9148      CHARACTER*4 ICOMH2
9149CCCCC THE FOLLOWING 2 LINES WERE ADDED OCTOBER 1996
9150      CHARACTER*4 IRHSTG
9151CCCCC THE FOLLOWING 2 LINES WERE ADDED SEPTEMBER 2003
9152      CHARACTER*4 ITABBR
9153      CHARACTER*80 ITABTI
9154C
9155      CHARACTER*4 ICASOD
9156C
9157      CHARACTER*4 IERRFA
9158      CHARACTER*4 IGUIFL
9159      CHARACTER*4 IGUIFB
9160      CHARACTER*4 ISUBN1
9161      CHARACTER*4 ISUBN2
9162      CHARACTER*4 ICASE2
9163C
9164      CHARACTER*4 IFUTMP(100)
9165C
9166      CHARACTER*4 IH
9167      CHARACTER*4 IH2
9168      CHARACTER*4 ISUBN0
9169C
9170      CHARACTER*1 IQUOTE
9171CCCCC CHARACTER*255 ICANS
9172      CHARACTER (LEN=MAXSTR) :: ICANS
9173C
9174      DIMENSION IDEFHL(10)
9175      DIMENSION IHOSLI(10)
9176C
9177CCCCC DIMENSION IANSSV(50,80)
9178      DIMENSION IANSSV(MAXLIS,MAXCIS)
9179      CHARACTER*4 IANSLO(MAXLIL,MAXCIL)
9180      DIMENSION IWIDLL(MAXLIL)
9181C
9182      DIMENSION ICOM3(*)
9183      DIMENSION ICOM4(*)
9184      DIMENSION ICOM5(*)
9185      DIMENSION NCOM5(*)
9186C
9187      DIMENSION ICTRA1(*)
9188      DIMENSION NCTRA1(*)
9189      DIMENSION ICTRA2(*)
9190      DIMENSION NCTRA2(*)
9191C
9192      CHARACTER*4 IFEESV
9193C
9194      CHARACTER*255 CURDIR
9195      CHARACTER*4   IFUNC9(255)
9196C
9197C-----COMMON----------------------------------------------------------
9198C
9199      INCLUDE 'DPCOFO.INC'
9200      INCLUDE 'DPCOMC.INC'
9201      INCLUDE 'DPCODB.INC'
9202      INCLUDE 'DPCOHK.INC'
9203      INCLUDE 'DPCOPC.INC'
9204      INCLUDE 'DPCODG.INC'
9205      INCLUDE 'DPCOSU.INC'
9206      INCLUDE 'DPCODA.INC'
9207      INCLUDE 'DPCOHO.INC'
9208      INCLUDE 'DPCOGR.INC'
9209CCCCC THE FOLLOWING LINE WAS INSERTED NOVEMBER 1989
9210      INCLUDE 'DPCODE.INC'
9211C
9212CCCCC TO AVOID NAME CONFLICTS, ONLY BRING IN THE SPECIFIC
9213CCCCC COMMON BLOCK
9214C
9215      CHARACTER*4  IERRST
9216      COMMON/CSETG/IERRST
9217C
9218C
9219C-----COMMON VARIABLES (GENERAL)--------------------------------------
9220C
9221      INCLUDE 'DPCOP2.INC'
9222C
9223C-----START POINT-----------------------------------------------------
9224C
9225      IF(IBUGSU.EQ.'ON'.OR.ISUBRO.EQ.'INSU')THEN
9226        WRITE(ICOUT,999)
9227  999   FORMAT(1X)
9228        CALL DPWRST('XXX','BUG ')
9229        WRITE(ICOUT,51)
9230   51   FORMAT('***** AT THE BEGINNING OF MAINSU--')
9231        CALL DPWRST('XXX','BUG ')
9232        WRITE(ICOUT,55)IBUGSU,IBUGS2,IBUGCO,IBUGEV,IBUGQ
9233   55   FORMAT('IBUGSU,IBUGS2,IBUGCO,IBUGEV,IBUGQ = ',4(A4,2X),A4)
9234        CALL DPWRST('XXX','BUG ')
9235        WRITE(ICOUT,58)IANGLU,ISQUAR,IFENSW,IBOOSS,IDEBOO
9236   58   FORMAT('IANGLU,ISQUAR,IFENSW,IBOOSS,IDEBOO = ',3(A4,2X),2I8)
9237        CALL DPWRST('XXX','BUG ')
9238        WRITE(ICOUT,59)IMACRO,IMACNU,IMACCS,IOFILE
9239   59   FORMAT('IMACRO,IMACNU,IMACCS,IOFILE = ',A4,I8,2X,A12,2X,A4)
9240        CALL DPWRST('XXX','BUG ')
9241        WRITE(ICOUT,62)IFOUND,IERROR,ICOM,ICOM2,NUMARG
9242   62   FORMAT('IFOUND,IERROR,ICOM,ICOM2,NUMARG = ',4(A4,2X),I8)
9243        CALL DPWRST('XXX','BUG ')
9244        DO70I=1,NUMARG
9245          WRITE(ICOUT,71)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I)
9246   71     FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) = ',
9247     1           I8,3(2X,A4),2X,I8,G15.7)
9248          CALL DPWRST('XXX','BUG ')
9249   70   CONTINUE
9250        WRITE(ICOUT,73)(IA(I),I=1,100)
9251   73   FORMAT('(IA(I),I=1,100) = ',100A1)
9252        CALL DPWRST('XXX','BUG ')
9253        WRITE(ICOUT,75)IMACRO,IPROGR,ICONCL,NUMCHA
9254   75   FORMAT('IMACRO,IPROGR,ICONCL,NUMCHA = ',3(A4,2X),I8)
9255        CALL DPWRST('XXX','BUG ')
9256        WRITE(ICOUT,81)ISACNC
9257   81   FORMAT('ISACNC = ',80A1)
9258        CALL DPWRST('XXX','BUG ')
9259        WRITE(ICOUT,82)IAUTSW,IAUTEX,ITOPIC,MAXNXT
9260   82   FORMAT('IAUTSW,IAUTEX,ITOPIC,MAXNXT = ',3(A4,2X),I8)
9261        CALL DPWRST('XXX','BUG ')
9262        WRITE(ICOUT,83)IHELMX,IFTEXP,IFORSW,ALOWFR
9263   83   FORMAT('IHELMX,IFTEXP,IFORSW,ALOWFR = ',I8,2(2X,A4),G15.7)
9264        CALL DPWRST('XXX','BUG ')
9265CCCCC   THE FOLLOWING 2 LINES WERE INSERTED NOVEMBER 1989
9266        WRITE(ICOUT,86)YATCCU,YATTCU,YATRCU,IYATOS,IYATRS
9267   86   FORMAT('YATCCU,YATTCU,YATRCU,IYATOS,IYATRS = ',3G15.7,
9268     1         2(2X,A4))
9269        CALL DPWRST('XXX','BUG ')
9270        WRITE(ICOUT,87)IRHSTG,IPRITY,IOUTTY,ALOWDG
9271   87   FORMAT('IRHSTG,IPRITY,IOUTTY,ALOWDG = ',3(A4,2X),G15.7)
9272        CALL DPWRST('XXX','BUG ')
9273        WRITE(ICOUT,88)ITABBR,ITABSP,ITABWD,ITABHT,NCTABT
9274   88   FORMAT('ITABBR,ITABSP,ITABWD,ITABHT,NCTABT = ',A4,2X,4I8)
9275        CALL DPWRST('XXX','BUG ')
9276        WRITE(ICOUT,89)ITABTI
9277   89   FORMAT('ITABTI = ',A80)
9278        CALL DPWRST('XXX','BUG ')
9279      ENDIF
9280C
9281      IFOUND='NO'
9282      IERROR='NO'
9283C
9284C               ******************************
9285C               **  TREAT THE ADD     CASE  **
9286C               **  TREAT THE CALL    CASE  **
9287C               **  TREAT THE EXECUTE CASE  **
9288C               **  TREAT THE RUN     CASE  **
9289C               ******************************
9290C
9291C     2015/03: CALL EXIT AND CALL EXIT ALL CASES SUPPORTED
9292C
9293      IF(ICOM.EQ.'ADD' .OR. ICOM.EQ.'CALL' .OR.
9294     1   ICOM.EQ.'EXEC' .OR. ICOM.EQ.'RUN ')THEN
9295C
9296        IF(NUMARG.EQ.1 .AND. IHARG(1).EQ.'CLIP' .AND.
9297     1     IHARG2(1).EQ.'BOAR')THEN
9298C
9299C         CHECK IF ARGUMENT IS A FILE NAME STARTING WITH
9300C         "CLIPBOARD.
9301C
9302          IWORD=2
9303          IOFILE='NO'
9304          CALL DPFILE(IANSLC,IWIDTH,IWORD,
9305     1                IOFILE,IBUGS2,ISUBRO,IERROR)
9306          IF(IOFILE.EQ.'NO')GOTO13390
9307        ENDIF
9308C
9309        IF(NUMARG.EQ.1 .AND.
9310     1    IHARG(1).EQ.'EXIT')THEN
9311          IMACCS='CLO2        '
9312          IMACRO='EOF'
9313          IFOUND='YES'
9314        ELSE
9315C
9316C         2015/11: COMMAND LINE SUBSTITUTION (ISSUE FOR LOOPS)
9317C
9318          IF(ILOOST.NE.'STOR')THEN
9319            CALL DPREP2(IANSLC,IWIDTH,
9320     1                  IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,
9321     1                  IVARLB,IROWLB,MAXOBV,
9322     1                  IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,IMALEV,
9323     1                  IBUGS2,ISUBRO,IERROR)
9324          ELSE
9325C
9326C           IN PROCESSING THE CALL COMMAND IN STORE MODE, WE ACTUALLY WANT
9327C           TO PERFORM COMMAND LINE SUBSTITION FOR THE FILE NAME, BUT NOT
9328C           FOR THE COMMAND LINE ARGUMENTS.  IF THERE ARE NO COMMAND LINE
9329C           ARGUMENTS, THEN NO SPECIAL PROCESSING NEEDED.
9330C
9331            ICANS=' '
9332            DO13301II=1,IWIDTH
9333              ICANS(II:II)=IANSLC(II)(1:1)
933413301       CONTINUE
9335C
9336C           NOW SEARCH FOR THE LOCATION OF THE FIRST TWO WORDS.
9337C
9338            IQUOTE='"'
9339            ISTART=0
9340            DO13303II=1,IWIDTH
9341              IF(ICANS(II:II).NE.' ')THEN
9342                ISTART=1
9343                GOTO13309
9344              ENDIF
934513303       CONTINUE
9346            GOTO13399
934713309       CONTINUE
9348C
9349            IQFLAG=0
9350            IF(ICANS(ISTART:ISTART).EQ.IQUOTE)IQFLAG=1
9351            DO13310KK=1,2
9352              DO13311II=ISTART,IWIDTH
9353                IF(IQFLAG.EQ.0)THEN
9354                  IF(ICANS(II:II).EQ.' ')THEN
9355                    ISTOP=II-1
9356                    GOTO13319
9357                  ENDIF
9358                ELSE
9359                  IF(ICANS(II:II).EQ.IQUOTE)THEN
9360                    ISTOP=II
9361                    GOTO13319
9362                  ENDIF
9363                ENDIF
936413311         CONTINUE
9365              CALL DPREP2(IANSLC,IWIDTH,
9366     1                    IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,
9367     1                    IVARLB,IROWLB,MAXOBV,
9368     1                    IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,IMALEV,
9369     1                    IBUGS2,ISUBRO,IERROR)
9370              GOTO13399
937113319         CONTINUE
9372              IF(KK.EQ.1)THEN
9373                ISTART=ISTOP+2
9374              ENDIF
937513310       CONTINUE
9376C
9377C           NOW DO COMMAND LINE SUBSTITUTION FOR THE FIRST ISTOP
9378C           CHARACTERS.
9379C
9380            ISTOP2=ISTOP
9381            CALL DPREP2(IANSLC,ISTOP,
9382     1                  IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,
9383     1                  IVARLB,IROWLB,MAXOBV,
9384     1                  IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,IMALEV,
9385     1                  IBUGS2,ISUBRO,IERROR)
9386            ICNT=ISTOP
9387            DO13321II=ISTOP2+1,IWIDTH
9388              ICNT=ICNT+1
9389              IANSLC(ICNT)(1:1)=ICANS(II:II)
939013321       CONTINUE
9391            IWIDTH=ICNT
9392          ENDIF
9393        ENDIF
9394C
939513399   CONTINUE
9396        CALL DPMACR(ICOM,ICOM2,
9397CCCCC   THE FOLOWING LINE WAS AUGMENTED   AUGUST 1994
9398CCCCC1              IMACRO,IMACNU,IMACCS,
9399     1              IMACRO,IMACNU,IMACCS,IMACL1,IMACL2,IMACLR,IMALEV,
9400     1              IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,MAXNAM,
9401     1              IANSLC,IWIDTH,
9402     1              IHARG,IHARG2,IARGT,IARG,ARG,NUMARG,
9403     1              IOFILE,
9404     1              ILOOST,ILOOLI,NUMLIL,NUMLOS,
9405     1              IANSLO,IWIDLL,MAXCIL,MAXLIL,
9406     1              IBUGS2,ISUBRO,IFOUND,IERROR)
9407C
9408C       IF "CALL EXIT" OR "CALL EXIT ALL" ENTERED, THEN DEPRECATE
9409C       CURRENT IF SWITCH SETTING.
9410C
9411        IF(ICOM.EQ.'CALL' .AND. IHARG(1).EQ.'EXIT')THEN
9412          IF(IIFSW.EQ.'TRUE' .AND. NUMIF.GT.0)NUMIF=NUMIF-1
9413        ENDIF
9414        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
9415      ENDIF
9416C
941713390 CONTINUE
9418C               **********************************************
9419C               **  TREAT THE INSERT CALL ARGUMENTS  CASE  **
9420C               **********************************************
9421C
9422      IF(ICOM.EQ.'INSE' .AND. IHARG(1).EQ.'CALL' .AND.
9423     1   IHARG(2).EQ.'ARGU')THEN
9424        CALL DPICLA(ICOM,ICOM2,
9425     1              IMACRO,IMACNU,IMACCS,
9426     1              IMACL1,IMACL2,
9427     1              IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,MAXNAM,
9428     1              IANSLC,IWIDTH,
9429     1              IHARG,IHARG2,IARGT,IARG,ARG,NUMARG,
9430     1              IBUGS2,ISUBRO,IFOUND,IERROR)
9431        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
9432      ENDIF
9433C
9434C
9435C               ******************************
9436C               **  TREAT THE DEFINE  CASE  **
9437C               ******************************
9438C
9439      IF(ICOM.EQ.'DEFI')THEN
9440        CALL DPDEFI(IHARG,IHARG2,IHARLC,NUMARG,
9441     1              ICOM3,ICOM4,ICOM5,NUMCOM,NCOM5,
9442     1              ICPREP,NCPREP,ICPOST,NCPOST,
9443     1              ICPREH,NCPREH,ICPOSH,NCPOSH,
9444     1              IBUGS2,ISUBRO,IFOUND,IERROR)
9445        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
9446      ENDIF
9447C
9448C               ********************************
9449C               **  TREAT THE TRANSLATE CASE  **
9450C               ********************************
9451C
9452      IF(ICOM.EQ.'TRAN')THEN
9453        CALL DPTRAN(IHARG,IHARG2,NUMARG,
9454     1              ICTRA1,NCTRA1,ICTRA2,NCTRA2,NUMTRA,
9455     1              IBUGS2,ISUBRO,IFOUND,IERROR)
9456        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
9457      ENDIF
9458C
9459C               ***************************
9460C               **  TREAT THE BAUD CASE  **
9461C               ***************************
9462C
9463      IF(ICOM.EQ.'BAUD')THEN
9464        CALL DPBAUD(IHARG,IARGT,IARG,NUMARG,IDEFBA,
9465     1              IBAUD,IFOUND,IERROR)
9466        IF(IFOUND.EQ.'YES'.AND.IERROR.EQ.'NO')THEN
9467          IGBAUD=IBAUD
9468          DO415I=1,MAXDEV
9469            IDBAUD(I)=IBAUD
9470  415     CONTINUE
9471        ENDIF
9472        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
9473      ENDIF
9474C
9475C               ************************************
9476C               **  TREAT THE COLUMN LIMITS CASE  **
9477C               ************************************
9478C
9479CCCCC IF(ICOM.EQ.'COLU')GOTO500
9480C  DECEMBER, 1989.  CHECK FOR CONFLICT WWITH COLUMN RULER COMMAND.
9481      IF(ICOM.EQ.'COLU'.AND.IHARG(1).NE.'RULE')GOTO500
9482      GOTO599
9483C
9484  500 CONTINUE
9485      CALL DPCOLL(IDEFC1,IDEFC2,IFCOL1,IFCOL2,
9486CCCCC FEBRUARY 2003: ADD FOLLOWING LINE
9487     1NUMRCM,
9488     1IFCOLL,IFCOLU,
9489     1IFOUND,IERROR)
9490      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
9491C
9492  599 CONTINUE
9493C
9494C               ************************************
9495C               **  TREAT THE TABLE WIDTH   CASE  **
9496C               ************************************
9497C
9498      IF(ICOM.EQ.'TABL'.AND.IHARG(1).EQ.'WIDT')THEN
9499        CALL DPTAWI(IFORWI,IFORWR,MAXNWI,
9500     1              ISUBRO,IBUGS2,IFOUND,IERROR)
9501        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
9502      ENDIF
9503C
9504C               ********************************************
9505C               **  TREAT THE MAXIMUM RECORD LENGTH CASE  **
9506C               ********************************************
9507C
9508      IF(ICOM.EQ.'MAXI'.AND.IHARG(1).EQ.'RECO'.AND.IHARG(2).EQ.'LENG')
9509     1  THEN
9510        CALL DPMXRL(IHARG,IARGT,IARG,NUMARG,IDEFRL,NUMRCM,MAXRCL,
9511     1              IFOUND,IERROR)
9512        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
9513      ENDIF
9514C
9515C               ******************************
9516C               **  TREAT THE DEGREES CASE  **
9517C               ******************************
9518C
9519C     (THE FOLLOWING IS COMMENTED OUT
9520C     (THE FOLLOWING IS COMMENTED OUT
9521C     (THE FOLLOWING IS COMMENTED OUT
9522C     IN THE SUBROUTINE MAINDG)
9523C
9524CCCCC IF(ICOM.EQ.'DEGR'.AND.ICOM2.EQ.'EES ')GOTO700
9525CCCCC GOTO799
9526C
9527CC700 CONTINUE
9528CCCCC CALL DPDEGS(IHARG,NUMARG,IDEFAU,
9529CCCCC1IANGLU,IFOUND,IERROR)
9530CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
9531C
9532CC799 CONTINUE
9533C
9534C               *****************************
9535C               **  TREAT THE DELETE CASE  **
9536C               *****************************
9537C
9538      IF(ICOM.EQ.'DELE')THEN
9539CCCCC   THE FOLLOWING LINE WAS FIXED     SEPTEMBER 1995
9540CCCCC   CALL DPDELE(IBUGS2,IBUGQ,IFOUND,IERROR)
9541        CALL DPDELE(IBUGS2,IBUGQ,ISUBRO,IFOUND,IERROR)
9542        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
9543      ENDIF
9544C
9545C               *********************************************
9546C               **  TREAT THE DEMODULATION FREQUENCY CASE  **
9547C               *********************************************
9548C
9549      IF(ICOM.EQ.'DEMO')THEN
9550        CALL DPDEFR(IHARG,IARGT,ARG,NUMARG,DEFDMF,
9551     1              DEMOFR,IFOUND,IERROR)
9552        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
9553      ENDIF
9554C
9555C               **********************************
9556C               **  TREAT THE DIMENSION CASE    **
9557C               **  TREAT THE REDIMENSION CASE  **
9558C               **********************************
9559C
9560      IF(ICOM.EQ.'DIME' .OR. ICOM.EQ.'REDI' .OR.
9561     1  (ICOM.EQ.'MATR' .AND. IHARG(1).EQ.'DIME'))THEN
9562        CALL DPDIME(IANS,IHARG,IARGT,IARG,NUMARG,IDEMXN,IDEMXC,
9563     1              IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP,
9564     1              IVALUE,VALUE,NUMNAM,MAXNAM,
9565     1              V,MAXNK,NUMN,MAXN,MAXNXT,
9566CCCCC               JANUARY 1998.  ADD FOLLOWING LINE
9567     1              MAXTOM,MAXROM,MAXCOM,MAXOBV,
9568     1              NUMCOL,MAXCOL,IFOUND,IERROR,IBUGS2)
9569        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
9570      ENDIF
9571C
9572C               ***************************************
9573C               **  TREAT THE DOUBLE PRECISION CASE  **
9574C               ***************************************
9575C
9576      IF(ICOM.EQ.'DOUB')THEN
9577CCCCC   CHECK FOR CONFLICT WITH DOUBLY NON-CENTRAL F PROB PLOT.
9578CCCCC   SEPTEMBER 1994
9579CCCCC   CHECK FOR CONFLICT WITH DOUBLE EXPONENTIAL PROB PLOT.
9580CCCCC   OCTOBER 1995
9581        IF(NUMARG.GE.2.AND.IHARG(1).EQ.'NONC')GOTO9000
9582        IF(NUMARG.GE.2.AND.IHARG(1).EQ.'NON-')GOTO9000
9583        IF(NUMARG.GE.1.AND.IHARG(1).EQ.'WEIB')GOTO9000
9584        IF(NUMARG.GE.1.AND.IHARG(1).EQ.'EXPO')GOTO9000
9585        IF(NUMARG.GE.1.AND.IHARG(1).EQ.'GAMM')GOTO9000
9586        IF(NUMARG.GE.1.AND.IHARG(1).EQ.'SAMP')GOTO9000
9587        IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PARE')GOTO9000
9588        CALL DPDOUB(IHARG,NUMARG,IDEFPR,IHMXPR,
9589     1              IPREC,IFOUND,IERROR)
9590        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
9591      ENDIF
9592C
9593C               ***************************
9594C               **  TREAT THE ECHO CASE  **
9595C               ***************************
9596C
9597      IF(ICOM.EQ.'ECHO')THEN
9598        CALL DPECSW(IHARG,NUMARG,
9599     1              IECHO,IFOUND,IERROR)
9600        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
9601      ENDIF
9602C
9603C               ****************************
9604C               **  TREAT THE EXIT  CASE  **
9605C               **  TREAT THE END   CASE  **
9606C               **  TREAT THE HALT  CASE  **
9607C               **  TREAT THE STOP  CASE  **
9608C               ****************************
9609C
9610      IF((ICOM.EQ.'END ' .AND. NUMARG.LE.0) .OR.
9611     1  ICOM.EQ.'EXIT' .OR.
9612     1  ICOM.EQ.'HALT' .OR. ICOM.EQ.'STOP' .OR.
9613     1  ICOM.EQ.'BYE ' .OR. ICOM.EQ.'QUIT')THEN
9614        CALL DPEXIT(ICAPSW,IBUGS2,ISUBRO,IFOUND,IERROR)
9615        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
9616      ENDIF
9617C
9618C               **********************************
9619C               **  TREAT THE ERASE DELAY CASE  **
9620C               **********************************
9621C
9622      IF(ICOM.EQ.'ERAS')THEN
9623        CALL DPERDE(IHARG,IARGT,ARG,NUMARG,DEFERD,
9624     1              ERASDE,IFOUND,IERROR)
9625         IF(IFOUND.EQ.'YES'.AND.IERROR.EQ.'NO')AGERDE=ERASDE
9626         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
9627      ENDIF
9628C
9629C               **************************************
9630C               **  TREAT THE FIT CONSTRAINT  CASE  **
9631C               **************************************
9632C
9633      IF(ICOM.EQ.'FIT'.AND.NUMARG.GE.1.AND.
9634     1   IHARG(1).EQ.'CONS')THEN
9635        CALL DPFICN(ICOM,IHARG,IHARG2,IARGT,ARG,NUMARG,
9636     1              IPARNC,IPANC2,IPAROP,
9637     1              PARLIM,PARLLM,PARULM,
9638     1              NUMCON,MAXCON,IFOUND,IERROR,IBUGS2)
9639        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
9640      ENDIF
9641C
9642C               *************************************
9643C               **  TREAT THE FIT ITERATIONS CASE  **
9644C               *************************************
9645C
9646      IF(ICOM.EQ.'FIT'.AND.NUMARG.GE.1.AND.
9647     1   IHARG(1).EQ.'ITER')THEN
9648        CALL DPFIIT(IHARG,IARGT,IARG,NUMARG,IDEFNI,
9649     1              IFITIT,IFOUND,IERROR)
9650        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
9651      ENDIF
9652C
9653C               ********************************
9654C               **  TREAT THE FIT POWER CASE  **
9655C               ********************************
9656C
9657      IF(ICOM.EQ.'FIT'.AND.NUMARG.GE.1.AND.
9658     1   IHARG(1).EQ.'POWE')THEN
9659        CALL DPFIPW(IHARG,IARGT,ARG,NUMARG,DEFFPW,
9660     1              FITPOW,IFOUND,IERROR)
9661        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
9662      ENDIF
9663C
9664C               *********************************************
9665C               **  TREAT THE FIT STANDARD DEVIATION CASE  **
9666C               *********************************************
9667C
9668      IF(ICOM.EQ.'FIT'.AND.NUMARG.GE.1.AND.
9669     1   IHARG(1).EQ.'STAN')THEN
9670        CALL DPFISD(IHARG,IARGT,ARG,NUMARG,DEFFSD,
9671     1              FITSD,IFOUND,IERROR)
9672        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
9673      ENDIF
9674C
9675C               ****************************
9676C               **  TREAT THE GRADS CASE  **
9677C               ****************************
9678C
9679C     (THE FOLLOWING IS COMMENTED OUT
9680C     BECAUSE THE ANGLE COMMAND IS NOW DONE
9681C     IN THE SUBROUTINE MAINDG)
9682C
9683CCCCC IF(ICOM.EQ.'GRAD')GOTO2100
9684CCCCC GOTO2199
9685C
9686C2100 CONTINUE
9687CCCCC CALL DPGRAD(IHARG,NUMARG,IDEFAU,
9688CCCCC1IANGLU,IFOUND,IERROR)
9689CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
9690C
9691C2199 CONTINUE
9692C
9693C               **************************************
9694C               **  TREAT THE HARDCOPY DELAY CASE   **
9695C               **************************************
9696C
9697      IF(ICOM.EQ.'HARD')THEN
9698        CALL DPHADE(IHARG,IARGT,ARG,NUMARG,DEFHAD,
9699     1              HARDDE,IFOUND,IERROR)
9700        IF(IFOUND.EQ.'YES'.AND.IERROR.EQ.'NO')AGCODE=HARDDE
9701        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
9702      ENDIF
9703C
9704C               ***************************
9705C               **  TREAT THE HELP CASE  **
9706C               ***************************
9707C
9708      IF(ICOM.EQ.'HELP')THEN
9709C
9710CCCCC THE FOLLOWING CALL WAS CHANGED JULY 1990
9711CCCCC CALL DPHELP(IHARG,IHARG2,NUMARG,IANS,IWIDTH,
9712CCCCC1IHELMX,
9713CCCCC1ICPREH,NCPREH,ICPOSH,NCPOSH,
9714CCCCC1IBUGS2,ISUBRO,IFOUND,IERROR)
9715C
9716CCCCC THE FOLLOWING CALL WAS INSERTED JULY 1990
9717CCCCC AND THEN COMMENTED OUT NOVEMBER 1991
9718CCCCC CALL DPHELP(IHARG,IHARG2,NUMARG,IANS,IWIDTH,
9719CCCCC1IHE1CO,IHE1AL,
9720CCCCC1IHE2CO,IHE2AL,
9721CCCCC1IHE3CO,IHE3AL,
9722CCCCC1IHE4CO,IHE4AL,
9723CCCCC1IHE5CO,IHE5AL,
9724CCCCC1IHE6CO,IHE6AL,
9725CCCCC1IHE7CO,IHE7AL,
9726CCCCC1IHE8CO,IHE8AL,
9727CCCCC1IHE9CO,IHE9AL,
9728CCCCC1IHELMX,
9729CCCCC1ICPREH,NCPREH,ICPOSH,NCPOSH,
9730CCCCC1IBUGS2,ISUBRO,IFOUND,IERROR)
9731C
9732CCCCC THE FOLLOWING CALL WAS CHANGED BACK NOVEMBER 1991
9733        CALL DPHELP(IHARG,IHARG2,NUMARG,IANS,IWIDTH,
9734     1              IHELMX,
9735     1              ICPREH,NCPREH,ICPOSH,NCPOSH,
9736     1              IBUGS2,ISUBRO,IFOUND,IERROR)
9737        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
9738      ENDIF
9739C
9740C               ***************************
9741C               **  TREAT THE HOST CASE  **
9742C               ***************************
9743C
9744      IF(ICOM.EQ.'HOST'.AND.IHARG(1).NE.'LINK')THEN
9745        CALL DPHOST(IHARG,NUMARG,IDEFHO,
9746     1              IHOST,IHOST1,IHOST2,IFOUND,IERROR)
9747        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
9748      ENDIF
9749C
9750C               ********************************
9751C               **  TREAT THE HOST LINK CASE  **
9752C               ********************************
9753C
9754      IF(ICOM.EQ.'HOST'.AND.NUMARG.GE.1.AND.
9755     1IHARG(1).EQ.'LINK')GOTO2500
9756      IF(ICOM.EQ.'COMM'.AND.NUMARG.GE.1.AND.
9757     1IHARG(1).EQ.'LINK')GOTO2500
9758      IF(ICOM.EQ.'LINK')GOTO2500
9759      GOTO2599
9760C
9761 2500 CONTINUE
9762      IF(IHARG(1).EQ.'LINK')THEN
9763        ISHIFT=1
9764        CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
9765     1              IBUGS2,IERROR)
9766        IHARG(1)='LINK'
9767        IHARG2(1)='    '
9768      ENDIF
9769      CALL DPHOSL(IHARG,NUMARG,IDEFHL,
9770     1IHOSLI,IFOUND,IERROR)
9771      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
9772C
9773 2599 CONTINUE
9774C
9775C               ****************************
9776C               **  TREAT THE KNOTS CASE  **
9777C               ****************************
9778C
9779      IF(ICOM.EQ.'KNOT')THEN
9780        CALL DPKNOT(IHARG,IHARG2,NUMARG,IDEFK1,IDEFK2,
9781     1              IKNOT1,IKNOT2,IFOUND,IERROR)
9782        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
9783      ENDIF
9784C
9785C               ************************************
9786C               **  TREAT THE MACRO CASE          **
9787C               **  TREAT THE END MACRO CASE      **
9788C               **  TREAT THE END OF MACRO CASE   **
9789C               **  TREAT THE CREATE CASE         **
9790C               **  TREAT THE END CREATE CASE     **
9791C               **  TREAT THE END OF CREATE CASE  **
9792C               ************************************
9793C
9794      IF(ICOM.EQ.'MACR' .OR. ICOM.EQ.'CREA')GOTO2700
9795      IF(ICOM.EQ.'END ' .AND. NUMARG.GE.1 .AND.
9796     1  (IHARG(1).EQ.'MACR' .OR. IHARG(1).EQ.'CREA'))GOTO2700
9797      IF(ICOM.EQ.'END ' .AND. NUMARG.GE.2 .AND. IHARG(1).EQ.'OF  ' .AND.
9798     1  (IHARG(2).EQ.'MACR' .OR. IHARG(2).EQ.'CREA'))GOTO2700
9799      GOTO2799
9800C
9801 2700 CONTINUE
9802      CALL DPMACR(ICOM,ICOM2,
9803CCCCC             THE FOLOWING LINE WAS AUGMENTED   AUGUST 1994
9804CCCCC1            IMACRO,IMACNU,IMACCS,
9805     1            IMACRO,IMACNU,IMACCS,IMACL1,IMACL2,IMACLR,IMALEV,
9806     1            IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,MAXNAM,
9807     1            IANSLC,IWIDTH,
9808     1            IHARG,IHARG2,IARGT,IARG,ARG,NUMARG,
9809     1            IOFILE,
9810     1            ILOOST,ILOOLI,NUMLIL,NUMLOS,
9811     1            IANSLO,IWIDLL,MAXCIL,MAXLIL,
9812     1            IBUGS2,ISUBRO,IFOUND,IERROR)
9813      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
9814C
9815 2799 CONTINUE
9816C
9817C               *******************************
9818C               **  TREAT THE OPERATOR CASE  **
9819C               **  TREAT THE CONSOLE  CASE  **
9820C               *******************************
9821C
9822      IF((ICOM.EQ.'CONS'.AND.ICOM2.EQ.'OLE ') .OR.
9823     1   ICOM.EQ.'OPER')THEN
9824        CALL DPOPMS(IANSLC,IWIDTH,IBUGS2,ISUBRO,IFOUND,IERROR)
9825        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
9826      ENDIF
9827C
9828C               ***************************
9829C               **  TREAT THE NAME CASE  **
9830C               ***************************
9831C
9832      IF(ICOM.EQ.'NAME' .OR. ICOM.EQ.'RENA')THEN
9833        CALL DPNAME(IHARG,IHARG2,IARGT,IARG,ARG,NUMARG,
9834     1              IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP,
9835     1              IVALUE,VALUE,NUMNAM,MAXNAM,
9836     1              IVARLB,
9837     1              NUMCOL,MAXCOL,MAXN,IANS,IWIDTH,
9838     1              IBUGS2,IFOUND,IERROR)
9839        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
9840      ENDIF
9841C
9842C               *************************************
9843C               **  TREAT THE VARIABLE LABEL CASE  **
9844C               **  NAME CONFLICTS WITH "VARIANCE" **
9845C               **  COMMANDS.                      **
9846C               *************************************
9847C
9848      IF(ICOM.EQ.'VARI'.AND.ICOM2.EQ.'ABLE')THEN
9849        CALL DPVLAB(IHARG,IHARG2,IARG,NUMARG,
9850     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,
9851     1              NUMNAM,MAXNAM,IVARLB,
9852     1              IANS,IANSLC,IWIDTH,IBUGS2,IFOUND,IERROR)
9853        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
9854      ENDIF
9855C
9856C               ****************************************
9857C               **  TREAT THE POLYNOMIAL DEGREE CASE  **
9858C               **  TREAT THE DEGREE CASE             **
9859C               ****************************************
9860C
9861      IF((ICOM.EQ.'DEGR'.AND.ICOM2.EQ.'EE  ') .OR.
9862     1   (ICOM.EQ.'POLY'.AND.IHARG(1).NE.'AEPP'))THEN
9863C
9864C       CHECK FOR NAME CONFLICTS
9865C
9866        IF(NUMARG.GE.2. AND. IHARG(1).EQ.'MLE')GOTO3199
9867        IF(NUMARG.GE.3. AND. IHARG(1).EQ.'MAXI' .AND.
9868     1     IHARG(2).EQ.'LIKE')GOTO3199
9869        IF(IHARG(1).EQ.'FIT' .OR. IHARG(2).EQ.'FIT' .OR.
9870     1     IHARG(3).EQ.'FIT')GOTO3199
9871C
9872        CALL DPDEGR(IHARG,IARGT,IARG,NUMARG,IDEFDG,IDEG,IFOUND,IERROR)
9873        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
9874      ENDIF
9875C
9876 3199 CONTINUE
9877C
9878C               ********************************
9879C               **  TREAT THE PRECISION CASE  **
9880C               ********************************
9881C
9882      IF(ICOM.EQ.'PREC' .AND. IHARG(1).NE.'PLOT')THEN
9883        CALL DPPREC(IHARG,NUMARG,IDEFPR,IHMXPR,
9884     1              IPREC,IFOUND,IERROR)
9885        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
9886      ENDIF
9887C
9888C               ********************************
9889C               **  TREAT THE PRE-ERASE CASE  **
9890C               ********************************
9891C
9892      IF(ICOM.EQ.'PRE')THEN
9893        CALL DPPREE(IHARG,NUMARG,
9894     1              IERASW,IFOUND,IERROR)
9895        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
9896      ENDIF
9897C
9898C               *******************************
9899C               **  TREAT THE PRINTING CASE  **
9900C               *******************************
9901C
9902      IF(ICOM.EQ.'PRIN'.AND.ICOM2.EQ.'TING')THEN
9903         CALL DPPRSW(IHARG,NUMARG,
9904     1               IPRIN2,IFOUND,IERROR)
9905        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
9906      ENDIF
9907C
9908C               ****************************
9909C               **  TREAT THE PROBE CASE  **
9910C               ****************************
9911C
9912      IF(ICOM.EQ.'PROB' .OR. ICOM.EQ.'DUMP')THEN
9913        CALL DPPROB(ILISMX,IREPCH,IOSW,
9914     1              IBUGUG,IBUGU2,IBUGU3,IBUGU4,ISUBRO,
9915     1              IBUGEX,IBUGE2,IBUGHE,IBUGH2,IBUGLO,
9916     1              IHELMX,IFTEXP,IFTORD,
9917     1              IFORSW,ICREAF,NCREAF,ICWRIF,NCWRIF,
9918     1              IREARW,IWRIRW,NPLOTP,IPRITY,
9919     1              IUNFOF,IUNFNR,IUNFMC,IMACRO,IMALEV,
9920     1              IANSLO,ILOOST,ILOOLI,
9921     1              NUMIF,ISEED,
9922     1              IFOUND,IERROR)
9923        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
9924      ENDIF
9925C
9926C               ******************************************
9927C               **  TREAT THE QUADRUPLE PRECISION CASE  **
9928C               ******************************************
9929C
9930      IF(ICOM.EQ.'QUAD'.AND.ICOM2.EQ.'RUPL')THEN
9931        CALL DPQUAD(IHARG,NUMARG,IDEFPR,IHMXPR,
9932     1              IPREC,IFOUND,IERROR)
9933        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
9934      ENDIF
9935C
9936C               ******************************
9937C               **  TREAT THE RADIANS CASE  **
9938C               ******************************
9939C
9940C     (THE FOLLOWING IS COMMENTED OUT
9941C     BECAUSE THE ANGLE COMMAND IS NOW DONE
9942C     IN THE SUBROUTINE MAINDG)
9943C
9944CCCCC IF(ICOM.EQ.'RADI')GOTO3700
9945CCCCC GOTO3799
9946C
9947C3700 CONTINUE
9948CCCCC CALL DPRADI(IHARG,NUMARG,IDEFAU,
9949CCCCC1IANGLU,IFOUND,IERROR)
9950CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
9951C
9952C3799 CONTINUE
9953C
9954C               ***************************
9955C               **  TREAT THE READ CASE  **
9956C               ***************************
9957C
9958      IF(ICOM.EQ.'READ')THEN
9959        INTINF=I1MACH(9)
9960        CALL DPREAD(IFROW1,IFROW2,IFCOL1,IFCOL2,ISKIP,INTINF,
9961     1              IMACRO,IMACNU,IMACCS,IMALEV,IOSW,ICREAF,NCREAF,
9962     1              IREARW,ICOMCH,ICOMSW,
9963     1              IUNFOF,IUNFNR,IUNFMC,NUMRCM,
9964     1              IFCOLL,IFCOLU,
9965     1              IANSLO,ILOOST,ILOOLI,IREPCH,
9966     1              IBUGS2,IBUGQ,ISUBRO,IFOUND,IERROR)
9967        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
9968      ENDIF
9969C
9970C               **********************************
9971C               **  TREAT THE STREAM READ CASE  **
9972C               **********************************
9973C
9974      IF(ICOM.EQ.'STRE' .AND. IHARG(1).EQ.'READ')THEN
9975        INTINF=I1MACH(9)
9976        CALL DPSTRE(IFROW1,IFROW2,IFCOL1,IFCOL2,ISKIP,INTINF,
9977     1              IMACRO,IMACNU,IMACCS,IMALEV,IOSW,ICREAF,NCREAF,
9978     1              ICWRIF,NCWRIF,IREARW,ICOMCH,ICOMSW,
9979     1              IUNFOF,IUNFNR,IUNFMC,NUMRCM,
9980     1              IFCOLL,IFCOLU,
9981     1              IANSLO,ILOOST,ILOOLI,IREPCH,
9982     1              IBUGS2,IBUGQ,ISUBRO,IFOUND,IERROR)
9983        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
9984      ENDIF
9985C
9986C               ****************************
9987C               **  TREAT THE RESET CASE  **
9988C               ****************************
9989C
9990      IF(ICOM.EQ.'CLEA' .AND. ICOM2.NE.'N   ' .AND.
9991     1   IHARG(1).NE.'CLIP')THEN
9992        ICOM='RESE'
9993        ICOM2='T   '
9994      ENDIF
9995C
9996      IF(ICOM.EQ.'RESE')THEN
9997        CALL DPRESE(IFOUND,IERROR)
9998        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
9999      ENDIF
10000C
10001C               ******************************
10002C               **  TREAT THE RESTORE CASE  **
10003C               ******************************
10004C
10005      IF(NUMARG.GE.1.AND.ICOM.EQ.'REST'.AND.
10006     1IHARG(1).EQ.'MEMO'.AND.IHARG2(1).EQ.'RY  ')GOTO4000
10007      IF(NUMARG.GE.1.AND.ICOM.EQ.'REST'.AND.
10008     1IHARG(1).EQ.'ALL '.AND.IHARG2(1).EQ.'    ')GOTO4000
10009      IF(ICOM.EQ.'REST')GOTO4000
10010      GOTO4099
10011C
10012 4000 CONTINUE
10013      CALL DPREST(IFOUND,IERROR)
10014      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10015C
10016 4099 CONTINUE
10017C
10018C               *****************************
10019C               **  TREAT THE RETAIN CASE  **
10020C               **  TREAT THE KEEP   CASE  **
10021C               **  TREAT THE PACK   CASE  **
10022C               *****************************
10023C
10024      IF(ICOM.EQ.'RETA' .OR. ICOM.EQ.'KEEP' .OR.
10025     1   ICOM.EQ.'PACK')THEN
10026        CALL DPRETA(IBUGS2,IBUGQ,IFOUND,IERROR)
10027        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10028      ENDIF
10029C
10030C               *********************************
10031C               **  TREAT THE ROW LIMITS CASE  **
10032C               *********************************
10033C
10034      IF(ICOM.EQ.'ROW')THEN
10035        CALL DPROWL(IHARG,IARGT,IARG,NUMARG,IDEFR1,IDEFR2,
10036     1              IFROW1,IFROW2,IFOUND,IERROR)
10037        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10038      ENDIF
10039C
10040C               ******************************************
10041C               **  TREAT THE TERMINATOR CHARACTOR CASE **
10042C               **  TREAT THE SEPARATOR CHARACTOR CASE  **
10043C               ******************************************
10044C
10045      IF((ICOM.EQ.'TERM'.AND.ICOM2.EQ.'INAT') .OR.
10046     1   (ICOM.EQ.'SEPA'.AND.ICOM2.EQ.'RATO'))THEN
10047        CALL DPTECH(IHARG,NUMARG,
10048     1              IDEFTC,ITERCH,
10049     1              IBUGS2,IFOUND,IERROR)
10050        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10051      ENDIF
10052C
10053C               ******************************************
10054C               **  TREAT THE CONTINUE   CHARACTOR CASE **
10055C               ******************************************
10056C
10057      IF(ICOM.EQ.'CONT' .AND. ICOM2.EQ.'INUE' .AND.
10058     1   IHARG(1).NE.'LOOP')THEN
10059        CALL DPCONC(IHARG,NUMARG,
10060     1              IDEFCC,
10061     1              ICONCH,
10062     1              IBUGS2,IFOUND,IERROR)
10063        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10064      ENDIF
10065C
10066CCCCC THE FOLLOWING SECTION WAS ADDED JUNE 1989
10067C               ********************************************
10068C               **  TREAT THE REPLACEMENT  CHARACTOR CASE **
10069C               **  TREAT THE SUBSTITUTION CHARACTOR CASE **
10070C               ********************************************
10071C
10072      IF((ICOM.EQ.'REPL'.AND.ICOM2.EQ.'ACEM') .OR.
10073     1   (ICOM.EQ.'SUBS'.AND.ICOM2.EQ.'TITU'))THEN
10074        CALL DPRECH(IHARG,NUMARG,
10075     1              IBASLC,IREPCH,
10076     1              IBUGS2,IFOUND,IERROR)
10077        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10078      ENDIF
10079C
10080CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 2005
10081C               **************************************************
10082C               **  TREAT THE MACRO SUBSTITUTION CHARACTOR CASE **
10083C               **************************************************
10084C
10085      IF(ICOM.EQ.'MACR'.AND.IHARG(1).EQ.'SUBS'.AND.
10086     1   IHARG(2).EQ.'CHAR')THEN
10087        CALL DPREMA(IHARG,NUMARG,
10088     1              IMACSC,IDEFMS,
10089     1              IBUGS2,ISUBRO,IFOUND,IERROR)
10090        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10091      ENDIF
10092C
10093C               **********************************
10094C               **  TREAT THE SERIAL READ CASE  **
10095C               **********************************
10096C
10097      IF(ICOM.EQ.'SERI')THEN
10098C
10099CCCCC   MAY, 1990.  ADD ICOMCH, ICOMSW TO CALL LIST
10100CCCCC   MARCH, 1996.  ADD IMALEV TO CALL LIST
10101        INTINF=I1MACH(9)
10102        CALL DPSERI(IFROW1,IFROW2,IFCOL1,IFCOL2,ISKIP,INTINF,
10103     1              IMACRO,IMACNU,IMACCS,IOSW,IMALEV,
10104     1              IREARW,ICOMCH,ICOMSW,
10105CCCCC FEBRAURY 2003.  ADD FOLLOWING LINE
10106     1              NUMRCM,
10107     1              IFCOLL,IFCOLU,
10108     1              IANSLO,ILOOST,ILOOLI,IREPCH,
10109     1              IBUGS2,IBUGQ,ISUBRO,IFOUND,IERROR)
10110        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10111      ENDIF
10112C
10113C               ***************************************
10114C               **  TREAT THE SINGLE PRECISION CASE  **
10115C               ***************************************
10116C
10117      IF(ICOM.EQ.'SING' .AND. IHARG(1).NE.'SAMP')THEN
10118        CALL DPSING(IHARG,NUMARG,IDEFPR,IHMXPR,
10119     1              IPREC,IFOUND,IERROR)
10120        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10121      ENDIF
10122C
10123C               ***************************
10124C               **  TREAT THE SKIP CASE  **
10125C               ***************************
10126C
10127      IF(ICOM.EQ.'SKIP')THEN
10128        CALL DPSKIP(IHARG,IARGT,IARG,NUMARG,IDEFSK,
10129     1              ISKIP,IFOUND,IERROR)
10130        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10131      ENDIF
10132C
10133C               *****************************
10134C               **  TREAT THE STATUS CASE  **
10135C               *****************************
10136C
10137CCCCC NOVEMBER 1997.  GUI STATUS (DON'T STORE IN SAVED COMMAND
10138CCCCC LIST)
10139CCCCC SEPTEMBER 2010. MAKE LS A SYNONYM FOR STATUS
10140C
10141      IFEESV=IFEEDB
10142      IF(ICOM.EQ.'GUI ' .AND.
10143     1  (IHARG(1).EQ.'STAT' .OR. IHARG(1).EQ.'LS  '))THEN
10144        IF(NUMARG.GE.1.AND.
10145     1     (IHARG(1).EQ.'STAT' .OR. IHARG(1).EQ.'LS  '))THEN
10146             ISHIFT=1
10147             CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
10148     1                   IBUGA2,IERROR)
10149             ICOM='STAT'
10150             ICOM2='US  '
10151             IFEEDB=IGUIFB
10152        ENDIF
10153      ENDIF
10154      IF(ICOM.EQ.'STAT' .OR. ICOM.EQ.'LS  ')THEN
10155        CALL DPSTAT(ISUBRO,IFOUND,IERROR)
10156        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10157      ENDIF
10158C
10159      IFEEDB=IFEESV
10160C
10161C               ****************************
10162C               **  TREAT THE TIME  CASE  **
10163C               **  TREAT THE CLOCK CASE  **
10164C               ****************************
10165C
10166      IF(ICOM.EQ.'TIME' .OR. ICOM.EQ.'CLOC' .OR.
10167     1   ICOM.EQ.'DATE')THEN
10168        CALL DPTIME(CURRTI,NCURRT,CURRDA,NCURRD,
10169     1              IBUGS2,ISUBRO,IFOUND,IERROR)
10170        IF(IFOUND.EQ.'YES'.AND.IERROR.EQ.'NO')THEN
10171           DO5110I=1,NCURRT
10172              IC4(1:4)='    '
10173              IC4(1:1)=CURRTI(I:I)
10174              IFUTMP(I)=IC4(1:4)
101755110       CONTINUE
10176           CALL UPDATF('CURR','TIME',IFUTMP,NCURRT,'CHAD','NO  ',
10177     1                 IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP,
10178     1                 NUMNAM,MAXNAM,IANS,IWIDTH,ILISTL,NEWNAM,MAXNAM,
10179     1                 IFUNC,NUMCHF,MAXCHF,IBUGS2,ILOCN,IFOUNN,IERRON)
10180           DO5120I=1,NCURRD
10181              IC4(1:4)='    '
10182              IC4(1:1)=CURRDA(I:I)
10183              IFUTMP(I)=IC4(1:4)
101845120       CONTINUE
10185           CALL UPDATF('CURR','DATE',IFUTMP,NCURRD,'CHAD','NO  ',
10186     1                 IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP,
10187     1                 NUMNAM,MAXNAM,IANS,IWIDTH,ILISTL,NEWNAM,MAXNAM,
10188     1                 IFUNC,NUMCHF,MAXCHF,IBUGS2,ILOCN,IFOUNN,IERRON)
10189        ENDIF
10190        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10191      ENDIF
10192C
10193C               ********************************
10194C               **  TREAT THE CPU TIME  CASE  **
10195C               ********************************
10196C
10197      IF(ICOM.EQ.'CPU ')THEN
10198        CALL DPCPU(ICOM,IHARG,IHARG2,IARGT,IARG,ARG,NUMARG,
10199     1             ATIME,
10200     1             IBUGS2,ISUBRO,IFOUND,IERROR)
10201        IF(IFOUND.EQ.'YES'.AND.IERROR.EQ.'NO')THEN
10202          IH='CPUT'
10203          IH2='IME '
10204          VALUE0=ATIME
10205          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
10206     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
10207     1                IANS,IWIDTH,IBUGS2,IERROR)
10208        ENDIF
10209        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10210      ENDIF
10211C
10212C               **********************************
10213C               **  TREAT THE PROCESS-ID  CASE  **
10214C               **********************************
10215C
10216      IFOUND='NO'
10217      IF(ICOM.EQ.'PID ' .OR.
10218     1   (ICOM.EQ.'PROC' .AND. IHARG(1).EQ.'ID'))THEN
10219        CALL DPPID(IPID,IBUGS2,ISUBRO,IFOUND,IERROR)
10220
10221        IF(IFOUND.EQ.'YES'.AND.IERROR.EQ.'NO'.AND.IPID.GT.0)THEN
10222          IH='PID '
10223          IH2='    '
10224          VALUE0=REAL(IPID)
10225          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
10226     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
10227     1                IANS,IWIDTH,IBUGS2,IERROR)
10228        ENDIF
10229      ENDIF
10230      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10231C
10232C               ********************************
10233C               **  TREAT THE PWD       CASE  **
10234C               ********************************
10235C
10236      IF(ICOM.EQ.'PWD ' .OR.
10237     1  (ICOM.EQ.'GETC' .AND. ICOM2.EQ.'WD  ') .OR.
10238     1  (ICOM.EQ.'CURR' .AND. IHARG(1).EQ.'DIRE'))THEN
10239        MAXTMP=255
10240        CALL DPPWD(CURDIR,MAXTMP,ICNT,IBUGS2,ISUBRO,IFOUND,IERROR)
10241        IF(IFOUND.EQ.'YES'.AND.IERROR.EQ.'NO')THEN
10242          IH='CURD'
10243          IH2='IR  '
10244          NEWNAM='YES'
10245          DO5130I=1,NUMNAM
10246            I2=I
10247            IF(IH.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I))THEN
10248              IF(IUSE(I2).EQ.'F')THEN
10249                NEWNAM='NO'
10250                GOTO5139
10251              ELSE
10252                NEWNAM='NULL'
10253              ENDIF
10254            ENDIF
10255 5130     CONTINUE
10256 5139     CONTINUE
10257C
10258          IF(NEWNAM.NE.'NULL')THEN
10259            ILISTL=NUMNAM+1
10260            DO5140I=1,ICNT
10261              IFUNC9(I)=' '
10262              IFUNC9(I)(1:1)=CURDIR(I:I)
10263 5140       CONTINUE
10264            CALL DPINFU(IFUNC9,ICNT,IHNAME,IHNAM2,IUSE,IN,
10265     1                  IVSTAR,IVSTOP,
10266     1                  NUMNAM,IANS,IWIDTH,IH,IH2,ILISTL,
10267     1                  NEWNAM,MAXNAM,
10268     1                  IFUNC,NUMCHF,MAXCHF,IBUGA3,IERROR)
10269          ENDIF
10270        ENDIF
10271        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10272      ENDIF
10273C
10274C               ***************************************
10275C               **  TREAT THE CLIPBOARD CLEAR  CASE  **
10276C               ***************************************
10277C
10278      IFOUND='NO'
10279      IF((ICOM.EQ.'CLIP' .AND. IHARG(1).EQ.'CLEA') .OR.
10280     1   (ICOM.EQ.'CLEA' .AND. IHARG(1).EQ.'CLIP'))THEN
10281        CALL DPCLI3(IBUGS2,ISUBRO,IERROR)
10282        IFOUND='YES'
10283        GOTO9000
10284      ENDIF
10285C
10286C               ***************************************
10287C               **  TREAT THE CLIPBOARD LOOP   CASE  **
10288C               ***************************************
10289C
10290      IFOUND='NO'
10291      IF((ICOM.EQ.'CLIP' .AND. IHARG(1).EQ.'LOOP') .OR.
10292     1   (ICOM.EQ.'LOOP' .AND. IHARG(1).EQ.'CLIP'))THEN
10293        IF(NUMARG.EQ.1)THEN
10294          ICLILO='ON'
10295          ICLIL2=0
10296          IFOUND='YES'
10297          GOTO9000
10298        ENDIF
10299      ENDIF
10300C
10301C               ***************************************
10302C               **  TREAT THE CLIPBOARD LOOP END CASE**
10303C               ***************************************
10304C
10305      IFOUND='NO'
10306      IF((ICOM.EQ.'CLIP' .AND. IHARG(1).EQ.'LOOP' .AND.
10307     1    IHARG(2).EQ.'END') .OR.
10308     1   (ICOM.EQ.'CLIP' .AND. IHARG(1).EQ.'END ' .AND.
10309     1    IHARG(2).EQ.'LOOP') .OR.
10310     1   (ICOM.EQ.'CLIP' .AND. IHARG(1).EQ.'END ' .AND.
10311     1    IHARG(2).EQ.'OF  ' .AND. IHARG(3).EQ.'LOOP'))THEN
10312        ICLILO='OFF'
10313        ICLIL2=0
10314        ICLIFL='OFF'
10315        ICLILN=0
10316        IFOUND='YES'
10317        CALL DPCLI3(IBUGS2,ISUBRO,IERROR)
10318        IF(IFEEDB.EQ.'ON')THEN
10319          WRITE(ICOUT,5150)
10320          CALL DPWRST('XXX','BUG ')
10321        ENDIF
10322        GOTO9000
10323      ENDIF
10324C
10325C               ***************************************
10326C               **  TREAT THE CLIPBOARD PAUSE  CASE  **
10327C               ***************************************
10328C
10329      IFOUND='NO'
10330      IF((ICOM.EQ.'CLIP' .AND. IHARG(1).EQ.'PAUS') .OR.
10331     1   (ICOM.EQ.'PAUS' .AND. IHARG(1).EQ.'CLIP'))THEN
10332        ICLIFL='PAUS'
10333        IF(ICLILO.EQ.'ON')ICLILO='PAUS'
10334        IFOUND='YES'
10335        IF(IFEEDB.EQ.'ON')THEN
10336          WRITE(ICOUT,5150)
10337 5150     FORMAT('COMMANDS WILL NOW BE ENTERED FROM KEYBOARD')
10338          CALL DPWRST('XXX','BUG ')
10339        ENDIF
10340        GOTO9000
10341      ENDIF
10342C
10343C               ***************************************
10344C               **  TREAT THE CLIPBOARD RESUME CASE  **
10345C               ***************************************
10346C
10347      IFOUND='NO'
10348      IF((ICOM.EQ.'CLIP' .AND. IHARG(1).EQ.'RESU') .OR.
10349     1   (ICOM.EQ.'RESU' .AND. IHARG(1).EQ.'CLIP'))THEN
10350        ICLIFL='ON'
10351        IF(ICLILO.EQ.'PAUS')ICLILO='ON'
10352        IFOUND='YES'
10353        GOTO9000
10354      ENDIF
10355C
10356C               ***************************************
10357C               **  TREAT THE CLIPBOARD RUN    CASE  **
10358C               ***************************************
10359C
10360      IFOUND='NO'
10361      IF((ICOM.EQ.'CLIP' .AND. IHARG(1).EQ.'RUN ') .OR.
10362     1   (ICOM.EQ.'RUN ' .AND. IHARG(1).EQ.'CLIP') .OR.
10363     1     (ICOM.EQ.'CALL' .AND. IHARG(1).EQ.'CLIP') .OR.
10364     1      ICOM.EQ.'CB' .OR.
10365     1   (NUMARG.EQ.0 .AND. ICOM.EQ.'CLIP'))THEN
10366        ICLIFL='ON'
10367        ICLILN=0
10368        IFOUND='YES'
10369        GOTO9000
10370      ENDIF
10371C
10372C               ***************************************
10373C               **  TREAT THE TRIPLE PRECISION CASE  **
10374C               ***************************************
10375C
10376      IF(ICOM.EQ.'TRIP')THEN
10377        CALL DPTRIP(IHARG,NUMARG,IDEFPR,IHMXPR,
10378     1              IPREC,IFOUND,IERROR)
10379        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10380      ENDIF
10381C
10382C               ******************************
10383C               **  TREAT THE WEIGHTS CASE  **
10384C               ******************************
10385C
10386      IF(ICOM.EQ.'WEIG')THEN
10387        CALL DPWEIG(IHARG,IHARG2,NUMARG,IDEFW1,IDEFW2,
10388     1              IWEIG1,IWEIG2,IWEIGH,IFOUND,IERROR)
10389        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10390      ENDIF
10391C
10392C               ************************************************
10393C               **  TREAT THE ORTHOGONAL DISTANCE ERROR CASE  **
10394C               ************************************************
10395C
10396      IF(ICOM.EQ.'ORTH')THEN
10397        IF(NUMARG.GE.2.AND.IHARG(1).EQ.'DIST'.AND.IHARG(2).EQ.'ERRO')
10398     1    THEN
10399          ISHIFT=2
10400          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
10401     1                IBUGA2,IERROR)
10402          CALL DPORER(IHARG,IHARG2,NUMARG,
10403     1                IODRE1,IODRE2,IFOUND,IERROR)
10404          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10405        ENDIF
10406      ENDIF
10407C
10408C               ************************************************
10409C               **  TREAT THE ORTHOGONAL DISTANCE DELTA CASE  **
10410C               ************************************************
10411C
10412      IF(ICOM.EQ.'ORTH')THEN
10413        IF(NUMARG.GE.2.AND.IHARG(1).EQ.'DIST'.AND.IHARG(2).EQ.'DELT')
10414     1    THEN
10415          ICASOD='DELT'
10416          ISHIFT=2
10417          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
10418     1                IBUGA2,IERROR)
10419          CALL DPORDE(IHARG,IHARG2,NUMARG,
10420     1                IODRD1,IODRD2,IODRD3,IODRD4,
10421     1                IWEIN1,IWEIN2,
10422     1                ICASOD,IFOUND,IERROR)
10423          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10424        ENDIF
10425      ENDIF
10426C
10427      IF(ICOM.EQ.'ORTH')THEN
10428        IF(NUMARG.GE.2.AND.IHARG(1).EQ.'DIST'.AND.IHARG(2).EQ.'Y   ')
10429     1    THEN
10430          ICASOD='Y   '
10431          ISHIFT=2
10432          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
10433     1                IBUGA2,IERROR)
10434          CALL DPORDE(IHARG,IHARG2,NUMARG,
10435     1                IODRD1,IODRD2,IODRD3,IODRD4,
10436     1                IWEIN1,IWEIN2,
10437     1                ICASOD,IFOUND,IERROR)
10438          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10439        ENDIF
10440      ENDIF
10441C
10442C               **************************************
10443C               **  TREAT THE CLASS ... LOWER CASE  **
10444C               **  TREAT THE CLASS ... UPPER CASE  **
10445C               **  TREAT THE CLASS ... WIDTH CASE  **
10446C               **************************************
10447C
10448      IF(ICOM.EQ.'CLAS')THEN
10449        CALL DPCLLO(IHARG,IARGT,ARG,NUMARG,
10450     1              CLLIMI,IFOUND,IERROR)
10451        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10452C
10453        CALL DPCLUP(IHARG,IARGT,ARG,NUMARG,
10454     1              CLLIMI,IFOUND,IERROR)
10455        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10456C
10457        CALL DPCLWI(IHARG,IARGT,ARG,NUMARG,
10458     1              CLWIDT,IFOUND,IERROR)
10459        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10460      ENDIF
10461C
10462C               ****************************
10463C               **  TREAT THE WRITE CASE  **
10464C               **  TREAT THE PRINT CASE  **
10465C               ****************************
10466C
10467CCCCC NOVEMBER 1997.  GUI PRINT/WRITE (DON'T STORE IN SAVED COMMAND
10468CCCCC LIST)
10469      IFEESV=IFEEDB
10470      IF(ICOM.EQ.'GUI ')THEN
10471        IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PRIN'.OR.
10472     1     IHARG(1).EQ.'WRIT')THEN
10473             ISHIFT=1
10474             CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
10475     1                   IBUGA2,IERROR)
10476             ICOM='WRIT'
10477             ICOM2='E   '
10478             IFEEDB=IGUIFB
10479        ENDIF
10480      ENDIF
10481      IF(ICOM.EQ.'WRIT')GOTO5800
10482      IF(ICOM.EQ.'PRIN'.AND.ICOM2.EQ.'T   ')GOTO5800
10483      IF(ICOM.EQ.'PRIN'.AND.ICOM2.EQ.'T1  ')GOTO5800
10484      IF(ICOM.EQ.'PRIN'.AND.ICOM2.EQ.'T2  ')GOTO5800
10485      IF(ICOM.EQ.'PRIN'.AND.ICOM2.EQ.'T3  ')GOTO5800
10486      IF(ICOM.EQ.'HEAD'.AND.ICOM2.EQ.'    ')GOTO5800
10487      IF(ICOM.EQ.'TAIL'.AND.ICOM2.EQ.'    '.AND.
10488     1   IHARG(1).NE.'AREA')GOTO5800
10489      GOTO5899
10490C
10491 5800 CONTINUE
10492CCCCC IF(NUMARG.GE.1.AND.IHARG(1).EQ.'DECI'.AND.
10493CCCCC1IHARG2(1).EQ.'MALS')GOTO5899
10494CCCCC IF(NUMARG.GE.1.AND.IHARG(1).EQ.'DECI'.AND.
10495CCCCC1IHARG2(1).EQ.'MAL')GOTO5899
10496CCCCC IF(NUMARG.GE.1.AND.IHARG(1).EQ.'FORM'.AND.
10497CCCCC1IHARG2(1).EQ.'AT')GOTO5899
10498CCCCC IF(NUMARG.GE.1.AND.IHARG(1).EQ.'REWI'.AND.
10499CCCCC1IHARG2(1).EQ.'ND')GOTO5899
10500C
10501      CALL DPWRIT(IMACRO,IMACNU,IMACCS,
10502     1            IFORSW,ICWRIF,NCWRIF,
10503     1            IWRIRW,
10504     1            IFORWI,IFORWR,MAXNWI,
10505     1            IBUGS2,IBUGQ,ISUBRO,IFOUND,IERROR)
10506C
10507      IFEEDB=IFEESV
10508      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10509C
10510 5899 CONTINUE
10511C
10512C               ******************************
10513C               **  TREAT THE COMMENT CASE  **
10514C               **  TREAT THE    .    CASE  **
10515C               ******************************
10516C
10517C  MAY, 1990.  SOFT-CODE THE COMMENT CHARACTER.  ALSO, A COMMENT
10518C  CHARACTER AND A COMMENT CHECK COMMAND WERE ADDED.  ALWAYS TREAT
10519C  PERIOD AS COMMENT ON COMMAND LINE.
10520C
10521      IF(ICOM.EQ.'.' .OR. ICOM.EQ.ICOMCH .OR. ICOM.EQ.'COMM')THEN
10522        IF(ICOM.EQ.'COMM'.AND. IHARG(1).EQ.'CHAR')GOTO5999
10523        IF(ICOM.EQ.'COMM'.AND. IHARG(1).EQ.'CHEC')GOTO5999
10524        IF(ICOM.EQ.'COMM'.AND. IHARG(1).EQ.'COEF')GOTO5999
10525        IF(ICOM.EQ.'COMM'.AND. IHARG(2).EQ.'COEF')GOTO5999
10526        IF(ICOM.EQ.'COMM'.AND. IHARG(1).EQ.'WEIB' .AND.
10527     1    IHARG(2).EQ.'SHAP')GOTO5999
10528        CALL DPDOT(IFOUND,IERROR)
10529        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10530      ENDIF
10531C
10532 5999 CONTINUE
10533C
10534C               *******************************
10535C               **  TREAT THE FEEDBACK CASE  **
10536C               *******************************
10537C
10538      IF(ICOM.EQ.'FEED')THEN
10539        CALL DPFEED(IHARG,NUMARG,
10540     1              IFEED2,IFOUND,IERROR)
10541        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10542      ENDIF
10543C
10544C               ***********************************
10545C               **  TREAT THE FILTER WIDTH CASE  **
10546C               ***********************************
10547C
10548      IF(ICOM.EQ.'FILT')THEN
10549        CALL DPFIWI(IHARG,IARGT,ARG,NUMARG,DEFFW,
10550     1              FILWID,IFOUND,IERROR)
10551        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10552      ENDIF
10553C
10554C               **************************************
10555C               **  TREAT THE DEFAULT COMMAND CASE  **
10556C               **************************************
10557C
10558      IF(ICOM.EQ.'DEFA')THEN
10559        CALL DPDECO(IANS,IWIDTH,IHARG,NUMARG,
10560     1              IDEFCM,IWIDDC,IDEFC,IBUGS2,IFOUND,IERROR)
10561        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10562      ENDIF
10563C
10564C               ***************************
10565C               **  TREAT THE BUGS CASE  **
10566C               ***************************
10567C
10568      IF(ICOM.EQ.'BUGS' .OR. ICOM.EQ.'BUG ')THEN
10569        CALL DPBUGS(IBUGS2,ISUBRO,IFOUND,IERROR)
10570        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10571      ENDIF
10572C
10573C               ***************************
10574C               **  TREAT THE MAIL CASE  **
10575C               ***************************
10576C
10577CCCCC IF(ICOM.EQ.'MAIL')GOTO6700
10578CCCCC GOTO6799
10579C
10580C6700 CONTINUE
10581CCCCC CALL DPMAIL(IANSLC,IWIDTH,IBUGS2,ISUBRO,IFOUND,IERROR)
10582CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10583C
10584C6799 CONTINUE
10585C
10586C               ***************************
10587C               **  TREAT THE NEWS CASE  **
10588C               ***************************
10589C
10590      IF(ICOM.EQ.'NEWS')THEN
10591        CALL DPNEWS(IBUGS2,ISUBRO,IFOUND,IERROR)
10592        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10593      ENDIF
10594C
10595C               ****************************
10596C               **  TREAT THE QUERY CASE  **
10597C               ****************************
10598C
10599CCCCC IF(ICOM.EQ.'QUER')GOTO6900
10600CCCCC IF(ICOM.EQ.'QUES')GOTO6900
10601CCCCC IF(ICOM.EQ.'MESS')GOTO6900
10602CCCCC GOTO6999
10603C
10604C6900 CONTINUE
10605CCCCC CALL DPQUER(IANSLC,IWIDTH,IBUGS2,ISUBRO,IFOUND,IERROR)
10606CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10607C
10608C6999 CONTINUE
10609C
10610C               ****************************
10611C               **  TREAT THE SET   CASE  **
10612C               ****************************
10613C
10614      IF(ICOM.EQ.'SET ')GOTO7110
10615C
10616CCCCC IF(ICOM.EQ.'READ')GOTO7105
10617CCCCC IF(ICOM.EQ.'WRIT')GOTO7105
10618CCCCC IF(ICOM.EQ.'PRIN'.AND.ICOM2.EQ.'T   ')GOTO7105
10619CCCCC GOTO7199
10620C
10621C7105 CONTINUE
10622CCCCC IF(NUMARG.GE.1.AND.IHARG(1).EQ.'DECI'.AND.
10623CCCCC1IHARG2(1).EQ.'MALS')GOTO7110
10624CCCCC IF(NUMARG.GE.1.AND.IHARG(1).EQ.'DECI'.AND.
10625CCCCC1IHARG2(1).EQ.'MAL')GOTO7110
10626CCCCC IF(NUMARG.GE.1.AND.IHARG(1).EQ.'FORM'.AND.
10627CCCCC1IHARG2(1).EQ.'AT')GOTO7110
10628CCCCC IF(NUMARG.GE.1.AND.IHARG(1).EQ.'REWI'.AND.
10629CCCCC1IHARG2(1).EQ.'ND')GOTO7110
10630      GOTO7199
10631C
10632 7110 CONTINUE
10633      CALL DPSET(ILISMX,IREPCH,IOSW,
10634     1IPPDE1,IPPDE2,
10635     1IBUGUG,IBUGU2,IBUGU3,IBUGU4,ISUBRO,
10636     1IBUGEX,IBUGE2,IBUGHE,IBUGH2,IBUGLO,
10637CCCCC AUGUST 1995.  ADD IFTORD
10638CCCCC1IHELMX,IFTEXP,
10639     1IHELMX,IFTEXP,IFTORD,
10640     1IFORSW,ICREAF,NCREAF,ICWRIF,NCWRIF,
10641     1IREARW,IWRIRW,
10642CCCCC THE FOLLOWING LINE WAS ADDED   APRIL 1992
10643     1NPLOTP,
10644CCCCC THE FOLLOWING LINE WAS ADDED   FEBRUARY 1993
10645     1IPRITY,
10646CCCCC THE FOLLOWING LINE WAS ADDED   APRIL 1995
10647     1IUNFOF,IUNFNR,IUNFMC,
10648CCCCC FOLLOWING LINE ADD MARCH 1996
10649CCCCC1IRHSTG,
10650     1IFOUND,IERROR)
10651      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10652C
10653 7199 CONTINUE
10654C
10655C               ********************************
10656C               **  TREAT THE IMPLEMENT CASE  **
10657C               ********************************
10658C
10659      IF(ICOM.EQ.'IMPL')THEN
10660        CALL DPIMPL(IHARG,IARGT,IARG,NUMARG,
10661     1              IX2TSW,IY2TSW,IX2ZSW,IY2ZSW,NCY2LA,
10662     1              ISQUAR,
10663     1              PXMIN,PYMIN,PXMAX,PYMAX,
10664     1              IBUGS2,IFOUND,IERROR)
10665        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10666      ENDIF
10667C
10668C               *****************************
10669C               **  TREAT THE REWIND CASE  **
10670C               *****************************
10671C
10672CCCCC IF(ICOM.EQ.'REWI')GOTO7300
10673CCCCC GOTO7399
10674CCCCC
10675C7300 CONTINUE
10676CCCCC CALL DPREWI(IBUGS2,IBUGQ,IFOUND,IERROR)
10677CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10678CCCCC
10679C7399 CONTINUE
10680C
10681C               ******************************
10682C               **  TREAT THE ENDFILE CASE  **
10683C               ******************************
10684C
10685CCCCC IF(ICOM.EQ.'ENDF')GOTO7400
10686CCCCC GOTO7499
10687CCCCC
10688C7400 CONTINUE
10689CCCCC CALL DPENDF(IBUGS2,IBUGQ,IFOUND,IERROR)
10690CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10691CCCCC
10692C7499 CONTINUE
10693C
10694C               *****************************
10695C               **  TREAT THE RELEASE CASE **
10696C               *****************************
10697C
10698CCCCC IF(ICOM.EQ.'RELE')GOTO7500
10699CCCCC IF(ICOM.EQ.'CLOS')GOTO7500
10700CCCCC IF(ICOM.EQ.'FREE')GOTO7500
10701CCCCC GOTO7599
10702CCCCC
10703C7500 CONTINUE
10704CCCCC CALL DPREWI(IBUGS2,IBUGQ,IFOUND,IERROR)
10705CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10706CCCCC
10707C7599 CONTINUE
10708C
10709C               ***************************
10710C               **  TREAT THE SEED CASE  **
10711C               ***************************
10712C
10713      IF(ICOM.EQ.'SEED')THEN
10714        CALL DPSEED(IHARG,IARGT,IARG,NUMARG,IDEFSE,
10715     1              ISEED,IFOUND,IERROR)
10716        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10717      ENDIF
10718C
10719C               **************************************
10720C               **  TREAT THE THE PROPORTION LIMITS   CASE  **
10721C               **  = THE ANOP LIMITS     CASE  **
10722C               **************************************
10723C
10724      IF(ICOM.EQ.'PROP'.AND.NUMARG.GE.1.AND.
10725     1IHARG(1).EQ.'LIMI'.AND.IHARG2(1).EQ.'TS  ')GOTO8100
10726      IF(ICOM.EQ.'PROP'.AND.NUMARG.GE.1.AND.
10727     1IHARG(1).EQ.'REGI'.AND.IHARG2(1).EQ.'ON  ')GOTO8100
10728      IF(ICOM.EQ.'ANOP'.AND.NUMARG.GE.1.AND.
10729     1IHARG(1).EQ.'LIMI'.AND.IHARG2(1).EQ.'TS  ')GOTO8100
10730      IF(ICOM.EQ.'ANOP'.AND.NUMARG.GE.1.AND.
10731     1IHARG(1).EQ.'REGI'.AND.IHARG2(1).EQ.'ON  ')GOTO8100
10732      GOTO8199
10733C
10734 8100 CONTINUE
10735      CALL DPANOL(IHARG,IARGT,ARG,NUMARG,DEFAL1,DEFAL2,
10736     1ANOPL1,ANOPL2,IFOUND,IERROR)
10737      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10738C
10739 8199 CONTINUE
10740C
10741C               ****************************
10742C               **  TREAT THE FENCE CASE  **
10743C               ****************************
10744C
10745      IF(ICOM.EQ.'FENC')THEN
10746        CALL DPFENC(IHARG,NUMARG,
10747     1              IFENSW,IFOUND,IERROR)
10748        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10749      ENDIF
10750C
10751C               ****************************
10752C               **  TREAT THE PAUSE CASE  **
10753C               ****************************
10754C
10755      IF(ICOM.EQ.'PAUS' .AND. NUMARG.EQ.0)THEN
10756        CALL DPPAUS(IBUGS2,IFOUND,IERROR)
10757        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10758      ENDIF
10759C
10760C               ****************************
10761C               **  TREAT THE SLEEP CASE  **
10762C               ****************************
10763C
10764      IF(ICOM.EQ.'SLEE')THEN
10765        CALL DPSLEE(IHARG,IHARG2,IARGT,IARG,ARG,NUMARG,
10766     1              IBUGD2,ISUBRO,IFOUND,IERROR)
10767        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10768      ENDIF
10769C
10770C               ******************************
10771C               **  TREAT THE APPEND  CASE  **
10772C               ******************************
10773C
10774      IF(ICOM.EQ.'APPE' .OR. ICOM.EQ.'AUGM')THEN
10775        CALL DPAPPE(IBUGS2,IBUGQ,ISUBRO,IFOUND,IERROR)
10776        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10777      ENDIF
10778C
10779C               ******************************
10780C               **  TREAT THE EXTEND  CASE  **
10781C               ******************************
10782C
10783      IF(ICOM.EQ.'EXTE')THEN
10784        CALL DPEXTE(IBUGS2,IBUGQ,ISUBRO,IFOUND,IERROR)
10785        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10786      ENDIF
10787C
10788C               **************************************
10789C               **  TREAT THE SUGGESTION  CASE      **
10790C               **  TREAT THE RECOMMENDATION  CASE  **
10791C               **  TREAT THE PROGRAM  CASE         **
10792C               **  TREAT THE CODE  CASE            **
10793C               **  TREAT THE EXPERT  CASE          **
10794C               **************************************
10795C
10796CCCCC IF(ICOM.EQ.'SUGG')GOTO8600
10797CCCCC IF(ICOM.EQ.'RECO')GOTO8600
10798CCCCC IF(ICOM.EQ.'PROG')GOTO8600
10799CCCCC IF(ICOM.EQ.'CODE')GOTO8600
10800CCCCC IF(ICOM.EQ.'EXPE')GOTO8600
10801CCCCC GOTO8699
10802CCCCC
10803C8600 CONTINUE
10804CCCCC CALL DPSUPR(IHARG,IHARG2,NUMARG,
10805CCCCC1ITOPIC,
10806CCCCC1IANS,IWIDTH,IBUGS2,IFOUND,IERROR)
10807CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10808CCCCC
10809C8699 CONTINUE
10810CCCCC
10811CCCCC           **************************************
10812CCCCC           **  TREAT THE GO          CASE      **
10813CCCCC           **************************************
10814CCCCC
10815CCCCC IF(ICOM.EQ.'GO')GOTO8700
10816CCCCC GOTO8799
10817CCCCC
10818C8700 CONTINUE
10819CCCCC CALL DPWRPF(IPRONU,IPROFS,IPROST,
10820CCCCC1ITOPIC,
10821CCCCC1IHARG,IHARG2,NUMARG,
10822CCCCC1IANS,IWIDTH,IBUGS2,IFOUND,IERROR)
10823CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10824CCCCC
10825C8799 CONTINUE
10826CCCCC
10827CCCCC           **************************************
10828CCCCC           **  TREAT THE CONCLUSIONS CASE      **
10829CCCCC           **************************************
10830CCCCC
10831CCCCC IF(ICOM.EQ.'CONC')GOTO8800
10832CCCCC GOTO8899
10833CCCCC
10834C8800 CONTINUE
10835CCCCC CALL DPLICF(ICONNU,ICONFS,ICONST,
10836CCCCC1IANS,IWIDTH,IBUGS2,IFOUND,IERROR)
10837CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10838C8899 CONTINUE
10839CCCCC
10840CCCCC
10841C               **************************************
10842C               **  TREAT THE ROOT ACCURACY  CASE   **
10843C               **************************************
10844C
10845      IF(ICOM.EQ.'ROOT'.AND.NUMARG.GE.1.AND.
10846     1IHARG(1).EQ.'ACCU')THEN
10847        CALL DPROAC(IHARG,IARGT,ARG,NUMARG,DEFRAC,
10848     1              ROOTAC,IFOUND,IERROR)
10849        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10850      ENDIF
10851C
10852CCCCC           ***************************
10853CCCCC           **  TREAT THE MENU CASE  **
10854CCCCC           ***************************
10855CCCCC
10856CCCCC IF(ICOM.EQ.'MENU')GOTO9100
10857CCCCC GOTO9199
10858CCCCC
10859C9100 CONTINUE
10860CCCCC CALL DPMENU(IMENNU,IMENFS,IMENST,
10861CCCCC1IHARG,NUMARG,IANS,IWIDTH,IBUGS2,IFOUND,IERROR)
10862CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10863CCCCC
10864C9199 CONTINUE
10865CCCCC
10866C               *****************************
10867C               **  TREAT THE PROMPT CASE  **
10868C               *****************************
10869C
10870      IF(ICOM.EQ.'PROM')THEN
10871        CALL DPPROM(IHARG,NUMARG,IPROSW,IFOUND,IERROR)
10872        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10873      ENDIF
10874C
10875C               **************************************
10876C               **  TREAT THE LIST (COMMANDS) CASE  **
10877C               **  (SAME AS THE RECALL CASE)       **
10878C               **************************************
10879C
10880CCCCC THE FOLLOWING PARAGRAPH WAS REWRITTEN    SEPTEMBER 1993
10881C
10882      IF(NUMARG.LE.0)THEN
10883        IF(ICOM.EQ.'LIST' .OR. ICOM.EQ.'TYPE' .OR.
10884     1     ICOM.EQ.'L'    .OR. ICOM.EQ.'RECA' .OR.
10885     1     ICOM.EQ.'V'    .OR. ICOM.EQ.'PREV' .OR.
10886     1    (ICOM.EQ.'VIEW' .AND. IHARG(1).NE.'PLOT'))THEN
10887          CALL DPLICO(IHARG,NUMARG,IANSSV,IREPMX,ILISMX,IPOINT,
10888     1                IHELMX,
10889     1                ICPREH,NCPREH,ICPOSH,NCPOSH,
10890     1                IBUGS2,ISUBRO,IFOUND,IERROR)
10891          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10892        ENDIF
10893      ENDIF
10894C
10895C               ****************************
10896C               **  TREAT THE LIST  CASE  **
10897C               ****************************
10898C
10899CCCCC APRIL 1997: CHECK FOR CONFLICT WITH LIST GRAPH, LIST PLOT,
10900CCCCC             VIEW PLOTS, AND VIEW GRAPHS.
10901C
10902      IF(ICOM.EQ.'VIEW'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT'.AND.
10903     1IHARG2(1).EQ.'    ')GOTO9499
10904      IF(ICOM.EQ.'VIEW'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT'.AND.
10905     1IHARG2(1).EQ.'S  ')GOTO9499
10906      IF(ICOM.EQ.'VIEW'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'GRAP'.AND.
10907     1IHARG2(1).EQ.'H  ')GOTO9499
10908      IF(ICOM.EQ.'VIEW'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'GRAP'.AND.
10909     1IHARG2(1).EQ.'HS ')GOTO9499
10910      IF(ICOM.EQ.'LIST'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT'.AND.
10911     1IHARG2(1).EQ.'    ')GOTO9499
10912      IF(ICOM.EQ.'LIST'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT'.AND.
10913     1IHARG2(1).EQ.'S  ')GOTO9499
10914      IF(ICOM.EQ.'LIST'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'GRAP'.AND.
10915     1IHARG2(1).EQ.'H  ')GOTO9499
10916      IF(ICOM.EQ.'LIST'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'GRAP'.AND.
10917     1IHARG2(1).EQ.'HS ')GOTO9499
10918C
10919      IF((ICOM.EQ.'LIST' .OR. ICOM.EQ.'L   ' .OR. ICOM.EQ.'VIEW' .OR.
10920     1   ICOM.EQ.'PREV' .OR. ICOM.EQ.'NLIS' .OR. ICOM.EQ.'NTYP' .OR.
10921     1   ICOM.EQ.'NVIE' .OR. ICOM.EQ.'NPRE') .AND.
10922     1   IHARG(1).NE.'=   ')THEN
10923CCCCC    2 LINES OF ARGS (IHELMX THROUGH NCPOSH) WERE ADDED JULY 1989
10924CCCCC    THE FOLLOWING LINE WAS CHANGED NOVEMBER 1989
10925        CALL DPLIST(ICOM,IANSLC,IWIDTH,IHARG,IHARG2,IARGT,
10926     1              IARG,ARG,NUMARG,
10927     1              ICOM3,ICOM4,ICOM5,NUMCOM,NCOM5,
10928CCCCC1              IHELMX,
10929     1              ILISMX,
10930     1              ICPREH,NCPREH,ICPOSH,NCPOSH,
10931     1              ILOOST,ILOOLI,NUMLIL,NUMLOS,
10932     1              IANSLO,IWIDLL,
10933     1              IBUGS2,IBUGQ,ISUBRO,IFOUND,IERROR)
10934        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10935      ENDIF
10936C
10937 9499 CONTINUE
10938C
10939CCCCC FOLLOWING SECTION ADDED APRIL 1997.
10940C               **********************************
10941C               **  TREAT THE SAVE PLOT   CASE  **
10942C               **********************************
10943C
10944      IF(NUMARG.GE.1.AND.ICOM.EQ.'SAVE'.AND.
10945     1IHARG(1).EQ.'PLOT'.AND.IHARG2(1).EQ.'    ')GOTO9500
10946      IF(NUMARG.GE.1.AND.ICOM.EQ.'SAVE'.AND.
10947     1IHARG(1).EQ.'PLOT'.AND.IHARG2(1).EQ.'S   ')GOTO9500
10948      IF(NUMARG.GE.1.AND.ICOM.EQ.'SAVE'.AND.
10949     1IHARG(1).EQ.'GRAP'.AND.IHARG2(1).EQ.'H   ')GOTO9500
10950      IF(NUMARG.GE.1.AND.ICOM.EQ.'SAVE'.AND.
10951     1IHARG(1).EQ.'GRAP'.AND.IHARG2(1).EQ.'HS  ')GOTO9500
10952      IF(ICOM.EQ.'SG  ')GOTO9500
10953      IF(ICOM.EQ.'SP  ')GOTO9500
10954      GOTO9509
10955C
10956 9500 CONTINUE
10957      CALL DPSAPL(IANSLC,IWIDTH,IHARG,NUMARG,
10958CCCCC1            IANSSV,IREPMX,IPOINT,
10959     1            IBUGS2,ISUBRO,IFOUND,IERROR)
10960      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10961      GOTO9509
10962C
10963C
10964C               **********************************
10965C               **  TREAT THE SAVE MEMORY CASE  **
10966C               **********************************
10967C
10968 9509 CONTINUE
10969      IF(NUMARG.GE.1.AND.ICOM.EQ.'SAVE'.AND.
10970     1IHARG(1).EQ.'MEMO'.AND.IHARG2(1).EQ.'RY  ')GOTO9510
10971      IF(NUMARG.GE.1.AND.ICOM.EQ.'SAVE'.AND.
10972     1IHARG(1).EQ.'ALL '.AND.IHARG2(1).EQ.'    ')GOTO9510
10973      GOTO9599
10974C
10975 9510 CONTINUE
10976      CALL DPSAVE(IFOUND,IERROR)
10977      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10978      GOTO9599
10979C
10980 9599 CONTINUE
10981C
10982C               **************************************
10983C               **  TREAT THE GUI SAVE PLOT CONTROL **
10984C               **************************************
10985C
10986      IFEESV=IFEEDB
10987      IF(ICOM.EQ.'GUI')THEN
10988        IFEEDB=IGUIFB
10989        IF(NUMARG.GE.3.AND.IHARG(1).EQ.'SAVE'.AND.
10990     1     IHARG(2).EQ.'PLOT'.AND.IHARG(3).EQ.'CONT')THEN
10991           CALL DPSAPC(IBUGS2,ISUBRO,IFOUND,IERROR)
10992           IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
10993        ENDIF
10994      ENDIF
10995      IFEEDB=IFEESV
10996C
10997C               **************************************
10998C               **  TREAT THE SAVE (COMMANDS) CASE  **
10999C               **************************************
11000C
11001CCCCC DECEMBER 1993.  CHECK FOR CONFLICT WITH S CHART COMMAND
11002C
11003      IF(ICOM.EQ.'SAVE' .OR. ICOM.EQ.'S   ' .AND.
11004     1   IHARG(1).NE.'CONT' .AND. IHARG(1).NE.'CHAR' .AND.
11005     1   IHARG(1).NE.'=   ')THEN
11006        CALL DPSACO(IANSLC,IWIDTH,IHARG,IARGT,IARG,NUMARG,
11007     1              IANSSV,IREPMX,IPOINT,ISACNC,
11008     1              IBUGS2,ISUBRO,IFOUND,IERROR)
11009        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11010      ENDIF
11011C
11012C               ****************************************
11013C               **  TREAT THE AUTOPLOT (SWITCH) CASE  **
11014C               ****************************************
11015C
11016      IF(ICOM.EQ.'AUTO'.AND.ICOM2.EQ.'PLOT')THEN
11017        CALL DPAUPL(IHARG,NUMARG,
11018     1              IAUTSW,IAUTEX,IFOUND,IERROR)
11019         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11020      ENDIF
11021C
11022C               **********************************
11023C               **  TREAT THE CURSOR SIZE CASE  **
11024C               **********************************
11025C
11026      IF(ICOM.EQ.'CURS'.AND.NUMARG.GE.1.AND.
11027     1IHARG(1).EQ.'SIZE')GOTO10100
11028      IF(ICOM.EQ.'CURS'.AND.NUMARG.GE.1.AND.
11029     1IHARG(1).EQ.'HEIG')GOTO10100
11030      IF(ICOM.EQ.'DIAL'.AND.NUMARG.GE.1.AND.
11031     1IHARG(1).EQ.'SIZE')GOTO10100
11032      IF(ICOM.EQ.'DIAL'.AND.NUMARG.GE.1.AND.
11033     1IHARG(1).EQ.'HEIG')GOTO10100
11034      GOTO10199
11035C
1103610100 CONTINUE
11037      CALL DPCUSZ(IHARG,IARGT,ARG,NUMARG,DEFCSZ,
11038     1ACURSZ,IFOUND,IERROR)
11039      PDIAHE=ACURSZ
11040      PDIAWI=PDIAHE/2.0
11041      IF(IFOUND.EQ.'YES'.AND.IERROR.EQ.'NO')GOTO10110
11042      GOTO10119
11043C
1104410110 CONTINUE
11045CCCCC ICOPSW='OFF'
11046CCCCC NUMCOP=0
11047CCCCC CALL DPCLPL(ICOPSW,NUMCOP,
11048CCCCC1PGRAXF,PGRAYF,
11049CCCCC1IGRASW,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
11050CCCCC1PDIAHE,PDIAWI,PDIAVG,PDIAHG)
11051CCCCC CALL DPCLDE
11052C0119 CONTINUE
11053      IF(NUMDEV.LE.0)GOTO10119
11054      DO10112IDEVIC=1,NUMDEV
11055      IF(IDPOWE(IDEVIC).EQ.'OFF')GOTO10112
11056      IMANUF=IDMANU(IDEVIC)
11057      IMODEL=IDMODE(IDEVIC)
11058      IMODE2=IDMOD2(IDEVIC)
11059      IMODE3=IDMOD3(IDEVIC)
11060      IGCONT=IDCONT(IDEVIC)
11061      IGCOLO=IDCOLO(IDEVIC)
11062      IGFONT=IDFONT(IDEVIC)
11063      NUMVPP=IDNVPP(IDEVIC)
11064      NUMHPP=IDNHPP(IDEVIC)
11065      ANUMVP=NUMVPP
11066      ANUMHP=NUMHPP
11067      IGUNIT=IDUNIT(IDEVIC)
11068      PCHSCA=PDSCAL(IDEVIC)
11069C
11070      CALL DPOPDE
11071      IBELSJ='OFF'
11072      NUMRIJ=0
11073      IERASJ='OFF'
11074      IBACCJ='JUNK'
11075      CALL DPOPPL(IGRASW,IBELSJ,NUMRIJ,IERASJ,IBACCJ)
11076      ICOPSJ='OFF'
11077      NUMCOJ=0
11078      CALL DPCLPL(ICOPSJ,NUMCOJ,
11079     1            PGRAXF,PGRAYF,
11080     1            IGRASW,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
11081     1            PDIAHE,PDIAWI,PDIAVG,PDIAHG)
11082      CALL DPCLDE
1108310112 CONTINUE
1108410119 CONTINUE
11085      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11086C
11087      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11088C
1108910199 CONTINUE
11090C
11091C               *************************************
11092C               **  TREAT THE CURSOR SPACING CASE  **
11093C               *************************************
11094C
11095      IF(ICOM.EQ.'CURS'.AND.NUMARG.GE.1.AND.
11096     1IHARG(1).EQ.'SPAC')GOTO10200
11097      IF(ICOM.EQ.'CURS'.AND.NUMARG.GE.1.AND.
11098     1IHARG(1).EQ.'GAP')GOTO10200
11099      IF(ICOM.EQ.'DIAL'.AND.NUMARG.GE.1.AND.
11100     1IHARG(1).EQ.'SPAC')GOTO10200
11101      IF(ICOM.EQ.'DIAL'.AND.NUMARG.GE.1.AND.
11102     1IHARG(1).EQ.'GAP')GOTO10200
11103      GOTO10299
11104C
1110510200 CONTINUE
11106      DEFCSP=0.0
11107      CALL DPCUSP(IHARG,IARGT,ARG,NUMARG,DEFCSP,
11108     1PDIAVG,IFOUND,IERROR)
11109      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11110C
1111110299 CONTINUE
11112C
11113C               *****************************************
11114C               **  TREAT THE CURSOR COORDINATES CASE  **
11115C               *****************************************
11116C
11117      IF(ICOM.EQ.'CURS'.AND.NUMARG.GE.1.AND.
11118     1IHARG(1).EQ.'COOR')GOTO10300
11119      IF(ICOM.EQ.'CURS'.AND.NUMARG.GE.1.AND.
11120     1IHARG(1).EQ.'LOCA')GOTO10300
11121      IF(ICOM.EQ.'DIAL'.AND.NUMARG.GE.1.AND.
11122     1IHARG(1).EQ.'COOR')GOTO10300
11123      IF(ICOM.EQ.'DIAL'.AND.NUMARG.GE.1.AND.
11124     1IHARG(1).EQ.'LOCA')GOTO10300
11125      GOTO10399
11126C
1112710300 CONTINUE
11128      CALL DPCUCO(IHARG,IARGT,ARG,NUMARG,PDIAYC,
11129     1PDIAY2,IFOUND,IERROR)
11130      IF(IFOUND.EQ.'YES'.AND.IERROR.EQ.'NO')GOTO10310
11131      GOTO10319
11132C
1113310310 CONTINUE
11134      IF(NUMDEV.LE.0)GOTO10319
11135      DO10312IDEVIC=1,NUMDEV
11136      IF(IDPOWE(IDEVIC).EQ.'OFF')GOTO10312
11137      IMANUF=IDMANU(IDEVIC)
11138      IMODEL=IDMODE(IDEVIC)
11139      IMODE2=IDMOD2(IDEVIC)
11140      IMODE3=IDMOD3(IDEVIC)
11141      IGCONT=IDCONT(IDEVIC)
11142      IGCOLO=IDCOLO(IDEVIC)
11143      IGFONT=IDFONT(IDEVIC)
11144      NUMVPP=IDNVPP(IDEVIC)
11145      NUMHPP=IDNHPP(IDEVIC)
11146      ANUMVP=NUMVPP
11147      ANUMHP=NUMHPP
11148      IGUNIT=IDUNIT(IDEVIC)
11149      PCHSCA=PDSCAL(IDEVIC)
11150C
11151      CALL DPOPDE
11152      IBELSJ='OFF'
11153      NUMRIJ=0
11154      IERASJ='OFF'
11155      IBACCJ='JUNK'
11156      CALL DPOPPL(IGRASW,IBELSJ,NUMRIJ,IERASJ,IBACCJ)
11157      ICOPSJ='OFF'
11158      NUMCOJ=0
11159      CALL DPCLPL(ICOPSJ,NUMCOJ,
11160     1            PGRAXF,PGRAYF,
11161     1            IGRASW,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
11162     1            PDIAHE,PDIAWI,PDIAVG,PDIAHG)
11163      CALL DPCLDE
1116410312 CONTINUE
1116510319 CONTINUE
11166      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11167C
1116810399 CONTINUE
11169C
11170C               **************************************
11171C               **  TREAT THE PREPOST  DEVICE CASE  **
11172C               **************************************
11173C
11174      IF(ICOM.EQ.'PREP'.AND.ICOM2.EQ.'OST')THEN
11175        CALL DPPRPO(ICOM,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
11176     1              IPPDE1,IPPDE2,
11177     1              IBUGS2,IFOUND,IERROR)
11178        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11179      ENDIF
11180C
11181C               ****************************
11182C               **  TREAT THE SEARCH CASE **
11183C               ****************************
11184C
11185      IF(ICOM.EQ.'SEAR' .OR. ICOM.EQ.'?   ' .OR.
11186     1   ICOM.EQ.'??? ' .OR. ICOM.EQ.'GREP' .OR.
11187     1  (ICOM.EQ.'FIND' .AND. ICOM2.EQ.'STR '))THEN
11188        ISEART='1LIN'
11189        IF(ICOM2.EQ.'CHB')ISEART='BLAN'
11190        IF(ICOM2.EQ.'CHBL')ISEART='BLAN'
11191        IF(ICOM2.EQ.'CHD')ISEART='----'
11192        IF(ICOM2.EQ.'CHDA')ISEART='----'
11193        IF(ICOM.EQ.'GREP')ISEART='GREP'
11194        IF(ICOM.EQ.'FIND' .AND. ICOM2.EQ.'STR ')ISEART='FIND'
11195CCCCC   THE FOLLOWING LINE WAS ADDED      JANUARY 1994
11196        IF(ICOM2.EQ.'CH1 ')ISEART='FIRS'
11197        CALL DPSEAR(IANS,IANSLC,IWIDTH,ICOM,IHARG,IHARG2,NUMARG,ISEART,
11198CCCCC   FEBRUARY 2003: ADD FOLLOWING LINE
11199     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
11200     1              IBUGS2,IBUGQ,ISUBRO,IFOUND,IERROR)
11201        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11202      ENDIF
11203C
11204C               ****************************************
11205C               **  TREAT THE LOWESS FRACTION  CASE   **
11206C               ****************************************
11207C
11208      IF(ICOM.EQ.'LOWE'.AND.NUMARG.GE.1.AND.
11209     1IHARG(1).EQ.'FRAC')GOTO10600
11210      IF(ICOM.EQ.'LOWE'.AND.NUMARG.GE.1.AND.
11211     1IHARG(1).EQ.'DECI')GOTO10600
11212      IF(ICOM.EQ.'LOWE'.AND.NUMARG.GE.1.AND.
11213     1IHARG(1).EQ.'PROP')GOTO10600
11214      IF(ICOM.EQ.'LOWE'.AND.NUMARG.GE.1.AND.
11215     1IHARG(1).EQ.'PERC')GOTO10600
11216      GOTO10699
11217C
1121810600 CONTINUE
11219C
11220      CALL DPLOFR(IHARG,IARGT,ARG,NUMARG,
11221     1ALOWFR,IFOUND,IERROR)
11222      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11223C
1122410699 CONTINUE
11225C
11226C               *********************************************
11227C               **  TREAT THE KERNEL DENSITY WIDTH  CASE   **
11228C               *********************************************
11229C
11230      IF(ICOM.EQ.'KERN')THEN
11231        IF(IHARG(1).EQ.'DENS'.AND.IHARG(2).EQ.'WIDT')THEN
11232          ISHIFT=1
11233          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
11234     1                IBUGA2,IERROR)
11235          CALL DPKDWI(IHARG,IARGT,ARG,NUMARG,
11236     1                PKDEWI,DEFKWI,IFOUND,IERROR)
11237          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11238        ELSEIF(IHARG(1).EQ.'WIDT')THEN
11239          CALL DPKDWI(IHARG,IARGT,ARG,NUMARG,
11240     1                PKDEWI,DEFKWI,IFOUND,IERROR)
11241          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11242        ENDIF
11243        IF(IHARG(1).EQ.'DENS'.AND.IHARG(2).EQ.'POIN')THEN
11244          ISHIFT=1
11245          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
11246     1                IBUGA2,IERROR)
11247          CALL DPKDNP(IHARG,IARGT,ARG,NUMARG,
11248     1                IKDENP,IDEFKN,IFOUND,IERROR)
11249          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11250        ELSEIF(IHARG(1).EQ.'POIN')THEN
11251          CALL DPKDNP(IHARG,IARGT,ARG,NUMARG,
11252     1                IKDENP,IDEFKN,IFOUND,IERROR)
11253          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11254        ELSEIF(IHARG(1).EQ.'DENS'.AND.IHARG(2).EQ.'NUMB'.AND.
11255     1         IHARG(3).EQ.'OF  '.AND.IHARG(4).EQ.'POIN')THEN
11256          ISHIFT=3
11257          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
11258     1                IBUGA2,IERROR)
11259          CALL DPKDNP(IHARG,IARGT,ARG,NUMARG,
11260     1                IKDENP,IDEFKN,IFOUND,IERROR)
11261          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11262        ELSEIF(IHARG(1).EQ.'DENS'.AND.IHARG(2).EQ.'NUMB'.AND.
11263     1         IHARG(3).EQ.'POIN')THEN
11264          ISHIFT=2
11265          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
11266     1                IBUGA2,IERROR)
11267          CALL DPKDNP(IHARG,IARGT,ARG,NUMARG,
11268     1                IKDENP,IDEFKN,IFOUND,IERROR)
11269          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11270        ENDIF
11271      ENDIF
11272C
11273C               *********************************************
11274C               **  TREAT THE BOOSTRAP SAMPLE SIZE  CASE   **
11275C               *********************************************
11276C
11277      IF(ICOM.EQ.'BOOT'.AND.NUMARG.GE.1.AND.
11278     1IHARG(1).EQ.'SAMP')GOTO10700
11279      IF(ICOM.EQ.'BOOT'.AND.NUMARG.GE.1.AND.
11280     1IHARG(1).EQ.'SIZE')GOTO10700
11281      GOTO10799
11282C
1128310700 CONTINUE
11284C
11285      CALL DPBOSS(IHARG,IARGT,IARG,NUMARG,
11286     1IBOOSS,IDEBOO,IFOUND,IERROR)
11287      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11288C
1128910799 CONTINUE
11290C
11291C               ***************************
11292C               **  TREAT THE SYSTEM CASE**
11293C               ***************************
11294C
11295      IF(ICOM.EQ.'SYST' .OR. ICOM.EQ.'DOS' .OR.
11296     1   ICOM.EQ.'UNIX' .OR. ICOM.EQ.'VMS' .OR.
11297     1   ICOM.EQ.'OS')THEN
11298        CALL DPSYST(IANS,IANSLC,IWIDTH,
11299     1              IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,
11300     1              IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,
11301     1              IBUGS2,ISUBRO,IFOUND,IERROR)
11302        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11303      ENDIF
11304C
11305C               *************************************
11306C               **  TREAT THE RSCRIPT/PYTHON CASE  **
11307C               *************************************
11308C
11309      IF(ICOM.EQ.'RSCR' .OR. ICOM.EQ.'PYTH')THEN
11310        CALL DPEXRP(IANS,IANSLC,IWIDTH,ICOM,ICOM2,
11311     1              IBUGS2,ISUBRO,IFOUND,IERROR)
11312        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11313      ENDIF
11314C
11315CCCCC THE FOLLOWING SECTION WAS ADDED JUNE 1989
11316C               *************************************
11317C               **  TREAT THE CAPTURE CASE         **
11318C               **  TREAT THE END CAPTURE CASE     **
11319C               **  TREAT THE END OF CAPTURE CASE  **
11320C               **  TREAT THE REDIRECT CASE        **
11321C               **  TREAT THE END REDIRECT CASE    **
11322C               **  TREAT THE END OF REDIRECT CASE **
11323C               *************************************
11324C
11325      IF(ICOM.EQ.'CAPT')GOTO11100
11326      IF(ICOM.EQ.'END '.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'CAPT')GOTO11100
11327      IF(ICOM.EQ.'END '.AND.NUMARG.GE.2.AND.IHARG(1).EQ.'OF  '.AND.
11328     1IHARG(2).EQ.'CAPT')GOTO11100
11329      IF(ICOM.EQ.'REDI')GOTO11100
11330      IF(ICOM.EQ.'END '.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'REDI')GOTO11100
11331      IF(ICOM.EQ.'END '.AND.NUMARG.GE.2.AND.IHARG(1).EQ.'OF  '.AND.
11332     1IHARG(2).EQ.'REDI')GOTO11100
11333      GOTO11199
11334C
1133511100 CONTINUE
11336      CALL DPCAPT(ICOM,ICOM2,
11337CCCCC JUNE 2002.  ADD ICAPTY
11338CCCCC JANUARY 2006.  ADD ICAPSC
11339     1ICAPSW,ICAPTY,ICAPSC,IPRDEF,
11340     1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,MAXNAM,IANSLC,IANS,IWIDTH,
11341     1IHARG,IHARG2,IARGT,IARG,ARG,NUMARG,
11342     1IOFILE,
11343CCCCC JUNE 2002.  ADD FOLLOWING ARGUMENTS TO ALLOW "CALL DPERAS".
11344     1IBACCO,IGRASW,IDIASW,
11345     1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
11346     1PDIAHE,PDIAWI,PDIAVG,PDIAHG,
11347     1NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
11348     1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
11349     1IDNVOF,IDNHOF,IDFONT,PDSCAL,
11350     1IREPCH,IMPSW,
11351     1IBUGS2,ISUBRO,IFOUND,IERROR)
11352      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11353C
1135411199 CONTINUE
11355C
11356CCCCC THE FOLLOWING SECTION WAS INSERTED NOVERMBER 1989
11357C               **************************************************
11358C               **  TREAT THE YATES COEF/T/RESSD CUTOFF CASE    **
11359C               **************************************************
11360C
11361      IF(ICOM.EQ.'YATE')GOTO11210
11362      GOTO11299
11363C
1136411210 CONTINUE
11365      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'CUTO'.AND.
11366     1IHARG2(2).EQ.'FF')GOTO11220
11367      GOTO11299
1136811220 CONTINUE
11369      CALL DPYACU(IHARG,IARGT,ARG,NUMARG,
11370     1YATCCU,YATTCU,YATRCU,IFOUND,IERROR)
11371      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11372C
1137311299 CONTINUE
11374C
11375CCCCC THE FOLLOWING SECTION WAS INSERTED NOVERMBER 1989
11376C               **************************************************
11377C               **  TREAT THE YATES OUTPUT CASE                 **
11378C               **************************************************
11379C
11380      IF(ICOM.EQ.'YATE')GOTO11310
11381      GOTO11399
11382C
1138311310 CONTINUE
11384      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'OUTP'.AND.
11385     1IHARG2(1).EQ.'UT')GOTO11320
11386      GOTO11399
1138711320 CONTINUE
11388      CALL DPYAOU(IHARG,NUMARG,
11389     1IYATOS,IFOUND,IERROR)
11390      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11391C
1139211399 CONTINUE
11393C
11394CCCCC THE FOLLOWING SECTION WAS INSERTED NOVERMBER 1989
11395C               **************************************************
11396C               **  TREAT THE COLUMN RULER CASE                 **
11397C               **  TREAT THE        RULER CASE                 **
11398C               **************************************************
11399C
11400      IF(ICOM.EQ.'COLU'.AND.NUMARG.GE.1.AND.
11401     1IHARG(1).EQ.'RULE')GOTO11410
11402      IF(ICOM.EQ.'RULE')GOTO11410
11403      IF(ICOM.EQ.'COLU'.AND.NUMARG.GE.1.AND.
11404     1IHARG(1).EQ.'NRUL')GOTO11410
11405      IF(ICOM.EQ.'NRUL')GOTO11410
11406      GOTO11499
11407C
1140811410 CONTINUE
11409      CALL DPCORU(ICOM,IHARG,NUMARG,
11410     1IFOUND,IERROR)
11411      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11412C
1141311499 CONTINUE
11414C
11415CCCCC THE FOLLOWING SECTION WAS ADDED BY ALAN   MAY 1990
11416C               ******************************************
11417C               **  TREAT THE COMMENT    CHARACTER CASE **
11418C               ******************************************
11419C
11420      IF(ICOM.EQ.'COMM')THEN
11421        CALL DPCOMM(IHARG,NUMARG,
11422     1              IDEFCZ,
11423     1              ICOMCH,
11424     1              ICOMSW,
11425     1              IBUGS2,IFOUND,IERROR)
11426        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11427      ENDIF
11428C
11429CCCCC THE FOLLOWING SECTION WAS ADDED   MARCH 1992
11430C               ******************************************
11431C               **  TREAT THE PRINTER TYPE/FORMAT CASE  **
11432C               ******************************************
11433C
11434      IF(ICOM.EQ.'PRIN'.AND.ICOM2.EQ.'TER ')GOTO11610
11435      IF(ICOM.EQ.'LP  ' .AND. IHARG(1).NE.'LOCA')GOTO11610
11436      GOTO11699
11437C
1143811610 CONTINUE
11439CCCCC CALL DPPRFO(IHARG,NUMARG,IPRITY,IBUGS2,IERROR)
11440      CALL DPPRFO(IHARG,NUMARG,IPRITY,IFOUND,IERROR)
11441      IF(IERROR.EQ.'YES')GOTO9000
11442C
1144311699 CONTINUE
11444C
11445CCCCC THE FOLLOWING SECTION WAS ADDED   MARCH 1992
11446C               ******************************************
11447C               **  TREAT THE FILE TYPE/FORMAT CASE     **
11448C               ******************************************
11449C
11450      IF(ICOM.EQ.'FILE')THEN
11451        CALL DPFIFO(IHARG,NUMARG,IOUTTY,IFOUND,IERROR)
11452        IF(IERROR.EQ.'YES')GOTO9000
11453      ENDIF
11454C
11455CCCCC THE FOLLOWING SECTION WAS ADDED BY ALAN   AUGUST 1992
11456C               ******************************************
11457C               **  TREAT THE VECTOR FORMAT        CASE **
11458C               ******************************************
11459C
11460      IF(ICOM.EQ.'VECT'.AND.IHARG(1).EQ.'FORM')THEN
11461        CALL DPVCFM(IHARG,NUMARG,
11462     1              IDEFVF,
11463     1              IVCFMT,
11464     1              IBUGS2,IFOUND,IERROR)
11465        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11466      ENDIF
11467C
11468CCCCC THE FOLLOWING SECTION WAS ADDED BY ALAN   AUGUST 1992
11469C               ******************************************
11470C               **  TREAT THE VECTOR ARROW         CASE **
11471C               ******************************************
11472C
11473      IF(ICOM.EQ.'VECT'.AND.IHARG(1).EQ.'ARRO')THEN
11474        CALL DPVCAR(IHARG,NUMARG,
11475     1              IDEFVA,IDEFVO,
11476     1              IVCARR,IVCOPN,
11477     1              IBUGS2,IFOUND,IERROR)
11478        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11479      ENDIF
11480C
11481CCCCC THE FOLLOWING SECTION WAS ADDED BY ALAN   NOVEMBER 1992
11482C               ******************************************
11483C               **  TREAT THE ANDREWS INCREMENT    CASE **
11484C               ******************************************
11485C
11486      IF(ICOM.EQ.'ANDR'.AND.IHARG(1).EQ.'INCR')THEN
11487        CALL DPANIN(IHARG,IARGT,ARG,NUMARG,DEFAIN,
11488     1              ANDINC,IFOUND,IERROR)
11489        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11490      ENDIF
11491C
11492CCCCC THE FOLLOWING SECTION WAS ADDED BY ALAN   JULY 1993
11493C               ******************************************
11494C               **  TREAT THE FRACTAL ITERATIONS   CASE **
11495C               ******************************************
11496C
11497      IF(ICOM.EQ.'FRAC'.AND.IHARG(1).EQ.'ITER')THEN
11498        CALL DPFRIT(IHARG,IARGT,ARG,NUMARG,MAXPOP,
11499     1              IFRAIT,IFOUND,IERROR)
11500        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11501      ENDIF
11502C
11503CCCCC THE FOLLOWING SECTION WAS ADDED BY ALAN   JULY 1993
11504C               ******************************************
11505C               **  TREAT THE FRACTAL TYPE         CASE **
11506C               ******************************************
11507C
11508      IF(ICOM.EQ.'FRAC'.AND.IHARG(1).EQ.'TYPE')THEN
11509        CALL DPFRTY(IHARG,NUMARG,
11510     1              IDEFFT,
11511     1              IFRATY,
11512     1              IBUGS2,IFOUND,IERROR)
11513        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11514      ENDIF
11515C
11516CCCCC THE FOLLOWING SECTION WAS ADDED BY ALAN   JULY 1993
11517C               **********************************************
11518C               **  TREAT THE PRINCIPLE COMPONENT TYPE CASE **
11519C               **********************************************
11520C
11521      IF(ICOM.EQ.'PRIN'.AND.IHARG(1).EQ.'COMP'.AND.
11522     1   IHARG(2).EQ.'TYPE')THEN
11523        CALL DPPCTY(IHARG,NUMARG,
11524     1              IDEFPT,
11525     1              IPCMTY,
11526     1              IBUGS2,IFOUND,IERROR)
11527        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11528      ENDIF
11529C
11530C               ****************************************
11531C               **  TREAT THE LOWESS DEGREE  CASE     **
11532C               ****************************************
11533C
11534      IF(ICOM.EQ.'LOWE'.AND.NUMARG.GE.1.AND.
11535     1   IHARG(1).EQ.'DEGR')THEN
11536        CALL DPLODG(IHARG,IARGT,ARG,NUMARG,
11537     1              ALOWDG,IFOUND,IERROR)
11538        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11539      ENDIF
11540C
11541CCCCC FOLLOWING SECTION ADDED JUNE 1994.
11542C               ***********************************************
11543C               **  TREAT THE OPTIMIZATION TOLERANCE  CASE   **
11544C               ***********************************************
11545C
11546      IF(ICOM.EQ.'OPTI'.AND.NUMARG.GE.1.AND.
11547     1IHARG(1).EQ.'TOLE')GOTO12600
11548      IF(ICOM.EQ.'OPTI'.AND.NUMARG.GE.1.AND.
11549     1IHARG(1).EQ.'ACCU')GOTO12600
11550      GOTO12699
11551C
1155212600 CONTINUE
11553C
11554      CALL DPOPAC(IHARG,IARGT,ARG,NUMARG,DEFOAC,
11555     1OPTACC,IFOUND,IERROR)
11556      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11557C
1155812699 CONTINUE
11559C
11560CCCCC THE FOLLOWING SECTION  WAS ADDED   MAY 1994  (JJF)
11561C               *****************************************
11562C               **  TREAT THE COPY (= COPY FILE) CASE  **
11563C               *****************************************
11564C
11565      IF(NUMARG.GE.1)THEN
11566         IF(ICOM.EQ.'COPY')THEN
11567            CALL DPCOFI(ICOM,IANSLC,IWIDTH,IHARG,IHARG2,NUMARG,
11568     1                  IBUGS2,IBUGQ,ISUBRO,IFOUND,IERROR)
11569            IFOUND='YES'
11570            GOTO9000
11571         ENDIF
11572      ENDIF
11573C
11574CCCCC THE FOLLOWING SECTION  WAS ADDED   MARCH 2019
11575C               *****************************************
11576C               **  TREAT THE PRINTFILE          CASE  **
11577C               *****************************************
11578C
11579      IF(NUMARG.GE.1)THEN
11580         IF(ICOM.EQ.'PRIN' .AND. ICOM2.EQ.'TFIL')THEN
11581            CALL DPPRFI(ICOM,IANSLC,IWIDTH,IHARG,IHARG2,NUMARG,
11582     1                  IBUGS2,ISUBRO,IFOUND,IERROR)
11583            IFOUND='YES'
11584            GOTO9000
11585         ENDIF
11586      ENDIF
11587C
11588CCCCC THE FOLLOWING SECTION WAS ADDED BY ALAN   FEBRUARY 1995
11589C               **********************************************
11590C               **  TREAT THE OPTIMIZATION METHOD      CASE **
11591C               **********************************************
11592C
11593      IF(ICOM.EQ.'OPTI'.AND.NUMARG.GE.1.AND.
11594     1   IHARG(1).EQ.'METH')THEN
11595        CALL DPOPME(IHARG,NUMARG,
11596     1              IDEFOM,IDEFHS,
11597     1              IOPTME,IOPTHE,
11598     1              IBUGS2,IFOUND,IERROR)
11599        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11600      ENDIF
11601C
11602CCCCC THE FOLLOWING SECTION WAS ADDED BY JIM   SEPTEMBER 1995
11603C               **********************************************
11604C               **  TREAT THE   INIT   CASE                 **
11605C               **  (USEFUL FOR SIGN-ON DEBUGGING)          **
11606C               **********************************************
11607C
11608      IF(ICOM.EQ.'INIT')THEN
11609         IBUGIN='ON'
11610C
11611         ICOMHO=ICOM
11612         ICOMH2=ICOM2
11613C
11614         WRITE(ICOUT,10811)
1161510811    FORMAT('FROM MAINSU--BEFORE CALL TO MAININ')
11616         CALL DPWRST('XXX','BUG ')
11617         WRITE(ICOUT,10812)IBUGMA,IBUGIN,ICOM,ICOM2,ICOMHO,ICOMH2,NUMDEV
1161810812    FORMAT('IBUGMA,IBUGIN,ICOM,ICOM2,ICOMHO,ICOMH2,NUMDEV = ',
11619     1   A4,2X,A4,2X,A4,2X,A4,2X,A4,2X,A4,I8)
11620         CALL DPWRST('XXX','BUG ')
11621C
11622         IRSCNT=1
11623         CALL MAININ(IBUGIN,ICOMHO,ICOMH2,IRSCNT)
11624         IBUGIN='OFF'
11625         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11626      ENDIF
11627C
11628CCCCC FOLLOWING SECTION ADDED APRIL 1997.
11629C               *******************************
11630C               **  TREAT THE WEB HELP CASE  **
11631C               *******************************
11632C
11633 1201 CONTINUE
11634C
11635      IF((ICOM.EQ.'WEB'.AND.IHARG(1).EQ.'HELP') .OR.
11636     1    ICOM.EQ.'??  ')THEN
11637        CALL DPHELW(ICOM,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
11638     1              IANS,IWIDTH,
11639     1              IBUGS2,ISUBRO,IFOUND,IERROR)
11640        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11641      ENDIF
11642C
11643CCCCC FOLLOWING SECTION ADDED MARCH 1999.
11644C               ***********************************
11645C               **  TREAT THE WEB HANDBOOK CASE  **
11646C               ***********************************
11647C
11648      IF(ICOM.EQ.'HAND' .OR. ICOM.EQ.'HB  ' .OR.
11649     1   ICOM.EQ.'WHB ' .OR.
11650     1  (ICOM.EQ.'????' .AND. ICOM2.EQ.'    ') .OR.
11651     1   (ICOM.EQ.'WEB'.AND.IHARG(1).EQ.'HAND'))THEN
11652        CALL DPHANW(ICOM,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,IANS,
11653     1              IWIDTH,IBUGS2,ISUBRO,IFOUND,IERROR)
11654        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11655      ENDIF
11656C
11657CCCCC FOLLOWING SECTION ADDED APRIL 1997.
11658C               *******************************
11659C               **  TREAT THE WEB      CASE  **
11660C               **  NOTE: SET "HANDBOOK" =   **
11661C               **        "WEB HANDBOOK      **
11662C               *******************************
11663C
11664CCCCC 2019/11: IF THE FIRST ARGUMENT DOES NOT START WITH ONE OF THE
11665C              FOLLOWING
11666C
11667C                  http
11668C                  file:
11669C                  www.
11670C                  A PERIOD "." WITHIN THE FIRST 8 CHARACTERS, THEN
11671C
11672C              THEN ASSUME THIS IS NOT A URL ADDRESS AND CONVERT THE
11673C              "WEB" COMMAND TO A "WEB HELP" COMMAND.
11674C
11675      IF(ICOM.EQ.'WEB'  .OR. ICOM.EQ.'W   ' .OR.
11676     1   ICOM.EQ.'WS  ' .OR.
11677     1  (ICOM.EQ.'????' .AND. ICOM2.EQ.'?   '))THEN
11678C
11679        IFLAG=0
11680        IF(ICOM.EQ.'WS  ')IFLAG=1
11681        IF(ICOM.EQ.'????' .AND. ICOM2.EQ.'?   ')IFLAG=1
11682        IF(IHARG(1).EQ.'SEAR' .AND. IHARG2(1).EQ.'CH  ')IFLAG=1
11683        IF(IHARG(1).EQ.'HTTP' .AND. IHARG2(1)(1:1).EQ.':')IFLAG=1
11684        IF(IHARG(1).EQ.'HTTP' .AND. IHARG2(1)(1:2).EQ.'S:')IFLAG=1
11685        IF(IHARG(1).EQ.'FILE' .AND. IHARG2(1)(1:1).EQ.':')IFLAG=1
11686        IF(IHARG(1).EQ.'"HTT' .AND. IHARG2(1)(1:2).EQ.'P:')IFLAG=1
11687        IF(IHARG(1).EQ.'"HTT' .AND. IHARG2(1)(1:3).EQ.'PS:')IFLAG=1
11688        IF(IHARG(1).EQ.'"FIL' .AND. IHARG2(1)(1:2).EQ.'E:')IFLAG=1
11689        IF(IHARG(1).EQ.'WWW.')IFLAG=1
11690        IF(IHARG(1)(1:1).EQ.'.')IFLAG=1
11691        IF(IHARG(1)(2:2).EQ.'.')IFLAG=1
11692        IF(IHARG(1)(3:3).EQ.'.')IFLAG=1
11693        IF(IHARG(1)(4:4).EQ.'.')IFLAG=1
11694        IF(IHARG2(1)(1:1).EQ.'.')IFLAG=1
11695        IF(IHARG2(1)(2:2).EQ.'.')IFLAG=1
11696        IF(IHARG2(1)(3:3).EQ.'.')IFLAG=1
11697        IF(IHARG2(1)(4:4).EQ.'.')IFLAG=1
11698C
11699        IF(IFLAG.EQ.1)THEN
11700          CALL DPWEB(ICOM,ICOM2,IHARG,IHARG2,NUMARG,
11701     1               IANSLC,IWIDTH,IBUGS2,ISUBRO,IFOUND,IERROR)
11702          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11703        ELSE
11704          ISHIFT=1
11705          CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
11706     1                IBUGS2,IERROR)
11707          ISTRT=-1
11708          DO1210II=1,30
11709            IF(IANS(II)(1:1).EQ.IHARG(1)(1:1)   .AND.
11710     1         IANS(II+1)(1:1).EQ.IHARG(1)(2:2) .AND.
11711     1         IANS(II+2)(1:1).EQ.IHARG(1)(3:3) .AND.
11712     1         IANS(II+3)(1:1).EQ.IHARG(1)(4:4))THEN
11713              ISTRT=II
11714              GOTO1219
11715            ENDIF
11716 1210     CONTINUE
11717 1219     CONTINUE
11718          IF(ISTRT.GE.1)THEN
11719            DO1220II=ISTRT,IWIDTH
11720              IF(II+5.LE.MAXSTR)THEN
11721                IANS(II+5)=IANS(II)
11722                IANSLC(II+5)=IANSLC(II)
11723              ENDIF
11724 1220       CONTINUE
11725            IANS(ISTRT)='H   '
11726            IANS(ISTRT+1)='E   '
11727            IANS(ISTRT+2)='L   '
11728            IANS(ISTRT+3)='P   '
11729            IANS(ISTRT+4)='    '
11730            IANSLC(ISTRT)='H   '
11731            IANSLC(ISTRT+1)='E   '
11732            IANSLC(ISTRT+2)='L   '
11733            IANSLC(ISTRT+3)='P   '
11734            IANSLC(ISTRT+4)='    '
11735          ENDIF
11736          IHARG(1)='HELP'
11737          IHARG2(1)='    '
11738          GOTO1201
11739        ENDIF
11740      ENDIF
11741C
11742CCCCC FOLLOWING SECTION ADDED APRIL 1997.
11743C               **********************************
11744C               **  TREAT THE REPEAT GRAPH CASE **
11745C               **********************************
11746C
11747      IF(NUMARG.GE.1.AND.ICOM.EQ.'REPE'.AND.
11748     1IHARG(1).EQ.'PLOT'.AND.IHARG2(1).EQ.'    ')GOTO12900
11749      IF(NUMARG.GE.1.AND.ICOM.EQ.'REPE'.AND.
11750     1IHARG(1).EQ.'PLOT'.AND.IHARG2(1).EQ.'S   ')GOTO12900
11751      IF(NUMARG.GE.1.AND.ICOM.EQ.'REPE'.AND.
11752     1IHARG(1).EQ.'GRAP'.AND.IHARG2(1).EQ.'H   ')GOTO12900
11753      IF(NUMARG.GE.1.AND.ICOM.EQ.'REPE'.AND.
11754     1IHARG(1).EQ.'GRAP'.AND.IHARG2(1).EQ.'HS  ')GOTO12900
11755      IF(ICOM.EQ.'RG  ')GOTO12900
11756      IF(ICOM.EQ.'RP  ')GOTO12900
11757      IF(NUMARG.GE.1.AND.ICOM.EQ.'VIEW'.AND.
11758     1IHARG(1).EQ.'PLOT'.AND.IHARG2(1).EQ.'    ')GOTO12900
11759      IF(NUMARG.GE.1.AND.ICOM.EQ.'VIEW'.AND.
11760     1IHARG(1).EQ.'PLOT'.AND.IHARG2(1).EQ.'S   ')GOTO12900
11761      IF(NUMARG.GE.1.AND.ICOM.EQ.'VIEW'.AND.
11762     1IHARG(1).EQ.'GRAP'.AND.IHARG2(1).EQ.'H   ')GOTO12900
11763      IF(NUMARG.GE.1.AND.ICOM.EQ.'VIEW'.AND.
11764     1IHARG(1).EQ.'GRAP'.AND.IHARG2(1).EQ.'HS  ')GOTO12900
11765      IF(ICOM.EQ.'VG  ')GOTO12900
11766      IF(ICOM.EQ.'VP  ')GOTO12900
11767      GOTO12990
11768C
1176912900 CONTINUE
11770      CALL DPREGR(IANSLC,IWIDTH,IHARG,IARGT,IARG,NUMARG,
11771     1IBUGS2,ISUBRO,IFOUND,IERROR)
11772      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
1177312990 CONTINUE
11774C
11775CCCCC FOLLOWING SECTION ADDED APRIL 1997.
11776C               **********************************
11777C               **  TREAT THE LIST   GRAPH CASE **
11778C               **********************************
11779C
11780      IF(NUMARG.GE.1.AND.ICOM.EQ.'LIST'.AND.
11781     1IHARG(1).EQ.'PLOT'.AND.IHARG2(1).EQ.'    ')GOTO13000
11782      IF(NUMARG.GE.1.AND.ICOM.EQ.'LIST'.AND.
11783     1IHARG(1).EQ.'PLOT'.AND.IHARG2(1).EQ.'S   ')GOTO13000
11784      IF(NUMARG.GE.1.AND.ICOM.EQ.'LIST'.AND.
11785     1IHARG(1).EQ.'GRAP'.AND.IHARG2(1).EQ.'H   ')GOTO13000
11786      IF(NUMARG.GE.1.AND.ICOM.EQ.'LIST'.AND.
11787     1IHARG(1).EQ.'GRAP'.AND.IHARG2(1).EQ.'HS  ')GOTO13000
11788      IF(ICOM.EQ.'LG  ')GOTO13000
11789      IF(ICOM.EQ.'LP  ' .AND. IHARG(1).NE.'LOCA')GOTO13000
11790      GOTO13090
11791C
1179213000 CONTINUE
11793      CALL DPLIGR(IANSLC,IWIDTH,IHARG,IARGT,IARG,NUMARG,
11794     1IBUGS2,ISUBRO,IFOUND,IERROR)
11795      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
1179613090 CONTINUE
11797C
11798CCCCC FOLLOWING SECTION ADDED APRIL 1997.
11799C               **********************************
11800C               **  TREAT THE CYCLE  GRAPH CASE **
11801C               **********************************
11802C
11803      IF(NUMARG.GE.1.AND.ICOM.EQ.'CYCL'.AND.
11804     1IHARG(1).EQ.'PLOT'.AND.IHARG2(1).EQ.'    ')GOTO13100
11805      IF(NUMARG.GE.1.AND.ICOM.EQ.'CYCL'.AND.
11806     1IHARG(1).EQ.'PLOT'.AND.IHARG2(1).EQ.'S   ')GOTO13100
11807      IF(NUMARG.GE.1.AND.ICOM.EQ.'CYCL'.AND.
11808     1IHARG(1).EQ.'GRAP'.AND.IHARG2(1).EQ.'H   ')GOTO13100
11809      IF(NUMARG.GE.1.AND.ICOM.EQ.'CYCL'.AND.
11810     1IHARG(1).EQ.'GRAP'.AND.IHARG2(1).EQ.'HS  ')GOTO13100
11811      IF(ICOM.EQ.'CG  ')GOTO13100
11812CCCCC MARCH 1998.  CONFLICT WITH CP PLOT COMMAND.
11813      IF(ICOM.EQ.'CP  '.AND.IHARG(1).NE.'PLOT')GOTO13100
11814      GOTO13190
11815C
1181613100 CONTINUE
11817      CALL DPCYGR(IANSLC,IWIDTH,IHARG,IARGT,IARG,NUMARG,
11818     1IBUGS2,ISUBRO,IFOUND,IERROR)
11819      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
1182013190 CONTINUE
11821C
11822C               ***************************
11823C               **  TREAT THE CD     CASE**
11824C               ***************************
11825C
11826      IF(ICOM.EQ.'CD  ')THEN
11827        CALL DPCDIR(IANS,IANSLC,IWIDTH,
11828     1              IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,
11829     1              IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,
11830     1              IBUGS2,ISUBRO,IFOUND,IERROR)
11831        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11832      ENDIF
11833C
11834C               ********************************
11835C               **  TREAT THE RM     CASE     **
11836C               ********************************
11837C
11838      IF(ICOM.EQ.'RM  ' .OR.
11839     1  (ICOM.EQ.'RMDI' .AND. ICOM2.EQ.'R   '))THEN
11840        CALL DPRM(IANS,IANSLC,IWIDTH,IBUGS2,ISUBRO,IFOUND,IERROR)
11841        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11842      ENDIF
11843C
11844C               ********************************
11845C               **  TREAT THE MKDIR  CASE     **
11846C               ********************************
11847C
11848      IF(ICOM.EQ.'MKDI' .AND. ICOM2.EQ.'R   ')THEN
11849        CALL DPMKDR(IANS,IANSLC,IWIDTH,IBUGS2,ISUBRO,IFOUND,IERROR)
11850        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11851      ENDIF
11852C
11853C               ********************************
11854C               **  TREAT THE CAT    CASE     **
11855C               ********************************
11856C
11857      IF(ICOM.EQ.'CAT ' .OR.
11858     1  (ICOM.EQ.'TYPE' .AND. ICOM2.EQ.'    '))THEN
11859        CALL DPCAT(IANS,IANSLC,IWIDTH,IBUGS2,ISUBRO,IFOUND,IERROR)
11860        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11861      ENDIF
11862C
11863C               ********************************
11864C               **  TREAT THE DIR    CASE     **
11865C               ********************************
11866C
11867      IF(ICOM.EQ.'DIR ' .OR. ICOM.EQ.'LS  ')THEN
11868        CALL DPDIR(IANS,IANSLC,IWIDTH,IBUGS2,ISUBRO,IFOUND,IERROR)
11869        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11870      ENDIF
11871C
11872C               ******************************************************
11873C               **  TREAT THE RECIPE SATTERWAITE APPROXIMATION CASE **
11874C               ******************************************************
11875C
11876      IF(ICOM.EQ.'RECI')THEN
11877        IF((NUMARG.GE.2.AND.IHARG(1).EQ.'SATT'.AND.
11878     1     IHARG(2).EQ.'APPR') .OR.
11879     1     (NUMARG.GE.1.AND.IHARG(1).EQ.'SATT') .OR.
11880     1     (NUMARG.GE.1.AND.IHARG(1).EQ.'APPR'))THEN
11881          CALL DPRESA(IHARG,NUMARG,IDEFSA,IRECSA,IBUGS2,IFOUND,IERROR)
11882          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11883C
11884C               ******************************************************
11885C               **  TREAT THE RECIPE PROBABILITY CONTENT       CASE **
11886C               ******************************************************
11887C
11888        ELSEIF((NUMARG.GE.2.AND.IHARG(1).EQ.'PROB'.AND.
11889     1         IHARG(2).EQ.'PLOT') .OR.
11890     1         (NUMARG.GE.2.AND.IHARG(1).EQ.'PROB'.AND.
11891     1         IHARG(2).EQ.'CONT') .OR.
11892     1         (NUMARG.GE.1.AND.IHARG(1).EQ.'CONT') .OR.
11893     1         (NUMARG.GE.1.AND.IHARG(1).EQ.'PROB'))THEN
11894          CALL DPREPC(IHARG,IARGT,ARG,NUMARG,DEFRPC,RECIPC,
11895     1                IFOUND,IERROR)
11896          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11897C
11898C               ******************************************************
11899C               **  TREAT THE RECIPE CONFIDENCE                CASE **
11900C               ******************************************************
11901C
11902        ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'CONF')THEN
11903          CALL DPRECO(IHARG,IARGT,ARG,NUMARG,DEFRCO,RECICO,
11904     1                IFOUND,IERROR)
11905          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11906C
11907C               ******************************************************
11908C               **  TREAT THE RECIPE FIT DEGREE                CASE **
11909C               ******************************************************
11910C
11911        ELSEIF((NUMARG.GE.2.AND.IHARG(1).EQ.'FIT '.AND.
11912     1         IHARG(2).EQ.'DEGR') .OR.
11913     1         (NUMARG.GE.1.AND.IHARG(1).EQ.'DEGR'))THEN
11914          CALL DPREDG(IHARG,IARGT,ARG,NUMARG,DEFRDG,RECIDG,
11915     1                IFOUND,IERROR)
11916          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11917C
11918C               ******************************************************
11919C               **  TREAT THE RECIPE ANOVA FACTORS             CASE **
11920C               ******************************************************
11921C
11922        ELSEIF((NUMARG.GE.2.AND.IHARG(1).EQ.'ANOV'.AND.
11923     1         IHARG(2).EQ.'FACT') .OR.
11924     1         (NUMARG.GE.1.AND.IHARG(1).EQ.'FACT'))THEN
11925          CALL DPREFA(IHARG,IARGT,ARG,NUMARG,DEFRFA,RECIFA,
11926     1                IFOUND,IERROR)
11927          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11928C
11929C               ******************************************************
11930C               **  TREAT THE RECIPE OUTPUT                    CASE **
11931C               ******************************************************
11932C
11933        ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'OUTP')THEN
11934          CALL DPRETN(IHARG,NUMARG,IDEFTN,IRECTN,
11935     1                IBUGS2,IFOUND,IERROR)
11936          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11937C
11938C               ******************************************************
11939C               **  TREAT THE RECIPE CORRELATION               CASE **
11940C               ******************************************************
11941C
11942        ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'CORR')THEN
11943          CALL DPRECR(IHARG,IARGT,IARG,NUMARG,IDEFR9,IRECC1,
11944     1                IFOUND,IERROR)
11945          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11946C
11947C               ******************************************************
11948C               **  TREAT THE RECIPE SIMCOV REPLICATES         CASE **
11949C               ******************************************************
11950C
11951        ELSEIF((NUMARG.GE.2.AND.IHARG(1).EQ.'SIMC'.AND.
11952     1         IHARG(2).EQ.'REPL') .OR.
11953     1         (NUMARG.GE.2.AND.IHARG(1).EQ.'REPL'.AND.
11954     1         IHARG(2).EQ.'SIMC') .OR.
11955     1         (NUMARG.GE.1.AND.IHARG(1).EQ.'SIMC') .OR.
11956     1         (NUMARG.GE.1.AND.IHARG(1).EQ.'REPL'))THEN
11957          CALL DPRES1(IHARG,IARGT,IARG,NUMARG,IDEFR7,IRECR1,
11958     1                IFOUND,IERROR)
11959          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11960C
11961C               ******************************************************
11962C               **  TREAT THE RECIPE SIMPVT REPLICATES         CASE **
11963C               ******************************************************
11964C
11965        ELSEIF((NUMARG.GE.2.AND.IHARG(1).EQ.'SIMP'.AND.
11966     1         IHARG(2).EQ.'REPL') .OR.
11967     1         (NUMARG.GE.2.AND.IHARG(1).EQ.'REPL'.AND.
11968     1         IHARG(2).EQ.'SIMP') .OR.
11969     1         (NUMARG.GE.1.AND.IHARG(1).EQ.'SIMP'))THEN
11970          CALL DPRESZ(IHARG,IARGT,IARG,NUMARG,IDEFR8,IRECR2,
11971     1                IFOUND,IERROR)
11972          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11973C
11974CCCCC FOLLOWING SECTION ADDED APRIL 1998.
11975C               ******************************************************
11976C               **  TREAT THE RECIPE FIT   FACTORS             CASE **
11977C               ******************************************************
11978C
11979        ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'FIT '.AND.
11980     1         IHARG(2).EQ.'FACT')THEN
11981          CALL DPREFF(IHARG,IARGT,ARG,NUMARG,DEFRFF,RECIFF,
11982     1                IFOUND,IERROR)
11983          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11984        ENDIF
11985C
11986      ENDIF
11987C
11988C               ********************************
11989C               **  TREAT THE AUTO TEXT CASE  **
11990C               ********************************
11991C
11992      IF(ICOM.EQ.'AUTO'.AND.
11993     1   NUMARG.GE.1.AND.IHARG(1).EQ.'TEXT')THEN
11994        CALL DPAUTX(IHARG,NUMARG,IATXSW,IFOUND,IERROR)
11995        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
11996      ENDIF
11997C
11998C
11999C               *****************
12000C               **  STEP 90--  **
12001C               **  EXIT       **
12002C               *****************
12003C
12004 9000 CONTINUE
12005C
12006      IERRST=IERROR
12007C
12008C     AUGUST 2007.  CHECK FOR FATAL ERROR
12009C
12010      IF(IERROR.EQ.'YES')THEN
12011        ISUBN1='MAIN'
12012        ISUBN2='SU  '
12013        ICASE2='SUPP'
12014        CALL DPERRO(IERRFA,IANSLC,IWIDTH,IGUIFL,
12015     1              ISUBN1,ISUBN2,ICASE2,
12016     1              IBUGS2,ISUBRO,IERROR)
12017      ENDIF
12018C
12019C
12020      IF(IBUGSU.EQ.'ON'.OR.ISUBRO.EQ.'INSU')THEN
12021        WRITE(ICOUT,999)
12022        CALL DPWRST('XXX','BUG ')
12023        WRITE(ICOUT,9011)
12024 9011   FORMAT('***** AT THE END       OF MAINSU--')
12025        CALL DPWRST('XXX','BUG ')
12026        WRITE(ICOUT,9022)IFOUND,IERROR
12027 9022   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
12028        CALL DPWRST('XXX','BUG ')
12029      ENDIF
12030C
12031      RETURN
12032      END
12033      SUBROUTINE MAKCDF(X,XI,LAMBDA,THETA,CDF)
12034C
12035C     THIS SUBROUTINE COMPUTES THE GOMPERTZ-MAKEHAM CUMULATIVE
12036C     DISTRIBUTION FUNCTION. IT HAS THE FOLLOWING CDF:
12037C         F(X,XI,LAMBDA,THETA) = 1 -
12038C                EXP[-XI*(EXP(LAMBDA*X) -1) - XI*THETA*LAMBDA*X)
12039C                X > 0; LAMBDA, XI > 0, THETA >= 0
12040C     NOTE THAT THIS IS THE PARAMETERIZATION USED BY THE DIGITAL
12041C     LIBRARY OF MATHEMATICAL FUNCTIONS (DLMF).  TO USE THE
12042C     PARAMETERIZATION GIVEN ON PAGE 108-109 OF MEEKER AND ESCOBAR,
12043C     DO THE FOLLOWING BEFORE CALLING THIS ROUTINE:
12044C
12045C         XI(DLMF) = GAMMA(MEEKER)/K(MEEKER)
12046C         LAMBDA(DLMF) = K(MEEKER)
12047C         THETA(DLMF) = LAMBDA(MEEKER)/GAMMA(MEEKER)
12048C
12049C     WRITTEN BY--JAMES J. FILLIBEN
12050C                 STATISTICAL ENGINEERING DIVISION
12051C                 INFORMATION TECHNOLOGY LABORATORY
12052C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
12053C                 GAITHERSBURG, MD 20899-8980
12054C                 PHONE--301-975-2855
12055C     REFERENCE--"STATISTICAL METHODS FOR RELIABILITY DATA",
12056C                MEEKER AND ESCOBAR, WILEY, 1998, PP. 108-109.
12057C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
12058C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
12059C     LANGUAGE--ANSI FORTRAN (1977)
12060C     VERSION NUMBER--2003/12
12061C     ORIGINAL VERSION--DECEMBER  2003.
12062C
12063C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
12064C
12065      REAL LAMBDA
12066C
12067      DOUBLE PRECISION DCDF
12068      DOUBLE PRECISION DXI
12069      DOUBLE PRECISION DLMBDA
12070      DOUBLE PRECISION DTHETA
12071      DOUBLE PRECISION DX
12072      DOUBLE PRECISION DTERM1
12073C
12074C---------------------------------------------------------------------
12075C
12076      INCLUDE 'DPCOP2.INC'
12077C
12078C-----START POINT-----------------------------------------------------
12079C
12080      CDF=0.0
12081      IF(X.LE.0.0)GOTO9999
12082      IF(XI.LE.0.0)THEN
12083        WRITE(ICOUT,101)
12084        CALL DPWRST('XXX','BUG ')
12085        WRITE(ICOUT,102)XI
12086        CALL DPWRST('XXX','BUG ')
12087        GOTO9999
12088      ENDIF
12089      IF(LAMBDA.LE.0.0)THEN
12090        WRITE(ICOUT,106)
12091        CALL DPWRST('XXX','BUG ')
12092        WRITE(ICOUT,107)LAMBDA
12093        CALL DPWRST('XXX','BUG ')
12094        GOTO9999
12095      ENDIF
12096      IF(THETA.LT.0.0)THEN
12097        WRITE(ICOUT,111)
12098        CALL DPWRST('XXX','BUG ')
12099        WRITE(ICOUT,112)THETA
12100        CALL DPWRST('XXX','BUG ')
12101        GOTO9999
12102      ENDIF
12103  101 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER (XI) TO MAKCDF')
12104  102 FORMAT('      IS NON-POSITIVE.  IT HAS THE VALUE ',E15.7)
12105  106 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER (LAMBDA) TO')
12106  107 FORMAT('      MAKCDF IS NON-POSITIVE.  IT HAS THE VALUE ',E15.7)
12107  111 FORMAT('***** ERROR--THE THIRD SHAPE PARAMETER (THETA) TO')
12108  112 FORMAT('      MAKCDF IS NEGATIVE.  IT HAS THE VALUE ',E15.7)
12109C
12110      DX=DBLE(X)
12111      DXI=DBLE(XI)
12112      DLMBDA=DBLE(LAMBDA)
12113      DTHETA=DBLE(THETA)
12114C
12115      DTERM1=-DXI*(DEXP(DLMBDA*DX) - 1.0D0) - DXI*DLMBDA*DTHETA*DX
12116C
12117      IF(DTERM1.LE.-80.D0)THEN
12118        CDF=1.0
12119        GOTO9999
12120      ELSEIF(DTERM1.GE.80.D0)THEN
12121        CDF=0.0
12122        WRITE(ICOUT,401)
12123        CALL DPWRST('XXX','BUG ')
12124        GOTO9999
12125      ELSE
12126        DCDF=1.0D0 - DEXP(DTERM1)
12127        CDF=REAL(DCDF)
12128      ENDIF
12129  401 FORMAT('***** NON-FATAL DIAGNOSTIC FROM MAKCDF.  THE COMPUTED ',
12130     1'CDF VALUE EXCEEDS MACHINE PRECISION.')
12131C
12132 9999 CONTINUE
12133      RETURN
12134      END
12135      REAL FUNCTION MAKFU2(X)
12136C
12137C     PURPOSE--MAKPPF CALLS FZERO TO FIND A ROOT FOR THE PERCENT
12138C              POINT FUNCTION.  MAKFU2 IS THE FUNCTION FOR WHICH
12139C              THE ZERO IS FOUND.  IT IS:
12140C                 P - MAKCDF(X,XI,LAMBDA,THETA)
12141C              WHERE P IS THE DESIRED PERCENT POINT.
12142C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
12143C                                WHICH THE CUMULATIVE DISTRIBUTION
12144C                                FUNCTION IS TO BE EVALUATED.
12145C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
12146C             FUNCTION VALUE MAKFU2.
12147C     PRINTING--NONE.
12148C     RESTRICTIONS--NONE.
12149C     OTHER DATAPAC   SUBROUTINES NEEDED--MAKCDF.
12150C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
12151C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
12152C     LANGUAGE--ANSI FORTRAN (1977)
12153C     REFERENCE--"STATISTICAL METHODS FOR RELIABILITY DATA",
12154C                MEEKER AND ESCOBAR, WILEY, 1998, PP. 108-109.
12155C     WRITTEN BY--JAMES J. FILLIBEN
12156C                 STATISTICAL ENGINEERING DIVISION
12157C                 INFORMATION TECHNOLOGY LABORATORY
12158C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
12159C                 GAITHERSBURG, MD 20899-8980
12160C                 PHONE--301-975-2855
12161C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
12162C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
12163C     LANGUAGE--ANSI FORTRAN (1977)
12164C     VERSION NUMBER--2003.12
12165C     ORIGINAL VERSION--DECEMBER  2003.
12166C
12167C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
12168C
12169C---------------------------------------------------------------------
12170C
12171      REAL P
12172      COMMON/MA2COM/P
12173C
12174      REAL XI
12175      REAL LAMBDA
12176      REAL THETA
12177      COMMON/MAKCOM/XI,LAMBDA,THETA
12178C
12179C-----COMMON----------------------------------------------------------
12180C
12181      INCLUDE 'DPCOP2.INC'
12182C
12183C-----START POINT-----------------------------------------------------
12184C
12185      CALL MAKCDF(X,XI,LAMBDA,THETA,CDF)
12186      MAKFU2=P - CDF
12187      RETURN
12188      END
12189      SUBROUTINE MAKCHA(X,XI,LAMBDA,THETA,HAZ)
12190C
12191C     THIS SUBROUTINE COMPUTES THE GOMPERTZ-MAKEHAM CUMULATIVE
12192C     HAZARD FUNCTION WHICH HAS THE FOLLOWING FORMULA:
12193C         H(X,XI,LAMBDA,THETA) =
12194C                      -[-XI*(EXP(LAMBDA*X) - 1) - XI*THETA*LAMBDA*X]
12195C                X > 0; LAMBDA, XI > 0, THETA >= 0
12196C     NOTE THAT THIS IS THE PARAMETERIZATION USED BY THE DIGITAL
12197C     LIBRARY OF MATHEMATICAL FUNCTIONS (DLMF).  TO USE THE
12198C     PARAMETERIZATION GIVEN ON PAGE 108-109 OF MEEKER AND ESCOBAR,
12199C     DO THE FOLLOWING BEFORE CALLING THIS ROUTINE:
12200C
12201C         XI(DLMF) = GAMMA(MEEKER)/K(MEEKER)
12202C         LAMBDA(DLMF) = K(MEEKER)
12203C         THETA(DLMF) = LAMBDA(MEEKER)/GAMMA(MEEKER)
12204C
12205C     WRITTEN BY--JAMES J. FILLIBEN
12206C                 STATISTICAL ENGINEERING DIVISION
12207C                 INFORMATION TECHNOLOGY LABORATORY
12208C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
12209C                 GAITHERSBURG, MD 20899-8980
12210C                 PHONE--301-975-2855
12211C     REFERENCE--"STATISTICAL METHODS FOR RELIABILITY DATA",
12212C                MEEKER AND ESCOBAR, WILEY, 1998, PP. 108-109.
12213C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
12214C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
12215C     LANGUAGE--ANSI FORTRAN (1977)
12216C     VERSION NUMBER--2004/7
12217C     ORIGINAL VERSION--JULY      2004.
12218C
12219C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
12220C
12221      REAL LAMBDA
12222C
12223      DOUBLE PRECISION DHAZ
12224      DOUBLE PRECISION DXI
12225      DOUBLE PRECISION DLMBDA
12226      DOUBLE PRECISION DTHETA
12227      DOUBLE PRECISION DX
12228C
12229C-----COMMON----------------------------------------------------------
12230C
12231      INCLUDE 'DPCOP2.INC'
12232C
12233C-----START POINT-----------------------------------------------------
12234C
12235      HAZ=0.0
12236      IF(X.LE.0.0)GOTO9999
12237      IF(XI.LE.0.0)THEN
12238        WRITE(ICOUT,101)
12239        CALL DPWRST('XXX','BUG ')
12240        WRITE(ICOUT,102)XI
12241        CALL DPWRST('XXX','BUG ')
12242        GOTO9999
12243      ENDIF
12244      IF(LAMBDA.LE.0.0)THEN
12245        WRITE(ICOUT,106)
12246        CALL DPWRST('XXX','BUG ')
12247        WRITE(ICOUT,107)LAMBDA
12248        CALL DPWRST('XXX','BUG ')
12249        GOTO9999
12250      ENDIF
12251      IF(THETA.LT.0.0)THEN
12252        WRITE(ICOUT,111)
12253        CALL DPWRST('XXX','BUG ')
12254        WRITE(ICOUT,112)THETA
12255        CALL DPWRST('XXX','BUG ')
12256        GOTO9999
12257      ENDIF
12258  101 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER (XI) TO MAKCHAZ')
12259  102 FORMAT('      IS NON-POSITIVE.  IT HAS THE VALUE ',E15.7)
12260  106 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER (LAMBDA) TO')
12261  107 FORMAT('      MAKCHAZ IS NON-POSITIVE.  IT HAS THE VALUE ',E15.7)
12262  111 FORMAT('***** ERROR--THE THIRD SHAPE PARAMETER (THETA) TO')
12263  112 FORMAT('      MAKCHAZ IS NEGATIVE.  IT HAS THE VALUE ',E15.7)
12264C
12265      DX=DBLE(X)
12266      DXI=DBLE(XI)
12267      DLMBDA=DBLE(LAMBDA)
12268      DTHETA=DBLE(THETA)
12269C
12270      DHAZ=-DXI*(DEXP(DLMBDA*DX) - 1.0D0) - DXI*DLMBDA*DTHETA*DX
12271      HAZ=-REAL(DHAZ)
12272C
12273 9999 CONTINUE
12274      RETURN
12275      END
12276      SUBROUTINE MAKHAZ(X,XI,LAMBDA,THETA,HAZ)
12277C
12278C     THIS SUBROUTINE COMPUTES THE GOMPERTZ-MAKEHAM
12279C     HAZARD FUNCTION WHICH HAS THE FOLLOWING FORMULA:
12280C         h(X,XI,LAMBDA,THETA) = f(X,XI,LAMBDA,THETA)/
12281C                                -LOG[1 - F(x,XI,LAMBDA,THETA)]
12282C                              = XI*THETA*LAMBDA + XI*LAMBDA*
12283C                                EXP(LAMBDA*X)
12284C                X > 0; LAMBDA, XI > 0, THETA >= 0
12285C         WHERE f IS THE PROBABILITY DENSITY AND F IS THE
12286C         CUMULATIVE DISTRIBUTION FUNCTION.
12287C
12288C     NOTE THAT THIS IS THE PARAMETERIZATION USED BY THE DIGITAL
12289C     LIBRARY OF MATHEMATICAL FUNCTIONS (DLMF).  TO USE THE
12290C     PARAMETERIZATION GIVEN ON PAGE 108-109 OF MEEKER AND ESCOBAR,
12291C     DO THE FOLLOWING BEFORE CALLING THIS ROUTINE:
12292C
12293C         XI(DLMF) = GAMMA(MEEKER)/K(MEEKER)
12294C         LAMBDA(DLMF) = K(MEEKER)
12295C         THETA(DLMF) = LAMBDA(MEEKER)/GAMMA(MEEKER)
12296C
12297C     WRITTEN BY--JAMES J. FILLIBEN
12298C                 STATISTICAL ENGINEERING DIVISION
12299C                 INFORMATION TECHNOLOGY LABORATORY
12300C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
12301C                 GAITHERSBURG, MD 20899-8980
12302C                 PHONE--301-975-2855
12303C     REFERENCE--"STATISTICAL METHODS FOR RELIABILITY DATA",
12304C                MEEKER AND ESCOBAR, WILEY, 1998, PP. 108-109.
12305C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
12306C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
12307C     LANGUAGE--ANSI FORTRAN (1977)
12308C     VERSION NUMBER--2004/7
12309C     ORIGINAL VERSION--JULY      2004.
12310C
12311C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
12312C
12313      REAL LAMBDA
12314C
12315      DOUBLE PRECISION DHAZ
12316      DOUBLE PRECISION DXI
12317      DOUBLE PRECISION DLMBDA
12318      DOUBLE PRECISION DTHETA
12319      DOUBLE PRECISION DX
12320      DOUBLE PRECISION DTERM1
12321      DOUBLE PRECISION DTERM2
12322C
12323C-----COMMON----------------------------------------------------------
12324C
12325      INCLUDE 'DPCOP2.INC'
12326C
12327C-----START POINT-----------------------------------------------------
12328C
12329      HAZ=0.0
12330      IF(X.LE.0.0)GOTO9999
12331      IF(XI.LE.0.0)THEN
12332        WRITE(ICOUT,101)
12333        CALL DPWRST('XXX','BUG ')
12334        WRITE(ICOUT,102)XI
12335        CALL DPWRST('XXX','BUG ')
12336        GOTO9999
12337      ENDIF
12338      IF(LAMBDA.LE.0.0)THEN
12339        WRITE(ICOUT,106)
12340        CALL DPWRST('XXX','BUG ')
12341        WRITE(ICOUT,107)LAMBDA
12342        CALL DPWRST('XXX','BUG ')
12343        GOTO9999
12344      ENDIF
12345      IF(THETA.LT.0.0)THEN
12346        WRITE(ICOUT,111)
12347        CALL DPWRST('XXX','BUG ')
12348        WRITE(ICOUT,112)THETA
12349        CALL DPWRST('XXX','BUG ')
12350        GOTO9999
12351      ENDIF
12352  101 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER (XI) TO MAKHAZZ')
12353  102 FORMAT('      IS NON-POSITIVE.  IT HAS THE VALUE ',E15.7)
12354  106 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER (LAMBDA) TO')
12355  107 FORMAT('      MAKHAZZ IS NON-POSITIVE.  IT HAS THE VALUE ',E15.7)
12356  111 FORMAT('***** ERROR--THE THIRD SHAPE PARAMETER (THETA) TO')
12357  112 FORMAT('      MAKHAZZ IS NEGATIVE.  IT HAS THE VALUE ',E15.7)
12358C
12359      DX=DBLE(X)
12360      DXI=DBLE(XI)
12361      DLMBDA=DBLE(LAMBDA)
12362      DTHETA=DBLE(THETA)
12363C
12364      DTERM1=DXI*DTHETA*DLMBDA
12365      DTERM2=DXI*DLMBDA*DEXP(DLMBDA*DX)
12366      DHAZ=DTERM1 + DTERM2
12367      HAZ=REAL(DHAZ)
12368      HAZ=REAL(DHAZ)
12369C
12370 9999 CONTINUE
12371      RETURN
12372      END
12373      SUBROUTINE MAKPDF(X,XI,LAMBDA,THETA,PDF)
12374C
12375C     THIS SUBROUTINE COMPUTES THE GOMPERTZ-MAKEHAM PROBABILITY
12376C     DENSITY FUNCTION. VALUE DISTRIBUTION.  IT HAS THE FOLLOWING
12377C     PDF:
12378C         F(X,XI,LAMBDA,THETA) = XI*LAMBDA*(THETA + EXP(LAMBDA*X))*
12379C                EXP[-XI*(EXP(LAMBDA*X) -1) - XI*THETA*LAMBDA*X)
12380C                X > 0; LAMBDA, XI > 0, THETA >= 0
12381C     NOTE THAT THIS IS THE PARAMETERIZATION USED BY THE DIGITAL
12382C     LIBRARY OF MATHEMATICAL FUNCTIONS (DLMF).  TO USE THE
12383C     PARAMETERIZATION GIVEN ON PAGE 108-109 OF MEEKER AND ESCOBAR,
12384C     DO THE FOLLOWING BEFORE CALLING THIS ROUTINE:
12385C
12386C         XI(DLMF) = GAMMA(MEEKER)/K(MEEKER)
12387C         LAMBDA(DLMF) = K(MEEKER)
12388C         THETA(DLMF) = LAMBDA(MEEKER)/GAMMA(MEEKER)
12389C
12390C     WRITTEN BY--JAMES J. FILLIBEN
12391C                 STATISTICAL ENGINEERING DIVISION
12392C         LAMBDA = THETA*LAMBDA*XI
12393C                 INFORMATION TECHNOLOGY LABORATORY
12394C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
12395C                 GAITHERSBURG, MD 20899-8980
12396C                 PHONE--301-975-2855
12397C     REFERENCE--"STATISTICAL METHODS FOR RELIABILITY DATA",
12398C                MEEKER AND ESCOBAR, WILEY, 1998, PP. 108-109.
12399C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
12400C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
12401C     LANGUAGE--ANSI FORTRAN (1977)
12402C     VERSION NUMBER--2003/12
12403C     ORIGINAL VERSION--DECEMBER  2003.
12404C
12405C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
12406C
12407      REAL LAMBDA
12408C
12409      DOUBLE PRECISION DPDF
12410      DOUBLE PRECISION DXI
12411      DOUBLE PRECISION DLMBDA
12412      DOUBLE PRECISION DTHETA
12413      DOUBLE PRECISION DX
12414      DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4
12415C
12416C-----COMMON----------------------------------------------------------
12417C
12418      INCLUDE 'DPCOP2.INC'
12419C
12420C-----START POINT-----------------------------------------------------
12421C
12422      PDF=0.0
12423      IF(X.LE.0.0)THEN
12424        WRITE(ICOUT,301)
12425        CALL DPWRST('XXX','BUG ')
12426        WRITE(ICOUT,302)X
12427        CALL DPWRST('XXX','BUG ')
12428        GOTO9999
12429      ENDIF
12430      IF(XI.LE.0.0)THEN
12431        WRITE(ICOUT,101)
12432        CALL DPWRST('XXX','BUG ')
12433        WRITE(ICOUT,102)XI
12434        CALL DPWRST('XXX','BUG ')
12435        GOTO9999
12436      ENDIF
12437      IF(LAMBDA.LE.0.0)THEN
12438        WRITE(ICOUT,106)
12439        CALL DPWRST('XXX','BUG ')
12440        WRITE(ICOUT,107)LAMBDA
12441        CALL DPWRST('XXX','BUG ')
12442        GOTO9999
12443      ENDIF
12444      IF(THETA.LT.0.0)THEN
12445        WRITE(ICOUT,111)
12446        CALL DPWRST('XXX','BUG ')
12447        WRITE(ICOUT,112)THETA
12448        CALL DPWRST('XXX','BUG ')
12449        GOTO9999
12450      ENDIF
12451  101 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER (XI) TO MAKPDF')
12452  102 FORMAT('      IS NON-POSITIVE.  IT HAS THE VALUE ',E15.7)
12453  106 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER (LAMBDA) TO')
12454  107 FORMAT('      MAKPDF IS NON-POSITIVE.  IT HAS THE VALUE ',E15.7)
12455  111 FORMAT('***** ERROR--THE THIRD SHAPE PARAMETER (THETA) TO')
12456  112 FORMAT('      MAKPDF IS NEGATIVE.  IT HAS THE VALUE ',E15.7)
12457  301 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO MAKPDF IS')
12458  302 FORMAT('      NON-POSITIVE.  IT HAS THE VALUE ',E15.7)
12459C
12460      DX=DBLE(X)
12461      DXI=DBLE(XI)
12462      DLMBDA=DBLE(LAMBDA)
12463      DTHETA=DBLE(THETA)
12464C
12465      DTERM1=DLOG(DXI) + DLOG(DLMBDA)
12466      DTERM2=DLOG(DTHETA + DEXP(DLMBDA*DX))
12467      DTERM3=-DXI*(DEXP(DLMBDA*DX) - 1.0D0) - DXI*DLMBDA*DTHETA*DX
12468      DTERM4=DTERM1 + DTERM2 + DTERM3
12469C
12470      IF(DTERM4.LE.-80.D0)THEN
12471        PDF=0.0
12472        GOTO9999
12473      ELSEIF(DTERM4.GE.80.D0)THEN
12474        PDF=0.0
12475        WRITE(ICOUT,401)
12476        CALL DPWRST('XXX','BUG ')
12477        GOTO9999
12478      ENDIF
12479  401 FORMAT('***** NON-FATAL DIAGNOSTIC FROM MAKPDF.  THE COMPUTED ',
12480     1'PDF VALUE EXCEEDS MACHINE PRECISION.')
12481C
12482      DPDF=DEXP(DTERM4)
12483      PDF=REAL(DPDF)
12484C
12485 9999 CONTINUE
12486      RETURN
12487      END
12488      SUBROUTINE MAKPPF(P,XI,LAMBDA,THETA,PPF)
12489C
12490C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
12491C              FUNCTION VALUE FOR THE GOMPERTZ-MAKEHAM DISTRIBUTION
12492C              WITH SHAPE PARAMETERS XI, LAMBDA, AND THETA.
12493C              THIS DISTRIBUTION IS DEFINED FOR POSITIVE X AND THE
12494C              PERCENT POINT FUNCTION IS COMPUTED BY
12495C              NUMERICALLY INVERTING THE CDF FUNCTION.
12496C
12497C     NOTE THAT THIS IS THE PARAMETERIZATION USED BY THE DIGITAL
12498C     LIBRARY OF MATHEMATICAL FUNCTIONS (DLMF).  TO USE THE
12499C     PARAMETERIZATION GIVEN ON PAGE 108-109 OF MEEKER AND ESCOBAR,
12500C     DO THE FOLLOWING BEFORE CALLING THIS ROUTINE:
12501C
12502C         XI(DLMF) = GAMMA(MEEKER)/K(MEEKER)
12503C         LAMBDA(DLMF) = K(MEEKER)
12504C         THETA(DLMF) = LAMBDA(MEEKER)/GAMMA(MEEKER)
12505C
12506C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE AT
12507C                                WHICH THE PERCENT POINT
12508C                                FUNCTION IS TO BE EVALUATED.
12509C                     --XI     = THE FIRST SHAPE PARAMETER
12510C                     --LAMBDA = THE SECOND SHAPE PARAMETER
12511C                     --THETA  = THE THIRD SHAPE PARAMETER
12512C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION CUMULATIVE
12513C                                DISTRIBUTION FUNCTION VALUE.
12514C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
12515C             FUNCTION VALUE PPF.
12516C     PRINTING--NONE.
12517C     RESTRICTIONS--NONE.
12518C     OTHER DATAPAC   SUBROUTINES NEEDED--FZERO.
12519C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
12520C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
12521C     LANGUAGE--ANSI FORTRAN (1977)
12522C     REFERENCE--"STATISTICAL METHODS FOR RELIABILITY DATA",
12523C                MEEKER AND ESCOBAR, WILEY, 1998, PP. 108-109.
12524C     WRITTEN BY--JAMES J. FILLIBEN
12525C                 STATISTICAL ENGINEERING DIVISION
12526C                 INFORMATION TECHNOLOGY LABORATORY
12527C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
12528C                 GAITHERSBURG, MD 20899-8980
12529C                 PHONE--301-975-2855
12530C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
12531C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
12532C     LANGUAGE--ANSI FORTRAN (1977)
12533C     VERSION NUMBER--2003.12
12534C     ORIGINAL VERSION--DECEMBER  2003.
12535C
12536C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
12537C
12538C---------------------------------------------------------------------
12539C
12540      REAL LAMBDA
12541      REAL PPF
12542C
12543      REAL MAKFU2
12544      EXTERNAL MAKFU2
12545C
12546      REAL P2
12547      COMMON/MA2COM/P2
12548C
12549      REAL XI2
12550      REAL LAMBD2
12551      REAL THETA2
12552      COMMON/MAKCOM/XI2,LAMBD2,THETA2
12553C
12554      INCLUDE 'DPCOP2.INC'
12555C
12556C-----START POINT-----------------------------------------------------
12557C
12558C               ********************************************
12559C               **  STEP 1--                              **
12560C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
12561C               ********************************************
12562C
12563      PPF=0.0
12564C
12565      IF(P.LT.0.0.OR.P.GE.1.0)THEN
12566         WRITE(ICOUT,61)
12567   61    FORMAT('***** ERROR--THE FIRST  INPUT ARGUMENT ',
12568     1          'TO THE MAKPPF SUBROUTINE ')
12569         CALL DPWRST('XXX','BUG ')
12570         WRITE(ICOUT,62)
12571   62    FORMAT('      IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL ***')
12572         CALL DPWRST('XXX','BUG ')
12573         WRITE(ICOUT,63)P
12574   63    FORMAT('      VALUE OF ARGUMENT = ',G15.7)
12575         CALL DPWRST('XXX','BUG ')
12576         PPF=0.0
12577         GOTO9000
12578      ENDIF
12579C
12580      IF(XI.LE.0.0)THEN
12581        WRITE(ICOUT,101)
12582        CALL DPWRST('XXX','BUG ')
12583        WRITE(ICOUT,102)XI
12584        CALL DPWRST('XXX','BUG ')
12585        GOTO9000
12586      ENDIF
12587      IF(LAMBDA.LE.0.0)THEN
12588        WRITE(ICOUT,106)
12589        CALL DPWRST('XXX','BUG ')
12590        WRITE(ICOUT,107)LAMBDA
12591        CALL DPWRST('XXX','BUG ')
12592        GOTO9000
12593      ENDIF
12594      IF(THETA.LT.0.0)THEN
12595        WRITE(ICOUT,111)
12596        CALL DPWRST('XXX','BUG ')
12597        WRITE(ICOUT,112)THETA
12598        CALL DPWRST('XXX','BUG ')
12599        GOTO9000
12600      ENDIF
12601  101 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER (XI) TO MAKPPF')
12602  102 FORMAT('      IS NON-POSITIVE.  IT HAS THE VALUE ',E15.7)
12603  106 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER (LAMBDA) TO')
12604  107 FORMAT('      MAKPPF IS NON-POSITIVE.  IT HAS THE VALUE ',E15.7)
12605  111 FORMAT('***** ERROR--THE THIRD SHAPE PARAMETER (THETA) TO')
12606  112 FORMAT('      MAKPPF IS NEGATIVE.  IT HAS THE VALUE ',E15.7)
12607C
12608      IF(P.EQ.0.0)THEN
12609        PPF=0.0
12610        GOTO9000
12611      ENDIF
12612C
12613C  STEP 1: FIND BRACKETING INTERVAL.  LOWER BOUND IS ZERO.  START WITH
12614C          10 AS GUESS FOR UPPER BOUND.  MULTIPLY BY 10 UNTIL
12615C          BRACKETING INTERVAL FOUND.
12616C
12617      XLOW=0.0000001
12618      XUP2=10.0
12619  200 CONTINUE
12620        CALL MAKCDF(XUP2,XI,LAMBDA,THETA,PTEMP)
12621        IF(PTEMP.GT.P)THEN
12622          XUP=XUP2
12623        ELSE
12624          XUP2=XUP2*10.0
12625          IF(XUP2.GT.CPUMAX/100.)THEN
12626            WRITE(ICOUT,201)
12627  201       FORMAT('***** ERROR FROM MAKPPF--UNABLE TO FIND A ',
12628     1             'BRACKETING INTERVAL')
12629            CALL DPWRST('XXX','BUG ')
12630            GOTO9000
12631          ENDIF
12632          GOTO200
12633        ENDIF
12634C
12635      AE=1.E-6
12636      RE=1.E-6
12637      P2=P
12638      XI2=XI
12639      LAMBD2=LAMBDA
12640      THETA2=THETA
12641      CALL FZERO(MAKFU2,XLOW,XUP,XUP,RE,AE,IFLAG)
12642C
12643      PPF=XLOW
12644C
12645      IF(IFLAG.EQ.2)THEN
12646C
12647C  NOTE: SUPPRESS THIS MESSAGE FOR NOW.
12648CCCCC   WRITE(ICOUT,999)
12649  999   FORMAT(1X)
12650CCCCC   CALL DPWRST('XXX','BUG ')
12651CCCCC   WRITE(ICOUT,111)
12652CC111   FORMAT('***** WARNING FROM MAKPPF--')
12653CCCCC   CALL DPWRST('XXX','BUG ')
12654CCCCC   WRITE(ICOUT,113)
12655CC113   FORMAT('      PPF VALUE MAY NOT BE COMPUTED TO DESIRED ',
12656CCCCC1         'TOLERANCE.')
12657CCCCC   CALL DPWRST('XXX','BUG ')
12658      ELSEIF(IFLAG.EQ.3)THEN
12659        WRITE(ICOUT,999)
12660        CALL DPWRST('XXX','BUG ')
12661        WRITE(ICOUT,121)
12662  121   FORMAT('***** WARNING FROM MAKPPF--')
12663        CALL DPWRST('XXX','BUG ')
12664        WRITE(ICOUT,123)
12665  123   FORMAT('      PPF VALUE MAY BE NEAR A SINGULAR POINT.')
12666        CALL DPWRST('XXX','BUG ')
12667      ELSEIF(IFLAG.EQ.4)THEN
12668        WRITE(ICOUT,999)
12669        CALL DPWRST('XXX','BUG ')
12670        WRITE(ICOUT,131)
12671  131   FORMAT('***** ERROR FROM MAKPPF--')
12672        CALL DPWRST('XXX','BUG ')
12673        WRITE(ICOUT,133)
12674  133   FORMAT('      APPROPRIATE BRACKETING INTERVAL NOT FOUND.')
12675        CALL DPWRST('XXX','BUG ')
12676      ELSEIF(IFLAG.EQ.5)THEN
12677        WRITE(ICOUT,999)
12678        CALL DPWRST('XXX','BUG ')
12679        WRITE(ICOUT,141)
12680  141   FORMAT('***** WARNING FROM MAKPPF--')
12681        CALL DPWRST('XXX','BUG ')
12682        WRITE(ICOUT,143)
12683  143   FORMAT('      MAXIMUM ITERATIONS EXCEEDED.')
12684        CALL DPWRST('XXX','BUG ')
12685      ENDIF
12686C
12687 9000 CONTINUE
12688      RETURN
12689      END
12690      SUBROUTINE MAKRAN(N,XI,LAMBDA,THETA,ISEED,X)
12691C
12692C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
12693C              FROM THE THE GOMPERTZ-MAKEHAM DISTIBUTION WITH
12694C              LOCATION = 0 AND SCALE = 1.  THIS DISTRIBUTION IS
12695C              DEFINED FOR POSITIVE X AND HAS THE PROBABILITY DENSITY
12696C              FUNCTION:
12697C              F(X,XI,LAMBDA,THETA) = XI*LAMBDA*(THETA + EXP(LAMBDA*X))
12698C                *EXP[-XI*(EXP(LAMBDA*X) -1) - XI*THETA*LAMBDA*X)
12699C                X > 0; LAMBDA, XI > 0, THETA >= 0
12700C              XI, LAMBDA, AND THETA ARE SHAPE PARAMETERS.
12701C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
12702C                                OF RANDOM NUMBERS TO BE
12703C                                GENERATED.
12704C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
12705C                                (OF DIMENSION AT LEAST N)
12706C                                INTO WHICH THE GENERATED
12707C                                RANDOM SAMPLE WILL BE PLACED.
12708C                     --XI     = A SINGLE PRECISON SCALAR THAT DEFINES
12709C                                THE FIRST SHAPE PARAMETER.
12710C                     --LAMBDA = A SINGLE PRECISON SCALAR THAT DEFINES
12711C                                THE SECOND SHAPE PARAMETER.
12712C                     --THETA  = A SINGLE PRECISON SCALAR THAT DEFINES
12713C                                THE THIRD SHAPE PARAMETER.
12714C     OUTPUT--A RANDOM SAMPLE OF SIZE N FROM THE COMPERTZ-MAKEHAM
12715C             DISTRIBUTION WITH LOCATION = 0 AND SCALE = 1.
12716C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
12717C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
12718C                   OF N FOR THIS SUBROUTINE.
12719C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, MAKPPF.
12720C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
12721C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
12722C     LANGUAGE--ANSI FORTRAN (1977)
12723C     METHOD--TRANSFORM NORMAL RANDOM NUMBERS
12724C     REFERENCE--"STATISTICAL METHODS FOR RELIABILITY DATA",
12725C                MEEKER AND ESCOBAR, WILEY, 1998, PP. 108-109.
12726C     WRITTEN BY--JAMES J. FILLIBEN
12727C                 STATISTICAL ENGINEERING DIVISION
12728C                 INFORMATION TECHNOLOGY LABORATORY
12729C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
12730C                 GAITHERSBURG, MD 20899-8980
12731C                 PHONE--301-975-2855
12732C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
12733C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
12734C     LANGUAGE--ANSI FORTRAN (1966)
12735C     VERSION NUMBER--2003.12
12736C     ORIGINAL VERSION--DECEMBER  2003.
12737C
12738C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
12739C
12740C---------------------------------------------------------------------
12741C
12742      DIMENSION X(*)
12743      REAL XI
12744      REAL THETA
12745      REAL LAMBDA
12746C
12747C---------------------------------------------------------------------
12748C
12749      INCLUDE 'DPCOP2.INC'
12750C
12751C-----START POINT-----------------------------------------------------
12752C
12753C     CHECK THE INPUT ARGUMENTS FOR ERRORS
12754C
12755      IF(N.LT.1)THEN
12756        WRITE(ICOUT, 5)
12757        CALL DPWRST('XXX','BUG ')
12758        WRITE(ICOUT,47)N
12759        CALL DPWRST('XXX','BUG ')
12760        GOTO9999
12761      ELSEIF(XI.LE.0.0)THEN
12762        WRITE(ICOUT, 6)
12763        CALL DPWRST('XXX','BUG ')
12764        WRITE(ICOUT,48)XI
12765        CALL DPWRST('XXX','BUG ')
12766        GOTO9999
12767      ELSEIF(LAMBDA.LE.0.0)THEN
12768        WRITE(ICOUT, 7)
12769        CALL DPWRST('XXX','BUG ')
12770        WRITE(ICOUT,48)LAMBDA
12771        CALL DPWRST('XXX','BUG ')
12772        GOTO9999
12773      ELSEIF(THETA.LT.0.0)THEN
12774        WRITE(ICOUT,8)
12775        CALL DPWRST('XXX','BUG ')
12776        WRITE(ICOUT,48)THETA
12777        CALL DPWRST('XXX','BUG ')
12778        GOTO9999
12779      ENDIF
12780    5 FORMAT('***** FATAL ERROR--THE FIRST (N) INPUT ARGUMENT TO THE ',
12781     1'MAKRAN SUBROUTINE IS NON-POSITIVE *****')
12782    6 FORMAT('***** FATAL ERROR--THE SECOND (XI) INPUT ARGUMENT TO ',
12783     1'THE MAKRAN SUBROUTINE IS NON-POSITIVE *****')
12784    7 FORMAT('***** FATAL ERROR--THE THIRD (LAMBDA) INPUT ARGUMENT ',
12785     1'TO THE MAKRAN SUBROUTINE IS NON-POSITIVE *****')
12786    8 FORMAT('***** FATAL ERROR--THE FOURTH (THETA) INPUT ARGUMENT ',
12787     1'TO THE MAKRAN SUBROUTINE IS NEGATIVE *****')
12788   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
12789   48 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',F15.7,' *****')
12790C
12791C     GENERATE N UNIFORM NUMBERS;
12792C
12793      CALL UNIRAN(N,ISEED,X)
12794C
12795C     GENERATE N GOMPERTZ-MAKEHAM RANDON NUMBERS USING THE
12796C     PERCENT POINT FUNCTION TRANSFORMATION.
12797C
12798      DO100I=1,N
12799        XTEMP=X(I)
12800        CALL MAKPPF(XTEMP,XI,LAMBDA,THETA,PPF)
12801        X(I)=PPF
12802  100 CONTINUE
12803C
12804 9999 CONTINUE
12805      RETURN
12806      END
12807      SUBROUTINE MA2CDF(X,ZETA,ETA,CDF)
12808C
12809C     THIS SUBROUTINE COMPUTES THE GOMPERTZ-MAKEHAM CUMULATIVE
12810C     DISTRIBUTION FUNCTION. THIS USES THE MEEKER AND ESCOBAR
12811C     PARAMETERIZATION (THIS TAKES THE 3-SHAPE PARAMETER CASE AND
12812C     RE-PARAMETERRIZES IT TO 2-SHAPE PARAMETERS AND A SCALE
12813C     PARAMETER.  IT HAS THE FOLLOWING CDF:
12814C         F(X,ZETA,ETA) = 1 - EXP[C1 - EXP(C2) - C3]
12815C                X,  > 0; ETA >= 0
12816C     WITH
12817C         C1 = EXP(-ZETA)
12818C         C2 = EXP(LOG(X)) - ZETA
12819C            = X - ZETA
12820C         C3 = ETA*EXP(LOG(X))
12821C            = ETA*X
12822C
12823C     PUTTING THIS TOGETHER GIVES
12824C         F(X,ZETA,ETA) = 1 - EXP[EXP(-ZETA) - EXP(X-ZETA) - ETA*X]
12825C                X,  > 0; ETA >= 0
12826C
12827C     WRITTEN BY--JAMES J. FILLIBEN
12828C                 STATISTICAL ENGINEERING DIVISION
12829C                 INFORMATION TECHNOLOGY LABORATORY
12830C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
12831C                 GAITHERSBURG, MD 20899-8980
12832C                 PHONE--301-975-2855
12833C     REFERENCE--"STATISTICAL METHODS FOR RELIABILITY DATA",
12834C                MEEKER AND ESCOBAR, WILEY, 1998, PP. 108-109.
12835C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
12836C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
12837C     LANGUAGE--ANSI FORTRAN (1977)
12838C     VERSION NUMBER--2004/7
12839C     ORIGINAL VERSION--JULY      2004.
12840C
12841C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
12842C
12843      REAL ZETA
12844      REAL ETA
12845C
12846      DOUBLE PRECISION DCDF
12847      DOUBLE PRECISION DETA
12848      DOUBLE PRECISION DZETA
12849      DOUBLE PRECISION DX
12850      DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4
12851C
12852C---------------------------------------------------------------------
12853C
12854      INCLUDE 'DPCOP2.INC'
12855C
12856C-----START POINT-----------------------------------------------------
12857C
12858      CDF=0.0
12859      IF(X.LE.0.0)GOTO9000
12860CCCCC IF(ETA.LE.0.0)THEN
12861CCCCC   WRITE(ICOUT,101)
12862CCCCC   CALL DPWRST('XXX','BUG ')
12863CCCCC   WRITE(ICOUT,102)ETA
12864CCCCC   CALL DPWRST('XXX','BUG ')
12865CCCCC   GOTO9000
12866CCCCC ENDIF
12867      IF(ETA.LT.0.0)THEN
12868        WRITE(ICOUT,106)
12869        CALL DPWRST('XXX','BUG ')
12870        WRITE(ICOUT,107)ZETA
12871        CALL DPWRST('XXX','BUG ')
12872        GOTO9000
12873      ENDIF
12874CC101 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER (ETA) TO MA2CDF')
12875CC102 FORMAT('      IS NON-POSITIVE.  IT HAS THE VALUE ',E15.7)
12876  106 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER (ZETA) TO')
12877  107 FORMAT('      MAKCDF IS NEGATIVE.  IT HAS THE VALUE ',E15.7)
12878C
12879      DX=DBLE(X)
12880      DETA=DBLE(ETA)
12881      DZETA=DBLE(ZETA)
12882C
12883      DTERM1=DEXP(-DZETA)
12884      DTERM2=DEXP(DX - DZETA)
12885      DTERM3=DETA*DX
12886      DTERM4=DTERM1 - DTERM2 - DTERM3
12887C
12888      IF(DTERM4.LE.-80.D0)THEN
12889        CDF=1.0
12890      ELSEIF(DTERM4.GE.80.D0)THEN
12891        CDF=0.0
12892        WRITE(ICOUT,401)
12893        CALL DPWRST('XXX','BUG ')
12894      ELSE
12895        DCDF=1.0D0 - DEXP(DTERM4)
12896        CDF=REAL(DCDF)
12897      ENDIF
12898  401 FORMAT('***** NON-FATAL DIAGNOSTIC FROM MAKCDF.  THE ',
12899     1'COMPUTED CDF VALUE EXCEEDS MACHINE PRECISION.')
12900C
12901 9000 CONTINUE
12902      RETURN
12903      END
12904      REAL FUNCTION MA2FU2(X)
12905C
12906C     PURPOSE--MA2PPF CALLS FZERO TO FIND A ROOT FOR THE PERCENT
12907C              POINT FUNCTION.  MA2FU2 IS THE FUNCTION FOR WHICH
12908C              THE ZERO IS FOUND.  IT IS:
12909C                 P - MA2CDF(X,ZETA,ETA)
12910C              WHERE P IS THE DESIRED PERCENT POINT.
12911C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
12912C                                WHICH THE CUMULATIVE DISTRIBUTION
12913C                                FUNCTION IS TO BE EVALUATED.
12914C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
12915C             FUNCTION VALUE MA2FU2.
12916C     PRINTING--NONE.
12917C     RESTRICTIONS--NONE.
12918C     OTHER DATAPAC   SUBROUTINES NEEDED--MA2CDF.
12919C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
12920C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
12921C     LANGUAGE--ANSI FORTRAN (1977)
12922C     REFERENCE--"STATISTICAL METHODS FOR RELIABILITY DATA",
12923C                MEEKER AND ESCOBAR, WILEY, 1998, PP. 108-109.
12924C     WRITTEN BY--JAMES J. FILLIBEN
12925C                 STATISTICAL ENGINEERING DIVISION
12926C                 INFORMATION TECHNOLOGY LABORATORY
12927C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
12928C                 GAITHERSBURG, MD 20899-8980
12929C                 PHONE--301-975-2855
12930C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
12931C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
12932C     LANGUAGE--ANSI FORTRAN (1977)
12933C     VERSION NUMBER--2004.7
12934C     ORIGINAL VERSION--JULY      2004.
12935C
12936C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
12937C
12938C---------------------------------------------------------------------
12939C
12940      REAL P
12941      COMMON/MA4COM/P
12942C
12943      REAL ETA
12944      REAL ZETA
12945      COMMON/MA3COM/ETA,ZETA
12946C
12947      INCLUDE 'DPCOP2.INC'
12948C
12949C-----START POINT-----------------------------------------------------
12950C
12951      CALL MA2CDF(X,ZETA,ETA,CDF)
12952      MA2FU2=P - CDF
12953      RETURN
12954      END
12955      SUBROUTINE MA2CHA(X,ZETA,ETA,CHAZ)
12956C
12957C     THIS SUBROUTINE COMPUTES THE GOMPERTZ-MAKEHAM CUMULATIVE
12958C     HAZARD FUNCTION. THIS USES THE MEEKER AND ESCOBAR
12959C     PARAMETERIZATION (THIS TAKES THE 3-SHAPE PARAMETER CASE AND
12960C     RE-PARAMETERRIZES IT TO 2-SHAPE PARAMETERS AND A SCALE
12961C     PARAMETER.  IT HAS THE FOLLOWING CDF:
12962C         F(X,ZETA,ETA) = 1 -
12963C                         EXP[EXP(-ZETA) - EXP(X - ZETA) - ETA*X]
12964C                X,  > 0; ETA >= 0
12965C     THE CUMULATIVE HAZARD IS:
12966C         H(X,ZETA,ETA) = -LOG(1 - F(X,ZETA,ETA))
12967C                        = -EXP(-ZETA) + EXP(X-ZETA) + ETA*X
12968C
12969C     WRITTEN BY--JAMES J. FILLIBEN
12970C                 STATISTICAL ENGINEERING DIVISION
12971C                 INFORMATION TECHNOLOGY LABORATORY
12972C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
12973C                 GAITHERSBURG, MD 20899-8980
12974C                 PHONE--301-975-2855
12975C     REFERENCE--"STATISTICAL METHODS FOR RELIABILITY DATA",
12976C                MEEKER AND ESCOBAR, WILEY, 1998, PP. 108-109.
12977C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
12978C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
12979C     LANGUAGE--ANSI FORTRAN (1977)
12980C     VERSION NUMBER--2004/7
12981C     ORIGINAL VERSION--JULY      2004.
12982C
12983C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
12984C
12985      REAL ZETA
12986      REAL ETA
12987C
12988      DOUBLE PRECISION DETA
12989      DOUBLE PRECISION DZETA
12990      DOUBLE PRECISION DX
12991      DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4
12992C
12993C---------------------------------------------------------------------
12994C
12995      INCLUDE 'DPCOP2.INC'
12996C
12997C-----START POINT-----------------------------------------------------
12998C
12999      CHAZ=0.0
13000      IF(X.LE.0.0)GOTO9000
13001      IF(ETA.LT.0.0)THEN
13002        WRITE(ICOUT,106)
13003        CALL DPWRST('XXX','BUG ')
13004        WRITE(ICOUT,107)ETA
13005        CALL DPWRST('XXX','BUG ')
13006        GOTO9000
13007      ENDIF
13008  106 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER (ETA) TO')
13009  107 FORMAT('      MAKCHAZ IS NEGATIVE.  IT HAS THE VALUE ',E15.7)
13010C
13011      DX=DBLE(X)
13012      DETA=DBLE(ETA)
13013      DZETA=DBLE(ZETA)
13014C
13015      DTERM1=DEXP(-DZETA)
13016      DTERM2=DEXP(DX - DZETA)
13017      DTERM3=DETA*DX
13018      DTERM4=DTERM1 - DTERM2 - DTERM3
13019      CHAZ=-REAL(DTERM4)
13020C
13021 9000 CONTINUE
13022      RETURN
13023      END
13024      SUBROUTINE MA2HAZ(X,ZETA,ETA,HAZ)
13025C
13026C     THIS SUBROUTINE COMPUTES THE GOMPERTZ-MAKEHAM HAZARD
13027C     FUNCTION. THIS USES THE MEEKER AND ESCOBAR
13028C     PARAMETERIZATION (THIS TAKES THE 3-SHAPE PARAMETER CASE AND
13029C     RE-PARAMETERRIZES IT TO 2-SHAPE PARAMETERS AND A SCALE
13030C     PARAMETER.  IT HAS THE FOLLOWING HAZARD FUNCTION:
13031C         h(X,ZETA,ETA) = ETA + EXP(-ZETA)*EXP(X)
13032C                         X, ETA >= 0
13033C     WRITTEN BY--JAMES J. FILLIBEN
13034C                 STATISTICAL ENGINEERING DIVISION
13035C                 INFORMATION TECHNOLOGY LABORATORY
13036C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
13037C                 GAITHERSBURG, MD 20899-8980
13038C                 PHONE--301-975-2855
13039C     REFERENCE--"STATISTICAL METHODS FOR RELIABILITY DATA",
13040C                MEEKER AND ESCOBAR, WILEY, 1998, PP. 108-109.
13041C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
13042C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
13043C     LANGUAGE--ANSI FORTRAN (1977)
13044C     VERSION NUMBER--2004/7
13045C     ORIGINAL VERSION--JULY      2004.
13046C
13047C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
13048C
13049      REAL ZETA
13050      REAL ETA
13051C
13052      DOUBLE PRECISION DHAZ
13053      DOUBLE PRECISION DETA
13054      DOUBLE PRECISION DZETA
13055      DOUBLE PRECISION DX
13056C
13057C---------------------------------------------------------------------
13058C
13059      INCLUDE 'DPCOP2.INC'
13060C
13061C-----START POINT-----------------------------------------------------
13062C
13063      HAZ=0.0
13064      IF(X.LE.0.0)THEN
13065        WRITE(ICOUT,103)
13066        CALL DPWRST('XXX','BUG ')
13067        WRITE(ICOUT,104)X
13068        CALL DPWRST('XXX','BUG ')
13069        GOTO9000
13070      ENDIF
13071      IF(ETA.LT.0.0)THEN
13072        WRITE(ICOUT,106)
13073        CALL DPWRST('XXX','BUG ')
13074        WRITE(ICOUT,107)ETA
13075        CALL DPWRST('XXX','BUG ')
13076        GOTO9000
13077      ENDIF
13078  103 FORMAT('***** ERROR--THE INPUT ARGUMENT  TO MA2HAZ IS')
13079  104 FORMAT('      NON-POSITIVE.  IT HAS THE VALUE ',E15.7)
13080  106 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER (ETA) TO')
13081  107 FORMAT('      MAKHAZ IS NEGATIVE.  IT HAS THE VALUE ',E15.7)
13082C
13083      DX=DBLE(X)
13084      DETA=DBLE(ETA)
13085      DZETA=DBLE(ZETA)
13086C
13087      DHAZ=DETA + DEXP(-DZETA)*DEXP(DX)
13088      HAZ=REAL(DHAZ)
13089C
13090 9000 CONTINUE
13091      RETURN
13092      END
13093      SUBROUTINE MA2PDF(X,ZETA,ETA,PDF)
13094C
13095C     THIS SUBROUTINE COMPUTES THE GOMPERTZ-MAKEHAM PROBABILITY
13096C     DENSITY FUNCTION. THIS USES THE MEEKER AND ESCOBAR
13097C     PARAMETERIZATION (THIS TAKES THE 3-SHAPE PARAMETER CASE AND
13098C     RE-PARAMETERRIZES IT TO 2-SHAPE PARAMETERS AND A SCALE
13099C     PARAMETER.  IT HAS THE FOLLOWING PROBABILITY DENSITY FUNCTION:
13100C         f(X,ZETA,ETA) = (ETA + EXP(X-ZETA))*
13101C                         EXP[EXP(-ZETA)-EXP(X-ZETA)-ETA*X]
13102C                         X, ETA > 0
13103C     WRITTEN BY--JAMES J. FILLIBEN
13104C                 STATISTICAL ENGINEERING DIVISION
13105C                 INFORMATION TECHNOLOGY LABORATORY
13106C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
13107C                 GAITHERSBURG, MD 20899-8980
13108C                 PHONE--301-975-2855
13109C     REFERENCE--"STATISTICAL METHODS FOR RELIABILITY DATA",
13110C                MEEKER AND ESCOBAR, WILEY, 1998, PP. 108-109.
13111C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
13112C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
13113C     LANGUAGE--ANSI FORTRAN (1977)
13114C     VERSION NUMBER--2004/7
13115C     ORIGINAL VERSION--JULY      2004.
13116C
13117C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
13118C
13119      REAL ZETA
13120      REAL ETA
13121C
13122      DOUBLE PRECISION DPDF
13123      DOUBLE PRECISION DETA
13124      DOUBLE PRECISION DZETA
13125      DOUBLE PRECISION DX
13126      DOUBLE PRECISION DTERM1
13127      DOUBLE PRECISION DTERM2
13128C
13129C---------------------------------------------------------------------
13130C
13131      INCLUDE 'DPCOP2.INC'
13132C
13133C-----START POINT-----------------------------------------------------
13134C
13135      PDF=0.0
13136      IF(X.LE.0.0)THEN
13137        WRITE(ICOUT,103)
13138        CALL DPWRST('XXX','BUG ')
13139        WRITE(ICOUT,104)X
13140        CALL DPWRST('XXX','BUG ')
13141        GOTO9000
13142      ENDIF
13143CCCCC IF(ZETA.LE.0.0)THEN
13144CCCCC   WRITE(ICOUT,101)
13145CCCCC   CALL DPWRST('XXX','BUG ')
13146CCCCC   WRITE(ICOUT,102)ZETA
13147CCCCC   CALL DPWRST('XXX','BUG ')
13148CCCCC   GOTO9000
13149CCCCC ENDIF
13150      IF(ETA.LT.0.0)THEN
13151        WRITE(ICOUT,106)
13152        CALL DPWRST('XXX','BUG ')
13153        WRITE(ICOUT,107)ETA
13154        CALL DPWRST('XXX','BUG ')
13155        GOTO9000
13156      ENDIF
13157  103 FORMAT('***** ERROR--THE INPUT ARGUMENT  TO MA2PDF IS')
13158  104 FORMAT('      NON-POSITIVE.  IT HAS THE VALUE ',E15.7)
13159  106 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER (ETA) TO')
13160  107 FORMAT('      MAKPDF IS NEGATIVE.  IT HAS THE VALUE ',E15.7)
13161C
13162      DX=DBLE(X)
13163      DZETA=DBLE(ZETA)
13164      DETA=DBLE(ETA)
13165C
13166      DTERM1=DETA + EXP(DX-DZETA)
13167      DTERM2=DEXP(-DZETA) - DEXP(DX-DZETA) - DETA*DX
13168      DPDF=DTERM1*DEXP(DTERM2)
13169      PDF=REAL(DPDF)
13170C
13171 9000 CONTINUE
13172      RETURN
13173      END
13174      SUBROUTINE MA2PPF(P,ZETA,ETA,PPF)
13175C
13176C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
13177C              FUNCTION VALUE FOR THE GOMPERTZ-MAKEHAM DISTRIBUTION
13178C              WITH SHAPE PARAMETERS ETA AND ZETA.
13179C              THIS DISTRIBUTION IS DEFINED FOR POSITIVE X AND THE
13180C              PERCENT POINT FUNCTION IS COMPUTED BY
13181C              NUMERICALLY INVERTING THE CDF FUNCTION.
13182C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE AT
13183C                                WHICH THE PERCENT POINT
13184C                                FUNCTION IS TO BE EVALUATED.
13185C                     --ZETA l = THE FIRST SHAPE PARAMETER
13186C                     --ETA    = THE SECOND SHAPE PARAMETER
13187C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION CUMULATIVE
13188C                                DISTRIBUTION FUNCTION VALUE.
13189C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
13190C             FUNCTION VALUE PPF.
13191C     PRINTING--NONE.
13192C     RESTRICTIONS--NONE.
13193C     OTHER DATAPAC   SUBROUTINES NEEDED--FZERO.
13194C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
13195C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
13196C     LANGUAGE--ANSI FORTRAN (1977)
13197C     REFERENCE--"STATISTICAL METHODS FOR RELIABILITY DATA",
13198C                MEEKER AND ESCOBAR, WILEY, 1998, PP. 108-109.
13199C     WRITTEN BY--JAMES J. FILLIBEN
13200C                 STATISTICAL ENGINEERING DIVISION
13201C                 INFORMATION TECHNOLOGY LABORATORY
13202C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
13203C                 GAITHERSBURG, MD 20899-8980
13204C                 PHONE--301-975-2855
13205C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
13206C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
13207C     LANGUAGE--ANSI FORTRAN (1977)
13208C     VERSION NUMBER--2004.7
13209C     ORIGINAL VERSION--JULY      2004.
13210C
13211C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
13212C
13213C---------------------------------------------------------------------
13214C
13215      REAL ETA
13216      REAL ZETA
13217      REAL PPF
13218C
13219      REAL MA2FU2
13220      EXTERNAL MA2FU2
13221C
13222      REAL P2
13223      COMMON/MA4COM/P2
13224C
13225      REAL ETA2
13226      REAL ZETA2
13227      COMMON/MA3COM/ETA2,ZETA2
13228C
13229      INCLUDE 'DPCOP2.INC'
13230C
13231C-----START POINT-----------------------------------------------------
13232C
13233C               ********************************************
13234C               **  STEP 1--                              **
13235C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
13236C               ********************************************
13237C
13238      PPF=0.0
13239C
13240      IF(P.LE.0.0.OR.P.GE.1.0)THEN
13241         WRITE(ICOUT,61)
13242   61    FORMAT('***** ERROR--THE FIRST  INPUT ARGUMENT ',
13243     1          'TO THE MA2PPF SUBROUTINE ')
13244         CALL DPWRST('XXX','BUG ')
13245         WRITE(ICOUT,62)
13246   62    FORMAT('      IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL ***')
13247         CALL DPWRST('XXX','BUG ')
13248         WRITE(ICOUT,63)P
13249   63    FORMAT('      VALUE OF ARGUMENT = ',G15.7)
13250         CALL DPWRST('XXX','BUG ')
13251         PPF=0.0
13252         GOTO9000
13253      ENDIF
13254C
13255      IF(ETA.LT.0.0)THEN
13256        WRITE(ICOUT,106)
13257        CALL DPWRST('XXX','BUG ')
13258        WRITE(ICOUT,107)ETA
13259        CALL DPWRST('XXX','BUG ')
13260        GOTO9000
13261      ENDIF
13262  106 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER (ETA) TO')
13263  107 FORMAT('      MAKPPF IS NEGATIVE.  IT HAS THE VALUE ',E15.7)
13264C
13265C  STEP 1: FIND BRACKETING INTERVAL.  LOWER BOUND IS ZERO.  START WITH
13266C          10 AS GUESS FOR UPPER BOUND.  MULTIPLY BY 10 UNTIL
13267C          BRACKETING INTERVAL FOUND.
13268C
13269      XLOW=0.0000001
13270      XUP2=10.0
13271  200 CONTINUE
13272        CALL MA2CDF(XUP2,ZETA,ETA,PTEMP)
13273        IF(PTEMP.GT.P)THEN
13274          XUP=XUP2
13275        ELSE
13276          XUP2=XUP2*10.0
13277          IF(XUP2.GT.CPUMAX/100.)THEN
13278            WRITE(ICOUT,201)
13279  201       FORMAT('***** ERROR FROM MA2PPF--UNABLE TO FIND A ',
13280     1             'BRACKETING INTERVAL')
13281            CALL DPWRST('XXX','BUG ')
13282            GOTO9000
13283          ENDIF
13284          GOTO200
13285        ENDIF
13286C
13287      AE=1.E-6
13288      RE=1.E-6
13289      P2=P
13290      ETA2=ETA
13291      ZETA2=ZETA
13292      CALL FZERO(MA2FU2,XLOW,XUP,XUP,RE,AE,IFLAG)
13293C
13294      PPF=XLOW
13295C
13296      IF(IFLAG.EQ.2)THEN
13297C
13298C  NOTE: SUPPRESS THIS MESSAGE FOR NOW.
13299CCCCC   WRITE(ICOUT,999)
13300  999   FORMAT(1X)
13301CCCCC   CALL DPWRST('XXX','BUG ')
13302CCCCC   WRITE(ICOUT,111)
13303CC111   FORMAT('***** WARNING FROM MA2PPF--')
13304CCCCC   CALL DPWRST('XXX','BUG ')
13305CCCCC   WRITE(ICOUT,113)
13306CC113   FORMAT('      PPF VALUE MAY NOT BE COMPUTED TO DESIRED ',
13307CCCCC1         'TOLERANCE.')
13308CCCCC   CALL DPWRST('XXX','BUG ')
13309      ELSEIF(IFLAG.EQ.3)THEN
13310        WRITE(ICOUT,999)
13311        CALL DPWRST('XXX','BUG ')
13312        WRITE(ICOUT,121)
13313  121   FORMAT('***** WARNING FROM MAKPPF--')
13314        CALL DPWRST('XXX','BUG ')
13315        WRITE(ICOUT,123)
13316  123   FORMAT('      PPF VALUE MAY BE NEAR A SINGULAR POINT.')
13317        CALL DPWRST('XXX','BUG ')
13318      ELSEIF(IFLAG.EQ.4)THEN
13319        WRITE(ICOUT,999)
13320        CALL DPWRST('XXX','BUG ')
13321        WRITE(ICOUT,131)
13322  131   FORMAT('***** ERROR FROM MAKPPF--')
13323        CALL DPWRST('XXX','BUG ')
13324        WRITE(ICOUT,133)
13325  133   FORMAT('      APPROPRIATE BRACKETING INTERVAL NOT FOUND.')
13326        CALL DPWRST('XXX','BUG ')
13327      ELSEIF(IFLAG.EQ.5)THEN
13328        WRITE(ICOUT,999)
13329        CALL DPWRST('XXX','BUG ')
13330        WRITE(ICOUT,141)
13331  141   FORMAT('***** WARNING FROM MAKPPF--')
13332        CALL DPWRST('XXX','BUG ')
13333        WRITE(ICOUT,143)
13334  143   FORMAT('      MAXIMUM ITERATIONS EXCEEDED.')
13335        CALL DPWRST('XXX','BUG ')
13336      ENDIF
13337C
13338 9000 CONTINUE
13339      RETURN
13340      END
13341      SUBROUTINE MA2RAN(N,ZETA,ETA,ISEED,X)
13342C
13343C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
13344C              FROM THE THE GOMPERTZ-MAKEHAM DISTIBUTION WITH
13345C              LOCATION = 0 AND SCALE = 1.  THIS DISTRIBUTION IS
13346C              DEFINED FOR POSITIVE X AND HAS THE PROBABILITY DENSITY
13347C              FUNCTION:
13348C              f(X,ETA,ZETA) = (1/X)*EXP(LOG(X))*
13349C                              [ZETA + EXP[EXP(LOG(X)) - ETA]*
13350C                              [1 - MA2CDF(X,ETA,ZETA)]
13351C                              X, ZETA > 0
13352C             WHERE MA2CDF IS:
13353C             F(X,ETA,ZETA) = 1 - EXP[C1 - EXP(C2) - C3]
13354C                             X, ZETA > 0
13355C             WITH
13356C                 C1 = EXP(-ETA)
13357C                 C2 = EXP(LOG(X) - ETA)
13358C                 C3 = ZETA*EXP(LOG(X))
13359C
13360C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
13361C                                OF RANDOM NUMBERS TO BE
13362C                                GENERATED.
13363C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
13364C                                (OF DIMENSION AT LEAST N)
13365C                                INTO WHICH THE GENERATED
13366C                                RANDOM SAMPLE WILL BE PLACED.
13367C                     --ETA    = A SINGLE PRECISON SCALAR THAT DEFINES
13368C                                THE FIRST SHAPE PARAMETER.
13369C                     --ZETA   = A SINGLE PRECISON SCALAR THAT DEFINES
13370C                                THE SECOND SHAPE PARAMETER.
13371C     OUTPUT--A RANDOM SAMPLE OF SIZE N FROM THE COMPERTZ-MAKEHAM
13372C             DISTRIBUTION WITH LOCATION = 0 AND SCALE = 1.
13373C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EETASTS.
13374C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAETAMUM VALUE
13375C                   OF N FOR THIS SUBROUTINE.
13376C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, MA2PPF.
13377C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
13378C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
13379C     LANGUAGE--ANSI FORTRAN (1977)
13380C     METHOD--TRANSFORM NORMAL RANDOM NUMBERS
13381C     REFERENCE--"STATISTICAL METHODS FOR RELIABILITY DATA",
13382C                MEEKER AND ESCOBAR, WILEY, 1998, PP. 108-109.
13383C     WRITTEN BY--JAMES J. FILLIBEN
13384C                 STATISTICAL ENGINEERING DIVISION
13385C                 INFORMATION TECHNOLOGY LABORATORY
13386C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
13387C                 GAITHERSBURG, MD 20899-8980
13388C                 PHONE--301-975-2855
13389C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
13390C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
13391C     LANGUAGE--ANSI FORTRAN (1977)
13392C     VERSION NUMBER--2004.7
13393C     ORIGINAL VERSION--JULY      2004.
13394C
13395C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
13396C
13397C---------------------------------------------------------------------
13398C
13399      DIMENSION X(*)
13400      REAL ETA
13401      REAL ZETA
13402C
13403C---------------------------------------------------------------------
13404C
13405      INCLUDE 'DPCOP2.INC'
13406C
13407C-----START POINT-----------------------------------------------------
13408C
13409C     CHECK THE INPUT ARGUMENTS FOR ERRORS
13410C
13411      IF(N.LT.1)THEN
13412        WRITE(ICOUT, 5)
13413        CALL DPWRST('XXX','BUG ')
13414        WRITE(ICOUT, 6)
13415        CALL DPWRST('XXX','BUG ')
13416        WRITE(ICOUT,47)N
13417        CALL DPWRST('XXX','BUG ')
13418        GOTO9999
13419      ELSEIF(ZETA.LT.0.0)THEN
13420        WRITE(ICOUT,106)
13421        CALL DPWRST('XXX','BUG ')
13422        WRITE(ICOUT,107)
13423        CALL DPWRST('XXX','BUG ')
13424        WRITE(ICOUT,48)ZETA
13425        CALL DPWRST('XXX','BUG ')
13426        GOTO9999
13427      ENDIF
13428  106 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER (ZETA) TO THE')
13429  107 FORMAT('      GOMPERTZ MAKEHAM RANDOM NUMBERS ROUTINE IS ',
13430     1       'NON-POSITIVE.')
13431    5 FORMAT('***** THE REQUESTED NUMBER OF RANDOM NUMBERS FOR THE')
13432    6 FORMAT('      GOMPERTZ-MAKEHAM DISTRIBUTION IS NON-POSITIVE.')
13433   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
13434   48 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',F15.7)
13435C
13436C     GENERATE N UNIFORM NUMBERS;
13437C
13438      CALL UNIRAN(N,ISEED,X)
13439C
13440C     GENERATE N GOMPERTZ-MAKEHAM RANDON NUMBERS USING THE
13441C     PERCENT POINT FUNCTION TRANSFORMATION.
13442C
13443      DO100I=1,N
13444        XTEMP=X(I)
13445        CALL MA2PPF(XTEMP,ZETA,ETA,PPF)
13446        X(I)=PPF
13447  100 CONTINUE
13448C
13449 9999 CONTINUE
13450      RETURN
13451      END
13452      SUBROUTINE MANDIS(X,Y,N,IWRITE,STATVA,IBUGA3,ISUBRO,IERROR)
13453C
13454C     PURPOSE--THIS SUBROUTINE COMPUTES THE MANHATTAN DISTANCE BETWEEN THE
13455C              TWO SETS OF DATA IN THE INPUT VECTORS X AND Y.  THE
13456C              SAMPLE MANHATTAN DISTANCE WILL BE A SINGLE PRECISION VALUE
13457C              CALCULATED AS:
13458C
13459C                 DISTANCE = SUM[i=1 to n][|X(i) - Y(i)|]
13460C
13461C              THIS IS EQUIVALENT TO A MINKOWSKY DISTANCE WITH
13462C              P = 1 AND IS ALSO KNOWN CITY BLOCK OR TAXI-CAB
13463C              DISTANCE.
13464C
13465C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
13466C                                (UNSORTED) OBSERVATIONS WHICH
13467C                                CONSTITUTE THE FIRST SET OF DATA.
13468C                     --Y      = THE SINGLE PRECISION VECTOR OF
13469C                                (UNSORTED) OBSERVATIONS WHICH
13470C                                CONSTITUTE THE SECOND SET OF DATA.
13471C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
13472C                                IN THE VECTORS X AND Y.
13473C     OUTPUT ARGUMENTS--STATVA = THE SINGLE PRECISION VALUE OF THE
13474C                                COMPUTED SAMPLE COSINE DISTANCE
13475C                                BETWEEN THE TWO SETS OF DATA IN THE
13476C                                INPUT VECTORS X AND Y.  THIS SINGLE
13477C                                PRECISION VALUE WILL BE BETWEEN 0.0
13478C                                AND 1.0 (INCLUSIVELY).
13479C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
13480C             SAMPLE MANHATTAN DISTANCE BETWEEN THE 2 SETS
13481C             OF DATA IN THE INPUT VECTORS X AND Y.
13482C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
13483C                   OF N FOR THIS SUBROUTINE.
13484C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
13485C     FORTRAN LIBRARY SUBROUTINES NEEDED--ABS.
13486C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
13487C     LANGUAGE--ANSI FORTRAN (1977)
13488C     REFERENCES--XXX
13489C     WRITTEN BY--ALAN HECKERT
13490C                 STATISTICAL ENGINEERING DIVISION
13491C                 INFORMATION TECHNOLOGY LABORATORY
13492C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
13493C                 GAITHERSBURG, MD 20899
13494C                 PHONE--301-975-2899
13495C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
13496C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
13497C     LANGUAGE--ANSI FORTRAN (1977)
13498C     VERSION NUMBER--2017/03
13499C     ORIGINAL VERSION--MARCH     2017.
13500C
13501C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
13502C
13503      CHARACTER*4 IWRITE
13504      CHARACTER*4 IBUGA3
13505      CHARACTER*4 ISUBRO
13506      CHARACTER*4 IERROR
13507C
13508      CHARACTER*4 ISUBN1
13509      CHARACTER*4 ISUBN2
13510C
13511C---------------------------------------------------------------------
13512C
13513      DIMENSION X(*)
13514      DIMENSION Y(*)
13515C
13516C---------------------------------------------------------------------
13517C
13518      INCLUDE 'DPCOP2.INC'
13519C
13520C-----START POINT-----------------------------------------------------
13521C
13522      ISUBN1='MAND'
13523      ISUBN2='IS  '
13524      IERROR='NO'
13525      STATVA=CPUMIN
13526C
13527      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NDIS')THEN
13528        WRITE(ICOUT,999)
13529  999   FORMAT(1X)
13530        CALL DPWRST('XXX','BUG ')
13531        WRITE(ICOUT,51)
13532   51   FORMAT('***** AT THE BEGINNING OF MANDIS--')
13533        CALL DPWRST('XXX','BUG ')
13534        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
13535   52   FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8)
13536        CALL DPWRST('XXX','BUG ')
13537        DO55I=1,N
13538          WRITE(ICOUT,56)I,X(I),Y(I)
13539   56     FORMAT('I,X(I),Y(I) = ',I8,2G15.7)
13540          CALL DPWRST('XXX','BUG ')
13541   55   CONTINUE
13542      ENDIF
13543C
13544C               ********************************************
13545C               **  STEP 1--                              **
13546C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
13547C               ********************************************
13548C
13549      AN=N
13550C
13551      IF(N.LT.1)THEN
13552        WRITE(ICOUT,999)
13553        CALL DPWRST('XXX','BUG ')
13554        WRITE(ICOUT,111)
13555  111   FORMAT('***** ERROR IN MANHATTAN DISTANCE--')
13556        CALL DPWRST('XXX','BUG ')
13557        WRITE(ICOUT,112)
13558  112   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE')
13559        CALL DPWRST('XXX','BUG ')
13560        WRITE(ICOUT,113)
13561  113   FORMAT('      VARIABLES IS LESS THAN 1.')
13562        CALL DPWRST('XXX','BUG ')
13563        WRITE(ICOUT,117)N
13564  117   FORMAT('      THE NUMBER OF OBSERVATIONS HERE = ',I8,'.')
13565        CALL DPWRST('XXX','BUG ')
13566        IERROR='YES'
13567        GOTO9000
13568      ENDIF
13569C
13570C               ************************************************
13571C               **  STEP 2--                                  **
13572C               **  COMPUTE THE MANHATTAN DISTANCE.           **
13573C               ************************************************
13574C
13575      STATVA=0.0
13576      DO200I=1,N
13577        STATVA=STATVA + ABS(X(I) - Y(I))
13578  200 CONTINUE
13579C
13580C               *******************************
13581C               **  STEP 3--                 **
13582C               **  WRITE OUT A LINE         **
13583C               **  OF SUMMARY INFORMATION.  **
13584C               *******************************
13585C
13586      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
13587        WRITE(ICOUT,999)
13588        CALL DPWRST('XXX','BUG ')
13589        WRITE(ICOUT,811)N,STATVA
13590  811   FORMAT('THE MANHATTAN DISTANCE OF THE ',I8,
13591     1           ' OBSERVATIONS = ',G15.7)
13592        CALL DPWRST('XXX','BUG ')
13593      ENDIF
13594C
13595C               *****************
13596C               **  STEP 90--  **
13597C               **  EXIT.      **
13598C               *****************
13599C
13600 9000 CONTINUE
13601      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NDIS')THEN
13602        WRITE(ICOUT,999)
13603        CALL DPWRST('XXX','BUG ')
13604        WRITE(ICOUT,9011)
13605 9011   FORMAT('***** AT THE END       OF MANDIS--')
13606        CALL DPWRST('XXX','BUG ')
13607        WRITE(ICOUT,9012)IERROR,STATVA
13608 9012   FORMAT('IERROR,STATVA = ',A4,2X,G15.7)
13609        CALL DPWRST('XXX','BUG ')
13610      ENDIF
13611C
13612      RETURN
13613      END
13614      SUBROUTINE MATARI(YM1,NR1,NC1,YM2,NR2,NC2,NR3,NC3,MAXROM,MAXCOM,
13615CCCCC JANUARY 1998.  RECODE TO USE LESS MATRICES.
13616CCCCC SUBROUTINE MATARI(YM1,NR1,NC1,YM2,NR2,NC2,YM3,NR3,NC3,
13617     1Y1,N1,Y2,N2,Y3,N3,Y4,N4,
13618     1INDEX,IZROV,IPOSV,
13619     1DMEAN,DSSQD,P1,P2,BETA,
13620     1YS1,YS2,YS3,YS4,
13621     1IMCASE,IUPFLG,IMSUBC,ITYPA1,ITYPA2,ITYPA3,ITYPA4,NUMVAR,IWRITE,
13622     1YM9,NR9,NC9,VECT9,NVECT9,SCAL9,ITYP9,
13623CCCCC AUGUST 1993.
13624CCCCC JANUARY 1998.  RECODE TO USE LESS MATRICES.
13625CCCCC1YMJUNK,YMJUN2,
13626     1IBUGA3,ISUBRO,IERROR)
13627C
13628C     PURPOSE--CARRY OUT MATRIX     ARITHMETIC OPERATIONS
13629C              OF THE REAL DATA IN MATRICES YM1 AND YM2.
13630C
13631C     OPERATIONS--ADDITION
13632C                 SUBTRACTION
13633C                 MULTIPLICATION
13634C                 TRUNCATION
13635C
13636C                 NUMBER OF ROWS
13637C                 NUMBER OF COLUMNS
13638C                 ROW
13639C                 ELEMENT
13640C                 REPLACE ROW
13641C                 REPLACE ELEMENT
13642C                 DIAGONAL
13643C
13644C                 SOLUTION
13645C                 ITERATIVE SOLUTION
13646C                 TRIDIAGONAL SOLVE
13647C                 TRIANGULAR SOLVE
13648C                 SIMPLEX SOLUTION
13649C                 RANK
13650C
13651C                 CONDITION NUMBER
13652C                 RECIPROCAL CONDITION NUMBER
13653C                 INVERSE
13654C                 TRIANGULAR INVERSE
13655C                 DETERMINANT
13656C                 TRACE
13657C                 PERMANENT
13658C                 ADJOINT
13659C                 SUBMATRIX
13660C                 MINOR
13661C                 COFACTOR
13662C
13663C                 DEFINITION
13664C                 AUGMENT
13665C                 TRANSPOSE
13666C
13667C                 CHARACTERISTIC EQUATION      (NOT YET IMPLEMENED)
13668C
13669C                 EIGENVALUES
13670C                 EIGENVECTORS
13671C                 SINGULAR VALUE
13672C                 SINGULAR VALUE DECOMPOSITION
13673C                 CHOLESKY DECOMPOSITION
13674C                 SPECTRAL NORM
13675C                 SPECTRAL RADIUS
13676C                 EUCLIDEAN NORM
13677C
13678C                 VARIANCE-COVARIANCE MATRIX
13679C                 CORRELATION MATRIX
13680C                 PRINCIPLE COMPONENTS ...
13681C                 ... PRINCIPLE COMPONENT ...
13682C                 COMOVEMENT MATRIX
13683C
13684C     EXAMPLES--LET M3 = MATRIX ADDITION M1 M2
13685C               LET M3 = MATRIX ADDITION M1 P1
13686C             --LET M3 = MATRIX SUBTRACTION M1 M2
13687C               LET M3 = MATRIX SUBTRACTION M1 P1
13688C             --LET M3 = MATRIX MULTIPLICATION M1 M2
13689C               LET M3 = MATRIX MULTIPLICATION M1 V1
13690C               LET M3 = MATRIX MULTIPLICATION M1 P1
13691C             --LET V3 = MATRIX SOLUTION M1 V2
13692C             --LET V3 = MATRIX ITERATIVE SOLUTION M1 V2
13693C             --LET M3 = MATRIX INVERSE M1
13694C             --LET P3 = MATRIX CONDITION NUMBER M1
13695C             --LET P3 = MATRIX RECIPROCAL CONDITION NUMBER M1
13696C             --LET M3 = MATRIX TRANSPOSE M1
13697C             --LET M3 = MATRIX ADJOINT M1
13698C             --LET V3 = MATRIX CHARACTERISTIC EQUATION M1
13699C             --LET V3 = MATRIX EIGENVALUES M1
13700C             --LET P3 = MATRIX EIGENVECTORS M1
13701C             --LET P3 = MATRIX RANK M1
13702C             --LET P3 = MATRIX DETERMINANT M1
13703C             --LET P3 = MATRIX PERMANENT M1
13704C             --LET P3 = MATRIX SPECTRAL NORM M1
13705C             --LET P3 = MATRIX SPECTRAL RADIUS M1
13706C             --LET P3 = MATRIX NUMBER OF ROWS M1
13707C             --LET P3 = MATRIX NUMBER OF COLUMNS M1
13708C             --LET V4 = MATRIX SIMPLEX SOLUTION V1 M1 V2 V3
13709C             --LET P3 = MATRIX TRACE M1
13710C             --LET M3 = MATRIX SUBMATRIX M1 P1 P2
13711C             --LET P3 = MATRIX MINOR M1 P1 P2
13712C             --LET P3 = MATRIX COFACTOR M1 P1 P2
13713C             --LET M3 = MATRIX DEFINITION V1 P1 P2
13714C             --LET M3 = MATRIX DEFINITION V1 P1 P2 P3
13715C             --LET P3 = MATRIX EUCLIDEAN NORM M1
13716C             --LET V3 = MATRIX ROW M1 P1
13717C             --LET P3 = MATRIX ELEMENT M1 P1 P2
13718C             --LET M3 = MATRIX REPLACE ROW M1 V1 P1
13719C             --LET M3 = MATRIX REPLACE ELEMENT M1 P1 P2
13720C             --LET M3 = MATRIX AUGMENT M1
13721C             --LET V3 = MATRIX DIAGONAL M1
13722C             --LET M3 = DIAGONAL MATRIX V1
13723C             --LET M3 = VARIANCE-COVARIANCE MATRIX M1
13724C             --LET M3 = CORRELATION MATRIX M1
13725C             --LET M3 = PRINCIPLE COMPONENTS M1
13726C             --LET M3 = PRINCIPLE COMPONENTS EIGENVECTORS M1
13727C             --LET V3 = PRINCIPLE COMPONENTS EIGENVALUES M1
13728C             --LET V3 = ... PRINCIPLE COMPONENT M1
13729C             --LET V3 = ... PRINCIPLE COMPONENT EIGENVECTOR M1
13730C             --LET P3 = ... PRINCIPLE COMPONENT EIGENVALUE M1
13731C             --LET V3 = MATRIX SINGULAR VALUES M1
13732C             --LET M3 V3 M2 = MATRIX SINGULAR VALUE DECOMP M1
13733C             --LET M3 V3 M2 = MATRIX SINGULAR VALUE FACTOR M1
13734C             --LET M3 = CHOLESKY DECOMP M1
13735C             --LET V4 = TRIDIAGONAL SOLVE V1 V2 V3
13736C             --LET V4 = TRIANGULAR SOLVE M1 V2
13737C             --LET M3 = TRIANGULAR INVERSE M2
13738C             --LET M3 = MATRIX TRUNCATION M1 P1
13739C             --LET M3 = MATRIX UPPPER TRUNCATION M1 P1
13740C
13741C     INPUT  ARGUMENTS--YM1 (REAL MATRIX)
13742C                     --NR1
13743C                     --NC1
13744C                     --YM2 (REAL MATRIX)
13745C                     --NR2
13746C                     --NC2
13747C                     --YM3 (REAL MATRIX)
13748C                     --NR3
13749C                     --NC3
13750C                     --Y1  (REAL VECTOR)
13751C                     --N1
13752C                     --Y2  (REAL VECTOR)
13753C                     --N2
13754C                     --Y3  (REAL VECTOR)
13755C                     --N3
13756C                     --Y4  (REAL VECTOR)
13757C                     --N4
13758C     OUTPUT ARGUMENTS--YM9 (REAL MATRIX)
13759C                     --NR9
13760C                     --NC9
13761C                     --VECT9 (REAL VECTOR)
13762C                     --NVECT9
13763C                     --SCAL9 (REAL SCALAR)
13764C                     --ITYP9
13765C
13766C     NOTE--IT IS NOT PERMISSIBLE TO HAVE THE OUTPUT MATRIX YM9(.)
13767C           BEING IDENTICAL TO THE INPUT MATRIX YM1(.), YM2(.), OR YM3(.).
13768C     WRITTEN BY--JAMES J. FILLIBEN
13769C                 STATISTICAL ENGINEERING DIVISION
13770C                 INFORMATION TECHNOLOGY LABORATORY
13771C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
13772C                 GAITHERSBURG, MD 20899-8980
13773C                 PHONE--301-975-2855
13774C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
13775C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
13776C     LANGUAGE--ANSI FORTRAN (1977)
13777C     VERSION NUMBER--87/10
13778C     ORIGINAL VERSION--SEPTEMBER 1987
13779C     UPDATED         --AUGUST    1988  (VARIANCE-COVARIANCE MATRIX)
13780C     UPDATED         --AUGUST    1988  (CORRELATION MATRIX)
13781C     UPDATED         --AUGUST    1988  (PRINCIPLE COMPONENTS)
13782C     UPDATED         --AUGUST    1988  (... PRINCIPLE COMPONENTS)
13783C     UPDATED         --APRIL     1992  DEFINE D999
13784C     UPDATED         --JULY      1993  FOR MATRIX SOLUTION,
13785C                                       DETERMINANT, INVERSE, REPLACE
13786C                                       NUMERICAL RECIPES CODE WITH
13787C                                       LINPACK CODE
13788C     UPDATED         --JULY      1993  EIGENVALUES AND EIGENVECTORS
13789C                                       EXTENDED TO NON-SYMMETRIC CASE
13790C     UPDATED         --JULY      1993  IMPLEMENT RANK, ADJOINT,
13791C                                       SINGULAR VALUES, SINGULAR VALUE
13792C                                       DECOMP
13793C     UPDATED         --SEPT      1993  ROW, ELEMENT CASES
13794C     UPDATED         --OCTOBER   1993  CHOLESKY DECOMPOSITION, REPLACE
13795C                                       ROW, REPLACE ELEMENT, AUGMENT,
13796C                                       DIAGONAL, ADD ARGUMENT TO
13797C                                       MATRIX DEFINITION, TRIDIAGONAL
13798C                                       SOLVE.
13799C     UPDATED         --OCTOBER   1993  MOVE SOME OPERATIONS TO MATAR2
13800C     UPDATED         --DECEMBER  1994 MATRIX SUBMATRIX FOR NON-SQUARE
13801C                                      MATRICES
13802C     UPDATED         --JUNE      1995 EXTEND SPECTRAL RADIUS TO
13803C                                      NON-SYMMETRIC CASE
13804C     UPDATED         --JANUARY   1998 RECODE TO USE FEWER MATRICES
13805C     UPDATED         --JULY      2002 SUPPORT FOR DIFFERENT TYPES OF
13806C                                      COVARIANCE AND CORRELATION MATRIX
13807C     UPDATED         --NOVEMBER  2004 SUPPORT FOR DIFFERENT TYPES OF
13808C     UPDATED         --MARCH     2006 MATRIX <LOWER/UPPER> TRUNCATE
13809C     UPDATED         --NOVEMBER  2007 COMOVEMENT MATRIX
13810C     UPDATED         --SEPTEMBER 2011 MATRIX CONDITION NUMBER
13811C     UPDATED         --SEPTEMBER 2011 MATRIX RECIPROCAL CONDITION
13812C                                             NUMBER
13813C     UPDATED         --JUNE      2012 PARTIAL CORRELATION MATRIX
13814C     UPDATED         --JUNE      2012 PARTIAL CORRELATION CDF MATRIX
13815C     UPDATED         --JUNE      2012 PARTIAL CORRELATION PVALUE MATRIX
13816C     UPDATED         --JUNE      2012 CORRELATION CDF MATRIX
13817C     UPDATED         --JUNE      2012 CORRELATION PVALUE MATRIX
13818C     UPDATED         --SEPTEMBER 2016 CORRELATION ABSOLUTE VALUE
13819C     UPDATED         --SEPTEMBER 2016 CORRELATION PERCENTAGE VALUE
13820C     UPDATED         --SEPTEMBER 2016 CORRELATION DIGITS
13821C     UPDATED         --AUGUST    2019 CALL LIST TO KENTAU
13822C
13823C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
13824C
13825      CHARACTER*4 IMCASE
13826      CHARACTER*4 IUPFLG
13827      CHARACTER*4 IMSUBC
13828      CHARACTER*4 PCCASE
13829      CHARACTER*4 ITYPA1
13830      CHARACTER*4 ITYPA2
13831      CHARACTER*4 ITYPA3
13832      CHARACTER*4 ITYPA4
13833      CHARACTER*4 IWRITE
13834      CHARACTER*4 ITYP9
13835      CHARACTER*4 IBUGA3
13836      CHARACTER*4 ISUBRO
13837      CHARACTER*4 IERROR
13838C
13839      CHARACTER*4 ISUBN1
13840      CHARACTER*4 ISUBN2
13841      CHARACTER*4 ICASZZ
13842C
13843C-----DOUBLE PRECISION STATEMENTS FOR NON-COMMON VARIABLES-------------------
13844C
13845      DOUBLE PRECISION DYM1
13846      DOUBLE PRECISION DYM2
13847      DOUBLE PRECISION DYM9
13848      DOUBLE PRECISION DSUM
13849      DOUBLE PRECISION DSUM1
13850      DOUBLE PRECISION DSUM2
13851      DOUBLE PRECISION DDEL
13852C
13853      DOUBLE PRECISION DNR1
13854      DOUBLE PRECISION DNC1
13855      DOUBLE PRECISION DMEAN
13856      DOUBLE PRECISION DSSQD
13857      DOUBLE PRECISION DDENOM
13858      DOUBLE PRECISION DDEL1
13859      DOUBLE PRECISION DDEL2
13860      DOUBLE PRECISION DCOV
13861CCCCC THE FOLLOWING LINE WAS ADDED   APRIL 1992
13862      DOUBLE PRECISION D999
13863C
13864C---------------------------------------------------------------------
13865C
13866      INCLUDE 'DPCOPA.INC'
13867C
13868      DIMENSION YM1(MAXROM,MAXCOM)
13869      DIMENSION YM2(MAXROM,MAXCOM)
13870CCCCC DIMENSION YM3(MAXROM,MAXCOM)
13871      DIMENSION Y1(*)
13872      DIMENSION Y2(*)
13873      DIMENSION Y3(*)
13874      DIMENSION Y4(*)
13875      DIMENSION YM9(MAXROM,MAXCOM)
13876      DIMENSION VECT9(*)
13877C
13878CCCCC DIMENSION YMJUNK(MAXROM,MAXCOM)
13879CCCCC DIMENSION YMJUN2(MAXROM,MAXCOM)
13880CCCCC JANUARY 1998.  FOLLOWINF DIMENSIONS TO MAXOBV.
13881CCCCC DIMENSION INDEX(MAXROM)
13882CCCCC DIMENSION VJUNK(MAXROM)
13883CCCCC DIMENSION VJUNK2(MAXROM)
13884CCCCC DIMENSION AINDE2(MAXROM)
13885CCCCC DIMENSION AINDE3(MAXROM)
13886C
13887CCCCC DIMENSION IZROV(MAXROM)
13888CCCCC DIMENSION IPOSV(MAXROM)
13889C
13890CCCCC DIMENSION DMEAN(MAXROM)
13891CCCCC DIMENSION DSSQD(MAXROM)
13892C
13893CCCCC DIMENSION INDEX(MAXOBV)
13894      DIMENSION INDEX(*)
13895CCCCC REPLACE VJUNK, VJUNK2 WITH Y3 AND Y4 BELOW (TO SAVE SPACE)
13896CCCCC DIMENSION VJUNK(MAXOBV)
13897CCCCC DIMENSION VJUNK2(MAXOBV)
13898CCCCC REPLACE AINDE2, AINDE3 WITH Y1 AND Y2 BELOW (TO SAVE SPACE)
13899CCCCC DIMENSION AINDE2(MAXOBV)
13900CCCCC DIMENSION AINDE3(MAXOBV)
13901C
13902CCCCC DIMENSION IZROV(MAXOBV)
13903CCCCC DIMENSION IPOSV(MAXOBV)
13904      DIMENSION IZROV(*)
13905      DIMENSION IPOSV(*)
13906C
13907CCCCC DIMENSION DMEAN(MAXOBV)
13908CCCCC DIMENSION DSSQD(MAXOBV)
13909      DIMENSION DMEAN(*)
13910      DIMENSION DSSQD(*)
13911C
13912C---------------------------------------------------------------------
13913C
13914CCCCC JULY 1993.  ADD FOLLOWING COMMON BLOCK FOR PRINCIPLE COMPONENTS
13915      INCLUDE 'DPCOSU.INC'
13916      INCLUDE 'DPCOST.INC'
13917      INCLUDE 'DPCOP2.INC'
13918C
13919CCCCC JULY 1993.  FOLLOWING LINE ADDED FOR RANK.
13920      DATA RMXINT /134217727. /
13921C
13922C-----START POINT-----------------------------------------------------
13923C
13924      ISUBN1='MATA'
13925      ISUBN2='RI  '
13926      IERROR='NO'
13927C
13928CCCCC JULY 1993.
13929CCCCC PCCASE='DACR'
13930      PCCASE=IPCMTY
13931      AMINOR=CPUMIN
13932      SCAL9=CPUMIN
13933      COFACT=CPUMIN
13934      DET=CPUMIN
13935C
13936      IYS1=(-999)
13937      IYS2=(-999)
13938      IYS3=(-999)
13939      IYS23=(-999)
13940C
13941      NRJ=(-999)
13942      NCJ=(-999)
13943C
13944CCCCC THE FOLLOWING LINE WAS ADDED   APRIL 1992
13945      D999=(-999.0D0)
13946C
13947      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'TARI')GOTO190
13948C
13949      WRITE(ICOUT,999)
13950  999 FORMAT(1X)
13951      CALL DPWRST('XXX','BUG ')
13952      WRITE(ICOUT,51)
13953   51 FORMAT('***** AT THE BEGINNING OF MATARI--')
13954      CALL DPWRST('XXX','BUG ')
13955      WRITE(ICOUT,52)IBUGA3,ISUBRO,ITYPA1,ITYPA2,ITYPA3,ITYPA4
13956   52 FORMAT('IBUGA3,ISUBRO,ITYPA1,ITYPA2,ITYPA3,ITYPA4 = ',
13957     1        (A4,2X),A4)
13958      CALL DPWRST('XXX','BUG ')
13959      WRITE(ICOUT,53)IMCASE,IMSUBC,IWRITE
13960   53 FORMAT('IMCASE,IMSUBC,IWRITE = ',2(A4,2X),A4)
13961      CALL DPWRST('XXX','BUG ')
13962      WRITE(ICOUT,55)NUMVAR,YS1,YS2,YS3,YS4,DSSQD(1)
13963   55 FORMAT('NUMVAR,YS1,YS2,YS3,YS4,DSSQD(1) = ',I8,5G15.7)
13964      CALL DPWRST('XXX','BUG ')
13965C
13966      WRITE(ICOUT,999)
13967      CALL DPWRST('XXX','BUG ')
13968      WRITE(ICOUT,61)NR1,NC1
13969   61 FORMAT('NR1,NC1 = ',2I8)
13970      CALL DPWRST('XXX','BUG ')
13971      IF(NR1.LE.0)GOTO69
13972      IF(NC1.LE.0)GOTO69
13973      JMAX=NC1
13974      IF(JMAX.GT.10)JMAX=10
13975      DO62I=1,NR1
13976      WRITE(ICOUT,63)I,(YM1(I,J),J=1,JMAX)
13977   63 FORMAT('I,YM1(I,.) = ',I8,10E10.3)
13978      CALL DPWRST('XXX','BUG ')
13979   62 CONTINUE
13980   69 CONTINUE
13981C
13982      WRITE(ICOUT,999)
13983      CALL DPWRST('XXX','BUG ')
13984      WRITE(ICOUT,71)NR2,NC2
13985   71 FORMAT('NR2,NC2 = ',2I8)
13986      CALL DPWRST('XXX','BUG ')
13987      IF(NR2.LE.0)GOTO79
13988      IF(NC2.LE.0)GOTO79
13989      JMAX=NC2
13990      IF(JMAX.GT.10)JMAX=10
13991      DO72I=1,NR2
13992      WRITE(ICOUT,73)I,(YM2(I,J),J=1,JMAX)
13993   73 FORMAT('I,YM2(I,.) = ',I8,10E10.3)
13994      CALL DPWRST('XXX','BUG ')
13995   72 CONTINUE
13996   79 CONTINUE
13997C
13998      WRITE(ICOUT,999)
13999      CALL DPWRST('XXX','BUG ')
14000      WRITE(ICOUT,81)NR3,NC3
14001   81 FORMAT('NR3,NC3 = ',2I8)
14002      CALL DPWRST('XXX','BUG ')
14003      IF(NR3.LE.0)GOTO89
14004      IF(NC3.LE.0)GOTO89
14005      JMAX=NC3
14006      IF(JMAX.GT.10)JMAX=10
14007      DO82I=1,NR3
14008      WRITE(ICOUT,83)I,(YM9(I,J),J=1,JMAX)
14009   83 FORMAT('I,YM9(I,.) = ',I8,10E10.3)
14010      CALL DPWRST('XXX','BUG ')
14011   82 CONTINUE
14012   89 CONTINUE
14013C
14014      WRITE(ICOUT,999)
14015      CALL DPWRST('XXX','BUG ')
14016      WRITE(ICOUT,111)N1
14017  111 FORMAT('N1 = ',I8)
14018      CALL DPWRST('XXX','BUG ')
14019      IF(N1.LE.0)GOTO119
14020      DO112I=1,N1
14021      WRITE(ICOUT,113)I,Y1(I)
14022  113 FORMAT('I,Y1(I) = ',I8,E15.7)
14023      CALL DPWRST('XXX','BUG ')
14024  112 CONTINUE
14025  119 CONTINUE
14026C
14027      WRITE(ICOUT,999)
14028      CALL DPWRST('XXX','BUG ')
14029      WRITE(ICOUT,121)N2
14030  121 FORMAT('N2 = ',I8)
14031      CALL DPWRST('XXX','BUG ')
14032      IF(N2.LE.0)GOTO129
14033      DO122I=1,N2
14034      WRITE(ICOUT,123)I,Y2(I)
14035  123 FORMAT('I,Y2(I) = ',I8,E15.7)
14036      CALL DPWRST('XXX','BUG ')
14037  122 CONTINUE
14038  129 CONTINUE
14039C
14040      WRITE(ICOUT,999)
14041      CALL DPWRST('XXX','BUG ')
14042      WRITE(ICOUT,131)N3
14043  131 FORMAT('N3 = ',I8)
14044      CALL DPWRST('XXX','BUG ')
14045      IF(N3.LE.0)GOTO139
14046      DO132I=1,N3
14047      WRITE(ICOUT,133)I,Y3(I)
14048  133 FORMAT('I,Y3(I) = ',I8,E15.7)
14049      CALL DPWRST('XXX','BUG ')
14050  132 CONTINUE
14051  139 CONTINUE
14052C
14053      WRITE(ICOUT,999)
14054      CALL DPWRST('XXX','BUG ')
14055      WRITE(ICOUT,141)N4
14056  141 FORMAT('N4 = ',I8)
14057      CALL DPWRST('XXX','BUG ')
14058      IF(N4.LE.0)GOTO149
14059      DO142I=1,N4
14060      WRITE(ICOUT,143)I,Y4(I)
14061  143 FORMAT('I,Y4(I) = ',I8,E15.7)
14062      CALL DPWRST('XXX','BUG ')
14063  142 CONTINUE
14064  149 CONTINUE
14065C
14066  190 CONTINUE
14067C
14068C               **************************************************
14069C               **  CARRY OUT MATRIX     ARITHMETIC OPERATIONS  **
14070C               **************************************************
14071C
14072      DNR1=NR1
14073      DNC1=NC1
14074C
14075C               ********************************************
14076C               **  STEP 11--                             **
14077C               **  CHECK NUMBER OF INPUT OBSERVATIONS.   **
14078C               ********************************************
14079C
14080      IF(ITYPA1.EQ.'MATR'.AND.NUMVAR.GE.1.AND.NR1.LE.0)GOTO1100
14081      IF(ITYPA1.EQ.'MATR'.AND.NUMVAR.GE.1.AND.NC1.LE.0)GOTO1100
14082      IF(ITYPA2.EQ.'MATR'.AND.NUMVAR.GE.2.AND.NR2.LE.0)GOTO1100
14083      IF(ITYPA2.EQ.'MATR'.AND.NUMVAR.GE.2.AND.NC2.LE.0)GOTO1100
14084      IF(ITYPA3.EQ.'MATR'.AND.NUMVAR.GE.3.AND.NR3.LE.0)GOTO1100
14085      IF(ITYPA3.EQ.'MATR'.AND.NUMVAR.GE.3.AND.NC3.LE.0)GOTO1100
14086C
14087      IF(ITYPA1.EQ.'VARI'.AND.NUMVAR.GE.1.AND.N1.LE.0)GOTO1100
14088      IF(ITYPA2.EQ.'VARI'.AND.NUMVAR.GE.2.AND.N2.LE.0)GOTO1100
14089      IF(ITYPA3.EQ.'VARI'.AND.NUMVAR.GE.3.AND.N3.LE.0)GOTO1100
14090C
14091      GOTO1190
14092C
14093 1100 CONTINUE
14094      IERROR='YES'
14095      WRITE(ICOUT,999)
14096      CALL DPWRST('XXX','BUG ')
14097      WRITE(ICOUT,1111)
14098 1111 FORMAT('***** ERROR IN MATARI--')
14099      CALL DPWRST('XXX','BUG ')
14100      WRITE(ICOUT,1112)
14101 1112 FORMAT('      THE INPUT NUMBER OF ROWS AND/OR COLUMNS')
14102      CALL DPWRST('XXX','BUG ')
14103      WRITE(ICOUT,1113)
14104 1113 FORMAT('      IN THE MATRIX AND/OR VECTOR FOR WHICH')
14105      CALL DPWRST('XXX','BUG ')
14106      IF(IMCASE.EQ.'MAAD')WRITE(ICOUT,1121)
14107 1121 FORMAT('      THE MATRIX     ADDITION IS TO BE ',
14108     1'COMPUTED')
14109      IF(IMCASE.EQ.'MAAD')CALL DPWRST('XXX','BUG ')
14110      IF(IMCASE.EQ.'MASU')WRITE(ICOUT,1122)
14111 1122 FORMAT('      THE MATRIX     SUBTRACTION IS TO BE ',
14112     1'COMPUTED')
14113      IF(IMCASE.EQ.'MASU')CALL DPWRST('XXX','BUG ')
14114      IF(IMCASE.EQ.'MAMU')WRITE(ICOUT,1123)
14115 1123 FORMAT('      THE MATRIX     MULTIPLICATION IS TO BE ',
14116     1'COMPUTED')
14117      IF(IMCASE.EQ.'MAMU')CALL DPWRST('XXX','BUG ')
14118      IF(IMCASE.EQ.'MASO')WRITE(ICOUT,1124)
14119 1124 FORMAT('      THE MATRIX     SOLUTION IS TO BE ',
14120     1'COMPUTED')
14121      IF(IMCASE.EQ.'MASO')CALL DPWRST('XXX','BUG ')
14122      IF(IMCASE.EQ.'MAIN')WRITE(ICOUT,1125)
14123 1125 FORMAT('      THE MATRIX     INVERSE IS TO BE ',
14124     1'COMPUTED')
14125      IF(IMCASE.EQ.'MAIN')CALL DPWRST('XXX','BUG ')
14126      IF(IMCASE.EQ.'MATR')WRITE(ICOUT,1126)
14127 1126 FORMAT('      THE MATRIX     TRANSPOSE IS TO BE ',
14128     1'COMPUTED')
14129      IF(IMCASE.EQ.'MATR')CALL DPWRST('XXX','BUG ')
14130      IF(IMCASE.EQ.'MAAJ')WRITE(ICOUT,1127)
14131 1127 FORMAT('      THE MATRIX     ADJOINT IS TO BE ',
14132     1'COMPUTED')
14133      IF(IMCASE.EQ.'MAAJ')CALL DPWRST('XXX','BUG ')
14134      IF(IMCASE.EQ.'MACE')WRITE(ICOUT,1128)
14135 1128 FORMAT('      THE MATRIX CHARACTERISTIC EQUATION IS TO BE ',
14136     1'COMPUTED')
14137      IF(IMCASE.EQ.'MACE')CALL DPWRST('XXX','BUG ')
14138      IF(IMCASE.EQ.'MAEA')WRITE(ICOUT,1129)
14139 1129 FORMAT('      THE MATRIX     EIGENVALUES ARE TO BE ',
14140     1'COMPUTED')
14141      IF(IMCASE.EQ.'MAEA')CALL DPWRST('XXX','BUG ')
14142      IF(IMCASE.EQ.'MAEE')WRITE(ICOUT,1130)
14143 1130 FORMAT('      THE MATRIX     EIGENVECTORS ARE TO BE ',
14144     1'COMPUTED')
14145      IF(IMCASE.EQ.'MAEE')CALL DPWRST('XXX','BUG ')
14146      IF(IMCASE.EQ.'MARA')WRITE(ICOUT,1131)
14147 1131 FORMAT('      THE MATRIX     RANK IS TO BE ',
14148     1'COMPUTED')
14149      IF(IMCASE.EQ.'MARA')CALL DPWRST('XXX','BUG ')
14150      IF(IMCASE.EQ.'MADE')WRITE(ICOUT,1132)
14151 1132 FORMAT('      THE MATRIX     DETERMINANT IS TO BE ',
14152     1'COMPUTED')
14153      IF(IMCASE.EQ.'MADE')CALL DPWRST('XXX','BUG ')
14154      IF(IMCASE.EQ.'MAPE')WRITE(ICOUT,1133)
14155 1133 FORMAT('      THE MATRIX     PERMANENT IS TO BE ',
14156     1'COMPUTED')
14157      IF(IMCASE.EQ.'MAPE')CALL DPWRST('XXX','BUG ')
14158      IF(IMCASE.EQ.'MASN')WRITE(ICOUT,1134)
14159 1134 FORMAT('      THE MATRIX     SPECTRAL NORM IS TO BE ',
14160     1'COMPUTED')
14161      IF(IMCASE.EQ.'MASN')CALL DPWRST('XXX','BUG ')
14162      IF(IMCASE.EQ.'MASR')WRITE(ICOUT,1135)
14163 1135 FORMAT('      THE MATRIX     SPECTRAL RADIUS IS TO BE ',
14164     1'COMPUTED')
14165      IF(IMCASE.EQ.'MASR')CALL DPWRST('XXX','BUG ')
14166      IF(IMCASE.EQ.'MANR')WRITE(ICOUT,1136)
14167 1136 FORMAT('      THE MATRIX     NUMBER OF ROWS IS TO BE ',
14168     1'COMPUTED')
14169      IF(IMCASE.EQ.'MANR')CALL DPWRST('XXX','BUG ')
14170      IF(IMCASE.EQ.'MANC')WRITE(ICOUT,1137)
14171 1137 FORMAT('      THE MATRIX     NUMBER OF COLUMNS IS TO BE ',
14172     1'COMPUTED')
14173      IF(IMCASE.EQ.'MANC')CALL DPWRST('XXX','BUG ')
14174      IF(IMCASE.EQ.'MANC')WRITE(ICOUT,1138)
14175 1138 FORMAT('      THE MATRIX     SIMPLEX SOLUTION IS TO BE ',
14176     1'COMPUTED')
14177      IF(IMCASE.EQ.'MANC')CALL DPWRST('XXX','BUG ')
14178      IF(IMCASE.EQ.'MATC')WRITE(ICOUT,1141)
14179 1141 FORMAT('      THE MATRIX     TRACE IS TO BE ',
14180     1'COMPUTED')
14181      IF(IMCASE.EQ.'MATC')CALL DPWRST('XXX','BUG ')
14182      IF(IMCASE.EQ.'MASM')WRITE(ICOUT,1142)
14183 1142 FORMAT('      THE MATRIX     SUBMATRIX IS TO BE ',
14184     1'COMPUTED')
14185      IF(IMCASE.EQ.'MASM')CALL DPWRST('XXX','BUG ')
14186      IF(IMCASE.EQ.'MAMI')WRITE(ICOUT,1143)
14187 1143 FORMAT('      THE MATRIX     MINOR IS TO BE ',
14188     1'COMPUTED')
14189      IF(IMCASE.EQ.'MAMI')CALL DPWRST('XXX','BUG ')
14190      IF(IMCASE.EQ.'MACF')WRITE(ICOUT,1144)
14191 1144 FORMAT('      THE MATRIX     COFACTOR IS TO BE ',
14192     1'COMPUTED')
14193      IF(IMCASE.EQ.'MACF')CALL DPWRST('XXX','BUG ')
14194      IF(IMCASE.EQ.'MADF')WRITE(ICOUT,1145)
14195 1145 FORMAT('      THE MATRIX     DEFINITION IS TO BE ',
14196     1'COMPUTED')
14197      IF(IMCASE.EQ.'MADF')CALL DPWRST('XXX','BUG ')
14198      IF(IMCASE.EQ.'MAEN')WRITE(ICOUT,1146)
14199 1146 FORMAT('      THE MATRIX     EUCLIDEAN NORM IS TO BE ',
14200     1'COMPUTED')
14201      IF(IMCASE.EQ.'MAEN')CALL DPWRST('XXX','BUG ')
14202      IF(IMCASE.EQ.'MAVC')WRITE(ICOUT,1151)
14203 1151 FORMAT('      THE VARIANCE-COVARIANCE MATRIX IS TO BE ',
14204     1'COMPUTED')
14205      IF(IMCASE.EQ.'MAVC')CALL DPWRST('XXX','BUG ')
14206      IF(IMCASE.EQ.'MACO')WRITE(ICOUT,1152)
14207 1152 FORMAT('      THE CORRELATION MATRIX IS TO BE ',
14208     1'COMPUTED')
14209      IF(IMCASE.EQ.'MACO')CALL DPWRST('XXX','BUG ')
14210      IF(IMCASE.EQ.'MAPC')WRITE(ICOUT,1153)
14211 1153 FORMAT('      THE PRINCIPLE COMPONENTS ARE TO BE ',
14212     1'COMPUTED')
14213      IF(IMCASE.EQ.'MAPC')CALL DPWRST('XXX','BUG ')
14214      IF(IMCASE(1:3).EQ.'MAP'.AND.IMCASE(4:4).NE.'C')THEN
14215         WRITE(ICOUT,1154)
14216 1154    FORMAT('      THE ... PRINCIPLE COMPONENT TO BE ',
14217     1   'COMPUTED')
14218         CALL DPWRST('XXX','BUG ')
14219      ENDIF
14220      WRITE(ICOUT,1181)
14221 1181 FORMAT('      MUST BE 1 OR LARGER;')
14222      CALL DPWRST('XXX','BUG ')
14223      WRITE(ICOUT,1182)
14224 1182 FORMAT('      SUCH WAS NOT THE CASE HERE.')
14225      CALL DPWRST('XXX','BUG ')
14226      IF(ITYPA1.EQ.'MATR'.AND.NUMVAR.GE.1)WRITE(ICOUT,1183)NR1,NC1
14227 1183 FORMAT('            MATRIX 1--',I8,' ROWS BY ',I8,' COLUMNS')
14228      IF(ITYPA1.EQ.'MATR'.AND.NUMVAR.GE.1)CALL DPWRST('XXX','BUG ')
14229      IF(ITYPA2.EQ.'MATR'.AND.NUMVAR.GE.2)WRITE(ICOUT,1184)NR2,NC2
14230 1184 FORMAT('            MATRIX 2--',I8,' ROWS BY ',I8,' COLUMNS')
14231      IF(ITYPA2.EQ.'MATR'.AND.NUMVAR.GE.2)CALL DPWRST('XXX','BUG ')
14232      IF(ITYPA3.EQ.'MATR'.AND.NUMVAR.GE.3)WRITE(ICOUT,1185)NR3,NC3
14233 1185 FORMAT('            MATRIX 3--',I8,' ROWS BY ',I8,' COLUMNS')
14234      IF(ITYPA3.EQ.'MATR'.AND.NUMVAR.GE.3)CALL DPWRST('XXX','BUG ')
14235      IF(ITYPA1.EQ.'VARI'.AND.NUMVAR.GE.1)WRITE(ICOUT,1186)N1
14236 1186 FORMAT('            VECTOR 1--',I8,' ROWS')
14237      IF(ITYPA1.EQ.'VARI'.AND.NUMVAR.GE.1)CALL DPWRST('XXX','BUG ')
14238      IF(ITYPA2.EQ.'VARI'.AND.NUMVAR.GE.2)WRITE(ICOUT,1187)N2
14239 1187 FORMAT('            VECTOR 2--',I8,' ROWS')
14240      IF(ITYPA2.EQ.'VARI'.AND.NUMVAR.GE.2)CALL DPWRST('XXX','BUG ')
14241      IF(ITYPA3.EQ.'VARI'.AND.NUMVAR.GE.3)WRITE(ICOUT,1188)N3
14242 1188 FORMAT('            VECTOR 3--',I8,' ROWS')
14243      IF(ITYPA3.EQ.'VARI'.AND.NUMVAR.GE.3)CALL DPWRST('XXX','BUG ')
14244      GOTO9000
14245C
14246 1190 CONTINUE
14247C
14248C               *********************************
14249C               **  STEP 12--                  **
14250C               **  BRANCH TO THE PROPER CASE  **
14251C               *********************************
14252C
14253      IF(IMCASE.EQ.'MAAD')GOTO2100
14254      IF(IMCASE.EQ.'MASU')GOTO2200
14255      IF(IMCASE.EQ.'MAMU')GOTO2300
14256      IF(IMCASE.EQ.'MASO')GOTO2400
14257      IF(IMCASE.EQ.'MAIN')GOTO2500
14258      IF(IMCASE.EQ.'MACN')GOTO2560
14259      IF(IMCASE.EQ.'MARC')GOTO2560
14260      IF(IMCASE.EQ.'MATR')GOTO2600
14261      IF(IMCASE.EQ.'MAAJ')GOTO2700
14262      IF(IMCASE.EQ.'MACE')GOTO2800
14263      IF(IMCASE.EQ.'MAEA')GOTO2900
14264      IF(IMCASE.EQ.'MAEE')GOTO3000
14265      IF(IMCASE.EQ.'MARA')GOTO3100
14266      IF(IMCASE.EQ.'MADE')GOTO3200
14267      IF(IMCASE.EQ.'MAPE')GOTO3300
14268      IF(IMCASE.EQ.'MASN')GOTO3400
14269      IF(IMCASE.EQ.'MASR')GOTO3500
14270      IF(IMCASE.EQ.'MANR')GOTO3600
14271      IF(IMCASE.EQ.'MANC')GOTO3700
14272      IF(IMCASE.EQ.'MASS')GOTO3800
14273      IF(IMCASE.EQ.'MATC')GOTO4100
14274      IF(IMCASE.EQ.'MASM')GOTO4200
14275      IF(IMCASE.EQ.'MAMI')GOTO4300
14276      IF(IMCASE.EQ.'MACF')GOTO4400
14277      IF(IMCASE.EQ.'MADF')GOTO4500
14278      IF(IMCASE.EQ.'MAEN')GOTO4600
14279      IF(IMCASE.EQ.'MAVC')GOTO5100
14280      IF(IMCASE.EQ.'MACO')GOTO5200
14281      IF(IMCASE.EQ.'MACC')GOTO5200
14282      IF(IMCASE.EQ.'MACP')GOTO5200
14283C
14284      IF(IMCASE.EQ.'MAPC')GOTO5300
14285      IF(IMCASE.EQ.'MAP1')GOTO5300
14286      IF(IMCASE.EQ.'MAP2')GOTO5300
14287      IF(IMCASE.EQ.'MAP3')GOTO5300
14288      IF(IMCASE.EQ.'MAP4')GOTO5300
14289      IF(IMCASE.EQ.'MAP5')GOTO5300
14290      IF(IMCASE.EQ.'MAP6')GOTO5300
14291      IF(IMCASE.EQ.'MAP7')GOTO5300
14292      IF(IMCASE.EQ.'MAP8')GOTO5300
14293      IF(IMCASE.EQ.'MAP9')GOTO5300
14294      IF(IMCASE.EQ.'MA10')GOTO5300
14295CCCCCC OCTOBER 1993.  FOLLOWING OPERATIONS MOVED TO MATAR2
14296CCCCC JULY 1993.  ADD FOLLOWING 3 LINES
14297CCCCC IF(IMCASE.EQ.'MASV')GOTO5800
14298CCCCC IF(IMCASE.EQ.'MASD')GOTO5900
14299CCCCC IF(IMCASE.EQ.'MASF')GOTO6000
14300CCCCC SEPTEMBER 1993.  ADD FOLLOWING 2 LINES
14301CCCCC IF(IMCASE.EQ.'MARW')GOTO6100
14302CCCCC IF(IMCASE.EQ.'MAEL')GOTO6200
14303CCCCC OCTOBER 1993.  ADD FOLLOWING LINE
14304CCCCC IF(IMCASE.EQ.'MACH')GOTO6300
14305CCCCC IF(IMCASE.EQ.'MAAU')GOTO6400
14306CCCCC IF(IMCASE.EQ.'MADI')GOTO6500
14307CCCCC IF(IMCASE.EQ.'DIMA')GOTO6600
14308CCCCC IF(IMCASE.EQ.'MARR')GOTO6700
14309CCCCC IF(IMCASE.EQ.'MARE')GOTO6800
14310CCCCC IF(IMCASE.EQ.'MATD')GOTO6900
14311CCCCC IF(IMCASE.EQ.'MATS')GOTO7000
14312CCCCC IF(IMCASE.EQ.'MATI')GOTO7100
14313CCCCC IF(IMCASE.EQ.'MAIS')GOTO7200
14314C
14315      IF(IMCASE.EQ.'MATZ')GOTO6100
14316      IF(IMCASE.EQ.'MAUZ')GOTO6200
14317      IF(IMCASE.EQ.'MACM')GOTO6300
14318      IF(IMCASE.EQ.'MPCO')GOTO6400
14319      IF(IMCASE.EQ.'MPCC')GOTO6400
14320      IF(IMCASE.EQ.'MPCP')GOTO6400
14321C
14322      WRITE(ICOUT,999)
14323      CALL DPWRST('XXX','BUG ')
14324      WRITE(ICOUT,1211)
14325 1211 FORMAT('***** INTERNAL ERROR IN MATARI--')
14326      CALL DPWRST('XXX','BUG ')
14327      WRITE(ICOUT,1212)
14328 1212 FORMAT('      IMCASE NOT EQUAL TO')
14329      CALL DPWRST('XXX','BUG ')
14330      WRITE(ICOUT,1213)
14331 1213 FORMAT('      MAAD, MASU, MAMU, MASO, ')
14332      CALL DPWRST('XXX','BUG ')
14333      WRITE(ICOUT,1214)
14334 1214 FORMAT('      MAIN, MATR, MAAJ, MACE, ')
14335      CALL DPWRST('XXX','BUG ')
14336      WRITE(ICOUT,1215)
14337 1215 FORMAT('      MAEA, MAEE, MARA, MADE, ')
14338      CALL DPWRST('XXX','BUG ')
14339      WRITE(ICOUT,1216)
14340 1216 FORMAT('      MAPE, MASN, MASR, MANR, ')
14341      CALL DPWRST('XXX','BUG ')
14342      WRITE(ICOUT,1217)
14343 1217 FORMAT('      MANC, MASS,')
14344      CALL DPWRST('XXX','BUG ')
14345      WRITE(ICOUT,1221)
14346 1221 FORMAT('      MAVC, MACO, MAPC, OR MAPX ')
14347      CALL DPWRST('XXX','BUG ')
14348      WRITE(ICOUT,1228)IMCASE
14349 1228 FORMAT('      IMCASE = ',A4)
14350      CALL DPWRST('XXX','BUG ')
14351      IERROR='YES'
14352      GOTO9000
14353C
14354C               *********************************************
14355C               **  STEP 21--                              **
14356C               **  TREAT THE MATRIX     ADDITION    CASE  **
14357C               *********************************************
14358C
14359 2100 CONTINUE
14360C
14361      IF(ITYPA1.EQ.'MATR'.AND.ITYPA2.EQ.'MATR')GOTO2110
14362      IF(ITYPA1.EQ.'MATR'.AND.ITYPA2.EQ.'VARI')GOTO2130
14363      IF(ITYPA1.EQ.'VARI'.AND.ITYPA2.EQ.'MATR')GOTO2150
14364      IF(ITYPA1.EQ.'MATR'.AND.ITYPA2.EQ.'PARA')GOTO2170
14365      IF(ITYPA1.EQ.'PARA'.AND.ITYPA2.EQ.'MATR')GOTO2180
14366C
14367      WRITE(ICOUT,999)
14368      CALL DPWRST('XXX','BUG ')
14369      WRITE(ICOUT,2101)
14370 2101 FORMAT('***** ERROR IN MATARI--')
14371      CALL DPWRST('XXX','BUG ')
14372      WRITE(ICOUT,2102)
14373 2102 FORMAT('      ILLEGAL ARGUMENT TYPES FOR MATRIX ADDITION.')
14374      CALL DPWRST('XXX','BUG ')
14375      WRITE(ICOUT,2103)ITYPA1
14376 2103 FORMAT('            TYPE FOR ARGUMENT 1 = ',A4)
14377      CALL DPWRST('XXX','BUG ')
14378      WRITE(ICOUT,2104)ITYPA2
14379 2104 FORMAT('            TYPE FOR ARGUMENT 2 = ',A4)
14380      CALL DPWRST('XXX','BUG ')
14381      IERROR='YES'
14382      GOTO9000
14383C
14384 2110 CONTINUE
14385      IF(NR1.EQ.NR2.AND.NC1.EQ.NC2)GOTO2119
14386      WRITE(ICOUT,999)
14387      CALL DPWRST('XXX','BUG ')
14388      WRITE(ICOUT,2111)
14389 2111 FORMAT('***** ERROR IN MATARI--')
14390      CALL DPWRST('XXX','BUG ')
14391      WRITE(ICOUT,2112)
14392 2112 FORMAT('      FOR MATRIX ADDITION OF MATRIX 1 & MATRIX 2,')
14393      CALL DPWRST('XXX','BUG ')
14394      WRITE(ICOUT,2113)
14395 2113 FORMAT('      THE NUMBER OF ROWS AND COLUMNS IN MATRIX 1')
14396      CALL DPWRST('XXX','BUG ')
14397      WRITE(ICOUT,2114)
14398 2114 FORMAT('      MUST EQUAL')
14399      CALL DPWRST('XXX','BUG ')
14400      WRITE(ICOUT,2115)
14401 2115 FORMAT('      THE NUMBER OF ROWS AND COLUMNS IN MATRIX 2;')
14402      CALL DPWRST('XXX','BUG ')
14403      WRITE(ICOUT,2116)
14404 2116 FORMAT('      SUCH WAS NOT THE CASE HERE.')
14405      CALL DPWRST('XXX','BUG ')
14406      WRITE(ICOUT,2117)NR1,NC1
14407 2117 FORMAT('            MATRIX 1--',I8,' ROWS BY ',I8,' COLUMNS')
14408      CALL DPWRST('XXX','BUG ')
14409      WRITE(ICOUT,2118)NR2,NC2
14410 2118 FORMAT('            MATRIX 2--',I8,' ROWS BY ',I8,' COLUMNS')
14411      CALL DPWRST('XXX','BUG ')
14412      IERROR='YES'
14413      GOTO9000
14414 2119 CONTINUE
14415C
14416      DO2121I=1,NR1
14417      DO2122J=1,NC1
14418      DYM1=YM1(I,J)
14419      DYM2=YM2(I,J)
14420      DYM9=DYM1+DYM2
14421      YM9(I,J)=DYM9
14422 2122 CONTINUE
14423 2121 CONTINUE
14424      ITYP9='MATR'
14425      NR9=NR1
14426      NC9=NC1
14427      GOTO9000
14428C
14429 2130 CONTINUE
14430      IF(NR1.EQ.N2)GOTO2139
14431      WRITE(ICOUT,999)
14432      CALL DPWRST('XXX','BUG ')
14433      WRITE(ICOUT,2131)
14434 2131 FORMAT('***** ERROR IN MATARI--')
14435      CALL DPWRST('XXX','BUG ')
14436      WRITE(ICOUT,2132)
14437 2132 FORMAT('      FOR MATRIX ADDITION OF MATRIX 1 & VECTOR 2,')
14438      CALL DPWRST('XXX','BUG ')
14439      WRITE(ICOUT,2133)
14440 2133 FORMAT('      THE NUMBER OF ROWS AND COLUMNS IN MATRIX 1')
14441      CALL DPWRST('XXX','BUG ')
14442      WRITE(ICOUT,2134)
14443 2134 FORMAT('      MUST EQUAL')
14444      CALL DPWRST('XXX','BUG ')
14445      WRITE(ICOUT,2135)
14446 2135 FORMAT('      THE NUMBER OF ROWS IN VECTOR 2;')
14447      CALL DPWRST('XXX','BUG ')
14448      WRITE(ICOUT,2136)
14449 2136 FORMAT('      SUCH WAS NOT THE CASE HERE.')
14450      CALL DPWRST('XXX','BUG ')
14451      WRITE(ICOUT,2137)NR1,NC1
14452 2137 FORMAT('            MATRIX 1--',I8,' ROWS BY ',I8,' COLUMNS')
14453      CALL DPWRST('XXX','BUG ')
14454      WRITE(ICOUT,2138)N2
14455 2138 FORMAT('            VECTOR 2--',I8,' ROWS')
14456      CALL DPWRST('XXX','BUG ')
14457      IERROR='YES'
14458      GOTO9000
14459 2139 CONTINUE
14460C
14461      DO2141I=1,NR1
14462      DYM2=Y2(I)
14463      DO2142J=1,NC1
14464      DYM1=YM1(I,J)
14465      DYM9=DYM1+DYM2
14466      YM9(I,J)=DYM9
14467 2142 CONTINUE
14468 2141 CONTINUE
14469      ITYP9='MATR'
14470      NR9=NR1
14471      NC9=NC1
14472      IUPFLG='SUBS'
14473      GOTO9000
14474C
14475 2150 CONTINUE
14476      IF(N1.EQ.NR2)GOTO2159
14477      WRITE(ICOUT,999)
14478      CALL DPWRST('XXX','BUG ')
14479      WRITE(ICOUT,2151)
14480 2151 FORMAT('***** ERROR IN MATARI--')
14481      CALL DPWRST('XXX','BUG ')
14482      WRITE(ICOUT,2152)
14483 2152 FORMAT('      FOR MATRIX ADDITION OF VECTOR 1 & MATRIX 2,')
14484      CALL DPWRST('XXX','BUG ')
14485      WRITE(ICOUT,2153)
14486 2153 FORMAT('      THE NUMBER OF ROWS IN VECTOR 1;')
14487      CALL DPWRST('XXX','BUG ')
14488      WRITE(ICOUT,2154)
14489 2154 FORMAT('      MUST EQUAL')
14490      CALL DPWRST('XXX','BUG ')
14491      WRITE(ICOUT,2155)
14492 2155 FORMAT('      THE NUMBER OF ROWS AND COLUMNS IN MATRIX 2')
14493      CALL DPWRST('XXX','BUG ')
14494      WRITE(ICOUT,2156)
14495 2156 FORMAT('      SUCH WAS NOT THE CASE HERE.')
14496      CALL DPWRST('XXX','BUG ')
14497      WRITE(ICOUT,2157)N1
14498 2157 FORMAT('            VECTOR 1--',I8,' ROWS')
14499      CALL DPWRST('XXX','BUG ')
14500      WRITE(ICOUT,2158)NR2,NC2
14501 2158 FORMAT('            MATRIX 2--',I8,' ROWS BY ',I8,' COLUMNS')
14502      CALL DPWRST('XXX','BUG ')
14503      IERROR='YES'
14504      GOTO9000
14505 2159 CONTINUE
14506C
14507      DO2161I=1,NR2
14508      DYM1=Y1(I)
14509      DO2162J=1,NC2
14510      DYM2=YM2(I,J)
14511      DYM9=DYM1+DYM2
14512      YM9(I,J)=DYM9
14513 2162 CONTINUE
14514 2161 CONTINUE
14515      ITYP9='MATR'
14516      NR9=NR2
14517      NC9=NC2
14518      GOTO9000
14519C
14520 2170 CONTINUE
14521      DYM2=YS2
14522      DO2171I=1,NR1
14523      DO2172J=1,NC1
14524      DYM1=YM1(I,J)
14525      DYM9=DYM1+DYM2
14526      YM9(I,J)=DYM9
14527 2172 CONTINUE
14528 2171 CONTINUE
14529      ITYP9='MATR'
14530      NR9=NR1
14531      NC9=NC1
14532      IUPFLG='SUBS'
14533      GOTO9000
14534C
14535 2180 CONTINUE
14536      DYM1=YS1
14537      DO2181I=1,NR2
14538      DO2182J=1,NC2
14539      DYM2=YM2(I,J)
14540      DYM9=DYM1+DYM2
14541      YM9(I,J)=DYM9
14542 2182 CONTINUE
14543 2181 CONTINUE
14544      ITYP9='MATR'
14545      NR9=NR2
14546      NC9=NC2
14547      IUPFLG='SUBS'
14548      GOTO9000
14549C
14550C               *********************************************
14551C               **  STEP 22--                              **
14552C               **  TREAT THE MATRIX     SUBTRACTION CASE  **
14553C               *********************************************
14554C
14555 2200 CONTINUE
14556C
14557      IF(ITYPA1.EQ.'MATR'.AND.ITYPA2.EQ.'MATR')GOTO2210
14558      IF(ITYPA1.EQ.'MATR'.AND.ITYPA2.EQ.'VARI')GOTO2230
14559      IF(ITYPA1.EQ.'VARI'.AND.ITYPA2.EQ.'MATR')GOTO2250
14560      IF(ITYPA1.EQ.'MATR'.AND.ITYPA2.EQ.'PARA')GOTO2270
14561      IF(ITYPA1.EQ.'PARA'.AND.ITYPA2.EQ.'MATR')GOTO2280
14562C
14563      WRITE(ICOUT,999)
14564      CALL DPWRST('XXX','BUG ')
14565      WRITE(ICOUT,2201)
14566 2201 FORMAT('***** ERROR IN MATARI--')
14567      CALL DPWRST('XXX','BUG ')
14568      WRITE(ICOUT,2202)
14569 2202 FORMAT('      ILLEGAL ARGUMENT TYPES FOR MATRIX SUBTRACTION.')
14570      CALL DPWRST('XXX','BUG ')
14571      WRITE(ICOUT,2203)ITYPA1
14572 2203 FORMAT('            TYPE FOR ARGUMENT 1 = ',A4)
14573      CALL DPWRST('XXX','BUG ')
14574      WRITE(ICOUT,2204)ITYPA2
14575 2204 FORMAT('            TYPE FOR ARGUMENT 2 = ',A4)
14576      CALL DPWRST('XXX','BUG ')
14577      IERROR='YES'
14578      GOTO9000
14579C
14580 2210 CONTINUE
14581      IF(NR1.EQ.NR2.AND.NC1.EQ.NC2)GOTO2219
14582      WRITE(ICOUT,999)
14583      CALL DPWRST('XXX','BUG ')
14584      WRITE(ICOUT,2211)
14585 2211 FORMAT('***** ERROR IN MATARI--')
14586      CALL DPWRST('XXX','BUG ')
14587      WRITE(ICOUT,2212)
14588 2212 FORMAT('      FOR MATRIX SUBTRACTION OF MATRIX 1 & MATRIX 2,')
14589      CALL DPWRST('XXX','BUG ')
14590      WRITE(ICOUT,2213)
14591 2213 FORMAT('      THE NUMBER OF ROWS AND COLUMNS IN MATRIX 1')
14592      CALL DPWRST('XXX','BUG ')
14593      WRITE(ICOUT,2214)
14594 2214 FORMAT('      MUST EQUAL')
14595      CALL DPWRST('XXX','BUG ')
14596      WRITE(ICOUT,2215)
14597 2215 FORMAT('      THE NUMBER OF ROWS AND COLUMNS IN MATRIX 2;')
14598      CALL DPWRST('XXX','BUG ')
14599      WRITE(ICOUT,2216)
14600 2216 FORMAT('      SUCH WAS NOT THE CASE HERE.')
14601      CALL DPWRST('XXX','BUG ')
14602      WRITE(ICOUT,2217)NR1,NC1
14603 2217 FORMAT('            MATRIX 1--',I8,' ROWS BY ',I8,' COLUMNS')
14604      CALL DPWRST('XXX','BUG ')
14605      WRITE(ICOUT,2218)NR2,NC2
14606 2218 FORMAT('            MATRIX 2--',I8,' ROWS BY ',I8,' COLUMNS')
14607      CALL DPWRST('XXX','BUG ')
14608      IERROR='YES'
14609      GOTO9000
14610 2219 CONTINUE
14611C
14612C
14613      DO2221I=1,NR1
14614      DO2222J=1,NC1
14615      DYM1=YM1(I,J)
14616      DYM2=YM2(I,J)
14617      DYM9=DYM1-DYM2
14618      YM9(I,J)=DYM9
14619 2222 CONTINUE
14620 2221 CONTINUE
14621      ITYP9='MATR'
14622      NR9=NR1
14623      NC9=NC1
14624      IUPFLG='SUBS'
14625      GOTO9000
14626C
14627 2230 CONTINUE
14628      IF(NR1.EQ.N2)GOTO2239
14629      WRITE(ICOUT,999)
14630      CALL DPWRST('XXX','BUG ')
14631      WRITE(ICOUT,2231)
14632 2231 FORMAT('***** ERROR IN MATARI--')
14633      CALL DPWRST('XXX','BUG ')
14634      WRITE(ICOUT,2232)
14635 2232 FORMAT('      FOR MATRIX SUBTRACTION OF MATRIX 1 & VECTOR 2,')
14636      CALL DPWRST('XXX','BUG ')
14637      WRITE(ICOUT,2233)
14638 2233 FORMAT('      THE NUMBER OF ROWS AND COLUMNS IN MATRIX 1')
14639      CALL DPWRST('XXX','BUG ')
14640      WRITE(ICOUT,2234)
14641 2234 FORMAT('      MUST EQUAL')
14642      CALL DPWRST('XXX','BUG ')
14643      WRITE(ICOUT,2235)
14644 2235 FORMAT('      THE NUMBER OF ROWS IN VECTOR 2;')
14645      CALL DPWRST('XXX','BUG ')
14646      WRITE(ICOUT,2236)
14647 2236 FORMAT('      SUCH WAS NOT THE CASE HERE.')
14648      CALL DPWRST('XXX','BUG ')
14649      WRITE(ICOUT,2237)NR1,NC1
14650 2237 FORMAT('            MATRIX 1--',I8,' ROWS BY ',I8,' COLUMNS')
14651      CALL DPWRST('XXX','BUG ')
14652      WRITE(ICOUT,2238)N2
14653 2238 FORMAT('            VECTOR 2--',I8,' ROWS')
14654      CALL DPWRST('XXX','BUG ')
14655      IERROR='YES'
14656      GOTO9000
14657 2239 CONTINUE
14658C
14659      DO2241I=1,NR1
14660      DYM2=Y2(I)
14661      DO2242J=1,NC1
14662      DYM1=YM1(I,J)
14663      DYM9=DYM1-DYM2
14664      YM9(I,J)=DYM9
14665 2242 CONTINUE
14666 2241 CONTINUE
14667      ITYP9='MATR'
14668      NR9=NR1
14669      NC9=NC1
14670      IUPFLG='SUBS'
14671      GOTO9000
14672C
14673 2250 CONTINUE
14674      IF(N1.EQ.NR2)GOTO2259
14675      WRITE(ICOUT,999)
14676      CALL DPWRST('XXX','BUG ')
14677      WRITE(ICOUT,2251)
14678 2251 FORMAT('***** ERROR IN MATARI--')
14679      CALL DPWRST('XXX','BUG ')
14680      WRITE(ICOUT,2252)
14681 2252 FORMAT('      FOR MATRIX SUBTRACTION OF VECTOR 1 & MATRIX 2,')
14682      CALL DPWRST('XXX','BUG ')
14683      WRITE(ICOUT,2253)
14684 2253 FORMAT('      THE NUMBER OF ROWS IN VECTOR 1;')
14685      CALL DPWRST('XXX','BUG ')
14686      WRITE(ICOUT,2254)
14687 2254 FORMAT('      MUST EQUAL')
14688      CALL DPWRST('XXX','BUG ')
14689      WRITE(ICOUT,2255)
14690 2255 FORMAT('      THE NUMBER OF ROWS AND COLUMNS IN MATRIX 2')
14691      CALL DPWRST('XXX','BUG ')
14692      WRITE(ICOUT,2256)
14693 2256 FORMAT('      SUCH WAS NOT THE CASE HERE.')
14694      CALL DPWRST('XXX','BUG ')
14695      WRITE(ICOUT,2257)N1
14696 2257 FORMAT('            VECTOR 1--',I8,' ROWS')
14697      CALL DPWRST('XXX','BUG ')
14698      WRITE(ICOUT,2258)NR2,NC2
14699 2258 FORMAT('            MATRIX 2--',I8,' ROWS BY ',I8,' COLUMNS')
14700      CALL DPWRST('XXX','BUG ')
14701      IERROR='YES'
14702      GOTO9000
14703 2259 CONTINUE
14704C
14705      DO2261I=1,NR2
14706      DYM1=Y1(I)
14707      DO2262J=1,NC2
14708      DYM2=YM2(I,J)
14709      DYM9=DYM1-DYM2
14710      YM9(I,J)=DYM9
14711 2262 CONTINUE
14712 2261 CONTINUE
14713      ITYP9='MATR'
14714      NR9=NR2
14715      NC9=NC2
14716      IUPFLG='SUBS'
14717      GOTO9000
14718C
14719 2270 CONTINUE
14720      DYM2=YS2
14721      DO2271I=1,NR1
14722      DO2272J=1,NC1
14723      DYM1=YM1(I,J)
14724      DYM9=DYM1-DYM2
14725      YM9(I,J)=DYM9
14726 2272 CONTINUE
14727 2271 CONTINUE
14728      ITYP9='MATR'
14729      NR9=NR1
14730      NC9=NC1
14731      IUPFLG='SUBS'
14732      GOTO9000
14733C
14734 2280 CONTINUE
14735      DYM1=YS1
14736      DO2281I=1,NR2
14737      DO2282J=1,NC2
14738      DYM2=YM2(I,J)
14739      DYM9=DYM1-DYM2
14740      YM9(I,J)=DYM9
14741 2282 CONTINUE
14742 2281 CONTINUE
14743      ITYP9='MATR'
14744      NR9=NR2
14745      NC9=NC2
14746      IUPFLG='SUBS'
14747      GOTO9000
14748C
14749C               *********************************************
14750C               **  STEP 23--                              **
14751C               **  TREAT THE MATRIX  MULTIPLICATION CASE  **
14752C               *********************************************
14753C
14754 2300 CONTINUE
14755C
14756      IF(ITYPA1.EQ.'MATR'.AND.ITYPA2.EQ.'MATR')GOTO2310
14757      IF(ITYPA1.EQ.'MATR'.AND.ITYPA2.EQ.'VARI')GOTO2330
14758      IF(ITYPA1.EQ.'VARI'.AND.ITYPA2.EQ.'MATR')GOTO2350
14759      IF(ITYPA1.EQ.'MATR'.AND.ITYPA2.EQ.'PARA')GOTO2370
14760      IF(ITYPA1.EQ.'PARA'.AND.ITYPA2.EQ.'MATR')GOTO2380
14761C
14762      WRITE(ICOUT,999)
14763      CALL DPWRST('XXX','BUG ')
14764      WRITE(ICOUT,2301)
14765 2301 FORMAT('***** ERROR IN MATARI--')
14766      CALL DPWRST('XXX','BUG ')
14767      WRITE(ICOUT,2302)
14768 2302 FORMAT('      ILLEGAL ARGUMENT TYPES FOR MATRIX MULTIPLIC.')
14769      CALL DPWRST('XXX','BUG ')
14770      WRITE(ICOUT,2303)ITYPA1
14771 2303 FORMAT('            TYPE FOR ARGUMENT 1 = ',A4)
14772      CALL DPWRST('XXX','BUG ')
14773      WRITE(ICOUT,2304)ITYPA2
14774 2304 FORMAT('            TYPE FOR ARGUMENT 2 = ',A4)
14775      CALL DPWRST('XXX','BUG ')
14776      IERROR='YES'
14777      GOTO9000
14778C
14779 2310 CONTINUE
14780      IF(NC1.EQ.NR2)GOTO2319
14781      WRITE(ICOUT,999)
14782      CALL DPWRST('XXX','BUG ')
14783      WRITE(ICOUT,2311)
14784 2311 FORMAT('***** ERROR IN MATARI--')
14785      CALL DPWRST('XXX','BUG ')
14786      WRITE(ICOUT,2312)
14787 2312 FORMAT('      FOR MATRIX MULTIPLIC. OF MATRIX 1 & MATRIX 2,')
14788      CALL DPWRST('XXX','BUG ')
14789      WRITE(ICOUT,2313)
14790 2313 FORMAT('      THE NUMBER OF COLUMNS IN MATRIX 1')
14791      CALL DPWRST('XXX','BUG ')
14792      WRITE(ICOUT,2314)
14793 2314 FORMAT('      MUST EQUAL')
14794      CALL DPWRST('XXX','BUG ')
14795      WRITE(ICOUT,2315)
14796 2315 FORMAT('      THE NUMBER OF ROWS    IN MATRIX 2;')
14797      CALL DPWRST('XXX','BUG ')
14798      WRITE(ICOUT,2316)
14799 2316 FORMAT('      SUCH WAS NOT THE CASE HERE.')
14800      CALL DPWRST('XXX','BUG ')
14801      WRITE(ICOUT,2317)NR1,NC1
14802 2317 FORMAT('            MATRIX 1--',I8,' ROWS BY ',I8,' COLUMNS')
14803      CALL DPWRST('XXX','BUG ')
14804      WRITE(ICOUT,2318)NR2,NC2
14805 2318 FORMAT('            MATRIX 2--',I8,' ROWS BY ',I8,' COLUMNS')
14806      CALL DPWRST('XXX','BUG ')
14807      IERROR='YES'
14808      GOTO9000
14809 2319 CONTINUE
14810C
14811      DO2321I=1,NR1
14812      DO2322J=1,NC2
14813      DSUM=0.0D0
14814      DO2323K=1,NC1
14815      DYM1=YM1(I,K)
14816      DYM2=YM2(K,J)
14817      DYM9=DYM1*DYM2
14818      DSUM=DSUM+DYM9
14819 2323 CONTINUE
14820      YM9(I,J)=DSUM
14821 2322 CONTINUE
14822 2321 CONTINUE
14823      ITYP9='MATR'
14824      NR9=NR1
14825      NC9=NC2
14826      IUPFLG='FULL'
14827      GOTO9000
14828C
14829 2330 CONTINUE
14830      IF(NC1.EQ.N2)GOTO2339
14831      WRITE(ICOUT,999)
14832      CALL DPWRST('XXX','BUG ')
14833      WRITE(ICOUT,2331)
14834 2331 FORMAT('***** ERROR IN MATARI--')
14835      CALL DPWRST('XXX','BUG ')
14836      WRITE(ICOUT,2332)
14837 2332 FORMAT('      FOR MATRIX MULTIPLIC. OF MATRIX 1 & VECTOR 2,')
14838      CALL DPWRST('XXX','BUG ')
14839      WRITE(ICOUT,2333)
14840 2333 FORMAT('      THE NUMBER OF COLUMNS IN MATRIX 1')
14841      CALL DPWRST('XXX','BUG ')
14842      WRITE(ICOUT,2334)
14843 2334 FORMAT('      MUST EQUAL')
14844      CALL DPWRST('XXX','BUG ')
14845      WRITE(ICOUT,2335)
14846 2335 FORMAT('      THE NUMBER OF ROWS IN VECTOR 2;')
14847      CALL DPWRST('XXX','BUG ')
14848      WRITE(ICOUT,2336)
14849 2336 FORMAT('      SUCH WAS NOT THE CASE HERE.')
14850      CALL DPWRST('XXX','BUG ')
14851      WRITE(ICOUT,2337)NR1,NC1
14852 2337 FORMAT('            MATRIX 1--',I8,' ROWS BY ',I8,' COLUMNS')
14853      CALL DPWRST('XXX','BUG ')
14854      WRITE(ICOUT,2338)N2
14855 2338 FORMAT('            VECTOR 2--',I8,' ROWS')
14856      CALL DPWRST('XXX','BUG ')
14857      IERROR='YES'
14858      GOTO9000
14859 2339 CONTINUE
14860C
14861      DO2341I=1,NR1
14862        J=1
14863        DSUM=0.0D0
14864        DO2343K=1,NC1
14865          DYM1=YM1(I,K)
14866          DYM2=Y2(K)
14867          DYM9=DYM1*DYM2
14868          DSUM=DSUM+DYM9
14869 2343   CONTINUE
14870        VECT9(I)=DSUM
14871 2341 CONTINUE
14872      ITYP9='VECT'
14873      NVECT9=NR1
14874      IUPFLG='FULL'
14875      GOTO9000
14876C
14877 2350 CONTINUE
14878      IF(1.EQ.NR2)GOTO2359
14879      WRITE(ICOUT,999)
14880      CALL DPWRST('XXX','BUG ')
14881      WRITE(ICOUT,2351)
14882 2351 FORMAT('***** ERROR IN MATARI--')
14883      CALL DPWRST('XXX','BUG ')
14884      WRITE(ICOUT,2352)
14885 2352 FORMAT('      FOR MATRIX MULTIPLIC. OF VECTOR 1 & MATRIX 2,')
14886      CALL DPWRST('XXX','BUG ')
14887      WRITE(ICOUT,2355)
14888 2355 FORMAT('      THE NUMBER OF ROWS IN MATRIX 2 MUST = 1')
14889      CALL DPWRST('XXX','BUG ')
14890      WRITE(ICOUT,2356)
14891 2356 FORMAT('      SUCH WAS NOT THE CASE HERE.')
14892      CALL DPWRST('XXX','BUG ')
14893      WRITE(ICOUT,2358)NR2,NC2
14894 2358 FORMAT('            MATRIX 2--',I8,' ROWS BY ',I8,' COLUMNS')
14895      CALL DPWRST('XXX','BUG ')
14896      IERROR='YES'
14897      GOTO9000
14898 2359 CONTINUE
14899C
14900      DO2361I=1,NR1
14901        DO2362J=1,NC2
14902          DSUM=0.0D0
14903          K=1
14904          DYM1=Y1(I)
14905          DYM2=YM2(K,J)
14906          DYM9=DYM1*DYM2
14907          DSUM=DSUM+DYM9
14908          YM9(I,J)=DSUM
14909 2362   CONTINUE
14910 2361 CONTINUE
14911      ITYP9='MATR'
14912      NR9=N1
14913      NC9=NC2
14914      IUPFLG='FULL'
14915      GOTO9000
14916C
14917 2370 CONTINUE
14918      DYM2=YS2
14919      DO2371I=1,NR1
14920      DO2372J=1,NC1
14921      DYM1=YM1(I,J)
14922      DYM9=DYM1*DYM2
14923      YM9(I,J)=DYM9
14924 2372 CONTINUE
14925 2371 CONTINUE
14926      ITYP9='MATR'
14927      NR9=NR1
14928      NC9=NC1
14929      IUPFLG='FULL'
14930      GOTO9000
14931C
14932 2380 CONTINUE
14933      DYM1=YS1
14934      DO2381I=1,NR2
14935      DO2382J=1,NC2
14936      DYM2=YM2(I,J)
14937      DYM9=DYM1*DYM2
14938      YM9(I,J)=DYM9
14939 2382 CONTINUE
14940 2381 CONTINUE
14941      ITYP9='MATR'
14942      NR9=NR2
14943      NC9=NC2
14944      IUPFLG='FULL'
14945      GOTO9000
14946C
14947C               *********************************************
14948C               **  STEP 24--                              **
14949C               **  TREAT THE MATRIX     SOLUTION    CASE  **
14950C               **  REFERENCE--PRESS ET AL, PAGE 37        **
14951C               *********************************************
14952C
14953 2400 CONTINUE
14954C
14955      IF(NR1.EQ.N2)GOTO2409
14956      WRITE(ICOUT,999)
14957      CALL DPWRST('XXX','BUG ')
14958      WRITE(ICOUT,2401)
14959 2401 FORMAT('***** ERROR IN MATARI--')
14960      CALL DPWRST('XXX','BUG ')
14961      WRITE(ICOUT,2402)
14962 2402 FORMAT('      FOR SOLVING A MATRIX EQUATION SUCH AS A*X = B,')
14963      CALL DPWRST('XXX','BUG ')
14964      WRITE(ICOUT,2403)
14965 2403 FORMAT('      THE NUMBER OF ROWS IN THE LEFT-SIDE MATRIX')
14966      CALL DPWRST('XXX','BUG ')
14967      WRITE(ICOUT,2404)
14968 2404 FORMAT('      MUST EQUAL')
14969      CALL DPWRST('XXX','BUG ')
14970      WRITE(ICOUT,2405)
14971 2405 FORMAT('      THE NUMBER OF ROWS IN THE RIGHT-SIDE VECTOR;')
14972      CALL DPWRST('XXX','BUG ')
14973      WRITE(ICOUT,2406)
14974 2406 FORMAT('      SUCH WAS NOT THE CASE HERE.')
14975      CALL DPWRST('XXX','BUG ')
14976      WRITE(ICOUT,2407)NR1
14977 2407 FORMAT('              NUMBER OF ROWS IN THE MATRIX = ',I8)
14978      CALL DPWRST('XXX','BUG ')
14979      WRITE(ICOUT,2408)N2
14980 2408 FORMAT('              NUMBER OF ROWS IN THE VECTOR = ',I8)
14981      CALL DPWRST('XXX','BUG ')
14982      IERROR='YES'
14983      GOTO9000
14984 2409 CONTINUE
14985C
14986      DO2451I=1,N2
14987CCCCC VECT9(I)=YM2(1,I)
14988CCCCC VECT9(I)=YM2(I,1)
14989      VECT9(I)=Y2(I)
14990 2451 CONTINUE
14991C
14992CCCCC JULY 1993.  REPLACE NUMERICAL RECIPES ALGORITHM WITH LINPACK
14993CCCCC ALGORITHM.
14994CCCCC CALL LUDCMP(YMJUNK,NR1,MAXROM,INDEX,DP1M1)
14995CCCCC CALL LUBKSB(YMJUNK,NR1,MAXROM,INDEX,VECT9)
14996      CALL SGECO(YM1,MAXROM,NR1,INDEX,RCOND,Y3)
14997      IF(IFEEDB.EQ.'ON')THEN
14998        WRITE(ICOUT,999)
14999        CALL DPWRST('XXX','BUG ')
15000        WRITE(ICOUT,2461)RCOND
15001        CALL DPWRST('XXX','TEXT ')
15002      ENDIF
15003 2461 FORMAT('THE RECIPROCAL CONDITION NUMBER FOR THE MATRIX = ',E15.7)
15004      EPS=1.0E-20
15005      IF(RCOND.LE.EPS)THEN
15006        WRITE(ICOUT,999)
15007        CALL DPWRST('XXX','BUG ')
15008        WRITE(ICOUT,2471)
15009        CALL DPWRST('XXX','ERRO ')
15010        WRITE(ICOUT,2472)
15011        CALL DPWRST('XXX','ERRO ')
15012        IERROR='YES'
15013      ELSE
15014        IJOB=0
15015        CALL SGESL(YM1,MAXROM,NR1,INDEX,VECT9,IJOB)
15016      END IF
15017 2471 FORMAT('****** ERROR IN MATARI ********')
15018 2472 FORMAT('       THE INPUT MATRIX IS SINGULAR')
15019CCCCC END CHANGE
15020C
15021      ITYP9='VECT'
15022      NVECT9=NR1
15023      IUPFLG='FULL'
15024      GOTO9000
15025C
15026C               *********************************************
15027C               **  STEP 25--                              **
15028C               **  TREAT THE MATRIX     INVERSE     CASE  **
15029C               **  REFERENCE--PRESS ET AL, PAGE 38        **
15030C               *********************************************
15031C
15032 2500 CONTINUE
15033C
15034      IF(NR1.NE.NC1)THEN
15035        WRITE(ICOUT,999)
15036        CALL DPWRST('XXX','BUG ')
15037        WRITE(ICOUT,2501)
15038 2501   FORMAT('***** ERROR IN MATRIX INVERSE--')
15039        CALL DPWRST('XXX','BUG ')
15040        WRITE(ICOUT,2502)
15041 2502   FORMAT('      FOR MATRIX INVERSE, THE NUMBER OF ROWS IN THE')
15042        CALL DPWRST('XXX','BUG ')
15043        WRITE(ICOUT,2503)
15044 2503   FORMAT('      MATRIX MUST EQUAL THE NUMBER OF COLUMNS IN THE ',
15045     1         'MATRIX.')
15046        CALL DPWRST('XXX','BUG ')
15047        WRITE(ICOUT,2504)NR1
15048 2504   FORMAT('            NUMBER OF ROWS    = ',I8)
15049        CALL DPWRST('XXX','BUG ')
15050        WRITE(ICOUT,2505)NC1
15051 2505   FORMAT('            NUMBER OF COLUMNS = ',I8)
15052        CALL DPWRST('XXX','BUG ')
15053        IERROR='YES'
15054        GOTO9000
15055      ENDIF
15056C
15057      DO2511I=1,NR1
15058        DO2512J=1,NC1
15059          YM9(I,J)=0.0
15060 2512   CONTINUE
15061        YM9(I,I)=1.0
15062 2511 CONTINUE
15063CCCCC JULY 1993.  REPLACE NUMERICAL RECIPES ALGORITHM WITH LINPACK
15064CCCCC ALGORITHM.
15065C
15066CCCCC CALL LUDCMP(YMJUNK,NR1,MAXROM,INDEX,DP1M1)
15067C
15068CCCCC DO2521J=1,NR1
15069CCCCC CALL LUBKSB(YMJUNK,NR1,MAXROM,INDEX,YM9(1,J))
15070C2521 CONTINUE
15071      CALL SGECO(YM1,MAXROM,NR1,INDEX,RCOND,Y3)
15072      IF(IFEEDB.EQ.'ON')THEN
15073        WRITE(ICOUT,999)
15074        CALL DPWRST('XXX','BUG ')
15075        WRITE(ICOUT,2521)RCOND
15076        CALL DPWRST('XXX','TEXT ')
15077      ENDIF
15078 2521 FORMAT('THE RECIPROCAL CONDITION NUMBER FOR THE MATRIX = ',G15.7)
15079      EPS=1.0E-20
15080      IF(RCOND.LE.EPS)THEN
15081        WRITE(ICOUT,999)
15082        CALL DPWRST('XXX','BUG ')
15083        WRITE(ICOUT,2561)
15084        CALL DPWRST('XXX','ERRO')
15085        WRITE(ICOUT,2523)
15086 2523   FORMAT('       THE INPUT MATRIX IS SINGULAR.')
15087        CALL DPWRST('XXX','ERRO')
15088        IERROR='YES'
15089      ELSE
15090        IJOB=1
15091        CALL SGEDI(YM1,MAXROM,NR1,INDEX,Y3,Y4,IJOB)
15092        DO2531J=1,NC1
15093          DO2532I=1,NR1
15094            YM9(I,J)=YM1(I,J)
15095 2532     CONTINUE
15096 2531   CONTINUE
15097      END IF
15098CCCCC END CHANGE
15099C
15100      ITYP9='MATR'
15101      NR9=NR1
15102      NC9=NC1
15103      IUPFLG='FULL'
15104      GOTO9000
15105C
15106C               *********************************************
15107C               **  STEP 25B-                              **
15108C               **  TREAT THE MATRIX CONDITION NUMBER CASE **
15109C               *********************************************
15110C
15111 2560 CONTINUE
15112C
15113      IF(NR1.NE.NC1)THEN
15114        WRITE(ICOUT,999)
15115        CALL DPWRST('XXX','BUG ')
15116        WRITE(ICOUT,2561)
15117 2561   FORMAT('***** ERROR IN MATRIX CONDITION--')
15118        CALL DPWRST('XXX','BUG ')
15119        WRITE(ICOUT,2562)
15120 2562   FORMAT('      FOR MATRIX CONDITION NUMBER, THE NUMBER OF ',
15121     1         'ROWS IN THE')
15122        CALL DPWRST('XXX','BUG ')
15123        WRITE(ICOUT,2563)
15124 2563   FORMAT('      MATRIX MUST EQUAL THE NUMBER OF COLUMNS IN THE ',
15125     1         'MATRIX.')
15126        CALL DPWRST('XXX','BUG ')
15127        WRITE(ICOUT,2564)NR1
15128 2564   FORMAT('            NUMBER OF ROWS    = ',I8)
15129        CALL DPWRST('XXX','BUG ')
15130        WRITE(ICOUT,2565)NC1
15131 2565   FORMAT('            NUMBER OF COLUMNS = ',I8)
15132        CALL DPWRST('XXX','BUG ')
15133        IERROR='YES'
15134        GOTO9000
15135      ENDIF
15136C
15137      CALL SGECO(YM1,MAXROM,NR1,INDEX,RCOND,Y3)
15138      IF(IFEEDB.EQ.'ON')THEN
15139        WRITE(ICOUT,999)
15140        CALL DPWRST('XXX','BUG ')
15141        WRITE(ICOUT,2521)RCOND
15142        CALL DPWRST('XXX','TEXT ')
15143      ENDIF
15144C
15145      ITYP9='SCAL'
15146      SCAL9=RCOND
15147      IF(IMCASE.EQ.'MACN')SCAL9=1.0/RCOND
15148      IUPFLG='FULL'
15149      GOTO9000
15150C
15151C               *********************************************
15152C               **  STEP 26--                              **
15153C               **  TREAT THE MATRIX     TRANSPOSE   CASE  **
15154C               *********************************************
15155C
15156 2600 CONTINUE
15157C
15158      IF(NR1.GT.MAXCOM)THEN
15159        WRITE(ICOUT,999)
15160        CALL DPWRST('XXX','BUG ')
15161        WRITE(ICOUT,2601)
15162 2601   FORMAT('***** ERROR IN MATARI--')
15163        CALL DPWRST('XXX','BUG ')
15164        WRITE(ICOUT,2603)NR1
15165 2603   FORMAT('      THE NUMBER OF ROWS IN THE MATRIX,',I5,
15166     1         'EXCEEDS THE MAXIMUM')
15167        CALL DPWRST('XXX','BUG ')
15168        WRITE(ICOUT,2605)MAXCOM
15169 2605   FORMAT('      NUMBER OF COLUMNS FOR A MATRIX,',I5,'.')
15170        CALL DPWRST('XXX','BUG ')
15171        WRITE(ICOUT,2607)
15172 2607   FORMAT('      THE MATRIX TRANSPOSE WAS NOT COMPUTED.')
15173        CALL DPWRST('XXX','BUG ')
15174        IERROR='YES'
15175        GOTO9000
15176      ENDIF
15177C
15178      DO2611I=1,NR1
15179      DO2612J=1,NC1
15180      YM9(J,I)=YM1(I,J)
15181 2612 CONTINUE
15182 2611 CONTINUE
15183C
15184      ITYP9='MATR'
15185      NR9=NC1
15186      NC9=NR1
15187      IUPFLG='FULL'
15188      GOTO9000
15189C
15190C               *********************************************
15191C               **  STEP 27--                              **
15192C               **  TREAT THE MATRIX     ADJOINT     CASE  **
15193C               *********************************************
15194CCCCC JULY 1993.  IMPLENENT THIS COMMAND.  NOTE THAT THE CLASSICAL
15195CCCCC ADJOINT IS ESSENTIALLY THE MATRIX CONTAINING THE COFACTORS
15196CCCCC FOR EACH ELEMENT.  THIS CALCULATES THE DETERMINANT AT
15197CCCCC EACH MATRIX SUB-ELEMENT, SO CAN GET TIME-CONSUMING FOR LARGE
15198CCCCC MATRICES.
15199C
15200 2700 CONTINUE
15201C
15202CCCCC WRITE(ICOUT,999)
15203CCCCC CALL DPWRST('XXX','BUG ')
15204CCCCC WRITE(ICOUT,2711)
15205C2711 FORMAT('***** ERROR IN MATARI--')
15206CCCCC CALL DPWRST('XXX','BUG ')
15207CCCCC WRITE(ICOUT,2712)
15208C2712 FORMAT('      THE MATRIX ADJOINT COMMAND')
15209CCCCC CALL DPWRST('XXX','BUG ')
15210CCCCC WRITE(ICOUT,2713)
15211C2713 FORMAT('      IS NOT YET IMPLEMENTED.')
15212CCCCC CALL DPWRST('XXX','BUG ')
15213CCCCC IERROR='YES'
15214C
15215      IF(NR1.EQ.NC1)GOTO2709
15216      WRITE(ICOUT,999)
15217      CALL DPWRST('XXX','BUG ')
15218      WRITE(ICOUT,2701)
15219 2701 FORMAT('***** ERROR IN MATARI--')
15220      CALL DPWRST('XXX','BUG ')
15221      WRITE(ICOUT,2702)
15222 2702 FORMAT('      FOR MATRIX ADJOINT,')
15223      CALL DPWRST('XXX','BUG ')
15224      WRITE(ICOUT,2703)
15225 2703 FORMAT('      THE NUMBER OF ROWS IN THE MATRIX')
15226      CALL DPWRST('XXX','BUG ')
15227      WRITE(ICOUT,2704)
15228 2704 FORMAT('      MUST EQUAL')
15229      CALL DPWRST('XXX','BUG ')
15230      WRITE(ICOUT,2705)
15231 2705 FORMAT('      THE NUMBER OF COLUMNS IN THE MATRIX;')
15232      CALL DPWRST('XXX','BUG ')
15233      WRITE(ICOUT,2706)
15234 2706 FORMAT('      SUCH WAS NOT THE CASE HERE.')
15235      CALL DPWRST('XXX','BUG ')
15236      WRITE(ICOUT,2707)NR1
15237 2707 FORMAT('            NUMBER OF ROWS    =',I8)
15238      CALL DPWRST('XXX','BUG ')
15239      WRITE(ICOUT,2708)NC1
15240 2708 FORMAT('            NUMBER OF COLUMNS =',I8)
15241      CALL DPWRST('XXX','BUG ')
15242      IERROR='YES'
15243      GOTO9000
15244 2709 CONTINUE
15245C
15246      DO2790IROWID=1,NR1
15247      IYS2=IROWID
15248      DO2780ICOLID=1,NC1
15249      IYS3=ICOLID
15250      I2=0
15251      J2=0
15252      DO2711I=1,NR1
15253      IF(I.EQ.IYS2)GOTO2711
15254      I2=I2+1
15255      NRJ=I2
15256      J2=0
15257      DO2712J=1,NC1
15258      IF(J.EQ.IYS3)GOTO2712
15259      J2=J2+1
15260      NCJ=J2
15261      YM2(I2,J2)=YM1(I,J)
15262 2712 CONTINUE
15263 2711 CONTINUE
15264C
15265      IF(NRJ.GE.1.AND.NCJ.GE.1)GOTO2729
15266      WRITE(ICOUT,999)
15267      CALL DPWRST('XXX','BUG ')
15268      WRITE(ICOUT,2721)
15269 2721 FORMAT('***** ERROR IN MATARI--')
15270      CALL DPWRST('XXX','BUG ')
15271      WRITE(ICOUT,2722)
15272 2722 FORMAT('      FOR MATRIX COFACTOR,')
15273      CALL DPWRST('XXX','BUG ')
15274      WRITE(ICOUT,2723)
15275 2723 FORMAT('      THE NUMBER OF ROWS IN THE SUBMATRIX, AND')
15276      CALL DPWRST('XXX','BUG ')
15277      WRITE(ICOUT,2724)
15278 2724 FORMAT('      THE NUMBER OF COLUMNS IN THE SUBMATRIX')
15279      CALL DPWRST('XXX','BUG ')
15280      WRITE(ICOUT,2725)
15281 2725 FORMAT('      MUST BOTH BE 1 OR LARGER;')
15282      CALL DPWRST('XXX','BUG ')
15283      WRITE(ICOUT,2726)
15284 2726 FORMAT('      SUCH WAS NOT THE CASE HERE.')
15285      CALL DPWRST('XXX','BUG ')
15286      WRITE(ICOUT,2727)NRJ
15287 2727 FORMAT('            NUMBER OF ROWS    =',I8)
15288      CALL DPWRST('XXX','BUG ')
15289      WRITE(ICOUT,2728)NCJ
15290 2728 FORMAT('            NUMBER OF COLUMNS =',I8)
15291      CALL DPWRST('XXX','BUG ')
15292      IERROR='YES'
15293      GOTO9000
15294 2729 CONTINUE
15295C
15296      IF(NRJ.EQ.NCJ)GOTO2739
15297      WRITE(ICOUT,999)
15298      CALL DPWRST('XXX','BUG ')
15299      WRITE(ICOUT,2731)
15300 2731 FORMAT('***** ERROR IN MATARI--')
15301      CALL DPWRST('XXX','BUG ')
15302      WRITE(ICOUT,2732)
15303 2732 FORMAT('      FOR MATRIX ADJOINT,')
15304      CALL DPWRST('XXX','BUG ')
15305      WRITE(ICOUT,2733)
15306 2733 FORMAT('      THE NUMBER OF ROWS IN THE SUBMATRIX')
15307      CALL DPWRST('XXX','BUG ')
15308      WRITE(ICOUT,2734)
15309 2734 FORMAT('      MUST EQUAL')
15310      CALL DPWRST('XXX','BUG ')
15311      WRITE(ICOUT,2735)
15312 2735 FORMAT('      THE NUMBER OF COLUMNS IN THE SUBMATRIX;')
15313      CALL DPWRST('XXX','BUG ')
15314      WRITE(ICOUT,2736)
15315 2736 FORMAT('      SUCH WAS NOT THE CASE HERE.')
15316      CALL DPWRST('XXX','BUG ')
15317      WRITE(ICOUT,2737)NRJ
15318 2737 FORMAT('            NUMBER OF ROWS    =',I8)
15319      CALL DPWRST('XXX','BUG ')
15320      WRITE(ICOUT,2738)NCJ
15321 2738 FORMAT('            NUMBER OF COLUMNS =',I8)
15322      CALL DPWRST('XXX','BUG ')
15323      IERROR='YES'
15324      GOTO9000
15325 2739 CONTINUE
15326C
15327      CALL SGECO(YM2,MAXROM,NRJ,INDEX,RCOND,Y3)
15328      EPS=1.0E-20
15329      IF(RCOND.LE.EPS)THEN
15330        WRITE(ICOUT,999)
15331        CALL DPWRST('XXX','BUG ')
15332        WRITE(ICOUT,2771)
15333        CALL DPWRST('XXX','ERRO ')
15334        WRITE(ICOUT,2772)
15335        CALL DPWRST('XXX','ERRO ')
15336        WRITE(ICOUT,2773)IROWID,ICOLID
15337        CALL DPWRST('XXX','ERRO ')
15338        COFACT=0.0
15339        IERROR='YES'
15340      ELSE
15341        IJOB=10
15342        CALL SGEDI(YM2,MAXROM,NRJ,INDEX,Y3,Y4,IJOB)
15343        DET=Y3(1)*10.0**Y3(2)
15344        COFACT=DET
15345        IYS23=IYS2+IYS3
15346        IREM=IYS23-2*(IYS23/2)
15347        IF(IREM.EQ.1)COFACT=(-COFACT)
15348      END IF
15349 2771 FORMAT('****** ERROR IN MATARI ********')
15350 2772 FORMAT('       UNABLE TO COMPUTE THE DETERMINANT FOR')
15351 2773 FORMAT('       ROW ',I4,' AND COLUMN ',I4)
15352CCCCC END CHANGE
15353C
15354      YM9(IROWID,ICOLID)=COFACT
15355 2780 CONTINUE
15356 2790 CONTINUE
15357C
15358      ITYP9='MATR'
15359      NC9=NR1
15360      NR9=NR1
15361      SCAL9=COFACT
15362      IUPFLG='FULL'
15363      GOTO9000
15364C
15365C               *******************************************************
15366C               **  STEP 28--                                        **
15367C               **  TREAT THE MATRIX CHARACTERISTIC EQUATION   CASE  **
15368C               *******************************************************
15369C
15370 2800 CONTINUE
15371C
15372      WRITE(ICOUT,999)
15373      CALL DPWRST('XXX','BUG ')
15374      WRITE(ICOUT,2811)
15375 2811 FORMAT('***** ERROR IN MATARI--')
15376      CALL DPWRST('XXX','BUG ')
15377      WRITE(ICOUT,2812)
15378 2812 FORMAT('      THE MATRIX CHARACTERISTIC EQUATION COMMAND')
15379      CALL DPWRST('XXX','BUG ')
15380      WRITE(ICOUT,2813)
15381 2813 FORMAT('      IS NOT YET IMPLEMENTED.')
15382      CALL DPWRST('XXX','BUG ')
15383      IERROR='YES'
15384      GOTO9000
15385C
15386C
15387C               *********************************************
15388C               **  STEP 29--                              **
15389C               **  TREAT THE MATRIX     EIGENVALUES CASE  **
15390C               *********************************************
15391C
15392 2900 CONTINUE
15393C
15394      IF(NR1.NE.NC1)THEN
15395        WRITE(ICOUT,999)
15396        CALL DPWRST('XXX','BUG ')
15397        WRITE(ICOUT,2901)
15398 2901   FORMAT('***** ERROR IN MATRIX EIGENVALUES--')
15399        CALL DPWRST('XXX','BUG ')
15400        WRITE(ICOUT,2903)
15401 2903   FORMAT('      THE NUMBER OF ROWS IN THE MATRIX MUST EQUAL THE')
15402        CALL DPWRST('XXX','BUG ')
15403        WRITE(ICOUT,2905)
15404 2905   FORMAT('      NUMBER OF COLUMNS IN THE MATRIX;  SUCH WAS NOT ',
15405     1         'THE CASE HERE.')
15406        CALL DPWRST('XXX','BUG ')
15407        WRITE(ICOUT,2907)NR1
15408 2907   FORMAT('            NUMBER OF ROWS    =',I8)
15409        CALL DPWRST('XXX','BUG ')
15410        WRITE(ICOUT,2908)NC1
15411 2908   FORMAT('            NUMBER OF COLUMNS =',I8)
15412        CALL DPWRST('XXX','BUG ')
15413        IERROR='YES'
15414        GOTO9000
15415      ENDIF
15416C
15417      DO2911I=1,NR1
15418        I2=I
15419        DO2912J=I,NC1
15420          J2=J
15421          YM1IJ=YM1(I,J)
15422          YM1JI=YM1(J,I)
15423          IF(YM1IJ.NE.YM1JI)GOTO2930
15424 2912   CONTINUE
15425 2911 CONTINUE
15426      GOTO2939
15427C
15428CCCCC JULY 1993.  ADD SUPPORT FOR NON-SYMMETRIC CASE.  THIS CASE
15429CCCCC CAN HAVE COMPLEX EIGENVALUES.  ROWS 1 THROUGH N OF THE OUTPUT
15430CCCCC VECTOR WILL CONTAIN THE REAL COMPONENT, ROWS N+1 THROUGH 2*N
15431CCCCC WILL CONTAIN THE COMPLEX COMPONENT.
15432 2930 CONTINUE
15433CCCCC WRITE(ICOUT,999)
15434CCCCC CALL DPWRST('XXX','BUG ')
15435CCCCC WRITE(ICOUT,2931)
15436C2931 FORMAT('***** ERROR IN MATARI--')
15437CCCCC CALL DPWRST('XXX','BUG ')
15438CCCCC WRITE(ICOUT,2932)
15439C2932 FORMAT('      FOR MATRIX EIGENVALUES,')
15440CCCCC CALL DPWRST('XXX','BUG ')
15441CCCCC WRITE(ICOUT,2933)
15442C2933 FORMAT('      THE MATRIX MUST BE SYMMETRIC')
15443CCCCC CALL DPWRST('XXX','BUG ')
15444CCCCC WRITE(ICOUT,2935)
15445C2935 FORMAT('      ( A(I,J) = A(J,I) FOR ALL I AND J ).')
15446CCCCC CALL DPWRST('XXX','BUG ')
15447CCCCC WRITE(ICOUT,2936)
15448C2936 FORMAT('      SUCH WAS NOT THE CASE HERE.')
15449CCCCC CALL DPWRST('XXX','BUG ')
15450CCCCC WRITE(ICOUT,2937)I2,J2,YM1IJ
15451C2937 FORMAT('            ELEMENT',I8,',',I8,' = ',E15.7)
15452CCCCC CALL DPWRST('XXX','BUG ')
15453CCCCC WRITE(ICOUT,2938)J2,I2,YM1JI
15454C2938 FORMAT('            ELEMENT',I8,',',I8,' = ',E15.7)
15455CCCCC CALL DPWRST('XXX','BUG ')
15456CCCCC IERROR='YES'
15457C
15458      IERR2=0
15459      IJOB=0
15460      CALL SGEEV(YM1,MAXROM,NR1,VECT9,YM2,MAXROM,Y3,
15461     1IJOB,IERR2)
15462      IF(IERR2.EQ.-1)THEN
15463        IERROR='YES'
15464        WRITE(ICOUT,2941)
15465        WRITE(ICOUT,2942)
15466      ELSE IF(IERR2.GT.0)THEN
15467        IERROR='YES'
15468        WRITE(ICOUT,2941)
15469        WRITE(ICOUT,2947)
15470        WRITE(ICOUT,2948)IERR2
15471        WRITE(ICOUT,2949)IERR2-1
15472      END IF
15473 2941 FORMAT('******** ERROR FROM MATRIX EIGENVALUES--')
15474 2942 FORMAT('         PROBLEM WITH MATRIX DIMENSIONS')
15475 2947 FORMAT('         THE EIGENVALUE ALGORITHM FAILED TO CONVERGE ')
15476 2948 FORMAT('         FOR EIGENVALUE ',I4)
15477 2949 FORMAT('         EIGENVALUES 1 THRU ',I4,' ARE CORRECT')
15478CCCCC END CHANGE
15479C
15480      ITYP9='VECT'
15481      NVECT9=2*NR1
15482      GOTO9000
15483CCCCC END CHANGES
15484 2939 CONTINUE
15485C
15486CCCCC JULY 1993.  REPLACE NUMERICAL RECIPES ALGORITHM WITH EISPACK
15487CCCCC ALGORITHM.
15488CCCCC CALL JACOBI(YMJUNK,NR1,MAXROM,VECT9,YMJUN2,NJACIT)
15489C
15490      IERR2=0
15491      IJOB=0
15492      CALL SSIEV(YM1,MAXROM,NR1,VECT9,Y3,IJOB,IERR2)
15493      IF(IERR2.EQ.-1)THEN
15494        IERROR='YES'
15495        WRITE(ICOUT,2961)
15496        WRITE(ICOUT,2962)
15497      ELSE IF(IERR2.EQ.-2)THEN
15498        IERROR='YES'
15499        WRITE(ICOUT,2961)
15500        WRITE(ICOUT,2963)
15501      ELSE IF(IERR2.GT.0)THEN
15502        IERROR='YES'
15503        WRITE(ICOUT,2961)
15504        WRITE(ICOUT,2967)
15505        WRITE(ICOUT,2968)IERR2
15506        WRITE(ICOUT,2969)IERR2-1
15507      END IF
15508 2961 FORMAT('******** ERROR FROM MATARI ************')
15509 2962 FORMAT('         THE NUMBER OF ROWS GREATER THAN MAXIMUM')
15510 2963 FORMAT('         LESS THAN 1 ROW')
15511 2967 FORMAT('         THE EIGENVALUE ALGORITHM FAILED TO CONVERGE ')
15512 2968 FORMAT('         FOR EIGENVALUE ',I4)
15513 2969 FORMAT('         EIGENVALUES 1 THRU ',I4,' ARE CORRECT')
15514CCCCC END CHANGE
15515C
15516      ITYP9='VECT'
15517      NVECT9=NR1
15518      IUPFLG='FULL'
15519      GOTO9000
15520C
15521C               *********************************************
15522C               **  STEP 30--                              **
15523C               **  TREAT THE MATRIX    EIGENVECTORS CASE  **
15524C               *********************************************
15525C
15526 3000 CONTINUE
15527C
15528      IF(NR1.NE.NC1)THEN
15529        WRITE(ICOUT,999)
15530        CALL DPWRST('XXX','BUG ')
15531        WRITE(ICOUT,3001)
15532 3001   FORMAT('***** ERROR IN MATRIX EIGENVECTORS--')
15533        CALL DPWRST('XXX','BUG ')
15534        WRITE(ICOUT,2903)
15535        CALL DPWRST('XXX','BUG ')
15536        WRITE(ICOUT,2905)
15537        CALL DPWRST('XXX','BUG ')
15538        WRITE(ICOUT,2907)NR1
15539        CALL DPWRST('XXX','BUG ')
15540        WRITE(ICOUT,2908)NC1
15541        CALL DPWRST('XXX','BUG ')
15542        IERROR='YES'
15543        GOTO9000
15544      ENDIF
15545C
15546      DO3011I=1,NR1
15547        I2=I
15548        DO3012J=I,NC1
15549          J2=J
15550          YM1IJ=YM1(I,J)
15551          YM1JI=YM1(J,I)
15552          IF(YM1IJ.NE.YM1JI)GOTO3030
15553 3012   CONTINUE
15554 3011 CONTINUE
15555      GOTO3039
15556C
15557 3030 CONTINUE
15558CCCCC JULY 1993.  ADD SUPPORT FOR NON-SYMMETRIC CASE.  THIS CASE
15559CCCCC CAN HAVE COMPLEX EIGENVECTORS.  ROWS 1 THROUGH N OF THE OUTPUT
15560CCCCC MATRIX WILL CONTAIN THE REAL COMPONENT, ROWS N+1 THROUGH 2*N
15561CCCCC WILL CONTAIN THE COMPLEX COMPONENT.
15562CCCCC WRITE(ICOUT,999)
15563CCCCC CALL DPWRST('XXX','BUG ')
15564CCCCC WRITE(ICOUT,3031)
15565C3031 FORMAT('***** ERROR IN MATARI--')
15566CCCCC CALL DPWRST('XXX','BUG ')
15567CCCCC WRITE(ICOUT,3032)
15568C3032 FORMAT('      FOR MATRIX EIGENVECTORS,')
15569CCCCC CALL DPWRST('XXX','BUG ')
15570CCCCC WRITE(ICOUT,3033)
15571C3033 FORMAT('      THE MATRIX MUST BE SYMMETRIC')
15572CCCCC CALL DPWRST('XXX','BUG ')
15573CCCCC WRITE(ICOUT,3035)
15574C3035 FORMAT('      ( A(I,J) = A(J,I) FOR ALL I AND J ).')
15575CCCCC CALL DPWRST('XXX','BUG ')
15576CCCCC WRITE(ICOUT,3036)
15577C3036 FORMAT('      SUCH WAS NOT THE CASE HERE.')
15578CCCCC CALL DPWRST('XXX','BUG ')
15579CCCCC WRITE(ICOUT,3037)I2,J2,YM1IJ
15580C3037 FORMAT('            ELEMENT',I8,',',I8,' = ',E15.7)
15581CCCCC CALL DPWRST('XXX','BUG ')
15582CCCCC WRITE(ICOUT,3038)J2,I2,YM1JI
15583C3038 FORMAT('            ELEMENT',I8,',',I8,' = ',E15.7)
15584CCCCC CALL DPWRST('XXX','BUG ')
15585CCCCC IERROR='YES'
15586C
15587      IERR2=0
15588      IJOB=1
15589      DO3021J=1,MAXCOM
15590        DO3022I=1,MAXROM
15591          IF(J.GT.NR1 .OR. I.GT.NR1)YM1(I,J)=0.0
15592          YM2(I,J)=0.0
15593          YM9(I,J)=0.0
15594 3022   CONTINUE
15595 3021 CONTINUE
15596      DO3023I=1,MAXOBV
15597        VECT9(I)=0.0
15598        Y3(I)=0.0
15599 3023 CONTINUE
15600C
15601      CALL SGEEV(YM1,MAXROM,NR1,VECT9,YM2,MAXROM,Y3,
15602     1IJOB,IERR2)
15603      IF(IERR2.EQ.-1)THEN
15604        IERROR='YES'
15605        WRITE(ICOUT,3001)
15606        WRITE(ICOUT,3042)
15607      ELSE IF(IERR2.GT.0)THEN
15608        IERROR='YES'
15609        WRITE(ICOUT,3001)
15610        WRITE(ICOUT,3047)
15611        WRITE(ICOUT,3048)IERR2
15612        WRITE(ICOUT,3049)IERR2-1
15613      ELSE
15614        DO3045J=1,NR1
15615        DO3044I=1,2*NR1
15616        YM9(I,J)=YM2(I,J)
15617 3044   CONTINUE
15618 3045   CONTINUE
15619      END IF
15620 3042 FORMAT('         PROBLEM WITH MATRIX DIMENSIONS')
15621 3047 FORMAT('         THE EIGENVALUE ALGORITHM FAILED TO CONVERGE ')
15622 3048 FORMAT('         FOR EIGENVALUE ',I4)
15623 3049 FORMAT('         EIGENVECTORS 1 THRU ',I4,' ARE CORRECT')
15624CCCCC END CHANGE
15625C
15626      ITYP9='MATR'
15627      NR9=2*NR1
15628      NC9=NC1
15629      IUPFLG='FULL'
15630CCCCC END CHANGES
15631      GOTO9000
15632 3039 CONTINUE
15633C
15634CCCCC JULY 1993.  REPLACE NUMERICAL RECIPES ALGORITHM WITH EISPACK
15635CCCCC ALGORITHM.
15636CCCCC CALL JACOBI(YMJUNK,NR1,MAXROM,VJUNK,YM9,NJACIT)
15637C
15638      IERR2=0
15639      IJOB=1
15640      DO3071I=1,MAXOBV
15641        VECT9(I)=0.0
15642        Y3(I)=0.0
15643 3071 CONTINUE
15644      CALL SSIEV(YM1,MAXROM,NR1,VECT9,Y3,IJOB,IERR2)
15645      IF(IERR2.EQ.-1)THEN
15646        IERROR='YES'
15647        WRITE(ICOUT,3001)
15648        WRITE(ICOUT,3062)
15649      ELSE IF(IERR2.EQ.-2)THEN
15650        IERROR='YES'
15651        WRITE(ICOUT,3001)
15652        WRITE(ICOUT,3063)
15653      ELSE IF(IERR2.GT.0)THEN
15654        IERROR='YES'
15655        WRITE(ICOUT,3001)
15656        WRITE(ICOUT,3067)
15657        WRITE(ICOUT,3068)IERR2
15658        WRITE(ICOUT,3069)IERR2-1
15659      ELSE
15660        DO3080J=1,NR1
15661        DO3082I=1,NR1
15662        YM9(I,J)=YM1(I,J)
15663 3082   CONTINUE
15664 3080   CONTINUE
15665      END IF
15666 3062 FORMAT('         THE NUMBER OF ROWS GREATER THAN MAXIMUM')
15667 3063 FORMAT('         LESS THAN 1 ROW')
15668 3067 FORMAT('         THE EIGENVALUE ALGORITHM FAILED TO CONVERGE ')
15669 3068 FORMAT('         FOR EIGENVALUE ',I4)
15670 3069 FORMAT('         EIGENVALUES 1 THRU ',I4,' ARE CORRECT')
15671CCCCC END CHANGE
15672C
15673      ITYP9='MATR'
15674      NR9=NR1
15675      NC9=NC1
15676      IUPFLG='FULL'
15677      GOTO9000
15678C
15679C               ************************************************
15680C               **  STEP 31--                                 **
15681C               **  TREAT THE MATRIX     RANK        CASE     **
15682C               **  COMPUTE FROM SINGULAR VALUE DECOMPOSITION **
15683C               ************************************************
15684C
15685CCCCC IMPLEMENTED JULY 1993.
15686 3100 CONTINUE
15687C
15688      IERR2=0
15689      IJOB=0
15690      CALL SSVDC(YM1,MAXROM,NR1,NC1,VECT9,Y3,YM1,MAXROM,
15691     1YM1,MAXROM,Y4,IJOB,IERR2)
15692      ARANK=0.
15693      IF(ITYPA2.EQ.'PARA')THEN
15694        ATOL=YS2
15695      ELSE
15696CCCCC   ATOL=0.0000001
15697        CALL SPDIV(RMXINT,2.0,IND,RESULT)
15698        ETA=RESULT+1.0
15699        CALL SPDIV(1.0,ETA,IND,ETA)
15700        ATOL=REAL(MAX(NR1,NC1))*VECT9(1)*ETA
15701      ENDIF
15702      NLAST=MIN(NR1,NC1)
15703      DO3120I=1,NLAST
15704      IF(VECT9(I).LE.ATOL)THEN
15705        ARANK=REAL(I-1)
15706        GOTO3129
15707      ENDIF
15708 3120 CONTINUE
15709      ARANK=REAL(NLAST)
15710 3129 CONTINUE
15711C
15712      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'TARI')GOTO3190
15713C
15714      WRITE(ICOUT,999)
15715      CALL DPWRST('XXX','BUG ')
15716      WRITE(ICOUT,3151)
15717 3151 FORMAT('***** COMPUTING RANK--')
15718      CALL DPWRST('XXX','BUG ')
15719      WRITE(ICOUT,3152)EPS,VECT9(1),ATOL
15720 3152 FORMAT('EPS,VECT((1),ATOL = ',
15721     1E15.7,2X,E15.7,2X,E15.7)
15722      CALL DPWRST('XXX','BUG ')
15723      NLAST=MIN(NR1+1,NC1)
15724      DO3180I=1,NLAST
15725      WRITE(ICOUT,3183)I,VECT9(I)
15726 3183 FORMAT('I,VECT9(I) = ',I4,2X,E15.7)
15727      CALL DPWRST('XXX','BUG ')
15728 3180 CONTINUE
15729C
15730 3190 CONTINUE
15731C
15732CCCCC END CHANGE
15733C
15734      ITYP9='SCAL'
15735      SCAL9=ARANK
15736      IUPFLG='FULL'
15737      GOTO9000
15738C
15739C               *********************************************
15740C               **  STEP 32--                              **
15741C               **  TREAT THE MATRIX     DETERMINANT CASE  **
15742C               **  REFERENCE--PRESS ET AL, PAGE 39        **
15743C               *********************************************
15744C
15745 3200 CONTINUE
15746C
15747      IF(NR1.EQ.NC1)GOTO3209
15748      WRITE(ICOUT,999)
15749      CALL DPWRST('XXX','BUG ')
15750      WRITE(ICOUT,3201)
15751 3201 FORMAT('***** ERROR IN MATARI--')
15752      CALL DPWRST('XXX','BUG ')
15753      WRITE(ICOUT,3202)
15754 3202 FORMAT('      FOR MATRIX DETERMINANT,')
15755      CALL DPWRST('XXX','BUG ')
15756      WRITE(ICOUT,3203)
15757 3203 FORMAT('      THE NUMBER OF ROWS IN THE MATRIX')
15758      CALL DPWRST('XXX','BUG ')
15759      WRITE(ICOUT,3204)
15760 3204 FORMAT('      MUST EQUAL')
15761      CALL DPWRST('XXX','BUG ')
15762      WRITE(ICOUT,3205)
15763 3205 FORMAT('      THE NUMBER OF COLUMNS IN THE MATRIX;')
15764      CALL DPWRST('XXX','BUG ')
15765      WRITE(ICOUT,3206)
15766 3206 FORMAT('      SUCH WAS NOT THE CASE HERE.')
15767      CALL DPWRST('XXX','BUG ')
15768      WRITE(ICOUT,3207)NR1
15769 3207 FORMAT('            NUMBER OF ROWS    =',I8)
15770      CALL DPWRST('XXX','BUG ')
15771      WRITE(ICOUT,3208)NC1
15772 3208 FORMAT('            NUMBER OF COLUMNS =',I8)
15773      CALL DPWRST('XXX','BUG ')
15774      IERROR='YES'
15775      GOTO9000
15776 3209 CONTINUE
15777C
15778CCCCC JULY 1993.  REPLACE NUMERICAL RECIPES ALGORITHM WITH LINPACK
15779CCCCC ALGORITHM.
15780CCCCC CALL LUDCMP(YMJUNK,NR1,MAXROM,INDEX,DP1M1)
15781C
15782CCCCC DET=DP1M1
15783CCCCC DO3221I=1,NR1
15784CCCCC DET=DET*YMJUNK(I,I)
15785C3221 CONTINUE
15786      CALL SGECO(YM1,MAXROM,NR1,INDEX,RCOND,Y3)
15787      WRITE(ICOUT,3261)RCOND
15788      CALL DPWRST('XXX','TEXT ')
15789 3261 FORMAT('THE RECIPROCAL CONDITION NUMBER FOR THE MATRIX = ',E15.7)
15790      EPS=1.0E-20
15791      IF(RCOND.LE.EPS)THEN
15792        WRITE(ICOUT,3271)
15793        CALL DPWRST('XXX','ERRO ')
15794        WRITE(ICOUT,3272)
15795        CALL DPWRST('XXX','ERRO ')
15796        IERROR='YES'
15797      ELSE
15798        IJOB=10
15799        CALL SGEDI(YM1,MAXROM,NR1,INDEX,Y3,Y4,IJOB)
15800        DET=Y3(1)*10.0**Y3(2)
15801      END IF
15802 3271 FORMAT('****** ERROR IN MATARI ********')
15803 3272 FORMAT('       THE INPUT MATRIX IS SINGULAR')
15804CCCCC END CHANGE
15805C
15806      ITYP9='SCAL'
15807      SCAL9=DET
15808      IUPFLG='FULL'
15809      GOTO9000
15810C
15811C               *********************************************
15812C               **  STEP 33--                              **
15813C               **  TREAT THE MATRIX     PERMANENT   CASE  **
15814C               *********************************************
15815C
15816 3300 CONTINUE
15817C
15818      IF(NR1.NE.NC1)THEN
15819        WRITE(ICOUT,999)
15820        CALL DPWRST('XXX','BUG ')
15821        WRITE(ICOUT,3301)
15822 3301   FORMAT('***** ERROR IN MATARI--')
15823        CALL DPWRST('XXX','BUG ')
15824        WRITE(ICOUT,3302)
15825 3302   FORMAT('      FOR MATRIX PERMANENT, THE NUMBER OF ROWS IN THE')
15826        CALL DPWRST('XXX','BUG ')
15827        WRITE(ICOUT,3305)
15828 3305   FORMAT('      MATRIX MUST EQUAL THE NUMBER OF COLUMNS IN')
15829        CALL DPWRST('XXX','BUG ')
15830        WRITE(ICOUT,3306)
15831 3306   FORMAT('      THE MATRIX;  SUCH WAS NOT THE CASE HERE.')
15832        CALL DPWRST('XXX','BUG ')
15833        WRITE(ICOUT,3307)NR1
15834 3307   FORMAT('            NUMBER OF ROWS    =',I8)
15835        CALL DPWRST('XXX','BUG ')
15836        WRITE(ICOUT,3308)NC1
15837 3308   FORMAT('            NUMBER OF COLUMNS =',I8)
15838        CALL DPWRST('XXX','BUG ')
15839        IERROR='YES'
15840        GOTO9000
15841      ENDIF
15842C
15843      IF(NR1.GT.50)THEN
15844        WRITE(ICOUT,999)
15845        CALL DPWRST('XXX','BUG ')
15846        WRITE(ICOUT,3311)
15847 3311   FORMAT('***** ERROR IN MATARI--')
15848        CALL DPWRST('XXX','BUG ')
15849        WRITE(ICOUT,3312)
15850 3312   FORMAT('      FOR MATRIX PERMANENT, THE NUMBER OF ROWS IN THE')
15851        CALL DPWRST('XXX','BUG ')
15852        WRITE(ICOUT,3315)
15853 3315   FORMAT('      MATRIX IS CURRENTLY RESTRICTED TO 50 OR LESS.')
15854        CALL DPWRST('XXX','BUG ')
15855        WRITE(ICOUT,3317)NR1
15856 3317   FORMAT('            NUMBER OF ROWS    =',I8)
15857        CALL DPWRST('XXX','BUG ')
15858        IERROR='YES'
15859        GOTO9000
15860      ENDIF
15861C
15862      CALL PERMAN(YM1,MAXROM,NR1,INDEX,Y3,APERM)
15863C
15864      ITYP9='SCAL'
15865      SCAL9=APERM
15866      IUPFLG='FULL'
15867      GOTO9000
15868C
15869C               *******************************************************
15870C               **  STEP 34--                                        **
15871C               **  TREAT THE MATRIX     SPECTRAL NORM    CASE       **
15872C               **  SPECTRAL NORM = COMPUTE MATRIX TIMES ITS         **
15873C               **                  TRANSPOSE, THEN FIND THE SQUARE  **
15874C               **                  ROOT OF THE EIGENVALUE WITH THE  **
15875C               **                  LARGEST ABSOLUTE VALUE.          **
15876C               **  REFERENCE--RALSTON                               **
15877C               *******************************************************
15878C
15879 3400 CONTINUE
15880C
15881      IF(NR1.GT.MAXCOM)THEN
15882        WRITE(ICOUT,999)
15883        CALL DPWRST('XXX','BUG ')
15884        WRITE(ICOUT,3411)
15885 3411   FORMAT('***** ERROR IN MATARI--')
15886        CALL DPWRST('XXX','BUG ')
15887        WRITE(ICOUT,3413)NR1
15888 3413   FORMAT('      THE NUMBER OF ROWS IN THE MATRIX,',I5,
15889     1         'EXCEEDS THE MAXIMUM')
15890        CALL DPWRST('XXX','BUG ')
15891        WRITE(ICOUT,3415)MAXCOM
15892 3415   FORMAT('      NUMBER OF COLUMNS FOR A MATRIX,',I5,'.')
15893        CALL DPWRST('XXX','BUG ')
15894        WRITE(ICOUT,3417)
15895 3417   FORMAT('      THE MATRIX TRANSPOSE WAS NOT COMPUTED.')
15896        CALL DPWRST('XXX','BUG ')
15897        IERROR='YES'
15898        GOTO9000
15899      ENDIF
15900C
15901      DO3421I=1,NR1
15902      DO3422J=1,NR1
15903      DSUM=0.0D0
15904      DO3423K=1,NC1
15905      DYM1=YM1(I,K)
15906      DYM2=YM1(J,K)
15907      DYM9=DYM1*DYM2
15908      DSUM=DSUM+DYM9
15909 3423 CONTINUE
15910      YM2(I,J)=DSUM
15911 3422 CONTINUE
15912 3421 CONTINUE
15913      NRJ=NR1
15914      NCJ=NR1
15915C
15916CCCCC JULY 1993.  REPLACE NUMERICAL RECIPES ALGORITHM WITH THE EISPACK
15917CCCCC ALGORITHM.  NOTE THAT MATRIX TIMES IT TRANSPOSE IS SYMMETRIC, SO
15918CCCCC USE SYMMERIC VERSION.
15919CCCCC CALL JACOBI(YMJUNK,NRJ,MAXROM,VJUNK,YMJUN2,NJACIT)
15920C
15921      IERR2=0
15922      IJOB=0
15923      CALL SSIEV(YM2,MAXROM,NR1,Y3,Y4,IJOB,IERR2)
15924      IF(IERR2.EQ.-1)THEN
15925        IERROR='YES'
15926        WRITE(ICOUT,3451)
15927        WRITE(ICOUT,3452)
15928        GOTO9000
15929      ELSE IF(IERR2.EQ.-2)THEN
15930        IERROR='YES'
15931        WRITE(ICOUT,3451)
15932        WRITE(ICOUT,3453)
15933        GOTO9000
15934      ELSE IF(IERR2.GT.0)THEN
15935        IERROR='YES'
15936        WRITE(ICOUT,3451)
15937        WRITE(ICOUT,3457)
15938        WRITE(ICOUT,3458)IERR2
15939        WRITE(ICOUT,3459)IERR2-1
15940        GOTO9000
15941      END IF
15942 3451 FORMAT('******** ERROR FROM MATARI ************')
15943 3452 FORMAT('         THE NUMBER OF ROWS GREATER THAN MAXIMUM')
15944 3453 FORMAT('         LESS THAN 1 ROW')
15945 3457 FORMAT('         THE EIGENVALUE ALGORITHM FAILED TO CONVERGE ')
15946 3458 FORMAT('         FOR EIGENVALUE ',I4)
15947 3459 FORMAT('         EIGENVALUES 1 THRU ',I4,' ARE CORRECT')
15948CCCCC END CHANGES
15949      AMAX=ABS(Y3(1))
15950      DO3461I=1,NR1
15951      IF(ABS(Y3(I)).GT.AMAX)AMAX=ABS(Y3(I))
15952 3461 CONTINUE
15953      AMAX2=0.0
15954      IF(AMAX.GT.0.0)AMAX2=SQRT(AMAX)
15955C
15956      ITYP9='SCAL'
15957      SCAL9=AMAX2
15958      IUPFLG='FULL'
15959      GOTO9000
15960C
15961C               *******************************************************
15962C               **  STEP 35--                                        **
15963C               **  TREAT THE MATRIX     SPECTRAL RADIUS    CASE     **
15964C               **  SPECTRAL RADIUS = LARGEST ABS(EIGENVALUE) OF A   **
15965C               **  REFERENCE--RALSTON                               **
15966C               *******************************************************
15967C
15968 3500 CONTINUE
15969C
15970CCCCC JUNE 1995.  EISPACK WILL HANDLE NON-SYMMETRIC MATRICES (FOR
15971CCCCC EIGENVALUES).  NO NEED TO RESTRICT TO SYMMETRIC MATRICES).
15972CCCCC IF(NR1.EQ.NC1)GOTO3509
15973CCCCC WRITE(ICOUT,999)
15974CCCCC CALL DPWRST('XXX','BUG ')
15975CCCCC WRITE(ICOUT,3501)
15976C3501 FORMAT('***** ERROR IN MATARI--')
15977CCCCC CALL DPWRST('XXX','BUG ')
15978CCCCC WRITE(ICOUT,3502)
15979C3502 FORMAT('      FOR MATRIX SPECTRAL RADIUS,')
15980CCCCC CALL DPWRST('XXX','BUG ')
15981CCCCC WRITE(ICOUT,3503)
15982C3503 FORMAT('      THE NUMBER OF ROWS IN THE MATRIX')
15983CCCCC CALL DPWRST('XXX','BUG ')
15984CCCCC WRITE(ICOUT,3504)
15985C3504 FORMAT('      MUST EQUAL')
15986CCCCC CALL DPWRST('XXX','BUG ')
15987CCCCC WRITE(ICOUT,3505)
15988C3505 FORMAT('      THE NUMBER OF COLUMNS IN THE MATRIX;')
15989CCCCC CALL DPWRST('XXX','BUG ')
15990CCCCC WRITE(ICOUT,3506)
15991C3506 FORMAT('      SUCH WAS NOT THE CASE HERE.')
15992CCCCC CALL DPWRST('XXX','BUG ')
15993CCCCC WRITE(ICOUT,3507)NR1
15994C3507 FORMAT('            NUMBER OF ROWS    =',I8)
15995CCCCC CALL DPWRST('XXX','BUG ')
15996CCCCC WRITE(ICOUT,3508)NC1
15997C3508 FORMAT('            NUMBER OF COLUMNS =',I8)
15998CCCCC CALL DPWRST('XXX','BUG ')
15999CCCCC IERROR='YES'
16000CCCCC GOTO9000
16001C
16002      DO3511I=1,NR1
16003      I2=I
16004      DO3512J=I,NC1
16005      J2=J
16006      YM1IJ=YM1(I,J)
16007      YM1JI=YM1(J,I)
16008      IF(YM1IJ.EQ.YM1JI)GOTO3512
16009      GOTO3530
16010 3512 CONTINUE
16011 3511 CONTINUE
16012      GOTO3539
16013CCCCC JULY 1993.  REPLACE NUMERICAL RECIPES ALGORITHM WITH EISPACK
16014CCCCC EISPACK CAN HANDLE NON-SYMMETRIC MATRICES.
16015 3530 CONTINUE
16016CCCCC WRITE(ICOUT,999)
16017CCCCC CALL DPWRST('XXX','BUG ')
16018CCCCC WRITE(ICOUT,3531)
16019C3531 FORMAT('***** ERROR IN MATARI--')
16020CCCCC CALL DPWRST('XXX','BUG ')
16021CCCCC WRITE(ICOUT,3532)
16022C3532 FORMAT('      FOR MATRIX SPECTRAL RADIUS,')
16023CCCCC CALL DPWRST('XXX','BUG ')
16024CCCCC WRITE(ICOUT,3533)
16025C3533 FORMAT('      THE MATRIX MUST BE SYMMETRIC')
16026CCCCC CALL DPWRST('XXX','BUG ')
16027CCCCC WRITE(ICOUT,3535)
16028C3535 FORMAT('      ( A(I,J) = A(J,I) FOR ALL I AND J ).')
16029CCCCC CALL DPWRST('XXX','BUG ')
16030CCCCC WRITE(ICOUT,3536)
16031C3536 FORMAT('      SUCH WAS NOT THE CASE HERE.')
16032CCCCC CALL DPWRST('XXX','BUG ')
16033CCCCC WRITE(ICOUT,3537)I2,J2,YM1IJ
16034C3537 FORMAT('            ELEMENT',I8,',',I8,' = ',E15.7)
16035CCCCC CALL DPWRST('XXX','BUG ')
16036CCCCC WRITE(ICOUT,3538)J2,I2,YM1JI
16037C3538 FORMAT('            ELEMENT',I8,',',I8,' = ',E15.7)
16038CCCCC CALL DPWRST('XXX','BUG ')
16039CCCCC IERROR='YES'
16040CCCCC GOTO9000
16041C
16042      IERR2=0
16043      IJOB=0
16044      CALL SGEEV(YM1,MAXROM,NR1,Y3,YM2,MAXROM,Y4,
16045     1IJOB,IERR2)
16046      IF(IERR2.EQ.-1)THEN
16047        IERROR='YES'
16048        WRITE(ICOUT,3541)
16049        WRITE(ICOUT,3542)
16050      ELSE IF(IERR2.GT.0)THEN
16051        IERROR='YES'
16052        WRITE(ICOUT,3541)
16053        WRITE(ICOUT,3547)
16054        WRITE(ICOUT,3548)IERR2
16055        WRITE(ICOUT,3549)IERR2-1
16056      END IF
16057 3541 FORMAT('******** ERROR FROM MATARI ************')
16058 3542 FORMAT('         PROBLEM WITH MATRIX DIMENSIONS')
16059 3547 FORMAT('         THE EIGENVALUE ALGORITHM FAILED TO CONVERGE ')
16060 3548 FORMAT('         FOR EIGENVALUE ',I4)
16061 3549 FORMAT('         EIGENVALUES 1 THRU ',I4,' ARE CORRECT')
16062C
16063C  COMPLEX ABSOLUTE VALUE IS DEFINED TO BE: SQRT(REAL**2+COMPLEX**2)
16064C
16065      AMAX=0.0
16066      ATEMP1=Y3(1)**2 + Y3(1+NR1)**2
16067      IF(ATEMP1.GE.0.0)AMAX=SQRT(ATEMP1)
16068      DO3538I=1,NR1
16069      ATEMP1=0.0
16070      ATEMP2=Y3(I)**2 + Y3(I+NR1)**2
16071      IF(ATEMP2.GE.0.0)ATEMP1=SQRT(ATEMP2)
16072      IF(ATEMP1.GT.AMAX)AMAX=ATEMP1
16073 3538 CONTINUE
16074      GOTO3599
16075C
16076CCCCC END CHANGE
16077 3539 CONTINUE
16078C
16079CCCCC JULY 1993.  REPLACE NUMERICAL RECIPES ALGORITHM WITH EISPACK
16080CCCCC CALL JACOBI(YMJUNK,NR1,MAXROM,VJUNK,YMJUN2,NJACIT)
16081C
16082      IERR2=0
16083      IJOB=0
16084      CALL SSIEV(YM1,MAXROM,NR1,Y3,Y4,IJOB,IERR2)
16085      IF(IERR2.EQ.-1)THEN
16086        IERROR='YES'
16087        WRITE(ICOUT,3561)
16088        WRITE(ICOUT,3562)
16089        GOTO9000
16090      ELSE IF(IERR2.EQ.-2)THEN
16091        IERROR='YES'
16092        WRITE(ICOUT,3561)
16093        WRITE(ICOUT,3563)
16094        GOTO9000
16095      ELSE IF(IERR2.GT.0)THEN
16096        IERROR='YES'
16097        WRITE(ICOUT,3561)
16098        WRITE(ICOUT,3567)
16099        WRITE(ICOUT,3568)IERR2
16100        WRITE(ICOUT,3569)IERR2-1
16101        GOTO9000
16102      END IF
16103 3561 FORMAT('******** ERROR FROM MATARI ************')
16104 3562 FORMAT('         THE NUMBER OF ROWS GREATER THAN MAXIMUM')
16105 3563 FORMAT('         LESS THAN 1 ROW')
16106 3567 FORMAT('         THE EIGENVALUE ALGORITHM FAILED TO CONVERGE ')
16107 3568 FORMAT('         FOR EIGENVALUE ',I4)
16108 3569 FORMAT('         EIGENVALUES 1 THRU ',I4,' ARE CORRECT')
16109CCCCC END CHANGES
16110C
16111      AMAX=ABS(Y3(1))
16112      DO3591I=1,NR1
16113      IF(ABS(Y3(I)).GT.AMAX)AMAX=ABS(Y3(I))
16114 3591 CONTINUE
16115C
16116 3599 CONTINUE
16117      ITYP9='SCAL'
16118      SCAL9=AMAX
16119      IUPFLG='FULL'
16120      GOTO9000
16121C
16122C               ***************************************************
16123C               **  STEP 36--                                    **
16124C               **  TREAT THE MATRIX     NUMBER OF ROWS    CASE  **
16125C               ***************************************************
16126C
16127 3600 CONTINUE
16128C
16129      SCAL9=NR1
16130C
16131      ITYP9='SCAL'
16132      NR9=1
16133      NC9=1
16134      IUPFLG='FULL'
16135      GOTO9000
16136C
16137C               ***************************************************
16138C               **  STEP 37--                                    **
16139C               **  TREAT THE MATRIX     NUMBER OF COLUMNS CASE  **
16140C               ***************************************************
16141C
16142 3700 CONTINUE
16143C
16144      SCAL9=NC1
16145C
16146      ITYP9='SCAL'
16147C
16148      NR9=1
16149      NC9=1
16150      IUPFLG='FULL'
16151      GOTO9000
16152C
16153C               *****************************************************
16154C               **  STEP 38--                                      **
16155C               **  TREAT THE MATRIX     SIMPLEX SOLUTION    CASE  **
16156C               **  REFERENCE--PRESS ET AL, PAGE 322               **
16157C               *****************************************************
16158C
16159 3800 CONTINUE
16160C
16161      NC2M2=NC2-2
16162C
16163      IF(N1.EQ.NC2M2)GOTO3809
16164      WRITE(ICOUT,999)
16165      CALL DPWRST('XXX','BUG ')
16166      WRITE(ICOUT,3801)
16167 3801 FORMAT('***** ERROR IN MATARI--')
16168      CALL DPWRST('XXX','BUG ')
16169      WRITE(ICOUT,3802)
16170 3802 FORMAT('      FOR MATRIX SIMPLEX SOLUTION OF OBJ. FUNCT. F.X')
16171      CALL DPWRST('XXX','BUG ')
16172      WRITE(ICOUT,3803)
16173 3803 FORMAT('      SUBJECT TO THE CONSTRAINTS IN MATRIX C')
16174      CALL DPWRST('XXX','BUG ')
16175      WRITE(ICOUT,3804)
16176 3804 FORMAT('      VIA   LET V = MATRIX SIMPLEX SOLUTION F C')
16177      CALL DPWRST('XXX','BUG ')
16178      WRITE(ICOUT,3805)
16179 3805 FORMAT('      NUMBER OF ROWS IN OBJ. FUNCTION VECTOR F MUST')
16180      CALL DPWRST('XXX','BUG ')
16181      WRITE(ICOUT,3806)
16182 3806 FORMAT('      BE EXACTLY 2 LESS THAN NUMBER OF COLUMNS IN C;')
16183      CALL DPWRST('XXX','BUG ')
16184      WRITE(ICOUT,3807)N1
16185 3807 FORMAT('            VECTOR--',I8,' ROWS')
16186      CALL DPWRST('XXX','BUG ')
16187      WRITE(ICOUT,3808)NR2,NC2
16188 3808 FORMAT('            MATRIX--',I8,' ROWS BY ',I8,' COLUMNS')
16189      CALL DPWRST('XXX','BUG ')
16190      IERROR='YES'
16191      GOTO9000
16192 3809 CONTINUE
16193C
16194      IF(1.LE.N1.AND.N1.LE.MAXCOM)GOTO3819
16195      WRITE(ICOUT,999)
16196      CALL DPWRST('XXX','BUG ')
16197      WRITE(ICOUT,3811)
16198 3811 FORMAT('***** ERROR IN MATARI--')
16199      CALL DPWRST('XXX','BUG ')
16200      WRITE(ICOUT,3812)
16201 3812 FORMAT('      FOR MATRIX SIMPLEX SOLUTION OF OBJ. FUNCT. F.X')
16202      CALL DPWRST('XXX','BUG ')
16203      WRITE(ICOUT,3813)
16204 3813 FORMAT('      SUBJECT TO THE CONSTRAINTS IN MATRIX C')
16205      CALL DPWRST('XXX','BUG ')
16206      WRITE(ICOUT,3814)
16207 3814 FORMAT('      VIA   LET V = MATRIX SIMPLEX SOLUTION F C')
16208      CALL DPWRST('XXX','BUG ')
16209      WRITE(ICOUT,3815)
16210 3815 FORMAT('      THE NUMBER OF ROWS IN OBJ. FUNCTION VECTOR F')
16211      CALL DPWRST('XXX','BUG ')
16212      WRITE(ICOUT,3816)MAXCOM
16213 3816 FORMAT('      MUST BE AT LEAST 1, AND AT MOST ',I8)
16214      CALL DPWRST('XXX','BUG ')
16215      WRITE(ICOUT,3817)N1
16216 3817 FORMAT('            NUMBER OF ROWS = ',I8)
16217      CALL DPWRST('XXX','BUG ')
16218      IERROR='YES'
16219      GOTO9000
16220 3819 CONTINUE
16221C
16222      IF(1.LE.NR2.AND.NR2.LE.MAXROM)GOTO3829
16223      WRITE(ICOUT,999)
16224      CALL DPWRST('XXX','BUG ')
16225      WRITE(ICOUT,3821)
16226 3821 FORMAT('***** ERROR IN MATARI--')
16227      CALL DPWRST('XXX','BUG ')
16228      WRITE(ICOUT,3822)
16229 3822 FORMAT('      FOR MATRIX SIMPLEX SOLUTION OF OBJ. FUNCT. F.X')
16230      CALL DPWRST('XXX','BUG ')
16231      WRITE(ICOUT,3823)
16232 3823 FORMAT('      SUBJECT TO THE CONSTRAINTS IN MATRIX C')
16233      CALL DPWRST('XXX','BUG ')
16234      WRITE(ICOUT,3824)
16235 3824 FORMAT('      VIA   LET V = MATRIX SIMPLEX SOLUTION F C')
16236      CALL DPWRST('XXX','BUG ')
16237      WRITE(ICOUT,3825)
16238 3825 FORMAT('      THE NUMBER OF CONSTRAINTS')
16239      CALL DPWRST('XXX','BUG ')
16240      WRITE(ICOUT,3826)
16241 3826 FORMAT('      (THAT IS, THE NUMBER OF ROWS IN THE MATRIX C)')
16242      CALL DPWRST('XXX','BUG ')
16243      WRITE(ICOUT,3827)MAXROM
16244 3827 FORMAT('      MUST BE AT LEAST 1, AND AT MOST ',I8)
16245      CALL DPWRST('XXX','BUG ')
16246      WRITE(ICOUT,3828)NR2
16247 3828 FORMAT('            NUMBER OF CONSTRAINTS = ',I8)
16248      CALL DPWRST('XXX','BUG ')
16249      IERROR='YES'
16250      GOTO9000
16251 3829 CONTINUE
16252C
16253      IF(3.LE.NC2.AND.NC2.LE.MAXCOM)GOTO3839
16254      WRITE(ICOUT,999)
16255      CALL DPWRST('XXX','BUG ')
16256      WRITE(ICOUT,3831)
16257 3831 FORMAT('***** ERROR IN MATARI--')
16258      CALL DPWRST('XXX','BUG ')
16259      WRITE(ICOUT,3832)
16260 3832 FORMAT('      FOR MATRIX SIMPLEX SOLUTION OF OBJ. FUNCT. F.X')
16261      CALL DPWRST('XXX','BUG ')
16262      WRITE(ICOUT,3833)
16263 3833 FORMAT('      SUBJECT TO THE CONSTRAINTS IN MATRIX C')
16264      CALL DPWRST('XXX','BUG ')
16265      WRITE(ICOUT,3834)
16266 3834 FORMAT('      VIA   LET V = MATRIX SIMPLEX SOLUTION F C')
16267      CALL DPWRST('XXX','BUG ')
16268      WRITE(ICOUT,3835)
16269 3835 FORMAT('      THE NUMBER OF COLUMNS IN THE CONSTRAINTS')
16270      CALL DPWRST('XXX','BUG ')
16271      WRITE(ICOUT,3836)MAXCOM
16272 3836 FORMAT('      MATRIX C MUST BE AT LEAST 3, AND AT MOST ',I8)
16273      CALL DPWRST('XXX','BUG ')
16274      WRITE(ICOUT,3837)NC2
16275 3837 FORMAT('            NUMBER OF COLUMNS = ',I8)
16276      CALL DPWRST('XXX','BUG ')
16277      IERROR='YES'
16278      GOTO9000
16279 3839 CONTINUE
16280C
16281      EPS=0.000001
16282      NR2P1=NR2+1
16283      NC2P=NC2-2
16284      NC2PP1=NC2P+1
16285      NC2M1=NC2-1
16286C
16287      DO3850J=1,NC2PP1
16288      YM9(1,J)=0.0
16289 3850 CONTINUE
16290C
16291      N1P1=N1+1
16292      DO3860J=2,N1P1
16293      JM1=J-1
16294      YM9(1,J)=Y1(JM1)
16295 3860 CONTINUE
16296C
16297      K=1
16298      DO3871ILOOP=1,3
16299C
16300      DO3872I=2,NR2P1
16301      IM1=I-1
16302      YTARG=YM2(IM1,NC2M1)
16303      IF(ILOOP.EQ.1.AND.YTARG.LT.-EPS)GOTO3873
16304      IF(ILOOP.EQ.1)GOTO3872
16305      IF(ILOOP.EQ.2.AND.EPS.LT.YTARG)GOTO3873
16306      IF(ILOOP.EQ.2)GOTO3872
16307      IF(ILOOP.EQ.3.AND.-EPS.LE.YTARG.AND.
16308     1                  YTARG.LE.EPS)GOTO3873
16309      IF(ILOOP.EQ.3)GOTO3872
16310 3873 CONTINUE
16311      K=K+1
16312C
16313      YM9(K,1)=YM2(IM1,NC2)
16314      DO3874J=2,NC2PP1
16315      JM1=J-1
16316      YM9(K,J)=(-YM2(IM1,JM1))
16317 3874 CONTINUE
16318C
16319 3872 CONTINUE
16320C
16321 3871 CONTINUE
16322C
16323      NLTZ=0
16324      NGTZ=0
16325      NEQZ=0
16326      DO3877I=1,NR2
16327      YTARG=YM2(I,NC2M1)
16328      IF(YTARG.LT.-EPS)NLTZ=NLTZ+1
16329      IF(EPS.LT.YTARG)NGTZ=NGTZ+1
16330      IF(-EPS.LE.YTARG.AND.YTARG.LE.EPS)NEQZ=NEQZ+1
16331 3877 CONTINUE
16332C
16333      CALL SIMPLX(YM9,NR2,NC2P,MAXROM,MAXCOM,NLTZ,NGTZ,NEQZ,
16334     1ICASE,IZROV,IPOSV,IBUGA3,ISUBRO,IERROR)
16335      IF(IERROR.EQ.'YES')GOTO9000
16336C
16337      DO3881I=1,N1
16338      VECT9(I)=0.0
16339 3881 CONTINUE
16340C
16341      DO3882I=1,NR2
16342      INDEX2=IPOSV(I)
16343      IP1=I+1
16344      IF(INDEX2.LE.N1)VECT9(INDEX2)=YM9(IP1,1)
16345 3882 CONTINUE
16346C
16347      ITYP9='VECT'
16348      NVECT9=N1
16349      IUPFLG='FULL'
16350      GOTO9000
16351C
16352C               *****************************************************
16353C               **  STEP 41--                                      **
16354C               **  TREAT THE MATRIX     TRACE               CASE  **
16355C               **  REFERENCE--RALSTON, PAGE XXX                   **
16356C               *****************************************************
16357C
16358 4100 CONTINUE
16359C
16360      IF(NR1.EQ.NC1)GOTO4109
16361      WRITE(ICOUT,999)
16362      CALL DPWRST('XXX','BUG ')
16363      WRITE(ICOUT,4101)
16364 4101 FORMAT('***** ERROR IN MATARI--')
16365      CALL DPWRST('XXX','BUG ')
16366      WRITE(ICOUT,4102)
16367 4102 FORMAT('      FOR MATRIX TRACE,')
16368      CALL DPWRST('XXX','BUG ')
16369      WRITE(ICOUT,4103)
16370 4103 FORMAT('      THE NUMBER OF ROWS IN THE MATRIX')
16371      CALL DPWRST('XXX','BUG ')
16372      WRITE(ICOUT,4104)
16373 4104 FORMAT('      MUST EQUAL')
16374      CALL DPWRST('XXX','BUG ')
16375      WRITE(ICOUT,4105)
16376 4105 FORMAT('      THE NUMBER OF COLUMNS IN THE MATRIX;')
16377      CALL DPWRST('XXX','BUG ')
16378      WRITE(ICOUT,4106)
16379 4106 FORMAT('      SUCH WAS NOT THE CASE HERE.')
16380      CALL DPWRST('XXX','BUG ')
16381      WRITE(ICOUT,4107)NR1
16382 4107 FORMAT('            NUMBER OF ROWS    =',I8)
16383      CALL DPWRST('XXX','BUG ')
16384      WRITE(ICOUT,4108)NC1
16385 4108 FORMAT('            NUMBER OF COLUMNS =',I8)
16386      CALL DPWRST('XXX','BUG ')
16387      IERROR='YES'
16388      GOTO9000
16389 4109 CONTINUE
16390C
16391      DSUM1=0.0D0
16392      DO4111I=1,NR1
16393      DYM1=YM1(I,I)
16394      DSUM1=DSUM1+DYM1
16395 4111 CONTINUE
16396C
16397      ITYP9='SCAL'
16398      SCAL9=DSUM1
16399      IUPFLG='FULL'
16400      GOTO9000
16401C
16402C               *****************************************************
16403C               **  STEP 42--                                      **
16404C               **  TREAT THE MATRIX     SUBMATRIX           CASE  **
16405C               **  REFERENCE--RALSTON, PAGE XXX                   **
16406C               *****************************************************
16407C
16408 4200 CONTINUE
16409C
16410CCCCC  NO REASON FOR RESTRICTION ON SQUARE MATRICES FOR THIS
16411CCCCC  COMMAND.  COMMENT OUT FOLLOWING SECTION.   DECEMBER 1994.
16412CCCCC  IF(NR1.EQ.NC1)GOTO4209
16413CCCCC  WRITE(ICOUT,999)
16414CCCCC  CALL DPWRST('XXX','BUG ')
16415CCCCC  WRITE(ICOUT,4201)
16416C4201 FORMAT('***** ERROR IN MATARI--')
16417CCCCC  CALL DPWRST('XXX','BUG ')
16418CCCCC  WRITE(ICOUT,4202)
16419C4202 FORMAT('      FOR MATRIX SUBMATRIX,')
16420CCCCC  CALL DPWRST('XXX','BUG ')
16421CCCCC  WRITE(ICOUT,4203)
16422C4203 FORMAT('      THE NUMBER OF ROWS IN THE MATRIX')
16423CCCCC  CALL DPWRST('XXX','BUG ')
16424CCCCC  WRITE(ICOUT,4204)
16425C4204 FORMAT('      MUST EQUAL')
16426CCCCC  CALL DPWRST('XXX','BUG ')
16427CCCCC  WRITE(ICOUT,4205)
16428C4205 FORMAT('      THE NUMBER OF COLUMNS IN THE MATRIX;')
16429CCCCC  CALL DPWRST('XXX','BUG ')
16430CCCCC  WRITE(ICOUT,4206)
16431C4206 FORMAT('      SUCH WAS NOT THE CASE HERE.')
16432CCCCC  CALL DPWRST('XXX','BUG ')
16433CCCCC  WRITE(ICOUT,4207)NR1
16434C4207 FORMAT('            NUMBER OF ROWS    =',I8)
16435CCCCC  CALL DPWRST('XXX','BUG ')
16436CCCCC  WRITE(ICOUT,4208)NC1
16437C4208 FORMAT('            NUMBER OF COLUMNS =',I8)
16438CCCCC  CALL DPWRST('XXX','BUG ')
16439CCCCC  IERROR='YES'
16440CCCCC  GOTO9000
16441C4209 CONTINUE
16442C
16443      IYS2=INT(YS2+0.1)
16444      IYS3=INT(YS3+0.1)
16445      I2=0
16446      J2=0
16447      DO4211I=1,NR1
16448      IF(I.EQ.IYS2)GOTO4211
16449      I2=I2+1
16450      NRJ=I2
16451      J2=0
16452      DO4212J=1,NC1
16453      IF(J.EQ.IYS3)GOTO4212
16454      J2=J2+1
16455      NCJ=J2
16456      YM2(I2,J2)=YM1(I,J)
16457 4212 CONTINUE
16458 4211 CONTINUE
16459C
16460      IF(NRJ.GE.1.AND.NCJ.GE.1)GOTO4229
16461      WRITE(ICOUT,999)
16462      CALL DPWRST('XXX','BUG ')
16463      WRITE(ICOUT,4221)
16464 4221 FORMAT('***** ERROR IN MATARI--')
16465      CALL DPWRST('XXX','BUG ')
16466      WRITE(ICOUT,4222)
16467 4222 FORMAT('      FOR MATRIX SUBMATRIX,')
16468      CALL DPWRST('XXX','BUG ')
16469      WRITE(ICOUT,4223)
16470 4223 FORMAT('      THE NUMBER OF ROWS IN THE SUBMATRIX, AND')
16471      CALL DPWRST('XXX','BUG ')
16472      WRITE(ICOUT,4224)
16473 4224 FORMAT('      THE NUMBER OF COLUMNS IN THE SUBMATRIX')
16474      CALL DPWRST('XXX','BUG ')
16475      WRITE(ICOUT,4225)
16476 4225 FORMAT('      MUST BOTH BE 1 OR LARGER;')
16477      CALL DPWRST('XXX','BUG ')
16478      WRITE(ICOUT,4226)
16479 4226 FORMAT('      SUCH WAS NOT THE CASE HERE.')
16480      CALL DPWRST('XXX','BUG ')
16481      WRITE(ICOUT,4227)NRJ
16482 4227 FORMAT('            NUMBER OF ROWS    =',I8)
16483      CALL DPWRST('XXX','BUG ')
16484      WRITE(ICOUT,4228)NCJ
16485 4228 FORMAT('            NUMBER OF COLUMNS =',I8)
16486      CALL DPWRST('XXX','BUG ')
16487      IERROR='YES'
16488      GOTO9000
16489 4229 CONTINUE
16490C
16491      DO4231I=1,NRJ
16492      DO4232J=1,NCJ
16493      YM9(I,J)=YM2(I,J)
16494 4232 CONTINUE
16495 4231 CONTINUE
16496C
16497      ITYP9='MATR'
16498CCCCC DECEMBER 1994.  FOLLOWING IS BACKWARDS.
16499CCCCC NR9=NCJ
16500CCCCC NC9=NRJ
16501      NR9=NRJ
16502      NC9=NCJ
16503      IUPFLG='FULL'
16504      GOTO9000
16505C
16506C               *****************************************************
16507C               **  STEP 43--                                      **
16508C               **  TREAT THE MATRIX     MINOR               CASE  **
16509C               **  REFERENCE--RALSTON, PAGE XXX                   **
16510C               *****************************************************
16511C
16512 4300 CONTINUE
16513C
16514      IF(NR1.EQ.NC1)GOTO4309
16515      WRITE(ICOUT,999)
16516      CALL DPWRST('XXX','BUG ')
16517      WRITE(ICOUT,4301)
16518 4301 FORMAT('***** ERROR IN MATARI--')
16519      CALL DPWRST('XXX','BUG ')
16520      WRITE(ICOUT,4302)
16521 4302 FORMAT('      FOR MATRIX MINOR,')
16522      CALL DPWRST('XXX','BUG ')
16523      WRITE(ICOUT,4303)
16524 4303 FORMAT('      THE NUMBER OF ROWS IN THE MATRIX')
16525      CALL DPWRST('XXX','BUG ')
16526      WRITE(ICOUT,4304)
16527 4304 FORMAT('      MUST EQUAL')
16528      CALL DPWRST('XXX','BUG ')
16529      WRITE(ICOUT,4305)
16530 4305 FORMAT('      THE NUMBER OF COLUMNS IN THE MATRIX;')
16531      CALL DPWRST('XXX','BUG ')
16532      WRITE(ICOUT,4306)
16533 4306 FORMAT('      SUCH WAS NOT THE CASE HERE.')
16534      CALL DPWRST('XXX','BUG ')
16535      WRITE(ICOUT,4307)NR1
16536 4307 FORMAT('            NUMBER OF ROWS    =',I8)
16537      CALL DPWRST('XXX','BUG ')
16538      WRITE(ICOUT,4308)NC1
16539 4308 FORMAT('            NUMBER OF COLUMNS =',I8)
16540      CALL DPWRST('XXX','BUG ')
16541      IERROR='YES'
16542      GOTO9000
16543 4309 CONTINUE
16544C
16545      IYS2=INT(YS2+0.1)
16546      IYS3=INT(YS3+0.1)
16547      I2=0
16548      J2=0
16549      DO4311I=1,NR1
16550      IF(I.EQ.IYS2)GOTO4311
16551      I2=I2+1
16552      NRJ=I2
16553      J2=0
16554      DO4312J=1,NC1
16555      IF(J.EQ.IYS3)GOTO4312
16556      J2=J2+1
16557      NCJ=J2
16558      YM2(I2,J2)=YM1(I,J)
16559 4312 CONTINUE
16560 4311 CONTINUE
16561C
16562      IF(NRJ.GE.1.AND.NCJ.GE.1)GOTO4329
16563      WRITE(ICOUT,999)
16564      CALL DPWRST('XXX','BUG ')
16565      WRITE(ICOUT,4321)
16566 4321 FORMAT('***** ERROR IN MATARI--')
16567      CALL DPWRST('XXX','BUG ')
16568      WRITE(ICOUT,4322)
16569 4322 FORMAT('      FOR MATRIX MINOR,')
16570      CALL DPWRST('XXX','BUG ')
16571      WRITE(ICOUT,4323)
16572 4323 FORMAT('      THE NUMBER OF ROWS IN THE SUBMATRIX, AND')
16573      CALL DPWRST('XXX','BUG ')
16574      WRITE(ICOUT,4324)
16575 4324 FORMAT('      THE NUMBER OF COLUMNS IN THE SUBMATRIX')
16576      CALL DPWRST('XXX','BUG ')
16577      WRITE(ICOUT,4325)
16578 4325 FORMAT('      MUST BOTH BE 1 OR LARGER;')
16579      CALL DPWRST('XXX','BUG ')
16580      WRITE(ICOUT,4326)
16581 4326 FORMAT('      SUCH WAS NOT THE CASE HERE.')
16582      CALL DPWRST('XXX','BUG ')
16583      WRITE(ICOUT,4327)NRJ
16584 4327 FORMAT('            NUMBER OF ROWS    =',I8)
16585      CALL DPWRST('XXX','BUG ')
16586      WRITE(ICOUT,4328)NCJ
16587 4328 FORMAT('            NUMBER OF COLUMNS =',I8)
16588      CALL DPWRST('XXX','BUG ')
16589      IERROR='YES'
16590      GOTO9000
16591 4329 CONTINUE
16592C
16593      IF(NRJ.EQ.NCJ)GOTO4339
16594      WRITE(ICOUT,999)
16595      CALL DPWRST('XXX','BUG ')
16596      WRITE(ICOUT,4331)
16597 4331 FORMAT('***** ERROR IN MATARI--')
16598      CALL DPWRST('XXX','BUG ')
16599      WRITE(ICOUT,4332)
16600 4332 FORMAT('      FOR MATRIX MINOR,')
16601      CALL DPWRST('XXX','BUG ')
16602      WRITE(ICOUT,4333)
16603 4333 FORMAT('      THE NUMBER OF ROWS IN THE SUBMATRIX')
16604      CALL DPWRST('XXX','BUG ')
16605      WRITE(ICOUT,4334)
16606 4334 FORMAT('      MUST EQUAL')
16607      CALL DPWRST('XXX','BUG ')
16608      WRITE(ICOUT,4335)
16609 4335 FORMAT('      THE NUMBER OF COLUMNS IN THE SUBMATRIX;')
16610      CALL DPWRST('XXX','BUG ')
16611      WRITE(ICOUT,4336)
16612 4336 FORMAT('      SUCH WAS NOT THE CASE HERE.')
16613      CALL DPWRST('XXX','BUG ')
16614      WRITE(ICOUT,4337)NRJ
16615 4337 FORMAT('            NUMBER OF ROWS    =',I8)
16616      CALL DPWRST('XXX','BUG ')
16617      WRITE(ICOUT,4338)NCJ
16618 4338 FORMAT('            NUMBER OF COLUMNS =',I8)
16619      CALL DPWRST('XXX','BUG ')
16620      IERROR='YES'
16621      GOTO9000
16622 4339 CONTINUE
16623C
16624CCCCC JULY 1993.  USE LINPACK ROUTINE TO COMPUTE THE DETERMINANT.
16625CCCCC CALL LUDCMP(YMJUNK,NRJ,MAXROM,INDEX,DP1M1)
16626C
16627CCCCC DPROD=DP1M1
16628CCCCC DO4341I=1,NRJ
16629CCCCC DYM9=YMJUNK(I,I)
16630CCCCC DPROD=DPROD*DYM9
16631C4341 CONTINUE
16632CCCCC DET=DPROD
16633CCCCC AMINOR=DET
16634C
16635      CALL SGECO(YM2,MAXROM,NRJ,INDEX,RCOND,Y3)
16636      EPS=1.0E-20
16637      IF(RCOND.LE.EPS)THEN
16638        WRITE(ICOUT,4371)
16639        CALL DPWRST('XXX','ERRO ')
16640        WRITE(ICOUT,4372)
16641        CALL DPWRST('XXX','ERRO ')
16642        COFACT=0.0
16643        IERROR='YES'
16644      ELSE
16645        IJOB=10
16646        CALL SGEDI(YM2,MAXROM,NRJ,INDEX,Y3,Y4,IJOB)
16647        DET=Y3(1)*10.0**Y3(2)
16648        AMINOR=DET
16649      END IF
16650 4371 FORMAT('****** ERROR IN MATARI ********')
16651 4372 FORMAT('       UNABLE TO COMPUTE THE DETERMINANT')
16652CCCCC END CHANGE
16653C
16654      ITYP9='SCAL'
16655      SCAL9=AMINOR
16656      IUPFLG='FULL'
16657      GOTO9000
16658C
16659C               *****************************************************
16660C               **  STEP 44--                                      **
16661C               **  TREAT THE MATRIX     COFACTOR            CASE  **
16662C               **  REFERENCE--RALSTON, PAGE XXX                   **
16663C               *****************************************************
16664C
16665 4400 CONTINUE
16666C
16667      IF(NR1.EQ.NC1)GOTO4409
16668      WRITE(ICOUT,999)
16669      CALL DPWRST('XXX','BUG ')
16670      WRITE(ICOUT,4401)
16671 4401 FORMAT('***** ERROR IN MATARI--')
16672      CALL DPWRST('XXX','BUG ')
16673      WRITE(ICOUT,4402)
16674 4402 FORMAT('      FOR MATRIX COFACTOR,')
16675      CALL DPWRST('XXX','BUG ')
16676      WRITE(ICOUT,4403)
16677 4403 FORMAT('      THE NUMBER OF ROWS IN THE MATRIX')
16678      CALL DPWRST('XXX','BUG ')
16679      WRITE(ICOUT,4404)
16680 4404 FORMAT('      MUST EQUAL')
16681      CALL DPWRST('XXX','BUG ')
16682      WRITE(ICOUT,4405)
16683 4405 FORMAT('      THE NUMBER OF COLUMNS IN THE MATRIX;')
16684      CALL DPWRST('XXX','BUG ')
16685      WRITE(ICOUT,4406)
16686 4406 FORMAT('      SUCH WAS NOT THE CASE HERE.')
16687      CALL DPWRST('XXX','BUG ')
16688      WRITE(ICOUT,4407)NR1
16689 4407 FORMAT('            NUMBER OF ROWS    =',I8)
16690      CALL DPWRST('XXX','BUG ')
16691      WRITE(ICOUT,4408)NC1
16692 4408 FORMAT('            NUMBER OF COLUMNS =',I8)
16693      CALL DPWRST('XXX','BUG ')
16694      IERROR='YES'
16695      GOTO9000
16696 4409 CONTINUE
16697C
16698      IYS2=INT(YS2+0.1)
16699      IYS3=INT(YS3+0.1)
16700      I2=0
16701      J2=0
16702      DO4411I=1,NR1
16703      IF(I.EQ.IYS2)GOTO4411
16704      I2=I2+1
16705      NRJ=I2
16706      J2=0
16707      DO4412J=1,NC1
16708      IF(J.EQ.IYS3)GOTO4412
16709      J2=J2+1
16710      NCJ=J2
16711      YM2(I2,J2)=YM1(I,J)
16712 4412 CONTINUE
16713 4411 CONTINUE
16714C
16715      IF(NRJ.GE.1.AND.NCJ.GE.1)GOTO4429
16716      WRITE(ICOUT,999)
16717      CALL DPWRST('XXX','BUG ')
16718      WRITE(ICOUT,4421)
16719 4421 FORMAT('***** ERROR IN MATARI--')
16720      CALL DPWRST('XXX','BUG ')
16721      WRITE(ICOUT,4422)
16722 4422 FORMAT('      FOR MATRIX COFACTOR,')
16723      CALL DPWRST('XXX','BUG ')
16724      WRITE(ICOUT,4423)
16725 4423 FORMAT('      THE NUMBER OF ROWS IN THE SUBMATRIX, AND')
16726      CALL DPWRST('XXX','BUG ')
16727      WRITE(ICOUT,4424)
16728 4424 FORMAT('      THE NUMBER OF COLUMNS IN THE SUBMATRIX')
16729      CALL DPWRST('XXX','BUG ')
16730      WRITE(ICOUT,4425)
16731 4425 FORMAT('      MUST BOTH BE 1 OR LARGER;')
16732      CALL DPWRST('XXX','BUG ')
16733      WRITE(ICOUT,4426)
16734 4426 FORMAT('      SUCH WAS NOT THE CASE HERE.')
16735      CALL DPWRST('XXX','BUG ')
16736      WRITE(ICOUT,4427)NRJ
16737 4427 FORMAT('            NUMBER OF ROWS    =',I8)
16738      CALL DPWRST('XXX','BUG ')
16739      WRITE(ICOUT,4428)NCJ
16740 4428 FORMAT('            NUMBER OF COLUMNS =',I8)
16741      CALL DPWRST('XXX','BUG ')
16742      IERROR='YES'
16743      GOTO9000
16744 4429 CONTINUE
16745C
16746      IF(NRJ.EQ.NCJ)GOTO4439
16747      WRITE(ICOUT,999)
16748      CALL DPWRST('XXX','BUG ')
16749      WRITE(ICOUT,4431)
16750 4431 FORMAT('***** ERROR IN MATARI--')
16751      CALL DPWRST('XXX','BUG ')
16752      WRITE(ICOUT,4432)
16753 4432 FORMAT('      FOR MATRIX COFACTOR,')
16754      CALL DPWRST('XXX','BUG ')
16755      WRITE(ICOUT,4433)
16756 4433 FORMAT('      THE NUMBER OF ROWS IN THE SUBMATRIX')
16757      CALL DPWRST('XXX','BUG ')
16758      WRITE(ICOUT,4434)
16759 4434 FORMAT('      MUST EQUAL')
16760      CALL DPWRST('XXX','BUG ')
16761      WRITE(ICOUT,4435)
16762 4435 FORMAT('      THE NUMBER OF COLUMNS IN THE SUBMATRIX;')
16763      CALL DPWRST('XXX','BUG ')
16764      WRITE(ICOUT,4436)
16765 4436 FORMAT('      SUCH WAS NOT THE CASE HERE.')
16766      CALL DPWRST('XXX','BUG ')
16767      WRITE(ICOUT,4437)NRJ
16768 4437 FORMAT('            NUMBER OF ROWS    =',I8)
16769      CALL DPWRST('XXX','BUG ')
16770      WRITE(ICOUT,4438)NCJ
16771 4438 FORMAT('            NUMBER OF COLUMNS =',I8)
16772      CALL DPWRST('XXX','BUG ')
16773      IERROR='YES'
16774      GOTO9000
16775 4439 CONTINUE
16776C
16777CCCCC JULY 1993.  USE LINPACK ROUTINE TO COMPUTE THE DETERMINANT.
16778CCCCC CALL LUDCMP(YMJUNK,NRJ,MAXROM,INDEX,DP1M1)
16779C
16780CCCCC DPROD=DP1M1
16781CCCCC DO4441I=1,NRJ
16782CCCCC DYM9=YMJUNK(I,I)
16783CCCCC DPROD=DPROD*DYM9
16784C4441 CONTINUE
16785CCCCC DET=DPROD
16786C
16787      CALL SGECO(YM2,MAXROM,NRJ,INDEX,RCOND,Y3)
16788      EPS=1.0E-20
16789      IF(RCOND.LE.EPS)THEN
16790        WRITE(ICOUT,4471)
16791        CALL DPWRST('XXX','ERRO ')
16792        WRITE(ICOUT,4472)
16793        CALL DPWRST('XXX','ERRO ')
16794        COFACT=0.0
16795        IERROR='YES'
16796      ELSE
16797        IJOB=10
16798        CALL SGEDI(YM2,MAXROM,NRJ,INDEX,Y3,Y4,IJOB)
16799        DET=Y3(1)*10.0**Y3(2)
16800        COFACT=DET
16801        IYS23=IYS2+IYS3
16802        IREM=IYS23-2*(IYS23/2)
16803        IF(IREM.EQ.1)COFACT=(-COFACT)
16804      END IF
16805 4471 FORMAT('****** ERROR IN MATARI ********')
16806 4472 FORMAT('       UNABLE TO COMPUTE THE DETERMINANT')
16807CCCCC END CHANGE
16808C
16809      ITYP9='SCAL'
16810      SCAL9=COFACT
16811      IUPFLG='FULL'
16812      GOTO9000
16813C
16814C               *****************************************************
16815C               **  STEP 45--                                      **
16816C               **  TREAT THE MATRIX     DEFINITION          CASE  **
16817C               **  REFERENCE--RALSTON, PAGE XXX                   **
16818C               *****************************************************
16819C
16820CCCCC OCTOBER 1993.  ADD OPTIONAL SYNTAX.  IF FOURTH PARAMETER
16821CCCCC SPECIFIED, LET IT BE THE STARTING ROW NUMBER.
16822 4500 CONTINUE
16823C
16824      IF(ITYPA4.EQ.'PARA')GOTO4560
16825      DO4511I=1,NR1
16826      DO4512J=1,NC1
16827      YM9(I,J)=YM1(I,J)
16828 4512 CONTINUE
16829 4511 CONTINUE
16830C
16831      ITYP9='MATR'
16832      NR9=NR1
16833      NC9=NC1
16834      GOTO9000
16835CCCCC OCTOBER 1993.  ADD FOLLOWING SECTION
16836 4560 CONTINUE
16837      IROWID=INT(YS4+0.5)
16838      IF(IROWID.LT.1.OR.IROWID.GT.NR1)IROWID=1
16839      ICOUNT=0
16840CCCCC NLAST=IROWID+NR1-1
16841      NLAST=NR1
16842      IF(NLAST.GT.MAXROM)NLAST=MAXROM
16843      DO4561I=IROWID,NLAST
16844      ICOUNT=ICOUNT+1
16845      DO4562J=1,NC1
16846      YM9(ICOUNT,J)=YM1(I,J)
16847 4562 CONTINUE
16848 4561 CONTINUE
16849C
16850      ITYP9='MATR'
16851      NR9=ICOUNT
16852      NC9=NC1
16853      IUPFLG='FULL'
16854      GOTO9000
16855C
16856C               *****************************************************
16857C               **  STEP 46--                                      **
16858C               **  TREAT THE MATRIX     EUCLIDEAN NORM      CASE  **
16859C               **  REFERENCE--RALSTON, PAGE XXX                   **
16860C               *****************************************************
16861C
16862 4600 CONTINUE
16863C
16864      DSUM1=0.0D0
16865      DO4621I=1,NR1
16866      DO4622J=1,NC1
16867      DYM1=YM1(I,J)
16868      DSUM1=DSUM1+DYM1*DYM1
16869 4622 CONTINUE
16870 4621 CONTINUE
16871      DSUM2=0.0D0
16872      IF(DSUM1.GT.0.0D0)DSUM2=SQRT(DSUM1)
16873C
16874      ITYP9='SCAL'
16875      SCAL9=DSUM2
16876      IUPFLG='FULL'
16877      GOTO9000
16878C
16879C               **************************************************************
16880C               **  STEP 51--                                               **
16881C               **  TREAT THE VARIANCE-COVARIANCE CASE                      **
16882C               **************************************************************
16883C
16884 5100 CONTINUE
16885C
16886CCCCC JULY 2002.  SUPPORT FOR WINSORIZED CORRELATION.
16887C
16888CCCCC NOVEMBER 2004.  SUPPORT FOR ROW BASED (AS OPPOSSED TO COLUMN
16889CCCCC                 BASED COVARIANCES.
16890C
16891      NTRIM1=-1
16892      NTRIM2=-1
16893      IF(ICOVDI.EQ.'COLU')THEN
16894        IWRITE='OFF'
16895        DO5151J=1,NC1
16896          DO5161K=1,NC1
16897            DO5155I=1,NR1
16898              Y3(I)=YM1(I,J)
16899              Y4(I)=YM1(I,K)
16900 5155       CONTINUE
16901            IF(ICOVTY.EQ.'RANK')THEN
16902              CALL RANKCV(Y3,Y4,NR1,IWRITE,Y1,Y2,VECT9,MAXOBV,RIGHT,
16903     1                    IBUGA3,IERROR)
16904            ELSEIF(ICOVTY.EQ.'WINS')THEN
16905              CALL WINSOR(Y3,NR1,P1,P2,NTRIM1,NTRIM2,IWRITE,
16906     1                    Y1,MAXOBV,Y2,
16907     1                    IBUGA3,ISUBRO,IERROR)
16908              DO5181I=1,NR1
16909                Y3(I)=Y2(I)
16910 5181         CONTINUE
16911              CALL WINSOR(Y4,NR1,P1,P2,NTRIM1,NTRIM2,IWRITE,
16912     1                    Y1,MAXOBV,Y2,
16913     1                    IBUGA3,ISUBRO,IERROR)
16914              DO5186I=1,NR1
16915                Y4(I)=Y2(I)
16916 5186         CONTINUE
16917              CALL COV(Y3,Y4,NR1,IWRITE,RIGHT,IBUGA3,IERROR)
16918            ELSEIF(ICOVTY.EQ.'BIWE')THEN
16919              CALL BIWMCV(Y3,Y4,NR1,IWRITE,Y1,Y2,MAXOBV,RIGHT,
16920     1                    IBUGA3,IERROR)
16921            ELSE
16922              CALL COV(Y3,Y4,NR1,IWRITE,RIGHT,IBUGA3,IERROR)
16923            ENDIF
16924            YM9(J,K)=RIGHT
16925 5161     CONTINUE
16926 5151   CONTINUE
16927        NR9=NC1
16928        NC9=NC1
16929      ELSE
16930        IWRITE='OFF'
16931        DO5121J=1,NR1
16932          DO5131K=1,NR1
16933            DO5125I=1,NC1
16934              Y3(I)=YM1(J,I)
16935              Y4(I)=YM1(K,I)
16936 5125       CONTINUE
16937            IF(ICOVTY.EQ.'RANK')THEN
16938              CALL RANKCV(Y3,Y4,NC1,IWRITE,Y1,Y2,VECT9,MAXOBV,RIGHT,
16939     1                    IBUGA3,IERROR)
16940            ELSEIF(ICOVTY.EQ.'WINS')THEN
16941              CALL WINSOR(Y3,NC1,P1,P2,NTRIM1,NTRIM2,IWRITE,
16942     1                    Y1,MAXOBV,Y2,
16943     1                    IBUGA3,ISUBRO,IERROR)
16944              DO5141I=1,NC1
16945                Y3(I)=Y2(I)
16946 5141         CONTINUE
16947              CALL WINSOR(Y4,NC1,P1,P2,NTRIM1,NTRIM2,IWRITE,
16948     1                    Y1,MAXOBV,Y2,
16949     1                    IBUGA3,ISUBRO,IERROR)
16950              DO5146I=1,NC1
16951                Y4(I)=Y2(I)
16952 5146         CONTINUE
16953              CALL COV(Y3,Y4,NC1,IWRITE,RIGHT,IBUGA3,IERROR)
16954            ELSEIF(ICOVTY.EQ.'BIWE')THEN
16955              CALL BIWMCV(Y3,Y4,NC1,IWRITE,Y1,Y2,MAXOBV,RIGHT,
16956     1                    IBUGA3,IERROR)
16957            ELSE
16958              CALL COV(Y3,Y4,NC1,IWRITE,RIGHT,IBUGA3,IERROR)
16959            ENDIF
16960            YM9(J,K)=RIGHT
16961 5131     CONTINUE
16962 5121   CONTINUE
16963        NR9=NC1
16964        NC9=NC1
16965      ENDIF
16966C
16967C
16968      ITYP9='MATR'
16969      IUPFLG='FULL'
16970      GOTO9000
16971C
16972C               ******************************************************
16973C               **  STEP 52--                                       **
16974C               **  TREAT THE CORRELATION CASE                      **
16975C               ******************************************************
16976C
16977 5200 CONTINUE
16978C
16979CCCCC JULY 2002.       SUPPORT FOR WINSORIZED CORRELATION, RANK CORRELATION,
16980CCCCC                  BIWEIGHT MID CORRELATION.
16981CCCCC NOVEMBER  2004.  SUPPORT FOR ROW BASED (AS OPPOSSED TO COLUMN
16982CCCCC                  BASED CORRELATIONS.  ALSO, ADD SUPPORT FOR
16983CCCCC                  KENDELL'S TAU CORRELATION.
16984CCCCC JUNE      2012.  SUPPORT FOR CORRELATION CDF MATRIX AND
16985CCCCC                              CORRELATION PVALUE MATRIX
16986CCCCC SEPTEMBER 2016.  SUPPORT FOR:
16987CCCCC                          SET CORRELATION ABSOLUTE VALUE <ON/OFF>
16988CCCCC                          SET CORRELATION PERCENTAGE VALUE <ON/OFF>
16989CCCCC                          SET CORRELATION DIGITS <VALUE>
16990C
16991      NTRIM1=-1
16992      NTRIM2=-1
16993      IF(ICORDI.EQ.'COLU')THEN
16994        IWRITE='OFF'
16995        DO5251J=1,NC1
16996          DO5261K=1,NC1
16997            DO5255I=1,NR1
16998              Y3(I)=YM1(I,J)
16999              Y4(I)=YM1(I,K)
17000 5255       CONTINUE
17001            IF(ICORTY.EQ.'RANK')THEN
17002              CALL RANKCR(Y3,Y4,NR1,IRCRTA,IWRITE,Y1,Y2,VECT9,MAXOBV,
17003     1                    RIGHT,STATCD,PVAL,PVALLT,PVALUT,
17004     1                    CUTU90,CUTU95,CTU975,CUTU99,CTU995,CTU999,
17005     1                    CUTL90,CUTL95,CTL975,CUTL99,CTL995,CTL999,
17006     1                    IBUGA3,ISUBRO,IERROR)
17007            ELSEIF(ICORTY.EQ.'WINS')THEN
17008              CALL WINSOR(Y3,NR1,P1,P2,NTRIM1,NTRIM2,IWRITE,
17009     1                    Y1,MAXOBV,Y2,
17010     1                    IBUGA3,ISUBRO,IERROR)
17011              DO5281I=1,NR1
17012                Y3(I)=Y2(I)
17013 5281         CONTINUE
17014              CALL WINSOR(Y4,NR1,P1,P2,NTRIM1,NTRIM2,IWRITE,
17015     1                    Y1,MAXOBV,Y2,
17016     1                    IBUGA3,ISUBRO,IERROR)
17017              DO5286I=1,NR1
17018                Y4(I)=Y2(I)
17019 5286         CONTINUE
17020              CALL CORR(Y3,Y4,NR1,IWRITE,RIGHT,IBUGA3,IERROR)
17021            ELSEIF(ICORTY.EQ.'PBCR')THEN
17022              CALL PBNCOR(Y3,Y4,NR1,IWRITE,Y1,Y2,MAXOBV,RIGHT,BETA,
17023     1                    IBUGA3,IERROR)
17024            ELSEIF(ICOVTY.EQ.'BIWE')THEN
17025              CALL BIWMDV(Y3,NR1,IWRITE,Y1,Y2,MAXOBV,RIGH1,
17026     1                    IBUGA3,IERROR)
17027              CALL BIWMDV(Y4,NR1,IWRITE,Y1,Y2,MAXOBV,RIGH2,
17028     1                    IBUGA3,IERROR)
17029              CALL BIWMCV(Y3,Y4,NR1,IWRITE,Y1,Y2,MAXOBV,RIGH3,
17030     1                    IBUGA3,IERROR)
17031              RIGH4=RIGH1*RIGH2
17032              IF(RIGH4.GT.0.0)THEN
17033                RIGHT=RIGH3/SQRT(RIGH4)
17034              ELSE
17035                RIGHT=0.0
17036              ENDIF
17037            ELSEIF(ICORTY.EQ.'KTAU')THEN
17038              ICASZZ='TWOS'
17039              CALL KENTAU(Y3,Y4,NR1,ICASZZ,IKTATA,IWRITE,Y1,Y2,MAXOBV,
17040     1                    RIGHT,AKTAUA,AKTAUB,AKTAUC,
17041     1                    STATCD,PVAL,PVALLT,PVALUT,
17042     1                    CUTU90,CUTU95,CTU975,CUTU99,CTU995,
17043     1                    CUTL90,CUTL95,CTL975,CUTL99,CTL995,
17044     1                    IBUGA3,ISUBRO,IERROR)
17045            ELSE
17046              CALL CORR(Y3,Y4,NR1,IWRITE,RIGHT,IBUGA3,IERROR)
17047            ENDIF
17048            IF(ICORAV.EQ.'ON')RIGHT=ABS(RIGHT)
17049            IF(ICORPV.EQ.'ON')RIGHT=100.*RIGHT
17050            IF(ICORDG.EQ.0)THEN
17051               RIGHT=INT(RIGHT+0.5)
17052            ELSEIF(ICORDG.GE.1 .AND. ICORDG.LE.6)THEN
17053              IPOWER=INT(AINT(ICORDG+0.5))
17054              RIGHT=REAL(INT(RIGHT*10**IPOWER + 0.5))/10**IPOWER
17055            ENDIF
17056            YM9(J,K)=RIGHT
17057 5261     CONTINUE
17058 5251   CONTINUE
17059        NR9=NC1
17060        NC9=NC1
17061      ELSE
17062        IWRITE='OFF'
17063        DO5221J=1,NR1
17064          DO5231K=1,NR1
17065            DO5225I=1,NC1
17066              Y3(I)=YM1(J,I)
17067              Y4(I)=YM1(K,I)
17068 5225       CONTINUE
17069            IF(ICORTY.EQ.'RANK')THEN
17070              CALL RANKCR(Y3,Y4,NC1,IRCRTA,IWRITE,Y1,Y2,VECT9,MAXOBV,
17071     1                    RIGHT,STATCD,PVAL,PVALLT,PVALUT,
17072     1                    CUTU90,CUTU95,CTU975,CUTU99,CTU995,CTU999,
17073     1                    CUTL90,CUTL95,CTL975,CUTL99,CTL995,CTL999,
17074     1                    IBUGA3,ISUBRO,IERROR)
17075            ELSEIF(ICORTY.EQ.'WINS')THEN
17076              CALL WINSOR(Y3,NC1,P1,P2,NTRIM1,NTRIM2,IWRITE,
17077     1                    Y1,MAXOBV,Y2,
17078     1                    IBUGA3,ISUBRO,IERROR)
17079              DO5241I=1,NC1
17080                Y3(I)=Y2(I)
17081 5241         CONTINUE
17082              CALL WINSOR(Y4,NC1,P1,P2,NTRIM1,NTRIM2,IWRITE,
17083     1                    Y1,MAXOBV,Y2,
17084     1                    IBUGA3,ISUBRO,IERROR)
17085              DO5246I=1,NC1
17086                Y4(I)=Y2(I)
17087 5246         CONTINUE
17088              CALL CORR(Y3,Y4,NC1,IWRITE,RIGHT,IBUGA3,IERROR)
17089            ELSEIF(ICORTY.EQ.'PBCR')THEN
17090              CALL PBNCOR(Y3,Y4,NC1,IWRITE,Y1,Y2,MAXOBV,RIGHT,BETA,
17091     1                    IBUGA3,IERROR)
17092            ELSEIF(ICOVTY.EQ.'BIWE')THEN
17093              CALL BIWMDV(Y3,NC1,IWRITE,Y1,Y2,MAXOBV,RIGH1,
17094     1                    IBUGA3,IERROR)
17095              CALL BIWMDV(Y4,NC1,IWRITE,Y1,Y2,MAXOBV,RIGH2,
17096     1                    IBUGA3,IERROR)
17097              CALL BIWMCV(Y3,Y4,NC1,IWRITE,Y1,Y2,MAXOBV,RIGH3,
17098     1                    IBUGA3,IERROR)
17099              RIGH4=RIGH1*RIGH2
17100              IF(RIGH4.GT.0.0)THEN
17101                RIGHT=RIGH3/SQRT(RIGH4)
17102              ELSE
17103                RIGHT=0.0
17104              ENDIF
17105            ELSEIF(ICORTY.EQ.'KTAU')THEN
17106              ICASZZ='TWOS'
17107              CALL KENTAU(Y3,Y4,NC1,ICASZZ,IKTATA,IWRITE,Y1,Y2,MAXOBV,
17108     1                    RIGHT,AKTAUA,AKTAUB,AKTAUC,
17109     1                    STATCD,PVAL,PVALLT,PVALUT,
17110     1                    CUTU90,CUTU95,CTU975,CUTU99,CTU995,
17111     1                    CUTL90,CUTL95,CTL975,CUTL99,CTL995,
17112     1                    IBUGA3,ISUBRO,IERROR)
17113            ELSE
17114              CALL CORR(Y3,Y4,NC1,IWRITE,RIGHT,IBUGA3,IERROR)
17115            ENDIF
17116            IF(ICORAV.EQ.'ON')RIGHT=ABS(RIGHT)
17117            IF(ICORPV.EQ.'ON')RIGHT=100.*RIGHT
17118            IF(ICORDG.EQ.0)THEN
17119               RIGHT=INT(RIGHT+0.5)
17120            ELSEIF(ICORDG.GE.1 .AND. ICORDG.LE.6)THEN
17121              IPOWER=INT(AINT(ICORDG+0.5))
17122              RIGHT=REAL(INT(RIGHT*10**IPOWER + 0.5))/10**IPOWER
17123            ENDIF
17124            YM9(J,K)=RIGHT
17125 5231     CONTINUE
17126 5221   CONTINUE
17127        NR9=NR1
17128        NC9=NR1
17129      ENDIF
17130C
17131C       SAVE EITHER THE CDF VALUES OR THE P-VALUES.
17132C
17133      IF(IMCASE.EQ.'MACC')THEN
17134        IDF1=1
17135        IDF2=NR1 - 2
17136        DO5291J=1,NC9
17137          DO5292I=1,NR9
17138            IF(I.EQ.J)THEN
17139              YM9(I,J)=0.0
17140            ELSE
17141              ANUM=REAL(NR1 - 2)*YM9(I,J)**2
17142              DENOM=1.0 - YM9(I,J)**2
17143              CDF=0.0
17144              IF(DENOM.NE.0.0)THEN
17145                AVAL=ABS(ANUM/DENOM)
17146                CALL FCDF(AVAL,IDF1,IDF2,CDF)
17147              ENDIF
17148              YM9(I,J)=CDF
17149            ENDIF
17150 5292     CONTINUE
17151 5291   CONTINUE
17152      ELSEIF(IMCASE.EQ.'MACP')THEN
17153        IDF1=1
17154        IDF2=NR1 - 2
17155        DO5296J=1,NC9
17156          DO5297I=1,NR9
17157            IF(I.EQ.J)THEN
17158              YM9(I,J)=1.0
17159            ELSE
17160              ANUM=REAL(NR1 - 2)*YM9(I,J)**2
17161              DENOM=1.0 - YM9(I,J)**2
17162              CDF=0.0
17163              IF(DENOM.NE.0.0)THEN
17164                AVAL=ABS(ANUM/DENOM)
17165                CALL FCDF(AVAL,IDF1,IDF2,CDF)
17166              ENDIF
17167              YM9(I,J)=1.0 - CDF
17168            ENDIF
17169 5297     CONTINUE
17170 5296   CONTINUE
17171      ENDIF
17172C
17173      ITYP9='MATR'
17174      IUPFLG='FULL'
17175      GOTO9000
17176C
17177C               **************************************************************
17178C               **  STEP 53--                                               **
17179C               **  TREAT THE PRINCIPLE COMPONENTS CASE                     **
17180C               **  TREAT THE PRINCIPLE COMPONENTS EIGENVECTORS CASE        **
17181C               **  TREAT THE PRINCIPLE COMPONENTS EIGENVALUES CASE         **
17182C               **  REFERENCE--JACKSON, J. E. (1980, 1981)                  **
17183C               **             PRINCIPLE COMPONENTS AND FACTOR ANALYSIS:    **
17184C               **             PART 1--PRINCIPLE COMPONENTS,                **
17185C               **             JQT OCT 1980, PAGES 201-213.                 **
17186C               **             PART 2--ADDITIONAL TOPICS RELATED            **
17187C               **             TO PRINCIPLE COMPONENTS,                     **
17188C               **             JQT JAN 1981, PAGES 46-58.                   **
17189C               **             PART 3--WHAT IS FACTOR ANALYSIS?,            **
17190C               **             JQT APR 1981, PAGES 125-130.                 **
17191C               **  REFERENCE--LAWTON, W. H., SYLVESTRE, E. A.,             **
17192C               **             AND MAGGIA, M. S. (1972).                    **
17193C               **             SELF MODELING NONLINEAR REGRESSION.          **
17194C               **             TECHNOMETRICS, AUGUST, 1972,                 **
17195C               **             PAGES 513-532.                               **
17196C               **************************************************************
17197C
17198 5300 CONTINUE
17199C
17200      IF(PCCASE.EQ.'DACV')GOTO5310
17201      IF(PCCASE.EQ.'DACR')GOTO5310
17202      GOTO5329
17203C
17204 5310 CONTINUE
17205      DO5311J=1,NC1
17206      DSUM1=0.0D0
17207      DO5312I=1,NR1
17208      DYM1=YM1(I,J)
17209      DSUM1=DSUM1+DYM1
17210 5312 CONTINUE
17211      DMEAN(J)=D999
17212      DDENOM=DNR1
17213      IF(DDENOM.NE.0.0D0)DMEAN(J)=DSUM1/DDENOM
17214 5311 CONTINUE
17215C
17216      DO5321J=1,NC1
17217      DO5322K=J,NC1
17218      DSUM1=0.0D0
17219      DO5323I=1,NR1
17220      DYM1=YM1(I,J)
17221      DYM2=YM1(I,K)
17222      DDEL1=DYM1-DMEAN(J)
17223      DDEL2=DYM2-DMEAN(K)
17224      DSUM1=DSUM1+DDEL1*DDEL2
17225 5323 CONTINUE
17226      DCOV=D999
17227      DDENOM=DNR1-1.0D0
17228      IF(DDENOM.NE.0.0D0)DCOV=DSUM1/DDENOM
17229      YM2(J,K)=DCOV
17230      YM2(K,J)=DCOV
17231 5322 CONTINUE
17232 5321 CONTINUE
17233 5329 CONTINUE
17234C
17235      IF(PCCASE.EQ.'DACV')GOTO5360
17236      IF(PCCASE.EQ.'DACR')GOTO5340
17237      IF(PCCASE.EQ.'CVCV')GOTO5330
17238      IF(PCCASE.EQ.'CVCR')GOTO5330
17239      IF(PCCASE.EQ.'CRCV')GOTO5350
17240      IF(PCCASE.EQ.'CRCR')GOTO5330
17241      GOTO5360
17242C
17243 5330 CONTINUE
17244      DO5331I=1,NR1
17245      DO5332J=1,NC1
17246      YM2(I,J)=YM1(I,J)
17247 5332 CONTINUE
17248 5331 CONTINUE
17249      IF(PCCASE.EQ.'CVCR')GOTO5340
17250      GOTO5360
17251C
17252 5340 CONTINUE
17253      DO5341I=1,NC1
17254      S1=YM2(I,I)
17255      S1=SQRT(S1)
17256      DO5342J=1,NC1
17257      S2=YM2(J,J)
17258      S2=SQRT(S2)
17259      IF(I.EQ.J)GOTO5342
17260      S1S2=S1*S2
17261      IF(S1S2.LE.0.0)YM2(I,J)=(-999.99)
17262      IF(S1S2.GT.0.0)YM2(I,J)=YM2(I,J)/S1S2
17263 5342 CONTINUE
17264 5341 CONTINUE
17265      DO5343I=1,NC1
17266      YM2(I,I)=1.0
17267 5343 CONTINUE
17268      GOTO5360
17269C
17270 5350 CONTINUE
17271      WRITE(ICOUT,999)
17272      CALL DPWRST('XXX','BUG ')
17273      WRITE(ICOUT,5351)
17274 5351 FORMAT('***** ERROR IN MATARI--')
17275      CALL DPWRST('XXX','BUG ')
17276      WRITE(ICOUT,5352)
17277 5352 FORMAT('       ILLEGAL PRINCIPLE COMPONENTS TYPE.')
17278      CALL DPWRST('XXX','BUG ')
17279      WRITE(ICOUT,5353)
17280 5353 FORMAT('      YOU CANNOT SPECIFY THAT THE STARTING MATRIX')
17281      CALL DPWRST('XXX','BUG ')
17282      WRITE(ICOUT,5354)
17283 5354 FORMAT('      IS THE CORRELATION MATRIX,')
17284      CALL DPWRST('XXX','BUG ')
17285      WRITE(ICOUT,5355)
17286 5355 FORMAT('      AND THEN SPECIFY THAT THE INTERMEDIATE MATRIX')
17287      CALL DPWRST('XXX','BUG ')
17288      WRITE(ICOUT,5356)
17289 5356 FORMAT('      IS THE COVARIANCE MATRIX')
17290      CALL DPWRST('XXX','BUG ')
17291      WRITE(ICOUT,5357)
17292 5357 FORMAT('      (SINCE LATTER CANNOT BE DERIVED FROM FORMER).')
17293      CALL DPWRST('XXX','BUG ')
17294      WRITE(ICOUT,5358)
17295 5358 FORMAT('      FIX BY USING THE    PRINCIPLE COMPONENTS TYPE')
17296      CALL DPWRST('XXX','BUG ')
17297      WRITE(ICOUT,5359)
17298 5359 FORMAT('      COMMAND.')
17299      CALL DPWRST('XXX','BUG ')
17300      IERROR='YES'
17301      GOTO9000
17302C
17303 5360 CONTINUE
17304      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TARI')GOTO5361
17305      GOTO5369
17306 5361 CONTINUE
17307      WRITE(ICOUT,999)
17308      CALL DPWRST('XXX','BUG ')
17309      WRITE(ICOUT,5362)
17310 5362 FORMAT('***** FROM THE MIDDLE OF MATARI--')
17311      CALL DPWRST('XXX','BUG ')
17312      WRITE(ICOUT,5363)NC1,MAXCOM
17313 5363 FORMAT('NC1,MAXCOM = ',2I8)
17314      CALL DPWRST('XXX','BUG ')
17315      DO5364I=1,NC1
17316      DO5365J=1,NC1
17317      WRITE(ICOUT,5366)I,J,YM2(I,J)
17318 5366 FORMAT('I,J,YM2(I,J) = ',2I8,E15.7)
17319      CALL DPWRST('XXX','BUG ')
17320 5365 CONTINUE
17321 5364 CONTINUE
17322 5369 CONTINUE
17323C
17324CCCCC JULY 1993.  USE EISPACK ROUTINES (NOTE THAT CORRELATION OR
17325CCCCC COVARIANCE MATRIX IS SYMMETRIC).
17326CCCCC ALSO, SINCE MAXROM AND MAXCOM NO LONGER EQUAL, BE SURE TO SEND
17327CCCCC MAXROM AS MATRIX LEADING DIMENSION.
17328CCCCC CALL JACOBI(YMJUNK,NC1,MAXCOM,VJUNK,YM9,NJACIT)
17329C
17330      IERR2=0
17331      IJOB=1
17332      DO5650J=1,NC1
17333      DO5651I=1,NC1
17334      YM9(I,J)=YM2(I,J)
17335 5651 CONTINUE
17336 5650 CONTINUE
17337      CALL SSIEV(YM9,MAXROM,NC1,Y3,Y4,IJOB,IERR2)
17338      IF(IERR2.NE.0)THEN
17339        IERROR='YES'
17340        WRITE(ICOUT,5661)
17341        WRITE(ICOUT,5662)
17342        WRITE(ICOUT,5663)
17343        GOTO9000
17344      END IF
17345 5661 FORMAT('******** ERROR FROM MATARI ************')
17346 5662 FORMAT('         UNABLE TO CALCULATE EIGENVALUES CORRECTLY.')
17347 5663 FORMAT('         PRINCIPLE COMPONENTS WERE NOT COMPUTED.')
17348CCCCC END CHANGE
17349C
17350      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TARI')GOTO5371
17351      GOTO5379
17352 5371 CONTINUE
17353      WRITE(ICOUT,999)
17354      CALL DPWRST('XXX','BUG ')
17355      WRITE(ICOUT,5372)
17356 5372 FORMAT('***** FROM THE MIDDLE OF MATARI--')
17357      CALL DPWRST('XXX','BUG ')
17358CCCCC WRITE(ICOUT,5373)NC1,MAXCOM,NJACIT
17359C5373 FORMAT('NC1,MAXCOM,NJACIT = ',3I8)
17360      WRITE(ICOUT,5373)NC1,MAXCOM
17361 5373 FORMAT('NC1,MAXCOM= ',2I8)
17362      CALL DPWRST('XXX','BUG ')
17363      DO5374I=1,NC1
17364      DO5375J=1,NC1
17365      WRITE(ICOUT,5376)I,J,YM9(I,J),Y3(I)
17366 5376 FORMAT('I,J,YM9(I,J),Y3(I) = ',2I8,2E15.7)
17367      CALL DPWRST('XXX','BUG ')
17368 5375 CONTINUE
17369 5374 CONTINUE
17370 5379 CONTINUE
17371C
17372      DO5380I=1,NC1
17373CCCCC AINDE2(I)=I
17374      Y1(I)=I
17375 5380 CONTINUE
17376C
17377CCCCC CALL SORTC(Y3,AINDE2,NC1,Y4,AINDE3)
17378      CALL SORTC(Y3,Y1,NC1,Y4,Y2)
17379C
17380      DO5390J=1,NC1
17381      JREV=NC1-J+1
17382CCCCC INDEX3=AINDE3(JREV)+0.5
17383      INDEX3=INT(Y2(JREV)+0.5)
17384      VECT9(J)=Y3(INDEX3)
17385 5390 CONTINUE
17386C
17387      DO5411J=1,NC1
17388      JREV=NC1-J+1
17389CCCCC INDEX3=AINDE3(JREV)+0.5
17390      INDEX3=INT(Y2(JREV)+0.5)
17391      DO5412I=1,NC1
17392      YM2(I,J)=YM9(I,INDEX3)
17393 5412 CONTINUE
17394 5411 CONTINUE
17395C
17396      DO5416I=1,NC1
17397      DO5417J=1,NC1
17398      YM9(I,J)=YM2(I,J)
17399 5417 CONTINUE
17400 5416 CONTINUE
17401C
17402      IF(IMCASE.EQ.'MAPC')GOTO5430
17403      GOTO5500
17404C
17405 5430 CONTINUE
17406      IF(IMSUBC.EQ.'EVEC')GOTO5440
17407      IF(IMSUBC.EQ.'EVAL')GOTO5450
17408      GOTO5460
17409C
17410 5440 CONTINUE
17411      ITYP9='MATR'
17412      NR9=NC1
17413      NC9=NC1
17414      IUPFLG='FULL'
17415      GOTO9000
17416C
17417 5450 CONTINUE
17418      ITYP9='VECT'
17419      NVECT9=NC1
17420      IUPFLG='FULL'
17421      GOTO9000
17422C
17423 5460 CONTINUE
17424      DO5461I=1,NR1
17425      DO5462J=1,NC1
17426      DSUM=0.0D0
17427      DO5463K=1,NC1
17428      DYM1=YM1(I,K)
17429      DDEL=DYM1-DMEAN(K)
17430      DYM2=YM9(K,J)
17431      DYM9=DDEL*DYM2
17432      DSUM=DSUM+DYM9
17433 5463 CONTINUE
17434      YM2(I,J)=DSUM
17435 5462 CONTINUE
17436 5461 CONTINUE
17437      DO5465I=1,NR1
17438      DO5466J=1,NC1
17439      YM9(I,J)=YM2(I,J)
17440 5466 CONTINUE
17441 5465 CONTINUE
17442      ITYP9='MATR'
17443      NR9=NR1
17444      NC9=NC1
17445      IUPFLG='FULL'
17446      GOTO9000
17447C
17448 5500 CONTINUE
17449      L=1
17450      IF(IMCASE.EQ.'MAP2')L=2
17451      IF(IMCASE.EQ.'MAP3')L=3
17452      IF(IMCASE.EQ.'MAP4')L=4
17453      IF(IMCASE.EQ.'MAP5')L=5
17454      IF(IMCASE.EQ.'MAP6')L=6
17455      IF(IMCASE.EQ.'MAP7')L=7
17456      IF(IMCASE.EQ.'MAP8')L=8
17457      IF(IMCASE.EQ.'MAP9')L=9
17458      IF(IMCASE.EQ.'MA10')L=10
17459C
17460      IF(IMSUBC.EQ.'EVEC')GOTO5530
17461      IF(IMSUBC.EQ.'EVAL')GOTO5540
17462      GOTO5550
17463C
17464 5530 CONTINUE
17465      DO5531I=1,NC1
17466      VECT9(I)=YM9(I,L)
17467 5531 CONTINUE
17468      ITYP9='VECT'
17469      NVECT9=NC1
17470      IUPFLG='FULL'
17471      GOTO9000
17472C
17473 5540 CONTINUE
17474      ITYP9='SCAL'
17475      SCAL9=VECT9(L)
17476      IUPFLG='FULL'
17477      GOTO9000
17478C
17479 5550 CONTINUE
17480      DO5551I=1,NR1
17481      DSUM=0.0D0
17482      DO5553K=1,NC1
17483      DYM1=YM1(I,K)
17484      DDEL=DYM1-DMEAN(K)
17485      DYM2=YM9(K,L)
17486      DYM9=DDEL*DYM2
17487      DSUM=DSUM+DYM9
17488 5553 CONTINUE
17489      VECT9(I)=DSUM
17490 5551 CONTINUE
17491      ITYP9='VECT'
17492      NVECT9=NR1
17493      IUPFLG='FULL'
17494      GOTO9000
17495C
17496C               **************************************************
17497C               **  STEP 54--                                   **
17498C               **  TREAT THE MATRIX TRUNCATION      CASE       **
17499C               **  THIS COMMAND SETS ANY VALUE BELOW THE       **
17500C               **  TRUNCATION VALUE TO THAT TRUNCATION         **
17501C               **  VALUE.  A COMMON USE OF THIS COMMAND        **
17502C               **  MIGHT BE TO REMOVE BACKGROUND (USE          **
17503C               **  MATRIX SUBTRACTION TO REMOVE THE            **
17504C               **  BACKGROUND AND THEN USE MATRIX TRUNCATION   **
17505C               **  TO SET ANY RESULTING NEGATIVE VALUES (I.E., **
17506C               **  POINTS BELOW THE BACKGROUND LEVEL) TO ZERO. **
17507C               **************************************************
17508C
17509 6100 CONTINUE
17510C
17511      IF(ITYPA1.EQ.'MATR'.AND.ITYPA2.EQ.'PARA')GOTO6170
17512      IF(ITYPA1.EQ.'PARA'.AND.ITYPA2.EQ.'MATR')GOTO6180
17513C
17514      WRITE(ICOUT,999)
17515      CALL DPWRST('XXX','BUG ')
17516      WRITE(ICOUT,6101)
17517 6101 FORMAT('***** ERROR IN MATARI--')
17518      CALL DPWRST('XXX','BUG ')
17519      WRITE(ICOUT,6102)
17520 6102 FORMAT('      ILLEGAL ARGUMENT TYPES FOR MATRIX TRUNCATION.')
17521      CALL DPWRST('XXX','BUG ')
17522      WRITE(ICOUT,6103)ITYPA1
17523 6103 FORMAT('            TYPE FOR ARGUMENT 1 = ',A4)
17524      CALL DPWRST('XXX','BUG ')
17525      WRITE(ICOUT,6104)ITYPA2
17526 6104 FORMAT('            TYPE FOR ARGUMENT 2 = ',A4)
17527      CALL DPWRST('XXX','BUG ')
17528      IERROR='YES'
17529      GOTO9000
17530C
17531 6170 CONTINUE
17532      DO6171I=1,NR1
17533      DO6172J=1,NC1
17534        YM9(I,J)=MAX(YM1(I,J),YS2)
17535 6172 CONTINUE
17536 6171 CONTINUE
17537      ITYP9='MATR'
17538      NR9=NR1
17539      NC9=NC1
17540      IUPFLG='SUBS'
17541      GOTO9000
17542C
17543 6180 CONTINUE
17544      DO6181I=1,NR1
17545      DO6182J=1,NC1
17546        YM9(I,J)=MAX(YM2(I,J),YS1)
17547 6182 CONTINUE
17548 6181 CONTINUE
17549      ITYP9='MATR'
17550      NR9=NR1
17551      NC9=NC1
17552      IUPFLG='SUBS'
17553      GOTO9000
17554C
17555C               **************************************************
17556C               **  STEP 55--                                   **
17557C               **  TREAT THE MATRIX UPPER TRUNCATION   CASE    **
17558C               **  THIS COMMAND SETS ANY VALUE ABOVE THE       **
17559C               **  TRUNCATION VALUE TO THAT TRUNCATION         **
17560C               **  VALUE.                                      **
17561C               **************************************************
17562C
17563 6200 CONTINUE
17564C
17565      IF(ITYPA1.EQ.'MATR'.AND.ITYPA2.EQ.'PARA')GOTO6270
17566      IF(ITYPA1.EQ.'PARA'.AND.ITYPA2.EQ.'MATR')GOTO6280
17567C
17568      WRITE(ICOUT,999)
17569      CALL DPWRST('XXX','BUG ')
17570      WRITE(ICOUT,6201)
17571 6201 FORMAT('***** ERROR IN MATARI--')
17572      CALL DPWRST('XXX','BUG ')
17573      WRITE(ICOUT,6202)
17574 6202 FORMAT('      ILLEGAL ARGUMENT TYPES FOR MATRIX UPPER ',
17575     1       'TRUNCATION.')
17576      CALL DPWRST('XXX','BUG ')
17577      WRITE(ICOUT,6203)ITYPA1
17578 6203 FORMAT('            TYPE FOR ARGUMENT 1 = ',A4)
17579      CALL DPWRST('XXX','BUG ')
17580      WRITE(ICOUT,6204)ITYPA2
17581 6204 FORMAT('            TYPE FOR ARGUMENT 2 = ',A4)
17582      CALL DPWRST('XXX','BUG ')
17583      IERROR='YES'
17584      GOTO9000
17585C
17586 6270 CONTINUE
17587      DO6271I=1,NR1
17588      DO6272J=1,NC1
17589        YM9(I,J)=MIN(YM1(I,J),YS2)
17590 6272 CONTINUE
17591 6271 CONTINUE
17592      ITYP9='MATR'
17593      NR9=NR1
17594      NC9=NC1
17595      IUPFLG='SUBS'
17596      GOTO9000
17597C
17598 6280 CONTINUE
17599      DO6281I=1,NR1
17600      DO6282J=1,NC1
17601        YM9(I,J)=MIN(YM2(I,J),YS1)
17602 6282 CONTINUE
17603 6281 CONTINUE
17604      ITYP9='MATR'
17605      NR9=NR1
17606      NC9=NC1
17607      IUPFLG='SUBS'
17608      GOTO9000
17609C
17610C               ******************************************************
17611C               **  STEP 63--                                       **
17612C               **  TREAT THE COMOVEMENT CASE                       **
17613C               ******************************************************
17614C
17615 6300 CONTINUE
17616C
17617      IF(ICORDI.EQ.'COLU')THEN
17618        IWRITE='OFF'
17619        DO6351J=1,NC1
17620          DO6361K=1,NC1
17621            DO6355I=1,NR1
17622              Y3(I)=YM1(I,J)
17623              Y4(I)=YM1(I,K)
17624 6355       CONTINUE
17625            IF(ICORTY.EQ.'RANK')THEN
17626              CALL RANKCM(Y3,Y4,NR1,IWRITE,Y1,Y2,VECT9,MAXOBV,RIGHT,
17627     1                    IBUGA3,IERROR)
17628            ELSE
17629              CALL COMOVE(Y3,Y4,NR1,IWRITE,RIGHT,IBUGA3,IERROR)
17630            ENDIF
17631            YM9(J,K)=RIGHT
17632 6361     CONTINUE
17633 6351   CONTINUE
17634        NR9=NC1
17635        NC9=NC1
17636      ELSE
17637        IWRITE='OFF'
17638        DO6321J=1,NR1
17639          DO6331K=1,NR1
17640            DO6325I=1,NC1
17641              Y3(I)=YM1(J,I)
17642              Y4(I)=YM1(K,I)
17643 6325       CONTINUE
17644            IF(ICORTY.EQ.'RANK')THEN
17645              CALL RANKCM(Y3,Y4,NC1,IWRITE,Y1,Y2,VECT9,MAXOBV,RIGHT,
17646     1                    IBUGA3,IERROR)
17647            ELSE
17648              CALL COMOVE(Y3,Y4,NC1,IWRITE,RIGHT,IBUGA3,IERROR)
17649            ENDIF
17650            YM9(J,K)=RIGHT
17651 6331     CONTINUE
17652 6321   CONTINUE
17653        NR9=NR1
17654        NC9=NR1
17655      ENDIF
17656C
17657      ITYP9='MATR'
17658      IUPFLG='FULL'
17659      GOTO9000
17660C
17661C               ******************************************************
17662C               **  STEP 64--                                       **
17663C               **  TREAT THE PARTIAL CORRELATION CASE              **
17664C               ******************************************************
17665C
17666 6400 CONTINUE
17667C
17668CCCCC COMPUTE THE PARTIAL CORRELATION MATRIX.  AS WITH THE REGULAR
17669CCCCC CORRELATION MATRIX, SUPPORT FOR:
17670CCCCC
17671CCCCC   1. EITHER COLUMN (DEFAULT) OR ROW BASED CORRELATIONS
17672CCCCC   2. SUPPORT FOR PEARSON CORRELATION, WINSORIZED CORRELATION,
17673CCCCC      BIWEIGHT MID-CORRELATION, RANK CORRELATION, OR KENDALL TAU
17674CCCCC      CORRELATION.
17675CCCCC
17676CCCCC ALGORITHM IS:
17677CCCCC
17678CCCCC   1. COMPUTE THE STANDARD CORRELATION MATRIX
17679CCCCC   2. INVERT THE CORELATION MATRIX
17680CCCCC   3. R(ij.) = -R(ij)/SQRT(R(ii)*R(jj))
17681CCCCC      WHERE R(IJ) IS THE IJ-TH ELEMENT OF THE INVERTED CORRELATION
17682CCCCC      MATRIX.
17683CCCCC
17684CCCCC   AUTOMATICALLY SET THE DIAGONAL ELEMENTS TO +1.
17685C
17686C       NUMBER OF ROWS (N) MUST BE GREATER THAN NUMBER OF COLUMNS
17687C
17688      IF(ICORDI.EQ.'COLU')THEN
17689        IF(NR1-NC1.LT.1)THEN
17690          WRITE(ICOUT,999)
17691          CALL DPWRST('XXX','BUG ')
17692          WRITE(ICOUT,6423)
17693          CALL DPWRST('XXX','ERRO')
17694          WRITE(ICOUT,6491)
17695 6491     FORMAT('      THE NUMBER OF ROWS IN THE MATRIX MUST BE ',
17696     1           'GREATER THAN THE NUMBER OF COLUMNS.')
17697          CALL DPWRST('XXX','ERRO')
17698          WRITE(ICOUT,6493)NR1
17699 6493     FORMAT('      THE NUMBER OF ROWS     = ',I8)
17700          CALL DPWRST('XXX','ERRO')
17701          WRITE(ICOUT,6495)NC1
17702 6495     FORMAT('      THE NUMBER OF COLUMNS  = ',I8)
17703          CALL DPWRST('XXX','ERRO')
17704          IERROR='YES'
17705          GOTO9000
17706        ENDIF
17707      ELSE
17708        IF(NC1-NR1.LT.1)THEN
17709          WRITE(ICOUT,999)
17710          CALL DPWRST('XXX','BUG ')
17711          WRITE(ICOUT,6423)
17712          CALL DPWRST('XXX','ERRO')
17713          WRITE(ICOUT,6492)
17714 6492     FORMAT('      THE NUMBER OF COLUMNS IN THE MATRIX MUST BE ',
17715     1           'GREATER THAN THE NUMBER OF ROWS.')
17716          CALL DPWRST('XXX','ERRO')
17717          WRITE(ICOUT,6493)NR1
17718          CALL DPWRST('XXX','ERRO')
17719          WRITE(ICOUT,6495)NC1
17720          CALL DPWRST('XXX','ERRO')
17721          IERROR='YES'
17722          GOTO9000
17723        ENDIF
17724      ENDIF
17725C
17726      NTRIM1=-1
17727      NTRIM2=-1
17728      IF(ICORDI.EQ.'COLU')THEN
17729        IWRITE='OFF'
17730        DO6401J=1,NC1
17731          DO6402K=1,NC1
17732            DO6403I=1,NR1
17733              Y3(I)=YM1(I,J)
17734              Y4(I)=YM1(I,K)
17735 6403       CONTINUE
17736            IF(ICORTY.EQ.'RANK')THEN
17737              CALL RANKCR(Y3,Y4,NR1,IRCRTA,IWRITE,Y1,Y2,VECT9,MAXOBV,
17738     1                    RIGHT,STATCD,PVAL,PVALLT,PVALUT,
17739     1                    CUTU90,CUTU95,CTU975,CUTU99,CTU995,CTU999,
17740     1                    CUTL90,CUTL95,CTL975,CUTL99,CTL995,CTL999,
17741     1                    IBUGA3,ISUBRO,IERROR)
17742            ELSEIF(ICORTY.EQ.'WINS')THEN
17743              CALL WINSOR(Y3,NR1,P1,P2,NTRIM1,NTRIM2,IWRITE,
17744     1                    Y1,MAXOBV,Y2,
17745     1                    IBUGA3,ISUBRO,IERROR)
17746              DO6406I=1,NR1
17747                Y3(I)=Y2(I)
17748 6406         CONTINUE
17749              CALL WINSOR(Y4,NR1,P1,P2,NTRIM1,NTRIM2,IWRITE,
17750     1                    Y1,MAXOBV,Y2,
17751     1                    IBUGA3,ISUBRO,IERROR)
17752              DO6407I=1,NR1
17753                Y4(I)=Y2(I)
17754 6407         CONTINUE
17755              CALL CORR(Y3,Y4,NR1,IWRITE,RIGHT,IBUGA3,IERROR)
17756            ELSEIF(ICORTY.EQ.'PBCR')THEN
17757              CALL PBNCOR(Y3,Y4,NR1,IWRITE,Y1,Y2,MAXOBV,RIGHT,BETA,
17758     1                    IBUGA3,IERROR)
17759            ELSEIF(ICOVTY.EQ.'BIWE')THEN
17760              CALL BIWMDV(Y3,NR1,IWRITE,Y1,Y2,MAXOBV,RIGH1,
17761     1                    IBUGA3,IERROR)
17762              CALL BIWMDV(Y4,NR1,IWRITE,Y1,Y2,MAXOBV,RIGH2,
17763     1                    IBUGA3,IERROR)
17764              CALL BIWMCV(Y3,Y4,NR1,IWRITE,Y1,Y2,MAXOBV,RIGH3,
17765     1                    IBUGA3,IERROR)
17766              RIGH4=RIGH1*RIGH2
17767              IF(RIGH4.GT.0.0)THEN
17768                RIGHT=RIGH3/SQRT(RIGH4)
17769              ELSE
17770                RIGHT=0.0
17771              ENDIF
17772            ELSEIF(ICORTY.EQ.'KTAU')THEN
17773              ICASZZ='TWOS'
17774              CALL KENTAU(Y3,Y4,NR1,ICASZZ,IKTATA,IWRITE,Y1,Y2,MAXOBV,
17775     1                    RIGHT,AKTAUA,AKTAUB,AKTAUC,
17776     1                    STATCD,PVAL,PVALLT,PVALUT,
17777     1                    CUTU90,CUTU95,CTU975,CUTU99,CTU995,
17778     1                    CUTL90,CUTL95,CTL975,CUTL99,CTL995,
17779     1                    IBUGA3,ISUBRO,IERROR)
17780            ELSE
17781              CALL CORR(Y3,Y4,NR1,IWRITE,RIGHT,IBUGA3,IERROR)
17782            ENDIF
17783            YM9(J,K)=RIGHT
17784 6402     CONTINUE
17785 6401   CONTINUE
17786        NR9=NC1
17787        NC9=NC1
17788      ELSE
17789        IWRITE='OFF'
17790        DO6411J=1,NR1
17791          DO6412K=1,NR1
17792            DO6413I=1,NC1
17793              Y3(I)=YM1(J,I)
17794              Y4(I)=YM1(K,I)
17795 6413       CONTINUE
17796            IF(ICORTY.EQ.'RANK')THEN
17797              CALL RANKCR(Y3,Y4,NC1,IRCRTA,IWRITE,Y1,Y2,VECT9,MAXOBV,
17798     1                    RIGHT,STATCD,PVAL,PVALLT,PVALUT,
17799     1                    CUTU90,CUTU95,CTU975,CUTU99,CTU995,CTU999,
17800     1                    CUTL90,CUTL95,CTL975,CUTL99,CTL995,CTL999,
17801     1                    IBUGA3,ISUBRO,IERROR)
17802            ELSEIF(ICORTY.EQ.'WINS')THEN
17803              CALL WINSOR(Y3,NC1,P1,P2,NTRIM1,NTRIM2,IWRITE,
17804     1                    Y1,MAXOBV,Y2,
17805     1                    IBUGA3,ISUBRO,IERROR)
17806              DO6414I=1,NC1
17807                Y3(I)=Y2(I)
17808 6414         CONTINUE
17809              CALL WINSOR(Y4,NC1,P1,P2,NTRIM1,NTRIM2,IWRITE,
17810     1                    Y1,MAXOBV,Y2,
17811     1                    IBUGA3,ISUBRO,IERROR)
17812              DO6415I=1,NC1
17813                Y4(I)=Y2(I)
17814 6415         CONTINUE
17815              CALL CORR(Y3,Y4,NC1,IWRITE,RIGHT,IBUGA3,IERROR)
17816            ELSEIF(ICORTY.EQ.'PBCR')THEN
17817              CALL PBNCOR(Y3,Y4,NC1,IWRITE,Y1,Y2,MAXOBV,RIGHT,BETA,
17818     1                    IBUGA3,IERROR)
17819            ELSEIF(ICOVTY.EQ.'BIWE')THEN
17820              CALL BIWMDV(Y3,NC1,IWRITE,Y1,Y2,MAXOBV,RIGH1,
17821     1                    IBUGA3,IERROR)
17822              CALL BIWMDV(Y4,NC1,IWRITE,Y1,Y2,MAXOBV,RIGH2,
17823     1                    IBUGA3,IERROR)
17824              CALL BIWMCV(Y3,Y4,NC1,IWRITE,Y1,Y2,MAXOBV,RIGH3,
17825     1                    IBUGA3,IERROR)
17826              RIGH4=RIGH1*RIGH2
17827              IF(RIGH4.GT.0.0)THEN
17828                RIGHT=RIGH3/SQRT(RIGH4)
17829              ELSE
17830                RIGHT=0.0
17831              ENDIF
17832            ELSEIF(ICORTY.EQ.'KTAU')THEN
17833              ICASZZ='TWOS'
17834              CALL KENTAU(Y3,Y4,NC1,ICASZZ,IKTATA,IWRITE,Y1,Y2,MAXOBV,
17835     1                    RIGHT,AKTAUA,AKTAUB,AKTAUC,
17836     1                    STATCD,PVAL,PVALLT,PVALUT,
17837     1                    CUTU90,CUTU95,CTU975,CUTU99,CTU995,
17838     1                    CUTL90,CUTL95,CTL975,CUTL99,CTL995,
17839     1                    IBUGA3,ISUBRO,IERROR)
17840            ELSE
17841              CALL CORR(Y3,Y4,NC1,IWRITE,RIGHT,IBUGA3,IERROR)
17842            ENDIF
17843            YM9(J,K)=RIGHT
17844 6412     CONTINUE
17845 6411   CONTINUE
17846        NR9=NR1
17847        NC9=NR1
17848      ENDIF
17849C
17850C     NOW INVERT THE CORRELATION MATRIX
17851C
17852      CALL SGECO(YM9,MAXROM,NR9,INDEX,RCOND,Y3)
17853      IF(IFEEDB.EQ.'ON')THEN
17854        WRITE(ICOUT,999)
17855        CALL DPWRST('XXX','BUG ')
17856        WRITE(ICOUT,6421)RCOND
17857        CALL DPWRST('XXX','TEXT ')
17858      ENDIF
17859 6421 FORMAT('THE RECIPROCAL CONDITION NUMBER FOR THE CORRELATION ',
17860     1       'MATRIX = ',G15.7)
17861      EPS=1.0E-20
17862      IF(RCOND.LE.EPS)THEN
17863        WRITE(ICOUT,999)
17864        CALL DPWRST('XXX','BUG ')
17865        WRITE(ICOUT,6423)
17866 6423   FORMAT('***** ERROR IN PARTIAL CORRELATION MATRIX--')
17867        CALL DPWRST('XXX','ERRO')
17868        WRITE(ICOUT,6425)
17869 6425   FORMAT('       THE CORRELATION MATRIX IS SINGULAR.')
17870        CALL DPWRST('XXX','ERRO')
17871        IERROR='YES'
17872      ELSE
17873        IJOB=1
17874        CALL SGEDI(YM9,MAXROM,NR9,INDEX,Y3,Y4,IJOB)
17875C
17876        DO6431J=1,NC9
17877          DO6432I=1,NR9
17878            YM1(I,J)=PSTAMV
17879            IF(I.EQ.J)THEN
17880              YM1(I,J)=1.0
17881            ELSE
17882              DENOM=YM9(I,I)*YM9(J,J)
17883              IF(DENOM.GT.0.0)YM1(I,J)=-YM9(I,J)/SQRT(DENOM)
17884            ENDIF
17885 6432     CONTINUE
17886 6431   CONTINUE
17887C
17888C       SAVE EITHER THE PARTIAL CORRELATION MATRIX, THE CDF
17889C       VALUES, OR THE P-VALUES.
17890C
17891        IF(IMCASE.EQ.'MPCO')THEN
17892          DO6441J=1,NC9
17893            DO6442I=1,NR9
17894              YM9(I,J)=YM1(I,J)
17895 6442       CONTINUE
17896 6441     CONTINUE
17897        ELSEIF(IMCASE.EQ.'MPCC')THEN
17898          IF(ICORDI.EQ.'COLU')THEN
17899            IDF1=1
17900            IDF2=NR1 - NC9
17901          ELSE
17902            IDF1=1
17903            IDF2=NC1 - NR9
17904          ENDIF
17905          DO6451J=1,NC9
17906            DO6452I=1,NR9
17907              YM9(I,J)=YM1(I,J)
17908              IF(I.EQ.J)THEN
17909                YM9(I,J)=0.0
17910              ELSE
17911                ANUM=REAL(NR1 - NC9)*YM1(I,J)**2
17912                DENOM=1.0 - YM1(I,J)**2
17913                CDF=0.0
17914                IF(DENOM.NE.0.0)THEN
17915                  AVAL=ABS(ANUM/DENOM)
17916                  CALL FCDF(AVAL,IDF1,IDF2,CDF)
17917                ENDIF
17918                YM9(I,J)=CDF
17919              ENDIF
17920 6452       CONTINUE
17921 6451     CONTINUE
17922        ELSEIF(IMCASE.EQ.'MPCP')THEN
17923          IF(ICORDI.EQ.'COLU')THEN
17924            IDF1=1
17925            IDF2=NR1 - NC9
17926          ELSE
17927            IDF1=1
17928            IDF2=NC1 - NR9
17929          ENDIF
17930          DO6461J=1,NC9
17931            DO6462I=1,NR9
17932              YM9(I,J)=YM1(I,J)
17933              IF(I.EQ.J)THEN
17934                YM9(I,J)=1.0
17935              ELSE
17936                ANUM=REAL(NR1 - NC9)*YM1(I,J)**2
17937                DENOM=1.0 - YM1(I,J)**2
17938                CDF=0.0
17939                IF(DENOM.NE.0.0)THEN
17940                  AVAL=ABS(ANUM/DENOM)
17941                  CALL FCDF(AVAL,IDF1,IDF2,CDF)
17942                ENDIF
17943                YM9(I,J)=1.0 - CDF
17944              ENDIF
17945 6462       CONTINUE
17946 6461     CONTINUE
17947        ENDIF
17948C
17949      END IF
17950C
17951      ITYP9='MATR'
17952      IUPFLG='FULL'
17953      GOTO9000
17954C               *****************
17955C               **  STEP 90--  **
17956C               **  EXIT.      **
17957C               *****************
17958C
17959 9000 CONTINUE
17960C
17961      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'TARI')GOTO9090
17962C
17963      WRITE(ICOUT,999)
17964      CALL DPWRST('XXX','BUG ')
17965      WRITE(ICOUT,9011)
17966 9011 FORMAT('***** AT THE END       OF MATARI--')
17967      CALL DPWRST('XXX','BUG ')
17968      WRITE(ICOUT,9012)IBUGA3,ISUBRO,IMCASE,ITYPA1,ITYPA2,ITYPA3,ITYPA4
17969 9012 FORMAT('IBUGA3,ISUBRO,IMCASE,ITYPA1,ITYPA2,ITYPA3,ITYPA4 = ',
17970     1A4,2X,A4,2X,A4,2X,A4,2X,A4,2X,A4,2X,A4)
17971      CALL DPWRST('XXX','BUG ')
17972      WRITE(ICOUT,9013)IMCASE,IMSUBC
17973 9013 FORMAT('IMCASE,IMSUBC = ',A4,2X,A4)
17974      CALL DPWRST('XXX','BUG ')
17975      WRITE(ICOUT,9014)NUMVAR,IWRITE
17976 9014 FORMAT('NUMVAR,IWRITE = ',I8,2X,A4)
17977      CALL DPWRST('XXX','BUG ')
17978      WRITE(ICOUT,9015)YS1,YS2,YS3,YS4
17979 9015 FORMAT('YS1,YS2,YS3,YS4 = ',4E15.7)
17980      CALL DPWRST('XXX','BUG ')
17981      WRITE(ICOUT,9016)IERROR
17982 9016 FORMAT('IERROR = ',A4)
17983      CALL DPWRST('XXX','BUG ')
17984      WRITE(ICOUT,9017)IYS2,IYS3,IYS23,NRJ,NCJ
17985 9017 FORMAT('IYS2,IYS3,IYS23,NRJ,NCJ = ',5I8)
17986      CALL DPWRST('XXX','BUG ')
17987C
17988      WRITE(ICOUT,999)
17989      CALL DPWRST('XXX','BUG ')
17990      WRITE(ICOUT,9031)NR1,NC1
17991 9031 FORMAT('NR1,NC1 = ',2I8)
17992      CALL DPWRST('XXX','BUG ')
17993      IF(NR1.LE.0)GOTO9039
17994      IF(NC1.LE.0)GOTO9039
17995      JMAX=NC1
17996      IF(JMAX.GT.10)JMAX=10
17997      DO9032I=1,NR1
17998      WRITE(ICOUT,9033)I,(YM1(I,J),J=1,JMAX)
17999 9033 FORMAT('I,YM1(I,.) = ',I8,10E10.3)
18000      CALL DPWRST('XXX','BUG ')
18001 9032 CONTINUE
18002 9039 CONTINUE
18003C
18004      WRITE(ICOUT,999)
18005      CALL DPWRST('XXX','BUG ')
18006      WRITE(ICOUT,9041)NR2,NC2
18007 9041 FORMAT('NR2,NC2 = ',2I8)
18008      CALL DPWRST('XXX','BUG ')
18009      IF(NR2.LE.0)GOTO9049
18010      IF(NC2.LE.0)GOTO9049
18011      JMAX=NC2
18012      IF(JMAX.GT.10)JMAX=10
18013      DO9042I=1,NR2
18014      WRITE(ICOUT,9043)I,(YM2(I,J),J=1,JMAX)
18015 9043 FORMAT('I,YM2(I,.) = ',I8,10E10.3)
18016      CALL DPWRST('XXX','BUG ')
18017 9042 CONTINUE
18018 9049 CONTINUE
18019C
18020      WRITE(ICOUT,999)
18021      CALL DPWRST('XXX','BUG ')
18022      WRITE(ICOUT,9051)NR9,NC9
18023 9051 FORMAT('NR9,NC9 = ',2I8)
18024      CALL DPWRST('XXX','BUG ')
18025      IF(NR9.LE.0)GOTO9059
18026      IF(NC9.LE.0)GOTO9059
18027      JMAX=NC9
18028      IF(JMAX.GT.10)JMAX=10
18029      DO9055I=1,NR9
18030      WRITE(ICOUT,9056)I,(YM9(I,J),J=1,JMAX)
18031 9056 FORMAT('I,YM9(I,.) = ',I8,10E10.3)
18032      CALL DPWRST('XXX','BUG ')
18033 9055 CONTINUE
18034 9059 CONTINUE
18035C
18036      WRITE(ICOUT,999)
18037      CALL DPWRST('XXX','BUG ')
18038      WRITE(ICOUT,9111)N1
18039 9111 FORMAT('N1 = ',I8)
18040      CALL DPWRST('XXX','BUG ')
18041      IF(N1.LE.0)GOTO9119
18042      DO9112I=1,N1
18043      WRITE(ICOUT,9113)I,Y1(I)
18044 9113 FORMAT('I,Y1(I) = ',I8,E15.7)
18045      CALL DPWRST('XXX','BUG ')
18046 9112 CONTINUE
18047 9119 CONTINUE
18048C
18049      WRITE(ICOUT,999)
18050      CALL DPWRST('XXX','BUG ')
18051      WRITE(ICOUT,9121)N2
18052 9121 FORMAT('N2 = ',I8)
18053      CALL DPWRST('XXX','BUG ')
18054      IF(N2.LE.0)GOTO9129
18055      DO9122I=1,N2
18056      WRITE(ICOUT,9123)I,Y2(I)
18057 9123 FORMAT('I,Y2(I) = ',I8,E15.7)
18058      CALL DPWRST('XXX','BUG ')
18059 9122 CONTINUE
18060 9129 CONTINUE
18061C
18062      WRITE(ICOUT,999)
18063      CALL DPWRST('XXX','BUG ')
18064      WRITE(ICOUT,9131)N3
18065 9131 FORMAT('N3 = ',I8)
18066      CALL DPWRST('XXX','BUG ')
18067      IF(N3.LE.0)GOTO9139
18068      DO9132I=1,N3
18069      WRITE(ICOUT,9133)I,Y3(I)
18070 9133 FORMAT('I,Y3(I) = ',I8,E15.7)
18071      CALL DPWRST('XXX','BUG ')
18072 9132 CONTINUE
18073 9139 CONTINUE
18074C
18075      WRITE(ICOUT,999)
18076      CALL DPWRST('XXX','BUG ')
18077      WRITE(ICOUT,9141)N4
18078 9141 FORMAT('N4 = ',I8)
18079      CALL DPWRST('XXX','BUG ')
18080      IF(N4.LE.0)GOTO9149
18081      DO9142I=1,N4
18082      WRITE(ICOUT,9143)I,Y4(I)
18083 9143 FORMAT('I,Y4(I) = ',I8,E15.7)
18084      CALL DPWRST('XXX','BUG ')
18085 9142 CONTINUE
18086 9149 CONTINUE
18087C
18088      WRITE(ICOUT,999)
18089      CALL DPWRST('XXX','BUG ')
18090      WRITE(ICOUT,9151)ITYP9,SCAL9
18091 9151 FORMAT('ITYP9,SCAL9 = ',A4,2X,E15.7)
18092      CALL DPWRST('XXX','BUG ')
18093C
18094      WRITE(ICOUT,999)
18095      CALL DPWRST('XXX','BUG ')
18096      WRITE(ICOUT,9161)NVECT9
18097 9161 FORMAT('NVECT9 = ',I8)
18098      CALL DPWRST('XXX','BUG ')
18099      IF(NVECT9.LE.0)GOTO9169
18100      DO9162I=1,NVECT9
18101      WRITE(ICOUT,9163)I,VECT9(I)
18102 9163 FORMAT('I,VECT9(I) = ',I8,E15.7)
18103      CALL DPWRST('XXX','BUG ')
18104 9162 CONTINUE
18105 9169 CONTINUE
18106C
18107      WRITE(ICOUT,999)
18108      CALL DPWRST('XXX','BUG ')
18109      WRITE(ICOUT,9171)NR9,NC9
18110 9171 FORMAT('NR9,NC9 = ',2I8)
18111      CALL DPWRST('XXX','BUG ')
18112      IF(NR9.LE.0)GOTO9179
18113      IF(NC9.LE.0)GOTO9179
18114      JMAX=NC9
18115      IF(JMAX.GT.10)JMAX=10
18116      DO9172I=1,NR9
18117      WRITE(ICOUT,9173)I,(YM9(I,J),J=1,JMAX)
18118 9173 FORMAT('I,YM9(I,.) = ',I8,10E10.3)
18119      CALL DPWRST('XXX','BUG ')
18120 9172 CONTINUE
18121 9179 CONTINUE
18122C
18123      IF(IMCASE.NE.'MASS')GOTO9189
18124      WRITE(ICOUT,9181)NR2,NC2
18125 9181 FORMAT('NR2,NC2 = ',2I8)
18126      CALL DPWRST('XXX','BUG ')
18127      IF(NR2.LE.0)GOTO9189
18128      IF(NC2.LE.0)GOTO9189
18129      JMAX=NC2+1
18130      IF(JMAX.GT.10)JMAX=10
18131      NR2P1=NR2+1
18132      DO9182I=1,NR2P1
18133      WRITE(ICOUT,9183)I,(YM2(I,J),J=1,JMAX)
18134 9183 FORMAT('I,YM2(I,.) = ',I8,10E10.3)
18135      CALL DPWRST('XXX','BUG ')
18136 9182 CONTINUE
18137      DO9185I=1,N3
18138      WRITE(ICOUT,9186)ICASE,I,IZROV(I),IPOSV(I)
18139 9186 FORMAT('ICASE,I,IZROV(I),IPOSV(I) = ',4I8)
18140      CALL DPWRST('XXX','BUG ')
18141 9185 CONTINUE
18142      WRITE(ICOUT,9187)NR2,NLTZ,NGTZ,NEQZ
18143 9187 FORMAT('NR2,NLTZ,NGTZ,NEQZ = ',4I8)
18144      CALL DPWRST('XXX','BUG ')
18145 9189 CONTINUE
18146C
18147 9090 CONTINUE
18148C
18149      RETURN
18150      END
18151      SUBROUTINE MATAR2(YM1,NR1,NC1,YM2,NR2,NC2,NR3,NC3,MAXROM,MAXCOM,
18152CCCCC JANUARY 1998.  RECODE TO USE LESS MATRICES.
18153CCCCC SUBROUTINE MATAR2(YM1,NR1,NC1,YM2,NR2,NC2,YM3,NR3,NC3,
18154     1Y1,N1,Y2,N2,Y3,N3,Y4,N4,
18155     1INDEX,
18156     1YS1,YS2,YS3,YS4,
18157     1IMCASE,IUPFLG,IMSUBC,ITYPA1,ITYPA2,ITYPA3,ITYPA4,NUMVAR,IWRITE,
18158     1IBPLSC,PBPLCO,
18159     1YM9,NR9,NC9,VECT9,NVECT9,SCAL9,ITYP9,
18160CCCCC JANUARY 1998.  RECODE TO USE LESS MATRICES.
18161CCCCC1YMJUNK,YMJUN2,
18162     1IBUGA3,ISUBRO,IERROR)
18163C
18164C     PURPOSE--CARRY OUT MATRIX     ARITHMETIC OPERATIONS
18165C              OF THE REAL DATA IN MATRICES YM1 AND YM2.
18166C
18167C     OPERATIONS--ADDITION
18168C                 SUBTRACTION
18169C                 MULTIPLICATION
18170C                 SOLUTION
18171C                 ITERATIVE SOLUTION
18172C                 INVERSE
18173C                 TRANSPOSE
18174C                 ADJOINT
18175C                 CHARACTERISTIC EQUATION      (NOT YET IMPLEMENED)
18176C                 EIGENVALUES
18177C                 EIGENVECTORS
18178C                 RANK
18179C                 DETERMINANT
18180C                 PERMANENT
18181C                 SPECTRAL NORM
18182C                 SPECTRAL RADIUS
18183C                 NUMBER OF ROWS
18184C                 NUMBER OF COLUMNS
18185C                 SIMPLEX SOLUTION
18186C                 TRACE
18187C                 SUBMATRIX
18188C                 MINOR
18189C                 COFACTOR
18190C                 DEFINITION
18191C                 EUCLIDEAN NORM
18192C                 SINGULAR VALUE
18193C                 SINGULAR VALUE DECOMPOSITION
18194C                 SINGULAR VALUE FACTORIZATION
18195C                 ROW
18196C                 ELEMENT
18197C                 REPLACE ROW
18198C                 REPLACE ELEMENT
18199C                 AUGMENT
18200C                 DIAGONAL
18201C                 CHOLESKY DECOMPOSITION
18202C                 TRIDIAGONAL SOLVE
18203C                 TRIANGULAR SOLVE
18204C                 TRIANGULAR INVERSE
18205C
18206C                 VARIANCE-COVARIANCE MATRIX
18207C                 CORRELATION MATRIX
18208C                 PRINCIPLE COMPONENTS ...
18209C                 ... PRINCIPLE COMPONENT ...
18210C                 BIPLOT
18211C
18212C     EXAMPLES--LET M3 = MATRIX ADDITION M1 M2
18213C               LET M3 = MATRIX ADDITION M1 P1
18214C             --LET M3 = MATRIX SUBTRACTION M1 M2
18215C               LET M3 = MATRIX SUBTRACTION M1 P1
18216C             --LET M3 = MATRIX MULTIPLICATION M1 M2
18217C               LET M3 = MATRIX MULTIPLICATION M1 V1
18218C               LET M3 = MATRIX MULTIPLICATION M1 P1
18219C             --LET V3 = MATRIX SOLUTION M1 V2
18220C             --LET M3 = MATRIX INVERSE M1
18221C             --LET A  = MATRIX CONDITION NUMBER M1
18222C             --LET M3 = MATRIX TRANSPOSE M1
18223C             --LET M3 = MATRIX ADJOINT M1
18224C             --LET V3 = MATRIX CHARACTERISTIC EQUATION M1
18225C             --LET V3 = MATRIX EIGENVALUES M1
18226C             --LET P3 = MATRIX EIGENVECTORS M1
18227C             --LET P3 = MATRIX RANK M1
18228C             --LET P3 = MATRIX DETERMINANT M1
18229C             --LET P3 = MATRIX PERMANENT M1
18230C             --LET P3 = MATRIX SPECTRAL NORM M1
18231C             --LET P3 = MATRIX SPECTRAL RADIUS M1
18232C             --LET P3 = MATRIX NUMBER OF ROWS M1
18233C             --LET P3 = MATRIX NUMBER OF COLUMNS M1
18234C             --LET V4 = MATRIX SIMPLEX SOLUTION V1 M1 V2 V3
18235C             --LET P3 = MATRIX TRACE M1
18236C             --LET M3 = MATRIX SUBMATRIX M1 P1 P2
18237C             --LET P3 = MATRIX MINOR M1 P1 P2
18238C             --LET P3 = MATRIX COFACTOR M1 P1 P2
18239C             --LET M3 = MATRIX DEFINITION V1 P1 P2
18240C             --LET P3 = MATRIX EUCLIDEAN NORM M1
18241C             --LET V3 = MATRIX ROW M1 P1
18242C             --LET P3 = MATRIX ELEMENT M1 P1 P2
18243C             --LET M3 = MATRIX REPLACE ROW M1 V1 P1
18244C             --LET M3 = MATRIX REPLACE ELEMENT M1 P1 P2
18245C             --LET M3 = MATRIX AUGMENT M1
18246C             --LET V3 = MATRIX DIAGONAL M1
18247C             --LET M3 = DIAGONAL MATRIX V1
18248C             --LET M3 = VARIANCE-COVARIANCE MATRIX M1
18249C             --LET M3 = CORRELATION MATRIX M1
18250C             --LET M3 = PRINCIPLE COMPONENTS M1
18251C             --LET M3 = PRINCIPLE COMPONENTS EIGENVECTORS M1
18252C             --LET V3 = PRINCIPLE COMPONENTS EIGENVALUES M1
18253C             --LET V3 = ... PRINCIPLE COMPONENT M1
18254C             --LET V3 = ... PRINCIPLE COMPONENT EIGENVECTOR M1
18255C             --LET P3 = ... PRINCIPLE COMPONENT EIGENVALUE M1
18256C             --LET V3 = MATRIX SINGULAR VALUES M1
18257C             --LET M3 V3 M2 = MATRIX SINGULAR VALUE DECOMP M1
18258C             --LET M3 V3 M2 = MATRIX SINGULAR VALUE FACTOR M1
18259C             --LET M3 = CHOLESKY DECOMP M1
18260C             --LET V4 = TRIDIAGONAL SOLVE V1 V2 V3
18261C
18262C     INPUT  ARGUMENTS--YM1 (REAL MATRIX)
18263C                     --NR1
18264C                     --NC1
18265C                     --YM2 (REAL MATRIX)
18266C                     --NR2
18267C                     --NC2
18268C                     --YM3 (REAL MATRIX)
18269C                     --NR3
18270C                     --NC3
18271C                     --Y1  (REAL VECTOR)
18272C                     --N1
18273C                     --Y2  (REAL VECTOR)
18274C                     --N2
18275C                     --Y3  (REAL VECTOR)
18276C                     --N3
18277C                     --Y4  (REAL VECTOR)
18278C                     --N4
18279C     OUTPUT ARGUMENTS--YM9 (REAL MATRIX)
18280C                     --NR9
18281C                     --NC9
18282C                     --VECT9 (REAL VECTOR)
18283C                     --NVECT9
18284C                     --SCAL9 (REAL SCALAR)
18285C                     --ITYP9
18286C
18287C     NOTE--IT IS NOT PERMISSIBLE TO HAVE THE OUTPUT MATRIX YM9(.)
18288C           BEING IDENTICAL TO THE INPUT MATRIX YM1(.), YM2(.), OR YM3(.).
18289C     WRITTEN BY--JAMES J. FILLIBEN
18290C                 STATISTICAL ENGINEERING DIVISION
18291C                 INFORMATION TECHNOLOGY LABORATORY
18292C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
18293C                 GAITHERSBURG, MD 20899-8980
18294C                 PHONE--301-975-2855
18295C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
18296C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
18297C     LANGUAGE--ANSI FORTRAN (1977)
18298C     VERSION NUMBER--87/10
18299C     ORIGINAL VERSION--SEPTEMBER 1987.
18300C     UPDATED         --AUGUST    1988  (VARIANCE-COVARIANCE MATRIX)
18301C     UPDATED         --AUGUST    1988  (CORRELATION MATRIX)
18302C     UPDATED         --AUGUST    1988  (PRINCIPLE COMPONENTS)
18303C     UPDATED         --AUGUST    1988  (... PRINCIPLE COMPONENTS)
18304C     UPDATED         --APRIL     1992  DEFINE D999
18305C     UPDATED         --JULY      1993  FOR MATRIX SOLUTION,
18306C                                       DETERMINANT, INVERSE, REPLACE
18307C                                       NUMERICAL RECIPES CODE WITH
18308C                                       LINPACK CODE
18309C     UPDATED         --JULY      1993  EIGENVALUES AND EIGENVECTORS
18310C                                       EXTENDED TO NON-SYMMETRIC CASE
18311C     UPDATED         --JULY      1993  IMPLEMENT RANK, ADJOINT,
18312C                                       SINGULAR VALUES, SINGULAR VALUE
18313C                                       DECOMP.
18314C     UPDATED         --SEPT      1993  ROW, ELEMENT CASES
18315C     UPDATED         --OCT       1993  CHOLESKY DECOMPOSITION, REPLACE
18316C                                       ROW, REPLACE ELEMENT, AUGMENT,
18317C                                       DIAGONAL, ADD ARGUMENT TO
18318C                                       MATRIX DEFINITION, TRIDIAGONAL
18319C                                       SOLVE.
18320C     UPDATED         --JANUARY   1998 RECODE TO MINIMIZE NUMBER OF
18321C                                      MATRICES NEEDED.
18322C     UPDATED         --APRIL     2009 ADD BIPLOT
18323C
18324C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
18325C
18326      CHARACTER*4 IMCASE
18327      CHARACTER*4 IUPFLG
18328      CHARACTER*4 IMSUBC
18329      CHARACTER*4 ITYPA1
18330      CHARACTER*4 ITYPA2
18331      CHARACTER*4 ITYPA3
18332      CHARACTER*4 ITYPA4
18333      CHARACTER*4 IWRITE
18334      CHARACTER*4 ITYP9
18335      CHARACTER*4 IBPLSC
18336      CHARACTER*4 IBUGA3
18337      CHARACTER*4 ISUBRO
18338      CHARACTER*4 IERROR
18339C
18340      CHARACTER*4 ISUBN1
18341      CHARACTER*4 ISUBN2
18342C
18343C-----DOUBLE PRECISION STATEMENTS FOR NON-COMMON VARIABLES-------------------
18344C
18345      DOUBLE PRECISION DNR1
18346      DOUBLE PRECISION DNC1
18347CCCCC THE FOLLOWING LINE WAS ADDED   APRIL 1992
18348      DOUBLE PRECISION D999
18349      DOUBLE PRECISION DSUM1
18350      DOUBLE PRECISION DYM1
18351C
18352C---------------------------------------------------------------------
18353C
18354      INCLUDE 'DPCOPA.INC'
18355C
18356      DIMENSION YM1(MAXROM,MAXCOM)
18357      DIMENSION YM2(MAXROM,MAXCOM)
18358CCCCC JANUARY 1998.  RECODE TO USE LESS MATRICES.
18359CCCCC DIMENSION YM3(MAXROM,MAXCOM)
18360      DIMENSION Y1(*)
18361      DIMENSION Y2(*)
18362      DIMENSION Y3(*)
18363      DIMENSION Y4(*)
18364      DIMENSION YM9(MAXROM,MAXCOM)
18365CCCCC DIMENSION VECT9(MAXROM)
18366      DIMENSION VECT9(*)
18367C
18368CCCCC JANUARY 1998.  RECODE TO USE LESS MATRICES.
18369CCCCC DIMENSION YMJUNK(MAXROM,MAXCOM)
18370CCCCC DIMENSION YMJUN2(MAXROM,MAXCOM)
18371CCCCC DIMENSION INDEX(MAXROM)
18372CCCCC DIMENSION VJUNK(MAXROM)
18373CCCCC DIMENSION VJUNK2(MAXROM)
18374      DIMENSION INDEX(*)
18375CCCCC DIMENSION VJUNK(MAXOBV)
18376CCCCC DIMENSION VJUNK2(MAXOBV)
18377C
18378C---------------------------------------------------------------------
18379C
18380      INCLUDE 'DPCOP2.INC'
18381C
18382C-----START POINT-----------------------------------------------------
18383C
18384      ISUBN1='MATA'
18385      ISUBN2='R2  '
18386      IERROR='NO'
18387C
18388      IYS1=(-999)
18389      IYS2=(-999)
18390      IYS3=(-999)
18391      IYS23=(-999)
18392C
18393      NRJ=(-999)
18394      NCJ=(-999)
18395C
18396CCCCC THE FOLLOWING LINE WAS ADDED   APRIL 1992
18397      D999=(-999.0D0)
18398C
18399      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'TAR2')GOTO190
18400C
18401      WRITE(ICOUT,999)
18402  999 FORMAT(1X)
18403      CALL DPWRST('XXX','BUG ')
18404      WRITE(ICOUT,51)
18405   51 FORMAT('***** AT THE BEGINNING OF MATAR2--')
18406      CALL DPWRST('XXX','BUG ')
18407      WRITE(ICOUT,52)IBUGA3,ISUBRO,ITYPA1,ITYPA2,ITYPA3,ITYPA4
18408   52 FORMAT('IBUGA3,ISUBRO,ITYPA1,ITYPA2,ITYPA3,ITYPA4 = ',
18409     1A4,2X,A4,2X,A4,2X,A4,2X,A4,2X,A4)
18410      CALL DPWRST('XXX','BUG ')
18411      WRITE(ICOUT,53)IMCASE,IMSUBC
18412   53 FORMAT('IMCASE,IMSUBC = ',A4,2X,A4)
18413      CALL DPWRST('XXX','BUG ')
18414      WRITE(ICOUT,54)NUMVAR,IWRITE
18415   54 FORMAT('NUMVAR,IWRITE = ',I8,2X,A4)
18416      CALL DPWRST('XXX','BUG ')
18417      WRITE(ICOUT,55)YS1,YS2,YS3,YS4
18418   55 FORMAT('YS1,YS2,YS3,YS4 = ',4E15.7)
18419      CALL DPWRST('XXX','BUG ')
18420C
18421      WRITE(ICOUT,999)
18422      CALL DPWRST('XXX','BUG ')
18423      WRITE(ICOUT,61)NR1,NC1
18424   61 FORMAT('NR1,NC1 = ',2I8)
18425      CALL DPWRST('XXX','BUG ')
18426      IF(NR1.LE.0)GOTO69
18427      IF(NC1.LE.0)GOTO69
18428      JMAX=NC1
18429      IF(JMAX.GT.10)JMAX=10
18430      DO62I=1,NR1
18431      WRITE(ICOUT,63)I,(YM1(I,J),J=1,JMAX)
18432   63 FORMAT('I,YM1(I,.) = ',I8,10E10.3)
18433      CALL DPWRST('XXX','BUG ')
18434   62 CONTINUE
18435   69 CONTINUE
18436C
18437      WRITE(ICOUT,999)
18438      CALL DPWRST('XXX','BUG ')
18439      WRITE(ICOUT,71)NR2,NC2
18440   71 FORMAT('NR2,NC2 = ',2I8)
18441      CALL DPWRST('XXX','BUG ')
18442      IF(NR2.LE.0)GOTO79
18443      IF(NC2.LE.0)GOTO79
18444      JMAX=NC2
18445      IF(JMAX.GT.10)JMAX=10
18446      DO72I=1,NR2
18447      WRITE(ICOUT,73)I,(YM2(I,J),J=1,JMAX)
18448   73 FORMAT('I,YM2(I,.) = ',I8,10E10.3)
18449      CALL DPWRST('XXX','BUG ')
18450   72 CONTINUE
18451   79 CONTINUE
18452C
18453      WRITE(ICOUT,999)
18454      CALL DPWRST('XXX','BUG ')
18455      WRITE(ICOUT,81)NR3,NC3
18456   81 FORMAT('NR3,NC3 = ',2I8)
18457      CALL DPWRST('XXX','BUG ')
18458      IF(NR3.LE.0)GOTO89
18459      IF(NC3.LE.0)GOTO89
18460      JMAX=NC3
18461      IF(JMAX.GT.10)JMAX=10
18462      DO82I=1,NR3
18463      WRITE(ICOUT,83)I,(YM9(I,J),J=1,JMAX)
18464   83 FORMAT('I,YM9(I,.) = ',I8,10E10.3)
18465      CALL DPWRST('XXX','BUG ')
18466   82 CONTINUE
18467   89 CONTINUE
18468C
18469      WRITE(ICOUT,999)
18470      CALL DPWRST('XXX','BUG ')
18471      WRITE(ICOUT,111)N1
18472  111 FORMAT('N1 = ',I8)
18473      CALL DPWRST('XXX','BUG ')
18474      IF(N1.LE.0)GOTO119
18475      DO112I=1,N1
18476      WRITE(ICOUT,113)I,Y1(I)
18477  113 FORMAT('I,Y1(I) = ',I8,E15.7)
18478      CALL DPWRST('XXX','BUG ')
18479  112 CONTINUE
18480  119 CONTINUE
18481C
18482      WRITE(ICOUT,999)
18483      CALL DPWRST('XXX','BUG ')
18484      WRITE(ICOUT,121)N2
18485  121 FORMAT('N2 = ',I8)
18486      CALL DPWRST('XXX','BUG ')
18487      IF(N2.LE.0)GOTO129
18488      DO122I=1,N2
18489      WRITE(ICOUT,123)I,Y2(I)
18490  123 FORMAT('I,Y2(I) = ',I8,E15.7)
18491      CALL DPWRST('XXX','BUG ')
18492  122 CONTINUE
18493  129 CONTINUE
18494C
18495      WRITE(ICOUT,999)
18496      CALL DPWRST('XXX','BUG ')
18497      WRITE(ICOUT,131)N3
18498  131 FORMAT('N3 = ',I8)
18499      CALL DPWRST('XXX','BUG ')
18500      IF(N3.LE.0)GOTO139
18501      DO132I=1,N3
18502      WRITE(ICOUT,133)I,Y3(I)
18503  133 FORMAT('I,Y3(I) = ',I8,E15.7)
18504      CALL DPWRST('XXX','BUG ')
18505  132 CONTINUE
18506  139 CONTINUE
18507C
18508      WRITE(ICOUT,999)
18509      CALL DPWRST('XXX','BUG ')
18510      WRITE(ICOUT,141)N4
18511  141 FORMAT('N4 = ',I8)
18512      CALL DPWRST('XXX','BUG ')
18513      IF(N4.LE.0)GOTO149
18514      DO142I=1,N4
18515      WRITE(ICOUT,143)I,Y4(I)
18516  143 FORMAT('I,Y4(I) = ',I8,E15.7)
18517      CALL DPWRST('XXX','BUG ')
18518  142 CONTINUE
18519  149 CONTINUE
18520C
18521  190 CONTINUE
18522C
18523C               **************************************************
18524C               **  CARRY OUT MATRIX     ARITHMETIC OPERATIONS  **
18525C               **************************************************
18526C
18527      DNR1=NR1
18528      DNC1=NC1
18529C
18530C               ********************************************
18531C               **  STEP 11--                             **
18532C               **  CHECK NUMBER OF INPUT OBSERVATIONS.   **
18533C               ********************************************
18534C
18535      IF(ITYPA1.EQ.'MATR'.AND.NUMVAR.GE.1.AND.NR1.LE.0)GOTO1100
18536      IF(ITYPA1.EQ.'MATR'.AND.NUMVAR.GE.1.AND.NC1.LE.0)GOTO1100
18537      IF(ITYPA2.EQ.'MATR'.AND.NUMVAR.GE.2.AND.NR2.LE.0)GOTO1100
18538      IF(ITYPA2.EQ.'MATR'.AND.NUMVAR.GE.2.AND.NC2.LE.0)GOTO1100
18539      IF(ITYPA3.EQ.'MATR'.AND.NUMVAR.GE.3.AND.NR3.LE.0)GOTO1100
18540      IF(ITYPA3.EQ.'MATR'.AND.NUMVAR.GE.3.AND.NC3.LE.0)GOTO1100
18541C
18542      IF(ITYPA1.EQ.'VARI'.AND.NUMVAR.GE.1.AND.N1.LE.0)GOTO1100
18543      IF(ITYPA2.EQ.'VARI'.AND.NUMVAR.GE.2.AND.N2.LE.0)GOTO1100
18544      IF(ITYPA3.EQ.'VARI'.AND.NUMVAR.GE.3.AND.N3.LE.0)GOTO1100
18545C
18546      GOTO1190
18547C
18548 1100 CONTINUE
18549      IERROR='YES'
18550      WRITE(ICOUT,999)
18551      CALL DPWRST('XXX','BUG ')
18552      WRITE(ICOUT,1111)
18553 1111 FORMAT('***** ERROR IN MATAR2--')
18554      CALL DPWRST('XXX','BUG ')
18555      WRITE(ICOUT,1112)
18556 1112 FORMAT('      THE INPUT NUMBER OF ROWS AND/OR COLUMNS')
18557      CALL DPWRST('XXX','BUG ')
18558      WRITE(ICOUT,1113)
18559 1113 FORMAT('      IN THE MATRIX AND/OR VECTOR FOR WHICH')
18560      CALL DPWRST('XXX','BUG ')
18561      WRITE(ICOUT,1121)
18562 1121 FORMAT('      THE MATRIX OPERATION IS TO BE COMPUTED')
18563      WRITE(ICOUT,1181)
18564 1181 FORMAT('      MUST BE 1 OR LARGER;')
18565      CALL DPWRST('XXX','BUG ')
18566      WRITE(ICOUT,1182)
18567 1182 FORMAT('      SUCH WAS NOT THE CASE HERE.')
18568      CALL DPWRST('XXX','BUG ')
18569C
18570      IF(ITYPA1.EQ.'MATR'.AND.NUMVAR.GE.1)WRITE(ICOUT,1183)NR1,NC1
18571 1183 FORMAT('            MATRIX 1--',I8,' ROWS BY ',I8,' COLUMNS')
18572      IF(ITYPA1.EQ.'MATR'.AND.NUMVAR.GE.1)CALL DPWRST('XXX','BUG ')
18573      IF(ITYPA2.EQ.'MATR'.AND.NUMVAR.GE.2)WRITE(ICOUT,1184)NR2,NC2
18574 1184 FORMAT('            MATRIX 2--',I8,' ROWS BY ',I8,' COLUMNS')
18575      IF(ITYPA2.EQ.'MATR'.AND.NUMVAR.GE.2)CALL DPWRST('XXX','BUG ')
18576      IF(ITYPA3.EQ.'MATR'.AND.NUMVAR.GE.3)WRITE(ICOUT,1185)NR3,NC3
18577 1185 FORMAT('            MATRIX 3--',I8,' ROWS BY ',I8,' COLUMNS')
18578      IF(ITYPA3.EQ.'MATR'.AND.NUMVAR.GE.3)CALL DPWRST('XXX','BUG ')
18579      IF(ITYPA1.EQ.'VARI'.AND.NUMVAR.GE.1)WRITE(ICOUT,1186)N1
18580 1186 FORMAT('            VECTOR 1--',I8,' ROWS')
18581      IF(ITYPA1.EQ.'VARI'.AND.NUMVAR.GE.1)CALL DPWRST('XXX','BUG ')
18582      IF(ITYPA2.EQ.'VARI'.AND.NUMVAR.GE.2)WRITE(ICOUT,1187)N2
18583 1187 FORMAT('            VECTOR 2--',I8,' ROWS')
18584      IF(ITYPA2.EQ.'VARI'.AND.NUMVAR.GE.2)CALL DPWRST('XXX','BUG ')
18585      IF(ITYPA3.EQ.'VARI'.AND.NUMVAR.GE.3)WRITE(ICOUT,1188)N3
18586 1188 FORMAT('            VECTOR 3--',I8,' ROWS')
18587      IF(ITYPA3.EQ.'VARI'.AND.NUMVAR.GE.3)CALL DPWRST('XXX','BUG ')
18588      GOTO9000
18589C
18590 1190 CONTINUE
18591C
18592C               *********************************
18593C               **  STEP 12--                  **
18594C               **  BRANCH TO THE PROPER CASE  **
18595C               *********************************
18596C
18597CCCCC JULY 1993.  ADD FOLLOWING 3 LINES
18598      IF(IMCASE.EQ.'MASV')GOTO5800
18599      IF(IMCASE.EQ.'MASD')GOTO5900
18600      IF(IMCASE.EQ.'MASF')GOTO6000
18601CCCCC SEPTEMBER 1993.  ADD FOLLOWING 2 LINES
18602      IF(IMCASE.EQ.'MARW')GOTO6100
18603      IF(IMCASE.EQ.'MAEL')GOTO6200
18604CCCCC OCTOBER 1993.  ADD FOLLOWING LINE
18605      IF(IMCASE.EQ.'MACH')GOTO6300
18606      IF(IMCASE.EQ.'MAAU')GOTO6400
18607      IF(IMCASE.EQ.'MADI')GOTO6500
18608      IF(IMCASE.EQ.'DIMA')GOTO6600
18609      IF(IMCASE.EQ.'MARR')GOTO6700
18610      IF(IMCASE.EQ.'MARE')GOTO6800
18611      IF(IMCASE.EQ.'MATD')GOTO6900
18612      IF(IMCASE.EQ.'MATS')GOTO7000
18613      IF(IMCASE.EQ.'MATI')GOTO7100
18614      IF(IMCASE.EQ.'MAIS')GOTO7200
18615      IF(IMCASE.EQ.'BIPL')GOTO7300
18616C
18617      WRITE(ICOUT,999)
18618      CALL DPWRST('XXX','BUG ')
18619      WRITE(ICOUT,1211)
18620 1211 FORMAT('***** INTERNAL ERROR IN MATAR2--')
18621      CALL DPWRST('XXX','BUG ')
18622      WRITE(ICOUT,1212)
18623 1212 FORMAT('      IMCASE NOT EQUAL TO')
18624      CALL DPWRST('XXX','BUG ')
18625      WRITE(ICOUT,1213)
18626 1213 FORMAT('      MASV, MASD, MASF, MARW, ')
18627      CALL DPWRST('XXX','BUG ')
18628      WRITE(ICOUT,1214)
18629 1214 FORMAT('      MAEL, MACH, MAAU, MADI, ')
18630      CALL DPWRST('XXX','BUG ')
18631      WRITE(ICOUT,1215)
18632 1215 FORMAT('      DIMA, MARR, MARE, MATD, ')
18633      CALL DPWRST('XXX','BUG ')
18634      WRITE(ICOUT,1216)
18635 1216 FORMAT('      MATS, MATI, MAIS ')
18636      CALL DPWRST('XXX','BUG ')
18637      WRITE(ICOUT,1228)IMCASE
18638 1228 FORMAT('      IMCASE = ',A4)
18639      CALL DPWRST('XXX','BUG ')
18640      IERROR='YES'
18641      GOTO9000
18642C
18643C               ************************************************
18644C               **  STEP 58--                                 **
18645C               **  TREAT THE MATRIX SINGULAR VALUES CASE     **
18646C               ************************************************
18647C
18648CCCCC IMPLEMENTED JULY 1993.
18649 5800 CONTINUE
18650C
18651      IERR2=0
18652      IJOB=0
18653      CALL SSVDC(YM1,MAXROM,NR1,NC1,VECT9,Y1,YM1,MAXROM,
18654     1YM1,MAXROM,Y2,IJOB,IERR2)
18655C
18656      ITYP9='VECT'
18657      NVECT9=MIN(NR1,NC1)
18658      IUPFLG='FULL'
18659      GOTO9000
18660C
18661C               ************************************************
18662C               **  STEP 59--                                 **
18663C               **  TREAT THE MATRIX SINGULAR VALUES          **
18664C               **  DECOMPOSITION CASE                        **
18665C               ************************************************
18666C
18667CCCCC IMPLEMENTED JULY 1993.
18668 5900 CONTINUE
18669C
18670      IF(NR1.LE.MAXCOM)GOTO5909
18671      WRITE(ICOUT,999)
18672      CALL DPWRST('XXX','BUG ')
18673      WRITE(ICOUT,5901)
18674 5901 FORMAT('***** ERROR IN MATAR2--')
18675      CALL DPWRST('XXX','BUG ')
18676      WRITE(ICOUT,5902)
18677 5902 FORMAT('      FOR MATRIX SINGULAR VALUE DECOMPOSITION,')
18678      CALL DPWRST('XXX','BUG ')
18679      WRITE(ICOUT,5903)
18680 5903 FORMAT('      THE NUMBER OF ROWS IN THE MATRIX')
18681      CALL DPWRST('XXX','BUG ')
18682      WRITE(ICOUT,5904)
18683 5904 FORMAT('      CAN NOT EXCEED ')
18684      CALL DPWRST('XXX','BUG ')
18685      WRITE(ICOUT,5905)
18686 5905 FORMAT('      THE MAXIMUM NUMBER OF COLUMNS IN THE MATRIX;')
18687      CALL DPWRST('XXX','BUG ')
18688      WRITE(ICOUT,5906)
18689 5906 FORMAT('      SUCH WAS NOT THE CASE HERE.')
18690      CALL DPWRST('XXX','BUG ')
18691      WRITE(ICOUT,5907)NR1
18692 5907 FORMAT('            NUMBER OF ROWS    =',I8)
18693      CALL DPWRST('XXX','BUG ')
18694      WRITE(ICOUT,5908)MAXCOM
18695 5908 FORMAT('            MAXIMUM NUMBER OF COLUMNS =',I8)
18696      CALL DPWRST('XXX','BUG ')
18697      IERROR='YES'
18698      GOTO9000
18699C
18700 5909 CONTINUE
18701      DO5922J=1,MAXCOM
18702      DO5921I=1,MAXROM
18703      YM9(I,J)=0.0
18704      YM2(I,J)=0.0
18705 5921 CONTINUE
18706 5922 CONTINUE
18707C
18708      IERR2=0
18709      IJOB=22
18710      NTEMP1=NR1
18711      NTEMP2=NC1
18712      CALL SSVDC(YM1,MAXROM,NTEMP1,NTEMP2,VECT9,Y1,YM9,MAXROM,
18713     1YM2,MAXROM,Y2,IJOB,IERR2)
18714C
18715      ITYP9='MATR'
18716      MM=NR1
18717      IF(MM.GT.NC1)MM=NC1
18718      NR9=NR1
18719      NC9=NR1
18720      NR2=NC1
18721      NC2=NC1
18722      NVECT9=MM
18723      IUPFLG='FULL'
18724      GOTO9000
18725C
18726C               ************************************************
18727C               **  STEP 60--                                 **
18728C               **  TREAT THE MATRIX SINGULAR VALUES          **
18729C               **  FACTORIZATION CASE                        **
18730C               ************************************************
18731C
18732CCCCC IMPLEMENTED JULY 1993.
18733 6000 CONTINUE
18734C
18735      DO6022J=1,MAXCOM
18736      DO6021I=1,MAXROM
18737      YM9(I,J)=0.0
18738      YM2(I,J)=0.0
18739 6021 CONTINUE
18740 6022 CONTINUE
18741C
18742      IERR2=0
18743      IJOB=22
18744      NTEMP1=NR1
18745      NTEMP2=NC1
18746      CALL SSVDC(YM1,MAXROM,NTEMP1,NTEMP2,VECT9,Y1,YM9,MAXROM,
18747     1YM2,MAXROM,Y2,IJOB,IERR2)
18748C
18749      ITYP9='MATR'
18750      MM=NR1
18751      IF(MM.GT.NC1)MM=NC1
18752      NR9=NR1
18753      NC9=NC1
18754      NR2=NC1
18755      NC2=NC1
18756      NVECT9=MM
18757      IUPFLG='FULL'
18758      GOTO9000
18759C
18760C               *****************************************************
18761C               **  STEP 61--                                      **
18762C               **  TREAT THE MATRIX     ROW                 CASE  **
18763C               *****************************************************
18764C
18765 6100 CONTINUE
18766      IROWID=INT(YS2+0.5)
18767      IF(IROWID.LT.1 .OR. IROWID.GT.NR1)THEN
18768        WRITE(ICOUT,999)
18769        CALL DPWRST('XXX','BUG ')
18770        WRITE(ICOUT,6101)
18771        CALL DPWRST('XXX','BUG ')
18772        WRITE(ICOUT,6102)
18773        CALL DPWRST('XXX','BUG ')
18774        WRITE(ICOUT,6103)
18775        WRITE(ICOUT,6104)NR1
18776        CALL DPWRST('XXX','BUG ')
18777        WRITE(ICOUT,6105)IROWID
18778        CALL DPWRST('XXX','BUG ')
18779        IERROR='YES'
18780        GOTO9000
18781      ENDIF
18782 6101 FORMAT('***** ERROR IN MATAR2--')
18783 6102 FORMAT('      FOR MATRIX ROW,')
18784 6103 FORMAT('      THE REQUESTED ROW IN THE MATRIX MUST BE BETWEEN')
18785 6104 FORMAT('      1 AND ',I8,'.  SUCH WAS NOT THE CASE HERE.')
18786 6105 FORMAT('      THE REQUESTED ROW NUMBER = ',I8)
18787C
18788      DO6120J=1,NC1
18789      VECT9(J)=YM1(IROWID,J)
18790 6120 CONTINUE
18791C
18792      ITYP9='VECT'
18793      NVECT9=NC1
18794      IUPFLG='FULL'
18795      GOTO9000
18796C
18797C               *****************************************************
18798C               **  STEP 62--                                      **
18799C               **  TREAT THE MATRIX     ELEMENT             CASE  **
18800C               *****************************************************
18801C
18802 6200 CONTINUE
18803      IROWID=INT(YS2+0.5)
18804      ICOLID=INT(YS3+0.5)
18805      IF(IROWID.LT.1 .OR. IROWID.GT.NR1)THEN
18806        WRITE(ICOUT,999)
18807        CALL DPWRST('XXX','BUG ')
18808        WRITE(ICOUT,6201)
18809        CALL DPWRST('XXX','BUG ')
18810        WRITE(ICOUT,6202)
18811        CALL DPWRST('XXX','BUG ')
18812        WRITE(ICOUT,6203)
18813        WRITE(ICOUT,6204)NR1
18814        CALL DPWRST('XXX','BUG ')
18815        WRITE(ICOUT,6205)IROWID
18816        CALL DPWRST('XXX','BUG ')
18817        IERROR='YES'
18818        GOTO9000
18819      ENDIF
18820 6201 FORMAT('***** ERROR IN MATAR2--')
18821 6202 FORMAT('      FOR MATRIX ELEMENT,')
18822 6203 FORMAT('      THE REQUESTED ROW IN THE MATRIX MUST BE BETWEEN')
18823 6204 FORMAT('      1 AND ',I8,'.  SUCH WAS NOT THE CASE HERE.')
18824 6205 FORMAT('      THE REQUESTED ROW NUMBER = ',I8)
18825C
18826      IF(ICOLID.LT.1 .OR. ICOLID.GT.NC1)THEN
18827        WRITE(ICOUT,999)
18828        CALL DPWRST('XXX','BUG ')
18829        WRITE(ICOUT,6211)
18830        CALL DPWRST('XXX','BUG ')
18831        WRITE(ICOUT,6212)
18832        CALL DPWRST('XXX','BUG ')
18833        WRITE(ICOUT,6213)
18834        WRITE(ICOUT,6214)NC1
18835        CALL DPWRST('XXX','BUG ')
18836        WRITE(ICOUT,6215)ICOLID
18837        CALL DPWRST('XXX','BUG ')
18838        IERROR='YES'
18839        GOTO9000
18840      ENDIF
18841 6211 FORMAT('***** ERROR IN MATAR2--')
18842 6212 FORMAT('      FOR MATRIX ELEMENT,')
18843 6213 FORMAT('      THE REQUESTED COLUMN IN THE MATRIX MUST BE')
18844 6214 FORMAT('      BETWEEN 1 AND ',I8,'.  SUCH WAS NOT THE CASE')
18845 6215 FORMAT('      HERE.  THE REQUESTED COLUMN NUMBER = ',I8)
18846C
18847      ITYP9='SCAL'
18848      SCAL9=YM1(IROWID,ICOLID)
18849      IUPFLG='FULL'
18850      GOTO9000
18851C
18852C               *********************************************
18853C               **  STEP 63--                              **
18854C               **  TREAT THE MATRIX CHOLESKY DECOMP CASE  **
18855C               **  REFERENCE--LINPACK USER'S GUIDE        **
18856C               *********************************************
18857C
18858 6300 CONTINUE
18859C
18860      IF(NR1.EQ.NC1)GOTO6309
18861      WRITE(ICOUT,999)
18862      CALL DPWRST('XXX','BUG ')
18863      WRITE(ICOUT,6301)
18864 6301 FORMAT('***** ERROR IN MATAR2--')
18865      CALL DPWRST('XXX','BUG ')
18866      WRITE(ICOUT,6302)
18867 6302 FORMAT('      FOR MATRIX CHOLESKY DECOMPOSITION,')
18868      CALL DPWRST('XXX','BUG ')
18869      WRITE(ICOUT,6303)
18870 6303 FORMAT('      THE NUMBER OF ROWS IN THE MATRIX')
18871      CALL DPWRST('XXX','BUG ')
18872      WRITE(ICOUT,6304)
18873 6304 FORMAT('      MUST EQUAL')
18874      CALL DPWRST('XXX','BUG ')
18875      WRITE(ICOUT,6305)
18876 6305 FORMAT('      THE NUMBER OF COLUMNS IN THE MATRIX;')
18877      CALL DPWRST('XXX','BUG ')
18878      WRITE(ICOUT,6306)
18879 6306 FORMAT('      SUCH WAS NOT THE CASE HERE.')
18880      CALL DPWRST('XXX','BUG ')
18881      WRITE(ICOUT,6307)NR1
18882 6307 FORMAT('            NUMBER OF ROWS    =',I8)
18883      CALL DPWRST('XXX','BUG ')
18884      WRITE(ICOUT,6308)NC1
18885 6308 FORMAT('            NUMBER OF COLUMNS =',I8)
18886      CALL DPWRST('XXX','BUG ')
18887      IERROR='YES'
18888      GOTO9000
18889 6309 CONTINUE
18890C
18891      CALL SPOCO(YM1,MAXROM,NR1,RCOND,Y1,INFO)
18892C
18893      IF(INFO.NE.0)THEN
18894      WRITE(ICOUT,999)
18895      CALL DPWRST('XXX','BUG ')
18896      WRITE(ICOUT,6351)
18897 6351 FORMAT('***** ERROR IN MATAR2--')
18898      CALL DPWRST('XXX','BUG ')
18899      WRITE(ICOUT,6352)
18900 6352 FORMAT('      FOR MATRIX CHOLESKY DECOMPOSITION,')
18901      CALL DPWRST('XXX','BUG ')
18902      WRITE(ICOUT,6353)
18903 6353 FORMAT('      THE INPUT MATRIX IS NOT SINGULAR.')
18904      CALL DPWRST('XXX','BUG ')
18905      IERROR='YES'
18906      ENDIF
18907C
18908      WRITE(ICOUT,6361)RCOND
18909      CALL DPWRST('XXX','TEXT ')
18910 6361 FORMAT('THE RECIPROCAL CONDITION NUMBER FOR THE MATRIX = ',E15.7)
18911      IF(1.0+RCOND.EQ.1.0)THEN
18912        WRITE(ICOUT,999)
18913        CALL DPWRST('XXX','BUG ')
18914        WRITE(ICOUT,6371)
18915        CALL DPWRST('XXX','ERRO ')
18916        WRITE(ICOUT,6372)
18917        CALL DPWRST('XXX','ERRO ')
18918        IERROR='YES'
18919      END IF
18920 6371 FORMAT('****** ERROR IN MATAR2 ********')
18921 6372 FORMAT('       THE INPUT MATRIX IS SINGULAR')
18922C
18923      DO6380I=1,NR1
18924      DO6382J=I,NR1
18925        YM9(J,I)=0.
18926        YM9(I,J)=YM1(I,J)
18927 6382 CONTINUE
18928 6380 CONTINUE
18929C
18930      ITYP9='MATR'
18931      NVECT9=NR1
18932      NR9=NR1
18933      NC9=NC1
18934      IUPFLG='FULL'
18935      GOTO9000
18936C
18937C
18938C               ******************************************************
18939C               **  STEP 64--                                       **
18940C               **  TREAT THE MATRIX AUGMENT CASE                   **
18941C               ******************************************************
18942C
18943 6400 CONTINUE
18944C
18945      IF(NR1.EQ.NR2)GOTO6409
18946      WRITE(ICOUT,999)
18947      CALL DPWRST('XXX','BUG ')
18948      WRITE(ICOUT,6401)
18949 6401 FORMAT('***** ERROR IN MATAR2--')
18950      CALL DPWRST('XXX','BUG ')
18951      WRITE(ICOUT,6402)
18952 6402 FORMAT('      FOR MATRIX AUGMENT,')
18953      CALL DPWRST('XXX','BUG ')
18954      WRITE(ICOUT,6403)
18955 6403 FORMAT('      THE NUMBER OF ROWS IN THE TWO MATRICES')
18956      CALL DPWRST('XXX','BUG ')
18957      WRITE(ICOUT,6404)
18958 6404 FORMAT('      MUST BE EQUAL.  SUCH WAS NOT THE CASE HERE.')
18959      CALL DPWRST('XXX','BUG ')
18960      WRITE(ICOUT,6407)NR1
18961 6407 FORMAT('            NUMBER OF ROWS FOR MATRIX 1 =',I8)
18962      CALL DPWRST('XXX','BUG ')
18963      WRITE(ICOUT,6408)NR2
18964 6408 FORMAT('            NUMBER OF ROWS FOR MATRIX 2 =',I8)
18965      CALL DPWRST('XXX','BUG ')
18966      IERROR='YES'
18967      GOTO9000
18968 6409 CONTINUE
18969C
18970      IF(NC1+NC2.LE.MAXCOM)GOTO6419
18971      WRITE(ICOUT,999)
18972      CALL DPWRST('XXX','BUG ')
18973      WRITE(ICOUT,6411)
18974 6411 FORMAT('***** ERROR IN MATAR2--')
18975      CALL DPWRST('XXX','BUG ')
18976      WRITE(ICOUT,6412)
18977 6412 FORMAT('      FOR MATRIX AUGMENT,')
18978      CALL DPWRST('XXX','BUG ')
18979      WRITE(ICOUT,6413)
18980 6413 FORMAT('      THE NUMBER OF COLUMNS IN THE NEW MATRIX')
18981      CALL DPWRST('XXX','BUG ')
18982      WRITE(ICOUT,6414)
18983 6414 FORMAT('      WOULD EXCEED THE ALLOWABLE MAXIMUM.')
18984      CALL DPWRST('XXX','BUG ')
18985      WRITE(ICOUT,6417)NC1
18986 6417 FORMAT('            NUMBER OF COLUMNS FOR MATRIX 1 = ',I8)
18987      CALL DPWRST('XXX','BUG ')
18988      WRITE(ICOUT,6418)NC2
18989 6418 FORMAT('            NUMBER OF COLUMNS FOR MATRIX 2 =',I8)
18990      CALL DPWRST('XXX','BUG ')
18991      IERROR='YES'
18992      GOTO9000
18993 6419 CONTINUE
18994C
18995      DO6430J=1,NC1
18996      DO6435I=1,NR1
18997      YM9(I,J)=YM1(I,J)
18998 6435 CONTINUE
18999 6430 CONTINUE
19000C
19001      DO6440J=1,NC2
19002      DO6445I=1,NR2
19003      J2=J+NC1
19004      YM9(I,J2)=YM2(I,J)
19005 6445 CONTINUE
19006 6440 CONTINUE
19007C
19008      ITYP9='MATR'
19009      NR9=NR1
19010      NC9=NC1+NC2
19011      IUPFLG='SUBS'
19012      GOTO9000
19013C
19014C               *****************************************************
19015C               **  STEP 65--                                      **
19016C               **  TREAT THE MATRIX DIAGONAL                CASE  **
19017C               *****************************************************
19018C
19019 6500 CONTINUE
19020      IF(NR1.EQ.NC1)GOTO6509
19021      WRITE(ICOUT,999)
19022      CALL DPWRST('XXX','BUG ')
19023      WRITE(ICOUT,6501)
19024 6501 FORMAT('***** ERROR IN MATAR2--')
19025      CALL DPWRST('XXX','BUG ')
19026      WRITE(ICOUT,6502)
19027 6502 FORMAT('      FOR MATRIX DIAGONAL,')
19028      CALL DPWRST('XXX','BUG ')
19029      WRITE(ICOUT,6503)
19030 6503 FORMAT('      THE NUMBER OF ROWS IN THE MATRIX')
19031      CALL DPWRST('XXX','BUG ')
19032      WRITE(ICOUT,6504)
19033 6504 FORMAT('      MUST EQUAL')
19034      CALL DPWRST('XXX','BUG ')
19035      WRITE(ICOUT,6505)
19036 6505 FORMAT('      THE NUMBER OF COLUMNS IN THE MATRIX;')
19037      CALL DPWRST('XXX','BUG ')
19038      WRITE(ICOUT,6506)
19039 6506 FORMAT('      SUCH WAS NOT THE CASE HERE.')
19040      CALL DPWRST('XXX','BUG ')
19041      WRITE(ICOUT,6507)NR1
19042 6507 FORMAT('            NUMBER OF ROWS    =',I8)
19043      CALL DPWRST('XXX','BUG ')
19044      WRITE(ICOUT,6508)NC1
19045 6508 FORMAT('            NUMBER OF COLUMNS =',I8)
19046      CALL DPWRST('XXX','BUG ')
19047      IERROR='YES'
19048      GOTO9000
19049 6509 CONTINUE
19050C
19051      DO6520I=1,NC1
19052      VECT9(I)=YM1(I,I)
19053 6520 CONTINUE
19054C
19055      ITYP9='VECT'
19056      NVECT9=NC1
19057      IUPFLG='FULL'
19058      GOTO9000
19059C
19060C               *****************************************************
19061C               **  STEP 66--                                      **
19062C               **  TREAT THE DIAGONAL MATRIX                CASE  **
19063C               *****************************************************
19064C
19065 6600 CONTINUE
19066C
19067      IF(N1.LE.MAXCOM)GOTO6609
19068      WRITE(ICOUT,999)
19069      CALL DPWRST('XXX','BUG ')
19070      WRITE(ICOUT,6601)
19071 6601 FORMAT('***** ERROR IN MATAR2--')
19072      CALL DPWRST('XXX','BUG ')
19073      WRITE(ICOUT,6602)
19074 6602 FORMAT('      FOR DIAGONAL MATRIX,')
19075      CALL DPWRST('XXX','BUG ')
19076      WRITE(ICOUT,6603)
19077 6603 FORMAT('      THE NUMBER OF ROWS IN THE VECTOR MUST BE LESS')
19078      CALL DPWRST('XXX','BUG ')
19079      WRITE(ICOUT,6604)
19080 6604 FORMAT('      THAN ',I8)
19081      CALL DPWRST('XXX','BUG ')
19082      WRITE(ICOUT,6606)
19083 6606 FORMAT('      SUCH WAS NOT THE CASE HERE.')
19084      CALL DPWRST('XXX','BUG ')
19085      WRITE(ICOUT,6607)N1
19086 6607 FORMAT('            NUMBER OF ROWS    =',I8)
19087      CALL DPWRST('XXX','BUG ')
19088      IERROR='YES'
19089      GOTO9000
19090C
19091 6609 CONTINUE
19092      DO6610J=1,N1
19093      DO6615I=1,N1
19094      YM9(I,J)=0.0
19095 6615 CONTINUE
19096 6610 CONTINUE
19097      DO6620I=1,N1
19098      YM9(I,I)=Y1(I)
19099 6620 CONTINUE
19100C
19101      ITYP9='MATR'
19102      NR9=N1
19103      NC9=N1
19104      IUPFLG='FULL'
19105      GOTO9000
19106C
19107C               *****************************************************
19108C               **  STEP 67--                                      **
19109C               **  TREAT THE MATRIX REPLACE ROW             CASE  **
19110C               *****************************************************
19111C
19112 6700 CONTINUE
19113      IROWID=INT(YS3+0.5)
19114      IF(IROWID.LT.1 .OR. IROWID.GT.NR1)THEN
19115        WRITE(ICOUT,999)
19116        CALL DPWRST('XXX','BUG ')
19117        WRITE(ICOUT,6701)
19118        CALL DPWRST('XXX','BUG ')
19119        WRITE(ICOUT,6702)
19120        CALL DPWRST('XXX','BUG ')
19121        WRITE(ICOUT,6703)
19122        WRITE(ICOUT,6704)NR1
19123        CALL DPWRST('XXX','BUG ')
19124        WRITE(ICOUT,6705)IROWID
19125        CALL DPWRST('XXX','BUG ')
19126        IERROR='YES'
19127        GOTO9000
19128      ENDIF
19129 6701 FORMAT('***** ERROR IN MATAR2--')
19130 6702 FORMAT('      FOR MATRIX REPLACE ROW,')
19131 6703 FORMAT('      THE REQUESTED ROW IN THE MATRIX MUST BE BETWEEN')
19132 6704 FORMAT('      1 AND ',I8,'.  SUCH WAS NOT THE CASE HERE.')
19133 6705 FORMAT('      THE REQUESTED ROW NUMBER = ',I8)
19134C
19135      IF(N2.NE.NC1)THEN
19136        WRITE(ICOUT,999)
19137        CALL DPWRST('XXX','BUG ')
19138        WRITE(ICOUT,6711)
19139        CALL DPWRST('XXX','BUG ')
19140        WRITE(ICOUT,6712)
19141        CALL DPWRST('XXX','BUG ')
19142        WRITE(ICOUT,6713)
19143        CALL DPWRST('XXX','BUG ')
19144        WRITE(ICOUT,6714)
19145        CALL DPWRST('XXX','BUG ')
19146        WRITE(ICOUT,6715)
19147        CALL DPWRST('XXX','BUG ')
19148        WRITE(ICOUT,6716)NC1
19149        CALL DPWRST('XXX','BUG ')
19150        WRITE(ICOUT,6717)N2
19151        CALL DPWRST('XXX','BUG ')
19152        IERROR='YES'
19153        GOTO9000
19154      ENDIF
19155 6711 FORMAT('***** ERROR IN MATAR2--')
19156 6712 FORMAT('      FOR MATRIX REPLACE ROW,')
19157 6713 FORMAT('      THE NUMBER OF COLUMNS IN THE MATRIX MUST EQUAL')
19158 6714 FORMAT('      THE NUMBER OF COLUMNS IN THE VECTOR.  SUCH WAS')
19159 6715 FORMAT('      NOT THE CASE HERE.')
19160 6716 FORMAT('      THE NUMBER OF COLUMNS IN THE MATRIX = ',I8)
19161 6717 FORMAT('      THE NUMBER OF COLUMNS IN THE VECTOR = ',I8)
19162C
19163      DO6720J=1,NC1
19164      DO6725I=1,NR1
19165      YM9(I,J)=YM1(I,J)
19166 6725 CONTINUE
19167 6720 CONTINUE
19168      DO6730J=1,N2
19169      YM9(IROWID,J)=Y2(J)
19170 6730 CONTINUE
19171C
19172      ITYP9='MATR'
19173      NR9=NR1
19174      NC9=NC1
19175      IUPFLG='SUBS'
19176      GOTO9000
19177C
19178C               *****************************************************
19179C               **  STEP 68--                                      **
19180C               **  TREAT THE MATRIX REPLACE ELEMENT         CASE  **
19181C               *****************************************************
19182C
19183 6800 CONTINUE
19184      IROWID=INT(YS2+0.5)
19185      ICOLID=INT(YS3+0.5)
19186      IF(IROWID.LT.1 .OR. IROWID.GT.NR1)THEN
19187        WRITE(ICOUT,999)
19188        CALL DPWRST('XXX','BUG ')
19189        WRITE(ICOUT,6801)
19190        CALL DPWRST('XXX','BUG ')
19191        WRITE(ICOUT,6802)
19192        CALL DPWRST('XXX','BUG ')
19193        WRITE(ICOUT,6803)
19194        WRITE(ICOUT,6804)NR1
19195        CALL DPWRST('XXX','BUG ')
19196        WRITE(ICOUT,6805)IROWID
19197        CALL DPWRST('XXX','BUG ')
19198        IERROR='YES'
19199        GOTO9000
19200      ENDIF
19201 6801 FORMAT('***** ERROR IN MATAR2--')
19202 6802 FORMAT('      FOR MATRIX REPLACE ELEMENT,')
19203 6803 FORMAT('      THE REQUESTED ROW IN THE MATRIX MUST BE BETWEEN')
19204 6804 FORMAT('      1 AND ',I8,'.  SUCH WAS NOT THE CASE HERE.')
19205 6805 FORMAT('      THE REQUESTED ROW NUMBER = ',I8)
19206C
19207      IF(ICOLID.LT.1 .OR. ICOLID.GT.NC1)THEN
19208        WRITE(ICOUT,999)
19209        CALL DPWRST('XXX','BUG ')
19210        WRITE(ICOUT,6811)
19211        CALL DPWRST('XXX','BUG ')
19212        WRITE(ICOUT,6812)
19213        CALL DPWRST('XXX','BUG ')
19214        WRITE(ICOUT,6813)
19215        WRITE(ICOUT,6814)NC1
19216        CALL DPWRST('XXX','BUG ')
19217        WRITE(ICOUT,6815)ICOLID
19218        CALL DPWRST('XXX','BUG ')
19219        IERROR='YES'
19220        GOTO9000
19221      ENDIF
19222 6811 FORMAT('***** ERROR IN MATAR2--')
19223 6812 FORMAT('      FOR MATRIX REPLACE ELEMENT,')
19224 6813 FORMAT('      THE REQUESTED COLUMN IN THE MATRIX MUST BE')
19225 6814 FORMAT('      BETWEEN 1 AND ',I8,'.  SUCH WAS NOT THE CASE')
19226 6815 FORMAT('      HERE.  THE REQUESTED COLUMN NUMBER = ',I8)
19227C
19228      DO6820J=1,NC1
19229      DO6825I=1,NR1
19230      YM9(I,J)=YM1(I,J)
19231 6825 CONTINUE
19232 6820 CONTINUE
19233      YM9(IROWID,ICOLID)=YS4
19234C
19235      ITYP9='MATR'
19236      NR9=NR1
19237      NC9=NC1
19238      IUPFLG='SUBS'
19239      GOTO9000
19240C
19241C               *********************************************
19242C               **  STEP 69--                              **
19243C               **  TREAT THE TRIDIAGONAL SOLUTION   CASE  **
19244C               **  REFERENCE--LINPACK (CHAPTER 7)         **
19245C               *********************************************
19246C
19247 6900 CONTINUE
19248C
19249      IF((N1.EQ.N2).AND.(N2.EQ.N3).AND.(N3.EQ.N4))GOTO6909
19250      WRITE(ICOUT,999)
19251      CALL DPWRST('XXX','BUG ')
19252      WRITE(ICOUT,6901)
19253 6901 FORMAT('***** ERROR IN MATAR2--')
19254      CALL DPWRST('XXX','BUG ')
19255      WRITE(ICOUT,6902)
19256 6902 FORMAT('      FOR SOLVING A TRIDIAGONAL EQUATION,')
19257      CALL DPWRST('XXX','BUG ')
19258      WRITE(ICOUT,6903)
19259 6903 FORMAT('      THE NUMBER OF ROWS IN THE FOUR INPUT VECTORS')
19260      CALL DPWRST('XXX','BUG ')
19261      WRITE(ICOUT,6904)
19262 6904 FORMAT('      MUST BE EQUAL.  SUCH WAS NOT THE CASE HERE.')
19263      CALL DPWRST('XXX','BUG ')
19264      WRITE(ICOUT,6907)N1,N2,N3,N4
19265 6907 FORMAT('              NUMBER OF ROWS IN THE VECTORS = ',4(I8,1X))
19266      CALL DPWRST('XXX','BUG ')
19267      IERROR='YES'
19268      GOTO9000
19269 6909 CONTINUE
19270C
19271      CALL SGTSL(N1,Y1,Y2,Y3,Y4,INFO)
19272      IF(INFO.EQ.0)GOTO6919
19273      WRITE(ICOUT,999)
19274      CALL DPWRST('XXX','BUG ')
19275      WRITE(ICOUT,6911)
19276 6911 FORMAT('***** ERROR IN MATAR2--')
19277      CALL DPWRST('XXX','BUG ')
19278      WRITE(ICOUT,6912)
19279 6912 FORMAT('      IN SOLVING A TRIDIAGONAL EQUATION,')
19280      CALL DPWRST('XXX','BUG ')
19281      WRITE(ICOUT,6913)
19282 6913 FORMAT('      A ZERO PIVOT ELEMENT WAS DETECTED.')
19283      CALL DPWRST('XXX','BUG ')
19284      IERROR='YES'
19285      GOTO9000
19286 6919 CONTINUE
19287C
19288      DO6920I=1,N1
19289      VECT9(I)=Y4(I)
19290 6920 CONTINUE
19291C
19292      ITYP9='VECT'
19293      NVECT9=N1
19294      IUPFLG='FULL'
19295      GOTO9000
19296C
19297C               *********************************************
19298C               **  STEP 70--                              **
19299C               **  TREAT THE TRIANGULAR SOLVE       CASE  **
19300C               **  REFERENCE--LINPACK (CHAPTER 6)         **
19301C               *********************************************
19302C
19303 7000 CONTINUE
19304C
19305      IF(NR1.EQ.N2)GOTO7009
19306      WRITE(ICOUT,999)
19307      CALL DPWRST('XXX','BUG ')
19308      WRITE(ICOUT,7001)
19309 7001 FORMAT('***** ERROR IN MATAR2--')
19310      CALL DPWRST('XXX','BUG ')
19311      WRITE(ICOUT,7002)
19312 7002 FORMAT('      FOR SOLVING A MATRIX EQUATION SUCH AS A*X = B,')
19313      CALL DPWRST('XXX','BUG ')
19314      WRITE(ICOUT,7003)
19315 7003 FORMAT('      THE NUMBER OF ROWS IN THE LEFT-SIDE MATRIX')
19316      CALL DPWRST('XXX','BUG ')
19317      WRITE(ICOUT,7004)
19318 7004 FORMAT('      MUST EQUAL')
19319      CALL DPWRST('XXX','BUG ')
19320      WRITE(ICOUT,7005)
19321 7005 FORMAT('      THE NUMBER OF ROWS IN THE RIGHT-SIDE VECTOR;')
19322      CALL DPWRST('XXX','BUG ')
19323      WRITE(ICOUT,7006)
19324 7006 FORMAT('      SUCH WAS NOT THE CASE HERE.')
19325      CALL DPWRST('XXX','BUG ')
19326      WRITE(ICOUT,7007)NR1
19327 7007 FORMAT('              NUMBER OF ROWS IN THE MATRIX = ',I8)
19328      CALL DPWRST('XXX','BUG ')
19329      WRITE(ICOUT,7008)N2
19330 7008 FORMAT('              NUMBER OF ROWS IN THE VECTOR = ',I8)
19331      CALL DPWRST('XXX','BUG ')
19332      IERROR='YES'
19333      GOTO9000
19334 7009 CONTINUE
19335C
19336      IJOB=1
19337      DO7046I=1,NR1
19338      DO7047J=I+1,NC1
19339      IF(YM1(I,J).NE.0.0)GOTO7049
19340 7047 CONTINUE
19341 7046 CONTINUE
19342      IJOB=0
19343 7049 CONTINUE
19344C
19345      DO7051I=1,N2
19346      VECT9(I)=Y2(I)
19347 7051 CONTINUE
19348C
19349      CALL STRSL(YM1,MAXROM,NR1,VECT9,IJOB,INFO)
19350      IF(INFO.NE.0)THEN
19351        WRITE(ICOUT,999)
19352        CALL DPWRST('XXX','BUG ')
19353        WRITE(ICOUT,7071)
19354        CALL DPWRST('XXX','ERRO ')
19355        WRITE(ICOUT,7072)
19356        CALL DPWRST('XXX','ERRO ')
19357        IERROR='YES'
19358      END IF
19359 7071 FORMAT('****** ERROR IN MATAR2 ********')
19360 7072 FORMAT('       THE INPUT MATRIX IS SINGULAR')
19361C
19362      ITYP9='VECT'
19363      NVECT9=NR1
19364      IUPFLG='FULL'
19365      GOTO9000
19366C
19367C               *********************************************
19368C               **  STEP 71--                              **
19369C               **  TREAT THE TRIANGULAR INVERSE     CASE  **
19370C               **  REFERENCE--LINPACK (CHAPTER 6)         **
19371C               *********************************************
19372C
19373 7100 CONTINUE
19374C
19375      IF(NR1.EQ.NC1)GOTO7109
19376      WRITE(ICOUT,999)
19377      CALL DPWRST('XXX','BUG ')
19378      WRITE(ICOUT,7101)
19379 7101 FORMAT('***** ERROR IN MATAR2--')
19380      CALL DPWRST('XXX','BUG ')
19381      WRITE(ICOUT,7102)
19382 7102 FORMAT('      FOR TRIANGULAR INVERSE,')
19383      CALL DPWRST('XXX','BUG ')
19384      WRITE(ICOUT,7103)
19385 7103 FORMAT('      THE NUMBER OF ROWS IN THE MATRIX')
19386      CALL DPWRST('XXX','BUG ')
19387      WRITE(ICOUT,7104)
19388 7104 FORMAT('      MUST EQUAL')
19389      CALL DPWRST('XXX','BUG ')
19390      WRITE(ICOUT,7105)
19391 7105 FORMAT('      THE NUMBER OF COLUMNS IN THE MATRIX;')
19392      CALL DPWRST('XXX','BUG ')
19393      WRITE(ICOUT,7106)
19394 7106 FORMAT('      SUCH WAS NOT THE CASE HERE.')
19395      CALL DPWRST('XXX','BUG ')
19396      WRITE(ICOUT,7107)NR1
19397 7107 FORMAT('            NUMBER OF ROWS    =',I8)
19398      CALL DPWRST('XXX','BUG ')
19399      WRITE(ICOUT,7108)NC1
19400 7108 FORMAT('            NUMBER OF COLUMNS =',I8)
19401      CALL DPWRST('XXX','BUG ')
19402      IERROR='YES'
19403      GOTO9000
19404 7109 CONTINUE
19405C
19406      IJOB=11
19407      DO7126I=1,NR1
19408      DO7127J=I+1,NC1
19409      IF(YM1(I,J).NE.0.0)GOTO7129
19410 7127 CONTINUE
19411 7126 CONTINUE
19412      IJOB=10
19413 7129 CONTINUE
19414      CALL STRDI(YM1,MAXROM,NR1,Y1,IJOB,INFO)
19415      IF(INFO.NE.0)THEN
19416        WRITE(ICOUT,999)
19417        CALL DPWRST('XXX','BUG ')
19418        WRITE(ICOUT,7171)
19419        CALL DPWRST('XXX','ERRO')
19420        WRITE(ICOUT,7172)
19421        CALL DPWRST('XXX','ERRO')
19422        IERROR='YES'
19423        GOTO9000
19424      END IF
19425 7171 FORMAT('****** ERROR IN MATAR2 ********')
19426 7172 FORMAT('       THE INPUT MATRIX IS SINGULAR')
19427C
19428      DO7181J=1,NC1
19429      DO7182I=1,NR1
19430      YM9(I,J)=YM1(I,J)
19431 7182 CONTINUE
19432 7181 CONTINUE
19433CCCCC END CHANGE
19434C
19435      ITYP9='MATR'
19436      NR9=NR1
19437      NC9=NC1
19438      IUPFLG='FULL'
19439      GOTO9000
19440C
19441C               *********************************************
19442C               **  STEP 72--                              **
19443C               **  TREAT THE MATRIX ITERATIVE SOLUTION CASE*
19444C               **  REFERENCE--LINPACk (PAGE 1.9)          **
19445C               *********************************************
19446C
19447 7200 CONTINUE
19448C
19449      IF(NR1.EQ.N2)GOTO7209
19450      WRITE(ICOUT,999)
19451      CALL DPWRST('XXX','BUG ')
19452      WRITE(ICOUT,7201)
19453 7201 FORMAT('***** ERROR IN MATARI--')
19454      CALL DPWRST('XXX','BUG ')
19455      WRITE(ICOUT,7202)
19456 7202 FORMAT('      FOR SOLVING A MATRIX EQUATION SUCH AS A*X = B,')
19457      CALL DPWRST('XXX','BUG ')
19458      WRITE(ICOUT,7203)
19459 7203 FORMAT('      THE NUMBER OF ROWS IN THE LEFT-SIDE MATRIX')
19460      CALL DPWRST('XXX','BUG ')
19461      WRITE(ICOUT,7204)
19462 7204 FORMAT('      MUST EQUAL')
19463      CALL DPWRST('XXX','BUG ')
19464      WRITE(ICOUT,7205)
19465 7205 FORMAT('      THE NUMBER OF ROWS IN THE RIGHT-SIDE VECTOR;')
19466      CALL DPWRST('XXX','BUG ')
19467      WRITE(ICOUT,7206)
19468 7206 FORMAT('      SUCH WAS NOT THE CASE HERE.')
19469      CALL DPWRST('XXX','BUG ')
19470      WRITE(ICOUT,7207)NR1
19471 7207 FORMAT('              NUMBER OF ROWS IN THE MATRIX = ',I8)
19472      CALL DPWRST('XXX','BUG ')
19473      WRITE(ICOUT,7208)N2
19474 7208 FORMAT('              NUMBER OF ROWS IN THE VECTOR = ',I8)
19475      CALL DPWRST('XXX','BUG ')
19476      IERROR='YES'
19477      GOTO9000
19478 7209 CONTINUE
19479C
19480      DO7241J=1,NC1
19481      DO7242I=1,NR1
19482      YM2(I,J)=YM1(I,J)
19483 7242 CONTINUE
19484      VECT9(J)=Y2(J)
19485 7241 CONTINUE
19486C
19487      CALL SGEFA(YM2,MAXROM,NR1,INDEX,INFO)
19488      IF(INFO.NE.0)THEN
19489        WRITE(ICOUT,999)
19490        CALL DPWRST('XXX','BUG ')
19491        WRITE(ICOUT,7271)
19492        CALL DPWRST('XXX','ERRO ')
19493        WRITE(ICOUT,7272)
19494        CALL DPWRST('XXX','ERRO ')
19495        IERROR='YES'
19496        GOTO9000
19497      END IF
19498 7271 FORMAT('****** ERROR IN MATAR2 ********')
19499 7272 FORMAT('       THE INPUT MATRIX IS SINGULAR')
19500C
19501      IJOB=0
19502      CALL SGESL(YM2,MAXROM,NR1,INDEX,VECT9,IJOB)
19503      XNORM=SASUM(NR1,VECT9,1)
19504      RELERR=0.0
19505      IF(XNORM.EQ.0.0)GOTO7295
19506      DO7280ITER=1,20
19507        DO7285I=1,NR1
19508          Y3(I)=SDSDOT(NR1,YM1(I,1),MAXROM,VECT9(1),1,-Y2(I))
19509 7285   CONTINUE
19510        CALL SGESL(YM2,MAXROM,NR1,INDEX,Y3,IJOB)
19511        DO7290I=1,NR1
19512          VECT9(I)=VECT9(I)-Y3(I)
19513 7290   CONTINUE
19514        RNORM=SASUM(NR1,Y3,1)
19515        IF(ITER.EQ.1)RELERR=RNORM/XNORM
19516        YS1=XNORM+RNORM
19517        IF(YS1.EQ.XNORM)GOTO7295
19518 7280 CONTINUE
19519      IERROR='YES'
19520      WRITE(ICOUT,999)
19521      CALL DPWRST('XXX','BUG ')
19522      WRITE(ICOUT,7281)
19523      CALL DPWRST('XXX','ERRO ')
19524      WRITE(ICOUT,7282)
19525      CALL DPWRST('XXX','ERRO ')
19526      GOTO9000
19527 7281 FORMAT('****** ERROR IN MATARI ********')
19528 7282 FORMAT('       SOLUTION FAILED TO CONVERGE.')
19529C
19530 7295 CONTINUE
19531      ITYP9='VECT'
19532      NVECT9=NR1
19533      IF(IFEEDB.EQ.'OFF')GOTO7299
19534      WRITE(ICOUT,999)
19535      CALL DPWRST('XXX','BUG ')
19536      WRITE(ICOUT,7296)RCOND
19537      CALL DPWRST('XXX','TEXT ')
19538 7296 FORMAT('THE RELATIVE ERROR = ',E15.7)
19539 7299 CONTINUE
19540      IUPFLG='FULL'
19541      GOTO9000
19542C
19543C               ************************************************
19544C               **  STEP 73--                                 **
19545C               **  TREAT THE BIPLOT CASE                     **
19546C               ************************************************
19547C
19548CCCCC IMPLEMENTED JULY 1993.
19549 7300 CONTINUE
19550C
19551      DO7322J=1,MAXCOM
19552      DO7321I=1,MAXROM
19553        YM9(I,J)=0.0
19554        YM2(I,J)=0.0
19555 7321 CONTINUE
19556 7322 CONTINUE
19557C
19558C     STEP 1: SCALE MATRIX (BASED ON IBPLSC)
19559C
19560C             1) GMEA  - SUBTRACT GRAND MEAN (DEFAULT)
19561C             2) CMEA  - SUBTRACT COLUMN MEAN
19562C             3) NONE  - NO SCALING
19563C
19564      IF(IBPLSC.EQ.'CMEA')THEN
19565        DO7330J=1,NC1
19566          DSUM1=0.0D0
19567          DO7335I=1,NR1
19568            DSUM1=DSUM1 + DBLE(YM1(I,J))
19569 7335     CONTINUE
19570          AMEAN=REAL(DSUM1/DBLE(NR1))
19571          DO7338I=1,NR1
19572            YM1(I,J)=YM1(I,J) - AMEAN
19573 7338     CONTINUE
19574 7330   CONTINUE
19575      ELSEIF(IBPLSC.EQ.'GMEA')THEN
19576        DSUM1=0.0D0
19577        DO7340J=1,NC1
19578          DO7345I=1,NR1
19579            DSUM1=DSUM1 + DBLE(YM1(I,J))
19580 7345     CONTINUE
19581 7340   CONTINUE
19582        AMEAN=REAL(DSUM1/DBLE(NR1*NC1))
19583        DO7349J=1,NC1
19584          DO7348I=1,NR1
19585            YM1(I,J)=YM1(I,J) - AMEAN
19586 7348     CONTINUE
19587 7349   CONTINUE
19588      ENDIF
19589C
19590C     STEP 2: COMPUTE EUCLIDEAN NORM
19591C
19592      DSUM1=0.0D0
19593      DO7361I=1,NR1
19594      DO7362J=1,NC1
19595        DYM1=YM1(I,J)
19596        DSUM1=DSUM1+DYM1*DYM1
19597 7362 CONTINUE
19598 7361 CONTINUE
19599      DYM1=0.0D0
19600      IF(DSUM1.GT.0.0D0)DYM1=DSQRT(DSUM1)
19601      SCAL9=REAL(DYM1)
19602C
19603C     STEP 3: COMPUTE SINGULAR VALUE FACTORIZATION
19604C
19605      IERR2=0
19606      IJOB=22
19607      NTEMP1=NR1
19608      NTEMP2=NC1
19609      CALL SSVDC(YM1,MAXROM,NTEMP1,NTEMP2,VECT9,Y1,YM9,MAXROM,
19610     1YM2,MAXROM,Y2,IJOB,IERR2)
19611C
19612      S1=VECT9(1)
19613      S2=VECT9(2)
19614      AFACT1=S1**PBPLCO
19615      AFACT2=S2**PBPLCO
19616      SCAL9=(S1**2 + S2**2)/SCAL9**2
19617      DO7670I=1,NTEMP1
19618        VECT9(I)=YM9(I,1)*AFACT1
19619        Y2(I)=YM9(I,2)*AFACT2
19620        Y3(I)=1.0
19621 7670 CONTINUE
19622      ICNT=NTEMP1
19623      AFACT1=S1**(1.0-PBPLCO)
19624      AFACT2=S2**(1.0-PBPLCO)
19625      DO7680I=1,NTEMP2
19626        ICNT=ICNT+1
19627        VECT9(ICNT)=YM2(1,I)*AFACT1
19628        Y2(ICNT)=YM2(2,I)*AFACT2
19629        Y3(ICNT)=2.0
19630 7680 CONTINUE
19631C
19632      ITYP9='VECT'
19633      NVECT9=ICNT
19634      IUPFLG='FULL'
19635      GOTO9000
19636C
19637C               *****************
19638C               **  STEP 90--  **
19639C               **  EXIT.      **
19640C               *****************
19641C
19642 9000 CONTINUE
19643C
19644      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'TAR2')GOTO9090
19645C
19646      WRITE(ICOUT,999)
19647      CALL DPWRST('XXX','BUG ')
19648      WRITE(ICOUT,9011)
19649 9011 FORMAT('***** AT THE END       OF MATAR2--')
19650      CALL DPWRST('XXX','BUG ')
19651      WRITE(ICOUT,9012)IBUGA3,ISUBRO,IMCASE,ITYPA1,ITYPA2,ITYPA3,ITYPA4
19652 9012 FORMAT('IBUGA3,ISUBRO,IMCASE,ITYPA1,ITYPA2,ITYPA3,ITYPA4 = ',
19653     1A4,2X,A4,2X,A4,2X,A4,2X,A4,2X,A4,2X,A4)
19654      CALL DPWRST('XXX','BUG ')
19655      WRITE(ICOUT,9013)IMCASE,IMSUBC
19656 9013 FORMAT('IMCASE,IMSUBC = ',A4,2X,A4)
19657      CALL DPWRST('XXX','BUG ')
19658      WRITE(ICOUT,9014)NUMVAR,IWRITE
19659 9014 FORMAT('NUMVAR,IWRITE = ',I8,2X,A4)
19660      CALL DPWRST('XXX','BUG ')
19661      WRITE(ICOUT,9015)YS1,YS2,YS3,YS4
19662 9015 FORMAT('YS1,YS2,YS3,YS4 = ',4E15.7)
19663      CALL DPWRST('XXX','BUG ')
19664      WRITE(ICOUT,9016)IERROR
19665 9016 FORMAT('IERROR = ',A4)
19666      CALL DPWRST('XXX','BUG ')
19667      WRITE(ICOUT,9017)IYS2,IYS3,IYS23,NRJ,NCJ
19668 9017 FORMAT('IYS2,IYS3,IYS23,NRJ,NCJ = ',5I8)
19669      CALL DPWRST('XXX','BUG ')
19670C
19671      WRITE(ICOUT,999)
19672      CALL DPWRST('XXX','BUG ')
19673      WRITE(ICOUT,9031)NR1,NC1
19674 9031 FORMAT('NR1,NC1 = ',2I8)
19675      CALL DPWRST('XXX','BUG ')
19676      IF(NR1.LE.0)GOTO9039
19677      IF(NC1.LE.0)GOTO9039
19678      JMAX=NC1
19679      IF(JMAX.GT.10)JMAX=10
19680      DO9032I=1,NR1
19681      WRITE(ICOUT,9033)I,(YM1(I,J),J=1,JMAX)
19682 9033 FORMAT('I,YM1(I,.) = ',I8,10E10.3)
19683      CALL DPWRST('XXX','BUG ')
19684 9032 CONTINUE
19685 9039 CONTINUE
19686C
19687      WRITE(ICOUT,999)
19688      CALL DPWRST('XXX','BUG ')
19689      WRITE(ICOUT,9041)NR2,NC2
19690 9041 FORMAT('NR2,NC2 = ',2I8)
19691      CALL DPWRST('XXX','BUG ')
19692      IF(NR2.LE.0)GOTO9049
19693      IF(NC2.LE.0)GOTO9049
19694      JMAX=NC2
19695      IF(JMAX.GT.10)JMAX=10
19696      DO9042I=1,NR2
19697      WRITE(ICOUT,9043)I,(YM2(I,J),J=1,JMAX)
19698 9043 FORMAT('I,YM2(I,.) = ',I8,10E10.3)
19699      CALL DPWRST('XXX','BUG ')
19700 9042 CONTINUE
19701 9049 CONTINUE
19702C
19703      WRITE(ICOUT,999)
19704      CALL DPWRST('XXX','BUG ')
19705      WRITE(ICOUT,9051)NR9,NC9
19706 9051 FORMAT('NR9,NC9 = ',2I8)
19707      CALL DPWRST('XXX','BUG ')
19708      IF(NR9.LE.0)GOTO9059
19709      IF(NC9.LE.0)GOTO9059
19710      JMAX=NC9
19711      IF(JMAX.GT.10)JMAX=10
19712      DO9055I=1,NR9
19713      WRITE(ICOUT,9056)I,(YM9(I,J),J=1,JMAX)
19714 9056 FORMAT('I,YM9(I,.) = ',I8,10E10.3)
19715      CALL DPWRST('XXX','BUG ')
19716 9055 CONTINUE
19717 9059 CONTINUE
19718C
19719      WRITE(ICOUT,999)
19720      CALL DPWRST('XXX','BUG ')
19721      WRITE(ICOUT,9111)N1
19722 9111 FORMAT('N1 = ',I8)
19723      CALL DPWRST('XXX','BUG ')
19724      IF(N1.LE.0)GOTO9119
19725      DO9112I=1,N1
19726      WRITE(ICOUT,9113)I,Y1(I)
19727 9113 FORMAT('I,Y1(I) = ',I8,E15.7)
19728      CALL DPWRST('XXX','BUG ')
19729 9112 CONTINUE
19730 9119 CONTINUE
19731C
19732      WRITE(ICOUT,999)
19733      CALL DPWRST('XXX','BUG ')
19734      WRITE(ICOUT,9121)N2
19735 9121 FORMAT('N2 = ',I8)
19736      CALL DPWRST('XXX','BUG ')
19737      IF(N2.LE.0)GOTO9129
19738      DO9122I=1,N2
19739      WRITE(ICOUT,9123)I,Y2(I)
19740 9123 FORMAT('I,Y2(I) = ',I8,E15.7)
19741      CALL DPWRST('XXX','BUG ')
19742 9122 CONTINUE
19743 9129 CONTINUE
19744C
19745      WRITE(ICOUT,999)
19746      CALL DPWRST('XXX','BUG ')
19747      WRITE(ICOUT,9131)N3
19748 9131 FORMAT('N3 = ',I8)
19749      CALL DPWRST('XXX','BUG ')
19750      IF(N3.LE.0)GOTO9139
19751      DO9132I=1,N3
19752      WRITE(ICOUT,9133)I,Y3(I)
19753 9133 FORMAT('I,Y3(I) = ',I8,E15.7)
19754      CALL DPWRST('XXX','BUG ')
19755 9132 CONTINUE
19756 9139 CONTINUE
19757C
19758      WRITE(ICOUT,999)
19759      CALL DPWRST('XXX','BUG ')
19760      WRITE(ICOUT,9141)N4
19761 9141 FORMAT('N4 = ',I8)
19762      CALL DPWRST('XXX','BUG ')
19763      IF(N4.LE.0)GOTO9149
19764      DO9142I=1,N4
19765      WRITE(ICOUT,9143)I,Y4(I)
19766 9143 FORMAT('I,Y4(I) = ',I8,E15.7)
19767      CALL DPWRST('XXX','BUG ')
19768 9142 CONTINUE
19769 9149 CONTINUE
19770C
19771      WRITE(ICOUT,999)
19772      CALL DPWRST('XXX','BUG ')
19773      WRITE(ICOUT,9151)ITYP9,SCAL9
19774 9151 FORMAT('ITYP9,SCAL9 = ',A4,2X,E15.7)
19775      CALL DPWRST('XXX','BUG ')
19776C
19777      WRITE(ICOUT,999)
19778      CALL DPWRST('XXX','BUG ')
19779      WRITE(ICOUT,9161)NVECT9
19780 9161 FORMAT('NVECT9 = ',I8)
19781      CALL DPWRST('XXX','BUG ')
19782      IF(NVECT9.LE.0)GOTO9169
19783      DO9162I=1,NVECT9
19784      WRITE(ICOUT,9163)I,VECT9(I)
19785 9163 FORMAT('I,VECT9(I) = ',I8,E15.7)
19786      CALL DPWRST('XXX','BUG ')
19787 9162 CONTINUE
19788 9169 CONTINUE
19789C
19790      WRITE(ICOUT,999)
19791      CALL DPWRST('XXX','BUG ')
19792      WRITE(ICOUT,9171)NR9,NC9
19793 9171 FORMAT('NR9,NC9 = ',2I8)
19794      CALL DPWRST('XXX','BUG ')
19795      IF(NR9.LE.0)GOTO9179
19796      IF(NC9.LE.0)GOTO9179
19797      JMAX=NC9
19798      IF(JMAX.GT.10)JMAX=10
19799      DO9172I=1,NR9
19800      WRITE(ICOUT,9173)I,(YM9(I,J),J=1,JMAX)
19801 9173 FORMAT('I,YM9(I,.) = ',I8,10E10.3)
19802      CALL DPWRST('XXX','BUG ')
19803 9172 CONTINUE
19804 9179 CONTINUE
19805C
19806      IF(IMCASE.NE.'MASS')GOTO9189
19807      WRITE(ICOUT,9181)NR2,NC2
19808 9181 FORMAT('NR2,NC2 = ',2I8)
19809      CALL DPWRST('XXX','BUG ')
19810      IF(NR2.LE.0)GOTO9189
19811      IF(NC2.LE.0)GOTO9189
19812      JMAX=NC2+1
19813      IF(JMAX.GT.10)JMAX=10
19814      NR2P1=NR2+1
19815      DO9182I=1,NR2P1
19816      WRITE(ICOUT,9183)I,(YM2(I,J),J=1,JMAX)
19817 9183 FORMAT('I,YM2(I,.) = ',I8,10E10.3)
19818      CALL DPWRST('XXX','BUG ')
19819 9182 CONTINUE
19820CCCCC WRITE(ICOUT,9187)NR2,NLTZ,NGTZ,NEQZ
19821C9187 FORMAT('NR2,NLTZ,NGTZ,NEQZ = ',4I8)
19822      WRITE(ICOUT,9187)NR2
19823 9187 FORMAT('NR2 = ',I8)
19824      CALL DPWRST('XXX','BUG ')
19825 9189 CONTINUE
19826C
19827 9090 CONTINUE
19828C
19829      RETURN
19830      END
19831      SUBROUTINE MATAR3(YM1,NR1,NC1,YM2,NR2,NC2,NR3,NC3,
19832     1                  MAXROM,MAXCOM,MAXOBV,
19833     1                  Y1,N1,Y2,N2,Y3,N3,
19834     1                  Y4,N4,Y5,Y6,
19835     1                  INDEX,
19836     1                  DTEMP1,DTEMP2,DTEMP3,
19837     1                  P,ABSE,RELE,AERROR,
19838     1                  YS1,YS2,YS3,YS4,
19839     1                  ASIG90,ASIG95,ASIG99,ASG995,
19840     1                  IMCASE,IUPFLG,IMSUBC,
19841     1                  ITYPA1,ITYPA2,ITYPA3,ITYPA4,NUMVAR,IWRITE,
19842     1                  ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,
19843     1                  ITEMP5,ITEMP6,ITEMP7,
19844     1                  YM9,NR9,NC9,VECT9,NVECT9,SCAL9,ITYP9,
19845     1                  ICASS7,
19846     1                  IRELAT,CLWID,XSTART,XSTOP,
19847     1                  STME,STMEC,ST2T,ST2TC,STC,STT,
19848     1                  IBUGA3,ISUBRO,IERROR)
19849C
19850C     PURPOSE--CARRY OUT MATRIX     ARITHMETIC OPERATIONS
19851C              OF THE REAL DATA IN MATRICES YM1 AND YM2.
19852C              ADD SOME ADDITIONAL FUNCTIONALITY
19853C
19854C     OPERATIONS--QUADRATIC FORM (X'MX)
19855C                 1-SAMPLE HOTELLING T-SQUARE
19856C                 2-SAMPLE HOTELLING T-SQUARE
19857C                 POOLED SAMPLE VARIANCE-COVARIANCE MATRIX
19858C                 MATRIX <ROW/COLUMN> SCALE
19859C                 <ROW/COLUMN> <STATISTIC>
19860C                 PARTITION    <STATISTIC>
19861C                 MATRIX    <STATISTIC>
19862C                 MATRIX  BIN
19863C                 EUCLIDEAN <ROW/COLUMN> DISTANCE
19864C                 CHEBYCHEV <ROW/COLUMN> DISTANCE
19865C                 L1 NORM <ROW/COLUMN> DISTANCE
19866C                 MINKOWSKY <ROW/COLUMN> DISTANCE
19867C                 MAHALANOBIS <ROW/COLUMN> DISTANCE
19868C                 MATRIX MEAN (I.E., GRAND MEAN)
19869C                 MATRIX SUM
19870C                 MATRIX ADD ROW
19871C                 MATRIX DELETE ROW
19872C                 LINEAR COMBINATION
19873C                 VECTOR TIMES TRANSPOSE
19874C                 MATRIX GROUP MEAN
19875C                 MATRIX GROUP STANDARD DEVIATION
19876C                 CATCHER MATRIX
19877C                 MULTIVARIATE NORMAL RANDOM NUMBERS
19878C                 MULTINOMIAL RANDOM NUMBERS
19879C                 MULTINOMIAL PDF
19880C                 XTXINV MATRIX
19881C                 VARIANCE INFLATION FACTORS
19882C                 CONDITION INDICES
19883C                 CREATE MATRIX
19884C                 QR DECOMPOSITION (NOT DONE)
19885C                 PSEUDO INVERSE
19886C                 WISHART RANDOM NUMBERS
19887C                 INDEPENDENT UNIFORM RANDOM NUMBERS
19888C                 CORRELATED UNIFORM RANDOM NUMBERS
19889C                 MULTIVARIATE NORMAL CDF
19890C                 DIRICHLET RANDOM NUMBERS
19891C                 MATRIX BIN
19892C                 MATRIX PARTITION <STAT>
19893C                 MATRIX <STAT>
19894C                 MINIMAL SPANNING TREE
19895C                 MATRIX RENUMBER
19896C                 EDGES TO ADJACENCY MATRIX
19897C                 MATRIX <ROW/COLUMN> FIT
19898C                 VARIABLE TO MATRIX
19899C                 MATRIX TO VARIABLE
19900C                 MATRIX COMBINE ROWS
19901C                 MATRIX COMBINE COLUMNS
19902C                 GENERATE MATRIX <STAT>
19903C                 DEX CORE
19904C                 DEX CONFOUND
19905C                 DEX CHECK CLASSIC
19906C                 DEX CHECK CENTER POINT
19907C
19908C     EXAMPLES--LET A1 = QUADRATIC FORM M X
19909C             --LET A1 = HOTELLING T-SQUARE M U0
19910C             --LET Y1 = MATRIX ROW MEAN M
19911C               LET Y1 = MATRIX COLUMN MEAN M
19912C
19913C     INPUT  ARGUMENTS--YM1 (REAL MATRIX)
19914C                     --NR1
19915C                     --NC1
19916C                     --YM2 (REAL MATRIX)
19917C                     --NR2
19918C                     --NC2
19919C                     --YM3 (REAL MATRIX)
19920C                     --NR3
19921C                     --NC3
19922C                     --Y1  (REAL VECTOR)
19923C                     --N1
19924C                     --Y2  (REAL VECTOR)
19925C                     --N2
19926C                     --Y3  (REAL VECTOR)
19927C                     --N3
19928C                     --Y4  (REAL VECTOR)
19929C                     --N4
19930C     OUTPUT ARGUMENTS--YM9 (REAL MATRIX)
19931C                     --NR9
19932C                     --NC9
19933C                     --VECT9 (REAL VECTOR)
19934C                     --NVECT9
19935C                     --SCAL9 (REAL SCALAR)
19936C                     --ITYP9
19937C
19938C     NOTE--IT IS NOT PERMISSIBLE TO HAVE THE OUTPUT MATRIX YM9(.)
19939C           BEING IDENTICAL TO THE INPUT MATRIX YM1(.), YM2(.), OR YM3(.).
19940C     WRITTEN BY--JAMES J. FILLIBEN
19941C                 STATISTICAL ENGINEERING DIVISION
19942C                 INFORMATION TECHNOLOGY LABORATORY
19943C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
19944C                 GAITHERSBURG, MD 20899-8980
19945C                 PHONE--301-975-2855
19946C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
19947C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
19948C     LANGUAGE--ANSI FORTRAN (1977)
19949C     VERSION NUMBER--98/06
19950C     ORIGINAL VERSION--JUNE      1998.
19951C     UPDATED         --MAY       2002. MULTIVARIATE NORM RAND NUMB
19952C     UPDATED         --MAY       2002. MULTINOMIAL RAND NUMB
19953C     UPDATED         --MAY       2002. WISHART RAND NUMB
19954C     UPDATED         --JUNE      2002. CATCHER MATRIX
19955C     UPDATED         --JUNE      2002. XTXINV MATRIX
19956C     UPDATED         --JUNE      2002. VARIANCE INFLATION FACTORS
19957C     UPDATED         --JUNE      2002. CONDITION NUMBERS
19958C     UPDATED         --JUNE      2002. CREATE MATRIX
19959C     UPDATED         --AUGUST    2002. USE "CMPSTA" TO COMPUTE
19960C                                       STATISTIC FOR
19961C                                       MATRIX <ROW/COLU> <STAT>
19962C     UPDATED         --APRIL     2003. FIX WISHART RANDOM NUMBERS
19963C     UPDATED         --APRIL     2003. MULTIVARIATE T RANDOM NUMBERS
19964C     UPDATED         --APRIL     2003. INDPENDENT UNIFORM RANDOM NUMB
19965C     UPDATED         --APRIL     2003. MULTIVARIATE NORMAL CDF
19966C     UPDATED         --APRIL     2003. MULTIVARIATE T CDF
19967C     UPDATED         --APRIL     2003. ARGUMENT LIST TO CMPSTA
19968C     UPDATED         --SEPTEMBER 2003. CORRELATED UNIFORM RANDOM NUMB
19969C     UPDATED         --JUNE      2005. MATRIX PARTITION <STAT>
19970C     UPDATED         --JUNE      2005. MATRIX <STAT>
19971C     UPDATED         --JULY      2005. MATRIX PARTITION <STAT>
19972C                                       EXTENDED TO UNEQUAL PARTITION
19973C                                       CASE
19974C     UPDATED         --MARCH     2006. MATRIX BIN
19975C     UPDATED         --MAY       2008. MATRIX RENUMBER
19976C     UPDATED         --JUNE      2008. EDGES TO ADJACENCY MATRIX
19977C     UPDATED         --SEPTEMBER 2008. ACTIVATE PSEUDO INVERSE COMMAND
19978C                                       (ACTUALLY RETURNS TRANSPOSE OF
19979C                                       PSEUDO INVERSE)
19980C     UPDATED         --JANUARY   2009. DISTINCTION BETWEEN DIRECTED AND
19981C                                       UNDIRECTED ADJACENCY MATRIX
19982C     UPDATED         --FEBRUARY  2010. MATRIX <ROW/COLUMN> FIT
19983C     UPDATED         --JUNE      2010. CALL LIST TO CMPSTA
19984C     UPDATED         --NOVEMBER  2010. VARIABLE TO MATRIX
19985C     UPDATED         --NOVEMBER  2010. MATRIX TO VARIABLE
19986C     UPDATED         --JANUARY   2011. MATRIX COMBINE ROWS
19987C     UPDATED         --JANUARY   2011. MATRIX COMBINE COLUMNS
19988C     UPDATED         --AUGUST    2017. GENERATE MATRIX <STAT>
19989C     UPDATED         --JANUARY   2018. DEX CORE
19990C     UPDATED         --JANUARY   2018. DEX CONFOUND
19991C     UPDATED         --AUGUST    2018. HAVE ALL DISTANCE MATRIX
19992C                                       (EUCLIDEAN, MINKOWSKY, BLOCK,
19993C                                       CHEBYCHEV) GO THROUGH A SINGLE
19994C                                       ROUTINE
19995C     UPDATED         --AUGUST    2018. ADDED ADDITIONAL DISTANCE
19996C                                       MATRIX OPTIONS
19997C     UPDATED         --SEPTEMBER 2018. DEX CHECK CENTER POINTS
19998C
19999C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
20000C
20001C
20002      CHARACTER*4 IMCASE
20003      CHARACTER*4 ICASS7
20004      CHARACTER*4 IUPFLG
20005      CHARACTER*4 IMSUBC
20006      CHARACTER*4 ITYPA1
20007      CHARACTER*4 ITYPA2
20008      CHARACTER*4 ITYPA3
20009      CHARACTER*4 ITYPA4
20010      CHARACTER*4 IWRITE
20011      CHARACTER*4 ITYP9
20012      CHARACTER*4 IBUGA3
20013      CHARACTER*4 ISUBRO
20014      CHARACTER*4 IERROR
20015C
20016      CHARACTER*4 IRELAT
20017      CHARACTER*4 ICASE
20018      CHARACTER*4 ISUBN1
20019      CHARACTER*4 ISUBN2
20020      CHARACTER*4 ICASE2
20021C
20022CCCCC MAY 2002. ADD FOLLOWING LINE
20023      LOGICAL LTF
20024C
20025C-----DOUBLE PRECISION STATEMENTS FOR NON-COMMON VARIABLES-------------------
20026C
20027      DOUBLE PRECISION DNR1
20028      DOUBLE PRECISION DNC1
20029      DOUBLE PRECISION D999
20030      DOUBLE PRECISION DSUM1
20031      DOUBLE PRECISION DSUM2
20032      DOUBLE PRECISION ABSEPS
20033      DOUBLE PRECISION RELEPS
20034      DOUBLE PRECISION VALS
20035      DOUBLE PRECISION ERRS
20036      DOUBLE PRECISION DN
20037      DOUBLE PRECISION DNORM
20038      DOUBLE PRECISION DLNPDF
20039      DOUBLE PRECISION DLNGAM
20040C
20041C---------------------------------------------------------------------
20042C
20043      DIMENSION YM1(MAXROM,MAXCOM)
20044      DIMENSION YM2(MAXROM,MAXCOM)
20045      DIMENSION Y1(*)
20046      DIMENSION Y2(*)
20047      DIMENSION Y3(*)
20048      DIMENSION Y4(*)
20049      DIMENSION Y5(*)
20050      DIMENSION Y6(*)
20051      DIMENSION YM9(MAXROM,MAXCOM)
20052      DIMENSION VECT9(*)
20053      DOUBLE PRECISION DTEMP1(*)
20054      DOUBLE PRECISION DTEMP2(*)
20055      DOUBLE PRECISION DTEMP3(*)
20056      INTEGER INDEX(*)
20057      INTEGER ITEMP1(*)
20058      INTEGER ITEMP2(*)
20059      INTEGER ITEMP3(*)
20060      INTEGER ITEMP4(*)
20061      INTEGER ITEMP5(*)
20062      INTEGER ITEMP6(*)
20063      INTEGER ITEMP7(*)
20064C
20065      CHARACTER*40 STME(500)
20066      CHARACTER*40 STMEC(500)
20067      CHARACTER*40 ST2T(500)
20068      CHARACTER*40 ST2TC(500)
20069      CHARACTER*40 STC(500)
20070      CHARACTER*40 STT(500)
20071C
20072C-----COMMON----------------------------------------------------------
20073C
20074      INCLUDE 'DPCOST.INC'
20075      INCLUDE 'DPCOP2.INC'
20076C
20077C-----START POINT-----------------------------------------------------
20078C
20079      ISUBN1='MATA'
20080      ISUBN2='R3  '
20081      IERROR='NO'
20082C
20083      IYS1=(-999)
20084      IYS2=(-999)
20085      IYS3=(-999)
20086      IYS23=(-999)
20087      NRJ=(-999)
20088      NCJ=(-999)
20089      D999=(-999.0D0)
20090C
20091      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'ATR3')THEN
20092C
20093        WRITE(ICOUT,999)
20094  999   FORMAT(1X)
20095        CALL DPWRST('XXX','BUG ')
20096        WRITE(ICOUT,51)
20097   51   FORMAT('***** AT THE BEGINNING OF MATAR3--')
20098        CALL DPWRST('XXX','BUG ')
20099        WRITE(ICOUT,52)IBUGA3,ISUBRO,ITYPA1,ITYPA2,ITYPA3,ITYPA4
20100   52   FORMAT('IBUGA3,ISUBRO,ITYPA1,ITYPA2,ITYPA3,ITYPA4 = ',
20101     1         5(A4,2X),A4)
20102        CALL DPWRST('XXX','BUG ')
20103        WRITE(ICOUT,53)IMCASE,IMSUBC,IWRITE,NUMVAR
20104   53   FORMAT('IMCASE,IMSUBC,IWRITE,NUMVAR = ',3(A4,2X),I8)
20105        CALL DPWRST('XXX','BUG ')
20106        WRITE(ICOUT,55)YS1,YS2,YS3,YS4,Y6(1)
20107   55   FORMAT('YS1,YS2,YS3,YS4,Y6(1) = ',5G15.7)
20108        CALL DPWRST('XXX','BUG ')
20109C
20110        WRITE(ICOUT,999)
20111        CALL DPWRST('XXX','BUG ')
20112        WRITE(ICOUT,61)NR1,NC1
20113   61   FORMAT('NR1,NC1 = ',2I8)
20114        CALL DPWRST('XXX','BUG ')
20115        IF(NR1.GE.1 .AND. NC1.GE.1)THEN
20116          JMAX=NC1
20117          IF(JMAX.GT.10)JMAX=10
20118          DO62I=1,NR1
20119            WRITE(ICOUT,63)I,(YM1(I,J),J=1,JMAX)
20120   63       FORMAT('I,YM1(I,.) = ',I8,10E10.3)
20121            CALL DPWRST('XXX','BUG ')
20122   62     CONTINUE
20123        ENDIF
20124C
20125        WRITE(ICOUT,999)
20126        CALL DPWRST('XXX','BUG ')
20127        WRITE(ICOUT,71)NR2,NC2
20128   71   FORMAT('NR2,NC2 = ',2I8)
20129        CALL DPWRST('XXX','BUG ')
20130        IF(NR2.GE.1 .AND. NC2.GE.1)THEN
20131          JMAX=NC2
20132          IF(JMAX.GT.10)JMAX=10
20133          DO72I=1,NR2
20134            WRITE(ICOUT,73)I,(YM2(I,J),J=1,JMAX)
20135   73       FORMAT('I,YM2(I,.) = ',I8,10E10.3)
20136            CALL DPWRST('XXX','BUG ')
20137   72     CONTINUE
20138        ENDIF
20139C
20140        WRITE(ICOUT,999)
20141        CALL DPWRST('XXX','BUG ')
20142        WRITE(ICOUT,81)NR3,NC3
20143   81   FORMAT('NR3,NC3 = ',2I8)
20144        CALL DPWRST('XXX','BUG ')
20145        IF(NR3.GE.1 .AND. NC3.GE.1)THEN
20146          JMAX=NC3
20147          IF(JMAX.GT.10)JMAX=10
20148          DO82I=1,NR3
20149            WRITE(ICOUT,83)I,(YM9(I,J),J=1,JMAX)
20150   83       FORMAT('I,YM9(I,.) = ',I8,10E10.3)
20151            CALL DPWRST('XXX','BUG ')
20152   82     CONTINUE
20153        ENDIF
20154C
20155        WRITE(ICOUT,999)
20156        CALL DPWRST('XXX','BUG ')
20157        WRITE(ICOUT,111)N1
20158  111   FORMAT('N1 = ',I8)
20159        CALL DPWRST('XXX','BUG ')
20160        IF(N1.GE.1)THEN
20161          DO112I=1,N1
20162            WRITE(ICOUT,113)I,Y1(I)
20163  113       FORMAT('I,Y1(I) = ',I8,E15.7)
20164            CALL DPWRST('XXX','BUG ')
20165  112     CONTINUE
20166        ENDIF
20167C
20168        WRITE(ICOUT,999)
20169        CALL DPWRST('XXX','BUG ')
20170        WRITE(ICOUT,121)N2
20171  121   FORMAT('N2 = ',I8)
20172        CALL DPWRST('XXX','BUG ')
20173        IF(N2.GE.1)THEN
20174          DO122I=1,N2
20175            WRITE(ICOUT,123)I,Y2(I)
20176  123       FORMAT('I,Y2(I) = ',I8,E15.7)
20177            CALL DPWRST('XXX','BUG ')
20178  122     CONTINUE
20179        ENDIF
20180C
20181        WRITE(ICOUT,999)
20182        CALL DPWRST('XXX','BUG ')
20183        WRITE(ICOUT,131)N3
20184  131   FORMAT('N3 = ',I8)
20185        CALL DPWRST('XXX','BUG ')
20186        IF(N3.GE.1)THEN
20187          DO132I=1,N3
20188            WRITE(ICOUT,133)I,Y3(I)
20189  133       FORMAT('I,Y3(I) = ',I8,E15.7)
20190            CALL DPWRST('XXX','BUG ')
20191  132     CONTINUE
20192        ENDIF
20193C
20194        WRITE(ICOUT,999)
20195        CALL DPWRST('XXX','BUG ')
20196        WRITE(ICOUT,141)N4
20197  141   FORMAT('N4 = ',I8)
20198        CALL DPWRST('XXX','BUG ')
20199        IF(N4.GE.1)THEN
20200          DO142I=1,N4
20201            WRITE(ICOUT,143)I,Y4(I)
20202  143       FORMAT('I,Y4(I) = ',I8,E15.7)
20203            CALL DPWRST('XXX','BUG ')
20204  142     CONTINUE
20205        ENDIF
20206C
20207      ENDIF
20208C
20209C               **************************************************
20210C               **  CARRY OUT MATRIX     ARITHMETIC OPERATIONS  **
20211C               **************************************************
20212C
20213      DNR1=NR1
20214      DNC1=NC1
20215C
20216C               ********************************************
20217C               **  STEP 11--                             **
20218C               **  CHECK NUMBER OF INPUT OBSERVATIONS.   **
20219C               ********************************************
20220C
20221      IF(IMCASE.EQ.'CRMA')GOTO8500
20222      IF(IMCASE.EQ.'GMST')GOTO8550
20223      IF(IMCASE.EQ.'CORE')GOTO10800
20224      IF(IMCASE.EQ.'CONF')GOTO10900
20225      IF(IMCASE.EQ.'CKCL')GOTO11000
20226      IF(IMCASE.EQ.'CKCP')GOTO11100
20227      IF(ITYPA1.EQ.'MATR'.AND.NUMVAR.GE.1.AND.NR1.LE.0)GOTO1100
20228      IF(ITYPA1.EQ.'MATR'.AND.NUMVAR.GE.1.AND.NC1.LE.0)GOTO1100
20229      IF(ITYPA2.EQ.'MATR'.AND.NUMVAR.GE.2.AND.NR2.LE.0)GOTO1100
20230      IF(ITYPA2.EQ.'MATR'.AND.NUMVAR.GE.2.AND.NC2.LE.0)GOTO1100
20231      IF(ITYPA3.EQ.'MATR'.AND.NUMVAR.GE.3.AND.NR3.LE.0)GOTO1100
20232      IF(ITYPA3.EQ.'MATR'.AND.NUMVAR.GE.3.AND.NC3.LE.0)GOTO1100
20233C
20234      IF(ITYPA1.EQ.'VARI'.AND.NUMVAR.GE.1.AND.N1.LE.0)GOTO1100
20235      IF(ITYPA2.EQ.'VARI'.AND.NUMVAR.GE.2.AND.N2.LE.0)GOTO1100
20236      IF(ITYPA3.EQ.'VARI'.AND.NUMVAR.GE.3.AND.N3.LE.0)GOTO1100
20237C
20238      GOTO1190
20239C
20240 1100 CONTINUE
20241      IERROR='YES'
20242      WRITE(ICOUT,999)
20243      CALL DPWRST('XXX','BUG ')
20244      WRITE(ICOUT,1111)
20245 1111 FORMAT('***** ERROR IN MATAR3--')
20246      CALL DPWRST('XXX','BUG ')
20247      WRITE(ICOUT,1112)
20248 1112 FORMAT('      THE INPUT NUMBER OF ROWS AND/OR COLUMNS IN THE')
20249      CALL DPWRST('XXX','BUG ')
20250      WRITE(ICOUT,1113)
20251 1113 FORMAT('      MATRIX AND/OR VECTOR FOR WHICH THE MATRIX')
20252      CALL DPWRST('XXX','BUG ')
20253      WRITE(ICOUT,1121)
20254 1121 FORMAT('      OPERATION IS TO BE COMPUTED MUST BE 1 OR')
20255      WRITE(ICOUT,1182)
20256 1182 FORMAT('      LARGER;  SUCH WAS NOT THE CASE HERE.')
20257      CALL DPWRST('XXX','BUG ')
20258C
20259      IF(ITYPA1.EQ.'MATR'.AND.NUMVAR.GE.1)THEN
20260        WRITE(ICOUT,1183)NR1,NC1
20261 1183   FORMAT('            MATRIX 1--',I8,' ROWS BY ',I8,' COLUMNS')
20262        CALL DPWRST('XXX','BUG ')
20263      ELSEIF(ITYPA2.EQ.'MATR'.AND.NUMVAR.GE.2)THEN
20264        WRITE(ICOUT,1184)NR2,NC2
20265 1184   FORMAT('            MATRIX 2--',I8,' ROWS BY ',I8,' COLUMNS')
20266        CALL DPWRST('XXX','BUG ')
20267      ELSEIF(ITYPA3.EQ.'MATR'.AND.NUMVAR.GE.3)THEN
20268        WRITE(ICOUT,1185)NR3,NC3
20269 1185   FORMAT('            MATRIX 3--',I8,' ROWS BY ',I8,' COLUMNS')
20270        CALL DPWRST('XXX','BUG ')
20271      ELSEIF(ITYPA1.EQ.'VARI'.AND.NUMVAR.GE.1)THEN
20272        WRITE(ICOUT,1186)N1
20273 1186   FORMAT('            VECTOR 1--',I8,' ROWS')
20274        CALL DPWRST('XXX','BUG ')
20275      ELSEIF(ITYPA2.EQ.'VARI'.AND.NUMVAR.GE.2)THEN
20276        WRITE(ICOUT,1187)N2
20277 1187   FORMAT('            VECTOR 2--',I8,' ROWS')
20278        CALL DPWRST('XXX','BUG ')
20279      ELSEIF(ITYPA3.EQ.'VARI'.AND.NUMVAR.GE.3)THEN
20280        WRITE(ICOUT,1188)N3
20281 1188   FORMAT('            VECTOR 3--',I8,' ROWS')
20282        CALL DPWRST('XXX','BUG ')
20283      ENDIF
20284      GOTO9000
20285C
20286 1190 CONTINUE
20287C
20288C               *********************************
20289C               **  STEP 12--                  **
20290C               **  BRANCH TO THE PROPER CASE  **
20291C               *********************************
20292C
20293      IF(IMCASE.EQ.'MPVC')GOTO5600
20294      IF(IMCASE.EQ.'MQFO')GOTO5800
20295      IF(IMCASE.EQ.'MHT1')GOTO5900
20296      IF(IMCASE.EQ.'MHT2')GOTO5700
20297      IF(IMCASE.EQ.'MROW')GOTO6000
20298      IF(IMCASE.EQ.'MCOL')GOTO6100
20299C
20300      IF(IMCASE.EQ.'MDER')THEN
20301        ICASE='ROW '
20302        GOTO6200
20303      ENDIF
20304      IF(IMCASE.EQ.'MDEC')THEN
20305        ICASE='COLU'
20306        GOTO6200
20307      ENDIF
20308C
20309      IF(IMCASE.EQ.'MDKR')THEN
20310        ICASE='ROW '
20311        GOTO6200
20312      ENDIF
20313      IF(IMCASE.EQ.'MDKC')THEN
20314        ICASE='COLU'
20315        GOTO6200
20316      ENDIF
20317C
20318      IF(IMCASE.EQ.'MDBR')THEN
20319        ICASE='ROW '
20320        GOTO6200
20321      ENDIF
20322      IF(IMCASE.EQ.'MDBC')THEN
20323        ICASE='COLU'
20324        GOTO6200
20325      ENDIF
20326C
20327      IF(IMCASE.EQ.'MDCR')THEN
20328        ICASE='ROW '
20329        GOTO6200
20330      ENDIF
20331      IF(IMCASE.EQ.'MDCC')THEN
20332        ICASE='COLU'
20333        GOTO6200
20334      ENDIF
20335C
20336      IF(IMCASE.EQ.'MCSR')THEN
20337        ICASE='ROW '
20338        GOTO6200
20339      ENDIF
20340      IF(IMCASE.EQ.'MCSC')THEN
20341        ICASE='COLU'
20342        GOTO6200
20343      ENDIF
20344C
20345      IF(IMCASE.EQ.'MCDR')THEN
20346        ICASE='ROW '
20347        GOTO6200
20348      ENDIF
20349      IF(IMCASE.EQ.'MCDC')THEN
20350        ICASE='COLU'
20351        GOTO6200
20352      ENDIF
20353C
20354      IF(IMCASE.EQ.'MZSR')THEN
20355        ICASE='ROW '
20356        GOTO6200
20357      ENDIF
20358      IF(IMCASE.EQ.'MASC')THEN
20359        ICASE='COLU'
20360        GOTO6200
20361      ENDIF
20362C
20363      IF(IMCASE.EQ.'MZDR')THEN
20364        ICASE='ROW '
20365        GOTO6200
20366      ENDIF
20367      IF(IMCASE.EQ.'MADC')THEN
20368        ICASE='COLU'
20369        GOTO6200
20370      ENDIF
20371C
20372      IF(IMCASE.EQ.'MJSR')THEN
20373        ICASE='ROW '
20374        GOTO6200
20375      ENDIF
20376      IF(IMCASE.EQ.'MJSC')THEN
20377        ICASE='COLU'
20378        GOTO6200
20379      ENDIF
20380C
20381      IF(IMCASE.EQ.'MJDR')THEN
20382        ICASE='ROW '
20383        GOTO6200
20384      ENDIF
20385      IF(IMCASE.EQ.'MJDC')THEN
20386        ICASE='COLU'
20387        GOTO6200
20388      ENDIF
20389C
20390      IF(IMCASE.EQ.'MPDR')THEN
20391        ICASE='ROW '
20392        GOTO6200
20393      ENDIF
20394      IF(IMCASE.EQ.'MPDC')THEN
20395        ICASE='COLU'
20396        GOTO6200
20397      ENDIF
20398C
20399      IF(IMCASE.EQ.'MHDR')THEN
20400        ICASE='ROW '
20401        GOTO6200
20402      ENDIF
20403      IF(IMCASE.EQ.'MHDC')THEN
20404        ICASE='COLU'
20405        GOTO6200
20406      ENDIF
20407C
20408      IF(IMCASE.EQ.'MXDR')THEN
20409        ICASE='ROW '
20410        GOTO6200
20411      ENDIF
20412      IF(IMCASE.EQ.'MXDC')THEN
20413        ICASE='COLU'
20414        GOTO6200
20415      ENDIF
20416C
20417      IF(IMCASE.EQ.'MRSC')THEN
20418        ICASE='ROW '
20419        GOTO6500
20420      ENDIF
20421      IF(IMCASE.EQ.'MCSC')THEN
20422        ICASE='COLU'
20423        GOTO6500
20424      ENDIF
20425C
20426      IF(IMCASE.EQ.'MDMR')THEN
20427        ICASE='ROW '
20428        GOTO6600
20429      ENDIF
20430      IF(IMCASE.EQ.'MDMC')THEN
20431        ICASE='COLU'
20432        GOTO6600
20433      ENDIF
20434C
20435      IF(IMCASE.EQ.'MQRD')GOTO6300
20436      IF(IMCASE.EQ.'MPIN')GOTO6400
20437      IF(IMCASE.EQ.'MAMM')GOTO7000
20438      IF(IMCASE.EQ.'MSUM')GOTO7030
20439      IF(IMCASE.EQ.'MAAR')GOTO7100
20440      IF(IMCASE.EQ.'MADR')GOTO7200
20441      IF(IMCASE.EQ.'MADM')GOTO7300
20442      IF(IMCASE.EQ.'MALC')GOTO7400
20443      IF(IMCASE.EQ.'MAVT')GOTO7500
20444      IF(IMCASE.EQ.'MAGM')GOTO7600
20445      IF(IMCASE.EQ.'MAGS')GOTO7700
20446      IF(IMCASE.EQ.'MVRN')GOTO7800
20447      IF(IMCASE.EQ.'MURN')GOTO7900
20448      IF(IMCASE.EQ.'MPDF')GOTO7950
20449      IF(IMCASE.EQ.'WIRN')GOTO8000
20450      IF(IMCASE.EQ.'MACA')GOTO8100
20451      IF(IMCASE.EQ.'XTXI')GOTO8200
20452      IF(IMCASE.EQ.'VINF')GOTO8300
20453      IF(IMCASE.EQ.'CIND')GOTO8400
20454      IF(IMCASE.EQ.'CRMA')GOTO8500
20455      IF(IMCASE.EQ.'GMST')GOTO8550
20456      IF(IMCASE.EQ.'IURN')GOTO8600
20457      IF(IMCASE.EQ.'NCDF')GOTO8700
20458      IF(IMCASE.EQ.'TCDF')GOTO8800
20459      IF(IMCASE.EQ.'TCDF')GOTO8800
20460      IF(IMCASE.EQ.'MTRN')GOTO8900
20461      IF(IMCASE.EQ.'DIRN')GOTO8950
20462      IF(IMCASE.EQ.'DPDF')GOTO9300
20463      IF(IMCASE.EQ.'DLPD')GOTO9300
20464      IF(IMCASE.EQ.'INRN')GOTO9400
20465      IF(IMCASE.EQ.'MPAR')GOTO9500
20466      IF(IMCASE.EQ.'MGRA')GOTO9600
20467      IF(IMCASE.EQ.'MATB')GOTO9700
20468      IF(IMCASE.EQ.'MARB')GOTO9700
20469      IF(IMCASE.EQ.'MSPT')GOTO9800
20470      IF(IMCASE.EQ.'MSP2')GOTO9900
20471      IF(IMCASE.EQ.'MARN')GOTO10000
20472      IF(IMCASE.EQ.'ADMA')GOTO10100
20473      IF(IMCASE.EQ.'ADMD')GOTO10100
20474      IF(IMCASE.EQ.'MFTR')GOTO10200
20475      IF(IMCASE.EQ.'MFTC')GOTO10300
20476      IF(IMCASE.EQ.'VMAT')GOTO10400
20477      IF(IMCASE.EQ.'MVAR')GOTO10500
20478      IF(IMCASE.EQ.'MCRO')GOTO10600
20479      IF(IMCASE.EQ.'MCCO')GOTO10700
20480C
20481      WRITE(ICOUT,999)
20482      CALL DPWRST('XXX','BUG ')
20483      WRITE(ICOUT,1211)
20484 1211 FORMAT('***** INTERNAL ERROR IN MATAR3--')
20485      CALL DPWRST('XXX','BUG ')
20486      WRITE(ICOUT,1212)IMCASE
20487 1212 FORMAT('      IMCASE NOT MATCHED.  IMCASE = ',A4)
20488      CALL DPWRST('XXX','BUG ')
20489      IERROR='YES'
20490      GOTO9000
20491C
20492C               *******************************************************
20493C               **  STEP 56--                                        **
20494C               **  TREAT THE POOLED VARIANCE-COVARIANCE MATRIX  CASE**
20495C               *******************************************************
20496C
20497 5600 CONTINUE
20498C
20499      IF(ITYPA2.EQ.'VARI')GOTO5650
20500C
20501      IF(NC1.EQ.NC2)GOTO5609
20502      WRITE(ICOUT,999)
20503      CALL DPWRST('XXX','BUG ')
20504      WRITE(ICOUT,5601)
20505 5601 FORMAT('***** ERROR IN MATARI--')
20506      CALL DPWRST('XXX','BUG ')
20507      WRITE(ICOUT,5602)
20508 5602 FORMAT('      FOR THE POOLED VARIANCE-COVARIANCE COMMAND,')
20509      CALL DPWRST('XXX','BUG ')
20510      WRITE(ICOUT,5603)
20511 5603 FORMAT('      THE NUMBER OF COLUMNS FOR THE TWO MATRICES')
20512      CALL DPWRST('XXX','BUG ')
20513      WRITE(ICOUT,5604)
20514 5604 FORMAT('      MUST BE EQUAL.')
20515      CALL DPWRST('XXX','BUG ')
20516      WRITE(ICOUT,5606)
20517 5606 FORMAT('      SUCH WAS NOT THE CASE HERE.')
20518      CALL DPWRST('XXX','BUG ')
20519      WRITE(ICOUT,5607)NC1
20520 5607 FORMAT('            NUMBER OF COLUMNS FOR MATRIX 1  =',I8)
20521      CALL DPWRST('XXX','BUG ')
20522      WRITE(ICOUT,5608)NC2
20523 5608 FORMAT('            NUMBER OF COLUMNS FOR MATRIX 2  =',I8)
20524      CALL DPWRST('XXX','BUG ')
20525      IERROR='YES'
20526      GOTO9000
20527 5609 CONTINUE
20528C
20529      CALL VARPOO(YM1,YM2,YM9,MAXROM,MAXCOM,NR1,NC1,NR2,
20530     1DTEMP1,IBUGA3,IERROR)
20531C
20532      ITYP9='MATR'
20533      NR9=NC1
20534      NC9=NC1
20535      IUPFLG='FULL'
20536      GOTO9000
20537C
20538 5650 CONTINUE
20539C
20540      IF(NR1.EQ.N2)GOTO5659
20541      WRITE(ICOUT,999)
20542      CALL DPWRST('XXX','BUG ')
20543      WRITE(ICOUT,5651)
20544 5651 FORMAT('***** ERROR IN MATARI--')
20545      CALL DPWRST('XXX','BUG ')
20546      WRITE(ICOUT,5652)
20547 5652 FORMAT('      FOR THE POOLED VARIANCE-COVARIANCE COMMAND,')
20548      CALL DPWRST('XXX','BUG ')
20549      WRITE(ICOUT,5653)
20550 5653 FORMAT('      THE NUMBER OF ROWS IN THE MATRIX')
20551      CALL DPWRST('XXX','BUG ')
20552      WRITE(ICOUT,5654)
20553 5654 FORMAT('      MUST EQUAL THE NUMBER OF ROWS IN THE GROUP-ID ',
20554     1'VARIABLE..')
20555      CALL DPWRST('XXX','BUG ')
20556      WRITE(ICOUT,5656)
20557 5656 FORMAT('      SUCH WAS NOT THE CASE HERE.')
20558      CALL DPWRST('XXX','BUG ')
20559      WRITE(ICOUT,5657)NC1
20560 5657 FORMAT('            NUMBER OF ROWS FOR MATRIX             =',I8)
20561      CALL DPWRST('XXX','BUG ')
20562      WRITE(ICOUT,5658)NC2
20563 5658 FORMAT('            NUMBER OF ROWS FOR GROUP ID VARIABLE  =',I8)
20564      CALL DPWRST('XXX','BUG ')
20565      IERROR='YES'
20566      GOTO9000
20567 5659 CONTINUE
20568C
20569      CALL VARPO2(YM1,YM2,YM9,MAXROM,MAXCOM,NR1,NC1,MAXROM,
20570     1Y2,Y3,INDEX,NK,DTEMP1,IBUGA3,IERROR)
20571C
20572      ITYP9='MATR'
20573      NR9=NC1
20574      NC9=NC1
20575      IUPFLG='FULL'
20576      GOTO9000
20577C
20578C               *******************************************************
20579C               **  STEP 57--                                        **
20580C               **  TREAT THE MATRIX 2-SAMPLE HOTELLING T-SQUARE CASE**
20581C               *******************************************************
20582C
20583 5700 CONTINUE
20584C
20585      IF(NC1.EQ.NC2)GOTO5709
20586      WRITE(ICOUT,999)
20587      CALL DPWRST('XXX','BUG ')
20588      WRITE(ICOUT,5701)
20589 5701 FORMAT('***** ERROR IN MATARI--')
20590      CALL DPWRST('XXX','BUG ')
20591      WRITE(ICOUT,5702)
20592 5702 FORMAT('      FOR THE 2-SAMPLE HOTELLING T-SQUARE TEST,')
20593      CALL DPWRST('XXX','BUG ')
20594      WRITE(ICOUT,5703)
20595 5703 FORMAT('      THE NUMBER OF COLUMNS FOR THE TWO MATRICES')
20596      CALL DPWRST('XXX','BUG ')
20597      WRITE(ICOUT,5704)
20598 5704 FORMAT('      MUST BE EQUAL.')
20599      CALL DPWRST('XXX','BUG ')
20600      WRITE(ICOUT,5706)
20601 5706 FORMAT('      SUCH WAS NOT THE CASE HERE.')
20602      CALL DPWRST('XXX','BUG ')
20603      WRITE(ICOUT,5707)NC1
20604 5707 FORMAT('            NUMBER OF COLUMNS FOR MATRIX 1  =',I8)
20605      CALL DPWRST('XXX','BUG ')
20606      WRITE(ICOUT,5708)NC2
20607 5708 FORMAT('            NUMBER OF COLUMNS FOR MATRIX 2  =',I8)
20608      CALL DPWRST('XXX','BUG ')
20609      IERROR='YES'
20610      GOTO9000
20611 5709 CONTINUE
20612C
20613      CALL HTTSQ2(YM1,YM2,YM9,MAXROM,MAXCOM,NR1,NR2,NC1,
20614     1TSTAT,ASIG90,ASIG95,ASIG99,ASG995,
20615     1DTEMP1,Y1,Y2,Y3,INDEX,
20616     1IBUGA3,IERROR)
20617C
20618      SCAL9=TSTAT
20619      ITYP9='SCAL'
20620      NR9=1
20621      NC9=1
20622      IUPFLG='FULL'
20623      GOTO9000
20624C
20625C               ************************************************
20626C               **  STEP 58--                                 **
20627C               **  TREAT THE MATRIX QUADRATIC FORM  CASE     **
20628C               **  QUADRATIC FORM = x'Mx                     **
20629C               **  x IS A VECTOR AND M IS A MATRIX           **
20630C               ************************************************
20631C
20632 5800 CONTINUE
20633C
20634      IF(NR1.EQ.NC1)GOTO5809
20635      WRITE(ICOUT,999)
20636      CALL DPWRST('XXX','BUG ')
20637      WRITE(ICOUT,5801)
20638 5801 FORMAT('***** ERROR IN MATARI--')
20639      CALL DPWRST('XXX','BUG ')
20640      WRITE(ICOUT,5802)
20641 5802 FORMAT('      FOR QUADRATIC FORM,')
20642      CALL DPWRST('XXX','BUG ')
20643      WRITE(ICOUT,5803)
20644 5803 FORMAT('      THE NUMBER OF ROWS IN THE MATRIX')
20645      CALL DPWRST('XXX','BUG ')
20646      WRITE(ICOUT,5804)
20647 5804 FORMAT('      MUST EQUAL')
20648      CALL DPWRST('XXX','BUG ')
20649      WRITE(ICOUT,5805)
20650 5805 FORMAT('      THE NUMBER OF COLUMNS IN THE MATRIX;')
20651      CALL DPWRST('XXX','BUG ')
20652      WRITE(ICOUT,5806)
20653 5806 FORMAT('      SUCH WAS NOT THE CASE HERE.')
20654      CALL DPWRST('XXX','BUG ')
20655      WRITE(ICOUT,5807)NR1
20656 5807 FORMAT('            NUMBER OF ROWS    =',I8)
20657      CALL DPWRST('XXX','BUG ')
20658      WRITE(ICOUT,5808)NC1
20659 5808 FORMAT('            NUMBER OF COLUMNS =',I8)
20660      CALL DPWRST('XXX','BUG ')
20661      IERROR='YES'
20662      GOTO9000
20663 5809 CONTINUE
20664C
20665      IF(N2.EQ.NR1)GOTO5859
20666      WRITE(ICOUT,999)
20667      CALL DPWRST('XXX','BUG ')
20668      WRITE(ICOUT,5851)
20669 5851 FORMAT('***** ERROR IN MATARI--')
20670      CALL DPWRST('XXX','BUG ')
20671      WRITE(ICOUT,5852)
20672 5852 FORMAT('      FOR QUADRATIC FORM, THE NUMBER OF ROWS IN THE')
20673      CALL DPWRST('XXX','BUG ')
20674      WRITE(ICOUT,5855)
20675 5855 FORMAT('      MATRIX MUST = NUMBER OF ROWS IN THE VECTOR')
20676      CALL DPWRST('XXX','BUG ')
20677      WRITE(ICOUT,5856)
20678 5856 FORMAT('      SUCH WAS NOT THE CASE HERE.')
20679      CALL DPWRST('XXX','BUG ')
20680      WRITE(ICOUT,5858)NR1,N1
20681 5858 FORMAT('          MATRIX --',I8,' ROWS, VECTOR  ',I8,' COLUMNS')
20682      CALL DPWRST('XXX','BUG ')
20683      IERROR='YES'
20684      GOTO9000
20685 5859 CONTINUE
20686C
20687      CALL QUAFRM(YM1,MAXROM,MAXCOM,NR1,NC1,Y2,IWRITE,SCAL9,
20688     1IBUGA3,IERROR)
20689C
20690      ITYP9='SCAL'
20691      NR9=1
20692      NC9=1
20693      IUPFLG='FULL'
20694      GOTO9000
20695C
20696C               *******************************************************
20697C               **  STEP 59--                                        **
20698C               **  TREAT THE MATRIX 1-SAMPLE HOTELLING T-SQUARE CASE**
20699C               **  H0: U=U0                                         **
20700C               **  T-SQUARE = N*(XBAR-U0)'*SINV*(XBAR-U0)           **
20701C               **  WHERE SINV = SAMPLE VARIANCE-COVARIANCE MATRIX   **
20702C               *******************************************************
20703C
20704 5900 CONTINUE
20705C
20706      IF(NC1.EQ.N2)GOTO5909
20707      WRITE(ICOUT,999)
20708      CALL DPWRST('XXX','BUG ')
20709      WRITE(ICOUT,5901)
20710 5901 FORMAT('***** ERROR IN MATARI--')
20711      CALL DPWRST('XXX','BUG ')
20712      WRITE(ICOUT,5902)
20713 5902 FORMAT('      FOR THE 1-SAMPLE HOTELLING T-SQUARE TEST,')
20714      CALL DPWRST('XXX','BUG ')
20715      WRITE(ICOUT,5903)
20716 5903 FORMAT('      THE NUMBER OF COLUMNS IN THE MATRIX')
20717      CALL DPWRST('XXX','BUG ')
20718      WRITE(ICOUT,5904)
20719 5904 FORMAT('      MUST EQUAL')
20720      CALL DPWRST('XXX','BUG ')
20721      WRITE(ICOUT,5905)
20722 5905 FORMAT('      THE NUMBER OF ROWS IN THE MEAN VECTOR;')
20723      CALL DPWRST('XXX','BUG ')
20724      WRITE(ICOUT,5906)
20725 5906 FORMAT('      SUCH WAS NOT THE CASE HERE.')
20726      CALL DPWRST('XXX','BUG ')
20727      WRITE(ICOUT,5907)NC1
20728 5907 FORMAT('            NUMBER OF COLUMNS FOR MATRIX    =',I8)
20729      CALL DPWRST('XXX','BUG ')
20730      WRITE(ICOUT,5908)N2
20731 5908 FORMAT('            NUMBER OF ROWS FOR MEAN VECTOR  =',I8)
20732      CALL DPWRST('XXX','BUG ')
20733      IERROR='YES'
20734      GOTO9000
20735 5909 CONTINUE
20736C
20737      CALL HTTSQ1(YM1,YM2,MAXROM,MAXCOM,NR1,NC1,
20738     1TSTAT,ASIG90,ASIG95,ASIG99,ASG995,
20739     1DTEMP1,Y2,Y1,Y3,INDEX,
20740     1IBUGA3,IERROR)
20741C
20742      SCAL9=TSTAT
20743      ITYP9='SCAL'
20744      NR9=1
20745      NC9=1
20746      IUPFLG='FULL'
20747      GOTO9000
20748C
20749C               ************************************************
20750C               **  STEP 60--                                 **
20751C               **  TREAT THE MATRIX ROW STATISTIC CASE       **
20752C               ************************************************
20753C
20754CCCCC IMPLEMENTED JULY 1993.
20755 6000 CONTINUE
20756C
20757      IWRITE='OFF'
20758      MAXNXT=MAXOBV
20759      IF(ICASS7.EQ.'INTE')NUMV2=1
20760C
20761      DO6010I=1,NR1
20762        DO6015J=1,NC1
20763          Y1(J)=YM1(I,J)
20764 6015   CONTINUE
20765        ASTAT=0.0
20766        CALL CMPSTA(
20767     1  Y1,Y2,Y2,Y3,Y4,Y5,MAXNXT,NC1,NC1,NC1,NUMV2,ICASS7,
20768     1  ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
20769     1  DTEMP1,DTEMP2,DTEMP3,
20770CCCCC1  IQUAME,IQUASE,PSTAMV,
20771     1  ASTAT,
20772     1  ISUBRO,IBUGA3,IERROR)
20773        VECT9(I)=ASTAT
20774 6010 CONTINUE
20775C
20776      ITYP9='VECT'
20777      NR9=1
20778      NC9=1
20779      NVECT9=NR1
20780      IUPFLG='SUBS'
20781      GOTO9000
20782C
20783C               *****************************************************
20784C               **  STEP 61--                                      **
20785C               **  TREAT THE MATRIX COLUMN STATISTIC        CASE  **
20786C               *****************************************************
20787C
20788 6100 CONTINUE
20789C
20790      IWRITE='OFF'
20791      MAXNXT=MAXOBV
20792      IF(ICASS7.EQ.'INTE')NUMV2=1
20793C
20794      DO6110I=1,NC1
20795        DO6115J=1,NR1
20796          Y1(J)=YM1(J,I)
20797 6115   CONTINUE
20798        ASTAT=0.0
20799        CALL CMPSTA(
20800     1  Y1,Y2,Y2,Y3,Y4,Y5,MAXNXT,NR1,NR1,NR1,NUMV2,ICASS7,
20801     1  ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
20802     1  DTEMP1,DTEMP2,DTEMP3,
20803CCCCC1  IQUAME,IQUASE,PSTAMV,
20804     1  ASTAT,
20805     1  ISUBRO,IBUGA3,IERROR)
20806        VECT9(I)=ASTAT
20807 6110 CONTINUE
20808C
20809      ITYP9='VECT'
20810      NR9=1
20811      NC9=1
20812      NVECT9=NC1
20813      IUPFLG='FULL'
20814      GOTO9000
20815C
20816C               *****************************************************
20817C               **  STEP 62--                                      **
20818C               **  TREAT THE MATRIX EUCLIDEAN DISTANCE      CASE  **
20819C               **            MATRIX CHEBYCHEV DISTANCE      CASE  **
20820C               **            MATRIX MINKOWSKY DISTANCE      CASE  **
20821C               **            MATRIX BLOCK     DISTANCE      CASE  **
20822C               **            MATRIX COSINE    DISTANCE      CASE  **
20823C               **            MATRIX COSINE    SIMILARITY    CASE  **
20824C               **            MATRIX JACCARD   DISTANCE      CASE  **
20825C               **            MATRIX JACCARD   SIMILARITY    CASE  **
20826C               *****************************************************
20827C
20828 6200 CONTINUE
20829C
20830      IF(ICASE.EQ.'ROW '.AND.NR1.GT.MAXCOM)THEN
20831        WRITE(ICOUT,999)
20832        CALL DPWRST('XXX','BUG ')
20833        WRITE(ICOUT,6211)
20834 6211   FORMAT('***** ERROR IN MATAR3--')
20835        CALL DPWRST('XXX','BUG ')
20836        WRITE(ICOUT,6213)
20837 6213   FORMAT('      FOR MATRIX ROW DISTANCES, THE NUMBER OF ')
20838        CALL DPWRST('XXX','BUG ')
20839        WRITE(ICOUT,6215)NR1
20840 6215   FORMAT('      CREATED COLUMNS, ',I8,', WOULD EXCEED THE ')
20841        CALL DPWRST('XXX','BUG ')
20842        WRITE(ICOUT,6217)MAXCOM
20843 6217   FORMAT('      MAXIMUM NUMBER OF ALLOWED COLUMNS,  ',I8,'.')
20844        CALL DPWRST('XXX','BUG ')
20845        IERROR='YES'
20846        GOTO9000
20847      ENDIF
20848C
20849      IWRITE='OFF'
20850      ICASE2='EUCL'
20851      IF(IMCASE(1:3).EQ.'MDK')ICASE2='MINK'
20852      IF(IMCASE(1:3).EQ.'MDB')ICASE2='BLOC'
20853      IF(IMCASE(1:3).EQ.'MDC')ICASE2='CHEB'
20854      IF(IMCASE(1:3).EQ.'MCS')ICASE2='COSS'
20855      IF(IMCASE(1:3).EQ.'MCD')ICASE2='COSD'
20856      IF(IMCASE(1:3).EQ.'MJS')ICASE2='JACS'
20857      IF(IMCASE(1:3).EQ.'MJD')ICASE2='JACD'
20858      IF(IMCASE(1:4).EQ.'MZSR')ICASE2='ACSS'
20859      IF(IMCASE(1:4).EQ.'MASC')ICASE2='ACSS'
20860      IF(IMCASE(1:4).EQ.'MZDR')ICASE2='ACSD'
20861      IF(IMCASE(1:4).EQ.'MADC')ICASE2='ACSD'
20862      IF(IMCASE(1:3).EQ.'MPD')ICASE2='PDIS'
20863      IF(IMCASE(1:3).EQ.'MPS')ICASE2='PSIM'
20864      IF(IMCASE(1:3).EQ.'MHD')ICASE2='HAMM'
20865      IF(IMCASE(1:3).EQ.'MXD')ICASE2='CANB'
20866C
20867      CALL EUCDIS(YM1,YM9,MAXROM,MAXCOM,NR1,NC1,
20868     1            ICASE,ICASE2,P,IWRITE,
20869     1            Y1,Y2,
20870     1            IBUGA3,ISUBRO,IERROR)
20871C
20872      ITYP9='MATR'
20873      IF(ICASE.EQ.'ROW')THEN
20874        NR9=NR1
20875        NC9=NR1
20876        IUPFLG='SUBS'
20877      ELSEIF(ICASE.EQ.'COLU')THEN
20878        NR9=NC1
20879        NC9=NC1
20880        IUPFLG='FULL'
20881      ELSE
20882        NR9=NR1
20883        NC9=NR1
20884        IUPFLG='SUBS'
20885      ENDIF
20886      GOTO9000
20887C
20888C               *********************************************
20889C               **  STEP 63--                              **
20890C               **  TREAT THE MATRIX QR       DECOMP CASE  **
20891C               **  REFERENCE--LINPACK USER'S GUIDE        **
20892C               *********************************************
20893C
20894 6300 CONTINUE
20895C
20896CCCCC IF(NR1.LE.MAXCOM)GOTO6309
20897CCCCC WRITE(ICOUT,999)
20898CCCCC CALL DPWRST('XXX','BUG ')
20899CCCCC WRITE(ICOUT,6301)
20900C6301 FORMAT('***** ERROR IN MATAR2--')
20901CCCCC CALL DPWRST('XXX','BUG ')
20902CCCCC WRITE(ICOUT,6302)
20903C6302 FORMAT('      FOR MATRIX SINGULAR VALUE DECOMPOSITION,')
20904CCCCC CALL DPWRST('XXX','BUG ')
20905CCCCC WRITE(ICOUT,6303)
20906C6303 FORMAT('      THE NUMBER OF ROWS IN THE MATRIX')
20907CCCCC CALL DPWRST('XXX','BUG ')
20908CCCCC WRITE(ICOUT,6304)
20909C6304 FORMAT('      CAN NOT EXCEED ')
20910CCCCC CALL DPWRST('XXX','BUG ')
20911CCCCC WRITE(ICOUT,6305)
20912C6305 FORMAT('      THE MAXIMUM NUMBER OF COLUMNS IN THE MATRIX;')
20913CCCCC CALL DPWRST('XXX','BUG ')
20914CCCCC WRITE(ICOUT,6306)
20915C6306 FORMAT('      SUCH WAS NOT THE CASE HERE.')
20916CCCCC CALL DPWRST('XXX','BUG ')
20917CCCCC WRITE(ICOUT,6307)NR1
20918C6307 FORMAT('            NUMBER OF ROWS    =',I8)
20919CCCCC CALL DPWRST('XXX','BUG ')
20920CCCCC WRITE(ICOUT,6308)MAXCOM
20921C6308 FORMAT('            MAXIMUM NUMBER OF COLUMNS =',I8)
20922CCCCC CALL DPWRST('XXX','BUG ')
20923CCCCC IERROR='YES'
20924CCCCC GOTO9000
20925C
20926C6309 CONTINUE
20927      DO6322J=1,MAXCOM
20928      DO6321I=1,MAXROM
20929      YM9(I,J)=0.0
20930      YM2(I,J)=0.0
20931 6321 CONTINUE
20932 6322 CONTINUE
20933C
20934      IERR2=0
20935      IJOB=11
20936      NTEMP1=NR1
20937      NTEMP2=NC1
20938      CALL SSVDC(YM1,MAXROM,NTEMP1,NTEMP2,VECT9,Y1,YM9,MAXROM,
20939     1YM2,MAXROM,Y2,IJOB,IERR2)
20940C
20941      ITYP9='MATR'
20942      MM=NR1
20943      IF(MM.GT.NC1)MM=NC1
20944      NR9=NR1
20945      NC9=NR1
20946      NR2=NC1
20947      NC2=NC1
20948      NVECT9=MM
20949      IUPFLG='FULL'
20950      GOTO9000
20951C
20952C               ******************************************************
20953C               **  STEP 64--                                       **
20954C               **  TREAT THE MATRIX PSEUDO INVERSE         CASE    **
20955C               ******************************************************
20956C
20957 6400 CONTINUE
20958C
20959      IF(NR1.LT.NC1)THEN
20960        WRITE(ICOUT,999)
20961        CALL DPWRST('XXX','BUG ')
20962        WRITE(ICOUT,6401)
20963 6401   FORMAT('***** ERROR IN PSEUDO INVERSE--')
20964        CALL DPWRST('XXX','BUG ')
20965        WRITE(ICOUT,6402)
20966 6402   FORMAT('      FOR THE MATRIX PSEUDO INVERSE, THE NUMBER OF')
20967        CALL DPWRST('XXX','BUG ')
20968        WRITE(ICOUT,6403)
20969 6403   FORMAT('      ROWS IN THE MATRIX MUST BE GREATER THAN OR')
20970        CALL DPWRST('XXX','BUG ')
20971        WRITE(ICOUT,6404)
20972 6404   FORMAT('      EQUAL TO THE NUMBER OF COLUMNS IN THE MATRIX;')
20973        CALL DPWRST('XXX','BUG ')
20974        WRITE(ICOUT,6406)
20975 6406   FORMAT('      SUCH WAS NOT THE CASE HERE.')
20976        CALL DPWRST('XXX','BUG ')
20977        WRITE(ICOUT,6407)NR1
20978 6407   FORMAT('            NUMBER OF ROWS    =',I8)
20979        CALL DPWRST('XXX','BUG ')
20980        WRITE(ICOUT,6408)NC1
20981 6408   FORMAT('            NUMBER OF COLUMNS =',I8)
20982        CALL DPWRST('XXX','BUG ')
20983        IERROR='YES'
20984        GOTO9000
20985      ENDIF
20986C
20987      IF(NR1.GT.MAXROM)THEN
20988        WRITE(ICOUT,999)
20989        CALL DPWRST('XXX','BUG ')
20990        WRITE(ICOUT,6411)
20991 6411   FORMAT('***** ERROR IN PSEUDO INVERSE--')
20992        CALL DPWRST('XXX','BUG ')
20993        WRITE(ICOUT,6412)
20994 6412   FORMAT('      FOR THE MATRIX PSEUDO INVERSE, THE NUMBER OF')
20995        CALL DPWRST('XXX','BUG ')
20996        WRITE(ICOUT,6413)
20997 6413   FORMAT('      ROWS IN THE MATRIX EXCEEDS THE MAXIMUM')
20998        CALL DPWRST('XXX','BUG ')
20999        WRITE(ICOUT,6414)
21000 6414   FORMAT('      ALLOWABLE NUMBER OF ROWS.')
21001        CALL DPWRST('XXX','BUG ')
21002        WRITE(ICOUT,6417)NR1
21003 6417   FORMAT('            NUMBER OF ROWS         = ',I8)
21004        CALL DPWRST('XXX','BUG ')
21005        WRITE(ICOUT,6418)MAXROM
21006 6418   FORMAT('            MAXIMUM NUMBER OF ROWS = ',I8)
21007        CALL DPWRST('XXX','BUG ')
21008        IERROR='YES'
21009        GOTO9000
21010      ENDIF
21011C
21012      IF(NC1.GT.MAXCOM)THEN
21013        WRITE(ICOUT,999)
21014        CALL DPWRST('XXX','BUG ')
21015        WRITE(ICOUT,6421)
21016 6421   FORMAT('***** ERROR IN PSEUDO INVERSE--')
21017        CALL DPWRST('XXX','BUG ')
21018        WRITE(ICOUT,6422)
21019 6422   FORMAT('      FOR THE MATRIX PSEUDO INVERSE, THE NUMBER OF')
21020        CALL DPWRST('XXX','BUG ')
21021        WRITE(ICOUT,6423)
21022 6423   FORMAT('      COLUMNS IN THE MATRIX EXCEEDS THE MAXIMUM')
21023        CALL DPWRST('XXX','BUG ')
21024        WRITE(ICOUT,6424)
21025 6424   FORMAT('      ALLOWABLE NUMBER OF COLUMNS.')
21026        CALL DPWRST('XXX','BUG ')
21027        WRITE(ICOUT,6427)NR1
21028 6427   FORMAT('            NUMBER OF COLUMNS         = ',I8)
21029        CALL DPWRST('XXX','BUG ')
21030        WRITE(ICOUT,6428)MAXROM
21031 6428   FORMAT('            MAXIMUM NUMBER OF COLUMNS = ',I8)
21032        CALL DPWRST('XXX','BUG ')
21033        IERROR='YES'
21034        GOTO9000
21035      ENDIF
21036C
21037      KTEMP=0
21038      CALL MATMPI(YM1,Y1,Y2,Y3,YM2,NR1,NC1,MAXROM,MAXROM,KTEMP,IFLAG)
21039C
21040      IF(IFLAG.EQ.3)THEN
21041        WRITE(ICOUT,999)
21042        CALL DPWRST('XXX','BUG ')
21043        WRITE(ICOUT,6431)
21044 6431   FORMAT('***** ERROR IN PSEUDO INVERSE--')
21045        CALL DPWRST('XXX','BUG ')
21046        WRITE(ICOUT,6432)
21047 6432   FORMAT('      UNABLE TO COMPUTE THE SINGULAR VALUE')
21048        CALL DPWRST('XXX','BUG ')
21049        WRITE(ICOUT,6433)
21050 6433   FORMAT('      DECOMPOSITION, SO UNABLE TO COMPUTE THE')
21051        CALL DPWRST('XXX','BUG ')
21052        WRITE(ICOUT,6434)
21053 6434   FORMAT('      PSEUDO INVERSE.')
21054        CALL DPWRST('XXX','BUG ')
21055        IERROR='YES'
21056        GOTO9000
21057      ELSE
21058        DO6450J=1,NC1
21059          DO6460I=1,NR1
21060            YM9(I,J)=YM1(I,J)
21061 6460     CONTINUE
21062 6450   CONTINUE
21063      ENDIF
21064C
21065      ITYP9='MATR'
21066      NR9=NR1
21067      NC9=NC1
21068      IUPFLG='FULL'
21069      GOTO9000
21070C
21071C               *****************************************************
21072C               **  STEP 65--                                      **
21073C               **  TREAT THE MATRIX SCALE                   CASE  **
21074C               *****************************************************
21075C
21076 6500 CONTINUE
21077C
21078      IWRITE='OFF'
21079      CALL MATSCA(YM1,YM9,MAXROM,MAXCOM,NR1,NC1,Y1,Y2,Y3,
21080     1IMATSC,ICASE,IWRITE,
21081     1IBUGA3,IERROR)
21082C
21083      ITYP9='MATR'
21084      NR9=NR1
21085      NC9=NC1
21086      IUPFLG='SUBS'
21087      GOTO9000
21088C
21089C               *****************************************************
21090C               **  STEP 66--                                      **
21091C               **  TREAT THE MATRIX MAHALONOBIS DISTANCE    CASE  **
21092C               *****************************************************
21093C
21094 6600 CONTINUE
21095C
21096      IF(ICASE.EQ.'ROW '.AND.NR1.GT.MAXCOM)THEN
21097        WRITE(ICOUT,999)
21098        CALL DPWRST('XXX','BUG ')
21099        WRITE(ICOUT,6611)
21100 6611   FORMAT('***** ERROR IN MATAR3--')
21101        CALL DPWRST('XXX','BUG ')
21102        WRITE(ICOUT,6613)
21103 6613   FORMAT('      FOR MAHALANOBIS ROW DISTANCES, THE NUMBER OF ')
21104        CALL DPWRST('XXX','BUG ')
21105        WRITE(ICOUT,6615)NR1
21106 6615   FORMAT('      CREATED COLUMNS, ',I8,', WOULD EXCEED THE ')
21107        CALL DPWRST('XXX','BUG ')
21108        WRITE(ICOUT,6617)MAXCOM
21109 6617   FORMAT('      MAXIMUM NUMBER OF ALLOWED COLUMNS,  ',I8,'.')
21110        CALL DPWRST('XXX','BUG ')
21111        IERROR='YES'
21112        GOTO9000
21113      ENDIF
21114C
21115      IWRITE='OFF'
21116      CALL MAHDIS(YM1,YM2,YM9,MAXROM,MAXCOM,NR1,NC1,
21117     1Y1,Y2,INDEX,DTEMP1,
21118     1ICASE,IWRITE,IBUGA3,IERROR)
21119C
21120      ITYP9='MATR'
21121      IF(ICASE.EQ.'ROW')THEN
21122        NR9=NR1
21123        NC9=NR1
21124        IUPFLG='SUBS'
21125      ELSEIF(ICASE.EQ.'COLU')THEN
21126        NR9=NC1
21127        NC9=NC1
21128        IUPFLG='FULL'
21129      ELSE
21130        NR9=NR1
21131        NC9=NR1
21132        IUPFLG='SUBS'
21133      ENDIF
21134      GOTO9000
21135C
21136C               *****************************************************
21137C               **  STEP 70--                                      **
21138C               **  TREAT THE MATRIX MEAN                    CASE  **
21139C               *****************************************************
21140C
21141 7000 CONTINUE
21142C
21143      ITYP9='SCAL'
21144      D999=0.0D0
21145      DO7010J=1,NC1
21146        DO7020I=1,NR1
21147          D999=D999+DBLE(YM1(I,J))
21148 7020   CONTINUE
21149 7010 CONTINUE
21150      D999=D999/DBLE(NR1*NC1)
21151      SCAL9=REAL(D999)
21152      NR9=1
21153      NC9=1
21154      IUPFLG='FULL'
21155      GOTO9000
21156C
21157C               *****************************************************
21158C               **  STEP 70.B--                                    **
21159C               **  TREAT THE MATRIX SUM                     CASE  **
21160C               *****************************************************
21161C
21162 7030 CONTINUE
21163C
21164      ITYP9='SCAL'
21165      D999=0.0D0
21166      DO7040J=1,NC1
21167        DO7050I=1,NR1
21168          D999=D999+DBLE(YM1(I,J))
21169 7050   CONTINUE
21170 7040 CONTINUE
21171      SCAL9=REAL(D999)
21172      NR9=1
21173      NC9=1
21174      IUPFLG='FULL'
21175      GOTO9000
21176C
21177C               *****************************************************
21178C               **  STEP 71--                                      **
21179C               **  TREAT THE MATRIX ADD ROW                 CASE  **
21180C               *****************************************************
21181C
21182 7100 CONTINUE
21183C
21184      IF(NC1.NE.N2)THEN
21185        WRITE(ICOUT,999)
21186        CALL DPWRST('XXX','BUG ')
21187        WRITE(ICOUT,7111)
21188 7111   FORMAT('***** ERROR IN MATAR3--')
21189        CALL DPWRST('XXX','BUG ')
21190        WRITE(ICOUT,7113)
21191 7113   FORMAT('      FOR MATRIX ADD ROW, THE NUMBER OF COLUMNS')
21192        CALL DPWRST('XXX','BUG ')
21193        WRITE(ICOUT,7115)NC1
21194 7115   FORMAT('      IN THE MATRIX, ',I8,', DOES NOT EQUAL THE')
21195        CALL DPWRST('XXX','BUG ')
21196        WRITE(ICOUT,7117)N2
21197 7117   FORMAT('      NUMBER OF ROWS IN THE VARIABLE,  ',I8,'.')
21198        CALL DPWRST('XXX','BUG ')
21199        IERROR='YES'
21200        GOTO9000
21201      ENDIF
21202C
21203      DO7110J=1,NC1
21204         DO7120I=1,NR1
21205           YM9(I,J)=YM1(I,J)
21206 7120    CONTINUE
21207         YM9(NR1+1,J)=Y2(J)
21208 7110 CONTINUE
21209C
21210      ITYP9='MATR'
21211      NC9=NC1
21212      NR9=NR1+1
21213      IUPFLG='SUBS'
21214      GOTO9000
21215C               *****************************************************
21216C               **  STEP 72--                                      **
21217C               **  TREAT THE MATRIX DELETE ROW              CASE  **
21218C               *****************************************************
21219C
21220 7200 CONTINUE
21221C
21222      IYS2=INT(YS2+0.5)
21223      IF(IYS2.LT.1.OR.IYS2.GT.NR1)THEN
21224        WRITE(ICOUT,999)
21225        CALL DPWRST('XXX','BUG ')
21226        WRITE(ICOUT,7211)
21227 7211   FORMAT('***** ERROR IN MATAR3--')
21228        CALL DPWRST('XXX','BUG ')
21229        WRITE(ICOUT,7213)
21230 7213   FORMAT('      FOR MATRIX DELETE ROW, THE ROW TO BE ')
21231        CALL DPWRST('XXX','BUG ')
21232        WRITE(ICOUT,7215)IYS2
21233 7215   FORMAT('      DELETED IN THE MATRIX, ',I8,', MUST BE >=1')
21234        CALL DPWRST('XXX','BUG ')
21235        WRITE(ICOUT,7217)NR1
21236 7217   FORMAT('      AND <= ',I8,'.')
21237        CALL DPWRST('XXX','BUG ')
21238        IERROR='YES'
21239        GOTO9000
21240      ENDIF
21241C
21242      DO7210J=1,NC1
21243         ICOUNT=0
21244         DO7220I=1,NR1
21245           IF(IYS2.NE.I)THEN
21246             ICOUNT=ICOUNT+1
21247             YM9(ICOUNT,J)=YM1(I,J)
21248           ENDIF
21249 7220    CONTINUE
21250 7210 CONTINUE
21251C
21252      ITYP9='MATR'
21253      NC9=NC1
21254      NR9=NR1-1
21255      IUPFLG='SUBS'
21256      GOTO9000
21257C
21258C               *****************************************************
21259C               **  STEP 73--                                      **
21260C               **  TREAT THE DISTANCE FROM MEAN             CASE  **
21261C               *****************************************************
21262C
21263 7300 CONTINUE
21264C
21265      ICASE='COLU'
21266      CALL VARCOV(YM1,YM2,MAXROM,MAXCOM,NR1,NC1,DTEMP1,
21267     1            ICASE,IBUGA3,IERROR)
21268C
21269      CALL SGECO(YM2,MAXROM,NC1,INDEX,RCOND,Y1)
21270      EPS=1.0E-20
21271      IF(RCOND.LE.EPS)THEN
21272        WRITE(ICOUT,999)
21273        CALL DPWRST('XXX','BUG ')
21274        WRITE(ICOUT,7371)
21275        CALL DPWRST('XXX','ERRO ')
21276        WRITE(ICOUT,7372)
21277        CALL DPWRST('XXX','ERRO ')
21278        WRITE(ICOUT,7373)
21279        CALL DPWRST('XXX','ERRO ')
21280        IERROR='YES'
21281        GOTO9000
21282      ENDIF
21283 7371 FORMAT('*** ERROR FROM MATAR3: UNABLE TO COMPUTE THE INVERSE OF ',
21284     1       'THE COVARIANCE MATRIX.')
21285 7372 FORMAT('    PROBLEM: SOME COLUMNS ARE LINEARLY DEPDENDENT ON ',
21286     1       ' OTHER COLUMNS.')
21287 7373 FORMAT('    SUGGESTED SOLUTION: WORK WITH A SUBSET OF THE ',
21288     1       'ORIGINAL COLUMNS.')
21289C
21290      IJOB=1
21291      CALL SGEDI(YM2,MAXROM,NC1,INDEX,Y1,Y2,IJOB)
21292C
21293      IWRITE='OFF'
21294      DO7320I=1,NR1
21295        DO7330J=1,NC1
21296          Y3(J)=YM1(I,J)-REAL(DTEMP1(J))
21297 7330   CONTINUE
21298        CALL QUAFRM(YM2,MAXROM,MAXCOM,NC1,NC1,Y3,IWRITE,SCAL9,
21299     1              IBUGA3,IERROR)
21300        VECT9(I)=SCAL9
21301 7320 CONTINUE
21302C
21303      ITYP9='VECT'
21304      NVECT9=NR1
21305      IUPFLG='SUBS'
21306      GOTO9000
21307C
21308C               *****************************************************
21309C               **  STEP 74--                                      **
21310C               **  TREAT THE LINEAR COMBINATION             CASE  **
21311C               *****************************************************
21312C
21313 7400 CONTINUE
21314C
21315      IF(N2.NE.NC1)THEN
21316        WRITE(ICOUT,999)
21317        CALL DPWRST('XXX','BUG ')
21318        WRITE(ICOUT,7411)
21319 7411   FORMAT('***** ERROR IN MATAR3--')
21320        CALL DPWRST('XXX','BUG ')
21321        WRITE(ICOUT,7413)
21322 7413   FORMAT('      FOR lINEAR COMBINATION, THE NUMER OF ROWS ')
21323        CALL DPWRST('XXX','BUG ')
21324        WRITE(ICOUT,7415)N2
21325 7415   FORMAT('      IN THE VECTOR, ',I8,' DOES NOT EQUAL THE ')
21326        CALL DPWRST('XXX','BUG ')
21327        WRITE(ICOUT,7417)NC1
21328 7417   FORMAT('      NUMBER OF COLUMNS IN THE MATRIX, ',I8,'.')
21329        CALL DPWRST('XXX','BUG ')
21330        IERROR='YES'
21331        GOTO9000
21332      ENDIF
21333C
21334      ICASE='COLU'
21335      CALL VARCOV(YM1,YM2,MAXROM,MAXCOM,NR1,NC1,DTEMP1,
21336     1            ICASE,IBUGA3,IERROR)
21337C
21338      DO7430J=1,NR1
21339        DSUM1=0.0D0
21340        DO7440L=1,NC1
21341          DSUM1=DSUM1 + DBLE(Y2(L))*DBLE(YM1(J,L))
21342 7440     CONTINUE
21343          VECT9(J)=REAL(DSUM1)
21344 7430   CONTINUE
21345C
21346      ITYP9='VECT'
21347      NVECT9=NR1
21348      IUPFLG='SUBS'
21349      GOTO9000
21350C
21351C               *****************************************************
21352C               **  STEP 75--                                      **
21353C               **  TREAT THE VECTOR TIMES TRANSPOSE         CASE  **
21354C               *****************************************************
21355C
21356 7500 CONTINUE
21357C
21358      IF(N1.GT.MAXCOM)THEN
21359      WRITE(ICOUT,999)
21360      CALL DPWRST('XXX','BUG ')
21361      WRITE(ICOUT,7501)
21362 7501 FORMAT('***** ERROR IN MATAR3--')
21363      CALL DPWRST('XXX','BUG ')
21364      WRITE(ICOUT,7502)
21365 7502 FORMAT('      FOR VECTOR TIMES TRANSPOSE')
21366      CALL DPWRST('XXX','BUG ')
21367      WRITE(ICOUT,7503)
21368 7503 FORMAT('      THE NUMBER OF ROWS IN THE VECTOR MUST BE LESS')
21369      CALL DPWRST('XXX','BUG ')
21370      WRITE(ICOUT,7504)
21371 7504 FORMAT('      THAN ',I8)
21372      CALL DPWRST('XXX','BUG ')
21373      WRITE(ICOUT,7506)
21374 7506 FORMAT('      SUCH WAS NOT THE CASE HERE.')
21375      CALL DPWRST('XXX','BUG ')
21376      WRITE(ICOUT,7507)N1
21377 7507 FORMAT('            NUMBER OF ROWS    =',I8)
21378      CALL DPWRST('XXX','BUG ')
21379      IERROR='YES'
21380      ENDIF
21381C
21382      DO7520I=1,N1
21383        DO7530J=1,N1
21384          YM9(I,J)=Y1(I)*Y1(J)
21385 7530   CONTINUE
21386 7520 CONTINUE
21387C
21388      ITYP9='MATR'
21389      NR9=N1
21390      NC9=N1
21391      IUPFLG='FULL'
21392      GOTO9000
21393C
21394C               *******************************************************
21395C               **  STEP 76--                                        **
21396C               **  TREAT THE MATRIX GROUP MEANS                CASE **
21397C               *******************************************************
21398C
21399 7600 CONTINUE
21400C
21401      IF(NR1.EQ.N2)GOTO7609
21402      WRITE(ICOUT,999)
21403      CALL DPWRST('XXX','BUG ')
21404      WRITE(ICOUT,7601)
21405 7601 FORMAT('***** ERROR IN MATARI--')
21406      CALL DPWRST('XXX','BUG ')
21407      WRITE(ICOUT,7602)
21408 7602 FORMAT('      FOR THE MATRIX GROUP MEANS CASE,')
21409      CALL DPWRST('XXX','BUG ')
21410      WRITE(ICOUT,7603)
21411 7603 FORMAT('      THE NUMBER OF ROWS IN THE MATRIX MUST EQUAL')
21412      CALL DPWRST('XXX','BUG ')
21413      WRITE(ICOUT,7605)
21414 7605 FORMAT('      THE NUMBER OF ROWS IN THE GROUP ID VARIABLE;')
21415      CALL DPWRST('XXX','BUG ')
21416      WRITE(ICOUT,7606)
21417 7606 FORMAT('      SUCH WAS NOT THE CASE HERE.')
21418      CALL DPWRST('XXX','BUG ')
21419      WRITE(ICOUT,7607)NR1
21420 7607 FORMAT('            NUMBER OF ROWS FOR MATRIX             =',I8)
21421      CALL DPWRST('XXX','BUG ')
21422      WRITE(ICOUT,7608)N2
21423 7608 FORMAT('            NUMBER OF ROWS FOR GROUP ID VARIABLE  =',I8)
21424      CALL DPWRST('XXX','BUG ')
21425      IERROR='YES'
21426      GOTO9000
21427 7609 CONTINUE
21428C
21429      CALL GRPMEA(YM1,YM9,MAXROM,MAXCOM,NR1,NC1,
21430     1Y2,Y3,INDEX,N2,NK,Y4,IBUGA3,IERROR)
21431C
21432      ITYP9='MATR'
21433      NR9=NK
21434      NC9=NC1
21435      IUPFLG='FULL'
21436      GOTO9000
21437C
21438C               *******************************************************
21439C               **  STEP 77--                                        **
21440C               **  TREAT THE MATRIX GROUP STANDARD DEVIATIONS  CASE **
21441C               *******************************************************
21442C
21443 7700 CONTINUE
21444C
21445      IF(NR1.EQ.N2)GOTO7709
21446      WRITE(ICOUT,999)
21447      CALL DPWRST('XXX','BUG ')
21448      WRITE(ICOUT,7701)
21449 7701 FORMAT('***** ERROR IN MATARI--')
21450      CALL DPWRST('XXX','BUG ')
21451      WRITE(ICOUT,7702)
21452 7702 FORMAT('      FOR THE MATRIX GROUP STANDARD DEVIATIONS CASE,')
21453      CALL DPWRST('XXX','BUG ')
21454      WRITE(ICOUT,7703)
21455 7703 FORMAT('      THE NUMBER OF ROWS IN THE MATRIX MUST EQUAL')
21456      CALL DPWRST('XXX','BUG ')
21457      WRITE(ICOUT,7705)
21458 7705 FORMAT('      THE NUMBER OF ROWS IN THE GROUP ID VARIABLE;')
21459      CALL DPWRST('XXX','BUG ')
21460      WRITE(ICOUT,7706)
21461 7706 FORMAT('      SUCH WAS NOT THE CASE HERE.')
21462      CALL DPWRST('XXX','BUG ')
21463      WRITE(ICOUT,7707)NR1
21464 7707 FORMAT('            NUMBER OF ROWS FOR MATRIX             =',I8)
21465      CALL DPWRST('XXX','BUG ')
21466      WRITE(ICOUT,7708)N2
21467 7708 FORMAT('            NUMBER OF ROWS FOR GROUP ID VARIABLE  =',I8)
21468      CALL DPWRST('XXX','BUG ')
21469      IERROR='YES'
21470      GOTO9000
21471 7709 CONTINUE
21472C
21473      CALL GRPSD(YM1,YM9,MAXROM,MAXCOM,NR1,NC1,
21474     1Y2,Y3,INDEX,N2,NK,Y4,IBUGA3,IERROR)
21475C
21476      ITYP9='MATR'
21477      NR9=NK
21478      NC9=NC1
21479      IUPFLG='FULL'
21480      GOTO9000
21481C
21482C     *******************************************************
21483C     **  STEP 78--                                        **
21484C     **  TREAT THE MULTIVARIATE NORM RANDOM NUMBERS  CASE **
21485C     *******************************************************
21486C
21487 7800 CONTINUE
21488C
21489      IF(N1.EQ.NR2)GOTO7809
21490      WRITE(ICOUT,999)
21491      CALL DPWRST('XXX','BUG ')
21492      WRITE(ICOUT,7801)
21493 7801 FORMAT('***** ERROR IN MATARI--')
21494      CALL DPWRST('XXX','BUG ')
21495      WRITE(ICOUT,7802)
21496 7802 FORMAT('      FOR THE MULTIVARIATE NORMAL RANDOM NUMBERS CASE,')
21497      CALL DPWRST('XXX','BUG ')
21498      WRITE(ICOUT,7803)
21499 7803 FORMAT('      THE NUMBER OF ROWS IN THE SIGMA MATRIX MUST EQUAL')
21500      CALL DPWRST('XXX','BUG ')
21501      WRITE(ICOUT,7805)
21502 7805 FORMAT('      THE NUMBER OF ROWS IN THE MEAN VARIABLE;')
21503      CALL DPWRST('XXX','BUG ')
21504      WRITE(ICOUT,7806)
21505 7806 FORMAT('      SUCH WAS NOT THE CASE HERE.')
21506      CALL DPWRST('XXX','BUG ')
21507      WRITE(ICOUT,7807)NR1
21508 7807 FORMAT('            NUMBER OF ROWS FOR SIGMA MATRIX       =',I8)
21509      CALL DPWRST('XXX','BUG ')
21510      WRITE(ICOUT,7808)N2
21511 7808 FORMAT('            NUMBER OF ROWS FOR MEAN VARIABLE      =',I8)
21512      CALL DPWRST('XXX','BUG ')
21513      IERROR='YES'
21514      GOTO9000
21515 7809 CONTINUE
21516C
21517      NTEMP=INT(YS3)
21518      LDSIG=MAXROM
21519      LTF=.TRUE.
21520      IFLAG=0
21521C
21522      DO7820I=1,NTEMP
21523        CALL RDMNOR(Y1,YM2,LDSIG,NR2,LTF,Y4,IFLAG,ISEED)
21524        IF(IFLAG.EQ.1)THEN
21525          WRITE(ICOUT,999)
21526          CALL DPWRST('XXX','BUG ')
21527          WRITE(ICOUT,7821)
21528 7821     FORMAT('***** ERROR IN MATARI--')
21529          CALL DPWRST('XXX','BUG ')
21530          WRITE(ICOUT,7822)
21531 7822     FORMAT('      FOR THE MULTIVARIATE NORMAL RANDOM NUMBERS ',
21532     1           'CASE,')
21533          CALL DPWRST('XXX','BUG ')
21534          WRITE(ICOUT,7823)
21535 7823     FORMAT('      UNABLE TO COMPUTE THE CHOLESKY DECOMPOSITION ',
21536     1           'OF THE')
21537          CALL DPWRST('XXX','BUG ')
21538          WRITE(ICOUT,7824)
21539 7824     FORMAT('      SIGMA MATRIX.  THIS IMPLIES SIGMA IS NOT ',
21540     1           'POSITIVE DEFINITE.')
21541          CALL DPWRST('XXX','BUG ')
21542          WRITE(ICOUT,7825)
21543 7825     FORMAT('      THE MULTIVARIATE RANDOM NUMBERS WERE NOT ',
21544     1           'GENERATED.')
21545          CALL DPWRST('XXX','BUG ')
21546          IERROR='YES'
21547          GOTO9000
21548        ENDIF
21549        DO7830J=1,NR2
21550          YM9(I,J)=Y4(J)
21551 7830   CONTINUE
21552 7820 CONTINUE
21553C
21554      ITYP9='MATR'
21555      NR9=NTEMP
21556      NC9=NR2
21557      IUPFLG='FULL'
21558      GOTO9000
21559C
21560C     *******************************************************
21561C     **  STEP 79--                                        **
21562C     **  TREAT THE MULTINOMIAL  RANDOM NUMBERS       CASE **
21563C     **  LET M = MULTINOMIAL RANDOM NUMBERS P N NEVENTS   **
21564C     *******************************************************
21565C
21566 7900 CONTINUE
21567C
21568      DSUM1=0.0D0
21569      DO7909I=1,N1
21570        DSUM1=DSUM1 + DBLE(Y1(I))
21571        IF(Y1(I).LE.0.0 .OR. Y1(I).GE.1.0)THEN
21572          WRITE(ICOUT,999)
21573          CALL DPWRST('XXX','BUG ')
21574          WRITE(ICOUT,7911)
21575          CALL DPWRST('XXX','BUG ')
21576          WRITE(ICOUT,7901)
21577 7901     FORMAT('      THE SPECIFIED PROBABILITIES MUST BE IN ',
21578     1           'THE INTERVAL (0,1).')
21579          CALL DPWRST('XXX','BUG ')
21580          WRITE(ICOUT,7903)I,Y1(I)
21581 7903     FORMAT('      ROW ',I8,' = ',E15.7)
21582          CALL DPWRST('XXX','BUG ')
21583          IERROR='YES'
21584          GOTO9000
21585        ENDIF
21586        IF(DSUM1.GT.1.000001D0)THEN
21587          WRITE(ICOUT,999)
21588          CALL DPWRST('XXX','BUG ')
21589          WRITE(ICOUT,7911)
21590 7911     FORMAT('***** ERROR IN MULTINOMIAL RANDOM NUMBERS--')
21591          CALL DPWRST('XXX','BUG ')
21592          WRITE(ICOUT,7013)
21593 7013     FORMAT('      THE SUM OF THE SPECIFIED PROBABILITIES ')
21594          CALL DPWRST('XXX','BUG ')
21595          WRITE(ICOUT,7015)
21596 7015     FORMAT('      HAS JUST EXCEEDED 1.')
21597          CALL DPWRST('XXX','BUG ')
21598          IERROR='YES'
21599          GOTO9000
21600        ENDIF
21601 7909 CONTINUE
21602C
21603      NTRIAL=INT(YS2+0.5)
21604      NEVENT=INT(YS3+0.5)
21605C
21606      IF(NTRIAL.LT.1)THEN
21607        WRITE(ICOUT,999)
21608        CALL DPWRST('XXX','BUG ')
21609        WRITE(ICOUT,7911)
21610        CALL DPWRST('XXX','BUG ')
21611        WRITE(ICOUT,7916)
21612 7916   FORMAT('      THE NUMBER OF TRIALS IS LESS THAN 1.  ',
21613     1         'NTRIALS = ',I8)
21614        CALL DPWRST('XXX','BUG ')
21615        IERROR='YES'
21616        GOTO9000
21617      ENDIF
21618      IF(NEVENT.LT.1)THEN
21619        WRITE(ICOUT,999)
21620        CALL DPWRST('XXX','BUG ')
21621        WRITE(ICOUT,7911)
21622        CALL DPWRST('XXX','BUG ')
21623        WRITE(ICOUT,7918)
21624 7918   FORMAT('      THE NUMBER OF EVENTS IS LESS THAN 1.  ',
21625     1         'NEVENTS = ',I8)
21626        CALL DPWRST('XXX','BUG ')
21627        IERROR='YES'
21628        GOTO9000
21629      ENDIF
21630C
21631      NCAT=N1
21632      IERROR='NO'
21633C
21634      DO7920I=1,NEVENT
21635        CALL MULRAN(NTRIAL,Y1,NCAT,ITEMP1,ISEED,IERROR)
21636        IF(IERROR.EQ.'YES')GOTO9000
21637        DO7930J=1,NCAT
21638          YM9(I,J)=REAL(ITEMP1(J))
21639 7930   CONTINUE
21640 7920 CONTINUE
21641C
21642      ITYP9='MATR'
21643      NR9=NEVENT
21644      NC9=NCAT
21645      IUPFLG='FULL'
21646      GOTO9000
21647C
21648C     *******************************************************
21649C     **  STEP 79.5--                                      **
21650C     **  TREAT THE MULTINOMIAL PDF                   CASE **
21651C     **  LET M = MULTINOMIAL PDF X P                      **
21652C     *******************************************************
21653C
21654 7950 CONTINUE
21655C
21656      IERROR='NO'
21657      IF(N1.NE.N2)THEN
21658        WRITE(ICOUT,999)
21659        CALL DPWRST('XXX','BUG ')
21660        WRITE(ICOUT,7951)
21661 7951   FORMAT('***** ERROR IN MULTINOMIAL PDF--')
21662        CALL DPWRST('XXX','BUG ')
21663        WRITE(ICOUT,7953)
21664 7953   FORMAT('      THE NUMBER OF ROWS IN THE NUMBER OF SUCCESSES')
21665        CALL DPWRST('XXX','BUG ')
21666        WRITE(ICOUT,7955)
21667 7955   FORMAT('      VECTOR AND THE PROBABILITY OF SUCCESS VECTORS')
21668        CALL DPWRST('XXX','BUG ')
21669        WRITE(ICOUT,7956)
21670 7956   FORMAT('      ARE NOT EQUAL.')
21671        CALL DPWRST('XXX','BUG ')
21672        WRITE(ICOUT,7957)N1
21673 7957   FORMAT('            NUMBER OF ROWS FOR NUMBER OF SUCCESSES = '
21674     1        ,I8)
21675        CALL DPWRST('XXX','BUG ')
21676        WRITE(ICOUT,7958)N2
21677 7958   FORMAT('            NUMBER OF ROWS FOR PROBABILITY OF ',
21678     1         'SUCCESS = ',I8)
21679        CALL DPWRST('XXX','BUG ')
21680        IERROR='YES'
21681        GOTO9000
21682      ENDIF
21683C
21684      DO7960I=1,N1
21685        IF(Y1(I).GE.0.0)THEN
21686          Y1(I)=REAL(INT(Y1(I)+0.1))
21687        ELSE
21688          WRITE(ICOUT,999)
21689          CALL DPWRST('XXX','BUG ')
21690          WRITE(ICOUT,7951)
21691          CALL DPWRST('XXX','BUG ')
21692          WRITE(ICOUT,7961)
21693 7961     FORMAT('      THE NUMBER OF SUCCESSES MUST BE A ',
21694     1           'NON-NEGATIVE INTEGER.')
21695          CALL DPWRST('XXX','BUG ')
21696          WRITE(ICOUT,7963)I,Y1(I)
21697 7963     FORMAT('      ROW ',I8,' = ',E15.7)
21698          CALL DPWRST('XXX','BUG ')
21699          IERROR='YES'
21700          GOTO9000
21701        ENDIF
21702 7960 CONTINUE
21703C
21704      DSUM1=0.0D0
21705      DO7970I=1,N1
21706        DSUM1=DSUM1 + DBLE(Y2(I))
21707        IF(Y2(I).LE.0.0 .OR. Y2(I).GE.1.0)THEN
21708          WRITE(ICOUT,999)
21709          CALL DPWRST('XXX','BUG ')
21710          WRITE(ICOUT,7951)
21711          CALL DPWRST('XXX','BUG ')
21712          WRITE(ICOUT,7971)
21713 7971     FORMAT('      THE SPECIFIED PROBABILITIES MUST BE IN ',
21714     1           'THE INTERVAL (0,1).')
21715          CALL DPWRST('XXX','BUG ')
21716          WRITE(ICOUT,7973)I,Y2(I)
21717 7973     FORMAT('      ROW ',I8,' = ',E15.7)
21718          CALL DPWRST('XXX','BUG ')
21719          IERROR='YES'
21720          GOTO9000
21721        ENDIF
21722        IF(DSUM1.GT.1.000001D0)THEN
21723          WRITE(ICOUT,999)
21724          CALL DPWRST('XXX','BUG ')
21725          WRITE(ICOUT,7951)
21726          CALL DPWRST('XXX','BUG ')
21727          WRITE(ICOUT,7981)
21728 7981     FORMAT('      THE SUM OF THE SPECIFIED PROBABILITIES ')
21729          CALL DPWRST('XXX','BUG ')
21730          WRITE(ICOUT,7983)
21731 7983     FORMAT('      HAS JUST EXCEEDED 1.')
21732          CALL DPWRST('XXX','BUG ')
21733          IERROR='YES'
21734          GOTO9000
21735        ENDIF
21736 7970 CONTINUE
21737C
21738      DSUM1=0.0D0
21739      DSUM2=0.0D0
21740      DO7990I=1,N1
21741        DSUM1=DSUM1+DBLE(Y1(I))
21742        DSUM2=DSUM2+DBLE(Y2(I))
21743 7990 CONTINUE
21744      DN=DSUM1
21745      DNORM=DSUM2
21746C
21747      NTRIAL=INT(DN)
21748C
21749      DSUM1=0.0D0
21750      DSUM2=0.0D0
21751      DLNPDF=DLNGAM(DN+1.0D0)
21752C
21753      DO7992I=1,N1
21754        DLNPDF=DLNPDF - DLNGAM(DBLE(Y1(I) + 1.0D0))
21755 7992 CONTINUE
21756      DO7995I=1,N1
21757        DLNPDF=DLNPDF + DLOG(DBLE(Y2(I))/DNORM)*DBLE(Y1(I))
21758 7995 CONTINUE
21759C
21760      IF(DLNPDF.LT.LOG(CPUMAX))THEN
21761        DLNPDF=DEXP(DLNPDF)
21762      ELSE
21763        WRITE(ICOUT,7998)
21764 7998   FORMAT('***** WARNING: LOGARITHM OF MULTINOMIAL PDF ',
21765     1         'RETURNED TO AVOID OVERFLOW.')
21766        CALL DPWRST('XXX','BUG ')
21767      ENDIF
21768C
21769      SCAL9=REAL(DLNPDF)
21770      ITYP9='SCAL'
21771      NR9=1
21772      NC9=1
21773      IUPFLG='FULL'
21774      GOTO9000
21775C
21776C     *******************************************************
21777C     **  STEP 80--                                        **
21778C     **  TREAT THE WISHART      RANDOM NUMBERS       CASE **
21779C     **  LET M = WISHART RANDOM NUMBERS MU SIGMA N        **
21780C     *******************************************************
21781C
21782 8000 CONTINUE
21783C
21784      IF(N1.EQ.NR2)GOTO8009
21785      WRITE(ICOUT,999)
21786      CALL DPWRST('XXX','BUG ')
21787      WRITE(ICOUT,8001)
21788 8001 FORMAT('***** ERROR IN MATAR3--')
21789      CALL DPWRST('XXX','BUG ')
21790      WRITE(ICOUT,8002)
21791 8002 FORMAT('      FOR THE WISHART RANDOM NUMBERS CASE,')
21792      CALL DPWRST('XXX','BUG ')
21793      WRITE(ICOUT,8003)
21794 8003 FORMAT('      THE NUMBER OF ROWS IN THE SIGMA MATRIX MUST EQUAL')
21795      CALL DPWRST('XXX','BUG ')
21796      WRITE(ICOUT,8005)
21797 8005 FORMAT('      THE NUMBER OF ROWS IN THE MEAN VARIABLE;')
21798      CALL DPWRST('XXX','BUG ')
21799      WRITE(ICOUT,8006)
21800 8006 FORMAT('      SUCH WAS NOT THE CASE HERE.')
21801      CALL DPWRST('XXX','BUG ')
21802      WRITE(ICOUT,8007)NR2
21803 8007 FORMAT('            NUMBER OF ROWS FOR SIGMA MATRIX       =',I8)
21804      CALL DPWRST('XXX','BUG ')
21805      WRITE(ICOUT,8008)N1
21806 8008 FORMAT('            NUMBER OF ROWS FOR MEAN VARIABLE      =',I8)
21807      CALL DPWRST('XXX','BUG ')
21808      IERROR='YES'
21809      GOTO9000
21810 8009 CONTINUE
21811C
21812      IF(NR2.NE.NC2)THEN
21813        WRITE(ICOUT,999)
21814        CALL DPWRST('XXX','BUG ')
21815        WRITE(ICOUT,8011)
21816 8011   FORMAT('***** ERROR IN MATAR3--')
21817        CALL DPWRST('XXX','BUG ')
21818        WRITE(ICOUT,8012)
21819 8012   FORMAT('      FOR WISHART RANDOM NUMBERS,')
21820        CALL DPWRST('XXX','BUG ')
21821        WRITE(ICOUT,8013)
21822 8013   FORMAT('      THE NUMBER OF ROWS IN THE SIGMA MATRIX MUST ',
21823     1         'EQUAL')
21824        CALL DPWRST('XXX','BUG ')
21825        WRITE(ICOUT,8014)
21826 8014   FORMAT('      THE NUMBER OF COLUMNS; SUCH WAS NOT THE CASE ',
21827     1         'HERE.')
21828        CALL DPWRST('XXX','BUG ')
21829        WRITE(ICOUT,8017)NR1
21830 8017   FORMAT('            NUMBER OF ROWS    =',I8)
21831        CALL DPWRST('XXX','BUG ')
21832        WRITE(ICOUT,8018)NC1
21833 8018   FORMAT('            NUMBER OF COLUMNS =',I8)
21834        CALL DPWRST('XXX','BUG ')
21835        IERROR='YES'
21836        GOTO9000
21837      ENDIF
21838C
21839      CALL SPOCO(YM2,MAXROM,NR2,RCOND,Y4,INFO)
21840C
21841      IF(INFO.NE.0)THEN
21842        WRITE(ICOUT,999)
21843        CALL DPWRST('XXX','BUG ')
21844        WRITE(ICOUT,8021)
21845 8021   FORMAT('***** ERROR IN MATAR3--')
21846        CALL DPWRST('XXX','BUG ')
21847        WRITE(ICOUT,8022)
21848 8022   FORMAT('      FOR MATRIX CHOLESKY DECOMPOSITION,')
21849        CALL DPWRST('XXX','BUG ')
21850        WRITE(ICOUT,8023)
21851 8023   FORMAT('      THE INPUT MATRIX IS NOT SINGULAR.')
21852        CALL DPWRST('XXX','BUG ')
21853        IERROR='YES'
21854      ENDIF
21855C
21856      WRITE(ICOUT,8061)RCOND
21857      CALL DPWRST('XXX','TEXT ')
21858 8061 FORMAT('THE RECIPROCAL CONDITION NUMBER FOR THE SIGMA MATRIX = ',
21859     1       E15.7)
21860      IF(1.0+RCOND.EQ.1.0)THEN
21861        WRITE(ICOUT,999)
21862        CALL DPWRST('XXX','BUG ')
21863        WRITE(ICOUT,8071)
21864        CALL DPWRST('XXX','ERRO ')
21865        WRITE(ICOUT,8072)
21866        CALL DPWRST('XXX','ERRO ')
21867        IERROR='YES'
21868      END IF
21869 8071 FORMAT('****** ERROR FOR WISHART RANDOM NUMBERS ********')
21870 8072 FORMAT('       THE SIGMA MATRIX IS SINGULAR')
21871C
21872      ICOUNT=0
21873      DO8080I=1,NR2
21874      DO8082J=I,NC2
21875        IF(J.GE.I)THEN
21876          ICOUNT=ICOUNT+1
21877          Y2(ICOUNT)=YM2(I,J)
21878        ENDIF
21879 8082 CONTINUE
21880 8080 CONTINUE
21881C
21882C
21883      NTEMP=INT(YS3)
21884      NP=NR2
21885      NNP=NP*(NP+1)/2
21886C
21887      CALL WSHRT(Y2,NTEMP,NP,NNP,Y3,Y4,ISEED)
21888C
21889      ICOUNT=0
21890      DO8090J=1,NP
21891        DO8092I=1,NP
21892          IF(I.LE.J)THEN
21893            ICOUNT=ICOUNT+1
21894            YM9(I,J)=Y4(ICOUNT)
21895            IF(I.NE.J)YM9(J,I)=YM9(I,J)
21896          ENDIF
21897 8092   CONTINUE
21898 8090 CONTINUE
21899C
21900      ITYP9='MATR'
21901      NR9=NP
21902      NC9=NP
21903      IUPFLG='FULL'
21904      GOTO9000
21905C
21906C               ***********************************************
21907C               **  STEP 81--                                **
21908C               **  TREAT THE CATCHER MATRIX CASE            **
21909C               **  C = X(X'X)**(-1)                         **
21910C               ***********************************************
21911C
21912 8100 CONTINUE
21913C
21914      CALL CATCHR(YM1,YM2,YM9,Y1,Y2,INDEX,
21915     1MAXROM,MAXCOM,NR1,NC1,
21916     1IBUGA3,IERROR)
21917C
21918      ITYP9='MATR'
21919      NR9=NR1
21920      NC9=NC1
21921      IUPFLG='FULL'
21922      GOTO9000
21923C
21924C               ***********************************************
21925C               **  STEP 82--                                **
21926C               **  TREAT THE (X'X)**(-1) MATRIX CASE        **
21927C               **  C = X(X'X)**(-1)                         **
21928C               ***********************************************
21929C
21930 8200 CONTINUE
21931C
21932      CALL XTXINV(YM1,YM9,Y1,Y2,INDEX,
21933     1MAXROM,MAXCOM,NR1,NC1,
21934     1IBUGA3,IERROR)
21935C
21936      ITYP9='MATR'
21937      NR9=NC1
21938      NC9=NC1
21939      IUPFLG='FULL'
21940      GOTO9000
21941C
21942C               ************************************************
21943C               **  STEP 83--                                 **
21944C               **  TREAT THE VARIANCE INFLATION FACTORS CASE **
21945C               ************************************************
21946C
21947 8300 CONTINUE
21948C
21949      CALL CATCHR(YM1,YM2,YM9,Y1,Y2,INDEX,
21950     1MAXROM,MAXCOM,NR1,NC1,
21951     1IBUGA3,IERROR)
21952C
21953      DO8310J=1,NC1
21954        DSUM1=0.0D0
21955        DSUM2=0.0D0
21956        DO8320I=1,NR1
21957          DSUM1=DSUM1 + DBLE(YM9(I,J))**2
21958          DSUM2=DSUM2 + DBLE(YM1(I,J))
21959 8320   CONTINUE
21960        DMEAN=DSUM2/DBLE(NR1)
21961        DSUM2=0.0D0
21962        DO8330I=1,NR1
21963          DSUM2=DSUM2 + (DBLE(YM1(I,J)) - DMEAN)**2
21964 8330   CONTINUE
21965        VECT9(J)=REAL(DSUM1*DSUM2)
21966 8310 CONTINUE
21967C
21968      ITYP9='VECT'
21969      NVECT9=NC1
21970      IUPFLG='FULL'
21971      GOTO9000
21972C
21973C               ***********************************************
21974C               **  STEP 84--                                **
21975C               **  TREAT THE CONDITION INDICES CASE         **
21976C               **  (USEFUL FOR REGRESSION DIAGNOSTICS)      **
21977C               ***********************************************
21978C
21979 8400 CONTINUE
21980C
21981C  SCALE DESIGN MATRIX
21982C
21983      DO8410J=1,NC1
21984        DSUM1=0.0D0
21985        DO8420I=1,NR1
21986          DSUM1=DSUM1 + DBLE(YM1(I,J))*DBLE(YM1(I,J))
21987 8420   CONTINUE
21988        DSUM1=DSQRT(DSUM1)
21989        DO8430I=1,NR1
21990          YM1(I,J)=YM1(I,J)/REAL(DSUM1)
21991 8430   CONTINUE
21992 8410 CONTINUE
21993C
21994C  COMPUTE SINGULAR VALUES OF SCALED MATRIX
21995C
21996      IERR2=0
21997      IJOB=0
21998      CALL SSVDC(YM1,MAXROM,NR1,NC1,VECT9,Y1,YM1,MAXROM,
21999     1YM1,MAXROM,Y2,IJOB,IERR2)
22000C
22001      DO8440I=1,NC1
22002        VECT9(I)=VECT9(I)*VECT9(I)
22003 8440 CONTINUE
22004C
22005      CALL MAXIM(VECT9,NC1,IWRITE,XMAX,IBUGA3,IERROR)
22006      DO8450I=1,NC1
22007        IF(VECT9(I).NE.0.0)THEN
22008          VECT9(I)=XMAX/VECT9(I)
22009        ELSE
22010          VECT9(I)=0.0
22011        ENDIF
22012 8450 CONTINUE
22013C
22014      ITYP9='VECT'
22015      NVECT9=NC1
22016      IUPFLG='FULL'
22017      GOTO9000
22018C
22019C               ***********************************************
22020C               **  STEP 85--                                **
22021C               **  TREAT THE CREATE MATRIX  CASE            **
22022C               **  LET M = CREATE MATRIX V1 V2 ... VK       **
22023C               **  NOTE: MOST OF THE REAL WORK OF THIS      **
22024C               **  FUNCTION ACTUALLY DONE IN DPMAT2, HERE   **
22025C               **  SIMPLY DOING A MATRIX COPY.              **
22026C               ***********************************************
22027C
22028 8500 CONTINUE
22029C
22030      DO8510J=1,NC1
22031        DO8520I=1,NR1
22032          YM9(I,J)=YM1(I,J)
22033 8520   CONTINUE
22034 8510 CONTINUE
22035C
22036      ITYP9='MATR'
22037      NR9=NR1
22038      NC9=NC1
22039      IUPFLG='FULL'
22040      GOTO9000
22041C
22042C               ****************************************************
22043C               **  STEP 85B-                                     **
22044C               **  TREAT THE GENERATE MATRIX  CASE               **
22045C               **  LET M = GENERATE MATRIX <STAT> V1 V2 ... VK   **
22046C               **  NOTE: MOST OF THE REAL WORK OF THIS           **
22047C               **  FUNCTION ACTUALLY DONE IN DPMAT2, HERE        **
22048C               **  SIMPLY DOING A MATRIX COPY.                   **
22049C               ****************************************************
22050C
22051 8550 CONTINUE
22052C
22053      DO8560J=1,NC1
22054        DO8570I=1,NR1
22055          YM9(I,J)=YM1(I,J)
22056 8570   CONTINUE
22057 8560 CONTINUE
22058C
22059      ITYP9='MATR'
22060      NR9=NR1
22061      NC9=NC1
22062      IUPFLG='FULL'
22063      GOTO9000
22064C
22065C     *********************************************************************
22066C     **  STEP 86--                                                      **
22067C     **  TREAT THE INDEPENDENT UNIFORM RANDOM NUMBERS  CASE             **
22068C     **    LET M = INDEPENDENT UNIFORM RANDOM NUMBER LOWLIM UPPLIM NP   **
22069C     *********************************************************************
22070C
22071 8600 CONTINUE
22072C
22073      NROW=INT(YS3 + 0.1)
22074      NCOL=N1
22075C
22076      DO8620J=1,NCOL
22077        ATEMP1=AMIN1(Y1(J),Y2(J))
22078        ATEMP2=ABS(Y2(J)-Y1(J))
22079        CALL UNIRAN(NROW,ISEED,Y4)
22080        DO8630I=1,NROW
22081          YM9(I,J)=ATEMP1 + ATEMP2*Y4(I)
22082 8630   CONTINUE
22083 8620 CONTINUE
22084C
22085      ITYP9='MATR'
22086      NR9=NROW
22087      NC9=NCOL
22088      IUPFLG='FULL'
22089      GOTO9000
22090C
22091C     *******************************************************
22092C     **  STEP 87--                                        **
22093C     **  TREAT THE MULTIVARIATE NORMAL CDF           CASE **
22094C     *******************************************************
22095C
22096 8700 CONTINUE
22097C
22098      IF(NR1.NE.NC1)THEN
22099        WRITE(ICOUT,999)
22100        CALL DPWRST('XXX','BUG ')
22101        WRITE(ICOUT,8701)
22102 8701   FORMAT('***** ERROR IN MULTIVARIATE NORMAL CDF--')
22103        CALL DPWRST('XXX','BUG ')
22104        WRITE(ICOUT,8702)
22105 8702   FORMAT('      FOR THE MULTIVARIATE NORMAL CDF CASE, THE')
22106        CALL DPWRST('XXX','BUG ')
22107        WRITE(ICOUT,8703)
22108 8703   FORMAT('      CORRELATION MATRIX MUST BE SQUARE.')
22109        CALL DPWRST('XXX','BUG ')
22110        WRITE(ICOUT,8706)
22111 8706   FORMAT('      SUCH WAS NOT THE CASE HERE.')
22112        CALL DPWRST('XXX','BUG ')
22113        WRITE(ICOUT,8707)NR1
22114 8707   FORMAT('            NUMBER OF ROWS FOR SIGMA MATRIX       =',I8)
22115        CALL DPWRST('XXX','BUG ')
22116        WRITE(ICOUT,8708)NC1
22117 8708   FORMAT('            NUMBER OF COLUMNS FOR SIGMA MATRIX    =',I8)
22118        CALL DPWRST('XXX','BUG ')
22119        IERROR='YES'
22120        GOTO9000
22121      ELSE
22122        N=NR1
22123      ENDIF
22124C
22125      IF(N3.EQ.0)THEN
22126        IF(N2.NE.N)THEN
22127          WRITE(ICOUT,999)
22128          CALL DPWRST('XXX','BUG ')
22129          WRITE(ICOUT,8711)
22130 8711     FORMAT('***** ERROR IN MULTIVARIATE NORMAL CDF--')
22131          CALL DPWRST('XXX','BUG ')
22132          WRITE(ICOUT,8712)
22133 8712     FORMAT('      FOR THE MULTIVARIATE NORMAL CDF CASE, THE')
22134          CALL DPWRST('XXX','BUG ')
22135          WRITE(ICOUT,8713)
22136 8713     FORMAT('      NUMBER OF ROWS FOR THE UPPER LIMIT VARIABLE')
22137          CALL DPWRST('XXX','BUG ')
22138          WRITE(ICOUT,8714)
22139 8714     FORMAT('      NUMBER OF ROWS/COLUMNS FOR THE SIGMA MATRRIX.')
22140          CALL DPWRST('XXX','BUG ')
22141          WRITE(ICOUT,8716)
22142 8716     FORMAT('      SUCH WAS NOT THE CASE HERE.')
22143          CALL DPWRST('XXX','BUG ')
22144          WRITE(ICOUT,8717)NR1
22145 8717     FORMAT('            NUMBER OF ROWS FOR SIGMA MATRIX    ',
22146     1           '          = ',I8)
22147          CALL DPWRST('XXX','BUG ')
22148          WRITE(ICOUT,8718)N2
22149 8718     FORMAT('            NUMBER OF ROWS FOR THE UPPER LIMIT ',
22150     1           'VECTOR    = ',I8)
22151          CALL DPWRST('XXX','BUG ')
22152          IERROR='YES'
22153          GOTO9000
22154        ENDIF
22155      ELSE
22156        IF(N2.NE.N .OR. N3.NE.N)THEN
22157          WRITE(ICOUT,999)
22158          CALL DPWRST('XXX','BUG ')
22159          WRITE(ICOUT,8721)
22160 8721     FORMAT('***** ERROR IN MULTIVARIATE NORMAL CDF--')
22161          CALL DPWRST('XXX','BUG ')
22162          WRITE(ICOUT,8722)
22163 8722     FORMAT('      FOR THE MULTIVARIATE NORMAL CDF CASE, THE')
22164          CALL DPWRST('XXX','BUG ')
22165          WRITE(ICOUT,8723)
22166 8723     FORMAT('      NUMBER OF ROWS FOR THE UPPER LIMIT VARIABLE')
22167          CALL DPWRST('XXX','BUG ')
22168          WRITE(ICOUT,8724)
22169 8724     FORMAT('      NUMBER OF ROWS/COLUMNS FOR THE SIGMA MATRRIX.')
22170          CALL DPWRST('XXX','BUG ')
22171          WRITE(ICOUT,8726)
22172 8726     FORMAT('      SUCH WAS NOT THE CASE HERE.')
22173          CALL DPWRST('XXX','BUG ')
22174          WRITE(ICOUT,8727)NR1
22175 8727     FORMAT('            NUMBER OF ROWS FOR SIGMA MATRIX    ',
22176     1           '          = ',I8)
22177          CALL DPWRST('XXX','BUG ')
22178          WRITE(ICOUT,8728)N2
22179 8728     FORMAT('            NUMBER OF ROWS FOR THE LOWER LIMIT ',
22180     1           'VECTOR    = ',I8)
22181          CALL DPWRST('XXX','BUG ')
22182          WRITE(ICOUT,8729)N3
22183 8729     FORMAT('            NUMBER OF ROWS FOR THE UPPER LIMIT ',
22184     1           'VECTOR    = ',I8)
22185          CALL DPWRST('XXX','BUG ')
22186          IERROR='YES'
22187          GOTO9000
22188        ENDIF
22189      ENDIF
22190C
22191      IF(N.LT.1 .OR. N .GT.20)THEN
22192        WRITE(ICOUT,999)
22193        CALL DPWRST('XXX','BUG ')
22194        WRITE(ICOUT,8731)
22195 8731   FORMAT('***** ERROR IN MULTIVARIATE NORMAL CDF--')
22196        CALL DPWRST('XXX','BUG ')
22197        WRITE(ICOUT,8732)
22198 8732   FORMAT('      CORRELATION MATRIX HAS LESS THAN ONE OR MORE')
22199        CALL DPWRST('XXX','BUG ')
22200        WRITE(ICOUT,8733)N
22201 8733   FORMAT('     THAN 20 VARIABLES.   NUMBER OF VARIABLES = ',I8)
22202        CALL DPWRST('XXX','BUG ')
22203        IERROR='YES'
22204        GOTO9000
22205      ENDIF
22206C
22207      DO8741I=1,N
22208        DTEMP1(I)=0.0D0
22209        DTEMP2(I)=0.0D0
22210        DTEMP3(I)=0.0D0
22211 8741 CONTINUE
22212      ICNT=0
22213      DO8760J=1,N
22214        DO8765I=1,N
22215          IF(J.LT.I)THEN
22216            ICNT=ICNT+1
22217            INDX=J + ((I-2)*(I-1))/2
22218            DTEMP1(INDX)=DBLE(YM1(I,J))
22219          ENDIF
22220 8765   CONTINUE
22221 8760 CONTINUE
22222C
22223      IF(N3.EQ.0)THEN
22224        DO8770I=1,N
22225          ITEMP1(I)=0
22226          DTEMP3(I)=DBLE(Y2(I))
22227          DTEMP2(I)=DBLE(Y2(I))
22228 8770   CONTINUE
22229      ELSE
22230        DO8775I=1,N
22231          ITEMP1(I)=2
22232          DTEMP2(I)=DBLE(Y2(I))
22233          DTEMP3(I)=DBLE(Y3(I))
22234          IF(Y2(I).EQ.CPUMIN.AND.Y3(I).EQ.CPUMAX)THEN
22235            ITEMP1(I)=-1
22236            DTEMP2(I)=0.0D0
22237            DTEMP3(I)=0.0D0
22238          ELSEIF(Y2(I).EQ.CPUMIN)THEN
22239            ITEMP1(I)=0
22240            DTEMP2(I)=DBLE(Y3(I))
22241            DTEMP3(I)=DBLE(Y3(I))
22242          ELSEIF(Y3(I).EQ.CPUMAX)THEN
22243            ITEMP1(I)=1
22244            DTEMP3(I)=DBLE(Y2(I))
22245            DTEMP2(I)=DBLE(Y2(I))
22246          ENDIF
22247 8775   CONTINUE
22248      ENDIF
22249C
22250      MAXPTS=5000*N*N*N
22251CCCCC ABSEPS=0.00005D0
22252CCCCC RELEPS=0.0D0
22253      ABSEPS=DBLE(ABSE)
22254      RELEPS=DBLE(RELE)
22255      VALS=0.0D0
22256      ERRS=0.0D0
22257      IFTS=0
22258C
22259      IF(IMVNTY.EQ.'SADM')THEN
22260        CALL SADMVN(N,DTEMP2,DTEMP3,ITEMP1,DTEMP1,
22261     1              MAXPTS,ABSEPS,RELEPS,ERRS,VALS,IFTS)
22262      ELSEIF(IMVNTY.EQ.'RANM')THEN
22263        CALL RANMVN(N,DTEMP2,DTEMP3,ITEMP1,DTEMP1,
22264     1              MAXPTS,ABSEPS,RELEPS,ERRS,VALS,IFTS)
22265      ELSEIF(IMVNTY.EQ.'KROM')THEN
22266        CALL KROMVN(N,DTEMP2,DTEMP3,ITEMP1,DTEMP1,
22267     1              MAXPTS,ABSEPS,RELEPS,ERRS,VALS,IFTS)
22268      ELSEIF(IMVNTY.EQ.'SPHM')THEN
22269        CALL SPHMVN(N,DTEMP2,DTEMP3,ITEMP1,DTEMP1,
22270     1              MAXPTS,ABSEPS,RELEPS,ERRS,VALS,IFTS)
22271      ELSE
22272        CALL SADMVN(N,DTEMP2,DTEMP3,ITEMP1,DTEMP1,
22273     1              MAXPTS,ABSEPS,RELEPS,ERRS,VALS,IFTS)
22274      ENDIF
22275C
22276      IF(IFTS.EQ.1)THEN
22277        WRITE(ICOUT,999)
22278        CALL DPWRST('XXX','BUG ')
22279        WRITE(ICOUT,8791)
22280 8791   FORMAT('***** WARNING IN MULTIVARIATE NORMAL CDF--')
22281        CALL DPWRST('XXX','BUG ')
22282        WRITE(ICOUT,8792)ABSEPS
22283 8792   FORMAT('      ERROR IS GREATER THAN REQUESTED VALUE OF ',
22284     1         E15.7)
22285        CALL DPWRST('XXX','BUG ')
22286      ENDIF
22287C
22288      ITYP9='SCAL'
22289      SCAL9=REAL(VALS)
22290      NR9=1
22291      NC9=1
22292      IUPFLG='FULL'
22293      AERROR=ERRS
22294      GOTO9000
22295C
22296C     *******************************************************
22297C     **  STEP 88--                                        **
22298C     **  TREAT THE MULTIVARIATE T      CDF           CASE **
22299C     *******************************************************
22300C
22301 8800 CONTINUE
22302C
22303      IF(NR1.NE.NC1)THEN
22304        WRITE(ICOUT,999)
22305        CALL DPWRST('XXX','BUG ')
22306        WRITE(ICOUT,8801)
22307 8801   FORMAT('***** ERROR IN MULTIVARIATE T CDF--')
22308        CALL DPWRST('XXX','BUG ')
22309        WRITE(ICOUT,8802)
22310 8802   FORMAT('      FOR THE MULTIVARIATE T CDF CASE, THE')
22311        CALL DPWRST('XXX','BUG ')
22312        WRITE(ICOUT,8803)
22313 8803   FORMAT('      CORRELATION MATRIX MUST BE SQUARE.')
22314        CALL DPWRST('XXX','BUG ')
22315        WRITE(ICOUT,8806)
22316 8806   FORMAT('      SUCH WAS NOT THE CASE HERE.')
22317        CALL DPWRST('XXX','BUG ')
22318        WRITE(ICOUT,8807)NR1
22319 8807   FORMAT('            NUMBER OF ROWS FOR SIGMA MATRIX       =',I8)
22320        CALL DPWRST('XXX','BUG ')
22321        WRITE(ICOUT,8808)NC1
22322 8808   FORMAT('            NUMBER OF COLUMNS FOR SIGMA MATRIX    =',I8)
22323        CALL DPWRST('XXX','BUG ')
22324        IERROR='YES'
22325        GOTO9000
22326      ELSE
22327        N=NR1
22328      ENDIF
22329C
22330      IF(N4.EQ.0)THEN
22331        IF(N3.NE.N)THEN
22332          WRITE(ICOUT,999)
22333          CALL DPWRST('XXX','BUG ')
22334          WRITE(ICOUT,8811)
22335 8811     FORMAT('***** ERROR IN MULTIVARIATE T CDF--')
22336          CALL DPWRST('XXX','BUG ')
22337          WRITE(ICOUT,8812)
22338 8812     FORMAT('      FOR THE MULTIVARIATE T CDF CASE, THE')
22339          CALL DPWRST('XXX','BUG ')
22340          WRITE(ICOUT,8813)
22341 8813     FORMAT('      NUMBER OF ROWS FOR THE UPPER LIMIT VARIABLE')
22342          CALL DPWRST('XXX','BUG ')
22343          WRITE(ICOUT,8814)
22344 8814     FORMAT('      NUMBER OF ROWS/COLUMNS FOR THE SIGMA MATRRIX.')
22345          CALL DPWRST('XXX','BUG ')
22346          WRITE(ICOUT,8816)
22347 8816     FORMAT('      SUCH WAS NOT THE CASE HERE.')
22348          CALL DPWRST('XXX','BUG ')
22349          WRITE(ICOUT,8817)NR1
22350 8817     FORMAT('            NUMBER OF ROWS FOR SIGMA MATRIX    ',
22351     1           '          = ',I8)
22352          CALL DPWRST('XXX','BUG ')
22353          WRITE(ICOUT,8818)N3
22354 8818     FORMAT('            NUMBER OF ROWS FOR THE UPPER LIMIT ',
22355     1           'VECTOR    = ',I8)
22356          CALL DPWRST('XXX','BUG ')
22357          IERROR='YES'
22358          GOTO9000
22359        ENDIF
22360      ELSE
22361        IF(N3.NE.N .OR. N4.NE.N)THEN
22362          WRITE(ICOUT,999)
22363          CALL DPWRST('XXX','BUG ')
22364          WRITE(ICOUT,8821)
22365 8821     FORMAT('***** ERROR IN MULTIVARIATE T CDF--')
22366          CALL DPWRST('XXX','BUG ')
22367          WRITE(ICOUT,8822)
22368 8822     FORMAT('      FOR THE MULTIVARIATE T CDF CASE, THE')
22369          CALL DPWRST('XXX','BUG ')
22370          WRITE(ICOUT,8823)
22371 8823     FORMAT('      NUMBER OF ROWS FOR THE UPPER LIMIT VARIABLE')
22372          CALL DPWRST('XXX','BUG ')
22373          WRITE(ICOUT,8824)
22374 8824     FORMAT('      NUMBER OF ROWS/COLUMNS FOR THE SIGMA MATRRIX.')
22375          CALL DPWRST('XXX','BUG ')
22376          WRITE(ICOUT,8826)
22377 8826     FORMAT('      SUCH WAS NOT THE CASE HERE.')
22378          CALL DPWRST('XXX','BUG ')
22379          WRITE(ICOUT,8827)NR1
22380 8827     FORMAT('            NUMBER OF ROWS FOR SIGMA MATRIX    ',
22381     1           '          = ',I8)
22382          CALL DPWRST('XXX','BUG ')
22383          WRITE(ICOUT,8828)N3
22384 8828     FORMAT('            NUMBER OF ROWS FOR THE LOWER LIMIT ',
22385     1           'VECTOR    = ',I8)
22386          CALL DPWRST('XXX','BUG ')
22387          WRITE(ICOUT,8829)N4
22388 8829     FORMAT('            NUMBER OF ROWS FOR THE UPPER LIMIT ',
22389     1           'VECTOR    = ',I8)
22390          CALL DPWRST('XXX','BUG ')
22391          IERROR='YES'
22392          GOTO9000
22393        ENDIF
22394      ENDIF
22395C
22396      IF(N.LT.1 .OR. N .GT.20)THEN
22397        WRITE(ICOUT,999)
22398        CALL DPWRST('XXX','BUG ')
22399        WRITE(ICOUT,8831)
22400 8831   FORMAT('***** ERROR IN MULTIVARIATE T CDF--')
22401        CALL DPWRST('XXX','BUG ')
22402        WRITE(ICOUT,8832)
22403 8832   FORMAT('      CORRELATION MATRIX HAS LESS THAN ONE OR MORE')
22404        CALL DPWRST('XXX','BUG ')
22405        WRITE(ICOUT,8833)N
22406 8833   FORMAT('     THAN 20 VARIABLES.   NUMBER OF VARIABLES = ',I8)
22407        CALL DPWRST('XXX','BUG ')
22408        IERROR='YES'
22409        GOTO9000
22410      ENDIF
22411C
22412      NU=INT(YS2+0.1)
22413C
22414      DO8841I=1,N
22415        DTEMP1(I)=0.0D0
22416        DTEMP2(I)=0.0D0
22417        DTEMP3(I)=0.0D0
22418 8841 CONTINUE
22419      ICNT=0
22420      DO8860J=1,N
22421        DO8865I=1,N
22422          IF(J.LT.I)THEN
22423            ICNT=ICNT+1
22424            INDX=J + ((I-2)*(I-1))/2
22425            DTEMP1(INDX)=DBLE(YM1(I,J))
22426          ENDIF
22427 8865   CONTINUE
22428 8860 CONTINUE
22429C
22430      IF(N4.EQ.0)THEN
22431        DO8870I=1,N
22432          ITEMP1(I)=0
22433          DTEMP3(I)=DBLE(Y3(I))
22434          DTEMP2(I)=DBLE(Y3(I))
22435 8870   CONTINUE
22436      ELSE
22437        DO8875I=1,N
22438          ITEMP1(I)=2
22439          DTEMP2(I)=DBLE(Y3(I))
22440          DTEMP3(I)=DBLE(Y4(I))
22441          IF(Y3(I).EQ.CPUMIN.AND.Y4(I).EQ.CPUMAX)THEN
22442            ITEMP1(I)=-1
22443            DTEMP2(I)=0.0D0
22444            DTEMP3(I)=0.0D0
22445          ELSEIF(Y3(I).EQ.CPUMIN)THEN
22446            ITEMP1(I)=0
22447            DTEMP2(I)=DBLE(Y4(I))
22448            DTEMP3(I)=DBLE(Y4(I))
22449          ELSEIF(Y3(I).EQ.CPUMAX)THEN
22450            ITEMP1(I)=1
22451            DTEMP3(I)=DBLE(Y3(I))
22452            DTEMP2(I)=DBLE(Y3(I))
22453          ENDIF
22454 8875   CONTINUE
22455      ENDIF
22456C
22457      MAXPTS=5000*N*N*N
22458CCCCC ABSEPS=0.00005D0
22459CCCCC RELEPS=0.0D0
22460      ABSEPS=DBLE(ABSE)
22461      RELEPS=DBLE(RELE)
22462      VALS=0.0D0
22463      ERRS=0.0D0
22464      IFTS=0
22465C
22466      IF(IMVNTY.EQ.'SADM')THEN
22467        CALL SADMVT(N,NU,DTEMP2,DTEMP3,ITEMP1,DTEMP1,
22468     1              MAXPTS,ABSEPS,RELEPS,ERRS,VALS,IFTS)
22469      ELSEIF(IMVNTY.EQ.'RANM')THEN
22470        CALL RANMVT(N,NU,DTEMP2,DTEMP3,ITEMP1,DTEMP1,
22471     1              MAXPTS,ABSEPS,RELEPS,ERRS,VALS,IFTS)
22472      ELSEIF(IMVNTY.EQ.'KROM')THEN
22473        CALL KROMVT(N,NU,DTEMP2,DTEMP3,ITEMP1,DTEMP1,
22474     1              MAXPTS,ABSEPS,RELEPS,ERRS,VALS,IFTS)
22475      ELSE
22476        CALL SADMVT(N,NU,DTEMP2,DTEMP3,ITEMP1,DTEMP1,
22477     1              MAXPTS,ABSEPS,RELEPS,ERRS,VALS,IFTS)
22478      ENDIF
22479C
22480      IF(IFTS.EQ.1)THEN
22481        WRITE(ICOUT,999)
22482        CALL DPWRST('XXX','BUG ')
22483        WRITE(ICOUT,8891)
22484 8891   FORMAT('***** WARNING IN MULTIVARIATE T CDF--')
22485        CALL DPWRST('XXX','BUG ')
22486        WRITE(ICOUT,8892)ABSEPS
22487 8892   FORMAT('      ERROR IS GREATER THAN REQUESTED VALUE OF ',
22488     1         E15.7)
22489        CALL DPWRST('XXX','BUG ')
22490      ENDIF
22491C
22492      ITYP9='SCAL'
22493      SCAL9=REAL(VALS)
22494      NR9=1
22495      NC9=1
22496      IUPFLG='FULL'
22497      GOTO9000
22498C
22499C     *******************************************************
22500C     **  STEP 89--                                        **
22501C     **  TREAT THE MULTIVARIATE T    RANDOM NUMBERS  CASE **
22502C     *******************************************************
22503C
22504 8900 CONTINUE
22505C
22506      IF(N1.EQ.NR2)GOTO8909
22507      WRITE(ICOUT,999)
22508      CALL DPWRST('XXX','BUG ')
22509      WRITE(ICOUT,8901)
22510 8901 FORMAT('***** ERROR IN MATARI--')
22511      CALL DPWRST('XXX','BUG ')
22512      WRITE(ICOUT,8902)
22513 8902 FORMAT('      FOR THE MULTIVARIATE T RANDOM NUMBERS CASE,')
22514      CALL DPWRST('XXX','BUG ')
22515      WRITE(ICOUT,8903)
22516 8903 FORMAT('      THE NUMBER OF ROWS IN THE SIGMA MATRIX MUST EQUAL')
22517      CALL DPWRST('XXX','BUG ')
22518      WRITE(ICOUT,8905)
22519 8905 FORMAT('      THE NUMBER OF ROWS IN THE MEAN VARIABLE;')
22520      CALL DPWRST('XXX','BUG ')
22521      WRITE(ICOUT,8906)
22522 8906 FORMAT('      SUCH WAS NOT THE CASE HERE.')
22523      CALL DPWRST('XXX','BUG ')
22524      WRITE(ICOUT,8907)NR1
22525 8907 FORMAT('            NUMBER OF ROWS FOR SIGMA MATRIX       =',I8)
22526      CALL DPWRST('XXX','BUG ')
22527      WRITE(ICOUT,8908)N2
22528 8908 FORMAT('            NUMBER OF ROWS FOR MEAN VARIABLE      =',I8)
22529      CALL DPWRST('XXX','BUG ')
22530      IERROR='YES'
22531      GOTO9000
22532 8909 CONTINUE
22533C
22534      NTEMP=INT(YS4)
22535      LDSIG=MAXROM
22536      LTF=.TRUE.
22537C
22538      DO8920I=1,NTEMP
22539        CALL RDMNOR(Y1,YM2,LDSIG,NR2,LTF,Y4,IFLAG,ISEED)
22540        DO8930J=1,NR2
22541          YM9(I,J)=Y4(J)
22542 8930   CONTINUE
22543 8920 CONTINUE
22544C
22545C  NOW DIVIDE BY SQRT(CHIRAN(NU)/NU)
22546C
22547      NU=INT(YS3+0.1)
22548      DO8940J=1,NR2
22549        CALL CHSRAN(NTEMP,REAL(NU),ISEED,Y4)
22550        DO8945I=1,NTEMP
22551          YM9(I,J)=YM9(I,J)/SQRT(Y4(I)/REAL(NU))
22552 8945   CONTINUE
22553 8940 CONTINUE
22554C
22555      ITYP9='MATR'
22556      NR9=NTEMP
22557      NC9=NR2
22558      IUPFLG='FULL'
22559      GOTO9000
22560C
22561C     *****************************************************************
22562C     **  STEP 89.5--                                                **
22563C     **  TREAT THE DIRICHLET RANDOM NUMBERS  CASE                   **
22564C     **    LET M = DIRICHLET RANDOM NUMBER ALPHA N                  **
22565C     *****************************************************************
22566C
22567 8950 CONTINUE
22568C
22569      NTEMP=INT(YS2 + 0.1)
22570      NRAN=1
22571C
22572      DO8959J=1,N1
22573        IF(Y1(J).LE.0.0)THEN
22574          WRITE(ICOUT,999)
22575          CALL DPWRST('XXX','BUG ')
22576          WRITE(ICOUT,8951)
22577 8951     FORMAT('***** ERROR FOR DIRICHLET RANDOM NUMBERS--')
22578          CALL DPWRST('XXX','BUG ')
22579          WRITE(ICOUT,8953)
22580 8953     FORMAT('      THE SHAPE PARAMETERS FOR THE DIRICHLET')
22581          CALL DPWRST('XXX','BUG ')
22582          WRITE(ICOUT,8954)
22583 8954     FORMAT('      MUST BE POSITIVE.  AT LEAST ONE OF THE SHAPE')
22584          CALL DPWRST('XXX','BUG ')
22585          WRITE(ICOUT,8955)
22586 8955     FORMAT('      PARAMETERS IS NOT POSITIVE.')
22587          CALL DPWRST('XXX','BUG ')
22588          IERROR='YES'
22589          GOTO9000
22590        ENDIF
22591 8959 CONTINUE
22592C
22593      IF(NTEMP.LT.2)THEN
22594        WRITE(ICOUT,999)
22595        CALL DPWRST('XXX','BUG ')
22596        WRITE(ICOUT,8961)
22597 8961   FORMAT('***** ERROR FOR DIRICHLET RANDOM NUMBERS--')
22598        CALL DPWRST('XXX','BUG ')
22599        WRITE(ICOUT,8963)
22600 8963   FORMAT('      THE REQUESTEND NUMBER OF ROWS MUST BE AT LEAST')
22601        CALL DPWRST('XXX','BUG ')
22602        WRITE(ICOUT,8965)
22603 8965   FORMAT('      ONE.  SUCH WAS NOT THE CASE HERE.')
22604        CALL DPWRST('XXX','BUG ')
22605        IERROR='YES'
22606        GOTO9000
22607      ENDIF
22608C
22609      NRAN=1
22610      DO8970I=1,NTEMP
22611        DSUM=0.0D0
22612        DO8980J=1,N1
22613          CALL GAMRAN(NRAN,Y1(J),ISEED,Y4(J))
22614          DSUM=DSUM+DBLE(Y4(J))
22615 8980   CONTINUE
22616        DO8985J=1,N1
22617          YM9(I,J)=REAL(DBLE(Y4(J))/DSUM)
22618 8985   CONTINUE
22619 8970 CONTINUE
22620C
22621      ITYP9='MATR'
22622      NR9=NTEMP
22623      NC9=N1
22624      IUPFLG='FULL'
22625      GOTO9000
22626C
22627C     *****************************************************************
22628C     **  STEP 93-- -                                                **
22629C     **  TREAT THE DIRICHLET PDF             CASE                   **
22630C     **    LET M = DIRICHLET PDF X THETA                            **
22631C     **    LET M = DIRICHLET LOG PDF X THETA                        **
22632C     *****************************************************************
22633C
22634 9300 CONTINUE
22635C
22636      IERROR='NO'
22637      IF(N1.NE.N2)THEN
22638        WRITE(ICOUT,999)
22639        CALL DPWRST('XXX','BUG ')
22640        WRITE(ICOUT,9351)
22641 9351   FORMAT('***** ERROR IN DIRICHELET PDF--')
22642        CALL DPWRST('XXX','BUG ')
22643        WRITE(ICOUT,9353)
22644 9353   FORMAT('      THE NUMBER OF ROWS IN THE X VECTOR AND THE')
22645        CALL DPWRST('XXX','BUG ')
22646        WRITE(ICOUT,9355)
22647 9355   FORMAT('      ALPHA VECTOR ARE NOT EQUAL')
22648        CALL DPWRST('XXX','BUG ')
22649        WRITE(ICOUT,9357)N1
22650 9357   FORMAT('            NUMBER OF ROWS FOR THE X VECTOR     = ',
22651     1        I8)
22652        CALL DPWRST('XXX','BUG ')
22653        WRITE(ICOUT,9358)N2
22654 9358   FORMAT('            NUMBER OF ROWS FOR THE ALPHA VECTOR = ',
22655     1        I8)
22656        CALL DPWRST('XXX','BUG ')
22657        IERROR='YES'
22658        GOTO9000
22659      ENDIF
22660C
22661      DSUM1=0.0D0
22662      DSUM2=0.0D0
22663      DO9360I=1,N1
22664        DSUM1=DSUM1+DBLE(Y2(I)-1.0)*DBLE(LOG(Y1(I)))
22665 9360 CONTINUE
22666      DLNPDF=DSUM1
22667C
22668      DO9370I=1,N1
22669        DSUM2=DSUM2 + DBLE(Y2(I))
22670 9370 CONTINUE
22671      DLNPDF=DLNPDF + DLNGAM(DSUM2)
22672      DO9380I=1,N1
22673        DLNPDF=DLNPDF - DLNGAM(DBLE(Y2(I)))
22674 9380 CONTINUE
22675C
22676      SCAL9=REAL(DLNPDF)
22677      IF(IMCASE.EQ.'DPDF')THEN
22678        SCAL9=EXP(SCAL9)
22679      ENDIF
22680      ITYP9='SCAL'
22681      NR9=1
22682      NC9=1
22683      IUPFLG='FULL'
22684      GOTO9000
22685C
22686C     ***********************************************************
22687C     **  STEP 94--                                            **
22688C     **  TREAT THE UNIFORM           RANDOM NUMBERS  CASE     **
22689C     **  (CORRELATED CASE)                                    **
22690C     **  LET M = MULTIVARIATE UNIFORM RANDOM NUMBERS SIGMA N  **
22691C     **  ALGORITHM FROM GENTLE (2003), 'RANDOM NUMBER         **
22692C     **  GENERATION AND MONTE CARLO METHODS', 2ND. ED., P. 207**
22693C     **  GENERATE NORMAL RANDOM NUMBERS AND THEN TAKE NORCDF  **
22694C     **  OF THOSE NUMBERS.  NOTE THAT THE LOCATION PARAMETER  **
22695C     **  IS ASSUMED TO BE ZERO.                               **
22696C     ***********************************************************
22697C
22698 9400 CONTINUE
22699C
22700      NTEMP=INT(YS2)
22701      LDSIG=MAXROM
22702      LTF=.TRUE.
22703C
22704      DO9410I=1,NR1
22705        Y1(I)=0.0
22706 9410 CONTINUE
22707C
22708      DO9420I=1,NTEMP
22709        CALL RDMNOR(Y1,YM1,LDSIG,NR1,LTF,Y4,IFLAG,ISEED)
22710        DO9430J=1,NR1
22711          CALL NORCDF(Y4(J),YM9(I,J))
22712 9430   CONTINUE
22713 9420 CONTINUE
22714C
22715      ITYP9='MATR'
22716      NR9=NTEMP
22717      NC9=NR1
22718      IUPFLG='FULL'
22719      GOTO9000
22720C
22721C               *****************************************************
22722C               **  STEP 95--                                      **
22723C               **  TREAT THE MATRIX PARTITION STATISTIC     CASE  **
22724C               *****************************************************
22725C
22726C  THIS COMMAND SPLITS THE FULL MATRIX INTO SUB-PARTITIONS
22727C  (DETERMINED BY NROWPA AND NCOLPA) AND CREATE A NEW MATRIX
22728C  CONTAINING THE COMPUTED STATISTIC FOR EACH OF THESE SUB-MATRICES.
22729C
22730C  TWO CASES ARE SUPPORTED:
22731C
22732C  1) IF THE SECOND AND THIRD ARGUMENTS ARE BOTH SCALAR, THEN
22733C     EXTRACT EQUI-SIZED PARTITIONS.
22734C
22735C  2) IF EITHER THE SECOND OR THIRD ARGUMENT IS A VECTOR, THEN
22736C     EXTRACT UNEQUAL PARTITIONS.  THE VECTOR IS TREATED AS A
22737C     TAG VARIABLE WHICH IDENTIFIES THE SUB-MATRICES.  WITH THIS
22738C     APPROACH, THE SUB-MATRICES DO NOT NEED TO BE OF EQUAL SIZE
22739C     AND DO NOT NEED TO DEFINE CONTIGUOUS SUBSETS.
22740C
22741 9500 CONTINUE
22742C
22743      IWRITE='OFF'
22744      MAXNXT=MAXOBV
22745      IF(ICASS7.EQ.'INTE')NUMV2=1
22746C
22747      NROWPA=INT(ABS(YS2+0.5))
22748      NCOLPA=INT(ABS(YS3+0.5))
22749      IF(N2.LE.0 .AND. N3.LE.0)THEN
22750C
22751        IF(NROWPA.EQ.0)NROWPA=2
22752        IF(NCOLPA.EQ.0)NCOLPA=2
22753C
22754        IROW=0
22755        ICOL=0
22756        DO9510I=1,NC1,NCOLPA
22757          ICOL=ICOL+1
22758          ICOL1=I
22759          ICOL2=I+NCOLPA-1
22760          IF(ICOL2.GT.NC1)ICOL2=NC1
22761          IROW=0
22762          DO9515J=1,NR1,NROWPA
22763            IROW=IROW+1
22764            IROW1=J
22765            IROW2=J+NROWPA-1
22766            IF(IROW2.GT.NR1)IROW2=NR1
22767            III=0
22768            DO9520II=ICOL1,ICOL2
22769              DO9530JJ=IROW1,IROW2
22770                III=III+1
22771                NTEMP=III
22772                Y1(III)=YM1(JJ,II)
22773 9530         CONTINUE
22774 9520       CONTINUE
22775            ASTAT=0.0
22776            CALL CMPSTA(
22777     1    Y1,Y2,Y2,Y3,Y4,Y5,MAXNXT,NTEMP,NTEMP,NTEMP,NUMV2,ICASS7,
22778     1    ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
22779     1    DTEMP1,DTEMP2,DTEMP3,
22780CCCCC1    IQUAME,IQUASE,PSTAMV,
22781     1    ASTAT,
22782     1    ISUBRO,IBUGA3,IERROR)
22783            YM9(IROW,ICOL)=ASTAT
22784 9515     CONTINUE
22785 9510   CONTINUE
22786C
22787        ITYP9='MATR'
22788        NR9=IROW
22789        NC9=ICOL
22790        IUPFLG='FULL'
22791        GOTO9000
22792C
22793      ELSE
22794C
22795        IF(N2.GE.1)THEN
22796          IF(N2.NE.NR1)THEN
22797            WRITE(ICOUT,999)
22798            CALL DPWRST('XXX','BUG ')
22799            WRITE(ICOUT,9551)
22800 9551       FORMAT('***** ERROR IN MATRIX PARTITION <STATISTIC>--')
22801            CALL DPWRST('XXX','BUG ')
22802            WRITE(ICOUT,9552)N2
22803 9552       FORMAT('      THE NUMBER OF ELEMENTS IN THE ROW VECTOR ',
22804     1             '= ',I8)
22805            CALL DPWRST('XXX','BUG ')
22806            WRITE(ICOUT,9553)NR1
22807 9553       FORMAT('      WHILE THE NUMBER OF ROWS IN THE MATRIX = ',
22808     1             I8)
22809            CALL DPWRST('XXX','BUG ')
22810            IERROR='YES'
22811            GOTO9000
22812          ENDIF
22813          CALL DISTIN(Y2,N2,IWRITE,Y5,NROWPA,IBUGA3,IERROR)
22814          DO9557I=1,NROWPA
22815            DTEMP1(I)=DBLE(Y5(I))
22816 9557     CONTINUE
22817        ELSE
22818          NROWPA=1
22819          DTEMP1(1)=1.0D0
22820          DO9558I=1,NR1
22821            Y2(I)=1.0
22822 9558     CONTINUE
22823        ENDIF
22824C
22825        IF(N3.GE.1)THEN
22826          IF(N3.NE.NC1)THEN
22827            WRITE(ICOUT,999)
22828            CALL DPWRST('XXX','BUG ')
22829            WRITE(ICOUT,9561)
22830 9561       FORMAT('***** ERROR IN MATRIX PARTITION <STATISTIC>--')
22831            CALL DPWRST('XXX','BUG ')
22832            WRITE(ICOUT,9562)N2
22833 9562       FORMAT('      THE NUMBER OF ELEMENTS IN THE COLUMN ',
22834     1             'VECTOR = ',I8)
22835            CALL DPWRST('XXX','BUG ')
22836            WRITE(ICOUT,9563)NC1
22837 9563       FORMAT('      WHILE THE NUMBER OF COLUMNS IN THE ',
22838     1             'MATRIX = ',I8)
22839            CALL DPWRST('XXX','BUG ')
22840            IERROR='YES'
22841            GOTO9000
22842          ENDIF
22843          CALL DISTIN(Y3,N3,IWRITE,Y5,NCOLPA,IBUGA3,IERROR)
22844          DO9567I=1,NCOLPA
22845            DTEMP2(I)=DBLE(Y5(I))
22846 9567     CONTINUE
22847        ELSE
22848          NCOLPA=1
22849          DTEMP2(1)=1.0D0
22850          DO9568I=1,NC1
22851            Y3(I)=1.0
22852 9568     CONTINUE
22853        ENDIF
22854C
22855        DO9571IROW=1,NROWPA
22856          AROW=REAL(DTEMP1(IROW))
22857          DO9572ICOL=1,NCOLPA
22858            ACOL=REAL(DTEMP2(ICOL))
22859C
22860            NTEMP=0
22861            DO9580JJ=1,NC1
22862              DO9590II=1,NR1
22863                IF(AROW.EQ.Y2(II) .AND. ACOL.EQ.Y3(JJ))THEN
22864                  NTEMP=NTEMP+1
22865                  Y1(NTEMP)=YM1(II,JJ)
22866                ENDIF
22867 9590         CONTINUE
22868 9580       CONTINUE
22869            IF(NTEMP.GE.1)THEN
22870              ASTAT=0.0
22871              CALL CMPSTA(
22872     1        Y1,Y5,Y5,YM2(1,1),YM2(1,2),YM2(1,3),MAXNXT,
22873     1        NTEMP,NTEMP,NTEMP,NUMV2,ICASS7,
22874     1        ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
22875     1        DTEMP1,DTEMP2,DTEMP3,
22876CCCCC1        IQUAME,IQUASE,PSTAMV,
22877     1        ASTAT,
22878     1        ISUBRO,IBUGA3,IERROR)
22879              YM9(IROW,ICOL)=ASTAT
22880            ELSE
22881              YM9(IROW,ICOL)=0.0
22882            ENDIF
22883 9572     CONTINUE
22884 9571   CONTINUE
22885C
22886        ITYP9='MATR'
22887        NR9=NROWPA
22888        NC9=NCOLPA
22889        IUPFLG='FULL'
22890        GOTO9000
22891C
22892      ENDIF
22893C
22894C               *****************************************************
22895C               **  STEP 96--                                      **
22896C               **  TREAT THE MATRIX STATISTIC               CASE  **
22897C               *****************************************************
22898C
22899C  THIS COMMAND COMPUTES A SPECIFIED STATISTIC FOR THE ENTIRE MATRIX.
22900C
22901C  NOTE 3/2007: ADD CRAMER CONTINGENCY COEFFICIENT AND
22902C               PEARSON CONTINGENCY COEFFICIENT.  THESE WORK
22903C               DIFFERENTLY THAN THE OTHER STATISTICS IN THAT
22904C               THEY ARE INTERPRETED AS RXC TABLES RATHER THAN
22905C               ONE ARRAY CONTAINING ALL THE MATRIX OBSERVATIONS.
22906C
22907 9600 CONTINUE
22908C
22909      IWRITE='OFF'
22910      MAXNXT=MAXOBV
22911      IF(ICASS7.EQ.'INTE')NUMV2=1
22912C
22913      IF(ICASS7.EQ.'CRAM')THEN
22914         CALL CRAME2(YM1,MAXROM,NR1,NC1,IWRITE,Y1,ASTAT,
22915     1               IBUGA3,IERROR)
22916         GOTO9699
22917      ELSEIF(ICASS7.EQ.'PEAR')THEN
22918         CALL PEARC2(YM1,MAXROM,NR1,NC1,IWRITE,Y1,ASTAT,
22919     1               IBUGA3,IERROR)
22920         GOTO9699
22921      ENDIF
22922C
22923      ICNT=0
22924      DO9610I=1,NC1
22925        DO9620J=1,NR1
22926          ICNT=ICNT+1
22927          IF(ICNT.GT.MAXOBV)THEN
22928            WRITE(ICOUT,999)
22929            CALL DPWRST('XXX','BUG ')
22930            WRITE(ICOUT,9611)
22931 9611       FORMAT('***** ERROR FROM MATRIX STATISTIC--')
22932            CALL DPWRST('XXX','BUG ')
22933            WRITE(ICOUT,9613)MAXOBV
22934 9613       FORMAT('      THE NUMBER OF ELEMENTS IS GREATER THAN ',
22935     1             I10)
22936            CALL DPWRST('XXX','BUG ')
22937            IERROR='YES'
22938            GOTO9000
22939          ENDIF
22940          Y1(ICNT)=YM1(I,J)
22941 9620   CONTINUE
22942 9610 CONTINUE
22943      ASTAT=0.0
22944      CALL CMPSTA(
22945     1    Y1,Y2,Y2,Y3,Y4,Y5,MAXNXT,ICNT,ICNT,ICNT,NUMV2,ICASS7,
22946     1    ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
22947     1    DTEMP1,DTEMP2,DTEMP3,
22948CCCCC1    IQUAME,IQUASE,PSTAMV,
22949     1    ASTAT,
22950     1    ISUBRO,IBUGA3,IERROR)
22951C
22952 9699 CONTINUE
22953      SCAL9=ASTAT
22954      ITYP9='SCAL'
22955      NR9=1
22956      NC9=1
22957      IUPFLG='FULL'
22958      GOTO9000
22959C
22960C               *****************************************************
22961C               **  STEP 97--                                      **
22962C               **  TREAT THE MATRIX BIN                     CASE  **
22963C               *****************************************************
22964C
22965C  THIS COMMAND BINS THE DATA IN A MATRIX (I.E., USEFUL FOR
22966C  GENERATING A HISTOGRAM OF ALL THE POINTS IN THE MATRIX.
22967C
22968 9700 CONTINUE
22969C
22970      IWRITE='OFF'
22971      MAXNXT=MAXOBV
22972C
22973      ICNT=0
22974      DO9710I=1,NC1
22975        DO9720J=1,NR1
22976          ICNT=ICNT+1
22977          IF(ICNT.GT.MAXOBV)THEN
22978            WRITE(ICOUT,999)
22979            CALL DPWRST('XXX','BUG ')
22980            WRITE(ICOUT,9711)
22981 9711       FORMAT('***** ERROR FROM MATRIX STATISTIC--')
22982            CALL DPWRST('XXX','BUG ')
22983            WRITE(ICOUT,9713)MAXOBV
22984 9713       FORMAT('      THE NUMBER OF ELEMENTS IS GREATER THAN ',
22985     1             I10)
22986            CALL DPWRST('XXX','BUG ')
22987            IERROR='YES'
22988            GOTO9000
22989          ENDIF
22990          Y1(ICNT)=YM1(J,I)
22991 9720   CONTINUE
22992 9710 CONTINUE
22993C
22994      CALL DPBIN(Y1,ICNT,IRELAT,CLWID,XSTART,XSTOP,IRHSTG,
22995     1           Y4,MAXNXT,IHSTCW,IHSTOU,
22996     1           Y2,Y3,N2,IBUGA3,IERROR)
22997C
22998      ITYP9='VECT'
22999      NVECT9=N2
23000      IUPFLG='FULL'
23001      DO9760I=1,NVECT9
23002        VECT9(I)=Y2(I)
23003        Y2(I)=Y3(I)
23004 9760 CONTINUE
23005      GOTO9000
23006C
23007C               *****************************************************
23008C               **  STEP 98--                                      **
23009C               **  TREAT THE MINIMAL SPANNING TREE          CASE  **
23010C               **  STEP 1:  CREATE A DISTANCE MATRIX FROM THE     **
23011C               **           TWO INPUT VECTORS (THE (X,Y)          **
23012C               **           COORDINATES)                          **
23013C               **  STEP 2:  CALL MINSPT TO COMPUTE THE EDGES OF   **
23014C               **           THE MINIMAL SPANNING TREE             **
23015C               **  STEP 3:  CONVERT THESE EDGES TO A LIST OF      **
23016C               **           VERTICES THAT CAN BE EASILY PLOTTED   **
23017C               *****************************************************
23018C
23019 9800 CONTINUE
23020C
23021C     STEP 1: COMPUTE A DISTANCE MATRIX
23022C
23023      IF(N1.GT.MAXROM)THEN
23024        WRITE(ICOUT,999)
23025        CALL DPWRST('XXX','BUG ')
23026        WRITE(ICOUT,9801)
23027 9801   FORMAT('***** ERROR IN MATAR3--')
23028        CALL DPWRST('XXX','BUG ')
23029        WRITE(ICOUT,9803)
23030 9803   FORMAT('      FOR THE MINIMAL SPANNING TREE, UNABLE TO COMPUTE')
23031        CALL DPWRST('XXX','BUG ')
23032        WRITE(ICOUT,9805)
23033 9805   FORMAT('      DISTANCE MATRIX (TOO MANY POINTS).')
23034        CALL DPWRST('XXX','BUG ')
23035        WRITE(ICOUT,9806)N1
23036 9806   FORMAT('      THE NUMBER OF VERTICES          = ',I8)
23037        CALL DPWRST('XXX','BUG ')
23038        WRITE(ICOUT,9807)MAXROM
23039 9807   FORMAT('      MAXIMUM NUMBER OF ALLOWED ROWS  =  ',I8,'.')
23040        CALL DPWRST('XXX','BUG ')
23041        IERROR='YES'
23042        GOTO9000
23043      ENDIF
23044C
23045      DO9810I=1,N1
23046        YM1(I,I)=0.0
23047        IF(I.EQ.N1)GOTO9810
23048        AY1=Y1(I)
23049        AX1=Y2(I)
23050        DO9820J=I+1,N1
23051          AY2=Y1(J)
23052          AX2=Y2(J)
23053          ADIST=SQRT((AX1 - AX2)**2 + (AY1 - AY2)**2)
23054          IF(ADIST.LE.0.0)THEN
23055            WRITE(ICOUT,999)
23056            CALL DPWRST('XXX','BUG ')
23057            WRITE(ICOUT,9801)
23058            CALL DPWRST('XXX','BUG ')
23059            WRITE(ICOUT,9823)I,J
23060 9823       FORMAT('      FOR ROW ',I8,' AND COLUMN ',I8,' THE ')
23061            CALL DPWRST('XXX','BUG ')
23062            WRITE(ICOUT,9825)
23063 9825       FORMAT('      COMPUTED DISTANCE IS ZERO.')
23064            CALL DPWRST('XXX','BUG ')
23065            IERROR='YES'
23066            GOTO9000
23067          ENDIF
23068          YM1(I,J)=ADIST
23069          YM1(J,I)=ADIST
23070 9820   CONTINUE
23071 9810   CONTINUE
23072        NR1=N1
23073C
23074C     STEP 2: COMPUTE THE EDGES OF THE MINIMAL SPANNING TREE
23075C
23076      CALL MINSPT(YM1,MAXROM,NR1,ITEMP1,ITEMP2,ITEMP3,Y3)
23077C
23078C     STEP 3: CONVERT TO A LIST OF VERTICES.  NOTE THAT THERE ARE
23079C             N-1 EDGES.  AN EDGE ESSENTIALLY DEFINES TWO VERTICES.
23080C             WE WILL ALSO DEFINED A "TAG" VARIABLE (THIS SIMPLIFIES
23081C             PLOTTING).
23082C
23083      ICNT1=0
23084      DO9830I=1,NR1-1
23085        IINDX1=ITEMP1(I)
23086        IINDX2=ITEMP2(I)
23087        ICNT1=ICNT1+1
23088        Y3(ICNT1)=Y1(IINDX1)
23089        Y4(ICNT1)=Y2(IINDX1)
23090        ICNT1=ICNT1+1
23091        Y3(ICNT1)=Y1(IINDX2)
23092        Y4(ICNT1)=Y2(IINDX2)
23093 9830 CONTINUE
23094      NVECT9=ICNT1
23095C
23096       DO9840I=1,NVECT9
23097         VECT9(I)=Y3(I)
23098         Y2(I)=Y4(I)
23099 9840  CONTINUE
23100C
23101       NTAG=NVECT9/2
23102       ICNT1=0
23103       ICNT2=0
23104       DO9850I=1,NTAG
23105         ICNT2=ICNT2+1
23106         ICNT1=ICNT1+1
23107         Y3(ICNT1)=REAL(ICNT2)
23108         ICNT1=ICNT1+1
23109         Y3(ICNT1)=REAL(ICNT2)
23110 9850  CONTINUE
23111C
23112      ITYP9='VECT'
23113      IUPFLG='FULL'
23114      GOTO9000
23115C
23116C               *****************************************************
23117C               **  STEP 99--                                      **
23118C               **  TREAT THE MINIMAL SPANNING TREE          CASE  **
23119C               **  FOR THIS VARIANT, WE START WITH A DISTANCE     **
23120C               **  MATRIX (RATHER THAN THE VERTICES).  THE        **
23121C               **  DISTANCES MAY IN FACT REFLECT "COSTS" OR       **
23122C               **  "WEIGHTINGS" AS OPPOSSED TO ACTUAL DISTANCES.  **
23123C               **  IN THIS CASE, THE RETURNED OUTPUT IS THE       **
23124C               **  LIST OF EDGES (I.E., WE DO NOT CONVERT BACK    **
23125C               **  TO ORIGINAL VERTICES).                         **
23126C               *****************************************************
23127C
23128 9900 CONTINUE
23129C
23130C     STEP 1: CHECK FOR A SQUARE MATRIX
23131C
23132      IF(NR1.NE.NC1)THEN
23133        WRITE(ICOUT,999)
23134        CALL DPWRST('XXX','BUG ')
23135        WRITE(ICOUT,9901)
23136 9901   FORMAT('***** ERROR IN MATARI--')
23137        CALL DPWRST('XXX','BUG ')
23138        WRITE(ICOUT,9902)
23139 9902   FORMAT('      FOR MINIMUM SPANNING TREE, THE NUMBER OF ROWS')
23140        CALL DPWRST('XXX','BUG ')
23141        WRITE(ICOUT,9903)
23142 9903   FORMAT('      IN THE MATRIX MUST EQUAL THE NUMBER OF COLUMNS')
23143        CALL DPWRST('XXX','BUG ')
23144        WRITE(ICOUT,9905)
23145 9905   FORMAT('      IN THE MATRIX;  SUCH WAS NOT THE CASE HERE.')
23146        CALL DPWRST('XXX','BUG ')
23147        WRITE(ICOUT,9907)NR1
23148 9907   FORMAT('            NUMBER OF ROWS    =',I8)
23149        CALL DPWRST('XXX','BUG ')
23150        WRITE(ICOUT,9908)NC1
23151 9908   FORMAT('            NUMBER OF COLUMNS =',I8)
23152        CALL DPWRST('XXX','BUG ')
23153        IERROR='YES'
23154        GOTO9000
23155      ENDIF
23156C
23157C     STEP 2: CHECK FOR A VALID DISTANCE MATRIX
23158C
23159C             A) DIAGONAL ELEMENTS SHOULD BE ZERO
23160C             B) ALL NON-DIAGONAL ELEMENTS SHOULD BE NON-ZERO
23161C             C) DIST(I,J) = DIST(J,I)
23162C
23163C
23164      DO9910I=1,N1
23165C
23166        IF(ABS(YM1(I,I)).GT.0.1E-12)THEN
23167          WRITE(ICOUT,999)
23168          CALL DPWRST('XXX','BUG ')
23169          WRITE(ICOUT,9901)
23170          CALL DPWRST('XXX','BUG ')
23171          WRITE(ICOUT,9913)
23172 9913     FORMAT('      FOR THE MINIMAL SPANNING TREE, A DIAGONAL')
23173          CALL DPWRST('XXX','BUG ')
23174          WRITE(ICOUT,9915)
23175 9915     FORMAT('      ELEMENT OF THE DISTANCE MATRIX IS NON-ZERO.')
23176          CALL DPWRST('XXX','BUG ')
23177          WRITE(ICOUT,9917)I,YM1(I,I)
23178 9917     FORMAT('      THE VALUE OF ROW ',I8,'  = ',G15.7)
23179          CALL DPWRST('XXX','BUG ')
23180          IERROR='YES'
23181          GOTO9000
23182        ENDIF
23183C
23184        DO9920J=I+1,N1
23185          IF(YM1(I,J).LE.0.0)THEN
23186            WRITE(ICOUT,999)
23187            CALL DPWRST('XXX','BUG ')
23188            WRITE(ICOUT,9901)
23189            CALL DPWRST('XXX','BUG ')
23190            WRITE(ICOUT,9921)I,J
23191 9921       FORMAT('      ROW ',I8,' AND COLUMN ',I8,' OF THE ')
23192            CALL DPWRST('XXX','BUG ')
23193            WRITE(ICOUT,9923)
23194 9923       FORMAT('      DISTANCE MATRIX IS NON-POSITIVE.')
23195            CALL DPWRST('XXX','BUG ')
23196            WRITE(ICOUT,9925)
23197 9925       FORMAT('      THE VALUE IS ',G15.7)
23198            CALL DPWRST('XXX','BUG ')
23199            IERROR='YES'
23200            GOTO9000
23201          ELSEIF(YM1(I,J).NE.YM1(J,I))THEN
23202            WRITE(ICOUT,999)
23203            CALL DPWRST('XXX','BUG ')
23204            WRITE(ICOUT,9901)
23205            CALL DPWRST('XXX','BUG ')
23206            WRITE(ICOUT,9931)
23207 9931       FORMAT('      THE DISTANCE MATRIX IS NOT SYMMETRIC.')
23208            CALL DPWRST('XXX','BUG ')
23209            WRITE(ICOUT,9933)I,J,YM1(I,J)
23210 9933       FORMAT('      ROW ',I8,' COLUMN ',I8,'  = ',G15.7)
23211            CALL DPWRST('XXX','BUG ')
23212            WRITE(ICOUT,9933)J,I,YM1(J,I)
23213            CALL DPWRST('XXX','BUG ')
23214            IERROR='YES'
23215            GOTO9000
23216          ENDIF
23217 9920   CONTINUE
23218 9910   CONTINUE
23219        NR1=N1
23220C
23221C     STEP 3: COMPUTE THE EDGES OF THE MINIMAL SPANNING TREE
23222C
23223      CALL MINSPT(YM1,MAXROM,NR1,ITEMP1,ITEMP2,ITEMP3,Y3)
23224C
23225C     STEP 3: CONVERT TO A LIST OF VERTICES.  NOTE THAT THERE ARE
23226C             N-1 EDGES.  AN EDGE ESSENTIALLY DEFINES TWO VERTICES.
23227C             WE WILL ALSO DEFINED A "TAG" VARIABLE (THIS SIMPLIFIES
23228C             PLOTTING).
23229C
23230      NVECT9=NR1-1
23231      DO9950I=1,NVECT9
23232        VECT9(I)=REAL(ITEMP1(I))
23233        Y2(I)=REAL(ITEMP2(I))
23234 9950 CONTINUE
23235C
23236      ITYP9='VECT'
23237      IUPFLG='FULL'
23238      GOTO9000
23239C
23240C               *****************************************************
23241C               **  STEP 10000--                                   **
23242C               **  TREAT THE MATRIX RENUMBER                CASE  **
23243C               *****************************************************
23244C
23245C  THIS COMMAND REORDERS THE ROWS (BASED ON Y2) AND COLUMNS
23246C  (BASED ON Y3) OF A MATRIX.
23247C
2324810000 CONTINUE
23249C
23250      IWRITE='OFF'
23251C
23252C     STEP 1: CHECK Y2 AND Y3
23253C
23254      IF(N2.NE.NR1)THEN
23255        WRITE(ICOUT,999)
23256        CALL DPWRST('XXX','BUG ')
23257        WRITE(ICOUT,10001)
2325810001   FORMAT('***** ERROR FROM MATRIX RENUMBER--')
23259        CALL DPWRST('XXX','BUG ')
23260        WRITE(ICOUT,10003)
2326110003   FORMAT('      THE NUMBER OF ELEMENTS IN THE ROW ',
23262     1         'PERMUATION VECTOR')
23263        CALL DPWRST('XXX','BUG ')
23264        WRITE(ICOUT,10005)
2326510005   FORMAT('      IS NOT EQUAL TO THE NUMBER OF ROWS IN ',
23266     1         'THE MATRIX.')
23267        CALL DPWRST('XXX','BUG ')
23268        WRITE(ICOUT,10007)N2
2326910007   FORMAT('      NUMBER OF ELEMENTS IN THE ROW PERMUATION ',
23270     1         'VECTOR    = ',I8)
23271        CALL DPWRST('XXX','BUG ')
23272        WRITE(ICOUT,10009)NR1
2327310009   FORMAT('      NUMBER OF ROWS IN THE MATRIX             ',
23274     1         '          = ',I8)
23275        CALL DPWRST('XXX','BUG ')
23276        IERROR='YES'
23277        GOTO9000
23278      ENDIF
23279C
23280      DO10010I=1,N2
23281        ITEMP1(I)=INT(Y2(I)+0.1)
23282        Y4(I)=REAL(ITEMP1(I))
2328310010 CONTINUE
23284      CALL DISTIN(Y4,N2,IWRITE,Y5,NDIST,IBUGA3,IERROR)
23285      CALL MINIM(Y4,N2,IWRITE,XMIN,IBUGA3,IERROR)
23286      CALL MAXIM(Y4,N2,IWRITE,XMAX,IBUGA3,IERROR)
23287C
23288      IF(N2.NE.NDIST)THEN
23289CCCCC   WRITE(ICOUT,999)
23290CCCCC   CALL DPWRST('XXX','BUG ')
23291CCCCC   WRITE(ICOUT,10001)
23292CCCCC   CALL DPWRST('XXX','BUG ')
23293CCCCC   WRITE(ICOUT,10013)
23294C10013   FORMAT('      THE VALUES IN THE ROW PERMUTATION ',
23295CCCCC1         'VECTOR ARE NOT ALL UNIQUE.')
23296CCCCC   CALL DPWRST('XXX','BUG ')
23297CCCCC   IERROR='YES'
23298CCCCC   GOTO9000
23299      ELSEIF(XMIN.LT.1.0)THEN
23300        WRITE(ICOUT,999)
23301        CALL DPWRST('XXX','BUG ')
23302        WRITE(ICOUT,10001)
23303        CALL DPWRST('XXX','BUG ')
23304        WRITE(ICOUT,10023)
2330510023   FORMAT('      THE MINIMUM VALUE IN THE ROW PERMUTATION ',
23306     1         'VECTOR')
23307        CALL DPWRST('XXX','BUG ')
23308        WRITE(ICOUT,10025)
2330910025   FORMAT('      IS LESS THAN ONE.')
23310        CALL DPWRST('XXX','BUG ')
23311        WRITE(ICOUT,10027)XMIN
2331210027   FORMAT('      THE MINIMUM VALUE IS ',G15.7)
23313        CALL DPWRST('XXX','BUG ')
23314        IERROR='YES'
23315        GOTO9000
23316      ELSEIF(XMAX.GT.REAL(N2))THEN
23317        WRITE(ICOUT,999)
23318        CALL DPWRST('XXX','BUG ')
23319        WRITE(ICOUT,10001)
23320        CALL DPWRST('XXX','BUG ')
23321        WRITE(ICOUT,10033)
2332210033   FORMAT('      THE MAXIMUM VALUE IN THE ROW PERMUTATION ',
23323     1         'VECTOR')
23324        CALL DPWRST('XXX','BUG ')
23325        WRITE(ICOUT,10035)
2332610035   FORMAT('      IS GREATER THAN THE NUMBER OF ELEMENTS.')
23327        CALL DPWRST('XXX','BUG ')
23328        WRITE(ICOUT,10037)XMAX
2332910037   FORMAT('      THE MAXIMUM VALUE IS      ',G15.7)
23330        CALL DPWRST('XXX','BUG ')
23331        WRITE(ICOUT,10038)N2
2333210038   FORMAT('      THE NUMBER OF ELEMENTS IS ',I8)
23333        CALL DPWRST('XXX','BUG ')
23334        IERROR='YES'
23335        GOTO9000
23336      ENDIF
23337C
23338      IF(N3.NE.NC1)THEN
23339        WRITE(ICOUT,999)
23340        CALL DPWRST('XXX','BUG ')
23341        WRITE(ICOUT,10001)
23342        CALL DPWRST('XXX','BUG ')
23343        WRITE(ICOUT,10043)
2334410043   FORMAT('      THE NUMBER OF ELEMENTS IN THE COLUMN ',
23345     1         'PERMUATION VECTOR')
23346        CALL DPWRST('XXX','BUG ')
23347        WRITE(ICOUT,10045)
2334810045   FORMAT('      IS NOT EQUAL TO THE NUMBER OF COLUMNS IN ',
23349     1         'THE MATRIX.')
23350        CALL DPWRST('XXX','BUG ')
23351        WRITE(ICOUT,10047)N3
2335210047   FORMAT('      NUMBER OF ELEMENTS IN THE COLUMN PERMUATION ',
23353     1         'VECTOR    = ',I8)
23354        CALL DPWRST('XXX','BUG ')
23355        WRITE(ICOUT,10049)NC1
2335610049   FORMAT('      NUMBER OF COLUMNS IN THE MATRIX             ',
23357     1         '          = ',I8)
23358        CALL DPWRST('XXX','BUG ')
23359        IERROR='YES'
23360        GOTO9000
23361      ENDIF
23362C
23363      DO10050I=1,N3
23364        ITEMP2(I)=INT(Y3(I)+0.1)
23365        Y4(I)=REAL(ITEMP2(I))
2336610050 CONTINUE
23367      CALL DISTIN(Y4,N3,IWRITE,Y5,NDIST,IBUGA3,IERROR)
23368      CALL MINIM(Y4,N3,IWRITE,XMIN,IBUGA3,IERROR)
23369      CALL MAXIM(Y4,N3,IWRITE,XMAX,IBUGA3,IERROR)
23370C
23371      IF(N3.NE.NDIST)THEN
23372CCCCC   WRITE(ICOUT,999)
23373CCCCC   CALL DPWRST('XXX','BUG ')
23374CCCCC   WRITE(ICOUT,10001)
23375CCCCC   CALL DPWRST('XXX','BUG ')
23376CCCCC   WRITE(ICOUT,10053)
23377C10053   FORMAT('      THE VALUES IN THE COLUMN PERMUTATION ',
23378CCCCC1         'VECTOR ARE NOT ALL UNIQUE.')
23379CCCCC   CALL DPWRST('XXX','BUG ')
23380CCCCC   IERROR='YES'
23381CCCCC   GOTO9000
23382      ELSEIF(XMIN.LT.1.0)THEN
23383        WRITE(ICOUT,999)
23384        CALL DPWRST('XXX','BUG ')
23385        WRITE(ICOUT,10001)
23386        CALL DPWRST('XXX','BUG ')
23387        WRITE(ICOUT,10063)
2338810063   FORMAT('      THE MINIMUM VALUE IN THE COLUMN PERMUTATION ',
23389     1         'VECTOR')
23390        CALL DPWRST('XXX','BUG ')
23391        WRITE(ICOUT,10065)
2339210065   FORMAT('      IS LESS THAN ONE.')
23393        CALL DPWRST('XXX','BUG ')
23394        WRITE(ICOUT,10067)XMIN
2339510067   FORMAT('      THE MINIMUM VALUE IS ',G15.7)
23396        CALL DPWRST('XXX','BUG ')
23397        IERROR='YES'
23398        GOTO9000
23399      ELSEIF(XMAX.GT.REAL(N3))THEN
23400        WRITE(ICOUT,999)
23401        CALL DPWRST('XXX','BUG ')
23402        WRITE(ICOUT,10001)
23403        CALL DPWRST('XXX','BUG ')
23404        WRITE(ICOUT,10073)
2340510073   FORMAT('      THE MAXIMUM VALUE IN THE ROW PERMUTATION ',
23406     1         'VECTOR')
23407        CALL DPWRST('XXX','BUG ')
23408        WRITE(ICOUT,10075)
2340910075   FORMAT('      IS GREATER THAN THE NUMBER OF ELEMENTS.')
23410        CALL DPWRST('XXX','BUG ')
23411        WRITE(ICOUT,10077)XMAX
2341210077   FORMAT('      THE MAXIMUM VALUE IS      ',G15.7)
23413        CALL DPWRST('XXX','BUG ')
23414        WRITE(ICOUT,10078)N2
2341510078   FORMAT('      THE NUMBER OF ELEMENTS IS ',I8)
23416        CALL DPWRST('XXX','BUG ')
23417        IERROR='YES'
23418        GOTO9000
23419      ENDIF
23420C
23421      DO10081I=1,NR1
23422        DO10082J=1,NC1
23423          IROW=ITEMP1(I)
23424          ICOL=ITEMP2(J)
23425          YM9(IROW,ICOL)=YM1(I,J)
2342610082   CONTINUE
2342710081 CONTINUE
23428C
23429      ITYP9='MATR'
23430      NR9=NR1
23431      NC9=NC1
23432      IUPFLG='FULL'
23433      GOTO9000
23434C
23435C               *****************************************************
23436C               **  STEP 10100--                                   **
23437C               **  TREAT THE ADJACENCY MATRIX               CASE  **
23438C               *****************************************************
23439C
23440C  THIS COMMAND CREATES AN ADJACENCY MATRIX FROM A LIST OF EDGES.
23441C
2344210100 CONTINUE
23443C
23444      IWRITE='OFF'
23445      NVERT=INT(YS3+0.1)
23446      NVERT=MAX(NVERT,N1)
23447      NVERT=MAX(NVERT,N2)
23448C
23449C     STEP 1: CHECK TO SEE IF THE MATRIX WILL FIT
23450C
23451      IF(NVERT.GT.MAXROM)THEN
23452        WRITE(ICOUT,999)
23453        CALL DPWRST('XXX','BUG ')
23454        WRITE(ICOUT,10101)
2345510101   FORMAT('***** ERROR FROM ADJACENCY MATRIX--')
23456        CALL DPWRST('XXX','BUG ')
23457        WRITE(ICOUT,10103)
2345810103   FORMAT('      THE NUMBER OF VERTICES EXCEEDS THE ',
23459     1         'MAXIMUM')
23460        CALL DPWRST('XXX','BUG ')
23461        WRITE(ICOUT,10105)
2346210105   FORMAT('      NUMBER OF ROWS FOR A MATRIX.')
23463        CALL DPWRST('XXX','BUG ')
23464        WRITE(ICOUT,10107)NVERT
2346510107   FORMAT('      THE NUMBER OF VERTICES                 = ',I8)
23466        CALL DPWRST('XXX','BUG ')
23467        WRITE(ICOUT,10109)MAXROM
2346810109   FORMAT('      THE MAXIMUM NUMBER OF ROWS IN A MATRIX = ',I8)
23469        CALL DPWRST('XXX','BUG ')
23470        IERROR='YES'
23471        GOTO9000
23472      ENDIF
23473C
23474      IF(NVERT.GT.MAXCOM)THEN
23475        WRITE(ICOUT,999)
23476        CALL DPWRST('XXX','BUG ')
23477        WRITE(ICOUT,10101)
23478        CALL DPWRST('XXX','BUG ')
23479        WRITE(ICOUT,10113)
2348010113   FORMAT('      THE NUMBER OF VERTICES EXCEEDS THE ',
23481     1         'MAXIMUM')
23482        CALL DPWRST('XXX','BUG ')
23483        WRITE(ICOUT,10115)
2348410115   FORMAT('      NUMBER OF COLUMNS FOR A MATRIX.')
23485        CALL DPWRST('XXX','BUG ')
23486        WRITE(ICOUT,10117)NVERT
2348710117   FORMAT('      THE NUMBER OF VERTICES                    = ',I8)
23488        CALL DPWRST('XXX','BUG ')
23489        WRITE(ICOUT,10119)MAXROM
2349010119   FORMAT('      THE MAXIMUM NUMBER OF COLUMNS IN A MATRIX = ',I8)
23491        CALL DPWRST('XXX','BUG ')
23492        IERROR='YES'
23493        GOTO9000
23494      ENDIF
23495C
23496C     STEP 2: NOW CREATE THE ADJACENCY MATRIX
23497C
23498C
23499      DO10120J=1,N1
23500        DO10130I=1,N1
23501          YM9(I,J)=0.0
2350210130   CONTINUE
2350310120 CONTINUE
23504C
23505      DO10140I=1,N1
23506        IROW=INT(Y1(I)+0.1)
23507C
23508        IF(IROW.LT.1 .OR. IROW.GT.NVERT)THEN
23509          WRITE(ICOUT,999)
23510          CALL DPWRST('XXX','BUG ')
23511          WRITE(ICOUT,10101)
23512          CALL DPWRST('XXX','BUG ')
23513          WRITE(ICOUT,10143)I
2351410143     FORMAT('      FOR EDGE ',I8,' THE ROW INDEX IS OUT OF')
23515          CALL DPWRST('XXX','BUG ')
23516          WRITE(ICOUT,10145)IROW
2351710145     FORMAT('      ROW INDEX = ',I8)
23518          CALL DPWRST('XXX','BUG ')
23519          IERROR='YES'
23520          GOTO9000
23521        ENDIF
23522C
23523        ICOL=INT(Y2(I)+0.1)
23524C
23525        IF(ICOL.LT.1 .OR. ICOL.GT.NVERT)THEN
23526          WRITE(ICOUT,999)
23527          CALL DPWRST('XXX','BUG ')
23528          WRITE(ICOUT,10101)
23529          CALL DPWRST('XXX','BUG ')
23530          WRITE(ICOUT,10153)I
2353110153     FORMAT('      FOR EDGE ',I8,' THE COLUMN INDEX IS OUT OF ',
23532     1           'RANGE.')
23533          CALL DPWRST('XXX','BUG ')
23534          WRITE(ICOUT,10155)ICOL
2353510155     FORMAT('      COLUMN INDEX = ',I8)
23536          CALL DPWRST('XXX','BUG ')
23537          IERROR='YES'
23538          GOTO9000
23539        ENDIF
23540C
23541        YM9(IROW,ICOL)=1.0
23542        IF(IMCASE.EQ.'ADMA')YM9(ICOL,IROW)=1.0
2354310140 CONTINUE
23544C
23545      ITYP9='MATR'
23546      NR9=NVERT
23547      NC9=NVERT
23548      IUPFLG='FULL'
23549      GOTO9000
23550C
23551C               ************************************************
23552C               **  STEP 10200--                              **
23553C               **  TREAT THE MATRIX ROW FIT       CASE       **
23554C               **  PERFORM A FIT OF EACH ROW OF THE MATRIX   **
23555C               **  AGAINST A COMMON X VARIABLE.  RIGHT NOW,  **
23556C               **  LIMIT TO LINEAR FIT (BUT MAYBE ADD        **
23557C               **  QUADRATIC FIT IN FUTURE).                 **
23558C               ************************************************
23559C
23560CCCCC IMPLEMENTED FEBRUARY 2010.
2356110200 CONTINUE
23562C
23563      IF(N2.NE.NC1)THEN
23564        WRITE(ICOUT,999)
23565        CALL DPWRST('XXX','BUG ')
23566        WRITE(ICOUT,10201)
2356710201   FORMAT('****** ERROR IN MATRIX ROW FIT--')
23568        CALL DPWRST('XXX','BUG ')
23569        WRITE(ICOUT,10202)NC1
2357010202   FORMAT('      THE NUMBER OF COLUMNS IN THE MATRIX (',I8,') ',
23571     1         'IS NOT EQUAL')
23572        CALL DPWRST('XXX','BUG ')
23573        WRITE(ICOUT,10203)N1
2357410203   FORMAT('      THE NUMBER OF ROWS IN THE X VARIABLE (',I8,').')
23575        CALL DPWRST('XXX','BUG ')
23576        IERROR='YES'
23577        GOTO9000
23578      ENDIF
23579C
23580      DO10210I=1,NR1
23581        DO10220J=1,NC1
23582          Y3(J)=YM1(I,J)
2358310220   CONTINUE
23584        ICNT=0
23585        DO10230J=1,NC1
23586          IF(Y3(J).EQ.PSTAMV)GOTO10230
23587          ICNT=ICNT+1
23588          Y4(ICNT)=Y2(J)
23589          Y3(ICNT)=Y3(J)
2359010230   CONTINUE
23591        NPTS=ICNT
23592        IF(NPTS.LE.0)THEN
23593          PPA0=PSTAMV
23594          PPA1=PSTAMV
23595          PPA0SD=PSTAMV
23596          PPA1SD=PSTAMV
23597        ELSE
23598          CALL LINFIT(Y3,Y4,NPTS,
23599     1                PPA0,PPA1,XRESSD,XRESDF,PPCC,SDPPA0,SDPPA1,CCALBE,
23600     1                ISUBRO,IBUGA3,IERROR)
23601        ENDIF
23602        YM9(I,1)=PPA0
23603        YM9(I,2)=PPA1
23604        YM9(I,3)=SDPPA0
23605        YM9(I,4)=SDPPA1
2360610210 CONTINUE
23607C
23608      ITYP9='VECT'
23609      NR9=1
23610      NC9=1
23611      DO10240I=1,NR1
23612        VECT9(I)=YM9(I,1)
23613        Y2(I)=YM9(I,2)
23614        Y3(I)=YM9(I,3)
23615        Y4(I)=YM9(I,4)
2361610240 CONTINUE
23617      NVECT9=NR1
23618      IUPFLG='FULL'
23619      GOTO9000
23620C
23621C               *************************************************
23622C               **  STEP 10300--                               **
23623C               **  TREAT THE MATRIX COLUMN FIT       CASE     **
23624C               **  PERFORM A FIT OF EACH COLUMN OF THE MATRIX **
23625C               **  AGAINST A COMMON X VARIABLE.  RIGHT NOW,   **
23626C               **  LIMIT TO LINEAR FIT (BUT MAYBE ADD         **
23627C               **  QUADRATIC FIT IN FUTURE).                  **
23628C               *************************************************
23629C
23630CCCCC IMPLEMENTED FEBRUARY 2010.
2363110300 CONTINUE
23632C
23633      IF(N2.NE.NR1)THEN
23634        WRITE(ICOUT,999)
23635        CALL DPWRST('XXX','BUG ')
23636        WRITE(ICOUT,10301)
2363710301   FORMAT('****** ERROR IN MATRIX COLUMN FIT--')
23638        CALL DPWRST('XXX','BUG ')
23639        WRITE(ICOUT,10302)NR1
2364010302   FORMAT('      THE NUMBER OF ROWS IN THE MATRIX (',I8,') ',
23641     1         'IS NOT EQUAL')
23642        CALL DPWRST('XXX','BUG ')
23643        WRITE(ICOUT,10303)N1
2364410303   FORMAT('      THE NUMBER OF ROWS IN THE X VARIABLE (',I8,').')
23645        CALL DPWRST('XXX','BUG ')
23646        IERROR='YES'
23647        GOTO9000
23648      ENDIF
23649C
23650      DO10310I=1,NC1
23651        DO10320J=1,NR1
23652          Y3(J)=YM1(J,I)
2365310320   CONTINUE
23654        ICNT=0
23655        DO10330J=1,NR1
23656          IF(Y3(J).EQ.PSTAMV)GOTO10330
23657          ICNT=ICNT+1
23658          Y4(ICNT)=Y2(J)
23659          Y3(ICNT)=Y3(J)
2366010330   CONTINUE
23661        NPTS=ICNT
23662        IF(NPTS.LE.0)THEN
23663          PPA0=PSTAMV
23664          PPA1=PSTAMV
23665          PPA0SD=PSTAMV
23666          PPA1SD=PSTAMV
23667        ELSE
23668          CALL LINFIT(Y3,Y4,NPTS,
23669     1                PPA0,PPA1,XRESSD,XRESDF,PPCC,SDPPA0,SDPPA1,CCALBE,
23670     1                ISUBRO,IBUGA3,IERROR)
23671        ENDIF
23672        YM9(I,1)=PPA0
23673        YM9(I,2)=PPA1
23674        YM9(I,3)=SDPPA0
23675        YM9(I,4)=SDPPA1
2367610310 CONTINUE
23677C
23678      ITYP9='VECT'
23679      NR9=1
23680      NC9=1
23681      DO10340I=1,NC1
23682        VECT9(I)=YM9(I,1)
23683        Y2(I)=YM9(I,2)
23684        Y3(I)=YM9(I,3)
23685        Y4(I)=YM9(I,4)
2368610340 CONTINUE
23687      NVECT9=NC1
23688      IUPFLG='FULL'
23689      GOTO9000
23690C
23691C               *************************************************
23692C               **  STEP 10400--                               **
23693C               **  TREAT THE VARIABLE TO MATRIX      CASE     **
23694C               *************************************************
23695C
23696CCCCC IMPLEMENTED NOVEMBER 2010.
2369710400 CONTINUE
23698C
23699      NROW=INT(YS2+0.1)
23700      NCOL=N1/NROW
23701      NREM=N1 - (NROW*NCOL)
23702      IF(NREM.GT.0)NCOL=NCOL+1
23703C
23704      IF(NROW.GT.MAXROM)THEN
23705        WRITE(ICOUT,999)
23706        CALL DPWRST('XXX','BUG ')
23707        WRITE(ICOUT,10401)
2370810401   FORMAT('****** ERROR IN VARIABLE TO MATRIX--')
23709        CALL DPWRST('XXX','BUG ')
23710        WRITE(ICOUT,10402)NROW
2371110402   FORMAT('      THE REQUESTED NUMBER OF ROWS FOR THE MATRIX (',
23712     1         I8,') ','IS TOO LARGE.')
23713        CALL DPWRST('XXX','BUG ')
23714        WRITE(ICOUT,10403)MAXROM
2371510403   FORMAT('      THE MAXIMUM NUMBER  OF ROWS   = (',I8,').')
23716        CALL DPWRST('XXX','BUG ')
23717        IERROR='YES'
23718        GOTO9000
23719      ENDIF
23720C
23721      IF(NCOL.GT.MAXCOM)THEN
23722        WRITE(ICOUT,999)
23723        CALL DPWRST('XXX','BUG ')
23724        WRITE(ICOUT,10411)
2372510411   FORMAT('****** ERROR IN VARIABLE TO MATRIX--')
23726        CALL DPWRST('XXX','BUG ')
23727        WRITE(ICOUT,10412)NCOL
2372810412   FORMAT('      THE REQUESTED NUMBER OF COLUMNS FOR THE MATRIX (',
23729     1         I8,') ','IS TOO LARGE.')
23730        CALL DPWRST('XXX','BUG ')
23731        WRITE(ICOUT,10413)MAXCOM
2373210413   FORMAT('      THE MAXIMUM NUMBER  OF COLUMNS   = (',I8,').')
23733        CALL DPWRST('XXX','BUG ')
23734        IERROR='YES'
23735        GOTO9000
23736      ENDIF
23737C
23738      IF(IVARMA.EQ.'COLU')THEN
23739        ICNT=0
23740        DO10420J=1,NCOL
23741          DO10430I=1,NROW
23742            ICNT=ICNT+1
23743            IF(ICNT.LE.N1)THEN
23744              YM9(I,J)=Y1(ICNT)
23745            ELSE
23746              YM9(I,J)=PSTAMV
23747            ENDIF
2374810430     CONTINUE
2374910420   CONTINUE
23750      ELSE
23751        ICNT=0
23752        DO10470I=1,NROW
23753          DO10480J=1,NCOL
23754            ICNT=ICNT+1
23755            IF(ICNT.LE.N1)THEN
23756              YM9(I,J)=Y1(ICNT)
23757            ELSE
23758              YM9(I,J)=PSTAMV
23759            ENDIF
2376010480     CONTINUE
2376110470   CONTINUE
23762      ENDIF
23763C
23764      ITYP9='MATR'
23765      NR9=NROW
23766      NC9=NCOL
23767      IUPFLG='FULL'
23768      GOTO9000
23769C
23770C               *************************************************
23771C               **  STEP 10500--                               **
23772C               **  TREAT THE MATRIX TO VARIABLE CASE          **
23773C               *************************************************
23774C
23775CCCCC IMPLEMENTED NOVEMBER 2010.
2377610500 CONTINUE
23777C
23778      IF(IMATVA.EQ.'COLU')THEN
23779        ICNT=0
23780        DO10520J=1,NC1
23781          DO10530I=1,NR1
23782            ICNT=ICNT+1
23783            IF(ICNT.LE.MAXOBV)THEN
23784              VECT9(ICNT)=YM1(I,J)
23785            ELSE
23786              WRITE(ICOUT,999)
23787              CALL DPWRST('XXX','BUG ')
23788              WRITE(ICOUT,10501)
2378910501         FORMAT('****** ERROR IN MATRIX TO VARIABLE--')
23790              CALL DPWRST('XXX','BUG ')
23791              WRITE(ICOUT,10502)MAXOBV
2379210502         FORMAT('      MAXIMUM NUMBER OF ROWS IN VARIABLE (',
23793     1               I8,') EXCEEDED.')
23794              CALL DPWRST('XXX','BUG ')
23795              IERROR='YES'
23796              GOTO9000
23797            ENDIF
2379810530     CONTINUE
2379910520   CONTINUE
23800      ELSE
23801        ICNT=0
23802        DO10570I=1,NR1
23803          DO10580J=1,NC1
23804            ICNT=ICNT+1
23805            IF(ICNT.LE.MAXOBV)THEN
23806              VECT9(ICNT)=YM1(I,J)
23807            ELSE
23808              WRITE(ICOUT,999)
23809              CALL DPWRST('XXX','BUG ')
23810              WRITE(ICOUT,10501)
23811              CALL DPWRST('XXX','BUG ')
23812              WRITE(ICOUT,10502)MAXOBV
23813              CALL DPWRST('XXX','BUG ')
23814              IERROR='YES'
23815              GOTO9000
23816            ENDIF
2381710580     CONTINUE
2381810570   CONTINUE
23819      ENDIF
23820C
23821      ITYP9='VECT'
23822      NVECT9=ICNT
23823      IUPFLG='FULL'
23824      GOTO9000
23825C
23826C               *****************************************************
23827C               **  STEP 10600-                                    **
23828C               **  TREAT THE MATRIX COMBINE ROW             CASE  **
23829C               *****************************************************
23830C
2383110600 CONTINUE
23832C
23833      IF(NC1.NE.NC2)THEN
23834        WRITE(ICOUT,999)
23835        CALL DPWRST('XXX','BUG ')
23836        WRITE(ICOUT,10611)
2383710611   FORMAT('***** ERROR IN MATRIX COMBINE ROW--')
23838        CALL DPWRST('XXX','BUG ')
23839        WRITE(ICOUT,10613)
2384010613   FORMAT('      THE NUMBER OF COLUMNS IN THE TWO MATRICES IS ',
23841     1         'NOT EQUAL.')
23842        CALL DPWRST('XXX','BUG ')
23843        WRITE(ICOUT,10615)NC1
2384410615   FORMAT('      THE NUMBER OF COLUMNS FOR THE FIRST  MATRIX: ',
23845     1         I8)
23846        CALL DPWRST('XXX','BUG ')
23847        WRITE(ICOUT,10617)NC2
2384810617   FORMAT('      THE NUMBER OF COLUMNS FOR THE SECOND MATRIX: ',
23849     1         I8)
23850        CALL DPWRST('XXX','BUG ')
23851        IERROR='YES'
23852        GOTO9000
23853      ENDIF
23854C
23855      DO10610J=1,NC1
23856         DO10620I=1,NR1
23857           YM9(I,J)=YM1(I,J)
2385810620    CONTINUE
23859         DO10630I=1,NR2
23860           IINDX=I+NR1
23861           IF(IINDX.GT.MAXROM)THEN
23862             WRITE(ICOUT,999)
23863             CALL DPWRST('XXX','BUG ')
23864             WRITE(ICOUT,10611)
23865             CALL DPWRST('XXX','BUG ')
23866             WRITE(ICOUT,10633)
2386710633        FORMAT('      THE MAXIMUM NUMBER OF ROWS FOR THE ',
23868     1              'OUTPUT MATRIX HAS BEEN EXCEEDED.')
23869             CALL DPWRST('XXX','BUG ')
23870             WRITE(ICOUT,10635)MAXROM
2387110635        FORMAT('      THE MAXIMUM NUMBER OF ROWS  = ',I8)
23872             CALL DPWRST('XXX','BUG ')
23873             WRITE(ICOUT,10637)NR1+NR2
2387410637        FORMAT('      THE REQUIRED NUMBER OF ROWS = ',I8)
23875             CALL DPWRST('XXX','BUG ')
23876             IERROR='YES'
23877             GOTO9000
23878           ENDIF
23879           YM9(I+NR1,J)=YM2(I,J)
2388010630    CONTINUE
2388110610 CONTINUE
23882C
23883      ITYP9='MATR'
23884      NC9=NC1
23885      NR9=NR1+NR2
23886      IUPFLG='FULL'
23887      GOTO9000
23888C
23889C               *****************************************************
23890C               **  STEP 10700-                                    **
23891C               **  TREAT THE MATRIX COMBINE COLUMN          CASE  **
23892C               *****************************************************
23893C
2389410700 CONTINUE
23895C
23896      IF(NR1.NE.NR2)THEN
23897        WRITE(ICOUT,999)
23898        CALL DPWRST('XXX','BUG ')
23899        WRITE(ICOUT,10711)
2390010711   FORMAT('***** ERROR IN MATRIX COMBINE COLUMN--')
23901        CALL DPWRST('XXX','BUG ')
23902        WRITE(ICOUT,10713)
2390310713   FORMAT('      THE NUMBER OF ROWS IN THE TWO MATRICES IS ',
23904     1         'NOT EQUAL.')
23905        CALL DPWRST('XXX','BUG ')
23906        WRITE(ICOUT,10715)NR1
2390710715   FORMAT('      THE NUMBER OF ROWS FOR THE FIRST  MATRIX: ',
23908     1         I8)
23909        CALL DPWRST('XXX','BUG ')
23910        WRITE(ICOUT,10717)NR2
2391110717   FORMAT('      THE NUMBER OF ROWS FOR THE SECOND MATRIX: ',
23912     1         I8)
23913        CALL DPWRST('XXX','BUG ')
23914        IERROR='YES'
23915        GOTO9000
23916      ENDIF
23917C
23918      DO10710I=1,NR1
23919         DO10720J=1,NC1
23920           YM9(I,J)=YM1(I,J)
2392110720    CONTINUE
23922         DO10730J=1,NC2
23923           IINDX=I+NC1
23924           IF(IINDX.GT.MAXCOM)THEN
23925             WRITE(ICOUT,999)
23926             CALL DPWRST('XXX','BUG ')
23927             WRITE(ICOUT,10711)
23928             CALL DPWRST('XXX','BUG ')
23929             WRITE(ICOUT,10733)
2393010733        FORMAT('      THE MAXIMUM NUMBER OF COLUMNS FOR THE ',
23931     1              'OUTPUT MATRIX HAS BEEN EXCEEDED.')
23932             CALL DPWRST('XXX','BUG ')
23933             WRITE(ICOUT,10735)MAXCOM
2393410735        FORMAT('      THE MAXIMUM NUMBER OF COLUMNS  = ',I8)
23935             CALL DPWRST('XXX','BUG ')
23936             WRITE(ICOUT,10737)NC1+NC2
2393710737        FORMAT('      THE REQUIRED NUMBER OF COLUMNS = ',I8)
23938             CALL DPWRST('XXX','BUG ')
23939             IERROR='YES'
23940             GOTO9000
23941           ENDIF
23942           YM9(I,J+NC1)=YM2(I,J)
2394310730    CONTINUE
2394410710 CONTINUE
23945C
23946      ITYP9='MATR'
23947      NC9=NC1+NC2
23948      NR9=NR1
23949      IUPFLG='FULL'
23950      GOTO9000
23951C
23952C               *****************************************************
23953C               **  STEP 10800-                                    **
23954C               **  TREAT THE DEX CORE                       CASE  **
23955C               *****************************************************
23956C
2395710800 CONTINUE
23958C
23959      MAXK=25
23960      NROW=10000
23961      CALL DPCORE(YM1,NC1,NR1,MAXROM,MAXK,
23962     1            YM9,ITEMP1,NROW,NUMCOR,
23963     1            ITEMP2,Y1,Y2,
23964     1            IBUGA3,ISUBRO,IERROR)
23965C
23966      ITYP9='MATR'
23967      NC9=5
23968      NR9=NUMCOR
23969      IUPFLG='FULL'
23970      GOTO9000
23971C
23972C               *****************************************************
23973C               **  STEP 10900-                                    **
23974C               **  TREAT THE DEX CONFOUND                   CASE  **
23975C               *****************************************************
23976C
2397710900 CONTINUE
23978C
23979      MAXK=25
23980      MAX2T=500
23981      IF(NR1*MAX2T.GT.46*MAXOBV/3)THEN
23982        WRITE(ICOUT,10901)
2398310901   FORMAT('***** ERROR IN DEX CONFOUND--')
23984        CALL DPWRST('XXX','BUG ')
23985        WRITE(ICOUT,10903)
2398610903   FORMAT('      INSUFFICIENT SPACE TO GENERATE CONFOUNDING ',
23987     1         'STRUCTURE.')
23988        CALL DPWRST('XXX','BUG ')
23989        IERROR='YES'
23990        GOTO9000
23991      ENDIF
23992      CALL DPDCF2(YM1,NC1,NR1,MAXK,MAXROM,
23993     1            YM2,MAX2T,
23994     1            Y1,Y3,Y4,VECT9,Y2,
23995     1            INDEX,ITEMP1,
23996     1            ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,ITEMP7,
23997     1            STME,STMEC,ST2T,ST2TC,STC,STT,
23998     1            NUMCON,
23999     1            IBUGA3,ISUBRO,IERROR)
24000C
24001      ITYP9='VECT'
24002      NVECT9=NUMCON
24003      IUPFLG='FULL'
24004      GOTO9000
24005C
24006C               *****************************************************
24007C               **  STEP 11000-                                    **
24008C               **  TREAT THE DEX CHECK CLASSIC              CASE  **
24009C               *****************************************************
24010C
2401111000 CONTINUE
24012C
24013C     CHECK IF MATRIX IS IN "CLASSIC" FORM FOR 2-LEVEL FACTORIAL DESIGN.
24014C     THAT IS, IF A VALUE OTHER THAN -1, 0, OR 1 IS DETECTED, THEN THE
24015C     MATRIX IS NOT IN CLASSIC FORM.  SET OUTPUT TO 1 FOR THE CLASSIC
24016C     CASE AND 0 OTHERWISE.
24017C
24018      SCAL9=1.0
24019      DO11010J=1,NC1
24020        DO11020I=1,NR1
24021          IF(YM1(I,J).EQ.-1.0 .OR. YM1(I,J).EQ.0.0 .OR.
24022     1       YM1(I,J).EQ.1.0)GOTO11020
24023          SCAL9=0.0
24024          GOTO11030
2402511020   CONTINUE
2402611010 CONTINUE
24027C
2402811030 CONTINUE
24029      ITYP9='SCAL'
24030      IUPFLG='FULL'
24031      GOTO9000
24032C
24033C               *****************************************************
24034C               **  STEP 11000-                                    **
24035C               **  TREAT THE DEX CHECK CENTER POINT         CASE  **
24036C               *****************************************************
24037C
2403811100 CONTINUE
24039C
24040C     CHECK FOR CENTER POINTS IN A LIST OF FACTOR VARIABLES.  CREATE
24041C     A TAG VARIABLE THAT WILL BE 1 FOR ROWS THAT ARE NOT CENTER POINTS
24042C     0 FOR ROWS THAT ARE CENTER POINTS.
24043C
24044C     2018/10: UPDATE SO THAT WE DO NOT ASSUME THE FACTORS ARE IN
24045C              CLASSIC UNITS (I.E., CENTER POINT EQUAL 0).  INSTEAD,
24046C              CHECK IF EQUAL TO THE MEDIAN VALUE OF THE DISTINCT
24047C              VALUES (FOR EVEN NUMBER OF DISTINCT LEVELS NO CENTER
24048C              POINT WILL BE DETECTED, FOR ODD NUMBER OF DISTINCT
24049C              LEVELS, CENTER POINT EQUALS THE MEDIAN).
24050C
24051      SCAL9=1.0
24052      DO11110I=1,NR1
24053        IFLAG=0
24054        DO11120J=1,NC1
24055C
24056C         FOR COLUMN J, DETERMINE THE CENTER POINT (= THE MEDIAN
24057C         OF THE DISTINCT VALUES)
24058C
24059          DO11130K=1,NR1
24060            Y1(K)=YM1(K,J)
2406111130     CONTINUE
24062          CALL DISTIN(Y1,NR1,IWRITE,Y2,NDIST,IBUGA3,IERROR)
24063          CALL MEDIAN(Y2,NDIST,IWRITE,Y3,MAXOBV,YMED,IBUGA3,IERROR)
24064C
24065C         NOW CHECK WHETHER THE CURRENT ROW IS EQUAL TO THE MEDIAN
24066C
24067          IF(YM1(I,J).NE.YMED)THEN
24068            IFLAG=1
24069            GOTO11129
24070          ENDIF
2407111120   CONTINUE
2407211129   CONTINUE
24073        VECT9(I)=REAL(IFLAG)
2407411110 CONTINUE
24075C
24076      ITYP9='VECT'
24077      NVECT9=NR1
24078      IUPFLG='FULL'
24079      GOTO9000
24080C
24081C               *****************
24082C               **  STEP 90--  **
24083C               **  EXIT.      **
24084C               *****************
24085C
24086 9000 CONTINUE
24087C
24088      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'ATR3')GOTO9090
24089C
24090      WRITE(ICOUT,999)
24091      CALL DPWRST('XXX','BUG ')
24092      WRITE(ICOUT,9011)
24093 9011 FORMAT('***** AT THE END       OF MATAR3--')
24094      CALL DPWRST('XXX','BUG ')
24095      WRITE(ICOUT,9012)IBUGA3,ISUBRO,IMCASE,ITYPA1,ITYPA2,ITYPA3,ITYPA4
24096 9012 FORMAT('IBUGA3,ISUBRO,IMCASE,ITYPA1,ITYPA2,ITYPA3,ITYPA4 = ',
24097     1A4,2X,A4,2X,A4,2X,A4,2X,A4,2X,A4,2X,A4)
24098      CALL DPWRST('XXX','BUG ')
24099      WRITE(ICOUT,9013)IMCASE,IMSUBC
24100 9013 FORMAT('IMCASE,IMSUBC = ',A4,2X,A4)
24101      CALL DPWRST('XXX','BUG ')
24102      WRITE(ICOUT,9014)NUMVAR,IWRITE
24103 9014 FORMAT('NUMVAR,IWRITE = ',I8,2X,A4)
24104      CALL DPWRST('XXX','BUG ')
24105      WRITE(ICOUT,9015)YS1,YS2,YS3,YS4
24106 9015 FORMAT('YS1,YS2,YS3,YS4 = ',4E15.7)
24107      CALL DPWRST('XXX','BUG ')
24108      WRITE(ICOUT,9016)IERROR
24109 9016 FORMAT('IERROR = ',A4)
24110      CALL DPWRST('XXX','BUG ')
24111      WRITE(ICOUT,9017)IYS2,IYS3,IYS23,NRJ,NCJ
24112 9017 FORMAT('IYS2,IYS3,IYS23,NRJ,NCJ = ',5I8)
24113      CALL DPWRST('XXX','BUG ')
24114C
24115      WRITE(ICOUT,999)
24116      CALL DPWRST('XXX','BUG ')
24117      WRITE(ICOUT,9031)NR1,NC1
24118 9031 FORMAT('NR1,NC1 = ',2I8)
24119      CALL DPWRST('XXX','BUG ')
24120      IF(NR1.LE.0)GOTO9039
24121      IF(NC1.LE.0)GOTO9039
24122      JMAX=NC1
24123      IF(JMAX.GT.10)JMAX=10
24124      DO9032I=1,NR1
24125      WRITE(ICOUT,9033)I,(YM1(I,J),J=1,JMAX)
24126 9033 FORMAT('I,YM1(I,.) = ',I8,10E10.3)
24127      CALL DPWRST('XXX','BUG ')
24128 9032 CONTINUE
24129 9039 CONTINUE
24130C
24131      WRITE(ICOUT,999)
24132      CALL DPWRST('XXX','BUG ')
24133      WRITE(ICOUT,9041)NR2,NC2
24134 9041 FORMAT('NR2,NC2 = ',2I8)
24135      CALL DPWRST('XXX','BUG ')
24136      IF(NR2.LE.0)GOTO9049
24137      IF(NC2.LE.0)GOTO9049
24138      JMAX=NC2
24139      IF(JMAX.GT.10)JMAX=10
24140      DO9042I=1,NR2
24141      WRITE(ICOUT,9043)I,(YM2(I,J),J=1,JMAX)
24142 9043 FORMAT('I,YM2(I,.) = ',I8,10E10.3)
24143      CALL DPWRST('XXX','BUG ')
24144 9042 CONTINUE
24145 9049 CONTINUE
24146C
24147      WRITE(ICOUT,999)
24148      CALL DPWRST('XXX','BUG ')
24149      WRITE(ICOUT,9051)NR9,NC9
24150 9051 FORMAT('NR9,NC9 = ',2I8)
24151      CALL DPWRST('XXX','BUG ')
24152      IF(NR9.LE.0)GOTO9059
24153      IF(NC9.LE.0)GOTO9059
24154      JMAX=NC9
24155      IF(JMAX.GT.10)JMAX=10
24156      DO9055I=1,NR9
24157      WRITE(ICOUT,9056)I,(YM9(I,J),J=1,JMAX)
24158 9056 FORMAT('I,YM9(I,.) = ',I8,10E10.3)
24159      CALL DPWRST('XXX','BUG ')
24160 9055 CONTINUE
24161 9059 CONTINUE
24162C
24163      WRITE(ICOUT,999)
24164      CALL DPWRST('XXX','BUG ')
24165      WRITE(ICOUT,9111)N1
24166 9111 FORMAT('N1 = ',I8)
24167      CALL DPWRST('XXX','BUG ')
24168      IF(N1.LE.0)GOTO9119
24169      DO9112I=1,N1
24170      WRITE(ICOUT,9113)I,Y1(I)
24171 9113 FORMAT('I,Y1(I) = ',I8,E15.7)
24172      CALL DPWRST('XXX','BUG ')
24173 9112 CONTINUE
24174 9119 CONTINUE
24175C
24176      WRITE(ICOUT,999)
24177      CALL DPWRST('XXX','BUG ')
24178      WRITE(ICOUT,9121)N2
24179 9121 FORMAT('N2 = ',I8)
24180      CALL DPWRST('XXX','BUG ')
24181      IF(N2.LE.0)GOTO9129
24182      DO9122I=1,N2
24183      WRITE(ICOUT,9123)I,Y2(I)
24184 9123 FORMAT('I,Y2(I) = ',I8,E15.7)
24185      CALL DPWRST('XXX','BUG ')
24186 9122 CONTINUE
24187 9129 CONTINUE
24188C
24189      WRITE(ICOUT,999)
24190      CALL DPWRST('XXX','BUG ')
24191      WRITE(ICOUT,9131)N3
24192 9131 FORMAT('N3 = ',I8)
24193      CALL DPWRST('XXX','BUG ')
24194      IF(N3.LE.0)GOTO9139
24195      DO9132I=1,N3
24196      WRITE(ICOUT,9133)I,Y3(I)
24197 9133 FORMAT('I,Y3(I) = ',I8,E15.7)
24198      CALL DPWRST('XXX','BUG ')
24199 9132 CONTINUE
24200 9139 CONTINUE
24201C
24202      WRITE(ICOUT,999)
24203      CALL DPWRST('XXX','BUG ')
24204      WRITE(ICOUT,9141)N4
24205 9141 FORMAT('N4 = ',I8)
24206      CALL DPWRST('XXX','BUG ')
24207      IF(N4.LE.0)GOTO9149
24208      DO9142I=1,N4
24209      WRITE(ICOUT,9143)I,Y4(I)
24210 9143 FORMAT('I,Y4(I) = ',I8,E15.7)
24211      CALL DPWRST('XXX','BUG ')
24212 9142 CONTINUE
24213 9149 CONTINUE
24214C
24215      WRITE(ICOUT,999)
24216      CALL DPWRST('XXX','BUG ')
24217      WRITE(ICOUT,9151)ITYP9,SCAL9
24218 9151 FORMAT('ITYP9,SCAL9 = ',A4,2X,E15.7)
24219      CALL DPWRST('XXX','BUG ')
24220C
24221      WRITE(ICOUT,999)
24222      CALL DPWRST('XXX','BUG ')
24223      WRITE(ICOUT,9161)NVECT9
24224 9161 FORMAT('NVECT9 = ',I8)
24225      CALL DPWRST('XXX','BUG ')
24226      IF(NVECT9.LE.0)GOTO9169
24227      DO9162I=1,NVECT9
24228      WRITE(ICOUT,9163)I,VECT9(I)
24229 9163 FORMAT('I,VECT9(I) = ',I8,E15.7)
24230      CALL DPWRST('XXX','BUG ')
24231 9162 CONTINUE
24232 9169 CONTINUE
24233C
24234      WRITE(ICOUT,999)
24235      CALL DPWRST('XXX','BUG ')
24236      WRITE(ICOUT,9171)NR9,NC9
24237 9171 FORMAT('NR9,NC9 = ',2I8)
24238      CALL DPWRST('XXX','BUG ')
24239      IF(NR9.LE.0)GOTO9179
24240      IF(NC9.LE.0)GOTO9179
24241      JMAX=NC9
24242      IF(JMAX.GT.10)JMAX=10
24243      DO9172I=1,NR9
24244      WRITE(ICOUT,9173)I,(YM9(I,J),J=1,JMAX)
24245 9173 FORMAT('I,YM9(I,.) = ',I8,10E10.3)
24246      CALL DPWRST('XXX','BUG ')
24247 9172 CONTINUE
24248 9179 CONTINUE
24249C
24250      IF(IMCASE.NE.'MASS')GOTO9189
24251      WRITE(ICOUT,9181)NR2,NC2
24252 9181 FORMAT('NR2,NC2 = ',2I8)
24253      CALL DPWRST('XXX','BUG ')
24254      IF(NR2.LE.0)GOTO9189
24255      IF(NC2.LE.0)GOTO9189
24256      JMAX=NC2+1
24257      IF(JMAX.GT.10)JMAX=10
24258      NR2P1=NR2+1
24259      DO9182I=1,NR2P1
24260      WRITE(ICOUT,9183)I,(YM2(I,J),J=1,JMAX)
24261 9183 FORMAT('I,YM2(I,.) = ',I8,10E10.3)
24262      CALL DPWRST('XXX','BUG ')
24263 9182 CONTINUE
24264CCCCC WRITE(ICOUT,9187)NR2,NLTZ,NGTZ,NEQZ
24265C9187 FORMAT('NR2,NLTZ,NGTZ,NEQZ = ',4I8)
24266      WRITE(ICOUT,9187)NR2
24267 9187 FORMAT('NR2 = ',I8)
24268      CALL DPWRST('XXX','BUG ')
24269 9189 CONTINUE
24270C
24271 9090 CONTINUE
24272C
24273      RETURN
24274      END
24275      SUBROUTINE MATCH(X,Z,NX,VAL,NVAL,IWRITE,Y,ICASE,
24276     1                 IBUGA3,ISUBRO,IERROR)
24277C
24278C     PURPOSE--MATCH EACH VALUE IN THE VALUE ARRAY TO THE
24279C              CLOSEST VALUE IN THE X ARRAY.  THE RETURNED
24280C              Y ARRAY WILL CONTAIN THE CORRESPONDING INDEX
24281C              VALUES OF THE X ARRAY (I.E., DON'T RETURN
24282C              THE MATCHING VALUE, JUST THE INDEX OF THE
24283C              MATCHING VALUE).
24284C              IF ICASE IS TRAN, THEN RETURN THE VALUE OF THE
24285C              ARRAY Z CORRESPONDING TO INDEX.
24286C     WRITTEN BY--ALAN HECKERT
24287C                 STATISTICAL ENGINEERING DIVISION
24288C                 INFORMATION TECHNOLOGY LABORATORY
24289C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
24290C                 GAITHERSBURG, MD 20899-8980
24291C                 PHONE--301-975-2855
24292C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
24293C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
24294C     LANGUAGE--ANSI FORTRAN (1977)
24295C     VERSION NUMBER--2001/10
24296C     ORIGINAL VERSION--OCTOBER   2001.
24297C     UPDATED         --DECEMBER  2019. ADD ISUBRO
24298C
24299C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES----------------
24300C
24301      CHARACTER*4 ICASE
24302      CHARACTER*4 IWRITE
24303      CHARACTER*4 IBUGA3
24304      CHARACTER*4 ISUBRO
24305      CHARACTER*4 IERROR
24306C
24307      CHARACTER*4 ISUBN1
24308      CHARACTER*4 ISUBN2
24309C
24310C
24311C------------------------------------------------------------------
24312C
24313      DIMENSION X(*)
24314      DIMENSION Y(*)
24315      DIMENSION Z(*)
24316      DIMENSION VAL(*)
24317C
24318C-----COMMON----------------------------------------------------
24319C
24320      INCLUDE 'DPCOP2.INC'
24321C
24322C-----START POINT--------------------------------------------------
24323C
24324      ISUBN1='MATC'
24325      ISUBN2='H   '
24326      IERROR='NO'
24327C
24328      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ATCH')THEN
24329        WRITE(ICOUT,999)
24330  999   FORMAT(1X)
24331        CALL DPWRST('XXX','BUG ')
24332        WRITE(ICOUT,51)
24333   51   FORMAT('***** AT THE BEGINNING OF MATCH--')
24334        CALL DPWRST('XXX','BUG ')
24335        WRITE(ICOUT,52)IBUGA3,ISUBRO,IWRITE,NX,NVAL
24336   52   FORMAT('IBUGA3,ISUBRO,IWRITE,NX,NVAL = ',3(A4,2X),2I8)
24337        CALL DPWRST('XXX','BUG ')
24338        DO55I=1,NX
24339          WRITE(ICOUT,56)I,X(I),Z(I)
24340   56     FORMAT('I,X(I),Z(I) = ',I8,2G15.7)
24341          CALL DPWRST('XXX','BUG ')
24342   55   CONTINUE
24343      ENDIF
24344C
24345C               ****************************************
24346C               **  COMPUTE INDICES OF MATCHING VALUES *
24347C               ****************************************
24348C
24349      DO100I=1,NVAL
24350        VALTMP=VAL(I)
24351        INDTMP=1
24352        YDIFF=CPUMAX
24353        DO200J=1,NX
24354          APROD=X(J)*VALTMP
24355          TERM1=MAX(X(J),VALTMP)
24356          TERM2=MIN(X(J),VALTMP)
24357          IF(APROD.GT.0.0)THEN
24358            ADIFF=ABS(ABS(TERM1) - ABS(TERM2))
24359          ELSEIF(APROD.LT.0.0)THEN
24360            ADIFF=TERM1+ABS(TERM2)
24361          ELSE
24362            ADIFF=ABS(TERM1-TERM2)
24363          ENDIF
24364          IF(ADIFF.LT.YDIFF)THEN
24365            INDTMP=J
24366            YDIFF=ADIFF
24367          ENDIF
24368  200   CONTINUE
24369        IF(ICASE.EQ.'INDE')THEN
24370          Y(I)=REAL(INDTMP)
24371        ELSE
24372          Y(I)=Z(INDTMP)
24373        ENDIF
24374  100 CONTINUE
24375C
24376C               *****************
24377C               **  STEP 90--  **
24378C               **  EXIT.      **
24379C               *****************
24380C
24381      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ATCH')THEN
24382        WRITE(ICOUT,999)
24383        CALL DPWRST('XXX','BUG ')
24384        WRITE(ICOUT,9011)
24385 9011   FORMAT('***** AT THE END       OF MATCH--')
24386        CALL DPWRST('XXX','BUG ')
24387        WRITE(ICOUT,9012)IERROR,NX
24388 9012   FORMAT('IERROR,NX = ',A4,2X,I8)
24389        CALL DPWRST('XXX','BUG ')
24390        DO9015I=1,NVAL
24391          WRITE(ICOUT,9016)I,VAL(I),Y(I)
24392 9016     FORMAT('I,VAL(I),Y(I) = ',I8,2G15.7)
24393          CALL DPWRST('XXX','BUG ')
24394 9015   CONTINUE
24395      ENDIF
24396C
24397      RETURN
24398      END
24399      SUBROUTINE MATCH2(X,NX,VAL,NVAL,Y,IWRITE,ISUBRO,IBUGA3,IERROR)
24400C
24401C     PURPOSE--SORT THE VALUES IN X.  FIND THE INDEX, IVAL,
24402C              SUCH THAT
24403C
24404C                    X(I) <= VAL < X(I+1)
24405C
24406C              IF VAL < X(1), RETURN A 0 AND IF VAL > X(NX) RETURN
24407C              NX + 1.
24408C
24409C              DO THIS FOR EACH ROW OF THE VAL VECTOR.
24410C
24411C     WRITTEN BY--ALAN HECKERT
24412C                 STATISTICAL ENGINEERING DIVISION
24413C                 INFORMATION TECHNOLOGY LABORATORY
24414C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
24415C                 GAITHERSBURG, MD 20899-8980
24416C                 PHONE--301-975-2899
24417C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
24418C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
24419C     LANGUAGE--ANSI FORTRAN (1977)
24420C     VERSION NUMBER--2018/08
24421C     ORIGINAL VERSION--AUGUST    2018.
24422C
24423C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES----------------
24424C
24425      CHARACTER*4 IWRITE
24426      CHARACTER*4 ISUBRO
24427      CHARACTER*4 IBUGA3
24428      CHARACTER*4 IERROR
24429C
24430      CHARACTER*4 ISUBN1
24431      CHARACTER*4 ISUBN2
24432C
24433C------------------------------------------------------------------
24434C
24435      DIMENSION X(*)
24436      DIMENSION VAL(*)
24437      DIMENSION Y(*)
24438C
24439C---------------------------------------------------------------
24440C
24441      INCLUDE 'DPCOP2.INC'
24442C
24443C-----START POINT--------------------------------------------------
24444C
24445      ISUBN1='MATC'
24446      ISUBN2='H2  '
24447      IERROR='NO'
24448C
24449      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'TCH2')THEN
24450        WRITE(ICOUT,999)
24451  999   FORMAT(1X)
24452        CALL DPWRST('XXX','BUG ')
24453        WRITE(ICOUT,51)
24454   51   FORMAT('***** AT THE BEGINNING OF MATCH2--')
24455        CALL DPWRST('XXX','BUG ')
24456        WRITE(ICOUT,52)IBUGA3,ISUBRO,IWRITE,NX
24457   52   FORMAT('IBUGA3,ISUBRO,IWRITE,NX = ',3(A4,2X),I8)
24458        CALL DPWRST('XXX','BUG ')
24459        DO55I=1,NX
24460          WRITE(ICOUT,56)I,X(I)
24461   56     FORMAT('I,X(I), VAL(I) = ',I8,G15.7)
24462          CALL DPWRST('XXX','BUG ')
24463   55   CONTINUE
24464      ENDIF
24465C
24466C               ****************************************
24467C               **  ERROR CHECKING                    **
24468C               ****************************************
24469C
24470      IF(NX.LT.1)THEN
24471        WRITE(ICOUT,999)
24472        CALL DPWRST('XXX','BUG ')
24473        WRITE(ICOUT,101)
24474  101   FORMAT('***** ERROR IN MATCH2--')
24475        CALL DPWRST('XXX','BUG ')
24476        WRITE(ICOUT,103)NX
24477  103   FORMAT('      THE NUMBER OF OBSERVATIONS IN THE RESPONSE ',
24478     1         'VARIABLE (',I5,') IS NON-POSITIVE.')
24479        CALL DPWRST('XXX','BUG ')
24480        IERROR='YES'
24481        GOTO9000
24482      ELSEIF(NVAL.LT.1)THEN
24483        WRITE(ICOUT,999)
24484        CALL DPWRST('XXX','BUG ')
24485        WRITE(ICOUT,101)
24486        CALL DPWRST('XXX','BUG ')
24487        WRITE(ICOUT,105)NVAL
24488  105   FORMAT('      THE NUMBER OF OBSERVATIONS IN THE MATCH ',
24489     1         'VARIABLE (',I5,') IS NON-POSITIVE.')
24490        CALL DPWRST('XXX','BUG ')
24491        IERROR='YES'
24492        GOTO9000
24493      ENDIF
24494C
24495C               ****************************************
24496C               **  COMPUTE INDICES OF MATCHING VALUES *
24497C               ****************************************
24498C
24499      CALL SORT(X,NX,X)
24500C
24501      DO100I=1,NVAL
24502        VALTMP=VAL(I)
24503        IF(VALTMP.LT.X(1))THEN
24504          Y(I)=0.
24505        ELSEIF(VALTMP.GT.X(NX))THEN
24506          Y(I)=REAL(NX+1)
24507        ELSE
24508          DO200J=1,NX-1
24509            IF(VALTMP.GE.X(J) .AND. VALTMP.LT.X(J+1))THEN
24510              Y(I)=REAL(J)
24511              GOTO100
24512            ENDIF
24513  200     CONTINUE
24514        ENDIF
24515  100 CONTINUE
24516C
24517C               *****************
24518C               **  STEP 90--  **
24519C               **  EXIT.      **
24520C               *****************
24521C
24522 9000 CONTINUE
24523C
24524      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ATC2')THEN
24525        WRITE(ICOUT,999)
24526        CALL DPWRST('XXX','BUG ')
24527        WRITE(ICOUT,9011)
24528 9011   FORMAT('***** AT THE END       OF MATCH2--')
24529        CALL DPWRST('XXX','BUG ')
24530        WRITE(ICOUT,9012)IERROR
24531 9012   FORMAT('IERROR = ',A4)
24532        CALL DPWRST('XXX','BUG ')
24533        DO9015I=1,NVAL
24534          WRITE(ICOUT,9016)I,Y(I)
24535 9016     FORMAT('I,Y(I) = ',I8,G15.7)
24536          CALL DPWRST('XXX','BUG ')
24537 9015   CONTINUE
24538      ENDIF
24539C
24540      RETURN
24541      END
24542      SUBROUTINE MATCDF(X,K,CDF)
24543C
24544C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
24545C              FUNCTION VALUE FOR THE CLASSICAL MATCHING
24546C              DISTRIBUTION ON THE INTERVAL (0,K).
24547C              THIS DISTRIBUTION HAS MEAN = 1
24548C              AND STANDARD DEVIATION = 1
24549C              THIS DISTRIBUTION HAS THE PROBABILITY
24550C              MASS FUNCTION:
24551C
24552C                P(X;K) = (1/X!)*SUM[i=1 to k-1][(-1)**i/i!]
24553C                         X = 0, 1, ..., K
24554C
24555C              GIVEN K ENTITIES NUMBERED 1 TO K THAT ARE
24556C              ARRANGED IN A RANDOM ORDER.  THE MATCHING
24557C              DISTRIBUTION IS THE NUMBER OF ENTITITIES FOR
24558C              WHICH THE NUMBERED ORDER IS THE SAME AS THE RANDM
24559C              ORDER.
24560C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
24561C                                WHICH THE CUMULATIVE DISTRIBUTION
24562C                                FUNCTION IS TO BE EVALUATED.
24563C                       K      = THE INTEGER VALUE THAT SPECIFIES
24564C                                THE MAXIMUM VALUE
24565C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
24566C                                DISTRIBUTION FUNCTION VALUE.
24567C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
24568C             DISTRIBUTION VALUE CDF.
24569C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
24570C     RESTRICTIONS--X SHOULD BE BETWEEN 0 AND N, INCLUSIVELY.
24571C     OTHER DATAPAC   SUBROUTINES NEEDED--DGAMMA.
24572C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP, POIPDF.
24573C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
24574C     LANGUAGE--ANSI FORTRAN.
24575C     REFERENCES--JOHNSON, KOTZ, AND KEMP (1992).  "UNIVARIATE
24576C                 DISCRETE DISTRIBUTIONS" SECOND EDITION,
24577C                 PAGES 409-414.
24578C     WRITTEN BY--JAMES J. FILLIBEN
24579C                 STATISTICAL ENGINEERING DIVISION
24580C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
24581C                 GAITHERSBURG, MD 20899-8980
24582C                 PHONE:  301-975-2855
24583C     ORIGINAL VERSION--JUNE      2006.
24584C
24585C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
24586C
24587C---------------------------------------------------------------------
24588C
24589      DOUBLE PRECISION DX
24590      DOUBLE PRECISION DK
24591      DOUBLE PRECISION DI
24592      DOUBLE PRECISION DTERM1
24593      DOUBLE PRECISION DSUM1
24594      DOUBLE PRECISION DCDF
24595      DOUBLE PRECISION DPDF
24596      DOUBLE PRECISION DGAMMA
24597C
24598      INCLUDE 'DPCOP2.INC'
24599C
24600C---------------------------------------------------------------------
24601C
24602C     CHECK THE INPUT ARGUMENTS FOR ERRORS
24603C
24604      CDF=0.0
24605C
24606      IF(K.LT.0)THEN
24607        WRITE(ICOUT,12)
24608        CALL DPWRST('XXX','BUG ')
24609        WRITE(ICOUT,46)N
24610        CALL DPWRST('XXX','BUG ')
24611        GOTO9000
24612      ENDIF
24613   12 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ',
24614     1       'MATCDF SUBROUTINE IS LESS THAN 0.')
24615C
24616      IX=INT(X+0.5)
24617      IF(IX.LT.0 .OR. IX.GT.K)THEN
24618        WRITE(ICOUT,2)
24619        CALL DPWRST('XXX','BUG ')
24620        WRITE(ICOUT,46)IX
24621        CALL DPWRST('XXX','BUG ')
24622        GOTO9000
24623      ENDIF
24624    2 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ',
24625     1       'MATCDF SUBROUTINE IS OUTSIDE THE (0,N) INTERVAL')
24626C
24627   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
24628C
24629C-----START POINT-----------------------------------------------------
24630C
24631C     FOR K SUFFICENTLY LARGE, USE POISSON (WITH LAMBDA = 1)
24632C     APPROXIMATION
24633C
24634      IF(K.GE.20)THEN
24635        ALAMB=1.0
24636        CALL POICDF(X,ALAMB,CDF)
24637      ELSE
24638        DK=DBLE(K)
24639        DCDF=0.0D0
24640        DO200J=0,IX
24641          IX2=J
24642          DX=DBLE(J)
24643          DTERM1=1.0D0/DGAMMA(DX+1.0D0)
24644          DSUM1=0.0D0
24645          DO100I=0,K-IX2
24646            DI=DBLE(I)
24647            DSUM1=DSUM1 + (-1.0D0)**DI/DGAMMA(DI+1.0D0)
24648  100     CONTINUE
24649          DPDF=DTERM1*DSUM1
24650          DCDF=DCDF + DPDF
24651  200   CONTINUE
24652        CDF=REAL(DCDF)
24653      ENDIF
24654C
24655 9000 CONTINUE
24656      RETURN
24657      END
24658      SUBROUTINE MATPDF(X,K,PDF)
24659C
24660C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
24661C              FUNCTION VALUE FOR THE CLASSICAL MATCHING
24662C              DISTRIBUTION ON THE INTERVAL (0,K).
24663C              THIS DISTRIBUTION HAS MEAN = 1
24664C              AND STANDARD DEVIATION = 1
24665C              THIS DISTRIBUTION HAS THE PROBABILITY
24666C              MASS FUNCTION:
24667C
24668C                P(X;K) = (1/X!)*SUM[i=1 to k-1][(-1)**i/i!]
24669C                         X = 0, 1, ..., K
24670C
24671C              GIVEN K ENTITIES NUMBERED 1 TO K THAT ARE
24672C              ARRANGED IN A RANDOM ORDER.  THE MATCHING
24673C              DISTRIBUTION IS THE NUMBER OF ENTITITIES FOR
24674C              WHICH THE NUMBERED ORDER IS THE SAME AS THE RANDM
24675C              ORDER.
24676C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
24677C                                WHICH THE PROBABILITY DENSITY
24678C                                FUNCTION IS TO BE EVALUATED.
24679C                       K      = THE INTEGER VALUE THAT SPECIFIES
24680C                                THE MAXIMUM VALUE
24681C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
24682C                                DENSITY FUNCTION VALUE.
24683C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
24684C             FUNCTION VALUE PDF.
24685C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
24686C     RESTRICTIONS--X SHOULD BE BETWEEN 0 AND N, INCLUSIVELY.
24687C     OTHER DATAPAC   SUBROUTINES NEEDED--DGAMMA, DLNGAM.
24688C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
24689C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
24690C     LANGUAGE--ANSI FORTRAN.
24691C     REFERENCES--JOHNSON, KOTZ, AND KEMP (1992).  "UNIVARIATE
24692C                 DISCRETE DISTRIBUTIONS" SECOND EDITION,
24693C                 PAGES 409-414.
24694C     WRITTEN BY--JAMES J. FILLIBEN
24695C                 STATISTICAL ENGINEERING DIVISION
24696C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
24697C                 GAITHERSBURG, MD 20899-8980
24698C                 PHONE:  301-975-2855
24699C     ORIGINAL VERSION--JUNE      2006.
24700C
24701C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
24702C
24703C---------------------------------------------------------------------
24704C
24705      DOUBLE PRECISION DX
24706      DOUBLE PRECISION DK
24707      DOUBLE PRECISION DI
24708      DOUBLE PRECISION DTERM1
24709      DOUBLE PRECISION DSUM1
24710      DOUBLE PRECISION DPDF
24711      DOUBLE PRECISION DGAMMA
24712      DOUBLE PRECISION DLNGAM
24713C
24714      INCLUDE 'DPCOP2.INC'
24715C
24716C---------------------------------------------------------------------
24717C
24718C     CHECK THE INPUT ARGUMENTS FOR ERRORS
24719C
24720      PDF=0.0
24721C
24722      IF(K.LT.0)THEN
24723        WRITE(ICOUT,12)
24724        CALL DPWRST('XXX','BUG ')
24725        WRITE(ICOUT,46)N
24726        CALL DPWRST('XXX','BUG ')
24727        GOTO9000
24728      ENDIF
24729   12 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ',
24730     1       'MATPDF SUBROUTINE IS LESS THAN 0.')
24731C
24732      IX=INT(X+0.5)
24733      IF(IX.LT.0 .OR. IX.GT.K)THEN
24734        WRITE(ICOUT,2)
24735        CALL DPWRST('XXX','BUG ')
24736        WRITE(ICOUT,46)IX
24737        CALL DPWRST('XXX','BUG ')
24738        GOTO9000
24739      ENDIF
24740    2 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ',
24741     1       'MATPDF SUBROUTINE IS OUTSIDE THE (0,N) INTERVAL')
24742C
24743   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
24744C
24745C-----START POINT-----------------------------------------------------
24746C
24747      DX=DBLE(IX)
24748      DK=DBLE(K)
24749C
24750C     FOR K SUFFICENTLY LARGE, USE APPROXIMATION EXP(-1)/X!
24751C
24752      IF(K.GE.20)THEN
24753        DPDF=DEXP(-1.0D0 - DLNGAM(DX+1.0D0))
24754      ELSE
24755        DTERM1=1.0D0/DGAMMA(DX+1.0D0)
24756        DSUM1=0.0D0
24757        DO100I=0,K-IX
24758          DI=DBLE(I)
24759          DSUM1=DSUM1 + (-1.0D0)**DI/DGAMMA(DI+1.0D0)
24760  100   CONTINUE
24761        DPDF=DTERM1*DSUM1
24762      ENDIF
24763      PDF=REAL(DPDF)
24764C
24765 9000 CONTINUE
24766      RETURN
24767      END
24768      SUBROUTINE MATPPF(P,K,PPF)
24769C
24770C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
24771C              FUNCTION VALUE FOR THE CLASSICAL MATCHING
24772C              DISTRIBUTION ON THE INTERVAL (0,K).
24773C              THIS DISTRIBUTION HAS MEAN = 1
24774C              AND STANDARD DEVIATION = 1
24775C              THIS DISTRIBUTION HAS THE PROBABILITY
24776C              MASS FUNCTION:
24777C
24778C                P(X;K) = (1/X!)*SUM[i=1 to k-1][(-1)**i/i!]
24779C                         X = 0, 1, ..., K
24780C
24781C              GIVEN K ENTITIES NUMBERED 1 TO K THAT ARE
24782C              ARRANGED IN A RANDOM ORDER.  THE MATCHING
24783C              DISTRIBUTION IS THE NUMBER OF ENTITITIES FOR
24784C              WHICH THE NUMBERED ORDER IS THE SAME AS THE RANDM
24785C              ORDER.
24786C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE AT
24787C                                WHICH THE PERCENT POINT
24788C                                FUNCTION IS TO BE EVALUATED.
24789C                       K      = THE INTEGER VALUE THAT SPECIFIES
24790C                                THE MAXIMUM VALUE
24791C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT POINT
24792C                                FUNCTION VALUE.
24793C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
24794C             DISTRIBUTION VALUE PPF.
24795C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
24796C     RESTRICTIONS--X SHOULD BE BETWEEN 0 AND N, INCLUSIVELY.
24797C     OTHER DATAPAC   SUBROUTINES NEEDED--DGAMMA.
24798C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP, POIPPF.
24799C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
24800C     LANGUAGE--ANSI FORTRAN.
24801C     REFERENCES--JOHNSON, KOTZ, AND KEMP (1992).  "UNIVARIATE
24802C                 DISCRETE DISTRIBUTIONS" SECOND EDITION,
24803C                 PAGES 409-414.
24804C     WRITTEN BY--JAMES J. FILLIBEN
24805C                 STATISTICAL ENGINEERING DIVISION
24806C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
24807C                 GAITHERSBURG, MD 20899-8980
24808C                 PHONE:  301-975-2855
24809C     ORIGINAL VERSION--JUNE      2006.
24810C
24811C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
24812C
24813C---------------------------------------------------------------------
24814C
24815      DOUBLE PRECISION DX
24816      DOUBLE PRECISION DP
24817      DOUBLE PRECISION DK
24818      DOUBLE PRECISION DI
24819      DOUBLE PRECISION DTERM1
24820      DOUBLE PRECISION DSUM1
24821      DOUBLE PRECISION DCDF
24822      DOUBLE PRECISION DPDF
24823      DOUBLE PRECISION DGAMMA
24824      DOUBLE PRECISION DEPS
24825C
24826      INCLUDE 'DPCOP2.INC'
24827C
24828C---------------------------------------------------------------------
24829C
24830C     CHECK THE INPUT ARGUMENTS FOR ERRORS
24831C
24832      PPF=0.0
24833C
24834      IF(K.LT.0)THEN
24835        WRITE(ICOUT,12)
24836        CALL DPWRST('XXX','BUG ')
24837        WRITE(ICOUT,46)N
24838        CALL DPWRST('XXX','BUG ')
24839        GOTO9000
24840      ENDIF
24841   12 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ',
24842     1       'MATCDF SUBROUTINE IS LESS THAN 0.')
24843C
24844      IF(P.LT.0.0 .OR. P.GT.1.0)THEN
24845        WRITE(ICOUT,2)
24846        CALL DPWRST('XXX','BUG ')
24847        WRITE(ICOUT,47)P
24848        CALL DPWRST('XXX','BUG ')
24849        GOTO9000
24850      ENDIF
24851    2 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO ',
24852     1       'MATPPF IS OUTSIDE THE (0,1) INTERVAL')
24853C
24854   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
24855   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
24856C
24857C-----START POINT-----------------------------------------------------
24858C
24859C     P = 0 AND P = 1 CASES
24860C
24861      IF(P.LE.0.0)THEN
24862        PPF=0.0
24863        GOTO9000
24864      ELSEIF(P.GE.1.0)THEN
24865        PPF=REAL(K)
24866        GOTO9000
24867      ENDIF
24868C
24869C     FOR K SUFFICENTLY LARGE, USE POISSON (WITH LAMBDA = 1)
24870C     APPROXIMATION
24871C
24872      IF(K.GE.20)THEN
24873        ALAMB=1.0
24874        CALL POIPPF(P,ALAMB,PPF)
24875        GOTO9000
24876      ELSE
24877        DK=DBLE(K)
24878        DP=DBLE(P)
24879        DCDF=0.0D0
24880        DEPS=1.0D-7
24881        DO200J=0,K
24882          IX2=J
24883          DX=DBLE(J)
24884          DTERM1=1.0D0/DGAMMA(DX+1.0D0)
24885          DSUM1=0.0D0
24886          DO100I=0,K-IX2
24887            DI=DBLE(I)
24888            DSUM1=DSUM1 + (-1.0D0)**DI/DGAMMA(DI+1.0D0)
24889  100     CONTINUE
24890          DPDF=DTERM1*DSUM1
24891          DCDF=DCDF + DPDF
24892          IF(DCDF.GE.DP-DEPS)THEN
24893            PPF=REAL(J)
24894            GOTO9000
24895          ENDIF
24896C
24897  200   CONTINUE
24898        PPF=1.0
24899      ENDIF
24900C
24901 9000 CONTINUE
24902      RETURN
24903      END
24904      SUBROUTINE MATRAN(N,K,ISEED,X)
24905C
24906C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
24907C              FROM THE MATCHING DISTRIBUTION
24908C              WITH SHAPE PARAMETER K.
24909C              THIS DISTRIBUTION HAS THE PROBABILITY
24910C              MASS FUNCTION:
24911C
24912C                P(X;K) = (1/X!)*SUM[i=1 to k-1][(-1)**i/i!]
24913C                         X = 0, 1, ..., K
24914C
24915C              GIVEN K ENTITIES NUMBERED 1 TO K THAT ARE
24916C              ARRANGED IN A RANDOM ORDER.  THE MATCHING
24917C              DISTRIBUTION IS THE NUMBER OF ENTITITIES FOR
24918C              WHICH THE NUMBERED ORDER IS THE SAME AS THE RANDM
24919C              ORDER.
24920C
24921C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
24922C                                OF RANDOM NUMBERS TO BE
24923C                                GENERATED.
24924C                     --NPAR   = THE INTEGER VALUE
24925C                                OF THE SHAPE PARAMETER.
24926C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
24927C                                (OF DIMENSION AT LEAST N)
24928C                                INTO WHICH THE GENERATED
24929C                                RANDOM SAMPLE WILL BE PLACED.
24930C     OUTPUT--A RANDOM SAMPLE OF SIZE N
24931C             FROM THE MATCHING DISTRIBUTION
24932C             WITH SHAPE PARAMETERS N AND NPAR.
24933C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
24934C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
24935C                   OF N FOR THIS SUBROUTINE.
24936C                 --NPAR > 0
24937C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, LCTPPF
24938C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
24939C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
24940C     LANGUAGE--ANSI FORTRAN (1977)
24941C     REFERENCES--JOHNSON, KOTZ, AND KEMP (1992).  "UNIVARIATE
24942C                 DISCRETE DISTRIBUTIONS", SECOND EDITION,
24943C                 WILEY, PP. 242-244.
24944C     WRITTEN BY--JAMES J. FILLIBEN
24945C                 STATISTICAL ENGINEERING DIVISION
24946C                 INFORMATION TECHNOLOGY LABORATORY
24947C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
24948C                 GAITHERSBURG, MD 20899-8980
24949C                 PHONE--301-975-2899
24950C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
24951C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
24952C     LANGUAGE--ANSI FORTRAN (1977)
24953C     VERSION NUMBER--2006/6
24954C     ORIGINAL VERSION--JUNE      2006.
24955C
24956C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
24957C
24958C---------------------------------------------------------------------
24959C
24960      INTEGER N
24961      INTEGER K
24962      DIMENSION X(*)
24963C
24964C-----COMMON----------------------------------------------------------
24965C
24966      INCLUDE 'DPCOP2.INC'
24967C
24968C-----START POINT-----------------------------------------------------
24969C
24970C     CHECK THE INPUT ARGUMENTS FOR ERRORS
24971C
24972      IF(N.LT.1)THEN
24973        WRITE(ICOUT, 5)
24974        CALL DPWRST('XXX','BUG ')
24975        WRITE(ICOUT,47)N
24976        CALL DPWRST('XXX','BUG ')
24977        GOTO9999
24978      ENDIF
24979C
24980      IF(K.LE.0.0)THEN
24981        WRITE(ICOUT,12)
24982        CALL DPWRST('XXX','BUG ')
24983        WRITE(ICOUT,47)K
24984        CALL DPWRST('XXX','BUG ')
24985        GOTO9999
24986      ENDIF
24987    5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF ',
24988     1'MATCHING RANDOM NUMBERS IS NON-POSITIVE')
24989   12 FORMAT('***** ERROR--THE K PARAMETER FOR THE ',
24990     1'MATCHING RANDOM NUMBERS IS NON-POSITIVE')
24991   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
24992C
24993C 100 CONTINUE
24994C
24995      IF(K.LT.20)THEN
24996        CALL UNIRAN(N,ISEED,X)
24997        DO100I=1,N
24998          XTEMP=X(I)
24999          CALL MATPPF(XTEMP,K,PPF)
25000          X(I)=PPF
25001  100   CONTINUE
25002      ELSE
25003        ALAMB=1.0
25004        CALL POIRAN(N,ALAMB,ISEED,X)
25005      ENDIF
25006C
25007 9999 CONTINUE
25008C
25009      RETURN
25010      END
25011