SUBROUTINE DPDIA2(X1,Y1,X2,Y2,X3,Y3, 1IFIG, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG) C C PURPOSE--DRAW A DIAMOND C WITH ONE END OF THE MAJOR AXIS AT (X1,Y1) C WITH ONE END OF THE MINOR AXIS AT (X2,Y2) C AND THE OTHER END OF MAJOR AXIS AT (X3,Y3). 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 1981. C UPDATED --MAY 1982. C UPDATED --JANUARY 1989. MODIFY CALLS TO DPDRPL (ALAN) C UPDATED --JANUARY 1989. MODIFY CALL TO DPFIRE (ALAN) C C-----NON-COMMON VARIABLES------------------------------------- C CHARACTER*4 IFIG CHARACTER*4 IPATT2 C CHARACTER*4 ILINPA CHARACTER*4 ILINCO C CHARACTER*4 IREBLI CHARACTER*4 IREBCO CHARACTER*4 IREFSW CHARACTER*4 IREFCO CHARACTER*4 IREPTY CHARACTER*4 IREPLI CHARACTER*4 IREPCO C CHARACTER*4 IPATT CHARACTER*4 ICOLF CHARACTER*4 ICOLP CHARACTER*4 ICOL CHARACTER*4 IFLAG C DIMENSION PX(10) DIMENSION PY(10) CCCCC DIMENSION PX3(10) CCCCC DIMENSION PY3(10) C DIMENSION ILINPA(*) DIMENSION ILINCO(*) DIMENSION PLINTH(*) C DIMENSION AREGBA(*) DIMENSION IREBLI(*) DIMENSION IREBCO(*) DIMENSION PREBTH(*) DIMENSION IREFSW(*) DIMENSION IREFCO(*) DIMENSION IREPTY(*) DIMENSION IREPLI(*) DIMENSION IREPCO(*) DIMENSION PREPTH(*) DIMENSION PREPSP(*) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOGR.INC' INCLUDE 'DPCOBE.INC' 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-----START POINT----------------------------------------------------- C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DIA2')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPDIA2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)X1,Y1 53 FORMAT('X1,Y1 = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)X2,Y2 54 FORMAT('X2,Y2 = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,59)IFIG 59 FORMAT('IFIG = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1) 61 FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',A4,2X,A4,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62)AREGBA(1) 62 FORMAT('AREGBA(1) = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1) 63 FORMAT('IREBLI(1),IREBCO(1),PREBTH(1) = ',A4,2X,A4,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,64)IREFSW(1),IREFCO(1) 64 FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) 65 FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ', 1A4,2X,A4,2X,A4,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,69)PTEXHE,PTEXWI 69 FORMAT('PTEXHE,PTEXWI= ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,70)PTEXVG,PTEXHG 70 FORMAT('PTEXVG,PTEXHG= ',2E15.6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,79)IBUGG4,ISUBG4,IERRG4 79 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ********************************* C ** STEP 1-- ** C ** DETERMINE THE COORDINATES ** C ** FOR THE DIAMOND ** C ********************************* C XC=(X1+X3)/2.0 YC=(Y1+Y3)/2.0 C XDEL=XC-X2 YDEL=YC-Y2 C X4=XC+XDEL Y4=YC+YDEL C PX(1)=X1 PY(1)=Y1 C PX(2)=X2 PY(2)=Y2 C PX(3)=X3 PY(3)=Y3 C PX(4)=X4 PY(4)=Y4 C PX(5)=X1 PY(5)=Y1 C NP=5 C C C *********************** C ** STEP 2-- ** C ** FILL THE FIGURE ** C ** (IF CALLED FOR) ** C *********************** C IF(IREFSW(1).EQ.'OFF')GOTO2190 IPATT=IREPTY(1) IPATT2='SOLI' PTHICK=PREPTH(1) PXGAP=PREPSP(1) PYGAP=PREPSP(1) ICOLF=IREFCO(1) ICOLP=IREPCO(1) CALL DPFIRE(PX,PY,NP, 1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,IPATT2) 2190 CONTINUE C C *************************** C ** STEP 3-- ** C ** DRAW OUT THE FIGURE ** C *************************** C IPATT=ILINPA(1) PTHICK=PLINTH(1) ICOL=ILINCO(1) IFLAG='ON' CCCCC CALL \PDRPL(PX,PY,NP,PX3,PY3,NP3, CCCCC1IFIG,IPATT,PTHICK,ICOL) CALL DPDRPL(PX,PY,NP, 1IFIG,IPATT,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DIA2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPDIA2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)XC,YC,XDEL,YDEL 9012 FORMAT('XC,YC,XDEL,YDEL = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NP 9014 FORMAT('NP = ',I8) CALL DPWRST('XXX','BUG ') DO9015I=1,NP WRITE(ICOUT,9016)I,PX(I),PY(I) 9016 FORMAT('I,PX(I),PY(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE WRITE(ICOUT,9039)IBUGG4,ISUBG4,IERRG4 9039 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPDIAL(IHARG,IARGT,IARG,NUMARG, 1IGRASW,PDIAXC,PDIAYC, 1NUMDEV, 1IDMANU,IDMODE,IDMOD2,IDMOD3, 1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 1IDNVOF,IDNHOF, CCCCC ADD FOLLOWING LINE MARCH 1997. 1IDFONT, 1IBUGD2,ISUBRO,IFOUND,IERROR) C C PURPOSE--SWITCH THE TERMINAL INTO DIALOGUE (= NON-GRAPHICS) MODE C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --IARGT (A CHARACTER VECTOR) C --IARG (AN INTEGER VECTOR) C --NUMARG C OUTPUT ARGUMENTS--IFOUND ('YES' OR 'NO') C --IERROR ('YES' OR 'NO' ) 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--NOVEMBER 1984. C UPDATED --MARCH 1997. SUPPORT FOR DEVICE FONT (ALAN) C C-----NON-COMMON VARIABLES---------------------------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT C CHARACTER*4 IGRASW C CHARACTER*4 IDMANU CHARACTER*4 IDMODE CHARACTER*4 IDMOD2 CHARACTER*4 IDMOD3 C CHARACTER*4 IDPOWE CHARACTER*4 IDCONT CHARACTER*4 IDCOLO CCCCC ADD FOLLOWING LINE MARCH 1997. CHARACTER*4 IDFONT C CHARACTER*4 IFOUND CHARACTER*4 IBUGD2 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION IARG(*) C DIMENSION IDMANU(*) DIMENSION IDMODE(*) DIMENSION IDMOD2(*) DIMENSION IDMOD3(*) C DIMENSION IDPOWE(*) DIMENSION IDCONT(*) DIMENSION IDCOLO(*) CCCCC ADD FOLLOWING LINE MARCH 1997. DIMENSION IDFONT(*) DIMENSION IDNVPP(*) DIMENSION IDNHPP(*) DIMENSION IDUNIT(*) C DIMENSION IDNVOF(*) DIMENSION IDNHOF(*) C C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOGR.INC' INCLUDE 'DPCOBE.INC' 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-----START POINT----------------------------------------------------- C ISUBN1='DPDI' ISUBN2='AL ' C IFOUND='NO' IERROR='NO' C IBUGG4=IBUGD2 ISUBG4=ISUBRO IERRG4=IERROR C IF(IBUGD2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('AT THE BEGINNING OF DPDIAL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGD2,IBUGG4 53 FORMAT('IBUGD2,IBUGG4 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IFOUND,IERROR 54 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)IGRASW,PDIAXC,PDIAYC 55 FORMAT('IGRASW,PDIAXC,PDIAYC = ',A4,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,60)NUMARG 60 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO61I=1,NUMARG WRITE(ICOUT,62)I,IHARG(I),IARGT(I),IARG(I) 62 FORMAT('I,IHARG(I),IARGT(I),IARG(I) = ', 1I8,2X,A4,2X,A4,2X,I8) CALL DPWRST('XXX','BUG ') 61 CONTINUE WRITE(ICOUT,70)NUMDEV 70 FORMAT('NUMDEV = ',I8) CALL DPWRST('XXX','BUG ') DO71I=1,NUMDEV WRITE(ICOUT,72)I,IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I) 72 FORMAT('I,IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I) = ', 1I8,2X,A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,73)I,IDPOWE(I),IDCONT(I),IDCOLO(I) 73 FORMAT('I,IDPOWE(I),IDCONT(I),IDCOLO(I) = ', 1I8,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,74)I,IDNVPP(I),IDNHPP(I),IDUNIT(I) 74 FORMAT('I,IDNVPP(I),IDNHPP(I),IDUNIT(I) = ', 1I8,2X,I8,2X,I8,2X,I8) CALL DPWRST('XXX','BUG ') 71 CONTINUE WRITE(ICOUT,82)IMANUF,IMODEL,IMODE2,IMODE3 82 FORMAT('IMANUF,IMODEL,IMODE2,IMODE3 = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,83)IGCONT,IGCOLO 83 FORMAT('IGCONT,IGCOLO = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,84)NUMVPP,NUMHPP,ANUMVP,ANUMHP 84 FORMAT('NUMVPP,NUMHPP,ANUMVP,ANUMHP = ',2I8,2E15.7) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ******************************************************** C ** STEP 1-- ** C ** EXTRACT NEEDED INFORMATION FROM THE COMMAND LINE ** C ******************************************************** C IF(NUMARG.LE.0)GOTO1110 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'ON')GOTO1110 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'OFF')GOTO1120 GOTO1110 C 1110 CONTINUE IGRASW='OFF2' IFOUND='YES' GOTO1190 C 1120 CONTINUE IGRASW='ON2' IFOUND='YES' GOTO1190 C 1190 CONTINUE C C ******************************** C ** STEP 2-- ** C ** STEP THROUGH EACH DEVICE ** C ******************************** C IF(NUMDEV.LE.0)GOTO9000 DO8000IDEVIC=1,NUMDEV C IF(IDPOWE(IDEVIC).EQ.'OFF')GOTO8000 C IMANUF=IDMANU(IDEVIC) IMODEL=IDMODE(IDEVIC) IMODE2=IDMOD2(IDEVIC) IMODE3=IDMOD3(IDEVIC) IGCONT=IDCONT(IDEVIC) IGCOLO=IDCOLO(IDEVIC) CCCCC ADD FOLLOWING LINE MARCH 1997. IGFONT=IDFONT(IDEVIC) NUMVPP=IDNVPP(IDEVIC) NUMHPP=IDNHPP(IDEVIC) ANUMVP=NUMVPP ANUMHP=NUMHPP C AUGUST 1988. ADD OFFSET VARIABLE IOFFSV=IDNVOF(IDEVIC) IOFFSH=IDNHOF(IDEVIC) C IGUNIT=IDUNIT(IDEVIC) C C ************************************************* C ** STEP 2.1-- ** C ** TREAT THE DISCRETE TERMINALS CASE ** C ************************************************* C ISTEPN='2.1' IF(IBUGD2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IGCONT.EQ.'OFF')GOTO8000 C C ************************************** C ** STEP 2.2-- ** C ** BRANCH TO THE APPROPRIATE CASE ** C ** FOR CONTINUOUS TERMINALS ** C ************************************** C 1200 CONTINUE ISTEPN='2.2' IF(IBUGD2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IGRASW.EQ.'OFF2')GOTO1300 GOTO1400 C C **************************************** C ** STEP 2.3-- ** C ** TREAT THE DIALOGUE MODE CASE ** C ** FOR CONTINUOUS TERMINALS. ** C **************************************** C 1300 CONTINUE ISTEPN='2.3' IF(IBUGD2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGD2.EQ.'ON')WRITE(ICOUT,1305) 1305 FORMAT('*** FROM DPDIAL--ENTRY INTO DIALOGUE MODE ', 1'SHOULD TAKE PLACE NOW') IF(IBUGD2.EQ.'ON')CALL DPWRST('XXX','BUG ') C CALL GRSEMO(IGRASW,PDIAXC,PDIAYC) C IF(IBUGD2.EQ.'ON')WRITE(ICOUT,1306) 1306 FORMAT('*** FROM DPDIAL--ENTRY INTO DIALOGUE MODE ', 1'SHOULD HAVE JUST TAKEN PLACE') IF(IBUGD2.EQ.'ON')CALL DPWRST('XXX','BUG ') C GOTO8000 C C **************************************** C ** STEP 2.4-- ** C ** TREAT THE GRAPHICS MODE CASE ** C ** FOR CONTINUOUS TERMINALS. ** C **************************************** C 1400 CONTINUE ISTEPN='2.4' IF(IBUGD2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGD2.EQ.'ON')WRITE(ICOUT,1405) 1405 FORMAT('*** FROM DPDIAL--ENTRY INTO GRAPHICS MODE ', 1'SHOULD TAKE PLACE NOW') IF(IBUGD2.EQ.'ON')CALL DPWRST('XXX','BUG ') C CALL GRSEMO(IGRASW,PDIAXC,PDIAYC) C IF(IBUGD2.EQ.'ON')WRITE(ICOUT,1206) 1206 FORMAT('*** FROM DPDIAL--ENTRY INTO GRAPHICS MODE ', 1'SHOULD HAVE JUST TAKEN PLACE') IF(IBUGD2.EQ.'ON')CALL DPWRST('XXX','BUG ') C GOTO8000 C 8000 CONTINUE IF(IGRASW.EQ.'OFF2')IGRASW='OFF' IF(IGRASW.EQ.'ON2')IGRASW='ON' C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGD2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('AT THE END OF DPDIAL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IBUGD2,IBUGG4 9013 FORMAT('IBUGD2,IBUGG4 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IFOUND,IERROR 9014 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)IGRASW,PDIAXC,PDIAYC 9015 FORMAT('IGRASW,PDIAXC,PDIAYC = ',A4,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9020)NUMARG 9020 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO9021I=1,NUMARG WRITE(ICOUT,9022)I,IHARG(I),IARGT(I),IARG(I) 9022 FORMAT('I,IHARG(I),IARGT(I),IARG(I) = ', 1I8,2X,A4,2X,A4,2X,I8) CALL DPWRST('XXX','BUG ') 9021 CONTINUE WRITE(ICOUT,9030)NUMDEV 9030 FORMAT('NUMDEV = ',I8) CALL DPWRST('XXX','BUG ') DO9031I=1,NUMDEV WRITE(ICOUT,9032)I,IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I) 9032 FORMAT('I,IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I) = ', 1I8,2X,A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9033)I,IDPOWE(I),IDCONT(I),IDCOLO(I) 9033 FORMAT('I,IDPOWE(I),IDCONT(I),IDCOLO(I) = ', 1I8,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9034)I,IDNVPP(I),IDNHPP(I),IDUNIT(I) 9034 FORMAT('I,IDNVPP(I),IDNHPP(I),IDUNIT(I) = ', 1I8,2X,I8,2X,I8,2X,I8) CALL DPWRST('XXX','BUG ') 9031 CONTINUE WRITE(ICOUT,9042)IMANUF,IMODEL,IMODE2,IMODE3 9042 FORMAT('IMANUF,IMODEL,IMODE2,IMODE3 = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9043)IGCONT,IGCOLO 9043 FORMAT('IGCONT,IGCOLO = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9044)NUMVPP,NUMHPP,ANUMVP,ANUMHP 9044 FORMAT('NUMVPP,NUMHPP,ANUMVP,ANUMHP = ',2I8,2E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPDIAM(IHARG,IARGT,ARG,NUMARG, 1PXSTAR,PYSTAR, 1PXEND,PYEND, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG, 1IGRASW,IDIASW, 1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1PDIAHE,PDIAWI,PDIAVG,PDIAHG, 1NUMDEV, 1IDMANU,IDMODE,IDMOD2,IDMOD3, 1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 1IDNVOF,IDNHOF, CCCCC ADD FOLLOWING LINE MARCH 1997. 1IDFONT, CCCCC ADD FOLLOWING LINE JULY 1997. 1UNITSW, 1IBUGD2,IFOUND,IERROR) C C PURPOSE--DRAW ONE OR MORE DIAMONDS C (DEPENDING ON HOW MANY NUMBERS ARE PROVIDED). C THE COORDINATES ARE IN STANDARDIZED UNITS C OF 0 TO 100. C NOTE--THE INPUT COORDINATES DEFINE 3 SUCCESSIVE POINTS C AROUND THE DIAMOND. C NOTE-THE USUAL INPUT NUMBER OF COORDINATES IS 3 C AND THEREFORE THE USUAL INPUT NUMBER OF NUMBERS IS 2*3 = 6. C NOTE--IF 4 NUMBERS ARE PROVIDED, C THEN THE DRAWN DIAMOND WILL GO C FROM THE LAST CURSOR POSITION C (ASSUMED TO BE AT ONE END OF MAJOR AXIS) C THROUGH THE (X,Y) POINT C (EITHER ABSOLUTE OR RELATIVE) C AS DEFINED BY THE FIRST AND SECOND NUMBERS C (ASSUMED TO BE AT ONE END OF MINOR AXIS), C TO THE (X,Y) POINT C (EITHER ABSOLUTE OR RELATIVE) C AS DEFINED BY THE THIRD AND FOURTH NUMBERS C (ASSUMED TO BE AT THE OTHER END OF MAJOR AXIS), C AND THEN BACK TO THE OTHER END OF THE MINOR AXIS, C AND CONTINUING BACK THE START POINT TO CLOSE THE DIAMOND. C NOTE--IF 6 NUMBERS ARE PROVIDED, C THEN THE DRAWN DIAMOND WILL GO C FROM THE ABSOLUTE (X,Y) POSITION C AS RESULTING FORM THE FIRST AND SECOND NUMBERS C (ASSUMED TO BE AT ONE END OF MAJOR AXIS), C THROUGH THE (X,Y) POINT C (EITHER ABSOLUTE OR RELATIVE) C AS DEFINED BY THE THIRD AND FOURTH NUMBERS C (ASSUMED TO BE AT ONE END OF MINOR AXIS), C TO THE (X,Y) POINT C (EITHER ABSOLUTE OR RELATIVE) C AS DEFINED BY THE FIFTH AND SIXTH NUMBERS C (ASSUMED TO BE AT THE OTHER END OF MAJOR AXIS), C AND THEN BACK TO THE OTHER END OF THE MINOR AXIS, C AND CONTINUING BACK THE START POINT TO CLOSE THE DIAMOND. C NOTE--AND SO FORTH FOR 10, 14, 18, ... NUMBERS. C INPUT ARGUMENTS--IHARG C --IARGT C --ARG C --NUMARG C --PXSTAR C --PYSTAR C OUTPUT ARGUMENTS--PXEND C --PYEND C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) 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 1981. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C UPDATED --NOVEMBER 1982. C UPDATED --JANUARY 1989. CALL LIST FOR OFFSET VAR (ALAN) C UPDATED --JANUARY 1989. SEP. UNITS FOR GR & ALPHA I/O (ALAN) C UPDATED --MARCH 1997. SUPPORT FOR DEVICE FONT (ALAN) C UPDATED --JULY 1997. SUPPORT FOR "DATA" UNITS (ALAN) C C-----NON-COMMON VARIABLES----------------------------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT C CHARACTER*4 ILINPA CHARACTER*4 ILINCO C CHARACTER*4 IREBLI CHARACTER*4 IREBCO CHARACTER*4 IREFSW CHARACTER*4 IREFCO CHARACTER*4 IREPTY CHARACTER*4 IREPLI CHARACTER*4 IREPCO C CHARACTER*4 IGRASW CHARACTER*4 IDIASW C CHARACTER*4 IDMANU CHARACTER*4 IDMODE CHARACTER*4 IDMOD2 CHARACTER*4 IDMOD3 CHARACTER*4 IDPOWE CHARACTER*4 IDCONT CHARACTER*4 IDCOLO CCCCC ADD FOLLOWING LINE MARCH 1997. CHARACTER*4 IDFONT CCCCC ADD FOLLOWING LINE JULY 1997. CHARACTER*4 UNITSW C CHARACTER*4 IFOUND CHARACTER*4 IBUGD2 CHARACTER*4 IERROR CHARACTER*4 ISUBRO C CHARACTER*4 IFIG CHARACTER*4 IBELSW CHARACTER*4 IERASW CHARACTER*4 IBACCO CHARACTER*4 ICOPSW CHARACTER*4 ITYPEO C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION ARG(*) C DIMENSION ILINPA(*) DIMENSION ILINCO(*) DIMENSION PLINTH(*) C DIMENSION AREGBA(*) DIMENSION IREBLI(*) DIMENSION IREBCO(*) DIMENSION PREBTH(*) DIMENSION IREFSW(*) DIMENSION IREFCO(*) DIMENSION IREPTY(*) DIMENSION IREPLI(*) DIMENSION IREPCO(*) DIMENSION PREPTH(*) DIMENSION PREPSP(*) C DIMENSION IDMANU(*) DIMENSION IDMODE(*) DIMENSION IDMOD2(*) DIMENSION IDMOD3(*) DIMENSION IDPOWE(*) DIMENSION IDCONT(*) DIMENSION IDCOLO(*) CCCCC ADD FOLLOWING LINE MARCH 1997. DIMENSION IDFONT(*) DIMENSION IDNVPP(*) DIMENSION IDNHPP(*) DIMENSION IDUNIT(*) C DIMENSION IDNVOF(*) DIMENSION IDNHOF(*) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOGR.INC' INCLUDE 'DPCOBE.INC' 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-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' IERRG4=IERROR CCCCC IBUGG4=IBUGD2 CCCCC ISUBG4=ISUBRO C ILOCFN=0 NUMNUM=0 C X1=0.0 Y1=0.0 X2=0.0 Y2=0.0 C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DIAM')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPDIAM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)NUMARG 53 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,NUMARG WRITE(ICOUT,56)I,IHARG(I),IARGT(I),ARG(I) 56 FORMAT('I,IHARG(I),IARGT(I),ARG(I) = ',I8,2X,A4,2X,A4,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE WRITE(ICOUT,57)PXSTAR,PYSTAR 57 FORMAT('PXSTAR,PYSTAR = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,58)PXEND,PYEND 58 FORMAT('PXEND,PYEND = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1) 61 FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',A4,2X,A4,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62)AREGBA(1) 62 FORMAT('AREGBA(1) = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1) 63 FORMAT('IREBLI(1),IREBCO(1),PREBTH(1) = ',A4,2X,A4,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,64)IREFSW(1),IREFCO(1) 64 FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) 65 FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ', 1A4,2X,A4,2X,A4,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,69)PTEXHE,PTEXWI 69 FORMAT('PTEXHE,PTEXWI= ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,70)PTEXVG,PTEXHG 70 FORMAT('PTEXVG,PTEXHG= ',2E15.6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,76)IGRASW,IDIASW 76 FORMAT('IGRASW,IDIASW = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,77)PGRAXF,PGRAYF,PDIAXC,PDIAYC 77 FORMAT('PGRAXF,PGRAYF,PDIAXC,PDIAYC = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,78)PDIAHE,PDIAWI,PDIAVG,PDIAHG 78 FORMAT('PDIAHE,PDIAWI,PDIAVG,PDIAHG = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,80)NUMDEV 80 FORMAT('NUMDEV= ',I8) CALL DPWRST('XXX','BUG ') DO81I=1,NUMDEV WRITE(ICOUT,82)IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I) 82 FORMAT('IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I) = ', 1A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,83)IDPOWE(I),IDCONT(I),IDCOLO(I) 83 FORMAT('IDPOWE(I),IDCONT(I),IDCOLO(I) = ', 1A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,84)IDNVPP(I),IDNHPP(I),IDUNIT(I) 84 FORMAT('IDNVPP(I),IDNHPP(I),IDUNIT(I) = ', 1I8,I8,I8) CALL DPWRST('XXX','BUG ') 81 CONTINUE WRITE(ICOUT,87)IFOUND 87 FORMAT('IFOUND= ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,88)IBUGG4,ISUBG4,IERRG4 88 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,89)IBUGD2,IERROR 89 FORMAT('IBUGD2,IERROR= ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C IFIG='DIAM' NUMPT=3 NUMPT2=2*NUMPT C C ******************************** C ** STEP 0-- ** C ** STEP THROUGH EACH DEVICE ** C ******************************** C IF(NUMDEV.LE.0)GOTO9000 DO8000IDEVIC=1,NUMDEV C IF(IDPOWE(IDEVIC).EQ.'OFF')GOTO8000 C IMANUF=IDMANU(IDEVIC) IMODEL=IDMODE(IDEVIC) IMODE2=IDMOD2(IDEVIC) IMODE3=IDMOD3(IDEVIC) IGCONT=IDCONT(IDEVIC) IGCOLO=IDCOLO(IDEVIC) CCCCC ADD FOLLOWING LINE MARCH 1997. IGFONT=IDFONT(IDEVIC) NUMVPP=IDNVPP(IDEVIC) NUMHPP=IDNHPP(IDEVIC) ANUMVP=NUMVPP ANUMHP=NUMHPP C AUGUST 1988. ADD OFFSET VARIABLE IOFFSV=IDNVOF(IDEVIC) IOFFSH=IDNHOF(IDEVIC) C IGUNIT=IDUNIT(IDEVIC) C C ************************************ C ** STEP 1-- ** C ** CARRY OUT OPENING OPERATIONS ** C ** ON THE GRAPHICS DEVICES ** C ************************************ C CALL DPOPDE C IBELSW='OFF' NUMRIN=0 IERASW='OFF' IBACCO='JUNK' C CALL DPOPPL(IGRASW, 1IBELSW,NUMRIN,IERASW, 1IBACCO) C C ***************************************** C ** STEP 2-- ** C ** SEARCH FOR COMMAND SPECIFICATIONS ** C ***************************************** C IF(NUMARG.GE.2.AND. 1IARGT(1).EQ.'NUMB'.AND.IARGT(2).EQ.'NUMB') 1GOTO1111 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'ABSO'.AND. 1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB') 1GOTO1112 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'RELA'.AND. 1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB') 1GOTO1113 GOTO1130 C 1111 CONTINUE ITYPEO='ABSO' ILOCFN=1 GOTO1119 C 1112 CONTINUE ITYPEO='ABSO' ILOCFN=2 GOTO1119 C 1113 CONTINUE ITYPEO='RELA' ILOCFN=2 GOTO1119 1119 CONTINUE C IF(ILOCFN.GT.NUMARG)GOTO1129 DO1120I=ILOCFN,NUMARG IF(IARGT(I).EQ.'NUMB')GOTO1120 GOTO1129 1120 CONTINUE IFOUND='YES' GOTO1149 1129 CONTINUE GOTO1130 C 1130 CONTINUE IERRG4='YES' WRITE(ICOUT,1131) 1131 FORMAT('***** ERROR IN DPDIAM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1132) 1132 FORMAT(' ILLEGAL FORM FOR DRAW ', 1'COMMAND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1134) 1134 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE ', 1'PROPER FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1135) 1135 FORMAT(' SUPPOSE IT IS DESIRED TO DRAW AN DIAMOND ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1136) 1136 FORMAT(' WITH ONE END OF MAJOR AXIS AT THE POINT 20 20 ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1137) 1137 FORMAT(' ONE END OF THE MINOR AXIS AT THE POINT 30 10') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1138) 1138 FORMAT(' AND WITH THE OTHER END OF THE MAJOR AXIS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1139) 1139 FORMAT(' AT THE POINT 40 20') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT(' THEN THE ALLOWABLE FORMS ARE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' DIAMOND 20 20 30 10 40 20 ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143) 1143 FORMAT(' DIAMOND ABSOLUTE 20 20 30 10 40 20 ') CALL DPWRST('XXX','BUG ') GOTO9000 1149 CONTINUE C C **************************** C ** STEP 3-- ** C ** DRAW OUT THE LINE(S) ** C **************************** C NUMNUM=NUMARG-ILOCFN+1 IF(NUMNUM.LT.NUMPT2)GOTO1151 GOTO1152 C 1151 CONTINUE J=ILOCFN-1 X1=PXSTAR Y1=PYSTAR GOTO1159 C 1152 CONTINUE J=ILOCFN IF(J.GT.NUMARG)GOTO1190 X1=ARG(J) CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X1,X1,IBUGD2,ISUBRO,IERROR) J=J+1 IF(J.GT.NUMARG)GOTO1190 Y1=ARG(J) CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y1,Y1,IBUGD2,ISUBRO,IERROR) GOTO1159 1159 CONTINUE C 1160 CONTINUE J=J+1 IF(J.GT.NUMARG)GOTO1190 X2=ARG(J) CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X2,X2,IBUGD2,ISUBRO,IERROR) IF(ITYPEO.EQ.'RELA')X2=X1+X2 J=J+1 IF(J.GT.NUMARG)GOTO1190 Y2=ARG(J) CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y2,Y2,IBUGD2,ISUBRO,IERROR) IF(ITYPEO.EQ.'RELA')Y2=Y1+Y2 C 1170 CONTINUE J=J+1 IF(J.GT.NUMARG)GOTO1190 X3=ARG(J) CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X3,X3,IBUGD2,ISUBRO,IERROR) IF(ITYPEO.EQ.'RELA')X3=X2+X3 J=J+1 IF(J.GT.NUMARG)GOTO1190 Y3=ARG(J) CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y3,Y3,IBUGD2,ISUBRO,IERROR) IF(ITYPEO.EQ.'RELA')Y3=Y2+Y3 C CALL DPDIA2(X1,Y1,X2,Y2,X3,Y3, 1IFIG, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG) C X1=X3 Y1=Y3 C GOTO1160 1190 CONTINUE C PXEND=X3 PYEND=Y3 C C ************************************ C ** STEP 4-- ** C ** CARRY OUT CLOSING OPERATIONS ** C ** ON THE GRAPHICS DEVICES ** C ************************************ C ICOPSW='OFF' NUMCOP=0 CALL DPCLPL(ICOPSW,NUMCOP, 1PGRAXF,PGRAYF, 1IGRASW,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1PDIAHE,PDIAWI,PDIAVG,PDIAHG) C CALL DPCLDE C 8000 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DIAM')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPDIAM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ILOCFN,NUMNUM 9012 FORMAT('ILOCFN,NUMNUM = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)X1,Y1,X2,Y2,X3,Y3 9013 FORMAT('X1,Y1,X2,Y2,X3,Y3 = ',6E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)PXSTAR,PYSTAR 9015 FORMAT('PXSTAR,PYSTAR = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)PXEND,PYEND 9016 FORMAT('PXEND,PYEND = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)IFIG 9017 FORMAT('IFIG = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9027)IFOUND 9027 FORMAT('IFOUND = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9028)IBUGG4,ISUBG4,IERRG4 9028 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9029)IBUGD2,IERROR 9029 FORMAT('IBUGD2,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPDIME(IHARG,IARGT,IARG,NUMARG,IDEMXN,IDEMXC, 1IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP,IVALUE,VALUE,NUMNAM,MAXNAM, 1V,MAXNK,NUMN,MAXN,MAXNXT, CCCCC JANUARY 1998. ADD FOLLOWING LINE. 1MAXTOM,MAXROM,MAXCOM,MAXOBV, 1NUMCOL,MAXCOL,IFOUND,IERROR,IBUGS2) C C PURPOSE--DEFINE THE MAXIMUM NUMBER OF ROWS (MAXN) C AND COLUMNS (MAXCOL) IN THE INTERNAL DATAPLOT C DATA ARRAY. C THE MAXIMUM NUMBER OF ROWS WILL BE PLACED C IN THE VARIABLE MAXN. C THE MAXIMUM NUMBER OF COLUMNS WILL BE PLACED C IN THE VARIABLE MAXCOL. C NOTE THAT THE PRODUCT OF MAXN AND MAXCOL SHOULD C NOT EXCEED THE VALUE OF MAXNK. C MAXNK DIFFERS AT DIFFERENT COMPUTER C INSTALLATIONS DEPENDENDING ON AVAILABLE MEMORY. C A TYPICAL VALUE FOR MAXNK IS 10000 . C MAXNK IS DEFINED IN THE SUBROUTINE INITDA. C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --IARG (A HOLLERITH VECTOR) C --NUMARG (AN INTEGER VARIABLE) C --IDEMXN (AN INTEGER VARIABLE) C --IDEMXC (AN INTEGER VARIABLE) C --IHNAME (A HOLLERITH VECTOR) C --IHNAM2 (A HOLLERITH VECTOR) C --IUSE (A HOLLERITH VECTOR) C --IN (AN INTEGER VECTOR) C --IVSTAR (AN INTEGER VECTOR) C --IVSTOP (AN INTEGER VECTOR) C --IVALUE (AN INTEGER VECTOR) C --VALUE (A FLOATING POINT VECTOR) C --NUMNAM (AN INTEGER VARIABLE) C --MAXNAM (AN INTEGER VARIABLE) C --V (A FLOATING POINT VECTOR) C --MAXNK (AN INTEGER VARIABLE) C --NUMN (AN INTEGER VARIABLE) C --NUMCOL (AN INTEGER VARIABLE) C OUTPUT ARGUMENTS--MAXN (AN INTEGER VARIABLE C WHICH SPECIFIES THE MAXIMUM C NUMBER OF ROWS FOR A GIVEN COLUMN C (THAT IS, THE MAXIMUM NUMBER OF C OBSERVATIONS FOR A GIVEN VARIABLE). C --MAXCOL (AN INTEGER VARIABLE C WHICH SPECIFIES THE MAXIMUM C NUMBER OF COLUMNS C (THAT IS, THE MAXIMUM NUMBER OF C VARIABLES) C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) 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--OCTOBER 1980. C UPDATED --FEBRUARY 1982. C UPDATED --MAY 1982. C UPDATED --APRIL 1985. C UPDATED --JUNE 1989. ALLOW FACTOR C UPDATED --JULY 1989. MAXCP1/2/3/4/5/6 C UPDATED --OCTOBER 1991. MOVE COMMENT LINE C UPDATED --JANUARY 1998. ADD DIMENSION MATRIX C C UPDATED --JULY 1998. SAVE AS INTERNAL PARAMETERS: C MAXROWS, MAXCOLS C MAXROWMT, MAXCOLMT C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT CHARACTER*4 IHNAME CHARACTER*4 IHNAM2 CHARACTER*4 IUSE CHARACTER*4 IFOUND CHARACTER*4 IERROR CHARACTER*4 IBUGS2 C CHARACTER*4 ITRUND CHARACTER*4 ITRUNV CHARACTER*4 IDONE C CHARACTER*1 IANS CHARACTER*4 IH CHARACTER*4 IH2 CHARACTER*4 ISUBN0 C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION IARG(*) C DIMENSION IHNAME(*) DIMENSION IHNAM2(*) DIMENSION IUSE(*) DIMENSION IN(*) DIMENSION IVSTAR(*) DIMENSION IVSTOP(*) DIMENSION IVALUE(*) DIMENSION VALUE(*) C DIMENSION V(*) C CCCCC THE FOLLOWING LINE WAS ADDED JULY 1989 INCLUDE 'DPCOM2.INC' CCCCC THE FOLLOWING LINE WAS ADDED JULY 1998 INCLUDE 'DPCOHO.INC' 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 IFOUND='YES' IERROR='NO' C ISUBN0='DIME' IANS=' ' IWIDTH=1 C ITEMPR=(-999) ITEMPC=(-999) ITEMRC=(-999) C MINR=MAXNK/MAXNAM MAXR=MAXNXT C MINC=MAXNK/MAXNXT MAXC=MAXNAM C MINRC=1 MAXRC=MAXNK C NNEW=0 IV1NEW=0 IV2NEW=0 C IF(IBUGS2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('AT THE BEGINNING OF DPDIME--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGS2 52 FORMAT('IBUGS2 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)NUMNAM,MAXNAM 53 FORMAT('NUMNAM,MAXNAM = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)MAXNK 54 FORMAT('MAXNK = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)NUMN,MAXN,MAXNXT 55 FORMAT('NUMN,MAXN,MAXNXT = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)NUMCOL,MAXCOL 56 FORMAT('NUMCOL,MAXCOL = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,57)MINR,MAXR,MINC,MAXC,MINRC,MAXRC 57 FORMAT('MINR,MAXR,MINC,MAXC,MINRC,MAXRC = ',6I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61) 61 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),', 1'IVSTAR(I),IVSTOP(I),IVALUE(I),VALUE(I)') CALL DPWRST('XXX','BUG ') IF(NUMNAM.LE.0)GOTO64 DO62I=1,NUMNAM WRITE(ICOUT,63)I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I), 1IVSTAR(I),IVSTOP(I),IVALUE(I),VALUE(I) 63 FORMAT(I8,2X,A4,2X,A4,2X,A4,4I8,E15.7) CALL DPWRST('XXX','BUG ') 62 CONTINUE 64 CONTINUE 90 CONTINUE C C **************************************** C ** STEP 11-- ** C ** DETERMINE THE DESIRED DIMENSIONS ** C **************************************** C IF(NUMARG.LE.1)GOTO1130 C CCCCC JANUARY 1998. ADD FOLLOWING FOR MATRIX DIMENSIONS C IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MATR')THEN IF(NUMARG.GE.2.AND.IHARG(2).EQ.'COLU')THEN IF(NUMARG.GE.3.AND.IARGT(3).EQ.'NUMB')THEN MAXCOM=IARG(3) IF(MAXCOM.GT.SQRT(REAL(MAXTOM)))MAXCOM=SQRT(REAL(MAXTOM)) IF(MAXCOM.LT.MAXTOM/MAXOBV)MAXCOM=MAXTOM/MAXOBV MAXROM=MAXTOM/MAXCOM IF(MAXROM.GT.MAXN)MAXROM=MAXN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,901)MAXROM CALL DPWRST('XXX','BUG ') WRITE(ICOUT,902)MAXCOM CALL DPWRST('XXX','BUG ') GOTO950 ELSE GOTO990 ENDIF ELSEIF(NUMARG.GE.3.AND.IHARG(3).EQ.'COLU')THEN IF(IARGT(2).EQ.'NUMB')THEN MAXCOM=IARG(2) IF(MAXCOM.GT.SQRT(REAL(MAXTOM)))MAXCOM=SQRT(REAL(MAXTOM)) IF(MAXCOM.LT.MAXTOM/MAXOBV)MAXCOM=MAXTOM/MAXOBV MAXROM=MAXTOM/MAXCOM IF(MAXROM.GT.MAXN)MAXROM=MAXN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,901)MAXROM CALL DPWRST('XXX','BUG ') WRITE(ICOUT,902)MAXCOM CALL DPWRST('XXX','BUG ') GOTO950 ELSE GOTO990 ENDIF ELSEIF(NUMARG.GE.2.AND.IHARG(2)(1:3).EQ.'ROW')THEN IF(NUMARG.GE.3.AND.IARGT(3).EQ.'NUMB')THEN MAXROM=IARG(3) IF(MAXROM.GT.MAXOBV)MAXROM=MAXOBV IF(MAXROM.LT.SQRT(REAL(MAXTOM)))MAXROM=SQRT(REAL(MAXTOM)) IF(MAXROM.GT.MAXN)MAXROM=MAXN MAXCOM=MAXTOM/MAXROM WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,901)MAXROM CALL DPWRST('XXX','BUG ') WRITE(ICOUT,902)MAXCOM CALL DPWRST('XXX','BUG ') GOTO950 ELSE GOTO990 ENDIF ELSEIF(NUMARG.GE.3.AND.IHARG(3)(1:3).EQ.'ROW')THEN IF(IARGT(2).EQ.'NUMB')THEN MAXROM=IARG(2) IF(MAXROM.GT.MAXOBV)MAXROM=MAXOBV IF(MAXROM.LT.SQRT(REAL(MAXTOM)))MAXROM=SQRT(REAL(MAXTOM)) IF(MAXROM.GT.MAXN)MAXROM=MAXN MAXCOM=MAXTOM/MAXROM WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,901)MAXROM CALL DPWRST('XXX','BUG ') WRITE(ICOUT,902)MAXCOM CALL DPWRST('XXX','BUG ') GOTO950 ELSE GOTO990 ENDIF ELSE GOTO990 ENDIF ENDIF GOTO980 C 950 CONTINUE IH='MAXR' IH2='OWMT' VALUE0=MAXROM CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGS2,IERROR) C IH='MAXC' IH2='OLMT' VALUE0=MAXCOM CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGS2,IERROR) C GOTO9000 C 901 FORMAT('THE MAXIMUM NUMBER OF MAXTRIX ROWS SET TO ',I5) 902 FORMAT('THE MAXIMUM NUMBER OF MAXTRIX COLUMNS SET TO ',I5) C 980 CONTINUE IF(NUMARG.LE.2.AND.IARGT(1).EQ.'NUMB'.AND. 1IARGT(2).EQ.'NUMB')GOTO1140 IF(NUMARG.LE.2.AND.IARGT(1).EQ.'NUMB'.AND. 1IARGT(2).NE.'NUMB')GOTO1150 C IF(NUMARG.LE.4.AND.IARGT(1).EQ.'NUMB'.AND. 1IARGT(2).NE.'NUMB'.AND.IARGT(3).EQ.'NUMB'.AND. 1IARGT(4).NE.'NUMB')GOTO1160 C 990 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1111) 1111 FORMAT('***** ERROR IN DPDIME--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1112) 1112 FORMAT(' ILLEGAL FORM FOR THE DIMENSION COMMAND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1113) 1113 FORMAT(' RECOMMENDED FORMS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1114) 1114 FORMAT(' DIMENSION 1000 OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1115) 1115 FORMAT(' DIMENSION 10 VARIABLES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1121) 1121 FORMAT(' OTHER ALLOWABLE FORMS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1122) 1122 FORMAT(' DIMENSION 1000 ROWS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1123) 1123 FORMAT(' DIMENSION 10 COLUMNS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1124) 1124 FORMAT(' DIMENSION 1000 OBSERVATIONS 10 VARIABLES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1125) 1125 FORMAT(' DIMENSION 10 VARIABLES 1000 OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1126) 1126 FORMAT(' DIMENSION 1000 ROWS 10 COLUMNS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1127) 1127 FORMAT(' DIMENSION 10 COLUMNS 1000 ROWS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1128) 1128 FORMAT(' DIMENSION 1000 10') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 1130 CONTINUE ITEMPR=IDEMXN ITEMPC=IDEMXC GOTO1190 C 1140 CONTINUE ITEMPR=IARG(1) ITEMPC=IARG(2) GOTO1190 C 1150 CONTINUE IF(IHARG(2).EQ.'ROW')GOTO1151 IF(IHARG(2).EQ.'ROWS')GOTO1151 IF(IHARG(2).EQ.'LINE')GOTO1151 IF(IHARG(2).EQ.'OBSE')GOTO1151 IF(IHARG(2).EQ.'COLU')GOTO1152 IF(IHARG(2).EQ.'VARI')GOTO1152 GOTO1151 1151 CONTINUE ITEMPR=IARG(1) IF(ITEMPR.LE.1)ITEMPR=1 ITEMPC=MAXNK/ITEMPR GOTO1190 1152 CONTINUE ITEMPC=IARG(1) IF(ITEMPC.LE.1)ITEMPC=1 ITEMPR=MAXNK/ITEMPC GOTO1190 C 1160 CONTINUE IF(IHARG(2).EQ.'ROW')GOTO1161 IF(IHARG(2).EQ.'ROWS')GOTO1161 IF(IHARG(2).EQ.'LINE')GOTO1161 IF(IHARG(2).EQ.'OBSE')GOTO1161 IF(IHARG(2).EQ.'COLU')GOTO1162 IF(IHARG(2).EQ.'VARI')GOTO1162 CCCCC THE FOLLOWING LINE WAS ADDED JULY 1989 IF(IHARG(2).EQ.'FACT')GOTO1162 GOTO1161 1161 CONTINUE ITEMPR=IARG(1) ITEMPC=IARG(3) GOTO1190 1162 CONTINUE ITEMPC=IARG(1) ITEMPR=IARG(3) GOTO1190 C 1190 CONTINUE ITEMRC=ITEMPR*ITEMPC C C ************************************* C ** STEP 12-- ** C ** DETERMINE IF THE SPECIFIED ** C ** OBSERVATIONS(= ROW) DIMENSION ** C ** IS TOO SMALL OR LARGE. ** C ************************************* C IF(MINR.LE.ITEMPR.AND.ITEMPR.LE.MAXR)GOTO1290 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1211) 1211 FORMAT('***** ERROR IN DPDIME--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1212) 1212 FORMAT(' THE OBSERVATIONS (= ROW) DIMENSION') CALL DPWRST('XXX','BUG ') IF(ITEMPR.LT.MINR) 1WRITE(ICOUT,1213) 1213 FORMAT(' IS TOO SMALL.') IF(ITEMPR.LT.MINR) 1CALL DPWRST('XXX','BUG ') IF(ITEMPR.GT.MAXR) 1WRITE(ICOUT,1214) 1214 FORMAT(' IS TOO LARGE.') IF(ITEMPR.GT.MAXR) 1CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1215)MINR,MAXR 1215 FORMAT(' IT MUST BE BETWEEN ',I8,' & ',I8,' (INCLUSIVE)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1216)ITEMPR 1216 FORMAT(' THE SPECIFIED VALUE IS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1217) 1217 FORMAT(' NO REDIMENSIONING WAS CARRIED OUT.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1290 CONTINUE C C ************************************* C ** STEP 13-- ** C ** DETERMINE IF THE SPECIFIED ** C ** VARIABLES(= COLUMN) DIMENSION ** C ** IS TOO LARGE. ** C ************************************* C IF(MINC.LE.ITEMPC.AND.ITEMPC.LE.MAXC)GOTO1390 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1311) 1311 FORMAT('***** ERROR IN DPDIME--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1312) 1312 FORMAT(' THE VARIABLES (= COLUMN) DIMENSION') CALL DPWRST('XXX','BUG ') IF(ITEMPC.LT.MINC) 1WRITE(ICOUT,1313) 1313 FORMAT(' IS TOO SMALL.') IF(ITEMPC.LT.MINC) 1CALL DPWRST('XXX','BUG ') IF(ITEMPC.GT.MAXC) 1WRITE(ICOUT,1314) 1314 FORMAT(' IS TOO LARGE.') IF(ITEMPC.GT.MAXC) 1CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1315)MINC,MAXC 1315 FORMAT(' IT MUST BE BETWEEN ',I8,' & ',I8,' (INCLUSIVE)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1316)ITEMPC 1316 FORMAT(' THE SPECIFIED VALUE IS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1317) 1317 FORMAT(' NO REDIMENSIONING WAS CARRIED OUT.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1390 CONTINUE C C ************************************* C ** STEP 14-- ** C ** DETERMINE IF THE COMBINED ** C ** DIMENSION (= ROW X COLUMN) ** C ** IS TOO LARGE. ** C ************************************* C IF(MINRC.LE.ITEMRC.AND.ITEMRC.LE.MAXRC)GOTO1490 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1411) 1411 FORMAT('***** ERROR IN DPDIME--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1412) 1412 FORMAT(' THE JOINT ROW AND COLUMN DIMENSIONS') CALL DPWRST('XXX','BUG ') IF(ITEMRC.LT.MINRC) 1WRITE(ICOUT,1413) 1413 FORMAT(' IS TOO SMALL.') IF(ITEMRC.LT.MINRC) 1CALL DPWRST('XXX','BUG ') IF(ITEMRC.GT.MAXRC) 1WRITE(ICOUT,1414) 1414 FORMAT(' IS TOO LARGE.') IF(ITEMRC.GT.MAXRC) 1CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1415) 1415 FORMAT(' THEIR PRODUCT MUST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1416)MINRC,MAXRC 1416 FORMAT(' BE BETWEEN ',I8,' & ',I8,' (INCLUSIVE)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1417)ITEMRC 1417 FORMAT(' THEIR PRODUCT IS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1418) 1418 FORMAT(' NO REDIMENSIONING WAS CARRIED OUT.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1490 CONTINUE C C ***************************** C ** STEP 15-- ** C ** SET THE DIMENSIONS ** C ** TO THE DESIRED VALUES ** C ***************************** C MAXNOL=MAXN MAXN=ITEMPR MAXCOL=ITEMPC MAXNNE=MAXN C CCCCC THE FOLLOWING 6 LINES WERE ADDED JULY 1989 MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C C ******************************** C ** STEP 16-- ** C ** PRINT OUT THE DIMENSIONS ** C ******************************** C IF(IFEEDB.EQ.'OFF')GOTO1619 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1613) 1613 FORMAT('DIMENSION INFORMATION--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1614)MAXNK 1614 FORMAT(' MAXIMUM DATA ARRAY SIZE = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1615)MAXN 1615 FORMAT(' MAXIMUM NUMBER OBS/VARIABLE (ROWS) = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1616)MAXCOL 1616 FORMAT(' MAXIMUM NUMBER VARIABLES (COLUMNS) = ',I8) CALL DPWRST('XXX','BUG ') 1619 CONTINUE C IH='MAXR' IH2='OWS ' VALUE0=MAXN CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGS2,IERROR) C IH='MAXC' IH2='OLS ' VALUE0=MAXCOL CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGS2,IERROR) C C C ************************************* C ** STEP 13-- ** C ** DETERMINE IF ANY OBSERVATIONS ** C ** NEED TO BE TRUNCATED ** C ************************************* C ITRUND='NO' C CCCCC THE FOLLOWING LINE WAS COMMENTED OUT OCTOBER 1991 CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') IF(IBUGS2.EQ.'OFF')GOTO2009 CCCCC THE FOLLOWING LINE WAS ADDED OCTOBER 1991 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2001) 2001 FORMAT('FROM THE MIDDLE OF DPDIME--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2002)NUMCOL,NUMNAM,IBUGS2 2002 FORMAT('NUMCOL,NUMNAM,IBUGS2 = ',I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') 2009 CONTINUE C IF(NUMCOL.LE.0)GOTO2190 DO2100ICOL=1,NUMCOL ICOLTG=ICOL IF(MAXNNE.GT.MAXNOL)ICOLTG=NUMCOL-ICOL+1 IF(IBUGS2.EQ.'ON')WRITE(ICOUT,999) IF(IBUGS2.EQ.'ON')CALL DPWRST('XXX','BUG ') IF(IBUGS2.EQ.'ON')WRITE(ICOUT,2101)MAXNNE,MAXNOL,ICOL,ICOLTG 2101 FORMAT('MAXNNE,MAXNOL,ICOL,ICOLTG = ',4I8) IF(IBUGS2.EQ.'ON')CALL DPWRST('XXX','BUG ') C IDONE='NO' IF(NUMNAM.LE.0)GOTO2190 DO2200INAM=1,NUMNAM IF(IVALUE(INAM).EQ.ICOLTG.AND.IUSE(INAM).EQ.'V')GOTO2210 GOTO2200 2210 CONTINUE C IF(IDONE.EQ.'YES')GOTO2390 NOLD=IN(INAM) IV1OLD=IVSTAR(INAM) IV2OLD=IVSTOP(INAM) C IF(NOLD.LE.MAXNNE)NNEW=NOLD IF(NOLD.GT.MAXNNE)NNEW=MAXNNE IF(NOLD.LE.MAXNNE)GOTO2219 IF(IFEEDB.EQ.'OFF')GOTO2218 WRITE(ICOUT,2211)IHNAME(INAM),IHNAM2(INAM),ICOLTG 2211 FORMAT(' NOTE--VARIABLE ',A4,A4,' (COLUMN ',I8,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2212)NOLD,MAXNNE 2212 FORMAT(' TRUNCATED FROM ',I8,' TO ',I8, 1' OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2213) 2213 FORMAT(' IN THE PROCESS OF REDIMENSIONING') CALL DPWRST('XXX','BUG ') 2218 CONTINUE ITRUND='YES' 2219 CONTINUE C IV1NEW=MAXNNE*(ICOLTG-1)+1 IV2NEW=MAXNNE*(ICOLTG-1)+NNEW IF(IBUGS2.EQ.'ON')WRITE(ICOUT,2221)NOLD,MAXNNE,NNEW 2221 FORMAT('NOLD,MAXNNE,NNEW = ',3I8) IF(IBUGS2.EQ.'ON')CALL DPWRST('XXX','BUG ') IF(IBUGS2.EQ.'ON')WRITE(ICOUT,2222)IV1OLD,IV2OLD,IV1NEW,IV2NEW 2222 FORMAT('IV1OLD,IV2OLD,IV1NEW,IV2NEW = ',4I8) IF(IBUGS2.EQ.'ON')CALL DPWRST('XXX','BUG ') C J=IV1OLD-1 IF(IV1NEW.GT.IV1OLD)GOTO2390 DO2300I=IV1NEW,IV2NEW J=J+1 V(I)=V(J) 2300 CONTINUE 2380 CONTINUE IDONE='YES' 2390 CONTINUE C IVSTAR(INAM)=IV1NEW IVSTOP(INAM)=IV2NEW IN(INAM)=NNEW IF(IBUGS2.EQ.'ON')WRITE(ICOUT,2391)INAM,IVSTAR(INAM),IVSTOP(INAM), 1IN(INAM) 2391 FORMAT('INAM,IVSTAR(INAM),IVSTOP(INAM),IN(INAM) = ',4I8) IF(IBUGS2.EQ.'ON')CALL DPWRST('XXX','BUG ') 2200 CONTINUE C 2100 CONTINUE 2190 CONTINUE C IF(ITRUND.EQ.'YES')GOTO2199 IF(IFEEDB.EQ.'OFF')GOTO2199 WRITE(ICOUT,2191) 2191 FORMAT(' NOTE--NO DATA TRUNCATION OCCURRED FOR ANY ', 1'VARIABLES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2192) 2192 FORMAT(' (COLUMNS) IN THE PROCESS OF REDIMENSIONING') CALL DPWRST('XXX','BUG ') 2199 CONTINUE C C ********************************** C ** STEP 14-- ** C ** DETERMINE IF ANY VARIABLES ** C ** NEED TO BE TRUNCRATED ** C ********************************** C ITRUNV='NO' C IF(NUMCOL.LE.MAXCOL)GOTO3190 NUMCOL=MAXCOL IDONE='NO' C IF(NUMNAM.LE.0)GOTO3190 INAM=0 3100 CONTINUE INAM=INAM+1 IF(INAM.GT.NUMNAM)GOTO3200 IF(IUSE(INAM).EQ.'V'.AND.IVALUE(INAM).GT.MAXCOL)GOTO3210 GOTO3200 C 3210 CONTINUE NUMNAM=NUMNAM-1 ICOLV=IVALUE(INAM) IF(IFEEDB.EQ.'OFF')GOTO3219 WRITE(ICOUT,3211)IHNAME(INAM),IHNAM2(INAM),ICOLV 3211 FORMAT(' NOTE--VARIABLE ',A4,A4,' (COLUMN ',I8,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3212) 3212 FORMAT(' DELETED IN THE PROCESS OF REDIMENSIONING') CALL DPWRST('XXX','BUG ') 3219 CONTINUE ITRUNV='YES' C NUMNM1=NUMNAM-1 IF(INAM.GT.NUMNM1)GOTO3229 DO3220I=INAM,NUMNM1 IP1=I+1 IHNAME(I)=IHNAME(IP1) IHNAM2(I)=IHNAM2(IP1) IUSE(I)=IUSE(IP1) IN(I)=IN(IP1) IVSTAR(I)=IVSTAR(IP1) IVSTOP(I)=IVSTOP(IP1) IVALUE(I)=IVALUE(IP1) VALUE(I)=VALUE(IP1) 3220 CONTINUE 3229 CONTINUE NUMNAM=NUMNAM-1 C 3200 CONTINUE C 3190 CONTINUE C IF(ITRUNV.EQ.'YES')GOTO3199 IF(IFEEDB.EQ.'OFF')GOTO3199 WRITE(ICOUT,3191) 3191 FORMAT(' NOTE--NO VARIABLES WERE DELETED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3192) 3192 FORMAT(' IN THE PROCESS OF REDIMENSIONING') CALL DPWRST('XXX','BUG ') 3199 CONTINUE C C *************************************** C ** STEP 15-- ** C ** REDEFINE THE COLUMN DESIGNATION ** C ** FOR PRED (PREDICTED VALUE) ** C ** RES (RESIDUALS) ** C ** YPLOT ** C ** XPLOT ** C ** X2PLOT ** C ** TAGPLOT ** C *************************************** C IF(NUMNAM.LE.0)GOTO4900 C DO4100I=1,NUMNAM I2=I IF(IHNAME(I).EQ.'PRED'.AND.IHNAM2(I).EQ.' ')GOTO4150 4100 CONTINUE GOTO4190 4150 CONTINUE IVALUE(I2)=MAXCOL+1 VALUE(I2)=IVALUE(I2) GOTO4190 4190 CONTINUE C DO4200I=1,NUMNAM I2=I IF(IHNAME(I).EQ.'RES '.AND.IHNAM2(I).EQ.' ')GOTO4250 4200 CONTINUE GOTO4290 4250 CONTINUE IVALUE(I2)=MAXCOL+2 VALUE(I2)=IVALUE(I2) GOTO4290 4290 CONTINUE C DO4300I=1,NUMNAM I2=I IF(IHNAME(I).EQ.'YPLO'.AND.IHNAM2(I).EQ.'T ')GOTO4350 4300 CONTINUE GOTO4390 4350 CONTINUE IVALUE(I2)=MAXCOL+3 VALUE(I2)=IVALUE(I2) GOTO4390 4390 CONTINUE C DO4400I=1,NUMNAM I2=I IF(IHNAME(I).EQ.'XPLO'.AND.IHNAM2(I).EQ.'T ')GOTO4450 4400 CONTINUE GOTO4490 4450 CONTINUE IVALUE(I2)=MAXCOL+4 VALUE(I2)=IVALUE(I2) GOTO4490 4490 CONTINUE C DO4500I=1,NUMNAM I2=I IF(IHNAME(I).EQ.'X2PL'.AND.IHNAM2(I).EQ.'OT ')GOTO4550 4500 CONTINUE GOTO4590 4550 CONTINUE IVALUE(I2)=MAXCOL+5 VALUE(I2)=IVALUE(I2) GOTO4590 4590 CONTINUE C DO4600I=1,NUMNAM I2=I IF(IHNAME(I).EQ.'TAGP'.AND.IHNAM2(I).EQ.'LOT ')GOTO4650 4600 CONTINUE GOTO4690 4650 CONTINUE IVALUE(I2)=MAXCOL+6 VALUE(I2)=IVALUE(I2) GOTO4690 4690 CONTINUE C 4900 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGS2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('AT THE END OF DPDIME--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGS2 9012 FORMAT('IBUGS2 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NUMNAM,MAXNAM 9013 FORMAT('NUMNAM,MAXNAM = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)MAXNK 9014 FORMAT('MAXNK = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)NUMN,MAXN,MAXNXT 9015 FORMAT('NUMN,MAXN,MAXNXT = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)NUMCOL,MAXCOL 9016 FORMAT('NUMCOL,MAXCOL = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)MINR,MAXR,MINC,MAXC,MINRC,MAXRC 9017 FORMAT('MINR,MAXR,MINC,MAXC,MINRC,MAXRC = ',6I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9018)ITEMPR,ITEMPC,ITEMRC 9018 FORMAT('ITEMPR,ITEMPC,ITEMRC = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021) 9021 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),', 1'IVSTAR(I),IVSTOP(I),IVALUE(I),VALUE(I)') CALL DPWRST('XXX','BUG ') IF(NUMNAM.LE.0)GOTO9024 DO9022I=1,NUMNAM WRITE(ICOUT,9023)I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I), 1IVSTAR(I),IVSTOP(I),IVALUE(I),VALUE(I) 9023 FORMAT(I8,2X,A4,2X,A4,2X,A4,4I8,E15.7) CALL DPWRST('XXX','BUG ') 9022 CONTINUE 9024 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPDOT(IFOUND,IERROR) C C PURPOSE--THIS IS A SUBROUTINE FOR THE C . COMMAND (A NULL COMMAND). C THIS CAPABILITY IS USEFUL FOR PROVIDING A VISUAL C SEPARATOR BETWEEN SECTIONS OF STORED DATAPLOT C CODE ON MASS STORAGE, OR FOR COMMENTING OUT C A GIVEN LINE OF DATAPLOT CODE. C INPUT ARGUMENTS--NONE C OUTPUT ARGUMENTS--IFOUND ('YES' OR 'NO') C --IERROR ('YES' OR 'NO' ) 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 1978. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C --NOVEMBER 1980. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IFOUND CHARACTER*4 IERROR 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 IFOUND='NO' IERROR='NO' C IFOUND='YES' GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPDOUB(IHARG,NUMARG,IDEFPR,IHMXPR, 1IPREC,IFOUND,IERROR) C C PURPOSE--DEFINE THE PREICSION SWITCH C AS DOUBLE PRECISION. C THIS IN TURN SPECIFIES THAT SUBSEQUENT C CALCULATIONS WILL ALL BE CARRIED OUT C IN DOUBLE PRECISION. C THE SPECIFIED PRECISION SWITCH SPECIFICATION C WILL BE PLACED IN THE HOLLERITH VARIABLE IPREC. C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --NUMARG (AN INTEGER VARIABLE) C --IDEFPR (A HOLLERITH VARIABLE) C --IHMXPR (A HOLLERITH VARIABLE) C OUTPUT ARGUMENTS--IPREC (A HOLLERITH VARIABLE) C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) 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 1980. C UPDATED --SEPTEMBER 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IDEFPR CHARACTER*4 IHMXPR CHARACTER*4 IPREC CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD C C--------------------------------------------------------------------- C DIMENSION IHARG(*) 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 IFOUND='NO' IERROR='NO' C IFOUND='YES' C 1110 CONTINUE IF(NUMARG.LE.0)GOTO1120 IF(IHARG(NUMARG).EQ.'ON')GOTO1130 IF(IHARG(NUMARG).EQ.'OFF')GOTO1120 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1130 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1120 GOTO1130 C 1120 CONTINUE IHOLD=IDEFPR GOTO1160 C 1130 CONTINUE IHOLD='DOUB' GOTO1160 C 1160 CONTINUE IF(IHOLD.EQ.'DOUB'.AND.IHMXPR.EQ.'SING')GOTO1170 IF(IHOLD.EQ.'TRIP'.AND.IHMXPR.EQ.'SING')GOTO1170 IF(IHOLD.EQ.'TRIP'.AND.IHMXPR.EQ.'DOUB')GOTO1170 IF(IHOLD.EQ.'QUAD'.AND.IHMXPR.EQ.'SING')GOTO1170 IF(IHOLD.EQ.'QUAD'.AND.IHMXPR.EQ.'DOUB')GOTO1170 IF(IHOLD.EQ.'QUAD'.AND.IHMXPR.EQ.'TRIP')GOTO1170 GOTO1180 C 1170 CONTINUE IERROR='YES' WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1172) 1172 FORMAT('***** ERROR IN DPDOUB--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1173) 1173 FORMAT(' THE DESIRED PRECISION IS HIGHER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1174) 1174 FORMAT(' THAN PERMITTED ON THIS COMPUTER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1175)IHOLD 1175 FORMAT(' DESIRED PRECISION = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1176)IHMXPR 1176 FORMAT(' MAXIMUM ALLOWABLE PRECISION = ',A4) CALL DPWRST('XXX','BUG ') GOTO1199 C 1180 CONTINUE IPREC=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1188)IPREC 1188 FORMAT('THE PRECISION SWITCH HAS JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPDRA2(X1,Y1,X2,Y2, 1IFIG, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG) C C PURPOSE--DRAW A LINE C WITH ONE END OF THE LINE AT (X1,Y1) C AND THE OTHER END AT (X2,Y2). 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 1981. C UPDATED --MAY 1982. C UPDATED --JANUARY 1989. MODIFY CALLS TO DPDRPL (ALAN) C UPDATED --JANUARY 1989. MODIFY CALL TO DPFIRE (ALAN) C C-----NON-COMMON VARIABLES------------------------------------- C CHARACTER*4 IFIG CHARACTER*4 IPATT2 C CHARACTER*4 ILINPA CHARACTER*4 ILINCO C CHARACTER*4 IREBLI CHARACTER*4 IREBCO CHARACTER*4 IREFSW CHARACTER*4 IREFCO CHARACTER*4 IREPTY CHARACTER*4 IREPLI CHARACTER*4 IREPCO C CHARACTER*4 IPATT CHARACTER*4 ICOLF CHARACTER*4 ICOLP CHARACTER*4 ICOL CHARACTER*4 IFLAG C DIMENSION PX(10) DIMENSION PY(10) CCCCC DIMENSION PX3(10) CCCCC DIMENSION PY3(10) C DIMENSION ILINPA(*) DIMENSION ILINCO(*) DIMENSION PLINTH(*) C DIMENSION AREGBA(*) DIMENSION IREBLI(*) DIMENSION IREBCO(*) DIMENSION PREBTH(*) DIMENSION IREFSW(*) DIMENSION IREFCO(*) DIMENSION IREPTY(*) DIMENSION IREPLI(*) DIMENSION IREPCO(*) DIMENSION PREPTH(*) DIMENSION PREPSP(*) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOGR.INC' INCLUDE 'DPCOBE.INC' 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-----START POINT----------------------------------------------------- C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRA2')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPDRA2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)X1,Y1 53 FORMAT('X1,Y1 = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)X2,Y2 54 FORMAT('X2,Y2 = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,59)IFIG 59 FORMAT('IFIG = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1) 61 FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',A4,2X,A4,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62)AREGBA(1) 62 FORMAT('AREGBA(1) = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1) 63 FORMAT('IREBLI(1),IREBCO(1),PREBTH(1) = ',A4,2X,A4,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,64)IREFSW(1),IREFCO(1) 64 FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) 65 FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ', 1A4,2X,A4,2X,A4,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,69)PTEXHE,PTEXWI 69 FORMAT('PTEXHE,PTEXWI= ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,70)PTEXVG,PTEXHG 70 FORMAT('PTEXVG,PTEXHG= ',2E15.6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,79)IBUGG4,ISUBG4,IERRG4 79 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ********************************* C ** STEP 1-- ** C ** DETERMINE THE COORDINATES ** C ** FOR THE LINE ** C ********************************* C PX(1)=X1 PY(1)=Y1 C PX(2)=X2 PY(2)=Y2 C NP=2 C C C *********************** C ** STEP 2-- ** C ** FILL THE FIGURE ** C ** (IF CALLED FOR) ** C *********************** C IF(IREFSW(1).EQ.'OFF')GOTO2190 IPATT=IREPTY(1) IPATT2='SOLI' PTHICK=PREPTH(1) PXGAP=PREPSP(1) PYGAP=PREPSP(1) ICOLF=IREFCO(1) ICOLP=IREPCO(1) CALL DPFIRE(PX,PY,NP, 1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,IPATT2) 2190 CONTINUE C C *************************** C ** STEP 3-- ** C ** DRAW OUT THE FIGURE ** C *************************** C IPATT=ILINPA(1) PTHICK=PLINTH(1) ICOL=ILINCO(1) IFLAG='ON' CCCCC CALL DPDRPL(PX,PY,NP,PX3,PY3,NP3, CCCCC1IFIG,IPATT,PTHICK,ICOL) CALL DPDRPL(PX,PY,NP, 1IFIG,IPATT,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRA2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPDRA2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NP 9013 FORMAT('NP = ',I8) CALL DPWRST('XXX','BUG ') DO9015I=1,NP WRITE(ICOUT,9016)I,PX(I),PY(I) 9016 FORMAT('I,PX(I),PY(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE WRITE(ICOUT,9039)IBUGG4,ISUBG4,IERRG4 9039 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPDRAW(IHARG,IARGT,ARG,NUMARG, 1PXSTAR,PYSTAR, 1PXEND,PYEND, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG, 1IGRASW,IDIASW, 1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1PDIAHE,PDIAWI,PDIAVG,PDIAHG, 1NUMDEV, 1IDMANU,IDMODE,IDMOD2,IDMOD3, 1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 1IDNVOF,IDNHOF, CCCCC ADD FOLLOWING LINE MARCH 1997. 1IDFONT, CCCCC THE FOLLOWING LINE WAS ADDED SEPTEMBER 1994 CCCCC AND THEN CHANGED FEBRUARY 1995 CCCCC1UNITSW, 1X1UNIT,Y1UNIT,X2UNIT,Y2UNIT, 1IBUGD2,IFOUND,IERROR) C C PURPOSE--DRAW ONE OR MORE LINES C (DEPENDING ON HOW MANY NUMBERS ARE PROVIDED). C THE COORDINATES ARE IN STANDARDIZED UNITS C OF 0 TO 100. C NOTE--THE INPUT COORDINATES DEFINE THE ENDS C OF THE LINE SEGMENTS. C NOTE-THE USUAL INPUT NUMBER OF COORDINATES IS 2 C AND THEREFORE THE USUAL INPUT NUMBER OF NUMBERS IS 2*2 = 4. C NOTE--IF 2 NUMBERS ARE PROVIDED, C THEN THE DRAWN LINE WILL GO C FROM THE LAST CURSOR POSITION C TO THE (X,Y) POINT C (EITHER ABSOLUTE OR RELATIVE) C AS DEFINED BY THE 2 NUMBERS. C NOTE--IF 4 NUMBERS ARE PROVIDED, C THEN THE DRAWN LINE WILL GO C FROM THE ABSOLUTE (X,Y) POSITION C AS DEFINED BY THE FIRST 2 NUMBERS C TO THE (X,Y) POINT C (EITHER ABSOLUTE OR RELATIVE) C AS DEFINED BY THE THIRD AND FOURTH NUMBERS. C NOTE--IF 6 NUMBERS ARE PROVIDED, C THEN THE DRAWN LINE WILL GO C FROM THE (X,Y) POSITION C AS RESULTING FROM THE THIRD AND FOURTH NUMBERS C TO THE (X,Y) POINT C (EITHER ABSOLUTE OR RELATIVE) C AS DEFINED BY THE FIFTH AND SIXTH NUMBERS. C NOTE--AND SO FORTH FOR 8, 10, 12, ... NUMBERS. C INPUT ARGUMENTS--IHARG C --IARGT C --ARG C --NUMARG C --PXSTAR C --PYSTAR C OUTPUT ARGUMENTS--PXEND C --PYEND C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) 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 1981. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C UPDATED --NOVEMBER 1982. C UPDATED --JANUARY 1989. CALL LIST FOR OFFSET VAR (ALAN) C UPDATED --SEPTEMBER 1994. UNITS SWITCH (DATA OR SCREEN) C UPDATED --FEBRUARY 1995. GENERALIZED DRAW.... COMMAND C UPDATED --MARCH 1997. SUPPORT FOR DEVICE FONT (ALAN) C C-----NON-COMMON VARIABLES----------------------------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT C CHARACTER*4 ILINPA CHARACTER*4 ILINCO C CHARACTER*4 IREBLI CHARACTER*4 IREBCO CHARACTER*4 IREFSW CHARACTER*4 IREFCO CHARACTER*4 IREPTY CHARACTER*4 IREPLI CHARACTER*4 IREPCO C CHARACTER*4 IGRASW CHARACTER*4 IDIASW C CHARACTER*4 IDMANU CHARACTER*4 IDMODE CHARACTER*4 IDMOD2 CHARACTER*4 IDMOD3 CHARACTER*4 IDPOWE CHARACTER*4 IDCONT CHARACTER*4 IDCOLO CCCCC ADD FOLLOWING LINE MARCH 1997. CHARACTER*4 IDFONT C CHARACTER*4 IFOUND CHARACTER*4 IBUGD2 CHARACTER*4 IERROR C CHARACTER*4 IFIG CHARACTER*4 IBELSW CHARACTER*4 IERASW CHARACTER*4 IBACCO CHARACTER*4 ICOPSW CHARACTER*4 ITYPEO CHARACTER*4 ISUBRO C CCCCC THE FOLLOWING LINE WAS ADDED SEPTEMBER 1994 CCCCC AND THEN CHANGED FEBRUARY 1995 CCCCC CHARACTER*4 UNITSW CHARACTER*4 X1UNIT CHARACTER*4 Y1UNIT CHARACTER*4 X2UNIT CHARACTER*4 Y2UNIT C C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION ARG(*) C DIMENSION ILINPA(*) DIMENSION ILINCO(*) DIMENSION PLINTH(*) C DIMENSION AREGBA(*) DIMENSION IREBLI(*) DIMENSION IREBCO(*) DIMENSION PREBTH(*) DIMENSION IREFSW(*) DIMENSION IREFCO(*) DIMENSION IREPTY(*) DIMENSION IREPLI(*) DIMENSION IREPCO(*) DIMENSION PREPTH(*) DIMENSION PREPSP(*) C DIMENSION IDMANU(*) DIMENSION IDMODE(*) DIMENSION IDMOD2(*) DIMENSION IDMOD3(*) DIMENSION IDPOWE(*) DIMENSION IDCONT(*) DIMENSION IDCOLO(*) CCCCC ADD FOLLOWING LINE MARCH 1997. DIMENSION IDFONT(*) DIMENSION IDNVPP(*) DIMENSION IDNHPP(*) DIMENSION IDUNIT(*) C DIMENSION IDNVOF(*) DIMENSION IDNHOF(*) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOGR.INC' INCLUDE 'DPCOBE.INC' 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-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' IERRG4=IERROR CCCCC IBUGG4=IBUGD2 CCCCC ISUBG4=ISUBRO C ILOCFN=0 NUMNUM=0 C X1=0.0 Y1=0.0 X2=0.0 Y2=0.0 C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRAW')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPDRAW--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)NUMARG 53 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,NUMARG WRITE(ICOUT,56)I,IHARG(I),IARGT(I),ARG(I) 56 FORMAT('I,IHARG(I),IARGT(I),ARG(I) = ',I8,2X,A4,2X,A4,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE WRITE(ICOUT,57)PXSTAR,PYSTAR 57 FORMAT('PXSTAR,PYSTAR = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,58)PXEND,PYEND 58 FORMAT('PXEND,PYEND = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1) 61 FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',A4,2X,A4,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62)AREGBA(1) 62 FORMAT('AREGBA(1) = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1) 63 FORMAT('IREBLI(1),IREBCO(1),PREBTH(1) = ',A4,2X,A4,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,64)IREFSW(1),IREFCO(1) 64 FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) 65 FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ', 1A4,2X,A4,2X,A4,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,69)PTEXHE,PTEXWI 69 FORMAT('PTEXHE,PTEXWI= ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,70)PTEXVG,PTEXHG 70 FORMAT('PTEXVG,PTEXHG= ',2E15.6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,76)IGRASW,IDIASW 76 FORMAT('IGRASW,IDIASW = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,77)PGRAXF,PGRAYF,PDIAXC,PDIAYC 77 FORMAT('PGRAXF,PGRAYF,PDIAXC,PDIAYC = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,78)PDIAHE,PDIAWI,PDIAVG,PDIAHG 78 FORMAT('PDIAHE,PDIAWI,PDIAVG,PDIAHG = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,80)NUMDEV 80 FORMAT('NUMDEV= ',I8) CALL DPWRST('XXX','BUG ') DO81I=1,NUMDEV WRITE(ICOUT,82)IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I) 82 FORMAT('IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I) = ', 1A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,83)IDPOWE(I),IDCONT(I),IDCOLO(I) 83 FORMAT('IDPOWE(I),IDCONT(I),IDCOLO(I) = ', 1A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,84)IDNVPP(I),IDNHPP(I),IDUNIT(I) 84 FORMAT('IDNVPP(I),IDNHPP(I),IDUNIT(I) = ', 1I8,I8,I8) CALL DPWRST('XXX','BUG ') 81 CONTINUE WRITE(ICOUT,85)X1UNIT,Y1UNIT,X2UNIT,Y2UNIT 85 FORMAT('X1UNIT,Y1UNIT,X2UNIT,Y2UNIT= ',4A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,87)IFOUND 87 FORMAT('IFOUND= ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,88)IBUGG4,ISUBG4,IERRG4 88 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,89)IBUGD2,IERROR 89 FORMAT('IBUGD2,IERROR= ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C IFIG='LINE' NUMPT=2 NUMPT2=2*NUMPT C C ******************************** C ** STEP 0-- ** C ** STEP THROUGH EACH DEVICE ** C ******************************** C IF(NUMDEV.LE.0)GOTO9000 DO8000IDEVIC=1,NUMDEV C IF(IDPOWE(IDEVIC).EQ.'OFF')GOTO8000 C IMANUF=IDMANU(IDEVIC) IMODEL=IDMODE(IDEVIC) IMODE2=IDMOD2(IDEVIC) IMODE3=IDMOD3(IDEVIC) IGCONT=IDCONT(IDEVIC) IGCOLO=IDCOLO(IDEVIC) CCCCC ADD FOLLOWING LINE MARCH 1997. IGFONT=IDFONT(IDEVIC) NUMVPP=IDNVPP(IDEVIC) NUMHPP=IDNHPP(IDEVIC) ANUMVP=NUMVPP ANUMHP=NUMHPP C AUGUST 1988. ADD OFFSET VARIABLE IOFFSV=IDNVOF(IDEVIC) IOFFSH=IDNHOF(IDEVIC) C IGUNIT=IDUNIT(IDEVIC) C C ************************************ C ** STEP 1-- ** C ** CARRY OUT OPENING OPERATIONS ** C ** ON THE GRAPHICS DEVICES ** C ************************************ C CALL DPOPDE C IBELSW='OFF' NUMRIN=0 IERASW='OFF' IBACCO='JUNK' C CALL DPOPPL(IGRASW, 1IBELSW,NUMRIN,IERASW, 1IBACCO) C C ***************************************** C ** STEP 2-- ** C ** SEARCH FOR COMMAND SPECIFICATIONS ** C ***************************************** C IF(NUMARG.GE.2.AND. 1IARGT(1).EQ.'NUMB'.AND.IARGT(2).EQ.'NUMB') 1GOTO1111 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'ABSO'.AND. 1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB') 1GOTO1112 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'RELA'.AND. 1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB') 1GOTO1113 GOTO1130 C 1111 CONTINUE ITYPEO='ABSO' ILOCFN=1 GOTO1119 C 1112 CONTINUE ITYPEO='ABSO' ILOCFN=2 GOTO1119 C 1113 CONTINUE ITYPEO='RELA' ILOCFN=2 GOTO1119 1119 CONTINUE C IF(ILOCFN.GT.NUMARG)GOTO1129 DO1120I=ILOCFN,NUMARG IF(IARGT(I).EQ.'NUMB')GOTO1120 GOTO1129 1120 CONTINUE IFOUND='YES' GOTO1149 1129 CONTINUE GOTO1130 C 1130 CONTINUE IERRG4='YES' WRITE(ICOUT,1131) 1131 FORMAT('***** ERROR IN DPDRAW--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1132) 1132 FORMAT(' ILLEGAL FORM FOR DRAW ', 1'COMMAND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1134) 1134 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE ', 1'PROPER FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1135) 1135 FORMAT(' SUPPOSE IT IS DESIRED TO DRAW A LINE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1136) 1136 FORMAT(' WITH ONE END AT THE POINT 20 20 ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1137) 1137 FORMAT(' AND WITH OPPOSITE END AT THE POINT 40 60') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT(' THEN THE ALLOWABLE FORMS ARE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' DRAW 20 20 40 60 ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143) 1143 FORMAT(' DRAW ABSOLUTE 20 20 40 60 ') CALL DPWRST('XXX','BUG ') GOTO9000 1149 CONTINUE C C **************************** C ** STEP 3-- ** C ** DRAW OUT THE LINE(S) ** C **************************** C NUMNUM=NUMARG-ILOCFN+1 IF(NUMNUM.LT.NUMPT2)GOTO1151 GOTO1152 C 1151 CONTINUE J=ILOCFN-1 X1=PXSTAR Y1=PYSTAR GOTO1159 C 1152 CONTINUE J=ILOCFN IF(J.GT.NUMARG)GOTO1190 X1=ARG(J) CCCCC THE FOLLOWING LINE WAS ADDED SEPTEMBER 1994 CCCCC AND THEN CHANGED FEBRUARY 1995 CCCCC IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X1,X1,IBUGD2,ISUBRO,IERROR) IF(X1UNIT.EQ.'DATA')CALL DPCODS('X',X1,X1,IBUGD2,ISUBRO,IERROR) J=J+1 IF(J.GT.NUMARG)GOTO1190 Y1=ARG(J) CCCCC THE FOLLOWING LINE WAS ADDED SEPTEMBER 1994 CCCCC AND THEN CHANGED FEBRUARY 1995 CCCCC IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y1,Y1,IBUGD2,ISUBRO,IERROR) IF(Y1UNIT.EQ.'DATA')CALL DPCODS('Y',Y1,Y1,IBUGD2,ISUBRO,IERROR) GOTO1159 1159 CONTINUE C 1160 CONTINUE J=J+1 IF(J.GT.NUMARG)GOTO1190 X2=ARG(J) CCCCC THE FOLLOWING LINE WAS ADDED SEPTEMBER 1994 CCCCC AND THEN CHANGED FEBRUARY 1995 CCCCC IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X2,X2,IBUGD2,ISUBRO,IERROR) IF(X2UNIT.EQ.'DATA')CALL DPCODS('X',X2,X2,IBUGD2,ISUBRO,IERROR) IF(ITYPEO.EQ.'RELA')X2=X1+X2 J=J+1 IF(J.GT.NUMARG)GOTO1190 Y2=ARG(J) CCCCC THE FOLLOWING LINE WAS ADDED SEPTEMBER 1994 CCCCC AND THEN CHANGED FEBRUARY 1995 CCCCC IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y2,Y2,IBUGD2,ISUBRO,IERROR) IF(Y2UNIT.EQ.'DATA')CALL DPCODS('Y',Y2,Y2,IBUGD2,ISUBRO,IERROR) IF(ITYPEO.EQ.'RELA')Y2=Y1+Y2 C 1170 CONTINUE CALL DPDRA2(X1,Y1,X2,Y2, 1IFIG, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG) C X1=X2 Y1=Y2 C GOTO1160 1190 CONTINUE C PXEND=X2 PYEND=Y2 C C ************************************ C ** STEP 4-- ** C ** CARRY OUT CLOSING OPERATIONS ** C ** ON THE GRAPHICS DEVICES ** C ************************************ C ICOPSW='OFF' NUMCOP=0 CALL DPCLPL(ICOPSW,NUMCOP, 1PGRAXF,PGRAYF, 1IGRASW,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1PDIAHE,PDIAWI,PDIAVG,PDIAHG) C CALL DPCLDE C 8000 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRAW')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPDRAW--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ILOCFN,NUMNUM 9012 FORMAT('ILOCFN,NUMNUM = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)X1,Y1,X2,Y2 9013 FORMAT('X1,Y1,X2,Y2 = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)PXSTAR,PYSTAR 9015 FORMAT('PXSTAR,PYSTAR = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)PXEND,PYEND 9016 FORMAT('PXEND,PYEND = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)IFIG 9017 FORMAT('IFIG = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9027)IFOUND 9027 FORMAT('IFOUND = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9028)IBUGG4,ISUBG4,IERRG4 9028 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9029)IBUGD2,IERROR 9029 FORMAT('IBUGD2,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPDRBA(Y,X,PY,PX,NP, 1ICASPL,ICAS3D, 1ISORSW, 1IBA2SW,ABA2WI,ABA2BA, 1IBA2BL,IBA2BC,PBA2BT, 1IBA2FS,IBA2FC, 1IBA2PT,IBA2PL,IBA2PC,IBA2TY,IBA2DI,PBA2PS,PBA2PT, 1XDELMN, 1PXMIN,PXMAX,PYMIN,PYMAX, 1FX1MIN,FX1MAX,FY1MIN,FY1MAX, 1IX1TSC,IY1TSC) C C PURPOSE--FOR A GENERAL GRAPHICS DEVICE, C AND FOR EACH VALUE IN X(.), DRAW A BAR C (= VERTICAL OR HORIZONTAL BAR) C FROM THE BASE POINT ABA2BA C TO THE POINT Y(.). C DO SO FOR A SPECIFIED BAR LINE TYPE, C LINES COLOR, AND LINE THICKNESS. C NOTE--THE VARIABLES PY(.) AND PX(.) ARE DUMMY VARIABLES C WHICH ARE USED IN THE INTERMEDIATE CALCULATIONS C AND WHOSE DIMENSIONS ARE DEFINED (FOR EASY OF CHANGE) C BACK IN THE MAIN ROUTINE. 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--87.5 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY 1983. C UPDATED--MAY 1987. C --JANUARY 1989. GLOBAL REPLACE ABA2BA WITH ABA2BA (ALAN) C UPDATED--FEBRUARY 1989. GRDRPL TO DPDRPL (ALAN) C UPDATED--FEBRUARY 1989. EXTRA ARGUMENT IN CALL TO DPFIRE (ALAN) C UPDATED--FEBRUARY 1989. BUG WITH PATTERN ON 1ST BAR ONLY (ALAN) C UPDATED--FEBRUARY 1989. NO SORT IF ICASPL='CONT' C --FEBRUARY 1989. RENUMBER C C-----NON-COMMON VARIABLES (GRAPHICS)------------------------------------------- C CHARACTER*4 ICASPL CHARACTER*4 ICAS3D C CHARACTER*4 ISORSW C CHARACTER*4 IBA2SW CHARACTER*4 IBA2BL CHARACTER*4 IBA2BC CHARACTER*4 IBA2FS CHARACTER*4 IBA2FC CHARACTER*4 IBA2PT CHARACTER*4 IBA2PL CHARACTER*4 IBA2PC CHARACTER*4 IBA2TY CHARACTER*4 IBA2DI C CHARACTER*4 IX1TSC CHARACTER*4 IY1TSC C CHARACTER*4 ITYPE C CHARACTER*4 IFIG CHARACTER*4 IPATT CHARACTER*4 ICOL CHARACTER*4 ICOLF CHARACTER*4 ICOLP CHARACTER*4 IDIR C CCCCC CHARACTER*4 IHORPA CCCCC CHARACTER*4 IVERPA CCCCC CHARACTER*4 IDUPPA CCCCC CHARACTER*4 IDDOPA C CHARACTER*4 IFIGSV CHARACTER*4 IFLAG CHARACTER*4 IPATT2 C DIMENSION Y(*) DIMENSION X(*) DIMENSION PY(*) DIMENSION PX(*) C DIMENSION PY2(20) DIMENSION PX2(20) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOGR.INC' INCLUDE 'DPCOBE.INC' 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-----START POINT----------------------------------------------------- C HOLD=1.0 ABASE=0.0 PBASE=0.0 PBASE2=0.0 PLEFT=0.0 PRIGHT=0.0 AWIDTH=0.0 PWIDTH=0.0 C FXMIN=FX1MIN FXMAX=FX1MAX FYMIN=FY1MIN FYMAX=FY1MAX C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRBA')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPDRBA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NP 52 FORMAT('NP = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASPL,ICAS3D 53 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)XDELMN 54 FORMAT('XDELMN = ',E15.7) CALL DPWRST('XXX','BUG ') IF(NP.LE.3)GOTO69 DO65I=1,3 WRITE(ICOUT,66)I,X(I),Y(I) 66 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 65 CONTINUE NPM2=NP-2 DO67I=NPM2,NP WRITE(ICOUT,68)I,X(I),Y(I) 68 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 67 CONTINUE 69 CONTINUE WRITE(ICOUT,70)ISORSW 70 FORMAT('ISORSW = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71)IBA2SW,ABA2WI,ABA2BA 71 FORMAT('IBA2SW,ABA2WI,ABA2BA = ',A4,2X,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)IBA2BL,IBA2BC,PBA2BT 72 FORMAT('IBA2BL,IBA2BC,PBA2BT = ',A4,2X,A4,2X,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,73)IBA2FS,IBA2FC 73 FORMAT('IBA2FS,IBA2FC = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,74)IBA2PT,IBA2PL,IBA2PC,IBA2TY,IBA2DI,PBA2PS,PBA2PT 74 FORMAT('IBA2PT,IBA2PL,IBA2PC,IBA2TY,IBA2DI,PBA2PS,PBA2PT = ', 1A4,2X,A4,2X,A4,2X,A4,2X,A4,2X,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,84)PXMIN,PXMAX,PYMIN,PYMAX 84 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX= ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,85)FX1MIN,FX1MAX,FY1MIN,FY1MAX 85 FORMAT('FX1MIN,FX1MAX,FY1MIN,FY1MAX= ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,86)IX1TSC,IY1TSC 86 FORMAT('IX1TSC,IY1TSC = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,89)IBUGG4,ISUBG4,IERRG4 89 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ************************************************* C ** STEP 11-- ** C ** IF CALLED FOR, SORT THE DATA ** C ** ACCORDING TO THE HORIZONTAL AXIS VARIABLE ** C ************************************************* C IDIR=IBA2DI C IF(ISORSW.EQ.'OFF')GOTO1150 IF(ICASPL.EQ.'PIEC')GOTO1150 IF(ICAS3D.EQ.'ON')GOTO1150 IF(ICASPL.EQ.'CONT')GOTO1150 C CALL SORTC2(X,Y,NP,PX,PY) GOTO1190 C 1150 CONTINUE DO1160I=1,NP PX(I)=X(I) PY(I)=Y(I) 1160 CONTINUE GOTO1190 C 1190 CONTINUE C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRBA')GOTO1199 WRITE(ICOUT,1194)IPR 1194 FORMAT('IPR=',I4) CALL DPWRST('XXX','BUG ') DO1192I=1,10 WRITE(ICOUT,1196) I,PX(I),PY(I) 1196 FORMAT('I,PX(I),PY(I)=',I4,2X,E15.7,2X,E15.7) CALL DPWRST('XXX','BUG ') 1192 CONTINUE 1199 CONTINUE C C ************************************************ C ** STEP 12-- ** C ** IF A LOG SCALE PLOT IS CALLED FOR, ** C ** CHECK THAT ALL DATA POINTS ARE POSITIVE. ** C ************************************************ C IF(IX1TSC.EQ.'LOG')GOTO1210 GOTO1290 C 1210 CONTINUE IF(IDIR.EQ.'H')GOTO1215 GOTO1219 1215 CONTINUE IF(ABA2BA.LE.0.0)HOLD=ABA2BA IF(ABA2BA.LE.0.0)GOTO1250 1219 CONTINUE C IF(ISORSW.EQ.'ON')GOTO1220 GOTO1230 C 1220 CONTINUE J=1 IF(PX(J).LE.0.0)GOTO1250 GOTO1290 C 1230 CONTINUE DO1235I=1,NP J=I IF(PX(J).LE.0.0)GOTO1250 1235 CONTINUE GOTO1290 C 1250 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1251) 1251 FORMAT('***** ERROR IN DPDRBA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1252) 1252 FORMAT(' THE LOG OF A NON-POSITIVE DATA VALUE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1253) 1253 FORMAT(' WAS ENCOUNTERED IN FORMING A PLOT.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1254) 1254 FORMAT(' DATA MAY NOT BE ZERO OR NEGATIVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1255) 1255 FORMAT(' WHEN A LOG SCALE PLOT IS USED.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1256)PX(J) 1256 FORMAT(' THE VALUE = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1257) 1257 FORMAT(' THIS VALUE CAME FROM THE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1258) 1258 FORMAT(' HORIZONTAL AXIS VARIABLE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1259) 1259 FORMAT(' CORRECTIVE ACTION--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1260) 1260 FORMAT(' CHANGE DATA OR CHANGE LIMITS.') CALL DPWRST('XXX','BUG ') IERRG4='YES' GOTO9000 C 1290 CONTINUE C IF(IY1TSC.EQ.'LOG')GOTO1310 GOTO1390 C 1310 CONTINUE IF(IDIR.EQ.'V')GOTO1315 GOTO1319 1315 CONTINUE IF(ABA2BA.LE.0.0)HOLD=ABA2BA IF(ABA2BA.LE.0.0)GOTO1350 1319 CONTINUE C IF(ISORSW.EQ.'ON')GOTO1320 GOTO1330 C 1320 CONTINUE J=1 IF(PY(J).LE.0.0)HOLD=PY(J) IF(PY(J).LE.0.0)GOTO1350 GOTO1390 C 1330 CONTINUE DO1335I=1,NP J=I IF(PY(J).LE.0.0)HOLD=PY(J) IF(PY(J).LE.0.0)GOTO1350 1335 CONTINUE GOTO1390 C 1350 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1351) 1351 FORMAT('***** ERROR IN DPDRBA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1352) 1352 FORMAT(' THE LOG OF A NON-POSITIVE DATA VALUE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1353) 1353 FORMAT(' WAS ENCOUNTERED IN FORMING A PLOT.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1354) 1354 FORMAT(' DATA MAY NOT BE ZERO OR NEGATIVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1355) 1355 FORMAT(' WHEN A LOG SCALE PLOT IS USED.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1356)HOLD 1356 FORMAT(' THE VALUE = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1357) 1357 FORMAT(' THIS VALUE CAME FROM THE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1358) 1358 FORMAT(' VERTICAL AXIS VARIABLE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1359) 1359 FORMAT(' CORRECTIVE ACTION--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1360) 1360 FORMAT(' CHANGE DATA OR CHANGE LIMITS.') CALL DPWRST('XXX','BUG ') IERRG4='YES' GOTO9000 C 1390 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRBA')GOTO1399 WRITE(ICOUT,1391) 1391 FORMAT('AT BRANCH POINT 1390') CALL DPWRST('XXX','BUG ') 1399 CONTINUE C C ****************************************** C ** STEP 40-- ** C ** IF A LOG SCALE PLOT IS CALLED FOR, ** C ** TRANSFORM THE DATA ** C ****************************************** C ABASE=ABA2BA AWIDTH=ABA2WI C IF(IDIR.EQ.'V')GOTO4001 GOTO4002 4001 CONTINUE IF(AWIDTH.EQ.CPUMIN.AND.XDELMN.LE.0.0)AWIDTH=1.0 IF(AWIDTH.EQ.CPUMIN.AND.XDELMN.GT.0.0)AWIDTH=XDELMN 4002 CONTINUE C IF(IDIR.EQ.'H')GOTO4003 GOTO4004 4003 CONTINUE CCCCC IF(AWIDTH.EQ.CPUMIN.AND.YDELMN.LE.0.0)AWIDTH=1.0 CCCCC IF(AWIDTH.EQ.CPUMIN.AND.YDELMN.GT.0.0)AWIDTH=XDELMN IF(AWIDTH.EQ.CPUMIN.AND.XDELMN.LE.0.0)AWIDTH=1.0 IF(AWIDTH.EQ.CPUMIN.AND.XDELMN.GT.0.0)AWIDTH=XDELMN 4004 CONTINUE C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRBA')GOTO4009 WRITE(ICOUT,4008) ABASE,AWIDTH 4008 FORMAT('ABASE,AWIDTH=',E15.7,1X,E15.7) CALL DPWRST('XXX','BUG ') 4009 CONTINUE C IF(IX1TSC.EQ.'LOG')GOTO4010 GOTO4019 4010 CONTINUE IF(IDIR.EQ.'H')ABASE=ALOG10(ABASE) DO4015I=1,NP PX(I)=ALOG10(PX(I)) 4015 CONTINUE 4019 CONTINUE C IF(IY1TSC.EQ.'LOG')GOTO4020 GOTO4029 4020 CONTINUE IF(IDIR.EQ.'V')ABASE=ALOG10(ABASE) DO4025I=1,NP PY(I)=ALOG10(PY(I)) 4025 CONTINUE 4029 CONTINUE C C ***************************************************** C ** STEP 50-- ** C ** TRANSLATE THE DATA POINTS ** C ** INTO STANDARDIZED (0.0 TO 100.0) COORDINATES. ** C ***************************************************** C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRBA')GOTO5001 WRITE(ICOUT,4999) 4999 FORMAT( 'AT 5001 BREAKPOINT') CALL DPWRST('XXX','BUG ') 5001 CONTINUE C FXMIN=FX1MIN FXMAX=FX1MAX IF(IX1TSC.EQ.'LOG')FXMIN=ALOG10(FX1MIN) IF(IX1TSC.EQ.'LOG')FXMAX=ALOG10(FX1MAX) C FYMIN=FY1MIN FYMAX=FY1MAX IF(IY1TSC.EQ.'LOG')FYMIN=ALOG10(FY1MIN) IF(IY1TSC.EQ.'LOG')FYMAX=ALOG10(FY1MAX) C FXRANG=FXMAX-FXMIN FYRANG=FYMAX-FYMIN PXRANG=PXMAX-PXMIN PYRANG=PYMAX-PYMIN C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRBA')GOTO5002 WRITE(ICOUT,4993) FXMIN,FXMAX,FYMIN,FYMAX 4993 FORMAT('FXMIN,FXMAX,FYMIN,FYMAX=',4(E15.7,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4994) FXRANG,FYRANG,PXRANG,PYRANG 4994 FORMAT('FXRANG,FYRANG,PXRANG,PYRANG=',6(E15.7,1X)) CALL DPWRST('XXX','BUG ') 5002 CONTINUE C DO5000I=1,NP FXRATI=(PX(I)-FXMIN)/FXRANG FYRATI=(PY(I)-FYMIN)/FYRANG PX(I)=PXMIN+FXRATI*PXRANG PY(I)=PYMIN+FYRATI*PYRANG 5000 CONTINUE C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRBA')GOTO5003 DO5004I=1,NP WRITE(ICOUT,5006) PX(I),PY(I) 5006 FORMAT('PX(I),PY(I)=',2(E15.7,1X)) CALL DPWRST('XXX','BUG ') 5004 CONTINUE 5003 CONTINUE C IF(IDIR.EQ.'V')GOTO5010 GOTO5019 5010 CONTINUE FYRATI=(ABASE-FYMIN)/FYRANG PBASE=PYMIN+FYRATI*PYRANG PWIDTH=AWIDTH*(PXRANG/FXRANG) 5019 CONTINUE C IF(IDIR.EQ.'H')GOTO5020 GOTO5029 5020 CONTINUE FXRATI=(ABASE-FXMIN)/FXRANG PBASE=PXMIN+FXRATI*PXRANG PWIDTH=AWIDTH*(PYRANG/FYRANG) 5029 CONTINUE C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRBA')GOTO5039 WRITE(ICOUT,5038) FXRATI,PBASE,PWIDTH 5038 FORMAT('FXRATI,PBASE,PWIDTH=',3(E15.7,1X)) CALL DPWRST('XXX','BUG ') 5039 CONTINUE C C ******************************* C ** STEP 70-- ** C ** PREPARE TO MAKE VARIOUS ** C ** LINE SETTINGS ** C ******************************* C ITYPE='LINE' C C ********************************************** C ** STEP 71-- ** C ** TRANSLATE THE CHARACTER REPRESENTATION ** C ** OF THE LINE PATTERN ** C ** INTO A NUMERIC REPRESENTATION ** C ** WHICH CAN BE UNDERSTOOD BY THE ** C ** GRAPHICS DEVICE. ** C ********************************************** C CCCCC IPATT=IBA2BL CCCCC CALL GRTRPA(ITYPE,IPATT,PXSPA,PYSPA, CCCCC1JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXSPA2,PYSPA2) C C ******************************* C ** STEP 72-- ** C ** SET THE LINE PATTERN ** C ** ON THE GRAPHICS DEVICE. ** C ******************************* C CCCCC CALL GRSEPA(ITYPE,IPATT,PXSPA,PYSPA, CCCCC1JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXSPA2,PYSPA2) C C ********************************************** C ** STEP 73-- ** C ** TRANSLATE THE DESIRED ** C ** LINE THICKNESS ** C ** INTO A NUMERIC REPRESENTATION ** C ** WHICH CAN BE UNDERSTOOD BY THE ** C ** GRAPHICS DEVICE. ** C ********************************************** C CCCCC PTHICK=PBA2BT CCCCC CALL GRTRTH(ITYPE,PTHICK,JTHICK,PTHIC2) C C ******************************* C ** STEP 74-- ** C ** SET THE LINE THICKNESS ** C ** ON THE GRAPHICS DEVICE. ** C ******************************* C CCCCC CALL GRSETH(ITYPE,PTHICK,JTHICK,PTHIC2) C C ********************************************** C ** STEP 75-- ** C ** TRANSLATE THE CHARACTER REPRESENTATION ** C ** OF THE LINE COLOR ** C ** INTO A NUMERIC REPRESENTATION ** C ** WHICH CAN BE UNDERSTOOD BY THE ** C ** GRAPHICS DEVICE. ** C ********************************************** C CCCCC ICOL=IBA2BC CCCCC CALL GRTRCO(ITYPE,ICOL,JCOL) C C ******************************* C ** STEP 76-- ** C ** SET THE LINE COLOR ** C ** ON THE GRAPHICS DEVICE. ** C ******************************* C CCCCC CALL GRSECO(ITYPE,ICOL,JCOL) C C ************************************** C ** STEP 80-- ** C ** DRAW AND FILL BARS ** C ** (BUT CLIP FIRST, IF NECESSARY) ** C ************************************** C CCCCC IFIG='GENE' IFIG='BOX' IF(IBA2TY.EQ.'3')IFIG='CUBE' IFIGSV=IFIG PBASE2=PBASE C CALL DPSQUE(PX,PY,NP, 1PXMIN,PXMAX,PYMIN,PYMAX) C C *************************************** C ** STEP 81-- ** C ** DRAW OUT ALL VERTICAL BARS ** C ** (BUT FILL FIRST, IF CALLED FOR) ** C *************************************** C IF(IDIR.EQ.'V')GOTO8100 GOTO8190 C 8100 CONTINUE C SEPTEMBER, 1987 - MOVE SETTINGS INSIDE THE LOOP CCCCC IPATT=IBA2PT CCCCC PTHICK=PBA2PT CCCCC PXGAP=PBA2PS CCCCC PYGAP=PBA2PS CCCCC ICOLF=IBA2FC CCCCC ICOLP=IBA2PC C IF(PBASE2.LT.PYMIN.AND.(PYMIN-PBASE2).LE.0.0001)PBASE2=PYMIN IF(PBASE2.GT.PYMAX.AND.(PBASE2-PYMAX).LE.0.0001)PBASE2=PYMAX C DO8105I=1,NP C IPATT=IBA2PT IPATT2=IBA2PL PTHICK=PBA2PT PXGAP=PBA2PS PYGAP=PBA2PS ICOLF=IBA2FC ICOLP=IBA2PC C PLEFT=PX(I)-PWIDTH/2.0 PRIGHT=PX(I)+PWIDTH/2.0 IF(PLEFT.LT.PXMIN.AND.(PXMIN-PLEFT).LE.0.0001)PLEFT=PXMIN IF(PRIGHT.GT.PXMAX.AND.(PRIGHT-PXMAX).LE.0.0001)PRIGHT=PXMAX C IF(PRIGHT.LT.PXMIN)GOTO8105 IF(PLEFT.GT.PXMAX)GOTO8105 IF(PY(I).LT.PYMIN.AND.PBASE2.LT.PYMIN)GOTO8105 IF(PY(I).GT.PYMAX.AND.PBASE2.GT.PYMAX)GOTO8105 C X1=PLEFT Y1=PBASE2 X2=PRIGHT Y2=PY(I) C DELX=ABS(X2-X1) DELY=ABS(Y2-Y1) DELMIN=DELX CCCCC IF(DELY.LT.DELX)DELMIN=DELY P3D=0.3 DEL3D=P3D*DELMIN C IF(IBA2FS.EQ.'OFF')GOTO8150 C IF(IBA2FS.EQ.'ON')GOTO8110 IF(IBA2FS.EQ.'ONF')GOTO8110 IF(IBA2FS.EQ.'ONS')GOTO8120 IF(IBA2FS.EQ.'ONT')GOTO8130 IF(IBA2FS.EQ.'ONFS')GOTO8110 IF(IBA2FS.EQ.'ONSF')GOTO8110 IF(IBA2FS.EQ.'ONFT')GOTO8110 IF(IBA2FS.EQ.'ONTF')GOTO8110 IF(IBA2FS.EQ.'ONST')GOTO8120 IF(IBA2FS.EQ.'ONTS')GOTO8120 C C FRONT FACE C 8110 CONTINUE PX2(1)=X1 PY2(1)=Y1 C PX2(2)=X2 PY2(2)=Y1 C PX2(3)=X2 PY2(3)=Y2 C PX2(4)=X1 PY2(4)=Y2 C PX2(5)=X1 PY2(5)=Y1 C NP2=5 C DO8115J=1,NP2 IF(PX2(J).LT.PXMIN)PX2(J)=PXMIN IF(PX2(J).GT.PXMAX)PX2(J)=PXMAX IF(PY2(J).LT.PYMIN)PY2(J)=PYMIN IF(PY2(J).GT.PYMAX)PY2(J)=PYMAX 8115 CONTINUE CALL DPFIRE(PX2,PY2,NP2, 1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP, 1IPATT2) C IF(IBA2TY.EQ.'2')GOTO8150 C IF(IBA2FS.EQ.'ON')GOTO8120 IF(IBA2FS.EQ.'ONF')GOTO8150 IF(IBA2FS.EQ.'ONS')GOTO8120 IF(IBA2FS.EQ.'ONT')GOTO8130 IF(IBA2FS.EQ.'ONFS')GOTO8120 IF(IBA2FS.EQ.'ONSF')GOTO8120 IF(IBA2FS.EQ.'ONFT')GOTO8130 IF(IBA2FS.EQ.'ONTF')GOTO8130 IF(IBA2FS.EQ.'ONST')GOTO8120 IF(IBA2FS.EQ.'ONTS')GOTO8120 C C SIDE (= RIGHT) FACE C 8120 CONTINUE IF(IBA2TY.EQ.'2')GOTO8150 PX2(1)=X2 PY2(1)=Y2 C PX2(2)=X2+DEL3D PY2(2)=Y2+DEL3D C PX2(3)=X2+DEL3D PY2(3)=Y1+DEL3D C PX2(4)=X2 PY2(4)=Y1 C PX2(5)=X2 PY2(5)=Y2 C NP2=5 C DO8125J=1,NP2 IF(PX2(J).LT.PXMIN)PX2(J)=PXMIN IF(PX2(J).GT.PXMAX)PX2(J)=PXMAX IF(PY2(J).LT.PYMIN)PY2(J)=PYMIN IF(PY2(J).GT.PYMAX)PY2(J)=PYMAX 8125 CONTINUE CALL DPFIRE(PX2,PY2,NP2, 1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP, 1IPATT2) C IF(IBA2FS.EQ.'ON')GOTO8130 IF(IBA2FS.EQ.'ONF')GOTO8150 IF(IBA2FS.EQ.'ONS')GOTO8150 IF(IBA2FS.EQ.'ONT')GOTO8130 IF(IBA2FS.EQ.'ONFS')GOTO8150 IF(IBA2FS.EQ.'ONSF')GOTO8150 IF(IBA2FS.EQ.'ONFT')GOTO8130 IF(IBA2FS.EQ.'ONTF')GOTO8130 IF(IBA2FS.EQ.'ONST')GOTO8130 IF(IBA2FS.EQ.'ONTS')GOTO8130 C C TOP FACE C 8130 CONTINUE IF(IBA2TY.EQ.'2')GOTO8150 PX2(1)=X1 PY2(1)=Y2 C PX2(2)=X1+DEL3D PY2(2)=Y2+DEL3D C PX2(3)=X2+DEL3D PY2(3)=Y2+DEL3D C PX2(4)=X2 PY2(4)=Y2 C PX2(5)=X1 PY2(5)=Y2 C NP2=5 C DO8135J=1,NP2 IF(PX2(J).LT.PXMIN)PX2(J)=PXMIN IF(PX2(J).GT.PXMAX)PX2(J)=PXMAX IF(PY2(J).LT.PYMIN)PY2(J)=PYMIN IF(PY2(J).GT.PYMAX)PY2(J)=PYMAX 8135 CONTINUE CALL DPFIRE(PX2,PY2,NP2, 1IFIG,IPATT,PTHICK,PX2GAP,PYGAP,ICOLF,ICOLP, 1IPATT2) C 8150 CONTINUE C C DRAW OUT THE EDGES OF THE BAR C IPATT=IBA2BL PTHICK=PBA2BT ICOL=IBA2BC C PX2(1)=X1 PY2(1)=Y1 C PX2(2)=X2 PY2(2)=Y1 C PX2(3)=X2 PY2(3)=Y2 C PX2(4)=X1 PY2(4)=Y2 C PX2(5)=X1 PY2(5)=Y1 C NP2=5 C DO8151J=1,NP2 IF(PX2(J).LT.PXMIN)PX2(J)=PXMIN IF(PX2(J).GT.PXMAX)PX2(J)=PXMAX IF(PY2(J).LT.PYMIN)PY2(J)=PYMIN IF(PY2(J).GT.PYMAX)PY2(J)=PYMAX 8151 CONTINUE IFLAG='ON' CCCCC CALL GRDRPL(PX2,PY2,NP2, CCCCC1IFIG,IPATT,PTHICK,ICOL, CCCCC1JPATT,JTHICK,PTHIC2,JCOL) CALL DPDRPL(PX2,PY2,NP2, 1IFIG,IPATT,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) C IF(IBA2TY.EQ.'2')GOTO8105 C PX2(1)=X1 PY2(1)=Y2 C PX2(2)=X1+DEL3D PY2(2)=Y2+DEL3D C PX2(3)=X2+DEL3D PY2(3)=Y2+DEL3D C PX2(4)=X2 PY2(4)=Y2 C NP2=4 C DO8152J=1,NP2 IF(PX2(J).LT.PXMIN)PX2(J)=PXMIN IF(PX2(J).GT.PXMAX)PX2(J)=PXMAX IF(PY2(J).LT.PYMIN)PY2(J)=PYMIN IF(PY2(J).GT.PYMAX)PY2(J)=PYMAX 8152 CONTINUE IFLAG='OFF' CCCCC CALL GRDRPL(PX2,PY2,NP2, CCCCC1IFIG,IPATT,PTHICK,ICOL, CCCCC1JPATT,JTHICK,PTHIC2,JCOL) CALL DPDRPL(PX2,PY2,NP2, 1IFIG,IPATT,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) C PX2(1)=X2+DEL3D PY2(1)=Y2+DEL3D C PX2(2)=X2+DEL3D PY2(2)=Y1+DEL3D C PX2(3)=X2 PY2(3)=Y1 C NP2=3 C DO8153J=1,NP2 IF(PX2(J).LT.PXMIN)PX2(J)=PXMIN IF(PX2(J).GT.PXMAX)PX2(J)=PXMAX IF(PY2(J).LT.PYMIN)PY2(J)=PYMIN IF(PY2(J).GT.PYMAX)PY2(J)=PYMAX 8153 CONTINUE IFLAG='OFF' CCCCC CALL GRDRPL(PX2,PY2,NP2, CCCCC1IFIG,IPATT,PTHICK,ICOL, CCCCC1JPATT,JTHICK,PTHIC2,JCOL) CALL DPDRPL(PX2,PY2,NP2, 1IFIG,IPATT,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) C 8105 CONTINUE C 8190 CONTINUE C C *************************************** C ** STEP 82-- ** C ** DRAW OUT ALL HORIZONTAL BARS ** C ** (BUT FILL FIRST, IF CALLED FOR) ** C *************************************** C IF(IDIR.EQ.'H')GOTO8200 GOTO8290 C 8200 CONTINUE C SEPTEMBER, 1987: MOVE INSIDE LOOP CCCCC IPATT=IBA2PT CCCCC PTHICK=PBA2PT CCCCC PXGAP=PBA2PS CCCCC PYGAP=PBA2PS CCCCC ICOLF=IBA2FC CCCCC ICOLP=IBA2PC C IF(PBASE2.LT.PXMIN.AND.(PXMIN-PBASE2).LE.0.0001)PBASE2=PXMIN IF(PBASE2.GT.PXMAX.AND.(PBASE2-PXMAX).LE.0.0001)PBASE2=PXMAX C DO8205I=1,NP C IPATT=IBA2PT IPATT2=IBA2PL PTHICK=PBA2PT PXGAP=PBA2PS PYGAP=PBA2PS ICOLF=IBA2FC ICOLP=IBA2PC C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRBA')GOTO8201 WRITE(ICOUT,8203) 8203 FORMAT('IN 8200 LOOP') CALL DPWRST('XXX','BUG ') 8201 CONTINUE PBOT=PY(I)-PWIDTH/2.0 PTOP=PY(I)+PWIDTH/2.0 IF(PBOT.LT.PYMIN.AND.(PYMIN-PBOT).LE.0.0001)PBOT=PYMIN IF(PTOP.GT.PYMAX.AND.(PTOP-PYMAX).LE.0.0001)PTOP=PYMAX IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRBA')GOTO8202 WRITE(ICOUT,8204) PBOT,PTOP 8204 FORMAT('PBOT,PTOP=',2(E15.7,1X)) CALL DPWRST('XXX','BUG ') 8202 CONTINUE C IF(PTOP.LT.PYMIN)GOTO8205 IF(PBOT.GT.PYMAX)GOTO8205 IF(PX(I).LT.PXMIN.AND.PBASE2.LT.PXMIN)GOTO8205 IF(PX(I).GT.PXMAX.AND.PBASE2.GT.PXMAX)GOTO8205 C X1=PBASE2 Y1=PBOT X2=PX(I) Y2=PTOP C DELX=ABS(X2-X1) DELY=ABS(Y2-Y1) DELMIN=DELY CCCCC IF(DELX.LT.DELY)DELMIN=DELX P3D=0.3 DEL3D=P3D*DELMIN C IF(IBA2FS.EQ.'OFF')GOTO8250 C IF(IBA2FS.EQ.'ON')GOTO8210 IF(IBA2FS.EQ.'ONF')GOTO8210 IF(IBA2FS.EQ.'ONS')GOTO8220 IF(IBA2FS.EQ.'ONT')GOTO8230 IF(IBA2FS.EQ.'ONFS')GOTO8210 IF(IBA2FS.EQ.'ONSF')GOTO8210 IF(IBA2FS.EQ.'ONFT')GOTO8210 IF(IBA2FS.EQ.'ONTF')GOTO8210 IF(IBA2FS.EQ.'ONST')GOTO8220 IF(IBA2FS.EQ.'ONTS')GOTO8220 C C FRONT FACE C 8210 CONTINUE PX2(1)=X1 PY2(1)=Y1 C PX2(2)=X2 PY2(2)=Y1 C PX2(3)=X2 PY2(3)=Y2 C PX2(4)=X1 PY2(4)=Y2 C PX2(5)=X1 PY2(5)=Y1 C NP2=5 C DO8215J=1,NP2 IF(PX2(J).LT.PXMIN)PX2(J)=PXMIN IF(PX2(J).GT.PXMAX)PX2(J)=PXMAX IF(PY2(J).LT.PYMIN)PY2(J)=PYMIN IF(PY2(J).GT.PYMAX)PY2(J)=PYMAX 8215 CONTINUE CALL DPFIRE(PX2,PY2,NP2, 1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP, 1IPATT2) C IF(IBA2TY.EQ.'2')GOTO8250 C IF(IBA2FS.EQ.'ON')GOTO8220 IF(IBA2FS.EQ.'ONF')GOTO8250 IF(IBA2FS.EQ.'ONS')GOTO8220 IF(IBA2FS.EQ.'ONT')GOTO8230 IF(IBA2FS.EQ.'ONFS')GOTO8220 IF(IBA2FS.EQ.'ONSF')GOTO8220 IF(IBA2FS.EQ.'ONFT')GOTO8230 IF(IBA2FS.EQ.'ONTF')GOTO8230 IF(IBA2FS.EQ.'ONST')GOTO8220 IF(IBA2FS.EQ.'ONTS')GOTO8220 C C SIDE (= RIGHT) FACE C 8220 CONTINUE IF(IBA2TY.EQ.'2')GOTO8250 PX2(1)=X2 PY2(1)=Y2 C PX2(2)=X2+DEL3D PY2(2)=Y2+DEL3D C PX2(3)=X2+DEL3D PY2(3)=Y1+DEL3D C PX2(4)=X2 PY2(4)=Y1 C PX2(5)=X2 PY2(5)=Y2 C NP2=5 C DO8225J=1,NP2 IF(PX2(J).LT.PXMIN)PX2(J)=PXMIN IF(PX2(J).GT.PXMAX)PX2(J)=PXMAX IF(PY2(J).LT.PYMIN)PY2(J)=PYMIN IF(PY2(J).GT.PYMAX)PY2(J)=PYMAX 8225 CONTINUE CALL DPFIRE(PX2,PY2,NP2, 1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP, 1IPATT2) C IF(IBA2FS.EQ.'ON')GOTO8230 IF(IBA2FS.EQ.'ONF')GOTO8250 IF(IBA2FS.EQ.'ONS')GOTO8250 IF(IBA2FS.EQ.'ONT')GOTO8230 IF(IBA2FS.EQ.'ONFS')GOTO8250 IF(IBA2FS.EQ.'ONSF')GOTO8250 IF(IBA2FS.EQ.'ONFT')GOTO8230 IF(IBA2FS.EQ.'ONTF')GOTO8230 IF(IBA2FS.EQ.'ONST')GOTO8230 IF(IBA2FS.EQ.'ONTS')GOTO8230 C C TOP FACE C 8230 CONTINUE IF(IBA2TY.EQ.'2')GOTO8250 PX2(1)=X1 PY2(1)=Y2 C PX2(2)=X1+DEL3D PY2(2)=Y2+DEL3D C PX2(3)=X2+DEL3D PY2(3)=Y2+DEL3D C PX2(4)=X2 PY2(4)=Y2 C PX2(5)=X1 PY2(5)=Y2 C NP2=5 C DO8235J=1,NP2 IF(PX2(J).LT.PXMIN)PX2(J)=PXMIN IF(PX2(J).GT.PXMAX)PX2(J)=PXMAX IF(PY2(J).LT.PYMIN)PY2(J)=PYMIN IF(PY2(J).GT.PYMAX)PY2(J)=PYMAX 8235 CONTINUE CALL DPFIRE(PX2,PY2,NP2, 1IFIG,IPATT,PTHICK,PX2GAP,PYGAP,ICOLF,ICOLP, 1IPATT2) C 8250 CONTINUE C C DRAW OUT THE EDGES OF THE BAR C IPATT=IBA2BL PTHICK=PBA2BT ICOL=IBA2BC C PX2(1)=X1 PY2(1)=Y1 C PX2(2)=X2 PY2(2)=Y1 C PX2(3)=X2 PY2(3)=Y2 C PX2(4)=X1 PY2(4)=Y2 C PX2(5)=X1 PY2(5)=Y1 C NP2=5 C DO8251J=1,NP2 IF(PX2(J).LT.PXMIN)PX2(J)=PXMIN IF(PX2(J).GT.PXMAX)PX2(J)=PXMAX IF(PY2(J).LT.PYMIN)PY2(J)=PYMIN IF(PY2(J).GT.PYMAX)PY2(J)=PYMAX 8251 CONTINUE IFLAG='ON' CCCCC CALL GRDRPL(PX2,PY2,NP2, CCCCC1IFIG,IPATT,PTHICK,ICOL, CCCCC1JPATT,JTHICK,PTHIC2,JCOL) CALL DPDRPL(PX2,PY2,NP2, 1IFIG,IPATT,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) C IF(IBA2TY.EQ.'2')GOTO8205 C PX2(1)=X1 PY2(1)=Y2 C PX2(2)=X1+DEL3D PY2(2)=Y2+DEL3D C PX2(3)=X2+DEL3D PY2(3)=Y2+DEL3D C PX2(4)=X2 PY2(4)=Y2 C NP2=4 C DO8252J=1,NP2 IF(PX2(J).LT.PXMIN)PX2(J)=PXMIN IF(PX2(J).GT.PXMAX)PX2(J)=PXMAX IF(PY2(J).LT.PYMIN)PY2(J)=PYMIN IF(PY2(J).GT.PYMAX)PY2(J)=PYMAX 8252 CONTINUE IFLAG='OFF' CCCCC CALL GRDRPL(PX2,PY2,NP2, CCCCC1IFIG,IPATT,PTHICK,ICOL, CCCCC1JPATT,JTHICK,PTHIC2,JCOL) CALL DPDRPL(PX2,PY2,NP2, 1IFIG,IPATT,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) C PX2(1)=X2+DEL3D PY2(1)=Y2+DEL3D C PX2(2)=X2+DEL3D PY2(2)=Y1+DEL3D C PX2(3)=X2 PY2(3)=Y1 C NP2=3 C DO8253J=1,NP2 IF(PX2(J).LT.PXMIN)PX2(J)=PXMIN IF(PX2(J).GT.PXMAX)PX2(J)=PXMAX IF(PY2(J).LT.PYMIN)PY2(J)=PYMIN IF(PY2(J).GT.PYMAX)PY2(J)=PYMAX 8253 CONTINUE IFLAG='OFF' CCCCC CALL GRDRPL(PX2,PY2,NP2, CCCCC1IFIG,IPATT,PTHICK,ICOL, CCCCC1JPATT,JTHICK,PTHIC2,JCOL) CALL DPDRPL(PX2,PY2,NP2, 1IFIG,IPATT,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) C 8205 CONTINUE C 8290 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRBA')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPDRBA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)NP 9012 FORMAT('NP = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ICASPL,ICAS3D 9013 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)ABASE,HOLD,PBASE,PBASE2,PLEFT,PRIGHT 9014 FORMAT('ABASE,HOLD,PBASE,PBASE2,PLEFT,PRIGHT = ',6E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XDELMN,AWIDTH,PWIDTH 9015 FORMAT('XDELMN,AWIDTH,PWIDTH = ',3E15.7) CALL DPWRST('XXX','BUG ') IF(NP.LE.3)GOTO9029 DO9025I=1,3 WRITE(ICOUT,9026)I,X(I),Y(I) 9026 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9025 CONTINUE NPM2=NP-2 DO9027I=NPM2,NP WRITE(ICOUT,9028)I,X(I),Y(I) 9028 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9027 CONTINUE 9029 CONTINUE WRITE(ICOUT,9030)ISORSW 9030 FORMAT('ISORSW = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9031)IBA2SW,ABA2WI,ABA2BA 9031 FORMAT('IBA2SW,ABA2WI,ABA2BA = ',A4,2X,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9032)IBA2BL,IBA2BC,PBA2BT 9032 FORMAT('IBA2BL,IBA2BC,PBA2BT = ',A4,2X,A4,2X,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9033)IBA2FS,IBA2FC 9033 FORMAT('IBA2FS,IBA2FC = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9034)IBA2PT,IBA2PL,IBA2PC,IBA2TY,IBA2DI,PBA2PS,PBA2PT 9034 FORMAT('IBA2PT,IBA2PL,IBA2PC,IBA2TY,IBA2DI,PBA2PS,PBA2PT = ', 1A4,2X,A4,2X,A4,2X,A4,2X,A4,2X,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9044)PXMIN,PXMAX,PYMIN,PYMAX 9044 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX= ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9045)FX1MIN,FX1MAX,FY1MIN,FY1MAX 9045 FORMAT('FX1MIN,FX1MAX,FY1MIN,FY1MAX= ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9046)FXMIN,FXMAX,FYMIN,FYMAX 9046 FORMAT('FXMIN,FXMAX,FYMIN,FYMAX= ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9047)IX1TSC,IY1TSC 9047 FORMAT('IX1TSC,IY1TSC = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9051)IFIG 9051 FORMAT('IFIG = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9052)IPATT,JPATT 9052 FORMAT('IPATT,JPATT = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9053)PTHICK,JTHICK,PTHIC2 9053 FORMAT('PTHICK,JTHICK,PTHIC2 = ',E15.7,I8,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9054)ICOL,JCOL,IDIR 9054 FORMAT('ICOL,JCOL,IDIR = ',A4,I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9055)ITYPE 9055 FORMAT('ITYPE = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9069)IBUGG4,ISUBG4,IERRG4 9069 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPDRCH(Y,X,PY,PX,NP,PY2,PX2,NP2,X3D, 1ICASPL,ICAS3D, 1ISORSW, CCCCC THE FOLLOWING ARGUMENT WAS ADDED MAY 1992 (JJF) 1ARE2BA, 1ICH2PA,ICH2FO,ICH2CA,ICH2JU,ICH2DI,ACH2AN,ICH2FI,ICH2CO, 1PCH2HE,PCH2WI,PCH2TH,PCH2HO,PCH2VO, 1ITEXSP, 1PXMIN,PXMAX,PYMIN,PYMAX, 1FX1MIN,FX1MAX,FY1MIN,FY1MAX, 1IX1TSC,IY1TSC, 1IMPSW2,AMPSCH,AMPSCW) C C PURPOSE--FOR A GENERAL GRAPHICS DEVICE, C DRAW A CHARACTER TRACE OF Y(.) VERSUS X(.), C THAT IS, DRAW A SPECIFIED MARKER (= CHARACTER) TYPE C AT EACH OF THE PLOT POINTS. C NOTE--THE VARIABLES PY(.) AND PX(.) ARE DUMMY VARIABLES C WHICH ARE USED IN THE INTERMEDIATE CALCULATIONS C AND WHOSE DIMENSIONS ARE DEFINED (FOR EASY OF CHANGE) C BACK IN THE MAIN ROUTINE. 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--83.6 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY 1983. C UPDATED --DECEMBER 1987. INDEPENDENT CONTROL OF CHAR WIDTH. C UPDATED --SEPTEMBER 1988. LOG/WEIBULL CHECK AS A SUBROUTINE C UPDATED --SEPTEMBER 1988. RENUMBER C UPDATED --SEPTEMBER 1988. IBUGG4 FOR IBUGPL C UPDATED --JUNE 1990. NORMAL PLOT C UPDATED --MAY 1992. ADD ARE2BA AS INPUT ARGUMENT C UPDATED --DECEMBER 1996. SIMPLIFY NORMAL PLOT C UPDATED --SEPTEMBER 1999. ARGUMENT LIST TO DPCLCH C UPDATED --JANUARY 2000. ADD X3D TO ARGUEMNT LIST C C-----NON-COMMON VARIABLES (GRAPHICS)------------------------------------------- C CHARACTER*4 ICASPL CHARACTER*4 ICAS3D C CHARACTER*4 ISORSW C CHARACTER*4 ICH2PA CHARACTER*4 ICH2FO CHARACTER*4 ICH2CA CHARACTER*4 ICH2JU CHARACTER*4 ICH2DI CHARACTER*4 ICH2FI CHARACTER*4 ICH2CO C CHARACTER*4 ITEXSP C CHARACTER*4 IX1TSC CHARACTER*4 IY1TSC C CHARACTER*4 IFIG CHARACTER*4 IPATT CHARACTER*4 IFONT CHARACTER*4 ICASE CHARACTER*4 IJUST CHARACTER*4 IDIR CHARACTER*4 IFILL CHARACTER*4 ICOL C CHARACTER*4 ISYMBL CHARACTER*4 ISPAC CHARACTER*4 IMPSW2 C CHARACTER*4 ICASAX C DIMENSION Y(*) DIMENSION X(*) DIMENSION X3D(*) DIMENSION PY(*) DIMENSION PX(*) DIMENSION PY2(*) DIMENSION PX2(*) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOGR.INC' INCLUDE 'DPCOBE.INC' 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-----START POINT----------------------------------------------------- C FXMIN=FX1MIN FXMAX=FX1MAX FYMIN=FY1MIN FYMAX=FY1MAX C AHUNDR=100.0 C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRCH')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPDRCH--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NP 52 FORMAT('NP = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASPL,ICAS3D 53 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') IF(NP.LE.3)GOTO69 DO65I=1,3 WRITE(ICOUT,66)I,X(I),Y(I) 66 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 65 CONTINUE NPM2=NP-2 DO67I=NPM2,NP WRITE(ICOUT,68)I,X(I),Y(I) 68 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 67 CONTINUE 69 CONTINUE WRITE(ICOUT,70)ISORSW 70 FORMAT('ISORSW = ',A4) CALL DPWRST('XXX','BUG ') CCCCC THE FOLLOWING 2 LINES WERE ADDED MAY 1992 (JJF) WRITE(ICOUT,71)ARE2BA 71 FORMAT('ARE2BA = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,74)ICH2PA 74 FORMAT('ICH2PA= ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,75)ICH2FO 75 FORMAT('ICH2FO= ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,76)ICH2JU 76 FORMAT('ICH2JU= ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,77)ICH2DI 77 FORMAT('ICH2DI= ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,78)ACH2AN 78 FORMAT('ACH2AN= ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,79)ICH2FI 79 FORMAT('ICH2FI= ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,80)ICH2CO 80 FORMAT('ICH2CO= ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,81)PCH2HE 81 FORMAT('PCH2HE= ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,82)PCH2WI 82 FORMAT('PCH2WI= ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,83)PCH2TH,PCH2VO,PCH2HO 83 FORMAT('PCH2TH,PCH2VO,PCH2HO= ',3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,84)ITEXSP 84 FORMAT('ITEXSP = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,85)PXMIN,PXMAX,PYMIN,PYMAX 85 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX= ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,86)FX1MIN,FX1MAX,FY1MIN,FY1MAX 86 FORMAT('FX1MIN,FX1MAX,FY1MIN,FY1MAX= ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,87)IX1TSC,IY1TSC 87 FORMAT('IX1TSC,IY1TSC = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,89)IBUGG4,ISUBG4,IERRG4 89 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ************************************************* C ** STEP 10-- ** C ** IF CALLED FOR, SORT THE DATA ** C ** ACCORDING TO THE HORIZONTAL AXIS VARIABLE ** C ************************************************* C IF(ISORSW.EQ.'OFF')GOTO1150 IF(ICASPL.EQ.'PIEC')GOTO1150 IF(ICAS3D.EQ.'ON')GOTO1150 C CALL SORTC2(X,Y,NP,PX,PY) GOTO1190 C 1150 CONTINUE DO1160I=1,NP PX(I)=X(I) PY(I)=Y(I) 1160 CONTINUE GOTO1190 C 1190 CONTINUE C C ********************************************************** C ** STEP 21-- ** C ** IF A NON-LINEAR SCALE PLOT IS CALLED FOR, ** C ** CHECK THAT ALL HORIZ. AXIS DATA POINTS ** C ** ARE IN VALID RANGE. ** C ** IF A LOG SCALE PLOT IS CALLED FOR, ** C ** CHECK THAT ALL HORIZ. AXIS DATA POINTS ARE > 0. ** C ** IF A WEIBULL SCALE PLOT IS CALLED FOR, ** C ** OR IF A NORMAL SCALE PLOT IS CALLED FOR, (JUNE 1990) C ** CHECK THAT ALL HORIZ. AXIS DATA POINTS ARE ** C ** STRICTLY > 0 AND STRICTLY < 100 ** C ********************************************************** C IF(IX1TSC.EQ.'LOG')GOTO2110 GOTO2119 2110 CONTINUE ICASAX='2DHO' CALL CKLOSC(PX,NP,ISORSW,ICASAX, 1ISUBG4,IBUGG4,IERRG4) IF(IERRG4.EQ.'YES')GOTO9000 2119 CONTINUE C IF(IX1TSC.EQ.'WEIB')GOTO2120 CCCCC THE FOLLOWING LINE WAS ADDED JUNE 1990 IF(IX1TSC.EQ.'NORM')GOTO2120 GOTO2129 2120 CONTINUE ICASAX='2DHO' CALL CKPRSC(PX,NP,ISORSW,ICASAX, 1ISUBG4,IBUGG4,IERRG4) IF(IERRG4.EQ.'YES')GOTO9000 2129 CONTINUE C C ********************************************************** C ** STEP 22-- ** C ** IF A NON-LINEAR SCALE PLOT IS CALLED FOR, ** C ** CHECK THAT ALL VERT. AXIS DATA POINTS ** C ** ARE IN VALID RANGE. ** C ** IF A LOG SCALE PLOT IS CALLED FOR, ** C ** CHECK THAT ALL VERT. AXIS DATA POINTS ARE > 0. ** C ** IF A WEIBULL SCALE PLOT IS CALLED FOR, ** C ** OR IF A NORMAL SCALE PLOT IS CALLED FOR, (JUNE 1990) C ** CHECK THAT ALL VERT. AXIS DATA POINTS ARE ** C ** STRICTLY > 0 AND STRICTLY < 100 ** C ********************************************************** C IF(IY1TSC.EQ.'LOG')GOTO2210 GOTO2219 2210 CONTINUE ICASAX='2DVE' CALL CKLOSC(PY,NP,ISORSW,ICASAX, 1ISUBG4,IBUGG4,IERRG4) IF(IERRG4.EQ.'YES')GOTO9000 2219 CONTINUE C IF(IY1TSC.EQ.'WEIB')GOTO2220 CCCCC THE FOLLOWING LINE WAS ADDED JUNE 1990 IF(IY1TSC.EQ.'NORM')GOTO2220 GOTO2229 2220 CONTINUE ICASAX='2DVE' CALL CKPRSC(PY,NP,ISORSW,ICASAX, 1ISUBG4,IBUGG4,IERRG4) IF(IERRG4.EQ.'YES')GOTO9000 2229 CONTINUE C C ****************************************** C ** STEP 41-- ** C ** IF A LOG SCALE PLOT IS CALLED FOR, ** C ** TRANSFORM THE DATA ** C ****************************************** C IF(IX1TSC.EQ.'LOG')GOTO4110 GOTO4119 4110 CONTINUE DO4115I=1,NP PX(I)=ALOG10(PX(I)) 4115 CONTINUE 4119 CONTINUE C IF(IY1TSC.EQ.'LOG')GOTO4120 GOTO4129 4120 CONTINUE DO4125I=1,NP PY(I)=ALOG10(PY(I)) 4125 CONTINUE 4129 CONTINUE C C ****************************************** C ** STEP 42-- ** C ** IF A WEIBULL SCALE PLOT IS CALLED FOR, ** C ** TRANSFORM THE DATA ** C ****************************************** C IF(IX1TSC.EQ.'WEIB')GOTO4210 GOTO4219 4210 CONTINUE DO4215I=1,NP PX(I)=ALOG(ALOG(AHUNDR/(AHUNDR-PX(I)))) 4215 CONTINUE 4219 CONTINUE C IF(IY1TSC.EQ.'WEIB')GOTO4220 GOTO4229 4220 CONTINUE DO4225I=1,NP PY(I)=ALOG(ALOG(AHUNDR/(AHUNDR-PY(I)))) 4225 CONTINUE 4229 CONTINUE C CCCCC THE FOLLOWING SECTION WAS ADDED JUNE 1990 C ****************************************** C ** STEP 43-- ** C ** IF A NORMAL SCALE PLOT IS CALLED FOR, ** C ** TRANSFORM THE DATA ** C ****************************************** C IF(IX1TSC.EQ.'NORM')GOTO4310 GOTO4340 4310 CONTINUE DO4315I=1,NP CCCCC PX(I)=ALOG(ALOG(AHUNDR/(AHUNDR-PX(I)))) ARG=PX(I)/AHUNDR CALL NORPPF(ARG,PX(I)) 4315 CONTINUE 4340 CONTINUE C ABASE=ARE2BA IF(IY1TSC.EQ.'NORM')GOTO4360 GOTO4390 4360 CONTINUE CCCCC IF(ABASE.NE.CPUMAX.AND.ABASE.GT.0.0.AND.ABASE.LT.AHUNDR) CCCCC1ABASE2=ALOG(ALOG(AHUNDR/(AHUNDR-ABASE))) IF(ABASE.NE.CPUMAX.AND.ABASE.GT.0.0.AND.ABASE.LT.AHUNDR) 1ARG=ABASE/AHUNDR IF(ABASE.NE.CPUMAX.AND.ABASE.GT.0.0.AND.ABASE.LT.AHUNDR) 1CALL NORPPF(ARG,ABASE2) IF(ABASE.NE.CPUMAX.AND.ABASE.LE.0.0)ABASE2=0.1 IF(ABASE.NE.CPUMAX.AND.ABASE.GE.AHUNDR)ABASE2=0.1 ABASE=ABASE2 DO4365I=1,NP CCCCC PY(I)=ALOG(ALOG(AHUNDR/(AHUNDR-PY(I)))) ARG=PY(I)/AHUNDR CALL NORPPF(ARG,PY(I)) 4365 CONTINUE 4390 CONTINUE C C ***************************************************** C ** STEP 50-- ** C ** TRANSLATE THE DATA POINTS ** C ** INTO STANDARDIZED (0.0 TO 100.0) COORDINATES. ** C ***************************************************** C FXMIN=FX1MIN FXMAX=FX1MAX IF(IX1TSC.EQ.'LOG')FXMIN=ALOG10(FX1MIN) IF(IX1TSC.EQ.'LOG')FXMAX=ALOG10(FX1MAX) IF(IX1TSC.EQ.'WEIB')FXMIN=ALOG(ALOG(AHUNDR/(AHUNDR-FX1MIN))) IF(IX1TSC.EQ.'WEIB')FXMAX=ALOG(ALOG(AHUNDR/(AHUNDR-FX1MAX))) CCCCC THE FOLLOWING SECTION WAS SIMPLIFIED DECEMBER 1996 IF(IX1TSC.EQ.'NORM')THEN ARG=FX1MIN/AHUNDR CALL NORPPF(ARG,FXMIN) ARG=FX1MAX/AHUNDR CALL NORPPF(ARG,FXMAX) ENDIF C FYMIN=FY1MIN FYMAX=FY1MAX IF(IY1TSC.EQ.'LOG')FYMIN=ALOG10(FY1MIN) IF(IY1TSC.EQ.'LOG')FYMAX=ALOG10(FY1MAX) IF(IY1TSC.EQ.'WEIB')FYMIN=ALOG(ALOG(AHUNDR/(AHUNDR-FY1MIN))) IF(IY1TSC.EQ.'WEIB')FYMAX=ALOG(ALOG(AHUNDR/(AHUNDR-FY1MAX))) CCCCC THE FOLLOWING SECTION WAS SIMPLIFIED DECEMBER 1996 IF(IY1TSC.EQ.'NORM')THEN ARG=FY1MIN/AHUNDR CALL NORPPF(ARG,FYMIN) ARG=FY1MAX/AHUNDR CALL NORPPF(ARG,FYMAX) ENDIF C FXRANG=FXMAX-FXMIN FYRANG=FYMAX-FYMIN PXRANG=PXMAX-PXMIN PYRANG=PYMAX-PYMIN C DO5100I=1,NP FXRATI=(PX(I)-FXMIN)/FXRANG FYRATI=(PY(I)-FYMIN)/FYRANG PX(I)=PXMIN+FXRATI*PXRANG PY(I)=PYMIN+FYRATI*PYRANG 5100 CONTINUE C DO5200I=1,NP PX(I)=PX(I)+PCH2HO PY(I)=PY(I)+PCH2VO 5200 CONTINUE C C *********************************************** C ** STEP 60-- ** C ** WRITE OUT THE MARKERS (PLOT CHARACTERS) ** C ** AT THE PLOT POINTS ** C *********************************************** C IFIG='GENE' IPATT=ICH2PA IFONT=ICH2FO ICASE=ICH2CA IJUST=ICH2JU IDIR=ICH2DI ANGLE=ACH2AN IFILL=ICH2FI ICOL=ICH2CO PHEIGH=PCH2HE CCCCC PWIDTH=0.5*PHEIGH CCCCC PWIDTH=PHEIGH*(ANUMVP/ANUMHP) DECEMBER 1987 TEST PWIDTH=PCH2WI PVEGAP=PHEIGH/2.0 PHOGAP=PWIDTH/2.0 PTHICK=PCH2TH ISYMBL=ICH2PA ISPAC=ITEXSP C CCCCC ADD X3D TO CALL LIST. JANUARY 2000. CALL DPCLCH(PX,PY,NP,PX2,PY2,NP2,X3D, 1PXMIN,PXMAX,PYMIN,PYMAX, 1ISORSW, 1IFIG,IPATT,IFONT,ICASE,IJUST,IDIR,ANGLE,IFILL,ICOL, 1PHEIGH,PWIDTH,PVEGAP,PHOGAP,PTHICK, 1IMPSW2,AMPSCH,AMPSCW, 1ISYMBL,ISPAC) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRCH')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPDRCH--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)NP 9012 FORMAT('NP = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ICASPL,ICAS3D 9013 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') IF(NP.LE.3)GOTO9029 DO9025I=1,3 WRITE(ICOUT,9026)I,X(I),Y(I) 9026 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9025 CONTINUE NPM2=NP-2 DO9027I=NPM2,NP WRITE(ICOUT,9028)I,X(I),Y(I) 9028 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9027 CONTINUE 9029 CONTINUE WRITE(ICOUT,9030)ISORSW 9030 FORMAT('ISORSW = ',A4) CALL DPWRST('XXX','BUG ') CCCCC THE FOLLOWING 2 LINES WERE ADDED MAY 1992 (JJF) WRITE(ICOUT,9031)ARE2BA 9031 FORMAT('ARE2BA = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9034)ICH2PA 9034 FORMAT('ICH2PA= ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9035)ICH2FO 9035 FORMAT('ICH2FO= ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9036)ICH2JU 9036 FORMAT('ICH2JU= ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9037)ICH2DI 9037 FORMAT('ICH2DI= ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9038)ACH2AN 9038 FORMAT('ACH2AN= ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9039)ICH2FI 9039 FORMAT('ICH2FI= ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9040)ICH2CO 9040 FORMAT('ICH2CO= ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9041)PCH2HE 9041 FORMAT('PCH2HE= ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9042)PCH2WI 9042 FORMAT('PCH2WI= ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9043)PCH2TH,PCH2HO,PCH2VO 9043 FORMAT('PCH2TH,PCH2HO,PCH2VO= ',3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9044)ITEXSP 9044 FORMAT('ITEXSP = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9045)PXMIN,PXMAX,PYMIN,PYMAX 9045 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX= ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9046)FX1MIN,FX1MAX,FY1MIN,FY1MAX 9046 FORMAT('FX1MIN,FX1MAX,FY1MIN,FY1MAX= ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9047)FXMIN,FXMAX,FYMIN,FYMAX 9047 FORMAT('FXMIN,FXMAX,FYMIN,FYMAX= ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9048)IX1TSC,IY1TSC 9048 FORMAT('IX1TSC,IY1TSC = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9051)ISYMBL,ISPAC 9051 FORMAT('ISYMBL,ISPAC = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9059)IBUGG4,ISUBG4,IERRG4 9059 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPDRFL(PXMIN,PYMIN,PXMAX,PYMAX, 1ICASPL,ICAS3D, 1IX1FSW,IX2FSW,IY1FSW,IY2FSW, 1IX1FPA,IX2FPA,IY1FPA,IY2FPA, 1IX1FCO,IX2FCO,IY1FCO,IY2FCO, 1PFRATH) C PURPOSE--DRAW THE 4 (IF CALLED FOR) FRAME LINES ON THE SCREEN. 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--83.6 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY 1983. C UPDATED --SEPTEMBER 1987. CALLS TO GRDRPL TO DPDRPL C UPDATED --FEBRUARY 1988. STAR PLOT C UPDATED --JANUARY 1989. MODIFY CALLS TO DPDRPL (ALAN) C C-----NON-COMMON VARIABLES (GRAPHICS)------------------------------------------- C CHARACTER*4 ICASPL CHARACTER*4 ICAS3D C CHARACTER*4 IX1FSW CHARACTER*4 IX2FSW CHARACTER*4 IY1FSW CHARACTER*4 IY2FSW C CHARACTER*4 IX1FPA CHARACTER*4 IX2FPA CHARACTER*4 IY1FPA CHARACTER*4 IY2FPA C CHARACTER*4 IX1FCO CHARACTER*4 IX2FCO CHARACTER*4 IY1FCO CHARACTER*4 IY2FCO C CHARACTER*4 IFIG CHARACTER*4 IPATT CHARACTER*4 ICOL CHARACTER*4 IFLAG C DIMENSION PX(10) DIMENSION PY(10) CCCCC DIMENSION PX3(10) CCCCC DIMENSION PY3(10) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOGR.INC' INCLUDE 'DPCOBE.INC' 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 C-----START POINT----------------------------------------------------- C NP=2 C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRFL')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPDRFL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)PXMIN,PYMIN,PXMAX,PYMAX 52 FORMAT('PXMIN,PYMIN,PXMAX,PYMAX = ',4F10.5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASPL,ICAS3D 53 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)IX1FSW,IX2FSW,IY1FSW,IY2FSW 55 FORMAT('IX1FSW,IX2FSW,IY1FSW,IY2FSW = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)IX1FPA,IX2FPA,IY1FPA,IY2FPA 56 FORMAT('IX1FPA,IX2FPA,IY1FPA,IY2FPA = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,57)IX1FCO,IX2FCO,IY1FCO,IY2FCO 57 FORMAT('IX1FCO,IX2FCO,IY1FCO,IY2FCO = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,58)PFRATH 58 FORMAT('PFRATH = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,59)IBUGG4,ISUBG4,IERRG4 59 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C IF(ICASPL.EQ.'PIEC')GOTO9000 IF(ICASPL.EQ.'STAR')GOTO9000 IF(ICAS3D.EQ.'ON')GOTO9000 C IFIG='LINE' PTHICK=PFRATH C C ************************************** C ** STEP 1-- ** C ** DRAW OUT THE BOTTOM FRAME LINE ** C ** (IF CALLED FOR) ** C ************************************** C IF(IX1FSW.EQ.'ON')GOTO1100 GOTO1190 1100 CONTINUE PX(1)=PXMIN PY(1)=PYMIN PX(2)=PXMAX PY(2)=PYMIN NP=2 IPATT=IX1FPA ICOL=IX1FCO IFLAG='ON' CCCCC CALL DPDRPL(PX,PY,NP,PX3,PY3,NP3, CCCCC1IFIG,IPATT,PTHICK,ICOL) CALL DPDRPL(PX,PY,NP, 1IFIG,IPATT,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 1190 CONTINUE C C ************************************* C ** STEP 2-- ** C ** DRAW OUT THE RIGHT FRAME LINE ** C ** (IF CALLED FOR) ** C ************************************* C IF(IY2FSW.EQ.'ON')GOTO1200 GOTO1290 1200 CONTINUE PX(1)=PXMAX PY(1)=PYMIN PX(2)=PXMAX PY(2)=PYMAX NP=2 IPATT=IY2FPA ICOL=IY2FCO IFLAG='ON' CCCCC CALL DPDRPL(PX,PY,NP,PX3,PY3,NP3, CCCCC1IFIG,IPATT,PTHICK,ICOL) CALL DPDRPL(PX,PY,NP, 1IFIG,IPATT,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 1290 CONTINUE C C *********************************** C ** STEP 3-- ** C ** DRAW OUT THE TOP FRAME LINE ** C ** (IF CALLED FOR) ** C *********************************** C IF(IX2FSW.EQ.'ON')GOTO1300 GOTO1390 1300 CONTINUE PX(1)=PXMAX PY(1)=PYMAX PX(2)=PXMIN PY(2)=PYMAX NP=2 IPATT=IX2FPA ICOL=IX2FCO IFLAG='ON' CCCCC CALL DPDRPL(PX,PY,NP,PX3,PY3,NP3, CCCCC1IFIG,IPATT,PTHICK,ICOL) CALL DPDRPL(PX,PY,NP, 1IFIG,IPATT,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 1390 CONTINUE C C ************************************* C ** STEP 4-- ** C ** DRAW OUT THE LEFT FRAME LINE ** C ** (IF CALLED FOR) ** C ************************************* C IF(IY1FSW.EQ.'ON')GOTO1400 GOTO1490 1400 CONTINUE PX(1)=PXMIN PY(1)=PYMAX PX(2)=PXMIN PY(2)=PYMIN NP=2 IPATT=IY1FPA ICOL=IY1FCO IFLAG='ON' CCCCC CALL DPDRPL(PX,PY,NP,PX3,PY3,NP3, CCCCC1IFIG,IPATT,PTHICK,ICOL) CALL DPDRPL(PX,PY,NP, 1IFIG,IPATT,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 1490 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRFL')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPDRFL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)PXMIN,PYMIN,PXMAX,PYMAX 9012 FORMAT('PXMIN,PYMIN,PXMAX,PYMAX = ',4F10.5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ICASPL,ICAS3D 9013 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)IX1FSW,IX2FSW,IY1FSW,IY2FSW 9015 FORMAT('IX1FSW,IX2FSW,IY1FSW,IY2FSW = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)IX1FPA,IX2FPA,IY1FPA,IY2FPA 9016 FORMAT('IX1FPA,IX2FPA,IY1FPA,IY2FPA = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)IX1FCO,IX2FCO,IY1FCO,IY2FCO 9017 FORMAT('IX1FCO,IX2FCO,IY1FCO,IY2FCO = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9018)PFRATH 9018 FORMAT('PFRATH = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9025)NP 9025 FORMAT('NP = ',I8) CALL DPWRST('XXX','BUG ') DO9026I=1,NP WRITE(ICOUT,9027)PX(I),PY(I) 9027 FORMAT('PX(I),PY(I) = ',E15.7,E15.7) CALL DPWRST('XXX','BUG ') 9026 CONTINUE WRITE(ICOUT,9029)IBUGG4,ISUBG4,IERRG4 9029 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPDRFR(ICASPL,ICAS3D, 1IVGMSW,IHGMSW) C C PURPOSE--DRAW FRAME LINES (ALONG WITH TIC MARKS, C TIC MARK LABELS, AND GRID LINES C FOR A PLOT. 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--83.6 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY 1983. C MODIFIED --MAY 1990. ADD OFFSET ARGUMENTS TO DPDRGL C C-----NON-COMMON VARIABLES (GRAPHICS)------------------------------------------- C CHARACTER*4 ICASPL CHARACTER*4 ICAS3D C CHARACTER*4 IVGMSW CHARACTER*4 IHGMSW C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOPC.INC' INCLUDE 'DPCOGR.INC' INCLUDE 'DPCOBE.INC' 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-----START POINT----------------------------------------------------- C C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRFR')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPDRFR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IMANUF,IMODEL 52 FORMAT('IMANUF,IMODEL = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASPL,ICAS3D 53 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)IBUGG4,ISUBG4,IERRG4 55 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ******************************* C ** STEP 1-- ** C ** FILL THE MARGIN REGION ** C ******************************* C IF(IERASW.EQ.'ON'.AND.IMARCO.NE.IBACCO) 1CALL DPFIMA(PXMIN,PYMIN,PXMAX,PYMAX, 1ICASPL,ICAS3D, 1IMARCO) C C **************************** C ** STEP 2-- ** C ** DRAW THE FRAME LINES ** C **************************** C CALL DPDRFL(PXMIN,PYMIN,PXMAX,PYMAX, 1ICASPL,ICAS3D, 1IX1FSW,IX2FSW,IY1FSW,IY2FSW, 1IX1FPA,IX2FPA,IY1FPA,IY2FPA, 1IX1FCO,IX2FCO,IY1FCO,IY2FCO, 1PFRATH) C C ************************** C ** STEP 3-- ** C ** DRAW THE TIC MARKS ** C ************************** C CALL DPDRTM(PXMIN,PYMIN,PXMAX,PYMAX, 1ICASPL,ICAS3D, 1IX1FSW,IX2FSW,IY1FSW,IY2FSW, 1IX1TSW,IX2TSW,IY1TSW,IY2TSW, 1PX1COO,PX2COO,PY1COO,PY2COO, 1NX1COO,NX2COO,NY1COO,NY2COO, 1PX1CMN,PX2CMN,PY1CMN,PY2CMN, 1NX1CMN,NX2CMN,NY1CMN,NY2CMN, 1PX1TLE,PX2TLE,PY1TLE,PY2TLE, 1PTICTH,PMNTFA, 1IX1TJU,IX2TJU,IY1TJU,IY2TJU, 1IX1TCO,IX2TCO,IY1TCO,IY2TCO) C C ************************************* C ** STEP 4-- ** C ** WRITE OUT THE TIC MARK LABELS ** C ************************************* C CALL DPWRTL(ICASPL,ICAS3D) C C *************************** C ** STEP 5-- ** C ** DRAW THE GRID LINES ** C *************************** C CALL DPDRGL(PXMIN,PYMIN,PXMAX,PYMAX, 1ICASPL,ICAS3D, 1IVGRSW,IHGRSW, 1IVGMSW,IHGMSW, 1PX1COO,PX2COO,PY1COO,PY2COO, 1X1COOR,X2COOR,Y1COOR,Y2COOR, 1NX1COO,NX2COO,NY1COO,NY2COO, 1PX1CMN,PX2CMN,PY1CMN,PY2CMN, 1X1COMN,X2COMN,Y1COMN,Y2COMN, 1NX1CMN,NX2CMN,NY1CMN,NY2CMN, 1IVGRPA,IHGRPA,IVGRCO,IHGRCO, 1PVGRTH,PHGRTH, 1PX1TOL,PX1TOR,PY1TOB,PY1TOT) CCCC ABOVE LINE ADDED MAY, 1990 (FOR TIC OFFSETS) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRFR')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPDRFR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IMANUF,IMODEL 9012 FORMAT('IMANUF,IMODEL = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ICASPL,ICAS3D 9013 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)IBUGG4,ISUBG4,IERRG4 9015 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPDRGL(PXMIN,PYMIN,PXMAX,PYMAX, 1ICASPL,ICAS3D, 1IVGRSW,IHGRSW, 1IVGMSW,IHGMSW, 1PX1COO,PX2COO,PY1COO,PY2COO, 1X1COOR,X2COOR,Y1COOR,Y2COOR, 1NX1COO,NX2COO,NY1COO,NY2COO, 1PX1CMN,PX2CMN,PY1CMN,PY2CMN, 1X1COMN,X2COMN,Y1COMN,Y2COMN, 1NX1CMN,NX2CMN,NY1CMN,NY2CMN, 1IVGRPA,IHGRPA,IVGRCO,IHGRCO, 1PVGRTH,PHGRTH, 1PX1TOL,PX1TOR,PY1TOB,PY1TOT) C C PURPOSE--DRAW GRID LINES ON A PLOT C FOR A GENERAL GRAPHICS DEVICE. 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--83.6 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY 1983. C UPDATED --SEPTEMBER 1987. GRDRPL TO DPDRPL C UPDATED --FEBRUARY 1988. STAR PLOT C UPDATED --MAY 1990. TIC OFFSETS C UPDATED --SEPTEMBER 1990. MISSING HORIZ. GRID LINES C C-----NON-COMMON VARIABLES (GRAPHICS)------------------------------------------- C CHARACTER*4 ICASPL CHARACTER*4 ICAS3D C CHARACTER*4 IVGRSW CHARACTER*4 IHGRSW CHARACTER*4 IVGMSW CHARACTER*4 IHGMSW CHARACTER*4 IVGRPA CHARACTER*4 IHGRPA CHARACTER*4 IVGRCO CHARACTER*4 IHGRCO C CHARACTER*4 ITYPE CHARACTER*4 IFIG CHARACTER*4 IPATT CHARACTER*4 ICOL CCCCC CHARACTER*4 IHORPA CCCCC CHARACTER*4 IVERPA CCCCC CHARACTER*4 IDUPPA CCCCC CHARACTER*4 IDDOPA CHARACTER*4 IFLAG C DIMENSION PX1COO(*) DIMENSION PX2COO(*) DIMENSION PY1COO(*) DIMENSION PY2COO(*) C DIMENSION X1COOR(*) DIMENSION X2COOR(*) DIMENSION Y1COOR(*) DIMENSION Y2COOR(*) C DIMENSION PX1CMN(*) DIMENSION PX2CMN(*) DIMENSION PY1CMN(*) DIMENSION PY2CMN(*) C DIMENSION X1COMN(*) DIMENSION X2COMN(*) DIMENSION Y1COMN(*) DIMENSION Y2COMN(*) C DIMENSION PX(100) DIMENSION PY(100) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOGR.INC' INCLUDE 'DPCOBE.INC' 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-----START POINT----------------------------------------------------- C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRGL')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPDRGL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)PXMIN,PYMIN,PXMAX,PYMAX 52 FORMAT('PXMIN,PYMIN,PXMAX,PYMAX = ',4F10.5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASPL,ICAS3D 53 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IVGRSW,IHGRSW,IVGMSW,IHGMSW 54 FORMAT('IVGRSW,IHGRSW,IVGMSW,IHGMSW = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)IVGRPA,IHGRPA 55 FORMAT('IVGRPA,IHGRPA = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)PVGRTH,PHGRTH 56 FORMAT('PVGRTH,PHGRTH = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,57)IVGRCO,IHGRCO 57 FORMAT('IVGRCO,IHGRCO = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,60)NX1COO,NX2COO,NY1COO,NY2COO 60 FORMAT('NX1COO,NX2COO,NY1COO,NY2COO = ',4I8) CALL DPWRST('XXX','BUG ') C IF(NX1COO.LE.0)GOTO69 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO61I=1,NX1COO WRITE(ICOUT,62)I,PX1COO(I),X1COOR(I) 62 FORMAT('I,PX1COO(I),X1COOR(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 61 CONTINUE 69 CONTINUE C IF(NX2COO.LE.0)GOTO79 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO71I=1,NX2COO WRITE(ICOUT,72)I,PX2COO(I),X2COOR(I) 72 FORMAT('I,PX2COO(I),X2COOR(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 71 CONTINUE 79 CONTINUE C IF(NY1COO.LE.0)GOTO89 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO81I=1,NY1COO WRITE(ICOUT,82)I,PY1COO(I),Y1COOR(I) 82 FORMAT('I,PY1COO(I),Y1COOR(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 81 CONTINUE 89 CONTINUE C IF(NY2COO.LE.0)GOTO99 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO91I=1,NY2COO WRITE(ICOUT,92)I,PY2COO(I),Y2COOR(I) 92 FORMAT('I,PY2COO(I),Y2COOR(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 91 CONTINUE 99 CONTINUE C WRITE(ICOUT,88)IBUGG4,ISUBG4,IERRG4 88 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') C 90 CONTINUE C IF(ICASPL.EQ.'PIEC')GOTO9000 IF(ICASPL.EQ.'STAR')GOTO9000 IF(ICAS3D.EQ.'ON')GOTO9000 C ITYPE='LINE' C C *************************************************** C ** STEP 1-- ** C ** TRANSLATE THE VERTICAL GRID LINE LINE PATTERN ** C ** INTO A NUMBER WHICH CAN BE UNDERSTOOD ** C ** BY THE GRAPHICS DEVICE. ** C *************************************************** C IPATT=IVGRPA CCCCC CALL GRTRPA(ITYPE,IPATT,PXSPA,PYSPA, CCCCC1JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXSPA2,PYSPA2) C C ********************************** C ** STEP 2-- ** C ** SET THE LINE PATTERN TO SOLID ** C ** ON THE GRAPHICS DEVICE. ** C ********************************** C CCCCC CALL GRSEPA(ITYPE,IPATT,PXSPA,PYSPA, CCCCC1JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXSPA2,PYSPA2) C C ********************************************** C ** STEP 3-- ** C ** TRANSLATE THE CHARACTER REPRESENTATION ** C ** OF THE VERTICAL GRID LINE COLOR C ** INTO A NUMERIC REPRESENTATION ** C ** WHICH CAN BE UNDERSTOOD BY THE ** C ** GRAPHICS DEVICE. ** C ********************************************** C ICOL=IVGRCO CCCCC CALL GRTRCO(ITYPE,ICOL,JCOL) C C ******************************* C ** STEP 4-- ** C ** SET THE COLOR ** C ** ON THE GRAPHICS DEVICE. ** C ******************************* C CCCCC CALL GRSECO(ITYPE,ICOL,JCOL) C C ********************************************** C ** STEP 5-- ** C ** TRANSLATE THE CHARACTER REPRESENTATION ** C ** OF THE VERTICAL GRID LINE THICKNESS ** C ** INTO A NUMERIC REPRESENTATION ** C ** WHICH CAN BE UNDERSTOOD BY THE ** C ** GRAPHICS DEVICE. ** C ********************************************** C PTHICK=PVGRTH CCCCC CALL GRTRTH(ITYPE,PTHICK,JTHICK,PTHIC2) C C ******************************* C ** STEP 6-- ** C ** SET THE LINE THICKNESS ** C ** ON THE GRAPHICS DEVICE. ** C ******************************* C CCCCC CALL GRSETH(ITYPE,PTHICK,JTHICK,PTHIC2) C C ********************************** C ** STEP 7-- ** C ** DRAW VERTICAL GRID LINES ** C ********************************** C IFIG='LINE' PY(1)=PYMIN PY(2)=PYMAX C IF(IVGRSW.EQ.'OFF')GOTO1140 IF(NX1COO.LE.2)GOTO1140 CCCCC MAY, 1990. IF TIC OFFSETS ARE NON-ZER0, DRAW THE FIRST AND CCCCC LAST GRID LINES (WHICH PREVIOUSLY WOULD ALWAYS BE ON THE FRAME. EPS=0.000001 IMIN=2 IF(ABS(PX1TOL).GE.EPS)IMIN=1 IMAX=NX1COO-1 IF(ABS(PX1TOR).GE.EPS)IMAX=NX1COO NP=2 CCCCC IMAX=NX1COO-1 IFLAG='ON' CCCCC DO1110I=2,IMAX DO1110I=IMIN,IMAX PX(1)=PX1COO(I) PX(2)=PX1COO(I) CCCCC CALL GRDRPL(PX,PY,NP, CCCCC1IFIG,IPATT,PTHICK,ICOL, CCCCC1JPATT,JTHICK,PTHIC2,JCOL) CALL DPDRPL(PX,PY,NP, 1IFIG,IPATT,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) IFLAG='OFF' 1110 CONTINUE 1140 CONTINUE C IF(IVGMSW.EQ.'OFF')GOTO1180 IF(NX1CMN.LE.2)GOTO1180 NP=2 IMAX=NX1CMN IFLAG='ON' DO1150I=1,IMAX PX(1)=PX1CMN(I) PX(2)=PX1CMN(I) CCCCC CALL GRDRPL(PX,PY,NP, CCCCC1IFIG,IPATT,PTHICK,ICOL, CCCCC1JPATT,JTHICK,PTHIC2,JCOL) CALL DPDRPL(PX,PY,NP, 1IFIG,IPATT,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) IFLAG='OFF' 1150 CONTINUE 1180 CONTINUE C 1190 CONTINUE C C *************************************************** C ** STEP 11-- ** C ** TRANSLATE THE HORIZONTAL GRID LINE LINE PATTERN * C ** INTO A NUMBER WHICH CAN BE UNDERSTOOD ** C ** BY THE GRAPHICS DEVICE. ** C *************************************************** C IPATT=IHGRPA CCCCC CALL GRTRPA(ITYPE,IPATT,PXSPA,PYSPA, CCCCC1JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXSPA2,PYSPA2) C C ********************************** C ** STEP 12-- ** C ** SET THE LINE PATTERN TO SOLID ** C ** ON THE GRAPHICS DEVICE. ** C ********************************** C CCCCC CALL GRSEPA(ITYPE,IPATT,PXSPA,PYSPA, CCCCC1JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXSPA2,PYSPA2) C C ********************************************** C ** STEP 13-- ** C ** TRANSLATE THE CHARACTER REPRESENTATION ** C ** OF THE HORIZONTAL GRID LINE COLOR C ** INTO A NUMERIC REPRESENTATION ** C ** WHICH CAN BE UNDERSTOOD BY THE ** C ** GRAPHICS DEVICE. ** C ********************************************** C ICOL=IHGRCO CCCCC CALL GRTRCO(ITYPE,ICOL,JCOL) C C ******************************* C ** STEP 14-- ** C ** SET THE COLOR ** C ** ON THE GRAPHICS DEVICE. ** C ******************************* C CCCCC CALL GRSECO(ITYPE,ICOL,JCOL) C C ********************************************** C ** STEP 15-- ** C ** TRANSLATE THE CHARACTER REPRESENTATION ** C ** OF THE HORIZONAL GRID LINE THICKNESS ** C ** INTO A NUMERIC REPRESENTATION ** C ** WHICH CAN BE UNDERSTOOD BY THE ** C ** GRAPHICS DEVICE. ** C ********************************************** C PTHICK=PHGRTH CCCCC CALL GRTRTH(ITYPE,PTHICK,JTHICK,PTHIC2) C C ******************************* C ** STEP 16-- ** C ** SET THE LINE THICKNESS ** C ** ON THE GRAPHICS DEVICE. ** C ******************************* C CCCCC CALL GRSETH(ITYPE,PTHICK,JTHICK,PTHIC2) C C ********************************** C ** STEP 17-- ** C ** DRAW HORIZONTAL GRID LINES ** C ********************************** C IFIG='LINE' PX(1)=PXMIN PX(2)=PXMAX C IF(IHGRSW.EQ.'OFF')GOTO1240 IF(NY1COO.LE.2)GOTO1240 NP=2 CCCCC MAY, 1990. IF TIC OFFSETS ARE NON-ZER0, DRAW THE FIRST AND CCCCC LAST GRID LINES (WHICH PREVIOUSLY WOULD ALWAYS BE ON THE FRAME. EPS=0.000001 IMIN=2 IF(ABS(PY1TOB).GE.EPS)IMIN=1 CCCCC THE FOLLOWING LINE WAS FIXED SEPTEMBER 1990 CCCCC IMAX=NX1COO-1 IMAX=NY1COO-1 IF(ABS(PY1TOT).GE.EPS)IMAX=NY1COO CCCCC IMAX=NY1COO-1 IFLAG='ON' CCCCC DO1210I=2,IMAX DO1210I=IMIN,IMAX PY(1)=PY1COO(I) PY(2)=PY1COO(I) CCCCC CALL GRDRPL(PX,PY,NP, CCCCC1IFIG,IPATT,PTHICK,ICOL, CCCCC1JPATT,JTHICK,PTHIC2,JCOL) CALL DPDRPL(PX,PY,NP, 1IFIG,IPATT,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) IFLAG='OFF' 1210 CONTINUE 1240 CONTINUE C IF(IHGMSW.EQ.'OFF')GOTO1280 IF(NY1CMN.LE.2)GOTO1280 NP=2 IMAX=NY1CMN IFLAG='ON' DO1250I=1,IMAX PY(1)=PY1CMN(I) PY(2)=PY1CMN(I) CCCCC CALL GRDRPL(PX,PY,NP, CCCCC1IFIG,IPATT,PTHICK,ICOL, CCCCC1JPATT,JTHICK,PTHIC2,JCOL) CALL DPDRPL(PX,PY,NP, 1IFIG,IPATT,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) IFLAG='OFF' 1250 CONTINUE 1280 CONTINUE C 1290 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRGL')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPDRGL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ICASPL,ICAS3D 9013 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9019)IPATT,JPATT 9019 FORMAT('IPATT,JPATT = ',A4,2X,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9020)PTHICK,JTHICK,PTHIC2 9020 FORMAT('PTHICK,JTHICK,PTHIC2 = ',E15.7,2X,A4,2X,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)ICOL,JCOL 9021 FORMAT('ICOL,JCOL = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9022)ITYPE 9022 FORMAT('ITYPE = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9029)IBUGG4,ISUBG4,IERRG4 9029 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPDRPL(PX,PY,NP, 1IFIG,IPATT,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) C MODIFIED SEPTEMBER, 1987 CCCCC SUBROUTINE DPDRPL(PX,PY,NP,PX3,PY3,NP3, CCCCC1IFIG,IPATT,PTHICK,ICOL) C C PURPOSE--FOR A GENERAL GRAPHICS DEVICE, C DRAW THE POLYLINE WHOSE COORDINATES C ARE GIVEN IN (PX(.),PY(.)) , C AND WHICH HAS SPECIFIED C PATTERN, THICKNESS, AND COLOR. C NOTE--THE COORDINATES IN (PX(.),PY(.)) ARE IN C STANDARDIZED (0.0 TO 100.0) UNITS. C NOTE--THERE ARE NP SUCH COORDINATE PAIRS. 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-369011 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--83.6 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY 1983. C UPDATED --JANUARY 1989. MODIFED CALL LIST (ALAN) C UPDATED --JANUARY 1989. MODIFIED LINE THICKNESS ALGOR. (ALAN) C UPDATED --MAY 1989. DEBUG FOR IFLAG C UPDATED --MAY 1995. USE EQUIVALENCE C C-----NON-COMMON VARIABLES (GRAPHICS)------------------------------------------- C CHARACTER*4 IFIG CHARACTER*4 IPATT CHARACTER*4 ICOL C CHARACTER*4 ITYPE CHARACTER*4 IHORPA CHARACTER*4 IVERPA CHARACTER*4 IDUPPA CHARACTER*4 IDDOPA C CHARACTER*4 IFLAG C DIMENSION PX(*) DIMENSION PY(*) CCCCC DIMENSION PX3(*) CCCCC DIMENSION PY3(*) INCLUDE 'DPCOPA.INC' DIMENSION PX3(MAXPOP) DIMENSION PY3(MAXPOP) CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZ2.INC' CCCCC EQUIVALENCE (G2RBAG(IGAR42),PX3(1)) CCCCC EQUIVALENCE (G2RBAG(IGAR43),PY3(1)) CCCCC END CHANGE C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOGR.INC' INCLUDE 'DPCOBE.INC' 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-----START POINT----------------------------------------------------- C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRPL')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPDRPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)MAX(10,NP) 54 FORMAT('NP = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,NP WRITE(ICOUT,56)PX(I),PY(I) 56 FORMAT('PX(I),PY(I) = ',E15.7,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE WRITE(ICOUT,58)IFIG,IPATT,PTHICK,ICOL 58 FORMAT('IFIG,IPATT,PTHICK,ICOL = ',A4,2X,A4,2X,E15.7,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,59)JTHICK,PTHICK,PTHIC2 59 FORMAT('JTHICK,PTHIC,PTHIC2 = ',I8,2G15.7) CALL DPWRST('XXX','BUG ') CCCCC THE FOLLOWING 2 LINES WERE ADDED MAY 1992 WRITE(ICOUT,62)IFLAG 62 FORMAT('IFLAG = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,69)IBUGG4,ISUBG4,IERRG4 69 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C SEPTEMMBER, 1987 - SET ATTRIBUTES ACCORDING TO FLAG NP3=NP IF(IFLAG.EQ.'OFF')GOTO700 C ITYPE='LINE' C C ********************************************** C ** STEP 1-- ** C ** TRANSLATE THE CHARACTER REPRESENTATION ** C ** OF THE LINE PATTERN ** C ** INTO A NUMERIC REPRESENTATION ** C ** WHICH CAN BE UNDERSTOOD BY THE ** C ** GRAPHICS DEVICE. ** C ********************************************** C CALL GRTRPA(ITYPE,IPATT,PXSPA,PYSPA, 1JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXSPA2,PYSPA2) C C ******************************* C ** STEP 2-- ** C ** SET THE LINE PATTERN ** C ** ON THE GRAPHICS DEVICE. ** C ******************************* C CALL GRSEPA(ITYPE,IPATT,PXSPA,PYSPA, 1JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXSPA2,PYSPA2) C C ********************************************** C ** STEP 3-- ** C ** TRANSLATE THE DESIRED ** C ** LINE THICKNESS ** C ** INTO A NUMERIC REPRESENTATION ** C ** WHICH CAN BE UNDERSTOOD BY THE ** C ** GRAPHICS DEVICE. ** C ********************************************** C CALL GRTRTH(ITYPE,PTHICK,JTHICK,PTHIC2) C C ******************************* C ** STEP 4-- ** C ** SET THE LINE THICKNESS ** C ** ON THE GRAPHICS DEVICE. ** C ******************************* C CALL GRSETH(ITYPE,PTHICK,JTHICK,PTHIC2) C C ********************************************** C ** STEP 901-- ** C ** TRANSLATE THE CHARACTER REPRESENTATION ** C ** OF THE LINE COLOR ** C ** INTO A NUMERIC REPRESENTATION ** C ** WHICH CAN BE UNDERSTOOD BY THE ** C ** GRAPHICS DEVICE. ** C ********************************************** C CALL GRTRCO(ITYPE,ICOL,JCOL) C C ******************************* C ** STEP 6-- ** C ** SET THE LINE COLOR ** C ** ON THE GRAPHICS DEVICE. ** C ******************************* C CALL GRSECO(ITYPE,ICOL,JCOL) C C ***************************** C ** STEP 7-- ** C ** DRAW OUT THE POLYLINE ** C ***************************** C 700 CONTINUE IF(IFLAG.EQ.'LOOP')GOTO800 CALL GRDRPL(PX,PY,NP, 1IFIG,IPATT,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL) C CCCCC PPENTH=0.1 CCCCC NLOOP=((PTHICK/(2.0*PPENTH))-1.0)+0.1 C CCCCC IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRPL') CCCCC1WRITE(ICOUT,1510)PPENTH,NLOOP C1510 FORMAT('PPENTH,NLOOP = ',E15.7,I8) CCCCC IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRPL') CCCCC1CALL DPWRST('XXX','BUG ') C IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRPL')THEN WRITE(ICOUT,1510)PTHIC2,JTHICK 1510 FORMAT('PTHIC2,JTICK = ',E15.7,I8) CALL DPWRST('XXX','BUG ') ENDIF C 800 CONTINUE NLOOP=JTHICK PPENTH=PTHIC2 C IF(NLOOP.LE.0)GOTO1590 DO1520I=1,NLOOP AI=I C DEL=PPENTH*AI IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRPL')THEN WRITE(ICOUT,1522)I,NLOOP,DEL 1522 FORMAT('I,NLOOP,DEL = ',2I8,G15.7) CALL DPWRST('XXX','BUG ') ENDIF CALL GRDEPL(PX,PY,NP,DEL,PX3,PY3,NP3) CALL GRDRPL(PX3,PY3,NP3, 1IFIG,IPATT,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL) C DEL=(-PPENTH*AI) CALL GRDEPL(PX,PY,NP,DEL,PX3,PY3,NP3) CALL GRDRPL(PX3,PY3,NP3, 1IFIG,IPATT,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL) C 1520 CONTINUE C 1590 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRPL')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPDRPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NP 9014 FORMAT('NP = ',I8) CALL DPWRST('XXX','BUG ') DO9015I=1,MAX(10,NP) WRITE(ICOUT,9016)PX(I),PY(I) 9016 FORMAT('PX(I),PY(I) = ',E15.7,E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE WRITE(ICOUT,9018)IFIG 9018 FORMAT('IFIG = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9019)IPATT,JPATT 9019 FORMAT('IPATT,JPATT = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9020)PTHICK,JTHICK,PTHIC2 9020 FORMAT('PTHICK,JTHICK,PTHIC2 = ',E15.7,I8,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)ICOL,JCOL 9021 FORMAT('ICOL,JCOL = ',A4,I8) CALL DPWRST('XXX','BUG ') CCCCC THE FOLLOWING 2 LINES WERE ADDED MAY 1992 WRITE(ICOUT,9022)IFLAG 9022 FORMAT('IFLAG = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9023)ITYPE 9023 FORMAT('ITYPE = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9024)PPENTH,DEL,NLOOP 9024 FORMAT('PPENTH,DEL,NLOOP = ',2E15.7,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9029)IBUGG4,ISUBG4,IERRG4 9029 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPDRPM(PX,PY,NP,X3D2,IJUNK2,IROWID,IROWLB, 1IFIG,IPATT,IFONT,ICASE,IJUST,IDIR,ANGLE,IFILL,ICOL, 1PHEIGH,PWIDTH,PVEGAP,PHOGAP,PTHICK, 1IMPSW2,AMPSCH,AMPSCW, 1ISYMBL,ISPAC) C C PURPOSE--FOR A GENERAL GRAPHICS DEVICE, C DRAW THE POLYMARKERS WHOSE COORDINATES C ARE GIVEN IN (PX(.),PY(.)) , C AND WHICH HAS SPECIFIED C MARKER TYPE, SIZE, FONT, JUSTIFICATION, COLOR, ANGLE, C AND LINE THICKNESS. C NOTE--THE COORDINATES IN (PX(.),PY(.)) ARE IN C STANDARDIZED (0.0 TO 100.0) UNITS. C NOTE--THERE ARE NP SUCH COORDINATE PAIRS. 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-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--83.6 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY 1983. C UPDATED --NOVEMBER 1995. SUPPORT FOR CASE ASIS C UPDATED --SEPTEMBER 1999. GRDRPM ARGUMENT LIST C UPDATED --DECEMBER 1999. SUPPORT SPECIAL PLOTTING C (FOR VALUE OF POINT,ETC.) C C-----NON-COMMON VARIABLES (GRAPHICS)------------------------------------------- C CHARACTER*4 ITYPE C CHARACTER*4 IFIG CHARACTER*4 IPATT CHARACTER*4 IFONT CHARACTER*4 ICASE CHARACTER*4 IJUST CHARACTER*4 IDIR CHARACTER*4 IFILL CHARACTER*4 ICOL C CHARACTER*4 ISYMBL CHARACTER*4 ISPAC CHARACTER*4 IMPSW2 C CHARACTER*4 IHORPA CHARACTER*4 IVERPA CHARACTER*4 IDUPPA CHARACTER*4 IDDOPA C CHARACTER*4 ITYPSV C CHARACTER*4 ICTEMP CHARACTER*4 ICTEXT CHARACTER*4 IERROR C CHARACTER*24 IROWLB C DIMENSION ICTEXT(50) C DIMENSION IROWID(*) DIMENSION IROWLB(*) DIMENSION IJUNK2(*) DIMENSION PX(*) DIMENSION PY(*) DIMENSION X3D2(*) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCODA.INC' INCLUDE 'DPCOGR.INC' INCLUDE 'DPCOBE.INC' 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-----START POINT----------------------------------------------------- C IERROR='OFF' IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRPM')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPDRPM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)NP 54 FORMAT('NP = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,NP WRITE(ICOUT,56)PX(I),PY(I) 56 FORMAT('PX(I),PY(I) = ',E15.7,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE WRITE(ICOUT,58)IFIG 58 FORMAT('IFIG = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,59)IPATT 59 FORMAT('IPATT = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62)IFONT 62 FORMAT('IFONT = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)IJUST 63 FORMAT('IJUST = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,64)IDIR,ANGLE 64 FORMAT('IDIR,ANGLE = ',A4,2X,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,65)IFILL 65 FORMAT('IFILL = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,66)ICOL 66 FORMAT('ICOL = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,67)PHEIGH,PWIDTH 67 FORMAT('PHEIGH,PWIDTH = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,68)PVEGAP,PHOGAP 68 FORMAT('PVEGAP,PHOGAP = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,69)PTHICK 69 FORMAT('PTHICK = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71)ISYMBL,ISPAC 71 FORMAT('ISYMBL,ISPAC = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,79)IBUGG4,ISUBG4,IERRG4 79 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C CCCCC DECEMBER 1999. SUPPORT SPECIAL CASES: CCCCC 1) XVAL = X-COORDINATE OF VARIABLE CCCCC 2) YVAL = Y-COORDINATE OF VARIABLE CCCCC 3) XYVA = (X,Y) OF VARIABLE CCCCC 4) ROWI = ROW-ID CCCCC 5) ROWL = ROW-LABEL CCCCC 6) TVAL = TAG-VALUE (SPECIAL CASE FOR CROSS-TABULATE PLOT, CCCCC BUT MAY HAVE OTHER USES AS WELL) CCCCC 7) ZVAL = USE VALUE IN X3D2 C IF( 1(ISYMBL(1:1).EQ.'R'.OR.ISYMBL(1:1).EQ.'r').AND. 1(ISYMBL(2:2).EQ.'O'.OR.ISYMBL(2:2).EQ.'o').AND. 1(ISYMBL(3:3).EQ.'W'.OR.ISYMBL(3:3).EQ.'w').AND. 1(ISYMBL(4:4).EQ.'I'.OR.ISYMBL(4:4).EQ.'i') 1)THEN DO1010I=1,NP IROW=IROWID(I) AROW=REAL(IROW) NCTEXT=0 DO1015J=1,50 ICTEXT(J)=' ' 1015 CONTINUE CALL DPCONH(IROW,AROW,ICTEXT,NH,IBUGG4,IERROR) NCTEXT=NH PX1=PX(I) PY1=PY(I) CALL DPWRTE(PX1,PY1,ICTEXT,NCTEXT, 1 IFONT,ICASE,IJUST,IDIR,ANGLE,IFILL,ICOL, 1 PHEIGH,PWIDTH,PVEGAP,PHOGAP,PTHICK, 1 ISYMBL,ISPAC, 1 IMPSW2,AMPSCH,AMPSCW, 1 PX99,PY99) 1010 CONTINUE GOTO9000 ELSEIF( 1(ISYMBL(1:1).EQ.'R'.OR.ISYMBL(1:1).EQ.'r').AND. 1(ISYMBL(2:2).EQ.'O'.OR.ISYMBL(2:2).EQ.'o').AND. 1(ISYMBL(3:3).EQ.'W'.OR.ISYMBL(3:3).EQ.'w').AND. 1(ISYMBL(4:4).EQ.'L'.OR.ISYMBL(4:4).EQ.'l') 1)THEN DO1020I=1,NP ITEMP=IROWID(I) IF(IROWLB(ITEMP).EQ.' ')THEN IROW=IROWID(I) AROW=REAL(IROW) NCTEXT=0 DO1025J=1,50 ICTEXT(J)=' ' 1025 CONTINUE CALL DPCONH(IROW,AROW,ICTEXT,NH,IBUGG4,IERROR) NCTEXT=NH ELSE NCTEXT=1 DO1026J=24,1,-1 IF(IROWLB(ITEMP)(J:J).NE.' ')THEN NCTEXT=J GOTO1027 ENDIF 1026 CONTINUE 1027 CONTINUE DO1028J=1,NCTEXT ICTEXT(J)(1:1)=IROWLB(ITEMP)(J:J) 1028 CONTINUE ENDIF PX1=PX(I) PY1=PY(I) CALL DPWRTE(PX1,PY1,ICTEXT,NCTEXT, 1 IFONT,ICASE,IJUST,IDIR,ANGLE,IFILL,ICOL, 1 PHEIGH,PWIDTH,PVEGAP,PHOGAP,PTHICK, 1 ISYMBL,ISPAC, 1 IMPSW2,AMPSCH,AMPSCW, 1 PX99,PY99) 1020 CONTINUE GOTO9000 ELSEIF( 1(ISYMBL(1:1).EQ.'X'.OR.ISYMBL(1:1).EQ.'x').AND. 1(ISYMBL(2:2).EQ.'V'.OR.ISYMBL(2:2).EQ.'v').AND. 1(ISYMBL(3:3).EQ.'A'.OR.ISYMBL(3:3).EQ.'a').AND. 1(ISYMBL(4:4).EQ.'L'.OR.ISYMBL(4:4).EQ.'l') 1)THEN DO1030I=1,NP PX1=PX(I) PY1=PY(I) AVAL=X(I) CONST=0.5 IF(AVAL.LT.0.0)CONST=-0.5 IVAL=INT(AVAL+CONST) NCTEXT=0 DO1035J=1,50 ICTEXT(J)=' ' 1035 CONTINUE CALL DPCONH(IVAL,AVAL,ICTEXT,NH,IBUGG4,IERROR) NCTEXT=NH CALL DPWRTE(PX1,PY1,ICTEXT,NCTEXT, 1 IFONT,ICASE,IJUST,IDIR,ANGLE,IFILL,ICOL, 1 PHEIGH,PWIDTH,PVEGAP,PHOGAP,PTHICK, 1 ISYMBL,ISPAC, 1 IMPSW2,AMPSCH,AMPSCW, 1 PX99,PY99) 1030 CONTINUE GOTO9000 ELSEIF( 1(ISYMBL(1:1).EQ.'Y'.OR.ISYMBL(1:1).EQ.'y').AND. 1(ISYMBL(2:2).EQ.'V'.OR.ISYMBL(2:2).EQ.'v').AND. 1(ISYMBL(3:3).EQ.'A'.OR.ISYMBL(3:3).EQ.'a').AND. 1(ISYMBL(4:4).EQ.'L'.OR.ISYMBL(4:4).EQ.'l') 1)THEN DO1040I=1,NP PX1=PX(I) PY1=PY(I) AVAL=Y(I) CONST=0.5 IF(AVAL.LT.0.0)CONST=-0.5 IVAL=INT(AVAL+CONST) NCTEXT=0 DO1045J=1,50 ICTEXT(J)=' ' 1045 CONTINUE CALL DPCONH(IVAL,AVAL,ICTEXT,NH,IBUGG4,IERROR) NCTEXT=NH CALL DPWRTE(PX1,PY1,ICTEXT,NCTEXT, 1 IFONT,ICASE,IJUST,IDIR,ANGLE,IFILL,ICOL, 1 PHEIGH,PWIDTH,PVEGAP,PHOGAP,PTHICK, 1 ISYMBL,ISPAC, 1 IMPSW2,AMPSCH,AMPSCW, 1 PX99,PY99) 1040 CONTINUE GOTO9000 ELSEIF( 1(ISYMBL(1:1).EQ.'X'.OR.ISYMBL(1:1).EQ.'x').AND. 1(ISYMBL(2:2).EQ.'Y'.OR.ISYMBL(2:2).EQ.'y').AND. 1(ISYMBL(3:3).EQ.'V'.OR.ISYMBL(3:3).EQ.'v').AND. 1(ISYMBL(4:4).EQ.'A'.OR.ISYMBL(4:4).EQ.'a') 1)THEN DO1050I=1,NP DO1055J=1,50 ICTEXT(J)=' ' 1055 CONTINUE PX1=PX(I) PY1=PY(I) AVAL=X(I) CONST=0.5 IF(AVAL.LT.0.0)CONST=-0.5 IVAL=INT(AVAL+CONST) NCTEXT=1 ICTEXT(NCTEXT)(1:1)='(' NCTEXT=NCTEXT+1 CALL DPCONH(IVAL,AVAL,ICTEXT(NCTEXT),NH,IBUGG4,IERROR) NCTEXT=NCTEXT+NH NCTEXT=NCTEXT+1 ICTEXT(NCTEXT)(1:1)=',' NCTEXT=NCTEXT+1 AVAL=Y(I) IF(AVAL.LT.0.0)CONST=-0.5 IVAL=INT(AVAL+CONST) CALL DPCONH(IVAL,AVAL,ICTEXT(NCTEXT),NH,IBUGG4,IERROR) NCTEXT=NCTEXT+NH ICTEXT(NCTEXT)(1:1)=')' CALL DPWRTE(PX1,PY1,ICTEXT,NCTEXT, 1 IFONT,ICASE,IJUST,IDIR,ANGLE,IFILL,ICOL, 1 PHEIGH,PWIDTH,PVEGAP,PHOGAP,PTHICK, 1 ISYMBL,ISPAC, 1 IMPSW2,AMPSCH,AMPSCW, 1 PX99,PY99) 1050 CONTINUE GOTO9000 ELSEIF( 1(ISYMBL(1:1).EQ.'T'.OR.ISYMBL(1:1).EQ.'t').AND. 1(ISYMBL(2:2).EQ.'V'.OR.ISYMBL(2:2).EQ.'v').AND. 1(ISYMBL(3:3).EQ.'A'.OR.ISYMBL(3:3).EQ.'a').AND. 1(ISYMBL(4:4).EQ.'L'.OR.ISYMBL(4:4).EQ.'l') 1)THEN DO1060I=1,NP PX1=PX(I) PY1=PY(I) AVAL=D(I) CONST=0.5 IF(AVAL.LT.0.0)CONST=-0.5 IVAL=INT(AVAL+CONST) NCTEXT=0 DO1065J=1,50 ICTEXT(J)=' ' 1065 CONTINUE CALL DPCONH(IVAL,AVAL,ICTEXT,NH,IBUGG4,IERROR) NCTEXT=NH CALL DPWRTE(PX1,PY1,ICTEXT,NCTEXT, 1 IFONT,ICASE,IJUST,IDIR,ANGLE,IFILL,ICOL, 1 PHEIGH,PWIDTH,PVEGAP,PHOGAP,PTHICK, 1 ISYMBL,ISPAC, 1 IMPSW2,AMPSCH,AMPSCW, 1 PX99,PY99) 1060 CONTINUE GOTO9000 ELSEIF( 1(ISYMBL(1:1).EQ.'Z'.OR.ISYMBL(1:1).EQ.'z').AND. 1(ISYMBL(2:2).EQ.'V'.OR.ISYMBL(2:2).EQ.'v').AND. 1(ISYMBL(3:3).EQ.'A'.OR.ISYMBL(3:3).EQ.'a').AND. 1(ISYMBL(4:4).EQ.'L'.OR.ISYMBL(4:4).EQ.'l') 1)THEN J=0 DO1070I=1,MAXPOP IF(IJUNK2(I).EQ.0)GOTO1070 J=J+1 PX1=PX(J) PY1=PY(J) AVAL=X3D2(I) CONST=0.5 IF(AVAL.LT.0.0)CONST=-0.5 IVAL=INT(AVAL+CONST) NCTEXT=0 DO1075JJ=1,50 ICTEXT(JJ)=' ' 1075 CONTINUE CALL DPCONH(IVAL,AVAL,ICTEXT,NH,IBUGG4,IERROR) NCTEXT=NH CALL DPWRTE(PX1,PY1,ICTEXT,NCTEXT, 1 IFONT,ICASE,IJUST,IDIR,ANGLE,IFILL,ICOL, 1 PHEIGH,PWIDTH,PVEGAP,PHOGAP,PTHICK, 1 ISYMBL,ISPAC, 1 IMPSW2,AMPSCH,AMPSCW, 1 PX99,PY99) IF(J.GE.NP)GOTO1079 1070 CONTINUE 1079 CONTINUE GOTO9000 ENDIF CCCCC NOVEMBER 1995. DO CASE CONVERSION HERE. CCCCC IF "ASIS" NO ACTION REQUIRED. CCCCC BE SURE TO TRANSLATE IPATT TO UPPER CASE. IF(ICASE.EQ.'LOWE')THEN DO100I=1,4 ICTEMP=ISYMBL(I:I) CALL DPCOAN(ICTEMP,IVALT) IF(IVALT.GE.65.AND.IVALT.LE.90)IVALT=IVALT+32 CALL DPCONA(IVALT,ICTEMP) ISYMBL(I:I)=ICTEMP 100 CONTINUE ELSEIF(ICASE.EQ.'UPPE')THEN DO110I=1,4 ICTEMP=ISYMBL(I:I) CALL DPCOAN(ICTEMP,IVALT) IF(IVALT.GE.97.AND.IVALT.LE.122)IVALT=IVALT-32 CALL DPCONA(IVALT,ICTEMP) ISYMBL(I:I)=ICTEMP 110 CONTINUE ELSEIF(ICASE.EQ.'ASIS')THEN CONTINUE END IF DO130I=1,4 ICTEMP=IPATT(I:I) CALL DPCOAN(ICTEMP,IVALT) IF(IVALT.GE.97.AND.IVALT.LE.122)IVALT=IVALT-32 CALL DPCONA(IVALT,ICTEMP) IPATT(I:I)=ICTEMP 130 CONTINUE C ITYPE='MARK' C C ********************************************** C ** STEP 1-- ** C ** TRANSLATE THE CHARACTER REPRESENTATION ** C ** OF THE MARKER PATTERN (TYPE) ** C ** INTO A NUMERIC REPRESENTATION ** C ** WHICH CAN BE UNDERSTOOD BY THE ** C ** GRAPHICS DEVICE. ** C ********************************************** C CALL GRTRPA(ITYPE,IPATT,PXSPA,PYSPA, 1JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXSPA2,PYSPA2) C C ******************************* C ** STEP 2-- ** C ** SET THE MARKER PATTERN ** C ** ON THE GRAPHICS DEVICE. ** C ******************************* C CALL GRSEPA(ITYPE,IPATT,PXSPA,PYSPA, 1JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXSPA2,PYSPA2) C C ********************************************** C ** STEP 3-- ** C ** TRANSLATE THE CHARACTER REPRESENTATION ** C ** OF THE MARKER FONT ** C ** INTO A NUMERIC REPRESENTATION ** C ** WHICH CAN BE UNDERSTOOD BY THE ** C ** GRAPHICS DEVICE. ** C ********************************************** C CALL GRTRFO(ITYPE,IFONT,JFONT) C C ************************************ C ** STEP 4-- ** C ** SET THE MARKER FONT ** C ** ON THE GRAPHICS DEVICE. ** C ************************************ C CALL GRSEFO(ITYPE,IFONT,JFONT) C C ********************************************** C ** STEP 5-- ** C ** TRANSLATE THE CHARACTER REPRESENTATION ** C ** OF THE MARKER CASE (UPPER OR LOWER) ** C ** INTO A NUMERIC REPRESENTATION ** C ** WHICH CAN BE UNDERSTOOD BY THE ** C ** GRAPHICS DEVICE. ** C ********************************************** C CALL GRTRCA(ITYPE,ICASE,JCASE) C C ************************************ C ** STEP 6-- ** C ** SET THE MARKER CASE ** C ** ON THE GRAPHICS DEVICE. ** C ************************************ C CALL GRSECA(ITYPE,ICASE,JCASE) C C ********************************************** C ** STEP 7-- ** C ** TRANSLATE THE CHARACTER REPRESENTATION ** C ** OF THE MARKER JUSTIFICATION ** C ** INTO A NUMERIC REPRESENTATION ** C ** WHICH CAN BE UNDERSTOOD BY THE ** C ** GRAPHICS DEVICE. ** C ********************************************** C CALL GRTRJU(ITYPE,IJUST,JJUST) C C ************************************ C ** STEP 8-- ** C ** SET THE MARKER JUSTIFICATION ** C ** ON THE GRAPHICS DEVICE. ** C ************************************ C CALL GRSEJU(ITYPE,IJUST,JJUST) C C ********************************************** C ** STEP 9-- ** C ** TRANSLATE THE CHARACTER REPRESENTATION ** C ** OF THE MARKER DIRECTION (ANGLE) ** C ** INTO A NUMERIC REPRESENTATION ** C ** WHICH CAN BE UNDERSTOOD BY THE ** C ** GRAPHICS DEVICE. ** C ********************************************** C CALL GRTRDI(ITYPE,IDIR,ANGLE,JDIR,ANGLE2) C C ************************************ C ** STEP 10-- ** C ** SET THE MARKER DIRECTION ** C ** ON THE GRAPHICS DEVICE. ** C ************************************ C CALL GRSEDI(ITYPE,IDIR,ANGLE,JDIR,ANGLE2) C C ********************************************** C ** STEP 11-- ** C ** TRANSLATE THE CHARACTER REPRESENTATION ** C ** OF THE MARKER FILL (ON/OFF) ** C ** INTO A NUMERIC REPRESENTATION ** C ** WHICH CAN BE UNDERSTOOD BY THE ** C ** GRAPHICS DEVICE. ** C ********************************************** C CALL GRTRFI(ITYPE,IFILL,JFILL) C C ******************************* C ** STEP 12-- ** C ** SET THE MARKER FILL ** C ** ON THE GRAPHICS DEVICE. ** C ******************************* C CALL GRSEFI(ITYPE,IFILL,JFILL) C C ********************************************** C ** STEP 13-- ** C ** TRANSLATE THE CHARACTER REPRESENTATION ** C ** OF THE MARKER COLOR ** C ** INTO A NUMERIC REPRESENTATION ** C ** WHICH CAN BE UNDERSTOOD BY THE ** C ** GRAPHICS DEVICE. ** C ********************************************** C ITYPSV=ITYPE IF(IFONT.EQ.'TEKT')ITYPE='TEXT' CALL GRTRCO(ITYPE,ICOL,JCOL) ITYPE=ITYPSV C C ******************************* C ** STEP 14-- ** C ** SET THE MARKER COLOR ** C ** ON THE GRAPHICS DEVICE. ** C ******************************* C ITYPSV=ITYPE IF(IFONT.EQ.'TEKT')ITYPE='TEXT' CALL GRSECO(ITYPE,ICOL,JCOL) ITYPE=ITYPSV C C ********************************************** C ** STEP 15-- ** C ** TRANSLATE THE CHARACTER REPRESENTATION ** C ** OF THE MARKER SIZE ** C ** INTO A NUMERIC REPRESENTATION ** C ** WHICH CAN BE UNDERSTOOD BY THE ** C ** GRAPHICS DEVICE. ** C ********************************************** C CALL GRTRSI(ITYPE,IFONT,PHEIGH,PWIDTH,PVEGAP,PHOGAP, 1JSIZE, 1JHEIG2,JWIDT2,JVEGA2,JHOGA2, 1PHEIG2,PWIDT2,PVEGA2,PHOGA2) C C ************************************ C ** STEP 16-- ** C ** SET THE MARKER SIZE ** C ** ON THE GRAPHICS DEVICE. ** C ************************************ C CALL GRSESI(ITYPE,IFONT,PHEIGH,PWIDTH,PVEGAP,PHOGAP, 1JSIZE, 1JHEIG2,JWIDT2,JVEGA2,JHOGA2, 1PHEIG2,PWIDT2,PVEGA2,PHOGA2) C C ********************************************** C ** STEP 17-- ** C ** TRANSLATE THE CHARACTER REPRESENTATION ** C ** OF THE MARKER LINE THICKNESS ** C ** INTO A NUMERIC REPRESENTATION ** C ** WHICH CAN BE UNDERSTOOD BY THE ** C ** GRAPHICS DEVICE. ** C ********************************************** C CALL GRTRTH(ITYPE,PTHICK,JTHICK,PTHIC2) C C ************************************ C ** STEP 18-- ** C ** SET THE MARKER LINE THICKNESS ** C ** ON THE GRAPHICS DEVICE. ** C ************************************ C CALL GRSETH(ITYPE,PTHICK,JTHICK,PTHIC2) C C ******************************* C ** STEP 19-- ** C ** DRAW OUT THE POLYMARKER ** C ******************************* C CALL GRDRPM(PX,PY,NP, 1IFIG,IPATT,IFONT,ICASE,IJUST,IDIR,ANGLE,IFILL,ICOL, 1JPATT,JFONT,JCASE,JJUST,JDIR,ANGLE2,JFILL,JCOL, 1PTHICK,JTHICK,PTHIC2, 1PHEIGH,PWIDTH,PVEGAP,PHOGAP, 1PHEIG2,PWIDT2,PVEGA2,PHOGA2, 1IMPSW2,AMPSCH,AMPSCW, 1ISYMBL,ISPAC) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRPM')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPDRPM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NP 9014 FORMAT('NP = ',I8) CALL DPWRST('XXX','BUG ') DO9015I=1,NP WRITE(ICOUT,9016)PX(I),PY(I) 9016 FORMAT('PX(I),PY(I) = ',E15.7,E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE WRITE(ICOUT,9018)IFIG 9018 FORMAT('IFIG = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9019)IPATT,JPATT 9019 FORMAT('IPATT,JPATT = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9022)IFONT,JFONT 9022 FORMAT('IFONT,JFONT = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9023)IJUST,JJUST 9023 FORMAT('IJUST,JJUST = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9024)IDIR,ANGLE,JDIR,ANGLE2 9024 FORMAT('IDIR,ANGLE,JDIR,ANGLE2 = ',A4,2X,E15.7,A4,2X,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9025)IFILL,JFILL 9025 FORMAT('IFILL,JFILL = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9026)ICOL,JCOL 9026 FORMAT('ICOL,JCOL = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9027)PHEIGH,PWIDTH,PVEGAP,PHOGAP 9027 FORMAT('PHEIGH,PWIDTH,PVEGAP,PHOGAP = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9028)PHEIG2,PWIDT2,PVEGA2,PHOGA2 9028 FORMAT('PHEIG2,PWIDT2,PVEGA2,PHOGA2 = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9029)PTHICK,PTHIC2 9029 FORMAT('PTHICK,PTHIC2 = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9031)ISYMBL,ISPAC 9031 FORMAT('ISYMBL,ISPAC = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9039)IBUGG4,ISUBG4,IERRG4 9039 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPDRSP(Y,X,PY,PX,NP, 1ICASPL,ICAS3D, 1ISORSW, 1ISP2LI,ISP2CO,ISP2DI,PSP2TH,ASP2BA, 1PXMIN,PXMAX,PYMIN,PYMAX, 1FX1MIN,FX1MAX,FY1MIN,FY1MAX, 1IX1TSC,IY1TSC) C C PURPOSE--FOR A GENERAL GRAPHICS DEVICE, C AND FOR EACH VALUE IN X(.), DRAW A SPIKE C (= A VERTICAL OR HORIZONTAL LINE SEGMENT) C FROM THE BASE POINT ASP2BA C TO THE POINT Y(.). C DO SO FOR A SPECIFIED SPIKE LINE TYPE, C LINES COLOR, LINE DIRECTION, AND LINE THICKNESS. C NOTE--THE VARIABLES PY(.) AND PX(.) ARE DUMMY VARIABLES C WHICH ARE USED IN THE INTERMEDIATE CALCULATIONS C AND WHOSE DIMENSIONS ARE DEFINED (FOR EASY OF CHANGE) C BACK IN THE MAIN ROUTINE. 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--87.6 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY 1983. C UPDATED--APRIL 1987. C UPDATED --SEPTEMBER 1988. RENUMBER C UPDATED --FEBRUARY 1989. CHANGE CALLS FROM GRDRPL TO DPDRPL (ALA C UPDATED --JULY 1990. CHARACTER*4 IPATT TO FIX BOMB C C-----NON-COMMON VARIABLES (GRAPHICS)------------------------------------------- C CHARACTER*4 ICASPL CHARACTER*4 ICAS3D C CHARACTER*4 ISORSW C CHARACTER*4 ISP2LI CHARACTER*4 ISP2CO CHARACTER*4 ISP2DI C CHARACTER*4 IX1TSC CHARACTER*4 IY1TSC C CHARACTER*4 ITYPE C CHARACTER*4 IFIG CHARACTER*4 IPATTT CCCCC THE FOLLOWING LINE WAS ADDED TO FIX SPIKE BOMB JULY 1990 CHARACTER*4 IPATT CHARACTER*4 ICOL CHARACTER*4 IDIR C C 6/23/86 C HOW COME THE FOLLOWING 4 VARIABLES ARE NOT CARRIED C AS INPUT TO THIS SUBROUTINE--NOT NEEDED??? C CHECK ON THIS. C CHARACTER*4 IHORPA CHARACTER*4 IVERPA CHARACTER*4 IDUPPA CHARACTER*4 IDDOPA CCCCC THE FOLLOWING LINE WAS ADDED FEBRUARY 1989 CHARACTER*4 IFLAG C DIMENSION Y(*) DIMENSION X(*) DIMENSION PY(*) DIMENSION PX(*) C DIMENSION PY2(10) DIMENSION PX2(10) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOGR.INC' INCLUDE 'DPCOBE.INC' 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-----START POINT----------------------------------------------------- C HOLD=1.0 ABASE=0.0 PBASE=0.0 PBASE2=0.0 C FXMIN=FX1MIN FXMAX=FX1MAX FYMIN=FY1MIN FYMAX=FY1MAX C CCCCC THE FOLLOWING 2 LINES WERE ADDED TO FIX SPIKE BOMB JULY 1990 IPATT='JUNK' JPATT=(-888) C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRSP')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPDRSP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NP 52 FORMAT('NP = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASPL,ICAS3D 53 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') IF(NP.LE.3)GOTO69 DO65I=1,3 WRITE(ICOUT,66)I,X(I),Y(I) 66 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 65 CONTINUE NPM2=NP-2 DO67I=NPM2,NP WRITE(ICOUT,68)I,X(I),Y(I) 68 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 67 CONTINUE 69 CONTINUE WRITE(ICOUT,70)ISORSW 70 FORMAT('ISORSW = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71)ISP2LI 71 FORMAT('ISP2LI= ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)ISP2CO,ISP2DI 72 FORMAT('ISP2CO,ISP2DI= ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,73)PSP2TH 73 FORMAT('PSP2TH= ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,74)ASP2BA 74 FORMAT('ASP2BA= ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,84)PXMIN,PXMAX,PYMIN,PYMAX 84 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX= ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,85)FX1MIN,FX1MAX,FY1MIN,FY1MAX 85 FORMAT('FX1MIN,FX1MAX,FY1MIN,FY1MAX= ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,86)IX1TSC,IY1TSC 86 FORMAT('IX1TSC,IY1TSC = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,89)IBUGG4,ISUBG4,IERRG4 89 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ************************************************* C ** STEP 11-- ** C ** IF CALLED FOR, SORT THE DATA ** C ** ACCORDING TO THE HORIZONTAL AXIS VARIABLE ** C ************************************************* C IDIR=ISP2DI C IF(ISORSW.EQ.'OFF')GOTO1150 IF(ICASPL.EQ.'PIEC')GOTO1150 IF(ICAS3D.EQ.'ON')GOTO1150 IF(ICASPL.EQ.'CONT')GOTO1150 C CALL SORTC2(X,Y,NP,PX,PY) GOTO1190 C 1150 CONTINUE DO1160I=1,NP PX(I)=X(I) PY(I)=Y(I) 1160 CONTINUE GOTO1190 C 1190 CONTINUE C C ************************************************ C ** STEP 12-- ** C ** IF A LOG SCALE PLOT IS CALLED FOR, ** C ** CHECK THAT ALL DATA POINTS ARE POSITIVE. ** C ************************************************ C IF(IX1TSC.EQ.'LOG')GOTO1210 GOTO1290 C 1210 CONTINUE IF(IDIR.EQ.'H')GOTO1215 GOTO1219 1215 CONTINUE IF(ASP2BA.LE.0.0)HOLD=ASP2BA IF(ASP2BA.LE.0.0)GOTO1250 1219 CONTINUE C IF(ISORSW.EQ.'ON')GOTO1220 GOTO1230 C 1220 CONTINUE J=1 IF(PX(J).LE.0.0)GOTO1250 GOTO1290 C 1230 CONTINUE DO1235I=1,NP J=I IF(PX(J).LE.0.0)GOTO1250 1235 CONTINUE GOTO1290 C 1250 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1251) 1251 FORMAT('***** ERROR IN DPDRSP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1252) 1252 FORMAT(' THE LOG OF A NON-POSITIVE DATA VALUE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1253) 1253 FORMAT(' WAS ENCOUNTERED IN FORMING A PLOT.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1254) 1254 FORMAT(' DATA MAY NOT BE ZERO OR NEGATIVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1255) 1255 FORMAT(' WHEN A LOG SCALE PLOT IS USED.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1256)PX(J) 1256 FORMAT(' THE VALUE = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1257) 1257 FORMAT(' THIS VALUE CAME FROM THE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1258) 1258 FORMAT(' HORIZONTAL AXIS VARIABLE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1259) 1259 FORMAT(' CORRECTIVE ACTION--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1260) 1260 FORMAT(' CHANGE DATA OR CHANGE LIMITS.') CALL DPWRST('XXX','BUG ') IERRG4='YES' GOTO9000 C 1290 CONTINUE C IF(IY1TSC.EQ.'LOG')GOTO1310 GOTO1390 C 1310 CONTINUE IF(IDIR.EQ.'V')GOTO1315 GOTO1319 1315 CONTINUE IF(ASP2BA.LE.0.0)HOLD=ASP2BA IF(ASP2BA.LE.0.0)GOTO1350 1319 CONTINUE C IF(ISORSW.EQ.'ON')GOTO1320 GOTO1330 C 1320 CONTINUE J=1 IF(PY(J).LE.0.0)HOLD=PY(J) IF(PY(J).LE.0.0)GOTO1350 GOTO1390 C 1330 CONTINUE DO1335I=1,NP J=I IF(PY(J).LE.0.0)HOLD=PY(J) IF(PY(J).LE.0.0)GOTO1350 1335 CONTINUE GOTO1390 C 1350 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1351) 1351 FORMAT('***** ERROR IN DPDRSP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1352) 1352 FORMAT(' THE LOG OF A NON-POSITIVE DATA VALUE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1353) 1353 FORMAT(' WAS ENCOUNTERED IN FORMING A PLOT.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1354) 1354 FORMAT(' DATA MAY NOT BE ZERO OR NEGATIVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1355) 1355 FORMAT(' WHEN A LOG SCALE PLOT IS USED.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1356)HOLD 1356 FORMAT(' THE VALUE = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1357) 1357 FORMAT(' THIS VALUE CAME FROM THE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1358) 1358 FORMAT(' VERTICAL AXIS VARIABLE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1359) 1359 FORMAT(' CORRECTIVE ACTION--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1360) 1360 FORMAT(' CHANGE DATA OR CHANGE LIMITS.') CALL DPWRST('XXX','BUG ') IERRG4='YES' GOTO9000 C 1390 CONTINUE C C ****************************************** C ** STEP 40-- ** C ** IF A LOG SCALE PLOT IS CALLED FOR, ** C ** TRANSFORM THE DATA ** C ****************************************** C ABASE=ASP2BA C IF(IX1TSC.EQ.'LOG')GOTO4010 GOTO4019 4010 CONTINUE IF(IDIR.EQ.'H')ABASE=ALOG10(ABASE) DO4015I=1,NP PX(I)=ALOG10(PX(I)) 4015 CONTINUE 4019 CONTINUE C IF(IY1TSC.EQ.'LOG')GOTO4020 GOTO4029 4020 CONTINUE IF(IDIR.EQ.'V')ABASE=ALOG10(ABASE) DO4025I=1,NP PY(I)=ALOG10(PY(I)) 4025 CONTINUE 4029 CONTINUE C C ***************************************************** C ** STEP 50-- ** C ** TRANSLATE THE DATA POINTS ** C ** INTO STANDARDIZED (0.0 TO 100.0) COORDINATES. ** C ***************************************************** C FXMIN=FX1MIN FXMAX=FX1MAX IF(IX1TSC.EQ.'LOG')FXMIN=ALOG10(FX1MIN) IF(IX1TSC.EQ.'LOG')FXMAX=ALOG10(FX1MAX) C FYMIN=FY1MIN FYMAX=FY1MAX IF(IY1TSC.EQ.'LOG')FYMIN=ALOG10(FY1MIN) IF(IY1TSC.EQ.'LOG')FYMAX=ALOG10(FY1MAX) C FXRANG=FXMAX-FXMIN FYRANG=FYMAX-FYMIN PXRANG=PXMAX-PXMIN PYRANG=PYMAX-PYMIN C DO5000I=1,NP FXRATI=(PX(I)-FXMIN)/FXRANG FYRATI=(PY(I)-FYMIN)/FYRANG PX(I)=PXMIN+FXRATI*PXRANG PY(I)=PYMIN+FYRATI*PYRANG 5000 CONTINUE C IF(IDIR.EQ.'V')GOTO5010 GOTO5019 5010 CONTINUE FYRATI=(ABASE-FYMIN)/FYRANG PBASE=PYMIN+FYRATI*PYRANG 5019 CONTINUE C IF(IDIR.EQ.'H')GOTO5020 GOTO5029 5020 CONTINUE FXRATI=(ABASE-FXMIN)/FXRANG PBASE=PXMIN+FXRATI*PXRANG 5029 CONTINUE C C ******************************* C ** STEP 70-- ** C ** PREPARE TO MAKE VARIOUS ** C ** LINE SETTINGS ** C ******************************* C ITYPE='LINE' C C ********************************************** C ** STEP 71-- ** C ** TRANSLATE THE CHARACTER REPRESENTATION ** C ** OF THE LINE PATTERN ** C ** INTO A NUMERIC REPRESENTATION ** C ** WHICH CAN BE UNDERSTOOD BY THE ** C ** GRAPHICS DEVICE. ** C ********************************************** C IPATTT=ISP2LI CALL GRTRPA(ITYPE,IPATTT,PXSPA,PYSPA, 1JPATTT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXSPA2,PYSPA2) C C ******************************* C ** STEP 72-- ** C ** SET THE LINE PATTERN ** C ** ON THE GRAPHICS DEVICE. ** C ******************************* C CALL GRSEPA(ITYPE,IPATTT,PXSPA,PYSPA, 1JPATTT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXSPA2,PYSPA2) C C ********************************************** C ** STEP 73-- ** C ** TRANSLATE THE DESIRED ** C ** LINE THICKNESS ** C ** INTO A NUMERIC REPRESENTATION ** C ** WHICH CAN BE UNDERSTOOD BY THE ** C ** GRAPHICS DEVICE. ** C ********************************************** C PTHICK=PSP2TH CALL GRTRTH(ITYPE,PTHICK,JTHICK,PTHIC2) C C ******************************* C ** STEP 74-- ** C ** SET THE LINE THICKNESS ** C ** ON THE GRAPHICS DEVICE. ** C ******************************* C CALL GRSETH(ITYPE,PTHICK,JTHICK,PTHIC2) C C ********************************************** C ** STEP 75-- ** C ** TRANSLATE THE CHARACTER REPRESENTATION ** C ** OF THE LINE COLOR ** C ** INTO A NUMERIC REPRESENTATION ** C ** WHICH CAN BE UNDERSTOOD BY THE ** C ** GRAPHICS DEVICE. ** C ********************************************** C ICOL=ISP2CO CALL GRTRCO(ITYPE,ICOL,JCOL) C C ******************************* C ** STEP 76-- ** C ** SET THE LINE COLOR ** C ** ON THE GRAPHICS DEVICE. ** C ******************************* C CALL GRSECO(ITYPE,ICOL,JCOL) C C ************************************** C ** STEP 81-- ** C ** DRAW OUT ALL SPIKES ** C ** (BUT CLIP FIRST, IF NECESSARY) ** C ************************************** C IFIG='GENE' C CALL DPSQUE(PX,PY,NP, 1PXMIN,PXMAX,PYMIN,PYMAX) C IF(IDIR.EQ.'V')GOTO7100 GOTO7190 7100 CONTINUE PBASE2=PBASE IF(PBASE2.LT.PYMIN.AND.(PYMIN-PBASE2).LE.0.0001)PBASE2=PYMIN IF(PBASE2.GT.PYMAX.AND.(PBASE2-PYMAX).LE.0.0001)PBASE2=PYMAX C CCCCC THE FOLLOWING LINE WAS ADDED FEBRUARY 1989 IFLAG='OFF' NP2=2 DO7110I=1,NP C IF(PX(I).LT.PXMIN)GOTO7110 IF(PX(I).GT.PXMAX)GOTO7110 IF(PY(I).LT.PYMIN.AND.PBASE2.LT.PYMIN)GOTO7110 IF(PY(I).GT.PYMAX.AND.PBASE2.GT.PYMAX)GOTO7110 C PX2(1)=PX(I) PX2(2)=PX(I) C PY2(1)=PBASE2 PY2(2)=PY(I) C DO7150J=1,NP2 IF(PY2(J).LT.PYMIN)PY2(J)=PYMIN IF(PY2(J).GT.PYMAX)PY2(J)=PYMAX 7150 CONTINUE C CCCCC THE FOLLOWING 3 LINES WERE COMMENTED OUT FEBRUARY 1989 CCCCC AND REPLACED BY THE SUBSEQUENT 3 LINES (ALAN) FEBRUARY 1989 CCCCC CALL GRDRPL(PX2,PY2,NP2, CCCCC1IFIG,IPATTT,PTHICK,ICOL, CCCCC1JPATTT,JTHICK,PTHIC2,JCOL) CALL DPDRPL(PX2,PY2,NP2, 1IFIG,IPATT,PTHICK,ICOL, CCCCC THE FOLLOWING LINE WAS TEMPORARILY FIXED JULY 9, 1990 CCCCC1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 1JPATTT,JTHICK,PTHIC2,JCOL,IFLAG) C C 7110 CONTINUE 7190 CONTINUE C IF(IDIR.EQ.'H')GOTO7200 GOTO7290 7200 CONTINUE CCCCC THE FOLLOWING LINE WAS ADDED FEBRUARY 1989 IFLAG='OFF' PBASE2=PBASE IF(PBASE2.LT.PXMIN.AND.(PXMIN-PBASE2).LE.0.0001)PBASE2=PXMIN IF(PBASE2.GT.PXMAX.AND.(PBASE2-PXMAX).LE.0.0001)PBASE2=PXMAX C NP2=2 DO7210I=1,NP C IF(PY(I).LT.PYMIN)GOTO7210 IF(PY(I).GT.PYMAX)GOTO7210 IF(PX(I).LT.PXMIN.AND.PBASE2.LT.PXMIN)GOTO7210 IF(PX(I).GT.PXMAX.AND.PBASE2.GT.PXMAX)GOTO7210 C PX2(1)=PBASE2 PX2(2)=PX(I) C PY2(1)=PY(I) PY2(2)=PY(I) C DO7250J=1,NP2 IF(PX2(J).LT.PXMIN)PX2(J)=PXMIN IF(PX2(J).GT.PXMAX)PX2(J)=PXMAX 7250 CONTINUE C CCCCC THE FOLLOWING 3 LINES WERE COMMENTED OUT FEBRUARY 1989 CCCCC AND REPLACED BY THE SUBSEQUENT 3 LINES (ALAN) FEBRUARY 1989 CCCCC CALL GRDRPL(PX2,PY2,NP2, CCCCC1IFIG,IPATTT,PTHICK,ICOL, CCCCC1JPATTT,JTHICK,PTHIC2,JCOL) CALL DPDRPL(PX2,PY2,NP2, 1IFIG,IPATT,PTHICK,ICOL, CCCCC THE FOLLOWING LINE WAS TEMPORARILY FIXED JULY 9, 1990 CCCCC1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 1JPATTT,JTHICK,PTHIC2,JCOL,IFLAG) C 7210 CONTINUE 7290 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRSP')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPDRSP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)NP 9012 FORMAT('NP = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ICASPL,ICAS3D 9013 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)HOLD 9014 FORMAT('HOLD = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)ABASE,PBASE,PBASE2 9015 FORMAT('ABASE,PBASE,PBASE2 = ',3E15.7) CALL DPWRST('XXX','BUG ') IF(NP.LE.3)GOTO9029 DO9025I=1,3 WRITE(ICOUT,9026)I,X(I),Y(I) 9026 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9025 CONTINUE NPM2=NP-2 DO9027I=NPM2,NP WRITE(ICOUT,9028)I,X(I),Y(I) 9028 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9027 CONTINUE 9029 CONTINUE WRITE(ICOUT,9030)ISORSW 9030 FORMAT('ISORSW = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9031)ISP2LI 9031 FORMAT('ISP2LI= ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9032)PSP2TH 9032 FORMAT('PSP2TH= ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9033)ISP2CO,ISP2DI 9033 FORMAT('ISP2CO,ISP2DI= ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9044)PXMIN,PXMAX,PYMIN,PYMAX 9044 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX= ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9045)FX1MIN,FX1MAX,FY1MIN,FY1MAX 9045 FORMAT('FX1MIN,FX1MAX,FY1MIN,FY1MAX= ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9046)FXMIN,FXMAX,FYMIN,FYMAX 9046 FORMAT('FXMIN,FXMAX,FYMIN,FYMAX= ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9047)IX1TSC,IY1TSC 9047 FORMAT('IX1TSC,IY1TSC = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9051)IFIG 9051 FORMAT('IFIG = ',A4) CALL DPWRST('XXX','BUG ') CCCCC THE FOLLOWING 2 LINES WERE AUGMENTED JULY 1990 CCCCC WRITE(ICOUT,9052)IPATTT,JPATTT C9052 FORMAT('IPATTT,JPATTT = ',A4,I8) CCCCC CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9052)IPATT,IPATTT,JPATTT 9052 FORMAT('IPATT,IPATTT,JPATTT = ',A4,2X,A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9053)PTHICK,JTHICK,PTHIC2 9053 FORMAT('PTHICK,JTHICK,PTHIC2 = ',E15.7,I8,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9054)ICOL,JCOL,IDIR 9054 FORMAT('ICOL,JCOL,IDIR = ',A4,I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9055)ITYPE 9055 FORMAT('ITYPE = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9069)IBUGG4,ISUBG4,IERRG4 9069 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPDRTM(PXMIN,PYMIN,PXMAX,PYMAX, 1ICASPL,ICAS3D, 1IX1FSW,IX2FSW,IY1FSW,IY2FSW, 1IX1TSW,IX2TSW,IY1TSW,IY2TSW, 1PX1COO,PX2COO,PY1COO,PY2COO, 1NX1COO,NX2COO,NY1COO,NY2COO, 1PX1CMN,PX2CMN,PY1CMN,PY2CMN, 1NX1CMN,NX2CMN,NY1CMN,NY2CMN, 1PX1TLE,PX2TLE,PY1TLE,PY2TLE, 1PTICTH,PMNTFA, 1IX1TJU,IX2TJU,IY1TJU,IY2TJU, 1IX1TCO,IX2TCO,IY1TCO,IY2TCO) C C PURPOSE--DRAW TIC MARKS ON THE FRAME LINES. 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--83.6 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY 1983. C UPDATED --FEBRUARY 1988. STAR PLOT C UPDATED --JANUARY 1989. CALL DPDRPL RATHER THAN GRDRPL (ALAN) C C-----NON-COMMON VARIABLES (GRAPHICS)------------------------------------------- C CHARACTER*4 ICASPL CHARACTER*4 ICAS3D C CHARACTER*4 IX1FSW CHARACTER*4 IX2FSW CHARACTER*4 IY1FSW CHARACTER*4 IY2FSW C CHARACTER*4 IX1TSW CHARACTER*4 IX2TSW CHARACTER*4 IY1TSW CHARACTER*4 IY2TSW C CHARACTER*4 IX1TJU CHARACTER*4 IX2TJU CHARACTER*4 IY1TJU CHARACTER*4 IY2TJU C CHARACTER*4 IX1TCO CHARACTER*4 IX2TCO CHARACTER*4 IY1TCO CHARACTER*4 IY2TCO C CHARACTER*4 ITYPE CHARACTER*4 IFIG CHARACTER*4 IPATT CHARACTER*4 ICOL CHARACTER*4 IHORPA CHARACTER*4 IVERPA CHARACTER*4 IDUPPA CHARACTER*4 IDDOPA C CHARACTER*4 IFLAG C DIMENSION PX1COO(*) DIMENSION PX2COO(*) DIMENSION PY1COO(*) DIMENSION PY2COO(*) C DIMENSION PX1CMN(*) DIMENSION PX2CMN(*) DIMENSION PY1CMN(*) DIMENSION PY2CMN(*) C DIMENSION PX(100) DIMENSION PY(100) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOGR.INC' INCLUDE 'DPCOBE.INC' 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-----START POINT----------------------------------------------------- C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRTM')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPDRTM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)PXMIN,PYMIN,PXMAX,PYMAX 52 FORMAT('PXMIN,PYMIN,PXMAX,PYMAX = ',4F10.5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASPL,ICAS3D 53 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IX1FSW,IX2FSW,IY1FSW,IY2FSW 54 FORMAT('IX1FSW,IX2FSW,IY1FSW,IY2FSW = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)IX1TSW,IX2TSW,IY1TSW,IY2TSW 55 FORMAT('IX1TSW,IX2TSW,IY1TSW,IY2TSW = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)PTICTH,PMNTFA 56 FORMAT('PTICTH,PMNTFA = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,57)IX1TJU,IX2TJU,IY1TJU,IY2TJU 57 FORMAT('IX1TJU,IX2TJU,IY1TJU,IY2TJU = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,58)IX1TCO,IX2TCO,IY1TCO,IY2TCO 58 FORMAT('IX1TCO,IX2TCO,IY1TCO,IY2TCO = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,59)NX1COO,NX2COO,NY1COO,NY2COO 59 FORMAT('NX1COO,NX2COO,NY1COO,NY2COO = ',4I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,60)NX1CMN,NX2CMN,NY1CMN,NY2CMN 60 FORMAT('NX1CMN,NX2CMN,NY1CMN,NY2CMN = ',4I8) CALL DPWRST('XXX','BUG ') C IF(NX1COO.LE.0)GOTO69 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO61I=1,NX1COO WRITE(ICOUT,62)I,PX1COO(I),PX1CMN(I) 62 FORMAT('I,PX1COO(I),PX1CMN(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 61 CONTINUE 69 CONTINUE C IF(NX2COO.LE.0)GOTO79 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO71I=1,NX2COO WRITE(ICOUT,72)I,PX2COO(I),PX2CMN(I) 72 FORMAT('I,PX2COO(I),PX2CMN(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 71 CONTINUE 79 CONTINUE C IF(NY1COO.LE.0)GOTO89 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO81I=1,NY1COO WRITE(ICOUT,82)I,PY1COO(I),PY1CMN(I) 82 FORMAT('I,PY1COO(I),PY1CMN(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 81 CONTINUE 89 CONTINUE C IF(NY2COO.LE.0)GOTO99 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO91I=1,NY2COO WRITE(ICOUT,92)I,PY2COO(I),PY2CMN(I) 92 FORMAT('I,PY2COO(I),PY2CMN(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 91 CONTINUE 99 CONTINUE C WRITE(ICOUT,88)IBUGG4,ISUBG4,IERRG4 88 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') C 90 CONTINUE C IF(ICASPL.EQ.'PIEC')GOTO9000 IF(ICASPL.EQ.'STAR')GOTO9000 IF(ICAS3D.EQ.'ON')GOTO9000 C ITYPE='LINE' C C *************************************************** C ** STEP 1-- ** C ** THE TIC MARKS WILL HAVE SOLID LINE PATTERN. ** C ** TRANSLATE THIS SOLID LINE PATTERN ** C ** INTO A NUMBER WHICH CAN BE UNDERSTOOD ** C ** BY THE GRAPHICS DEVICE. ** C *************************************************** C IFIG='LINE' IPATT='SOLI' CALL GRTRPA(ITYPE,IPATT,PXSPA,PYSPA, 1JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXSPA2,PYSPA2) C C ********************************** C ** STEP 2-- ** C ** SET THE LINE TYPE TO SOLID ** C ** ON THE GRAPHICS DEVICE. ** C ********************************** C CALL GRSEPA(ITYPE,IPATT,PXSPA,PYSPA, 1JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXSPA2,PYSPA2) C C ********************************************** C ** STEP 3-- ** C ** TRANSLATE THE CHARACTER REPRESENTATION ** C ** OF THE TIC THICKNESS ** C ** INTO A NUMERIC REPRESENTATION ** C ** WHICH CAN BE UNDERSTOOD BY THE ** C ** GRAPHICS DEVICE. ** C ********************************************** C PTHICK=PTICTH CALL GRTRTH(ITYPE,PTHICK,JTHICK,PTHIC2) C C ******************************* C ** STEP 4-- ** C ** SET THE LINE THICKNESS ** C ** ON THE GRAPHICS DEVICE. ** C ******************************* C CALL GRSETH(ITYPE,PTHICK,JTHICK,PTHIC2) C C ****************************************************** C ** STEP 7-- ** C ** DRAW MAJOR TIC MARKS ON BOTTOM HORIZONTAL AXIS ** C ** DRAW MINOR TIC MARKS ON BOTTOM HORIZONTAL AXIS ** C ****************************************************** C IF(IX1FSW.EQ.'OFF')GOTO1190 IF(IX1TSW.EQ.'OFF')GOTO1190 C ICOL=IX1TCO CALL GRTRCO(ITYPE,ICOL,JCOL) CALL GRSECO(ITYPE,ICOL,JCOL) C PMJTLE=PX1TLE C PY(1)=PYMIN PY(2)=PYMIN IF(IX1TJU.EQ.'THRU')PY(1)=PYMIN+PMJTLE/2.0 IF(IX1TJU.EQ.'THRU')PY(2)=PYMIN-PMJTLE/2.0 IF(IX1TJU.EQ.'IN')PY(1)=PYMIN+PMJTLE IF(IX1TJU.EQ.'INSI')PY(1)=PYMIN+PMJTLE IF(IX1TJU.EQ.'OUT')PY(1)=PYMIN-PMJTLE IF(IX1TJU.EQ.'OUTS')PY(1)=PYMIN-PMJTLE C IF(NX1COO.LE.0)GOTO1190 NP=2 IFLAG='OFF' DO1110I=1,NX1COO PX(1)=PX1COO(I) PX(2)=PX1COO(I) CCCCC CALL GRDRPL(PX,PY,NP, CCCCC1IFIG,IPATT,PTHICK,ICOL, CCCCC1JPATT,JTHICK,PTHIC2,JCOL) CALL DPDRPL(PX,PY,NP, 1IFIG,IPATT,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 1110 CONTINUE C PMNTLE=PMJTLE*PMNTFA C PY(1)=PYMIN PY(2)=PYMIN IF(IX1TJU.EQ.'THRU')PY(1)=PYMIN+PMNTLE/2.0 IF(IX1TJU.EQ.'THRU')PY(2)=PYMIN-PMNTLE/2.0 IF(IX1TJU.EQ.'IN')PY(1)=PYMIN+PMNTLE IF(IX1TJU.EQ.'INSI')PY(1)=PYMIN+PMNTLE IF(IX1TJU.EQ.'OUT')PY(1)=PYMIN-PMNTLE IF(IX1TJU.EQ.'OUTS')PY(1)=PYMIN-PMNTLE C IF(NX1CMN.LE.0)GOTO1190 NP=2 IFLAG='OFF' DO1120I=1,NX1CMN PX(1)=PX1CMN(I) PX(2)=PX1CMN(I) CCCCC CALL GRDRPL(PX,PY,NP, CCCCC1IFIG,IPATT,PTHICK,ICOL, CCCCC1JPATT,JTHICK,PTHIC2,JCOL) CALL DPDRPL(PX,PY,NP, 1IFIG,IPATT,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 1120 CONTINUE C 1190 CONTINUE C C ****************************************************** C ** STEP 8-- ** C ** DRAW MAJOR TIC MARKS ON TOP HORIZONTAL AXIS ** C ** DRAW MINOR TIC MARKS ON TOP HORIZONTAL AXIS ** C ****************************************************** C IF(IX2FSW.EQ.'OFF')GOTO1290 IF(IX2TSW.EQ.'OFF')GOTO1290 C ICOL=IX2TCO CALL GRTRCO(ITYPE,ICOL,JCOL) CALL GRSECO(ITYPE,ICOL,JCOL) C PMJTLE=PX2TLE C PY(1)=PYMAX PY(2)=PYMAX IF(IX2TJU.EQ.'THRU')PY(1)=PYMAX+PMJTLE/2.0 IF(IX2TJU.EQ.'THRU')PY(2)=PYMAX-PMJTLE/2.0 IF(IX2TJU.EQ.'IN')PY(1)=PYMAX-PMJTLE IF(IX2TJU.EQ.'INSI')PY(1)=PYMAX-PMJTLE IF(IX2TJU.EQ.'OUT')PY(1)=PYMAX+PMJTLE IF(IX2TJU.EQ.'OUTS')PY(1)=PYMAX+PMJTLE C IF(NX2COO.LE.0)GOTO1290 NP=2 IFLAG='OFF' DO1210I=1,NX2COO PX(1)=PX2COO(I) PX(2)=PX2COO(I) CCCCC CALL GRDRPL(PX,PY,NP, CCCCC1IFIG,IPATT,PTHICK,ICOL, CCCCC1JPATT,JTHICK,PTHIC2,JCOL) CALL DPDRPL(PX,PY,NP, 1IFIG,IPATT,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 1210 CONTINUE C PMNTLE=PMJTLE*PMNTFA C PY(1)=PYMAX PY(2)=PYMAX IF(IX2TJU.EQ.'THRU')PY(1)=PYMAX+PMNTLE/2.0 IF(IX2TJU.EQ.'THRU')PY(2)=PYMAX-PMNTLE/2.0 IF(IX2TJU.EQ.'IN')PY(1)=PYMAX-PMNTLE IF(IX2TJU.EQ.'INSI')PY(1)=PYMAX-PMNTLE IF(IX2TJU.EQ.'OUT')PY(1)=PYMAX+PMNTLE IF(IX2TJU.EQ.'OUTS')PY(1)=PYMAX+PMNTLE C IF(NX2CMN.LE.0)GOTO1290 NP=2 IFLAG='OFF' DO1220I=1,NX2CMN PX(1)=PX2CMN(I) PX(2)=PX2CMN(I) CCCCC CALL GRDRPL(PX,PY,NP, CCCCC1IFIG,IPATT,PTHICK,ICOL, CCCCC1JPATT,JTHICK,PTHIC2,JCOL) CALL DPDRPL(PX,PY,NP, 1IFIG,IPATT,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 1220 CONTINUE C 1290 CONTINUE C C ****************************************************** C ** STEP 9-- ** C ** DRAW MAJOR TIC MARKS ON LEFT VERTICAL AXIS ** C ** DRAW MINOR TIC MARKS ON LEFT VERTICAL AXIS ** C ****************************************************** C IF(IY1FSW.EQ.'OFF')GOTO1390 IF(IY1TSW.EQ.'OFF')GOTO1390 C ICOL=IY1TCO CALL GRTRCO(ITYPE,ICOL,JCOL) CALL GRSECO(ITYPE,ICOL,JCOL) C PMJTLE=PY1TLE*(ANUMVP/ANUMHP) C PX(1)=PXMIN PX(2)=PXMIN IF(IY1TJU.EQ.'THRU')PX(1)=PXMIN-PMJTLE/2.0 IF(IY1TJU.EQ.'THRU')PX(2)=PXMIN+PMJTLE/2.0 IF(IY1TJU.EQ.'IN')PX(1)=PXMIN+PMJTLE IF(IY1TJU.EQ.'INSI')PX(1)=PXMIN+PMJTLE IF(IY1TJU.EQ.'OUT')PX(1)=PXMIN-PMJTLE IF(IY1TJU.EQ.'OUTS')PX(1)=PXMIN-PMJTLE C IF(NY1COO.LE.0)GOTO1390 NP=2 IFLAG='OFF' DO1310I=1,NY1COO PY(1)=PY1COO(I) PY(2)=PY1COO(I) CCCCC CALL GRDRPL(PX,PY,NP, CCCCC1IFIG,IPATT,PTHICK,ICOL, CCCCC1JPATT,JTHICK,PTHIC2,JCOL) CALL DPDRPL(PX,PY,NP, 1IFIG,IPATT,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 1310 CONTINUE C PMNTLE=PMJTLE*PMNTFA C PX(1)=PXMIN PX(2)=PXMIN IF(IY1TJU.EQ.'THRU')PX(1)=PXMIN-PMNTLE/2.0 IF(IY1TJU.EQ.'THRU')PX(2)=PXMIN+PMNTLE/2.0 IF(IY1TJU.EQ.'IN')PX(1)=PXMIN+PMNTLE IF(IY1TJU.EQ.'INSI')PX(1)=PXMIN+PMNTLE IF(IY1TJU.EQ.'OUT')PX(1)=PXMIN-PMNTLE IF(IY1TJU.EQ.'OUTS')PX(1)=PXMIN-PMNTLE C IF(NY1CMN.LE.0)GOTO1390 NP=2 IFLAG='OFF' DO1320I=1,NY1CMN PY(1)=PY1CMN(I) PY(2)=PY1CMN(I) CCCCC CALL GRDRPL(PX,PY,NP, CCCCC1IFIG,IPATT,PTHICK,ICOL, CCCCC1JPATT,JTHICK,PTHIC2,JCOL) CALL DPDRPL(PX,PY,NP, 1IFIG,IPATT,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 1320 CONTINUE C 1390 CONTINUE C C ****************************************************** C ** STEP 10-- ** C ** DRAW MAJOR TIC MARKS ON RIGHT VERTICAL AXIS ** C ** DRAW MINOR TIC MARKS ON RIGHT VERTICAL AXIS ** C ****************************************************** C IF(IY2FSW.EQ.'OFF')GOTO1490 IF(IY2TSW.EQ.'OFF')GOTO1490 C ICOL=IY2TCO CALL GRTRCO(ITYPE,ICOL,JCOL) CALL GRSECO(ITYPE,ICOL,JCOL) C PMJTLE=PY2TLE*(ANUMVP/ANUMHP) C PX(1)=PXMAX PX(2)=PXMAX IF(IY2TJU.EQ.'THRU')PX(1)=PXMAX-PMJTLE/2.0 IF(IY2TJU.EQ.'THRU')PX(2)=PXMAX+PMJTLE/2.0 IF(IY2TJU.EQ.'IN')PX(1)=PXMAX-PMJTLE IF(IY2TJU.EQ.'INSI')PX(1)=PXMAX-PMJTLE IF(IY2TJU.EQ.'OUT')PX(1)=PXMAX+PMJTLE IF(IY2TJU.EQ.'OUTS')PX(1)=PXMAX+PMJTLE C IF(NY2COO.LE.0)GOTO1490 NP=2 IFLAG='OFF' DO1410I=1,NY2COO PY(1)=PY2COO(I) PY(2)=PY2COO(I) CCCCC CALL GRDRPL(PX,PY,NP, CCCCC1IFIG,IPATT,PTHICK,ICOL, CCCCC1JPATT,JTHICK,PTHIC2,JCOL) CALL DPDRPL(PX,PY,NP, 1IFIG,IPATT,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 1410 CONTINUE C PMNTLE=PMJTLE*PMNTFA C PX(1)=PXMAX PX(2)=PXMAX IF(IY2TJU.EQ.'THRU')PX(1)=PXMAX-PMNTLE/2.0 IF(IY2TJU.EQ.'THRU')PX(2)=PXMAX+PMNTLE/2.0 IF(IY2TJU.EQ.'IN')PX(1)=PXMAX-PMNTLE IF(IY2TJU.EQ.'INSI')PX(1)=PXMAX-PMNTLE IF(IY2TJU.EQ.'OUT')PX(1)=PXMAX+PMNTLE IF(IY2TJU.EQ.'OUTS')PX(1)=PXMAX+PMNTLE C IF(NY2CMN.LE.0)GOTO1490 NP=2 IFLAG='OFF' DO1420I=1,NY2CMN PY(1)=PY2CMN(I) PY(2)=PY2CMN(I) CCCCC CALL GRDRPL(PX,PY,NP, CCCCC1IFIG,IPATT,PTHICK,ICOL, CCCCC1JPATT,JTHICK,PTHIC2,JCOL) CALL DPDRPL(PX,PY,NP, 1IFIG,IPATT,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 1420 CONTINUE C 1490 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRTM')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPDRTM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ICASPL,ICAS3D 9013 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)PTICTH 9016 FORMAT('PTICTH = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9018)IFIG 9018 FORMAT('IFIG = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9019)IPATT,JPATT 9019 FORMAT('IPATT,JPATT = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9020)PTHICK,JTHICK,PTHIC2 9020 FORMAT('PTHICK,JTHICK,PTHIC2 = ',E15.7,2X,A4,2X,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)ICOL,JCOL 9021 FORMAT('ICOL,JCOL = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9022)ITYPE 9022 FORMAT('ITYPE = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9029)IBUGG4,ISUBG4,IERRG4 9029 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPDRTR(Y,X,PY,PX,NP,PY2,PX2,NP2,PY3,PX3,NP3, 1ICASPL,ICAS3D, 1ISORSW, 1ILI2PA,ILI2CO,PLI2TH, CCCCC OCTOBER 1993. ADD ARE3BA CCCCC1ARE2BA, 1ARE2BA,ARE3BA, 1IRE2FS,IRE2FC, 1IRE2PT,IRE2PL,IRE2PC,PRE2PT,PRE2PS, CCCCC MARCH 1994. ADD FOLLOWING LINE 1IREBPL, 1PXMIN,PXMAX,PYMIN,PYMAX, 1FX1MIN,FX1MAX,FY1MIN,FY1MAX, 1IX1TSC,IY1TSC) C C PURPOSE--FOR A GENERAL GRAPHICS DEVICE, C DRAW A SINGLE TRACE OF Y(.) VERSUS X(.) C FOR A SPECIFIED LINE TYPE, COLOR, AND THICKNESS. C AND (IF CALLED FOR) FILL IN BELOW/ABOVE THE TRACE C TO THE BASE LINE ARE2BA. C NOTE--THE VARIABLES PY(.) AND PX(.) ARE DUMMY VARIABLES C WHICH ARE USED IN THE INTERMEDIATE CALCULATIONS C AND WHOSE DIMENSIONS ARE DEFINED (FOR EASY OF CHANGE) C BACK IN THE MAIN ROUTINE. 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--83.6 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY 1983. C UPDATED --FEBRUARY 1988. STAR PLOT C UPDATED --JUNE 1988. CALLS TO DPFIRE C UPDATED --SEPTEMBER 1988. LOG/WEIBULL CHECK AS A SUBROUTINE C UPDATED --SEPTEMBER 1988. RENUMBER C UPDATED --DECEMBER 1988. IBUGG4 FOR IBUGPL C UPDATED --JUNE 1990. NORMAL PLOT C UPDATED --OCTOBER 1993. BAR BASE AUTOMATIC C UPDATED --OCTOBER 1993. REGION BASE AUTOMATIC C UPDATED --NOVEMBER 1993. FILL PIE CHART AS "POLYGON" C UPDATED --MARCH 1994 REGION BASE POLYGON C UPDATED --DECEMBER 1996 FIX NORMAL PLOT C C-----NON-COMMON VARIABLES (GRAPHICS)------------------------------------------- C CHARACTER*4 ICASPL CHARACTER*4 ICAS3D C CHARACTER*4 ISORSW C CHARACTER*4 ILI2PA CHARACTER*4 ILI2CO C CHARACTER*4 IRE2FS CHARACTER*4 IRE2FC CHARACTER*4 IRE2PT CHARACTER*4 IRE2PL CHARACTER*4 IRE2PC CHARACTER*4 IREBPL C CHARACTER*4 IX1TSC CHARACTER*4 IY1TSC C CHARACTER*4 IFIG CHARACTER*4 IPATT CHARACTER*4 ICOL CHARACTER*4 IPATT2 C CHARACTER*4 ICOLF CHARACTER*4 ICOLP C CHARACTER*4 ICASAX C DIMENSION Y(*) DIMENSION X(*) DIMENSION PY(*) DIMENSION PX(*) DIMENSION PY2(*) DIMENSION PX2(*) DIMENSION PY3(*) DIMENSION PX3(*) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOGR.INC' INCLUDE 'DPCOBE.INC' 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-----START POINT----------------------------------------------------- C HOLD=1.0 ABASE=0.0 PBASE=0.0 PBASE2=0.0 PLEFT=0.0 PRIGHT=0.0 AWIDTH=0.0 PWIDTH=0.0 FYRATI=0.0 C FXMIN=FX1MIN FXMAX=FX1MAX FYMIN=FY1MIN FYMAX=FY1MAX C AHUNDR=100.0 ABASE2=0.0 C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRTR')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPDRTR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NP 52 FORMAT('NP = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASPL,ICAS3D 53 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') IF(NP.LE.3)GOTO69 DO65I=1,3 WRITE(ICOUT,66)I,X(I),Y(I) 66 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 65 CONTINUE NPM2=NP-2 DO67I=NPM2,NP WRITE(ICOUT,68)I,X(I),Y(I) 68 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 67 CONTINUE 69 CONTINUE WRITE(ICOUT,70)ISORSW 70 FORMAT('ISORSW = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71)ILI2PA,ILI2CO,PLI2TH 71 FORMAT('ILI2PA,ILI2CO,PLI2TH = ',A4,2X,A4,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)ARE2BA 72 FORMAT('ARE2BA = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,73)IRE2FS,IRE2FC 73 FORMAT('IRE2FS,IRE2FC = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,74)IRE2PT,IRE2PL,IRE2PC,PRE2PT,PRE2PS 74 FORMAT('IRE2PT,IRE2PL,IRE2PC,PRE2PT,PRE2PS = ', 1A4,2X,A4,2X,A4,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,84)PXMIN,PXMAX,PYMIN,PYMAX 84 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX= ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,85)FX1MIN,FX1MAX,FY1MIN,FY1MAX 85 FORMAT('FX1MIN,FX1MAX,FY1MIN,FY1MAX= ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,86)IX1TSC,IY1TSC 86 FORMAT('IX1TSC,IY1TSC = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,89)IBUGG4,ISUBG4,IERRG4 89 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ************************************************* C ** STEP 1-- ** C ** IF CALLED FOR, SORT THE DATA ** C ** ACCORDING TO THE HORIZONTAL AXIS VARIABLE ** C ************************************************* C IF(ISORSW.EQ.'OFF')GOTO1150 IF(ICASPL.EQ.'PIEC')GOTO1150 IF(ICASPL.EQ.'STAR')GOTO1150 IF(ICAS3D.EQ.'ON')GOTO1150 IF(ICASPL.EQ.'CONT')GOTO1150 CCCCC MARCH 1994. ADD FOLLOWING LINE IF(IREBPL.EQ.'ON')GOTO1150 C CALL SORTC2(X,Y,NP,PX,PY) GOTO1190 C 1150 CONTINUE DO1160I=1,NP PX(I)=X(I) PY(I)=Y(I) 1160 CONTINUE GOTO1190 C 1190 CONTINUE C C ********************************************************** C ** STEP 21-- ** C ** IF A NON-LINEAR SCALE PLOT IS CALLED FOR, ** C ** CHECK THAT ALL HORIZ. AXIS DATA POINTS ** C ** ARE IN VALID RANGE. ** C ** IF A LOG SCALE PLOT IS CALLED FOR, ** C ** CHECK THAT ALL HORIZ. AXIS DATA POINTS ARE > 0. ** C ** IF A WEIBULL SCALE PLOT IS CALLED FOR, ** C ** CHECK THAT ALL HORIZ. AXIS DATA POINTS ARE ** C ** STRICTLY > 0 AND STRICTLY < 100 ** C ********************************************************** C IF(IX1TSC.EQ.'LOG')GOTO2110 GOTO2119 2110 CONTINUE ICASAX='2DHO' CALL CKLOSC(PX,NP,ISORSW,ICASAX, 1ISUBG4,IBUGG4,IERRG4) IF(IERRG4.EQ.'YES')GOTO9000 2119 CONTINUE C IF(IX1TSC.EQ.'WEIB')GOTO2120 CCCCC THE FOLLOWING LINE WAS ADDED JUNE 1990 IF(IX1TSC.EQ.'NORM')GOTO2120 GOTO2129 2120 CONTINUE ICASAX='2DHO' CCCCC CALL CKPRSC(PX,NP,ISORSW,ICASAX, CCCCC1ISUBG4,IBUGG4,IERRG4) CCCCC IF(IERRG4.EQ.'YES')GOTO9000 2129 CONTINUE C C ********************************************************** C ** STEP 22-- ** C ** IF A NON-LINEAR SCALE PLOT IS CALLED FOR, ** C ** CHECK THAT ALL VERT. AXIS DATA POINTS ** C ** ARE IN VALID RANGE. ** C ** IF A LOG SCALE PLOT IS CALLED FOR, ** C ** CHECK THAT ALL VERT. AXIS DATA POINTS ARE > 0. ** C ** IF A WEIBULL SCALE PLOT IS CALLED FOR, ** C ** CHECK THAT ALL VERT. AXIS DATA POINTS ARE ** C ** STRICTLY > 0 AND STRICTLY < 100 ** C ********************************************************** C IF(IY1TSC.EQ.'LOG')GOTO2210 GOTO2219 2210 CONTINUE ICASAX='2DVE' CALL CKLOSC(PY,NP,ISORSW,ICASAX, 1ISUBG4,IBUGG4,IERRG4) IF(IERRG4.EQ.'YES')GOTO9000 2219 CONTINUE C IF(IY1TSC.EQ.'WEIB')GOTO2220 CCCCC THE FOLLOWING LINE WAS ADDED JUNE 1990 IF(IY1TSC.EQ.'NORM')GOTO2220 GOTO2229 2220 CONTINUE ICASAX='2DVE' CCCCC CALL CKPRSC(PY,NP,ISORSW,ICASAX, CCCCC1ISUBG4,IBUGG4,IERRG4) CCCCC IF(IERRG4.EQ.'YES')GOTO9000 2229 CONTINUE C C ****************************************** C ** STEP 4-- ** C ** IF A NON-LINEAR SCALE PLOT IS CALLED FOR, ** C ** TRANSFORM THE DATA ** C ****************************************** C C ****************************************** C ** STEP 4.1-- ** C ** IF A LOG SCALE PLOT IS CALLED FOR, ** C ** TRANSFORM THE DATA ** C ****************************************** C IF(IX1TSC.EQ.'LOG')GOTO4110 GOTO4140 4110 CONTINUE DO4115I=1,NP PX(I)=ALOG10(PX(I)) 4115 CONTINUE 4140 CONTINUE C ABASE=ARE2BA CCCCC OCTOBER 1993. ADD FOLLOWING ABAS2=ARE3BA IF(IY1TSC.EQ.'LOG')GOTO4160 GOTO4190 4160 CONTINUE IF(ABASE.NE.CPUMAX.AND.ABASE.GT.0.0)ABASE=ALOG10(ABASE) IF(ABASE.NE.CPUMAX.AND.ABASE.LE.0.0)ABASE=1.0 CCCCC OCTOBER 1993. ADD FOLLOWING IF(ABAS2.NE.CPUMAX.AND.ABAS2.GT.0.0)ABAS2=ALOG10(ABAS2) IF(ABAS2.NE.CPUMAX.AND.ABAS2.LE.0.0)ABAS2=1.0 DO4165I=1,NP PY(I)=ALOG10(PY(I)) 4165 CONTINUE 4190 CONTINUE C C ****************************************** C ** STEP 4.2-- ** C ** IF A WEIBULL SCALE PLOT IS CALLED FOR, ** C ** TRANSFORM THE DATA ** C ****************************************** C IF(IX1TSC.EQ.'WEIB')GOTO4210 GOTO4240 4210 CONTINUE DO4215I=1,NP PX(I)=ALOG(ALOG(AHUNDR/(AHUNDR-PX(I)))) 4215 CONTINUE 4240 CONTINUE C ABASE=ARE2BA CCCCC OCTOBER 1993. ADD FOLLOWING ABAS2=ARE3BA IF(IY1TSC.EQ.'WEIB')GOTO4260 GOTO4290 4260 CONTINUE IF(ABASE.NE.CPUMAX.AND.ABASE.GT.0.0.AND.ABASE.LT.AHUNDR) 1ABASE2=ALOG(ALOG(AHUNDR/(AHUNDR-ABASE))) IF(ABASE.NE.CPUMAX.AND.ABASE.LE.0.0)ABASE2=0.1 IF(ABASE.NE.CPUMAX.AND.ABASE.GE.AHUNDR)ABASE2=0.1 ABASE=ABASE2 CCCCC OCTOBER 1993. ADD FOLLOWING IF(ABAS2.NE.CPUMAX.AND.ABAS2.GT.0.0.AND.ABAS2.LT.AHUNDR) 1ABASE2=ALOG(ALOG(AHUNDR/(AHUNDR-ABAS2))) IF(ABAS2.NE.CPUMAX.AND.ABAS2.LE.0.0)ABASE2=0.1 IF(ABAS2.NE.CPUMAX.AND.ABAS2.GE.AHUNDR)ABASE2=0.1 ABAS2=ABASE2 DO4265I=1,NP PY(I)=ALOG(ALOG(AHUNDR/(AHUNDR-PY(I)))) 4265 CONTINUE 4290 CONTINUE C CCCCC THE FOLLOWING SECTION WAS ADDED JUNE 1990 C ****************************************** C ** STEP 4.3-- ** C ** IF A NORMAL SCALE PLOT IS CALLED FOR, ** C ** TRANSFORM THE DATA ** C ****************************************** C IF(IX1TSC.EQ.'NORM')GOTO4310 GOTO4340 4310 CONTINUE DO4315I=1,NP CCCCC THE FOLLOWING 2 LINES WERE COMMENTED OUT JULY 1993 CCCCC THE FOLLOWING 2 LINES WERE UN-COMMENTED OUT DECEMBER 1996 ARG=PX(I)/AHUNDR CALL NORPPF(ARG,PX(I)) CCCCC THE FOLLOWING 2 LINES WERE COMMENTED OUT DECEMBER 1996 CCCCC CALL NORCDF(PX(I),PX(I)) CCCCC PX(I)=AHUNDR*PX(I) 4315 CONTINUE 4340 CONTINUE C ABASE=ARE2BA CCCCC OCTOBER 1993. ADD FOLLOWING ABAS2=ARE3BA IF(IY1TSC.EQ.'NORM')GOTO4360 GOTO4390 4360 CONTINUE CCCCC IF(ABASE.NE.CPUMAX.AND.ABASE.GT.0.0.AND.ABASE.LT.AHUNDR) CCCCC1ABASE2=ALOG(ALOG(AHUNDR/(AHUNDR-ABASE))) IF(ABASE.NE.CPUMAX.AND.ABASE.GT.0.0.AND.ABASE.LT.AHUNDR) 1ARG=ABASE/AHUNDR IF(ABASE.NE.CPUMAX.AND.ABASE.GT.0.0.AND.ABASE.LT.AHUNDR) 1CALL NORPPF(ARG,ABASE2) IF(ABASE.NE.CPUMAX.AND.ABASE.LE.0.0)ABASE2=0.1 IF(ABASE.NE.CPUMAX.AND.ABASE.GE.AHUNDR)ABASE2=0.1 ABASE=ABASE2 CCCCC OCTOBER 1993. ADD FOLLOWING IF(ABAS2.NE.CPUMAX.AND.ABAS2.GT.0.0.AND.ABAS2.LT.AHUNDR) 1ARG=ABAS2/AHUNDR IF(ABAS2.NE.CPUMAX.AND.ABAS2.GT.0.0.AND.ABAS2.LT.AHUNDR) 1CALL NORPPF(ARG,ABASE2) IF(ABAS2.NE.CPUMAX.AND.ABAS2.LE.0.0)ABASE2=0.1 IF(ABAS2.NE.CPUMAX.AND.ABAS2.GE.AHUNDR)ABASE2=0.1 ABAS2=ABASE2 DO4365I=1,NP CCCCC PY(I)=ALOG(ALOG(AHUNDR/(AHUNDR-PY(I)))) CCCCC THE FOLLOWING 2 LINES WERE COMMENTED OUT JULY 1993 CCCCC THE FOLLOWING 2 LINES WERE UN-COMMENTED OUT DECEMBER 1996 ARG=PY(I)/AHUNDR CALL NORPPF(ARG,PY(I)) CCCCC THE FOLLOWING 2 LINES WERE COMMENTED OUT DECEMBER 1996 CCCCC CALL NORCDF(PY(I),PY(I)) CCCCC PY(I)=AHUNDR*PY(I) 4365 CONTINUE 4390 CONTINUE C C ***************************************************** C ** STEP 5-- ** C ** TRANSLATE THE DATA POINTS ** C ** INTO STANDARDIZED (0.0 TO 100.0) COORDINATES. ** C ***************************************************** C FXMIN=FX1MIN FXMAX=FX1MAX IF(IX1TSC.EQ.'LOG')FXMIN=ALOG10(FX1MIN) IF(IX1TSC.EQ.'LOG')FXMAX=ALOG10(FX1MAX) IF(IX1TSC.EQ.'WEIB')FXMIN=ALOG(ALOG(AHUNDR/(AHUNDR-FX1MIN))) IF(IX1TSC.EQ.'WEIB')FXMAX=ALOG(ALOG(AHUNDR/(AHUNDR-FX1MAX))) CCCCC THE FOLLOWING SECTION WAS REWRITTEN DECEMBER 1996 IF(IX1TSC.EQ.'NORM')THEN ARG=FX1MIN/AHUNDR CALL NORPPF(ARG,FXMIN) ARG=FX1MAX/AHUNDR CALL NORPPF(ARG,FXMAX) END IF C FYMIN=FY1MIN FYMAX=FY1MAX IF(IY1TSC.EQ.'LOG')FYMIN=ALOG10(FY1MIN) IF(IY1TSC.EQ.'LOG')FYMAX=ALOG10(FY1MAX) IF(IY1TSC.EQ.'WEIB')FYMIN=ALOG(ALOG(AHUNDR/(AHUNDR-FY1MIN))) IF(IY1TSC.EQ.'WEIB')FYMAX=ALOG(ALOG(AHUNDR/(AHUNDR-FY1MAX))) CCCCC THE FOLLOWING SECTION WAS REWRITTEN DECEMBER 1996 IF(IY1TSC.EQ.'NORM')THEN ARG=FY1MIN/AHUNDR CALL NORPPF(ARG,FYMIN) ARG=FY1MAX/AHUNDR CALL NORPPF(ARG,FYMAX) ENDIF CCCCC THE FOLLOWING 6 LINES WERE COMMENTED OUT DECEMBER 1996 CCCCC IF(IY1TSC.EQ.'NORM')THEN CCCCC CALL NORCDF(FY1MIN,FYMIN) CCCCC FYMIN=AHUNDR*FYMIN CCCCC CALL NORCDF(FY1MAX,FYMAX) CCCCC FYMAX=AHUNDR*FYMAX CCCCC ENDIF C FXRANG=FXMAX-FXMIN FYRANG=FYMAX-FYMIN PXRANG=PXMAX-PXMIN PYRANG=PYMAX-PYMIN C DO5100I=1,NP FXRATI=(PX(I)-FXMIN)/FXRANG FYRATI=(PY(I)-FYMIN)/FYRANG PX(I)=PXMIN+FXRATI*PXRANG PY(I)=PYMIN+FYRATI*PYRANG 5100 CONTINUE IF(ABASE.NE.CPUMAX)FYRATI=(ABASE-FYMIN)/FYRANG IF(ABASE.NE.CPUMAX)PBASE=PYMIN+FYRATI*PYRANG CCCCC OCTOBER 1993. ADD FOLLOWING IF(ABAS2.NE.CPUMAX)FYRAT2=(ABAS2-FYMIN)/FYRANG IF(ABAS2.NE.CPUMAX)PBASE9=PYMIN+FYRAT2*PYRANG C C ************************************** C ** STEP 6-- ** C ** IF CALLED FOR, ** C ** FILL OVER/UNDER THE TRACE ** C ** (BUT CLIP FIRST, IF NECESSARY) ** C ************************************** C IFIG='GENE' IF(ICASPL.EQ.'PIEC')IFIG='POLY' CCCCC MARCH 1994. ADD FOLLOWING LINE IF(IREBPL.EQ.'ON')IFIG='POLY' C IF(IRE2FS.EQ.'OFF')GOTO6190 IPATT=IRE2PT PTHICK=PRE2PT PXGAP=PRE2PS PYGAP=PRE2PS ICOLF=IRE2FC ICOLP=IRE2PC C CALL DPSQUE(PX,PY,NP, 1PXMIN,PXMAX,PYMIN,PYMAX) C CCCCC MARCH 1994. ADD FOLLOWING LINE IF(IREBPL.EQ.'ON')GOTO6110 IF(ABASE.EQ.CPUMAX)GOTO6110 GOTO6120 C 6110 CONTINUE DO6115I=1,NP PX2(I)=PX(I) PY2(I)=PY(I) 6115 CONTINUE NP2=NP+1 PX2(NP2)=PX(1) PY2(NP2)=PY(1) C DO6116J=1,NP2 IF(PX2(J).LT.PXMIN)PX2(J)=PXMIN IF(PX2(J).GT.PXMAX)PX2(J)=PXMAX IF(PY2(J).LT.PYMIN)PY2(J)=PYMIN IF(PY2(J).GT.PYMAX)PY2(J)=PYMAX 6116 CONTINUE C CCCCC CALL DPFIRE(PX2,PY2,NP2, CCCCC1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP) C JUNE, 1988 IPATT2=IRE2PL CALL DPFIRE(PX2,PY2,NP2, 1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,IPATT2) C GOTO6190 C 6120 CONTINUE PBASE2=PBASE IF(PBASE2.LT.PYMIN.AND.(PYMIN-PBASE2).LE.0.0001)PBASE2=PYMIN IF(PBASE2.GT.PYMAX.AND.(PBASE2-PYMAX).LE.0.0001)PBASE2=PYMAX CCCCC OCTOBER 1993. ADD FOLLOWING PBASE8=PBASE9 IF(PBASE9.LT.PYMIN.AND.(PYMIN-PBASE9).LE.0.0001)PBASE8=PYMIN IF(PBASE9.GT.PYMAX.AND.(PBASE9-PYMAX).LE.0.0001)PBASE8=PYMAX CCCCC OCTOBER 1993. IF(NP.GT.2)GOTO6130 C NP2=5 NPM1=NP-1 IF(NPM1.LE.0)GOTO6190 DO6125I=1,NPM1 IP1=I+1 C PLEFT=PX(I) PRIGHT=PX(IP1) IF(PLEFT.LT.PXMIN.AND.(PXMIN-PLEFT).LE.0.0001)PLEFT=PXMIN IF(PRIGHT.GT.PXMAX.AND.(PRIGHT-PXMAX).LE.0.0001)PRIGHT=PXMAX C IF(PRIGHT.LT.PXMIN)GOTO6125 IF(PLEFT.GT.PXMAX)GOTO6125 IF(PY(I).LT.PYMIN.AND.PBASE2.LT.PYMIN)GOTO6125 IF(PY(I).GT.PYMAX.AND.PBASE2.GT.PYMAX)GOTO6125 C PX2(1)=PLEFT PX2(2)=PRIGHT PX2(3)=PRIGHT PX2(4)=PLEFT PX2(5)=PLEFT C PY2(1)=PBASE2 CCCCC OCTOBER 1993. ADD FOLLOWING CCCCC PY2(2)=PBASE2 PY2(2)=PBASE8 CCCCC END CHANGE PY2(3)=PY(IP1) PY2(4)=PY(I) PY2(5)=PBASE2 C DO6126J=1,NP2 IF(PX2(J).LT.PXMIN)PX2(J)=PXMIN IF(PX2(J).GT.PXMAX)PX2(J)=PXMAX IF(PY2(J).LT.PYMIN)PY2(J)=PYMIN IF(PY2(J).GT.PYMAX)PY2(J)=PYMAX 6126 CONTINUE C CCCCC CALL DPFIRE(PX2,PY2,NP2, CCCCC1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP) CCCCC JUNE, 1988. IPATT2=IRE2PL CALL DPFIRE(PX2,PY2,NP2, 1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,IPATT2) 6125 CONTINUE C GOTO6190 CCCCC OCTOBER 1993. TREAT REGION AS SINGLE POLYGON 6130 CONTINUE C DO6135I=1,NP C PX2(I)=PX(I) PY2(I)=PY(I) IF(PX2(I).LT.PXMIN)PX2(I)=PXMIN IF(PX2(I).GT.PXMAX)PX2(I)=PXMAX IF(PY2(I).LT.PYMIN)PY2(I)=PYMIN IF(PY2(I).GT.PYMAX)PY2(I)=PYMAX 6135 CONTINUE C NP2=NP+1 PX2(NP2)=PX2(NP) PY2(NP2)=PBASE2 NP2=NP2+1 PX2(NP2)=PX2(1) PY2(NP2)=PBASE2 NP2=NP2+1 PX2(NP2)=PX2(1) PY2(NP2)=PY2(1) C IPATT2=IRE2PL CALL DPFIRE(PX2,PY2,NP2, 1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,IPATT2) C GOTO6190 C 6190 CONTINUE C C ***************************************** C ** STEP 7-- ** C ** DRAW OUT THE TRACE ** C ** (BUT CLIP IT FIRST, IF NECESSARY) ** C ***************************************** C IFIG='GENE' IPATT=ILI2PA PTHICK=PLI2TH ICOL=ILI2CO C CALL DPCLTR(PX,PY,NP,PX2,PY2,NP2,PY3,PX3,NP3, 1PXMIN,PXMAX,PYMIN,PYMAX, 1ISORSW, 1IFIG,IPATT,PTHICK,ICOL) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRTR')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPDRTR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)NP 9012 FORMAT('NP = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ICASPL,ICAS3D 9013 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') IF(NP.LE.3)GOTO9029 DO9025I=1,3 WRITE(ICOUT,9026)I,X(I),Y(I) 9026 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9025 CONTINUE NPM2=NP-2 DO9027I=NPM2,NP WRITE(ICOUT,9028)I,X(I),Y(I) 9028 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9027 CONTINUE 9029 CONTINUE WRITE(ICOUT,9030)ISORSW 9030 FORMAT('ISORSW = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9031)ILI2PA,ILI2CO,PLI2TH 9031 FORMAT('ILI2PA,ILI2CO,PLI2TH = ',A4,2X,A4,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9032)ARE2BA 9032 FORMAT('ARE2BA = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9033)IRE2FS,IRE2FC 9033 FORMAT('IRE2FS,IRE2FC = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9034)IRE2PT,IRE2PL,IRE2PC,PRE2PT,PRE2PS 9034 FORMAT('IRE2PT,IRE2PL,IRE2PC,PRE2PT,PRE2PS = ', 1A4,2X,A4,2X,A4,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9044)PXMIN,PXMAX,PYMIN,PYMAX 9044 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX= ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9045)FX1MIN,FX1MAX,FY1MIN,FY1MAX 9045 FORMAT('FX1MIN,FX1MAX,FY1MIN,FY1MAX= ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9046)FXMIN,FXMAX,FYMIN,FYMAX 9046 FORMAT('FXMIN,FXMAX,FYMIN,FYMAX= ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9047)IX1TSC,IY1TSC 9047 FORMAT('IX1TSC,IY1TSC = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9049)IBUGG4,ISUBG4,IERRG4 9049 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPDUAN(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IBUGG2,IBUGG3,ISUBRO,IBUGQ,IFOUND,IERROR) C C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS C THAT WILL DEFINE A DUANE PLOT C (USED IN RELIABILITY) C VERTICAL AXIS = Ti /I C HORIZONTAL AXIS = Ti C WHERE Ti ARE SORTED FAILURE TIMES 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/5 C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IAND1 CHARACTER*4 IAND2 CHARACTER*4 IBUGG2 CHARACTER*4 IBUGG3 CHARACTER*4 ISUBRO CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASQ CHARACTER*4 IH CHARACTER*4 IH2 CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CCCCC CHARACTER*4 IHVA21 CCCCC CHARACTER*4 IHVA22 C CHARACTER*4 ISUBN0 CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION Y1(MAXOBV) INCLUDE 'DPCOZZ.INC' EQUIVALENCE (GARBAG(IGARB1),Y1(1)) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOHO.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' 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-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C ISUBN1='DPDU' ISUBN2='AN ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C MAXV2=2 MINN2=2 C ICOLV2=0 C IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'DUAN')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPDUAN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICASPL,IAND1,IAND2 52 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ 53 FORMAT('IBUGG2,IBUGG3,IBUGQ = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)MAXCOL 54 FORMAT('MAXCOL = ',I8) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C C ********************************** C ** TREAT THE DUANE PLOT ** C ********************************** C C ******************************************* C ** STEP 1-- ** C ** SEARCH FOR DUANE PLOT ** C ******************************************* C ISTEPN='11' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DUAN') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASPL='DUAN' IF(NUMARG.GE.1.AND. 1ICOM.EQ.'DUAN'.AND.IHARG(1).EQ.'PLOT') 1GOTO111 C ICASPL=' ' IFOUND='NO' GOTO9000 C 111 CONTINUE ILASTC=1 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO180 C 180 CONTINUE IFOUND='YES' GOTO190 C 190 CONTINUE C C ******************************************************* C ** STEP 2-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ******************************************************* C ISTEPN='2' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DUAN') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=1 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IF(ICASPL.EQ.'DUAN')GOTO270 C 260 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,261) 261 FORMAT('***** INTERNAL ERROR IN DPDUAN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,262) 262 FORMAT(' AT BRANCH POINT 261--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,263) 263 FORMAT(' ICASPL NOT EQUAL TO DUAN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,266)ICASPL 266 FORMAT(' ICASPL = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,267) 267 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,268)(IANS(I),I=1,IWIDTH) 268 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 270 CONTINUE MAXV2=1 GOTO290 C 290 CONTINUE C C ******************************************** C ** STEP 11-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C ** (THIS WILL BE THE RESPONSE VARIABLE) ** C ******************************************** C ISTEPN='11' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DUAN') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHLEFT=IHARG(1) IHLEF2=IHARG2(1) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHLEFT,IHLEF2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLL=IVALUE(ILOCV) NLEFT=IN(ILOCV) C C *********************************************************** C ** STEP 12-- ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (NLEFT) ** C ** FOR THE RESPONSE VARIABLE IS POSITIVE. ** C *********************************************************** C ISTEPN='12' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DUAN') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NLEFT.GE.MINN2)GOTO1290 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1211) 1211 FORMAT('***** ERROR IN DPDUAN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1212)IHLEFT,IHLEF2 1212 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS ', 1'IN VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1213) 1213 FORMAT(' (FOR WHICH A DUANE PLOT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1214) 1214 FORMAT(' IS TO BE GENERATED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1215)MINN2 1215 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1216) 1216 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1217) 1217 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1218)(IANS(I),I=1,IWIDTH) 1218 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1290 CONTINUE C C ***************************************** C ** STEP 21-- ** C ** CHECK TO SEE THE TYPE CASE-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='21' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DUAN') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO2190 DO2100J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO2110 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO2110 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO2120 2100 CONTINUE GOTO2190 2110 CONTINUE ICASQ='SUBS' ILOCQ=J1 GOTO2190 2120 CONTINUE ICASQ='FOR' ILOCQ=J1 GOTO2190 2190 CONTINUE IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'DUAN')GOTO2195 WRITE(ICOUT,2191)NUMARG,ILOCQ 2191 FORMAT('NUMARG,ILOCQ = ',2I8) CALL DPWRST('XXX','BUG ') 2195 CONTINUE C C *********************************************** C ** STEP 22-- ** C ** CHECK FOR A VALID NUMBER ** C ** OF VARIABLES ** C ** (EXACTLY 1 ** C ** FOR A DUANE PLOT). ** C *********************************************** C ISTEPN='22' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DUAN') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMV2=ILOCQ-1 IF(1.LE.NUMV2.AND.NUMV2.LE.MAXV2)GOTO2209 GOTO2250 C 2209 CONTINUE IF(NUMV2.LE.1)GOTO2290 C 2250 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2251) 2251 FORMAT('***** ERROR IN DPDUAN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2252) 2252 FORMAT(' FOR A DUANE PLOT,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2253) 2253 FORMAT(' THE NUMBER OF VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2254) 2254 FORMAT(' MUST BE EXACTLY 1 ;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2255) 2255 FORMAT(' SUCH WAS NOT THE CASE HERE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2256) 2256 FORMAT(' THE SPECIFIED NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2257)NUMV2 2257 FORMAT(' OF VARIABLES WAS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2258) 2258 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2259)(IANS(I),I=1,IWIDTH) 2259 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 2290 CONTINUE C C ********************************************** C ** STEP 31-- ** C ** FORM THE VARIABLE Y1(.) ** C ** WHICH WILL CONTAIN THE VARIABLE; ** C ** FORM THIS VARIABLE BY ** C ** BRANCHING TO THE APPROPRIATE SUBCASE ** C ** (FULL, SUBSET, OR FOR). ** C ********************************************** C ISTEPN='31' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DUAN') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASQ.EQ.'FULL')GOTO3110 IF(ICASQ.EQ.'SUBS')GOTO3120 IF(ICASQ.EQ.'FOR')GOTO3130 C 3110 CONTINUE DO3115I=1,NLEFT ISUB(I)=1 3115 CONTINUE NQ=NLEFT GOTO3150 C 3120 CONTINUE NIOLD=NLEFT CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO3150 C 3130 CONTINUE NIOLD=NLEFT CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO3150 C 3150 CONTINUE IF(NQ.GE.MINN2)GOTO3160 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3151) 3151 FORMAT('***** ERROR IN DPDUAN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3152) 3152 FORMAT(' AFTER THE APPROPRIATE SUBSET HAS BEEN ', 1'EXTRACTED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3153)IHLEFT,IHLEF2 3153 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING', 1'FROM VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3154) 3154 FORMAT(' (FOR WHICH AN AUTO OR CROSS-PERIODOGRAM ', 1'ANALYSIS ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3155) 3155 FORMAT(' IS TO BE FORMED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3156)MINN2 3156 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3157) 3157 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3158) 3158 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,3159)(IANS(I),I=1,IWIDTH) 3159 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 3160 CONTINUE J=0 IMAX=NLEFT IF(NQ.LT.NLEFT)IMAX=NQ DO3170I=1,IMAX IF(ISUB(I).EQ.0)GOTO3170 J=J+1 C IJ=MAXN*(ICOLL-1)+I IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DUAN') 1WRITE(ICOUT,3166)I,J,IJ,ICOLL,MAXCOL,MAXN,V(IJ) 3166 FORMAT('I,J,IJ,ICOLL,MAXCOL,MAXN,V(IJ) = ',6I8,E15.7) IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DUAN') 1CALL DPWRST('XXX','BUG ') IF(ICOLL.LE.MAXCOL)Y1(J)=V(IJ) IF(ICOLL.EQ.MAXCP1)Y1(J)=PRED(I) IF(ICOLL.EQ.MAXCP2)Y1(J)=RES(I) IF(ICOLL.EQ.MAXCP3)Y1(J)=YPLOT(I) IF(ICOLL.EQ.MAXCP4)Y1(J)=XPLOT(I) IF(ICOLL.EQ.MAXCP5)Y1(J)=X2PLOT(I) CCCCC THE FOLLOWING LINE WAS FIXED APRIL 1992 CCCCC IF(ICOLL.EQ.MAXCP31)Y1(J)=TAGPLO(I) IF(ICOLL.EQ.MAXCP6)Y1(J)=TAGPLO(I) C 3170 CONTINUE NS=J C C ************************************************************* C ** STEP 41-- ** C ** FORM THE VERTICAL AND HORIZONTALAXIS ** C ** VARIABLES (Y(.) AND X(.), RESPECTIVELY)FOR THE PLOT. ** C ** FORM THE CURVE DESIGNATION VARIABLED(.) . ** C ** THIS WILL BE ALL ONES. ** C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** C ** DEFINE THE NUMBER OF PLOT VARIABLES(NPLOTV). ** C ************************************************************* C ISTEPN='41' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DUAN') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL DPDUA2(Y1,NS,ICASPL,MAXN, 1Y,X,D,NPLOTP,NPLOTV, 1ALPHA,BETA,XRESSD,XRESDF,CCXY,SDALPH,SDBETA,CCALBE, 1IBUGG3,ISUBRO,IERROR) C C *************************************** C ** STEP 61-- ** C ** COMPUTE DUANE PLOT STAT ** C ** UPDATE INTERNAL DATAPLOT TABLES ** C *************************************** C ISTEPN='61' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CCCCC ISUBN0='DPDU' CCCCC CALL LINFIT(Y,X,NPLOTP, CCCCC1ALPHA,BETA,XRESSD,XRESDF,CCXY,SDALPH,SDBETA,CCALBE, CCCCC1ISUBRO,IBUGG3,IERROR) C IH='DPCC' IH2=' ' VALUE0=CCXY CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGG3,IERROR) C IH='DPA0' IH2=' ' VALUE0=ALPHA CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGG3,IERROR) C IH='DPA1' IH2=' ' VALUE0=BETA CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGG3,IERROR) C IH='SDDP' IH2='A0 ' VALUE0=SDALPH CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGG3,IERROR) C IH='SDDP' IH2='A1 ' VALUE0=SDBETA CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGG3,IERROR) C IH='DPRE' IH2='SSD ' VALUE0=XRESSD CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGG3,IERROR) C IH='DPRE' IH2='SDF ' VALUE0=XRESDF CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGG3,IERROR) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'DUAN')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPDUAN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IFOUND,IERROR 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 9013 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ', 1I8,I8,I8,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') IF(NPLOTP.LE.0)GOTO9090 DO9015I=1,NPLOTP WRITE(ICOUT,9016)I,Y(I),X(I),D(I) 9016 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPDUA2(Y1,N,ICASPL,MAXN, 1Y,X,D,NPLOTP,NPLOTV, 1ALPHA,BETA,XRESSD,XRESDF,CCXY,SDALPH,SDBETA,CCALBE, 1IBUGG3,ISUBRO,IERROR) C C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS C THAT WILL DEFINE A DUANE PLOT C VERTICAL AXIS = Ti/I C HORIZONTAL AXIS = Ti C INPUT ARGUMENTS--Y1 = THE SINGLE PRECISION VECTOR OF C (UNSORTED) OBSERVATIONS C FOR THE FIRST VARIABLE. C N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C CAUTION--THE INPUT VARIABLE Y1(.) WILL BE CHANGED HEREIN C (IT WILL BE SORTED) 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/5 C ORIGINAL VERSION--MAY 1998. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IBUGG3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISUBN0 CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION Y1(*) C DIMENSION Y(*) DIMENSION X(*) DIMENSION D(*) 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='DPDU' ISUBN2='A2 ' C IERROR='NO' C IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'DUA2')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPDUA2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGG3,ISUBRO,IERROR 52 FORMAT('IBUGG3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N,ICASPL,MAXN 53 FORMAT('N,ICASPL,MAXN = ',I8,2X,A4,I8) CALL DPWRST('XXX','BUG ') DO55I=1,N 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 ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(N.GE.2)GOTO119 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN DPDUA2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' MUST BE AT LEAST 2;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114)N 114 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 119 CONTINUE C HOLD=Y1(1) DO120I=1,N IF(Y1(I).NE.HOLD)GOTO129 120 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** ERROR IN DPDUA2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,122) 122 FORMAT(' ALL ELEMENTS IN Y1 ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,123)HOLD 123 FORMAT(' ARE IDENTICALLY EQUAL TO ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 129 CONTINUE C C *********************************************** C ** STEP 12-- ** C ** COMPUTE COORDINATES FOR TAIL AREA PLOT ** C ** (INCORPORATE STAIR-STEP APPEARANCE) ** C ** NOTE--THE LOGGING OF THE 1-F(X) WILL ** C ** NOTE BE DONE HEREIN BUT WILL ** C ** BE DONE IN THE UNDERLYING ** C ** GRAPHICS BY LOG SCALE ** C *********************************************** C C CALL SORT(Y1,N,Y1) C AN=N J=0 DO1100I=1,N J=J+1 X(J)=Y1(I) Y(J)=Y1(J)/REAL(J) D(J)=1.0 1100 CONTINUE NPLOTP=J C C NOTE: FOR FITTED LINE, NEED TO FIT THE LOGS OF Y AND X C ISUBN0='DPDU' DO200I=1,NPLOTP Y(I)=LOG(Y(I)) X(I)=LOG(X(I)) 200 CONTINUE CALL LINFIT(Y,X,NPLOTP, 1ALPHA,BETA,XRESSD,XRESDF,CCXY,SDALPH,SDBETA,CCALBE, 1ISUBRO,IBUGG3,IERROR) DO300I=1,NPLOTP Y(I)=EXP(Y(I)) X(I)=EXP(X(I)) 300 CONTINUE NPLOTP=NPLOTP+1 X(NPLOTP)=X(1) Y(NPLOTP)=EXP(ALPHA+BETA*LOG(X(1))) D(NPLOTP)=2.0 NPLOTP=NPLOTP+1 X(NPLOTP)=X(N) Y(NPLOTP)=EXP(ALPHA+BETA*LOG(X(N))) D(NPLOTP)=2.0 C NPLOTV=2 GOTO9000 C C ****************** C ** STEP 90-- ** C ** EXIT ** C ****************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'DUA2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPDUA2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGG3,ISUBRO,IERROR 9012 FORMAT('IBUGG3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N,ICASPL,MAXN 9013 FORMAT('N,ICASPL,MAXN = ',I8,2X,A4,I8) CALL DPWRST('XXX','BUG ') DO9015I=1,N WRITE(ICOUT,9016)I,Y1(I) 9016 FORMAT('I, Y1(I), = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE WRITE(ICOUT,9021)NPLOTP,NPLOTV 9021 FORMAT('NPLOTP,NPLOTV = ',2I8) CALL DPWRST('XXX','BUG ') DO9022I=1,NPLOTP WRITE(ICOUT,9023)I,Y(I),X(I),D(I) 9023 FORMAT('I,Y(I),X(I),D(I) = ',I8,3E15.7) CALL DPWRST('XXX','BUG ') 9022 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPDURB(YTEMP,XTEMP,MAXNXT, 1ICAPSW, 1IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) C C PURPOSE--CARRY OUT DURBIN TEST C NON-PARAMETRIC TWO-WAY ANOVA OF INCOMPLETE BLOCK C DESIGNS C EXAMPLE--DURBIN TEST Y X1 X2 C REFERENCE--W. J. CONOVER (1999). "PRACTICAL NONPARAMETRIC C STATISTICS", THIRD EDITION, WILEY, PP. 388-395. 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--2006/1 C ORIGINAL VERSION--JANUARY 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICAPSW CHARACTER*4 IBUGA2 CHARACTER*4 IBUGA3 CHARACTER*4 IBUGQ CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASEQ C CHARACTER*4 IH11 CHARACTER*4 IH12 CHARACTER*4 IH21 CHARACTER*4 IH22 CHARACTER*4 IH31 CHARACTER*4 IH32 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C CHARACTER*4 IUSE1 CHARACTER*4 IUSE2 CHARACTER*4 IUSE3 C CHARACTER*4 IH CHARACTER*4 IH2 CHARACTER*4 IHOST1 CHARACTER*4 ISUBN0 C C--------------------------------------------------------------------- C DIMENSION YTEMP(*) DIMENSION XTEMP(*) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION XTEMP2(MAXOBV) DIMENSION DBLOCK(MAXOBV) DIMENSION DTREAT(MAXOBV) DIMENSION YRANK(MAXOBV) DIMENSION RJ(MAXOBV) C INCLUDE 'DPCOZZ.INC' EQUIVALENCE(GARBAG(IGARB1),XTEMP2(1)) EQUIVALENCE(GARBAG(IGARB2),DBLOCK(1)) EQUIVALENCE(GARBAG(IGARB3),DTREAT(1)) EQUIVALENCE(GARBAG(IGARB4),YRANK(1)) EQUIVALENCE(GARBAG(IGARB5),RJ(1)) C INCLUDE 'DPCOHK.INC' INCLUDE 'DPCOSU.INC' INCLUDE 'DPCODA.INC' 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-----START POINT----------------------------------------------------- C ISUBN1='DPDU' ISUBN2='RB ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C IFOUND='NO' IERROR='NO' C N1=(-999) N2=(-999) C NS1=(-999) NS2=(-999) C IUSE1='-999' IUSE2='-999' C ILOCV=(-999) C VALUE1=(-999.0) VALUE2=(-999.0) C ICOL1=(-999) ICOL2=(-999) C MINN2=4 C IFOUND='YES' C NLEFT=0 C ICASEQ='UNKN' C C ****************************************** C ** TREAT THE DURBIN TEST CASE ** C ****************************************** C IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'DURB')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPDURB--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ 52 FORMAT('IBUGA2,IBUGA3,IBUBQ = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICAPSW,ICAPTY 53 FORMAT('ICAPSW,ICAPTY = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)MAXNXT 55 FORMAT('MAXNXT = ',I8) CALL DPWRST('XXX','BUG ') ENDIF C C ****************************************************** C ** STEP 2-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ****************************************************** C ISTEPN='2' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=3 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2, 1IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C **************************************** C ** STEP 11-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C ** (THIS SHULD BE A VARIABLE.) ** C **************************************** C ISTEPN='11' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'DURB') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IH11=IHARG(1) IH12=IHARG2(1) IHWUSE='V' MESSAG='YES' CALL CHECKN(IH11,IH12,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) C IF(IERROR.EQ.'YES')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT('***** ERROR IN DURBIN TEST--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' FOR THE DURBIN TEST, THE FIRST ARGUMENT (THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1145) 1145 FORMAT(' RESPONSE VARIABLE) MUST BE A VARIABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1146) 1146 FORMAT(' (AS OPPOSED TO A PARAMETER OR FUNCTION).') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1147) 1147 FORMAT(' ARGUMENT 1 WAS NOT A VARIABLE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1148) 1148 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,1150)(IANS(I),I=1,MIN(IWIDTH,80)) 1150 FORMAT(80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF C IUSE1=IUSE(ILOCV) ICOL1=IVALUE(ILOCV) N1=IN(ILOCV) 1190 CONTINUE C C ****************************************************** C ** STEP 12-- ** C ** IF ARGUMENT 1 IS A VARIABLE, ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (N1)** C ** FOR ARGUMENT 1 IS 4 OR MORE. ** C ****************************************************** C ISTEPN='12' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'DURB') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IUSE1.EQ.'V' .AND. N1.LE.MINN2)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1211) 1211 FORMAT('***** ERROR IN DURBIN TEST--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1212) 1212 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS FOR WHICH THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1214) 1214 FORMAT(' DURBIN TEST WAS TO HAVE BEEN CARRIED OUT MUST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1216)MINN2 1216 FORMAT(' BE ',I8,' OR LARGER; SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1218)IH11,IH12,N1 1218 FORMAT(' VARIABLE ',A4,A4,' HAS ',I8,' OBSERVATIONS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1219) 1219 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,1220)(IANS(I),I=1,MIN(IWIDTH,80)) 1220 FORMAT(80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF C C **************************************** C ** STEP 21-- ** C ** CHECK THE VALIDITY OF ARGUMENT 2 ** C ** (THIS SHOULD ALSO BE A VARIABLE) ** C **************************************** C ISTEPN='21' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'DURB') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IH21=IHARG(2) IH22=IHARG2(2) IHWUSE='V' MESSAG='YES' CALL CHECKN(IH21,IH22,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) C IF(IERROR.EQ.'YES')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2141) 2141 FORMAT('***** ERROR IN THE DURBIN TEST--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2142) 2142 FORMAT(' FOR THE DURBIN TEST, THE SECOND ARGUMENT (THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2145) 2145 FORMAT(' FIRST FACTOR (= BLOCK) VARIABLE) MUST BE A') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2146) 2146 FORMAT(' VARIABLE (AS OPPOSED TO A PARAMETER OR') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2147) 2147 FORMAT(' FUNCTION). ARGUMENT 2 WAS NOT A VARIABLE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2148) 2148 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2150)(IANS(I),I=1,MIN(IWIDTH,80)) 2150 FORMAT(80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF C IUSE2=IUSE(ILOCV) ICOL2=IVALUE(ILOCV) N2=IN(ILOCV) C C ****************************************************** C ** STEP 21B-- ** C ** IF ARGUMENT 2 IS A VARIABLE, ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (N2)** C ** FOR ARGUMENT 2 IS THE SAME AS ARGUMENT 1. ** C ****************************************************** C ISTEPN='21B' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'DURB') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IUSE2.EQ.'V' .AND. N1.NE.N2)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2161) 2161 FORMAT('***** ERROR IN THE DURBIN TEST--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2162) 2162 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS FOR VARIABLE 2') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2163) 2163 FORMAT(' OF THE DURBIN TEST MUST BE THE SAME AS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2165) 2165 FORMAT(' VARIABLE 1. SUCH WAS NOT THE CASE HERE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2166)N1,N2 2166 FORMAT(' N1 = ',I8,' N2 = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2169) 2169 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2170)(IANS(I),I=1,MIN(IWIDTH,80)) 2170 FORMAT(80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF C C **************************************** C ** STEP 22-- ** C ** CHECK THE VALIDITY OF ARGUMENT 3 ** C ** (THIS SHOULD ALSO BE A VARIABLE) ** C **************************************** C ISTEPN='22' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'DURB') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IH31=IHARG(3) IH32=IHARG2(3) IHWUSE='V' MESSAG='YES' CALL CHECKN(IH31,IH32,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) C IF(IERROR.EQ.'YES')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2241) 2241 FORMAT('***** ERROR IN THE DURBIN TEST--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2242) 2242 FORMAT(' FOR THE DURBIN TEST, THE THIRD ARGUMENT (THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2245) 2245 FORMAT(' SECOND FACTOR (= TREATMENT) VARIABLE) MUST BE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2246) 2246 FORMAT(' A VARIABLE (AS OPPOSED TO A PARAMETER OR') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2247) 2247 FORMAT(' FUNCTION). ARGUMENT 3 WAS NOT A VARIABLE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2248) 2248 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2250)(IANS(I),I=1,MIN(IWIDTH,80)) 2250 FORMAT(80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF C IUSE3=IUSE(ILOCV) ICOL3=IVALUE(ILOCV) N3=IN(ILOCV) C C ****************************************************** C ** STEP 21B-- ** C ** IF ARGUMENT 3 IS A VARIABLE, ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (N3)** C ** FOR ARGUMENT 3 IS THE SAME AS ARGUMENT 1. ** C ****************************************************** C ISTEPN='22B' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'DURB') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IUSE3.EQ.'V' .AND. N1.NE.N3)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2261) 2261 FORMAT('***** ERROR IN THE DURBIN TEST--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2262) 2262 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS FOR VARIABLE 3') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2263) 2263 FORMAT(' OF THE DURBIN TEST MUST BE THE SAME AS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2265) 2265 FORMAT(' VARIABLE 1. SUCH WAS NOT THE CASE HERE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2266)N1,N3 2266 FORMAT(' N1 = ',I8,' N3 = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2269) 2269 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2270)(IANS(I),I=1,MIN(IWIDTH,80)) 2270 FORMAT(80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF C C ***************************************** C ** STEP 40-- ** C ** CHECK TO SEE THE TYPE CASE-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='40' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO4090 DO4000J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO4010 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO4010 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO4020 4000 CONTINUE GOTO4090 4010 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO4090 4020 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO4090 4090 CONTINUE C IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'DURB')THEN WRITE(ICOUT,4091)NUMARG,ILOCQ 4091 FORMAT('NUMARG,ILOCQ = ',2I8) CALL DPWRST('XXX','BUG ') ENDIF C C *********************************************** C ** STEP 41-- ** C ** TEMPORARILY FORM THE VARIABLE Y(.) ** C ** WHICH WILL HOLD THE DATA FROM SAMPLE 1. ** C ** FORM THIS VARIABLE BY ** C ** BRANCHING TO THE APPROPRIATE SUBCASE ** C ** (FULL, SUBSET, OR FOR). ** C *********************************************** C ISTEPN='41' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO4110 IF(ICASEQ.EQ.'SUBS')GOTO4120 IF(ICASEQ.EQ.'FOR')GOTO4130 C 4110 CONTINUE DO4115I=1,N1 ISUB(I)=1 4115 CONTINUE NQ=N1 GOTO4150 C 4120 CONTINUE NIOLD=N1 CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO4150 C 4130 CONTINUE NIOLD=N1 CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO4150 C 4150 CONTINUE IF(NQ.LE.MINN2)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4151) 4151 FORMAT('***** ERROR IN THE DURBIN TEST--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4152) 4152 FORMAT(' AFTER THE APPROPRIATE SUBSET HAS BEEN EXTRACTED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4153)IH11,IH12 4153 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING FROM ', 1 'VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4154) 4154 FORMAT(' (FOR WHICH THE DURBIN TEST IS TO BE CARRIED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4156)MINN2 4156 FORMAT(' OUT) MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4157)NQ 4157 FORMAT(' SUCH WAS NOT THE CASE HERE. (N = ',I8,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4158) 4158 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,4159)(IANS(I),I=1,MIN(IWIDTH,80)) 4159 FORMAT(' ',80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF C J=0 IMAX=N1 IF(NQ.LT.N1)IMAX=NQ DO4170I=1,IMAX IF(ISUB(I).EQ.0)GOTO4170 J=J+1 C IJ=MAXN*(ICOL1-1)+I IF(ICOL1.LE.MAXCOL)Y(J)=V(IJ) IF(ICOL1.EQ.MAXCP1)Y(J)=PRED(I) IF(ICOL1.EQ.MAXCP2)Y(J)=RES(I) IF(ICOL1.EQ.MAXCP3)Y(J)=YPLOT(I) IF(ICOL1.EQ.MAXCP4)Y(J)=XPLOT(I) IF(ICOL1.EQ.MAXCP5)Y(J)=X2PLOT(I) IF(ICOL1.EQ.MAXCP6)Y(J)=TAGPLO(I) C IJ=MAXN*(ICOL2-1)+I IF(ICOL2.LE.MAXCOL)X(J)=V(IJ) IF(ICOL2.EQ.MAXCP1)X(J)=PRED(I) IF(ICOL2.EQ.MAXCP2)X(J)=RES(I) IF(ICOL2.EQ.MAXCP3)X(J)=YPLOT(I) IF(ICOL2.EQ.MAXCP4)X(J)=XPLOT(I) IF(ICOL2.EQ.MAXCP5)X(J)=X2PLOT(I) IF(ICOL2.EQ.MAXCP6)X(J)=TAGPLO(I) C IJ=MAXN*(ICOL3-1)+I IF(ICOL2.LE.MAXCOL)XTEMP2(J)=V(IJ) IF(ICOL2.EQ.MAXCP1)XTEMP2(J)=PRED(I) IF(ICOL2.EQ.MAXCP2)XTEMP2(J)=RES(I) IF(ICOL2.EQ.MAXCP3)XTEMP2(J)=YPLOT(I) IF(ICOL2.EQ.MAXCP4)XTEMP2(J)=XPLOT(I) IF(ICOL2.EQ.MAXCP5)XTEMP2(J)=X2PLOT(I) IF(ICOL2.EQ.MAXCP6)XTEMP2(J)=TAGPLO(I) C 4170 CONTINUE NS1=J C C ********************************** C ** STEP 52-- ** C ** CARRY OUT THE DURBIN TEST ** C ********************************** C ISTEPN='52' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'DURB') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'DURB')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5211) 5211 FORMAT('***** FROM DPDURB, AS WE ARE ABOUT TO CALL DPDUR2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5212)N1,N2,N3,NS1,MAXN 5212 FORMAT('N1,N2,N3,NS1,MAXN = ',5I8) CALL DPWRST('XXX','BUG ') DO5215I=1,NS1 WRITE(ICOUT,5216)I,Y(I),X(I),XTEMP2(I) 5216 FORMAT('I,Y(I),X(I),XTEMP2(I) = ',I8,3E15.7) CALL DPWRST('XXX','BUG ') 5215 CONTINUE WRITE(ICOUT,5231)IBUGA3 5231 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') ENDIF C CALL DPDUR2(Y,X,XTEMP2,NS1, 1YTEMP,XTEMP,YRANK,RJ,DBLOCK,DTREAT,MAXNXT, 1STATVA,STATCD,CUT0,CUT50,CUT75,CUT90,CUT95,CUT99,CUT999, 1ICAPSW,ICAPTY, 1IBUGA3,ISUBRO,IERROR) C C *************************************** C ** STEP 61-- ** C ** UPDATE INTERNAL DATAPLOT TABLES ** C *************************************** C ISTEPN='61' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'DURB') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ISUBN0='DPFR' C IH='STAT' IH2='VAL ' VALUE0=STATVA CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='STAT' IH2='CDF ' VALUE0=STATCD CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTO' IH2='FF0 ' VALUE0=CUT0 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTO' IH2='FF50' VALUE0=CUT50 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTO' IH2='FF75' VALUE0=CUT75 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTO' IH2='FF90' VALUE0=CUT90 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTO' IH2='FF95' VALUE0=CUT95 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTO' IH2='FF99' VALUE0=CUT99 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTO' IH2='F999' VALUE0=CUT99 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'DUR2')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPDURB--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA2,IBUGA3,IBUGQ 9012 FORMAT('IBUGA2,IBUGA3,IBUGQ = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)N1,N2,N3,NS1 9014 FORMAT('N1,N2,N3,NS1 = ',4I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)ICASEQ 9015 FORMAT('ICASEQ = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)IFOUND,IERROR 9016 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') ENDIF C RETURN END SUBROUTINE DPDUR2(Y,BLOCK,TREAT,N, 1YTEMP,XTEMP,YRANK,RJ,DBLOCK,DTREAT,MAXNXT, 1STATVA,STATCD,CUT0,CUT50,CUT75,CUT90,CUT95,CUT99,CUT999, 1ICAPSW,ICAPTY, 1IBUGA3,ISUBRO,IERROR) C C PURPOSE--THIS ROUTINE CARRIES OUT DURBIN'S TEST C NON-PARAMETRIC TWO-WAY ANOVA FOR BALANCED, C INCOMPLETE BLOCK DESIGNS C EXAMPLE--DURBIN TEST Y BLOCK TREAT C REFERENCE--W. J. CONOVER (1999). "PRACTICAL NONPARAMETRIC C STATISTICS", THIRD EDITION, WILEY, PP. 388-395. 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 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/1 C ORIGINAL VERSION--JANUARY 2006. C UPDATED --OCTOBER 2006. CALL LIST TO TPPF C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICAPSW CHARACTER*4 ICAPTY CHARACTER*1 IBASLC CHARACTER*4 IBUGA3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 IWRITE C CHARACTER*6 ICONC1 CHARACTER*6 ICONC2 CHARACTER*6 ICONC3 C CHARACTER*4 ISUBN0 CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C CHARACTER*3 IATEMP C DOUBLE PRECISION DSUM1 DOUBLE PRECISION DSUM2 C C--------------------------------------------------------------------- C DIMENSION Y(*) DIMENSION BLOCK(*) DIMENSION TREAT(*) DIMENSION YRANK(*) DIMENSION RJ(*) DIMENSION DBLOCK(*) DIMENSION DTREAT(*) DIMENSION YTEMP(*) DIMENSION XTEMP(*) C INCLUDE 'DPCOF2.INC' C CHARACTER*80 IFILE1 CHARACTER*12 ISTAT1 CHARACTER*12 IFORM1 CHARACTER*12 IACCE1 CHARACTER*12 IPROT1 CHARACTER*12 ICURS1 CHARACTER*4 IERRF1 CHARACTER*4 IENDF1 CHARACTER*4 IREWI1 C CHARACTER*80 IFILE2 CHARACTER*12 ISTAT2 CHARACTER*12 IFORM2 CHARACTER*12 IACCE2 CHARACTER*12 IPROT2 CHARACTER*12 ICURS2 CHARACTER*4 IERRF2 CHARACTER*4 IENDF2 CHARACTER*4 IREWI2 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='DPDU' ISUBN2='R2 ' C IERROR='NO' C IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DUR2')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,51) 51 FORMAT('**** AT THE BEGINNING OF DPDUR2--') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,55)N 55 FORMAT('N = ',I8) CALL DPWRST('XXX','WRIT') DO56I=1,N WRITE(ICOUT,57)I,Y(I),BLOCK(I),TREAT(I) 57 FORMAT('I,Y(I),BLOCK(I),TREAT(I) = ',I8,3E15.7) CALL DPWRST('XXX','WRIT') 56 CONTINUE ENDIF C C ******************************************** C ** STEP 11-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C ISTEPN='11' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DUR2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C HOLD=Y(1) DO1135I=2,N IF(Y(I).NE.HOLD)GOTO1139 1135 CONTINUE 1130 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1131)HOLD 1131 FORMAT('***** NOTE FROM DURBIN TEST--RESPONSE VARIABLE ', 1 'HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','WRIT') GOTO9000 1139 CONTINUE C HOLD=BLOCK(1) DO1235I=2,N IF(BLOCK(I).NE.HOLD)GOTO1239 1235 CONTINUE 1230 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1231)HOLD 1231 FORMAT('***** NOTE FROM DURBIN TEST--FIRST FACTOR VARIABLE ', 1 'HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','WRIT') GOTO9000 1239 CONTINUE C HOLD=TREAT(1) DO1335I=2,N IF(TREAT(I).NE.HOLD)GOTO1339 1335 CONTINUE 1330 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1331)HOLD 1331 FORMAT('***** NOTE FROM DURBIN TEST--SECOND FACTOR VARIABLE ', 1 'HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','WRIT') GOTO9000 1339 CONTINUE C C ******************************************** C ** STEP 12-- ** C ** CHECK TO SEE IF A BALANCED DESIGN ** C ** WAS ENTERED. ** C ** 1) EVERY BLOCK CONTAINS K EXPERIMENTAL** C ** UNITS. ** C ** 2) EVERY TREATMENT APPEARS IN R ** C ** BLOCKS. ** C ******************************************** C ISTEPN='12' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DUR2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C STEP 1: COMPUTE NUMBER OF DISTINCT BLOCKS AND TREATMENTS C CALL DISTIN(BLOCK,N,IWRITE,DBLOCK,NBLOCK,IBUGA3,IERROR) IF(IERROR.EQ.'YES' .OR. NBLOCK.LE.0)GOTO9000 CALL DISTIN(TREAT,N,IWRITE,DTREAT,NTREAT,IBUGA3,IERROR) IF(IERROR.EQ.'YES' .OR. NTREAT.LE.0)GOTO9000 C C STEP 2: DETERMINE IF EVERY BLOCK CONTAINS K EXPERIMENTAL C TREATMENTS C KHOLD=0 DO1410I=1,NBLOCK ABLOCK=BLOCK(I) NK=0 DO1420J=1,N IF(BLOCK(J).EQ.ABLOCK)NK=NK+1 1420 CONTINUE IF(KHOLD.EQ.0)THEN KHOLD=NK ELSE IF(NK.NE.KHOLD)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1431) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1432) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1433)I,NK,KHOLD CALL DPWRST('XXX','WRIT') IERROR='YES' GOTO9000 ENDIF ENDIF 1410 CONTINUE 1431 FORMAT('***** ERROR FROM DURBIN TEST--') 1432 FORMAT(' UNEQUAL BLOCK SIZES DETECTED:') 1433 FORMAT(' BLOCK ',I8,' HAD ',I8,' TREATMENTS WHEN ', 1 I8,' TREATMENTS WERE EXPECTED.') C C STEP 3: DETERMINE IF EVERY TREATMENT APPEARS IN R BLOCKS C (FOR NOW JUST CHECK THAT IT APPEARS R TIMES) C IRHOLD=0 DO1510I=1,NTREAT ATREAT=TREAT(I) NR=0 DO1520J=1,N IF(TREAT(J).EQ.ATREAT)NR=NR+1 1520 CONTINUE IF(IRHOLD.EQ.0)THEN IRHOLD=NR ELSE IF(NR.NE.IRHOLD)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1531) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1532) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1533)I,NR,IRHOLD CALL DPWRST('XXX','WRIT') IERROR='YES' GOTO9000 ENDIF ENDIF 1510 CONTINUE 1531 FORMAT('***** ERROR FROM DURBIN TEST--') 1532 FORMAT(' UNEQUAL TREATMENT SIZES DETECTED:') 1533 FORMAT(' TREATMENT ',I8,' APPEARED ',I8,' TIMES ', 1 'WHEN ',I8,' OCCURENCES WERE EXPECTED.') C C ****************************** C ** STEP 21-- ** C ** CARRY OUT CALCULATIONS ** C ** FOR DURBIN TEST ** C ****************************** C ISTEPN='21' IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DUR2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IWRITE='OFF' C C COMPUTATIONAL ALGORITHM: C C 1. X(IJ) = RESPONSE FOR BLOCK I, TREATMENT J C 2. R(X(IJ)) = RANK OF X(IJ) WITHIN EACH BLOCK C 3. R(J) = SUM[I=1 TO K][R(X(IJ))] C 4. A = SUM[I=1 TO B][J=1 TO T][(R(X(IJ)]**2 C 5. C = B*K(K+1)**2/4 C 6. T1 = (T-1)*{SUM[J=1 TO T][R(J)**2] - R*C]/(A-C) C DSUM1=0.0D0 DSUM2=0.0D0 DO4010I=1,MAXNXT XTEMP(I)=0.0 YTEMP(I)=0.0 YRANK(I)=0.0 RJ(I)=0.0 4010 CONTINUE C C EXTRACT THE X(IJ) FOR EACH BLOCK C DO2110I=1,NBLOCK HOLD=DBLOCK(I) ICOUNT=0 DO2120J=1,N IF(BLOCK(J).EQ.HOLD)THEN ICOUNT=ICOUNT+1 YTEMP(ICOUNT)=Y(J) ENDIF 2120 CONTINUE CALL RANK(YTEMP,ICOUNT,IWRITE,XTEMP,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOUNT=0 DO2130J=1,N IF(BLOCK(J).EQ.HOLD)THEN ICOUNT=ICOUNT+1 YRANK(J)=XTEMP(ICOUNT) ENDIF 2130 CONTINUE 2110 CONTINUE C IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DUR2')THEN DO2140I=1,N WRITE(ICOUT,2142)I,Y(I),YRANK(I) 2142 FORMAT('I,Y(I),YRANK(I) = ',I8,E15.7,F12.2) CALL DPWRST('XXX','BUG ') 2140 CONTINUE ENDIF C C STEP 3: NOW COMPUTE RANK SUMS FOR EACH TREATMENT C DO2210I=1,NTREAT HOLD=DTREAT(I) DSUM1=0.0D0 DO2220J=1,N IF(TREAT(J).EQ.HOLD)THEN DSUM1=DSUM1 + DBLE(YRANK(J)) ENDIF 2220 CONTINUE RJ(I)=REAL(DSUM1) 2210 CONTINUE C IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DUR2')THEN DO2240I=1,NTREAT WRITE(ICOUT,2242)I,RJ(I) 2242 FORMAT('I,RJ(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 2240 CONTINUE ENDIF C C STEP 4: NOW COMPUTE VARIOUS QUANTITIES BASED ON RJ C DSUM2=0.0D0 DO2310I=1,N DSUM2=DSUM2 + DBLE(YRANK(I))**2 2310 CONTINUE A=REAL(DSUM2) B=REAL(NBLOCK) T=REAL(NTREAT) R=REAL(NR) AK=REAL(NK) C=B*AK*(AK+1)**2/4.0 DENOM=A-C C1=(T-1.0) C2=R*C C DSUM1=0.0D0 DO2320I=1,NTREAT DSUM1=DSUM1 + RJ(I)**2 2320 CONTINUE T1=C1*(REAL(DSUM1)-C2)/DENOM T2=(T1/C1)/((B*(AK-1.0) - T1)/(B*AK - B - T + 1.0)) C STATVA=T2 NUMDF1=NTREAT-1 NUMDF2=INT(B*AK - B - T +1) CALL FCDF(STATVA,NUMDF1,NUMDF2,STATCD) C CUT0=0.0 CALL FPPF(.50,NUMDF1,NUMDF2,CUT50) CALL FPPF(.75,NUMDF1,NUMDF2,CUT75) CALL FPPF(.90,NUMDF1,NUMDF2,CUT90) CALL FPPF(.95,NUMDF1,NUMDF2,CUT95) CALL FPPF(.99,NUMDF1,NUMDF2,CUT99) CALL FPPF(.999,NUMDF1,NUMDF2,CUT999) C IDF=INT(B*AK - B - T + 1.0) CALL TPPF(0.95,REAL(IDF),T95) CALL TPPF(0.975,REAL(IDF),T975) CALL TPPF(0.995,REAL(IDF),T995) TERM1=(A-C)*2.0*R/(B*AK - B - T + 1.0) TERM2=1.0 - (T1/(B*(AK - 1.0))) CONTRA=SQRT(TERM1*TERM2) CONTR1=T95*CONTRA CONTR2=T975*CONTRA CONTR3=T995*CONTRA C ICONC1='ACCEPT' ICONC2='ACCEPT' ICONC3='ACCEPT' C IF(STATVA.GT.CUT95)ICONC2='REJECT' C C ***************************** C ** STEP 42- ** C ** WRITE OUT THE TABLE ** C ***************************** C ISTEPN='42' IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DUR2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IOUNI1=IST1NU IFILE1=IST1NA ISTAT1=IST1ST IFORM1=IST1FO IACCE1=IST1AC IPROT1=IST1PR ICURS1=IST1CS ISUBN0='DUR2' IERRF1='NO' C IREWI1='ON' CALL DPOPFI(IOUNI1,IFILE1,ISTAT1,IFORM1,IACCE1,IPROT1,ICURS1, 1IREWI1,ISUBN0,IERRF1,IBUGA3,ISUBRO,IERROR) IF(IERRF1.EQ.'YES')GOTO9000 C IOUNI2=IST2NU IFILE2=IST2NA ISTAT2=IST2ST IFORM2=IST2FO IACCE2=IST2AC IPROT2=IST2PR ICURS2=IST2CS ISUBN0='DUR2' IERRF2='NO' C IREWI2='ON' CALL DPOPFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 1IREWI2,ISUBN0,IERRF2,IBUGA3,ISUBRO,IERROR) IF(IERRF2.EQ.'YES')GOTO9000 C WRITE(IOUNI1,2005) 2005 FORMAT(4X,'RESPONSE',13X,'RANK',11X,'BLOCK',8X,'TREATMENT') DO2010I=1,N WRITE(IOUNI1,2011)Y(I),YRANK(I),BLOCK(I),TREAT(I) 2011 FORMAT(1X,E15.7,F15.2,F15.2,F15.2) 2010 CONTINUE C WRITE(IOUNI2,2021)CONTRA 2021 FORMAT(1X,'Contrast term: ',E15.7) WRITE(IOUNI2,2022)CONTR1 2022 FORMAT(1X,'Contrast term*t(0.95): ',E15.7) WRITE(IOUNI2,2023)CONTR2 2023 FORMAT(1X,'Contrast term*t(0.975): ',E15.7) WRITE(IOUNI2,2024)CONTR3 2024 FORMAT(1X,'Contrast term*t(0.995): ',E15.7) WRITE(IOUNI2,2025) 2025 FORMAT(10X,'I',10X,'J',8X,'|R(I)-R(J)|') C DO2030I=1,NTREAT DO2039J=1,NTREAT IF(I.LT.J)THEN ADIFF=ABS(RJ(I)-RJ(J)) IATEMP=' ' IF(ABS(ADIFF).GE.CONTR1)IATEMP(1:1)='*' IF(ABS(ADIFF).GE.CONTR2)IATEMP(2:2)='*' IF(ABS(ADIFF).GE.CONTR3)IATEMP(3:3)='*' WRITE(IOUNI2,2037)I,J,ADIFF,IATEMP 2037 FORMAT(3X,I8,3X,I8,5X,E15.7,A3) ENDIF 2039 CONTINUE 2030 CONTINUE C IENDF1='OFF' IREWI1='ON' CALL DPCLFI(IOUNI1,IFILE1,ISTAT1,IFORM1,IACCE1,IPROT1,ICURS1, 1IENDF1,IREWI1,ISUBN0,IERRF1,IBUGA3,ISUBRO,IERROR) IF(IERRF1.EQ.'YES')GOTO9000 C IENDF2='OFF' IREWI2='ON' CALL DPCLFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 1IENDF2,IREWI2,ISUBN0,IERRF2,IBUGA3,ISUBRO,IERROR) IF(IERRF2.EQ.'YES')GOTO9000 C C ****************************** C ** STEP 43-- ** C ** WRITE OUT EVERYTHING ** C ** FOR DURBIN TEST ** C ****************************** C ISTEPN='43' IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DUR2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IPRINT.EQ.'ON')THEN IF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'HTML')THEN C C STEP 1: WRITE HEADER C WRITE(ICOUT,5001) 5001 FORMAT('') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5002) 5002 FORMAT('
') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5003) 5003 FORMAT('DURBIN TEST FOR IDENTICAL TREATMENT ', 1 'EFFECTS:
') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5013) 5013 FORMAT('TWO-WAY BALANCED INCOMPLETE BLOCK DESIGN') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5004) 5004 FORMAT('


') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C C STEP 2: START LIST C WRITE(ICOUT,5005) 5005 FORMAT('
    ') CALL DPWRST('XXX','WRIT') C C STEP 2A: LIST ITEM 1 C WRITE(ICOUT,5006) 5006 FORMAT('
  1. Statistics:') CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5007) 5007 FORMAT('

    ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5011) 5011 FORMAT(' ') CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5021) 5021 FORMAT(' ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) 5023 FORMAT(' ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) 5026 FORMAT(' ') CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5041) 5041 FORMAT(' Number of Blocks:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5029)NBLOCK CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5042) 5042 FORMAT(' Number of Treatments:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5029)NTREAT CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5942) 5942 FORMAT(' Number of Blocks For Each ', 1 'Treatment') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5029)NR CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5044) 5044 FORMAT(' A (Sum of Squares of Ranks):') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)A 5051 FORMAT(' ',G15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5045) 5045 FORMAT(' C (Correction Factor):') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)C1 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) 5047 FORMAT(' Durbin T1 Test Statistic ', 1 '(Uncorrected):') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)T1 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5046) 5046 FORMAT(' Durbin T2 Test Statistic ', 1 '(Corrected):') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)STATVA CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5091) 5091 FORMAT('
    ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5025) 5025 FORMAT(' Number of Observations:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) 5027 FORMAT(' ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5029)N 5029 FORMAT(' ',I8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) 5028 FORMAT('
    ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5007) CALL DPWRST('XXX','WRIT') C C STEP 2B: LIST ITEM 2 C WRITE(ICOUT,5066) 5066 FORMAT('

  2. Percent Points of the F Reference ', 1 'Distribution
    ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5067) 5067 FORMAT(' for DURBIN Test Statistic:') CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5007) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5011) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5071) 5071 FORMAT(' 0 Percent Point:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)CUT0 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5072) 5072 FORMAT(' 50 Percent Point:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)CUT50 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5073) 5073 FORMAT(' 75 Percent Point:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)CUT75 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5074) 5074 FORMAT(' 90 Percent Point:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)CUT90 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5075) 5075 FORMAT(' 95 Percent Point:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)CUT95 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5076) 5076 FORMAT(' 99 Percent Point:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)CUT99 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5077) 5077 FORMAT(' 99.9 Percent Point:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)CUT999 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5078)100.0*STATCD 5078 FORMAT('
    ',G15.7,' Percent Point:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5052)STATVA 5052 FORMAT('
    ',G15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5091) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5007) CALL DPWRST('XXX','WRIT') C C STEP 2C: LIST ITEM 3 C WRITE(ICOUT,5081) 5081 FORMAT('
  3. Conclusion (at the 5% level):') CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5007) CALL DPWRST('XXX','WRIT') IF(STATVA.LE.CUT95)THEN WRITE(ICOUT,5087)NTREAT 5087 FORMAT(' The ',I8,' treatments have identical ', 1 'effects.') ELSE WRITE(ICOUT,5088)NTREAT 5088 FORMAT(' The ',I8,' treatments do not have ', 1 'identical effects.') ENDIF CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5093) 5093 FORMAT('
') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5095) 5095 FORMAT('
')
        CALL DPWRST('XXX','WRIT')
C
      ELSEIF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'LATE')THEN
 8001   FORMAT('{',A1,'bf DURBIN TEST FOR IDENTICAL TREATMENT ',
     1         'EFFECTS:}')
 8091   FORMAT('{',A1,'bf TWO-WAY BALANCED INCOMPLETE BLOCK ',
     1         'DESIGNS}')
 8002   FORMAT(A1,'begin{table}')
 8003   FORMAT(A1,'end{table}')
 8004   FORMAT(A1,'begin{center}')
 8005   FORMAT(A1,'end{center}')
 8006   FORMAT(A1,'end{verbatim}')
 8007   FORMAT(5X,'$ ',A1,1X,A1,' $ ',A1,A1)
 8011   FORMAT(A1,'begin{enumerate}')
 8012   FORMAT(A1,'end{enumerate}')
C
        CALL DPCONA(92,IBASLC)
C
        WRITE(ICOUT,8006)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8004)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8002)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8001)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8091)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8007)IBASLC,IBASLC,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8007)IBASLC,IBASLC,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8011)IBASLC
        CALL DPWRST('XXX','WRIT')
C
 8020   FORMAT(11X,A1,'newline')
 8021   FORMAT(5X,A1,'item Statistics:')
 8022   FORMAT(5X,A1,'item Percent Points of the F Reference ',
     1         'Distribution:')
 8023   FORMAT(5X,A1,'item Conclusion (at the 5',A1,'% level):')
 8030   FORMAT(11X,A1,'begin{tabular} {lr}')
 8031   FORMAT(11X,'Number of Observations: & ',I8,2X,A1,A1)
 8032   FORMAT(11X,'Number of Blocks: & ',I8,2X,A1,A1)
 8033   FORMAT(11X,'Number of Treatments: & ',I8,2X,A1,A1)
 8933   FORMAT(11X,'Number of Blocks for Each Treatment: & ',
     1         I8,2X,A1,A1)
 8034   FORMAT(11X,'Durbin Test Statistic T1 (Uncorrected): & ',
     1         G15.7,2X,A1,A1)
 8035   FORMAT(11X,'A (Sum of Squares of Ranks): & ',G15.7,2X,A1,A1)
 8036   FORMAT(11X,'C (Correction Factor): & ',G15.7,2X,A1,A1)
 8037   FORMAT(11X,'Durbin Test Statistic T2 (Corrected): & ',
     1         G15.7,2X,A1,A1)
 8040   FORMAT(11X,A1,'end{tabular}')
 8041   FORMAT(11X,G15.7,' Percent Point: & ',G15.7,2X,A1,A1)
 8042   FORMAT(11X,'The ',I8,' treatments have identical effects.',
     1         2X,A1,A1)
 8043   FORMAT(11X,'The ',I8,' treatments do not have identical ',
     1         'effects.',2X,A1,A1)
 8044   FORMAT(11X,'0      Percent Point: & ',G15.7,2X,A1,A1)
 8045   FORMAT(11X,'50     Percent Point: & ',G15.7,2X,A1,A1)
 8046   FORMAT(11X,'90     Percent Point: & ',G15.7,2X,A1,A1)
 8047   FORMAT(11X,'95     Percent Point: & ',G15.7,2X,A1,A1)
 8048   FORMAT(11X,'99     Percent Point: & ',G15.7,2X,A1,A1)
 8049   FORMAT(11X,'99.9   Percent Point: & ',G15.7,2X,A1,A1)
C
        WRITE(ICOUT,8021)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8020)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8030)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8031)N,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8032)NBLOCK,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8033)NTREAT,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8933)NR,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8035)A,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8036)C,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8034)T1,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8037)STATVA,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8040)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,8022)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8020)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8030)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8044)CUT0,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8045)CUT50,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8046)CUT90,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8047)CUT95,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8048)CUT99,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8049)CUT999,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8041)100.*STATCD,STATVA,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8040)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,8023)IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8020)IBASLC
        CALL DPWRST('XXX','WRIT')
        IF(STATVA.LE.CUT95)THEN
          WRITE(ICOUT,8042)NTREAT,IBASLC,IBASLC
          CALL DPWRST('XXX','WRIT')
        ELSE
          WRITE(ICOUT,8043)NTREAT,IBASLC,IBASLC
          CALL DPWRST('XXX','WRIT')
        ENDIF
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
 8051   FORMAT(A1,'end{enumerate}')
 8052   FORMAT(A1,'begin{verbatim}')
        WRITE(ICOUT,8051)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8003)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8005)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8052)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
      ELSEIF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'RTF')THEN
C
      ELSE
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7211)
 7211   FORMAT('              DURBIN TEST FOR IDENTICAL ',
     1         'TREATMENT EFFECTS:')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7213)
 7213   FORMAT('              TWO-WAY BALANCED, INCOMPLETE ',
     1         'BLOCK DESIGNS')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,7220)
 7220   FORMAT('1. STATISTICS')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7221)N
 7221   FORMAT(6X,'NUMBER OF OBSERVATIONS                 = ',I8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7222)NBLOCK
 7222   FORMAT(6X,'NUMBER OF BLOCKS                       = ',I8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7223)NTREAT
 7223   FORMAT(6X,'NUMBER OF TREATMENTS                   = ',I8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7224)NR
 7224   FORMAT(6X,'NUMBER OF BLOCKS FOR EACH TREATMENT    = ',I8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7225)A
 7225   FORMAT(6X,'A (SUM OF SQUARES OF RANKS)            = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7226)C
 7226   FORMAT(6X,'C (CORRECTION FACTOR)                  = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7227)T1
 7227   FORMAT(6X,'DURBIN TEST STATISTIC T1 (UNCORRECTED) = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7228)STATVA
 7228   FORMAT(6X,'DURBIN TEST STATISTIC T2 (CORRECTED)   = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7240)
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7240)
 7240   FORMAT('2. PERCENT POINTS OF THE F REFERENCE DISTRIBUTION')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7241)
 7241   FORMAT('   FOR DURBIN TEST STATISTIC')
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,7265)CUT0
 7265   FORMAT(6X,'0          % POINT    = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7266)CUT50
 7266   FORMAT(6X,'50         % POINT    = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7267)CUT75
 7267   FORMAT(6X,'75         % POINT    = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7268)CUT90
 7268   FORMAT(6X,'90         % POINT    = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7269)CUT95
 7269   FORMAT(6X,'95         % POINT    = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7270)CUT99
 7270   FORMAT(6X,'99         % POINT    = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7271)CUT999
 7271   FORMAT(6X,'99.9       % POINT    = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7280)100.*STATCD,STATVA
 7280   FORMAT(6X,G15.7,'   % Point:  ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,7291)
 7291   FORMAT('3. CONCLUSION (AT THE 5% LEVEL):')
        CALL DPWRST('XXX','WRIT')
        IF(STATVA.LE.CUT95)THEN
          WRITE(ICOUT,7293)NTREAT
 7293     FORMAT(6X,'THE ',I8,' TREATMENTS HAVE IDENTICAL EFFECTS')
          CALL DPWRST('XXX','WRIT')
        ELSE
          WRITE(ICOUT,7295)NTREAT
 7295     FORMAT(6X,'THE ',I8,' TREATMENTS DO NOT HAVE IDENTICAL ',
     1           'EFFECTS')
          CALL DPWRST('XXX','WRIT')
        ENDIF
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        IF(IFEEDB.EQ.'ON')THEN
          WRITE(ICOUT,9212)
 9212     FORMAT(6X,'RESPONSE, RANKED RESPONSE, BLOCK AND TREATMENT ',
     1           ' WRITTEN TO FILE DPST1F.DAT')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,9214)
 9214     FORMAT(6X,'TREATMENT RANKS AND COMPARISONS WRITTEN TO FILE ',
     1           ' DPST2F.DAT')
          CALL DPWRST('XXX','BUG ')
        ENDIF
C
      ENDIF
      ENDIF
C
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DUR2')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF DPDUR2--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9012)N,IBUGA3,IERROR
 9012   FORMAT('N,IBUGA3,IERROR = ',I8,2X,A4,2X,A4)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9015)N
 9015   FORMAT('N = ',I8)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE DPECDF(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
     1IBUGG2,IBUGG3,ISUBRO,IBUGQ,IFOUND,IERROR)
C
C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
C              THAT WILL DEFINE AN EMPIRICAL CDF PLOT
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/5
C     ORIGINAL VERSION--MAY       1998.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASPL
      CHARACTER*4 IAND1
      CHARACTER*4 IAND2
      CHARACTER*4 IBUGG2
      CHARACTER*4 IBUGG3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGQ
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
      CHARACTER*4 IHWUSE
      CHARACTER*4 MESSAG
      CHARACTER*4 ICASQ
      CHARACTER*4 IHLEFT
      CHARACTER*4 IHLEF2
      CHARACTER*4 IHRIGH
      CHARACTER*4 IHRIG2
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
C
      DIMENSION Y1(MAXOBV)
      DIMENSION X1(MAXOBV)
      INCLUDE 'DPCOZZ.INC'
      EQUIVALENCE (GARBAG(IGARB1),Y1(1))
      EQUIVALENCE (GARBAG(IGARB2),X1(1))
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOHK.INC'
      INCLUDE 'DPCODA.INC'
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-----START POINT-----------------------------------------------------
C
      IFOUND='NO'
      IERROR='NO'
C
      ISUBN1='DPEC'
      ISUBN2='DF  '
C
      MAXCP1=MAXCOL+1
      MAXCP2=MAXCOL+2
      MAXCP3=MAXCOL+3
      MAXCP4=MAXCOL+4
      MAXCP5=MAXCOL+5
      MAXCP6=MAXCOL+6
C
      MAXV2=2
      MINN2=2
C
      ICOLV2=0
C
      IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'ECDF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPECDF--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)ICASPL,IAND1,IAND2
   52 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ
   53 FORMAT('IBUGG2,IBUGG3,IBUGQ = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)MAXCOL
   54 FORMAT('MAXCOL = ',I8)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C
C               ***********************************
C               **  TREAT THE EMPIRICAL CDF PLOT **
C               ***********************************
C
C               *******************************************
C               **  STEP 1--                             **
C               **  SEARCH FOR EMPIRICAL CDF, ECDF       **
C               *******************************************
C
      ISTEPN='11'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'ECDF')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      ICASPL='ECDF'
      IF(NUMARG.GE.1.AND.
     1ICOM.EQ.'ECDF'.AND.IHARG(1).EQ.'PLOT')
     1GOTO111
C
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'EMPI'.AND.IHARG(1).EQ.'CDF '.AND.IHARG(2).EQ.'PLOT')
     1GOTO112
C
      ICASPL='    '
      IFOUND='NO'
      GOTO9000
C
  111 CONTINUE
      ILASTC=1
      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
      GOTO180
C
  112 CONTINUE
      ILASTC=2
      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
      GOTO180
C
  180 CONTINUE
      IFOUND='YES'
      GOTO190
C
  190 CONTINUE
C
C               *******************************************************
C               **  STEP 2--                                         **
C               **  CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS.  **
C               *******************************************************
C
      ISTEPN='2'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'ECDF')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      MINNA=1
      MAXNA=100
      CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
C
      IF(ICASPL.EQ.'ECDF')GOTO270
C
  260 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,261)
  261 FORMAT('***** INTERNAL ERROR IN DPECDF')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,262)
  262 FORMAT('      AT BRANCH POINT 261--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,263)
  263 FORMAT('      ICASPL NOT EQUAL TO    ECDF')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,266)ICASPL
  266 FORMAT('      ICASPL = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,267)
  267 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,268)(IANS(I),I=1,MIN(IWIDTH,80))
  268 FORMAT(80A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
  270 CONTINUE
      MAXV2=2
      GOTO290
C
  290 CONTINUE
C
C               ********************************************
C               **  STEP 11--                             **
C               **  CHECK THE VALIDITY OF ARGUMENT 1      **
C               **  (THIS WILL BE THE RESPONSE VARIABLE)  **
C               ********************************************
C
      ISTEPN='11'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'ECDF')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IHLEFT=IHARG(1)
      IHLEF2=IHARG2(1)
      IHWUSE='V'
      MESSAG='YES'
      CALL CHECKN(IHLEFT,IHLEF2,IHWUSE,
     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
      ICOLL=IVALUE(ILOCV)
      NLEFT=IN(ILOCV)
C
C               *******************************************************
C               **  STEP 12--                                        **
C               **  CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (NLEFT)
C               **  FOR THE RESPONSE VARIABLE IS POSITIVE.           **
C               *******************************************************
C
      ISTEPN='12'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'ECDF')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(NLEFT.GE.MINN2)GOTO1290
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1211)
 1211 FORMAT('***** ERROR IN DPECDF--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1212)IHLEFT,IHLEF2
 1212 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS ',
     1'IN VARIABLE ',A4,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1213)
 1213 FORMAT('      (FOR WHICH A EMPIRICAL CDF PLOT')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1214)
 1214 FORMAT('      IS TO BE GENERATED)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1215)MINN2
 1215 FORMAT('      MUST BE ',I8,' OR LARGER;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1216)
 1216 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1217)
 1217 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,1218)(IANS(I),I=1,IWIDTH)
 1218 FORMAT('      ',80A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
 1290 CONTINUE
C
C               ********************************************
C               **  STEP 13--                             **
C               **  CHECK THE VALIDITY OF ARGUMENT 2      **
C               **  (THIS WILL BE THE TAG      VARIABLE)  **
C               ********************************************
C
      ISTEPN='13'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'ECDF')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(NUMARG.LE.1)THEN
        NUMV=1
        ICOLR=-1
        NRIGHT=-1
      ELSE 
        IHRIGH=IHARG(2)
        IHRIG2=IHARG2(2)
        IHWUSE='V'
        MESSAG='NO'
        CALL CHECKN(IHLEFT,IHLEF2,IHWUSE,
     1  IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1  ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
        IF(IERROR.EQ.'YES')THEN
          NUMV=1
          ICOLR=-1
          NRIGHT=-1
        ELSE
          NUMV=2
          ICOLR=IVALUE(ILOCV)
          NRIGHT=IN(ILOCV)
        ENDIF
      ENDIF
C
C               ******************************************************
C               **  STEP 14--                                       **
C               **  CHECK THAT THE INPUT NUMBER OF OBSERVATIONS     **
C               **  FOR THE TAG VARIABLE (NRIGHT) IS THE SAME AS    **
C               **  THE NUMBER OF OBSERVATIONS FOR THE RESPONSE     **
C               ** VARIABLE.                                        **
C               ******************************************************
C
      ISTEPN='14'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'ECDF')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(NUMV.LT.2)GOTO1490
      IF(NUMV.EQ.2.AND.NLEFT.EQ.NRIGHT)GOTO1490
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1411)
 1411 FORMAT('***** ERROR IN DPECDF--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1412)
 1412 FORMAT('      IF TWO VARIABLES ARE SPECIFED FOR THE ',
     1'ECDFAN-MEIER PLOT,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1413)
 1413 FORMAT('      THEY MUST HAVE THE SAME NUMBER OF OBSERVATIONS.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1414)
 1414 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1415)IHLEFT,IHLEF2,NLEFT
 1415 FORMAT('      ',A4,A4,' HAS ',I8,' OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1416)IHRIGH,IHRIG2,NRIGHT
 1416 FORMAT('      ',A4,A4,' HAS ',I8,' OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1417)
 1417 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,1418)(IANS(I),I=1,MIN(IWIDTH,80))
 1418 FORMAT('      ',80A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
 1490 CONTINUE
C
C               *****************************************
C               **  STEP 21--                          **
C               **  CHECK TO SEE THE TYPE CASE--       **
C               **    1) UNQUALIFIED (THAT IS, FULL);  **
C               **    2) SUBSET/EXCEPT; OR             **
C               **    3) FOR.                          **
C               *****************************************
C
      ISTEPN='21'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'ECDF')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      ICASQ='FULL'
      ILOCQ=NUMARG+1
      IF(NUMARG.LT.1)GOTO2190
      DO2100J=1,NUMARG
      J1=J
      IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET  ') GOTO2110
      IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT  ') GOTO2110
      IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.'    ') GOTO2120
 2100 CONTINUE
      GOTO2190
 2110 CONTINUE
      ICASQ='SUBS'
      ILOCQ=J1
      GOTO2190
 2120 CONTINUE
      ICASQ='FOR'
      ILOCQ=J1
      GOTO2190
 2190 CONTINUE
      IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'ECDF')GOTO2195
      WRITE(ICOUT,2191)NUMARG,ILOCQ
 2191 FORMAT('NUMARG,ILOCQ = ',2I8)
      CALL DPWRST('XXX','BUG ')
 2195 CONTINUE
C
C               ***********************************************
C               **  STEP 22--                                **
C               **  CHECK FOR A VALID NUMBER                 **
C               **  OF VARIABLES                             **
C               **  (EITHER 1 OR 2                           **
C               **  FOR A EMPIRICAL CDF PLOT).                **
C               ***********************************************
C
      ISTEPN='22'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'ECDF')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      NUMV2=ILOCQ-1
      IF(1.LE.NUMV2.AND.NUMV2.LE.MAXV2)GOTO2209
      GOTO2250
C
 2209 CONTINUE
      IF(NUMV2.LE.2)GOTO2290
C
 2250 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2251)
 2251 FORMAT('***** ERROR IN DPECDF--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2252)
 2252 FORMAT('      FOR A EMPIRICAL CDF PLOT,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2253)
 2253 FORMAT('      THE NUMBER OF VARIABLES ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2254)
 2254 FORMAT('      MUST BE EITHER 1 OR 2  ;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2255)
 2255 FORMAT('      SUCH WAS NOT THE CASE HERE;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2256)
 2256 FORMAT('      THE SPECIFIED NUMBER')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2257)NUMV2
 2257 FORMAT('      OF VARIABLES WAS ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2258)
 2258 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,2259)(IANS(I),I=1,MIN(IWIDTH,80))
 2259 FORMAT(80A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
 2290 CONTINUE
C
C               **********************************************
C               **  STEP 31--                               **
C               **  FORM THE VARIABLE Y1(.)                 **
C               **  WHICH WILL CONTAIN THE        VARIABLE; **
C               **  FORM THIS VARIABLE BY                   **
C               **  BRANCHING TO THE APPROPRIATE SUBCASE    **
C               **  (FULL, SUBSET, OR FOR).                 **
C               **********************************************
C
      ISTEPN='31'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'ECDF')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(ICASQ.EQ.'FULL')GOTO3110
      IF(ICASQ.EQ.'SUBS')GOTO3120
      IF(ICASQ.EQ.'FOR')GOTO3130
C
 3110 CONTINUE
      DO3115I=1,NLEFT
      ISUB(I)=1
 3115 CONTINUE
      NQ=NLEFT
      GOTO3150
C
 3120 CONTINUE
      NIOLD=NLEFT
      CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR)
      NQ=NIOLD
      GOTO3150
C
 3130 CONTINUE
      NIOLD=NLEFT
      CALL DPFOR(NIOLD,NFOR,IROW1,IROWN,
     1NLOCAL,ILOCS,NS,IBUGQ,IERROR)
      NQ=NFOR
      GOTO3150
C
 3150 CONTINUE
      IF(NQ.GE.MINN2)GOTO3160
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3151)
 3151 FORMAT('***** ERROR IN DPECDF--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3152)
 3152 FORMAT('      AFTER THE APPROPRIATE SUBSET HAS BEEN ',
     1'EXTRACTED,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3153)IHLEFT,IHLEF2
 3153 FORMAT('      THE NUMBER OF OBSERVATIONS REMAINING',
     1'FROM VARIABLE ',A4,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3154)
 3154 FORMAT('      (FOR WHICH A EMPIRICAL CDF PLOT IS TO BE ',
     1'FORMED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3156)MINN2
 3156 FORMAT('      MUST BE ',I8,' OR LARGER;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3157)
 3157 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3158)
 3158 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,3159)(IANS(I),I=1,MIN(IWIDTH,80))
 3159 FORMAT('      ',80A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
 3160 CONTINUE
      J=0
      IMAX=NLEFT
      IF(NQ.LT.NLEFT)IMAX=NQ
      DO3170I=1,IMAX
      IF(ISUB(I).EQ.0)GOTO3170
      J=J+1
C
      IJ=MAXN*(ICOLL-1)+I
      IF(ICOLL.LE.MAXCOL)Y1(J)=V(IJ)
      IF(ICOLL.EQ.MAXCP1)Y1(J)=PRED(I)
      IF(ICOLL.EQ.MAXCP2)Y1(J)=RES(I)
      IF(ICOLL.EQ.MAXCP3)Y1(J)=YPLOT(I)
      IF(ICOLL.EQ.MAXCP4)Y1(J)=XPLOT(I)
      IF(ICOLL.EQ.MAXCP5)Y1(J)=X2PLOT(I)
      IF(ICOLL.EQ.MAXCP6)Y1(J)=TAGPLO(I)
C
      IF(NUMV.EQ.1)THEN
        X1(J)=-1.0
        GOTO3170
      ENDIF
      IF(ICOLR.LE.MAXCOL)X1(J)=V(IJ)
      IF(ICOLR.EQ.MAXCP1)X1(J)=PRED(I)
      IF(ICOLR.EQ.MAXCP2)X1(J)=RES(I)
      IF(ICOLR.EQ.MAXCP3)X1(J)=YPLOT(I)
      IF(ICOLR.EQ.MAXCP4)X1(J)=XPLOT(I)
      IF(ICOLR.EQ.MAXCP5)X1(J)=X2PLOT(I)
      IF(ICOLR.EQ.MAXCP6)X1(J)=TAGPLO(I)
C
 3170 CONTINUE
      NS=J
C
C               *******************************************************
C               **  STEP 41--                                        **
C               **  FORM THE VERTICAL AND HORIZONTALAXIS             **
C               **  VARIABLES (Y(.) AND X(.), RESPECTIVELY)FOR THE PLOT. **
C               **  FORM THE CURVE DESIGNATION VARIABLED(.)  .       **
C               **  THIS WILL BE ALL ONES.                           **
C               **  DEFINE THE NUMBER OF PLOT POINTS   (NPLOTP).     **
C               **  DEFINE THE NUMBER OF PLOT VARIABLES(NPLOTV).     **
C               *******************************************************
C
      ISTEPN='41'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'ECDF')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      CALL DPECD2(Y1,X1,NS,NUMV,ICASPL,MAXN,
     1Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR)
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'ECDF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPECDF--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IFOUND,IERROR
 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
 9013 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',
     1I8,I8,I8,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      IF(NPLOTP.LE.0)GOTO9090
      DO9015I=1,NPLOTP
      WRITE(ICOUT,9016)I,Y(I),X(I),D(I)
 9016 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPECD2(Y1,X1,N,NUMV,ICASPL,MAXN,
     1Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR)
C
C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
C              THAT WILL DEFINE AN EMPIRICAL CDF PLOT
C     INPUT ARGUMENTS--Y1     = THE SINGLE PRECISION VECTOR OF
C                               (UNSORTED) OBSERVATIONS
C                               FOR THE FIRST  VARIABLE.
C                               IF X1 IS SPECIFIED, THEN Y1 BECOMES
C                               A FREQUENCY VARIABLE
C                      X1   = IF SPECIFIED, IT REPRESENTS THE
C                             OBSERVATION POINTS (AND Y1 IS THE
C                             FREQUENCY)
C                      N      = THE INTEGER NUMBER OF OBSERVATIONS
C                               IN THE 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-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/5
C     ORIGINAL VERSION--MAY       1998.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      EXTERNAL SUM
C
      CHARACTER*4 ICASPL
      CHARACTER*4 IBUGG3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION Y1(*)
      DIMENSION X1(*)
C
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION D(*)
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='DPEC'
      ISUBN2='D2  '
C
      IERROR='NO'
C
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'ECD2')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPECD2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGG3,ISUBRO,IERROR
   52 FORMAT('IBUGG3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)N,NUMV,ICASPL,MAXN
   53 FORMAT('N,NUMV,ICASPL,MAXN = ',2I8,2X,A4,I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,N
      WRITE(ICOUT,56)I,Y1(I),X1(I)
   56 FORMAT('I, Y1(I), X1(I), = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(N.GE.2)GOTO119
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN DPECD2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,112)
  112 FORMAT('      THE NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,113)
  113 FORMAT('      MUST BE AT LEAST 2;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,114)N
  114 FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  119 CONTINUE
C
      HOLD=Y1(1)
      DO120I=1,N
      IF(Y1(I).NE.HOLD)GOTO129
  120 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,121)
  121 FORMAT('***** ERROR IN DPECD2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,122)
  122 FORMAT('      ALL ELEMENTS IN Y1 ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,123)HOLD
  123 FORMAT('      ARE IDENTICALLY EQUAL TO ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  129 CONTINUE
C
C               ***********************************************
C               **  STEP 12--                                **
C               **  COMPUTE COORDINATES FOR EMPIRICAL CDF PLOT**
C               **  (INCORPORATE STAIR-STEP APPEARANCE)      **
C               ***********************************************
C
      IF(NUMV.EQ.1)THEN
        CALL SORT(Y1,N,Y1)
        J=1
        X(J)=Y1(1)
        Y(J)=0.0
        D(J)=1.0
        J=2
        X(J)=Y1(1)
        Y(J)=1.0/REAL(N)
        D(J)=1.0
        DO200I=2,N
          J=J+1
          X(J)=Y1(I)
          Y(J)=REAL(I-1)/REAL(N)
          D(J)=1.0
          J=J+1
          X(J)=Y1(I)
          Y(J)=REAL(I)/REAL(N)
          D(J)=1.0
  200   CONTINUE
      ELSE
        CALL SORTC(X1,Y1,N,X1,Y1)
        IWRITE='OFF'
        CALL SUM(Y1,N,IWRITE,YSUM,IBUGG3,IERROR)
        CALL CUMSUM(Y1,N,IWRITE,Y1,IBUGG3,IERROR)
        J=1
        X(J)=X1(1)
        Y(J)=0.0
        D(J)=1.0
        J=2
        X(J)=X1(1)
        Y(J)=Y1(1)/REAL(YSUM)
        D(J)=1.0
        DO300I=2,N
          J=J+1
          X(J)=X1(I)
          Y(J)=Y1(I-1)/YSUM
          D(J)=1.0
          J=J+1
          X(J)=X1(I)
          Y(J)=Y1(I)/YSUM
          D(J)=1.0
  300   CONTINUE
      ENDIF
C
      NPLOTP=J
      NPLOTV=2
      GOTO9000
C
C               ******************
C               **   STEP 90--  **
C               **   EXIT       **
C               ******************
C
 9000 CONTINUE
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'ECD2')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPECD2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGG3,ISUBRO,IERROR
 9012 FORMAT('IBUGG3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)N,ICASPL,MAXN
 9013 FORMAT('N,ICASPL,MAXN = ',I8,2X,A4,I8)
      CALL DPWRST('XXX','BUG ')
      DO9015I=1,N
      WRITE(ICOUT,9016)I,Y1(I)
 9016 FORMAT('I, Y1(I), = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
      WRITE(ICOUT,9021)NPLOTP,NPLOTV
 9021 FORMAT('NPLOTP,NPLOTV = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO9022I=1,NPLOTP
      WRITE(ICOUT,9023)I,Y(I),X(I),D(I)
 9023 FORMAT('I,Y(I),X(I),D(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
 9022 CONTINUE
 9090 CONTINUE
C
      RETURN
      END