1      SUBROUTINE CNP(X,N,XTEMP,MAXNXT,ENGLSL,ENGUSL,IWRITE,ICNPKD,
2     1               XCNP,IBUGA3,IERROR)
3C
4C     PURPOSE--THIS SUBROUTINE COMPUTES THE SAMPLE NON-PARAMETRIC CP
5C              (PROCESS CAPABILITY INDEX) OF THE DATA IN THE INPUT
6C              VECTOR X.
7C                 CNP = (ENGUSL - ENGLSL)/(P(.99865) - P(0.00135))
8C           WHERE P(x) IS THE PERCENTILE FUNCTION.  THIS HAS COVERAGE
9C           COMPARABLE TO THE NORMAL-BASED CP STATISTIC (+/- 3*SIGMA).
10C           AN ALTERNATIVE DEFINITION HAS 99% COVERAGE AND HAS THE
11C           FORMULA
12C                 CNP = (ENGUSL - ENGLSL)/(P(.995) - P(0.005))
13C     NOTE--CP IS A MEASURE OF PROCESS PRECISION--
14C           IT CONTAINS NO BIAS INFORMATION.
15C     NOTE--THE CP INDEX IS A MEASURE WHICH TAKES ON THE VALUES 0 TO
16C           INFINITY.  A GOOD PROCESS YIELDS VALUES OF CP WHICH ARE
17C           LARGE (ABOVE 2); VALUES OF CP FROM 0.5 TO 1.0 ARE TYPICAL.
18C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
19C                                (UNSORTED OR SORTED) OBSERVATIONS.
20C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
21C                                IN THE VECTOR X.
22C                     --ENGLSL = LOWER (ENGINEERING) SPEC LIMIT
23C                     --ENGUSL = UPPER (ENGINEERING) SPEC LIMIT
24C     OUTPUT ARGUMENTS--CP     = THE SINGLE PRECISION VALUE OF THE
25C                                COMPUTED SAMPLE CP
26C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE SAMPLE CP INDEX
27C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
28C                   OF N FOR THIS SUBROUTINE.
29C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
30C     FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT.
31C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
32C     LANGUAGE--ANSI FORTRAN (1977)
33C     REFERENCES--CHEN AND DING (2001), "A NEW PROCESS CAPABILITY
34C                 INDEX FOR NON-NORMAL DISTRIBUTIONS", INTERNATIONAL
35C                 JOURNAL OF QUALITY & RELIABILITY MANAGEMENT,
36C                 VOL. 18, NO. 7, PP. 762-770.
37C     WRITTEN BY--ALAN HECKERT
38C                 STATISTICAL ENGINEERING DIVISION
39C                 INFORMATION TECHNOLOGY LABORATORY
40C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
41C                 GAITHERSBURG, MD 20899
42C                 PHONE--301-975-28999
43C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
44C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
45C     LANGUAGE--ANSI FORTRAN (1977)
46C     VERSION NUMBER--2015.4
47C     ORIGINAL VERSION--APRIL     2015.
48C
49C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
50C
51      CHARACTER*4 ICNPKD
52      CHARACTER*4 IWRITE
53      CHARACTER*4 IBUGA3
54      CHARACTER*4 IERROR
55C
56      CHARACTER*4 ISUBN1
57      CHARACTER*4 ISUBN2
58C
59      REAL NUM
60C
61C---------------------------------------------------------------------
62C
63      DIMENSION X(*)
64      DIMENSION XTEMP(*)
65C
66C---------------------------------------------------------------------
67C
68      INCLUDE 'DPCOP2.INC'
69C
70C-----START POINT-----------------------------------------------------
71C
72      ISUBN1='CNP '
73      ISUBN2='    '
74      IERROR='NO'
75C
76      XCNP=0.0
77      DMEAN=0.0D0
78C
79      IF(IBUGA3.EQ.'ON')THEN
80        WRITE(ICOUT,999)
81  999   FORMAT(1X)
82        CALL DPWRST('XXX','BUG ')
83        WRITE(ICOUT,51)
84   51   FORMAT('***** AT THE BEGINNING OF CNP--')
85        CALL DPWRST('XXX','BUG ')
86        WRITE(ICOUT,52)IBUGA3,N,MAXNXT,ENGUSL,ENGLSL
87   52   FORMAT('IBUGA3,N,MAXNXT,ENGUSL,ENGLSL = ',A4,2X,2I8,2G15.7)
88        CALL DPWRST('XXX','BUG ')
89        DO55I=1,N
90          WRITE(ICOUT,56)I,X(I)
91   56     FORMAT('I,X(I) = ',I8,G15.7)
92          CALL DPWRST('XXX','BUG ')
93   55   CONTINUE
94      ENDIF
95C
96C               ********************************************
97C               **  COMPUTE PROCESS CAPABILITY INDEX CP  **
98C               ********************************************
99C
100C               ********************************************
101C               **  STEP 1--                              **
102C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
103C               ********************************************
104C
105      AN=N
106C
107      IF(N.LT.1)THEN
108        IERROR='YES'
109        WRITE(ICOUT,999)
110        CALL DPWRST('XXX','BUG ')
111        WRITE(ICOUT,111)
112  111   FORMAT('***** ERROR IN CNP--')
113        CALL DPWRST('XXX','BUG ')
114        WRITE(ICOUT,112)
115  112   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ',
116     1         'VARIABLE IS NON-POSITIVE.')
117        CALL DPWRST('XXX','BUG ')
118        WRITE(ICOUT,117)N
119  117   FORMAT('      THE NUMBER OF OBSERVATIONS = ',I8,'.')
120        CALL DPWRST('XXX','BUG ')
121        GOTO9000
122      ELSEIF(N.EQ.1)THEN
123        GOTO9000
124      ENDIF
125C
126      HOLD=X(1)
127      DO135I=2,N
128        IF(X(I).NE.HOLD)GOTO139
129  135 CONTINUE
130      GOTO9000
131  139 CONTINUE
132C
133C               ****************************************
134C               **  STEP 2--                          **
135C               **  COMPUTE THE MEDIAN AND PERCENTILE **
136C               **  POINTS                            **
137C               ****************************************
138C
139      IWRITE='OFF'
140      IF(ICNPKD.EQ.'PEAR')THEN
141        P=99.865
142        CALL PERCEN(P,X,N,IWRITE,XTEMP,MAXNXT,P995,IBUGA3,IERROR)
143        P=0.135
144        CALL PERCEN(P,X,N,IWRITE,XTEMP,MAXNXT,P005,IBUGA3,IERROR)
145      ELSE
146        P=99.5
147        CALL PERCEN(P,X,N,IWRITE,XTEMP,MAXNXT,P995,IBUGA3,IERROR)
148        P=0.5
149        CALL PERCEN(P,X,N,IWRITE,XTEMP,MAXNXT,P005,IBUGA3,IERROR)
150      ENDIF
151C
152C               **************************************************
153C               **  STEP 3--                                    **
154C               **  COMPUTE THE CNP RATIO                       **
155C               **************************************************
156C
157      NUM=ENGUSL-ENGLSL
158      IF(NUM.LE.0.0)NUM=0.0D0
159      DEN=P995-P005
160      IF(DEN.GT.0.0)XCNP=NUM/DEN
161C
162C               *******************************
163C               **  STEP 3--                 **
164C               **  WRITE OUT A LINE         **
165C               **  OF SUMMARY INFORMATION.  **
166C               *******************************
167C
168      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
169        WRITE(ICOUT,999)
170        CALL DPWRST('XXX','BUG ')
171        WRITE(ICOUT,811)N,XCNP
172  811   FORMAT('THE CNP OF THE ',I8,' OBSERVATIONS = ',G15.7)
173        CALL DPWRST('XXX','BUG ')
174      ENDIF
175C
176C               *****************
177C               **  STEP 90--  **
178C               **  EXIT.      **
179C               *****************
180C
181 9000 CONTINUE
182      IF(IBUGA3.EQ.'ON')THEN
183        WRITE(ICOUT,999)
184        CALL DPWRST('XXX','BUG ')
185        WRITE(ICOUT,9011)
186 9011   FORMAT('***** AT THE END       OF CP--')
187        CALL DPWRST('XXX','BUG ')
188        WRITE(ICOUT,9012)IBUGA3,IERROR
189 9012   FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
190        CALL DPWRST('XXX','BUG ')
191        WRITE(ICOUT,9017)NUM,DEN,XCNP
192 9017   FORMAT('NUM,DEN,XCNP = ',3G15.7)
193        CALL DPWRST('XXX','BUG ')
194      ENDIF
195C
196      RETURN
197      END
198      SUBROUTINE CNPK(X,N,XTEMP,MAXNXT,ENGLSL,ENGUSL,IWRITE,ICNPKD,
199     1                XCNPK,
200     1                IBUGA3,IERROR)
201C
202C     PURPOSE--THIS SUBROUTINE COMPUTES THE SAMPLE CNPK
203C              (PROCESS CAPABILITY INDEX) OF THE DATA IN THE INPUT
204C              VECTOR X.
205C              CNPK = MIN(A,B)
206C              WHERE:
207C                  A = (USL-MEDIAN)/(P(.995)-MEDIAN)
208C                  B = (MEDIAN-LSL)/(MEDIAN-P(.005))
209C                  P = THE PERCENTILE FUNCTION
210C     NOTE--SUPPORT OPTIONAL FORMULA THAT SEEMS TO BE MORE
211C           PREVALENT IN THE LITERATURE:
212C
213C              CNPK = MIN(A,B)
214C              WHERE:
215C                  A = (USL-MEDIAN)/((P(.99865)-P(.00135))/2)
216C                  B = (MEDIAN-LSL)/((P(.99865)-P(.00135))/2)
217C                  P = THE PERCENTILE FUNCTION
218C     NOTE--CNPK IS A MEASURE OF PROCESS ACCURACY--
219C           COMBINING BOTH PRECISION AND UNBIASEDNESS.
220C           IT IS A NON-PARAMETERIC METHOD FOR THE CPK STATISTIC
221C           THAT IS RECOMMENDED WHEN THE DATA ARE NOT NORMAL.
222C     NOTE--THE CNPK INDEX IS A MEASURE WHICH TAKES ON THE VALUES 0 TO
223C           INFINITY.  A GOOD PROCESS YIELDS VALUES OF CNPK
224C           WHICH ARE LARGE (ABOVE 2);
225C           VALUES OF CNPK FROM 0.5 TO 1.0 ARE TYPICAL.
226C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
227C                                (UNSORTED OR SORTED) OBSERVATIONS.
228C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
229C                                IN THE VECTOR X.
230C                     --ENGLSL = LOWER (ENGINEERING) SPEC LIMIT
231C                     --ENGUSL = UPPER (ENGINEERING) SPEC LIMIT
232C     OUTPUT ARGUMENTS--CNPK    = THE SINGLE PRECISION VALUE OF THE
233C                                COMPUTED SAMPLE CNPK
234C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
235C             SAMPLE CNPK INDEX
236C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
237C                   OF N FOR THIS SUBROUTINE.
238C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
239C     FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT.
240C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
241C     LANGUAGE--ANSI FORTRAN (1977)
242C     REFERENCES--AFP 800-7. "USAF R&M 2000 PROCESS", DEPARTMENT OF
243C                 THE AIR FORCE, HQ USAF, WASHINGTON, DC GPO, 1 OCT
244C                 1988. (THIS ISN'T THE RIGHT DOCUMENT, NOT SURE
245C                 WHICH DOCUMENT ACTUALLY HAS THE TECHNICAL DETAILS).
246C               --PEARN, TAI, HSIAO, AND AO (2014), "APPROXIMATELY
247C                 UNBIASED ESTIMATOR FOR NON-NORMAL PROCESS
248C                 CAPABILITY INDEX", JOURNAL OF TESTING AND
249C                 EVALUATION, VOL. 42, NO. 6, PP. 1-10.
250C               --CHEN AND DING (2001), "A NEW PROCESS CAPABILITY
251C                 INDEX FOR NON-NORMAL DISTRIBUTIONS", INTERNATIONAL
252C                 JOURNAL OF QUALITY & RELIABILITY MANAGEMENT,
253C                 VOL. 18, NO. 7, PP. 762-770.
254C     WRITTEN BY--JAMES J. FILLIBEN
255C                 STATISTICAL ENGINEERING DIVISION
256C                 INFORMATION TECHNOLOGY LABORATORY
257C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
258C                 GAITHERSBURG, MD 20899
259C                 PHONE--301-975-2855
260C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
261C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
262C     LANGUAGE--ANSI FORTRAN (1977)
263C     VERSION NUMBER--99.3
264C     ORIGINAL VERSION--MARCH     1999.
265C     UPDATED         --APRIL     2015. SUPPORT ALTERNATIVE DEFINITION
266C
267C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
268C
269      CHARACTER*4 ICNPKD
270      CHARACTER*4 IWRITE
271      CHARACTER*4 IBUGA3
272      CHARACTER*4 IERROR
273C
274      CHARACTER*4 ISUBN1
275      CHARACTER*4 ISUBN2
276C
277C---------------------------------------------------------------------
278C
279      DIMENSION X(*)
280      DIMENSION XTEMP(*)
281C
282C---------------------------------------------------------------------
283C
284      INCLUDE 'DPCOP2.INC'
285C
286C-----START POINT-----------------------------------------------------
287C
288      ISUBN1='CNPK'
289      ISUBN2='    '
290      IERROR='NO'
291C
292      DMEAN=0.0D0
293      XCNPK=0.0
294C
295      IF(IBUGA3.EQ.'ON')THEN
296        WRITE(ICOUT,999)
297  999   FORMAT(1X)
298        CALL DPWRST('XXX','BUG ')
299        WRITE(ICOUT,51)
300   51   FORMAT('***** AT THE BEGINNING OF CNPK--')
301        CALL DPWRST('XXX','BUG ')
302        WRITE(ICOUT,52)IBUGA3,N,ENGUSL,ENGLSL
303   52   FORMAT('IBUGA3,N,ENGUSL,ENGLSL = ',A4,2X,I8,2G15.7)
304        CALL DPWRST('XXX','BUG ')
305        DO55I=1,N
306         WRITE(ICOUT,56)I,X(I)
307   56    FORMAT('I,X(I) = ',I8,G15.7)
308         CALL DPWRST('XXX','BUG ')
309   55   CONTINUE
310      ENDIF
311C
312C               ********************************************
313C               **  COMPUTE PROCESS CAPABILITY INDEX CNPK  **
314C               ********************************************
315C
316C               ********************************************
317C               **  STEP 1--                              **
318C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
319C               ********************************************
320C
321      AN=N
322C
323      IF(N.LT.1)THEN
324        IERROR='YES'
325        WRITE(ICOUT,999)
326        CALL DPWRST('XXX','BUG ')
327        WRITE(ICOUT,111)
328  111   FORMAT('***** ERROR IN CNPK--')
329        CALL DPWRST('XXX','BUG ')
330        WRITE(ICOUT,112)
331  112   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ',
332     1         'VARIABLE IS NON-POSITIVE.')
333        CALL DPWRST('XXX','BUG ')
334        WRITE(ICOUT,117)N
335  117   FORMAT('      THE NUMBER OF OBSERVATIONS HERE = ',I8,'.')
336        CALL DPWRST('XXX','BUG ')
337        GOTO9000
338      ELSEIF(N.EQ.1)THEN
339        GOTO9000
340      ENDIF
341C
342      HOLD=X(1)
343      DO135I=2,N
344        IF(X(I).NE.HOLD)GOTO139
345  135 CONTINUE
346      GOTO9000
347  139 CONTINUE
348C
349C               ****************************************
350C               **  STEP 2--                          **
351C               **  COMPUTE THE MEDIAN AND PERCENTILE **
352C               **  POINTS                            **
353C               ****************************************
354C
355      IWRITE='OFF'
356      CALL MEDIAN(X,N,IWRITE,XTEMP,MAXNXT,XMED,IBUGA3,IERROR)
357      IF(ICNPKD.EQ.'PEAR')THEN
358        P=99.865
359        CALL PERCEN(P,X,N,IWRITE,XTEMP,MAXNXT,P995,IBUGA3,IERROR)
360        P=0.135
361        CALL PERCEN(P,X,N,IWRITE,XTEMP,MAXNXT,P005,IBUGA3,IERROR)
362      ELSE
363        P=99.5
364        CALL PERCEN(P,X,N,IWRITE,XTEMP,MAXNXT,P995,IBUGA3,IERROR)
365        P=0.5
366        CALL PERCEN(P,X,N,IWRITE,XTEMP,MAXNXT,P005,IBUGA3,IERROR)
367      ENDIF
368C
369C               **************************************************
370C               **  STEP 3--                                    **
371C               **  COMPUTE THE CNPK RATIO                      **
372C               **************************************************
373C
374      IF(ICNPKD.EQ.'PEAR')THEN
375        DENOM=(P995 - P005)/2.0
376        UPPER=(ENGUSL-XMED)/DENOM
377        ALOWER=(XMED-ENGLSL)/DENOM
378        XCNPK=MIN(UPPER,ALOWER)
379      ELSE
380        UPPER=(ENGUSL-XMED)/(P995-XMED)
381        ALOWER=(XMED-ENGLSL)/(XMED-P005)
382        XCNPK=MIN(UPPER,ALOWER)
383      ENDIF
384C
385C               *******************************
386C               **  STEP 3--                 **
387C               **  WRITE OUT A LINE         **
388C               **  OF SUMMARY INFORMATION.  **
389C               *******************************
390C
391      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
392        WRITE(ICOUT,999)
393        CALL DPWRST('XXX','BUG ')
394        WRITE(ICOUT,811)N,XCNPK
395  811   FORMAT('THE CNPK OF THE ',I8,' OBSERVATIONS = ',
396     1         G15.7)
397        CALL DPWRST('XXX','BUG ')
398      ENDIF
399C
400C               *****************
401C               **  STEP 90--  **
402C               **  EXIT.      **
403C               *****************
404C
405 9000 CONTINUE
406      IF(IBUGA3.EQ.'ON')THEN
407        WRITE(ICOUT,999)
408        CALL DPWRST('XXX','BUG ')
409        WRITE(ICOUT,9011)
410 9011   FORMAT('***** AT THE END       OF CNPK--')
411        CALL DPWRST('XXX','BUG ')
412        WRITE(ICOUT,9012)IBUGA3,IERROR
413 9012   FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
414        CALL DPWRST('XXX','BUG ')
415        WRITE(ICOUT,9014)XMED,P005,P995
416 9014   FORMAT('XMED,P005,P995 = ',3G15.7)
417        CALL DPWRST('XXX','BUG ')
418        WRITE(ICOUT,9016)UPPER,ALOWER,XCNPK
419 9016   FORMAT('UPPER,ALOWER ,XCNPK= ',3G15.7)
420        CALL DPWRST('XXX','BUG ')
421      ENDIF
422C
423      RETURN
424      END
425      SUBROUTINE CNPM(X,N,XTEMP,MAXNXT,ENGLSL,ENGUSL,TARGET,IWRITE,
426     1                ICNPKD,XCNPM,
427     1                IBUGA3,IERROR)
428C
429C     PURPOSE--THIS SUBROUTINE COMPUTES THE SAMPLE CNPM PROCESS
430C              CAPABILITY INDEX OF THE DATA IN THE INPUT VECTOR X.
431C              THIS IS A NON-PARAMETRIC VERSION OF THE CPM STATISTIC.
432C
433C                 CNPM = (USL - LSL)/
434C                        [6*SQRT{((P(0.99865)-P(0.00135)/6)**2 +
435C                        (MEDIAN - TARGET)**2}]
436C
437C           WHERE P(x) IS THE PERCENTILE FUNCTION.  THIS HAS COVERAGE
438C           COMPARABLE TO THE NORMAL-BASED CPM STATISTIC (+/- 3*SIGMA).
439C           AN ALTERNATIVE DEFINITION HAS 99% COVERAGE AND USES
440C           P(0.995) AND P(0.005).
441C     NOTE--CNPM IS A MEASURE OF PROCESS ACCURACY--
442C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
443C                                (UNSORTED OR SORTED) OBSERVATIONS.
444C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
445C                                IN THE VECTOR X.
446C                     --ENGLSL = LOWER (ENGINEERING) SPEC LIMIT
447C                     --ENGUSL = UPPER (ENGINEERING) SPEC LIMIT
448C                     --TARGET = TARGET (ENGINEERING) SPEC LIMIT
449C     OUTPUT ARGUMENTS--XCNPM  = THE SINGLE PRECISION VALUE OF THE
450C                                COMPUTED SAMPLE CNPM
451C                     --XLCL   = LOWER 95% CONFIDENCE INTERVAL
452C                     --XUCL   = UPPER 95% CONFIDENCE INTERVAL
453C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE SAMPLE CPM INDEX
454C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
455C                   OF N FOR THIS SUBROUTINE.
456C     OTHER DATAPAC   SUBROUTINES NEEDED--MEAN AND SD.
457C     FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT.
458C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
459C     LANGUAGE--ANSI FORTRAN (1977)
460C     REFERENCES--NORMA HUBELE, ARIZONA STATE
461C               --CHEN AND DING (2001), "A NEW PROCESS CAPABILITY
462C                 INDEX FOR NON-NORMAL DISTRIBUTIONS", INTERNATIONAL
463C                 JOURNAL OF QUALITY & RELIABILITY MANAGEMENT,
464C                 VOL. 18, NO. 7, PP. 762-770.
465C     WRITTEN BY--ALAN HECKERT
466C                 STATISTICAL ENGINEERING DIVISION
467C                 INFORMATION TECHNOLOGY LABORATORY
468C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
469C                 GAITHERSBURG, MD 20899
470C                 PHONE--301-975-2899
471C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
472C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
473C     LANGUAGE--ANSI FORTRAN (1977)
474C     VERSION NUMBER--2015.04
475C     ORIGINAL VERSION--APRIL     2015.
476C
477C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
478C
479      CHARACTER*4 ICNPKD
480      CHARACTER*4 IWRITE
481      CHARACTER*4 IBUGA3
482      CHARACTER*4 IERROR
483C
484      CHARACTER*4 ISUBN1
485      CHARACTER*4 ISUBN2
486C
487      REAL NUM
488C
489C---------------------------------------------------------------------
490C
491      DIMENSION X(*)
492      DIMENSION XTEMP(*)
493C
494C---------------------------------------------------------------------
495C
496      INCLUDE 'DPCOP2.INC'
497C
498C-----START POINT-----------------------------------------------------
499C
500      ISUBN1='CNPM'
501      ISUBN2='    '
502      IERROR='NO'
503C
504      XCNPM=0.0
505C
506      IF(IBUGA3.EQ.'ON')THEN
507        WRITE(ICOUT,999)
508  999   FORMAT(1X)
509        CALL DPWRST('XXX','BUG ')
510        WRITE(ICOUT,51)
511   51   FORMAT('***** AT THE BEGINNING OF CNPM--')
512        CALL DPWRST('XXX','BUG ')
513        WRITE(ICOUT,52)IBUGA3,N,ENGUSL,ENGLSL,TARGET
514   52   FORMAT('IBUGA3,N,ENGUSL,ENGLSL,TARGET = ',A4,2X,I8,3G15.7)
515        CALL DPWRST('XXX','BUG ')
516        DO55I=1,N
517          WRITE(ICOUT,56)I,X(I)
518   56     FORMAT('I,X(I) = ',I8,G15.7)
519          CALL DPWRST('XXX','BUG ')
520   55   CONTINUE
521      ENDIF
522C
523C               ********************************************
524C               **  COMPUTE PROCESS CAPABILITY INDEX CNPM **
525C               ********************************************
526C
527C               ********************************************
528C               **  STEP 1--                              **
529C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
530C               ********************************************
531C
532      AN=N
533C
534      IF(N.LT.1)THEN
535        IERROR='YES'
536        WRITE(ICOUT,999)
537        CALL DPWRST('XXX','BUG ')
538        WRITE(ICOUT,111)
539  111   FORMAT('***** ERROR IN CNPM--')
540        CALL DPWRST('XXX','BUG ')
541        WRITE(ICOUT,112)
542  112   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ',
543     1         'VARIABLE IS NON-POSITIVE.')
544        CALL DPWRST('XXX','BUG ')
545        WRITE(ICOUT,117)N
546  117   FORMAT('      THE NUMBER OF OBSERVATIONS = ',I8,'.')
547        CALL DPWRST('XXX','BUG ')
548        GOTO9000
549      ELSEIF(N.EQ.1)THEN
550        GOTO9000
551      ENDIF
552C
553      HOLD=X(1)
554      DO135I=2,N
555        IF(X(I).NE.HOLD)GOTO139
556  135 CONTINUE
557      GOTO9000
558  139 CONTINUE
559C
560C               ****************************************
561C               **  STEP 2--                          **
562C               **  COMPUTE THE MEDIAN AND PERCENTILE **
563C               **  POINTS                            **
564C               ****************************************
565C
566      IWRITE='OFF'
567      CALL MEDIAN(X,N,IWRITE,XTEMP,MAXNXT,XMED,IBUGA3,IERROR)
568      IF(ICNPKD.EQ.'PEAR')THEN
569        P=99.865
570        CALL PERCEN(P,X,N,IWRITE,XTEMP,MAXNXT,P995,IBUGA3,IERROR)
571        P=0.135
572        CALL PERCEN(P,X,N,IWRITE,XTEMP,MAXNXT,P005,IBUGA3,IERROR)
573      ELSE
574        P=99.5
575        CALL PERCEN(P,X,N,IWRITE,XTEMP,MAXNXT,P995,IBUGA3,IERROR)
576        P=0.5
577        CALL PERCEN(P,X,N,IWRITE,XTEMP,MAXNXT,P005,IBUGA3,IERROR)
578      ENDIF
579C
580C               **************************************************
581C               **  STEP 3--                                    **
582C               **  COMPUTE THE CNPM RATIO                      **
583C               **************************************************
584C
585      NUM=ABS(ENGUSL-ENGLSL)
586      TERM1=(P995-P005)/6.0
587      TERM2=(XMED-TARGET)**2
588      DEN=6.0*SQRT(TERM1**2 + TERM2)
589      IF(DEN.GT.0.0)XCNPM=NUM/DEN
590C
591C               *******************************
592C               **  STEP 3--                 **
593C               **  WRITE OUT A LINE         **
594C               **  OF SUMMARY INFORMATION.  **
595C               *******************************
596C
597      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
598        WRITE(ICOUT,999)
599        CALL DPWRST('XXX','BUG ')
600        WRITE(ICOUT,811)N,XNCPM
601  811   FORMAT('THE CNPM OF THE ',I8,' OBSERVATIONS = ',G15.7)
602        CALL DPWRST('XXX','BUG ')
603      ENDIF
604C
605C               *****************
606C               **  STEP 90--  **
607C               **  EXIT.      **
608C               *****************
609C
610 9000 CONTINUE
611      IF(IBUGA3.EQ.'ON')THEN
612        WRITE(ICOUT,999)
613        CALL DPWRST('XXX','BUG ')
614        WRITE(ICOUT,9011)
615 9011   FORMAT('***** AT THE END       OF CNPM--')
616        CALL DPWRST('XXX','BUG ')
617        WRITE(ICOUT,9012)IBUGA3,IERROR
618 9012   FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
619        CALL DPWRST('XXX','BUG ')
620        WRITE(ICOUT,9014)XMED,P005,P995
621 9014   FORMAT('XMED,P005,P995 = ',3G15.7)
622        CALL DPWRST('XXX','BUG ')
623        WRITE(ICOUT,9016)NUM,DEN,XCNPM
624 9016   FORMAT('NUM,DEN,XCNPM= ',3G15.7)
625        CALL DPWRST('XXX','BUG ')
626      ENDIF
627C
628      RETURN
629      END
630      SUBROUTINE CNPMK(X,N,XTEMP1,MAXNXT,ENGLSL,ENGUSL,TARGET,IWRITE,
631     1                 ICNPKD,XCNPMK,
632     1                 IBUGA3,IERROR)
633C
634C     PURPOSE--THIS SUBROUTINE COMPUTES THE SAMPLE CNPMK PROCESS
635C              CAPABILITY INDEX OF THE DATA IN THE INPUT VECTOR X.
636C              THIS IS A NON-PARAMETRIC VERSION OF THE CPMK STATISTIC.
637C
638C                CNPMK = min{(USL - MED,MED-LSL)}/
639C                        [3*SQRT{((P(0.99865)-P(0.00135)/6)**2 +
640C                        (MEDIAN - TARGET)**2}]
641C
642C           WHERE P(x) IS THE PERCENTILE FUNCTION.  THIS HAS COVERAGE
643C           COMPARABLE TO THE NORMAL-BASED CPM STATISTIC (+/- 3*SIGMA).
644C           AN ALTERNATIVE DEFINITION HAS 99% COVERAGE AND USES
645C           P(0.995) AND P(0.005).
646C     NOTE--CNPM IS A MEASURE OF PROCESS ACCURACY--
647C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
648C                                (UNSORTED OR SORTED) OBSERVATIONS.
649C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
650C                                IN THE VECTOR X.
651C                     --ENGLSL = LOWER (ENGINEERING) SPEC LIMIT
652C                     --ENGUSL = UPPER (ENGINEERING) SPEC LIMIT
653C                     --TARGET = TARGET (ENGINEERING) SPEC LIMIT
654C     OUTPUT ARGUMENTS--XCNPMK = THE SINGLE PRECISION VALUE OF THE
655C                                COMPUTED SAMPLE CNPMK
656C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE SAMPLE CPMK INDEX
657C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
658C                   OF N FOR THIS SUBROUTINE.
659C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE
660C     FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT.
661C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
662C     LANGUAGE--ANSI FORTRAN (1977)
663C     REFERENCES--CHEN AND DING (2001), "A NEW PROCESS CAPABILITY
664C                 INDEX FOR NON-NORMAL DISTRIBUTIONS", INTERNATIONAL
665C                 JOURNAL OF QUALITY & RELIABILITY MANAGEMENT,
666C                 VOL. 18, NO. 7, PP. 762-770.
667C     WRITTEN BY--ALAN HECKERT
668C                 STATISTICAL ENGINEERING DIVISION
669C                 INFORMATION TECHNOLOGY LABORATORY
670C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
671C                 GAITHERSBURG, MD 20899
672C                 PHONE--301-975-2899
673C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
674C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
675C     LANGUAGE--ANSI FORTRAN (1977)
676C     VERSION NUMBER--2015.04
677C     ORIGINAL VERSION--APRIL     2015.
678C
679C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
680C
681      CHARACTER*4 ICNPKD
682      CHARACTER*4 IWRITE
683      CHARACTER*4 IBUGA3
684      CHARACTER*4 IERROR
685C
686      CHARACTER*4 ISUBN1
687      CHARACTER*4 ISUBN2
688C
689      REAL NUM
690C
691C---------------------------------------------------------------------
692C
693      DIMENSION X(*)
694      DIMENSION XTEMP1(*)
695C
696C---------------------------------------------------------------------
697C
698      INCLUDE 'DPCOP2.INC'
699C
700C-----START POINT-----------------------------------------------------
701C
702      ISUBN1='CNPM'
703      ISUBN2='K   '
704      IERROR='NO'
705C
706      XCNPMK=0.0
707C
708      IF(IBUGA3.EQ.'ON')THEN
709        WRITE(ICOUT,999)
710  999   FORMAT(1X)
711        CALL DPWRST('XXX','BUG ')
712        WRITE(ICOUT,51)
713   51   FORMAT('***** AT THE BEGINNING OF CNPMK--')
714        CALL DPWRST('XXX','BUG ')
715        WRITE(ICOUT,52)IBUGA3,N,ENGUSL,ENGLSL,TARGET
716   52   FORMAT('IBUGA3,N,ENGUSL,ENGLSL,TARGET = ',A4,2X,I8,3G15.7)
717        CALL DPWRST('XXX','BUG ')
718        DO55I=1,N
719          WRITE(ICOUT,56)I,X(I)
720   56     FORMAT('I,X(I) = ',I8,G15.7)
721          CALL DPWRST('XXX','BUG ')
722   55   CONTINUE
723      ENDIF
724C
725C               ********************************************
726C               **  COMPUTE PROCESS CAPABILITY INDEX CNPM **
727C               ********************************************
728C
729C               ********************************************
730C               **  STEP 1--                              **
731C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
732C               ********************************************
733C
734      AN=N
735C
736      IF(N.LT.1)THEN
737        IERROR='YES'
738        WRITE(ICOUT,999)
739        CALL DPWRST('XXX','BUG ')
740        WRITE(ICOUT,111)
741  111   FORMAT('***** ERROR IN CNPMK--')
742        CALL DPWRST('XXX','BUG ')
743        WRITE(ICOUT,112)
744  112   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ',
745     1         'VARIABLE IS NON-POSITIVE.')
746        CALL DPWRST('XXX','BUG ')
747        WRITE(ICOUT,117)N
748  117   FORMAT('      THE NUMBER OF OBSERVATIONS = ',I8,'.')
749        CALL DPWRST('XXX','BUG ')
750        GOTO9000
751      ELSEIF(N.EQ.1)THEN
752        GOTO9000
753      ENDIF
754C
755      HOLD=X(1)
756      DO135I=2,N
757        IF(X(I).NE.HOLD)GOTO139
758  135 CONTINUE
759      GOTO9000
760  139 CONTINUE
761C
762C               ****************************************
763C               **  STEP 2--                          **
764C               **  COMPUTE THE MEDIAN AND PERCENTILE **
765C               **  POINTS                            **
766C               ****************************************
767C
768      IWRITE='OFF'
769      CALL MEDIAN(X,N,IWRITE,XTEMP1,MAXNXT,XMED,IBUGA3,IERROR)
770      IF(ICNPKD.EQ.'PEAR')THEN
771        P=99.865
772        CALL PERCEN(P,X,N,IWRITE,XTEMP1,MAXNXT,P995,IBUGA3,IERROR)
773        P=0.135
774        CALL PERCEN(P,X,N,IWRITE,XTEMP1,MAXNXT,P005,IBUGA3,IERROR)
775      ELSE
776        P=99.5
777        CALL PERCEN(P,X,N,IWRITE,XTEMP1,MAXNXT,P995,IBUGA3,IERROR)
778        P=0.5
779        CALL PERCEN(P,X,N,IWRITE,XTEMP1,MAXNXT,P005,IBUGA3,IERROR)
780      ENDIF
781C
782C               **************************************************
783C               **  STEP 3--                                    **
784C               **  COMPUTE THE CNPM RATIO                      **
785C               **************************************************
786C
787      UPPER=ENGUSL-XMED
788      ALOWER=XMED-ENGLSL
789      NUM=MIN(UPPER,ALOWER)
790      TERM1=(P995-P005)/6.0
791      TERM2=(XMED-TARGET)**2
792      DEN=3.0*SQRT(TERM1**2 + TERM2)
793      IF(DEN.GT.0.0)XCNPMK=NUM/DEN
794C
795C               *******************************
796C               **  STEP 3--                 **
797C               **  WRITE OUT A LINE         **
798C               **  OF SUMMARY INFORMATION.  **
799C               *******************************
800C
801      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
802        WRITE(ICOUT,999)
803        CALL DPWRST('XXX','BUG ')
804        WRITE(ICOUT,811)N,XNCPMK
805  811   FORMAT('THE CNPMK OF THE ',I8,' OBSERVATIONS = ',G15.7)
806        CALL DPWRST('XXX','BUG ')
807      ENDIF
808C
809C               *****************
810C               **  STEP 90--  **
811C               **  EXIT.      **
812C               *****************
813C
814 9000 CONTINUE
815      IF(IBUGA3.EQ.'ON')THEN
816        WRITE(ICOUT,999)
817        CALL DPWRST('XXX','BUG ')
818        WRITE(ICOUT,9011)
819 9011   FORMAT('***** AT THE END       OF CNPM--')
820        CALL DPWRST('XXX','BUG ')
821        WRITE(ICOUT,9012)IBUGA3,IERROR
822 9012   FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
823        CALL DPWRST('XXX','BUG ')
824        WRITE(ICOUT,9014)XMED,P005,P995
825 9014   FORMAT('XMED,P005,P995 = ',3G15.7)
826        CALL DPWRST('XXX','BUG ')
827        WRITE(ICOUT,9016)NUM,DEN,XCNPMK
828 9016   FORMAT('NUM,DEN,XCNPMK= ',3G15.7)
829        CALL DPWRST('XXX','BUG ')
830      ENDIF
831C
832      RETURN
833      END
834      SUBROUTINE COCODE(X,N,XREF,NREF,XPRIME,IBUGA3)
835C
836C     PURPOSE--THIS SUBROUTINE CO-CODES
837C              THE N ELEMENTS OF THE SINGLE PRECISION VECTOR X,
838C              AS DICTATED BY HOW X MATCHES XREF.
839C     IN PARTICULAR, ALL ELEMENTS IN X THAT MATCH XREF(1)
840C                    WILL GET CODED WITH 1.
841C                    ALL ELEMENTS IN X THAT MATCH XREF(2)
842C                    WILL GET CODED WITH 2.
843C                    ETC.
844C              THE OUTPUT IS, IN FACT, PLACED IN XPRIME.
845C              (X AND XREF REMAIN UNCHANGED)
846C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
847C                                OBSERVATIONS TO BE CO-CODED.
848C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
849C                                IN THE VECTOR X AND XPRIME.
850C                     --XREF   = THE SINGLE PRECISION VECTOR OF
851C                                REFERENCE OBSERVATIONS.
852C                     --NREF   = THE INTEGER NUMBER OF OBSERVATIONS
853C                                IN THE VECTOR XREF.
854C     OUTPUT ARGUMENTS--XPRIME = THE SINGLE PRECISION VECTOR
855C                                INTO WHICH THE RECODED DATA VALUES
856C                                WILL BE PLACED.
857C     OUTPUT--THE SINGLE PRECISION VECTOR XPRIME
858C             CONTAINING THE RECODED VALUES.
859C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
860C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
861C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
862C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
863C     LANGUAGE--ANSI FORTRAN (1977)
864C     WRITTEN BY--JAMES J. FILLIBEN
865C                 STATISTICAL ENGINEERING DIVISION
866C                 INFORMATION TECHNOLOGY LABORATORY
867C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
868C                 GAITHERSBURG, MD 20899
869C                 PHONE--301-975-2855
870C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
871C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
872C     ORIGINAL VERSION--JULY      1991.
873C
874C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
875C
876C---------------------------------------------------------------------
877C
878      DIMENSION X(*),XREF(*),XPRIME(*)
879      CHARACTER*4 IBUGA3
880C
881C---------------------------------------------------------------------
882C
883      INCLUDE 'DPCOP2.INC'
884C
885C-----START POINT-----------------------------------------------------
886C
887C     CHECK THE INPUT ARGUMENTS FOR ERRORS
888C
889      IF(N.LT.1)GOTO50
890      GOTO90
891   50 CONTINUE
892      WRITE(ICOUT,15)
893   15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
894     1'SORTC  SUBROUTINE IS NON-POSITIVE *****')
895      CALL DPWRST('XXX','BUG ')
896      WRITE(ICOUT,47)N
897   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
898      CALL DPWRST('XXX','BUG ')
899      RETURN
900   90 CONTINUE
901C
902      IF(IBUGA3.NE.'ON')GOTO190
903      WRITE(ICOUT,999)
904  999 FORMAT(1X)
905      CALL DPWRST('XXX','BUG ')
906      WRITE(ICOUT,110)
907  110 FORMAT('***** AT THE BEGINNING OF COCODE--')
908      CALL DPWRST('XXX','BUG ')
909      WRITE(ICOUT,111)N,NREF
910  111 FORMAT('N,NREF = ',I8,I8)
911      CALL DPWRST('XXX','BUG ')
912      DO112I=1,N
913      WRITE(ICOUT,113)I,X(I),XREF(I)
914  113 FORMAT('I,X(I),XREF(I) = ',I8,2E15.7)
915      CALL DPWRST('XXX','BUG ')
916  112 CONTINUE
917  190 CONTINUE
918C
919      DO1100I=1,N
920      XPRIME(I)=-999
921 1100 CONTINUE
922C
923      DO1200I=1,NREF
924      XREFI=XREF(I)
925      DO1300J=1,N
926      IF(X(J).EQ.XREFI)XPRIME(J)=I
927 1300 CONTINUE
928 1200 CONTINUE
929C
930      IF(IBUGA3.EQ.'ON')THEN
931        WRITE(ICOUT,999)
932        CALL DPWRST('XXX','BUG ')
933        WRITE(ICOUT,9011)
934 9011   FORMAT('***** AT THE END       OF COCODE--')
935        CALL DPWRST('XXX','BUG ')
936        WRITE(ICOUT,9012)N,NREF
937 9012   FORMAT('N,NREF = ',2I8)
938        CALL DPWRST('XXX','BUG ')
939        DO9015I=1,N
940          WRITE(ICOUT,9016)I,X(I),XREF(I),XPRIME(I)
941 9016     FORMAT('I,X(I),XREF(I),XPRIME(I) = ',I8,3G15.7)
942          CALL DPWRST('XXX','BUG ')
943 9015   CONTINUE
944      ENDIF
945C
946      RETURN
947      END
948      SUBROUTINE COCOPY(YREF,NREF,X,NX,XREF,Y,NY,IBUGA3)
949C
950C     PURPOSE--THIS SUBROUTINE CO-COPIES
951C              THE NREF ELEMENTS OF THE SINGLE PRECISION
952C              VECTOR YREF INTO THE (TYPICALLY) LONGER VECTOR Y.
953C              AS DICTATED BY HOW X MATCHES XREF.
954C     IN PARTICULAR, FOR ALL ELEMENTS IN X THAT MATCH XREF(1),
955C                    Y WILL BECOME YREF(1).
956C                    FOR ALL ELEMENTS IN X THAT MATCH XREF(2),
957C                    Y WILL BECOME YREF(2).
958C                    ETC.
959C              THE OUTPUT IS, IN FACT, PLACED IN Y.
960C              (X, XREF, AND YREF REMAIN UNCHANGED).
961C     INPUT  ARGUMENTS--YREF   = THE SINGLE PRECISION VECTOR OF
962C                                OBSERVATIONS TO BE CO-COPIED.
963C                     --NREF   = THE INTEGER NUMBER OF OBSERVATIONS
964C                                IN THE VECTOR YREF (AND XREF).
965C                     --X      = THE SINGLE PRECISION VECTOR OF
966C                                OBSERVATIONS USED FOR MATCHING .
967C                     --NX     = THE INTEGER NUMBER OF OBSERVATIONS
968C                                IN THE VECTOR X (AND Y).
969C                     --XREF   = THE SINGLE PRECISION VECTOR OF
970C                                REFERENCE OBSERVATIONS.
971C     OUTPUT ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR
972C                                INTO WHICH THE VARIOUS YREF VALUES
973C                                WILL BE COPIED.
974C                       NY     = THE INTEGER NUMBER OF ELEMENTS
975C                                IN Y (= NX)
976C     OUTPUT--THE SINGLE PRECISION VECTOR Y
977C             CONTAINING THE COPIED VALUES.
978C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
979C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
980C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
981C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
982C     LANGUAGE--ANSI FORTRAN (1977)
983C     WRITTEN BY--JAMES J. FILLIBEN
984C                 STATISTICAL ENGINEERING DIVISION
985C                 INFORMATION TECHNOLOGY LABORATORY
986C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
987C                 GAITHERSBURG, MD 20899
988C                 PHONE--301-975-2855
989C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
990C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
991C     ORIGINAL VERSION--JULY      1991.
992C
993C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
994C
995C---------------------------------------------------------------------
996C
997      DIMENSION YREF(*),X(*),XREF(*),Y(*)
998      CHARACTER*4 IBUGA3
999C
1000C---------------------------------------------------------------------
1001C
1002      INCLUDE 'DPCOP2.INC'
1003C
1004C-----START POINT-----------------------------------------------------
1005C
1006C     CHECK THE INPUT ARGUMENTS FOR ERRORS
1007C
1008      IF(NX.LT.1)GOTO50
1009      GOTO90
1010   50 CONTINUE
1011      WRITE(ICOUT,15)
1012   15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ',
1013     1'SORTC  SUBROUTINE IS NON-POSITIVE *****')
1014      CALL DPWRST('XXX','BUG ')
1015      WRITE(ICOUT,47)NX
1016   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
1017      CALL DPWRST('XXX','BUG ')
1018      NY=NX
1019      RETURN
1020   90 CONTINUE
1021C
1022      IF(IBUGA3.NE.'ON')GOTO190
1023      WRITE(ICOUT,999)
1024  999 FORMAT(1X)
1025      CALL DPWRST('XXX','BUG ')
1026      WRITE(ICOUT,110)
1027  110 FORMAT('***** AT THE BEGINNING OF COCOPY--')
1028      CALL DPWRST('XXX','BUG ')
1029      WRITE(ICOUT,111)NREF,NX
1030  111 FORMAT('NREF,NX = ',I8,I8)
1031      CALL DPWRST('XXX','BUG ')
1032      DO112I=1,NX
1033      WRITE(ICOUT,113)I,X(I),XREF(I),YREF(I)
1034  113 FORMAT('I,X(I),XREF(I),YREF(I) = ',I8,3E15.7)
1035      CALL DPWRST('XXX','BUG ')
1036  112 CONTINUE
1037  190 CONTINUE
1038C
1039      DO1100I=1,NX
1040      Y(I)=-999
1041 1100 CONTINUE
1042C
1043      DO1200I=1,NREF
1044      XREFI=XREF(I)
1045      DO1300J=1,NX
1046      IF(X(J).EQ.XREFI)Y(J)=YREF(I)
1047 1300 CONTINUE
1048 1200 CONTINUE
1049      NY=NX
1050C
1051      IF(IBUGA3.EQ.'ON')THEN
1052        WRITE(ICOUT,999)
1053        CALL DPWRST('XXX','BUG ')
1054        WRITE(ICOUT,9011)
1055 9011   FORMAT('***** AT THE END       OF COCOPY--')
1056        CALL DPWRST('XXX','BUG ')
1057        WRITE(ICOUT,9012)NREF,NX,NY
1058 9012   FORMAT('NREF,NX,NY = ',I8,I8,I8)
1059        CALL DPWRST('XXX','BUG ')
1060        DO9015I=1,NX
1061          WRITE(ICOUT,9016)I,X(I),XREF(I),YREF(I)
1062 9016     FORMAT('I,X(I),XREF(I),YREF(I) = ',I8,3E15.7)
1063          CALL DPWRST('XXX','BUG ')
1064 9015   CONTINUE
1065        DO9020I=1,NY
1066          WRITE(ICOUT,9021)I,Y(I)
1067 9021     FORMAT('I,Y(I) = ',I8,E15.7)
1068          CALL DPWRST('XXX','BUG ')
1069 9020   CONTINUE
1070      ENDIF
1071C
1072      RETURN
1073      END
1074      SUBROUTINE CODCT2(X1,X2,N,ICCTOF,ICCTG1,IWRITE,
1075     1                  Y,XIDTEM,XIDTE2,
1076     1                  IBUGA3,ISUBRO,IERROR)
1077C
1078C     PURPOSE--THIS SUBROUTINE CREATES A CODED VARIABLE FROM THE
1079C              CROSS TABULATION OF TWO GROUP-ID VARIABLES.  THIS
1080C              CAN BE USEFUL FOR COMMANDS OF THE FORM
1081C
1082C                  <COMMAND>  Y  X
1083C
1084C              WHERE X IS A GROUP-ID VARIABLE.  THIS ALLOWS US TO
1085C              USE THESE COMMANDS FOR THE CASE WHERE WE ACTUALLY
1086C              HAVE MULTIPLE GROUPS.  FOR EXAMPLE, WE CAN CREATE
1087C              A BOX PLOT OVER SEVERAL GROUPS.
1088C
1089C              THE CODING IS BASED ON THE FOLLOWING FORMULA:
1090C
1091C                  ICODE = OFFSET + (ISET1-1)*NGROUP2 + ISET2
1092C
1093C              WHERE
1094C
1095C                  OFFSET    = AN INITIAL OFFSET (DEFAULTS TO 0)
1096C                  ISET1     = I-TH DISTINCT VALUE OF GROUP 1
1097C                  ISET2     = I-TH DISTINCT VALUE OF GROUP 2
1098C                  NGROUP2   = NUMBER OF DISTINCT VALUES FOR GROUP 2
1099C
1100C              FOR PLOTS, WE MAY WANT TO SPACE GROUPS FURTHER APART.
1101C              THE ICCTG1 PARAMETER CAN BE USED TO CONTROL THIS
1102C              (I.E., WE USE THE MAXIMUM OF NGROUP2 AND ICCTG1).
1103C     INPUT  ARGUMENTS--X1     = THE SINGLE PRECISION VECTOR CONTAINING
1104C                                THE VALUES OF THE FIRST GROUP VARIABLE
1105C                     --X2     = THE SINGLE PRECISION VECTOR CONTAINING
1106C                                THE VALUES OF THE SECOND GROUP VARIABLE
1107C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
1108C                                IN THE VECTORS X1 AND X2.
1109C                     --ICCTOF = THE INTEGER PARAMETER THAT SPECIFIES
1110C                                THE OFFSET.
1111C                     --ICCTG1 = THE INTEGER PARAMETER THAT SPECIFIES
1112C                                THE SPACING BETWEEN GROUPS.
1113C     OUTPUT ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR INTO WHICH
1114C                                THE CODED VALUES WILL BE PLACED.
1115C     OUTPUT--THE SINGLE PRECISION VECTOR Y WHICH WILL CONTAIN THE CODED
1116C             VALUES CORRESPONDING TO THE OBSERVATIONS IN THE VECTORS
1117C             X1 AND X2.
1118C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
1119C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT, DISTIN.
1120C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
1121C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
1122C     LANGUAGE--ANSI FORTRAN (1977)
1123C     WRITTEN BY--JAMES J. FILLIBEN
1124C                 STATISTICAL ENGINEERING DIVISION
1125C                 INFORMATION TECHNOLOGY LABORATORY
1126C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
1127C                 GAITHERSBURG, MD 20899-8980
1128C                 PHONE--301-975-2899
1129C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
1130C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
1131C     LANGUAGE--ANSI FORTRAN (1977)
1132C     VERSION NUMBER--2009/6
1133C     ORIGINAL VERSION--JUNE      2009.
1134C
1135C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
1136C
1137      CHARACTER*4 IWRITE
1138      CHARACTER*4 IBUGA3
1139      CHARACTER*4 ISUBRO
1140      CHARACTER*4 IERROR
1141C
1142      CHARACTER*4 ISUBN1
1143      CHARACTER*4 ISUBN2
1144C
1145C---------------------------------------------------------------------
1146C
1147CCCCC INCLUDE 'DPCOPA.INC'
1148C
1149      DIMENSION X1(*)
1150      DIMENSION X2(*)
1151      DIMENSION Y(*)
1152      DIMENSION XIDTEM(*)
1153      DIMENSION XIDTE2(*)
1154C
1155C---------------------------------------------------------------------
1156C
1157      INCLUDE 'DPCOP2.INC'
1158C
1159C-----START POINT-----------------------------------------------------
1160C
1161      ISUBN1='CODC'
1162      ISUBN2='T2  '
1163C
1164      IERROR='NO'
1165C
1166      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DCT2')THEN
1167        WRITE(ICOUT,999)
1168  999   FORMAT(1X)
1169        CALL DPWRST('XXX','BUG ')
1170        WRITE(ICOUT,51)
1171   51   FORMAT('***** AT THE BEGINNING OF CODCT2--')
1172        CALL DPWRST('XXX','BUG ')
1173        WRITE(ICOUT,52)IBUGA3,ISUBRO,N,ICCTOF,ICCTG1
1174   52   FORMAT('IBUGA3,ISUBRO,N,ICCTOF,ICCTG1 = ',A4,2X,A4,2X,3I8)
1175        CALL DPWRST('XXX','BUG ')
1176        DO55I=1,N
1177          WRITE(ICOUT,56)I,X1(I),X2(I)
1178   56     FORMAT('I,X1(I),X2(I) = ',I8,2G15.7)
1179          CALL DPWRST('XXX','BUG ')
1180   55   CONTINUE
1181      ENDIF
1182C
1183C               ***********************************************************
1184C               **  STEP 2--                                             **
1185C               **  PERFORM THE CODING--                                 **
1186C               ***********************************************************
1187C
1188      CALL DISTIN(X1,N,IWRITE,XIDTEM,NGRP1,IBUGA3,IERROR)
1189      CALL SORT(XIDTEM,NGRP1,XIDTEM)
1190      CALL DISTIN(X2,N,IWRITE,XIDTE2,NGRP2,IBUGA3,IERROR)
1191      CALL SORT(XIDTE2,NGRP2,XIDTE2)
1192C
1193      IFACT1=MAX(NGRP2,ICCTG1)
1194C
1195      DO100I=1,N
1196C
1197        DO200J=1,NGRP1
1198          DO300K=1,NGRP2
1199C
1200            IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DCT2')THEN
1201              WRITE(ICOUT,301)I,J,K
1202  301         FORMAT('I,J,K = ',3I8)
1203              CALL DPWRST('XXX','BUG ')
1204              WRITE(ICOUT,302)X1(I),X2(I),XIDTEM(J),XIDTE2(K)
1205  302         FORMAT('X1(I),X2(I),XIDTEM(J),XIDTE2(K)=',4G15.7)
1206              CALL DPWRST('XXX','BUG ')
1207            ENDIF
1208C
1209            IF(X1(I).EQ.XIDTEM(J) .AND. X2(I).EQ.XIDTE2(K))THEN
1210              IINDX=ICCTOF + (J-1)*IFACT1 + K
1211              Y(I)=REAL(IINDX)
1212              GOTO100
1213            ENDIF
1214  300     CONTINUE
1215  200   CONTINUE
1216C
1217        WRITE(ICOUT,999)
1218        CALL DPWRST('XXX','BUG ')
1219        WRITE(ICOUT,305)
1220  305   FORMAT('***** INTERNAL ERROR IN CODCT2 SUBROUTINE--')
1221        CALL DPWRST('XXX','BUG ')
1222        WRITE(ICOUT,310)I
1223  310   FORMAT('      NO CODE FOUND FOR ELEMENT NUMBER ',I8)
1224        CALL DPWRST('XXX','BUG ')
1225        WRITE(ICOUT,312)X1(I)
1226  312   FORMAT('      GROUP-ID VARIABLE 1 = ',G15.7)
1227        CALL DPWRST('XXX','BUG ')
1228        WRITE(ICOUT,313)X2(I)
1229  313   FORMAT('      GROUP-ID VARIABLE 2 = ',G15.7)
1230        CALL DPWRST('XXX','BUG ')
1231        IERROR='YES'
1232        GOTO9000
1233C
1234  100 CONTINUE
1235C
1236C               ******************************
1237C               **  STEP 3--                **
1238C               **  WRITE OUT A FEW LINES   **
1239C               **  OF SUMMARY INFORMATION  **
1240C               **  ABOUT THE CODING.       **
1241C               ******************************
1242C
1243      IF(IFEEDB.EQ.'OFF')GOTO890
1244      IF(IWRITE.EQ.'OFF')GOTO890
1245      WRITE(ICOUT,999)
1246      CALL DPWRST('XXX','BUG ')
1247      WRITE(ICOUT,811)NGRP1*NGRP2
1248  811 FORMAT('NUMBER OF DISTINCT CODE VALUES = ',I8)
1249      CALL DPWRST('XXX','BUG ')
1250      WRITE(ICOUT,999)
1251      CALL DPWRST('XXX','BUG ')
1252  890 CONTINUE
1253C
1254C               *****************
1255C               **  STEP 90--  **
1256C               **  EXIT.      **
1257C               *****************
1258C
1259 9000 CONTINUE
1260C
1261      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DCT2')THEN
1262        WRITE(ICOUT,999)
1263        CALL DPWRST('XXX','BUG ')
1264        WRITE(ICOUT,9011)
1265 9011   FORMAT('***** AT THE END       OF CODCT2--')
1266        CALL DPWRST('XXX','BUG ')
1267        WRITE(ICOUT,9013)NGRP1,NGRP2
1268 9013   FORMAT('NGRP1,NGRP2 = ',2I8)
1269        CALL DPWRST('XXX','BUG ')
1270        DO9015I=1,N
1271          WRITE(ICOUT,9016)I,X1(I),X2(I),Y(I)
1272 9016     FORMAT('I,X1(I),X2(I),Y(I) = ',I8,3G15.7)
1273          CALL DPWRST('XXX','BUG ')
1274 9015   CONTINUE
1275      ENDIF
1276C
1277      RETURN
1278      END
1279      SUBROUTINE CODCT3(X1,X2,X3,N,ICCTOF,ICCTG1,ICCTG2,IWRITE,
1280     1                  Y,XIDTEM,XIDTE2,XIDTE3,
1281     1                  IBUGA3,ISUBRO,IERROR)
1282C
1283C     PURPOSE--THIS SUBROUTINE CREATES A CODED VARIABLE FROM THE
1284C              CROSS TABULATION OF THREE GROUP-ID VARIABLES.  THIS
1285C              CAN BE USEFUL FOR COMMANDS OF THE FORM
1286C
1287C                  <COMMAND>  Y  X
1288C
1289C              WHERE X IS A GROUP-ID VARIABLE.  THIS ALLOWS US TO
1290C              USE THESE COMMANDS FOR THE CASE WHERE WE ACTUALLY
1291C              HAVE MULTIPLE GROUPS.  FOR EXAMPLE, WE CAN CREATE
1292C              A BOX PLOT OVER SEVERAL GROUPS.
1293C
1294C              THE CODING IS BASED ON THE FOLLOWING FORMULA:
1295C
1296C                  ICODE = OFFSET + (ISET1-1)*NGROUP2*NGROUP3 +
1297C                                   (ISET2-1)*NGROUP3 + ISET3
1298C
1299C              WHERE
1300C
1301C                  OFFSET    = AN INITIAL OFFSET (DEFAULTS TO 0)
1302C                  ISET1     = I-TH DISTINCT VALUE OF GROUP 1
1303C                  ISET2     = I-TH DISTINCT VALUE OF GROUP 2
1304C                  ISET3     = I-TH DISTINCT VALUE OF GROUP 3
1305C                  NGROUP2   = NUMBER OF DISTINCT VALUES FOR GROUP 2
1306C                  NGROUP3   = NUMBER OF DISTINCT VALUES FOR GROUP 3
1307C
1308C              FOR PLOTS, WE MAY WANT TO SPACE GROUPS FURTHER APART.
1309C              THE ICCTG1 AND ICCTG2 PARAMETERS CAN BE USED TO CONTROL
1310C              THIS (I.E., WE USE:
1311C
1312C                   THE MAXIMUM OF NGROUP2 AND ICCTG1
1313C                   THE MAXIMUM OF NGROUP3 AND ICCTG2
1314C
1315C     INPUT  ARGUMENTS--X1     = THE SINGLE PRECISION VECTOR CONTAINING
1316C                                THE VALUES OF THE FIRST GROUP VARIABLE
1317C                     --X2     = THE SINGLE PRECISION VECTOR CONTAINING
1318C                                THE VALUES OF THE SECOND GROUP VARIABLE
1319C                     --X3     = THE SINGLE PRECISION VECTOR CONTAINING
1320C                                THE VALUES OF THE THIRD GROUP VARIABLE
1321C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
1322C                                IN THE VECTORS X1, X2 AND X3.
1323C                     --ICCTOF = THE INTEGER PARAMETER THAT SPECIFIES
1324C                                THE OFFSET.
1325C                     --ICCTG1 = THE INTEGER PARAMETER THAT SPECIFIES
1326C                                THE SPACING FOR GROUP 2.
1327C                     --ICCTG2 = THE INTEGER PARAMETER THAT SPECIFIES
1328C                                THE SPACING FOR GROUP 3.
1329C     OUTPUT ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR INTO WHICH
1330C                                THE CODED VALUES WILL BE PLACED.
1331C     OUTPUT--THE SINGLE PRECISION VECTOR Y WHICH WILL CONTAIN THE CODED
1332C             VALUES CORRESPONDING TO THE OBSERVATIONS IN THE VECTORS
1333C             X1, X2 AND X3.
1334C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
1335C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT, DISTIN.
1336C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
1337C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
1338C     LANGUAGE--ANSI FORTRAN (1977)
1339C     WRITTEN BY--JAMES J. FILLIBEN
1340C                 STATISTICAL ENGINEERING DIVISION
1341C                 INFORMATION TECHNOLOGY LABORATORY
1342C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
1343C                 GAITHERSBURG, MD 20899-8980
1344C                 PHONE--301-975-2899
1345C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
1346C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
1347C     LANGUAGE--ANSI FORTRAN (1977)
1348C     VERSION NUMBER--2009/6
1349C     ORIGINAL VERSION--JUNE      2009.
1350C
1351C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
1352C
1353      CHARACTER*4 IWRITE
1354      CHARACTER*4 IBUGA3
1355      CHARACTER*4 ISUBRO
1356      CHARACTER*4 IERROR
1357C
1358      CHARACTER*4 ISUBN1
1359      CHARACTER*4 ISUBN2
1360C
1361C---------------------------------------------------------------------
1362C
1363CCCCC INCLUDE 'DPCOPA.INC'
1364C
1365      DIMENSION X1(*)
1366      DIMENSION X2(*)
1367      DIMENSION X3(*)
1368      DIMENSION Y(*)
1369      DIMENSION XIDTEM(*)
1370      DIMENSION XIDTE2(*)
1371      DIMENSION XIDTE3(*)
1372C
1373C---------------------------------------------------------------------
1374C
1375      INCLUDE 'DPCOP2.INC'
1376C
1377C-----START POINT-----------------------------------------------------
1378C
1379      ISUBN1='CODC'
1380      ISUBN2='T3  '
1381C
1382      IERROR='NO'
1383C
1384      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DCT3')THEN
1385        WRITE(ICOUT,999)
1386  999   FORMAT(1X)
1387        CALL DPWRST('XXX','BUG ')
1388        WRITE(ICOUT,51)
1389   51   FORMAT('***** AT THE BEGINNING OF CODCT3--')
1390        CALL DPWRST('XXX','BUG ')
1391        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
1392   52   FORMAT('IBUGA3,ISUBRO,N = ',A4,2X,A4,2X,I8)
1393        CALL DPWRST('XXX','BUG ')
1394        DO55I=1,N
1395          WRITE(ICOUT,56)I,X1(I),X2(I),X3(I)
1396   56     FORMAT('I,X1(I),X2(I),X3(I) = ',I8,3G15.7)
1397          CALL DPWRST('XXX','BUG ')
1398   55   CONTINUE
1399      ENDIF
1400C
1401C               ***********************************************************
1402C               **  STEP 2--                                             **
1403C               **  PERFORM THE CODING--                                 **
1404C               ***********************************************************
1405C
1406      CALL DISTIN(X1,N,IWRITE,XIDTEM,NGRP1,IBUGA3,IERROR)
1407      CALL SORT(XIDTEM,NGRP1,XIDTEM)
1408      CALL DISTIN(X2,N,IWRITE,XIDTE2,NGRP2,IBUGA3,IERROR)
1409      CALL SORT(XIDTE2,NGRP2,XIDTE2)
1410      CALL DISTIN(X3,N,IWRITE,XIDTE3,NGRP3,IBUGA3,IERROR)
1411      CALL SORT(XIDTE3,NGRP3,XIDTE3)
1412C
1413      IFACT1=MAX(NGRP2,ICCTG1)
1414      IFACT2=MAX(NGRP3,ICCTG2)
1415C
1416      DO100I=1,N
1417C
1418        DO200J=1,NGRP1
1419          DO300K=1,NGRP2
1420            DO400L=1,NGRP3
1421C
1422            IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DCT3')THEN
1423              WRITE(ICOUT,301)I,J,K,L
1424  301         FORMAT('I,J,K,L = ',4I8)
1425              CALL DPWRST('XXX','BUG ')
1426              WRITE(ICOUT,302)X1(I),X2(I),X3(I)
1427  302         FORMAT('X1(I),X2(I),X3(I)=',3G15.7)
1428              CALL DPWRST('XXX','BUG ')
1429              WRITE(ICOUT,303)XIDTEM(J),XIDTE2(K),XIDTE3(L)
1430  303         FORMAT('XIDTEM(J),XIDTE2(K),XIDTE3(L)=',3G15.7)
1431              CALL DPWRST('XXX','BUG ')
1432            ENDIF
1433C
1434            IF(X1(I).EQ.XIDTEM(J) .AND. X2(I).EQ.XIDTE2(K) .AND.
1435     1         X3(I).EQ.XIDTE3(L))THEN
1436              IINDX=ICCTOF + (J-1)*IFACT1*IFACT2 + (K-1)*IFACT2 + L
1437              Y(I)=REAL(IINDX)
1438              GOTO100
1439            ENDIF
1440  400     CONTINUE
1441  300     CONTINUE
1442  200   CONTINUE
1443C
1444        WRITE(ICOUT,999)
1445        CALL DPWRST('XXX','BUG ')
1446        WRITE(ICOUT,305)
1447  305   FORMAT('***** INTERNAL ERROR IN CODCT3 SUBROUTINE--')
1448        CALL DPWRST('XXX','BUG ')
1449        WRITE(ICOUT,310)I
1450  310   FORMAT('      NO CODE FOUND FOR ELEMENT NUMBER ',I8)
1451        CALL DPWRST('XXX','BUG ')
1452        WRITE(ICOUT,312)X1(I)
1453  312   FORMAT('      GROUP-ID VARIABLE 1 = ',G15.7)
1454        CALL DPWRST('XXX','BUG ')
1455        WRITE(ICOUT,313)X2(I)
1456  313   FORMAT('      GROUP-ID VARIABLE 2 = ',G15.7)
1457        CALL DPWRST('XXX','BUG ')
1458        WRITE(ICOUT,314)X3(I)
1459  314   FORMAT('      GROUP-ID VARIABLE 3 = ',G15.7)
1460        CALL DPWRST('XXX','BUG ')
1461        IERROR='YES'
1462        GOTO9000
1463C
1464  100 CONTINUE
1465C
1466C               ******************************
1467C               **  STEP 3--                **
1468C               **  WRITE OUT A FEW LINES   **
1469C               **  OF SUMMARY INFORMATION  **
1470C               **  ABOUT THE CODING.       **
1471C               ******************************
1472C
1473      IF(IFEEDB.EQ.'OFF')GOTO890
1474      IF(IWRITE.EQ.'OFF')GOTO890
1475      WRITE(ICOUT,999)
1476      CALL DPWRST('XXX','BUG ')
1477      WRITE(ICOUT,811)NGRP1*NGRP2*NGRP3
1478  811 FORMAT('NUMBER OF DISTINCT CODE VALUES = ',I8)
1479      CALL DPWRST('XXX','BUG ')
1480      WRITE(ICOUT,999)
1481      CALL DPWRST('XXX','BUG ')
1482  890 CONTINUE
1483C
1484C               *****************
1485C               **  STEP 90--  **
1486C               **  EXIT.      **
1487C               *****************
1488C
1489 9000 CONTINUE
1490C
1491      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DCT3')THEN
1492        WRITE(ICOUT,999)
1493        CALL DPWRST('XXX','BUG ')
1494        WRITE(ICOUT,9011)
1495 9011   FORMAT('***** AT THE END       OF CODCT3--')
1496        CALL DPWRST('XXX','BUG ')
1497        WRITE(ICOUT,9013)NGRP1,NGRP2,NGRP3
1498 9013   FORMAT('NGRP1,NGRP2,NGRP3 = ',3I8)
1499        CALL DPWRST('XXX','BUG ')
1500        DO9015I=1,N
1501          WRITE(ICOUT,9016)I,X1(I),X2(I),X3(I),Y(I)
1502 9016     FORMAT('I,X1(I),X2(I),X3(I),Y(I) = ',I8,4G15.7)
1503          CALL DPWRST('XXX','BUG ')
1504 9015   CONTINUE
1505      ENDIF
1506C
1507      RETURN
1508      END
1509      SUBROUTINE CODCT4(X1,X2,X3,X4,N,
1510     1                  ICCTOF,ICCTG1,ICCTG2,ICCTG3,IWRITE,
1511     1                  Y,XIDTEM,XIDTE2,XIDTE3,XIDTE4,
1512     1                  IBUGA3,ISUBRO,IERROR)
1513C
1514C     PURPOSE--THIS SUBROUTINE CREATES A CODED VARIABLE FROM THE
1515C              CROSS TABULATION OF FOUR GROUP-ID VARIABLES.  THIS
1516C              CAN BE USEFUL FOR COMMANDS OF THE FORM
1517C
1518C                  <COMMAND>  Y  X
1519C
1520C              WHERE X IS A GROUP-ID VARIABLE.  THIS ALLOWS US TO
1521C              USE THESE COMMANDS FOR THE CASE WHERE WE ACTUALLY
1522C              HAVE MULTIPLE GROUPS.  FOR EXAMPLE, WE CAN CREATE
1523C              A BOX PLOT OVER SEVERAL GROUPS.
1524C
1525C              THE CODING IS BASED ON THE FOLLOWING FORMULA:
1526C
1527C                  ICODE = OFFSET + (ISET1-1)*NGROUP2*NGROUP3*NGROUP4 +
1528C                                   (ISET2-1)*NGROUP3*NGROUP4 +
1529C                                   (ISET3-1)*NGROUP4 + ISET4
1530C
1531C              WHERE
1532C
1533C                  OFFSET    = AN INITIAL OFFSET (DEFAULTS TO 0)
1534C                  ISET1     = I-TH DISTINCT VALUE OF GROUP 1
1535C                  ISET2     = I-TH DISTINCT VALUE OF GROUP 2
1536C                  ISET3     = I-TH DISTINCT VALUE OF GROUP 3
1537C                  ISET4     = I-TH DISTINCT VALUE OF GROUP 4
1538C                  NGROUP2   = NUMBER OF DISTINCT VALUES FOR GROUP 2
1539C                  NGROUP3   = NUMBER OF DISTINCT VALUES FOR GROUP 3
1540C                  NGROUP4   = NUMBER OF DISTINCT VALUES FOR GROUP 4
1541C
1542C              FOR PLOTS, WE MAY WANT TO SPACE GROUPS FURTHER APART.
1543C              THE ICCTG1, ICCTG2, AND ICCTG3 PARAMETERS CAN BE USED
1544C              TO CONTROL THIS (I.E., WE USE:
1545C
1546C                   THE MAXIMUM OF NGROUP2 AND ICCTG1
1547C                   THE MAXIMUM OF NGROUP3 AND ICCTG2
1548C                   THE MAXIMUM OF NGROUP4 AND ICCTG3
1549C
1550C     INPUT  ARGUMENTS--X1     = THE SINGLE PRECISION VECTOR CONTAINING
1551C                                THE VALUES OF THE FIRST GROUP VARIABLE
1552C                     --X2     = THE SINGLE PRECISION VECTOR CONTAINING
1553C                                THE VALUES OF THE SECOND GROUP VARIABLE
1554C                     --X3     = THE SINGLE PRECISION VECTOR CONTAINING
1555C                                THE VALUES OF THE THIRD GROUP VARIABLE
1556C                     --X4     = THE SINGLE PRECISION VECTOR CONTAINING
1557C                                THE VALUES OF THE FOURTH GROUP VARIABLE
1558C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
1559C                                IN THE VECTORS X1, X2, X3 AND X4.
1560C                     --ICCTOF = THE INTEGER PARAMETER THAT SPECIFIES
1561C                                THE OFFSET.
1562C                     --ICCTG1 = THE INTEGER PARAMETER THAT SPECIFIES
1563C                                THE SPACING FOR GROUP 2.
1564C                     --ICCTG2 = THE INTEGER PARAMETER THAT SPECIFIES
1565C                                THE SPACING FOR GROUP 3.
1566C                     --ICCTG3 = THE INTEGER PARAMETER THAT SPECIFIES
1567C                                THE SPACING FOR GROUP 4.
1568C     OUTPUT ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR INTO WHICH
1569C                                THE CODED VALUES WILL BE PLACED.
1570C     OUTPUT--THE SINGLE PRECISION VECTOR Y WHICH WILL CONTAIN THE CODED
1571C             VALUES CORRESPONDING TO THE OBSERVATIONS IN THE VECTORS
1572C             X1, X2, X3 AND X4.
1573C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
1574C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT, DISTIN.
1575C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
1576C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
1577C     LANGUAGE--ANSI FORTRAN (1977)
1578C     WRITTEN BY--JAMES J. FILLIBEN
1579C                 STATISTICAL ENGINEERING DIVISION
1580C                 INFORMATION TECHNOLOGY LABORATORY
1581C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
1582C                 GAITHERSBURG, MD 20899-8980
1583C                 PHONE--301-975-2899
1584C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
1585C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
1586C     LANGUAGE--ANSI FORTRAN (1977)
1587C     VERSION NUMBER--2009/6
1588C     ORIGINAL VERSION--JUNE      2009.
1589C
1590C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
1591C
1592      CHARACTER*4 IWRITE
1593      CHARACTER*4 IBUGA3
1594      CHARACTER*4 ISUBRO
1595      CHARACTER*4 IERROR
1596C
1597      CHARACTER*4 ISUBN1
1598      CHARACTER*4 ISUBN2
1599C
1600C---------------------------------------------------------------------
1601C
1602CCCCC INCLUDE 'DPCOPA.INC'
1603C
1604      DIMENSION X1(*)
1605      DIMENSION X2(*)
1606      DIMENSION X3(*)
1607      DIMENSION X4(*)
1608      DIMENSION Y(*)
1609      DIMENSION XIDTEM(*)
1610      DIMENSION XIDTE2(*)
1611      DIMENSION XIDTE3(*)
1612      DIMENSION XIDTE4(*)
1613C
1614C---------------------------------------------------------------------
1615C
1616      INCLUDE 'DPCOP2.INC'
1617C
1618C-----START POINT-----------------------------------------------------
1619C
1620      ISUBN1='CODC'
1621      ISUBN2='T4  '
1622C
1623      IERROR='NO'
1624C
1625      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DCT4')THEN
1626        WRITE(ICOUT,999)
1627  999   FORMAT(1X)
1628        CALL DPWRST('XXX','BUG ')
1629        WRITE(ICOUT,51)
1630   51   FORMAT('***** AT THE BEGINNING OF CODCT4--')
1631        CALL DPWRST('XXX','BUG ')
1632        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
1633   52   FORMAT('IBUGA3,ISUBRO,N = ',A4,2X,A4,2X,I8)
1634        CALL DPWRST('XXX','BUG ')
1635        DO55I=1,N
1636          WRITE(ICOUT,56)I,X1(I),X2(I),X3(I),X4(I)
1637   56     FORMAT('I,X1(I),X2(I),X3(I),X4(I) = ',I8,4G15.7)
1638          CALL DPWRST('XXX','BUG ')
1639   55   CONTINUE
1640      ENDIF
1641C
1642C               ***********************************************************
1643C               **  STEP 2--                                             **
1644C               **  PERFORM THE CODING--                                 **
1645C               ***********************************************************
1646C
1647      CALL DISTIN(X1,N,IWRITE,XIDTEM,NGRP1,IBUGA3,IERROR)
1648      CALL SORT(XIDTEM,NGRP1,XIDTEM)
1649      CALL DISTIN(X2,N,IWRITE,XIDTE2,NGRP2,IBUGA3,IERROR)
1650      CALL SORT(XIDTE2,NGRP2,XIDTE2)
1651      CALL DISTIN(X3,N,IWRITE,XIDTE3,NGRP3,IBUGA3,IERROR)
1652      CALL SORT(XIDTE3,NGRP3,XIDTE3)
1653      CALL DISTIN(X4,N,IWRITE,XIDTE4,NGRP4,IBUGA3,IERROR)
1654      CALL SORT(XIDTE4,NGRP4,XIDTE4)
1655C
1656      IFACT1=MAX(NGRP2,ICCTG1)
1657      IFACT2=MAX(NGRP3,ICCTG2)
1658      IFACT3=MAX(NGRP4,ICCTG3)
1659C
1660      DO100I=1,N
1661C
1662        DO200J=1,NGRP1
1663          DO300K=1,NGRP2
1664            DO400L=1,NGRP3
1665            DO500M=1,NGRP4
1666C
1667            IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DCT4')THEN
1668              WRITE(ICOUT,301)I,J,K,L,M
1669  301         FORMAT('I,J,K,L,M = ',5I8)
1670              CALL DPWRST('XXX','BUG ')
1671              WRITE(ICOUT,302)X1(I),X2(I),X3(I),X4(I)
1672  302         FORMAT('X1(I),X2(I),X3(I),X4(I)=',4G15.7)
1673              CALL DPWRST('XXX','BUG ')
1674              WRITE(ICOUT,303)XIDTEM(J),XIDTE2(K),XIDTE3(L),XIDTE4(M)
1675  303         FORMAT('XIDTEM(J),XIDTE2(K),XIDTE3(L),XIDTE4(M)=',4G15.7)
1676              CALL DPWRST('XXX','BUG ')
1677            ENDIF
1678C
1679            IF(X1(I).EQ.XIDTEM(J) .AND. X2(I).EQ.XIDTE2(K) .AND.
1680     1         X3(I).EQ.XIDTE3(L) .AND. X4(I).EQ.XIDTE4(M))THEN
1681              IINDX=ICCTOF + (J-1)*IFACT1*IFACT2*IFACT3 +
1682     1        (K-1)*IFACT2*IFACT3 +
1683     1        (L-1)*IFACT3 + M
1684              Y(I)=REAL(IINDX)
1685              GOTO100
1686            ENDIF
1687  500     CONTINUE
1688  400     CONTINUE
1689  300     CONTINUE
1690  200   CONTINUE
1691C
1692        WRITE(ICOUT,999)
1693        CALL DPWRST('XXX','BUG ')
1694        WRITE(ICOUT,305)
1695  305   FORMAT('***** INTERNAL ERROR IN CODCT4 SUBROUTINE--')
1696        CALL DPWRST('XXX','BUG ')
1697        WRITE(ICOUT,310)I
1698  310   FORMAT('      NO CODE FOUND FOR ELEMENT NUMBER ',I8)
1699        CALL DPWRST('XXX','BUG ')
1700        WRITE(ICOUT,312)X1(I)
1701  312   FORMAT('      GROUP-ID VARIABLE 1 = ',G15.7)
1702        CALL DPWRST('XXX','BUG ')
1703        WRITE(ICOUT,313)X2(I)
1704  313   FORMAT('      GROUP-ID VARIABLE 2 = ',G15.7)
1705        CALL DPWRST('XXX','BUG ')
1706        WRITE(ICOUT,314)X3(I)
1707  314   FORMAT('      GROUP-ID VARIABLE 3 = ',G15.7)
1708        CALL DPWRST('XXX','BUG ')
1709        WRITE(ICOUT,315)X4(I)
1710  315   FORMAT('      GROUP-ID VARIABLE 4 = ',G15.7)
1711        CALL DPWRST('XXX','BUG ')
1712        IERROR='YES'
1713        GOTO9000
1714C
1715  100 CONTINUE
1716C
1717C               ******************************
1718C               **  STEP 3--                **
1719C               **  WRITE OUT A FEW LINES   **
1720C               **  OF SUMMARY INFORMATION  **
1721C               **  ABOUT THE CODING.       **
1722C               ******************************
1723C
1724      IF(IFEEDB.EQ.'OFF')GOTO890
1725      IF(IWRITE.EQ.'OFF')GOTO890
1726      WRITE(ICOUT,999)
1727      CALL DPWRST('XXX','BUG ')
1728      WRITE(ICOUT,811)NGRP1*NGRP2*NGRP3*NGRP4
1729  811 FORMAT('NUMBER OF DISTINCT CODE VALUES = ',I8)
1730      CALL DPWRST('XXX','BUG ')
1731      WRITE(ICOUT,999)
1732      CALL DPWRST('XXX','BUG ')
1733  890 CONTINUE
1734C
1735C               *****************
1736C               **  STEP 90--  **
1737C               **  EXIT.      **
1738C               *****************
1739C
1740 9000 CONTINUE
1741C
1742      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DCT4')THEN
1743        WRITE(ICOUT,999)
1744        CALL DPWRST('XXX','BUG ')
1745        WRITE(ICOUT,9011)
1746 9011   FORMAT('***** AT THE END       OF CODCT4--')
1747        CALL DPWRST('XXX','BUG ')
1748        WRITE(ICOUT,9013)NGRP1,NGRP2,NGRP3,NGRP4
1749 9013   FORMAT('NGRP1,NGRP2,NGRP3,NGRP4 = ',4I8)
1750        CALL DPWRST('XXX','BUG ')
1751        DO9015I=1,N
1752          WRITE(ICOUT,9016)I,X1(I),X2(I),X3(I),X4(I),Y(I)
1753 9016     FORMAT('I,X1(I),X2(I),X3(I),X4(I),Y(I) = ',I8,5G15.7)
1754          CALL DPWRST('XXX','BUG ')
1755 9015   CONTINUE
1756      ENDIF
1757C
1758      RETURN
1759      END
1760      SUBROUTINE CODCT5(X1,X2,X3,X4,X5,N,
1761     1                  ICCTOF,ICCTG1,ICCTG2,ICCTG3,ICCTG4,IWRITE,
1762     1                  Y,XIDTEM,XIDTE2,XIDTE3,XIDTE4,XIDTE5,
1763     1                  IBUGA3,ISUBRO,IERROR)
1764C
1765C     PURPOSE--THIS SUBROUTINE CREATES A CODED VARIABLE FROM THE
1766C              CROSS TABULATION OF FIVE GROUP-ID VARIABLES.  THIS
1767C              CAN BE USEFUL FOR COMMANDS OF THE FORM
1768C
1769C                  <COMMAND>  Y  X
1770C
1771C              WHERE X IS A GROUP-ID VARIABLE.  THIS ALLOWS US TO
1772C              USE THESE COMMANDS FOR THE CASE WHERE WE ACTUALLY
1773C              HAVE MULTIPLE GROUPS.  FOR EXAMPLE, WE CAN CREATE
1774C              A BOX PLOT OVER SEVERAL GROUPS.
1775C
1776C              THE CODING IS BASED ON THE FOLLOWING FORMULA:
1777C
1778C                  ICODE = OFFSET +
1779C                          (ISET1-1)*NGROUP2*NGROUP3*NGROUP4*NGROUP5 +
1780C                          (ISET2-1)*NGROUP3*NGROUP4*NGROUP5 +
1781C                          (ISET3-1)*NGROUP4*NGROUP5
1782C                          (ISET4-1)*NGROUP5 + ISET5
1783C
1784C              WHERE
1785C
1786C                  OFFSET    = AN INITIAL OFFSET (DEFAULTS TO 0)
1787C                  ISET1     = I-TH DISTINCT VALUE OF GROUP 1
1788C                  ISET2     = I-TH DISTINCT VALUE OF GROUP 2
1789C                  ISET3     = I-TH DISTINCT VALUE OF GROUP 3
1790C                  ISET4     = I-TH DISTINCT VALUE OF GROUP 4
1791C                  ISET5     = I-TH DISTINCT VALUE OF GROUP 5
1792C                  NGROUP2   = NUMBER OF DISTINCT VALUES FOR GROUP 2
1793C                  NGROUP3   = NUMBER OF DISTINCT VALUES FOR GROUP 3
1794C                  NGROUP4   = NUMBER OF DISTINCT VALUES FOR GROUP 4
1795C                  NGROUP5   = NUMBER OF DISTINCT VALUES FOR GROUP 5
1796C
1797C              FOR PLOTS, WE MAY WANT TO SPACE GROUPS FURTHER APART.
1798C              THE ICCTG1, ICCTG2, ICCTG3,AND ICCTG4 PARAMETERS CAN BE
1799C              USED TO CONTROL THIS (I.E., WE USE:
1800C
1801C                   THE MAXIMUM OF NGROUP2 AND ICCTG1
1802C                   THE MAXIMUM OF NGROUP3 AND ICCTG2
1803C                   THE MAXIMUM OF NGROUP4 AND ICCTG3
1804C                   THE MAXIMUM OF NGROUP5 AND ICCTG4
1805C
1806C     INPUT  ARGUMENTS--X1     = THE SINGLE PRECISION VECTOR CONTAINING
1807C                                THE VALUES OF THE FIRST GROUP VARIABLE
1808C                     --X2     = THE SINGLE PRECISION VECTOR CONTAINING
1809C                                THE VALUES OF THE SECOND GROUP VARIABLE
1810C                     --X3     = THE SINGLE PRECISION VECTOR CONTAINING
1811C                                THE VALUES OF THE THIRD GROUP VARIABLE
1812C                     --X4     = THE SINGLE PRECISION VECTOR CONTAINING
1813C                                THE VALUES OF THE FOURTH GROUP VARIABLE
1814C                     --X5     = THE SINGLE PRECISION VECTOR CONTAINING
1815C                                THE VALUES OF THE FIFTH GROUP VARIABLE
1816C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
1817C                                IN THE VECTORS X1, X2, X3, X4 AND X5.
1818C                     --ICCTOF = THE INTEGER PARAMETER THAT SPECIFIES
1819C                                THE OFFSET.
1820C                     --ICCTG1 = THE INTEGER PARAMETER THAT SPECIFIES
1821C                                THE SPACING FOR GROUP 2.
1822C                     --ICCTG2 = THE INTEGER PARAMETER THAT SPECIFIES
1823C                                THE SPACING FOR GROUP 3.
1824C                     --ICCTG3 = THE INTEGER PARAMETER THAT SPECIFIES
1825C                                THE SPACING FOR GROUP 4.
1826C                     --ICCTG4 = THE INTEGER PARAMETER THAT SPECIFIES
1827C                                THE SPACING FOR GROUP 5.
1828C     OUTPUT ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR INTO WHICH
1829C                                THE CODED VALUES WILL BE PLACED.
1830C     OUTPUT--THE SINGLE PRECISION VECTOR Y WHICH WILL CONTAIN THE CODED
1831C             VALUES CORRESPONDING TO THE OBSERVATIONS IN THE VECTORS
1832C             X1, X2, X3, X4 AND X5.
1833C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
1834C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT, DISTIN.
1835C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
1836C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
1837C     LANGUAGE--ANSI FORTRAN (1977)
1838C     WRITTEN BY--JAMES J. FILLIBEN
1839C                 STATISTICAL ENGINEERING DIVISION
1840C                 INFORMATION TECHNOLOGY LABORATORY
1841C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
1842C                 GAITHERSBURG, MD 20899-8980
1843C                 PHONE--301-975-2899
1844C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
1845C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
1846C     LANGUAGE--ANSI FORTRAN (1977)
1847C     VERSION NUMBER--2009/6
1848C     ORIGINAL VERSION--JUNE      2009.
1849C
1850C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
1851C
1852      CHARACTER*4 IWRITE
1853      CHARACTER*4 IBUGA3
1854      CHARACTER*4 ISUBRO
1855      CHARACTER*4 IERROR
1856C
1857      CHARACTER*4 ISUBN1
1858      CHARACTER*4 ISUBN2
1859C
1860C---------------------------------------------------------------------
1861C
1862CCCCC INCLUDE 'DPCOPA.INC'
1863C
1864      DIMENSION X1(*)
1865      DIMENSION X2(*)
1866      DIMENSION X3(*)
1867      DIMENSION X4(*)
1868      DIMENSION X5(*)
1869      DIMENSION Y(*)
1870      DIMENSION XIDTEM(*)
1871      DIMENSION XIDTE2(*)
1872      DIMENSION XIDTE3(*)
1873      DIMENSION XIDTE4(*)
1874      DIMENSION XIDTE5(*)
1875C
1876C---------------------------------------------------------------------
1877C
1878      INCLUDE 'DPCOP2.INC'
1879C
1880C-----START POINT-----------------------------------------------------
1881C
1882      ISUBN1='CODC'
1883      ISUBN2='T4  '
1884C
1885      IERROR='NO'
1886C
1887      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DCT5')THEN
1888        WRITE(ICOUT,999)
1889  999   FORMAT(1X)
1890        CALL DPWRST('XXX','BUG ')
1891        WRITE(ICOUT,51)
1892   51   FORMAT('***** AT THE BEGINNING OF CODCT5--')
1893        CALL DPWRST('XXX','BUG ')
1894        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
1895   52   FORMAT('IBUGA3,ISUBRO,N = ',A4,2X,A4,2X,I8)
1896        CALL DPWRST('XXX','BUG ')
1897        WRITE(ICOUT,53)ICCTOF,ICCTG1,ICCTG2,ICCTG3,ICCTG4
1898   53   FORMAT('ICCTOF,ICCTG1,ICCTG2,ICCTG3,ICCTG4 = ',5I5)
1899        CALL DPWRST('XXX','BUG ')
1900        DO55I=1,N
1901          WRITE(ICOUT,56)I,X1(I),X2(I),X3(I),X4(I),X5(I)
1902   56     FORMAT('I,X1(I),X2(I),X3(I),X4(I),X5(I) = ',I8,5G15.7)
1903          CALL DPWRST('XXX','BUG ')
1904   55   CONTINUE
1905      ENDIF
1906C
1907C               ***********************************************************
1908C               **  STEP 2--                                             **
1909C               **  PERFORM THE CODING--                                 **
1910C               ***********************************************************
1911C
1912      CALL DISTIN(X1,N,IWRITE,XIDTEM,NGRP1,IBUGA3,IERROR)
1913      CALL SORT(XIDTEM,NGRP1,XIDTEM)
1914      CALL DISTIN(X2,N,IWRITE,XIDTE2,NGRP2,IBUGA3,IERROR)
1915      CALL SORT(XIDTE2,NGRP2,XIDTE2)
1916      CALL DISTIN(X3,N,IWRITE,XIDTE3,NGRP3,IBUGA3,IERROR)
1917      CALL SORT(XIDTE3,NGRP3,XIDTE3)
1918      CALL DISTIN(X4,N,IWRITE,XIDTE4,NGRP4,IBUGA3,IERROR)
1919      CALL SORT(XIDTE4,NGRP4,XIDTE4)
1920      CALL DISTIN(X5,N,IWRITE,XIDTE5,NGRP5,IBUGA3,IERROR)
1921      CALL SORT(XIDTE5,NGRP5,XIDTE5)
1922C
1923      IFACT1=MAX(NGRP2,ICCTG1)
1924      IFACT2=MAX(NGRP3,ICCTG2)
1925      IFACT3=MAX(NGRP4,ICCTG3)
1926      IFACT4=MAX(NGRP5,ICCTG4)
1927C
1928      DO100I=1,N
1929C
1930        DO200J=1,NGRP1
1931          DO300K=1,NGRP2
1932            DO400L=1,NGRP3
1933            DO500M=1,NGRP4
1934            DO600JJ=1,NGRP5
1935C
1936            IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DCT5')THEN
1937              WRITE(ICOUT,301)I,J,K,L,M
1938  301         FORMAT('I,J,K,L,M = ',5I8)
1939              CALL DPWRST('XXX','BUG ')
1940              WRITE(ICOUT,302)X1(I),X2(I),X3(I),X4(I),X5(I)
1941  302         FORMAT('X1(I),X2(I),X3(I),X4(I),X5(I)=',5G15.7)
1942              CALL DPWRST('XXX','BUG ')
1943              WRITE(ICOUT,303)XIDTEM(J),XIDTE2(K),XIDTE3(L),
1944     1                        XIDTE4(M),XIDTE5(JJ)
1945  303         FORMAT('XIDTEM(J),XIDTE2(K),XIDTE3(L),XIDTE4(M),',
1946     1               'XIDTE5(JJ)=',5G15.7)
1947              CALL DPWRST('XXX','BUG ')
1948            ENDIF
1949C
1950            IF(X1(I).EQ.XIDTEM(J) .AND. X2(I).EQ.XIDTE2(K) .AND.
1951     1         X3(I).EQ.XIDTE3(L) .AND. X4(I).EQ.XIDTE4(M) .AND.
1952     1         X5(I).EQ.XIDTE5(JJ))THEN
1953              IINDX=ICCTOF + (J-1)*IFACT1*IFACT2*IFACT3*IFACT4 +
1954     1        (K-1)*IFACT2*IFACT3*IFACT4 +
1955     1        (L-1)*IFACT3*IFACT4 +
1956     1        (M-1)*IFACT4 + JJ
1957              Y(I)=REAL(IINDX)
1958              GOTO100
1959            ENDIF
1960  600     CONTINUE
1961  500     CONTINUE
1962  400     CONTINUE
1963  300     CONTINUE
1964  200   CONTINUE
1965C
1966        WRITE(ICOUT,999)
1967        CALL DPWRST('XXX','BUG ')
1968        WRITE(ICOUT,305)
1969  305   FORMAT('***** INTERNAL ERROR IN CODCT5 SUBROUTINE--')
1970        CALL DPWRST('XXX','BUG ')
1971        WRITE(ICOUT,310)I
1972  310   FORMAT('      NO CODE FOUND FOR ELEMENT NUMBER ',I8)
1973        CALL DPWRST('XXX','BUG ')
1974        WRITE(ICOUT,312)X1(I)
1975  312   FORMAT('      GROUP-ID VARIABLE 1 = ',G15.7)
1976        CALL DPWRST('XXX','BUG ')
1977        WRITE(ICOUT,313)X2(I)
1978  313   FORMAT('      GROUP-ID VARIABLE 2 = ',G15.7)
1979        CALL DPWRST('XXX','BUG ')
1980        WRITE(ICOUT,314)X3(I)
1981  314   FORMAT('      GROUP-ID VARIABLE 3 = ',G15.7)
1982        CALL DPWRST('XXX','BUG ')
1983        WRITE(ICOUT,315)X4(I)
1984  315   FORMAT('      GROUP-ID VARIABLE 4 = ',G15.7)
1985        CALL DPWRST('XXX','BUG ')
1986        WRITE(ICOUT,316)X5(I)
1987  316   FORMAT('      GROUP-ID VARIABLE 5 = ',G15.7)
1988        CALL DPWRST('XXX','BUG ')
1989        IERROR='YES'
1990        GOTO9000
1991C
1992  100 CONTINUE
1993C
1994C               ******************************
1995C               **  STEP 3--                **
1996C               **  WRITE OUT A FEW LINES   **
1997C               **  OF SUMMARY INFORMATION  **
1998C               **  ABOUT THE CODING.       **
1999C               ******************************
2000C
2001      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
2002        WRITE(ICOUT,999)
2003        CALL DPWRST('XXX','BUG ')
2004        WRITE(ICOUT,811)NGRP1*NGRP2*NGRP3*NGRP4*NGRP5
2005  811   FORMAT('NUMBER OF DISTINCT CODE VALUES = ',I8)
2006        CALL DPWRST('XXX','BUG ')
2007        WRITE(ICOUT,999)
2008        CALL DPWRST('XXX','BUG ')
2009      ENDIF
2010C
2011C               *****************
2012C               **  STEP 90--  **
2013C               **  EXIT.      **
2014C               *****************
2015C
2016 9000 CONTINUE
2017C
2018      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DCT5')THEN
2019        WRITE(ICOUT,999)
2020        CALL DPWRST('XXX','BUG ')
2021        WRITE(ICOUT,9011)
2022 9011   FORMAT('***** AT THE END       OF CODCT5--')
2023        CALL DPWRST('XXX','BUG ')
2024        WRITE(ICOUT,9013)NGRP1,NGRP2,NGRP3,NGRP4,NGRP5
2025 9013   FORMAT('NGRP1,NGRP2,NGRP3,NGRP4,NGRP5 = ',5I8)
2026        CALL DPWRST('XXX','BUG ')
2027        DO9015I=1,N
2028          WRITE(ICOUT,9016)I,X1(I),X2(I),X3(I),X4(I),X5(I),Y(I)
2029 9016     FORMAT('I,X1(I),X2(I),X3(I),X4(I),X5(I),Y(I) = ',I8,5G15.7)
2030          CALL DPWRST('XXX','BUG ')
2031 9015   CONTINUE
2032      ENDIF
2033C
2034      RETURN
2035      END
2036      SUBROUTINE CODCT6(X1,X2,X3,X4,X5,X6,N,
2037     1                  ICCTOF,ICCTG1,ICCTG2,ICCTG3,ICCTG4,ICCTG5,
2038     1                  IWRITE,
2039     1                  Y,XIDTEM,XIDTE2,XIDTE3,XIDTE4,XIDTE5,XIDTE6,
2040     1                  IBUGA3,ISUBRO,IERROR)
2041C
2042C     PURPOSE--THIS SUBROUTINE CREATES A CODED VARIABLE FROM THE
2043C              CROSS TABULATION OF SIX GROUP-ID VARIABLES.  THIS
2044C              CAN BE USEFUL FOR COMMANDS OF THE FORM
2045C
2046C                  <COMMAND>  Y  X
2047C
2048C              WHERE X IS A GROUP-ID VARIABLE.  THIS ALLOWS US TO
2049C              USE THESE COMMANDS FOR THE CASE WHERE WE ACTUALLY
2050C              HAVE MULTIPLE GROUPS.  FOR EXAMPLE, WE CAN CREATE
2051C              A BOX PLOT OVER SEVERAL GROUPS.
2052C
2053C              THE CODING IS BASED ON THE FOLLOWING FORMULA:
2054C
2055C                  ICODE = OFFSET +
2056C                          (ISET1-1)*NGROUP2*NGROUP3*NGROUP4*NGROUP5*NGROUP6 +
2057C                          (ISET2-1)*NGROUP3*NGROUP4*NGROUP5*NGROUP6 +
2058C                          (ISET3-1)*NGROUP4*NGROUP5*NGROUP6 +
2059C                          (ISET4-1)*NGROUP5*NGROUP6 +
2060C                          (ISET5-1)*NGROUP6 + ISET6
2061C
2062C              WHERE
2063C
2064C                  OFFSET    = AN INITIAL OFFSET (DEFAULTS TO 0)
2065C                  ISET1     = I-TH DISTINCT VALUE OF GROUP 1
2066C                  ISET2     = I-TH DISTINCT VALUE OF GROUP 2
2067C                  ISET3     = I-TH DISTINCT VALUE OF GROUP 3
2068C                  ISET4     = I-TH DISTINCT VALUE OF GROUP 4
2069C                  ISET5     = I-TH DISTINCT VALUE OF GROUP 5
2070C                  ISET6     = I-TH DISTINCT VALUE OF GROUP 6
2071C                  NGROUP2   = NUMBER OF DISTINCT VALUES FOR GROUP 2
2072C                  NGROUP3   = NUMBER OF DISTINCT VALUES FOR GROUP 3
2073C                  NGROUP4   = NUMBER OF DISTINCT VALUES FOR GROUP 4
2074C                  NGROUP5   = NUMBER OF DISTINCT VALUES FOR GROUP 5
2075C                  NGROUP6   = NUMBER OF DISTINCT VALUES FOR GROUP 6
2076C
2077C              FOR PLOTS, WE MAY WANT TO SPACE GROUPS FURTHER APART.
2078C              THE ICCTG1, ICCTG2, ICCTG3, ICCTG4, AND ICCTG5 PARAMETERS
2079C              CAN BE USED TO CONTROL THIS (I.E., WE USE:
2080C
2081C                   THE MAXIMUM OF NGROUP2 AND ICCTG1
2082C                   THE MAXIMUM OF NGROUP3 AND ICCTG2
2083C                   THE MAXIMUM OF NGROUP4 AND ICCTG3
2084C                   THE MAXIMUM OF NGROUP5 AND ICCTG4
2085C                   THE MAXIMUM OF NGROUP6 AND ICCTG5
2086C
2087C     INPUT  ARGUMENTS--X1     = THE SINGLE PRECISION VECTOR CONTAINING
2088C                                THE VALUES OF THE FIRST GROUP VARIABLE
2089C                     --X2     = THE SINGLE PRECISION VECTOR CONTAINING
2090C                                THE VALUES OF THE SECOND GROUP VARIABLE
2091C                     --X3     = THE SINGLE PRECISION VECTOR CONTAINING
2092C                                THE VALUES OF THE THIRD GROUP VARIABLE
2093C                     --X4     = THE SINGLE PRECISION VECTOR CONTAINING
2094C                                THE VALUES OF THE FOURTH GROUP VARIABLE
2095C                     --X5     = THE SINGLE PRECISION VECTOR CONTAINING
2096C                                THE VALUES OF THE FIFTH GROUP VARIABLE
2097C                     --X6     = THE SINGLE PRECISION VECTOR CONTAINING
2098C                                THE VALUES OF THE SIXTH GROUP VARIABLE
2099C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
2100C                                IN THE VECTORS X1, X2, X3, X4, X5 AND
2101C                                X6.
2102C                     --ICCTOF = THE INTEGER PARAMETER THAT SPECIFIES
2103C                                THE OFFSET.
2104C                     --ICCTG1 = THE INTEGER PARAMETER THAT SPECIFIES
2105C                                THE SPACING FOR GROUP 2.
2106C                     --ICCTG2 = THE INTEGER PARAMETER THAT SPECIFIES
2107C                                THE SPACING FOR GROUP 3.
2108C                     --ICCTG3 = THE INTEGER PARAMETER THAT SPECIFIES
2109C                                THE SPACING FOR GROUP 4.
2110C                     --ICCTG4 = THE INTEGER PARAMETER THAT SPECIFIES
2111C                                THE SPACING FOR GROUP 5.
2112C                     --ICCTG5 = THE INTEGER PARAMETER THAT SPECIFIES
2113C                                THE SPACING FOR GROUP 6.
2114C     OUTPUT ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR INTO WHICH
2115C                                THE CODED VALUES WILL BE PLACED.
2116C     OUTPUT--THE SINGLE PRECISION VECTOR Y WHICH WILL CONTAIN THE CODED
2117C             VALUES CORRESPONDING TO THE OBSERVATIONS IN THE VECTORS
2118C             X1, X2, X3, X4, X5 AND X6.
2119C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
2120C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT, DISTIN.
2121C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
2122C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
2123C     LANGUAGE--ANSI FORTRAN (1977)
2124C     WRITTEN BY--JAMES J. FILLIBEN
2125C                 STATISTICAL ENGINEERING DIVISION
2126C                 INFORMATION TECHNOLOGY LABORATORY
2127C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
2128C                 GAITHERSBURG, MD 20899-8980
2129C                 PHONE--301-975-2899
2130C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
2131C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
2132C     LANGUAGE--ANSI FORTRAN (1977)
2133C     VERSION NUMBER--2009/6
2134C     ORIGINAL VERSION--JUNE      2009.
2135C
2136C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
2137C
2138      CHARACTER*4 IWRITE
2139      CHARACTER*4 IBUGA3
2140      CHARACTER*4 ISUBRO
2141      CHARACTER*4 IERROR
2142C
2143      CHARACTER*4 ISUBN1
2144      CHARACTER*4 ISUBN2
2145C
2146C---------------------------------------------------------------------
2147C
2148CCCCC INCLUDE 'DPCOPA.INC'
2149C
2150      DIMENSION X1(*)
2151      DIMENSION X2(*)
2152      DIMENSION X3(*)
2153      DIMENSION X4(*)
2154      DIMENSION X5(*)
2155      DIMENSION X6(*)
2156      DIMENSION Y(*)
2157      DIMENSION XIDTEM(*)
2158      DIMENSION XIDTE2(*)
2159      DIMENSION XIDTE3(*)
2160      DIMENSION XIDTE4(*)
2161      DIMENSION XIDTE5(*)
2162      DIMENSION XIDTE6(*)
2163C
2164C---------------------------------------------------------------------
2165C
2166      INCLUDE 'DPCOP2.INC'
2167C
2168C-----START POINT-----------------------------------------------------
2169C
2170      ISUBN1='CODC'
2171      ISUBN2='T6  '
2172      IERROR='NO'
2173C
2174      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DCT6')THEN
2175        WRITE(ICOUT,999)
2176  999   FORMAT(1X)
2177        CALL DPWRST('XXX','BUG ')
2178        WRITE(ICOUT,51)
2179   51   FORMAT('***** AT THE BEGINNING OF CODCT6--')
2180        CALL DPWRST('XXX','BUG ')
2181        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
2182   52   FORMAT('IBUGA3,ISUBRO,N = ',A4,2X,A4,2X,I8)
2183        CALL DPWRST('XXX','BUG ')
2184        WRITE(ICOUT,53)ICCTOF,ICCTG1,ICCTG2,ICCTG3,ICCTG4,ICCTG5
2185   53   FORMAT('ICCTOF,ICCTG1,ICCTG2,ICCTG3,ICCTG4,ICCTG5 = ',6I5)
2186        CALL DPWRST('XXX','BUG ')
2187        DO55I=1,N
2188          WRITE(ICOUT,56)I,X1(I),X2(I),X3(I),X4(I),X5(I),X6(I)
2189   56     FORMAT('I,X1(I),X2(I),X3(I),X4(I),X5(I),X6(I) = ',I8,6G15.7)
2190          CALL DPWRST('XXX','BUG ')
2191   55   CONTINUE
2192      ENDIF
2193C
2194C               ***********************************************************
2195C               **  STEP 2--                                             **
2196C               **  PERFORM THE CODING--                                 **
2197C               ***********************************************************
2198C
2199      CALL DISTIN(X1,N,IWRITE,XIDTEM,NGRP1,IBUGA3,IERROR)
2200      CALL SORT(XIDTEM,NGRP1,XIDTEM)
2201      CALL DISTIN(X2,N,IWRITE,XIDTE2,NGRP2,IBUGA3,IERROR)
2202      CALL SORT(XIDTE2,NGRP2,XIDTE2)
2203      CALL DISTIN(X3,N,IWRITE,XIDTE3,NGRP3,IBUGA3,IERROR)
2204      CALL SORT(XIDTE3,NGRP3,XIDTE3)
2205      CALL DISTIN(X4,N,IWRITE,XIDTE4,NGRP4,IBUGA3,IERROR)
2206      CALL SORT(XIDTE4,NGRP4,XIDTE4)
2207      CALL DISTIN(X5,N,IWRITE,XIDTE5,NGRP5,IBUGA3,IERROR)
2208      CALL SORT(XIDTE5,NGRP5,XIDTE5)
2209      CALL DISTIN(X6,N,IWRITE,XIDTE6,NGRP6,IBUGA3,IERROR)
2210      CALL SORT(XIDTE6,NGRP6,XIDTE6)
2211C
2212      IFACT1=MAX(NGRP2,ICCTG1)
2213      IFACT2=MAX(NGRP3,ICCTG2)
2214      IFACT3=MAX(NGRP4,ICCTG3)
2215      IFACT4=MAX(NGRP5,ICCTG4)
2216      IFACT5=MAX(NGRP6,ICCTG5)
2217C
2218      DO100I=1,N
2219C
2220        DO200J=1,NGRP1
2221          DO300K=1,NGRP2
2222            DO400L=1,NGRP3
2223            DO500M=1,NGRP4
2224            DO600JJ=1,NGRP5
2225            DO700KK=1,NGRP6
2226C
2227            IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DCT6')THEN
2228              WRITE(ICOUT,301)I,J,K,L,M
2229  301         FORMAT('I,J,K,L,M = ',5I8)
2230              CALL DPWRST('XXX','BUG ')
2231              WRITE(ICOUT,302)X1(I),X2(I),X3(I),X4(I),X5(I),X6(I)
2232  302         FORMAT('X1(I),X2(I),X3(I),X4(I),X5(I),X6(I)=',6G15.7)
2233              CALL DPWRST('XXX','BUG ')
2234              WRITE(ICOUT,303)XIDTEM(J),XIDTE2(K),XIDTE3(L),
2235     1                        XIDTE4(M),XIDTE5(JJ),XIDTE6(KK)
2236  303         FORMAT('XIDTEM(J),XIDTE2(K),XIDTE3(L),XIDTE4(M),',
2237     1               'XIDTE5(JJ),XIDTE6(KK)=',6G15.7)
2238              CALL DPWRST('XXX','BUG ')
2239            ENDIF
2240C
2241            IF(X1(I).EQ.XIDTEM(J) .AND. X2(I).EQ.XIDTE2(K) .AND.
2242     1         X3(I).EQ.XIDTE3(L) .AND. X4(I).EQ.XIDTE4(M) .AND.
2243     1         X5(I).EQ.XIDTE5(JJ) .AND. X6(I).EQ.XIDTE6(KK))THEN
2244              IINDX=ICCTOF + (J-1)*IFACT1*IFACT2*IFACT3*IFACT4*IFACT5 +
2245     1        (K-1)*IFACT2*IFACT3*IFACT4*IFACT5 +
2246     1        (L-1)*IFACT3*IFACT4*IFACT5 +
2247     1        (M-1)*IFACT4*IFACT5 +
2248     1        (JJ-1)*IFACT5 + KK
2249              Y(I)=REAL(IINDX)
2250              GOTO100
2251            ENDIF
2252  700     CONTINUE
2253  600     CONTINUE
2254  500     CONTINUE
2255  400     CONTINUE
2256  300     CONTINUE
2257  200   CONTINUE
2258C
2259        WRITE(ICOUT,999)
2260        CALL DPWRST('XXX','BUG ')
2261        WRITE(ICOUT,305)
2262  305   FORMAT('***** INTERNAL ERROR IN CODCT6 SUBROUTINE--')
2263        CALL DPWRST('XXX','BUG ')
2264        WRITE(ICOUT,310)I
2265  310   FORMAT('      NO CODE FOUND FOR ELEMENT NUMBER ',I8)
2266        CALL DPWRST('XXX','BUG ')
2267        WRITE(ICOUT,312)X1(I)
2268  312   FORMAT('      GROUP-ID VARIABLE 1 = ',G15.7)
2269        CALL DPWRST('XXX','BUG ')
2270        WRITE(ICOUT,313)X2(I)
2271  313   FORMAT('      GROUP-ID VARIABLE 2 = ',G15.7)
2272        CALL DPWRST('XXX','BUG ')
2273        WRITE(ICOUT,314)X3(I)
2274  314   FORMAT('      GROUP-ID VARIABLE 3 = ',G15.7)
2275        CALL DPWRST('XXX','BUG ')
2276        WRITE(ICOUT,315)X4(I)
2277  315   FORMAT('      GROUP-ID VARIABLE 4 = ',G15.7)
2278        CALL DPWRST('XXX','BUG ')
2279        WRITE(ICOUT,316)X5(I)
2280  316   FORMAT('      GROUP-ID VARIABLE 5 = ',G15.7)
2281        CALL DPWRST('XXX','BUG ')
2282        WRITE(ICOUT,317)X6(I)
2283  317   FORMAT('      GROUP-ID VARIABLE 6 = ',G15.7)
2284        CALL DPWRST('XXX','BUG ')
2285        IERROR='YES'
2286        GOTO9000
2287C
2288  100 CONTINUE
2289C
2290C               ******************************
2291C               **  STEP 3--                **
2292C               **  WRITE OUT A FEW LINES   **
2293C               **  OF SUMMARY INFORMATION  **
2294C               **  ABOUT THE CODING.       **
2295C               ******************************
2296C
2297      IF(IFEEDB.EQ.'OFF')GOTO890
2298      IF(IWRITE.EQ.'OFF')GOTO890
2299      WRITE(ICOUT,999)
2300      CALL DPWRST('XXX','BUG ')
2301      WRITE(ICOUT,811)NGRP1*NGRP2*NGRP3*NGRP4*NGRP5*NGRP6
2302  811 FORMAT('NUMBER OF DISTINCT CODE VALUES = ',I8)
2303      CALL DPWRST('XXX','BUG ')
2304      WRITE(ICOUT,999)
2305      CALL DPWRST('XXX','BUG ')
2306  890 CONTINUE
2307C
2308C               *****************
2309C               **  STEP 90--  **
2310C               **  EXIT.      **
2311C               *****************
2312C
2313 9000 CONTINUE
2314C
2315      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DCT6')THEN
2316        WRITE(ICOUT,999)
2317        CALL DPWRST('XXX','BUG ')
2318        WRITE(ICOUT,9011)
2319 9011   FORMAT('***** AT THE END       OF CODCT6--')
2320        CALL DPWRST('XXX','BUG ')
2321        WRITE(ICOUT,9013)NGRP1,NGRP2,NGRP3,NGRP4,NGRP5,NGRP6
2322 9013   FORMAT('NGRP1,NGRP2,NGRP3,NGRP4,NGRP5,NGRP6 = ',6I8)
2323        CALL DPWRST('XXX','BUG ')
2324        DO9015I=1,N
2325          WRITE(ICOUT,9016)I,X1(I),X2(I),X3(I),X4(I),X5(I),X6(I),Y(I)
2326 9016     FORMAT('I,X1(I),X2(I),X3(I),X4(I),X5(I),X6(I),Y(I) = ',
2327     1           I8,6G15.7)
2328          CALL DPWRST('XXX','BUG ')
2329 9015   CONTINUE
2330      ENDIF
2331C
2332      RETURN
2333      END
2334      SUBROUTINE CODE(X,N,IWRITE,Y,DIST,MAXOBV,IBUGA3,IERROR)
2335C
2336C     PURPOSE--THIS SUBROUTINE CODES THE ELEMENTS
2337C              OF THE INPUT VECTOR X
2338C              AND PUTS THE CODED VALUES INTO THE OUTPUT VECTOR Y.
2339C              THE CODING IS AS FOLLOWS--
2340C              THE MINIMUM IS CODED AS 1.0.
2341C              THE NEXT LARGER VALUE AS 2.0,
2342C              THE NEXT LARGER VALUE AS 3.0,
2343C              ETC.
2344C     NOTE--THIS ROUTINE IN JJF8 HAS BEEN MODIFIED FOR DATAPLOT
2345C           FROM THE SAME-NAME SUBROUTINE IN JJF6 IN 4 IMPORTANT WAYS--
2346C           1)  THE UPPER LIMIT (IUPPER) HAS BEEN
2347C               REDUCED FROM 7500 TO 1000
2348C           2)  THE VECTOR DIST HAS HAD ITS DIMENSION
2349C               CHANGED FROM 7500 TO 1000.
2350C           3)  THE VECTOR DIST HAS BEEN TAKEN OUT OF COMMON.
2351C           4)  THE VECTOR WS HAS BEEN DELETED.
2352C           5)  THE OUTPUT WRITING HAS BEEN SUPPRESSED.
2353C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR
2354C                                OF OBSERVATIONS TO BE CODED.
2355C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
2356C                                IN THE VECTOR X.
2357C     OUTPUT ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR
2358C                                INTO WHICH THE CODED VALUES
2359C                                WILL BE PLACED.
2360C     OUTPUT--THE SINGLE PRECISION VECTOR Y
2361C             WHICH WILL CONTAIN THE CODED VALUES
2362C             CORRESPONDING TO THE OBSERVATIONS IN
2363C             THE VECTOR X.
2364C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
2365C     RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N
2366C                   FOR THIS SUBROUTINE IS 15000.
2367C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT.
2368C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
2369C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
2370C     LANGUAGE--ANSI FORTRAN (1977)
2371C     COMMENT--ALL OCCURRANCES OF THE MINIMUM ARE CODED AS 1.0;
2372C              ALL OCCURANCES OF THE NEXT LARGER VALUE
2373C              ARE CODED AS 2.0;
2374C              ALL OCCURANCES OF THE NEXT LARGER VALUE
2375C              ARE CODED AS 3.0, ETC.
2376C     COMMENT--THE INPUT VECTOR X REMAINS UNALTERED.
2377C     REFERENCES--NONE.
2378C     WRITTEN BY--JAMES J. FILLIBEN
2379C                 STATISTICAL ENGINEERING DIVISION
2380C                 INFORMATION TECHNOLOGY LABORATORY
2381C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
2382C                 GAITHERSBURG, MD 20899
2383C                 PHONE--301-975-2855
2384C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
2385C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
2386C     LANGUAGE--ANSI FORTRAN (1977)
2387C     VERSION NUMBER--82/7
2388C     ORIGINAL VERSION--OCTOBER   1975.
2389C     UPDATED         --NOVEMBER  1975.
2390C     UPDATED         --JUNE      1977.
2391C     UPDATED         --JULY      1977.
2392C     UPDATED         --JULY      1979.
2393C     UPDATED         --AUGUST    1981.
2394C     UPDATED         --APRIL     1982.
2395C     UPDATED         --MAY       1982.
2396C     UPDATED         --JUNE      1990. TEMPORARY ARRAYS TO GARBAGE COMMON
2397C
2398C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
2399C
2400      CHARACTER*4 IWRITE
2401      CHARACTER*4 IBUGA3
2402      CHARACTER*4 IERROR
2403C
2404      CHARACTER*4 ISUBN1
2405      CHARACTER*4 ISUBN2
2406C
2407C---------------------------------------------------------------------
2408C
2409      DIMENSION X(*)
2410      DIMENSION Y(*)
2411      DIMENSION DIST(*)
2412C
2413C---------------------------------------------------------------------
2414C
2415      INCLUDE 'DPCOP2.INC'
2416C
2417C-----START POINT-----------------------------------------------------
2418C
2419      ISUBN1='CODE'
2420      ISUBN2='    '
2421      IERROR='NO'
2422      IUPPER=MAXOBV
2423C
2424      IF(IBUGA3.EQ.'ON')THEN
2425        WRITE(ICOUT,999)
2426  999   FORMAT(1X)
2427        CALL DPWRST('XXX','BUG ')
2428        WRITE(ICOUT,51)
2429   51   FORMAT('***** AT THE BEGINNING OF CODE--')
2430        CALL DPWRST('XXX','BUG ')
2431        WRITE(ICOUT,52)IBUGA3,N,IUPPER
2432   52   FORMAT('IBUGA3,N,IUPPER = ',A4,2X,2I8)
2433        CALL DPWRST('XXX','BUG ')
2434        DO55I=1,N
2435          WRITE(ICOUT,56)I,X(I)
2436   56     FORMAT('I,X(I) = ',I8,G15.7)
2437          CALL DPWRST('XXX','BUG ')
2438   55   CONTINUE
2439      ENDIF
2440C
2441C               *****************************
2442C               **  COMPUTE CODED VALUES.  **
2443C               *****************************
2444C
2445C               ********************************************
2446C               **  STEP 1--                              **
2447C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
2448C               ********************************************
2449C
2450      IF(N.LT.1 .OR. N.GT.IUPPER)THEN
2451        WRITE(ICOUT,999)
2452        CALL DPWRST('XXX','BUG ')
2453        WRITE(ICOUT,111)
2454  111   FORMAT('***** ERROR IN CODE--')
2455        CALL DPWRST('XXX','BUG ')
2456        WRITE(ICOUT,113)
2457  113   FORMAT('      THE NUMBER OF OBSERVATIONS IN THE RESPONSE ',
2458     1         'VARIABLE')
2459        CALL DPWRST('XXX','BUG ')
2460        WRITE(ICOUT,115)IUPPER
2461  115   FORMAT('      IS LESS THAN 1 OR GREATER THAN ',I10)
2462        CALL DPWRST('XXX','BUG ')
2463        WRITE(ICOUT,118)N
2464  118   FORMAT('      THE VALUE OF THE ARGUMENT IS ',I8)
2465        CALL DPWRST('XXX','BUG ')
2466        IERROR='YES'
2467        GOTO9000
2468      ENDIF
2469C
2470      IF(N.EQ.1)THEN
2471        Y(1)=1.0
2472        GOTO9000
2473      ENDIF
2474C
2475      HOLD=X(1)
2476      DO135I=2,N
2477        IF(X(I).NE.HOLD)GOTO139
2478  135 CONTINUE
2479      DO137I=1,N
2480        Y(I)=1.0
2481  137 CONTINUE
2482      GOTO9000
2483  139 CONTINUE
2484C
2485C               *************************************************************
2486C               **  STEP 2--                                               **
2487C               **  PERFORM THE CODING--                                   **
2488C               **  PULL OUT THE DISTINCT VALUES,                          **
2489C               **  THEN SORT (AND ESSENTIALLY RANK) THE DISTINCT VALUES,  **
2490C               **  THEN APPLY THE RANKS TO ALL THE VALUES.                **
2491C               *************************************************************
2492C
2493      NUMDIS=1
2494      DIST(NUMDIS)=X(1)
2495      DO200I=2,N
2496        DO300J=1,NUMDIS
2497          IF(X(I).EQ.DIST(J))GOTO200
2498  300   CONTINUE
2499        NUMDIS=NUMDIS+1
2500        DIST(NUMDIS)=X(I)
2501  200 CONTINUE
2502C
2503      CALL SORT(DIST,NUMDIS,DIST)
2504C
2505      DO600I=1,N
2506        DO700J=1,NUMDIS
2507          IF(X(I).EQ.DIST(J))THEN
2508            Y(I)=J
2509            GOTO600
2510          ENDIF
2511  700   CONTINUE
2512        WRITE(ICOUT,999)
2513        CALL DPWRST('XXX','BUG ')
2514        WRITE(ICOUT,705)
2515        CALL DPWRST('XXX','BUG ')
2516        WRITE(ICOUT,710)I,X(I)
2517  705   FORMAT('***** INTERNAL ERROR IN CODE SUBROUTINE--')
2518        CALL DPWRST('XXX','BUG ')
2519  710   FORMAT('      NO CODE FOUND FOR ELEMENT NUMBER ',I8,' = ',
2520     1         G15.7)
2521        GOTO9000
2522  600 CONTINUE
2523C
2524C               ******************************
2525C               **  STEP 3--                **
2526C               **  WRITE OUT A FEW LINES   **
2527C               **  OF SUMMARY INFORMATION  **
2528C               **  ABOUT THE CODING.       **
2529C               ******************************
2530C
2531      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
2532        WRITE(ICOUT,999)
2533        CALL DPWRST('XXX','BUG ')
2534        WRITE(ICOUT,811)NUMDIS
2535  811   FORMAT('NUMBER OF DISTINCT CODE VALUES = ',I8)
2536        CALL DPWRST('XXX','BUG ')
2537        WRITE(ICOUT,999)
2538        CALL DPWRST('XXX','BUG ')
2539        AI=1
2540        WRITE(ICOUT,812)DIST(1),AI
2541  812   FORMAT('THE MINIMUM (= ',G15.7,' ) HAS CODE VALUE ',F10.0)
2542        CALL DPWRST('XXX','BUG ')
2543        AI=NUMDIS
2544        WRITE(ICOUT,813)DIST(NUMDIS),AI
2545  813   FORMAT('THE MAXIMUM (= ',G15.7,' ) HAS CODE VALUE ',F10.0)
2546        CALL DPWRST('XXX','BUG ')
2547      ENDIF
2548C
2549C               *****************
2550C               **  STEP 90--  **
2551C               **  EXIT.      **
2552C               *****************
2553C
2554 9000 CONTINUE
2555C
2556      IF(IBUGA3.EQ.'ON')THEN
2557        WRITE(ICOUT,999)
2558        CALL DPWRST('XXX','BUG ')
2559        WRITE(ICOUT,9011)
2560 9011   FORMAT('***** AT THE END       OF CODE--')
2561        CALL DPWRST('XXX','BUG ')
2562        WRITE(ICOUT,9012)IBUGA3,IERROR
2563 9012   FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
2564        CALL DPWRST('XXX','BUG ')
2565        WRITE(ICOUT,9013)N,NUMDIS
2566 9013   FORMAT('N,NUMDIS = ',2I8)
2567        CALL DPWRST('XXX','BUG ')
2568        DO9015I=1,N
2569          WRITE(ICOUT,9016)I,X(I),Y(I),DIST(I)
2570 9016     FORMAT('I,X(I),Y(I),DIST(I) = ',I8,3E15.7)
2571          CALL DPWRST('XXX','BUG ')
2572 9015   CONTINUE
2573      ENDIF
2574C
2575      RETURN
2576      END
2577      SUBROUTINE CODECH(YTEMP,IWRITE,IBUGA3,ISUBRO,IERROR)
2578C
2579C     PURPOSE--THIS SUBROUTINE READS THE CHARCTER DATA STORED IN
2580C              FILE "DPZCHF.DAT" AND CODES A SELECTED FIELD INTO
2581C              A NUMERIC VARIABLE.  THAT IS, EACH DISTINCT
2582C              CHARACTER VARIABLE WILL BE ASSIGNED AN INTEGER
2583C              CODE (DETERMINED BY ORDER THAT THE FIRST OCCURENCE
2584C              IS FOUND).
2585C     OUTPUT ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR
2586C                                INTO WHICH THE CODED VALUES
2587C                                WILL BE PLACED.
2588C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
2589C                                IN THE CHARACTER VARIABLE.
2590C     OUTPUT--THE SINGLE PRECISION VECTOR Y
2591C             WHICH WILL CONTAIN THE CODED VALUES
2592C             CORRESPONDING TO THE OBSERVATIONS IN
2593C             THE VECTOR X.
2594C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
2595C     RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N
2596C                   FOR THIS SUBROUTINE IS MAXOBV.
2597C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT.
2598C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
2599C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
2600C     LANGUAGE--ANSI FORTRAN (1977)
2601C     REFERENCES--NONE.
2602C     WRITTEN BY--ALAN HECKERT
2603C                 STATISTICAL ENGINEERING DIVISION
2604C                 INFORMATION TECHNOLOGY LABORATORY
2605C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
2606C                 GAITHERSBURG, MD 20899-8980
2607C                 PHONE--301-975-2899
2608C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
2609C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
2610C     LANGUAGE--ANSI FORTRAN (1977)
2611C     VERSION NUMBER--2004/1
2612C     ORIGINAL VERSION--JANUARY   2004.
2613C     UPDATED         --FEBRUARY  2006. FIX BUG WHERE IT WAS ONLY
2614C                                       WORKING IF THERE WAS ONE
2615C                                       CHARACTER VARIABLE IN THE
2616C                                       DPZCHF.DAT.
2617C     UPDATED         --APRIL     2017. MODIFY THE FEEDBACK TO SHOW
2618C                                       THE ACTUAL MAPPING
2619C     UPDATED         --JUNE      2019. DIMENSION SCRATCH REAL ARRAYS IN
2620C                                       CALLING ROUTINE
2621C
2622C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
2623C
2624      DIMENSION YTEMP(*)
2625C
2626      CHARACTER*4 IWRITE
2627      CHARACTER*4 IBUGA3
2628      CHARACTER*4 ISUBRO
2629      CHARACTER*4 IERROR
2630C
2631      CHARACTER*4 ISTEPN
2632      CHARACTER*4 ISUBN1
2633      CHARACTER*4 ISUBN2
2634      CHARACTER*4 ICASEL
2635C
2636      CHARACTER*4 IH
2637      CHARACTER*4 IH2
2638      CHARACTER*4 IHLEFT
2639      CHARACTER*4 IHLEF2
2640      CHARACTER*4 IHRIGH
2641      CHARACTER*4 IHRIG2
2642C
2643C---------------------------------------------------------------------
2644C
2645      INCLUDE 'DPCOPA.INC'
2646      INCLUDE 'DPCODA.INC'
2647      INCLUDE 'DPCOHK.INC'
2648      INCLUDE 'DPCOF2.INC'
2649      INCLUDE 'DPCOZC.INC'
2650C
2651CCCCC CHARACTER*80 IFILE
2652      CHARACTER (LEN=MAXFNC) :: IFILE
2653      CHARACTER*12 ISTAT
2654      CHARACTER*12 IFORM
2655      CHARACTER*12 IACCES
2656      CHARACTER*12 IPROT
2657      CHARACTER*12 ICURST
2658      CHARACTER*4 IENDFI
2659      CHARACTER*4 IREWIN
2660      CHARACTER*4 ISUBN0
2661      CHARACTER*4 IERRFI
2662C
2663      CHARACTER*500 IATEMP
2664      CHARACTER*20 IFRMT
2665      CHARACTER*24 IXTEMP(MAXOBV)
2666      EQUIVALENCE (CGARBG(1),IXTEMP(1))
2667C
2668C---------------------------------------------------------------------
2669C
2670      INCLUDE 'DPCOP2.INC'
2671C
2672C-----START POINT-----------------------------------------------------
2673C
2674      ISUBN1='CODE'
2675      ISUBN2='CH  '
2676      IERROR='NO'
2677C
2678      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DECH')THEN
2679        WRITE(ICOUT,999)
2680  999   FORMAT(1X)
2681        CALL DPWRST('XXX','BUG ')
2682        WRITE(ICOUT,51)
2683   51   FORMAT('***** AT THE BEGINNING OF CODECH--')
2684        CALL DPWRST('XXX','BUG ')
2685        WRITE(ICOUT,52)IBUGA3
2686   52   FORMAT('IBUGA3 = ',A4)
2687        CALL DPWRST('XXX','BUG ')
2688      ENDIF
2689C
2690C               **************************************************
2691C               **  STEP 1--                                     *
2692C               **  EXAMINE THE LEFT-HAND SIDE--                 *
2693C               **  IS THE NAME     NAME TO LEFT OF = SIGN       *
2694C               **  ALREADY IN THE NAME LIST?                    *
2695C               **  NOTE THAT     ILISTL    IS THE LINE IN THE   *
2696C               **  TABLE OF THE NAME ON THE LEFT.               *
2697C               **************************************************
2698C
2699      ISTEPN='1'
2700      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DECH')
2701     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2702C
2703      IHLEFT=IHARG(1)
2704      IHLEF2=IHARG2(1)
2705      DO2000I=1,NUMNAM
2706        I2=I
2707        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
2708          ILISTL=I2
2709          GOTO2100
2710        ENDIF
2711 2000 CONTINUE
2712      ILISTL=NUMNAM+1
2713      IF(ILISTL.GT.MAXNAM)THEN
2714        WRITE(ICOUT,999)
2715        CALL DPWRST('XXX','BUG ')
2716        WRITE(ICOUT,2201)
2717 2201   FORMAT('***** ERROR IN CODECH--')
2718        CALL DPWRST('XXX','BUG ')
2719        WRITE(ICOUT,2202)
2720 2202   FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND FUNCTION')
2721        CALL DPWRST('XXX','BUG ')
2722        WRITE(ICOUT,2203)MAXNAM
2723 2203   FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
2724        CALL DPWRST('XXX','BUG ')
2725        WRITE(ICOUT,2204)
2726 2204   FORMAT('      ENTER      STATUS')
2727        CALL DPWRST('XXX','BUG ')
2728        WRITE(ICOUT,2205)
2729 2205   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES, AND')
2730        CALL DPWRST('XXX','BUG ')
2731        WRITE(ICOUT,2206)
2732 2206   FORMAT('      THEN DELETE SOME OF THE ALREADY-USED NAMES.')
2733        CALL DPWRST('XXX','BUG ')
2734        IERROR='YES'
2735        GOTO9000
2736      ENDIF
2737C
2738 2100 CONTINUE
2739C
2740C               *****************************
2741C               **  COMPUTE CODED VALUES.  **
2742C               *****************************
2743C
2744C               ********************************************
2745C               **  STEP 2--                              **
2746C               **  OPEN THE DPZCHF.DAT FILE.             **
2747C               ********************************************
2748C
2749      IHRIGH=IHARG(5)
2750      IHRIG2=IHARG2(5)
2751C
2752      IOUNIT=IZCHNU
2753      IFILE=IZCHNA
2754      ISTAT=IZCHST
2755      IFORM=IZCHFO
2756      IACCES=IZCHAC
2757      IPROT=IZCHPR
2758      ICURST=IZCHCS
2759C
2760      ISUBN0='READ'
2761      IERRFI='NO'
2762      CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,
2763     1            ICURST,
2764     1            IREWIN,ISUBN0,IERRFI,IBUGA3,ISUBRO,IERROR)
2765      IF(IERRFI.EQ.'YES')THEN
2766        IERROR='YES'
2767        WRITE(ICOUT,999)
2768        CALL DPWRST('XXX','BUG ')
2769        WRITE(ICOUT,111)
2770  111   FORMAT('***** ERROR IN CODECH--')
2771        CALL DPWRST('XXX','BUG ')
2772        WRITE(ICOUT,118)
2773  118   FORMAT('      UNABLE TO OPEN THE FILE CHARACTER DATA FILE:')
2774        CALL DPWRST('XXX','BUG ')
2775        WRITE(ICOUT,119)IFILE
2776  119   FORMAT('      ',A80)
2777        CALL DPWRST('XXX','BUG ')
2778        GOTO8000
2779      ENDIF
2780C
2781      READ(IOUNIT,'(I8)',END=171,ERR=171)NUMVAR
2782C
2783CCCCC FEBRUARY 2006:  BUG FIX FOR THE FOLLOWING LOOP.
2784C
2785      IVAR=-1
2786      DO130I=1,NUMVAR
2787        READ(IOUNIT,'(A4,A4)',END=181,ERR=181)IH,IH2
2788        IF(IHRIGH.EQ.IH .AND. IHRIG2.EQ.IH2)THEN
2789          IVAR=I
2790CCCCC     GOTO199
2791        ENDIF
2792  130 CONTINUE
2793      IF(IVAR.GT.0)GOTO199
2794C
2795      WRITE(ICOUT,999)
2796      CALL DPWRST('XXX','BUG ')
2797      WRITE(ICOUT,111)
2798      CALL DPWRST('XXX','BUG ')
2799      WRITE(ICOUT,131)IHRIGH,IHRIG2
2800  131 FORMAT('***** VARIABLE ',A4,A4,' NOT FOUND IN THE CHARACTER ',
2801     1       'DATA FILE:')
2802      CALL DPWRST('XXX','BUG ')
2803      WRITE(ICOUT,119)IFILE
2804      CALL DPWRST('XXX','BUG ')
2805      IERROR='YES'
2806      GOTO8000
2807C
2808  171 CONTINUE
2809      WRITE(ICOUT,999)
2810      CALL DPWRST('XXX','BUG ')
2811      WRITE(ICOUT,111)
2812      CALL DPWRST('XXX','BUG ')
2813      WRITE(ICOUT,173)
2814  173 FORMAT('      ERROR READING THE NUMBER OF CHARACTER VARIABLES ',
2815     1       'IN THE CHARACTER DATA FILE:')
2816      CALL DPWRST('XXX','BUG ')
2817      WRITE(ICOUT,119)IFILE
2818      CALL DPWRST('XXX','BUG ')
2819      IERROR='YES'
2820      GOTO8000
2821C
2822  181 CONTINUE
2823      WRITE(ICOUT,999)
2824      CALL DPWRST('XXX','BUG ')
2825      WRITE(ICOUT,111)
2826      CALL DPWRST('XXX','BUG ')
2827      WRITE(ICOUT,183)
2828  183 FORMAT('      ERROR READING THE VARIABLE NAMES ',
2829     1       'IN THE CHARACTER DATA FILE:')
2830      CALL DPWRST('XXX','BUG ')
2831      WRITE(ICOUT,119)IFILE
2832      CALL DPWRST('XXX','BUG ')
2833      IERROR='YES'
2834      GOTO8000
2835C
2836  199 CONTINUE
2837C
2838C               *************************************************
2839C               **  STEP 2--                                   **
2840C               **  PERFORM THE CODING--                       **
2841C               **  STORE UNIQUE VALUES IN IXTEMP, COMPARE     **
2842C               **  TO LIST IN IXTEMP.                         **
2843C               *************************************************
2844C
2845      IATEMP=' '
2846      IFRMT='(A   )'
2847      WRITE(IFRMT(3:5),'(I3)')25*IVAR
2848      N=1
2849      IROW=1
2850      READ(IOUNIT,IFRMT,END=491,ERR=491)IATEMP
2851      YTEMP(1)=REAL(N)
2852      IFRST=(IVAR-1)*25 + 1
2853      ILAST=IVAR*25 - 1
2854      IXTEMP(1)=' '
2855      IXTEMP(1)=IATEMP(IFRST:ILAST)
2856C
2857      DO210I=2,MAXOBV
2858        IATEMP=' '
2859        READ(IOUNIT,IFRMT,END=499,ERR=491)IATEMP
2860        IROW=I
2861        DO220J=1,N
2862          IF(IATEMP(IFRST:ILAST).EQ.IXTEMP(J)(1:24))THEN
2863            YTEMP(IROW)=REAL(J)
2864            GOTO210
2865          ENDIF
2866  220   CONTINUE
2867        N=N+1
2868        IXTEMP(N)=' '
2869        IXTEMP(N)=IATEMP(IFRST:ILAST)
2870        YTEMP(IROW)=REAL(N)
2871  210 CONTINUE
2872      GOTO499
2873C
2874  491 CONTINUE
2875      WRITE(ICOUT,999)
2876      CALL DPWRST('XXX','BUG ')
2877      WRITE(ICOUT,111)
2878      CALL DPWRST('XXX','BUG ')
2879      WRITE(ICOUT,493)IROW
2880  493 FORMAT('      ERROR READING ROW ',I8,' OF THE CHARACTER ',
2881     1       'VARIABLES IN THE CHARACTER DATA FILE:')
2882      CALL DPWRST('XXX','BUG ')
2883      WRITE(ICOUT,119)IFILE
2884      CALL DPWRST('XXX','BUG ')
2885      IERROR='YES'
2886      GOTO8000
2887C
2888C
2889C               ******************************
2890C               **  STEP 3--                **
2891C               **  WRITE OUT A FEW LINES   **
2892C               **  OF SUMMARY INFORMATION  **
2893C               **  ABOUT THE CODING.       **
2894C               ******************************
2895C
2896  499 CONTINUE
2897C
2898C     2017/04: MODIFY THE FEEDBACK TO SHOW THE FULL MAPPING
2899C
2900      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
2901        WRITE(ICOUT,999)
2902        CALL DPWRST('XXX','BUG ')
2903        WRITE(ICOUT,811)IHRIGH,IHRIG2,N
2904  811   FORMAT('NUMBER OF DISTINCT CHARACTER VALUES FOR ',2A4,' = ',I8)
2905        CALL DPWRST('XXX','BUG ')
2906        WRITE(ICOUT,999)
2907        CALL DPWRST('XXX','BUG ')
2908        IF(N.LE.9)THEN
2909          IFRMT="(A  ,' => ',I1)"
2910        ELSEIF(N.LE.99)THEN
2911          IFRMT="(A  ,' => ',I2)"
2912        ELSE
2913          IFRMT="(A  ,' => ',I3)"
2914        ENDIF
2915C
2916        MAXCHR=1
2917        DO810I=1,MIN(N,100)
2918          DO813J=24,1,-1
2919            IF(IXTEMP(I)(J:J).NE.' ')THEN
2920              IF(J.GT.MAXCHR)MAXCHR=J
2921              GOTO815
2922            ENDIF
2923  813     CONTINUE
2924  815     CONTINUE
2925  810   CONTINUE
2926        WRITE(IFRMT(3:4),'(I2)')MAXCHR
2927C
2928        DO820I=1,N
2929          WRITE(ICOUT,IFRMT)IXTEMP(I),I
2930          CALL DPWRST('XXX','BUG ')
2931  820   CONTINUE
2932      ENDIF
2933C
2934C               *****************************************************
2935C               **  STEP 5--                                       **
2936C               **  ENTER THE CODED      VALUES INTO THE DATAPLOT  **
2937C               **  HOUSEKEEPING ARRAY                             **
2938C               *****************************************************
2939C
2940      ISTEPN='5'
2941      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DECH')
2942     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2943C
2944      ICASEL='V'
2945      XINT=0.0
2946      IXINT=0
2947      CALL DPINVP(IHLEFT,IHLEF2,ICASEL,YTEMP,IROW,XINT,IXINT,
2948     1ISUBN1,ISUBN2,IBUGA3,IERROR)
2949C
2950C               ***************************************
2951C               **  STEP 88--                        **
2952C               **  CLOSE THE DPZCHF.DAT FILE.       **
2953C               ***************************************
2954C
2955 8000 CONTINUE
2956C
2957      IENDFI='OFF'
2958      IREWIN='ON'
2959      CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
2960     1            IENDFI,IREWIN,ISUBN0,IERRFI,IBUGA3,ISUBRO,IERROR)
2961      IZCHCS='CLOSED'
2962      GOTO9000
2963C
2964C               *****************
2965C               **  STEP 90--  **
2966C               **  EXIT.      **
2967C               *****************
2968C
2969 9000 CONTINUE
2970C
2971      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DECH')THEN
2972        WRITE(ICOUT,999)
2973        CALL DPWRST('XXX','BUG ')
2974        WRITE(ICOUT,9011)
2975 9011   FORMAT('***** AT THE END OF CODECH--')
2976        CALL DPWRST('XXX','BUG ')
2977        WRITE(ICOUT,9012)IBUGA3,IERROR,N,IROW
2978 9012   FORMAT('IBUGA3,IERROR,N,IROW = ',2(A4,2X),2I8)
2979        CALL DPWRST('XXX','BUG ')
2980        DO9015I=1,N
2981          WRITE(ICOUT,9016)I,IXTEMP(I)
2982 9016     FORMAT('I,IXTEMP(I) = ',I8,A24)
2983          CALL DPWRST('XXX','BUG ')
2984 9015   CONTINUE
2985        DO9035I=1,IROW
2986          WRITE(ICOUT,9036)I,YTEMP(I)
2987 9036     FORMAT('I,YTEMP(I) = ',I8,G15.7)
2988          CALL DPWRST('XXX','BUG ')
2989 9035   CONTINUE
2990      ENDIF
2991C
2992      RETURN
2993      END
2994      SUBROUTINE CODEC2(YTEMP,YTEMP2,IPERM,IWRITE,IBUGA3,ISUBRO,IERROR)
2995C
2996C     PURPOSE--THIS SUBROUTINE READS THE CHARCTER DATA STORED IN
2997C              FILE "DPZCHF.DAT" AND CODES A SELECTED FIELD INTO
2998C              A NUMERIC VARIABLE.  THAT IS, EACH DISTINCT
2999C              CHARACTER VARIABLE WILL BE ASSIGNED AN INTEGER
3000C              CODE.  THIS ROUTINE IS SIMILAR TO CODECH.  THE
3001C              DISTINCTION IS THAT CODECH CODES BY THE ORDER THE
3002C              VALUES ARE ENCOUNTERED IN THE FILE WHILE THIS
3003C              ROUTINE CODES BY (LEXICAL) ALPHABETIC ORDER.
3004C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
3005C     RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N
3006C                   FOR THIS SUBROUTINE IS MAXOBV.
3007C     OTHER DATAPAC   SUBROUTINES NEEDED--HPSORT.
3008C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
3009C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
3010C     LANGUAGE--ANSI FORTRAN (1977)
3011C     REFERENCES--NONE.
3012C     WRITTEN BY--ALAN HECKERT
3013C                 STATISTICAL ENGINEERING DIVISION
3014C                 INFORMATION TECHNOLOGY LABORATORY
3015C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
3016C                 GAITHERSBURG, MD 20899-8980
3017C                 PHONE--301-975-2899
3018C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
3019C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
3020C     LANGUAGE--ANSI FORTRAN (1977)
3021C     VERSION NUMBER--2004/1
3022C     ORIGINAL VERSION--JANUARY   2004.
3023C     UPDATED         --DECEMBER  2009. DON'T USE IXSAVE SO COMMENT
3024C                                       OUT DECLARATION
3025C     UPDATED         --DECEMBER  2009. MODIFY DECLARATION OF IXWORK
3026C                                       FOR INTEL COMPILER
3027C     UPDATED         --APRIL     2017. MODIFY THE FEEDBACK TO SHOW
3028C                                       THE ACTUAL MAPPING
3029C     UPDATED         --JUNE      2019. DIMENSION REAL SCRATCH ARRAYS
3030C                                       IN CALLING ROUTINE
3031C
3032C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
3033C
3034      DIMENSION YTEMP(*)
3035      DIMENSION YTEMP2(*)
3036      DIMENSION IPERM(*)
3037C
3038      CHARACTER*4 IWRITE
3039      CHARACTER*4 IBUGA3
3040      CHARACTER*4 ISUBRO
3041      CHARACTER*4 IERROR
3042C
3043      CHARACTER*4 ISTEPN
3044      CHARACTER*4 ISUBN1
3045      CHARACTER*4 ISUBN2
3046      CHARACTER*4 ICASEL
3047C
3048      CHARACTER*4 IH
3049      CHARACTER*4 IH2
3050      CHARACTER*4 IHLEFT
3051      CHARACTER*4 IHLEF2
3052      CHARACTER*4 IHRIGH
3053      CHARACTER*4 IHRIG2
3054C
3055C---------------------------------------------------------------------
3056C
3057      INCLUDE 'DPCOPA.INC'
3058      INCLUDE 'DPCODA.INC'
3059      INCLUDE 'DPCOHK.INC'
3060      INCLUDE 'DPCOF2.INC'
3061      INCLUDE 'DPCOZC.INC'
3062C
3063CCCCC CHARACTER*80 IFILE
3064      CHARACTER (LEN=MAXFNC) :: IFILE
3065      CHARACTER*12 ISTAT
3066      CHARACTER*12 IFORM
3067      CHARACTER*12 IACCES
3068      CHARACTER*12 IPROT
3069      CHARACTER*12 ICURST
3070      CHARACTER*4 IENDFI
3071      CHARACTER*4 IREWIN
3072      CHARACTER*4 ISUBN0
3073      CHARACTER*4 IERRFI
3074C
3075      CHARACTER*500 IATEMP
3076      CHARACTER*20 IFRMT
3077      CHARACTER*24 IXTEMP(MAXOBV/2)
3078      CHARACTER*24 IXWORK(MAXOBV/2)
3079CCCCC CHARACTER*24 IXSAVE(MAXOBV/2)
3080      EQUIVALENCE (CGARBG(1),IXTEMP(1))
3081      EQUIVALENCE (CGARBG(MAXOBV/2 + 1),IXWORK(1))
3082C
3083C---------------------------------------------------------------------
3084C
3085      INCLUDE 'DPCOP2.INC'
3086C
3087C-----START POINT-----------------------------------------------------
3088C
3089      ISUBN1='CODE'
3090      ISUBN2='C2  '
3091      IERROR='NO'
3092C
3093      INDX=0
3094C
3095      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC2')THEN
3096        ISTEPN='1'
3097        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3098        WRITE(ICOUT,999)
3099  999   FORMAT(1X)
3100        CALL DPWRST('XXX','BUG ')
3101        WRITE(ICOUT,51)
3102   51   FORMAT('***** AT THE BEGINNING OF CODEC2--')
3103        CALL DPWRST('XXX','BUG ')
3104        WRITE(ICOUT,52)IBUGA3
3105   52   FORMAT('IBUGA3 = ',A4)
3106        CALL DPWRST('XXX','BUG ')
3107      ENDIF
3108C
3109C               **************************************************
3110C               **  STEP 1--                                     *
3111C               **  EXAMINE THE LEFT-HAND SIDE--                 *
3112C               **  IS THE NAME     NAME TO LEFT OF = SIGN       *
3113C               **  ALREADY IN THE NAME LIST?                    *
3114C               **  NOTE THAT     ILISTL    IS THE LINE IN THE   *
3115C               **  TABLE OF THE NAME ON THE LEFT.               *
3116C               **************************************************
3117C
3118      IHLEFT=IHARG(1)
3119      IHLEF2=IHARG2(1)
3120      DO2000I=1,NUMNAM
3121        I2=I
3122        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
3123          ILISTL=I2
3124          GOTO2100
3125        ENDIF
3126 2000 CONTINUE
3127      ILISTL=NUMNAM+1
3128      IF(ILISTL.GT.MAXNAM)THEN
3129        WRITE(ICOUT,999)
3130        CALL DPWRST('XXX','BUG ')
3131        WRITE(ICOUT,2201)
3132 2201   FORMAT('***** ERROR IN CODEC2--')
3133        CALL DPWRST('XXX','BUG ')
3134        WRITE(ICOUT,2202)
3135 2202   FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND FUNCTION')
3136        CALL DPWRST('XXX','BUG ')
3137        WRITE(ICOUT,2203)MAXNAM
3138 2203   FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
3139        CALL DPWRST('XXX','BUG ')
3140        WRITE(ICOUT,2204)
3141 2204   FORMAT('      ENTER      STATUS')
3142        CALL DPWRST('XXX','BUG ')
3143        WRITE(ICOUT,2205)
3144 2205   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES, AND')
3145        CALL DPWRST('XXX','BUG ')
3146        WRITE(ICOUT,2206)
3147 2206   FORMAT('      THEN DELETE SOME OF THE ALREADY-USED NAMES.')
3148        CALL DPWRST('XXX','BUG ')
3149        IERROR='YES'
3150        GOTO9000
3151      ENDIF
3152C
3153 2100 CONTINUE
3154C
3155C               *****************************
3156C               **  COMPUTE CODED VALUES.  **
3157C               *****************************
3158C
3159C               ********************************************
3160C               **  STEP 2--                              **
3161C               **  OPEN THE DPZCHF.DAT FILE.             **
3162C               ********************************************
3163C
3164      IHRIGH=IHARG(6)
3165      IHRIG2=IHARG2(6)
3166C
3167      IOUNIT=IZCHNU
3168      IFILE=IZCHNA
3169      ISTAT=IZCHST
3170      IFORM=IZCHFO
3171      IACCES=IZCHAC
3172      IPROT=IZCHPR
3173      ICURST=IZCHCS
3174C
3175      ISUBN0='READ'
3176      IERRFI='NO'
3177      CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,
3178     1            ICURST,
3179     1            IREWIN,ISUBN0,IERRFI,IBUGA3,ISUBRO,IERROR)
3180      IF(IERRFI.EQ.'YES')THEN
3181        IERROR='YES'
3182        WRITE(ICOUT,999)
3183        CALL DPWRST('XXX','BUG ')
3184        WRITE(ICOUT,111)
3185  111   FORMAT('***** ERROR IN CODEC2--')
3186        CALL DPWRST('XXX','BUG ')
3187        WRITE(ICOUT,118)
3188  118   FORMAT('      UNABLE TO OPEN THE FILE CHARACTER DATA FILE:')
3189        CALL DPWRST('XXX','BUG ')
3190        WRITE(ICOUT,119)IFILE
3191  119   FORMAT('      ',A80)
3192        CALL DPWRST('XXX','BUG ')
3193        GOTO8000
3194      ENDIF
3195C
3196      READ(IOUNIT,'(I8)',END=171,ERR=171)NUMVAR
3197C
3198      IVAR=-1
3199      DO130I=1,NUMVAR
3200        READ(IOUNIT,'(A4,A4)',END=181,ERR=181)IH,IH2
3201        IF(IHRIGH.EQ.IH .AND. IHRIG2.EQ.IH2)THEN
3202          IVAR=I
3203CCCCC     GOTO199
3204        ENDIF
3205  130 CONTINUE
3206      IF(IVAR.GT.0)GOTO199
3207C
3208      WRITE(ICOUT,999)
3209      CALL DPWRST('XXX','BUG ')
3210      WRITE(ICOUT,111)
3211      CALL DPWRST('XXX','BUG ')
3212      WRITE(ICOUT,131)IHRIGH,IHRIG2
3213  131 FORMAT('***** VARIABLE ',A4,A4,' NOT FOUND IN THE CHARACTER ',
3214     1       'DATA FILE:')
3215      CALL DPWRST('XXX','BUG ')
3216      WRITE(ICOUT,119)IFILE
3217      CALL DPWRST('XXX','BUG ')
3218      IERROR='YES'
3219      GOTO8000
3220C
3221  171 CONTINUE
3222      WRITE(ICOUT,999)
3223      CALL DPWRST('XXX','BUG ')
3224      WRITE(ICOUT,111)
3225      CALL DPWRST('XXX','BUG ')
3226      WRITE(ICOUT,173)
3227  173 FORMAT('      ERROR READING THE NUMBER OF CHARACTER VARIABLES ',
3228     1       'IN THE CHARACTER DATA FILE:')
3229      CALL DPWRST('XXX','BUG ')
3230      WRITE(ICOUT,119)IFILE
3231      CALL DPWRST('XXX','BUG ')
3232      IERROR='YES'
3233      GOTO8000
3234C
3235  181 CONTINUE
3236      WRITE(ICOUT,999)
3237      CALL DPWRST('XXX','BUG ')
3238      WRITE(ICOUT,111)
3239      CALL DPWRST('XXX','BUG ')
3240      WRITE(ICOUT,183)
3241  183 FORMAT('      ERROR READING THE VARIABLE NAMES ',
3242     1       'IN THE CHARACTER DATA FILE:')
3243      CALL DPWRST('XXX','BUG ')
3244      WRITE(ICOUT,119)IFILE
3245      CALL DPWRST('XXX','BUG ')
3246      IERROR='YES'
3247      GOTO8000
3248C
3249  199 CONTINUE
3250C
3251C               *************************************************
3252C               **  STEP 2--                                   **
3253C               **  PERFORM THE CODING--                       **
3254C               **  1) STORE UNIQUE VALUES IN IXTEMP           **
3255C               **  2) SORT VALUES IN IXTEMP                   **
3256C               **  3) CODE BASED ON SORTED IXTEMP VALUES      **
3257C               *************************************************
3258C
3259      ISTEPN='2'
3260      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC2')
3261     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3262C
3263      IATEMP=' '
3264      IFRMT=' '
3265      IFRMT='(A   )'
3266      WRITE(IFRMT(3:5),'(I3)')25*IVAR
3267      N=1
3268      IROW=1
3269      READ(IOUNIT,IFRMT,END=491,ERR=491)IATEMP
3270      YTEMP(1)=REAL(N)
3271      IFRST=(IVAR-1)*25 + 1
3272      ILAST=IVAR*25 - 1
3273      IXTEMP(1)=' '
3274      IXTEMP(1)=IATEMP(IFRST:ILAST)
3275C
3276      DO210I=2,MAXOBV
3277        IATEMP=' '
3278        READ(IOUNIT,IFRMT,END=499,ERR=491)IATEMP
3279        IROW=IROW+1
3280        DO220J=1,N
3281          IF(IATEMP(IFRST:ILAST).EQ.IXTEMP(J)(1:24))THEN
3282            YTEMP(IROW)=REAL(J)
3283            GOTO210
3284          ENDIF
3285  220   CONTINUE
3286        N=N+1
3287        IF(N.GT.MAXOBV/2)THEN
3288          WRITE(ICOUT,999)
3289          CALL DPWRST('XXX','BUG ')
3290          WRITE(ICOUT,111)
3291          CALL DPWRST('XXX','BUG ')
3292          WRITE(ICOUT,221)
3293  221     FORMAT('      NUMBER OF UNIQUE CHARACTER VALUE EXCEEDS ',
3294     1           I8,' .')
3295          CALL DPWRST('XXX','BUG ')
3296          WRITE(ICOUT,223)
3297  223     FORMAT('      CODING NOT PERFORMED.')
3298          CALL DPWRST('XXX','BUG ')
3299          IERROR='YES'
3300          GOTO9000
3301        ENDIF
3302        IXTEMP(N)=' '
3303        IXTEMP(N)=IATEMP(IFRST:ILAST)
3304        YTEMP(IROW)=REAL(N)
3305  210 CONTINUE
3306C
3307  499 CONTINUE
3308C
3309      ISTEPN='3'
3310      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC2')
3311     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3312C
3313      IBEG=1
3314      IEND=24
3315      KFLAG=2
3316      IER=0
3317      CALL HPSORT(IXTEMP,N,IBEG,IEND,IPERM,KFLAG,IXWORK(1),IER)
3318C
3319      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC2')THEN
3320        WRITE(ICOUT,292)N,IROW,IER
3321  292   FORMAT('N,IROW,IER = ',3I8)
3322        CALL DPWRST('XXX','BUG ')
3323        IF(N.GT.0)THEN
3324          DO290I=1,N
3325            WRITE(ICOUT,293)I,IXTEMP(I),IPERM(I)
3326  293       FORMAT('I,IXTEMP(I),IPERM(I) = ',I8,1X,A24,1X,I8)
3327            CALL DPWRST('XXX','BUG ')
3328  290     CONTINUE
3329        ENDIF
3330      ENDIF
3331      IF(IER.GT.0)GOTO9000
3332C
3333      ISTEPN='4'
3334      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC2')
3335     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3336C
3337      DO310I=1,IROW
3338        ITEMP=INT(YTEMP(I) + 0.5)
3339        DO320K=1,N
3340          IF(ITEMP.EQ.IPERM(K))THEN
3341            INDX=K
3342            GOTO329
3343          ENDIF
3344  320   CONTINUE
3345  329   CONTINUE
3346        YTEMP2(I)=REAL(INDX)
3347  310 CONTINUE
3348      DO330I=1,IROW
3349        YTEMP(I)=YTEMP2(I)
3350  330 CONTINUE
3351C
3352      GOTO599
3353C
3354  491 CONTINUE
3355      WRITE(ICOUT,999)
3356      CALL DPWRST('XXX','BUG ')
3357      WRITE(ICOUT,111)
3358      CALL DPWRST('XXX','BUG ')
3359      WRITE(ICOUT,493)IROW
3360  493 FORMAT('      ERROR READING ROW ',I8,' OF THE CHARACTER ',
3361     1       'VARIABLES IN THE CHARACTER DATA FILE:')
3362      CALL DPWRST('XXX','BUG ')
3363      WRITE(ICOUT,119)IFILE
3364      CALL DPWRST('XXX','BUG ')
3365      IERROR='YES'
3366      GOTO8000
3367C
3368C               ******************************
3369C               **  STEP 3--                **
3370C               **  WRITE OUT A FEW LINES   **
3371C               **  OF SUMMARY INFORMATION  **
3372C               **  ABOUT THE CODING.       **
3373C               ******************************
3374C
3375  599 CONTINUE
3376C
3377C     2017/04: MODIFY THE FEEDBACK TO SHOW THE FULL MAPPING
3378C
3379      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
3380        WRITE(ICOUT,999)
3381        CALL DPWRST('XXX','BUG ')
3382        WRITE(ICOUT,811)IHRIGH,IHRIG2,N
3383  811   FORMAT('NUMBER OF DISTINCT CHARACTER VALUES FOR ',2A4,' = ',I8)
3384        CALL DPWRST('XXX','BUG ')
3385        WRITE(ICOUT,999)
3386        CALL DPWRST('XXX','BUG ')
3387        IF(N.LE.9)THEN
3388          IFRMT="(A  ,' => ',I1)"
3389        ELSEIF(N.LE.99)THEN
3390          IFRMT="(A  ,' => ',I2)"
3391        ELSE
3392          IFRMT="(A  ,' => ',I3)"
3393        ENDIF
3394C
3395        MAXCHR=1
3396        DO810I=1,MIN(N,100)
3397          DO813J=24,1,-1
3398            IF(IXTEMP(I)(J:J).NE.' ')THEN
3399              IF(J.GT.MAXCHR)MAXCHR=J
3400              GOTO815
3401            ENDIF
3402  813     CONTINUE
3403  815     CONTINUE
3404  810   CONTINUE
3405        WRITE(IFRMT(3:4),'(I2)')MAXCHR
3406C
3407        DO820I=1,N
3408          WRITE(ICOUT,IFRMT)IXTEMP(I),I
3409          CALL DPWRST('XXX','BUG ')
3410  820   CONTINUE
3411      ENDIF
3412C
3413C               *****************************************************
3414C               **  STEP 5--                                       **
3415C               **  ENTER THE CODED      VALUES INTO THE DATAPLOT  **
3416C               **  HOUSEKEEPING ARRAY                             **
3417C               *****************************************************
3418C
3419      ISTEPN='5'
3420      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC2')
3421     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3422C
3423      ICASEL='V'
3424      XINT=0.0
3425      IXINT=0
3426      CALL DPINVP(IHLEFT,IHLEF2,ICASEL,YTEMP,IROW,XINT,IXINT,
3427     1ISUBN1,ISUBN2,IBUGA3,IERROR)
3428C
3429C               ***************************************
3430C               **  STEP 6--                         **
3431C               **  CLOSE THE DPZCHF.DAT FILE.       **
3432C               ***************************************
3433C
3434 8000 CONTINUE
3435C
3436      ISTEPN='6'
3437      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC2')
3438     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3439C
3440      IENDFI='OFF'
3441      IREWIN='ON'
3442      CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
3443     1            IENDFI,IREWIN,ISUBN0,IERRFI,IBUGA3,ISUBRO,IERROR)
3444      IZCHCS='CLOSED'
3445      GOTO9000
3446C
3447C               *****************
3448C               **  STEP 90--  **
3449C               **  EXIT.      **
3450C               *****************
3451C
3452 9000 CONTINUE
3453C
3454      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC2')THEN
3455        WRITE(ICOUT,999)
3456        CALL DPWRST('XXX','BUG ')
3457        WRITE(ICOUT,9011)
3458 9011   FORMAT('***** AT THE END OF CODEC2--')
3459        CALL DPWRST('XXX','BUG ')
3460        WRITE(ICOUT,9012)IBUGA3,IERROR
3461 9012   FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
3462        CALL DPWRST('XXX','BUG ')
3463        WRITE(ICOUT,9013)N,IROW
3464 9013   FORMAT('N,IROW = ',2I8)
3465        CALL DPWRST('XXX','BUG ')
3466        DO9015I=1,N
3467          WRITE(ICOUT,9016)I,IXTEMP(I)
3468 9016     FORMAT('I,IXTEMP(I) = ',I8,A24)
3469          CALL DPWRST('XXX','BUG ')
3470 9015   CONTINUE
3471        DO9035I=1,IROW
3472          WRITE(ICOUT,9036)I,YTEMP(I)
3473 9036     FORMAT('I,YTEMP(I) = ',I8,E15.7)
3474          CALL DPWRST('XXX','BUG ')
3475 9035   CONTINUE
3476      ENDIF
3477C
3478      RETURN
3479      END
3480      SUBROUTINE CODEC3(YTEMP,IWRITE,IBUGA3,ISUBRO,IERROR)
3481C
3482C     PURPOSE--THIS SUBROUTINE READS THE CHARCTER DATA STORED IN
3483C              FILE "DPZCHF.DAT" AND CODES A SELECTED FIELD INTO
3484C              A NUMERIC VARIABLE.  THIS IMPLEMENTS THE
3485C              "REFERENCE CHARACTER CODE" COMMAND.
3486C
3487C              FOR THE "CODECH" ROUTINE (WHICH IMPLEMENTS THE
3488C              "CHARACTER CODE" COMMAND"), EACH DISTINCT CHARACTER
3489C              VARIABLE WILL BE ASSIGNED AN INTEGER CODE DETERMINED
3490C              BY ORDER THAT THE FIRST OCCURENCE IS FOUND).
3491C
3492C              THIS VARIANT IS SIMILAR.  HOWEVER, INSTEAD OF BASING THE
3493C              CODE BASED ON THE ORDER OF FIRST APPEARANCE, THE CODE
3494C              WILL BE BASED ON A PREVIOUSLY DEFINED GROUP LABEL.  THIS
3495C              IS USEFUL WHEN, FOR EXAMPLE, READING SEVERAL SETS OF DATA
3496C              THAT USE THE SAME CATEGORICAL VARIABLE AND WE WANT THE
3497C              CODING TO BE CONSISTENT ACROSS THE DATA FILES.
3498C
3499C     OUTPUT ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR INTO WHICH
3500C                                THE CODED VALUES WILL BE PLACED.
3501C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS IN
3502C                                THE CHARACTER VARIABLE.
3503C     OUTPUT--THE SINGLE PRECISION VECTOR Y WHICH WILL CONTAIN THE CODED
3504C             VALUES CORRESPONDING TO THE OBSERVATIONS IN THE VECTOR X.
3505C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
3506C     RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N FOR THIS SUBROUTINE
3507C                   IS MAXOBV.
3508C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
3509C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
3510C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
3511C     LANGUAGE--ANSI FORTRAN (1977)
3512C     REFERENCES--NONE.
3513C     WRITTEN BY--ALAN HECKERT
3514C                 STATISTICAL ENGINEERING DIVISION
3515C                 INFORMATION TECHNOLOGY LABORATORY
3516C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
3517C                 GAITHERSBURG, MD 20899-8980
3518C                 PHONE--301-975-2899
3519C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
3520C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
3521C     LANGUAGE--ANSI FORTRAN (1977)
3522C     VERSION NUMBER--2018/06
3523C     ORIGINAL VERSION--JUNE      2018.
3524C     UPDATED         --JUNE      2019. MOVE DIMENSION OF SCRATCH
3525C                                       REAL ARRAY TO CALLING ROUTINE
3526C
3527C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
3528C
3529      DIMENSION YTEMP(*)
3530C
3531      CHARACTER*4 IWRITE
3532      CHARACTER*4 IBUGA3
3533      CHARACTER*4 ISUBRO
3534      CHARACTER*4 IERROR
3535C
3536      CHARACTER*4 ISTEPN
3537      CHARACTER*4 ISUBN1
3538      CHARACTER*4 ISUBN2
3539      CHARACTER*4 ICASEL
3540C
3541      CHARACTER*4 IH
3542      CHARACTER*4 IH2
3543      CHARACTER*4 IHLEFT
3544      CHARACTER*4 IHLEF2
3545      CHARACTER*4 IHRIGH
3546      CHARACTER*4 IHRIG2
3547      CHARACTER*4 IHRIG3
3548      CHARACTER*4 IHRIG4
3549C
3550C---------------------------------------------------------------------
3551C
3552      INCLUDE 'DPCOPA.INC'
3553      INCLUDE 'DPCODA.INC'
3554      INCLUDE 'DPCOHK.INC'
3555      INCLUDE 'DPCOF2.INC'
3556      INCLUDE 'DPCOZC.INC'
3557C
3558CCCCC CHARACTER*80 IFILE
3559      CHARACTER (LEN=MAXFNC) :: IFILE
3560      CHARACTER*12 ISTAT
3561      CHARACTER*12 IFORM
3562      CHARACTER*12 IACCES
3563      CHARACTER*12 IPROT
3564      CHARACTER*12 ICURST
3565      CHARACTER*4 IENDFI
3566      CHARACTER*4 IREWIN
3567      CHARACTER*4 ISUBN0
3568      CHARACTER*4 IERRFI
3569C
3570      CHARACTER*500 IATEMP
3571      CHARACTER*20 IFRMT
3572      CHARACTER*24 IXTEMP(MAXOBV)
3573      EQUIVALENCE (CGARBG(1),IXTEMP(1))
3574C
3575C---------------------------------------------------------------------
3576C
3577      INCLUDE 'DPCOP2.INC'
3578C
3579C-----START POINT-----------------------------------------------------
3580C
3581      ISUBN1='CODE'
3582      ISUBN2='CH  '
3583      IERROR='NO'
3584C
3585      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC3')THEN
3586        WRITE(ICOUT,999)
3587  999   FORMAT(1X)
3588        CALL DPWRST('XXX','BUG ')
3589        WRITE(ICOUT,51)
3590   51   FORMAT('***** AT THE BEGINNING OF CODEC3--')
3591        CALL DPWRST('XXX','BUG ')
3592        WRITE(ICOUT,52)IBUGA3,ISUBRO
3593   52   FORMAT('IBUGA3,ISUBRO = ',A4,2X,A4)
3594        CALL DPWRST('XXX','BUG ')
3595      ENDIF
3596C
3597C               **************************************************
3598C               **  STEP 1--                                     *
3599C               **  EXAMINE THE LEFT-HAND SIDE--                 *
3600C               **  IS THE NAME     NAME TO LEFT OF = SIGN       *
3601C               **  ALREADY IN THE NAME LIST?                    *
3602C               **  NOTE THAT     ILISTL    IS THE LINE IN THE   *
3603C               **  TABLE OF THE NAME ON THE LEFT.               *
3604C               **************************************************
3605C
3606      ISTEPN='1'
3607      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC3')
3608     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3609C
3610      IHLEFT=IHARG(1)
3611      IHLEF2=IHARG2(1)
3612      DO100I=1,NUMNAM
3613        I2=I
3614        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
3615          ILISTL=I2
3616          GOTO110
3617        ENDIF
3618  100 CONTINUE
3619      ILISTL=NUMNAM+1
3620      IF(ILISTL.GT.MAXNAM)THEN
3621        WRITE(ICOUT,999)
3622        CALL DPWRST('XXX','BUG ')
3623        WRITE(ICOUT,111)
3624  111   FORMAT('***** ERROR IN REFERENCE CHARACTER CODE--')
3625        CALL DPWRST('XXX','BUG ')
3626        WRITE(ICOUT,112)
3627  112   FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND FUNCTION')
3628        CALL DPWRST('XXX','BUG ')
3629        WRITE(ICOUT,113)MAXNAM
3630  113   FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
3631        CALL DPWRST('XXX','BUG ')
3632        WRITE(ICOUT,114)
3633  114   FORMAT('      ENTER      STATUS')
3634        CALL DPWRST('XXX','BUG ')
3635        WRITE(ICOUT,115)
3636  115   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES, AND')
3637        CALL DPWRST('XXX','BUG ')
3638        WRITE(ICOUT,116)
3639  116   FORMAT('      THEN DELETE SOME OF THE ALREADY-USED NAMES.')
3640        CALL DPWRST('XXX','BUG ')
3641        IERROR='YES'
3642        GOTO9000
3643      ENDIF
3644C
3645  110 CONTINUE
3646C
3647C               **************************************************
3648C               **  STEP 2--                                     *
3649C               **  EXAMINE THE RIGHT-HAND SIDE--                *
3650C               **  IS THE SECOND NAME ON THE RIGHT HAND SIDE    *
3651C               **  A PREVIOUSLY DEFINED GROUP LABEL?            *
3652C               **************************************************
3653C
3654      ISTEPN='1'
3655      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC3')
3656     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3657C
3658      IHRIG3=IHARG(7)
3659      IHRIG4=IHARG2(7)
3660      DO200I=1,MAXGRP
3661        IF(IHRIG3.EQ.IGRPVN(I)(1:4).AND.IHRIG4.EQ.IGRPVN(I)(5:8))THEN
3662          IGRP=I
3663          GOTO210
3664        ENDIF
3665  200 CONTINUE
3666C
3667      WRITE(ICOUT,999)
3668      CALL DPWRST('XXX','BUG ')
3669      WRITE(ICOUT,111)
3670      CALL DPWRST('XXX','BUG ')
3671      WRITE(ICOUT,212)IHRIG3,IHRIG4
3672  212 FORMAT('      THE SPECIFIED GROUP (',2A4,') WAS NOT FOUND.')
3673      CALL DPWRST('XXX','BUG ')
3674      IERROR='YES'
3675      GOTO9000
3676C
3677  210 CONTINUE
3678C
3679      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC3')THEN
3680        WRITE(ICOUT,221)IGRP
3681  221   FORMAT('AT 210: IGRP = ',I8)
3682        CALL DPWRST('XXX','BUG ')
3683        WRITE(ICOUT,51)
3684      ENDIF
3685C
3686C               *****************************
3687C               **  COMPUTE CODED VALUES.  **
3688C               *****************************
3689C
3690C               ********************************************
3691C               **  STEP 3--                              **
3692C               **  OPEN THE DPZCHF.DAT FILE.             **
3693C               ********************************************
3694C
3695      ISTEPN='3'
3696      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC3')
3697     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3698C
3699      IHRIGH=IHARG(6)
3700      IHRIG2=IHARG2(6)
3701C
3702      IOUNIT=IZCHNU
3703      IFILE=IZCHNA
3704      ISTAT=IZCHST
3705      IFORM=IZCHFO
3706      IACCES=IZCHAC
3707      IPROT=IZCHPR
3708      ICURST=IZCHCS
3709C
3710      ISUBN0='READ'
3711      IERRFI='NO'
3712      CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,
3713     1            ICURST,
3714     1            IREWIN,ISUBN0,IERRFI,IBUGA3,ISUBRO,IERROR)
3715      IF(IERRFI.EQ.'YES')THEN
3716        IERROR='YES'
3717        WRITE(ICOUT,999)
3718        CALL DPWRST('XXX','BUG ')
3719        WRITE(ICOUT,111)
3720        CALL DPWRST('XXX','BUG ')
3721        WRITE(ICOUT,311)
3722  311   FORMAT('      UNABLE TO OPEN THE FILE CHARACTER DATA FILE:')
3723        CALL DPWRST('XXX','BUG ')
3724        WRITE(ICOUT,319)IFILE
3725  319   FORMAT('      ',A80)
3726        CALL DPWRST('XXX','BUG ')
3727        GOTO7000
3728      ENDIF
3729C
3730      READ(IOUNIT,'(I8)',END=371,ERR=371)NUMVAR
3731C
3732      IVAR=-1
3733      DO330I=1,NUMVAR
3734        READ(IOUNIT,'(A4,A4)',END=381,ERR=381)IH,IH2
3735        IF(IHRIGH.EQ.IH .AND. IHRIG2.EQ.IH2)THEN
3736          IVAR=I
3737        ENDIF
3738  330 CONTINUE
3739      IF(IVAR.GT.0)GOTO399
3740C
3741      WRITE(ICOUT,999)
3742      CALL DPWRST('XXX','BUG ')
3743      WRITE(ICOUT,111)
3744      CALL DPWRST('XXX','BUG ')
3745      WRITE(ICOUT,331)IHRIGH,IHRIG2
3746  331 FORMAT('      VARIABLE ',A4,A4,' NOT FOUND IN THE CHARACTER ',
3747     1       'DATA FILE:')
3748      CALL DPWRST('XXX','BUG ')
3749      WRITE(ICOUT,319)IFILE
3750      CALL DPWRST('XXX','BUG ')
3751      IERROR='YES'
3752      GOTO7000
3753C
3754  371 CONTINUE
3755      WRITE(ICOUT,999)
3756      CALL DPWRST('XXX','BUG ')
3757      WRITE(ICOUT,111)
3758      CALL DPWRST('XXX','BUG ')
3759      WRITE(ICOUT,373)
3760  373 FORMAT('      ERROR READING THE NUMBER OF CHARACTER VARIABLES ',
3761     1       'IN THE CHARACTER DATA FILE:')
3762      CALL DPWRST('XXX','BUG ')
3763      WRITE(ICOUT,319)IFILE
3764      CALL DPWRST('XXX','BUG ')
3765      IERROR='YES'
3766      GOTO7000
3767C
3768  381 CONTINUE
3769      WRITE(ICOUT,999)
3770      CALL DPWRST('XXX','BUG ')
3771      WRITE(ICOUT,111)
3772      CALL DPWRST('XXX','BUG ')
3773      WRITE(ICOUT,383)
3774  383 FORMAT('      ERROR READING THE VARIABLE NAMES ',
3775     1       'IN THE CHARACTER DATA FILE:')
3776      CALL DPWRST('XXX','BUG ')
3777      WRITE(ICOUT,319)IFILE
3778      CALL DPWRST('XXX','BUG ')
3779      IERROR='YES'
3780      GOTO7000
3781C
3782  399 CONTINUE
3783C
3784C               *************************************************
3785C               **  STEP 4--                                   **
3786C               **  PERFORM THE CODING--                       **
3787C               **  STORE UNIQUE VALUES IN IXTEMP, COMPARE     **
3788C               **  TO LIST IN IXTEMP.                         **
3789C               *************************************************
3790C
3791      ISTEPN='4'
3792      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC3')
3793     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3794C
3795      IFRMT='(A   )'
3796      WRITE(IFRMT(3:5),'(I3)')25*IVAR
3797      IFRST=(IVAR-1)*25 + 1
3798      ILAST=IVAR*25 - 1
3799C
3800      DO410I=1,MAXOBV
3801        IATEMP=' '
3802        READ(IOUNIT,IFRMT,END=499,ERR=491)IATEMP
3803        IROW=I
3804        DO420J=1,MAXGLA
3805          IF(IATEMP(IFRST:ILAST).EQ.IGRPLA(J,IGRP)(1:24))THEN
3806            YTEMP(IROW)=REAL(J)
3807            GOTO419
3808          ENDIF
3809  420   CONTINUE
3810        YTEMP(IROW)=-1.0
3811C
3812  419   CONTINUE
3813        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC3')THEN
3814          WRITE(ICOUT,421)I,IFRST,ILAST
3815  421     FORMAT('AT 419: I,IFRST,ILAST = ',3I8)
3816          CALL DPWRST('XXX','BUG ')
3817          WRITE(ICOUT,423)IATEMP(IFRST:ILAST)
3818  423     FORMAT('IATEMP(IFRST:ILAST) = ',A24)
3819          CALL DPWRST('XXX','BUG ')
3820        ENDIF
3821C
3822  410 CONTINUE
3823      GOTO499
3824C
3825  491 CONTINUE
3826      WRITE(ICOUT,999)
3827      CALL DPWRST('XXX','BUG ')
3828      WRITE(ICOUT,111)
3829      CALL DPWRST('XXX','BUG ')
3830      WRITE(ICOUT,493)IROW
3831  493 FORMAT('      ERROR READING ROW ',I8,' OF THE CHARACTER ',
3832     1       'VARIABLES IN THE CHARACTER DATA FILE:')
3833      CALL DPWRST('XXX','BUG ')
3834      WRITE(ICOUT,319)IFILE
3835      CALL DPWRST('XXX','BUG ')
3836      IERROR='YES'
3837      GOTO7000
3838C
3839C
3840C               ******************************
3841C               **  STEP 5--                **
3842C               **  WRITE OUT A FEW LINES   **
3843C               **  OF SUMMARY INFORMATION  **
3844C               **  ABOUT THE CODING.       **
3845C               ******************************
3846C
3847  499 CONTINUE
3848C
3849      ISTEPN='5'
3850      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC3')
3851     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3852C
3853      CALL MINIM(YTEMP,IROW,IWRITE,YMIN,IBUGA3,IERROR)
3854      CALL MAXIM(YTEMP,IROW,IWRITE,YMAX,IBUGA3,IERROR)
3855C
3856      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
3857        WRITE(ICOUT,999)
3858        CALL DPWRST('XXX','BUG ')
3859        WRITE(ICOUT,811)IHLEFT,IHLEF2,INT(YMIN)
3860  811   FORMAT('THE MINIMUM VALUE FOR ',2A4,' IS: ',I8)
3861        CALL DPWRST('XXX','BUG ')
3862        WRITE(ICOUT,813)IHLEFT,IHLEF2,INT(YMAX)
3863  813   FORMAT('THE MAXIMUM VALUE FOR ',2A4,' IS: ',I8)
3864        CALL DPWRST('XXX','BUG ')
3865      ENDIF
3866C
3867C               *****************************************************
3868C               **  STEP 6--                                       **
3869C               **  ENTER THE CODED      VALUES INTO THE DATAPLOT  **
3870C               **  HOUSEKEEPING ARRAY                             **
3871C               *****************************************************
3872C
3873      ISTEPN='6'
3874      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC3')
3875     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3876C
3877      ICASEL='V'
3878      XINT=0.0
3879      IXINT=0
3880      CALL DPINVP(IHLEFT,IHLEF2,ICASEL,YTEMP,IROW,XINT,IXINT,
3881     1ISUBN1,ISUBN2,IBUGA3,IERROR)
3882C
3883C               ***************************************
3884C               **  STEP 7--                         **
3885C               **  CLOSE THE DPZCHF.DAT FILE.       **
3886C               ***************************************
3887C
3888 7000 CONTINUE
3889C
3890      ISTEPN='7'
3891      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC3')
3892     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3893C
3894      IENDFI='OFF'
3895      IREWIN='ON'
3896      CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
3897     1            IENDFI,IREWIN,ISUBN0,IERRFI,IBUGA3,ISUBRO,IERROR)
3898      IZCHCS='CLOSED'
3899      GOTO9000
3900C
3901C               *****************
3902C               **  STEP 90--  **
3903C               **  EXIT.      **
3904C               *****************
3905C
3906 9000 CONTINUE
3907C
3908      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC3')THEN
3909        WRITE(ICOUT,999)
3910        CALL DPWRST('XXX','BUG ')
3911        WRITE(ICOUT,9011)
3912 9011   FORMAT('***** AT THE END OF CODEC3--')
3913        CALL DPWRST('XXX','BUG ')
3914        WRITE(ICOUT,9013)IERROR,N,IROW
3915 9013   FORMAT('IERROR,N,IROW = ',A4,2X,2I8)
3916        CALL DPWRST('XXX','BUG ')
3917        DO9035I=1,IROW
3918          WRITE(ICOUT,9036)I,YTEMP(I)
3919 9036     FORMAT('I,YTEMP(I) = ',I8,G15.7)
3920          CALL DPWRST('XXX','BUG ')
3921 9035   CONTINUE
3922      ENDIF
3923C
3924      RETURN
3925      END
3926      SUBROUTINE CODEDX(X,N,IWRITE,Y,XDIST,IBUGA3,ISUBRO,IERROR)
3927C
3928C     PURPOSE--FOR CLASSIC 2-LEVEL FACTORIAL DESIGNS, IT IS CONVENIENT
3929C              FOR EACH OF THE FACTOR VARIABLES TO LABEL THE LOW VALUE AS
3930C              "-1" AND THE HIGH VALUE AS "+1".  IN ADDITION, THERE MAY BE
3931C              CENTER POINTS WHICH ARE CODED AS "0".  IF THE FACTOR
3932C              VARIABLE IS CODED IN THE ORIGINAL UNITS OF THE DATA, THIS
3933C              ROUTINE CAN BE USED TO CONVERT IT TO THE "-1" AND "+1"
3934C              CODING.
3935C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR
3936C                                OF OBSERVATIONS TO BE CODED.
3937C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
3938C                                IN THE VECTOR X.
3939C     OUTPUT ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR
3940C                                INTO WHICH THE CODED VALUES
3941C                                WILL BE PLACED.
3942C     OUTPUT--THE SINGLE PRECISION VECTOR Y WHICH WILL CONTAIN THE CODED
3943C             VALUES CORRESPONDING TO THE OBSERVATIONS IN THE VECTOR X.
3944C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
3945C     RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N FOR THIS SUBROUTINE
3946C                   IS 15000.
3947C     OTHER DATAPAC   SUBROUTINES NEEDED--DISTIN.
3948C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
3949C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
3950C     LANGUAGE--ANSI FORTRAN (1977)
3951C     COMMENT--THE INPUT VECTOR X REMAINS UNALTERED.
3952C     REFERENCES--NONE.
3953C     WRITTEN BY--ALAN HECKERT
3954C                 STATISTICAL ENGINEERING DIVISION
3955C                 INFORMATION TECHNOLOGY LABORATORY
3956C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
3957C                 GAITHERSBURG, MD 20899
3958C                 PHONE--301-975-2899
3959C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
3960C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
3961C     VERSION NUMBER--2018/01
3962C     ORIGINAL VERSION--JANUARY   2018.
3963C
3964C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
3965C
3966      CHARACTER*4 IWRITE
3967      CHARACTER*4 IBUGA3
3968      CHARACTER*4 ISUBRO
3969      CHARACTER*4 IERROR
3970C
3971      CHARACTER*4 ISUBN1
3972      CHARACTER*4 ISUBN2
3973C
3974C---------------------------------------------------------------------
3975C
3976      DIMENSION X(*)
3977      DIMENSION Y(*)
3978      DIMENSION XDIST(*)
3979C
3980C---------------------------------------------------------------------
3981C
3982      INCLUDE 'DPCOP2.INC'
3983C
3984C-----START POINT-----------------------------------------------------
3985C
3986      ISUBN1='CODE'
3987      ISUBN2='DX  '
3988      IERROR='NO'
3989C
3990      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEDX')THEN
3991        WRITE(ICOUT,999)
3992  999   FORMAT(1X)
3993        CALL DPWRST('XXX','BUG ')
3994        WRITE(ICOUT,51)
3995   51   FORMAT('***** AT THE BEGINNING OF CODEDX--')
3996        CALL DPWRST('XXX','BUG ')
3997        WRITE(ICOUT,53)IBUGA3,ISUBRO,N
3998   53   FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8)
3999        CALL DPWRST('XXX','BUG ')
4000        DO55I=1,N
4001          WRITE(ICOUT,56)I,X(I)
4002   56     FORMAT('I,X(I) = ',I8,G15.7)
4003          CALL DPWRST('XXX','BUG ')
4004   55   CONTINUE
4005      ENDIF
4006C
4007C               *****************************
4008C               **  COMPUTE CODED VALUES.  **
4009C               *****************************
4010C
4011C               ********************************************
4012C               **  STEP 1--                              **
4013C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
4014C               ********************************************
4015C
4016      IF(N.LT.1)THEN
4017        WRITE(ICOUT,999)
4018        CALL DPWRST('XXX','BUG ')
4019        WRITE(ICOUT,111)
4020  111   FORMAT('***** ERROR IN CODEDX--')
4021        CALL DPWRST('XXX','BUG ')
4022        WRITE(ICOUT,113)
4023  113   FORMAT('      THE NUMBER OF OBSERVATIONS IN THE RESPONSE ',
4024     1         'VARIABLE IS LESS THAN 1.')
4025        CALL DPWRST('XXX','BUG ')
4026        WRITE(ICOUT,118)N
4027  118   FORMAT('      THE NUMBER OF OBSERVATIONS IS ',I10)
4028        CALL DPWRST('XXX','BUG ')
4029        IERROR='YES'
4030        GOTO9000
4031      ELSEIF(N.EQ.1)THEN
4032        Y(1)=1.0
4033        GOTO8000
4034      ENDIF
4035C
4036      HOLD=X(1)
4037      DO135I=2,N
4038        IF(X(I).NE.HOLD)GOTO139
4039  135 CONTINUE
4040      DO137I=1,N
4041        Y(I)=1.0
4042  137 CONTINUE
4043      GOTO8000
4044  139 CONTINUE
4045C
4046C               *************************************************************
4047C               **  STEP 2--                                               **
4048C               **  PERFORM THE CODING--                                   **
4049C               *************************************************************
4050C
4051      CALL DISTIN(X,N,IWRITE,XDIST,NDIST,IBUGA3,IERROR)
4052      CALL SORT(XDIST,NDIST,XDIST)
4053C
4054      IF(NDIST.EQ.1)THEN
4055        DO210I=1,N
4056          Y(I)=1.0
4057  210   CONTINUE
4058      ELSEIF(NDIST.EQ.2)THEN
4059        AVAL1=XDIST(1)
4060        AVAL2=XDIST(2)
4061        DO220I=1,N
4062          IF(X(I).EQ.AVAL1)THEN
4063            Y(I)=-1.0
4064          ELSE
4065            Y(I)=1.0
4066          ENDIF
4067  220   CONTINUE
4068      ELSEIF(NDIST.EQ.3)THEN
4069        AVAL1=XDIST(1)
4070        AVAL2=XDIST(2)
4071        AVAL3=XDIST(3)
4072        DO230I=1,N
4073          IF(X(I).EQ.AVAL1)THEN
4074            Y(I)=-1.0
4075          ELSEIF(X(I).EQ.AVAL3)THEN
4076            Y(I)=1.0
4077          ELSE
4078            Y(I)=0.0
4079          ENDIF
4080  230   CONTINUE
4081      ELSE
4082        WRITE(ICOUT,111)
4083        CALL DPWRST('XXX','BUG ')
4084        WRITE(ICOUT,241)
4085  241   FORMAT('      THE RESPONSE VARIABLE CONTAINS MORE THAN THREE ',
4086     1         'DISTINCT VALUES.')
4087        CALL DPWRST('XXX','BUG ')
4088        WRITE(ICOUT,243)NDIST
4089  243   FORMAT('      THE NUMBER OF DISTINCT VALUES DETECTED WAS ',I8)
4090        CALL DPWRST('XXX','BUG ')
4091        IERROR='YES'
4092        GOTO9000
4093      ENDIF
4094C
4095C               ******************************
4096C               **  STEP 3--                **
4097C               **  WRITE OUT A FEW LINES   **
4098C               **  OF SUMMARY INFORMATION  **
4099C               **  ABOUT THE CODING.       **
4100C               ******************************
4101C
4102 8000 CONTINUE
4103C
4104      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
4105        WRITE(ICOUT,999)
4106        CALL DPWRST('XXX','BUG ')
4107        IF(NDIST.LE.2)THEN
4108          WRITE(ICOUT,8112)
4109 8112     FORMAT('THE RESPONSE VARIABLE HAS BEEN CODED AS ',
4110     1         '-1 AND +1 VALUES.')
4111          CALL DPWRST('XXX','BUG ')
4112        ELSE
4113          WRITE(ICOUT,8114)
4114 8114     FORMAT('THE RESPONSE VARIABLE HAS BEEN CODED AS ',
4115     1         '-1, 0, AND +1 VALUES.')
4116          CALL DPWRST('XXX','BUG ')
4117        ENDIF
4118      ENDIF
4119C
4120C               *****************
4121C               **  STEP 90--  **
4122C               **  EXIT.      **
4123C               *****************
4124C
4125 9000 CONTINUE
4126C
4127      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEDX')THEN
4128        WRITE(ICOUT,999)
4129        CALL DPWRST('XXX','BUG ')
4130        WRITE(ICOUT,9011)
4131 9011   FORMAT('***** AT THE END       OF CODEDX--')
4132        CALL DPWRST('XXX','BUG ')
4133        WRITE(ICOUT,9013)IERROR
4134 9013   FORMAT('IERROR = ',A4)
4135        CALL DPWRST('XXX','BUG ')
4136        DO9015I=1,N
4137          WRITE(ICOUT,9016)I,X(I),Y(I)
4138 9016     FORMAT('I,X(I),Y(I) = ',I8,G15.7,F7.0)
4139          CALL DPWRST('XXX','BUG ')
4140 9015   CONTINUE
4141      ENDIF
4142C
4143      RETURN
4144      END
4145      SUBROUTINE CODED2(X,N,IWRITE,Y,NOUT,XDIST,IBUGA3,ISUBRO,IERROR)
4146C
4147C     PURPOSE--FOR CLASSIC 2-LEVEL FACTORIAL DESIGNS, IT IS CONVENIENT
4148C              FOR EACH OF THE FACTOR VARIABLES TO LABEL THE LOW VALUE AS
4149C              "-1" AND THE HIGH VALUE AS "+1".  IN ADDITION, THERE MAY BE
4150C              CENTER POINTS WHICH ARE CODED AS "0".  IF THE FACTOR
4151C              VARIABLE IS CODED IN THE ORIGINAL UNITS OF THE DATA, THIS
4152C              ROUTINE CAN BE USED TO CONVERT IT TO THE "-1" AND "+1"
4153C              CODING.
4154C
4155C              THIS ROUTINE IS SIMILAR TO "CODEDX".  THE DISTINCTION IS
4156C              THAT THIS ROUTINE ONLY SAVES THE MINIMUM VALUE (AS -1)
4157C              AND THE MAXIMUM VALUE (AS +1).  ALL OTHER VALUES ARE
4158C              DISCARDED.
4159C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR
4160C                                OF OBSERVATIONS TO BE CODED.
4161C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
4162C                                IN THE VECTOR X.
4163C     OUTPUT ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR
4164C                                INTO WHICH THE CODED VALUES
4165C                                WILL BE PLACED.
4166C                     --NOUT   = THE INTEGER NUMBER OF OBSERVATIONS
4167C                                THAT ARE SAVED IN Y (NOT NECCESSARILY
4168C                                EQUAL TO N).
4169C     OUTPUT--THE SINGLE PRECISION VECTOR Y WHICH WILL CONTAIN THE CODED
4170C             VALUES CORRESPONDING TO THE OBSERVATIONS IN THE VECTOR X.
4171C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
4172C     RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N FOR THIS SUBROUTINE
4173C                   IS 15000.
4174C     OTHER DATAPAC   SUBROUTINES NEEDED--DISTIN.
4175C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
4176C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
4177C     LANGUAGE--ANSI FORTRAN (1977)
4178C     COMMENT--THE INPUT VECTOR X REMAINS UNALTERED.
4179C     REFERENCES--NONE.
4180C     WRITTEN BY--ALAN HECKERT
4181C                 STATISTICAL ENGINEERING DIVISION
4182C                 INFORMATION TECHNOLOGY LABORATORY
4183C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
4184C                 GAITHERSBURG, MD 20899
4185C                 PHONE--301-975-2899
4186C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
4187C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
4188C     VERSION NUMBER--2018/10
4189C     ORIGINAL VERSION--OCTOBER   2018.
4190C
4191C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
4192C
4193      CHARACTER*4 IWRITE
4194      CHARACTER*4 IBUGA3
4195      CHARACTER*4 ISUBRO
4196      CHARACTER*4 IERROR
4197C
4198      CHARACTER*4 ISUBN1
4199      CHARACTER*4 ISUBN2
4200C
4201C---------------------------------------------------------------------
4202C
4203      DIMENSION X(*)
4204      DIMENSION Y(*)
4205      DIMENSION XDIST(*)
4206C
4207C---------------------------------------------------------------------
4208C
4209      INCLUDE 'DPCOP2.INC'
4210C
4211C-----START POINT-----------------------------------------------------
4212C
4213      ISUBN1='CODE'
4214      ISUBN2='D2  '
4215      IERROR='NO'
4216C
4217      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DED2')THEN
4218        WRITE(ICOUT,999)
4219  999   FORMAT(1X)
4220        CALL DPWRST('XXX','BUG ')
4221        WRITE(ICOUT,51)
4222   51   FORMAT('***** AT THE BEGINNING OF CODED2--')
4223        CALL DPWRST('XXX','BUG ')
4224        WRITE(ICOUT,53)IBUGA3,ISUBRO,N
4225   53   FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8)
4226        CALL DPWRST('XXX','BUG ')
4227        DO55I=1,N
4228          WRITE(ICOUT,56)I,X(I)
4229   56     FORMAT('I,X(I) = ',I8,G15.7)
4230          CALL DPWRST('XXX','BUG ')
4231   55   CONTINUE
4232      ENDIF
4233C
4234C               *****************************
4235C               **  COMPUTE CODED VALUES.  **
4236C               *****************************
4237C
4238C               ********************************************
4239C               **  STEP 1--                              **
4240C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
4241C               ********************************************
4242C
4243      IF(N.LT.1)THEN
4244        WRITE(ICOUT,999)
4245        CALL DPWRST('XXX','BUG ')
4246        WRITE(ICOUT,111)
4247  111   FORMAT('***** ERROR IN CODED2--')
4248        CALL DPWRST('XXX','BUG ')
4249        WRITE(ICOUT,113)
4250  113   FORMAT('      THE NUMBER OF OBSERVATIONS IN THE RESPONSE ',
4251     1         'VARIABLE IS LESS THAN 1.')
4252        CALL DPWRST('XXX','BUG ')
4253        WRITE(ICOUT,118)N
4254  118   FORMAT('      THE NUMBER OF OBSERVATIONS IS ',I10)
4255        CALL DPWRST('XXX','BUG ')
4256        IERROR='YES'
4257        GOTO9000
4258      ELSEIF(N.EQ.1)THEN
4259        Y(1)=1.0
4260        NOUT=1
4261        GOTO8000
4262      ENDIF
4263C
4264      HOLD=X(1)
4265      DO135I=2,N
4266        IF(X(I).NE.HOLD)GOTO139
4267  135 CONTINUE
4268      DO137I=1,N
4269        Y(I)=1.0
4270  137 CONTINUE
4271      NOUT=N
4272      GOTO8000
4273  139 CONTINUE
4274C
4275C               *************************************************************
4276C               **  STEP 2--                                               **
4277C               **  PERFORM THE CODING--                                   **
4278C               *************************************************************
4279C
4280      CALL DISTIN(X,N,IWRITE,XDIST,NDIST,IBUGA3,IERROR)
4281      CALL SORT(XDIST,NDIST,XDIST)
4282C
4283      IF(NDIST.EQ.1)THEN
4284        DO210I=1,N
4285          Y(I)=1.0
4286  210   CONTINUE
4287        NOUT=N
4288      ELSEIF(NDIST.EQ.2)THEN
4289        AVAL1=XDIST(1)
4290        AVAL2=XDIST(2)
4291        DO220I=1,N
4292          IF(X(I).EQ.AVAL1)THEN
4293            Y(I)=-1.0
4294          ELSE
4295            Y(I)=1.0
4296          ENDIF
4297  220   CONTINUE
4298        NOUT=N
4299      ELSEIF(NDIST.GE.3)THEN
4300        AVAL1=XDIST(1)
4301        AVAL2=XDIST(NDIST)
4302        NOUT=0
4303        DO230I=1,N
4304          IF(X(I).EQ.AVAL1)THEN
4305            Y(I)=-1.0
4306            NOUT=NOUT+1
4307          ELSEIF(X(I).EQ.AVAL2)THEN
4308            Y(I)=1.0
4309            NOUT=NOUT+1
4310          ENDIF
4311  230   CONTINUE
4312      ENDIF
4313C
4314C               ******************************
4315C               **  STEP 3--                **
4316C               **  WRITE OUT A FEW LINES   **
4317C               **  OF SUMMARY INFORMATION  **
4318C               **  ABOUT THE CODING.       **
4319C               ******************************
4320C
4321 8000 CONTINUE
4322C
4323      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
4324        WRITE(ICOUT,999)
4325        CALL DPWRST('XXX','BUG ')
4326        WRITE(ICOUT,8112)
4327 8112   FORMAT('THE RESPONSE VARIABLE HAS BEEN CODED AS ',
4328     1         '-1 AND +1 VALUES.')
4329        CALL DPWRST('XXX','BUG ')
4330      ENDIF
4331C
4332C               *****************
4333C               **  STEP 90--  **
4334C               **  EXIT.      **
4335C               *****************
4336C
4337 9000 CONTINUE
4338C
4339      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DED2')THEN
4340        WRITE(ICOUT,999)
4341        CALL DPWRST('XXX','BUG ')
4342        WRITE(ICOUT,9011)
4343 9011   FORMAT('***** AT THE END       OF CODED2--')
4344        CALL DPWRST('XXX','BUG ')
4345        WRITE(ICOUT,9013)IERROR,NOUT,NDIST
4346 9013   FORMAT('IERROR,NOUT,NDIST = ',A4,2X,2I8)
4347        CALL DPWRST('XXX','BUG ')
4348        DO9015I=1,NOUT
4349          WRITE(ICOUT,9016)I,Y(I)
4350 9016     FORMAT('I,Y(I) = ',I8,F7.0)
4351          CALL DPWRST('XXX','BUG ')
4352 9015   CONTINUE
4353      ENDIF
4354C
4355      RETURN
4356      END
4357      SUBROUTINE CODEH(X,N,NUMINT,IWRITE,Y,XS,MAXOBV,IBUGA3,IERROR)
4358C
4359C     PURPOSE--THIS SUBROUTINE CODES THE ELEMENTS
4360C              OF THE INPUT VECTOR X
4361C              AND PUTS THE CODED VALUES INTO THE OUTPUT VECTOR Y.
4362C              THE CODING IS AS FOLLOWS--
4363C                  THE FIRST NUMINT'TH OF THE DATA IS CODED AS 1.0
4364C                  THE NEXT  NUMINT'TH OF THE DATA IS CODED AS 2.0
4365C                  ETC.
4366C                  THE LAST  NUMINT'TH OF THE DATA IS CODED AS NUMINT
4367C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR
4368C                                OF OBSERVATIONS TO BE CODED.
4369C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
4370C                                IN THE VECTOR X.
4371C     OUTPUT ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR
4372C                                INTO WHICH THE CODED VALUES
4373C                                WILL BE PLACED.
4374C     OUTPUT--THE SINGLE PRECISION VECTOR Y
4375C             WHICH WILL CONTAIN THE CODED VALUES
4376C             CORRESPONDING TO THE OBSERVATIONS IN
4377C             THE VECTOR X.
4378C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
4379C     RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N
4380C                   FOR THIS SUBROUTINE IS 15000.
4381C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT.
4382C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
4383C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
4384C     LANGUAGE--ANSI FORTRAN (1977)
4385C     COMMENT--THE INPUT VECTOR X REMAINS UNALTERED.
4386C     REFERENCES--NONE.
4387C     WRITTEN BY--JAMES J. FILLIBEN
4388C                 STATISTICAL ENGINEERING DIVISION
4389C                 INFORMATION TECHNOLOGY LABORATORY
4390C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
4391C                 GAITHERSBURG, MD 20899
4392C                 PHONE--301-975-2855
4393C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
4394C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
4395C     VERSION NUMBER--82/7
4396C     ORIGINAL VERSION--OCTOBER   1981.
4397C     UPDATED         --MAY       1982.
4398C     UPDATED         --JUNE      1990. TEMPORARY ARRAYS TO GARBAGE COMMON
4399C
4400C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
4401C
4402      CHARACTER*4 IWRITE
4403      CHARACTER*4 IBUGA3
4404      CHARACTER*4 IERROR
4405C
4406      CHARACTER*4 ISUBN1
4407      CHARACTER*4 ISUBN2
4408C
4409C---------------------------------------------------------------------
4410C
4411CCCCC INCLUDE 'DPCOPA.INC'
4412C
4413      DIMENSION X(*)
4414      DIMENSION Y(*)
4415      DIMENSION XS(MAXOBV)
4416CCCCC FOLLOWING LINES ADDED JUNE, 1990
4417CCCCC INCLUDE 'DPCOZ2.INC'
4418CCCCC EQUIVALENCE (G2RBAG(IGAR45),XS(1))
4419CCCCC END CHANGE
4420C
4421C---------------------------------------------------------------------
4422C
4423      INCLUDE 'DPCOP2.INC'
4424C
4425C-----START POINT-----------------------------------------------------
4426C
4427      ISUBN1='CODE'
4428      ISUBN2='N   '
4429C
4430      IERROR='NO'
4431      IUPPER=MAXOBV
4432C
4433      X50=0.0
4434C
4435      IF(IBUGA3.EQ.'OFF')GOTO90
4436      WRITE(ICOUT,999)
4437  999 FORMAT(1X)
4438      CALL DPWRST('XXX','BUG ')
4439      WRITE(ICOUT,51)
4440   51 FORMAT('***** AT THE BEGINNING OF CODEH--')
4441      CALL DPWRST('XXX','BUG ')
4442      WRITE(ICOUT,52)IBUGA3
4443   52 FORMAT('IBUGA3 = ',A4)
4444      CALL DPWRST('XXX','BUG ')
4445      WRITE(ICOUT,53)N,IUPPER,NUMINT
4446   53 FORMAT('N,IUPPER,NUMINT = ',3I8)
4447      CALL DPWRST('XXX','BUG ')
4448      DO55I=1,N
4449      WRITE(ICOUT,56)I,X(I)
4450   56 FORMAT('I,X(I) = ',I8,E15.7)
4451      CALL DPWRST('XXX','BUG ')
4452   55 CONTINUE
4453   90 CONTINUE
4454C
4455C               *****************************
4456C               **  COMPUTE CODED VALUES.  **
4457C               *****************************
4458C
4459C               ********************************************
4460C               **  STEP 1--                              **
4461C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
4462C               ********************************************
4463C
4464      IF(1.LE.N.AND.N.LE.IUPPER)GOTO119
4465      IERROR='YES'
4466      WRITE(ICOUT,999)
4467      CALL DPWRST('XXX','BUG ')
4468      WRITE(ICOUT,111)IUPPER
4469  111 FORMAT('***** ERROR IN CODEH--',
4470     1'THE SECOND INPUT ARGUMENT (N) IS SMALLER THAN 1',
4471     1'OR LARGER THAN ',I8)
4472      CALL DPWRST('XXX','BUG ')
4473      WRITE(ICOUT,118)N
4474  118 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
4475      CALL DPWRST('XXX','BUG ')
4476      GOTO9000
4477  119 CONTINUE
4478C
4479      IF(N.EQ.1)GOTO120
4480      GOTO129
4481  120 CONTINUE
4482CCCCC WRITE(ICOUT,999)
4483CCCCC CALL DPWRST('XXX','BUG ')
4484CCCCC WRITE(ICOUT,121)
4485CC121 FORMAT('***** NON-FATAL DIAGNOSTIC IN CODEH--',
4486CCCCC CALL DPWRST('XXX','BUG ')
4487CCCCC1'THE SECOND INPUT ARGUMENT (N) HAS THE VALUE 1')
4488      Y(1)=1.0
4489      GOTO9000
4490  129 CONTINUE
4491C
4492      HOLD=X(1)
4493      DO135I=2,N
4494      IF(X(I).NE.HOLD)GOTO139
4495  135 CONTINUE
4496CCCCC WRITE(ICOUT,999)
4497CCCCC CALL DPWRST('XXX','BUG ')
4498CCCCC WRITE(ICOUT,136)HOLD
4499CC136 FORMAT('***** NON-FATAL DIAGNOSTIC IN CODEH--',
4500CCCCC CALL DPWRST('XXX','BUG ')
4501CCCCC1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
4502      DO137I=1,N
4503      Y(I)=1.0
4504  137 CONTINUE
4505      GOTO9000
4506  139 CONTINUE
4507C
4508C               *******************************************************
4509C               **  STEP 2--                                         **
4510C               **  PERFORM THE CODING--                             **
4511C               *******************************************************
4512C
4513      CALL SORT(X,N,XS)
4514C
4515      AN=N
4516C
4517      DO1410I=1,N
4518      Y(I)=4.0
4519 1410 CONTINUE
4520C
4521      N2=(N+1)/2
4522      IARG1=(N2+1)/2
4523      IARG2=(N2+1)-IARG1
4524      IARG1R=N-IARG1+1
4525      IARG2R=N-IARG2+1
4526      X75=(XS(IARG1R)+XS(IARG2R))/2.0
4527      XCUT=X75
4528      DO1420I=1,N
4529      IF(X(I).LE.XCUT)Y(I)=3.0
4530 1420 CONTINUE
4531C
4532      N50=N/2
4533      N50P1=N50+1
4534      IEVODD=N-2*(N/2)
4535      IF(IEVODD.EQ.0)X50=(XS(N50)+XS(N50P1))/2.0
4536      IF(IEVODD.EQ.1)X50=XS(N50P1)
4537      XCUT=X50
4538      DO1430I=1,N
4539      IF(X(I).LE.XCUT)Y(I)=2.0
4540 1430 CONTINUE
4541C
4542      N2=(N+1)/2
4543      IARG1=(N2+1)/2
4544      IARG2=(N2+1)-IARG1
4545      X25=(XS(IARG1)+XS(IARG2))/2.0
4546      XCUT=X25
4547      DO1440I=1,N
4548      IF(X(I).LE.XCUT)Y(I)=1.0
4549 1440 CONTINUE
4550C
4551C               ******************************
4552C               **  STEP 3--                **
4553C               **  WRITE OUT A FEW LINES   **
4554C               **  OF SUMMARY INFORMATION  **
4555C               **  ABOUT THE CODING.       **
4556C               ******************************
4557C
4558      IF(IFEEDB.EQ.'OFF')GOTO8190
4559      IF(IWRITE.EQ.'OFF')GOTO8190
4560      WRITE(ICOUT,999)
4561      CALL DPWRST('XXX','BUG ')
4562      WRITE(ICOUT,8112)NUMINT
4563 8112 FORMAT('NUMBER OF CODE INTERVALS = ',I8)
4564      CALL DPWRST('XXX','BUG ')
4565      WRITE(ICOUT,999)
4566      CALL DPWRST('XXX','BUG ')
4567      AI=1
4568      WRITE(ICOUT,8114)XS(1),AI
4569 8114 FORMAT('THE MINIMUM (= ',E15.7,' ) HAS CODE VALUE ',F10.0)
4570      CALL DPWRST('XXX','BUG ')
4571      AI=NUMINT
4572      WRITE(ICOUT,8116)XS(N),AI
4573 8116 FORMAT('THE MAXIMUM (= ',E15.7,' ) HAS CODE VALUE ',F10.0)
4574      CALL DPWRST('XXX','BUG ')
4575 8190 CONTINUE
4576C
4577C               *****************
4578C               **  STEP 90--  **
4579C               **  EXIT.      **
4580C               *****************
4581C
4582 9000 CONTINUE
4583C
4584      IF(IBUGA3.EQ.'OFF')GOTO9090
4585      WRITE(ICOUT,999)
4586      CALL DPWRST('XXX','BUG ')
4587      WRITE(ICOUT,9011)
4588 9011 FORMAT('***** AT THE END       OF CODEH--')
4589      CALL DPWRST('XXX','BUG ')
4590      WRITE(ICOUT,9012)IBUGA3,IERROR
4591 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
4592      CALL DPWRST('XXX','BUG ')
4593      WRITE(ICOUT,9013)N,NUMINT
4594 9013 FORMAT('N,NUMINT = ',2I8)
4595      CALL DPWRST('XXX','BUG ')
4596      DO9015I=1,N
4597      WRITE(ICOUT,9016)I,X(I),Y(I)
4598 9016 FORMAT('I,X(I),Y(I) = ',I8,2E15.7)
4599      CALL DPWRST('XXX','BUG ')
4600 9015 CONTINUE
4601 9090 CONTINUE
4602C
4603      RETURN
4604      END
4605      SUBROUTINE CODEN(X,N,NUMINT,IWRITE,Y,XS,MAXOBV,IBUGA3,IERROR)
4606C
4607C     PURPOSE--THIS SUBROUTINE CODES THE ELEMENTS
4608C              OF THE INPUT VECTOR X
4609C              AND PUTS THE CODED VALUES INTO THE OUTPUT VECTOR Y.
4610C              THE CODING IS AS FOLLOWS--
4611C                  THE FIRST NUMINT'TH OF THE DATA IS CODED AS 1.0
4612C                  THE NEXT  NUMINT'TH OF THE DATA IS CODED AS 2.0
4613C                  ETC.
4614C                  THE LAST  NUMINT'TH OF THE DATA IS CODED AS NUMINT
4615C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR
4616C                                OF OBSERVATIONS TO BE CODED.
4617C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
4618C                                IN THE VECTOR X.
4619C     OUTPUT ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR
4620C                                INTO WHICH THE CODED VALUES
4621C                                WILL BE PLACED.
4622C     OUTPUT--THE SINGLE PRECISION VECTOR Y
4623C             WHICH WILL CONTAIN THE CODED VALUES
4624C             CORRESPONDING TO THE OBSERVATIONS IN
4625C             THE VECTOR X.
4626C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
4627C     RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N
4628C                   FOR THIS SUBROUTINE IS 15000.
4629C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT.
4630C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
4631C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
4632C     LANGUAGE--ANSI FORTRAN (1977)
4633C     COMMENT--THE INPUT VECTOR X REMAINS UNALTERED.
4634C     REFERENCES--NONE.
4635C     WRITTEN BY--JAMES J. FILLIBEN
4636C                 STATISTICAL ENGINEERING DIVISION
4637C                 INFORMATION TECHNOLOGY LABORATORY
4638C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
4639C                 GAITHERSBURG, MD 20899
4640C                 PHONE--301-975-2855
4641C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
4642C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
4643C     VERSION NUMBER--82/7
4644C     ORIGINAL VERSION--OCTOBER   1981.
4645C     UPDATED         --MAY       1982.
4646C     UPDATED         --JUNE      1990. TEMPORARY ARRAYS TO GARBAGE COMMON
4647C
4648C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
4649C
4650      CHARACTER*4 IWRITE
4651      CHARACTER*4 IBUGA3
4652      CHARACTER*4 IERROR
4653C
4654      CHARACTER*4 ISUBN1
4655      CHARACTER*4 ISUBN2
4656C
4657C---------------------------------------------------------------------
4658C
4659      DIMENSION X(*)
4660      DIMENSION Y(*)
4661      DIMENSION XS(MAXOBV)
4662C
4663C---------------------------------------------------------------------
4664C
4665      INCLUDE 'DPCOP2.INC'
4666C
4667C-----START POINT-----------------------------------------------------
4668C
4669      ISUBN1='CODE'
4670      ISUBN2='N   '
4671      IERROR='NO'
4672C
4673      IUPPER=MAXOBV
4674      XMED=0.0
4675C
4676      IF(IBUGA3.EQ.'ON')THEN
4677        WRITE(ICOUT,999)
4678  999   FORMAT(1X)
4679        CALL DPWRST('XXX','BUG ')
4680        WRITE(ICOUT,51)
4681   51   FORMAT('***** AT THE BEGINNING OF CODEN--')
4682        CALL DPWRST('XXX','BUG ')
4683        WRITE(ICOUT,53)IBUGA3,N,IUPPER,NUMINT
4684   53   FORMAT('IBUGA3,N,IUPPER,NUMINT = ',A4,2X,3I8)
4685        CALL DPWRST('XXX','BUG ')
4686        DO55I=1,N
4687          WRITE(ICOUT,56)I,X(I)
4688   56     FORMAT('I,X(I) = ',I8,G15.7)
4689          CALL DPWRST('XXX','BUG ')
4690   55   CONTINUE
4691      ENDIF
4692C
4693C               *****************************
4694C               **  COMPUTE CODED VALUES.  **
4695C               *****************************
4696C
4697C               ********************************************
4698C               **  STEP 1--                              **
4699C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
4700C               ********************************************
4701C
4702      IF(N.LT.1 .OR. N.GT.IUPPER)THEN
4703        IERROR='YES'
4704        WRITE(ICOUT,999)
4705        CALL DPWRST('XXX','BUG ')
4706        WRITE(ICOUT,111)
4707  111   FORMAT('***** ERROR IN CODEN--')
4708        CALL DPWRST('XXX','BUG ')
4709        WRITE(ICOUT,113)
4710  113   FORMAT('      THE NUMBER OF OBSERVATIONS IN THE RESPONSE ',
4711     1         'VARIABLE')
4712        CALL DPWRST('XXX','BUG ')
4713        WRITE(ICOUT,115)IUPPER
4714  115   FORMAT('      IS LESS THAN 1 OR GREATER THAN ',I10)
4715        CALL DPWRST('XXX','BUG ')
4716        WRITE(ICOUT,118)N
4717  118   FORMAT('      THE NUMBER OF OBSERVATIONS IS ',I10)
4718        CALL DPWRST('XXX','BUG ')
4719        GOTO9000
4720      ENDIF
4721C
4722      IF(N.EQ.1)THEN
4723        Y(1)=1.0
4724        GOTO9000
4725      ENDIF
4726C
4727      HOLD=X(1)
4728      DO135I=2,N
4729        IF(X(I).NE.HOLD)GOTO139
4730  135 CONTINUE
4731      DO137I=1,N
4732        Y(I)=1.0
4733  137 CONTINUE
4734      GOTO9000
4735  139 CONTINUE
4736C
4737C               *************************************************************
4738C               **  STEP 2--                                               **
4739C               **  PERFORM THE CODING--                                   **
4740C               *************************************************************
4741C
4742      CALL SORT(X,N,XS)
4743C
4744      AN=N
4745      IF(NUMINT.EQ.1)THEN
4746        DO1110I=1,N
4747          Y(I)=NUMINT
4748 1110   CONTINUE
4749      ELSEIF(NUMINT.GE.3)THEN
4750        DO1310I=1,N
4751          Y(I)=NUMINT
4752 1310   CONTINUE
4753        ANUMIN=NUMINT
4754        JMAX=NUMINT-1
4755        DO1320J=1,JMAX
4756          JREV=JMAX-J+1
4757          AJREV=JREV
4758          P=AJREV/ANUMIN
4759          AK=P*AN
4760          K1=INT(AK)
4761          K2=INT(AK+1.0)
4762          IF(K1.LE.1)K1=1
4763          IF(K1.GE.N)K1=N
4764          IF(K2.LE.1)K2=1
4765          IF(K2.GE.N)K2=N
4766          XCUT=(XS(K1)+XS(K2))/2.0
4767          DO1350I=1,N
4768            IF(X(I).LE.XCUT)Y(I)=JREV
4769 1350     CONTINUE
4770 1320   CONTINUE
4771      ELSE
4772        DO1210I=1,N
4773          Y(I)=NUMINT
4774 1210   CONTINUE
4775        N50=N/2
4776        N50P1=N50+1
4777        IEVODD=N-2*(N/2)
4778        IF(IEVODD.EQ.0)XMED=(XS(N50)+XS(N50P1))/2.0
4779        IF(IEVODD.EQ.1)XMED=XS(N50P1)
4780        XCUT=XMED
4781        DO1250I=1,N
4782          IF(X(I).LE.XCUT)Y(I)=1.0
4783 1250   CONTINUE
4784      ENDIF
4785C
4786C               ******************************
4787C               **  STEP 3--                **
4788C               **  WRITE OUT A FEW LINES   **
4789C               **  OF SUMMARY INFORMATION  **
4790C               **  ABOUT THE CODING.       **
4791C               ******************************
4792C
4793      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
4794        WRITE(ICOUT,999)
4795        CALL DPWRST('XXX','BUG ')
4796        WRITE(ICOUT,8112)NUMINT
4797 8112   FORMAT('NUMBER OF CODE INTERVALS = ',I8)
4798        CALL DPWRST('XXX','BUG ')
4799        WRITE(ICOUT,999)
4800        CALL DPWRST('XXX','BUG ')
4801        AI=1
4802        WRITE(ICOUT,8114)XS(1),AI
4803 8114   FORMAT('THE MINIMUM (= ',E15.7,' ) HAS CODE VALUE ',F10.0)
4804        CALL DPWRST('XXX','BUG ')
4805        AI=NUMINT
4806        WRITE(ICOUT,8116)XS(N),AI
4807 8116   FORMAT('THE MAXIMUM (= ',E15.7,' ) HAS CODE VALUE ',F10.0)
4808        CALL DPWRST('XXX','BUG ')
4809      ENDIF
4810C
4811C               *****************
4812C               **  STEP 90--  **
4813C               **  EXIT.      **
4814C               *****************
4815C
4816 9000 CONTINUE
4817C
4818      IF(IBUGA3.EQ.'ON')THEN
4819        WRITE(ICOUT,999)
4820        CALL DPWRST('XXX','BUG ')
4821        WRITE(ICOUT,9011)
4822 9011   FORMAT('***** AT THE END       OF CODEN--')
4823        CALL DPWRST('XXX','BUG ')
4824        WRITE(ICOUT,9013)IERROR,N,NUMINT
4825 9013   FORMAT('IERROR,N,NUMINT = ',A4,2X,2I8)
4826        CALL DPWRST('XXX','BUG ')
4827        DO9015I=1,N
4828          WRITE(ICOUT,9016)I,X(I),Y(I)
4829 9016     FORMAT('I,X(I),Y(I) = ',I8,2E15.7)
4830          CALL DPWRST('XXX','BUG ')
4831 9015   CONTINUE
4832      ENDIF
4833C
4834      RETURN
4835      END
4836      SUBROUTINE CODEST(ISUBRO,IBUGA3,IERROR)
4837C
4838C     PURPOSE--THIS SUBROUTINE READS THE CHARCTER DATA STORED IN
4839C              FILE "DPZCHF.DAT" AND CODES A SELECTED FIELD INTO
4840C              A STRING.  THE LHS DEFINES THE BASE NAME FOR THE
4841C              STRINGS.
4842C     OUTPUT--THE CHARACTER STRINGS.
4843C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
4844C     RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N
4845C                   FOR THIS SUBROUTINE IS MAXOBV.
4846C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT.
4847C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
4848C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
4849C     LANGUAGE--ANSI FORTRAN (1977)
4850C     REFERENCES--NONE.
4851C     WRITTEN BY--ALAN HECKERT
4852C                 STATISTICAL ENGINEERING DIVISION
4853C                 INFORMATION TECHNOLOGY LABORATORY
4854C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
4855C                 GAITHERSBURG, MD 20899-8980
4856C                 PHONE--301-975-2899
4857C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
4858C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
4859C     LANGUAGE--ANSI FORTRAN (1977)
4860C     VERSION NUMBER--2011/10
4861C     ORIGINAL VERSION--OCTOBER   2011.
4862C     UPDATED         --MARCH     2015. CALL LIST TO DPINFU
4863C
4864C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
4865C
4866      CHARACTER*4 IBUGA3
4867      CHARACTER*4 ISUBRO
4868      CHARACTER*4 IERROR
4869C
4870      CHARACTER*4 ISTEPN
4871      CHARACTER*4 ISUBN1
4872      CHARACTER*4 ISUBN2
4873      CHARACTER*4 ICASEL
4874C
4875      CHARACTER*4 NEWNAM
4876      CHARACTER*4 NEWCOL
4877      CHARACTER*4 IH
4878      CHARACTER*4 IH2
4879      CHARACTER*8 ISTRIN
4880      CHARACTER*8 IHLEFT
4881      CHARACTER*4 IHLEF3
4882      CHARACTER*4 IHLEF4
4883      CHARACTER*4 IHRIGH
4884      CHARACTER*4 IHRIG2
4885C
4886      CHARACTER*4 ISTRZ2(24)
4887C
4888      CHARACTER*4 ISUBN0
4889C
4890C---------------------------------------------------------------------
4891C
4892      INCLUDE 'DPCOPA.INC'
4893      INCLUDE 'DPCODA.INC'
4894      INCLUDE 'DPCOHK.INC'
4895      INCLUDE 'DPCOHO.INC'
4896      INCLUDE 'DPCOF2.INC'
4897      INCLUDE 'DPCOZC.INC'
4898C
4899CCCCC CHARACTER*80 IFILE
4900      CHARACTER (LEN=MAXFNC) :: IFILE
4901      CHARACTER*12 ISTAT
4902      CHARACTER*12 IFORM
4903      CHARACTER*12 IACCES
4904      CHARACTER*12 IPROT
4905      CHARACTER*12 ICURST
4906      CHARACTER*4 IENDFI
4907      CHARACTER*4 IREWIN
4908      CHARACTER*4 IERRFI
4909C
4910      CHARACTER*24 IATEMP
4911      CHARACTER*12 IFRMT
4912      CHARACTER*24 IXTEMP(9999)
4913      EQUIVALENCE (CGARBG(1),IXTEMP(1))
4914C
4915C---------------------------------------------------------------------
4916C
4917      INCLUDE 'DPCOP2.INC'
4918C
4919C-----START POINT-----------------------------------------------------
4920C
4921      ISUBN1='CODE'
4922      ISUBN2='ST  '
4923      IERROR='NO'
4924C
4925      NBASE=0
4926C
4927      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEST')THEN
4928        WRITE(ICOUT,999)
4929  999   FORMAT(1X)
4930        CALL DPWRST('XXX','BUG ')
4931        WRITE(ICOUT,51)
4932   51   FORMAT('***** AT THE BEGINNING OF CODEST--')
4933        CALL DPWRST('XXX','BUG ')
4934        WRITE(ICOUT,52)IBUGA3,ISUBRO
4935   52   FORMAT('IBUGA3,ISUBRO = ',A4,2X,A4)
4936        CALL DPWRST('XXX','BUG ')
4937      ENDIF
4938C
4939C               ********************************************
4940C               **  STEP 1--                              **
4941C               **  OPEN THE DPZCHF.DAT FILE.             **
4942C               ********************************************
4943C
4944      ISTEPN='1'
4945      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DEST')
4946     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4947C
4948      IHRIGH=IHARG(6)
4949      IHRIG2=IHARG2(6)
4950C
4951      IOUNIT=IZCHNU
4952      IFILE=IZCHNA
4953      ISTAT=IZCHST
4954      IFORM=IZCHFO
4955      IACCES=IZCHAC
4956      IPROT=IZCHPR
4957      ICURST=IZCHCS
4958C
4959      ISUBN0='READ'
4960      IERRFI='NO'
4961      CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,
4962     1            ICURST,
4963     1            IREWIN,ISUBN0,IERRFI,IBUGA3,ISUBRO,IERROR)
4964      IF(IERRFI.EQ.'YES')THEN
4965        IERROR='YES'
4966        WRITE(ICOUT,999)
4967        CALL DPWRST('XXX','BUG ')
4968        WRITE(ICOUT,111)
4969  111   FORMAT('***** ERROR IN CHARACTER CODE STRING--')
4970        CALL DPWRST('XXX','BUG ')
4971        WRITE(ICOUT,118)
4972  118   FORMAT('      UNABLE TO OPEN THE FILE CHARACTER DATA FILE:')
4973        CALL DPWRST('XXX','BUG ')
4974        WRITE(ICOUT,119)IFILE
4975  119   FORMAT('      ',A80)
4976        CALL DPWRST('XXX','BUG ')
4977        GOTO8000
4978      ENDIF
4979C
4980      READ(IOUNIT,'(I8)',END=171,ERR=171)NUMVAR
4981C
4982      IVAR=-1
4983      DO130I=1,NUMVAR
4984        READ(IOUNIT,'(A4,A4)',END=181,ERR=181)IH,IH2
4985        IF(IHRIGH.EQ.IH .AND. IHRIG2.EQ.IH2)THEN
4986          IVAR=I
4987        ENDIF
4988  130 CONTINUE
4989      IF(IVAR.GT.0)GOTO199
4990C
4991      WRITE(ICOUT,999)
4992      CALL DPWRST('XXX','BUG ')
4993      WRITE(ICOUT,111)
4994      CALL DPWRST('XXX','BUG ')
4995      WRITE(ICOUT,131)IHRIGH,IHRIG2
4996  131 FORMAT('***** VARIABLE ',A4,A4,' NOT FOUND IN THE CHARACTER ',
4997     1       'DATA FILE:')
4998      CALL DPWRST('XXX','BUG ')
4999      WRITE(ICOUT,119)IFILE
5000      CALL DPWRST('XXX','BUG ')
5001      IERROR='YES'
5002      GOTO8000
5003C
5004  171 CONTINUE
5005      WRITE(ICOUT,999)
5006      CALL DPWRST('XXX','BUG ')
5007      WRITE(ICOUT,111)
5008      CALL DPWRST('XXX','BUG ')
5009      WRITE(ICOUT,173)
5010  173 FORMAT('      ERROR READING THE NUMBER OF CHARACTER VARIABLES ',
5011     1       'IN THE CHARACTER DATA FILE:')
5012      CALL DPWRST('XXX','BUG ')
5013      WRITE(ICOUT,119)IFILE
5014      CALL DPWRST('XXX','BUG ')
5015      IERROR='YES'
5016      GOTO8000
5017C
5018  181 CONTINUE
5019      WRITE(ICOUT,999)
5020      CALL DPWRST('XXX','BUG ')
5021      WRITE(ICOUT,111)
5022      CALL DPWRST('XXX','BUG ')
5023      WRITE(ICOUT,183)
5024  183 FORMAT('      ERROR READING THE VARIABLE NAMES ',
5025     1       'IN THE CHARACTER DATA FILE:')
5026      CALL DPWRST('XXX','BUG ')
5027      WRITE(ICOUT,119)IFILE
5028      CALL DPWRST('XXX','BUG ')
5029      IERROR='YES'
5030      GOTO8000
5031C
5032  199 CONTINUE
5033C
5034C               **********************************
5035C               **  STEP 2--                    **
5036C               **  DETERMINE NUMBER OF STRINGS **
5037C               **  TO CREATE                   **
5038C               **********************************
5039C
5040      ISTEPN='2'
5041      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DEST')
5042     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5043C
5044      NSTR=NUMVAR
5045      IF(NSTR.GT.9999)NSTR=9999
5046C
5047C               *************************************************
5048C               **  STEP 3--                                   **
5049C               **  EXTRACT THE BASE NAME ON THE LHS OF THE    **
5050C               **  EQUAL SIGN AND THEN LOOP THROUGH THE       **
5051C               **  NUMBER OF STRINGS TO CREATE.               **
5052C               *************************************************
5053C
5054      ISTEPN='3'
5055      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DEST')
5056     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5057C
5058      IHLEFT(1:4)=IHARG(1)
5059      IHLEFT(5:8)=IHARG2(1)
5060      NBASE=1
5061      DO310I=8,1,-1
5062        IF(IHLEFT(I:I).NE.' ')THEN
5063          NBASE=I
5064          GOTO319
5065        ENDIF
5066  310 CONTINUE
5067  319 CONTINUE
5068C
5069      IF(NSTR.LE.9)THEN
5070        IF(NBASE.GT.7)NBASE=7
5071      ELSEIF(NSTR.LE.99)THEN
5072        IF(NBASE.GT.6)NBASE=6
5073      ELSEIF(NSTR.LE.999)THEN
5074        IF(NBASE.GT.5)NBASE=5
5075      ELSE
5076        IF(NBASE.GT.4)NBASE=4
5077      ENDIF
5078C
5079      ISTEPN='4'
5080      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DEST')
5081     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5082C
5083      IF(IVAR.EQ.1)THEN
5084        IFRMT='(A24)'
5085      ELSE
5086        IFRMT='(   X,A24)'
5087        WRITE(IFRMT(2:4),'(I3)')25*(IVAR-1)
5088      ENDIF
5089C
5090      N=0
5091      IROW=0
5092C
5093      DO410I=1,MAXOBV
5094C
5095        IATEMP=' '
5096        READ(IOUNIT,IFRMT,END=499,ERR=491)IATEMP
5097        IROW=I
5098C
5099C       CHECK TO SEE IF TEXT ON CURRENT ROW IS NEW OR
5100C       HAS BEEN PREVIOUSLY ENTERED.
5101C
5102        INEW=1
5103        IF(N.GE.1)THEN
5104          DO420J=1,N
5105            IF(IATEMP(1:24).EQ.IXTEMP(J)(1:24))THEN
5106              INEW=0
5107              GOTO429
5108            ENDIF
5109  420     CONTINUE
5110  429     CONTINUE
5111        ENDIF
5112C
5113C       ADD NEW STRING IF REQUIRED
5114C
5115        IF(INEW.EQ.0)GOTO410
5116        N=N+1
5117        IF(N.GT.9999)THEN
5118          WRITE(ICOUT,999)
5119          CALL DPWRST('XXX','BUG ')
5120          WRITE(ICOUT,111)
5121          CALL DPWRST('XXX','BUG ')
5122          WRITE(ICOUT,431)
5123  431     FORMAT('      ATTEMPT TO CREATE MORE THAN 9,999 STRINGS.')
5124          CALL DPWRST('XXX','BUG ')
5125          WRITE(ICOUT,433)
5126  433     FORMAT('      NO MORE STRINGS WILL BE GENERATED.')
5127          CALL DPWRST('XXX','BUG ')
5128        ELSE
5129          IXTEMP(N)=' '
5130          IXTEMP(N)=IATEMP(1:24)
5131          ISTRIN=' '
5132          ISTRIN(1:NBASE)=IHLEFT(1:NBASE)
5133          IF(N.LE.9)THEN
5134            WRITE(ISTRIN(NBASE+1:NBASE+1),'(I1)')N
5135          ELSEIF(N.LE.99)THEN
5136            WRITE(ISTRIN(NBASE+1:NBASE+2),'(I2)')N
5137          ELSEIF(N.LE.999)THEN
5138            WRITE(ISTRIN(NBASE+1:NBASE+3),'(I3)')N
5139          ELSE
5140            WRITE(ISTRIN(NBASE+1:NBASE+4),'(I4)')N
5141          ENDIF
5142C
5143          NEWNAM='NO'
5144          NEWCOL='NO'
5145          ICASEL='UNKN'
5146          NIOLD1=0
5147          ICOLL=0
5148C
5149          DO510II=1,NUMNAM
5150            I2=II
5151            IF(ISTRIN(1:4).EQ.IHNAME(I2).AND.
5152     1         ISTRIN(5:8).EQ.IHNAM2(I2))THEN
5153              IF(IUSE(I2).EQ.'F')THEN
5154                ICASEL='STRI'
5155                ILISTL=I2
5156                GOTO519
5157              ELSE
5158                WRITE(ICOUT,999)
5159                CALL DPWRST('XXX','BUG ')
5160                WRITE(ICOUT,111)
5161                CALL DPWRST('XXX','BUG ')
5162                WRITE(ICOUT,513)ISTRIN
5163  513           FORMAT('      THE NAME ',A8,' ALREADY EXISTS, BUT NOT ',
5164     1                 'AS A STRING.')
5165                CALL DPWRST('XXX','BUG ')
5166                WRITE(ICOUT,515)
5167  515           FORMAT('      THIS STRING WILL NOT BE CREATED.')
5168                CALL DPWRST('XXX','BUG ')
5169                GOTO9000
5170              ENDIF
5171            ENDIF
5172  510     CONTINUE
5173  519     CONTINUE
5174C
5175          NEWNAM='YES'
5176          ICASEL='STRI'
5177C
5178          ILISTL=NUMNAM+1
5179          IF(ILISTL.GT.MAXNAM)THEN
5180            WRITE(ICOUT,999)
5181            CALL DPWRST('XXX','BUG ')
5182            WRITE(ICOUT,111)
5183            CALL DPWRST('XXX','BUG ')
5184            WRITE(ICOUT,522)
5185  522       FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND ',
5186     1             'FUNCTION')
5187            CALL DPWRST('XXX','BUG ')
5188            WRITE(ICOUT,524)MAXNAM
5189  524       FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
5190            CALL DPWRST('XXX','BUG ')
5191            IERROR='YES'
5192            GOTO9000
5193          ENDIF
5194C
5195C               *****************************************************
5196C               **  STEP 6--                                       **
5197C               **  ADD THE CURRENT STRING                         **
5198C               *****************************************************
5199C
5200          ISTEPN='6'
5201          IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STGL')
5202     1       CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5203C
5204          NCHAR=1
5205          DO605JJ=24,1,-1
5206            IF(IXTEMP(N)(JJ:JJ).NE.' ')THEN
5207              NCHAR=JJ
5208              GOTO609
5209            ENDIF
5210  605     CONTINUE
5211  609     CONTINUE
5212          IHLEF3=ISTRIN(1:4)
5213          IHLEF4=ISTRIN(5:8)
5214          DO611J=1,NCHAR
5215            ISTRZ2(J)=' '
5216            ISTRZ2(J)(1:1)=IXTEMP(N)(J:J)
5217  611     CONTINUE
5218C
5219          CALL DPINFU(ISTRZ2,NCHAR,IHNAME,IHNAM2,IUSE,IN,
5220     1                IVSTAR,IVSTOP,
5221     1                NUMNAM,IANS,IWIDTH,IHLEF3,IHLEF4,ILISTL,
5222     1                NEWNAM,MAXNAM,
5223     1                IFUNC,NUMCHF,MAXCHF,IBUGA3,IERROR)
5224          IF(IERROR.EQ.'YES')GOTO9000
5225C
5226        ENDIF
5227C
5228  410 CONTINUE
5229      GOTO499
5230C
5231  491 CONTINUE
5232      WRITE(ICOUT,999)
5233      CALL DPWRST('XXX','BUG ')
5234      WRITE(ICOUT,111)
5235      CALL DPWRST('XXX','BUG ')
5236      WRITE(ICOUT,493)I
5237  493 FORMAT('      ERROR READING ROW ',I8,' OF THE CHARACTER ',
5238     1       'VARIABLES IN THE CHARACTER DATA FILE:')
5239      CALL DPWRST('XXX','BUG ')
5240      WRITE(ICOUT,119)IFILE
5241      CALL DPWRST('XXX','BUG ')
5242      IERROR='YES'
5243      GOTO8000
5244C
5245  499 CONTINUE
5246      GOTO8000
5247C
5248C               ***************************************
5249C               **  STEP 88--                        **
5250C               **  CLOSE THE DPZCHF.DAT FILE.       **
5251C               ***************************************
5252C
5253 8000 CONTINUE
5254C
5255      IENDFI='OFF'
5256      IREWIN='ON'
5257      CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
5258     1            IENDFI,IREWIN,ISUBN0,IERRFI,IBUGA3,ISUBRO,IERROR)
5259      IZCHCS='CLOSED'
5260      IF(IFEEDB.EQ.'ON')THEN
5261        WRITE(ICOUT,999)
5262        CALL DPWRST('XXX','BUG ')
5263        WRITE(ICOUT,8001)N,ISTRIN(1:NBASE)
5264 8001   FORMAT('      ',I5,' STRINGS CREATED WITH BASE NAME = ',A8)
5265        CALL DPWRST('XXX','BUG ')
5266      ENDIF
5267      GOTO9000
5268C
5269C               *****************
5270C               **  STEP 90--  **
5271C               **  EXIT.      **
5272C               *****************
5273C
5274 9000 CONTINUE
5275C
5276      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEST')THEN
5277        WRITE(ICOUT,999)
5278        CALL DPWRST('XXX','BUG ')
5279        WRITE(ICOUT,9011)
5280 9011   FORMAT('***** AT THE END OF CODEST--')
5281        CALL DPWRST('XXX','BUG ')
5282        WRITE(ICOUT,9012)IBUGA3,IERROR
5283 9012   FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
5284        CALL DPWRST('XXX','BUG ')
5285        WRITE(ICOUT,9013)N,IROW
5286 9013   FORMAT('N,IROW = ',I8)
5287        CALL DPWRST('XXX','BUG ')
5288        DO9015I=1,N
5289          WRITE(ICOUT,9016)I,IXTEMP(I)
5290 9016     FORMAT('I,IXTEMP(I) = ',I8,A24)
5291          CALL DPWRST('XXX','BUG ')
5292 9015   CONTINUE
5293      ENDIF
5294C
5295      RETURN
5296      END
5297      SUBROUTINE CODEX(X,N,IWRITE,Y,IBUGA3,ISUBRO,IERROR)
5298C
5299C     PURPOSE--GIVEN DATA OF THE FORM
5300C
5301C
5302C              1  1  1  0  0  0  1  1
5303C
5304C              WE WANT TO CREATE A CODED VARIABLE
5305C
5306C              1  1  1  0  0  0  2  2
5307C
5308C              THAT IS, FOR EACH NON-ZERO CHUNK, WE WANT TO
5309C              CREATE A COUNTER FOR EACH NON-ZERO BLOCK.
5310C
5311C              THIS IS USED IN THE CONTEXT OF A TAG VARIABLE
5312C              WHERE THE TAG IS SET TO 1 WHEN SOME CONDITION IS
5313C              SATISFIED.  HOWEVER, WE WANT TO UNIQUELY IDENTIFY
5314C              EACH CONTIGUOUS CHUNK OF DATA THAT SATISFIES THE
5315C              CONDITION.
5316C
5317C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR
5318C                                OF OBSERVATIONS TO BE CODED.
5319C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
5320C                                IN THE VECTOR X.
5321C     OUTPUT ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR INTO WHICH
5322C                                THE CODED VALUES WILL BE PLACED.
5323C     OUTPUT--THE SINGLE PRECISION VECTOR Y WHICH WILL CONTAIN THE CODED
5324C             VALUES CORRESPONDING TO THE OBSERVATIONS IN THE VECTOR X.
5325C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
5326C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
5327C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
5328C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
5329C     LANGUAGE--ANSI FORTRAN (1977)
5330C     COMMENT--THE INPUT VECTOR X REMAINS UNALTERED.
5331C     REFERENCES--NONE.
5332C     WRITTEN BY--ALAN HECKERT
5333C                 STATISTICAL ENGINEERING DIVISION
5334C                 INFORMATION TECHNOLOGY LABORATORY
5335C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
5336C                 GAITHERSBURG, MD 20899
5337C                 PHONE--301-975-2899
5338C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
5339C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
5340C     LANGUAGE--ANSI FORTRAN (1977)
5341C     VERSION NUMBER--2017/07
5342C     ORIGINAL VERSION--JULY      2017.
5343C
5344C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
5345C
5346      CHARACTER*4 IWRITE
5347      CHARACTER*4 IBUGA3
5348      CHARACTER*4 ISUBRO
5349      CHARACTER*4 IERROR
5350C
5351      CHARACTER*4 ISUBN1
5352      CHARACTER*4 ISUBN2
5353C
5354C---------------------------------------------------------------------
5355C
5356      DIMENSION X(*)
5357      DIMENSION Y(*)
5358C
5359C---------------------------------------------------------------------
5360C
5361      INCLUDE 'DPCOP2.INC'
5362C
5363C-----START POINT-----------------------------------------------------
5364C
5365      ISUBN1='CODE'
5366      ISUBN2='X   '
5367      IERROR='NO'
5368C
5369      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ODEX')THEN
5370        WRITE(ICOUT,999)
5371  999   FORMAT(1X)
5372        CALL DPWRST('XXX','BUG ')
5373        WRITE(ICOUT,51)
5374   51   FORMAT('***** AT THE BEGINNING OF CODE--')
5375        CALL DPWRST('XXX','BUG ')
5376        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
5377   52   FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8)
5378        CALL DPWRST('XXX','BUG ')
5379        DO55I=1,N
5380          WRITE(ICOUT,56)I,X(I)
5381   56     FORMAT('I,X(I) = ',I8,G15.7)
5382          CALL DPWRST('XXX','BUG ')
5383   55   CONTINUE
5384      ENDIF
5385C
5386C               *****************************
5387C               **  COMPUTE CODED VALUES.  **
5388C               *****************************
5389C
5390C               ********************************************
5391C               **  STEP 1--                              **
5392C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
5393C               ********************************************
5394C
5395      IF(N.LT.1)THEN
5396        WRITE(ICOUT,999)
5397        CALL DPWRST('XXX','BUG ')
5398        WRITE(ICOUT,111)
5399  111   FORMAT('***** ERROR IN CODEX--')
5400        CALL DPWRST('XXX','BUG ')
5401        WRITE(ICOUT,113)N
5402  113   FORMAT('      THE NUMBER OF OBSERVATIONS, ',I8,' IS LESS ',
5403     1         'THAN ONE.')
5404        CALL DPWRST('XXX','BUG ')
5405        IERROR='YES'
5406        GOTO9000
5407      ENDIF
5408C
5409C               *****************************************************
5410C               **  STEP 2--                                       **
5411C               **  PERFORM THE CODING--                           **
5412C               *****************************************************
5413C
5414      ICNT=0
5415      IFLAG=0
5416      DO600I=1,N
5417        IF(X(I).EQ.0.0)THEN
5418          Y(I)=0.0
5419          IFLAG=0
5420        ELSE
5421          IF(IFLAG.EQ.0)THEN
5422            ICNT=ICNT+1
5423            Y(I)=REAL(ICNT)
5424            IFLAG=1
5425          ELSEIF(IFLAG.EQ.1)THEN
5426            Y(I)=REAL(ICNT)
5427          ENDIF
5428        ENDIF
5429  600 CONTINUE
5430C
5431C               ******************************
5432C               **  STEP 3--                **
5433C               **  WRITE OUT A FEW LINES   **
5434C               **  OF SUMMARY INFORMATION  **
5435C               **  ABOUT THE CODING.       **
5436C               ******************************
5437C
5438      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
5439        WRITE(ICOUT,999)
5440        CALL DPWRST('XXX','BUG ')
5441        WRITE(ICOUT,812)X(1),Y(1)
5442  812   FORMAT('THE FIRST OUTPUT VALUE (= ',G15.7,' ) HAS CODE ',
5443     1         'VALUE ',F10.0)
5444        CALL DPWRST('XXX','BUG ')
5445        WRITE(ICOUT,814)X(N),Y(N)
5446  814   FORMAT('THE LAST OUTPUT VALUE (= ',G15.7,' ) HAS CODE ',
5447     1         'VALUE ',F10.0)
5448        CALL DPWRST('XXX','BUG ')
5449      ENDIF
5450C
5451C               *****************
5452C               **  STEP 90--  **
5453C               **  EXIT.      **
5454C               *****************
5455C
5456 9000 CONTINUE
5457C
5458      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ODEX')THEN
5459        WRITE(ICOUT,999)
5460        CALL DPWRST('XXX','BUG ')
5461        WRITE(ICOUT,9011)
5462 9011   FORMAT('***** AT THE END       OF CODEX--')
5463        CALL DPWRST('XXX','BUG ')
5464        WRITE(ICOUT,9012)IERROR
5465 9012   FORMAT('IERROR = ',A4)
5466        CALL DPWRST('XXX','BUG ')
5467        DO9015I=1,N
5468          WRITE(ICOUT,9016)I,X(I),Y(I)
5469 9016     FORMAT('I,X(I),Y(I) = ',I8,2G15.7)
5470          CALL DPWRST('XXX','BUG ')
5471 9015   CONTINUE
5472      ENDIF
5473C
5474      RETURN
5475      END
5476      SUBROUTINE CODEZ(X,N,IWRITE,Y,IBUGA3,ISUBRO,IERROR)
5477C
5478C     PURPOSE--THIS SUBROUTINE IS SIMILAR TO THE CODE ROUTINE.
5479C              HOWEVER, IT DIFFERS IN ONE KEY RESPECT.  THE CODE
5480C              ROUTINE CODES BASED ON THE DISTINCT VALUES REGARDLESS
5481C              OF THE ORDER OF THE DATA.  THIS ROUTINE CREATES THE
5482C              CODE BASED ON WHEN THE INPUT VECTOR CHANGES VALUE.
5483C              FOR EXAMPLE, IF X HAS
5484C
5485C                  1 1 1 2 2 2 3 3 3 1 1 2 2 2 2 3 3 3
5486C
5487C              THEN THE CODED VECTOR WILL BE
5488C
5489C                  1 1 1 2 2 2 3 3 3 4 4 5 5 5 5 6 6
5490C
5491C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR
5492C                                OF OBSERVATIONS TO BE CODED.
5493C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
5494C                                IN THE VECTOR X.
5495C     OUTPUT ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR INTO WHICH
5496C                                THE CODED VALUES WILL BE PLACED.
5497C     OUTPUT--THE SINGLE PRECISION VECTOR Y WHICH WILL CONTAIN THE CODED
5498C             VALUES CORRESPONDING TO THE OBSERVATIONS IN THE VECTOR X.
5499C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
5500C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
5501C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
5502C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
5503C     LANGUAGE--ANSI FORTRAN (1977)
5504C     COMMENT--THE INPUT VECTOR X REMAINS UNALTERED.
5505C     REFERENCES--NONE.
5506C     WRITTEN BY--ALAN HECKERT
5507C                 STATISTICAL ENGINEERING DIVISION
5508C                 INFORMATION TECHNOLOGY LABORATORY
5509C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
5510C                 GAITHERSBURG, MD 20899
5511C                 PHONE--301-975-2899
5512C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
5513C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
5514C     LANGUAGE--ANSI FORTRAN (1977)
5515C     VERSION NUMBER--2016/6
5516C     ORIGINAL VERSION--JUNE      2016.
5517C
5518C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
5519C
5520      CHARACTER*4 IWRITE
5521      CHARACTER*4 IBUGA3
5522      CHARACTER*4 ISUBRO
5523      CHARACTER*4 IERROR
5524C
5525      CHARACTER*4 ISUBN1
5526      CHARACTER*4 ISUBN2
5527C
5528C---------------------------------------------------------------------
5529C
5530      DIMENSION X(*)
5531      DIMENSION Y(*)
5532C
5533C---------------------------------------------------------------------
5534C
5535      INCLUDE 'DPCOP2.INC'
5536C
5537C-----START POINT-----------------------------------------------------
5538C
5539      ISUBN1='CODE'
5540      ISUBN2='Z   '
5541C
5542      IERROR='NO'
5543C
5544      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ODEZ')THEN
5545        WRITE(ICOUT,999)
5546  999   FORMAT(1X)
5547        CALL DPWRST('XXX','BUG ')
5548        WRITE(ICOUT,51)
5549   51   FORMAT('***** AT THE BEGINNING OF CODE--')
5550        CALL DPWRST('XXX','BUG ')
5551        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
5552   52   FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8)
5553        CALL DPWRST('XXX','BUG ')
5554        DO55I=1,N
5555          WRITE(ICOUT,56)I,X(I)
5556   56     FORMAT('I,X(I) = ',I8,G15.7)
5557          CALL DPWRST('XXX','BUG ')
5558   55   CONTINUE
5559      ENDIF
5560C
5561C               *****************************
5562C               **  COMPUTE CODED VALUES.  **
5563C               *****************************
5564C
5565C               ********************************************
5566C               **  STEP 1--                              **
5567C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
5568C               ********************************************
5569C
5570      IF(N.LT.1)THEN
5571        WRITE(ICOUT,999)
5572        CALL DPWRST('XXX','BUG ')
5573        WRITE(ICOUT,111)
5574  111   FORMAT('***** ERROR IN CODEZ--')
5575        CALL DPWRST('XXX','BUG ')
5576        WRITE(ICOUT,113)N
5577  113   FORMAT('      THE NUMBER OF OBSERVATIONS, ',I8,' IS LESS ',
5578     1         'THAN ONE.')
5579        CALL DPWRST('XXX','BUG ')
5580        IERROR='YES'
5581        GOTO9000
5582      ENDIF
5583C
5584      IF(N.EQ.1)THEN
5585        Y(1)=1.0
5586        GOTO9000
5587      ENDIF
5588C
5589C
5590C               *****************************************************
5591C               **  STEP 2--                                       **
5592C               **  PERFORM THE CODING--                           **
5593C               *****************************************************
5594C
5595      HOLD=X(1)
5596      ACODE=1.0
5597      Y(1)=ACODE
5598      DO600I=2,N
5599        IF(X(I).EQ.HOLD)THEN
5600          Y(I)=ACODE
5601        ELSE
5602          HOLD=X(I)
5603          ACODE=ACODE+1.0
5604          Y(I)=ACODE
5605        ENDIF
5606  600 CONTINUE
5607C
5608C               ******************************
5609C               **  STEP 3--                **
5610C               **  WRITE OUT A FEW LINES   **
5611C               **  OF SUMMARY INFORMATION  **
5612C               **  ABOUT THE CODING.       **
5613C               ******************************
5614C
5615      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
5616        WRITE(ICOUT,999)
5617        CALL DPWRST('XXX','BUG ')
5618        WRITE(ICOUT,812)X(1),Y(1)
5619  812   FORMAT('THE FIRST OUTPUT VALUE (= ',G15.7,' ) HAS CODE ',
5620     1         'VALUE ',F10.0)
5621        CALL DPWRST('XXX','BUG ')
5622        WRITE(ICOUT,814)X(N),Y(N)
5623  814   FORMAT('THE LAST OUTPUT VALUE (= ',G15.7,' ) HAS CODE ',
5624     1         'VALUE ',F10.0)
5625        CALL DPWRST('XXX','BUG ')
5626      ENDIF
5627C
5628C               *****************
5629C               **  STEP 90--  **
5630C               **  EXIT.      **
5631C               *****************
5632C
5633 9000 CONTINUE
5634C
5635      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ODEZ')THEN
5636        WRITE(ICOUT,999)
5637        CALL DPWRST('XXX','BUG ')
5638        WRITE(ICOUT,9011)
5639 9011   FORMAT('***** AT THE END       OF CODEZ--')
5640        CALL DPWRST('XXX','BUG ')
5641        WRITE(ICOUT,9012)IERROR
5642 9012   FORMAT('IERROR = ',A4)
5643        CALL DPWRST('XXX','BUG ')
5644        DO9015I=1,N
5645          WRITE(ICOUT,9016)I,X(I),Y(I)
5646 9016     FORMAT('I,X(I),Y(I) = ',I8,2G15.7)
5647          CALL DPWRST('XXX','BUG ')
5648 9015   CONTINUE
5649      ENDIF
5650C
5651      RETURN
5652      END
5653      SUBROUTINE COENAM(IV1,IV2,IWORD1,IWORD2,IBUGCN,IERROR)
5654C
5655C     PURPOSE--THIS SUBROUTINE CREATES A HOLLERITH COEFFICIENT NAME
5656C              FROM THE 2 INPUT INTEGER VALUES IV1 AND IV2.
5657C              IT ALSO AUTOMATICALLY PUTS THE LETTER A AS
5658C              THE FIRST LETTER OF THE PARAMETER NAME.
5659C              EXAMPLES--
5660C                 INPUT--IV1 = 1   AND IV2 = 7    OUTPUT--A17
5661C                 INPUT--IV1 = 2   AND IV2 = 3    OUTPUT--A23
5662C                 INPUT--IV1 = 5   AND IV2 = 2    OUTPUT--A52
5663C     NOTE--IF THE OUTPUT STRING HAPPENS TO CONSIST OF
5664C           1 TO 4 CHARACTERS, THEN CHARACTERS 1 TO 4
5665C           WILL BE PLACED INTO THE FIRST HOLLERITH
5666C           VARIABLE IWORD1.
5667C           IF THE OUTPUT STRING HAPPENS TO CONSIST OF
5668C           MORE THAN 4 CHARACTERS, THEN CHARACTERS 5 TO 8
5669C           WILL BE PLACED INTO THE SECOND HOLLERITH
5670C           VARIABLE IWORD2.
5671C           IF THE OUTPUT STRING HAPPENS TO CONSIST OF
5672C           MORE THAN 8 CHARACTERS, THEN CHARACTERS 9 ON UP
5673C           WILL BE IGNORED.
5674C     NOTE--IV1 AND IV2 ARE INTEGER VARIABLES.
5675C     NOTE--IWORD1 IS A HOLLERITH VARIABLE.
5676C         --IWORD2 IS A HOLLERITH VARIABLE.
5677C     WRITTEN BY--JAMES J. FILLIBEN
5678C                 STATISTICAL ENGINEERING DIVISION
5679C                 INFORMATION TECHNOLOGY LABORATORY
5680C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
5681C                 GAITHERSBURG, MD 20899
5682C                 PHONE--301-975-2855
5683C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
5684C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
5685C     LANGUAGE--ANSI FORTRAN (1977)
5686C     VERSION NUMBER--82/7
5687C     ORIGINAL VERSION--DECEMBER  1978.
5688C     UPDATED         --MARCH     1981.
5689C     UPDATED         --NOVEMBER  1981.
5690C     UPDATED         --MARCH     1982.
5691C     UPDATED         --MAY       1982.
5692C
5693C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
5694C
5695      CHARACTER*4 IWORD1
5696      CHARACTER*4 IWORD2
5697      CHARACTER*4 IBUGCN
5698      CHARACTER*4 IERROR
5699C
5700      CHARACTER*4 ISTRIT
5701      CHARACTER*4 ISTRIN
5702      CHARACTER*4 IWORD3
5703C
5704      CHARACTER*4 ISUBN1
5705      CHARACTER*4 ISUBN2
5706      CHARACTER*4 ISTEPN
5707C
5708C---------------------------------------------------------------------
5709C
5710      DIMENSION ISTRIT(15)
5711      DIMENSION ISTRIN(30)
5712C
5713C---------------------------------------------------------------------
5714C
5715      INCLUDE 'DPCOP2.INC'
5716C
5717C-----START POINT-----------------------------------------------------
5718C
5719      IERROR='NO'
5720C
5721      ISUBN1='COEN'
5722      ISUBN2='AM  '
5723C
5724      IF(IBUGCN.EQ.'OFF')GOTO90
5725      WRITE(ICOUT,999)
5726  999 FORMAT(1X)
5727      CALL DPWRST('XXX','BUG ')
5728      WRITE(ICOUT,51)
5729   51 FORMAT('***** AT THE BEGINNING OF COENAM--')
5730      CALL DPWRST('XXX','BUG ')
5731      WRITE(ICOUT,52)IV1,IV2
5732   52 FORMAT('IV1,IV2 = ',2I8)
5733      CALL DPWRST('XXX','BUG ')
5734      WRITE(ICOUT,53)IBUGCN
5735   53 FORMAT('IBUGCN = ',A4)
5736      CALL DPWRST('XXX','BUG ')
5737   90 CONTINUE
5738C
5739C               **********************************
5740C               **  STEP 1--                    **
5741C               **  DEFINE THE FIRST CHARACTER  **
5742C               **  OF THE PARAMETER NAME       **
5743C               **********************************
5744C
5745      ISTEPN='1'
5746      IF(IBUGCN.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5747C
5748      K=0
5749      K=K+1
5750      ISTRIN(K)='A'
5751C
5752C               *******************************************
5753C               **  STEP 2--                             **
5754C               **  FORM THE STRING CONTAINING           **
5755C               **  THE 1 CHARACTER PER WORD             **
5756C               **  REPRESENTATION OF THE VALUE IN IV1.  **
5757C               *******************************************
5758C
5759      J=0
5760      ISTEPN='2'
5761      IF(IBUGCN.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5762C
5763      IREM=IV1
5764      DO100IPASS=1,10
5765      J=J+1
5766      IDIGIT=IREM-10*(IREM/10)
5767      IF(IDIGIT.EQ.0)ISTRIT(J)='0'
5768      IF(IDIGIT.EQ.1)ISTRIT(J)='1'
5769      IF(IDIGIT.EQ.2)ISTRIT(J)='2'
5770      IF(IDIGIT.EQ.3)ISTRIT(J)='3'
5771      IF(IDIGIT.EQ.4)ISTRIT(J)='4'
5772      IF(IDIGIT.EQ.5)ISTRIT(J)='5'
5773      IF(IDIGIT.EQ.6)ISTRIT(J)='6'
5774      IF(IDIGIT.EQ.7)ISTRIT(J)='7'
5775      IF(IDIGIT.EQ.8)ISTRIT(J)='8'
5776      IF(IDIGIT.EQ.9)ISTRIT(J)='9'
5777      IREM=IREM-IDIGIT
5778      IREM=IREM/10
5779      IF(IREM.LE.0)GOTO140
5780  100 CONTINUE
5781  140 CONTINUE
5782      N1=J
5783C
5784      DO150I=1,N1
5785      K=K+1
5786      IREV=N1-I+1
5787      ISTRIN(K)=ISTRIT(IREV)
5788  150 CONTINUE
5789C
5790C               *******************************************
5791C               **  STEP 3--                             **
5792C               **  FORM THE STRING CONTAINING           **
5793C               **  THE 1 CHARACTER PER WORD             **
5794C               **  REPRESENTATION OF THE VALUE IN IV2.  **
5795C               *******************************************
5796C
5797      ISTEPN='3'
5798      IF(IBUGCN.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5799C
5800      J=0
5801      IREM=IV2
5802      DO200IPASS=1,10
5803      J=J+1
5804      IDIGIT=IREM-10*(IREM/10)
5805      IF(IDIGIT.EQ.0)ISTRIT(J)='0'
5806      IF(IDIGIT.EQ.1)ISTRIT(J)='1'
5807      IF(IDIGIT.EQ.2)ISTRIT(J)='2'
5808      IF(IDIGIT.EQ.3)ISTRIT(J)='3'
5809      IF(IDIGIT.EQ.4)ISTRIT(J)='4'
5810      IF(IDIGIT.EQ.5)ISTRIT(J)='5'
5811      IF(IDIGIT.EQ.6)ISTRIT(J)='6'
5812      IF(IDIGIT.EQ.7)ISTRIT(J)='7'
5813      IF(IDIGIT.EQ.8)ISTRIT(J)='8'
5814      IF(IDIGIT.EQ.9)ISTRIT(J)='9'
5815      IREM=IREM-IDIGIT
5816      IREM=IREM/10
5817      IF(IREM.LE.0)GOTO240
5818  200 CONTINUE
5819  240 CONTINUE
5820      N2=J
5821C
5822      DO250I=1,N2
5823      K=K+1
5824      IREV=N2-I+1
5825      ISTRIN(K)=ISTRIT(IREV)
5826  250 CONTINUE
5827C
5828C               *******************************************************
5829C               **  STEP 4--                                         **
5830C               **  CONVERT THE 1 CHARACTER PER WORD REPRESENTATION  **
5831C               **  FOR THE PARAMETER NAME                           **
5832C               **  INTO A 4 CHARACTER PER WORD REPRESENTATION.      **
5833C               *******************************************************
5834C
5835      ISTEPN='4'
5836      IF(IBUGCN.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5837C
5838      ISTART=1
5839      ISTOP=K
5840      CALL DP1H4H(ISTART,ISTOP,ISTRIN,
5841     1IWORD1,IWORD2,IWORD3,NUMWD,NUMCH,IBUGCN,IERROR)
5842C
5843C               *****************
5844C               **  STEP 90--  **
5845C               **  EXIT       **
5846C               *****************
5847C
5848      IF(IBUGCN.EQ.'ON')THEN
5849        WRITE(ICOUT,999)
5850        CALL DPWRST('XXX','BUG ')
5851        WRITE(ICOUT,9011)
5852 9011   FORMAT('***** AT THE END       OF COENAM--')
5853        CALL DPWRST('XXX','BUG ')
5854        WRITE(ICOUT,9012)IERROR
5855 9012   FORMAT('IERROR = ',A4)
5856        CALL DPWRST('XXX','BUG ')
5857        WRITE(ICOUT,9013)N1,N2,ISTART,ISTOP
5858 9013   FORMAT('N1,N2,ISTART,ISTOP = ',4I8)
5859        CALL DPWRST('XXX','BUG ')
5860        WRITE(ICOUT,9014)(ISTRIN(I),I=1,K)
5861 9014   FORMAT('ISTRIN(.) = ',80A1)
5862        CALL DPWRST('XXX','BUG ')
5863        WRITE(ICOUT,9015)NUMBPC,NUMCPW,NUMWD,NUMCH
5864 9015   FORMAT('NUMBPC,NUMCPW,NUMWD,NUMCH = ',4I8)
5865        CALL DPWRST('XXX','BUG ')
5866        WRITE(ICOUT,9017)IWORD1,IWORD2,IWORD3
5867 9017   FORMAT('IWORD1,IWORD2,IWORD3 = ',2(A4,2X),A4)
5868        CALL DPWRST('XXX','BUG ')
5869      ENDIF
5870C
5871      RETURN
5872      END
5873      SUBROUTINE COLLAP(NVAR, X, Y, LOCY, NX, NY, DIM, CONFIG)
5874C
5875C        ALGORITHM AS 51.1  APPL. STATIST. (1972) VOL.21, P.218
5876C
5877C        COMPUTES A MARGINAL TABLE FROM A COMPLETE TABLE.
5878C        ALL PARAMETERS ARE ASSUMED VALID WITHOUT TEST.
5879C
5880C        IF THE VALUE OF NVAR IS TO BE GREATER THAN 7, THE
5881C        DIMENSIONS IN THE DECLARATIONS OF SIZE AND COORD MUST
5882C        BE INCREASED TO NVAR+1 AND NVAR RESPECTIVELY.
5883C
5884      INTEGER SIZE(8), DIM(NVAR), CONFIG(NVAR), COORD(7)
5885C
5886C        THE LARGER TABLE IS X AND THE SMALLER ONE IS Y
5887C
5888      REAL X(NX), Y(NY), ZERO
5889      DATA ZERO /0.0/
5890C
5891C        INITIALISE ARRAYS
5892C
5893      SIZE(1) = 1
5894      DO 10 K = 1, NVAR
5895         L = CONFIG(K)
5896         IF (L .EQ. 0) GOTO 20
5897         SIZE(K + 1) = SIZE(K) * DIM(L)
5898   10 CONTINUE
5899C
5900C        FIND NUMBER OF VARIABLES IN CONFIGURATION
5901C
5902      K = NVAR + 1
5903   20 CONTINUE
5904      N = K - 1
5905C
5906C        INITIALISE Y. FIRST CELL OF MARGINAL TABLE IS
5907C        AT Y(LOCY) AND TABLE HAS SIZE(K) ELEMENTS
5908C
5909      LOCU = LOCY + SIZE(K) - 1
5910      DO 30 J = LOCY, LOCU
5911         Y(J) = ZERO
5912   30 CONTINUE
5913C
5914C        INITIALISE COORDINATES
5915C
5916      DO 50 K = 1, NVAR
5917         COORD(K) = 0
5918   50 CONTINUE
5919C
5920C        FIND LOCATIONS IN TABLES
5921C
5922      I = 1
5923   60 CONTINUE
5924      J = LOCY
5925      DO 70 K = 1, N
5926         L = CONFIG(K)
5927         J = J + COORD(L) * SIZE(K)
5928   70 CONTINUE
5929      Y(J) = Y(J) + X(I)
5930C
5931C        UPDATE COORDINATES
5932C
5933      I = I + 1
5934      DO 80 K = 1, NVAR
5935         COORD(K) = COORD(K) + 1
5936         IF (COORD(K) .LT. DIM(K)) GOTO 60
5937         COORD(K) = 0
5938   80 CONTINUE
5939C
5940      RETURN
5941      END
5942      SUBROUTINE COMARI(Y1,Y2,Y3,Y4,N1,IACASE,IWRITE,
5943     1                  Y5,Y6,N5,SCAL3,ITYP3,
5944     1                  IBUGA3,ISUBRO,IERROR)
5945C
5946C     PURPOSE--CARRY OUT COMPLEX ARITHMETIC OPERATIONS
5947C              OF THE COMPLEX DATA IN Y1,Y2 AND Y3,Y4.
5948C
5949C     OPERATIONS--ADDITION
5950C                 SUBTRACTTION
5951C                 MULTIPLICATION
5952C                 DIVISION
5953C                 EXPONENTIATION
5954C                 SQUARE ROOT
5955C                 ROOTS OF A POLYNOMIAL (WITH COMPLEX COEFFICIENTS)
5956C                 CONJUGATE
5957C
5958C     INPUT  ARGUMENTS--Y1 (REAL PART)       Y2 (IMAGINARY PART)
5959C                     --Y3 (REAL PART)       Y4 (IMAGINARY PART)
5960C     OUTPUT ARGUMENTS--Y5 (REAL PART)       Y6 (IMAGINARY PART)
5961C
5962C     NOTE--IT IS NOT PERMISSIBLE TO HAVE THE OUTPUT VECTORS Y5(.) AND Y6(.)
5963C           BEING IDENTICAL TO THE INPUT VECTORS Y1(.) AND Y2(.), OR
5964C           Y3(.) AND Y4(.).
5965C     WRITTEN BY--JAMES J. FILLIBEN
5966C                 STATISTICAL ENGINEERING DIVISION
5967C                 INFORMATION TECHNOLOGY LABORATORY
5968C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
5969C                 GAITHERSBURG, MD 20899
5970C                 PHONE--301-975-2855
5971C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
5972C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
5973C     LANGUAGE--ANSI FORTRAN (1977)
5974C     VERSION NUMBER--87/5
5975C     ORIGINAL VERSION--APRIL     1987.
5976C     UPDATED         --AUGUST    1987.  COMPLEX SQUARE ROOT
5977C     UPDATED         --AUGUST    1987.  COMPLEX ROOTS OF POLYNOMIAL
5978C     UPDATED         --SEPTEMBER 1987.  COMPLEX CONJUGATE
5979C     UPDATED         --MAY       1995.  EQUIVALENCE FOR ARRAYS
5980C     UPDATED         --AUGUST    1995.  REPLACE NUMERICAL RECIPES
5981C                                        ROUTINE FOR COMPLEX ROOTS
5982C                                        WITH CMLIB ROUTINE
5983C     UPDATED         --JUNE      2019.  DIMENSION COEFS, ROOTS,
5984C                                        WORK, ERRBND
5985C
5986C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
5987C
5988      CHARACTER*4 IACASE
5989      CHARACTER*4 IWRITE
5990      CHARACTER*4 ITYP3
5991      CHARACTER*4 IBUGA3
5992      CHARACTER*4 ISUBRO
5993      CHARACTER*4 IERROR
5994C
5995      CHARACTER*4 ISUBN1
5996      CHARACTER*4 ISUBN2
5997C
5998C-----COMPLEX STATEMENTS FOR NON-COMMON VARIABLES-------------------
5999C
6000      COMPLEX CY1Y2
6001      COMPLEX CTRANS
6002      COMPLEX COEFS
6003      COMPLEX ROOTS
6004CCCCC FOLLOWING LINES ADDED AUGUST 1995
6005      COMPLEX WORK
6006C
6007C-----DOUBLE PRECISION STATEMENTS FOR NON-COMMON VARIABLES-------------------
6008C
6009      DOUBLE PRECISION DY1
6010      DOUBLE PRECISION DY2
6011      DOUBLE PRECISION DY3
6012      DOUBLE PRECISION DY4
6013      DOUBLE PRECISION DY5
6014      DOUBLE PRECISION DY6
6015      DOUBLE PRECISION DDEN
6016      DOUBLE PRECISION DE
6017      DOUBLE PRECISION DC
6018      DOUBLE PRECISION DS
6019C
6020C-----LOGICAL STATEMENTS FOR NON-COMMON VARIABLES-------------------
6021C
6022CCCCC LOGICAL POLISH
6023C
6024C---------------------------------------------------------------------
6025C
6026      INCLUDE 'DPCOPA.INC'
6027C
6028      DIMENSION Y1(*)
6029      DIMENSION Y2(*)
6030      DIMENSION Y3(*)
6031      DIMENSION Y4(*)
6032      DIMENSION Y5(*)
6033      DIMENSION Y6(*)
6034C
6035      DIMENSION COEFS(MAXOBV)
6036      DIMENSION ROOTS(MAXOBV)
6037      DIMENSION WORK(MAXOBV)
6038      DIMENSION ERRBND(MAXOBV)
6039      INCLUDE 'DPCOZZ.INC'
6040      EQUIVALENCE (GARBAG(JGAR15),COEFS(1))
6041      EQUIVALENCE (GARBAG(JGAR17),ROOTS(1))
6042      EQUIVALENCE (GARBAG(JGAR19),WORK(1))
6043      EQUIVALENCE (GARBAG(IGAR10),ERRBND(1))
6044C
6045C---------------------------------------------------------------------
6046C
6047      INCLUDE 'DPCOP2.INC'
6048C
6049C-----START POINT-----------------------------------------------------
6050C
6051      ISUBN1='COMA'
6052      ISUBN2='RI  '
6053C
6054      IERROR='NO'
6055C
6056      SCAL3=(-999.0)
6057      ITYP3='VECT'
6058C
6059      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'MARI')GOTO90
6060      WRITE(ICOUT,999)
6061  999 FORMAT(1X)
6062      CALL DPWRST('XXX','BUG ')
6063      WRITE(ICOUT,51)
6064   51 FORMAT('***** AT THE BEGINNING OF COMARI--')
6065      CALL DPWRST('XXX','BUG ')
6066      WRITE(ICOUT,52)IBUGA3,ISUBRO,IACASE,IWRITE
6067   52 FORMAT('IBUGA3,ISUBRO,IACASE,IWRITE = ',A4,2X,A4,2X,A4,2X,A4)
6068      CALL DPWRST('XXX','BUG ')
6069      WRITE(ICOUT,53)N1
6070   53 FORMAT('N1 = ',I8)
6071      CALL DPWRST('XXX','BUG ')
6072      DO55I=1,N1
6073      WRITE(ICOUT,56)I,Y1(I),Y2(I),Y3(I),Y4(I)
6074   56 FORMAT('I,Y1(I),Y2(I),Y3(I),Y4(I) = ',I8,4E13.5)
6075      CALL DPWRST('XXX','BUG ')
6076   55 CONTINUE
6077   90 CONTINUE
6078C
6079C               ***********************************************
6080C               **  CARRY OUT COMPLEX ARITHMETIC OPERATIONS  **
6081C               ***********************************************
6082C
6083C               ********************************************
6084C               **  STEP 11--                             **
6085C               **  CHECK NUMBER OF INPUT OBSERVATIONS.   **
6086C               ********************************************
6087C
6088      IF(N1.LT.1)GOTO1100
6089      GOTO1190
6090C
6091 1100 CONTINUE
6092      IERROR='YES'
6093      WRITE(ICOUT,999)
6094      CALL DPWRST('XXX','BUG ')
6095      WRITE(ICOUT,1151)
6096 1151 FORMAT('***** ERROR IN COMARI--')
6097      CALL DPWRST('XXX','BUG ')
6098      WRITE(ICOUT,1152)
6099 1152 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
6100      CALL DPWRST('XXX','BUG ')
6101      WRITE(ICOUT,1153)
6102 1153 FORMAT('      IN THE VARIABLE FOR WHICH')
6103      CALL DPWRST('XXX','BUG ')
6104      IF(IACASE.EQ.'COAD')WRITE(ICOUT,1154)
6105 1154 FORMAT('      THE COMPLEX ADDITION IS TO BE ',
6106     1'COMPUTED')
6107      IF(IACASE.EQ.'COAD')CALL DPWRST('XXX','BUG ')
6108      IF(IACASE.EQ.'COSU')WRITE(ICOUT,1155)
6109 1155 FORMAT('      THE COMPLEX SUBTRACTION IS TO BE ',
6110     1'COMPUTED')
6111      IF(IACASE.EQ.'COSU')CALL DPWRST('XXX','BUG ')
6112      IF(IACASE.EQ.'COMU')WRITE(ICOUT,1156)
6113 1156 FORMAT('      THE COMPLEX MULTIPLICATION IS TO BE ',
6114     1'COMPUTED')
6115      IF(IACASE.EQ.'COMU')CALL DPWRST('XXX','BUG ')
6116      IF(IACASE.EQ.'CODI')WRITE(ICOUT,1157)
6117 1157 FORMAT('      THE COMPLEX DIVISION IS TO BE ',
6118     1'COMPUTED')
6119      IF(IACASE.EQ.'CODI')CALL DPWRST('XXX','BUG ')
6120      IF(IACASE.EQ.'COEX')WRITE(ICOUT,1158)
6121 1158 FORMAT('      THE COMPLEX EXPONENTIATION IS TO BE ',
6122     1'COMPUTED')
6123      IF(IACASE.EQ.'COEX')CALL DPWRST('XXX','BUG ')
6124      IF(IACASE.EQ.'COSR')WRITE(ICOUT,1159)
6125 1159 FORMAT('      THE COMPLEX SQUARE ROOT IS TO BE ',
6126     1'COMPUTED')
6127      IF(IACASE.EQ.'COSR')CALL DPWRST('XXX','BUG ')
6128      IF(IACASE.EQ.'CORO')WRITE(ICOUT,1160)
6129 1160 FORMAT('      THE COMPLEX ROOTS ARE TO BE ',
6130     1'COMPUTED')
6131      IF(IACASE.EQ.'CORO')CALL DPWRST('XXX','BUG ')
6132      IF(IACASE.EQ.'COR1')WRITE(ICOUT,1161)
6133 1161 FORMAT('      THE COMPLEX ROOTS ARE TO BE ',
6134     1'COMPUTED')
6135      IF(IACASE.EQ.'COR1')CALL DPWRST('XXX','BUG ')
6136      IF(IACASE.EQ.'COCO')WRITE(ICOUT,1162)
6137 1162 FORMAT('      THE COMPLEX CONJUGATE IS TO BE ',
6138     1'COMPUTED')
6139      IF(IACASE.EQ.'COCO')CALL DPWRST('XXX','BUG ')
6140      WRITE(ICOUT,1171)
6141 1171 FORMAT('      MUST BE 1 OR LARGER.')
6142      CALL DPWRST('XXX','BUG ')
6143      WRITE(ICOUT,1172)
6144 1172 FORMAT('      SUCH WAS NOT THE CASE HERE.')
6145      CALL DPWRST('XXX','BUG ')
6146      WRITE(ICOUT,1173)N1
6147 1173 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
6148     1'.')
6149      CALL DPWRST('XXX','BUG ')
6150      GOTO9000
6151C
6152 1190 CONTINUE
6153C
6154C               *********************************
6155C               **  STEP 12--                  **
6156C               **  BRANCH TO THE PROPER CASE  **
6157C               *********************************
6158C
6159      IF(IACASE.EQ.'COAD')GOTO2100
6160      IF(IACASE.EQ.'COSU')GOTO2200
6161      IF(IACASE.EQ.'COMU')GOTO2300
6162      IF(IACASE.EQ.'CODI')GOTO2400
6163      IF(IACASE.EQ.'COEX')GOTO2500
6164      IF(IACASE.EQ.'COSR')GOTO2600
6165      IF(IACASE.EQ.'CORO')GOTO2700
6166      IF(IACASE.EQ.'COR1')GOTO2700
6167      IF(IACASE.EQ.'COCO')GOTO2800
6168C
6169      WRITE(ICOUT,999)
6170      CALL DPWRST('XXX','BUG ')
6171      WRITE(ICOUT,1211)
6172 1211 FORMAT('***** INTERNAL ERROR IN COMARI--')
6173      CALL DPWRST('XXX','BUG ')
6174      WRITE(ICOUT,1212)
6175 1212 FORMAT('      IACASE NOT EQUAL TO')
6176      CALL DPWRST('XXX','BUG ')
6177      WRITE(ICOUT,1213)
6178 1213 FORMAT('      COAD, COSU, COMU, CODI,')
6179      CALL DPWRST('XXX','BUG ')
6180      WRITE(ICOUT,1214)
6181 1214 FORMAT('      COEX, COSR, CORO, COR1,')
6182      CALL DPWRST('XXX','BUG ')
6183      WRITE(ICOUT,1215)
6184 1215 FORMAT('      OR COCO')
6185      CALL DPWRST('XXX','BUG ')
6186      WRITE(ICOUT,1221)
6187 1221 FORMAT('      IACASE = ',A4)
6188      CALL DPWRST('XXX','BUG ')
6189      IERROR='YES'
6190      GOTO9000
6191C
6192C               *********************************************
6193C               **  STEP 21--                              **
6194C               **  TREAT THE COMPLEX ADDITION       CASE  **
6195C               *********************************************
6196C
6197 2100 CONTINUE
6198      DO2110I=1,N1
6199      DY1=Y1(I)
6200      DY2=Y2(I)
6201      DY3=Y3(I)
6202      DY4=Y4(I)
6203      DY5=DY1+DY3
6204      DY6=DY2+DY4
6205      Y5(I)=DY5
6206      Y6(I)=DY6
6207 2110 CONTINUE
6208C
6209      ITYP3='VECT'
6210      N5=N1
6211      GOTO9000
6212C
6213C               *********************************************
6214C               **  STEP 22--                              **
6215C               **  TREAT THE COMPLEX SUBTRACTION    CASE  **
6216C               *********************************************
6217C
6218 2200 CONTINUE
6219      DO2210I=1,N1
6220      DY1=Y1(I)
6221      DY2=Y2(I)
6222      DY3=Y3(I)
6223      DY4=Y4(I)
6224      DY5=DY1-DY3
6225      DY6=DY2-DY4
6226      Y5(I)=DY5
6227      Y6(I)=DY6
6228 2210 CONTINUE
6229C
6230      ITYP3='VECT'
6231      N5=N1
6232      GOTO9000
6233C
6234C               *********************************************
6235C               **  STEP 23--                              **
6236C               **  TREAT THE COMPLEX MULTIPLICATION CASE  **
6237C               *********************************************
6238C
6239 2300 CONTINUE
6240      DO2310I=1,N1
6241      DY1=Y1(I)
6242      DY2=Y2(I)
6243      DY3=Y3(I)
6244      DY4=Y4(I)
6245      DY5=DY1*DY3-DY2*DY4
6246      DY6=DY1*DY4+DY2*DY3
6247      Y5(I)=DY5
6248      Y6(I)=DY6
6249 2310 CONTINUE
6250C
6251      ITYP3='VECT'
6252      N5=N1
6253      GOTO9000
6254C
6255C               *********************************************
6256C               **  STEP 24--                              **
6257C               **  TREAT THE COMPLEX DIVISION       CASE  **
6258C               *********************************************
6259C
6260 2400 CONTINUE
6261      DO2410I=1,N1
6262      DY1=Y1(I)
6263      DY2=Y2(I)
6264      DY3=Y3(I)
6265      DY4=Y4(I)
6266      DDEN=DY3**2+DY4**2
6267      IF(DDEN.NE.0.0D0)GOTO2419
6268      WRITE(ICOUT,999)
6269      CALL DPWRST('XXX','BUG ')
6270      WRITE(ICOUT,2411)
6271 2411 FORMAT('***** ERROR IN COMARI--')
6272      CALL DPWRST('XXX','BUG ')
6273      WRITE(ICOUT,2412)
6274 2412 FORMAT('      A ZERO DENOMINATOR WAS ENCOUNTERED')
6275      CALL DPWRST('XXX','BUG ')
6276      WRITE(ICOUT,2413)
6277 2413 FORMAT('      IN ATTEMPTING TO CARRY OUT')
6278      CALL DPWRST('XXX','BUG ')
6279      WRITE(ICOUT,2414)
6280 2414 FORMAT('      A COMPLEX DIVISION.')
6281      CALL DPWRST('XXX','BUG ')
6282      WRITE(ICOUT,2415)I
6283 2415 FORMAT('      THE ',I8,'TH ELEMENT OF THE')
6284      CALL DPWRST('XXX','BUG ')
6285      WRITE(ICOUT,2416)
6286 2416 FORMAT('      REAL AND IMAGINARY PARTS OF THE')
6287      CALL DPWRST('XXX','BUG ')
6288      WRITE(ICOUT,2417)
6289 2417 FORMAT('      COMPLEX DIVISOR ARE BOTH 0')
6290      CALL DPWRST('XXX','BUG ')
6291      WRITE(ICOUT,2418)I,Y3(I),Y4(I)
6292 2418 FORMAT('I,Y3(I),Y4(I) = ',I8,2E15.7)
6293      CALL DPWRST('XXX','BUG ')
6294      IERROR='YES'
6295      GOTO9000
6296 2419 CONTINUE
6297      DY5=(DY1*DY3+DY2*DY4)/DDEN
6298      DY6=(DY2*DY3-DY1*DY4)/DDEN
6299      Y5(I)=DY5
6300      Y6(I)=DY6
6301 2410 CONTINUE
6302C
6303      ITYP3='VECT'
6304      N5=N1
6305      GOTO9000
6306C
6307C               *********************************************
6308C               **  STEP 25--                              **
6309C               **  TREAT THE COMPLEX EXPONENTIATION CASE  **
6310C               *********************************************
6311C
6312 2500 CONTINUE
6313      DO2510I=1,N1
6314      DY1=Y1(I)
6315      DY2=Y2(I)
6316      DE=DEXP(DY1)
6317      DC=DCOS(DY2)
6318      DS=DSIN(DY2)
6319      DY5=DE*DC
6320      DY6=DE*DS
6321      Y5(I)=DY5
6322      Y6(I)=DY6
6323 2510 CONTINUE
6324C
6325      ITYP3='VECT'
6326      N5=N1
6327      GOTO9000
6328C
6329C               *********************************************
6330C               **  STEP 26--                              **
6331C               **  TREAT THE COMPLEX SQUARE ROOT    CASE  **
6332C               *********************************************
6333C
6334 2600 CONTINUE
6335      DO2610I=1,N1
6336      CY1Y2=CMPLX(Y1(I),Y2(I))
6337      CTRANS=CSQRT(CY1Y2)
6338      Y5(I)=REAL(CTRANS)
6339      Y6(I)=AIMAG(CTRANS)
6340 2610 CONTINUE
6341C
6342      ITYP3='VECT'
6343      N5=N1
6344      GOTO9000
6345C
6346C               ***********************************************
6347C               **  STEP 27--                                **
6348C               **  TREAT THE COMPLEX ROOTS OF A POLYNOMIAL  **
6349C               **  WITH COMPLEX COEFFICIENTS CASE           **
6350C               ***********************************************
6351C
6352 2700 CONTINUE
6353      NCOEFS=N1
6354      NROOTS=NCOEFS-1
6355C
6356CCCCC AUGUST 1995.  REPLACE NUMERICAL RECIPES ROUTINE WITH
6357CCCCC SLATEC ROUTINE.
6358CCCCC CPZERO EXPECTS COEFFICIENTS IN OPPOSIT ORDER OF ZROOTS.
6359CCCCC DO2710I=1,NCOEFS
6360CCCCC COEFS(I)=CMPLX(Y1(I),Y2(I))
6361C2710 CONTINUE
6362      ICOUNT=0
6363      DO2710I=NCOEFS,1,-1
6364      ICOUNT=ICOUNT+1
6365      COEFS(ICOUNT)=CMPLX(Y1(I),Y2(I))
6366 2710 CONTINUE
6367C
6368      IFLG=0
6369      CALL CPZERO(NROOTS,COEFS,ROOTS,WORK,IFLG,ERRBND)
6370      IF(IFLG.EQ.1)THEN
6371        WRITE(ICOUT,2721)
6372 2721   FORMAT('***** ERROR IN COMARI--LEADING COEFFICIENT IS ',
6373     1         'ZERO OR DEGREE IS ZERO')
6374        CALL DPWRST('XXX','BUG ')
6375      ELSEIF(IFLG.EQ.2)THEN
6376        WRITE(ICOUT,2726)
6377 2726   FORMAT('***** ERROR IN COMARI--ROOTS DID NOT CONVERGE.')
6378        CALL DPWRST('XXX','BUG ')
6379      ENDIF
6380CCCCC POLISH=.FALSE.
6381CCCCC CALL ZROOTS(COEFS,NROOTS,ROOTS,POLISH)
6382C
6383CCCCC DO2720I=1,NROOTS
6384CCCCC ROOTS(I)=ROOTS(I)*(1.0+0.01*I)
6385C2720 CONTINUE
6386C
6387CCCCC POLISH=.TRUE.
6388CCCCC CALL ZROOTS(COEFS,NROOTS,ROOTS,POLISH)
6389C
6390      DO2730I=1,NROOTS
6391      Y5(I)=REAL(ROOTS(I))
6392      Y6(I)=AIMAG(ROOTS(I))
6393 2730 CONTINUE
6394C
6395      ITYP3='VECT'
6396      N5=NROOTS
6397      GOTO9000
6398C
6399C               *********************************************
6400C               **  STEP 28--                              **
6401C               **  TREAT THE COMPLEX CONJUGATE      CASE  **
6402C               *********************************************
6403C
6404 2800 CONTINUE
6405      DO2810I=1,N1
6406      Y5(I)=Y1(I)
6407      Y6(I)=(-Y2(I))
6408 2810 CONTINUE
6409C
6410      ITYP3='VECT'
6411      N5=N1
6412      GOTO9000
6413C
6414C               *****************
6415C               **  STEP 90--  **
6416C               **  EXIT.      **
6417C               *****************
6418C
6419 9000 CONTINUE
6420C
6421      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'MARI')GOTO9090
6422      WRITE(ICOUT,999)
6423      CALL DPWRST('XXX','BUG ')
6424      WRITE(ICOUT,9011)
6425 9011 FORMAT('***** AT THE END       OF COMARI--')
6426      CALL DPWRST('XXX','BUG ')
6427      WRITE(ICOUT,9012)IBUGA3,ISUBRO,IACASE,IWRITE
6428 9012 FORMAT('IBUGA3,ISUBRO,IACASE,IWRITE = ',A4,2X,A4,2X,A4,2X,A4)
6429      CALL DPWRST('XXX','BUG ')
6430      WRITE(ICOUT,9013)IERROR
6431 9013 FORMAT('IERROR = ',A4)
6432      CALL DPWRST('XXX','BUG ')
6433      WRITE(ICOUT,9017)N1,N5
6434 9017 FORMAT('N1,N5 = ',2I8)
6435      CALL DPWRST('XXX','BUG ')
6436      WRITE(ICOUT,9018)SCAL3,ITYP3
6437 9018 FORMAT('SCAL3,ITYP3 = ',E15.7,2X,A4)
6438      CALL DPWRST('XXX','BUG ')
6439      IF(ITYP3.EQ.'SCAL')GOTO9090
6440      DO9015I=1,N1
6441      WRITE(ICOUT,9016)I,Y1(I),Y2(I),Y3(I),Y4(I),Y5(I),Y6(I)
6442 9016 FORMAT('I,Y1(I),Y2(I),Y3(I),Y4(I),Y5(I),Y6(I) = ',I8,6E13.5)
6443      CALL DPWRST('XXX','BUG ')
6444 9015 CONTINUE
6445 9090 CONTINUE
6446C
6447      RETURN
6448      END
6449      SUBROUTINE COMDIG(X,N,IWRITE,XDIGI,NDIGI,IBUGA3,IERROR)
6450C
6451C     PURPOSE--THIS SUBROUTINE COMPUTES THE COMMON DIGITS FOR A
6452C              VECTOR OF NUMBERS.  FOR EXAMPLE, GIVEN
6453C                0.0321, 0.0323, 0.0329, 0.0325
6454C              THE COMMON DIGITS ARE 0.03.  NOTE THAT ONLY DIGITS
6455C              TO THE RIGHT OF THE DECIMAL PLACE ARE CONSIDERED.
6456C              THE FOLLOWING SPECIAL CASES ARE CONSIDERED:
6457C                  1) IF THE FIRST DECIMAL DOES NOT AGREE, SET
6458C                     XDIGI=-1.0.
6459C                  2) IF THE INTEGER PORTION OF THE NUMBER DOES
6460C                     NOT AGREE, THEN SET XDIGI=-1.0.
6461C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
6462C                                (UNSORTED OR SORTED) OBSERVATIONS.
6463C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
6464C                                IN THE VECTOR X.
6465C     OUTPUT ARGUMENTS--XDIGI  = THE SINGLE PRECISION VALUE OF THE
6466C                                COMPUTED COMMON DIGITS
6467C                     --NDIGI  = THE INTEGER VALUE OF THE
6468C                                NUMBER OF COMMON DIGITS
6469C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
6470C             COMMON DIGITS
6471C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
6472C                   OF N FOR THIS SUBROUTINE.
6473C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
6474C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
6475C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
6476C     LANGUAGE--ANSI FORTRAN (1977)
6477C     WRITTEN BY--ALAN HECKERT
6478C                 STATISTICAL ENGINEERING DIVISION
6479C                 INFORMATION TECHNOLOGY LABORATORY
6480C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
6481C                 GAITHERSBURG, MD 20899
6482C                 PHONE--301-975-2899
6483C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
6484C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
6485C     LANGUAGE--ANSI FORTRAN (1977)
6486C     VERSION NUMBER--2001.8
6487C     ORIGINAL VERSION--AUGUST    2001.
6488C
6489      PARAMETER(MAXDIG=7)
6490C
6491C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
6492C
6493      CHARACTER*4 IWRITE
6494      CHARACTER*4 IBUGA3
6495      CHARACTER*4 IERROR
6496C
6497      CHARACTER*4 ISUBN1
6498      CHARACTER*4 ISUBN2
6499C
6500C---------------------------------------------------------------------
6501C
6502      DIMENSION X(*)
6503      DIMENSION DIGITS(MAXDIG)
6504C
6505C---------------------------------------------------------------------
6506C
6507      INCLUDE 'DPCOP2.INC'
6508C
6509C-----START POINT-----------------------------------------------------
6510C
6511      ISUBN1='COMD'
6512      ISUBN2='IG  '
6513C
6514      IERROR='NO'
6515C
6516      IF(IBUGA3.EQ.'OFF')GOTO90
6517      WRITE(ICOUT,999)
6518  999 FORMAT(1X)
6519      CALL DPWRST('XXX','BUG ')
6520      WRITE(ICOUT,51)
6521   51 FORMAT('***** AT THE BEGINNING OF COMDIG--')
6522      CALL DPWRST('XXX','BUG ')
6523      WRITE(ICOUT,52)IBUGA3
6524   52 FORMAT('IBUGA3 = ',A4)
6525      CALL DPWRST('XXX','BUG ')
6526      WRITE(ICOUT,53)N
6527   53 FORMAT('N = ',I8)
6528      CALL DPWRST('XXX','BUG ')
6529      DO55I=1,N
6530      WRITE(ICOUT,56)I,X(I)
6531   56 FORMAT('I,X(I) = ',I8,E15.7)
6532      CALL DPWRST('XXX','BUG ')
6533   55 CONTINUE
6534   90 CONTINUE
6535C
6536C               ********************************************
6537C               **  STEP 1--                              **
6538C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
6539C               ********************************************
6540C
6541      AN=N
6542C
6543      IF(N.GE.2)GOTO119
6544      IERROR='YES'
6545      WRITE(ICOUT,999)
6546      CALL DPWRST('XXX','BUG ')
6547      WRITE(ICOUT,111)
6548  111 FORMAT('***** ERROR IN COMDIG--THE INPUT NUMBER OF OBSERVATIONS')
6549      CALL DPWRST('XXX','BUG ')
6550      WRITE(ICOUT,113)
6551  113 FORMAT('      IN THE VARIABLE FOR WHICH THE COMMON DIGITS ARE')
6552      CALL DPWRST('XXX','BUG ')
6553      WRITE(ICOUT,115)
6554  115 FORMAT('      TO BE COMPUTED MUST BE 2 OR LARGER.')
6555      CALL DPWRST('XXX','BUG ')
6556      WRITE(ICOUT,116)
6557  116 FORMAT('      SUCH WAS NOT THE CASE HERE.')
6558      CALL DPWRST('XXX','BUG ')
6559      WRITE(ICOUT,117)N
6560  117 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,'.')
6561      CALL DPWRST('XXX','BUG ')
6562      GOTO9000
6563  119 CONTINUE
6564C
6565      HOLD=X(1)
6566      DO135I=2,N
6567      IF(X(I).NE.HOLD)GOTO139
6568  135 CONTINUE
6569      WRITE(ICOUT,999)
6570      CALL DPWRST('XXX','BUG ')
6571      WRITE(ICOUT,136)HOLD
6572  136 FORMAT('***** NON-FATAL DIAGNOSTIC IN COMDIG--',
6573     1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
6574      CALL DPWRST('XXX','BUG ')
6575      XDIGI=ABS(HOLD)-REAL(INT(ABS(HOLD)))
6576      NDIGI=MAXDIG
6577      GOTO9000
6578  139 CONTINUE
6579C
6580C  CHECK IF INTEGER PORTION OF NUMBERS MATCHES FOR ALL THE NUMBERS.
6581C
6582      IHOLD=INT(X(1))
6583      DO145I=2,N
6584        IXTEMP=INT(X(I))
6585        IF(IXTEMP.NE.IHOLD)THEN
6586          NDIG=-1
6587          XDIGI=0.0
6588          IF(IFEEDB.EQ.'OFF')GOTO149
6589          IF(IWRITE.EQ.'OFF')GOTO149
6590          WRITE(ICOUT,999)
6591          CALL DPWRST('XXX','BUG ')
6592          WRITE(ICOUT,146)N
6593  146 FORMAT('THE INTEGER PORTION OF THE  ',I8,' OBSERVATIONS DOES ',
6594     1       'NOT MATCH.')
6595          CALL DPWRST('XXX','BUG ')
6596  149     CONTINUE
6597          GOTO800
6598        ENDIF
6599  145 CONTINUE
6600C
6601C               ************************
6602C               **  STEP 2--          **
6603C               **  COMPUTE THE DIGITS**
6604C               ************************
6605C
6606      XDIGI=0.0
6607      NDIGI=0
6608C
6609      DO200L=1,MAXDIG
6610        ATEMP=X(1)*10**(L-1)
6611        ADIG=ABS(ATEMP) - INT(ABS(ATEMP))
6612        IDIG=INT(ADIG*10)
6613        DO300I=2,N
6614          ATEMP=X(I)*10**(L-1)
6615          ADIG=ABS(ATEMP) - INT(ABS(ATEMP))
6616          IDIG2=INT(ADIG*10)
6617          IF(IDIG.NE.IDIG2)GOTO209
6618  300   CONTINUE
6619        NDIGI=NDIGI+1
6620        DIGITS(NDIGI)=IDIG
6621  200 CONTINUE
6622  209 CONTINUE
6623C
6624      IF(NDIGI.GT.0)THEN
6625        XDIGI=REAL(INT(X(1)))*(10**NDIGI)
6626        DO400I=1,NDIGI
6627          ATEMP=DIGITS(I)*(10**(NDIGI-I))
6628          XDIGI=XDIGI + ATEMP
6629  400   CONTINUE
6630        XDIGI=XDIGI/(10**NDIGI)
6631      ENDIF
6632C
6633C               *******************************
6634C               **  STEP 3--                 **
6635C               **  WRITE OUT A LINE         **
6636C               **  OF SUMMARY INFORMATION.  **
6637C               *******************************
6638C
6639  800 CONTINUE
6640      IF(IFEEDB.EQ.'OFF')GOTO890
6641      IF(IWRITE.EQ.'OFF')GOTO890
6642      WRITE(ICOUT,999)
6643      CALL DPWRST('XXX','BUG ')
6644      WRITE(ICOUT,811)N,NDIGI
6645  811 FORMAT('THE NUMBER OF COMMON DIGITS FOR THE ',I8,
6646     1       ' OBSERVATIONS = ',I5)
6647      CALL DPWRST('XXX','BUG ')
6648      WRITE(ICOUT,813)XDIGI
6649  813 FORMAT('THE COMMON DIGITS = ',G15.7)
6650      CALL DPWRST('XXX','BUG ')
6651  890 CONTINUE
6652C
6653C               *****************
6654C               **  STEP 90--  **
6655C               **  EXIT.      **
6656C               *****************
6657C
6658 9000 CONTINUE
6659      IF(IBUGA3.EQ.'OFF')GOTO9090
6660      WRITE(ICOUT,999)
6661      CALL DPWRST('XXX','BUG ')
6662      WRITE(ICOUT,9011)
6663 9011 FORMAT('***** AT THE END       OF SUM--')
6664      CALL DPWRST('XXX','BUG ')
6665      WRITE(ICOUT,9012)IBUGA3,IERROR
6666 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
6667      CALL DPWRST('XXX','BUG ')
6668      WRITE(ICOUT,9013)N
6669 9013 FORMAT('N = ',I8)
6670      CALL DPWRST('XXX','BUG ')
6671      WRITE(ICOUT,9015)NDIGI,XDIGI
6672 9015 FORMAT('NDIGI,XDIGI = ',I8,E15.7)
6673      CALL DPWRST('XXX','BUG ')
6674 9090 CONTINUE
6675C
6676      RETURN
6677      END
6678      SUBROUTINE COMOVE(X,Y,N,IWRITE,XYCOMO,IBUGA3,IERROR)
6679C
6680C     PURPOSE--THIS SUBROUTINE COMPUTES THE
6681C              SAMPLE (LEIGH-PERLMAN) COMOVEMENT COEFFICIENT
6682C              BETWEEN THE 2 SETS OF DATA IN THE INPUT VECTORS X AND Y.
6683C              THE SAMPLE COMOVEMENT COEFFICIENT WILL BE A SINGLE
6684C              PRECISION VALUE CALCULATED AS THE
6685C              SUM OF CROSS PRODUCTS DIVIDED BY (N-1).
6686C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
6687C                                (UNSORTED) OBSERVATIONS
6688C                                WHICH CONSTITUTE THE FIRST SET
6689C                                OF DATA.
6690C                     --Y      = THE SINGLE PRECISION VECTOR OF
6691C                                (UNSORTED) OBSERVATIONS
6692C                                WHICH CONSTITUTE THE SECOND SET
6693C                                OF DATA.
6694C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
6695C                                IN THE VECTOR X, OR EQUIVALENTLY,
6696C                                THE INTEGER NUMBER OF OBSERVATIONS
6697C                                IN THE VECTOR Y.
6698C     OUTPUT ARGUMENTS--XYCOMO = THE SINGLE PRECISION VALUE OF THE
6699C                                COMPUTED SAMPLE COMOVEMENT COEFFICIENT
6700C                                BETWEEN THE 2 SETS OF DATA
6701C                                IN THE INPUT VECTORS X AND Y.
6702C                                THIS SINGLE PRECISION VALUE
6703C                                WILL BE BETWEEN -1.0 AND 1.0
6704C                                (INCLUSIVELY).
6705C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
6706C             SAMPLE COMOVEMENT COEFFICIENT BETWEEN THE 2 SETS
6707C             OF DATA IN THE INPUT VECTORS X AND Y.
6708C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
6709C                   OF N FOR THIS SUBROUTINE.
6710C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
6711C     FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT.
6712C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
6713C     LANGUAGE--ANSI FORTRAN (1977)
6714C     REFERENCES--AN INDEX FOR COMOVEMENT OF TIME SEQUENCES
6715C                 WITH GEOPHYSICAL APPLICATIONS:  A WORKING PAPER
6716C                 (PENN STATE INTERFACE CONFERANCE ON ASTRONOMY
6717C                 AUGUST 11-14, 1991)
6718C     WRITTEN BY--JAMES J. FILLIBEN
6719C                 STATISTICAL ENGINEERING DIVISION
6720C                 INFORMATION TECHNOLOGY LABORATORY
6721C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
6722C                 GAITHERSBURG, MD 20899
6723C                 PHONE--301-975-2855
6724C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
6725C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
6726C     LANGUAGE--ANSI FORTRAN (1966)
6727C     VERSION NUMBER--92/8
6728C     ORIGINAL VERSION--AUGUST    1991.
6729C
6730C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
6731C
6732      CHARACTER*4 IWRITE
6733      CHARACTER*4 IBUGA3
6734      CHARACTER*4 IERROR
6735C
6736      CHARACTER*4 ISUBN1
6737      CHARACTER*4 ISUBN2
6738C
6739C---------------------------------------------------------------------
6740C
6741      DOUBLE PRECISION DN
6742      DOUBLE PRECISION DXI
6743      DOUBLE PRECISION DXIM1
6744      DOUBLE PRECISION DYI
6745      DOUBLE PRECISION DYIM1
6746      DOUBLE PRECISION DDELX
6747      DOUBLE PRECISION DDELY
6748      DOUBLE PRECISION DSUMX
6749      DOUBLE PRECISION DSUMY
6750      DOUBLE PRECISION DSUMXY
6751      DOUBLE PRECISION DSQRTX
6752      DOUBLE PRECISION DSQRTY
6753C
6754      DIMENSION X(*)
6755      DIMENSION Y(*)
6756C
6757C---------------------------------------------------------------------
6758C
6759      INCLUDE 'DPCOP2.INC'
6760C
6761C-----START POINT-----------------------------------------------------
6762C
6763      ISUBN1='COMO'
6764      ISUBN2='VE  '
6765C
6766      IERROR='NO'
6767C
6768      DN=0.0D0
6769      DSUMX=0.0D0
6770      DSUMY=0.0D0
6771      DSUMXY=0.0D0
6772C
6773      IF(IBUGA3.EQ.'OFF')GOTO90
6774      WRITE(ICOUT,999)
6775  999 FORMAT(1X)
6776      CALL DPWRST('XXX','BUG ')
6777      WRITE(ICOUT,51)
6778   51 FORMAT('***** AT THE BEGINNING OF COMOVE--')
6779      CALL DPWRST('XXX','BUG ')
6780      WRITE(ICOUT,52)IBUGA3
6781   52 FORMAT('IBUGA3 = ',A4)
6782      CALL DPWRST('XXX','BUG ')
6783      WRITE(ICOUT,53)N
6784   53 FORMAT('N = ',I8)
6785      CALL DPWRST('XXX','BUG ')
6786      DO55I=1,N
6787      WRITE(ICOUT,56)I,X(I),Y(I)
6788   56 FORMAT('I,X(I),Y(I) = ',I8,2E15.7)
6789      CALL DPWRST('XXX','BUG ')
6790   55 CONTINUE
6791   90 CONTINUE
6792C
6793C               *******************************************
6794C               **  COMPUTE     COMOVEMENT COEFFICIENT  **
6795C               *******************************************
6796C
6797C               ********************************************
6798C               **  STEP 1--                              **
6799C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
6800C               ********************************************
6801C
6802      AN=N
6803C
6804      IF(N.GE.2)GOTO119
6805      IERROR='YES'
6806      WRITE(ICOUT,999)
6807      CALL DPWRST('XXX','BUG ')
6808      WRITE(ICOUT,111)
6809  111 FORMAT('***** ERROR IN COMOVE--')
6810      CALL DPWRST('XXX','BUG ')
6811      WRITE(ICOUT,112)
6812  112 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
6813      CALL DPWRST('XXX','BUG ')
6814      WRITE(ICOUT,113)
6815  113 FORMAT('      IN THE VARIABLE FOR WHICH')
6816      CALL DPWRST('XXX','BUG ')
6817      WRITE(ICOUT,114)
6818  114 FORMAT('      THE COMOVEMENT COEFFICIENT IS TO BE')
6819      CALL DPWRST('XXX','BUG ')
6820      WRITE(ICOUT,115)
6821  115 FORMAT('      COMPUTED, MUST BE 2 OR LARGER.')
6822      CALL DPWRST('XXX','BUG ')
6823      WRITE(ICOUT,116)
6824  116 FORMAT('      SUCH WAS NOT THE CASE HERE.')
6825      CALL DPWRST('XXX','BUG ')
6826      WRITE(ICOUT,117)N
6827  117 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
6828     1'.')
6829      CALL DPWRST('XXX','BUG ')
6830      GOTO9000
6831  119 CONTINUE
6832C
6833      IF(N.EQ.2)GOTO120
6834      GOTO129
6835  120 CONTINUE
6836      WRITE(ICOUT,999)
6837      CALL DPWRST('XXX','BUG ')
6838      WRITE(ICOUT,121)
6839  121 FORMAT('***** NON-FATAL DIAGNOSTIC IN COMOVE--',
6840     1'THE THIRD INPUT ARGUMENT (N) HAS THE VALUE 2')
6841      CALL DPWRST('XXX','BUG ')
6842      XYCOMO=1.0
6843      GOTO9000
6844  129 CONTINUE
6845C
6846      HOLD=X(1)
6847      DO135I=2,N
6848      IF(X(I).NE.HOLD)GOTO139
6849  135 CONTINUE
6850      WRITE(ICOUT,999)
6851      CALL DPWRST('XXX','BUG ')
6852      WRITE(ICOUT,136)HOLD
6853  136 FORMAT('***** NON-FATAL DIAGNOSTIC IN COMOVE--',
6854     1'THE FIRST  INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
6855      CALL DPWRST('XXX','BUG ')
6856      XYCOMO=1.0
6857      GOTO9000
6858  139 CONTINUE
6859C
6860      HOLD=Y(1)
6861      DO145I=2,N
6862      IF(Y(I).NE.HOLD)GOTO149
6863  145 CONTINUE
6864      WRITE(ICOUT,999)
6865      CALL DPWRST('XXX','BUG ')
6866      WRITE(ICOUT,146)HOLD
6867  146 FORMAT('***** NON-FATAL DIAGNOSTIC IN COMOVE--',
6868     1'THE SECOND INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
6869      CALL DPWRST('XXX','BUG ')
6870      XYCOMO=1.0
6871      GOTO9000
6872  149 CONTINUE
6873C
6874C               ************************************************
6875C               **  STEP 2--                                  **
6876C               **  COMPUTE THE     COMOVEMENT COEFFICIENT.  **
6877C               ************************************************
6878C
6879      DN=N
6880      DSUMX=0.0D0
6881      DSUMY=0.0D0
6882      DSUMXY=0.0D0
6883      DO300I=2,N
6884      IM1=I-1
6885      DXI=X(I)
6886      DXIM1=X(IM1)
6887      DDELX=DXI-DXIM1
6888      DYI=Y(I)
6889      DYIM1=Y(IM1)
6890      DDELY=DYI-DYIM1
6891      DSUMX=DSUMX+DDELX**2
6892      DSUMY=DSUMY+DDELY**2
6893      DSUMXY=DSUMXY+DDELX*DDELY
6894  300 CONTINUE
6895      DSQRTX=0.0
6896      IF(DSUMX.GT.0.0D0)DSQRTX=DSQRT(DSUMX)
6897      DSQRTY=0.0
6898      IF(DSUMY.GT.0.0D0)DSQRTY=DSQRT(DSUMY)
6899      XYCOMO=DSUMXY/(DSQRTX*DSQRTY)
6900C
6901C               *******************************
6902C               **  STEP 3--                 **
6903C               **  WRITE OUT A LINE         **
6904C               **  OF SUMMARY INFORMATION.  **
6905C               *******************************
6906C
6907      IF(IFEEDB.EQ.'OFF')GOTO890
6908      IF(IWRITE.EQ.'OFF')GOTO890
6909      WRITE(ICOUT,999)
6910      CALL DPWRST('XXX','BUG ')
6911      WRITE(ICOUT,811)N,XYCOMO
6912  811 FORMAT('THE LEIGH-PERLMAN COMOVEMENT COEF. OF THE ',
6913     1I8,' OBSERV. = ',E15.7)
6914      CALL DPWRST('XXX','BUG ')
6915  890 CONTINUE
6916C
6917C               *****************
6918C               **  STEP 90--  **
6919C               **  EXIT.      **
6920C               *****************
6921C
6922 9000 CONTINUE
6923      IF(IBUGA3.EQ.'OFF')GOTO9090
6924      WRITE(ICOUT,999)
6925      CALL DPWRST('XXX','BUG ')
6926      WRITE(ICOUT,9011)
6927 9011 FORMAT('***** AT THE END       OF COV--')
6928      CALL DPWRST('XXX','BUG ')
6929      WRITE(ICOUT,9012)IBUGA3,IERROR
6930 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
6931      CALL DPWRST('XXX','BUG ')
6932      WRITE(ICOUT,9013)N
6933 9013 FORMAT('N = ',I8)
6934      CALL DPWRST('XXX','BUG ')
6935      WRITE(ICOUT,9014)DN,DSUMX,DSUMY,DSUMXY
6936 9014 FORMAT('DN,DSUMX,DSUMY,DSUMXY = ',4D15.7)
6937      CALL DPWRST('XXX','BUG ')
6938      WRITE(ICOUT,9015)XYCOMO
6939 9015 FORMAT('XYCOMO = ',E15.7)
6940      CALL DPWRST('XXX','BUG ')
6941 9090 CONTINUE
6942C
6943      RETURN
6944      END
6945      SUBROUTINE COMPIC(IFUNC1,N1,IOLD,IOLD2,INEW,INEW2,NCHANG,
6946     1IFUNC2,N2,IBUGA3,IERROR)
6947C
6948C     PURPOSE--SCAN THE FUNCTIONAL EXPRESSION GIVEN IN IFUNC1
6949C              AND CHANGE ALL OCCURRANCES OF
6950C              PARAMETER, VARIABLE, FUNCTION, AND
6951C              NUMBERS GIVEN IN IOLD BY THE CORRESPONDING
6952C              STRINGS GIVEN IN INEW.
6953C     NOTE--IT IS ASSUMED THAT NAMES ARE
6954C           ALREADY IN THE FORM OF A4--THAT IS
6955C           INDIVIDUALLY PACKED PER WORD.
6956C     NOTE--NUMBERS MAY NOT BE CHANGED.
6957C     NOTE--PARAMETERS MAY BE CHANGED TO NUMBERS
6958C           BUT ONLY THE FIRST 8 CHARACTERS OF THE NUMBER WILL
6959C           BE TRANSFERRED.
6960C     WRITTEN BY--JAMES J. FILLIBEN
6961C                 STATISTICAL ENGINEERING DIVISION
6962C                 INFORMATION TECHNOLOGY LABORATORY
6963C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
6964C                 GAITHERSBURG, MD 20899
6965C                 PHONE--301-975-2855
6966C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
6967C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
6968C     LANGUAGE--ANSI FORTRAN (1977)
6969C     VERSION NUMBER--82/7
6970C     ORIGINAL VERSION--JANUARY   1979.
6971C     UPDATED         --FEBRUARY  1979.
6972C     UPDATED         --JULY      1981.
6973C     UPDATED         --MAY       1982.
6974C
6975C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
6976C
6977      CHARACTER*4 IFUNC1
6978      CHARACTER*4 IOLD
6979      CHARACTER*4 IOLD2
6980      CHARACTER*4 INEW
6981      CHARACTER*4 INEW2
6982      CHARACTER*4 IFUNC2
6983      CHARACTER*4 IBUGA3
6984      CHARACTER*4 IERROR
6985C
6986      CHARACTER*4 ISUBN1
6987      CHARACTER*4 ISUBN2
6988      CHARACTER*4 ISTEPN
6989C
6990      CHARACTER*4 ICH11
6991      CHARACTER*4 ICH12
6992      CHARACTER*4 ICH1
6993      CHARACTER*4 ICH21
6994      CHARACTER*4 ICH22
6995      CHARACTER*4 ICH2
6996      CHARACTER*4 ICASEP
6997      CHARACTER*4 ICASEA
6998      CHARACTER*4 IHALF1
6999      CHARACTER*4 IHALF2
7000C
7001C---------------------------------------------------------------------
7002C
7003      DIMENSION IFUNC1(*)
7004      DIMENSION IFUNC2(*)
7005      DIMENSION IOLD(*)
7006      DIMENSION IOLD2(*)
7007      DIMENSION INEW(*)
7008      DIMENSION INEW2(*)
7009C
7010      DIMENSION ICH11(10)
7011      DIMENSION ICH12(10)
7012      DIMENSION ICH1(20)
7013      DIMENSION ICH21(10)
7014      DIMENSION ICH22(10)
7015      DIMENSION ICH2(20)
7016C
7017C---------------------------------------------------------------------
7018C
7019      INCLUDE 'DPCOP2.INC'
7020C
7021C-----START POINT-----------------------------------------------------
7022C
7023      ISUBN1='COMP'
7024      ISUBN2='IC  '
7025C
7026      IERROR='NO'
7027C
7028      NUMASC=4
7029      NUMAS2=2*NUMASC
7030C
7031      IEND1=0
7032C
7033      IF(IBUGA3.EQ.'OFF')GOTO90
7034      WRITE(ICOUT,999)
7035  999 FORMAT(1X)
7036      CALL DPWRST('XXX','BUG ')
7037      WRITE(ICOUT,51)
7038   51 FORMAT('***** AT THE BEGINNING OF COMPIC--')
7039      CALL DPWRST('XXX','BUG ')
7040      WRITE(ICOUT,52)N1,IBUGA3
7041   52 FORMAT('N1,IBUGA3 = ',I8,2X,A4)
7042      CALL DPWRST('XXX','BUG ')
7043      WRITE(ICOUT,53)(IFUNC1(I),I=1,N1)
7044   53 FORMAT('IFUNC1(.)=',30A4)
7045      CALL DPWRST('XXX','BUG ')
7046      WRITE(ICOUT,54)NCHANG
7047   54 FORMAT('NCHANG = ',I8)
7048      CALL DPWRST('XXX','BUG ')
7049      DO55I=1,NCHANG
7050      WRITE(ICOUT,56)I,IOLD(I),IOLD2(I),INEW(I),INEW2(I)
7051   56 FORMAT('I,IOLD(I),IOLD2(I),INEW(I),INEW2(I) = ',
7052     1I8,2X,A4,A4,2X,A4,A4)
7053      CALL DPWRST('XXX','BUG ')
7054   55 CONTINUE
7055   90 CONTINUE
7056C
7057C               ********************************************
7058C               **  STEP 1--                              **
7059C               **  COPY THE INPUT FUNCTION IN IFUNC1(.)  **
7060C               **  INTO THE OUTPUT VECTOR IFUNC2(.).     **
7061C               ********************************************
7062C
7063      ISTEPN='1'
7064      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7065C
7066      IF(N1.LE.0)GOTO190
7067      DO80I=1,N1
7068      IFUNC2(I)=IFUNC1(I)
7069   80 CONTINUE
7070      N2=N1
7071C
7072C               *****************************************
7073C               **  STEP 2--                           **
7074C               **  LOOP THROUGH THE INPUT FUNCTION--  **
7075C               **  1 CHARACTER (USUALLY) AT A TIME.   **
7076C               *****************************************
7077C
7078      ISTEPN='2'
7079      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7080C
7081      I=0
7082  100 CONTINUE
7083      I=I+1
7084      IF(I.GT.N2)GOTO190
7085      IF(NCHANG.LE.0)GOTO190
7086C
7087C               ******************************************
7088C               **  STEP 3--                            **
7089C               **  FOR THIS CHARACTER (CHARACTER I),   **
7090C               **  SCAN THROUGH ALL POTENTIAL CHANGES  **
7091C               **  TO BE MADE.                         **
7092C               ******************************************
7093C
7094      ISTEPN='3'
7095      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7096C
7097      DO200J=1,NCHANG
7098      CALL DPXH1H(IOLD(J),ICH11,IEND11,IBUGA3)
7099      CALL DPXH1H(IOLD2(J),ICH12,IEND12,IBUGA3)
7100      DO205K=1,NUMAS2
7101      ICH1(K)=' '
7102  205 CONTINUE
7103      L=0
7104      DO206K=1,NUMASC
7105      L=L+1
7106      ICH1(L)=ICH11(K)
7107  206 CONTINUE
7108      DO207K=1,NUMASC
7109      L=L+1
7110      ICH1(L)=ICH12(K)
7111  207 CONTINUE
7112      IEND1=0
7113      IF(IEND11.GE.1)IEND1=IEND11
7114      IF(IEND11.GE.NUMASC)IEND1=NUMASC
7115      IF(IEND12.GE.1)IEND1=NUMASC+IEND12
7116      IF(IEND12.GE.NUMAS2)IEND1=NUMAS2
7117C
7118      IF(IEND1.LE.0)GOTO200
7119C
7120C               *********************************************
7121C               **  STEP 4--                               **
7122C               **  CHECK FOR A LEFT OR RIGHT PARENTHESIS  **
7123C               **  IN THE INPUT CHANGE PATTERN.           **
7124C               *********************************************
7125C
7126      ISTEPN='4'
7127      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7128C
7129      ICASEP='NO'
7130      DO210K=1,IEND1
7131      IF(ICH1(K).EQ.'(')GOTO220
7132      IF(ICH1(K).EQ.')')GOTO220
7133  210 CONTINUE
7134      ICASEP='NO'
7135      GOTO290
7136  220 CONTINUE
7137      ICASEP='YES'
7138  290 CONTINUE
7139C
7140C               ********************************************************
7141C               **  STEP 5--                                          **
7142C               **  STARTING WITH CHARACTER I OF THE INPUT FUNCTION,  **
7143C               **  COMPARE THE STRING IN THE INPUT FUNCTION          **
7144C               **  WITH THIS INPUT CHANGE PATTERN.                   **
7145C               **  DETERMINE IF THERE IS A MATCH.                    **
7146C               ********************************************************
7147C
7148      ISTEPN='5'
7149      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7150C
7151      L1=I-1
7152      DO300K=1,IEND1
7153      L1=L1+1
7154      IF(IFUNC2(L1).EQ.ICH1(K))GOTO300
7155      GOTO200
7156  300 CONTINUE
7157C
7158C               **********************************************
7159C               **  STEP 6--                                **
7160C               **  IF HAVE A MATCH,                        **
7161C               **  CHECK TO SEE IF THE STRING              **
7162C               **  IN THE FUNCTION                         **
7163C               **  IS PRECEDED BY A +, -, *, /, **, (,     **
7164C               **  (OR IS THE FIRST STRING ON THE LINE),   **
7165C               **  AND ALSO                                **
7166C               **  IS SUCCEDED BY A +, -, *, /, **, ),     **
7167C               **  (OR IS THE LAST  STRING ON THE LINE).   **
7168C               **  A FULFILLMENT OF ANY OF THE ABOVE       **
7169C               **  14 CONDITIONS WILL BE SUFFICIENT        **
7170C               **  TO ASSURE THAT INDIVIDUAL MIDDLE        **
7171C               **  CHARACTERS IN LIBRARY FUNCTIONS         **
7172C               **  (E.G., THE 'X' IN 'EXP')                **
7173C               **  AND IN MULTI-CHARACTER VARIABLE NAMES   **
7174C               **  (E.G., THE 'X' IN 'FLUX')               **
7175C               **  WILL NOT BE INADVERTANTLY CHANGED       **
7176C               **  (E.G., BY, SAY, 'FOR X = 3').           **
7177C               **********************************************
7178C
7179      ISTEPN='6'
7180      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7181C
7182      ICASEA='NO'
7183      IHALF1='NO'
7184      IHALF2='NO'
7185C
7186      IM1=I-1
7187      IF(IM1.LE.0)GOTO410
7188      IF(IFUNC2(IM1).EQ.'+')GOTO410
7189      IF(IFUNC2(IM1).EQ.'-')GOTO410
7190      IF(IFUNC2(IM1).EQ.'*')GOTO410
7191      IF(IFUNC2(IM1).EQ.'/')GOTO410
7192      IF(IFUNC2(IM1).EQ.'**')GOTO410
7193      IF(IFUNC2(IM1).EQ.'(')GOTO410
7194      IHALF1='NO'
7195      GOTO419
7196  410 CONTINUE
7197      IHALF1='YES'
7198  419 CONTINUE
7199C
7200      L1P1=L1+1
7201      IF(L1P1.GT.N2)GOTO420
7202      IF(IFUNC2(L1P1).EQ.'+')GOTO420
7203      IF(IFUNC2(L1P1).EQ.'-')GOTO420
7204      IF(IFUNC2(L1P1).EQ.'*')GOTO420
7205      IF(IFUNC2(L1P1).EQ.'/')GOTO420
7206      IF(IFUNC2(L1P1).EQ.'**')GOTO420
7207      IF(IFUNC2(L1P1).EQ.')')GOTO420
7208      IHALF2='NO'
7209      GOTO429
7210  420 CONTINUE
7211      IHALF2='YES'
7212  429 CONTINUE
7213C
7214      ICASEA='NO'
7215      IF(IHALF1.EQ.'YES'.AND.IHALF2.EQ.'YES')ICASEA='YES'
7216C
7217C               *********************************************************
7218C               **  STEP 7--                                           **
7219C               **  IF THE INPUT STRING HAD ANY PARENTHESES,           **
7220C               **     THEN CHANGE ANY MATCHING STRING IN THE FUNCTION.**
7221C               **  IF THE INPUT STRING HAD NO PARENTHESES,            **
7222C               **     THEN CHANGE MATCHING STRINGS IN THE FUNCTION    **
7223C               **     ONLY WHEN THE MATCHING FUNCTION SUBSTRING       **
7224C               **     IS PRECEDED BY A +, -, *, /, **, (,             **
7225C               **     (OR IS THE FIRST STRING ON THE LINE), AND ALSO  **
7226C               **     IS SUCCEDED BY A +, -, *, /, **, ),             **
7227C               **     (OR IS THE LAST  STRING ON THE LINE).           **
7228C               *********************************************************
7229C
7230      ISTEPN='7'
7231      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7232C
7233      IF(ICASEP.EQ.'YES')GOTO590
7234      IF(ICASEP.EQ.'NO'.AND.ICASEA.EQ.'YES')GOTO590
7235      GOTO200
7236  590 CONTINUE
7237C
7238C               **************************************************
7239C               **  STEP 8--                                    **
7240C               **  IF CHANGES ARE TO BE MADE,                  **
7241C               **  EXTRACT THE OUTPUT CHANGE PATTERN           **
7242C               **  CORRESPONDING TO THE INPUT CHANGE PATTERN.  **
7243C               **************************************************
7244C
7245      ISTEPN='8'
7246      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7247C
7248      CALL DPXH1H(INEW(J),ICH21,IEND21,IBUGA3)
7249      CALL DPXH1H(INEW2(J),ICH22,IEND22,IBUGA3)
7250      DO605K=1,NUMAS2
7251      ICH2(K)=' '
7252  605 CONTINUE
7253      L=0
7254      DO606K=1,NUMASC
7255      L=L+1
7256      ICH2(L)=ICH21(K)
7257  606 CONTINUE
7258      DO607K=1,NUMASC
7259      L=L+1
7260      ICH2(L)=ICH22(K)
7261  607 CONTINUE
7262      IEND2=0
7263      IF(IEND21.GE.1)IEND2=IEND21
7264      IF(IEND21.GE.NUMASC)IEND2=NUMASC
7265      IF(IEND22.GE.1)IEND2=NUMASC+IEND21
7266      IF(IEND22.GE.NUMAS2)IEND2=NUMAS2
7267C
7268      IF(IEND2.LE.0)GOTO200
7269C
7270C               ******************************
7271C               **  STEP 9--                **
7272C               **  CARRY OUT THE CHANGES   **
7273C               **  IN THE INPUT FUNCTION.  **
7274C               ******************************
7275C
7276      ISTEPN='9'
7277      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7278C
7279      ISTAR1=I
7280      ISTOP1=ISTAR1+IEND1-1
7281      ISTAR2=1
7282      ISTOP2=ISTAR2+IEND2-1
7283      CALL DPSIRS(IFUNC2,N2,ISTAR1,ISTOP1,ICH2,IEND2,ISTAR2,ISTOP2,
7284     1IBUGA3,IERROR)
7285      I=ISTOP1+(IEND2-IEND1)
7286      GOTO100
7287C
7288  200 CONTINUE
7289      GOTO100
7290C
7291  190 CONTINUE
7292C
7293C               *****************
7294C               **  STEP 90--  **
7295C               **  EXIT       **
7296C               *****************
7297C
7298      IF(IBUGA3.EQ.'ON')THEN
7299        WRITE(ICOUT,999)
7300        CALL DPWRST('XXX','BUG ')
7301        WRITE(ICOUT,9011)
7302 9011   FORMAT('***** AT THE END       OF COMPIC--')
7303        CALL DPWRST('XXX','BUG ')
7304        WRITE(ICOUT,9012)IBUGA3,N1,NCHANG,NUMASC,NUMAS2
7305 9012   FORMAT('IBUGA3,N1,N2,NCHANG,NUMASC,NUMAS2 = ',A4,2X,5I8)
7306        CALL DPWRST('XXX','BUG ')
7307        WRITE(ICOUT,9013)(IFUNC1(I),I=1,N1)
7308 9013   FORMAT('IFUNC1(.)=',30A4)
7309        CALL DPWRST('XXX','BUG ')
7310        DO9015I=1,NCHANG
7311          WRITE(ICOUT,9016)I,IOLD(I),IOLD2(I),INEW(I),INEW2(I)
7312 9016     FORMAT('I,IOLD(I),IOLD2(I),INEW(I),INEW2(I) = ',
7313     1           I8,2X,2A4,2X,2A4)
7314          CALL DPWRST('XXX','BUG ')
7315 9015   CONTINUE
7316        WRITE(ICOUT,9018)(IFUNC2(I),I=1,N2)
7317 9018   FORMAT('IFUNC2(.)=',30A4)
7318        CALL DPWRST('XXX','BUG ')
7319        WRITE(ICOUT,9020)IEND11,IEND12,IEND1,IEND21,IEND22,IEND2
7320 9020   FORMAT('IEND11,IEND12,IEND1,IEND21,IEND22,IEND2 = ',6I8)
7321        CALL DPWRST('XXX','BUG ')
7322        WRITE(ICOUT,9021)(ICH11(I),I=1,10)
7323 9021   FORMAT('(ICH11(I),I=1,10) = ',10A1)
7324        CALL DPWRST('XXX','BUG ')
7325        WRITE(ICOUT,9022)(ICH12(I),I=1,10)
7326 9022   FORMAT('(ICH12(I),I=1,10) = ',10A1)
7327        CALL DPWRST('XXX','BUG ')
7328        WRITE(ICOUT,9023)(ICH1 (I),I=1,10)
7329 9023   FORMAT('(ICH1 (I),I=1,10) = ',10A1)
7330        CALL DPWRST('XXX','BUG ')
7331        WRITE(ICOUT,9024)(ICH21(I),I=1,10)
7332 9024   FORMAT('(ICH21(I),I=1,10) = ',10A1)
7333        CALL DPWRST('XXX','BUG ')
7334        WRITE(ICOUT,9025)(ICH22(I),I=1,10)
7335 9025   FORMAT('(ICH22(I),I=1,10) = ',10A1)
7336        CALL DPWRST('XXX','BUG ')
7337        WRITE(ICOUT,9026)(ICH2 (I),I=1,10)
7338 9026   FORMAT('(ICH2 (I),I=1,10) = ',10A1)
7339        CALL DPWRST('XXX','BUG ')
7340      ENDIF
7341C
7342      RETURN
7343      END
7344      SUBROUTINE COMPID(IA,NUMCHA,IPASS,PARAM,IPARN1,IPARN2,NUMPAR,
7345     1IVARN1,IVARN2,NUMVAR,
7346     1IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,ID,NUMCHD,
7347     1IBUGCO,IBUGEV,ISUBRO,IERROR)
7348C
7349C     PURPOSE--THIS SUBROUTINE DETERMINES THE DERIVATIVE OF
7350C              A FORTRAN MATHEMATICAL FUNCTION EXPRESSION.
7351C     NOTE--TYPICALLY THIS SUBROUTINE IS CALLED ONLY
7352C           WITH IPASS=2; IN SUCH CASE,
7353C           IPARN1(.) AND NUMPAR ARE NEVER DETERMINED,
7354C           NEEDED, OR OUTPUTTED.
7355C           (NOTE--THERE EXISTS POSSIBLE DIFFERENCES WITH NUMPAR
7356C           AS DEFINED FOR THIS SUBROUTINE
7357C           AS OPPOSED TO THE DEFINITION FOR COMPID).
7358C     INPUT  ARGUMENTS--IA     = THE HOLLARITH VECTOR WHICH CONTAINS
7359C                                THE FUNCTION OF INTEREST
7360C                                FOR WHICH THE ANALYTIC DERIVATIVE
7361C                                IS TO BE DETERMINED.
7362C                                IA(.) MAY BE EITHER UNPACKED (1 CHARACTER PER W
7363C                                OR PACKED (4 CHARACTERS PER WORD)
7364C                                ALTHOUGH THE USUAL REPRESENTATION IS UNPACKED.
7365C                     --NUMCHA = THE INTEGER VALUE WHICH
7366C                                DEFINES THE NUMBER OF CHARACTERS IN IA.
7367C                                NUMCHA DEFINES THE LENGTH OF THE
7368C                                HOLLARITH STRING TO BE OPERATED ON.
7369C                     --IPASS  = AN INTEGER FLAG CODE
7370C                                WHICH DEFINES WHICH PASS (1 OR 2) INTO THIS
7371C                                SUBROUTINE THE USER IS IN.
7372C                                PASS 1 DETERMINE PARAMETER NAMES;
7373C                                PASS 2 DOES FUNCTION EVALUATIONS.
7374C                     --PARAM  = THE SINGLE PRECISION VECTOR OF PARAMETER
7375C                                (AND VARIABLE)
7376C                                VALUES CORRESPONDING TO THE PARAMETER NAMES
7377C                                AS GIVEN IN THE VECTOR IPARN1.
7378C                     --IPARN1 = THE INTEGER VECTOR OF PARAMETER
7379C                                (AND VARIABLE)
7380C                                NAMES AS TYPICALLY DETERMINED BY PASS 1.
7381C     OUTPUT ARGUMENTS--ID     = THE HOLLARITH VECTOR WHICH CONTAINS
7382C                                THE DESIRED DERIVATIVE FUNCTION.
7383C                                ID(.) IS UNPACKED (THAT IS,
7384C                                1 CHARACTER PER WORD).
7385C                     --NUMCHD = THE INTEGER VALUE WHICH
7386C                                DEFINES THE NUMBER OF CHARACTERS IN ID.
7387C                                NUMCHD DEFINES THE LENGTH OF THE
7388C                                HOLLARITH STRING FOR THE DERIVATIVE FUNCTION.
7389C     OUTPUT--THE SINGLE PRECISION COMPUTED SCALAR VALUE,
7390C     PRINTING--NONE.
7391C     RESTRICTIONS--NONE.
7392C     OTHER           SUBROUTINES NEEDED--EVAL
7393C     FORTRAN LIBRARY SUBROUTINES NEEDED--(ALL IN EVAL)
7394C                                         SQRT
7395C                                         EXP
7396C                                         LOG
7397C                                         LOG10
7398C                                         SIN
7399C                                         COS
7400C                                         ATAN
7401C                                         ATAN2
7402C                                         TANH
7403C                                         ABS
7404C                                         AINT
7405C                                         ARCSIN
7406C                                         ARCCOS
7407C                                         ARCTAN
7408C                                         OCTAL
7409C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
7410C     LANGUAGE--ANSI FORTRAN.
7411C     NOTE--THIS SUBROUTINE ALLOWS ONE TO PERFORM
7412C           INTERACTIVE FUNCTION EVALUATIONS.
7413C     REFERENCES--NONE.
7414C     WRITTEN BY--JAMES J. FILLIBEN
7415C                 STATISTICAL ENGINEERING LABORATORY (205.03)
7416C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
7417C                 GAITHERSBURG, MD 20899
7418C                 PHONE:  301-921-2315
7419C     ORIGINAL VERSION--DECEMBER  1978.
7420C     UPDATED         --JANUARY   1979.
7421C     UPDATED         --JANUARY   1981.
7422C     UPDATED         --APRIL     1986.
7423C
7424      CHARACTER*4 IA
7425      CHARACTER*4 IPARN1
7426      CHARACTER*4 IPARN2
7427      CHARACTER*4 IVARN1
7428      CHARACTER*4 IVARN2
7429      CHARACTER*4 IANGLU
7430      CHARACTER*4 ITYPEH
7431      CHARACTER*4 IW21HO
7432      CHARACTER*4 IW22HO
7433      CHARACTER*4 IBUGCO
7434      CHARACTER*4 IBUGEV
7435      CHARACTER*4 IERROR
7436C
7437      CHARACTER*4 ISUBN1
7438      CHARACTER*4 ISUBN2
7439      CHARACTER*4 ISTEPN
7440C
7441      CHARACTER*4 IR
7442      CHARACTER*4 IB
7443      CHARACTER*4 IL
7444      CHARACTER*4 ICH
7445      CHARACTER*4 IW21
7446      CHARACTER*4 IW22
7447      CHARACTER*4 ITYPE
7448      CHARACTER*4 IANS1
7449      CHARACTER*4 IANS2
7450      CHARACTER*4 IANS3
7451      CHARACTER*4 IANS4
7452      CHARACTER*4 ISUBRO
7453      CHARACTER*4 IFOUND
7454CCCCC CHARACTER*4 IBUG0
7455CCCCC CHARACTER*4 IBUG1
7456CCCCC CHARACTER*4 IBUG2
7457CCCCC CHARACTER*4 IBUG3
7458CCCCC CHARACTER*4 IBUG4
7459CCCCC CHARACTER*4 IBUG5
7460CCCCC CHARACTER*4 IBUG6
7461CCCCC CHARACTER*4 IBUG7
7462CCCCC CHARACTER*4 IBUGXH
7463CCCCC CHARACTER*4 IBUGCD
7464C
7465      CHARACTER*4 ID
7466      CHARACTER*4 ID1
7467      CHARACTER*4 ID2
7468      CHARACTER*4 ID3
7469      CHARACTER*4 ICON
7470C
7471C---------------------------------------------------------------------
7472C
7473      DIMENSION IA(*)
7474      DIMENSION PARAM(*)
7475      DIMENSION IPARN1(*)
7476      DIMENSION IPARN2(*)
7477C
7478      DIMENSION IVARN1(*)
7479      DIMENSION IVARN2(*)
7480C
7481      DIMENSION ID(*)
7482C
7483C     NOTE--THE DIMENSIONS OF ITYPEH, IW21HO, IW22HO, AND W2HOLD
7484C           WHICH ARE DEFINED IN THE MAIN PROGRAM
7485C           SHOULD BE AT LEAST AS LARGE AS THE DIMENSIONS
7486C           OF IW21 AND IW22 BELOW.
7487C
7488      DIMENSION ITYPEH(*)
7489      DIMENSION IW21HO(*)
7490      DIMENSION IW22HO(*)
7491      DIMENSION W2HOLD(*)
7492C
7493CCCCC DIMENSION IB(225)
7494CCCCC DIMENSION IR(225)
7495CCCCC DIMENSION IBEGIN(225)
7496CCCCC DIMENSION IEND(225)
7497CCCCC DIMENSION ITYPE(225)
7498CCCCC DIMENSION IW21(225)
7499CCCCC DIMENSION IW22(225)
7500CCCCC DIMENSION W2(225)
7501      DIMENSION IB(1000)
7502      DIMENSION IR(1000)
7503      DIMENSION IBEGIN(1000)
7504      DIMENSION IEND(1000)
7505      DIMENSION ITYPE(1000)
7506      DIMENSION IW21(1000)
7507      DIMENSION IW22(1000)
7508      DIMENSION W2(1000)
7509C
7510      DIMENSION ID1(250)
7511      DIMENSION ID2(250)
7512      DIMENSION ID3(250)
7513C
7514      DIMENSION ICH(10)
7515C
7516      DIMENSION IL(10)
7517C
7518      DIMENSION ICON(1000)
7519      DIMENSION ICON1(50)
7520      DIMENSION ICON2(50)
7521C
7522C-----COMMON VARIABLES (GENERAL)-----------------------------------------------
7523C
7524      INCLUDE 'DPCOP2.INC'
7525C
7526C-----DATA STATEMENTS-----------------------------------------------------
7527C
7528CCCCC DATA IBUG0/'OFF'/
7529CCCCC DATA IBUG1/'OFF'/
7530CCCCC DATA IBUG2/'OFF'/
7531CCCCC DATA IBUG3/'OFF'/
7532CCCCC DATA IBUG4/'OFF'/
7533CCCCC DATA IBUG5/'OFF'/
7534CCCCC DATA IBUG6/'OFF'/
7535CCCCC DATA IBUG7/'OFF'/
7536CCCCC DATA IBUGXH/'OFF'/
7537CCCCC DATA IBUGCD/'OFF'/
7538C
7539C     DEFINE THE UPPER LIMIT OF THE NUMBER OF CHARACTERS
7540C     THAT MAY BE PROCESSED BY THIS SUBROUTINE
7541C     (COUNTING BLANKS, LEFT-HAND SIDE, EQUAL SIGN,
7542C     AND RIGHT HAND SIDE).
7543C     IF RESTRICT THE EXPRESSION TO 1 LINE IMAGE,
7544C     THEN A REASONABLE UPPER BOUND IS 80.
7545C     WHATEVER UPPER BOUND IS SET,
7546C     THE DIMENSIONS OF MOST OF THE VECTORS
7547C     MUST BE EQUAL OR LARGER TO THIS NUMBER.
7548C     (THE VECTOR IL(.) WHICH CONTAINS THE
7549C     NUMBER OF CHARACTERS TO THE LEFT
7550C     OF THE EQUAL SIGN (BLANKS IGNORED)
7551C     MAY BE MUCH SMALLER--LIKE 6.)
7552C     NOTE--AS OF JANUARY 1979, THE BOUND WAS RESET TO 150.
7553C
7554CCCCC DATA MAXCHA/150/
7555CCCCC DATA MAXCHA/225/
7556      DATA MAXCHA/1000/
7557C
7558C-----START POINT-----------------------------------------------------
7559C
7560      ISUBN1='COMP'
7561      ISUBN2='ID  '
7562C
7563      IERROR='NO  '
7564C
7565C     THE FOLLOWING STATEMENT (N=1) HAS BEEN ADDED
7566C     IN CONVERTING THE COMPIL SUBROUTINE
7567C     TO THE COMPID SUBROUTINE.
7568C
7569      N=1
7570C
7571      IF(IBUGCO.EQ.'OFF'.AND.ISUBRO.NE.'MPID')GOTO90
7572      WRITE(ICOUT,999)
7573  999 FORMAT(1X)
7574      CALL DPWRST('XXX','BUG ')
7575      WRITE(ICOUT,51)
7576   51 FORMAT('***** AT THE BEGINNING OF COMPID--')
7577      CALL DPWRST('XXX','BUG ')
7578      WRITE(ICOUT,52)NUMCHA,N,IPASS,IANGLU
7579   52 FORMAT('NUMCHA,N,IPASS,IANGLU = ',3I8,2X,A4)
7580      CALL DPWRST('XXX','BUG ')
7581      WRITE(ICOUT,53)(IA(I),I=1,NUMCHA)
7582   53 FORMAT('IA--',80A1)
7583      CALL DPWRST('XXX','BUG ')
7584      WRITE(ICOUT,54)IBUGCO,IBUGEV
7585   54 FORMAT('IBUGCO,IBUGEV = ',A4,2X,A4)
7586      CALL DPWRST('XXX','BUG ')
7587      WRITE(ICOUT,999)
7588      CALL DPWRST('XXX','BUG ')
7589      WRITE(ICOUT,61)NUMPAR
7590   61 FORMAT('NUMPAR = ',I8)
7591      CALL DPWRST('XXX','BUG ')
7592      IF(NUMPAR.LE.0)GOTO64
7593      DO62I=1,NUMPAR
7594      WRITE(ICOUT,63)I,IPARN1(I),IPARN2(I),PARAM(I)
7595   63 FORMAT('I,IPARN1(I),IPARN2(I),PARAM(I) = ',I8,2X,A4,2X,A4,2X,
7596     1E15.7)
7597      CALL DPWRST('XXX','BUG ')
7598   62 CONTINUE
7599   64 CONTINUE
7600      WRITE(ICOUT,999)
7601      CALL DPWRST('XXX','BUG ')
7602      WRITE(ICOUT,65)NUMVAR
7603   65 FORMAT('NUMVAR = ',I8)
7604      CALL DPWRST('XXX','BUG ')
7605      IF(NUMVAR.LE.0)GOTO69
7606      DO66I=1,NUMVAR
7607      WRITE(ICOUT,67)I,IVARN1(I),IVARN2(I)
7608   67 FORMAT('I,IVARN1(I),IVARN2(I) = ',I8,2X,A4,2X,A4)
7609      CALL DPWRST('XXX','BUG ')
7610   66 CONTINUE
7611   69 CONTINUE
7612      WRITE(ICOUT,999)
7613      CALL DPWRST('XXX','BUG ')
7614      WRITE(ICOUT,71)NWHOLD
7615   71 FORMAT('NWHOLD = ',I8)
7616      CALL DPWRST('XXX','BUG ')
7617      IF(NWHOLD.LE.0)GOTO79
7618      DO72I=1,NWHOLD
7619      WRITE(ICOUT,73)I,ITYPEH(I),IW21HO(I),IW22HO(I),W2HOLD(I)
7620   73 FORMAT('I,ITYPEH(I),IW21HO(I),IW22HO(I),W2HOLD(I) = ',
7621     1I8,2X,A4,2X,A4,2X,A4,2X,E15.7)
7622      CALL DPWRST('XXX','BUG ')
7623   72 CONTINUE
7624   79 CONTINUE
7625   90 CONTINUE
7626C
7627C               ************************************************************
7628C               **  DEFINE NUMASC = NUMBER OF ASCII CHARACTERS PER WORD.  **
7629C               **  THIS IS 4 REGARDLESS OF THE COMPUTER MAKE AND         **
7630C               **  REGARDLESS OF THE WORD SIZE.                          **
7631C               ************************************************************
7632C
7633      NUMASC=4
7634      NUMAS2=2*NUMASC
7635      NUMAS3=3*NUMASC
7636      NUMAS4=4*NUMASC
7637C
7638C     CHECK THAT THE INPUT NUMBER OF CHARACTERS NUMCHA
7639C     (INCLUDING LEFT SIDE, RIGHT SIDE, EQUAL SIGN,
7640C     AND BLANKS) IS AT LEAST 1 AND AT MOST MAXCHA
7641C     (WHERE MAXCHA IS THE INTERNALLY DEFINED VARIABLE
7642C     WHICH CONTROLS DIMENSION SIZES AND WHICH
7643C     TYPICALLY HAS THE VALUE 80).
7644C
7645      IF(1.LE.NUMCHA.AND.NUMCHA.LE.MAXCHA)GOTO139
7646      WRITE(ICOUT,121)
7647  121 FORMAT('***** ERROR IN COMPID--')
7648      CALL DPWRST('XXX','BUG ')
7649      WRITE(ICOUT,122)
7650  122 FORMAT('      THE NUMBER OF CHARACTERS NUMCHA ')
7651      CALL DPWRST('XXX','BUG ')
7652      WRITE(ICOUT,123)
7653  123 FORMAT('      WHICH DEFINES THE LENGTH OF THE ')
7654      CALL DPWRST('XXX','BUG ')
7655      WRITE(ICOUT,124)
7656  124 FORMAT('      INPUT EXPRESSION (INCLUDING LEFT-HAND SIDE,')
7657      CALL DPWRST('XXX','BUG ')
7658      WRITE(ICOUT,125)
7659  125 FORMAT('      RIGHT-HAND SIDE, EQUAL SIGN, AND ALL BLANKS)')
7660      CALL DPWRST('XXX','BUG ')
7661      WRITE(ICOUT,126)
7662  126 FORMAT('      IS SMALLER THAN 1 OR LARGER THAN MAXCHA')
7663      CALL DPWRST('XXX','BUG ')
7664      WRITE(ICOUT,127)
7665  127 FORMAT('      (MAXCHA IS AN INTERNALLY-DEFINED VARIABLE')
7666      CALL DPWRST('XXX','BUG ')
7667      WRITE(ICOUT,128)MAXCHA
7668  128 FORMAT('      WHICH HAS THE VALUE = ',I8,'   .')
7669      CALL DPWRST('XXX','BUG ')
7670      WRITE(ICOUT,129)
7671  129 FORMAT('      THE NUMBER OF CHARACTERS IN THE')
7672      CALL DPWRST('XXX','BUG ')
7673      WRITE(ICOUT,130)NUMCHA
7674  130 FORMAT('      INPUT EXPRESSION IS ',I8)
7675      CALL DPWRST('XXX','BUG ')
7676      IF(NUMCHA.GE.1)WRITE(ICOUT,131)(IA(I),I=1,NUMCHA)
7677  131 FORMAT('      INPUT EXPRESSION--',100A1)
7678      IF(NUMCHA.GE.1)CALL DPWRST('XXX','BUG ')
7679      IERROR='YES '
7680      GOTO9000
7681  139 CONTINUE
7682C
7683C     BLANK-OUT AND ZERO-OUT SOME VARIABLES AND VECTORS.
7684C
7685CCCCC Y=0.0
7686      IC2=0
7687C
7688      DO160I=1,NUMCHA
7689      IR(I)='    '
7690      IB(I)='    '
7691      IW21(I)='    '
7692      IW22(I)='    '
7693      W2(I)=0.0
7694      ITYPE(I)='    '
7695      IW21HO(I)='    '
7696      IW22HO(I)='    '
7697      W2HOLD(I)=0.0
7698      ITYPEH(I)='    '
7699      ID1(I)='    '
7700      ID2(I)='    '
7701      ID3(I)='    '
7702      ID(I)='    '
7703  160 CONTINUE
7704C
7705C
7706C               ***********************************************
7707C               **  STEP 1--                                 **
7708C               **  OPERATE ON THE VECTOR IA(.).             **
7709C               **  IA(.) MAY BE OPTIONALLY EITHER UNPACKED  **
7710C               **  (1 CHARACTER PER WORD),                  **
7711C               **  OR PACKED                                **
7712C               **  (UP TO 4 CHARACTERS PER WORD).           **
7713C               **  IN ANY EVENT, IB(.) IS UNPACKED.         **
7714C               **  NOTE ALSO THAT IB(.) HAS BLANKS OMITTED. **
7715C               ***********************************************
7716C
7717      ISTEPN='1'
7718      IF(IBUGCO.EQ.'ON'.OR.ISUBRO.EQ.'RIV4')
7719     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7720C
7721      K=0
7722      DO200I=1,NUMCHA
7723      IF(IA(I).EQ.'    ')GOTO200
7724      CALL DPXH1H(IA(I),ICH,ILASTC,IBUGEV)
7725      IF(ILASTC.LE.0)GOTO200
7726      DO250J=1,ILASTC
7727      K=K+1
7728      IB(K)=ICH(J)
7729  250 CONTINUE
7730  200 CONTINUE
7731      NCTOT=K
7732C
7733      IF(NCTOT.GE.1)GOTO290
7734      WRITE(ICOUT,205)NCTOT
7735  205 FORMAT('***** ERROR IN COMPID--TOTAL NUMBER OF CHARACTERS ',
7736     1'IN MODEL (INCL. BOTH SIDES, BLANKS, AND EQUAL SIGN) ',
7737     1'IS < 2.  NCTOT = ',I5)
7738      CALL DPWRST('XXX','BUG ')
7739      WRITE(ICOUT,271)NUMCHA,N,IPASS
7740  271 FORMAT('NUMCHA,N,IPASS = ',3I8)
7741      CALL DPWRST('XXX','BUG ')
7742      WRITE(ICOUT,272)(IA(I),I=1,NUMCHA)
7743  272 FORMAT('IA--',80A1)
7744      CALL DPWRST('XXX','BUG ')
7745C
7746      WRITE(ICOUT,999)
7747      CALL DPWRST('XXX','BUG ')
7748      WRITE(ICOUT,281)NUMPAR
7749  281 FORMAT('NUMPAR = ',I8)
7750      CALL DPWRST('XXX','BUG ')
7751      IF(NUMPAR.LE.0)GOTO289
7752      DO282I=1,NUMPAR
7753      WRITE(ICOUT,283)I,IPARN1(I),IPARN2(I),PARAM(I)
7754  283 FORMAT('I,IPARN1(I),IPARN2(I),PARAM(I) = ',I8,2X,A4,2X,A4,2X,
7755     1E15.7)
7756      CALL DPWRST('XXX','BUG ')
7757  282 CONTINUE
7758  289 CONTINUE
7759      IERROR='YES '
7760      GOTO9000
7761C
7762  290 CONTINUE
7763      IF(IBUGCO.EQ.'OFF'.AND.ISUBRO.NE.'MPID')GOTO299
7764      WRITE(ICOUT,291)NCTOT
7765  291 FORMAT('NCTOT = ',I8)
7766      CALL DPWRST('XXX','BUG ')
7767      DO292I=1,NCTOT
7768      WRITE(ICOUT,293)I,IB(I)
7769  293 FORMAT('I,IB(I) = ',I8,2X,A4)
7770      CALL DPWRST('XXX','BUG ')
7771  292 CONTINUE
7772  299 CONTINUE
7773C
7774C               **************************************************************
7775C               **  STEP 2--                                                **
7776C               **  OPERATE ON THE VECTOR IB(.).                            **
7777C               **  DETERMINE THE NUMBER OF CHARACTERS (IF ANY)             **
7778C               **  FOR THE LEFT-HAND SIDE.  OUTPUT THEM INTO THE           **
7779C               **  VECTOR IL(.).                                           **
7780C               **************************************************************
7781C
7782      DO500I=1,NCTOT
7783      I2=I
7784      IF(IB(I).EQ.'=   ')GOTO550
7785  500 CONTINUE
7786      NCL=0
7787      ISTARR=1
7788      GOTO559
7789  550 CONTINUE
7790      NCL=I2-1
7791      ISTARR=I2+1
7792  559 CONTINUE
7793C
7794      IF(NCL.LE.0)GOTO699
7795      DO600I=1,NCL
7796      IL(I)=IB(I)
7797  600 CONTINUE
7798      IF(IBUGCO.EQ.'OFF'.AND.ISUBRO.NE.'MPID')GOTO699
7799      ISTEPN='2'
7800      CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7801      WRITE(ICOUT,691)NCL
7802  691 FORMAT('NCL = ',2I8)
7803      CALL DPWRST('XXX','BUG ')
7804      DO692I=1,NCL
7805      WRITE(ICOUT,693)I,IL(I)
7806  693 FORMAT('I,IL(I) = ',I8,2X,A4)
7807      CALL DPWRST('XXX','BUG ')
7808  692 CONTINUE
7809  699 CONTINUE
7810C
7811C               ***************************************************************
7812C               **  STEP 3--                                                 **
7813C               **  OPERATE ON THE VECTOR IB(.).                             **
7814C               **  DETERMINE THE NUMBER OF CHARACTERS FOR RIGHT-HAND SIDE.  **
7815C               **  OUTPUT THEM INTO THE VECTOR IR(.).                       **
7816C               ***************************************************************
7817C
7818      IF(ISTARR.LE.NCTOT)GOTO719
7819      WRITE(ICOUT,701)
7820  701 FORMAT('***** ERROR IN COMPID--')
7821      CALL DPWRST('XXX','BUG ')
7822      WRITE(ICOUT,702)
7823  702 FORMAT('      THE NUMBER OF CHARACTERS ON THE RIGHT')
7824      CALL DPWRST('XXX','BUG ')
7825      WRITE(ICOUT,703)
7826  703 FORMAT('      (WITH BLANKS IGNORED) IS 0.')
7827      CALL DPWRST('XXX','BUG ')
7828      WRITE(ICOUT,704)
7829  704 FORMAT('      THE TOTAL NUMBER OF PACKED CHARACTERS   NCTOT')
7830      CALL DPWRST('XXX','BUG ')
7831      WRITE(ICOUT,705)
7832  705 FORMAT('      LEFT (IF ANY), EQUAL SIGN (IF ANY), AND RIGHT')
7833      CALL DPWRST('XXX','BUG ')
7834      WRITE(ICOUT,706)NCTOT
7835  706 FORMAT('      = ',I8)
7836      CALL DPWRST('XXX','BUG ')
7837      WRITE(ICOUT,707)
7838  707 FORMAT('      THE START POSITION FOR THE PACKED RIGHT')
7839      CALL DPWRST('XXX','BUG ')
7840      WRITE(ICOUT,708)ISTARR
7841  708 FORMAT('      IS COLUMN ',I8)
7842      CALL DPWRST('XXX','BUG ')
7843      WRITE(ICOUT,709)NUMCHA
7844  709 FORMAT('      THE INPUT NUMBER OF CHARACTERS NUMCHA = ',I8)
7845      CALL DPWRST('XXX','BUG ')
7846      IF(NUMCHA.GE.1)WRITE(ICOUT,710)(IA(I),I=1,NUMCHA)
7847  710 FORMAT('      INPUT EXPRESSION--',100A1)
7848      IF(NUMCHA.GE.1)CALL DPWRST('XXX','BUG ')
7849      IERROR='YES '
7850      GOTO9000
7851  719 CONTINUE
7852C
7853      K=0
7854      DO700I=ISTARR,NCTOT
7855      K=K+1
7856      IR(K)=IB(I)
7857  700 CONTINUE
7858      NCR=K
7859C
7860      IF(IBUGCO.EQ.'OFF'.AND.ISUBRO.NE.'MPID')GOTO799
7861      ISTEPN='3'
7862      CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7863      WRITE(ICOUT,791)NCR
7864  791 FORMAT('NCR = ',2I8)
7865      CALL DPWRST('XXX','BUG ')
7866      DO792I=1,NCR
7867      WRITE(ICOUT,793)I,IR(I)
7868  793 FORMAT('I,IR(I) = ',I8,2X,A4)
7869      CALL DPWRST('XXX','BUG ')
7870  792 CONTINUE
7871  799 CONTINUE
7872C
7873C               ****************************************************************
7874C               **  STEP 4--
7875C               **  OPERATE ON THE VECTOR IR(.).
7876C               **  SIMPLIFY THE RIGHT-HAND SIDE.
7877C               **  ANALYZE THE RIGHT-HAND SIDE.
7878C               **  DETERMINE THE NUMBER OF DIFFERENT LOGICAL COMPONENTS.
7879C               **        1. NUMBER (CONSISTING OF 0,1,2,...,9 OR .)
7880C               **        2. X VARIABLE
7881C               **        3. OPERATION (+   -   *   /   **)
7882C               **        4. PARENTHESES (   (   OR   )    )
7883C               **        5. LIBRARY FUNCTION (ALOG   EXP   ETC + AUGMENTED LIB.
7884C               **        6. COMMA (FOR MULTI-ARGUMENT LIBRARY FUNCTIONS)
7885C               **        7. PARAMETER (ANYTHING NOT ABOVE)
7886C               **  CHECK FOR SYNTAX ERRORS.
7887C               **  OUTPUT THE TYPE COMPONENT INTO ITYPE(.).
7888C               **  OUTPUT THE START LOCATION IN IR(.) OF EACH COMPONENT INTO IB
7889C               **  OUTPUT THE STOP  LOCATION IN IR(.) OF EACH COMPONENT INTO IE
7890C               ****************************************************************
7891C
7892      CALL DPSIPA(IR,NCR,IBUGEV,IERROR)
7893      CALL DPSISI(IR,NCR,IBUGEV,IERROR)
7894      CALL DPSIP1(IR,NCR,IBUGEV,IERROR)
7895      CALL DPSIP0(IR,NCR,IBUGEV,IERROR)
7896      CALL DPSIE1(IR,NCR,IBUGEV,IERROR)
7897      CALL DPSIE0(IR,NCR,IBUGEV,IERROR)
7898      CALL DPSIA0(IR,NCR,IBUGEV,IERROR)
7899      CALL DPSIA2(IR,NCR,IBUGEV,ISUBRO,IERROR)
7900      CALL DPSIFL(IR,NCR,IBUGEV,IERROR)
7901C
7902      NW=0
7903      I=1
7904      NCON=0
7905 1050 CONTINUE
7906      IP1=I+1
7907      IP2=I+2
7908      IP3=I+3
7909      IP4=I+4
7910      IP5=I+5
7911C
7912      IF(IR(I).EQ.'0   ')GOTO1100
7913      IF(IR(I).EQ.'1   ')GOTO1100
7914      IF(IR(I).EQ.'2   ')GOTO1100
7915      IF(IR(I).EQ.'3   ')GOTO1100
7916      IF(IR(I).EQ.'4   ')GOTO1100
7917      IF(IR(I).EQ.'5   ')GOTO1100
7918      IF(IR(I).EQ.'6   ')GOTO1100
7919      IF(IR(I).EQ.'7   ')GOTO1100
7920      IF(IR(I).EQ.'8   ')GOTO1100
7921      IF(IR(I).EQ.'9   ')GOTO1100
7922      IF(IR(I).EQ.'.   ')GOTO1100
7923C
7924C     NOTE--THE FOLLOWING LINE IS BEING COMMENTED OUT
7925C     SO AS TO GENERALIZE COMPIL INTO COMPID
7926C     (1 VARIABLE INTO MANY VARIABLES).
7927C
7928CCCCC IF(IR(I).EQ.'X   ')GOTO1200
7929C
7930      IF(IR(I).EQ.'+   ')GOTO1300
7931      IF(IR(I).EQ.'-   ')GOTO1300
7932      IF(IR(I).EQ.'*   ')GOTO1300
7933      IF(IR(I).EQ.'/   ')GOTO1300
7934C
7935      IF(IR(I).EQ.'(   ')GOTO1410
7936      IF(IR(I).EQ.')   ')GOTO1420
7937C
7938      IF(IR(I).EQ.',   ')GOTO1700
7939C
7940C     CHECK FOR A LIBRARY FUNCTION.
7941C
7942CCCCC CALL CKLIBF(IR,NCR,I,IFOUND,NCLF,IBUGEV,IERROR)
7943      CALL CKLIB1(IR,NCR,I,IFOUND,NCLF,IBUGEV,IERROR)
7944      IF(IERROR.EQ.'YES')GOTO9000
7945      IF(IFOUND.EQ.'NO')CALL CKLIB2(IR,NCR,I,IFOUND,NCLF,IBUGEV,IERROR)
7946      IF(IERROR.EQ.'YES')GOTO9000
7947C
7948C
7949      IF(IBUGCO.EQ.'OFF'.AND.ISUBRO.NE.'MPID')GOTO1069
7950      WRITE(ICOUT,999)
7951      CALL DPWRST('XXX','BUG ')
7952      WRITE(ICOUT,1061)
7953 1061 FORMAT('***** IN COMPID, AFTER RETURNING FROM CKLIBF--')
7954      CALL DPWRST('XXX','BUG ')
7955      WRITE(ICOUT,1062)NCR,I
7956 1062 FORMAT('NCR,I = ',2I8)
7957      CALL DPWRST('XXX','BUG ')
7958      DO1063I4=1,NCR
7959      WRITE(ICOUT,1064)I4,IR(I4)
7960 1064 FORMAT('I4,IR(I4) = ',I8,2X,A4)
7961      CALL DPWRST('XXX','BUG ')
7962 1063 CONTINUE
7963      WRITE(ICOUT,1065)IFOUND,NCLF,IERROR
7964 1065 FORMAT('IFOUND,NCLF,IERROR = ',A4,I8,2X,A4)
7965      CALL DPWRST('XXX','BUG ')
7966 1069 CONTINUE
7967C
7968      IF(IERROR.EQ.'YES ')GOTO9000
7969      IF(IFOUND.EQ.'YES '.AND.NCLF.EQ.8)GOTO1580
7970      IF(IFOUND.EQ.'YES '.AND.NCLF.EQ.7)GOTO1570
7971      IF(IFOUND.EQ.'YES '.AND.NCLF.EQ.6)GOTO1560
7972      IF(IFOUND.EQ.'YES '.AND.NCLF.EQ.5)GOTO1550
7973      IF(IFOUND.EQ.'YES '.AND.NCLF.EQ.4)GOTO1540
7974      IF(IFOUND.EQ.'YES '.AND.NCLF.EQ.3)GOTO1530
7975      IF(IFOUND.EQ.'YES '.AND.NCLF.EQ.2)GOTO1520
7976      IF(IFOUND.EQ.'YES '.AND.NCLF.EQ.1)GOTO1510
7977C
7978      GOTO1600
7979C
7980 1100 CONTINUE
7981      NCON=NCON+1
7982      ICON1(NCON)=IC2+1
7983      IC=0
7984      NW=NW+1
7985      ITYPE(NW)='N   '
7986      JMIN=I
7987      J=I
7988 1150 CONTINUE
7989      IC=IC+1
7990      IC2=IC2+1
7991      ICON(IC2)=IR(J)
7992      J=J+1
7993      IF(J.GT.NCR)GOTO1160
7994      IF(IR(J).EQ.'0   ')GOTO1150
7995      IF(IR(J).EQ.'1   ')GOTO1150
7996      IF(IR(J).EQ.'2   ')GOTO1150
7997      IF(IR(J).EQ.'3   ')GOTO1150
7998      IF(IR(J).EQ.'4   ')GOTO1150
7999      IF(IR(J).EQ.'5   ')GOTO1150
8000      IF(IR(J).EQ.'6   ')GOTO1150
8001      IF(IR(J).EQ.'7   ')GOTO1150
8002      IF(IR(J).EQ.'8   ')GOTO1150
8003      IF(IR(J).EQ.'9   ')GOTO1150
8004      IF(IR(J).EQ.'.   ')GOTO1150
8005 1160 CONTINUE
8006      ICON2(NCON)=IC2
8007      JMAX=J-1
8008      GOTO1800
8009C
8010C1200 CONTINUE
8011CCCCC NW=NW+1
8012CCCCC NLPWP=0
8013CCCCC NRPWP=0
8014CCCCC JMIN=I
8015CCCCC J=I
8016CCCCC ILOOP=0
8017 1250 CONTINUE
8018      J=J+1
8019      IF(J.GT.NCR)GOTO1260
8020      IF(IR(J).EQ.'+   ')GOTO1260
8021      IF(IR(J).EQ.'-   ')GOTO1260
8022      IF(IR(J).EQ.'*   ')GOTO1260
8023      IF(IR(J).EQ.'/   ')GOTO1260
8024      IF(IR(J).EQ.'(   ')NLPWP=NLPWP+1
8025      IF(IR(J).EQ.')   ')NRPWP=NRPWP+1
8026      IF(IR(J).EQ.')   '.AND.NRPWP.GT.NLPWP)GOTO1260
8027      ILOOP=ILOOP+1
8028      IF(ILOOP.LE.NUMAS2)GOTO1250
8029      WRITE(ICOUT,1256)NUMAS2
8030 1256 FORMAT('***** ERROR IN COMPID--PARAMETER NAME EXCEEDS ',I8,
8031     1'CHARACTERS')
8032      CALL DPWRST('XXX','BUG ')
8033      DO1257K=JMIN,J
8034      WRITE(ICOUT,1258)K,IR(K)
8035 1258 FORMAT('K,IR(K) = ',I8,2X,A4)
8036      CALL DPWRST('XXX','BUG ')
8037 1257 CONTINUE
8038      IERROR='YES '
8039      GOTO9000
8040 1260 CONTINUE
8041      JMAX=J-1
8042C     THE FOLLOWING STATEMENT HAS BEEN
8043C     COMMENTED OUT IN GOING FROM THE
8044C     COMPIL SUBROUTINE TO THE COMPID
8045C     SUBROUTINE SO THAT X WILL NOT
8046C     BE TREATED AS A SPECIAL VARIABLE.
8047CCCCC IF(JMAX.EQ.JMIN)ITYPE(NW)='X   '
8048      IF(JMAX.GT.JMIN)ITYPE(NW)='PAR '
8049      GOTO1800
8050C
8051 1300 CONTINUE
8052      NW=NW+1
8053      ITYPE(NW)='OP  '
8054      JMIN=I
8055      JMAX=I
8056      IP1=I+1
8057      IF(IR(I).EQ.'*   '.AND.IR(IP1).EQ.'*   ')JMAX=IP1
8058      GOTO1800
8059C
8060 1410 CONTINUE
8061      NW=NW+1
8062      ITYPE(NW)='LP  '
8063      JMIN=I
8064      JMAX=I
8065      GOTO1800
8066 1420 CONTINUE
8067      NW=NW+1
8068      ITYPE(NW)='RP  '
8069      JMIN=I
8070      JMAX=I
8071      GOTO1800
8072C
8073 1510 CONTINUE
8074      NW=NW+1
8075      ITYPE(NW)='LF  '
8076      JMIN=I
8077      JMAX=I
8078      GOTO1800
8079C
8080 1520 CONTINUE
8081      NW=NW+1
8082      ITYPE(NW)='LF  '
8083      JMIN=I
8084      JMAX=I+1
8085      GOTO1800
8086C
8087 1530 CONTINUE
8088      NW=NW+1
8089      ITYPE(NW)='LF  '
8090      JMIN=I
8091      JMAX=I+2
8092      GOTO1800
8093C
8094 1540 CONTINUE
8095      NW=NW+1
8096      ITYPE(NW)='LF  '
8097      JMIN=I
8098      JMAX=I+3
8099      GOTO1800
8100C
8101 1550 CONTINUE
8102      NW=NW+1
8103      ITYPE(NW)='LF  '
8104      JMIN=I
8105      JMAX=I+4
8106      GOTO1800
8107C
8108 1560 CONTINUE
8109      NW=NW+1
8110      ITYPE(NW)='LF  '
8111      JMIN=I
8112      JMAX=I+5
8113      GOTO1800
8114C
8115 1570 CONTINUE
8116      NW=NW+1
8117      ITYPE(NW)='LF  '
8118      JMIN=I
8119      JMAX=I+6
8120      GOTO1800
8121C
8122 1580 CONTINUE
8123      NW=NW+1
8124      ITYPE(NW)='LF  '
8125      JMIN=I
8126      JMAX=I+7
8127      GOTO1800
8128C
8129 1700 CONTINUE
8130      NW=NW+1
8131      ITYPE(NW)='COM '
8132      JMIN=I
8133      JMAX=I
8134      GOTO1800
8135C
8136 1600 CONTINUE
8137      NW=NW+1
8138      ITYPE(NW)='PAR '
8139      NLPWP=0
8140      NRPWP=0
8141      JMIN=I
8142      J=I
8143      ILOOP=0
8144C
8145 1650 CONTINUE
8146      J=J+1
8147      IF(J.GT.NCR)GOTO1660
8148      IF(IR(J).EQ.'+   ')GOTO1660
8149      IF(IR(J).EQ.'-   ')GOTO1660
8150      IF(IR(J).EQ.'*   ')GOTO1660
8151      IF(IR(J).EQ.'/   ')GOTO1660
8152      IF(IR(J).EQ.'(   ')NLPWP=NLPWP+1
8153      IF(IR(J).EQ.')   ')NRPWP=NRPWP+1
8154      IF(IR(J).EQ.')   '.AND.NRPWP.GT.NLPWP)GOTO1660
8155      IF(IR(J).EQ.',   ')GOTO1660
8156      ILOOP=ILOOP+1
8157      IF(ILOOP.LE.NUMAS2)GOTO1650
8158      WRITE(ICOUT,1656)NUMAS2
8159 1656 FORMAT('***** ERROR IN COMPID--PARAMETER NAME EXCEEDS ',I8,
8160     1'CHARACTERS')
8161      CALL DPWRST('XXX','BUG ')
8162      DO1657K=JMIN,J
8163      WRITE(ICOUT,1658)K,IR(K)
8164 1658 FORMAT('K,IR(K) = ',I8,2X,A4)
8165      CALL DPWRST('XXX','BUG ')
8166 1657 CONTINUE
8167      IERROR='YES '
8168      GOTO9000
8169 1660 CONTINUE
8170      JMAX=J-1
8171      GOTO1800
8172C
8173 1800 CONTINUE
8174C
8175C     CHECK THAT NW HAS NOT EXCEEDED MAXCHA (USUALLY 80)
8176C
8177      IF(NW.LE.MAXCHA)GOTO1900
8178      WRITE(ICOUT,1901)
8179 1901 FORMAT('***** ERROR IN COMPID--')
8180      CALL DPWRST('XXX','BUG ')
8181      WRITE(ICOUT,1902)
8182 1902 FORMAT('      THE VARIABLE NW HAS JUST EXCEEDED')
8183      CALL DPWRST('XXX','BUG ')
8184      WRITE(ICOUT,1903)
8185 1903 FORMAT('      THE MAX ALLOWABLE LIMIT DEFINED ',
8186     1'BY THE INTERNAL VARIABLE MAXCHA.')
8187      CALL DPWRST('XXX','BUG ')
8188      WRITE(ICOUT,1904)MAXCHA
8189 1904 FORMAT('      THIS LIMIT IS MAXCHA = ',I8)
8190      CALL DPWRST('XXX','BUG ')
8191      WRITE(ICOUT,1905)NUMCHA
8192 1905 FORMAT('      THE INPUT NUMBER OF CHARACTERS NUMCHA = ',I8)
8193      CALL DPWRST('XXX','BUG ')
8194      IF(NUMCHA.GE.1)WRITE(ICOUT,1906)(IA(I),I=1,NUMCHA)
8195 1906 FORMAT('      INPUT EXPRESSION--',100A1)
8196      IF(NUMCHA.GE.1)CALL DPWRST('XXX','BUG ')
8197      WRITE(ICOUT,1907)
8198 1907 FORMAT('      THE NUMBER OF (PACKED) CHARACTERS ON ',
8199     1'RIGHT-HAND SIDE NCR = ',I8)
8200      CALL DPWRST('XXX','BUG ')
8201      IF(NCR.GE.1)WRITE(ICOUT,1908)(IR(I),I=1,NCR)
8202 1908 FORMAT('      (PACKED) RIGHT-HAND SIDE--',95A1)
8203      IF(NCR.GE.1)CALL DPWRST('XXX','BUG ')
8204      IERROR='YES '
8205      GOTO9000
8206 1900 CONTINUE
8207C
8208      IBEGIN(NW)=JMIN
8209      IEND(NW)=JMAX
8210      I=JMAX
8211C
8212      I=I+1
8213      IF(I.LE.NCR)GOTO1050
8214C
8215C     TEST THAT NW IS POSITIVE.
8216C
8217      IF(NW.GE.1)GOTO1959
8218      WRITE(ICOUT,1951)NW
8219 1951 FORMAT('***** ERROR IN COMPID--NW IS NON-POSITIVE. ',
8220     1'NW = ',I8)
8221      CALL DPWRST('XXX','BUG ')
8222      IERROR='YES '
8223      GOTO9000
8224 1959 CONTINUE
8225C
8226      IF(NW.EQ.1)GOTO1969
8227      DO1960I=1,NW
8228      IP1=I+1
8229      IF(ITYPE(I).EQ.'LF  '.AND.ITYPE(IP1).NE.'LP  ')GOTO1961
8230      GOTO1960
8231 1961 CONTINUE
8232      WRITE(ICOUT,1962)
8233      CALL DPWRST('XXX','BUG ')
8234      WRITE(ICOUT,1963)NW
8235      CALL DPWRST('XXX','BUG ')
8236      WRITE(ICOUT,1964)I
8237      CALL DPWRST('XXX','BUG ')
8238      WRITE(ICOUT,1965)ITYPE(I)
8239      CALL DPWRST('XXX','BUG ')
8240      WRITE(ICOUT,1966)ITYPE(IP1)
8241 1962 FORMAT('***** ERROR IN COMPID--LIBRARY FUNCTION ',
8242     1'NOT FOLLOWED BY A LEFT PARENTHESES')
8243      CALL DPWRST('XXX','BUG ')
8244 1963 FORMAT('             NW = ',I8)
8245 1964 FORMAT('             I  = ',I8)
8246 1965 FORMAT('             ITYPE(I) = ',A4)
8247 1966 FORMAT('             ITYPE(I+1) = ',A4)
8248      IERROR='YES '
8249      GOTO9000
8250 1960 CONTINUE
8251 1969 CONTINUE
8252C
8253      IF(ITYPE(NW).EQ.'OP  ')GOTO1970
8254      IF(ITYPE(NW).EQ.'LF  ')GOTO1972
8255      GOTO1979
8256C
8257 1970 CONTINUE
8258      WRITE(ICOUT,1971)ITYPE(NW)
8259 1971 FORMAT('***** ERROR IN COMPID--LAST TERM IN TOTAL ',
8260     1' EXPRESSION IS AN OPERATION = ',A4)
8261      CALL DPWRST('XXX','BUG ')
8262      IERROR='YES '
8263      GOTO9000
8264 1972 CONTINUE
8265      WRITE(ICOUT,1973)ITYPE(NW)
8266 1973 FORMAT('***** ERROR IN COMPID--LAST TERM IN TOTAL ',
8267     1' EXPRESSION = A LIBRARY FUNCTION = ',A4)
8268      CALL DPWRST('XXX','BUG ')
8269      IERROR='YES '
8270      GOTO9000
8271 1979 CONTINUE
8272C
8273      IF(IBUGCO.EQ.'OFF'.AND.ISUBRO.NE.'MPID')GOTO1999
8274      ISTEPN='4'
8275      CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8276      WRITE(ICOUT,1991)NW,ICMIN
8277 1991 FORMAT('NW,ICMIN = ',2I8)
8278      CALL DPWRST('XXX','BUG ')
8279      DO1992I=1,NW
8280      ICMIN=IBEGIN(I)
8281      ICMINP=ICMIN+1
8282      ICMINQ=ICMIN+2
8283      WRITE(ICOUT,1993)I,IR(ICMIN),IR(ICMINP),IR(ICMINQ),ITYPE(I),
8284     1IBEGIN(I),IEND(I)
8285 1993 FORMAT('I,IR(ICMIN),IR(ICMIN+1),IR(ICMIN+2),ITYPE(I),',
8286     1'IBEGIN(I),IEND(I) = ',I8,2X,3A4,A4,2X,I8,2X,I8)
8287      CALL DPWRST('XXX','BUG ')
8288 1992 CONTINUE
8289 1999 CONTINUE
8290C
8291C               ****************************************************************
8292C               **  STEP 5--
8293C               **  OPERATE ON EACH COMPONENT OF THE VECTOR IR(.).
8294C               **  CONVERT THE NUMBERS TO FLOATING POINT VALUES.
8295C               **  CONVERT THE PARAMETERS TO FLOATING POINT VALUES.
8296C      *  SET THE X TO A DUMMY VALUE OF 0.0 FOR THE TIME BEING.       **
8297C               **  CONVERT THE OPERATIONS INTO A 1-WORD REPRESENTATION.
8298C               **  'CONVERT' THE PARENTHESES INTO A 1-WORD REPRESENTATION.
8299C               **  CONVERT THE COEFFICIENTS TO COEFFICIENT VALUES.
8300C               **  CONVERT THE LIBRARY FUNCTIONS INTO A 1-WORD REPRESENTATION.
8301C               **  SAVE THE CONTENTS OF ITYPE, IW2, AND W2 IN
8302C               **  ITYPEH, IW21HO, AND WHOLD FOR LATER USE
8303C               **  IN REDEFINING ITYPE, IW2, AND W2 FOR EACH NEW X VALUE.
8304C               **  OUTPUT THE VECTORS IW2 AND W2.
8305C               **  OUTPUT THE VECTORS IW21HO, W2HOLD, AND ITYPEH.
8306C               ****************************************************************
8307C
8308CCCCC IC=0 APRIL 29, 1986
8309      IC3=0
8310      DO3000I=1,NW
8311      ICMIN=IBEGIN(I)
8312      ICMAX=IEND(I)
8313      IF(ITYPE(I).EQ.'N   ')GOTO3100
8314      IF(ITYPE(I).EQ.'X   ')GOTO3200
8315      IF(ITYPE(I).EQ.'OP  ')GOTO3300
8316      IF(ITYPE(I).EQ.'LP  '.OR.ITYPE(I).EQ.'RP  ')GOTO3400
8317      IF(ITYPE(I).EQ.'PAR ')GOTO3500
8318      IF(ITYPE(I).EQ.'LF  ')GOTO3600
8319      IF(ITYPE(I).EQ.'COM ')GOTO3700
8320      WRITE(ICOUT,3005)
8321 3005 FORMAT('***** ERROR IN COMPID--ITYPE(I) NOT X, OP, LP, PAR, ',
8322     1'OR LF')
8323      CALL DPWRST('XXX','BUG ')
8324      WRITE(ICOUT,3006)I,ITYPE(I),IW21(I),W2(I)
8325 3006 FORMAT('I,ITYPE(I),IW21(I),W2(I) = ',
8326     1I8,2X,A4,2X,A4,2X,E15.7)
8327      CALL DPWRST('XXX','BUG ')
8328      IERROR='YES '
8329      GOTO9000
8330C
8331 3100 CONTINUE
8332CCCCC IC=IC+1 APRIL 29, 1986
8333      IC3=IC3+1
8334CCCCC IW21(I)=IC
8335CCCCC CALL DPC4IH(IC,IW21(I),IBUGEV,IERROR) APRIL 29, 1986
8336      CALL DPC4IH(IC3,IW21(I),IBUGEV,IERROR)
8337      IW22(I)='    '
8338      W2(I)=0.0
8339      IANS1='    '
8340      IANS2='    '
8341      IANS3='    '
8342      IANS4='    '
8343      J=0
8344      DO3150IC=ICMIN,ICMAX
8345      J=J+1
8346      JM1=J-1
8347      L=J-(NUMASC*(JM1/NUMASC))
8348      K=NUMBPC*(L-1)
8349      K=IABS(K)
8350CCCCC WRITE(ICOUT,3333)J,JM1,L,K,IR(IC)
8351C3333 FORMAT('J,JM1,L,K,IR(IC) = ',4I8,2X,A4)
8352CCCCC CALL DPWRST('XXX','BUG ')
8353      IF(J.LE.NUMASC)GOTO3151
8354      IF(J.LE.NUMAS2)GOTO3152
8355      IF(J.LE.NUMAS3)GOTO3153
8356      IF(J.LE.NUMAS4)GOTO3154
8357      GOTO3155
8358 3151 CONTINUE
8359      CALL DPCHEX(0,NUMBPC,IR(IC),K,NUMBPC,IANS1)
8360      GOTO3155
8361 3152 CONTINUE
8362      CALL DPCHEX(0,NUMBPC,IR(IC),K,NUMBPC,IANS2)
8363      GOTO3155
8364 3153 CONTINUE
8365      CALL DPCHEX(0,NUMBPC,IR(IC),K,NUMBPC,IANS3)
8366      GOTO3155
8367 3154 CONTINUE
8368      CALL DPCHEX(0,NUMBPC,IR(IC),K,NUMBPC,IANS4)
8369      GOTO3155
8370 3155 CONTINUE
8371CCCCC WRITE(ICOUT,4444)IANS1,IANS2,IANS3,IANS4
8372C4444 FORMAT(4A4)
8373CCCCC CALL DPWRST('XXX','BUG ')
8374 3150 CONTINUE
8375      CALL ERRORF(IANS1,IANS2,IANS3,IANS4,-1000000000.0,1000000000.0,
8376     11000000000.0,ANS2,IERROR)
8377      IF(IERROR.EQ.'YES ')GOTO9000
8378      W2(I)=ANS2
8379      GOTO3000
8380C
8381 3200 CONTINUE
8382      W2(I)=0.0
8383      GOTO3000
8384C
8385 3300 CONTINUE
8386      IW21(I)=IR(ICMIN)
8387      IW22(I)='    '
8388      ICMINP=ICMIN+1
8389      IF(IR(ICMIN).EQ.'*   '.AND.IR(ICMINP).EQ.'*   ')IW21(I)='**  '
8390      IF(IR(ICMIN).EQ.'*   '.AND.IR(ICMINP).EQ.'*   ')IW22(I)='    '
8391      GOTO3000
8392C
8393 3400 CONTINUE
8394      IW21(I)=IR(ICMIN)
8395      IW22(I)='    '
8396      GOTO3000
8397C
8398 3500 CONTINUE
8399      IW21(I)='    '
8400      IW22(I)='    '
8401      ICMAX2=ICMIN+NUMAS2-1
8402      IF(ICMAX.LE.ICMAX2)ICMAX2=ICMAX
8403      J=0
8404      DO3530IC=ICMIN,ICMAX2
8405      J=J+1
8406      J2=J
8407      IF(J2.GT.NUMASC)J2=J-NUMASC
8408      ISTAR3=NUMBPC*(J2-1)
8409      ISTAR3=IABS(ISTAR3)
8410      IF(J.LE.NUMASC)CALL DPCHEX(0,NUMBPC,IR(IC),ISTAR3,NUMBPC,IW21(I))
8411      IF(J.GT.NUMASC)CALL DPCHEX(0,NUMBPC,IR(IC),ISTAR3,NUMBPC,IW22(I))
8412 3530 CONTINUE
8413C
8414      IF(IPASS.EQ.1)GOTO3000
8415C
8416      IF(NUMPAR.LE.0)GOTO3559
8417      DO3550J=1,NUMPAR
8418      IF(IW21(I).EQ.IPARN1(J).AND.IW22(I).EQ.IPARN2(J))GOTO3555
8419 3550 CONTINUE
8420      GOTO3559
8421 3555 CONTINUE
8422      W2(I)=PARAM(J)
8423      GOTO3000
8424 3559 CONTINUE
8425C
8426      IF(NUMVAR.LE.0)GOTO3569
8427      DO3560J=1,NUMVAR
8428      IF(IW21(I).EQ.IPARN1(J).AND.IW22(I).EQ.IPARN2(J))GOTO3565
8429 3560 CONTINUE
8430 3565 CONTINUE
8431      W2(I)=0.0
8432      ITYPE(I)='VAR '
8433      GOTO3000
8434 3569 CONTINUE
8435C
8436      WRITE(ICOUT,3571)
8437 3571 FORMAT('***** ERROR IN COMPID--NO MATCH FOR PARAM./VAR. NAME')
8438      CALL DPWRST('XXX','BUG ')
8439      WRITE(ICOUT,3572)IW21(I),IW22(I)
8440 3572 FORMAT('                       GIVEN PARAM./VAR. NAME = ',2A4)
8441      CALL DPWRST('XXX','BUG ')
8442      WRITE(ICOUT,3573)NUMPAR
8443 3573 FORMAT('                       NUMBER OF PARAM./VAR. =',I8)
8444      CALL DPWRST('XXX','BUG ')
8445      WRITE(ICOUT,3574)
8446 3574 FORMAT('                       ADMISSIBLE PARAM./VAR. ',
8447     1'NAMES = ')
8448      CALL DPWRST('XXX','BUG ')
8449      DO3575J=1,NUMPAR
8450      WRITE(ICOUT,3576)J,IPARN1(J),IPARN2(J)
8451 3576 FORMAT('                       PARAM./VAR. NAME ',I4,'--  ',
8452     12A4)
8453      CALL DPWRST('XXX','BUG ')
8454 3575 CONTINUE
8455      WRITE(ICOUT,3577)(IA(J),J=1,NUMCHA)
8456 3577 FORMAT('      FUNCTION EXPRESSION--',100A1)
8457      CALL DPWRST('XXX','BUG ')
8458      IERROR='YES '
8459      GOTO9000
8460C
8461 3600 CONTINUE
8462      IW21(I)='    '
8463      IW22(I)='    '
8464      ICMAX2=ICMIN+NUMAS2-1
8465      IF(ICMAX.LE.ICMAX2)ICMAX2=ICMAX
8466      J=0
8467      DO3650IC=ICMIN,ICMAX2
8468      J=J+1
8469      J2=J
8470      IF(J2.GT.NUMASC)J2=J-NUMASC
8471      ISTAR3=NUMBPC*(J2-1)
8472      ISTAR3=IABS(ISTAR3)
8473      IF(J.LE.NUMASC)CALL DPCHEX(0,NUMBPC,IR(IC),ISTAR3,NUMBPC,IW21(I))
8474      IF(J.GT.NUMASC)CALL DPCHEX(0,NUMBPC,IR(IC),ISTAR3,NUMBPC,IW22(I))
8475 3650 CONTINUE
8476      GOTO3000
8477C
8478 3700 CONTINUE
8479      IW21(I)=IR(ICMIN)
8480      IW22(I)='    '
8481      GOTO3000
8482C
8483 3000 CONTINUE
8484      NWHOLD=NW
8485      DO3900I=1,NW
8486      ITYPEH(I)=ITYPE(I)
8487      IW21HO(I)=IW21(I)
8488      IW22HO(I)=IW22(I)
8489      W2HOLD(I)=W2(I)
8490 3900 CONTINUE
8491      IF(IBUGCO.EQ.'OFF'.AND.ISUBRO.NE.'MPID')GOTO3999
8492      ISTEPN='5'
8493      CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8494      DO3992I=1,NW
8495      ICMIN=IBEGIN(I)
8496      ICMINP=ICMIN+1
8497      ICMINQ=ICMIN+2
8498      WRITE(ICOUT,3993)I,IR(ICMIN),IR(ICMINP),IR(ICMINQ),ITYPE(I),
8499     1IW21(I),IW22(I),W2(I)
8500 3993 FORMAT('I,IR(ICMIN),IR(ICMIN+1),IR(ICMIN+2),ITYPE(I),',
8501     1'IW21(I),IW22HO(I),W2(I) = ',I8,2X,3A4,2X,A4,2X,A4,2X,A4,2X,E15.6)
8502      CALL DPWRST('XXX','BUG ')
8503 3992 CONTINUE
8504 3999 CONTINUE
8505C
8506C               ****************************************************
8507C               **  STEP 6--                                      **
8508C               **  THIS STEP IS TO BE EXECUTED IF IPASS=1;       **
8509C               **  OTHERWISE IT IS SKIPPED.                      **
8510C               **  IF THIS STEP IS EXECUTED, STEP 7 IS NOT;      **
8511C               **  IF THIS STEP IS NOT EXECUTED, STEP 7 IS.      **
8512C               **  OPERATE ON IW2 AND ITYPE VECTORS.             **
8513C               **  DETERMINE THE NUMBER OF DISTINCT PARAMETERS.  **
8514C               **  FORM THE OUTPUT VECTOR IPARN1.                 **
8515C               **  CHECK TO SEE IF SOME OF THE PREVIOSULY-       **
8516C               **  DEFINED PARAMETERS ARE IN FACT VARIABLES.     **
8517C               ****************************************************
8518C
8519      IF(IPASS.EQ.1)GOTO4050
8520      GOTO4999
8521 4050 CONTINUE
8522C
8523      NUMPAR=0
8524      DO4100I=1,NW
8525      IF(ITYPE(I).EQ.'PAR ')GOTO4190
8526      GOTO4100
8527 4190 CONTINUE
8528C
8529      IF(NUMVAR.LE.0)GOTO4290
8530      DO4250J=1,NUMVAR
8531      IF(IW21(I).EQ.IVARN1(J).AND.IW22(I).EQ.IVARN2(J))GOTO4260
8532 4250 CONTINUE
8533      GOTO4290
8534 4260 CONTINUE
8535      ITYPE(I)='VAR '
8536      GOTO4100
8537 4290 CONTINUE
8538C
8539      IF(NUMPAR.EQ.0)GOTO4300
8540      DO4400J=1,NUMPAR
8541      IF(IW21(I).EQ.IPARN1(J).AND.IW22(I).EQ.IPARN2(J))GOTO4100
8542 4400 CONTINUE
8543 4300 CONTINUE
8544      NUMPAR=NUMPAR+1
8545      IPARN1(NUMPAR)=IW21(I)
8546      IPARN2(NUMPAR)=IW22(I)
8547 4100 CONTINUE
8548C
8549      IF(IBUGCO.EQ.'OFF'.AND.ISUBRO.NE.'MPID')GOTO4599
8550      ISTEPN='6'
8551      CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8552      WRITE(ICOUT,4591)
8553 4591 FORMAT('AT END OF STEP 6 FOR PASS 1 (RIGHT BEFORE ',
8554     1'RETURNING TO MAIN ROUTINE FROM COMPID)--')
8555      CALL DPWRST('XXX','BUG ')
8556      DO4592I=1,NW
8557      ICMIN=IBEGIN(I)
8558      ICMINP=ICMIN+1
8559      ICMINQ=ICMIN+2
8560      WRITE(ICOUT,4593)I,IR(ICMIN),IR(ICMINP),IR(ICMINQ),ITYPE(I),
8561     1IW21(I),IW22(I),W2(I)
8562 4593 FORMAT('I,IR(ICMIN),IR(ICMIN+1),IR(ICMIN+2),ITYPE(I),',
8563     1'IW21(I),IW22(I),W2(I) = ',I8,2X,3A4,A4,2X,A4,2X,A4,2X,E15.7)
8564      CALL DPWRST('XXX','BUG ')
8565 4592 CONTINUE
8566 4599 CONTINUE
8567C
8568      GOTO9000
8569 4999 CONTINUE
8570C
8571C               ****************************************************************
8572C               **  STEP 7--
8573C               **  OPERATE ON THE W2(.) AND IW21(.) VECTORS.
8574C               **  THIS STEP IS NOT EXECUTED IF STEP 6 IS;
8575C               **  THIS STEP IS EXECUTED IF STEP 6 IS NOT.
8576C               **  FIRST MAKE SURE THAT THE NUMBER OF LEFT
8577C               **  AND RIGHT PARENTHESES ARE THE SAME.
8578C               **  (STEP 6 THEN SETS UP A LARGE DO LOOP
8579C               **  WHICH GOES THROUGH ALL OF THE VALUES OF THE X VECTOR
8580C               **  AND GENERATES CORRESPONDING VALUES OF THE Y VECTOR.)
8581C               **  FOR A GIVEN X VALUE, IT EVALUATES THE FUNCTION
8582C               **  BY FIRST SEEKING THE INNERMOST PARENTHESES
8583C               **  (BY SEARCHING FOR THE FIRST REMAINING RIGHT PARENTHESS).
8584C               **  AND THEN EVALUATING ALL SUCH PARENTHETICAL EXPRESSIONS--
8585C               **  WORKING FROM THE INNERMOST OUT.
8586C               **  AFTER EVALUATING A PARENTHESES PAIR,
8587C               **  THE ENTIRE PARENTHESES GROUP (PARENTHESES INCLUDED)
8588C               **  IS REPLACED BY THE SCALAR ANSWER.
8589C               **  THE IW2, W2, AND ITYPE VECTORS ARE SQUEEZED ACCORDINGLY
8590C               **  (IN THE SUBROUTINE EVAL).
8591C               **  SINCE THE VECTORS IW2, W2, AND ITYPE ARE ALTERED (SQUEEZED)
8592C               **  FOR EACH X VALUE, THEY MUST BE REDEFINED FROM THE SAVED
8593C               **  VALUES IN IW2, W2, AND ITYPE FOR EACH NEW X VALUE.
8594C               **  THE ABOVE SQUEEZING OPERATION IS REPEATED
8595C               **  FOR EACH PARENTHESES PAIR UNTIL ALL PARENTHESES
8596C               **  ARE GONE AND WE REMAIN ONLY WITH THE FINAL ANSWER.
8597C               **  FOR EACH VALUE X(.) OF THE INPUT X VECTOR,
8598C               **  OUTPUT THE CORRESPONDING VALUE Y(.) OF
8599C               **  THE DESIRED OUTPUT VECTOR.
8600C               **  FOR A GIVEN VALUE X(.), THE CORRESPONDING
8601C               **  COMPUTED Y(.) WILL BE THE EVALUATED VALUE OF
8602C               **  THE RIGHT-HAND SIDE OF THE SPECIFIED EQUATION Y = F(X).
8603C               ****************************************************************
8604C
8605      NLP=0
8606      NRP=0
8607      DO5100I=1,NW
8608      IF(ITYPE(I).EQ.'LP  ')NLP=NLP+1
8609      IF(ITYPE(I).EQ.'RP  ')NRP=NRP+1
8610 5100 CONTINUE
8611      IF(NLP.EQ.NRP)GOTO5190
8612      WRITE(ICOUT,5155)
8613      CALL DPWRST('XXX','BUG ')
8614      WRITE(ICOUT,5156)
8615      CALL DPWRST('XXX','BUG ')
8616      WRITE(ICOUT,5157)NLP
8617      CALL DPWRST('XXX','BUG ')
8618      WRITE(ICOUT,5158)NRP
8619 5155 FORMAT('***** ERROR IN COMPID--')
8620      CALL DPWRST('XXX','BUG ')
8621 5156 FORMAT('NUMBER OF LEFT PARENTHESES NOT EQUAL TO ',
8622     1'NUMBER OF RIGHT PARENTHESES')
8623 5157 FORMAT('NUMBER OF LEFT  PARENTHESES = ',I8)
8624 5158 FORMAT('NUMBER OF RIGHT PARENTHESES = ',I8)
8625      IERROR='YES '
8626      GOTO9000
8627 5190 CONTINUE
8628C
8629CCCCC DO8000II=1,N
8630      NW=NWHOLD
8631      DO5200I=1,NW
8632      ITYPE(I)=ITYPEH(I)
8633      IW21(I)=IW21HO(I)
8634      IW22(I)=IW22HO(I)
8635      W2(I)=W2HOLD(I)
8636C     THE FOLLOWING STATEMENT HAS BEEN COMMENTED OUT
8637C     IN GOING FROM COMPIL TO COMPID.
8638CCCCC IF(ITYPE(I).EQ.'X   ')W2(I)=X(II)
8639 5200 CONTINUE
8640      IF(IBUGCO.EQ.'ON'.OR.ISUBRO.EQ.'RIV4')
8641     1GOTO5249
8642      GOTO5299
8643 5249 CONTINUE
8644      ISTEPN='7'
8645      CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8646      DO5250I=1,NW
8647      WRITE(ICOUT,5251)I,IW21HO(I),IW21(I),ITYPE(I)
8648 5251 FORMAT('I,IW21HO(I),IW21(I),ITYPE(I) = ',I8,2X,A4,2X,A4,2X,A4)
8649      CALL DPWRST('XXX','BUG ')
8650 5250 CONTINUE
8651 5299 CONTINUE
8652C
8653C               *********************************
8654C               **  STEP 7--                   **
8655C               **  DETERMINE THE DERIVATIVE.  **
8656C               *********************************
8657C
8658      CALL DERIV0(IW21,IW22,ITYPE,NW,
8659     1IPARN1,IPARN2,NUMPAR,IVARN1,IVARN2,NUMVAR,
8660     1ICON,ICON1,ICON2,NCON,ID1,ID2,NUMCD2,
8661     1IBUGEV,ISUBRO,IFOUND,IERROR)
8662C
8663      IF(IBUGCO.EQ.'OFF'.AND.ISUBRO.NE.'MPID')GOTO5319
8664      WRITE(ICOUT,999)
8665      CALL DPWRST('XXX','BUG ')
8666      WRITE(ICOUT,5311)
8667 5311 FORMAT('***** IN COMPID, AFTER RETURNING FROM DERIV0--')
8668      CALL DPWRST('XXX','BUG ')
8669      WRITE(ICOUT,5312)NUMCD2
8670 5312 FORMAT('      NUMCD2 = ',I8)
8671      CALL DPWRST('XXX','BUG ')
8672      DO5315I=1,NUMCD2
8673      WRITE(ICOUT,5316)I,ID1(I),ID2(I)
8674 5316 FORMAT('      I,ID1(I),ID2(I) = ',I8,2X,A4,2X,A4)
8675      CALL DPWRST('XXX','BUG ')
8676 5315 CONTINUE
8677 5319 CONTINUE
8678C
8679C               ***********************************************************
8680C               **  STEP 7.2--                                           **
8681C               **  FORM THE OUTPUT VECTOR ID(.).                        **
8682C               **  NOTE THAT ID1(.) AND ID2(.) ARE PARALLEL             **
8683C               **  REPRESENTATIONS OF THE DESIRED DERIVATIVE FUNCTION   **
8684C               **  (ID1(.) HAS THE FIRST 4 CHARACTERS;                  **
8685C               **  ID2(.) HAS THE NEXT 4 CHARACTERS).                   **
8686C               **  MOST COMPONENTS (E.G., +, -, *, /, (, ), ETC.)       **
8687C               **  USE ONLY 1 CHARACTER OUT OF THE 8.                   **
8688C               **  SOME COMPONENTS (NAMELY, **)                         **
8689C               **  USE 2 CHARACTERS OUT OF THE 8.                       **
8690C               **  SOME COMPONTENTS (NAMELY, LIBRARY FUNCTIONS)         **
8691C               **  USE MANY (3 TO 7) CHARACTERS OUT OF THE 8.           **
8692C               **  IN ANY EVENT, THE OUTPUT VECTOR ID(.) WILL BE        **
8693C               **  AN UNPACKED (1 CHARACTER PER WORD) SYNTHESIS         **
8694C               **  OF THE 2 PACKED \VYYEYC\TYORS Y\I\D1(.) AND ID2(.).  **
8695C               ***********************************************************
8696C
8697      ISTEPN='7.2'
8698      IF(IBUGCO.EQ.'ON'.OR.ISUBRO.EQ.'RIV4')
8699     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8700C
8701      J=0
8702      IF(NUMCD2.LE.0)GOTO5639
8703      DO5600I=1,NUMCD2
8704      IF(ID1(I).EQ.'    ')GOTO5619
8705      J=J+1
8706      ID3(J)=ID1(I)
8707 5619 CONTINUE
8708      IF(ID2(I).EQ.'    ')GOTO5629
8709      J=J+1
8710      ID3(J)=ID2(I)
8711 5629 CONTINUE
8712 5600 CONTINUE
8713 5639 CONTINUE
8714      NUMCH3=J
8715C
8716      IF(IBUGCO.EQ.'OFF'.AND.ISUBRO.NE.'MPID')GOTO5649
8717      WRITE(ICOUT,999)
8718      CALL DPWRST('XXX','BUG ')
8719      WRITE(ICOUT,5641)NUMCD2,NUMCH3
8720 5641 FORMAT('NUMCD2,NUMCH3 = ',2I8)
8721      CALL DPWRST('XXX','BUG ')
8722      DO5645I=1,NUMCH3
8723      WRITE(ICOUT,5646)I,ID3(I)
8724 5646 FORMAT('I,ID3(I) = ',I8,2X,A4)
8725      CALL DPWRST('XXX','BUG ')
8726 5645 CONTINUE
8727 5649 CONTINUE
8728C
8729      K=0
8730      DO5700I=1,NUMCH3
8731      IF(ID3(I).EQ.'    ')GOTO5700
8732      CALL DPXH1H(ID3(I),ICH,ILASTC,IBUGEV)
8733      IF(ILASTC.LE.0)GOTO5700
8734      DO5750J=1,ILASTC
8735      K=K+1
8736      ID(K)=ICH(J)
8737 5750 CONTINUE
8738 5700 CONTINUE
8739      NCTOTD=K
8740C
8741      IF(NCTOTD.GE.1)GOTO5789
8742      WRITE(ICOUT,5705)NCTOTD
8743 5705 FORMAT('***** ERROR IN COMPID--TOTAL NUMBER OF CHARACTERS ',
8744     1'IN DERIVATIVE. (INCL. BLANKS, AND EQUAL SIGN) ',
8745     1'IS < 2.  NCTOTD = ',I5)
8746      CALL DPWRST('XXX','BUG ')
8747      WRITE(ICOUT,5771)NUMCHD,N,IPASS
8748 5771 FORMAT('NUMCHD,N,IPASS = ',3I8)
8749      CALL DPWRST('XXX','BUG ')
8750      WRITE(ICOUT,5772)(ID(I),I=1,NUMCHD)
8751 5772 FORMAT('ID--',80A1)
8752      CALL DPWRST('XXX','BUG ')
8753      IERROR='YES'
8754      GOTO9000
8755 5789 CONTINUE
8756C
8757      IF(IBUGCO.EQ.'OFF'.AND.ISUBRO.NE.'MPID')GOTO5799
8758      WRITE(ICOUT,5791)NCTOTD
8759 5791 FORMAT('NCTOTD = ',I8)
8760      CALL DPWRST('XXX','BUG ')
8761      DO5792I=1,NCTOTD
8762      WRITE(ICOUT,5793)I,ID(I)
8763 5793 FORMAT('I,ID(I) = ',I8,2X,A4)
8764      CALL DPWRST('XXX','BUG ')
8765 5792 CONTINUE
8766 5799 CONTINUE
8767      NUMCHD=NCTOTD
8768C
8769C               *******************************************
8770C               **  STEP 7.3--                           **
8771C               **  SIMPLIFY THE FUNCTIONAL EXPRESSION.  **
8772C               *******************************************
8773C
8774      CALL DPSIPA(ID,NUMCHD,IBUGEV,IERROR)
8775      CALL DPSISI(ID,NUMCHD,IBUGEV,IERROR)
8776      CALL DPSIP1(ID,NUMCHD,IBUGEV,IERROR)
8777      CALL DPSIP0(ID,NUMCHD,IBUGEV,IERROR)
8778      CALL DPSIE1(ID,NUMCHD,IBUGEV,IERROR)
8779      CALL DPSIE0(ID,NUMCHD,IBUGEV,IERROR)
8780      CALL DPSIA0(ID,NUMCHD,IBUGEV,IERROR)
8781      CALL DPSIA2(ID,NUMCHD,IBUGEV,ISUBRO,IERROR)
8782      CALL DPSIFL(ID,NUMCHD,IBUGEV,IERROR)
8783C
8784      CALL DPSIPA(ID,NUMCHD,IBUGEV,IERROR)
8785      CALL DPSISI(ID,NUMCHD,IBUGEV,IERROR)
8786      CALL DPSIP1(ID,NUMCHD,IBUGEV,IERROR)
8787      CALL DPSIP0(ID,NUMCHD,IBUGEV,IERROR)
8788      CALL DPSIE1(ID,NUMCHD,IBUGEV,IERROR)
8789      CALL DPSIE0(ID,NUMCHD,IBUGEV,IERROR)
8790      CALL DPSIA0(ID,NUMCHD,IBUGEV,IERROR)
8791      CALL DPSIA2(ID,NUMCHD,IBUGEV,ISUBRO,IERROR)
8792      CALL DPSIFL(ID,NUMCHD,IBUGEV,IERROR)
8793C
8794C               *****************
8795C               **  STEP 90--  **
8796C               **  EXIT.      **
8797C               *****************
8798C
8799 9000 CONTINUE
8800C
8801      IF(IBUGCO.EQ.'ON' .OR. ISUBRO.EQ.'MPID')THEN
8802        WRITE(ICOUT,999)
8803        CALL DPWRST('XXX','BUG ')
8804        WRITE(ICOUT,9011)
8805 9011   FORMAT('***** AT THE END       OF COMPID--')
8806        CALL DPWRST('XXX','BUG ')
8807        WRITE(ICOUT,9012)IERROR,NUMCHA,NUMCHD
8808 9012   FORMAT('IERROR,NUMCHA,NUMCHD = ',A4,2X,2I8)
8809        CALL DPWRST('XXX','BUG ')
8810        WRITE(ICOUT,9013)
8811 9013   FORMAT('INPUT FUNCTION--')
8812        CALL DPWRST('XXX','BUG ')
8813        WRITE(ICOUT,9016)(IA(J),J=1,NUMCHA)
8814 9016   FORMAT(130A1)
8815        CALL DPWRST('XXX','BUG ')
8816C
8817        WRITE(ICOUT,9022)
8818 9022   FORMAT('OUTPUT DERIVATIVE--')
8819        CALL DPWRST('XXX','BUG ')
8820        DO9025I=1,NUMCHD,12
8821          JMIN=I
8822          JMAX=JMIN+11
8823          IF(JMAX.GT.NUMCHD)JMAX=NUMCHD
8824          WRITE(ICOUT,9026)(ID(J),J=JMIN,JMAX)
8825 9026     FORMAT(12A4)
8826          CALL DPWRST('XXX','BUG ')
8827 9025   CONTINUE
8828C
8829      ENDIF
8830C
8831      RETURN
8832      END
8833      SUBROUTINE COMPIM(IA,NUMCHA,IPASS,PARAM,IPARN1,IPARN2,NUMPAR,
8834     1                  IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,Y,
8835     1                  IBUGCO,IBUGEV,IERROR)
8836C
8837C     PURPOSE--THIS SUBROUTINE INTERPRETS AND EVALUATES A FORTRAN
8838C              MATHEMATICAL FUNCTION EXPRESSION OF THE FORM
8839C               Y=F(.,.,.,.,...).  IT IS A GENERALIZATION OF JJF7.COMPIL
8840C              WHICH COULD HANDLE ONLY 1 ARGUMENT (X).  THIS SUBROUTINE
8841C              IS TYPICALLY ENTERED WITH TWO PASSES--
8842C              THE FIRST PASS ANALYZES THE STRING AND HAS AS ITS OUTPUT
8843C              THE HOLLERITH NAMES OF THE VARIOUS PARAMETERS. A
8844C              'PARAMETER' IN THIS SUBROUTINE (COMPIM) MEANS ANY USUAL
8845C              PARAMETER IN AN EXPRESSION AS WELL AS ANY VARIABLE NAME
8846C              (E.G., X1, X2, X3, TEMP, RES, ETC.) THIS IS A FUNDAMENTAL
8847C              WAY THAT COMPIM DIFFERS FROM COMPIL.  ALSO, COMPIM OUTPUTS
8848C              ONLY A COMPUTED SCALAR VALUE (AS OPPOSED TO COMPIL WHICH
8849C              OUTPUTS AN ENTIRE COMPUTED VECTOR).  THESE NAMES ARE
8850C              OUTPUTTED IN THIS FIRST PASS AS ELEMENTS IN THE VECTORS
8851C              IPARN1 AND IPARN2.  THE SECOND PASS USES INPUT PARAMETER
8852C              VALUES (INPUTTED IN THE VECTOR PARAM) TO ACTUALLY EVALUATE
8853C              THE FUNCTION (OUTPUTTED IN THE SCALAR Y).  NOTE THAT IF
8854C              SOME OF THE 'PARAMETERS' ARE IN FACT ELEMENTS OF A VECTOR
8855C              VARIABLE, THE ITERATING THROUGH THE ENTIRE VECTOR IS DONE
8856C              IN THE CALLING SUBROUTINE AND NOT WITHIN COMPIM
8857C              (THIS IS ANOTHER WAY THAT COMPIM DIFFERS FROM COMPIL).
8858C     INPUT  ARGUMENTS--IA     = THE INTEGER VECTOR WHICH CONTAINS
8859C                                THE HOLLERITH CHARACTERS WHICH
8860C                                MAKE UP THE LINE OF FORTRAN CODE.
8861C                                THIS VECTOR CONTAINS THE STRING
8862C                                TO BE OPERATED ON, INTERPRETED,
8863C                                AND EVALUATED.
8864C                     --NUMCHA = THE INTEGER VALUE WHICH
8865C                                DEFINES THE NUMBER OF CHARACTERS IN IA.
8866C                                NUMCHA DEFINES THE LENGTH OF THE
8867C                                HOLLERITH STRING TO BE OPERATED ON,
8868C                                INTERPRETED, AND EVALUATED.
8869C                     --IPASS  = AN INTEGER FLAG CODE
8870C                                WHICH DEFINES WHICH PASS (1 OR 2) INTO THIS
8871C                                SUBROUTINE THE USER IS IN.
8872C                                PASS 1 DETERMINE PARAMETER NAMES;
8873C                                PASS 2 DOES FUNCTION EVALUATIONS.
8874C                     --PARAM  = THE SINGLE PRECISION VECTOR OF PARAMETER
8875C                                (AND VARIABLE)
8876C                                VALUES CORRESPONDING TO THE PARAMETER NAMES
8877C                                AS GIVEN IN THE VECTOR IPARN.
8878C                     --IPARN1 = THE INTEGER VECTOR
8879C                                CONTAINING CHARACTERS 1 THROUGH 4
8880C                                OF PARAMETER (AND VARIABLE)
8881C                                NAMES AS TYPICALLY DETERMINED BY PASS 1.
8882C                     --IPARN2 = THE INTEGER VECTOR
8883C                                CONTAINING CHARACTERS 5 THROUGH 8
8884C                                OF PARAMETER (AND VARIABLE)
8885C                                NAMES AS TYPICALLY DETERMINED BY PASS 1.
8886C      OUTPUT ARGUMENTS--Y     = THE SINGLE PRECISION COMPUTED SCALAR VALUE OF
8887C                                THE FUNCTION AS DETERMINED BY PASS 2
8888C                                AND WHICH CONSTITUTE THE ULTIMATE
8889C                                OUTPUT FROM THIS SUBROUTINE.
8890C                                THAT IS, SYMBOLICALLY,
8891C                                Y = F(X1,X2,X3,TEMP,RES,ETC.,PAR1,PAR2,PAR3,ETC
8892C     OUTPUT--THE SINGLE PRECISION COMPUTED SCALAR VALUE,
8893C     PRINTING--NONE.
8894C     RESTRICTIONS--NONE.
8895C     OTHER           SUBROUTINES NEEDED--EVAL
8896C     FORTRAN LIBRARY SUBROUTINES NEEDED--(ALL IN EVAL)
8897C                                         SQRT
8898C                                         EXP
8899C                                         LOG
8900C                                         LOG10
8901C                                         SIN
8902C                                         COS
8903C                                         ATAN
8904C                                         ATAN2
8905C                                         TANH
8906C                                         ABS
8907C                                         AINT
8908C                                         ARCSIN
8909C                                         ARCCOS
8910C                                         ARCTAN
8911C                                         OCTAL
8912C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
8913C     LANGUAGE--ANSI FORTRAN (1977)
8914C     NOTE--THIS SUBROUTINE ALLOWS ONE TO PERFORM
8915C           INTERACTIVE FUNCTION EVALUATIONS.
8916C     REFERENCES--NONE.
8917C     WRITTEN BY--JAMES J. FILLIBEN
8918C                 STATISTICAL ENGINEERING DIVISION
8919C                 INFORMATION TECHNOLOGY LABORATORY
8920C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
8921C                 GAITHERSBURG, MD 20899
8922C                 PHONE--301-975-2855
8923C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
8924C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
8925C     LANGUAGE--ANSI FORTRAN (1966)
8926C     VERSION NUMBER--82/7
8927C     ORIGINAL VERSION--NOVEMBER  1976.
8928C     UPDATED         --FEBRUARY  1977.
8929C     UPDATED         --DECEMBER  1977.
8930C     UPDATED         --JANUARY   1978.
8931C     UPDATED         --JULY      1978.
8932C     UPDATED         --OCTOBER   1978.
8933C     UPDATED         --DECEMBER  1978.
8934C     UPDATED         --JANUARY   1979.
8935C     UPDATED         --FEBRUARY  1979.
8936C     UPDATED         --JULY      1979.
8937C     UPDATED         --JANUARY   1981.
8938C     UPDATED         --FEBRUARY  1981.
8939C     UPDATED         --JUNE      1981.
8940C     UPDATED         --JANUARY   1981.
8941C     UPDATED         --MARCH     1982.
8942C     UPDATED         --MAY       1982.
8943C     UPDATED         --JUNE      1986.
8944C     UPDATED         --DECEMBER  1988.  BLANK OUT IR(.) FOR AT LEAST 10 CHAR
8945C     UPDATED         --SEPTEMBER 1994.  ADD SAVE4 ARGUMENT TO EVALM.
8946C     UPDATED         --APRIL     1995.  BUG:
8947C                                        LET A = TPDF(X,2) - TPDF(X,3)
8948C                                        SETS SAVE1 TO 2 IN BOTH CASES
8949C     UPDATED         --MAY       1998.  ADD FIFTH PARAMETER
8950C     UPDATED         --JUNE      2003.  ADD SAVE6, SAVE7, SAVE8
8951C                                        ARGUMENTS TO EVALM.
8952C     UPDATED         --FEBRUARY  2005.  CONVERT STRING TO UPPER CASE
8953C     UPDATED         --DECEMBER  2010.  INITIALIZATION OF SAVE1 ...
8954C                                        SAVE8
8955C
8956C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
8957C
8958      CHARACTER*4 IA
8959      CHARACTER*4 IPARN1
8960      CHARACTER*4 IPARN2
8961      CHARACTER*4 IANGLU
8962      CHARACTER*4 ITYPEH
8963      CHARACTER*4 IW21HO
8964      CHARACTER*4 IW22HO
8965      CHARACTER*4 IBUGCO
8966      CHARACTER*4 IBUGEV
8967      CHARACTER*4 IERROR
8968C
8969      CHARACTER*4 ISUBN1
8970      CHARACTER*4 ISUBN2
8971      CHARACTER*4 ISTEPN
8972C
8973      CHARACTER*4 IR
8974      CHARACTER*4 IB
8975      CHARACTER*4 IL
8976      CHARACTER*4 ICH
8977      CHARACTER*4 IW21
8978      CHARACTER*4 IW22
8979      CHARACTER*4 ITYPE
8980      CHARACTER*4 IANS1
8981      CHARACTER*4 IANS2
8982      CHARACTER*4 IANS3
8983      CHARACTER*4 IANS4
8984      CHARACTER*4 IFOUND
8985C
8986C---------------------------------------------------------------------
8987C
8988      DIMENSION IA(*)
8989      DIMENSION PARAM(*)
8990      DIMENSION IPARN1(*)
8991      DIMENSION IPARN2(*)
8992C
8993C     NOTE--THE DIMENSIONS OF ITYPEH, IW21HO, IW22HO, AND W2HOLD
8994C           WHICH ARE DEFINED IN THE MAIN PROGRAM
8995C           SHOULD BE AT LEAST AS LARGE AS THE DIMENSIONS
8996C           OF IW2 AND IW22 BELOW.
8997C
8998      DIMENSION ITYPEH(*)
8999      DIMENSION IW21HO(*)
9000      DIMENSION IW22HO(*)
9001      DIMENSION W2HOLD(*)
9002C
9003C     NOTE--THE DIMENSION OF IB SHOULD BE THE SAME AS
9004C           THE DIMENSION OF SUBROUTINE IA IN DPLET.
9005C
9006      PARAMETER (MAXCHA=1000)
9007C
9008      DIMENSION IB(MAXCHA)
9009      DIMENSION IR(MAXCHA)
9010      DIMENSION IBEGIN(MAXCHA)
9011      DIMENSION IEND(MAXCHA)
9012      DIMENSION ITYPE(MAXCHA)
9013      DIMENSION IW21(MAXCHA)
9014      DIMENSION IW22(MAXCHA)
9015      DIMENSION W2(MAXCHA)
9016C
9017      DIMENSION ICH(10)
9018      DIMENSION IL(10)
9019C
9020CCCCC ADD FOLLOWING SECTION APRIL 1995.
9021C
9022      PARAMETER(MAXNST=25)
9023      DIMENSION SAVE1(MAXNST)
9024      DIMENSION SAVE2(MAXNST)
9025      DIMENSION SAVE3(MAXNST)
9026      DIMENSION SAVE4(MAXNST)
9027      DIMENSION SAVE5(MAXNST)
9028      DIMENSION SAVE6(MAXNST)
9029      DIMENSION SAVE7(MAXNST)
9030      DIMENSION SAVE8(MAXNST)
9031C
9032C---------------------------------------------------------------------
9033C
9034      INCLUDE 'DPCOP2.INC'
9035C
9036C-----DATA STATEMENTS-------------------------------------------------
9037C
9038C     DEFINE THE UPPER LIMIT OF THE NUMBER OF CHARACTERS THAT MAY BE
9039C     PROCESSED BY THIS SUBROUTINE (COUNTING BLANKS, LEFT-HAND SIDE,
9040C     EQUAL SIGN, AND RIGHT HAND SIDE).  IF RESTRICT THE EXPRESSION TO 1
9041C     LINE IMAGE, THEN A REASONABLE UPPER BOUND IS 80.  WHATEVER UPPER
9042C     BOUND IS SET, THE DIMENSIONS OF MOST OF THE VECTORS MUST BE EQUAL
9043C     OR LARGER TO THIS NUMBER.  (THE VECTOR IL(.) WHICH CONTAINS THE
9044C     NUMBER OF CHARACTERS TO THE LEFT OF THE EQUAL SIGN (BLANKS IGNORED)
9045C     MAY BE MUCH SMALLER--LIKE 6.)
9046C     NOTE--AS OF JANUARY 1979, THE BOUND WAS RESET TO 150.
9047C
9048CCCCC DATA MAXCHA/150/
9049CCCCC DATA MAXCHA/225/
9050CCCCC DATA MAXCHA/1000/
9051C
9052C-----START POINT-----------------------------------------------------
9053C
9054      ISUBN1='COMP'
9055      ISUBN2='IM  '
9056C
9057      IERROR='NO'
9058C
9059C     THE FOLLOWING STATEMENT (N=1) HAS BEEN ADDED IN CONVERTING
9060C     THE COMPIL SUBROUTINE TO THE COMPIM SUBROUTINE.
9061C
9062      N=1
9063C
9064      IF(IBUGCO.EQ.'ON')THEN
9065        WRITE(ICOUT,999)
9066  999   FORMAT(1X)
9067        CALL DPWRST('XXX','BUG ')
9068        WRITE(ICOUT,51)
9069   51   FORMAT('***** AT THE BEGINNING OF COMPIM--')
9070        CALL DPWRST('XXX','BUG ')
9071        WRITE(ICOUT,52)NUMCHA,N,IPASS,IANGLU,IBUGCO,IBUGEV
9072   52   FORMAT('NUMCHA,N,IPASS,IANGLU,IBUGCO,IBUGEV = ',3I8,3(2X,A4))
9073        CALL DPWRST('XXX','BUG ')
9074        WRITE(ICOUT,53)(IA(I),I=1,MIN(80,NUMCHA))
9075   53   FORMAT('IA--',80A1)
9076        CALL DPWRST('XXX','BUG ')
9077        WRITE(ICOUT,999)
9078        CALL DPWRST('XXX','BUG ')
9079        WRITE(ICOUT,61)NUMPAR
9080   61   FORMAT('NUMPAR = ',I8)
9081        CALL DPWRST('XXX','BUG ')
9082        IF(NUMPAR.GE.1)THEN
9083          DO62I=1,NUMPAR
9084            WRITE(ICOUT,63)I,IPARN1(I),IPARN2(I),PARAM(I)
9085   63       FORMAT('I,IPARN1(I),IPARN2(I),PARAM(I) = ',I8,2(2X,A4),2X,
9086     1             F15.7)
9087            CALL DPWRST('XXX','BUG ')
9088   62     CONTINUE
9089        ENDIF
9090        WRITE(ICOUT,999)
9091        CALL DPWRST('XXX','BUG ')
9092        WRITE(ICOUT,71)NWHOLD
9093   71   FORMAT('NWHOLD = ',I8)
9094        CALL DPWRST('XXX','BUG ')
9095        IF(NWHOLD.GE.1)THEN
9096          DO72I=1,NWHOLD
9097            WRITE(ICOUT,73)I,ITYPEH(I),IW21HO(I),IW22HO(I),W2HOLD(I)
9098   73       FORMAT('I,ITYPEH(I),IW21HO(I),IW22HO(I),W2HOLD(I) = ',
9099     1             I8,3(2X,A4),2X,F15.7)
9100            CALL DPWRST('XXX','BUG ')
9101   72     CONTINUE
9102        ENDIF
9103        WRITE(ICOUT,81)IPASS,NW
9104   81   FORMAT('IPASS,NW = ',2I8)
9105        CALL DPWRST('XXX','BUG ')
9106        IF(NW.GE.1)THEN
9107          WRITE(ICOUT,82)ITYPE(NW)
9108   82     FORMAT('ITYPE(NW) = ',A4)
9109          CALL DPWRST('XXX','BUG ')
9110        ENDIF
9111      ENDIF
9112C
9113C               **********************************************************
9114C               **  DEFINE NUMASC = NUMBER OF ASCII CHARACTERS PER WORD.**
9115C               **  THIS IS 4 REGARDLESS OF THE COMPUTER MAKE AND       **
9116C               **  REGARDLESS OF THE WORD SIZE.                        **
9117C               **********************************************************
9118C
9119      NUMASC=4
9120      NUMAS2=2*NUMASC
9121      NUMAS3=3*NUMASC
9122      NUMAS4=4*NUMASC
9123C
9124C     IF IPASS = 2, SKIP ALL OF THE PRELIMINARY CODE
9125C     AND JUMP TO CALCULATIVE PART OF CODE.
9126C
9127      IF(IPASS.EQ.2)GOTO5000
9128C
9129C     CHECK THAT THE INPUT NUMBER OF CHARACTERS NUMCHA
9130C     (INCLUDING LEFT SIDE, RIGHT SIDE, EQUAL SIGN,
9131C     AND BLANKS) IS AT LEAST 1 AND AT MOST MAXCHA
9132C     (WHERE MAXCHA IS THE INTERNALLY DEFINED VARIABLE
9133C     WHICH CONTROLS DIMENSION SIZES AND WHICH
9134C     TYPICALLY HAS THE VALUE 80).
9135C
9136      IF(NUMCHA.LT.1 .OR. NUMCHA.GT.MAXCHA)THEN
9137        WRITE(ICOUT,21)
9138   21   FORMAT('***** ERROR IN COMPIM--')
9139        CALL DPWRST('XXX','BUG ')
9140        WRITE(ICOUT,22)
9141   22   FORMAT('      THE NUMBER OF CHARACTERS NUMCHA WHICH DEFINES ',
9142     1         'THE LENGTH')
9143        CALL DPWRST('XXX','BUG ')
9144        WRITE(ICOUT,24)
9145   24   FORMAT('      OF THE INPUT EXPRESSION (INCLUDING LEFT-HAND ',
9146     1         'SIDE,')
9147        CALL DPWRST('XXX','BUG ')
9148        WRITE(ICOUT,25)
9149   25   FORMAT('      RIGHT-HAND SIDE, EQUAL SIGN, AND ALL BLANKS) IS')
9150        CALL DPWRST('XXX','BUG ')
9151        WRITE(ICOUT,26)
9152   26   FORMAT('      LESS THAN 1 OR LARGER THAN MAXCHA (MAXCHA IS AN')
9153        CALL DPWRST('XXX','BUG ')
9154        WRITE(ICOUT,28)MAXCHA
9155   28   FORMAT('      INTERNALLY DEFINED VARIABLE WHICH HAS THE ',
9156     1         'VALUE = ',I8,'   .')
9157        CALL DPWRST('XXX','BUG ')
9158        WRITE(ICOUT,30)NUMCHA
9159   30   FORMAT('      THE NUMBER OF CHARACTERS IN THE INPUT ',
9160     1         'EXPRESSION IS ',I8)
9161        CALL DPWRST('XXX','BUG ')
9162        IF(NUMCHA.GE.1)THEN
9163          WRITE(ICOUT,31)(IA(I),I=1,MIN(100,NUMCHA))
9164   31     FORMAT('      INPUT EXPRESSION--',100A1)
9165          CALL DPWRST('XXX','BUG ')
9166        ENDIF
9167        IERROR='YES'
9168        GOTO9000
9169      ENDIF
9170C
9171CCCCC FEBRUARY 2005.  CONVERT INPUT FUNCTION TO ALL UPPER CASE.
9172CCCCC                 THIS IS TO ADDRESS ISSUE WHERE IF FUNCTION
9173CCCCC                 WAS DEFINED AS "LET STRING" RATHER THAN
9174CCCCC                 "LET FUNCTION", CASE IS PRESERVED.  HOWEVER,
9175CCCCC                 WHEN EVALUATING FUNCTION, WE NEED THE STRING
9176CCCCC                 TO BE EVALUATED IN UPPER CASE.
9177C
9178      DO91I=1,NUMCHA
9179        ITEMP=ICHAR(IA(I)(1:1))
9180        IF(ITEMP.GE.97 .AND. ITEMP.LE.122)THEN
9181          ITEMP=ITEMP-32
9182          IA(I)(1:1)=CHAR(ITEMP)
9183        ENDIF
9184   91 CONTINUE
9185C
9186C     BLANK-OUT AND ZERO-OUT SOME VARIABLES AND VECTORS.
9187C
9188      Y=0.0
9189      DO160I=1,NUMCHA
9190        IR(I)='    '
9191        IB(I)='    '
9192        IW21(I)='    '
9193        IW22(I)='    '
9194        W2(I)=0.0
9195        ITYPE(I)='    '
9196        IW21HO(I)='    '
9197        IW22HO(I)='    '
9198        W2HOLD(I)=0.0
9199        ITYPEH(I)='    '
9200  160 CONTINUE
9201C
9202C     THE FOLLOWING LOOP WAS PUT IN TO AVOID A PROBLEM
9203C     ESSENTAILLY CAUSED IN DPLIB1 AND WHICH
9204C     SHOWED UP IN  LET A = 1 1 3   LET A = ABS(A)   LET B = A
9205C     MARY BETH    12/88
9206C
9207      DO161I=1,10
9208        IR(I)='    '
9209  161 CONTINUE
9210C
9211C               ************************************
9212C               **  STEP 1--                      **
9213C               **  OPERATE ON THE VECTOR IA(.).  **
9214C               **  SQUEEZE OUT ALL BLANKS.       **
9215C               **  OUTPUT THE VECTOR IB(.).      **
9216C               ************************************
9217C
9218      K=0
9219      DO100I=1,NUMCHA
9220        IF(IA(I).EQ.' ')GOTO100
9221        CALL DPXH1H(IA(I),ICH,ILASTC,IBUGCO)
9222        IF(ILASTC.LE.0)GOTO100
9223        DO150J=1,ILASTC
9224          K=K+1
9225          IB(K)=ICH(J)
9226  150   CONTINUE
9227  100 CONTINUE
9228      NCTOT=K
9229      IF(NCTOT.LT.1)THEN
9230        WRITE(ICOUT,21)
9231        CALL DPWRST('XXX','BUG ')
9232        WRITE(ICOUT,105)NCTOT
9233  105   FORMAT('      TOTAL NUMBER OF CHARACTERS IN MODEL (INCLUDING ',
9234     1         'BOTH SIDES, BLANKS, AND EQUAL SIGN) IS < 1.  NCTOT = ',
9235     1         I5)
9236        CALL DPWRST('XXX','BUG ')
9237        WRITE(ICOUT,171)NUMCHA,N,IPASS
9238  171   FORMAT('NUMCHA,N,IPASS = ',3I8)
9239        CALL DPWRST('XXX','BUG ')
9240        WRITE(ICOUT,172)(IA(I),I=1,MIN(80,NUMCHA))
9241  172   FORMAT('IA--',80A1)
9242        CALL DPWRST('XXX','BUG ')
9243C
9244        WRITE(ICOUT,999)
9245        CALL DPWRST('XXX','BUG ')
9246        WRITE(ICOUT,181)NUMPAR
9247  181   FORMAT('NUMPAR = ',I8)
9248        CALL DPWRST('XXX','BUG ')
9249        IF(NUMPAR.GT.0)THEN
9250          DO182I=1,NUMPAR
9251            WRITE(ICOUT,183)I,IPARN1(I),IPARN2(I),PARAM(I)
9252  183       FORMAT('I,IPARN1(I),IPARN2(I),PARAM(I) = ',I8,2(2X,A4),2X,
9253     1             F15.7)
9254            CALL DPWRST('XXX','BUG ')
9255  182     CONTINUE
9256        ENDIF
9257        IERROR='YES'
9258        GOTO9000
9259      ENDIF
9260C
9261      IF(IBUGCO.EQ.'ON')THEN
9262        ISTEPN='1'
9263        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9264        WRITE(ICOUT,191)NCTOT
9265  191   FORMAT('NCTOT = ',I8)
9266        CALL DPWRST('XXX','BUG ')
9267        DO192I=1,NCTOT
9268          WRITE(ICOUT,193)I,IB(I)
9269  193     FORMAT('I,IB(I) = ',I5,2X,A4)
9270          CALL DPWRST('XXX','BUG ')
9271  192   CONTINUE
9272      ENDIF
9273C
9274C               *********************************************************
9275C               **  STEP 2--                                           **
9276C               **  OPERATE ON THE VECTOR IB(.).                       **
9277C               **  DETERMINE THE NUMBER OF CHARACTERS (IF ANY)        **
9278C               **  FOR THE LEFT-HAND SIDE.  OUTPUT THEM INTO THE      **
9279C               **  VECTOR IL(.).                                      **
9280C               *********************************************************
9281C
9282      DO500I=1,NCTOT
9283        I2=I
9284        IF(IB(I).EQ.'=')THEN
9285          NCL=I2-1
9286          ISTARR=I2+1
9287          GOTO559
9288        ENDIF
9289  500 CONTINUE
9290      NCL=0
9291      ISTARR=1
9292  559 CONTINUE
9293C
9294      IF(NCL.GT.0)THEN
9295        DO600I=1,NCL
9296          IL(I)=IB(I)
9297  600   CONTINUE
9298      ENDIF
9299C
9300      IF(IBUGCO.EQ.'ON')THEN
9301        ISTEPN='2'
9302        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9303        WRITE(ICOUT,691)NCL
9304  691   FORMAT('NCL = ',2I8)
9305        CALL DPWRST('XXX','BUG ')
9306        DO692I=1,NCL
9307          WRITE(ICOUT,693)I,IL(I)
9308  693     FORMAT('I,IL(I) = ',I5,2X,A4)
9309          CALL DPWRST('XXX','BUG ')
9310  692   CONTINUE
9311      ENDIF
9312C
9313C               *********************************************************
9314C               **  STEP 3--                                           **
9315C               **  OPERATE ON THE VECTOR IB(.).  DETERMINE THE        **
9316C               **  NUMBER OF CHARACTERS FOR RIGHT-HAND SIDE.          **
9317C               **  OUTPUT THEM INTO THE VECTOR IR(.).                 **
9318C               *********************************************************
9319C
9320      IF(ISTARR.GT.NCTOT)THEN
9321        WRITE(ICOUT,21)
9322        CALL DPWRST('XXX','BUG ')
9323        WRITE(ICOUT,702)
9324  702   FORMAT('      THE NUMBER OF CHARACTERS ON THE RIGHT (WITH ',
9325     1         'BLANKS IGNORED)')
9326        CALL DPWRST('XXX','BUG ')
9327        WRITE(ICOUT,703)
9328  703   FORMAT('      IS 0.  THE TOTAL NUMBER OF PACKED CHARACTERS ',
9329     1         'LEFT')
9330        CALL DPWRST('XXX','BUG ')
9331        WRITE(ICOUT,704)NCTOT
9332  704   FORMAT('      (IF ANY), EQUAL SIGN (IF ANY), AND RIGHT = ',I8)
9333        CALL DPWRST('XXX','BUG ')
9334        WRITE(ICOUT,707)ISTARR
9335  707   FORMAT('      THE START POSITION FOR THE PACKED RIGHT IS ',
9336     1         'COLUMN ',I8)
9337        CALL DPWRST('XXX','BUG ')
9338        WRITE(ICOUT,709)NUMCHA
9339  709   FORMAT('      THE INPUT NUMBER OF CHARACTERS NUMCHA = ',I8)
9340        CALL DPWRST('XXX','BUG ')
9341        IF(NUMCHA.GE.1)THEN
9342          WRITE(ICOUT,31)(IA(I),I=1,MIN(100,NUMCHA))
9343          CALL DPWRST('XXX','BUG ')
9344        ENDIF
9345        IERROR='YES'
9346        GOTO9000
9347      ENDIF
9348C
9349      K=0
9350      DO700I=ISTARR,NCTOT
9351        K=K+1
9352        IR(K)=IB(I)
9353  700 CONTINUE
9354      NCR=K
9355C
9356      IF(IBUGCO.EQ.'ON')THEN
9357        ISTEPN='3'
9358        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9359        WRITE(ICOUT,791)NCR
9360  791   FORMAT('NCR = ',2I8)
9361        CALL DPWRST('XXX','BUG ')
9362        DO792I=1,NCR
9363          WRITE(ICOUT,793)I,IR(I)
9364  793     FORMAT('I,IR(I) = ',I5,2X,A4)
9365          CALL DPWRST('XXX','BUG ')
9366  792   CONTINUE
9367      ENDIF
9368C
9369C               ********************************************************
9370C               **  STEP 4--                                          **
9371C               **  OPERATE ON THE VECTOR IR(.).  ANALYZE THE         **
9372C               **  RIGHT-HAND SIDE.  DETERMINE THE NUMBER OF         **
9373C               **  DIFFERENT LOGICAL COMPONENTS.                     **
9374C               **     1. NUMBER (CONSISTING OF 0,1,2,...,9 OR .)     **
9375C               **     2. X VARIABLE                                  **
9376C               **     3. OPERATION (+   -   *   /   **)              **
9377C               **     4. PARENTHESES (   (   OR   )    )             **
9378C               **     5. LIBRARY FUNCTION (ALOG   EXP   ETC +        **
9379C               **        AUGMENTED LIB.                              **
9380C               **     6. COMMA (FOR MULTI-ARGUMENT LIBRARY FUNCTIONS)**
9381C               **     7. PARAMETER (ANYTHING NOT ABOVE)              **
9382C               **  CHECK FOR SYNTAX ERRORS.                          **
9383C               **  OUTPUT THE TYPE COMPONENT INTO ITYPE(.).          **
9384C               **  OUTPUT THE START LOCATION IN IR(.) OF EACH        **
9385C               **  OUTPUT THE STOP  LOCATION IN IR(.) OF EACH        **
9386C               **  COMPONENT INTO IE                                 **
9387C               ********************************************************
9388C
9389      NW=0
9390      I=1
9391 1050 CONTINUE
9392      IP1=I+1
9393      IP2=I+2
9394      IP3=I+3
9395      IP4=I+4
9396      IP5=I+5
9397C
9398      IF(IR(I).EQ.'0' .OR. IR(I).EQ.'1' .OR. IR(I).EQ.'2' .OR.
9399     1   IR(I).EQ.'3' .OR. IR(I).EQ.'4' .OR. IR(I).EQ.'5' .OR.
9400     1   IR(I).EQ.'6' .OR. IR(I).EQ.'7' .OR. IR(I).EQ.'8' .OR.
9401     1   IR(I).EQ.'9' .OR. IR(I).EQ.'.')THEN
9402        NW=NW+1
9403        ITYPE(NW)='N'
9404        JMIN=I
9405        J=I
9406 1150   CONTINUE
9407        J=J+1
9408        IF(J.LE.NCR)THEN
9409          IF(IR(J).EQ.'0' .OR. IR(J).EQ.'1' .OR. IR(J).EQ.'2' .OR.
9410     1       IR(J).EQ.'3' .OR. IR(J).EQ.'4' .OR. IR(J).EQ.'5' .OR.
9411     1       IR(J).EQ.'6' .OR. IR(J).EQ.'7' .OR. IR(J).EQ.'8' .OR.
9412     1       IR(J).EQ.'9' .OR. IR(J).EQ.'.')THEN
9413               GOTO1150
9414          ENDIF
9415        ENDIF
9416        JMAX=J-1
9417        GOTO1800
9418      ELSEIF(IR(I).EQ.'+' .OR. IR(I).EQ.'-' .OR. IR(I).EQ.'*' .OR.
9419     1   IR(I).EQ.'/')THEN
9420        NW=NW+1
9421        ITYPE(NW)='OP'
9422        JMIN=I
9423        JMAX=I
9424        IP1=I+1
9425        IF(IR(I).EQ.'*'.AND.IR(IP1).EQ.'*')JMAX=IP1
9426        GOTO1800
9427      ELSEIF(IR(I).EQ.'(')THEN
9428        NW=NW+1
9429        ITYPE(NW)='LP'
9430        JMIN=I
9431        JMAX=I
9432        GOTO1800
9433      ELSEIF(IR(I).EQ.')')THEN
9434        NW=NW+1
9435        ITYPE(NW)='RP'
9436        JMIN=I
9437        JMAX=I
9438        GOTO1800
9439      ELSEIF(IR(I).EQ.',')THEN
9440        NW=NW+1
9441        ITYPE(NW)='COM'
9442        JMIN=I
9443        JMAX=I
9444        GOTO1800
9445      ENDIF
9446C
9447C     CHECK FOR A LIBRARY FUNCTION.
9448C
9449      CALL CKLIB1(IR,NCR,I,IFOUND,NCLF,IBUGEV,IERROR)
9450      IF(IERROR.EQ.'YES')GOTO9000
9451      IF(IFOUND.EQ.'NO')CALL CKLIB2(IR,NCR,I,IFOUND,NCLF,IBUGEV,IERROR)
9452      IF(IERROR.EQ.'YES')GOTO9000
9453C
9454      IF(IFOUND.EQ.'YES')THEN
9455        IF(NCLF.GE.1 .AND. NCLF.LE.8)THEN
9456          NW=NW+1
9457          ITYPE(NW)='LF'
9458          JMIN=I
9459          JMAX=I+NCLF-1
9460          GOTO1800
9461        ENDIF
9462      ENDIF
9463C
9464      NW=NW+1
9465      ITYPE(NW)='PAR'
9466      NLPWP=0
9467      NRPWP=0
9468      JMIN=I
9469      J=I
9470      ILOOP=0
9471 1650 CONTINUE
9472      J=J+1
9473      IF(J.LE.NCR)THEN
9474        IF(IR(J).EQ.'+' .OR. IR(J).EQ.'-' .OR.
9475     1     IR(J).EQ.'*' .OR. IR(J).EQ.'/' .OR.
9476     1     IR(J).EQ.',')GOTO1660
9477        IF(IR(J).EQ.'(')NLPWP=NLPWP+1
9478        IF(IR(J).EQ.')')NRPWP=NRPWP+1
9479        IF(IR(J).EQ.')'.AND.NRPWP.GT.NLPWP)GOTO1660
9480        ILOOP=ILOOP+1
9481        IF(ILOOP.LE.NUMAS2)GOTO1650
9482C
9483        WRITE(ICOUT,21)
9484        CALL DPWRST('XXX','BUG ')
9485        WRITE(ICOUT,1656)NUMAS2
9486 1656   FORMAT('      PARAMETER NAME EXCEEDS ',I8,' CHARACTERS')
9487        CALL DPWRST('XXX','BUG ')
9488        DO1657K=JMIN,J
9489          WRITE(ICOUT,1658)K,IR(K)
9490 1658     FORMAT('K, IR(K) = ',I8,2X,A4)
9491          CALL DPWRST('XXX','BUG ')
9492 1657   CONTINUE
9493        IERROR='YES'
9494        GOTO9000
9495      ENDIF
9496C
9497 1660 CONTINUE
9498      JMAX=J-1
9499C
9500 1800 CONTINUE
9501C
9502C     CHECK THAT NW HAS NOT EXCEEDED MAXCHA (USUALLY 80)
9503C
9504      IF(NW.GT.MAXCHA)THEN
9505        WRITE(ICOUT,21)
9506        CALL DPWRST('XXX','BUG ')
9507        WRITE(ICOUT,1902)
9508 1902   FORMAT('      THE VARIABLE NW HAS JUST EXCEEDED THE MAXIMUM ',
9509     1         'ALLOWABLE')
9510        CALL DPWRST('XXX','BUG ')
9511        WRITE(ICOUT,1903)
9512 1903   FORMAT('      LIMIT DEFINED BY THE INTERNAL VARIABLE MAXCHA.')
9513        CALL DPWRST('XXX','BUG ')
9514        WRITE(ICOUT,1904)MAXCHA
9515 1904   FORMAT('      THIS LIMIT IS MAXCHA = ',I8)
9516        CALL DPWRST('XXX','BUG ')
9517        WRITE(ICOUT,1905)NUMCHA
9518 1905   FORMAT('      THE INPUT NUMBER OF CHARACTERS NUMCHA = ',I8)
9519        CALL DPWRST('XXX','BUG ')
9520        IF(NUMCHA.GE.1)THEN
9521          WRITE(ICOUT,31)(IA(I),I=1,MIN(100,NUMCHA))
9522          CALL DPWRST('XXX','BUG ')
9523        ENDIF
9524        WRITE(ICOUT,1907)
9525 1907   FORMAT('      THE NUMBER OF (PACKED) CHARACTERS ON ',
9526     1         'RIGHT-HAND SIDE = ',I8)
9527        CALL DPWRST('XXX','BUG ')
9528        IF(NCR.GE.1)THEN
9529          WRITE(ICOUT,1908)(IR(I),I=1,MIN(95,NCR))
9530 1908     FORMAT('      (PACKED) RIGHT-HAND SIDE--',95A1)
9531          CALL DPWRST('XXX','BUG ')
9532        ENDIF
9533        IERROR='YES'
9534        GOTO9000
9535      ENDIF
9536C
9537      IBEGIN(NW)=JMIN
9538      IEND(NW)=JMAX
9539      I=JMAX
9540C
9541      I=I+1
9542      IF(I.LE.NCR)GOTO1050
9543C
9544C     TEST THAT NW IS POSITIVE.
9545C
9546      IF(NW.LT.1)THEN
9547        WRITE(ICOUT,21)
9548        CALL DPWRST('XXX','BUG ')
9549        WRITE(ICOUT,1951)NW
9550 1951   FORMAT('      NW IS NON-POSITIVE.  NW = ',I8)
9551        CALL DPWRST('XXX','BUG ')
9552        IERROR='YES'
9553        GOTO9000
9554      ELSEIF(NW.EQ.1)THEN
9555        DO1960I=1,NW
9556          IP1=I+1
9557          IF(ITYPE(I).EQ.'LF'.AND.ITYPE(IP1).NE.'LP')THEN
9558            WRITE(ICOUT,21)
9559            CALL DPWRST('XXX','BUG ')
9560            WRITE(ICOUT,1962)
9561 1962       FORMAT('      LIBRARY FUNCTION NOT FOLLOWED BY A LEFT ',
9562     1             'PARENTHESES')
9563            CALL DPWRST('XXX','BUG ')
9564            WRITE(ICOUT,1963)NW
9565 1963       FORMAT('             NW = ',I8)
9566            CALL DPWRST('XXX','BUG ')
9567            WRITE(ICOUT,1964)I
9568 1964       FORMAT('             I  = ',I8)
9569            CALL DPWRST('XXX','BUG ')
9570            WRITE(ICOUT,1965)ITYPE(I)
9571 1965       FORMAT('             ITYPE(I) = ',A4)
9572            CALL DPWRST('XXX','BUG ')
9573            WRITE(ICOUT,1966)ITYPE(IP1)
9574 1966       FORMAT('             ITYPE(I+1) = ',A4)
9575            CALL DPWRST('XXX','BUG ')
9576            IERROR='YES'
9577            GOTO9000
9578          ENDIF
9579 1960   CONTINUE
9580      ENDIF
9581C
9582      IF(ITYPE(NW).EQ.'OP')THEN
9583        WRITE(ICOUT,21)
9584        CALL DPWRST('XXX','BUG ')
9585        WRITE(ICOUT,1971)ITYPE(NW)
9586 1971   FORMAT('      LAST TERM IN TOTAL EXPRESSION IS AN OPERATION = ',
9587     1         A4)
9588        CALL DPWRST('XXX','BUG ')
9589        IERROR='YES'
9590        GOTO9000
9591      ELSEIF(ITYPE(NW).EQ.'LF')THEN
9592        WRITE(ICOUT,21)
9593        CALL DPWRST('XXX','BUG ')
9594        WRITE(ICOUT,1973)ITYPE(NW)
9595 1973   FORMAT('      LAST TERM IN TOTAL EXPRESSION = A LIBRARY ',
9596     1         'FUNCTION = ',A4)
9597        CALL DPWRST('XXX','BUG ')
9598        WRITE(ICOUT,1975)IPASS,NW
9599 1975   FORMAT('IPASS,NW = ',2I8)
9600        CALL DPWRST('XXX','BUG ')
9601        IF(NW.GE.1)THEN
9602          WRITE(ICOUT,1976)ITYPE(NW)
9603 1976     FORMAT('ITYPE(NW) = ',A4)
9604          CALL DPWRST('XXX','BUG ')
9605        ENDIF
9606        IERROR='YES'
9607        GOTO9000
9608      ENDIF
9609C
9610      IF(IBUGCO.EQ.'ON')THEN
9611        ISTEPN='4'
9612        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9613        WRITE(ICOUT,1991)NW
9614 1991   FORMAT('NW = ',I8)
9615        CALL DPWRST('XXX','BUG ')
9616        DO1992I=1,NW
9617          ICMIN=IBEGIN(I)
9618          ICMINP=ICMIN+1
9619          ICMINQ=ICMIN+2
9620          WRITE(ICOUT,1993)I,IR(ICMIN),IR(ICMINP),IR(ICMINQ),ITYPE(I),
9621     1                     IBEGIN(I),IEND(I)
9622 1993     FORMAT('I,IR(ICMIN),IR(ICMIN+1),IR(ICMIN+2),ITYPE(I),',
9623     1           'IBEGIN(I),IEND(I) = ',I8,2X,4A4,2(2X,I8))
9624          CALL DPWRST('XXX','BUG ')
9625 1992   CONTINUE
9626      ENDIF
9627C
9628C               ********************************************************
9629C               **  STEP 5--                                          **
9630C               **  OPERATE ON EACH COMPONENT OF THE VECTOR IR(.).    **
9631C               **  CONVERT THE NUMBERS TO FLOATING POINT VALUES.     **
9632C               **  CONVERT THE PARAMATERS TO FLOATING POINT VALUES.  **
9633C               **  SET THE X TO AN DUMMY VALUE OF 0.0 FOR THE TIME BEING.
9634C               **  CONVERT THE OPERATIONS INTO A 1-WORD REPRESENTATION.
9635C               **  'CONVERT' THE PARENTHESES INTO A 1-WORD REPRESENTATION.
9636C               **  CONVERT THE COEFFICIENTS TO COEFFICIENT VALUES.   **
9637C               **  CONVERT THE LIBRARY FUNCTIONS INTO A 1-WORD REPRESENTATION.
9638C               **  SAVE THE CONTENTS OF ITYPE, IW21, IW22, AND W2 IN **
9639C               **  ITYPEH, IW21HO, IW22HO, AND WHOLD FOR LATER USE   **
9640C               **  IN REDEFINING ITYPE, IW21, IW22, AND W2 FOR EACH NEW X VALUE
9641C               **  OUTPUT THE VECTORS IW21, IW22 AND W2.             **
9642C               **  OUTPUT THE VECTORS IW21HO, IW22HO, W2HOLD, AND ITYPEH.
9643C               ********************************************************
9644C
9645      DO3000I=1,NW
9646        ICMIN=IBEGIN(I)
9647        ICMAX=IEND(I)
9648        IF(ITYPE(I).EQ.'N')THEN
9649          W2(I)=0.0
9650          IANS1='    '
9651          IANS2='    '
9652          IANS3='    '
9653          IANS4='    '
9654          J=0
9655          DO3150IC=ICMIN,ICMAX
9656            J=J+1
9657            JM1=J-1
9658            L=J-(NUMASC*(JM1/NUMASC))
9659            K=NUMBPC*(L-1)
9660            K=IABS(K)
9661            IF(J.LE.NUMASC)THEN
9662              CALL DPCHEX(0,NUMBPC,IR(IC),K,NUMBPC,IANS1)
9663            ELSEIF(J.LE.NUMAS2)THEN
9664              CALL DPCHEX(0,NUMBPC,IR(IC),K,NUMBPC,IANS2)
9665            ELSEIF(J.LE.NUMAS3)THEN
9666              CALL DPCHEX(0,NUMBPC,IR(IC),K,NUMBPC,IANS3)
9667            ELSEIF(J.LE.NUMAS4)THEN
9668              CALL DPCHEX(0,NUMBPC,IR(IC),K,NUMBPC,IANS4)
9669            ENDIF
9670 3150     CONTINUE
9671          ERRMAX=10.0**9
9672          ERRMIN=-ERRMAX
9673          CALL ERRORF(IANS1,IANS2,IANS3,IANS4,ERRMIN,ERRMAX,
9674     1                ERRMAX,ANS2,IERROR)
9675          IF(IERROR.EQ.'YES')GOTO9000
9676          W2(I)=ANS2
9677          GOTO3000
9678        ELSEIF(ITYPE(I).EQ.'X')THEN
9679          W2(I)=0.0
9680          GOTO3000
9681        ELSEIF(ITYPE(I).EQ.'OP')THEN
9682          IW21(I)=IR(ICMIN)
9683          ICMINP=ICMIN+1
9684          IF(IR(ICMIN).EQ.'*'.AND.IR(ICMINP).EQ.'*')IW21(I)='**'
9685          GOTO3000
9686        ELSEIF(ITYPE(I).EQ.'LP'.OR.ITYPE(I).EQ.'RP')THEN
9687          IW21(I)=IR(ICMIN)
9688          GOTO3000
9689        ELSEIF(ITYPE(I).EQ.'PAR')THEN
9690          IW21(I)='    '
9691          IW22(I)='    '
9692          ICMAX2=ICMIN+NUMAS2-1
9693          IF(ICMAX.LE.ICMAX2)ICMAX2=ICMAX
9694          J=0
9695          DO3550IC=ICMIN,ICMAX2
9696            J=J+1
9697            J2=J
9698            IF(J2.GT.NUMASC)J2=J-NUMASC
9699            ISTAR3=NUMBPC*(J2-1)
9700            ISTAR3=IABS(ISTAR3)
9701            IF(J.LE.NUMASC)THEN
9702              CALL DPCHEX(0,NUMBPC,IR(IC),ISTAR3,NUMBPC,IW21(I))
9703            ELSE
9704              CALL DPCHEX(0,NUMBPC,IR(IC),ISTAR3,NUMBPC,IW22(I))
9705            ENDIF
9706 3550     CONTINUE
9707C
9708          IF(IPASS.EQ.1)GOTO3000
9709C
9710          DO3570J=1,NUMPAR
9711            IF(IW21(I).EQ.IPARN1(J).AND.IW22(I).EQ.IPARN2(J))THEN
9712              W2(I)=PARAM(J)
9713              GOTO3000
9714            ENDIF
9715 3570     CONTINUE
9716          WRITE(ICOUT,21)
9717          CALL DPWRST('XXX','BUG ')
9718          WRITE(ICOUT,3571)
9719 3571     FORMAT('      NO MATCH FOR PARAMETER/VARIABLE NAME')
9720          CALL DPWRST('XXX','BUG ')
9721          WRITE(ICOUT,3572)IW21(I),IW22(I)
9722 3572     FORMAT('               GIVEN PARAMETER/VARIABLE NAME = ',2A4)
9723          CALL DPWRST('XXX','BUG ')
9724          WRITE(ICOUT,3573)NUMPAR
9725 3573     FORMAT('               NUMBER OF PARAMETER/VARIABLE =',I8)
9726          CALL DPWRST('XXX','BUG ')
9727          WRITE(ICOUT,3574)
9728 3574     FORMAT('               ADMISSIBLE PARAMETER/VARIABLE ',
9729     1           'NAMES = ')
9730          CALL DPWRST('XXX','BUG ')
9731          DO3575J=1,NUMPAR
9732            WRITE(ICOUT,3576)J,IPARN1(J),IPARN2(J)
9733 3576       FORMAT('               PARAMETER/VARIABLE NAME ',I4,'--',
9734     1             2A4)
9735            CALL DPWRST('XXX','BUG ')
9736 3575     CONTINUE
9737          WRITE(ICOUT,3577)(IA(J),J=1,MIN(100,NUMCHA))
9738 3577     FORMAT('      FUNCTION EXPRESSION--',100A1)
9739          CALL DPWRST('XXX','BUG ')
9740          IERROR='YES'
9741          GOTO9000
9742        ELSEIF(ITYPE(I).EQ.'LF')THEN
9743          IW21(I)='    '
9744          IW22(I)='    '
9745          ICMAX2=ICMIN+NUMAS2-1
9746          IF(ICMAX.LE.ICMAX2)ICMAX2=ICMAX
9747          J=0
9748          DO3650IC=ICMIN,ICMAX2
9749            J=J+1
9750            J2=J
9751            IF(J2.GT.NUMASC)J2=J-NUMASC
9752            ISTAR3=NUMBPC*(J2-1)
9753            ISTAR3=IABS(ISTAR3)
9754            IF(J.LE.NUMASC)THEN
9755              CALL DPCHEX(0,NUMBPC,IR(IC),ISTAR3,NUMBPC,IW21(I))
9756            ELSE
9757              CALL DPCHEX(0,NUMBPC,IR(IC),ISTAR3,NUMBPC,IW22(I))
9758            ENDIF
9759 3650     CONTINUE
9760          GOTO3000
9761        ELSEIF(ITYPE(I).EQ.'COM')THEN
9762          IW21(I)=IR(ICMIN)
9763          GOTO3000
9764        ENDIF
9765C
9766        WRITE(ICOUT,21)
9767        CALL DPWRST('XXX','BUG ')
9768        WRITE(ICOUT,3005)
9769 3005   FORMAT('      ITYPE(I) NOT X, OP, LP, PAR, OR LF')
9770        CALL DPWRST('XXX','BUG ')
9771        WRITE(ICOUT,3006)I,ITYPE(I),IW21(I),W2(I)
9772 3006   FORMAT('I,ITYPE(I),IW21(I),W2(I) = ',I8,2(2X,A4),2X,F15.7)
9773        CALL DPWRST('XXX','BUG ')
9774        IERROR='YES'
9775        GOTO9000
9776C
9777 3000 CONTINUE
9778C
9779      NWHOLD=NW
9780      DO3900I=1,NW
9781        ITYPEH(I)=ITYPE(I)
9782        IW21HO(I)=IW21(I)
9783        IW22HO(I)=IW22(I)
9784        W2HOLD(I)=W2(I)
9785 3900 CONTINUE
9786C
9787      IF(IBUGCO.EQ.'ON')THEN
9788        ISTEPN='5'
9789        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9790        DO3992I=1,NW
9791          ICMIN=IBEGIN(I)
9792          ICMINP=ICMIN+1
9793          ICMINQ=ICMIN+2
9794          WRITE(ICOUT,3993)I,IR(ICMIN),IR(ICMINP),IR(ICMINQ),ITYPE(I),
9795     1                     IW21(I),IW22(I),W2(I)
9796 3993     FORMAT('I,IR(ICMIN),IR(ICMIN+1),IR(ICMIN+2),ITYPE(I),W21(I),',
9797     1           'IW22HO(I),W2(I) = ',I8,2X,3A4,3(2X,A4),2X,F15.6)
9798          CALL DPWRST('XXX','BUG ')
9799 3992   CONTINUE
9800      ENDIF
9801C
9802C               ****************************************************
9803C               **  STEP 6--                                      **
9804C               **  THIS STEP IS TO BE EXECUTED IF IPASS=1;       **
9805C               **  OTHERWISE IT IS SKIPPED.                      **
9806C               **  IF THIS STEP IS EXECUTED, STEP 7 IS NOT;      **
9807C               **  IF THIS STEP IS NOT EXECUTED, STEP 7 IS.      **
9808C               **  OPERATE ON IW21, IW22, AND ITYPE VECTORS.      **
9809C               **  DETERMINE THE NUMBER OF DISTINCT PARAMETERS.  **
9810C               **  FORM THE OUTPUT VECTOR IPARN.                 **
9811C               ****************************************************
9812C
9813      IF(IPASS.EQ.1)THEN
9814C
9815        NUMPAR=0
9816        DO4100I=1,NW
9817          IF(ITYPE(I).NE.'PAR')GOTO4100
9818          IF(NUMPAR.GT.0)THEN
9819            DO4400J=1,NUMPAR
9820              IF(IW21(I).EQ.IPARN1(J).AND.IW22(I).EQ.IPARN2(J))GOTO4100
9821 4400       CONTINUE
9822          ENDIF
9823          NUMPAR=NUMPAR+1
9824          IPARN1(NUMPAR)=IW21(I)
9825          IPARN2(NUMPAR)=IW22(I)
9826 4100   CONTINUE
9827        GOTO9000
9828      ENDIF
9829C
9830C               *********************************************************
9831C               **  STEP 7-- C                                         **
9832C               **  OPERATE ON THE W2(.), IW21(.), AND IW22(.) VECTORS.**
9833C               **  THIS STEP IS NOT EXECUTED IF STEP 6 IS; THIS STEP  **
9834C               **  IS EXECUTED IF STEP 6 IS NOT.  FIRST MAKE SURE THAT**
9835C               **  THE NUMBER OF LEFT AND RIGHT PARENTHESES ARE THE   **
9836C               **  SAME.  (STEP 6 THEN SETS UP A LARGE DO LOOP WHICH  **
9837C               **  GOES THROUGH ALL OF THE VALUES OF THE X VECTOR AND **
9838C               **  GENERATES CORRESPONDING VALUES OF THE Y VECTOR.)   **
9839C               **  FOR A GIVEN X VALUE, IT EVALUATES THE FUNCTION BY  **
9840C               **  FIRST SEEKING THE INNERMOST PARENTHESES (BY        **
9841C               **  SEARCHING FOR THE FIRST REMAINING RIGHT PARENTHESS).*
9842C               **  AND THEN EVALUATING ALL SUCH PARENTHETICAL         **
9843C               **  EXPRESSIONS--WORKING FROM THE INNERMOST OUT. AFTER **
9844C               **  EVALUATING A PARENTHESES PAIR, THE ENTIRE          **
9845C               **  PARENTHESES GROUP (PARENTHESES INCLUDED) IS        **
9846C               **  REPLACED BY THE SCALAR ANSWER.  THE IW21, IW22,    **
9847C               **  W2, AND ITYPE VECTORS ARE SQUEEZED ACCORDING (IN   **
9848C               **  THE SUBROUTINE EVAL).  SINCE THE VECTORS IW21,     **
9849C               **  IW22, W2, AND ITYPE ARE ALTERED FOR EACH X VALUE,  **
9850C               **  THEY MUST BE REDEFINED FROM THE SAVED VALUES IN    **
9851C               **  IW21HO, IW22HO, W2HOLD, AND ITYPEH FOR EACH NEW X  **
9852C               **  THE ABOVE SQUEEZING OPERATION IS REPEATED FOR EACH **
9853C               **  PARENTHESES PAIR UNTIL ALL PARENTHESES ARE GONE    **
9854C               **  AND WE REMAIN ONLY WITH THE FINAL ANSWER.  FOR     **
9855C               **  EACH VALUE X(.) OF THE INPUT X VECTOR, OUTPUT THE  **
9856C               **  CORRESPONDING VALUE Y(.) OF THE DESIRED OUTPUT     **
9857C               **  VECTOR.  FOR A GIVEN VALUE X(.), THE CORRESPONDING **
9858C               **  COMPUTED Y(.) WILL BE THE EVALUATED VALUE OF THE   **
9859C               **  RIGHT-HAND SIDE OF THE SPECIFIED EQUATION Y = F(X).**
9860C               *********************************************************
9861C
9862 5000 CONTINUE
9863C
9864      NW=NWHOLD
9865      DO5050I=1,NW
9866        ITYPE(I)=ITYPEH(I)
9867        IW21(I)=IW21HO(I)
9868        IW22(I)=IW22HO(I)
9869        W2(I)=W2HOLD(I)
9870 5050 CONTINUE
9871C
9872      DO5060I=1,NW
9873        IF(ITYPE(I).EQ.'PAR')THEN
9874          IF(NUMPAR.GT.0)THEN
9875            DO5070J=1,NUMPAR
9876              J2=J
9877              IF(IW21(I).EQ.IPARN1(J).AND.IW22(I).EQ.IPARN2(J))THEN
9878                W2(I)=PARAM(J2)
9879                GOTO5060
9880              ENDIF
9881 5070       CONTINUE
9882          ENDIF
9883C
9884          WRITE(ICOUT,21)
9885          CALL DPWRST('XXX','BUG ')
9886          WRITE(ICOUT,5071)
9887 5071     FORMAT('      NO MATCH FOR PARAMETER/VARIABLE NAME')
9888          CALL DPWRST('XXX','BUG ')
9889          WRITE(ICOUT,5072)IW21(I),IW22(I)
9890 5072     FORMAT('      GIVEN PARAMETER/VARIABLE NAME = ',2A4)
9891          CALL DPWRST('XXX','BUG ')
9892          WRITE(ICOUT,5073)NUMPAR
9893 5073     FORMAT('      NUMBER OF PARAMETERS/VARIABLES =',I8)
9894          CALL DPWRST('XXX','BUG ')
9895          WRITE(ICOUT,5074)
9896 5074     FORMAT('      ADMISSIBLE PARAMETER/VARIABLE NAMES = ')
9897          CALL DPWRST('XXX','BUG ')
9898          DO5075J=1,NUMPAR
9899            WRITE(ICOUT,5076)J,IPARN1(J),IPARN2(J)
9900 5076       FORMAT('      PARAMETER/VARIABLE NAME ',I3,'--',2A4)
9901            CALL DPWRST('XXX','BUG ')
9902 5075     CONTINUE
9903          WRITE(ICOUT,5077)(IA(J),J=1,MIN(100,NUMCHA))
9904 5077     FORMAT('      FUNCTION EXPRESSION--',100A1)
9905          CALL DPWRST('XXX','BUG ')
9906          IERROR='YES'
9907          GOTO9000
9908C
9909        ELSEIF(ITYPE(I).EQ.'N'  .OR. ITYPE(I).EQ.'X'  .OR.
9910     1         ITYPE(I).EQ.'OP' .OR. ITYPE(I).EQ.'LP' .OR.
9911     1         ITYPE(I).EQ.'RP' .OR. ITYPE(I).EQ.'LF' .OR.
9912     1         ITYPE(I).EQ.'COM')THEN
9913          GOTO5060
9914        ELSE
9915          WRITE(ICOUT,21)
9916          CALL DPWRST('XXX','BUG ')
9917          WRITE(ICOUT,5061)
9918 5061     FORMAT('      ITYPE(I) NOT X, OP, LP, PAR, OR LF')
9919          CALL DPWRST('XXX','BUG ')
9920          WRITE(ICOUT,5062)I,ITYPE(I),IW21(I),IW22(I),W2(I)
9921 5062     FORMAT('I,ITYPE(I),IW21(I),IW22(I),W2(I) = ',
9922     1           I8,3(2X,A4),2X,F15.7)
9923          CALL DPWRST('XXX','BUG ')
9924          IERROR='YES'
9925          GOTO9000
9926        ENDIF
9927 5060 CONTINUE
9928C
9929      NLP=0
9930      NRP=0
9931      DO5100I=1,NW
9932        IF(ITYPE(I).EQ.'LP')NLP=NLP+1
9933        IF(ITYPE(I).EQ.'RP')NRP=NRP+1
9934 5100 CONTINUE
9935C
9936      IF(NLP.NE.NRP)THEN
9937        WRITE(ICOUT,21)
9938        CALL DPWRST('XXX','BUG ')
9939        WRITE(ICOUT,5156)
9940 5156   FORMAT('      NUMBER OF LEFT PARENTHESES NOT EQUAL TO ',
9941     1         'NUMBER OF RIGHT PARENTHESES')
9942        CALL DPWRST('XXX','BUG ')
9943        WRITE(ICOUT,5157)NLP
9944 5157   FORMAT('      NUMBER OF LEFT  PARENTHESES = ',I8)
9945        CALL DPWRST('XXX','BUG ')
9946        WRITE(ICOUT,5158)NRP
9947 5158   FORMAT('      NUMBER OF RIGHT PARENTHESES = ',I8)
9948        CALL DPWRST('XXX','BUG ')
9949        IERROR='YES'
9950        GOTO9000
9951      ENDIF
9952C
9953CCCCC ADD FOLLOWING LINES APRIL 1995.
9954CCCCC 2010/12: INITIALIZE TO CPUMIN RATHER THAN -99.9.
9955CCCCC          NEED TO MODIFY DPLIB1, DPLIB2, DPLIB3 TO
9956CCCCC          CHECK FOR CPUMIN RATHER THAN -99.9.
9957C
9958      ILIBC1=0
9959      ILIBC2=0
9960      DO5195IJ=1,MAXNST
9961        SAVE1(IJ)=CPUMIN
9962        SAVE2(IJ)=CPUMIN
9963        SAVE3(IJ)=CPUMIN
9964        SAVE4(IJ)=CPUMIN
9965        SAVE5(IJ)=CPUMIN
9966        SAVE6(IJ)=CPUMIN
9967        SAVE7(IJ)=CPUMIN
9968        SAVE8(IJ)=CPUMIN
9969 5195 CONTINUE
9970C
9971      DO10000II=1,N
9972C
9973        IF(II.GT.1)THEN
9974          NW=NWHOLD
9975          DO5200I=1,NW
9976            ITYPE(I)=ITYPEH(I)
9977            IW21(I)=IW21HO(I)
9978            IW22(I)=IW22HO(I)
9979            W2(I)=W2HOLD(I)
9980 5200     CONTINUE
9981        ENDIF
9982C
9983        IF(IBUGCO.EQ.'ON')THEN
9984          ISTEPN='7'
9985          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9986          DO5250I=1,NW
9987            WRITE(ICOUT,5251)I,IW21HO(I),IW22HO(I),IW21(I),IW22(I)
9988 5251       FORMAT('I,IW21HO(I),IW22HO(I),IW21(I),IW22(I) = ',
9989     1             I8,4(2X,A4))
9990            CALL DPWRST('XXX','BUG ')
9991 5250     CONTINUE
9992        ENDIF
9993C
9994        ILOOP=1
9995 5350   CONTINUE
9996        DO5400I=1,NW
9997          I2=I
9998          IF(ITYPE(I).EQ.'RP')THEN
9999            ISTOP=I2
10000            DO5600JJ=1,ISTOP
10001              IREV=ISTOP-JJ+1
10002              IF(ITYPE(IREV).EQ.'LP')THEN
10003                ISTART=IREV
10004                GOTO5690
10005              ENDIF
10006 5600       CONTINUE
10007            WRITE(ICOUT,21)
10008            CALL DPWRST('XXX','BUG ')
10009            WRITE(ICOUT,5605)
10010 5605       FORMAT('      ITYPE(IREV) NOT LP')
10011            CALL DPWRST('XXX','BUG ')
10012            ISTART=IREV
10013            GOTO5690
10014          ENDIF
10015 5400   CONTINUE
10016        ISTOP=NW+1
10017        ISTART=0
10018 5690   CONTINUE
10019C
10020        ISTAP1=ISTART+1
10021        ISTOM1=ISTOP-1
10022        IJUNK=ISTART-1
10023        IF(IJUNK.GE.1)THEN
10024          IF(ITYPE(IJUNK).EQ.'LF')ILIBC1=ILIBC1+1
10025        ENDIF
10026        CALL EVALM(IW21,IW22,W2,ITYPE,ISTAP1,ISTOM1,IANGLU,Y,
10027     1             SAVE1,SAVE2,SAVE3,SAVE4,SAVE5,SAVE6,SAVE7,SAVE8,
10028     1             ILIBC1,ILIBC2,IBUGEV,IERROR)
10029        IF(IERROR.EQ.'YES')GOTO9000
10030C
10031        IF(ISTART.GT.0)THEN
10032          W2(ISTART)=Y
10033          ITYPE(ISTART)='V'
10034          IF(NW.GT.1)THEN
10035            ISTOPP=ISTOP+1
10036            J=ISTART
10037            IF(ISTOP.NE.NW)THEN
10038              DO5700I=ISTOPP,NW
10039                J=J+1
10040                IW21(J)=IW21(I)
10041                IW22(J)=IW22(I)
10042                W2(J)=W2(I)
10043                ITYPE(J)=ITYPE(I)
10044 5700         CONTINUE
10045            ENDIF
10046            NW=J
10047            GOTO5350
10048          ENDIF
10049        ENDIF
1005010000 CONTINUE
10051C
10052C               *****************
10053C               **  STEP 90--  **
10054C               **  EXIT       **
10055C               *****************
10056C
10057 9000 CONTINUE
10058      IF(IBUGCO.EQ.'ON')THEN
10059        WRITE(ICOUT,999)
10060        CALL DPWRST('XXX','BUG ')
10061        WRITE(ICOUT,9011)
10062 9011   FORMAT('***** AT THE END       OF COMPIM--')
10063        CALL DPWRST('XXX','BUG ')
10064        DO9113I=1,MAXNST
10065          WRITE(ICOUT,9013)I,SAVE1(I),SAVE2(I),SAVE3(I),SAVE4(I),Y
10066 9013     FORMAT('I,SAVE1,SAVE2,SAVE3,SAVE4,Y = ',I3,5E15.7)
10067          CALL DPWRST('XXX','BUG ')
10068 9113   CONTINUE
10069        WRITE(ICOUT,9014)NUMCHA,N,IPASS,NW,IANGLU
10070 9014   FORMAT('NUMCHA,N,IPASS,NW,IANGLU = ',4I8,2X,A4)
10071        CALL DPWRST('XXX','BUG ')
10072        IF(NW.GE.1)THEN
10073          WRITE(ICOUT,9022)ITYPE(NW)
10074 9022     FORMAT('ITYPE(NW) = ',A4)
10075          CALL DPWRST('XXX','BUG ')
10076        ENDIF
10077      ENDIF
10078C
10079      RETURN
10080      END
10081      DOUBLE PRECISION FUNCTION CONDIT( N, SYMIN )
10082*
10083*     Computes condition number of symmetric matix in situ
10084*
10085      INTEGER NL, N
10086      PARAMETER ( NL = 100 )
10087      DOUBLE PRECISION DET, SYMIN(*), SUM, ROWMX, ROWMXI,
10088     & SYM(NL*(NL+1)/2)
10089      INTEGER II, IJ, I, J, IM
10090      ROWMX = 0
10091      IJ = 0
10092      DO 100 I = 1,N
10093         SUM = 0
10094         IM = (I-2)*(I-1)/2
10095         DO 200 J = 1,I-1
10096            IM = IM + 1
10097            SUM = SUM + ABS(SYMIN(IM))
10098            IJ = IJ + 1
10099            SYM(IJ) = SYMIN(IM)
10100  200    CONTINUE
10101         SUM = SUM + 1
10102         IJ = IJ + 1
10103         SYM(IJ) = 1
10104         IM = IM + I
10105         DO 300 J = I,N-1
10106            SUM = SUM + ABS(SYMIN(IM))
10107            IM = IM + J
10108  300    CONTINUE
10109         ROWMX = MAX( SUM, ROWMX )
10110  100 CONTINUE
10111      CALL SYMINV(N, SYM, DET)
10112      ROWMXI = 0
10113      II = 0
10114      DO 400 I = 1,N
10115         SUM = 0
10116         IJ = II
10117         DO 500 J = 1,I
10118            IJ = IJ + 1
10119            SUM = SUM + ABS(SYM(IJ))
10120 500     CONTINUE
10121         DO 600 J = I,N-1
10122            IJ = IJ + J
10123            SUM = SUM + ABS(SYM(IJ))
10124 600     CONTINUE
10125         ROWMXI = MAX( SUM, ROWMXI )
10126         II = II + I
10127 400  CONTINUE
10128      CONDIT = ROWMX*ROWMXI
10129C
10130      RETURN
10131      END
10132      SUBROUTINE CONINS(X,Y,NPT,XX,YY,NPTC)
10133C
10134C     PURPOSE--INCORPORATE AN INTERIOR CLOSED CONTOUR SEGMENT
10135C              INTO ANOTHER SEGMENT
10136C
10137C     RECOMMENDED DIMENSIONS--
10138C        X(NPT+NPTC+1)
10139C        Y(NPT+NPTC+1)
10140C        XX(NPTC)
10141C        YY(NPTC)
10142C        LC(4)
10143C
10144C     WRITTEN BY--DAVID W. BEHRINGER NOAA/AOML (MIAMI).
10145C                 AS PART OF NOAA'S CONCX V.3   MARCH 1988.
10146C     ORIGINAL VERSION (IN DATAPLOT)--AUGUST    1988.
10147C
10148C---------------------------------------------------------------------
10149C
10150CCCCC DIMENSION X(NPT+NPTC+1),Y(NPT+NPTC+1),XX(NPTC),YY(NPTC),LC(4)
10151C
10152      DIMENSION X(*)
10153      DIMENSION Y(*)
10154      DIMENSION XX(*)
10155      DIMENSION YY(*)
10156C
10157      DIMENSION LC(4)
10158C
10159C-----START POINT-----------------------------------------------------
10160C
10161C   FIRST FIND UP, DOWN, LEFT & RIGHT EXTREMES OF AN INTERIOR SEGMENT
10162      DO 10 I=1,4
10163        LC(I)=1
10164 10   CONTINUE
10165      DO 20 L=1,NPTC
10166        IF (XX(L).LT.XX(LC(1))) LC(1)=L
10167        IF (YY(L).GT.YY(LC(2))) LC(2)=L
10168        IF (XX(L).GT.XX(LC(3))) LC(3)=L
10169        IF (YY(L).LT.YY(LC(4))) LC(4)=L
10170 20   CONTINUE
10171C   FIND A REASONABLY CLOSE APPROACH OF INTERIOR SEGMENT TO THE CONTINUOUS
10172C                        STRING
10173      L1=LC(1)
10174      L0=1
10175      DMN=SQRT((XX(L1)-X(L0))**2+(YY(L1)-Y(L0))**2)
10176      DO 100 L=1,NPT
10177        DO 200 I=1,4
10178          LL=LC(I)
10179          DTST=SQRT((XX(LL)-X(L))**2+(YY(LL)-Y(L))**2)
10180          IF (DTST.LT.DMN) THEN
10181            DMN=DTST
10182            L0=L
10183            L1=LL
10184          END IF
10185 200    CONTINUE
10186 100  CONTINUE
10187C   REORDER THE INTERIOR SEGMENT
10188      DO 300 L=1,L1-1
10189        HX=XX(1)
10190        HY=YY(1)
10191        DO 400 LL=2,NPTC-1
10192          XX(LL-1)=XX(LL)
10193          YY(LL-1)=YY(LL)
10194 400    CONTINUE
10195        XX(NPTC-1)=HX
10196        YY(NPTC-1)=HY
10197 300  CONTINUE
10198      XX(NPTC)=XX(1)
10199      YY(NPTC)=YY(1)
10200C   INSERT THE INTERIOR SEGMENT INTO THE CONTINUOUS STRING
10201      DO 500 L=NPT,L0,-1
10202        X(L+1)=X(L)
10203        Y(L+1)=Y(L)
10204 500  CONTINUE
10205      NPT=NPT+1
10206      L0=L0+1
10207      L2=NPT+1
10208      L3=NPTC+L2
10209      NPT=L3-1
10210      DO 600 L=L2,NPT
10211        LL=L-L2+1
10212        X(L)=XX(LL)
10213        Y(L)=YY(LL)
10214 600  CONTINUE
10215      CALL STRSWP(X,L0,L2,L3)
10216      CALL STRSWP(Y,L0,L2,L3)
10217      RETURN
10218      END
10219      SUBROUTINE CONCDF(DX,DSHAPE,DM,ICONDF,DCDF)
10220C
10221C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
10222C              FUNCTION VALUE FOR THE CONSUL DISTRIBUTION WITH SHAPE
10223C              PARAMETERS THETA AND M.  THIS DISTRIBUTION IS
10224C              DEFINED FOR ALL INTEGER X >= 1.
10225C
10226C              THIS DISTRIBUTION REDUCES TO THE GEOMETRIC
10227C              DISTRIBUTION WHEN M = 1.  FOR THIS REASON, IT
10228C              SOMETIMES REFERRED TO AS THE GENERALIZED GEOMETRIC
10229C              DISTRIBUTION.  NOTE THAT THIS DISTRIBUTION HAS A
10230C              SIMILAR FORM TO THE GEETA DISTRIBUTION.
10231C
10232C              THE PROBABILITY MASS FUNCTION IS:
10233C              p(X;THETA,M)=
10234C                  (M*X  X-1)*THETA**(X-1)*(1-THETA)**(M*X-X+1)/X
10235C                  X = 1, 2, 3, ,...
10236C                  0 < THETA < 1; 1 <= M < 1/THETA
10237C
10238C              A RECURRENCE RELATION FOR THE CDF FUNCTION IS
10239C
10240C                  P(X;THETA,M) = {(M-1)*(X-1)+1}/(X-1)}*
10241C                                 THETA*(1-TYHETA)**(M-1)*
10242C                                 PROD[i=1 to X-2][(1 + M/(M*X-M-i)]*
10243C                                 P(X-1;THETA,M)
10244C
10245C              THIS DISTRIBUTION IS SOMETIMES PARAMETERIZED USING
10246C              THE MEAN (MU) INSTEAD OF THETA.  THIS RESULTS IN
10247C              THE PROBABILITY MASS FUNCTION:
10248C              p(X;MU,M)=
10249C                  (M*X  X-1)*((MU-1)/(M*MU))**(X-1)*
10250C                  (1 - (M-1)/(M*MU))**(M*X-X+1)/X
10251C                  X = 1, 2, 3, ,...
10252C                  MU >= 1; M > 1
10253C              NOTE THAT THE RELATION IS:
10254C
10255C                  THETA=(MU-1)/(M*MU)
10256C
10257C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
10258C                                WHICH THE CUMULATIVE DISTRIBUTION
10259C                                FUNCTION IS TO BE EVALUATED.
10260C                                X SHOULD BE A NON-NEGATIVE INTEGER.
10261C                     --DSHAPE = THE FIRST SHAPE PARAMETER
10262C                                (EITHER THETA OR MU)
10263C                     --DM     = THE SECOND SHAPE PARAMETER
10264C     OUTPUT ARGUMENTS--DCDF   = THE DOUBLE PRECISION CUMULATIVE
10265C                                DISTRIBUTION FUNCTION VALUE.
10266C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION FUNCTION
10267C             VALUE CDF FOR THE CONSUL DISTRIBUTION WITH SHAPE
10268C             PARAMETERS THETA (OR MU) AND M
10269C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
10270C     RESTRICTIONS--X SHOULD BE A POSITIVE INTEGER
10271C                 --0 < THETA < 1; 1 < M < 1/THETA
10272C                 --MU >= 1; M > 1
10273C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
10274C     LANGUAGE--ANSI FORTRAN (1977)
10275C     REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
10276C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTER 8.
10277C     WRITTEN BY--JAMES J. FILLIBEN
10278C                 STATISTICAL ENGINEERING DIVISION
10279C                 INFORMATION TECHNOLOGY LABORATORY
10280C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
10281C                 GAITHERSBURG, MD 20899-8980
10282C                 PHONE--301-975-2855
10283C     LANGUAGE--ANSI FORTRAN (1977)
10284C     VERSION NUMBER--2006/8
10285C     ORIGINAL VERSION--AUGUST    2006.
10286C
10287C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
10288C
10289C---------------------------------------------------------------------
10290C
10291      DOUBLE PRECISION DX
10292      DOUBLE PRECISION DSHAPE
10293      DOUBLE PRECISION DM
10294      DOUBLE PRECISION DCDF
10295      DOUBLE PRECISION DPDF
10296      DOUBLE PRECISION DPDFSV
10297C
10298      DOUBLE PRECISION DTERM1
10299      DOUBLE PRECISION DTERM2
10300      DOUBLE PRECISION DTERM3
10301      DOUBLE PRECISION DTHETA
10302      DOUBLE PRECISION DMU
10303      DOUBLE PRECISION DSUM
10304C
10305      CHARACTER*4 ICONDF
10306      CHARACTER*4 ICOND2
10307C
10308C---------------------------------------------------------------------
10309C
10310      INCLUDE 'DPCOP2.INC'
10311C
10312C-----START POINT-----------------------------------------------------
10313C
10314C     CHECK THE INPUT ARGUMENTS FOR ERRORS
10315C
10316      IF(ICONDF.EQ.'THET')THEN
10317        DTHETA=DSHAPE
10318      ELSE
10319        DMU=DSHAPE
10320        DTHETA=(DMU-1.0D0)/(DM*DMU)
10321      ENDIF
10322C
10323      IX=INT(DX+0.5D0)
10324      IF(IX.LT.1)THEN
10325        WRITE(ICOUT,4)
10326        CALL DPWRST('XXX','BUG ')
10327        WRITE(ICOUT,46)DX
10328        CALL DPWRST('XXX','BUG ')
10329        DCDF=0.0D0
10330        GOTO9000
10331      ENDIF
10332    4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO CONCDF IS LESS ',
10333     1'THAN 1')
10334C
10335      IF(ICONDF.EQ.'THET')THEN
10336        IF(DTHETA.LE.0.0D0 .OR. DTHETA.GE.1.0D0)THEN
10337          WRITE(ICOUT,15)
10338          CALL DPWRST('XXX','BUG ')
10339          WRITE(ICOUT,46)DTHETA
10340          CALL DPWRST('XXX','BUG ')
10341          DCDF=0.0
10342          GOTO9000
10343        ENDIF
10344   15   FORMAT('***** ERROR--THE SECOND ARGUMENT TO CONCDF IS NOT ',
10345     1         'IN THE INTERVAL (0,1)')
10346C
10347        IF(DM.LT.1.0D0 .OR. DM.GE.1.0D0/DTHETA)THEN
10348          WRITE(ICOUT,25)1.0D0/DTHETA
10349          CALL DPWRST('XXX','BUG ')
10350          WRITE(ICOUT,46)DM
10351          CALL DPWRST('XXX','BUG ')
10352          DCDF=0.0
10353          GOTO9000
10354        ENDIF
10355   25   FORMAT('***** ERROR--THE THIRD ARGUMENT TO CONCDF IS NOT ',
10356     1         'IN THE INTERVAL (1,',G15.7,')')
10357      ELSE
10358        IF(DMU.LT.1.0D0)THEN
10359          WRITE(ICOUT,35)
10360          CALL DPWRST('XXX','BUG ')
10361          WRITE(ICOUT,46)DMU
10362          CALL DPWRST('XXX','BUG ')
10363          DCDF=0.0
10364          GOTO9000
10365        ENDIF
10366   35   FORMAT('***** ERROR--THE SECOND ARGUMENT TO CONCDF IS ',
10367     1         'LESS THAN 1')
10368C
10369        IF(DM.LT.1.0D0)THEN
10370          WRITE(ICOUT,38)
10371          CALL DPWRST('XXX','BUG ')
10372          WRITE(ICOUT,46)DM
10373          CALL DPWRST('XXX','BUG ')
10374          DCDF=0.0
10375          GOTO9000
10376        ENDIF
10377   38   FORMAT('***** ERROR--THE THIRD ARGUMENT TO CONCDF IS ',
10378     1         'LESS THAN 1')
10379      ENDIF
10380C
10381   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
10382C
10383      DCDF=(1.0D0 - DTHETA)**DM
10384      IF(IX.EQ.1)THEN
10385        GOTO9000
10386      ELSE
10387        DX=2.0D0
10388        ICOND2='THET'
10389        CALL CONPDF(DX,DTHETA,DM,ICOND2,DPDF)
10390        DCDF=DCDF+DPDF
10391        IF(IX.EQ.2)GOTO9000
10392        DX=3.0D0
10393        CALL CONPDF(DX,DTHETA,DM,ICOND2,DPDF)
10394        DCDF=DCDF+DPDF
10395        IF(IX.EQ.3)GOTO9000
10396        DPDFSV=DPDF
10397      ENDIF
10398C
10399      DO100I=4,IX
10400        DX=DBLE(I)
10401        DTERM1=DLOG(DTHETA) + (DM-1.0D0)*DLOG(1.0D0 - DTHETA)
10402        DTERM2=DLOG((DM-1.0D0)*(DX-1.0D0) + 1.0D0) - DLOG(DX-1.0D0)
10403        DTERM3=DTERM1 + DTERM2
10404        DSUM=0.0D0
10405        DO200J=1,I-2
10406          DSUM=DSUM + DLOG(1.0D0 + DM/(DM*DX - DM - DBLE(J)))
10407  200   CONTINUE
10408        IF(DPDFSV.GT.0.0D0)THEN
10409          DPDF=DEXP(DTERM3 + DSUM + DLOG(DPDFSV))
10410        ELSE
10411          GOTO9000
10412        ENDIF
10413        DCDF=DCDF + DPDF
10414        DPDFSV=DPDF
10415  100 CONTINUE
10416C
10417 9000 CONTINUE
10418      RETURN
10419      END
10420      SUBROUTINE CONFOU(ISUBRO,IBUGA3,IERROR)
10421C
10422C     PURPOSE--CREATE STRINGS FOR CONFOUNDING FOR CERTAIN
10423C              TWO-LEVEL DESIGNS.
10424C     EXAMPLE--LET CON COP = CONFOUND  N K
10425C
10426C              BASED ON VALUES OF N AND K, A NUMBER OF STRINGS
10427C              STARTING WITH "CON" AND "COP" WILL BE CREATED.
10428C     WRITTEN BY--ALAN HECKERT
10429C                 STATISTICAL ENGINEERING DIVISION
10430C                 INFORMATION TECHNOLOGY LABORATORY
10431C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
10432C                 GAITHERSBURG, MD 20899-8980
10433C                 PHONE--301-975-2899
10434C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
10435C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
10436C     LANGUAGE--ANSI FORTRAN (1977)
10437C     VERSION NUMBER--2015/01
10438C     ORIGINAL VERSION--JANUARY   2015.
10439C
10440C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
10441C
10442      CHARACTER*4 ISUBRO
10443      CHARACTER*4 IBUGA3
10444      CHARACTER*4 IERROR
10445C
10446      CHARACTER*8 IHLEFT
10447      CHARACTER*4 IHLEF2
10448      CHARACTER*4 IHRIGH
10449      CHARACTER*4 IHRIG2
10450C
10451      CHARACTER*8 ISTR1
10452      CHARACTER*8 ISTR2
10453      CHARACTER*8   ISTRZ1
10454      CHARACTER*16  ISTRZ2
10455C
10456      CHARACTER*4 ISUBN1
10457      CHARACTER*4 ISUBN2
10458      CHARACTER*4 ISTEPN
10459C
10460C---------------------------------------------------------------------
10461C
10462C-----COMMON----------------------------------------------------------
10463C
10464      INCLUDE 'DPCOPA.INC'
10465      INCLUDE 'DPCOHK.INC'
10466      INCLUDE 'DPCOHO.INC'
10467      INCLUDE 'DPCODA.INC'
10468C
10469C-----COMMON VARIABLES (GENERAL)--------------------------------------
10470C
10471      INCLUDE 'DPCOP2.INC'
10472C
10473C-----START POINT-----------------------------------------------------
10474C
10475      ISUBN1='CONF'
10476      ISUBN2='OU  '
10477      IERROR='NO'
10478C
10479      N=-1
10480      K=-1
10481      ILOC3=0
10482C
10483      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NFOU')THEN
10484        WRITE(ICOUT,999)
10485  999   FORMAT(1X)
10486        CALL DPWRST('XXX','BUG ')
10487        WRITE(ICOUT,51)
10488   51   FORMAT('***** AT THE BEGINNING OF CONFOU--')
10489        CALL DPWRST('XXX','BUG ')
10490        WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMNAM
10491   52   FORMAT('IBUGA3,ISUBRO,NUMNAM = ',A4,2X,A4,2X,I8)
10492        CALL DPWRST('XXX','BUG ')
10493        DO55I=1,NUMNAM
10494          WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),
10495     1                   IVSTOP(I)
10496   56     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
10497     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
10498          CALL DPWRST('XXX','BUG ')
10499   55   CONTINUE
10500        WRITE(ICOUT,57)NUMCHF,MAXCHF
10501   57   FORMAT('NUMCHF,MAXCHF = ',2I8)
10502        CALL DPWRST('XXX','BUG ')
10503        WRITE(ICOUT,60)(IFUNC(I),I=1,MIN(120,MAXCHF))
10504   60   FORMAT('IFUNC(.)  = ',120A1)
10505        CALL DPWRST('XXX','BUG ')
10506      ENDIF
10507C
10508C               **********************************
10509C               **  STEP 1--                    **
10510C               **  ERROR CHECKING--EXACTLY 6   **
10511C               **  AGUMENTS REQUIRED.          **
10512C               **********************************
10513C
10514      ISTEPN='1'
10515      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NFOU')
10516     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10517C
10518      IF(NUMARG.NE.6)THEN
10519        WRITE(ICOUT,999)
10520        CALL DPWRST('XXX','BUG ')
10521        WRITE(ICOUT,101)
10522  101   FORMAT('***** ERROR IN CONFOUND--')
10523        CALL DPWRST('XXX','BUG ')
10524        WRITE(ICOUT,103)
10525  103   FORMAT('      EXACTLY SIX ARGUMENTS EXPECTED.')
10526        CALL DPWRST('XXX','BUG ')
10527        WRITE(ICOUT,105)NUMARG
10528  105   FORMAT('      ',I3,' ARGUMENTS GIVEN.')
10529        CALL DPWRST('XXX','BUG ')
10530        IERROR='YES'
10531        GOTO9000
10532      ENDIF
10533C
10534C               **********************************
10535C               **  STEP 2--                    **
10536C               **  EXTRACT VALUES FOR N AND K  **
10537C               **  FROM RIGHT HAND SIDE.       **
10538C               **********************************
10539C
10540      ISTEPN='1'
10541      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NFOU')
10542     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10543C
10544C     N AND K CAN EITHER BE PREVIOUSLY DEFINED PARAMETERS OR
10545C     SIMPLY NUMBERS.  ANY OTHER TYPE IS AN ERROR.
10546C
10547      IHRIGH=IHARG(5)
10548      IHRIG2=IHARG2(5)
10549C
10550      DO210I=1,NUMNAM
10551        IF(IHRIGH(1:4).EQ.IHNAME(I)(1:4) .AND.
10552     1     IHRIG2(1:4).EQ.IHNAM2(I)(1:4))THEN
10553            AK=VALUE(I)
10554            GOTO219
10555        ENDIF
10556  210 CONTINUE
10557C
10558C     NAME NOT FOUND.  CHECK IF ARGUMENT IS A NUMBER.
10559C
10560      IF(IARGT(5).EQ.'NUMB')THEN
10561        AK=ARG(5)
10562      ELSE
10563        WRITE(ICOUT,999)
10564        CALL DPWRST('XXX','BUG ')
10565        WRITE(ICOUT,101)
10566        CALL DPWRST('XXX','BUG ')
10567        WRITE(ICOUT,203)
10568  203   FORMAT('      THE NUMBER OF FACTORS ARGUMENT WAS NOT FOUND')
10569        CALL DPWRST('XXX','BUG ')
10570        WRITE(ICOUT,205)
10571  205   FORMAT('      AS EITHER A PARAMETER OR A NUMBER.')
10572        CALL DPWRST('XXX','BUG ')
10573        WRITE(ICOUT,207)IHARG(5),IHARG2(5)
10574  207   FORMAT('      THE ARGUMENT IS: ',2A4)
10575        CALL DPWRST('XXX','BUG ')
10576        IERROR='YES'
10577        GOTO9000
10578      ENDIF
10579  219 CONTINUE
10580C
10581      IHRIGH=IHARG(6)
10582      IHRIG2=IHARG2(6)
10583C
10584      DO260I=1,NUMNAM
10585        IF(IHRIGH(1:4).EQ.IHNAME(I)(1:4) .AND.
10586     1     IHRIG2(1:4).EQ.IHNAM2(I)(1:4))THEN
10587            AN=VALUE(I)
10588            GOTO269
10589        ENDIF
10590  260 CONTINUE
10591C
10592C     NAME NOT FOUND.  CHECK IF ARGUMENT IS A NUMBER.
10593C
10594      IF(IARGT(6).EQ.'NUMB')THEN
10595        AN=ARG(6)
10596      ELSE
10597        WRITE(ICOUT,999)
10598        CALL DPWRST('XXX','BUG ')
10599        WRITE(ICOUT,101)
10600        CALL DPWRST('XXX','BUG ')
10601        WRITE(ICOUT,263)
10602  263   FORMAT('      THE SAMPLE SIZE ARGUMENT WAS NOT FOUND')
10603        CALL DPWRST('XXX','BUG ')
10604        WRITE(ICOUT,265)
10605  265   FORMAT('      AS EITHER A PARAMETER OR A NUMBER.')
10606        CALL DPWRST('XXX','BUG ')
10607        WRITE(ICOUT,267)IHARG(6),IHARG2(6)
10608  267   FORMAT('      THE ARGUMENT IS: ',2A4)
10609        CALL DPWRST('XXX','BUG ')
10610        IERROR='YES'
10611        GOTO9000
10612      ENDIF
10613C
10614  269 CONTINUE
10615C
10616      IF(AK.GT.AN)THEN
10617        AKSAV=AK
10618        AK=AN
10619        AN=AKSAV
10620      ENDIF
10621C
10622      K=INT(AK+0.1)
10623      NTEMP=INT(AN+0.1)
10624C
10625      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NFOU')THEN
10626        WRITE(ICOUT,291)K,NTEMP
10627  291   FORMAT('K,NTEMP = ',2I8)
10628        CALL DPWRST('XXX','BUG ')
10629      ENDIF
10630C
10631C               *************************************************
10632C               **  STEP 3--                                   **
10633C               **  EXTRACT THE BASE NAMES ON THE LHS OF THE   **
10634C               **  EQUAL SIGN AND THEN LOOP THROUGH THE       **
10635C               **  NUMBER OF STRINGS TO CREATE.               **
10636C               *************************************************
10637C
10638      ISTEPN='3'
10639      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NFOU')
10640     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10641C
10642      IHLEFT(1:4)=IHARG(1)
10643      IHLEFT(5:8)=IHARG2(1)
10644      NBASE1=1
10645      DO310I=8,1,-1
10646        IF(IHLEFT(I:I).NE.' ')THEN
10647          NBASE1=I
10648          GOTO319
10649        ENDIF
10650  310 CONTINUE
10651  319 CONTINUE
10652C
10653      ISTR1=' '
10654      IF(NBASE1.LE.4)THEN
10655        ISTR1(1:NBASE1)=IHLEFT(1:NBASE1)
10656      ELSE
10657        ISTR1(1:4)=IHLEFT(1:4)
10658        NCHR=NBASE1-5+1
10659        ISTR1(5:NBASE1)=IHLEF2(1:NCHR)
10660      ENDIF
10661C
10662      IHLEFT(1:4)=IHARG(2)
10663      IHLEFT(5:8)=IHARG2(2)
10664      NBASE2=1
10665      DO360I=8,1,-1
10666        IF(IHLEFT(I:I).NE.' ')THEN
10667          NBASE2=I
10668          GOTO369
10669        ENDIF
10670  360 CONTINUE
10671  369 CONTINUE
10672C
10673      ISTR2=' '
10674      IF(NBASE2.LE.4)THEN
10675        ISTR2(1:NBASE2)=IHLEFT(1:NBASE2)
10676      ELSE
10677        ISTR2(1:4)=IHLEFT(1:4)
10678        NCHR=NBASE2-5+1
10679        ISTR2(5:NBASE2)=IHLEF2(1:NCHR)
10680      ENDIF
10681C
10682      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NFOU')THEN
10683        WRITE(ICOUT,391)NBASE1,NBASE2,ISTR1,ISTR2
10684  391   FORMAT('NBASE1,NBASE2,ISTR1,ISTR2 = ',2I8,2(2X,A4))
10685        CALL DPWRST('XXX','BUG ')
10686      ENDIF
10687C
10688C               **********************************
10689C               **  STEP 4--                    **
10690C               **  STEP THROUGH THE SUPPORTED  **
10691C               **  K/N COMBINATIONS AND CREATE **
10692C               **  THE STRINGS.                **
10693C               **********************************
10694C
10695      ISTEPN='4'
10696      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NFOU')
10697     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10698C
10699      IF(NTEMP.EQ.4)THEN
10700        IF(K.EQ.2)THEN
10701C
10702C         K = 2, N = 4 (2**2)
10703C
10704C           CON1   = 1
10705C           CON2   = 2
10706C           CON12  = 12
10707C
10708C           COP1   = 1
10709C           COP2   = 2
10710C           COP12  = 12
10711C
10712C         MAKE SURE STRING NAME WILL HAVE <= 8 CHARACTERS
10713C
10714          IF(NBASE1.GT.6)THEN
10715            IERROR='YES'
10716            GOTO8010
10717          ELSEIF(NBASE2.GT.6)THEN
10718            IERROR='YES'
10719            GOTO8010
10720          ENDIF
10721C
10722C         NOW CREATE THE STRINGS
10723C
10724          ISTR1(NBASE1+1:NBASE1+1)='1'
10725          ISTRZ1(1:1)='1'
10726          NCHAR=1
10727          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
10728          IF(IERROR.EQ.'YES')GOTO8020
10729C
10730          ISTR1(NBASE1+1:NBASE1+1)='2'
10731          ISTRZ1(1:1)='2'
10732          NCHAR=1
10733          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
10734          IF(IERROR.EQ.'YES')GOTO8020
10735C
10736          ISTR1(NBASE1+1:NBASE1+2)='12'
10737          ISTRZ1(1:2)='12'
10738          NCHAR=2
10739          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
10740          IF(IERROR.EQ.'YES')GOTO8020
10741C
10742          ISTR2(NBASE2+1:NBASE2+1)='1'
10743          ISTRZ2(1:1)='1'
10744          NCHAR=1
10745          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
10746          IF(IERROR.EQ.'YES')GOTO8020
10747C
10748          ISTR2(NBASE2+1:NBASE2+1)='2'
10749          ISTRZ2(1:1)='2'
10750          NCHAR=1
10751          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
10752          IF(IERROR.EQ.'YES')GOTO8020
10753C
10754          ISTR2(NBASE2+1:NBASE2+2)='12'
10755          ISTRZ2(1:2)='12'
10756          NCHAR=2
10757          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
10758          IF(IERROR.EQ.'YES')GOTO8020
10759C
10760        ELSEIF(K.EQ.3)THEN
10761C
10762C         K = 3, N = 4 (2**(3-1)
10763C
10764C           CON1   = 1
10765C           CON2   = 2
10766C           CON12  = 3
10767C
10768C           COP1   = 1+23
10769C           COP2   = 2+13
10770C           COP12  = 3+12
10771C
10772C         MAKE SURE STRING NAME WILL HAVE <= 8 CHARACTERS
10773C
10774          IF(NBASE1.GT.6)THEN
10775            IERROR='YES'
10776            GOTO8010
10777          ELSEIF(NBASE2.GT.6)THEN
10778            IERROR='YES'
10779            GOTO8010
10780          ENDIF
10781C
10782C         NOW CREATE THE STRINGS
10783C
10784          ISTR1(NBASE1+1:NBASE1+1)='1'
10785          ISTRZ1(1:1)='1'
10786          NCHAR=1
10787          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
10788          IF(IERROR.EQ.'YES')GOTO9000
10789C
10790          ISTR1(NBASE1+1:NBASE1+1)='2'
10791          ISTRZ1(1:1)='2'
10792          NCHAR=1
10793          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
10794          IF(IERROR.EQ.'YES')GOTO9000
10795C
10796          ISTR1(NBASE1+1:NBASE1+2)='12'
10797          ISTRZ1(1:1)='3'
10798          NCHAR=1
10799          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
10800          IF(IERROR.EQ.'YES')GOTO9000
10801C
10802          ISTR2(NBASE2+1:NBASE2+1)='1'
10803          ISTRZ2(1:4)='1+23'
10804          NCHAR=4
10805          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
10806          IF(IERROR.EQ.'YES')GOTO9000
10807C
10808          ISTR2(NBASE2+1:NBASE2+1)='2'
10809          ISTRZ2(1:4)='2+13'
10810          NCHAR=4
10811          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
10812          IF(IERROR.EQ.'YES')GOTO9000
10813C
10814          ISTR2(NBASE2+1:NBASE2+2)='12'
10815          ISTRZ2(1:4)='3+12'
10816          NCHAR=4
10817          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
10818          IF(IERROR.EQ.'YES')GOTO9000
10819C
10820        ELSE
10821          IERROR='YES'
10822          GOTO8030
10823        ENDIF
10824      ELSEIF(NTEMP.EQ.8)THEN
10825        IF(K.EQ.3)THEN
10826C
10827C         K = 3, N = 8 (2**3)
10828C
10829C           CON1   = 1
10830C           CON2   = 2
10831C           CON3   = 3
10832C           CON12  = 12
10833C           CON13  = 13
10834C           CON23  = 23
10835C           CON123 = 123
10836C
10837C           COP1   = 1
10838C           COP2   = 2
10839C           COP3   = 3
10840C           COP12  = 12
10841C           COP13  = 13
10842C           COP23  = 23
10843C           COP123 = 123
10844C
10845C         MAKE SURE STRING NAME WILL HAVE <= 8 CHARACTERS
10846C
10847          IF(NBASE1.GT.5)THEN
10848            IERROR='YES'
10849            GOTO8010
10850          ELSEIF(NBASE2.GT.5)THEN
10851            IERROR='YES'
10852            GOTO8010
10853          ENDIF
10854C
10855C         NOW CREATE THE STRINGS
10856C
10857          ISTR1(NBASE1+1:NBASE1+1)='1'
10858          ISTRZ1(1:1)='1'
10859          NCHAR=1
10860          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
10861          IF(IERROR.EQ.'YES')GOTO9000
10862C
10863          ISTR1(NBASE1+1:NBASE1+1)='2'
10864          ISTRZ1(1:1)='2'
10865          NCHAR=1
10866          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
10867          IF(IERROR.EQ.'YES')GOTO9000
10868C
10869          ISTR1(NBASE1+1:NBASE1+2)='3'
10870          ISTRZ1(1:1)='3'
10871          NCHAR=1
10872          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
10873          IF(IERROR.EQ.'YES')GOTO9000
10874C
10875          ISTR1(NBASE1+1:NBASE1+2)='12'
10876          ISTRZ1(1:2)='12'
10877          NCHAR=2
10878          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
10879          IF(IERROR.EQ.'YES')GOTO9000
10880C
10881          ISTR1(NBASE1+1:NBASE1+2)='13'
10882          ISTRZ1(1:2)='13'
10883          NCHAR=2
10884          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
10885          IF(IERROR.EQ.'YES')GOTO9000
10886C
10887          ISTR1(NBASE1+1:NBASE1+2)='23'
10888          ISTRZ1(1:2)='23'
10889          NCHAR=2
10890          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
10891          IF(IERROR.EQ.'YES')GOTO9000
10892C
10893          ISTR1(NBASE1+1:NBASE1+3)='123'
10894          ISTRZ1(1:3)='123'
10895          NCHAR=3
10896          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
10897          IF(IERROR.EQ.'YES')GOTO9000
10898C
10899          ISTR2(NBASE2+1:NBASE2+1)='1'
10900          ISTRZ2(1:1)='1'
10901          NCHAR=1
10902          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
10903          IF(IERROR.EQ.'YES')GOTO9000
10904C
10905          ISTR2(NBASE2+1:NBASE2+1)='2'
10906          ISTRZ2(1:2)='2'
10907          NCHAR=1
10908          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
10909          IF(IERROR.EQ.'YES')GOTO9000
10910C
10911          ISTR2(NBASE2+1:NBASE2+1)='3'
10912          ISTRZ2(1:1)='3'
10913          NCHAR=1
10914          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
10915          IF(IERROR.EQ.'YES')GOTO9000
10916C
10917          ISTR2(NBASE2+1:NBASE2+2)='12'
10918          ISTRZ2(1:2)='12'
10919          NCHAR=2
10920          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
10921          IF(IERROR.EQ.'YES')GOTO9000
10922C
10923          ISTR2(NBASE2+1:NBASE2+2)='13'
10924          ISTRZ2(1:2)='13'
10925          NCHAR=2
10926          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
10927          IF(IERROR.EQ.'YES')GOTO9000
10928C
10929          ISTR2(NBASE2+1:NBASE2+2)='23'
10930          ISTRZ2(1:2)='23'
10931          NCHAR=2
10932          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
10933          IF(IERROR.EQ.'YES')GOTO9000
10934C
10935          ISTR2(NBASE2+1:NBASE2+3)='123'
10936          ISTRZ2(1:3)='123'
10937          NCHAR=3
10938          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
10939          IF(IERROR.EQ.'YES')GOTO9000
10940C
10941        ELSEIF(K.EQ.4)THEN
10942C
10943C         K = 4, N = 8 (2**(4-1))
10944C
10945C           CON1   = 1
10946C           CON2   = 2
10947C           CON3   = 3
10948C           CON12  = 12
10949C           CON13  = 13
10950C           CON23  = 14
10951C           CON123 = 4
10952C
10953C           COP1   = 1
10954C           COP2   = 2
10955C           COP3   = 3
10956C           COP12  = 12+34
10957C           COP13  = 13+24
10958C           COP23  = 14+23
10959C           COP123 = 4
10960C
10961C         MAKE SURE STRING NAME WILL HAVE <= 8 CHARACTERS
10962C
10963          IF(NBASE1.GT.5)THEN
10964            IERROR='YES'
10965            GOTO8010
10966          ELSEIF(NBASE2.GT.5)THEN
10967            IERROR='YES'
10968            GOTO8010
10969          ENDIF
10970C
10971C         NOW CREATE THE STRINGS
10972C
10973          ISTR1(NBASE1+1:NBASE1+1)='1'
10974          ISTRZ1(1:1)='1'
10975          NCHAR=1
10976          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
10977          IF(IERROR.EQ.'YES')GOTO9000
10978C
10979          ISTR1(NBASE1+1:NBASE1+1)='2'
10980          ISTRZ1(1:1)='2'
10981          NCHAR=1
10982          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
10983          IF(IERROR.EQ.'YES')GOTO9000
10984C
10985          ISTR1(NBASE1+1:NBASE1+2)='3'
10986          ISTRZ1(1:1)='3'
10987          NCHAR=1
10988          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
10989          IF(IERROR.EQ.'YES')GOTO9000
10990C
10991          ISTR1(NBASE1+1:NBASE1+2)='12'
10992          ISTRZ1(1:2)='12'
10993          NCHAR=2
10994          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
10995          IF(IERROR.EQ.'YES')GOTO9000
10996C
10997          ISTR1(NBASE1+1:NBASE1+2)='13'
10998          ISTRZ1(1:2)='13'
10999          NCHAR=2
11000          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11001          IF(IERROR.EQ.'YES')GOTO9000
11002C
11003          ISTR1(NBASE1+1:NBASE1+2)='23'
11004          ISTRZ1(1:2)='14'
11005          NCHAR=2
11006          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11007          IF(IERROR.EQ.'YES')GOTO9000
11008C
11009          ISTR1(NBASE1+1:NBASE1+3)='123'
11010          ISTRZ1(1:1)='4'
11011          NCHAR=1
11012          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11013          IF(IERROR.EQ.'YES')GOTO9000
11014C
11015          ISTR2(NBASE2+1:NBASE2+1)='1'
11016          ISTRZ2(1:1)='1'
11017          NCHAR=1
11018          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11019          IF(IERROR.EQ.'YES')GOTO9000
11020C
11021          ISTR2(NBASE2+1:NBASE2+1)='2'
11022          ISTRZ2(1:2)='2'
11023          NCHAR=1
11024          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11025          IF(IERROR.EQ.'YES')GOTO9000
11026C
11027          ISTR2(NBASE2+1:NBASE2+1)='3'
11028          ISTRZ2(1:1)='3'
11029          NCHAR=1
11030          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11031          IF(IERROR.EQ.'YES')GOTO9000
11032C
11033          ISTR2(NBASE2+1:NBASE2+2)='12'
11034          ISTRZ2(1:5)='12+34'
11035          NCHAR=5
11036          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11037          IF(IERROR.EQ.'YES')GOTO9000
11038C
11039          ISTR2(NBASE2+1:NBASE2+2)='13'
11040          ISTRZ2(1:5)='13+24'
11041          NCHAR=5
11042          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11043          IF(IERROR.EQ.'YES')GOTO9000
11044C
11045          ISTR2(NBASE2+1:NBASE2+2)='23'
11046          ISTRZ2(1:5)='14+23'
11047          NCHAR=5
11048          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11049          IF(IERROR.EQ.'YES')GOTO9000
11050C
11051          ISTR2(NBASE2+1:NBASE2+3)='123'
11052          ISTRZ2(1:1)='4'
11053          NCHAR=1
11054          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11055          IF(IERROR.EQ.'YES')GOTO9000
11056C
11057        ELSEIF(K.EQ.5)THEN
11058C
11059C         K = 5, N = 8 (2**(5-2))
11060C
11061C           CON1   = 1
11062C           CON2   = 2
11063C           CON3   = 3
11064C           CON12  = 4
11065C           CON13  = 5
11066C           CON23  = 23
11067C           CON123 = 25
11068C
11069C           COP1   = 1+24+35
11070C           COP2   = 2+14
11071C           COP3   = 3+15
11072C           COP12  = 4+12
11073C           COP13  = 5+13
11074C           COP23  = 23+45
11075C           COP123 = 25+34
11076C
11077C         MAKE SURE STRING NAME WILL HAVE <= 8 CHARACTERS
11078C
11079          IF(NBASE1.GT.5)THEN
11080            IERROR='YES'
11081            GOTO8010
11082          ELSEIF(NBASE2.GT.5)THEN
11083            IERROR='YES'
11084            GOTO8010
11085          ENDIF
11086C
11087C         NOW CREATE THE STRINGS
11088C
11089          ISTR1(NBASE1+1:NBASE1+1)='1'
11090          ISTRZ1(1:1)='1'
11091          NCHAR=1
11092          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11093          IF(IERROR.EQ.'YES')GOTO9000
11094C
11095          ISTR1(NBASE1+1:NBASE1+1)='2'
11096          ISTRZ1(1:1)='2'
11097          NCHAR=1
11098          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11099          IF(IERROR.EQ.'YES')GOTO9000
11100C
11101          ISTR1(NBASE1+1:NBASE1+2)='3'
11102          ISTRZ1(1:1)='3'
11103          NCHAR=1
11104          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11105          IF(IERROR.EQ.'YES')GOTO9000
11106C
11107          ISTR1(NBASE1+1:NBASE1+2)='12'
11108          ISTRZ1(1:1)='4'
11109          NCHAR=1
11110          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11111          IF(IERROR.EQ.'YES')GOTO9000
11112C
11113          ISTR1(NBASE1+1:NBASE1+2)='13'
11114          ISTRZ1(1:1)='5'
11115          NCHAR=1
11116          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11117          IF(IERROR.EQ.'YES')GOTO9000
11118C
11119          ISTR1(NBASE1+1:NBASE1+2)='23'
11120          ISTRZ1(1:2)='23'
11121          NCHAR=2
11122          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11123          IF(IERROR.EQ.'YES')GOTO9000
11124C
11125          ISTR1(NBASE1+1:NBASE1+3)='123'
11126          ISTRZ1(1:2)='25'
11127          NCHAR=2
11128          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11129          IF(IERROR.EQ.'YES')GOTO9000
11130C
11131          ISTR2(NBASE2+1:NBASE2+1)='1'
11132          ISTRZ2(1:7)='1+24+35'
11133          NCHAR=7
11134          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11135          IF(IERROR.EQ.'YES')GOTO9000
11136C
11137          ISTR2(NBASE2+1:NBASE2+1)='2'
11138          ISTRZ2(1:4)='2+14'
11139          NCHAR=4
11140          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11141          IF(IERROR.EQ.'YES')GOTO9000
11142C
11143          ISTR2(NBASE2+1:NBASE2+1)='3'
11144          ISTRZ2(1:4)='3+15'
11145          NCHAR=4
11146          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11147          IF(IERROR.EQ.'YES')GOTO9000
11148C
11149          ISTR2(NBASE2+1:NBASE2+2)='12'
11150          ISTRZ2(1:4)='4+12'
11151          NCHAR=4
11152          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11153          IF(IERROR.EQ.'YES')GOTO9000
11154C
11155          ISTR2(NBASE2+1:NBASE2+2)='13'
11156          ISTRZ2(1:4)='5+13'
11157          NCHAR=4
11158          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11159          IF(IERROR.EQ.'YES')GOTO9000
11160C
11161          ISTR2(NBASE2+1:NBASE2+2)='23'
11162          ISTRZ2(1:5)='23+45'
11163          NCHAR=5
11164          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11165          IF(IERROR.EQ.'YES')GOTO9000
11166C
11167          ISTR2(NBASE2+1:NBASE2+3)='123'
11168          ISTRZ2(1:5)='25+34'
11169          NCHAR=5
11170          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11171          IF(IERROR.EQ.'YES')GOTO9000
11172C
11173        ELSEIF(K.EQ.6)THEN
11174C
11175C         K = 6, N = 8 (2**(6-3))
11176C
11177C           CON1   = 1
11178C           CON2   = 2
11179C           CON3   = 3
11180C           CON12  = 4
11181C           CON13  = 5
11182C           CON23  = 6
11183C           CON123 = 16
11184C
11185C           COP1   = 1+24+35
11186C           COP2   = 2+14+36
11187C           COP3   = 3+15+26
11188C           COP12  = 4+12+56
11189C           COP13  = 5+13+46
11190C           COP23  = 6+23+45
11191C           COP123 = 16+25+34
11192C
11193C         MAKE SURE STRING NAME WILL HAVE <= 8 CHARACTERS
11194C
11195          IF(NBASE1.GT.5)THEN
11196            IERROR='YES'
11197            GOTO8010
11198          ELSEIF(NBASE2.GT.5)THEN
11199            IERROR='YES'
11200            GOTO8010
11201          ENDIF
11202C
11203C         NOW CREATE THE STRINGS
11204C
11205          ISTR1(NBASE1+1:NBASE1+1)='1'
11206          ISTRZ1(1:1)='1'
11207          NCHAR=1
11208          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11209          IF(IERROR.EQ.'YES')GOTO9000
11210C
11211          ISTR1(NBASE1+1:NBASE1+1)='2'
11212          ISTRZ1(1:1)='2'
11213          NCHAR=1
11214          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11215          IF(IERROR.EQ.'YES')GOTO9000
11216C
11217          ISTR1(NBASE1+1:NBASE1+2)='3'
11218          ISTRZ1(1:1)='3'
11219          NCHAR=1
11220          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11221          IF(IERROR.EQ.'YES')GOTO9000
11222C
11223          ISTR1(NBASE1+1:NBASE1+2)='12'
11224          ISTRZ1(1:1)='4'
11225          NCHAR=1
11226          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11227          IF(IERROR.EQ.'YES')GOTO9000
11228C
11229          ISTR1(NBASE1+1:NBASE1+2)='13'
11230          ISTRZ1(1:1)='5'
11231          NCHAR=1
11232          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11233          IF(IERROR.EQ.'YES')GOTO9000
11234C
11235          ISTR1(NBASE1+1:NBASE1+2)='23'
11236          ISTRZ1(1:1)='6'
11237          NCHAR=1
11238          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11239          IF(IERROR.EQ.'YES')GOTO9000
11240C
11241          ISTR1(NBASE1+1:NBASE1+3)='123'
11242          ISTRZ1(1:2)='16'
11243          NCHAR=2
11244          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11245          IF(IERROR.EQ.'YES')GOTO9000
11246C
11247          ISTR2(NBASE2+1:NBASE2+1)='1'
11248          ISTRZ2(1:7)='1+24+35'
11249          NCHAR=7
11250          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11251          IF(IERROR.EQ.'YES')GOTO9000
11252C
11253          ISTR2(NBASE2+1:NBASE2+1)='2'
11254          ISTRZ2(1:7)='2+14+36'
11255          NCHAR=7
11256          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11257          IF(IERROR.EQ.'YES')GOTO9000
11258C
11259          ISTR2(NBASE2+1:NBASE2+1)='3'
11260          ISTRZ2(1:7)='3+15+26'
11261          NCHAR=7
11262          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11263          IF(IERROR.EQ.'YES')GOTO9000
11264C
11265          ISTR2(NBASE2+1:NBASE2+2)='12'
11266          ISTRZ2(1:7)='4+12+56'
11267          NCHAR=7
11268          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11269          IF(IERROR.EQ.'YES')GOTO9000
11270C
11271          ISTR2(NBASE2+1:NBASE2+2)='13'
11272          ISTRZ2(1:7)='5+13+46'
11273          NCHAR=7
11274          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11275          IF(IERROR.EQ.'YES')GOTO9000
11276C
11277          ISTR2(NBASE2+1:NBASE2+2)='23'
11278          ISTRZ2(1:7)='6+23+45'
11279          NCHAR=7
11280          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11281          IF(IERROR.EQ.'YES')GOTO9000
11282C
11283          ISTR2(NBASE2+1:NBASE2+3)='123'
11284          ISTRZ2(1:8)='16+25+34'
11285          NCHAR=8
11286          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11287          IF(IERROR.EQ.'YES')GOTO9000
11288C
11289        ELSEIF(K.EQ.7)THEN
11290C
11291C         K = 7, N = 8 (2**(7-4))
11292C
11293C           CON1   = 1
11294C           CON2   = 2
11295C           CON3   = 3
11296C           CON12  = 4
11297C           CON13  = 5
11298C           CON23  = 6
11299C           CON123 = 7
11300C
11301C           COP1   = 1+24+35+67
11302C           COP2   = 2+14+36+57
11303C           COP3   = 3+15+26+47
11304C           COP12  = 4+12+56+37
11305C           COP13  = 5+13+46+17
11306C           COP23  = 6+23+45+17
11307C           COP123 = 7+16+25+34
11308C
11309C         MAKE SURE STRING NAME WILL HAVE <= 8 CHARACTERS
11310C
11311          IF(NBASE1.GT.5)THEN
11312            IERROR='YES'
11313            GOTO8010
11314          ELSEIF(NBASE2.GT.5)THEN
11315            IERROR='YES'
11316            GOTO8010
11317          ENDIF
11318C
11319C         NOW CREATE THE STRINGS
11320C
11321          ISTR1(NBASE1+1:NBASE1+1)='1'
11322          ISTRZ1(1:1)='1'
11323          NCHAR=1
11324          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11325          IF(IERROR.EQ.'YES')GOTO9000
11326C
11327          ISTR1(NBASE1+1:NBASE1+1)='2'
11328          ISTRZ1(1:1)='2'
11329          NCHAR=1
11330          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11331          IF(IERROR.EQ.'YES')GOTO9000
11332C
11333          ISTR1(NBASE1+1:NBASE1+2)='3'
11334          ISTRZ1(1:1)='3'
11335          NCHAR=1
11336          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11337          IF(IERROR.EQ.'YES')GOTO9000
11338C
11339          ISTR1(NBASE1+1:NBASE1+2)='12'
11340          ISTRZ1(1:1)='4'
11341          NCHAR=1
11342          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11343          IF(IERROR.EQ.'YES')GOTO9000
11344C
11345          ISTR1(NBASE1+1:NBASE1+2)='13'
11346          ISTRZ1(1:1)='5'
11347          NCHAR=1
11348          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11349          IF(IERROR.EQ.'YES')GOTO9000
11350C
11351          ISTR1(NBASE1+1:NBASE1+2)='23'
11352          ISTRZ1(1:1)='6'
11353          NCHAR=1
11354          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11355          IF(IERROR.EQ.'YES')GOTO9000
11356C
11357          ISTR1(NBASE1+1:NBASE1+3)='123'
11358          ISTRZ1(1:1)='7'
11359          NCHAR=1
11360          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11361          IF(IERROR.EQ.'YES')GOTO9000
11362C
11363          ISTR2(NBASE2+1:NBASE2+1)='1'
11364          ISTRZ2(1:10)='1+24+35+67'
11365          NCHAR=10
11366          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11367          IF(IERROR.EQ.'YES')GOTO9000
11368C
11369          ISTR2(NBASE2+1:NBASE2+1)='2'
11370          ISTRZ2(1:10)='2+14+36+57'
11371          NCHAR=10
11372          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11373          IF(IERROR.EQ.'YES')GOTO9000
11374C
11375          ISTR2(NBASE2+1:NBASE2+1)='3'
11376          ISTRZ2(1:10)='3+15+26+47'
11377          NCHAR=10
11378          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11379          IF(IERROR.EQ.'YES')GOTO9000
11380C
11381          ISTR2(NBASE2+1:NBASE2+2)='12'
11382          ISTRZ2(1:10)='4+12+56+37'
11383          NCHAR=10
11384          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11385          IF(IERROR.EQ.'YES')GOTO9000
11386C
11387          ISTR2(NBASE2+1:NBASE2+2)='13'
11388          ISTRZ2(1:10)='5+13+46+17'
11389          NCHAR=10
11390          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11391          IF(IERROR.EQ.'YES')GOTO9000
11392C
11393          ISTR2(NBASE2+1:NBASE2+2)='23'
11394          ISTRZ2(1:10)='6+23+45+17'
11395          NCHAR=10
11396          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11397          IF(IERROR.EQ.'YES')GOTO9000
11398C
11399          ISTR2(NBASE2+1:NBASE2+3)='123'
11400          ISTRZ2(1:10)='7+16+25+34'
11401          NCHAR=10
11402          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11403          IF(IERROR.EQ.'YES')GOTO9000
11404C
11405        ELSE
11406          IERROR='YES'
11407          GOTO8030
11408        ENDIF
11409      ELSEIF(NTEMP.EQ.16)THEN
11410        IF(K.EQ.4)THEN
11411C
11412C         K = 4, N = 16 (2**4)
11413C
11414C           CON1    = 1
11415C           CON2    = 2
11416C           CON3    = 3
11417C           CON4    = 4
11418C           CON12   = 12
11419C           CON13   = 13
11420C           CON14   = 14
11421C           CON23   = 23
11422C           CON24   = 24
11423C           CON34   = 34
11424C           CON123  = 123
11425C           CON124  = 124
11426C           CON134  = 134
11427C           CON234  = 234
11428C           CON1234 = 1234
11429C
11430C           COP1    = 1
11431C           COP2    = 2
11432C           COP3    = 3
11433C           COP4    = 4
11434C           COP12   = 12
11435C           COP13   = 13
11436C           COP14   = 14
11437C           COP23   = 23
11438C           COP24   = 24
11439C           COP34   = 34
11440C           COP123  = 123
11441C           COP124  = 124
11442C           COP134  = 134
11443C           COP234  = 234
11444C           COP1234 = 1234
11445C
11446C         MAKE SURE STRING NAME WILL HAVE <= 8 CHARACTERS
11447C
11448          IF(NBASE1.GT.4)THEN
11449            IERROR='YES'
11450            GOTO8010
11451          ELSEIF(NBASE2.GT.4)THEN
11452            IERROR='YES'
11453            GOTO8010
11454          ENDIF
11455C
11456C         NOW CREATE THE STRINGS
11457C
11458          ISTR1(NBASE1+1:NBASE1+1)='1'
11459          ISTRZ1(1:1)='1'
11460          NCHAR=1
11461          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11462          IF(IERROR.EQ.'YES')GOTO9000
11463C
11464          ISTR1(NBASE1+1:NBASE1+1)='2'
11465          ISTRZ1(1:1)='2'
11466          NCHAR=1
11467          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11468          IF(IERROR.EQ.'YES')GOTO9000
11469C
11470          ISTR1(NBASE1+1:NBASE1+2)='3'
11471          ISTRZ1(1:1)='3'
11472          NCHAR=1
11473          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11474          IF(IERROR.EQ.'YES')GOTO9000
11475C
11476          ISTR1(NBASE1+1:NBASE1+2)='4'
11477          ISTRZ1(1:1)='4'
11478          NCHAR=1
11479          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11480          IF(IERROR.EQ.'YES')GOTO9000
11481C
11482          ISTR1(NBASE1+1:NBASE1+2)='12'
11483          ISTRZ1(1:2)='12'
11484          NCHAR=2
11485          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11486          IF(IERROR.EQ.'YES')GOTO9000
11487C
11488          ISTR1(NBASE1+1:NBASE1+2)='13'
11489          ISTRZ1(1:2)='13'
11490          NCHAR=2
11491          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11492          IF(IERROR.EQ.'YES')GOTO9000
11493C
11494          ISTR1(NBASE1+1:NBASE1+2)='14'
11495          ISTRZ1(1:2)='14'
11496          NCHAR=2
11497          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11498          IF(IERROR.EQ.'YES')GOTO9000
11499C
11500          ISTR1(NBASE1+1:NBASE1+2)='23'
11501          ISTRZ1(1:2)='23'
11502          NCHAR=2
11503          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11504          IF(IERROR.EQ.'YES')GOTO9000
11505C
11506          ISTR1(NBASE1+1:NBASE1+2)='24'
11507          ISTRZ1(1:2)='24'
11508          NCHAR=2
11509          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11510          IF(IERROR.EQ.'YES')GOTO9000
11511C
11512          ISTR1(NBASE1+1:NBASE1+2)='34'
11513          ISTRZ1(1:2)='34'
11514          NCHAR=2
11515          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11516          IF(IERROR.EQ.'YES')GOTO9000
11517C
11518          ISTR1(NBASE1+1:NBASE1+3)='123'
11519          ISTRZ1(1:3)='123'
11520          NCHAR=3
11521          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11522          IF(IERROR.EQ.'YES')GOTO9000
11523C
11524          ISTR1(NBASE1+1:NBASE1+3)='124'
11525          ISTRZ1(1:3)='124'
11526          NCHAR=3
11527          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11528          IF(IERROR.EQ.'YES')GOTO9000
11529C
11530          ISTR1(NBASE1+1:NBASE1+3)='134'
11531          ISTRZ1(1:3)='134'
11532          NCHAR=3
11533          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11534          IF(IERROR.EQ.'YES')GOTO9000
11535C
11536          ISTR1(NBASE1+1:NBASE1+3)='234'
11537          ISTRZ1(1:3)='234'
11538          NCHAR=3
11539          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11540          IF(IERROR.EQ.'YES')GOTO9000
11541C
11542          ISTR1(NBASE1+1:NBASE1+4)='1234'
11543          ISTRZ1(1:4)='1234'
11544          NCHAR=4
11545          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11546          IF(IERROR.EQ.'YES')GOTO9000
11547C
11548          ISTR2(NBASE2+1:NBASE2+1)='1'
11549          ISTRZ2(1:1)='1'
11550          NCHAR=1
11551          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11552          IF(IERROR.EQ.'YES')GOTO9000
11553C
11554          ISTR2(NBASE2+1:NBASE2+1)='2'
11555          ISTRZ2(1:1)='2'
11556          NCHAR=1
11557          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11558          IF(IERROR.EQ.'YES')GOTO9000
11559C
11560          ISTR2(NBASE2+1:NBASE2+1)='3'
11561          ISTRZ2(1:1)='3'
11562          NCHAR=1
11563          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11564          IF(IERROR.EQ.'YES')GOTO9000
11565C
11566          ISTR2(NBASE2+1:NBASE2+1)='4'
11567          ISTRZ2(1:1)='4'
11568          NCHAR=1
11569          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11570          IF(IERROR.EQ.'YES')GOTO9000
11571C
11572          ISTR2(NBASE2+1:NBASE2+2)='12'
11573          ISTRZ2(1:2)='12'
11574          NCHAR=2
11575          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11576          IF(IERROR.EQ.'YES')GOTO9000
11577C
11578          ISTR2(NBASE2+1:NBASE2+2)='13'
11579          ISTRZ2(1:2)='13'
11580          NCHAR=2
11581          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11582          IF(IERROR.EQ.'YES')GOTO9000
11583C
11584          ISTR2(NBASE2+1:NBASE2+2)='14'
11585          ISTRZ2(1:2)='14'
11586          NCHAR=2
11587          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11588          IF(IERROR.EQ.'YES')GOTO9000
11589C
11590          ISTR2(NBASE2+1:NBASE2+2)='23'
11591          ISTRZ2(1:2)='23'
11592          NCHAR=2
11593          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11594          IF(IERROR.EQ.'YES')GOTO9000
11595C
11596          ISTR2(NBASE2+1:NBASE2+2)='24'
11597          ISTRZ2(1:2)='24'
11598          NCHAR=2
11599          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11600          IF(IERROR.EQ.'YES')GOTO9000
11601C
11602          ISTR2(NBASE2+1:NBASE2+2)='34'
11603          ISTRZ2(1:2)='34'
11604          NCHAR=2
11605          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11606          IF(IERROR.EQ.'YES')GOTO9000
11607C
11608          ISTR2(NBASE2+1:NBASE2+3)='123'
11609          ISTRZ2(1:3)='123'
11610          NCHAR=3
11611          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11612          IF(IERROR.EQ.'YES')GOTO9000
11613C
11614          ISTR2(NBASE2+1:NBASE2+3)='124'
11615          ISTRZ2(1:3)='124'
11616          NCHAR=3
11617          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11618          IF(IERROR.EQ.'YES')GOTO9000
11619C
11620          ISTR2(NBASE2+1:NBASE2+3)='134'
11621          ISTRZ2(1:3)='134'
11622          NCHAR=3
11623          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11624          IF(IERROR.EQ.'YES')GOTO9000
11625C
11626          ISTR2(NBASE2+1:NBASE2+3)='234'
11627          ISTRZ2(1:3)='234'
11628          NCHAR=3
11629          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11630          IF(IERROR.EQ.'YES')GOTO9000
11631C
11632          ISTR2(NBASE2+1:NBASE2+4)='1234'
11633          ISTRZ2(1:4)='1234'
11634          NCHAR=4
11635          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11636          IF(IERROR.EQ.'YES')GOTO9000
11637C
11638        ELSEIF(K.EQ.5)THEN
11639C
11640C         K = 5, N = 16 (2**(5-1))
11641C
11642C           CON1    = 1
11643C           CON2    = 2
11644C           CON3    = 3
11645C           CON4    = 4
11646C           CON12   = 12
11647C           CON13   = 13
11648C           CON14   = 14
11649C           CON23   = 23
11650C           CON24   = 24
11651C           CON34   = 34
11652C           CON123  = 45
11653C           CON124  = 35
11654C           CON134  = 25
11655C           CON234  = 15
11656C           CON1234 = 5
11657C
11658C           COP1    = 1
11659C           COP2    = 2
11660C           COP3    = 3
11661C           COP4    = 4
11662C           COP12   = 12
11663C           COP13   = 13
11664C           COP14   = 14
11665C           COP23   = 23
11666C           COP24   = 24
11667C           COP34   = 34
11668C           COP123  = 45
11669C           COP124  = 35
11670C           COP134  = 25
11671C           COP234  = 15
11672C           COP1234 = 5
11673C
11674C         MAKE SURE STRING NAME WILL HAVE <= 8 CHARACTERS
11675C
11676          IF(NBASE1.GT.4)THEN
11677            IERROR='YES'
11678            GOTO8010
11679          ELSEIF(NBASE2.GT.4)THEN
11680            IERROR='YES'
11681            GOTO8010
11682          ENDIF
11683C
11684C         NOW CREATE THE STRINGS
11685C
11686          ISTR1(NBASE1+1:NBASE1+1)='1'
11687          ISTRZ1(1:1)='1'
11688          NCHAR=1
11689          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11690          IF(IERROR.EQ.'YES')GOTO9000
11691C
11692          ISTR1(NBASE1+1:NBASE1+1)='2'
11693          ISTRZ1(1:1)='2'
11694          NCHAR=1
11695          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11696          IF(IERROR.EQ.'YES')GOTO9000
11697C
11698          ISTR1(NBASE1+1:NBASE1+2)='3'
11699          ISTRZ1(1:1)='3'
11700          NCHAR=1
11701          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11702          IF(IERROR.EQ.'YES')GOTO9000
11703C
11704          ISTR1(NBASE1+1:NBASE1+2)='4'
11705          ISTRZ1(1:1)='4'
11706          NCHAR=1
11707          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11708          IF(IERROR.EQ.'YES')GOTO9000
11709C
11710          ISTR1(NBASE1+1:NBASE1+2)='12'
11711          ISTRZ1(1:2)='12'
11712          NCHAR=2
11713          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11714          IF(IERROR.EQ.'YES')GOTO9000
11715C
11716          ISTR1(NBASE1+1:NBASE1+2)='13'
11717          ISTRZ1(1:2)='13'
11718          NCHAR=2
11719          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11720          IF(IERROR.EQ.'YES')GOTO9000
11721C
11722          ISTR1(NBASE1+1:NBASE1+2)='14'
11723          ISTRZ1(1:2)='14'
11724          NCHAR=2
11725          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11726          IF(IERROR.EQ.'YES')GOTO9000
11727C
11728          ISTR1(NBASE1+1:NBASE1+2)='23'
11729          ISTRZ1(1:2)='23'
11730          NCHAR=2
11731          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11732          IF(IERROR.EQ.'YES')GOTO9000
11733C
11734          ISTR1(NBASE1+1:NBASE1+2)='24'
11735          ISTRZ1(1:2)='24'
11736          NCHAR=2
11737          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11738          IF(IERROR.EQ.'YES')GOTO9000
11739C
11740          ISTR1(NBASE1+1:NBASE1+2)='34'
11741          ISTRZ1(1:2)='34'
11742          NCHAR=2
11743          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11744          IF(IERROR.EQ.'YES')GOTO9000
11745C
11746          ISTR1(NBASE1+1:NBASE1+3)='123'
11747          ISTRZ1(1:2)='45'
11748          NCHAR=2
11749          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11750          IF(IERROR.EQ.'YES')GOTO9000
11751C
11752          ISTR1(NBASE1+1:NBASE1+3)='124'
11753          ISTRZ1(1:2)='35'
11754          NCHAR=2
11755          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11756          IF(IERROR.EQ.'YES')GOTO9000
11757C
11758          ISTR1(NBASE1+1:NBASE1+3)='134'
11759          ISTRZ1(1:2)='25'
11760          NCHAR=2
11761          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11762          IF(IERROR.EQ.'YES')GOTO9000
11763C
11764          ISTR1(NBASE1+1:NBASE1+3)='234'
11765          ISTRZ1(1:2)='15'
11766          NCHAR=2
11767          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11768          IF(IERROR.EQ.'YES')GOTO9000
11769C
11770          ISTR1(NBASE1+1:NBASE1+4)='1234'
11771          ISTRZ1(1:1)='5'
11772          NCHAR=1
11773          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11774          IF(IERROR.EQ.'YES')GOTO9000
11775C
11776          ISTR2(NBASE2+1:NBASE2+1)='1'
11777          ISTRZ2(1:1)='1'
11778          NCHAR=1
11779          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11780          IF(IERROR.EQ.'YES')GOTO9000
11781C
11782          ISTR2(NBASE2+1:NBASE2+1)='2'
11783          ISTRZ2(1:1)='2'
11784          NCHAR=1
11785          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11786          IF(IERROR.EQ.'YES')GOTO9000
11787C
11788          ISTR2(NBASE2+1:NBASE2+1)='3'
11789          ISTRZ2(1:1)='3'
11790          NCHAR=1
11791          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11792          IF(IERROR.EQ.'YES')GOTO9000
11793C
11794          ISTR2(NBASE2+1:NBASE2+1)='4'
11795          ISTRZ2(1:1)='4'
11796          NCHAR=1
11797          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11798          IF(IERROR.EQ.'YES')GOTO9000
11799C
11800          ISTR2(NBASE2+1:NBASE2+2)='12'
11801          ISTRZ2(1:2)='12'
11802          NCHAR=2
11803          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11804          IF(IERROR.EQ.'YES')GOTO9000
11805C
11806          ISTR2(NBASE2+1:NBASE2+2)='13'
11807          ISTRZ2(1:2)='13'
11808          NCHAR=2
11809          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11810          IF(IERROR.EQ.'YES')GOTO9000
11811C
11812          ISTR2(NBASE2+1:NBASE2+2)='14'
11813          ISTRZ2(1:2)='14'
11814          NCHAR=2
11815          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11816          IF(IERROR.EQ.'YES')GOTO9000
11817C
11818          ISTR2(NBASE2+1:NBASE2+2)='23'
11819          ISTRZ2(1:2)='23'
11820          NCHAR=2
11821          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11822          IF(IERROR.EQ.'YES')GOTO9000
11823C
11824          ISTR2(NBASE2+1:NBASE2+2)='24'
11825          ISTRZ2(1:2)='24'
11826          NCHAR=2
11827          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11828          IF(IERROR.EQ.'YES')GOTO9000
11829C
11830          ISTR2(NBASE2+1:NBASE2+2)='34'
11831          ISTRZ2(1:2)='34'
11832          NCHAR=2
11833          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11834          IF(IERROR.EQ.'YES')GOTO9000
11835C
11836          ISTR2(NBASE2+1:NBASE2+3)='123'
11837          ISTRZ2(1:2)='45'
11838          NCHAR=2
11839          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11840          IF(IERROR.EQ.'YES')GOTO9000
11841C
11842          ISTR2(NBASE2+1:NBASE2+3)='124'
11843          ISTRZ2(1:2)='35'
11844          NCHAR=2
11845          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11846          IF(IERROR.EQ.'YES')GOTO9000
11847C
11848          ISTR2(NBASE2+1:NBASE2+3)='134'
11849          ISTRZ2(1:2)='25'
11850          NCHAR=2
11851          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11852          IF(IERROR.EQ.'YES')GOTO9000
11853C
11854          ISTR2(NBASE2+1:NBASE2+3)='234'
11855          ISTRZ2(1:2)='15'
11856          NCHAR=2
11857          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11858          IF(IERROR.EQ.'YES')GOTO9000
11859C
11860          ISTR2(NBASE2+1:NBASE2+4)='1234'
11861          ISTRZ2(1:1)='5'
11862          NCHAR=1
11863          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
11864          IF(IERROR.EQ.'YES')GOTO9000
11865C
11866        ELSEIF(K.EQ.6)THEN
11867C
11868C         K = 6, N = 16 (2**(6-2))
11869C
11870C           CON1    = 1
11871C           CON2    = 2
11872C           CON3    = 3
11873C           CON4    = 4
11874C           CON12   = 12
11875C           CON13   = 13
11876C           CON14   = 14
11877C           CON23   = 23
11878C           CON24   = 24
11879C           CON34   = 34
11880C           CON123  = 5
11881C           CON124  = 124
11882C           CON134  = 134
11883C           CON234  = 6
11884C           CON1234 = 16
11885C
11886C           COP1    = 1
11887C           COP2    = 2
11888C           COP3    = 3
11889C           COP4    = 4
11890C           COP12   = 12+35
11891C           COP13   = 13+25
11892C           COP14   = 14+56
11893C           COP23   = 23+15+46
11894C           COP24   = 24+36
11895C           COP34   = 34+26
11896C           COP123  = 5
11897C           COP124  = 124
11898C           COP134  = 134
11899C           COP234  = 6
11900C           COP1234 = 45
11901C
11902C         MAKE SURE STRING NAME WILL HAVE <= 8 CHARACTERS
11903C
11904          IF(NBASE1.GT.4)THEN
11905            IERROR='YES'
11906            GOTO8010
11907          ELSEIF(NBASE2.GT.4)THEN
11908            IERROR='YES'
11909            GOTO8010
11910          ENDIF
11911C
11912C         NOW CREATE THE STRINGS
11913C
11914          ISTR1(NBASE1+1:NBASE1+1)='1'
11915          ISTRZ1(1:1)='1'
11916          NCHAR=1
11917          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11918          IF(IERROR.EQ.'YES')GOTO9000
11919C
11920          ISTR1(NBASE1+1:NBASE1+1)='2'
11921          ISTRZ1(1:1)='2'
11922          NCHAR=1
11923          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11924          IF(IERROR.EQ.'YES')GOTO9000
11925C
11926          ISTR1(NBASE1+1:NBASE1+2)='3'
11927          ISTRZ1(1:1)='3'
11928          NCHAR=1
11929          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11930          IF(IERROR.EQ.'YES')GOTO9000
11931C
11932          ISTR1(NBASE1+1:NBASE1+2)='4'
11933          ISTRZ1(1:1)='4'
11934          NCHAR=1
11935          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11936          IF(IERROR.EQ.'YES')GOTO9000
11937C
11938          ISTR1(NBASE1+1:NBASE1+2)='12'
11939          ISTRZ1(1:2)='12'
11940          NCHAR=2
11941          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11942          IF(IERROR.EQ.'YES')GOTO9000
11943C
11944          ISTR1(NBASE1+1:NBASE1+2)='13'
11945          ISTRZ1(1:2)='13'
11946          NCHAR=2
11947          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11948          IF(IERROR.EQ.'YES')GOTO9000
11949C
11950          ISTR1(NBASE1+1:NBASE1+2)='14'
11951          ISTRZ1(1:2)='14'
11952          NCHAR=2
11953          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11954          IF(IERROR.EQ.'YES')GOTO9000
11955C
11956          ISTR1(NBASE1+1:NBASE1+2)='23'
11957          ISTRZ1(1:2)='23'
11958          NCHAR=2
11959          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11960          IF(IERROR.EQ.'YES')GOTO9000
11961C
11962          ISTR1(NBASE1+1:NBASE1+2)='24'
11963          ISTRZ1(1:2)='24'
11964          NCHAR=2
11965          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11966          IF(IERROR.EQ.'YES')GOTO9000
11967C
11968          ISTR1(NBASE1+1:NBASE1+2)='34'
11969          ISTRZ1(1:2)='34'
11970          NCHAR=2
11971          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11972          IF(IERROR.EQ.'YES')GOTO9000
11973C
11974          ISTR1(NBASE1+1:NBASE1+3)='123'
11975          ISTRZ1(1:1)='5'
11976          NCHAR=1
11977          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11978          IF(IERROR.EQ.'YES')GOTO9000
11979C
11980          ISTR1(NBASE1+1:NBASE1+3)='124'
11981          ISTRZ1(1:3)='124'
11982          NCHAR=3
11983          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11984          IF(IERROR.EQ.'YES')GOTO9000
11985C
11986          ISTR1(NBASE1+1:NBASE1+3)='134'
11987          ISTRZ1(1:3)='134'
11988          NCHAR=3
11989          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11990          IF(IERROR.EQ.'YES')GOTO9000
11991C
11992          ISTR1(NBASE1+1:NBASE1+3)='234'
11993          ISTRZ1(1:1)='6'
11994          NCHAR=1
11995          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
11996          IF(IERROR.EQ.'YES')GOTO9000
11997C
11998          ISTR1(NBASE1+1:NBASE1+4)='1234'
11999          ISTRZ1(1:2)='16'
12000          NCHAR=2
12001          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12002          IF(IERROR.EQ.'YES')GOTO9000
12003C
12004          ISTR2(NBASE2+1:NBASE2+1)='1'
12005          ISTRZ2(1:1)='1'
12006          NCHAR=1
12007          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12008          IF(IERROR.EQ.'YES')GOTO9000
12009C
12010          ISTR2(NBASE2+1:NBASE2+1)='2'
12011          ISTRZ2(1:1)='2'
12012          NCHAR=1
12013          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12014          IF(IERROR.EQ.'YES')GOTO9000
12015C
12016          ISTR2(NBASE2+1:NBASE2+1)='3'
12017          ISTRZ2(1:1)='3'
12018          NCHAR=1
12019          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12020          IF(IERROR.EQ.'YES')GOTO9000
12021C
12022          ISTR2(NBASE2+1:NBASE2+1)='4'
12023          ISTRZ2(1:1)='4'
12024          NCHAR=1
12025          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12026          IF(IERROR.EQ.'YES')GOTO9000
12027C
12028          ISTR2(NBASE2+1:NBASE2+2)='12'
12029          ISTRZ2(1:5)='12+35'
12030          NCHAR=5
12031          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12032          IF(IERROR.EQ.'YES')GOTO9000
12033C
12034          ISTR2(NBASE2+1:NBASE2+2)='13'
12035          ISTRZ2(1:5)='13+25'
12036          NCHAR=5
12037          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12038          IF(IERROR.EQ.'YES')GOTO9000
12039C
12040          ISTR2(NBASE2+1:NBASE2+2)='14'
12041          ISTRZ2(1:5)='14+56'
12042          NCHAR=5
12043          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12044          IF(IERROR.EQ.'YES')GOTO9000
12045C
12046          ISTR2(NBASE2+1:NBASE2+2)='23'
12047          ISTRZ2(1:8)='23+15+46'
12048          NCHAR=8
12049          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12050          IF(IERROR.EQ.'YES')GOTO9000
12051C
12052          ISTR2(NBASE2+1:NBASE2+2)='24'
12053          ISTRZ2(1:5)='24+36'
12054          NCHAR=5
12055          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12056          IF(IERROR.EQ.'YES')GOTO9000
12057C
12058          ISTR2(NBASE2+1:NBASE2+2)='34'
12059          ISTRZ2(1:5)='34+26'
12060          NCHAR=5
12061          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12062          IF(IERROR.EQ.'YES')GOTO9000
12063C
12064          ISTR2(NBASE2+1:NBASE2+3)='123'
12065          ISTRZ2(1:1)='5'
12066          NCHAR=1
12067          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12068          IF(IERROR.EQ.'YES')GOTO9000
12069C
12070          ISTR2(NBASE2+1:NBASE2+3)='124'
12071          ISTRZ2(1:3)='124'
12072          NCHAR=3
12073          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12074          IF(IERROR.EQ.'YES')GOTO9000
12075C
12076          ISTR2(NBASE2+1:NBASE2+3)='134'
12077          ISTRZ2(1:3)='134'
12078          NCHAR=3
12079          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12080          IF(IERROR.EQ.'YES')GOTO9000
12081C
12082          ISTR2(NBASE2+1:NBASE2+3)='234'
12083          ISTRZ2(1:1)='6'
12084          NCHAR=1
12085          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12086          IF(IERROR.EQ.'YES')GOTO9000
12087C
12088          ISTR2(NBASE2+1:NBASE2+4)='1234'
12089          ISTRZ2(1:2)='45'
12090          NCHAR=2
12091          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12092          IF(IERROR.EQ.'YES')GOTO9000
12093C
12094        ELSEIF(K.EQ.7)THEN
12095C
12096C         K = 7, N = 16 (2**(7-3))
12097C
12098C           CON1    = 1
12099C           CON2    = 2
12100C           CON3    = 3
12101C           CON4    = 4
12102C           CON12   = 12
12103C           CON13   = 13
12104C           CON14   = 14
12105C           CON23   = 23
12106C           CON24   = 24
12107C           CON34   = 34
12108C           CON123  = 7
12109C           CON124  = 124
12110C           CON134  = 6
12111C           CON234  = 5
12112C           CON1234 = 15
12113C
12114C           COP1    = 1
12115C           COP2    = 2
12116C           COP3    = 3
12117C           COP4    = 4
12118C           COP12   = 12+37+56
12119C           COP13   = 13+27+46
12120C           COP14   = 14+36+57
12121C           COP23   = 15+26+47
12122C           COP24   = 16+25+34
12123C           COP34   = 17+23+45
12124C           COP123  = 7
12125C           COP124  = 124
12126C           COP134  = 6
12127C           COP234  = 5
12128C           COP1234 = 15+26+47
12129C
12130C         MAKE SURE STRING NAME WILL HAVE <= 8 CHARACTERS
12131C
12132          IF(NBASE1.GT.4)THEN
12133            IERROR='YES'
12134            GOTO8010
12135          ELSEIF(NBASE2.GT.4)THEN
12136            IERROR='YES'
12137            GOTO8010
12138          ENDIF
12139C
12140C         NOW CREATE THE STRINGS
12141C
12142          ISTR1(NBASE1+1:NBASE1+1)='1'
12143          ISTRZ1(1:1)='1'
12144          NCHAR=1
12145          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12146          IF(IERROR.EQ.'YES')GOTO9000
12147C
12148          ISTR1(NBASE1+1:NBASE1+1)='2'
12149          ISTRZ1(1:1)='2'
12150          NCHAR=1
12151          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12152          IF(IERROR.EQ.'YES')GOTO9000
12153C
12154          ISTR1(NBASE1+1:NBASE1+2)='3'
12155          ISTRZ1(1:1)='3'
12156          NCHAR=1
12157          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12158          IF(IERROR.EQ.'YES')GOTO9000
12159C
12160          ISTR1(NBASE1+1:NBASE1+2)='4'
12161          ISTRZ1(1:1)='4'
12162          NCHAR=1
12163          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12164          IF(IERROR.EQ.'YES')GOTO9000
12165C
12166          ISTR1(NBASE1+1:NBASE1+2)='12'
12167          ISTRZ1(1:2)='12'
12168          NCHAR=2
12169          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12170          IF(IERROR.EQ.'YES')GOTO9000
12171C
12172          ISTR1(NBASE1+1:NBASE1+2)='13'
12173          ISTRZ1(1:2)='13'
12174          NCHAR=2
12175          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12176          IF(IERROR.EQ.'YES')GOTO9000
12177C
12178          ISTR1(NBASE1+1:NBASE1+2)='14'
12179          ISTRZ1(1:2)='14'
12180          NCHAR=2
12181          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12182          IF(IERROR.EQ.'YES')GOTO9000
12183C
12184          ISTR1(NBASE1+1:NBASE1+2)='23'
12185          ISTRZ1(1:2)='23'
12186          NCHAR=2
12187          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12188          IF(IERROR.EQ.'YES')GOTO9000
12189C
12190          ISTR1(NBASE1+1:NBASE1+2)='24'
12191          ISTRZ1(1:2)='24'
12192          NCHAR=2
12193          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12194          IF(IERROR.EQ.'YES')GOTO9000
12195C
12196          ISTR1(NBASE1+1:NBASE1+2)='34'
12197          ISTRZ1(1:2)='34'
12198          NCHAR=2
12199          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12200          IF(IERROR.EQ.'YES')GOTO9000
12201C
12202          ISTR1(NBASE1+1:NBASE1+3)='123'
12203          ISTRZ1(1:1)='7'
12204          NCHAR=1
12205          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12206          IF(IERROR.EQ.'YES')GOTO9000
12207C
12208          ISTR1(NBASE1+1:NBASE1+3)='124'
12209          ISTRZ1(1:3)='124'
12210          NCHAR=3
12211          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12212          IF(IERROR.EQ.'YES')GOTO9000
12213C
12214          ISTR1(NBASE1+1:NBASE1+3)='134'
12215          ISTRZ1(1:1)='6'
12216          NCHAR=1
12217          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12218          IF(IERROR.EQ.'YES')GOTO9000
12219C
12220          ISTR1(NBASE1+1:NBASE1+3)='234'
12221          ISTRZ1(1:1)='5'
12222          NCHAR=1
12223          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12224          IF(IERROR.EQ.'YES')GOTO9000
12225C
12226          ISTR1(NBASE1+1:NBASE1+4)='1234'
12227          ISTRZ1(1:2)='15'
12228          NCHAR=2
12229          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12230          IF(IERROR.EQ.'YES')GOTO9000
12231C
12232          ISTR2(NBASE2+1:NBASE2+1)='1'
12233          ISTRZ2(1:1)='1'
12234          NCHAR=1
12235          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12236          IF(IERROR.EQ.'YES')GOTO9000
12237C
12238          ISTR2(NBASE2+1:NBASE2+1)='2'
12239          ISTRZ2(1:1)='2'
12240          NCHAR=1
12241          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12242          IF(IERROR.EQ.'YES')GOTO9000
12243C
12244          ISTR2(NBASE2+1:NBASE2+1)='3'
12245          ISTRZ2(1:1)='3'
12246          NCHAR=1
12247          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12248          IF(IERROR.EQ.'YES')GOTO9000
12249C
12250          ISTR2(NBASE2+1:NBASE2+1)='4'
12251          ISTRZ2(1:1)='4'
12252          NCHAR=1
12253          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12254          IF(IERROR.EQ.'YES')GOTO9000
12255C
12256          ISTR2(NBASE2+1:NBASE2+2)='12'
12257          ISTRZ2(1:8)='12+37+56'
12258          NCHAR=8
12259          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12260          IF(IERROR.EQ.'YES')GOTO9000
12261C
12262          ISTR2(NBASE2+1:NBASE2+2)='13'
12263          ISTRZ2(1:8)='13+27+46'
12264          NCHAR=8
12265          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12266          IF(IERROR.EQ.'YES')GOTO9000
12267C
12268          ISTR2(NBASE2+1:NBASE2+2)='14'
12269          ISTRZ2(1:8)='14+36+57'
12270          NCHAR=8
12271          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12272          IF(IERROR.EQ.'YES')GOTO9000
12273C
12274          ISTR2(NBASE2+1:NBASE2+2)='23'
12275          ISTRZ2(1:8)='15+26+47'
12276          NCHAR=8
12277          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12278          IF(IERROR.EQ.'YES')GOTO9000
12279C
12280          ISTR2(NBASE2+1:NBASE2+2)='24'
12281          ISTRZ2(1:8)='16+25+34'
12282          NCHAR=8
12283          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12284          IF(IERROR.EQ.'YES')GOTO9000
12285C
12286          ISTR2(NBASE2+1:NBASE2+2)='34'
12287          ISTRZ2(1:8)='17+23+45'
12288          NCHAR=8
12289          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12290          IF(IERROR.EQ.'YES')GOTO9000
12291C
12292          ISTR2(NBASE2+1:NBASE2+3)='123'
12293          ISTRZ2(1:1)='7'
12294          NCHAR=1
12295          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12296          IF(IERROR.EQ.'YES')GOTO9000
12297C
12298          ISTR2(NBASE2+1:NBASE2+3)='124'
12299          ISTRZ2(1:3)='124'
12300          NCHAR=3
12301          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12302          IF(IERROR.EQ.'YES')GOTO9000
12303C
12304          ISTR2(NBASE2+1:NBASE2+3)='134'
12305          ISTRZ2(1:1)='6'
12306          NCHAR=1
12307          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12308          IF(IERROR.EQ.'YES')GOTO9000
12309C
12310          ISTR2(NBASE2+1:NBASE2+3)='234'
12311          ISTRZ2(1:1)='5'
12312          NCHAR=1
12313          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12314          IF(IERROR.EQ.'YES')GOTO9000
12315C
12316          ISTR2(NBASE2+1:NBASE2+4)='1234'
12317          ISTRZ2(1:8)='15+26+47'
12318          NCHAR=8
12319          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12320          IF(IERROR.EQ.'YES')GOTO9000
12321C
12322        ELSEIF(K.EQ.8)THEN
12323C
12324C         K = 8, N = 16 (2**(8-4))
12325C
12326C           CON1    = 1
12327C           CON2    = 2
12328C           CON3    = 3
12329C           CON4    = 4
12330C           CON12   = 12
12331C           CON13   = 13
12332C           CON14   = 14
12333C           CON23   = 23
12334C           CON24   = 24
12335C           CON34   = 34
12336C           CON123  = 7
12337C           CON124  = 8
12338C           CON134  = 6
12339C           CON234  = 5
12340C           CON1234 = 15
12341C
12342C           COP1    = 1
12343C           COP2    = 2
12344C           COP3    = 3
12345C           COP4    = 4
12346C           COP12   = 12+37+48+56
12347C           COP13   = 13+27+46+58
12348C           COP14   = 14+28+36+57
12349C           COP23   = 23+17+45+68
12350C           COP24   = 24+18+35+67
12351C           COP34   = 34+16+25+78
12352C           COP123  = 7
12353C           COP124  = 8
12354C           COP134  = 6
12355C           COP234  = 5
12356C           COP1234 = 15+26+38+47
12357C
12358C         MAKE SURE STRING NAME WILL HAVE <= 8 CHARACTERS
12359C
12360          IF(NBASE1.GT.4)THEN
12361            IERROR='YES'
12362            GOTO8010
12363          ELSEIF(NBASE2.GT.4)THEN
12364            IERROR='YES'
12365            GOTO8010
12366          ENDIF
12367C
12368C         NOW CREATE THE STRINGS
12369C
12370          ISTR1(NBASE1+1:NBASE1+1)='1'
12371          ISTRZ1(1:1)='1'
12372          NCHAR=1
12373          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12374          IF(IERROR.EQ.'YES')GOTO9000
12375C
12376          ISTR1(NBASE1+1:NBASE1+1)='2'
12377          ISTRZ1(1:1)='2'
12378          NCHAR=1
12379          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12380          IF(IERROR.EQ.'YES')GOTO9000
12381C
12382          ISTR1(NBASE1+1:NBASE1+2)='3'
12383          ISTRZ1(1:1)='3'
12384          NCHAR=1
12385          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12386          IF(IERROR.EQ.'YES')GOTO9000
12387C
12388          ISTR1(NBASE1+1:NBASE1+2)='4'
12389          ISTRZ1(1:1)='4'
12390          NCHAR=1
12391          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12392          IF(IERROR.EQ.'YES')GOTO9000
12393C
12394          ISTR1(NBASE1+1:NBASE1+2)='12'
12395          ISTRZ1(1:2)='12'
12396          NCHAR=2
12397          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12398          IF(IERROR.EQ.'YES')GOTO9000
12399C
12400          ISTR1(NBASE1+1:NBASE1+2)='13'
12401          ISTRZ1(1:2)='13'
12402          NCHAR=2
12403          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12404          IF(IERROR.EQ.'YES')GOTO9000
12405C
12406          ISTR1(NBASE1+1:NBASE1+2)='14'
12407          ISTRZ1(1:2)='14'
12408          NCHAR=2
12409          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12410          IF(IERROR.EQ.'YES')GOTO9000
12411C
12412          ISTR1(NBASE1+1:NBASE1+2)='23'
12413          ISTRZ1(1:2)='23'
12414          NCHAR=2
12415          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12416          IF(IERROR.EQ.'YES')GOTO9000
12417C
12418          ISTR1(NBASE1+1:NBASE1+2)='24'
12419          ISTRZ1(1:2)='24'
12420          NCHAR=2
12421          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12422          IF(IERROR.EQ.'YES')GOTO9000
12423C
12424          ISTR1(NBASE1+1:NBASE1+2)='34'
12425          ISTRZ1(1:2)='34'
12426          NCHAR=2
12427          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12428          IF(IERROR.EQ.'YES')GOTO9000
12429C
12430          ISTR1(NBASE1+1:NBASE1+3)='123'
12431          ISTRZ1(1:1)='7'
12432          NCHAR=1
12433          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12434          IF(IERROR.EQ.'YES')GOTO9000
12435C
12436          ISTR1(NBASE1+1:NBASE1+3)='124'
12437          ISTRZ1(1:1)='8'
12438          NCHAR=1
12439          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12440          IF(IERROR.EQ.'YES')GOTO9000
12441C
12442          ISTR1(NBASE1+1:NBASE1+3)='134'
12443          ISTRZ1(1:1)='6'
12444          NCHAR=1
12445          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12446          IF(IERROR.EQ.'YES')GOTO9000
12447C
12448          ISTR1(NBASE1+1:NBASE1+3)='234'
12449          ISTRZ1(1:1)='5'
12450          NCHAR=1
12451          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12452          IF(IERROR.EQ.'YES')GOTO9000
12453C
12454          ISTR1(NBASE1+1:NBASE1+4)='1234'
12455          ISTRZ1(1:2)='15'
12456          NCHAR=2
12457          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12458          IF(IERROR.EQ.'YES')GOTO9000
12459C
12460          ISTR2(NBASE2+1:NBASE2+1)='1'
12461          ISTRZ2(1:1)='1'
12462          NCHAR=1
12463          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12464          IF(IERROR.EQ.'YES')GOTO9000
12465C
12466          ISTR2(NBASE2+1:NBASE2+1)='2'
12467          ISTRZ2(1:1)='2'
12468          NCHAR=1
12469          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12470          IF(IERROR.EQ.'YES')GOTO9000
12471C
12472          ISTR2(NBASE2+1:NBASE2+1)='3'
12473          ISTRZ2(1:1)='3'
12474          NCHAR=1
12475          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12476          IF(IERROR.EQ.'YES')GOTO9000
12477C
12478          ISTR2(NBASE2+1:NBASE2+1)='4'
12479          ISTRZ2(1:1)='4'
12480          NCHAR=1
12481          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12482          IF(IERROR.EQ.'YES')GOTO9000
12483C
12484          ISTR2(NBASE2+1:NBASE2+2)='12'
12485          ISTRZ2(1:11)='12+37+48+56'
12486          NCHAR=11
12487          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12488          IF(IERROR.EQ.'YES')GOTO9000
12489C
12490          ISTR2(NBASE2+1:NBASE2+2)='13'
12491          ISTRZ2(1:11)='13+27+46+58'
12492          NCHAR=11
12493          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12494          IF(IERROR.EQ.'YES')GOTO9000
12495C
12496          ISTR2(NBASE2+1:NBASE2+2)='14'
12497          ISTRZ2(1:11)='14+28+36+57'
12498          NCHAR=11
12499          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12500          IF(IERROR.EQ.'YES')GOTO9000
12501C
12502          ISTR2(NBASE2+1:NBASE2+2)='23'
12503          ISTRZ2(1:11)='23+17+45+68'
12504          NCHAR=11
12505          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12506          IF(IERROR.EQ.'YES')GOTO9000
12507C
12508          ISTR2(NBASE2+1:NBASE2+2)='24'
12509          ISTRZ2(1:11)='24+18+35+67'
12510          NCHAR=11
12511          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12512          IF(IERROR.EQ.'YES')GOTO9000
12513C
12514          ISTR2(NBASE2+1:NBASE2+2)='34'
12515          ISTRZ2(1:11)='34+16+25+78'
12516          NCHAR=11
12517          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12518          IF(IERROR.EQ.'YES')GOTO9000
12519C
12520          ISTR2(NBASE2+1:NBASE2+3)='123'
12521          ISTRZ2(1:1)='7'
12522          NCHAR=1
12523          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12524          IF(IERROR.EQ.'YES')GOTO9000
12525C
12526          ISTR2(NBASE2+1:NBASE2+3)='124'
12527          ISTRZ2(1:1)='8'
12528          NCHAR=1
12529          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12530          IF(IERROR.EQ.'YES')GOTO9000
12531C
12532          ISTR2(NBASE2+1:NBASE2+3)='134'
12533          ISTRZ2(1:1)='6'
12534          NCHAR=1
12535          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12536          IF(IERROR.EQ.'YES')GOTO9000
12537C
12538          ISTR2(NBASE2+1:NBASE2+3)='234'
12539          ISTRZ2(1:1)='5'
12540          NCHAR=1
12541          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12542          IF(IERROR.EQ.'YES')GOTO9000
12543C
12544          ISTR2(NBASE2+1:NBASE2+4)='1234'
12545          ISTRZ2(1:11)='15+26+38+47'
12546          NCHAR=11
12547          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12548          IF(IERROR.EQ.'YES')GOTO9000
12549C
12550        ELSE
12551          IERROR='YES'
12552          GOTO8030
12553        ENDIF
12554      ELSEIF(NTEMP.EQ.32)THEN
12555        IF(K.EQ.5)THEN
12556C
12557C         K = 5, N = 32 (2**5)
12558C
12559C           CON1     = 1
12560C           CON2     = 2
12561C           CON3     = 3
12562C           CON4     = 4
12563C           CON5     = 5
12564C           CON12    = 12
12565C           CON13    = 13
12566C           CON14    = 14
12567C           CON15    = 15
12568C           CON23    = 23
12569C           CON24    = 24
12570C           CON25    = 25
12571C           CON34    = 34
12572C           CON35    = 35
12573C           CON45    = 45
12574C           CON123   = 123
12575C           CON124   = 124
12576C           CON125   = 125
12577C           CON134   = 134
12578C           CON135   = 135
12579C           CON145   = 145
12580C           CON234   = 234
12581C           CON235   = 235
12582C           CON245   = 245
12583C           CON345   = 345
12584C           CON1234  = 1234
12585C           CON1235  = 1235
12586C           CON1245  = 1245
12587C           CON1345  = 1345
12588C           CON2345  = 2345
12589C           CON12345 = 12345
12590C
12591C           COP1     = 1
12592C           COP2     = 2
12593C           COP3     = 3
12594C           COP4     = 4
12595C           COP5     = 5
12596C           COP12    = 12
12597C           COP13    = 13
12598C           COP14    = 14
12599C           COP15    = 15
12600C           COP23    = 23
12601C           COP24    = 24
12602C           COP25    = 25
12603C           COP34    = 34
12604C           COP35    = 35
12605C           COP45    = 45
12606C           COP123   = 123
12607C           COP124   = 124
12608C           COP125   = 125
12609C           COP134   = 134
12610C           COP135   = 135
12611C           COP145   = 145
12612C           COP234   = 234
12613C           COP235   = 235
12614C           COP245   = 245
12615C           COP345   = 345
12616C           COP1234  = 1234
12617C           COP1235  = 1235
12618C           COP1245  = 1245
12619C           COP1345  = 1345
12620C           COP2345  = 2345
12621C           COP12345 = 12345
12622C
12623C         MAKE SURE STRING NAME WILL HAVE <= 8 CHARACTERS
12624C
12625          IF(NBASE1.GT.3)THEN
12626            IERROR='YES'
12627            GOTO8010
12628          ELSEIF(NBASE2.GT.3)THEN
12629            IERROR='YES'
12630            GOTO8010
12631          ENDIF
12632C
12633C         NOW CREATE THE STRINGS
12634C
12635          ISTR1(NBASE1+1:NBASE1+1)='1'
12636          ISTRZ1(1:1)='1'
12637          NCHAR=1
12638          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12639          IF(IERROR.EQ.'YES')GOTO9000
12640C
12641          ISTR1(NBASE1+1:NBASE1+1)='2'
12642          ISTRZ1(1:1)='2'
12643          NCHAR=1
12644          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12645          IF(IERROR.EQ.'YES')GOTO9000
12646C
12647          ISTR1(NBASE1+1:NBASE1+2)='3'
12648          ISTRZ1(1:1)='3'
12649          NCHAR=1
12650          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12651          IF(IERROR.EQ.'YES')GOTO9000
12652C
12653          ISTR1(NBASE1+1:NBASE1+2)='4'
12654          ISTRZ1(1:1)='4'
12655          NCHAR=1
12656          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12657          IF(IERROR.EQ.'YES')GOTO9000
12658C
12659          ISTR1(NBASE1+1:NBASE1+2)='5'
12660          ISTRZ1(1:1)='5'
12661          NCHAR=1
12662          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12663          IF(IERROR.EQ.'YES')GOTO9000
12664C
12665          ISTR1(NBASE1+1:NBASE1+2)='12'
12666          ISTRZ1(1:2)='12'
12667          NCHAR=2
12668          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12669          IF(IERROR.EQ.'YES')GOTO9000
12670C
12671          ISTR1(NBASE1+1:NBASE1+2)='13'
12672          ISTRZ1(1:2)='13'
12673          NCHAR=2
12674          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12675          IF(IERROR.EQ.'YES')GOTO9000
12676C
12677          ISTR1(NBASE1+1:NBASE1+2)='14'
12678          ISTRZ1(1:2)='14'
12679          NCHAR=2
12680          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12681          IF(IERROR.EQ.'YES')GOTO9000
12682C
12683          ISTR1(NBASE1+1:NBASE1+2)='15'
12684          ISTRZ1(1:2)='15'
12685          NCHAR=2
12686          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12687          IF(IERROR.EQ.'YES')GOTO9000
12688C
12689          ISTR1(NBASE1+1:NBASE1+2)='23'
12690          ISTRZ1(1:2)='23'
12691          NCHAR=2
12692          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12693          IF(IERROR.EQ.'YES')GOTO9000
12694C
12695          ISTR1(NBASE1+1:NBASE1+2)='24'
12696          ISTRZ1(1:2)='24'
12697          NCHAR=2
12698          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12699          IF(IERROR.EQ.'YES')GOTO9000
12700C
12701          ISTR1(NBASE1+1:NBASE1+2)='25'
12702          ISTRZ1(1:2)='25'
12703          NCHAR=2
12704          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12705          IF(IERROR.EQ.'YES')GOTO9000
12706C
12707          ISTR1(NBASE1+1:NBASE1+2)='34'
12708          ISTRZ1(1:2)='34'
12709          NCHAR=2
12710          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12711          IF(IERROR.EQ.'YES')GOTO9000
12712C
12713          ISTR1(NBASE1+1:NBASE1+2)='35'
12714          ISTRZ1(1:2)='35'
12715          NCHAR=2
12716          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12717          IF(IERROR.EQ.'YES')GOTO9000
12718C
12719          ISTR1(NBASE1+1:NBASE1+2)='45'
12720          ISTRZ1(1:2)='45'
12721          NCHAR=2
12722          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12723          IF(IERROR.EQ.'YES')GOTO9000
12724C
12725          ISTR1(NBASE1+1:NBASE1+3)='123'
12726          ISTRZ1(1:3)='123'
12727          NCHAR=3
12728          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12729          IF(IERROR.EQ.'YES')GOTO9000
12730C
12731          ISTR1(NBASE1+1:NBASE1+3)='124'
12732          ISTRZ1(1:3)='124'
12733          NCHAR=3
12734          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12735          IF(IERROR.EQ.'YES')GOTO9000
12736C
12737          ISTR1(NBASE1+1:NBASE1+3)='125'
12738          ISTRZ1(1:3)='125'
12739          NCHAR=3
12740          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12741          IF(IERROR.EQ.'YES')GOTO9000
12742C
12743          ISTR1(NBASE1+1:NBASE1+3)='134'
12744          ISTRZ1(1:3)='134'
12745          NCHAR=3
12746          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12747          IF(IERROR.EQ.'YES')GOTO9000
12748C
12749          ISTR1(NBASE1+1:NBASE1+3)='135'
12750          ISTRZ1(1:3)='135'
12751          NCHAR=3
12752          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12753          IF(IERROR.EQ.'YES')GOTO9000
12754C
12755          ISTR1(NBASE1+1:NBASE1+3)='145'
12756          ISTRZ1(1:3)='145'
12757          NCHAR=3
12758          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12759          IF(IERROR.EQ.'YES')GOTO9000
12760C
12761          ISTR1(NBASE1+1:NBASE1+3)='234'
12762          ISTRZ1(1:3)='234'
12763          NCHAR=3
12764          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12765          IF(IERROR.EQ.'YES')GOTO9000
12766C
12767          ISTR1(NBASE1+1:NBASE1+3)='235'
12768          ISTRZ1(1:3)='235'
12769          NCHAR=3
12770          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12771          IF(IERROR.EQ.'YES')GOTO9000
12772C
12773          ISTR1(NBASE1+1:NBASE1+3)='245'
12774          ISTRZ1(1:3)='245'
12775          NCHAR=3
12776          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12777          IF(IERROR.EQ.'YES')GOTO9000
12778C
12779          ISTR1(NBASE1+1:NBASE1+3)='345'
12780          ISTRZ1(1:3)='345'
12781          NCHAR=3
12782          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12783          IF(IERROR.EQ.'YES')GOTO9000
12784C
12785          ISTR1(NBASE1+1:NBASE1+4)='1234'
12786          ISTRZ1(1:4)='1234'
12787          NCHAR=4
12788          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12789          IF(IERROR.EQ.'YES')GOTO9000
12790C
12791          ISTR1(NBASE1+1:NBASE1+4)='1235'
12792          ISTRZ1(1:4)='1235'
12793          NCHAR=4
12794          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12795          IF(IERROR.EQ.'YES')GOTO9000
12796C
12797          ISTR1(NBASE1+1:NBASE1+4)='1245'
12798          ISTRZ1(1:4)='1245'
12799          NCHAR=4
12800          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12801          IF(IERROR.EQ.'YES')GOTO9000
12802C
12803          ISTR1(NBASE1+1:NBASE1+4)='1345'
12804          ISTRZ1(1:4)='1345'
12805          NCHAR=4
12806          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12807          IF(IERROR.EQ.'YES')GOTO9000
12808C
12809          ISTR1(NBASE1+1:NBASE1+4)='2345'
12810          ISTRZ1(1:4)='2345'
12811          NCHAR=4
12812          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12813          IF(IERROR.EQ.'YES')GOTO9000
12814C
12815          ISTR1(NBASE1+1:NBASE1+5)='12345'
12816          ISTRZ1(1:5)='12345'
12817          NCHAR=5
12818          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
12819          IF(IERROR.EQ.'YES')GOTO9000
12820C
12821          ISTR2(NBASE2+1:NBASE2+1)='1'
12822          ISTRZ2(1:1)='1'
12823          NCHAR=1
12824          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12825          IF(IERROR.EQ.'YES')GOTO9000
12826C
12827          ISTR2(NBASE2+1:NBASE2+1)='2'
12828          ISTRZ2(1:1)='2'
12829          NCHAR=1
12830          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12831          IF(IERROR.EQ.'YES')GOTO9000
12832C
12833          ISTR2(NBASE2+1:NBASE2+2)='3'
12834          ISTRZ2(1:1)='3'
12835          NCHAR=1
12836          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12837          IF(IERROR.EQ.'YES')GOTO9000
12838C
12839          ISTR2(NBASE2+1:NBASE2+2)='4'
12840          ISTRZ2(1:1)='4'
12841          NCHAR=1
12842          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12843          IF(IERROR.EQ.'YES')GOTO9000
12844C
12845          ISTR2(NBASE2+1:NBASE2+2)='5'
12846          ISTRZ2(1:1)='5'
12847          NCHAR=1
12848          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12849          IF(IERROR.EQ.'YES')GOTO9000
12850C
12851          ISTR2(NBASE2+1:NBASE2+2)='12'
12852          ISTRZ2(1:2)='12'
12853          NCHAR=2
12854          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12855          IF(IERROR.EQ.'YES')GOTO9000
12856C
12857          ISTR2(NBASE2+1:NBASE2+2)='13'
12858          ISTRZ2(1:2)='13'
12859          NCHAR=2
12860          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12861          IF(IERROR.EQ.'YES')GOTO9000
12862C
12863          ISTR2(NBASE2+1:NBASE2+2)='14'
12864          ISTRZ2(1:2)='14'
12865          NCHAR=2
12866          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12867          IF(IERROR.EQ.'YES')GOTO9000
12868C
12869          ISTR2(NBASE2+1:NBASE2+2)='15'
12870          ISTRZ2(1:2)='15'
12871          NCHAR=2
12872          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12873          IF(IERROR.EQ.'YES')GOTO9000
12874C
12875          ISTR2(NBASE2+1:NBASE2+2)='23'
12876          ISTRZ2(1:2)='23'
12877          NCHAR=2
12878          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12879          IF(IERROR.EQ.'YES')GOTO9000
12880C
12881          ISTR2(NBASE2+1:NBASE2+2)='24'
12882          ISTRZ2(1:2)='24'
12883          NCHAR=2
12884          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12885          IF(IERROR.EQ.'YES')GOTO9000
12886C
12887          ISTR2(NBASE2+1:NBASE2+2)='25'
12888          ISTRZ2(1:2)='25'
12889          NCHAR=2
12890          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12891          IF(IERROR.EQ.'YES')GOTO9000
12892C
12893          ISTR2(NBASE2+1:NBASE2+2)='34'
12894          ISTRZ2(1:2)='34'
12895          NCHAR=2
12896          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12897          IF(IERROR.EQ.'YES')GOTO9000
12898C
12899          ISTR2(NBASE2+1:NBASE2+2)='35'
12900          ISTRZ2(1:2)='35'
12901          NCHAR=2
12902          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12903          IF(IERROR.EQ.'YES')GOTO9000
12904C
12905          ISTR2(NBASE2+1:NBASE2+2)='45'
12906          ISTRZ2(1:2)='45'
12907          NCHAR=2
12908          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12909          IF(IERROR.EQ.'YES')GOTO9000
12910C
12911          ISTR2(NBASE2+1:NBASE2+3)='123'
12912          ISTRZ2(1:3)='123'
12913          NCHAR=3
12914          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12915          IF(IERROR.EQ.'YES')GOTO9000
12916C
12917          ISTR2(NBASE2+1:NBASE2+3)='124'
12918          ISTRZ2(1:3)='124'
12919          NCHAR=3
12920          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12921          IF(IERROR.EQ.'YES')GOTO9000
12922C
12923          ISTR2(NBASE2+1:NBASE2+3)='125'
12924          ISTRZ2(1:3)='125'
12925          NCHAR=3
12926          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12927          IF(IERROR.EQ.'YES')GOTO9000
12928C
12929          ISTR2(NBASE2+1:NBASE2+3)='134'
12930          ISTRZ2(1:3)='134'
12931          NCHAR=3
12932          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12933          IF(IERROR.EQ.'YES')GOTO9000
12934C
12935          ISTR2(NBASE2+1:NBASE2+3)='135'
12936          ISTRZ2(1:3)='135'
12937          NCHAR=3
12938          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12939          IF(IERROR.EQ.'YES')GOTO9000
12940C
12941          ISTR2(NBASE2+1:NBASE2+3)='145'
12942          ISTRZ2(1:3)='145'
12943          NCHAR=3
12944          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12945          IF(IERROR.EQ.'YES')GOTO9000
12946C
12947          ISTR2(NBASE2+1:NBASE2+3)='234'
12948          ISTRZ2(1:3)='234'
12949          NCHAR=3
12950          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12951          IF(IERROR.EQ.'YES')GOTO9000
12952C
12953          ISTR2(NBASE2+1:NBASE2+3)='235'
12954          ISTRZ2(1:3)='235'
12955          NCHAR=3
12956          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12957          IF(IERROR.EQ.'YES')GOTO9000
12958C
12959          ISTR2(NBASE2+1:NBASE2+3)='245'
12960          ISTRZ2(1:3)='245'
12961          NCHAR=3
12962          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12963          IF(IERROR.EQ.'YES')GOTO9000
12964C
12965          ISTR2(NBASE2+1:NBASE2+3)='345'
12966          ISTRZ2(1:3)='345'
12967          NCHAR=3
12968          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12969          IF(IERROR.EQ.'YES')GOTO9000
12970C
12971          ISTR2(NBASE2+1:NBASE2+4)='1234'
12972          ISTRZ2(1:4)='1234'
12973          NCHAR=4
12974          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12975          IF(IERROR.EQ.'YES')GOTO9000
12976C
12977          ISTR2(NBASE2+1:NBASE2+4)='1235'
12978          ISTRZ2(1:4)='1235'
12979          NCHAR=4
12980          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12981          IF(IERROR.EQ.'YES')GOTO9000
12982C
12983          ISTR2(NBASE2+1:NBASE2+4)='1245'
12984          ISTRZ2(1:4)='1245'
12985          NCHAR=4
12986          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12987          IF(IERROR.EQ.'YES')GOTO9000
12988C
12989          ISTR2(NBASE2+1:NBASE2+4)='1345'
12990          ISTRZ2(1:4)='1345'
12991          NCHAR=4
12992          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12993          IF(IERROR.EQ.'YES')GOTO9000
12994C
12995          ISTR2(NBASE2+1:NBASE2+4)='2345'
12996          ISTRZ2(1:4)='2345'
12997          NCHAR=4
12998          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
12999          IF(IERROR.EQ.'YES')GOTO9000
13000C
13001          ISTR2(NBASE2+1:NBASE2+5)='12345'
13002          ISTRZ2(1:5)='12345'
13003          NCHAR=5
13004          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13005          IF(IERROR.EQ.'YES')GOTO9000
13006C
13007        ELSEIF(K.EQ.6)THEN
13008C
13009C         K = 6, N = 32 (2**(6-1))
13010C
13011C           CON1     = 1
13012C           CON2     = 2
13013C           CON3     = 3
13014C           CON4     = 4
13015C           CON5     = 5
13016C           CON12    = 12
13017C           CON13    = 13
13018C           CON14    = 14
13019C           CON15    = 15
13020C           CON23    = 23
13021C           CON24    = 24
13022C           CON25    = 25
13023C           CON34    = 34
13024C           CON35    = 35
13025C           CON45    = 45
13026C           CON123   = 123
13027C           CON124   = 124
13028C           CON125   = 125
13029C           CON134   = 134
13030C           CON135   = 135
13031C           CON145   = 145
13032C           CON234   = 234
13033C           CON235   = 235
13034C           CON245   = 245
13035C           CON345   = 345
13036C           CON1234  = 56
13037C           CON1235  = 46
13038C           CON1245  = 36
13039C           CON1345  = 26
13040C           CON2345  = 16
13041C           CON12345 = 6
13042C
13043C           COP1     = 1
13044C           COP2     = 2
13045C           COP3     = 3
13046C           COP4     = 4
13047C           COP5     = 5
13048C           COP12    = 12
13049C           COP13    = 13
13050C           COP14    = 14
13051C           COP15    = 15
13052C           COP23    = 23
13053C           COP24    = 24
13054C           COP25    = 25
13055C           COP34    = 34
13056C           COP35    = 35
13057C           COP45    = 45
13058C           COP123   = 123
13059C           COP124   = 124
13060C           COP125   = 125
13061C           COP134   = 134
13062C           COP135   = 135
13063C           COP145   = 145
13064C           COP234   = 234
13065C           COP235   = 235
13066C           COP245   = 245
13067C           COP345   = 345
13068C           COP1234  = 56
13069C           COP1235  = 46
13070C           COP1245  = 36
13071C           COP1345  = 26
13072C           COP2345  = 16
13073C           COP12345 = 6
13074C
13075C         MAKE SURE STRING NAME WILL HAVE <= 8 CHARACTERS
13076C
13077          IF(NBASE1.GT.3)THEN
13078            IERROR='YES'
13079            GOTO8010
13080          ELSEIF(NBASE2.GT.3)THEN
13081            IERROR='YES'
13082            GOTO8010
13083          ENDIF
13084C
13085C         NOW CREATE THE STRINGS
13086C
13087          ISTR1(NBASE1+1:NBASE1+1)='1'
13088          ISTRZ1(1:1)='1'
13089          NCHAR=1
13090          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13091          IF(IERROR.EQ.'YES')GOTO9000
13092C
13093          ISTR1(NBASE1+1:NBASE1+1)='2'
13094          ISTRZ1(1:1)='2'
13095          NCHAR=1
13096          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13097          IF(IERROR.EQ.'YES')GOTO9000
13098C
13099          ISTR1(NBASE1+1:NBASE1+2)='3'
13100          ISTRZ1(1:1)='3'
13101          NCHAR=1
13102          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13103          IF(IERROR.EQ.'YES')GOTO9000
13104C
13105          ISTR1(NBASE1+1:NBASE1+2)='4'
13106          ISTRZ1(1:1)='4'
13107          NCHAR=1
13108          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13109          IF(IERROR.EQ.'YES')GOTO9000
13110C
13111          ISTR1(NBASE1+1:NBASE1+2)='5'
13112          ISTRZ1(1:1)='5'
13113          NCHAR=1
13114          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13115          IF(IERROR.EQ.'YES')GOTO9000
13116C
13117          ISTR1(NBASE1+1:NBASE1+2)='12'
13118          ISTRZ1(1:2)='12'
13119          NCHAR=2
13120          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13121          IF(IERROR.EQ.'YES')GOTO9000
13122C
13123          ISTR1(NBASE1+1:NBASE1+2)='13'
13124          ISTRZ1(1:2)='13'
13125          NCHAR=2
13126          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13127          IF(IERROR.EQ.'YES')GOTO9000
13128C
13129          ISTR1(NBASE1+1:NBASE1+2)='14'
13130          ISTRZ1(1:2)='14'
13131          NCHAR=2
13132          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13133          IF(IERROR.EQ.'YES')GOTO9000
13134C
13135          ISTR1(NBASE1+1:NBASE1+2)='15'
13136          ISTRZ1(1:2)='15'
13137          NCHAR=2
13138          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13139          IF(IERROR.EQ.'YES')GOTO9000
13140C
13141          ISTR1(NBASE1+1:NBASE1+2)='23'
13142          ISTRZ1(1:2)='23'
13143          NCHAR=2
13144          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13145          IF(IERROR.EQ.'YES')GOTO9000
13146C
13147          ISTR1(NBASE1+1:NBASE1+2)='24'
13148          ISTRZ1(1:2)='24'
13149          NCHAR=2
13150          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13151          IF(IERROR.EQ.'YES')GOTO9000
13152C
13153          ISTR1(NBASE1+1:NBASE1+2)='25'
13154          ISTRZ1(1:2)='25'
13155          NCHAR=2
13156          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13157          IF(IERROR.EQ.'YES')GOTO9000
13158C
13159          ISTR1(NBASE1+1:NBASE1+2)='34'
13160          ISTRZ1(1:2)='34'
13161          NCHAR=2
13162          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13163          IF(IERROR.EQ.'YES')GOTO9000
13164C
13165          ISTR1(NBASE1+1:NBASE1+2)='35'
13166          ISTRZ1(1:2)='35'
13167          NCHAR=2
13168          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13169          IF(IERROR.EQ.'YES')GOTO9000
13170C
13171          ISTR1(NBASE1+1:NBASE1+2)='45'
13172          ISTRZ1(1:2)='45'
13173          NCHAR=2
13174          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13175          IF(IERROR.EQ.'YES')GOTO9000
13176C
13177          ISTR1(NBASE1+1:NBASE1+3)='123'
13178          ISTRZ1(1:3)='123'
13179          NCHAR=3
13180          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13181          IF(IERROR.EQ.'YES')GOTO9000
13182C
13183          ISTR1(NBASE1+1:NBASE1+3)='124'
13184          ISTRZ1(1:3)='124'
13185          NCHAR=3
13186          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13187          IF(IERROR.EQ.'YES')GOTO9000
13188C
13189          ISTR1(NBASE1+1:NBASE1+3)='125'
13190          ISTRZ1(1:3)='125'
13191          NCHAR=3
13192          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13193          IF(IERROR.EQ.'YES')GOTO9000
13194C
13195          ISTR1(NBASE1+1:NBASE1+3)='134'
13196          ISTRZ1(1:3)='134'
13197          NCHAR=3
13198          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13199          IF(IERROR.EQ.'YES')GOTO9000
13200C
13201          ISTR1(NBASE1+1:NBASE1+3)='135'
13202          ISTRZ1(1:3)='135'
13203          NCHAR=3
13204          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13205          IF(IERROR.EQ.'YES')GOTO9000
13206C
13207          ISTR1(NBASE1+1:NBASE1+3)='145'
13208          ISTRZ1(1:3)='145'
13209          NCHAR=3
13210          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13211          IF(IERROR.EQ.'YES')GOTO9000
13212C
13213          ISTR1(NBASE1+1:NBASE1+3)='234'
13214          ISTRZ1(1:3)='234'
13215          NCHAR=3
13216          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13217          IF(IERROR.EQ.'YES')GOTO9000
13218C
13219          ISTR1(NBASE1+1:NBASE1+3)='235'
13220          ISTRZ1(1:3)='235'
13221          NCHAR=3
13222          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13223          IF(IERROR.EQ.'YES')GOTO9000
13224C
13225          ISTR1(NBASE1+1:NBASE1+3)='245'
13226          ISTRZ1(1:3)='245'
13227          NCHAR=3
13228          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13229          IF(IERROR.EQ.'YES')GOTO9000
13230C
13231          ISTR1(NBASE1+1:NBASE1+3)='345'
13232          ISTRZ1(1:3)='345'
13233          NCHAR=3
13234          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13235          IF(IERROR.EQ.'YES')GOTO9000
13236C
13237          ISTR1(NBASE1+1:NBASE1+4)='1234'
13238          ISTRZ1(1:2)='56'
13239          NCHAR=2
13240          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13241          IF(IERROR.EQ.'YES')GOTO9000
13242C
13243          ISTR1(NBASE1+1:NBASE1+4)='1235'
13244          ISTRZ1(1:2)='46'
13245          NCHAR=2
13246          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13247          IF(IERROR.EQ.'YES')GOTO9000
13248C
13249          ISTR1(NBASE1+1:NBASE1+4)='1245'
13250          ISTRZ1(1:2)='36'
13251          NCHAR=2
13252          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13253          IF(IERROR.EQ.'YES')GOTO9000
13254C
13255          ISTR1(NBASE1+1:NBASE1+4)='1345'
13256          ISTRZ1(1:2)='26'
13257          NCHAR=2
13258          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13259          IF(IERROR.EQ.'YES')GOTO9000
13260C
13261          ISTR1(NBASE1+1:NBASE1+4)='2345'
13262          ISTRZ1(1:2)='16'
13263          NCHAR=2
13264          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13265          IF(IERROR.EQ.'YES')GOTO9000
13266C
13267          ISTR1(NBASE1+1:NBASE1+5)='12345'
13268          ISTRZ1(1:1)='6'
13269          NCHAR=1
13270          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13271          IF(IERROR.EQ.'YES')GOTO9000
13272C
13273          ISTR2(NBASE2+1:NBASE2+1)='1'
13274          ISTRZ2(1:1)='1'
13275          NCHAR=1
13276          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13277          IF(IERROR.EQ.'YES')GOTO9000
13278C
13279          ISTR2(NBASE2+1:NBASE2+1)='2'
13280          ISTRZ2(1:1)='2'
13281          NCHAR=1
13282          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13283          IF(IERROR.EQ.'YES')GOTO9000
13284C
13285          ISTR2(NBASE2+1:NBASE2+2)='3'
13286          ISTRZ2(1:1)='3'
13287          NCHAR=1
13288          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13289          IF(IERROR.EQ.'YES')GOTO9000
13290C
13291          ISTR2(NBASE2+1:NBASE2+2)='4'
13292          ISTRZ2(1:1)='4'
13293          NCHAR=1
13294          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13295          IF(IERROR.EQ.'YES')GOTO9000
13296C
13297          ISTR2(NBASE2+1:NBASE2+2)='5'
13298          ISTRZ2(1:1)='5'
13299          NCHAR=1
13300          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13301          IF(IERROR.EQ.'YES')GOTO9000
13302C
13303          ISTR2(NBASE2+1:NBASE2+2)='12'
13304          ISTRZ2(1:2)='12'
13305          NCHAR=2
13306          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13307          IF(IERROR.EQ.'YES')GOTO9000
13308C
13309          ISTR2(NBASE2+1:NBASE2+2)='13'
13310          ISTRZ2(1:2)='13'
13311          NCHAR=2
13312          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13313          IF(IERROR.EQ.'YES')GOTO9000
13314C
13315          ISTR2(NBASE2+1:NBASE2+2)='14'
13316          ISTRZ2(1:2)='14'
13317          NCHAR=2
13318          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13319          IF(IERROR.EQ.'YES')GOTO9000
13320C
13321          ISTR2(NBASE2+1:NBASE2+2)='15'
13322          ISTRZ2(1:2)='15'
13323          NCHAR=2
13324          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13325          IF(IERROR.EQ.'YES')GOTO9000
13326C
13327          ISTR2(NBASE2+1:NBASE2+2)='23'
13328          ISTRZ2(1:2)='23'
13329          NCHAR=2
13330          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13331          IF(IERROR.EQ.'YES')GOTO9000
13332C
13333          ISTR2(NBASE2+1:NBASE2+2)='24'
13334          ISTRZ2(1:2)='24'
13335          NCHAR=2
13336          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13337          IF(IERROR.EQ.'YES')GOTO9000
13338C
13339          ISTR2(NBASE2+1:NBASE2+2)='25'
13340          ISTRZ2(1:2)='25'
13341          NCHAR=2
13342          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13343          IF(IERROR.EQ.'YES')GOTO9000
13344C
13345          ISTR2(NBASE2+1:NBASE2+2)='34'
13346          ISTRZ2(1:2)='34'
13347          NCHAR=2
13348          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13349          IF(IERROR.EQ.'YES')GOTO9000
13350C
13351          ISTR2(NBASE2+1:NBASE2+2)='35'
13352          ISTRZ2(1:2)='35'
13353          NCHAR=2
13354          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13355          IF(IERROR.EQ.'YES')GOTO9000
13356C
13357          ISTR2(NBASE2+1:NBASE2+2)='45'
13358          ISTRZ2(1:2)='45'
13359          NCHAR=2
13360          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13361          IF(IERROR.EQ.'YES')GOTO9000
13362C
13363          ISTR2(NBASE2+1:NBASE2+3)='123'
13364          ISTRZ2(1:3)='123'
13365          NCHAR=3
13366          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13367          IF(IERROR.EQ.'YES')GOTO9000
13368C
13369          ISTR2(NBASE2+1:NBASE2+3)='124'
13370          ISTRZ2(1:3)='124'
13371          NCHAR=3
13372          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13373          IF(IERROR.EQ.'YES')GOTO9000
13374C
13375          ISTR2(NBASE2+1:NBASE2+3)='125'
13376          ISTRZ2(1:3)='125'
13377          NCHAR=3
13378          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13379          IF(IERROR.EQ.'YES')GOTO9000
13380C
13381          ISTR2(NBASE2+1:NBASE2+3)='134'
13382          ISTRZ2(1:3)='134'
13383          NCHAR=3
13384          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13385          IF(IERROR.EQ.'YES')GOTO9000
13386C
13387          ISTR2(NBASE2+1:NBASE2+3)='135'
13388          ISTRZ2(1:3)='135'
13389          NCHAR=3
13390          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13391          IF(IERROR.EQ.'YES')GOTO9000
13392C
13393          ISTR2(NBASE2+1:NBASE2+3)='145'
13394          ISTRZ2(1:3)='145'
13395          NCHAR=3
13396          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13397          IF(IERROR.EQ.'YES')GOTO9000
13398C
13399          ISTR2(NBASE2+1:NBASE2+3)='234'
13400          ISTRZ2(1:3)='234'
13401          NCHAR=3
13402          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13403          IF(IERROR.EQ.'YES')GOTO9000
13404C
13405          ISTR2(NBASE2+1:NBASE2+3)='235'
13406          ISTRZ2(1:3)='235'
13407          NCHAR=3
13408          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13409          IF(IERROR.EQ.'YES')GOTO9000
13410C
13411          ISTR2(NBASE2+1:NBASE2+3)='245'
13412          ISTRZ2(1:3)='245'
13413          NCHAR=3
13414          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13415          IF(IERROR.EQ.'YES')GOTO9000
13416C
13417          ISTR2(NBASE2+1:NBASE2+3)='345'
13418          ISTRZ2(1:3)='345'
13419          NCHAR=3
13420          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13421          IF(IERROR.EQ.'YES')GOTO9000
13422C
13423          ISTR2(NBASE2+1:NBASE2+4)='1234'
13424          ISTRZ2(1:2)='56'
13425          NCHAR=2
13426          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13427          IF(IERROR.EQ.'YES')GOTO9000
13428C
13429          ISTR2(NBASE2+1:NBASE2+4)='1235'
13430          ISTRZ2(1:2)='46'
13431          NCHAR=2
13432          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13433          IF(IERROR.EQ.'YES')GOTO9000
13434C
13435          ISTR2(NBASE2+1:NBASE2+4)='1245'
13436          ISTRZ2(1:2)='36'
13437          NCHAR=2
13438          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13439          IF(IERROR.EQ.'YES')GOTO9000
13440C
13441          ISTR2(NBASE2+1:NBASE2+4)='1345'
13442          ISTRZ2(1:2)='26'
13443          NCHAR=2
13444          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13445          IF(IERROR.EQ.'YES')GOTO9000
13446C
13447          ISTR2(NBASE2+1:NBASE2+4)='2345'
13448          ISTRZ2(1:2)='16'
13449          NCHAR=2
13450          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13451          IF(IERROR.EQ.'YES')GOTO9000
13452C
13453          ISTR2(NBASE2+1:NBASE2+5)='12345'
13454          ISTRZ2(1:1)='6'
13455          NCHAR=1
13456          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13457          IF(IERROR.EQ.'YES')GOTO9000
13458C
13459        ELSEIF(K.EQ.7)THEN
13460C
13461C         K = 7, N = 32 (2**(7-2))
13462C
13463C           CON1     = 1
13464C           CON2     = 2
13465C           CON3     = 3
13466C           CON4     = 4
13467C           CON5     = 5
13468C           CON12    = 12
13469C           CON13    = 13
13470C           CON14    = 14
13471C           CON15    = 15
13472C           CON23    = 23
13473C           CON24    = 24
13474C           CON25    = 25
13475C           CON34    = 34
13476C           CON35    = 35
13477C           CON45    = 45
13478C           CON123   = 46
13479C           CON124   = 36
13480C           CON125   = 47
13481C           CON134   = 26
13482C           CON135   = 135
13483C           CON145   = 27
13484C           CON234   = 16
13485C           CON235   = 235
13486C           CON245   = 17
13487C           CON345   = 345
13488C           CON1234  = 6
13489C           CON1235  = 456
13490C           CON1245  = 7
13491C           CON1345  = 256
13492C           CON2345  = 156
13493C           CON12345 = 56
13494C
13495C           COP1     = 1
13496C           COP2     = 2
13497C           COP3     = 3
13498C           COP4     = 4
13499C           COP5     = 5
13500C           COP12    = 12
13501C           COP13    = 13
13502C           COP14    = 14
13503C           COP15    = 15
13504C           COP23    = 23
13505C           COP24    = 24
13506C           COP25    = 25
13507C           COP34    = 34
13508C           COP35    = 35+67
13509C           COP45    = 45
13510C           COP123   = 46
13511C           COP124   = 36+57
13512C           COP125   = 47
13513C           COP134   = 26
13514C           COP135   = 135
13515C           COP145   = 27
13516C           COP234   = 16
13517C           COP235   = 235
13518C           COP245   = 17
13519C           COP345   = 345
13520C           COP1234  = 6
13521C           COP1235  = 456
13522C           COP1245  = 7
13523C           COP1345  = 256
13524C           COP2345  = 156
13525C           COP12345 = 56+37
13526C
13527C         MAKE SURE STRING NAME WILL HAVE <= 8 CHARACTERS
13528C
13529          IF(NBASE1.GT.3)THEN
13530            IERROR='YES'
13531            GOTO8010
13532          ELSEIF(NBASE2.GT.3)THEN
13533            IERROR='YES'
13534            GOTO8010
13535          ENDIF
13536C
13537C         NOW CREATE THE STRINGS
13538C
13539          ISTR1(NBASE1+1:NBASE1+1)='1'
13540          ISTRZ1(1:1)='1'
13541          NCHAR=1
13542          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13543          IF(IERROR.EQ.'YES')GOTO9000
13544C
13545          ISTR1(NBASE1+1:NBASE1+1)='2'
13546          ISTRZ1(1:1)='2'
13547          NCHAR=1
13548          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13549          IF(IERROR.EQ.'YES')GOTO9000
13550C
13551          ISTR1(NBASE1+1:NBASE1+2)='3'
13552          ISTRZ1(1:1)='3'
13553          NCHAR=1
13554          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13555          IF(IERROR.EQ.'YES')GOTO9000
13556C
13557          ISTR1(NBASE1+1:NBASE1+2)='4'
13558          ISTRZ1(1:1)='4'
13559          NCHAR=1
13560          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13561          IF(IERROR.EQ.'YES')GOTO9000
13562C
13563          ISTR1(NBASE1+1:NBASE1+2)='5'
13564          ISTRZ1(1:1)='5'
13565          NCHAR=1
13566          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13567          IF(IERROR.EQ.'YES')GOTO9000
13568C
13569          ISTR1(NBASE1+1:NBASE1+2)='12'
13570          ISTRZ1(1:2)='12'
13571          NCHAR=2
13572          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13573          IF(IERROR.EQ.'YES')GOTO9000
13574C
13575          ISTR1(NBASE1+1:NBASE1+2)='13'
13576          ISTRZ1(1:2)='13'
13577          NCHAR=2
13578          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13579          IF(IERROR.EQ.'YES')GOTO9000
13580C
13581          ISTR1(NBASE1+1:NBASE1+2)='14'
13582          ISTRZ1(1:2)='14'
13583          NCHAR=2
13584          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13585          IF(IERROR.EQ.'YES')GOTO9000
13586C
13587          ISTR1(NBASE1+1:NBASE1+2)='15'
13588          ISTRZ1(1:2)='15'
13589          NCHAR=2
13590          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13591          IF(IERROR.EQ.'YES')GOTO9000
13592C
13593          ISTR1(NBASE1+1:NBASE1+2)='23'
13594          ISTRZ1(1:2)='23'
13595          NCHAR=2
13596          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13597          IF(IERROR.EQ.'YES')GOTO9000
13598C
13599          ISTR1(NBASE1+1:NBASE1+2)='24'
13600          ISTRZ1(1:2)='24'
13601          NCHAR=2
13602          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13603          IF(IERROR.EQ.'YES')GOTO9000
13604C
13605          ISTR1(NBASE1+1:NBASE1+2)='25'
13606          ISTRZ1(1:2)='25'
13607          NCHAR=2
13608          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13609          IF(IERROR.EQ.'YES')GOTO9000
13610C
13611          ISTR1(NBASE1+1:NBASE1+2)='34'
13612          ISTRZ1(1:2)='34'
13613          NCHAR=2
13614          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13615          IF(IERROR.EQ.'YES')GOTO9000
13616C
13617          ISTR1(NBASE1+1:NBASE1+2)='35'
13618          ISTRZ1(1:2)='35'
13619          NCHAR=2
13620          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13621          IF(IERROR.EQ.'YES')GOTO9000
13622C
13623          ISTR1(NBASE1+1:NBASE1+2)='45'
13624          ISTRZ1(1:2)='45'
13625          NCHAR=2
13626          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13627          IF(IERROR.EQ.'YES')GOTO9000
13628C
13629          ISTR1(NBASE1+1:NBASE1+3)='123'
13630          ISTRZ1(1:2)='46'
13631          NCHAR=2
13632          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13633          IF(IERROR.EQ.'YES')GOTO9000
13634C
13635          ISTR1(NBASE1+1:NBASE1+3)='124'
13636          ISTRZ1(1:2)='36'
13637          NCHAR=2
13638          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13639          IF(IERROR.EQ.'YES')GOTO9000
13640C
13641          ISTR1(NBASE1+1:NBASE1+3)='125'
13642          ISTRZ1(1:2)='47'
13643          NCHAR=2
13644          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13645          IF(IERROR.EQ.'YES')GOTO9000
13646C
13647          ISTR1(NBASE1+1:NBASE1+3)='134'
13648          ISTRZ1(1:2)='26'
13649          NCHAR=2
13650          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13651          IF(IERROR.EQ.'YES')GOTO9000
13652C
13653          ISTR1(NBASE1+1:NBASE1+3)='135'
13654          ISTRZ1(1:3)='135'
13655          NCHAR=3
13656          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13657          IF(IERROR.EQ.'YES')GOTO9000
13658C
13659          ISTR1(NBASE1+1:NBASE1+3)='145'
13660          ISTRZ1(1:2)='27'
13661          NCHAR=2
13662          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13663          IF(IERROR.EQ.'YES')GOTO9000
13664C
13665          ISTR1(NBASE1+1:NBASE1+3)='234'
13666          ISTRZ1(1:2)='16'
13667          NCHAR=2
13668          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13669          IF(IERROR.EQ.'YES')GOTO9000
13670C
13671          ISTR1(NBASE1+1:NBASE1+3)='235'
13672          ISTRZ1(1:3)='235'
13673          NCHAR=3
13674          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13675          IF(IERROR.EQ.'YES')GOTO9000
13676C
13677          ISTR1(NBASE1+1:NBASE1+3)='245'
13678          ISTRZ1(1:2)='17'
13679          NCHAR=2
13680          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13681          IF(IERROR.EQ.'YES')GOTO9000
13682C
13683          ISTR1(NBASE1+1:NBASE1+3)='345'
13684          ISTRZ1(1:3)='345'
13685          NCHAR=3
13686          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13687          IF(IERROR.EQ.'YES')GOTO9000
13688C
13689          ISTR1(NBASE1+1:NBASE1+4)='1234'
13690          ISTRZ1(1:1)='6'
13691          NCHAR=1
13692          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13693          IF(IERROR.EQ.'YES')GOTO9000
13694C
13695          ISTR1(NBASE1+1:NBASE1+4)='1235'
13696          ISTRZ1(1:3)='456'
13697          NCHAR=3
13698          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13699          IF(IERROR.EQ.'YES')GOTO9000
13700C
13701          ISTR1(NBASE1+1:NBASE1+4)='1245'
13702          ISTRZ1(1:1)='7'
13703          NCHAR=1
13704          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13705          IF(IERROR.EQ.'YES')GOTO9000
13706C
13707          ISTR1(NBASE1+1:NBASE1+4)='1345'
13708          ISTRZ1(1:3)='256'
13709          NCHAR=3
13710          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13711          IF(IERROR.EQ.'YES')GOTO9000
13712C
13713          ISTR1(NBASE1+1:NBASE1+4)='2345'
13714          ISTRZ1(1:3)='156'
13715          NCHAR=3
13716          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13717          IF(IERROR.EQ.'YES')GOTO9000
13718C
13719          ISTR1(NBASE1+1:NBASE1+5)='12345'
13720          ISTRZ1(1:2)='56'
13721          NCHAR=2
13722          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13723          IF(IERROR.EQ.'YES')GOTO9000
13724C
13725          ISTR2(NBASE2+1:NBASE2+1)='1'
13726          ISTRZ2(1:1)='1'
13727          NCHAR=1
13728          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13729          IF(IERROR.EQ.'YES')GOTO9000
13730C
13731          ISTR2(NBASE2+1:NBASE2+1)='2'
13732          ISTRZ2(1:1)='2'
13733          NCHAR=1
13734          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13735          IF(IERROR.EQ.'YES')GOTO9000
13736C
13737          ISTR2(NBASE2+1:NBASE2+2)='3'
13738          ISTRZ2(1:1)='3'
13739          NCHAR=1
13740          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13741          IF(IERROR.EQ.'YES')GOTO9000
13742C
13743          ISTR2(NBASE2+1:NBASE2+2)='4'
13744          ISTRZ2(1:1)='4'
13745          NCHAR=1
13746          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13747          IF(IERROR.EQ.'YES')GOTO9000
13748C
13749          ISTR2(NBASE2+1:NBASE2+2)='5'
13750          ISTRZ2(1:1)='5'
13751          NCHAR=1
13752          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13753          IF(IERROR.EQ.'YES')GOTO9000
13754C
13755          ISTR2(NBASE2+1:NBASE2+2)='12'
13756          ISTRZ2(1:2)='12'
13757          NCHAR=2
13758          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13759          IF(IERROR.EQ.'YES')GOTO9000
13760C
13761          ISTR2(NBASE2+1:NBASE2+2)='13'
13762          ISTRZ2(1:2)='13'
13763          NCHAR=2
13764          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13765          IF(IERROR.EQ.'YES')GOTO9000
13766C
13767          ISTR2(NBASE2+1:NBASE2+2)='14'
13768          ISTRZ2(1:2)='14'
13769          NCHAR=2
13770          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13771          IF(IERROR.EQ.'YES')GOTO9000
13772C
13773          ISTR2(NBASE2+1:NBASE2+2)='15'
13774          ISTRZ2(1:2)='15'
13775          NCHAR=2
13776          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13777          IF(IERROR.EQ.'YES')GOTO9000
13778C
13779          ISTR2(NBASE2+1:NBASE2+2)='23'
13780          ISTRZ2(1:2)='23'
13781          NCHAR=2
13782          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13783          IF(IERROR.EQ.'YES')GOTO9000
13784C
13785          ISTR2(NBASE2+1:NBASE2+2)='24'
13786          ISTRZ2(1:2)='24'
13787          NCHAR=2
13788          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13789          IF(IERROR.EQ.'YES')GOTO9000
13790C
13791          ISTR2(NBASE2+1:NBASE2+2)='25'
13792          ISTRZ2(1:2)='25'
13793          NCHAR=2
13794          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13795          IF(IERROR.EQ.'YES')GOTO9000
13796C
13797          ISTR2(NBASE2+1:NBASE2+2)='34'
13798          ISTRZ2(1:2)='34'
13799          NCHAR=2
13800          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13801          IF(IERROR.EQ.'YES')GOTO9000
13802C
13803          ISTR2(NBASE2+1:NBASE2+2)='35'
13804          ISTRZ2(1:5)='35+67'
13805          NCHAR=5
13806          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13807          IF(IERROR.EQ.'YES')GOTO9000
13808C
13809          ISTR2(NBASE2+1:NBASE2+2)='45'
13810          ISTRZ2(1:2)='45'
13811          NCHAR=2
13812          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13813          IF(IERROR.EQ.'YES')GOTO9000
13814C
13815          ISTR2(NBASE2+1:NBASE2+3)='123'
13816          ISTRZ2(1:2)='46'
13817          NCHAR=2
13818          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13819          IF(IERROR.EQ.'YES')GOTO9000
13820C
13821          ISTR2(NBASE2+1:NBASE2+3)='124'
13822          ISTRZ2(1:5)='36+57'
13823          NCHAR=5
13824          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13825          IF(IERROR.EQ.'YES')GOTO9000
13826C
13827          ISTR2(NBASE2+1:NBASE2+3)='125'
13828          ISTRZ2(1:2)='47'
13829          NCHAR=2
13830          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13831          IF(IERROR.EQ.'YES')GOTO9000
13832C
13833          ISTR2(NBASE2+1:NBASE2+3)='134'
13834          ISTRZ2(1:2)='26'
13835          NCHAR=2
13836          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13837          IF(IERROR.EQ.'YES')GOTO9000
13838C
13839          ISTR2(NBASE2+1:NBASE2+3)='135'
13840          ISTRZ2(1:3)='135'
13841          NCHAR=3
13842          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13843          IF(IERROR.EQ.'YES')GOTO9000
13844C
13845          ISTR2(NBASE2+1:NBASE2+3)='145'
13846          ISTRZ2(1:2)='27'
13847          NCHAR=2
13848          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13849          IF(IERROR.EQ.'YES')GOTO9000
13850C
13851          ISTR2(NBASE2+1:NBASE2+3)='234'
13852          ISTRZ2(1:2)='16'
13853          NCHAR=2
13854          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13855          IF(IERROR.EQ.'YES')GOTO9000
13856C
13857          ISTR2(NBASE2+1:NBASE2+3)='235'
13858          ISTRZ2(1:3)='235'
13859          NCHAR=3
13860          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13861          IF(IERROR.EQ.'YES')GOTO9000
13862C
13863          ISTR2(NBASE2+1:NBASE2+3)='245'
13864          ISTRZ2(1:2)='17'
13865          NCHAR=2
13866          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13867          IF(IERROR.EQ.'YES')GOTO9000
13868C
13869          ISTR2(NBASE2+1:NBASE2+3)='345'
13870          ISTRZ2(1:3)='345'
13871          NCHAR=3
13872          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13873          IF(IERROR.EQ.'YES')GOTO9000
13874C
13875          ISTR2(NBASE2+1:NBASE2+4)='1234'
13876          ISTRZ2(1:1)='6'
13877          NCHAR=1
13878          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13879          IF(IERROR.EQ.'YES')GOTO9000
13880C
13881          ISTR2(NBASE2+1:NBASE2+4)='1235'
13882          ISTRZ2(1:3)='456'
13883          NCHAR=3
13884          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13885          IF(IERROR.EQ.'YES')GOTO9000
13886C
13887          ISTR2(NBASE2+1:NBASE2+4)='1245'
13888          ISTRZ2(1:1)='7'
13889          NCHAR=1
13890          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13891          IF(IERROR.EQ.'YES')GOTO9000
13892C
13893          ISTR2(NBASE2+1:NBASE2+4)='1345'
13894          ISTRZ2(1:3)='256'
13895          NCHAR=3
13896          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13897          IF(IERROR.EQ.'YES')GOTO9000
13898C
13899          ISTR2(NBASE2+1:NBASE2+4)='2345'
13900          ISTRZ2(1:3)='156'
13901          NCHAR=3
13902          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13903          IF(IERROR.EQ.'YES')GOTO9000
13904C
13905          ISTR2(NBASE2+1:NBASE2+5)='12345'
13906          ISTRZ2(1:5)='56+37'
13907          NCHAR=5
13908          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
13909          IF(IERROR.EQ.'YES')GOTO9000
13910C
13911        ELSEIF(K.EQ.10)THEN
13912C
13913C         K = 10, N = 32 (2**(10-5))
13914C
13915C           CON1     = 1
13916C           CON2     = 2
13917C           CON3     = 3
13918C           CON4     = 4
13919C           CON5     = 5
13920C           CON12    = 12
13921C           CON13    = 13
13922C           CON14    = 14
13923C           CON15    = 15
13924C           CON23    = 23
13925C           CON24    = 24
13926C           CON25    = 25
13927C           CON34    = 34
13928C           CON35    = 35
13929C           CON45    = 45
13930C           CON123   = 46
13931C           CON124   = 36
13932C           CON125   = 37
13933C           CON134   = 26
13934C           CON135   = 27
13935C           CON145   = 28
13936C           CON234   = 16
13937C           CON235   = 17
13938C           CON245   = 18
13939C           CON345   = 19
13940C           CON1234  = 6
13941C           CON1235  = 7
13942C           CON1245  = 8
13943C           CON1345  = 9
13944C           CON2345  = 0
13945C           CON12345 = 10
13946C
13947C           COP1     = 1
13948C           COP2     = 2
13949C           COP3     = 3
13950C           COP4     = 4
13951C           COP5     = 5
13952C           COP12    = 12+90
13953C           COP13    = 13+80
13954C           COP14    = 14+70
13955C           COP15    = 15+60
13956C           COP23    = 23+89
13957C           COP24    = 24+79
13958C           COP25    = 25+69
13959C           COP34    = 34+78
13960C           COP35    = 35+68
13961C           COP45    = 45+67
13962C           COP123   = 46+57
13963C           COP124   = 36+58
13964C           COP125   = 37+48
13965C           COP134   = 26+59
13966C           COP135   = 27+49
13967C           COP145   = 28+39
13968C           COP234   = 16+50
13969C           COP235   = 17+40
13970C           COP245   = 18+30
13971C           COP345   = 19+20
13972C           COP1234  = 6
13973C           COP1235  = 7
13974C           COP1245  = 8
13975C           COP1345  = 9
13976C           COP2345  = 0
13977C           COP12345 = 56+47+38+29+10
13978C
13979C         MAKE SURE STRING NAME WILL HAVE <= 8 CHARACTERS
13980C
13981          IF(NBASE1.GT.3)THEN
13982            IERROR='YES'
13983            GOTO8010
13984          ELSEIF(NBASE2.GT.3)THEN
13985            IERROR='YES'
13986            GOTO8010
13987          ENDIF
13988C
13989C         NOW CREATE THE STRINGS
13990C
13991          ISTR1(NBASE1+1:NBASE1+1)='1'
13992          ISTRZ1(1:1)='1'
13993          NCHAR=1
13994          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
13995          IF(IERROR.EQ.'YES')GOTO9000
13996C
13997          ISTR1(NBASE1+1:NBASE1+1)='2'
13998          ISTRZ1(1:1)='2'
13999          NCHAR=1
14000          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
14001          IF(IERROR.EQ.'YES')GOTO9000
14002C
14003          ISTR1(NBASE1+1:NBASE1+2)='3'
14004          ISTRZ1(1:1)='3'
14005          NCHAR=1
14006          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
14007          IF(IERROR.EQ.'YES')GOTO9000
14008C
14009          ISTR1(NBASE1+1:NBASE1+2)='4'
14010          ISTRZ1(1:1)='4'
14011          NCHAR=1
14012          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
14013          IF(IERROR.EQ.'YES')GOTO9000
14014C
14015          ISTR1(NBASE1+1:NBASE1+2)='5'
14016          ISTRZ1(1:1)='5'
14017          NCHAR=1
14018          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
14019          IF(IERROR.EQ.'YES')GOTO9000
14020C
14021          ISTR1(NBASE1+1:NBASE1+2)='12'
14022          ISTRZ1(1:2)='12'
14023          NCHAR=2
14024          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
14025          IF(IERROR.EQ.'YES')GOTO9000
14026C
14027          ISTR1(NBASE1+1:NBASE1+2)='13'
14028          ISTRZ1(1:2)='13'
14029          NCHAR=2
14030          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
14031          IF(IERROR.EQ.'YES')GOTO9000
14032C
14033          ISTR1(NBASE1+1:NBASE1+2)='14'
14034          ISTRZ1(1:2)='14'
14035          NCHAR=2
14036          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
14037          IF(IERROR.EQ.'YES')GOTO9000
14038C
14039          ISTR1(NBASE1+1:NBASE1+2)='15'
14040          ISTRZ1(1:2)='15'
14041          NCHAR=2
14042          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
14043          IF(IERROR.EQ.'YES')GOTO9000
14044C
14045          ISTR1(NBASE1+1:NBASE1+2)='23'
14046          ISTRZ1(1:2)='23'
14047          NCHAR=2
14048          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
14049          IF(IERROR.EQ.'YES')GOTO9000
14050C
14051          ISTR1(NBASE1+1:NBASE1+2)='24'
14052          ISTRZ1(1:2)='24'
14053          NCHAR=2
14054          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
14055          IF(IERROR.EQ.'YES')GOTO9000
14056C
14057          ISTR1(NBASE1+1:NBASE1+2)='25'
14058          ISTRZ1(1:2)='25'
14059          NCHAR=2
14060          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
14061          IF(IERROR.EQ.'YES')GOTO9000
14062C
14063          ISTR1(NBASE1+1:NBASE1+2)='34'
14064          ISTRZ1(1:2)='34'
14065          NCHAR=2
14066          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
14067          IF(IERROR.EQ.'YES')GOTO9000
14068C
14069          ISTR1(NBASE1+1:NBASE1+2)='35'
14070          ISTRZ1(1:2)='35'
14071          NCHAR=2
14072          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
14073          IF(IERROR.EQ.'YES')GOTO9000
14074C
14075          ISTR1(NBASE1+1:NBASE1+2)='45'
14076          ISTRZ1(1:2)='45'
14077          NCHAR=2
14078          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
14079          IF(IERROR.EQ.'YES')GOTO9000
14080C
14081          ISTR1(NBASE1+1:NBASE1+3)='123'
14082          ISTRZ1(1:2)='46'
14083          NCHAR=2
14084          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
14085          IF(IERROR.EQ.'YES')GOTO9000
14086C
14087          ISTR1(NBASE1+1:NBASE1+3)='124'
14088          ISTRZ1(1:2)='36'
14089          NCHAR=2
14090          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
14091          IF(IERROR.EQ.'YES')GOTO9000
14092C
14093          ISTR1(NBASE1+1:NBASE1+3)='125'
14094          ISTRZ1(1:2)='37'
14095          NCHAR=2
14096          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
14097          IF(IERROR.EQ.'YES')GOTO9000
14098C
14099          ISTR1(NBASE1+1:NBASE1+3)='134'
14100          ISTRZ1(1:2)='26'
14101          NCHAR=2
14102          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
14103          IF(IERROR.EQ.'YES')GOTO9000
14104C
14105          ISTR1(NBASE1+1:NBASE1+3)='135'
14106          ISTRZ1(1:2)='27'
14107          NCHAR=2
14108          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
14109          IF(IERROR.EQ.'YES')GOTO9000
14110C
14111          ISTR1(NBASE1+1:NBASE1+3)='145'
14112          ISTRZ1(1:2)='28'
14113          NCHAR=2
14114          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
14115          IF(IERROR.EQ.'YES')GOTO9000
14116C
14117          ISTR1(NBASE1+1:NBASE1+3)='234'
14118          ISTRZ1(1:2)='16'
14119          NCHAR=2
14120          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
14121          IF(IERROR.EQ.'YES')GOTO9000
14122C
14123          ISTR1(NBASE1+1:NBASE1+3)='235'
14124          ISTRZ1(1:2)='17'
14125          NCHAR=2
14126          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
14127          IF(IERROR.EQ.'YES')GOTO9000
14128C
14129          ISTR1(NBASE1+1:NBASE1+3)='245'
14130          ISTRZ1(1:2)='18'
14131          NCHAR=2
14132          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
14133          IF(IERROR.EQ.'YES')GOTO9000
14134C
14135          ISTR1(NBASE1+1:NBASE1+3)='345'
14136          ISTRZ1(1:2)='19'
14137          NCHAR=2
14138          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
14139          IF(IERROR.EQ.'YES')GOTO9000
14140C
14141          ISTR1(NBASE1+1:NBASE1+4)='1234'
14142          ISTRZ1(1:1)='6'
14143          NCHAR=1
14144          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
14145          IF(IERROR.EQ.'YES')GOTO9000
14146C
14147          ISTR1(NBASE1+1:NBASE1+4)='1235'
14148          ISTRZ1(1:1)='7'
14149          NCHAR=1
14150          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
14151          IF(IERROR.EQ.'YES')GOTO9000
14152C
14153          ISTR1(NBASE1+1:NBASE1+4)='1245'
14154          ISTRZ1(1:1)='8'
14155          NCHAR=1
14156          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
14157          IF(IERROR.EQ.'YES')GOTO9000
14158C
14159          ISTR1(NBASE1+1:NBASE1+4)='1345'
14160          ISTRZ1(1:1)='9'
14161          NCHAR=1
14162          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
14163          IF(IERROR.EQ.'YES')GOTO9000
14164C
14165          ISTR1(NBASE1+1:NBASE1+4)='2345'
14166          ISTRZ1(1:1)='0'
14167          NCHAR=1
14168          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
14169          IF(IERROR.EQ.'YES')GOTO9000
14170C
14171          ISTR1(NBASE1+1:NBASE1+5)='12345'
14172          ISTRZ1(1:2)='10'
14173          NCHAR=2
14174          CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR)
14175          IF(IERROR.EQ.'YES')GOTO9000
14176C
14177          ISTR2(NBASE2+1:NBASE2+1)='1'
14178          ISTRZ2(1:1)='1'
14179          NCHAR=1
14180          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
14181          IF(IERROR.EQ.'YES')GOTO9000
14182C
14183          ISTR2(NBASE2+1:NBASE2+1)='2'
14184          ISTRZ2(1:1)='2'
14185          NCHAR=1
14186          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
14187          IF(IERROR.EQ.'YES')GOTO9000
14188C
14189          ISTR2(NBASE2+1:NBASE2+2)='3'
14190          ISTRZ2(1:1)='3'
14191          NCHAR=1
14192          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
14193          IF(IERROR.EQ.'YES')GOTO9000
14194C
14195          ISTR2(NBASE2+1:NBASE2+2)='4'
14196          ISTRZ2(1:1)='4'
14197          NCHAR=1
14198          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
14199          IF(IERROR.EQ.'YES')GOTO9000
14200C
14201          ISTR2(NBASE2+1:NBASE2+2)='5'
14202          ISTRZ2(1:1)='5'
14203          NCHAR=1
14204          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
14205          IF(IERROR.EQ.'YES')GOTO9000
14206C
14207          ISTR2(NBASE2+1:NBASE2+2)='12'
14208          ISTRZ2(1:5)='12+90'
14209          NCHAR=5
14210          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
14211          IF(IERROR.EQ.'YES')GOTO9000
14212C
14213          ISTR2(NBASE2+1:NBASE2+2)='13'
14214          ISTRZ2(1:5)='13+80'
14215          NCHAR=5
14216          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
14217          IF(IERROR.EQ.'YES')GOTO9000
14218C
14219          ISTR2(NBASE2+1:NBASE2+2)='14'
14220          ISTRZ2(1:5)='14+70'
14221          NCHAR=5
14222          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
14223          IF(IERROR.EQ.'YES')GOTO9000
14224C
14225          ISTR2(NBASE2+1:NBASE2+2)='15'
14226          ISTRZ2(1:5)='15+60'
14227          NCHAR=5
14228          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
14229          IF(IERROR.EQ.'YES')GOTO9000
14230C
14231          ISTR2(NBASE2+1:NBASE2+2)='23'
14232          ISTRZ2(1:5)='23+89'
14233          NCHAR=5
14234          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
14235          IF(IERROR.EQ.'YES')GOTO9000
14236C
14237          ISTR2(NBASE2+1:NBASE2+2)='24'
14238          ISTRZ2(1:5)='24+79'
14239          NCHAR=5
14240          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
14241          IF(IERROR.EQ.'YES')GOTO9000
14242C
14243          ISTR2(NBASE2+1:NBASE2+2)='25'
14244          ISTRZ2(1:5)='25+69'
14245          NCHAR=5
14246          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
14247          IF(IERROR.EQ.'YES')GOTO9000
14248C
14249          ISTR2(NBASE2+1:NBASE2+2)='34'
14250          ISTRZ2(1:5)='34+78'
14251          NCHAR=5
14252          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
14253          IF(IERROR.EQ.'YES')GOTO9000
14254C
14255          ISTR2(NBASE2+1:NBASE2+2)='35'
14256          ISTRZ2(1:5)='35+68'
14257          NCHAR=5
14258          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
14259          IF(IERROR.EQ.'YES')GOTO9000
14260C
14261          ISTR2(NBASE2+1:NBASE2+2)='45'
14262          ISTRZ2(1:5)='45+67'
14263          NCHAR=5
14264          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
14265          IF(IERROR.EQ.'YES')GOTO9000
14266C
14267          ISTR2(NBASE2+1:NBASE2+3)='123'
14268          ISTRZ2(1:5)='46+57'
14269          NCHAR=5
14270          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
14271          IF(IERROR.EQ.'YES')GOTO9000
14272C
14273          ISTR2(NBASE2+1:NBASE2+3)='124'
14274          ISTRZ2(1:5)='36+58'
14275          NCHAR=5
14276          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
14277          IF(IERROR.EQ.'YES')GOTO9000
14278C
14279          ISTR2(NBASE2+1:NBASE2+3)='125'
14280          ISTRZ2(1:5)='37+48'
14281          NCHAR=5
14282          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
14283          IF(IERROR.EQ.'YES')GOTO9000
14284C
14285          ISTR2(NBASE2+1:NBASE2+3)='134'
14286          ISTRZ2(1:5)='26+59'
14287          NCHAR=5
14288          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
14289          IF(IERROR.EQ.'YES')GOTO9000
14290C
14291          ISTR2(NBASE2+1:NBASE2+3)='135'
14292          ISTRZ2(1:5)='27+49'
14293          NCHAR=5
14294          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
14295          IF(IERROR.EQ.'YES')GOTO9000
14296C
14297          ISTR2(NBASE2+1:NBASE2+3)='145'
14298          ISTRZ2(1:5)='28+39'
14299          NCHAR=5
14300          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
14301          IF(IERROR.EQ.'YES')GOTO9000
14302C
14303          ISTR2(NBASE2+1:NBASE2+3)='234'
14304          ISTRZ2(1:5)='16+50'
14305          NCHAR=5
14306          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
14307          IF(IERROR.EQ.'YES')GOTO9000
14308C
14309          ISTR2(NBASE2+1:NBASE2+3)='235'
14310          ISTRZ2(1:5)='17+40'
14311          NCHAR=5
14312          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
14313          IF(IERROR.EQ.'YES')GOTO9000
14314C
14315          ISTR2(NBASE2+1:NBASE2+3)='245'
14316          ISTRZ2(1:5)='18+30'
14317          NCHAR=5
14318          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
14319          IF(IERROR.EQ.'YES')GOTO9000
14320C
14321          ISTR2(NBASE2+1:NBASE2+3)='345'
14322          ISTRZ2(1:5)='19+20'
14323          NCHAR=5
14324          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
14325          IF(IERROR.EQ.'YES')GOTO9000
14326C
14327          ISTR2(NBASE2+1:NBASE2+4)='1234'
14328          ISTRZ2(1:1)='6'
14329          NCHAR=1
14330          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
14331          IF(IERROR.EQ.'YES')GOTO9000
14332C
14333          ISTR2(NBASE2+1:NBASE2+4)='1235'
14334          ISTRZ2(1:1)='7'
14335          NCHAR=1
14336          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
14337          IF(IERROR.EQ.'YES')GOTO9000
14338C
14339          ISTR2(NBASE2+1:NBASE2+4)='1245'
14340          ISTRZ2(1:1)='8'
14341          NCHAR=1
14342          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
14343          IF(IERROR.EQ.'YES')GOTO9000
14344C
14345          ISTR2(NBASE2+1:NBASE2+4)='1345'
14346          ISTRZ2(1:1)='9'
14347          NCHAR=1
14348          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
14349          IF(IERROR.EQ.'YES')GOTO9000
14350C
14351          ISTR2(NBASE2+1:NBASE2+4)='2345'
14352          ISTRZ2(1:1)='0'
14353          NCHAR=1
14354          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
14355          IF(IERROR.EQ.'YES')GOTO9000
14356C
14357          ISTR2(NBASE2+1:NBASE2+5)='12345'
14358          ISTRZ2(1:14)='56+47+38+29+10'
14359          NCHAR=14
14360          CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR)
14361          IF(IERROR.EQ.'YES')GOTO9000
14362C
14363        ELSE
14364          IERROR='YES'
14365          GOTO8030
14366        ENDIF
14367      ELSE
14368        IERROR='YES'
14369        GOTO8030
14370      ENDIF
14371C
14372C               *****************************************************
14373C               **  STEP 7--                                       **
14374C               **  PRINT FEEDBACK MESSAGE                         **
14375C               *****************************************************
14376C
14377      ISTEPN='4'
14378      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NFOU')
14379     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14380C
14381      IF(IFEEDB.EQ.'ON' .AND. IPRINT.EQ.'ON')THEN
14382        WRITE(ICOUT,999)
14383        CALL DPWRST('XXX','BUG ')
14384        WRITE(ICOUT,710)
14385  710   FORMAT(I5,' THE CONFOUNDING STRINGS HAVE BEEN CREATED.')
14386        CALL DPWRST('XXX','BUG ')
14387        WRITE(ICOUT,999)
14388        CALL DPWRST('XXX','BUG ')
14389      ENDIF
14390      GOTO9000
14391C
14392C               *****************************************************
14393C               **  STEP 8--                                       **
14394C               **  PRINT ERROR MESSAGES                           **
14395C               *****************************************************
14396C
14397 8010 CONTINUE
14398      WRITE(ICOUT,999)
14399      CALL DPWRST('XXX','BUG ')
14400      WRITE(ICOUT,101)
14401      CALL DPWRST('XXX','BUG ')
14402      WRITE(ICOUT,8011)
14403 8011 FORMAT('       STRING BASE TOO LONG FOR SPECIFIED N AND K.')
14404      CALL DPWRST('XXX','BUG ')
14405      WRITE(ICOUT,8013)ISTR1
14406 8013 FORMAT('       BASE FOR FIRST SET OF STRINGS IS ',A8)
14407      CALL DPWRST('XXX','BUG ')
14408      WRITE(ICOUT,8015)ISTR2
14409 8015 FORMAT('       BASE FOR SECOND SET OF STRINGS IS ',A8)
14410      CALL DPWRST('XXX','BUG ')
14411      WRITE(ICOUT,8033)K
14412      CALL DPWRST('XXX','BUG ')
14413      WRITE(ICOUT,8035)NTEMP
14414      CALL DPWRST('XXX','BUG ')
14415      GOTO9000
14416C
14417 8020 CONTINUE
14418      WRITE(ICOUT,999)
14419      CALL DPWRST('XXX','BUG ')
14420      WRITE(ICOUT,101)
14421      CALL DPWRST('XXX','BUG ')
14422      WRITE(ICOUT,8021)
14423 8021 FORMAT('       ERROR IN CREATING THE STRINGS.')
14424      CALL DPWRST('XXX','BUG ')
14425      GOTO9000
14426C
14427 8030 CONTINUE
14428      WRITE(ICOUT,999)
14429      CALL DPWRST('XXX','BUG ')
14430      WRITE(ICOUT,101)
14431      CALL DPWRST('XXX','BUG ')
14432      WRITE(ICOUT,8031)
14433 8031 FORMAT('       CONFOUND NOT SPECIFIED FOR GIVEN K AND N.')
14434      CALL DPWRST('XXX','BUG ')
14435      WRITE(ICOUT,8033)K
14436 8033 FORMAT('       THE VALUE OF K IS ',I8)
14437      CALL DPWRST('XXX','BUG ')
14438      WRITE(ICOUT,8035)NTEMP
14439 8035 FORMAT('       THE VALUE OF N IS ',I8)
14440      CALL DPWRST('XXX','BUG ')
14441      GOTO9000
14442C
14443C               ****************
14444C               **  STEP 90-- **
14445C               **  EXIT.     **
14446C               ****************
14447C
14448 9000 CONTINUE
14449      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NFOU')THEN
14450        WRITE(ICOUT,999)
14451        CALL DPWRST('XXX','BUG ')
14452        WRITE(ICOUT,9011)
14453 9011   FORMAT('***** AT THE END       OF CONFOU--')
14454        CALL DPWRST('XXX','BUG ')
14455        WRITE(ICOUT,9013)NUMNAM
14456 9013   FORMAT('NUMNAM,IVALUE = ',2I8)
14457        CALL DPWRST('XXX','BUG ')
14458        DO9015I=1,NUMNAM
14459          WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),
14460     1                     IVSTAR(I),IVSTOP(I)
14461 9016     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
14462     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
14463          CALL DPWRST('XXX','BUG ')
14464 9015   CONTINUE
14465      ENDIF
14466C
14467      RETURN
14468      END
14469      SUBROUTINE CONFO2(ISTRIN,ISTRZZ,NCHAR,ISUBRO,IBUGA3,IERROR)
14470C
14471C     PURPOSE--UTILITY ROUTINE FOR "CONFOU".  THIS ROUTINE
14472C              UPDATES A SINGLE STRING IN THE INTERNAL STRING
14473C              TABLE.
14474C     WRITTEN BY--ALAN HECKERT
14475C                 STATISTICAL ENGINEERING DIVISION
14476C                 INFORMATION TECHNOLOGY LABORATORY
14477C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
14478C                 GAITHERSBURG, MD 20899-8980
14479C                 PHONE--301-975-2899
14480C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
14481C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
14482C     LANGUAGE--ANSI FORTRAN (1977)
14483C     VERSION NUMBER--2015/01
14484C     ORIGINAL VERSION--JANUARY   2015.
14485C     UPDATED         --MARCH     2015. CALL LIST TO DPINFU
14486C
14487C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
14488C
14489      CHARACTER*4  ISTRZ2(40)
14490C
14491      CHARACTER*8 ISTRIN
14492      CHARACTER*4 ISUBRO
14493      CHARACTER*4 IBUGA3
14494      CHARACTER*4 IERROR
14495C
14496      CHARACTER*4 NEWNAM
14497      CHARACTER*4 ICASEL
14498      CHARACTER*8 IHLEFT
14499      CHARACTER*4 IHLEF2
14500      CHARACTER*4 ISUBN1
14501      CHARACTER*4 ISUBN2
14502      CHARACTER*4 ISTEPN
14503C
14504      CHARACTER*(*) ISTRZZ
14505C
14506C---------------------------------------------------------------------
14507C
14508C-----COMMON----------------------------------------------------------
14509C
14510      INCLUDE 'DPCOPA.INC'
14511      INCLUDE 'DPCOHK.INC'
14512      INCLUDE 'DPCOHO.INC'
14513      INCLUDE 'DPCODA.INC'
14514C
14515C-----COMMON VARIABLES (GENERAL)--------------------------------------
14516C
14517      INCLUDE 'DPCOP2.INC'
14518C
14519C-----START POINT-----------------------------------------------------
14520C
14521      ISUBN1='CONF'
14522      ISUBN2='O2  '
14523      IERROR='NO'
14524C
14525      N=-1
14526      K=-1
14527      ILOC3=0
14528C
14529      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NFO2')THEN
14530        WRITE(ICOUT,999)
14531  999   FORMAT(1X)
14532        CALL DPWRST('XXX','BUG ')
14533        WRITE(ICOUT,51)
14534   51   FORMAT('***** AT THE BEGINNING OF CONFO2--')
14535        CALL DPWRST('XXX','BUG ')
14536        WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMNAM
14537   52   FORMAT('IBUGA3,ISUBRO,NUMNAM = ',A4,2X,A4,2X,I8)
14538        CALL DPWRST('XXX','BUG ')
14539        DO55I=1,NUMNAM
14540          WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),
14541     1                   IVSTOP(I)
14542   56     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
14543     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
14544          CALL DPWRST('XXX','BUG ')
14545   55   CONTINUE
14546        WRITE(ICOUT,57)NUMCHF,MAXCHF
14547   57   FORMAT('NUMCHF,MAXCHF = ',2I8)
14548        CALL DPWRST('XXX','BUG ')
14549        WRITE(ICOUT,60)(IFUNC(I),I=1,MIN(120,MAXCHF))
14550   60   FORMAT('IFUNC(.)  = ',120A1)
14551        CALL DPWRST('XXX','BUG ')
14552      ENDIF
14553C
14554C               ******************************************************
14555C               **  STEP 5--                                         *
14556C               **  EXAMINE THE CURRENT STRING--                     *
14557C               **  IF THIS IS A PREVIOUSLY DEFINED NAME, IT SHOULD  *
14558C               **  BE A STRING    (IF NOT, REPORT AN ERROR).        *
14559C               ******************************************************
14560C
14561        ISTEPN='5'
14562        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NFO2')
14563     1     CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14564C
14565        DO510II=1,NUMNAM
14566          I2=II
14567          IF(ISTRIN(1:4).EQ.IHNAME(I2).AND.
14568     1       ISTRIN(5:8).EQ.IHNAM2(I2))THEN
14569            IF(IUSE(I2).EQ.'F')THEN
14570              ICASEL='STRI'
14571              ILISTL=I2
14572              GOTO519
14573            ELSE
14574              WRITE(ICOUT,999)
14575              CALL DPWRST('XXX','BUG ')
14576              WRITE(ICOUT,511)
14577  511         FORMAT('****** ERROR IN CONFO2--')
14578              CALL DPWRST('XXX','BUG ')
14579              WRITE(ICOUT,513)ISTRIN
14580  513         FORMAT('      THE NAME ',A8,' ALREADY EXISTS, BUT NOT ',
14581     1               'AS A STRING.')
14582              CALL DPWRST('XXX','BUG ')
14583              WRITE(ICOUT,515)
14584  515         FORMAT('      THIS STRING WILL NOT BE CREATED.')
14585              CALL DPWRST('XXX','BUG ')
14586              GOTO9000
14587            ENDIF
14588          ENDIF
14589  510   CONTINUE
14590C
14591        NEWNAM='YES'
14592        ICASEL='STRI'
14593C
14594        ILISTL=NUMNAM+1
14595        IF(ILISTL.GT.MAXNAM)THEN
14596          WRITE(ICOUT,999)
14597          CALL DPWRST('XXX','BUG ')
14598          WRITE(ICOUT,511)
14599          CALL DPWRST('XXX','BUG ')
14600          WRITE(ICOUT,522)
14601  522     FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND ',
14602     1           'FUNCTION')
14603          CALL DPWRST('XXX','BUG ')
14604          WRITE(ICOUT,524)MAXNAM
14605  524     FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
14606          CALL DPWRST('XXX','BUG ')
14607          IERROR='YES'
14608          GOTO9000
14609        ENDIF
14610C
14611  519   CONTINUE
14612C
14613C               *****************************************************
14614C               **  STEP 6--                                       **
14615C               **  ADD THE CURRENT STRING                         **
14616C               *****************************************************
14617C
14618        ISTEPN='6'
14619        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NFO2')
14620     1     CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14621C
14622        IHLEFT=ISTRIN(1:4)
14623        IHLEF2=ISTRIN(5:8)
14624        DO411J=1,NCHAR
14625          ISTRZ2(J)=' '
14626          ISTRZ2(J)(1:1)=ISTRZZ(J:J)
14627  411   CONTINUE
14628C
14629        CALL DPINFU(ISTRZ2,NCHAR,IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP,
14630     1              NUMNAM,IANS,IWIDTH,IHLEFT,IHLEF2,ILISTL,
14631     1              NEWNAM,MAXNME,
14632     1              IFUNC,NUMCHF,MAXCHF,IBUGA3,IERROR)
14633        IF(IERROR.EQ.'YES')GOTO9000
14634C
14635C               ****************
14636C               **  STEP 90-- **
14637C               **  EXIT.     **
14638C               ****************
14639C
14640 9000 CONTINUE
14641      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NFO2')THEN
14642        WRITE(ICOUT,999)
14643        CALL DPWRST('XXX','BUG ')
14644        WRITE(ICOUT,9011)
14645 9011   FORMAT('***** AT THE END       OF CONFO2--')
14646        CALL DPWRST('XXX','BUG ')
14647        WRITE(ICOUT,9013)NUMNAM
14648 9013   FORMAT('NUMNAM,IVALUE = ',2I8)
14649        CALL DPWRST('XXX','BUG ')
14650        DO9015I=1,NUMNAM
14651          WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),
14652     1                     IVSTAR(I),IVSTOP(I)
14653 9016     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
14654     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
14655          CALL DPWRST('XXX','BUG ')
14656 9015   CONTINUE
14657      ENDIF
14658C
14659      RETURN
14660      END
14661      DOUBLE PRECISION FUNCTION CONFUN(DM)
14662C
14663C     PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE
14664C              CONSUL MEAN AND ONES FREQUENCY EQUATION.
14665C
14666C              THE MEAN AND ONES FREQUENCY ESTIMATE OF MU IS:
14667C
14668C                  MUHAT = XBAR
14669C
14670C              THE ESTIMATE OF M IS THEN THE SOLUTION OF THE
14671C              EQUATION
14672C
14673C                 M*LOG(1 - (XBAR-1)/(M*XBAR)) - LOG(N1/N) = 0
14674C
14675C              CALLED BY DFZERO ROUTINE FOR SOLVING A NONLINEAR
14676C              UNIVARIATE EQUATION.
14677C     EXAMPLE--CONSUL MAXIMUM LIKELIHOOD Y
14678C     REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
14679C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTER 8.
14680C     WRITTEN BY--JAMES J. FILLIBEN
14681C                 STATISTICAL ENGINEERING DIVISION
14682C                 INFORMATION TECHNOLOGY LABORATORY
14683C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
14684C                 GAITHERSBUG, MD 20899-8980
14685C                 PHONE--301-975-2855
14686C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
14687C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
14688C     LANGUAGE--ANSI FORTRAN (1977)
14689C     VERSION NUMBER--2006/8
14690C     ORIGINAL VERSION--AUGUST    2006.
14691C
14692C---------------------------------------------------------------------
14693C
14694      DOUBLE PRECISION DM
14695C
14696      DOUBLE PRECISION XBAR
14697      DOUBLE PRECISION S2
14698      DOUBLE PRECISION F1FREQ
14699      COMMON/CONCOM/XBAR,S2,F1FREQ,MAXROW,N
14700C
14701C---------------------------------------------------------------------
14702C
14703      INCLUDE 'DPCOP2.INC'
14704C
14705C-----START POINT-----------------------------------------------------
14706C
14707      CONFUN=DM*DLOG(1.0D0 - (XBAR-1.0D0)/(DM*XBAR)) - DLOG(F1FREQ)
14708C
14709      RETURN
14710      END
14711      SUBROUTINE CONFU2(N,XPAR,FVEC,IFLAG,Y,K)
14712C
14713C     PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE
14714C              CONSUL MAXIMUM LIKELIHOOD EQUATION.
14715C
14716C              THE MAXIMUM LIKELIHOOD FREQUENCY ESTIMATE OF MU IS:
14717C
14718C                  MUHAT = XBAR
14719C
14720C              THE ESTIMATE OF M IS THEN THE SOLUTION OF THE
14721C              EQUATION
14722C
14723C                 LOG(1 - (XBAR-1)/(M*XBAR)) + (1/(N*XBAR))*
14724C                 SUM[X=2 to k][SUM[i=0 to X-2][X*N(x)/(M*X-i)]] = 0
14725C
14726C              THIS ROUTINE ASSUMES THE DATA IS IN THE FORM
14727C
14728C                   X(I)  FREQ(I)
14729C
14730C              CALLED BY DNSQE ROUTINE FOR SOLVING SIMULTANEOUS
14731C              NONLINEAR EQUATIONS.  NOTE THAT THE CALLING SEQUENCE
14732C              DID NOT ACCOMODATE A DATA ARRAY (AND ASSCIATED NUMBER OF
14733C              OBSERVATIONS), SO THESE WERE ADDED TO THE CALL LIST.
14734C              SINCE DNSQE ONLY PASSES ONE ARRAY, WE SPLIT INTO
14735C              TWO PARTS: 1 - MAXNXT/2 ARE THE FREQUENCIES WHILE
14736C              (MAXNXT/2 + 1) - MAXNXT ARE THE CLASS VALUES (I.E.,
14737C              THE X).
14738C     EXAMPLE--CONSUL MAXIMUM LIKELIHOOD Y
14739C     REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
14740C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTER 8.
14741C     WRITTEN BY--JAMES J. FILLIBEN
14742C                 STATISTICAL ENGINEERING DIVISION
14743C                 INFORMATION TECHNOLOGY LABORATORY
14744C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
14745C                 GAITHERSBUG, MD 20899-8980
14746C                 PHONE--301-975-2855
14747C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
14748C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
14749C     LANGUAGE--ANSI FORTRAN (1977)
14750C     VERSION NUMBER--2006/8
14751C     ORIGINAL VERSION--AUGUST    2006.
14752C
14753C---------------------------------------------------------------------
14754C
14755      DOUBLE PRECISION XPAR(*)
14756      DOUBLE PRECISION FVEC(*)
14757      REAL Y(*)
14758C
14759      DOUBLE PRECISION DM
14760      DOUBLE PRECISION DTERM1
14761      DOUBLE PRECISION DTERM2
14762      DOUBLE PRECISION DTERM3
14763      DOUBLE PRECISION DSUM1
14764      DOUBLE PRECISION DN
14765      DOUBLE PRECISION DX
14766      DOUBLE PRECISION DFREQ
14767C
14768      DOUBLE PRECISION XBAR
14769      DOUBLE PRECISION S2
14770      DOUBLE PRECISION F1FREQ
14771      COMMON/CONCOM/XBAR,S2,F1FREQ,MAXROW,NTOT
14772C
14773C---------------------------------------------------------------------
14774C
14775      INCLUDE 'DPCOP2.INC'
14776C
14777C-----START POINT-----------------------------------------------------
14778C
14779      N=1
14780      IFLAG=0
14781C
14782      DM=XPAR(1)
14783      DN=DBLE(NTOT)
14784      IINDX=MAXROW/2
14785C
14786      DTERM1=(DM*XBAR - XBAR + 1.0D0)/(DM*XBAR)
14787      DTERM2=1.0D0/(DN*XBAR)
14788C
14789      DSUM1=0.0D0
14790      DO100I=2,K
14791        DX=DBLE(Y(IINDX+I))
14792        DFREQ=Y(I)
14793        DO200J=0,I-2
14794          DSUM1=DSUM1 + DX*DFREQ/(DM*DX - DBLE(J))
14795  200   CONTINUE
14796  100 CONTINUE
14797C
14798      DTERM3=DTERM2*DSUM1
14799      FVEC(1)=DTERM1 - DEXP(-DTERM3)
14800CCCCC FVEC(1)=DTERM1 + DTERM2*DSUM1
14801C
14802      RETURN
14803      END
14804      SUBROUTINE CONPDF(DX,DSHAPE,DM,ICONDF,DPDF)
14805C
14806C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY MASS
14807C              FUNCTION VALUE FOR THE CONSUL DISTRIBUTION WITH SHAPE
14808C              PARAMETERS THETA AND M.  THIS DISTRIBUTION IS
14809C              DEFINED FOR ALL INTEGER X >= 1.
14810C
14811C              THIS DISTRIBUTION REDUCES TO THE GEOMETRIC
14812C              DISTRIBUTION WHEN M = 1.  FOR THIS REASON, IT
14813C              SOMETIMES REFERRED TO AS THE GENERALIZED GEOMETRIC
14814C              DISTRIBUTION.  NOTE THAT THIS DISTRIBUTION HAS A
14815C              SIMILAR FORM TO THE GEETA DISTRIBUTION.
14816C
14817C              THE PROBABILITY MASS FUNCTION IS:
14818C              p(X;THETA,M)=
14819C                  (M*X  X-1)*THETA**(X-1)*(1-THETA)**(M*X-X+1)/X
14820C                  X = 1, 2, 3, ,...
14821C                  0 < THETA < 1; 1 <= M < 1/THETA
14822C
14823C              THE MEAN AND VARIANCE ARE:
14824C
14825C                  MEAN     = 1/(1-THETA*M)
14826C                  VARIANCE = M*THETA*(1-THETA)/
14827C                             (1-THETA*M)**3
14828C
14829C              THIS DISTRIBUTION IS SOMETIMES PARAMETERIZED USING
14830C              THE MEAN (MU) INSTEAD OF THETA.  THIS RESULTS IN
14831C              THE PROBABILITY MASS FUNCTION:
14832C              p(X;MU,M)=
14833C                  (M*X  X-1)*((MU-1)/(M*MU))**(X-1)*
14834C                  (1 - (M-1)/(M*MU))**(M*X-X+1)/X
14835C                  X = 1, 2, 3, ,...
14836C                  MU >= 1; M > 1
14837C              NOTE THAT THE RELATION IS:
14838C
14839C                  THETA=(MU-1)/(M*MU)
14840C
14841C              THE MEAN AND VARIANCE BECOME:
14842C
14843C                  MEAN     = MU
14844C                  VARIANCE = MU*(MU-1)*(M*MU-MU+1)/M
14845C
14846C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
14847C                                WHICH THE PROBABILITY MASS
14848C                                FUNCTION IS TO BE EVALUATED.
14849C                                X SHOULD BE A NON-NEGATIVE INTEGER.
14850C                     --DSHAPE = THE FIRST SHAPE PARAMETER
14851C                                (EITHER THETA OR MU)
14852C                     --DM     = THE SECOND SHAPE PARAMETER
14853C     OUTPUT ARGUMENTS--DPDF   = THE DOUBLE PRECISION PROBABILITY MASS
14854C                                FUNCTION VALUE.
14855C     OUTPUT--THE DOUBLE PRECISION PROBABILITY MASS FUNCTION VALUE
14856C             PDF FOR THE CONSUL DISTRIBUTION WITH SHAPE PARAMETERS
14857C             THETA (OR MU) AND M
14858C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
14859C     RESTRICTIONS--X SHOULD BE A POSITIVE INTEGER
14860C                 --0 < THETA < 1; 1 < M < 1/THETA
14861C                 --MU >= 1; M > 1
14862C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
14863C     LANGUAGE--ANSI FORTRAN (1977)
14864C     REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
14865C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTER 8.
14866C     WRITTEN BY--JAMES J. FILLIBEN
14867C                 STATISTICAL ENGINEERING DIVISION
14868C                 INFORMATION TECHNOLOGY LABORATORY
14869C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
14870C                 GAITHERSBURG, MD 20899-8980
14871C                 PHONE--301-975-2855
14872C     LANGUAGE--ANSI FORTRAN (1977)
14873C     VERSION NUMBER--2006/8
14874C     ORIGINAL VERSION--AUGUST    2006.
14875C
14876C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
14877C
14878C---------------------------------------------------------------------
14879C
14880      DOUBLE PRECISION DX
14881      DOUBLE PRECISION DSHAPE
14882      DOUBLE PRECISION DM
14883      DOUBLE PRECISION DPDF
14884C
14885      DOUBLE PRECISION DTERM1
14886      DOUBLE PRECISION DTERM2
14887      DOUBLE PRECISION DTERM3
14888      DOUBLE PRECISION DTERM4
14889      DOUBLE PRECISION DTERM5
14890      DOUBLE PRECISION DTERM6
14891      DOUBLE PRECISION DTHETA
14892      DOUBLE PRECISION DMU
14893      DOUBLE PRECISION DLNGAM
14894C
14895      CHARACTER*4 ICONDF
14896C
14897C---------------------------------------------------------------------
14898C
14899      INCLUDE 'DPCOP2.INC'
14900C
14901C-----START POINT-----------------------------------------------------
14902C
14903C     CHECK THE INPUT ARGUMENTS FOR ERRORS
14904C
14905      IF(ICONDF.EQ.'THET')THEN
14906        DTHETA=DSHAPE
14907      ELSE
14908        DMU=DSHAPE
14909      ENDIF
14910C
14911      IX=INT(DX+0.5D0)
14912      IF(IX.LT.1)THEN
14913        WRITE(ICOUT,4)
14914        CALL DPWRST('XXX','BUG ')
14915        WRITE(ICOUT,46)DX
14916        CALL DPWRST('XXX','BUG ')
14917        DPDF=0.0D0
14918        GOTO9000
14919      ENDIF
14920    4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO CONPDF IS LESS ',
14921     1'THAN 1')
14922C
14923      IF(ICONDF.EQ.'THET')THEN
14924        IF(DTHETA.LE.0.0D0 .OR. DTHETA.GE.1.0D0)THEN
14925          WRITE(ICOUT,15)
14926          CALL DPWRST('XXX','BUG ')
14927          WRITE(ICOUT,46)DTHETA
14928          CALL DPWRST('XXX','BUG ')
14929          DPDF=0.0
14930          GOTO9000
14931        ENDIF
14932   15   FORMAT('***** ERROR--THE SECOND ARGUMENT TO CONPDF IS NOT ',
14933     1         'IN THE INTERVAL (0,1)')
14934C
14935        IF(DM.LT.1.0D0 .OR. DM.GE.1.0D0/DTHETA)THEN
14936          WRITE(ICOUT,25)1.0D0/DTHETA
14937          CALL DPWRST('XXX','BUG ')
14938          WRITE(ICOUT,46)DM
14939          CALL DPWRST('XXX','BUG ')
14940          DPDF=0.0
14941          GOTO9000
14942        ENDIF
14943   25   FORMAT('***** ERROR--THE THIRD ARGUMENT TO CONPDF IS NOT ',
14944     1         'IN THE INTERVAL (1,',G15.7,')')
14945      ELSE
14946        IF(DMU.LT.1.0D0)THEN
14947          WRITE(ICOUT,35)
14948          CALL DPWRST('XXX','BUG ')
14949          WRITE(ICOUT,46)DMU
14950          CALL DPWRST('XXX','BUG ')
14951          DPDF=0.0
14952          GOTO9000
14953        ENDIF
14954   35   FORMAT('***** ERROR--THE SECOND ARGUMENT TO CONPDF IS ',
14955     1         'LESS THAN 1')
14956C
14957        IF(DM.LT.1.0D0)THEN
14958          WRITE(ICOUT,38)
14959          CALL DPWRST('XXX','BUG ')
14960          WRITE(ICOUT,46)DM
14961          CALL DPWRST('XXX','BUG ')
14962          DPDF=0.0
14963          GOTO9000
14964        ENDIF
14965   38   FORMAT('***** ERROR--THE THIRD ARGUMENT TO CONPDF IS ',
14966     1         'LESS THAN 1')
14967      ENDIF
14968C
14969   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
14970C
14971      DX=DBLE(IX)
14972C
14973      IF(ICONDF.EQ.'THET')THEN
14974        DTERM1=DLNGAM(DM*DX+1.0D0) + (DX-1.0D0)*DLOG(DTHETA) +
14975     1         (DM*DX-DX+1.0D0)*DLOG(1.0D0 - DTHETA)
14976        DTERM2=DLNGAM(DX) + DLNGAM(DM*DX-DX+2.0D0)
14977        DTERM3=DLOG(DX)
14978        DTERM4=DTERM1 - DTERM2 - DTERM3
14979        DPDF=DEXP(DTERM4)
14980      ELSE
14981        DTERM1=-DLOG(DX)
14982        DTERM2=DLNGAM(DM*DX+1.0D0)
14983        DTERM3=-DLNGAM(DX) - DLNGAM(DM*DX-DX+2.0D0)
14984        DTERM4=(DX-1.0D0)*(DLOG(DMU-1.0D0) - DLOG(DM) - DLOG(DMU))
14985        DTERM5=(DM*DX-DX+1.0D0)*DLOG(1.0D0 - (DMU-1.0D0)/(DM*DMU))
14986        DTERM6=DTERM1 + DTERM2 + DTERM3 + DTERM4 + DTERM5
14987        DPDF=DEXP(DTERM6)
14988      ENDIF
14989C
14990 9000 CONTINUE
14991      RETURN
14992      END
14993      SUBROUTINE CONPPF(DP,DSHAPE,DM,ICONDF,DPPF)
14994C
14995C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
14996C              FUNCTION VALUE FOR THE CONSUL DISTRIBUTION WITH SHAPE
14997C              PARAMETERS THETA AND M.  THIS DISTRIBUTION IS
14998C              DEFINED FOR ALL INTEGER X >= 1.
14999C
15000C              THIS DISTRIBUTION REDUCES TO THE GEOMETRIC
15001C              DISTRIBUTION WHEN M = 1.  FOR THIS REASON, IT
15002C              SOMETIMES REFERRED TO AS THE GENERALIZED GEOMETRIC
15003C              DISTRIBUTION.  NOTE THAT THIS DISTRIBUTION HAS A
15004C              SIMILAR FORM TO THE GEETA DISTRIBUTION.
15005C
15006C              THE PROBABILITY MASS FUNCTION IS:
15007C              p(X;THETA,M)=
15008C                  (M*X  X-1)*THETA**(X-1)*(1-THETA)**(M*X-X+1)/X
15009C                  X = 1, 2, 3, ,...
15010C                  0 < THETA < 1; 1 <= M < 1/THETA
15011C
15012C              A RECURRENCE RELATION FOR THE CDF FUNCTION IS
15013C
15014C                  P(X;THETA,M) = {(M-1)*(X-1)+1}/(X-1)}*
15015C                                 THETA*(1-TYHETA)**(M-1)*
15016C                                 PROD[i=1 to X-2][(1 + M/(M*X-M-i)]*
15017C                                 P(X-1;THETA,M)
15018C
15019C              THIS DISTRIBUTION IS SOMETIMES PARAMETERIZED USING
15020C              THE MEAN (MU) INSTEAD OF THETA.  THIS RESULTS IN
15021C              THE PROBABILITY MASS FUNCTION:
15022C              p(X;MU,M)=
15023C                  (M*X  X-1)*((MU-1)/(M*MU))**(X-1)*
15024C                  (1 - (M-1)/(M*MU))**(M*X-X+1)/X
15025C                  X = 1, 2, 3, ,...
15026C                  MU >= 1; M > 1
15027C              NOTE THAT THE RELATION IS:
15028C
15029C                  THETA=(MU-1)/(M*MU)
15030C
15031C              THE PERCENT POINT FUNCTION IS COMPUTED BY SUMMING
15032C              THE CUMULATIVE DISTRIBUTION UNTIL THE APPROPRIATE
15033C              PROBABILITY IS REACHED.
15034C
15035C     INPUT  ARGUMENTS--DP     = THE DOUBLE PRECISION VALUE AT
15036C                                WHICH THE PERCENT POINT
15037C                                FUNCTION IS TO BE EVALUATED.
15038C                     --DSHAPE = THE FIRST SHAPE PARAMETER
15039C                                (EITHER THETA OR MU)
15040C                     --DM     = THE SECOND SHAPE PARAMETER
15041C     OUTPUT ARGUMENTS--DPPF   = THE DOUBLE PRECISION PERCENT POINT
15042C                                FUNCTION VALUE.
15043C     OUTPUT--THE DOUBLE PRECISION PERCENT POINT FUNCTION
15044C             VALUE PPF FOR THE CONSUL DISTRIBUTION WITH SHAPE
15045C             PARAMETERS THETA (OR MU) AND M
15046C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
15047C     RESTRICTIONS--X SHOULD BE A POSITIVE INTEGER
15048C                 --0 < THETA < 1; 1 < M < 1/THETA
15049C                 --MU >= 1; M > 1
15050C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
15051C     LANGUAGE--ANSI FORTRAN (1977)
15052C     REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
15053C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTER 8.
15054C     WRITTEN BY--JAMES J. FILLIBEN
15055C                 STATISTICAL ENGINEERING DIVISION
15056C                 INFORMATION TECHNOLOGY LABORATORY
15057C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
15058C                 GAITHERSBURG, MD 20899-8980
15059C                 PHONE--301-975-2855
15060C     LANGUAGE--ANSI FORTRAN (1977)
15061C     VERSION NUMBER--2006/8
15062C     ORIGINAL VERSION--AUGUST    2006.
15063C
15064C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
15065C
15066C---------------------------------------------------------------------
15067C
15068      DOUBLE PRECISION DP
15069      DOUBLE PRECISION DPPF
15070      DOUBLE PRECISION DX
15071      DOUBLE PRECISION DSHAPE
15072      DOUBLE PRECISION DM
15073      DOUBLE PRECISION DCDF
15074      DOUBLE PRECISION DPDF
15075      DOUBLE PRECISION DPDFSV
15076C
15077      DOUBLE PRECISION DTERM1
15078      DOUBLE PRECISION DTERM2
15079      DOUBLE PRECISION DTERM3
15080      DOUBLE PRECISION DTHETA
15081      DOUBLE PRECISION DMU
15082      DOUBLE PRECISION DSUM
15083      DOUBLE PRECISION DEPS
15084C
15085      CHARACTER*4 ICONDF
15086      CHARACTER*4 ICOND2
15087C
15088C---------------------------------------------------------------------
15089C
15090      INCLUDE 'DPCOP2.INC'
15091C
15092C-----START POINT-----------------------------------------------------
15093C
15094C     CHECK THE INPUT ARGUMENTS FOR ERRORS
15095C
15096      IF(ICONDF.EQ.'THET')THEN
15097        DTHETA=DSHAPE
15098      ELSE
15099        DMU=DSHAPE
15100        DTHETA=(DMU-1.0D0)/(DM*DMU)
15101      ENDIF
15102C
15103      IF(DP.LT.0.0D0 .OR. DP.GE.1.0D0)THEN
15104        WRITE(ICOUT,4)
15105        CALL DPWRST('XXX','BUG ')
15106        WRITE(ICOUT,46)DP
15107        CALL DPWRST('XXX','BUG ')
15108        DPPF=0.0D0
15109        GOTO9000
15110      ENDIF
15111    4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO GETPPF IS OUTSIDE ',
15112     1'THE (0,1] INTERVAL')
15113C
15114      IF(ICONDF.EQ.'THET')THEN
15115        IF(DTHETA.LE.0.0D0 .OR. DTHETA.GE.1.0D0)THEN
15116          WRITE(ICOUT,15)
15117          CALL DPWRST('XXX','BUG ')
15118          WRITE(ICOUT,46)DTHETA
15119          CALL DPWRST('XXX','BUG ')
15120          DPPF=0.0
15121          GOTO9000
15122        ENDIF
15123   15   FORMAT('***** ERROR--THE SECOND ARGUMENT TO CONPPF IS NOT ',
15124     1         'IN THE INTERVAL (0,1)')
15125C
15126        IF(DM.LT.1.0D0 .OR. DM.GE.1.0D0/DTHETA)THEN
15127          WRITE(ICOUT,25)1.0D0/DTHETA
15128          CALL DPWRST('XXX','BUG ')
15129          WRITE(ICOUT,46)DM
15130          CALL DPWRST('XXX','BUG ')
15131          DPPF=0.0
15132          GOTO9000
15133        ENDIF
15134   25   FORMAT('***** ERROR--THE THIRD ARGUMENT TO CONPPF IS NOT ',
15135     1         'IN THE INTERVAL (1,',G15.7,')')
15136      ELSE
15137        IF(DMU.LT.1.0D0)THEN
15138          WRITE(ICOUT,35)
15139          CALL DPWRST('XXX','BUG ')
15140          WRITE(ICOUT,46)DMU
15141          CALL DPWRST('XXX','BUG ')
15142          DPPF=0.0
15143          GOTO9000
15144        ENDIF
15145   35   FORMAT('***** ERROR--THE SECOND ARGUMENT TO CONPPF IS ',
15146     1         'LESS THAN 1')
15147C
15148        IF(DM.LT.1.0D0)THEN
15149          WRITE(ICOUT,38)
15150          CALL DPWRST('XXX','BUG ')
15151          WRITE(ICOUT,46)DM
15152          CALL DPWRST('XXX','BUG ')
15153          DPPF=0.0
15154          GOTO9000
15155        ENDIF
15156   38   FORMAT('***** ERROR--THE THIRD ARGUMENT TO CONPPF IS ',
15157     1         'LESS THAN 1')
15158      ENDIF
15159C
15160   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
15161C
15162      DEPS=1.0D-7
15163      DCDF=(1.0D0 - DTHETA)**DM
15164      IF(DCDF.GE.DP-DEPS)THEN
15165        DPPF=1.0D0
15166        GOTO9000
15167      ELSE
15168        DX=2.0D0
15169        ICOND2='THET'
15170        CALL CONPDF(DX,DTHETA,DM,ICOND2,DPDF)
15171        DCDF=DCDF+DPDF
15172        IF(DCDF.GE.DP-DEPS)THEN
15173          DPPF=2.0D0
15174          GOTO9000
15175        ENDIF
15176        DX=3.0D0
15177        CALL CONPDF(DX,DTHETA,DM,ICOND2,DPDF)
15178        DCDF=DCDF+DPDF
15179        IF(DCDF.GE.DP-DEPS)THEN
15180          DPPF=3.0D0
15181          GOTO9000
15182        ENDIF
15183        DPDFSV=DPDF
15184      ENDIF
15185C
15186      I=3
15187  100 CONTINUE
15188        I=I+1
15189        DX=DBLE(I)
15190        DTERM1=DLOG(DTHETA) + (DM-1.0D0)*DLOG(1.0D0 - DTHETA)
15191        DTERM2=DLOG((DM-1.0D0)*(DX-1.0D0) + 1.0D0) - DLOG(DX-1.0D0)
15192        DTERM3=DTERM1 + DTERM2
15193        DSUM=0.0D0
15194        DO200J=1,I-2
15195          DSUM=DSUM + DLOG(1.0D0 + DM/(DM*DX - DM - DBLE(J)))
15196  200   CONTINUE
15197        IF(DPDFSV.GT.0.0D0)THEN
15198          DPDF=DEXP(DTERM3 + DSUM + DLOG(DPDFSV))
15199        ELSE
15200          DPPF=DBLE(I)
15201          GOTO9000
15202        ENDIF
15203        DCDF=DCDF + DPDF
15204        IF(DCDF.GE.DP-DEPS)THEN
15205          DPPF=DBLE(I)
15206          GOTO9000
15207        ENDIF
15208        DPDFSV=DPDF
15209      GOTO100
15210C
15211 9000 CONTINUE
15212      RETURN
15213      END
15214      SUBROUTINE CONRAN(N,SHAPE,AM,ICONDF,ISEED,X)
15215C
15216C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
15217C              FROM THE CONSUL DISTRIBUTION WITH SHAPE PARAMETERS
15218C              THETA OR MU AND AM.
15219C
15220C              THE PROBABILITY MASS FUNCTION IS:
15221C              p(X;THETA,M)=
15222C                  (M*X  X-1)*THETA**(X-1)*(1-THETA)**(M*X-X+1)/X
15223C                  X = 1, 2, 3, ,...
15224C                  0 < THETA < 1; 1 <= M < 1/THETA
15225C
15226C              THE MEAN AND VARIANCE ARE:
15227C
15228C                  MEAN     = 1/(1-THETA*M)
15229C                  VARIANCE = M*THETA*(1-THETA)/
15230C                             (1-THETA*M)**3
15231C
15232C              THIS DISTRIBUTION IS SOMETIMES PARAMETERIZED USING
15233C              THE MEAN (MU) INSTEAD OF THETA.  THIS RESULTS IN
15234C              THE PROBABILITY MASS FUNCTION:
15235C              p(X;MU,M)=
15236C                  (M*X  X-1)*((MU-1)/(M*MU))**(X-1)*
15237C                  (1 - (M-1)/(M*MU))**(M*X-X+1)/X
15238C                  X = 1, 2, 3, ,...
15239C                  MU >= 1; M > 1
15240C              NOTE THAT THE RELATION IS:
15241C
15242C                  THETA=(MU-1)/(M*MU)
15243C
15244C
15245C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
15246C                                OF RANDOM NUMBERS TO BE
15247C                                GENERATED.
15248C                     --SHAPE  = THE SINGLE PRECISION VALUE
15249C                                OF THE FIRST SHAPE PARAMETER.
15250C                     --AM     = THE SINGLE PRECISION VALUE
15251C                                OF THE SECOND SHAPE PARAMETER.
15252C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
15253C                                (OF DIMENSION AT LEAST N)
15254C                                INTO WHICH THE CONSUL
15255C                                RANDOM SAMPLE WILL BE PLACED.
15256C     OUTPUT--A RANDOM SAMPLE OF SIZE N
15257C             FROM THE CONSUL DISTRIBUTION
15258C             WITH SHAPE PARAMETERS THETA (OR MU) AND AM.
15259C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
15260C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
15261C                   OF N FOR THIS SUBROUTINE.
15262C                 --0 < THETA < 1, 1 < M < 1/THETA
15263C                   MU >= 1; M > 1
15264C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, CONPPF
15265C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
15266C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
15267C     LANGUAGE--ANSI FORTRAN (1977)
15268C     REFERENCES--CONSUL (1990), "CONSUL DISTRIBUTION AND ITS
15269C                 PROPERTIES", COMMUNICATIONS IN STATISTICS--
15270C                 THEORY AND METHODS, 19, PP. 3051-3068.
15271C               --CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
15272C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTER 8.
15273C     WRITTEN BY--JAMES J. FILLIBEN
15274C                 STATISTICAL ENGINEERING DIVISION
15275C                 INFORMATION TECHNOLOGY LABORATORY
15276C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
15277C                 GAITHERSBURG, MD 20899-8980
15278C                 PHONE--301-975-2899
15279C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
15280C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
15281C     LANGUAGE--ANSI FORTRAN (1977)
15282C     VERSION NUMBER--2006/7
15283C     ORIGINAL VERSION--JULY      2006.
15284C
15285C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
15286C
15287C---------------------------------------------------------------------
15288C
15289      DIMENSION X(*)
15290C
15291      CHARACTER*4 ICONDF
15292C
15293      DOUBLE PRECISION DPPF
15294C
15295C---------------------------------------------------------------------
15296C
15297      INCLUDE 'DPCOP2.INC'
15298C
15299C-----START POINT-----------------------------------------------------
15300C
15301C     CHECK THE INPUT ARGUMENTS FOR ERRORS
15302C
15303      IF(N.LT.1)THEN
15304        WRITE(ICOUT,5)
15305        CALL DPWRST('XXX','BUG ')
15306        WRITE(ICOUT,47)N
15307        CALL DPWRST('XXX','BUG ')
15308        GOTO9000
15309      ENDIF
15310    5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF CONSUL RANDOM ',
15311     1       'NUMBERS IS NON-POSITIVE')
15312C
15313      IF(ICONDF.EQ.'THET')THEN
15314        THETA=SHAPE
15315        IF(THETA.LE.0.0 .OR. THETA.GE.1.0)THEN
15316          WRITE(ICOUT,15)
15317          CALL DPWRST('XXX','BUG ')
15318          WRITE(ICOUT,16)
15319          CALL DPWRST('XXX','BUG ')
15320          WRITE(ICOUT,46)THETA
15321          CALL DPWRST('XXX','BUG ')
15322          GOTO9000
15323        ENDIF
15324   15   FORMAT('***** ERROR--THE THETA PARAMETER FOR THE CONSUL')
15325   16   FORMAT('      RANDOM NUMBERS IS OUTSIDE THE (0,1) INTERVAL')
15326C
15327        IF(AM.LT.1.0 .OR. AM.GE.1.0/THETA)THEN
15328          WRITE(ICOUT,25)
15329          CALL DPWRST('XXX','BUG ')
15330          WRITE(ICOUT,26)1.0/THETA
15331          CALL DPWRST('XXX','BUG ')
15332          WRITE(ICOUT,46)AM
15333          CALL DPWRST('XXX','BUG ')
15334          GOTO9000
15335        ENDIF
15336   25   FORMAT('***** ERROR--THE M PARAMETER FOR THE CONSUL')
15337   26   FORMAT('      RANDOM NUMBERS IS OUTSIDE THE (1,',G15.7,') ',
15338     1         'INTERVAL')
15339      ELSE
15340        AMU=SHAPE
15341        IF(AMU.LT.1.0)THEN
15342          WRITE(ICOUT,35)
15343          CALL DPWRST('XXX','BUG ')
15344          WRITE(ICOUT,36)
15345          CALL DPWRST('XXX','BUG ')
15346          WRITE(ICOUT,46)AMU
15347          CALL DPWRST('XXX','BUG ')
15348          GOTO9000
15349        ENDIF
15350   35   FORMAT('***** ERROR--THE MU PARAMETER FOR THE CONSUL')
15351   36   FORMAT('      RANDOM NUMBERS IS LESS THAN 1')
15352C
15353        IF(AM.LE.1.0)THEN
15354          WRITE(ICOUT,38)
15355          CALL DPWRST('XXX','BUG ')
15356          WRITE(ICOUT,39)
15357          CALL DPWRST('XXX','BUG ')
15358          WRITE(ICOUT,46)AM
15359          CALL DPWRST('XXX','BUG ')
15360          GOTO9000
15361        ENDIF
15362   38   FORMAT('***** ERROR--THE M PARAMETER FOR THE CONSUL')
15363   39   FORMAT('      RANDOM NUMBERS IS LESS THAN OR EQUAL TO 1')
15364      ENDIF
15365C
15366   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
15367   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
15368C
15369C     GENERATE N CONSUL DISTRIBUTION RANDOM NUMBERS USING THE
15370C     INVERSION METHOD.
15371C
15372      CALL UNIRAN(N,ISEED,X)
15373      DO100I=1,N
15374        XTEMP=X(I)
15375        CALL CONPPF(DBLE(XTEMP),DBLE(SHAPE),DBLE(AM),ICONDF,DPPF)
15376        X(I)=REAL(DPPF)
15377  100 CONTINUE
15378C
15379 9000 CONTINUE
15380C
15381      RETURN
15382      END
15383      SUBROUTINE CONV14(ISTRIN,NSTRIN,IA,IB,IWIDTH,IBUGXX,IERROR)
15384C
15385C     PURPOSE--CONVERT THE FIRST NSTRIN CHARACTERS IF ISTRIN
15386C              TO THE FIRST CHARACTERS OF THE CHARACTER*4 ARRAYS
15387C              IA AND IB.
15388C
15389C     WRITTEN BY--JAMES J. FILLIBEN
15390C                 STATISTICAL ENGINEERING DIVISION
15391C                 INFORMATION TECHNOLOGY LABORATORY
15392C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
15393C                 GAITHERSBURG, MD 20899
15394C                 PHONE--301-975-2855
15395C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
15396C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
15397C     LANGUAGE--ANSI FORTRAN (1977)
15398C     VERSION NUMBER--93.3
15399C     ORIGINAL VERSION--FEBRUARY 1993
15400C
15401C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
15402C
15403CCCCC CHARACTER*80 ISTRIN
15404      CHARACTER (LEN=*) :: ISTRIN
15405      CHARACTER (LEN=4) :: IA(*)
15406      CHARACTER (LEN=4) :: IB(*)
15407      CHARACTER*4 IBUGXX
15408      CHARACTER*4 IERROR
15409C
15410      CHARACTER*4 IC4
15411C
15412C---------------------------------------------------------------------
15413C
15414      INCLUDE 'DPCOP2.INC'
15415C
15416C-----START POINT-----------------------------------------------------
15417C
15418      IERROR='NO'
15419C
15420      IF(IBUGXX.EQ.'ON')THEN
15421        WRITE(ICOUT,999)
15422  999   FORMAT(1X)
15423        CALL DPWRST('XXX','BUG ')
15424        WRITE(ICOUT,51)
15425   51   FORMAT('***** AT THE BEGINNING OF CONV14--')
15426        CALL DPWRST('XXX','BUG ')
15427        WRITE(ICOUT,52)IBUGXX,IERROR,NSTRIN
15428   52   FORMAT('IBUGXX,IERROR,NSTRIN = ',2(A4,2X),I8)
15429        CALL DPWRST('XXX','BUG ')
15430        WRITE(ICOUT,53)ISTRIN(1:80)
15431   53   FORMAT('ISTRIN(1:80) = ',A80)
15432        CALL DPWRST('XXX','BUG ')
15433      ENDIF
15434C
15435      IWIDTH=NSTRIN
15436      IF(1.LE.NSTRIN.AND.NSTRIN.LE.80)THEN
15437         DO1000I=1,NSTRIN
15438           IC4='    '
15439           IC4(1:1)=ISTRIN(I:I)
15440           IA(I)=IC4
15441           IB(I)=IC4
15442 1000    CONTINUE
15443         IERROR='NO'
15444      ELSE
15445         IERROR='YES'
15446      ENDIF
15447C
15448      IF(IBUGXX.EQ.'ON')THEN
15449        WRITE(ICOUT,999)
15450        CALL DPWRST('XXX','BUG ')
15451        WRITE(ICOUT,9011)
15452 9011   FORMAT('***** AT THE END       OF CONV14--')
15453        CALL DPWRST('XXX','BUG ')
15454        WRITE(ICOUT,9014)IERROR,NSTRIN,IWIDTH
15455 9014   FORMAT('IERROR,NSTRIN,IWIDTH = ',A4,2X,2I8)
15456        CALL DPWRST('XXX','BUG ')
15457        IF(IWIDTH.GE.1)THEN
15458          DO9020I=1,IWIDTH
15459            WRITE(ICOUT,9021)I,IA(I),IB(I)
15460 9021       FORMAT('I,IA(I),IB(I) = ',I8,2X,A4,2X,A4)
15461            CALL DPWRST('XXX','BUG ')
15462 9020     CONTINUE
15463        ENDIF
15464      ENDIF
15465C
15466      RETURN
15467      END
15468      SUBROUTINE CONVOL(Y1,N1,Y2,N2,NUMVAR,IWRITE,MAXN,
15469     1                  Y3,N3,IBUGA3,IERROR)
15470C
15471C     PURPOSE--COMPUTE CONVOLUTION OF 2 VARIABLES.
15472C     NOTE--IF  THE FIRST  VARIABLE IS Y1(.)
15473C           AND THE SECOND VARIABLE IS Y2(.),
15474C           THEN THE OUTPUT VARIABLE CONTAINING THE
15475C           CONVOLUTION
15476C           WILL BE COMPUTED AS FOLLOWS--
15477C              Y3(1) = Y1(1)*Y2(1)
15478C              Y3(2) = Y1(1)*Y2(2) + Y1(2)*Y2(1)
15479C              Y3(3) = Y1(1)*Y2(3) + Y1(2)*Y2(2) + Y1(3)*Y2(1)
15480C              ETC.
15481C     NOTE--IT IS NOT PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y3(.)
15482C           BEING IDENTICAL (OVERLAYED) ON THE INPUT VECTORS Y1(.) OR Y2(.)
15483C     NOTE--Y1 AND Y2 NEED NOT BE THE SAME LENGTH.
15484C     WRITTEN BY--JAMES J. FILLIBEN
15485C                 STATISTICAL ENGINEERING DIVISION
15486C                 INFORMATION TECHNOLOGY LABORATORY
15487C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
15488C                 GAITHERSBURG, MD 20899
15489C                 PHONE--301-975-2855
15490C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
15491C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
15492C     LANGUAGE--ANSI FORTRAN (1977)
15493C     VERSION NUMBER--82/7
15494C     ORIGINAL VERSION--NOVEMBER  1981.
15495C     UPDATED         --MAY       1982.
15496C
15497C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
15498C
15499      CHARACTER*4 IWRITE
15500      CHARACTER*4 IBUGA3
15501      CHARACTER*4 IERROR
15502C
15503      CHARACTER*4 ISUBN1
15504      CHARACTER*4 ISUBN2
15505      CHARACTER*4 ISTEPN
15506C
15507C---------------------------------------------------------------------
15508C
15509      DIMENSION Y1(*)
15510      DIMENSION Y2(*)
15511      DIMENSION Y3(*)
15512C
15513C---------------------------------------------------------------------
15514C
15515      INCLUDE 'DPCOP2.INC'
15516C
15517C-----START POINT-----------------------------------------------------
15518C
15519      ISUBN1='CONV'
15520      ISUBN2='OL  '
15521      IERROR='NO'
15522C
15523      IF(IBUGA3.EQ.'ON')THEN
15524        WRITE(ICOUT,999)
15525  999   FORMAT(1X)
15526        CALL DPWRST('XXX','BUG ')
15527        WRITE(ICOUT,51)
15528   51   FORMAT('***** AT THE BEGINNING OF CONVOL--')
15529        CALL DPWRST('XXX','BUG ')
15530        WRITE(ICOUT,53)IBUGA3,IWRITE,N1,N2,NUMVAR,MAXN
15531   53   FORMAT('IBUGA3,IWRITE,N1,N2,NUMVAR,MAXN = ',2(A4,2X),4I8)
15532        CALL DPWRST('XXX','BUG ')
15533        DO55I=1,N1
15534          WRITE(ICOUT,56)I,Y1(I)
15535   56     FORMAT('I,Y1(I) = ',I8,G15.7)
15536          CALL DPWRST('XXX','BUG ')
15537   55   CONTINUE
15538        DO57I=1,N2
15539          WRITE(ICOUT,58)I,Y2(I)
15540   58     FORMAT('I,Y2(I) = ',I8,G15.7)
15541          CALL DPWRST('XXX','BUG ')
15542   57   CONTINUE
15543      ENDIF
15544C
15545C               *******************************
15546C               **  COMPUTE THE CONVOLUTION  **
15547C               *******************************
15548C
15549      ISTEPN='1'
15550      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15551C
15552      IF(N1.LE.0)GOTO150
15553      IF(N2.LE.0)GOTO150
15554      I3MIN=2
15555      I3MAX=N1+N2
15556      N3=I3MAX-I3MIN+1
15557      IF(N3.GT.MAXN)GOTO170
15558C
15559      DO100I3=1,N3
15560      Y3(I3)=0.0
15561  100 CONTINUE
15562C
15563      DO500I1=1,N1
15564      DO600I2=1,N2
15565      Y1P=Y1(I1)
15566      Y2P=Y2(I2)
15567      Y3P=Y1P*Y2P
15568      IARG=I1+I2-1
15569      Y3(IARG)=Y3(IARG)+Y3P
15570  600 CONTINUE
15571  500 CONTINUE
15572      GOTO190
15573C
15574  150 CONTINUE
15575      IERROR='YES'
15576      WRITE(ICOUT,999)
15577      CALL DPWRST('XXX','BUG ')
15578      WRITE(ICOUT,151)
15579  151 FORMAT('***** ERROR IN CONVOL--')
15580      CALL DPWRST('XXX','BUG ')
15581      WRITE(ICOUT,152)
15582  152 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
15583      CALL DPWRST('XXX','BUG ')
15584      WRITE(ICOUT,153)
15585  153 FORMAT('      IN THE VARIABLES FOR WHICH')
15586      CALL DPWRST('XXX','BUG ')
15587      WRITE(ICOUT,154)
15588  154 FORMAT('      THE CONVOLUTION IS TO BE COMPUTED')
15589      CALL DPWRST('XXX','BUG ')
15590      WRITE(ICOUT,155)
15591  155 FORMAT('      MUST BE 1 OR LARGER.')
15592      CALL DPWRST('XXX','BUG ')
15593      WRITE(ICOUT,156)
15594  156 FORMAT('      SUCH WAS NOT THE CASE HERE.')
15595      CALL DPWRST('XXX','BUG ')
15596      WRITE(ICOUT,157)N1,N2
15597  157 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',2I8,
15598     1'.')
15599      CALL DPWRST('XXX','BUG ')
15600      GOTO190
15601C
15602  170 CONTINUE
15603      IERROR='YES'
15604      WRITE(ICOUT,999)
15605      CALL DPWRST('XXX','BUG ')
15606      WRITE(ICOUT,171)
15607  171 FORMAT('***** ERROR IN CONVOL--')
15608      CALL DPWRST('XXX','BUG ')
15609      WRITE(ICOUT,172)
15610  172 FORMAT('      THE NUMBER OF OBSERVATIONS')
15611      CALL DPWRST('XXX','BUG ')
15612      WRITE(ICOUT,173)
15613  173 FORMAT('      IN THE RESULTING CONVOLUTION VARIABLE ')
15614      CALL DPWRST('XXX','BUG ')
15615      WRITE(ICOUT,175)MAXN
15616  175 FORMAT('      MUST BE LESS THAN OR EQUAL TO ',I8,' .')
15617      CALL DPWRST('XXX','BUG ')
15618      WRITE(ICOUT,176)
15619  176 FORMAT('      SUCH WAS NOT THE CASE HERE.')
15620      CALL DPWRST('XXX','BUG ')
15621      WRITE(ICOUT,177)N3
15622  177 FORMAT('      THE OUTPUT NUMBER OF OBSERVATIONS HERE = ',I8,
15623     1'.')
15624      CALL DPWRST('XXX','BUG ')
15625      GOTO190
15626C
15627  190 CONTINUE
15628C
15629C               *****************
15630C               **  STEP 90--  **
15631C               **  EXIT.      **
15632C               *****************
15633C
15634      IF(IBUGA3.EQ.'ON')THEN
15635        WRITE(ICOUT,999)
15636        CALL DPWRST('XXX','BUG ')
15637        WRITE(ICOUT,9011)
15638 9011   FORMAT('***** AT THE END       OF CONVOL--')
15639        CALL DPWRST('XXX','BUG ')
15640        WRITE(ICOUT,9013)IERROR,N1,N2,NUMVAR,MAXN,N3
15641 9013   FORMAT('IERROR,N1,N2,NUMVAR,MAXN,N3 = ',A4,2X,5I8)
15642        CALL DPWRST('XXX','BUG ')
15643        DO9015I=1,N3
15644          WRITE(ICOUT,9016)I,Y1(I),Y2(I),Y3(I)
15645 9016     FORMAT('I,Y1(I),Y2(I),Y3(I) = ',I8,3G15.7)
15646          CALL DPWRST('XXX','BUG ')
15647 9015   CONTINUE
15648      ENDIF
15649C
15650      RETURN
15651      END
15652      SUBROUTINE CORMAT(X,Y,N,IWRITE,XIDTEM,STAT,IBUGA3,IERROR)
15653C
15654C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROPORTION OF
15655C              CORRECT MATCHES BETWEEN TWO VARIABLES.  THE
15656C              NUMBER OF CORRECT MATCHES IS THE SUM OF THE
15657C              TRUE POSITIVES AND TRUE NEGATIVES.
15658C
15659C              THIS IS SPECIFICALLY FOR THE 2X2 CASE.  THAT IS,
15660C              EACH VARIABLE HAS TWO MUTUALLY EXCLUSIVE
15661C              CHOICES CODED AS 1 (FOR SUCCESS) OR 0 (FOR
15662C              FAILURE).  A TRUE POSITIVE IS DEFINED AS THE
15663C              CASE WHERE THE SECOND VARIABLE IS 1 AND THE FIRST
15664C              VARIABLE IS A 1.
15665C
15666C              A TYPICAL EXAMPLE WOULD BE WHERE VARIABLE ONE
15667C              DENOTES THE GROUND TRUTH AND A VALUE OF 1
15668C              INDICATES "PRESENT" AND A VALUE OF 0 INDICATES
15669C              "NOT PRESENT".  VARIABLE TWO REPRESENTS SOME TYPE
15670C              OF DETECTION DEVICE WHERE A VALUE OF 1 INDICATES
15671C              THE DEVICE DETECTED THE SPECIFIED OBJECT WHILE A
15672C              VALUE OF 0 INDICATES THAT THE OBJECT WAS NOT
15673C              DETECTED.  A TRUE POSITIVE THEN IS THE CASE WHERE
15674C              THE DEVICE DETECTED THE OBJECT WHEN IT WAS
15675C              ACTUALY THERE.
15676C
15677C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
15678C                                (UNSORTED) OBSERVATIONS
15679C                                WHICH CONSTITUTE THE FIRST SET
15680C                                OF DATA.
15681C                     --Y      = THE SINGLE PRECISION VECTOR OF
15682C                                (UNSORTED) OBSERVATIONS
15683C                                WHICH CONSTITUTE THE SECOND SET
15684C                                OF DATA.
15685C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
15686C                                IN THE VECTOR X, OR EQUIVALENTLY,
15687C                                THE INTEGER NUMBER OF OBSERVATIONS
15688C                                IN THE VECTOR Y.
15689C     OUTPUT ARGUMENTS--STAT   = THE SINGLE PRECISION VALUE OF THE
15690C                                COMPUTED TRUE POSITIVE PROPORTION
15691C                                BETWEEN THE 2 SETS OF DATA
15692C                                IN THE INPUT VECTORS X AND Y.
15693C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
15694C             SAMPLE TRUE POSITIVE PROPORTION BETWEEN THE 2 SETS
15695C             OF DATA IN THE INPUT VECTORS X AND Y.
15696C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
15697C                   OF N FOR THIS SUBROUTINE.
15698C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
15699C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
15700C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
15701C     LANGUAGE--ANSI FORTRAN (1977)
15702C     WRITTEN BY--JAMES J. FILLIBEN
15703C                 STATISTICAL ENGINEERING DIVISION
15704C                 INFORMATION TECHNOLOGY LABORATORY
15705C                 NATIONAL INSTIUTE OF STANDARDS AND TECHNOLOGY
15706C                 GAITHERSBURG, MD 20899-8980
15707C                 PHONE--301-975-2899
15708C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
15709C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
15710C     LANGUAGE--ANSI FORTRAN (1977)
15711C     VERSION NUMBER--2007/5
15712C     ORIGINAL VERSION--MAY       2007.
15713C     UPDATED         --AUGUST    2007. IF 2X2 CASE, CHECK IF SUM
15714C                                       OF ENTRIES IS <= 4.  IN THIS
15715C                                       CASE, ASSUME WE HAVE RAW DATA
15716C
15717C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
15718C
15719      CHARACTER*4 IWRITE
15720      CHARACTER*4 IBUGA3
15721      CHARACTER*4 IERROR
15722C
15723      CHARACTER*4 ISTEPN
15724      CHARACTER*4 ISUBN1
15725      CHARACTER*4 ISUBN2
15726C
15727C---------------------------------------------------------------------
15728C
15729      DIMENSION X(*)
15730      DIMENSION Y(*)
15731      DIMENSION XIDTEM(*)
15732C
15733C---------------------------------------------------------------------
15734C
15735      INCLUDE 'DPCOP2.INC'
15736C
15737C-----START POINT-----------------------------------------------------
15738C
15739      ISUBN1='TRUP'
15740      ISUBN2='OS  '
15741C
15742      IERROR='NO'
15743C
15744C
15745      IF(IBUGA3.EQ.'ON')THEN
15746        WRITE(ICOUT,999)
15747  999   FORMAT(1X)
15748        CALL DPWRST('XXX','BUG ')
15749        WRITE(ICOUT,51)
15750   51   FORMAT('***** AT THE BEGINNING OF CORMAT--')
15751        CALL DPWRST('XXX','BUG ')
15752        WRITE(ICOUT,52)IBUGA3
15753   52   FORMAT('IBUGA3 = ',A4)
15754        CALL DPWRST('XXX','BUG ')
15755        WRITE(ICOUT,53)N
15756   53   FORMAT('N = ',I8)
15757        CALL DPWRST('XXX','BUG ')
15758        DO55I=1,N
15759          WRITE(ICOUT,56)I,X(I),Y(I)
15760   56     FORMAT('I,X(I),Y(I) = ',I8,2G15.7)
15761          CALL DPWRST('XXX','BUG ')
15762   55   CONTINUE
15763      ENDIF
15764C
15765C               ********************************************
15766C               **  STEP 21--                             **
15767C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
15768C               ********************************************
15769C
15770      ISTEPN='21'
15771      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15772C
15773      IF(N.LT.2)THEN
15774        WRITE(ICOUT,999)
15775        CALL DPWRST('XXX','WRIT')
15776        WRITE(ICOUT,1201)
15777 1201   FORMAT('***** ERROR IN THE CORRECT MATCH PROPORTION')
15778        CALL DPWRST('XXX','WRIT')
15779        WRITE(ICOUT,1203)
15780 1203   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ',
15781     1         'VARIABLES IS LESS THAN TWO')
15782        CALL DPWRST('XXX','WRIT')
15783        WRITE(ICOUT,1205)N
15784 1205   FORMAT('SAMPLE SIZE = ',I8)
15785        CALL DPWRST('XXX','WRIT')
15786        IERROR='YES'
15787        GOTO9000
15788      ENDIF
15789C
15790C               ********************************************
15791C               **  STEP 22--                             **
15792C               **  CHECK THAT THE VARIABLES HAVE AT MOST **
15793C               **  TWO DISTINCT VALUES (1 INDICATES A    **
15794C               **  SUCCESS, 0 INDICATES A FAILURE).      **
15795C               ********************************************
15796C
15797      ISTEPN='22'
15798      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15799C
15800C     NOTE: CHECK FOR SPECIAL CASE N = 2.  IN THIS CASE,
15801C           ASSUME WE HAVE A 2X2 TABLE OF COUNTS INSTEAD
15802C           OF RAW DATA.
15803C
15804      IF(N.EQ.2)THEN
15805        N11=INT(X(1)+0.5)
15806        N21=INT(X(2)+0.5)
15807        N12=INT(Y(1)+0.5)
15808        N22=INT(Y(2)+0.5)
15809C
15810C       CHECK IF ALL ENTRIES 0 OR 1. IF SO, ASSUME
15811C       RAW DATA CASE.
15812C
15813        IF((N11.EQ.0 .OR. N11.EQ.1) .AND.
15814     1     (N12.EQ.0 .OR. N12.EQ.1) .AND.
15815     1     (N21.EQ.0 .OR. N21.EQ.1) .AND.
15816     1     (N22.EQ.0 .OR. N22.EQ.1)) GOTO1349
15817C
15818        IF(N11.LT.0)THEN
15819          WRITE(ICOUT,999)
15820          CALL DPWRST('XXX','BUG ')
15821          WRITE(ICOUT,1201)
15822          CALL DPWRST('XXX','BUG ')
15823          WRITE(ICOUT,1311)
15824 1311     FORMAT('      ROW 1 COLUMN 1 OF THE COUNTS TABLE IS ',
15825     1           'NEGATIVE.')
15826          CALL DPWRST('XXX','BUG ')
15827        ELSEIF(N21.LT.0)THEN
15828          WRITE(ICOUT,999)
15829          CALL DPWRST('XXX','BUG ')
15830          WRITE(ICOUT,1201)
15831          CALL DPWRST('XXX','BUG ')
15832          WRITE(ICOUT,1321)
15833 1321     FORMAT('      ROW 2 COLUMN 1 OF THE COUNTS TABLE IS ',
15834     1           'NEGATIVE.')
15835          CALL DPWRST('XXX','BUG ')
15836        ELSEIF(N12.LT.0)THEN
15837          WRITE(ICOUT,999)
15838          CALL DPWRST('XXX','BUG ')
15839          WRITE(ICOUT,1201)
15840          CALL DPWRST('XXX','BUG ')
15841          WRITE(ICOUT,1331)
15842 1331     FORMAT('      ROW 1 COLUMN 2 OF THE COUNTS TABLE IS ',
15843     1           'NEGATIVE.')
15844          CALL DPWRST('XXX','BUG ')
15845        ELSEIF(N22.LT.0)THEN
15846          WRITE(ICOUT,999)
15847          CALL DPWRST('XXX','BUG ')
15848          WRITE(ICOUT,1201)
15849          CALL DPWRST('XXX','BUG ')
15850          WRITE(ICOUT,1341)
15851 1341     FORMAT('      ROW 2 COLUMN 2 OF THE COUNTS TABLE IS ',
15852     1           'NEGATIVE.')
15853          CALL DPWRST('XXX','BUG ')
15854        ENDIF
15855C
15856        NTEMP=N11 + N12 + N21 + N22
15857        STAT=REAL(N11 + N22)/REAL(NTEMP)
15858        GOTO3000
15859      ENDIF
15860C
15861 1349 CONTINUE
15862C
15863      CALL DISTIN(X,N,IWRITE,XIDTEM,NDIST,IBUGA3,IERROR)
15864      IF(NDIST.EQ.1)THEN
15865        AVAL=XIDTEM(1)
15866        IF(ABS(AVAL).LE.0.5)THEN
15867          AVAL=0.0
15868        ELSE
15869          AVAL=1.0
15870        ENDIF
15871        DO2202I=1,N
15872          X(I)=1.0
15873 2202   CONTINUE
15874      ELSEIF(NDIST.EQ.2)THEN
15875        IF(XIDTEM(1).EQ.1.0 .OR. XIDTEM(2).EQ.1.0)THEN
15876          DO2203I=1,N
15877            IF(X(I).NE.1.0)X(I)=0.0
15878 2203     CONTINUE
15879        ELSE
15880          ATEMP1=MIN(XIDTEM(1),XIDTEM(2))
15881          ATEMP2=MAX(XIDTEM(1),XIDTEM(2))
15882          DO2208I=1,N
15883            IF(X(I).EQ.ATEMP1)X(I)=0.0
15884            IF(X(I).EQ.ATEMP2)X(I)=1.0
15885 2208     CONTINUE
15886        ENDIF
15887      ELSEIF(NDIST.GT.2)THEN
15888        N11=0
15889        N12=0
15890        N21=0
15891        DO2510I=1,N
15892          IF(Y(I).EQ.X(I))THEN
15893            N11=N11+1
15894          ELSEIF(Y(I).LT.X(I))THEN
15895            N12=N12+1
15896          ELSEIF(Y(I).GT.X(I))THEN
15897            N21=N21+1
15898          ENDIF
15899 2510   CONTINUE
15900        STAT=REAL(N11)/REAL(N)
15901        GOTO9000
15902      ELSE
15903CCCCC   WRITE(ICOUT,999)
15904CCCCC   CALL DPWRST('XXX','BUG ')
15905CCCCC   WRITE(ICOUT,1201)
15906CCCCC   CALL DPWRST('XXX','BUG ')
15907CCCCC   WRITE(ICOUT,2211)
15908C2211   FORMAT('      RESPONSE VARIABLE ONE SHOULD CONTAIN AT MOST')
15909CCCCC   CALL DPWRST('XXX','BUG ')
15910CCCCC   WRITE(ICOUT,2213)
15911C2213   FORMAT('      TWO DISTINCT VALUES.')
15912CCCCC   CALL DPWRST('XXX','BUG ')
15913CCCCC   WRITE(ICOUT,2215)NDIST
15914C2215   FORMAT('      ',I8,' DISTINCT VALUES FOUND.')
15915CCCCC   CALL DPWRST('XXX','BUG ')
15916CCCCC   IERROR='YES'
15917CCCCC   GOTO9000
15918      ENDIF
15919C
15920      CALL DISTIN(Y,N,IWRITE,XIDTEM,NDIST,IBUGA3,IERROR)
15921      IF(NDIST.EQ.1)THEN
15922        AVAL=XIDTEM(1)
15923        IF(ABS(AVAL).LE.0.5)THEN
15924          AVAL=0.0
15925        ELSE
15926          AVAL=1.0
15927        ENDIF
15928        DO2302I=1,N
15929          Y(I)=1.0
15930 2302   CONTINUE
15931      ELSEIF(NDIST.EQ.2)THEN
15932        IF(XIDTEM(1).EQ.1.0 .OR. XIDTEM(2).EQ.1.0)THEN
15933          DO2303I=1,N
15934            IF(Y(I).NE.1.0)Y(I)=0.0
15935 2303     CONTINUE
15936        ELSE
15937          ATEMP1=MIN(XIDTEM(1),XIDTEM(2))
15938          ATEMP2=MAX(XIDTEM(1),XIDTEM(2))
15939          DO2308I=1,N
15940            IF(Y(I).EQ.ATEMP1)Y(I)=0.0
15941            IF(Y(I).EQ.ATEMP2)Y(I)=1.0
15942 2308     CONTINUE
15943        ENDIF
15944      ELSEIF(NDIST.GT.2)THEN
15945        N11=0
15946        N12=0
15947        N21=0
15948        DO2520I=1,N
15949          IF(Y(I).EQ.X(I))THEN
15950            N11=N11+1
15951          ELSEIF(Y(I).LT.X(I))THEN
15952            N12=N12+1
15953          ELSEIF(Y(I).GT.X(I))THEN
15954            N21=N21+1
15955          ENDIF
15956 2520   CONTINUE
15957        STAT=REAL(N11)/REAL(N)
15958        GOTO9000
15959      ELSE
15960CCCCC   WRITE(ICOUT,999)
15961CCCCC   CALL DPWRST('XXX','BUG ')
15962CCCCC   WRITE(ICOUT,1201)
15963CCCCC   CALL DPWRST('XXX','BUG ')
15964CCCCC   WRITE(ICOUT,2311)
15965C2311   FORMAT('      RESPONSE VARIABLE TWO SHOULD CONTAIN AT MOST')
15966CCCCC   CALL DPWRST('XXX','BUG ')
15967CCCCC   WRITE(ICOUT,2313)
15968C2313   FORMAT('      TWO DISTINCT VALUES.')
15969CCCCC   CALL DPWRST('XXX','BUG ')
15970CCCCC   WRITE(ICOUT,2315)NDIST
15971C2315   FORMAT('      ',I8,' DISTINCT VALUES FOUND.')
15972CCCCC   CALL DPWRST('XXX','BUG ')
15973CCCCC   IERROR='YES'
15974CCCCC   GOTO9000
15975      ENDIF
15976C
15977      N11=0
15978      N12=0
15979      N21=0
15980      N22=0
15981      DO2410I=1,N
15982        IF(X(I).EQ.1.0 .AND. Y(I).EQ.1.0)THEN
15983          N11=N11+1
15984        ELSEIF(X(I).EQ.0.0 .AND. Y(I).EQ.0.0)THEN
15985          N22=N22+1
15986        ELSEIF(X(I).EQ.1.0 .AND. Y(I).EQ.0.0)THEN
15987          N12=N12+1
15988        ELSEIF(X(I).EQ.0.0 .AND. Y(I).EQ.1.0)THEN
15989          N21=N21+1
15990        ENDIF
15991 2410 CONTINUE
15992C
15993      STAT=REAL(N11 + N22)/REAL(N)
15994C
15995 3000 CONTINUE
15996C
15997C
15998C               *******************************
15999C               **  STEP 3--                 **
16000C               **  WRITE OUT A LINE         **
16001C               **  OF SUMMARY INFORMATION.  **
16002C               *******************************
16003C
16004      IF(IFEEDB.EQ.'OFF')GOTO890
16005      IF(IWRITE.EQ.'OFF' .OR. IWRITE.EQ.'NO')GOTO890
16006      WRITE(ICOUT,999)
16007      CALL DPWRST('XXX','BUG ')
16008      WRITE(ICOUT,811)STAT
16009  811 FORMAT('THE CORRECT MATCH PROPORTION = ',G15.7)
16010      CALL DPWRST('XXX','BUG ')
16011  890 CONTINUE
16012C
16013C               *****************
16014C               **  STEP 90--  **
16015C               **  EXIT.      **
16016C               *****************
16017C
16018 9000 CONTINUE
16019      IF(IBUGA3.EQ.'ON')THEN
16020        WRITE(ICOUT,999)
16021        CALL DPWRST('XXX','BUG ')
16022        WRITE(ICOUT,9011)
16023 9011   FORMAT('***** AT THE END OF CORMAT--')
16024        CALL DPWRST('XXX','BUG ')
16025        WRITE(ICOUT,9012)IBUGA3,IERROR
16026 9012   FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
16027        CALL DPWRST('XXX','BUG ')
16028        WRITE(ICOUT,9013)N,N11,N12,N21,N22
16029 9013   FORMAT('N,N11,N12,N21,N22 = ',5I10)
16030        CALL DPWRST('XXX','BUG ')
16031        WRITE(ICOUT,9015)STAT
16032 9015   FORMAT('STAT = ',G15.7)
16033        CALL DPWRST('XXX','BUG ')
16034      ENDIF
16035C
16036      RETURN
16037      END
16038      SUBROUTINE CORR(X,Y,N,IWRITE,XYCORR,IBUGA3,IERROR)
16039C
16040C     PURPOSE--THIS SUBROUTINE COMPUTES THE SAMPLE CORRELATION COEFFICIENT
16041C              BETWEEN THE 2 SETS OF DATA IN THE INPUT VECTORS X AND Y.
16042C              THE SAMPLE CORRELATION COEFFICIENT WILL BE A SINGLE
16043C              PRECISION VALUE CALCULATED AS THE SUM OF CROSS PRODUCTS
16044C              DIVIDED BY (N-1).
16045C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
16046C                                (UNSORTED) OBSERVATIONS WHICH
16047C                                CONSTITUTE THE FIRST SET OF DATA.
16048C                     --Y      = THE SINGLE PRECISION VECTOR OF
16049C                                (UNSORTED) OBSERVATIONS WHICH
16050C                                CONSTITUTE THE SECOND SET OF DATA.
16051C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
16052C                                IN THE VECTOR X, OR EQUIVALENTLY,
16053C                                THE INTEGER NUMBER OF OBSERVATIONS
16054C                                IN THE VECTOR Y.
16055C     OUTPUT ARGUMENTS--XYCORR = THE SINGLE PRECISION VALUE OF THE
16056C                                COMPUTED SAMPLE CORRELATION COEFFICIENT
16057C                                BETWEEN THE 2 SETS OF DATA IN THE
16058C                                INPUT VECTORS X AND Y.  THIS SINGLE
16059C                                PRECISION VALUE WILL BE BETWEEN -1.0
16060C                                AND 1.0 (INCLUSIVELY).
16061C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
16062C             SAMPLE CORRELATION COEFFICIENT BETWEEN THE 2 SETS
16063C             OF DATA IN THE INPUT VECTORS X AND Y.
16064C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
16065C                   OF N FOR THIS SUBROUTINE.
16066C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
16067C     FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT.
16068C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
16069C     LANGUAGE--ANSI FORTRAN (1977)
16070C     REFERENCES--KENDALL AND STUART, THE ADVANCED THEORY OF
16071C                 STATISTICS, VOLUME 1, EDITION 2, 1963, PAGES 235-236.
16072C               --KENDALL AND STUART, THE ADVANCED THEORY OF
16073C                 STATISTICS, VOLUME 2, EDITION 1, 1961, PAGES 292-293.
16074C               --SNEDECOR AND COCHRAN, STATISTICAL METHODS,
16075C                 EDITION 6, 1967, PAGES 172-198.
16076C     WRITTEN BY--JAMES J. FILLIBEN
16077C                 STATISTICAL ENGINEERING DIVISION
16078C                 INFORMATION TECHNOLOGY LABORATORY
16079C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
16080C                 GAITHERSBURG, MD 20899
16081C                 PHONE--301-975-2855
16082C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
16083C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
16084C     LANGUAGE--ANSI FORTRAN (1977)
16085C     VERSION NUMBER--82/7
16086C     ORIGINAL VERSION--APRIL     1979.
16087C     UPDATED         --JUNE      1979.
16088C     UPDATED         --JULY      1979.
16089C     UPDATED         --AUGUST    1981.
16090C     UPDATED         --MAY       1982.
16091C
16092C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
16093C
16094      CHARACTER*4 IWRITE
16095      CHARACTER*4 IBUGA3
16096      CHARACTER*4 IERROR
16097C
16098      CHARACTER*4 ISUBN1
16099      CHARACTER*4 ISUBN2
16100C
16101C---------------------------------------------------------------------
16102C
16103      DOUBLE PRECISION DN
16104      DOUBLE PRECISION DX1
16105      DOUBLE PRECISION DX2
16106      DOUBLE PRECISION DSUM1
16107      DOUBLE PRECISION DSUM2
16108      DOUBLE PRECISION DSUM12
16109      DOUBLE PRECISION DMEAN1
16110      DOUBLE PRECISION DMEAN2
16111      DOUBLE PRECISION DSQRT1
16112      DOUBLE PRECISION DSQRT2
16113C
16114      DIMENSION X(*)
16115      DIMENSION Y(*)
16116C
16117C---------------------------------------------------------------------
16118C
16119      INCLUDE 'DPCOP2.INC'
16120C
16121C-----START POINT-----------------------------------------------------
16122C
16123      ISUBN1='CORR'
16124      ISUBN2='    '
16125      IERROR='NO'
16126C
16127      DN=0.0D0
16128      DMEAN1=0.0D0
16129      DMEAN2=0.0D0
16130      DSUM12=0.0D0
16131C
16132      IF(IBUGA3.EQ.'ON')THEN
16133        WRITE(ICOUT,999)
16134  999   FORMAT(1X)
16135        CALL DPWRST('XXX','BUG ')
16136        WRITE(ICOUT,51)
16137   51   FORMAT('***** AT THE BEGINNING OF CORR--')
16138        CALL DPWRST('XXX','BUG ')
16139        WRITE(ICOUT,52)IBUGA3,N
16140   52   FORMAT('IBUGA3,N = ',A4,2X,I8)
16141        CALL DPWRST('XXX','BUG ')
16142        DO55I=1,N
16143         WRITE(ICOUT,56)I,X(I),Y(I)
16144   56    FORMAT('I,X(I),Y(I) = ',I8,2G15.7)
16145         CALL DPWRST('XXX','BUG ')
16146   55   CONTINUE
16147      ENDIF
16148C
16149C               *******************************************
16150C               **  COMPUTE     CORRELATION COEFFICIENT  **
16151C               *******************************************
16152C
16153C               ********************************************
16154C               **  STEP 1--                              **
16155C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
16156C               ********************************************
16157C
16158      AN=N
16159C
16160      IF(N.LT.1)THEN
16161        IERROR='YES'
16162        WRITE(ICOUT,999)
16163        CALL DPWRST('XXX','BUG ')
16164        WRITE(ICOUT,111)
16165  111   FORMAT('***** ERROR IN CORRELATION--')
16166        CALL DPWRST('XXX','BUG ')
16167        WRITE(ICOUT,112)
16168  112   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE')
16169        CALL DPWRST('XXX','BUG ')
16170        WRITE(ICOUT,113)
16171  113   FORMAT('      IS LESS THAN 1.')
16172        CALL DPWRST('XXX','BUG ')
16173        WRITE(ICOUT,117)N
16174  117   FORMAT('      THE NUMBER OF OBSERVATIONS HERE = ',I8,'.')
16175        CALL DPWRST('XXX','BUG ')
16176        GOTO9000
16177      ENDIF
16178C
16179      IF(N.EQ.1)THEN
16180        XYCORR=1.0
16181        GOTO9000
16182      ENDIF
16183C
16184      HOLD=X(1)
16185      DO135I=2,N
16186        IF(X(I).NE.HOLD)GOTO139
16187  135 CONTINUE
16188      IF(IWRITE.EQ.'ON')THEN
16189        WRITE(ICOUT,999)
16190        CALL DPWRST('XXX','BUG ')
16191        WRITE(ICOUT,131)
16192  131   FORMAT('***** WARNING IN CORRELATION--')
16193        CALL DPWRST('XXX','BUG ')
16194        WRITE(ICOUT,136)HOLD
16195  136   FORMAT('      THE FIRST RESPONSE VARIABLE HAS ALL ',
16196     1         'ELEMENTS = ',G15.7)
16197        CALL DPWRST('XXX','BUG ')
16198      ENDIF
16199      XYCORR=0.0
16200      GOTO9000
16201  139 CONTINUE
16202C
16203      HOLD=Y(1)
16204      DO145I=2,N
16205       IF(Y(I).NE.HOLD)GOTO149
16206  145 CONTINUE
16207      IF(IWRITE.EQ.'ON')THEN
16208        WRITE(ICOUT,999)
16209        CALL DPWRST('XXX','BUG ')
16210        WRITE(ICOUT,131)
16211        CALL DPWRST('XXX','BUG ')
16212        WRITE(ICOUT,146)HOLD
16213  146   FORMAT('      THE SECOND RESPONSE VARIABLE HAS ALL ',
16214     1         'ELEMENTS = ',G15.7)
16215        CALL DPWRST('XXX','BUG ')
16216      ENDIF
16217      XYCORR=0.0
16218      GOTO9000
16219  149 CONTINUE
16220C
16221C               ************************************************
16222C               **  STEP 2--                                  **
16223C               **  COMPUTE THE     CORRELATION COEFFICIENT.  **
16224C               ************************************************
16225C
16226      DN=N
16227      DSUM1=0.0D0
16228      DSUM2=0.0D0
16229      DO200I=1,N
16230        DX1=X(I)
16231        DX2=Y(I)
16232        DSUM1=DSUM1+DX1
16233        DSUM2=DSUM2+DX2
16234  200 CONTINUE
16235      DMEAN1=DSUM1/DN
16236      DMEAN2=DSUM2/DN
16237C
16238      DSUM1=0.0D0
16239      DSUM2=0.0D0
16240      DSUM12=0.0D0
16241      DO300I=1,N
16242        DX1=X(I)
16243        DX2=Y(I)
16244        DSUM1=DSUM1+(DX1-DMEAN1)*(DX1-DMEAN1)
16245        DSUM2=DSUM2+(DX2-DMEAN2)*(DX2-DMEAN2)
16246        DSUM12=DSUM12+(DX1-DMEAN1)*(DX2-DMEAN2)
16247  300 CONTINUE
16248      DSQRT1=0.0
16249      IF(DSUM1.GT.0.0D0)DSQRT1=DSQRT(DSUM1)
16250      DSQRT2=0.0
16251      IF(DSUM2.GT.0.0D0)DSQRT2=DSQRT(DSUM2)
16252      XYCORR=DSUM12/(DSQRT1*DSQRT2)
16253C
16254C               *******************************
16255C               **  STEP 3--                 **
16256C               **  WRITE OUT A LINE         **
16257C               **  OF SUMMARY INFORMATION.  **
16258C               *******************************
16259C
16260      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
16261        WRITE(ICOUT,999)
16262        CALL DPWRST('XXX','BUG ')
16263        WRITE(ICOUT,811)N,XYCORR
16264  811   FORMAT('THE CORRELATION COEFFICIENT OF THE ',I8,
16265     1         ' OBSERVATIONS = ',G15.7)
16266        CALL DPWRST('XXX','BUG ')
16267      ENDIF
16268C
16269C               *****************
16270C               **  STEP 90--  **
16271C               **  EXIT.      **
16272C               *****************
16273C
16274 9000 CONTINUE
16275      IF(IBUGA3.EQ.'ON')THEN
16276        WRITE(ICOUT,999)
16277        CALL DPWRST('XXX','BUG ')
16278        WRITE(ICOUT,9011)
16279 9011   FORMAT('***** AT THE END       OF CORR--')
16280        CALL DPWRST('XXX','BUG ')
16281        WRITE(ICOUT,9012)IERROR,XYCORR
16282 9012   FORMAT('IERROR,XYCORR = ',A4,2X,G15.7)
16283        CALL DPWRST('XXX','BUG ')
16284        WRITE(ICOUT,9014)DN,DMEAN1,DMEAN2,DSUM12
16285 9014   FORMAT('DN,DMEAN1,DMEAN2,DSUM12 = ',4G15.7)
16286        CALL DPWRST('XXX','BUG ')
16287      ENDIF
16288C
16289      RETURN
16290      END
16291      SUBROUTINE CORRAT(Y,X,N,ICASE,IWRITE,XDIST,ETA,
16292     1                  IBUGA3,ISUBRO,IERROR)
16293C
16294C     PURPOSE--THIS SUBROUTINE COMPUTES THE SAMPLE CORRELATION RATIO
16295C              FOR THE RESPONSE VARIABLE Y AND GROUP-ID VARIABLE X.
16296C              THE FORMULA IS:
16297C
16298C                 ETA**2 = SUM[i=1 to p][N(i)*(YBAR(i) - YBAR)**2/
16299C                          SUM[i=1 to p][SUM[j=1 to N(i)][Y(ij) - YBAR)**2
16300C
16301C              WHERE
16302C
16303C                 P       = NUMBER OF GROUPS
16304C                 N(i)    = NUMBER OF OBERVATIONS IN GROUP i
16305C                 YBAR(i) = MEAN OF GROUP i
16306C                 YBAR    = GRAND MEAN
16307C
16308C              THE INTRACLASS CORRELATION COEFFICIENT IS THE THE
16309C              SQUARE ROOT OF THE CORRELATION RATIO.
16310C
16311C     INPUT  ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR OF
16312C                                (UNSORTED) OBSERVATIONS FOR THE
16313C                                RESPONSE VARIABLE.
16314C                     --X      = THE SINGLE PRECISION VECTOR OF
16315C                                (UNSORTED) OBSERVATIONS FOR THE
16316C                                GROUP-ID VARIABLE.
16317C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
16318C                                IN THE VECTOR Y.
16319C     OUTPUT ARGUMENTS--CORR   = THE SINGLE PRECISION VALUE OF THE
16320C                                COMPUTED SAMPLE CORRELATION RATIO.
16321C                                THIS SINGLE PRECISION VALUE WILL BE
16322C                                BETWEEN -1.0 AND 1.0 (INCLUSIVELY).
16323C                     --ETA    = THE SINGLE PRECISION VALUE OF THE
16324C                                COMPUTED SAMPLE INTRACLASS CORRELATION.
16325C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE SAMPLE
16326C             CORRELATION RATIO FOR THE 2 SETS OF DATA IN THE INPUT
16327C             VECTORS X AND Y.
16328C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
16329C                   OF N FOR THIS SUBROUTINE.
16330C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
16331C     FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT.
16332C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
16333C     LANGUAGE--ANSI FORTRAN (1977)
16334C     REFERENCES--Pearson E.S. (1926) "Review of Statistical Methods
16335C                 for Research Workers (R. A. Fisher)", Science
16336C                 Progress, 20, 733-734.
16337C     WRITTEN BY--ALAN HECKERT
16338C                 STATISTICAL ENGINEERING DIVISION
16339C                 INFORMATION TECHNOLOGY LABORATORY
16340C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
16341C                 GAITHERSBURG, MD 20899
16342C                 PHONE--301-975-2899
16343C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
16344C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
16345C     LANGUAGE--ANSI FORTRAN (1977)
16346C     VERSION NUMBER--2019/08
16347C     ORIGINAL VERSION--AUGUST    2019.
16348C
16349C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
16350C
16351      CHARACTER*4 ICASE
16352      CHARACTER*4 IWRITE
16353      CHARACTER*4 IBUGA3
16354      CHARACTER*4 ISUBRO
16355      CHARACTER*4 IERROR
16356C
16357      CHARACTER*4 ISUBN1
16358      CHARACTER*4 ISUBN2
16359C
16360C---------------------------------------------------------------------
16361C
16362      DIMENSION X(*)
16363      DIMENSION Y(*)
16364      DIMENSION XDIST(*)
16365C
16366      DOUBLE PRECISION DN
16367      DOUBLE PRECISION DSUM1
16368      DOUBLE PRECISION DSUM2
16369      DOUBLE PRECISION DSUM3
16370      DOUBLE PRECISION DSUM4
16371      DOUBLE PRECISION DMEAN
16372C
16373C---------------------------------------------------------------------
16374C
16375      INCLUDE 'DPCOP2.INC'
16376C
16377C-----START POINT-----------------------------------------------------
16378C
16379      ISUBN1='CORR'
16380      ISUBN2='AT  '
16381      IERROR='NO'
16382C
16383      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RRAT')THEN
16384        WRITE(ICOUT,999)
16385  999   FORMAT(1X)
16386        CALL DPWRST('XXX','BUG ')
16387        WRITE(ICOUT,51)
16388   51   FORMAT('***** AT THE BEGINNING OF CORR--')
16389        CALL DPWRST('XXX','BUG ')
16390        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
16391   52   FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8)
16392        CALL DPWRST('XXX','BUG ')
16393        DO55I=1,N
16394          WRITE(ICOUT,56)I,X(I),Y(I)
16395   56     FORMAT('I,X(I),Y(I) = ',I8,2G15.7)
16396          CALL DPWRST('XXX','BUG ')
16397   55   CONTINUE
16398      ENDIF
16399C
16400C               *******************************************
16401C               **  COMPUTE     CORRELATION RATIO        **
16402C               *******************************************
16403C
16404C               ********************************************
16405C               **  STEP 1--                              **
16406C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
16407C               ********************************************
16408C
16409      AN=N
16410C
16411      IF(N.LT.1)THEN
16412        IERROR='YES'
16413        WRITE(ICOUT,999)
16414        CALL DPWRST('XXX','BUG ')
16415        WRITE(ICOUT,111)
16416  111   FORMAT('***** ERROR IN CORRELATION RATIO--')
16417        CALL DPWRST('XXX','BUG ')
16418        WRITE(ICOUT,112)
16419  112   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE')
16420        CALL DPWRST('XXX','BUG ')
16421        WRITE(ICOUT,113)
16422  113   FORMAT('      VARIABLE IS LESS THAN 1.')
16423        CALL DPWRST('XXX','BUG ')
16424        WRITE(ICOUT,117)N
16425  117   FORMAT('      THE NUMBER OF OBSERVATIONS = ',I8,'.')
16426        CALL DPWRST('XXX','BUG ')
16427        GOTO9000
16428      ENDIF
16429C
16430C               ************************************************
16431C               **  STEP 2--                                  **
16432C               **  COMPUTE THE     CORRELATION RATIO.        **
16433C               ************************************************
16434C
16435      CALL DISTIN(X,N,IWRITE,XDIST,NDIST,IBUGA3,IERROR)
16436      CALL MEAN(Y,N,IWRITE,YBAR,IBUGA3,IERROR)
16437C
16438      DSUM2=0.0D0
16439      DSUM4=0.0D0
16440      DO1000IGRP=1,NDIST
16441        NTEMP=0
16442        AHOLD=XDIST(IGRP)
16443        DSUM1=0.0D0
16444        DSUM3=0.0D0
16445        DO1010I=1,N
16446          IF(X(I).EQ.AHOLD)THEN
16447            NTEMP=NTEMP+1
16448            DSUM1=DSUM1 + DBLE(Y(I))
16449            DSUM3=DSUM3 + (DBLE(Y(I)) - DBLE(YBAR))**2
16450          ENDIF
16451 1010   CONTINUE
16452        DMEAN=DSUM1/DBLE(NTEMP)
16453        DN=DBLE(NTEMP)
16454        DSUM2=DSUM2 + DN*(DMEAN-DBLE(YBAR))**2
16455        DSUM4=DSUM4 + DSUM3
16456C
16457        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RRAT')THEN
16458          WRITE(ICOUT,1019)IGRP,NTEMP,DSUM1,DSUM3
16459 1019     FORMAT('IGRP,NTEMP,DSUM1,DSUM3 = ',2I8,2G15.7)
16460          CALL DPWRST('XXX','BUG ')
16461        ENDIF
16462C
16463 1000 CONTINUE
16464      ETASQ=REAL(DSUM2/DSUM4)
16465      ETA=DSQRT(DSUM2/DSUM4)
16466C
16467C               *******************************
16468C               **  STEP 3--                 **
16469C               **  WRITE OUT A LINE         **
16470C               **  OF SUMMARY INFORMATION.  **
16471C               *******************************
16472C
16473      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
16474        WRITE(ICOUT,999)
16475        CALL DPWRST('XXX','BUG ')
16476        IF(ICASE.EQ.'CRAT')THEN
16477          WRITE(ICOUT,8011)N,ETA
16478 8011     FORMAT('THE CORRELATION RATIO OF THE ',I8,
16479     1         ' OBSERVATIONS = ',G15.7)
16480          CALL DPWRST('XXX','BUG ')
16481        ELSE
16482          WRITE(ICOUT,8013)N,ETASQ
16483 8013     FORMAT('THE INTRACLASS CORRELATION OF THE ',I8,
16484     1         ' OBSERVATIONS = ',G15.7)
16485          CALL DPWRST('XXX','BUG ')
16486        ENDIF
16487      ENDIF
16488C
16489C               *****************
16490C               **  STEP 90--  **
16491C               **  EXIT.      **
16492C               *****************
16493C
16494 9000 CONTINUE
16495      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RRAT')THEN
16496        WRITE(ICOUT,999)
16497        CALL DPWRST('XXX','BUG ')
16498        WRITE(ICOUT,9011)
16499 9011   FORMAT('***** AT THE END       OF CORRAT--')
16500        CALL DPWRST('XXX','BUG ')
16501        WRITE(ICOUT,9012)IERROR,NDIST,CORR,ETA
16502 9012   FORMAT('IERROR,NDIST,CORR,ETA = ',A4,2X,I8,2X,2G15.7)
16503        CALL DPWRST('XXX','BUG ')
16504        WRITE(ICOUT,9014)DN,DMEAN1,DMEAN2,DSUM12
16505 9014   FORMAT('DN,DMEAN1,DMEAN2,DSUM12 = ',4G15.7)
16506        CALL DPWRST('XXX','BUG ')
16507      ENDIF
16508C
16509      RETURN
16510      END
16511      SUBROUTINE COSCDF(X,CDF)
16512C
16513C     NOTE--COSINE CDF IS:
16514C              COSCDF(X) = (PI + X + SIN(X))/(2*PI),  -PI<=X<=PI
16515C     WRITTEN BY--JAMES J. FILLIBEN
16516C                 STATISTICAL ENGINEERING DIVISION
16517C                 INFORMATION TECHNOLOGY LABORATORY
16518C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
16519C                 GAITHERSBURG, MD 20899
16520C                 PHONE--301-975-2855
16521C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
16522C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
16523C     LANGUAGE--ANSI FORTRAN (1977)
16524C     VERSION NUMBER--95/4
16525C     ORIGINAL VERSION--APRIL     1995.
16526C
16527C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
16528C
16529C
16530      INCLUDE 'DPCOP2.INC'
16531C
16532      DATA PI/3.1415926535898E0/
16533C
16534C-----START POINT-----------------------------------------------------
16535C
16536      CDF=0.0
16537      IF(X.LT.-PI)THEN
16538        CDF=0.0
16539      ELSEIF(X.GT.PI)THEN
16540        CDF=1.0
16541      ELSE
16542        CDF=(PI + X + SIN(X))/(2*PI)
16543      ENDIF
16544C
16545      RETURN
16546      END
16547      SUBROUTINE COSDIS(X,Y,N,IWRITE,ICASE,STATVA,IBUGA3,ISUBRO,IERROR)
16548C
16549C     PURPOSE--THIS SUBROUTINE COMPUTES THE COSINE DISTANCE BETWEEN THE
16550C              TWO SETS OF DATA IN THE INPUT VECTORS X AND Y.  THE
16551C              SAMPLE COSINE DISTANCE WILL BE A SINGLE PRECISION VALUE
16552C              CALCULATED AS:
16553C
16554C                 SIMLARITY = SUM[i=1 to n][X(i)*Y(i)]/
16555C                             {SQRT(SUM{i=1 to n][X(i)**2])*
16556C                             SQRT(SUM{i=1 to n][Y(i)**2])}
16557C
16558C                 DISTANCE = 1 - SIMILARITY
16559C
16560C              THE ABOVE DISTANCE IS FOR POSITIVE VECTORS.  NOTE
16561C              THAT THIS DISTANCE IS NOT A PROPER DISTANCE IN THAT
16562C              THE SCHWARTZ INEQUALITY DOES NOT HOLD.  HOWEVER, THE
16563C              ANGULAR VERSIONS (FOR POSITIVE VECTORS) ARE PROPER
16564C              DISTANCES:
16565C
16566C                 ANGULAR DISTANCE = (1/COSINE SIMILARITY)/PI
16567C                 ANGULAR SIMILARITY = 1 - DISTANCE
16568C
16569C              2018/08: UPDATED FORMULAS
16570C
16571C                 ANGULAR DISTANCE = COS^(-1)(COSINE SIMILARITY)/PI
16572C                 ANGULAR SIMILARITY = 1 - DISTANCE
16573C
16574C              IF NEGATIVE DATA IS ENCOUNTERED IN THE INPUT
16575C              VECTORS, ONLY THE COSINE SIMILARITY IS COMPUTED.
16576C
16577C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
16578C                                (UNSORTED) OBSERVATIONS WHICH
16579C                                CONSTITUTE THE FIRST SET OF DATA.
16580C                     --Y      = THE SINGLE PRECISION VECTOR OF
16581C                                (UNSORTED) OBSERVATIONS WHICH
16582C                                CONSTITUTE THE SECOND SET OF DATA.
16583C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
16584C                                IN THE VECTORS X AND Y.
16585C     OUTPUT ARGUMENTS--STATVA = THE SINGLE PRECISION VALUE OF THE
16586C                                COMPUTED SAMPLE COSINE DISTANCE
16587C                                BETWEEN THE TWO SETS OF DATA IN THE
16588C                                INPUT VECTORS X AND Y.  THIS SINGLE
16589C                                PRECISION VALUE WILL BE BETWEEN 0.0
16590C                                AND 1.0 (INCLUSIVELY).
16591C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
16592C             SAMPLE COSINE DISTANCE BETWEEN THE 2 SETS
16593C             OF DATA IN THE INPUT VECTORS X AND Y.
16594C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
16595C                   OF N FOR THIS SUBROUTINE.
16596C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
16597C     FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT.
16598C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
16599C     LANGUAGE--ANSI FORTRAN (1977)
16600C     REFERENCES--JOHN FOREMAN (2014), "DATA SMART", WILEY.
16601C     WRITTEN BY--ALAN HECKERT
16602C                 STATISTICAL ENGINEERING DIVISION
16603C                 INFORMATION TECHNOLOGY LABORATORY
16604C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
16605C                 GAITHERSBURG, MD 20899
16606C                 PHONE--301-975-2899
16607C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
16608C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
16609C     LANGUAGE--ANSI FORTRAN (1977)
16610C     VERSION NUMBER--2017/03
16611C     ORIGINAL VERSION--MARCH     2017.
16612C
16613C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
16614C
16615      CHARACTER*4 IWRITE
16616      CHARACTER*4 ICASE
16617      CHARACTER*4 IBUGA3
16618      CHARACTER*4 ISUBRO
16619      CHARACTER*4 IERROR
16620C
16621      CHARACTER*4 ISUBN1
16622      CHARACTER*4 ISUBN2
16623C
16624C---------------------------------------------------------------------
16625C
16626      DOUBLE PRECISION DX1
16627      DOUBLE PRECISION DX2
16628      DOUBLE PRECISION DSUM1
16629      DOUBLE PRECISION DSUM2
16630      DOUBLE PRECISION DSUM3
16631      DOUBLE PRECISION DTERM1
16632C
16633      DIMENSION X(*)
16634      DIMENSION Y(*)
16635C
16636C---------------------------------------------------------------------
16637C
16638      INCLUDE 'DPCOP2.INC'
16639C
16640      DATA PI/3.14159265358979/
16641C
16642C-----START POINT-----------------------------------------------------
16643C
16644      ISUBN1='COSD'
16645      ISUBN2='IS  '
16646      IERROR='NO'
16647      COSSIM=CPUMIN
16648      COSDST=CPUMIN
16649      ANGSIM=CPUMIN
16650      ANGDIS=CPUMIN
16651C
16652      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'SDIS')THEN
16653        WRITE(ICOUT,999)
16654  999   FORMAT(1X)
16655        CALL DPWRST('XXX','BUG ')
16656        WRITE(ICOUT,51)
16657   51   FORMAT('***** AT THE BEGINNING OF COSDIS--')
16658        CALL DPWRST('XXX','BUG ')
16659        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
16660   52   FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8)
16661        CALL DPWRST('XXX','BUG ')
16662        DO55I=1,N
16663          WRITE(ICOUT,56)I,X(I),Y(I)
16664   56     FORMAT('I,X(I),Y(I) = ',I8,2G15.7)
16665          CALL DPWRST('XXX','BUG ')
16666   55   CONTINUE
16667      ENDIF
16668C
16669C               ********************************************
16670C               **  STEP 1--                              **
16671C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
16672C               ********************************************
16673C
16674      AN=N
16675C
16676      IF(N.LT.1)THEN
16677        WRITE(ICOUT,999)
16678        CALL DPWRST('XXX','BUG ')
16679        WRITE(ICOUT,111)
16680  111   FORMAT('***** ERROR IN COSINE DISTANCE--')
16681        CALL DPWRST('XXX','BUG ')
16682        WRITE(ICOUT,112)
16683  112   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE')
16684        CALL DPWRST('XXX','BUG ')
16685        WRITE(ICOUT,113)
16686  113   FORMAT('      VARIABLES IS LESS THAN 1.')
16687        CALL DPWRST('XXX','BUG ')
16688        WRITE(ICOUT,117)N
16689  117   FORMAT('      THE NUMBER OF OBSERVATIONS HERE = ',I8,'.')
16690        CALL DPWRST('XXX','BUG ')
16691        IERROR='YES'
16692        GOTO9000
16693      ENDIF
16694C
16695      IF(N.EQ.1)THEN
16696        STATVA=1.0
16697        GOTO9000
16698      ENDIF
16699C
16700C               ************************************************
16701C               **  STEP 2--                                  **
16702C               **  COMPUTE THE COSINE DISTANCE.              **
16703C               ************************************************
16704C
16705      IFLAG=1
16706      DSUM1=0.0D0
16707      DSUM2=0.0D0
16708      DSUM3=0.0D0
16709      DO200I=1,N
16710        IF(X(I).LT.0.0)IFLAG=0
16711        IF(Y(I).LT.0.0)IFLAG=0
16712        DX1=X(I)
16713        DX2=Y(I)
16714        DSUM1=DSUM1+DX1*DX2
16715        DSUM2=DSUM2+DX1**2
16716        DSUM3=DSUM3+DX2**2
16717  200 CONTINUE
16718      IF(DSUM2.GT.0.0D0 .AND. DSUM3.GT.0.0D0)THEN
16719        DTERM1=DSUM1/(DSQRT(DSUM2)*DSQRT(DSUM3))
16720      ELSE
16721        GOTO9000
16722      ENDIF
16723      COSSIM=REAL(DTERM1)
16724      IF(IFLAG.EQ.1)THEN
16725        COSDST=1.0 - COSSIM
16726        AFACT=2.0
16727      ELSE
16728        AFACT=1.0
16729      ENDIF
16730      ANGDIS=AFACT*ACOS(COSSIM)/PI
16731      ANGSIM=1.0 - ANGDIS
16732C
16733      IF(ICASE.EQ.'COSS')THEN
16734        STATVA=COSSIM
16735      ELSEIF(ICASE.EQ.'COSD')THEN
16736        STATVA=COSDST
16737      ELSEIF(ICASE.EQ.'ACOS')THEN
16738        STATVA=ANGSIM
16739      ELSEIF(ICASE.EQ.'ACOD')THEN
16740        STATVA=ANGDIS
16741      ENDIF
16742C
16743C               *******************************
16744C               **  STEP 3--                 **
16745C               **  WRITE OUT A LINE         **
16746C               **  OF SUMMARY INFORMATION.  **
16747C               *******************************
16748C
16749      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
16750        WRITE(ICOUT,999)
16751        CALL DPWRST('XXX','BUG ')
16752        IF(ICASE.EQ.'COSD')THEN
16753          WRITE(ICOUT,811)N,STATVA
16754  811     FORMAT('THE COSINE DISTANCE OF THE ',I8,
16755     1           ' OBSERVATIONS = ',G15.7)
16756          CALL DPWRST('XXX','BUG ')
16757        ELSEIF(ICASE.EQ.'COSS')THEN
16758          WRITE(ICOUT,813)N,STATVA
16759  813     FORMAT('THE COSINE SIMILARITY OF THE ',I8,
16760     1           ' OBSERVATIONS = ',G15.7)
16761          CALL DPWRST('XXX','BUG ')
16762        ELSEIF(ICASE.EQ.'ANGS')THEN
16763          WRITE(ICOUT,815)N,STATVA
16764  815     FORMAT('THE ANGULAR COSINE SIMILARITY OF THE ',I8,
16765     1           ' OBSERVATIONS = ',G15.7)
16766          CALL DPWRST('XXX','BUG ')
16767        ELSEIF(ICASE.EQ.'ANGD')THEN
16768          WRITE(ICOUT,817)N,STATVA
16769  817     FORMAT('THE ANGULAR COSINE DISTANCE OF THE ',I8,
16770     1           ' OBSERVATIONS = ',G15.7)
16771          CALL DPWRST('XXX','BUG ')
16772        ENDIF
16773      ENDIF
16774C
16775C               *****************
16776C               **  STEP 90--  **
16777C               **  EXIT.      **
16778C               *****************
16779C
16780 9000 CONTINUE
16781      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'SDIS')THEN
16782        WRITE(ICOUT,999)
16783        CALL DPWRST('XXX','BUG ')
16784        WRITE(ICOUT,9011)
16785 9011   FORMAT('***** AT THE END       OF CORR--')
16786        CALL DPWRST('XXX','BUG ')
16787        WRITE(ICOUT,9012)IERROR,STATVA,IFLAG1
16788 9012   FORMAT('IERROR,STATVA,IFLAG1 = ',A4,2X,G15.7,I5)
16789        CALL DPWRST('XXX','BUG ')
16790        WRITE(ICOUT,9014)DSUM1,DSUM2,DSUM3,DTERM1
16791 9014   FORMAT('DSUM1,DSUM2,DSUM3,DTERM1 = ',4G15.7)
16792        CALL DPWRST('XXX','BUG ')
16793        WRITE(ICOUT,9016)COSSIM,COSDST,ANGSIM,ANGDIS
16794 9016   FORMAT('COSSIM,COSDST,ANGSIM,ANGDIS = ',4G15.7)
16795        CALL DPWRST('XXX','BUG ')
16796      ENDIF
16797C
16798      RETURN
16799      END
16800      SUBROUTINE COSPDF(X,PDF)
16801C
16802C     NOTE--COSINE PDF IS:
16803C              COSPDF(X) = (1 + COS(X))/(2*PI),  -PI<=X<=PI
16804C     WRITTEN BY--JAMES J. FILLIBEN
16805C                 STATISTICAL ENGINEERING DIVISION
16806C                 INFORMATION TECHNOLOGY LABORATORY
16807C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
16808C                 GAITHERSBURG, MD 20899
16809C                 PHONE--301-975-2855
16810C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
16811C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
16812C     LANGUAGE--ANSI FORTRAN (1977)
16813C     VERSION NUMBER--95/4
16814C     ORIGINAL VERSION--APRIL     1995.
16815C
16816C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
16817C
16818C
16819      INCLUDE 'DPCOP2.INC'
16820C
16821      DATA PI/3.1415926535898E0/
16822C
16823C-----START POINT-----------------------------------------------------
16824C
16825      PDF=0.0
16826      IF(X.LT.-PI .OR. X.GT.PI)THEN
16827        WRITE(ICOUT,301)
16828        CALL DPWRST('XXX','BUG ')
16829        WRITE(ICOUT,302)X
16830        CALL DPWRST('XXX','BUG ')
16831        GOTO9999
16832      ENDIF
16833  301 FORMAT('***** ERROR--THE INPUT ARGUMENT TO COSPDF IS NOT IN THE ',
16834     1       'INTERVAL (-PI,PI).')
16835  302 FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
16836C
16837      PDF=(1.0 + COS(X))/(2*PI)
16838C
16839 9999 CONTINUE
16840      RETURN
16841      END
16842      SUBROUTINE COSPPF(P,PPF)
16843C
16844C     NOTE--ALGORITHM ADDED APRIL 1995 (ALAN)
16845C           USE A BISECTION METHOD
16846C     WRITTEN BY--JAMES J. FILLIBEN
16847C                 STATISTICAL ENGINEERING DIVISION
16848C                 INFORMATION TECHNOLOGY LABORATORY
16849C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
16850C                 GAITHERSBURG, MD 20899
16851C                 PHONE--301-975-2855
16852C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
16853C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
16854C     LANGUAGE--ANSI FORTRAN (1977)
16855C     VERSION NUMBER--95/4
16856C     ORIGINAL VERSION--APRIL     1995.
16857C
16858C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
16859C
16860      INCLUDE 'DPCOP2.INC'
16861C
16862      DATA PI/3.1415926535898E0/
16863      DATA EPS /1.0E-10/
16864      DATA SIG /1.0E-10/
16865      DATA ZERO /0./
16866      DATA MAXIT /500/
16867C
16868C-----START POINT-----------------------------------------------------
16869C
16870C     CHECK THE INPUT ARGUMENTS FOR ERRORS
16871C
16872      IF(P.LT.0.0.OR.P.GT.1.0)THEN
16873        WRITE(ICOUT,1)
16874    1   FORMAT('***** ERROR--THE FIRST ARGUMENT TO COSPPF IS OUTSIDE',
16875     1         ' THE ALLOWABLE (0,1) INTERVAL.')
16876        CALL DPWRST('XXX','BUG ')
16877        WRITE(ICOUT,46)P
16878   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
16879        CALL DPWRST('XXX','BUG ')
16880        PPF=0.0
16881        RETURN
16882      ENDIF
16883C
16884      IERR=0
16885      IC = 0
16886      IF(P.LE.0.0)THEN
16887        PPF=-PI
16888        GOTO9999
16889      ELSEIF(P.GE.1.0)THEN
16890        PPF=PI
16891        GOTO9999
16892      ENDIF
16893C
16894      XL = -PI
16895      XR = PI
16896      FXL = -P
16897      FXR = 1.0 - P
16898CCCCC INVALID P EXPLICITLY CHECKED FOR EARLIER.
16899CCCCC IF(FXL*FXR .GT. ZERO)GOTO50
16900C
16901C  BISECTION METHOD
16902C
16903  105 CONTINUE
16904      X = (XL+XR)*0.5
16905      CALL COSCDF(X,CDF)
16906      P1=CDF
16907      PPF=X
16908      FCS = P1 - P
16909      IF(FCS*FXL.GT.ZERO)GOTO110
16910      XR = X
16911      FXR = FCS
16912      GOTO115
16913  110 CONTINUE
16914      XL = X
16915      FXL = FCS
16916  115 CONTINUE
16917      XRML = XR - XL
16918      IF(XRML.LE.SIG .AND. ABS(FCS).LE.EPS)GOTO9999
16919      IC = IC + 1
16920      IF(IC.LE.MAXIT)GOTO105
16921      WRITE(ICOUT,130)
16922      CALL DPWRST('XXX','BUG ')
16923  130 FORMAT('***** ERROR--COSPPF ROUTINE DID NOT CONVERGE. ***')
16924      GOTO9999
16925C
16926 9999 CONTINUE
16927      RETURN
16928      END
16929      SUBROUTINE COSRAN(N,ISEED,X)
16930C
16931C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
16932C              FROM THE COSINE DISTRIBUTION
16933C              F(X) = 0.5*EXP(-ABS(X)).
16934C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
16935C                                OF RANDOM NUMBERS TO BE
16936C                                GENERATED.
16937C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
16938C                                (OF DIMENSION AT LEAST N)
16939C                                INTO WHICH THE GENERATED
16940C                                RANDOM SAMPLE WILL BE PLACED.
16941C     OUTPUT--A RANDOM SAMPLE OF SIZE N
16942C             FROM THE COSINE DISTRIBUTION
16943C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
16944C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
16945C                   OF N FOR THIS SUBROUTINE.
16946C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
16947C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
16948C     LANGUAGE--ANSI FORTRAN (1977)
16949C     WRITTEN BY--JAMES J. FILLIBEN
16950C                 STATISTICAL ENGINEERING DIVISION
16951C                 INFORMATION TECHNOLOGY LABORATORY
16952C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
16953C                 GAITHERSBURG, MD 20899
16954C                 PHONE--301-975-2855
16955C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
16956C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
16957C     LANGUAGE--ANSI FORTRAN (1977)
16958C     VERSION NUMBER--2001/10
16959C     ORIGINAL VERSION--OCTOBER   2001.
16960C
16961C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
16962C
16963C---------------------------------------------------------------------
16964C
16965      DIMENSION X(*)
16966C
16967C---------------------------------------------------------------------
16968C
16969      INCLUDE 'DPCOP2.INC'
16970C
16971C-----START POINT-----------------------------------------------------
16972C
16973C     CHECK THE INPUT ARGUMENTS FOR ERRORS
16974C
16975      IF(N.LT.1)THEN
16976        WRITE(ICOUT, 5)
16977    5   FORMAT('***** ERROR--THE FIRST ARGUMENT TO COSRAN IS ',
16978     1         'NON-POSITIVE.')
16979        CALL DPWRST('XXX','BUG ')
16980        WRITE(ICOUT,47)N
16981   47   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
16982        CALL DPWRST('XXX','BUG ')
16983        RETURN
16984      ENDIF
16985C
16986C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
16987C
16988      CALL UNIRAN(N,ISEED,X)
16989C
16990C     GENERATE N COSINE RANDOM NUMBERS
16991C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
16992C
16993      DO100I=1,N
16994        CALL COSPPF(X(I),XTEMP)
16995        X(I)=XTEMP
16996  100 CONTINUE
16997C
16998      RETURN
16999      END
17000      SUBROUTINE COSTRA(Y1,N1,IWRITE,Y2,N2,IBUGA3,IERROR)
17001C
17002C     PURPOSE--COMPUTE COSINE TRANSFORM OF A VARIABLE--
17003C            = THE COEFFICIENTS OF THE COSINE TERM
17004C              IN THE FINITE FOURIER RESPRESENTATION OF THE DATA IN Y1.
17005C              Y2(1) = A0 = MEAN
17006C              Y2(2) = A1
17007C              Y2(3) = A2
17008C              ETC.
17009C     NOTE--IT IS NOT PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y2(.)
17010C           BEING IDENTICAL TO THE INPUT VECTOR Y1(.).
17011C     WRITTEN BY--JAMES J. FILLIBEN
17012C                 STATISTICAL ENGINEERING DIVISION
17013C                 INFORMATION TECHNOLOGY LABORATORY
17014C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
17015C                 GAITHERSBURG, MD 20899
17016C                 PHONE--301-975-2855
17017C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
17018C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
17019C     LANGUAGE--ANSI FORTRAN (1977)
17020C     VERSION NUMBER--85/1
17021C     ORIGINAL VERSION--DECEMBER  1984.
17022C
17023C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
17024C
17025      CHARACTER*4 IWRITE
17026      CHARACTER*4 IBUGA3
17027      CHARACTER*4 IERROR
17028C
17029      CHARACTER*4 ISUBN1
17030C
17031C-----DOUBLE PRECISION STATEMENTS FOR NON-COMMON VARIABLES-------------
17032C
17033      DOUBLE PRECISION DPI
17034      DOUBLE PRECISION DN1
17035      DOUBLE PRECISION DDEL
17036      DOUBLE PRECISION DI
17037      DOUBLE PRECISION DSUM
17038      DOUBLE PRECISION DK
17039      DOUBLE PRECISION DOMEGA
17040      DOUBLE PRECISION DY1K
17041C
17042C---------------------------------------------------------------------
17043C
17044      DIMENSION Y1(*)
17045      DIMENSION Y2(*)
17046C
17047C---------------------------------------------------------------------
17048C
17049      INCLUDE 'DPCOP2.INC'
17050C
17051C-----START POINT-----------------------------------------------------
17052C
17053      ISUBN1='COST'
17054      IERROR='NO'
17055C
17056      N1HALF=(-999)
17057      IMAX=(-999)
17058      IEVODD=(-999)
17059      DDEL=(-999.0D0)
17060      DN1=(-999.0D0)
17061C
17062      DN1=N1
17063C
17064      DPI=3.14159265358979D0
17065C
17066      IF(IBUGA3.EQ.'ON')THEN
17067        WRITE(ICOUT,999)
17068  999   FORMAT(1X)
17069        CALL DPWRST('XXX','BUG ')
17070        WRITE(ICOUT,51)
17071   51   FORMAT('***** AT THE BEGINNING OF COSTRA--')
17072        CALL DPWRST('XXX','BUG ')
17073        WRITE(ICOUT,53)IBUGA3,IWRITE,N1
17074   53   FORMAT('IBUGA3,IWRITE,N1 = ',2(A4,2X),I8)
17075        CALL DPWRST('XXX','BUG ')
17076        DO55I=1,N1
17077          WRITE(ICOUT,56)I,Y1(I)
17078   56     FORMAT('I,Y1(I) = ',I8,G15.7)
17079          CALL DPWRST('XXX','BUG ')
17080   55   CONTINUE
17081      ENDIF
17082C
17083C               ***********************************
17084C               **  COMPUTE COSINE TRANSFORM.    **
17085C               ***********************************
17086C
17087      IF(N1.LT.1)GOTO1100
17088      GOTO1190
17089C
17090 1100 CONTINUE
17091      IERROR='YES'
17092      WRITE(ICOUT,999)
17093      CALL DPWRST('XXX','BUG ')
17094      WRITE(ICOUT,1151)
17095 1151 FORMAT('***** ERROR IN COSTRA--')
17096      CALL DPWRST('XXX','BUG ')
17097      WRITE(ICOUT,1152)
17098 1152 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
17099      CALL DPWRST('XXX','BUG ')
17100      WRITE(ICOUT,1153)
17101 1153 FORMAT('      IN THE VARIABLE FOR WHICH')
17102      CALL DPWRST('XXX','BUG ')
17103      WRITE(ICOUT,1154)
17104 1154 FORMAT('      THE COSINE TRANSFORM IS TO BE COMPUTED')
17105      CALL DPWRST('XXX','BUG ')
17106      WRITE(ICOUT,1155)
17107 1155 FORMAT('      MUST BE 1 OR LARGER.')
17108      CALL DPWRST('XXX','BUG ')
17109      WRITE(ICOUT,1156)
17110 1156 FORMAT('      SUCH WAS NOT THE CASE HERE.')
17111      CALL DPWRST('XXX','BUG ')
17112      WRITE(ICOUT,1157)N1
17113 1157 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
17114     1'.')
17115      CALL DPWRST('XXX','BUG ')
17116      GOTO9000
17117C
17118 1190 CONTINUE
17119C
17120      N1HALF=N1/2
17121      N1HALP=N1HALF+1
17122      IMAX=N1HALP
17123      IEVODD=N1-2*(N1/2)
17124      DDEL=(DN1+1.0D0)/2.0D0
17125      IF(IEVODD.EQ.0)DDEL=(DN1+2.0D0)/2.0D0
17126C
17127      J=0
17128      J=J+1
17129      DSUM=0.0
17130      DO1205K=1,N1
17131      DY1K=Y1(K)
17132      DSUM=DSUM+DY1K
17133 1205 CONTINUE
17134      COEF=DSUM/DN1
17135      Y2(J)=COEF
17136C
17137      DO1210IP1=2,IMAX
17138      J=J+1
17139      I=IP1-1
17140      DI=I
17141CCCCC FREQI=DI/DN1
17142      DSUM=0.0D0
17143C
17144      DO1220K=1,N1
17145      DK=K
17146      DOMEGA=2.0*DPI*(DI/DN1)
17147      DY1K=Y1(K)
17148      DSUM=DSUM+DY1K*DCOS(DOMEGA*(DK-DDEL))
17149 1220 CONTINUE
17150      COEF=DSUM/DN1
17151      IF(IBUGA3.EQ.'ON')WRITE(ICOUT,1221)J,I,DN1,DI,COEF
17152 1221 FORMAT('J,I,DN1,DI,COEF = ',I8,I8,2D15.7,E15.7)
17153      IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ')
17154C
17155      Y2(J)=COEF
17156C
17157 1210 CONTINUE
17158C
17159      N2=J
17160C
17161C               *****************
17162C               **  STEP 90--  **
17163C               **  EXIT.      **
17164C               *****************
17165C
17166 9000 CONTINUE
17167C
17168      IF(IBUGA3.EQ.'OFF')GOTO9090
17169      WRITE(ICOUT,999)
17170      CALL DPWRST('XXX','BUG ')
17171      WRITE(ICOUT,9011)
17172 9011 FORMAT('***** AT THE END       OF COSTRA--')
17173      CALL DPWRST('XXX','BUG ')
17174      WRITE(ICOUT,9012)IBUGA3,IERROR
17175 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
17176      CALL DPWRST('XXX','BUG ')
17177      WRITE(ICOUT,9013)N1,N2,N1HALF,IMAX,IEVODD,DDEL
17178 9013 FORMAT('N1,N2,N1HALF,IMAX,IEVODD,DDEL = ',5I8,D15.7)
17179      CALL DPWRST('XXX','BUG ')
17180      DO9015I=1,N1
17181      WRITE(ICOUT,9016)I,Y1(I),Y2(I)
17182 9016 FORMAT('I,Y1(I),Y2(I) = ',I8,2E15.7)
17183      CALL DPWRST('XXX','BUG ')
17184 9015 CONTINUE
17185 9090 CONTINUE
17186C
17187      RETURN
17188      END
17189      SUBROUTINE COV(X,Y,N,IWRITE,XYCOV,IBUGA3,IERROR)
17190C
17191C     PURPOSE--THIS SUBROUTINE COMPUTES THE
17192C              SAMPLE COVARIANCE COEFFICIENT
17193C              BETWEEN THE 2 SETS OF DATA IN THE INPUT VECTORS X AND Y.
17194C              THE SAMPLE COVARIANCE COEFFICIENT WILL BE A SINGLE
17195C              PRECISION VALUE CALCULATED AS THE
17196C              SUM OF CROSS PRODUCTS DIVIDED BY (N-1).
17197C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
17198C                                (UNSORTED) OBSERVATIONS
17199C                                WHICH CONSTITUTE THE FIRST SET
17200C                                OF DATA.
17201C                     --Y      = THE SINGLE PRECISION VECTOR OF
17202C                                (UNSORTED) OBSERVATIONS
17203C                                WHICH CONSTITUTE THE SECOND SET
17204C                                OF DATA.
17205C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
17206C                                IN THE VECTOR X, OR EQUIVALENTLY,
17207C                                THE INTEGER NUMBER OF OBSERVATIONS
17208C                                IN THE VECTOR Y.
17209C     OUTPUT ARGUMENTS--XYCOV  = THE SINGLE PRECISION VALUE OF THE
17210C                                COMPUTED SAMPLE COVARIANCE COEFFICIENT
17211C                                BETWEEN THE 2 SETS OF DATA
17212C                                IN THE INPUT VECTORS X AND Y.
17213C                                THIS SINGLE PRECISION VALUE
17214C                                WILL BE BETWEEN -1.0 AND 1.0
17215C                                (INCLUSIVELY).
17216C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
17217C             SAMPLE COVARIANCE COEFFICIENT BETWEEN THE 2 SETS
17218C             OF DATA IN THE INPUT VECTORS X AND Y.
17219C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
17220C                   OF N FOR THIS SUBROUTINE.
17221C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
17222C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
17223C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
17224C     LANGUAGE--ANSI FORTRAN (1977)
17225C     REFERENCES--KENDALL AND STUART, THE ADVANCED THEORY OF
17226C                 STATISTICS, VOLUME 1, EDITION 2, 1963, PAGES 235-236.
17227C               --KENDALL AND STUART, THE ADVANCED THEORY OF
17228C                 STATISTICS, VOLUME 2, EDITION 1, 1961, PAGES 292-293.
17229C               --SNEDECOR AND COCHRAN, STATISTICAL METHODS,
17230C                 EDITION 6, 1967, PAGES 172-198.
17231C     WRITTEN BY--JAMES J. FILLIBEN
17232C                 STATISTICAL ENGINEERING DIVISION
17233C                 INFORMATION TECHNOLOGY LABORATORY
17234C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
17235C                 GAITHERSBURG, MD 20899
17236C                 PHONE--301-975-2855
17237C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
17238C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
17239C     LANGUAGE--ANSI FORTRAN (1966)
17240C     VERSION NUMBER--82/7
17241C     ORIGINAL VERSION--APRIL     1979.
17242C     UPDATED         --JUNE      1979.
17243C     UPDATED         --JULY      1979.
17244C     UPDATED         --AUGUST    1981.
17245C     UPDATED         --MAY       1982.
17246C
17247C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
17248C
17249      CHARACTER*4 IWRITE
17250      CHARACTER*4 IBUGA3
17251      CHARACTER*4 IERROR
17252C
17253      CHARACTER*4 ISUBN1
17254      CHARACTER*4 ISUBN2
17255C
17256C---------------------------------------------------------------------
17257C
17258      DOUBLE PRECISION DN
17259      DOUBLE PRECISION DX1
17260      DOUBLE PRECISION DX2
17261      DOUBLE PRECISION DSUM1
17262      DOUBLE PRECISION DSUM2
17263      DOUBLE PRECISION DSUM12
17264      DOUBLE PRECISION DMEAN1
17265      DOUBLE PRECISION DMEAN2
17266C
17267      DIMENSION X(*)
17268      DIMENSION Y(*)
17269C
17270C---------------------------------------------------------------------
17271C
17272      INCLUDE 'DPCOP2.INC'
17273C
17274C-----START POINT-----------------------------------------------------
17275C
17276      ISUBN1='COV '
17277      ISUBN2='    '
17278C
17279      IERROR='NO'
17280C
17281      DN=0.0D0
17282      DMEAN1=0.0D0
17283      DMEAN2=0.0D0
17284      DSUM12=0.0D0
17285C
17286      IF(IBUGA3.EQ.'OFF')GOTO90
17287      WRITE(ICOUT,999)
17288  999 FORMAT(1X)
17289      CALL DPWRST('XXX','BUG ')
17290      WRITE(ICOUT,51)
17291   51 FORMAT('***** AT THE BEGINNING OF COV--')
17292      CALL DPWRST('XXX','BUG ')
17293      WRITE(ICOUT,52)IBUGA3
17294   52 FORMAT('IBUGA3 = ',A4)
17295      CALL DPWRST('XXX','BUG ')
17296      WRITE(ICOUT,53)N
17297   53 FORMAT('N = ',I8)
17298      CALL DPWRST('XXX','BUG ')
17299      DO55I=1,N
17300      WRITE(ICOUT,56)I,X(I),Y(I)
17301   56 FORMAT('I,X(I),Y(I) = ',I8,2E15.7)
17302      CALL DPWRST('XXX','BUG ')
17303   55 CONTINUE
17304   90 CONTINUE
17305C
17306C               *******************************************
17307C               **  COMPUTE     COVARIANCE  COEFFICIENT  **
17308C               *******************************************
17309C
17310C               ********************************************
17311C               **  STEP 1--                              **
17312C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
17313C               ********************************************
17314C
17315      AN=N
17316C
17317      IF(N.GE.1)GOTO119
17318      IERROR='YES'
17319      WRITE(ICOUT,999)
17320      CALL DPWRST('XXX','BUG ')
17321      WRITE(ICOUT,111)
17322  111 FORMAT('***** ERROR IN COV--')
17323      CALL DPWRST('XXX','BUG ')
17324      WRITE(ICOUT,112)
17325  112 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
17326      CALL DPWRST('XXX','BUG ')
17327      WRITE(ICOUT,113)
17328  113 FORMAT('      IN THE VARIABLE FOR WHICH')
17329      CALL DPWRST('XXX','BUG ')
17330      WRITE(ICOUT,114)
17331  114 FORMAT('      THE COVARIANCE COEFFICIENT IS TO BE')
17332      CALL DPWRST('XXX','BUG ')
17333      WRITE(ICOUT,115)
17334  115 FORMAT('      COMPUTED, MUST BE 1 OR LARGER.')
17335      CALL DPWRST('XXX','BUG ')
17336      WRITE(ICOUT,116)
17337  116 FORMAT('      SUCH WAS NOT THE CASE HERE.')
17338      CALL DPWRST('XXX','BUG ')
17339      WRITE(ICOUT,117)N
17340  117 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
17341     1'.')
17342      CALL DPWRST('XXX','BUG ')
17343      GOTO9000
17344  119 CONTINUE
17345C
17346      IF(N.EQ.1)GOTO120
17347      GOTO129
17348  120 CONTINUE
17349      WRITE(ICOUT,999)
17350      CALL DPWRST('XXX','BUG ')
17351      WRITE(ICOUT,121)
17352  121 FORMAT('***** NON-FATAL DIAGNOSTIC IN COV--',
17353     1'THE THIRD INPUT ARGUMENT (N) HAS THE VALUE 1')
17354      CALL DPWRST('XXX','BUG ')
17355      XYCOV=0.0
17356      GOTO9000
17357  129 CONTINUE
17358C
17359      HOLD=X(1)
17360      DO135I=2,N
17361      IF(X(I).NE.HOLD)GOTO139
17362  135 CONTINUE
17363      WRITE(ICOUT,999)
17364      CALL DPWRST('XXX','BUG ')
17365      WRITE(ICOUT,136)HOLD
17366  136 FORMAT('***** NON-FATAL DIAGNOSTIC IN COV--',
17367     1'THE FIRST  INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
17368      CALL DPWRST('XXX','BUG ')
17369      XYCOV=0.0
17370      GOTO9000
17371  139 CONTINUE
17372C
17373      HOLD=Y(1)
17374      DO145I=2,N
17375      IF(Y(I).NE.HOLD)GOTO149
17376  145 CONTINUE
17377      WRITE(ICOUT,999)
17378      CALL DPWRST('XXX','BUG ')
17379      WRITE(ICOUT,146)HOLD
17380  146 FORMAT('***** NON-FATAL DIAGNOSTIC IN COV--',
17381     1'THE SECOND INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
17382      CALL DPWRST('XXX','BUG ')
17383      XYCOV=0.0
17384      GOTO9000
17385  149 CONTINUE
17386C
17387C               ************************************************
17388C               **  STEP 2--                                  **
17389C               **  COMPUTE THE     COVARIANCE  COEFFICIENT.  **
17390C               ************************************************
17391C
17392      DN=N
17393      DSUM1=0.0D0
17394      DSUM2=0.0D0
17395      DO200I=1,N
17396      DX1=X(I)
17397      DX2=Y(I)
17398      DSUM1=DSUM1+DX1
17399      DSUM2=DSUM2+DX2
17400  200 CONTINUE
17401      DMEAN1=DSUM1/DN
17402      DMEAN2=DSUM2/DN
17403C
17404      DSUM12=0.0D0
17405      DO300I=1,N
17406      DX1=X(I)
17407      DX2=Y(I)
17408      DSUM12=DSUM12+(DX1-DMEAN1)*(DX2-DMEAN2)
17409  300 CONTINUE
17410      XYCOV=DSUM12/(DN-1.0D0)
17411C
17412C               *******************************
17413C               **  STEP 3--                 **
17414C               **  WRITE OUT A LINE         **
17415C               **  OF SUMMARY INFORMATION.  **
17416C               *******************************
17417C
17418      IF(IFEEDB.EQ.'OFF')GOTO890
17419      IF(IWRITE.EQ.'OFF')GOTO890
17420      WRITE(ICOUT,999)
17421      CALL DPWRST('XXX','BUG ')
17422      WRITE(ICOUT,811)N,XYCOV
17423  811 FORMAT('THE COVARIANCE COEFFICIENT OF THE ',I8,
17424     1' OBSERVATIONS = ',E15.7)
17425      CALL DPWRST('XXX','BUG ')
17426  890 CONTINUE
17427C
17428C               *****************
17429C               **  STEP 90--  **
17430C               **  EXIT.      **
17431C               *****************
17432C
17433 9000 CONTINUE
17434      IF(IBUGA3.EQ.'OFF')GOTO9090
17435      WRITE(ICOUT,999)
17436      CALL DPWRST('XXX','BUG ')
17437      WRITE(ICOUT,9011)
17438 9011 FORMAT('***** AT THE END       OF COV--')
17439      CALL DPWRST('XXX','BUG ')
17440      WRITE(ICOUT,9012)IBUGA3,IERROR
17441 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
17442      CALL DPWRST('XXX','BUG ')
17443      WRITE(ICOUT,9013)N
17444 9013 FORMAT('N = ',I8)
17445      CALL DPWRST('XXX','BUG ')
17446      WRITE(ICOUT,9014)DN,DMEAN1,DMEAN2,DSUM12
17447 9014 FORMAT('DN,DMEAN1,DMEAN2,DSUM12 = ',4D15.7)
17448      CALL DPWRST('XXX','BUG ')
17449      WRITE(ICOUT,9015)XYCOV
17450 9015 FORMAT('XYCOV = ',E15.7)
17451      CALL DPWRST('XXX','BUG ')
17452 9090 CONTINUE
17453C
17454      RETURN
17455      END
17456      SUBROUTINE COVMAT(YM1,YM9,DMEAN,MAXROM,NR,NC,MAXVAR)
17457C
17458C     PURPOSE--THIS SUBROUTINE COMPUTES THE VARIANCE-COVARIANCE
17459C              MATRIX.  THIS IS A UTILITY ROUTINE, ERROR CHECKING
17460C              PERFORMED BY CALLING ROUTINES.
17461C     INPUT  ARGUMENTS--YM1    = THE SINGLE PRECISION MATRIX OF
17462C                                OBSERVATIONS
17463C                     --NR     = THE INTEGER NUMBER OF ROWS
17464C                     --NC     = THE INTEGER NUMBER OF COLUMNS
17465C                     --MAXROM = LEADING DIMENSION OF XMAT, COVMAT
17466C     OUTPUT ARGUMENTS--YM9    = THE SINGLE PRECISION MATRIX WHICH
17467C                                WILL CONTAIN THE COVARIANCE MATRIX
17468C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
17469C             SAMPLE VARIANCE-COVARIANCE MATRIX.
17470C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
17471C                   OF N FOR THIS SUBROUTINE.
17472C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
17473C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
17474C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
17475C     LANGUAGE--ANSI FORTRAN (1977)
17476C     WRITTEN BY--JAMES J. FILLIBEN
17477C                 STATISTICAL ENGINEERING DIVISION
17478C                 INFORMATION TECHNOLOGY LABORATORY
17479C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
17480C                 GAITHERSBURG, MD 20899
17481C                 PHONE--301-975-2855
17482C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
17483C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
17484C     LANGUAGE--ANSI FORTRAN (1966)
17485C     VERSION NUMBER--2003/2
17486C     ORIGINAL VERSION--FEBRUARY  2003.
17487C
17488C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
17489C
17490      DOUBLE PRECISION DSUM1
17491      DOUBLE PRECISION DYM1
17492      DOUBLE PRECISION DDENOM
17493      DOUBLE PRECISION DNR
17494      DOUBLE PRECISION DDEL1
17495      DOUBLE PRECISION DDEL2
17496      DOUBLE PRECISION DCOV
17497      DOUBLE PRECISION DMEAN(*)
17498C
17499      DIMENSION YM1(MAXROM,NC)
17500      DIMENSION YM9(MAXVAR,MAXVAR)
17501C
17502C---------------------------------------------------------------------
17503C
17504      INCLUDE 'DPCOP2.INC'
17505C
17506C-----START POINT-----------------------------------------------------
17507C
17508      DNR=DBLE(NR)
17509C
17510      DO5111J=1,NC
17511        DSUM1=0.0D0
17512        DO5112I=1,NR
17513          DYM1=YM1(I,J)
17514          DSUM1=DSUM1+DYM1
17515 5112   CONTINUE
17516        DMEAN(J)=-9999.0D0
17517        DDENOM=DNR
17518        IF(DDENOM.NE.0.0D0)DMEAN(J)=REAL(DSUM1/DDENOM)
17519 5111 CONTINUE
17520C
17521      DO5121J=1,NC
17522        DO5122K=J,NC
17523          DSUM1=0.0D0
17524          DO5123I=1,NR
17525            DYM1=YM1(I,J)
17526            DYM2=YM1(I,K)
17527            DDEL1=DYM1-DMEAN(J)
17528            DDEL2=DYM2-DMEAN(K)
17529            DSUM1=DSUM1+DDEL1*DDEL2
17530 5123     CONTINUE
17531          DCOV=-9999.0D0
17532          DDENOM=DNR-1.0D0
17533          IF(DDENOM.NE.0.0D0)DCOV=DSUM1/DDENOM
17534          YM9(J,K)=DCOV
17535          YM9(K,J)=DCOV
17536 5122   CONTINUE
17537 5121 CONTINUE
17538C
17539C               *****************
17540C               **  STEP 90--  **
17541C               **  EXIT.      **
17542C               *****************
17543C
17544      RETURN
17545      END
17546      SUBROUTINE CP(X,N,ENGLSL,ENGUSL,IWRITE,XCP,XLCL,XUCL,
17547     1             IBUGA3,IERROR)
17548C
17549C     PURPOSE--THIS SUBROUTINE COMPUTES THE SAMPLE CP (PROCESS
17550C              CAPABILITY INDEX) OF THE DATA IN THE INPUT VECTOR X.
17551C              CP = (ENGUSL - ENGLSL) / 6*S
17552C     NOTE--IF THE TARGET VALUE IS MIDWAY BETWEEN ENGUSL AND ENGLSL,
17553C           THEN AN ALTERNATIVE EQUIVALENT DEFINITION FOR CP IS
17554C              CP = (ENGUSL-TARGET) / 3*S
17555C     NOTE--CP IS A MEASURE OF PROCESS PRECISION--
17556C           IT CONTAINS NO BIAS INFORMATION.
17557C     NOTE--THE CP INDEX IS A MEASURE WHICH TAKES ON THE VALUES 0 TO
17558C           INFINITY.  A GOOD PROCESS YIELDS VALUES OF CP WHICH ARE
17559C           LARGE (ABOVE 2); VALUES OF CP FROM 0.5 TO 1.0 ARE TYPICAL.
17560C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
17561C                                (UNSORTED OR SORTED) OBSERVATIONS.
17562C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
17563C                                IN THE VECTOR X.
17564C                     --ENGLSL = LOWER (ENGINEERING) SPEC LIMIT
17565C                     --ENGUSL = UPPER (ENGINEERING) SPEC LIMIT
17566C     OUTPUT ARGUMENTS--CP     = THE SINGLE PRECISION VALUE OF THE
17567C                                COMPUTED SAMPLE CP
17568C                     --XLCL   = LOWER 95% CONFIDENCE INTERVAL
17569C                     --XUCL   = UPPER 95% CONFIDENCE INTERVAL
17570C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
17571C             SAMPLE CP INDEX
17572C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
17573C                   OF N FOR THIS SUBROUTINE.
17574C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
17575C     FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT.
17576C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
17577C     LANGUAGE--ANSI FORTRAN (1977)
17578C     REFERENCES--R&M 2000 AIRFORCE MANUAL
17579C     WRITTEN BY--JAMES J. FILLIBEN
17580C                 STATISTICAL ENGINEERING DIVISION
17581C                 INFORMATION TECHNOLOGY LABORATORY
17582C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
17583C                 GAITHERSBURG, MD 20899
17584C                 PHONE--301-975-2855
17585C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
17586C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
17587C     LANGUAGE--ANSI FORTRAN (1977)
17588C     VERSION NUMBER--89.5
17589C     ORIGINAL VERSION--MAY       1989.
17590C     UPDATED         --SEPTEMBER 1990. REVERSE INPUT ARGS
17591C     UPDATED         --APRIL     2001. ADD LOWER AND UPPER 95%
17592C                                       CONFIDENCE INTERVAL.
17593C
17594C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
17595C
17596      CHARACTER*4 IWRITE
17597      CHARACTER*4 IBUGA3
17598      CHARACTER*4 IERROR
17599C
17600      CHARACTER*4 ISUBN1
17601      CHARACTER*4 ISUBN2
17602C
17603C---------------------------------------------------------------------
17604C
17605      DOUBLE PRECISION DN
17606      DOUBLE PRECISION DX
17607      DOUBLE PRECISION DSUM
17608      DOUBLE PRECISION DMEAN
17609      DOUBLE PRECISION DVAR
17610      DOUBLE PRECISION DSD
17611C
17612      DOUBLE PRECISION DUSL
17613      DOUBLE PRECISION DLSL
17614      DOUBLE PRECISION DNUM
17615      DOUBLE PRECISION DDEN
17616      DOUBLE PRECISION DCP
17617C
17618      DIMENSION X(*)
17619C
17620C---------------------------------------------------------------------
17621C
17622      INCLUDE 'DPCOP2.INC'
17623C
17624C-----START POINT-----------------------------------------------------
17625C
17626      ISUBN1='CP  '
17627      ISUBN2='    '
17628      IERROR='NO'
17629C
17630      XCP=0.0
17631      DMEAN=0.0D0
17632C
17633      IF(IBUGA3.EQ.'ON')THEN
17634        WRITE(ICOUT,999)
17635  999   FORMAT(1X)
17636        CALL DPWRST('XXX','BUG ')
17637        WRITE(ICOUT,51)
17638   51   FORMAT('***** AT THE BEGINNING OF CP--')
17639        CALL DPWRST('XXX','BUG ')
17640        WRITE(ICOUT,52)IBUGA3,N,ENGUSL,ENGLSL
17641   52   FORMAT('IBUGA3,N,ENGUSL,ENGLSL = ',A4,2X,I8,2G15.7)
17642        CALL DPWRST('XXX','BUG ')
17643        DO55I=1,N
17644          WRITE(ICOUT,56)I,X(I)
17645   56     FORMAT('I,X(I) = ',I8,G15.7)
17646          CALL DPWRST('XXX','BUG ')
17647   55   CONTINUE
17648      ENDIF
17649C
17650C               ********************************************
17651C               **  COMPUTE PROCESS CAPABILITY INDEX CP  **
17652C               ********************************************
17653C
17654C               ********************************************
17655C               **  STEP 1--                              **
17656C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
17657C               ********************************************
17658C
17659      AN=N
17660C
17661      IF(N.LT.1)THEN
17662        IERROR='YES'
17663        WRITE(ICOUT,999)
17664        CALL DPWRST('XXX','BUG ')
17665        WRITE(ICOUT,111)
17666  111   FORMAT('***** ERROR IN CP--')
17667        CALL DPWRST('XXX','BUG ')
17668        WRITE(ICOUT,112)
17669  112   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ',
17670     1         'VARIABLE IS NON-POSITIVE.')
17671        CALL DPWRST('XXX','BUG ')
17672        WRITE(ICOUT,117)N
17673  117   FORMAT('      THE NUMBER OF OBSERVATIONS = ',I8,'.')
17674        CALL DPWRST('XXX','BUG ')
17675        GOTO9000
17676      ELSEIF(N.EQ.1)THEN
17677        GOTO9000
17678      ENDIF
17679C
17680      HOLD=X(1)
17681      DO135I=2,N
17682        IF(X(I).NE.HOLD)GOTO139
17683  135 CONTINUE
17684      GOTO9000
17685  139 CONTINUE
17686C
17687C               ***************************************
17688C               **  STEP 2--                         **
17689C               **  COMPUTE THE STANDARD DEVIATION.  **
17690C               ***************************************
17691C
17692      DN=N
17693      DSUM=0.0D0
17694      DO200I=1,N
17695        DX=X(I)
17696        DSUM=DSUM+DX
17697  200 CONTINUE
17698      DMEAN=DSUM/DN
17699C
17700      DSUM=0.0D0
17701      DO300I=1,N
17702        DX=X(I)
17703        DSUM=DSUM+(DX-DMEAN)**2
17704  300 CONTINUE
17705      DVAR=DSUM/(DN-1.0D0)
17706      DSD=0.0D0
17707      IF(DVAR.GT.0.0D0)DSD=DSQRT(DVAR)
17708      XSD=DSD
17709C
17710C               **************************************************
17711C               **  STEP 3--                                    **
17712C               **  COMPUTE THE CP RATIO                        **
17713C               **************************************************
17714C
17715      DUSL=ENGUSL
17716      DLSL=ENGLSL
17717C
17718      DNUM=DUSL-DLSL
17719      IF(DNUM.LE.0.0D0)DNUM=0.0D0
17720C
17721      DDEN=6.0*DSD
17722C
17723      DCP=0.0
17724      IF(DDEN.GT.0.0D0)DCP=DNUM/DDEN
17725      XCP=DCP
17726C
17727      XLCL=0.0
17728      XUCL=0.0
17729      AN=REAL(N)
17730      NV=N-1
17731      AV=REAL(NV)
17732      P=0.975
17733      CALL CHSPPF(P,NV,PPF)
17734      IF((PPF/AV).GT.0.0)XUCL=XCP*SQRT(PPF/AV)
17735      P=0.025
17736      CALL CHSPPF(P,NV,PPF)
17737      IF((PPF/AV).GT.0.0)XLCL=XCP*SQRT(PPF/AV)
17738C
17739C               *******************************
17740C               **  STEP 3--                 **
17741C               **  WRITE OUT A LINE         **
17742C               **  OF SUMMARY INFORMATION.  **
17743C               *******************************
17744C
17745      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
17746        WRITE(ICOUT,999)
17747        CALL DPWRST('XXX','BUG ')
17748        WRITE(ICOUT,811)N,XCP
17749  811   FORMAT('THE CP OF THE ',I8,' OBSERVATIONS = ',G15.7)
17750        CALL DPWRST('XXX','BUG ')
17751      ENDIF
17752C
17753C               *****************
17754C               **  STEP 90--  **
17755C               **  EXIT.      **
17756C               *****************
17757C
17758 9000 CONTINUE
17759      IF(IBUGA3.EQ.'ON')THEN
17760        WRITE(ICOUT,999)
17761        CALL DPWRST('XXX','BUG ')
17762        WRITE(ICOUT,9011)
17763 9011   FORMAT('***** AT THE END       OF CP--')
17764        CALL DPWRST('XXX','BUG ')
17765        WRITE(ICOUT,9012)IBUGA3,IERROR
17766 9012   FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
17767        CALL DPWRST('XXX','BUG ')
17768        WRITE(ICOUT,9014)DMEAN,DSD,DUSL,DLSL
17769 9014   FORMAT('DMEAN,DSD,DUSL,DLSL = ',4G15.7)
17770        CALL DPWRST('XXX','BUG ')
17771        WRITE(ICOUT,9017)DNUM,DDEN,DCP,XCP
17772 9017   FORMAT('DNUM,DDEN,DCP,XCP = ',4G15.7)
17773        CALL DPWRST('XXX','BUG ')
17774      ENDIF
17775C
17776      RETURN
17777      END
17778      SUBROUTINE CPEVL(N,M,A,Z,C,B,KBD)
17779C***BEGIN PROLOGUE  CPEVL
17780C***REFER TO  CPZERO
17781C
17782C        Evaluate a complex polynomial and its derivatives.
17783C        Optionally compute error bounds for these values.
17784C
17785C   INPUT...
17786C        N = Degree of the polynomial
17787C        M = Number of derivatives to be calculated,
17788C            M=0 evaluates only the function
17789C            M=1 evaluates the function and first derivative, etc.
17790C             if M .GT. N+1 function and all N derivatives will be
17791C                calculated.
17792C       A = Complex vector containing the N+1 coefficients of polynomial
17793C               A(I)= coefficient of Z**(N+1-I)
17794C        Z = Complex point at which the evaluation is to take place.
17795C        C = Array of 2(M+1) words into which values are placed.
17796C        B = Array of 2(M+1) words only needed if bounds are to be
17797C              calculated.  It is not used otherwise.
17798C        KBD = A logical variable, e.g. .TRUE. or .FALSE. which is
17799C              to be set .TRUE. if bounds are to be computed.
17800C
17801C  OUTPUT...
17802C        C =  C(I+1) contains the complex value of the I-th
17803C              derivative at Z, I=0,...,M
17804C        B =  B(I) contains the bounds on the real and imaginary parts
17805C              of C(I) if they were requested.
17806C***ROUTINES CALLED  I1MACH
17807C***END PROLOGUE  CPEVL
17808C
17809      COMPLEX A(1),C(1),Z,CI,CIM1,B(1),BI,BIM1,T,ZA,Q
17810      LOGICAL KBD
17811C
17812      INCLUDE 'DPCOMC.INC'
17813C
17814      DATA NBITS /0/
17815      ZA(Q)=CMPLX(ABS(REAL(Q)),ABS(AIMAG(Q)))
17816C***FIRST EXECUTABLE STATEMENT  CPEVL
17817      IF ( NBITS .EQ. 0 ) NBITS = I1MACH (11)
17818      D1=2.**(1-NBITS)
17819      NP1=N+1
17820      DO 1 J=1,NP1
17821         CI=0.0
17822         CIM1=A(J)
17823         BI=0.0
17824         BIM1=0.0
17825         MINI=MIN0(M+1,N+2-J)
17826            DO 11 I=1,MINI
17827               IF(J .NE. 1) CI=C(I)
17828               IF(I .NE. 1) CIM1=C(I-1)
17829               C(I)=CIM1+Z*CI
17830               IF(.NOT. KBD) GO TO 1
17831               IF(J .NE. 1) BI=B(I)
17832               IF(I .NE. 1) BIM1=B(I-1)
17833               T=BI+(3.*D1+4.*D1*D1)*ZA(CI)
17834               R=REAL(ZA(Z)*CMPLX(REAL(T),-AIMAG(T)))
17835               S=AIMAG(ZA(Z)*T)
17836               B(I)=(1.+8.*D1)*(BIM1+D1*ZA(CIM1)+CMPLX(R,S))
17837               IF(J .EQ. 1) B(I)=0.0
17838   11       CONTINUE
17839    1 CONTINUE
17840      RETURN
17841      END
17842      SUBROUTINE CPK(X,N,ENGLSL,ENGUSL,IWRITE,XCPK,XLCL,XUCL,
17843     1               IBUGA3,IERROR)
17844C
17845C     PURPOSE--THIS SUBROUTINE COMPUTES THE SAMPLE CPK (PROCESS
17846C              CAPABILITY INDEX) OF THE DATA IN THE INPUT VECTOR X.
17847C
17848C                 CPK = MIN(USL-MEAN,MEAN-LSL)/(3*S)
17849C
17850C     NOTE--CPK IS A MEASURE OF PROCESS ACCURACY--
17851C           COMBINING BOTH PRECISION AND UNBIASEDNESS.
17852C     NOTE--THE CPK INDEX IS A MEASURE WHICH TAKES ON THE VALUES 0 TO
17853C           INFINITY.  A GOOD PROCESS YIELDS VALUES OF CPK WHICH ARE
17854C           LARGE (ABOVE 2); VALUES OF CPK FROM 0.5 TO 1.0 ARE TYPICAL.
17855C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
17856C                                (UNSORTED OR SORTED) OBSERVATIONS.
17857C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
17858C                                IN THE VECTOR X.
17859C                     --ENGLSL = LOWER (ENGINEERING) SPEC LIMIT
17860C                     --ENGUSL = UPPER (ENGINEERING) SPEC LIMIT
17861C     OUTPUT ARGUMENTS--CPK    = THE SINGLE PRECISION VALUE OF THE
17862C                                COMPUTED SAMPLE CPK
17863C                     --XLCL   = LOWER 95% CONFIDENCE LEVEL
17864C                     --XUCL   = UPPER 95% CONFIDENCE LEVEL
17865C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
17866C             SAMPLE CPK INDEX
17867C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
17868C                   OF N FOR THIS SUBROUTINE.
17869C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
17870C     FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT.
17871C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
17872C     LANGUAGE--ANSI FORTRAN (1977)
17873C     REFERENCES--R&M 2000 AIR FORCE MANUAL
17874C               --CHEN AND DING (2001), "A NEW PROCESS CAPABILITY
17875C                 INDEX FOR NON-NORMAL DISTRIBUTIONS", INTERNATIONAL
17876C                 JOURNAL OF QUALITY & RELIABILITY MANAGEMENT,
17877C                 VOL. 18, NO. 7, PP. 762-770.
17878C     WRITTEN BY--JAMES J. FILLIBEN
17879C                 STATISTICAL ENGINEERING DIVISION
17880C                 INFORMATION TECHNOLOGY LABORATORY
17881C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
17882C                 GAITHERSBURG, MD 20899
17883C                 PHONE--301-975-2855
17884C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
17885C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
17886C     LANGUAGE--ANSI FORTRAN (1977)
17887C     VERSION NUMBER--89.5
17888C     ORIGINAL VERSION--MAY       1989.
17889C     UPDATED         --SEPTEMBER 1990. REVERSE INPUT ARGS
17890C     UPDATED         --APRIL     2001. 95% CONFIDENCE LIMITS
17891C
17892C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
17893C
17894      CHARACTER*4 IWRITE
17895      CHARACTER*4 IBUGA3
17896      CHARACTER*4 IERROR
17897C
17898      CHARACTER*4 ISUBN1
17899      CHARACTER*4 ISUBN2
17900C
17901C---------------------------------------------------------------------
17902C
17903      DOUBLE PRECISION DN
17904      DOUBLE PRECISION DX
17905      DOUBLE PRECISION DSUM
17906      DOUBLE PRECISION DMEAN
17907      DOUBLE PRECISION DVAR
17908      DOUBLE PRECISION DSD
17909C
17910      DOUBLE PRECISION DUSL
17911      DOUBLE PRECISION DLSL
17912      DOUBLE PRECISION DUPPER
17913      DOUBLE PRECISION DLOWER
17914      DOUBLE PRECISION DNUM
17915      DOUBLE PRECISION DDEN
17916      DOUBLE PRECISION DCPK
17917C
17918      DIMENSION X(*)
17919C
17920C---------------------------------------------------------------------
17921C
17922      INCLUDE 'DPCOP2.INC'
17923C
17924C-----START POINT-----------------------------------------------------
17925C
17926      ISUBN1='CPK '
17927      ISUBN2='    '
17928      IERROR='NO'
17929C
17930      XCPK=0.0
17931C
17932      IF(IBUGA3.EQ.'ON')THEN
17933        WRITE(ICOUT,999)
17934  999   FORMAT(1X)
17935        CALL DPWRST('XXX','BUG ')
17936        WRITE(ICOUT,51)
17937   51   FORMAT('***** AT THE BEGINNING OF CPK--')
17938        CALL DPWRST('XXX','BUG ')
17939        WRITE(ICOUT,52)IBUGA3,N,ENGUSL,ENGLSL
17940   52   FORMAT('IBUGA3,N,ENGUSL,ENGLSL = ',A4,2X,I8,2G15.7)
17941        CALL DPWRST('XXX','BUG ')
17942        DO55I=1,N
17943          WRITE(ICOUT,56)I,X(I)
17944   56     FORMAT('I,X(I) = ',I8,G15.7)
17945          CALL DPWRST('XXX','BUG ')
17946   55   CONTINUE
17947      ENDIF
17948C
17949C               ********************************************
17950C               **  COMPUTE PROCESS CAPABILITY INDEX CPK  **
17951C               ********************************************
17952C
17953C               ********************************************
17954C               **  STEP 1--                              **
17955C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
17956C               ********************************************
17957C
17958      AN=N
17959C
17960      IF(N.LT.1)THEN
17961        IERROR='YES'
17962        WRITE(ICOUT,999)
17963        CALL DPWRST('XXX','BUG ')
17964        WRITE(ICOUT,111)
17965  111   FORMAT('***** ERROR IN CPK--')
17966        CALL DPWRST('XXX','BUG ')
17967        WRITE(ICOUT,112)
17968  112   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ',
17969     1         'VARIABLE IS NON-POSITIVE.')
17970        CALL DPWRST('XXX','BUG ')
17971        WRITE(ICOUT,117)N
17972  117   FORMAT('      THE NUMBER OF OBSERVATIONS = ',I8,'.')
17973        CALL DPWRST('XXX','BUG ')
17974        GOTO9000
17975      ELSEIF(N.EQ.1)THEN
17976        GOTO9000
17977      ENDIF
17978C
17979      HOLD=X(1)
17980      DO135I=2,N
17981        IF(X(I).NE.HOLD)GOTO139
17982  135 CONTINUE
17983      GOTO9000
17984  139 CONTINUE
17985C
17986C               ***************************************
17987C               **  STEP 2--                         **
17988C               **  COMPUTE THE STANDARD DEVIATION.  **
17989C               ***************************************
17990C
17991      DN=N
17992      DSUM=0.0D0
17993      DO200I=1,N
17994        DX=X(I)
17995        DSUM=DSUM+DX
17996  200 CONTINUE
17997      DMEAN=DSUM/DN
17998C
17999      DSUM=0.0D0
18000      DO300I=1,N
18001        DX=X(I)
18002        DSUM=DSUM+(DX-DMEAN)**2
18003  300 CONTINUE
18004      DVAR=DSUM/(DN-1.0D0)
18005      DSD=0.0D0
18006      IF(DVAR.GT.0.0D0)DSD=DSQRT(DVAR)
18007      XSD=DSD
18008C
18009C               **************************************************
18010C               **  STEP 3--                                    **
18011C               **  COMPUTE THE CPK RATIO                       **
18012C               **************************************************
18013C
18014      DUSL=ENGUSL
18015      DLSL=ENGLSL
18016C
18017      DUPPER=DUSL-DMEAN
18018      DLOWER=DMEAN-DLSL
18019C
18020      DNUM=DUPPER
18021      IF(DLOWER.LT.DUPPER)DNUM=DLOWER
18022      IF(DNUM.LE.0.0D0)DNUM=0.0D0
18023C
18024      DDEN=3.0*DSD
18025C
18026      DCPK=0.0
18027      IF(DDEN.GT.0.0D0)DCPK=DNUM/DDEN
18028      XCPK=DCPK
18029C
18030      AN=REAL(N)
18031      P=0.975
18032      TERM1=1.0/(9.0*AN)
18033      TERM2=XCPK*XCPK/(2.0*(AN-1.0))
18034      CALL NORPPF(P,PPF)
18035      XLCL=XCPK - PPF*SQRT(TERM1 + TERM2)
18036      XUCL=XCPK + PPF*SQRT(TERM1 + TERM2)
18037C
18038C               *******************************
18039C               **  STEP 3--                 **
18040C               **  WRITE OUT A LINE         **
18041C               **  OF SUMMARY INFORMATION.  **
18042C               *******************************
18043C
18044      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
18045        WRITE(ICOUT,999)
18046        CALL DPWRST('XXX','BUG ')
18047        WRITE(ICOUT,811)N,XCPK
18048  811   FORMAT('THE CPK OF THE ',I8,' OBSERVATIONS = ',G15.7)
18049        CALL DPWRST('XXX','BUG ')
18050      ENDIF
18051C
18052C               *****************
18053C               **  STEP 90--  **
18054C               **  EXIT.      **
18055C               *****************
18056C
18057 9000 CONTINUE
18058      IF(IBUGA3.EQ.'ON')THEN
18059        WRITE(ICOUT,999)
18060        CALL DPWRST('XXX','BUG ')
18061        WRITE(ICOUT,9011)
18062 9011   FORMAT('***** AT THE END       OF CPK--')
18063        CALL DPWRST('XXX','BUG ')
18064        WRITE(ICOUT,9012)IBUGA3,IERROR
18065 9012   FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
18066        CALL DPWRST('XXX','BUG ')
18067        WRITE(ICOUT,9014)DMEAN,DSD
18068 9014   FORMAT('DMEAN,DSD = ',2G15.7)
18069        CALL DPWRST('XXX','BUG ')
18070        WRITE(ICOUT,9016)DUSL,DLSL,DUPPER,DLOWER
18071 9016   FORMAT('DUSL,DLSL,DUPPER,DLOWER = ',4G15.7)
18072        CALL DPWRST('XXX','BUG ')
18073        WRITE(ICOUT,9017)DNUM,DDEN,DCPK,XCPK
18074 9017   FORMAT('DNUM,DDEN,DCPK,XCPK = ',4G15.7)
18075        CALL DPWRST('XXX','BUG ')
18076      ENDIF
18077C
18078      RETURN
18079      END
18080      SUBROUTINE CPKM(X,N,ENGLSL,ENGUSL,TARGET,IWRITE,XCPKM,XLCL,XUCL,
18081     1                IBUGA3,IERROR)
18082C
18083C     PURPOSE--THIS SUBROUTINE COMPUTES THE SAMPLE CPKM (PROCESS
18084C              CAPABILITY INDEX) OF THE DATA IN THE INPUT VECTOR X.
18085C
18086C                 CPKM = MIN(USL-MEAN,MEAN-LSL)/
18087C                        {3*SQRT(S**2 +(MEAN-TARGET)**2)}
18088C
18089C     NOTE--CPKM IS A MEASURE OF PROCESS ACCURACY--
18090C           COMBINING BOTH PRECISION AND UNBIASEDNESS.
18091C     NOTE--THE CPKM INDEX IS A MEASURE WHICH TAKES ON THE VALUES 0 TO
18092C           INFINITY.  A GOOD PROCESS YIELDS VALUES OF CPKM WHICH ARE
18093C           LARGE (ABOVE 2); VALUES OF CPKM FROM 0.5 TO 1.0 ARE TYPICAL.
18094C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
18095C                                (UNSORTED OR SORTED) OBSERVATIONS.
18096C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
18097C                                IN THE VECTOR X.
18098C                     --ENGLSL = LOWER (ENGINEERING) SPEC LIMIT
18099C                     --ENGUSL = UPPER (ENGINEERING) SPEC LIMIT
18100C                     --TARGET = TARGET VALUE (ENGINEERING)
18101C     OUTPUT ARGUMENTS--CPKM   = THE SINGLE PRECISION VALUE OF THE
18102C                                COMPUTED SAMPLE CPKM
18103C                     --XLCL   = LOWER 95% CONFIDENCE LEVEL
18104C                     --XUCL   = UPPER 95% CONFIDENCE LEVEL
18105C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
18106C             SAMPLE CPKM INDEX
18107C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
18108C                   OF N FOR THIS SUBROUTINE.
18109C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
18110C     FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT.
18111C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
18112C     LANGUAGE--ANSI FORTRAN (1977)
18113C     REFERENCES--CHEN AND DING (2001), "A NEW PROCESS CAPABILITY
18114C                 INDEX FOR NON-NORMAL DISTRIBUTIONS", INTERNATIONAL
18115C                 JOURNAL OF QUALITY & RELIABILITY MANAGEMENT,
18116C                 VOL. 18, NO. 7, PP. 762-770.
18117C     WRITTEN BY--ALAN HECKERT
18118C                 STATISTICAL ENGINEERING DIVISION
18119C                 INFORMATION TECHNOLOGY LABORATORY
18120C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
18121C                 GAITHERSBURG, MD 20899
18122C                 PHONE--301-975-2899
18123C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
18124C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
18125C     LANGUAGE--ANSI FORTRAN (1977)
18126C     VERSION NUMBER--2015.4
18127C     ORIGINAL VERSION--APRIL     2015.
18128C
18129C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
18130C
18131      CHARACTER*4 IWRITE
18132      CHARACTER*4 IBUGA3
18133      CHARACTER*4 IERROR
18134C
18135      CHARACTER*4 ISUBN1
18136      CHARACTER*4 ISUBN2
18137C
18138C---------------------------------------------------------------------
18139C
18140      DOUBLE PRECISION DN
18141      DOUBLE PRECISION DX
18142      DOUBLE PRECISION DSUM
18143      DOUBLE PRECISION DMEAN
18144      DOUBLE PRECISION DVAR
18145      DOUBLE PRECISION DSD
18146C
18147      DOUBLE PRECISION DUSL
18148      DOUBLE PRECISION DLSL
18149      DOUBLE PRECISION DTARG
18150      DOUBLE PRECISION DUPPER
18151      DOUBLE PRECISION DLOWER
18152      DOUBLE PRECISION DNUM
18153      DOUBLE PRECISION DDEN
18154      DOUBLE PRECISION DCPKM
18155C
18156      DIMENSION X(*)
18157C
18158C---------------------------------------------------------------------
18159C
18160      INCLUDE 'DPCOP2.INC'
18161C
18162C-----START POINT-----------------------------------------------------
18163C
18164      ISUBN1='CPKM'
18165      ISUBN2='    '
18166      IERROR='NO'
18167C
18168      XCPKM=0.0
18169      XCL=CPUMIN
18170      XUL=CPUMIN
18171C
18172      IF(IBUGA3.EQ.'ON')THEN
18173        WRITE(ICOUT,999)
18174  999   FORMAT(1X)
18175        CALL DPWRST('XXX','BUG ')
18176        WRITE(ICOUT,51)
18177   51   FORMAT('***** AT THE BEGINNING OF CPKM--')
18178        CALL DPWRST('XXX','BUG ')
18179        WRITE(ICOUT,52)IBUGA3,N,ENGUSL,ENGLSL,XLCL,XUCL
18180   52   FORMAT('IBUGA3,N,ENGUSL,ENGLSL,XLCL,XUCL = ',A4,2X,I8,4G15.7)
18181        CALL DPWRST('XXX','BUG ')
18182        DO55I=1,N
18183          WRITE(ICOUT,56)I,X(I)
18184   56     FORMAT('I,X(I) = ',I8,G15.7)
18185          CALL DPWRST('XXX','BUG ')
18186   55   CONTINUE
18187      ENDIF
18188C
18189C               ********************************************
18190C               **  COMPUTE PROCESS CAPABILITY INDEX CPKM  **
18191C               ********************************************
18192C
18193C               ********************************************
18194C               **  STEP 1--                              **
18195C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
18196C               ********************************************
18197C
18198      AN=N
18199C
18200      IF(N.LT.1)THEN
18201        IERROR='YES'
18202        WRITE(ICOUT,999)
18203        CALL DPWRST('XXX','BUG ')
18204        WRITE(ICOUT,111)
18205  111   FORMAT('***** ERROR IN CPKM--')
18206        CALL DPWRST('XXX','BUG ')
18207        WRITE(ICOUT,112)
18208  112   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ',
18209     1         'VARIABLE IS NON-POSITIVE.')
18210        CALL DPWRST('XXX','BUG ')
18211        WRITE(ICOUT,117)N
18212  117   FORMAT('      THE NUMBER OF OBSERVATIONS = ',I8,'.')
18213        CALL DPWRST('XXX','BUG ')
18214        GOTO9000
18215      ELSEIF(N.EQ.1)THEN
18216        GOTO9000
18217      ENDIF
18218C
18219      HOLD=X(1)
18220      DO135I=2,N
18221        IF(X(I).NE.HOLD)GOTO139
18222  135 CONTINUE
18223      GOTO9000
18224  139 CONTINUE
18225C
18226C               ***************************************
18227C               **  STEP 2--                         **
18228C               **  COMPUTE THE STANDARD DEVIATION.  **
18229C               ***************************************
18230C
18231      DN=N
18232      DSUM=0.0D0
18233      DO200I=1,N
18234        DX=X(I)
18235        DSUM=DSUM+DX
18236  200 CONTINUE
18237      DMEAN=DSUM/DN
18238C
18239      DSUM=0.0D0
18240      DO300I=1,N
18241        DX=X(I)
18242        DSUM=DSUM+(DX-DMEAN)**2
18243  300 CONTINUE
18244      DVAR=DSUM/(DN-1.0D0)
18245      DSD=0.0D0
18246      IF(DVAR.GT.0.0D0)DSD=DSQRT(DVAR)
18247      XSD=DSD
18248C
18249C               **************************************************
18250C               **  STEP 3--                                    **
18251C               **  COMPUTE THE CPKM RATIO                      **
18252C               **************************************************
18253C
18254      DUSL=DBLE(ENGUSL)
18255      DLSL=DBLE(ENGLSL)
18256      DTARG=DBLE(TARGET)
18257C
18258      DUPPER=DUSL-DMEAN
18259      DLOWER=DMEAN-DLSL
18260C
18261      DNUM=DUPPER
18262      IF(DLOWER.LT.DUPPER)DNUM=DLOWER
18263      IF(DNUM.LE.0.0D0)DNUM=0.0D0
18264C
18265      DDEN=3.0*DSQRT(DSD**2 + (DMEAN-DTARG)**2)
18266C
18267      DCPKM=0.0
18268      IF(DDEN.GT.0.0D0)DCPKM=DNUM/DDEN
18269      XCPKM=DCPKM
18270C
18271C     FOLLOWING CONFIDENCE INTERVALS ARE FOR CPK.  HAVEN'T FOUND
18272C     A SOURCE FOR CPKM CONFIDENCE INTERVALS.
18273C
18274CCCCC AN=REAL(N)
18275CCCCC P=0.975
18276CCCCC TERM1=1.0/(9.0*AN)
18277CCCCC TERM2=XCPKM*XCPK/(2.0*(AN-1.0))
18278CCCCC CALL NORPPF(P,PPF)
18279CCCCC XLCL=XCPKM - PPF*SQRT(TERM1 + TERM2)
18280CCCCC XUCL=XCPKM + PPF*SQRT(TERM1 + TERM2)
18281C
18282C               *******************************
18283C               **  STEP 3--                 **
18284C               **  WRITE OUT A LINE         **
18285C               **  OF SUMMARY INFORMATION.  **
18286C               *******************************
18287C
18288      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
18289        WRITE(ICOUT,999)
18290        CALL DPWRST('XXX','BUG ')
18291        WRITE(ICOUT,811)N,XCPKM
18292  811   FORMAT('THE CPKM OF THE ',I8,' OBSERVATIONS = ',G15.7)
18293        CALL DPWRST('XXX','BUG ')
18294      ENDIF
18295C
18296C               *****************
18297C               **  STEP 90--  **
18298C               **  EXIT.      **
18299C               *****************
18300C
18301 9000 CONTINUE
18302      IF(IBUGA3.EQ.'ON')THEN
18303        WRITE(ICOUT,999)
18304        CALL DPWRST('XXX','BUG ')
18305        WRITE(ICOUT,9011)
18306 9011   FORMAT('***** AT THE END       OF CPKM--')
18307        CALL DPWRST('XXX','BUG ')
18308        WRITE(ICOUT,9012)IBUGA3,IERROR
18309 9012   FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
18310        CALL DPWRST('XXX','BUG ')
18311        WRITE(ICOUT,9014)DMEAN,DSD
18312 9014   FORMAT('DMEAN,DSD = ',2G15.7)
18313        CALL DPWRST('XXX','BUG ')
18314        WRITE(ICOUT,9016)DUSL,DLSL,DUPPER,DLOWER
18315 9016   FORMAT('DUSL,DLSL,DUPPER,DLOWER = ',4G15.7)
18316        CALL DPWRST('XXX','BUG ')
18317        WRITE(ICOUT,9017)DNUM,DDEN,DCPKM,XCPKM
18318 9017   FORMAT('DNUM,DDEN,DCPKM,XCPK = ',4G15.7)
18319        CALL DPWRST('XXX','BUG ')
18320      ENDIF
18321C
18322      RETURN
18323      END
18324      SUBROUTINE CPL(X,N,ENGLSL,ENGUSL,IWRITE,XCPL,XLCL,XUCL,
18325     1               IBUGA3,IERROR)
18326C
18327C     PURPOSE--THIS SUBROUTINE COMPUTES THE
18328C              SAMPLE CPL (PROCESS CAPABILITY INDEX)
18329C              OF THE DATA IN THE INPUT VECTOR X.
18330C              CPL = NUMERATOR/DENOMINATOR
18331C              WHERE NUMERATOR = XBAR - LOWER SPEC LIMIT
18332C              AND DENOMINATOR = 3 * SIGMA
18333C     NOTE--CPL IS A VARIATION OF CPL WHEN YOU ARE ONLY
18334C           INTERESTED IN THE LOWER SPEC LIMIT.
18335C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
18336C                                (UNSORTED OR SORTED) OBSERVATIONS.
18337C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
18338C                                IN THE VECTOR X.
18339C                     --ENGLSL = LOWER (ENGINEERING) SPEC LIMIT
18340C                     --ENGUSL = UPPER (ENGINEERING) SPEC LIMIT
18341C     OUTPUT ARGUMENTS--CPL    = THE SINGLE PRECISION VALUE OF THE
18342C                                COMPUTED SAMPLE CPL
18343C                     --XLCL   = LOWER 95% CONFIDENCE LEVEL
18344C                     --XUCL   = UPPER 95% CONFIDENCE LEVEL
18345C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
18346C             SAMPLE CPL INDEX
18347C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
18348C                   OF N FOR THIS SUBROUTINE.
18349C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
18350C     FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT.
18351C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
18352C     LANGUAGE--ANSI FORTRAN (1977)
18353C     REFERENCES--R&M 2000 AIR FORCE MANUAL
18354C     WRITTEN BY--JAMES J. FILLIBEN
18355C                 STATISTICAL ENGINEERING DIVISION
18356C                 INFORMATION TECHNOLOGY LABORATORY
18357C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
18358C                 GAITHERSBURG, MD 20899
18359C                 PHONE--301-975-2855
18360C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
18361C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
18362C     LANGUAGE--ANSI FORTRAN (1977)
18363C     VERSION NUMBER--2001.4
18364C     ORIGINAL VERSION--APRIL     2001.
18365C
18366C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
18367C
18368      CHARACTER*4 IWRITE
18369      CHARACTER*4 IBUGA3
18370      CHARACTER*4 IERROR
18371C
18372      CHARACTER*4 ISUBN1
18373      CHARACTER*4 ISUBN2
18374C
18375C---------------------------------------------------------------------
18376C
18377      DOUBLE PRECISION DN
18378      DOUBLE PRECISION DX
18379      DOUBLE PRECISION DSUM
18380      DOUBLE PRECISION DMEAN
18381      DOUBLE PRECISION DVAR
18382      DOUBLE PRECISION DSD
18383C
18384      DOUBLE PRECISION DUSL
18385      DOUBLE PRECISION DLSL
18386      DOUBLE PRECISION DUPPER
18387      DOUBLE PRECISION DLOWER
18388      DOUBLE PRECISION DNUM
18389      DOUBLE PRECISION DDEN
18390      DOUBLE PRECISION DCPL
18391C
18392      DIMENSION X(*)
18393C
18394C---------------------------------------------------------------------
18395C
18396      INCLUDE 'DPCOP2.INC'
18397C
18398C-----START POINT-----------------------------------------------------
18399C
18400      ISUBN1='CPL '
18401      ISUBN2='    '
18402C
18403      IERROR='NO'
18404C
18405      DMEAN=0.0D0
18406C
18407      IF(IBUGA3.EQ.'OFF')GOTO90
18408      WRITE(ICOUT,999)
18409  999 FORMAT(1X)
18410      CALL DPWRST('XXX','BUG ')
18411      WRITE(ICOUT,51)
18412   51 FORMAT('***** AT THE BEGINNING OF CPL--')
18413      CALL DPWRST('XXX','BUG ')
18414      WRITE(ICOUT,52)IBUGA3
18415   52 FORMAT('IBUGA3 = ',A4)
18416      CALL DPWRST('XXX','BUG ')
18417      WRITE(ICOUT,53)N
18418   53 FORMAT('N = ',I8)
18419      CALL DPWRST('XXX','BUG ')
18420      WRITE(ICOUT,54)ENGUSL,ENGLSL
18421   54 FORMAT('ENGUSL,ENGLSL = ',2E15.7)
18422      CALL DPWRST('XXX','BUG ')
18423      DO55I=1,N
18424      WRITE(ICOUT,56)I,X(I)
18425   56 FORMAT('I,X(I) = ',I8,E15.7)
18426      CALL DPWRST('XXX','BUG ')
18427   55 CONTINUE
18428   90 CONTINUE
18429C
18430C               ********************************************
18431C               **  COMPUTE PROCESS CAPABILITY INDEX CPL  **
18432C               ********************************************
18433C
18434C               ********************************************
18435C               **  STEP 1--                              **
18436C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
18437C               ********************************************
18438C
18439      AN=N
18440C
18441      IF(N.GE.1)GOTO119
18442      IERROR='YES'
18443      WRITE(ICOUT,999)
18444      CALL DPWRST('XXX','BUG ')
18445      WRITE(ICOUT,111)
18446  111 FORMAT('***** ERROR IN CPL--')
18447      CALL DPWRST('XXX','BUG ')
18448      WRITE(ICOUT,112)
18449  112 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
18450      CALL DPWRST('XXX','BUG ')
18451      WRITE(ICOUT,113)
18452  113 FORMAT('      IN THE VARIABLE FOR WHICH')
18453      CALL DPWRST('XXX','BUG ')
18454      WRITE(ICOUT,114)
18455  114 FORMAT('      THE CPL STATISTIC IS TO BE COMPUTED')
18456      CALL DPWRST('XXX','BUG ')
18457      WRITE(ICOUT,115)
18458  115 FORMAT('      MUST BE 1 OR LARGER.')
18459      CALL DPWRST('XXX','BUG ')
18460      WRITE(ICOUT,116)
18461  116 FORMAT('      SUCH WAS NOT THE CASE HERE.')
18462      CALL DPWRST('XXX','BUG ')
18463      WRITE(ICOUT,117)N
18464  117 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
18465     1'.')
18466      CALL DPWRST('XXX','BUG ')
18467      GOTO9000
18468  119 CONTINUE
18469C
18470      IF(N.EQ.1)GOTO120
18471      GOTO129
18472  120 CONTINUE
18473      XSD=0.0
18474      GOTO9000
18475  129 CONTINUE
18476C
18477      HOLD=X(1)
18478      DO135I=2,N
18479      IF(X(I).NE.HOLD)GOTO139
18480  135 CONTINUE
18481      XSD=0.0
18482      GOTO9000
18483  139 CONTINUE
18484C
18485C               ***************************************
18486C               **  STEP 2--                         **
18487C               **  COMPUTE THE STANDARD DEVIATION.  **
18488C               ***************************************
18489C
18490      DN=N
18491      DSUM=0.0D0
18492      DO200I=1,N
18493      DX=X(I)
18494      DSUM=DSUM+DX
18495  200 CONTINUE
18496      DMEAN=DSUM/DN
18497C
18498      DSUM=0.0D0
18499      DO300I=1,N
18500      DX=X(I)
18501      DSUM=DSUM+(DX-DMEAN)**2
18502  300 CONTINUE
18503      DVAR=DSUM/(DN-1.0D0)
18504      DSD=0.0D0
18505      IF(DVAR.GT.0.0D0)DSD=DSQRT(DVAR)
18506      XSD=DSD
18507C
18508C               **************************************************
18509C               **  STEP 3--                                    **
18510C               **  COMPUTE THE CPL RATIO                       **
18511C               **************************************************
18512C
18513      DUSL=ENGUSL
18514      DLSL=ENGLSL
18515C
18516      DUPPER=DUSL-DMEAN
18517      DLOWER=DMEAN-DLSL
18518C
18519      DNUM=DLOWER
18520C
18521      DDEN=3.0*DSD
18522C
18523      DCPL=0.0D0
18524      IF(DDEN.GT.0.0D0)DCPL=DNUM/DDEN
18525      XCPL=DCPL
18526C
18527      AN=REAL(N)
18528      P=0.975
18529      CALL NORPPF(P,PPF)
18530      XLCL=0.0
18531      XUCL=0.0
18532      IF(N.GT.1)THEN
18533        XLCL=XCPL - PPF*SQRT((1.0/(9.0*AN)) + XCPL/(2.0*(AN-1.0)))
18534        XUCL=XCPL + PPF*SQRT((1.0/(9.0*AN)) + XCPL/(2.0*(AN-1.0)))
18535      ENDIF
18536C
18537C               *******************************
18538C               **  STEP 3--                 **
18539C               **  WRITE OUT A LINE         **
18540C               **  OF SUMMARY INFORMATION.  **
18541C               *******************************
18542C
18543      IF(IFEEDB.EQ.'OFF')GOTO890
18544      IF(IWRITE.EQ.'OFF')GOTO890
18545      WRITE(ICOUT,999)
18546      CALL DPWRST('XXX','BUG ')
18547      WRITE(ICOUT,811)N,XCPL
18548  811 FORMAT('THE CPK OF THE ',I8,' OBSERVATIONS = ',
18549     1E15.7)
18550      CALL DPWRST('XXX','BUG ')
18551  890 CONTINUE
18552C
18553C               *****************
18554C               **  STEP 90--  **
18555C               **  EXIT.      **
18556C               *****************
18557C
18558 9000 CONTINUE
18559      IF(IBUGA3.EQ.'OFF')GOTO9090
18560      WRITE(ICOUT,999)
18561      CALL DPWRST('XXX','BUG ')
18562      WRITE(ICOUT,9011)
18563 9011 FORMAT('***** AT THE END       OF CPL--')
18564      CALL DPWRST('XXX','BUG ')
18565      WRITE(ICOUT,9012)IBUGA3,IERROR
18566 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
18567      CALL DPWRST('XXX','BUG ')
18568      WRITE(ICOUT,9013)N
18569 9013 FORMAT('N = ',I8)
18570      CALL DPWRST('XXX','BUG ')
18571      WRITE(ICOUT,9014)DMEAN
18572 9014 FORMAT('DMEAN = ',D15.7)
18573      CALL DPWRST('XXX','BUG ')
18574      WRITE(ICOUT,9015)DSD
18575 9015 FORMAT('DSD = ',E15.7)
18576      CALL DPWRST('XXX','BUG ')
18577      WRITE(ICOUT,9016)DUSL,DLSL,DUPPER,DLOWER
18578 9016 FORMAT('DUSL,DLSL,DUPPER,DLOWER = ',4D15.7)
18579      CALL DPWRST('XXX','BUG ')
18580      WRITE(ICOUT,9017)DNUM,DDEN,DCPL,XCPL
18581 9017 FORMAT('DNUM,DDEN,DCPL,XCPL = ',3D15.7,E15.7)
18582      CALL DPWRST('XXX','BUG ')
18583 9090 CONTINUE
18584C
18585      RETURN
18586      END
18587      SUBROUTINE CPM(X,N,ENGLSL,ENGUSL,TARGET,IWRITE,XCPM,XLCL,XUCL,
18588     1               IBUGA3,IERROR)
18589C
18590C     PURPOSE--THIS SUBROUTINE COMPUTES THE SAMPLE CPM (PROCESS
18591C              CAPABILITY INDEX) OF THE DATA IN THE INPUT VECTOR X.
18592C
18593C                 CPM = (USL - LSL)/(6*SQRT(S**2+(XBAR-TARGET)**2))
18594C
18595C     NOTE--CPM IS A MEASURE OF PROCESS ACCURACY--
18596C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
18597C                                (UNSORTED OR SORTED) OBSERVATIONS.
18598C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
18599C                                IN THE VECTOR X.
18600C                     --ENGLSL = LOWER (ENGINEERING) SPEC LIMIT
18601C                     --ENGUSL = UPPER (ENGINEERING) SPEC LIMIT
18602C                     --TARGET = TARGET (ENGINEERING) SPEC LIMIT
18603C     OUTPUT ARGUMENTS--XCPM   = THE SINGLE PRECISION VALUE OF THE
18604C                                COMPUTED SAMPLE CPM
18605C                     --XLCL   = LOWER 95% CONFIDENCE INTERVAL
18606C                     --XUCL   = UPPER 95% CONFIDENCE INTERVAL
18607C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE SAMPLE CPM INDEX
18608C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
18609C                   OF N FOR THIS SUBROUTINE.
18610C     OTHER DATAPAC   SUBROUTINES NEEDED--MEAN AND SD.
18611C     FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT.
18612C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
18613C     LANGUAGE--ANSI FORTRAN (1977)
18614C     REFERENCES--NORMA HUBELE, ARIZONA STATE
18615C               --CHEN AND DING (2001), "A NEW PROCESS CAPABILITY
18616C                 INDEX FOR NON-NORMAL DISTRIBUTIONS", INTERNATIONAL
18617C                 JOURNAL OF QUALITY & RELIABILITY MANAGEMENT,
18618C                 VOL. 18, NO. 7, PP. 762-770.
18619C     WRITTEN BY--JAMES J. FILLIBEN
18620C                 STATISTICAL ENGINEERING DIVISION
18621C                 INFORMATION TECHNOLOGY LABORATORY
18622C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
18623C                 GAITHERSBURG, MD 20899
18624C                 PHONE--301-975-2899
18625C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
18626C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
18627C     LANGUAGE--ANSI FORTRAN (1977)
18628C     VERSION NUMBER--98.11
18629C     ORIGINAL VERSION--NOVEMBER  1998.
18630C     UPDATED         --APRIL     2001. ADD 95% CONFIDENCE LIMITS
18631C
18632C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
18633C
18634      CHARACTER*4 IWRITE
18635      CHARACTER*4 IBUGA3
18636      CHARACTER*4 IERROR
18637C
18638      CHARACTER*4 ISUBN1
18639      CHARACTER*4 ISUBN2
18640C
18641C---------------------------------------------------------------------
18642C
18643      DOUBLE PRECISION DN
18644      DOUBLE PRECISION DX
18645      DOUBLE PRECISION DSUM
18646      DOUBLE PRECISION DMEAN
18647      DOUBLE PRECISION DVAR
18648      DOUBLE PRECISION DSD
18649C
18650      DOUBLE PRECISION DUSL
18651      DOUBLE PRECISION DLSL
18652      DOUBLE PRECISION DTARG
18653      DOUBLE PRECISION DNUM
18654      DOUBLE PRECISION DDEN
18655      DOUBLE PRECISION DCPM
18656C
18657      DIMENSION X(*)
18658C
18659C---------------------------------------------------------------------
18660C
18661      INCLUDE 'DPCOP2.INC'
18662C
18663C-----START POINT-----------------------------------------------------
18664C
18665      ISUBN1='CPM '
18666      ISUBN2='    '
18667      IERROR='NO'
18668C
18669      XCPM=0.0
18670C
18671      IF(IBUGA3.EQ.'ON')THEN
18672        WRITE(ICOUT,999)
18673  999   FORMAT(1X)
18674        CALL DPWRST('XXX','BUG ')
18675        WRITE(ICOUT,51)
18676   51   FORMAT('***** AT THE BEGINNING OF CPM--')
18677        CALL DPWRST('XXX','BUG ')
18678        WRITE(ICOUT,52)IBUGA3,N,ENGUSL,ENGLSL,TARGET
18679   52   FORMAT('IBUGA3,N,ENGUSL,ENGLSL,TARGET = ',A4,2X,I8,3G15.7)
18680        CALL DPWRST('XXX','BUG ')
18681        DO55I=1,N
18682          WRITE(ICOUT,56)I,X(I)
18683   56     FORMAT('I,X(I) = ',I8,G15.7)
18684          CALL DPWRST('XXX','BUG ')
18685   55   CONTINUE
18686      ENDIF
18687C
18688C               ********************************************
18689C               **  COMPUTE PROCESS CAPABILITY INDEX CPM  **
18690C               ********************************************
18691C
18692C               ********************************************
18693C               **  STEP 1--                              **
18694C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
18695C               ********************************************
18696C
18697      AN=N
18698C
18699      IF(N.LT.1)THEN
18700        IERROR='YES'
18701        WRITE(ICOUT,999)
18702        CALL DPWRST('XXX','BUG ')
18703        WRITE(ICOUT,111)
18704  111   FORMAT('***** ERROR IN CPM--')
18705        CALL DPWRST('XXX','BUG ')
18706        WRITE(ICOUT,112)
18707  112   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ',
18708     1         'VARIABLE IS NON-POSITIVE.')
18709        CALL DPWRST('XXX','BUG ')
18710        WRITE(ICOUT,117)N
18711  117   FORMAT('      THE NUMBER OF OBSERVATIONS = ',I8,'.')
18712        CALL DPWRST('XXX','BUG ')
18713        GOTO9000
18714      ELSEIF(N.EQ.1)THEN
18715        GOTO9000
18716      ENDIF
18717C
18718      HOLD=X(1)
18719      DO135I=2,N
18720        IF(X(I).NE.HOLD)GOTO139
18721  135 CONTINUE
18722      GOTO9000
18723  139 CONTINUE
18724C
18725C               ***************************************
18726C               **  STEP 2--                         **
18727C               **  COMPUTE THE STANDARD DEVIATION.  **
18728C               ***************************************
18729C
18730      DN=N
18731      DSUM=0.0D0
18732      DO200I=1,N
18733        DX=X(I)
18734        DSUM=DSUM+DX
18735  200 CONTINUE
18736      DMEAN=DSUM/DN
18737C
18738      DSUM=0.0D0
18739      DO300I=1,N
18740        DX=X(I)
18741        DSUM=DSUM+(DX-DMEAN)**2
18742  300 CONTINUE
18743      DVAR=DSUM/(DN-1.0D0)
18744      DSD=0.0D0
18745      IF(DVAR.GT.0.0D0)DSD=DSQRT(DVAR)
18746      XMEAN=DMEAN
18747      XSD=DSD
18748C
18749C               **************************************************
18750C               **  STEP 3--                                    **
18751C               **  COMPUTE THE CPM RATIO                       **
18752C               **************************************************
18753C
18754      DUSL=ENGUSL
18755      DLSL=ENGLSL
18756      DTARG=TARGET
18757C
18758      DNUM=DUSL-DLSL
18759      DDEN=6.0D0*DSQRT(DSD**2 + (DMEAN-DTARG)**2)
18760C
18761      DCPM=0.0
18762      IF(DDEN.GT.0.0D0)DCPM=DNUM/DDEN
18763      XCPM=DCPM
18764C
18765      XLCL=0.0
18766      XUCL=0.0
18767      AN=REAL(N)
18768      NV=N-1
18769      AV=REAL(NV)
18770      P=0.975
18771      CALL CHSPPF(P,NV,PPF)
18772      IF((PPF/AV).GT.0.0)XUCL=XCPM*SQRT(PPF/AV)
18773      P=0.025
18774      CALL CHSPPF(P,NV,PPF)
18775      IF((PPF/AV).GT.0.0)XLCL=XCPM*SQRT(PPF/AV)
18776C
18777C               *******************************
18778C               **  STEP 3--                 **
18779C               **  WRITE OUT A LINE         **
18780C               **  OF SUMMARY INFORMATION.  **
18781C               *******************************
18782C
18783      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
18784        WRITE(ICOUT,999)
18785        CALL DPWRST('XXX','BUG ')
18786        WRITE(ICOUT,811)N,XCPM
18787  811   FORMAT('THE CPM OF THE ',I8,' OBSERVATIONS = ',G15.7)
18788        CALL DPWRST('XXX','BUG ')
18789      ENDIF
18790C
18791C               *****************
18792C               **  STEP 90--  **
18793C               **  EXIT.      **
18794C               *****************
18795C
18796 9000 CONTINUE
18797      IF(IBUGA3.EQ.'ON')THEN
18798        WRITE(ICOUT,999)
18799        CALL DPWRST('XXX','BUG ')
18800        WRITE(ICOUT,9011)
18801 9011   FORMAT('***** AT THE END       OF CPM--')
18802        CALL DPWRST('XXX','BUG ')
18803        WRITE(ICOUT,9012)IBUGA3,IERROR
18804 9012   FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
18805        CALL DPWRST('XXX','BUG ')
18806        WRITE(ICOUT,9014)DMEAN,DSD,DUSL,DLSL
18807 9014   FORMAT('DMEAN,DSD,DUSL,DLSL = ',4G15.7)
18808        CALL DPWRST('XXX','BUG ')
18809        WRITE(ICOUT,9017)DNUM,DDEN,DCPM,XCPM
18810 9017   FORMAT('DNUM,DDEN,DCPM,XCPM = ',4G15.7)
18811        CALL DPWRST('XXX','BUG ')
18812      ENDIF
18813C
18814      RETURN
18815      END
18816      SUBROUTINE CPMK(X,N,ENGLSL,ENGUSL,TARGET,IWRITE,XCPMK,XLCL,XUCL,
18817     1                IBUGA3,IERROR)
18818C
18819C     PURPOSE--THIS SUBROUTINE COMPUTES THE SAMPLE CPMK (PROCESS
18820C              CAPABILITY INDEX) OF THE DATA IN THE INPUT VECTOR X.
18821C
18822C                 CPMK = MIN(USL-MEAN,MEAN-LSL)/
18823C                        {3*SQRT(S**2 +(MEAN-TARGET)**2)}
18824C
18825C     NOTE--CPMK IS A MEASURE OF PROCESS ACCURACY--
18826C           COMBINING BOTH PRECISION AND UNBIASEDNESS.
18827C     NOTE--THE CPMK INDEX IS A MEASURE WHICH TAKES ON THE VALUES 0 TO
18828C           INFINITY.  A GOOD PROCESS YIELDS VALUES OF CPMK WHICH ARE
18829C           LARGE (ABOVE 2); VALUES OF CPMK FROM 0.5 TO 1.0 ARE TYPICAL.
18830C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
18831C                                (UNSORTED OR SORTED) OBSERVATIONS.
18832C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
18833C                                IN THE VECTOR X.
18834C                     --ENGLSL = LOWER (ENGINEERING) SPEC LIMIT
18835C                     --ENGUSL = UPPER (ENGINEERING) SPEC LIMIT
18836C                     --TARGET = TARGET VALUE (ENGINEERING)
18837C     OUTPUT ARGUMENTS--CPMK   = THE SINGLE PRECISION VALUE OF THE
18838C                                COMPUTED SAMPLE CPMK
18839C                     --XLCL   = LOWER 95% CONFIDENCE LEVEL
18840C                     --XUCL   = UPPER 95% CONFIDENCE LEVEL
18841C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
18842C             SAMPLE CPMK INDEX
18843C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
18844C                   OF N FOR THIS SUBROUTINE.
18845C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
18846C     FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT.
18847C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
18848C     LANGUAGE--ANSI FORTRAN (1977)
18849C     REFERENCES--CHEN AND DING (2001), "A NEW PROCESS CAPABILITY
18850C                 INDEX FOR NON-NORMAL DISTRIBUTIONS", INTERNATIONAL
18851C                 JOURNAL OF QUALITY & RELIABILITY MANAGEMENT,
18852C                 VOL. 18, NO. 7, PP. 762-770.
18853C     WRITTEN BY--ALAN HECKERT
18854C                 STATISTICAL ENGINEERING DIVISION
18855C                 INFORMATION TECHNOLOGY LABORATORY
18856C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
18857C                 GAITHERSBURG, MD 20899
18858C                 PHONE--301-975-2899
18859C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
18860C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
18861C     LANGUAGE--ANSI FORTRAN (1977)
18862C     VERSION NUMBER--2015.4
18863C     ORIGINAL VERSION--APRIL     2015.
18864C
18865C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
18866C
18867      CHARACTER*4 IWRITE
18868      CHARACTER*4 IBUGA3
18869      CHARACTER*4 IERROR
18870C
18871      CHARACTER*4 ISUBN1
18872      CHARACTER*4 ISUBN2
18873C
18874C---------------------------------------------------------------------
18875C
18876      DOUBLE PRECISION DN
18877      DOUBLE PRECISION DX
18878      DOUBLE PRECISION DSUM
18879      DOUBLE PRECISION DMEAN
18880      DOUBLE PRECISION DVAR
18881      DOUBLE PRECISION DSD
18882C
18883      DOUBLE PRECISION DUSL
18884      DOUBLE PRECISION DLSL
18885      DOUBLE PRECISION DTARG
18886      DOUBLE PRECISION DUPPER
18887      DOUBLE PRECISION DLOWER
18888      DOUBLE PRECISION DNUM
18889      DOUBLE PRECISION DDEN
18890      DOUBLE PRECISION DCPMK
18891C
18892      DIMENSION X(*)
18893C
18894C---------------------------------------------------------------------
18895C
18896      INCLUDE 'DPCOP2.INC'
18897C
18898C-----START POINT-----------------------------------------------------
18899C
18900      ISUBN1='CPMK'
18901      ISUBN2='    '
18902      IERROR='NO'
18903C
18904      XCPMK=0.0
18905      XCL=CPUMIN
18906      XUL=CPUMIN
18907C
18908      IF(IBUGA3.EQ.'ON')THEN
18909        WRITE(ICOUT,999)
18910  999   FORMAT(1X)
18911        CALL DPWRST('XXX','BUG ')
18912        WRITE(ICOUT,51)
18913   51   FORMAT('***** AT THE BEGINNING OF CPMK--')
18914        CALL DPWRST('XXX','BUG ')
18915        WRITE(ICOUT,52)IBUGA3,N,ENGUSL,ENGLSL,XLCL,XUCL
18916   52   FORMAT('IBUGA3,N,ENGUSL,ENGLSL,XLCL,XUCL = ',A4,2X,I8,4G15.7)
18917        CALL DPWRST('XXX','BUG ')
18918        DO55I=1,N
18919          WRITE(ICOUT,56)I,X(I)
18920   56     FORMAT('I,X(I) = ',I8,G15.7)
18921          CALL DPWRST('XXX','BUG ')
18922   55   CONTINUE
18923      ENDIF
18924C
18925C               ********************************************
18926C               **  COMPUTE PROCESS CAPABILITY INDEX CPMK  **
18927C               ********************************************
18928C
18929C               ********************************************
18930C               **  STEP 1--                              **
18931C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
18932C               ********************************************
18933C
18934      AN=N
18935C
18936      IF(N.LT.1)THEN
18937        IERROR='YES'
18938        WRITE(ICOUT,999)
18939        CALL DPWRST('XXX','BUG ')
18940        WRITE(ICOUT,111)
18941  111   FORMAT('***** ERROR IN CPMK--')
18942        CALL DPWRST('XXX','BUG ')
18943        WRITE(ICOUT,112)
18944  112   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ',
18945     1         'VARIABLE IS NON-POSITIVE.')
18946        CALL DPWRST('XXX','BUG ')
18947        WRITE(ICOUT,117)N
18948  117   FORMAT('      THE NUMBER OF OBSERVATIONS = ',I8,'.')
18949        CALL DPWRST('XXX','BUG ')
18950        GOTO9000
18951      ELSEIF(N.EQ.1)THEN
18952        GOTO9000
18953      ENDIF
18954C
18955      HOLD=X(1)
18956      DO135I=2,N
18957        IF(X(I).NE.HOLD)GOTO139
18958  135 CONTINUE
18959      GOTO9000
18960  139 CONTINUE
18961C
18962C               ***************************************
18963C               **  STEP 2--                         **
18964C               **  COMPUTE THE STANDARD DEVIATION.  **
18965C               ***************************************
18966C
18967      DN=N
18968      DSUM=0.0D0
18969      DO200I=1,N
18970        DX=X(I)
18971        DSUM=DSUM+DX
18972  200 CONTINUE
18973      DMEAN=DSUM/DN
18974C
18975      DSUM=0.0D0
18976      DO300I=1,N
18977        DX=X(I)
18978        DSUM=DSUM+(DX-DMEAN)**2
18979  300 CONTINUE
18980      DVAR=DSUM/(DN-1.0D0)
18981      DSD=0.0D0
18982      IF(DVAR.GT.0.0D0)DSD=DSQRT(DVAR)
18983      XSD=DSD
18984C
18985C               **************************************************
18986C               **  STEP 3--                                    **
18987C               **  COMPUTE THE CPMK RATIO                      **
18988C               **************************************************
18989C
18990      DUSL=DBLE(ENGUSL)
18991      DLSL=DBLE(ENGLSL)
18992      DTARG=DBLE(TARGET)
18993C
18994      DUPPER=DUSL-DMEAN
18995      DLOWER=DMEAN-DLSL
18996C
18997      DNUM=DUPPER
18998      IF(DLOWER.LT.DUPPER)DNUM=DLOWER
18999      IF(DNUM.LE.0.0D0)DNUM=0.0D0
19000C
19001      DDEN=3.0*DSQRT(DSD**2 + (DMEAN-DTARG)**2)
19002C
19003      DCPMK=0.0
19004      IF(DDEN.GT.0.0D0)DCPMK=DNUM/DDEN
19005      XCPMK=DCPMK
19006C
19007C     FOLLOWING CONFIDENCE INTERVALS ARE FOR CPK.  HAVEN'T FOUND
19008C     A SOURCE FOR CPMK CONFIDENCE INTERVALS.
19009C
19010CCCCC AN=REAL(N)
19011CCCCC P=0.975
19012CCCCC TERM1=1.0/(9.0*AN)
19013CCCCC TERM2=XCPMK*XCPK/(2.0*(AN-1.0))
19014CCCCC CALL NORPPF(P,PPF)
19015CCCCC XLCL=XCPMK - PPF*SQRT(TERM1 + TERM2)
19016CCCCC XUCL=XCPMK + PPF*SQRT(TERM1 + TERM2)
19017C
19018C               *******************************
19019C               **  STEP 3--                 **
19020C               **  WRITE OUT A LINE         **
19021C               **  OF SUMMARY INFORMATION.  **
19022C               *******************************
19023C
19024      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
19025        WRITE(ICOUT,999)
19026        CALL DPWRST('XXX','BUG ')
19027        WRITE(ICOUT,811)N,XCPMK
19028  811   FORMAT('THE CPMK OF THE ',I8,' OBSERVATIONS = ',G15.7)
19029        CALL DPWRST('XXX','BUG ')
19030      ENDIF
19031C
19032C               *****************
19033C               **  STEP 90--  **
19034C               **  EXIT.      **
19035C               *****************
19036C
19037 9000 CONTINUE
19038      IF(IBUGA3.EQ.'ON')THEN
19039        WRITE(ICOUT,999)
19040        CALL DPWRST('XXX','BUG ')
19041        WRITE(ICOUT,9011)
19042 9011   FORMAT('***** AT THE END       OF CPMK--')
19043        CALL DPWRST('XXX','BUG ')
19044        WRITE(ICOUT,9012)IBUGA3,IERROR
19045 9012   FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
19046        CALL DPWRST('XXX','BUG ')
19047        WRITE(ICOUT,9014)DMEAN,DSD
19048 9014   FORMAT('DMEAN,DSD = ',2G15.7)
19049        CALL DPWRST('XXX','BUG ')
19050        WRITE(ICOUT,9016)DUSL,DLSL,DUPPER,DLOWER
19051 9016   FORMAT('DUSL,DLSL,DUPPER,DLOWER = ',4G15.7)
19052        CALL DPWRST('XXX','BUG ')
19053        WRITE(ICOUT,9017)DNUM,DDEN,DCPMK,XCPMK
19054 9017   FORMAT('DNUM,DDEN,DCPMK,XCPMK = ',4G15.7)
19055        CALL DPWRST('XXX','BUG ')
19056      ENDIF
19057C
19058      RETURN
19059      END
19060      COMPLEX FUNCTION CPSI(ZIN)
19061C***BEGIN PROLOGUE  CPSI
19062C***DATE WRITTEN   780501   (YYMMDD)
19063C***REVISION DATE  820801   (YYMMDD)
19064C***CATEGORY NO.  C7C
19065C***KEYWORDS  COMPLEX,DIGAMMA FUNCTION,PSI FUNCTION,SPECIAL FUNCTION
19066C***AUTHOR  FULLERTON, W., (LANL)
19067C***PURPOSE  Computes the Psi function of complex argument.
19068C***DESCRIPTION
19069C
19070C PSI(X) calculates the psi (or digamma) function of X.  PSI(X)
19071C is the logarithmic derivative of the gamma function of X.
19072C***REFERENCES  (NONE)
19073C***ROUTINES CALLED  CCOT,R1MACH,XERROR
19074C***END PROLOGUE  CPSI
19075      COMPLEX ZIN, Z, Z2INV, CORR,  CCOT, CLOG
19076C
19077      INCLUDE 'DPCOMC.INC'
19078      INCLUDE 'DPCOP2.INC'
19079C
19080      DIMENSION BERN(13)
19081      DATA BERN( 1) /   .8333333333 3333333 E-1 /
19082      DATA BERN( 2) /  -.8333333333 3333333 E-2 /
19083      DATA BERN( 3) /   .3968253968 2539683 E-2 /
19084      DATA BERN( 4) /  -.4166666666 6666667 E-2 /
19085      DATA BERN( 5) /   .7575757575 7575758 E-2 /
19086      DATA BERN( 6) /  -.2109279609 2796093 E-1 /
19087      DATA BERN( 7) /   .8333333333 3333333 E-1 /
19088      DATA BERN( 8) /  -.4432598039 2156863 E0 /
19089      DATA BERN( 9) /   .3053954330 2701197 E1 /
19090      DATA BERN(10) /  -.2645621212 1212121 E2 /
19091      DATA BERN(11) /   .2814601449 2753623 E3 /
19092      DATA BERN(12) /  -.3454885393 7728938 E4 /
19093      DATA BERN(13) /   .5482758333 3333333 E5 /
19094      DATA PI / 3.141592653 589793 E0 /
19095      DATA NTERM, BOUND, DXREL, RMIN, RBIG / 0, 4*0.0 /
19096C***FIRST EXECUTABLE STATEMENT  CPSI
19097C
19098      CPSI = (0.0, 0.0)
19099C
19100      IF (NTERM.NE.0) GO TO 10
19101      NTERM = INT(-0.30*LOG(R1MACH(3)))
19102C MAYBE BOUND = N*(0.1*EPS)**(-1/(2*N-1)) / (PI*EXP(1))
19103      BOUND = 0.1171*FLOAT(NTERM) *
19104     1  (0.1*R1MACH(3))**(-1.0/(2.0*FLOAT(NTERM)-1.0))
19105      DXREL = SQRT(R1MACH(4))
19106      RMIN = EXP (AMAX1 (LOG(R1MACH(1)), -LOG(R1MACH(2))) + 0.011 )
19107      RBIG = 1.0/R1MACH(3)
19108C
19109 10   Z = ZIN
19110      X = REAL(Z)
19111      Y = AIMAG(Z)
19112      IF (Y.LT.0.0) Z = CONJG(Z)
19113C
19114      CORR = (0.0, 0.0)
19115      CABSZ = CABS(Z)
19116      IF (X.GE.0.0 .AND. CABSZ.GT.BOUND) GO TO 50
19117      IF (X.LT.0.0 .AND. ABS(Y).GT.BOUND) GO TO 50
19118C
19119      IF (CABSZ.LT.BOUND) GO TO 20
19120C
19121C USE THE REFLECTION FORMULA FOR REAL(Z) NEGATIVE, CABS(Z) LARGE, AND
19122C ABS(AIMAG(Y)) SMALL.
19123C
19124      CORR = -PI*CCOT(PI*Z)
19125      Z = 1.0 - Z
19126      GO TO 50
19127C
19128C USE THE RECURSION RELATION FOR CABS(Z) SMALL.
19129C
19130 20   IF (CABSZ.LT.RMIN) THEN
19131CCCCC   CALL XERROR ( 'CPSI    CPSI CALLED WITH Z SO NE
19132CCCCC1AR 0 THAT CPSI OVERFLOWS',      56, 2, 2)
19133        WRITE(ICOUT,102)
19134        CALL DPWRST('XXX','BUG ')
19135        RETURN
19136      ENDIF
19137 102  FORMAT('***** INTERNAL ERROR FROM CPSI: ARGUMENT SO CLOSE',
19138     1' TO ZERO THAT CPSI OVERFLOWS')
19139C
19140      IF (X.GE.(-0.5) .OR. ABS(Y).GT.DXREL) GO TO 30
19141      IF (CABS((Z-AINT(X-0.5))/X).LT.DXREL) THEN
19142CCCCC   CALL XERROR ( 'CPSI    ANSWE
19143CCCCC1R LT HALF PRECISION BECAUSE Z TOO NEAR NEGATIVE INTEGER', 68, 1, 1
19144CCCCC2)
19145        WRITE(ICOUT,202)
19146        CALL DPWRST('XXX','BUG ')
19147        RETURN
19148      ENDIF
19149 202  FORMAT('***** INTERNAL ERROR FROM CPSI: ANSWER LESS THAN HALF',
19150     1' PRECISION BECAUSE ARGUMENT TOO NEAR A NEGATIVE INTEGER')
19151      IF (Y.EQ.0.0 .AND. X.EQ.AINT(X)) THEN
19152CCCCC   CALL XERROR ( 'CPSI    Z IS A NEG
19153CCCCC1ATIVE INTEGER', 31, 3, 2)
19154        WRITE(ICOUT,302)
19155        CALL DPWRST('XXX','BUG ')
19156        RETURN
19157      ENDIF
19158 302  FORMAT('***** INTERNAL ERROR FROM CPSI: ARGUMENT IS A ',
19159     1' NEGATIVE INTEGER')
19160C
19161 30   N = INT(SQRT(BOUND**2-Y**2) - X + 1.0)
19162      DO 40 I=1,N
19163        CORR = CORR - 1.0/Z
19164        Z = Z + 1.0
19165 40   CONTINUE
19166C
19167C NOW EVALUATE THE ASYMPTOTIC SERIES FOR SUITABLY LARGE Z.
19168C
19169 50   IF (CABSZ.GT.RBIG) CPSI = CLOG(Z) + CORR
19170      IF (CABSZ.GT.RBIG) GO TO 70
19171C
19172      CPSI = (0.0, 0.0)
19173      Z2INV = 1.0/Z**2
19174      DO 60 I=1,NTERM
19175        NDX = NTERM + 1 - I
19176        CPSI = BERN(NDX) + Z2INV*CPSI
19177 60   CONTINUE
19178      CPSI = CLOG(Z) - 0.5/Z - CPSI*Z2INV + CORR
19179C
19180 70   IF (Y.LT.0.0) CPSI = CONJG(CPSI)
19181C
19182      RETURN
19183      END
19184      SUBROUTINE CPU(X,N,ENGLSL,ENGUSL,IWRITE,XCPU,XLCL,XUCL,
19185     1               IBUGA3,IERROR)
19186C
19187C     PURPOSE--THIS SUBROUTINE COMPUTES THE
19188C              SAMPLE CPU (PROCESS CAPABILITY INDEX)
19189C              OF THE DATA IN THE INPUT VECTOR X.
19190C              CPU = NUMERATOR/DENOMINATOR
19191C              WHERE NUMERATOR = XBAR + UPPER SPEC LIMIT
19192C              AND DENOMINATOR = 3 * SIGMA
19193C     NOTE--CPU IS A VARIATION OF CPK WHEN YOU ARE ONLY
19194C           INTERESTED IN THE UPPER SPEC LIMIT.
19195C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
19196C                                (UNSORTED OR SORTED) OBSERVATIONS.
19197C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
19198C                                IN THE VECTOR X.
19199C                     --ENGLSL = LOWER (ENGINEERING) SPEC LIMIT
19200C                     --ENGUSL = UPPER (ENGINEERING) SPEC LIMIT
19201C     OUTPUT ARGUMENTS--CPU    = THE SINGLE PRECISION VALUE OF THE
19202C                                COMPUTED SAMPLE CPU
19203C                     --XLCL   = LOWER 95% CONFIDENCE LEVEL
19204C                     --XUCL   = UPPER 95% CONFIDENCE LEVEL
19205C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
19206C             SAMPLE CPU INDEX
19207C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
19208C                   OF N FOR THIS SUBROUTINE.
19209C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
19210C     FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT.
19211C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
19212C     LANGUAGE--ANSI FORTRAN (1977)
19213C     REFERENCES--R&M 2000 AIR FORCE MANUAL
19214C     WRITTEN BY--JAMES J. FILLIBEN
19215C                 STATISTICAL ENGINEERING DIVISION
19216C                 INFORMATION TECHNOLOGY LABORATORY
19217C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
19218C                 GAITHERSBURG, MD 20899
19219C                 PHONE--301-975-2855
19220C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
19221C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
19222C     LANGUAGE--ANSI FORTRAN (1977)
19223C     VERSION NUMBER--2001.4
19224C     ORIGINAL VERSION--APRIL     2001.
19225C
19226C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
19227C
19228      CHARACTER*4 IWRITE
19229      CHARACTER*4 IBUGA3
19230      CHARACTER*4 IERROR
19231C
19232      CHARACTER*4 ISUBN1
19233      CHARACTER*4 ISUBN2
19234C
19235C---------------------------------------------------------------------
19236C
19237      DOUBLE PRECISION DN
19238      DOUBLE PRECISION DX
19239      DOUBLE PRECISION DSUM
19240      DOUBLE PRECISION DMEAN
19241      DOUBLE PRECISION DVAR
19242      DOUBLE PRECISION DSD
19243C
19244      DOUBLE PRECISION DUSL
19245      DOUBLE PRECISION DLSL
19246      DOUBLE PRECISION DUPPER
19247      DOUBLE PRECISION DLOWER
19248      DOUBLE PRECISION DNUM
19249      DOUBLE PRECISION DDEN
19250      DOUBLE PRECISION DCPU
19251C
19252      DIMENSION X(*)
19253C
19254C---------------------------------------------------------------------
19255C
19256      INCLUDE 'DPCOP2.INC'
19257C
19258C-----START POINT-----------------------------------------------------
19259C
19260      ISUBN1='CPU '
19261      ISUBN2='    '
19262      IERROR='NO'
19263C
19264      DMEAN=0.0D0
19265C
19266      IF(IBUGA3.EQ.'OFF')GOTO90
19267      WRITE(ICOUT,999)
19268  999 FORMAT(1X)
19269      CALL DPWRST('XXX','BUG ')
19270      WRITE(ICOUT,51)
19271   51 FORMAT('***** AT THE BEGINNING OF CPU--')
19272      CALL DPWRST('XXX','BUG ')
19273      WRITE(ICOUT,52)IBUGA3
19274   52 FORMAT('IBUGA3 = ',A4)
19275      CALL DPWRST('XXX','BUG ')
19276      WRITE(ICOUT,53)N
19277   53 FORMAT('N = ',I8)
19278      CALL DPWRST('XXX','BUG ')
19279      WRITE(ICOUT,54)ENGUSL,ENGLSL
19280   54 FORMAT('ENGUSL,ENGLSL = ',2E15.7)
19281      CALL DPWRST('XXX','BUG ')
19282      DO55I=1,N
19283      WRITE(ICOUT,56)I,X(I)
19284   56 FORMAT('I,X(I) = ',I8,E15.7)
19285      CALL DPWRST('XXX','BUG ')
19286   55 CONTINUE
19287   90 CONTINUE
19288C
19289C               ********************************************
19290C               **  COMPUTE PROCESS CAPABILITY INDEX CPU  **
19291C               ********************************************
19292C
19293C               ********************************************
19294C               **  STEP 1--                              **
19295C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
19296C               ********************************************
19297C
19298      AN=N
19299C
19300      IF(N.GE.1)GOTO119
19301      IERROR='YES'
19302      WRITE(ICOUT,999)
19303      CALL DPWRST('XXX','BUG ')
19304      WRITE(ICOUT,111)
19305  111 FORMAT('***** ERROR IN CPU--')
19306      CALL DPWRST('XXX','BUG ')
19307      WRITE(ICOUT,112)
19308  112 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
19309      CALL DPWRST('XXX','BUG ')
19310      WRITE(ICOUT,113)
19311  113 FORMAT('      IN THE VARIABLE FOR WHICH')
19312      CALL DPWRST('XXX','BUG ')
19313      WRITE(ICOUT,114)
19314  114 FORMAT('      THE CPU STATISTIC IS TO BE COMPUTED')
19315      CALL DPWRST('XXX','BUG ')
19316      WRITE(ICOUT,115)
19317  115 FORMAT('      MUST BE 1 OR LARGER.')
19318      CALL DPWRST('XXX','BUG ')
19319      WRITE(ICOUT,116)
19320  116 FORMAT('      SUCH WAS NOT THE CASE HERE.')
19321      CALL DPWRST('XXX','BUG ')
19322      WRITE(ICOUT,117)N
19323  117 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
19324     1'.')
19325      CALL DPWRST('XXX','BUG ')
19326      GOTO9000
19327  119 CONTINUE
19328C
19329      IF(N.EQ.1)GOTO120
19330      GOTO129
19331  120 CONTINUE
19332      XSD=0.0
19333      GOTO9000
19334  129 CONTINUE
19335C
19336      HOLD=X(1)
19337      DO135I=2,N
19338      IF(X(I).NE.HOLD)GOTO139
19339  135 CONTINUE
19340      XSD=0.0
19341      GOTO9000
19342  139 CONTINUE
19343C
19344C               ***************************************
19345C               **  STEP 2--                         **
19346C               **  COMPUTE THE STANDARD DEVIATION.  **
19347C               ***************************************
19348C
19349      DN=N
19350      DSUM=0.0D0
19351      DO200I=1,N
19352      DX=X(I)
19353      DSUM=DSUM+DX
19354  200 CONTINUE
19355      DMEAN=DSUM/DN
19356C
19357      DSUM=0.0D0
19358      DO300I=1,N
19359      DX=X(I)
19360      DSUM=DSUM+(DX-DMEAN)**2
19361  300 CONTINUE
19362      DVAR=DSUM/(DN-1.0D0)
19363      DSD=0.0D0
19364      IF(DVAR.GT.0.0D0)DSD=DSQRT(DVAR)
19365      XSD=DSD
19366C
19367C               **************************************************
19368C               **  STEP 3--                                    **
19369C               **  COMPUTE THE CPU RATIO                       **
19370C               **************************************************
19371C
19372      DUSL=ENGUSL
19373      DLSL=ENGLSL
19374C
19375      DUPPER=DUSL-DMEAN
19376      DLOWER=DMEAN-DLSL
19377C
19378      DNUM=DUPPER
19379C
19380      DDEN=3.0*DSD
19381C
19382      DCPU=0.0D0
19383      IF(DDEN.GT.0.0D0)DCPU=DNUM/DDEN
19384      XCPU=DCPU
19385C
19386      AN=REAL(N)
19387      P=0.975
19388      CALL NORPPF(P,PPF)
19389      XLCL=0.0
19390      XUCL=0.0
19391      IF(N.GT.1)THEN
19392        XLCL=XCPU - PPF*SQRT((1.0/(9.0*AN)) + XCPU/(2.0*(AN-1.0)))
19393        XUCL=XCPU + PPF*SQRT((1.0/(9.0*AN)) + XCPU/(2.0*(AN-1.0)))
19394      ENDIF
19395C
19396C               *******************************
19397C               **  STEP 3--                 **
19398C               **  WRITE OUT A LINE         **
19399C               **  OF SUMMARY INFORMATION.  **
19400C               *******************************
19401C
19402      IF(IFEEDB.EQ.'OFF')GOTO890
19403      IF(IWRITE.EQ.'OFF')GOTO890
19404      WRITE(ICOUT,999)
19405      CALL DPWRST('XXX','BUG ')
19406      WRITE(ICOUT,811)N,XCPU
19407  811 FORMAT('THE CPK OF THE ',I8,' OBSERVATIONS = ',
19408     1E15.7)
19409      CALL DPWRST('XXX','BUG ')
19410  890 CONTINUE
19411C
19412C               *****************
19413C               **  STEP 90--  **
19414C               **  EXIT.      **
19415C               *****************
19416C
19417 9000 CONTINUE
19418      IF(IBUGA3.EQ.'OFF')GOTO9090
19419      WRITE(ICOUT,999)
19420      CALL DPWRST('XXX','BUG ')
19421      WRITE(ICOUT,9011)
19422 9011 FORMAT('***** AT THE END       OF CPU--')
19423      CALL DPWRST('XXX','BUG ')
19424      WRITE(ICOUT,9012)IBUGA3,IERROR
19425 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
19426      CALL DPWRST('XXX','BUG ')
19427      WRITE(ICOUT,9013)N
19428 9013 FORMAT('N = ',I8)
19429      CALL DPWRST('XXX','BUG ')
19430      WRITE(ICOUT,9014)DMEAN
19431 9014 FORMAT('DMEAN = ',D15.7)
19432      CALL DPWRST('XXX','BUG ')
19433      WRITE(ICOUT,9015)DSD
19434 9015 FORMAT('DSD = ',E15.7)
19435      CALL DPWRST('XXX','BUG ')
19436      WRITE(ICOUT,9016)DUSL,DLSL,DUPPER,DLOWER
19437 9016 FORMAT('DUSL,DLSL,DUPPER,DLOWER = ',4D15.7)
19438      CALL DPWRST('XXX','BUG ')
19439      WRITE(ICOUT,9017)DNUM,DDEN,DCPU,XCPU
19440 9017 FORMAT('DNUM,DDEN,DCPU,XCPU = ',3D15.7,E15.7)
19441      CALL DPWRST('XXX','BUG ')
19442 9090 CONTINUE
19443C
19444      RETURN
19445      END
19446      SUBROUTINE CPZERO(IN,A,R,T,IFLG,S)
19447C***BEGIN PROLOGUE  CPZERO
19448C***DATE WRITTEN   810223   (YYMMDD)
19449C***REVISION DATE  860227   (YYMMDD)
19450C***CATEGORY NO.  F1A1B
19451C***KEYWORDS  COMPLEX,POLYNOMIAL ROOTS,ROOTS,ZEROES,ZEROS
19452C***AUTHOR  KAHANER, D. K., (NBS)
19453C***PURPOSE  Find the zeros of a polynomial with complex coefficients.
19454C***DESCRIPTION
19455C
19456C      Find the zeros of the complex polynomial
19457C         P(Z)= A(1)*Z**N + A(2)*Z**(N-1) +...+ A(N+1)
19458C
19459C    Input...
19460C       IN = degree of P(Z)
19461C       A = complex vector containing coefficients of P(Z),
19462C            A(I) = coefficient of Z**(N+1-i)
19463C       R = N word complex vector containing initial estimates for zeros
19464C            if these are known.
19465C       T = 4(N+1) word array used for temporary storage
19466C       IFLG = flag to indicate if initial estimates of
19467C              zeros are input.
19468C            If IFLG .EQ. 0, no estimates are input.
19469C            If IFLG .NE. 0, the vector R contains estimates of
19470C               the zeros
19471C       ** WARNING ****** If estimates are input, they must
19472C                         be separated, that is, distinct or
19473C                         not repeated.
19474C       S = an N word array
19475C
19476C    Output...
19477C       R(I) = Ith zero,
19478C       S(I) = bound for R(I) .
19479C       IFLG = error diagnostic
19480C    Error Diagnostics...
19481C       If IFLG .EQ. 0 on return, all is well
19482C       If IFLG .EQ. 1 on return, A(1)=0.0 or N=0 on input
19483C       If IFLG .EQ. 2 on return, the program failed to coverge
19484C                after 25*N iterations.  Best current estimates of the
19485C                zeros are in R(I).  Error bounds are not calculated.
19486C***REFERENCES  (NONE)
19487C***ROUTINES CALLED  CPEVL
19488C***END PROLOGUE  CPZERO
19489C
19490CCCCC APRIL 1996.  MAKE DUMMY DIMENSION "*"
19491CCCCC REAL  S(1)
19492CCCCC COMPLEX R(1),T(1),A(1),PN,TEMP
19493      REAL  S(*)
19494      COMPLEX R(*),T(*),A(*),PN,TEMP,PNTEMP(1),TEMP2(1)
19495C***FIRST EXECUTABLE STATEMENT  CPZERO
19496      IF( IN .LE. 0 .OR. CABS(A(1)) .EQ. 0.0 ) GO TO 30
19497C
19498C       CHECK FOR EASILY OBTAINED ZEROS
19499C
19500      N=IN
19501      N1=N+1
19502      IF(IFLG .NE. 0) GO TO 14
19503    1 CONTINUE
19504      N1=N+1
19505      IF(N .GT. 1) GO TO 2
19506         R(1)=-A(2)/A(1)
19507         S(1)=0.0
19508         RETURN
19509    2 CONTINUE
19510         IF( CABS(A(N1)) .NE. 0.0 ) GO TO 3
19511         R(N)=0.0
19512         S(N)=0.0
19513         N=N-1
19514         GO TO 1
19515C
19516C          IF INITIAL ESTIMATES FOR ZEROS NOT GIVEN, FIND SOME
19517C
19518    3 CONTINUE
19519      TEMP=-A(2)/(A(1)*FLOAT(N))
19520      CALL CPEVL(N,N,A,TEMP,T,T,.FALSE.)
19521      IMAX=N+2
19522      T(N1)=CABS(T(N1))
19523      DO 6 I=2,N1
19524         T(N+I)=-CABS(T(N+2-I))
19525         IF(REAL(T(N+I)) .LT. REAL(T(IMAX))) IMAX=N+I
19526    6 CONTINUE
19527      X=(-REAL(T(IMAX))/REAL(T(N1)))**(1./FLOAT(IMAX-N1))
19528    7 CONTINUE
19529         X=2.*X
19530         CALL CPEVL(N,0,T(N1),CMPLX(X,0.0),PNTEMP,PNTEMP,.FALSE.)
19531         PN=PNTEMP(1)
19532      IF (REAL(PN).LT.0.) GO TO 7
19533      U=.5*X
19534      V=X
19535   10 CONTINUE
19536         X=.5*(U+V)
19537         CALL CPEVL(N,0,T(N1),CMPLX(X,0.0),PNTEMP,PNTEMP,.FALSE.)
19538         PN=PNTEMP(1)
19539         IF (REAL(PN).GT.0.) V=X
19540         IF (REAL(PN).LE.0.) U=X
19541         IF((V-U) .GT. .001*(1.+V)) GO TO 10
19542      DO 13 I=1,N
19543         U=(3.14159265/FLOAT(N))*(.5+2.*FLOAT(I-1))
19544         R(I)=AMAX1(X,.001*CABS(TEMP))*CMPLX(COS(U),SIN(U))+TEMP
19545   13 CONTINUE
19546C
19547C          MAIN ITERATION LOOP STARTS HERE
19548C
19549   14 CONTINUE
19550      NR=0
19551      NMAX=25*N
19552      DO 19 NIT=1,NMAX
19553         DO 18 I=1,N
19554            IF(NIT .NE. 1 .AND. CABS(T(I)) .EQ. 0.) GO TO 18
19555               CALL CPEVL(N,0,A,R(I),PNTEMP,TEMP2,.TRUE.)
19556               PN=PNTEMP(1)
19557               TEMP=TEMP2(1)
19558               IF(ABS(REAL(PN))+ABS(AIMAG(PN)) .GT. REAL(TEMP)+
19559     1              AIMAG(TEMP)) GO TO 16
19560                  T(I)=0.0
19561                  NR=NR+1
19562                  GO TO 18
19563   16          TEMP=A(1)
19564               DO 17 J=1,N
19565                  IF(J .NE. I) TEMP=TEMP*(R(I)-R(J))
19566   17          CONTINUE
19567               T(I)=PN/TEMP
19568   18    CONTINUE
19569         DO 15 I=1,N
19570            R(I)=R(I)-T(I)
19571   15    CONTINUE
19572         IF(NR .EQ. N) GO TO 21
19573   19 CONTINUE
19574      GO TO 26
19575C
19576C          CALCULATE ERROR BOUNDS FOR ZEROS
19577C
19578   21 DO 25 NR=1,N
19579         CALL CPEVL(N,N,A,R(NR),T,T(N+2),.TRUE.)
19580         X=CABS(CMPLX(ABS(REAL(T(1))),ABS(AIMAG(T(1))))+T(N+2))
19581         S(NR)=0.0
19582         DO 23 I=1,N
19583            X=X*FLOAT(N1-I)/FLOAT(I)
19584            TEMP=CMPLX(AMAX1(ABS(REAL(T(I+1)))-REAL(T(N1+I)),0.0),
19585     1           AMAX1(ABS(AIMAG(T(I+1)))-AIMAG(T(N1+I)),0.0))
19586            S(NR)=AMAX1(S(NR),(CABS(TEMP)/X)**(1./FLOAT(I)))
19587   23    CONTINUE
19588         S(NR)=1./S(NR)
19589   25 CONTINUE
19590      IFLG=0
19591      RETURN
19592C        ERROR EXITS
19593   26 CONTINUE
19594      IFLG=2
19595      RETURN
19596   30 CONTINUE
19597      IFLG=1
19598      RETURN
19599      END
19600      SUBROUTINE CRAMER(Y1,Y2,N,IWRITE,XIDTEM,XIDTE2,TEMP1,STAT,
19601     1           IBUGA3,IERROR)
19602C
19603C     PURPOSE--THIS SUBROUTINE COMPUTES CRAMER'S COEFFICIENT
19604C              FOR RXC CONTINGENCY TABLES.  THIS IS
19605C
19606C                  SQRT(T/(N*(Q-1)))
19607C
19608C              WHERE
19609C
19610C                  T = CHI-SQUARE STATISTIC
19611C                    = SUM[i=1 to r][SUM[j=1 to c]
19612C                      [(O(ij)-E(ij))**2/E(ij)]]
19613C
19614C                      O = OBSERVED COUNT
19615C                      E = EXPECTED COUNT
19616C                        = ROW TOTAL*COL TOTAL/GRAND TOTAL
19617C
19618C                  N = TOTAL NUMBER OF OBSERVATIONS
19619C                  Q = MIN(R,C)
19620C
19621C     REFERENCE--CONOVER (1999), "PRACTICAL NONPARAMETRIC
19622C                STATISTICS", THIRD EDITION, WILEY, PP. 229-230.
19623C     NOTE--THIS SUBROUTINE HANDLES THE RAW DATA CASE.  USE
19624C           THE COMMAND
19625C
19626C               LET A = MATRIX CRAMER CONTINGENCY COEFFICENT M
19627C
19628C           IF YOUR DATA CONSISTS OF AN RXC TABLE.
19629C     INPUT  ARGUMENTS--Y1     = THE SINGLE PRECISION VECTOR OF
19630C                                (UNSORTED) OBSERVATIONS
19631C                                WHICH CONSTITUTE THE FIRST SET
19632C                                OF DATA.
19633C                     --Y2     = THE SINGLE PRECISION VECTOR OF
19634C                                (UNSORTED) OBSERVATIONS
19635C                                WHICH CONSTITUTE THE SECOND SET
19636C                                OF DATA.
19637C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
19638C                                IN THE VECTOR X, OR EQUIVALENTLY,
19639C                                THE INTEGER NUMBER OF OBSERVATIONS
19640C                                IN THE VECTOR Y.
19641C     OUTPUT ARGUMENTS--STAT   = THE SINGLE PRECISION VALUE OF THE
19642C                                CRAMER'S CONTINGENCY COEFFICIENT
19643C                                BETWEEN THE 2 SETS OF DATA
19644C                                IN THE INPUT VECTORS X AND Y.
19645C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
19646C             SAMPLE CRAMER'S CONTINGENCY COEFFICENT BETWEEN THE
19647C             2 SETS OF DATA IN THE INPUT VECTORS X AND Y.
19648C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
19649C                   OF N FOR THIS SUBROUTINE.
19650C     OTHER DATAPAC   SUBROUTINES NEEDED--DISTIN.
19651C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
19652C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
19653C     LANGUAGE--ANSI FORTRAN (1977)
19654C     WRITTEN BY--JAMES J. FILLIBEN
19655C                 STATISTICAL ENGINEERING DIVISION
19656C                 INFORMATION TECHNOLOGY LABORATORY
19657C                 NATIONAL INSTIUTE OF STANDARDS AND TECHNOLOGY
19658C                 GAITHERSBURG, MD 20899-8980
19659C                 PHONE--301-975-2899
19660C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
19661C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
19662C     LANGUAGE--ANSI FORTRAN (1977)
19663C     VERSION NUMBER--2007/3
19664C     ORIGINAL VERSION--MARCH     2007.
19665C
19666C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
19667C
19668      CHARACTER*4 IWRITE
19669      CHARACTER*4 IBUGA3
19670      CHARACTER*4 IERROR
19671C
19672      CHARACTER*4 ISTEPN
19673      CHARACTER*4 ISUBN1
19674      CHARACTER*4 ISUBN2
19675C
19676C---------------------------------------------------------------------
19677C
19678      PARAMETER(MAXLEV=20000)
19679      PARAMETER(IWORK1=0)
19680      PARAMETER(IWORK2=20000)
19681      PARAMETER(IWORK3=40000)
19682      PARAMETER(IWORK4=60000)
19683      PARAMETER(IWORK5=80000)
19684C
19685      DIMENSION Y1(*)
19686      DIMENSION Y2(*)
19687      DIMENSION XIDTEM(*)
19688      DIMENSION XIDTE2(*)
19689      DIMENSION TEMP1(*)
19690C
19691C---------------------------------------------------------------------
19692C
19693      INCLUDE 'DPCOP2.INC'
19694C
19695C-----START POINT-----------------------------------------------------
19696C
19697      ISUBN1='CRAM'
19698      ISUBN2='ER  '
19699C
19700      IERROR='NO'
19701C
19702C
19703      IF(IBUGA3.EQ.'ON')THEN
19704        WRITE(ICOUT,999)
19705  999   FORMAT(1X)
19706        CALL DPWRST('XXX','BUG ')
19707        WRITE(ICOUT,51)
19708   51   FORMAT('***** AT THE BEGINNING OF CRAMER--')
19709        CALL DPWRST('XXX','BUG ')
19710        WRITE(ICOUT,52)IBUGA3
19711   52   FORMAT('IBUGA3 = ',A4)
19712        CALL DPWRST('XXX','BUG ')
19713        WRITE(ICOUT,53)N
19714   53   FORMAT('N = ',I8)
19715        CALL DPWRST('XXX','BUG ')
19716        DO55I=1,N
19717          WRITE(ICOUT,56)I,Y1(I),Y2(I)
19718   56     FORMAT('I,Y1(I),Y2(I) = ',I8,2G15.7)
19719          CALL DPWRST('XXX','BUG ')
19720   55   CONTINUE
19721      ENDIF
19722C
19723C               ********************************************
19724C               **  STEP 21--                             **
19725C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
19726C               ********************************************
19727C
19728      ISTEPN='21'
19729      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19730C
19731      IF(N.LT.2)THEN
19732        WRITE(ICOUT,999)
19733        CALL DPWRST('XXX','WRIT')
19734        WRITE(ICOUT,1201)
19735 1201   FORMAT('****** ERROR IN CRAMER CONTINGENCY COEFFICIENT--')
19736        CALL DPWRST('XXX','WRIT')
19737        WRITE(ICOUT,2101)
19738 2101   FORMAT('      THE NUMBER OF OBSERVATIONS IS LESS THAN 2.')
19739        CALL DPWRST('XXX','WRIT')
19740        WRITE(ICOUT,2103)N
19741 2103   FORMAT('SAMPLE SIZE = ',I8)
19742        CALL DPWRST('XXX','WRIT')
19743        IERROR='YES'
19744        GOTO9000
19745      ENDIF
19746C
19747C               ******************************************************
19748C               **  STEP 2.2--                                      **
19749C               **  DETERMINE THE NUMBER OF DISTINCT VALUES         **
19750C               **  FOR THE GROUP VARIABLES (Y1, Y2).               **
19751C               ******************************************************
19752C
19753      ISTEPN='22'
19754      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19755C
19756      CALL DISTIN(Y1,N,IWRITE,XIDTEM,NUMSE1,IBUGA3,IERROR)
19757      CALL SORT(XIDTEM,NUMSE1,XIDTEM)
19758      CALL DISTIN(Y2,N,IWRITE,XIDTE2,NUMSE2,IBUGA3,IERROR)
19759      CALL SORT(XIDTE2,NUMSE2,XIDTE2)
19760C
19761      IF(NUMSE1.LT.1 .OR. NUMSE1.GT.MAXLEV)THEN
19762        WRITE(ICOUT,999)
19763        CALL DPWRST('XXX','BUG ')
19764        WRITE(ICOUT,1201)
19765        CALL DPWRST('XXX','BUG ')
19766        WRITE(ICOUT,2202)MAXLEV
19767 2202   FORMAT('      NUMBER OF SETS FOR VARIABLE ONE IS OUTSIDE ',
19768     1         'THE INTERVAL (1,',I8,')')
19769        CALL DPWRST('XXX','BUG ')
19770        WRITE(ICOUT,2204)NUMSE1
19771 2204   FORMAT('      THE NUMBER OF SET = ',I10)
19772        CALL DPWRST('XXX','BUG ')
19773        IERROR='YES'
19774        GOTO9000
19775      ENDIF
19776C
19777      IF(NUMSE2.LT.1 .OR. NUMSE2.GT.MAXLEV)THEN
19778        WRITE(ICOUT,999)
19779        CALL DPWRST('XXX','BUG ')
19780        WRITE(ICOUT,1201)
19781        CALL DPWRST('XXX','BUG ')
19782        WRITE(ICOUT,2212)MAXLEV
19783 2212   FORMAT('      NUMBER OF SETS FOR VARIABLE TWO IS OUTSIDE ',
19784     1         'THE INTERVAL (1,',I8,')')
19785        CALL DPWRST('XXX','BUG ')
19786        WRITE(ICOUT,2204)NUMSE2
19787        CALL DPWRST('XXX','BUG ')
19788        IERROR='YES'
19789        GOTO9000
19790      ENDIF
19791C
19792C               ***********************************************
19793C               **  STEP 2.3--                               **
19794C               **  COMPUTE THE CHI-SQUARE STATISTIC         **
19795C               ***********************************************
19796C
19797      ISTEPN='23'
19798      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19799C
19800C     COMPUTE COUNTS FOR EACH CELL
19801C
19802      J=0
19803      DO2310ISET1=1,NUMSE1
19804        DO2320ISET2=1,NUMSE2
19805C
19806          K=0
19807          DO2330I=1,N
19808            IF(XIDTEM(ISET1).EQ.Y1(I).AND.XIDTE2(ISET2).EQ.Y2(I))THEN
19809              K=K+1
19810            ENDIF
19811 2330     CONTINUE
19812          NTEMP=K
19813          J=J+1
19814          TEMP1(IWORK1+J)=REAL(K)
19815          TEMP1(IWORK2+J)=XIDTEM(ISET1)
19816          TEMP1(IWORK3+J)=XIDTE2(ISET2)
19817C
19818 2320   CONTINUE
19819 2310 CONTINUE
19820      NTEMP2=J
19821C
19822C     COMPUTE ROW AND COLUMN TOTALS AND GRAND TOTAL.
19823C
19824      J=0
19825      GTOTAL=0.0
19826C
19827      DO2340ISET1=1,NUMSE1
19828        TEMP1(IWORK4+ISET1)=0.0
19829        DO2350ISET2=1,NUMSE2
19830          J=J+1
19831          TEMP1(IWORK4+ISET1)=TEMP1(IWORK4+ISET1) + TEMP1(IWORK1+J)
19832          GTOTAL=GTOTAL + TEMP1(IWORK1+J)
19833 2350   CONTINUE
19834C
19835        IF(IBUGA3.EQ.'ON')THEN
19836          WRITE(ICOUT,2352)ISET1,TEMP1(IWORK4+ISET1)
19837 2352     FORMAT('ISET1,ROWTOT(ISET1)=',I5,1X,G15.7)
19838          CALL DPWRST('XXX','BUG ')
19839        ENDIF
19840 2340 CONTINUE
19841C
19842      DO2360ISET2=1,NUMSE2
19843        TEMP1(IWORK5+ISET2)=0.0
19844        DO2370J=1,NTEMP2
19845          IF(TEMP1(IWORK3+J).EQ.XIDTE2(ISET2))THEN
19846            TEMP1(IWORK5+ISET2)=TEMP1(IWORK5+ISET2) + TEMP1(IWORK1+J)
19847          ENDIF
19848 2370   CONTINUE
19849C
19850        IF(IBUGA3.EQ.'ON')THEN
19851          WRITE(ICOUT,2372)ISET2,TEMP1(IWORK5+ISET2)
19852 2372     FORMAT('ISET2,COLTOT(ISET2)=',I5,1X,G15.7)
19853          CALL DPWRST('XXX','BUG ')
19854        ENDIF
19855C
19856 2360 CONTINUE
19857C
19858C     NOW COMPUTE THE CHI-SQUARE TEST STATISTIC
19859C
19860      STAT=0.0
19861      J=0
19862C
19863      DO2380ISET1=1,NUMSE1
19864        DO2390ISET2=1,NUMSE2
19865          J=J+1
19866          EXP=TEMP1(IWORK4+ISET1)*TEMP1(IWORK5+ISET2)/GTOTAL
19867          STAT=STAT + (TEMP1(IWORK1+J) - EXP)**2/EXP
19868 2390   CONTINUE
19869 2380 CONTINUE
19870      T=STAT
19871      Q=REAL(MIN(NUMSE1,NUMSE2))
19872      STAT=STAT/(GTOTAL*(Q-1.0))
19873      STAT=SQRT(STAT)
19874C
19875C               *******************************
19876C               **  STEP 3--                 **
19877C               **  WRITE OUT A LINE         **
19878C               **  OF SUMMARY INFORMATION.  **
19879C               *******************************
19880C
19881      IF(IFEEDB.EQ.'OFF')GOTO890
19882      IF(IWRITE.EQ.'OFF')GOTO890
19883      WRITE(ICOUT,999)
19884      CALL DPWRST('XXX','BUG ')
19885      WRITE(ICOUT,811)STAT
19886  811 FORMAT('THE CRAMER CONTINGENCY COEFFICIENT = ',G15.7)
19887      CALL DPWRST('XXX','BUG ')
19888  890 CONTINUE
19889C
19890C               *****************
19891C               **  STEP 90--  **
19892C               **  EXIT.      **
19893C               *****************
19894C
19895 9000 CONTINUE
19896      IF(IBUGA3.EQ.'ON')THEN
19897        WRITE(ICOUT,999)
19898        CALL DPWRST('XXX','BUG ')
19899        WRITE(ICOUT,9011)
19900 9011   FORMAT('***** AT THE END OF CRAMER--')
19901        CALL DPWRST('XXX','BUG ')
19902        WRITE(ICOUT,9012)IBUGA3,IERROR
19903 9012   FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
19904        CALL DPWRST('XXX','BUG ')
19905        WRITE(ICOUT,9015)T,GTOTAL,Q,STAT
19906 9015   FORMAT('T,GTOTAL,Q,STAT = ',4G15.7)
19907        CALL DPWRST('XXX','BUG ')
19908      ENDIF
19909C
19910      RETURN
19911      END
19912      SUBROUTINE CRAME2(XMAT,MAXOBV,NR1,NC1,IWRITE,
19913     1           TEMP1,STAT,
19914     1           IBUGA3,IERROR)
19915C
19916C     PURPOSE--THIS SUBROUTINE COMPUTES CRAMER'S COEFFICIENT
19917C              FOR RXC CONTINGENCY TABLES.  THIS IS
19918C
19919C                  SQRT(T/(N*(Q-1)))
19920C
19921C              WHERE
19922C
19923C                  T = CHI-SQUARE STATISTIC
19924C                    = SUM[i=1 to r][SUM[j=1 to c]
19925C                      [(O(ij)-E(ij))**2/E(ij)]]
19926C
19927C                      O = OBSERVED COUNT
19928C                      E = EXPECTED COUNT
19929C                        = ROW TOTAL*COL TOTAL/GRAND TOTAL
19930C
19931C                  N = TOTAL NUMBER OF OBSERVATIONS
19932C                  Q = MIN(R,C)
19933C
19934C     REFERENCE--CONOVER (1999), "PRACTICAL NONPARAMETRIC
19935C                STATISTICS", THIRD EDITION, WILEY, PP. 229-230.
19936C     NOTE--THIS SUBROUTINE HANDLES THE SUMMARY DATA CASE (I.E..
19937C           THE DATA IS GIVEN AS AN RXC TABLE).   THE "CRAMER"
19938C           SUBROUTINE IS USED FOR THE RAW DATA CASE.
19939C     INPUT  ARGUMENTS--XMAT   = THE SINGLE PRECISION MATRIX OF
19940C                                OBSERVATIONS (RXC TABLE)
19941C                     --MAXOBV = THE INTEGER NUMBER THAT SPECIFIES
19942C                                THE MAXIMUM NUMBER OF ROWS IN THE
19943C                                MATRIX.
19944C                     --NR1    = THE INTEGER NUMBER OF ROWS
19945C                                IN THE MATRIX XMAT.
19946C                     --NC1    = THE INTEGER NUMBER OF COLUMNS
19947C                                IN THE MATRIX XMAT.
19948C     OUTPUT ARGUMENTS--STAT   = THE SINGLE PRECISION VALUE OF THE
19949C                                CRAMER'S CONTINGENCY COEFFICIENT
19950C                                OF THE DATA IN THE MATRIX XMAT.
19951C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
19952C             SAMPLE CRAMER'S CONTINGENCY COEFFICENT OF THE DATA
19953C             IN THE MATRIX XMAT.
19954C     RESTRICTIONS--THE MAXIMUM NUMBER OF LEVELS IS 50,000.
19955C     OTHER DATAPAC   SUBROUTINES NEEDED--DISTIN.
19956C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
19957C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
19958C     LANGUAGE--ANSI FORTRAN (1977)
19959C     WRITTEN BY--JAMES J. FILLIBEN
19960C                 STATISTICAL ENGINEERING DIVISION
19961C                 INFORMATION TECHNOLOGY LABORATORY
19962C                 NATIONAL INSTIUTE OF STANDARDS AND TECHNOLOGY
19963C                 GAITHERSBURG, MD 20899-8980
19964C                 PHONE--301-975-2899
19965C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
19966C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
19967C     LANGUAGE--ANSI FORTRAN (1977)
19968C     VERSION NUMBER--2007/3
19969C     ORIGINAL VERSION--MARCH     2007.
19970C
19971C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
19972C
19973      CHARACTER*4 IWRITE
19974      CHARACTER*4 IBUGA3
19975      CHARACTER*4 IERROR
19976C
19977      CHARACTER*4 ISTEPN
19978      CHARACTER*4 ISUBN1
19979      CHARACTER*4 ISUBN2
19980C
19981C---------------------------------------------------------------------
19982C
19983      PARAMETER(MAXLEV=50000)
19984      PARAMETER(IWORK1=0)
19985      PARAMETER(IWORK2=50000)
19986C
19987      DIMENSION XMAT(MAXOBV,NC1)
19988      DIMENSION TEMP1(*)
19989C
19990C---------------------------------------------------------------------
19991C
19992      INCLUDE 'DPCOP2.INC'
19993C
19994C-----START POINT-----------------------------------------------------
19995C
19996      ISUBN1='CRAM'
19997      ISUBN2='ER  '
19998      IERROR='NO'
19999C
20000C
20001      IF(IBUGA3.EQ.'ON')THEN
20002        WRITE(ICOUT,999)
20003  999   FORMAT(1X)
20004        CALL DPWRST('XXX','BUG ')
20005        WRITE(ICOUT,51)
20006   51   FORMAT('***** AT THE BEGINNING OF CRAME2--')
20007        CALL DPWRST('XXX','BUG ')
20008        WRITE(ICOUT,52)IBUGA3
20009   52   FORMAT('IBUGA3 = ',A4)
20010        CALL DPWRST('XXX','BUG ')
20011        WRITE(ICOUT,53)MAXOBV,NR1,NC1
20012   53   FORMAT('MAXOBV,NR1,NC1 = ',3I8)
20013        CALL DPWRST('XXX','BUG ')
20014        DO55I=1,NR1
20015          DO60J=1,NC1
20016            WRITE(ICOUT,56)I,J,XMAT(I,J)
20017   56       FORMAT('I,J,XMAT(I,J) = ',2I8,G15.7)
20018            CALL DPWRST('XXX','BUG ')
20019   60     CONTINUE
20020   55   CONTINUE
20021      ENDIF
20022C
20023C               ********************************************
20024C               **  STEP 21--                             **
20025C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
20026C               ********************************************
20027C
20028      ISTEPN='21'
20029      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20030C
20031      IF(NR1.LT.2 .OR. NR1.GT.MAXLEV)THEN
20032        WRITE(ICOUT,999)
20033        CALL DPWRST('XXX','WRIT')
20034        WRITE(ICOUT,1201)
20035 1201   FORMAT('****** ERROR IN MATRIX CRAMER CONTINGENCY ',
20036     1         'COEFFICIENT--')
20037        CALL DPWRST('XXX','WRIT')
20038        WRITE(ICOUT,2101)
20039 2101   FORMAT('      THE NUMBER OF ROWS IN THE MATRIX IS LESS ',
20040     1         'THAN 2')
20041        CALL DPWRST('XXX','WRIT')
20042        WRITE(ICOUT,2102)MAXLEV
20043 2102   FORMAT('      OR GREATER THAN ',I10,'.')
20044        CALL DPWRST('XXX','WRIT')
20045        WRITE(ICOUT,2103)NR1
20046 2103   FORMAT('NUMBER OF ROWS = ',I8)
20047        CALL DPWRST('XXX','WRIT')
20048        IERROR='YES'
20049        GOTO9000
20050      ENDIF
20051C
20052      IF(NC1.LT.2 .OR. NC1.GT.MAXLEV)THEN
20053        WRITE(ICOUT,999)
20054        CALL DPWRST('XXX','WRIT')
20055        WRITE(ICOUT,1201)
20056        CALL DPWRST('XXX','WRIT')
20057        WRITE(ICOUT,2111)
20058 2111   FORMAT('      THE NUMBER OF COLUMNS IN THE MATRIX IS LESS ',
20059     1         'THAN 2')
20060        CALL DPWRST('XXX','WRIT')
20061        WRITE(ICOUT,2102)MAXLEV
20062        CALL DPWRST('XXX','WRIT')
20063        WRITE(ICOUT,2113)NC1
20064 2113   FORMAT('NUMBER OF COLUMNS = ',I8)
20065        CALL DPWRST('XXX','WRIT')
20066        IERROR='YES'
20067        GOTO9000
20068      ENDIF
20069C
20070      GTOTAL=0.0
20071      DO2120J=1,NC1
20072        DO2130I=1,NR1
20073          ITEMP=INT(XMAT(I,J)+0.5)
20074          IF(ITEMP.LT.0)THEN
20075            WRITE(ICOUT,999)
20076            CALL DPWRST('XXX','WRIT')
20077            WRITE(ICOUT,1201)
20078            CALL DPWRST('XXX','WRIT')
20079            WRITE(ICOUT,2131)
20080 2131       FORMAT('      A NEGATIVE COUNT WAS ENCOUNTERED IN THE ',
20081     1             'INPUT MATRIX.')
20082            CALL DPWRST('XXX','WRIT')
20083            WRITE(ICOUT,2133)I,J,ITEMP
20084 2133       FORMAT('      COUNT FOR ROW ',I8,' COLUMN ',I8,' = ',I8)
20085            CALL DPWRST('XXX','WRIT')
20086            IERROR='YES'
20087            GOTO9000
20088          ENDIF
20089          XMAT(I,J)=REAL(ITEMP)
20090          GTOTAL=GTOTAL + XMAT(I,J)
20091 2130   CONTINUE
20092 2120 CONTINUE
20093C
20094      IF(IBUGA3.EQ.'ON')THEN
20095        WRITE(ICOUT,2344)GTOTAL
20096 2344   FORMAT('GTOTAL = ',G15.7)
20097        CALL DPWRST('XXX','BUG ')
20098      ENDIF
20099C
20100C               ******************************************************
20101C               **  STEP 2.2--                                      **
20102C               **  COMPUTE THE ROW AND COLUMN TOTALS.              **
20103C               ******************************************************
20104C
20105      ISTEPN='22'
20106      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20107C
20108      DO2340ISET1=1,NR1
20109        TEMP1(IWORK1+ISET1)=0.0
20110        DO2350ISET2=1,NC1
20111          TEMP1(IWORK1+ISET1)=TEMP1(IWORK1+ISET1) + XMAT(ISET1,ISET2)
20112          IF(IBUGA3.EQ.'ON')THEN
20113            WRITE(ICOUT,2342)ISET1,ISET2,XMAT(ISET1,ISET2)
20114 2342       FORMAT('ISET1,ISET2,XMAT(I,J) =',2I8,G15.7)
20115            CALL DPWRST('XXX','BUG ')
20116          ENDIF
20117 2350   CONTINUE
20118C
20119        IF(IBUGA3.EQ.'ON')THEN
20120          WRITE(ICOUT,2352)ISET1,TEMP1(IWORK1+ISET1)
20121 2352     FORMAT('ISET1,ROWTOT(ISET1)=',I5,1X,G15.7)
20122          CALL DPWRST('XXX','BUG ')
20123        ENDIF
20124 2340 CONTINUE
20125C
20126      DO2360ISET2=1,NC1
20127        TEMP1(IWORK2+ISET2)=0.0
20128        DO2370ISET1=1,NR1
20129          TEMP1(IWORK2+ISET2)=TEMP1(IWORK2+ISET2) + XMAT(ISET1,ISET2)
20130 2370   CONTINUE
20131C
20132        IF(IBUGA3.EQ.'ON')THEN
20133          WRITE(ICOUT,2372)ISET2,TEMP1(IWORK2+ISET2)
20134 2372     FORMAT('ISET2,COLTOT(ISET2)=',I5,1X,G15.7)
20135          CALL DPWRST('XXX','BUG ')
20136        ENDIF
20137C
20138 2360 CONTINUE
20139C
20140C               ******************************************************
20141C               **  STEP 2.3--                                      **
20142C               **  COMPUTE THE CHI-SQUARE STATISTIC.               **
20143C               ******************************************************
20144C
20145      ISTEPN='23'
20146      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20147C
20148C     NOW COMPUTE THE CHI-SQUARE TEST STATISTIC
20149C
20150      STAT=0.0
20151C
20152      DO2380ISET1=1,NR1
20153        DO2390ISET2=1,NC1
20154          EXP=TEMP1(IWORK1+ISET1)*TEMP1(IWORK2+ISET2)/GTOTAL
20155          STAT=STAT + (XMAT(ISET1,ISET2) - EXP)**2/EXP
20156 2390   CONTINUE
20157 2380 CONTINUE
20158      T=STAT
20159      Q=REAL(MIN(NR1,NC1))
20160      STAT=STAT/(GTOTAL*(Q-1.0))
20161      STAT=SQRT(STAT)
20162C
20163C               *******************************
20164C               **  STEP 3--                 **
20165C               **  WRITE OUT A LINE         **
20166C               **  OF SUMMARY INFORMATION.  **
20167C               *******************************
20168C
20169      IF(IFEEDB.EQ.'OFF')GOTO890
20170      IF(IWRITE.EQ.'OFF')GOTO890
20171      WRITE(ICOUT,999)
20172      CALL DPWRST('XXX','BUG ')
20173      WRITE(ICOUT,811)STAT
20174  811 FORMAT('THE CRAMER CONTINGENCY COEFFICIENT = ',G15.7)
20175      CALL DPWRST('XXX','BUG ')
20176  890 CONTINUE
20177C
20178C               *****************
20179C               **  STEP 90--  **
20180C               **  EXIT.      **
20181C               *****************
20182C
20183 9000 CONTINUE
20184      IF(IBUGA3.EQ.'ON')THEN
20185        WRITE(ICOUT,999)
20186        CALL DPWRST('XXX','BUG ')
20187        WRITE(ICOUT,9011)
20188 9011   FORMAT('***** AT THE END OF CRAME2--')
20189        CALL DPWRST('XXX','BUG ')
20190        WRITE(ICOUT,9012)IBUGA3,IERROR
20191 9012   FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
20192        CALL DPWRST('XXX','BUG ')
20193        WRITE(ICOUT,9015)T,GTOTAL,Q,STAT
20194 9015   FORMAT('T,GTOTAL,Q,STAT = ',4G15.7)
20195        CALL DPWRST('XXX','BUG ')
20196      ENDIF
20197C
20198      RETURN
20199      END
20200      FUNCTION CSEVL (X, CS, N)
20201C***BEGIN PROLOGUE  CSEVL
20202C***PURPOSE  Evaluate a Chebyshev series.
20203C***LIBRARY   SLATEC (FNLIB)
20204C***CATEGORY  C3A2
20205C***TYPE      SINGLE PRECISION (CSEVL-S, DCSEVL-D)
20206C***KEYWORDS  CHEBYSHEV SERIES, FNLIB, SPECIAL FUNCTIONS
20207C***AUTHOR  Fullerton, W., (LANL)
20208C***DESCRIPTION
20209C
20210C  Evaluate the N-term Chebyshev series CS at X.  Adapted from
20211C  a method presented in the paper by Broucke referenced below.
20212C
20213C       Input Arguments --
20214C  X    value at which the series is to be evaluated.
20215C  CS   array of N terms of a Chebyshev series.  In evaluating
20216C       CS, only half the first coefficient is summed.
20217C  N    number of terms in array CS.
20218C
20219C***REFERENCES  R. Broucke, Ten subroutines for the manipulation of
20220C                 Chebyshev series, Algorithm 446, Communications of
20221C                 the A.C.M. 16, (1973) pp. 254-256.
20222C               L. Fox and I. B. Parker, Chebyshev Polynomials in
20223C                 Numerical Analysis, Oxford University Press, 1968,
20224C                 page 56.
20225C***ROUTINES CALLED  R1MACH, XERMSG
20226C***REVISION HISTORY  (YYMMDD)
20227C   770401  DATE WRITTEN
20228C   890831  Modified array declarations.  (WRB)
20229C   890831  REVISION DATE from Version 3.2
20230C   891214  Prologue converted to Version 4.0 format.  (BAB)
20231C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
20232C   900329  Prologued revised extensively and code rewritten to allow
20233C           X to be slightly outside interval (-1,+1).  (WRB)
20234C   920501  Reformatted the REFERENCES section.  (WRB)
20235C***END PROLOGUE  CSEVL
20236      REAL B0, B1, B2, CS(*), ONEPL, TWOX, X
20237      LOGICAL FIRST
20238      SAVE FIRST, ONEPL
20239C
20240C-----COMMON----------------------------------------------------------
20241C
20242      INCLUDE 'DPCOMC.INC'
20243      INCLUDE 'DPCOP2.INC'
20244C
20245      DATA FIRST /.TRUE./
20246C***FIRST EXECUTABLE STATEMENT  CSEVL
20247C
20248      B0=0.0
20249      B2=0.0
20250C
20251      IF (FIRST) ONEPL = 1.0E0 + R1MACH(4)
20252      FIRST = .FALSE.
20253C
20254      IF (N .LT. 1) THEN
20255        WRITE(ICOUT,11)
20256        CALL DPWRST('XXX','BUG ')
20257        WRITE(ICOUT,12)
20258        CALL DPWRST('XXX','BUG ')
20259        CSEVL = 0.0
20260        RETURN
20261      ENDIF
20262   11 FORMAT('***** ERROR FROM CSEVL.  THE NUMBER OF TERMS IS ')
20263   12 FORMAT('      LESS THAN OR EQUAL TO ZERO.                *****')
20264      IF (N .GT. 1000) THEN
20265        WRITE(ICOUT,21)
20266        CALL DPWRST('XXX','BUG ')
20267        WRITE(ICOUT,22)
20268        CALL DPWRST('XXX','BUG ')
20269        CSEVL = 0.0
20270        RETURN
20271      ENDIF
20272   21 FORMAT('***** ERROR FROM CSEVL.  THE NUMBER OF TERMS IS ')
20273   22 FORMAT('      GREATER THAN 1000.                         *****')
20274      IF (ABS(X) .GT. ONEPL) THEN
20275        WRITE(ICOUT,31)
20276        CALL DPWRST('XXX','BUG ')
20277        WRITE(ICOUT,32)
20278        CALL DPWRST('XXX','BUG ')
20279      ENDIF
20280   31 FORMAT('***** WARNING FROM CSEVL.  X IS OUTSIDE THE ')
20281   32 FORMAT('      INTERVAL (-1,+1).                          *****')
20282C
20283      B1 = 0.0E0
20284      B0 = 0.0E0
20285      TWOX = 2.0*X
20286      DO 10 I = 1,N
20287         B2 = B1
20288         B1 = B0
20289         NI = N + 1 - I
20290         B0 = TWOX*B1 - B2 + CS(NI)
20291   10 CONTINUE
20292C
20293      CSEVL = 0.5E0*(B0-B2)
20294C
20295      RETURN
20296      END
20297      SUBROUTINE CUMAVE(X,NX,IWRITE,Y,IBUGA3,IERROR)
20298C
20299C     PURPOSE--COMPUTE CUMULATIVE AVERAGE (MEAN) OF AN ARRAY
20300C     NOTE--IT IS PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y(.)
20301C           BEING IDENTICAL TO THE INPUT VECTOR X(.).
20302C     WRITTEN BY--JAMES J. FILLIBEN
20303C                 STATISTICAL ENGINEERING DIVISION
20304C                 INFORMATION TECHNOLOGY LABORATORY
20305C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
20306C                 GAITHERSBURG, MD 20899
20307C                 PHONE--301-975-2855
20308C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
20309C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
20310C     LANGUAGE--ANSI FORTRAN (1977)
20311C     VERSION NUMBER--98/5
20312C     ORIGINAL VERSION--MAY       1998.
20313C
20314C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
20315C
20316      CHARACTER*4 IWRITE
20317      CHARACTER*4 IBUGA3
20318      CHARACTER*4 IERROR
20319C
20320      CHARACTER*4 ISUBN1
20321      CHARACTER*4 ISUBN2
20322C
20323      DOUBLE PRECISION DSUM
20324C
20325C---------------------------------------------------------------------
20326C
20327      DIMENSION X(*)
20328      DIMENSION Y(*)
20329C
20330C---------------------------------------------------------------------
20331C
20332      INCLUDE 'DPCOP2.INC'
20333C
20334C-----START POINT-----------------------------------------------------
20335C
20336      ISUBN1='CUMA'
20337      ISUBN2='VE  '
20338      IERROR='NO'
20339C
20340      IF(IBUGA3.EQ.'ON')THEN
20341        WRITE(ICOUT,999)
20342  999   FORMAT(1X)
20343        CALL DPWRST('XXX','BUG ')
20344        WRITE(ICOUT,51)
20345   51   FORMAT('***** AT THE BEGINNING OF CUMAVE--')
20346        CALL DPWRST('XXX','BUG ')
20347        WRITE(ICOUT,52)IBUGA3,IWRITE,NX
20348   52   FORMAT('IBUGA3,IWRITE,NX = ',2(A4,2X),I8)
20349        CALL DPWRST('XXX','BUG ')
20350        DO55I=1,NX
20351          WRITE(ICOUT,56)I,X(I)
20352   56     FORMAT('I,X(I) = ',I8,G15.7)
20353          CALL DPWRST('XXX','BUG ')
20354   55   CONTINUE
20355      ENDIF
20356C
20357C               **************************************
20358C               **  COMPUTE CUMULATIVE AVERAGE      **
20359C               **************************************
20360C
20361      Y(1)=X(1)
20362      IF(NX.LT.2)GOTO9000
20363      DSUM=DBLE(Y(1))
20364      DO100I=2,NX
20365        DSUM=DSUM + DBLE(X(I))
20366        Y(I)=REAL(DSUM/DBLE(I))
20367  100 CONTINUE
20368C
20369C               *****************
20370C               **  STEP 90--  **
20371C               **  EXIT.      **
20372C               *****************
20373C
20374 9000 CONTINUE
20375C
20376      IF(IBUGA3.EQ.'OFF')GOTO9090
20377      WRITE(ICOUT,999)
20378      CALL DPWRST('XXX','BUG ')
20379      WRITE(ICOUT,9011)
20380 9011 FORMAT('***** AT THE END       OF CUMAVE--')
20381      CALL DPWRST('XXX','BUG ')
20382      WRITE(ICOUT,9012)IBUGA3,IERROR
20383 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
20384      CALL DPWRST('XXX','BUG ')
20385      WRITE(ICOUT,9013)NX
20386 9013 FORMAT('NX = ',I8)
20387      CALL DPWRST('XXX','BUG ')
20388      DO9015I=1,NX
20389      WRITE(ICOUT,9016)I,X(I),Y(I)
20390 9016 FORMAT('I,X(I),Y(I) = ',I8,2E15.7)
20391      CALL DPWRST('XXX','BUG ')
20392 9015 CONTINUE
20393 9090 CONTINUE
20394C
20395      RETURN
20396      END
20397      SUBROUTINE CUMHAZ(X,TAG,NX,IWRITE,Y,XTEMP,MAXOBV,IBUGA3,IERROR)
20398C
20399C     PURPOSE--COMPUTE CUMULATIVE HAZARD OF AN ARRAY
20400C              THE TAG VARIABLE IDENTIFIES CENSORED DATA
20401C              (1 = FAILURE TIME, 0 = CENSORED)
20402C     NOTE--IT IS PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y(.)
20403C           BEING IDENTICAL TO THE INPUT VECTOR X(.).
20404C     WRITTEN BY--JAMES J. FILLIBEN
20405C                 STATISTICAL ENGINEERING DIVISION
20406C                 INFORMATION TECHNOLOGY LABORATORY
20407C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
20408C                 GAITHERSBURG, MD 20899
20409C                 PHONE--301-975-2855
20410C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
20411C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
20412C     LANGUAGE--ANSI FORTRAN (1977)
20413C     VERSION NUMBER--98/5
20414C     ORIGINAL VERSION--MAY       1998.
20415C     UPDATED         --JANUARY   2007. ARGUMENT LIST TO RANK
20416C
20417C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
20418C
20419      CHARACTER*4 IWRITE
20420      CHARACTER*4 IBUGA3
20421      CHARACTER*4 IERROR
20422C
20423      CHARACTER*4 ISUBN1
20424      CHARACTER*4 ISUBN2
20425C
20426      DOUBLE PRECISION DSUM
20427C
20428C---------------------------------------------------------------------
20429C
20430      DIMENSION X(*)
20431      DIMENSION Y(*)
20432      DIMENSION TAG(*)
20433      DIMENSION XTEMP(*)
20434C
20435C---------------------------------------------------------------------
20436C
20437      INCLUDE 'DPCOP2.INC'
20438C
20439C-----START POINT-----------------------------------------------------
20440C
20441      ISUBN1='CUMH'
20442      ISUBN2='AZ  '
20443C
20444      IERROR='NO'
20445C
20446      IF(IBUGA3.EQ.'OFF')GOTO90
20447      WRITE(ICOUT,999)
20448  999 FORMAT(1X)
20449      CALL DPWRST('XXX','BUG ')
20450      WRITE(ICOUT,51)
20451   51 FORMAT('***** AT THE BEGINNING OF CUMHAZ--')
20452      CALL DPWRST('XXX','BUG ')
20453      WRITE(ICOUT,52)IBUGA3
20454   52 FORMAT('IBUGA3 = ',A4)
20455      CALL DPWRST('XXX','BUG ')
20456      WRITE(ICOUT,53)NX
20457   53 FORMAT('NX = ',I8)
20458      CALL DPWRST('XXX','BUG ')
20459      DO55I=1,NX
20460      WRITE(ICOUT,56)I,X(I),TAG(I)
20461   56 FORMAT('I,X(I), TAG(I) = ',I8,2E15.7)
20462      CALL DPWRST('XXX','BUG ')
20463   55 CONTINUE
20464   90 CONTINUE
20465C
20466C               **************************************
20467C               **  COMPUTE CUMULATIVE HAZARD       **
20468C               **************************************
20469C
20470      CALL SORTC(X,TAG,NX,Y,TAG)
20471      CALL RANK(Y,NX,IWRITE,Y,XTEMP,MAXOBV,IBUGA3,IERROR)
20472      IF(IERROR.EQ.'YES')GOTO9000
20473C
20474      AFACT=REAL(NX+1)
20475      DO100J=1,NX
20476        IF(ABS(TAG(J)).GE.0.5)THEN
20477          Y(J)=100./(AFACT - Y(J))
20478        ELSE
20479          Y(J)=0.0
20480        ENDIF
20481  100 CONTINUE
20482C
20483      DSUM=0.0D0
20484      DO200I=1,NX
20485        DSUM=DSUM+DBLE(Y(I))
20486        Y(I)=REAL(DSUM)
20487  200 CONTINUE
20488C
20489C               *****************
20490C               **  STEP 90--  **
20491C               **  EXIT.      **
20492C               *****************
20493C
20494 9000 CONTINUE
20495C
20496      IF(IBUGA3.EQ.'OFF')GOTO9090
20497      WRITE(ICOUT,999)
20498      CALL DPWRST('XXX','BUG ')
20499      WRITE(ICOUT,9011)
20500 9011 FORMAT('***** AT THE END       OF CUMHAZ--')
20501      CALL DPWRST('XXX','BUG ')
20502      WRITE(ICOUT,9012)IBUGA3,IERROR
20503 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
20504      CALL DPWRST('XXX','BUG ')
20505      WRITE(ICOUT,9013)NX
20506 9013 FORMAT('NX = ',2I8)
20507      CALL DPWRST('XXX','BUG ')
20508      DO9015I=1,NX
20509      WRITE(ICOUT,9016)I,X(I),Y(I)
20510 9016 FORMAT('I,X(I),Y(I) = ',I8,2E15.7)
20511      CALL DPWRST('XXX','BUG ')
20512 9015 CONTINUE
20513 9090 CONTINUE
20514C
20515      RETURN
20516      END
20517      SUBROUTINE CUMINT(Y,X,N,NUMVAR,IWRITE,Z,IBUGA3,IERROR)
20518C
20519C     PURPOSE--COMPUTE CUMULATIVE INTEGRAL OF A VARIABLE.
20520C     NOTE--IF THE VERTICAL AXIS VARIABLE IS Y(.)
20521C           AND THE HORIZONTAL AXIS VARIABLE IS X(.),
20522C           THEN THE OUTPUT VARIABLE CONTAINING THE
20523C           CUMULATIVE INTEGRAL
20524C           WILL BE COMPUTED AS FOLLOWS--
20525C              Z(1) = 0
20526C              Z(2) = Z(1) + (Y(2)-Y(1))*(X(2)-X(1))/2
20527C              Z(3) = Z(2) + Y(2)*(X(3)-X(2)) + (Y(3)-Y(2))*(X(3)-X(2))/2
20528C              ETC.
20529C     NOTE--IT IS PERMISSIBLE TO HAVE THE OUTPUT VECTOR Z(.)
20530C           BEING IDENTICAL TO THE INPUT VECTOR X(.)
20531C           OR THE INPUT VECTORS X(.) AND Y(.).
20532C     WRITTEN BY--JAMES J. FILLIBEN
20533C                 STATISTICAL ENGINEERING DIVISION
20534C                 INFORMATION TECHNOLOGY LABORATORY
20535C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
20536C                 GAITHERSBURG, MD 20899
20537C                 PHONE--301-975-2855
20538C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
20539C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
20540C     LANGUAGE--ANSI FORTRAN (1977)
20541C     VERSION NUMBER--82/7
20542C     ORIGINAL VERSION--FEBRUARY  1979.
20543C     UPDATED         --APRIL     1979.
20544C     UPDATED         --JULY      1979.
20545C     UPDATED         --AUGUST    1981.
20546C     UPDATED         --MAY       1982.
20547C
20548C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
20549C
20550      CHARACTER*4 IWRITE
20551      CHARACTER*4 IBUGA3
20552      CHARACTER*4 IERROR
20553C
20554      CHARACTER*4 ISUBN1
20555      CHARACTER*4 ISUBN2
20556      CHARACTER*4 ISTEPN
20557C
20558C---------------------------------------------------------------------
20559C
20560      DIMENSION Y(*)
20561      DIMENSION X(*)
20562      DIMENSION Z(*)
20563C
20564      DOUBLE PRECISION DINT
20565      DOUBLE PRECISION DXI
20566      DOUBLE PRECISION DYI
20567      DOUBLE PRECISION DXIM1
20568      DOUBLE PRECISION DYIM1
20569      DOUBLE PRECISION DDELX
20570      DOUBLE PRECISION DDELY
20571      DOUBLE PRECISION DTERM1
20572      DOUBLE PRECISION DTERM2
20573C
20574C---------------------------------------------------------------------
20575C
20576      INCLUDE 'DPCOP2.INC'
20577C
20578C-----START POINT-----------------------------------------------------
20579C
20580      ISUBN1='CUMI'
20581      ISUBN2='NT  '
20582      IERROR='NO'
20583C
20584      DXI=0.0D0
20585C
20586      IF(IBUGA3.EQ.'ON')THEN
20587        WRITE(ICOUT,999)
20588  999   FORMAT(1X)
20589        CALL DPWRST('XXX','BUG ')
20590        WRITE(ICOUT,51)
20591   51   FORMAT('***** AT THE BEGINNING OF CUMINT--')
20592        CALL DPWRST('XXX','BUG ')
20593        WRITE(ICOUT,52)IBUGA3,IWRITE,N,NUMVAR
20594   52   FORMAT('IBUGA3,IWRITE,N,NUMVAR = ',2(A4,2X),2I8)
20595        CALL DPWRST('XXX','BUG ')
20596        DO55I=1,N
20597          WRITE(ICOUT,56)I,X(I),Y(I)
20598   56     FORMAT('I,X(I),Y(I) = ',I8,2G15.7)
20599          CALL DPWRST('XXX','BUG ')
20600   55   CONTINUE
20601      ENDIF
20602C
20603C               ****************************************************
20604C               **  CUMPUTE THE CUMULATIVE (NUMERICAL) INTEGRAL.  **
20605C               ****************************************************
20606C
20607      ISTEPN='1'
20608      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20609C
20610      DINT=0.0D0
20611      IF(N.LT.1)GOTO150
20612      IF(N.EQ.1)GOTO190
20613      I=1
20614      IF(NUMVAR.EQ.1)DXI=I
20615      IF(NUMVAR.EQ.2)DXI=X(I)
20616      DYI=Y(1)
20617      Z(1)=0.0
20618      DO100I=2,N
20619      DXIM1=DXI
20620      DYIM1=DYI
20621      IF(NUMVAR.EQ.1)DXI=I
20622      IF(NUMVAR.EQ.2)DXI=X(I)
20623      DYI=Y(I)
20624      DDELX=DXI-DXIM1
20625      DDELY=DYI-DYIM1
20626      DTERM1=DYIM1*DDELX
20627      DTERM2=DDELY*DDELX/2.0D0
20628      DINT=DINT+DTERM1+DTERM2
20629      Z(I)=DINT
20630  100 CONTINUE
20631      GOTO190
20632C
20633  150 CONTINUE
20634      IERROR='YES'
20635      WRITE(ICOUT,999)
20636      CALL DPWRST('XXX','BUG ')
20637      WRITE(ICOUT,151)
20638  151 FORMAT('***** ERROR IN CUMINT--')
20639      CALL DPWRST('XXX','BUG ')
20640      WRITE(ICOUT,152)
20641  152 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
20642      CALL DPWRST('XXX','BUG ')
20643      WRITE(ICOUT,153)
20644  153 FORMAT('      IN THE VARIABLE FOR WHICH')
20645      CALL DPWRST('XXX','BUG ')
20646      WRITE(ICOUT,154)
20647  154 FORMAT('      THE CUMULATIVE INTEGRAL IS TO BE COMPUTED')
20648      CALL DPWRST('XXX','BUG ')
20649      WRITE(ICOUT,155)
20650  155 FORMAT('      MUST BE 1 OR LARGER.')
20651      CALL DPWRST('XXX','BUG ')
20652      WRITE(ICOUT,156)
20653  156 FORMAT('      SUCH WAS NOT THE CASE HERE.')
20654      CALL DPWRST('XXX','BUG ')
20655      WRITE(ICOUT,157)N
20656  157 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
20657     1'.')
20658      CALL DPWRST('XXX','BUG ')
20659  190 CONTINUE
20660C
20661C               *****************
20662C               **  STEP 90--  **
20663C               **  EXIT.      **
20664C               *****************
20665C
20666      IF(IBUGA3.EQ.'ON')THEN
20667        WRITE(ICOUT,999)
20668        CALL DPWRST('XXX','BUG ')
20669        WRITE(ICOUT,9011)
20670 9011   FORMAT('***** AT THE END       OF CUMINT--')
20671        CALL DPWRST('XXX','BUG ')
20672        WRITE(ICOUT,9012)IBUGA3,IERROR,N,NUMVAR
20673 9012   FORMAT('IBUGA3,IERROR,N,NUMVAR = ',2(A4,2X),2I8)
20674        CALL DPWRST('XXX','BUG ')
20675        DO9015I=1,N
20676          WRITE(ICOUT,9016)I,X(I),Y(I),Z(I)
20677 9016     FORMAT('I,X(I),Y(I),Z(I) = ',I8,3G15.7)
20678          CALL DPWRST('XXX','BUG ')
20679 9015   CONTINUE
20680      ENDIF
20681C
20682      RETURN
20683      END
20684      SUBROUTINE CUMMAX(X,N,IWRITE,Y,IBUGA3,ISUBRO,IERROR)
20685C
20686C     PURPOSE--COMPUTE CUMULATIVE MAXIMUM OF A VARIABLE
20687C     NOTE--IT IS PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y(.)
20688C           BEING IDENTICAL TO THE INPUT VECTOR X(.).
20689C     WRITTEN BY--ALAN HECKERT
20690C                 STATISTICAL ENGINEERING DIVISION
20691C                 INFORMATION TECHNOLOGY LABORATORY
20692C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
20693C                 GAITHERSBURG, MD 20899
20694C                 PHONE--301-975-2899
20695C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
20696C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
20697C     LANGUAGE--ANSI FORTRAN (1977)
20698C     VERSION NUMBER--2012/12
20699C     ORIGINAL VERSION--DECEMBER  2012.
20700C
20701C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
20702C
20703      CHARACTER*4 IWRITE
20704      CHARACTER*4 IBUGA3
20705      CHARACTER*4 ISUBRO
20706      CHARACTER*4 IERROR
20707C
20708      CHARACTER*4 ISUBN1
20709      CHARACTER*4 ISUBN2
20710C
20711C---------------------------------------------------------------------
20712C
20713      DIMENSION X(*)
20714      DIMENSION Y(*)
20715C
20716C---------------------------------------------------------------------
20717C
20718      INCLUDE 'DPCOP2.INC'
20719C
20720C-----START POINT-----------------------------------------------------
20721C
20722      ISUBN1='CUMM'
20723      ISUBN2='IN  '
20724      IERROR='NO'
20725C
20726      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'MMAX')THEN
20727        WRITE(ICOUT,999)
20728  999   FORMAT(1X)
20729        CALL DPWRST('XXX','BUG ')
20730        WRITE(ICOUT,51)
20731   51   FORMAT('***** AT THE BEGINNING OF CUMMAX--')
20732        CALL DPWRST('XXX','BUG ')
20733        WRITE(ICOUT,52)IBUGA3,IWRITE,N
20734   52   FORMAT('IBUGA3,IWRITE,N = ',2(A4,2X),I8)
20735        CALL DPWRST('XXX','BUG ')
20736        DO55I=1,N
20737          WRITE(ICOUT,56)I,X(I)
20738   56     FORMAT('I,X(I) = ',I8,G15.7)
20739          CALL DPWRST('XXX','BUG ')
20740   55   CONTINUE
20741      ENDIF
20742C
20743C               ***********************************
20744C               **  COMPUTE CUMULATIVE MAXIMUM.  **
20745C               ***********************************
20746C
20747      IF(N.LT.1)THEN
20748        IERROR='YES'
20749        WRITE(ICOUT,999)
20750        CALL DPWRST('XXX','BUG ')
20751        WRITE(ICOUT,151)
20752  151   FORMAT('***** ERROR IN CUMULATIVE MAXIMUM--')
20753        CALL DPWRST('XXX','BUG ')
20754        WRITE(ICOUT,152)
20755  152   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS FOR THE')
20756        CALL DPWRST('XXX','BUG ')
20757        WRITE(ICOUT,153)
20758  153   FORMAT('      RESPONSE VARIABLE IS LESS THAN 1.')
20759        CALL DPWRST('XXX','BUG ')
20760        WRITE(ICOUT,157)N
20761  157   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
20762     1         '.')
20763        CALL DPWRST('XXX','BUG ')
20764C
20765      ELSE
20766C
20767        Y(1)=X(1)
20768        YMAX=Y(1)
20769        DO100I=1,N
20770          IF(X(I).GT.YMAX)THEN
20771            Y(I)=X(I)
20772            YMAX=Y(I)
20773          ELSE
20774            Y(I)=YMAX
20775          ENDIF
20776  100   CONTINUE
20777      ENDIF
20778C
20779C               *****************
20780C               **  STEP 90--  **
20781C               **  EXIT.      **
20782C               *****************
20783C
20784      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'MMAX')THEN
20785        WRITE(ICOUT,999)
20786        CALL DPWRST('XXX','BUG ')
20787        WRITE(ICOUT,9011)
20788 9011   FORMAT('***** AT THE END       OF CUMMAX--')
20789        CALL DPWRST('XXX','BUG ')
20790        WRITE(ICOUT,9012)IERROR
20791 9012   FORMAT('IERROR = ',A4)
20792        CALL DPWRST('XXX','BUG ')
20793        DO9015I=1,N
20794          WRITE(ICOUT,9016)I,X(I),Y(I)
20795 9016     FORMAT('I,X(I),Y(I) = ',I8,2G15.7)
20796          CALL DPWRST('XXX','BUG ')
20797 9015   CONTINUE
20798      ENDIF
20799C
20800      RETURN
20801      END
20802      SUBROUTINE CUMMIN(X,N,IWRITE,Y,IBUGA3,ISUBRO,IERROR)
20803C
20804C     PURPOSE--COMPUTE CUMULATIVE MINIMUM OF A VARIABLE
20805C     NOTE--IT IS PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y(.)
20806C           BEING IDENTICAL TO THE INPUT VECTOR X(.).
20807C     WRITTEN BY--ALAN HECKERT
20808C                 STATISTICAL ENGINEERING DIVISION
20809C                 INFORMATION TECHNOLOGY LABORATORY
20810C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
20811C                 GAITHERSBURG, MD 20899
20812C                 PHONE--301-975-2899
20813C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
20814C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
20815C     LANGUAGE--ANSI FORTRAN (1977)
20816C     VERSION NUMBER--2012/12
20817C     ORIGINAL VERSION--DECEMBER  2012.
20818C
20819C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
20820C
20821      CHARACTER*4 IWRITE
20822      CHARACTER*4 IBUGA3
20823      CHARACTER*4 ISUBRO
20824      CHARACTER*4 IERROR
20825C
20826      CHARACTER*4 ISUBN1
20827      CHARACTER*4 ISUBN2
20828C
20829C---------------------------------------------------------------------
20830C
20831      DIMENSION X(*)
20832      DIMENSION Y(*)
20833C
20834C---------------------------------------------------------------------
20835C
20836      INCLUDE 'DPCOP2.INC'
20837C
20838C-----START POINT-----------------------------------------------------
20839C
20840      ISUBN1='CUMM'
20841      ISUBN2='IN  '
20842      IERROR='NO'
20843C
20844      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'MMIN')THEN
20845        WRITE(ICOUT,999)
20846  999   FORMAT(1X)
20847        CALL DPWRST('XXX','BUG ')
20848        WRITE(ICOUT,51)
20849   51   FORMAT('***** AT THE BEGINNING OF CUMMIN--')
20850        CALL DPWRST('XXX','BUG ')
20851        WRITE(ICOUT,52)IBUGA3,IWRITE,N
20852   52   FORMAT('IBUGA3,IWRITE,N = ',2(A4,2X),I8)
20853        CALL DPWRST('XXX','BUG ')
20854        DO55I=1,N
20855          WRITE(ICOUT,56)I,X(I)
20856   56     FORMAT('I,X(I) = ',I8,G15.7)
20857          CALL DPWRST('XXX','BUG ')
20858   55   CONTINUE
20859      ENDIF
20860C
20861C               ***********************************
20862C               **  COMPUTE CUMULATIVE MINIMUM.  **
20863C               ***********************************
20864C
20865      IF(N.LT.1)THEN
20866        IERROR='YES'
20867        WRITE(ICOUT,999)
20868        CALL DPWRST('XXX','BUG ')
20869        WRITE(ICOUT,151)
20870  151   FORMAT('***** ERROR IN CUMULATIVE MINIMUM--')
20871        CALL DPWRST('XXX','BUG ')
20872        WRITE(ICOUT,152)
20873  152   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS FOR THE')
20874        CALL DPWRST('XXX','BUG ')
20875        WRITE(ICOUT,153)
20876  153   FORMAT('      RESPONSE VARIABLE IS LESS THAN 1.')
20877        CALL DPWRST('XXX','BUG ')
20878        WRITE(ICOUT,157)N
20879  157   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
20880     1         '.')
20881        CALL DPWRST('XXX','BUG ')
20882C
20883      ELSE
20884C
20885        Y(1)=X(1)
20886        YMIN=Y(1)
20887        DO100I=1,N
20888          IF(X(I).LT.YMIN)THEN
20889            Y(I)=X(I)
20890            YMIN=Y(I)
20891          ELSE
20892            Y(I)=YMIN
20893          ENDIF
20894  100   CONTINUE
20895      ENDIF
20896C
20897C               *****************
20898C               **  STEP 90--  **
20899C               **  EXIT.      **
20900C               *****************
20901C
20902      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'MMIN')THEN
20903        WRITE(ICOUT,999)
20904        CALL DPWRST('XXX','BUG ')
20905        WRITE(ICOUT,9011)
20906 9011   FORMAT('***** AT THE END       OF CUMMIN--')
20907        CALL DPWRST('XXX','BUG ')
20908        WRITE(ICOUT,9012)IERROR
20909 9012   FORMAT('IERROR = ',A4)
20910        CALL DPWRST('XXX','BUG ')
20911        DO9015I=1,N
20912          WRITE(ICOUT,9016)I,X(I),Y(I)
20913 9016     FORMAT('I,X(I),Y(I) = ',I8,2G15.7)
20914          CALL DPWRST('XXX','BUG ')
20915 9015   CONTINUE
20916      ENDIF
20917C
20918      RETURN
20919      END
20920      SUBROUTINE CUMPRO(X,N,IWRITE,Y,IBUGA3,IERROR)
20921C
20922C     PURPOSE--COMPUTE CUMULATIVE PRODUCT OF A VARIABLE--
20923C              Y(1) = X(1)
20924C              Y(2) = X(1) * X(2)
20925C              Y(3) = X(1) * X(2) * X(3)
20926C              ETC.
20927C     NOTE--IT IS PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y(.)
20928C           BEING IDENTICAL TO THE INPUT VECTOR X(.).
20929C     WRITTEN BY--JAMES J. FILLIBEN
20930C                 STATISTICAL ENGINEERING DIVISION
20931C                 INFORMATION TECHNOLOGY LABORATORY
20932C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
20933C                 GAITHERSBURG, MD 20899
20934C                 PHONE--301-975-2855
20935C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
20936C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
20937C     LANGUAGE--ANSI FORTRAN (1977)
20938C     VERSION NUMBER--82/7
20939C     ORIGINAL VERSION--APRIL     1979.
20940C     UPDATED         --JULY      1979.
20941C     UPDATED         --AUGUST    1981.
20942C     UPDATED         --MAY       1982.
20943C
20944C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
20945C
20946      CHARACTER*4 IWRITE
20947      CHARACTER*4 IBUGA3
20948      CHARACTER*4 IERROR
20949C
20950      CHARACTER*4 ISUBN1
20951      CHARACTER*4 ISUBN2
20952C
20953C---------------------------------------------------------------------
20954C
20955      DIMENSION X(*)
20956      DIMENSION Y(*)
20957C
20958      DOUBLE PRECISION DPROD
20959      DOUBLE PRECISION DX
20960C
20961C---------------------------------------------------------------------
20962C
20963      INCLUDE 'DPCOP2.INC'
20964C
20965C-----START POINT-----------------------------------------------------
20966C
20967      ISUBN1='CUMP'
20968      ISUBN2='RO  '
20969      IERROR='NO'
20970C
20971      IF(IBUGA3.EQ.'ON')THEN
20972        WRITE(ICOUT,999)
20973  999   FORMAT(1X)
20974        CALL DPWRST('XXX','BUG ')
20975        WRITE(ICOUT,51)
20976   51   FORMAT('***** AT THE BEGINNING OF CUMPRO--')
20977        CALL DPWRST('XXX','BUG ')
20978        WRITE(ICOUT,52)IBUGA3,IWRITE,N
20979   52   FORMAT('IBUGA3,IWRITE,N = ',2(A4,2X),I8)
20980        CALL DPWRST('XXX','BUG ')
20981        DO55I=1,N
20982          WRITE(ICOUT,56)I,X(I)
20983   56     FORMAT('I,X(I) = ',I8,G15.7)
20984          CALL DPWRST('XXX','BUG ')
20985   55   CONTINUE
20986      ENDIF
20987C
20988C               ***********************************
20989C               **  COMPUTE CUMULATIVE PRODUCT.  **
20990C               ***********************************
20991C
20992      DPROD=1.0D0
20993      IF(N.LT.1)THEN
20994        IERROR='YES'
20995        WRITE(ICOUT,999)
20996        CALL DPWRST('XXX','BUG ')
20997        WRITE(ICOUT,151)
20998  151   FORMAT('***** ERROR IN CUMULATIVE PRODUCT--')
20999        CALL DPWRST('XXX','BUG ')
21000        WRITE(ICOUT,152)
21001  152   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS FOR THE')
21002        CALL DPWRST('XXX','BUG ')
21003        WRITE(ICOUT,153)
21004  153   FORMAT('      RESPONSE VARIABLE IS LESS THAN 1.')
21005        CALL DPWRST('XXX','BUG ')
21006        WRITE(ICOUT,157)N
21007  157   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
21008     1         '.')
21009        CALL DPWRST('XXX','BUG ')
21010      ELSE
21011        DO100I=1,N
21012          DX=X(I)
21013          DPROD=DPROD*DX
21014          Y(I)=DPROD
21015  100   CONTINUE
21016      ENDIF
21017C
21018C               *****************
21019C               **  STEP 90--  **
21020C               **  EXIT.      **
21021C               *****************
21022C
21023      IF(IBUGA3.EQ.'ON')THEN
21024        WRITE(ICOUT,999)
21025        CALL DPWRST('XXX','BUG ')
21026        WRITE(ICOUT,9011)
21027 9011   FORMAT('***** AT THE END       OF CUMPRO--')
21028        CALL DPWRST('XXX','BUG ')
21029        WRITE(ICOUT,9012)IERROR
21030 9012   FORMAT('IERROR = ',A4)
21031        CALL DPWRST('XXX','BUG ')
21032        DO9015I=1,N
21033          WRITE(ICOUT,9016)I,X(I),Y(I)
21034 9016     FORMAT('I,X(I),Y(I) = ',I8,2G15.7)
21035          CALL DPWRST('XXX','BUG ')
21036 9015   CONTINUE
21037      ENDIF
21038C
21039      RETURN
21040      END
21041      SUBROUTINE CUMSTA(Y1,Y2,Y3,N,NUMV,ICASS7,MAXNXT,
21042     1                  ISEED,ICSTSV,
21043     1                  TEMP1,TEMP2,TEMP3,
21044     1                  ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
21045     1                  DTEMP1,DTEMP2,DTEMP3,
21046     1                  YOUT,NOUT,
21047     1                  ISUBRO,IBUGA3,IERROR)
21048C
21049C     PURPOSE--COMPUTE A "CUMULATIVE" STATISTIC.  ALTHOUGH THIS IS TYPICALLY
21050C              USED FOR A LOCATION STATISTIC, IN CAN BE USED FOR ANY
21051C              SUPPORTED STATISTIC.  NOTE THAT A FEW SPECIFIC STATISTICS
21052C              ARE GENERATED SEPARATELY FROM THIS SUBROUTINE.  THESE
21053C              ARE TYPICALLY GENERATED MORE EFFICIENTLY THAN THIS ROUTINE
21054C              WHICH SIMPLY LOOPS THROUGH THE ARRAY AND CALLS CMPSTA TO
21055C              COMPUTE THE STATISTIC.
21056C     WRITTEN BY--ALAN HECKERT
21057C                 STATISTICAL ENGINEERING DIVISION
21058C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
21059C                 GAITHERSBURG, MD 20899-8980
21060C                 PHONE--301-975-2899
21061C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
21062C           OF THE NATIONAL BUREAU OF STANDARDS.
21063C     LANGUAGE--ANSI FORTRAN (1977)
21064C     VERSION NUMBER--2013/01
21065C     ORIGINAL VERSION--JANUARY     2013.
21066C     UPDATED         --MARCH       2013. CUMULATIVE STATISTIC START
21067C
21068C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
21069C
21070      CHARACTER*4 ICASS7
21071      CHARACTER*4 ISUBRO
21072      CHARACTER*4 IBUGA3
21073      CHARACTER*4 IERROR
21074C
21075      CHARACTER*4 ISUBN1
21076      CHARACTER*4 ISUBN2
21077C
21078C---------------------------------------------------------------------
21079C
21080      DIMENSION Y1(*)
21081      DIMENSION Y2(*)
21082      DIMENSION Y3(*)
21083      DIMENSION YOUT(*)
21084C
21085      DIMENSION TEMP1(*)
21086      DIMENSION TEMP2(*)
21087      DIMENSION TEMP3(*)
21088      INTEGER ITEMP1(*)
21089      INTEGER ITEMP2(*)
21090      INTEGER ITEMP3(*)
21091      INTEGER ITEMP4(*)
21092      INTEGER ITEMP5(*)
21093      INTEGER ITEMP6(*)
21094      DOUBLE PRECISION DTEMP1(*)
21095      DOUBLE PRECISION DTEMP2(*)
21096      DOUBLE PRECISION DTEMP3(*)
21097C
21098C---------------------------------------------------------------------
21099C
21100      INCLUDE 'DPCOP2.INC'
21101C
21102C-----START POINT-----------------------------------------------------
21103C
21104      ISUBN1='CUMS'
21105      ISUBN2='TA  '
21106C
21107      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'MSTA')THEN
21108        WRITE(ICOUT,70)
21109   70   FORMAT('AT THE BEGINNING OF CUMSTA--')
21110        CALL DPWRST('XXX','BUG ')
21111        WRITE(ICOUT,71)ICASS7,N,ICSTSV
21112   71   FORMAT('ICASS7,N,ICSTSV = ',A4,2X,2I8)
21113        CALL DPWRST('XXX','BUG ')
21114        DO75I=1,N
21115          WRITE(ICOUT,73)I,Y1(I),Y2(I),Y3(I)
21116   73     FORMAT('I,Y1(I),Y2(I),Y3(I) = ',I8,3G15.7)
21117          CALL DPWRST('XXX','BUG ')
21118   75   CONTINUE
21119      ENDIF
21120C
21121C     CHECK THE INPUT ARGUMENTS FOR ERRORS
21122C
21123      IF(N.LT.2)THEN
21124        WRITE(ICOUT,999)
21125  999   FORMAT(1X)
21126        CALL DPWRST('XXX','BUG ')
21127        WRITE(ICOUT,31)
21128   31   FORMAT('***** ERROR IN CUMULATIVE <STAT> COMMAND--')
21129        CALL DPWRST('XXX','BUG ')
21130        WRITE(ICOUT,32)
21131   32   FORMAT('      THE NUMBER OF OBSERVATIONS IS LESS THAN TWO.')
21132        CALL DPWRST('XXX','BUG ')
21133        WRITE(ICOUT,34)N
21134   34   FORMAT('      THE NUMBER OF OBSERVATIONS = ',I8)
21135        CALL DPWRST('XXX','BUG ')
21136        WRITE(ICOUT,999)
21137        CALL DPWRST('XXX','BUG ')
21138        IERROR='YES'
21139        GOTO9000
21140      ENDIF
21141C
21142C               ******************************************************
21143C               **  STEP 1--LOOP THROUGH AND COMPUTE THE STATISTIC  **
21144C               ******************************************************
21145C
21146C     MARCH 2013: SOME STATISTICS REQUIRE A MINIMUM NUMBER OF VALUES
21147C                 IN ORDER TO COMPUTE.  USER CAN ENTER THE COMMAND
21148C
21149C                    SET CUMULATIVE STATISTIC START <IVAL>
21150C
21151C                 TO SPECIFY A MINIMUM NUMBER OF VALUES BEFORE START
21152C                 COMPUTING THE STATISTIC.
21153C
21154      NOUT=0
21155      ISTRT=ICSTSV
21156      IF(ISTRT.LT.1 .OR. ISTRT.GT.N)ISTRT=1
21157      DO1010I=ISTRT,N
21158        NTEMP=I
21159        CALL CMPSTA(Y1,Y2,Y3,TEMP1,TEMP2,TEMP3,
21160     1              MAXNXT,NTEMP,NTEMP,NTEMP,NUMV,ICASS7,
21161     1              ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
21162     1              DTEMP1,DTEMP2,DTEMP3,
21163CCCCC1              IQUAME,IQUASE,PSTAMV,
21164     1              STAT,
21165     1              ISUBRO,IBUGA3,IERROR)
21166        IF(IERROR.EQ.'YES')GOTO9000
21167        NOUT=NOUT+1
21168        YOUT(NOUT)=STAT
21169 1010 CONTINUE
21170C
21171C               ******************
21172C               **   STEP 90--  **
21173C               **   EXIT       **
21174C               ******************
21175C
21176 9000 CONTINUE
21177      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'MSTA')THEN
21178        WRITE(ICOUT,999)
21179        CALL DPWRST('XXX','BUG ')
21180        WRITE(ICOUT,9011)
21181 9011   FORMAT('***** AT THE END       OF CUMSTA--')
21182        CALL DPWRST('XXX','BUG ')
21183        WRITE(ICOUT,9013)NOUT
21184 9013   FORMAT('NOUT = ',I8)
21185        CALL DPWRST('XXX','BUG ')
21186        IF(NOUT.GE.1)THEN
21187          DO9021I=1,NOUT
21188            WRITE(ICOUT,9023)I,YOUT(I)
21189 9023       FORMAT('I,YOUT(I) = ',I8,G15.7)
21190            CALL DPWRST('XXX','BUG ')
21191 9021     CONTINUE
21192        ENDIF
21193      ENDIF
21194C
21195      RETURN
21196      END
21197      SUBROUTINE CUMSUM(X,N,IWRITE,Y,IBUGA3,IERROR)
21198C
21199C     PURPOSE--COMPUTE CUMULATIVE SUM OF A VARIABLE--
21200C              Y(1) = X(1)
21201C              Y(2) = X(1) + X(2)
21202C              Y(3) = X(1) + X(2) + X(3)
21203C              ETC.
21204C     NOTE--IT IS PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y(.)
21205C           BEING IDENTICAL TO THE INPUT VECTOR X(.).
21206C     WRITTEN BY--JAMES J. FILLIBEN
21207C                 STATISTICAL ENGINEERING DIVISION
21208C                 INFORMATION TECHNOLOGY LABORATORY
21209C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
21210C                 GAITHERSBURG, MD 20899
21211C                 PHONE--301-975-2855
21212C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
21213C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
21214C     LANGUAGE--ANSI FORTRAN (1977)
21215C     VERSION NUMBER--82/7
21216C     ORIGINAL VERSION--FEBRUARY  1979.
21217C     UPDATED         --APRIL     1979.
21218C     UPDATED         --JULY      1979.
21219C     UPDATED         --AUGUST    1981.
21220C     UPDATED         --MAY       1982.
21221C
21222C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
21223C
21224      CHARACTER*4 IWRITE
21225      CHARACTER*4 IBUGA3
21226      CHARACTER*4 IERROR
21227C
21228      CHARACTER*4 ISUBN1
21229      CHARACTER*4 ISUBN2
21230C
21231C---------------------------------------------------------------------
21232C
21233      DIMENSION X(*)
21234      DIMENSION Y(*)
21235C
21236      DOUBLE PRECISION DSUM
21237      DOUBLE PRECISION DX
21238C
21239C---------------------------------------------------------------------
21240C
21241      INCLUDE 'DPCOP2.INC'
21242C
21243C-----START POINT-----------------------------------------------------
21244C
21245      ISUBN1='CUMS'
21246      ISUBN2='UM  '
21247      IERROR='NO'
21248C
21249      IF(IBUGA3.EQ.'ON')THEN
21250        WRITE(ICOUT,999)
21251  999   FORMAT(1X)
21252        CALL DPWRST('XXX','BUG ')
21253        WRITE(ICOUT,51)
21254   51   FORMAT('***** AT THE BEGINNING OF CUMSUM--')
21255        CALL DPWRST('XXX','BUG ')
21256        WRITE(ICOUT,52)IBUGA3,IWRITE,N
21257   52   FORMAT('IBUGA3,IWRITE,N = ',2(A4,2X),I8)
21258        CALL DPWRST('XXX','BUG ')
21259        DO55I=1,N
21260          WRITE(ICOUT,56)I,X(I)
21261   56     FORMAT('I,X(I) = ',I8,G15.7)
21262          CALL DPWRST('XXX','BUG ')
21263   55   CONTINUE
21264      ENDIF
21265C
21266C               *******************************
21267C               **  COMPUTE CUMULATIVE SUM.  **
21268C               *******************************
21269C
21270      DSUM=0.0D0
21271      IF(N.LT.1)THEN
21272        IERROR='YES'
21273        WRITE(ICOUT,999)
21274        CALL DPWRST('XXX','BUG ')
21275        WRITE(ICOUT,151)
21276  151   FORMAT('***** ERROR IN CUMULATIVE SUM--')
21277        CALL DPWRST('XXX','BUG ')
21278        WRITE(ICOUT,152)
21279  152   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS FOR THE')
21280        CALL DPWRST('XXX','BUG ')
21281        WRITE(ICOUT,153)
21282  153   FORMAT('      RESPONSE VARIABLE IS LESS THAN 1.')
21283        CALL DPWRST('XXX','BUG ')
21284        WRITE(ICOUT,157)N
21285  157   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
21286     1         '.')
21287        CALL DPWRST('XXX','BUG ')
21288      ELSE
21289        DO100I=1,N
21290          DX=X(I)
21291          DSUM=DSUM+DX
21292          Y(I)=DSUM
21293  100   CONTINUE
21294      ENDIF
21295C
21296C               *****************
21297C               **  STEP 90--  **
21298C               **  EXIT.      **
21299C               *****************
21300C
21301      IF(IBUGA3.EQ.'ON')THEN
21302        WRITE(ICOUT,999)
21303        CALL DPWRST('XXX','BUG ')
21304        WRITE(ICOUT,9011)
21305 9011   FORMAT('***** AT THE END       OF CUMSUM--')
21306        CALL DPWRST('XXX','BUG ')
21307        WRITE(ICOUT,9012)IERROR
21308 9012   FORMAT('IERROR = ',A4)
21309        CALL DPWRST('XXX','BUG ')
21310        DO9015I=1,N
21311          WRITE(ICOUT,9016)I,X(I),Y(I)
21312 9016     FORMAT('I,X(I),Y(I) = ',I8,2G15.7)
21313          CALL DPWRST('XXX','BUG ')
21314 9015   CONTINUE
21315      ENDIF
21316C
21317      RETURN
21318      END
21319      SUBROUTINE cumtnc(t,df,pnonc,cum,ccum)
21320C
21321C     2017/01: THIS ROUTINE IS FROM THE DCDFLIB LIBRARY OF BARRY BROWN,
21322C              JAMES LAVATO, AND KATHY RUSSELL.
21323C
21324C              THE MAIN MODIFICATION OF THIS ROUTINE IS TO REPLACE
21325C              GAMLN, CUMT, CUMNOR, AND BRATIO WITH ROUTINES THAT ARE
21326C              ALREADY IN DATAPLOT.
21327C
21328C**********************************************************************
21329C
21330C     SUBROUTINE CUMTNC(T,DF,PNONC,CUM,CCUM)
21331C
21332C                 CUMulative Non-Central T-distribution
21333C
21334C
21335C                              Function
21336C
21337C
21338C     Computes the integral from -infinity to T of the non-central
21339C     t-density.
21340C
21341C
21342C                              Arguments
21343C
21344C
21345C     T --> Upper limit of integration of the non-central t-density.
21346C                                                  T is DOUBLE PRECISION
21347C
21348C     DF --> Degrees of freedom of the non-central t-distribution.
21349C                                                  DF is DOUBLE PRECISIO
21350C
21351C     PNONC --> Non-centrality parameter of the non-central t distibutio
21352C                                                  PNONC is DOUBLE PRECI
21353C
21354C     CUM <-- Cumulative t-distribution.
21355C                                                  CCUM is DOUBLE PRECIS
21356C
21357C     CCUM <-- Compliment of Cumulative t-distribution.
21358C                                                  CCUM is DOUBLE PRECIS
21359C
21360C
21361C                              Method
21362C
21363C     Upper tail    of  the  cumulative  noncentral t   using
21364C     formulae from page 532  of Johnson, Kotz,  Balakrishnan, Coninuous
21365C     Univariate Distributions, Vol 2, 2nd Edition.  Wiley (1995)
21366C
21367C     This implementation starts the calculation at i = lambda,
21368C     which is near the largest Di.  It then sums forward and backward.
21369C***********************************************************************
21370C     .. Parameters ..
21371
21372      DOUBLE PRECISION one,zero,half,two,onep5
21373      PARAMETER (one=1.0d0,zero=0.0d0,half=0.5d0,two=2.0d0,onep5=1.5d0)
21374      DOUBLE PRECISION conv
21375      PARAMETER (conv=1.0d-7)
21376      DOUBLE PRECISION tiny
21377      PARAMETER (tiny=1.0d-10)
21378C     ..
21379C     .. Scalar Arguments ..
21380      DOUBLE PRECISION ccum,cum,df,pnonc,t
21381C     ..
21382C     .. Local Scalars ..
21383      DOUBLE PRECISION alghdf,b,bb,bbcent,bcent,cent,d,dcent,dpnonc,
21384     +                 dum1,dum2,e,ecent,halfdf,lambda,lnomx,lnx,omx,
21385     +                 pnonc2,s,scent,ss,sscent,t2,term,tt,twoi,x,
21386     +                 xi,xlnd,xlne
21387      INTEGER ierr
21388      LOGICAL qrevs
21389C     ..
21390C     .. External Functions ..
21391CCCCC DOUBLE PRECISION gamln
21392CCCCC EXTERNAL gamln
21393      DOUBLE PRECISION DLNGAM
21394      EXTERNAL DLNGAM
21395C     ..
21396C     .. External Subroutines ..
21397CCCCC EXTERNAL bratio,cumnor,cumt
21398      EXTERNAL bratio
21399C     ..
21400C     .. Intrinsic Functions ..
21401      INTRINSIC abs,exp,int,log,max,min
21402C     ..
21403
21404C
21405      dum1=0.0
21406      dum2=0.0
21407C
21408C     Case pnonc essentially zero
21409
21410      IF (abs(pnonc).LE.tiny) THEN
21411ccccc     CALL cumt(t,df,cum,ccum)
21412          CALL tdcdf(t,df,cum)
21413          ccum=1.0d0 - cum
21414          RETURN
21415
21416      END IF
21417
21418      qrevs = t .LT. zero
21419      IF (qrevs) THEN
21420          tt = -t
21421          dpnonc = -pnonc
21422
21423      ELSE
21424          tt = t
21425          dpnonc = pnonc
21426      END IF
21427
21428      pnonc2 = dpnonc*dpnonc
21429      t2 = tt*tt
21430
21431      IF (abs(tt).LE.tiny) THEN
21432ccccc     CALL cumnor(-pnonc,cum,ccum)
21433          CALL nodcdf(-pnonc,cum)
21434          ccum=1.0d0 - cum
21435          RETURN
21436
21437      END IF
21438
21439      lambda = half*pnonc2
21440      x = df/ (df+t2)
21441      omx = one - x
21442
21443      lnx = log(x)
21444      lnomx = log(omx)
21445
21446      halfdf = half*df
21447ccccc alghdf = gamln(halfdf)
21448      alghdf = DLNGAM(halfdf)
21449
21450C     ******************** Case i = lambda
21451
21452      cent = int(lambda)
21453
21454      IF (cent.LT.one) cent = one
21455
21456C     Compute d=T(2i) in log space and offset by exp(-lambda)
21457
21458ccccc xlnd = cent*log(lambda) - gamln(cent+one) - lambda
21459      xlnd = cent*log(lambda) - dlngam(cent+one) - lambda
21460
21461      dcent = exp(xlnd)
21462
21463C     Compute e=t(2i+1) in log space offset by exp(-lambda)
21464
21465ccccc xlne = (cent+half)*log(lambda) - gamln(cent+onep5) - lambda
21466      xlne = (cent+half)*log(lambda) - dlngam(cent+onep5) - lambda
21467      ecent = exp(xlne)
21468
21469      IF (dpnonc.LT.zero) ecent = -ecent
21470
21471C     Compute bcent=B(2*cent)
21472
21473      CALL bratio(halfdf,cent+half,x,omx,bcent,dum1,ierr)
21474CCCCC bcent=dbetai(x,halfdf,cent+half)
21475
21476C     compute bbcent=B(2*cent+1)
21477
21478      CALL bratio(halfdf,cent+one,x,omx,bbcent,dum2,ierr)
21479CCCCC bbcent=dbetai(x,halfdf,cent+one)
21480
21481C     Case bcent and bbcent are essentially zero
21482C     Thus t is effectively infinite
21483
21484      IF ((bcent+bbcent).LT.tiny) THEN
21485          IF (qrevs) THEN
21486              cum = zero
21487              ccum = one
21488
21489          ELSE
21490              cum = one
21491              ccum = zero
21492          END IF
21493
21494          RETURN
21495
21496      END IF
21497
21498C     Case bcent and bbcent are essentially one
21499C     Thus t is effectively zero
21500
21501      IF ((dum1+dum2).LT.tiny) THEN
21502ccccc     CALL cumnor(-pnonc,cum,ccum)
21503          CALL nodcdf(-pnonc,cum)
21504          ccum=1.0d0 - cum
21505          RETURN
21506
21507      END IF
21508
21509C     First term in ccum is D*B + E*BB
21510
21511      ccum = dcent*bcent + ecent*bbcent
21512
21513C     compute s(cent) = B(2*(cent+1)) - B(2*cent))
21514
21515ccccc scent = gamln(halfdf+cent+half) - gamln(cent+onep5) - alghdf +
21516      scent = dlngam(halfdf+cent+half) - dlngam(cent+onep5) - alghdf +
21517     +        halfdf*lnx + (cent+half)*lnomx
21518      scent = exp(scent)
21519
21520C     compute ss(cent) = B(2*cent+3) - B(2*cent+1)
21521
21522ccccc sscent = gamln(halfdf+cent+one) - gamln(cent+two) - alghdf +
21523      sscent = dlngam(halfdf+cent+one) - dlngam(cent+two) - alghdf +
21524     +         halfdf*lnx + (cent+one)*lnomx
21525      sscent = exp(sscent)
21526
21527C     ******************** Sum Forward
21528
21529      xi = cent + one
21530      twoi = two*xi
21531
21532      d = dcent
21533
21534      e = ecent
21535
21536      b = bcent
21537
21538      bb = bbcent
21539
21540      s = scent
21541
21542      ss = sscent
21543
21544   10 b = b + s
21545      bb = bb + ss
21546
21547      d = (lambda/xi)*d
21548      e = (lambda/ (xi+half))*e
21549
21550      term = d*b + e*bb
21551
21552      ccum = ccum + term
21553
21554      s = s*omx* (df+twoi-one)/ (twoi+one)
21555
21556      ss = ss*omx* (df+twoi)/ (twoi+two)
21557
21558      xi = xi + one
21559      twoi = two*xi
21560
21561      IF (abs(term).GT.conv*ccum) GO TO 10
21562
21563C     ******************** Sum Backward
21564
21565      xi = cent
21566      twoi = two*xi
21567
21568      d = dcent
21569
21570      e = ecent
21571
21572      b = bcent
21573
21574      bb = bbcent
21575
21576      s = scent* (one+twoi)/ ((df+twoi-one)*omx)
21577
21578      ss = sscent* (two+twoi)/ ((df+twoi)*omx)
21579
21580   20 b = b - s
21581      bb = bb - ss
21582
21583      d = d* (xi/lambda)
21584
21585      e = e* ((xi+half)/lambda)
21586
21587      term = d*b + e*bb
21588
21589      ccum = ccum + term
21590
21591      xi = xi - one
21592
21593      IF (xi.LT.half) GO TO 30
21594
21595      twoi = two*xi
21596
21597      s = s* (one+twoi)/ ((df+twoi-one)*omx)
21598
21599      ss = ss* (two+twoi)/ ((df+twoi)*omx)
21600
21601      IF (abs(term).GT.conv*ccum) GO TO 20
21602
21603   30 CONTINUE
21604
21605      IF (qrevs) THEN
21606          cum = half*ccum
21607          ccum = one - cum
21608
21609      ELSE
21610          ccum = half*ccum
21611          cum = one - ccum
21612      END IF
21613
21614C     Due to roundoff error the answer may not lie between zero and one
21615C     Force it to do so
21616
21617      cum = max(min(cum,one),zero)
21618      ccum = max(min(ccum,one),zero)
21619
21620      RETURN
21621
21622      END
21623      SUBROUTINE CURVE (P, X, N0, N, EPS, MAXITR, MU, SIGMA, ITER,
21624     1   SEMU, SESIG, COVAR, E0, EX, CHISQ,
21625     1   F, F1, XN,
21626     1   FUNC,
21627     1   IFAULT)
21628C
21629C       ALGORITHM AS 95 APPL. STATIST. (1976) VOL.25, NO.1
21630C
21631C       ESTIMATES MU AND SIGMA OF DISTRIBUTION FUNCTION
21632C       F( (X-MU)/SIGMA ) FROM A GROUPED SAMPLE OF X VALUES.
21633C       NOTE ON ARRAY SIZES
21634C       THE ARRAYS IN THE SECOND DIMENSION STATEMENT MUST HAVE
21635C       MINIMUM SIZE P.  IF P IS TO EXCEED 20, A SUITABLE SIZE
21636C       MUST BE SET FOR THEM, AND THE IF STATEMENT WHICH CHECKS
21637C       THE VALUE OF P MUST BE AMENDED.
21638C
21639C     Auxiliary routines required: FUNC & DEVIAT (both user-supplied)
21640C
21641      PARAMETER (MAXCLA=1000)
21642C
21643      INTEGER P
21644      REAL NN, NI, NP, MU, ONE, ZERO
21645      DIMENSION X(*), N(*), EX(*)
21646      DIMENSION F(*), F1(*), XN(*)
21647C
21648      EXTERNAL FUNC
21649C
21650      DATA RR/1.0E-10/
21651      DATA ONE/1.0/
21652      DATA ZERO/0.0/
21653C
21654      E=0.0
21655      D=0.0
21656      C=0.0
21657      DENOM=0.0
21658C
21659C       ERROR EXIT IF P TOO SMALL OR TOO LARGE
21660C
21661      IF (P.LT.2 .OR. P.GT.MAXCLA) THEN
21662         IFAULT = 1
21663         GOTO9000
21664      END IF
21665C
21666      IFAULT = 0
21667C
21668C       SET FREQUENCIES IN FLOATING POINT
21669C
21670      XN0 = N0
21671      NSUM = N0
21672      DO 10 I = 1, P
21673        XN(I) = N(I)
21674        NSUM = NSUM + N(I)
21675 10   CONTINUE
21676      K = P - 1
21677      XNSUM = REAL(NSUM)
21678      NP = XN(P)
21679C
21680C       ITERATIVE APPROXIMATION
21681C
21682      DO 40 ITER = 1, MAXITR
21683C
21684C       COMPUTE VALUES OF DISTRIBUTION AND DENSITY FUNCTIONS,
21685C       USING CURRENT VALUES OF MU, SIGMA
21686C
21687        DO 20 I = 1, P
21688          CALL FUNC ((X(I) - MU)/SIGMA, F(I), F1(I))
21689 20     CONTINUE
21690        DM = ONE - F(P)
21691C
21692C
21693C       TEST FOR SMALL DIVISOR TO AVOID OVERFLOW
21694C
21695        IF (ABS(DM).LT.RR) THEN
21696           IFAULT=2
21697           GO TO 9000
21698        ENDIF
21699C
21700        F1P = F1(P)
21701        IF (ABS(F(1)).LT.RR) THEN
21702           IFAULT=2
21703           GO TO 9000
21704        ENDIF
21705C
21706        XI1 = X(1) - MU
21707        XP = X(P) - MU
21708        R = F1(1)/F(1)
21709        S = F1P/DM
21710        T = -XN0*R
21711        U = NP*S
21712        A = T + U
21713        B = XI1*T + XP*U
21714        R = F1(1)*R
21715        S = F1P*S
21716        C = R + S
21717        R = XI1*S
21718        S = XP*S
21719        D = R + S
21720        E = XI1*R + XP*S
21721        DO 30 I = 1, K
21722          FI = F(I)
21723          FI1 = F(I + 1)
21724          F1I1 = F1(I + 1)
21725          F1I = F1(I)
21726          XI = XI1
21727          XI1 = X(I + 1) - MU
21728          NI = XN(I)
21729          R = FI1 - FI
21730C
21731          IF (ABS(R).LT.RR) THEN
21732             IFAULT=2
21733             GO TO 9000
21734          ENDIF
21735C
21736          S = F1I1 - F1I
21737          U = XI1*F1I1 - XI*F1I
21738          SR = S/R
21739          UR = U/R
21740          A = A - NI*SR
21741          B = B - NI*UR
21742          C = C + S*SR
21743          D = D + S*UR
21744          E = E + U*UR
21745 30     CONTINUE
21746        DENOM = (C*E - D*D)*XNSUM
21747C
21748C       COMPUTE ADJUSTMENTS TO MU, SIGMA
21749C
21750        SIGDEN = SIGMA/DENOM
21751        DMU = (E*A - D*B)*SIGDEN
21752        DSIGMA = (C*B - D*A)*SIGMA*SIGDEN
21753        MU = MU + DMU
21754        SIGMA = SIGMA + DSIGMA
21755        ERR = ABS(DMU) + ABS(DSIGMA)
21756C
21757C       TEST FOR CONVERGENCE
21758C
21759        IF (ERR.LT.EPS) GOTO50
21760 40   CONTINUE
21761C
21762C     SET FAULT IF LIMIT FOR NUMBER OF ITERATIONS IS
21763C     REACHED, THEN PROCEED
21764C
21765      IFAULT = 4
21766      ITER = MAXITR
21767C
21768 50   CONTINUE
21769      DO 60 I = 1, P
21770        CALL FUNC ((X(I) - MU)/SIGMA, F(I), DUM)
21771 60   CONTINUE
21772C
21773C     COMPUTE VARIANCES AND COVARIANCE OF ESTIMATES
21774C
21775      SIGDEN = SIGMA*SIGMA/DENOM
21776      VARMU = E*SIGDEN
21777      SIGDEN = SIGMA*SIGDEN
21778      COVAR = -D*SIGDEN
21779      VARSIG = C*SIGMA*SIGDEN
21780      IF (VARMU.LT.ZERO .OR. VARSIG.LT.ZERO) THEN
21781         IFAULT=3
21782         GO TO 9000
21783      ENDIF
21784C
21785      SEMU = SQRT(VARMU)
21786      SESIG = SQRT(VARSIG)
21787C
21788C       COMPUTE EXPECTED FREQUENCIES AND CHI SQUARE
21789C
21790      E0 = XNSUM*F(1)
21791      EP = XNSUM*(ONE - F(P))
21792      EX(P) = EP
21793      CHISQ = ((XN0 - E0)**2)/E0 + ((NP - EP)**2)/EP
21794      DO 70 I = 1, K
21795        NN = XNSUM*(F(I+1) - F(I))
21796        CHISQ = CHISQ + ((NN - XN(I))**2)/NN
21797        EX(I) = NN
21798 70   CONTINUE
21799C
21800 9000 CONTINUE
21801      RETURN
21802      END
21803      SUBROUTINE CUSARL(X,NX,IWRITE,Y,ICASE,IBUGA3,IERROR)
21804C
21805C     PURPOSE--COMPUTE CUMULATIVE SUM ARL.
21806C              USE APPLIED STATISTICS ALGORITHM AS 258.
21807C     WRITTEN BY--ALAN HECKERT
21808C                 STATISTICAL ENGINEERING DIVISION
21809C                 INFORMATION TECHNOLOGY LABORATORY
21810C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
21811C                 GAITHERSBURG, MD 20899
21812C                 PHONE--301-975-2899
21813C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
21814C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
21815C     LANGUAGE--ANSI FORTRAN (1977)
21816C     VERSION NUMBER--99/3
21817C     ORIGINAL VERSION--MARCH    1999.
21818C
21819C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
21820C
21821      CHARACTER*4 IWRITE
21822      CHARACTER*4 ICASE
21823      CHARACTER*4 IBUGA3
21824      CHARACTER*4 IERROR
21825C
21826      CHARACTER*4 ISUBN1
21827      CHARACTER*4 ISUBN2
21828      CHARACTER*4 IHWUSE
21829      CHARACTER*4 MESSAG
21830      CHARACTER*4 IHP
21831      CHARACTER*4 IHP2
21832C
21833C---------------------------------------------------------------------
21834C
21835      DIMENSION X(*)
21836      DIMENSION Y(*)
21837C
21838C---------------------------------------------------------------------
21839C
21840      INCLUDE 'DPCOPA.INC'
21841      INCLUDE 'DPCOHK.INC'
21842      INCLUDE 'DPCOP2.INC'
21843C
21844C-----START POINT-----------------------------------------------------
21845C
21846      ISUBN1='CUSA'
21847      ISUBN2='RL  '
21848      IERROR='NO'
21849C
21850      IF(IBUGA3.EQ.'ON')THEN
21851        WRITE(ICOUT,999)
21852  999   FORMAT(1X)
21853        CALL DPWRST('XXX','BUG ')
21854        WRITE(ICOUT,51)
21855   51   FORMAT('***** AT THE BEGINNING OF CUSARL--')
21856        CALL DPWRST('XXX','BUG ')
21857        WRITE(ICOUT,52)ICASE,IBUGA3,IWRITE,NX
21858   52   FORMAT('ICAE,IBUGA3,IWRITE,NX = ',3(A4,2X),I8)
21859        CALL DPWRST('XXX','BUG ')
21860        DO55I=1,NX
21861          WRITE(ICOUT,56)I,X(I)
21862   56     FORMAT('I,X(I) = ',I8,G15.7)
21863          CALL DPWRST('XXX','BUG ')
21864   55   CONTINUE
21865      ENDIF
21866C
21867C               *********************************************
21868C               **  CHECK FOR PARAMERERS: DELTA, S0, K, H  **
21869C               *********************************************
21870C
21871      IHP='S0  '
21872      IHP2='    '
21873      IHWUSE='P'
21874      MESSAG='NO'
21875      CALL CHECKN(IHP,IHP2,IHWUSE,
21876     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
21877     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
21878      IF(IERROR.EQ.'YES')THEN
21879        S0=0.0
21880      ELSE
21881        S0=VALUE(ILOCP)
21882      ENDIF
21883C
21884      IHP='K   '
21885      IHP2='    '
21886      IHWUSE='P'
21887      MESSAG='YES'
21888      CALL CHECKN(IHP,IHP2,IHWUSE,
21889     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
21890     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
21891      IF(IERROR.EQ.'YES')GOTO9000
21892      AK=VALUE(ILOCP)
21893C
21894      IF(AK.LT.0)THEN
21895        WRITE(ICOUT,999)
21896        CALL DPWRST('XXX','BUG ')
21897        WRITE(ICOUT,16211)
2189816211 FORMAT('***** ERROR IN CUSARL--')
21899        CALL DPWRST('XXX','BUG ')
21900        WRITE(ICOUT,16212)
2190116212 FORMAT('      THE SPECIFIED PARAMETER K')
21902        CALL DPWRST('XXX','BUG ')
21903        WRITE(ICOUT,16213)
2190416213 FORMAT('      FOR THE CUMULATIVE SUM AVERAGE RUN LENGTH')
21905        CALL DPWRST('XXX','BUG ')
21906        WRITE(ICOUT,16214)
2190716214 FORMAT('      MUST BE GREATER THAN OR EQUAL TO 0;')
21908        CALL DPWRST('XXX','BUG ')
21909        WRITE(ICOUT,16215)
2191016215 FORMAT('      SUCH WAS NOT THE CASE HERE.')
21911        CALL DPWRST('XXX','BUG ')
21912        WRITE(ICOUT,16216)AK
2191316216 FORMAT('      THE SPECIFIED VALUE OF K = ',E15.7)
21914        CALL DPWRST('XXX','BUG ')
21915        IERROR='YES'
21916        GOTO9000
21917      ENDIF
21918C
21919      IHP='H   '
21920      IHP2='    '
21921      IHWUSE='P'
21922      MESSAG='YES'
21923      CALL CHECKN(IHP,IHP2,IHWUSE,
21924     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
21925     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
21926      IF(IERROR.EQ.'YES')GOTO9000
21927      AH=VALUE(ILOCP)
21928C
21929      IF(AH.LT.0)THEN
21930        WRITE(ICOUT,999)
21931        CALL DPWRST('XXX','BUG ')
21932        WRITE(ICOUT,16311)
2193316311 FORMAT('***** ERROR IN CUSARL--')
21934        CALL DPWRST('XXX','BUG ')
21935        WRITE(ICOUT,16312)
2193616312 FORMAT('      THE SPECIFIED PARAMETER H')
21937        CALL DPWRST('XXX','BUG ')
21938        WRITE(ICOUT,16313)
2193916313 FORMAT('      FOR THE CUMULATIVE SUM AVERAGE RUN LENGTH')
21940        CALL DPWRST('XXX','BUG ')
21941        WRITE(ICOUT,16314)
2194216314 FORMAT('      MUST BE GREATER THAN OR EQUAL TO 0;')
21943        CALL DPWRST('XXX','BUG ')
21944        WRITE(ICOUT,16315)
2194516315 FORMAT('      SUCH WAS NOT THE CASE HERE.')
21946        CALL DPWRST('XXX','BUG ')
21947        WRITE(ICOUT,16316)AH
2194816316 FORMAT('      THE SPECIFIED VALUE OF K = ',E15.7)
21949        CALL DPWRST('XXX','BUG ')
21950        IERROR='YES'
21951        GOTO9000
21952      ENDIF
21953C
21954      DO100I=1,NX
21955        DELTA=X(I)
21956        IF(ICASE.EQ.'TWOS')THEN
21957          CALL ARL2(DELTA,AK,AH,S0,ARL,ARLFIR,IFAULT)
21958        ELSE
21959          CALL ARL1(DELTA,AK,AH,S0,ARL,ARLFIR,IFAULT)
21960        ENDIF
21961        IF(IFAULT.EQ.1)THEN
21962          WRITE(ICOUT,999)
21963          CALL DPWRST('XXX','BUG ')
21964          WRITE(ICOUT,141)
21965  141 FORMAT('***** ERROR IN CUSARL--')
21966          CALL DPWRST('XXX','BUG ')
21967          WRITE(ICOUT,143)
21968  143 FORMAT('      ERROR IN INPUT ARGUMENTS TO ARL ROUTINE.')
21969          CALL DPWRST('XXX','BUG ')
21970          IERROR='YES'
21971          GOTO9000
21972        ELSEIF(IFAULT.EQ.2)THEN
21973          WRITE(ICOUT,999)
21974          CALL DPWRST('XXX','BUG ')
21975          WRITE(ICOUT,151)
21976  151 FORMAT('***** ERROR IN CUSARL--')
21977          CALL DPWRST('XXX','BUG ')
21978          WRITE(ICOUT,153)DELTA
21979  153 FORMAT('      FOR X = ',G15.7,', EQUATIONS ARE SINGULAR.')
21980          CALL DPWRST('XXX','BUG ')
21981          IERROR='YES'
21982          GOTO9000
21983        ELSEIF(IFAULT.EQ.3)THEN
21984          WRITE(ICOUT,999)
21985          CALL DPWRST('XXX','BUG ')
21986          WRITE(ICOUT,161)
21987  161 FORMAT('***** ERROR IN CUSARL--')
21988          CALL DPWRST('XXX','BUG ')
21989          WRITE(ICOUT,163)DELTA
21990  163 FORMAT('      FOR X = ',G15.7,', VALUE OF S0 IS TOO LARGE.')
21991          CALL DPWRST('XXX','BUG ')
21992          IERROR='YES'
21993          GOTO9000
21994        ENDIF
21995        IF(S0.GT.0.0)THEN
21996          Y(I)=ARLFIR
21997        ELSE
21998          Y(I)=ARL
21999        ENDIF
22000  100 CONTINUE
22001C
22002C               *****************
22003C               **  STEP 90--  **
22004C               **  EXIT.      **
22005C               *****************
22006C
22007 9000 CONTINUE
22008C
22009      IF(IBUGA3.EQ.'OFF')GOTO9090
22010      WRITE(ICOUT,999)
22011      CALL DPWRST('XXX','BUG ')
22012      WRITE(ICOUT,9011)
22013 9011 FORMAT('***** AT THE END       OF CUSARL--')
22014      CALL DPWRST('XXX','BUG ')
22015      WRITE(ICOUT,9012)IBUGA3,IERROR
22016 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
22017      CALL DPWRST('XXX','BUG ')
22018      WRITE(ICOUT,9013)NX
22019 9013 FORMAT('NX = ',I8)
22020      CALL DPWRST('XXX','BUG ')
22021      DO9015I=1,NX
22022      WRITE(ICOUT,9016)I,X(I),Y(I)
22023 9016 FORMAT('I,X(I),Y(I) = ',I8,2E15.7)
22024      CALL DPWRST('XXX','BUG ')
22025 9015 CONTINUE
22026 9090 CONTINUE
22027C
22028      RETURN
22029      END
22030      double precision function cvflow(cv)
22031      implicit double precision (a-h,o-z)
22032      common /cvc/ estcv,sqrtn,df,ratio,alphad2,omad2
22033c
22034      xncp = sqrtn/cv
22035ccccc call cdftnc(1,p,q,ratio,df,xncp,ier,bound)
22036      call nctcd2(ratio,df,xncp,p)
22037ccccc if (ier .ne. 0) then
22038ccccc    write(6,10)
22039ccccc    write(7,10)
22040c10      format(/,1x,'The ier value from a call',
22041cccccx   ' to cdftnc was nonzero.  Please contact',/,
22042cccccx   1x,'Steve Verrill at sverrill@fs.fed.us.',/)
22043ccccc    stop
22044ccccc endif
22045      cvflow = alphad2 - p
22046      return
22047      end
22048      double precision function cvfup(cv)
22049      implicit double precision (a-h,o-z)
22050      common /cvc/ estcv,sqrtn,df,ratio,alphad2,omad2
22051      xncp = sqrtn/cv
22052      call nctcd2(ratio,df,xncp,p)
22053ccccc if (ier .ne. 0) then
22054ccccc    write(6,10)
22055ccccc    write(7,10)
22056c10      format(/,1x,'The ier value from a call',
22057cccccx   ' to cdftnc was nonzero.  Please contact',/,
22058cccccx   1x,'Steve Verrill at sverrill@fs.fed.us.',/)
22059ccccc    stop
22060ccccc endif
22061      cvfup = omad2 - p
22062      return
22063      end
22064