SUBROUTINE CNPK(X,N,XTEMP,MAXNXT,ENGLSL,ENGUSL,IWRITE,XCNPK, 1IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE CNPK (PROCESS CAPABILITY INDEX) C OF THE DATA IN THE INPUT VECTOR X. C CNPK = MIN(A,B) C WHERE A = (USL-MEDIAN)/(P(.995)-MEDIAN) C WHERE B = (MEDIAN-LSL)/(MEDIAN-P(.005)) C AND P = THE PERCENTILE FUNCTION C NOTE--CNPK IS A MEASURE OF PROCESS ACCURACY-- C COMBINING BOTH PRECISION AND UNBIASEDNESS. C IT IS A NON-PARAMETERIC METHOD FOR THE CPK STATISTIC C THAT IS RECOMMENDED WHEN THE DATA ARE NOT NORMAL. C NOTE--THE CNPK INDEX IS A MEASURE WHICH TAKES ON C THE VALUES 0 TO INFINITY. C A GOOD PROCESS YIELDS VALUES OF CNPK C WHICH ARE LARGE (ABOVE 2); C VALUES OF CNPK FROM 0.5 TO 1.0 ARE TYPICAL. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C --ENGLSL = LOWER (ENGINEERING) SPEC LIMIT C --ENGUSL = UPPER (ENGINEERING) SPEC LIMIT C OUTPUT ARGUMENTS--CNPK = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE CNPK C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE CNPK INDEX C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--R&M 2000 AIR FORCE MANUAL C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--99.3 C ORIGINAL VERSION--MARCH 1999. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION X(*) DIMENSION XTEMP(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='CNPK ' ISUBN2=' ' C IERROR='NO' C DMEAN=0.0D0 C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF CNPK--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)ENGUSL,ENGLSL 54 FORMAT('ENGUSL,ENGLSL = ',2E15.7) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ******************************************** C ** COMPUTE PROCESS CAPABILITY INDEX CNPK ** C ******************************************** C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(N.GE.1)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN CNPK--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' IN THE VARIABLE FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114) 114 FORMAT(' THE CNPK STATISTIC IS TO BE COMPUTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116) 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,117)N 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C IF(N.EQ.1)GOTO120 GOTO129 120 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,121) CC121 FORMAT('***** NON-FATAL DIAGNOSTIC IN CNPK--', CCCCC CALL DPWRST('XXX','BUG ') CCCCC1'THE SECOND INPUT ARGUMENT (N) HAS THE VALUE 1') XSD=0.0 GOTO9000 129 CONTINUE C HOLD=X(1) DO135I=2,N IF(X(I).NE.HOLD)GOTO139 135 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,136)HOLD CC136 FORMAT('***** NON-FATAL DIAGNOSTIC IN CNPK--', CCCCC CALL DPWRST('XXX','BUG ') CCCCC1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) XSD=0.0 GOTO9000 139 CONTINUE C 190 CONTINUE C C *************************************** C ** STEP 2-- ** C ** COMPUTE THE MEDIAN AND PERCENTILE** C ** POIUNTS ** C *************************************** C IWRITE='OFF' CALL MEDIAN(X,N,IWRITE,XTEMP,MAXNXT,XMED,IBUGA3,IERROR) P=99.5 CALL PERCEN(P,X,N,IWRITE,XTEMP,MAXNXT,P995,IBUGA3,IERROR) P=0.5 CALL PERCEN(P,X,N,IWRITE,XTEMP,MAXNXT,P005,IBUGA3,IERROR) C C ************************************************** C ** STEP 3-- ** C ** COMPUTE THE CNPK RATIO ** C ************************************************** C USL=ENGUSL LSL=ENGLSL C UPPER=(USL-XMED)/(P995-XMED) ALOWER=(XMED-LSL)/(XMED-P005) XCNPK=MIN(UPPER,ALOWER) C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)N,XCNPK 811 FORMAT('THE CNPK OF THE ',I8,' OBSERVATIONS = ', 1E15.7) CALL DPWRST('XXX','BUG ') 890 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF CNPK--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N 9013 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)XMED 9014 FORMAT('XMED = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)P005,P995 9015 FORMAT('P005,P995 = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)UPPER,ALOWER 9016 FORMAT('UPPER,ALOWER = ',2E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE COCODE(X,N,XREF,NREF,XPRIME,IBUGA3) C C PURPOSE--THIS SUBROUTINE CO-CODES C THE N ELEMENTS OF THE SINGLE PRECISION VECTOR X, C AS DICTATED BY HOW X MATCHES XREF. C IN PARTICULAR, ALL ELEMENTS IN X THAT MATCH XREF(1) C WILL GET CODED WITH 1. C ALL ELEMENTS IN X THAT MATCH XREF(2) C WILL GET CODED WITH 2. C ETC. C THE OUTPUT IS, IN FACT, PLACED IN XPRIME. C (X AND XREF REMAIN UNCHANGED) C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C OBSERVATIONS TO BE CO-CODED. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X AND XPRIME. C --XREF = THE SINGLE PRECISION VECTOR OF C REFERENCE OBSERVATIONS. C --NREF = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR XREF. C OUTPUT ARGUMENTS--XPRIME = THE SINGLE PRECISION VECTOR C INTO WHICH THE RECODED DATA VALUES C WILL BE PLACED. C OUTPUT--THE SINGLE PRECISION VECTOR XPRIME C CONTAINING THE RECODED VALUES. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C ORIGINAL VERSION--JULY 1991. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*),XREF(*),XPRIME(*) CHARACTER*4 IBUGA3 C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)GOTO50 GOTO90 50 CONTINUE WRITE(ICOUT,15) 15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ', 1'SORTC SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') CALL DPWRST('XXX','BUG ') RETURN 90 CONTINUE C IF(IBUGA3.NE.'ON')GOTO190 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,110) 110 FORMAT('***** AT THE BEGINNING OF COCODE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111)N,NREF 111 FORMAT('N,NREF = ',I8,I8) CALL DPWRST('XXX','BUG ') DO112I=1,N WRITE(ICOUT,113)I,X(I),XREF(I) 113 FORMAT('I,X(I),XREF(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 112 CONTINUE 190 CONTINUE C DO1100I=1,N XPRIME(I)=-999 1100 CONTINUE C DO1200I=1,NREF XREFI=XREF(I) DO1300J=1,N IF(X(J).EQ.XREFI)XPRIME(J)=I 1300 CONTINUE 1200 CONTINUE C 9000 CONTINUE IF(IBUGA3.NE.'ON')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF COCODE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)N,NREF 9012 FORMAT('N,NREF = ',I8,I8) CALL DPWRST('XXX','BUG ') DO9015I=1,N WRITE(ICOUT,9016)I,X(I),XREF(I) 9016 FORMAT('I,X(I),XREF(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE DO9020I=1,N WRITE(ICOUT,9021)I,XPRIME(I) 9021 FORMAT('I,XPRIME(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 9020 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE COCOPY(YREF,NREF,X,NX,XREF,Y,NY,IBUGA3) C C PURPOSE--THIS SUBROUTINE CO-COPIES C THE NREF ELEMENTS OF THE SINGLE PRECISION C VECTOR YREF INTO THE (TYPICALLY) LONGER VECTOR Y. C AS DICTATED BY HOW X MATCHES XREF. C IN PARTICULAR, FOR ALL ELEMENTS IN X THAT MATCH XREF(1), C Y WILL BECOME YREF(1). C FOR ALL ELEMENTS IN X THAT MATCH XREF(2), C Y WILL BECOME YREF(2). C ETC. C THE OUTPUT IS, IN FACT, PLACED IN Y. C (X, XREF, AND YREF REMAIN UNCHANGED). C INPUT ARGUMENTS--YREF = THE SINGLE PRECISION VECTOR OF C OBSERVATIONS TO BE CO-COPIED. C --NREF = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR YREF (AND XREF). C --X = THE SINGLE PRECISION VECTOR OF C OBSERVATIONS USED FOR MATCHING . C --NX = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X (AND Y). C --XREF = THE SINGLE PRECISION VECTOR OF C REFERENCE OBSERVATIONS. C OUTPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR C INTO WHICH THE VARIOUS YREF VALUES C WILL BE COPIED. C NY = THE INTEGER NUMBER OF ELEMENTS C IN Y (= NX) C OUTPUT--THE SINGLE PRECISION VECTOR Y C CONTAINING THE COPIED VALUES. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C ORIGINAL VERSION--JULY 1991. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION YREF(*),X(*),XREF(*),Y(*) CHARACTER*4 IBUGA3 C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(NX.LT.1)GOTO50 GOTO90 50 CONTINUE WRITE(ICOUT,15) 15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1'SORTC SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)NX 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') CALL DPWRST('XXX','BUG ') NY=NX RETURN 90 CONTINUE C IF(IBUGA3.NE.'ON')GOTO190 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,110) 110 FORMAT('***** AT THE BEGINNING OF COCOPY--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111)NREF,NX 111 FORMAT('NREF,NX = ',I8,I8) CALL DPWRST('XXX','BUG ') DO112I=1,NX WRITE(ICOUT,113)I,X(I),XREF(I),YREF(I) 113 FORMAT('I,X(I),XREF(I),YREF(I) = ',I8,3E15.7) CALL DPWRST('XXX','BUG ') 112 CONTINUE 190 CONTINUE C DO1100I=1,NX Y(I)=-999 1100 CONTINUE C DO1200I=1,NREF XREFI=XREF(I) DO1300J=1,NX IF(X(J).EQ.XREFI)Y(J)=YREF(I) 1300 CONTINUE 1200 CONTINUE NY=NX C 9000 CONTINUE IF(IBUGA3.NE.'ON')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF COCOPY--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)NREF,NX,NY 9012 FORMAT('NREF,NX,NY = ',I8,I8,I8) CALL DPWRST('XXX','BUG ') DO9015I=1,NX WRITE(ICOUT,9016)I,X(I),XREF(I),YREF(I) 9016 FORMAT('I,X(I),XREF(I),YREF(I) = ',I8,3E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE DO9020I=1,NY WRITE(ICOUT,9021)I,Y(I) 9021 FORMAT('I,Y(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 9020 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE CODE(X,N,IWRITE,Y,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE CODES THE ELEMENTS C OF THE INPUT VECTOR X C AND PUTS THE CODED VALUES INTO THE OUTPUT VECTOR Y. C THE CODING IS AS FOLLOWS-- C THE MINIMUM IS CODED AS 1.0. C THE NEXT LARGER VALUE AS 2.0, C THE NEXT LARGER VALUE AS 3.0, C ETC. C NOTE--THIS ROUTINE IN JJF8 HAS BEEN MODIFIED C FOR DATAPLOT C FROM THE SAME-NAME SUBROUTINE IN JJF6 IN 4 IMPORTANT WAYS-- C 1) THE UPPER LIMIT (IUPPER) HAS BEEN C REDUCED FROM 7500 TO 1000 C 2) THE VECTOR DIST HAS HAD ITS DIMENSION C CHANGED FROM 7500 TO 1000. C 3) THE VECTOR DIST HAS BEEN TAKEN OUT OF COMMON. C 4) THE VECTOR WS HAS BEEN DELETED. C 5) THE OUTPUT WRITING HAS BEEN SUPPRESSED. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR C OF OBSERVATIONS TO BE CODED. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C OUTPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR C INTO WHICH THE CODED VALUES C WILL BE PLACED. C OUTPUT--THE SINGLE PRECISION VECTOR Y C WHICH WILL CONTAIN THE CODED VALUES C CORRESPONDING TO THE OBSERVATIONS IN C THE VECTOR X. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N C FOR THIS SUBROUTINE IS 15000. C OTHER DATAPAC SUBROUTINES NEEDED--SORT. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C COMMENT--ALL OCCURRANCES OF THE MINIMUM ARE CODED AS 1.0; C ALL OCCURANCES OF THE NEXT LARGER VALUE C ARE CODED AS 2.0; C ALL OCCURANCES OF THE NEXT LARGER VALUE C ARE CODED AS 3.0, ETC. C COMMENT--THE INPUT VECTOR X REMAINS UNALTERED. C REFERENCES--NONE. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82/7 C ORIGINAL VERSION--OCTOBER 1975. C UPDATED --NOVEMBER 1975. C UPDATED --JUNE 1977. C UPDATED --JULY 1977. C UPDATED --JULY 1979. C UPDATED --AUGUST 1981. C UPDATED --APRIL 1982. C UPDATED --MAY 1982. C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION X(*) DIMENSION Y(*) DIMENSION DIST(MAXOBV) CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZ2.INC' EQUIVALENCE (G2RBAG(IGAR45),DIST(1)) CCCCC END CHANGE C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='CODE' ISUBN2=' ' C IERROR='NO' IUPPER=MAXOBV C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF CODE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N,IUPPER 53 FORMAT('N,IUPPER = ',2I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ***************************** C ** COMPUTE CODED VALUES. ** C ***************************** C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(1.LE.N.AND.N.LE.IUPPER)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111)IUPPER 111 FORMAT('***** ERROR IN CODE--', 1'THE SECOND INPUT ARGUMENT (N) IS SMALLER THAN 1', 1'OR LARGER THAN ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,118)N 118 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C IF(N.EQ.1)GOTO120 GOTO129 120 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** NON-FATAL DIAGNOSTIC IN CODE--', 1'THE SECOND INPUT ARGUMENT (N) HAS THE VALUE 1') CALL DPWRST('XXX','BUG ') Y(1)=1.0 GOTO9000 129 CONTINUE C HOLD=X(1) DO135I=2,N IF(X(I).NE.HOLD)GOTO139 135 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,136)HOLD 136 FORMAT('***** NON-FATAL DIAGNOSTIC IN CODE--', 1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') DO137I=1,N Y(I)=1.0 137 CONTINUE GOTO9000 139 CONTINUE C 190 CONTINUE C C ************************************************************* C ** STEP 2-- ** C ** PERFORM THE CODING-- ** C ** PULL OUT THE DISTINCT VALUES, ** C ** THEN SORT (AND ESSENTIALLY RANK) THE DISTINCT VALUES, ** C ** THEN APPLY THE RANKS TO ALL THE VALUES. ** C ************************************************************* C NUMDIS=1 DIST(NUMDIS)=X(1) DO200I=2,N DO300J=1,NUMDIS IF(X(I).EQ.DIST(J))GOTO200 300 CONTINUE NUMDIS=NUMDIS+1 DIST(NUMDIS)=X(I) 200 CONTINUE C CALL SORT(DIST,NUMDIS,DIST) C DO600I=1,N DO700J=1,NUMDIS IF(X(I).EQ.DIST(J))GOTO750 700 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,705) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,710)I,X(I) 705 FORMAT('***** INTERNAL ERROR IN CODE SUBROUTINE--') CALL DPWRST('XXX','BUG ') 710 FORMAT(' NO CODE FOUND FOR ELEMENT NUMBER ',I8,' = ', 1E15.7) GOTO9000 750 Y(I)=J 600 CONTINUE C C ****************************** C ** STEP 3-- ** C ** WRITE OUT A FEW LINES ** C ** OF SUMMARY INFORMATION ** C ** ABOUT THE CODING. ** C ****************************** C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)NUMDIS 811 FORMAT('NUMBER OF DISTINCT CODE VALUES = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') AI=1 WRITE(ICOUT,812)DIST(1),AI 812 FORMAT('THE MINIMUM (= ',E15.7,' ) HAS CODE VALUE ',F10.0) CALL DPWRST('XXX','BUG ') AI=NUMDIS WRITE(ICOUT,813)DIST(NUMDIS),AI 813 FORMAT('THE MAXIMUM (= ',E15.7,' ) HAS CODE VALUE ',F10.0) CALL DPWRST('XXX','BUG ') 890 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE C IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF CODE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N,NUMDIS 9013 FORMAT('N,NUMDIS = ',2I8) CALL DPWRST('XXX','BUG ') DO9015I=1,N WRITE(ICOUT,9016)I,X(I),Y(I),DIST(I) 9016 FORMAT('I,X(I),Y(I),DIST(I) = ',I8,3E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE CODECH(ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD, 1IA,PARAM,IPARN,IPARN2, 1IWRITE, 1IBUGA3,ISUBRO,IERROR) C C PURPOSE--THIS SUBROUTINE READS THE CHARCTER DATA STORED IN C FILE "DPZCHF.DAT" AND CODES A SELECTED FIELD INTO C A NUMERIC VARIABLE. THAT IS, EACH DISTINCT C CHARACTER VARIABLE WILL BE ASSIGNED AN INTEGER C CODE (DETERMINED BY ORDER THAT THE FIRST OCCURENCE C IS FOUND). C OUTPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR C INTO WHICH THE CODED VALUES C WILL BE PLACED. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE CHARACTER VARIABLE. C OUTPUT--THE SINGLE PRECISION VECTOR Y C WHICH WILL CONTAIN THE CODED VALUES C CORRESPONDING TO THE OBSERVATIONS IN C THE VECTOR X. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N C FOR THIS SUBROUTINE IS MAXOBV. C OTHER DATAPAC SUBROUTINES NEEDED--SORT. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--NONE. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004/1 C ORIGINAL VERSION--JANUARY 2004. C UPDATED --FEBRUARY 2006. FIX BUG WHERE IT WAS ONLY C WORKING IF THERE WAS ONE C CHARACTER VARIABLE IN THE C DPZCHF.DAT. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISTEPN CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ICASEL C CHARACTER*4 IH CHARACTER*4 IH2 CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CHARACTER*4 IHRIGH CHARACTER*4 IHRIG2 C CHARACTER*4 ITYPEH CHARACTER*4 IW21HO CHARACTER*4 IW22HO CHARACTER*4 IA CHARACTER*4 IPARN CHARACTER*4 IPARN2 CHARACTER*4 IANGLU CHARACTER*4 IBUGCO CHARACTER*4 IBUGEV C DIMENSION ITYPEH(*) DIMENSION IW21HO(*) DIMENSION IW22HO(*) DIMENSION W2HOLD(*) C DIMENSION IA(*) DIMENSION PARAM(*) DIMENSION IPARN(*) DIMENSION IPARN2(*) C C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCODA.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCOF2.INC' INCLUDE 'DPCOZC.INC' INCLUDE 'DPCOZZ.INC' C CHARACTER*80 IFILE CHARACTER*12 ISTAT CHARACTER*12 IFORM CHARACTER*12 IACCES CHARACTER*12 IPROT CHARACTER*12 ICURST CHARACTER*4 IENDFI CHARACTER*4 IREWIN CHARACTER*4 ISUBN0 CHARACTER*4 IERRFI C CHARACTER*500 IATEMP CHARACTER*6 IFRMT CHARACTER*24 IXTEMP(MAXOBV) DIMENSION YTEMP(MAXOBV) EQUIVALENCE (GARBAG(1),YTEMP(1)) EQUIVALENCE (CGARBG(1),IXTEMP(1)) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='CODE' ISUBN2='CH ' C IERROR='NO' C IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DECH')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF CODECH--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') ENDIF C C ************************************************** C ** STEP 1-- * C ** EXAMINE THE LEFT-HAND SIDE-- * C ** IS THE NAME NAME TO LEFT OF = SIGN * C ** ALREADY IN THE NAME LIST? * C ** NOTE THAT ILISTL IS THE LINE IN THE * C ** TABLE OF THE NAME ON THE LEFT. * C ************************************************** C ISTEPN='1' IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DECH') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHLEFT=IHARG(1) IHLEF2=IHARG2(1) DO2000I=1,NUMNAM I2=I IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN ILISTL=I2 GOTO2100 ENDIF 2000 CONTINUE ILISTL=NUMNAM+1 IF(ILISTL.GT.MAXNAM)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2201) 2201 FORMAT('***** ERROR IN CODECH--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2202) 2202 FORMAT(' THE NUMBER OF VARIABLE, PARAMETER, AND FUNCTION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2203)MAXNAM 2203 FORMAT(' NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2204) 2204 FORMAT(' ENTER STATUS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2205) 2205 FORMAT(' TO FIND OUT THE FULL LIST OF USED NAMES, AND') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2206) 2206 FORMAT(' THEN DELETE SOME OF THE ALREADY-USED NAMES.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C 2100 CONTINUE C C ***************************** C ** COMPUTE CODED VALUES. ** C ***************************** C C ******************************************** C ** STEP 2-- ** C ** OPEN THE DPZCHF.DAT FILE. ** C ******************************************** C IHRIGH=IHARG(5) IHRIG2=IHARG2(5) C IOUNIT=IZCHNU IFILE=IZCHNA ISTAT=IZCHST IFORM=IZCHFO IACCES=IZCHAC IPROT=IZCHPR ICURST=IZCHCS C ISUBN0='READ' IERRFI='NO' CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT, 1 ICURST, 1 IREWIN,ISUBN0,IERRFI,IBUGA3,ISUBRO,IERROR) IF(IERRFI.EQ.'YES')THEN IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN CODECH--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,118) 118 FORMAT(' UNABLE TO OPEN THE FILE CHARACTER DATA FILE:') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,119)IFILE 119 FORMAT(' ',A80) CALL DPWRST('XXX','BUG ') GOTO8000 ENDIF C READ(IOUNIT,'(I8)',END=171,ERR=171)NUMVAR C CCCCC FEBRUARY 2006: BUG FIX FOR THE FOLLOWING LOOP. C IVAR=-1 DO130I=1,NUMVAR READ(IOUNIT,'(A4,A4)',END=181,ERR=181)IH,IH2 IF(IHRIGH.EQ.IH .AND. IHRIG2.EQ.IH2)THEN IVAR=I CCCCC GOTO199 ENDIF 130 CONTINUE IF(IVAR.GT.0)GOTO199 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,131)IHRIGH,IHRIG2 131 FORMAT('***** VARIABLE ',A4,A4,' NOT FOUND IN THE CHARACTER ', 1 'DATA FILE:') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,119)IFILE CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO8000 C 171 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,173) 173 FORMAT(' ERROR READING THE NUMBER OF CHARACTER VARIABLES ', 1 'IN THE CHARACTER DATA FILE:') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,119)IFILE CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO8000 C 181 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,183) 183 FORMAT(' ERROR READING THE VARIABLE NAMES ', 1 'IN THE CHARACTER DATA FILE:') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,119)IFILE CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO8000 C 199 CONTINUE C C ************************************************* C ** STEP 2-- ** C ** PERFORM THE CODING-- ** C ** STORE UNIQUE VALUES IN IXTEMP, COMPARE ** C ** TO LIST IN IXTEMP. ** C ************************************************* C IATEMP=' ' IFRMT='(A )' WRITE(IFRMT(3:5),'(I3)')25*IVAR N=1 IROW=1 READ(IOUNIT,IFRMT,END=491,ERR=491)IATEMP YTEMP(1)=REAL(N) IFRST=(IVAR-1)*25 + 1 ILAST=IVAR*25 - 1 IXTEMP(1)=' ' IXTEMP(1)=IATEMP(IFRST:ILAST) C DO210I=2,MAXOBV IATEMP=' ' READ(IOUNIT,IFRMT,END=499,ERR=491)IATEMP IROW=I DO220J=1,N IF(IATEMP(IFRST:ILAST).EQ.IXTEMP(J)(1:24))THEN YTEMP(IROW)=REAL(J) GOTO210 ENDIF 220 CONTINUE N=N+1 IXTEMP(N)=' ' IXTEMP(N)=IATEMP(IFRST:ILAST) YTEMP(IROW)=REAL(N) 210 CONTINUE GOTO499 C 491 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,493)IROW 493 FORMAT(' ERROR READING ROW ',I8,' OF THE CHARACTER ', 1 'VARIABLES IN THE CHARACTER DATA FILE:') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,119)IFILE CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO8000 C C C ****************************** C ** STEP 3-- ** C ** WRITE OUT A FEW LINES ** C ** OF SUMMARY INFORMATION ** C ** ABOUT THE CODING. ** C ****************************** C 499 CONTINUE C IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)N 811 FORMAT('NUMBER OF DISTINCT CHARACTER VALUES = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') AI=1.0 WRITE(ICOUT,812)IXTEMP(1),AI 812 FORMAT('THE FIRST CHARACTER VALUE (= ',A24, 1 ' ) HAS CODE VALUE ',F10.0) CALL DPWRST('XXX','BUG ') AI=REAL(N) WRITE(ICOUT,813)IXTEMP(N),AI 813 FORMAT('THE FIRST CHARACTER VALUE (= ',A24, 1 ' ) HAS CODE VALUE ',F10.0) CALL DPWRST('XXX','BUG ') ENDIF C C ***************************************************** C ** STEP 5-- ** C ** ENTER THE CODED VALUES INTO THE DATAPLOT ** C ** HOUSEKEEPING ARRAY ** C ***************************************************** C ISTEPN='5' IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DECH') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEL='V' XINT=0.0 IXINT=0 CALL DPINVP(IHLEFT,IHLEF2,ICASEL,YTEMP,IROW,XINT,IXINT, 1ISUBN1,ISUBN2,IBUGA3,IERROR) C C *************************************** C ** STEP 88-- ** C ** CLOSE THE DPZCHF.DAT FILE. ** C *************************************** C 8000 CONTINUE C IENDFI='OFF' IREWIN='ON' CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 1 IENDFI,IREWIN,ISUBN0,IERRFI,IBUGA3,ISUBRO,IERROR) IZCHCS='CLOSED' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE C IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DECH')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF CODECH--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N,IROW 9013 FORMAT('N,IROW = ',I8) CALL DPWRST('XXX','BUG ') DO9015I=1,N WRITE(ICOUT,9016)I,IXTEMP(I) 9016 FORMAT('I,IXTEMP(I) = ',I8,A24) CALL DPWRST('XXX','BUG ') 9015 CONTINUE DO9035I=1,IROW WRITE(ICOUT,9036)I,YTEMP(I) 9036 FORMAT('I,YTEMP(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 9035 CONTINUE ENDIF C RETURN END SUBROUTINE CODEC2(ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD, 1IA,PARAM,IPARN,IPARN2, 1IWRITE, 1IBUGA3,ISUBRO,IERROR) C C PURPOSE--THIS SUBROUTINE READS THE CHARCTER DATA STORED IN C FILE "DPZCHF.DAT" AND CODES A SELECTED FIELD INTO C A NUMERIC VARIABLE. THAT IS, EACH DISTINCT C CHARACTER VARIABLE WILL BE ASSIGNED AN INTEGER C CODE. THIS ROUTINE IS SIMILAR TO CODECH. THE C DISTINCTION IS THAT CODECH CODES BY THE ORDER THE C VALUES ARE ENCOUNTERED IN THE FILE WHILE THIS C ROUTINE CODES BY (LEXICAL) ALPHABETIC ORDER. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N C FOR THIS SUBROUTINE IS MAXOBV. C OTHER DATAPAC SUBROUTINES NEEDED--HPSORT. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--NONE. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004/1 C ORIGINAL VERSION--JANUARY 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISTEPN CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ICASEL C CHARACTER*4 IH CHARACTER*4 IH2 CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CHARACTER*4 IHRIGH CHARACTER*4 IHRIG2 C CHARACTER*4 ITYPEH CHARACTER*4 IW21HO CHARACTER*4 IW22HO CHARACTER*4 IA CHARACTER*4 IPARN CHARACTER*4 IPARN2 CHARACTER*4 IANGLU CHARACTER*4 IBUGCO CHARACTER*4 IBUGEV C DIMENSION ITYPEH(*) DIMENSION IW21HO(*) DIMENSION IW22HO(*) DIMENSION W2HOLD(*) C DIMENSION IA(*) DIMENSION PARAM(*) DIMENSION IPARN(*) DIMENSION IPARN2(*) C C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCODA.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCOF2.INC' INCLUDE 'DPCOZC.INC' INCLUDE 'DPCOZZ.INC' INCLUDE 'DPCOZI.INC' C CHARACTER*80 IFILE CHARACTER*12 ISTAT CHARACTER*12 IFORM CHARACTER*12 IACCES CHARACTER*12 IPROT CHARACTER*12 ICURST CHARACTER*4 IENDFI CHARACTER*4 IREWIN CHARACTER*4 ISUBN0 CHARACTER*4 IERRFI C CHARACTER*500 IATEMP CHARACTER*6 IFRMT CHARACTER*24 IXTEMP(MAXOBV/2) CHARACTER*24 IXWORK(MAXOBV/2) CHARACTER*24 IXSAVE(MAXOBV/2) DIMENSION YTEMP(MAXOBV) DIMENSION YTEMP2(MAXOBV) DIMENSION IPERM(MAXOBV) EQUIVALENCE (GARBAG(1),YTEMP(1)) EQUIVALENCE (GARBAG(IGARB2),YTEMP2(1)) EQUIVALENCE (IGARBG(1),IPERM(1)) EQUIVALENCE (CGARBG(1),IXTEMP(1)) EQUIVALENCE (CGARBG(MAXOBV/2 + 1),IXWORK(1)) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='CODE' ISUBN2='C2 ' C IERROR='NO' C IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC2')THEN ISTEPN='1' CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF CODEC2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') ENDIF C C ************************************************** C ** STEP 1-- * C ** EXAMINE THE LEFT-HAND SIDE-- * C ** IS THE NAME NAME TO LEFT OF = SIGN * C ** ALREADY IN THE NAME LIST? * C ** NOTE THAT ILISTL IS THE LINE IN THE * C ** TABLE OF THE NAME ON THE LEFT. * C ************************************************** C IHLEFT=IHARG(1) IHLEF2=IHARG2(1) DO2000I=1,NUMNAM I2=I IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN ILISTL=I2 GOTO2100 ENDIF 2000 CONTINUE ILISTL=NUMNAM+1 IF(ILISTL.GT.MAXNAM)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2201) 2201 FORMAT('***** ERROR IN CODEC2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2202) 2202 FORMAT(' THE NUMBER OF VARIABLE, PARAMETER, AND FUNCTION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2203)MAXNAM 2203 FORMAT(' NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2204) 2204 FORMAT(' ENTER STATUS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2205) 2205 FORMAT(' TO FIND OUT THE FULL LIST OF USED NAMES, AND') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2206) 2206 FORMAT(' THEN DELETE SOME OF THE ALREADY-USED NAMES.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C 2100 CONTINUE C C ***************************** C ** COMPUTE CODED VALUES. ** C ***************************** C C ******************************************** C ** STEP 2-- ** C ** OPEN THE DPZCHF.DAT FILE. ** C ******************************************** C IHRIGH=IHARG(6) IHRIG2=IHARG2(6) C IOUNIT=IZCHNU IFILE=IZCHNA ISTAT=IZCHST IFORM=IZCHFO IACCES=IZCHAC IPROT=IZCHPR ICURST=IZCHCS C ISUBN0='READ' IERRFI='NO' CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT, 1 ICURST, 1 IREWIN,ISUBN0,IERRFI,IBUGA3,ISUBRO,IERROR) IF(IERRFI.EQ.'YES')THEN IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN CODEC2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,118) 118 FORMAT(' UNABLE TO OPEN THE FILE CHARACTER DATA FILE:') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,119)IFILE 119 FORMAT(' ',A80) CALL DPWRST('XXX','BUG ') GOTO8000 ENDIF C READ(IOUNIT,'(I8)',END=171,ERR=171)NUMVAR C IVAR=-1 DO130I=1,NUMVAR READ(IOUNIT,'(A4,A4)',END=181,ERR=181)IH,IH2 IF(IHRIGH.EQ.IH .AND. IHRIG2.EQ.IH2)THEN IVAR=I CCCCC GOTO199 ENDIF 130 CONTINUE IF(IVAR.GT.0)GOTO199 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,131)IHRIGH,IHRIG2 131 FORMAT('***** VARIABLE ',A4,A4,' NOT FOUND IN THE CHARACTER ', 1 'DATA FILE:') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,119)IFILE CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO8000 C 171 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,173) 173 FORMAT(' ERROR READING THE NUMBER OF CHARACTER VARIABLES ', 1 'IN THE CHARACTER DATA FILE:') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,119)IFILE CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO8000 C 181 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,183) 183 FORMAT(' ERROR READING THE VARIABLE NAMES ', 1 'IN THE CHARACTER DATA FILE:') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,119)IFILE CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO8000 C 199 CONTINUE C C ************************************************* C ** STEP 2-- ** C ** PERFORM THE CODING-- ** C ** 1) STORE UNIQUE VALUES IN IXTEMP ** C ** 2) SORT VALUES IN IXTEMP ** C ** 3) CODE BASED ON SORTED IXTEMP VALUES ** C ************************************************* C ISTEPN='2' IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IATEMP=' ' IFRMT='(A )' WRITE(IFRMT(3:5),'(I3)')25*IVAR N=1 IROW=1 READ(IOUNIT,IFRMT,END=491,ERR=491)IATEMP YTEMP(1)=REAL(N) IFRST=(IVAR-1)*25 + 1 ILAST=IVAR*25 - 1 IXTEMP(1)=' ' IXTEMP(1)=IATEMP(IFRST:ILAST) C DO210I=2,MAXOBV IATEMP=' ' READ(IOUNIT,IFRMT,END=499,ERR=491)IATEMP IROW=IROW+1 DO220J=1,N IF(IATEMP(IFRST:ILAST).EQ.IXTEMP(J)(1:24))THEN YTEMP(IROW)=REAL(J) GOTO210 ENDIF 220 CONTINUE N=N+1 IF(N.GT.MAXOBV/2)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,221) 221 FORMAT(' NUMBER OF UNIQUE CHARACTER VALUE EXCEEDS ', 1 I8,' .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,223) 223 FORMAT(' CODING NOT PERFORMED.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF IXTEMP(N)=' ' IXTEMP(N)=IATEMP(IFRST:ILAST) YTEMP(IROW)=REAL(N) 210 CONTINUE C 499 CONTINUE C ISTEPN='3' IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IBEG=1 IEND=24 KFLAG=2 IER=0 CALL HPSORT(IXTEMP,N,IBEG,IEND,IPERM,KFLAG,IXWORK,IER) C IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC2')THEN WRITE(ICOUT,292)N,IROW,IER 292 FORMAT('N,IROW,IER = ',3I8) CALL DPWRST('XXX','BUG ') IF(N.GT.0)THEN DO290I=1,N WRITE(ICOUT,293)I,IXTEMP(I),IPERM(I) 293 FORMAT('I,IXTEMP(I),IPERM(I) = ',I8,1X,A24,1X,I8) CALL DPWRST('XXX','BUG ') 290 CONTINUE ENDIF ENDIF IF(IER.GT.0)GOTO9000 C ISTEPN='4' IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO310I=1,IROW ITEMP=INT(YTEMP(I) + 0.5) DO320K=1,N IF(ITEMP.EQ.IPERM(K))THEN INDX=K GOTO329 ENDIF 320 CONTINUE 329 CONTINUE YTEMP2(I)=REAL(INDX) 310 CONTINUE DO330I=1,IROW YTEMP(I)=YTEMP2(I) 330 CONTINUE C GOTO599 C 491 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,493)IROW 493 FORMAT(' ERROR READING ROW ',I8,' OF THE CHARACTER ', 1 'VARIABLES IN THE CHARACTER DATA FILE:') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,119)IFILE CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO8000 C C ****************************** C ** STEP 3-- ** C ** WRITE OUT A FEW LINES ** C ** OF SUMMARY INFORMATION ** C ** ABOUT THE CODING. ** C ****************************** C 599 CONTINUE C IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)N 811 FORMAT('NUMBER OF DISTINCT CHARACTER VALUES = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,812)IXTEMP(1) 812 FORMAT('THE FIRST CHARACTER VALUE (= ',A24, 1 ' ) HAS CODE VALUE 1 ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,813)IXTEMP(N),N 813 FORMAT('THE LAST CHARACTER VALUE (= ',A24, 1 ' ) HAS CODE VALUE ',I6) CALL DPWRST('XXX','BUG ') ENDIF C C ***************************************************** C ** STEP 5-- ** C ** ENTER THE CODED VALUES INTO THE DATAPLOT ** C ** HOUSEKEEPING ARRAY ** C ***************************************************** C ISTEPN='5' IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEL='V' XINT=0.0 IXINT=0 CALL DPINVP(IHLEFT,IHLEF2,ICASEL,YTEMP,IROW,XINT,IXINT, 1ISUBN1,ISUBN2,IBUGA3,IERROR) C C *************************************** C ** STEP 6-- ** C ** CLOSE THE DPZCHF.DAT FILE. ** C *************************************** C 8000 CONTINUE C ISTEPN='6' IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IENDFI='OFF' IREWIN='ON' CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 1 IENDFI,IREWIN,ISUBN0,IERRFI,IBUGA3,ISUBRO,IERROR) IZCHCS='CLOSED' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE C IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC2')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF CODEC2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N,IROW 9013 FORMAT('N,IROW = ',2I8) CALL DPWRST('XXX','BUG ') DO9015I=1,N WRITE(ICOUT,9016)I,IXTEMP(I) 9016 FORMAT('I,IXTEMP(I) = ',I8,A24) CALL DPWRST('XXX','BUG ') 9015 CONTINUE DO9035I=1,IROW WRITE(ICOUT,9036)I,YTEMP(I) 9036 FORMAT('I,YTEMP(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 9035 CONTINUE ENDIF C RETURN END SUBROUTINE CODEH(X,N,NUMINT,IWRITE,Y,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE CODES THE ELEMENTS C OF THE INPUT VECTOR X C AND PUTS THE CODED VALUES INTO THE OUTPUT VECTOR Y. C THE CODING IS AS FOLLOWS-- C THE FIRST NUMINT'TH OF THE DATA IS CODED AS 1.0 C THE NEXT NUMINT'TH OF THE DATA IS CODED AS 2.0 C ETC. C THE LAST NUMINT'TH OF THE DATA IS CODED AS NUMINT C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR C OF OBSERVATIONS TO BE CODED. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C OUTPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR C INTO WHICH THE CODED VALUES C WILL BE PLACED. C OUTPUT--THE SINGLE PRECISION VECTOR Y C WHICH WILL CONTAIN THE CODED VALUES C CORRESPONDING TO THE OBSERVATIONS IN C THE VECTOR X. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N C FOR THIS SUBROUTINE IS 15000. C OTHER DATAPAC SUBROUTINES NEEDED--SORT. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C COMMENT--THE INPUT VECTOR X REMAINS UNALTERED. C REFERENCES--NONE. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C VERSION NUMBER--82/7 C ORIGINAL VERSION--OCTOBER 1981. C UPDATED --MAY 1982. C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION X(*) DIMENSION Y(*) DIMENSION XS(MAXOBV) CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZ2.INC' EQUIVALENCE (G2RBAG(IGAR45),XS(1)) CCCCC END CHANGE C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='CODE' ISUBN2='N ' C IERROR='NO' IUPPER=MAXOBV C X50=0.0 C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF CODEH--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N,IUPPER,NUMINT 53 FORMAT('N,IUPPER,NUMINT = ',3I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ***************************** C ** COMPUTE CODED VALUES. ** C ***************************** C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(1.LE.N.AND.N.LE.IUPPER)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111)IUPPER 111 FORMAT('***** ERROR IN CODEH--', 1'THE SECOND INPUT ARGUMENT (N) IS SMALLER THAN 1', 1'OR LARGER THAN ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,118)N 118 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C IF(N.EQ.1)GOTO120 GOTO129 120 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,121) CC121 FORMAT('***** NON-FATAL DIAGNOSTIC IN CODEH--', CCCCC CALL DPWRST('XXX','BUG ') CCCCC1'THE SECOND INPUT ARGUMENT (N) HAS THE VALUE 1') Y(1)=1.0 GOTO9000 129 CONTINUE C HOLD=X(1) DO135I=2,N IF(X(I).NE.HOLD)GOTO139 135 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,136)HOLD CC136 FORMAT('***** NON-FATAL DIAGNOSTIC IN CODEH--', CCCCC CALL DPWRST('XXX','BUG ') CCCCC1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) DO137I=1,N Y(I)=1.0 137 CONTINUE GOTO9000 139 CONTINUE C 190 CONTINUE C C ************************************************************* C ** STEP 2-- ** C ** PERFORM THE CODING-- ** C ************************************************************* C CALL SORT(X,N,XS) C AN=N C 1400 CONTINUE DO1410I=1,N Y(I)=4.0 1410 CONTINUE C N2=(N+1)/2 IARG1=(N2+1)/2 IARG2=(N2+1)-IARG1 IARG1R=N-IARG1+1 IARG2R=N-IARG2+1 X75=(XS(IARG1R)+XS(IARG2R))/2.0 XCUT=X75 DO1420I=1,N IF(X(I).LE.XCUT)Y(I)=3.0 1420 CONTINUE C N50=N/2 N50P1=N50+1 IEVODD=N-2*(N/2) IF(IEVODD.EQ.0)X50=(XS(N50)+XS(N50P1))/2.0 IF(IEVODD.EQ.1)X50=XS(N50P1) XCUT=X50 DO1430I=1,N IF(X(I).LE.XCUT)Y(I)=2.0 1430 CONTINUE C N2=(N+1)/2 IARG1=(N2+1)/2 IARG2=(N2+1)-IARG1 X25=(XS(IARG1)+XS(IARG2))/2.0 XCUT=X25 DO1440I=1,N IF(X(I).LE.XCUT)Y(I)=1.0 1440 CONTINUE C C ****************************** C ** STEP 3-- ** C ** WRITE OUT A FEW LINES ** C ** OF SUMMARY INFORMATION ** C ** ABOUT THE CODING. ** C ****************************** C IF(IFEEDB.EQ.'OFF')GOTO8190 IF(IWRITE.EQ.'OFF')GOTO8190 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8112)NUMINT 8112 FORMAT('NUMBER OF CODE INTERVALS = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') AI=1 WRITE(ICOUT,8114)XS(1),AI 8114 FORMAT('THE MINIMUM (= ',E15.7,' ) HAS CODE VALUE ',F10.0) CALL DPWRST('XXX','BUG ') AI=NUMINT WRITE(ICOUT,8116)XS(N),AI 8116 FORMAT('THE MAXIMUM (= ',E15.7,' ) HAS CODE VALUE ',F10.0) CALL DPWRST('XXX','BUG ') 8190 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE C IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF CODEH--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N,NUMINT 9013 FORMAT('N,NUMINT = ',2I8) CALL DPWRST('XXX','BUG ') DO9015I=1,N WRITE(ICOUT,9016)I,X(I),Y(I) 9016 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE CODEN(X,N,NUMINT,IWRITE,Y,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE CODES THE ELEMENTS C OF THE INPUT VECTOR X C AND PUTS THE CODED VALUES INTO THE OUTPUT VECTOR Y. C THE CODING IS AS FOLLOWS-- C THE FIRST NUMINT'TH OF THE DATA IS CODED AS 1.0 C THE NEXT NUMINT'TH OF THE DATA IS CODED AS 2.0 C ETC. C THE LAST NUMINT'TH OF THE DATA IS CODED AS NUMINT C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR C OF OBSERVATIONS TO BE CODED. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C OUTPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR C INTO WHICH THE CODED VALUES C WILL BE PLACED. C OUTPUT--THE SINGLE PRECISION VECTOR Y C WHICH WILL CONTAIN THE CODED VALUES C CORRESPONDING TO THE OBSERVATIONS IN C THE VECTOR X. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N C FOR THIS SUBROUTINE IS 15000. C OTHER DATAPAC SUBROUTINES NEEDED--SORT. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C COMMENT--THE INPUT VECTOR X REMAINS UNALTERED. C REFERENCES--NONE. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C VERSION NUMBER--82/7 C ORIGINAL VERSION--OCTOBER 1981. C UPDATED --MAY 1982. C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION X(*) DIMENSION Y(*) DIMENSION XS(MAXOBV) CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZ2.INC' EQUIVALENCE (G2RBAG(IGAR45),XS(1)) CCCCC END CHANGE C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='CODE' ISUBN2='N ' C IERROR='NO' IUPPER=MAXOBV C XMED=0.0 C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF CODEN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N,IUPPER,NUMINT 53 FORMAT('N,IUPPER,NUMINT = ',3I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ***************************** C ** COMPUTE CODED VALUES. ** C ***************************** C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(1.LE.N.AND.N.LE.IUPPER)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111)IUPPER 111 FORMAT('***** ERROR IN CODEN--', 1'THE SECOND INPUT ARGUMENT (N) IS SMALLER THAN 1', 1'OR LARGER THAN ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,118)N 118 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C IF(N.EQ.1)GOTO120 GOTO129 120 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,121) CC121 FORMAT('***** NON-FATAL DIAGNOSTIC IN CODEN--', CCCCC CALL DPWRST('XXX','BUG ') CCCCC1'THE SECOND INPUT ARGUMENT (N) HAS THE VALUE 1') Y(1)=1.0 GOTO9000 129 CONTINUE C HOLD=X(1) DO135I=2,N IF(X(I).NE.HOLD)GOTO139 135 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,136)HOLD CC136 FORMAT('***** NON-FATAL DIAGNOSTIC IN CODEN--', CCCCC CALL DPWRST('XXX','BUG ') CCCCC1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) DO137I=1,N Y(I)=1.0 137 CONTINUE GOTO9000 139 CONTINUE C 190 CONTINUE C C ************************************************************* C ** STEP 2-- ** C ** PERFORM THE CODING-- ** C ************************************************************* C CALL SORT(X,N,XS) C AN=N C SEPTEMBER, 1987 FOLLOWING LINE COMMENTED OUT CCCCC NUMINT=2 IF(NUMINT.EQ.1)GOTO1100 IF(NUMINT.EQ.2)GOTO1200 IF(NUMINT.GE.3)GOTO1300 GOTO1200 C 1100 CONTINUE DO1110I=1,N Y(I)=NUMINT 1110 CONTINUE GOTO7900 C 1200 CONTINUE DO1210I=1,N Y(I)=NUMINT 1210 CONTINUE N50=N/2 N50P1=N50+1 IEVODD=N-2*(N/2) IF(IEVODD.EQ.0)XMED=(XS(N50)+XS(N50P1))/2.0 IF(IEVODD.EQ.1)XMED=XS(N50P1) XCUT=XMED DO1250I=1,N IF(X(I).LE.XCUT)Y(I)=1.0 1250 CONTINUE GOTO7900 C 1300 CONTINUE DO1310I=1,N Y(I)=NUMINT 1310 CONTINUE ANUMIN=NUMINT JMAX=NUMINT-1 DO1320J=1,JMAX JREV=JMAX-J+1 AJREV=JREV P=AJREV/ANUMIN AK=P*AN K1=AK K2=AK+1.0 IF(K1.LE.1)K1=1 IF(K1.GE.N)K1=N IF(K2.LE.1)K2=1 IF(K2.GE.N)K2=N XCUT=(XS(K1)+XS(K2))/2.0 DO1350I=1,N IF(X(I).LE.XCUT)Y(I)=JREV 1350 CONTINUE 1320 CONTINUE GOTO7900 C 7900 CONTINUE C C ****************************** C ** STEP 3-- ** C ** WRITE OUT A FEW LINES ** C ** OF SUMMARY INFORMATION ** C ** ABOUT THE CODING. ** C ****************************** C IF(IFEEDB.EQ.'OFF')GOTO8190 IF(IWRITE.EQ.'OFF')GOTO8190 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8112)NUMINT 8112 FORMAT('NUMBER OF CODE INTERVALS = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') AI=1 WRITE(ICOUT,8114)XS(1),AI 8114 FORMAT('THE MINIMUM (= ',E15.7,' ) HAS CODE VALUE ',F10.0) CALL DPWRST('XXX','BUG ') AI=NUMINT WRITE(ICOUT,8116)XS(N),AI 8116 FORMAT('THE MAXIMUM (= ',E15.7,' ) HAS CODE VALUE ',F10.0) CALL DPWRST('XXX','BUG ') 8190 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE C IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF CODEN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N,NUMINT 9013 FORMAT('N,NUMINT = ',2I8) CALL DPWRST('XXX','BUG ') DO9015I=1,N WRITE(ICOUT,9016)I,X(I),Y(I) 9016 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE COENAM(IV1,IV2,IWORD1,IWORD2,IBUGCN,IERROR) C C PURPOSE--THIS SUBROUTINE CREATES A HOLLERITH COEFFICIENT NAME C FROM THE 2 INPUT INTEGER VALUES IV1 AND IV2. C IT ALSO AUTOMATICALLY PUTS THE LETTER A AS C THE FIRST LETTER OF THE PARAMETER NAME. C EXAMPLES-- C INPUT--IV1 = 1 AND IV2 = 7 OUTPUT--A17 C INPUT--IV1 = 2 AND IV2 = 3 OUTPUT--A23 C INPUT--IV1 = 5 AND IV2 = 2 OUTPUT--A52 C NOTE--IF THE OUTPUT STRING HAPPENS TO CONSIST OF C 1 TO 4 CHARACTERS, THEN CHARACTERS 1 TO 4 C WILL BE PLACED INTO THE FIRST HOLLERITH C VARIABLE IWORD1. C IF THE OUTPUT STRING HAPPENS TO CONSIST OF C MORE THAN 4 CHARACTERS, THEN CHARACTERS 5 TO 8 C WILL BE PLACED INTO THE SECOND HOLLERITH C VARIABLE IWORD2. C IF THE OUTPUT STRING HAPPENS TO CONSIST OF C MORE THAN 8 CHARACTERS, THEN CHARACTERS 9 ON UP C WILL BE IGNORED. C NOTE--IV1 AND IV2 ARE INTEGER VARIABLES. C NOTE--IWORD1 IS A HOLLERITH VARIABLE. C --IWORD2 IS A HOLLERITH VARIABLE. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--DECEMBER 1978. C UPDATED --MARCH 1981. C UPDATED --NOVEMBER 1981. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWORD1 CHARACTER*4 IWORD2 CHARACTER*4 IBUGCN CHARACTER*4 IERROR C CHARACTER*4 ISTRIT CHARACTER*4 ISTRIN CHARACTER*4 IWORD3 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C DIMENSION ISTRIT(15) DIMENSION ISTRIN(30) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IERROR='NO' C ISUBN1='COEN' ISUBN2='AM ' C IF(IBUGCN.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF COENAM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IV1,IV2 52 FORMAT('IV1,IV2 = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGCN 53 FORMAT('IBUGCN = ',A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ********************************** C ** STEP 1-- ** C ** DEFINE THE FIRST CHARACTER ** C ** OF THE PARAMETER NAME ** C ********************************** C ISTEPN='1' IF(IBUGCN.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C K=0 K=K+1 ISTRIN(K)='A' C C ******************************************* C ** STEP 2-- ** C ** FORM THE STRING CONTAINING ** C ** THE 1 CHARACTER PER WORD ** C ** REPRESENTATION OF THE VALUE IN IV1. ** C ******************************************* C J=0 ISTEPN='2' IF(IBUGCN.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IREM=IV1 DO100IPASS=1,10 J=J+1 IDIGIT=IREM-10*(IREM/10) IF(IDIGIT.EQ.0)ISTRIT(J)='0' IF(IDIGIT.EQ.1)ISTRIT(J)='1' IF(IDIGIT.EQ.2)ISTRIT(J)='2' IF(IDIGIT.EQ.3)ISTRIT(J)='3' IF(IDIGIT.EQ.4)ISTRIT(J)='4' IF(IDIGIT.EQ.5)ISTRIT(J)='5' IF(IDIGIT.EQ.6)ISTRIT(J)='6' IF(IDIGIT.EQ.7)ISTRIT(J)='7' IF(IDIGIT.EQ.8)ISTRIT(J)='8' IF(IDIGIT.EQ.9)ISTRIT(J)='9' IREM=IREM-IDIGIT IREM=IREM/10 IF(IREM.LE.0)GOTO140 100 CONTINUE 140 CONTINUE N1=J C DO150I=1,N1 K=K+1 IREV=N1-I+1 ISTRIN(K)=ISTRIT(IREV) 150 CONTINUE C C ******************************************* C ** STEP 3-- ** C ** FORM THE STRING CONTAINING ** C ** THE 1 CHARACTER PER WORD ** C ** REPRESENTATION OF THE VALUE IN IV2. ** C ******************************************* C ISTEPN='3' IF(IBUGCN.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C J=0 IREM=IV2 DO200IPASS=1,10 J=J+1 IDIGIT=IREM-10*(IREM/10) IF(IDIGIT.EQ.0)ISTRIT(J)='0' IF(IDIGIT.EQ.1)ISTRIT(J)='1' IF(IDIGIT.EQ.2)ISTRIT(J)='2' IF(IDIGIT.EQ.3)ISTRIT(J)='3' IF(IDIGIT.EQ.4)ISTRIT(J)='4' IF(IDIGIT.EQ.5)ISTRIT(J)='5' IF(IDIGIT.EQ.6)ISTRIT(J)='6' IF(IDIGIT.EQ.7)ISTRIT(J)='7' IF(IDIGIT.EQ.8)ISTRIT(J)='8' IF(IDIGIT.EQ.9)ISTRIT(J)='9' IREM=IREM-IDIGIT IREM=IREM/10 IF(IREM.LE.0)GOTO240 200 CONTINUE 240 CONTINUE N2=J C DO250I=1,N2 K=K+1 IREV=N2-I+1 ISTRIN(K)=ISTRIT(IREV) 250 CONTINUE C C ******************************************************* C ** STEP 4-- ** C ** CONVERT THE 1 CHARACTER PER WORD REPRESENTATION ** C ** FOR THE PARAMETER NAME ** C ** INTO A 4 CHARACTER PER WORD REPRESENTATION. ** C ******************************************************* C ISTEPN='4' IF(IBUGCN.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ISTART=1 ISTOP=K CALL DP1H4H(ISTART,ISTOP,ISTRIN, 1IWORD1,IWORD2,IWORD3,NUMWD,NUMCH,IBUGCN,IERROR) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE C IF(IBUGCN.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF COENAM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IERROR 9012 FORMAT('IERROR = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N1,N2,ISTART,ISTOP 9013 FORMAT('N1,N2,ISTART,ISTOP = ',4I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)(ISTRIN(I),I=1,K) 9014 FORMAT('ISTRIN(.) = ',80A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)NUMBPC,NUMCPW 9015 FORMAT('NUMBPC,NUMCPW = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)NUMWD,NUMCH 9016 FORMAT('NUMWD, NUMCH = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)IWORD1,IWORD2 9017 FORMAT('IWORD1,IWORD2 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9018)IWORD3 9018 FORMAT('IWORD3 = ',A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE COMARI(Y1,Y2,Y3,Y4,N1,IACASE,IWRITE, 1Y5,Y6,N5,SCAL3,ITYP3,IBUGA3,ISUBRO,IERROR) C C PURPOSE--CARRY OUT COMPLEX ARITHMETIC OPERATIONS C OF THE COMPLEX DATA IN Y1,Y2 AND Y3,Y4. C C OPERATIONS--ADDITION C SUBTRACTTION C MULTIPLICATION C DIVISION C EXPONENTIATION C SQUARE ROOT C ROOTS OF A POLYNOMIAL (WITH COMPLEX COEFFICIENTS) C CONJUGATE C C INPUT ARGUMENTS--Y1 (REAL PART) Y2 (IMAGINARY PART) C --Y3 (REAL PART) Y4 (IMAGINARY PART) C OUTPUT ARGUMENTS--Y5 (REAL PART) Y6 (IMAGINARY PART) C C NOTE--IT IS NOT PERMISSIBLE TO HAVE THE OUTPUT VECTORS Y5(.) AND Y6(.) C BEING IDENTICAL TO THE INPUT VECTORS Y1(.) AND Y2(.), OR C Y3(.) AND Y4(.). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--87/5 C ORIGINAL VERSION--APRIL 1987. C UPDATED --AUGUST 1987. COMPLEX SQUARE ROOT C UPDATED --AUGUST 1987. COMPLEX ROOTS OF POLYNOMIAL C UPDATED --SEPTEMBER 1987. COMPLEX CONJUGATE C UPDATED --MAY 1995. EQUIVALENCE FOR ARRAYS C UPDATED --AUGUST 1995. REPLACE NUMERICAL RECIPES C ROUTINE FOR COMPLEX ROOTS C WITH CMLIB ROUTINE C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IACASE CHARACTER*4 IWRITE CHARACTER*4 ITYP3 CHARACTER*4 IBUGA3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C-----COMPLEX STATEMENTS FOR NON-COMMON VARIABLES------------------- C COMPLEX CY1Y2 COMPLEX CTRANS COMPLEX COEFS COMPLEX ROOTS CCCCC FOLLOWING LINES ADDED AUGUST 1995 COMPLEX WORK C C-----DOUBLE PRECISION STATEMENTS FOR NON-COMMON VARIABLES------------------- C DOUBLE PRECISION DY1 DOUBLE PRECISION DY2 DOUBLE PRECISION DY3 DOUBLE PRECISION DY4 DOUBLE PRECISION DY5 DOUBLE PRECISION DY6 DOUBLE PRECISION DDEN DOUBLE PRECISION DE DOUBLE PRECISION DC DOUBLE PRECISION DS C C-----LOGICAL STATEMENTS FOR NON-COMMON VARIABLES------------------- C CCCCC LOGICAL POLISH C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION Y1(*) DIMENSION Y2(*) DIMENSION Y3(*) DIMENSION Y4(*) DIMENSION Y5(*) DIMENSION Y6(*) C DIMENSION COEFS(MAXOBV) DIMENSION ROOTS(MAXOBV) CCCCC FOLLOWING LINES ADDED AUGUST 1995 DIMENSION WORK(MAXOBV) DIMENSION ERRBND(MAXOBV) CCCCC FOLLOWING LINES ADDED MAY 1995 INCLUDE 'DPCOZ2.INC' EQUIVALENCE (G2RBAG(IGAR11),COEFS(1)) EQUIVALENCE (G2RBAG(IGAR21),ROOTS(1)) CCCCC FOLLOWING LINES ADDED AUGUST 1995 EQUIVALENCE (G2RBAG(IGAR31),WORK(1)) EQUIVALENCE (G2RBAG(IGAR34),ERRBND(1)) CCCCC END CHANGE C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='COMA' ISUBN2='RI ' C IERROR='NO' C SCAL3=(-999.0) ITYP3='VECT' C IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'MARI')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF COMARI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3,ISUBRO,IACASE,IWRITE 52 FORMAT('IBUGA3,ISUBRO,IACASE,IWRITE = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N1 53 FORMAT('N1 = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N1 WRITE(ICOUT,56)I,Y1(I),Y2(I),Y3(I),Y4(I) 56 FORMAT('I,Y1(I),Y2(I),Y3(I),Y4(I) = ',I8,4E13.5) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C *********************************************** C ** CARRY OUT COMPLEX ARITHMETIC OPERATIONS ** C *********************************************** C C ******************************************** C ** STEP 11-- ** C ** CHECK NUMBER OF INPUT OBSERVATIONS. ** C ******************************************** C IF(N1.LT.1)GOTO1100 GOTO1190 C 1100 CONTINUE IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1151) 1151 FORMAT('***** ERROR IN COMARI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1152) 1152 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1153) 1153 FORMAT(' IN THE VARIABLE FOR WHICH') CALL DPWRST('XXX','BUG ') IF(IACASE.EQ.'COAD')WRITE(ICOUT,1154) 1154 FORMAT(' THE COMPLEX ADDITION IS TO BE ', 1'COMPUTED') IF(IACASE.EQ.'COAD')CALL DPWRST('XXX','BUG ') IF(IACASE.EQ.'COSU')WRITE(ICOUT,1155) 1155 FORMAT(' THE COMPLEX SUBTRACTION IS TO BE ', 1'COMPUTED') IF(IACASE.EQ.'COSU')CALL DPWRST('XXX','BUG ') IF(IACASE.EQ.'COMU')WRITE(ICOUT,1156) 1156 FORMAT(' THE COMPLEX MULTIPLICATION IS TO BE ', 1'COMPUTED') IF(IACASE.EQ.'COMU')CALL DPWRST('XXX','BUG ') IF(IACASE.EQ.'CODI')WRITE(ICOUT,1157) 1157 FORMAT(' THE COMPLEX DIVISION IS TO BE ', 1'COMPUTED') IF(IACASE.EQ.'CODI')CALL DPWRST('XXX','BUG ') IF(IACASE.EQ.'COEX')WRITE(ICOUT,1158) 1158 FORMAT(' THE COMPLEX EXPONENTIATION IS TO BE ', 1'COMPUTED') IF(IACASE.EQ.'COEX')CALL DPWRST('XXX','BUG ') IF(IACASE.EQ.'COSR')WRITE(ICOUT,1159) 1159 FORMAT(' THE COMPLEX SQUARE ROOT IS TO BE ', 1'COMPUTED') IF(IACASE.EQ.'COSR')CALL DPWRST('XXX','BUG ') IF(IACASE.EQ.'CORO')WRITE(ICOUT,1160) 1160 FORMAT(' THE COMPLEX ROOTS ARE TO BE ', 1'COMPUTED') IF(IACASE.EQ.'CORO')CALL DPWRST('XXX','BUG ') IF(IACASE.EQ.'COR1')WRITE(ICOUT,1161) 1161 FORMAT(' THE COMPLEX ROOTS ARE TO BE ', 1'COMPUTED') IF(IACASE.EQ.'COR1')CALL DPWRST('XXX','BUG ') IF(IACASE.EQ.'COCO')WRITE(ICOUT,1162) 1162 FORMAT(' THE COMPLEX CONJUGATE IS TO BE ', 1'COMPUTED') IF(IACASE.EQ.'COCO')CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1171) 1171 FORMAT(' MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1172) 1172 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1173)N1 1173 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 C 1190 CONTINUE C C ********************************* C ** STEP 12-- ** C ** BRANCH TO THE PROPER CASE ** C ********************************* C IF(IACASE.EQ.'COAD')GOTO2100 IF(IACASE.EQ.'COSU')GOTO2200 IF(IACASE.EQ.'COMU')GOTO2300 IF(IACASE.EQ.'CODI')GOTO2400 IF(IACASE.EQ.'COEX')GOTO2500 IF(IACASE.EQ.'COSR')GOTO2600 IF(IACASE.EQ.'CORO')GOTO2700 IF(IACASE.EQ.'COR1')GOTO2700 IF(IACASE.EQ.'COCO')GOTO2800 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1211) 1211 FORMAT('***** INTERNAL ERROR IN COMARI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1212) 1212 FORMAT(' IACASE NOT EQUAL TO') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1213) 1213 FORMAT(' COAD, COSU, COMU, CODI,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1214) 1214 FORMAT(' COEX, COSR, CORO, COR1,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1215) 1215 FORMAT(' OR COCO') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1221) 1221 FORMAT(' IACASE = ',A4) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C C ********************************************* C ** STEP 21-- ** C ** TREAT THE COMPLEX ADDITION CASE ** C ********************************************* C 2100 CONTINUE DO2110I=1,N1 DY1=Y1(I) DY2=Y2(I) DY3=Y3(I) DY4=Y4(I) DY5=DY1+DY3 DY6=DY2+DY4 Y5(I)=DY5 Y6(I)=DY6 2110 CONTINUE C ITYP3='VECT' N5=N1 GOTO9000 C C ********************************************* C ** STEP 22-- ** C ** TREAT THE COMPLEX SUBTRACTION CASE ** C ********************************************* C 2200 CONTINUE DO2210I=1,N1 DY1=Y1(I) DY2=Y2(I) DY3=Y3(I) DY4=Y4(I) DY5=DY1-DY3 DY6=DY2-DY4 Y5(I)=DY5 Y6(I)=DY6 2210 CONTINUE C ITYP3='VECT' N5=N1 GOTO9000 C C ********************************************* C ** STEP 23-- ** C ** TREAT THE COMPLEX MULTIPLICATION CASE ** C ********************************************* C 2300 CONTINUE DO2310I=1,N1 DY1=Y1(I) DY2=Y2(I) DY3=Y3(I) DY4=Y4(I) DY5=DY1*DY3-DY2*DY4 DY6=DY1*DY4+DY2*DY3 Y5(I)=DY5 Y6(I)=DY6 2310 CONTINUE C ITYP3='VECT' N5=N1 GOTO9000 C C ********************************************* C ** STEP 24-- ** C ** TREAT THE COMPLEX DIVISION CASE ** C ********************************************* C 2400 CONTINUE DO2410I=1,N1 DY1=Y1(I) DY2=Y2(I) DY3=Y3(I) DY4=Y4(I) DDEN=DY3**2+DY4**2 IF(DDEN.NE.0.0D0)GOTO2419 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2411) 2411 FORMAT('***** ERROR IN COMARI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2412) 2412 FORMAT(' A ZERO DENOMINATOR WAS ENCOUNTERED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2413) 2413 FORMAT(' IN ATTEMPTING TO CARRY OUT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2414) 2414 FORMAT(' A COMPLEX DIVISION.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2415)I 2415 FORMAT(' THE ',I8,'TH ELEMENT OF THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2416) 2416 FORMAT(' REAL AND IMAGINARY PARTS OF THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2417) 2417 FORMAT(' COMPLEX DIVISOR ARE BOTH 0') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2418)I,Y3(I),Y4(I) 2418 FORMAT('I,Y3(I),Y4(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 2419 CONTINUE DY5=(DY1*DY3+DY2*DY4)/DDEN DY6=(DY2*DY3-DY1*DY4)/DDEN Y5(I)=DY5 Y6(I)=DY6 2410 CONTINUE C ITYP3='VECT' N5=N1 GOTO9000 C C ********************************************* C ** STEP 25-- ** C ** TREAT THE COMPLEX EXPONENTIATION CASE ** C ********************************************* C 2500 CONTINUE DO2510I=1,N1 DY1=Y1(I) DY2=Y2(I) DE=DEXP(DY1) DC=DCOS(DY2) DS=DSIN(DY2) DY5=DE*DC DY6=DE*DS Y5(I)=DY5 Y6(I)=DY6 2510 CONTINUE C ITYP3='VECT' N5=N1 GOTO9000 C C ********************************************* C ** STEP 26-- ** C ** TREAT THE COMPLEX SQUARE ROOT CASE ** C ********************************************* C 2600 CONTINUE DO2610I=1,N1 CY1Y2=CMPLX(Y1(I),Y2(I)) CTRANS=CSQRT(CY1Y2) Y5(I)=REAL(CTRANS) Y6(I)=AIMAG(CTRANS) 2610 CONTINUE C ITYP3='VECT' N5=N1 GOTO9000 C C *********************************************** C ** STEP 27-- ** C ** TREAT THE COMPLEX ROOTS OF A POLYNOMIAL ** C ** WITH COMPLEX COEFFICIENTS CASE ** C *********************************************** C 2700 CONTINUE NCOEFS=N1 NROOTS=NCOEFS-1 C CCCCC AUGUST 1995. REPLACE NUMERICAL RECIPES ROUTINE WITH CCCCC SLATEC ROUTINE. CCCCC CPZERO EXPECTS COEFFICIENTS IN OPPOSIT ORDER OF ZROOTS. CCCCC DO2710I=1,NCOEFS CCCCC COEFS(I)=CMPLX(Y1(I),Y2(I)) C2710 CONTINUE ICOUNT=0 DO2710I=NCOEFS,1,-1 ICOUNT=ICOUNT+1 COEFS(ICOUNT)=CMPLX(Y1(I),Y2(I)) 2710 CONTINUE C IFLG=0 CALL CPZERO(NROOTS,COEFS,ROOTS,WORK,IFLG,ERRBND) IF(IFLG.EQ.1)THEN WRITE(ICOUT,2721) 2721 FORMAT('***** ERROR IN COMARI--LEADING COEFFICIENT IS ', 1 'ZERO OR DEGREE IS ZERO') CALL DPWRST('XXX','BUG ') ELSEIF(IFLG.EQ.2)THEN WRITE(ICOUT,2726) 2726 FORMAT('***** ERROR IN COMARI--ROOTS DID NOT CONVERGE.') CALL DPWRST('XXX','BUG ') ENDIF CCCCC POLISH=.FALSE. CCCCC CALL ZROOTS(COEFS,NROOTS,ROOTS,POLISH) C CCCCC DO2720I=1,NROOTS CCCCC ROOTS(I)=ROOTS(I)*(1.0+0.01*I) C2720 CONTINUE C CCCCC POLISH=.TRUE. CCCCC CALL ZROOTS(COEFS,NROOTS,ROOTS,POLISH) C DO2730I=1,NROOTS Y5(I)=REAL(ROOTS(I)) Y6(I)=AIMAG(ROOTS(I)) 2730 CONTINUE C ITYP3='VECT' N5=NROOTS GOTO9000 C C ********************************************* C ** STEP 28-- ** C ** TREAT THE COMPLEX CONJUGATE CASE ** C ********************************************* C 2800 CONTINUE DO2810I=1,N1 Y5(I)=Y1(I) Y6(I)=(-Y2(I)) 2810 CONTINUE C ITYP3='VECT' N5=N1 GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE C IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'MARI')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF COMARI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,ISUBRO,IACASE,IWRITE 9012 FORMAT('IBUGA3,ISUBRO,IACASE,IWRITE = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IERROR 9013 FORMAT('IERROR = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)N1,N5 9017 FORMAT('N1,N5 = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9018)SCAL3,ITYP3 9018 FORMAT('SCAL3,ITYP3 = ',E15.7,2X,A4) CALL DPWRST('XXX','BUG ') IF(ITYP3.EQ.'SCAL')GOTO9090 DO9015I=1,N1 WRITE(ICOUT,9016)I,Y1(I),Y2(I),Y3(I),Y4(I),Y5(I),Y6(I) 9016 FORMAT('I,Y1(I),Y2(I),Y3(I),Y4(I),Y5(I),Y6(I) = ',I8,6E13.5) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE COMDIG(X,N,IWRITE,XDIGI,NDIGI,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE COMMON DIGITS FOR A C VECTOR OF NUMBERS. FOR EXAMPLE, GIVEN C 0.0321, 0.0323, 0.0329, 0.0325 C THE COMMON DIGITS ARE 0.03. NOTE THAT ONLY DIGITS C TO THE RIGHT OF THE DECIMAL PLACE ARE CONSIDERED. C THE FOLLOWING SPECIAL CASES ARE CONSIDERED: C 1) IF THE FIRST DECIMAL DOES NOT AGREE, SET C XDIGI=-1.0. C 2) IF THE INTEGER PORTION OF THE NUMBER DOES C NOT AGREE, THEN SET XDIGI=-1.0. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C OUTPUT ARGUMENTS--XDIGI = THE SINGLE PRECISION VALUE OF THE C COMPUTED COMMON DIGITS C --NDIGI = THE INTEGER VALUE OF THE C NUMBER OF COMMON DIGITS C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C COMMON DIGITS C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2001.8 C ORIGINAL VERSION--AUGUST 2001. C PARAMETER(MAXDIG=7) C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION X(*) DIMENSION DIGITS(MAXDIG) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='COMD' ISUBN2='IG ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF COMDIG--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(N.GE.2)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN COMDIG--THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' IN THE VARIABLE FOR WHICH THE COMMON DIGITS ARE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' TO BE COMPUTED MUST BE 2 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116) 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,117)N 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,'.') CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C HOLD=X(1) DO135I=2,N IF(X(I).NE.HOLD)GOTO139 135 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,136)HOLD 136 FORMAT('***** NON-FATAL DIAGNOSTIC IN COMDIG--', 1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') XDIGI=ABS(HOLD)-REAL(INT(ABS(HOLD))) NDIGI=MAXDIG GOTO9000 139 CONTINUE C C CHECK IF INTEGER PORTION OF NUMBERS MATCHES FOR ALL THE NUMBERS. C IHOLD=INT(X(1)) DO145I=2,N IXTEMP=INT(X(I)) IF(IXTEMP.NE.IHOLD)THEN NDIG=-1 XDIGI=0.0 IF(IFEEDB.EQ.'OFF')GOTO149 IF(IWRITE.EQ.'OFF')GOTO149 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,146)N 146 FORMAT('THE INTEGER PORTION OF THE ',I8,' OBSERVATIONS DOES ', 1 'NOT MATCH.') CALL DPWRST('XXX','BUG ') 149 CONTINUE GOTO800 ENDIF 145 CONTINUE C 190 CONTINUE C C ************************ C ** STEP 2-- ** C ** COMPUTE THE DIGITS** C ************************ C XDIGI=0.0 NDIGI=0 C DO200L=1,MAXDIG ATEMP=X(1)*10**(L-1) ADIG=ABS(ATEMP) - INT(ABS(ATEMP)) IDIG=INT(ADIG*10) DO300I=2,N ATEMP=X(I)*10**(L-1) ADIG=ABS(ATEMP) - INT(ABS(ATEMP)) IDIG2=INT(ADIG*10) IF(IDIG.NE.IDIG2)GOTO209 300 CONTINUE NDIGI=NDIGI+1 DIGITS(NDIGI)=IDIG 200 CONTINUE 209 CONTINUE C IF(NDIGI.GT.0)THEN XDIGI=REAL(INT(X(1)))*(10**NDIGI) DO400I=1,NDIGI ATEMP=DIGITS(I)*(10**(NDIGI-I)) XDIGI=XDIGI + ATEMP 400 CONTINUE XDIGI=XDIGI/(10**NDIGI) ENDIF C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C 800 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)N,NDIGI 811 FORMAT('THE NUMBER OF COMMON DIGITS FOR THE ',I8, 1 ' OBSERVATIONS = ',I5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,813)XDIGI 813 FORMAT('THE COMMON DIGITS = ',G15.7) CALL DPWRST('XXX','BUG ') 890 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF SUM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N 9013 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)NDIGI,XDIGI 9015 FORMAT('NDIGI,XDIGI = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE COMOVE(X,Y,N,IWRITE,XYCOMO,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE (LEIGH-PERLMAN) COMOVEMENT COEFFICIENT C BETWEEN THE 2 SETS OF DATA IN THE INPUT VECTORS X AND Y. C THE SAMPLE COMOVEMENT COEFFICIENT WILL BE A SINGLE C PRECISION VALUE CALCULATED AS THE C SUM OF CROSS PRODUCTS DIVIDED BY (N-1). C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C (UNSORTED) OBSERVATIONS C WHICH CONSTITUTE THE FIRST SET C OF DATA. C --Y = THE SINGLE PRECISION VECTOR OF C (UNSORTED) OBSERVATIONS C WHICH CONSTITUTE THE SECOND SET C OF DATA. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X, OR EQUIVALENTLY, C THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR Y. C OUTPUT ARGUMENTS--XYCOMO = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE COMOVEMENT COEFFICIENT C BETWEEN THE 2 SETS OF DATA C IN THE INPUT VECTORS X AND Y. C THIS SINGLE PRECISION VALUE C WILL BE BETWEEN -1.0 AND 1.0 C (INCLUSIVELY). C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE COMOVEMENT COEFFICIENT BETWEEN THE 2 SETS C OF DATA IN THE INPUT VECTORS X AND Y. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--AN INDEX FOR COMOVEMENT OF TIME SEQUENCES C WITH GEOPHYSICAL APPLICATIONS: A WORKING PAPER C (PENN STATE INTERFACE CONFERANCE ON ASTRONOMY C AUGUST 11-14, 1991) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--92/8 C ORIGINAL VERSION--AUGUST 1991. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DOUBLE PRECISION DN DOUBLE PRECISION DXI DOUBLE PRECISION DXIM1 DOUBLE PRECISION DYI DOUBLE PRECISION DYIM1 DOUBLE PRECISION DDELX DOUBLE PRECISION DDELY DOUBLE PRECISION DSUMX DOUBLE PRECISION DSUMY DOUBLE PRECISION DSUMXY DOUBLE PRECISION DSQRTX DOUBLE PRECISION DSQRTY C DIMENSION X(*) DIMENSION Y(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='COMO' ISUBN2='VE ' C IERROR='NO' C DN=0.0D0 DSUMX=0.0D0 DSUMY=0.0D0 DSUMXY=0.0D0 C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF COMOVE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I),Y(I) 56 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ******************************************* C ** COMPUTE COMOVEMENT COEFFICIENT ** C ******************************************* C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(N.GE.2)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN COMOVE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' IN THE VARIABLE FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114) 114 FORMAT(' THE COMOVEMENT COEFFICIENT IS TO BE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' COMPUTED, MUST BE 2 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116) 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,117)N 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C IF(N.EQ.2)GOTO120 GOTO129 120 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** NON-FATAL DIAGNOSTIC IN COMOVE--', 1'THE THIRD INPUT ARGUMENT (N) HAS THE VALUE 2') CALL DPWRST('XXX','BUG ') XYCOMO=1.0 GOTO9000 129 CONTINUE C HOLD=X(1) DO135I=2,N IF(X(I).NE.HOLD)GOTO139 135 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,136)HOLD 136 FORMAT('***** NON-FATAL DIAGNOSTIC IN COMOVE--', 1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') XYCOMO=1.0 GOTO9000 139 CONTINUE C HOLD=Y(1) DO145I=2,N IF(Y(I).NE.HOLD)GOTO149 145 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,146)HOLD 146 FORMAT('***** NON-FATAL DIAGNOSTIC IN COMOVE--', 1'THE SECOND INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') XYCOMO=1.0 GOTO9000 149 CONTINUE C C ************************************************ C ** STEP 2-- ** C ** COMPUTE THE COMOVEMENT COEFFICIENT. ** C ************************************************ C DN=N DSUMX=0.0D0 DSUMY=0.0D0 DSUMXY=0.0D0 DO300I=2,N IM1=I-1 DXI=X(I) DXIM1=X(IM1) DDELX=DXI-DXIM1 DYI=Y(I) DYIM1=Y(IM1) DDELY=DYI-DYIM1 DSUMX=DSUMX+DDELX**2 DSUMY=DSUMY+DDELY**2 DSUMXY=DSUMXY+DDELX*DDELY 300 CONTINUE DSQRTX=0.0 IF(DSUMX.GT.0.0D0)DSQRTX=DSQRT(DSUMX) DSQRTY=0.0 IF(DSUMY.GT.0.0D0)DSQRTY=DSQRT(DSUMY) XYCOMO=DSUMXY/(DSQRTX*DSQRTY) C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)N,XYCOMO 811 FORMAT('THE LEIGH-PERLMAN COMOVEMENT COEF. OF THE ', 1I8,' OBSERV. = ',E15.7) CALL DPWRST('XXX','BUG ') 890 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF COV--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N 9013 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)DN,DSUMX,DSUMY,DSUMXY 9014 FORMAT('DN,DSUMX,DSUMY,DSUMXY = ',4D15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XYCOMO 9015 FORMAT('XYCOMO = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE COMPIC(IFUNC1,N1,IOLD,IOLD2,INEW,INEW2,NCHANG, 1IFUNC2,N2,IBUGA3,IERROR) C C PURPOSE--SCAN THE FUNCTIONAL EXPRESSION GIVEN IN IFUNC1 C AND CHANGE ALL OCCURRANCES OF C PARAMETER, VARIABLE, FUNCTION, AND C NUMBERS GIVEN IN IOLD BY THE CORRESPONDING C STRINGS GIVEN IN INEW. C NOTE--IT IS ASSUMED THAT NAMES ARE C ALREADY IN THE FORM OF A4--THAT IS C INDIVIDUALLY PACKED PER WORD. C NOTE--NUMBERS MAY NOT BE CHANGED. C NOTE--PARAMETERS MAY BE CHANGED TO NUMBERS C BUT ONLY THE FIRST 8 CHARACTERS OF THE NUMBER WILL C BE TRANSFERRED. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--JANUARY 1979. C UPDATED --FEBRUARY 1979. C UPDATED --JULY 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IFUNC1 CHARACTER*4 IOLD CHARACTER*4 IOLD2 CHARACTER*4 INEW CHARACTER*4 INEW2 CHARACTER*4 IFUNC2 CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C CHARACTER*4 ICH11 CHARACTER*4 ICH12 CHARACTER*4 ICH1 CHARACTER*4 ICH21 CHARACTER*4 ICH22 CHARACTER*4 ICH2 CHARACTER*4 ICASEP CHARACTER*4 ICASEA CHARACTER*4 IHALF1 CHARACTER*4 IHALF2 C C--------------------------------------------------------------------- C DIMENSION IFUNC1(*) DIMENSION IFUNC2(*) DIMENSION IOLD(*) DIMENSION IOLD2(*) DIMENSION INEW(*) DIMENSION INEW2(*) C DIMENSION ICH11(10) DIMENSION ICH12(10) DIMENSION ICH1(20) DIMENSION ICH21(10) DIMENSION ICH22(10) DIMENSION ICH2(20) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='COMP' ISUBN2='IC ' C IERROR='NO' C NUMASC=4 NUMAS2=2*NUMASC C IEND1=0 C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF COMPIC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)N1,IBUGA3 52 FORMAT('N1,IBUGA3 = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)(IFUNC1(I),I=1,N1) 53 FORMAT('IFUNC1(.)=',30A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)NCHANG 54 FORMAT('NCHANG = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,NCHANG WRITE(ICOUT,56)I,IOLD(I),IOLD2(I),INEW(I),INEW2(I) 56 FORMAT('I,IOLD(I),IOLD2(I),INEW(I),INEW2(I) = ', 1I8,2X,A4,A4,2X,A4,A4) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ******************************************** C ** STEP 1-- ** C ** COPY THE INPUT FUNCTION IN IFUNC1(.) ** C ** INTO THE OUTPUT VECTOR IFUNC2(.). ** C ******************************************** C ISTEPN='1' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(N1.LE.0)GOTO190 DO80I=1,N1 IFUNC2(I)=IFUNC1(I) 80 CONTINUE N2=N1 C C ***************************************** C ** STEP 2-- ** C ** LOOP THROUGH THE INPUT FUNCTION-- ** C ** 1 CHARACTER (USUALLY) AT A TIME. ** C ***************************************** C ISTEPN='2' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C I=0 100 CONTINUE I=I+1 IF(I.GT.N2)GOTO190 IF(NCHANG.LE.0)GOTO190 C C ****************************************** C ** STEP 3-- ** C ** FOR THIS CHARACTER (CHARACTER I), ** C ** SCAN THROUGH ALL POTENTIAL CHANGES ** C ** TO BE MADE. ** C ****************************************** C ISTEPN='3' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO200J=1,NCHANG CALL DPXH1H(IOLD(J),ICH11,IEND11,IBUGA3) CALL DPXH1H(IOLD2(J),ICH12,IEND12,IBUGA3) DO205K=1,NUMAS2 ICH1(K)=' ' 205 CONTINUE L=0 DO206K=1,NUMASC L=L+1 ICH1(L)=ICH11(K) 206 CONTINUE DO207K=1,NUMASC L=L+1 ICH1(L)=ICH12(K) 207 CONTINUE IEND1=0 IF(IEND11.GE.1)IEND1=IEND11 IF(IEND11.GE.NUMASC)IEND1=NUMASC IF(IEND12.GE.1)IEND1=NUMASC+IEND12 IF(IEND12.GE.NUMAS2)IEND1=NUMAS2 C IF(IEND1.LE.0)GOTO200 C C ********************************************* C ** STEP 4-- ** C ** CHECK FOR A LEFT OR RIGHT PARENTHESIS ** C ** IN THE INPUT CHANGE PATTERN. ** C ********************************************* C ISTEPN='4' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEP='NO' DO210K=1,IEND1 IF(ICH1(K).EQ.'(')GOTO220 IF(ICH1(K).EQ.')')GOTO220 210 CONTINUE ICASEP='NO' GOTO290 220 CONTINUE ICASEP='YES' 290 CONTINUE C C ******************************************************** C ** STEP 5-- ** C ** STARTING WITH CHARACTER I OF THE INPUT FUNCTION, ** C ** COMPARE THE STRING IN THE INPUT FUNCTION ** C ** WITH THIS INPUT CHANGE PATTERN. ** C ** DETERMINE IF THERE IS A MATCH. ** C ******************************************************** C ISTEPN='5' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C L1=I-1 DO300K=1,IEND1 L1=L1+1 IF(IFUNC2(L1).EQ.ICH1(K))GOTO300 GOTO200 300 CONTINUE C C ********************************************** C ** STEP 6-- ** C ** IF HAVE A MATCH, ** C ** CHECK TO SEE IF THE STRING ** C ** IN THE FUNCTION ** C ** IS PRECEDED BY A +, -, *, /, **, (, ** C ** (OR IS THE FIRST STRING ON THE LINE), ** C ** AND ALSO ** C ** IS SUCCEDED BY A +, -, *, /, **, ), ** C ** (OR IS THE LAST STRING ON THE LINE). ** C ** A FULFILLMENT OF ANY OF THE ABOVE ** C ** 14 CONDITIONS WILL BE SUFFICIENT ** C ** TO ASSURE THAT INDIVIDUAL MIDDLE ** C ** CHARACTERS IN LIBRARY FUNCTIONS ** C ** (E.G., THE 'X' IN 'EXP') ** C ** AND IN MULTI-CHARACTER VARIABLE NAMES ** C ** (E.G., THE 'X' IN 'FLUX') ** C ** WILL NOT BE INADVERTANTLY CHANGED ** C ** (E.G., BY, SAY, 'FOR X = 3'). ** C ********************************************** C ISTEPN='6' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEA='NO' IHALF1='NO' IHALF2='NO' C IM1=I-1 IF(IM1.LE.0)GOTO410 IF(IFUNC2(IM1).EQ.'+')GOTO410 IF(IFUNC2(IM1).EQ.'-')GOTO410 IF(IFUNC2(IM1).EQ.'*')GOTO410 IF(IFUNC2(IM1).EQ.'/')GOTO410 IF(IFUNC2(IM1).EQ.'**')GOTO410 IF(IFUNC2(IM1).EQ.'(')GOTO410 IHALF1='NO' GOTO419 410 CONTINUE IHALF1='YES' 419 CONTINUE C L1P1=L1+1 IF(L1P1.GT.N2)GOTO420 IF(IFUNC2(L1P1).EQ.'+')GOTO420 IF(IFUNC2(L1P1).EQ.'-')GOTO420 IF(IFUNC2(L1P1).EQ.'*')GOTO420 IF(IFUNC2(L1P1).EQ.'/')GOTO420 IF(IFUNC2(L1P1).EQ.'**')GOTO420 IF(IFUNC2(L1P1).EQ.')')GOTO420 IHALF2='NO' GOTO429 420 CONTINUE IHALF2='YES' 429 CONTINUE C ICASEA='NO' IF(IHALF1.EQ.'YES'.AND.IHALF2.EQ.'YES')ICASEA='YES' C 490 CONTINUE C C *********************************************************** C ** STEP 7-- ** C ** IF THE INPUT STRING HAD ANY PARENTHESES, ** C ** THEN CHANGE ANY MATCHING STRING IN THE FUNCTION. ** C ** IF THE INPUT STRING HAD NO PARENTHESES, ** C ** THEN CHANGE MATCHING STRINGS IN THE FUNCTION ** C ** ONLY WHEN THE MATCHING FUNCTION SUBSTRING ** C ** IS PRECEDED BY A +, -, *, /, **, (, ** C ** (OR IS THE FIRST STRING ON THE LINE), AND ALSO ** C ** IS SUCCEDED BY A +, -, *, /, **, ), ** C ** (OR IS THE LAST STRING ON THE LINE). ** C *********************************************************** C ISTEPN='7' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEP.EQ.'YES')GOTO590 IF(ICASEP.EQ.'NO'.AND.ICASEA.EQ.'YES')GOTO590 GOTO200 590 CONTINUE C C ************************************************** C ** STEP 8-- ** C ** IF CHANGES ARE TO BE MADE, ** C ** EXTRACT THE OUTPUT CHANGE PATTERN ** C ** CORRESPONDING TO THE INPUT CHANGE PATTERN. ** C ************************************************** C ISTEPN='8' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL DPXH1H(INEW(J),ICH21,IEND21,IBUGA3) CALL DPXH1H(INEW2(J),ICH22,IEND22,IBUGA3) DO605K=1,NUMAS2 ICH2(K)=' ' 605 CONTINUE L=0 DO606K=1,NUMASC L=L+1 ICH2(L)=ICH21(K) 606 CONTINUE DO607K=1,NUMASC L=L+1 ICH2(L)=ICH22(K) 607 CONTINUE IEND2=0 IF(IEND21.GE.1)IEND2=IEND21 IF(IEND21.GE.NUMASC)IEND2=NUMASC IF(IEND22.GE.1)IEND2=NUMASC+IEND21 IF(IEND22.GE.NUMAS2)IEND2=NUMAS2 C IF(IEND2.LE.0)GOTO200 C C ****************************** C ** STEP 9-- ** C ** CARRY OUT THE CHANGES ** C ** IN THE INPUT FUNCTION. ** C ****************************** C ISTEPN='9' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ISTAR1=I ISTOP1=ISTAR1+IEND1-1 ISTAR2=1 ISTOP2=ISTAR2+IEND2-1 CALL DPSIRS(IFUNC2,N2,ISTAR1,ISTOP1,ICH2,IEND2,ISTAR2,ISTOP2, 1IBUGA3,IERROR) I=ISTOP1+(IEND2-IEND1) GOTO100 C 200 CONTINUE GOTO100 C 190 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF COMPIC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)N1,IBUGA3 9012 FORMAT('N1,IBUGA3 = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)(IFUNC1(I),I=1,N1) 9013 FORMAT('IFUNC1(.)=',30A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NCHANG 9014 FORMAT('NCHANG = ',I8) CALL DPWRST('XXX','BUG ') DO9015I=1,NCHANG WRITE(ICOUT,9016)I,IOLD(I),IOLD2(I),INEW(I),INEW2(I) 9016 FORMAT('I,IOLD(I),IOLD2(I),INEW(I),INEW2(I) = ', 1I8,2X,A4,A4,2X,A4,A4) CALL DPWRST('XXX','BUG ') 9015 CONTINUE WRITE(ICOUT,9017)N2 9017 FORMAT('N2 = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9018)(IFUNC2(I),I=1,N2) 9018 FORMAT('IFUNC2(.)=',30A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9019)NUMASC,NUMAS2 9019 FORMAT('NUMASC,NUMAS2 = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9020)IEND11,IEND12,IEND1,IEND21,IEND22,IEND2 9020 FORMAT('IEND11,IEND12,IEND1,IEND21,IEND22,IEND2 = ',6I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)(ICH11(I),I=1,10) 9021 FORMAT('(ICH11(I),I=1,10) = ',10A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9022)(ICH12(I),I=1,10) 9022 FORMAT('(ICH12(I),I=1,10) = ',10A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9023)(ICH1 (I),I=1,10) 9023 FORMAT('(ICH1 (I),I=1,10) = ',10A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9024)(ICH21(I),I=1,10) 9024 FORMAT('(ICH21(I),I=1,10) = ',10A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9025)(ICH22(I),I=1,10) 9025 FORMAT('(ICH22(I),I=1,10) = ',10A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9026)(ICH2 (I),I=1,10) 9026 FORMAT('(ICH2 (I),I=1,10) = ',10A1) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE COMPID(IA,NUMCHA,IPASS,PARAM,IPARN1,IPARN2,NUMPAR, 1IVARN1,IVARN2,NUMVAR, 1IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,ID,NUMCHD, 1IBUGCO,IBUGEV,ISUBRO,IERROR) C C PURPOSE--THIS SUBROUTINE DETERMINES THE DERIVATIVE OF C A FORTRAN MATHEMATICAL FUNCTION EXPRESSION. C NOTE--TYPICALLY THIS SUBROUTINE IS CALLED ONLY C WITH IPASS=2; IN SUCH CASE, C IPARN1(.) AND NUMPAR ARE NEVER DETERMINED, C NEEDED, OR OUTPUTTED. C (NOTE--THERE EXISTS POSSIBLE DIFFERENCES WITH NUMPAR C AS DEFINED FOR THIS SUBROUTINE C AS OPPOSED TO THE DEFINITION FOR COMPID). C INPUT ARGUMENTS--IA = THE HOLLARITH VECTOR WHICH CONTAINS C THE FUNCTION OF INTEREST C FOR WHICH THE ANALYTIC DERIVATIVE C IS TO BE DETERMINED. C IA(.) MAY BE EITHER UNPACKED (1 CHARACTER PER W C OR PACKED (4 CHARACTERS PER WORD) C ALTHOUGH THE USUAL REPRESENTATION IS UNPACKED. C --NUMCHA = THE INTEGER VALUE WHICH C DEFINES THE NUMBER OF CHARACTERS IN IA. C NUMCHA DEFINES THE LENGTH OF THE C HOLLARITH STRING TO BE OPERATED ON. C --IPASS = AN INTEGER FLAG CODE C WHICH DEFINES WHICH PASS (1 OR 2) INTO THIS C SUBROUTINE THE USER IS IN. C PASS 1 DETERMINE PARAMETER NAMES; C PASS 2 DOES FUNCTION EVALUATIONS. C --PARAM = THE SINGLE PRECISION VECTOR OF PARAMETER C (AND VARIABLE) C VALUES CORRESPONDING TO THE PARAMETER NAMES C AS GIVEN IN THE VECTOR IPARN1. C --IPARN1 = THE INTEGER VECTOR OF PARAMETER C (AND VARIABLE) C NAMES AS TYPICALLY DETERMINED BY PASS 1. C OUTPUT ARGUMENTS--ID = THE HOLLARITH VECTOR WHICH CONTAINS C THE DESIRED DERIVATIVE FUNCTION. C ID(.) IS UNPACKED (THAT IS, C 1 CHARACTER PER WORD). C --NUMCHD = THE INTEGER VALUE WHICH C DEFINES THE NUMBER OF CHARACTERS IN ID. C NUMCHD DEFINES THE LENGTH OF THE C HOLLARITH STRING FOR THE DERIVATIVE FUNCTION. C OUTPUT--THE SINGLE PRECISION COMPUTED SCALAR VALUE, C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER SUBROUTINES NEEDED--EVAL C FORTRAN LIBRARY SUBROUTINES NEEDED--(ALL IN EVAL) C SQRT C EXP C ALOG C ALOG10 C SIN C COS C ATAN C ATAN2 C TANH C ABS C AINT C ARCSIN C ARCCOS C ARCTAN C OCTAL C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C NOTE--THIS SUBROUTINE ALLOWS ONE TO PERFORM C INTERACTIVE FUNCTION EVALUATIONS. C REFERENCES--NONE. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE: 301-921-2315 C ORIGINAL VERSION--DECEMBER 1978. C UPDATED --JANUARY 1979. C UPDATED --JANUARY 1981. C UPDATED --APRIL 1986. C CHARACTER*4 IA CHARACTER*4 IPARN1 CHARACTER*4 IPARN2 CHARACTER*4 IVARN1 CHARACTER*4 IVARN2 CHARACTER*4 IANGLU CHARACTER*4 ITYPEH CHARACTER*4 IW21HO CHARACTER*4 IW22HO CHARACTER*4 IBUGCO CHARACTER*4 IBUGEV CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C CHARACTER*4 IR CHARACTER*4 IB CHARACTER*4 IL CHARACTER*4 ICH CHARACTER*4 IW21 CHARACTER*4 IW22 CHARACTER*4 ITYPE CHARACTER*4 IANS1 CHARACTER*4 IANS2 CHARACTER*4 IANS3 CHARACTER*4 IANS4 CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CCCCC CHARACTER*4 IBUG0 CCCCC CHARACTER*4 IBUG1 CCCCC CHARACTER*4 IBUG2 CCCCC CHARACTER*4 IBUG3 CCCCC CHARACTER*4 IBUG4 CCCCC CHARACTER*4 IBUG5 CCCCC CHARACTER*4 IBUG6 CCCCC CHARACTER*4 IBUG7 CCCCC CHARACTER*4 IBUGXH CCCCC CHARACTER*4 IBUGCD C CHARACTER*4 ID CHARACTER*4 ID1 CHARACTER*4 ID2 CHARACTER*4 ID3 CHARACTER*4 ICON C C--------------------------------------------------------------------- C DIMENSION IA(*) DIMENSION PARAM(*) DIMENSION IPARN1(*) DIMENSION IPARN2(*) C DIMENSION IVARN1(*) DIMENSION IVARN2(*) C DIMENSION ID(*) C C NOTE--THE DIMENSIONS OF ITYPEH, IW21HO, IW22HO, AND W2HOLD C WHICH ARE DEFINED IN THE MAIN PROGRAM C SHOULD BE AT LEAST AS LARGE AS THE DIMENSIONS C OF IW21 AND IW22 BELOW. C DIMENSION ITYPEH(*) DIMENSION IW21HO(*) DIMENSION IW22HO(*) DIMENSION W2HOLD(*) C CCCCC DIMENSION IB(225) CCCCC DIMENSION IR(225) CCCCC DIMENSION IBEGIN(225) CCCCC DIMENSION IEND(225) CCCCC DIMENSION ITYPE(225) CCCCC DIMENSION IW21(225) CCCCC DIMENSION IW22(225) CCCCC DIMENSION W2(225) DIMENSION IB(1000) DIMENSION IR(1000) DIMENSION IBEGIN(1000) DIMENSION IEND(1000) DIMENSION ITYPE(1000) DIMENSION IW21(1000) DIMENSION IW22(1000) DIMENSION W2(1000) C DIMENSION ID1(250) DIMENSION ID2(250) DIMENSION ID3(250) C DIMENSION ICH(10) C DIMENSION IL(10) C DIMENSION ICON(1000) DIMENSION ICON1(50) DIMENSION ICON2(50) C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS----------------------------------------------------- C CCCCC DATA IBUG0/'OFF'/ CCCCC DATA IBUG1/'OFF'/ CCCCC DATA IBUG2/'OFF'/ CCCCC DATA IBUG3/'OFF'/ CCCCC DATA IBUG4/'OFF'/ CCCCC DATA IBUG5/'OFF'/ CCCCC DATA IBUG6/'OFF'/ CCCCC DATA IBUG7/'OFF'/ CCCCC DATA IBUGXH/'OFF'/ CCCCC DATA IBUGCD/'OFF'/ C C DEFINE THE UPPER LIMIT OF THE NUMBER OF CHARACTERS C THAT MAY BE PROCESSED BY THIS SUBROUTINE C (COUNTING BLANKS, LEFT-HAND SIDE, EQUAL SIGN, C AND RIGHT HAND SIDE). C IF RESTRICT THE EXPRESSION TO 1 LINE IMAGE, C THEN A REASONABLE UPPER BOUND IS 80. C WHATEVER UPPER BOUND IS SET, C THE DIMENSIONS OF MOST OF THE VECTORS C MUST BE EQUAL OR LARGER TO THIS NUMBER. C (THE VECTOR IL(.) WHICH CONTAINS THE C NUMBER OF CHARACTERS TO THE LEFT C OF THE EQUAL SIGN (BLANKS IGNORED) C MAY BE MUCH SMALLER--LIKE 6.) C NOTE--AS OF JANUARY 1979, THE BOUND WAS RESET TO 150. C CCCCC DATA MAXCHA/150/ CCCCC DATA MAXCHA/225/ DATA MAXCHA/1000/ C C-----START POINT----------------------------------------------------- C ISUBN1='COMP' ISUBN2='ID ' C IERROR='NO ' C C THE FOLLOWING STATEMENT (N=1) HAS BEEN ADDED C IN CONVERTING THE COMPIL SUBROUTINE C TO THE COMPID SUBROUTINE. C N=1 C IF(IBUGCO.EQ.'OFF'.AND.ISUBRO.NE.'MPID')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF COMPID--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NUMCHA,N,IPASS,IANGLU 52 FORMAT('NUMCHA,N,IPASS,IANGLU = ',3I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)(IA(I),I=1,NUMCHA) 53 FORMAT('IA--',80A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IBUGCO,IBUGEV 54 FORMAT('IBUGCO,IBUGEV = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61)NUMPAR 61 FORMAT('NUMPAR = ',I8) CALL DPWRST('XXX','BUG ') IF(NUMPAR.LE.0)GOTO64 DO62I=1,NUMPAR WRITE(ICOUT,63)I,IPARN1(I),IPARN2(I),PARAM(I) 63 FORMAT('I,IPARN1(I),IPARN2(I),PARAM(I) = ',I8,2X,A4,2X,A4,2X, 1E15.7) CALL DPWRST('XXX','BUG ') 62 CONTINUE 64 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,65)NUMVAR 65 FORMAT('NUMVAR = ',I8) CALL DPWRST('XXX','BUG ') IF(NUMVAR.LE.0)GOTO69 DO66I=1,NUMVAR WRITE(ICOUT,67)I,IVARN1(I),IVARN2(I) 67 FORMAT('I,IVARN1(I),IVARN2(I) = ',I8,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 66 CONTINUE 69 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71)NWHOLD 71 FORMAT('NWHOLD = ',I8) CALL DPWRST('XXX','BUG ') IF(NWHOLD.LE.0)GOTO79 DO72I=1,NWHOLD WRITE(ICOUT,73)I,ITYPEH(I),IW21HO(I),IW22HO(I),W2HOLD(I) 73 FORMAT('I,ITYPEH(I),IW21HO(I),IW22HO(I),W2HOLD(I) = ', 1I8,2X,A4,2X,A4,2X,A4,2X,E15.7) CALL DPWRST('XXX','BUG ') 72 CONTINUE 79 CONTINUE 90 CONTINUE C C ************************************************************ C ** DEFINE NUMASC = NUMBER OF ASCII CHARACTERS PER WORD. ** C ** THIS IS 4 REGARDLESS OF THE COMPUTER MAKE AND ** C ** REGARDLESS OF THE WORD SIZE. ** C ************************************************************ C NUMASC=4 NUMAS2=2*NUMASC NUMAS3=3*NUMASC NUMAS4=4*NUMASC C C CHECK THAT THE INPUT NUMBER OF CHARACTERS NUMCHA C (INCLUDING LEFT SIDE, RIGHT SIDE, EQUAL SIGN, C AND BLANKS) IS AT LEAST 1 AND AT MOST MAXCHA C (WHERE MAXCHA IS THE INTERNALLY DEFINED VARIABLE C WHICH CONTROLS DIMENSION SIZES AND WHICH C TYPICALLY HAS THE VALUE 80). C IF(1.LE.NUMCHA.AND.NUMCHA.LE.MAXCHA)GOTO139 WRITE(ICOUT,121) 121 FORMAT('***** ERROR IN COMPID--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,122) 122 FORMAT(' THE NUMBER OF CHARACTERS NUMCHA ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,123) 123 FORMAT(' WHICH DEFINES THE LENGTH OF THE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,124) 124 FORMAT(' INPUT EXPRESSION (INCLUDING LEFT-HAND SIDE,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,125) 125 FORMAT(' RIGHT-HAND SIDE, EQUAL SIGN, AND ALL BLANKS)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,126) 126 FORMAT(' IS SMALLER THAN 1 OR LARGER THAN MAXCHA') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,127) 127 FORMAT(' (MAXCHA IS AN INTERNALLY-DEFINED VARIABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,128)MAXCHA 128 FORMAT(' WHICH HAS THE VALUE = ',I8,' .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,129) 129 FORMAT(' THE NUMBER OF CHARACTERS IN THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,130)NUMCHA 130 FORMAT(' INPUT EXPRESSION IS ',I8) CALL DPWRST('XXX','BUG ') IF(NUMCHA.GE.1)WRITE(ICOUT,131)(IA(I),I=1,NUMCHA) 131 FORMAT(' INPUT EXPRESSION--',100A1) IF(NUMCHA.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES ' GOTO9000 139 CONTINUE C C BLANK-OUT AND ZERO-OUT SOME VARIABLES AND VECTORS. C CCCCC Y=0.0 IC2=0 C DO160I=1,NUMCHA IR(I)=' ' IB(I)=' ' IW21(I)=' ' IW22(I)=' ' W2(I)=0.0 ITYPE(I)=' ' IW21HO(I)=' ' IW22HO(I)=' ' W2HOLD(I)=0.0 ITYPEH(I)=' ' ID1(I)=' ' ID2(I)=' ' ID3(I)=' ' ID(I)=' ' 160 CONTINUE C C C *********************************************** C ** STEP 1-- ** C ** OPERATE ON THE VECTOR IA(.). ** C ** IA(.) MAY BE OPTIONALLY EITHER UNPACKED ** C ** (1 CHARACTER PER WORD), ** C ** OR PACKED ** C ** (UP TO 4 CHARACTERS PER WORD). ** C ** IN ANY EVENT, IB(.) IS UNPACKED. ** C ** NOTE ALSO THAT IB(.) HAS BLANKS OMITTED. ** C *********************************************** C ISTEPN='1' IF(IBUGCO.EQ.'ON'.OR.ISUBRO.EQ.'RIV4') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C K=0 DO200I=1,NUMCHA IF(IA(I).EQ.' ')GOTO200 CALL DPXH1H(IA(I),ICH,ILASTC,IBUGEV) IF(ILASTC.LE.0)GOTO200 DO250J=1,ILASTC K=K+1 IB(K)=ICH(J) 250 CONTINUE 200 CONTINUE NCTOT=K C IF(NCTOT.GE.1)GOTO290 WRITE(ICOUT,205)NCTOT 205 FORMAT('***** ERROR IN COMPID--TOTAL NUMBER OF CHARACTERS ', 1'IN MODEL (INCL. BOTH SIDES, BLANKS, AND EQUAL SIGN) ', 1'IS < 2. NCTOT = ',I5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,271)NUMCHA,N,IPASS 271 FORMAT('NUMCHA,N,IPASS = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,272)(IA(I),I=1,NUMCHA) 272 FORMAT('IA--',80A1) CALL DPWRST('XXX','BUG ') C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,281)NUMPAR 281 FORMAT('NUMPAR = ',I8) CALL DPWRST('XXX','BUG ') IF(NUMPAR.LE.0)GOTO289 DO282I=1,NUMPAR WRITE(ICOUT,283)I,IPARN1(I),IPARN2(I),PARAM(I) 283 FORMAT('I,IPARN1(I),IPARN2(I),PARAM(I) = ',I8,2X,A4,2X,A4,2X, 1E15.7) CALL DPWRST('XXX','BUG ') 282 CONTINUE 289 CONTINUE IERROR='YES ' GOTO9000 C 290 CONTINUE IF(IBUGCO.EQ.'OFF'.AND.ISUBRO.NE.'MPID')GOTO299 WRITE(ICOUT,291)NCTOT 291 FORMAT('NCTOT = ',I8) CALL DPWRST('XXX','BUG ') DO292I=1,NCTOT WRITE(ICOUT,293)I,IB(I) 293 FORMAT('I,IB(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 292 CONTINUE 299 CONTINUE C C ************************************************************** C ** STEP 2-- ** C ** OPERATE ON THE VECTOR IB(.). ** C ** DETERMINE THE NUMBER OF CHARACTERS (IF ANY) ** C ** FOR THE LEFT-HAND SIDE. OUTPUT THEM INTO THE ** C ** VECTOR IL(.). ** C ************************************************************** C DO500I=1,NCTOT I2=I IF(IB(I).EQ.'= ')GOTO550 500 CONTINUE NCL=0 ISTARR=1 GOTO559 550 CONTINUE NCL=I2-1 ISTARR=I2+1 559 CONTINUE C IF(NCL.LE.0)GOTO699 DO600I=1,NCL IL(I)=IB(I) 600 CONTINUE 690 CONTINUE IF(IBUGCO.EQ.'OFF'.AND.ISUBRO.NE.'MPID')GOTO699 ISTEPN='2' CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) WRITE(ICOUT,691)NCL 691 FORMAT('NCL = ',2I8) CALL DPWRST('XXX','BUG ') DO692I=1,NCL WRITE(ICOUT,693)I,IL(I) 693 FORMAT('I,IL(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 692 CONTINUE 699 CONTINUE C C *************************************************************** C ** STEP 3-- ** C ** OPERATE ON THE VECTOR IB(.). ** C ** DETERMINE THE NUMBER OF CHARACTERS FOR RIGHT-HAND SIDE. ** C ** OUTPUT THEM INTO THE VECTOR IR(.). ** C *************************************************************** C IF(ISTARR.LE.NCTOT)GOTO719 WRITE(ICOUT,701) 701 FORMAT('***** ERROR IN COMPID--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,702) 702 FORMAT(' THE NUMBER OF CHARACTERS ON THE RIGHT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,703) 703 FORMAT(' (WITH BLANKS IGNORED) IS 0.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,704) 704 FORMAT(' THE TOTAL NUMBER OF PACKED CHARACTERS NCTOT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,705) 705 FORMAT(' LEFT (IF ANY), EQUAL SIGN (IF ANY), AND RIGHT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,706)NCTOT 706 FORMAT(' = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,707) 707 FORMAT(' THE START POSITION FOR THE PACKED RIGHT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,708)ISTARR 708 FORMAT(' IS COLUMN ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,709)NUMCHA 709 FORMAT(' THE INPUT NUMBER OF CHARACTERS NUMCHA = ',I8) CALL DPWRST('XXX','BUG ') IF(NUMCHA.GE.1)WRITE(ICOUT,710)(IA(I),I=1,NUMCHA) 710 FORMAT(' INPUT EXPRESSION--',100A1) IF(NUMCHA.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES ' GOTO9000 719 CONTINUE C K=0 DO700I=ISTARR,NCTOT K=K+1 IR(K)=IB(I) 700 CONTINUE NCR=K C IF(IBUGCO.EQ.'OFF'.AND.ISUBRO.NE.'MPID')GOTO799 ISTEPN='3' CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) WRITE(ICOUT,791)NCR 791 FORMAT('NCR = ',2I8) CALL DPWRST('XXX','BUG ') DO792I=1,NCR WRITE(ICOUT,793)I,IR(I) 793 FORMAT('I,IR(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 792 CONTINUE 799 CONTINUE C C **************************************************************** C ** STEP 4-- C ** OPERATE ON THE VECTOR IR(.). C ** SIMPLIFY THE RIGHT-HAND SIDE. C ** ANALYZE THE RIGHT-HAND SIDE. C ** DETERMINE THE NUMBER OF DIFFERENT LOGICAL COMPONENTS. C ** 1. NUMBER (CONSISTING OF 0,1,2,...,9 OR .) C ** 2. X VARIABLE C ** 3. OPERATION (+ - * / **) C ** 4. PARENTHESES ( ( OR ) ) C ** 5. LIBRARY FUNCTION (ALOG EXP ETC + AUGMENTED LIB. C ** 6. COMMA (FOR MULTI-ARGUMENT LIBRARY FUNCTIONS) C ** 7. PARAMETER (ANYTHING NOT ABOVE) C ** CHECK FOR SYNTAX ERRORS. C ** OUTPUT THE TYPE COMPONENT INTO ITYPE(.). C ** OUTPUT THE START LOCATION IN IR(.) OF EACH COMPONENT INTO IB C ** OUTPUT THE STOP LOCATION IN IR(.) OF EACH COMPONENT INTO IE C **************************************************************** C CALL DPSIPA(IR,NCR,IBUGEV,IERROR) CALL DPSISI(IR,NCR,IBUGEV,IERROR) CALL DPSIP1(IR,NCR,IBUGEV,IERROR) CALL DPSIP0(IR,NCR,IBUGEV,IERROR) CALL DPSIE1(IR,NCR,IBUGEV,IERROR) CALL DPSIE0(IR,NCR,IBUGEV,IERROR) CALL DPSIA0(IR,NCR,IBUGEV,IERROR) CALL DPSIA2(IR,NCR,IBUGEV,ISUBRO,IERROR) CALL DPSIFL(IR,NCR,IBUGEV,IERROR) C NW=0 I=1 NCON=0 1050 CONTINUE IP1=I+1 IP2=I+2 IP3=I+3 IP4=I+4 IP5=I+5 C IF(IR(I).EQ.'0 ')GOTO1100 IF(IR(I).EQ.'1 ')GOTO1100 IF(IR(I).EQ.'2 ')GOTO1100 IF(IR(I).EQ.'3 ')GOTO1100 IF(IR(I).EQ.'4 ')GOTO1100 IF(IR(I).EQ.'5 ')GOTO1100 IF(IR(I).EQ.'6 ')GOTO1100 IF(IR(I).EQ.'7 ')GOTO1100 IF(IR(I).EQ.'8 ')GOTO1100 IF(IR(I).EQ.'9 ')GOTO1100 IF(IR(I).EQ.'. ')GOTO1100 C C NOTE--THE FOLLOWING LINE IS BEING COMMENTED OUT C SO AS TO GENERALIZE COMPIL INTO COMPID C (1 VARIABLE INTO MANY VARIABLES). C CCCCC IF(IR(I).EQ.'X ')GOTO1200 C IF(IR(I).EQ.'+ ')GOTO1300 IF(IR(I).EQ.'- ')GOTO1300 IF(IR(I).EQ.'* ')GOTO1300 IF(IR(I).EQ.'/ ')GOTO1300 C IF(IR(I).EQ.'( ')GOTO1410 IF(IR(I).EQ.') ')GOTO1420 C IF(IR(I).EQ.', ')GOTO1700 C C CHECK FOR A LIBRARY FUNCTION. C CCCCC CALL CKLIBF(IR,NCR,I,IFOUND,NCLF,IBUGEV,IERROR) CALL CKLIB1(IR,NCR,I,IFOUND,NCLF,IBUGEV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IF(IFOUND.EQ.'NO')CALL CKLIB2(IR,NCR,I,IFOUND,NCLF,IBUGEV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C IF(IBUGCO.EQ.'OFF'.AND.ISUBRO.NE.'MPID')GOTO1069 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1061) 1061 FORMAT('***** IN COMPID, AFTER RETURNING FROM CKLIBF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1062)NCR,I 1062 FORMAT('NCR,I = ',2I8) CALL DPWRST('XXX','BUG ') DO1063I4=1,NCR WRITE(ICOUT,1064)I4,IR(I4) 1064 FORMAT('I4,IR(I4) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 1063 CONTINUE WRITE(ICOUT,1065)IFOUND,NCLF,IERROR 1065 FORMAT('IFOUND,NCLF,IERROR = ',A4,I8,2X,A4) CALL DPWRST('XXX','BUG ') 1069 CONTINUE C IF(IERROR.EQ.'YES ')GOTO9000 IF(IFOUND.EQ.'YES '.AND.NCLF.EQ.8)GOTO1580 IF(IFOUND.EQ.'YES '.AND.NCLF.EQ.7)GOTO1570 IF(IFOUND.EQ.'YES '.AND.NCLF.EQ.6)GOTO1560 IF(IFOUND.EQ.'YES '.AND.NCLF.EQ.5)GOTO1550 IF(IFOUND.EQ.'YES '.AND.NCLF.EQ.4)GOTO1540 IF(IFOUND.EQ.'YES '.AND.NCLF.EQ.3)GOTO1530 IF(IFOUND.EQ.'YES '.AND.NCLF.EQ.2)GOTO1520 IF(IFOUND.EQ.'YES '.AND.NCLF.EQ.1)GOTO1510 C GOTO1600 C 1100 CONTINUE NCON=NCON+1 ICON1(NCON)=IC2+1 IC=0 NW=NW+1 ITYPE(NW)='N ' JMIN=I J=I 1150 CONTINUE IC=IC+1 IC2=IC2+1 ICON(IC2)=IR(J) J=J+1 IF(J.GT.NCR)GOTO1160 IF(IR(J).EQ.'0 ')GOTO1150 IF(IR(J).EQ.'1 ')GOTO1150 IF(IR(J).EQ.'2 ')GOTO1150 IF(IR(J).EQ.'3 ')GOTO1150 IF(IR(J).EQ.'4 ')GOTO1150 IF(IR(J).EQ.'5 ')GOTO1150 IF(IR(J).EQ.'6 ')GOTO1150 IF(IR(J).EQ.'7 ')GOTO1150 IF(IR(J).EQ.'8 ')GOTO1150 IF(IR(J).EQ.'9 ')GOTO1150 IF(IR(J).EQ.'. ')GOTO1150 1160 CONTINUE ICON2(NCON)=IC2 JMAX=J-1 GOTO1800 C C1200 CONTINUE CCCCC NW=NW+1 CCCCC NLPWP=0 CCCCC NRPWP=0 CCCCC JMIN=I CCCCC J=I CCCCC ILOOP=0 1250 CONTINUE J=J+1 IF(J.GT.NCR)GOTO1260 IF(IR(J).EQ.'+ ')GOTO1260 IF(IR(J).EQ.'- ')GOTO1260 IF(IR(J).EQ.'* ')GOTO1260 IF(IR(J).EQ.'/ ')GOTO1260 IF(IR(J).EQ.'( ')NLPWP=NLPWP+1 IF(IR(J).EQ.') ')NRPWP=NRPWP+1 IF(IR(J).EQ.') '.AND.NRPWP.GT.NLPWP)GOTO1260 ILOOP=ILOOP+1 IF(ILOOP.LE.NUMAS2)GOTO1250 WRITE(ICOUT,1256)NUMAS2 1256 FORMAT('***** ERROR IN COMPID--PARAMETER NAME EXCEEDS ',I8, 1'CHARACTERS') CALL DPWRST('XXX','BUG ') DO1257K=JMIN,J WRITE(ICOUT,1258)K,IR(K) 1258 FORMAT('K,IR(K) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 1257 CONTINUE IERROR='YES ' GOTO9000 1260 CONTINUE JMAX=J-1 C THE FOLLOWING STATEMENT HAS BEEN C COMMENTED OUT IN GOING FROM THE C COMPIL SUBROUTINE TO THE COMPID C SUBROUTINE SO THAT X WILL NOT C BE TREATED AS A SPECIAL VARIABLE. CCCCC IF(JMAX.EQ.JMIN)ITYPE(NW)='X ' IF(JMAX.GT.JMIN)ITYPE(NW)='PAR ' GOTO1800 C 1300 CONTINUE NW=NW+1 ITYPE(NW)='OP ' JMIN=I JMAX=I IP1=I+1 IF(IR(I).EQ.'* '.AND.IR(IP1).EQ.'* ')JMAX=IP1 GOTO1800 C 1410 CONTINUE NW=NW+1 ITYPE(NW)='LP ' JMIN=I JMAX=I GOTO1800 1420 CONTINUE NW=NW+1 ITYPE(NW)='RP ' JMIN=I JMAX=I GOTO1800 C 1510 CONTINUE NW=NW+1 ITYPE(NW)='LF ' JMIN=I JMAX=I GOTO1800 C 1520 CONTINUE NW=NW+1 ITYPE(NW)='LF ' JMIN=I JMAX=I+1 GOTO1800 C 1530 CONTINUE NW=NW+1 ITYPE(NW)='LF ' JMIN=I JMAX=I+2 GOTO1800 C 1540 CONTINUE NW=NW+1 ITYPE(NW)='LF ' JMIN=I JMAX=I+3 GOTO1800 C 1550 CONTINUE NW=NW+1 ITYPE(NW)='LF ' JMIN=I JMAX=I+4 GOTO1800 C 1560 CONTINUE NW=NW+1 ITYPE(NW)='LF ' JMIN=I JMAX=I+5 GOTO1800 C 1570 CONTINUE NW=NW+1 ITYPE(NW)='LF ' JMIN=I JMAX=I+6 GOTO1800 C 1580 CONTINUE NW=NW+1 ITYPE(NW)='LF ' JMIN=I JMAX=I+7 GOTO1800 C 1700 CONTINUE NW=NW+1 ITYPE(NW)='COM ' JMIN=I JMAX=I GOTO1800 C 1600 CONTINUE NW=NW+1 ITYPE(NW)='PAR ' NLPWP=0 NRPWP=0 JMIN=I J=I ILOOP=0 C 1650 CONTINUE J=J+1 IF(J.GT.NCR)GOTO1660 IF(IR(J).EQ.'+ ')GOTO1660 IF(IR(J).EQ.'- ')GOTO1660 IF(IR(J).EQ.'* ')GOTO1660 IF(IR(J).EQ.'/ ')GOTO1660 IF(IR(J).EQ.'( ')NLPWP=NLPWP+1 IF(IR(J).EQ.') ')NRPWP=NRPWP+1 IF(IR(J).EQ.') '.AND.NRPWP.GT.NLPWP)GOTO1660 IF(IR(J).EQ.', ')GOTO1660 ILOOP=ILOOP+1 IF(ILOOP.LE.NUMAS2)GOTO1650 WRITE(ICOUT,1656)NUMAS2 1656 FORMAT('***** ERROR IN COMPID--PARAMETER NAME EXCEEDS ',I8, 1'CHARACTERS') CALL DPWRST('XXX','BUG ') DO1657K=JMIN,J WRITE(ICOUT,1658)K,IR(K) 1658 FORMAT('K,IR(K) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 1657 CONTINUE IERROR='YES ' GOTO9000 1660 CONTINUE JMAX=J-1 GOTO1800 C 1800 CONTINUE C C CHECK THAT NW HAS NOT EXCEEDED MAXCHA (USUALLY 80) C IF(NW.LE.MAXCHA)GOTO1900 WRITE(ICOUT,1901) 1901 FORMAT('***** ERROR IN COMPID--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1902) 1902 FORMAT(' THE VARIABLE NW HAS JUST EXCEEDED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1903) 1903 FORMAT(' THE MAX ALLOWABLE LIMIT DEFINED ', 1'BY THE INTERNAL VARIABLE MAXCHA.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1904)MAXCHA 1904 FORMAT(' THIS LIMIT IS MAXCHA = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1905)NUMCHA 1905 FORMAT(' THE INPUT NUMBER OF CHARACTERS NUMCHA = ',I8) CALL DPWRST('XXX','BUG ') IF(NUMCHA.GE.1)WRITE(ICOUT,1906)(IA(I),I=1,NUMCHA) 1906 FORMAT(' INPUT EXPRESSION--',100A1) IF(NUMCHA.GE.1)CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1907) 1907 FORMAT(' THE NUMBER OF (PACKED) CHARACTERS ON ', 1'RIGHT-HAND SIDE NCR = ',I8) CALL DPWRST('XXX','BUG ') IF(NCR.GE.1)WRITE(ICOUT,1908)(IR(I),I=1,NCR) 1908 FORMAT(' (PACKED) RIGHT-HAND SIDE--',95A1) IF(NCR.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES ' GOTO9000 1900 CONTINUE C IBEGIN(NW)=JMIN IEND(NW)=JMAX I=JMAX C I=I+1 IF(I.LE.NCR)GOTO1050 1950 CONTINUE C C TEST THAT NW IS POSITIVE. C IF(NW.GE.1)GOTO1959 WRITE(ICOUT,1951)NW 1951 FORMAT('***** ERROR IN COMPID--NW IS NON-POSITIVE. ', 1'NW = ',I8) CALL DPWRST('XXX','BUG ') IERROR='YES ' GOTO9000 1959 CONTINUE C IF(NW.EQ.1)GOTO1969 DO1960I=1,NW IP1=I+1 IF(ITYPE(I).EQ.'LF '.AND.ITYPE(IP1).NE.'LP ')GOTO1961 GOTO1960 1961 CONTINUE WRITE(ICOUT,1962) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1963)NW CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1964)I CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1965)ITYPE(I) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1966)ITYPE(IP1) 1962 FORMAT('***** ERROR IN COMPID--LIBRARY FUNCTION ', 1'NOT FOLLOWED BY A LEFT PARENTHESES') CALL DPWRST('XXX','BUG ') 1963 FORMAT(' NW = ',I8) 1964 FORMAT(' I = ',I8) 1965 FORMAT(' ITYPE(I) = ',A4) 1966 FORMAT(' ITYPE(I+1) = ',A4) IERROR='YES ' GOTO9000 1960 CONTINUE 1969 CONTINUE C IF(ITYPE(NW).EQ.'OP ')GOTO1970 IF(ITYPE(NW).EQ.'LF ')GOTO1972 GOTO1979 C 1970 CONTINUE WRITE(ICOUT,1971)ITYPE(NW) 1971 FORMAT('***** ERROR IN COMPID--LAST TERM IN TOTAL ', 1' EXPRESSION IS AN OPERATION = ',A4) CALL DPWRST('XXX','BUG ') IERROR='YES ' GOTO9000 1972 CONTINUE WRITE(ICOUT,1973)ITYPE(NW) 1973 FORMAT('***** ERROR IN COMPID--LAST TERM IN TOTAL ', 1' EXPRESSION = A LIBRARY FUNCTION = ',A4) CALL DPWRST('XXX','BUG ') IERROR='YES ' GOTO9000 1979 CONTINUE C IF(IBUGCO.EQ.'OFF'.AND.ISUBRO.NE.'MPID')GOTO1999 ISTEPN='4' CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) WRITE(ICOUT,1991)NW,ICMIN 1991 FORMAT('NW,ICMIN = ',2I8) CALL DPWRST('XXX','BUG ') DO1992I=1,NW ICMIN=IBEGIN(I) ICMINP=ICMIN+1 ICMINQ=ICMIN+2 WRITE(ICOUT,1993)I,IR(ICMIN),IR(ICMINP),IR(ICMINQ),ITYPE(I), 1IBEGIN(I),IEND(I) 1993 FORMAT('I,IR(ICMIN),IR(ICMIN+1),IR(ICMIN+2),ITYPE(I),', 1'IBEGIN(I),IEND(I) = ',I8,2X,3A4,A4,2X,I8,2X,I8) CALL DPWRST('XXX','BUG ') 1992 CONTINUE 1999 CONTINUE C C **************************************************************** C ** STEP 5-- C ** OPERATE ON EACH COMPONENT OF THE VECTOR IR(.). C ** CONVERT THE NUMBERS TO FLOATING POINT VALUES. C ** CONVERT THE PARAMETERS TO FLOATING POINT VALUES. C * SET THE X TO A DUMMY VALUE OF 0.0 FOR THE TIME BEING. ** C ** CONVERT THE OPERATIONS INTO A 1-WORD REPRESENTATION. C ** 'CONVERT' THE PARENTHESES INTO A 1-WORD REPRESENTATION. C ** CONVERT THE COEFFICIENTS TO COEFFICIENT VALUES. C ** CONVERT THE LIBRARY FUNCTIONS INTO A 1-WORD REPRESENTATION. C ** SAVE THE CONTENTS OF ITYPE, IW2, AND W2 IN C ** ITYPEH, IW21HO, AND WHOLD FOR LATER USE C ** IN REDEFINING ITYPE, IW2, AND W2 FOR EACH NEW X VALUE. C ** OUTPUT THE VECTORS IW2 AND W2. C ** OUTPUT THE VECTORS IW21HO, W2HOLD, AND ITYPEH. C **************************************************************** C CCCCC IC=0 APRIL 29, 1986 IC3=0 DO3000I=1,NW ICMIN=IBEGIN(I) ICMAX=IEND(I) IF(ITYPE(I).EQ.'N ')GOTO3100 IF(ITYPE(I).EQ.'X ')GOTO3200 IF(ITYPE(I).EQ.'OP ')GOTO3300 IF(ITYPE(I).EQ.'LP '.OR.ITYPE(I).EQ.'RP ')GOTO3400 IF(ITYPE(I).EQ.'PAR ')GOTO3500 IF(ITYPE(I).EQ.'LF ')GOTO3600 IF(ITYPE(I).EQ.'COM ')GOTO3700 WRITE(ICOUT,3005) 3005 FORMAT('***** ERROR IN COMPID--ITYPE(I) NOT X, OP, LP, PAR, ', 1'OR LF') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3006)I,ITYPE(I),IW21(I),W2(I) 3006 FORMAT('I,ITYPE(I),IW21(I),W2(I) = ', 1I8,2X,A4,2X,A4,2X,E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES ' GOTO9000 C 3100 CONTINUE CCCCC IC=IC+1 APRIL 29, 1986 IC3=IC3+1 CCCCC IW21(I)=IC CCCCC CALL DPC4IH(IC,IW21(I),IBUGEV,IERROR) APRIL 29, 1986 CALL DPC4IH(IC3,IW21(I),IBUGEV,IERROR) IW22(I)=' ' W2(I)=0.0 IANS1=' ' IANS2=' ' IANS3=' ' IANS4=' ' J=0 DO3150IC=ICMIN,ICMAX J=J+1 JM1=J-1 L=J-(NUMASC*(JM1/NUMASC)) K=NUMBPC*(L-1) K=IABS(K) CCCCC WRITE(ICOUT,3333)J,JM1,L,K,IR(IC) 3333 FORMAT('J,JM1,L,K,IR(IC) = ',4I8,2X,A4) CCCCC CALL DPWRST('XXX','BUG ') IF(J.LE.NUMASC)GOTO3151 IF(J.LE.NUMAS2)GOTO3152 IF(J.LE.NUMAS3)GOTO3153 IF(J.LE.NUMAS4)GOTO3154 GOTO3155 3151 CONTINUE CALL DPCHEX(0,NUMBPC,IR(IC),K,NUMBPC,IANS1) GOTO3155 3152 CONTINUE CALL DPCHEX(0,NUMBPC,IR(IC),K,NUMBPC,IANS2) GOTO3155 3153 CONTINUE CALL DPCHEX(0,NUMBPC,IR(IC),K,NUMBPC,IANS3) GOTO3155 3154 CONTINUE CALL DPCHEX(0,NUMBPC,IR(IC),K,NUMBPC,IANS4) GOTO3155 3155 CONTINUE CCCCC WRITE(ICOUT,4444)IANS1,IANS2,IANS3,IANS4 4444 FORMAT(4A4) CCCCC CALL DPWRST('XXX','BUG ') 3150 CONTINUE CALL ERRORF(IANS1,IANS2,IANS3,IANS4,-1000000000.0,1000000000.0, 11000000000.0,ANS2,IERROR) IF(IERROR.EQ.'YES ')GOTO9000 W2(I)=ANS2 GOTO3000 C 3200 CONTINUE W2(I)=0.0 GOTO3000 C 3300 CONTINUE IW21(I)=IR(ICMIN) IW22(I)=' ' ICMINP=ICMIN+1 IF(IR(ICMIN).EQ.'* '.AND.IR(ICMINP).EQ.'* ')IW21(I)='** ' IF(IR(ICMIN).EQ.'* '.AND.IR(ICMINP).EQ.'* ')IW22(I)=' ' GOTO3000 C 3400 CONTINUE IW21(I)=IR(ICMIN) IW22(I)=' ' GOTO3000 C 3500 CONTINUE IW21(I)=' ' IW22(I)=' ' ICMAX2=ICMIN+NUMAS2-1 IF(ICMAX.LE.ICMAX2)ICMAX2=ICMAX J=0 DO3530IC=ICMIN,ICMAX2 J=J+1 J2=J IF(J2.GT.NUMASC)J2=J-NUMASC ISTAR3=NUMBPC*(J2-1) ISTAR3=IABS(ISTAR3) IF(J.LE.NUMASC)CALL DPCHEX(0,NUMBPC,IR(IC),ISTAR3,NUMBPC,IW21(I)) IF(J.GT.NUMASC)CALL DPCHEX(0,NUMBPC,IR(IC),ISTAR3,NUMBPC,IW22(I)) 3530 CONTINUE C IF(IPASS.EQ.1)GOTO3000 C IF(NUMPAR.LE.0)GOTO3559 DO3550J=1,NUMPAR IF(IW21(I).EQ.IPARN1(J).AND.IW22(I).EQ.IPARN2(J))GOTO3555 3550 CONTINUE GOTO3559 3555 CONTINUE W2(I)=PARAM(J) GOTO3000 3559 CONTINUE C IF(NUMVAR.LE.0)GOTO3569 DO3560J=1,NUMVAR IF(IW21(I).EQ.IPARN1(J).AND.IW22(I).EQ.IPARN2(J))GOTO3565 3560 CONTINUE 3565 CONTINUE W2(I)=0.0 ITYPE(I)='VAR ' GOTO3000 3569 CONTINUE C WRITE(ICOUT,3571) 3571 FORMAT('***** ERROR IN COMPID--NO MATCH FOR PARAM./VAR. NAME') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3572)IW21(I),IW22(I) 3572 FORMAT(' GIVEN PARAM./VAR. NAME = ',2A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3573)NUMPAR 3573 FORMAT(' NUMBER OF PARAM./VAR. =',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3574) 3574 FORMAT(' ADMISSIBLE PARAM./VAR. ', 1'NAMES = ') CALL DPWRST('XXX','BUG ') DO3575J=1,NUMPAR WRITE(ICOUT,3576)J,IPARN1(J),IPARN2(J) 3576 FORMAT(' PARAM./VAR. NAME ',I4,'-- ', 12A4) CALL DPWRST('XXX','BUG ') 3575 CONTINUE WRITE(ICOUT,3577)(IA(J),J=1,NUMCHA) 3577 FORMAT(' FUNCTION EXPRESSION--',100A1) CALL DPWRST('XXX','BUG ') IERROR='YES ' GOTO9000 C 3600 CONTINUE IW21(I)=' ' IW22(I)=' ' ICMAX2=ICMIN+NUMAS2-1 IF(ICMAX.LE.ICMAX2)ICMAX2=ICMAX J=0 DO3650IC=ICMIN,ICMAX2 J=J+1 J2=J IF(J2.GT.NUMASC)J2=J-NUMASC ISTAR3=NUMBPC*(J2-1) ISTAR3=IABS(ISTAR3) IF(J.LE.NUMASC)CALL DPCHEX(0,NUMBPC,IR(IC),ISTAR3,NUMBPC,IW21(I)) IF(J.GT.NUMASC)CALL DPCHEX(0,NUMBPC,IR(IC),ISTAR3,NUMBPC,IW22(I)) 3650 CONTINUE GOTO3000 C 3700 CONTINUE IW21(I)=IR(ICMIN) IW22(I)=' ' GOTO3000 C 3000 CONTINUE NWHOLD=NW DO3900I=1,NW ITYPEH(I)=ITYPE(I) IW21HO(I)=IW21(I) IW22HO(I)=IW22(I) W2HOLD(I)=W2(I) 3900 CONTINUE IF(IBUGCO.EQ.'OFF'.AND.ISUBRO.NE.'MPID')GOTO3999 ISTEPN='5' CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) DO3992I=1,NW ICMIN=IBEGIN(I) ICMINP=ICMIN+1 ICMINQ=ICMIN+2 WRITE(ICOUT,3993)I,IR(ICMIN),IR(ICMINP),IR(ICMINQ),ITYPE(I), 1IW21(I),IW22(I),W2(I) 3993 FORMAT('I,IR(ICMIN),IR(ICMIN+1),IR(ICMIN+2),ITYPE(I),', 1'IW21(I),IW22HO(I),W2(I) = ',I8,2X,3A4,2X,A4,2X,A4,2X,A4,2X,E15.6) CALL DPWRST('XXX','BUG ') 3992 CONTINUE 3999 CONTINUE C C **************************************************** C ** STEP 6-- ** C ** THIS STEP IS TO BE EXECUTED IF IPASS=1; ** C ** OTHERWISE IT IS SKIPPED. ** C ** IF THIS STEP IS EXECUTED, STEP 7 IS NOT; ** C ** IF THIS STEP IS NOT EXECUTED, STEP 7 IS. ** C ** OPERATE ON IW2 AND ITYPE VECTORS. ** C ** DETERMINE THE NUMBER OF DISTINCT PARAMETERS. ** C ** FORM THE OUTPUT VECTOR IPARN1. ** C ** CHECK TO SEE IF SOME OF THE PREVIOSULY- ** C ** DEFINED PARAMETERS ARE IN FACT VARIABLES. ** C **************************************************** C IF(IPASS.EQ.1)GOTO4050 GOTO4999 4050 CONTINUE C NUMPAR=0 DO4100I=1,NW IF(ITYPE(I).EQ.'PAR ')GOTO4190 GOTO4100 4190 CONTINUE C IF(NUMVAR.LE.0)GOTO4290 DO4250J=1,NUMVAR IF(IW21(I).EQ.IVARN1(J).AND.IW22(I).EQ.IVARN2(J))GOTO4260 4250 CONTINUE GOTO4290 4260 CONTINUE ITYPE(I)='VAR ' GOTO4100 4290 CONTINUE C IF(NUMPAR.EQ.0)GOTO4300 DO4400J=1,NUMPAR IF(IW21(I).EQ.IPARN1(J).AND.IW22(I).EQ.IPARN2(J))GOTO4100 4400 CONTINUE 4300 CONTINUE NUMPAR=NUMPAR+1 IPARN1(NUMPAR)=IW21(I) IPARN2(NUMPAR)=IW22(I) 4100 CONTINUE C IF(IBUGCO.EQ.'OFF'.AND.ISUBRO.NE.'MPID')GOTO4599 ISTEPN='6' CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) WRITE(ICOUT,4591) 4591 FORMAT('AT END OF STEP 6 FOR PASS 1 (RIGHT BEFORE ', 1'RETURNING TO MAIN ROUTINE FROM COMPID)--') CALL DPWRST('XXX','BUG ') DO4592I=1,NW ICMIN=IBEGIN(I) ICMINP=ICMIN+1 ICMINQ=ICMIN+2 WRITE(ICOUT,4593)I,IR(ICMIN),IR(ICMINP),IR(ICMINQ),ITYPE(I), 1IW21(I),IW22(I),W2(I) 4593 FORMAT('I,IR(ICMIN),IR(ICMIN+1),IR(ICMIN+2),ITYPE(I),', 1'IW21(I),IW22(I),W2(I) = ',I8,2X,3A4,A4,2X,A4,2X,A4,2X,E15.7) CALL DPWRST('XXX','BUG ') 4592 CONTINUE 4599 CONTINUE C GOTO9000 4999 CONTINUE C C **************************************************************** C ** STEP 7-- C ** OPERATE ON THE W2(.) AND IW21(.) VECTORS. C ** THIS STEP IS NOT EXECUTED IF STEP 6 IS; C ** THIS STEP IS EXECUTED IF STEP 6 IS NOT. C ** FIRST MAKE SURE THAT THE NUMBER OF LEFT C ** AND RIGHT PARENTHESES ARE THE SAME. C ** (STEP 6 THEN SETS UP A LARGE DO LOOP C ** WHICH GOES THROUGH ALL OF THE VALUES OF THE X VECTOR C ** AND GENERATES CORRESPONDING VALUES OF THE Y VECTOR.) C ** FOR A GIVEN X VALUE, IT EVALUATES THE FUNCTION C ** BY FIRST SEEKING THE INNERMOST PARENTHESES C ** (BY SEARCHING FOR THE FIRST REMAINING RIGHT PARENTHESS). C ** AND THEN EVALUATING ALL SUCH PARENTHETICAL EXPRESSIONS-- C ** WORKING FROM THE INNERMOST OUT. C ** AFTER EVALUATING A PARENTHESES PAIR, C ** THE ENTIRE PARENTHESES GROUP (PARENTHESES INCLUDED) C ** IS REPLACED BY THE SCALAR ANSWER. C ** THE IW2, W2, AND ITYPE VECTORS ARE SQUEEZED ACCORDINGLY C ** (IN THE SUBROUTINE EVAL). C ** SINCE THE VECTORS IW2, W2, AND ITYPE ARE ALTERED (SQUEEZED) C ** FOR EACH X VALUE, THEY MUST BE REDEFINED FROM THE SAVED C ** VALUES IN IW2, W2, AND ITYPE FOR EACH NEW X VALUE. C ** THE ABOVE SQUEEZING OPERATION IS REPEATED C ** FOR EACH PARENTHESES PAIR UNTIL ALL PARENTHESES C ** ARE GONE AND WE REMAIN ONLY WITH THE FINAL ANSWER. C ** FOR EACH VALUE X(.) OF THE INPUT X VECTOR, C ** OUTPUT THE CORRESPONDING VALUE Y(.) OF C ** THE DESIRED OUTPUT VECTOR. C ** FOR A GIVEN VALUE X(.), THE CORRESPONDING C ** COMPUTED Y(.) WILL BE THE EVALUATED VALUE OF C ** THE RIGHT-HAND SIDE OF THE SPECIFIED EQUATION Y = F(X). C **************************************************************** C 5000 CONTINUE C NLP=0 NRP=0 DO5100I=1,NW IF(ITYPE(I).EQ.'LP ')NLP=NLP+1 IF(ITYPE(I).EQ.'RP ')NRP=NRP+1 5100 CONTINUE IF(NLP.EQ.NRP)GOTO5190 WRITE(ICOUT,5155) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5156) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5157)NLP CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5158)NRP 5155 FORMAT('***** ERROR IN COMPID--') CALL DPWRST('XXX','BUG ') 5156 FORMAT('NUMBER OF LEFT PARENTHESES NOT EQUAL TO ', 1'NUMBER OF RIGHT PARENTHESES') 5157 FORMAT('NUMBER OF LEFT PARENTHESES = ',I8) 5158 FORMAT('NUMBER OF RIGHT PARENTHESES = ',I8) IERROR='YES ' GOTO9000 5190 CONTINUE C CCCCC DO8000II=1,N NW=NWHOLD DO5200I=1,NW ITYPE(I)=ITYPEH(I) IW21(I)=IW21HO(I) IW22(I)=IW22HO(I) W2(I)=W2HOLD(I) C THE FOLLOWING STATEMENT HAS BEEN COMMENTED OUT C IN GOING FROM COMPIL TO COMPID. CCCCC IF(ITYPE(I).EQ.'X ')W2(I)=X(II) 5200 CONTINUE IF(IBUGCO.EQ.'ON'.OR.ISUBRO.EQ.'RIV4') 1GOTO5249 GOTO5299 5249 CONTINUE ISTEPN='7' CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) DO5250I=1,NW WRITE(ICOUT,5251)I,IW21HO(I),IW21(I),ITYPE(I) 5251 FORMAT('I,IW21HO(I),IW21(I),ITYPE(I) = ',I8,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 5250 CONTINUE 5299 CONTINUE C C ********************************* C ** STEP 7-- ** C ** DETERMINE THE DERIVATIVE. ** C ********************************* C CALL DERIV0(IW21,IW22,ITYPE,NW, 1IPARN1,IPARN2,NUMPAR,IVARN1,IVARN2,NUMVAR, 1ICON,ICON1,ICON2,NCON,ID1,ID2,NUMCD2, 1IBUGEV,ISUBRO,IFOUND,IERROR) C IF(IBUGCO.EQ.'OFF'.AND.ISUBRO.NE.'MPID')GOTO5319 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5311) 5311 FORMAT('***** IN COMPID, AFTER RETURNING FROM DERIV0--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5312)NUMCD2 5312 FORMAT(' NUMCD2 = ',I8) CALL DPWRST('XXX','BUG ') DO5315I=1,NUMCD2 WRITE(ICOUT,5316)I,ID1(I),ID2(I) 5316 FORMAT(' I,ID1(I),ID2(I) = ',I8,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 5315 CONTINUE 5319 CONTINUE C C *********************************************************** C ** STEP 7.2-- ** C ** FORM THE OUTPUT VECTOR ID(.). ** C ** NOTE THAT ID1(.) AND ID2(.) ARE PARALLEL ** C ** REPRESENTATIONS OF THE DESIRED DERIVATIVE FUNCTION ** C ** (ID1(.) HAS THE FIRST 4 CHARACTERS; ** C ** ID2(.) HAS THE NEXT 4 CHARACTERS). ** C ** MOST COMPONENTS (E.G., +, -, *, /, (, ), ETC.) ** C ** USE ONLY 1 CHARACTER OUT OF THE 8. ** C ** SOME COMPONENTS (NAMELY, **) ** C ** USE 2 CHARACTERS OUT OF THE 8. ** C ** SOME COMPONTENTS (NAMELY, LIBRARY FUNCTIONS) ** C ** USE MANY (3 TO 7) CHARACTERS OUT OF THE 8. ** C ** IN ANY EVENT, THE OUTPUT VECTOR ID(.) WILL BE ** C ** AN UNPACKED (1 CHARACTER PER WORD) SYNTHESIS ** C ** OF THE 2 PACKED \VYYEYC\TYORS Y\I\D1(.) AND ID2(.). ** C *********************************************************** C ISTEPN='7.2' IF(IBUGCO.EQ.'ON'.OR.ISUBRO.EQ.'RIV4') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C J=0 IF(NUMCD2.LE.0)GOTO5639 DO5600I=1,NUMCD2 IF(ID1(I).EQ.' ')GOTO5619 J=J+1 ID3(J)=ID1(I) 5619 CONTINUE IF(ID2(I).EQ.' ')GOTO5629 J=J+1 ID3(J)=ID2(I) 5629 CONTINUE 5600 CONTINUE 5639 CONTINUE NUMCH3=J C IF(IBUGCO.EQ.'OFF'.AND.ISUBRO.NE.'MPID')GOTO5649 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5641)NUMCD2,NUMCH3 5641 FORMAT('NUMCD2,NUMCH3 = ',2I8) CALL DPWRST('XXX','BUG ') DO5645I=1,NUMCH3 WRITE(ICOUT,5646)I,ID3(I) 5646 FORMAT('I,ID3(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 5645 CONTINUE 5649 CONTINUE C K=0 DO5700I=1,NUMCH3 IF(ID3(I).EQ.' ')GOTO5700 CALL DPXH1H(ID3(I),ICH,ILASTC,IBUGEV) IF(ILASTC.LE.0)GOTO5700 DO5750J=1,ILASTC K=K+1 ID(K)=ICH(J) 5750 CONTINUE 5700 CONTINUE NCTOTD=K C IF(NCTOTD.GE.1)GOTO5789 WRITE(ICOUT,5705)NCTOTD 5705 FORMAT('***** ERROR IN COMPID--TOTAL NUMBER OF CHARACTERS ', 1'IN DERIVATIVE. (INCL. BLANKS, AND EQUAL SIGN) ', 1'IS < 2. NCTOTD = ',I5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5771)NUMCHD,N,IPASS 5771 FORMAT('NUMCHD,N,IPASS = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5772)(ID(I),I=1,NUMCHD) 5772 FORMAT('ID--',80A1) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 5789 CONTINUE C IF(IBUGCO.EQ.'OFF'.AND.ISUBRO.NE.'MPID')GOTO5799 WRITE(ICOUT,5791)NCTOTD 5791 FORMAT('NCTOTD = ',I8) CALL DPWRST('XXX','BUG ') DO5792I=1,NCTOTD WRITE(ICOUT,5793)I,ID(I) 5793 FORMAT('I,ID(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 5792 CONTINUE 5799 CONTINUE NUMCHD=NCTOTD C C ******************************************* C ** STEP 7.3-- ** C ** SIMPLIFY THE FUNCTIONAL EXPRESSION. ** C ******************************************* C CALL DPSIPA(ID,NUMCHD,IBUGEV,IERROR) CALL DPSISI(ID,NUMCHD,IBUGEV,IERROR) CALL DPSIP1(ID,NUMCHD,IBUGEV,IERROR) CALL DPSIP0(ID,NUMCHD,IBUGEV,IERROR) CALL DPSIE1(ID,NUMCHD,IBUGEV,IERROR) CALL DPSIE0(ID,NUMCHD,IBUGEV,IERROR) CALL DPSIA0(ID,NUMCHD,IBUGEV,IERROR) CALL DPSIA2(ID,NUMCHD,IBUGEV,ISUBRO,IERROR) CALL DPSIFL(ID,NUMCHD,IBUGEV,IERROR) C CALL DPSIPA(ID,NUMCHD,IBUGEV,IERROR) CALL DPSISI(ID,NUMCHD,IBUGEV,IERROR) CALL DPSIP1(ID,NUMCHD,IBUGEV,IERROR) CALL DPSIP0(ID,NUMCHD,IBUGEV,IERROR) CALL DPSIE1(ID,NUMCHD,IBUGEV,IERROR) CALL DPSIE0(ID,NUMCHD,IBUGEV,IERROR) CALL DPSIA0(ID,NUMCHD,IBUGEV,IERROR) CALL DPSIA2(ID,NUMCHD,IBUGEV,ISUBRO,IERROR) CALL DPSIFL(ID,NUMCHD,IBUGEV,IERROR) C 8000 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGCO.EQ.'OFF'.AND.ISUBRO.NE.'MPID')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF COMPID--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)NUMCHA,NUMCHD 9012 FORMAT('NUMCHA,NUMCHD = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013) 9013 FORMAT('INPUT FUNCTION--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)(IA(J),J=1,NUMCHA) 9016 FORMAT(130A1) CALL DPWRST('XXX','BUG ') C WRITE(ICOUT,9022) 9022 FORMAT('OUTPUT DERIVATIVE--') CALL DPWRST('XXX','BUG ') DO9025I=1,NUMCHD,12 JMIN=I JMAX=JMIN+11 IF(JMAX.GT.NUMCHD)JMAX=NUMCHD WRITE(ICOUT,9026)(ID(J),J=JMIN,JMAX) 9026 FORMAT(12A4) CALL DPWRST('XXX','BUG ') 9025 CONTINUE C WRITE(ICOUT,9031)IBUGEV,IERROR 9031 FORMAT('IBUGEV,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE COMPIM(IA,NUMCHA,IPASS,PARAM,IPARN1,IPARN2,NUMPAR, 1IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,Y, 1IBUGCO,IBUGEV,IERROR) C C PURPOSE--THIS SUBROUTINE INTERPRETS AND EVALUATES C A FORTRAN MATHEMATICAL FUNCTION EXPRESSION C OF THE FORM Y=F(.,.,.,.,...). C IT IS A GENERALIZATION OF JJF7.COMPIL C WHICH COULD HANDLE ONLY 1 ARGUMENT (X). C THIS SUBROUTINE IS TYPICALLY C ENTERED WITH TWO PASSES-- C THE FIRST PASS ANALYZES THE STRING C AND HAS AS ITS OUTPUT THE HOLLERITH C NAMES OF THE VARIOUS PARAMETERS. C A 'PARAMETER' IN THIS SUBROUTINE (COMPIM) C MEANS ANY USUAL PARAMETER IN AN EXPRESSION C AS WELL AS ANY VARIABLE NAME (E.G., X1, X2, X3, TEMP, RES, ETC.) C THIS IS A FUNDAMENTAL WAY THAT COMPIM C DIFFERS FROM COMPIL. C ALSO, COMPIM OUTPUTS ONLY A COMPUTED SCALAR VALUE C (AS OPPOSED TO COMPIL WHICH OUTPUTS AN ENTIRE C COMPUTED VECTOR). C THESE NAMES ARE OUTPUTTED IN THIS FIRST PASS C AS ELEMENTS IN THE VECTORS IPARN1 AND IPARN2. C THE SECOND PASS USES INPUT PARAMETER VALUES C (INPUTTED IN THE VECTOR PARAM) C TO ACTUALLY EVALUATE THE FUNCTION C (OUTPUTTED IN THE SCALAR Y). C NOTE THAT IF SOME OF THE 'PARAMETERS' ARE C IN FACT ELEMENTS OF A VECTOR VARIABLE, C THE ITERATING THROUGH THE ENTIRE VECTOR IS DONE C IN THE CALLING SUBROUTINE AND NOT WITHIN COMPIM C (THIS IS ANOTHER WAY THAT COMPIM DIFFERS FROM COMPIL). C INPUT ARGUMENTS--IA = THE INTEGER VECTOR WHICH CONTAINS C THE HOLLERITH CHARACTERS WHICH C MAKE UP THE LINE OF FORTRAN CODE. C THIS VECTOR CONTAINS THE STRING C TO BE OPERATED ON, INTERPRETED, C AND EVALUATED. C --NUMCHA = THE INTEGER VALUE WHICH C DEFINES THE NUMBER OF CHARACTERS IN IA. C NUMCHA DEFINES THE LENGTH OF THE C HOLLERITH STRING TO BE OPERATED ON, C INTERPRETED, AND EVALUATED. C --IPASS = AN INTEGER FLAG CODE C WHICH DEFINES WHICH PASS (1 OR 2) INTO THIS C SUBROUTINE THE USER IS IN. C PASS 1 DETERMINE PARAMETER NAMES; C PASS 2 DOES FUNCTION EVALUATIONS. C --PARAM = THE SINGLE PRECISION VECTOR OF PARAMETER C (AND VARIABLE) C VALUES CORRESPONDING TO THE PARAMETER NAMES C AS GIVEN IN THE VECTOR IPARN. C --IPARN1 = THE INTEGER VECTOR C CONTAINING CHARACTERS 1 THROUGH 4 C OF PARAMETER (AND VARIABLE) C NAMES AS TYPICALLY DETERMINED BY PASS 1. C --IPARN2 = THE INTEGER VECTOR C CONTAINING CHARACTERS 5 THROUGH 8 C OF PARAMETER (AND VARIABLE) C NAMES AS TYPICALLY DETERMINED BY PASS 1. C OUTPUT ARGUMENTS--Y = THE SINGLE PRECISION COMPUTED SCALAR VALUE OF C THE FUNCTION AS DETERMINED BY PASS 2 C AND WHICH CONSTITUTE THE ULTIMATE C OUTPUT FROM THIS SUBROUTINE. C THAT IS, SYMBOLICALLY, C Y = F(X1,X2,X3,TEMP,RES,ETC.,PAR1,PAR2,PAR3,ETC C OUTPUT--THE SINGLE PRECISION COMPUTED SCALAR VALUE, C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER SUBROUTINES NEEDED--EVAL C FORTRAN LIBRARY SUBROUTINES NEEDED--(ALL IN EVAL) C SQRT C EXP C ALOG C ALOG10 C SIN C COS C ATAN C ATAN2 C TANH C ABS C AINT C ARCSIN C ARCCOS C ARCTAN C OCTAL C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C NOTE--THIS SUBROUTINE ALLOWS ONE TO PERFORM C INTERACTIVE FUNCTION EVALUATIONS. C REFERENCES--NONE. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82/7 C ORIGINAL VERSION--NOVEMBER 1976. C UPDATED --FEBRUARY 1977. C UPDATED --DECEMBER 1977. C UPDATED --JANUARY 1978. C UPDATED --JULY 1978. C UPDATED --OCTOBER 1978. C UPDATED --DECEMBER 1978. C UPDATED --JANUARY 1979. C UPDATED --FEBRUARY 1979. C UPDATED --JULY 1979. C UPDATED --JANUARY 1981. C UPDATED --FEBRUARY 1981. C UPDATED --JUNE 1981. C UPDATED --JANUARY 1981. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C UPDATED --JUNE 1986. C UPDATED --DECEMBER 1988. BLANK OUT IR(.) FOR AT LEAST 10 CHAR C UPDATED --SEPTEMBER 1994. ADD SAVE4 ARGUMENT TO EVALM. C UPDATED --APRIL 1995. BUG: C LET A = TPDF(X,2) - TPDF(X,3) C SETS SAVE1 TO 2 IN BOTH CASES C UPDATED --MAY 1998. ADD FIFTH PARAMETER C UPDATED --JUNE 2003. ADD SAVE6, SAVE7, SAVE8 C ARGUMENTS TO EVALM. C UPDATED --FEBRUARY 2005. CONVERT STRING TO UPPER CASE C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IA CHARACTER*4 IPARN1 CHARACTER*4 IPARN2 CHARACTER*4 IANGLU CHARACTER*4 ITYPEH CHARACTER*4 IW21HO CHARACTER*4 IW22HO CHARACTER*4 IBUGCO CHARACTER*4 IBUGEV CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C CHARACTER*4 IR CHARACTER*4 IB CHARACTER*4 IL CHARACTER*4 ICH CHARACTER*4 IW21 CHARACTER*4 IW22 CHARACTER*4 ITYPE CHARACTER*4 IANS1 CHARACTER*4 IANS2 CHARACTER*4 IANS3 CHARACTER*4 IANS4 CHARACTER*4 IFOUND CCCCC CHARACTER*4 IBUG0 CCCCC CHARACTER*4 IBUG1 CCCCC CHARACTER*4 IBUG2 CCCCC CHARACTER*4 IBUG3 CCCCC CHARACTER*4 IBUG4 CCCCC CHARACTER*4 IBUG5 CCCCC CHARACTER*4 IBUG7 C C--------------------------------------------------------------------- C DIMENSION IA(*) DIMENSION PARAM(*) DIMENSION IPARN1(*) DIMENSION IPARN2(*) C C NOTE--THE DIMENSIONS OF ITYPEH, IW21HO, IW22HO, AND W2HOLD C WHICH ARE DEFINED IN THE MAIN PROGRAM C SHOULD BE AT LEAST AS LARGE AS THE DIMENSIONS C OF IW2 AND IW22 BELOW. C DIMENSION ITYPEH(*) DIMENSION IW21HO(*) DIMENSION IW22HO(*) DIMENSION W2HOLD(*) C C NOTE--THE DIMENSION OF IB SHOULD BE THE SAME AS C THE DIMENSION OF SUBROUTINE IA IN DPLET. C CCCCC DIMENSION IB(225) CCCCC DIMENSION IR(225) CCCCC DIMENSION IBEGIN(225) CCCCC DIMENSION IEND(225) CCCCC DIMENSION ITYPE(225) CCCCC DIMENSION IW21(225) CCCCC DIMENSION IW22(225) CCCCC DIMENSION W2(225) DIMENSION IB(1000) DIMENSION IR(1000) DIMENSION IBEGIN(1000) DIMENSION IEND(1000) DIMENSION ITYPE(1000) DIMENSION IW21(1000) DIMENSION IW22(1000) DIMENSION W2(1000) C DIMENSION ICH(10) C DIMENSION IL(10) C CCCCC ADD FOLLOWING SECTION APRIL 1995. C PARAMETER(MAXNST=25) DIMENSION SAVE1(MAXNST) DIMENSION SAVE2(MAXNST) DIMENSION SAVE3(MAXNST) DIMENSION SAVE4(MAXNST) DIMENSION SAVE5(MAXNST) DIMENSION SAVE6(MAXNST) DIMENSION SAVE7(MAXNST) DIMENSION SAVE8(MAXNST) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C DEFINE THE UPPER LIMIT OF THE NUMBER OF CHARACTERS C THAT MAY BE PROCESSED BY THIS SUBROUTINE C (COUNTING BLANKS, LEFT-HAND SIDE, EQUAL SIGN, C AND RIGHT HAND SIDE). C IF RESTRICT THE EXPRESSION TO 1 LINE IMAGE, C THEN A REASONABLE UPPER BOUND IS 80. C WHATEVER UPPER BOUND IS SET, C THE DIMENSIONS OF MOST OF THE VECTORS C MUST BE EQUAL OR LARGER TO THIS NUMBER. C (THE VECTOR IL(.) WHICH CONTAINS THE C NUMBER OF CHARACTERS TO THE LEFT C OF THE EQUAL SIGN (BLANKS IGNORED) C MAY BE MUCH SMALLER--LIKE 6.) C NOTE--AS OF JANUARY 1979, THE BOUND WAS RESET TO 150. C CCCCC DATA MAXCHA/150/ CCCCC DATA MAXCHA/225/ DATA MAXCHA/1000/ C C-----START POINT----------------------------------------------------- C ISUBN1='COMP' ISUBN2='IM ' C IERROR='NO' C CCCCC IBUG0='OFF' CCCCC IBUG1='OFF' CCCCC IBUG2='OFF' CCCCC IBUG3='OFF' CCCCC IBUG4='OFF' CCCCC IBUG5='OFF' CCCCC IBUG7='OFF' C C THE FOLLOWING STATEMENT (N=1) HAS BEEN ADDED C IN CONVERTING THE COMPIL SUBROUTINE C TO THE COMPIM SUBROUTINE. C N=1 C IF(IBUGCO.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF COMPIM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NUMCHA,N,IPASS,IANGLU 52 FORMAT('NUMCHA,N,IPASS,IANGLU = ',3I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)(IA(I),I=1,NUMCHA) 53 FORMAT('IA--',80A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IBUGCO,IBUGEV 54 FORMAT('IBUGCO,IBUGEV = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61)NUMPAR 61 FORMAT('NUMPAR = ',I8) CALL DPWRST('XXX','BUG ') IF(NUMPAR.LE.0)GOTO69 DO62I=1,NUMPAR WRITE(ICOUT,63)I,IPARN1(I),IPARN2(I),PARAM(I) 63 FORMAT('I,IPARN1(I),IPARN2(I),PARAM(I) = ',I8,2X,A4,2X,A4,2X, 1F15.7) CALL DPWRST('XXX','BUG ') 62 CONTINUE 69 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71)NWHOLD 71 FORMAT('NWHOLD = ',I8) CALL DPWRST('XXX','BUG ') IF(NWHOLD.LE.0)GOTO79 DO72I=1,NWHOLD WRITE(ICOUT,73)I,ITYPEH(I),IW21HO(I),IW22HO(I),W2HOLD(I) 73 FORMAT('I,ITYPEH(I),IW21HO(I),IW22HO(I),W2HOLD(I) = ', 1I8,2X,A4,2X,A4,2X,A4,2X,F15.7) CALL DPWRST('XXX','BUG ') 72 CONTINUE 79 CONTINUE WRITE(ICOUT,81)IPASS,NW 81 FORMAT('IPASS,NW = ',2I8) CALL DPWRST('XXX','BUG ') IF(NW.GE.1)WRITE(ICOUT,82)ITYPE(NW) 82 FORMAT('ITYPE(NW) = ',A4) IF(NW.GE.1)CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ************************************************************ C ** DEFINE NUMASC = NUMBER OF ASCII CHARACTERS PER WORD. ** C ** THIS IS 4 REGARDLESS OF THE COMPUTER MAKE AND ** C ** REGARDLESS OF THE WORD SIZE. ** C ************************************************************ C NUMASC=4 NUMAS2=2*NUMASC NUMAS3=3*NUMASC NUMAS4=4*NUMASC C C IF IPASS = 2, SKIP ALL OF THE PRELIMINARY CODE C AND JUMP TO CALCULATIVE PART OF CODE. C IF(IPASS.EQ.2)GOTO5000 C C CHECK THAT THE INPUT NUMBER OF CHARACTERS NUMCHA C (INCLUDING LEFT SIDE, RIGHT SIDE, EQUAL SIGN, C AND BLANKS) IS AT LEAST 1 AND AT MOST MAXCHA C (WHERE MAXCHA IS THE INTERNALLY DEFINED VARIABLE C WHICH CONTROLS DIMENSION SIZES AND WHICH C TYPICALLY HAS THE VALUE 80). C IF(1.LE.NUMCHA.AND.NUMCHA.LE.MAXCHA)GOTO39 WRITE(ICOUT,21) 21 FORMAT('***** ERROR IN COMPIM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,22) 22 FORMAT(' THE NUMBER OF CHARACTERS NUMCHA ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,23) 23 FORMAT(' WHICH DEFINES THE LENGTH OF THE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,24) 24 FORMAT(' INPUT EXPRESSION (INCLUDING LEFT-HAND SIDE,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,25) 25 FORMAT(' RIGHT-HAND SIDE, EQUAL SIGN, AND ALL BLANKS)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,26) 26 FORMAT(' IS SMALLER THAN 1 OR LARGER THAN MAXCHA') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,27) 27 FORMAT(' (MAXCHA IS AN INTERNALLY-DEFINED VARIABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,28)MAXCHA 28 FORMAT(' WHICH HAS THE VALUE = ',I8,' .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,29) 29 FORMAT(' THE NUMBER OF CHARACTERS IN THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,30)NUMCHA 30 FORMAT(' INPUT EXPRESSION IS ',I8) CALL DPWRST('XXX','BUG ') IF(NUMCHA.GE.1)WRITE(ICOUT,31)(IA(I),I=1,NUMCHA) 31 FORMAT(' INPUT EXPRESSION--',100A1) IF(NUMCHA.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 39 CONTINUE C CCCCC FEBRUARY 2005. CONVERT INPUT FUNCTION TO ALL UPPER CASE. CCCCC THIS IS TO ADDRESS ISSUE WHERE IF FUNCTION CCCCC WAS DEFINED AS "LET STRING" RATHER THAN CCCCC "LET FUNCTION", CASE IS PRESERVED. HOWEVER, CCCCC WHEN EVALUATING FUNCTION, WE NEED THE STRING CCCCC TO BE EVALUATED IN UPPER CASE. C DO91I=1,NUMCHA ITEMP=ICHAR(IA(I)(1:1)) IF(ITEMP.GE.97 .AND. ITEMP.LE.122)THEN ITEMP=ITEMP-32 IA(I)(1:1)=CHAR(ITEMP) ENDIF 91 CONTINUE C C BLANK-OUT AND ZERO-OUT SOME VARIABLES AND VECTORS. C Y=0.0 DO160I=1,NUMCHA IR(I)=' ' IB(I)=' ' IW21(I)=' ' IW22(I)=' ' W2(I)=0.0 ITYPE(I)=' ' IW21HO(I)=' ' IW22HO(I)=' ' W2HOLD(I)=0.0 ITYPEH(I)=' ' 160 CONTINUE C C THE FOLLOWING LOOP WAS PUT IN TO AVOID A PROBLEM C ESSENTAILLY CAUSED IN DPLIB1 AND WHICH C SHOWED UP IN LET A = 1 1 3 LET A = ABS(A) LET B = A C MARY BETH 12/88 C DO161I=1,10 IR(I)=' ' 161 CONTINUE C C ************************************ C ** STEP 1-- ** C ** OPERATE ON THE VECTOR IA(.). ** C ** SQUEEZE OUT ALL BLANKS. ** C ** OUTPUT THE VECTOR IB(.). ** C ************************************ C K=0 DO100I=1,NUMCHA IF(IA(I).EQ.' ')GOTO100 CALL DPXH1H(IA(I),ICH,ILASTC,IBUGCO) IF(ILASTC.LE.0)GOTO100 DO150J=1,ILASTC K=K+1 IB(K)=ICH(J) 150 CONTINUE 100 CONTINUE NCTOT=K IF(NCTOT.GE.1)GOTO190 WRITE(ICOUT,105)NCTOT 105 FORMAT('***** ERROR IN COMPIM--TOTAL NUMBER OF CHARACTERS ', 1'IN MODEL (INCL. BOTH SIDES, BLANKS, AND EQUAL SIGN) ', 1'IS < 2. NCTOT = ',I5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,171)NUMCHA,N,IPASS 171 FORMAT('NUMCHA,N,IPASS = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,172)(IA(I),I=1,NUMCHA) 172 FORMAT('IA--',80A1) CALL DPWRST('XXX','BUG ') C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,181)NUMPAR 181 FORMAT('NUMPAR = ',I8) CALL DPWRST('XXX','BUG ') IF(NUMPAR.LE.0)GOTO189 DO182I=1,NUMPAR WRITE(ICOUT,183)I,IPARN1(I),IPARN2(I),PARAM(I) 183 FORMAT('I,IPARN1(I),IPARN2(I),PARAM(I) = ',I8,2X,A4,2X,A4,2X, 1F15.7) CALL DPWRST('XXX','BUG ') 182 CONTINUE 189 CONTINUE IERROR='YES' GOTO9000 190 CONTINUE IF(IBUGCO.EQ.'OFF')GOTO199 ISTEPN='1' CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) WRITE(ICOUT,191)NCTOT 191 FORMAT('NCTOT = ',I8) CALL DPWRST('XXX','BUG ') DO192I=1,NCTOT WRITE(ICOUT,193)I,IB(I) 193 FORMAT('I,IB(I) = ',I5,2X,A4) CALL DPWRST('XXX','BUG ') 192 CONTINUE 199 CONTINUE C C ************************************************************** C ** STEP 2-- ** C ** OPERATE ON THE VECTOR IB(.). ** C ** DETERMINE THE NUMBER OF CHARACTERS (IF ANY) ** C ** FOR THE LEFT-HAND SIDE. OUTPUT THEM INTO THE ** C ** VECTOR IL(.). ** C ************************************************************** C DO500I=1,NCTOT I2=I IF(IB(I).EQ.'=')GOTO550 500 CONTINUE NCL=0 ISTARR=1 GOTO559 550 CONTINUE NCL=I2-1 ISTARR=I2+1 559 CONTINUE C IF(NCL.LE.0)GOTO699 DO600I=1,NCL IL(I)=IB(I) 600 CONTINUE 690 CONTINUE IF(IBUGCO.EQ.'OFF')GOTO699 ISTEPN='2' CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) WRITE(ICOUT,691)NCL 691 FORMAT('NCL = ',2I8) CALL DPWRST('XXX','BUG ') DO692I=1,NCL WRITE(ICOUT,693)I,IL(I) 693 FORMAT('I,IL(I) = ',I5,2X,A4) CALL DPWRST('XXX','BUG ') 692 CONTINUE 699 CONTINUE C C *************************************************************** C ** STEP 3-- ** C ** OPERATE ON THE VECTOR IB(.). ** C ** DETERMINE THE NUMBER OF CHARACTERS FOR RIGHT-HAND SIDE. ** C ** OUTPUT THEM INTO THE VECTOR IR(.). ** C *************************************************************** C IF(ISTARR.LE.NCTOT)GOTO719 WRITE(ICOUT,701) 701 FORMAT('***** ERROR IN COMPIM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,702) 702 FORMAT(' THE NUMBER OF CHARACTERS ON THE RIGHT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,703) 703 FORMAT(' (WITH BLANKS IGNORED) IS 0.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,704) 704 FORMAT(' THE TOTAL NUMBER OF PACKED CHARACTERS NCTOT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,705) 705 FORMAT(' LEFT (IF ANY), EQUAL SIGN (IF ANY), AND RIGHT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,706)NCTOT 706 FORMAT(' = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,707) 707 FORMAT(' THE START POSITION FOR THE PACKED RIGHT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,708)ISTARR 708 FORMAT(' IS COLUMN ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,709)NUMCHA 709 FORMAT(' THE INPUT NUMBER OF CHARACTERS NUMCHA = ',I8) CALL DPWRST('XXX','BUG ') IF(NUMCHA.GE.1)WRITE(ICOUT,710)(IA(I),I=1,NUMCHA) 710 FORMAT(' INPUT EXPRESSION--',100A1) IF(NUMCHA.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 719 CONTINUE C K=0 DO700I=ISTARR,NCTOT K=K+1 IR(K)=IB(I) 700 CONTINUE NCR=K C IF(IBUGCO.EQ.'OFF')GOTO799 ISTEPN='3' CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) WRITE(ICOUT,791)NCR 791 FORMAT('NCR = ',2I8) CALL DPWRST('XXX','BUG ') DO792I=1,NCR WRITE(ICOUT,793)I,IR(I) 793 FORMAT('I,IR(I) = ',I5,2X,A4) CALL DPWRST('XXX','BUG ') 792 CONTINUE 799 CONTINUE C C **************************************************************** C ** STEP 4-- C ** OPERATE ON THE VECTOR IR(.). C ** ANALYZE THE RIGHT-HAND SIDE. C ** DETERMINE THE NUMBER OF DIFFERENT LOGICAL COMPONENTS. C ** 1. NUMBER (CONSISTING OF 0,1,2,...,9 OR .) C ** 2. X VARIABLE C ** 3. OPERATION (+ - * / **) C ** 4. PARENTHESES ( ( OR ) ) C ** 5. LIBRARY FUNCTION (ALOG EXP ETC + AUGMENTED LIB. C ** 6. COMMA (FOR MULTI-ARGUMENT LIBRARY FUNCTIONS) C ** 7. PARAMETER (ANYTHING NOT ABOVE) C ** CHECK FOR SYNTAX ERRORS. C ** OUTPUT THE TYPE COMPONENT INTO ITYPE(.). C ** OUTPUT THE START LOCATION IN IR(.) OF EACH COMPONENT INTO IB C ** OUTPUT THE STOP LOCATION IN IR(.) OF EACH COMPONENT INTO IE C **************************************************************** C NW=0 I=1 1050 CONTINUE IP1=I+1 IP2=I+2 IP3=I+3 IP4=I+4 IP5=I+5 C IF(IR(I).EQ.'0')GOTO1100 IF(IR(I).EQ.'1')GOTO1100 IF(IR(I).EQ.'2')GOTO1100 IF(IR(I).EQ.'3')GOTO1100 IF(IR(I).EQ.'4')GOTO1100 IF(IR(I).EQ.'5')GOTO1100 IF(IR(I).EQ.'6')GOTO1100 IF(IR(I).EQ.'7')GOTO1100 IF(IR(I).EQ.'8')GOTO1100 IF(IR(I).EQ.'9')GOTO1100 IF(IR(I).EQ.'.')GOTO1100 C C NOTE--THE FOLLOWING LINE IS BEING COMMENTED OUT C SO AS TO GENERALIZE COMPIL INTO COMPIM C (1 VARIABLE INTO MANY VARIABLES). CCCCC IF(IR(I).EQ.'X')GOTO1200 C IF(IR(I).EQ.'+')GOTO1300 IF(IR(I).EQ.'-')GOTO1300 IF(IR(I).EQ.'*')GOTO1300 IF(IR(I).EQ.'/')GOTO1300 C IF(IR(I).EQ.'(')GOTO1410 IF(IR(I).EQ.')')GOTO1420 C IF(IR(I).EQ.',')GOTO1700 C C CHECK FOR A LIBRARY FUNCTION. C CCCCC CALL CKLIBF(IR,NCR,I,IFOUND,NCLF,IBUGEV,IERROR) CALL CKLIB1(IR,NCR,I,IFOUND,NCLF,IBUGEV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IF(IFOUND.EQ.'NO')CALL CKLIB2(IR,NCR,I,IFOUND,NCLF,IBUGEV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IF(IFOUND.EQ.'NO')GOTO1600 IF(IFOUND.EQ.'YES'.AND.NCLF.EQ.8)GOTO1580 IF(IFOUND.EQ.'YES'.AND.NCLF.EQ.7)GOTO1570 IF(IFOUND.EQ.'YES'.AND.NCLF.EQ.6)GOTO1560 IF(IFOUND.EQ.'YES'.AND.NCLF.EQ.5)GOTO1550 IF(IFOUND.EQ.'YES'.AND.NCLF.EQ.4)GOTO1540 IF(IFOUND.EQ.'YES'.AND.NCLF.EQ.3)GOTO1530 IF(IFOUND.EQ.'YES'.AND.NCLF.EQ.2)GOTO1520 IF(IFOUND.EQ.'YES'.AND.NCLF.EQ.1)GOTO1510 C GOTO1600 C 1100 CONTINUE NW=NW+1 ITYPE(NW)='N' JMIN=I J=I 1150 CONTINUE J=J+1 IF(J.GT.NCR)GOTO1160 IF(IR(J).EQ.'0')GOTO1150 IF(IR(J).EQ.'1')GOTO1150 IF(IR(J).EQ.'2')GOTO1150 IF(IR(J).EQ.'3')GOTO1150 IF(IR(J).EQ.'4')GOTO1150 IF(IR(J).EQ.'5')GOTO1150 IF(IR(J).EQ.'6')GOTO1150 IF(IR(J).EQ.'7')GOTO1150 IF(IR(J).EQ.'8')GOTO1150 IF(IR(J).EQ.'9')GOTO1150 IF(IR(J).EQ.'.')GOTO1150 1160 CONTINUE JMAX=J-1 GOTO1800 C C1200 CONTINUE CCCCC NW=NW+1 CCCCC NLPWP=0 CCCCC NRPWP=0 CCCCC JMIN=I CCCCC J=I CCCCC ILOOP=0 1250 CONTINUE J=J+1 IF(J.GT.NCR)GOTO1260 IF(IR(J).EQ.'+')GOTO1260 IF(IR(J).EQ.'-')GOTO1260 IF(IR(J).EQ.'*')GOTO1260 IF(IR(J).EQ.'/')GOTO1260 IF(IR(J).EQ.'(')NLPWP=NLPWP+1 IF(IR(J).EQ.')')NRPWP=NRPWP+1 IF(IR(J).EQ.')'.AND.NRPWP.GT.NLPWP)GOTO1260 ILOOP=ILOOP+1 IF(ILOOP.LE.NUMAS2)GOTO1250 WRITE(ICOUT,1256)NUMAS2 1256 FORMAT('***** ERROR IN COMPIM--PARAMETER NAME EXCEEDS ',I8, 1' CHARACTERS') CALL DPWRST('XXX','BUG ') DO1257K=JMIN,J WRITE(ICOUT,1258)K,IR(K) 1258 FORMAT('K, IR(K) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 1257 CONTINUE IERROR='YES' GOTO9000 1260 CONTINUE JMAX=J-1 C THE FOLLOWING STATEMENT HAS BEEN C COMMENTED OUT IN GOING FROM THE C COMPIL SUBROUTINE TO THE COMPIM C SUBROUTINE SO THAT X WILL NOT C BE TREATED AS A SPECIAL VARIABLE. CCCCC IF(JMAX.EQ.JMIN)ITYPE(NW)='X' IF(JMAX.GT.JMIN)ITYPE(NW)='PAR' GOTO1800 C 1300 CONTINUE NW=NW+1 ITYPE(NW)='OP' JMIN=I JMAX=I IP1=I+1 IF(IR(I).EQ.'*'.AND.IR(IP1).EQ.'*')JMAX=IP1 GOTO1800 C 1410 CONTINUE NW=NW+1 ITYPE(NW)='LP' JMIN=I JMAX=I GOTO1800 1420 CONTINUE NW=NW+1 ITYPE(NW)='RP' JMIN=I JMAX=I GOTO1800 C 1510 CONTINUE NW=NW+1 ITYPE(NW)='LF' JMIN=I JMAX=I GOTO1800 C 1520 CONTINUE NW=NW+1 ITYPE(NW)='LF' JMIN=I JMAX=I+1 GOTO1800 C 1530 CONTINUE NW=NW+1 ITYPE(NW)='LF' JMIN=I JMAX=I+2 GOTO1800 C 1540 CONTINUE NW=NW+1 ITYPE(NW)='LF' JMIN=I JMAX=I+3 GOTO1800 C 1550 CONTINUE NW=NW+1 ITYPE(NW)='LF' JMIN=I JMAX=I+4 GOTO1800 C 1560 CONTINUE NW=NW+1 ITYPE(NW)='LF' JMIN=I JMAX=I+5 GOTO1800 C 1570 CONTINUE NW=NW+1 ITYPE(NW)='LF' JMIN=I JMAX=I+6 GOTO1800 C 1580 CONTINUE NW=NW+1 ITYPE(NW)='LF' JMIN=I JMAX=I+7 GOTO1800 C 1700 CONTINUE NW=NW+1 ITYPE(NW)='COM' JMIN=I JMAX=I GOTO1800 C 1600 CONTINUE NW=NW+1 ITYPE(NW)='PAR' NLPWP=0 NRPWP=0 JMIN=I J=I ILOOP=0 1650 CONTINUE J=J+1 IF(J.GT.NCR)GOTO1660 IF(IR(J).EQ.'+')GOTO1660 IF(IR(J).EQ.'-')GOTO1660 IF(IR(J).EQ.'*')GOTO1660 IF(IR(J).EQ.'/')GOTO1660 IF(IR(J).EQ.'(')NLPWP=NLPWP+1 IF(IR(J).EQ.')')NRPWP=NRPWP+1 IF(IR(J).EQ.')'.AND.NRPWP.GT.NLPWP)GOTO1660 IF(IR(J).EQ.',')GOTO1660 ILOOP=ILOOP+1 IF(ILOOP.LE.NUMAS2)GOTO1650 WRITE(ICOUT,1656)NUMAS2 1656 FORMAT('***** ERROR IN COMPIM--PARAMETER NAME EXCEEDS ',I8, 1' CHARACTERS') CALL DPWRST('XXX','BUG ') DO1657K=JMIN,J WRITE(ICOUT,1658)K,IR(K) 1658 FORMAT('K, IR(K) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 1657 CONTINUE IERROR='YES' GOTO9000 1660 CONTINUE JMAX=J-1 GOTO1800 C 1800 CONTINUE C C CHECK THAT NW HAS NOT EXCEEDED MAXCHA (USUALLY 80) C IF(NW.LE.MAXCHA)GOTO1900 WRITE(ICOUT,1901) 1901 FORMAT('***** ERROR IN COMPIM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1902) 1902 FORMAT(' THE VARIABLE NW HAS JUST EXCEEDED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1903) 1903 FORMAT(' THE MAX ALLOWABLE LIMIT DEFINED ', 1'BY THE INTERNAL VARIABLE MAXCHA.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1904)MAXCHA 1904 FORMAT(' THIS LIMIT IS MAXCHA = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1905)NUMCHA 1905 FORMAT(' THE INPUT NUMBER OF CHARACTERS NUMCHA = ',I8) CALL DPWRST('XXX','BUG ') IF(NUMCHA.GE.1)WRITE(ICOUT,1906)(IA(I),I=1,NUMCHA) 1906 FORMAT(' INPUT EXPRESSION--',100A1) IF(NUMCHA.GE.1)CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1907) 1907 FORMAT(' THE NUMBER OF (PACKED) CHARACTERS ON ', 1'RIGHT-HAND SIDE NCR = ',I8) CALL DPWRST('XXX','BUG ') IF(NCR.GE.1)WRITE(ICOUT,1908)(IR(I),I=1,NCR) 1908 FORMAT(' (PACKED) RIGHT-HAND SIDE--',95A1) IF(NCR.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1900 CONTINUE C IBEGIN(NW)=JMIN IEND(NW)=JMAX I=JMAX C I=I+1 IF(I.LE.NCR)GOTO1050 1950 CONTINUE C C TEST THAT NW IS POSITIVE. C IF(NW.GE.1)GOTO1959 WRITE(ICOUT,1951)NW 1951 FORMAT('***** ERROR IN COMPIM--NW IS NON-POSITIVE. ', 1'NW = ',I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1959 CONTINUE C IF(NW.EQ.1)GOTO1969 DO1960I=1,NW IP1=I+1 IF(ITYPE(I).EQ.'LF'.AND.ITYPE(IP1).NE.'LP')GOTO1961 GOTO1960 1961 CONTINUE WRITE(ICOUT,1962) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1963)NW CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1964)I CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1965)ITYPE(I) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1966)ITYPE(IP1) 1962 FORMAT('***** ERROR IN COMPIM--LIBRARY FUNCTION ', 1'NOT FOLLOWED BY A LEFT PARENTHESES') CALL DPWRST('XXX','BUG ') 1963 FORMAT(' NW = ',I8) 1964 FORMAT(' I = ',I8) 1965 FORMAT(' ITYPE(I) = ',A4) 1966 FORMAT(' ITYPE(I+1) = ',A4) IERROR='YES' GOTO9000 1960 CONTINUE 1969 CONTINUE C IF(ITYPE(NW).EQ.'OP')GOTO1970 IF(ITYPE(NW).EQ.'LF')GOTO1972 GOTO1979 C 1970 CONTINUE WRITE(ICOUT,1971)ITYPE(NW) 1971 FORMAT('***** ERROR IN COMPIM--LAST TERM IN TOTAL ', 1' EXPRESSION IS AN OPERATION = ',A4) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1972 CONTINUE WRITE(ICOUT,1973)ITYPE(NW) 1973 FORMAT('***** ERROR IN COMPIM--LAST TERM IN TOTAL ', 1' EXPRESSION = A LIBRARY FUNCTION = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1975)IPASS,NW 1975 FORMAT('IPASS,NW = ',2I8) CALL DPWRST('XXX','BUG ') IF(NW.GE.1)WRITE(ICOUT,1976)ITYPE(NW) 1976 FORMAT('ITYPE(NW) = ',A4) IF(NW.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1979 CONTINUE C IF(IBUGCO.EQ.'OFF')GOTO1999 ISTEPN='4' CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) WRITE(ICOUT,1991)NW 1991 FORMAT('NW = ',I8) CALL DPWRST('XXX','BUG ') DO1992I=1,NW ICMIN=IBEGIN(I) ICMINP=ICMIN+1 ICMINQ=ICMIN+2 WRITE(ICOUT,1993)I,IR(ICMIN),IR(ICMINP),IR(ICMINQ),ITYPE(I), 1IBEGIN(I),IEND(I) 1993 FORMAT('I,IR(ICMIN),IR(ICMIN+1),IR(ICMIN+2),ITYPE(I),', 1'IBEGIN(I),IEND(I) = ',I8,2X,3A4,A4,2X,I8,2X,I8) CALL DPWRST('XXX','BUG ') 1992 CONTINUE 1999 CONTINUE C C **************************************************************** C ** STEP 5-- C ** OPERATE ON EACH COMPONENT OF THE VECTOR IR(.). C ** CONVERT THE NUMBERS TO FLOATING POINT VALUES. C ** CONVERT THE PARAMATERS TO FLOATING POINT VALUES. C ** SET THE X TO AN DUMMY VALUE OF 0.0 FOR THE TIME BEING. C ** CONVERT THE OPERATIONS INTO A 1-WORD REPRESENTATION. C ** 'CONVERT' THE PARENTHESES INTO A 1-WORD REPRESENTATION. C ** CONVERT THE COEFFICIENTS TO COEFFICIENT VALUES. C ** CONVERT THE LIBRARY FUNCTIONS INTO A 1-WORD REPRESENTATION. C ** SAVE THE CONTENTS OF ITYPE, IW21, IW22, AND W2 IN C ** ITYPEH, IW21HO, IW22HO, AND WHOLD FOR LATER USE C ** IN REDEFINING ITYPE, IW21, IW22, AND W2 FOR EACH NEW X VALUE C ** OUTPUT THE VECTORS IW21, IW22 AND W2. C ** OUTPUT THE VECTORS IW21HO, IW22HO, W2HOLD, AND ITYPEH. C **************************************************************** C DO3000I=1,NW ICMIN=IBEGIN(I) ICMAX=IEND(I) IF(ITYPE(I).EQ.'N')GOTO3100 IF(ITYPE(I).EQ.'X')GOTO3200 IF(ITYPE(I).EQ.'OP')GOTO3300 IF(ITYPE(I).EQ.'LP'.OR.ITYPE(I).EQ.'RP')GOTO3400 IF(ITYPE(I).EQ.'PAR')GOTO3500 IF(ITYPE(I).EQ.'LF')GOTO3600 IF(ITYPE(I).EQ.'COM')GOTO3700 WRITE(ICOUT,3005) 3005 FORMAT('***** ERROR IN COMPIM--ITYPE(I) NOT X, OP, LP, PAR, ', 1'OR LF') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3006)I,ITYPE(I),IW21(I),W2(I) 3006 FORMAT('I,ITYPE(I),IW21(I),W2(I) = ', 1I8,2X,A4,2X,A4,2X,F15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 3100 CONTINUE W2(I)=0.0 IANS1=' ' IANS2=' ' IANS3=' ' IANS4=' ' J=0 DO3150IC=ICMIN,ICMAX J=J+1 JM1=J-1 L=J-(NUMASC*(JM1/NUMASC)) K=NUMBPC*(L-1) K=IABS(K) CCCCC WRITE(ICOUT,3333)J,JM1,L,K,IR(IC) 3333 FORMAT('J,JM1,L,K,IR(IC) = ',4I8,2X,A4) CCCCC CALL DPWRST('XXX','BUG ') IF(J.LE.NUMASC)GOTO3151 IF(J.LE.NUMAS2)GOTO3152 IF(J.LE.NUMAS3)GOTO3153 IF(J.LE.NUMAS4)GOTO3154 GOTO3155 3151 CONTINUE CALL DPCHEX(0,NUMBPC,IR(IC),K,NUMBPC,IANS1) GOTO3155 3152 CONTINUE CALL DPCHEX(0,NUMBPC,IR(IC),K,NUMBPC,IANS2) GOTO3155 3153 CONTINUE CALL DPCHEX(0,NUMBPC,IR(IC),K,NUMBPC,IANS3) GOTO3155 3154 CONTINUE CALL DPCHEX(0,NUMBPC,IR(IC),K,NUMBPC,IANS4) GOTO3155 3155 CONTINUE CCCCC WRITE(ICOUT,4444)IANS1,IANS2,IANS3,IANS4 4444 FORMAT(4A4) CCCCC CALL DPWRST('XXX','BUG ') 3150 CONTINUE ERRMAX=10.0**9 ERRMIN=-ERRMAX CALL ERRORF(IANS1,IANS2,IANS3,IANS4,ERRMIN,ERRMAX, 1ERRMAX,ANS2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 W2(I)=ANS2 GOTO3000 C 3200 CONTINUE W2(I)=0.0 GOTO3000 C 3300 CONTINUE IW21(I)=IR(ICMIN) ICMINP=ICMIN+1 IF(IR(ICMIN).EQ.'*'.AND.IR(ICMINP).EQ.'*')IW21(I)='**' GOTO3000 C 3400 CONTINUE IW21(I)=IR(ICMIN) GOTO3000 C 3500 CONTINUE IW21(I)=' ' IW22(I)=' ' ICMAX2=ICMIN+NUMAS2-1 IF(ICMAX.LE.ICMAX2)ICMAX2=ICMAX J=0 DO3550IC=ICMIN,ICMAX2 J=J+1 J2=J IF(J2.GT.NUMASC)J2=J-NUMASC ISTAR3=NUMBPC*(J2-1) ISTAR3=IABS(ISTAR3) IF(J.LE.NUMASC)CALL DPCHEX(0,NUMBPC,IR(IC),ISTAR3,NUMBPC,IW21(I)) IF(J.GT.NUMASC)CALL DPCHEX(0,NUMBPC,IR(IC),ISTAR3,NUMBPC,IW22(I)) 3550 CONTINUE C IF(IPASS.EQ.1)GOTO3000 C DO3570J=1,NUMPAR IF(IW21(I).EQ.IPARN1(J).AND.IW22(I).EQ.IPARN2(J))GOTO3580 3570 CONTINUE WRITE(ICOUT,3571) 3571 FORMAT('***** ERROR IN COMPIM--NO MATCH FOR PARAM./VAR. NAME') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3572)IW21(I),IW22(I) 3572 FORMAT(' GIVEN PARAM./VAR. NAME = ',2A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3573)NUMPAR 3573 FORMAT(' NUMBER OF PARAM./VAR. =',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3574) 3574 FORMAT(' ADMISSIBLE PARAM./VAR. ', 1'NAMES = ') CALL DPWRST('XXX','BUG ') DO3575J=1,NUMPAR WRITE(ICOUT,3576)J,IPARN1(J),IPARN2(J) 3576 FORMAT(' PARAM./VAR. NAME ',I4,'--',2A4) CALL DPWRST('XXX','BUG ') 3575 CONTINUE WRITE(ICOUT,3577)(IA(J),J=1,NUMCHA) 3577 FORMAT(' FUNCTION EXPRESSION--',100A1) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 3580 CONTINUE W2(I)=PARAM(J) GOTO3000 C 3600 CONTINUE IW21(I)=' ' IW22(I)=' ' ICMAX2=ICMIN+NUMAS2-1 IF(ICMAX.LE.ICMAX2)ICMAX2=ICMAX J=0 DO3650IC=ICMIN,ICMAX2 J=J+1 J2=J IF(J2.GT.NUMASC)J2=J-NUMASC ISTAR3=NUMBPC*(J2-1) ISTAR3=IABS(ISTAR3) IF(J.LE.NUMASC)CALL DPCHEX(0,NUMBPC,IR(IC),ISTAR3,NUMBPC,IW21(I)) IF(J.GT.NUMASC)CALL DPCHEX(0,NUMBPC,IR(IC),ISTAR3,NUMBPC,IW22(I)) 3650 CONTINUE GOTO3000 C 3700 CONTINUE IW21(I)=IR(ICMIN) GOTO3000 C 3000 CONTINUE NWHOLD=NW DO3900I=1,NW ITYPEH(I)=ITYPE(I) IW21HO(I)=IW21(I) IW22HO(I)=IW22(I) W2HOLD(I)=W2(I) 3900 CONTINUE IF(IBUGCO.EQ.'OFF')GOTO3999 ISTEPN='5' CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) DO3992I=1,NW ICMIN=IBEGIN(I) ICMINP=ICMIN+1 ICMINQ=ICMIN+2 WRITE(ICOUT,3993)I,IR(ICMIN),IR(ICMINP),IR(ICMINQ),ITYPE(I), 1IW21(I),IW22(I),W2(I) 3993 FORMAT('I,IR(ICMIN),IR(ICMIN+1),IR(ICMIN+2),ITYPE(I),', 1'IW21(I),IW22HO(I),W2(I) = ',I8,2X,3A4,2X,A4,2X,A4,2X,A4,2X,F15.6) CALL DPWRST('XXX','BUG ') 3992 CONTINUE 3999 CONTINUE C C **************************************************** C ** STEP 6-- ** C ** THIS STEP IS TO BE EXECUTED IF IPASS=1; ** C ** OTHERWISE IT IS SKIPPED. ** C ** IF THIS STEP IS EXECUTED, STEP 7 IS NOT; ** C ** IF THIS STEP IS NOT EXECUTED, STEP 7 IS. ** C ** OPERATE ON IW21, IW22, AND ITYPE VECTORS. ** C ** DETERMINE THE NUMBER OF DISTINCT PARAMETERS. ** C ** FORM THE OUTPUT VECTOR IPARN. ** C **************************************************** C IF(IPASS.EQ.1)GOTO4050 GOTO4999 4050 CONTINUE C NUMPAR=0 DO4100I=1,NW IF(ITYPE(I).EQ.'PAR')GOTO4200 GOTO4100 4200 CONTINUE IF(NUMPAR.EQ.0)GOTO4300 DO4400J=1,NUMPAR IF(IW21(I).EQ.IPARN1(J).AND.IW22(I).EQ.IPARN2(J))GOTO4100 4400 CONTINUE 4300 CONTINUE NUMPAR=NUMPAR+1 IPARN1(NUMPAR)=IW21(I) IPARN2(NUMPAR)=IW22(I) 4100 CONTINUE GOTO9000 4999 CONTINUE C C **************************************************************** C ** STEP 7-- C ** OPERATE ON THE W2(.), IW21(.), AND IW22(.) VECTORS. C ** THIS STEP IS NOT EXECUTED IF STEP 6 IS; C ** THIS STEP IS EXECUTED IF STEP 6 IS NOT. C ** FIRST MAKE SURE THAT THE NUMBER OF LEFT C ** AND RIGHT PARENTHESES ARE THE SAME. C ** (STEP 6 THEN SETS UP A LARGE DO LOOP C ** WHICH GOES THROUGH ALL OF THE VALUES OF THE X VECTOR C ** AND GENERATES CORRESPONDING VALUES OF THE Y VECTOR.) C ** FOR A GIVEN X VALUE, IT EVALUATES THE FUNCTION C ** BY FIRST SEEKING THE INNERMOST PARENTHESES C ** (BY SEARCHING FOR THE FIRST REMAINING RIGHT PARENTHESS). C ** AND THEN EVALUATING ALL SUCH PARENTHETICAL EXPRESSIONS-- C ** WORKING FROM THE INNERMOST OUT. C ** AFTER EVALUATING A PARENTHESES PAIR, C ** THE ENTIRE PARENTHESES GROUP (PARENTHESES INCLUDED) C ** IS REPLACED BY THE SCALAR ANSWER. C ** THE IW21, IW22, W2, AND ITYPE VECTORS ARE SQUEEZED ACCORDING C ** (IN THE SUBROUTINE EVAL). C ** SINCE THE VECTORS IW21, IW22, W2, AND ITYPE ARE ALTERED (SQU C ** FOR EACH X VALUE, THEY MUST BE REDEFINED FROM THE SAVED C ** VALUES IN IW21HO, IW22HO, W2HOLD, AND ITYPEH FOR EACH NEW X C ** THE ABOVE SQUEEZING OPERATION IS REPEATED C ** FOR EACH PARENTHESES PAIR UNTIL ALL PARENTHESES C ** ARE GONE AND WE REMAIN ONLY WITH THE FINAL ANSWER. C ** FOR EACH VALUE X(.) OF THE INPUT X VECTOR, C ** OUTPUT THE CORRESPONDING VALUE Y(.) OF C ** THE DESIRED OUTPUT VECTOR. C ** FOR A GIVEN VALUE X(.), THE CORRESPONDING C ** COMPUTED Y(.) WILL BE THE EVALUATED VALUE OF C ** THE RIGHT-HAND SIDE OF THE SPECIFIED EQUATION Y = F(X). C **************************************************************** C 5000 CONTINUE C NW=NWHOLD DO5050I=1,NW ITYPE(I)=ITYPEH(I) IW21(I)=IW21HO(I) IW22(I)=IW22HO(I) W2(I)=W2HOLD(I) 5050 CONTINUE C DO5060I=1,NW IF(ITYPE(I).EQ.'PAR')GOTO5069 C IF(ITYPE(I).EQ.'N')GOTO5089 IF(ITYPE(I).EQ.'X')GOTO5089 IF(ITYPE(I).EQ.'OP')GOTO5089 IF(ITYPE(I).EQ.'LP'.OR.ITYPE(I).EQ.'RP')GOTO5089 IF(ITYPE(I).EQ.'LF')GOTO5089 IF(ITYPE(I).EQ.'COM')GOTO5089 WRITE(ICOUT,5061) 5061 FORMAT('***** ERROR IN COMPIM--ITYPE(I) NOT X, OP, LP, PAR, ', 1'OR LF') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5062)I,ITYPE(I),IW21(I),IW22(I),W2(I) 5062 FORMAT('I,ITYPE(I),IW21(I),IW22(I),W2(I) = ', 1I8,2X,A4,2X,A4,2X,A4,2X,F15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 5069 CONTINUE C IF(NUMPAR.LE.0)GOTO5079 DO5070J=1,NUMPAR J2=J IF(IW21(I).EQ.IPARN1(J).AND.IW22(I).EQ.IPARN2(J))GOTO5080 5070 CONTINUE 5079 CONTINUE WRITE(ICOUT,5071) 5071 FORMAT('***** ERROR IN COMPIM--NO MATCH FOR PARAM./VAR. NAME') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5072)IW21(I),IW22(I) 5072 FORMAT(' GIVEN PARAM./VAR. NAME = ',2A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5073)NUMPAR 5073 FORMAT(' NUMBER OF PARAM./VAR. =',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5074) 5074 FORMAT(' ADMISSIBLE PARAM./VAR. ', 1'NAMES = ') CALL DPWRST('XXX','BUG ') DO5075J=1,NUMPAR WRITE(ICOUT,5076)J,IPARN1(J),IPARN2(J) 5076 FORMAT(' PARAM./VAR. NAME ',I3,'--',2A4) CALL DPWRST('XXX','BUG ') 5075 CONTINUE WRITE(ICOUT,5077)(IA(J),J=1,NUMCHA) 5077 FORMAT(' FUNCTION EXPRESSION--',100A1) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 5080 CONTINUE W2(I)=PARAM(J2) 5089 CONTINUE 5060 CONTINUE C NLP=0 NRP=0 DO5100I=1,NW IF(ITYPE(I).EQ.'LP')NLP=NLP+1 IF(ITYPE(I).EQ.'RP')NRP=NRP+1 5100 CONTINUE IF(NLP.EQ.NRP)GOTO5190 WRITE(ICOUT,5155) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5156) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5157)NLP CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5158)NRP 5155 FORMAT('***** ERROR IN COMPIM--') CALL DPWRST('XXX','BUG ') 5156 FORMAT('NUMBER OF LEFT PARENTHESES NOT EQUAL TO ', 1'NUMBER OF RIGHT PARENTHESES') 5157 FORMAT('NUMBER OF LEFT PARENTHESES = ',I8) 5158 FORMAT('NUMBER OF RIGHT PARENTHESES = ',I8) IERROR='YES' GOTO9000 5190 CONTINUE C CCCCC ADD FOLLOWING LINES APRIL 1995. ILIBC1=0 ILIBC2=0 DO5195IJ=1,MAXNST SAVE1(IJ)=-99.9 SAVE2(IJ)=-99.9 SAVE3(IJ)=-99.9 SAVE4(IJ)=-99.9 SAVE5(IJ)=-99.9 SAVE6(IJ)=-99.9 SAVE7(IJ)=-99.9 SAVE8(IJ)=-99.9 5195 CONTINUE C DO10000II=1,N C IF(II.EQ.1)GOTO5209 NW=NWHOLD DO5200I=1,NW ITYPE(I)=ITYPEH(I) IW21(I)=IW21HO(I) IW22(I)=IW22HO(I) W2(I)=W2HOLD(I) C THE FOLLOWING STATEMENT HAS BEEN COMMENTED OUT C IN GOING FROM COMPIL TO COMPIM. CCCCC IF(ITYPE(I).EQ.'X')W2(I)=X(II) 5200 CONTINUE 5209 CONTINUE C IF(IBUGCO.EQ.'ON')GOTO5249 GOTO5299 5249 CONTINUE ISTEPN='7' CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) DO5250I=1,NW WRITE(ICOUT,5251)I,IW21HO(I),IW22HO(I),IW21(I),IW22(I) 5251 FORMAT('I,IW21HO(I),IW22HO(I),IW21(I),IW22(I) = ', 1I8,2X,A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 5250 CONTINUE 5299 CONTINUE C ILOOP=1 5310 CONTINUE 5350 CONTINUE DO5400I=1,NW I2=I IF(ITYPE(I).EQ.'RP')GOTO5450 5400 CONTINUE ISTOP=NW+1 ISTART=0 GOTO5690 5450 CONTINUE ISTOP=I2 DO5600I=1,ISTOP IREV=ISTOP-I+1 IF(ITYPE(IREV).EQ.'LP')GOTO5650 5600 CONTINUE WRITE(ICOUT,5605) 5605 FORMAT('***** ERROR IN COMPIM--ITYPE(IREV) NOT LP') CALL DPWRST('XXX','BUG ') 5650 CONTINUE ISTART=IREV 5690 CONTINUE C ISTAP1=ISTART+1 ISTOM1=ISTOP-1 CCCCC ADD SAVE4 ARGUMENT SEPTEMBER 1994. CCCCC ADD SAVE5 ARGUMENT MAY 1998. CCCCC ADD SAVE6, SAVE7, SAVE8 ARGUMENTS JUNE 2003. IJUNK=ISTART-1 IF(IJUNK.GE.1)THEN IF(ITYPE(IJUNK).EQ.'LF')ILIBC1=ILIBC1+1 ENDIF CALL EVALM(IW21,IW22,W2,ITYPE,ISTAP1,ISTOM1,IANGLU,Y, CCCCC1SAVE1,SAVE2,SAVE3,IBUGEV,IERROR) 1SAVE1,SAVE2,SAVE3,SAVE4,SAVE5,SAVE6,SAVE7,SAVE8, 1ILIBC1,ILIBC2,IBUGEV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IF(ISTART.LE.0)GOTO5900 W2(ISTART)=Y ITYPE(ISTART)='V' IF(NW.EQ.1)GOTO5900 ISTOPP=ISTOP+1 J=ISTART IF(ISTOP.EQ.NW)GOTO5750 DO5700I=ISTOPP,NW J=J+1 IW21(J)=IW21(I) IW22(J)=IW22(I) W2(J)=W2(I) ITYPE(J)=ITYPE(I) 5700 CONTINUE 5750 CONTINUE NW=J GOTO5350 C5300 CONTINUE CCCCC ILOOP=ILOOP+1 CCCCC IF(ILOOP.LE.1000000)GOTO5310 C 5900 CONTINUE 10000 CONTINUE GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGCO.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF COMPIM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGCO,IBUGEV 9012 FORMAT('IBUGCO,IBUGEV = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') DO9113I=1,MAXNST WRITE(ICOUT,9013)I,SAVE1(I),SAVE2(I),SAVE3(I),SAVE4(I),Y 9013 FORMAT('I,SAVE1,SAVE2,SAVE3,SAVE4,Y = ',I3,5E15.7) CALL DPWRST('XXX','BUG ') 9113 CONTINUE WRITE(ICOUT,9014)NUMCHA,N,IPASS,IANGLU 9014 FORMAT('NUMCHA,N,IPASS,IANGLU = ',3I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)IPASS,NW 9021 FORMAT('IPASS,NW = ',2I8) CALL DPWRST('XXX','BUG ') IF(NW.GE.1)WRITE(ICOUT,9022)ITYPE(NW) 9022 FORMAT('ITYPE(NW) = ',A4) IF(NW.GE.1)CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END DOUBLE PRECISION FUNCTION CONDIT( N, SYMIN ) * * Computes condition number of symmetric matix in situ * INTEGER NL, N PARAMETER ( NL = 100 ) DOUBLE PRECISION DET, SYMIN(*), SUM, ROWMX, ROWMXI, & SYM(NL*(NL+1)/2) INTEGER II, IJ, I, J, IM ROWMX = 0 IJ = 0 DO 100 I = 1,N SUM = 0 IM = (I-2)*(I-1)/2 DO 200 J = 1,I-1 IM = IM + 1 SUM = SUM + ABS(SYMIN(IM)) IJ = IJ + 1 SYM(IJ) = SYMIN(IM) 200 CONTINUE SUM = SUM + 1 IJ = IJ + 1 SYM(IJ) = 1 IM = IM + I DO 300 J = I,N-1 SUM = SUM + ABS(SYMIN(IM)) IM = IM + J 300 CONTINUE ROWMX = MAX( SUM, ROWMX ) 100 CONTINUE CALL SYMINV(N, SYM, DET) ROWMXI = 0 II = 0 DO 400 I = 1,N SUM = 0 IJ = II DO 500 J = 1,I IJ = IJ + 1 SUM = SUM + ABS(SYM(IJ)) 500 CONTINUE DO 600 J = I,N-1 IJ = IJ + J SUM = SUM + ABS(SYM(IJ)) 600 CONTINUE ROWMXI = MAX( SUM, ROWMXI ) II = II + I 400 CONTINUE CONDIT = ROWMX*ROWMXI C RETURN END SUBROUTINE CONINS(X,Y,NPT,XX,YY,NPTC) C C PURPOSE--INCORPORATE AN INTERIOR CLOSED CONTOUR SEGMENT C INTO ANOTHER SEGMENT C C RECOMMENDED DIMENSIONS-- C X(NPT+NPTC+1) C Y(NPT+NPTC+1) C XX(NPTC) C YY(NPTC) C LC(4) C C WRITTEN BY--DAVID W. BEHRINGER NOAA/AOML (MIAMI). C AS PART OF NOAA'S CONCX V.3 MARCH 1988. C ORIGINAL VERSION (IN DATAPLOT)--AUGUST 1988. C C--------------------------------------------------------------------- C CCCCC DIMENSION X(NPT+NPTC+1),Y(NPT+NPTC+1),XX(NPTC),YY(NPTC),LC(4) C DIMENSION X(*) DIMENSION Y(*) DIMENSION XX(*) DIMENSION YY(*) C DIMENSION LC(4) C C-----START POINT----------------------------------------------------- C C FIRST FIND UP, DOWN, LEFT & RIGHT EXTREMES OF AN INTERIOR SEGMENT DO 10 I=1,4 LC(I)=1 10 CONTINUE DO 20 L=1,NPTC IF (XX(L).LT.XX(LC(1))) LC(1)=L IF (YY(L).GT.YY(LC(2))) LC(2)=L IF (XX(L).GT.XX(LC(3))) LC(3)=L IF (YY(L).LT.YY(LC(4))) LC(4)=L 20 CONTINUE C FIND A REASONABLY CLOSE APPROACH OF INTERIOR SEGMENT TO THE CONTINUOUS C STRING L1=LC(1) L0=1 DMN=SQRT((XX(L1)-X(L0))**2+(YY(L1)-Y(L0))**2) DO 100 L=1,NPT DO 200 I=1,4 LL=LC(I) DTST=SQRT((XX(LL)-X(L))**2+(YY(LL)-Y(L))**2) IF (DTST.LT.DMN) THEN DMN=DTST L0=L L1=LL END IF 200 CONTINUE 100 CONTINUE C REORDER THE INTERIOR SEGMENT DO 300 L=1,L1-1 HX=XX(1) HY=YY(1) DO 400 LL=2,NPTC-1 XX(LL-1)=XX(LL) YY(LL-1)=YY(LL) 400 CONTINUE XX(NPTC-1)=HX YY(NPTC-1)=HY 300 CONTINUE XX(NPTC)=XX(1) YY(NPTC)=YY(1) C INSERT THE INTERIOR SEGMENT INTO THE CONTINUOUS STRING DO 500 L=NPT,L0,-1 X(L+1)=X(L) Y(L+1)=Y(L) 500 CONTINUE NPT=NPT+1 L0=L0+1 L2=NPT+1 L3=NPTC+L2 NPT=L3-1 DO 600 L=L2,NPT LL=L-L2+1 X(L)=XX(LL) Y(L)=YY(LL) 600 CONTINUE CALL STRSWP(X,L0,L2,L3) CALL STRSWP(Y,L0,L2,L3) RETURN END SUBROUTINE CONCDF(DX,DSHAPE,DM,ICONDF,DCDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE CONSUL DISTRIBUTION WITH SHAPE C PARAMETERS THETA AND M. THIS DISTRIBUTION IS C DEFINED FOR ALL INTEGER X >= 1. C C THIS DISTRIBUTION REDUCES TO THE GEOMETRIC C DISTRIBUTION WHEN M = 1. FOR THIS REASON, IT C SOMETIMES REFERRED TO AS THE GENERALIZED GEOMETRIC C DISTRIBUTION. NOTE THAT THIS DISTRIBUTION HAS A C SIMILAR FORM TO THE GEETA DISTRIBUTION. C C THE PROBABILITY MASS FUNCTION IS: C p(X;THETA,M)= C (M*X X-1)*THETA**(X-1)*(1-THETA)**(M*X-X+1)/X C X = 1, 2, 3, ,... C 0 < THETA < 1; 1 <= M < 1/THETA C C A RECURRENCE RELATION FOR THE CDF FUNCTION IS C C P(X;THETA,M) = {(M-1)*(X-1)+1}/(X-1)}* C THETA*(1-TYHETA)**(M-1)* C PROD[i=1 to X-2][(1 + M/(M*X-M-i)]* C P(X-1;THETA,M) C C THIS DISTRIBUTION IS SOMETIMES PARAMETERIZED USING C THE MEAN (MU) INSTEAD OF THETA. THIS RESULTS IN C THE PROBABILITY MASS FUNCTION: C p(X;MU,M)= C (M*X X-1)*((MU-1)/(M*MU))**(X-1)* C (1 - (M-1)/(M*MU))**(M*X-X+1)/X C X = 1, 2, 3, ,... C MU >= 1; M > 1 C NOTE THAT THE RELATION IS: C C THETA=(MU-1)/(M*MU) C C INPUT ARGUMENTS--DX = THE DOUBLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C X SHOULD BE A NON-NEGATIVE INTEGER. C --DSHAPE = THE FIRST SHAPE PARAMETER C (EITHER THETA OR MU) C --DM = THE SECOND SHAPE PARAMETER C OUTPUT ARGUMENTS--DCDF = THE DOUBLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION FUNCTION C VALUE CDF FOR THE CONSUL DISTRIBUTION WITH SHAPE C PARAMETERS THETA (OR MU) AND M C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE A POSITIVE INTEGER C --0 < THETA < 1; 1 < M < 1/THETA C --MU >= 1; M > 1 C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY C DISTRIBUTIONS", BIRKHAUSER, CHAPTER 8. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/8 C ORIGINAL VERSION--AUGUST 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DSHAPE DOUBLE PRECISION DM DOUBLE PRECISION DCDF DOUBLE PRECISION DPDF DOUBLE PRECISION DPDFSV C DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTHETA DOUBLE PRECISION DMU DOUBLE PRECISION DSUM C CHARACTER*4 ICONDF CHARACTER*4 ICOND2 C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(ICONDF.EQ.'THET')THEN DTHETA=DSHAPE ELSE DMU=DSHAPE DTHETA=(DMU-1.0D0)/(DM*DMU) ENDIF C IX=INT(DX+0.5D0) IF(IX.LT.1)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DX CALL DPWRST('XXX','BUG ') DCDF=0.0D0 GOTO9000 ENDIF 4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO CONCDF IS LESS ', 1'THAN 1') C IF(ICONDF.EQ.'THET')THEN IF(DTHETA.LE.0.0D0 .OR. DTHETA.GE.1.0D0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DTHETA CALL DPWRST('XXX','BUG ') DCDF=0.0 GOTO9000 ENDIF 15 FORMAT('***** ERROR--THE SECOND ARGUMENT TO CONCDF IS NOT ', 1 'IN THE INTERVAL (0,1)') C IF(DM.LT.1.0D0 .OR. DM.GE.1.0D0/DTHETA)THEN WRITE(ICOUT,25)1.0D0/DTHETA CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DM CALL DPWRST('XXX','BUG ') DCDF=0.0 GOTO9000 ENDIF 25 FORMAT('***** ERROR--THE THIRD ARGUMENT TO CONCDF IS NOT ', 1 'IN THE INTERVAL (1,',G15.7,')') ELSE IF(DMU.LT.1.0D0)THEN WRITE(ICOUT,35) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DMU CALL DPWRST('XXX','BUG ') DCDF=0.0 GOTO9000 ENDIF 35 FORMAT('***** ERROR--THE SECOND ARGUMENT TO CONCDF IS ', 1 'LESS THAN 1') C IF(DM.LT.1.0D0)THEN WRITE(ICOUT,38) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DM CALL DPWRST('XXX','BUG ') DCDF=0.0 GOTO9000 ENDIF 38 FORMAT('***** ERROR--THE THIRD ARGUMENT TO CONCDF IS ', 1 'LESS THAN 1') ENDIF C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) C DCDF=(1.0D0 - DTHETA)**DM IF(IX.EQ.1)THEN GOTO9000 ELSE DX=2.0D0 ICOND2='THET' CALL CONPDF(DX,DTHETA,DM,ICOND2,DPDF) DCDF=DCDF+DPDF IF(IX.EQ.2)GOTO9000 DX=3.0D0 CALL CONPDF(DX,DTHETA,DM,ICOND2,DPDF) DCDF=DCDF+DPDF IF(IX.EQ.3)GOTO9000 DPDFSV=DPDF ENDIF C DO100I=4,IX DX=DBLE(I) DTERM1=DLOG(DTHETA) + (DM-1.0D0)*DLOG(1.0D0 - DTHETA) DTERM2=DLOG((DM-1.0D0)*(DX-1.0D0) + 1.0D0) - DLOG(DX-1.0D0) DTERM3=DTERM1 + DTERM2 DSUM=0.0D0 DO200J=1,I-2 DSUM=DSUM + DLOG(1.0D0 + DM/(DM*DX - DM - DBLE(J))) 200 CONTINUE IF(DPDFSV.GT.0.0D0)THEN DPDF=DEXP(DTERM3 + DSUM + DLOG(DPDFSV)) ELSE GOTO9000 ENDIF DCDF=DCDF + DPDF DPDFSV=DPDF 100 CONTINUE C 9000 CONTINUE RETURN END DOUBLE PRECISION FUNCTION CONFUN(DM) C C PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE C CONSUL MEAN AND ONES FREQUENCY EQUATION. C C THE MEAN AND ONES FREQUENCY ESTIMATE OF MU IS: C C MUHAT = XBAR C C THE ESTIMATE OF M IS THEN THE SOLUTION OF THE C EQUATION C C M*LOG(1 - (XBAR-1)/(M*XBAR)) - LOG(N1/N) = 0 C C CALLED BY DFZERO ROUTINE FOR SOLVING A NONLINEAR C UNIVARIATE EQUATION. C EXAMPLE--CONSUL MAXIMUM LIKELIHOOD Y C REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY C DISTRIBUTIONS", BIRKHAUSER, CHAPTER 8. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBUG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/8 C ORIGINAL VERSION--AUGUST 2006. C C--------------------------------------------------------------------- C DOUBLE PRECISION DM C DOUBLE PRECISION XBAR DOUBLE PRECISION S2 DOUBLE PRECISION F1FREQ COMMON/CONCOM/XBAR,S2,F1FREQ,MAXROW,N C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C CONFUN=DM*DLOG(1.0D0 - (XBAR-1.0D0)/(DM*XBAR)) - DLOG(F1FREQ) C RETURN END SUBROUTINE CONFU2(N,XPAR,FVEC,IFLAG,Y,K) C C PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE C CONSUL MAXIMUM LIKELIHOOD EQUATION. C C THE MAXIMUM LIKELIHOOD FREQUENCY ESTIMATE OF MU IS: C C MUHAT = XBAR C C THE ESTIMATE OF M IS THEN THE SOLUTION OF THE C EQUATION C C LOG(1 - (XBAR-1)/(M*XBAR)) + (1/(N*XBAR))* C SUM[X=2 to k][SUM[i=0 to X-2][X*N(x)/(M*X-i)]] = 0 C C THIS ROUTINE ASSUMES THE DATA IS IN THE FORM C C X(I) FREQ(I) C C CALLED BY DNSQE ROUTINE FOR SOLVING SIMULTANEOUS C NONLINEAR EQUATIONS. NOTE THAT THE CALLING SEQUENCE C DID NOT ACCOMODATE A DATA ARRAY (AND ASSCIATED NUMBER OF C OBSERVATIONS), SO THESE WERE ADDED TO THE CALL LIST. C SINCE DNSQE ONLY PASSES ONE ARRAY, WE SPLIT INTO C TWO PARTS: 1 - MAXNXT/2 ARE THE FREQUENCIES WHILE C (MAXNXT/2 + 1) - MAXNXT ARE THE CLASS VALUES (I.E., C THE X). C EXAMPLE--CONSUL MAXIMUM LIKELIHOOD Y C REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY C DISTRIBUTIONS", BIRKHAUSER, CHAPTER 8. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBUG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/8 C ORIGINAL VERSION--AUGUST 2006. C C--------------------------------------------------------------------- C DOUBLE PRECISION XPAR(*) DOUBLE PRECISION FVEC(*) REAL Y(*) C DOUBLE PRECISION DM DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DSUM1 DOUBLE PRECISION DN DOUBLE PRECISION DX DOUBLE PRECISION DFREQ C DOUBLE PRECISION XBAR DOUBLE PRECISION S2 DOUBLE PRECISION F1FREQ COMMON/CONCOM/XBAR,S2,F1FREQ,MAXROW,NTOT C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C DM=XPAR(1) DN=DBLE(NTOT) IINDX=MAXROW/2 C DTERM1=(DM*XBAR - XBAR + 1.0D0)/(DM*XBAR) DTERM2=1.0D0/(DN*XBAR) C DSUM1=0.0D0 DO100I=2,K DX=DBLE(Y(IINDX+I)) DFREQ=Y(I) DO200J=0,I-2 DSUM1=DSUM1 + DX*DFREQ/(DM*DX - DBLE(J)) 200 CONTINUE 100 CONTINUE C DTERM3=DTERM2*DSUM1 FVEC(1)=DTERM1 - DEXP(-DTERM3) CCCCC FVEC(1)=DTERM1 + DTERM2*DSUM1 C RETURN END SUBROUTINE CONPDF(DX,DSHAPE,DM,ICONDF,DPDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY MASS C FUNCTION VALUE FOR THE CONSUL DISTRIBUTION WITH SHAPE C PARAMETERS THETA AND M. THIS DISTRIBUTION IS C DEFINED FOR ALL INTEGER X >= 1. C C THIS DISTRIBUTION REDUCES TO THE GEOMETRIC C DISTRIBUTION WHEN M = 1. FOR THIS REASON, IT C SOMETIMES REFERRED TO AS THE GENERALIZED GEOMETRIC C DISTRIBUTION. NOTE THAT THIS DISTRIBUTION HAS A C SIMILAR FORM TO THE GEETA DISTRIBUTION. C C THE PROBABILITY MASS FUNCTION IS: C p(X;THETA,M)= C (M*X X-1)*THETA**(X-1)*(1-THETA)**(M*X-X+1)/X C X = 1, 2, 3, ,... C 0 < THETA < 1; 1 <= M < 1/THETA C C THE MEAN AND VARIANCE ARE: C C MEAN = 1/(1-THETA*M) C VARIANCE = M*THETA*(1-THETA)/ C (1-THETA*M)**3 C C THIS DISTRIBUTION IS SOMETIMES PARAMETERIZED USING C THE MEAN (MU) INSTEAD OF THETA. THIS RESULTS IN C THE PROBABILITY MASS FUNCTION: C p(X;MU,M)= C (M*X X-1)*((MU-1)/(M*MU))**(X-1)* C (1 - (M-1)/(M*MU))**(M*X-X+1)/X C X = 1, 2, 3, ,... C MU >= 1; M > 1 C NOTE THAT THE RELATION IS: C C THETA=(MU-1)/(M*MU) C C THE MEAN AND VARIANCE BECOME: C C MEAN = MU C VARIANCE = MU*(MU-1)*(M*MU-MU+1)/M C C INPUT ARGUMENTS--DX = THE DOUBLE PRECISION VALUE AT C WHICH THE PROBABILITY MASS C FUNCTION IS TO BE EVALUATED. C X SHOULD BE A NON-NEGATIVE INTEGER. C --DSHAPE = THE FIRST SHAPE PARAMETER C (EITHER THETA OR MU) C --DM = THE SECOND SHAPE PARAMETER C OUTPUT ARGUMENTS--DPDF = THE DOUBLE PRECISION PROBABILITY MASS C FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION PROBABILITY MASS FUNCTION VALUE C PDF FOR THE CONSUL DISTRIBUTION WITH SHAPE PARAMETERS C THETA (OR MU) AND M C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE A POSITIVE INTEGER C --0 < THETA < 1; 1 < M < 1/THETA C --MU >= 1; M > 1 C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY C DISTRIBUTIONS", BIRKHAUSER, CHAPTER 8. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/8 C ORIGINAL VERSION--AUGUST 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DSHAPE DOUBLE PRECISION DM DOUBLE PRECISION DPDF C DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTERM4 DOUBLE PRECISION DTERM5 DOUBLE PRECISION DTERM6 DOUBLE PRECISION DTHETA DOUBLE PRECISION DMU DOUBLE PRECISION DLNGAM C CHARACTER*4 ICONDF C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(ICONDF.EQ.'THET')THEN DTHETA=DSHAPE ELSE DMU=DSHAPE ENDIF C IX=INT(DX+0.5D0) IF(IX.LT.1)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DX CALL DPWRST('XXX','BUG ') DPDF=0.0D0 GOTO9000 ENDIF 4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO CONPDF IS LESS ', 1'THAN 1') C IF(ICONDF.EQ.'THET')THEN IF(DTHETA.LE.0.0D0 .OR. DTHETA.GE.1.0D0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DTHETA CALL DPWRST('XXX','BUG ') DPDF=0.0 GOTO9000 ENDIF 15 FORMAT('***** ERROR--THE SECOND ARGUMENT TO CONPDF IS NOT ', 1 'IN THE INTERVAL (0,1)') C IF(DM.LT.1.0D0 .OR. DM.GE.1.0D0/DTHETA)THEN WRITE(ICOUT,25)1.0D0/DTHETA CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DM CALL DPWRST('XXX','BUG ') DPDF=0.0 GOTO9000 ENDIF 25 FORMAT('***** ERROR--THE THIRD ARGUMENT TO CONPDF IS NOT ', 1 'IN THE INTERVAL (1,',G15.7,')') ELSE IF(DMU.LT.1.0D0)THEN WRITE(ICOUT,35) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DMU CALL DPWRST('XXX','BUG ') DPDF=0.0 GOTO9000 ENDIF 35 FORMAT('***** ERROR--THE SECOND ARGUMENT TO CONPDF IS ', 1 'LESS THAN 1') C IF(DM.LT.1.0D0)THEN WRITE(ICOUT,38) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DM CALL DPWRST('XXX','BUG ') DPDF=0.0 GOTO9000 ENDIF 38 FORMAT('***** ERROR--THE THIRD ARGUMENT TO CONPDF IS ', 1 'LESS THAN 1') ENDIF C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) C DX=DBLE(IX) C IF(ICONDF.EQ.'THET')THEN DTERM1=DLNGAM(DM*DX+1.0D0) + (DX-1.0D0)*DLOG(DTHETA) + 1 (DM*DX-DX+1.0D0)*DLOG(1.0D0 - DTHETA) DTERM2=DLNGAM(DX) + DLNGAM(DM*DX-DX+2.0D0) DTERM3=DLOG(DX) DTERM4=DTERM1 - DTERM2 - DTERM3 DPDF=DEXP(DTERM4) ELSE DTERM1=-DLOG(DX) DTERM2=DLNGAM(DM*DX+1.0D0) DTERM3=-DLNGAM(DX) - DLNGAM(DM*DX-DX+2.0D0) DTERM4=(DX-1.0D0)*(DLOG(DMU-1.0D0) - DLOG(DM) - DLOG(DMU)) DTERM5=(DM*DX-DX+1.0D0)*DLOG(1.0D0 - (DMU-1.0D0)/(DM*DMU)) DTERM6=DTERM1 + DTERM2 + DTERM3 + DTERM4 + DTERM5 DPDF=DEXP(DTERM6) ENDIF C 9000 CONTINUE RETURN END SUBROUTINE CONPPF(DP,DSHAPE,DM,ICONDF,DPPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE CONSUL DISTRIBUTION WITH SHAPE C PARAMETERS THETA AND M. THIS DISTRIBUTION IS C DEFINED FOR ALL INTEGER X >= 1. C C THIS DISTRIBUTION REDUCES TO THE GEOMETRIC C DISTRIBUTION WHEN M = 1. FOR THIS REASON, IT C SOMETIMES REFERRED TO AS THE GENERALIZED GEOMETRIC C DISTRIBUTION. NOTE THAT THIS DISTRIBUTION HAS A C SIMILAR FORM TO THE GEETA DISTRIBUTION. C C THE PROBABILITY MASS FUNCTION IS: C p(X;THETA,M)= C (M*X X-1)*THETA**(X-1)*(1-THETA)**(M*X-X+1)/X C X = 1, 2, 3, ,... C 0 < THETA < 1; 1 <= M < 1/THETA C C A RECURRENCE RELATION FOR THE CDF FUNCTION IS C C P(X;THETA,M) = {(M-1)*(X-1)+1}/(X-1)}* C THETA*(1-TYHETA)**(M-1)* C PROD[i=1 to X-2][(1 + M/(M*X-M-i)]* C P(X-1;THETA,M) C C THIS DISTRIBUTION IS SOMETIMES PARAMETERIZED USING C THE MEAN (MU) INSTEAD OF THETA. THIS RESULTS IN C THE PROBABILITY MASS FUNCTION: C p(X;MU,M)= C (M*X X-1)*((MU-1)/(M*MU))**(X-1)* C (1 - (M-1)/(M*MU))**(M*X-X+1)/X C X = 1, 2, 3, ,... C MU >= 1; M > 1 C NOTE THAT THE RELATION IS: C C THETA=(MU-1)/(M*MU) C C THE PERCENT POINT FUNCTION IS COMPUTED BY SUMMING C THE CUMULATIVE DISTRIBUTION UNTIL THE APPROPRIATE C PROBABILITY IS REACHED. C C INPUT ARGUMENTS--DP = THE DOUBLE PRECISION VALUE AT C WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C --DSHAPE = THE FIRST SHAPE PARAMETER C (EITHER THETA OR MU) C --DM = THE SECOND SHAPE PARAMETER C OUTPUT ARGUMENTS--DPPF = THE DOUBLE PRECISION PERCENT POINT C FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION PERCENT POINT FUNCTION C VALUE PPF FOR THE CONSUL DISTRIBUTION WITH SHAPE C PARAMETERS THETA (OR MU) AND M C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE A POSITIVE INTEGER C --0 < THETA < 1; 1 < M < 1/THETA C --MU >= 1; M > 1 C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY C DISTRIBUTIONS", BIRKHAUSER, CHAPTER 8. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/8 C ORIGINAL VERSION--AUGUST 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DP DOUBLE PRECISION DPPF DOUBLE PRECISION DX DOUBLE PRECISION DSHAPE DOUBLE PRECISION DM DOUBLE PRECISION DCDF DOUBLE PRECISION DPDF DOUBLE PRECISION DPDFSV C DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTHETA DOUBLE PRECISION DMU DOUBLE PRECISION DSUM C CHARACTER*4 ICONDF CHARACTER*4 ICOND2 C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(ICONDF.EQ.'THET')THEN DTHETA=DSHAPE ELSE DMU=DSHAPE DTHETA=(DMU-1.0D0)/(DM*DMU) ENDIF C IF(DP.LT.0.0D0 .OR. DP.GE.1.0D0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DP CALL DPWRST('XXX','BUG ') DPPF=0.0D0 GOTO9000 ENDIF 4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO GETPPF IS OUTSIDE ', 1'THE (0,1] INTERVAL') C IF(ICONDF.EQ.'THET')THEN IF(DTHETA.LE.0.0D0 .OR. DTHETA.GE.1.0D0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DTHETA CALL DPWRST('XXX','BUG ') DPPF=0.0 GOTO9000 ENDIF 15 FORMAT('***** ERROR--THE SECOND ARGUMENT TO CONPPF IS NOT ', 1 'IN THE INTERVAL (0,1)') C IF(DM.LT.1.0D0 .OR. DM.GE.1.0D0/DTHETA)THEN WRITE(ICOUT,25)1.0D0/DTHETA CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DM CALL DPWRST('XXX','BUG ') DPPF=0.0 GOTO9000 ENDIF 25 FORMAT('***** ERROR--THE THIRD ARGUMENT TO CONPPF IS NOT ', 1 'IN THE INTERVAL (1,',G15.7,')') ELSE IF(DMU.LT.1.0D0)THEN WRITE(ICOUT,35) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DMU CALL DPWRST('XXX','BUG ') DPPF=0.0 GOTO9000 ENDIF 35 FORMAT('***** ERROR--THE SECOND ARGUMENT TO CONPPF IS ', 1 'LESS THAN 1') C IF(DM.LT.1.0D0)THEN WRITE(ICOUT,38) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DM CALL DPWRST('XXX','BUG ') DPPF=0.0 GOTO9000 ENDIF 38 FORMAT('***** ERROR--THE THIRD ARGUMENT TO CONPPF IS ', 1 'LESS THAN 1') ENDIF C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) C DCDF=(1.0D0 - DTHETA)**DM IF(DCDF.GE.DP)THEN DPPF=1.0D0 GOTO9000 ELSE DX=2.0D0 ICOND2='THET' CALL CONPDF(DX,DTHETA,DM,ICOND2,DPDF) DCDF=DCDF+DPDF IF(DCDF.GE.DP)THEN DPPF=2.0D0 GOTO9000 ENDIF DX=3.0D0 CALL CONPDF(DX,DTHETA,DM,ICOND2,DPDF) DCDF=DCDF+DPDF IF(DCDF.GE.DP)THEN DPPF=3.0D0 GOTO9000 ENDIF DPDFSV=DPDF ENDIF C I=3 100 CONTINUE I=I+1 DX=DBLE(I) DTERM1=DLOG(DTHETA) + (DM-1.0D0)*DLOG(1.0D0 - DTHETA) DTERM2=DLOG((DM-1.0D0)*(DX-1.0D0) + 1.0D0) - DLOG(DX-1.0D0) DTERM3=DTERM1 + DTERM2 DSUM=0.0D0 DO200J=1,I-2 DSUM=DSUM + DLOG(1.0D0 + DM/(DM*DX - DM - DBLE(J))) 200 CONTINUE IF(DPDFSV.GT.0.0D0)THEN DPDF=DEXP(DTERM3 + DSUM + DLOG(DPDFSV)) ELSE DPPF=DBLE(I) GOTO9000 ENDIF DCDF=DCDF + DPDF IF(DCDF.GE.DP)THEN DPPF=DBLE(I) GOTO9000 ENDIF DPDFSV=DPDF GOTO100 C 9000 CONTINUE RETURN END SUBROUTINE CONRAN(N,SHAPE,AM,ICONDF,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE CONSUL DISTRIBUTION WITH SHAPE PARAMETERS C THETA OR MU AND AM. C C THE PROBABILITY MASS FUNCTION IS: C p(X;THETA,M)= C (M*X X-1)*THETA**(X-1)*(1-THETA)**(M*X-X+1)/X C X = 1, 2, 3, ,... C 0 < THETA < 1; 1 <= M < 1/THETA C C THE MEAN AND VARIANCE ARE: C C MEAN = 1/(1-THETA*M) C VARIANCE = M*THETA*(1-THETA)/ C (1-THETA*M)**3 C C THIS DISTRIBUTION IS SOMETIMES PARAMETERIZED USING C THE MEAN (MU) INSTEAD OF THETA. THIS RESULTS IN C THE PROBABILITY MASS FUNCTION: C p(X;MU,M)= C (M*X X-1)*((MU-1)/(M*MU))**(X-1)* C (1 - (M-1)/(M*MU))**(M*X-X+1)/X C X = 1, 2, 3, ,... C MU >= 1; M > 1 C NOTE THAT THE RELATION IS: C C THETA=(MU-1)/(M*MU) C C C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --SHAPE = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER. C --AM = THE SINGLE PRECISION VALUE C OF THE SECOND SHAPE PARAMETER. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE CONSUL C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE CONSUL DISTRIBUTION C WITH SHAPE PARAMETERS THETA (OR MU) AND AM. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --0 < THETA < 1, 1 < M < 1/THETA C MU >= 1; M > 1 C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN, CONPPF C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--CONSUL (1990), "CONSUL DISTRIBUTION AND ITS C PROPERTIES", COMMUNICATIONS IN STATISTICS-- C THEORY AND METHODS, 19, PP. 3051-3068. C --CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY C DISTRIBUTIONS", BIRKHAUSER, CHAPTER 8. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/7 C ORIGINAL VERSION--JULY 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C CHARACTER*4 ICONDF C DOUBLE PRECISION DPPF C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF CONSUL RANDOM ', 1 'NUMBERS IS NON-POSITIVE') C IF(ICONDF.EQ.'THET')THEN THETA=SHAPE IF(THETA.LE.0.0 .OR. THETA.GE.1.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,16) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)THETA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 15 FORMAT('***** ERROR--THE THETA PARAMETER FOR THE CONSUL') 16 FORMAT(' RANDOM NUMBERS IS OUTSIDE THE (0,1) INTERVAL') C IF(AM.LT.1.0 .OR. AM.GE.1.0/THETA)THEN WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,26)1.0/THETA CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)AM CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 25 FORMAT('***** ERROR--THE M PARAMETER FOR THE CONSUL') 26 FORMAT(' RANDOM NUMBERS IS OUTSIDE THE (1,',G15.7,') ', 1 'INTERVAL') ELSE AMU=SHAPE IF(AMU.LT.1.0)THEN WRITE(ICOUT,35) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,36) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)AMU CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 35 FORMAT('***** ERROR--THE MU PARAMETER FOR THE CONSUL') 36 FORMAT(' RANDOM NUMBERS IS LESS THAN 1') C IF(AM.LE.1.0)THEN WRITE(ICOUT,38) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,39) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)AM CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 38 FORMAT('***** ERROR--THE M PARAMETER FOR THE CONSUL') 39 FORMAT(' RANDOM NUMBERS IS LESS THAN OR EQUAL TO 1') ENDIF C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C C GENERATE N CONSUL DISTRIBUTION RANDOM NUMBERS USING THE C INVERSION METHOD. C CALL UNIRAN(N,ISEED,X) DO100I=1,N XTEMP=X(I) CALL CONPPF(DBLE(XTEMP),DBLE(SHAPE),DBLE(AM),ICONDF,DPPF) X(I)=REAL(DPPF) 100 CONTINUE C 9000 CONTINUE C RETURN END SUBROUTINE CONV14(ISTRIN,NSTRIN,IA,IB,IWIDTH,IBUGXX,IERROR) C PURPOSE--CONVERT THE FIRST NSTRIN CHARACTERS IF ISTRIN C TO THE FIRST CHARACTERS OF THE CHARACTER*4 ARRAYS C IA AND IB. C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--93.3 C ORIGINAL VERSION--FEBRUARY 1993 C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*80 ISTRIN CHARACTER*4 IA CHARACTER*4 IB CHARACTER*4 IBUGXX CHARACTER*4 IERROR C CHARACTER*4 IC4 C C--------------------------------------------------------------------- C DIMENSION IA(80) DIMENSION IB(80) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IERROR='NO' C IF(IBUGXX.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF CONV14--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGXX,IERROR 52 FORMAT('IBUGXX,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ISTRIN(1:80) 53 FORMAT('ISTRIN(1:80) = ',A80) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)NSTRIN 54 FORMAT('NSTRIN = ',I8) CALL DPWRST('XXX','BUG ') 90 CONTINUE C IWIDTH=NSTRIN IF(1.LE.NSTRIN.AND.NSTRIN.LE.80)THEN DO1000I=1,NSTRIN IC4=' ' IC4(1:1)=ISTRIN(I:I) IA(I)=IC4 IB(I)=IC4 1000 CONTINUE IERROR='NO' ELSE IERROR='YES' ENDIF C IF(IBUGXX.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF CONV14--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGXX,IERROR 9012 FORMAT('IBUGXX,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ISTRIN(1:80) 9013 FORMAT('ISTRIN(1:80) = ',A80) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NSTRIN,IWIDTH 9014 FORMAT('NSTRIN,IWIDTH = ',2I8) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN DO9020I=1,IWIDTH WRITE(ICOUT,9021)I,IA(I),IB(I) 9021 FORMAT('I,IA(I),IB(I) = ',I8,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 9020 CONTINUE ENDIF 9090 CONTINUE C RETURN END SUBROUTINE CONVOL(Y1,N1,Y2,N2,NUMVAR,IWRITE,MAXN, 1Y3,N3,IBUGA3,IERROR) C C PURPOSE--COMPUTE CONVOLUTION OF 2 VARIABLES. C NOTE--IF THE FIRST VARIABLE IS Y1(.) C AND THE SECOND VARIABLE IS Y2(.), C THEN THE OUTPUT VARIABLE CONTAINING THE C CONVOLUTION C WILL BE COMPUTED AS FOLLOWS-- C Y3(1) = Y1(1)*Y2(1) C Y3(2) = Y1(1)*Y2(2) + Y1(2)*Y2(1) C Y3(3) = Y1(1)*Y2(3) + Y1(2)*Y2(2) + Y1(3)*Y2(1) C ETC. C NOTE--IT IS NOT PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y3(.) C BEING IDENTICAL (OVERLAYED) ON THE INPUT VECTORS Y1(.) OR Y2(.) C NOTE--Y1 AND Y2 NEED NOT BE THE SAME LENGTH. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--NOVEMBER 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C DIMENSION Y1(*) DIMENSION Y2(*) DIMENSION Y3(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='CONV' ISUBN2='OL ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF CONVOL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N1,N2,NUMVAR,MAXN 53 FORMAT('N1,N2,NUMVAR,MAXN = ',4I8) CALL DPWRST('XXX','BUG ') DO55I=1,N1 WRITE(ICOUT,56)I,Y1(I) 56 FORMAT('I,Y1(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE DO57I=1,N2 WRITE(ICOUT,58)I,Y2(I) 58 FORMAT('I,Y2(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 57 CONTINUE 90 CONTINUE C C ******************************* C ** COMPUTE THE CONVOLUTION ** C ******************************* C ISTEPN='1' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(N1.LE.0)GOTO150 IF(N2.LE.0)GOTO150 I3MIN=2 I3MAX=N1+N2 N3=I3MAX-I3MIN+1 IF(N3.GT.MAXN)GOTO170 C DO100I3=1,N3 Y3(I3)=0.0 100 CONTINUE C DO500I1=1,N1 DO600I2=1,N2 Y1P=Y1(I1) Y2P=Y2(I2) Y3P=Y1P*Y2P IARG=I1+I2-1 Y3(IARG)=Y3(IARG)+Y3P 600 CONTINUE 500 CONTINUE GOTO190 C 150 CONTINUE IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,151) 151 FORMAT('***** ERROR IN CONVOL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,152) 152 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,153) 153 FORMAT(' IN THE VARIABLES FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,154) 154 FORMAT(' THE CONVOLUTION IS TO BE COMPUTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,155) 155 FORMAT(' MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,156) 156 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,157)N1,N2 157 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',2I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO190 C 170 CONTINUE IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,171) 171 FORMAT('***** ERROR IN CONVOL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,172) 172 FORMAT(' THE NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,173) 173 FORMAT(' IN THE RESULTING CONVOLUTION VARIABLE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,175)MAXN 175 FORMAT(' MUST BE LESS THAN OR EQUAL TO ',I8,' .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,176) 176 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,177)N3 177 FORMAT(' THE OUTPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO190 C 190 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE C IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF CONVOL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N1,N2,NUMVAR,MAXN,N3 9013 FORMAT('N1,N2,NUMVAR,MAXN,N3 = ',5I8) CALL DPWRST('XXX','BUG ') DO9015I=1,N3 WRITE(ICOUT,9016)I,Y1(I),Y2(I),Y3(I) 9016 FORMAT('I,Y1(I),Y2(I),Y3(I) = ',I8,3E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE CORR(X,Y,N,IWRITE,XYCORR,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE CORRELATION COEFFICIENT C BETWEEN THE 2 SETS OF DATA IN THE INPUT VECTORS X AND Y. C THE SAMPLE CORRELATION COEFFICIENT WILL BE A SINGLE C PRECISION VALUE CALCULATED AS THE C SUM OF CROSS PRODUCTS DIVIDED BY (N-1). C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C (UNSORTED) OBSERVATIONS C WHICH CONSTITUTE THE FIRST SET C OF DATA. C --Y = THE SINGLE PRECISION VECTOR OF C (UNSORTED) OBSERVATIONS C WHICH CONSTITUTE THE SECOND SET C OF DATA. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X, OR EQUIVALENTLY, C THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR Y. C OUTPUT ARGUMENTS--XYCORR = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE CORRELATION COEFFICIENT C BETWEEN THE 2 SETS OF DATA C IN THE INPUT VECTORS X AND Y. C THIS SINGLE PRECISION VALUE C WILL BE BETWEEN -1.0 AND 1.0 C (INCLUSIVELY). C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE CORRELATION COEFFICIENT BETWEEN THE 2 SETS C OF DATA IN THE INPUT VECTORS X AND Y. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--KENDALL AND STUART, THE ADVANCED THEORY OF C STATISTICS, VOLUME 1, EDITION 2, 1963, PAGES 235-236. C --KENDALL AND STUART, THE ADVANCED THEORY OF C STATISTICS, VOLUME 2, EDITION 1, 1961, PAGES 292-293. C --SNEDECOR AND COCHRAN, STATISTICAL METHODS, C EDITION 6, 1967, PAGES 172-198. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82/7 C ORIGINAL VERSION--APRIL 1979. C UPDATED --JUNE 1979. C UPDATED --JULY 1979. C UPDATED --AUGUST 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DOUBLE PRECISION DN DOUBLE PRECISION DX1 DOUBLE PRECISION DX2 DOUBLE PRECISION DSUM1 DOUBLE PRECISION DSUM2 DOUBLE PRECISION DSUM12 DOUBLE PRECISION DMEAN1 DOUBLE PRECISION DMEAN2 DOUBLE PRECISION DSQRT1 DOUBLE PRECISION DSQRT2 C DIMENSION X(*) DIMENSION Y(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='CORR' ISUBN2=' ' C IERROR='NO' C DN=0.0D0 DMEAN1=0.0D0 DMEAN2=0.0D0 DSUM12=0.0D0 C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF COV--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I),Y(I) 56 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ******************************************* C ** COMPUTE CORRELATION COEFFICIENT ** C ******************************************* C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(N.GE.1)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN COV--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' IN THE VARIABLE FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114) 114 FORMAT(' THE CORRELATION COEFFICIENT IS TO BE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' COMPUTED, MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116) 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,117)N 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C IF(N.EQ.1)GOTO120 GOTO129 120 CONTINUE IF(IWRITE.EQ.'OFF')GOTO129 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** NON-FATAL DIAGNOSTIC IN COV--', 1'THE THIRD INPUT ARGUMENT (N) HAS THE VALUE 1') CALL DPWRST('XXX','BUG ') XYCORR=1.0 GOTO9000 129 CONTINUE C HOLD=X(1) DO135I=2,N IF(X(I).NE.HOLD)GOTO139 135 CONTINUE IF(IWRITE.EQ.'OFF')GOTO139 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,136)HOLD 136 FORMAT('***** NON-FATAL DIAGNOSTIC IN COV--', 1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') XYCORR=1.0 GOTO9000 139 CONTINUE C HOLD=Y(1) DO145I=2,N IF(Y(I).NE.HOLD)GOTO149 145 CONTINUE IF(IWRITE.EQ.'OFF')GOTO149 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,146)HOLD 146 FORMAT('***** NON-FATAL DIAGNOSTIC IN COV--', 1'THE SECOND INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') XYCORR=1.0 GOTO9000 149 CONTINUE C 190 CONTINUE C C ************************************************ C ** STEP 2-- ** C ** COMPUTE THE CORRELATION COEFFICIENT. ** C ************************************************ C DN=N DSUM1=0.0D0 DSUM2=0.0D0 DO200I=1,N DX1=X(I) DX2=Y(I) DSUM1=DSUM1+DX1 DSUM2=DSUM2+DX2 200 CONTINUE DMEAN1=DSUM1/DN DMEAN2=DSUM2/DN C DSUM1=0.0D0 DSUM2=0.0D0 DSUM12=0.0D0 DO300I=1,N DX1=X(I) DX2=Y(I) DSUM1=DSUM1+(DX1-DMEAN1)*(DX1-DMEAN1) DSUM2=DSUM2+(DX2-DMEAN2)*(DX2-DMEAN2) DSUM12=DSUM12+(DX1-DMEAN1)*(DX2-DMEAN2) 300 CONTINUE DSQRT1=0.0 IF(DSUM1.GT.0.0D0)DSQRT1=DSQRT(DSUM1) DSQRT2=0.0 IF(DSUM2.GT.0.0D0)DSQRT2=DSQRT(DSUM2) XYCORR=DSUM12/(DSQRT1*DSQRT2) C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)N,XYCORR 811 FORMAT('THE CORRELATION COEFFICIENT OF THE ',I8, 1' OBSERVATIONS = ',E15.7) CALL DPWRST('XXX','BUG ') 890 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF COV--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N 9013 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)DN,DMEAN1,DMEAN2,DSUM12 9014 FORMAT('DN,DMEAN1,DMEAN2,DSUM12 = ',4D15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XYCORR 9015 FORMAT('XYCORR = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE COSCDF(X,CDF) C C NOTE--COSINE CDF IS: C COSCDF(X) = (PI + X + SIN(X))/(2*PI), -PI<=X<=PI C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--95/4 C ORIGINAL VERSION--APRIL 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA PI/3.1415926535898E0/ C C-----START POINT----------------------------------------------------- C CDF=0.0 IF(X.LT.-PI)THEN CDF=0.0 ELSEIF(X.GT.PI)THEN CDF=1.0 ELSE CDF=(PI + X + SIN(X))/(2*PI) ENDIF C 9999 CONTINUE RETURN END SUBROUTINE COSPDF(X,PDF) C C NOTE--COSINE PDF IS: C COSPDF(X) = (1 + COS(X))/(2*PI), -PI<=X<=PI C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--95/4 C ORIGINAL VERSION--APRIL 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA PI/3.1415926535898E0/ C C-----START POINT----------------------------------------------------- C PDF=0.0 IF(X.LT.-PI .OR. X.GT.PI)THEN WRITE(ICOUT,301) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,302)X CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 301 FORMAT('***** FATAL DIAGNOSTIC--THE INPUT ARGUMENT IS NOT IN 1 THE INTERVAL (-PI,PI).') 302 FORMAT(' IT HAS THE VALUE ',E15.7) C PDF=(1.0 + COS(X))/(2*PI) GOTO9999 C 9999 CONTINUE RETURN END SUBROUTINE COSPPF(P,PPF) C C NOTE--ALGORITHM ADDED APRIL 1995 (ALAN) C USE A BISECTION METHOD C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--95/4 C ORIGINAL VERSION--APRIL 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA PI/3.1415926535898E0/ DATA EPS /1.0E-6/ DATA SIG /1.0E-6/ DATA ZERO /0./ DATA MAXIT /500/ C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LT.0.0.OR.P.GT.1.0)GOTO50 GOTO90 50 WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 RETURN 90 CONTINUE 1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1' COSPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C IERR=0 IC = 0 IF(P.LE.0.0)THEN PPF=-PI GOTO9999 ENDIF IF(P.GE.1.0)THEN PPF=PI GOTO9999 ENDIF C XL = -PI XR = PI FXL = -P FXR = 1.0 - P CCCCC INVALID P EXPLICITLY CHECKED FOR EARLIER. IF(FXL*FXR .GT. ZERO)GOTO50 C C BISECTION METHOD C 105 CONTINUE X = (XL+XR)*0.5 CALL COSCDF(X,CDF) P1=CDF PPF=X FCS = P1 - P IF(FCS*FXL.GT.ZERO)GOTO110 XR = X FXR = FCS GOTO115 110 CONTINUE XL = X FXL = FCS 115 CONTINUE XRML = XR - XL IF(XRML.LE.SIG .AND. ABS(FCS).LE.EPS)GOTO9999 IC = IC + 1 IF(IC.LE.MAXIT)GOTO105 WRITE(ICOUT,130) CALL DPWRST('XXX','BUG ') 130 FORMAT('***** FATAL ERROR--COSPPF ROUTINE DID NOT CONVERGE. ***') GOTO9999 C 9999 CONTINUE RETURN END SUBROUTINE COSRAN(N,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE COSINE DISTRIBUTION C F(X) = 0.5*EXP(-ABS(X)). C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE COSINE DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--2001/10 C ORIGINAL VERSION--OCTOBER 2001. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)GOTO50 GOTO90 50 WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') RETURN 90 CONTINUE 5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1'COSRAN SUBROUTINE IS NON-POSITIVE *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C C GENERATE N UNIFORM (0,1) RANDOM NUMBERS; C CALL UNIRAN(N,ISEED,X) C C GENERATE N COSINE RANDOM NUMBERS C USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. C DO100I=1,N CALL COSPPF(X(I),XTEMP) X(I)=XTEMP 100 CONTINUE C RETURN END SUBROUTINE COSTRA(Y1,N1,IWRITE,Y2,N2,IBUGA3,IERROR) C C PURPOSE--COMPUTE COSINE TRANSFORM OF A VARIABLE-- C = THE COEFFICIENTS OF THE COSINE TERM C IN THE FINITE FOURIER RESPRESENTATION OF THE DATA IN Y1. C Y2(1) = A0 = MEAN C Y2(2) = A1 C Y2(3) = A2 C ETC. C NOTE--IT IS NOT PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y2(.) C BEING IDENTICAL TO THE INPUT VECTOR Y1(.). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85/1 C ORIGINAL VERSION--DECEMBER 1984. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C-----DOUBLE PRECISION STATEMENTS FOR NON-COMMON VARIABLES------------------- C DOUBLE PRECISION DPI DOUBLE PRECISION DN1 DOUBLE PRECISION DDEL DOUBLE PRECISION DI DOUBLE PRECISION DSUM DOUBLE PRECISION DK DOUBLE PRECISION DOMEGA DOUBLE PRECISION DY1K C C--------------------------------------------------------------------- C DIMENSION Y1(*) DIMENSION Y2(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='COST' ISUBN2='RA ' C IERROR='NO' C N1HALF=(-999) IMAX=(-999) IEVODD=(-999) DDEL=(-999.0D0) DN1=(-999.0D0) C DN1=N1 C DPI=3.14159265358979D0 C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF COSTRA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N1 53 FORMAT('N1 = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N1 WRITE(ICOUT,56)I,Y1(I) 56 FORMAT('I,Y1(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C *********************************** C ** COMPUTE COSINE TRANSFORM. ** C *********************************** C IF(N1.LT.1)GOTO1100 GOTO1190 C 1100 CONTINUE IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1151) 1151 FORMAT('***** ERROR IN COSTRA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1152) 1152 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1153) 1153 FORMAT(' IN THE VARIABLE FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1154) 1154 FORMAT(' THE COSINE TRANSFORM IS TO BE COMPUTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1155) 1155 FORMAT(' MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1156) 1156 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1157)N1 1157 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 C 1190 CONTINUE C N1HALF=N1/2 N1HALP=N1HALF+1 IMAX=N1HALP IEVODD=N1-2*(N1/2) DDEL=(DN1+1.0D0)/2.0D0 IF(IEVODD.EQ.0)DDEL=(DN1+2.0D0)/2.0D0 C J=0 J=J+1 DSUM=0.0 DO1205K=1,N1 DY1K=Y1(K) DSUM=DSUM+DY1K 1205 CONTINUE COEF=DSUM/DN1 Y2(J)=COEF C DO1210IP1=2,IMAX J=J+1 I=IP1-1 DI=I CCCCC FREQI=DI/DN1 DSUM=0.0D0 C DO1220K=1,N1 DK=K DOMEGA=2.0*DPI*(DI/DN1) DY1K=Y1(K) DSUM=DSUM+DY1K*DCOS(DOMEGA*(DK-DDEL)) 1220 CONTINUE COEF=DSUM/DN1 IF(IBUGA3.EQ.'ON')WRITE(ICOUT,1221)J,I,DN1,DI,COEF 1221 FORMAT('J,I,DN1,DI,COEF = ',I8,I8,2D15.7,E15.7) IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ') C Y2(J)=COEF C 1210 CONTINUE C N2=J C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE C IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF COSTRA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N1,N2,N1HALF,IMAX,IEVODD,DDEL 9013 FORMAT('N1,N2,N1HALF,IMAX,IEVODD,DDEL = ',5I8,D15.7) CALL DPWRST('XXX','BUG ') DO9015I=1,N1 WRITE(ICOUT,9016)I,Y1(I),Y2(I) 9016 FORMAT('I,Y1(I),Y2(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE COV(X,Y,N,IWRITE,XYCOV,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE COVARIANCE COEFFICIENT C BETWEEN THE 2 SETS OF DATA IN THE INPUT VECTORS X AND Y. C THE SAMPLE COVARIANCE COEFFICIENT WILL BE A SINGLE C PRECISION VALUE CALCULATED AS THE C SUM OF CROSS PRODUCTS DIVIDED BY (N-1). C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C (UNSORTED) OBSERVATIONS C WHICH CONSTITUTE THE FIRST SET C OF DATA. C --Y = THE SINGLE PRECISION VECTOR OF C (UNSORTED) OBSERVATIONS C WHICH CONSTITUTE THE SECOND SET C OF DATA. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X, OR EQUIVALENTLY, C THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR Y. C OUTPUT ARGUMENTS--XYCOV = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE COVARIANCE COEFFICIENT C BETWEEN THE 2 SETS OF DATA C IN THE INPUT VECTORS X AND Y. C THIS SINGLE PRECISION VALUE C WILL BE BETWEEN -1.0 AND 1.0 C (INCLUSIVELY). C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE COVARIANCE COEFFICIENT BETWEEN THE 2 SETS C OF DATA IN THE INPUT VECTORS X AND Y. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--KENDALL AND STUART, THE ADVANCED THEORY OF C STATISTICS, VOLUME 1, EDITION 2, 1963, PAGES 235-236. C --KENDALL AND STUART, THE ADVANCED THEORY OF C STATISTICS, VOLUME 2, EDITION 1, 1961, PAGES 292-293. C --SNEDECOR AND COCHRAN, STATISTICAL METHODS, C EDITION 6, 1967, PAGES 172-198. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82/7 C ORIGINAL VERSION--APRIL 1979. C UPDATED --JUNE 1979. C UPDATED --JULY 1979. C UPDATED --AUGUST 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DOUBLE PRECISION DN DOUBLE PRECISION DX1 DOUBLE PRECISION DX2 DOUBLE PRECISION DSUM1 DOUBLE PRECISION DSUM2 DOUBLE PRECISION DSUM12 DOUBLE PRECISION DMEAN1 DOUBLE PRECISION DMEAN2 C DIMENSION X(*) DIMENSION Y(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='COV ' ISUBN2=' ' C IERROR='NO' C DN=0.0D0 DMEAN1=0.0D0 DMEAN2=0.0D0 DSUM12=0.0D0 C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF COV--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I),Y(I) 56 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ******************************************* C ** COMPUTE COVARIANCE COEFFICIENT ** C ******************************************* C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(N.GE.1)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN COV--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' IN THE VARIABLE FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114) 114 FORMAT(' THE COVARIANCE COEFFICIENT IS TO BE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' COMPUTED, MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116) 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,117)N 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C IF(N.EQ.1)GOTO120 GOTO129 120 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** NON-FATAL DIAGNOSTIC IN COV--', 1'THE THIRD INPUT ARGUMENT (N) HAS THE VALUE 1') CALL DPWRST('XXX','BUG ') XYCOV=0.0 GOTO9000 129 CONTINUE C HOLD=X(1) DO135I=2,N IF(X(I).NE.HOLD)GOTO139 135 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,136)HOLD 136 FORMAT('***** NON-FATAL DIAGNOSTIC IN COV--', 1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') XYCOV=0.0 GOTO9000 139 CONTINUE C HOLD=Y(1) DO145I=2,N IF(Y(I).NE.HOLD)GOTO149 145 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,146)HOLD 146 FORMAT('***** NON-FATAL DIAGNOSTIC IN COV--', 1'THE SECOND INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') XYCOV=0.0 GOTO9000 149 CONTINUE C 190 CONTINUE C C ************************************************ C ** STEP 2-- ** C ** COMPUTE THE COVARIANCE COEFFICIENT. ** C ************************************************ C DN=N DSUM1=0.0D0 DSUM2=0.0D0 DO200I=1,N DX1=X(I) DX2=Y(I) DSUM1=DSUM1+DX1 DSUM2=DSUM2+DX2 200 CONTINUE DMEAN1=DSUM1/DN DMEAN2=DSUM2/DN C DSUM12=0.0D0 DO300I=1,N DX1=X(I) DX2=Y(I) DSUM12=DSUM12+(DX1-DMEAN1)*(DX2-DMEAN2) 300 CONTINUE XYCOV=DSUM12/(DN-1.0D0) C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)N,XYCOV 811 FORMAT('THE COVARIANCE COEFFICIENT OF THE ',I8, 1' OBSERVATIONS = ',E15.7) CALL DPWRST('XXX','BUG ') 890 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF COV--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N 9013 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)DN,DMEAN1,DMEAN2,DSUM12 9014 FORMAT('DN,DMEAN1,DMEAN2,DSUM12 = ',4D15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XYCOV 9015 FORMAT('XYCOV = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE COVMAT(YM1,YM9,DMEAN,MAXROM,NR,NC,MAXVAR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE VARIANCE-COVARIANCE C MATRIX. THIS IS A UTILITY ROUTINE, ERROR CHECKING C PERFORMED BY CALLING ROUTINES. C INPUT ARGUMENTS--YM1 = THE SINGLE PRECISION MATRIX OF C OBSERVATIONS C --NR = THE INTEGER NUMBER OF ROWS C --NC = THE INTEGER NUMBER OF COLUMNS C --MAXROM = LEADING DIMENSION OF XMAT, COVMAT C OUTPUT ARGUMENTS--YM9 = THE SINGLE PRECISION MATRIX WHICH C WILL CONTAIN THE COVARIANCE MATRIX C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE VARIANCE-COVARIANCE MATRIX. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--2003/2 C ORIGINAL VERSION--FEBRUARY 2003. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C DOUBLE PRECISION DSUM1 DOUBLE PRECISION DYM1 DOUBLE PRECISION DDENOM DOUBLE PRECISION DNR DOUBLE PRECISION DDEL1 DOUBLE PRECISION DDEL2 DOUBLE PRECISION DCOV DOUBLE PRECISION DMEAN(*) C DIMENSION YM1(MAXROM,NC) DIMENSION YM9(MAXVAR,MAXVAR) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C DNR=DBLE(NR) C DO5111J=1,NC DSUM1=0.0D0 DO5112I=1,NR DYM1=YM1(I,J) DSUM1=DSUM1+DYM1 5112 CONTINUE DMEAN(J)=-9999.0D0 DDENOM=DNR IF(DDENOM.NE.0.0D0)DMEAN(J)=REAL(DSUM1/DDENOM) 5111 CONTINUE C DO5121J=1,NC DO5122K=J,NC DSUM1=0.0D0 DO5123I=1,NR DYM1=YM1(I,J) DYM2=YM1(I,K) DDEL1=DYM1-DMEAN(J) DDEL2=DYM2-DMEAN(K) DSUM1=DSUM1+DDEL1*DDEL2 5123 CONTINUE DCOV=-9999.0D0 DDENOM=DNR-1.0D0 IF(DDENOM.NE.0.0D0)DCOV=DSUM1/DDENOM YM9(J,K)=DCOV YM9(K,J)=DCOV 5122 CONTINUE 5121 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE C RETURN END SUBROUTINE CP(X,N,ENGLSL,ENGUSL,IWRITE,XCP,XLCL,XUCL, 1 IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE CP (PROCESS CAPABILITY INDEX) C OF THE DATA IN THE INPUT VECTOR X. C CP = (ENGUSL - ENGLSL) / 6*S C NOTE--IF THE TARGET VALUE IS MIDWAY BETWEEN C ENGUSL AND ENGLSL, THEN AN ALTERNATIVE C EQUIVALENT DEFINITION FOR CP IS C CP = (ENGUSL-TARGET) / 3*S C NOTE ONLY--CP IS A MEASURE OF PROCESS PRECISION-- C IS CONTAINS NO BIAS INFORMATION. C NOTE--THE CP INDEX IS A MEASURE WHICH TAKES ON C THE VALUES 0 TO INFINITY. C A GOOD PROCESS YIELDS VALUES OF CP C WHICH ARE LARGE (ABOVE 2); C VALUES OF CP FROM 0.5 TO 1.0 ARE TYPICAL. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C --ENGLSL = LOWER (ENGINEERING) SPEC LIMIT C --ENGUSL = UPPER (ENGINEERING) SPEC LIMIT C OUTPUT ARGUMENTS--CP = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE CP C --XLCL = LOWER 95% CONFIDENCE INTERVAL C --XUCL = UPPER 95% CONFIDENCE INTERVAL C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE CP INDEX C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--R&M 2000 AIRFORCE MANUAL C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--89.5 C ORIGINAL VERSION--MAY 1989. C UPDATED --SEPTEMBER 1990. REVERSE INPUT ARGS C UPDATED --APRIL 2001. ADD LOWER AND UPPER 95% C CONFIDENCE INTERVAL. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DOUBLE PRECISION DN DOUBLE PRECISION DX DOUBLE PRECISION DSUM DOUBLE PRECISION DMEAN DOUBLE PRECISION DVAR DOUBLE PRECISION DSD C DOUBLE PRECISION DUSL DOUBLE PRECISION DLSL DOUBLE PRECISION DNUM DOUBLE PRECISION DDEN DOUBLE PRECISION DCP C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='CP ' ISUBN2=' ' C IERROR='NO' C DMEAN=0.0D0 C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF CP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)ENGUSL,ENGLSL 54 FORMAT('ENGUSL,ENGLSL = ',2E15.7) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ******************************************** C ** COMPUTE PROCESS CAPABILITY INDEX CP ** C ******************************************** C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(N.GE.1)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN CP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' IN THE VARIABLE FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114) 114 FORMAT(' THE CP STATISTIC IS TO BE COMPUTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116) 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,117)N 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C IF(N.EQ.1)GOTO120 GOTO129 120 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,121) CC121 FORMAT('***** NON-FATAL DIAGNOSTIC IN CP--', CCCCC CALL DPWRST('XXX','BUG ') CCCCC1'THE SECOND INPUT ARGUMENT (N) HAS THE VALUE 1') XSD=0.0 GOTO9000 129 CONTINUE C HOLD=X(1) DO135I=2,N IF(X(I).NE.HOLD)GOTO139 135 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,136)HOLD CC136 FORMAT('***** NON-FATAL DIAGNOSTIC IN CP--', CCCCC CALL DPWRST('XXX','BUG ') CCCCC1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) XSD=0.0 GOTO9000 139 CONTINUE C 190 CONTINUE C C *************************************** C ** STEP 2-- ** C ** COMPUTE THE STANDARD DEVIATION. ** C *************************************** C DN=N DSUM=0.0D0 DO200I=1,N DX=X(I) DSUM=DSUM+DX 200 CONTINUE DMEAN=DSUM/DN C DSUM=0.0D0 DO300I=1,N DX=X(I) DSUM=DSUM+(DX-DMEAN)**2 300 CONTINUE DVAR=DSUM/(DN-1.0D0) DSD=0.0D0 IF(DVAR.GT.0.0D0)DSD=DSQRT(DVAR) XSD=DSD C C ************************************************** C ** STEP 3-- ** C ** COMPUTE THE CP RATIO ** C ************************************************** C DUSL=ENGUSL DLSL=ENGLSL C DNUM=DUSL-DLSL IF(DNUM.LE.0.0D0)DNUM=0.0D0 C DDEN=6.0*DSD C DCP=0.0 IF(DDEN.GT.0.0D0)DCP=DNUM/DDEN XCP=DCP C XLCL=0.0 XUCL=0.0 AN=REAL(N) NV=N-1 AV=REAL(NV) P=0.975 CALL CHSPPF(P,NV,PPF) IF((PPF/AV).GT.0.0)XUCL=XCP*SQRT(PPF/AV) P=0.025 CALL CHSPPF(P,NV,PPF) IF((PPF/AV).GT.0.0)XLCL=XCP*SQRT(PPF/AV) C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)N,XCP 811 FORMAT('THE CP OF THE ',I8,' OBSERVATIONS = ', 1E15.7) CALL DPWRST('XXX','BUG ') 890 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF CP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N 9013 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)DMEAN 9014 FORMAT('DMEAN = ',D15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)DSD 9015 FORMAT('DSD = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)DUSL,DLSL 9016 FORMAT('DUSL,DLSL = ',2D15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)DNUM,DDEN,DCP,XCP 9017 FORMAT('DNUM,DDEN,DCP,XCP = ',3D15.7,E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE CPEVL(N,M,A,Z,C,B,KBD) C***BEGIN PROLOGUE CPEVL C***REFER TO CPZERO C C Evaluate a complex polynomial and its derivatives. C Optionally compute error bounds for these values. C C INPUT... C N = Degree of the polynomial C M = Number of derivatives to be calculated, C M=0 evaluates only the function C M=1 evaluates the function and first derivative, etc. C if M .GT. N+1 function and all N derivatives will be C calculated. C A = Complex vector containing the N+1 coefficients of polynomial C A(I)= coefficient of Z**(N+1-I) C Z = Complex point at which the evaluation is to take place. C C = Array of 2(M+1) words into which values are placed. C B = Array of 2(M+1) words only needed if bounds are to be C calculated. It is not used otherwise. C KBD = A logical variable, e.g. .TRUE. or .FALSE. which is C to be set .TRUE. if bounds are to be computed. C C OUTPUT... C C = C(I+1) contains the complex value of the I-th C derivative at Z, I=0,...,M C B = B(I) contains the bounds on the real and imaginary parts C of C(I) if they were requested. C***ROUTINES CALLED I1MACH C***END PROLOGUE CPEVL C COMPLEX A(1),C(1),Z,CI,CIM1,B(1),BI,BIM1,T,ZA,Q LOGICAL KBD C INCLUDE 'DPCOMC.INC' C DATA NBITS /0/ ZA(Q)=CMPLX(ABS(REAL(Q)),ABS(AIMAG(Q))) C***FIRST EXECUTABLE STATEMENT CPEVL IF ( NBITS .EQ. 0 ) NBITS = I1MACH (11) D1=2.**(1-NBITS) NP1=N+1 DO 1 J=1,NP1 CI=0.0 CIM1=A(J) BI=0.0 BIM1=0.0 MINI=MIN0(M+1,N+2-J) DO 1 I=1,MINI IF(J .NE. 1) CI=C(I) IF(I .NE. 1) CIM1=C(I-1) C(I)=CIM1+Z*CI IF(.NOT. KBD) GO TO 1 IF(J .NE. 1) BI=B(I) IF(I .NE. 1) BIM1=B(I-1) T=BI+(3.*D1+4.*D1*D1)*ZA(CI) R=REAL(ZA(Z)*CMPLX(REAL(T),-AIMAG(T))) S=AIMAG(ZA(Z)*T) B(I)=(1.+8.*D1)*(BIM1+D1*ZA(CIM1)+CMPLX(R,S)) IF(J .EQ. 1) B(I)=0.0 1 CONTINUE RETURN END SUBROUTINE CPK(X,N,ENGLSL,ENGUSL,IWRITE,XCPK,XLCL,XUCL, 1 IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE CPK (PROCESS CAPABILITY INDEX) C OF THE DATA IN THE INPUT VECTOR X. C CPK = NUMERATOR/DENOMINATOR C WHERE NUMERATOR = MIN(A,B) C WHERE A = UPPER SPEC LIMIT - XBAR C AND B = XBAR - LOWER SPEC LIMIT C AND DENOMINATOR = 3 * SIGMA C NOTE--CPK IS A MEASURE OF PROCESS ACCURACY-- C COMBINING BOTH PRECISION AND UNBIASEDNESS. C NOTE--THE CPK INDEX IS A MEASURE WHICH TAKES ON C THE VALUES 0 TO INFINITY. C A GOOD PROCESS YIELDS VALUES OF CPK C WHICH ARE LARGE (ABOVE 2); C VALUES OF CPK FROM 0.5 TO 1.0 ARE TYPICAL. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C --ENGLSL = LOWER (ENGINEERING) SPEC LIMIT C --ENGUSL = UPPER (ENGINEERING) SPEC LIMIT C OUTPUT ARGUMENTS--CPK = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE CPK C --XLCL = LOWER 95% CONFIDENCE LEVEL C --XUCL = UPPER 95% CONFIDENCE LEVEL C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE CPK INDEX C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--R&M 2000 AIR FORCE MANUAL C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--89.5 C ORIGINAL VERSION--MAY 1989. C UPDATED --SEPTEMBER 1990. REVERSE INPUT ARGS C UPDATED --APRIL 2001. 95% CONFIDENCE LIMITS C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DOUBLE PRECISION DN DOUBLE PRECISION DX DOUBLE PRECISION DSUM DOUBLE PRECISION DMEAN DOUBLE PRECISION DVAR DOUBLE PRECISION DSD C DOUBLE PRECISION DUSL DOUBLE PRECISION DLSL DOUBLE PRECISION DUPPER DOUBLE PRECISION DLOWER DOUBLE PRECISION DNUM DOUBLE PRECISION DDEN DOUBLE PRECISION DCPK C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='CPK ' ISUBN2=' ' C IERROR='NO' C DMEAN=0.0D0 C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF CPK--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)ENGUSL,ENGLSL 54 FORMAT('ENGUSL,ENGLSL = ',2E15.7) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ******************************************** C ** COMPUTE PROCESS CAPABILITY INDEX CPK ** C ******************************************** C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(N.GE.1)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN CPK--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' IN THE VARIABLE FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114) 114 FORMAT(' THE CPK STATISTIC IS TO BE COMPUTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116) 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,117)N 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C IF(N.EQ.1)GOTO120 GOTO129 120 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,121) CC121 FORMAT('***** NON-FATAL DIAGNOSTIC IN CPK--', CCCCC CALL DPWRST('XXX','BUG ') CCCCC1'THE SECOND INPUT ARGUMENT (N) HAS THE VALUE 1') XSD=0.0 GOTO9000 129 CONTINUE C HOLD=X(1) DO135I=2,N IF(X(I).NE.HOLD)GOTO139 135 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,136)HOLD CC136 FORMAT('***** NON-FATAL DIAGNOSTIC IN CPK--', CCCCC CALL DPWRST('XXX','BUG ') CCCCC1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) XSD=0.0 GOTO9000 139 CONTINUE C 190 CONTINUE C C *************************************** C ** STEP 2-- ** C ** COMPUTE THE STANDARD DEVIATION. ** C *************************************** C DN=N DSUM=0.0D0 DO200I=1,N DX=X(I) DSUM=DSUM+DX 200 CONTINUE DMEAN=DSUM/DN C DSUM=0.0D0 DO300I=1,N DX=X(I) DSUM=DSUM+(DX-DMEAN)**2 300 CONTINUE DVAR=DSUM/(DN-1.0D0) DSD=0.0D0 IF(DVAR.GT.0.0D0)DSD=DSQRT(DVAR) XSD=DSD C C ************************************************** C ** STEP 3-- ** C ** COMPUTE THE CPK RATIO ** C ************************************************** C DUSL=ENGUSL DLSL=ENGLSL C DUPPER=DUSL-DMEAN DLOWER=DMEAN-DLSL C DNUM=DUPPER IF(DLOWER.LT.DUPPER)DNUM=DLOWER IF(DNUM.LE.0.0D0)DNUM=0.0D0 C DDEN=3.0*DSD C DCPK=0.0 IF(DDEN.GT.0.0D0)DCPK=DNUM/DDEN XCPK=DCPK C AN=REAL(N) P=0.975 TERM1=1.0/(9.0*AN) TERM2=XCPK*XCPK/(2.0*(AN-1.0)) CALL NORPPF(P,PPF) XLCL=XCPK - PPF*SQRT(TERM1 + TERM2) XUCL=XCPK + PPF*SQRT(TERM1 + TERM2) C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)N,XCPK 811 FORMAT('THE CPK OF THE ',I8,' OBSERVATIONS = ', 1E15.7) CALL DPWRST('XXX','BUG ') 890 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF CPK--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N 9013 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)DMEAN 9014 FORMAT('DMEAN = ',D15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)DSD 9015 FORMAT('DSD = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)DUSL,DLSL,DUPPER,DLOWER 9016 FORMAT('DUSL,DLSL,DUPPER,DLOWER = ',4D15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)DNUM,DDEN,DCPK,XCPK 9017 FORMAT('DNUM,DDEN,DCPK,XCPK = ',3D15.7,E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE CPL(X,N,ENGLSL,ENGUSL,IWRITE,XCPL,XLCL,XUCL, 1 IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE CPL (PROCESS CAPABILITY INDEX) C OF THE DATA IN THE INPUT VECTOR X. C CPL = NUMERATOR/DENOMINATOR C WHERE NUMERATOR = XBAR - LOWER SPEC LIMIT C AND DENOMINATOR = 3 * SIGMA C NOTE--CPL IS A VARIATION OF CPL WHEN YOU ARE ONLY C INTERESTED IN THE LOWER SPEC LIMIT. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C --ENGLSL = LOWER (ENGINEERING) SPEC LIMIT C --ENGUSL = UPPER (ENGINEERING) SPEC LIMIT C OUTPUT ARGUMENTS--CPL = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE CPL C --XLCL = LOWER 95% CONFIDENCE LEVEL C --XUCL = UPPER 95% CONFIDENCE LEVEL C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE CPL INDEX C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--R&M 2000 AIR FORCE MANUAL C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2001.4 C ORIGINAL VERSION--APRIL 2001. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DOUBLE PRECISION DN DOUBLE PRECISION DX DOUBLE PRECISION DSUM DOUBLE PRECISION DMEAN DOUBLE PRECISION DVAR DOUBLE PRECISION DSD C DOUBLE PRECISION DUSL DOUBLE PRECISION DLSL DOUBLE PRECISION DUPPER DOUBLE PRECISION DLOWER DOUBLE PRECISION DNUM DOUBLE PRECISION DDEN DOUBLE PRECISION DCPL C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='CPL ' ISUBN2=' ' C IERROR='NO' C DMEAN=0.0D0 C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF CPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)ENGUSL,ENGLSL 54 FORMAT('ENGUSL,ENGLSL = ',2E15.7) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ******************************************** C ** COMPUTE PROCESS CAPABILITY INDEX CPL ** C ******************************************** C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(N.GE.1)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN CPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' IN THE VARIABLE FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114) 114 FORMAT(' THE CPL STATISTIC IS TO BE COMPUTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116) 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,117)N 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C IF(N.EQ.1)GOTO120 GOTO129 120 CONTINUE XSD=0.0 GOTO9000 129 CONTINUE C HOLD=X(1) DO135I=2,N IF(X(I).NE.HOLD)GOTO139 135 CONTINUE XSD=0.0 GOTO9000 139 CONTINUE C 190 CONTINUE C C *************************************** C ** STEP 2-- ** C ** COMPUTE THE STANDARD DEVIATION. ** C *************************************** C DN=N DSUM=0.0D0 DO200I=1,N DX=X(I) DSUM=DSUM+DX 200 CONTINUE DMEAN=DSUM/DN C DSUM=0.0D0 DO300I=1,N DX=X(I) DSUM=DSUM+(DX-DMEAN)**2 300 CONTINUE DVAR=DSUM/(DN-1.0D0) DSD=0.0D0 IF(DVAR.GT.0.0D0)DSD=DSQRT(DVAR) XSD=DSD C C ************************************************** C ** STEP 3-- ** C ** COMPUTE THE CPL RATIO ** C ************************************************** C DUSL=ENGUSL DLSL=ENGLSL C DUPPER=DUSL-DMEAN DLOWER=DMEAN-DLSL C DNUM=DLOWER C DDEN=3.0*DSD C DCPL=0.0D0 IF(DDEN.GT.0.0D0)DCPL=DNUM/DDEN XCPL=DCPL C AN=REAL(N) P=0.975 CALL NORPPF(P,PPF) XLCL=0.0 XUCL=0.0 IF(N.GT.1)THEN XLCL=XCPL - PPF*SQRT((1.0/(9.0*AN)) + XCPL/(2.0*(AN-1.0))) XUCL=XCPL + PPF*SQRT((1.0/(9.0*AN)) + XCPL/(2.0*(AN-1.0))) ENDIF C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)N,XCPL 811 FORMAT('THE CPK OF THE ',I8,' OBSERVATIONS = ', 1E15.7) CALL DPWRST('XXX','BUG ') 890 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF CPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N 9013 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)DMEAN 9014 FORMAT('DMEAN = ',D15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)DSD 9015 FORMAT('DSD = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)DUSL,DLSL,DUPPER,DLOWER 9016 FORMAT('DUSL,DLSL,DUPPER,DLOWER = ',4D15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)DNUM,DDEN,DCPL,XCPL 9017 FORMAT('DNUM,DDEN,DCPL,XCPL = ',3D15.7,E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE CPM(X,N,ENGLSL,ENGUSL,TARGET,IWRITE,XCPM,XLCL,XUCL, 1IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE CPM (PROCESS CAPABILITY INDEX) C OF THE DATA IN THE INPUT VECTOR X. C CPM = (USL - LSL)/(6*SQRT(S**2+(XBAR-TARGET)**2)) C NOTE--CPM IS A MEASURE OF PROCESS ACCURACY-- C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C --ENGLSL = LOWER (ENGINEERING) SPEC LIMIT C --ENGUSL = UPPER (ENGINEERING) SPEC LIMIT C --TARGET = TARGET (ENGINEERING) SPEC LIMIT C OUTPUT ARGUMENTS--CPM = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE CPM C --XLCL = LOWER 95% CONFIDENCE INTERVAL C --XUCL = UPPER 95% CONFIDENCE INTERVAL C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE CPM INDEX C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--MEAN AND SD. C FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--NORMA HUBELE, ARIZONA STATE C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--98.11 C ORIGINAL VERSION--NOVEMBER 1998. C UPDATED --APRIL 2001. ADD 95% CONFIDENCE LIMITS C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DOUBLE PRECISION DN DOUBLE PRECISION DX DOUBLE PRECISION DSUM DOUBLE PRECISION DMEAN DOUBLE PRECISION DVAR DOUBLE PRECISION DSD C DOUBLE PRECISION DUSL DOUBLE PRECISION DLSL DOUBLE PRECISION DTARG DOUBLE PRECISION DNUM DOUBLE PRECISION DDEN DOUBLE PRECISION DCPM C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='CPM ' ISUBN2=' ' C IERROR='NO' C DMEAN=0.0D0 C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF CPM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)ENGUSL,ENGLSL 54 FORMAT('ENGUSL,ENGLSL = ',2E15.7) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ******************************************** C ** COMPUTE PROCESS CAPABILITY INDEX CPM ** C ******************************************** C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(N.GE.1)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN CPM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' IN THE VARIABLE FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114) 114 FORMAT(' THE CPM STATISTIC IS TO BE COMPUTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116) 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,117)N 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C IF(N.EQ.1)GOTO120 GOTO129 120 CONTINUE XSD=0.0 GOTO9000 129 CONTINUE C HOLD=X(1) DO135I=2,N IF(X(I).NE.HOLD)GOTO139 135 CONTINUE XSD=0.0 GOTO9000 139 CONTINUE C 190 CONTINUE C C *************************************** C ** STEP 2-- ** C ** COMPUTE THE STANDARD DEVIATION. ** C *************************************** C DN=N DSUM=0.0D0 DO200I=1,N DX=X(I) DSUM=DSUM+DX 200 CONTINUE DMEAN=DSUM/DN C DSUM=0.0D0 DO300I=1,N DX=X(I) DSUM=DSUM+(DX-DMEAN)**2 300 CONTINUE DVAR=DSUM/(DN-1.0D0) DSD=0.0D0 IF(DVAR.GT.0.0D0)DSD=DSQRT(DVAR) XMEAN=DMEAN XSD=DSD C C ************************************************** C ** STEP 3-- ** C ** COMPUTE THE CPM RATIO ** C ************************************************** C DUSL=ENGUSL DLSL=ENGLSL DTARG=TARGET C DNUM=DUSL-DLSL DDEN=6.0D0*DSQRT(DSD**2 + (DMEAN-DTARG)**2) C DCPM=0.0 IF(DDEN.GT.0.0D0)DCPM=DNUM/DDEN XCPM=DCPM C XLCL=0.0 XUCL=0.0 AN=REAL(N) NV=N-1 AV=REAL(NV) P=0.975 CALL CHSPPF(P,NV,PPF) IF((PPF/AV).GT.0.0)XUCL=XCPM*SQRT(PPF/AV) P=0.025 CALL CHSPPF(P,NV,PPF) IF((PPF/AV).GT.0.0)XLCL=XCPM*SQRT(PPF/AV) C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)N,XCPM 811 FORMAT('THE CPM OF THE ',I8,' OBSERVATIONS = ', 1E15.7) CALL DPWRST('XXX','BUG ') 890 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF CPM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N 9013 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)DMEAN 9014 FORMAT('DMEAN = ',D15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)DSD 9015 FORMAT('DSD = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)DUSL,DLSL 9016 FORMAT('DUSL,DLSL = ',2D15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)DNUM,DDEN,DCPM,XCPM 9017 FORMAT('DNUM,DDEN,DCPM,XCPM = ',3D15.7,E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END COMPLEX FUNCTION CPSI(ZIN) C***BEGIN PROLOGUE CPSI C***DATE WRITTEN 780501 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. C7C C***KEYWORDS COMPLEX,DIGAMMA FUNCTION,PSI FUNCTION,SPECIAL FUNCTION C***AUTHOR FULLERTON, W., (LANL) C***PURPOSE Computes the Psi function of complex argument. C***DESCRIPTION C C PSI(X) calculates the psi (or digamma) function of X. PSI(X) C is the logarithmic derivative of the gamma function of X. C***REFERENCES (NONE) C***ROUTINES CALLED CCOT,R1MACH,XERROR C***END PROLOGUE CPSI COMPLEX ZIN, Z, Z2INV, CORR, CCOT, CLOG C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DIMENSION BERN(13) DATA BERN( 1) / .8333333333 3333333 E-1 / DATA BERN( 2) / -.8333333333 3333333 E-2 / DATA BERN( 3) / .3968253968 2539683 E-2 / DATA BERN( 4) / -.4166666666 6666667 E-2 / DATA BERN( 5) / .7575757575 7575758 E-2 / DATA BERN( 6) / -.2109279609 2796093 E-1 / DATA BERN( 7) / .8333333333 3333333 E-1 / DATA BERN( 8) / -.4432598039 2156863 E0 / DATA BERN( 9) / .3053954330 2701197 E1 / DATA BERN(10) / -.2645621212 1212121 E2 / DATA BERN(11) / .2814601449 2753623 E3 / DATA BERN(12) / -.3454885393 7728938 E4 / DATA BERN(13) / .5482758333 3333333 E5 / DATA PI / 3.141592653 589793 E0 / DATA NTERM, BOUND, DXREL, RMIN, RBIG / 0, 4*0.0 / C***FIRST EXECUTABLE STATEMENT CPSI IF (NTERM.NE.0) GO TO 10 NTERM = -0.30*ALOG(R1MACH(3)) C MAYBE BOUND = N*(0.1*EPS)**(-1/(2*N-1)) / (PI*EXP(1)) BOUND = 0.1171*FLOAT(NTERM) * 1 (0.1*R1MACH(3))**(-1.0/(2.0*FLOAT(NTERM)-1.0)) DXREL = SQRT(R1MACH(4)) RMIN = EXP (AMAX1 (ALOG(R1MACH(1)), -ALOG(R1MACH(2))) + 0.011 ) RBIG = 1.0/R1MACH(3) C 10 Z = ZIN X = REAL(Z) Y = AIMAG(Z) IF (Y.LT.0.0) Z = CONJG(Z) C CORR = (0.0, 0.0) CABSZ = CABS(Z) IF (X.GE.0.0 .AND. CABSZ.GT.BOUND) GO TO 50 IF (X.LT.0.0 .AND. ABS(Y).GT.BOUND) GO TO 50 C IF (CABSZ.LT.BOUND) GO TO 20 C C USE THE REFLECTION FORMULA FOR REAL(Z) NEGATIVE, CABS(Z) LARGE, AND C ABS(AIMAG(Y)) SMALL. C CORR = -PI*CCOT(PI*Z) Z = 1.0 - Z GO TO 50 C C USE THE RECURSION RELATION FOR CABS(Z) SMALL. C 20 IF (CABSZ.LT.RMIN) THEN CCCCC CALL XERROR ( 'CPSI CPSI CALLED WITH Z SO NE CCCCC1AR 0 THAT CPSI OVERFLOWS', 56, 2, 2) WRITE(ICOUT,102) CALL DPWRST('XXX','BUG ') RETURN ENDIF 102 FORMAT('***** INTERNAL ERROR FROM CPSI: ARGUMENT SO CLOSE', 1' TO ZERO THAT CPSI OVERFLOWS') C IF (X.GE.(-0.5) .OR. ABS(Y).GT.DXREL) GO TO 30 IF (CABS((Z-AINT(X-0.5))/X).LT.DXREL) THEN CCCCC CALL XERROR ( 'CPSI ANSWE CCCCC1R LT HALF PRECISION BECAUSE Z TOO NEAR NEGATIVE INTEGER', 68, 1, 1 CCCCC2) WRITE(ICOUT,202) CALL DPWRST('XXX','BUG ') RETURN ENDIF 202 FORMAT('***** INTERNAL ERROR FROM CPSI: ANSWER LESS THAN HALF', 1' PRECISION BECAUSE ARGUMENT TOO NEAR A NEGATIVE INTEGER') IF (Y.EQ.0.0 .AND. X.EQ.AINT(X)) THEN CCCCC CALL XERROR ( 'CPSI Z IS A NEG CCCCC1ATIVE INTEGER', 31, 3, 2) WRITE(ICOUT,302) CALL DPWRST('XXX','BUG ') RETURN ENDIF 302 FORMAT('***** INTERNAL ERROR FROM CPSI: ARGUMENT IS A ', 1' NEGATIVE INTEGER') C 30 N = SQRT(BOUND**2-Y**2) - X + 1.0 DO 40 I=1,N CORR = CORR - 1.0/Z Z = Z + 1.0 40 CONTINUE C C NOW EVALUATE THE ASYMPTOTIC SERIES FOR SUITABLY LARGE Z. C 50 IF (CABSZ.GT.RBIG) CPSI = CLOG(Z) + CORR IF (CABSZ.GT.RBIG) GO TO 70 C CPSI = (0.0, 0.0) Z2INV = 1.0/Z**2 DO 60 I=1,NTERM NDX = NTERM + 1 - I CPSI = BERN(NDX) + Z2INV*CPSI 60 CONTINUE CPSI = CLOG(Z) - 0.5/Z - CPSI*Z2INV + CORR C 70 IF (Y.LT.0.0) CPSI = CONJG(CPSI) C RETURN END SUBROUTINE CPU(X,N,ENGLSL,ENGUSL,IWRITE,XCPU,XLCL,XUCL, 1 IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE CPU (PROCESS CAPABILITY INDEX) C OF THE DATA IN THE INPUT VECTOR X. C CPU = NUMERATOR/DENOMINATOR C WHERE NUMERATOR = XBAR + UPPER SPEC LIMIT C AND DENOMINATOR = 3 * SIGMA C NOTE--CPU IS A VARIATION OF CPK WHEN YOU ARE ONLY C INTERESTED IN THE UPPER SPEC LIMIT. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C --ENGLSL = LOWER (ENGINEERING) SPEC LIMIT C --ENGUSL = UPPER (ENGINEERING) SPEC LIMIT C OUTPUT ARGUMENTS--CPU = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE CPU C --XLCL = LOWER 95% CONFIDENCE LEVEL C --XUCL = UPPER 95% CONFIDENCE LEVEL C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE CPU INDEX C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--R&M 2000 AIR FORCE MANUAL C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2001.4 C ORIGINAL VERSION--APRIL 2001. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DOUBLE PRECISION DN DOUBLE PRECISION DX DOUBLE PRECISION DSUM DOUBLE PRECISION DMEAN DOUBLE PRECISION DVAR DOUBLE PRECISION DSD C DOUBLE PRECISION DUSL DOUBLE PRECISION DLSL DOUBLE PRECISION DUPPER DOUBLE PRECISION DLOWER DOUBLE PRECISION DNUM DOUBLE PRECISION DDEN DOUBLE PRECISION DCPU C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='CPU ' ISUBN2=' ' C IERROR='NO' C DMEAN=0.0D0 C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF CPU--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)ENGUSL,ENGLSL 54 FORMAT('ENGUSL,ENGLSL = ',2E15.7) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ******************************************** C ** COMPUTE PROCESS CAPABILITY INDEX CPU ** C ******************************************** C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(N.GE.1)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN CPU--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' IN THE VARIABLE FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114) 114 FORMAT(' THE CPU STATISTIC IS TO BE COMPUTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116) 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,117)N 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C IF(N.EQ.1)GOTO120 GOTO129 120 CONTINUE XSD=0.0 GOTO9000 129 CONTINUE C HOLD=X(1) DO135I=2,N IF(X(I).NE.HOLD)GOTO139 135 CONTINUE XSD=0.0 GOTO9000 139 CONTINUE C 190 CONTINUE C C *************************************** C ** STEP 2-- ** C ** COMPUTE THE STANDARD DEVIATION. ** C *************************************** C DN=N DSUM=0.0D0 DO200I=1,N DX=X(I) DSUM=DSUM+DX 200 CONTINUE DMEAN=DSUM/DN C DSUM=0.0D0 DO300I=1,N DX=X(I) DSUM=DSUM+(DX-DMEAN)**2 300 CONTINUE DVAR=DSUM/(DN-1.0D0) DSD=0.0D0 IF(DVAR.GT.0.0D0)DSD=DSQRT(DVAR) XSD=DSD C C ************************************************** C ** STEP 3-- ** C ** COMPUTE THE CPU RATIO ** C ************************************************** C DUSL=ENGUSL DLSL=ENGLSL C DUPPER=DUSL-DMEAN DLOWER=DMEAN-DLSL C DNUM=DUPPER C DDEN=3.0*DSD C DCPU=0.0D0 IF(DDEN.GT.0.0D0)DCPU=DNUM/DDEN XCPU=DCPU C AN=REAL(N) P=0.975 CALL NORPPF(P,PPF) XLCL=0.0 XUCL=0.0 IF(N.GT.1)THEN XLCL=XCPU - PPF*SQRT((1.0/(9.0*AN)) + XCPU/(2.0*(AN-1.0))) XUCL=XCPU + PPF*SQRT((1.0/(9.0*AN)) + XCPU/(2.0*(AN-1.0))) ENDIF C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)N,XCPU 811 FORMAT('THE CPK OF THE ',I8,' OBSERVATIONS = ', 1E15.7) CALL DPWRST('XXX','BUG ') 890 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF CPU--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N 9013 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)DMEAN 9014 FORMAT('DMEAN = ',D15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)DSD 9015 FORMAT('DSD = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)DUSL,DLSL,DUPPER,DLOWER 9016 FORMAT('DUSL,DLSL,DUPPER,DLOWER = ',4D15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)DNUM,DDEN,DCPU,XCPU 9017 FORMAT('DNUM,DDEN,DCPU,XCPU = ',3D15.7,E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE CPZERO(IN,A,R,T,IFLG,S) C***BEGIN PROLOGUE CPZERO C***DATE WRITTEN 810223 (YYMMDD) C***REVISION DATE 860227 (YYMMDD) C***CATEGORY NO. F1A1B C***KEYWORDS COMPLEX,POLYNOMIAL ROOTS,ROOTS,ZEROES,ZEROS C***AUTHOR KAHANER, D. K., (NBS) C***PURPOSE Find the zeros of a polynomial with complex coefficients. C***DESCRIPTION C C Find the zeros of the complex polynomial C P(Z)= A(1)*Z**N + A(2)*Z**(N-1) +...+ A(N+1) C C Input... C IN = degree of P(Z) C A = complex vector containing coefficients of P(Z), C A(I) = coefficient of Z**(N+1-i) C R = N word complex vector containing initial estimates for zeros C if these are known. C T = 4(N+1) word array used for temporary storage C IFLG = flag to indicate if initial estimates of C zeros are input. C If IFLG .EQ. 0, no estimates are input. C If IFLG .NE. 0, the vector R contains estimates of C the zeros C ** WARNING ****** If estimates are input, they must C be separated, that is, distinct or C not repeated. C S = an N word array C C Output... C R(I) = Ith zero, C S(I) = bound for R(I) . C IFLG = error diagnostic C Error Diagnostics... C If IFLG .EQ. 0 on return, all is well C If IFLG .EQ. 1 on return, A(1)=0.0 or N=0 on input C If IFLG .EQ. 2 on return, the program failed to coverge C after 25*N iterations. Best current estimates of the C zeros are in R(I). Error bounds are not calculated. C***REFERENCES (NONE) C***ROUTINES CALLED CPEVL C***END PROLOGUE CPZERO C CCCCC APRIL 1996. MAKE DUMMY DIMENSION "*" CCCCC REAL S(1) CCCCC COMPLEX R(1),T(1),A(1),PN,TEMP REAL S(*) COMPLEX R(*),T(*),A(*),PN,TEMP C***FIRST EXECUTABLE STATEMENT CPZERO IF( IN .LE. 0 .OR. CABS(A(1)) .EQ. 0.0 ) GO TO 30 C C CHECK FOR EASILY OBTAINED ZEROS C N=IN N1=N+1 IF(IFLG .NE. 0) GO TO 14 1 N1=N+1 IF(N .GT. 1) GO TO 2 R(1)=-A(2)/A(1) S(1)=0.0 RETURN 2 IF( CABS(A(N1)) .NE. 0.0 ) GO TO 3 R(N)=0.0 S(N)=0.0 N=N-1 GO TO 1 C C IF INITIAL ESTIMATES FOR ZEROS NOT GIVEN, FIND SOME C 3 TEMP=-A(2)/(A(1)*FLOAT(N)) CALL CPEVL(N,N,A,TEMP,T,T,.FALSE.) IMAX=N+2 T(N1)=CABS(T(N1)) DO 6 I=2,N1 T(N+I)=-CABS(T(N+2-I)) IF(REAL(T(N+I)) .LT. REAL(T(IMAX))) IMAX=N+I 6 CONTINUE X=(-REAL(T(IMAX))/REAL(T(N1)))**(1./FLOAT(IMAX-N1)) 7 X=2.*X CALL CPEVL(N,0,T(N1),CMPLX(X,0.0),PN,PN,.FALSE.) IF (REAL(PN).LT.0.) GO TO 7 U=.5*X V=X 10 X=.5*(U+V) CALL CPEVL(N,0,T(N1),CMPLX(X,0.0),PN,PN,.FALSE.) IF (REAL(PN).GT.0.) V=X IF (REAL(PN).LE.0.) U=X IF((V-U) .GT. .001*(1.+V)) GO TO 10 DO 13 I=1,N U=(3.14159265/FLOAT(N))*(.5+2.*FLOAT(I-1)) 13 R(I)=AMAX1(X,.001*CABS(TEMP))*CMPLX(COS(U),SIN(U))+TEMP C C MAIN ITERATION LOOP STARTS HERE C 14 NR=0 NMAX=25*N DO 19 NIT=1,NMAX DO 18 I=1,N IF(NIT .NE. 1 .AND. CABS(T(I)) .EQ. 0.) GO TO 18 CALL CPEVL(N,0,A,R(I),PN,TEMP,.TRUE.) IF(ABS(REAL(PN))+ABS(AIMAG(PN)) .GT. REAL(TEMP)+ 1 AIMAG(TEMP)) GO TO 16 T(I)=0.0 NR=NR+1 GO TO 18 16 TEMP=A(1) DO 17 J=1,N 17 IF(J .NE. I) TEMP=TEMP*(R(I)-R(J)) T(I)=PN/TEMP 18 CONTINUE DO 15 I=1,N 15 R(I)=R(I)-T(I) IF(NR .EQ. N) GO TO 21 19 CONTINUE GO TO 26 C C CALCULATE ERROR BOUNDS FOR ZEROS C 21 DO 25 NR=1,N CALL CPEVL(N,N,A,R(NR),T,T(N+2),.TRUE.) X=CABS(CMPLX(ABS(REAL(T(1))),ABS(AIMAG(T(1))))+T(N+2)) S(NR)=0.0 DO 23 I=1,N X=X*FLOAT(N1-I)/FLOAT(I) TEMP=CMPLX(AMAX1(ABS(REAL(T(I+1)))-REAL(T(N1+I)),0.0), 1 AMAX1(ABS(AIMAG(T(I+1)))-AIMAG(T(N1+I)),0.0)) 23 S(NR)=AMAX1(S(NR),(CABS(TEMP)/X)**(1./FLOAT(I))) 25 S(NR)=1./S(NR) IFLG=0 RETURN C ERROR EXITS 26 IFLG=2 RETURN 30 IFLG=1 RETURN END FUNCTION CSEVL (X, CS, N) C***BEGIN PROLOGUE CSEVL C***PURPOSE Evaluate a Chebyshev series. C***LIBRARY SLATEC (FNLIB) C***CATEGORY C3A2 C***TYPE SINGLE PRECISION (CSEVL-S, DCSEVL-D) C***KEYWORDS CHEBYSHEV SERIES, FNLIB, SPECIAL FUNCTIONS C***AUTHOR Fullerton, W., (LANL) C***DESCRIPTION C C Evaluate the N-term Chebyshev series CS at X. Adapted from C a method presented in the paper by Broucke referenced below. C C Input Arguments -- C X value at which the series is to be evaluated. C CS array of N terms of a Chebyshev series. In evaluating C CS, only half the first coefficient is summed. C N number of terms in array CS. C C***REFERENCES R. Broucke, Ten subroutines for the manipulation of C Chebyshev series, Algorithm 446, Communications of C the A.C.M. 16, (1973) pp. 254-256. C L. Fox and I. B. Parker, Chebyshev Polynomials in C Numerical Analysis, Oxford University Press, 1968, C page 56. C***ROUTINES CALLED R1MACH, XERMSG C***REVISION HISTORY (YYMMDD) C 770401 DATE WRITTEN C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 900329 Prologued revised extensively and code rewritten to allow C X to be slightly outside interval (-1,+1). (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE CSEVL REAL B0, B1, B2, CS(*), ONEPL, TWOX, X LOGICAL FIRST SAVE FIRST, ONEPL C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA FIRST /.TRUE./ C***FIRST EXECUTABLE STATEMENT CSEVL IF (FIRST) ONEPL = 1.0E0 + R1MACH(4) FIRST = .FALSE. C IF (N .LT. 1) THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') CSEVL = 0.0 RETURN ENDIF 11 FORMAT('***** ERROR FROM CSEVL. THE NUMBER OF TERMS IS ') 12 FORMAT(' LESS THAN OR EQUAL TO ZERO. *****') IF (N .GT. 1000) THEN WRITE(ICOUT,21) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,22) CALL DPWRST('XXX','BUG ') CSEVL = 0.0 RETURN ENDIF 21 FORMAT('***** ERROR FROM CSEVL. THE NUMBER OF TERMS IS ') 22 FORMAT(' GREATER THAN 1000. *****') IF (ABS(X) .GT. ONEPL) THEN WRITE(ICOUT,31) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,32) CALL DPWRST('XXX','BUG ') ENDIF 31 FORMAT('***** WARNING FROM CSEVL. X IS OUTSIDE THE ') 32 FORMAT(' INTERVAL (-1,+1). *****') C B1 = 0.0E0 B0 = 0.0E0 TWOX = 2.0*X DO 10 I = 1,N B2 = B1 B1 = B0 NI = N + 1 - I B0 = TWOX*B1 - B2 + CS(NI) 10 CONTINUE C CSEVL = 0.5E0*(B0-B2) C RETURN END SUBROUTINE CUMAVE(X,NX,IWRITE,Y,IBUGA3,IERROR) C C PURPOSE--COMPUTE CUMULATIVE AVERAGE (MEAN) OF AN ARRAY C NOTE--IT IS PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y(.) C BEING IDENTICAL TO THE INPUT VECTOR X(.). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--98/5 C ORIGINAL VERSION--MAY 1998. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C DOUBLE PRECISION DSUM C C--------------------------------------------------------------------- C DIMENSION X(*) DIMENSION Y(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='CUMA' ISUBN2='VE ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF CUMAVE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)NX 53 FORMAT('NX = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,NX WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ************************************** C ** COMPUTE CUMULATIVE AVERAGE ** C ************************************** C Y(1)=X(1) IF(NX.LT.2)GOTO9000 DSUM=DBLE(Y(1)) DO100I=2,NX DSUM=DSUM + DBLE(X(I)) Y(I)=REAL(DSUM/DBLE(I)) 100 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE C IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF CUMAVE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NX 9013 FORMAT('NX = ',I8) CALL DPWRST('XXX','BUG ') DO9015I=1,NX WRITE(ICOUT,9016)I,X(I),Y(I) 9016 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE CUMHAZ(X,TAG,NX,IWRITE,Y,IBUGA3,IERROR) C C PURPOSE--COMPUTE CUMULATIVE HAZARD OF AN ARRAY C THE TAG VARIABLE IDENTIFIES CENSORED DATA C (1 = FAILURE TIME, 0 = CENSORED) C NOTE--IT IS PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y(.) C BEING IDENTICAL TO THE INPUT VECTOR X(.). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--98/5 C ORIGINAL VERSION--MAY 1998. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C DOUBLE PRECISION DSUM C C--------------------------------------------------------------------- C DIMENSION X(*) DIMENSION Y(*) DIMENSION TAG(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='CUMH' ISUBN2='AZ ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF CUMHAZ--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)NX 53 FORMAT('NX = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,NX WRITE(ICOUT,56)I,X(I),TAG(I) 56 FORMAT('I,X(I), TAG(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ************************************** C ** COMPUTE CUMULATIVE HAZARD ** C ************************************** C CALL SORTC(X,TAG,NX,Y,TAG) CALL RANK(Y,NX,IWRITE,Y,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C AFACT=REAL(NX+1) DO100J=1,NX IF(ABS(TAG(J)).GE.0.5)THEN Y(J)=100./(AFACT - Y(J)) ELSE Y(J)=0.0 ENDIF 100 CONTINUE C DSUM=0.0D0 DO200I=1,NX DSUM=DSUM+DBLE(Y(I)) Y(I)=REAL(DSUM) 200 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE C IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF CUMHAZ--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NX 9013 FORMAT('NX = ',2I8) CALL DPWRST('XXX','BUG ') DO9015I=1,NX WRITE(ICOUT,9016)I,X(I),Y(I) 9016 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE CUMINT(Y,X,N,NUMVAR,IWRITE,Z,IBUGA3,IERROR) C C PURPOSE--COMPUTE CUMULATIVE INTEGRAL OF A VARIABLE. C NOTE--IF THE VERTICAL AXIS VARIABLE IS Y(.) C AND THE HORIZONTAL AXIS VARIABLE IS X(.), C THEN THE OUTPUT VARIABLE CONTAINING THE C CUMULATIVE INTEGRAL C WILL BE COMPUTED AS FOLLOWS-- C Z(1) = 0 C Z(2) = Z(1) + (Y(2)-Y(1))*(X(2)-X(1))/2 C Z(3) = Z(2) + Y(2)*(X(3)-X(2)) + (Y(3)-Y(2))*(X(3)-X(2))/2 C ETC. C NOTE--IT IS PERMISSIBLE TO HAVE THE OUTPUT VECTOR Z(.) C BEING IDENTICAL TO THE INPUT VECTOR X(.) C OR THE INPUT VECTORS X(.) AND Y(.). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--FEBRUARY 1979. C UPDATED --APRIL 1979. C UPDATED --JULY 1979. C UPDATED --AUGUST 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C DIMENSION Y(*) DIMENSION X(*) DIMENSION Z(*) C DOUBLE PRECISION DINT DOUBLE PRECISION DXI DOUBLE PRECISION DYI DOUBLE PRECISION DXIM1 DOUBLE PRECISION DYIM1 DOUBLE PRECISION DDELX DOUBLE PRECISION DDELY DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='CUMI' ISUBN2='NT ' C IERROR='NO' C DXI=0.0D0 C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF CUMINT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N,NUMVAR 53 FORMAT('N,NUMVAR = ',2I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I),Y(I) 56 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C **************************************************** C ** CUMPUTE THE CUMULATIVE (NUMERICAL) INTEGRAL. ** C **************************************************** C ISTEPN='1' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DINT=0.0D0 IF(N.LT.1)GOTO150 IF(N.EQ.1)GOTO190 I=1 IF(NUMVAR.EQ.1)DXI=I IF(NUMVAR.EQ.2)DXI=X(I) DYI=Y(1) Z(1)=0.0 DO100I=2,N DXIM1=DXI DYIM1=DYI IF(NUMVAR.EQ.1)DXI=I IF(NUMVAR.EQ.2)DXI=X(I) DYI=Y(I) DDELX=DXI-DXIM1 DDELY=DYI-DYIM1 DTERM1=DYIM1*DDELX DTERM2=DDELY*DDELX/2.0D0 DINT=DINT+DTERM1+DTERM2 Z(I)=DINT 100 CONTINUE GOTO190 C 150 CONTINUE IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,151) 151 FORMAT('***** ERROR IN CUMINT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,152) 152 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,153) 153 FORMAT(' IN THE VARIABLE FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,154) 154 FORMAT(' THE CUMULATIVE INTEGRAL IS TO BE COMPUTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,155) 155 FORMAT(' MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,156) 156 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,157)N 157 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') 190 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE C IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF CUMINT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N,NUMVAR 9013 FORMAT('N,NUMVAR = ',2I8) CALL DPWRST('XXX','BUG ') DO9015I=1,N WRITE(ICOUT,9016)I,X(I),Y(I),Z(I) 9016 FORMAT('I,X(I),Y(I),Z(I) = ',I8,3E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE CUMPRO(X,N,IWRITE,Y,IBUGA3,IERROR) C C PURPOSE--COMPUTE CUMULATIVE PRODUCT OF A VARIABLE-- C Y(1) = X(1) C Y(2) = X(1) * X(2) C Y(3) = X(1) * X(2) * X(3) C ETC. C NOTE--IT IS PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y(.) C BEING IDENTICAL TO THE INPUT VECTOR X(.). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--APRIL 1979. C UPDATED --JULY 1979. C UPDATED --AUGUST 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION X(*) DIMENSION Y(*) C DOUBLE PRECISION DPROD DOUBLE PRECISION DX C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C C-----START POINT----------------------------------------------------- C ISUBN1='CUMP' ISUBN2='RO ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF CUMPRO--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C *********************************** C ** COMPUTE CUMULATIVE PRODUCT. ** C *********************************** C DPROD=1.0D0 IF(N.LT.1)GOTO150 DO100I=1,N DX=X(I) DPROD=DPROD*DX Y(I)=DPROD 100 CONTINUE GOTO190 C 150 CONTINUE IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,151) 151 FORMAT('***** ERROR IN CUMPRO--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,152) 152 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,153) 153 FORMAT(' IN THE VARIABLE FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,154) 154 FORMAT(' THE CUMULATIVE PRODUCT IS TO BE COMPUTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,155) 155 FORMAT(' MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,156) 156 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,157)N 157 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') C 190 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE C IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF CUMPRO--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N 9013 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO9015I=1,N WRITE(ICOUT,9016)I,X(I),Y(I) 9016 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE CUMSUM(X,N,IWRITE,Y,IBUGA3,IERROR) C C PURPOSE--COMPUTE CUMULATIVE SUM OF A VARIABLE-- C Y(1) = X(1) C Y(2) = X(1) + X(2) C Y(3) = X(1) + X(2) + X(3) C ETC. C NOTE--IT IS PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y(.) C BEING IDENTICAL TO THE INPUT VECTOR X(.). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--FEBRUARY 1979. C UPDATED --APRIL 1979. C UPDATED --JULY 1979. C UPDATED --AUGUST 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION X(*) DIMENSION Y(*) C DOUBLE PRECISION DSUM DOUBLE PRECISION DX C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='CUMS' ISUBN2='UM ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF CUMSUM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ******************************* C ** COMPUTE CUMULATIVE SUM. ** C ******************************* C DSUM=0.0D0 IF(N.LT.1)GOTO150 DO100I=1,N DX=X(I) DSUM=DSUM+DX Y(I)=DSUM 100 CONTINUE GOTO190 C 150 CONTINUE IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,151) 151 FORMAT('***** ERROR IN CUMSUM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,152) 152 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,153) 153 FORMAT(' IN THE VARIABLE FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,154) 154 FORMAT(' THE CUMULATIVE SUM IS TO BE COMPUTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,155) 155 FORMAT(' MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,156) 156 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,157)N 157 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') C 190 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE C IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF CUMSUM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N 9013 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO9015I=1,N WRITE(ICOUT,9016)I,X(I),Y(I) 9016 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE CUSARL(X,NX,IWRITE,Y,ICASE,IBUGA3,IERROR) C C PURPOSE--COMPUTE CUMULATIVE SUM ARL. C USE APPLIED STATISTICS ALGORITHM AS 258. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--99/3 C ORIGINAL VERSION--MARCH 1999. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 ICASE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 IHP CHARACTER*4 IHP2 C C--------------------------------------------------------------------- C DIMENSION X(*) DIMENSION Y(*) C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOHK.INC' C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='CUSA' ISUBN2='RL ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF CUSARL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICASE,IBUGA3 52 FORMAT('ICAE,IBUGA3 = ',2A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)NX 53 FORMAT('NX = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,NX WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ********************************************* C ** CHECK FOR PARAMERERS: DELTA, S0, K, H ** C ********************************************* C IHP='S0 ' IHP2=' ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IHP,IHP2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')THEN S0=0.0 ELSE S0=VALUE(ILOCP) ENDIF C IHP='K ' IHP2=' ' IHWUSE='P' MESSAG='YES' CALL CHECKN(IHP,IHP2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')GOTO9000 AK=VALUE(ILOCP) C IF(AK.LT.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,16211) 16211 FORMAT('***** ERROR IN CUSARL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,16212) 16212 FORMAT(' THE SPECIFIED PARAMETER K') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,16213) 16213 FORMAT(' FOR THE CUMULATIVE SUM AVERAGE RUN LENGTH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,16214) 16214 FORMAT(' MUST BE GREATER THAN OR EQUAL TO 0;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,16215) 16215 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,16216)AK 16216 FORMAT(' THE SPECIFIED VALUE OF K = ',E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C IHP='H ' IHP2=' ' IHWUSE='P' MESSAG='YES' CALL CHECKN(IHP,IHP2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')GOTO9000 AH=VALUE(ILOCP) C IF(AH.LT.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,16311) 16311 FORMAT('***** ERROR IN CUSARL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,16312) 16312 FORMAT(' THE SPECIFIED PARAMETER H') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,16313) 16313 FORMAT(' FOR THE CUMULATIVE SUM AVERAGE RUN LENGTH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,16314) 16314 FORMAT(' MUST BE GREATER THAN OR EQUAL TO 0;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,16315) 16315 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,16316)AH 16316 FORMAT(' THE SPECIFIED VALUE OF K = ',E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C DO100I=1,NX DELTA=X(I) IF(ICASE.EQ.'TWOS')THEN CALL ARL2(DELTA,AK,AH,S0,ARL,ARLFIR,IFAULT) ELSE CALL ARL1(DELTA,AK,AH,S0,ARL,ARLFIR,IFAULT) ENDIF IF(IFAULT.EQ.1)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,141) 141 FORMAT('***** ERROR IN CUSARL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,143) 143 FORMAT(' ERROR IN INPUT ARGUMENTS TO ARL ROUTINE.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ELSEIF(IFAULT.EQ.2)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,151) 151 FORMAT('***** ERROR IN CUSARL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,153)DELTA 153 FORMAT(' FOR X = ',G15.7,', EQUATIONS ARE SINGULAR.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ELSEIF(IFAULT.EQ.3)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,161) 161 FORMAT('***** ERROR IN CUSARL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,163)DELTA 163 FORMAT(' FOR X = ',G15.7,', VALUE OF S0 IS TOO LARGE.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF IF(S0.GT.0.0)THEN Y(I)=ARLFIR ELSE Y(I)=ARL ENDIF 100 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE C IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF CUSARL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NX 9013 FORMAT('NX = ',I8) CALL DPWRST('XXX','BUG ') DO9015I=1,NX WRITE(ICOUT,9016)I,X(I),Y(I) 9016 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END