SUBROUTINE DPI(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1ICONT,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) C C PURPOSE--GENERATE ONE OF THE FOLLOWING 4 I PLOTS-- C 1) MEDIAN; C 2) MEAN; C 3) MIDRANGE; C 4) MIDMEAN; C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--JANUARY 1981. C UPDATED --AUGUST 1981. C UPDATED --MAY 1982. C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IAND1 CHARACTER*4 IAND2 CHARACTER*4 ICONT CHARACTER*4 IBUGG2 CHARACTER*4 IBUGG3 CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASEQ CHARACTER*4 IH CHARACTER*4 IH2 CHARACTER*4 IERRO2 CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CHARACTER*4 IHHOR CHARACTER*4 IHHOR2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION Y1(MAXOBV) DIMENSION X1(MAXOBV) C DIMENSION XIDTEM(MAXOBV) DIMENSION TEMP(MAXOBV) CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZZ.INC' EQUIVALENCE (GARBAG(IGARB1),X1(1)) EQUIVALENCE (GARBAG(IGARB2),Y1(1)) EQUIVALENCE (GARBAG(IGARB3),XIDTEM(1)) EQUIVALENCE (GARBAG(IGARB4),TEMP(1)) CCCCC END CHANGE 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 IERROR='NO' C ISUBN1='DPI ' ISUBN2=' ' 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 ICOLH=0 C C ******************************* C ** TREAT THE I PLOT CASE ** C ******************************* C IF(IBUGG2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPI--') 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)ICONT,IBUGG2,IBUGG3,IBUGQ 53 FORMAT('ICONT,IBUGG2,IBUGG3,IBUGQ = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C *************************** C ** STEP 1-- ** C ** EXTRACT THE COMMAND ** C *************************** C ISTEPN='1' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C ********************************** C ** STEP 1.1-- ** C ** SEARCH FOR MEDIAN I PLOT ** C ********************************** C ICASPL='MDIP' C IF(NUMARG.GE.2.AND. 1ICOM.EQ.'MEDI'.AND.IHARG(1).EQ.'I'.AND.IHARG(2).EQ.'PLOT') 1GOTO112 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'I'.AND.IHARG(1).EQ.'PLOT') 1GOTO111 C C ******************************** C ** STEP 1.2-- ** C ** SEARCH FOR MEAN I PLOT ** C ******************************** C ICASPL='MEIP' C IF(NUMARG.GE.2.AND. 1ICOM.EQ.'MEAN'.AND.IHARG(1).EQ.'I'.AND.IHARG(2).EQ.'PLOT') 1GOTO112 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'XBAR'.AND.IHARG(1).EQ.'I'.AND.IHARG(2).EQ.'PLOT') 1GOTO112 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'AVER'.AND.IHARG(1).EQ.'I'.AND.IHARG(2).EQ.'PLOT') 1GOTO112 C C ********************************** C ** STEP 1.3-- ** C ** SEARCH FOR MIDRANGE I PLOT ** C ********************************** C ICASPL='MRIP' C IF(NUMARG.GE.2.AND. 1ICOM.EQ.'MIDR'.AND.IHARG(1).EQ.'I'.AND.IHARG(2).EQ.'PLOT') 1GOTO112 C C ********************************** C ** STEP 1.4-- ** C ** SEARCH FOR MIDMEAN I PLOT ** C ********************************** C ICASPL='MMIP' C IF(NUMARG.GE.2.AND. 1ICOM.EQ.'MIDM'.AND.IHARG(1).EQ.'I'.AND.IHARG(2).EQ.'PLOT') 1GOTO112 C ICASPL=' ' C 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 1-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C *********************************************************** C ISTEPN='1' IF(IBUGG2.EQ.'ON')CALL 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 C ******************************************** C ** STEP 2-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C ** (THIS WILL BE THE RESPONSE VARIABLE) ** C ******************************************** C ISTEPN='2' IF(IBUGG2.EQ.'ON')CALL 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) IF(IBUGG2.EQ.'ON')WRITE(ICOUT,211)IHLEFT,ICOLL,NLEFT 211 FORMAT('IHLEFT,ICOLL,NLEFT = ',A4,I8,I8) IF(IBUGG2.EQ.'ON')CALL DPWRST('XXX','BUG ') C C *************************************************************** C ** STEP 3-- ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (NLEFT) ** C ** FOR THE RESPONSE VARIABLE IS 2 OR LARGER. ** C *************************************************************** C ISTEPN='3' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NLEFT.GE.MINN2)GOTO390 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,311) 311 FORMAT('***** ERROR IN DPI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,312) 312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'MDIP')WRITE(ICOUT,321) 321 FORMAT(' (FOR WHICH A (MEDIAN) I PLOT ') IF(ICASPL.EQ.'MDIP')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'MEIP')WRITE(ICOUT,322) 322 FORMAT(' (FOR WHICH A MEAN I PLOT ') IF(ICASPL.EQ.'MEIP')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'MRIP')WRITE(ICOUT,323) 323 FORMAT(' (FOR WHICH A MIDRANGE I PLOT ') IF(ICASPL.EQ.'MRIP')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'MMIP')WRITE(ICOUT,324) 324 FORMAT(' (FOR WHICH A MIDMEAN I PLOT ') IF(ICASPL.EQ.'MMIP')CALL DPWRST('XXX','BUG ') WRITE(ICOUT,325) 325 FORMAT(' WAS TO HAVE BEEN FORMED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,326)MINN2 326 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,327) 327 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,328) 328 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,329)(IANS(I),I=1,IWIDTH) 329 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 390 CONTINUE C C ***************************************** C ** STEP 4-- ** C ** CHECK TO SEE THE TYPE SUBCASE ** C ** (BASED ON THE QUALIFIER)-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='4' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO480 DO400J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO410 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO410 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO420 400 CONTINUE GOTO490 410 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO490 420 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO490 C 480 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,481) 481 FORMAT('***** INTERNAL ERROR IN DPI') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,482) 482 FORMAT(' AT BRANCH POINT 481--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,483) 483 FORMAT(' NUMARG LESS THAN 1 EVEN THOUGH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,484) 484 FORMAT(' NUMARG HAD PREVIOUSLY PASSED THIS TEST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,485)NUMARG 485 FORMAT(' ONCE ALREADY. VALUE OF NUMARG = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,486) 486 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,487)(IANS(I),I=1,IWIDTH) 487 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 490 CONTINUE IF(IBUGG2.EQ.'OFF')GOTO495 WRITE(ICOUT,491)NUMARG,ILOCQ,ICASEQ 491 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') 495 CONTINUE C C ************************************************************ C ** STEP 5-- ** C ** IF A SECOND ARGUMENT EXISTS, THEN THIS ** C ** INDICATES THAT THE VALUES IN THE ** C ** FIRST VARIABLE ARE TO BE GROUPED ** C ** BASED ON VALUES OF THE SECOND VARIABLE; ** C ** THAT IS, THE SECOND VARAIBLE DEFINES THE ** C ** GROUP NUMBERS WITHIN WHICH THE MEANS, ** C ** STANDARD DEVIATIONS, RANGES, AND ** C ** CUMULATIVE SUMS ARE TO BE COMPUTED. ** C ** THE VALUES IN THE SECOND VARIABLE ** C ** ARE THE X VALUES FOR EACH MEAN, STANDARD DEVIATION, ** C ** ETC. IN THE RESULTING I PLOT . ** C ** THE VALUES IN THE SECOND VARIABLE ** C ** NEED NOT HAVE BEEN PREVIOUSLY ** C ** SORTED OR HAVE COMMON VALUES ADJACENT. ** C ** IF WE HAVE THE 2-VARIABLE CASE, ** C ** CHECK THE VALIDITY OF THE SECOND (X) VARIABLE. ** C ************************************************************ C ISTEPN='5' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMV2=ILOCQ-1 IF(NUMV2.EQ.1)GOTO590 IF(NUMV2.EQ.2)GOTO530 GOTO510 C 510 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,511) 511 FORMAT('***** ERROR IN DPI--') CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'MDIP')WRITE(ICOUT,512) 512 FORMAT(' FOR A (MEDIAN) I PLOT, ') IF(ICASPL.EQ.'MDIP')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'MEIP')WRITE(ICOUT,513) 513 FORMAT(' FOR A MEAN I PLOT, ') IF(ICASPL.EQ.'MEIP')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'MRIP')WRITE(ICOUT,514) 514 FORMAT(' (FOR WHICH A MIDRANGE I PLOT ') IF(ICASPL.EQ.'MRIP')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'MMIP')WRITE(ICOUT,515) 515 FORMAT(' (FOR WHICH A MIDMEAN I PLOT ') IF(ICASPL.EQ.'MMIP')CALL DPWRST('XXX','BUG ') WRITE(ICOUT,518) 518 FORMAT(' THE NUMBER OF VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,519) 519 FORMAT(' MUST BE EITHER 1 OR 2 ;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,520) 520 FORMAT(' SUCH WAS NOT THE CASE HERE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,521) 521 FORMAT(' THE SPECIFIED NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,522)NUMV2 522 FORMAT(' OF VARIABLES WAS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,523) 523 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,524)(IANS(I),I=1,IWIDTH) 524 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 530 CONTINUE IHHOR=IHARG(2) IHHOR2=IHARG2(2) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHHOR,IHHOR2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLH=IVALUE(ILOCV) NHOR=IN(ILOCV) IF(IBUGG2.EQ.'ON')WRITE(ICOUT,531)IHHOR,ICOLH,NHOR 531 FORMAT('IHHOR,ICOLH,NHOR = ',A4,I8,I8) IF(IBUGG2.EQ.'ON')CALL DPWRST('XXX','BUG ') C IF(NHOR.NE.NLEFT)GOTO570 GOTO590 C 570 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,571) 571 FORMAT('***** ERROR IN DPI--') CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'MDIP')WRITE(ICOUT,572) 572 FORMAT(' FOR A (MEDIAN) I PLOT CHART, ') IF(ICASPL.EQ.'MDIP')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'MEIP')WRITE(ICOUT,573) 573 FORMAT(' FOR A MEAN I PLOT,') IF(ICASPL.EQ.'MEIP')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'MRIP')WRITE(ICOUT,574) 574 FORMAT(' (FOR WHICH A MIDRANGE I PLOT ') IF(ICASPL.EQ.'MRIP')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'MMIP')WRITE(ICOUT,575) 575 FORMAT(' (FOR WHICH A MIDMEAN I PLOT ') IF(ICASPL.EQ.'MMIP')CALL DPWRST('XXX','BUG ') WRITE(ICOUT,578) 578 FORMAT(' WHEN HAVE 2 VARAIBLES SPECIFIED, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,579) 579 FORMAT(' THE NUMBER OF ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,580) 580 FORMAT(' IN THE 2 VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,581) 581 FORMAT(' MUST BE THE SAME; ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,582) 582 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,583) 583 FORMAT(' THE FIRST VARIABLE (RESPONSE VALUES)--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,584)IHLEFT,NLEFT 584 FORMAT(' ',A4,' HAS ',I8,' ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,585) 585 FORMAT(' THE SECOND VARIABLE (HORIZ. AXIS VALUES)--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,586)IHHOR,NHOR 586 FORMAT(' ',A4,' HAS ',I8,' ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,587) 587 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,588)(IANS(I),I=1,IWIDTH) 588 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 590 CONTINUE C C ************************************************* C ** STEP 6-- ** C ** BRANCH TO THE APPROPRIATE SUBCASE; ** C ** (BASED ON THE QUALIFIER) ** C ** THEN FORM THE RESPONSE VARIABLE ** C ** AND THE SECOND VARIABLE (IF EXISTENT) ** C ************************************************* C ISTEPN='6' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO610 IF(ICASEQ.EQ.'SUBS')GOTO620 IF(ICASEQ.EQ.'FOR')GOTO630 C 610 CONTINUE DO615I=1,NLEFT ISUB(I)=1 615 CONTINUE NQ=NLEFT GOTO650 C 620 CONTINUE NIOLD=NLEFT CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO650 C 630 CONTINUE NIOLD=NLEFT CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO650 C 650 CONTINUE J=0 IMAX=NLEFT IF(NQ.LT.NLEFT)IMAX=NQ DO660I=1,IMAX IF(ISUB(I).EQ.0)GOTO660 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) IF(NUMV2.LE.1)GOTO660 C IJ=MAXN*(ICOLH-1)+I IF(ICOLH.LE.MAXCOL)X1(J)=V(IJ) IF(ICOLH.EQ.MAXCP1)X1(J)=PRED(I) IF(ICOLH.EQ.MAXCP2)X1(J)=RES(I) IF(ICOLH.EQ.MAXCP3)X1(J)=YPLOT(I) IF(ICOLH.EQ.MAXCP4)X1(J)=XPLOT(I) IF(ICOLH.EQ.MAXCP5)X1(J)=X2PLOT(I) IF(ICOLH.EQ.MAXCP6)X1(J)=TAGPLO(I) C 660 CONTINUE NLOCAL=J C C **************************************************************** C ** STEP 7-- ** C ** FOR THE 1-VARIABLE CASE ONLY, * C ** DETERMINE IF THE ANALYST ** C ** HAS SPECIFIED THE GROUP SIZE, ** C ** FOR THE I PLOT ANALYSIS. ** C ** THE GROUP SIZE SETTING IS DEFINED BY SEARCHING THE ** C ** INTERNAL TABLE FOR THE PARAMETER NAME NI ; ** C ** IF FOUND, USE THE SPECIFIED VALUE. ** C ** IF NOT FOUND, GENERATE AN ERROR MESSAGE. ** C **************************************************************** C ISTEPN='7' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMV2.GE.2)GOTO790 C IH='NI ' IH2=' ' IHWUSE='P' MESSAG='YES' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) IERROR=IERRO2 IF(IERRO2.EQ.'YES')GOTO9000 ISIZE=VALUE(ILOCP)+0.5 790 CONTINUE C C C ************************************************************* C ** STEP 8-- ** C ** COMPUTE THE APPROPRIATE I PLOT STATISTIC-- ** C ** (MEDIAN OR MEDAN ). ** C ** COMPUTE CONFIDENCE LINES. ** C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** C ** VALUES Y(.) AND X(.) FOR THE PLOT. ** C ** DEFINE THE VECTOR D(.) TO 1'S, 2'S, AND 3'S ** C ** FOR THE PLOTTED VALUE, THE LOWER CONFIDENCE LINE, ** C ** AND THE UPPER CONFIDENCE LINE. ** C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). ** C ************************************************************* C ISTEPN='8' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C 809 CONTINUE CALL DPI2(Y1,X1,NLOCAL,NUMV2,ICASPL,ISIZE,ICONT, 1XIDTEM,TEMP, 1Y,X,D,NPLOTP,NPLOTV,IBUGG3,IERROR) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPI--') 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 ') WRITE(ICOUT,9014)ISIZE 9014 FORMAT('ISIZE = ',I8) 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 DPI2(Y,X,N,NUMV2,ICASPL,ISIZE,ICONT, 1XIDTEM,TEMP, 1Y2,X2,D2,N2,NPLOTV,IBUGG3,IERROR) C C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS C THAT WILL DEFINE AN I PLOT C OF THE FOLLOWING TYPES-- C 1) (MEDIAN) I PLOT; C 2) MEAN I PLOT; C 3) MIDRANGE I PLOT; C 4) MIDMEAN I 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-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--FEBRUARY 1981. C UPDATED --DECEMBER 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 ICONT CHARACTER*4 IBUGG3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C DIMENSION Y(*) DIMENSION X(*) DIMENSION Y2(*) DIMENSION X2(*) DIMENSION D2(*) C DIMENSION XIDTEM(*) DIMENSION TEMP(*) 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='DPI2' ISUBN2=' ' C I2=0 AN=0.0 C N50=1 C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.GE.1)GOTO39 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,31) 31 FORMAT('***** ERROR IN DPI2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,32) 32 FORMAT(' THE NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,33) 33 FORMAT(' MUST BE AT LEAST 1;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,34)N 34 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 39 CONTINUE C IF(N.GE.2)GOTO49 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46) 46 FORMAT('***** ERROR IN DPI2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47) 47 FORMAT(' THE NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,48) 48 FORMAT(' WAS EXACTLY EQUAL TO 1.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 49 CONTINUE C HOLD=Y(1) DO60I=1,N IF(Y(I).NE.HOLD)GOTO69 60 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61) 61 FORMAT('***** ERROR IN DPI2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62) 62 FORMAT(' ALL RESPONSE VARIABLE ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)HOLD 63 FORMAT(' ARE IDENTICALLY EQUAL TO ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 69 CONTINUE C IF(IBUGG3.EQ.'OFF')GOTO90 WRITE(ICOUT,70) 70 FORMAT('AT THE BEGINNING OF DPI2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71)N,ICASPL,NUMV2,ISIZE,ICONT 71 FORMAT('N,ICASPL,NUMV2,ISIZE,ICONT = ',I8,2X,A4,I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') DO72I=1,N WRITE(ICOUT,73)I,Y(I),X(I) 73 FORMAT('I, Y(I), X(I) = ',I8,2F15.7) CALL DPWRST('XXX','BUG ') 72 CONTINUE 90 CONTINUE C C ******************************************************** C ** STEP 1-- ** C ** DETERMINE THE NUMBER OF DISTINCT VALUES ** C ** FOR VARIABLE 2 (THE GROUP VARIABLE). ** C ** IF ALL VALUES ARE DISTINCT, THEN THIS ** C ** IMPLIES WE HAVE THE NO REPLICATION CASE ** C ** WHICH IS AN ERROR CONDITION FOR AN I PLOT . ** C ******************************************************** C ISTEPN='1' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMV2.EQ.1)GOTO110 IF(NUMV2.EQ.2)GOTO150 C 110 CONTINUE NUMSET=0 DO120I=ISIZE,N,ISIZE I2=I NUMSET=NUMSET+1 XIDTEM(NUMSET)=NUMSET 120 CONTINUE IF(I2.LT.N)GOTO130 GOTO140 130 CONTINUE NUMSET=NUMSET+1 XIDTEM(NUMSET)=NUMSET 140 CONTINUE DO145I=1,N IGROUP=1+((I-1)/ISIZE) IMID=(IGROUP-1)*ISIZE+(ISIZE/2) X(I)=IMID 145 CONTINUE GOTO190 C 150 CONTINUE NUMSET=0 DO160I=1,N IF(NUMSET.EQ.0)GOTO165 DO170J=1,NUMSET IF(X(I).EQ.XIDTEM(J))GOTO160 170 CONTINUE 165 CONTINUE NUMSET=NUMSET+1 XIDTEM(NUMSET)=X(I) 160 CONTINUE CALL SORT(XIDTEM,NUMSET,XIDTEM) C XID1=XIDTEM(1) XID2=XIDTEM(NUMSET) C 190 CONTINUE C IF(NUMSET.EQ.0)WRITE(ICOUT,191) 191 FORMAT('ERROR IN DPI2 SUBROUTINE--NUMSET = 0') IF(NUMSET.EQ.0)CALL DPWRST('XXX','BUG ') IF(NUMSET.EQ.0)GOTO9000 IF(NUMSET.EQ.0)IERROR='YES' C IF(NUMSET.EQ.N)WRITE(ICOUT,192) 192 FORMAT('ERROR IN DPI2 SUBROUTINE--NUMSET = N') IF(NUMSET.EQ.N)CALL DPWRST('XXX','BUG ') IF(NUMSET.EQ.N)IERROR='YES' IF(NUMSET.EQ.N)GOTO9000 C C ************************************************************** C ** STEP 4-- ** C ** IN ORDER TO DETERMINE THE PROPER PLOT COOORDINATES ** C ** FOR THE DESIRED PLOT, ** C ** FIRST BRANCH TO THE PROPER SUBCASE-- ** C ** 1) (MEDIAN) I PLOT; ** C ** 2) MEAN I PLOT; ** C ************************************************************** C ISTEPN='4' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASPL.EQ.'MDIP')GOTO1100 IF(ICASPL.EQ.'MEIP')GOTO1100 IF(ICASPL.EQ.'MRIP')GOTO1100 IF(ICASPL.EQ.'MMIP')GOTO1100 C 260 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,261) 261 FORMAT('***** INTERNAL ERROR IN DPI2') 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 ONE OF THE ALLOWABLE 4--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,264) 264 FORMAT(' MDIP, MEIP, MRIP, OR MMIP') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,266)ICASPL 266 FORMAT(' ICASPL = ',A4) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C C *************************************************** C ** STEP 4A-- ** C ** DETERMINE PLOT COORDINATES FOR 4 SUBCASES-- ** C ** 1) (MEDIAN) I PLOT; ** C ** 2) MEAN I PLOT; ** C ** 3) MIDRANGE I PLOT; ** C ** 4) MIDMEAN I PLOT; ** C *************************************************** C 1100 CONTINUE C ISTEPN='4A' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C AN=N ANUMSE=NUMSET C P1=0.25 P2=0.75 C NUMCPL=11 J=0 JD=0 DO1110ISET=1,NUMSET C K=0 DO1120I=1,N IF(X(I).EQ.XIDTEM(ISET))K=K+1 IF(X(I).EQ.XIDTEM(ISET))TEMP(K)=Y(I) 1120 CONTINUE NI=K ANI=NI C IF(IBUGG3.EQ.'ON')WRITE(ICOUT,1121)ISET,XIDTEM(ISET),NI 1121 FORMAT('ISET,XIDTEM(ISET),NI = ',I8,E15.7,I8) IF(IBUGG3.EQ.'ON')CALL DPWRST('XXX','BUG ') C IF(NI.LE.0)GOTO1140 CALL SORT(TEMP,NI,TEMP) C XMID=XIDTEM(ISET) C C *************************** C ** STEP 4.1-- ** C ** COMPUTE THE MAXIMUM ** C *************************** C YMAX=TEMP(NI) C C ********************************* C ** STEP 4.2-- ** C ** COMPUTE THE TYPICAL VALUE ** C ** (MEDIAN, MEAN, ** C ** MIDRANGE, OR TRIMMED MEAN) ** C ********************************* C IF(ICASPL.EQ.'MDIP')GOTO1131 IF(ICASPL.EQ.'MEIP')GOTO1133 IF(ICASPL.EQ.'MRIP')GOTO1135 IF(ICASPL.EQ.'MMIP')GOTO1137 C 1131 CONTINUE N50=NI/2 N50P1=N50+1 IEVODD=NI-2*(NI/2) IF(IEVODD.EQ.0)Y50=(TEMP(N50)+TEMP(N50P1))/2.0 IF(IEVODD.EQ.1)Y50=TEMP(N50P1) GOTO1139 C 1133 CONTINUE SUM=0.0 DO1134I=1,NI SUM=SUM+TEMP(I) 1134 CONTINUE Y50=SUM/ANI GOTO1139 C 1135 CONTINUE Y50=(TEMP(1)+TEMP(NI))/2.0 GOTO1139 C 1137 CONTINUE NP1=P1*ANI+0.0001 NP2=P2*ANI+0.0001 IMIN=NP1+1 IMAX=N-NP2 IF(IMIN.LT.1)IMIN=1 IF(IMAX.GT.NI)IMAX=NI IF(IMIN.GT.IMAX)IMIN=IMAX Y50=TEMP(1) SUM=0.0 L=0 DO1138I=IMIN,IMAX L=L+1 SUM=SUM+TEMP(I) 1138 CONTINUE AL=L Y50=SUM/AL GOTO1139 C 1139 CONTINUE NP1=P1*ANI+0.0001 NP2=P2*ANI+0.0001 C C *************************** C ** STEP 4.3-- ** C ** COMPUTE THE MINIMUM ** C *************************** C YMIN=TEMP(1) C GOTO1149 C 1140 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT('***** INTERNAL ERROR IN DPI2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT('NI FOR SOME CLASS = 0') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143)ISET,XIDTEM(ISET),NI 1143 FORMAT('ISET,XIDTEM(ISET),NI = ',I8,E15.7,I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1149 CONTINUE IF(IBUGG3.EQ.'ON')WRITE(ICOUT,1151)YMIN,Y50,YMAX,ISET,K,TEMP(K) 1151 FORMAT('YMIN,Y50,YMAX,ISET,K,TEMP(K) = ',3E15.7,2I8,E15.7) IF(IBUGG3.EQ.'ON')CALL DPWRST('XXX','BUG ') C 1160 CONTINUE C C ******************************************** C ** STEP 4.11-- ** C ** DEFINE THE CHARACTER AT THE MAXIMUM; ** C ******************************************** C CALL DPCHLI(ICONT,NUMCPL,YMAX,YMAX,XMID,XMID,J,JD,Y2,X2,D2,IERROR) C C *************************************** C ** STEP 4.12-- ** C ** DEFINE THE CHARACTER ** C ** FOR THE TYPICAL VALUE ** C ** (SUCH AS THE MEDIAN OR MEAN) ** C *************************************** C CALL DPCHLI(ICONT,NUMCPL,Y50,Y50,XMID,XMID,J,JD,Y2,X2,D2,IERROR) C C ******************************************** C ** STEP 4.13-- ** C ** DEFINE THE CHARACTER AT THE MINIMUM. ** C ******************************************** C CALL DPCHLI(ICONT,NUMCPL,YMIN,YMIN,XMID,XMID,J,JD,Y2,X2,D2,IERROR) C C ************************************* C ** STEP 4.14-- ** C ** DEFINE THE VERTICAL LINE FROM ** C ** THE MAX TO THE TYPICAL VALUE ** C ************************************* C CALL DPCHLI(ICONT,NUMCPL,YMAX,Y50,XMID,XMID,J,JD,Y2,X2,D2,IERROR) C C ********************************** C ** STEP 4.15-- ** C ** DEFINE THE VERTICAL LINE ** C ** FROM THE TYPICAL VALUE ** C ** TO THE MIN ** C ********************************** C CALL DPCHLI(ICONT,NUMCPL,Y50,YMIN,XMID,XMID,J,JD,Y2,X2,D2,IERROR) C 1110 CONTINUE C N2=J NPLOTV=3 GOTO9000 C C ****************** C ** STEP 90-- ** C ** EXIT ** C ****************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPI2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ICASPL,N,NUMSET,N2,IERROR 9012 FORMAT('ICASPL,N,NUMSET,N2,IERROR = ',A4,3I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NUMV2 9013 FORMAT('NUMV2 = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)AN,NI,N50 9014 FORMAT('AN,NI,N50 = ',E15.7,2I8) CALL DPWRST('XXX','BUG ') DO9015I=1,N2 WRITE(ICOUT,9016)I,Y2(I),X2(I),D2(I) 9016 FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPICOM(Y,X,N,MINSIZ, 1Y2,XLOW,XUPP,N2, 1ISUBRO,IBUGA3,IERROR) C C PURPOSE--FOR DISCRETE DISTRIBUTIONS, WE TYPICALLY WANT TO C GENERATE A FREQUENCY DISTRIBUTION FOR THE NON-NEGATIVE C INTEGERS. THIS ROUTINE WILL DO THAT. TWO ADDITIONAL C FEATURES: C C 1) FOR LONG-TAILED DISTRIBUTIONS (E.G., THE YULE C OR ZETA DISTRIBUTIONS, WE WILL HAVE AN EXTREMELY C LARGE NUMBER OF EMPTY CELLS IN THE TAIL. SO C THIS ROUTINE WILL RETURN THE FREQUENCY TABLE C IN THE FORM: C C FREQ CLASS-LOWER-LIMIT CLASS-UPPER-LIMIT C C EMPTY CLASSES WILL BE COMBINED WITH THE NEXT C HIGHEST NON-EMPTY CLASS. C C 2) FOR THE CHI-SQUARE GOODNESS OF FIT, IT IS C RECOMMENDED THAT CLASSES WITH LESS THAN 5 C OBSERVATIONS BE COMBINED IN ORDER FOR THE CHI-SQUARE C GOODNESS OF FIT TES TO BE VALID. AFTER COMPUTING C THE FREQUENCY TABLE, CLASSES WILL BE COMBINED SO C THAT ALL CLASSES HAVE A FREQUENCY OF AT LEAST C "MINSIZ" WHERE "MINSIZ" IS SET BY THE USER C (THE DEFAULT VALUE IS 5). C 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/5 C ORIGINAL VERSION--MAY 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ISUBRO CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 IWRITE CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION Y(*) DIMENSION X(*) DIMENSION Y2(*) DIMENSION XLOW(*) DIMENSION XUPP(*) 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='DPIC' ISUBN2='OM ' C IERROR='NO' IWRITE='NO' C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(N.LT.2)THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,31) 31 FORMAT('***** ERROR IN INTEGER FREQUENCY TABLE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,32) 32 FORMAT(' THE NUMBER OF INPUT VALUE IS LESS THAN TWO.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,34)N 34 FORMAT(' THE ENTERED NUMBER OF INPUT VALUES HERE = ',I6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ICOM')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,70) 70 FORMAT('***** AT THE BEGINNING OF DPICOM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)N,MINSIZ 72 FORMAT('N,MINSIZ = ',2I8) CALL DPWRST('XXX','BUG ') DO73I=1,N WRITE(ICOUT,74)I,Y(I) 74 FORMAT('I,Y(I) = ',I8,G15.7) CALL DPWRST('XXX','BUG ') 73 CONTINUE ENDIF C C ******************************************** C ** STEP 2-- ** C ** ROUND TO NEAREST INTEGER VALUE (AND ** C ** CHECK FOR NEGARIVE VALUES) ** C ******************************************** C DO100I=1,N ITEMP=INT(Y(I)+0.5) IF(ITEMP.LT.0)THEN WRITE(ICOUT,31) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,102)I,Y(I) 102 FORMAT(' ROW ',I8,' IS NON-POSITIVE. VALUE = ',G15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF Y(I)=REAL(ITEMP) 100 CONTINUE C C ******************************************** C ** STEP 3-- ** C ** 1) SORT ** C ** 2) EXTRACT DISTINCT VALUES IN INPUT ** C ** VECTOR ** C ** 3) GENERATE THE FREQUENCY TABLE ** C ******************************************** C CALL SORT(Y,N,Y) CALL DISTIN(Y,N,IWRITE,X,NDIST,IBUGA3,IERROR) C C CHECK IF ALL DATA VALUES EQUAL TO SAME VALUE. C IF(NDIST.EQ.1)THEN Y2(1)=X(1) XLOW(1)=X(1)-0.5 XUPP(1)=X(1)+0.5 N2=1 GOTO9000 ENDIF C DO200I=1,NDIST Y2(I)=0.0 XLOW(I)=0.0 XUPP(I)=0.0 200 CONTINUE C DO300J=1,NDIST AHOLD=X(J) IF(J.EQ.1)THEN XLOW(J)=AHOLD-0.5 AHOLD2=X(J+1) XUPP(J)=AHOLD2-0.5 ELSEIF(J.EQ.NDIST)THEN XUPP(J)=AHOLD+0.5 XLOW(J)=XUPP(J-1) ELSE XLOW(J)=XUPP(J-1) XUPP(J)=AHOLD+0.5 ENDIF DO310I=1,N IF(Y(I).EQ.AHOLD)THEN Y2(J)=Y2(J)+1 ENDIF 310 CONTINUE 300 CONTINUE C C C ********************************************** C ** STEP 4-- ** C ** COMBINE CLASSES WITH A FREQUECNY LESS ** C ** THAN MINSIZ. ** C ********************************************** C N2=0 IFLAG=0 ISTRT=1 ICNT2=NDIST AMINSZ=REAL(MINSIZ) EPS=1.0E-10 C C RIGHT TAIL TO CENTER. TEMPORARILY STORE IN UPPER PART OF C XLOW, XUPP, AND Y2 ARRARYS, WILL THEN FLIP THE SORT AT THE C END. C DO400I=NDIST,1,-1 ALOW=XLOW(I) AHIGH=XUPP(I) ATEMP=Y2(I) IF(IFLAG.EQ.0)THEN IF(ATEMP+EPS.GE.AMINSZ)THEN ICNT2=ICNT2+1 XLOW(ICNT2)=ALOW XUPP(ICNT2)=AHIGH Y2(ICNT2)=ATEMP ELSE IFLAG=1 ASUM=ATEMP ISTOP=I ENDIF ELSE ASUM=ASUM + ATEMP IF(ASUM+EPS.GE.AMINSZ)THEN ICNT2=ICNT2 + 1 XLOW(ICNT2)=ALOW XUPP(ICNT2)=XUPP(ISTOP) Y2(ICNT2)=ASUM ISTOP=-1 IFLAG=0 ENDIF ENDIF 400 CONTINUE C IF(IFLAG.EQ.1 .AND. ASUM.GT.0.0)THEN XLOW(ICNT2)=XLOW(1) XUPP(ICNT2)=XLOW(ICNT2-1) Y2(ICNT2)=Y2(ICNT2) + ASUM ENDIF N2RGHT=ICNT2 C C NOW COPY REVERSE ORDER RIGHT TAIL ENTRIES C ICNT=0 DO500I=ICNT2,NDIST+1,-1 ICNT=ICNT+1 Y2(ICNT)=Y2(I) XLOW(ICNT)=XLOW(I) XUPP(ICNT)=XUPP(I) 500 CONTINUE N2=ICNT C C ****************** C ** STEP 90-- ** C ** EXIT ** C ****************** C 9000 CONTINUE IF(IBUGA3.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPICOM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IERROR,N2 9012 FORMAT('IERROR,N2 = ',A4,2X,I8) CALL DPWRST('XXX','BUG ') DO9015I=1,N2 WRITE(ICOUT,9016)I,Y2(I),XLOW(I),XUPP(I) 9016 FORMAT('I,Y2(I),XLOW(I),XUPP(I) = ',I8,3G15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE ENDIF C RETURN END SUBROUTINE DPIF(ILOCS,ICASIF,IBUGQ,IERROR) C C PURPOSE--DEFINE A TRUE-FALSE CHARACTER VARIABLE C WHICH WILL BE USED IN OTHER SUBROUTINES C FOR THE CONDITIONAL EXECTUION OF STATEMENTS. 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/1 C ORIGINAL VERSION--JANUARY 1983. C UPDATED --AUGUST 1987. (TO ALLOW <> TO WORK) C UPDATED --AUGUST 1992. TO ALLOW ... NOT EXIST C UPDATED --AUGUST 1997. TO ALLOW ... EXIST C UPDATED --FEBRUARY 1999. IF ERROR, SET IF TO FALSE C UPDATED --JULY 2002. REDO IF NOT EXIST AND IF EXIST C UPDATED --JULY 2002. ADD: IF STRING = "..." C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGQ CHARACTER*4 IERROR C CHARACTER*4 ICASIF C CHARACTER*4 ISTATI CHARACTER*4 ICASSC CHARACTER*4 ICASQU CHARACTER*4 ICASPA CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASOP CHARACTER*4 IHSET CHARACTER*4 IHSET2 CHARACTER*4 IH CHARACTER*4 IH2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C CHARACTER*8 ITYPE CHARACTER*80 ITEXT1 CHARACTER*80 ITEXT2 C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.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 ISUBN1='DPIF' ISUBN2=' ' C IERROR='NO' C ICASIF='TRUE' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 C C ******************************** C ** TREAT THE IF CASE ** C ******************************** C IF(IBUGQ.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPIF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ILOCS,ICASIF 52 FORMAT('ILOCS,ICASIF = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IBUGQ,IERROR 54 FORMAT('IBUGQ,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)NUMARG,NUMNAM,MAXNAM,N,MAXN 55 FORMAT('NUMARG,NUMNAM,MAXNAM,N,MAXN = ',5I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)IWIDTH,ILOCS,ILOCS2,ILOCTG 56 FORMAT('IWIDTH,ILOCS,ILOCS2,ILOCTG = ',4I8) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C **************************************************************** C ** STEP 1-- C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. C **************************************************************** C ISTEPN='1' IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=0 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2, 1IERROR) IF(IERROR.EQ.'YES')GOTO9000 C CCCCC THE FOLLOWING SECTION WAS ADDED AUGUST 1992 C ************************************************** C ** STEP 2.0-- ** C ** TREAT THE IF ... NOT EXIST CASE ** C ** IF ... NOT EXIST THEN ==> ICASIF = TRUE ** C ** IF ... EXIST THEN ==> ICASIF = FALSE ** C ************************************************** C IF(NUMARG.GE.3)THEN IF(IHARG(2).EQ.'NOT'.AND.IHARG(3).EQ.'EXIS')THEN C IH=IHARG(1) IH2=IHARG2(1) MESSAG='NO' CALL CHECKF(IH,IH2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,ITYPE) C IF(ITYPE.EQ.'NONE')THEN ICASIF='TRUE' ELSE ICASIF='FALS' ENDIF IERROR='NO' GOTO9000 C ENDIF ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED NOVEMBER 1997 C ************************************************** C ** STEP 2.0A-- ** C ** TREAT THE IF ... EXIST CASE ** C ** IF ... EXIST THEN ==> ICASIF = TRUE ** C ** IF ... NOT EXIST THEN ==> ICASIF = FALSE** C ************************************************** C ICASIF='TRUE' IF(NUMARG.GE.2)THEN IF(IHARG(2).EQ.'EXIS')THEN C IH=IHARG(1) IH2=IHARG2(1) MESSAG='NO' CALL CHECKF(IH,IH2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,ITYPE) C IF(ITYPE.EQ.'NONE')THEN ICASIF='FALS' ELSE ICASIF='TRUE' ENDIF IERROR='NO' GOTO9000 C ENDIF ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED JULY 2002. C ************************************************** C ** STEP 2.0B- ** C ** TREAT THE ** C ** IF STRING = "....." CASE ** C ** IF STRING <> "..." CASE ** C ************************************************** C IF(ICOM.EQ.'IF')THEN IF(NUMARG.GE.3.AND.(IHARG(2).EQ.'='.OR.IHARG(2).EQ.'<>'))THEN C IH=IHARG(1) IH2=IHARG2(1) MESSAG='NO' CALL CHECKF(IH,IH2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,ITYPE) C IF(ITYPE.NE.'STRING')GOTO199 IF(IHARG(2).EQ.'=')IFLAG=0 IF(IHARG(2).EQ.'<>')IFLAG=1 IERROR='NO' C CCCCC SEARCH FOR STRING AFTER THE "=" OR "<>". C IF(IFLAG.EQ.0)THEN DO110I=1,80 IF(IANSLC(I).EQ.'=')THEN ISTRT=I+1 GOTO119 ENDIF 110 CONTINUE IERROR='YES' GOTO9000 119 CONTINUE ELSE DO120I=1,79 IF(IANSLC(I).EQ.'<' .AND. IANSLC(I).EQ.'>')THEN ISTRT=I+2 GOTO129 ENDIF 120 CONTINUE IERROR='YES' GOTO9000 129 CONTINUE ENDIF C NTEXT2=0 ITEXT2=' ' DO130I=ISTRT,IWIDTH IF(IANSLC(I).EQ.' ')THEN GOTO130 ELSEIF(IANSLC(I).EQ.'"')THEN NSTRT=I+1 ICOUNT=0 DO132J=NSTRT,IWIDTH IF(IANSLC(J).EQ.'"')THEN NLAST=J-1 GOTO134 ELSE ICOUNT=ICOUNT+1 ITEXT2(ICOUNT:ICOUNT)=IANSLC(J)(1:1) ENDIF 132 CONTINUE NLAST=IWIDTH 134 CONTINUE NTEXT2=NLAST-NSTRT+1 GOTO139 ELSE NSTRT=I ICOUNT=0 DO137J=NSTRT,IWIDTH IF(IANSLC(J).EQ.' ')THEN NLAST=J-1 GOTO138 ELSE ICOUNT=ICOUNT+1 ITEXT2(ICOUNT:ICOUNT)=IANSLC(J)(1:1) ENDIF 137 CONTINUE NLAST=IWIDTH 138 CONTINUE NTEXT2=NLAST-NSTRT+1 GOTO139 ENDIF 130 CONTINUE 139 CONTINUE C CCCCC EXTRACT VALUE OF STRING IN ARGUMENT 1 C NTEXT1=0 ITEXT1=' ' NSTRT=IVSTAR(ILOC) NSTOP=IVSTOP(ILOC) DO140J=NSTRT,NSTOP NTEXT1=NTEXT1+1 ITEXT1(NTEXT1:NTEXT1)=IFUNC(J)(1:1) 140 CONTINUE C CCCCC NOW COMPARE THE TWO STRINGS (IMTCH=0 FOR MATCH, 1 FOR NO MATCH) C IMTCH=0 IF(NTEXT1.EQ.NTEXT2)THEN DO150J=1,NTEXT1 IF(ITEXT1(J:J).NE.ITEXT2(J:J))THEN IMTCH=1 GOTO159 ENDIF 150 CONTINUE 159 CONTINUE ELSE IMTCH=1 ENDIF C CCCCC SET IF STATUS C IF(IMTCH.EQ.0)THEN ICASIF='TRUE' ELSE ICASIF='FALS' ENDIF C GOTO9000 C ENDIF ENDIF C 199 CONTINUE C C **************************************************************** C **************************************************************** C ** STEP 2.1-- C ** INITIALIZE ALL ELEMENTS IN ISUB(.) TO 11 C ** ISUB(.) WILL TAKE ON 4 VALUES AT MOST-- C ** 00, 01, 10, 11 . C ** THE FIRST DIGIT INDICATES WHETHER OR NOT THE GIVEN ELEMENT C ** IS OUT (0) OR IN (1) OF THE LOCAL CUMULATIVE UNION SET. C ** THE SECOND DIGIT INDICATES WHETHER OR NOT THE GIVEN ELEMENT C ** IS OUT (0) OR IN (1) OF THE GLOBAL CUMULATIVE INTERSECTION S C ** THE INITIALIZATION OF ALL ELEMENTS TO 11 C ** THUS INDICATES THAT INITIALLY ALL ELEMENTS (TEMPORARILY) C ** ARE IN THE LOCAL UNION SET, C ** AND INITIALLY ALL ELEMENTS C ** ARE IN THE GLOBAL INTERSECTION SET. C **************************************************************** C ISTEPN='2.1' IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NIOLD=1 DO200I=1,NIOLD ISUB(I)=11 200 CONTINUE C C ************************************************* C ** STEP 2.2-- ** C ** IF EXISTENT, ** C ** PACK < = INTO <= ** C ** PACK = < INTO =< ** C ** PACK > = INTO >= ** C ** PACK = > INTO => ** C ** THIS IS BECAUSE = SIGNS ARE AUTOMATICALLY ** C ** GIVEN A SPACE IN DPTYPE AND TREATED AS ** C ** AS A SEPARATE WORD. ** C ** NOTE THAT NUMARG WILL BE CHANGED. ** C ************************************************* C ISTEPN='2.2' IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL ADJUS2(IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) C C ************************************************ C ** STEP 3.1-- ** C ** CHECK TO SEE IF HAVE THE IF CASE. ** C ** LOCATE THE POSITION IN THE ARGUMENT LIST ** C ** OF THE WORD IF . ** C ************************************************ C ISTEPN='3.1' IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C JMAX=0 ICASSC='SEAR' ICASQU='UNKN' NUMSV=0 DO300IPASS=1,100 C IF(IBUGQ.EQ.'OFF')GOTO309 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,301) 301 FORMAT('***** AT THE BEGINNING OF ANOTHER PASS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,302)IPASS 302 FORMAT('IPASS = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,303)ICASSC,ILOCTG,IHARG(ILOCTG),IHARG2(ILOCTG) 303 FORMAT('ICASSC,ILOCTG,IHARG(ILOCTG),IHARG2(ILOCTG) = ', 1A4,I8,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,304)JMAX 304 FORMAT('JMAX= ',I8) CALL DPWRST('XXX','BUG ') 309 CONTINUE C IF(ICASSC.EQ.'STOP')GOTO1100 JMIN=JMAX+1 IF(JMIN.GT.NUMARG)GOTO1100 IF(JMIN.EQ.NUMARG.AND.IHARG(JMIN).EQ.'AND '.AND. 1IHARG2(JMIN).EQ.' ')GOTO1100 C IF(ICASSC.EQ.'CONT')GOTO600 DO310I=1,NIOLD ITEMP=ISUB(I) IF(ITEMP.EQ.00)ISUB(I)=00 IF(ITEMP.EQ.10)ISUB(I)=00 IF(ITEMP.EQ.01)ISUB(I)=00 IF(ITEMP.EQ.11)ISUB(I)=11 310 CONTINUE C ICASQU='UNKN' DO340J=JMIN,NUMARG J2=J IF(IHARG(J).EQ.'IF '.AND.IHARG2(J).EQ.' ')GOTO350 340 CONTINUE IF(JMIN.EQ.1.AND. 1ICOM.EQ.'IF '.AND.ICOM2.EQ.' ')J2=0 IF(JMIN.EQ.1.AND. 1ICOM.EQ.'IF '.AND.ICOM2.EQ.' ')GOTO350 ILOCS=NUMARG+1 GOTO1100 C 350 CONTINUE ICASQU='IF ' ILOCS=J2 GOTO390 C 390 CONTINUE IF(IBUGQ.EQ.'ON')WRITE(ICOUT,391)IPASS,ICASQU,ILOCS 391 FORMAT('IPASS,ICASQU,ILOCS = ',I8,2X,A4,I8) IF(IBUGQ.EQ.'ON')CALL DPWRST('XXX','BUG ') C C ******************************************* C ** STEP 3.2-- ** C ** IF HAVE THE IF CASE, ** C ** INITIALIZE ISUB(.) TO 0X--00 OR 01. ** C ******************************************* C ISTEPN='3.2' IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASQU.EQ.'IF ')GOTO400 IERROR='YES' GOTO9000 C 400 CONTINUE DO401I=1,NIOLD ITEMP=ISUB(I) IF(ITEMP.EQ.00)ISUB(I)=00 IF(ITEMP.EQ.10)ISUB(I)=00 IF(ITEMP.EQ.01)ISUB(I)=01 IF(ITEMP.EQ.11)ISUB(I)=01 401 CONTINUE GOTO409 C 409 CONTINUE C C ******************************************************** C ** STEP 4-- ** C ** CHECK VALIDITY OF FIRST ARGUMENT AFTER IF ** C ** THIS SHOULD BE THE IF PARAMETER ** C ******************************************************** C ISTEPN='4' IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASPA='UNKN' ILOCS1=ILOCS+1 JMAX=ILOCS1 IF(ILOCS1.LE.NUMARG)GOTO429 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,411) 411 FORMAT('***** ERROR IN DPIF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,412) 412 FORMAT(' THE WORD IF WAS THE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,413) 413 FORMAT(' FINAL WORD ON THE COMMAND LINE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,414) 414 FORMAT(' THE WORD IF SHOULD HAVE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,415) 415 FORMAT(' BEEN FOLLOWED BY OTHER ARGUMENTS, AS IN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,416) 416 FORMAT(' IF A = 4') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,417) 417 FORMAT(' IF A > 6') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,418) 418 FORMAT(' IF X >= B') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,419) 419 FORMAT(' AND SO FORTH.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,421) 421 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,422)(IANS(I),I=1,IWIDTH) 422 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 429 CONTINUE C IHSET=IHARG(ILOCS1) IHSET2=IHARG2(ILOCS1) C 440 CONTINUE ICASPA='P ' IHWUSE='P' MESSAG='YES' CALL CHECKN(IHSET,IHSET2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ASETV=VALUE(ILOC) IF(IBUGQ.EQ.'ON')WRITE(ICOUT,451)ILOCS1,IHSET,IHSET2,ASETV 451 FORMAT('ILOCS1,IHSET,IHSET2,ASETV = ',I8,3X,2A4,3X,E15.7) IF(IBUGQ.EQ.'ON')CALL DPWRST('XXX','BUG ') GOTO490 C 490 CONTINUE IF(IBUGQ.EQ.'ON')WRITE(ICOUT,491)IPASS,IHSET,IHSET2,ICASPA,ASETV 491 FORMAT('IPASS,IHSET,IHSET2,ICASPA,ASETV = ', 1I8,2X,A4,2X,A4,2X,A4,E15.7) IF(IBUGQ.EQ.'ON')CALL DPWRST('XXX','BUG ') C C **************************************************************** C ** STEP 5-- C ** CHECK TO SEE IF NEXT ARGUMENT IS C ** < C ** <= C ** = C ** >= C ** > C ** <> C ** IF NONE OF THE ABOVE, THEN THE ASSUMED OPERATION IS = . C **************************************************************** C ISTEPN='5' IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASOP='UNKN' ILOCS2=ILOCS+2 JMAX=ILOCS2 IF(ILOCS2.LE.NUMARG)GOTO529 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,501) 501 FORMAT('***** ERROR IN DPIF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,502) 502 FORMAT(' THE IF PARAMETER NAME WAS THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,503) 503 FORMAT(' FINAL WORD ON THE COMMAND LINE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,504) 504 FORMAT(' THE IF PARAMETER NAME SHOULD HAVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,505) 505 FORMAT(' BEEN FOLLOWED BY OTHER ARGUMENTS, AS IN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,506) 506 FORMAT(' IF A = 4') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,507) 507 FORMAT(' IF A > 6') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,508) 508 FORMAT(' IF A >= B') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,510) 510 FORMAT(' AND SO FORTH.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,521) 521 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,522)(IANS(I),I=1,IWIDTH) 522 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 529 CONTINUE C IHSET=IHARG(ILOCS2) IHSET2=IHARG2(ILOCS2) C IF(IHSET.EQ.'< ')GOTO531 IF(IHSET.EQ.'<= ')GOTO532 IF(IHSET.EQ.'=< ')GOTO532 IF(IHSET.EQ.'= ')GOTO533 IF(IHSET.EQ.'>= ')GOTO534 IF(IHSET.EQ.'=> ')GOTO534 IF(IHSET.EQ.'> ')GOTO535 IF(IHSET.EQ.'<> ')GOTO536 IF(IHSET.EQ.'>< ')GOTO536 GOTO537 C 531 CONTINUE ICASOP='< ' ILOCTG=ILOCS2 GOTO590 C 532 CONTINUE ICASOP='<= ' ILOCTG=ILOCS2 GOTO590 C 533 CONTINUE ICASOP='= ' ILOCTG=ILOCS2 GOTO590 C 534 CONTINUE ICASOP='>= ' ILOCTG=ILOCS2 GOTO590 C 535 CONTINUE ICASOP='> ' ILOCTG=ILOCS2 GOTO590 C 536 CONTINUE ICASOP='<> ' ILOCTG=ILOCS2 GOTO590 C 537 CONTINUE ICASOP='=ASS' ILOCTG=ILOCS2-1 GOTO590 C 590 CONTINUE IF(IBUGQ.EQ.'ON')WRITE(ICOUT,591)IPASS,IHSET,IHSET2,ICASPA,ICASOP 591 FORMAT('IPASS,IHSET,IHSET2,ICASPA,ICASOP = ', 1I8,2X,A4,2X,A4,2X,A4,2X,A4) IF(IBUGQ.EQ.'ON')CALL DPWRST('XXX','BUG ') C C ************************************************************** C ** STEP 6-- ** C ** DETERMINE THE LOWER LIMIT OF THE INTERVAL OF INTEREST. ** C ** THIS IS DONE BY CHECKING THE FIRST (NEXT) ARGUMENT ** C ** IN THE LIST. ** C ** ALSO, FOR THOSE 4 CASES IN WHICH ** C ** ICASOP IS < <= >= > ** C ** DETERMINE THE UPPER LIMIT OF THE INTERVAL OF INTEREST. ** C ************************************************************** C 600 CONTINUE C ISTEPN='6' IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGQ.EQ.'OFF')GOTO609 WRITE(ICOUT,601) 601 FORMAT(' AT THE BEGINNING OF STEP 6 IN DPIF--') CALL DPWRST('XXX','BUG ') DO605I=1,NIOLD WRITE(ICOUT,606)I,ISUB(I) 606 FORMAT('I,ISUB(I) = ',I8,I8) CALL DPWRST('XXX','BUG ') 605 CONTINUE 609 CONTINUE C ILOCTG=ILOCTG+1 JMAX=ILOCTG IF(ILOCTG.LE.NUMARG)GOTO629 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,611) 611 FORMAT('***** ERROR IN DPIF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,612) 612 FORMAT(' THE IF OPERATION < <= = >= >') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,613) 613 FORMAT(' WAS THE FINAL WORD ON THE COMMAND LINE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,614) 614 FORMAT(' THE IF VARIABLE NAME SHOULD HAVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,615) 615 FORMAT(' BEEN FOLLOWED BY OTHER ARGUMENTS, AS IN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,616) 616 FORMAT(' IF A = 4') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,617) 617 FORMAT(' IF A > 6') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,618) 618 FORMAT(' IF A >= 6') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,620) 620 FORMAT(' AND SO FORTH.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,621) 621 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,622)(IANS(I),I=1,IWIDTH) 622 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 629 CONTINUE C IF(IARGT(ILOCTG).EQ.'NUMB')GOTO640 IF(IARGT(ILOCTG).EQ.'WORD')GOTO650 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,631) 631 FORMAT('***** INTERNAL ERROR IN DPIF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,632) 632 FORMAT(' AN ARGUMENT TYPE WHICH SHOULD BE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,633) 633 FORMAT(' EITHER A NUMBER OR A WORD, IS NEITHER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,634)IHARG(ILOCTG),IHARG2(ILOCTG) 634 FORMAT(' ARGUMENT = ',2A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,635)ILOCTG 635 FORMAT(' LOCATION IN ARGUMENT LIST = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,636)IARGT(ILOCTG) 636 FORMAT(' ARGUMENT TYPE = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,637) 637 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,638)(IANS(I),I=1,IWIDTH) 638 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 640 CONTINUE DMIN=ARG(ILOCTG) DMAX=ARG(ILOCTG) IF(ICASOP.EQ.'= ')GOTO690 IF(ICASOP.EQ.'=ASS')GOTO690 IF(ICASOP.EQ.'<> ')GOTO690 IF(ICASOP.EQ.'< ')DMIN=CPUMIN IF(ICASOP.EQ.'< ')DMAX=ARG(ILOCTG) IF(ICASOP.EQ.'< ')GOTO690 IF(ICASOP.EQ.'<= ')DMIN=CPUMIN IF(ICASOP.EQ.'<= ')DMAX=ARG(ILOCTG) IF(ICASOP.EQ.'<= ')GOTO690 IF(ICASOP.EQ.'>= ')DMIN=ARG(ILOCTG) IF(ICASOP.EQ.'>= ')DMAX=CPUMAX IF(ICASOP.EQ.'>= ')GOTO690 IF(ICASOP.EQ.'> ')DMIN=ARG(ILOCTG) IF(ICASOP.EQ.'> ')DMAX=CPUMAX IF(ICASOP.EQ.'> ')GOTO690 GOTO690 C 650 CONTINUE IH=IHARG(ILOCTG) IH2=IHARG2(ILOCTG) IHWUSE='P' MESSAG='YES' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR) IF(IERROR.EQ.'YES')GOTO9000 DMIN=VALUE(ILOC) DMAX=VALUE(ILOC) IF(ICASOP.EQ.'= ')GOTO690 IF(ICASOP.EQ.'=ASS')GOTO690 IF(ICASOP.EQ.'<> ')GOTO690 IF(ICASOP.EQ.'< ')DMIN=CPUMIN IF(ICASOP.EQ.'< ')DMAX=VALUE(ILOC) IF(ICASOP.EQ.'< ')GOTO690 IF(ICASOP.EQ.'<= ')DMIN=CPUMIN IF(ICASOP.EQ.'<= ')DMAX=VALUE(ILOC) IF(ICASOP.EQ.'<= ')GOTO690 IF(ICASOP.EQ.'>= ')DMIN=VALUE(ILOC) IF(ICASOP.EQ.'>= ')DMAX=CPUMAX IF(ICASOP.EQ.'>= ')GOTO690 IF(ICASOP.EQ.'> ')DMIN=VALUE(ILOC) IF(ICASOP.EQ.'> ')DMAX=CPUMAX IF(ICASOP.EQ.'> ')GOTO690 GOTO690 C 690 CONTINUE IF(IBUGQ.EQ.'ON')WRITE(ICOUT,691)IPASS,ICASPA,ICASOP,IH,IH2,DMIN, 1DMAX 691 FORMAT('IPASS,ICASPA,ICASOP,IH,IH2,DMIN,DMAX = ', 1I8,2X,A4,2X,A4,2X,A4,2X,A4,2E15.7) IF(IBUGQ.EQ.'ON')CALL DPWRST('XXX','BUG ') C C **************************************************************** C ** STEP 7-- C ** DETERMINE THE UPPER LIMIT OF THE INTERVAL OF INTEREST. C ** NOTE THAT FOR THOSE 4 CASES IN WHICH C ** ICASOP IS < <= >= > ** C ** THE UPPER LIMIT OF THE INTERVAL ** C ** HAS ALREADY BEEN DETERMINED AND SO ** C ** ALL OF THE CODE OF THIS SECTION MAY BE SKIPPED. C ** ON THE OTHER HAND WHEN THE OPERATION IS = , C ** (EXPLICITLY OR ASSUMED), ** C ** OR <> , C ** THE UPPER LIMIT MUST BE DETERMINED. C ** THIS IS DONE BY CHECKING THE NEXT ARGUMENT C ** IN THE LIST. C ** IF THIS NEXT ARGUMENT IS TO , C ** THIS IMPLIES THAT AN UPPER LIMIT WILL BE PROVIDED C ** (IN THE ARGUMENT AFTER THE TO ). C ** HOWEVER, IF THE NEXT ARGUMENT IS NOT A TO , C ** THEN THIS IMPLIES THAT THE LIST CONSISTS C ** OF INDIVIDUAL ELEMENTS OF THE SUBSET C ** AND SO THE UPPER LIMIT WILL BE IDENTICAL C ** TO THE LOWER LIMIT. C **************************************************************** C 700 CONTINUE C ISTEPN='7' IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASOP.EQ.'< ')ICASSC='SEAR' IF(ICASOP.EQ.'< ')GOTO790 IF(ICASOP.EQ.'<= ')ICASSC='SEAR' IF(ICASOP.EQ.'<= ')GOTO790 IF(ICASOP.EQ.'>= ')ICASSC='SEAR' IF(ICASOP.EQ.'>= ')GOTO790 IF(ICASOP.EQ.'> ')ICASSC='SEAR' IF(ICASOP.EQ.'> ')GOTO790 C ILOCTG=ILOCTG+1 C IF(ILOCTG.GT.NUMARG)GOTO710 IF(ILOCTG.EQ.NUMARG.AND.IHARG(ILOCTG).EQ.'AND '.AND. 1IHARG2(ILOCTG).EQ.' ')GOTO710 IF(ILOCTG.LE.NUMARG.AND.IHARG(ILOCTG).EQ.'IF '.AND. 1IHARG2(ILOCTG).EQ.' ')GOTO720 IF(ILOCTG.LE.NUMARG.AND.IHARG(ILOCTG).EQ.'TO '.AND. 1IHARG2(ILOCTG).EQ.' ')GOTO750 GOTO730 C 710 CONTINUE ILOCTG=ILOCTG-1 JMAX=ILOCTG ICASSC='STOP' DMAX=DMIN GOTO790 C 720 CONTINUE ILOCTG=ILOCTG-1 JMAX=ILOCTG ICASSC='SEAR' DMAX=DMIN GOTO790 C 730 CONTINUE ILOCTG=ILOCTG-1 JMAX=ILOCTG ICASSC='CONT' DMAX=DMIN GOTO790 C 750 CONTINUE ILOCTG=ILOCTG+1 JMAX=ILOCTG IF(ILOCTG.GT.NUMARG)GOTO760 IF(ILOCTG.EQ.NUMARG.AND.IHARG(ILOCTG).EQ.'AND '.AND. 1IHARG2(ILOCTG).EQ.' ')GOTO760 IF(ILOCTG.LE.NUMARG.AND.IHARG(ILOCTG).EQ.'IF '.AND. 1IHARG2(ILOCTG).EQ.' ')GOTO760 IF(ILOCTG.LE.NUMARG.AND.IHARG(ILOCTG).EQ.'TO '.AND. 1IHARG2(ILOCTG).EQ.' ')GOTO760 GOTO770 C 760 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,761) 761 FORMAT('***** ERROR IN DPIF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,762) 762 FORMAT(' THE WORD TO SHOULD HAVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,763) 763 FORMAT(' BEEN FOLLOWED BY A NUMBER OR') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,764) 764 FORMAT(' BY A PARAMETER NAME, BUT WAS NOT.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,765)IHARG(ILOCTG),IHARG2(ILOCTG) 765 FORMAT(' TO WAS FOLLOWED BY THE WORD ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,766) 766 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,767)(IANS(I),I=1,IWIDTH) 767 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 770 CONTINUE IF(IARGT(ILOCTG).EQ.'NUMB')GOTO775 IF(IARGT(ILOCTG).EQ.'WORD')GOTO776 C IBRAN=770 WRITE(ICOUT,771)IBRAN CALL DPWRST('XXX','BUG ') WRITE(ICOUT,772)ILOCTG,IARGT(ILOCTG) 771 FORMAT('***** INTERNAL ERROR IN DPIF--', 1'IMPOSSIBLE BRANCH CONDITION AT BRANCH POINT = ',I8) CALL DPWRST('XXX','BUG ') 772 FORMAT('ILOCTG, IARGT(ILOCTG) = ',I8,2X,A4) IERROR='YES' GOTO9000 C 775 CONTINUE DMAX=ARG(ILOCTG) GOTO780 C 776 CONTINUE IH=IHARG(ILOCTG) IH2=IHARG2(ILOCTG) IHWUSE='P' MESSAG='YES' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR) IF(IERROR.EQ.'YES')GOTO9000 DMAX=VALUE(ILOC) GOTO780 C 780 CONTINUE ILOCTG=ILOCTG+1 ICASSC='CONT' IF(ILOCTG.GT.NUMARG)ICASSC='STOP' IF(ILOCTG.EQ.NUMARG.AND.IHARG(ILOCTG).EQ.'AND '.AND. 1IHARG2(ILOCTG).EQ.' ')ICASSC='STOP' IF(ILOCTG.LE.NUMARG.AND.IHARG(ILOCTG).EQ.'IF '.AND. 1IHARG2(ILOCTG).EQ.' ')ICASSC='SEAR' ILOCTG=ILOCTG-1 JMAX=ILOCTG C 790 CONTINUE IF(IBUGQ.EQ.'ON')WRITE(ICOUT,791)IPASS,ICASPA,ICASOP,IH,IH2,DMIN, 1DMAX 791 FORMAT('IPASS,ICASPA,ICASOP,IH,IH2,DMIN,DMAX = ', 1I8,2X,A4,2X,A4,2X,A4,2X,A4,2E15.7) IF(IBUGQ.EQ.'ON')CALL DPWRST('XXX','BUG ') C C *************************************************** C ** STEP 8-- ** C ** TO ALLOW FOR ROUNDOFF ERRORS IN THE ** C ** STORAGE OF NUMBERS, ** C ** JUDICIOUSLY EXPAND THE INTERVAL OF INTEREST ** C ** BY AN EPSILON AMOUNT. ** C *************************************************** C ISTEPN='8' IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) IF(IBUGQ.EQ.'OFF')GOTO804 WRITE(ICOUT,801) 801 FORMAT(' AT THE BEGINNING OF STEP 8--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,802)DMIN,DMAX 802 FORMAT('DMIN,DMAX = ',2E15.7) CALL DPWRST('XXX','BUG ') 804 CONTINUE C IF(DMIN.LE.DMAX)GOTO809 HOLD=DMIN DMIN=DMAX DMAX=HOLD 809 CONTINUE C IF(DMIN.EQ.CPUMIN)GOTO819 IF(DMIN.EQ.CPUMAX)GOTO819 IF(ABS(DMIN).EQ.0.0)EPS=0.000001 IF(ABS(DMIN).NE.0.0)EPS=ABS(DMIN*0.000001) IF(ICASOP.EQ.'= ')DMIN=DMIN-EPS IF(ICASOP.EQ.'=ASS')DMIN=DMIN-EPS IF(ICASOP.EQ.'<> ')DMIN=DMIN-EPS IF(ICASOP.EQ.'< ')DMIN=DMIN-EPS IF(ICASOP.EQ.'<= ')DMIN=DMIN-EPS IF(ICASOP.EQ.'>= ')DMIN=DMIN-EPS IF(ICASOP.EQ.'> ')DMIN=DMIN+EPS 819 CONTINUE C IF(DMAX.EQ.CPUMAX)GOTO829 IF(DMAX.EQ.CPUMIN)GOTO829 IF(ABS(DMAX).EQ.0.0)EPS=0.000001 IF(ABS(DMAX).NE.0.0)EPS=ABS(DMAX*0.000001) IF(ICASOP.EQ.'= ')DMAX=DMAX+EPS IF(ICASOP.EQ.'=ASS')DMAX=DMAX+EPS IF(ICASOP.EQ.'<> ')DMAX=DMAX+EPS IF(ICASOP.EQ.'< ')DMAX=DMAX-EPS IF(ICASOP.EQ.'<= ')DMAX=DMAX+EPS IF(ICASOP.EQ.'>= ')DMAX=DMAX+EPS IF(ICASOP.EQ.'> ')DMAX=DMAX+EPS 829 CONTINUE C 890 CONTINUE IF(IBUGQ.EQ.'ON')WRITE(ICOUT,891)IPASS,ICASPA,ICASOP,IH,IH2 891 FORMAT('IPASS,ICASPA,ICASOP,IH,IH2 = ', 1I8,2X,A4,2X,A4,2X,A4,2X,A4) IF(IBUGQ.EQ.'ON')CALL DPWRST('XXX','BUG ') IF(IBUGQ.EQ.'ON')WRITE(ICOUT,892)EPS,DMIN,DMAX,CPUMIN,CPUMAX 892 FORMAT('EPS,DMIN,DMAX,CPUMIN,CPUMAX = ',5E15.7) IF(IBUGQ.EQ.'ON')CALL DPWRST('XXX','BUG ') C C **************************************************** C ** STEP 9-- ** C ** DEFINE THE ISUB(.) VECTOR-- ** C ** FOR ANY K (K = 1 TO NIOLD), ** C ** IF THE K-TH ELEMENT OF THE ** C ** SUBSET SPECIFICATION VARIABLE ** C ** (THE VARIABLE SPECIFIED AFTER SUBSET ** C ** IN THE COMMAND LINE) ** C ** IS WITHIN THE SPECIFIED (DMIN,DMAX) LIMITS, ** C ** THEN ISUB(K) SHOULD RESULT IN A VALUE OF 1; ** C ** BUT IF THE K-TH ELEMENT OF THE ** C ** SUBSET SPECIFICATION VARIABLE ** C ** IS OUTSIDE THE SPECIFIED (DMIN,DMAX) LIMITS, ** C ** THEN ISUB(K) SHOULD RESULT IN A 0 . ** C **************************************************** C ISTEPN='9' IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGQ.EQ.'ON')WRITE(ICOUT,901)ILOCS1,IHSET,IHSET2,ICASPA,ASETV, 1MAXCOL 901 FORMAT('ILOCS1,IHSET,IHSET2,ICASPA,ASETV,MAXCOL = ', 1I8,2X,A4,2X,A4,2X,A4,E15.7,I8) IF(IBUGQ.EQ.'ON')CALL DPWRST('XXX','BUG ') C IF(ICASPA.EQ.'UNKN')GOTO910 IF(ICASPA.EQ.'P ')GOTO940 C 910 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,911) 911 FORMAT('***** INTERNAL ERROR IN DPIF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,912) 912 FORMAT(' IMPROPER VALUE FOR ICASPA AND/OR ASETV') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,913)ICASPA,ASETV,MAXCOL,MAXCP1,MAXCP2 913 FORMAT(' ICASPA,ASETV,MAXCOL,MAXCP1,MAXCP2 = ',A4, 1E15.7,3I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 940 CONTINUE NS=0 ND=0 DO941I=1,NIOLD VIJ=ASETV IF(IBUGQ.EQ.'ON')WRITE(9,947)I,NIOLD,ASETV,DMIN,DMAX,VIJ 947 FORMAT('I,NIOLD,ASETV,DMIN,DMAX,VIJ = ', 12I8,E15.7,3F12.5) TARGET=VIJ ISTATI='FALS' C IF(ICASQU.EQ.'IF '.AND.ICASOP.EQ.'<> '.AND. 1TARGET.LT.DMIN)GOTO942 IF(ICASQU.EQ.'IF '.AND.ICASOP.EQ.'<> '.AND. 1DMAX.LT.TARGET)GOTO942 IF(ICASQU.EQ.'IF '.AND.ICASOP.EQ.'<> '.AND. 1DMIN.LE.TARGET.AND.TARGET.LE.DMAX)GOTO943 IF(ICASQU.EQ.'IF '.AND. 1DMIN.LE.TARGET.AND.TARGET.LE.DMAX)GOTO942 IF(ICASQU.EQ.'IF ')GOTO943 GOTO941 C 942 CONTINUE ISTATI='TRUE' ITEMP=ISUB(I) IF(ITEMP.EQ.00)ISUB(I)=10 IF(ITEMP.EQ.10)ISUB(I)=10 IF(ITEMP.EQ.01)ISUB(I)=11 IF(ITEMP.EQ.11)ISUB(I)=11 NS=NS+1 GOTO941 943 CONTINUE ND=ND+1 GOTO941 941 CONTINUE GOTO990 C 990 CONTINUE IF(IBUGQ.EQ.'ON')WRITE(ICOUT,991)IPASS,ICASQU,DMIN,DMAX,EPS, 1NIOLD,NS,ND 991 FORMAT('IPASS,ICASQU,DMIN,DMAX,EPS,NIOLD,NS,ND = ', 1I8,2X,A4,3E15.7,3I8) IF(IBUGQ.EQ.'ON')CALL DPWRST('XXX','BUG ') IF(IBUGQ.EQ.'OFF')GOTO994 DO992I=1,NIOLD WRITE(ICOUT,993)I,ISUB(I) 993 FORMAT('I,ISUB(I) = ',I8,I8) CALL DPWRST('XXX','BUG ') 992 CONTINUE WRITE(ICOUT,995)ITEMP,ISTATI 995 FORMAT('ITEMP,ISTATI = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 994 CONTINUE C C ************************************************* C ** STEP 10-- ** C ** WRITE OUT A MESSAGE FOR THIS STEP ** C ** INDICATING ** C ** THE SUBSET PARAMETER NAME, ** C ** THE SUBSET MINIMUM, ** C ** THE SUBSET MAXIMUM, ** C ** THE SUBSET PARAMETER VALUE, ** C ** THE SUBSET PARAMETER STATUS, ** C ************************************************* C ISTEPN='10' IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C 1010 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1019 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1011) 1011 FORMAT('***** NOTE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1012)IHARG(ILOCS1),IHARG2(ILOCS1) 1012 FORMAT(' IF PARAMETER = ',2A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1013)DMIN 1013 FORMAT(' IF MINIMUM = ',E17.10) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1014)DMAX 1014 FORMAT(' IF MAXIMUM = ',E17.10) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1015)ASETV 1015 FORMAT(' IF PARAMETER VALUE = ',E17.10) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1016)ISTATI 1016 FORMAT(' IF PARAMETER STATUS = ',A4) CALL DPWRST('XXX','BUG ') 1019 CONTINUE GOTO1050 C 1050 CONTINUE CCCCC IF(NS.GE.1)GOTO1059 CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1051) C1051 FORMAT('***** ERROR IN DPIF--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1052) C1052 FORMAT(' THE SUBSET IS EMPTY--IT HAS NO ELEMENTS IN IT.') CCCCC CALL DPWRST('XXX','BUG ') CCCCC IERROR='YES' CCCCC GOTO9000 C1059 CONTINUE C NUMSV=IPASS C 300 CONTINUE C 1100 CONTINUE DO1110I=1,NIOLD ITEMP=ISUB(I) IF(ITEMP.EQ.00)ISUB(I)=00 IF(ITEMP.EQ.10)ISUB(I)=00 IF(ITEMP.EQ.01)ISUB(I)=00 IF(ITEMP.EQ.11)ISUB(I)=11 1110 CONTINUE C C ************************************* C ** STEP 11-- ** C ** PUT ISUB(.) IN FINAL 0,1 FORM ** C ************************************* C ISTEPN='11' IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO1210I=1,NIOLD ITEMP=ISUB(I) IF(ITEMP.EQ.00)ISUB(I)=0 IF(ITEMP.EQ.10)ISUB(I)=0 IF(ITEMP.EQ.01)ISUB(I)=1 IF(ITEMP.EQ.11)ISUB(I)=1 1210 CONTINUE C C ***************************************** C ** STEP 12-- ** C ** IF THERE WERE 2 OR MORE SUBSET ** C ** VARIABLES, GATHER INFORMATION ** C ** FOR A FINAL SUMMARY MESSAGE BY ** C ** DETERMINING THE FINAL NUMBER OF ** C ** ELEMENTS IN THE SUBSET ** C ** (AFTER ALL VARIABLES HAVE ** C ** BEEN INDIVIDUALLY ACCOUNTED FOR). ** C ***************************************** C 1500 CONTINUE C ISTEPN='12' IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMSV.LE.1)GOTO1590 NS=0 DO1510I=1,NIOLD IF(ISUB(I).EQ.1)NS=NS+1 1510 CONTINUE 1590 CONTINUE C C ************************************************* C ** STEP 13-- ** C ** IF THERE WERE 2 OR MORE SUBSET VARIABLES, ** C ** WRITE OUT A FINAL MESSAGE ** C ** SUMMARIZING FOR ALL VARIABLES ** C ** THE NUMBER OF SUBSET VARIABLES ** C ** THE INPUT NUMBER OF OBSERVATIONS (LOCAL), ** C ** THE NUMBER OF OBSERVATIONS IGNORED ** C ** AND THE OUTPUT NUMBER OF OBSERVATIONS ** C ** (THAT IS, THE SUBSET SAMPLE SIZE). ** C ** ALSO, CHECK THAT NS IS POSITIVE. ** C ************************************************* C ISTEPN='13' IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASIF='FALS' IF(ISUB(1).EQ.1)ICASIF='TRUE' C IF(NUMSV.LE.1)GOTO1690 C IF(IFEEDB.EQ.'OFF')GOTO1609 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1601) 1601 FORMAT('***** IF SUMMARY--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1602)NUMSV 1602 FORMAT(' NUMBER OF SPECIFICATIONS = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1605)ICASIF 1605 FORMAT(' FINAL IF STATUS = ',A4) CALL DPWRST('XXX','BUG ') 1609 CONTINUE C 1690 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE C C IF ERROR, THEN SET IF STATUS TO FALSE. FEBRUARY 1999 C IF(IERROR.EQ.'YES')THEN ICASIF='FALS' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9001) 9001 FORMAT('***** ERROR IN DPIF, IF STATUS SET TO FALSE.') CALL DPWRST('XXX','BUG ') ENDIF IF(IBUGQ.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPIF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)NIOLD,ILOCS,NS 9012 FORMAT('NIOLD,ILOCS,NS = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IBUGQ,IERROR 9014 FORMAT('IBUGQ,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)NUMARG,NUMNAM,MAXNAM,N,MAXN 9015 FORMAT('NUMARG,NUMNAM,MAXNAM,N,MAXN = ',5I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)IWIDTH,ILOCS,ILOCS2,ILOCTG 9016 FORMAT('IWIDTH,ILOCS,ILOCS2,ILOCTG = ',4I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)NUMSV,ND 9017 FORMAT('NUMSV,ND = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9018)ICASQU,ICASPA,ICASOP,ICASSC 9018 FORMAT('ICASQU,ICASPA,ICASOP,ICASSC = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') DO9020I=1,NIOLD WRITE(ICOUT,9021)I,ISUB(I) 9021 FORMAT('I,ISUB(I) = ',2I8) CALL DPWRST('XXX','BUG ') 9020 CONTINUE WRITE(ICOUT,9022)ISTATI,ICASIF 9022 FORMAT('ISTATI,ICASIF = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9023)JMIN,JMAX,NUMARG 9023 FORMAT('JMIN,JMAX,NUMARG = ',3I8) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPIMP1(IX2TSW,IY2TSW,IX2ZSW,IY2ZSW,NCY2LA, 1IBUGS2,IFOUND,IERROR) C C PURPOSE--THIS IS IMPLEMENTATION MODULE NUMBER 1. C THIS WILL RESULT IN-- C 1) NO TIC MARKS OR TIC MARK LABELS ON UPPER FRAME LINE C 2) NO TIC MARKS OR TIC MARK LABELS ON RIGHT FRAME LINE C 3) NO VERTICAL LABEL (Y2LABEL) ON RIGHT FRAME LINE C NOTE--THIS SUBROUTINE WILL BE EXECUTED WHEN THE C ANALYST ENTERS THE COMMAND-- C IMPLEMENT 1 C NOTE--THE IMPLEMENT COMMAND IS USEFUL FOR IMPLEMENTATION ,DEBUGGING, C AND FOR NON-STANDARD CONVENTIONS (E.G., PLOTS WITH NON-STANDARD C SIZE OR TIC MARK CONVENTIONS OTHER THAN DATAPLOT'S DEFAULT) C INPUT ARGUMENTS--NONE C OUTPUT ARGUMENTS-- C --IX2TSW C --IY2TSW C --IX2ZSW C --IY2ZSW C --NCY2LA 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 1981. C UPDATED --APRIL 1982. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGS2 C CHARACTER*4 IX2TSW CHARACTER*4 IY2TSW C CHARACTER*4 IX2ZSW CHARACTER*4 IY2ZSW 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 IERROR='NO' IFOUND='YES' 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 DPIMP1--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IX2TSW,IY2TSW 52 FORMAT('IX2TSW,IY2TSW = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IX2ZSW,IY2ZSW 53 FORMAT('IX2ZSW,IY2ZSW = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)NCY2LA 54 FORMAT('NCY2LA = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,59)IBUGS2,IFOUND,IERROR 59 FORMAT('IBUGS2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C *********************************************** C ** STEP 1-- ** C ** DEFINE PARAMETER CHANGES TO BE MADE ** C ** FOR THIS IMPLEMENTATION MODULE NUMBER 1 ** C *********************************************** C IX2TSW='ON' IY2TSW='ON' C IX2ZSW='ON' IY2ZSW='ON' C CCCCC NCY2LA=0 C C *************************** C ** STEP 2-- ** C ** WRITE OUT A MESSAGE. ** C *************************** C IF(IFEEDB.EQ.'OFF')GOTO1169 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1151) 1151 FORMAT('THE IMPLEMENTATION MODULE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1152) 1152 FORMAT(' HAS JUST BEEN ACTIVATED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1153) 1153 FORMAT(' WHICH ALLOWS TIC MARKS ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1154) 1154 FORMAT(' AND TIC MARK LABELS ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1155) 1155 FORMAT(' ON THE TOP AND RIGHT FRAME LINES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1156) 1156 FORMAT(' OF ALL SUBSEQUENT PLOTS.') CALL DPWRST('XXX','BUG ') 1169 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 DPIMP1--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IX2TSW,IY2TSW 9012 FORMAT('IX2TSW,IY2TSW = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IX2ZSW,IY2ZSW 9013 FORMAT('IX2ZSW,IY2ZSW = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NCY2LA 9014 FORMAT('NCY2LA = ',I8) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPIMP2(ANUMVP,ANUMHP, 1ISQUAR, 1PXMIN,PYMIN,PXMAX,PYMAX, 1IBUGS2,IFOUND,IERROR) C C PURPOSE--THIS IS IMPLEMENTATION MODULE NUMBER 2. C THIS WILL RESULT IN-- C THE PLOT FRAME CHANGED FROM RECTANGULAR C TO SQUARE FOR ALL FUTURE PLOTS C ON TEKTRONIX GRAPHICS DEVICES. C NOTE--THIS SUBROUTINE WILL BE EXECUTED WHEN THE C ANALYST ENTERS THE COMMAND-- C IMPLEMENT 2 C NOTE--THE IMPLEMENT COMMAND IS USEFUL FOR IMPLEMENTATION ,DEBUGGING, C AND FOR NON-STANDARD CONVENTIONS (E.G., PLOTS WITH NON-STANDARD C SIZE OR TIC MARK CONVENTIONS OTHER THAN DATAPLOT'S DEFAULT) C INPUT ARGUMENTS--NONE C OUTPUT ARGUMENTS-- C --PXMIN C --PYMIN C --PXMAX C --PYMAX 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 1981. C UPDATED --APRIL 1982. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ISQUAR C CHARACTER*4 IBUGS2 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 IERROR='NO' IFOUND='YES' 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 DPIMP2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ANUMVP,ANUMHP 52 FORMAT('ANUMVP,ANUMHP = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ISQUAR 53 FORMAT('ISQUAR = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)PXMIN,PXMAX,PYMIN,PYMAX 54 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,59)IBUGS2,IFOUND,IERROR 59 FORMAT('IBUGS2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C *********************************************** C ** STEP 1-- ** C ** DEFINE PARAMETER CHANGES TO BE MADE ** C ** FOR THIS IMPLEMENTATION MODULE NUMBER 2 ** C *********************************************** C ISQUAR='ON' C CCCCC PXMIN=15.0 CCCCC PYMIN=20.0 CCCCC PYMAX=90.0 C CCCCC PYDEL=PYMAX-PYMIN CCCCC PXDEL=PYDEL*(ANUMVP/ANUMHP) CCCCC PXMAX=PXMIN+PXDEL C C *************************** C ** STEP 2-- ** C ** WRITE OUT A MESSAGE. ** C *************************** C IF(IFEEDB.EQ.'OFF')GOTO1169 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1151) 1151 FORMAT('THE IMPLEMENTATION MODULE ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1152) 1152 FORMAT(' HAS JUST BEEN ACTIVATED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1153) 1153 FORMAT(' WHICH YIELDS A SQUARE PLOT FRAME') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1154) 1154 FORMAT(' FOR ALL SUBSEQUENT PLOTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1155) 1155 FORMAT(' ON (CONTINUOUS) GRAPHICS DEVICES.') CALL DPWRST('XXX','BUG ') 1169 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 DPIMP2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ISQUAR 9012 FORMAT('ISQUAR = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ANUMVP,ANUMHP 9013 FORMAT('ANUMVP,ANUMHP = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)PXMIN,PXMAX,PYMIN,PYMAX 9014 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9019)IBUGS2,IFOUND,IERROR 9019 FORMAT('IBUGS2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPIMPL(IHARG,IARGT,IARG,NUMARG, 1IX2TSW,IY2TSW,IX2ZSW,IY2ZSW,NCY2LA, 1ISQUAR, 1PXMIN,PYMIN,PXMAX,PYMAX, 1IBUGS2,IFOUND,IERROR) C C PURPOSE--REINITIALIZE A SET OF UNDERLYING C FORTRAN PARAMETERS SO AS TO ACHIEVE C ALTERNATE SETTINGS FOR SUCH PARAMETERS. C NOTE--THIS CAPABILITY IS USEFUL FOR IMPLEMENTATION ,DEBUGGING, C AND FOR NON-STANDARD CONVENTIONS (E.G., PLOTS WITH NON-STANDARD C SIZE OR NO TIC MARKS ON UPPER AND RIGHT FRAME). C INPUT ARGUMENTS-- C --IHARG C --IARGT C --IARG C --NUMARG C --IBUGS2 C OUTPUT ARGUMENTS-- C --IX2TSW C --IY2TSW C --IX2ZSW C --IY2ZSW C --NCY2LA C C --PXMIN C --PYMIN C --PXMAX C --PYMAX C 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 1981. C UPDATED --APRIL 1982. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ISQUAR C CHARACTER*4 IHARG CHARACTER*4 IARGT C CHARACTER*4 IX2TSW CHARACTER*4 IY2TSW C CHARACTER*4 IX2ZSW CHARACTER*4 IY2ZSW C CHARACTER*4 IBUGS2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION IARG(*) 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 IHOLD=(-999) IMPLNU=(-999) C IFOUND='NO' IERROR='NO' C IF(NUMARG.LE.0)GOTO1050 IF(IHARG(NUMARG).EQ.'ON')GOTO1050 IF(IHARG(NUMARG).EQ.'OFF')GOTO1050 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1050 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1050 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1060 GOTO1040 C 1040 CONTINUE IF(IHARG(NUMARG).EQ.'TICS')GOTO1100 IF(IHARG(NUMARG).EQ.'SQUA')GOTO1200 GOTO8000 C 1050 CONTINUE IHOLD=0 GOTO1070 C 1060 CONTINUE IHOLD=IARG(NUMARG) GOTO1070 C 1070 CONTINUE IFOUND='YES' IMPLNU=IHOLD C IF(IMPLNU.EQ.1)GOTO1100 IF(IMPLNU.EQ.2)GOTO1200 GOTO8000 C 1100 CONTINUE CALL DPIMP1(IX2TSW,IY2TSW,IX2ZSW,IY2ZSW,NCY2LA, 1IBUGS2,IFOUND,IERROR) GOTO9000 C 1200 CONTINUE CALL DPIMP2(ANUMVP,ANUMHP, 1ISQUAR, 1PXMIN,PYMIN,PXMAX,PYMAX, 1IBUGS2,IFOUND,IERROR) GOTO9000 C 8000 CONTINUE IERROR='YES' WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8111) 8111 FORMAT('***** ERROR IN DPIMPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8112) 8112 FORMAT(' AN ATTEMPT WAS MADE TO ACTIVATE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8113)IHARG(NUMARG) 8113 FORMAT(' IMPLEMENTATION MODULE ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8114) 8114 FORMAT(' BUT SUCH A MODULE DOES NOT EXIST.') CALL DPWRST('XXX','BUG ') 8119 CONTINUE GOTO9000 C 9000 CONTINUE IF(IBUGS2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPIMPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)NUMARG 9012 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IHARG(1),IARGT(1),IARG(1) 9013 FORMAT('IHARG(1),IARGT(1),IARG(1) = ', 1A4,2X,A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IHARG(NUMARG),IARGT(NUMARG),IARG(NUMARG) 9014 FORMAT('IHARG(NUMARG),IARGT(NUMARG),IARG(NUMARG) = ', 1A4,2X,A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)IHOLD 9015 FORMAT('IHOLD = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)IMPLNU 9016 FORMAT('IMPLNU = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9029)IBUGS2,IFOUND,IERROR 9029 FORMAT('IBUGS2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPINCU(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT, 1ISEED, 1ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) C C PURPOSE--GENERATE ONE OF THE FOLLOWING INFLUENCE CURVES-- C AN INFLUENCE CURVE IS A MEASURE OF ROBUSTNESS. C IT PLOTS THE VALUE OF A STATISTIC WHEN ONE ADDITIONAL C VALUE IS ADDED. FOR EXAMPLE, C MEAN INFLUENCE CURVE Y XSEQ C CYCLES THROUGH THE POINTS IN XSEQ. THE VERTICAL C AXIS IS THE VALUE OF THE MEAN FOR THE POINTS IN Y C WITH THE SINGLE VALUE IN XSEQ ADDED TO Y. C C FOR THIS PLOT, ONLY ONE VARIABLE STATISTICS ARE C SUPPORTED (I.E., NO CORRELATION, ETC.). C C MEAN INFLUENCE CURVE C MIDM INFLUENCE CURVE C MEDI INFLUENCE CURVE C WINSORIZED MEAN INFLUENCE CURVE C BIWEIGHT LOCATION INFLUENCE CURVE C GEOMETRIC MEAN INFLUENCE CURVE C HARMONIC MEAN INFLUENCE CURVE C HODGES LEHMAN PLOT C SD INFLUENCE CURVE C REL SD INFLUENCE CURVE C SD MEAN INFLUENCE CURVE C TRIMMED MEAN STANDARD ERROR INFLUENCE CURVE C VARI INFLUENCE CURVE C REL VARI INFLUENCE CURVE C VARI MEAN INFLUENCE CURVE C RANG INFLUENCE CURVE C GEOMETRIC STANDARD DEVIATION INFLUENCE CURVE C AAD INFLUENCE CURVE C MAD INFLUENCE CURVE C SN INFLUENCE CURVE C QN INFLUENCE CURVE C INTERQUARTILE RANGE INFLUENCE CURVE C BIWEIGHT SCALE INFLUENCE CURVE C BIWEIGHT MIDVARIANCE PLOT C PERCENTAGE BEND MIDVARIANCE PLOT C WINSORIZED VARIANCE INFLUENCE CURVE C WINSORIZED SD INFLUENCE CURVE C MINI INFLUENCE CURVE C MAXI INFLUENCE CURVE C EXTREME INFLUENCE CURVE C SKEW INFLUENCE CURVE C KURT INFLUENCE CURVE C AUCR INFLUENCE CURVE C SDM INFLUENCE CURVE C AUCV INFLUENCE CURVE C RACV INFLUENCE CURVE C LOWH INFLUENCE CURVE C UPPH INFLUENCE CURVE C LOWQ INFLUENCE CURVE C UPPQ INFLUENCE CURVE C TRIM INFLUENCE CURVE C WINM INFLUENCE CURVE C MIDQ INFLUENCE CURVE C PERCENTILE INFLUENCE CURVE C QUANTILE INFLUENCE CURVE C QUANTILE STANDARD ERROR INFLUENCE CURVE C 1DEC INFLUENCE CURVE C 2DEC INFLUENCE CURVE C 3DEC INFLUENCE CURVE C 4DEC INFLUENCE CURVE C 5DEC INFLUENCE CURVE C 6DEC INFLUENCE CURVE C 7DEC INFLUENCE CURVE C 8DEC INFLUENCE CURVE C 9DEC INFLUENCE CURVE C SINE FREQUENCY INFLUENCE CURVE C SINE AMPLITUDE INFLUENCE CURVE C TAGUCHI SIGNAL-TO-NOISE INFLUENCE CURVES C CP INFLUENCE CURVE C CPL INFLUENCE CURVE C CPU INFLUENCE CURVE C CPK INFLUENCE CURVE C CPM INFLUENCE CURVE C CC INFLUENCE CURVE C CNPK INFLUENCE CURVE C PERCENT DEFECTIVE INFLUENCE CURVE C EXPECTED LOSS INFLUENCE CURVE C NORM PPCC INFLUENCE CURVE 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-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--2002/7 C ORIGINAL VERSION--JULY 2002. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IAND1 CHARACTER*4 IAND2 CHARACTER*4 ICONT CHARACTER*4 ISUBRO CHARACTER*4 IBUGG2 CHARACTER*4 IBUGG3 CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASEQ CHARACTER*4 IH CHARACTER*4 IH2 CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CHARACTER*4 IHHOR CHARACTER*4 IHHOR2 CHARACTER*4 IHX CHARACTER*4 IHX2 C CHARACTER*4 ISUBN0 CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION TEMP(*) DIMENSION TEMP2(*) DIMENSION TEMP3(*) DIMENSION XTEMP1(*) DIMENSION XTEMP2(*) C DIMENSION Y1(MAXOBV) DIMENSION Z1(MAXOBV) DIMENSION X1(MAXOBV) DIMENSION XTEMP3(MAXOBV) INCLUDE 'DPCOZZ.INC' EQUIVALENCE (GARBAG(IGARB1),X1(1)) EQUIVALENCE (GARBAG(IGARB2),Y1(1)) EQUIVALENCE (GARBAG(IGARB3),Z1(1)) EQUIVALENCE (GARBAG(IGARB4),XTEMP3(1)) C INCLUDE 'DPCOZI.INC' C INTEGER ITEMP1(MAXOBV) INTEGER ITEMP2(MAXOBV) INTEGER ITEMP3(MAXOBV) INTEGER ITEMP4(MAXOBV) INTEGER ITEMP5(MAXOBV) INTEGER ITEMP6(MAXOBV) EQUIVALENCE (IGARBG(IIGAR1),ITEMP1(1)) EQUIVALENCE (IGARBG(IIGAR2),ITEMP2(1)) EQUIVALENCE (IGARBG(IIGAR3),ITEMP3(1)) EQUIVALENCE (IGARBG(IIGAR4),ITEMP4(1)) EQUIVALENCE (IGARBG(IIGAR5),ITEMP5(1)) EQUIVALENCE (IGARBG(IIGAR6),ITEMP6(1)) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' INCLUDE 'DPCOHO.INC' INCLUDE 'DPCOST.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='NO' C ISUBN1='INCU' ISUBN2=' ' 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 ICOLL=0 ICOLH=0 ICOLX=0 C C ************************************ C ** TREAT THE INFLUENCE CURVE CASE ** C ************************************ C IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'INCU')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPINCU--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ 52 FORMAT('ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ = ', 1A4,2X,A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASPL,IAND1,IAND2 53 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C *************************** C ** STEP 1-- ** C ** EXTRACT THE COMMAND ** C *************************** C ISTEPN='1' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPINCU') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C ********************************* C ** STEP 1-- ** C ** DETERMINE IF OF THIS TYPE ** C ** AND BRANCH ACCORDINGLY. ** C ********************************* C ISTEPN='1' IF(IBUGG2.EQ.'ON'.AND.ISUBRO.NE.'INCU') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.1)GOTO9000 C IF(ICOM.EQ.'MIDR'.AND.ICOM2.EQ.'ANGE')GOTO221 IF(ICOM.EQ.'MEAN'.AND.ICOM2.EQ.' ')GOTO222 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'AVER'.AND.ICOM2.EQ.'AGE '.AND.IHARG(1).EQ.'ABSO'.AND. 1IHARG(2).EQ.'DEVI')GOTO413 IF(ICOM.EQ.'AAD '.AND.ICOM2.EQ.' ')GOTO414 C IF(ICOM.EQ.'AVER'.AND.ICOM2.EQ.'AGE ')GOTO222 IF(ICOM.EQ.'MIDM'.AND.ICOM2.EQ.'EAN ')GOTO223 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'MEDI'.AND.ICOM2.EQ.'AN '.AND.IHARG(1).EQ.'ABSO'.AND. 1IHARG(2).EQ.'DEVI')GOTO415 IF(ICOM.EQ.'MAD '.AND.ICOM2.EQ.' ')GOTO416 C IF(ICOM.EQ.'MEDI'.AND.ICOM2.EQ.'AN ')GOTO224 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'TRIM'.AND.IHARG(1).EQ.'MEAN'.AND. 1(IHARG(2).NE.'STAN'.AND.IHARG(3).NE.'ERRO'))GOTO225 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'WIND'.AND.IHARG(1).EQ.'MEAN')GOTO226 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'WINS'.AND.IHARG(1).EQ.'MEAN')GOTO226 C IF(ICOM.EQ.'R '.AND.ICOM2.EQ.' ')GOTO241 IF(ICOM.EQ.'RANG'.AND.ICOM2.EQ.'E ')GOTO241 IF(ICOM.EQ.'MINI'.AND.ICOM2.EQ.'MUM ')THEN IF(NUMARG.GE.2.AND.IHARG(1).EQ.'BLOC'.AND.IHARG(2).EQ.'PLOT') 1 GOTO9000 GOTO242 ENDIF IF(ICOM.EQ.'MINI')THEN IF(NUMARG.GE.2.AND.IHARG(1).EQ.'BLOC'.AND.IHARG(2).EQ.'PLOT') 1 GOTO9000 GOTO242 ENDIF IF(ICOM.EQ.'MIN '.AND.ICOM2.EQ.' ')THEN IF(NUMARG.GE.2.AND.IHARG(1).EQ.'BLOC'.AND.IHARG(2).EQ.'PLOT') 1 GOTO9000 GOTO242 ENDIF IF(ICOM.EQ.'MAXI'.AND.ICOM2.EQ.'MUM ')THEN IF(NUMARG.GE.2.AND.IHARG(1).EQ.'BLOC'.AND.IHARG(2).EQ.'PLOT') 1 GOTO9000 GOTO243 ENDIF IF(ICOM.EQ.'MAXI')THEN IF(NUMARG.GE.2.AND.IHARG(1).EQ.'BLOC'.AND.IHARG(2).EQ.'PLOT') 1 GOTO9000 GOTO243 ENDIF IF(ICOM.EQ.'MAX '.AND.ICOM2.EQ.' ')THEN IF(NUMARG.GE.2.AND.IHARG(1).EQ.'BLOC'.AND.IHARG(2).EQ.'PLOT') 1 GOTO9000 GOTO243 ENDIF C IF(NUMARG.GE.3.AND. 1ICOM.EQ.'VARI'.AND.IHARG(1).EQ.'OF '.AND. 1IHARG(2).EQ.'THE '.AND.IHARG(3).EQ.'MEAN')GOTO251 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'VARI'.AND.IHARG(1).EQ.'OF '.AND. 1IHARG(2).EQ.'MEAN')GOTO252 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'VARI'.AND.IHARG(1).EQ.'MEAN')GOTO253 IF(ICOM.EQ.'VARI'.AND.ICOM2.EQ.'ANCE')GOTO254 IF(ICOM.EQ.'VARI'.AND.ICOM2.EQ.' ')GOTO254 C IF(NUMARG.GE.3.AND. 1ICOM.EQ.'VAR '.AND.IHARG(1).EQ.'OF '.AND. 1IHARG(2).EQ.'THE '.AND.IHARG(3).EQ.'MEAN')GOTO251 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'VAR '.AND.IHARG(1).EQ.'OF '.AND. 1IHARG(2).EQ.'MEAN')GOTO252 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'VAR '.AND.IHARG(1).EQ.'MEAN')GOTO253 IF(ICOM.EQ.'VAR '.AND.ICOM2.EQ.' ')GOTO254 C IF(NUMARG.GE.4.AND. 1ICOM.EQ.'STAN'.AND.IHARG(1).EQ.'DEVI'.AND. 1IHARG(2).EQ.'OF '.AND.IHARG(3).EQ.'THE '.AND. 1IHARG(4).EQ.'MEAN')GOTO261 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'STAN'.AND.IHARG(1).EQ.'DEVI'.AND. 1IHARG(2).EQ.'OF '.AND.IHARG(3).EQ.'MEAN')GOTO262 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'STAN'.AND.IHARG(1).EQ.'DEVI'.AND. 1IHARG(2).EQ.'MEAN')GOTO263 C IF(NUMARG.GE.3.AND. 1ICOM.EQ.'SD '.AND.IHARG(1).EQ.'OF '.AND. 1IHARG(2).EQ.'THE '.AND.IHARG(3).EQ.'MEAN')GOTO262 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'SD '.AND.IHARG(1).EQ.'OF '.AND. 1IHARG(2).EQ.'MEAN')GOTO263 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'SD '.AND.IHARG(1).EQ.'MEAN')GOTO266 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'STAN'.AND.IHARG(1).EQ.'DEVI')GOTO264 IF(ICOM.EQ.'SD '.AND.ICOM2.EQ.' ')GOTO265 IF(ICOM.EQ.'S '.AND.ICOM2.EQ.' ')GOTO265 C IF(ICOM.EQ.'RS '.AND.ICOM2.EQ.' ')GOTO271 IF(ICOM.EQ.'RSD '.AND.ICOM2.EQ.' ')GOTO271 IF(ICOM.EQ.'RELS'.AND.ICOM2.EQ.' ')GOTO271 IF(ICOM.EQ.'RELS'.AND.ICOM2.EQ.'D ')GOTO271 IF(ICOM.EQ.'RV '.AND.ICOM2.EQ.' ')GOTO272 IF(ICOM.EQ.'RVAR'.AND.ICOM2.EQ.' ')GOTO272 IF(ICOM.EQ.'RELV'.AND.ICOM2.EQ.' ')GOTO272 IF(ICOM.EQ.'RELV'.AND.ICOM2.EQ.' ')GOTO272 IF(ICOM.EQ.'RELV'.AND.ICOM2.EQ.'AR ')GOTO272 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'COEF'.AND.IHARG(1).EQ.'OF '.AND. 1IHARG(2).EQ.'VARI')GOTO273 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'COEF'.AND.IHARG(1).EQ.'VARI')GOTO274 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'RELA'.AND.IHARG(1).EQ.'SD ')GOTO276 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'RELA'.AND.IHARG(1).EQ.'STAN'.AND. 1IHARG(2).EQ.'DEVI')GOTO277 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'RELA'.AND.IHARG(1).EQ.'VAR ')GOTO278 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'RELA'.AND.IHARG(1).EQ.'VARI')GOTO278 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'LOWE'.AND.IHARG(1).EQ.'QUAR')GOTO301 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'FIRS'.AND.IHARG(1).EQ.'QUAR')GOTO301 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'SECO'.AND.IHARG(1).EQ.'QUAR')GOTO302 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'UPPE'.AND.IHARG(1).EQ.'QUAR')GOTO303 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'THIR'.AND.IHARG(1).EQ.'QUAR')GOTO303 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'LOWE'.AND.IHARG(1).EQ.'HING')GOTO304 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'UPPE'.AND.IHARG(1).EQ.'HING')GOTO305 C IF(NUMARG.GE.3.AND. 1ICOM.EQ.'STAN'.AND.IHARG(1).EQ.'THIR'.AND. 1IHARG(2).EQ.'CENT'.AND.IHARG(3).EQ.'MOME')GOTO311 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'STAN'.AND.IHARG(1).EQ.'3RD '.AND. 1IHARG(2).EQ.'CENT'.AND.IHARG(3).EQ.'MOME')GOTO311 IF(ICOM.EQ.'SKEW'.AND.ICOM2.EQ.'NESS')GOTO312 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'STAN'.AND.IHARG(1).EQ.'FOUR'.AND. 1IHARG(2).EQ.'CENT'.AND.IHARG(3).EQ.'MOME')GOTO313 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'STAN'.AND.IHARG(1).EQ.'4TH '.AND. 1IHARG(2).EQ.'CENT'.AND.IHARG(3).EQ.'MOME')GOTO313 IF(ICOM.EQ.'KURT'.AND.ICOM2.EQ.'OSIS')GOTO314 C IF(NUMARG.GE.2.AND. 1ICOM.EQ.'AUTO'.AND.ICOM2.EQ.'COVA'.AND. 1IHARG(1).EQ.'INFL'.AND.IHARG(2).EQ.'CURV')GOTO321 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'AUTO'.AND.ICOM2.EQ.'CORR'.AND. 1IHARG(1).EQ.'INFL'.AND.IHARG(2).EQ.'CURV')GOTO322 C IF(NUMARG.GE.1.AND.IHARG(1).EQ.'DECI')GOTO111 GOTO119 111 CONTINUE IF(ICOM.EQ.'FIRS')GOTO341 IF(ICOM.EQ.'SECO')GOTO342 IF(ICOM.EQ.'THIR')GOTO343 IF(ICOM.EQ.'FOUR')GOTO344 IF(ICOM.EQ.'FIFT')GOTO345 IF(ICOM.EQ.'SIXT')GOTO346 IF(ICOM.EQ.'SEVE')GOTO347 IF(ICOM.EQ.'EIGH')GOTO348 IF(ICOM.EQ.'NINT')GOTO349 119 CONTINUE C IF(ICOM.EQ.'PERC'.AND.IHARG(1).NE.'BEND'.AND.IHARG(1).NE.'DEFE') 1 GOTO350 C IF(ICOM.EQ.'SN'.AND.IHARG(1).EQ.'SCAL')GOTO478 IF(ICOM.EQ.'QN'.AND.IHARG(1).EQ.'SCAL')GOTO480 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'SIN'.AND.IHARG(1).EQ.'FREQ')GOTO361 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'SINE'.AND.IHARG(1).EQ.'FREQ')GOTO361 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'SIN'.AND.IHARG(1).EQ.'AMP')GOTO362 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'SINE'.AND.IHARG(1).EQ.'AMP')GOTO362 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'SIN'.AND.IHARG(1).EQ.'AMPL')GOTO362 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'SINE'.AND.IHARG(1).EQ.'AMPL')GOTO362 C IF(NUMARG.GE.1.AND.ICOM.EQ.'TAGU')GOTO130 GOTO139 130 CONTINUE IF(IHARG(1).EQ.'SN')GOTO371 IF(IHARG(1).EQ.'S/N')GOTO371 IF(IHARG(1).EQ.'SN0')GOTO371 IF(IHARG(1).EQ.'S/N0')GOTO371 IF(IHARG(1).EQ.'SNT')GOTO371 IF(IHARG(1).EQ.'S/NT')GOTO371 IF(IHARG(1).EQ.'SN+')GOTO372 IF(IHARG(1).EQ.'S/N+')GOTO372 IF(IHARG(1).EQ.'SNL')GOTO372 IF(IHARG(1).EQ.'SN-')GOTO373 IF(IHARG(1).EQ.'S/N-')GOTO373 IF(IHARG(1).EQ.'SNS')GOTO373 IF(IHARG(1).EQ.'SN00')GOTO374 IF(IHARG(1).EQ.'SNT2')GOTO374 IF(IHARG(1).EQ.'S/N2')GOTO374 IF(IHARG(1).EQ.'SN2')GOTO374 139 CONTINUE C IF(ICOM.EQ.'SN')GOTO381 IF(ICOM.EQ.'S/N')GOTO381 IF(ICOM.EQ.'SN0')GOTO381 IF(ICOM.EQ.'S/N0')GOTO381 IF(ICOM.EQ.'SNT')GOTO381 IF(ICOM.EQ.'S/NT')GOTO381 IF(ICOM.EQ.'SN+')GOTO382 IF(ICOM.EQ.'S/N+')GOTO382 IF(ICOM.EQ.'SNL ')GOTO382 IF(ICOM.EQ.'SN-')GOTO383 IF(ICOM.EQ.'S/N-')GOTO383 IF(ICOM.EQ.'SNS')GOTO383 IF(ICOM.EQ.'SN00')GOTO384 IF(ICOM.EQ.'SNT2')GOTO384 IF(ICOM.EQ.'S/N2')GOTO384 IF(ICOM.EQ.'SN2')GOTO384 C IF(ICOM.EQ.'CP')GOTO401 IF(ICOM.EQ.'CPK')GOTO402 IF(ICOM.EQ.'CNPK')GOTO398 IF(ICOM.EQ.'CPM')GOTO400 IF(ICOM.EQ.'CC')GOTO399 IF(ICOM.EQ.'CPL')GOTO396 IF(ICOM.EQ.'CPU')GOTO397 IF(NUMARG.GE.1)THEN IF(ICOM.EQ.'PERC'.AND.IHARG(1).EQ.'DEFE')GOTO403 IF(ICOM.EQ.'EXPE'.AND.IHARG(1).EQ.'LOSS')GOTO404 ENDIF C IF(NUMARG.GE.1)THEN IF(ICOM.EQ.'NORM'.AND.IHARG(1).EQ.'PPCC')GOTO411 ENDIF C IF(NUMARG.GE.1)THEN IF(ICOM.EQ.'EXTR')GOTO412 ENDIF C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'GEOM'.AND.ICOM2.EQ.'ETRI'.AND.IHARG(1).EQ.'MEAN')GOTO426 C IF(NUMARG.GE.2.AND. 1ICOM.EQ.'GEOM'.AND.ICOM2.EQ.'ETRI'.AND.IHARG(1).EQ.'STAN'.AND. 1IHARG(2).EQ.'DEVI')GOTO436 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'HARM'.AND.IHARG(1).EQ.'MEAN')GOTO446 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'INTE'.AND.IHARG(1).EQ.'RANG')GOTO456 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'IQ '.AND.IHARG(1).EQ.'RANG')GOTO456 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'BIWE'.AND.IHARG(1).EQ.'LOCA')GOTO457 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'BIWE'.AND.IHARG(1).EQ.'SCAL')GOTO458 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'WINS'.AND.IHARG(1).EQ.'VARI')GOTO460 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'WINS'.AND.IHARG(1).EQ.'SD')GOTO462 C IF(NUMARG.GE.2.AND. 1ICOM.EQ.'WINS'.AND.IHARG(1).EQ.'STAN'.AND.IHARG(2).EQ.'DEVI') 1GOTO464 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'BIWE'.AND.IHARG(1).EQ.'MIDV')GOTO466 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'HODG'.AND.IHARG(1).EQ.'LEHM')GOTO468 C IF(NUMARG.GE.2.AND. 1ICOM.EQ.'PERC'.AND.IHARG(1).EQ.'BEND'.AND.IHARG(2).EQ.'MIDV') 1GOTO470 C IF(NUMARG.GE.2.AND. 1ICOM.EQ.'QUAN'.AND.IHARG(1).EQ.'STAN'.AND.IHARG(2).EQ.'ERRO') 1GOTO472 C IF(ICOM.EQ.'QUAN')GOTO474 C IF(NUMARG.GE.3.AND. 1ICOM.EQ.'TRIM'.AND.IHARG(1).EQ.'MEAN'.AND. 1IHARG(2).EQ.'STAN'.AND.IHARG(3).EQ.'ERRO') 1GOTO476 C IFOUND='NO' GOTO9000 C C ********************** C ** STEP 2-- ** C ** DEFINE ICASPL. ** C ********************** C 221 CONTINUE ICASPL='MIDR' GOTO701 C 222 CONTINUE ICASPL='MEAN' GOTO701 C 223 CONTINUE ICASPL='MIDM' GOTO701 C 224 CONTINUE ICASPL='MEDI' GOTO701 C 225 CONTINUE ICASPL='TRIM' GOTO702 C 226 CONTINUE ICASPL='WINM' GOTO702 C 241 CONTINUE ICASPL='RANG' GOTO701 C 242 CONTINUE ICASPL='MINI' GOTO701 C 243 CONTINUE ICASPL='MAXI' GOTO701 C 251 CONTINUE ICASPL='VAME' GOTO704 C 252 CONTINUE ICASPL='VAME' GOTO703 C 253 CONTINUE ICASPL='VAME' GOTO702 C 254 CONTINUE ICASPL='VARI' GOTO701 C 261 CONTINUE ICASPL='SDME' GOTO705 C 262 CONTINUE ICASPL='SDME' GOTO704 C 263 CONTINUE ICASPL='SDME' GOTO703 C 264 CONTINUE ICASPL='SD' GOTO702 C 265 CONTINUE ICASPL='SD' GOTO701 C 266 CONTINUE ICASPL='SDME' GOTO702 C 271 CONTINUE ICASPL='RESD' GOTO701 C 272 CONTINUE ICASPL='REVA' GOTO701 C 273 CONTINUE ICASPL='CVAR' GOTO703 C 274 CONTINUE ICASPL='CVAR' GOTO702 C 276 CONTINUE ICASPL='RESD' GOTO702 C 277 CONTINUE ICASPL='RESD' GOTO703 C 278 CONTINUE ICASPL='REVA' GOTO702 C 301 CONTINUE ICASPL='LOWQ' GOTO702 C 302 CONTINUE ICASPL='MIDQ' GOTO702 C 303 CONTINUE ICASPL='UPPQ' GOTO702 C 304 CONTINUE ICASPL='LOWH' GOTO702 C 305 CONTINUE ICASPL='UPPH' GOTO702 C 311 CONTINUE ICASPL='SKEW' GOTO704 C 312 CONTINUE ICASPL='SKEW' GOTO701 C 313 CONTINUE ICASPL='KURT' GOTO704 C 314 CONTINUE ICASPL='KURT' GOTO701 C 321 CONTINUE ICASPL='AUCV' GOTO701 C 322 CONTINUE ICASPL='AUCR' GOTO701 C 341 CONTINUE ICASPL='1DEC' GOTO702 C 342 CONTINUE ICASPL='2DEC' GOTO702 C 343 CONTINUE ICASPL='3DEC' GOTO702 C 344 CONTINUE ICASPL='4DEC' GOTO702 C 345 CONTINUE ICASPL='5DEC' GOTO702 C 346 CONTINUE ICASPL='6DEC' GOTO702 C 347 CONTINUE ICASPL='7DEC' GOTO702 C 348 CONTINUE ICASPL='8DEC' GOTO702 C 349 CONTINUE ICASPL='9DEC' GOTO702 C 350 CONTINUE ICASPL='PERC' GOTO701 C 361 CONTINUE ICASPL='SIFR' GOTO702 C 362 CONTINUE ICASPL='SIAM' GOTO702 C 371 CONTINUE ICASPL='SN0' GOTO702 C 372 CONTINUE ICASPL='SN+' GOTO702 C 373 CONTINUE ICASPL='SN-' GOTO702 C 374 CONTINUE ICASPL='SN00' GOTO702 C 381 CONTINUE ICASPL='SN0' GOTO701 C 382 CONTINUE ICASPL='SN+' GOTO701 C 383 CONTINUE ICASPL='SN-' GOTO701 C 384 CONTINUE ICASPL='SN00' GOTO701 C 396 CONTINUE ICASPL='CPL' GOTO701 C 397 CONTINUE ICASPL='CPU' GOTO701 C 398 CONTINUE ICASPL='CNPK' GOTO701 C 399 CONTINUE ICASPL='CC' GOTO701 C 400 CONTINUE ICASPL='CPM' GOTO701 C 401 CONTINUE ICASPL='CP' GOTO701 C 402 CONTINUE ICASPL='CPK' GOTO701 C 403 CONTINUE ICASPL='PEDE' GOTO702 C 404 CONTINUE ICASPL='EXLO' GOTO702 C 411 CONTINUE ICASPL='NOPP' GOTO702 C 412 CONTINUE ICASPL='EXTR' GOTO701 C 413 CONTINUE ICASPL='AAD ' GOTO703 C 414 CONTINUE ICASPL='AAD ' GOTO701 C 415 CONTINUE ICASPL='MAD ' GOTO703 C 416 CONTINUE ICASPL='MAD ' GOTO701 C 426 CONTINUE ICASPL='GEME' GOTO702 C 436 CONTINUE ICASPL='GESD' GOTO703 C 446 CONTINUE ICASPL='HAME' GOTO702 C 456 CONTINUE ICASPL='IQRA' GOTO702 C 457 CONTINUE ICASPL='BILO' GOTO702 C 458 CONTINUE ICASPL='BISC' GOTO702 C 460 CONTINUE ICASPL='WIVA' GOTO702 C 462 CONTINUE ICASPL='WISD' GOTO702 C 464 CONTINUE ICASPL='WISD' GOTO703 C 466 CONTINUE ICASPL='BIMV' GOTO702 C 468 CONTINUE ICASPL='HLEH' GOTO702 C 470 CONTINUE ICASPL='PBMV' GOTO703 C 472 CONTINUE ICASPL='QUSE' GOTO703 C 474 CONTINUE ICASPL='QUAN' GOTO701 C 476 CONTINUE ICASPL='TMSE' GOTO704 C 478 CONTINUE ICASPL='SNSC' GOTO702 C 480 CONTINUE ICASPL='QNSC' GOTO702 C C ***************************************************** C ** STEP 2-- ** C ** DETERMINE THE LOCATION (IN IHARG(.)) ** C ** OF THE WORD INFLUENCE CURVE ** C ** PLACE IT IN ILASTC ** C ***************************************************** C 701 CONTINUE IF(NUMARG.LT.2)GOTO780 IF(IHARG(1).EQ.'INFL'.AND.IHARG(2).EQ.'CURV')GOTO802 GOTO780 C 702 CONTINUE IF(NUMARG.LT.3)GOTO780 IF(IHARG(2).EQ.'INFL'.AND.IHARG(3).EQ.'CURV')GOTO803 GOTO780 C 703 CONTINUE IF(NUMARG.LT.4)GOTO780 IF(IHARG(3).EQ.'INFL'.AND.IHARG(4).EQ.'CURV')GOTO804 GOTO780 C 704 CONTINUE IF(NUMARG.LT.5)GOTO780 IF(IHARG(4).EQ.'INFL'.AND.IHARG(5).EQ.'CURV')GOTO805 GOTO780 C 705 CONTINUE IF(NUMARG.LT.6)GOTO780 IF(IHARG(5).EQ.'INFL'.AND.IHARG(6).EQ.'CURV')GOTO806 GOTO780 C 780 CONTINUE IFOUND='NO' ICASPL='UNKN' GOTO9000 C 801 CONTINUE ILASTC=1 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO890 C 802 CONTINUE ILASTC=2 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO890 C 803 CONTINUE ILASTC=3 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO890 C 804 CONTINUE ILASTC=4 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO890 C 805 CONTINUE ILASTC=5 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO890 C 806 CONTINUE ILASTC=6 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO890 C 890 CONTINUE IFOUND='YES' C C ****************************************************** C ** STEP 21-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ****************************************************** C ISTEPN='21' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'INCU') 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 C ******************************************** C ** STEP 22-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C ** (THIS WILL BE THE RESPONSE VARIABLE) ** C ******************************************** C ISTEPN='22' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPINCU') 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) IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'INCU') 1WRITE(ICOUT,2211)IHLEFT,ICOLL,NLEFT 2211 FORMAT('IHLEFT,ICOLL,NLEFT = ',A4,I8,I8) IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPINCU') 1CALL DPWRST('XXX','BUG ') C C ****************************************************** C ** STEP 23--CHECK THAT ** C ** THE INPUT NUMBER OF OBSERVATIONS (NLEFT) ** C ** FOR THE RESPONSE VARIABLE IS 2 OR LARGER. ** C ****************************************************** C ISTEPN='23' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'INCU') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NLEFT.GE.MINN2)GOTO2390 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2311) 2311 FORMAT('***** ERROR IN DPINCU--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2312) 2312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2321) 2321 FORMAT(' (FOR WHICH A ... INFLUENCE CURVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2314) 2314 FORMAT(' WAS TO HAVE BEEN FORMED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2315)MINN2 2315 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2316) 2316 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2317) 2317 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2318)(IANS(I),I=1,MIN(80,IWIDTH)) 2318 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 2390 CONTINUE C C ***************************************** C ** STEP 24-- ** C ** CHECK TO SEE THE TYPE SUBCASE ** C ** (BASED ON THE QUALIFIER)-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='24' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPINCU') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO2480 DO2400J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO2410 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO2410 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO2420 2400 CONTINUE GOTO2490 2410 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO2490 2420 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO2490 C 2480 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2481) 2481 FORMAT('***** INTERNAL ERROR IN DPINCU') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2482) 2482 FORMAT(' AT BRANCH POINT 2481--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2483) 2483 FORMAT(' NUMARG LESS THAN 1 EVEN THOUGH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2484) 2484 FORMAT(' NUMARG HAD PREVIOUSLY PASSED THIS TEST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2485)NUMARG 2485 FORMAT(' ONCE ALREADY. VALUE OF NUMARG = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2486) 2486 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2487)(IANS(I),I=1,IWIDTH) 2487 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 2490 CONTINUE IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'INCU')GOTO2495 WRITE(ICOUT,2491)NUMARG,ILOCQ,ICASEQ 2491 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') 2495 CONTINUE C C ***************************************** C ** STEP 24.5-- ** C ** DETERMINE THE NUMBER OF VARIABLES ** C ***************************************** C ISTEPN='24.5' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'INCU') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMV2=ILOCQ-1 C C ****************************************************** C ** STEP 25-- ** C ** FOR A ONE VARIABLE STATISTIC (E.G., THE MEAN) ** C ** THE SECOND VARIABLE IS THE ARRAY OF VALUES ** C ** THAT ARE ADDED TO THE FIRST VARIABLE (ONE AT ** C ** A TIME). TWO VARIABLE STATISTICS NOT CURRENTLY ** C ** SUPPORTED, SO THEREFORE EXACTLY TWO VARIABLES ** C ** EXPECTED. ** C ****************************************************** C ISTEPN='25' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'INCU') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMV2=ILOCQ-1 IF(NUMV2.EQ.2)GOTO2530 GOTO2510 C 2510 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2511) 2511 FORMAT('***** ERROR IN DPINCU--FOR AN ... INFLUENCE CURVE,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2518) 2518 FORMAT(' THE NUMBER OF VARIABLES MUST BE EXACTLY TWO.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2520) 2520 FORMAT(' SUCH WAS NOT THE CASE HERE; THE SPECIFIED NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2522)NUMV2 2522 FORMAT(' OF VARIABLES WAS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2523) 2523 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2524)(IANS(I),I=1,MIN(80,IWIDTH)) 2524 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 2530 CONTINUE IHHOR=IHARG(2) IHHOR2=IHARG2(2) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHHOR,IHHOR2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLH=IVALUE(ILOCV) NHOR=IN(ILOCV) IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'INCU') 1WRITE(ICOUT,2531)IHHOR,ICOLH,NHOR 2531 FORMAT('IHHOR,ICOLH,NHOR = ',A4,I8,I8) IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'INCU') 1CALL DPWRST('XXX','BUG ') C C ************************************************* C ** STEP 26-- ** C ** BRANCH TO THE APPROPRIATE SUBCASE; ** C ** (BASED ON THE QUALIFIER) ** C ** THEN FORM THE RESPONSE VARIABLE ** C ** AND THE SECOND VARIABLE (IF EXISTENT) ** C ************************************************* C ISTEPN='26' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPINCU') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO2610 IF(ICASEQ.EQ.'SUBS')GOTO2620 IF(ICASEQ.EQ.'FOR')GOTO2630 C 2610 CONTINUE DO2615I=1,NLEFT ISUB(I)=1 2615 CONTINUE NQ=NLEFT GOTO2650 C 2620 CONTINUE NIOLD=NLEFT CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO2650 C 2630 CONTINUE NIOLD=NLEFT CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO2650 C 2650 CONTINUE J=0 IMAX=NLEFT IF(NQ.LT.NLEFT)IMAX=NQ DO2660I=1,IMAX IF(ISUB(I).EQ.0)GOTO2660 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 2660 CONTINUE NY=J C J=0 IMAX=NHOR IF(NQ.LT.NLEFT)IMAX=NQ DO2665I=1,IMAX J=J+1 C IJ=MAXN*(ICOLH-1)+I IF(ICOLH.LE.MAXCOL)X1(J)=V(IJ) IF(ICOLH.EQ.MAXCP1)X1(J)=PRED(I) IF(ICOLH.EQ.MAXCP2)X1(J)=RES(I) IF(ICOLH.EQ.MAXCP3)X1(J)=YPLOT(I) IF(ICOLH.EQ.MAXCP4)X1(J)=XPLOT(I) IF(ICOLH.EQ.MAXCP5)X1(J)=X2PLOT(I) IF(ICOLH.EQ.MAXCP6)X1(J)=TAGPLO(I) C 2665 CONTINUE NX=J C C ******************************************************* C ** STEP 28-- ** C ** COMPUTE THE APPROPRIATE INFLUENCE CURVE -- ** C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** C ** VALUES Y(.) AND X(.) FOR THE PLOT. ** C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). ** C ******************************************************* C ISTEPN='28' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'INCU') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL DPINC2(Y1,X1,Z1,NX,NY,NUMV2,ICASPL,ISIZE,ICONT, 1TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,XTEMP3,MAXNXT, 1ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1IQUAME,IQUASE, 1Y,X,D,NPLOTP,NPLOTV,ISUBRO,IBUGG3,IERROR) C C C ************************************************* C ** STEP 29-- ** C ** SAVE DIFFERENCE BETWEEN HIGHEST VALUE AND ** C ** LOWEST VALUE OF STATISTIC IN INTERNAL ** C ** PARAMETER ALOWHIGH ** C ************************************************* AMINS=CPUMAX AMAXS=CPUMIN DO2910I=1,NPLOTP IF(D(I).NE.1.0)GOTO2910 IF(Y(I).GT.AMAXS)THEN AMAXS=Y(I) IMAXIN=I ENDIF IF(Y(I).LT.AMINS)THEN AMINS=Y(I) IMININ=I ENDIF 2910 CONTINUE ADIFF=AMAXS-AMINS IF(IMAXIN.GT.IMININ)ADIFF=-ADIFF C ISUBN0='INCU' C IH='ALOW' IH2='HIGH' VALUE0=ADIFF CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGG3,IERROR) C C C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'INCU')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPINCU--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ 9012 FORMAT('ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ = ', 1A4,2X,A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IFOUND,IERROR 9013 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 9014 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ', 1I8,I8,I8,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)ISIZE 9015 FORMAT('ISIZE = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)NUMV2 9016 FORMAT('NUMV2 = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)IHLEFT,IHLEF2,ICOLL,NLEFT 9017 FORMAT('IHLEFT,IHLEF2,ICOLL,NLEFT = ',A4,2X,A4,I8,I8) CALL DPWRST('XXX','BUG ') IF(NUMV2.GE.2)WRITE(ICOUT,9018)IHHOR,IHHOR2,ICOLH,NHOR 9018 FORMAT('IHHOR,IHHOR2,ICOLH,NHOR = ',A4,2X,A4,I8,I8) IF(NUMV2.GE.2)CALL DPWRST('XXX','BUG ') IF(NUMV2.GE.3)WRITE(ICOUT,9019)IHX,IHX2,ICOLX,NX 9019 FORMAT('IHX,IHX2,ICOLX,NX = ',A4,2X,A4,I8,I8) IF(NUMV2.GE.3)CALL DPWRST('XXX','BUG ') CCCCC THE FOLLOWING LINE WAS CHANGED SEPTEMBER 1992 CCCCC IF(NPLOTP.LE.0)GOTO9090 IF(IFOUND.EQ.'NO'.OR.NPLOTP.LE.0)GOTO9090 DO9025I=1,NPLOTP WRITE(ICOUT,9026)I,Y(I),X(I),D(I) 9026 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) CALL DPWRST('XXX','BUG ') 9025 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPINC2(Y,X,Z,NX,NY,NUMV2,ICASPL,ISIZE,ICONT, 1TEMP,TEMPZ,XIDTEM,XTEMP1,XTEMP2,XTEMP3,MAXNXT, 1ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1IQUAME,IQUASE, 1Y2,X2,D2,N2,NPLOTV,ISUBRO,IBUGG3,IERROR) C C PURPOSE--GENERATE ONE OF THE FOLLOWING INFLUENCE CURVES-- C AN INFLUENCE CURVE IS A MEASURE OF ROBUSTNESS. C IT PLOTS THE VALUE OF A STATISTIC WHEN ONE ADDITIONAL C VALUE IS ADDED. FOR EXAMPLE, C MEAN INFLUENCE CURVE Y XSEQ C CYCLES THROUGH THE POINTS IN XSEQ. THE VERTICAL C AXIS IS THE VALUE OF THE MEAN FOR THE POINTS IN Y C WITH THE SINGLE VALUE IN XSEQ ADDED TO Y. C C FOR THIS PLOT, ONLY ONE VARIABLE STATISTICS ARE C SUPPORTED (I.E., NO CORRELATION, ETC.). C C MEAN INFLUENCE CURVE C MIDM INFLUENCE CURVE C MEDI INFLUENCE CURVE C WINSORIZED MEAN INFLUENCE CURVE C BIWEIGHT LOCATION INFLUENCE CURVE C GEOMETRIC MEAN INFLUENCE CURVE C HARMONIC MEAN INFLUENCE CURVE C HODGES LEHMAN INFLUENCE CURVE C SD INFLUENCE CURVE C REL SD INFLUENCE CURVE C SD MEAN INFLUENCE CURVE C TRIMMED MEAN STANDARD ERROR INFLUENCE CURVE C VARI INFLUENCE CURVE C REL VARI INFLUENCE CURVE C VARI MEAN INFLUENCE CURVE C RANG INFLUENCE CURVE C GEOMETRIC STANDARD DEVIATION INFLUENCE CURVE C AAD INFLUENCE CURVE C MAD INFLUENCE CURVE C SN INFLUENCE CURVE C QN INFLUENCE CURVE C INTERQUARTILE RANGE INFLUENCE CURVE C BIWEIGHT SCALE INFLUENCE CURVE C BIWEIGHT MIDVARIANCE INFLUENCE CURVE C PERCENT BEND MIDVARIANCE INFLUENCE CURVE C WINSORIZED VARIANCE INFLUENCE CURVE C WINSORIZED SD INFLUENCE CURVE C MINI INFLUENCE CURVE C MAXI INFLUENCE CURVE C EXTREME INFLUENCE CURVE C SKEW INFLUENCE CURVE C KURT INFLUENCE CURVE C AUCR INFLUENCE CURVE C SDM INFLUENCE CURVE C AUCV INFLUENCE CURVE C RACV INFLUENCE CURVE C LOWH INFLUENCE CURVE C UPPH INFLUENCE CURVE C LOWQ INFLUENCE CURVE C UPPQ INFLUENCE CURVE C TRIM INFLUENCE CURVE C WINM INFLUENCE CURVE C MIDQ INFLUENCE CURVE C PERCENTILE INFLUENCE CURVE C QUANTILE INFLUENCE CURVE C QUANTILE STANDARD ERROR INFLUENCE CURVE C 1DEC INFLUENCE CURVE C 2DEC INFLUENCE CURVE C 3DEC INFLUENCE CURVE C 4DEC INFLUENCE CURVE C 5DEC INFLUENCE CURVE C 6DEC INFLUENCE CURVE C 7DEC INFLUENCE CURVE C 8DEC INFLUENCE CURVE C 9DEC INFLUENCE CURVE C SINE FREQUENCY INFLUENCE CURVE C SINE AMPLITUDE INFLUENCE CURVE C TAGUCHI SIGNAL-TO-NOISE INFLUENCE CURVES C CP INFLUENCE CURVE C CPL INFLUENCE CURVE C CPU INFLUENCE CURVE C CPK INFLUENCE CURVE C CPM INFLUENCE CURVE C CC INFLUENCE CURVE C CNPK INFLUENCE CURVE C PERCENT DEFECTIVE INFLUENCE CURVE C EXPECTED LOSS INFLUENCE CURVE C NORM PPCC INFLUENCE CURVE 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-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 REFERENCE--MOSTELLER AND TUKEY, "EXPLORATORY DATA ANALYSIS". C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2002/7 C ORIGINAL VERSION--JULY 2002. C UPDATED --AUGUST 2002. USE CMPSTA TO COMPUTE THE C STATISTIC. C UPDATED --APRIL 2003. ADD SN AND QN. REQUIRED C ADDITIONAL SCRATCH ARRAYS C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C EXTERNAL SUM EXTERNAL RANGE C CHARACTER*4 ICASPL CHARACTER*4 ICONT CHARACTER*4 IQUAME CHARACTER*4 IQUASE CHARACTER*4 ISUBRO CHARACTER*4 IBUGG3 CHARACTER*4 IERROR C CHARACTER*4 IWRITE C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C DIMENSION Y(*) DIMENSION Z(*) DIMENSION X(*) DIMENSION Y2(*) DIMENSION X2(*) DIMENSION D2(*) C DIMENSION TEMP(*) DIMENSION TEMPZ(*) DIMENSION XIDTEM(*) DIMENSION XTEMP1(*) DIMENSION XTEMP2(*) DIMENSION XTEMP3(*) DIMENSION ITEMP1(*) DIMENSION ITEMP2(*) DIMENSION ITEMP3(*) DIMENSION ITEMP4(*) DIMENSION ITEMP5(*) DIMENSION ITEMP6(*) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOHK.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='DPIN' ISUBN2='C2 ' C IWRITE='OFF' C I2=0 ISIZE2=0 C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(NY.GE.2)GOTO39 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,31) 31 FORMAT('***** ERROR IN DPINC2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,32) 32 FORMAT(' THE NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,33) 33 FORMAT(' MUST BE AT LEAST 2;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,34)NY 34 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 39 CONTINUE C C IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'INC2')GOTO90 WRITE(ICOUT,70) 70 FORMAT('AT THE BEGINNING OF DPINC2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71)IBUGG3,ISUBRO 71 FORMAT('IBUGG3,ISUBRO = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)NY,NX,ICASPL,NUMV2,ISIZE,ICONT 72 FORMAT('NY,NX,ICASPL,NUMV2,ISIZE,ICONT = ',2I8,2X,A4,I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') DO73I=1,MAX(NY,NX) WRITE(ICOUT,74)I,Y(I) 74 FORMAT('I, Y(I),X(I) = ',I8,2F15.7) CALL DPWRST('XXX','BUG ') 73 CONTINUE 90 CONTINUE C C ******************************************************** C ** STEP 1-- ** C ** SORT THE HORIZONTAL AXIS VARIABLE, EXTRACT ** C ** THE DISTINCT VALUES. ** C ******************************************************** C ISTEPN='1' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'INC2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C 150 CONTINUE IWRITE='OFF' CALL SORT(X,NX,X) CALL DISTIN(X,NX,IWRITE,X,NXDIST,IBUGG3,IERROR) C C ****************************************** C ** STEP 2-- ** C ** COMPUTE THE SPECIFIED STATISTIC ** C ** FOR EACH DISTINCT VALUE OF X ADDED ** C ** TO THE Y VARIABLE. ** C ****************************************** C ISTEPN='11' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'INC2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C J=0 C DO11000ISET=1,NXDIST C ILAST=NY+1 DO11011I=1,NY TEMP(I)=Y(I) 11011 CONTINUE TEMP(ILAST)=X(ISET) NS2=ILAST C CALL CMPSTA( 1TEMP,TEMPZ,XTEMP1,XTEMP2,XTEMP3,MAXNXT,NS2,NS2,NUMV2,ICASPL, 1ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1IQUAME,IQUASE, 1RIGHT, 1ISUBRO,IBUGG3,IERROR) C C --------------------------- C 79000 CONTINUE J=J+1 Y2(J)=RIGHT X2(J)=X(ISET) D2(J)=1.0 C 11000 CONTINUE N2=J NPLOTV=3 GOTO9000 C C ****************** C ** STEP 90-- ** C ** EXIT ** C ****************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'INC2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPINC2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGG3,ISUBRO 9012 FORMAT('IBUGG3,ISUBRO = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ICASPL,NX,NY,N2,IERROR 9013 FORMAT('ICASPL,NX,NY,N2,IERROR = ',A4,3I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NUMV2,ISIZE 9014 FORMAT('NUMV2,ISIZE = ',2I8) CALL DPWRST('XXX','BUG ') DO9020I=1,N2 WRITE(ICOUT,9021)I,Y2(I),X2(I),D2(I) 9021 FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2) CALL DPWRST('XXX','BUG ') 9020 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPIND2(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 INDUCTOR C WITH ONE END AT (X1,Y1) C AND THE OTHER END AT (X2,Y2). C NOTE--THE HEIGHT OF EACH LOOP IS PTEXHE. C THE WIDTH OF EACH LOOP IS PTEXWI. 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 C-----NON-COMMON VARIABLES------------------------------------- C CHARACTER*4 IFIG 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 CCCCC CHARACTER*4 ICOLF CCCCC CHARACTER*4 ICOLP CHARACTER*4 ICOL CHARACTER*4 IFLAG C DIMENSION PX(1000) DIMENSION PY(1000) CCCCC FEBRUARY 1994. ADD FOLLOWING SECTION INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOZ2.INC' EQUIVALENCE (G2RBAG(IGAR11),PX(1)) EQUIVALENCE (G2RBAG(IGAR12),PY(1)) CCCCC END CHANGE CCCCC DIMENSION PX3(1000) CCCCC DIMENSION PY3(1000) 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 IPATT=ILINPA(1) PTHICK=PLINTH(1) ICOL=ILINCO(1) C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'IND2')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPIND2--') 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 FIGURE ** C ********************************* C DELX=X2-X1 DELY=Y2-Y1 ALEN=0.0 TERM=(X2-X1)**2+(Y2-Y1)**2 IF(TERM.GT.0.0)ALEN=SQRT(TERM) IF(ABS(DELX).GE.0.00001)THETA=ATAN(DELY/DELX) IF(ABS(DELX).LT.0.00001.AND.DELY.GE.0.0)THETA=3.1415926/2.0 IF(ABS(DELX).LT.0.00001.AND.DELY.LT.0.0)THETA=-3.1415926/2.0 C AJXMIN=PTEXWI AJXDEL=PTEXWI AJYDEL=PTEXHE AJXMAX=ALEN-2*AJXDEL C XMIN=AJXMIN XDEL=AJXDEL YDEL=AJYDEL XMAX=AJXMAX C K=0 C X=0 Y=0 K=K+1 PX(K)=X1 PY(K)=Y1 C X=XMIN Y=0 CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) K=K+1 PX(K)=XP PY(K)=YP C AJX=AJXMIN-AJXDEL CCCCC DO1450JX=JXMIN,JXMAX,JXDEL 1440 CONTINUE AJX=AJX+AJXDEL IF(AJX.GT.AJXMAX)GOTO1460 C X=AJX Y=0 CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) AJX3=XP AJY3=YP C X=AJX+AJXDEL Y=0 CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) AJX4=XP AJY4=YP C CCCCC CALL DPIND3(AJX3,AJY3,AJX4,AJY4,IBUGD2,IERROR) CALL DPIND3(AJX3,AJY3,AJX4,AJY4,PX,PY,K,PX3,PY3,NP3, 1IFIG,IPATT,PTHICK,ICOL) C 1450 CONTINUE GOTO1440 C 1460 CONTINUE C CCCCC X=XMAX X=ALEN Y=0 CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) K=K+1 PX(K)=XP PY(K)=YP C NP=K C C *********************** C ** STEP 2-- ** C ** FILL THE FIGURE ** C ** (IF CALLED FOR) ** C *********************** C CCCCC IF(IREFSW(1).EQ.'OFF')GOTO2190 CCCCC IPATT=IREPTY(1) CCCCC PTHICK=PREPTH(1) CCCCC PXGAP=PREPSP(1) CCCCC PYGAP=PREPSP(1) CCCCC ICOLF=IREFCO(1) CCCCC ICOLP=IREPCO(1) CCCCC CALL DPFIRE(PX,PY,NP, CCCCC1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP)CCCCC C2190 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.'CIR2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPCIR2--') 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 DPIND3(X1,Y1,X2,Y2,PX,PY,K,PX3,PY3,NP3, 1IFIG,IPATT,PTHICK,ICOL) C C PURPOSE--DRAW A SEMI-CIRCLE FOR AN INDUCTOR C WITH ONE END OF THE DIAGONAL 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 C-----NON-COMMON VARIABLES----------------------------------------- C CHARACTER*4 IFIG CHARACTER*4 IPATT CHARACTER*4 ICOL CHARACTER*4 IFLAG C DIMENSION PX(*) DIMENSION PY(*) C CCCCC DIMENSION PX3(*) CCCCC DIMENSION PY3(*) 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.'IND3')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPIND3--') 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,55)K 55 FORMAT('K = ',I8) 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 DELX=X2-X1 DELY=Y2-Y1 ALEN=0.0 TERM=(X2-X1)**2+(Y2-Y1)**2 IF(TERM.GT.0.0)ALEN=SQRT(TERM) R=ALEN/2.0 IF(ABS(DELX).GE.0.00001)THETA=ATAN(DELY/DELX) IF(ABS(DELX).LT.0.00001.AND.DELY.GE.0.0)THETA=3.1415926/2.0 IF(ABS(DELX).LT.0.00001.AND.DELY.LT.0.0)THETA=-3.1415926/2.0 C X=0.0 Y=0.0 CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) K=K+1 PX(K)=XP PY(K)=YP C DO3010I=1,181,5 IREV=181-I+1 PHI2=IREV-1 PHI2=PHI2*(2.0*3.1415926)/360.0 X=R*COS(PHI2)+R Y=R*SIN(PHI2) CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) K=K+1 PX(K)=XP PY(K)=YP C IF(K.LE.490)GOTO3010 NP=K 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) K=0 K=K+1 PX(K)=XP PY(K)=YP C 3010 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'IND3')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPIND3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)K 9014 FORMAT('K = ',A4) CALL DPWRST('XXX','BUG ') DO9015I=1,K 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 DPINDU(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 INDUCTORS 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 2 ENDS C OF THE INDUCTOR. 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 INDUCTOR 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 INDUCTOR 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 INDUCTOR 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 --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 CCCCC ADD FOLLOWING LINE MARCH 1997. CHARACTER*4 IDFONT CCCCC ADD FOLLOWING LINE JULY 1997. CHARACTER*4 UNITSW CHARACTER*4 IDCOLO 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.'INDU')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPINDU--') 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='INDU' 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 DPINDU--') 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 INDUCTOR ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1136) 1136 FORMAT(' FROM THE POINT 20 20 ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1137) 1137 FORMAT(' TO 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(' INDUCTOR 20 20 40 60 ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143) 1143 FORMAT(' INDUCTOR 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 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 CALL DPIND2(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.'INDU')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPINDU--') 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) 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 DPINFU(IFUNC3,N3,IHNAME,IHNAM2,IUSE,IVSTAR,IVSTOP, 1NUMNAM,IANS,IWIDTH,IHLEFT,IHLEF2,ILISTL,NEWNAM,MAXN3, 1IFUNC,NUMCHF,MAXCHF,IBUGA3,IERROR) C C PURPOSE--INSERT (IF NECESSARY) THE FUNCTION C IN IFUNC3(.) INTO THE GENERAL C DATAPLOT INTERNAL FUNCTION TABLE IFUNC(.). C ALSO, UPDATE INTERNAL DATAPLOT C LISTS (IF NECESSARY). C C INPUT FUNCTION--IN IFUNC3(.) C OUTPUT FUNCTION--SOMEWHERE IN IFUNC(.). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--DECEMBER 1978. C UPDATED --JANUARY 1979. C UPDATED --JULY 1981. C UPDATED --MAY 1982. C UPDATED --DECEMBER 1993. FIX BUG STATEMENT C MAXCHF => 120 C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IFUNC3 CHARACTER*4 IHNAME CHARACTER*4 IHNAM2 CHARACTER*4 IUSE CHARACTER*4 IANS CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CHARACTER*4 IFUNC CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 NEWNAM C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C DIMENSION IHNAME(*) DIMENSION IHNAM2(*) DIMENSION IUSE(*) DIMENSION IVSTAR(*) DIMENSION IVSTOP(*) C DIMENSION IANS(*) C DIMENSION IFUNC3(*) DIMENSION IFUNC(*) 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='DPIN' ISUBN2='FU ' C IERROR='NO' C IDEL=0 C C ****************************************** C ** INSERT A FUNCTION ** C ** INTO THE GENERAL DATAPLOT FUNCTION ** C ** TABLE IFUNC(.). ** C ** MAKE ADJUSTMENTS TO THE ** C ** INTERNAL DATAPLOT LISTS. ** C ****************************************** C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPINFU--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)NUMNAM,ILISTL,NEWNAM 53 FORMAT('NUMNAM,ILISTL,NEWNAM = ',2I8,2X,A4) CALL DPWRST('XXX','BUG ') DO55I=1,NUMNAM WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),IVSTOP(I) 56 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),IVSTOP(I)=', 1I8,2X,A4,A4,2X,A4,I8,I8) CALL DPWRST('XXX','BUG ') 55 CONTINUE WRITE(ICOUT,57)N3,NUMCHF,MAXN3,MAXCHF 57 FORMAT('N3,NUMCHF,MAXN3,MAXCHF = ',4I8) CALL DPWRST('XXX','BUG ') IF(N3.GE.1)WRITE(ICOUT,59)(IFUNC3(I),I=1,MIN(N3,120)) 59 FORMAT('IFUNC3(.) = ',120A1) IF(N3.GE.1)CALL DPWRST('XXX','BUG ') CCCCC THE FOLLOWING LINE WAS CHANGED DECEMBER 1993 CCCCC WRITE(ICOUT,60)(IFUNC(I),I=1,MAXCHF) WRITE(ICOUT,60)(IFUNC(I),I=1,MIN(MAXCHF,120)) 60 FORMAT('IFUNC(.) = ',120A1) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ********************************** C ** STEP 1-- ** C ** INITIALIZE SOME VARIABLES. ** C ********************************** C ISTEPN='1' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IERROR='NO' NUMCH0=NUMCHF C C ***************************************************** C ** STEP 2-- ** C ** DETERMINE IF THE ADDITION OF THE NEW FUNCTION ** C ** TO THE INTERNAL DATAPLOT TABLE ** C ** WILL OVERFLOW THE TABLE (TYPICALLY ** C ** THERE IS A MAXCHF CHARACTER LIMIT ** C ** FOR THE SUM TOTAL OVER ALL FUNCTIONS). ** C ***************************************************** C ISTEPN='2' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NEWNAM.EQ.'YES')GOTO2100 GOTO2200 C 2100 CONTINUE N0TEST=NUMCHF+N3 GOTO2300 C 2200 CONTINUE IMIN=IVSTAR(ILISTL) IMAX=IVSTOP(ILISTL) N3OLD=IMAX-IMIN+1 IDEL=N3-N3OLD N0TEST=NUMCHF+IDEL GOTO2300 C 2300 CONTINUE IF(N0TEST.LE.MAXCHF)GOTO2390 WRITE(ICOUT,2301) 2301 FORMAT('***** ERROR IN DPINFU--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2302) 2302 FORMAT(' ERROR CAUSED IN ENTERING') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2303) 2303 FORMAT(' THE FUNCTION INTO THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2304) 2304 FORMAT(' INTERNAL DATAPLOT FUNCTION TABLE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2305) 2305 FORMAT(' THE TOTAL NUMBER OF CHARACTERS IN THAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2306)MAXCHF 2306 FORMAT(' TABLE (FOR ALL FUNCTIONS) MAY NOT EXCEED ', 1I8,'.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2307) 2307 FORMAT(' SUCH AN OVERFLOW CONDITION HAS JUST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2308) 2308 FORMAT(' BEEN ENCOUNTERED.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2309) 2309 FORMAT(' THE FUNCTION TABLE HAS BEEN RESET') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2310) 2310 FORMAT(' TO ITS STATUS BEFORE THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2311) 2311 FORMAT(' LAST FUNCTION WAS ATTEMPTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2312) 2312 FORMAT(' TO BE ENTERED.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2313) 2313 FORMAT(' THE TOTAL NUMBER OF CHARACTERS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2314) 2314 FORMAT(' IN THE FUNCTION TABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2315)NUMCHF 2315 FORMAT(' HAS BEEN RESET TO ITS PREVIOUS VALUE = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2316) 2316 FORMAT(' THE NUMBER OF CHARACTERS IN THE FUNCTION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2317)N3 2317 FORMAT(' THAT WAS ATTEMPTED TO BE ENTERED = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2318) 2318 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2319)(IANS(I),I=1,MIN(IWIDTH,100)) 2319 FORMAT(' ',100A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2321) 2321 FORMAT(' SUGGESTED POSSIBLE SOLUTION--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2322) 2322 FORMAT(' REDEFINE SOME OF THE OTHER ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2323) 2323 FORMAT(' ALREADY-DEFINED FUNCTIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2324) 2324 FORMAT(' THAT MAY NO LONGER BE NEEDED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2325) 2325 FORMAT(' SO THAT THEY ARE ONLY 1 CHARACTER LONG') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2326) 2326 FORMAT(' EXAMPLE--LET FUNCTION F3=C') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 2390 CONTINUE C C *************************************************** C ** STEP 3-- ** C ** MOVE THE SEGMENT OF THE STRING IN IFUNC(.) ** C ** WHICH IS BEYOND THE FUNCTION OF INTEREST ** C ** OVER AN APPROPRIATE NUMBER OF SPACES. ** C *************************************************** C ISTEPN='3' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NEWNAM.EQ.'YES')GOTO3110 GOTO3120 C 3110 CONTINUE ISTART=NUMCHF+1 ISTOP=ISTART+N3-1 GOTO3190 C 3120 CONTINUE ISTART=IVSTAR(ILISTL) ISTOP=ISTART+N3-1 GOTO3190 C 3190 CONTINUE C IF(NEWNAM.EQ.'YES')GOTO3290 KMIN=ISTOP+1 KMAX=NUMCHF+IDEL C IF(IDEL.EQ.0)GOTO3290 IF(IDEL.GT.0)GOTO3210 IF(IDEL.LT.0)GOTO3220 C 3210 CONTINUE DO3215K=KMIN,KMAX KREV=KMAX-K+KMIN LREV=KREV-IDEL IFUNC(KREV)=IFUNC(LREV) 3215 CONTINUE GOTO3290 C 3220 CONTINUE DO3225K=KMIN,KMAX L=K-IDEL IFUNC(K)=IFUNC(L) 3225 CONTINUE C 3290 CONTINUE C C ************************************************** C ** STEP 4-- ** C ** MOVE THE NEW FUNCTION INTO THE APPROPRIATE ** C ** PLACE IN IFUNC(.). ** C ************************************************** C ISTEPN='4' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C L=0 DO4200K=ISTART,ISTOP L=L+1 IFUNC(K)=IFUNC3(L) 4200 CONTINUE 4290 CONTINUE C C ************************************ C ** STEP 5-- ** C ** REDEFINE NUMCHF = THE UPDATED ** C ** LENGTH OF IFUNC(.). ** C ************************************ C ISTEPN='5' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMCHF=N0TEST C C ************************************************* C ** STEP 6-- ** C ** MAKE THE ADJUSTMENTS TO THE INTERNAL LIST ** C ************************************************* C ISTEPN='6' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NEWNAM.EQ.'YES')GOTO6100 GOTO6200 C 6100 CONTINUE IHNAME(ILISTL)=IHLEFT IHNAM2(ILISTL)=IHLEF2 IUSE(ILISTL)='F' IVSTAR(ILISTL)=ISTART IVSTOP(ILISTL)=ISTOP NUMNAM=NUMNAM+1 GOTO9000 C 6200 CONTINUE N3OLD=IVSTOP(ILISTL)-IVSTAR(ILISTL)+1 IDEL=N3-N3OLD C DO6210I=1,NUMNAM IF(IUSE(I).EQ.'F')GOTO6220 GOTO6210 6220 CONTINUE IF(IVSTAR(I).GT.ISTART)IVSTAR(I)=IVSTAR(I)+IDEL IF(IVSTOP(I).GE.ISTART)IVSTOP(I)=IVSTOP(I)+IDEL 6210 CONTINUE GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPINFU--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3 9012 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NEWNAM,NUMNAM 9013 FORMAT('NEWNAM,NUMNAM = ',A4,I8) CALL DPWRST('XXX','BUG ') DO9015I=1,NUMNAM WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),IVSTOP(I) 9016 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),IVSTOP(I)=', 1I8,2X,A4,A4,2X,A4,I8,I8) CALL DPWRST('XXX','BUG ') 9015 CONTINUE WRITE(ICOUT,9017)NUMCH0 9017 FORMAT('NUMCH0 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9018)N3,NUMCHF,MAXN3,MAXCHF 9018 FORMAT('N3,NUMCHF,MAXN3,MAXCHF = ',4I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9019)(IFUNC3(I),I=1,MIN(N3,120)) 9019 FORMAT('IFUNC3(.) = ',120A1) CALL DPWRST('XXX','BUG ') CCCCC THE FOLLOWING LINE WAS CHANGED DECEMBER 1993 CCCCC WRITE(ICOUT,9020)(IFUNC(I),I=1,MAXCHF) WRITE(ICOUT,9020)(IFUNC(I),I=1,MIN(MAXCHF,120)) 9020 FORMAT('IFUNC(.) = ',120A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)IERROR 9021 FORMAT('IERROR = ',A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPINLE(ILEGN2,ISTH,N2,ILEGNA,ILEGST,ILEGSP, 1NUMLEG,MAXLEG,ILEGTE,NCLEG,MXCLEG,IANS,IWIDTH,IBUGIL,IERROR) C C PURPOSE--INSERT(IF NECESSARY) THE HOLLERITH LEGEND C IN ISTH(.) C INTO (RESPECTIVELY) THE PACKED C INTERNAL DATAPLOT TABLES ILEGTE(.) C ALSO, UPDATE INTERNAL DATAPLOT LISTS C ILEGNA(.), ILEGST(.), AND ILEGSP(.). C A CHECK FOR N2 BEING POSITIVE IS DONE HEREIN. C C NOTE--IT IS ASSUMED IN ALL CASES (EVEN FOR C A BLANKED-OUT LEGEND) THAT THE NUMBER C OF CHARACTERS IN THE LEGEND IS AT LEAST 1; C (THAT IS, THE INPUT N2 IS 1 OR LARGER). C C INPUT LEGENDS --IN ISTH(.) C OUTPUT LEGENDS --SOMEWHERE IN ILEGTE(.) C C ILEGN2 = NAME FOR THE INPUT LEGEND. C ISTH = VECTOR CONTAINING INPUT LEGEND STRING (IN HOLLERITH) C N2 = LENGTH OF INPUT LEGEND STRING. C ILEGNA = TABLE OF EXISTING LEGEND NAMES. C ILEGST = TABLE OF EXISTING START POSITIONS IN ILEGTE. C ILEGSP = TABLE OF EXISTING STOP POSITIONS IN ILEGTE. C NUMLEG = NUMBER OF EXISTING LEGENDS. C MAXLEG = MAXIMUM NUMBER OF ALLOWABLE LEGENDS. C ILEGTE = VECTOR OF PACKED LEGENDS (HOLLERITH) WHERE FINAL STORAGE IS DONE C NCLEG = NUMBER OF PACKED CHARACTERS IN ILEGTE(.) C MXCLEG = MAX NUMBER OF ALLOWABLE CHARACTERS IN ILEGTE(.) 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--82/7 C ORIGINAL VERSION--MARCH 1979. C UPDATED --SEPTEMBER 1980. C UPDATED --JANUARY 1981. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C UPDATED --JUNE 1994. BUG FIX C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ILEGN2 CHARACTER*4 ISTH CHARACTER*4 ILEGNA CHARACTER*4 ILEGTE CHARACTER*4 IANS CHARACTER*4 IBUGIL CHARACTER*4 IERROR C CHARACTER*4 NEWNAM C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C DIMENSION ISTH(*) DIMENSION ILEGNA(*) DIMENSION ILEGST(*) DIMENSION ILEGSP(*) DIMENSION ILEGTE(*) DIMENSION IANS(*) 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='DPIN' ISUBN2='LE ' C ILISTL=0 IDEL=0 C NEWNAM='UNKN' C C ****************************************** C ** INSERT A LEGEND ** C ** INTO THE GENERAL DATAPLOT LEGEND ** C ** TABLES ILEGTE(.) ** C ** MAKE ADJUSTMENTS TO THE ** C ** INTERNAL DATAPLOT LISTS. ** C ****************************************** C IF(IBUGIL.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71) 71 FORMAT('***** AT THE BEGINNING OF DPINLE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)ILEGN2,N2 72 FORMAT('ILEGN2,N2 = ',A4,3X,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,73)(ISTH(I),I=1,N2) 73 FORMAT('ISTH(.) = ',55A2) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,75)NCLEG,MXCLEG 75 FORMAT('NCLEG,MXCLEG = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,76)(ILEGTE(I),I=1,NCLEG) 76 FORMAT('ILEGTE(.) = ',55A2) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,81)NUMLEG,MAXLEG 81 FORMAT('NUMLEG,MAXLEG = ',2I8) CALL DPWRST('XXX','BUG ') DO82I=1,NUMLEG WRITE(ICOUT,83)I,ILEGNA(I),ILEGST(I),ILEGSP(I) 83 FORMAT('I,ILEGNA(I),ILEGST(I),ILEGSP(I) = ',I4,3X,A4,I8,I8) CALL DPWRST('XXX','BUG ') 82 CONTINUE 90 CONTINUE C C ********************************** C ** STEP 1-- ** C ** INITIALIZE SOME VARIABLES. ** C ********************************** C ISTEPN='1' IF(IBUGIL.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IERROR='NO' NUMCH0=NCLEG C IF(N2.GE.1)GOTO190 C WRITE(ICOUT,111) 111 FORMAT('***** INTERNAL ERROR IN DPLEG--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT LENGTH N2 OF THE STRING IS ', 1'NON-POSITIVE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113)N2 113 FORMAT(' N2 = ',I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 190 CONTINUE C C ************************************ C ** STEP 2-- ** C ** DETERMINE IF THE LEGEND NAME ** C ** ALREADY EXISTS IN THE TABLE. ** C ************************************ C ISTEPN='2' IF(IBUGIL.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NEWNAM='YES' IF(NUMLEG.LE.0)GOTO250 DO210I=1,NUMLEG I2=I IF(ILEGN2.EQ.ILEGNA(I))GOTO220 210 CONTINUE GOTO250 C 220 CONTINUE NEWNAM='NO' ILISTL=I2 GOTO290 C 250 CONTINUE NEWNAM='YES' ILISTL=NUMLEG+1 GOTO290 C 290 CONTINUE C C *********************************************************** C ** STEP 3-- ** C ** FOR THE CASE WHEN HAVE A NEW NAME, ** C ** DETERMINE IF THIS NEW NAME ** C ** WILL OVERFLOW THE ALLOWABLE NUMBER OF LEGEND NAMES ** C ** IN TABLE ILEGNA(.). ** C *********************************************************** C ISTEPN='3' IF(IBUGIL.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NEWNAM.EQ.'NO')GOTO390 IF(ILISTL.LE.MAXLEG)GOTO390 C WRITE(ICOUT,301) 301 FORMAT('***** ERROR IN DPINLE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,302) 302 FORMAT(' ERROR CAUSED IN ENTERING') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,303) 303 FORMAT(' THE LEGEND INTO THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,304) 304 FORMAT(' INTERNAL DATAPLOT LEGEND TABLE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,305) 305 FORMAT(' THE TOTAL NUMBER OF LEGENDS IN THAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,306)MAXLEG 306 FORMAT(' TABLE (FOR ALL LEGENDS) MAY NOT EXCEED ', 1I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,307) 307 FORMAT(' SUCH AN OVERFLOW CONDITION HAS JUST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,308) 308 FORMAT(' BEEN ENCOUNTERED.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,309) 309 FORMAT(' THE LEGEND TABLE HAS JUST BEEN RESET') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,310) 310 FORMAT(' TO ITS STATUS BEFORE THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,311) 311 FORMAT(' LAST LEGEND WAS ATTEMPTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,312) 312 FORMAT(' TO BE ENTERED.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,313) 313 FORMAT(' THE TOTAL NUMBER OF LEGENDS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,314) 314 FORMAT(' IN THE LEGEND TABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,315)NUMLEG 315 FORMAT(' HAS JUST BEEN RESET TO ITS PREVIOUS VALUE =',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,318) 318 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,319)(IANS(I),I=1,IWIDTH) 319 FORMAT(' ',100A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,321) 321 FORMAT(' SUGGESTED POSSIBLE SOLUTION--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,322) 322 FORMAT(' REDEFINE SOME OF THE OTHER ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,323) 323 FORMAT(' ALREADY-DEFINED LEGENDS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,324) 324 FORMAT(' THAT MAY NO LONGER BE NEEDED.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 390 CONTINUE C C ***************************************************** C ** STEP 4-- ** C ** DETERMINE IF THE ADDITION OF THE NEW LEGEND ** C ** STRING TO THE INTERNAL DATAPLOT TABLES ** C ** ILEGTE(.) ** C ** WILL OVERFLOW THE TABLE (TYPICALLY ** C ** THERE IS A 500 CHARACTER LIMIT ** C ** FOR THE SUM TOTAL OVER ALL LEGENDS). ** C ***************************************************** C ISTEPN='4' IF(IBUGIL.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NEWNAM.EQ.'YES')GOTO2100 GOTO2200 C 2100 CONTINUE N0TEST=NCLEG+N2 GOTO2300 C 2200 CONTINUE IMIN=ILEGST(ILISTL) IMAX=ILEGSP(ILISTL) N2OLD=IMAX-IMIN+1 IDEL=N2-N2OLD N0TEST=NCLEG+IDEL GOTO2300 C 2300 CONTINUE IF(N0TEST.LE.MXCLEG)GOTO2390 WRITE(ICOUT,2301) 2301 FORMAT('***** ERROR IN DPINLE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2302) 2302 FORMAT(' ERROR CAUSED IN ENTERING') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2303) 2303 FORMAT(' THE LEGEND INTO THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2304) 2304 FORMAT(' INTERNAL DATAPLOT LEGEND TABLE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2305) 2305 FORMAT(' THE TOTAL NUMBER OF CHARACTERS IN THAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2306)MXCLEG 2306 FORMAT(' TABLE (FOR ALL LEGEND S) MAY NOT EXCEED ', 1I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2307) 2307 FORMAT(' SUCH AN OVERFLOW CONDITION HAS JUST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2308) 2308 FORMAT(' BEEN ENCOUNTERED.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2309) 2309 FORMAT(' THE LEGEND TABLE HAS JUST BEEN RESET') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2310) 2310 FORMAT(' TO ITS STATUS BEFORE THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2311) 2311 FORMAT(' LAST LEGEND WAS ATTEMPTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2312) 2312 FORMAT(' TO BE ENTERED.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2313) 2313 FORMAT(' THE TOTAL NUMBER OF CHARACTERS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2314) 2314 FORMAT(' IN THE LEGEND TABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2315)NCLEG 2315 FORMAT(' HAS JUST BEEN RESET TO ITS PREVIOUS VALUE =',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2316) 2316 FORMAT(' THE NUMBER OF CHARACTERS IN THE LEGEND ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2317)N2 2317 FORMAT(' THAT WAS ATTEMPTED TO BE ENTERED = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2318) 2318 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2319)(IANS(I),I=1,IWIDTH) 2319 FORMAT(' ',100A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2321) 2321 FORMAT(' SUGGESTED POSSIBLE SOLUTION--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2322) 2322 FORMAT(' REDEFINE (SHORTEN) SOME OF THE OTHER ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2323) 2323 FORMAT(' ALREADY-DEFINED LEGENDS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2324) 2324 FORMAT(' THAT MAY NO LONGER BE NEEDED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2325) 2325 FORMAT(' SO THAT THEY ARE ONLY 1 CHARACTER LONG') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2326) 2326 FORMAT(' EXAMPLE--LEGEND 4 ') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 2390 CONTINUE C C *************************************************** C ** STEP 5-- ** C ** MOVE THE SEGMENT OF THE STRING IN ILEGTE(.) ** C ** WHICH IS BEYOND THE LEGEND OF INTEREST ** C ** OVER AN APPROPRIATE NUMBER OF SPACES. ** C *************************************************** C ISTEPN='5' IF(IBUGIL.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NEWNAM.EQ.'YES')GOTO3110 GOTO3120 C 3110 CONTINUE ISTART=NCLEG+1 ISTOP=ISTART+N2-1 GOTO3190 C 3120 CONTINUE ISTART=ILEGST(ILISTL) ISTOP=ISTART+N2-1 GOTO3190 C 3190 CONTINUE C IF(NEWNAM.EQ.'YES')GOTO3290 KMIN=ISTOP+1 KMAX=NCLEG+IDEL CCCCC JUNE 1994. FOLLOWING LINE CAUSED SPURIOUS CHARACTERS IF CCCCC HIGHER LEGENDS BLANKED OUT, EARLIER LEGEND LONGER THAN THE CCCCC ORIGINAL. CCCCC IF(KMIN.GT.NCLEG)GOTO3290 IF(IDEL.LE.0)GOTO3210 GOTO3220 C 3210 CONTINUE NCLEGP=NCLEG+1 DO3211K=KMIN,KMAX L=K-IDEL IF(L.GE.NCLEGP)GOTO3211 ILEGTE(K)=ILEGTE(L) 3211 CONTINUE GOTO3290 C 3220 CONTINUE DO3221K=KMIN,KMAX KREV=KMAX-K+KMIN L=KREV-IDEL IF(L.LE.0)GOTO3221 ILEGTE(KREV)=ILEGTE(L) 3221 CONTINUE GOTO3290 C 3290 CONTINUE C C ************************************************** C ** STEP 6-- ** C ** MOVE THE NEW LEGEND INTO THE APPROPRIATE ** C ** PLACE IN ILEGTE(.). ** C ************************************************** C ISTEPN='6' IF(IBUGIL.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C L=0 DO4200K=ISTART,ISTOP L=L+1 ILEGTE(K)=ISTH(L) 4200 CONTINUE 4290 CONTINUE C C ************************************ C ** STEP 7-- ** C ** REDEFINE NCLEG = THE UPDATED ** C ** LENGTH OF ILEGTE(.). ** C ************************************ C ISTEPN='7' IF(IBUGIL.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NCLEG=N0TEST C C ************************************************* C ** STEP 8-- ** C ** MAKE THE ADJUSTMENTS TO THE INTERNAL LIST ** C ************************************************* C ISTEPN='8' IF(IBUGIL.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NEWNAM.EQ.'YES')GOTO6100 GOTO6200 C 6100 CONTINUE ILEGNA(ILISTL)=ILEGN2 ILEGST(ILISTL)=ISTART ILEGSP(ILISTL)=ISTOP NUMLEG=NUMLEG+1 GOTO9000 C 6200 CONTINUE N2OLD=ILEGSP(ILISTL)-ILEGST(ILISTL)+1 IDEL=N2-N2OLD C DO6210I=1,NUMLEG IF(ILEGST(I).GT.ISTART)ILEGST(I)=ILEGST(I)+IDEL IF(ILEGSP(I).GE.ISTART)ILEGSP(I)=ILEGSP(I)+IDEL 6210 CONTINUE GOTO9000 C C **************** C ** STEP 90-- ** C ** EXIT. ** C **************** C 9000 CONTINUE C ISTEPN='9' IF(IBUGIL.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGIL.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPINLE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)N2,N2OLD,IDEL,KMIN,KMAX 9012 FORMAT('N2,N2OLD,IDEL,KMIN,KMAX = ',5I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NCLEG,MXCLEG,NUMCH0 9013 FORMAT('NCLEG,MXCLEG,NUMCH0 = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)(ILEGTE(I),I=1,NCLEG) 9014 FORMAT('ILEGTE(.) = ',55A2) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)NEWNAM,ILISTL,NUMLEG 9015 FORMAT('NEWNAM,ILISTL,NUMLEG = ',A4,2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)NEWNAM,NUMLEG 9021 FORMAT('NEWNAM,NUMLEG = ',A4,3X,I8) CALL DPWRST('XXX','BUG ') DO9022I=1,NUMLEG WRITE(ICOUT,9023)I,ILEGNA(I),ILEGST(I),ILEGSP(I) 9023 FORMAT('I,ILEGNA(I),ILEGST(I),ILEGSP(I) = ',I4,3X,A4,I8,I8) CALL DPWRST('XXX','BUG ') 9022 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPINPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1MAXNPP, 1IBUGG3,IBUGQ,IFOUND,IERROR) C C PURPOSE--FORM AN INTERACTION PLOT, I.E. C INTERACTION PLOT Y X1 X2 C IS A PLOT OF Y VERSUS X1*X2 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--99/10 C ORIGINAL VERSION--OCTOBER 1999. 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 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 ICASEQ CHARACTER*4 IERRO4 C PARAMETER(MAXY=25) C DIMENSION IVARN1(MAXY) DIMENSION IVARN2(MAXY) DIMENSION ILIS(MAXY) DIMENSION ICOL(MAXY) C CCCCC CHARACTER*4 IH11 CCCCC CHARACTER*4 IH12 CHARACTER*4 IHRIGH CHARACTER*4 IHRIG2 CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ISUBRO CHARACTER*4 ISTEPN CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 IVARN1 CHARACTER*4 IVARN2 C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.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 ISUBN1='DPIN' ISUBN2='PL ' IFOUND='YES' IAND2='NO' ICASPL='INTE' IBUGG2=IBUGG3 C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C 1000 CONTINUE C IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'INPL')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPINPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NPLOTV,NPLOTP,NS 52 FORMAT('NPLOTV,NPLOTP,NS = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASPL,IAND1,IAND2 53 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IBUGG3,IBUGQ 54 FORMAT('IBUGG3,IBUGQ = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)IFOUND,IERROR 55 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)MAXNPP 56 FORMAT('MAXNPP = ',I8) CALL DPWRST('XXX','BUG ') 90 CONTINUE C ISTEPN='10' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'INPL') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 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.'INPL') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINN2=2 MINNA=2 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C ***************************************** C ** STEP 11-- ** C ** CHECK TO SEE THE TYPE SUBCASE ** C ** (BASED ON THE QUALIFIER)-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='11' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'INPL') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO1180 DO1100J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ')GOTO1110 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ')GOTO1110 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ')GOTO1120 1100 CONTINUE GOTO1180 1110 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO1190 1120 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO1190 C 1180 CONTINUE GOTO1190 C 1190 CONTINUE IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'INPL')THEN WRITE(ICOUT,1191)NUMARG,ILOCQ,ICASEQ 1191 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') ENDIF C C ************************************************** C ** STEP 12-- ** C ** DETERMINE THE NUMBER OF VARIABLES ** C ** TO BE INCLUDED AS PLOT COMPONENTS ** C ** IF THE TO FEATURE IS USED IN THE ** C ** ARGUMENT LIST, TRANSLATE THE TO TO ** C ** EXPLICIT VARIABLE NAMES ** C ************************************************** C ISTEPN='12' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'INPL') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C JMIN=1 JMAX=ILOCQ-1 IF(JMAX.GT.NUMARG)JMAX=NUMARG CALL EXTVAR(IHARG,IHARG2,NUMARG,JMIN,JMAX,MAXY, 1IHNAME,IHNAM2,IUSE,NUMNAM, 1IVARN1,IVARN2,NUMVAR,IBUGG3,ISUBRO,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C 1290 CONTINUE C C *************************************** C ** STEP 13-- ** C ** CHECK THE VALIDITY OF EACH ** C ** OF THE VARIABLES. ** C ** ALSO CHECK TO ASSURE THAT EACH ** C ** OF THE VARIABLES HAS AT LEAST ** C ** 2 OBSERVATIONS. ** C *************************************** C ISTEPN='13' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'INPL') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IFLAG=0 DO1300I=1,NUMVAR C IHRIGH=IVARN1(I) IHRIG2=IVARN2(I) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHRIGH,IHRIG2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C NRIGHT=IN(ILOCV) IF(I.EQ.1)THEN NTEMP=NRIGHT ELSE IF(NRIGHT.NE.NTEMP)IFLAG=1 ENDIF ILIS(I)=ILOCV ICOL(I)=IVALUE(ILOCV) IF(NRIGHT.GE.MINN2)GOTO1390 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1311) 1311 FORMAT('***** ERROR IN DPSPMA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1312) 1312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS FOR WHICH AN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1321) 1321 FORMAT(' INTERACTION PLOT WAS TO HAVE BEEN FORMED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1326)MINN2 1326 FORMAT(' MUST BE ',I8,' OR LARGER; SUCH WAS NOT THE CASE', 1' HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1328) 1328 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1329)(IANS(J),J=1,MIN(IWIDTH,100)) 1329 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1390 CONTINUE C 1300 CONTINUE C C C ****************************************************** C ** STEP 1.4-- ** C ** CHECK THAT VARIABLES HAVE THE SAME NUMBER OF ** C ** ELEMENTS. ** C ****************************************************** C 1400 CONTINUE ISTEPN='1.4' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'INPL') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IFLAG.EQ.0)GOTO1490 C 1410 CONTINUE WRITE(ICOUT,1411) 1411 FORMAT('***** ERROR IN DPINPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1413) 1413 FORMAT(' THE NUMBER OF OBSERVATIONS IN ALL VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1414) 1414 FORMAT(' MUST BE THE SAME; SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') DO1417I=1,NUMVAR I2=ILIS(I) WRITE(ICOUT,1416)IVARN1(I2),IVARN2(I2),IN(I2) 1416 FORMAT(' VARIABLE ',A4,A4,' HAS ',I8,' OBSERVATIONS;') CALL DPWRST('XXX','BUG ') 1417 CONTINUE WRITE(ICOUT,1420) 1420 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1421)(IANS(I),I=1,MIN(IWIDTH,100)) 1421 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 1490 CONTINUE C C ********************************************* C ** STEP 13-- ** C ** FORM THE VECTOR ISUB(.) ** C ** DEPENDING ON THE TYPE OF CASE ** C ** FOR THE QUALIFIER. ** C ********************************************* C ISTEPN='13' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'INPL') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NLOCAL=NRIGHT IF(ICASEQ.EQ.'FULL')GOTO1310 IF(ICASEQ.EQ.'SUBS')GOTO1320 IF(ICASEQ.EQ.'FOR')GOTO1330 C 1310 CONTINUE DO1315I=1,NLOCAL ISUB(I)=1 1315 CONTINUE NQ=NLOCAL NS=1 GOTO1350 C 1320 CONTINUE NIOLD=NLOCAL CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERRO4) NQ=NIOLD GOTO1350 C 1330 CONTINUE NIOLD=NLOCAL CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERRO4) NQ=NFOR IF(NS.GT.NIOLD)NS=NIOLD GOTO1350 C 1350 CONTINUE C C ******************************************************* C ** STEP 16-- ** C ** FORM THE PLOT COORIDINATES ** C ******************************************************* C ISTEPN='15.2' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C 1519 CONTINUE C L=0 C DO1520I=1,NLOCAL IF(ISUB(I).EQ.0)GOTO1520 L=L+1 C IF(L.LE.MAXNPP)GOTO1529 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1521) 1521 FORMAT('***** ERROR IN DPINPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1523) 1523 FORMAT(' THE NUMBER OF PLOT POINTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1524)MAXNPP 1524 FORMAT(' HAS JUST EXCEEDED ',I8,' *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1525)I,NLOCAL,L,MAXN,MAXNPP,NPLOTP 1525 FORMAT('I,NLOCAL,L,MAXN,MAXNPP,NPLOTP = ',6I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1526)IAND1,IAND2,IFOUND,IERROR 1526 FORMAT('IAND1,IAND2,IFOUND,IERROR = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') GOTO9000 1529 CONTINUE C IVAV=ICOL(1) IJ=MAXN*(IVAV-1)+I IF(IVAV.LE.MAXCOL)Y(L)=V(IJ) IF(IVAV.EQ.MAXCP1)Y(L)=PRED(I) IF(IVAV.EQ.MAXCP2)Y(L)=RES(I) IF(IVAV.EQ.MAXCP3)Y(L)=YPLOT(I) IF(IVAV.EQ.MAXCP4)Y(L)=XPLOT(I) IF(IVAV.EQ.MAXCP5)Y(L)=X2PLOT(I) IF(IVAV.EQ.MAXCP6)Y(L)=TAGPLO(I) X(L)=1.0 C IF(NUMVAR.LT.2)GOTO1520 DO1530K=2,NUMVAR IVAV=ICOL(K) IJ=MAXN*(IVAV-1)+I IF(IVAV.LE.MAXCOL)ATEMP=V(IJ) IF(IVAV.EQ.MAXCP1)ATEMP=PRED(I) IF(IVAV.EQ.MAXCP2)ATEMP=RES(I) IF(IVAV.EQ.MAXCP3)ATEMP=YPLOT(I) IF(IVAV.EQ.MAXCP4)ATEMP=XPLOT(I) IF(IVAV.EQ.MAXCP5)ATEMP=X2PLOT(I) IF(IVAV.EQ.MAXCP6)ATEMP=TAGPLO(I) X(L)=X(L)*ATEMP 1530 CONTINUE C D(L)=1.0 NPLOTP=L C 1520 CONTINUE NPLOTV=2 GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPINPL--') 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,NLOCAL,ICASPL,IAND1,IAND2 9013 FORMAT('NPLOTV,NPLOTP,NLOCAL,ICASPL,IAND1,IAND2 = ', 1I8,I8,I8,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IBUGG3,IBUGQ 9014 FORMAT('IBUGG3,IBUGQ = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)IFOUND,IERROR 9015 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)MAXNPP 9016 FORMAT('MAXNPP = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9020) 9020 FORMAT('I,Y(.),X(.),D(.),ISUB(.)--') CALL DPWRST('XXX','BUG ') DO9021I=1,NPLOTP WRITE(ICOUT,9022)I,Y(I),X(I),D(I),ISUB(I) 9022 FORMAT(I8,F15.7,F15.7,F15.7,I8) CALL DPWRST('XXX','BUG ') 9021 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPINT2(MODEL,NUMCHA,PARAM,IPARN,IPARN2,NUMPV, 1IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD, 1IVARN,IVARN2,NUMVAR,XMIN,XMAX,XINT, 1IBUGA3,IBUGCO,IBUGEV,IERROR) C C PURPOSE--COMPUTE THE INTEGRAL OF A FUNCTION C FROM THE LIMITS XMIN TO XMAX. 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 --JULY 1981. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 MODEL CHARACTER*4 IPARN CHARACTER*4 IPARN2 CHARACTER*4 IANGLU CHARACTER*4 ITYPEH CHARACTER*4 IW21HO CHARACTER*4 IW22HO CHARACTER*4 IVARN CHARACTER*4 IVARN2 CHARACTER*4 IBUGA3 CHARACTER*4 IBUGCO CHARACTER*4 IBUGEV CHARACTER*4 IERROR C CHARACTER*4 IH CHARACTER*4 IH2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DOUBLE PRECISION W,Z DOUBLE PRECISION DMIN,DMAX,DNUMSE,DINT,DJ,DELTA2,DMIN2,DMAX2 DOUBLE PRECISION DB0,DB1,DSUM2,DX,DY,DINT2 C DIMENSION MODEL(*) DIMENSION PARAM(*) DIMENSION IPARN(*) DIMENSION IPARN2(*) DIMENSION IVARN(*) DIMENSION IVARN2(*) C DIMENSION ITYPEH(*) DIMENSION IW21HO(*) DIMENSION IW22HO(*) DIMENSION W2HOLD(*) C DIMENSION ILOCV(10) C DIMENSION W(16) DIMENSION Z(16) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C DATA Z(1),Z(2),Z(3),Z(4),Z(5),Z(6),Z(7),Z(8) 1 /-0.98940093499165D0,-0.944575023073233D0, 1-0.865631202387832D0,-0.755404408355003D0,-0.617876244402644D0, 1-0.458016777657227D0,-0.281603550779259D0,-0.095012509837637D0/ DATA Z(9),Z(10),Z(11),Z(12),Z(13),Z(14),Z(15),Z(16) 1/0.095012509837637D0,0.281603550779259D0,0.458016777657227D0, 10.617876244402644D0,0.755404408355003D0,0.865631202387832D0, 10.944575023073233D0,0.989400934991650D0/ DATA W(1),W(2),W(3),W(4),W(5),W(6),W(7),W(8) 1 /0.027152459411754D0,0.062253523938648D0, 10.095158511682493D0,0.124628971255534D0,0.149595988816577D0, 10.169156519395003D0,0.182603415044924D0,0.189450610455069D0/ DATA W(9),W(10),W(11),W(12),W(13),W(14),W(15),W(16) 1/0.189450610455069D0,0.182603415044924D0,0.169156519395003D0, 10.149595988816577D0,0.124628971255534D0,0.095158511682493D0, 10.062253523938648D0,0.027152459411754D0/ C C-----START POINT----------------------------------------------------- C ISUBN1='DPIN' ISUBN2='T2 ' C CUTOFF=0.001 ACCUR=0.0000001 MAXSEG=20 IPASS=2 C J2=0 C ABSXIN=0.0 XINT2=0.0 DIFF=0.0 RATIO=0.0 C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPINT2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3,IBUGCO,IBUGEV 52 FORMAT('IBUGA3,IBUGCO,IBUGEV = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)NUMCHA,NUMPV,NUMVAR 53 FORMAT('NUMCHA,NUMPV,NUMVAR, = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)(MODEL(J),J=1,NUMCHA) 54 FORMAT('MODEL(I) = ',100A1) CALL DPWRST('XXX','BUG ') DO55I=1,NUMPV WRITE(ICOUT,56)I,PARAM(I),IPARN(I),IPARN2(I) 56 FORMAT('I,PARAM(I),IPARN(I),IPARN2(I) = ',I8,E15.7,A4,A4) CALL DPWRST('XXX','BUG ') 55 CONTINUE WRITE(ICOUT,57)IANGLU 57 FORMAT('IANGLU = ',A4) CALL DPWRST('XXX','BUG ') DO60I=1,NUMVAR WRITE(ICOUT,61)I,IVARN(I),IVARN2(I) 61 FORMAT('I, IVARN(I) = ',I8,2X,A4,A4) CALL DPWRST('XXX','BUG ') 60 CONTINUE WRITE(ICOUT,62)XMIN,XMAX 62 FORMAT('XMIN, XMAX = ',2E15.7) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C *************************************************** C ** STEP 1-- ** C ** DETERMINE THE LOCATIONS (IN THE LIST IPARN) ** C ** OF THE VARIABLES OF INTEGRATION. ** C *************************************************** C DO100I=1,NUMVAR IH=IVARN(I) IH2=IVARN2(I) DO200J=1,NUMPV J2=J IF(IH.EQ.IPARN(J).AND.IH2.EQ.IPARN2(J))GOTO210 200 CONTINUE 210 CONTINUE ILOCV(I)=J2 100 CONTINUE C C ************************************************** C ** STEP 2-- ** C ** WRITE OUT PRELIMINARY SUMMARY INFORMATION ** C ************************************************** C IF(IPRINT.EQ.'OFF')GOTO409 IF(IFEEDB.EQ.'OFF')GOTO409 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,401) 401 FORMAT('INTEGRAL EVALUATION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,402)(MODEL(I),I=1,NUMCHA) 402 FORMAT(' FUNCTION--',80A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,403)XMIN 403 FORMAT(' SPECIFIED LOWER LIMIT OF INTEGRAL = ',F20.10) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,404)XMAX 404 FORMAT(' SPECIFIED UPPER LIMIT OF INTEGRAL = ',F20.10) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,405)NUMVAR 405 FORMAT(' NUMBER OF VARIABLES OF INTEGRATION = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,406) 406 FORMAT('NUMBER OF * VALUE OF ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,407) 407 FORMAT('PARTITIONS * INTEGRAL ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,408) 408 FORMAT('-------------*--------------------') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') 409 CONTINUE C C *********************************************** C ** STEP 3-- ** C ** STEP THROUGH 10 DIFFERENT SEGMENTATIONS ** C ** OF THE DOMAIN OF THE INTEGRAL. ** C *********************************************** C 3000 CONTINUE DMIN=XMIN DMAX=XMAX DO3100NUMSEG=1,MAXSEG C C **************************************************** C ** STEP 4-- ** C ** WITHIN A GIVEN SEGMENTATION, ** C ** APPLY THE 16-POINT GAUSSIAN QUADRATURE RULE. ** C **************************************************** C DNUMSE=NUMSEG DELTA2=(DMAX-DMIN)/DNUMSE DINT=0.0D0 DO3200J=1,NUMSEG DJ=J DMIN2=DMIN+(DJ-1.0D0)*DELTA2 DMAX2=DMIN+DJ*DELTA2 DB1=(DMAX2-DMIN2)/2.0D0 DB0=(DMAX2+DMIN2)/2.0D0 C DSUM2=0.0D0 DO3300I=1,16 DX=DB0+DB1*Z(I) X=DX DO3400K=1,NUMVAR JLOC=ILOCV(K) PARAM(JLOC)=X 3400 CONTINUE CALL COMPIM(MODEL,NUMCHA,IPASS,PARAM,IPARN,IPARN2,NUMPV, 1IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,Y, 1IBUGCO,IBUGEV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IF(IBUGA3.EQ.'ON')WRITE(ICOUT,3402)X,Y 3402 FORMAT('X,Y = ',2E15.7) IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ') DY=Y DSUM2=DSUM2+W(I)*DY 3300 CONTINUE DINT2=DB1*DSUM2 DINT=DINT+DINT2 IF(IBUGA3.EQ.'ON')WRITE(ICOUT,3311)NUMSEG,J,DSUM2,DB0,DB1,DINT2 3311 FORMAT('NUMSEG,J,DSUM2,DB0,DB1,DINT2=',2I3,4D12.5) IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ') C C ****************************** C ** STEP 5-- ** C ** WRITE OUT THE INTEGRAL ** C ****************************** C 3200 CONTINUE XINT=DINT IF(IPRINT.EQ.'OFF')GOTO3109 IF(IFEEDB.EQ.'OFF')GOTO3109 WRITE(ICOUT,3103)NUMSEG,XINT 3103 FORMAT(I8,' * ',E15.7) CALL DPWRST('XXX','BUG ') 3109 CONTINUE C IF(NUMSEG.EQ.1)GOTO3150 ABSXIN=ABS(XINT) DIFF=ABS(XINT-XINT2) IF(ABSXIN.LE.CUTOFF.AND.DIFF.LE.ACCUR)GOTO3500 IF(ABSXIN.LE.CUTOFF.AND.DIFF.GT.ACCUR)GOTO3150 RATIO=ABS(DIFF/XINT) IF(ABSXIN.GT.CUTOFF.AND.RATIO.LE.ACCUR)GOTO3500 IF(ABSXIN.GT.CUTOFF.AND.RATIO.GT.ACCUR)GOTO3150 3150 CONTINUE IF(IBUGA3.EQ.'ON')WRITE(ICOUT,3155)CUTOFF,ACCUR,DIFF,RATIO,ABSXIN 3155 FORMAT('CUTOFF,ACCUR,DIFF,RATIO,ABSXIN = ',5E15.7) IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ') XINT2=XINT C 3100 CONTINUE C 3500 CONTINUE IF(IPRINT.EQ.'OFF')GOTO3519 IF(IFEEDB.EQ.'OFF')GOTO3519 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3511)XINT 3511 FORMAT('INTEGRAL VALUE = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') 3519 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPINT2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)CUTOFF,ACCUR,DIFF,RATIO,ABSXIN 9012 FORMAT('CUTOFF,ACCUR,DIFF,RATIO,ABSXIN = ',5E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)XMIN,XMAX,XINT 9013 FORMAT('XMIN,XMAX,XINT = ',3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IERROR 9014 FORMAT('IERROR = ',A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPINTE(ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD, 1IA,PARAM,IPARN,IPARN2, 1IANGLU,IBUGA3,IBUGCO,IBUGEV,IBUGQ,IERROR) C C PURPOSE--TREAT THE LET CASE FOR C FINDING THE DEFINITE INTEGRAL OF AN FUNCTION. C EXAMPLE--LET A = INTEGRAL X**3+2*X**2-4*X+5 FOR X = 1 3 C --LET X = INTEGRAL F1 FOR X = 0 B 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 --JULY 1981. C UPDATED --SEPTEMBER 1981. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C UPDATED --NOVEMBER 1989. FIX AJUNK & BJUNK DIMENSIONS C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ITYPEH CHARACTER*4 IW21HO CHARACTER*4 IW22HO CHARACTER*4 IA CHARACTER*4 IPARN CHARACTER*4 IPARN2 CHARACTER*4 IANGLU CHARACTER*4 IBUGA3 CHARACTER*4 IBUGCO CHARACTER*4 IBUGEV CHARACTER*4 IBUGQ CHARACTER*4 IERROR C CHARACTER*4 NEWNAM CHARACTER*4 IHOUT CHARACTER*4 IHOUT2 CHARACTER*4 IUOUT CHARACTER*4 IDUMV CHARACTER*4 IDUMV2 CHARACTER*4 IHPARN CHARACTER*4 IHPAR2 CHARACTER*4 IHL CHARACTER*4 IHL2 CHARACTER*4 IWD1 CHARACTER*4 IWD2 CHARACTER*4 IWD12 CHARACTER*4 IWD22 CHARACTER*4 ILAB CHARACTER*4 IKEY CHARACTER*4 IKEY2 CHARACTER*4 INCLUN CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASEL CHARACTER*4 IFOUND CHARACTER*4 IFOUN1 CHARACTER*4 IFOUN2 CHARACTER*4 IERRO2 CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CHARACTER*4 IOLD CHARACTER*4 IOLD2 CHARACTER*4 INEW CHARACTER*4 INEW2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C DIMENSION ITYPEH(*) DIMENSION IW21HO(*) DIMENSION IW22HO(*) DIMENSION W2HOLD(*) C DIMENSION IA(*) DIMENSION PARAM(*) DIMENSION IPARN(*) DIMENSION IPARN2(*) C DIMENSION IDUMV(100) DIMENSION IDUMV2(100) C DIMENSION ILAB(10) DIMENSION IOLD(10) DIMENSION IOLD2(10) DIMENSION INEW(10) DIMENSION INEW2(10) C CCCCC THE FOLLOWING LINE WAS ADDED NOVEMBER 1989 DIMENSION BJUNK(1) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.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 ISUBN1='DPIN' ISUBN2='TE ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C IERROR='NO' C ILOCMX=0 NUMLIM=0 ILOC3=0 IP=0 IV=0 LOCDUM=0 C IHLEFT='UNKN' IHLEF2='UNKN' C C ******************************************* C ** TREAT THE DEFINITE INTEGRAL SUBCASE ** C ** OF THE LET COMMAND ** C ******************************************* C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPINTE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGCO,IBUGEV 53 FORMAT('IBUGCO,IBUGEV = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IBUGQ 54 FORMAT('IBUGQ = ',A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ********************************** C ** STEP 1-- ** C ** INITIALIZE SOME VARIABLES. ** C ********************************** C ISTEPN='1' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NEWNAM='NO' C MAXN2=MAXCHF MAXN3=MAXCHF CCCCC MAXN4=MAXCHF C C ******************************************************* C ** STEP 2-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ******************************************************* C ISTEPN='2' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=1 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2, 1IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C **************************************************************** C ** STEP 2-- * C ** EXAMINE THE LEFT-HAND SIDE-- * C ** IS THE NAME NAME TO LEFT OF = SIGN * C ** ALREADY IN THE NAME LIST? * C ** NOTE THAT ILISTL IS THE LINE IN THE TABLE * C ** OF THE NAME ON THE LEFT. * C **************************************************************** C ISTEPN='2' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHLEFT=IHARG(1) IHLEF2=IHARG2(1) DO2000I=1,NUMNAM I2=I IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))GOTO2100 2000 CONTINUE NEWNAM='YES' ILISTL=NUMNAM+1 IF(ILISTL.GT.MAXNAM)GOTO2200 GOTO2900 2200 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2201) 2201 FORMAT('***** ERROR IN DPINTE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2202) 2202 FORMAT(' THE NUMBER OF VARIABLE, PARAMETER, & FUNCTION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2203)MAXNAM 2203 FORMAT(' NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2204) 2204 FORMAT(' ENTER STAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2205) 2205 FORMAT(' TO FIND OUT THE FULL LIST OF USED NAMES,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2206) 2206 FORMAT(' AND THEN REDEFINE (REUSE) SOME OF THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2207) 2207 FORMAT(' ALREADY-USED NAMES') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 2100 CONTINUE ILISTL=I2 2900 CONTINUE C C *************************************************************** C ** STEP 3.1-- ** C ** EXTRACT THE RIGHT-SIDE FUNCTIONAL C ** EXPRESSION FROM THE INPUT COMMAND LINE ** C ** (STARTING WITH THE FIRST NON-BLANK LOCATION AFTER THE ** C ** EQUAL SIGN AND ENDING WITH THE END OF THE LINE ** C ** OR WITH THE LAST NON-BLANK CHARACTER BEFORE WRT . ** C ** PLACE THE FUNCTION IN IFUNC2(.) . ** C *************************************************************** C ISTEPN='3.1' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IWD1=IHARG(3) IWD12=IHARG2(3) IWD2='WRT ' IWD22=' ' CALL DPEXST(IANS,IWIDTH,IWD1,IWD12,IWD2,IWD22,MAXN2, 1IFUNC2,N2,IBUGA3,IFOUND,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IF(IFOUND.EQ.'YES')GOTO3500 C IWD1=IHARG(3) IWD12=IHARG2(3) IWD2='FOR ' IWD22=' ' CALL DPEXST(IANS,IWIDTH,IWD1,IWD12,IWD2,IWD22,MAXN2, 1IFUNC2,N2,IBUGA3,IFOUND,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IF(IFOUND.EQ.'YES')GOTO3500 C CCCCC IWD1=IHARG(3) CCCCC IWD12=IHARG2(3) CCCCC IWD2='SUBS' CCCCC IWD22='ET ' CCCCC CALL DPEXST(IANS,IWIDTH,IWD1,IWD12,IWD2,IWD22,MAXN2, CCCCC1IFUNC2,N2,IBUGA3,IFOUND,IERROR) CCCCC IF(IERROR.EQ.'YES')GOTO9000 CCCCC IF(IFOUND.EQ.'YES')GOTO3500 C CCCCC IWD1=IHARG(3) CCCCC IWD12=IHARG2(3) CCCCC IWD2='EXCE' CCCCC IWD22='PT ' CCCCC CALL DPEXST(IANS,IWIDTH,IWD1,IWD12,IWD2,IWD22,MAXN2, CCCCC1IFUNC2,N2,IBUGA3,IFOUND,IERROR) CCCCC IF(IERROR.EQ.'YES')GOTO9000 CCCCC IF(IFOUND.EQ.'YES')GOTO3500 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3101) 3101 FORMAT('***** ERROR IN DPINTE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3102) 3102 FORMAT(' INVALID COMMAND FORM FOR INTEGRATION.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3103) 3103 FORMAT(' GENERAL FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3104) 3104 FORMAT(' LET ... = INTEGRAL ... WRT ... ', 1'FOR ... = ... TO ...') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3105) 3105 FORMAT(' THE ENTIRE COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,3106)(IANS(I),I=1,IWIDTH) 3106 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 3500 CONTINUE C C *********************************************************** C ** STEP 4-- ** C ** DETERMINE IF THE EXPRESSION HAS ANY FUNCTION NAMES ** C ** INBEDDED. IF SO, REPLACE THE FUNCTION NAMES ** C ** BY EACH FUNCTION'S DEFINITION. DO SO REPEATEDLY ** C ** UNTIL ALL FUNCTION REFERENCES HAVE BEEN ANNIHILATED ** C ** AND THE EXPRESSION IS LEFT ONLY WITH ** C ** CONSTANTS, PARAMETERS, AND VARIABLES--NO FUNCTIONS. ** C ** PLACE THE RESULTING FUNCTIONAL EXPRESSION INTO IFUNC3(.) ** C *********************************************************** C ISTEPN='4' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL DPEXFU(IFUNC2,N2,IHNAME,IHNAM2,IUSE,IVSTAR,IVSTOP, 1NUMNAM,IANS,IWIDTH,IFUNC,NUMCHF,MAXCHF,IFUNC3,N3,MAXN3, 1IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IF(IBUGA3.EQ.'OFF')GOTO5090 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') ILAB(1)='INPU' ILAB(2)='T FU' ILAB(3)='NCTI' ILAB(4)='ON ' ILAB(5)=' ' ILAB(6)=' = ' NUMWDL=6 CALL DPPRIF(ILAB,NUMWDL,IFUNC3,N3,IBUGA3) C WRITE(ICOUT,5081)IDUMV(1),IDUMV2(1) 5081 FORMAT('INTEGRATION VARIABLE = ',A4,A4) CALL DPWRST('XXX','BUG ') C 5090 CONTINUE C C ************************************* C ** STEP 5-- ** C ** EXTRACT QUALIFIER INFORMATION. ** C ************************************* C ISTEPN='5' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C ********************************************************* C ** STEP 5.1-- ** C ** DETERMINE THE DUMMY VARIABLE FOR THE INTEGRATION. ** C ********************************************************* C ISTEPN='5.1' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IKEY='WRT ' IKEY2=' ' ISHIFT=1 ILOCA=1 ILOCB=NUMARG INCLUN='NO' CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB, 1IHARG,IHARG2,NUMARG, 1INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,IUSE,IN,NUMNAM, 1IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT,IVOUT,VOUT,IUOUT, 1INOUT,IBUGA3,IERROR) IF(IFOUN1.EQ.'NO'.OR.IFOUN2.EQ.'NO')GOTO5119 IDUMV(1)=IHOUT IDUMV2(1)=IHOUT2 NUMDV=1 GOTO5190 5119 CONTINUE C IKEY='FOR ' IKEY2=' ' ISHIFT=1 ILOCA=1 ILOCB=NUMARG INCLUN='NO' CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB, 1IHARG,IHARG2,NUMARG, 1INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,IUSE,IN,NUMNAM, 1IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT,IVOUT,VOUT,IUOUT, 1INOUT,IBUGA3,IERROR) IF(IFOUN1.EQ.'NO'.OR.IFOUN2.EQ.'NO')GOTO5129 IDUMV(1)=IHOUT IDUMV2(1)=IHOUT2 NUMDV=1 GOTO5190 5129 CONTINUE C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5181) 5181 FORMAT('***** ERROR IN DPINTE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5182) 5182 FORMAT(' INVALID COMMAND FORM FOR INTEGRATION.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5183) 5183 FORMAT(' NO VARIABLE OF INTEGRATION DEFINED.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5185) 5185 FORMAT(' GENERAL FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5186) 5186 FORMAT(' LET ... = INTEGRAL ... WRT ... ', 1'FOR ... = ... TO ...') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5187) 5187 FORMAT(' THE ENTIRE COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,5189)(IANS(I),I=1,IWIDTH) 5189 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 5190 CONTINUE C C ************************************************** C ** STEP 5.2-- ** C ** DETERMINE THE LIMITS FOR THE INTEGRATION. ** C ************************************************** C ISTEPN='5.2' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMLIM=0 C IKEY='FOR ' IKEY2=' ' ISHIFT=3 ILOCA=1 ILOCB=NUMARG INCLUN='NO' CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB, 1IHARG,IHARG2,NUMARG, 1INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,IUSE,IN,NUMNAM, 1IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT,IVOUT,VOUT,IUOUT, 1INOUT,IBUGA3,IERROR) IF(IFOUN1.EQ.'NO'.OR.IFOUN2.EQ.'NO')GOTO5219 XMIN=VOUT NUMLIM=NUMLIM+1 5219 CONTINUE C IKEY='FOR ' IKEY2=' ' ISHIFT=4 ILOCA=1 ILOCB=NUMARG INCLUN='NO' CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB, 1IHARG,IHARG2,NUMARG, 1INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,IUSE,IN,NUMNAM, 1IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT,IVOUT,VOUT,IUOUT, 1INOUT,IBUGA3,IERROR) IF(IFOUN1.EQ.'NO'.OR.IFOUN2.EQ.'NO')GOTO5229 IF(IHOUT.EQ.'TO '.AND.IHOUT2.EQ.' ')GOTO5229 XMAX=VOUT ILOCMX=ILOC2 NUMLIM=NUMLIM+1 5229 CONTINUE C IF(NUMLIM.GE.2)GOTO5239 IKEY='FOR ' IKEY2=' ' ISHIFT=5 ILOCA=1 ILOCB=NUMARG INCLUN='NO' CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB, 1IHARG,IHARG2,NUMARG, 1INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,IUSE,IN,NUMNAM, 1IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT,IVOUT,VOUT,IUOUT, 1INOUT,IBUGA3,IERROR) IF(IFOUN1.EQ.'NO'.OR.IFOUN2.EQ.'NO')GOTO5239 XMAX=VOUT ILOCMX=ILOC2 NUMLIM=NUMLIM+1 5239 CONTINUE C IF(NUMLIM.GE.2)GOTO5290 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5281) 5281 FORMAT('***** ERROR IN DPINTE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5282) 5282 FORMAT(' INVALID COMMAND FORM FOR INTEGRATION.') CALL DPWRST('XXX','BUG ') IF(NUMLIM.EQ.0)WRITE(ICOUT,5283) 5283 FORMAT(' NO LIMITS OF INTEGRATION DEFINED.') IF(NUMLIM.EQ.0)CALL DPWRST('XXX','BUG ') IF(NUMLIM.EQ.1)WRITE(ICOUT,5284) 5284 FORMAT(' ONLY ONE LIMIT OF INTEGRATION DEFINED.') IF(NUMLIM.EQ.1)CALL DPWRST('XXX','BUG ') IF(NUMLIM.NE.0.AND.NUMLIM.NE.1)WRITE(ICOUT,5285)NUMLIM 5285 FORMAT(' NUMBER OF LIMITS DEFINED = ',I8) IF(NUMLIM.NE.0.AND.NUMLIM.NE.1)CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5286) 5286 FORMAT(' GENERAL FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5287) 5287 FORMAT(' LET ... = INTEGRAL ... WRT ... ', 1'FOR ... = ... TO ...') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5288) 5288 FORMAT(' THE ENTIRE COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,5289)(IANS(I),I=1,IWIDTH) 5289 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 5290 CONTINUE C C ********************************************** C ** STEP 6.3-- ** C ** SCAN THE QUALIFIERS FOR VARIABLE, ** C ** PARAMETER, FUNCTION, AND VALUE CHANGES ** C ** IN THE FUNCTION. ** C ********************************************** C ISTEPN='6.3' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NCHANG=0 DO6300IFORI=1,10 C IKEY='FOR ' IKEY2=' ' ISHIFT=1 IF(IFORI.EQ.1)ILOCA=ILOCMX IF(IFORI.NE.1)ILOCA=ILOC3 ILOCB=NUMARG INCLUN='NO' CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB, 1IHARG,IHARG2,NUMARG, 1INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,IUSE,IN,NUMNAM, 1IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT,IVOUT,VOUT,IUOUT, 1INOUT,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO6380 IF(IFOUN1.EQ.'NO'.OR.IFOUN2.EQ.'NO')GOTO6350 C ILOC3=ILOC2+2 IF(ILOC3.GT.NUMARG)GOTO6380 NCHANG=NCHANG+1 IOLD(NCHANG)=IHARG(ILOC2) IOLD2(NCHANG)=IHARG2(ILOC2) INEW(NCHANG)=IHARG(ILOC3) INEW2(NCHANG)=IHARG2(ILOC3) C 6300 CONTINUE 6350 CONTINUE GOTO6390 C 6380 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6301) 6301 FORMAT('***** ERROR IN DPINTE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6302) 6302 FORMAT(' INVALID COMMAND FORM FOR INTEGRATION.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6303) 6303 FORMAT(' GENERAL FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6304) 6304 FORMAT(' LET FUNCTION ... = INTEGRAL ... WRT ... ', 1'FOR ... = ... TO ...') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6305) 6305 FORMAT(' THE ENTIRE COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,6306)(IANS(I),I=1,IWIDTH) 6306 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 6390 CONTINUE C C ********************************************** C ** STEP 6.4-- ** C ** CARRY OUT THE VARIABLE, ** C ** PARAMETER, AND FUNCTION CHANGES ** C ** AND THEN PRINT OUT A BRIEF MESSAGE ** C ** INDICATING THAT THE CHANGES ** C ** HAVE BEEN MADE. ** C ********************************************** C ISTEPN='6.4' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IPRINT.EQ.'OFF')GOTO6490 IF(IFEEDB.EQ.'OFF')GOTO6490 IF(NCHANG.LE.0)GOTO6490 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') ILAB(1)='PRE ' ILAB(2)='-CHA' ILAB(3)='NGE ' ILAB(4)='FUNC' ILAB(5)='TION' ILAB(6)=' = ' NUMWDL=6 CALL DPPRIF(ILAB,NUMWDL,IFUNC3,N3,IBUGA3) C CALL COMPIC(IFUNC3,N3,IOLD,IOLD2,INEW,INEW2,NCHANG,IFUNC3,N3, 1IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C ILAB(1)='POST' ILAB(2)='-CHA' ILAB(3)='NGE ' ILAB(4)='FUNC' ILAB(5)='TION' ILAB(6)=' = ' NUMWDL=6 CALL DPPRIF(ILAB,NUMWDL,IFUNC3,N3,IBUGA3) C 6490 CONTINUE C C ********************************************************** C ** STEP 6.7-- ** C ** MAKE A NON-CALCULATING PASS AT THE FUNCTION ** C ** SO AS TO EXTRACT ALL PARAMETER AND VARIABLE NAMES. ** C ********************************************************** C ISTEPN='6.8' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C IPASS=1 CALL COMPIM(IFUNC3,N3,IPASS,PARAM,IPARN,IPARN2,NUMPV, 1IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,AJUNK, 1IBUGCO,IBUGEV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C *********************************************** C ** STEP 7-- ** C ** CHECK THAT ALL PARAMETERS ** C ** IN THE FUNCTION ARE ALREADY PRESENT ** C ** IN THE AVAILABLE NAME LIST IHNAME(.). ** C *********************************************** C ISTEPN='7' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IP=0 IV=0 IF(NUMPV.LE.0)GOTO7650 DO7600J=1,NUMPV IHPARN=IPARN(J) IHPAR2=IPARN2(J) IF(IHPARN.EQ.IDUMV(1).AND.IHPAR2.EQ.IDUMV2(1))GOTO7630 IHWUSE='P' MESSAG='YES' CALL CHECKN(IHPARN,IHPAR2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) IF(IERRO2.EQ.'YES')GOTO7610 GOTO7620 C 7610 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7611) 7611 FORMAT('***** ERROR IN DPINTE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7612) 7612 FORMAT(' A PARAMETER/FUNCTION HAS BEEN ENCOUNTERED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7613) 7613 FORMAT(' IN THE FUNCTION TO BE INTEGRATED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7614) 7614 FORMAT(' WHICH HAS NOT YET BEEN DEFINED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7615) 7615 FORMAT(' THE UNKNOWN PARAMETER/FUNCTION = ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7616) 7616 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,7617)(IANS(I),I=1,IWIDTH) 7617 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 7620 CONTINUE IP=IP+1 PARAM(J)=VALUE(ILOCP) GOTO7600 C 7630 CONTINUE IV=IV+1 LOCDUM=J 7600 CONTINUE 7650 CONTINUE C C ****************************** C ** STEP 8-- ** C ** DETERMINE THE INTEGRAL ** C ****************************** C ISTEPN='8' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGA3.EQ.'OFF')GOTO7719 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7711) 7711 FORMAT('***** FROM DPINTE, IMMEDIATELY BEFORE CALLING ', 1'INTEGR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7712)N3,NUMPV 7712 FORMAT('N3,NUMPV = ',I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7713)NUMDV,XMIN,XMAX,XINT 7713 FORMAT('NUMDV,XMIN,XMAX,XINT = ',I8,3E15.7) CALL DPWRST('XXX','BUG ') DO7714I=1,NUMDV WRITE(ICOUT,7715)I,IDUMV(I),IDUMV2(I) 7715 FORMAT('I,IDUMV(I),IDUMV2(I) = ',I8,2X,A4,A4) CALL DPWRST('XXX','BUG ') 7714 CONTINUE WRITE(ICOUT,7716)IBUGA3,IBUGCO,IBUGEV 7716 FORMAT('IBUGA3,IBUGCO,IBUGEV = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 7719 CONTINUE C CALL DPINT2(IFUNC3,N3,PARAM,IPARN,IPARN2,NUMPV, 1IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD, 1IDUMV,IDUMV2,NUMDV,XMIN,XMAX,XINT, 1IBUGA3,IBUGCO,IBUGEV,IERROR) C C ***************************************************** C ** STEP 9-- ** C ** ENTER THE INTEGRATION VALUE INTO THE DATAPLOT ** C ** HOUSEKEEPING ARRAY ** C ***************************************************** C ISTEPN='9' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHL=IHLEFT IHL2=IHLEF2 ICASEL='P' IXINT=XINT+0.5 CCCCC THE FOLLOWING 2 LINES WERE ADDED NOVEMBER 1989 BJUNK(1)=AJUNK NJUNK=1 CCCCC THE FOLLOWING LINE WAS CHANGED NOVEMBER 1989 CCCCC CALL DPINVP(IHL,IHL2,ICASEL,AJUNK,NJUNK,XINT,IXINT, CALL DPINVP(IHL,IHL2,ICASEL,BJUNK,NJUNK,XINT,IXINT, 1ISUBN1,ISUBN2,IBUGA3,IERROR) C C **************** C ** STEP 90-- ** C ** EXIT ** C **************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPINTE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3 9012 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IBUGCO,IBUGEV 9013 FORMAT('IBUGCO,IBUGEV = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IBUGQ 9014 FORMAT('IBUGQ = ',A4) CALL DPWRST('XXX','BUG ') DO9015I=1,NUMNAM WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),IVSTOP(I) 9016 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),IVSTOP(I)=', 1I8,2X,A4,A4,2X,A4,I8,I8) CALL DPWRST('XXX','BUG ') 9015 CONTINUE WRITE(ICOUT,9017)NUMCHF,MAXCHF,IWIDTH,N2 9017 FORMAT('NUMCHF,MAXCHF,IWIDTH,N2 = ',4I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9018)(IFUNC(I),I=1,IWIDTH) 9018 FORMAT('IFUNC(.) = ',115A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9019)(IFUNC2(I),I=1,N2) 9019 FORMAT('IFUNC2(.) = ',115A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9020)N3 9020 FORMAT('N3 = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)(IFUNC3(I),I=1,N3) 9021 FORMAT('IFUNC3(.) = ',115A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9022)NUMPV 9022 FORMAT('NUMPV = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9023)IP,IV,IDUMV(1),IDUMV2(1),LOCDUM 9023 FORMAT('IP,IV,IDUMV(1),IDUMV2(1),LOCDUM = ',I8,I8,2X,A4,A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9024)IHLEFT,IHLEF2 9024 FORMAT('IHLEFT,IHLEF2 = ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9025)ICASEL,IFOUND,IERROR 9025 FORMAT('ICASEL,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9026)XMIN,XMAX,XINT 9026 FORMAT('XMIN,XMAX,XINT = ',3E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPINVP(IHLEFT,IHLEF2,ICASEL,VLEFT,NLEFT,PLEFT,ILEFT, 1ISUBN3,ISUBN4,IBUGA3,IERROR) C C PURPOSE--INSERT THE VARIABLE OR PARAMETER C WITH NAME IHLEFT C INTO THE INTERNAL DATAPLOT TABLE. C ALSO, UPDATE INTERNAL DATAPLOT C LISTS (IF NECESSARY). 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--82/7 C ORIGINAL VERSION--JANUARY 1979. C UPDATED --FEBRUARY 1979. C UPDATED --JULY 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CHARACTER*4 ICASEL CHARACTER*4 ISUBN3 CHARACTER*4 ISUBN4 CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 NEWNAM CHARACTER*4 NEWCOL C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C DIMENSION VLEFT(*) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.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 ISUBN1='DPIN' ISUBN2='VP ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 C IERROR='NO' C ICOLL=0 C C ****************************************** C ** INSERT A VARIABLE ** C ** INTO THE GENERAL DATAPLOT ** C ** ARRAY V(.) ; OR ** C ** INSERT A PARAMETER VALUE ** C ** INTO THE INTERNAL DATAPLOT TABLE. ** C ** MAKE ADJUSTMENTS TO THE ** C ** INTERNAL DATAPLOT LISTS. ** C ****************************************** C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPINVP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IHLEFT,IHLEF2,ICASEL,NLEFT,PLEFT 52 FORMAT('IHLEFT,IHLEF2,ICASEL,NLEFT,PLEFT = ', 1A4,A4,2X,A4,I8,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)VLEFT(1),VLEFT(NLEFT) 53 FORMAT('VLEFT(1),VLEFT(NLEFT) = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)NUMNAM,MAXNAM,NUMCOL,MAXN,MAXCOL 54 FORMAT('NUMNAM,MAXNAM,NUMCOL,MAXN,MAXCOL = ',5I8) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ********************************** C ** STEP 1-- ** C ** INITIALIZE SOME VARIABLES. ** C ********************************** C ISTEPN='1' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NEWNAM='NO' NEWCOL='NO' C C ******************************************************* C ** STEP 2-- ** C ** DETERMINE WHETHER OR NOT THE NAME IN IHLEFT ** C ** ALREADY EXISTS IN THE INTERNAL IHNAME(.) TABLE. ** C ** THE 'YES' OR 'NO' RESULT IS PLACED IN NEWNAM. ** C ** THE LINE IN THE TABLE IS PLACED INTO ILISTL. ** C ** DETERMINE ALSO IF THE NUMBER OF NAMES ** C ** IN THE IHNAME(.) TABLE EXCEEDS THE ** C ** MAXIMUM ALLOWABLE NUMBER (MAXNAM). ** C ******************************************************* C ISTEPN='2' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO2000I=1,NUMNAM I2=I IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))GOTO2030 2000 CONTINUE NEWNAM='YES' ILISTL=NUMNAM+1 GOTO2050 2030 CONTINUE NEWNAM='NO' ILISTL=I2 2050 CONTINUE C IF(ILISTL.LE.MAXNAM)GOTO2090 WRITE(ICOUT,2051)ISUBN1,ISUBN2,ISUBN3,ISUBN4 2051 FORMAT('***** ERROR IN ',A4,A4,'AS CALLED FROM ',A4,A4,'--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2052) 2052 FORMAT(' THE NUMBER OF VARIABLE/PARAMETER', 1'/FUNCTION NAMES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2053)MAXNAM 2053 FORMAT(' HAS JUST EXCEEDED THE MAX ALLOWABLE (= ', 1I8,') .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2054) 2054 FORMAT(' SUGGESTED ACTION--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2055) 2055 FORMAT(' ENTER STAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2056) 2056 FORMAT(' TO FIND OUT THE FULL LIST OF USED NAMES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2057) 2057 FORMAT(' AND THEN REUSE SOME NAME. ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2058) 2058 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2059)(IANS(I),I=1,IWIDTH) 2059 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 2090 CONTINUE C C *************************************** C ** STEP 3-- ** C ** IF OUTPUT IS TO BE A VARIABLE, ** C ** DETERMINE WHAT COLUMN IN V(.) ** C ** THE OUTPUT WILL GO. ** C ** THE RESULT WILL BE PLACED ** C ** INTO ICOLL . ** C *************************************** C ISTEPN='3' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEL.NE.'V')GOTO3099 C IF(NEWNAM.EQ.'YES')NEWCOL='YES' IF(NEWNAM.EQ.'YES')ICOLL=NUMCOL+1 C IF(NEWNAM.EQ.'NO'.AND.IUSE(ILISTL).NE.'V')NEWCOL='YES' IF(NEWNAM.EQ.'NO'.AND.IUSE(ILISTL).NE.'V')ICOLL=NUMCOL+1 C IF(NEWNAM.EQ.'NO'.AND.IUSE(ILISTL).EQ.'V')NEWCOL='NO' IF(NEWNAM.EQ.'NO'.AND.IUSE(ILISTL).EQ.'V')ICOLL=IVALUE(ILISTL) C 3099 CONTINUE C C ***************************************** C ** STEP 4-- ** C ** DETERMINE IF THE COLUMN IN V(.) ** C ** WOULD EXCEED THE MAX ALLOWABLE ** C ** NUMBER OF COLUMNS. ** C ***************************************** C ISTEPN='4' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEL.NE.'V')GOTO4099 IF(ICASEL.EQ.'V'.AND.ICOLL.LE.MAXCOL)GOTO4099 C WRITE(ICOUT,4051)ISUBN1,ISUBN2,ISUBN3,ISUBN4 4051 FORMAT('***** ERROR IN ',A4,A4,'AS CALLED FROM ',A4,A4,'--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4052) 4052 FORMAT(' THE NUMBER OF DATA COLUMNS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4053)MAXCOL 4053 FORMAT(' HAS JUST EXCEEDED THE MAX ALLOWABLE ',I8,' .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4054) 4054 FORMAT(' SUGGESTED ACTION--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4055) 4055 FORMAT(' ENTER STAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4056) 4056 FORMAT(' TO FIND OUT THE FULL LIST OF USED COLUMNS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4057) 4057 FORMAT(' AND THEN OVERWRITE SOME COLUMN. ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4058) 4058 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,4059)(IANS(I),I=1,IWIDTH) 4059 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 4099 CONTINUE C C ******************************************* C ** STEP 5-- ** C ** IF OUTPUT IS TO BE A VARIABLE, ** C ** ENTER THE CONTENTS OF VLEFT(.) ** C ** (ALL NLEFT ELEMENTS OF VLEFT(.)) ** C ** INTO COLUMN ICOLL OF V(.) . ** C ******************************************* C ISTEPN='5' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEL.NE.'V')GOTO5099 IF(NLEFT.LE.0)GOTO5099 IF(NLEFT.LE.MAXN)GOTO5039 C WRITE(ICOUT,5021)ISUBN1,ISUBN2,ISUBN3,ISUBN4 5021 FORMAT('***** ERROR IN ',A4,A4,'AS CALLED FROM ',A4,A4,'--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5022)NLEFT 5022 FORMAT(' THE NUMBER (= ',I8,') OF ELEMENTS ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5023)IHLEFT,IHLEF2 5023 FORMAT(' FOR VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5024)MAXN 5024 FORMAT(' HAS JUST EXCEEDED THE MAX ALLOWABLE ',I8,' .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5025) 5025 FORMAT(' SUGGESTED ACTION--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5026) 5026 FORMAT(' ENTER STAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5027) 5027 FORMAT(' TO FIND OUT THE FULL LIST OF USED COLUMNS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5028) 5028 FORMAT(' AND THEN OVERWRITE SOME COLUMN. ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5029) 5029 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,5030)(IANS(I),I=1,IWIDTH) 5030 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 5039 CONTINUE C DO5070I=1,NLEFT IJ=MAXN*(ICOLL-1)+I IF(ICOLL.LE.MAXCOL)V(IJ)=VLEFT(I) IF(ICOLL.EQ.MAXCP1)PRED(I)=VLEFT(I) IF(ICOLL.EQ.MAXCP2)RES(I)=VLEFT(I) 5070 CONTINUE C 5099 CONTINUE C C ******************************************* C ** STEP 7-- ** C ** CARRY OUT THE LIST UPDATING AND ** C ** GENERATE THE INFORMATIVE PRINTING ** C ******************************************* C ISTEPN='7' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEL.EQ.'P')GOTO7010 IF(ICASEL.EQ.'V')GOTO7020 GOTO9000 C 7010 CONTINUE IHNAME(ILISTL)=IHLEFT IHNAM2(ILISTL)=IHLEF2 VALUE(ILISTL)=PLEFT IVALUE(ILISTL)=ILEFT IN(ILISTL)=ILEFT IUSE(ILISTL)='P' IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1 C IF(IFEEDB.EQ.'OFF')GOTO7019 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7011)IHLEFT,IHLEF2,VALUE(ILISTL) 7011 FORMAT('THE COMPUTED VALUE OF THE CONSTANT ',A4,A4, 1' = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') 7019 CONTINUE GOTO7190 C 7020 CONTINUE IHNAME(ILISTL)=IHLEFT IHNAM2(ILISTL)=IHLEF2 IUSE(ILISTL)='V' IVALUE(ILISTL)=ICOLL VALUE(ILISTL)=ICOLL IN(ILISTL)=NLEFT C CCCCC IUSE(ICOLL)='V' CCCCC IVALUE(ICOLL)=ICOLL CCCCC VALUE(ICOLL)=ICOLL CCCCC IN(ICOLL)=NLEFT C IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1 IF(NEWCOL.EQ.'YES')NUMCOL=NUMCOL+1 C DO7100I=1,NUMNAM I2=I IF(IUSE(I).EQ.'V'.AND.IVALUE(I).EQ.ICOLL)GOTO7105 GOTO7100 7105 CONTINUE IUSE(I2)='V' IVALUE(I2)=ICOLL VALUE(I2)=ICOLL IN(I2)=NLEFT 7100 CONTINUE C NS=NLEFT IF(IFEEDB.EQ.'OFF')GOTO7119 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7111)IHLEFT,IHLEF2,NS 7111 FORMAT('THE NUMBER OF VALUES GENERATED FOR ', 1'THE VARIABLE ',A4,A4,' = ',I8) CALL DPWRST('XXX','BUG ') 7119 CONTINUE C IROW1=1 IROWN=NLEFT C IF(IFEEDB.EQ.'OFF')GOTO7149 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IJ1=MAXN*(ICOLL-1)+IROW1 IF(ICOLL.LE.MAXCOL)WRITE(ICOUT,7121)IHLEFT,IHLEF2,V(IJ1), 1IROW1 7121 FORMAT('THE FIRST COMPUTED VALUE OF ',A4,A4, 1' = ',E15.7,' (ROW ',I5,')') IF(ICOLL.LE.MAXCOL)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP1)WRITE(ICOUT,7121)IHLEFT,IHLEF2,PRED(IROW1), 1IROW1 IF(ICOLL.EQ.MAXCP1)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP2)WRITE(ICOUT,7121)IHLEFT,IHLEF2,RES(IROW1), 1IROW1 IF(ICOLL.EQ.MAXCP2)CALL DPWRST('XXX','BUG ') IJN=MAXN*(ICOLL-1)+IROWN IF(ICOLL.LE.MAXCOL.AND. 1NS.NE.1)WRITE(ICOUT,7131)NS,IHLEFT,IHLEF2,V(IJN),IROWN IF(ICOLL.LE.MAXCOL.AND. 1NS.NE.1)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP1.AND. 1NS.NE.1)WRITE(ICOUT,7131)NS,IHLEFT,IHLEF2,PRED(IROWN),IROWN IF(ICOLL.EQ.MAXCP1.AND. 1NS.NE.1)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP2.AND. 1NS.NE.1)WRITE(ICOUT,7131)NS,IHLEFT,IHLEF2,RES(IROWN),IROWN 7131 FORMAT('THE LAST (',I5,'TH) COMPUTED VALUE OF ',A4,A4, 1' = ',E15.7,' (ROW ',I5,')') IF(ICOLL.EQ.MAXCP2.AND. 1NS.NE.1)CALL DPWRST('XXX','BUG ') IF(NS.NE.1)GOTO7180 C WRITE(ICOUT,7142) 7142 FORMAT('NOTE--THE ABOVE VALUE WAS THE ONLY VALUE COMPUTED ', 1'FOR THIS VARIABLE.') CALL DPWRST('XXX','BUG ') 7149 CONTINUE 7180 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO7189 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7182)IHLEFT,IHLEF2,ICOLL 7182 FORMAT('THE CURRENT COLUMN FOR ', 1'THE VARIABLE ',A4,A4,' = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7183)IHLEFT,IHLEF2,NLEFT 7183 FORMAT('THE CURRENT LENGTH OF ', 1'THE VARIABLE ',A4,A4,' = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') 7189 CONTINUE C 7190 CONTINUE C C **************** C ** STEP 90-- ** C ** EXIT ** C **************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('AT THE END OF DPINVP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IHLEFT,IHLEF2,ICASEL,NLEFT,PLEFT,ILEFT 9012 FORMAT('IHLEFT,IHLEF2,ICASEL,NLEFT,PLEFT,ILEFT = ', 1A4,A4,2X,A4,I8,E15.7,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)VLEFT(1),VLEFT(NLEFT) 9013 FORMAT('VLEFT(1),VLEFT(NLEFT) = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)NEWNAM,ILISTL,ICOLL,NUMNAM 9015 FORMAT('NEWNAM,ILISTL,ICOLL,NUMNAM = ',A4,I8,I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)IHNAME(ILISTL),IHNAM2(ILISTL),IVALUE(ILISTL), 1VALUE(ILISTL) 9016 FORMAT('IHNAME(ILISTL),IHNAM2(ILISTL),IVALUE(ILISTL),', 1'VALUE(ILISTL) = ',A4,A4,2X,I8,2X,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)IUSE(ILISTL),IN(ILISTL) 9017 FORMAT('IUSE(ILISTL),IN(ILISTL) = ',A4,2X,I8) CALL DPWRST('XXX','BUG ') IJ1=MAXN*(ICOLL-1)+1 IJN=MAXN*(ICOLL-1)+NLEFT WRITE(ICOUT,9018)IJ1,IJN,V(IJ1),V(IJN) 9018 FORMAT('IJ1,IJN,V(IJ1),V(IJN) = ',2I8,2E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPISP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT, 1ISEED, 1ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) C C PURPOSE--GENERATE ONE OF THE FOLLOWING INTERACTION STATISTIC C PLOTS (THESE DIFFER FROM THE STATISTIC PLOT CASE C IN THAT THERE CAN BE MORE THAN 1 X VARIABLE, THESE C ARE MULTIPLIED TO GET THE INTERACTION X TERM, MAIN C APPLICATION IS IN DESIGN OF EXPERIMENTS)-- C MEAN INTERACTION STATISTIC PLOT C MIDM INTERACTION STATISTIC PLOT C MEDI INTERACTION STATISTIC PLOT C SD INTERACTION STATISTIC PLOT C REL SD INTERACTION STATISTIC PLOT C SD MEAN INTERACTION STATISTIC PLOT C VARI INTERACTION STATISTIC PLOT C REL VARI INTERACTION STATISTIC PLOT C VARI MEAN INTERACTION STATISTIC PLOT C RANG INTERACTION STATISTIC PLOT C MINI INTERACTION STATISTIC PLOT C MAXI INTERACTION STATISTIC PLOT C EXTREME INTERACTION STATISTIC PLOT C SKEW INTERACTION STATISTIC PLOT C KURT INTERACTION STATISTIC PLOT C AUCR INTERACTION STATISTIC PLOT C SDM INTERACTION STATISTIC PLOT C AUCV INTERACTION STATISTIC PLOT C LOWH INTERACTION STATISTIC PLOT C UPPH INTERACTION STATISTIC PLOT C LOWQ INTERACTION STATISTIC PLOT C UPPQ INTERACTION STATISTIC PLOT C TRIM INTERACTION STATISTIC PLOT C WINM INTERACTION STATISTIC PLOT C MIDQ INTERACTION STATISTIC PLOT C 1DEC INTERACTION STATISTIC PLOT C 2DEC INTERACTION STATISTIC PLOT C 3DEC INTERACTION STATISTIC PLOT C 4DEC INTERACTION STATISTIC PLOT C 5DEC INTERACTION STATISTIC PLOT C 6DEC INTERACTION STATISTIC PLOT C 7DEC INTERACTION STATISTIC PLOT C 8DEC INTERACTION STATISTIC PLOT C 9DEC INTERACTION STATISTIC PLOT C SINE FREQUENCY INTERACTION STATISTIC PLOT C SINE AMPLITUDE INTERACTION STATISTIC PLOT C LINEAR INTERCEPT INTERACTION STATISTIC PLOT C LINEAR SLOPE INTERACTION STATISTIC PLOT C LINEAR RESSD INTERACTION STATISTIC PLOT C LINEAR CORRELATION INTERACTION STATISTIC PLOT C TAGUCHI SIGNAL-TO-NOISE PLOTS C CP PLOT C CPK PLOT C CPM PLOT C CC PLOT C CNPK PLOT C PERCENT DEFECTIVE PLOT C EXPECTED LOSS PLOT C NORM PPCC INTERACTION STATISTIC PLOT C AAD PLOT C MAD PLOT C SN SCALE PLOT C QN SCALE PLOT C PERCENTILE PLOT C GEOMETRIC MEAN PLOT C GEOMETRIC STANDARD DEVIATION PLOT C BIWEIGHT LOCATION PLOT C BIWEIGHT SCALE PLOT C WINSORIZED VARIANCE PLOT C WINSORIZED SD PLOT C CORRELATION INTERACTION STATISTIC PLOT C COVARIANCE INTERACTION STATISTIC PLOT C RANK CORRELATION INTERACTION STATISTIC PLOT C RANK COVARIANCE INTERACTION STATISTIC PLOT C KENDELLS TAU INTERACTION STATISTIC PLOT C WINSORIZED COVARIANCE PLOT C WINSORIZED CORRELATION PLOT C BIWEIGHT MIDVARIANCE PLOT C BIWEIGHT MIDCOVARIANCE PLOT C BIWEIGHT MIDCORRELATION PLOT C PERCENTAGE BEND MIDVARIANCE PLOT C PERCENTAGE BEND CORRELATION PLOT C HODGES LEHMAN PLOT C QUANTILE PLOT C QUANTILE STANDARD ERROR PLOT C TRIMMED MEAN STANDARD ERROR 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-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--99/10 C ORIGINAL VERSION--OCTOBER 1999. C UPDATED --JULY 2002. BIWEIGHT LOCATION C UPDATED --JULY 2002. BIWEIGHT SCALE C UPDATED --JULY 2002. WINSORIZED VARIANCE C UPDATED --JULY 2002. WINSORIZED SD C UPDATED --JULY 2002. ADD WINSORIZED COVARIANCE PLOT C UPDATED --JULY 2002. ADD WINSORIZED CORRELATION PLOT C UPDATED --JULY 2002. ADD BIWEIGHT MIDVARIANCE PLOT C UPDATED --JULY 2002. ADD BIWEIGHT MIDCOVARIANCE PLOT C UPDATED --JULY 2002. ADD BIWEIGHT MIDCORRELATION PLOT C UPDATED --JULY 2002. ADD PERCENTAGE BEND MIDVARIANCE C PLOT C UPDATED --JULY 2002. ADD PERCENTAGE BEND CORRELATION C PLOT C UPDATED --JULY 2002. ADD HODGES LEHMAN PLOT C UPDATED --JULY 2002. ADD QUANTILE PLOT C UPDATED --JULY 2002. ADD QUANTILE STANDARD ERROR PLOT C UPDATED --JULY 2002. ADD TRIMMED MEAN STANDARD C ERROR PLOT C UPDATED --APRIL 2003. ADD SN AND QN, REQUIRED C ADDITIONAL SCRATCH ARRAYS C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IAND1 CHARACTER*4 IAND2 CHARACTER*4 ICONT CHARACTER*4 ISUBRO CHARACTER*4 IBUGG2 CHARACTER*4 IBUGG3 CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASEQ CHARACTER*4 IH CHARACTER*4 IH2 CHARACTER*4 IERRO2 CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CHARACTER*4 IHHOR CHARACTER*4 IHHOR2 C CHARACTER*4 ICASV C CHARACTER*4 ISUBN0 CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C PARAMETER (MAXV2=25) C DIMENSION TEMP(*) DIMENSION TEMP2(*) DIMENSION TEMP3(*) DIMENSION XTEMP1(*) DIMENSION XTEMP2(*) C DIMENSION ICOLH(MAXV2) DIMENSION NHOR(MAXV2) C DIMENSION Y1(MAXOBV) DIMENSION Z1(MAXOBV) DIMENSION X1(MAXOBV) DIMENSION XTEMP3(MAXOBV) CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZZ.INC' EQUIVALENCE (GARBAG(IGARB1),X1(1)) EQUIVALENCE (GARBAG(IGARB2),Y1(1)) EQUIVALENCE (GARBAG(IGARB3),Z1(1)) EQUIVALENCE (GARBAG(IGARB4),XTEMP3(1)) CCCCC END CHANGE C CCCCC JULY 2002. ADD INTEGER ARRAYS FOR HODGES-LEHMAN PLOT. INCLUDE 'DPCOZI.INC' C INTEGER ITEMP1(MAXOBV) INTEGER ITEMP2(MAXOBV) INTEGER ITEMP3(MAXOBV) INTEGER ITEMP4(MAXOBV) INTEGER ITEMP5(MAXOBV) INTEGER ITEMP6(MAXOBV) EQUIVALENCE (IGARBG(IIGAR1),ITEMP1(1)) EQUIVALENCE (IGARBG(IIGAR2),ITEMP2(1)) EQUIVALENCE (IGARBG(IIGAR3),ITEMP3(1)) EQUIVALENCE (IGARBG(IIGAR4),ITEMP4(1)) EQUIVALENCE (IGARBG(IIGAR5),ITEMP5(1)) EQUIVALENCE (IGARBG(IIGAR6),ITEMP6(1)) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' INCLUDE 'DPCOHO.INC' INCLUDE 'DPCOST.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='NO' C ISUBN1='PISP' ISUBN2=' ' ICASV='ON' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C MINN2=2 C ICOLL=0 DO20I=1,MAXV2 ICOLH(I)=0 NHOR(I)=0 20 CONTINUE C C ************************************************* C ** TREAT THE INTERACTION STATISTIC PLOT CASE ** C ************************************************* C IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'PISP')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPISP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ 52 FORMAT('ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ = ', 1A4,2X,A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASPL,IAND1,IAND2 53 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C *************************** C ** STEP 1-- ** C ** EXTRACT THE COMMAND ** C *************************** C ISTEPN='1' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PISP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C ********************************* C ** STEP 1-- ** C ** DETERMINE IF OF THIS TYPE ** C ** AND BRANCH ACCORDINGLY. ** C ********************************* C ISTEPN='1' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PISP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.2)GOTO9000 C IF(ICOM.EQ.'NUMB'.AND.ICOM2.EQ.'ER ')GOTO201 IF(ICOM.EQ.'COUN'.AND.ICOM2.EQ.'T ')GOTO201 IF(ICOM.EQ.'COUN'.AND.ICOM2.EQ.'TS ')GOTO201 IF(ICOM.EQ.'SIZE'.AND.ICOM2.EQ.' ')GOTO201 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'SAMP'.AND.IHARG(1).EQ.'SIZE')GOTO202 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'SUBS'.AND.IHARG(1).EQ.'SIZE')GOTO202 C IF(ICOM.EQ.'SUM '.AND.ICOM2.EQ.' ')GOTO211 IF(ICOM.EQ.'PROD'.AND.ICOM2.EQ.'UCT ')GOTO212 IF(ICOM.EQ.'INTE'.AND.ICOM2.EQ.'GRAL')GOTO213 C IF(ICOM.EQ.'MIDR'.AND.ICOM2.EQ.'ANGE')GOTO221 IF(ICOM.EQ.'MEAN'.AND.ICOM2.EQ.' ')GOTO222 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'AVER'.AND.ICOM2.EQ.'AGE '.AND.IHARG(1).EQ.'ABSO'.AND. 1IHARG(2).EQ.'DEVI')GOTO413 IF(ICOM.EQ.'AAD '.AND.ICOM2.EQ.' ')GOTO414 C IF(ICOM.EQ.'AVER'.AND.ICOM2.EQ.'AGE ')GOTO222 IF(ICOM.EQ.'MIDM'.AND.ICOM2.EQ.'EAN ')GOTO223 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'MEDI'.AND.ICOM2.EQ.'AN '.AND.IHARG(1).EQ.'ABSO'.AND. 1IHARG(2).EQ.'DEVI')GOTO415 IF(ICOM.EQ.'MAD '.AND.ICOM2.EQ.' ')GOTO416 C IF(ICOM.EQ.'MEDI'.AND.ICOM2.EQ.'AN ')GOTO224 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'TRIM'.AND.IHARG(1).EQ.'MEAN'.AND. 1(IHARG(2).NE.'STAN'.AND.IHARG(3).NE.'ERRO'))GOTO225 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'WIND'.AND.IHARG(1).EQ.'MEAN')GOTO226 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'WINS'.AND.IHARG(1).EQ.'MEAN')GOTO226 C IF(ICOM.EQ.'R '.AND.ICOM2.EQ.' ')GOTO241 IF(ICOM.EQ.'RANG'.AND.ICOM2.EQ.'E ')GOTO241 IF(ICOM.EQ.'MINI'.AND.ICOM2.EQ.'MUM ')THEN IF(NUMARG.GE.2.AND.IHARG(1).EQ.'BLOC'.AND.IHARG(2).EQ.'PLOT') 1 GOTO9000 GOTO242 ENDIF IF(ICOM.EQ.'MIN '.AND.ICOM2.EQ.' ')THEN IF(NUMARG.GE.2.AND.IHARG(1).EQ.'BLOC'.AND.IHARG(2).EQ.'PLOT') 1 GOTO9000 GOTO242 ENDIF IF(ICOM.EQ.'MAXI'.AND.ICOM2.EQ.'MUM ')THEN IF(NUMARG.GE.2.AND.IHARG(1).EQ.'BLOC'.AND.IHARG(2).EQ.'PLOT') 1 GOTO9000 GOTO243 ENDIF IF(ICOM.EQ.'MAX '.AND.ICOM2.EQ.' ')THEN IF(NUMARG.GE.2.AND.IHARG(1).EQ.'BLOC'.AND.IHARG(2).EQ.'PLOT') 1 GOTO9000 GOTO243 ENDIF C IF(NUMARG.GE.3.AND. 1ICOM.EQ.'VARI'.AND.IHARG(1).EQ.'OF '.AND. 1IHARG(2).EQ.'THE '.AND.IHARG(3).EQ.'MEAN')GOTO251 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'VARI'.AND.IHARG(1).EQ.'OF '.AND. 1IHARG(2).EQ.'MEAN')GOTO252 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'VARI'.AND.IHARG(1).EQ.'MEAN')GOTO253 IF(ICOM.EQ.'VARI'.AND.ICOM2.EQ.'ANCE')GOTO254 IF(ICOM.EQ.'VARI'.AND.ICOM2.EQ.' ')GOTO254 C IF(NUMARG.GE.3.AND. 1ICOM.EQ.'VAR '.AND.IHARG(1).EQ.'OF '.AND. 1IHARG(2).EQ.'THE '.AND.IHARG(3).EQ.'MEAN')GOTO251 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'VAR '.AND.IHARG(1).EQ.'OF '.AND. 1IHARG(2).EQ.'MEAN')GOTO252 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'VAR '.AND.IHARG(1).EQ.'MEAN')GOTO253 IF(ICOM.EQ.'VAR '.AND.ICOM2.EQ.' ')GOTO254 C IF(NUMARG.GE.4.AND. 1ICOM.EQ.'STAN'.AND.IHARG(1).EQ.'DEVI'.AND. 1IHARG(2).EQ.'OF '.AND.IHARG(3).EQ.'THE '.AND. 1IHARG(4).EQ.'MEAN')GOTO261 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'STAN'.AND.IHARG(1).EQ.'DEVI'.AND. 1IHARG(2).EQ.'OF '.AND.IHARG(3).EQ.'MEAN')GOTO262 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'STAN'.AND.IHARG(1).EQ.'DEVI'.AND. 1IHARG(2).EQ.'MEAN')GOTO263 C IF(NUMARG.GE.3.AND. 1ICOM.EQ.'SD '.AND.IHARG(1).EQ.'OF '.AND. 1IHARG(2).EQ.'THE '.AND.IHARG(3).EQ.'MEAN')GOTO262 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'SD '.AND.IHARG(1).EQ.'OF '.AND. 1IHARG(2).EQ.'MEAN')GOTO263 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'SD '.AND.IHARG(1).EQ.'MEAN')GOTO266 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'STAN'.AND.IHARG(1).EQ.'DEVI')GOTO264 IF(ICOM.EQ.'SD '.AND.ICOM2.EQ.' ')GOTO265 IF(ICOM.EQ.'S '.AND.ICOM2.EQ.' ')GOTO265 C IF(ICOM.EQ.'RS '.AND.ICOM2.EQ.' ')GOTO271 IF(ICOM.EQ.'RSD '.AND.ICOM2.EQ.' ')GOTO271 IF(ICOM.EQ.'RELS'.AND.ICOM2.EQ.' ')GOTO271 IF(ICOM.EQ.'RELS'.AND.ICOM2.EQ.'D ')GOTO271 IF(ICOM.EQ.'RV '.AND.ICOM2.EQ.' ')GOTO272 IF(ICOM.EQ.'RVAR'.AND.ICOM2.EQ.' ')GOTO272 IF(ICOM.EQ.'RELV'.AND.ICOM2.EQ.' ')GOTO272 IF(ICOM.EQ.'RELV'.AND.ICOM2.EQ.' ')GOTO272 IF(ICOM.EQ.'RELV'.AND.ICOM2.EQ.'AR ')GOTO272 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'COEF'.AND.IHARG(1).EQ.'OF '.AND. 1IHARG(2).EQ.'VARI')GOTO273 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'COEF'.AND.IHARG(1).EQ.'VARI')GOTO274 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'RELA'.AND.IHARG(1).EQ.'SD ')GOTO276 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'RELA'.AND.IHARG(1).EQ.'STAN'.AND. 1IHARG(2).EQ.'DEVI')GOTO277 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'RELA'.AND.IHARG(1).EQ.'VAR ')GOTO278 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'RELA'.AND.IHARG(1).EQ.'VARI')GOTO278 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'LOWE'.AND.IHARG(1).EQ.'QUAR')GOTO301 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'FIRS'.AND.IHARG(1).EQ.'QUAR')GOTO301 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'SECO'.AND.IHARG(1).EQ.'QUAR')GOTO302 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'UPPE'.AND.IHARG(1).EQ.'QUAR')GOTO303 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'THIR'.AND.IHARG(1).EQ.'QUAR')GOTO303 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'LOWE'.AND.IHARG(1).EQ.'HING')GOTO304 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'UPPE'.AND.IHARG(1).EQ.'HING')GOTO305 C IF(NUMARG.GE.3.AND. 1ICOM.EQ.'STAN'.AND.IHARG(1).EQ.'THIR'.AND. 1IHARG(2).EQ.'CENT'.AND.IHARG(3).EQ.'MOME')GOTO311 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'STAN'.AND.IHARG(1).EQ.'3RD '.AND. 1IHARG(2).EQ.'CENT'.AND.IHARG(3).EQ.'MOME')GOTO311 IF(ICOM.EQ.'SKEW'.AND.ICOM2.EQ.'NESS')GOTO312 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'STAN'.AND.IHARG(1).EQ.'FOUR'.AND. 1IHARG(2).EQ.'CENT'.AND.IHARG(3).EQ.'MOME')GOTO313 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'STAN'.AND.IHARG(1).EQ.'4TH '.AND. 1IHARG(2).EQ.'CENT'.AND.IHARG(3).EQ.'MOME')GOTO313 IF(ICOM.EQ.'KURT'.AND.ICOM2.EQ.'OSIS')GOTO314 C IF(NUMARG.GE.2.AND. 1ICOM.EQ.'AUTO'.AND.ICOM2.EQ.'COVA'.AND. 1IHARG(1).EQ.'STAT'.AND.IHARG(2).EQ.'PLOT')GOTO321 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'AUTO'.AND.ICOM2.EQ.'CORR'.AND. 1IHARG(1).EQ.'STAT'.AND.IHARG(2).EQ.'PLOT')GOTO322 C IF(ICOM.EQ.'COVA'.AND.ICOM2.EQ.'RIAN')GOTO331 IF(ICOM.EQ.'CORR'.AND.ICOM2.EQ.'ELAT')GOTO332 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'RANK'.AND.IHARG(1).EQ.'COVA')GOTO333 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'RANK'.AND.IHARG(1).EQ.'CORR')GOTO334 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'KEND'.AND.IHARG(1).EQ.'TAU ')GOTO337 C IF(NUMARG.GE.1.AND.IHARG(1).EQ.'DECI')GOTO111 GOTO119 111 CONTINUE IF(ICOM.EQ.'FIRS')GOTO341 IF(ICOM.EQ.'SECO')GOTO342 IF(ICOM.EQ.'THIR')GOTO343 IF(ICOM.EQ.'FOUR')GOTO344 IF(ICOM.EQ.'FIFT')GOTO345 IF(ICOM.EQ.'SIXT')GOTO346 IF(ICOM.EQ.'SEVE')GOTO347 IF(ICOM.EQ.'EIGH')GOTO348 IF(ICOM.EQ.'NINT')GOTO349 119 CONTINUE C IF(ICOM.EQ.'PERC'.AND.IHARG(1).NE.'BEND'.AND.IHARG(1).NE.'DEFE') 1 GOTO350 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'SIN'.AND.IHARG(1).EQ.'FREQ')GOTO361 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'SINE'.AND.IHARG(1).EQ.'FREQ')GOTO361 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'SIN'.AND.IHARG(1).EQ.'AMP')GOTO362 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'SINE'.AND.IHARG(1).EQ.'AMP')GOTO362 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'SIN'.AND.IHARG(1).EQ.'AMPL')GOTO362 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'SINE'.AND.IHARG(1).EQ.'AMPL')GOTO362 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'LINE'.AND.IHARG(1).EQ.'INTE')GOTO363 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'LINE'.AND.IHARG(1).EQ.'SLOP')GOTO364 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'LINE'.AND.IHARG(1).EQ.'RESS')GOTO365 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'LINE'.AND.IHARG(1).EQ.'CORR')GOTO366 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'SN '.AND.IHARG(1).EQ.'SCAL')GOTO500 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'QN '.AND.IHARG(1).EQ.'SCAL')GOTO502 C IF(NUMARG.GE.1.AND.ICOM.EQ.'TAGU')GOTO130 GOTO139 130 CONTINUE IF(IHARG(1).EQ.'SN')GOTO371 IF(IHARG(1).EQ.'S/N')GOTO371 IF(IHARG(1).EQ.'SN0')GOTO371 IF(IHARG(1).EQ.'S/N0')GOTO371 IF(IHARG(1).EQ.'SNT')GOTO371 IF(IHARG(1).EQ.'S/NT')GOTO371 IF(IHARG(1).EQ.'SN+')GOTO372 IF(IHARG(1).EQ.'S/N+')GOTO372 IF(IHARG(1).EQ.'SNL')GOTO372 IF(IHARG(1).EQ.'SN-')GOTO373 IF(IHARG(1).EQ.'S/N-')GOTO373 IF(IHARG(1).EQ.'SNS')GOTO373 IF(IHARG(1).EQ.'SN00')GOTO374 IF(IHARG(1).EQ.'SNT2')GOTO374 IF(IHARG(1).EQ.'S/N2')GOTO374 IF(IHARG(1).EQ.'SN2')GOTO374 139 CONTINUE C IF(ICOM.EQ.'SN')GOTO381 IF(ICOM.EQ.'S/N')GOTO381 IF(ICOM.EQ.'SN0')GOTO381 IF(ICOM.EQ.'S/N0')GOTO381 IF(ICOM.EQ.'SNT')GOTO381 IF(ICOM.EQ.'S/NT')GOTO381 IF(ICOM.EQ.'SN+')GOTO382 IF(ICOM.EQ.'S/N+')GOTO382 IF(ICOM.EQ.'SNL ')GOTO382 IF(ICOM.EQ.'SN-')GOTO383 IF(ICOM.EQ.'S/N-')GOTO383 IF(ICOM.EQ.'SNS')GOTO383 IF(ICOM.EQ.'SN00')GOTO384 IF(ICOM.EQ.'SNT2')GOTO384 IF(ICOM.EQ.'S/N2')GOTO384 IF(ICOM.EQ.'SN2')GOTO384 C IF(ICOM.EQ.'CP')GOTO401 IF(ICOM.EQ.'CPK')GOTO402 IF(ICOM.EQ.'CNPK')GOTO398 IF(ICOM.EQ.'CPM')GOTO400 IF(ICOM.EQ.'CC')GOTO399 IF(NUMARG.GE.1)THEN IF(ICOM.EQ.'PERC'.AND.IHARG(1).EQ.'DEFE')GOTO403 IF(ICOM.EQ.'EXPE'.AND.IHARG(1).EQ.'LOSS')GOTO404 ENDIF C IF(NUMARG.GE.1)THEN IF(ICOM.EQ.'NORM'.AND.IHARG(1).EQ.'PPCC')GOTO411 ENDIF C IF(NUMARG.GE.1)THEN IF(ICOM.EQ.'EXTR')GOTO412 ENDIF C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'GEOM'.AND.ICOM2.EQ.'ETRI'.AND.IHARG(1).EQ.'MEAN')GOTO426 C IF(NUMARG.GE.2.AND. 1ICOM.EQ.'GEOM'.AND.ICOM2.EQ.'ETRI'.AND.IHARG(1).EQ.'STAN'.AND. 1IHARG(2).EQ.'DEVI')GOTO436 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'BIWE'.AND.IHARG(1).EQ.'LOCA')GOTO446 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'BIWE'.AND.IHARG(1).EQ.'SCAL')GOTO456 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'WINS'.AND.IHARG(1).EQ.'VARI')GOTO466 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'WINS'.AND.IHARG(1).EQ.'SD')GOTO476 C IF(NUMARG.GE.2.AND. 1ICOM.EQ.'WINS'.AND.IHARG(1).EQ.'STAN'.AND. 1IHARG(2).EQ.'DEVI')GOTO478 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'WINS'.AND.IHARG(1).EQ.'COVA')GOTO480 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'WINS'.AND.IHARG(1).EQ.'CORR')GOTO482 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'BIWE'.AND.IHARG(1).EQ.'MIDV')GOTO484 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'BIWE'.AND. 1IHARG(1).EQ.'MIDC'.AND.IHARG2(1).EQ.'ORRE')GOTO487 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'BIWE'.AND.IHARG(1).EQ.'MIDC')GOTO486 C IF(NUMARG.GE.2.AND. 1ICOM.EQ.'PERC'.AND.IHARG(1).EQ.'BEND'.AND. 1IHARG(2).EQ.'MIDV')GOTO488 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'HODG'.AND.IHARG(1).EQ.'LEHM')GOTO490 C IF(NUMARG.GE.2.AND. 1ICOM.EQ.'QUAN'.AND.IHARG(1).EQ.'STAN'.AND. 1IHARG(2).EQ.'ERRO')GOTO492 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'QUAN')GOTO494 C IF(NUMARG.GE.3.AND. 1ICOM.EQ.'TRIM'.AND.IHARG(1).EQ.'MEAN'.AND. 1IHARG(2).EQ.'STAN'.AND.IHARG(3).EQ.'ERRO')GOTO496 C IF(NUMARG.GE.2.AND. 1ICOM.EQ.'PERC'.AND.IHARG(1).EQ.'BEND'.AND. 1IHARG(2).EQ.'CORR')GOTO498 C IFOUND='NO' GOTO9000 C C ********************** C ** STEP 2-- ** C ** DEFINE ICASPL. ** C ********************** C 201 CONTINUE ICASPL='NUMB' GOTO701 C 202 CONTINUE ICASPL='NUMB' GOTO702 C 211 CONTINUE ICASPL='SUM' GOTO701 C 212 CONTINUE ICASPL='PROD' GOTO701 C 213 CONTINUE ICASPL='INTE' GOTO701 C 221 CONTINUE ICASPL='MIDR' GOTO701 C 222 CONTINUE ICASPL='MEAN' GOTO701 C 223 CONTINUE ICASPL='MIDM' GOTO701 C 224 CONTINUE ICASPL='MEDI' GOTO701 C 225 CONTINUE ICASPL='TRIM' GOTO702 C 226 CONTINUE ICASPL='WINM' GOTO702 C 241 CONTINUE ICASPL='RANG' GOTO701 C 242 CONTINUE ICASPL='MINI' GOTO701 C 243 CONTINUE ICASPL='MAXI' GOTO701 C 251 CONTINUE ICASPL='VAME' GOTO704 C 252 CONTINUE ICASPL='VAME' GOTO703 C 253 CONTINUE ICASPL='VAME' GOTO702 C 254 CONTINUE ICASPL='VARI' GOTO701 C 261 CONTINUE ICASPL='SDME' GOTO705 C 262 CONTINUE ICASPL='SDME' GOTO704 C 263 CONTINUE ICASPL='SDME' GOTO703 C 264 CONTINUE ICASPL='SD' GOTO702 C 265 CONTINUE ICASPL='SD' GOTO701 C 266 CONTINUE ICASPL='SDME' GOTO702 C 271 CONTINUE ICASPL='RESD' GOTO701 C 272 CONTINUE ICASPL='REVA' GOTO701 C 273 CONTINUE ICASPL='REVA' GOTO703 C 274 CONTINUE ICASPL='REVA' GOTO702 C 276 CONTINUE ICASPL='RESD' GOTO702 C 277 CONTINUE ICASPL='RESD' GOTO703 C 278 CONTINUE ICASPL='REVA' GOTO702 C 301 CONTINUE ICASPL='LOWQ' GOTO702 C 302 CONTINUE ICASPL='MIDQ' GOTO702 C 303 CONTINUE ICASPL='UPPQ' GOTO702 C 304 CONTINUE ICASPL='LOWH' GOTO702 C 305 CONTINUE ICASPL='UPPH' GOTO702 C 311 CONTINUE ICASPL='SKEW' GOTO704 C 312 CONTINUE ICASPL='SKEW' GOTO701 C 313 CONTINUE ICASPL='KURT' GOTO704 C 314 CONTINUE ICASPL='KURT' GOTO701 C 321 CONTINUE ICASPL='AUCV' GOTO701 C 322 CONTINUE ICASPL='AUCR' GOTO701 C 331 CONTINUE ICASPL='COVA' ICASV='TWO' GOTO701 C 332 CONTINUE ICASPL='CORR' ICASV='TWO' GOTO701 C 333 CONTINUE ICASPL='RACV' ICASV='TWO' GOTO702 C 334 CONTINUE ICASPL='RACR' ICASV='TWO' GOTO702 C 337 CONTINUE ICASPL='KTAU' ICASV='TWO' GOTO702 C 341 CONTINUE ICASPL='1DEC' GOTO702 C 342 CONTINUE ICASPL='2DEC' GOTO702 C 343 CONTINUE ICASPL='3DEC' GOTO702 C 344 CONTINUE ICASPL='4DEC' GOTO702 C 345 CONTINUE ICASPL='5DEC' GOTO702 C 346 CONTINUE ICASPL='6DEC' GOTO702 C 347 CONTINUE ICASPL='7DEC' GOTO702 C 348 CONTINUE ICASPL='8DEC' GOTO702 C 349 CONTINUE ICASPL='9DEC' GOTO702 C 350 CONTINUE ICASPL='PERC' GOTO701 C 361 CONTINUE ICASPL='SIFR' GOTO702 C 362 CONTINUE ICASPL='SIAM' GOTO702 C 363 CONTINUE ICASPL='LIIN' ICASV='TWO' GOTO702 C 364 CONTINUE ICASPL='LISL' ICASV='TWO' GOTO702 C 365 CONTINUE ICASPL='LIRE' ICASV='TWO' GOTO702 C 366 CONTINUE ICASPL='LICO' ICASV='TWO' GOTO702 C 371 CONTINUE ICASPL='SN0' GOTO702 C 372 CONTINUE ICASPL='SN+' GOTO702 C 373 CONTINUE ICASPL='SN-' GOTO702 C 374 CONTINUE ICASPL='SN00' GOTO702 C 381 CONTINUE ICASPL='SN0' GOTO701 C 382 CONTINUE ICASPL='SN+' GOTO701 C 383 CONTINUE ICASPL='SN-' GOTO701 C 384 CONTINUE ICASPL='SN00' GOTO701 C 398 CONTINUE ICASPL='CNPK' GOTO701 C 399 CONTINUE ICASPL='CC' GOTO701 C 400 CONTINUE ICASPL='CPM' GOTO701 C 401 CONTINUE ICASPL='CP' GOTO701 C 402 CONTINUE ICASPL='CPK' GOTO701 C 403 CONTINUE ICASPL='PEDE' GOTO702 C 404 CONTINUE ICASPL='EXLO' GOTO702 C 411 CONTINUE ICASPL='NOPP' GOTO702 C 412 CONTINUE ICASPL='EXTR' GOTO701 C 413 CONTINUE ICASPL='AAD ' GOTO703 C 414 CONTINUE ICASPL='AAD ' GOTO701 C 415 CONTINUE ICASPL='MAD ' GOTO703 C 416 CONTINUE ICASPL='MAD ' GOTO701 C 426 CONTINUE ICASPL='GEME' GOTO702 C 436 CONTINUE ICASPL='GESD' GOTO703 C 446 CONTINUE ICASPL='BILO' GOTO702 C 456 CONTINUE ICASPL='BISC' GOTO702 C 466 CONTINUE ICASPL='WIVA' GOTO702 C 476 CONTINUE ICASPL='WISD' GOTO702 C 478 CONTINUE ICASPL='WISD' GOTO703 C 480 CONTINUE ICASPL='WICV' ICASV='TWO' GOTO702 C 482 CONTINUE ICASPL='WICR' ICASV='TWO' GOTO702 C 484 CONTINUE ICASPL='BIMV' GOTO702 C 486 CONTINUE ICASPL='BIMC' ICASV='TWO' GOTO702 C 487 CONTINUE ICASPL='BICR' ICASV='TWO' GOTO702 C 488 CONTINUE ICASPL='PBMV' GOTO703 C 490 CONTINUE ICASPL='HLEH' GOTO702 C 492 CONTINUE ICASPL='QUSE' GOTO703 C 494 CONTINUE ICASPL='QUAN' GOTO701 C 496 CONTINUE ICASPL='TMSE' GOTO704 C 498 CONTINUE ICASPL='PBCR' ICASV='TWO' GOTO703 C 500 CONTINUE ICASPL='SNSC' ICASV='TWO' GOTO702 C 502 CONTINUE ICASPL='QNSC' ICASV='TWO' GOTO702 C C ***************************************************** C ** STEP 2-- ** C ** DETERMINE THE LOCATION (IN IHARG(.)) ** C ** OF THE WORD PLOT ** C ** PLACE IT IN ILASTC ** C ***************************************************** C 701 CONTINUE IF(NUMARG.LT.2)GOTO780 IF(IHARG(1).EQ.'INTE'.AND.IHARG(2).EQ.'PLOT')GOTO801 IF(NUMARG.LT.3)GOTO780 IF(IHARG(1).EQ.'INTE'.AND.IHARG(2).EQ.'STAT'.AND. 1 IHARG(3).EQ.'PLOT')GOTO802 GOTO780 C 702 CONTINUE IF(NUMARG.LT.3)GOTO780 IF(IHARG(2).EQ.'INTE'.AND.IHARG(3).EQ.'PLOT')GOTO802 IF(NUMARG.LT.4)GOTO780 IF(IHARG(2).EQ.'INTE'.AND.IHARG(3).EQ.'STAT'.AND. 1 IHARG(4).EQ.'PLOT')GOTO803 GOTO780 C 703 CONTINUE IF(NUMARG.LT.4)GOTO780 IF(IHARG(3).EQ.'INTE'.AND.IHARG(4).EQ.'PLOT')GOTO803 IF(NUMARG.LT.5)GOTO780 IF(IHARG(3).EQ.'INTE'.AND.IHARG(4).EQ.'STAT'.AND. 1 IHARG(5).EQ.'PLOT')GOTO804 GOTO780 C 704 CONTINUE IF(NUMARG.LT.5)GOTO780 IF(IHARG(4).EQ.'INTE'.AND.IHARG(5).EQ.'PLOT')GOTO804 IF(NUMARG.LT.6)GOTO780 IF(IHARG(4).EQ.'INTE'.AND.IHARG(5).EQ.'STAT'.AND. 1 IHARG(6).EQ.'PLOT')GOTO805 GOTO780 C 705 CONTINUE IF(NUMARG.LT.6)GOTO780 IF(IHARG(5).EQ.'INTE'.AND.IHARG(6).EQ.'PLOT')GOTO805 IF(NUMARG.LT.7)GOTO780 IF(IHARG(5).EQ.'INTE'.AND.IHARG(6).EQ.'STAT'.AND. 1IHARG(7).EQ.'PLOT')GOTO806 GOTO780 C 780 CONTINUE IFOUND='NO' ICASPL='UNKN' GOTO9000 C 801 CONTINUE ILASTC=2 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO890 C 802 CONTINUE ILASTC=3 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO890 C 803 CONTINUE ILASTC=4 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO890 C 804 CONTINUE ILASTC=5 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO890 C 805 CONTINUE ILASTC=6 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO890 C 806 CONTINUE ILASTC=7 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO890 C 890 CONTINUE IFOUND='YES' C C ****************************************************** C ** STEP 21-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ****************************************************** C ISTEPN='21' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PISP') 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 C ******************************************** C ** STEP 22-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C ** (THIS WILL BE THE RESPONSE VARIABLE) ** C ******************************************** C ISTEPN='22' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PISP') 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) IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PISP') 1WRITE(ICOUT,2211)IHLEFT,ICOLL,NLEFT 2211 FORMAT('IHLEFT,ICOLL,NLEFT = ',A4,I8,I8) IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PISP') 1CALL DPWRST('XXX','BUG ') C C ******************************************************* C ** STEP 23-- ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (NLEFT) C ** FOR THE RESPONSE VARIABLE IS 2 OR LARGER. ** C ******************************************************* C ISTEPN='23' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PISP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NLEFT.GE.MINN2)GOTO2390 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2311) 2311 FORMAT('***** ERROR IN DPISP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2312) 2312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2321) 2321 FORMAT(' (FOR WHICH AN ... INTERACTION STATISTIC PLOT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2314) 2314 FORMAT(' WAS TO HAVE BEEN FORMED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2315)MINN2 2315 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2316) 2316 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2317) 2317 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2318)(IANS(I),I=1,MIN(IWIDTH,80)) 2318 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 2390 CONTINUE C C ***************************************** C ** STEP 24-- ** C ** CHECK TO SEE THE TYPE SUBCASE ** C ** (BASED ON THE QUALIFIER)-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='24' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PISP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO2460 DO2400J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO2410 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO2410 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO2420 2400 CONTINUE GOTO2490 2410 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO2490 2420 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO2490 C 2460 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2461) 2461 FORMAT('***** INTERNAL ERROR IN DPISP') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2462) 2462 FORMAT(' AT BRANCH POINT 2481--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2463) 2463 FORMAT(' NUMARG LESS THAN 1 EVEN THOUGH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2464) 2464 FORMAT(' NUMARG HAD PREVIOUSLY PASSED THIS TEST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2465)NUMARG 2465 FORMAT(' ONCE ALREADY. VALUE OF NUMARG = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2466) 2466 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2467)(IANS(I),I=1,MIN(IWIDTH,80)) 2467 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 2490 CONTINUE IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'PISP')GOTO2495 WRITE(ICOUT,2491)NUMARG,ILOCQ,ICASEQ 2491 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') 2495 CONTINUE C C ***************************************** C ** STEP 24.5-- ** C ** DETERMINE THE NUMBER OF VARIABLES ** C ***************************************** C ISTEPN='24.5' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PISP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMV2=ILOCQ-1 IF(NUMV2.LT.1.OR.NUMV2.GT.MAXV2)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2481) 2481 FORMAT('***** ERROR IN DPISP') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2482) 2482 FORMAT(' FOR AN INTERACTION STATISTIC PLOT, THE NUMBER OF ', 1 'VARIABLES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2484) 2484 FORMAT(' MUST BE BETWEEN 1 AND ',I8,'. THERE WERE ',I8, 1 'VARIABLES ENTERED.') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2467)(IANS(I),I=1,MIN(IWIDTH,80)) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C C ****************************************************** C ** STEP 25-- ** C ** IF A SECOND ARGUMENT EXISTS, THEN THIS ** C ** INDICATES THAT THE VALUES IN THE ** C ** FIRST VARIABLE ARE TO BE GROUPED ** C ** BASED ON VALUES OF THE SECOND VARIABLE; ** C ** THAT IS, THE SECOND VARAIBLE DEFINES THE ** C ** GROUP NUMBERS WITHIN WHICH THE MEANS, ** C ** STANDARD DEVIATIONS, RANGES, AND ** C ** CUMULATIVE SUMS ARE TO BE COMPUTED. ** C ** THE VALUES IN THE SECOND VARIABLE ** C ** ARE THE X VALUES FOR EACH MEAN, STANDARD ** C ** DEVIATION, ETC. ** C ** IN THE RESULTING INTERACTION STATISTIC PLOT. ** C ** THE VALUES IN THE SECOND VARIABLE ** C ** NEED NOT HAVE BEEN PREVIOUSLY ** C ** SORTED OR HAVE COMMON VALUES ADJACENT. ** C ** IF WE HAVE THE 2-VARIABLE CASE, ** C ** CHECK THE VALIDITY OF THE SECOND (X) VARIABLE. ** C ** NOTE: FOR INTERACTION CASE, AS OPPOSSED TO ** C ** STANDARD STATISTIC PLOT, THERE CAN BE MORE** C ** THAN ONE X VARIABLE, IF SO THEY ARE ** C ** MULTIPLIED TOGETHER TO GET AN X ** C ** INTERACTION TERM. ** C ****************************************************** C 2501 CONTINUE ISTEPN='25' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PISP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C 2530 CONTINUE C DO2539J=2,NUMV2 IHHOR=IHARG(J) IHHOR2=IHARG2(J) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHHOR,IHHOR2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLH(J-1)=IVALUE(ILOCV) NHOR(J)=IN(ILOCV) IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PISP') 1 WRITE(ICOUT,2531)IHHOR,ICOLH(J),NHOR(J) 2531 FORMAT('IHHOR,ICOLH,NHOR = ',A4,I8,I8) IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PISP') 1 CALL DPWRST('XXX','BUG ') IF(NHOR(J).NE.NLEFT)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2571) 2571 FORMAT('***** ERROR IN DPISP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2572) 2572 FORMAT(' FOR AN ... INTERACTION STATISTIC PLOT, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2579) 2579 FORMAT(' THE NUMBER OF ELEMENTS IN EACH VARIABLE MUST BE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2581) 2581 FORMAT(' THE SAME; SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2583)IHLEFT,IHLEF2,NLEFT 2583 FORMAT(' VARIABLE 1 ',A4,A4,' HAS ',I8,' ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2584)J,IHHOR,IHHOR2,NHOR 2584 FORMAT(' VARIABLE ',I4, ',',A4,A4,' HAS ',I8,' ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2587) 2587 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2588)(IANS(I),I=1,MIN(IWIDTH,80)) 2588 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C 2539 CONTINUE C C ************************************************* C ** STEP 26-- ** C ** BRANCH TO THE APPROPRIATE SUBCASE; ** C ** (BASED ON THE QUALIFIER) ** C ** THEN FORM THE RESPONSE VARIABLE ** C ** AND THE SECOND VARIABLE (IF EXISTENT) ** C ************************************************* C ISTEPN='26' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PISP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO2610 IF(ICASEQ.EQ.'SUBS')GOTO2620 IF(ICASEQ.EQ.'FOR')GOTO2630 C 2610 CONTINUE DO2615I=1,NLEFT ISUB(I)=1 2615 CONTINUE NQ=NLEFT GOTO2650 C 2620 CONTINUE NIOLD=NLEFT CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO2650 C 2630 CONTINUE NIOLD=NLEFT CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO2650 C 2650 CONTINUE J=0 IMAX=NLEFT IF(NQ.LT.NLEFT)IMAX=NQ IF(ICASV.EQ.'TWO')THEN JSTART=2 ELSE JSTART=1 ENDIF DO2660I=1,IMAX IF(ISUB(I).EQ.0)GOTO2660 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) IF(NUMV2.LE.1)GOTO2660 C IF(ICASV.EQ.'TWO')THEN IJ=MAXN*(ICOLH(1)-1)+I IF(ICOLH(1).LE.MAXCOL)Z1(J)=V(IJ) IF(ICOLH(1).EQ.MAXCP1)Z1(J)=PRED(I) IF(ICOLH(1).EQ.MAXCP2)Z1(J)=RES(I) IF(ICOLH(1).EQ.MAXCP3)Z1(J)=YPLOT(I) IF(ICOLH(1).EQ.MAXCP4)Z1(J)=XPLOT(I) IF(ICOLH(1).EQ.MAXCP5)Z1(J)=X2PLOT(I) IF(ICOLH(1).EQ.MAXCP6)Z1(J)=TAGPLO(I) ENDIF C IF(NUMV2-1.LT.JSTART)GOTO2660 X1(J)=1.0 DO2665ITEMP=JSTART,NUMV2-1 IJ=MAXN*(ICOLH(ITEMP)-1)+I IF(ICOLH(ITEMP).LE.MAXCOL)X1(J)=X1(J)*V(IJ) IF(ICOLH(ITEMP).EQ.MAXCP1)X1(J)=X1(J)*PRED(I) IF(ICOLH(ITEMP).EQ.MAXCP2)X1(J)=X1(J)*RES(I) IF(ICOLH(ITEMP).EQ.MAXCP3)X1(J)=X1(J)*YPLOT(I) IF(ICOLH(ITEMP).EQ.MAXCP4)X1(J)=X1(J)*XPLOT(I) IF(ICOLH(ITEMP).EQ.MAXCP5)X1(J)=X1(J)*X2PLOT(I) IF(ICOLH(ITEMP).EQ.MAXCP6)X1(J)=X1(J)*TAGPLO(I) 2665 CONTINUE C 2660 CONTINUE NLOCAL=J C C ****************************************************** C ** STEP 27-- ** C ** FOR THE 1-VARIABLE CASE ONLY, ** C ** DETERMINE IF THE ANALYST ** C ** HAS SPECIFIED THE GROUP SIZE, ** C ** FOR THE INTERACTION STATISTIC PLOT ANALYSIS. ** C ** THE GROUP SIZE SETTING IS DEFINED BY SEARCHING THE C ** INTERNAL TABLE FOR THE PARAMETER NAME NI ;* C ** IF FOUND, USE THE SPECIFIED VALUE. ** C ** IF NOT FOUND, GENERATE AN ERROR MESSAGE. ** C ****************************************************** C ISTEPN='27' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PISP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMV2.GE.2)GOTO2790 C IH='NI ' IH2=' ' IHWUSE='P' MESSAG='YES' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) IERROR=IERRO2 IF(IERRO2.EQ.'YES')GOTO9000 ISIZE=VALUE(ILOCP)+0.5 2790 CONTINUE C C ***************************************************** C ** STEP 28-- ** C ** COMPUTE THE APPROPRIATE INTERACTION STATISTIC ** C ** PLOT STATISTIC-- ** C ** (MEAN, STANDARD DEVIATION, RANGE, OR CUSUM). ** C ** COMPUTE CONFIDENCE LINES. ** C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** C ** VALUES Y(.) AND X(.) FOR THE PLOT. ** C ** DEFINE THE VECTOR D(.) TO 1'S, 2'S, AND 3'S ** C ** FOR THE PLOTTED VALUE, THE LOWER CONFIDENCE ** C ** LINE, AND THE UPPER CONFIDENCE LINE. ** C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). ** C ***************************************************** C ISTEPN='28' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PISP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CCCCC JULY 2002. ALL VALUES OF X1 SHOULD BE "-1" OR "+1". CCCCC IF NOT, PRINT AN ERROR MESSAGE. C EPS=1.0E-7 DO2710I=1,NLOCAL IF(ABS(X1(I)).LE.EPS)GOTO2710 IF(ABS(X1(I)-1.0).LE.EPS)GOTO2710 IF(ABS(X1(I)+1.0).LE.EPS)GOTO2710 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2711) 2711 FORMAT('***** ERROR IN INTERACTION PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2713) 2713 FORMAT(' A PRODUCT OF THE INDEPENDENT VARIABLES IS ', 1 'NOT EQUAL TO -1, 0, +1') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 2710 CONTINUE C NUMV2=2 IF(ICASV.EQ.'TWO')NUMV2=3 CALL DPSP2(Y1,Z1,X1,NLOCAL,NUMV2,ICASPL,ISIZE,ICONT, 1TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,XTEMP3,MAXNXT, 1ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1IQUAME,IQUASE, 1Y,X,D,NPLOTP,NPLOTV,ISUBRO,IBUGG3,IERROR) C C C ************************************************* C ** STEP 29-- ** C ** SAVE DIFFERENCE BETWEEN HIGHEST VALUE AND ** C ** LOWEST VALUE OF STATISTIC IN INTERNAL ** C ** PARAMETER ALOWHIGH ** C ************************************************* AMINS=CPUMAX AMAXS=CPUMIN DO2910I=1,NPLOTP IF(D(I).NE.1.0)GOTO2910 IF(Y(I).GT.AMAXS)THEN AMAXS=Y(I) IMAXIN=I ENDIF IF(Y(I).LT.AMINS)THEN AMINS=Y(I) IMININ=I ENDIF 2910 CONTINUE ADIFF=AMAXS-AMINS IF(IMAXIN.GT.IMININ)ADIFF=-ADIFF C ISUBN0='DPSP' C IH='ALOW' IH2='HIGH' VALUE0=ADIFF 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.'PISP')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPISP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ 9012 FORMAT('ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ = ', 1A4,2X,A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IFOUND,IERROR 9013 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 9014 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ', 1I8,I8,I8,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)ISIZE 9015 FORMAT('ISIZE = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)NUMV2 9016 FORMAT('NUMV2 = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)IHLEFT,IHLEF2,ICOLL,NLEFT 9017 FORMAT('IHLEFT,IHLEF2,ICOLL,NLEFT = ',A4,2X,A4,I8,I8) CALL DPWRST('XXX','BUG ') IF(IFOUND.EQ.'NO'.OR.NPLOTP.LE.0)GOTO9090 DO9025I=1,NPLOTP WRITE(ICOUT,9026)I,Y(I),X(I),D(I) 9026 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) CALL DPWRST('XXX','BUG ') 9025 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPJBSP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IBOOSS,ISEED,IBCABT, 1TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT, 1ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) C C PURPOSE--GENERATE ONE OF THE FOLLOWING C JACKNIFE OR BOOTSTRAP STATISTIC PLOTS-- C C FOLLOWING FOR A SINGLE RESPONSE VARIABLE C JACKNIFE/BOOTSTRAP MEAN PLOT C JACKNIFE/BOOTSTRAP MIDM PLOT C JACKNIFE/BOOTSTRAP MEDI PLOT C JACKNIFE/BOOTSTRAP GEOMETRIC MEAN PLOT C JACKNIFE/BOOTSTRAP GEOMETRIC SD PLOT C JACKNIFE/BOOTSTRAP MAD PLOT C JACKNIFE/BOOTSTRAP AAD PLOT C JACKNIFE/BOOTSTRAP SN PLOT C JACKNIFE/BOOTSTRAP QN PLOT C JACKNIFE/BOOTSTRAP VARI PLOT C JACKNIFE/BOOTSTRAP RSD PLOT C JACKNIFE/BOOTSTRAP RANG PLOT C JACKNIFE/BOOTSTRAP MINI PLOT C JACKNIFE/BOOTSTRAP MAXI PLOT C JACKNIFE/BOOTSTRAP SKEW PLOT C JACKNIFE/BOOTSTRAP KURT PLOT C JACKNIFE/BOOTSTRAP AUCR PLOT C JACKNIFE/BOOTSTRAP SDM PLOT C JACKNIFE/BOOTSTRAP AUCV PLOT C JACKNIFE/BOOTSTRAP RACV PLOT C JACKNIFE/BOOTSTRAP SIN FREQUENCY PLOT C JACKNIFE/BOOTSTRAP SIN AMPLITUDE PLOT C JACKNIFE/BOOTSTRAP LOWH PLOT C JACKNIFE/BOOTSTRAP UPPH PLOT C JACKNIFE/BOOTSTRAP LOWQ PLOT C JACKNIFE/BOOTSTRAP UPPQ PLOT C JACKNIFE/BOOTSTRAP TRIM PLOT C JACKNIFE/BOOTSTRAP WINM PLOT C JACKNIFE/BOOTSTRAP MIDQ PLOT C JACKNIFE/BOOTSTRAP 1DEC PLOT C JACKNIFE/BOOTSTRAP 2DEC PLOT C JACKNIFE/BOOTSTRAP 3DEC PLOT C JACKNIFE/BOOTSTRAP 4DEC PLOT C JACKNIFE/BOOTSTRAP 5DEC PLOT C JACKNIFE/BOOTSTRAP 6DEC PLOT C JACKNIFE/BOOTSTRAP 7DEC PLOT C JACKNIFE/BOOTSTRAP 8DEC PLOT C JACKNIFE/BOOTSTRAP 9DEC PLOT C JACKNIFE/BOOTSTRAP PERCENTILE PLOT C JACKNIFE/BOOTSTRAP TAGUCHI SIGNAL-TO-NOISE PLOTS C JACKNIFE/BOOTSTRAP GEOMETRIC MEAN PLOT C JACKNIFE/BOOTSTRAP GEOMETRIC SD PLOT C JACKNIFE/BOOTSTRAP HARMONIC MEAN PLOT C JACKNIFE/BOOTSTRAP IQ RANGE PLOT C JACKNIFE/BOOTSTRAP BIWEIGHT LOCATION PLOT C JACKNIFE/BOOTSTRAP BIWEIGHT SCALE PLOT C JACKNIFE/BOOTSTRAP WINSORIZED VARIANCE PLOT C JACKNIFE/BOOTSTRAP WINSORIZED SD PLOT C JACKNIFE/BOOTSTRAP BIWEIGHT MIDVARIANCE PLOT C JACKNIFE/BOOTSTRAP PERCENTAGE BEND MIDVARIANCE PLOT C JACKNIFE/BOOTSTRAP HODGES LEHMAN PLOT C JACKNIFE/BOOTSTRAP QUANTILE PLOT C JACKNIFE/BOOTSTRAP QUANTILE STANDARD ERROR PLOT C JACKNIFE/BOOTSTRAP TRIMMED MEAN STANDARD ERROR PLOT C JACKNIFE/BOOTSTRAP LINEAR CALIBRATION PLOT C JACKNIFE/BOOTSTRAP QUADRATIC CALIBRATION PLOT C C FOLLOWING FOR TWO RESPONSE VARIABLES C JACKNIFE/BOOTSTRAP LINEAR INTERCEPT PLOT C JACKNIFE/BOOTSTRAP LINEAR SLOPE PLOT C JACKNIFE/BOOTSTRAP LINEAR RESSD PLOT C JACKNIFE/BOOTSTRAP LINEAR CORRELATION PLOT C JACKNIFE/BOOTSTRAP WINSORIZED COVARIANCE PLOT C JACKNIFE/BOOTSTRAP WINSORIZED CORRELATION PLOT C JACKNIFE/BOOTSTRAP BIWEIGHT COVARIANCE PLOT C JACKNIFE/BOOTSTRAP BIWEIGHT CORRELATION PLOT C JACKNIFE/BOOTSTRAP PERCENTAGE BEND CORRELATION PLOT C JACKNIFE/BOOTSTRAP CORRELATION PLOT C JACKNIFE/BOOTSTRAP RANK CORRELATION PLOT C JACKNIFE/BOOTSTRAP COVARIANCE PLOT C JACKNIFE/BOOTSTRAP RANK COVARIANCE PLOT C JACKNIFE/BOOTSTRAP KENDELLS TAU PLOT C JACKNIFE/BOOTSTRAP RATIO PLOT C C FOLLOWING STATISTICS COMPUTE DIFFERENCE IN C STATISTIC FOR TWO RESPONSE VARIABLES (USED FOR C LOCATION AND SCALE STATISTICS): C C LOCATION: C JACKNIFE/BOOTSTRAP DIFF OF MEANS PLOT C JACKNIFE/BOOTSTRAP DIFF OF MIDMEANS PLOT C JACKNIFE/BOOTSTRAP DIFF OF MEDIANS PLOT C JACKNIFE/BOOTSTRAP DIFF OF TRIMMED MEANS PLOT C JACKNIFE/BOOTSTRAP DIFF OF WINSORIZED MEANS PLOT C JACKNIFE/BOOTSTRAP DIFF OF GEOMETRIC MEANS PLOT C JACKNIFE/BOOTSTRAP DIFF OF HARMONIC MEANS PLOT C JACKNIFE/BOOTSTRAP DIFF OF HODGES-LEHMAN PLOT C JACKNIFE/BOOTSTRAP DIFF OF BIWEIGHT LOCATION PLOT C C SCALE: C JACKNIFE/BOOTSTRAP DIFF OF STANDARD DEVIATIONS PLOT C JACKNIFE/BOOTSTRAP DIFF OF VARIANCES PLOT C JACKNIFE/BOOTSTRAP DIFF OF AAD PLOT C JACKNIFE/BOOTSTRAP DIFF OF MAD PLOT C JACKNIFE/BOOTSTRAP DIFF OF SN PLOT C JACKNIFE/BOOTSTRAP DIFF OF QN PLOT C JACKNIFE/BOOTSTRAP DIFF OF INTERQUARTILE RANGE PLOT C JACKNIFE/BOOTSTRAP DIFF OF WINSORIZED SD PLOT C JACKNIFE/BOOTSTRAP DIFF OF WINSORIZED VARIANCE PLOT C JACKNIFE/BOOTSTRAP DIFF OF BIWEIGHT MIDVARIANCE PLOT C JACKNIFE/BOOTSTRAP DIFF OF BIWEIGHT SCALE PLOT C JACKNIFE/BOOTSTRAP DIFF OF PERCENTAGE BEND PLOT C JACKNIFE/BOOTSTRAP DIFF OF GEOMETRIC SD PLOT C JACKNIFE/BOOTSTRAP DIFF OF RANGE PLOT C JACKNIFE/BOOTSTRAP DIFF OF MIDRANGE PLOT C JACKNIFE/BOOTSTRAP DIFF OF QUANTILE PLOT C JACKNIFE/BOOTSTRAP DIFF OF SKEWNESS PLOT C JACKNIFE/BOOTSTRAP DIFF OF KURTOSIS PLOT C JACKNIFE/BOOTSTRAP DIFF OF RELATIVE SD PLOT C JACKNIFE/BOOTSTRAP DIFF OF SD OF MEAN PLOT C JACKNIFE/BOOTSTRAP DIFF OF RELATIVE VARIANCE PLOT C JACKNIFE/BOOTSTRAP DIFF OF VARIANCE OF THE MEAN PLOT C JACKNIFE/BOOTSTRAP DIFF OF MINIMUM PLOT C JACKNIFE/BOOTSTRAP DIFF OF MAXIMUM PLOT C JACKNIFE/BOOTSTRAP DIFF OF EXTREMES PLOT C JACKNIFE/BOOTSTRAP DIFF OF COEFFICENT OF VARI PLOT C JACKNIFE/BOOTSTRAP DIFF OF SUM PLOT C C FOLLOWING FOR DISTRIBUTION: C LOCATION AND SCALE C JACKNIFE/BOOTSTRAP UNIFORM PLOT C JACKNIFE/BOOTSTRAP UNIFORM MLE PLOT C JACKNIFE/BOOTSTRAP NORMAL PLOT C JACKNIFE/BOOTSTRAP NORMAL MLE PLOT C JACKNIFE/BOOTSTRAP LOGISTIC PLOT C JACKNIFE/BOOTSTRAP LOGISTIC MLE PLOT C JACKNIFE/BOOTSTRAP LAPLACE PLOT C JACKNIFE/BOOTSTRAP LAPLACE MLE PLOT C JACKNIFE/BOOTSTRAP CAUCHY PLOT C JACKNIFE/BOOTSTRAP CAUCHY MLE PLOT C JACKNIFE/BOOTSTRAP HALFNORMAL PLOT C JACKNIFE/BOOTSTRAP EXPONENTIAL PLOT C JACKNIFE/BOOTSTRAP EXPONENTIAL MLE PLOT C JACKNIFE/BOOTSTRAP GUMBEL PLOT C JACKNIFE/BOOTSTRAP GUMBEL MLE PLOT C JACKNIFE/BOOTSTRAP SEMICIRCULAR PLOT C JACKNIFE/BOOTSTRAP COSINE PLOT C JACKNIFE/BOOTSTRAP ANGLIT PLOT C JACKNIFE/BOOTSTRAP ARCSINE PLOT C JACKNIFE/BOOTSTRAP HYPERBOLIC SECANT PLOT C JACKNIFE/BOOTSTRAP SLASH PLOT C JACKNIFE/BOOTSTRAP RAYLEIGH PLOT C JACKNIFE/BOOTSTRAP RAYLEIGH MLE PLOT C ONE SHAPE PARAMETER, LOCATION AND SCALE C JACKNIFE/BOOTSTRAP WEIBULL PLOT C JACKNIFE/BOOTSTRAP INVERTED WEIBULL PLOT C JACKNIFE/BOOTSTRAP LOGNORMAL PLOT C JACKNIFE/BOOTSTRAP GAMMA PLOT C JACKNIFE/BOOTSTRAP INVERTED GAMMA PLOT C JACKNIFE/BOOTSTRAP LOG GAMMA PLOT C JACKNIFE/BOOTSTRAP GENERALIZED PARETO PLOT C JACKNIFE/BOOTSTRAP T PLOT C JACKNIFE/BOOTSTRAP CHI SQUARE PLOT C JACKNIFE/BOOTSTRAP CHI PLOT C JACKNIFE/BOOTSTRAP GEOMETRIC EXTR EXPO PLOT C JACKNIFE/BOOTSTRAP FATIGUE LIFE PLOT C JACKNIFE/BOOTSTRAP WALD PLOT C JACKNIFE/BOOTSTRAP PARETO PLOT C JACKNIFE/BOOTSTRAP FRECHET PLOT C JACKNIFE/BOOTSTRAP TUKEY LAMBDA PLOT C JACKNIFE/BOOTSTRAP BRADFORD PLOT C JACKNIFE/BOOTSTRAP RECIPROCAL PLOT C JACKNIFE/BOOTSTRAP ERROR PLOT C JACKNIFE/BOOTSTRAP TRIANGULAR PLOT C JACKNIFE/BOOTSTRAP LOG LOGISTIC PLOT C JACKNIFE/BOOTSTRAP DOUBLE WEIBULL PLOT C JACKNIFE/BOOTSTRAP FOLDED T PLOT C JACKNIFE/BOOTSTRAP SKEW LAPLACE PLOT C JACKNIFE/BOOTSTRAP ASYMETRIC LAPLACE PLOT C JACKNIFE/BOOTSTRAP ASYMETRIC LAPLACE MLE PLOT C JACKNIFE/BOOTSTRAP LOG LAPLACE PLOT C JACKNIFE/BOOTSTRAP GENERALIZED EXTREME VALUE C PLOT C JACKNIFE/BOOTSTRAP GENERALIZED LOGISTIC C PLOT C JACKNIFE/BOOTSTRAP GENERALIZED LOGISTIC TYPE 2 C PLOT C JACKNIFE/BOOTSTRAP GENERALIZED LOGISTIC TYPE 3 C PLOT C JACKNIFE/BOOTSTRAP GENERALIZED LOGISTIC TYPE 5 C PLOT C JACKNIFE/BOOTSTRAP WEIBULL KS PLOT C JACKNIFE/BOOTSTRAP INVERTED WEIBULL KS PLOT C JACKNIFE/BOOTSTRAP LOGNORMAL KS PLOT C JACKNIFE/BOOTSTRAP GAMMA KS PLOT C JACKNIFE/BOOTSTRAP INVERTED GAMMA KS PLOT C JACKNIFE/BOOTSTRAP LOG GAMMA KS PLOT C JACKNIFE/BOOTSTRAP GENERALIZED PARETO KS PLOT C JACKNIFE/BOOTSTRAP T KS PLOT C JACKNIFE/BOOTSTRAP CHI SQUARE KS PLOT C JACKNIFE/BOOTSTRAP GEOM EXTR EXPO SQUARE KS PLOT C JACKNIFE/BOOTSTRAP FATIGUE LIFE SQUARE KS PLOT C JACKNIFE/BOOTSTRAP WALD SQUARE KS PLOT C JACKNIFE/BOOTSTRAP PARETO SQUARE KS PLOT C JACKNIFE/BOOTSTRAP FRECHET SQUARE KS PLOT C JACKNIFE/BOOTSTRAP TUKEY LAMBDA SQUARE KS PLOT C JACKNIFE/BOOTSTRAP POWER KS PLOT C JACKNIFE/BOOTSTRAP VON MISES KS PLOT C JACKNIFE/BOOTSTRAP WRAPPED CAUCHY KS PLOT C JACKNIFE/BOOTSTRAP GENERALIZED LOGISTIC KS PLOT C JACKNIFE/BOOTSTRAP GENERALIZED LOGISTIC TYPE 2 C KS PLOT C JACKNIFE/BOOTSTRAP GENERALIZED LOGISTIC TYPE 3 C KS PLOT C JACKNIFE/BOOTSTRAP GENERALIZED LOGISTIC TYPE 5 C KS PLOT C JACKNIFE/BOOTSTRAP GENERALIZED HALF LOGISTIC C KS PLOT C JACKNIFE/BOOTSTRAP PARETO SECOND KIND KS PLOT C JACKNIFE/BOOTSTRAP GENERALIZED LOGISTIC KS PLOT C JACKNIFE/BOOTSTRAP MAXWELL KS PLOT C ONE SHAPE PARAMETER AND SCALE C JACKNIFE/BOOTSTRAP WEIBULL MLE PLOT C JACKNIFE/BOOTSTRAP LOGNORMAL MLE PLOT C JACKNIFE/BOOTSTRAP GAMMA MLE PLOT C JACKNIFE/BOOTSTRAP GEOM EXTR EXPO MLE PLOT C JACKNIFE/BOOTSTRAP FATIGUE LIFE MLE PLOT C JACKNIFE/BOOTSTRAP GENERALIZED PARETO MLE PLOT C JACKNIFE/BOOTSTRAP GENERALIZED PARETO MOME PLOT C JACKNIFE/BOOTSTRAP FRECHET MLE PLOT C JACKNIFE/BOOTSTRAP INVERTED WEIBULL MLE PLOT C TWO SHAPE PARAMETERS C JACKNIFE/BOOTSTRAP INVERSE GAUSSIAN MLE PLOT C JACKNIFE/BOOTSTRAP PARETO MLE PLOT C JACKNIFE/BOOTSTRAP FOLDED NORMAL MLE 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--89/2 C ORIGINAL VERSION--JANUARY 1989. C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON C UPDATED --FEBRUARY 1994. SYNONYMS FOR TAGUCHI C UPDATED --MARCH 1995. MAD AND AAD PLOTS C UPDATED --MARCH 1998. SAVE CERTAIN PERCENTILE PARAMETERS C AUTOMATICALLY C UPDATED --MARCH 1998. ACTIVATE RELATIVE VARIANCE AND C COEFFICENT OF VARIATION C UPDATED --NOVEMBER 1998. ADD PERCENTILE PLOTS C UPDATED --MARCH 1999. ADD GEOMETRIC MEAN C UPDATED --MARCH 1999. ADD GEOMETRIC STAND DEVIATION C UPDATED --MARCH 1999. ADD HARMONIC MEAN C UPDATED --SEPTEMBER 2001. ADD IQ RANGE C UPDATED --NOVEMBER 2001. ADD BIWEIGHT LOCATION C UPDATED --NOVEMBER 2001. ADD BIWEIGHT SCALE C UPDATED --JULY 2002. ADD WINSORIZED VARIANCE C UPDATED --JULY 2002. ADD WINSORIZED SD C UPDATED --JULY 2002. ADD WINSORIZED COVARIANCE C UPDATED --JULY 2002. ADD WINSORIZED CORRELATION C UPDATED --JULY 2002. ADD BIWEIGHT MIDVARIANCE C UPDATED --JULY 2002. ADD BIWEIGHT MIDCOVARIANCE C UPDATED --JULY 2002. ADD BIWEIGHT MIDCORRELATION C UPDATED --JULY 2002. ADD PERCENTAGE BEND MIDVARIANCE C UPDATED --JULY 2002. ADD PERCENTAGE BEND CORRELATION C UPDATED --JULY 2002. ADD HODGES LEHMAN C UPDATED --JULY 2002. ADD QUANTILE C UPDATED --JULY 2002. ADD QUANTILE STANDARD ERROR C UPDATED --JULY 2002. ADD TRIMMED MEAN STANDARD ERROR C UPDATED --JULY 2002. ADD LINEAR CALIBRATION C UPDATED --JULY 2002. ADD QUADRATIC CALIBRATION C UPDATED --MARCH 2003. ADD 34 "DIFFERENCE OF" STATS C UPDATED --MARCH 2003. FOR "DIFFERENCE OF" STATS, C DISTINGUISH BETWEEN INDEPENDENT C AND DEPENDENT GROUPS C UPDATED --APRIL 2003. ADD SN AND QN (AND DIFFERENCE C OF). REQUIRED ADDITIONAL C SCRATCH ARRAYS. C UPDATED --JULY 2003. SUPPORT FOR TWO GROUP VARIABLES C UPDATED --SEPTEMBER 2003. SUPPORT FOR BCA CONFIDENCE INTERVAL C UPDATED --JANUARY 2005. MAKE COMMAND SEARCH TABLE C DRIVEN C UPDATED --JANUARY 2005. SUPPORT FOR BOOTSTRAPPING OF C DISTRIBUTIONAL MODELS C UPDATED --MARCH 2005. ADD GENERALIZED PARETO MLE C AND MOMENTS C UPDATED --MAY 2005. ADD FRECHET MLE C UPDATED --AUGUST 2005. ADD INVERTED WEIBULL MLE C UPDATED --SEPTEMBER 2005. ADD RATIO C UPDATED --MARCH 2006. UNIFORM MLE PLOT AS SYNONYM C FOR UNIFORM MAXI LIKE C UPDATED --MARCH 2006. ADD GENERALIZIED LOGISTIC C TYPE 2 - TYPE 5 C UPDATED --MARCH 2006. ADD BETA NORMAL C UPDATED --OCTOBER 2006. MAXWELL KS PLOT C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IAND1 CHARACTER*4 IAND2 CHARACTER*4 ICONT CHARACTER*4 ISUBRO CHARACTER*4 IBUGG2 CHARACTER*4 IBUGG3 CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 ICASJB CHARACTER*4 IFLAGD CHARACTER*4 IFLAGV CHARACTER*4 IBCABT CHARACTER*4 ICENSO CHARACTER*4 IMETHD C CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASEQ CHARACTER*4 IH CHARACTER*4 IH2 CHARACTER*4 IHP CHARACTER*4 IHP2 CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CHARACTER*4 IHHOR CHARACTER*4 IHHOR2 CHARACTER*4 IHX CHARACTER*4 IHX2 CHARACTER*4 IHXG CHARACTER*4 IHXG2 CHARACTER*4 IH41 CHARACTER*4 IH42 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C CHARACTER*4 ISTATN(17) CHARACTER*4 ISTAT2(17) C C--------------------------------------------------------------------- C PARAMETER (NUMCHS=516) CHARACTER*4 INAME(NUMCHS,6) CHARACTER*4 INCASE(NUMCHS) CHARACTER*4 INFLAV(NUMCHS) CHARACTER*4 INFLAD(NUMCHS) C INCLUDE 'DPCOPA.INC' C DIMENSION TEMP(*) DIMENSION TEMP2(*) DIMENSION TEMP3(*) DIMENSION XTEMP1(*) DIMENSION XTEMP2(*) C DIMENSION Y1(MAXOBV) DIMENSION Z1(MAXOBV) DIMENSION X1(MAXOBV) INCLUDE 'DPCOZZ.INC' DIMENSION TEMP0(MAXOBV) DIMENSION TEMPZ0(MAXOBV) DIMENSION RES1(MAXOBV) DIMENSION RES2(MAXOBV) DIMENSION XTEMP3(MAXOBV) DIMENSION TEMP4(MAXOBV) DIMENSION TEMP5(MAXOBV) DIMENSION XGRP2(MAXOBV) DIMENSION TEMPTH(MAXOBV) DIMENSION TEMPT2(MAXOBV) DIMENSION TEMP6(MAXOBV) DIMENSION TEMP7(MAXOBV) DIMENSION TEMP8(MAXOBV) DIMENSION QP(MAXOBV) DIMENSION XPERC(MAXOBV) EQUIVALENCE (GARBAG(IGARB1),Y1(1)) EQUIVALENCE (GARBAG(IGARB2),Z1(1)) EQUIVALENCE (GARBAG(IGARB3),X1(1)) EQUIVALENCE (GARBAG(IGARB4),TEMP0(1)) EQUIVALENCE (GARBAG(IGARB5),TEMPZ0(1)) EQUIVALENCE (GARBAG(IGARB6),RES1(1)) EQUIVALENCE (GARBAG(IGARB7),RES2(1)) EQUIVALENCE (GARBAG(IGARB8),XTEMP3(1)) EQUIVALENCE (GARBAG(IGARB9),TEMP4(1)) EQUIVALENCE (GARBAG(IGAR10),TEMP5(1)) EQUIVALENCE (GARBAG(JGAR11),XGRP2(1)) EQUIVALENCE (GARBAG(JGAR12),TEMPTH(1)) EQUIVALENCE (GARBAG(JGAR13),TEMP6(1)) EQUIVALENCE (GARBAG(JGAR14),TEMP7(1)) EQUIVALENCE (GARBAG(JGAR15),TEMP8(1)) EQUIVALENCE (GARBAG(JGAR16),TEMPT2(1)) EQUIVALENCE (GARBAG(JGAR17),QP(1)) EQUIVALENCE (GARBAG(JGAR18),XPERC(1)) C INCLUDE 'DPCOZI.INC' C INTEGER ITEMP1(MAXOBV) INTEGER ITEMP2(MAXOBV) INTEGER ITEMP3(MAXOBV) INTEGER ITEMP4(MAXOBV) INTEGER ITEMP5(MAXOBV) INTEGER ITEMP6(MAXOBV) EQUIVALENCE (IGARBG(IIGAR1),ITEMP1(1)) EQUIVALENCE (IGARBG(IIGAR2),ITEMP2(1)) EQUIVALENCE (IGARBG(IIGAR3),ITEMP3(1)) EQUIVALENCE (IGARBG(IIGAR4),ITEMP4(1)) EQUIVALENCE (IGARBG(IIGAR5),ITEMP5(1)) EQUIVALENCE (IGARBG(IIGAR6),ITEMP6(1)) C INCLUDE 'DPCOZD.INC' C DOUBLE PRECISION DTEMP1(MAXOBV) DOUBLE PRECISION DTEMP2(MAXOBV) DOUBLE PRECISION DTEMP3(MAXOBV) DOUBLE PRECISION DTEMP4(MAXOBV) EQUIVALENCE (DGARBG(IDGAR1),DTEMP1(1)) EQUIVALENCE (DGARBG(IDGAR2),DTEMP2(1)) EQUIVALENCE (DGARBG(IDGAR3),DTEMP3(1)) EQUIVALENCE (DGARBG(IDGAR4),DTEMP4(1)) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' INCLUDE 'DPCOST.INC' INCLUDE 'DPCOS2.INC' INCLUDE 'DPCOMC.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 DATA (ISTATN(I),I=1,17)/ 1'BSD ', 1'BMEA', 1'B975', 1'B025', 1'B001', 1'B005', 1'B01 ', 1'B05 ', 1'B10 ', 1'B20 ', 1'B50 ', 1'B80 ', 1'B90 ', 1'B95 ', 1'B99 ', 1'B995', 1'B999'/ DATA (ISTAT2(I),I=1,17)/ 1' ', 1'N ', 1' ', 1' ', 1' ', 1' ', 1' ', 1' ', 1' ', 1' ', 1' ', 1' ', 1' ', 1' ', 1' ', 1' ', 1' '/ C DATA INCASE(1)/'NUMB'/ DATA (INAME(1,J),J=1,6)/ 1'NUMB',' ',' ',' ',' ',' '/ DATA INFLAV(1)/'ONE '/ DATA INFLAD(1)/'OFF '/ C DATA INCASE(2)/'NUMB'/ DATA (INAME(2,J),J=1,6)/ 1 'SIZE',' ',' ',' ',' ',' '/ DATA INFLAV(2)/'ONE '/ DATA INFLAD(2)/'OFF '/ C DATA INCASE(3)/'NUMB'/ DATA (INAME(3,J),J=1,6)/ 1'COUN',' ',' ',' ',' ',' '/ DATA INFLAV(3)/'ONE '/ DATA INFLAD(3)/'OFF '/ C DATA INCASE(4)/'NUMB'/ DATA (INAME(4,J),J=1,6)/ 1'SAMP','SIZE',' ',' ',' ',' '/ DATA INFLAV(4)/'ONE '/ DATA INFLAD(4)/'OFF '/ C DATA INCASE(5)/'NUMB'/ DATA (INAME(5,J),J=1,6)/ 1'SUBS','SIZE',' ',' ',' ',' '/ DATA INFLAV(5)/'ONE '/ DATA INFLAD(5)/'OFF '/ C DATA INCASE(6)/'SUM '/ DATA (INAME(6,J),J=1,6)/ 1'SUM ',' ',' ',' ',' ',' '/ DATA INFLAV(6)/'ONE '/ DATA INFLAD(6)/'OFF '/ C DATA INCASE(7)/'PROD'/ DATA (INAME(7,J),J=1,6)/ 1'PROD',' ',' ',' ',' ',' '/ DATA INFLAV(7)/'ONE '/ DATA INFLAD(7)/'OFF '/ C DATA INCASE(8)/'MIDR'/ DATA (INAME(8,J),J=1,6)/ 1'MIDR',' ',' ',' ',' ',' '/ DATA INFLAV(8)/'ONE '/ DATA INFLAD(8)/'OFF '/ C DATA INCASE(9)/'MEAN'/ DATA (INAME(9,J),J=1,6)/ 1'MEAN',' ',' ',' ',' ',' '/ DATA INFLAV(9)/'ONE '/ DATA INFLAD(9)/'OFF '/ C DATA INCASE(10)/'AAD '/ DATA (INAME(10,J),J=1,6)/ 1'AAD ',' ',' ',' ',' ',' '/ DATA INFLAV(10)/'ONE '/ DATA INFLAD(10)/'OFF '/ C DATA INCASE(11)/'AAD '/ DATA (INAME(11,J),J=1,6)/ 1'AVER','ABSO','DEVI',' ',' ',' '/ DATA INFLAV(11)/'ONE '/ DATA INFLAD(11)/'OFF '/ C DATA INCASE(12)/'MEAN'/ DATA (INAME(12,J),J=1,6)/ 1'AVER',' ',' ',' ',' ',' '/ DATA INFLAV(12)/'ONE '/ DATA INFLAD(12)/'OFF '/ C DATA INCASE(13)/'MIDM'/ DATA (INAME(13,J),J=1,6)/ 1'MIDM',' ',' ',' ',' ',' '/ DATA INFLAV(13)/'ONE '/ DATA INFLAD(13)/'OFF '/ C DATA INCASE(15)/'MAD '/ DATA (INAME(15,J),J=1,6)/ 1'MAD ',' ',' ',' ',' ',' '/ DATA INFLAV(15)/'ONE '/ DATA INFLAD(15)/'OFF '/ C DATA INCASE(16)/'MAD '/ DATA (INAME(16,J),J=1,6)/ 1'MEDI','ABSO','DEVI',' ',' ',' '/ DATA INFLAV(16)/'ONE '/ DATA INFLAD(16)/'OFF '/ C DATA INCASE(17)/'MEDI'/ DATA (INAME(17,J),J=1,6)/ 1'MEDI',' ',' ',' ',' ',' '/ DATA INFLAV(17)/'ONE '/ DATA INFLAD(17)/'OFF '/ C DATA INCASE(18)/'TRIM'/ DATA (INAME(18,J),J=1,6)/ 1'TRIM','MEAN',' ',' ',' ',' '/ DATA INFLAV(18)/'ONE '/ DATA INFLAD(18)/'OFF '/ C DATA INCASE(19)/'WINM'/ DATA (INAME(19,J),J=1,6)/ 1'WINS','MEAN',' ',' ',' ',' '/ DATA INFLAV(19)/'ONE '/ DATA INFLAD(19)/'OFF '/ C DATA INCASE(20)/'WINM'/ DATA (INAME(20,J),J=1,6)/ 1'WIND','MEAN',' ',' ',' ',' '/ DATA INFLAV(20)/'ONE '/ DATA INFLAD(20)/'OFF '/ C DATA INCASE(21)/'RANG'/ DATA (INAME(21,J),J=1,6)/ 1'RANG',' ',' ',' ',' ',' '/ DATA INFLAV(21)/'ONE '/ DATA INFLAD(21)/'OFF '/ C DATA INCASE(22)/'RANG'/ DATA (INAME(22,J),J=1,6)/ 1'R ',' ',' ',' ',' ',' '/ DATA INFLAV(22)/'ONE '/ DATA INFLAD(22)/'OFF '/ C DATA INCASE(23)/'MINI'/ DATA (INAME(23,J),J=1,6)/ 1'MINI',' ',' ',' ',' ',' '/ DATA INFLAV(23)/'ONE '/ DATA INFLAD(23)/'OFF '/ C DATA INCASE(24)/'MAXI'/ DATA (INAME(24,J),J=1,6)/ 1'MAXI',' ',' ',' ',' ',' '/ DATA INFLAV(24)/'ONE '/ DATA INFLAD(24)/'OFF '/ C DATA INCASE(25)/'EXTR'/ DATA (INAME(25,J),J=1,6)/ 1'EXTR',' ',' ',' ',' ',' '/ DATA INFLAV(25)/'ONE '/ DATA INFLAD(25)/'OFF '/ C DATA INCASE(26)/'VM '/ DATA (INAME(26,J),J=1,6)/ 1'VARI','OF ','THE ','MEAN',' ',' '/ DATA INFLAV(26)/'ONE '/ DATA INFLAD(26)/'OFF '/ C DATA INCASE(27)/'VM '/ DATA (INAME(27,J),J=1,6)/ 1'VARI','OF ','MEAN',' ',' ',' '/ DATA INFLAV(27)/'ONE '/ DATA INFLAD(27)/'OFF '/ C DATA INCASE(28)/'VM '/ DATA (INAME(28,J),J=1,6)/ 1'VARI','MEAN',' ',' ',' ',' '/ DATA INFLAV(28)/'ONE '/ DATA INFLAD(28)/'OFF '/ C DATA INCASE(29)/'VARI'/ DATA (INAME(29,J),J=1,6)/ 1'VARI',' ',' ',' ',' ',' '/ DATA INFLAV(29)/'ONE '/ DATA INFLAD(29)/'OFF '/ C DATA INCASE(30)/'VARI'/ DATA (INAME(30,J),J=1,6)/ 1'VARI',' ',' ',' ',' ',' '/ DATA INFLAV(30)/'ONE '/ DATA INFLAD(30)/'OFF '/ C DATA INCASE(31)/'SDM '/ DATA (INAME(31,J),J=1,6)/ 1'STAN','DEVI','OF ','THE ','MEAN',' '/ DATA INFLAV(31)/'ONE '/ DATA INFLAD(31)/'OFF '/ C DATA INCASE(32)/'SDM '/ DATA (INAME(32,J),J=1,6)/ 1'STAN','DEVI','OF ','MEAN',' ',' '/ DATA INFLAV(32)/'ONE '/ DATA INFLAD(32)/'OFF '/ C DATA INCASE(33)/'SDM '/ DATA (INAME(33,J),J=1,6)/ 1'STAN','DEVI','MEAN',' ',' ',' '/ DATA INFLAV(33)/'ONE '/ DATA INFLAD(33)/'OFF '/ C DATA INCASE(34)/'SD '/ DATA (INAME(34,J),J=1,6)/ 1'STAN','DEVI',' ',' ',' ',' '/ DATA INFLAV(34)/'ONE '/ DATA INFLAD(34)/'OFF '/ C DATA INCASE(35)/'SD '/ DATA (INAME(35,J),J=1,6)/ 1'SD ',' ',' ',' ',' ',' '/ DATA INFLAV(35)/'ONE '/ DATA INFLAD(35)/'OFF '/ C DATA INCASE(36)/'SD '/ DATA (INAME(36,J),J=1,6)/ 1'S ',' ',' ',' ',' ',' '/ DATA INFLAV(36)/'ONE '/ DATA INFLAD(36)/'OFF '/ C DATA INCASE(37)/'RSD '/ DATA (INAME(37,J),J=1,6)/ 1'RS ',' ',' ',' ',' ',' '/ DATA INFLAV(37)/'ONE '/ DATA INFLAD(37)/'OFF '/ C DATA INCASE(38)/'RSD '/ DATA (INAME(38,J),J=1,6)/ 1'RSD ',' ',' ',' ',' ',' '/ DATA INFLAV(38)/'ONE '/ DATA INFLAD(38)/'OFF '/ C DATA INCASE(39)/'RSD '/ DATA (INAME(39,J),J=1,6)/ 1'RELS',' ',' ',' ',' ',' '/ DATA INFLAV(39)/'ONE '/ DATA INFLAD(39)/'OFF '/ C DATA INCASE(40)/'RSD '/ DATA (INAME(40,J),J=1,6)/ 1'RELA','STAN','DEVI',' ',' ',' '/ DATA INFLAV(40)/'ONE '/ DATA INFLAD(40)/'OFF '/ C DATA INCASE(41)/'RSD '/ DATA (INAME(41,J),J=1,6)/ 1'RELA','SD ',' ',' ',' ',' '/ DATA INFLAV(41)/'ONE '/ DATA INFLAD(41)/'OFF '/ C DATA INCASE(42)/'RVAR'/ DATA (INAME(42,J),J=1,6)/ 1'RELA','VARI',' ',' ',' ',' '/ DATA INFLAV(42)/'ONE '/ DATA INFLAD(42)/'OFF '/ C DATA INCASE(43)/'RVAR'/ DATA (INAME(43,J),J=1,6)/ 1'RV ',' ',' ',' ',' ',' '/ DATA INFLAV(43)/'ONE '/ DATA INFLAD(43)/'OFF '/ C DATA INCASE(44)/'RVAR'/ DATA (INAME(44,J),J=1,6)/ 1'RELV',' ',' ',' ',' ',' '/ DATA INFLAV(44)/'ONE '/ DATA INFLAD(44)/'OFF '/ C DATA INCASE(45)/'RVAR'/ DATA (INAME(45,J),J=1,6)/ 1'RVAR',' ',' ',' ',' ',' '/ DATA INFLAV(45)/'ONE '/ DATA INFLAD(45)/'OFF '/ C DATA INCASE(46)/'CVAR'/ DATA (INAME(46,J),J=1,6)/ 1'COEF','VARI',' ',' ',' ',' '/ DATA INFLAV(46)/'ONE '/ DATA INFLAD(46)/'OFF '/ C DATA INCASE(47)/'CVAR'/ DATA (INAME(47,J),J=1,6)/ 1'COEF','OF ','VARI',' ',' ',' '/ DATA INFLAV(47)/'ONE '/ DATA INFLAD(47)/'OFF '/ C DATA INCASE(48)/'CVAR'/ DATA (INAME(48,J),J=1,6)/ 1'COEF','OF ','VARI',' ',' ',' '/ DATA INFLAV(48)/'ONE '/ DATA INFLAD(48)/'OFF '/ C DATA INCASE(49)/'LOWQ'/ DATA (INAME(49,J),J=1,6)/ 1'LOWE','QUAR',' ',' ',' ',' '/ DATA INFLAV(49)/'ONE '/ DATA INFLAD(49)/'OFF '/ C DATA INCASE(50)/'LOWQ'/ DATA (INAME(50,J),J=1,6)/ 1'FIRS','QUAR',' ',' ',' ',' '/ DATA INFLAV(50)/'ONE '/ DATA INFLAD(50)/'OFF '/ C DATA INCASE(51)/'MIDQ'/ DATA (INAME(51,J),J=1,6)/ 1'SECO','QUAR',' ',' ',' ',' '/ DATA INFLAV(51)/'ONE '/ DATA INFLAD(51)/'OFF '/ C DATA INCASE(52)/'UPPQ'/ DATA (INAME(52,J),J=1,6)/ 1'THIR','QUAR',' ',' ',' ',' '/ DATA INFLAV(52)/'ONE '/ DATA INFLAD(52)/'OFF '/ C DATA INCASE(53)/'UPPQ'/ DATA (INAME(53,J),J=1,6)/ 1'UPPE','QUAR',' ',' ',' ',' '/ DATA INFLAV(53)/'ONE '/ DATA INFLAD(53)/'OFF '/ C DATA INCASE(54)/'UPPH'/ DATA (INAME(54,J),J=1,6)/ 1'UPPE','HING',' ',' ',' ',' '/ DATA INFLAV(54)/'ONE '/ DATA INFLAD(54)/'OFF '/ C DATA INCASE(55)/'LOWH'/ DATA (INAME(55,J),J=1,6)/ 1'LOWE','HING',' ',' ',' ',' '/ DATA INFLAV(55)/'ONE '/ DATA INFLAD(55)/'OFF '/ C DATA INCASE(56)/'SKEW'/ DATA (INAME(56,J),J=1,6)/ 1'STAN','THIR','CENT','MOME',' ',' '/ DATA INFLAV(56)/'ONE '/ DATA INFLAD(56)/'OFF '/ C DATA INCASE(57)/'SKEW'/ DATA (INAME(57,J),J=1,6)/ 1'STAN','3RD ','CENT','MOME',' ',' '/ DATA INFLAV(57)/'ONE '/ DATA INFLAD(57)/'OFF '/ C DATA INCASE(58)/'SKEW'/ DATA (INAME(58,J),J=1,6)/ 1'SKEW',' ',' ',' ',' ',' '/ DATA INFLAV(58)/'ONE '/ DATA INFLAD(58)/'OFF '/ C DATA INCASE(59)/'KURT'/ DATA (INAME(59,J),J=1,6)/ 1'STAN','FOUR','CENT','MOME',' ',' '/ DATA INFLAV(59)/'ONE '/ DATA INFLAD(59)/'OFF '/ C DATA INCASE(60)/'KURT'/ DATA (INAME(60,J),J=1,6)/ 1'STAN','4TH ','CENT','MOME',' ',' '/ DATA INFLAV(60)/'ONE '/ DATA INFLAD(60)/'OFF '/ C DATA INCASE(61)/'KURT'/ DATA (INAME(61,J),J=1,6)/ 1'KURT',' ',' ',' ',' ',' '/ DATA INFLAV(61)/'ONE '/ DATA INFLAD(61)/'OFF '/ C DATA INCASE(62)/'AUCV'/ DATA (INAME(62,J),J=1,6)/ 1'AUTO','STAT','PLOT',' ',' ',' '/ DATA INFLAV(62)/'ONE '/ DATA INFLAD(62)/'OFF '/ C DATA INCASE(63)/'AUCR'/ DATA (INAME(63,J),J=1,6)/ 1'AUTO','STAT','PLOT',' ',' ',' '/ DATA INFLAV(63)/'ONE '/ DATA INFLAD(63)/'OFF '/ C DATA INCASE(64)/'AUCR'/ DATA (INAME(64,J),J=1,6)/ 1'AUTO',' ',' ',' ',' ',' '/ DATA INFLAV(64)/'ONE '/ DATA INFLAD(64)/'OFF '/ C DATA INCASE(65)/'AUCV'/ DATA (INAME(65,J),J=1,6)/ 1'AUTO',' ',' ',' ',' ',' '/ DATA INFLAV(65)/'ONE '/ DATA INFLAD(65)/'OFF '/ C DATA INCASE(66)/'RACV'/ DATA (INAME(66,J),J=1,6)/ 1'RANK','COVA',' ',' ',' ',' '/ DATA INFLAV(66)/'TWO '/ DATA INFLAD(66)/'OFF '/ C DATA INCASE(67)/'RACR'/ DATA (INAME(67,J),J=1,6)/ 1'RANK','CORR',' ',' ',' ',' '/ DATA INFLAV(67)/'TWO '/ DATA INFLAD(67)/'OFF '/ C DATA INCASE(68)/'KTAU'/ DATA (INAME(68,J),J=1,6)/ 1'KEND','TAU ',' ',' ',' ',' '/ DATA INFLAV(68)/'TWO '/ DATA INFLAD(68)/'OFF '/ C DATA INCASE(69)/'KTAU'/ DATA (INAME(69,J),J=1,6)/ 1'KEND','TAU ',' ',' ',' ',' '/ DATA INFLAV(69)/'TWO '/ DATA INFLAD(69)/'OFF '/ C DATA INCASE(70)/'1DEC'/ DATA (INAME(70,J),J=1,6)/ 1'FIRS','DECI',' ',' ',' ',' '/ DATA INFLAV(70)/'ONE '/ DATA INFLAD(70)/'OFF '/ C DATA INCASE(71)/'2DEC'/ DATA (INAME(71,J),J=1,6)/ 1'SECO','DECI',' ',' ',' ',' '/ DATA INFLAV(71)/'ONE '/ DATA INFLAD(71)/'OFF '/ C DATA INCASE(72)/'3DEC'/ DATA (INAME(72,J),J=1,6)/ 1'THIR','DECI',' ',' ',' ',' '/ DATA INFLAV(72)/'ONE '/ DATA INFLAD(72)/'OFF '/ C DATA INCASE(73)/'4DEC'/ DATA (INAME(73,J),J=1,6)/ 1'FOUR','DECI',' ',' ',' ',' '/ DATA INFLAV(73)/'ONE '/ DATA INFLAD(73)/'OFF '/ C DATA INCASE(74)/'5DEC'/ DATA (INAME(74,J),J=1,6)/ 1'FIFT','DECI',' ',' ',' ',' '/ DATA INFLAV(74)/'ONE '/ DATA INFLAD(74)/'OFF '/ C DATA INCASE(75)/'6DEC'/ DATA (INAME(75,J),J=1,6)/ 1'SIXT','DECI',' ',' ',' ',' '/ DATA INFLAV(75)/'ONE '/ DATA INFLAD(75)/'OFF '/ C DATA INCASE(76)/'7DEC'/ DATA (INAME(76,J),J=1,6)/ 1'SEVE','DECI',' ',' ',' ',' '/ DATA INFLAV(76)/'ONE '/ DATA INFLAD(76)/'OFF '/ C DATA INCASE(77)/'8DEC'/ DATA (INAME(77,J),J=1,6)/ 1'EIGH','DECI',' ',' ',' ',' '/ DATA INFLAV(77)/'ONE '/ DATA INFLAD(77)/'OFF '/ C DATA INCASE(78)/'9DEC'/ DATA (INAME(78,J),J=1,6)/ 1'NINT','DECI',' ',' ',' ',' '/ DATA INFLAV(78)/'ONE '/ DATA INFLAD(78)/'OFF '/ C DATA INCASE(79)/'PERC'/ DATA (INAME(79,J),J=1,6)/ 1'PERC',' ',' ',' ',' ',' '/ DATA INFLAV(79)/'ONE '/ DATA INFLAD(79)/'OFF '/ C DATA INCASE(80)/'SIFR'/ DATA (INAME(80,J),J=1,6)/ 1'SIN ','FREQ',' ',' ',' ',' '/ DATA INFLAV(80)/'TWO '/ DATA INFLAD(80)/'OFF '/ C DATA INCASE(81)/'SIFR'/ DATA (INAME(81,J),J=1,6)/ 1'SINE','FREQ',' ',' ',' ',' '/ DATA INFLAV(81)/'TWO '/ DATA INFLAD(81)/'OFF '/ C DATA INCASE(82)/'SIAM'/ DATA (INAME(82,J),J=1,6)/ 1'SIN ','AMPL',' ',' ',' ',' '/ DATA INFLAV(82)/'TWO '/ DATA INFLAD(82)/'OFF '/ C DATA INCASE(83)/'SIAM'/ DATA (INAME(83,J),J=1,6)/ 1'SINE','AMPL',' ',' ',' ',' '/ DATA INFLAV(83)/'TWO '/ DATA INFLAD(83)/'OFF '/ C DATA INCASE(84)/'LIIN'/ DATA (INAME(84,J),J=1,6)/ 1'LINE','INTE',' ',' ',' ',' '/ DATA INFLAV(84)/'TWO '/ DATA INFLAD(84)/'OFF '/ C DATA INCASE(85)/'LISL'/ DATA (INAME(85,J),J=1,6)/ 1'LINE','SLOP',' ',' ',' ',' '/ DATA INFLAV(85)/'TWO '/ DATA INFLAD(85)/'OFF '/ C DATA INCASE(86)/'LIRE'/ DATA (INAME(86,J),J=1,6)/ 1'LINE','RESS',' ',' ',' ',' '/ DATA INFLAV(86)/'TWO '/ DATA INFLAD(86)/'OFF '/ C DATA INCASE(87)/'LIRE'/ DATA (INAME(87,J),J=1,6)/ 1'LINE','RESI','SD ',' ',' ',' '/ DATA INFLAV(87)/'TWO '/ DATA INFLAD(87)/'OFF '/ C DATA INCASE(88)/'LIRE'/ DATA (INAME(88,J),J=1,6)/ 1'LINE','RESI','STAN','DEVI',' ',' '/ DATA INFLAV(88)/'TWO '/ DATA INFLAD(88)/'OFF '/ C DATA INCASE(89)/'LICO'/ DATA (INAME(89,J),J=1,6)/ 1'LINE','CORR',' ',' ',' ',' '/ DATA INFLAV(89)/'TWO '/ DATA INFLAD(89)/'OFF '/ C DATA INCASE(90)/'SNSC'/ DATA (INAME(90,J),J=1,6)/ 1'SN ','SCAL',' ',' ',' ',' '/ DATA INFLAV(90)/'ONE '/ DATA INFLAD(90)/'OFF '/ C DATA INCASE(91)/'QNSC'/ DATA (INAME(91,J),J=1,6)/ 1'QN ','SCAL',' ',' ',' ',' '/ DATA INFLAV(91)/'ONE '/ DATA INFLAD(91)/'OFF '/ C DATA INCASE(92)/'SN0 '/ DATA (INAME(92,J),J=1,6)/ 1'TAGU','SN ',' ',' ',' ',' '/ DATA INFLAV(92)/'ONE '/ DATA INFLAD(92)/'OFF '/ C DATA INCASE(93)/'SN0 '/ DATA (INAME(93,J),J=1,6)/ 1'TAGU','SN0 ',' ',' ',' ',' '/ DATA INFLAV(93)/'ONE '/ DATA INFLAD(93)/'OFF '/ C DATA INCASE(94)/'SN0 '/ DATA (INAME(94,J),J=1,6)/ 1'TAGU','SNT ',' ',' ',' ',' '/ DATA INFLAV(94)/'ONE '/ DATA INFLAD(94)/'OFF '/ C DATA INCASE(95)/'SN0 '/ DATA (INAME(95,J),J=1,6)/ 1'TAGU','SNN ',' ',' ',' ',' '/ DATA INFLAV(95)/'ONE '/ DATA INFLAD(95)/'OFF '/ C DATA INCASE(96)/'SN0 '/ DATA (INAME(96,J),J=1,6)/ 1'TAGU','SNT1',' ',' ',' ',' '/ DATA INFLAV(96)/'ONE '/ DATA INFLAD(96)/'OFF '/ C DATA INCASE(97)/'SN0 '/ DATA (INAME(97,J),J=1,6)/ 1'TAGU','SNN1',' ',' ',' ',' '/ DATA INFLAV(97)/'ONE '/ DATA INFLAD(97)/'OFF '/ C DATA INCASE(98)/'SN0 '/ DATA (INAME(98,J),J=1,6)/ 1'TAGU','SN1 ',' ',' ',' ',' '/ DATA INFLAV(98)/'ONE '/ DATA INFLAD(98)/'OFF '/ C DATA INCASE(99)/'SN+ '/ DATA (INAME(99,J),J=1,6)/ 1'TAGU','SNL ',' ',' ',' ',' '/ DATA INFLAV(99)/'ONE '/ DATA INFLAD(99)/'OFF '/ C DATA INCASE(100)/'SN+ '/ DATA (INAME(100,J),J=1,6)/ 1'TAGU','SNB ',' ',' ',' ',' '/ DATA INFLAV(100)/'ONE '/ DATA INFLAD(100)/'OFF '/ C DATA INCASE(101)/'SN+ '/ DATA (INAME(101,J),J=1,6)/ 1'TAGU','SN+ ',' ',' ',' ',' '/ DATA INFLAV(101)/'ONE '/ DATA INFLAD(101)/'OFF '/ C DATA INCASE(102)/'SN- '/ DATA (INAME(102,J),J=1,6)/ 1'TAGU','SNS ',' ',' ',' ',' '/ DATA INFLAV(102)/'ONE '/ DATA INFLAD(102)/'OFF '/ C DATA INCASE(103)/'SN- '/ DATA (INAME(103,J),J=1,6)/ 1'TAGU','SN- ',' ',' ',' ',' '/ DATA INFLAV(103)/'ONE '/ DATA INFLAD(103)/'OFF '/ C DATA INCASE(104)/'SN00'/ DATA (INAME(104,J),J=1,6)/ 1'TAGU','SN2 ',' ',' ',' ',' '/ DATA INFLAV(104)/'ONE '/ DATA INFLAD(104)/'OFF '/ C DATA INCASE(105)/'SN00'/ DATA (INAME(105,J),J=1,6)/ 1'TAGU','SNT2',' ',' ',' ',' '/ DATA INFLAV(105)/'ONE '/ DATA INFLAD(105)/'OFF '/ C DATA INCASE(106)/'SN00'/ DATA (INAME(106,J),J=1,6)/ 1'TAGU','SNN2',' ',' ',' ',' '/ DATA INFLAV(106)/'ONE '/ DATA INFLAD(106)/'OFF '/ C DATA INCASE(107)/'SN00'/ DATA (INAME(107,J),J=1,6)/ 1'TAGU','SN00',' ',' ',' ',' '/ DATA INFLAV(107)/'ONE '/ DATA INFLAD(107)/'OFF '/ C DATA INCASE(108)/'SN0 '/ DATA (INAME(108,J),J=1,6)/ 1'SN0 ',' ',' ',' ',' ',' '/ DATA INFLAV(108)/'ONE '/ DATA INFLAD(108)/'OFF '/ C DATA INCASE(109)/'SN0 '/ DATA (INAME(109,J),J=1,6)/ 1'SN ',' ',' ',' ',' ',' '/ DATA INFLAV(109)/'ONE '/ DATA INFLAD(109)/'OFF '/ C DATA INCASE(110)/'SN0 '/ DATA (INAME(110,J),J=1,6)/ 1'SNT ',' ',' ',' ',' ',' '/ DATA INFLAV(110)/'ONE '/ DATA INFLAD(110)/'OFF '/ C DATA INCASE(111)/'SN0 '/ DATA (INAME(111,J),J=1,6)/ 1'SNN ',' ',' ',' ',' ',' '/ DATA INFLAV(111)/'ONE '/ DATA INFLAD(111)/'OFF '/ C DATA INCASE(112)/'SN0 '/ DATA (INAME(112,J),J=1,6)/ 1'SNT1',' ',' ',' ',' ',' '/ DATA INFLAV(112)/'ONE '/ DATA INFLAD(112)/'OFF '/ C DATA INCASE(113)/'SN0 '/ DATA (INAME(113,J),J=1,6)/ 1'SNN1',' ',' ',' ',' ',' '/ DATA INFLAV(113)/'ONE '/ DATA INFLAD(113)/'OFF '/ C DATA INCASE(114)/'SN0 '/ DATA (INAME(114,J),J=1,6)/ 1'SNN1',' ',' ',' ',' ',' '/ DATA INFLAV(114)/'ONE '/ DATA INFLAD(114)/'OFF '/ C DATA INCASE(115)/'SN0 '/ DATA (INAME(115,J),J=1,6)/ 1'SN1 ',' ',' ',' ',' ',' '/ DATA INFLAV(115)/'ONE '/ DATA INFLAD(115)/'OFF '/ C DATA INCASE(116)/'SN+ '/ DATA (INAME(116,J),J=1,6)/ 1'SNL ',' ',' ',' ',' ',' '/ DATA INFLAV(116)/'ONE '/ DATA INFLAD(116)/'OFF '/ C DATA INCASE(117)/'SN+ '/ DATA (INAME(117,J),J=1,6)/ 1'SNB ',' ',' ',' ',' ',' '/ DATA INFLAV(117)/'ONE '/ DATA INFLAD(117)/'OFF '/ C DATA INCASE(118)/'SN+ '/ DATA (INAME(118,J),J=1,6)/ 1'SN+ ',' ',' ',' ',' ',' '/ DATA INFLAV(118)/'ONE '/ DATA INFLAD(118)/'OFF '/ C DATA INCASE(119)/'SN- '/ DATA (INAME(119,J),J=1,6)/ 1'SN- ',' ',' ',' ',' ',' '/ DATA INFLAV(119)/'ONE '/ DATA INFLAD(119)/'OFF '/ C DATA INCASE(120)/'SN00'/ DATA (INAME(120,J),J=1,6)/ 1'SN00',' ',' ',' ',' ',' '/ DATA INFLAV(120)/'ONE '/ DATA INFLAD(120)/'OFF '/ C DATA INCASE(121)/'SN00'/ DATA (INAME(121,J),J=1,6)/ 1'SNT2',' ',' ',' ',' ',' '/ DATA INFLAV(121)/'ONE '/ DATA INFLAD(121)/'OFF '/ C DATA INCASE(122)/'SN00'/ DATA (INAME(122,J),J=1,6)/ 1'SNN2',' ',' ',' ',' ',' '/ DATA INFLAV(122)/'ONE '/ DATA INFLAD(122)/'OFF '/ C DATA INCASE(123)/'SN00'/ DATA (INAME(123,J),J=1,6)/ 1'SN2 ',' ',' ',' ',' ',' '/ DATA INFLAV(123)/'ONE '/ DATA INFLAD(123)/'OFF '/ C DATA INCASE(124)/'GEME'/ DATA (INAME(124,J),J=1,6)/ 1'GEOM','MEAN',' ',' ',' ',' '/ DATA INFLAV(124)/'ONE '/ DATA INFLAD(124)/'OFF '/ C DATA INCASE(125)/'GESD'/ DATA (INAME(125,J),J=1,6)/ 1'GEOM','SD ',' ',' ',' ',' '/ DATA INFLAV(125)/'ONE '/ DATA INFLAD(125)/'OFF '/ C DATA INCASE(126)/'GESD'/ DATA (INAME(126,J),J=1,6)/ 1'GEOM','STAN','DEVI',' ',' ',' '/ DATA INFLAV(126)/'ONE '/ DATA INFLAD(126)/'OFF '/ C DATA INCASE(127)/'GESD'/ DATA (INAME(127,J),J=1,6)/ 1'GEOM','STAN','DEVI',' ',' ',' '/ DATA INFLAV(127)/'ONE '/ DATA INFLAD(127)/'OFF '/ C DATA INCASE(128)/'HAME'/ DATA (INAME(128,J),J=1,6)/ 1'HARM','MEAN',' ',' ',' ',' '/ DATA INFLAV(128)/'ONE '/ DATA INFLAD(128)/'OFF '/ C DATA INCASE(129)/'IQRA'/ DATA (INAME(129,J),J=1,6)/ 1'IQ ','RANG',' ',' ',' ',' '/ DATA INFLAV(129)/'ONE '/ DATA INFLAD(129)/'OFF '/ C DATA INCASE(130)/'IQRA'/ DATA (INAME(130,J),J=1,6)/ 1'INTE','RANG',' ',' ',' ',' '/ DATA INFLAV(130)/'ONE '/ DATA INFLAD(130)/'OFF '/ C DATA INCASE(131)/'BILO'/ DATA (INAME(131,J),J=1,6)/ 1'BIWE','LOCA',' ',' ',' ',' '/ DATA INFLAV(131)/'ONE '/ DATA INFLAD(131)/'OFF '/ C DATA INCASE(132)/'BISC'/ DATA (INAME(132,J),J=1,6)/ 1'BIWE','SCAL',' ',' ',' ',' '/ DATA INFLAV(132)/'ONE '/ DATA INFLAD(132)/'OFF '/ C DATA INCASE(133)/'WIVA'/ DATA (INAME(133,J),J=1,6)/ 1'WINS','VARI',' ',' ',' ',' '/ DATA INFLAV(133)/'ONE '/ DATA INFLAD(133)/'OFF '/ C DATA INCASE(134)/'WIVA'/ DATA (INAME(134,J),J=1,6)/ 1'WIND','VARI',' ',' ',' ',' '/ DATA INFLAV(134)/'ONE '/ DATA INFLAD(134)/'OFF '/ C DATA INCASE(135)/'WISD'/ DATA (INAME(135,J),J=1,6)/ 1'WINS','SD ',' ',' ',' ',' '/ DATA INFLAV(135)/'ONE '/ DATA INFLAD(135)/'OFF '/ C DATA INCASE(136)/'WISD'/ DATA (INAME(136,J),J=1,6)/ 1'WIND','SD ',' ',' ',' ',' '/ DATA INFLAV(136)/'ONE '/ DATA INFLAD(136)/'OFF '/ C DATA INCASE(137)/'WISD'/ DATA (INAME(137,J),J=1,6)/ 1'WINS','STAN','DEVI',' ',' ',' '/ DATA INFLAV(137)/'ONE '/ DATA INFLAD(137)/'OFF '/ C DATA INCASE(138)/'WISD'/ DATA (INAME(138,J),J=1,6)/ 1'WIND','STAN','DEVI',' ',' ',' '/ DATA INFLAV(138)/'ONE '/ DATA INFLAD(138)/'OFF '/ C DATA INCASE(139)/'WICV'/ DATA (INAME(139,J),J=1,6)/ 1'WINS','COVA',' ',' ',' ',' '/ DATA INFLAV(139)/'TWO '/ DATA INFLAD(139)/'OFF '/ C DATA INCASE(140)/'WICV'/ DATA (INAME(140,J),J=1,6)/ 1'WIND','COVA',' ',' ',' ',' '/ DATA INFLAV(140)/'TWO '/ DATA INFLAD(140)/'OFF '/ C DATA INCASE(141)/'WICR'/ DATA (INAME(141,J),J=1,6)/ 1'WINS','CORR',' ',' ',' ',' '/ DATA INFLAV(141)/'TWO '/ DATA INFLAD(141)/'OFF '/ C DATA INCASE(142)/'WICR'/ DATA (INAME(142,J),J=1,6)/ 1'WIND','CORR',' ',' ',' ',' '/ DATA INFLAV(142)/'TWO '/ DATA INFLAD(142)/'OFF '/ C DATA INCASE(143)/'BICR'/ DATA (INAME(143,J),J=1,6)/ 1'BIWE','MIDC',' ',' ',' ',' '/ DATA INFLAV(143)/'TWO '/ DATA INFLAD(143)/'OFF '/ C DATA INCASE(144)/'BICR'/ DATA (INAME(144,J),J=1,6)/ 1'BIWE','MID ','CORR',' ',' ',' '/ DATA INFLAV(144)/'TWO '/ DATA INFLAD(144)/'OFF '/ C DATA INCASE(145)/'BIMV'/ DATA (INAME(145,J),J=1,6)/ 1'BIWE','MID ','VARI',' ',' ',' '/ DATA INFLAV(145)/'ONE '/ DATA INFLAD(145)/'OFF '/ C DATA INCASE(146)/'BIMV'/ DATA (INAME(146,J),J=1,6)/ 1'BIWE','MIDV',' ',' ',' ',' '/ DATA INFLAV(146)/'ONE '/ DATA INFLAD(146)/'OFF '/ C DATA INCASE(147)/'PBMV'/ DATA (INAME(147,J),J=1,6)/ 1'PERC','BEND','MIDV',' ',' ',' '/ DATA INFLAV(147)/'ONE '/ DATA INFLAD(147)/'OFF '/ C DATA INCASE(148)/'HLEH'/ DATA (INAME(148,J),J=1,6)/ 1'HODG','LEHM',' ',' ',' ',' '/ DATA INFLAV(148)/'ONE '/ DATA INFLAD(148)/'OFF '/ C DATA INCASE(149)/'QUSE'/ DATA (INAME(149,J),J=1,6)/ 1'QUAN','STAN','ERRO',' ',' ',' '/ DATA INFLAV(149)/'ONE '/ DATA INFLAD(149)/'OFF '/ C DATA INCASE(150)/'QUAN'/ DATA (INAME(150,J),J=1,6)/ 1'QUAN',' ',' ',' ',' ',' '/ DATA INFLAV(150)/'ONE '/ DATA INFLAD(150)/'OFF '/ C DATA INCASE(151)/'TMSE'/ DATA (INAME(151,J),J=1,6)/ 1'TRIM','MEAN','STAN','ERRO',' ',' '/ DATA INFLAV(151)/'ONE '/ DATA INFLAD(151)/'OFF '/ C DATA INCASE(152)/'PBCR'/ DATA (INAME(152,J),J=1,6)/ 1'PERC','BEND','CORR',' ',' ',' '/ DATA INFLAV(152)/'TWO '/ DATA INFLAD(152)/'OFF '/ C DATA INCASE(153)/'LICA'/ DATA (INAME(153,J),J=1,6)/ 1'LINE','CALI',' ',' ',' ',' '/ DATA INFLAV(153)/'TWO '/ DATA INFLAD(153)/'OFF '/ C DATA INCASE(154)/'QUCA'/ DATA (INAME(154,J),J=1,6)/ 1'QUAD','CALI',' ',' ',' ',' '/ DATA INFLAV(154)/'TWO '/ DATA INFLAD(154)/'OFF '/ C DATA INCASE(155)/'CP '/ DATA (INAME(155,J),J=1,6)/ 1'CP ',' ',' ',' ',' ',' '/ DATA INFLAV(155)/'ONE '/ DATA INFLAD(155)/'OFF '/ C DATA INCASE(156)/'CPK '/ DATA (INAME(156,J),J=1,6)/ 1'CPK ',' ',' ',' ',' ',' '/ DATA INFLAV(156)/'ONE '/ DATA INFLAD(156)/'OFF '/ C DATA INCASE(157)/'CNPK'/ DATA (INAME(157,J),J=1,6)/ 1'CNPK',' ',' ',' ',' ',' '/ DATA INFLAV(157)/'ONE '/ DATA INFLAD(157)/'OFF '/ C DATA INCASE(158)/'CPM '/ DATA (INAME(158,J),J=1,6)/ 1'CPM ',' ',' ',' ',' ',' '/ DATA INFLAV(158)/'ONE '/ DATA INFLAD(158)/'OFF '/ C DATA INCASE(159)/'CC '/ DATA (INAME(159,J),J=1,6)/ 1'CC ',' ',' ',' ',' ',' '/ DATA INFLAV(159)/'ONE '/ DATA INFLAD(159)/'OFF '/ C DATA INCASE(160)/'CPL '/ DATA (INAME(160,J),J=1,6)/ 1'CPL ',' ',' ',' ',' ',' '/ DATA INFLAV(160)/'ONE '/ DATA INFLAD(160)/'OFF '/ C DATA INCASE(161)/'CPU '/ DATA (INAME(161,J),J=1,6)/ 1'CPU ',' ',' ',' ',' ',' '/ DATA INFLAV(161)/'ONE '/ DATA INFLAD(161)/'OFF '/ C DATA INCASE(162)/'EXLO '/ DATA (INAME(162,J),J=1,6)/ 1'EXPE','LOSS',' ',' ',' ',' '/ DATA INFLAV(162)/'ONE '/ DATA INFLAD(162)/'OFF '/ C DATA INCASE(163)/'PEDE '/ DATA (INAME(163,J),J=1,6)/ 1'PERC','DEFE',' ',' ',' ',' '/ DATA INFLAV(163)/'ONE '/ DATA INFLAD(163)/'OFF '/ C DATA INCASE(164)/'DMEA '/ DATA (INAME(164,J),J=1,6)/ 1'DIFF','OF ','MEAN',' ',' ',' '/ DATA INFLAV(164)/'TWO '/ DATA INFLAD(164)/'ON '/ C DATA INCASE(165)/'DAAD '/ DATA (INAME(165,J),J=1,6)/ 1'DIFF','OF ','AVER','ABSO','DEVI',' '/ DATA INFLAV(165)/'TWO '/ DATA INFLAD(165)/'ON '/ C DATA INCASE(166)/'DMEA '/ DATA (INAME(166,J),J=1,6)/ 1'DIFF','OF ','AVER',' ',' ',' '/ DATA INFLAV(166)/'TWO '/ DATA INFLAD(166)/'ON '/ C DATA INCASE(167)/'DAAD '/ DATA (INAME(167,J),J=1,6)/ 1'DIFF','OF ','AAD ',' ',' ',' '/ DATA INFLAV(167)/'TWO '/ DATA INFLAD(167)/'ON '/ C DATA INCASE(168)/'DMDM '/ DATA (INAME(168,J),J=1,6)/ 1'DIFF','OF ','MIDM',' ',' ',' '/ DATA INFLAV(168)/'TWO '/ DATA INFLAD(168)/'ON '/ C DATA INCASE(169)/'DMAD '/ DATA (INAME(169,J),J=1,6)/ 1'DIFF','OF ','MAD ',' ',' ',' '/ DATA INFLAV(169)/'TWO '/ DATA INFLAD(169)/'ON '/ C DATA INCASE(170)/'DMAD '/ DATA (INAME(170,J),J=1,6)/ 1'DIFF','OF ','MEDI','ABSO','DEVI',' '/ DATA INFLAV(170)/'TWO '/ DATA INFLAD(170)/'ON '/ C DATA INCASE(171)/'DMED '/ DATA (INAME(171,J),J=1,6)/ 1'DIFF','OF ','MEDI',' ',' ',' '/ DATA INFLAV(171)/'TWO '/ DATA INFLAD(171)/'ON '/ C DATA INCASE(172)/'DTRM '/ DATA (INAME(172,J),J=1,6)/ 1'DIFF','OF ','TRIM','MEAN',' ',' '/ DATA INFLAV(172)/'TWO '/ DATA INFLAD(172)/'ON '/ C DATA INCASE(173)/'DWNM '/ DATA (INAME(173,J),J=1,6)/ 1'DIFF','OF ','WINS','MEAN',' ',' '/ DATA INFLAV(173)/'TWO '/ DATA INFLAD(173)/'ON '/ C DATA INCASE(174)/'DWNM '/ DATA (INAME(174,J),J=1,6)/ 1'DIFF','OF ','WIND','MEAN',' ',' '/ DATA INFLAV(174)/'TWO '/ DATA INFLAD(174)/'ON '/ C DATA INCASE(175)/'DGEO '/ DATA (INAME(175,J),J=1,6)/ 1'DIFF','OF ','GEOM','MEAN',' ',' '/ DATA INFLAV(175)/'TWO '/ DATA INFLAD(175)/'ON '/ C DATA INCASE(176)/'DHAR '/ DATA (INAME(176,J),J=1,6)/ 1'DIFF','OF ','HARM','MEAN',' ',' '/ DATA INFLAV(176)/'TWO '/ DATA INFLAD(176)/'ON '/ C DATA INCASE(177)/'DHDL'/ DATA (INAME(177,J),J=1,6)/ 1'DIFF','OF ','HODG','LEHM',' ',' '/ DATA INFLAV(177)/'TWO '/ DATA INFLAD(177)/'ON '/ C DATA INCASE(178)/'DBIW'/ DATA (INAME(178,J),J=1,6)/ 1'DIFF','OF ','BIWE','LOCA',' ',' '/ DATA INFLAV(178)/'TWO '/ DATA INFLAD(178)/'ON '/ C DATA INCASE(179)/'DSD '/ DATA (INAME(179,J),J=1,6)/ 1'DIFF','OF ','STAN','DEVI',' ',' '/ DATA INFLAV(179)/'TWO '/ DATA INFLAD(179)/'ON '/ C DATA INCASE(180)/'DSD '/ DATA (INAME(180,J),J=1,6)/ 1'DIFF','OF ','SD ',' ',' ',' '/ DATA INFLAV(180)/'TWO '/ DATA INFLAD(180)/'ON '/ C DATA INCASE(181)/'DVAR'/ DATA (INAME(181,J),J=1,6)/ 1'DIFF','OF ','VARI',' ',' ',' '/ DATA INFLAV(181)/'TWO '/ DATA INFLAD(181)/'ON '/ C DATA INCASE(182)/'DSDM'/ DATA (INAME(182,J),J=1,6)/ 1'DIFF','OF ','STAN','DEVI','OF ','MEAN'/ DATA INFLAV(182)/'TWO '/ DATA INFLAD(182)/'ON '/ C DATA INCASE(183)/'DSDM'/ DATA (INAME(183,J),J=1,6)/ 1'DIFF','OF ','STAN','DEVI','MEAN',' '/ DATA INFLAV(183)/'TWO '/ DATA INFLAD(183)/'ON '/ C DATA INCASE(184)/'DSDM'/ DATA (INAME(184,J),J=1,6)/ 1'DIFF','OF ','STAN','DEVI','MEAN',' '/ DATA INFLAV(184)/'TWO '/ DATA INFLAD(184)/'ON '/ C DATA INCASE(185)/'DSDM'/ DATA (INAME(185,J),J=1,6)/ 1'DIFF','OF ','SD ','OF ','THE ','MEAN'/ DATA INFLAV(185)/'TWO '/ DATA INFLAD(185)/'ON '/ C DATA INCASE(186)/'DSDM'/ DATA (INAME(186,J),J=1,6)/ 1'DIFF','OF ','SD ','THE ','MEAN',' '/ DATA INFLAV(186)/'TWO '/ DATA INFLAD(186)/'ON '/ C DATA INCASE(187)/'DSDM'/ DATA (INAME(187,J),J=1,6)/ 1'DIFF','OF ','SD ','MEAN',' ',' '/ DATA INFLAV(187)/'TWO '/ DATA INFLAD(187)/'ON '/ C DATA INCASE(188)/'DVAM'/ DATA (INAME(188,J),J=1,6)/ 1'DIFF','OF ','VARI','MEAN',' ',' '/ DATA INFLAV(188)/'TWO '/ DATA INFLAD(188)/'ON '/ C DATA INCASE(189)/'DVAM'/ DATA (INAME(189,J),J=1,6)/ 1'DIFF','OF ','VARI','OF ','MEAN',' '/ DATA INFLAV(189)/'TWO '/ DATA INFLAD(189)/'ON '/ C DATA INCASE(190)/'DVAM'/ DATA (INAME(190,J),J=1,6)/ 1'DIFF','OF ','VARI','OF ','THE ','MEAN'/ DATA INFLAV(190)/'TWO '/ DATA INFLAD(190)/'ON '/ C DATA INCASE(191)/'DIQR'/ DATA (INAME(191,J),J=1,6)/ 1'DIFF','OF ','INTE','RANG',' ',' '/ DATA INFLAV(191)/'TWO '/ DATA INFLAD(191)/'ON '/ C DATA INCASE(192)/'DIQR'/ DATA (INAME(192,J),J=1,6)/ 1'DIFF','OF ','IQ ','RANG',' ',' '/ DATA INFLAV(192)/'TWO '/ DATA INFLAD(192)/'ON '/ C DATA INCASE(193)/'DWSD'/ DATA (INAME(193,J),J=1,6)/ 1'DIFF','OF ','WINS','SD ',' ',' '/ DATA INFLAV(193)/'TWO '/ DATA INFLAD(193)/'ON '/ C DATA INCASE(194)/'DWSD'/ DATA (INAME(194,J),J=1,6)/ 1'DIFF','OF ','WIND','SD ',' ',' '/ DATA INFLAV(194)/'TWO '/ DATA INFLAD(194)/'ON '/ C DATA INCASE(195)/'DWSD'/ DATA (INAME(195,J),J=1,6)/ 1'DIFF','OF ','WINS','STAN','DEVI',' '/ DATA INFLAV(195)/'TWO '/ DATA INFLAD(195)/'ON '/ C DATA INCASE(196)/'DWSD'/ DATA (INAME(196,J),J=1,6)/ 1'DIFF','OF ','WIND','STAN','DEVI',' '/ DATA INFLAV(196)/'TWO '/ DATA INFLAD(196)/'ON '/ C DATA INCASE(197)/'DWVA'/ DATA (INAME(197,J),J=1,6)/ 1'DIFF','OF ','WINS','VARI',' ',' '/ DATA INFLAV(197)/'TWO '/ DATA INFLAD(197)/'ON '/ C DATA INCASE(198)/'DWVA'/ DATA (INAME(198,J),J=1,6)/ 1'DIFF','OF ','WIND','VARI',' ',' '/ DATA INFLAV(198)/'TWO '/ DATA INFLAD(198)/'ON '/ C DATA INCASE(199)/'DBIM'/ DATA (INAME(199,J),J=1,6)/ 1'DIFF','OF ','BIWE','MIDV',' ',' '/ DATA INFLAV(199)/'TWO '/ DATA INFLAD(199)/'ON '/ C DATA INCASE(200)/'DBIS'/ DATA (INAME(200,J),J=1,6)/ 1'DIFF','OF ','BIWE','SCAL',' ',' '/ DATA INFLAV(200)/'TWO '/ DATA INFLAD(200)/'ON '/ C DATA INCASE(201)/'DPBN'/ DATA (INAME(201,J),J=1,6)/ 1'DIFF','OF ','PERC','BEND','MIDV',' '/ DATA INFLAV(201)/'TWO '/ DATA INFLAD(201)/'ON '/ C DATA INCASE(202)/'DGSD'/ DATA (INAME(202,J),J=1,6)/ 1'DIFF','OF ','GEOM','SD ',' ',' '/ DATA INFLAV(202)/'TWO '/ DATA INFLAD(202)/'ON '/ C DATA INCASE(203)/'DGSD'/ DATA (INAME(203,J),J=1,6)/ 1'DIFF','OF ','GEOM','STAN','DEVI',' '/ DATA INFLAV(203)/'TWO '/ DATA INFLAD(203)/'ON '/ C DATA INCASE(204)/'DRAN'/ DATA (INAME(204,J),J=1,6)/ 1'DIFF','OF ','RANG',' ',' ',' '/ DATA INFLAV(204)/'TWO '/ DATA INFLAD(204)/'ON '/ C DATA INCASE(205)/'DMDR'/ DATA (INAME(205,J),J=1,6)/ 1'DIFF','OF ','MIDR',' ',' ',' '/ DATA INFLAV(205)/'TWO '/ DATA INFLAD(205)/'ON '/ C DATA INCASE(206)/'DMDR'/ DATA (INAME(206,J),J=1,6)/ 1'DIFF','OF ','MID ','RANG',' ',' '/ DATA INFLAV(206)/'TWO '/ DATA INFLAD(206)/'ON '/ C DATA INCASE(207)/'DQUA'/ DATA (INAME(207,J),J=1,6)/ 1'DIFF','OF ','QUAN',' ',' ',' '/ DATA INFLAV(207)/'TWO '/ DATA INFLAD(207)/'ON '/ C DATA INCASE(208)/'DSKE'/ DATA (INAME(208,J),J=1,6)/ 1'DIFF','OF ','SKEW',' ',' ',' '/ DATA INFLAV(208)/'TWO '/ DATA INFLAD(208)/'ON '/ C DATA INCASE(209)/'DSKE'/ DATA (INAME(209,J),J=1,6)/ 1'DIFF','OF ','STAN','CENT','THIR','MOME'/ DATA INFLAV(209)/'TWO '/ DATA INFLAD(209)/'ON '/ C DATA INCASE(210)/'DSKE'/ DATA (INAME(210,J),J=1,6)/ 1'DIFF','OF ','STAN','CENT','3RD ','MOME'/ DATA INFLAV(210)/'TWO '/ DATA INFLAD(210)/'ON '/ C DATA INCASE(211)/'DKUR'/ DATA (INAME(211,J),J=1,6)/ 1'DIFF','OF ','KURT',' ',' ',' '/ DATA INFLAV(211)/'TWO '/ DATA INFLAD(211)/'ON '/ C DATA INCASE(212)/'DKUR'/ DATA (INAME(212,J),J=1,6)/ 1'DIFF','OF ','STAN','CENT','FOUR','MOME'/ DATA INFLAV(212)/'TWO '/ DATA INFLAD(212)/'ON '/ C DATA INCASE(213)/'DKUR'/ DATA (INAME(213,J),J=1,6)/ 1'DIFF','OF ','STAN','CENT','4TH ','MOME'/ DATA INFLAV(213)/'TWO '/ DATA INFLAD(213)/'ON '/ C DATA INCASE(214)/'DRSD'/ DATA (INAME(214,J),J=1,6)/ 1'DIFF','OF ','RELA','SD ',' ',' '/ DATA INFLAV(214)/'TWO '/ DATA INFLAD(214)/'ON '/ C DATA INCASE(215)/'DRSD'/ DATA (INAME(215,J),J=1,6)/ 1'DIFF','OF ','RELA','STAN','DEVI',' '/ DATA INFLAV(215)/'TWO '/ DATA INFLAD(215)/'ON '/ C DATA INCASE(216)/'DRVA'/ DATA (INAME(216,J),J=1,6)/ 1'DIFF','OF ','RELA','VARI',' ',' '/ DATA INFLAV(216)/'TWO '/ DATA INFLAD(216)/'ON '/ C DATA INCASE(217)/'DMIN'/ DATA (INAME(217,J),J=1,6)/ 1'DIFF','OF ','MINI',' ',' ',' '/ DATA INFLAV(217)/'TWO '/ DATA INFLAD(217)/'ON '/ C DATA INCASE(218)/'DMAX'/ DATA (INAME(218,J),J=1,6)/ 1'DIFF','OF ','MAXI',' ',' ',' '/ DATA INFLAV(218)/'TWO '/ DATA INFLAD(218)/'ON '/ C DATA INCASE(219)/'DEXT'/ DATA (INAME(219,J),J=1,6)/ 1'DIFF','OF ','EXTR',' ',' ',' '/ DATA INFLAV(219)/'TWO '/ DATA INFLAD(219)/'ON '/ C DATA INCASE(220)/'DCVA'/ DATA (INAME(220,J),J=1,6)/ 1'DIFF','OF ','COEF','OF ','VARI',' '/ DATA INFLAV(220)/'TWO '/ DATA INFLAD(220)/'ON '/ C DATA INCASE(221)/'DCVA'/ DATA (INAME(221,J),J=1,6)/ 1'DIFF','OF ','COEF','VARI',' ',' '/ DATA INFLAV(221)/'TWO '/ DATA INFLAD(221)/'ON '/ C DATA INCASE(222)/'DSN '/ DATA (INAME(222,J),J=1,6)/ 1'DIFF','OF ','SN ','SCAL',' ',' '/ DATA INFLAV(222)/'TWO '/ DATA INFLAD(222)/'ON '/ C DATA INCASE(223)/'DSN '/ DATA (INAME(223,J),J=1,6)/ 1'DIFF','OF ','SN ',' ',' ',' '/ DATA INFLAV(223)/'TWO '/ DATA INFLAD(223)/'ON '/ C DATA INCASE(224)/'DQN '/ DATA (INAME(224,J),J=1,6)/ 1'DIFF','OF ','QN ','SCAL',' ',' '/ DATA INFLAV(224)/'TWO '/ DATA INFLAD(224)/'ON '/ C DATA INCASE(225)/'DQN '/ DATA (INAME(225,J),J=1,6)/ 1'DIFF','OF ','QN ',' ',' ',' '/ DATA INFLAV(225)/'TWO '/ DATA INFLAD(225)/'ON '/ C DATA INCASE(226)/'DSUM'/ DATA (INAME(226,J),J=1,6)/ 1'DIFF','OF ','SUM ',' ',' ',' '/ DATA INFLAV(226)/'TWO '/ DATA INFLAD(226)/'ON '/ C DATA INCASE(227)/'DSUM'/ DATA (INAME(227,J),J=1,6)/ 1'DIFF','OF ','SUMS',' ',' ',' '/ DATA INFLAV(227)/'TWO '/ DATA INFLAD(227)/'ON '/ C DATA INCASE(228)/'COVA'/ DATA (INAME(228,J),J=1,6)/ 1'COVA',' ',' ',' ',' ',' '/ DATA INFLAV(228)/'TWO '/ DATA INFLAD(228)/'OFF '/ C DATA INCASE(229)/'CORR'/ DATA (INAME(229,J),J=1,6)/ 1'CORR',' ',' ',' ',' ',' '/ DATA INFLAV(229)/'TWO '/ DATA INFLAD(229)/'OFF '/ C DATA INCASE(230)/'NOML'/ DATA (INAME(230,J),J=1,6)/ 1'NORM','MAXI','LIKE',' ',' ',' '/ DATA INFLAV(230)/'ONE '/ DATA INFLAD(230)/'OFF '/ C DATA INCASE(231)/'NOML'/ DATA (INAME(231,J),J=1,6)/ 1'NORM','MLE ',' ',' ',' ',' '/ DATA INFLAV(231)/'ONE '/ DATA INFLAD(231)/'OFF '/ C DATA INCASE(232)/'LOML'/ DATA (INAME(232,J),J=1,6)/ 1'LOGI','MAXI','LIKE',' ',' ',' '/ DATA INFLAV(232)/'ONE '/ DATA INFLAD(232)/'OFF '/ C DATA INCASE(233)/'LOML'/ DATA (INAME(233,J),J=1,6)/ 1'LOGI','MLE ',' ',' ',' ',' '/ DATA INFLAV(233)/'ONE '/ DATA INFLAD(233)/'OFF '/ C DATA INCASE(234)/'LAML'/ DATA (INAME(234,J),J=1,6)/ 1'LAPL','MAXI','LIKE',' ',' ',' '/ DATA INFLAV(234)/'ONE '/ DATA INFLAD(234)/'OFF '/ C DATA INCASE(235)/'LAPP'/ DATA (INAME(235,J),J=1,6)/ 1'LAPL',' ',' ',' ',' ',' '/ DATA INFLAV(235)/'ONE '/ DATA INFLAD(235)/'OFF '/ C DATA INCASE(236)/'LAML'/ DATA (INAME(236,J),J=1,6)/ 1'DOUB','EXPO','MAXI','LIKE',' ',' '/ DATA INFLAV(236)/'ONE '/ DATA INFLAD(236)/'OFF '/ C DATA INCASE(237)/'LAPP'/ DATA (INAME(237,J),J=1,6)/ 1'DOUB','EXPO',' ',' ',' ',' '/ DATA INFLAV(237)/'ONE '/ DATA INFLAD(237)/'OFF '/ C DATA INCASE(238)/'UNML'/ DATA (INAME(238,J),J=1,6)/ 1'UNIF','MAXI','LIKE',' ',' ',' '/ DATA INFLAV(238)/'ONE '/ DATA INFLAD(238)/'OFF '/ C DATA INCASE(239)/'UNPP'/ DATA (INAME(239,J),J=1,6)/ 1'UNIF',' ',' ',' ',' ',' '/ DATA INFLAV(239)/'ONE '/ DATA INFLAD(239)/'OFF '/ C DATA INCASE(240)/'CAML'/ DATA (INAME(240,J),J=1,6)/ 1'CAUC','MAXI','LIKE',' ',' ',' '/ DATA INFLAV(240)/'ONE '/ DATA INFLAD(240)/'OFF '/ C DATA INCASE(241)/'CAPP'/ DATA (INAME(241,J),J=1,6)/ 1'CAUC',' ',' ',' ',' ',' '/ DATA INFLAV(241)/'ONE '/ DATA INFLAD(241)/'OFF '/ C DATA INCASE(242)/'EXML'/ DATA (INAME(242,J),J=1,6)/ 1'EXPO','MAXI','LIKE',' ',' ',' '/ DATA INFLAV(242)/'ONE '/ DATA INFLAD(242)/'OFF '/ C DATA INCASE(243)/'EXPP'/ DATA (INAME(243,J),J=1,6)/ 1'EXPO',' ',' ',' ',' ',' '/ DATA INFLAV(243)/'ONE '/ DATA INFLAD(243)/'OFF '/ C DATA INCASE(244)/'GUML'/ DATA (INAME(244,J),J=1,6)/ 1'GUMB','MAXI','LIKE',' ',' ',' '/ DATA INFLAV(244)/'ONE '/ DATA INFLAD(244)/'OFF '/ C DATA INCASE(245)/'GUPP'/ DATA (INAME(245,J),J=1,6)/ 1'GUMB',' ',' ',' ',' ',' '/ DATA INFLAV(245)/'ONE '/ DATA INFLAD(245)/'OFF '/ C DATA INCASE(246)/'GUML'/ DATA (INAME(246,J),J=1,6)/ 1'EV1 ','MAXI','LIKE',' ',' ',' '/ DATA INFLAV(246)/'ONE '/ DATA INFLAD(246)/'OFF '/ C DATA INCASE(247)/'GUPP'/ DATA (INAME(247,J),J=1,6)/ 1'EV1 ',' ',' ',' ',' ',' '/ DATA INFLAV(247)/'ONE '/ DATA INFLAD(247)/'OFF '/ C DATA INCASE(248)/'GUML'/ DATA (INAME(248,J),J=1,6)/ 1'EXTR','VALU','TYPE','1 ','MAXI','LIKE'/ DATA INFLAV(248)/'ONE '/ DATA INFLAD(248)/'OFF '/ C DATA INCASE(249)/'GUPP'/ DATA (INAME(249,J),J=1,6)/ 1'EXTR','VALU','TYPE','1 ',' ',' '/ DATA INFLAV(249)/'ONE '/ DATA INFLAD(249)/'OFF '/ C DATA INCASE(250)/'HNPP'/ DATA (INAME(250,J),J=1,6)/ 1'HALF','NORM',' ',' ',' ',' '/ DATA INFLAV(250)/'ONE '/ DATA INFLAD(250)/'OFF '/ C DATA INCASE(251)/'COPP'/ DATA (INAME(251,J),J=1,6)/ 1'COSI',' ',' ',' ',' ',' '/ DATA INFLAV(251)/'ONE '/ DATA INFLAD(251)/'OFF '/ C DATA INCASE(252)/'RAML'/ DATA (INAME(252,J),J=1,6)/ 1'RAYL','MAXI','LIKE',' ',' ',' '/ DATA INFLAV(252)/'ONE '/ DATA INFLAD(252)/'OFF '/ C DATA INCASE(253)/'RAPP'/ DATA (INAME(253,J),J=1,6)/ 1'RAYL',' ',' ',' ',' ',' '/ DATA INFLAV(253)/'ONE '/ DATA INFLAD(253)/'OFF '/ C DATA INCASE(254)/'SLPP'/ DATA (INAME(254,J),J=1,6)/ 1'SLAS',' ',' ',' ',' ',' '/ DATA INFLAV(254)/'ONE '/ DATA INFLAD(254)/'OFF '/ C DATA INCASE(255)/'ANPP'/ DATA (INAME(255,J),J=1,6)/ 1'ANGL',' ',' ',' ',' ',' '/ DATA INFLAV(255)/'ONE '/ DATA INFLAD(255)/'OFF '/ C DATA INCASE(256)/'ARPP'/ DATA (INAME(256,J),J=1,6)/ 1'ARCS',' ',' ',' ',' ',' '/ DATA INFLAV(256)/'ONE '/ DATA INFLAD(256)/'OFF '/ C DATA INCASE(257)/'LUPP'/ DATA (INAME(257,J),J=1,6)/ 1'LAND',' ',' ',' ',' ',' '/ DATA INFLAV(257)/'ONE '/ DATA INFLAD(257)/'OFF '/ C DATA INCASE(258)/'SEPP'/ DATA (INAME(258,J),J=1,6)/ 1'SEMI','CIRC',' ',' ',' ',' '/ DATA INFLAV(258)/'ONE '/ DATA INFLAD(258)/'OFF '/ C DATA INCASE(259)/'SEPP'/ DATA (INAME(259,J),J=1,6)/ 1'SEMI',' ',' ',' ',' ',' '/ DATA INFLAV(259)/'ONE '/ DATA INFLAD(259)/'OFF '/ C DATA INCASE(260)/'HSPP'/ DATA (INAME(260,J),J=1,6)/ 1'HYPE','SECA',' ',' ',' ',' '/ DATA INFLAV(260)/'ONE '/ DATA INFLAD(260)/'OFF '/ C DATA INCASE(261)/'HCPP'/ DATA (INAME(261,J),J=1,6)/ 1'HALF','CAUC',' ',' ',' ',' '/ DATA INFLAV(261)/'ONE '/ DATA INFLAD(261)/'OFF '/ C DATA INCASE(262)/'DSUM'/ DATA (INAME(262,J),J=1,6)/ 1'DIFF','OF ','SUMS',' ',' ',' '/ DATA INFLAV(262)/'TWO '/ DATA INFLAD(262)/'ON '/ C DATA INCASE(263)/'NOPP'/ DATA (INAME(263,J),J=1,6)/ 1'NORM',' ',' ',' ',' ',' '/ DATA INFLAV(263)/'ONE '/ DATA INFLAD(263)/'OFF '/ C DATA INCASE(264)/'WEML'/ DATA (INAME(264,J),J=1,6)/ 1'WEIB','MAXI','LIKE',' ',' ',' '/ DATA INFLAV(264)/'ONE '/ DATA INFLAD(264)/'OFF '/ C DATA INCASE(265)/'LNML'/ DATA (INAME(265,J),J=1,6)/ 1'LOGN','MAXI','LIKE',' ',' ',' '/ DATA INFLAV(265)/'ONE '/ DATA INFLAD(265)/'OFF '/ C DATA INCASE(266)/'LNML'/ DATA (INAME(266,J),J=1,6)/ 1'LOG ','NORM','MAXI','LIKE',' ',' '/ DATA INFLAV(266)/'ONE '/ DATA INFLAD(266)/'OFF '/ C DATA INCASE(267)/'GAML'/ DATA (INAME(267,J),J=1,6)/ 1'GAMM','MAXI','LIKE',' ',' ',' '/ DATA INFLAV(267)/'ONE '/ DATA INFLAD(267)/'OFF '/ C DATA INCASE(268)/'GIKS'/ DATA (INAME(268,J),J=1,6)/ 1'INVE','GAMM','KS ',' ',' ',' '/ DATA INFLAV(268)/'ONE '/ DATA INFLAD(268)/'OFF '/ C DATA INCASE(269)/'LGKS'/ DATA (INAME(269,J),J=1,6)/ 1'LOG ','GAMM','KS ',' ',' ',' '/ DATA INFLAV(269)/'ONE '/ DATA INFLAD(269)/'OFF '/ C DATA INCASE(270)/'GEKS'/ DATA (INAME(270,J),J=1,6)/ 1'GENE','PARE','KS ',' ',' ',' '/ DATA INFLAV(270)/'ONE '/ DATA INFLAD(270)/'OFF '/ C DATA INCASE(271)/'IWKS'/ DATA (INAME(271,J),J=1,6)/ 1'INVE','WEIB','KS ',' ',' ',' '/ DATA INFLAV(271)/'ONE '/ DATA INFLAD(271)/'OFF '/ C DATA INCASE(272)/'CSKS'/ DATA (INAME(272,J),J=1,6)/ 1'CHI ','SQUA','KS ',' ',' ',' '/ DATA INFLAV(272)/'ONE '/ DATA INFLAD(272)/'OFF '/ C DATA INCASE(273)/'CSKS'/ DATA (INAME(273,J),J=1,6)/ 1'CHIS','KS ',' ',' ',' ',' '/ DATA INFLAV(273)/'ONE '/ DATA INFLAD(273)/'OFF '/ C DATA INCASE(274)/'CHKS'/ DATA (INAME(274,J),J=1,6)/ 1'CHI ','KS ',' ',' ',' ',' '/ DATA INFLAV(274)/'ONE '/ DATA INFLAD(274)/'OFF '/ C DATA INCASE(275)/'TKS'/ DATA (INAME(275,J),J=1,6)/ 1'T ','KS ',' ',' ',' ',' '/ DATA INFLAV(275)/'ONE '/ DATA INFLAD(275)/'OFF '/ C DATA INCASE(276)/'WEML'/ DATA (INAME(276,J),J=1,6)/ 1'WEIB','MLE ',' ',' ',' ',' '/ DATA INFLAV(276)/'ONE '/ DATA INFLAD(276)/'OFF '/ C DATA INCASE(277)/'WEKS'/ DATA (INAME(277,J),J=1,6)/ 1'WEIB','KS ',' ',' ',' ',' '/ DATA INFLAV(277)/'ONE '/ DATA INFLAD(277)/'OFF '/ C DATA INCASE(278)/'LNML'/ DATA (INAME(278,J),J=1,6)/ 1'LOGN','MLE ',' ',' ',' ',' '/ DATA INFLAV(278)/'ONE '/ DATA INFLAD(278)/'OFF '/ C DATA INCASE(279)/'LNKS'/ DATA (INAME(279,J),J=1,6)/ 1'LOGN','KS ',' ',' ',' ',' '/ DATA INFLAV(279)/'ONE '/ DATA INFLAD(279)/'OFF '/ C DATA INCASE(280)/'LNML'/ DATA (INAME(280,J),J=1,6)/ 1'LOG ','NORM','MLE ',' ',' ',' '/ DATA INFLAV(280)/'ONE '/ DATA INFLAD(280)/'OFF '/ C DATA INCASE(281)/'LNKS'/ DATA (INAME(281,J),J=1,6)/ 1'LOG ','NORM','KS ',' ',' ',' '/ DATA INFLAV(281)/'ONE '/ DATA INFLAD(281)/'OFF '/ C DATA INCASE(282)/'GAML'/ DATA (INAME(282,J),J=1,6)/ 1'GAMM','MLE ',' ',' ',' ',' '/ DATA INFLAV(282)/'ONE '/ DATA INFLAD(282)/'OFF '/ C DATA INCASE(283)/'GAKS'/ DATA (INAME(283,J),J=1,6)/ 1'GAMM','KOLM','SMIR',' ',' ',' '/ DATA INFLAV(283)/'ONE '/ DATA INFLAD(283)/'OFF '/ C DATA INCASE(284)/'GAKS'/ DATA (INAME(284,J),J=1,6)/ 1'GAMM','KS ',' ',' ',' ',' '/ DATA INFLAV(284)/'ONE '/ DATA INFLAD(284)/'OFF '/ C DATA INCASE(285)/'GACP'/ DATA (INAME(285,J),J=1,6)/ 1'GAMM',' ',' ',' ',' ',' '/ DATA INFLAV(285)/'ONE '/ DATA INFLAD(285)/'OFF '/ C DATA INCASE(286)/'WEKS'/ DATA (INAME(286,J),J=1,6)/ 1'WEIB','KOLM','SMIR',' ',' ',' '/ DATA INFLAV(286)/'ONE '/ DATA INFLAD(286)/'OFF '/ C DATA INCASE(287)/'LNKS'/ DATA (INAME(287,J),J=1,6)/ 1'LOGN','KOLM','SMIR',' ',' ',' '/ DATA INFLAV(287)/'ONE '/ DATA INFLAD(287)/'OFF '/ C DATA INCASE(288)/'LNCP'/ DATA (INAME(288,J),J=1,6)/ 1'LOGN',' ',' ',' ',' ',' '/ DATA INFLAV(288)/'ONE '/ DATA INFLAD(288)/'OFF '/ C DATA INCASE(289)/'LNKS'/ DATA (INAME(289,J),J=1,6)/ 1'LOG ','NORM','KOLM','SMIR',' ',' '/ DATA INFLAV(289)/'ONE '/ DATA INFLAD(289)/'OFF '/ C DATA INCASE(290)/'LNCP'/ DATA (INAME(290,J),J=1,6)/ 1'LOG ','NORM',' ',' ',' ',' '/ DATA INFLAV(290)/'ONE '/ DATA INFLAD(290)/'OFF '/ C DATA INCASE(291)/'IWKS'/ DATA (INAME(291,J),J=1,6)/ 1'INVE','WEIB','KOLM','SMIR',' ',' '/ DATA INFLAV(291)/'ONE '/ DATA INFLAD(291)/'OFF '/ C DATA INCASE(292)/'IWML'/ DATA (INAME(292,J),J=1,6)/ 1'INVE','WEIB','MAXI','LIKE',' ',' '/ DATA INFLAV(292)/'ONE '/ DATA INFLAD(292)/'OFF '/ C DATA INCASE(293)/'GIKS'/ DATA (INAME(293,J),J=1,6)/ 1'INVE','GAMM','KOLM','SMIR',' ',' '/ DATA INFLAV(293)/'ONE '/ DATA INFLAD(293)/'OFF '/ C DATA INCASE(294)/'GICP'/ DATA (INAME(294,J),J=1,6)/ 1'INVE','GAMM',' ',' ',' ',' '/ DATA INFLAV(294)/'ONE '/ DATA INFLAD(294)/'OFF '/ C DATA INCASE(295)/'LGKS'/ DATA (INAME(295,J),J=1,6)/ 1'LOG ','GAMM','KOLM','SMIR',' ',' '/ DATA INFLAV(295)/'ONE '/ DATA INFLAD(295)/'OFF '/ C DATA INCASE(296)/'LGCP'/ DATA (INAME(296,J),J=1,6)/ 1'LOG ','GAMM',' ',' ',' ',' '/ DATA INFLAV(296)/'ONE '/ DATA INFLAD(296)/'OFF '/ C DATA INCASE(297)/'LGKS'/ DATA (INAME(297,J),J=1,6)/ 1'LOGG','KOLM','SMIR',' ',' ',' '/ DATA INFLAV(297)/'ONE '/ DATA INFLAD(297)/'OFF '/ C DATA INCASE(298)/'LGCP'/ DATA (INAME(298,J),J=1,6)/ 1'LOGG',' ',' ',' ',' ',' '/ DATA INFLAV(298)/'ONE '/ DATA INFLAD(298)/'OFF '/ C DATA INCASE(299)/'GEKS'/ DATA (INAME(299,J),J=1,6)/ 1'GENE','PARE','KOLM','SMIR',' ',' '/ DATA INFLAV(299)/'ONE '/ DATA INFLAD(299)/'OFF '/ C DATA INCASE(300)/'GEML'/ DATA (INAME(300,J),J=1,6)/ 1'GENE','PARE','MLE ',' ',' ',' '/ DATA INFLAV(300)/'ONE '/ DATA INFLAD(300)/'OFF '/ C DATA INCASE(301)/'CSKS'/ DATA (INAME(301,J),J=1,6)/ 1'CHI ','SQUA','KOLM','SMIR',' ',' '/ DATA INFLAV(301)/'ONE '/ DATA INFLAD(301)/'OFF '/ C DATA INCASE(302)/'CSCP'/ DATA (INAME(302,J),J=1,6)/ 1'CHI ','SQUA',' ',' ',' ',' '/ DATA INFLAV(302)/'ONE '/ DATA INFLAD(302)/'OFF '/ C DATA INCASE(303)/'CSKS'/ DATA (INAME(303,J),J=1,6)/ 1'CHIS','KOLM','SMIR',' ',' ',' '/ DATA INFLAV(303)/'ONE '/ DATA INFLAD(303)/'OFF '/ C DATA INCASE(304)/'CSCP'/ DATA (INAME(304,J),J=1,6)/ 1'CHIS',' ',' ',' ',' ',' '/ DATA INFLAV(304)/'ONE '/ DATA INFLAD(304)/'OFF '/ C DATA INCASE(305)/'CHKS'/ DATA (INAME(305,J),J=1,6)/ 1'CHI ','KOLM','SMIR',' ',' ',' '/ DATA INFLAV(305)/'ONE '/ DATA INFLAD(305)/'OFF '/ C DATA INCASE(306)/'CHCP'/ DATA (INAME(306,J),J=1,6)/ 1'CHI ',' ',' ',' ',' ',' '/ DATA INFLAV(306)/'ONE '/ DATA INFLAD(306)/'OFF '/ C DATA INCASE(307)/'TKS'/ DATA (INAME(307,J),J=1,6)/ 1'T ','KOLM','SMIR',' ',' ',' '/ DATA INFLAV(307)/'ONE '/ DATA INFLAD(307)/'OFF '/ C DATA INCASE(308)/'TCP'/ DATA (INAME(308,J),J=1,6)/ 1'T ',' ',' ',' ',' ',' '/ DATA INFLAV(308)/'ONE '/ DATA INFLAD(308)/'OFF '/ C DATA INCASE(309)/'EEKS'/ DATA (INAME(309,J),J=1,6)/ 1'GEOM','EXTR','EXPO','KOLM','SMIR',' '/ DATA INFLAV(309)/'ONE '/ DATA INFLAD(309)/'OFF '/ C DATA INCASE(310)/'EEKS'/ DATA (INAME(310,J),J=1,6)/ 1'GEOM','EXTR','EXPO','KS ',' ',' '/ DATA INFLAV(310)/'ONE '/ DATA INFLAD(310)/'OFF '/ C DATA INCASE(311)/'EEML'/ DATA (INAME(311,J),J=1,6)/ 1'GEOM','EXTR','EXPO','MAXI','LIKE',' '/ DATA INFLAV(311)/'ONE '/ DATA INFLAD(311)/'OFF '/ C DATA INCASE(312)/'EEML'/ DATA (INAME(312,J),J=1,6)/ 1'GEOM','EXTR','EXPO','MLE ',' ',' '/ DATA INFLAV(312)/'ONE '/ DATA INFLAD(312)/'OFF '/ C DATA INCASE(313)/'EECP'/ DATA (INAME(313,J),J=1,6)/ 1'GEOM','EXTR','EXPO',' ',' ',' '/ DATA INFLAV(313)/'ONE '/ DATA INFLAD(313)/'OFF '/ C DATA INCASE(314)/'PAKS'/ DATA (INAME(314,J),J=1,6)/ 1'PARE','KOLM','SMIR',' ',' ',' '/ DATA INFLAV(314)/'ONE '/ DATA INFLAD(314)/'OFF '/ C DATA INCASE(315)/'PAKS'/ DATA (INAME(315,J),J=1,6)/ 1'PARE','KS ',' ',' ',' ',' '/ DATA INFLAV(315)/'ONE '/ DATA INFLAD(315)/'OFF '/ C DATA INCASE(316)/'PAML'/ DATA (INAME(316,J),J=1,6)/ 1'PARE','MAXI','LIKE',' ',' ',' '/ DATA INFLAV(316)/'ONE '/ DATA INFLAD(316)/'OFF '/ C DATA INCASE(317)/'PAML'/ DATA (INAME(317,J),J=1,6)/ 1'PARE','MLE ',' ',' ',' ',' '/ DATA INFLAV(317)/'ONE '/ DATA INFLAD(317)/'OFF '/ C DATA INCASE(318)/'PACP'/ DATA (INAME(318,J),J=1,6)/ 1'PARE',' ',' ',' ',' ',' '/ DATA INFLAV(318)/'ONE '/ DATA INFLAD(318)/'OFF '/ C DATA INCASE(319)/'WAKS'/ DATA (INAME(319,J),J=1,6)/ 1'WALD','KOLM','SMIR',' ',' ',' '/ DATA INFLAV(319)/'ONE '/ DATA INFLAD(319)/'OFF '/ C DATA INCASE(320)/'WAKS'/ DATA (INAME(320,J),J=1,6)/ 1'WALD','KS ',' ',' ',' ',' '/ DATA INFLAV(320)/'ONE '/ DATA INFLAD(320)/'OFF '/ C DATA INCASE(321)/'WAML'/ DATA (INAME(321,J),J=1,6)/ 1'WALD','MAXI','LIKE',' ',' ',' '/ DATA INFLAV(321)/'ONE '/ DATA INFLAD(321)/'OFF '/ C DATA INCASE(322)/'WAML'/ DATA (INAME(322,J),J=1,6)/ 1'WALD','MLE ',' ',' ',' ',' '/ DATA INFLAV(322)/'ONE '/ DATA INFLAD(322)/'OFF '/ C DATA INCASE(323)/'WACP'/ DATA (INAME(323,J),J=1,6)/ 1'WALD',' ',' ',' ',' ',' '/ DATA INFLAV(323)/'ONE '/ DATA INFLAD(323)/'OFF '/ C DATA INCASE(324)/'FLKS'/ DATA (INAME(324,J),J=1,6)/ 1'FATI','LIFE','KOLM','SMIR',' ',' '/ DATA INFLAV(324)/'ONE '/ DATA INFLAD(324)/'OFF '/ C DATA INCASE(325)/'FLKS'/ DATA (INAME(325,J),J=1,6)/ 1'FATI','LIFE','KS ',' ',' ',' '/ DATA INFLAV(325)/'ONE '/ DATA INFLAD(325)/'OFF '/ C DATA INCASE(326)/'FLML'/ DATA (INAME(326,J),J=1,6)/ 1'FATI','LIFE','MAXI','LIKE',' ',' '/ DATA INFLAV(326)/'ONE '/ DATA INFLAD(326)/'OFF '/ C DATA INCASE(327)/'FLML'/ DATA (INAME(327,J),J=1,6)/ 1'FATI','LIFE','MLE ',' ',' ',' '/ DATA INFLAV(327)/'ONE '/ DATA INFLAD(327)/'OFF '/ C DATA INCASE(328)/'FLCP'/ DATA (INAME(328,J),J=1,6)/ 1'FATI','LIFE',' ',' ',' ',' '/ DATA INFLAV(328)/'ONE '/ DATA INFLAD(328)/'OFF '/ C DATA INCASE(329)/'FLKS'/ DATA (INAME(329,J),J=1,6)/ 1'BIRN','SAUN','KOLM','SMIR',' ',' '/ DATA INFLAV(329)/'ONE '/ DATA INFLAD(329)/'OFF '/ C DATA INCASE(330)/'FLKS'/ DATA (INAME(330,J),J=1,6)/ 1'BIRN','SAUN','KS ',' ',' ',' '/ DATA INFLAV(330)/'ONE '/ DATA INFLAD(330)/'OFF '/ C DATA INCASE(331)/'FLML'/ DATA (INAME(331,J),J=1,6)/ 1'BIRN','SAUN','MAXI','LIKE',' ',' '/ DATA INFLAV(331)/'ONE '/ DATA INFLAD(331)/'OFF '/ C DATA INCASE(332)/'FLML'/ DATA (INAME(332,J),J=1,6)/ 1'BIRN','SAUN','MLE ',' ',' ',' '/ DATA INFLAV(332)/'ONE '/ DATA INFLAD(332)/'OFF '/ C DATA INCASE(333)/'FLCP'/ DATA (INAME(333,J),J=1,6)/ 1'BIRN','SAUN',' ',' ',' ',' '/ DATA INFLAV(333)/'ONE '/ DATA INFLAD(333)/'OFF '/ C DATA INCASE(334)/'E2KS'/ DATA (INAME(334,J),J=1,6)/ 1'FREC','KOLM','SMIR',' ',' ',' '/ DATA INFLAV(334)/'ONE '/ DATA INFLAD(334)/'OFF '/ C DATA INCASE(335)/'E2KS'/ DATA (INAME(335,J),J=1,6)/ 1'FREC','KS ',' ',' ',' ',' '/ DATA INFLAV(335)/'ONE '/ DATA INFLAD(335)/'OFF '/ C DATA INCASE(336)/'FRML'/ DATA (INAME(336,J),J=1,6)/ 1'FREC','MAXI','LIKE',' ',' ',' '/ DATA INFLAV(336)/'ONE '/ DATA INFLAD(336)/'OFF '/ C DATA INCASE(337)/'FRML'/ DATA (INAME(337,J),J=1,6)/ 1'FREC','MLE ',' ',' ',' ',' '/ DATA INFLAV(337)/'ONE '/ DATA INFLAD(337)/'OFF '/ C DATA INCASE(338)/'E2CP'/ DATA (INAME(338,J),J=1,6)/ 1'FREC',' ',' ',' ',' ',' '/ DATA INFLAV(338)/'ONE '/ DATA INFLAD(338)/'OFF '/ C DATA INCASE(339)/'LAKS'/ DATA (INAME(339,J),J=1,6)/ 1'TUKE','LAMB','KOLM','SMIR',' ',' '/ DATA INFLAV(339)/'ONE '/ DATA INFLAD(339)/'OFF '/ C DATA INCASE(340)/'LAKS'/ DATA (INAME(340,J),J=1,6)/ 1'TUKE','LAMB','KS ',' ',' ',' '/ DATA INFLAV(340)/'ONE '/ DATA INFLAD(340)/'OFF '/ C DATA INCASE(341)/'LACP'/ DATA (INAME(341,J),J=1,6)/ 1'TUKE','LAMB',' ',' ',' ',' '/ DATA INFLAV(341)/'ONE '/ DATA INFLAD(341)/'OFF '/ C DATA INCASE(342)/'LAKS'/ DATA (INAME(342,J),J=1,6)/ 1'LAMB','KOLM','SMIR',' ',' ',' '/ DATA INFLAV(342)/'ONE '/ DATA INFLAD(342)/'OFF '/ C DATA INCASE(343)/'LAKS'/ DATA (INAME(343,J),J=1,6)/ 1'LAMB','KS ',' ',' ',' ',' '/ DATA INFLAV(343)/'ONE '/ DATA INFLAD(343)/'OFF '/ C DATA INCASE(344)/'LACP'/ DATA (INAME(344,J),J=1,6)/ 1'LAMB',' ',' ',' ',' ',' '/ DATA INFLAV(344)/'ONE '/ DATA INFLAD(344)/'OFF '/ C DATA INCASE(345)/'WECP'/ DATA (INAME(345,J),J=1,6)/ 1'WEIB',' ',' ',' ',' ',' '/ DATA INFLAV(345)/'ONE '/ DATA INFLAD(345)/'OFF '/ C DATA INCASE(346)/'GHKS'/ DATA (INAME(346,J),J=1,6)/ 1'GH ','KOLM','SMIR',' ',' ',' '/ DATA INFLAV(346)/'ONE '/ DATA INFLAD(346)/'OFF '/ C DATA INCASE(347)/'GHKS'/ DATA (INAME(347,J),J=1,6)/ 1'GH ','KS ',' ',' ',' ',' '/ DATA INFLAV(347)/'ONE '/ DATA INFLAD(347)/'OFF '/ C DATA INCASE(348)/'GHCP'/ DATA (INAME(348,J),J=1,6)/ 1'GH ',' ',' ',' ',' ',' '/ DATA INFLAV(348)/'ONE '/ DATA INFLAD(348)/'OFF '/ C DATA INCASE(349)/'GHKS'/ DATA (INAME(349,J),J=1,6)/ 1'G ','H ','KOLM','SMIR',' ',' '/ DATA INFLAV(349)/'ONE '/ DATA INFLAD(349)/'OFF '/ C DATA INCASE(350)/'GHKS'/ DATA (INAME(350,J),J=1,6)/ 1'G ','H ','KS ',' ',' ',' '/ DATA INFLAV(350)/'ONE '/ DATA INFLAD(350)/'OFF '/ C DATA INCASE(351)/'GHCP'/ DATA (INAME(351,J),J=1,6)/ 1'G ','H ',' ',' ',' ',' '/ DATA INFLAV(351)/'ONE '/ DATA INFLAD(351)/'OFF '/ C DATA INCASE(352)/'GHKS'/ DATA (INAME(352,J),J=1,6)/ 1'G ','AND ','H ','KOLM','SMIR',' '/ DATA INFLAV(352)/'ONE '/ DATA INFLAD(352)/'OFF '/ C DATA INCASE(353)/'GHKS'/ DATA (INAME(353,J),J=1,6)/ 1'G ','AND ','H ','KS ',' ',' '/ DATA INFLAV(353)/'ONE '/ DATA INFLAD(353)/'OFF '/ C DATA INCASE(354)/'GHCP'/ DATA (INAME(354,J),J=1,6)/ 1'G ','AND ','H ',' ',' ',' '/ DATA INFLAV(354)/'ONE '/ DATA INFLAD(354)/'OFF '/ C DATA INCASE(355)/'BRKS'/ DATA (INAME(355,J),J=1,6)/ 1'BRAD','KOLM','SMIR',' ',' ',' '/ DATA INFLAV(355)/'ONE '/ DATA INFLAD(355)/'OFF '/ C DATA INCASE(356)/'BRKS'/ DATA (INAME(356,J),J=1,6)/ 1'BRAD','KS ',' ',' ',' ',' '/ DATA INFLAV(356)/'ONE '/ DATA INFLAD(356)/'OFF '/ C DATA INCASE(357)/'BRCP'/ DATA (INAME(357,J),J=1,6)/ 1'BRAD',' ',' ',' ',' ',' '/ DATA INFLAV(357)/'ONE '/ DATA INFLAD(357)/'OFF '/ C DATA INCASE(358)/'REKS'/ DATA (INAME(358,J),J=1,6)/ 1'RECI','KOLM','SMIR',' ',' ',' '/ DATA INFLAV(358)/'ONE '/ DATA INFLAD(358)/'OFF '/ C DATA INCASE(359)/'REKS'/ DATA (INAME(359,J),J=1,6)/ 1'RECI','KS ',' ',' ',' ',' '/ DATA INFLAV(359)/'ONE '/ DATA INFLAD(359)/'OFF '/ C DATA INCASE(360)/'RECP'/ DATA (INAME(360,J),J=1,6)/ 1'RECI',' ',' ',' ',' ',' '/ DATA INFLAV(360)/'ONE '/ DATA INFLAD(360)/'OFF '/ C DATA INCASE(361)/'ERKS'/ DATA (INAME(361,J),J=1,6)/ 1'ERRO','KOLM','SMIR',' ',' ',' '/ DATA INFLAV(361)/'ONE '/ DATA INFLAD(361)/'OFF '/ C DATA INCASE(362)/'ERKS'/ DATA (INAME(362,J),J=1,6)/ 1'ERRO','KS ',' ',' ',' ',' '/ DATA INFLAV(362)/'ONE '/ DATA INFLAD(362)/'OFF '/ C DATA INCASE(363)/'ERCP'/ DATA (INAME(363,J),J=1,6)/ 1'ERRO',' ',' ',' ',' ',' '/ DATA INFLAV(363)/'ONE '/ DATA INFLAD(363)/'OFF '/ C DATA INCASE(364)/'ERKS'/ DATA (INAME(364,J),J=1,6)/ 1'SUBB','KOLM','SMIR',' ',' ',' '/ DATA INFLAV(364)/'ONE '/ DATA INFLAD(364)/'OFF '/ C DATA INCASE(365)/'ERKS'/ DATA (INAME(365,J),J=1,6)/ 1'SUBB','KS ',' ',' ',' ',' '/ DATA INFLAV(365)/'ONE '/ DATA INFLAD(365)/'OFF '/ C DATA INCASE(366)/'ERCP'/ DATA (INAME(366,J),J=1,6)/ 1'SUBB',' ',' ',' ',' ',' '/ DATA INFLAV(366)/'ONE '/ DATA INFLAD(366)/'OFF '/ C DATA INCASE(367)/'TRKS'/ DATA (INAME(367,J),J=1,6)/ 1'TRIA','KOLM','SMIR',' ',' ',' '/ DATA INFLAV(367)/'ONE '/ DATA INFLAD(367)/'OFF '/ C DATA INCASE(368)/'TRKS'/ DATA (INAME(368,J),J=1,6)/ 1'TRIA','KS ',' ',' ',' ',' '/ DATA INFLAV(368)/'ONE '/ DATA INFLAD(368)/'OFF '/ C DATA INCASE(369)/'TRCP'/ DATA (INAME(369,J),J=1,6)/ 1'TRIA',' ',' ',' ',' ',' '/ DATA INFLAV(369)/'ONE '/ DATA INFLAD(369)/'OFF '/ C DATA INCASE(370)/'LLKS'/ DATA (INAME(370,J),J=1,6)/ 1'LOG ','LOGI','KOLM','SMIR',' ',' '/ DATA INFLAV(370)/'ONE '/ DATA INFLAD(370)/'OFF '/ C DATA INCASE(371)/'LLKS'/ DATA (INAME(371,J),J=1,6)/ 1'LOG ','LOGI','KS ',' ',' ',' '/ DATA INFLAV(371)/'ONE '/ DATA INFLAD(371)/'OFF '/ C DATA INCASE(372)/'LLCP'/ DATA (INAME(372,J),J=1,6)/ 1'LOG ','LOGI',' ',' ',' ',' '/ DATA INFLAV(372)/'ONE '/ DATA INFLAD(372)/'OFF '/ C DATA INCASE(373)/'DWKS'/ DATA (INAME(373,J),J=1,6)/ 1'DOUB','WEIB','KOLM','SMIR',' ',' '/ DATA INFLAV(373)/'ONE '/ DATA INFLAD(373)/'OFF '/ C DATA INCASE(374)/'DWKS'/ DATA (INAME(374,J),J=1,6)/ 1'DOUB','WEIB','KS ',' ',' ',' '/ DATA INFLAV(374)/'ONE '/ DATA INFLAD(374)/'OFF '/ C DATA INCASE(375)/'DWCP'/ DATA (INAME(375,J),J=1,6)/ 1'DOUB','WEIB',' ',' ',' ',' '/ DATA INFLAV(375)/'ONE '/ DATA INFLAD(375)/'OFF '/ C DATA INCASE(376)/'FTKS'/ DATA (INAME(376,J),J=1,6)/ 1'FOLD','T ','KOLM','SMIR',' ',' '/ DATA INFLAV(376)/'ONE '/ DATA INFLAD(376)/'OFF '/ C DATA INCASE(377)/'FTKS'/ DATA (INAME(377,J),J=1,6)/ 1'FOLD','T ','KS ',' ',' ',' '/ DATA INFLAV(377)/'ONE '/ DATA INFLAD(377)/'OFF '/ C DATA INCASE(378)/'FTCP'/ DATA (INAME(378,J),J=1,6)/ 1'FOLD','T ',' ',' ',' ',' '/ DATA INFLAV(378)/'ONE '/ DATA INFLAD(378)/'OFF '/ C DATA INCASE(379)/'ADKS'/ DATA (INAME(379,J),J=1,6)/ 1'ASYM','LAPL','KOLM','SMIR',' ',' '/ DATA INFLAV(379)/'ONE '/ DATA INFLAD(379)/'OFF '/ C DATA INCASE(380)/'ADKS'/ DATA (INAME(380,J),J=1,6)/ 1'ASYM','LAPL','KS ',' ',' ',' '/ DATA INFLAV(380)/'ONE '/ DATA INFLAD(380)/'OFF '/ C DATA INCASE(381)/'ADML'/ DATA (INAME(381,J),J=1,6)/ 1'ASYM','LAPL','MAXI','LIKE',' ',' '/ DATA INFLAV(381)/'ONE '/ DATA INFLAD(381)/'OFF '/ C DATA INCASE(382)/'LXKS'/ DATA (INAME(382,J),J=1,6)/ 1'LOG ','LAPL','KOLM','SMIR',' ',' '/ DATA INFLAV(382)/'ONE '/ DATA INFLAD(382)/'OFF '/ C DATA INCASE(383)/'LXKS'/ DATA (INAME(383,J),J=1,6)/ 1'LOG ','LAPL','KS ',' ',' ',' '/ DATA INFLAV(383)/'ONE '/ DATA INFLAD(383)/'OFF '/ C DATA INCASE(384)/'LXCP'/ DATA (INAME(384,J),J=1,6)/ 1'LOG ','LAPL',' ',' ',' ',' '/ DATA INFLAV(384)/'ONE '/ DATA INFLAD(384)/'OFF '/ C DATA INCASE(385)/'SDKS'/ DATA (INAME(385,J),J=1,6)/ 1'SKEW','DOUB','EXPO','KOLM','SMIR',' '/ DATA INFLAV(385)/'ONE '/ DATA INFLAD(385)/'OFF '/ C DATA INCASE(386)/'SDKS'/ DATA (INAME(386,J),J=1,6)/ 1'SKEW','DOUB','EXPO','KS ',' ',' '/ DATA INFLAV(386)/'ONE '/ DATA INFLAD(386)/'OFF '/ C DATA INCASE(387)/'SDCP'/ DATA (INAME(387,J),J=1,6)/ 1'SKEW','DOUB','EXPO',' ',' ',' '/ DATA INFLAV(387)/'ONE '/ DATA INFLAD(387)/'OFF '/ C DATA INCASE(388)/'ADKS'/ DATA (INAME(388,J),J=1,6)/ 1'ASYM','DOUB','EXPO','KOLM','SMIR',' '/ DATA INFLAV(388)/'ONE '/ DATA INFLAD(388)/'OFF '/ C DATA INCASE(389)/'ADKS'/ DATA (INAME(389,J),J=1,6)/ 1'ASYM','DOUB','EXPO','KS ',' ',' '/ DATA INFLAV(389)/'ONE '/ DATA INFLAD(389)/'OFF '/ C DATA INCASE(390)/'ADCP'/ DATA (INAME(390,J),J=1,6)/ 1'ASYM','DOUB','EXPO',' ',' ',' '/ DATA INFLAV(390)/'ONE '/ DATA INFLAD(390)/'OFF '/ C DATA INCASE(391)/'LXKS'/ DATA (INAME(391,J),J=1,6)/ 1'LOG ','DOUB','EXPO','KOLM','SMIR',' '/ DATA INFLAV(391)/'ONE '/ DATA INFLAD(391)/'OFF '/ C DATA INCASE(392)/'LXKS'/ DATA (INAME(392,J),J=1,6)/ 1'LOG ','DOUB','EXPO','KS ',' ',' '/ DATA INFLAV(392)/'ONE '/ DATA INFLAD(392)/'OFF '/ C DATA INCASE(393)/'LXCP'/ DATA (INAME(393,J),J=1,6)/ 1'LOG ','DOUB','EXPO',' ',' ',' '/ DATA INFLAV(393)/'ONE '/ DATA INFLAD(393)/'OFF '/ C DATA INCASE(394)/'GVKS'/ DATA (INAME(394,J),J=1,6)/ 1'GENE','EXTR','VALU','KOLM','SMIR',' '/ DATA INFLAV(394)/'ONE '/ DATA INFLAD(394)/'OFF '/ C DATA INCASE(395)/'GVKS'/ DATA (INAME(395,J),J=1,6)/ 1'GENE','EXTR','VALU','KS ',' ',' '/ DATA INFLAV(395)/'ONE '/ DATA INFLAD(395)/'OFF '/ C DATA INCASE(396)/'GVCP'/ DATA (INAME(396,J),J=1,6)/ 1'GENE','EXTR','VALU',' ',' ',' '/ DATA INFLAV(396)/'ONE '/ DATA INFLAD(396)/'OFF '/ C DATA INCASE(397)/'SDKS'/ DATA (INAME(397,J),J=1,6)/ 1'SKEW','LAPL','KOLM','SMIR',' ',' '/ DATA INFLAV(397)/'ONE '/ DATA INFLAD(397)/'OFF '/ C DATA INCASE(398)/'SDKS'/ DATA (INAME(398,J),J=1,6)/ 1'SKEW','LAPL','KS ',' ',' ',' '/ DATA INFLAV(398)/'ONE '/ DATA INFLAD(398)/'OFF '/ C DATA INCASE(399)/'SDCP'/ DATA (INAME(399,J),J=1,6)/ 1'SKEW','LAPL',' ',' ',' ',' '/ DATA INFLAV(399)/'ONE '/ DATA INFLAD(399)/'OFF '/ C DATA INCASE(400)/'HLPP'/ DATA (INAME(400,J),J=1,6)/ 1'HALF','LOGI',' ',' ',' ',' '/ DATA INFLAV(400)/'ONE '/ DATA INFLAD(400)/'OFF '/ C DATA INCASE(401)/'PFKS'/ DATA (INAME(401,J),J=1,6)/ 1'POWE','KOLM','SMIR',' ',' ',' '/ DATA INFLAV(401)/'ONE '/ DATA INFLAD(401)/'OFF '/ C DATA INCASE(402)/'PFKS'/ DATA (INAME(402,J),J=1,6)/ 1'POWE','KS ',' ',' ',' ',' '/ DATA INFLAV(402)/'ONE '/ DATA INFLAD(402)/'OFF '/ C DATA INCASE(403)/'PFML'/ DATA (INAME(403,J),J=1,6)/ 1'POWE','MAXI','LIKE',' ',' ',' '/ DATA INFLAV(403)/'ONE '/ DATA INFLAD(403)/'OFF '/ C DATA INCASE(404)/'PFML'/ DATA (INAME(404,J),J=1,6)/ 1'POWE','MLE ',' ',' ',' ',' '/ DATA INFLAV(404)/'ONE '/ DATA INFLAD(404)/'OFF '/ C DATA INCASE(405)/'PFCP'/ DATA (INAME(405,J),J=1,6)/ 1'POWE',' ',' ',' ',' ',' '/ DATA INFLAV(405)/'ONE '/ DATA INFLAD(405)/'OFF '/ C DATA INCASE(406)/'VMKS'/ DATA (INAME(406,J),J=1,6)/ 1'VON ','MISE','KOLM','SMIR',' ',' '/ DATA INFLAV(406)/'ONE '/ DATA INFLAD(406)/'OFF '/ C DATA INCASE(407)/'VMKS'/ DATA (INAME(407,J),J=1,6)/ 1'VON ','MISE','KS ',' ',' ',' '/ DATA INFLAV(407)/'ONE '/ DATA INFLAD(407)/'OFF '/ C DATA INCASE(408)/'VMCP'/ DATA (INAME(408,J),J=1,6)/ 1'VON ','MISE',' ',' ',' ',' '/ DATA INFLAV(408)/'ONE '/ DATA INFLAD(408)/'OFF '/ C DATA INCASE(409)/'GLKS'/ DATA (INAME(409,J),J=1,6)/ 1'GENE','LOGI','KOLM','SMIR',' ',' '/ DATA INFLAV(409)/'ONE '/ DATA INFLAD(409)/'OFF '/ C DATA INCASE(410)/'GLKS'/ DATA (INAME(410,J),J=1,6)/ 1'GENE','LOGI','KS ',' ',' ',' '/ DATA INFLAV(410)/'ONE '/ DATA INFLAD(410)/'OFF '/ C DATA INCASE(411)/'GLCP'/ DATA (INAME(411,J),J=1,6)/ 1'GENE','LOGI',' ',' ',' ',' '/ DATA INFLAV(411)/'ONE '/ DATA INFLAD(411)/'OFF '/ C DATA INCASE(412)/'GZKS'/ DATA (INAME(412,J),J=1,6)/ 1'GENE','HALF','LOGI','KOLM','SMIR',' '/ DATA INFLAV(412)/'ONE '/ DATA INFLAD(412)/'OFF '/ C DATA INCASE(413)/'GZKS'/ DATA (INAME(413,J),J=1,6)/ 1'GENE','HALF','LOGI','KS ',' ',' '/ DATA INFLAV(413)/'ONE '/ DATA INFLAD(413)/'OFF '/ C DATA INCASE(414)/'GZCP'/ DATA (INAME(414,J),J=1,6)/ 1'GENE','HALF','LOGI',' ',' ',' '/ DATA INFLAV(414)/'ONE '/ DATA INFLAD(414)/'OFF '/ C DATA INCASE(415)/'P2KS'/ DATA (INAME(415,J),J=1,6)/ 1'PARE','SECO','KIND','KOLM','SMIR',' '/ DATA INFLAV(415)/'ONE '/ DATA INFLAD(415)/'OFF '/ C DATA INCASE(416)/'P2KS'/ DATA (INAME(416,J),J=1,6)/ 1'PARE','SECO','KIND','KS ',' ',' '/ DATA INFLAV(416)/'ONE '/ DATA INFLAD(416)/'OFF '/ C DATA INCASE(417)/'P2CP'/ DATA (INAME(417,J),J=1,6)/ 1'PARE','SECO','KIND',' ',' ',' '/ DATA INFLAV(417)/'ONE '/ DATA INFLAD(417)/'OFF '/ C DATA INCASE(418)/'WCKS'/ DATA (INAME(418,J),J=1,6)/ 1'WRAP','CAUC','KOLM','SMIR',' ',' '/ DATA INFLAV(418)/'ONE '/ DATA INFLAD(418)/'OFF '/ C DATA INCASE(419)/'WCKS'/ DATA (INAME(419,J),J=1,6)/ 1'WRAP','CAUC','KS ',' ',' ',' '/ DATA INFLAV(419)/'ONE '/ DATA INFLAD(419)/'OFF '/ C DATA INCASE(420)/'WCCP'/ DATA (INAME(420,J),J=1,6)/ 1'WRAP','CAUC',' ',' ',' ',' '/ DATA INFLAV(420)/'ONE '/ DATA INFLAD(420)/'OFF '/ C DATA INCASE(421)/'PFKS'/ DATA (INAME(421,J),J=1,6)/ 1'POWE','FUNC','KOLM','SMIR',' ',' '/ DATA INFLAV(421)/'ONE '/ DATA INFLAD(421)/'OFF '/ C DATA INCASE(422)/'PFKS'/ DATA (INAME(422,J),J=1,6)/ 1'POWE','FUNC','KS ',' ',' ',' '/ DATA INFLAV(422)/'ONE '/ DATA INFLAD(422)/'OFF '/ C DATA INCASE(423)/'PFML'/ DATA (INAME(423,J),J=1,6)/ 1'POWE','FUNC','MAXI','LIKE',' ',' '/ DATA INFLAV(423)/'ONE '/ DATA INFLAD(423)/'OFF '/ C DATA INCASE(424)/'PFML'/ DATA (INAME(424,J),J=1,6)/ 1'POWE','FUNC','MLE ',' ',' ',' '/ DATA INFLAV(424)/'ONE '/ DATA INFLAD(424)/'OFF '/ C DATA INCASE(425)/'PFCP'/ DATA (INAME(425,J),J=1,6)/ 1'POWE','FUNC',' ',' ',' ',' '/ DATA INFLAV(425)/'ONE '/ DATA INFLAD(425)/'OFF '/ C DATA INCASE(426)/'ADML'/ DATA (INAME(426,J),J=1,6)/ 1'ASYM','LAPL','MLE ',' ',' ',' '/ DATA INFLAV(426)/'ONE '/ DATA INFLAD(426)/'OFF '/ C DATA INCASE(427)/'ADCP'/ DATA (INAME(427,J),J=1,6)/ 1'ASYM','LAPL',' ',' ',' ',' '/ DATA INFLAV(427)/'ONE '/ DATA INFLAD(427)/'OFF '/ C DATA INCASE(428)/'IGKS'/ DATA (INAME(428,J),J=1,6)/ 1'INVE','GAUS','KOLM','SMIR',' ',' '/ DATA INFLAV(428)/'ONE '/ DATA INFLAD(428)/'OFF '/ C DATA INCASE(429)/'IGKS'/ DATA (INAME(429,J),J=1,6)/ 1'INVE','GAUS','KS ',' ',' ',' '/ DATA INFLAV(429)/'ONE '/ DATA INFLAD(429)/'OFF '/ C DATA INCASE(430)/'IGML'/ DATA (INAME(430,J),J=1,6)/ 1'INVE','GAUS','MAXI','LIKE',' ',' '/ DATA INFLAV(430)/'ONE '/ DATA INFLAD(430)/'OFF '/ C DATA INCASE(431)/'IGML'/ DATA (INAME(431,J),J=1,6)/ 1'INVE','GAUS','MLE ',' ',' ',' '/ DATA INFLAV(431)/'ONE '/ DATA INFLAD(431)/'OFF '/ C DATA INCASE(432)/'IGCP'/ DATA (INAME(432,J),J=1,6)/ 1'INVE','GAUS',' ',' ',' ',' '/ DATA INFLAV(432)/'ONE '/ DATA INFLAD(432)/'OFF '/ C DATA INCASE(433)/'FNKS'/ DATA (INAME(433,J),J=1,6)/ 1'FOLD','NORM','KOLM','SMIR',' ',' '/ DATA INFLAV(433)/'ONE '/ DATA INFLAD(433)/'OFF '/ C DATA INCASE(434)/'FNKS'/ DATA (INAME(434,J),J=1,6)/ 1'FOLD','NORM','KS ',' ',' ',' '/ DATA INFLAV(434)/'ONE '/ DATA INFLAD(434)/'OFF '/ C DATA INCASE(435)/'FNML'/ DATA (INAME(435,J),J=1,6)/ 1'FOLD','NORM','MAXI','LIKE',' ',' '/ DATA INFLAV(435)/'ONE '/ DATA INFLAD(435)/'OFF '/ C DATA INCASE(436)/'FNML'/ DATA (INAME(436,J),J=1,6)/ 1'FOLD','NORM','MLE ',' ',' ',' '/ DATA INFLAV(436)/'ONE '/ DATA INFLAD(436)/'OFF '/ C DATA INCASE(437)/'FNCP'/ DATA (INAME(437,J),J=1,6)/ 1'FOLD','NORM',' ',' ',' ',' '/ DATA INFLAV(437)/'ONE '/ DATA INFLAD(437)/'OFF '/ C DATA INCASE(438)/'LOPP'/ DATA (INAME(438,J),J=1,6)/ 1'LOGI',' ',' ',' ',' ',' '/ DATA INFLAV(438)/'ONE '/ DATA INFLAD(438)/'OFF '/ C DATA INCASE(439)/'BEKS'/ DATA (INAME(439,J),J=1,6)/ 1'BETA','KOLM','SMIR',' ',' ',' '/ DATA INFLAV(439)/'ONE '/ DATA INFLAD(439)/'OFF '/ C DATA INCASE(440)/'BEKS'/ DATA (INAME(440,J),J=1,6)/ 1'BETA','KS ',' ',' ',' ',' '/ DATA INFLAV(440)/'ONE '/ DATA INFLAD(440)/'OFF '/ C DATA INCASE(441)/'BEML'/ DATA (INAME(441,J),J=1,6)/ 1'BETA','MAXI','LIKE',' ',' ',' '/ DATA INFLAV(441)/'ONE '/ DATA INFLAD(441)/'OFF '/ C DATA INCASE(442)/'BEML'/ DATA (INAME(442,J),J=1,6)/ 1'BETA','MLE ',' ',' ',' ',' '/ DATA INFLAV(442)/'ONE '/ DATA INFLAD(442)/'OFF '/ C DATA INCASE(443)/'BECP'/ DATA (INAME(443,J),J=1,6)/ 1'BETA',' ',' ',' ',' ',' '/ DATA INFLAV(443)/'ONE '/ DATA INFLAD(443)/'OFF '/ C DATA INCASE(444)/'FKS'/ DATA (INAME(444,J),J=1,6)/ 1'F ','KOLM','SMIR',' ',' ',' '/ DATA INFLAV(444)/'ONE '/ DATA INFLAD(444)/'OFF '/ C DATA INCASE(445)/'FKS'/ DATA (INAME(445,J),J=1,6)/ 1'F ','KS ',' ',' ',' ',' '/ DATA INFLAV(445)/'ONE '/ DATA INFLAD(445)/'OFF '/ C DATA INCASE(446)/'FCP'/ DATA (INAME(446,J),J=1,6)/ 1'F ',' ',' ',' ',' ',' '/ DATA INFLAV(446)/'ONE '/ DATA INFLAD(446)/'OFF '/ C DATA INCASE(447)/'GGKS'/ DATA (INAME(447,J),J=1,6)/ 1'GENE','GAMM','KOLM','SMIR',' ',' '/ DATA INFLAV(447)/'ONE '/ DATA INFLAD(447)/'OFF '/ C DATA INCASE(448)/'GGKS'/ DATA (INAME(448,J),J=1,6)/ 1'GENE','GAMM','KS ',' ',' ',' '/ DATA INFLAV(448)/'ONE '/ DATA INFLAD(448)/'OFF '/ C DATA INCASE(449)/'GGCP'/ DATA (INAME(449,J),J=1,6)/ 1'GENE','GAMM',' ',' ',' ',' '/ DATA INFLAV(449)/'ONE '/ DATA INFLAD(449)/'OFF '/ C DATA INCASE(450)/'DGKS'/ DATA (INAME(450,J),J=1,6)/ 1'DOUB','GAMM','KOLM','SMIR',' ',' '/ DATA INFLAV(450)/'ONE '/ DATA INFLAD(450)/'OFF '/ C DATA INCASE(451)/'DGKS'/ DATA (INAME(451,J),J=1,6)/ 1'DOUB','GAMM','KS ',' ',' ',' '/ DATA INFLAV(451)/'ONE '/ DATA INFLAD(451)/'OFF '/ C DATA INCASE(452)/'DGCP'/ DATA (INAME(452,J),J=1,6)/ 1'DOUB','GAMM',' ',' ',' ',' '/ DATA INFLAV(452)/'ONE '/ DATA INFLAD(452)/'OFF '/ C DATA INCASE(453)/'PNKS'/ DATA (INAME(453,J),J=1,6)/ 1'POWE','NORM','KOLM','SMIR',' ',' '/ DATA INFLAV(453)/'ONE '/ DATA INFLAD(453)/'OFF '/ C DATA INCASE(454)/'PNKS'/ DATA (INAME(454,J),J=1,6)/ 1'POWE','NORM','KS ',' ',' ',' '/ DATA INFLAV(454)/'ONE '/ DATA INFLAD(454)/'OFF '/ C DATA INCASE(455)/'PNML'/ DATA (INAME(455,J),J=1,6)/ 1'POWE','NORM','MAXI','LIKE',' ',' '/ DATA INFLAV(455)/'ONE '/ DATA INFLAD(455)/'OFF '/ C DATA INCASE(456)/'PNML'/ DATA (INAME(456,J),J=1,6)/ 1'POWE','NORM','MLE ',' ',' ',' '/ DATA INFLAV(456)/'ONE '/ DATA INFLAD(456)/'OFF '/ C DATA INCASE(457)/'PNCP'/ DATA (INAME(457,J),J=1,6)/ 1'POWE','NORM',' ',' ',' ',' '/ DATA INFLAV(457)/'ONE '/ DATA INFLAD(457)/'OFF '/ C DATA INCASE(458)/'GEML'/ DATA (INAME(458,J),J=1,6)/ 1'GENE','PARE','MAXI','LIKE',' ',' '/ DATA INFLAV(458)/'ONE '/ DATA INFLAD(458)/'OFF '/ C DATA INCASE(459)/'GEMO'/ DATA (INAME(459,J),J=1,6)/ 1'GENE','PARE','MOME',' ',' ',' '/ DATA INFLAV(459)/'ONE '/ DATA INFLAD(459)/'OFF '/ C DATA INCASE(460)/'GEDE'/ DATA (INAME(460,J),J=1,6)/ 1'DEHA',' ',' ',' ',' ',' '/ DATA INFLAV(460)/'ONE '/ DATA INFLAD(460)/'OFF '/ C DATA INCASE(461)/'GECM'/ DATA (INAME(461,J),J=1,6)/ 1'CME ',' ',' ',' ',' ',' '/ DATA INFLAV(461)/'ONE '/ DATA INFLAD(461)/'OFF '/ C DATA INCASE(462)/'GECP'/ DATA (INAME(462,J),J=1,6)/ 1'GENE','PARE',' ',' ',' ',' '/ DATA INFLAV(462)/'ONE '/ DATA INFLAD(462)/'OFF '/ C DATA INCASE(463)/'FRML'/ DATA (INAME(463,J),J=1,6)/ 1'EXTR','VALU','TYPE','2 ','MAXI','LIKE'/ DATA INFLAV(463)/'ONE '/ DATA INFLAD(463)/'OFF '/ C DATA INCASE(464)/'FRML'/ DATA (INAME(464,J),J=1,6)/ 1'EXTR','VALU','TYPE','2 ','MLE ',' '/ DATA INFLAV(464)/'ONE '/ DATA INFLAD(464)/'OFF '/ C DATA INCASE(466)/'E2KS'/ DATA (INAME(466,J),J=1,6)/ 1'EXTR','VALU','TYPE','2 ','KOLM','SMIR'/ DATA INFLAV(466)/'ONE '/ DATA INFLAD(466)/'OFF '/ C DATA INCASE(467)/'E2KS'/ DATA (INAME(467,J),J=1,6)/ 1'EXTR','VALU','TYPE','2 ','KS ',' '/ DATA INFLAV(467)/'ONE '/ DATA INFLAD(467)/'OFF '/ C DATA INCASE(468)/'E2CP'/ DATA (INAME(468,J),J=1,6)/ 1'EXTR','VALU','TYPE','2 ',' ',' '/ DATA INFLAV(468)/'ONE '/ DATA INFLAD(468)/'OFF '/ C DATA INCASE(469)/'MAML'/ DATA (INAME(469,J),J=1,6)/ 1'MAXW','MAXI','LIKE',' ',' ',' '/ DATA INFLAV(469)/'ONE '/ DATA INFLAD(469)/'OFF '/ C DATA INCASE(470)/'MAKS'/ DATA (INAME(470,J),J=1,6)/ 1'MAXW','KOLM','SMIR',' ',' ',' '/ DATA INFLAV(470)/'ONE '/ DATA INFLAD(470)/'OFF '/ C DATA INCASE(471)/'MAKS'/ DATA (INAME(471,J),J=1,6)/ 1'MAXW','KS ',' ',' ',' ',' '/ DATA INFLAV(471)/'ONE '/ DATA INFLAD(471)/'OFF '/ C DATA INCASE(472)/'IWML'/ DATA (INAME(472,J),J=1,6)/ 1'INVE','WEIB','MLE ',' ',' ',' '/ DATA INFLAV(472)/'ONE '/ DATA INFLAD(472)/'OFF '/ C DATA INCASE(473)/'IWCP'/ DATA (INAME(473,J),J=1,6)/ 1'INVE','WEIB',' ',' ',' ',' '/ DATA INFLAV(473)/'ONE '/ DATA INFLAD(473)/'OFF '/ C DATA INCASE(474)/'RATI'/ DATA (INAME(474,J),J=1,6)/ 1'RATI',' ',' ',' ',' ',' '/ DATA INFLAV(474)/'TWO '/ DATA INFLAD(474)/'OFF '/ C DATA INCASE(475)/'G2KS'/ DATA (INAME(475,J),J=1,6)/ 1'GENE','LOGI','TYPE','2 ','KOLM','SMIR'/ DATA INFLAV(475)/'ONE '/ DATA INFLAD(475)/'OFF '/ C DATA INCASE(476)/'G2KS'/ DATA (INAME(476,J),J=1,6)/ 1'GENE','LOGI','TYPE','II ','KOLM','SMIR'/ DATA INFLAV(476)/'ONE '/ DATA INFLAD(476)/'OFF '/ C DATA INCASE(477)/'G2KS'/ DATA (INAME(477,J),J=1,6)/ 1'GENE','LOGI','TYPE','2 ','KS ',' '/ DATA INFLAV(477)/'ONE '/ DATA INFLAD(477)/'OFF '/ C DATA INCASE(478)/'G2KS'/ DATA (INAME(478,J),J=1,6)/ 1'GENE','LOGI','TYPE','II ','KS ',' '/ DATA INFLAV(478)/'ONE '/ DATA INFLAD(478)/'OFF '/ C DATA INCASE(479)/'G2CP'/ DATA (INAME(479,J),J=1,6)/ 1'GENE','LOGI','TYPE','2 ',' ',' '/ DATA INFLAV(479)/'ONE '/ DATA INFLAD(479)/'OFF '/ C DATA INCASE(480)/'G2CP'/ DATA (INAME(480,J),J=1,6)/ 1'GENE','LOGI','TYPE','II ',' ',' '/ DATA INFLAV(480)/'ONE '/ DATA INFLAD(480)/'OFF '/ C DATA INCASE(481)/'G3KS'/ DATA (INAME(481,J),J=1,6)/ 1'GENE','LOGI','TYPE','3 ','KOLM','SMIR'/ DATA INFLAV(481)/'ONE '/ DATA INFLAD(481)/'OFF '/ C DATA INCASE(482)/'G3KS'/ DATA (INAME(482,J),J=1,6)/ 1'GENE','LOGI','TYPE','III ','KOLM','SMIR'/ DATA INFLAV(482)/'ONE '/ DATA INFLAD(482)/'OFF '/ C DATA INCASE(483)/'G3KS'/ DATA (INAME(483,J),J=1,6)/ 1'GENE','LOGI','TYPE','3 ','KS ',' '/ DATA INFLAV(483)/'ONE '/ DATA INFLAD(483)/'OFF '/ C DATA INCASE(484)/'G3KS'/ DATA (INAME(484,J),J=1,6)/ 1'GENE','LOGI','TYPE','III ','KS ',' '/ DATA INFLAV(484)/'ONE '/ DATA INFLAD(484)/'OFF '/ C DATA INCASE(485)/'G3CP'/ DATA (INAME(485,J),J=1,6)/ 1'GENE','LOGI','TYPE','3 ',' ',' '/ DATA INFLAV(485)/'ONE '/ DATA INFLAD(485)/'OFF '/ C DATA INCASE(486)/'G3CP'/ DATA (INAME(486,J),J=1,6)/ 1'GENE','LOGI','TYPE','III ',' ',' '/ DATA INFLAV(486)/'ONE '/ DATA INFLAD(486)/'OFF '/ C DATA INCASE(487)/'G4KS'/ DATA (INAME(487,J),J=1,6)/ 1'GENE','LOGI','TYPE','4 ','KOLM','SMIR'/ DATA INFLAV(487)/'ONE '/ DATA INFLAD(487)/'OFF '/ C DATA INCASE(488)/'G4KS'/ DATA (INAME(488,J),J=1,6)/ 1'GENE','LOGI','TYPE','IV ','KOLM','SMIR'/ DATA INFLAV(488)/'ONE '/ DATA INFLAD(488)/'OFF '/ C DATA INCASE(489)/'G4KS'/ DATA (INAME(489,J),J=1,6)/ 1'GENE','LOGI','TYPE','4 ','KS ',' '/ DATA INFLAV(489)/'ONE '/ DATA INFLAD(489)/'OFF '/ C DATA INCASE(490)/'G4KS'/ DATA (INAME(490,J),J=1,6)/ 1'GENE','LOGI','TYPE','IV ','KS ',' '/ DATA INFLAV(490)/'ONE '/ DATA INFLAD(490)/'OFF '/ C DATA INCASE(491)/'G4CP'/ DATA (INAME(491,J),J=1,6)/ 1'GENE','LOGI','TYPE','4 ',' ',' '/ DATA INFLAV(491)/'ONE '/ DATA INFLAD(491)/'OFF '/ C DATA INCASE(492)/'G4CP'/ DATA (INAME(492,J),J=1,6)/ 1'GENE','LOGI','TYPE','IV ',' ',' '/ DATA INFLAV(492)/'ONE '/ DATA INFLAD(492)/'OFF '/ C DATA INCASE(493)/'G5KS'/ DATA (INAME(493,J),J=1,6)/ 1'GENE','LOGI','TYPE','5 ','KOLM','SMIR'/ DATA INFLAV(493)/'ONE '/ DATA INFLAD(493)/'OFF '/ C DATA INCASE(494)/'G5KS'/ DATA (INAME(494,J),J=1,6)/ 1'GENE','LOGI','TYPE','V ','KOLM','SMIR'/ DATA INFLAV(494)/'ONE '/ DATA INFLAD(494)/'OFF '/ C DATA INCASE(495)/'G5KS'/ DATA (INAME(495,J),J=1,6)/ 1'GENE','LOGI','HOSK','KOLM','SMIR',' '/ DATA INFLAV(495)/'ONE '/ DATA INFLAD(495)/'OFF '/ C DATA INCASE(496)/'G5KS'/ DATA (INAME(496,J),J=1,6)/ 1'GENE','LOGI','TYPE','5 ','KS ',' '/ DATA INFLAV(496)/'ONE '/ DATA INFLAD(496)/'OFF '/ C DATA INCASE(497)/'G5KS'/ DATA (INAME(497,J),J=1,6)/ 1'GENE','LOGI','TYPE','V ','KS ',' '/ DATA INFLAV(497)/'ONE '/ DATA INFLAD(497)/'OFF '/ C DATA INCASE(498)/'G5KS'/ DATA (INAME(498,J),J=1,6)/ 1'GENE','LOGI','HOSK','KS ',' ',' '/ DATA INFLAV(498)/'ONE '/ DATA INFLAD(498)/'OFF '/ C DATA INCASE(499)/'G5CP'/ DATA (INAME(499,J),J=1,6)/ 1'GENE','LOGI','TYPE','5 ',' ',' '/ DATA INFLAV(499)/'ONE '/ DATA INFLAD(499)/'OFF '/ C DATA INCASE(500)/'G5CP'/ DATA (INAME(500,J),J=1,6)/ 1'GENE','LOGI','TYPE','V ',' ',' '/ DATA INFLAV(500)/'ONE '/ DATA INFLAD(500)/'OFF '/ C DATA INCASE(501)/'G5CP'/ DATA (INAME(501,J),J=1,6)/ 1'GENE','LOGI','HOSK',' ',' ',' '/ DATA INFLAV(501)/'ONE '/ DATA INFLAD(501)/'OFF '/ C DATA INCASE(502)/'BNKS'/ DATA (INAME(502,J),J=1,6)/ 1'BETA','NORM','KOLM','SMIR',' ',' '/ DATA INFLAV(502)/'ONE '/ DATA INFLAD(502)/'OFF '/ C DATA INCASE(503)/'BNKS'/ DATA (INAME(503,J),J=1,6)/ 1'BETA','NORM','KS ',' ',' ',' '/ DATA INFLAV(503)/'ONE '/ DATA INFLAD(503)/'OFF '/ C DATA INCASE(504)/'BNCP'/ DATA (INAME(504,J),J=1,6)/ 1'BETA','NORM',' ',' ',' ',' '/ DATA INFLAV(504)/'ONE '/ DATA INFLAD(504)/'OFF '/ C DATA INCASE(505)/'G5LM'/ DATA (INAME(505,J),J=1,6)/ 1'GENE','LOGI','TYPE','5 ','LMOM',' '/ DATA INFLAV(505)/'ONE '/ DATA INFLAD(505)/'OFF '/ C DATA INCASE(506)/'G5LM'/ DATA (INAME(506,J),J=1,6)/ 1'GENE','LOGI','TYPE','V ','LMOM',' '/ DATA INFLAV(506)/'ONE '/ DATA INFLAD(506)/'OFF '/ C DATA INCASE(507)/'G5LM'/ DATA (INAME(507,J),J=1,6)/ 1'GENE','LOGI','HOSK','LMOM',' ',' '/ DATA INFLAV(507)/'ONE '/ DATA INFLAD(507)/'OFF '/ C DATA INCASE(508)/'G5LM'/ DATA (INAME(508,J),J=1,6)/ 1'GENE','LOGI','TYPE','5 ','L ','MOME'/ DATA INFLAV(508)/'ONE '/ DATA INFLAD(508)/'OFF '/ C DATA INCASE(509)/'G5LM'/ DATA (INAME(509,J),J=1,6)/ 1'GENE','LOGI','TYPE','V ','L ','MOME'/ DATA INFLAV(509)/'ONE '/ DATA INFLAD(509)/'OFF '/ C DATA INCASE(510)/'G5LM'/ DATA (INAME(510,J),J=1,6)/ 1'GENE','LOGI','HOSK','L ','MOME',' '/ DATA INFLAV(510)/'ONE '/ DATA INFLAD(510)/'OFF '/ C DATA INCASE(511)/'LDKS'/ DATA (INAME(511,J),J=1,6)/ 1'GENE','TUKE','LAMB','KOLM','SMIR',' '/ DATA INFLAV(511)/'ONE '/ DATA INFLAD(511)/'OFF '/ C DATA INCASE(512)/'LDKS'/ DATA (INAME(512,J),J=1,6)/ 1'GENE','TUKE','LAMB','KS ',' ',' '/ DATA INFLAV(512)/'ONE '/ DATA INFLAD(512)/'OFF '/ C DATA INCASE(513)/'LDCP'/ DATA (INAME(513,J),J=1,6)/ 1'GENE','TUKE','LAMB',' ',' ',' '/ DATA INFLAV(513)/'ONE '/ DATA INFLAD(513)/'OFF '/ C DATA INCASE(514)/'MAML'/ DATA (INAME(514,J),J=1,6)/ 1'MAXW','MLE ',' ',' ',' ',' '/ DATA INFLAV(514)/'ONE '/ DATA INFLAD(514)/'OFF '/ C DATA INCASE(515)/'MAKS'/ DATA (INAME(515,J),J=1,6)/ 1'MAXW','KOLM','SMIR',' ',' ',' '/ DATA INFLAV(515)/'ONE '/ DATA INFLAD(515)/'OFF '/ C DATA INCASE(516)/'MAKS'/ DATA (INAME(516,J),J=1,6)/ 1'MAXW','KS ',' ',' ',' ',' '/ DATA INFLAV(516)/'ONE '/ DATA INFLAD(516)/'OFF '/ C C-----START POINT----------------------------------------------------- C IERROR='NO' IFLAGD='OFF' IFLAGV='ONE' NGRPV=0 ICENSO='OFF' IMETHD='UNIM' IF(IPPLCN.EQ.'KAPL')IMETHD=IPPLCN C ISUBN1='DPJB' ISUBN2='SP ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C MAXV2=4 MINN2=2 C ICOLL=0 ICOLH=0 ICOLX=0 C C ********************************************** C ** TREAT THE BOOTSTRAP/JACKNIFE PLOT CASE ** C ********************************************** C IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'JBSP')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPJBSP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ 52 FORMAT('ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ = ', 1 A4,2X,A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASPL,IAND1,IAND2 53 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IBOOSS 54 FORMAT('IBOOSS = ',I8) CALL DPWRST('XXX','BUG ') ENDIF C C *************************** C ** STEP 1-- ** C ** EXTRACT THE COMMAND ** C *************************** C ISTEPN='1' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'JBSP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C ********************************* C ** STEP 1-- ** C ** DETERMINE IF OF THIS TYPE ** C ** AND BRANCH ACCORDINGLY. ** C ********************************* C ISTEPN='1' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'JBSP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICOM.EQ.'JACK')THEN ICASJB='JACK' ELSEIF(ICOM.EQ.'BOOT')THEN ICASJB='BOOT' ELSE IFOUND='NO' GOTO9000 ENDIF C ISHIFT=1 IF(IHARG(1).EQ.'CENS')THEN ISHIFT=2 ICOM=IHARG(2) ICOM2=IHARG2(2) ICENSO='ON' ELSE ICOM=IHARG(1) ICOM2=IHARG2(1) ENDIF CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1IBUGG3,IERROR) C IF(NUMARG.LE.1)GOTO9000 C C *************************** C ** STEP 1B-- ** C ** EXTRACT THE COMMAND ** C *************************** C ISTEPN='1B' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPPP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO100I=1,NUMCHS IROW=I IF(INAME(I,1).NE.ICOM)GOTO100 DO102J=2,6 IF(INAME(I,J).NE.' ')GOTO102 ITEMP=J-1 GOTO104 102 CONTINUE ITEMP=6 104 CONTINUE ILASTC=0 IF(ITEMP.GT.1)THEN DO108J=2,ITEMP IF(INAME(I,J).NE.IHARG(J-1))GOTO100 108 CONTINUE ILASTC=ITEMP-1 ENDIF I1=ILASTC+1 I2=ILASTC+2 I3=ILASTC+3 IF(IHARG(I1).EQ.'PLOT')THEN ILASTC=I1 GOTO112 ELSEIF(IHARG(I1).EQ.'STAT'.AND.IHARG(I2).EQ.'PLOT')THEN ILASTC=I2 GOTO112 ELSEIF(IHARG(I1).EQ.'CENS'.AND.IHARG(I2).EQ.'PLOT')THEN ICENSO='ON' ILASTC=I2 GOTO112 ELSEIF(IHARG(I1).EQ.'CENS'.AND.IHARG(I2).EQ.'STAT'.AND. 1 IHARG(I3).EQ.'PLOT')THEN ICENSO='ON' ILASTC=I3 GOTO112 END IF C 100 CONTINUE C C ----------NO MATCH FOUND---------- C ICASPL=' ' IFOUND='NO' GOTO9000 C 112 CONTINUE ICASPL=INCASE(IROW) IFLAGV=INFLAV(IROW) IFLAGD=INFLAD(IROW) CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) IFOUND='YES' C IF(ICENSO.EQ.'ON')IFLAGV='TWO' C C ****************************************************** C ** STEP 21-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ****************************************************** C ISTEPN='21' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'JBSP') 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 C ******************************************** C ** STEP 22-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C ** (THIS WILL BE THE RESPONSE VARIABLE) ** C ******************************************** C ISTEPN='22' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'JBSP') 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) IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'JBSP')THEN WRITE(ICOUT,2211)IHLEFT,ICOLL,NLEFT 2211 FORMAT('IHLEFT,ICOLL,NLEFT = ',A4,I8,I8) CALL DPWRST('XXX','BUG ') ENDIF C C ******************************************************* C ** STEP 23-- ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (NLEFT)** C ** FOR THE RESPONSE VARIABLE IS 2 OR LARGER. ** C ******************************************************* C ISTEPN='23' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'JBSP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NLEFT.LT.MINN2)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2311) 2311 FORMAT('***** ERROR IN BOOTSTRAP/JACKNIFE PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2312) 2312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS FOR WHICH A') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2314) 2314 FORMAT(' BOOTSTRAP/JACKNIFE ... PLOT WAS TO HAVE BEEN ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2315)MINN2 2315 FORMAT(' FORMED MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2316) 2316 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2317) 2317 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2318)(IANS(I),I=1,MIN(80,IWIDTH)) 2318 FORMAT(' ',80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF C C ***************************************** C ** STEP 24-- ** C ** CHECK TO SEE THE TYPE SUBCASE ** C ** (BASED ON THE QUALIFIER)-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='24' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'JBSP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO2480 DO2400J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO2410 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO2410 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO2420 2400 CONTINUE GOTO2490 2410 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO2490 2420 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO2490 C 2480 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2481) 2481 FORMAT('***** INTERNAL ERROR IN BOOTSTRAP/JACKNIFE PLOT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2482) 2482 FORMAT(' AT BRANCH POINT 2481 IN DPJBSP--NUMARG LESS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2483) 2483 FORMAT(' THAN 1 EVEN THOUGH NUMARG HAD PREVIOUSLY PASSED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2485)NUMARG 2485 FORMAT(' THIS TEST ONCE ALREADY. VALUE OF NUMARG = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2486) 2486 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2487)(IANS(I),I=1,MIN(80,IWIDTH)) 2487 FORMAT(' ',80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 C 2490 CONTINUE IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'JBSP')THEN WRITE(ICOUT,2491)NUMARG,ILOCQ,ICASEQ 2491 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') ENDIF C C ***************************************** C ** STEP 24.5-- ** C ** DETERMINE THE NUMBER OF VARIABLES ** C ***************************************** C ISTEPN='24.5' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'JBSP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C ****************************************************** C ** STEP 25-- ** C ** IF A SECOND ARGUMENT EXISTS, THEN THIS ** C ** INDICATES THAT THE VALUES IN THE ** C ** FIRST VARIABLE ARE TO BE GROUPED ** C ** BASED ON VALUES OF THE SECOND VARIABLE; ** C ** THAT IS, THE SECOND VARAIBLE DEFINES THE ** C ** GROUP NUMBERS WITHIN WHICH THE MEANS, ** C ** STANDARD DEVIATIONS, RANGES, AND ** C ** CUMULATIVE SUMS ARE TO BE COMPUTED. ** C ** THE VALUES IN THE SECOND VARIABLE ** C ** ARE THE X VALUES FOR EACH MEAN, STANDARD ** C ** DEVIATION, ETC. IN THE RESULTING STATISTIC ** C ** PLOT. THE VALUES IN THE SECOND VARIABLE ** C ** NEED NOT HAVE BEEN PREVIOUSLY ** C ** SORTED OR HAVE COMMON VALUES ADJACENT. ** C ** IF WE HAVE THE 2-VARIABLE CASE, ** C ** CHECK THE VALIDITY OF THE SECOND (X) VARIABLE. ** C ****************************************************** C ISTEPN='25' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'JBSP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMEXP=1 IF(IFLAGV.EQ.'TWO')NUMEXP=2 NUMV2=ILOCQ-1 C IF(NUMV2.LT.NUMEXP .OR. NUMV2.GT.NUMEXP+2)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2511) 2511 FORMAT('***** ERROR IN BOOTSTRAP/JACKNIFE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2512) 2512 FORMAT(' FOR A BOOTSTRAP/JACKNIFE ... PLOT, THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2518)NUMEXP,NUMEXP+2 2518 FORMAT(' NUMBER OF VARIABLES MUST BE BETWEEN ',I4, 1 ' AND ',I4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2520) 2520 FORMAT(' SUCH WAS NOT THE CASE HERE; THE SPECIFIED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2522)NUMV2 2522 FORMAT(' NUMBER OF VARIABLES WAS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2523) 2523 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2524)(IANS(I),I=1,MIN(80,IWIDTH)) 2524 FORMAT(' ',80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF C IF(NUMV2.EQ.2)THEN IF(IFLAGV.EQ.'TWO')THEN IHHOR=IHARG(2) IHHOR2=IHARG2(2) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHHOR,IHHOR2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLH=IVALUE(ILOCV) NHOR=IN(ILOCV) IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'JBSP')THEN WRITE(ICOUT,2531)IHHOR,ICOLH,NHOR 2531 FORMAT('IHHOR,ICOLH,NHOR = ',A4,I8,I8) CALL DPWRST('XXX','BUG ') ENDIF ELSE IHX=IHARG(2) IHX2=IHARG2(2) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHX,IHX2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLX=IVALUE(ILOCV) NX=IN(ILOCV) NGRPV=1 ENDIF ELSEIF(NUMV2.EQ.3)THEN IF(IFLAGV.EQ.'TWO')THEN IHHOR=IHARG(2) IHHOR2=IHARG2(2) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHHOR,IHHOR2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLH=IVALUE(ILOCV) NHOR=IN(ILOCV) IHX=IHARG(3) IHX2=IHARG2(3) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHX,IHX2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLX=IVALUE(ILOCV) NX=IN(ILOCV) NGRPV=1 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'JBSP')THEN WRITE(ICOUT,2531)IHHOR,ICOLH,NHOR CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2541)IHX,ICOLX,NX 2541 FORMAT('IHX,ICOLX,NX = ',A4,I8,I8) CALL DPWRST('XXX','BUG ') ENDIF ELSE IHX=IHARG(2) IHX2=IHARG2(2) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHX,IHX2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLX=IVALUE(ILOCV) NX=IN(ILOCV) C IHXG=IHARG(3) IHXG2=IHARG2(3) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHXG,IHXG2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLX2=IVALUE(ILOCV) NX2=IN(ILOCV) NGRPV=2 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'JBSP')THEN WRITE(ICOUT,2541)IHX,ICOLX,NX CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2543)IHXG,ICOLX2,NX2 2543 FORMAT('IHXG,ICOLX2,NX2 = ',A4,I8,I8) CALL DPWRST('XXX','BUG ') ENDIF ENDIF ELSEIF(NUMV2.EQ.4)THEN IF(IFLAGV.EQ.'TWO')THEN IHHOR=IHARG(2) IHHOR2=IHARG2(2) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHHOR,IHHOR2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLH=IVALUE(ILOCV) NHOR=IN(ILOCV) IHX=IHARG(3) IHX2=IHARG2(3) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHX,IHX2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLX=IVALUE(ILOCV) NX=IN(ILOCV) NGRPV=2 IHXG=IHARG(4) IHXG2=IHARG2(4) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHXG,IHXG2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLX2=IVALUE(ILOCV) NX2=IN(ILOCV) IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'JBSP')THEN WRITE(ICOUT,2531)IHHOR,ICOLH,NHOR CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2541)IHX,ICOLX,NX CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2543)IHXG,ICOLX2,NX2 CALL DPWRST('XXX','BUG ') ENDIF ELSE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2551) 2551 FORMAT('***** ERROR IN BOOTSTRAP/JACKNIFE PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2552)NUMV2 2552 FORMAT(' FOR A ONE VARIABLE STATISTIC, AT MOST THREE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2553)NUMV2 2553 FORMAT(' EXPECTED. FOUR VARIABLES WERE SPECIFIED.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF ELSE GOTO2590 ENDIF C CCCCC FOR DEPENDENT GROUPS FOR "DIFFERENCE OF" STATISTICS, SAMPLE CCCCC SIZES FOR TWO RESPONSE VARIABLES NEED NOT BE EQUAL. NOTE, CCCCC HOWEVER, THAT IF A GROUP ID VARIABLE IS ALSO SPECIFIED, CCCCC THEN WE DO RESTRICT TO EQUAL SAMPLE SIZES. C CCCCC UPDATE CHECK TO ACCOUNT FOR CASE WHERE THERE ARE TWO CCCCC VARIABLES. C 2570 CONTINUE IF(NUMV2.EQ.2)THEN IF(IFLAGV.EQ.'ONE')THEN IF(NX.EQ.NLEFT)GOTO2590 ELSEIF(IFLAGV.EQ.'TWO')THEN IF(NHOR.EQ.NLEFT)GOTO2590 IF(IFLAGD.EQ.'ON' .AND. IBOOGR.EQ.'INDE')GOTO2590 ENDIF ELSEIF(NUMV2.EQ.3)THEN IF(IFLAGV.EQ.'ONE')THEN IF(NX.EQ.NLEFT .AND. NX2.EQ.NLEFT)GOTO2590 ELSEIF(IFLAGV.EQ.'TWO')THEN IF(NX.EQ.NLEFT.AND.NHOR.EQ.NLEFT)GOTO2590 ENDIF ELSEIF(NUMV2.EQ.4)THEN IF(NX.EQ.NLEFT.AND.NX2.EQ.NLEFT.AND.NHOR.EQ.NLEFT)GOTO2590 ENDIF C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2571) 2571 FORMAT('***** ERROR IN BOOTSTRAP/JACKNIFE PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2572)NUMV2 2572 FORMAT(' FOR A BOOTSTRAP/JACKNIFE ... PLOT, WHEN ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2579) 2579 FORMAT(' VARIABLES SPECIFIED, THE NUMBER OF ELEMENTS IN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2580)NUMV2 2580 FORMAT(' THE ',I8,' VARIABLES MUST BE THE SAME;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2582) 2582 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2583)IHLEFT,IHLEF2,NLEFT 2583 FORMAT(' VARIABLE 1 ',A4,A4,' HAS ',I8,' ELEMENTS') CALL DPWRST('XXX','BUG ') IF(NUMV2.EQ.2 .AND. IFLAGV.EQ.'TWO')THEN WRITE(ICOUT,2584)IHHOR,IHHOR2,NHOR 2584 FORMAT(' RESPONSE VARIABLE 2 ',A4,A4,' HAS ',I8, 1 ' ELEMENTS') CALL DPWRST('XXX','BUG ') ELSEIF(NUMV2.EQ.2 .AND. IFLAGV.EQ.'ONE')THEN WRITE(ICOUT,2585)IHX,IHX2,NX2 CALL DPWRST('XXX','BUG ') ELSEIF(NUMV2.EQ.3 .AND. IFLAGV.EQ.'TWO')THEN WRITE(ICOUT,2585)IHX,IHX2,NX 2585 FORMAT(' GROUP VARIABLE 1 ',A4,A4,' HAS ',I8, 1 ' ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2584)IHHOR,IHHOR2,NHOR CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') ELSEIF(NUMV2.EQ.3 .AND. IFLAGV.EQ.'ONE')THEN WRITE(ICOUT,2585)IHX,IHX2,NX CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2589)IHXG,IHXG2,NX2 2589 FORMAT(' GROUP VARIABLE 2 ',A4,A4,' HAS ',I8, 1 ' ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') ELSEIF(NUMV2.EQ.4)THEN WRITE(ICOUT,2585)IHX,IHX2,NX CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2589)IHXG,IHXG2,NX2 CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2584)IHHOR,IHHOR2,NHOR CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') ENDIF WRITE(ICOUT,2587) 2587 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2588)(IANS(I),I=1,IWIDTH) 2588 FORMAT(' ',80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 C 2590 CONTINUE C C ************************************************* C ** STEP 26-- ** C ** BRANCH TO THE APPROPRIATE SUBCASE; ** C ** (BASED ON THE QUALIFIER) ** C ** THEN FORM THE RESPONSE VARIABLE ** C ** AND THE SECOND VARIABLE (IF EXISTENT) ** C ************************************************* C ISTEPN='26' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'JBSP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CCCCC MARCH 2003: ACCOUNT FOR CASE OF INDPENDENT GROUPS FOR CCCCC "DIFFERENCE OF" STATISTICS. IN THIS CASE, EQUAL SAMPLE CCCCC SIZES NOT REQUIRED. C NMAX=NLEFT IF(NUMV2.EQ.2 .AND. IFLAGD.EQ.'ON' .AND. IBOOGR.EQ.'INDE') 1 NMAX=MAX(NLEFT,NHOR) C IF(ICASEQ.EQ.'FULL')GOTO2610 IF(ICASEQ.EQ.'SUBS')GOTO2620 IF(ICASEQ.EQ.'FOR')GOTO2630 C 2610 CONTINUE DO2615I=1,NMAX ISUB(I)=1 2615 CONTINUE NQ=NMAX GOTO2650 C 2620 CONTINUE NIOLD=NMAX CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO2650 C 2630 CONTINUE NIOLD=NMAX CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR NLOCA2=NLOCAL GOTO2650 C 2650 CONTINUE J=0 J2=0 IMAX=NMAX IF(NQ.LT.NMAX)IMAX=NQ DO2660I=1,IMAX IF(ISUB(I).EQ.0)GOTO2660 C IF(NUMV2.EQ.2.AND.IFLAGD.EQ.'ON'.AND.IBOOGR.EQ.'INDE'.AND. 1 J.GE.NLEFT)GOTO2665 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) IF(NUMV2.LE.1)GOTO2660 C 2665 CONTINUE IF(NUMV2.EQ.2.AND.IFLAGD.EQ.'ON'.AND.IBOOGR.EQ.'INDE'.AND. 1 J2.GE.NHOR)GOTO2660 J2=J2+1 IF(IFLAGV.EQ.'ONE')THEN IJ=MAXN*(ICOLX-1)+I IF(ICOLH.LE.MAXCOL)X1(J2)=V(IJ) IF(ICOLH.EQ.MAXCP1)X1(J2)=PRED(I) IF(ICOLH.EQ.MAXCP2)X1(J2)=RES(I) IF(ICOLH.EQ.MAXCP3)X1(J2)=YPLOT(I) IF(ICOLH.EQ.MAXCP4)X1(J2)=XPLOT(I) IF(ICOLH.EQ.MAXCP5)X1(J2)=X2PLOT(I) IF(ICOLH.EQ.MAXCP6)X1(J2)=TAGPLO(I) ELSE IJ=MAXN*(ICOLH-1)+I IF(ICOLH.LE.MAXCOL)Z1(J2)=V(IJ) IF(ICOLH.EQ.MAXCP1)Z1(J2)=PRED(I) IF(ICOLH.EQ.MAXCP2)Z1(J2)=RES(I) IF(ICOLH.EQ.MAXCP3)Z1(J2)=YPLOT(I) IF(ICOLH.EQ.MAXCP4)Z1(J2)=XPLOT(I) IF(ICOLH.EQ.MAXCP5)Z1(J2)=X2PLOT(I) IF(ICOLH.EQ.MAXCP6)Z1(J2)=TAGPLO(I) ENDIF IF(NUMV2.LE.2)GOTO2660 C IF(IFLAGV.EQ.'ONE')THEN IJ=MAXN*(ICOLX2-1)+I IF(ICOLX2.LE.MAXCOL)XGRP2(J)=V(IJ) IF(ICOLX2.EQ.MAXCP1)XGRP2(J)=PRED(I) IF(ICOLX2.EQ.MAXCP2)XGRP2(J)=RES(I) IF(ICOLX2.EQ.MAXCP3)XGRP2(J)=YPLOT(I) IF(ICOLX2.EQ.MAXCP4)XGRP2(J)=XPLOT(I) IF(ICOLX2.EQ.MAXCP5)XGRP2(J)=X2PLOT(I) IF(ICOLX2.EQ.MAXCP6)XGRP2(J)=TAGPLO(I) ELSE IJ=MAXN*(ICOLX-1)+I IF(ICOLX.LE.MAXCOL)X1(J)=V(IJ) IF(ICOLX.EQ.MAXCP1)X1(J)=PRED(I) IF(ICOLX.EQ.MAXCP2)X1(J)=RES(I) IF(ICOLX.EQ.MAXCP3)X1(J)=YPLOT(I) IF(ICOLX.EQ.MAXCP4)X1(J)=XPLOT(I) IF(ICOLX.EQ.MAXCP5)X1(J)=X2PLOT(I) IF(ICOLX.EQ.MAXCP6)X1(J)=TAGPLO(I) ENDIF C IF(NUMV2.LE.3)GOTO2660 C IJ=MAXN*(ICOLX2-1)+I IF(ICOLX2.LE.MAXCOL)XGRP2(J)=V(IJ) IF(ICOLX2.EQ.MAXCP1)XGRP2(J)=PRED(I) IF(ICOLX2.EQ.MAXCP2)XGRP2(J)=RES(I) IF(ICOLX2.EQ.MAXCP3)XGRP2(J)=YPLOT(I) IF(ICOLX2.EQ.MAXCP4)XGRP2(J)=XPLOT(I) IF(ICOLX2.EQ.MAXCP5)XGRP2(J)=X2PLOT(I) IF(ICOLX2.EQ.MAXCP6)XGRP2(J)=TAGPLO(I) GOTO2660 C 2660 CONTINUE NLOCAL=J IF(NUMV2.EQ.2.AND.IFLAGD.EQ.'ON'.AND.IBOOGR.EQ.'INDE')THEN NLOCA2=J2 ELSE NLOCA2=NLOCAL ENDIF C C **************************************************** C ** STEP 27-- ** C ** FOR THE 1-VARIABLE CASE ONLY, ** C ** DETERMINE IF THE ANALYST ** C ** HAS SPECIFIED THE GROUP SIZE, ** C ** FOR THE STATISTIC PLOT ANALYSIS. ** C ** THE GROUP SIZE SETTING IS DEFINED BY SEARCHING** C ** THE INTERNAL TABLE FOR THE PARAMETER NAME NI;** C ** IF FOUND, USE THE SPECIFIED VALUE. ** C ** IF NOT FOUND, GENERATE AN ERROR MESSAGE. ** C **************************************************** C ISTEPN='27' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'JBSP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C ******************************************************* C ** STEP 28-- ** C ** COMPUTE THE APPROPRIATE STATISTIC PLOT STATISTIC--* C ** (MEAN, STANDARD DEVIATION, RANGE, OR CUSUM). ** C ** COMPUTE CONFIDENCE LINES. ** C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** C ** VALUES Y(.) AND X(.) FOR THE PLOT. ** C ** DEFINE THE VECTOR D(.) TO 1'S, 2'S, AND 3'S ** C ** FOR THE PLOTTED VALUE, THE LOWER CONFIDENCE LINE,** C ** AND THE UPPER CONFIDENCE LINE. ** C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). ** C ******************************************************* C ISTEPN='28' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'JBSP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHP='ALPH' IHP2='A ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IHP,IHP2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')THEN ALPHA=0.05 ELSE ALPHA=VALUE(ILOCP) ENDIF IF(ALPHA.LT.0.0 .OR. ALPHA.GT.1.0)ALPHA=0.05 IF(ALPHA.GT.0.5)ALPHA=1.0-ALPHA C IF(IQUAVR.EQ.'NONE')THEN NPERC=0 ELSEIF(IQUAVR.EQ.'DEFAULT')THEN QP(1)=0.5 QP(2)=1.0 QP(3)=2.5 QP(4)=5.0 QP(5)=10.0 QP(6)=20.0 QP(7)=30.0 QP(8)=40.0 QP(9)=50.0 QP(10)=60.0 QP(11)=70.0 QP(12)=80.0 QP(13)=90.0 QP(14)=95.0 QP(15)=97.5 QP(16)=99.0 QP(17)=99.5 NPERC=17 ELSE IH41=IQUAVR(1:4) IH42=IQUAVR(5:8) IHWUSE='V' MESSAG='NO' CALL CHECKN(IH41,IH42,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) C IF(IERROR.EQ.'YES')THEN NPERC=0 ELSE ICOLQP=IVALUE(ILOCV) NPERC=IN(ILOCV) ICNT=0 DO4180I=1,NPERC IJ=MAXN*(ICOLQP-1)+I ICNT=ICNT+1 IF(ICOLQP.LE.MAXCOL)QP(ICNT)=V(IJ) IF(ICOLQP.EQ.MAXCP1)QP(ICNT)=PRED(I) IF(ICOLQP.EQ.MAXCP2)QP(ICNT)=RES(I) IF(ICOLQP.EQ.MAXCP3)QP(ICNT)=YPLOT(I) IF(ICOLQP.EQ.MAXCP4)QP(ICNT)=XPLOT(I) IF(ICOLQP.EQ.MAXCP5)QP(ICNT)=X2PLOT(I) IF(ICOLQP.EQ.MAXCP6)QP(ICNT)=TAGPLO(I) IF(QP(ICNT).LE.0.0 .OR. QP(ICNT).GE.100.0)THEN ICNT=ICNT-1 ENDIF 4180 CONTINUE NPERC=ICNT C ENDIF ENDIF C CCCCC JUNE, 1990. MOVE TEMP0 - RES2 DIMENSIONING FROM DPJBS2 CALL DPJBS2(Y1,Z1,X1,NLOCAL,NLOCA2,NUMV2,ICASPL,ISIZE,ICONT, 1ICASJB,IBOOSS,ISEED,NGRPV,IBCABT,ALPHA, 1IFLAGD,IFLAGV, 1ICENSO,IMETHD,NUMPAR,MINMAX,NPERC,IPOTTO, 1TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,XTEMP3,MAXOBV, CCCC JULY 2002. ADD FOLLOWING LINE 1ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1Y,X,D,NPLOTP,NPLOTV, CCCC MARCH 1998. ADD FOLLOWING 2 LINES 1TEMP0,TEMPZ0,RES1,RES2,TEMP4,TEMP5,XGRP2,TEMPTH,TEMP6, 1TEMP7,TEMP8,TEMPT2,QP,XPERC, 1DTEMP1,DTEMP2,DTEMP3,DTEMP4, 1BMEAN,BSD,B001,B005,B01,B025,B05,B10,B20,B50,B80,B90,B95, 1B975,B99,B995,B999, 1ISUBRO,IBUGG3,IERROR) C C AUTOMATICALLY SAVE CERTAIN PERCENTILE PARAMETERS. MARCH 1998 C JANUARY 2005: ONLY SAVE IF 1 PARAMETER IS ESTIMARED (E.G., C DISTRIBUTIONAL FITTING HAS 2 TO 4 PARAMETERS) C C C *************************************** C ** STEP 51-- ** C ** UPDATE INTERNAL DATAPLOT TABLES ** C *************************************** C CUTOFF=REAL(I1MACH(9)) ISTEPN='51' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) IF(NUMPAR.GT.1)GOTO5199 DO5100IPASS=1,17 IH=ISTATN(IPASS) IH2=ISTAT2(IPASS) DO5150I=1,NUMNAM I2=I IF(IH.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I).AND. 1 IUSE(I).EQ.'P')GOTO5180 5150 CONTINUE IF(NUMNAM.GE.MAXNAM)THEN WRITE(ICOUT,5151) 5151 FORMAT('***** ERROR IN BOOTSTRAP/JACKNIFE PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5152) 5152 FORMAT(' THE TOTAL NUMBER OF (VARIABLE + PARAMETER)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5153)MAXNAM 5153 FORMAT(' NAMES MUST BE AT MOST ',I8,'. SUCH WAS NOT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5155) 5155 FORMAT(' THE CASE HERE--THE MAXIMUM ALLOWABLE NUMBER OF') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5156) 5156 FORMAT(' NAMES HAS JUST BEEN EXCEEDED.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5157) 5157 FORMAT(' SUGGESTED ACTION--ENTER STATUS TO') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5158) 5158 FORMAT(' DETERMINE THE IMPORTANT (VERSUS UNIMPORTANT)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5160) 5160 FORMAT(' VARIABLES AND PARAMETERS, AND THEN REUSE SOME') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5161) 5161 FORMAT(' OF THE NAMES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5162) 5162 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,5163)(IANS(I),I=1,MIN(80,IWIDTH)) 5163 FORMAT(' ',80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF C NUMNAM=NUMNAM+1 ILOC=NUMNAM IHNAME(ILOC)=IH IHNAM2(ILOC)=IH2 IUSE(ILOC)='P' IF(IPASS.EQ.1)VALUE(ILOC)=BSD IF(IPASS.EQ.2)VALUE(ILOC)=BMEAN IF(IPASS.EQ.3)VALUE(ILOC)=B975 IF(IPASS.EQ.4)VALUE(ILOC)=B025 IF(IPASS.EQ.5)VALUE(ILOC)=B001 IF(IPASS.EQ.6)VALUE(ILOC)=B005 IF(IPASS.EQ.7)VALUE(ILOC)=B01 IF(IPASS.EQ.8)VALUE(ILOC)=B05 IF(IPASS.EQ.9)VALUE(ILOC)=B10 IF(IPASS.EQ.10)VALUE(ILOC)=B20 IF(IPASS.EQ.11)VALUE(ILOC)=B50 IF(IPASS.EQ.12)VALUE(ILOC)=B80 IF(IPASS.EQ.13)VALUE(ILOC)=B90 IF(IPASS.EQ.14)VALUE(ILOC)=B95 IF(IPASS.EQ.15)VALUE(ILOC)=B99 IF(IPASS.EQ.16)VALUE(ILOC)=B995 IF(IPASS.EQ.17)VALUE(ILOC)=B999 VAL=VALUE(ILOC) IF((-CUTOFF).LE.VAL.AND.VAL.LE.CUTOFF)IVAL=VAL+0.5 IF(VAL.GT.CUTOFF)IVAL=CUTOFF IF(VAL.LT.(-CUTOFF))IVAL=(-CUTOFF) IVALUE(ILOC)=IVAL GOTO5100 C 5180 CONTINUE IF(IPASS.EQ.1)VALUE(I2)=BSD IF(IPASS.EQ.2)VALUE(I2)=BMEAN IF(IPASS.EQ.3)VALUE(I2)=B975 IF(IPASS.EQ.4)VALUE(I2)=B025 IF(IPASS.EQ.5)VALUE(I2)=B001 IF(IPASS.EQ.6)VALUE(I2)=B005 IF(IPASS.EQ.7)VALUE(I2)=B01 IF(IPASS.EQ.8)VALUE(I2)=B05 IF(IPASS.EQ.9)VALUE(I2)=B10 IF(IPASS.EQ.10)VALUE(I2)=B20 IF(IPASS.EQ.11)VALUE(I2)=B50 IF(IPASS.EQ.12)VALUE(I2)=B80 IF(IPASS.EQ.13)VALUE(I2)=B90 IF(IPASS.EQ.14)VALUE(I2)=B95 IF(IPASS.EQ.15)VALUE(I2)=B99 IF(IPASS.EQ.16)VALUE(I2)=B995 IF(IPASS.EQ.17)VALUE(I2)=B999 VAL=VALUE(I2) IF((-CUTOFF).LE.VAL.AND.VAL.LE.CUTOFF)IVAL=VAL+0.5 IF(VAL.GT.CUTOFF)IVAL=CUTOFF IF(VAL.LT.(-CUTOFF))IVAL=(-CUTOFF) IVALUE(I2)=IVAL GOTO5100 C 5100 CONTINUE 5199 CONTINUE C C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'JBSP')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPJBSP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ 9012 FORMAT('ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ = ', 1 A4,2X,A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IFOUND,IERROR,IBOOSS,ICASJB 9013 FORMAT('IFOUND,IERROR,IBOOSS,ICASJB = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 9014 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ', 1 I8,I8,I8,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)ISIZE 9015 FORMAT('ISIZE = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)NUMV2 9016 FORMAT('NUMV2 = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)IHLEFT,IHLEF2,ICOLL,NLEFT 9017 FORMAT('IHLEFT,IHLEF2,ICOLL,NLEFT = ',A4,2X,A4,I8,I8) CALL DPWRST('XXX','BUG ') IF(NUMV2.GE.2)THEN WRITE(ICOUT,9018)IHHOR,IHHOR2,ICOLH,NHOR 9018 FORMAT('IHHOR,IHHOR2,ICOLH,NHOR = ',A4,2X,A4,I8,I8) CALL DPWRST('XXX','BUG ') ENDIF IF(NUMV2.GE.3)THEN WRITE(ICOUT,9019)IHX,IHX2,ICOLX,NX 9019 FORMAT('IHX,IHX2,ICOLX,NX = ',A4,2X,A4,I8,I8) CALL DPWRST('XXX','BUG ') ENDIF IF(NPLOTP.LE.0)THEN DO9025I=1,NPLOTP WRITE(ICOUT,9026)I,Y(I),X(I),D(I) 9026 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) CALL DPWRST('XXX','BUG ') 9025 CONTINUE ENDIF ENDIF C RETURN END SUBROUTINE DPJBS2(Y,Z,X,N,NZ,NUMV2,ICASPL,ISIZE,ICONT, 1ICASJB,IBOOSS,ISEED,NGRPV,IBCABT,ALPHA, 1IFLAGD,IFLAGV, 1ICENSO,IMETHD,NUMPAR,MINMAX,NPERC,IPOTTO, 1TEMP,TEMPZ,XIDTEM,XTEMP1,XTEMP2,XTEMP3,MAXNXT, CCCC JULY 2002. ADD FOLLOWING LINE 1ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1Y2,X2,D2,N2,NPLOTV, 1TEMP0,TEMPZ0,RES1,RES2,TEMP4,XIDTE2,XGRP2,TEMPTH,TEMP6, 1TEMP7,TEMP8,TEMPT2,QP,XQP, 1DTEMP1,DTEMP2,DTEMP3,DTEMP4, CCCCC MARCH 1998. ADD FOLLOWING 2 LINES 1BMEAN,BSD,B001,B005,B01,B025,B05,B10,B20,B50,B80,B90,B95, 1B975,B99,B995,B999, 1ISUBRO,IBUGG3,IERROR) CCCCC JUNE, 1990. MOVE DIMENSIONING OF TEMP0 - RES2 TO DPJBSP C C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS C THAT WILL DEFINE A JACKNIFE OR BOOTSTRAP PLOT C (SEE DPJBSP FOR ALLOWABLE TYPES) 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 REFERENCE--ASTM MANUAL STP-15D, PAGES 78-84, 100-105 C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--89/2 C ORIGINAL VERSION--JANUARY 1989. C UPDATED --JUNE 1990. MOVE SOME DIMENSIONS TO DPJBSP C UPDATED --DECEMBER 1993. LINFIT ARGS C UPDATED --DECEMBER 1993. LINFIT ARGS: PROTECT RESSD/DF C UPDATED --MARCH 1995. MAD AND AAD C UPDATED --MARCH 1995. GEOMETRIC MEAN C UPDATED --MARCH 1995. GEOMETRIC SD C UPDATED --NOVEMBER 2001. BIWEIGHT LOCATION C UPDATED --NOVEMBER 2001. BIWEIGHT SCALE C UPDATED --JULY 2002. WINSORIZED VARIANCE C UPDATED --JULY 2002. WINSORIZED SD C UPDATED --JULY 2002. ADD WINSORIZED COVARIANCE C UPDATED --JULY 2002. ADD WINSORIZED CORRELATION C UPDATED --JULY 2002. ADD BIWEIGHT MIDVARIANCE C UPDATED --JULY 2002. ADD BIWEIGHT MIDCOVARIANCE C UPDATED --JULY 2002. ADD PERCENTAGE BEND MIDVARIANCE C UPDATED --JULY 2002. ADD PERCENTAGE BEND CORRELATION C UPDATED --JULY 2002. ADD HODGES LEHMAN C UPDATED --JULY 2002. ADD QUANTILE C UPDATED --JULY 2002. ADD QUANTILE STANDARD ERROR C UPDATED --JULY 2002. ADD TRIMMED MEAN STANDARD ERROR C UPDATED --JULY 2002. ADD BIWEIGHT CORRELATION C UPDATED --JULY 2002. ADD LINEAR CALIBRATION C UPDATED --JULY 2002. ADD QUADRATIC CALIBRATION C UPDATED --AUGUST 2002. USE "CMPSTA" TO COMPUTE MOST C STATISTICS. C UPDATED --MARCH 2003. ADD 34 "DIFFERENCE OF" STATS C UPDATED --MARCH 2003. FOR "DIFFERENCE OF" STATS, C DISTINGUISH BETWEEN INDEPENDENT C AND DEPENDENT GROUPS C UPDATED --APRIL 2003. SN AND QN (DIFFERENCE OF), C REQUIRED ADDITIONAL SCRATCH C ARRAYS. C UPDATED --JULY 2003. FOR GROUP CASE, WRITE SOME C RELEVANT PERCENTILES FOR C EACH GROUP TO DPST1F.DAT. C UPDATED --JULY 2003. SUPPORT TWO GROUP VARIABLES C UPDATED --SEPTEMBER 2003. SUPPORT BCA CONFIDENCE C INTERVALS: C A) COMPUTE FULL-SAMPLE STAT C B) COMPUTE JACKNIFE ESTIMATE C UPDATED --JANUARY 2005. SUPPORT BOOTSTRAP C DISTRIBUTIONAL FITTING C UPDATED --MARCH 2005. GENERALIZED PARETO MLE C UPDATED --MAY 2005. GENERALIZED PARETO DEHAAN, CME C UPDATED --JULY 2005. CALL LIST TO DPJBCP AND DPJBKS C UPDATED --AUGUST 2005. INVERTED WEIBULL MAXIMUM LIKE C UPDATED --MARCH 2006. GENERALIZED LOGISTC 2-5 C UPDATED --MARCH 2006. GENERALIZED LOGISTC 5 LMOMENTS C UPDATED --MARCH 2006. BETA NORMAL C UPDATED --MARCH 2006. CHECK FOR UNDEFINED ML FOR C ASYMMETRIC LAPLACE C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C EXTERNAL SUM EXTERNAL RANGE C CHARACTER*4 ICASPL CHARACTER*4 ICONT CHARACTER*4 ISUBRO CHARACTER*4 ISUBN0 CHARACTER*4 IBUGG3 CHARACTER*4 IERROR C CHARACTER*4 IHP CHARACTER*4 IHP2 CHARACTER*4 IHWUSE CHARACTER*4 MESSAG C CHARACTER*4 IWRITE CHARACTER*4 IFLAGD CHARACTER*4 IFLAGV CHARACTER*4 IBCABT CHARACTER*4 ICASZZ CHARACTER*4 ICENSO CHARACTER*4 IMETHD C CHARACTER*4 ICASJB CHARACTER*4 ICASRA C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN CHARACTER*25 IFORMT CHARACTER*25 IFORMZ 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 CHARACTER*80 IFILE3 CHARACTER*12 ISTAT3 CHARACTER*12 IFORM3 CHARACTER*12 IACCE3 CHARACTER*12 IPROT3 CHARACTER*12 ICURS3 CHARACTER*4 IERRF3 CHARACTER*4 IENDF3 CHARACTER*4 IREWI3 C CHARACTER*80 IFILE4 CHARACTER*12 ISTAT4 CHARACTER*12 IFORM4 CHARACTER*12 IACCE4 CHARACTER*12 IPROT4 CHARACTER*12 ICURS4 CHARACTER*4 IERRF4 CHARACTER*4 IENDF4 CHARACTER*4 IREWI4 C DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DSUM1 DOUBLE PRECISION DSUM2 C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION Y(*) DIMENSION Z(*) DIMENSION X(*) DIMENSION Y2(*) DIMENSION X2(*) DIMENSION D2(*) C DIMENSION TEMP(*) DIMENSION TEMPZ(*) DIMENSION XIDTEM(*) DIMENSION XIDTE2(*) DIMENSION XTEMP1(*) DIMENSION XTEMP2(*) DIMENSION XTEMP3(*) DIMENSION TEMP4(*) DIMENSION XGRP2(*) DIMENSION TEMPTH(*) DIMENSION TEMP6(*) DIMENSION TEMPT2(*) DIMENSION TEMP7(*) DIMENSION TEMP8(*) DIMENSION QP(*) DIMENSION XQP(*) C DOUBLE PRECISION DTEMP1(*) DOUBLE PRECISION DTEMP2(*) DOUBLE PRECISION DTEMP3(*) DOUBLE PRECISION DTEMP4(*) C INTEGER ITEMP1(*) INTEGER ITEMP2(*) INTEGER ITEMP3(*) INTEGER ITEMP4(*) INTEGER ITEMP5(*) INTEGER ITEMP6(*) C CCCCC JUNE, 1990. DIMENSION FOLLOWING ARRAYS IN DPJBSP CCCCC DIMENSION TEMP0(MAXOBV) CCCCC DIMENSION TEMPZ0(MAXOBV) CCCCC DIMENSION RES1(MAXOBV) CCCCC DIMENSION RES2(MAXOBV) DIMENSION TEMP0(*) DIMENSION TEMPZ0(*) DIMENSION RES1(*) DIMENSION RES2(*) C REAL KSLOC REAL KSSCAL C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOHK.INC' INCLUDE 'DPCOST.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='JBS2' ISUBN2='2 ' C IWRITE='OFF' C NUMPAR=1 C I2=0 ISIZE2=0 NUMSET=0 NUMSE1=0 NUMSE2=0 C NACC=0 NREJ=0 C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,31) 31 FORMAT('***** ERROR IN BOOTSTRAP/JACKNIFE PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,32) 32 FORMAT(' THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 1;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,34)N 34 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C IF(IBUGG3.GE.'ON'.OR.ISUBRO.EQ.'PSP2')THEN WRITE(ICOUT,70) 70 FORMAT('AT THE BEGINNING OF DPJBS2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71)IBUGG3,ISUBRO,ICASJB,IBOOSS 71 FORMAT('IBUGG3,ISUBRO,ICASJB,IBOOSS = ',A4,2X,A4,2X,A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)N,ICASPL,NUMV2,ISIZE,ICONT,NGRPV 72 FORMAT('N,ICASPL,NUMV2,ISIZE,ICONT,NGRPV = ', 1 I8,2X,A4,I8,I8,2X,A4,I4) CALL DPWRST('XXX','BUG ') DO73I=1,N IF(NUMV2.LE.2)THEN WRITE(ICOUT,74)I,Y(I),X(I),Z(I) 74 FORMAT('I, Y(I),X(I),Z(I) = ',I8,3F15.7) CALL DPWRST('XXX','BUG ') ELSEIF(NUMV2.GE.3)THEN WRITE(ICOUT,75)I,Y(I),Z(I),X(I) 75 FORMAT('I, Y(I),Z(I),X(I) = ',I8,3F15.7) CALL DPWRST('XXX','BUG ') ENDIF 73 CONTINUE WRITE(ICOUT,77)ICENSO,IMETHD,IPPLDP 77 FORMAT('ICENSO,IMETHD,IPPLDP = ',A4,2X,A4,2X,I8) CALL DPWRST('XXX','BUG ') ENDIF C C ******************************************************** C ** STEP 1-- ** C ** DETERMINE THE NUMBER OF DISTINCT VALUES ** C ** FOR THE GROUP VARIABLE (USUALLY VAR. 2) ** C ** IF ALL VALUES ARE DISTINCT, THEN THIS ** C ** IMPLIES WE HAVE THE NO REPLICATION CASE ** C ** WHICH IS AN ERROR CONDITION FOR A PLOT. ** C ******************************************************** C ISTEPN='1' IF(IBUGG3.GE.'ON'.OR.ISUBRO.EQ.'PSP2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMSET=0 IF(NGRPV.EQ.1)THEN DO151I=1,N IF(NUMSET.GT.0)THEN DO152J=1,NUMSET IF(X(I).EQ.XIDTEM(J))GOTO151 152 CONTINUE ENDIF NUMSET=NUMSET+1 XIDTEM(NUMSET)=X(I) 151 CONTINUE CALL SORT(XIDTEM,NUMSET,XIDTEM) ANUMSE=NUMSET C IF(NUMSET.LT.1)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,161) 161 FORMAT('***** ERROR IN BOOTSTRAP/JACKNIFE PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,162) 162 FORMAT(' FOR THE ONE GROUP VARIABLE CASE, THE NUMBER ', 1 'OF SETS = 0 ') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C ELSEIF(NUMSET.GE.N)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,175) 175 FORMAT('***** ERROR IN BOOTSTRAP/JACKNIFE PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,176) 176 FORMAT(' NUMBER OF SETS NUMSET IDENTICAL TO ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,177) 177 FORMAT(' NUMBER OF OBSERVATIONS N .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,178)NUMSET 178 FORMAT(' NUMSET = N = ',I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C ELSEIF(NGRPV.EQ.2)THEN CALL DISTIN(X,N,IWRITE,XIDTEM,NUMSE1,IBUGG3,IERROR) CALL SORT(XIDTEM,NUMSE1,XIDTEM) CALL DISTIN(XGRP2,N,IWRITE,XIDTE2,NUMSE2,IBUGG3,IERROR) CALL SORT(XIDTE2,NUMSE2,XIDTE2) NUMSET=NUMSE1*NUMSE2 C IF(NUMSE1.LT.1 .OR. NUMSE1.GE.N)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,181) 181 FORMAT('***** ERROR IN BOOTSTRAP/JACKNIFE PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,182) 182 FORMAT(' THE NUMBER OF SETS FOR THE GROUP ONE VARIABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,183) 183 FORMAT(' IS ZERO OR EQUAL TO THE NUMBER OF POINTS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,184)NUMSE1 184 FORMAT(' NUMBER OF SETS = ',I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ELSEIF(NUMSE2.LT.1 .OR. NUMSE2.GE.N)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,186) 186 FORMAT('***** ERROR IN BOOTSTRAP/JACKNIFE PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,187) 187 FORMAT(' THE NUMBER OF SETS FOR THE GROUP TWO VARIABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,188) 188 FORMAT(' IS ZERO OR EQUAL TO THE NUMBER OF POINTS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,189)NUMSE2 189 FORMAT(' NUMBER OF SETS = ',I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C ELSE NUMSET=0 ENDIF C AN=N C CCCCC JANUARY 2005. UNGROUPED DATA WILL WRITE TO FILES DPST1F.DAT CCCCC ANFD DPST2F.DAT. C CCCCC IF(NUMSET.GE.1 .OR. NUMSE1.GE.1)THEN IOUNI1=IST1NU IFILE1=IST1NA ISTAT1=IST1ST IFORM1=IST1FO IACCE1=IST1AC IPROT1=IST1PR ICURS1=IST1CS ISUBN0='JBS2' IERRF1='NO' C IREWI1='ON' CALL DPOPFI(IOUNI1,IFILE1,ISTAT1,IFORM1,IACCE1,IPROT1,ICURS1, 1 IREWI1,ISUBN0,IERRF1,IBUGG3,ISUBRO,IERROR) IF(IERRF1.EQ.'YES')GOTO9000 C IOUNI2=IST2NU IFILE2=IST2NA ISTAT2=IST2ST IFORM2=IST2FO IACCE2=IST2AC IPROT2=IST2PR ICURS2=IST2CS ISUBN0='JBS2' IERRF2='NO' C IREWI2='ON' CALL DPOPFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 1 IREWI2,ISUBN0,IERRF2,IBUGG3,ISUBRO,IERROR) IF(IERRF2.EQ.'YES')GOTO9000 C CCCCC ENDIF C IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')THEN IOUNI3=IST3NU IFILE3=IST3NA ISTAT3=IST3ST IFORM3=IST3FO IACCE3=IST3AC IPROT3=IST3PR ICURS3=IST3CS ISUBN0='JBS2' IERRF3='NO' C IREWI3='ON' CALL DPOPFI(IOUNI3,IFILE3,ISTAT3,IFORM3,IACCE3,IPROT3,ICURS3, 1 IREWI3,ISUBN0,IERRF3,IBUGG3,ISUBRO,IERROR) IF(IERRF3.EQ.'YES')GOTO9000 C WRITE(IOUNI3,203)100.0*(1.0-ALPHA) 203 FORMAT(' BCa BOOTSTRAP ',F7.2,'% CONFIDENCE INTERVALS:') WRITE(IOUNI3,205)ALPHA/2.0,(1.0-ALPHA/2) 205 FORMAT('SIGNIFICANCE LEVELS = (',F6.3,',',F6.3,')') WRITE(IOUNI3,207) 207 FORMAT(6X,'LOWER',11X,'UPPER') WRITE(IOUNI3,209) 209 FORMAT(3X,'CONFIDENCE',5X,'CONFIDENCE',11X,'^',14X,'^') WRITE(IOUNI3,211) 211 FORMAT(6X,'LIMIT',11X,'LIMIT',12X,'Z0',13X,'A0',6X,'ALPHA1', 1 3X,'ALPHA2') WRITE(IOUNI3,213) 213 FORMAT('---------------------------------------------------', 1 '-------------------------') ENDIF C C ****************************************** C ** STEP 11-- ** C ** COMPUTE THE SPECIFIED STATISTIC ** C ** FOR EACH SUBSET OF THE DATA, AND ** C ** THEN FOR THE FULL DATA SET ** C ****************************************** C ISTEPN='11' IF(IBUGG3.GE.'ON'.OR.ISUBRO.EQ.'PSP2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C J=0 J2=0 IF(NGRPV.EQ.1)THEN ISETMX=NUMSET+1 ELSEIF(NGRPV.EQ.2)THEN ISETMX=NUMSE1*NUMSE2+1 ELSE ISETMX=1 ENDIF C DO11000ISET=1,ISETMX C IF(ISET.EQ.ISETMX)THEN K=0 K2=0 DO11021I=1,MAX(N,NZ) IF(K.LT.N)THEN K=K+1 TEMP0(K)=Y(I) ENDIF IF(K2.LE.NZ)THEN K2=K2+1 TEMPZ0(K2)=Z(I) ENDIF IF(NUMV2.EQ.2.AND.IFLAGV.EQ.'ON')TEMPZ0(K)=Y(I) IF(IBUGG3.EQ.'ON')THEN WRITE(ICOUT,777)NUMSET,TEMP0(1),TEMP(1),TEMPZ0(1),TEMPZ0(2) CALL DPWRST('XXX','BUG ') ENDIF 11021 CONTINUE NS2=K NS22=K2 IF(NGRPV.EQ.2)THEN ISET1=0 ISET2=0 ENDIF ELSEIF(NGRPV.EQ.1 .AND. ISET.LE.NUMSET)THEN K=0 K2=0 DO11011I=1,MAX(N,NZ) IF(X(I).NE.XIDTEM(ISET))GOTO11011 IF(K.LT.N)THEN K=K+1 TEMP0(K)=Y(I) ENDIF IF(K2.LE.NZ)THEN K2=K2+1 TEMPZ0(K2)=Z(I) ENDIF IF(NUMV2.EQ.2.AND.IFLAGV.EQ.'TWO')TEMPZ0(K)=Z(I) IF(IBUGG3.EQ.'ON')THEN WRITE(ICOUT,777)NUMSET,TEMP0(1),TEMP(1),TEMPZ0(1),TEMPZ0(2) 777 FORMAT('NUMSET,TEMP0(1),TEMP(1),TEMPZ0(1),TEMPZ0(2) = ', 1 I8,4E15.7) CALL DPWRST('XXX','BUG ') ENDIF 11011 CONTINUE NI=K NS2=NI NI2=K2 NS22=NI2 ELSEIF(NGRPV.EQ.2 .AND. ISET.LE.NUMSE1*NUMSE2)THEN ISET1=INT((ISET-1)/NUMSE2) + 1 ISET2=MOD((ISET-1),NUMSE2) + 1 K=0 K2=0 DO11031I=1,MAX(N,NZ) IF(X(I).NE.XIDTEM(ISET1) .OR. XGRP2(I).NE.XIDTE2(ISET2)) 1 GOTO11031 IF(K.LT.N)THEN K=K+1 TEMP0(K)=Y(I) ENDIF IF(K2.LE.NZ)THEN K2=K2+1 TEMPZ0(K2)=Z(I) ENDIF IF(NUMV2.EQ.2.AND.IFLAGV.EQ.'TWO')TEMPZ0(K)=Z(I) IF(IBUGG3.EQ.'ON')THEN WRITE(ICOUT,777)NUMSET,TEMP0(1),TEMP(1), 1 TEMPZ0(1),TEMPZ0(2) CALL DPWRST('XXX','BUG ') ENDIF 11031 CONTINUE NI=K NS2=NI NI2=K2 NS22=NI2 ENDIF C IF(NS2.LT.1)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,11081) 11081 FORMAT('***** INTERNAL ERROR IN DPJBS2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,11082) 11082 FORMAT('NI FOR SOME CLASS = 0') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,11083)ISET,XIDTEM(ISET),NI 11083 FORMAT('ISET,XIDTEM(ISET),NI = ',I8,E15.7,I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C NRESAM=NS2 IF(ICASJB.EQ.'BOOT')NRESAM=IBOOSS C C AUGUST 2002. SIMPLIFY CODE BY USING "CMPSTA" TO COMPUTE C STATISTIC. NOTE THAT THE FOLLOWING DISTINCT CASES ARE SUPPORTED: C C 1) STATISTIC COMPUTED FROM A SINGLE RESPONSE VARIABLE C (MOST CASES IN THIS CATEGORY, E.G., THE MEAN) C 2) STATISTIC COMPUTED FROM TWO RESPONSE VARIABLES, C RESPONSES ARE PAIRED (E.G., THE CORRELATION). C 3) STATISTIC COMPUTED FROM TWO RESPONSE VARIABLES, THE C RESPONSES ARE NOT PAIRED (I.E., SAMPLE THE TWO VARIABLES C SEPARATELY). CURRENTLY, NO CASES FOR THIS. C 4) LINEAR AND QUADRATIC CALIBRATION HANDLED SEPARATELY. C 5) LINEAR SLOPE, LINEAR CORRELATION, LINEAR RESSD, C LINEAR INTERCEPT HANDLED SEPARATELY. C C CASES WITH TWO PAIRED RESPONSE VARIABLES C IF(ICASPL.EQ.'BIMC')GOTO11490 IF(ICASPL.EQ.'BICR')GOTO11490 IF(ICASPL.EQ.'WICV')GOTO11490 IF(ICASPL.EQ.'WICR')GOTO11490 IF(ICASPL.EQ.'COVA')GOTO11490 IF(ICASPL.EQ.'CORR')GOTO11490 IF(ICASPL.EQ.'RACV')GOTO11490 IF(ICASPL.EQ.'RACR')GOTO11490 IF(ICASPL.EQ.'KTAU')GOTO11490 IF(ICASPL.EQ.'PBCR')GOTO11490 IF(ICASPL.EQ.'RATI')GOTO11490 IF(IBOOGR.EQ.'DEPE'.AND.IFLAGD.EQ.'ON')GOTO11490 C C CASES WITH TWO UNPAIRED RESPONSE VARIABLES (NOT NECESSARILY OF C SAME SIZE) C IF(IBOOGR.EQ.'INDE'.AND.IFLAGD.EQ.'ON')GOTO11590 C C C HANDLE LINEAR INTERCEPT, LINEAR SLOPE, LINEAR RESSD, C LINEAR CORRELATION SEPARATELY. C IF(ICASPL.EQ.'LIIN')GOTO11730 IF(ICASPL.EQ.'LISL')GOTO11730 IF(ICASPL.EQ.'LIRE')GOTO11730 IF(ICASPL.EQ.'LICO')GOTO11730 C C HANDLE LINEAR CALIBRATION, QUADRATIC CALIBRATION SEPARATELY C LINEAR CORRELATION SEPARELY. C IF(ICASPL.EQ.'LICA')GOTO12210 IF(ICASPL.EQ.'QUCA')GOTO12240 C C JANUARY 2005: C HANDLE DISTRIBUTIONAL FITTING CASES SEPARATELY. THERE ARE C SEVERAL SUB-CASES: C C 1) PROBABILITY PLOT USED TO ESTIMATE LOCATION AND SCALE C 2) PPCC/PROBABILITY PLOT USED TO ESTIMATE SHAPE, LOCATION, AND SCALE C 3) KS/PROBABILITY PLOT USED TO ESTIMATE SHAPE, LOCATION, AND SCALE C 4) MAXIMUM LIKELIHOOD USED TO ESTIMATE DISTRIBUTION PARAMETERS C IF(ICASPL.EQ.'NOPP')GOTO14210 IF(ICASPL.EQ.'LOPP')GOTO14210 IF(ICASPL.EQ.'LAPP')GOTO14210 IF(ICASPL.EQ.'UNPP')GOTO14210 IF(ICASPL.EQ.'CAPP')GOTO14210 IF(ICASPL.EQ.'EXPP')GOTO14210 IF(ICASPL.EQ.'GUPP')GOTO14210 IF(ICASPL.EQ.'HNPP')GOTO14210 IF(ICASPL.EQ.'COPP')GOTO14210 IF(ICASPL.EQ.'RAPP')GOTO14210 IF(ICASPL.EQ.'ARPP')GOTO14210 IF(ICASPL.EQ.'ANPP')GOTO14210 IF(ICASPL.EQ.'SEPP')GOTO14210 IF(ICASPL.EQ.'HSPP')GOTO14210 IF(ICASPL.EQ.'HCPP')GOTO14210 IF(ICASPL.EQ.'SLPP')GOTO14210 IF(ICASPL.EQ.'HLPP')GOTO14210 C CCCCC LANDAU HAS SOME PROBLEMS, SO COMMENT OUT FOR NOW CCCCC IF(ICASPL.EQ.'LUPP')GOTO14210 IF(ICASPL.EQ.'LUPP')THEN IERROR='YES' GOTO9000 ENDIF C IF(ICASPL.EQ.'WECP')GOTO14310 IF(ICASPL.EQ.'LNCP')GOTO14310 IF(ICASPL.EQ.'GACP')GOTO14310 IF(ICASPL.EQ.'GICP')GOTO14310 IF(ICASPL.EQ.'LGCP')GOTO14310 IF(ICASPL.EQ.'IWCP')GOTO14310 IF(ICASPL.EQ.'GECP')GOTO14310 IF(ICASPL.EQ.'CSCP')GOTO14310 IF(ICASPL.EQ.'CHCP')GOTO14310 IF(ICASPL.EQ.'TCP')GOTO14310 IF(ICASPL.EQ.'EECP')GOTO14310 IF(ICASPL.EQ.'FLCP')GOTO14310 IF(ICASPL.EQ.'E2CP')GOTO14310 IF(ICASPL.EQ.'WACP')GOTO14310 IF(ICASPL.EQ.'PACP')GOTO14310 IF(ICASPL.EQ.'P2CP')GOTO14310 IF(ICASPL.EQ.'LACP')GOTO14310 IF(ICASPL.EQ.'BRCP')GOTO14310 IF(ICASPL.EQ.'RECP')GOTO14310 IF(ICASPL.EQ.'TRCP')GOTO14310 IF(ICASPL.EQ.'ERCP')GOTO14310 IF(ICASPL.EQ.'LLCP')GOTO14310 IF(ICASPL.EQ.'DWCP')GOTO14310 IF(ICASPL.EQ.'FTCP')GOTO14310 IF(ICASPL.EQ.'SDCP')GOTO14310 IF(ICASPL.EQ.'ADCP')GOTO14310 IF(ICASPL.EQ.'LXCP')GOTO14310 IF(ICASPL.EQ.'GVCP')GOTO14310 IF(ICASPL.EQ.'PFCP')GOTO14310 IF(ICASPL.EQ.'VMCP')GOTO14310 IF(ICASPL.EQ.'WCCP')GOTO14310 IF(ICASPL.EQ.'GLCP')GOTO14310 IF(ICASPL.EQ.'GZCP')GOTO14310 IF(ICASPL.EQ.'DGCP')GOTO14310 IF(ICASPL.EQ.'PNCP')GOTO14310 IF(ICASPL.EQ.'G2CP')GOTO14310 IF(ICASPL.EQ.'G3CP')GOTO14310 IF(ICASPL.EQ.'G5CP')GOTO14310 C IF(ICASPL.EQ.'GHCP')GOTO14360 IF(ICASPL.EQ.'IGCP')GOTO14360 IF(ICASPL.EQ.'GGCP')GOTO14360 IF(ICASPL.EQ.'BECP')GOTO14360 IF(ICASPL.EQ.'FNCP')GOTO14360 IF(ICASPL.EQ.'FCP')GOTO14360 IF(ICASPL.EQ.'BNCP')GOTO14360 IF(ICASPL.EQ.'G4CP')GOTO14360 IF(ICASPL.EQ.'LDCP')GOTO14360 C IF(ICASPL.EQ.'WEKS')GOTO14410 IF(ICASPL.EQ.'LNKS')GOTO14410 IF(ICASPL.EQ.'GAKS')GOTO14410 IF(ICASPL.EQ.'GIKS')GOTO14410 IF(ICASPL.EQ.'LGKS')GOTO14410 IF(ICASPL.EQ.'IWKS')GOTO14410 IF(ICASPL.EQ.'GEKS')GOTO14410 IF(ICASPL.EQ.'CSKS')GOTO14410 IF(ICASPL.EQ.'CHKS')GOTO14410 IF(ICASPL.EQ.'TKS')GOTO14410 IF(ICASPL.EQ.'EEKS')GOTO14410 IF(ICASPL.EQ.'FLKS')GOTO14410 IF(ICASPL.EQ.'E2KS')GOTO14410 IF(ICASPL.EQ.'WAKS')GOTO14410 IF(ICASPL.EQ.'PAKS')GOTO14410 IF(ICASPL.EQ.'LAKS')GOTO14410 IF(ICASPL.EQ.'BRKS')GOTO14410 IF(ICASPL.EQ.'REKS')GOTO14410 IF(ICASPL.EQ.'TRKS')GOTO14410 IF(ICASPL.EQ.'ERKS')GOTO14410 IF(ICASPL.EQ.'LLKS')GOTO14410 IF(ICASPL.EQ.'DWKS')GOTO14410 IF(ICASPL.EQ.'FTKS')GOTO14410 IF(ICASPL.EQ.'SDKS')GOTO14410 IF(ICASPL.EQ.'ADKS')GOTO14410 IF(ICASPL.EQ.'LXKS')GOTO14410 IF(ICASPL.EQ.'GVKS')GOTO14410 IF(ICASPL.EQ.'PFKS')GOTO14410 IF(ICASPL.EQ.'VMKS')GOTO14410 IF(ICASPL.EQ.'WCKS')GOTO14410 IF(ICASPL.EQ.'GLKS')GOTO14410 IF(ICASPL.EQ.'GZKS')GOTO14410 IF(ICASPL.EQ.'DGKS')GOTO14410 IF(ICASPL.EQ.'PNKS')GOTO14410 IF(ICASPL.EQ.'G2KS')GOTO14410 IF(ICASPL.EQ.'G3KS')GOTO14410 IF(ICASPL.EQ.'G5KS')GOTO14410 IF(ICASPL.EQ.'MAKS')GOTO14410 C IF(ICASPL.EQ.'GHKS')GOTO14460 IF(ICASPL.EQ.'IGKS')GOTO14460 IF(ICASPL.EQ.'GGKS')GOTO14460 IF(ICASPL.EQ.'BEKS')GOTO14460 IF(ICASPL.EQ.'FNKS')GOTO14460 IF(ICASPL.EQ.'FKS')GOTO14460 IF(ICASPL.EQ.'LDKS')GOTO14460 IF(ICASPL.EQ.'BNKS')GOTO14460 IF(ICASPL.EQ.'G4KS')GOTO14460 C IF(ICASPL.EQ.'NOML')GOTO14710 IF(ICASPL.EQ.'LOML')GOTO14710 IF(ICASPL.EQ.'LAML')GOTO14710 IF(ICASPL.EQ.'UNML')GOTO14710 IF(ICASPL.EQ.'CAML')GOTO14710 IF(ICASPL.EQ.'GUML')GOTO14710 IF(ICASPL.EQ.'EXML')GOTO14710 IF(ICASPL.EQ.'RAML')GOTO14710 IF(ICASPL.EQ.'MAML')GOTO14710 IF(ICASPL.EQ.'FNML')GOTO14710 C IF(ICASPL.EQ.'LNML')GOTO14810 IF(ICASPL.EQ.'WEML')GOTO14810 IF(ICASPL.EQ.'GAML')GOTO14810 IF(ICASPL.EQ.'EEML')GOTO14810 IF(ICASPL.EQ.'FLML')GOTO14810 IF(ICASPL.EQ.'IGML')GOTO14810 IF(ICASPL.EQ.'PAML')GOTO14810 IF(ICASPL.EQ.'GEML')GOTO14810 IF(ICASPL.EQ.'GEMO')GOTO14810 IF(ICASPL.EQ.'GEDE')GOTO14810 IF(ICASPL.EQ.'GECM')GOTO14810 IF(ICASPL.EQ.'FRML')GOTO14810 IF(ICASPL.EQ.'BEML')GOTO14810 IF(ICASPL.EQ.'IWML')GOTO14810 C IF(ICASPL.EQ.'ADML')GOTO14910 IF(ICASPL.EQ.'G5LM')GOTO14910 C C REMAINING CASES ARE FOR A SINGLE RESPONSE VARIABLE C GOTO11360 C C JACKNIFE/BOOTSTRAP FOR STATISTICS WITH ONE RESPONSE VARIABLE C 11360 CONTINUE C C FOR BCA CONFIDENCE INTERVAL, COMPUTE FULL-SAMPLE STATISTIC. C IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')THEN CALL CMPSTA( 1 TEMP0,TEMPZ,XTEMP1,XTEMP2,XTEMP3, 1 MAXNXT,NS2,NS2,NUMV2,ICASPL, 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1 IQUAME,IQUASE, 1 THETHT, 1 ISUBRO,IBUGG3,IERROR) NBELOW=0 ENDIF C TAGID=1.0 DO11361IRESAM=1,NRESAM CALL DPJBS3(TEMP0,NS2,ICASJB,IRESAM,ISEED,TEMP,NS3,ITEMP1, 1 TEMP4,IBUGG3,IERROR) CALL CMPSTA( 1 TEMP,TEMPZ,XTEMP1,XTEMP2,XTEMP3, 1 MAXNXT,NS3,NS3,NUMV2,ICASPL, 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1 IQUAME,IQUASE, 1 RIGHT, 1 ISUBRO,IBUGG3,IERROR) IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')THEN IF(RIGHT.LT.THETHT)NBELOW=NBELOW+1 TEMP6(IRESAM)=RIGHT ENDIF IF(NGRPV.LE.1)THEN CALL DPJBS4(ISET,NUMSET,J,J2,RIGHT,TAGID,XIDTEM,Y2,X2,D2) ELSE CALL DPJBS5(ISET1,ISET2,NUMSE1,NUMSE2,J,RIGHT,XIDTEM, 1 XIDTE2,Y2,X2,D2) ENDIF 11361 CONTINUE C C FOR BCA CONFIDENCE INTERVAL, COMPUTE: C 1) Z0HAT C 2) JACKNIFE ESTIMATES C IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')THEN CALL NORPPF(REAL(NBELOW)/REAL(NRESAM),Z0HAT) ICASZZ='JACK' DO11363IRESAM=1,NS2 CALL DPJBS3(TEMP0,NS2,ICASZZ,IRESAM,ISEED,TEMP,NS3,ITEMP1, 1 TEMP4,IBUGG3,IERROR) CALL CMPSTA( 1 TEMP,TEMPZ,XTEMP1,XTEMP2,XTEMP3, 1 MAXNXT,NS3,NS3,NUMV2,ICASPL, 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1 IQUAME,IQUASE, 1 RIGHT, 1 ISUBRO,IBUGG3,IERROR) TEMPTH(IRESAM)=RIGHT 11363 CONTINUE CALL MEAN(TEMPTH,NS2,IWRITE,THETDT,IBUGG3,IERROR) DSUM1=0.0D0 DSUM2=0.0D0 DTHETM=DBLE(THETDT) DO11365I=1,NS2 DTERM1=DBLE(TEMPTH(I)) DSUM1 = DSUM1 + (DTHETM - DTERM1)**3 DSUM2 = DSUM2 + (DTHETM - DTERM1)**2 11365 CONTINUE DTERM2 = DSUM1/(6.0D0*(DSUM2**1.5)) A0HAT=REAL(DTERM2) CALL NORPPF(ALPHA/2.0,ALOWSL) CALL NORPPF(1.0 - ALPHA/2.0,AUPPSL) TERM1=Z0HAT + (Z0HAT + AUPPSL)/(1.0 - A0HAT*(Z0HAT+AUPPSL)) CALL NORCDF(TERM1,ALPHA2) TERM1=Z0HAT + (Z0HAT + ALOWSL)/(1.0 - A0HAT*(Z0HAT+ALOWSL)) CALL NORCDF(TERM1,ALPHA1) CALL PERCEN(100.0*ALPHA1,TEMP6,NS2,IWRITE,TEMP4,MAXNXT, 1 BCAUL,IBUGG3,IERROR) CALL PERCEN(100.0*ALPHA2,TEMP6,NS2,IWRITE,TEMP4,MAXNXT, 1 BCALL,IBUGG3,IERROR) IF(NGRPV.EQ.1)THEN WRITE(IOUNI3,11368)BCALL,BCAUL,Z0HAT,A0HAT,ALPHA1,ALPHA2, 1 XIDTEM(ISET) ELSEIF(NGRPV.EQ.2)THEN WRITE(IOUNI3,11368)BCALL,BCAUL,Z0HAT,A0HAT,ALPHA1,ALPHA2, 1 XIDTEM(ISET1),XIDTE2(ISET2) ELSE WRITE(IOUNI3,11368)BCALL,BCAUL,Z0HAT,A0HAT,ALPHA1,ALPHA2 ENDIF 11368 FORMAT(4E15.7,2F8.4,2F10.0) ENDIF C GOTO79000 C C JACKNIFE/BOOTSTRAP FOR STATISTICS WITH TWO (PAIRED) RESPONSE C VARIABLES C 11490 CONTINUE C C FOR BCA CONFIDENCE INTERVAL, COMPUTE FULL-SAMPLE STATISTIC. C IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')THEN CALL CMPSTA( 1 TEMP0,TEMPZ0,XTEMP1,XTEMP2,XTEMP3, 1 MAXNXT,NS2,NS2,NUMV2,ICASPL, 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1 IQUAME,IQUASE, 1 THETHT, 1 ISUBRO,IBUGG3,IERROR) NBELOW=0 ENDIF C TAGID=1.0 DO11491IRESAM=1,NRESAM CALL DPJBS3(TEMP0,NS2,ICASJB,IRESAM,ISEED,TEMP,NS3,ITEMP1, 1 TEMP4,IBUGG3,IERROR) DO11493IJ=1,NS3 TEMPZ(IJ)=TEMPZ0(ITEMP1(IJ)) 11493 CONTINUE CALL CMPSTA( 1 TEMP,TEMPZ,XTEMP1,XTEMP2,XTEMP3, 1 MAXNXT,NS3,NS3,NUMV2,ICASPL, 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1 IQUAME,IQUASE, 1 RIGHT, 1 ISUBRO,IBUGG3,IERROR) C IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')THEN IF(RIGHT.LT.THETHT)NBELOW=NBELOW+1 TEMP6(IRESAM)=RIGHT ENDIF C IF(NGRPV.LE.1)THEN CALL DPJBS4(ISET,NUMSET,J,J2,RIGHT,TAGID,XIDTEM,Y2,X2,D2) ELSE CALL DPJBS5(ISET1,ISET2,NUMSE1,NUMSE2,J,RIGHT,XIDTEM, 1 XIDTE2,Y2,X2,D2) ENDIF 11491 CONTINUE C C FOR BCA CONFIDENCE INTERVAL, COMPUTE: C 1) Z0HAT C 2) JACKNIFE ESTIMATES C IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')THEN CALL NORPPF(REAL(NBELOW)/REAL(NRESAM),Z0HAT) ICASZZ='JACK' DO11496IRESAM=1,NS2 CALL DPJBS3(TEMP0,NS2,ICASZZ,IRESAM,ISEED,TEMP,NS3,ITEMP1, 1 TEMP4,IBUGG3,IERROR) CALL CMPSTA( 1 TEMP,TEMPZ0,XTEMP1,XTEMP2,XTEMP3, 1 MAXNXT,NS3,NS3,NUMV2,ICASPL, 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1 IQUAME,IQUASE, 1 RIGHT, 1 ISUBRO,IBUGG3,IERROR) TEMPTH(IRESAM)=RIGHT 11496 CONTINUE CALL MEAN(TEMPTH,NS2,IWRITE,THETDT,IBUGG3,IERROR) DSUM1=0.0D0 DSUM2=0.0D0 DTHETM=DBLE(THETDT) DO11497I=1,NS2 DTERM1=DBLE(TEMPTH(I)) DSUM1 = DSUM1 + (DTHETM - DTERM1)**3 DSUM2 = DSUM2 + (DTHETM - DTERM1)**2 11497 CONTINUE DTERM2 = DSUM1/(6.0D0*(DSUM2**1.5)) A0HAT=REAL(DTERM2) CALL NORPPF(ALPHA/2.0,ALOWSL) CALL NORPPF(1.0 - ALPHA/2.0,AUPPSL) TERM1=Z0HAT + (Z0HAT + AUPPSL)/(1.0 - A0HAT*(Z0HAT+AUPPSL)) CALL NORCDF(TERM1,ALPHA2) TERM1=Z0HAT + (Z0HAT + ALOWSL)/(1.0 - A0HAT*(Z0HAT+ALOWSL)) CALL NORCDF(TERM1,ALPHA1) CALL PERCEN(100.0*ALPHA1,TEMP6,NS2,IWRITE,TEMP4,MAXNXT, 1 BCAUL,IBUGG3,IERROR) CALL PERCEN(100.0*ALPHA2,TEMP6,NS2,IWRITE,TEMP4,MAXNXT, 1 BCALL,IBUGG3,IERROR) IF(NGRPV.EQ.1)THEN WRITE(IOUNI3,11498)BCALL,BCAUL,Z0HAT,A0HAT,ALPHA1,ALPHA2, 1 XIDTEM(ISET) ELSEIF(NGRPV.EQ.2)THEN WRITE(IOUNI3,11498)BCALL,BCAUL,Z0HAT,A0HAT,ALPHA1,ALPHA2, 1 XIDTEM(ISET1),XIDTE2(ISET2) ELSE WRITE(IOUNI3,11498)BCALL,BCAUL,Z0HAT,A0HAT,ALPHA1,ALPHA2 ENDIF 11498 FORMAT(4E15.7,2F8.4,2F10.0) ENDIF C GOTO79000 C C JACKNIFE/BOOTSTRAP FOR STATISTICS WITH TWO (UNPAIRED) RESPONSE C VARIABLES. CURRENTLY ONLY FOR EQUAL SAMPLE SIZES, NEED TO C EXTEND TO UNEQUAL SAMPLE SIZES. C C BCA INTERVALS NOT COMPUTED FOR THIS CASE (NOT CLEAR HOW TO C PERFORM THE JACKNIFE STEP FOR UNPAIRED SAMPLES). C 11590 CONTINUE IBCABT='OFF' TAGID=1.0 DO11591IRESAM=1,NRESAM CALL DPJBS3(TEMP0,NS2,ICASJB,IRESAM,ISEED,TEMP,NS3,ITEMP1, 1 TEMP4,IBUGG3,IERROR) CALL DPJBS3(TEMPZ0,NS22,ICASJB,IRESAM,ISEED,TEMPZ,NS32,ITEMP1, 1 TEMP4,IBUGG3,IERROR) CALL CMPSTA( 1 TEMP,TEMPZ,XTEMP1,XTEMP2,XTEMP3, 1 MAXNXT,NS3,NS32,NUMV2,ICASPL, 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1 IQUAME,IQUASE, 1 RIGHT, 1 ISUBRO,IBUGG3,IERROR) IF(NGRPV.LE.1)THEN CALL DPJBS4(ISET,NUMSET,J,J2,RIGHT,TAGID,XIDTEM,Y2,X2,D2) ELSE CALL DPJBS5(ISET1,ISET2,NUMSE1,NUMSE2,J,RIGHT,XIDTEM, 1 XIDTE2,Y2,X2,D2) ENDIF 11591 CONTINUE GOTO79000 C C JACKNIFE/BOOTSTRAP FOR THE 4 LINEAR FIT CASES C 11730 CONTINUE C C FOR BCA CONFIDENCE INTERVAL, COMPUTE FULL-SAMPLE STATISTIC. C IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')THEN CALL CMPSTA( 1 TEMP0,TEMPZ0,XTEMP1,XTEMP2,XTEMP3, 1 MAXNXT,NS2,NS2,NUMV2,ICASPL, 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1 IQUAME,IQUASE, 1 THETHT, 1 ISUBRO,IBUGG3,IERROR) NBELOW=0 ENDIF C CALL LINFIT(TEMP0,TEMPZ0,NS2, 1 ALPHA,BETA,XRESSD,XRESDF,CCXY,SDALPH,SDBETA,CCALBE, 1 ISUBRO,IBUGG3,IERROR) ALPHA0=ALPHA BETA0=BETA DO11731I=1,NS2 RES1(I)=TEMP0(I)-(ALPHA0+BETA0*TEMPZ0(I)) 11731 CONTINUE DO11732IRESAM=1,NRESAM CALL DPJBS3(RES1,NS2,ICASJB,IRESAM,ISEED,RES2,NS3,ITEMP1, 1 TEMP4,IBUGG3,IERROR) DO11733I=1,NS3 TEMP0(I)=(ALPHA0+BETA0*TEMPZ0(I))+RES2(I) 11733 CONTINUE CALL CMPSTA( 1 TEMP0,TEMPZ0,XTEMP1,XTEMP2,XTEMP3, 1 MAXNXT,NS3,NS3,NUMV2,ICASPL, 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1 IQUAME,IQUASE, 1 RIGHT, 1 ISUBRO,IBUGG3,IERROR) C IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')THEN IF(RIGHT.LT.THETHT)NBELOW=NBELOW+1 TEMP6(IRESAM)=RIGHT ENDIF C IF(NGRPV.LE.1)THEN TAGID=1.0 CALL DPJBS4(ISET,NUMSET,J,J2,RIGHT,TAGID,XIDTEM,Y2,X2,D2) ELSE CALL DPJBS5(ISET1,ISET2,NUMSE1,NUMSE2,J,RIGHT,XIDTEM, 1 XIDTE2,Y2,X2,D2) ENDIF 11732 CONTINUE C C FOR BCA CONFIDENCE INTERVAL, COMPUTE: C 1) Z0HAT C 2) JACKNIFE ESTIMATES C IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')THEN CALL NORPPF(REAL(NBELOW)/REAL(NRESAM),Z0HAT) ICASZZ='JACK' DO11831IRESAM=1,NS2 CALL DPJBS3(RES1,NS2,ICASJB,IRESAM,ISEED,RES2,NS3,ITEMP1, 1 TEMP4,IBUGG3,IERROR) DO11833I=1,NS3 TEMP0(I)=(ALPHA0+BETA0*TEMPZ0(I))+RES2(I) 11833 CONTINUE CALL CMPSTA( 1 TEMP0,TEMPZ0,XTEMP1,XTEMP2,XTEMP3, 1 MAXNXT,NS3,NS3,NUMV2,ICASPL, 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1 IQUAME,IQUASE, 1 RIGHT, 1 ISUBRO,IBUGG3,IERROR) TEMPTH(IRESAM)=RIGHT 11831 CONTINUE CALL MEAN(TEMPTH,NS2,IWRITE,THETDT,IBUGG3,IERROR) DSUM1=0.0D0 DSUM2=0.0D0 DTHETM=DBLE(THETDT) DO11835I=1,NS2 DTERM1=DBLE(TEMPTH(I)) DSUM1 = DSUM1 + (DTHETM - DTERM1)**3 DSUM2 = DSUM2 + (DTHETM - DTERM1)**2 11835 CONTINUE DTERM2 = DSUM1/(6.0D0*(DSUM2**1.5)) A0HAT=REAL(DTERM2) CALL NORPPF(ALPHA/2.0,ALOWSL) CALL NORPPF(1.0 - ALPHA/2.0,AUPPSL) TERM1=Z0HAT + (Z0HAT + AUPPSL)/(1.0 - A0HAT*(Z0HAT+AUPPSL)) CALL NORCDF(TERM1,ALPHA2) TERM1=Z0HAT + (Z0HAT + ALOWSL)/(1.0 - A0HAT*(Z0HAT+ALOWSL)) CALL NORCDF(TERM1,ALPHA1) CALL PERCEN(100.0*ALPHA1,TEMP6,NS2,IWRITE,TEMP4,MAXNXT, 1 BCAUL,IBUGG3,IERROR) CALL PERCEN(100.0*ALPHA2,TEMP6,NS2,IWRITE,TEMP4,MAXNXT, 1 BCALL,IBUGG3,IERROR) IF(NGRPV.EQ.1)THEN WRITE(IOUNI3,11838)BCALL,BCAUL,Z0HAT,A0HAT,ALPHA1,ALPHA2, 1 XIDTEM(ISET) ELSEIF(NGRPV.EQ.2)THEN WRITE(IOUNI3,11838)BCALL,BCAUL,Z0HAT,A0HAT,ALPHA1,ALPHA2, 1 XIDTEM(ISET1),XIDTE2(ISET2) ELSE WRITE(IOUNI3,11838)BCALL,BCAUL,Z0HAT,A0HAT,ALPHA1,ALPHA2 ENDIF 11838 FORMAT(4E15.7,2F8.4,2F10.0) ENDIF C GOTO79000 C C JACKNIFE/BOOTSTRAP FOR THE LINEAR/QUADRATIC CALIBRATION CASES C C CCCCC NOTE: FOR LINEAR CALIBRATION, 2 METHODS. "RESI" USES CCCCC EFROM METHOD OF RESAMPLING THE RESIDUALS. "DATA" CCCCC USES WU METHOD OF RESAMPLING THE ORIGINAL Y AND X. CCCCC IN EITHER CASE, THE PARAMETER Y0 SHOULD BE PRE-DEFINED. C 12210 CONTINUE C IBCABT='OFF' C IHP='Y0 ' IHP2=' ' IHWUSE='P' MESSAG='YES' CALL CHECKN(IHP,IHP2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')THEN GOTO9000 ELSE Y0=VALUE(ILOCP) ENDIF C IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JSB2')THEN DO12239I=1,NS2 WRITE(ICOUT,12231)I,TEMP0(I),TEMPZ0(I) 12231 FORMAT('I,TEMP0(I),TEMPZ0(I) = ',I8,2G15.7) CALL DPWRST('XXX','BUG ') 12239 CONTINUE ENDIF IF(IBOOME.EQ.'RESI')THEN C C GENERATE FIT AND RESIDUALS FROM ORIGINAL DATA. C CALL LINFIT(TEMP0,TEMPZ0,NS2, 1 ALPHA,BETA,XRESSD,XRESDF,CCXY,SDALPH,SDBETA,CCALBE, 1 ISUBRO,IBUGG3,IERROR) ALPHA0=ALPHA BETA0=BETA DO12211I=1,NS2 RES1(I)=TEMP0(I)-(ALPHA0+BETA0*TEMPZ0(I)) 12211 CONTINUE IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JSB2')THEN WRITE(ICOUT,12233)ALPHA0,BETA0 12233 FORMAT('ALPHA0,BETA0 = ',2G15.7) CALL DPWRST('XXX','BUG ') ENDIF C C RESAMPLE RESIDUALS. C DO12216IRESAM=1,NRESAM CALL DPJBS3(RES1,NS2,ICASJB,IRESAM,ISEED,RES2,NS3,ITEMP1, 1 TEMP4,IBUGG3,IERROR) DO12213I=1,NS3 TEMP(I)=(ALPHA0+BETA0*TEMPZ0(I))+RES2(I) 12213 CONTINUE CALL LINFIT(TEMP,TEMPZ0,NS3, 1 ALPHA,BETA,XRESSD,XRESDF,CCXY,SDALPH,SDBETA,CCALBE, 1 ISUBRO,IBUGG3,IERROR) A0=ALPHA A1=BETA RIGHT=(Y0-A0)/A1 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JSB2')THEN WRITE(ICOUT,12235)IRESAM,ALPHA,BETA,RIGHT 12235 FORMAT('IRESAM,ALPHA0,BETA0,RIGHT = ',I8,3G15.7) CALL DPWRST('XXX','BUG ') ENDIF TAGID=1.0 IF(NGRPV.LE.1)THEN CALL DPJBS4(ISET,NUMSET,J,J2,RIGHT,TAGID,XIDTEM, 1 Y2,X2,D2) ELSE CALL DPJBS5(ISET1,ISET2,NUMSE1,NUMSE2,J,RIGHT,XIDTEM, 1 XIDTE2,Y2,X2,D2) ENDIF 12216 CONTINUE ELSE C C RESAMPLE ORIGINAL Y AND X VALUES (ROWS OF Y AND X SHOULD REMAIN C PAIRED). C DO12226IRESAM=1,NRESAM CALL DPJBS3(TEMP0,NS2,ICASJB,IRESAM,ISEED,TEMP,NS3,ITEMP1, 1 TEMP4,IBUGG3,IERROR) DO12221IJ=1,NS3 TEMPZ(IJ)=TEMPZ0(ITEMP1(IJ)) 12221 CONTINUE CALL LINFIT(TEMP,TEMPZ,NS3, 1 ALPHA,BETA,XRESSD,XRESDF,CCXY,SDALPH,SDBETA,CCALBE, 1 ISUBRO,IBUGG3,IERROR) A0=ALPHA A1=BETA RIGHT=(Y0-A0)/A1 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JSB2')THEN WRITE(ICOUT,12237)IRESAM,ALPHA,BETA,RIGHT 12237 FORMAT('IRESAM,ALPHA0,BETA0,RIGHT = ',I8,3G15.7) CALL DPWRST('XXX','BUG ') ENDIF TAGID=1.0 IF(NGRPV.LE.1)THEN CALL DPJBS4(ISET,NUMSET,J,J2,RIGHT,TAGID,XIDTEM, 1 Y2,X2,D2) ELSE CALL DPJBS5(ISET1,ISET2,NUMSE1,NUMSE2,J,RIGHT,XIDTEM, 1 XIDTE2,Y2,X2,D2) ENDIF 12226 CONTINUE ENDIF GOTO79000 C CCCCC NOTE: FOR QUADRATIC CALIBRATION, 2 METHODS. "RESI" USES CCCCC EFROM METHOD OF RESAMPLING THE RESIDUALS. "DATA" CCCCC USES WU METHOD OF RESAMPLING THE ORIGINAL Y AND X. CCCCC IN EITHER CASE, THE PARAMETER Y0 SHOULD BE PRE-DEFINED. CCCCC CCCCC AFTER QUADRATIC FIT, QUADRATIC FORMULA IS: CCCCC X = (-b +/- SQRT(b**2 - 4*a*c))/(2*a) C 12240 CONTINUE C IHP='Y0 ' IHP2=' ' IHWUSE='P' MESSAG='YES' CALL CHECKN(IHP,IHP2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')THEN GOTO9000 ELSE Y0=VALUE(ILOCP) ENDIF C IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JSB2')THEN DO12269I=1,NS2 WRITE(ICOUT,12261)I,TEMP0(I),TEMPZ0(I) 12261 FORMAT('I,TEMP0(I),TEMPZ0(I) = ',I8,2G15.7) CALL DPWRST('XXX','BUG ') 12269 CONTINUE ENDIF C CALL MINIM(TEMPZ0,NS2,IWRITE,XLEFT,IBUGG3,IERROR) CALL MAXIM(TEMPZ0,NS2,IWRITE,XRIGHT,IBUGG3,IERROR) C IF(IBOOME.EQ.'RESI')THEN C C GENERATE FIT AND RESIDUALS FROM ORIGINAL DATA. C CALL QUAFI2(TEMPZ0,TEMP0,NS2, 1 XTEMP1, 1 ALPHA,BETA1,BETA2, 1 ISUBRO,IBUGG3,IERROR) ALPHA0=ALPHA BETA10=BETA1 BETA20=BETA2 C C=ALPHA - Y0 B=BETA1 A=BETA2 TERM1=B**2 - 4.0*A*C RIGH10=0.0 RIGH20=0.0 IF(TERM1.GE.0.0)THEN TERM1=SQRT(TERM1) RIGH10=(-B + TERM1)/(2*A) RIGH20=(-B - TERM1)/(2*A) ENDIF IF(RIGH10.GE.XLEFT .AND. RIGH10.LE.XRIGHT)THEN RIGHT0=RIGH10 ELSEIF(RIGH20.GE.XLEFT .AND. RIGH20.LE.XRIGHT)THEN RIGHT0=RIGH20 ELSE RIGHT0=RIGH10 ENDIF IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JSB2')THEN WRITE(ICOUT,12262)RIGH10,RIGH20 12262 FORMAT('FULL SAMPLE ROOTS: RIGH10,RIGH20 = ',2E15.7) CALL DPWRST('XXX','BUG ') ENDIF C DO12241I=1,NS2 AJUNK1=TEMPZ0(I) RES1(I)=TEMP0(I)-(ALPHA0+BETA10*AJUNK1+BETA20*AJUNK1**2) 12241 CONTINUE IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JSB2')THEN WRITE(ICOUT,12263)ALPHA0,BETA10,BETA20 12263 FORMAT('ALPHA0,BETA10,BETA20 = ',3G15.7) CALL DPWRST('XXX','BUG ') ENDIF C C RESAMPLE RESIDUALS. C NREJ=0 NNEG=0 DO12246IRESAM=1,NRESAM CALL DPJBS3(RES1,NS2,ICASJB,IRESAM,ISEED,RES2,NS3,ITEMP1, 1 TEMP4,IBUGG3,IERROR) DO12243I=1,NS3 AJUNK1=TEMPZ0(I) TEMP(I)=(ALPHA0+BETA10*AJUNK1+BETA20*AJUNK1**2)+RES2(I) 12243 CONTINUE CALL QUAFI2(TEMPZ0,TEMP,NS3, 1 XTEMP1, 1 ALPHA,BETA1,BETA2, 1 ISUBRO,IBUGG3,IERROR) C=ALPHA - Y0 B=BETA1 A=BETA2 TERM1=B**2 - 4.0*A*C IF(TERM1.EQ.0.0)THEN RIGHT=(-B + TERM1)/(2*A) ELSEIF(TERM1.GT.0.0)THEN TERM1=SQRT(TERM1) RIGH1=(-B + TERM1)/(2*A) RIGH2=(-B - TERM1)/(2*A) IF(RIGH1.GE.XLEFT .AND. RIGH1.LE.XRIGHT)THEN IF(RIGH2.GE.XLEFT .AND. RIGH2.LE.XRIGHT)THEN D1DIFF=ABS(RIGH1-RIGHT0) D2DIFF=ABS(RIGH2-RIGHT0) IF(D1DIFF.LE.D2DIFF)THEN RIGHT=RIGH1 ELSE RIGHT=RIGH2 ENDIF ELSE RIGHT=RIGH1 ENDIF ELSEIF(RIGH2.GE.XLEFT .AND. RIGH2.LE.XRIGHT)THEN RIGHT=RIGH2 ELSE IF(RIGH1.GT.0.0 .AND. RIGH2.LE.0.0)THEN RIGHT=RIGH1 ELSEIF(RIGH2.GT.0.0 .AND. RIGH1.LE.0.0)THEN RIGHT=RIGH2 ELSE D1DIFF=ABS(RIGH1-RIGHT0) D2DIFF=ABS(RIGH2-RIGHT0) IF(D1DIFF.LE.D2DIFF)THEN RIGHT=RIGH1 ELSE RIGHT=RIGH2 ENDIF ENDIF ENDIF IF(RIGHT.LT.0)NNEG=NNEG+1 ELSEIF(TERM1.LT.0.0)THEN NREJ=NREJ+1 GOTO12246 ENDIF IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JSB2')THEN WRITE(ICOUT,12265)IRESAM,ALPHA,BETA1,BETA2,RIGHT 12265 FORMAT('IRESAM,ALPHA,BETA1,BETA2,RIGHT = ',I8,3G15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,12266)A,B,C,TERM1 12266 FORMAT('A, B, C, TERM1 = ',4G15.7) CALL DPWRST('XXX','BUG ') ENDIF TAGID=1.0 IF(NGRPV.LE.1)THEN CALL DPJBS4(ISET,NUMSET,J,J2,RIGHT,TAGID,XIDTEM, 1 Y2,X2,D2) ELSE CALL DPJBS5(ISET1,ISET2,NUMSE1,NUMSE2,J,RIGHT,XIDTEM, 1 XIDTE2,Y2,X2,D2) ENDIF 12246 CONTINUE ELSE C C RESAMPLE ORIGINAL Y AND X VALUES (ROWS OF Y AND X SHOULD REMAIN C PAIRED). C NNEG=0 NREJ=0 DO12256IRESAM=1,NRESAM CALL DPJBS3(TEMP0,NS2,ICASJB,IRESAM,ISEED,TEMP,NS3,ITEMP1, 1 TEMP4,IBUGG3,IERROR) DO12251IJ=1,NS3 TEMPZ(IJ)=TEMPZ0(ITEMP1(IJ)) 12251 CONTINUE CALL QUAFI2(TEMPZ,TEMP,NS3, 1 XTEMP1, 1 ALPHA,BETA1,BETA2, 1 ISUBRO,IBUGG3,IERROR) C=ALPHA - Y0 B=BETA1 A=BETA2 TERM1=B**2 - 4.0*A*C IF(TERM1.EQ.0.0)THEN RIGHT=(-B + TERM1)/(2*A) ELSEIF(TERM1.GT.0.0)THEN TERM1=SQRT(TERM1) RIGH1=(-B + TERM1)/(2*A) RIGH2=(-B - TERM1)/(2*A) IF(RIGH1.GE.XLEFT .AND. RIGH1.LE.XRIGHT)THEN IF(RIGH2.GE.XLEFT .AND. RIGH2.LE.XRIGHT)THEN IF(RIGH1.GT.0.0 .AND. RIGH2.LE.0.0)THEN RIGHT=RIGH1 ELSEIF(RIGH2.GT.0.0 .AND. RIGH1.LE.0.0)THEN RIGHT=RIGH2 ELSE D1DIFF=ABS(RIGH1-RIGHT0) D2DIFF=ABS(RIGH2-RIGHT0) IF(D1DIFF.LE.D2DIFF)THEN RIGHT=RIGH1 ELSE RIGHT=RIGH2 ENDIF ENDIF ELSE RIGHT=RIGH1 ENDIF ELSEIF(RIGH2.GE.XLEFT .AND. RIGH2.LE.XRIGHT)THEN RIGHT=RIGH2 ELSE D1DIFF=ABS(RIGH1-RIGHT0) D2DIFF=ABS(RIGH2-RIGHT0) IF(D1DIFF.LE.D2DIFF)THEN RIGHT=RIGH1 ELSE RIGHT=RIGH2 ENDIF ENDIF IF(RIGHT.LT.0)NNEG=NNEG+1 ELSEIF(TERM1.LT.0.0)THEN NREJ=NREJ+1 GOTO12256 ENDIF IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JSB2')THEN WRITE(ICOUT,12265)IRESAM,ALPHA,BETA1,BETA2,RIGHT CALL DPWRST('XXX','BUG ') ENDIF TAGID=1.0 IF(NGRPV.LE.1)THEN CALL DPJBS4(ISET,NUMSET,J,J2,RIGHT,TAGID,XIDTEM, 1 Y2,X2,D2) ELSE CALL DPJBS5(ISET1,ISET2,NUMSE1,NUMSE2,J,RIGHT,XIDTEM, 1 XIDTE2,Y2,X2,D2) ENDIF 12256 CONTINUE ENDIF IF(NREJ.GT.0)THEN WRITE(ICOUT,12247) 12247 FORMAT('***** WARNING FROM DPJBS2--QUADRATIC CALIBRATION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,12248)NREJ 12248 FORMAT(' FOR ',I8,' BOOTSTRAP SAMPLES, NO REAL ROOTS ', 1 'FOR THE QUADRATIC EQUATION.') CALL DPWRST('XXX','BUG ') ENDIF IF(NNEG.GT.0)THEN WRITE(ICOUT,12247) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,12249)NREJ 12249 FORMAT(' FOR ',I8,' BOOTSTRAP SAMPLES, NEGATIVE ROOT ', 1 'SELECTED.') CALL DPWRST('XXX','BUG ') ENDIF GOTO79000 C C JANUARY 2005: IMPLEMENT BOOTSTRAP DISTRIBUTIONAL FITTING C C JACKNIFE/BOOTSTRAP FOR DISTRIBUTIONS THAT ESTIMATE LOCATION AND C SCALE PARAMETERS VIA A PROBABILITY PLOT. C 14210 CONTINUE C NUMPAR=3 C IF(NPERC.GT.0 .AND.ISET.EQ.1)THEN IOUNI4=IST4NU IFILE4=IST4NA ISTAT4=IST4ST IFORM4=IST4FO IACCE4=IST4AC IPROT4=IST4PR ICURS4=IST4CS ISUBN0='JBS2' IERRF4='NO' C IREWI4='ON' CALL DPOPFI(IOUNI4,IFILE4,ISTAT4,IFORM4,IACCE4, 1 IPROT4,ICURS4, 1 IREWI4,ISUBN0,IERRF4,IBUGG3,ISUBRO,IERROR) IF(IERRF4.EQ.'YES')GOTO9000 IF(NGRPV.EQ.0)THEN IFORMT='( E15.7)' IFORMZ='( F15.3)' IF(NPERC.LE.9)THEN WRITE(IFORMT(5:5),'(I1)')NPERC WRITE(IFORMZ(5:5),'(I1)')NPERC ELSEIF(NPERC.LE.99)THEN WRITE(IFORMT(4:5),'(I2)')NPERC WRITE(IFORMZ(4:5),'(I2)')NPERC ELSEIF(NPERC.LE.999)THEN WRITE(IFORMT(3:5),'(I3)')NPERC WRITE(IFORMZ(3:5),'(I3)')NPERC ELSE NPERC=0 ENDIF ELSEIF(NGRPV.EQ.1)THEN IFORMT='(I8,1X, E15.7)' IFORMZ='(9X, F15.3)' IF(NPERC.LE.9)THEN WRITE(IFORMT(11:11),'(I1)')NPERC WRITE(IFORMZ(8:8),'(I1)')NPERC ELSEIF(NPERC.LE.99)THEN WRITE(IFORMT(10:11),'(I2)')NPERC WRITE(IFORMZ(7:8),'(I2)')NPERC ELSEIF(NPERC.LE.999)THEN WRITE(IFORMT(9:11),'(I3)')NPERC WRITE(IFORMZ(7:8),'(I3)')NPERC ELSE NPERC=0 ENDIF ELSEIF(NGRPV.EQ.2)THEN IFORMT='(I8,1X,I8,1X, E15.7)' IFORMZ='(18X, F15.3)' IF(NPERC.LE.9)THEN WRITE(IFORMT(17:17),'(I1)')NPERC WRITE(IFORMZ(9:9),'(I1)')NPERC ELSEIF(NPERC.LE.99)THEN WRITE(IFORMT(16:17),'(I2)')NPERC WRITE(IFORMZ(8:9),'(I2)')NPERC ELSEIF(NPERC.LE.999)THEN WRITE(IFORMT(15:17),'(I3)')NPERC WRITE(IFORMZ(8:9),'(I3)')NPERC ELSE NPERC=0 ENDIF ENDIF IF(NPERC.GT.0)THEN WRITE(IOUNI4,IFORMZ)(QP(JJ),JJ=1,NPERC) ENDIF ENDIF C C FOR BCA CONFIDENCE INTERVAL, COMPUTE FULL-SAMPLE STATISTIC. C IF((IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT') .OR. 1 (IBOOPA.EQ.'PARA' .AND. ICENSO.NE.'ON'))THEN CALL DPJBPP( 1 TEMP0,TEMPZ0,NS2,ICASPL,ICENSO,IMETHD,IPPLDP,MAXNXT, 1 MINMAX, 1 XTEMP1,XTEMP2, 1 XTEMP3,TEMP8,RES1,RES2, 1 QP,XQP,NPERC, 1 PPA0HT,PPA1HT,CORRHT, 1 IBUGG3,ISUBRO,IERROR) ICASRA='NULL' PPA0SV=PPA0HT PPA1SV=PPA1HT IF(ICASPL.EQ.'NOPP')ICASRA='NORM' IF(ICASPL.EQ.'UNPP')ICASRA='UNIF' IF(ICASPL.EQ.'LOPP')ICASRA='LOGI' IF(ICASPL.EQ.'CAPP')ICASRA='CAUC' IF(ICASPL.EQ.'LAPP')ICASRA='DOUB' IF(ICASPL.EQ.'HNPP')ICASRA='HALF' IF(ICASPL.EQ.'EXPP')ICASRA='EXPO' IF(ICASPL.EQ.'GUPP')ICASRA='EXV1' IF(ICASPL.EQ.'SEPP')ICASRA='SEMI' IF(ICASPL.EQ.'HCPP')ICASRA='HFCA' IF(ICASPL.EQ.'COPP')ICASRA='COSI' IF(ICASPL.EQ.'ANPP')ICASRA='ANGL' IF(ICASPL.EQ.'HSPP')ICASRA='HSEC' IF(ICASPL.EQ.'HLPP')ICASRA='HALO' IF(ICASPL.EQ.'SLPP')ICASRA='SLAS' IF(ICASPL.EQ.'RAPP')ICASRA='RAYL' IF(ICASPL.EQ.'ARPP')ICASRA='ARCS' IF(ICASPL.EQ.'LUPP')ICASRA='LAND' NBELW1=0 NBELW2=0 NBELW3=0 ENDIF C C HANDLE BOOTSTRAP SAMPLE DIFFERENTLY FOR CENSORED AND UNCENSORED C DATA (CENSORED CASE HAS A PAIRED VARIABLE TO RESAMPLE) C IF(ICENSO.EQ.'OFF')THEN DO14261IRESAM=1,NRESAM IF(IBOOPA.EQ.'PARA')THEN CALL DPJBRA(ICASRA,ISEED,MINMAX, 1 TEMP,NS2, 1 SHAPE1,SHAPE2,PPA0SV,PPA1SV, 1 IMAKDF,IGEODF,IBEIDF,IBEKDF,IGEPDF,IADEDF, 1 ILGADF,ISKNDF,IGLDDF, 1 IBUGG3,ISUBRO,IERROR) ELSE CALL DPJBS3(TEMP0,NS2,ICASJB,IRESAM,ISEED, 1 TEMP,NS3,ITEMP1, 1 TEMP4,IBUGG3,IERROR) ENDIF CALL DPJBPP(TEMP,TEMP4,NS2, 1 ICASPL,ICENSO,IMETHD,IPPLDP,MAXNXT, 1 MINMAX, 1 XTEMP1,XTEMP2, 1 XTEMP3,TEMP8,RES1,RES2, 1 QP,XQP,NPERC, 1 PPA0,PPA1,ACORR, 1 IBUGG3,ISUBRO,IERROR) C IF((NGRPV.GE.1 .AND. NPERC.GT.0 .AND. ISET.LE.NUMSET) .OR. 1 (NPERC.GT.0 .AND. NGRPV.EQ.0 .AND. ISET.EQ.1))THEN IF(NGRPV.EQ.0)THEN WRITE(IOUNI4,IFORMT)(XQP(JJ),JJ=1,NPERC) ELSEIF(NGRPV.EQ.1)THEN WRITE(IOUNI4,IFORMT)ISET,(XQP(JJ),JJ=1,NPERC) ELSEIF(NGRPV.EQ.2)THEN WRITE(IOUNI4,IFORMT)ISET1,ISET2,(XQP(JJ),JJ=1,NPERC) ENDIF ENDIF C IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')THEN IF(PPA0.LT.PPA0HT)NBELW1=NBELW1+1 TEMP6(IRESAM)=PPA0 TEMP7(IRESAM)=PPA1 ENDIF IF(NGRPV.LE.1)THEN TAGID=1.0 CALL DPJBS4(ISET,NUMSET,J,J2,PPA0,TAGID,XIDTEM, 1 Y2,X2,D2) TAGID=2.0 CALL DPJBS4(ISET,NUMSET,J,J2,PPA1,TAGID,XIDTEM, 1 Y2,X2,D2) TAGID=3.0 CALL DPJBS4(ISET,NUMSET,J,J2,ACORR,TAGID,XIDTEM, 1 Y2,X2,D2) ELSE CALL DPJBS5(ISET1,ISET2,NUMSE1,NUMSE2,J,PPA0,XIDTEM, 1 XIDTE2,Y2,X2,D2) ENDIF 14261 CONTINUE ELSE DO14271IRESAM=1,NRESAM CALL DPJBS3(TEMP0,NS2,ICASJB,IRESAM,ISEED,TEMP,NS3,ITEMP1, 1 TEMP4,IBUGG3,IERROR) DO14273IJ=1,NS3 TEMPZ(IJ)=TEMPZ0(ITEMP1(IJ)) 14273 CONTINUE CALL DPJBPP(TEMP,TEMPZ,NS2, 1 ICASPL,ICENSO,IMETHD,IPPLDP,MAXNXT, 1 MINMAX, 1 XTEMP1,XTEMP2, 1 XTEMP3,TEMP8,RES1,RES2, 1 QP,XQP,NPERC, 1 PPA0,PPA1,ACORR, 1 IBUGG3,ISUBRO,IERROR) C IF((NGRPV.GE.1 .AND. NPERC.GT.0 .AND. ISET.LE.NUMSET) .OR. 1 (NPERC.GT.0 .AND. NGRPV.EQ.0 .AND. ISET.EQ.1))THEN IF(NGRPV.EQ.0)THEN WRITE(IOUNI4,IFORMT)(XQP(JJ),JJ=1,NPERC) ELSEIF(NGRPV.EQ.1)THEN WRITE(IOUNI4,IFORMT)ISET,(XQP(JJ),JJ=1,NPERC) ELSEIF(NGRPV.EQ.2)THEN WRITE(IOUNI4,IFORMT)ISET1,ISET2,(XQP(JJ),JJ=1,NPERC) ENDIF ENDIF C IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')THEN IF(PPA0.LT.PPA0HT)NBELW1=NBELW1+1 TEMP6(IRESAM)=PPA0 TEMP7(IRESAM)=PPA1 ENDIF IF(NGRPV.LE.1)THEN TAGID=1.0 CALL DPJBS4(ISET,NUMSET,J,J2,PPA0,TAGID,XIDTEM, 1 Y2,X2,D2) TAGID=2.0 CALL DPJBS4(ISET,NUMSET,J,J2,PPA1,TAGID,XIDTEM, 1 Y2,X2,D2) TAGID=3.0 CALL DPJBS4(ISET,NUMSET,J,J2,ACORR,TAGID,XIDTEM, 1 Y2,X2,D2) ELSE CALL DPJBS5(ISET1,ISET2,NUMSE1,NUMSE2,J,PPA0,XIDTEM, 1 XIDTE2,Y2,X2,D2) ENDIF 14271 CONTINUE ENDIF C C FOR BCA CONFIDENCE INTERVAL, COMPUTE: C 1) Z0HAT C 2) JACKNIFE ESTIMATES C IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')THEN CALL NORPPF(REAL(NBELOW)/REAL(NRESAM),Z0HAT) ICASZZ='JACK' DO14275IRESAM=1,NS2 CALL DPJBS3(TEMP0,NS2,ICASZZ,IRESAM,ISEED,TEMP,NS3,ITEMP1, 1 TEMP4,IBUGG3,IERROR) CALL CMPSTA( 1 TEMP,TEMPZ,XTEMP1,XTEMP2,XTEMP3, 1 MAXNXT,NS3,NS3,NUMV2,ICASPL, 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1 IQUAME,IQUASE, 1 RIGHT, 1 ISUBRO,IBUGG3,IERROR) TEMPTH(IRESAM)=RIGHT 14275 CONTINUE CALL MEAN(TEMPTH,NS2,IWRITE,THETDT,IBUGG3,IERROR) DSUM1=0.0D0 DSUM2=0.0D0 DTHETM=DBLE(THETDT) DO14265I=1,NS2 DTERM1=DBLE(TEMPTH(I)) DSUM1 = DSUM1 + (DTHETM - DTERM1)**3 DSUM2 = DSUM2 + (DTHETM - DTERM1)**2 14265 CONTINUE DTERM2 = DSUM1/(6.0D0*(DSUM2**1.5)) A0HAT=REAL(DTERM2) CALL NORPPF(ALPHA/2.0,ALOWSL) CALL NORPPF(1.0 - ALPHA/2.0,AUPPSL) TERM1=Z0HAT + (Z0HAT + AUPPSL)/(1.0 - A0HAT*(Z0HAT+AUPPSL)) CALL NORCDF(TERM1,ALPHA2) TERM1=Z0HAT + (Z0HAT + ALOWSL)/(1.0 - A0HAT*(Z0HAT+ALOWSL)) CALL NORCDF(TERM1,ALPHA1) CALL PERCEN(100.0*ALPHA1,TEMP6,NS2,IWRITE,TEMP4,MAXNXT, 1 BCAUL,IBUGG3,IERROR) CALL PERCEN(100.0*ALPHA2,TEMP6,NS2,IWRITE,TEMP4,MAXNXT, 1 BCALL,IBUGG3,IERROR) IF(NGRPV.EQ.1)THEN WRITE(IOUNI3,11368)BCALL,BCAUL,Z0HAT,A0HAT,ALPHA1,ALPHA2, 1 XIDTEM(ISET) ELSEIF(NGRPV.EQ.2)THEN WRITE(IOUNI3,11368)BCALL,BCAUL,Z0HAT,A0HAT,ALPHA1,ALPHA2, 1 XIDTEM(ISET1),XIDTE2(ISET2) ELSE WRITE(IOUNI3,11368)BCALL,BCAUL,Z0HAT,A0HAT,ALPHA1,ALPHA2 ENDIF ENDIF C ILAST=ISETMX IF(NGRPV.GE.1)ILAST=ISETMX-1 IF(NPERC.GT.0 .AND. ISET.EQ.ILAST)THEN IENDF4='OFF' IREWI4='ON' CALL DPCLFI(IOUNI4,IFILE4,ISTAT4,IFORM4,IACCE4,IPROT4,ICURS4, 1 IENDF4,IREWI4,ISUBN0,IERRF4,IBUGG3,ISUBRO,IERROR) IF(IERRF4.EQ.'YES')GOTO9000 ENDIF C GOTO79000 C C JACKNIFE/BOOTSTRAP FOR DISTRIBUTIONS THAT ESTIMATE ONE SHAPE C PARAMETER VIA PPCC PLOT AND LOCATION AND SCALE PARAMETERS VIA C A PROBABILITY PLOT. C 14310 CONTINUE C NUMPAR=4 NHOR1=IPPCAP(1) NHOR2=IPPCAP(2) C IF(NPERC.GT.0 .AND.ISET.EQ.1)THEN IOUNI4=IST4NU IFILE4=IST4NA ISTAT4=IST4ST IFORM4=IST4FO IACCE4=IST4AC IPROT4=IST4PR ICURS4=IST4CS ISUBN0='JBS2' IERRF4='NO' C IREWI4='ON' CALL DPOPFI(IOUNI4,IFILE4,ISTAT4,IFORM4,IACCE4, 1 IPROT4,ICURS4, 1 IREWI4,ISUBN0,IERRF4,IBUGG3,ISUBRO,IERROR) IF(IERRF4.EQ.'YES')GOTO9000 IF(NGRPV.EQ.0)THEN IFORMT='( E15.7)' IFORMZ='( F15.3)' IF(NPERC.LE.9)THEN WRITE(IFORMT(5:5),'(I1)')NPERC WRITE(IFORMZ(5:5),'(I1)')NPERC ELSEIF(NPERC.LE.99)THEN WRITE(IFORMT(4:5),'(I2)')NPERC WRITE(IFORMZ(4:5),'(I2)')NPERC ELSEIF(NPERC.LE.999)THEN WRITE(IFORMT(3:5),'(I3)')NPERC WRITE(IFORMZ(3:5),'(I3)')NPERC ELSE NPERC=0 ENDIF ELSEIF(NGRPV.EQ.1)THEN IFORMT='(I8,1X, E15.7)' IFORMZ='(9X, F15.3)' IF(NPERC.LE.9)THEN WRITE(IFORMT(11:11),'(I1)')NPERC WRITE(IFORMZ(8:8),'(I1)')NPERC ELSEIF(NPERC.LE.99)THEN WRITE(IFORMT(10:11),'(I2)')NPERC WRITE(IFORMZ(7:8),'(I2)')NPERC ELSEIF(NPERC.LE.999)THEN WRITE(IFORMT(9:11),'(I3)')NPERC WRITE(IFORMZ(7:8),'(I3)')NPERC ELSE NPERC=0 ENDIF ELSEIF(NGRPV.EQ.2)THEN IFORMT='(I8,1X,I8,1X, E15.7)' IFORMZ='(18X, F15.3)' IF(NPERC.LE.9)THEN WRITE(IFORMT(17:17),'(I1)')NPERC WRITE(IFORMZ(9:9),'(I1)')NPERC ELSEIF(NPERC.LE.99)THEN WRITE(IFORMT(16:17),'(I2)')NPERC WRITE(IFORMZ(8:9),'(I2)')NPERC ELSEIF(NPERC.LE.999)THEN WRITE(IFORMT(15:17),'(I3)')NPERC WRITE(IFORMZ(8:9),'(I3)')NPERC ELSE NPERC=0 ENDIF ENDIF IF(NPERC.GT.0)THEN WRITE(IOUNI4,IFORMZ)(QP(JJ),JJ=1,NPERC) ENDIF ENDIF C C C FOR BCA CONFIDENCE INTERVAL, COMPUTE FULL-SAMPLE STATISTIC. C IF((IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT') .OR. 1 (IBOOPA.EQ.'PARA' .AND. ICENSO.NE.'ON'))THEN CALL DPJBCP( 1 TEMP0,TEMPZ0,NS2, 1 ICASPL,ICENSO,IMETHD,IPPCDP,MAXNXT,MINMAX, 1 XTEMP1,XTEMP2,XTEMP3,TEMP8, 1 NHOR1,IGEPDF,IADEDF,ILGADF,ISKNDF, 1 QP,XQP,NPERC, 1 PPA0HT,PPA1HT,SHAPHT,ACORR, 1 IBUGG3,ISUBRO,IERROR) ICASRA='NULL' PPA0SV=PPA0HT PPA1SV=PPA1HT SHAPSV=SHAPHT IF(ICASPL.EQ.'WECP')ICASRA='WEIB' IF(ICASPL.EQ.'LACP')ICASRA='LAMB' IF(ICASPL.EQ.'LNCP')ICASRA='LOGN' IF(ICASPL.EQ.'TCP')ICASRA='T' IF(ICASPL.EQ.'CSCP')ICASRA='CHIS' IF(ICASPL.EQ.'CHCP')ICASRA='CHI' IF(ICASPL.EQ.'GACP')ICASRA='GAMM' IF(ICASPL.EQ.'GACP')ICASRA='GAMM' IF(ICASPL.EQ.'E2CP')ICASRA='EXV2' IF(ICASPL.EQ.'PACP')ICASRA='PARE' IF(ICASPL.EQ.'P2CP')ICASRA='PAR2' IF(ICASPL.EQ.'TRCP')ICASRA='TRIA' IF(ICASPL.EQ.'WACP')ICASRA='WALD' IF(ICASPL.EQ.'FLCP')ICASRA='FL' IF(ICASPL.EQ.'GECP')ICASRA='GEP' IF(ICASPL.EQ.'PFCP')ICASRA='POWF' IF(ICASPL.EQ.'IWCP')ICASRA='IWEI' IF(ICASPL.EQ.'DWCP')ICASRA='DWEI' IF(ICASPL.EQ.'DGCP')ICASRA='DGAM' IF(ICASPL.EQ.'LGCP')ICASRA='LGAM' IF(ICASPL.EQ.'GICP')ICASRA='IGAM' IF(ICASPL.EQ.'LDCP')ICASRA='LDEX' IF(ICASPL.EQ.'GVCP')ICASRA='GEVA' IF(ICASPL.EQ.'GZCP')ICASRA='GHLO' IF(ICASPL.EQ.'BRCP')ICASRA='BRAD' IF(ICASPL.EQ.'RECP')ICASRA='RECI' IF(ICASPL.EQ.'PNCP')ICASRA='PNOR' IF(ICASPL.EQ.'LLCP')ICASRA='LLOG' IF(ICASPL.EQ.'EECP')ICASRA='GEEE' IF(ICASPL.EQ.'ERCP')ICASRA='ERRO' IF(ICASPL.EQ.'VMCP')ICASRA='VONM' IF(ICASPL.EQ.'WCCP')ICASRA='WRCA' IF(ICASPL.EQ.'SNCP')ICASRA='SKWN' IF(ICASPL.EQ.'GLCP')ICASRA='GLOG' IF(ICASPL.EQ.'SDCP')ICASRA='SKDE' IF(ICASPL.EQ.'ADCP')ICASRA='ASDE' IF(ICASPL.EQ.'MCCP')ICASRA='MCLE' NBELW1=0 NBELW2=0 NBELW3=0 ENDIF C C HANDLE BOOTSTRAP SAMPLE DIFFERENTLY FOR CENSORED AND UNCENSORED C DATA (CENSORED CASE HAS A PAIRED VARIABLE TO RESAMPLE) C IF(ICENSO.EQ.'OFF')THEN DO14321IRESAM=1,NRESAM IF(IBOOPA.EQ.'PARA')THEN CALL DPJBRA(ICASRA,ISEED,MINMAX, 1 TEMP,NS2, 1 SHAPSV,SHAPE2,PPA0SV,PPA1SV, 1 IMAKDF,IGEODF,IBEIDF,IBEKDF,IGEPDF,IADEDF, 1 ILGADF,ISKNDF,IGLDDF, 1 IBUGG3,ISUBRO,IERROR) ELSE CALL DPJBS3(TEMP0,NS2,ICASJB,IRESAM,ISEED,TEMP, 1 NS3,ITEMP1, 1 TEMP4,IBUGG3,IERROR) ENDIF CALL DPJBCP( 1 TEMP,TEMP4,NS2, 1 ICASPL,ICENSO,IMETHD,IPPCDP,MAXNXT,MINMAX, 1 XTEMP1,XTEMP2,XTEMP3,TEMP8, 1 NHOR1,IGEPDF,IADEDF,ILGADF,ISKNDF, 1 QP,XQP,NPERC, 1 PPA0,PPA1,SHAPE1,ACORR, 1 IBUGG3,ISUBRO,IERROR) C C IF((NGRPV.GE.1 .AND. NPERC.GT.0 .AND. ISET.LE.NUMSET) .OR. 1 (NPERC.GT.0 .AND. NGRPV.EQ.0 .AND. ISET.EQ.1))THEN IF(NGRPV.EQ.0)THEN WRITE(IOUNI4,IFORMT)(XQP(JJ),JJ=1,NPERC) ELSEIF(NGRPV.EQ.1)THEN WRITE(IOUNI4,IFORMT)ISET,(XQP(JJ),JJ=1,NPERC) ELSEIF(NGRPV.EQ.2)THEN WRITE(IOUNI4,IFORMT)ISET1,ISET2,(XQP(JJ),JJ=1,NPERC) ENDIF ENDIF C IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')THEN IF(PPA0.LT.PPA0HT)NBELW1=NBELW1+1 IF(PPA1.LT.PPA1HT)NBELW2=NBELW2+1 IF(SHAPE1.LT.SHA1HT)NBELW3=NBELW3+1 TEMP6(IRESAM)=PPA0 TEMP7(IRESAM)=PPA1 ENDIF IF(NGRPV.LE.1)THEN TAGID=1.0 CALL DPJBS4(ISET,NUMSET,J,J2,PPA0,TAGID,XIDTEM, 1 Y2,X2,D2) TAGID=2.0 CALL DPJBS4(ISET,NUMSET,J,J2,PPA1,TAGID,XIDTEM, 1 Y2,X2,D2) TAGID=3.0 CALL DPJBS4(ISET,NUMSET,J,J2,SHAPE1,TAGID,XIDTEM, 1 Y2,X2,D2) TAGID=4.0 CALL DPJBS4(ISET,NUMSET,J,J2,ACORR,TAGID,XIDTEM, 1 Y2,X2,D2) ELSE CALL DPJBS5(ISET1,ISET2,NUMSE1,NUMSE2,J,PPA0,XIDTEM, 1 XIDTE2,Y2,X2,D2) ENDIF 14321 CONTINUE ELSE DO14331IRESAM=1,NRESAM CALL DPJBS3(TEMP0,NS2,ICASJB,IRESAM,ISEED,TEMP,NS3,ITEMP1, 1 TEMP4,IBUGG3,IERROR) DO14333IJ=1,NS3 TEMPZ(IJ)=TEMPZ0(ITEMP1(IJ)) 14333 CONTINUE CALL DPJBCP( 1 TEMP,TEMPZ,NS2, 1 ICASPL,ICENSO,IMETHD,IPPCDP,MAXNXT,MINMAX, 1 XTEMP1,XTEMP2,XTEMP3,TEMP8, 1 NHOR1,IGEPDF,IADEDF,ILGADF,ISKNDF, 1 QP,XQP,NPERC, 1 PPA0,PPA1,SHAPE1,ACORR, 1 IBUGG3,ISUBRO,IERROR) C IF((NGRPV.GE.1 .AND. NPERC.GT.0 .AND. ISET.LE.NUMSET) .OR. 1 (NPERC.GT.0 .AND. NGRPV.EQ.0 .AND. ISET.EQ.1))THEN IF(NGRPV.EQ.0)THEN WRITE(IOUNI4,IFORMT)(XQP(JJ),JJ=1,NPERC) ELSEIF(NGRPV.EQ.1)THEN WRITE(IOUNI4,IFORMT)ISET,(XQP(JJ),JJ=1,NPERC) ELSEIF(NGRPV.EQ.2)THEN WRITE(IOUNI4,IFORMT)ISET1,ISET2,(XQP(JJ),JJ=1,NPERC) ENDIF ENDIF C IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')THEN IF(PPA0.LT.PPA0HT)NBELW1=NBELW1+1 IF(PPA1.LT.PPA1HT)NBELW2=NBELW2+1 IF(SHAPE1.LT.SHA1HT)NBELW3=NBELW3+1 TEMP6(IRESAM)=PPA0 TEMP7(IRESAM)=PPA1 ENDIF IF(NGRPV.LE.1)THEN TAGID=1.0 CALL DPJBS4(ISET,NUMSET,J,J2,PPA0,TAGID,XIDTEM, 1 Y2,X2,D2) TAGID=2.0 CALL DPJBS4(ISET,NUMSET,J,J2,PPA1,TAGID,XIDTEM, 1 Y2,X2,D2) TAGID=3.0 CALL DPJBS4(ISET,NUMSET,J,J2,SHAPE1,TAGID,XIDTEM, 1 Y2,X2,D2) TAGID=4.0 CALL DPJBS4(ISET,NUMSET,J,J2,ACORR,TAGID,XIDTEM, 1 Y2,X2,D2) ELSE CALL DPJBS5(ISET1,ISET2,NUMSE1,NUMSE2,J,PPA0,XIDTEM, 1 XIDTE2,Y2,X2,D2) ENDIF 14331 CONTINUE ENDIF C C FOR BCA CONFIDENCE INTERVAL, COMPUTE: C 1) Z0HAT C 2) JACKNIFE ESTIMATES C IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')THEN CALL NORPPF(REAL(NBELOW)/REAL(NRESAM),Z0HAT) ICASZZ='JACK' DO14345IRESAM=1,NS2 CALL DPJBS3(TEMP0,NS2,ICASZZ,IRESAM,ISEED,TEMP,NS3,ITEMP1, 1 TEMP4,IBUGG3,IERROR) CALL CMPSTA( 1 TEMP,TEMPZ,XTEMP1,XTEMP2,XTEMP3, 1 MAXNXT,NS3,NS3,NUMV2,ICASPL, 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1 IQUAME,IQUASE, 1 RIGHT, 1 ISUBRO,IBUGG3,IERROR) TEMPTH(IRESAM)=RIGHT 14345 CONTINUE CALL MEAN(TEMPTH,NS2,IWRITE,THETDT,IBUGG3,IERROR) DSUM1=0.0D0 DSUM2=0.0D0 DTHETM=DBLE(THETDT) DO14348I=1,NS2 DTERM1=DBLE(TEMPTH(I)) DSUM1 = DSUM1 + (DTHETM - DTERM1)**3 DSUM2 = DSUM2 + (DTHETM - DTERM1)**2 14348 CONTINUE DTERM2 = DSUM1/(6.0D0*(DSUM2**1.5)) A0HAT=REAL(DTERM2) CALL NORPPF(ALPHA/2.0,ALOWSL) CALL NORPPF(1.0 - ALPHA/2.0,AUPPSL) TERM1=Z0HAT + (Z0HAT + AUPPSL)/(1.0 - A0HAT*(Z0HAT+AUPPSL)) CALL NORCDF(TERM1,ALPHA2) TERM1=Z0HAT + (Z0HAT + ALOWSL)/(1.0 - A0HAT*(Z0HAT+ALOWSL)) CALL NORCDF(TERM1,ALPHA1) CALL PERCEN(100.0*ALPHA1,TEMP6,NS2,IWRITE,TEMP4,MAXNXT, 1 BCAUL,IBUGG3,IERROR) CALL PERCEN(100.0*ALPHA2,TEMP6,NS2,IWRITE,TEMP4,MAXNXT, 1 BCALL,IBUGG3,IERROR) IF(NGRPV.EQ.1)THEN WRITE(IOUNI3,11368)BCALL,BCAUL,Z0HAT,A0HAT,ALPHA1,ALPHA2, 1 XIDTEM(ISET) ELSEIF(NGRPV.EQ.2)THEN WRITE(IOUNI3,11368)BCALL,BCAUL,Z0HAT,A0HAT,ALPHA1,ALPHA2, 1 XIDTEM(ISET1),XIDTE2(ISET2) ELSE WRITE(IOUNI3,11368)BCALL,BCAUL,Z0HAT,A0HAT,ALPHA1,ALPHA2 ENDIF ENDIF C ILAST=ISETMX IF(NGRPV.GE.1)ILAST=ISETMX-1 IF(NPERC.GT.0 .AND. ISET.EQ.ILAST)THEN IENDF4='OFF' IREWI4='ON' CALL DPCLFI(IOUNI4,IFILE4,ISTAT4,IFORM4,IACCE4,IPROT4,ICURS4, 1 IENDF4,IREWI4,ISUBN0,IERRF4,IBUGG3,ISUBRO,IERROR) IF(IERRF4.EQ.'YES')GOTO9000 ENDIF C GOTO79000 C C JACKNIFE/BOOTSTRAP FOR DISTRIBUTIONS THAT ESTIMATE TWO SHAPE C PARAMETER VIA PPCC PLOT AND LOCATION AND SCALE PARAMETERS VIA C A PROBABILITY PLOT. C 14360 CONTINUE C NUMPAR=5 NHOR1=IPPCAP(1) NHOR2=IPPCAP(2) C IF(NPERC.GT.0 .AND.ISET.EQ.1)THEN IOUNI4=IST4NU IFILE4=IST4NA ISTAT4=IST4ST IFORM4=IST4FO IACCE4=IST4AC IPROT4=IST4PR ICURS4=IST4CS ISUBN0='JBS2' IERRF4='NO' C IREWI4='ON' CALL DPOPFI(IOUNI4,IFILE4,ISTAT4,IFORM4,IACCE4, 1 IPROT4,ICURS4, 1 IREWI4,ISUBN0,IERRF4,IBUGG3,ISUBRO,IERROR) IF(IERRF4.EQ.'YES')GOTO9000 IF(NGRPV.EQ.0)THEN IFORMT='( E15.7)' IFORMZ='( F15.3)' IF(NPERC.LE.9)THEN WRITE(IFORMT(5:5),'(I1)')NPERC WRITE(IFORMZ(5:5),'(I1)')NPERC ELSEIF(NPERC.LE.99)THEN WRITE(IFORMT(4:5),'(I2)')NPERC WRITE(IFORMZ(4:5),'(I2)')NPERC ELSEIF(NPERC.LE.999)THEN WRITE(IFORMT(3:5),'(I3)')NPERC WRITE(IFORMZ(3:5),'(I3)')NPERC ELSE NPERC=0 ENDIF ELSEIF(NGRPV.EQ.1)THEN IFORMT='(I8,1X, E15.7)' IFORMZ='(9X, F15.3)' IF(NPERC.LE.9)THEN WRITE(IFORMT(11:11),'(I1)')NPERC WRITE(IFORMZ(8:8),'(I1)')NPERC ELSEIF(NPERC.LE.99)THEN WRITE(IFORMT(10:11),'(I2)')NPERC WRITE(IFORMZ(7:8),'(I2)')NPERC ELSEIF(NPERC.LE.999)THEN WRITE(IFORMT(9:11),'(I3)')NPERC WRITE(IFORMZ(7:8),'(I3)')NPERC ELSE NPERC=0 ENDIF ELSEIF(NGRPV.EQ.2)THEN IFORMT='(I8,1X,I8,1X, E15.7)' IFORMZ='(18X, F15.3)' IF(NPERC.LE.9)THEN WRITE(IFORMT(17:17),'(I1)')NPERC WRITE(IFORMZ(9:9),'(I1)')NPERC ELSEIF(NPERC.LE.99)THEN WRITE(IFORMT(16:17),'(I2)')NPERC WRITE(IFORMZ(8:9),'(I2)')NPERC ELSEIF(NPERC.LE.999)THEN WRITE(IFORMT(15:17),'(I3)')NPERC WRITE(IFORMZ(8:9),'(I3)')NPERC ELSE NPERC=0 ENDIF ENDIF IF(NPERC.GT.0)THEN WRITE(IOUNI4,IFORMZ)(QP(JJ),JJ=1,NPERC) ENDIF ENDIF C C C FOR BCA CONFIDENCE INTERVAL, COMPUTE FULL-SAMPLE STATISTIC. C IF((IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT') .OR. 1 (IBOOPA.EQ.'PARA' .AND. ICENSO.NE.'ON'))THEN CALL DPJBC2( 1 TEMP0,TEMPZ0,NS2, 1 ICASPL,ICENSO,IMETHD,IPPCDP,MAXNXT,MINMAX, 1 XTEMP1,XTEMP2,XTEMP3,TEMP8, 1 NHOR1,NHOR2, 1 QP,XQP,NPERC, 1 PPA0HT,PPA1HT,SHA1HT,SHA2HT,ACORR, 1 IBUGG3,ISUBRO,IERROR) ICASRA='NULL' PPA0SV=PPA0HT PPA1SV=PPA1HT SHA1SV=SHA1HT SHA2SV=SHA2HT IF(ICASPL.EQ.'GHCP')ICASRA='GH ' IF(ICASPL.EQ.'FCP')ICASRA='F ' IF(ICASPL.EQ.'FNCP')ICASRA='FNRM' IF(ICASPL.EQ.'IGCP')ICASRA='IG ' IF(ICASPL.EQ.'BECP')ICASRA='BETA' IF(ICASPL.EQ.'GGCP')ICASRA='GGD ' NBELW1=0 NBELW2=0 NBELW3=0 NBELW4=0 ENDIF C C HANDLE BOOTSTRAP SAMPLE DIFFERENTLY FOR CENSORED AND UNCENSORED C DATA (CENSORED CASE HAS A PAIRED VARIABLE TO RESAMPLE) C IF(ICENSO.EQ.'OFF')THEN DO14371IRESAM=1,NRESAM IF(IBOOPA.EQ.'PARA')THEN CALL DPJBRA(ICASRA,ISEED,MINMAX, 1 TEMP,NS2, 1 SHA1SV,SHA2SV,PPA0SV,PPA1SV, 1 IMAKDF,IGEODF,IBEIDF,IBEKDF,IGEPDF,IADEDF, 1 ILGADF,ISKNDF,IGLDDF, 1 IBUGG3,ISUBRO,IERROR) ELSE CALL DPJBS3(TEMP0,NS2,ICASJB,IRESAM,ISEED,TEMP, 1 NS3,ITEMP1, 1 TEMP4,IBUGG3,IERROR) ENDIF CALL DPJBC2( 1 TEMP,TEMP4,NS2, 1 ICASPL,ICENSO,IMETHD,IPPCDP,MAXNXT,MINMAX, 1 XTEMP1,XTEMP2,XTEMP3,TEMP8, 1 NHOR1,NHOR2, 1 QP,XQP,NPERC, 1 PPA0,PPA1,SHAPE1,SHAPE2,ACORR, 1 IBUGG3,ISUBRO,IERROR) C C IF((NGRPV.GE.1 .AND. NPERC.GT.0 .AND. ISET.LE.NUMSET) .OR. 1 (NPERC.GT.0 .AND. NGRPV.EQ.0 .AND. ISET.EQ.1))THEN IF(NGRPV.EQ.0)THEN WRITE(IOUNI4,IFORMT)(XQP(JJ),JJ=1,NPERC) ELSEIF(NGRPV.EQ.1)THEN WRITE(IOUNI4,IFORMT)ISET,(XQP(JJ),JJ=1,NPERC) ELSEIF(NGRPV.EQ.2)THEN WRITE(IOUNI4,IFORMT)ISET1,ISET2,(XQP(JJ),JJ=1,NPERC) ENDIF ENDIF C IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')THEN IF(PPA0.LT.PPA0HT)NBELW1=NBELW1+1 IF(PPA1.LT.PPA1HT)NBELW2=NBELW2+1 IF(SHAPE1.LT.SHA1HT)NBELW3=NBELW3+1 IF(SHAPE2.LT.SHA2HT)NBELW4=NBELW4+1 TEMP6(IRESAM)=PPA0 TEMP7(IRESAM)=PPA1 ENDIF IF(NGRPV.LE.1)THEN TAGID=1.0 CALL DPJBS4(ISET,NUMSET,J,J2,PPA0,TAGID,XIDTEM, 1 Y2,X2,D2) TAGID=2.0 CALL DPJBS4(ISET,NUMSET,J,J2,PPA1,TAGID,XIDTEM, 1 Y2,X2,D2) TAGID=3.0 CALL DPJBS4(ISET,NUMSET,J,J2,SHAPE1,TAGID,XIDTEM, 1 Y2,X2,D2) TAGID=4.0 CALL DPJBS4(ISET,NUMSET,J,J2,SHAPE2,TAGID,XIDTEM, 1 Y2,X2,D2) TAGID=5.0 CALL DPJBS4(ISET,NUMSET,J,J2,ACORR,TAGID,XIDTEM, 1 Y2,X2,D2) ELSE CALL DPJBS5(ISET1,ISET2,NUMSE1,NUMSE2,J,PPA0,XIDTEM, 1 XIDTE2,Y2,X2,D2) ENDIF 14371 CONTINUE ELSE DO14381IRESAM=1,NRESAM CALL DPJBS3(TEMP0,NS2,ICASJB,IRESAM,ISEED,TEMP,NS3,ITEMP1, 1 TEMP4,IBUGG3,IERROR) DO14383IJ=1,NS3 TEMPZ(IJ)=TEMPZ0(ITEMP1(IJ)) 14383 CONTINUE CALL DPJBC2( 1 TEMP,TEMPZ,NS2, 1 ICASPL,ICENSO,IMETHD,IPPCDP,MAXNXT,MINMAX, 1 XTEMP1,XTEMP2,XTEMP3,TEMP8, 1 NHOR1,NHOR2, 1 QP,XQP,NPERC, 1 PPA0,PPA1,SHAPE1,SHAPE2,ACORR, 1 IBUGG3,ISUBRO,IERROR) C IF((NGRPV.GE.1 .AND. NPERC.GT.0 .AND. ISET.LE.NUMSET) .OR. 1 (NPERC.GT.0 .AND. NGRPV.EQ.0 .AND. ISET.EQ.1))THEN IF(NGRPV.EQ.0)THEN WRITE(IOUNI4,IFORMT)(XQP(JJ),JJ=1,NPERC) ELSEIF(NGRPV.EQ.1)THEN WRITE(IOUNI4,IFORMT)ISET,(XQP(JJ),JJ=1,NPERC) ELSEIF(NGRPV.EQ.2)THEN WRITE(IOUNI4,IFORMT)ISET1,ISET2,(XQP(JJ),JJ=1,NPERC) ENDIF ENDIF C IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')THEN IF(PPA0.LT.PPA0HT)NBELW1=NBELW1+1 IF(PPA1.LT.PPA1HT)NBELW2=NBELW2+1 IF(SHAPE1.LT.SHA1HT)NBELW3=NBELW3+1 TEMP6(IRESAM)=PPA0 TEMP7(IRESAM)=PPA1 ENDIF IF(NGRPV.LE.1)THEN TAGID=1.0 CALL DPJBS4(ISET,NUMSET,J,J2,PPA0,TAGID,XIDTEM, 1 Y2,X2,D2) TAGID=2.0 CALL DPJBS4(ISET,NUMSET,J,J2,PPA1,TAGID,XIDTEM, 1 Y2,X2,D2) TAGID=3.0 CALL DPJBS4(ISET,NUMSET,J,J2,SHAPE1,TAGID,XIDTEM, 1 Y2,X2,D2) TAGID=4.0 CALL DPJBS4(ISET,NUMSET,J,J2,SHAPE2,TAGID,XIDTEM, 1 Y2,X2,D2) TAGID=5.0 CALL DPJBS4(ISET,NUMSET,J,J2,ACORR,TAGID,XIDTEM, 1 Y2,X2,D2) ELSE CALL DPJBS5(ISET1,ISET2,NUMSE1,NUMSE2,J,PPA0,XIDTEM, 1 XIDTE2,Y2,X2,D2) ENDIF 14381 CONTINUE ENDIF C C FOR BCA CONFIDENCE INTERVAL, COMPUTE: C 1) Z0HAT C 2) JACKNIFE ESTIMATES C IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')THEN CALL NORPPF(REAL(NBELOW)/REAL(NRESAM),Z0HAT) ICASZZ='JACK' DO14395IRESAM=1,NS2 CALL DPJBS3(TEMP0,NS2,ICASZZ,IRESAM,ISEED,TEMP,NS3,ITEMP1, 1 TEMP4,IBUGG3,IERROR) CALL CMPSTA( 1 TEMP,TEMPZ,XTEMP1,XTEMP2,XTEMP3, 1 MAXNXT,NS3,NS3,NUMV2,ICASPL, 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1 IQUAME,IQUASE, 1 RIGHT, 1 ISUBRO,IBUGG3,IERROR) TEMPTH(IRESAM)=RIGHT 14395 CONTINUE CALL MEAN(TEMPTH,NS2,IWRITE,THETDT,IBUGG3,IERROR) DSUM1=0.0D0 DSUM2=0.0D0 DTHETM=DBLE(THETDT) DO14398I=1,NS2 DTERM1=DBLE(TEMPTH(I)) DSUM1 = DSUM1 + (DTHETM - DTERM1)**3 DSUM2 = DSUM2 + (DTHETM - DTERM1)**2 14398 CONTINUE DTERM2 = DSUM1/(6.0D0*(DSUM2**1.5)) A0HAT=REAL(DTERM2) CALL NORPPF(ALPHA/2.0,ALOWSL) CALL NORPPF(1.0 - ALPHA/2.0,AUPPSL) TERM1=Z0HAT + (Z0HAT + AUPPSL)/(1.0 - A0HAT*(Z0HAT+AUPPSL)) CALL NORCDF(TERM1,ALPHA2) TERM1=Z0HAT + (Z0HAT + ALOWSL)/(1.0 - A0HAT*(Z0HAT+ALOWSL)) CALL NORCDF(TERM1,ALPHA1) CALL PERCEN(100.0*ALPHA1,TEMP6,NS2,IWRITE,TEMP4,MAXNXT, 1 BCAUL,IBUGG3,IERROR) CALL PERCEN(100.0*ALPHA2,TEMP6,NS2,IWRITE,TEMP4,MAXNXT, 1 BCALL,IBUGG3,IERROR) IF(NGRPV.EQ.1)THEN WRITE(IOUNI3,11368)BCALL,BCAUL,Z0HAT,A0HAT,ALPHA1,ALPHA2, 1 XIDTEM(ISET) ELSEIF(NGRPV.EQ.2)THEN WRITE(IOUNI3,11368)BCALL,BCAUL,Z0HAT,A0HAT,ALPHA1,ALPHA2, 1 XIDTEM(ISET1),XIDTE2(ISET2) ELSE WRITE(IOUNI3,11368)BCALL,BCAUL,Z0HAT,A0HAT,ALPHA1,ALPHA2 ENDIF ENDIF C ILAST=ISETMX IF(NGRPV.GE.1)ILAST=ISETMX-1 IF(NPERC.GT.0 .AND. ISET.EQ.ILAST)THEN IENDF4='OFF' IREWI4='ON' CALL DPCLFI(IOUNI4,IFILE4,ISTAT4,IFORM4,IACCE4,IPROT4,ICURS4, 1 IENDF4,IREWI4,ISUBN0,IERRF4,IBUGG3,ISUBRO,IERROR) IF(IERRF4.EQ.'YES')GOTO9000 ENDIF C GOTO79000 C C JACKNIFE/BOOTSTRAP FOR DISTRIBUTIONS THAT ESTIMATE ONE SHAPE C PARAMETER VIA KS PLOT AND LOCATION AND SCALE PARAMETERS VIA C A PROBABILITY PLOT. C 14410 CONTINUE C NUMPAR=4 NHOR1=IPPCAP(1) NHOR2=IPPCAP(2) C IHP='KSLO' IHP2='C ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IHP,IHP2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')THEN KSLOC=CPUMIN ELSE KSLOC=VALUE(ILOCP) ENDIF C IHP='KSSC' IHP2='ALE ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IHP,IHP2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')THEN KSSCAL=CPUMIN ELSE KSSCAL=VALUE(ILOCP) ENDIF C IF(NPERC.GT.0 .AND.ISET.EQ.1)THEN IOUNI4=IST4NU IFILE4=IST4NA ISTAT4=IST4ST IFORM4=IST4FO IACCE4=IST4AC IPROT4=IST4PR ICURS4=IST4CS ISUBN0='JBS2' IERRF4='NO' C IREWI4='ON' CALL DPOPFI(IOUNI4,IFILE4,ISTAT4,IFORM4,IACCE4, 1 IPROT4,ICURS4, 1 IREWI4,ISUBN0,IERRF4,IBUGG3,ISUBRO,IERROR) IF(IERRF4.EQ.'YES')GOTO9000 IF(NGRPV.EQ.0)THEN IFORMT='( E15.7)' IFORMZ='( F15.3)' IF(NPERC.LE.9)THEN WRITE(IFORMT(5:5),'(I1)')NPERC WRITE(IFORMZ(5:5),'(I1)')NPERC ELSEIF(NPERC.LE.99)THEN WRITE(IFORMT(4:5),'(I2)')NPERC WRITE(IFORMZ(4:5),'(I2)')NPERC ELSEIF(NPERC.LE.999)THEN WRITE(IFORMT(3:5),'(I3)')NPERC WRITE(IFORMZ(3:5),'(I3)')NPERC ELSE NPERC=0 ENDIF ELSEIF(NGRPV.EQ.1)THEN IFORMT='(I8,1X, E15.7)' IFORMZ='(9X, F15.3)' IF(NPERC.LE.9)THEN WRITE(IFORMT(11:11),'(I1)')NPERC WRITE(IFORMZ(8:8),'(I1)')NPERC ELSEIF(NPERC.LE.99)THEN WRITE(IFORMT(10:11),'(I2)')NPERC WRITE(IFORMZ(7:8),'(I2)')NPERC ELSEIF(NPERC.LE.999)THEN WRITE(IFORMT(9:11),'(I3)')NPERC WRITE(IFORMZ(7:8),'(I3)')NPERC ELSE NPERC=0 ENDIF ELSEIF(NGRPV.EQ.2)THEN IFORMT='(I8,1X,I8,1X, E15.7)' IFORMZ='(18X, F15.3)' IF(NPERC.LE.9)THEN WRITE(IFORMT(17:17),'(I1)')NPERC WRITE(IFORMZ(9:9),'(I1)')NPERC ELSEIF(NPERC.LE.99)THEN WRITE(IFORMT(16:17),'(I2)')NPERC WRITE(IFORMZ(8:9),'(I2)')NPERC ELSEIF(NPERC.LE.999)THEN WRITE(IFORMT(15:17),'(I3)')NPERC WRITE(IFORMZ(8:9),'(I3)')NPERC ELSE NPERC=0 ENDIF ENDIF IF(NPERC.GT.0)THEN WRITE(IOUNI4,IFORMZ)(QP(JJ),JJ=1,NPERC) ENDIF ENDIF C C C FOR BCA CONFIDENCE INTERVAL, COMPUTE FULL-SAMPLE STATISTIC. C IF((IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT') .OR. 1 (IBOOPA.EQ.'PARA' .AND. ICENSO.NE.'ON'))THEN CALL DPJBKS( 1 TEMP0,TEMPZ0,NS2, 1 ICASPL,IMETHD,IPPCDP,MAXNXT,MINMAX,PMAXLO, 1 XTEMP1,XTEMP2,XTEMP3,TEMP8, 1 NHOR1,IGEPDF,IADEDF,ILGADF,ISKNDF,KSLOC,KSSCAL, 1 QP,XQP,NPERC, 1 PPA0,PPA1,SHAPE1,AMINKS, 1 IBUGG3,ISUBRO,IERROR) ICASRA='NULL' PPA0SV=PPA0HT PPA1SV=PPA1HT SHAPSV=SHAPHT IF(ICASPL.EQ.'WEKS')ICASRA='WEIB' IF(ICASPL.EQ.'LAKS')ICASRA='LAMB' IF(ICASPL.EQ.'LNKS')ICASRA='LOGN' IF(ICASPL.EQ.'TKS')ICASRA='T' IF(ICASPL.EQ.'CSKS')ICASRA='CHIS' IF(ICASPL.EQ.'CHKS')ICASRA='CHI' IF(ICASPL.EQ.'GAKS')ICASRA='GAMM' IF(ICASPL.EQ.'GAKS')ICASRA='GAMM' IF(ICASPL.EQ.'E2KS')ICASRA='EXV2' IF(ICASPL.EQ.'PAKS')ICASRA='PARE' IF(ICASPL.EQ.'P2KS')ICASRA='PAR2' IF(ICASPL.EQ.'TRKS')ICASRA='TRIA' IF(ICASPL.EQ.'WAKS')ICASRA='WALD' IF(ICASPL.EQ.'FLKS')ICASRA='FL' IF(ICASPL.EQ.'GEKS')ICASRA='GEP' IF(ICASPL.EQ.'PFKS')ICASRA='POWF' IF(ICASPL.EQ.'IWKS')ICASRA='IWEI' IF(ICASPL.EQ.'DWKS')ICASRA='DWEI' IF(ICASPL.EQ.'DGKS')ICASRA='DGAM' IF(ICASPL.EQ.'LGKS')ICASRA='LGAM' IF(ICASPL.EQ.'GIKS')ICASRA='IGAM' IF(ICASPL.EQ.'LDKS')ICASRA='LDEX' IF(ICASPL.EQ.'GVKS')ICASRA='GEVA' IF(ICASPL.EQ.'GZKS')ICASRA='GHLO' IF(ICASPL.EQ.'BRKS')ICASRA='BRAD' IF(ICASPL.EQ.'REKS')ICASRA='RECI' IF(ICASPL.EQ.'PNKS')ICASRA='PNOR' IF(ICASPL.EQ.'LLKS')ICASRA='LLOG' IF(ICASPL.EQ.'EEKS')ICASRA='GEEE' IF(ICASPL.EQ.'ERKS')ICASRA='ERRO' IF(ICASPL.EQ.'VMKS')ICASRA='VONM' IF(ICASPL.EQ.'WCKS')ICASRA='WRCA' IF(ICASPL.EQ.'SNKS')ICASRA='SKWN' IF(ICASPL.EQ.'GLKS')ICASRA='GLOG' IF(ICASPL.EQ.'SDKS')ICASRA='SKDE' IF(ICASPL.EQ.'ADKS')ICASRA='ASDE' IF(ICASPL.EQ.'MCKS')ICASRA='MCLE' NBELW1=0 NBELW2=0 NBELW3=0 ENDIF C C HANDLE BOOTSTRAP SAMPLE DIFFERENTLY FOR CENSORED AND UNCENSORED C DATA (CENSORED CASE HAS A PAIRED VARIABLE TO RESAMPLE) C IF(ICENSO.EQ.'OFF')THEN DO14421IRESAM=1,NRESAM IF(IBOOPA.EQ.'PARA')THEN CALL DPJBRA(ICASRA,ISEED,MINMAX, 1 TEMP,NS2, 1 SHAPSV,SHAPE2,PPA0SV,PPA1SV, 1 IMAKDF,IGEODF,IBEIDF,IBEKDF,IGEPDF,IADEDF, 1 ILGADF,ISKNDF,IGLDDF, 1 IBUGG3,ISUBRO,IERROR) ELSE CALL DPJBS3(TEMP0,NS2,ICASJB,IRESAM,ISEED, 1 TEMP,NS3,ITEMP1, 1 TEMP4,IBUGG3,IERROR) ENDIF CALL DPJBKS( 1 TEMP,TEMP4,NS2, 1 ICASPL,IMETHD,IPPCDP,MAXNXT,MINMAX,PMAXLO, 1 XTEMP1,XTEMP2,XTEMP3,TEMP8, 1 NHOR1,IGEPDF,IADEDF,ILGADF,ISKNDF,KSLOC,KSSCAL, 1 QP,XQP,NPERC, 1 PPA0,PPA1,SHAPE1,AMINKS, 1 IBUGG3,ISUBRO,IERROR) C C IF((NGRPV.GE.1 .AND. NPERC.GT.0 .AND. ISET.LE.NUMSET) .OR. 1 (NPERC.GT.0 .AND. NGRPV.EQ.0 .AND. ISET.EQ.1))THEN IF(NGRPV.EQ.0)THEN WRITE(IOUNI4,IFORMT)(XQP(JJ),JJ=1,NPERC) ELSEIF(NGRPV.EQ.1)THEN WRITE(IOUNI4,IFORMT)ISET,(XQP(JJ),JJ=1,NPERC) ELSEIF(NGRPV.EQ.2)THEN WRITE(IOUNI4,IFORMT)ISET1,ISET2,(XQP(JJ),JJ=1,NPERC) ENDIF ENDIF C IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')THEN IF(PPA0.LT.PPA0HT)NBELW1=NBELW1+1 IF(PPA1.LT.PPA1HT)NBELW2=NBELW2+1 IF(SHAPE1.LT.SHA1HT)NBELW3=NBELW3+1 TEMP6(IRESAM)=PPA0 TEMP7(IRESAM)=PPA1 ENDIF IF(NGRPV.LE.1)THEN TAGID=1.0 CALL DPJBS4(ISET,NUMSET,J,J2,PPA0,TAGID,XIDTEM, 1 Y2,X2,D2) TAGID=2.0 CALL DPJBS4(ISET,NUMSET,J,J2,PPA1,TAGID,XIDTEM, 1 Y2,X2,D2) TAGID=3.0 CALL DPJBS4(ISET,NUMSET,J,J2,SHAPE1,TAGID,XIDTEM, 1 Y2,X2,D2) TAGID=4.0 CALL DPJBS4(ISET,NUMSET,J,J2,AMINKS,TAGID,XIDTEM, 1 Y2,X2,D2) ELSE CALL DPJBS5(ISET1,ISET2,NUMSE1,NUMSE2,J,PPA0,XIDTEM, 1 XIDTE2,Y2,X2,D2) ENDIF 14421 CONTINUE ELSE CCCCC DO14431IRESAM=1,NRESAM CCCCC CALL DPJBS3(TEMP0,NS2,ICASJB,IRESAM,ISEED,TEMP,NS3,ITEMP1, CCCCC1 TEMP4,IBUGG3,IERROR) CCCCC DO14433IJ=1,NS3 CCCCC TEMPZ(IJ)=TEMPZ0(ITEMP1(IJ)) 14433 CONTINUE CCCCC CALL DPJBKS( CCCCC1 TEMP,TEMPZ,NS2, CCCCC1 ICASPL,IMETHD,IPPCDP,MAXNXT,MINMAX,PMAXLO, CCCCC1 XTEMP1,XTEMP2,XTEMP3,TEMP8, CCCCC1 NHOR1,IGEPDF,IADEDF,ILGADF,ISKNDF, CCCCC1 QP,XQP,NPERC, CCCCC1 PPA0,PPA1,SHAPE1,ACORR, CCCCC1 IBUGG3,ISUBRO,IERROR) C CCCCC IF((NGRPV.GE.1 .AND. NPERC.GT.0 .AND. ISET.LE.NUMSET) .OR. CCCCC1 (NPERC.GT.0 .AND. NGRPV.EQ.0 .AND. ISET.EQ.1))THEN CCCCC IF(NGRPV.EQ.0)THEN CCCCC WRITE(IOUNI4,IFORMT)(XQP(JJ),JJ=1,NPERC) CCCCC ELSEIF(NGRPV.EQ.1)THEN CCCCC WRITE(IOUNI4,IFORMT)ISET,(XQP(JJ),JJ=1,NPERC) CCCCC ELSEIF(NGRPV.EQ.2)THEN CCCCC WRITE(IOUNI4,IFORMT)ISET1,ISET2,(XQP(JJ),JJ=1,NPERC) CCCCC ENDIF CCCCC ENDIF C CCCCC IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')THEN CCCCC IF(PPA0.LT.PPA0HT)NBELW1=NBELW1+1 CCCCC IF(PPA1.LT.PPA1HT)NBELW2=NBELW2+1 CCCCC IF(SHAPE1.LT.SHA1HT)NBELW3=NBELW3+1 CCCCC TEMP6(IRESAM)=PPA0 CCCCC TEMP7(IRESAM)=PPA1 CCCCC ENDIF CCCCC IF(NGRPV.LE.1)THEN CCCCC TAGID=1.0 CCCCC CALL DPJBS4(ISET,NUMSET,J,J2,PPA0,TAGID,XIDTEM, CCCCC1 Y2,X2,D2) CCCCC TAGID=2.0 CCCCC CALL DPJBS4(ISET,NUMSET,J,J2,PPA1,TAGID,XIDTEM, CCCCC1 Y2,X2,D2) CCCCC TAGID=3.0 CCCCC CALL DPJBS4(ISET,NUMSET,J,J2,SHAPE1,TAGID,XIDTEM, CCCCC1 Y2,X2,D2) CCCCC TAGID=4.0 CCCCC CALL DPJBS4(ISET,NUMSET,J,J2,ACORR,TAGID,XIDTEM, CCCCC1 Y2,X2,D2) CCCCC ELSE CCCCC CALL DPJBS5(ISET1,ISET2,NUMSE1,NUMSE2,J,PPA0,XIDTEM, CCCCC1 XIDTE2,Y2,X2,D2) CCCCC ENDIF 14431 CONTINUE ENDIF C C FOR BCA CONFIDENCE INTERVAL, COMPUTE: C 1) Z0HAT C 2) JACKNIFE ESTIMATES C IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')THEN CALL NORPPF(REAL(NBELOW)/REAL(NRESAM),Z0HAT) ICASZZ='JACK' DO14445IRESAM=1,NS2 CALL DPJBS3(TEMP0,NS2,ICASZZ,IRESAM,ISEED,TEMP,NS3,ITEMP1, 1 TEMP4,IBUGG3,IERROR) CALL CMPSTA( 1 TEMP,TEMPZ,XTEMP1,XTEMP2,XTEMP3, 1 MAXNXT,NS3,NS3,NUMV2,ICASPL, 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1 IQUAME,IQUASE, 1 RIGHT, 1 ISUBRO,IBUGG3,IERROR) TEMPTH(IRESAM)=RIGHT 14445 CONTINUE CALL MEAN(TEMPTH,NS2,IWRITE,THETDT,IBUGG3,IERROR) DSUM1=0.0D0 DSUM2=0.0D0 DTHETM=DBLE(THETDT) DO14448I=1,NS2 DTERM1=DBLE(TEMPTH(I)) DSUM1 = DSUM1 + (DTHETM - DTERM1)**3 DSUM2 = DSUM2 + (DTHETM - DTERM1)**2 14448 CONTINUE DTERM2 = DSUM1/(6.0D0*(DSUM2**1.5)) A0HAT=REAL(DTERM2) CALL NORPPF(ALPHA/2.0,ALOWSL) CALL NORPPF(1.0 - ALPHA/2.0,AUPPSL) TERM1=Z0HAT + (Z0HAT + AUPPSL)/(1.0 - A0HAT*(Z0HAT+AUPPSL)) CALL NORCDF(TERM1,ALPHA2) TERM1=Z0HAT + (Z0HAT + ALOWSL)/(1.0 - A0HAT*(Z0HAT+ALOWSL)) CALL NORCDF(TERM1,ALPHA1) CALL PERCEN(100.0*ALPHA1,TEMP6,NS2,IWRITE,TEMP4,MAXNXT, 1 BCAUL,IBUGG3,IERROR) CALL PERCEN(100.0*ALPHA2,TEMP6,NS2,IWRITE,TEMP4,MAXNXT, 1 BCALL,IBUGG3,IERROR) IF(NGRPV.EQ.1)THEN WRITE(IOUNI3,11368)BCALL,BCAUL,Z0HAT,A0HAT,ALPHA1,ALPHA2, 1 XIDTEM(ISET) ELSEIF(NGRPV.EQ.2)THEN WRITE(IOUNI3,11368)BCALL,BCAUL,Z0HAT,A0HAT,ALPHA1,ALPHA2, 1 XIDTEM(ISET1),XIDTE2(ISET2) ELSE WRITE(IOUNI3,11368)BCALL,BCAUL,Z0HAT,A0HAT,ALPHA1,ALPHA2 ENDIF ENDIF C ILAST=ISETMX IF(NGRPV.GE.1)ILAST=ISETMX-1 IF(NPERC.GT.0 .AND. ISET.EQ.ILAST)THEN IENDF4='OFF' IREWI4='ON' CALL DPCLFI(IOUNI4,IFILE4,ISTAT4,IFORM4,IACCE4,IPROT4,ICURS4, 1 IENDF4,IREWI4,ISUBN0,IERRF4,IBUGG3,ISUBRO,IERROR) IF(IERRF4.EQ.'YES')GOTO9000 ENDIF C GOTO79000 C C JACKNIFE/BOOTSTRAP FOR DISTRIBUTIONS THAT ESTIMATE TWO SHAPE C PARAMETERS VIA KS PLOT AND LOCATION AND SCALE PARAMETERS VIA C A PROBABILITY PLOT. C 14460 CONTINUE C NUMPAR=4 NHOR1=IPPCAP(1) NHOR2=IPPCAP(2) C IHP='KSLO' IHP2='C ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IHP,IHP2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')THEN KSLOC=CPUMIN ELSE KSLOC=VALUE(ILOCP) ENDIF C IHP='KSSC' IHP2='ALE ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IHP,IHP2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')THEN KSSCAL=CPUMIN ELSE KSSCAL=VALUE(ILOCP) ENDIF C IF(NPERC.GT.0 .AND.ISET.EQ.1)THEN IOUNI4=IST4NU IFILE4=IST4NA ISTAT4=IST4ST IFORM4=IST4FO IACCE4=IST4AC IPROT4=IST4PR ICURS4=IST4CS ISUBN0='JBS2' IERRF4='NO' C IREWI4='ON' CALL DPOPFI(IOUNI4,IFILE4,ISTAT4,IFORM4,IACCE4, 1 IPROT4,ICURS4, 1 IREWI4,ISUBN0,IERRF4,IBUGG3,ISUBRO,IERROR) IF(IERRF4.EQ.'YES')GOTO9000 IF(NGRPV.EQ.0)THEN IFORMT='( E15.7)' IFORMZ='( F15.3)' IF(NPERC.LE.9)THEN WRITE(IFORMT(5:5),'(I1)')NPERC WRITE(IFORMZ(5:5),'(I1)')NPERC ELSEIF(NPERC.LE.99)THEN WRITE(IFORMT(4:5),'(I2)')NPERC WRITE(IFORMZ(4:5),'(I2)')NPERC ELSEIF(NPERC.LE.999)THEN WRITE(IFORMT(3:5),'(I3)')NPERC WRITE(IFORMZ(3:5),'(I3)')NPERC ELSE NPERC=0 ENDIF ELSEIF(NGRPV.EQ.1)THEN IFORMT='(I8,1X, E15.7)' IFORMZ='(9X, F15.3)' IF(NPERC.LE.9)THEN WRITE(IFORMT(11:11),'(I1)')NPERC WRITE(IFORMZ(8:8),'(I1)')NPERC ELSEIF(NPERC.LE.99)THEN WRITE(IFORMT(10:11),'(I2)')NPERC WRITE(IFORMZ(7:8),'(I2)')NPERC ELSEIF(NPERC.LE.999)THEN WRITE(IFORMT(9:11),'(I3)')NPERC WRITE(IFORMZ(7:8),'(I3)')NPERC ELSE NPERC=0 ENDIF ELSEIF(NGRPV.EQ.2)THEN IFORMT='(I8,1X,I8,1X, E15.7)' IFORMZ='(18X, F15.3)' IF(NPERC.LE.9)THEN WRITE(IFORMT(17:17),'(I1)')NPERC WRITE(IFORMZ(9:9),'(I1)')NPERC ELSEIF(NPERC.LE.99)THEN WRITE(IFORMT(16:17),'(I2)')NPERC WRITE(IFORMZ(8:9),'(I2)')NPERC ELSEIF(NPERC.LE.999)THEN WRITE(IFORMT(15:17),'(I3)')NPERC WRITE(IFORMZ(8:9),'(I3)')NPERC ELSE NPERC=0 ENDIF ENDIF IF(NPERC.GT.0)THEN WRITE(IOUNI4,IFORMZ)(QP(JJ),JJ=1,NPERC) ENDIF ENDIF C C C FOR BCA CONFIDENCE INTERVAL, COMPUTE FULL-SAMPLE STATISTIC. C IF((IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT') .OR. 1 (IBOOPA.EQ.'PARA' .AND. ICENSO.NE.'ON'))THEN CALL DPJBK2( 1 TEMP0,TEMPZ0,NS2, 1 ICASPL,IMETHD,IPPCDP,MAXNXT,MINMAX, 1 XTEMP1,XTEMP2,XTEMP3,TEMP8, 1 NHOR1,NHOR2,KSLOC,KSSCAL, 1 QP,XQP,NPERC, 1 PPA0,PPA1,SHAPE1,SHAPE2,AMINKS, 1 IBUGG3,ISUBRO,IERROR) ICASRA='NULL' PPA0SV=PPA0HT PPA1SV=PPA1HT SHA1SV=SHA1HT SHA2SV=SHA2HT IF(ICASPL.EQ.'GHKS')ICASRA='GH ' IF(ICASPL.EQ.'FKS')ICASRA='F ' IF(ICASPL.EQ.'FNKS')ICASRA='FNRM' IF(ICASPL.EQ.'IGKS')ICASRA='IG ' IF(ICASPL.EQ.'BEKS')ICASRA='BETA' IF(ICASPL.EQ.'GGKS')ICASRA='GGD ' NBELW1=0 NBELW2=0 NBELW3=0 ENDIF C C HANDLE BOOTSTRAP SAMPLE DIFFERENTLY FOR CENSORED AND UNCENSORED C DATA (CENSORED CASE HAS A PAIRED VARIABLE TO RESAMPLE) C IF(ICENSO.EQ.'OFF')THEN DO14471IRESAM=1,NRESAM IF(IBOOPA.EQ.'PARA')THEN CALL DPJBRA(ICASRA,ISEED,MINMAX, 1 TEMP,NS2, 1 SHA1SV,SHA2SV,PPA0SV,PPA1SV, 1 IMAKDF,IGEODF,IBEIDF,IBEKDF,IGEPDF,IADEDF, 1 ILGADF,ISKNDF,IGLDDF, 1 IBUGG3,ISUBRO,IERROR) ELSE CALL DPJBS3(TEMP0,NS2,ICASJB,IRESAM,ISEED,TEMP, 1 NS3,ITEMP1, 1 TEMP4,IBUGG3,IERROR) ENDIF CALL DPJBK2( 1 TEMP,TEMP4,NS2, 1 ICASPL,IMETHD,IPPCDP,MAXNXT,MINMAX, 1 XTEMP1,XTEMP2,XTEMP3,TEMP8, 1 NHOR1,NHOR2,KSLOC,KSSCAL, 1 QP,XQP,NPERC, 1 PPA0,PPA1,SHAPE1,SHAPE2,AMINKS, 1 IBUGG3,ISUBRO,IERROR) C IF((NGRPV.GE.1 .AND. NPERC.GT.0 .AND. ISET.LE.NUMSET) .OR. 1 (NPERC.GT.0 .AND. NGRPV.EQ.0 .AND. ISET.EQ.1))THEN IF(NGRPV.EQ.0)THEN WRITE(IOUNI4,IFORMT)(XQP(JJ),JJ=1,NPERC) ELSEIF(NGRPV.EQ.1)THEN WRITE(IOUNI4,IFORMT)ISET,(XQP(JJ),JJ=1,NPERC) ELSEIF(NGRPV.EQ.2)THEN WRITE(IOUNI4,IFORMT)ISET1,ISET2,(XQP(JJ),JJ=1,NPERC) ENDIF ENDIF C IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')THEN IF(PPA0.LT.PPA0HT)NBELW1=NBELW1+1 IF(PPA1.LT.PPA1HT)NBELW2=NBELW2+1 IF(SHAPE1.LT.SHA1HT)NBELW3=NBELW3+1 TEMP6(IRESAM)=PPA0 TEMP7(IRESAM)=PPA1 ENDIF IF(NGRPV.LE.1)THEN TAGID=1.0 CALL DPJBS4(ISET,NUMSET,J,J2,PPA0,TAGID,XIDTEM, 1 Y2,X2,D2) TAGID=2.0 CALL DPJBS4(ISET,NUMSET,J,J2,PPA1,TAGID,XIDTEM, 1 Y2,X2,D2) TAGID=3.0 CALL DPJBS4(ISET,NUMSET,J,J2,SHAPE1,TAGID,XIDTEM, 1 Y2,X2,D2) TAGID=4.0 CALL DPJBS4(ISET,NUMSET,J,J2,SHAPE2,TAGID,XIDTEM, 1 Y2,X2,D2) TAGID=5.0 CALL DPJBS4(ISET,NUMSET,J,J2,AMINKS,TAGID,XIDTEM, 1 Y2,X2,D2) ELSE CALL DPJBS5(ISET1,ISET2,NUMSE1,NUMSE2,J,PPA0,XIDTEM, 1 XIDTE2,Y2,X2,D2) ENDIF 14471 CONTINUE ELSE CCCCC DO14481IRESAM=1,NRESAM CCCCC CALL DPJBS3(TEMP0,NS2,ICASJB,IRESAM,ISEED,TEMP,NS3,ITEMP1, CCCCC1 TEMP4,IBUGG3,IERROR) CCCCC DO14483IJ=1,NS3 CCCCC TEMPZ(IJ)=TEMPZ0(ITEMP1(IJ)) 14483 CONTINUE CCCCC CALL DPJBK2( CCCCC1 TEMP,TEMPZ,NS2, CCCCC1 ICASPL,IMETHD,IPPCDP,MAXNXT,MINMAX, CCCCC1 XTEMP1,XTEMP2,XTEMP3,TEMP8, CCCCC1 NHOR1,NHOR2,KSLOC,KSSCAL, CCCCC1 QP,XQP,NPERC, CCCCC1 PPA0,PPA1,SHAPE1,SHAPE2,ACORR, CCCCC1 IBUGG3,ISUBRO,IERROR) C CCCCC IF((NGRPV.GE.1 .AND. NPERC.GT.0 .AND. ISET.LE.NUMSET) .OR. CCCCC1 (NPERC.GT.0 .AND. NGRPV.EQ.0 .AND. ISET.EQ.1))THEN CCCCC IF(NGRPV.EQ.0)THEN CCCCC WRITE(IOUNI4,IFORMT)(XQP(JJ),JJ=1,NPERC) CCCCC ELSEIF(NGRPV.EQ.1)THEN CCCCC WRITE(IOUNI4,IFORMT)ISET,(XQP(JJ),JJ=1,NPERC) CCCCC ELSEIF(NGRPV.EQ.2)THEN CCCCC WRITE(IOUNI4,IFORMT)ISET1,ISET2,(XQP(JJ),JJ=1,NPERC) CCCCC ENDIF CCCCC ENDIF C CCCCC IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')THEN CCCCC IF(PPA0.LT.PPA0HT)NBELW1=NBELW1+1 CCCCC IF(PPA1.LT.PPA1HT)NBELW2=NBELW2+1 CCCCC IF(SHAPE1.LT.SHA1HT)NBELW3=NBELW3+1 CCCCC TEMP6(IRESAM)=PPA0 CCCCC TEMP7(IRESAM)=PPA1 CCCCC ENDIF CCCCC IF(NGRPV.LE.1)THEN CCCCC TAGID=1.0 CCCCC CALL DPJBS4(ISET,NUMSET,J,J2,PPA0,TAGID,XIDTEM, CCCCC1 Y2,X2,D2) CCCCC TAGID=2.0 CCCCC CALL DPJBS4(ISET,NUMSET,J,J2,PPA1,TAGID,XIDTEM, CCCCC1 Y2,X2,D2) CCCCC TAGID=3.0 CCCCC CALL DPJBS4(ISET,NUMSET,J,J2,SHAPE1,TAGID,XIDTEM, CCCCC1 Y2,X2,D2) CCCCC TAGID=4.0 CCCCC CALL DPJBS4(ISET,NUMSET,J,J2,SHAPE2,TAGID,XIDTEM, CCCCC1 Y2,X2,D2) CCCCC TAGID=5.0 CCCCC CALL DPJBS4(ISET,NUMSET,J,J2,ACORR,TAGID,XIDTEM, CCCCC1 Y2,X2,D2) CCCCC ELSE CCCCC CALL DPJBS5(ISET1,ISET2,NUMSE1,NUMSE2,J,PPA0,XIDTEM, CCCCC1 XIDTE2,Y2,X2,D2) CCCCC ENDIF 14481 CONTINUE ENDIF C C FOR BCA CONFIDENCE INTERVAL, COMPUTE: C 1) Z0HAT C 2) JACKNIFE ESTIMATES C IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')THEN CALL NORPPF(REAL(NBELOW)/REAL(NRESAM),Z0HAT) ICASZZ='JACK' DO14495IRESAM=1,NS2 CALL DPJBS3(TEMP0,NS2,ICASZZ,IRESAM,ISEED,TEMP,NS3,ITEMP1, 1 TEMP4,IBUGG3,IERROR) CALL CMPSTA( 1 TEMP,TEMPZ,XTEMP1,XTEMP2,XTEMP3, 1 MAXNXT,NS3,NS3,NUMV2,ICASPL, 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1 IQUAME,IQUASE, 1 RIGHT, 1 ISUBRO,IBUGG3,IERROR) TEMPTH(IRESAM)=RIGHT 14495 CONTINUE CALL MEAN(TEMPTH,NS2,IWRITE,THETDT,IBUGG3,IERROR) DSUM1=0.0D0 DSUM2=0.0D0 DTHETM=DBLE(THETDT) DO14498I=1,NS2 DTERM1=DBLE(TEMPTH(I)) DSUM1 = DSUM1 + (DTHETM - DTERM1)**3 DSUM2 = DSUM2 + (DTHETM - DTERM1)**2 14498 CONTINUE DTERM2 = DSUM1/(6.0D0*(DSUM2**1.5)) A0HAT=REAL(DTERM2) CALL NORPPF(ALPHA/2.0,ALOWSL) CALL NORPPF(1.0 - ALPHA/2.0,AUPPSL) TERM1=Z0HAT + (Z0HAT + AUPPSL)/(1.0 - A0HAT*(Z0HAT+AUPPSL)) CALL NORCDF(TERM1,ALPHA2) TERM1=Z0HAT + (Z0HAT + ALOWSL)/(1.0 - A0HAT*(Z0HAT+ALOWSL)) CALL NORCDF(TERM1,ALPHA1) CALL PERCEN(100.0*ALPHA1,TEMP6,NS2,IWRITE,TEMP4,MAXNXT, 1 BCAUL,IBUGG3,IERROR) CALL PERCEN(100.0*ALPHA2,TEMP6,NS2,IWRITE,TEMP4,MAXNXT, 1 BCALL,IBUGG3,IERROR) IF(NGRPV.EQ.1)THEN WRITE(IOUNI3,11368)BCALL,BCAUL,Z0HAT,A0HAT,ALPHA1,ALPHA2, 1 XIDTEM(ISET) ELSEIF(NGRPV.EQ.2)THEN WRITE(IOUNI3,11368)BCALL,BCAUL,Z0HAT,A0HAT,ALPHA1,ALPHA2, 1 XIDTEM(ISET1),XIDTE2(ISET2) ELSE WRITE(IOUNI3,11368)BCALL,BCAUL,Z0HAT,A0HAT,ALPHA1,ALPHA2 ENDIF ENDIF C ILAST=ISETMX IF(NGRPV.GE.1)ILAST=ISETMX-1 IF(NPERC.GT.0 .AND. ISET.EQ.ILAST)THEN IENDF4='OFF' IREWI4='ON' CALL DPCLFI(IOUNI4,IFILE4,ISTAT4,IFORM4,IACCE4,IPROT4,ICURS4, 1 IENDF4,IREWI4,ISUBN0,IERRF4,IBUGG3,ISUBRO,IERROR) IF(IERRF4.EQ.'YES')GOTO9000 ENDIF C GOTO79000 C C JACKNIFE/BOOTSTRAP FOR DISTRIBUTIONS THAT ESTIMATE LOCATION AND C SCALE PARAMETERS VIA MAXIMUM LIKELIHOOD. C 14710 CONTINUE C NUMPAR=2 IF(NPERC.GT.0 .AND.ISET.EQ.1)THEN IOUNI4=IST4NU IFILE4=IST4NA ISTAT4=IST4ST IFORM4=IST4FO IACCE4=IST4AC IPROT4=IST4PR ICURS4=IST4CS ISUBN0='JBS2' IERRF4='NO' C IREWI4='ON' CALL DPOPFI(IOUNI4,IFILE4,ISTAT4,IFORM4,IACCE4, 1 IPROT4,ICURS4, 1 IREWI4,ISUBN0,IERRF4,IBUGG3,ISUBRO,IERROR) IF(IERRF4.EQ.'YES')GOTO9000 IF(NGRPV.EQ.0)THEN IFORMT='( E15.7)' IFORMZ='( F15.3)' IF(NPERC.LE.9)THEN WRITE(IFORMT(5:5),'(I1)')NPERC WRITE(IFORMZ(5:5),'(I1)')NPERC ELSEIF(NPERC.LE.99)THEN WRITE(IFORMT(4:5),'(I2)')NPERC WRITE(IFORMZ(4:5),'(I2)')NPERC ELSEIF(NPERC.LE.999)THEN WRITE(IFORMT(3:5),'(I3)')NPERC WRITE(IFORMZ(3:5),'(I3)')NPERC ELSE NPERC=0 ENDIF ELSEIF(NGRPV.EQ.1)THEN IFORMT='(I8,1X, E15.7)' IFORMZ='(9X, F15.3)' IF(NPERC.LE.9)THEN WRITE(IFORMT(11:11),'(I1)')NPERC WRITE(IFORMZ(8:8),'(I1)')NPERC ELSEIF(NPERC.LE.99)THEN WRITE(IFORMT(10:11),'(I2)')NPERC WRITE(IFORMZ(7:8),'(I2)')NPERC ELSEIF(NPERC.LE.999)THEN WRITE(IFORMT(9:11),'(I3)')NPERC WRITE(IFORMZ(7:8),'(I3)')NPERC ELSE NPERC=0 ENDIF ELSEIF(NGRPV.EQ.2)THEN IFORMT='(I8,1X,I8,1X, E15.7)' IFORMZ='(18X, F15.3)' IF(NPERC.LE.9)THEN WRITE(IFORMT(17:17),'(I1)')NPERC WRITE(IFORMZ(9:9),'(I1)')NPERC ELSEIF(NPERC.LE.99)THEN WRITE(IFORMT(16:17),'(I2)')NPERC WRITE(IFORMZ(8:9),'(I2)')NPERC ELSEIF(NPERC.LE.999)THEN WRITE(IFORMT(15:17),'(I3)')NPERC WRITE(IFORMZ(8:9),'(I3)')NPERC ELSE NPERC=0 ENDIF ENDIF IF(NPERC.GT.0)THEN WRITE(IOUNI4,IFORMZ)(QP(JJ),JJ=1,NPERC) ENDIF ENDIF C C FOR BCA CONFIDENCE INTERVAL, COMPUTE FULL-SAMPLE STATISTIC. C IF((IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT') .OR. 1 (IBOOPA.EQ.'PARA' .AND. ICENSO.NE.'ON'))THEN CALL DPJBML(TEMP,TEMP4,NS2, 1 ICASPL,ICENSO,MAXNXT,MINMAX,PMAXLO, 1 XTEMP1,XTEMP2, 1 DTEMP1, 1 ALOCTH,SCALTH, 1 QP,XQP,NP, 1 IBUGG3,ISUBRO,IERROR) ICASRA='NULL' ALOCSV=ALOCTH SCALSV=SCALTH IF(ICASPL.EQ.'NOML')ICASRA='NORM' IF(ICASPL.EQ.'UNML')ICASRA='UNIF' IF(ICASPL.EQ.'LOML')ICASRA='LOGI' IF(ICASPL.EQ.'CAML')ICASRA='CAUC' IF(ICASPL.EQ.'LAML')ICASRA='DOUB' IF(ICASPL.EQ.'EXML')ICASRA='EXPO' IF(ICASPL.EQ.'GUML')ICASRA='EXV1' IF(ICASPL.EQ.'RAML')ICASRA='RAYL' IF(ICASPL.EQ.'FNML')ICASRA='FNRM' IF(ICASPL.EQ.'MAML')ICASRA='MAXW' NBELW1=0 NBELW2=0 ENDIF C C HANDLE BOOTSTRAP SAMPLE DIFFERENTLY FOR CENSORED AND UNCENSORED C DATA (CENSORED CASE HAS A PAIRED VARIABLE TO RESAMPLE) C IF(ICENSO.EQ.'OFF')THEN DO14761IRESAM=1,NRESAM IF(IBOOPA.EQ.'PARA')THEN CALL DPJBRA(ICASRA,ISEED,MINMAX, 1 TEMP,NS2, 1 SHAPE1,SHAPE2,ALOCTH,SCALTH, 1 IMAKDF,IGEODF,IBEIDF,IBEKDF,IGEPDF,IADEDF, 1 ILGADF,ISKNDF,IGLDDF, 1 IBUGG3,ISUBRO,IERROR) ELSE CALL DPJBS3(TEMP0,NS2,ICASJB,IRESAM,ISEED,TEMP, 1 NS3,ITEMP1, 1 TEMP4,IBUGG3,IERROR) ENDIF IF(IRESAM.EQ.1 .AND. 1 (IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'JBS2'))THEN DO14762II=1,NS2 WRITE(ICOUT,14763)II,TEMP(II) 14763 FORMAT('II,TEMP(II) = ',I8,G15.7) CALL DPWRST('XXX','BUG ') 14762 CONTINUE ENDIF CALL DPJBML(TEMP,TEMP4,NS2, 1 ICASPL,ICENSO,MAXNXT,MINMAX,PMAXLO, 1 XTEMP1,XTEMP2, 1 DTEMP1, 1 ALOC,SCALE, 1 QP,XQP,NPERC, 1 IBUGG3,ISUBRO,IERROR) C IF((NGRPV.GE.1 .AND. NPERC.GT.0 .AND. ISET.LE.NUMSET) .OR. 1 (NPERC.GT.0 .AND. NGRPV.EQ.0 .AND. ISET.EQ.1))THEN IF(NGRPV.EQ.0)THEN WRITE(IOUNI4,IFORMT)(XQP(JJ),JJ=1,NPERC) ELSEIF(NGRPV.EQ.1)THEN WRITE(IOUNI4,IFORMT)ISET,(XQP(JJ),JJ=1,NPERC) ELSEIF(NGRPV.EQ.2)THEN WRITE(IOUNI4,IFORMT)ISET1,ISET2,(XQP(JJ),JJ=1,NPERC) ENDIF ENDIF C IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')THEN IF(PPA0.LT.PPA0HT)NBELW1=NBELW1+1 TEMP6(IRESAM)=ALOC TEMP7(IRESAM)=SCALE ENDIF IF(NGRPV.LE.1)THEN TAGID=1.0 CALL DPJBS4(ISET,NUMSET,J,J2,ALOC,TAGID,XIDTEM, 1 Y2,X2,D2) TAGID=2.0 CALL DPJBS4(ISET,NUMSET,J,J2,SCALE,TAGID,XIDTEM, 1 Y2,X2,D2) ELSE CALL DPJBS5(ISET1,ISET2,NUMSE1,NUMSE2,J,ALOC,XIDTEM, 1 XIDTE2,Y2,X2,D2) ENDIF 14761 CONTINUE ELSE DO14771IRESAM=1,NRESAM CALL DPJBS3(TEMP0,NS2,ICASJB,IRESAM,ISEED,TEMP,NS3,ITEMP1, 1 TEMP4,IBUGG3,IERROR) DO14773IJ=1,NS3 TEMPZ(IJ)=TEMPZ0(ITEMP1(IJ)) 14773 CONTINUE CALL DPJBML(TEMP,TEMPZ,NS2, 1 ICASPL,ICENSO,MAXNXT,MINMAX,PMAXLO, 1 XTEMP1,XTEMP2, 1 DTEMP1, 1 ALOC,SCALE, 1 QP,XQP,NPERC, 1 IBUGG3,ISUBRO,IERROR) C IF((NGRPV.GE.1 .AND. NPERC.GT.0 .AND. ISET.LE.NUMSET) .OR. 1 (NPERC.GT.0 .AND. NGRPV.EQ.0 .AND. ISET.EQ.1))THEN IF(NGRPV.EQ.0)THEN WRITE(IOUNI4,IFORMT)(XQP(JJ),JJ=1,NPERC) ELSEIF(NGRPV.EQ.1)THEN WRITE(IOUNI4,IFORMT)ISET,(XQP(JJ),JJ=1,NPERC) ELSEIF(NGRPV.EQ.2)THEN WRITE(IOUNI4,IFORMT)ISET1,ISET2,(XQP(JJ),JJ=1,NPERC) ENDIF ENDIF C IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')THEN IF(ALOC.LT.ALOCTH)NBELW1=NBELW1+1 TEMP6(IRESAM)=ALOC TEMP7(IRESAM)=SCALE ENDIF IF(NGRPV.LE.1)THEN TAGID=1.0 CALL DPJBS4(ISET,NUMSET,J,J2,ALOC,TAGID,XIDTEM, 1 Y2,X2,D2) TAGID=2.0 CALL DPJBS4(ISET,NUMSET,J,J2,SCALE,TAGID,XIDTEM, 1 Y2,X2,D2) ELSE CALL DPJBS5(ISET1,ISET2,NUMSE1,NUMSE2,J,ALOC,XIDTEM, 1 XIDTE2,Y2,X2,D2) ENDIF 14771 CONTINUE ENDIF C C FOR BCA CONFIDENCE INTERVAL, COMPUTE: C 1) Z0HAT C 2) JACKNIFE ESTIMATES C IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')THEN CALL NORPPF(REAL(NBELOW)/REAL(NRESAM),Z0HAT) ICASZZ='JACK' DO14775IRESAM=1,NS2 CALL DPJBS3(TEMP0,NS2,ICASZZ,IRESAM,ISEED,TEMP,NS3,ITEMP1, 1 TEMP4,IBUGG3,IERROR) CALL CMPSTA( 1 TEMP,TEMPZ,XTEMP1,XTEMP2,XTEMP3, 1 MAXNXT,NS3,NS3,NUMV2,ICASPL, 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1 IQUAME,IQUASE, 1 RIGHT, 1 ISUBRO,IBUGG3,IERROR) TEMPTH(IRESAM)=RIGHT 14775 CONTINUE CALL MEAN(TEMPTH,NS2,IWRITE,THETDT,IBUGG3,IERROR) DSUM1=0.0D0 DSUM2=0.0D0 DTHETM=DBLE(THETDT) DO14765I=1,NS2 DTERM1=DBLE(TEMPTH(I)) DSUM1 = DSUM1 + (DTHETM - DTERM1)**3 DSUM2 = DSUM2 + (DTHETM - DTERM1)**2 14765 CONTINUE DTERM2 = DSUM1/(6.0D0*(DSUM2**1.5)) A0HAT=REAL(DTERM2) CALL NORPPF(ALPHA/2.0,ALOWSL) CALL NORPPF(1.0 - ALPHA/2.0,AUPPSL) TERM1=Z0HAT + (Z0HAT + AUPPSL)/(1.0 - A0HAT*(Z0HAT+AUPPSL)) CALL NORCDF(TERM1,ALPHA2) TERM1=Z0HAT + (Z0HAT + ALOWSL)/(1.0 - A0HAT*(Z0HAT+ALOWSL)) CALL NORCDF(TERM1,ALPHA1) CALL PERCEN(100.0*ALPHA1,TEMP6,NS2,IWRITE,TEMP4,MAXNXT, 1 BCAUL,IBUGG3,IERROR) CALL PERCEN(100.0*ALPHA2,TEMP6,NS2,IWRITE,TEMP4,MAXNXT, 1 BCALL,IBUGG3,IERROR) IF(NGRPV.EQ.1)THEN WRITE(IOUNI3,11368)BCALL,BCAUL,Z0HAT,A0HAT,ALPHA1,ALPHA2, 1 XIDTEM(ISET) ELSEIF(NGRPV.EQ.2)THEN WRITE(IOUNI3,11368)BCALL,BCAUL,Z0HAT,A0HAT,ALPHA1,ALPHA2, 1 XIDTEM(ISET1),XIDTE2(ISET2) ELSE WRITE(IOUNI3,11368)BCALL,BCAUL,Z0HAT,A0HAT,ALPHA1,ALPHA2 ENDIF ENDIF C ILAST=ISETMX IF(NGRPV.GE.1)ILAST=ISETMX-1 IF(NPERC.GT.0 .AND. ISET.EQ.ILAST)THEN IENDF4='OFF' IREWI4='ON' CALL DPCLFI(IOUNI4,IFILE4,ISTAT4,IFORM4,IACCE4,IPROT4,ICURS4, 1 IENDF4,IREWI4,ISUBN0,IERRF4,IBUGG3,ISUBRO,IERROR) IF(IERRF4.EQ.'YES')GOTO9000 ENDIF C GOTO79000 C C JACKNIFE/BOOTSTRAP FOR DISTRIBUTIONS THAT ESTIMATE ONE SHAPE AND C THE SCALE PARAMETERS VIA MAXIMUM LIKELIHOOD. C 14810 CONTINUE C NUMPAR=2 IF(NPERC.GT.0 .AND.ISET.EQ.1)THEN IOUNI4=IST4NU IFILE4=IST4NA ISTAT4=IST4ST IFORM4=IST4FO IACCE4=IST4AC IPROT4=IST4PR ICURS4=IST4CS ISUBN0='JBS2' IERRF4='NO' C IREWI4='ON' CALL DPOPFI(IOUNI4,IFILE4,ISTAT4,IFORM4,IACCE4, 1 IPROT4,ICURS4, 1 IREWI4,ISUBN0,IERRF4,IBUGG3,ISUBRO,IERROR) IF(IERRF4.EQ.'YES')GOTO9000 IF(NGRPV.EQ.0)THEN IFORMT='( E15.7)' IFORMZ='( F15.3)' IF(NPERC.LE.9)THEN WRITE(IFORMT(5:5),'(I1)')NPERC WRITE(IFORMZ(5:5),'(I1)')NPERC ELSEIF(NPERC.LE.99)THEN WRITE(IFORMT(4:5),'(I2)')NPERC WRITE(IFORMZ(4:5),'(I2)')NPERC ELSEIF(NPERC.LE.999)THEN WRITE(IFORMT(3:5),'(I3)')NPERC WRITE(IFORMZ(3:5),'(I3)')NPERC ELSE NPERC=0 ENDIF ELSEIF(NGRPV.EQ.1)THEN IFORMT='(I8,1X, E15.7)' IFORMZ='(9X, F15.3)' IF(NPERC.LE.9)THEN WRITE(IFORMT(11:11),'(I1)')NPERC WRITE(IFORMZ(8:8),'(I1)')NPERC ELSEIF(NPERC.LE.99)THEN WRITE(IFORMT(10:11),'(I2)')NPERC WRITE(IFORMZ(7:8),'(I2)')NPERC ELSEIF(NPERC.LE.999)THEN WRITE(IFORMT(9:11),'(I3)')NPERC WRITE(IFORMZ(7:8),'(I3)')NPERC ELSE NPERC=0 ENDIF ELSEIF(NGRPV.EQ.2)THEN IFORMT='(I8,1X,I8,1X, E15.7)' IFORMZ='(18X, F15.3)' IF(NPERC.LE.9)THEN WRITE(IFORMT(17:17),'(I1)')NPERC WRITE(IFORMZ(9:9),'(I1)')NPERC ELSEIF(NPERC.LE.99)THEN WRITE(IFORMT(16:17),'(I2)')NPERC WRITE(IFORMZ(8:9),'(I2)')NPERC ELSEIF(NPERC.LE.999)THEN WRITE(IFORMT(15:17),'(I3)')NPERC WRITE(IFORMZ(8:9),'(I3)')NPERC ELSE NPERC=0 ENDIF ENDIF IF(NPERC.GT.0)THEN WRITE(IOUNI4,IFORMZ)(QP(JJ),JJ=1,NPERC) ENDIF ENDIF C C FOR BCA CONFIDENCE INTERVAL, COMPUTE FULL-SAMPLE STATISTIC. C IF((IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT') .OR. 1 (IBOOPA.EQ.'PARA' .AND. ICENSO.NE.'ON'))THEN CALL DPJBM2(TEMP,TEMP4,NS2, 1 ICASPL,ICENSO,MAXNXT,MINMAX,IGEPDF, 1 XTEMP1,XTEMP2, 1 DTEMP1, 1 SCALTH,SHAPTH, 1 QP,XQP,NP, 1 IPOTTO, 1 IBUGG3,ISUBRO,IERROR) ICASRA='NULL' ALOCSV=0.0 SCALSV=SCALTH SHAPSV=SHAPTH IF(ICASPL.EQ.'WEML')ICASRA='WEIB' IF(ICASPL.EQ.'GAML')ICASRA='GAMM' IF(ICASPL.EQ.'LNML')ICASRA='LOGN' IF(ICASPL.EQ.'FLML')ICASRA='FL ' IF(ICASPL.EQ.'EEML')ICASRA='GEEE' IF(ICASPL.EQ.'BEML')ICASRA='BETA' IF(ICASPL.EQ.'IGML')ICASRA='IG ' IF(ICASPL.EQ.'PAML')ICASRA='PARE' IF(ICASPL.EQ.'GEML')ICASRA='GPAR' IF(ICASPL.EQ.'GEMO')ICASRA='GPAR' IF(ICASPL.EQ.'GEDE')ICASRA='GPAR' IF(ICASPL.EQ.'GECM')ICASRA='GPAR' IF(ICASPL.EQ.'FRML')ICASRA='FREC' IF(ICASPL.EQ.'IWML')ICASRA='IWEI' NBELW1=0 NBELW2=0 ENDIF C C HANDLE BOOTSTRAP SAMPLE DIFFERENTLY FOR CENSORED AND UNCENSORED C DATA (CENSORED CASE HAS A PAIRED VARIABLE TO RESAMPLE) C IF(ICENSO.EQ.'OFF')THEN DO14861IRESAM=1,NRESAM IF(IBOOPA.EQ.'PARA')THEN CALL DPJBRA(ICASRA,ISEED,MINMAX, 1 TEMP,NS2, 1 SHAPSV,SHAPE2,ALOCSV,SCALSV, 1 IMAKDF,IGEODF,IBEIDF,IBEKDF,IGEPDF,IADEDF, 1 ILGADF,ISKNDF,IGLDDF, 1 IBUGG3,ISUBRO,IERROR) ELSE CALL DPJBS3(TEMP0,NS2,ICASJB,IRESAM,ISEED,TEMP, 1 NS3,ITEMP1, 1 TEMP4,IBUGG3,IERROR) ENDIF IF(IRESAM.EQ.1 .AND. 1 (IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'JBS2'))THEN DO14862II=1,NS2 WRITE(ICOUT,14863)II,TEMP(II) 14863 FORMAT('II,TEMP(II) = ',I8,G15.7) CALL DPWRST('XXX','BUG ') 14862 CONTINUE ENDIF CALL DPJBM2(TEMP,TEMP4,NS2, 1 ICASPL,ICENSO,MAXNXT,MINMAX,IGEPDF, 1 XTEMP1,XTEMP2, 1 DTEMP1, 1 SCALE,SHAPE, 1 QP,XQP,NPERC, 1 IPOTTO, 1 IBUGG3,ISUBRO,IERROR) C IF((NGRPV.GE.1 .AND. NPERC.GT.0 .AND. ISET.LE.NUMSET) .OR. 1 (NPERC.GT.0 .AND. NGRPV.EQ.0 .AND. ISET.EQ.1))THEN IF(NGRPV.EQ.0)THEN WRITE(IOUNI4,IFORMT)(XQP(JJ),JJ=1,NPERC) ELSEIF(NGRPV.EQ.1)THEN WRITE(IOUNI4,IFORMT)ISET,(XQP(JJ),JJ=1,NPERC) ELSEIF(NGRPV.EQ.2)THEN WRITE(IOUNI4,IFORMT)ISET1,ISET2,(XQP(JJ),JJ=1,NPERC) ENDIF ENDIF C IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')THEN IF(PPA0.LT.PPA0HT)NBELW1=NBELW1+1 TEMP6(IRESAM)=SCALE TEMP7(IRESAM)=SHAPE ENDIF IF(NGRPV.LE.1)THEN TAGID=1.0 CALL DPJBS4(ISET,NUMSET,J,J2,SCALE,TAGID,XIDTEM, 1 Y2,X2,D2) TAGID=2.0 CALL DPJBS4(ISET,NUMSET,J,J2,SHAPE,TAGID,XIDTEM, 1 Y2,X2,D2) ELSE CALL DPJBS5(ISET1,ISET2,NUMSE1,NUMSE2,J,ALOC,XIDTEM, 1 XIDTE2,Y2,X2,D2) ENDIF 14861 CONTINUE ELSE DO14871IRESAM=1,NRESAM CALL DPJBS3(TEMP0,NS2,ICASJB,IRESAM,ISEED,TEMP,NS3,ITEMP1, 1 TEMP4,IBUGG3,IERROR) DO14873IJ=1,NS3 TEMPZ(IJ)=TEMPZ0(ITEMP1(IJ)) 14873 CONTINUE CALL DPJBM2(TEMP,TEMPZ,NS2, 1 ICASPL,ICENSO,MAXNXT,MINMAX,IGEPDF, 1 XTEMP1,XTEMP2, 1 DTEMP1, 1 SCALE,SHAPE, 1 QP,XQP,NPERC, 1 IPOTTO, 1 IBUGG3,ISUBRO,IERROR) C IF((NGRPV.GE.1 .AND. NPERC.GT.0 .AND. ISET.LE.NUMSET) .OR. 1 (NPERC.GT.0 .AND. NGRPV.EQ.0 .AND. ISET.EQ.1))THEN IF(NGRPV.EQ.0)THEN WRITE(IOUNI4,IFORMT)(XQP(JJ),JJ=1,NPERC) ELSEIF(NGRPV.EQ.1)THEN WRITE(IOUNI4,IFORMT)ISET,(XQP(JJ),JJ=1,NPERC) ELSEIF(NGRPV.EQ.2)THEN WRITE(IOUNI4,IFORMT)ISET1,ISET2,(XQP(JJ),JJ=1,NPERC) ENDIF ENDIF C IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')THEN IF(ALOC.LT.ALOCTH)NBELW1=NBELW1+1 TEMP6(IRESAM)=SCALE TEMP7(IRESAM)=SHAPE ENDIF IF(NGRPV.LE.1)THEN TAGID=1.0 CALL DPJBS4(ISET,NUMSET,J,J2,SCALE,TAGID,XIDTEM, 1 Y2,X2,D2) TAGID=2.0 CALL DPJBS4(ISET,NUMSET,J,J2,SHAPE,TAGID,XIDTEM, 1 Y2,X2,D2) ELSE CALL DPJBS5(ISET1,ISET2,NUMSE1,NUMSE2,J,ALOC,XIDTEM, 1 XIDTE2,Y2,X2,D2) ENDIF 14871 CONTINUE ENDIF C C FOR BCA CONFIDENCE INTERVAL, COMPUTE: C 1) Z0HAT C 2) JACKNIFE ESTIMATES C IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')THEN CALL NORPPF(REAL(NBELOW)/REAL(NRESAM),Z0HAT) ICASZZ='JACK' DO14875IRESAM=1,NS2 CALL DPJBS3(TEMP0,NS2,ICASZZ,IRESAM,ISEED,TEMP,NS3,ITEMP1, 1 TEMP4,IBUGG3,IERROR) CALL CMPSTA( 1 TEMP,TEMPZ,XTEMP1,XTEMP2,XTEMP3, 1 MAXNXT,NS3,NS3,NUMV2,ICASPL, 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1 IQUAME,IQUASE, 1 RIGHT, 1 ISUBRO,IBUGG3,IERROR) TEMPTH(IRESAM)=RIGHT 14875 CONTINUE CALL MEAN(TEMPTH,NS2,IWRITE,THETDT,IBUGG3,IERROR) DSUM1=0.0D0 DSUM2=0.0D0 DTHETM=DBLE(THETDT) DO14865I=1,NS2 DTERM1=DBLE(TEMPTH(I)) DSUM1 = DSUM1 + (DTHETM - DTERM1)**3 DSUM2 = DSUM2 + (DTHETM - DTERM1)**2 14865 CONTINUE DTERM2 = DSUM1/(6.0D0*(DSUM2**1.5)) A0HAT=REAL(DTERM2) CALL NORPPF(ALPHA/2.0,ALOWSL) CALL NORPPF(1.0 - ALPHA/2.0,AUPPSL) TERM1=Z0HAT + (Z0HAT + AUPPSL)/(1.0 - A0HAT*(Z0HAT+AUPPSL)) CALL NORCDF(TERM1,ALPHA2) TERM1=Z0HAT + (Z0HAT + ALOWSL)/(1.0 - A0HAT*(Z0HAT+ALOWSL)) CALL NORCDF(TERM1,ALPHA1) CALL PERCEN(100.0*ALPHA1,TEMP6,NS2,IWRITE,TEMP4,MAXNXT, 1 BCAUL,IBUGG3,IERROR) CALL PERCEN(100.0*ALPHA2,TEMP6,NS2,IWRITE,TEMP4,MAXNXT, 1 BCALL,IBUGG3,IERROR) IF(NGRPV.EQ.1)THEN WRITE(IOUNI3,11368)BCALL,BCAUL,Z0HAT,A0HAT,ALPHA1,ALPHA2, 1 XIDTEM(ISET) ELSEIF(NGRPV.EQ.2)THEN WRITE(IOUNI3,11368)BCALL,BCAUL,Z0HAT,A0HAT,ALPHA1,ALPHA2, 1 XIDTEM(ISET1),XIDTE2(ISET2) ELSE WRITE(IOUNI3,11368)BCALL,BCAUL,Z0HAT,A0HAT,ALPHA1,ALPHA2 ENDIF ENDIF C ILAST=ISETMX IF(NGRPV.GE.1)ILAST=ISETMX-1 IF(NPERC.GT.0 .AND. ISET.EQ.ILAST)THEN IENDF4='OFF' IREWI4='ON' CALL DPCLFI(IOUNI4,IFILE4,ISTAT4,IFORM4,IACCE4,IPROT4,ICURS4, 1 IENDF4,IREWI4,ISUBN0,IERRF4,IBUGG3,ISUBRO,IERROR) IF(IERRF4.EQ.'YES')GOTO9000 ENDIF C GOTO79000 C C JACKNIFE/BOOTSTRAP FOR DISTRIBUTIONS THAT ESTIMATE ONE SHAPE AND C THE LOCATION AND SCALE PARAMETERS VIA MAXIMUM LIKELIHOOD. C C NOTE 3/2006: ASYMMETRIC LAPLACE CAN HAVE UNDEFINED MAXIMUM C LIKELIHOOD ESTIMATE. C C 1) IF FULL SAMPLE MLE IS UNDEFINED, PRINT C ERROR MESSAGE AND SKIP BOOTSTRAP. C C 2) FOR BOOTSTRAP SAMPLES, KEEP TRACK OF HOW C MANY SAMPLES ARE UNDEFINED. IF THIS POSITIVE, C PRINT HOW MANY SAMPLES ARE UNDEFINED. C 14910 CONTINUE C NUMPAR=3 IF(NPERC.GT.0 .AND.ISET.EQ.1)THEN IOUNI4=IST4NU IFILE4=IST4NA ISTAT4=IST4ST IFORM4=IST4FO IACCE4=IST4AC IPROT4=IST4PR ICURS4=IST4CS ISUBN0='JBS2' IERRF4='NO' C IREWI4='ON' CALL DPOPFI(IOUNI4,IFILE4,ISTAT4,IFORM4,IACCE4, 1 IPROT4,ICURS4, 1 IREWI4,ISUBN0,IERRF4,IBUGG3,ISUBRO,IERROR) IF(IERRF4.EQ.'YES')GOTO9000 IF(NGRPV.EQ.0)THEN IFORMT='( E15.7)' IFORMZ='( F15.3)' IF(NPERC.LE.9)THEN WRITE(IFORMT(5:5),'(I1)')NPERC WRITE(IFORMZ(5:5),'(I1)')NPERC ELSEIF(NPERC.LE.99)THEN WRITE(IFORMT(4:5),'(I2)')NPERC WRITE(IFORMZ(4:5),'(I2)')NPERC ELSEIF(NPERC.LE.999)THEN WRITE(IFORMT(3:5),'(I3)')NPERC WRITE(IFORMZ(3:5),'(I3)')NPERC ELSE NPERC=0 ENDIF ELSEIF(NGRPV.EQ.1)THEN IFORMT='(I8,1X, E15.7)' IFORMZ='(9X, F15.3)' IF(NPERC.LE.9)THEN WRITE(IFORMT(11:11),'(I1)')NPERC WRITE(IFORMZ(8:8),'(I1)')NPERC ELSEIF(NPERC.LE.99)THEN WRITE(IFORMT(10:11),'(I2)')NPERC WRITE(IFORMZ(7:8),'(I2)')NPERC ELSEIF(NPERC.LE.999)THEN WRITE(IFORMT(9:11),'(I3)')NPERC WRITE(IFORMZ(7:8),'(I3)')NPERC ELSE NPERC=0 ENDIF ELSEIF(NGRPV.EQ.2)THEN IFORMT='(I8,1X,I8,1X, E15.7)' IFORMZ='(18X, F15.3)' IF(NPERC.LE.9)THEN WRITE(IFORMT(17:17),'(I1)')NPERC WRITE(IFORMZ(9:9),'(I1)')NPERC ELSEIF(NPERC.LE.99)THEN WRITE(IFORMT(16:17),'(I2)')NPERC WRITE(IFORMZ(8:9),'(I2)')NPERC ELSEIF(NPERC.LE.999)THEN WRITE(IFORMT(15:17),'(I3)')NPERC WRITE(IFORMZ(8:9),'(I3)')NPERC ELSE NPERC=0 ENDIF ENDIF IF(NPERC.GT.0)THEN WRITE(IOUNI4,IFORMZ)(QP(JJ),JJ=1,NPERC) ENDIF ENDIF C C FOR BCA CONFIDENCE INTERVAL, COMPUTE FULL-SAMPLE STATISTIC. C IF((IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT') .OR. 1 (IBOOPA.EQ.'PARA' .AND. ICENSO.NE.'ON'))THEN IUDFLG=0 CALL DPJBM4(TEMP,TEMP4,NS2, 1 ICASPL,ICENSO,MAXNXT,MINMAX, 1 XTEMP1,XTEMP2, 1 DTEMP1,DTEMP2,DTEMP3,DTEMP4, 1 IADEDF, 1 ALOCTH,SCALTH,SHAPTH, 1 QP,XQP,NP, 1 IUDFLG, 1 IBUGG3,ISUBRO,IERROR) C IF(IUDFLG.EQ.1)THEN WRITE(ICOUT,14851) 14851 FORMAT('***** ERROR FROM BOOTSTRAP/JACKNIFE PLOT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,14853) 14853 FORMAT(' FULL SAMPLE MAXIMUM LIKELIHOOD IS ', 1 'UNDEFINED FOR') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,14854) 14854 FORMAT(' ASYMMETRIC LAPLACE DISTRIBUTION.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C ICASRA='NULL' ALOCSV=ALOCTH SCALSV=SCALTH SHAPSV=SHAPTH IF(ICASPL.EQ.'ADML')ICASRA='ASDE' NBELW1=0 NBELW2=0 NBELW3=0 ELSE IUDFLG=0 CALL DPJBM4(TEMP,TEMP4,NS2, 1 ICASPL,ICENSO,MAXNXT,MINMAX, 1 XTEMP1,XTEMP2, 1 DTEMP1,DTEMP2,DTEMP3,DTEMP4, 1 IADEDF, 1 ALOCTH,SCALTH,SHAPTH, 1 QP,XQP,NP, 1 IUDFLG, 1 IBUGG3,ISUBRO,IERROR) C IF(IUDFLG.EQ.1)THEN WRITE(ICOUT,14851) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,14853) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,14854) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF ENDIF C C HANDLE BOOTSTRAP SAMPLE DIFFERENTLY FOR CENSORED AND UNCENSORED C DATA (CENSORED CASE HAS A PAIRED VARIABLE TO RESAMPLE) C IUDCNT=0 IF(ICENSO.EQ.'OFF')THEN DO14961IRESAM=1,NRESAM IF(IBOOPA.EQ.'PARA')THEN CALL DPJBRA(ICASRA,ISEED,MINMAX, 1 TEMP,NS2, 1 SHAPSV,SHAPE2,ALOCSV,SCALSV, 1 IMAKDF,IGEODF,IBEIDF,IBEKDF,IGEPDF,IADEDF, 1 ILGADF,ISKNDF,IGLDDF, 1 IBUGG3,ISUBRO,IERROR) ELSE CALL DPJBS3(TEMP0,NS2,ICASJB,IRESAM,ISEED,TEMP, 1 NS3,ITEMP1, 1 TEMP4,IBUGG3,IERROR) ENDIF IF(IRESAM.EQ.1 .AND. 1 (IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'JBS2'))THEN DO14962II=1,NS2 WRITE(ICOUT,14963)II,TEMP(II) 14963 FORMAT('II,TEMP(II) = ',I8,G15.7) CALL DPWRST('XXX','BUG ') 14962 CONTINUE ENDIF CALL DPJBM4(TEMP,TEMP4,NS2, 1 ICASPL,ICENSO,MAXNXT,MINMAX, 1 XTEMP1,XTEMP2, 1 DTEMP1,DTEMP2,DTEMP3,DTEMP4, 1 IADEDF, 1 ALOC,SCALE,SHAPE, 1 QP,XQP,NPERC, 1 IUDFLG, 1 IBUGG3,ISUBRO,IERROR) IF(IUDFLG.EQ.1)THEN NREJ=NREJ+1 ENDIF C IF(IUDFLG.EQ.0)THEN IF( 1 (NGRPV.GE.1 .AND. NPERC.GT.0 .AND. ISET.LE.NUMSET) .OR. 1 (NPERC.GT.0 .AND. NGRPV.EQ.0 .AND. ISET.EQ.1))THEN IF(NGRPV.EQ.0)THEN WRITE(IOUNI4,IFORMT)(XQP(JJ),JJ=1,NPERC) ELSEIF(NGRPV.EQ.1)THEN WRITE(IOUNI4,IFORMT)ISET,(XQP(JJ),JJ=1,NPERC) ELSEIF(NGRPV.EQ.2)THEN WRITE(IOUNI4,IFORMT)ISET1,ISET2,(XQP(JJ),JJ=1,NPERC) ENDIF ENDIF C IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')THEN IF(PPA0.LT.PPA0HT)NBELW1=NBELW1+1 TEMP6(IRESAM)=SCALE TEMP7(IRESAM)=SHAPE ENDIF IF(NGRPV.LE.1)THEN TAGID=1.0 CALL DPJBS4(ISET,NUMSET,J,J2,ALOC,TAGID,XIDTEM, 1 Y2,X2,D2) TAGID=2.0 CALL DPJBS4(ISET,NUMSET,J,J2,SCALE,TAGID,XIDTEM, 1 Y2,X2,D2) TAGID=3.0 CALL DPJBS4(ISET,NUMSET,J,J2,SHAPE,TAGID,XIDTEM, 1 Y2,X2,D2) ELSE CALL DPJBS5(ISET1,ISET2,NUMSE1,NUMSE2,J,ALOC,XIDTEM, 1 XIDTE2,Y2,X2,D2) ENDIF ENDIF 14961 CONTINUE ELSE DO14971IRESAM=1,NRESAM CALL DPJBS3(TEMP0,NS2,ICASJB,IRESAM,ISEED,TEMP,NS3,ITEMP1, 1 TEMP4,IBUGG3,IERROR) DO14973IJ=1,NS3 TEMPZ(IJ)=TEMPZ0(ITEMP1(IJ)) 14973 CONTINUE IUDFLG=0 CALL DPJBM4(TEMP,TEMPZ,NS2, 1 ICASPL,ICENSO,MAXNXT,MINMAX, 1 XTEMP1,XTEMP2, 1 DTEMP1,DTEMP2,DTEMP3,DTEMP4, 1 IADEDF, 1 ALOC,SCALE,SHAPE, 1 QP,XQP,NPERC, 1 IUDFLG, 1 IBUGG3,ISUBRO,IERROR) C IF(IUDFLG.EQ.1)THEN NREJ=NREJ+1 ENDIF C IF(IUDFLG.EQ.0)THEN IF( 1 (NGRPV.GE.1 .AND. NPERC.GT.0 .AND. ISET.LE.NUMSET) .OR. 1 (NPERC.GT.0 .AND. NGRPV.EQ.0 .AND. ISET.EQ.1))THEN IF(NGRPV.EQ.0)THEN WRITE(IOUNI4,IFORMT)(XQP(JJ),JJ=1,NPERC) ELSEIF(NGRPV.EQ.1)THEN WRITE(IOUNI4,IFORMT)ISET,(XQP(JJ),JJ=1,NPERC) ELSEIF(NGRPV.EQ.2)THEN WRITE(IOUNI4,IFORMT)ISET1,ISET2,(XQP(JJ),JJ=1,NPERC) ENDIF ENDIF C IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')THEN IF(ALOC.LT.ALOCTH)NBELW1=NBELW1+1 TEMP6(IRESAM)=SCALE TEMP7(IRESAM)=SHAPE ENDIF IF(NGRPV.LE.1)THEN TAGID=1.0 CALL DPJBS4(ISET,NUMSET,J,J2,ALOC,TAGID,XIDTEM, 1 Y2,X2,D2) TAGID=2.0 CALL DPJBS4(ISET,NUMSET,J,J2,SCALE,TAGID,XIDTEM, 1 Y2,X2,D2) TAGID=3.0 CALL DPJBS4(ISET,NUMSET,J,J2,SHAPE,TAGID,XIDTEM, 1 Y2,X2,D2) ELSE CALL DPJBS5(ISET1,ISET2,NUMSE1,NUMSE2,J,ALOC,XIDTEM, 1 XIDTE2,Y2,X2,D2) ENDIF ENDIF 14971 CONTINUE ENDIF C IF(NREJ.GT.0)THEN WRITE(ICOUT,54872) 54872 FORMAT('***** WARNING FROM BOOTSTRAP/JACKNIFE PLOT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54873)NREJ,NRESAM 54873 FORMAT(' ',I8,' OF ',I8,' BOOTSTRAP SAMPLES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54874) 54874 FORMAT(' RESULTED IN UNDEFINED MAXIMUM LIKELIHOOD', 1 'ESTIMATES.') CALL DPWRST('XXX','BUG ') ENDIF C C FOR BCA CONFIDENCE INTERVAL, COMPUTE: C 1) Z0HAT C 2) JACKNIFE ESTIMATES C IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT' .AND. NREJ.LE.0)THEN CALL NORPPF(REAL(NBELOW)/REAL(NRESAM),Z0HAT) ICASZZ='JACK' DO14975IRESAM=1,NS2 CALL DPJBS3(TEMP0,NS2,ICASZZ,IRESAM,ISEED,TEMP,NS3,ITEMP1, 1 TEMP4,IBUGG3,IERROR) CALL CMPSTA( 1 TEMP,TEMPZ,XTEMP1,XTEMP2,XTEMP3, 1 MAXNXT,NS3,NS3,NUMV2,ICASPL, 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1 IQUAME,IQUASE, 1 RIGHT, 1 ISUBRO,IBUGG3,IERROR) TEMPTH(IRESAM)=RIGHT 14975 CONTINUE CALL MEAN(TEMPTH,NS2,IWRITE,THETDT,IBUGG3,IERROR) DSUM1=0.0D0 DSUM2=0.0D0 DTHETM=DBLE(THETDT) DO14965I=1,NS2 DTERM1=DBLE(TEMPTH(I)) DSUM1 = DSUM1 + (DTHETM - DTERM1)**3 DSUM2 = DSUM2 + (DTHETM - DTERM1)**2 14965 CONTINUE DTERM2 = DSUM1/(6.0D0*(DSUM2**1.5)) A0HAT=REAL(DTERM2) CALL NORPPF(ALPHA/2.0,ALOWSL) CALL NORPPF(1.0 - ALPHA/2.0,AUPPSL) TERM1=Z0HAT + (Z0HAT + AUPPSL)/(1.0 - A0HAT*(Z0HAT+AUPPSL)) CALL NORCDF(TERM1,ALPHA2) TERM1=Z0HAT + (Z0HAT + ALOWSL)/(1.0 - A0HAT*(Z0HAT+ALOWSL)) CALL NORCDF(TERM1,ALPHA1) CALL PERCEN(100.0*ALPHA1,TEMP6,NS2,IWRITE,TEMP4,MAXNXT, 1 BCAUL,IBUGG3,IERROR) CALL PERCEN(100.0*ALPHA2,TEMP6,NS2,IWRITE,TEMP4,MAXNXT, 1 BCALL,IBUGG3,IERROR) IF(NGRPV.EQ.1)THEN WRITE(IOUNI3,11368)BCALL,BCAUL,Z0HAT,A0HAT,ALPHA1,ALPHA2, 1 XIDTEM(ISET) ELSEIF(NGRPV.EQ.2)THEN WRITE(IOUNI3,11368)BCALL,BCAUL,Z0HAT,A0HAT,ALPHA1,ALPHA2, 1 XIDTEM(ISET1),XIDTE2(ISET2) ELSE WRITE(IOUNI3,11368)BCALL,BCAUL,Z0HAT,A0HAT,ALPHA1,ALPHA2 ENDIF ENDIF C ILAST=ISETMX IF(NGRPV.GE.1)ILAST=ISETMX-1 IF(NPERC.GT.0 .AND. ISET.EQ.ILAST)THEN IENDF4='OFF' IREWI4='ON' CALL DPCLFI(IOUNI4,IFILE4,ISTAT4,IFORM4,IACCE4,IPROT4,ICURS4, 1 IENDF4,IREWI4,ISUBN0,IERRF4,IBUGG3,ISUBRO,IERROR) IF(IERRF4.EQ.'YES')GOTO9000 ENDIF C GOTO79000 C 79000 CONTINUE C C ************************************************ C ** STEP 19-- ** C ** FOR GROUPED DATA, WRITE GROUP-ID, MEAN, ** C ** MEDIAN, B025, B975, B05, B90, B005, B995 ** C ** TO DPST1F.DAT. ** C ************************************************ C CCCCC JANUARY 2005. FOR UNGROUPED DATA, WRITE BOOTSTRAP ESTIMATES CCCCC TO FILE. ALSO, ACCOMODATE CASE WHERE MORE CCCCC THAN ONE PARAMETER IS ESTIMATED. C IF(NGRPV.EQ.1)THEN IF(NUMPAR.LE.1)THEN IF(ISET.LE.NUMSET)THEN ICOUNT=0 DO19010I=1,J IF(INT(D2(I)+0.01).EQ.ISET)THEN ICOUNT=ICOUNT+1 TEMP(ICOUNT)=Y2(I) WRITE(IOUNI1,19012)ISET,Y2(I) ENDIF 19010 CONTINUE 19012 FORMAT(I8,E15.7) ENDIF ELSEIF(NUMPAR.EQ.2)THEN IF(ISET.LE.NUMSET)THEN ICOUNT=0 DO19013I=1,J,2 IF(INT(D2(I)+0.01).EQ.ISET)THEN ICOUNT=ICOUNT+1 TEMP(ICOUNT)=Y2(I) ICOUNT=ICOUNT+1 TEMP(ICOUNT)=Y2(I+1) WRITE(IOUNI1,19014)ISET,Y2(I),Y2(I+1) ENDIF 19013 CONTINUE 19014 FORMAT(I8,2E15.7) ENDIF ELSEIF(NUMPAR.EQ.3)THEN IF(ISET.LE.NUMSET)THEN ICOUNT=0 DO19016I=1,J,3 IF(INT(D2(I)+0.01).EQ.ISET)THEN ICOUNT=ICOUNT+1 TEMP(ICOUNT)=Y2(I) ICOUNT=ICOUNT+1 TEMP(ICOUNT)=Y2(I+1) ICOUNT=ICOUNT+1 TEMP(ICOUNT)=Y2(I+2) WRITE(IOUNI1,19017)ISET,Y2(I),Y2(I+1),Y2(I+2) ENDIF 19016 CONTINUE 19017 FORMAT(I8,3E15.7) ENDIF ELSEIF(NUMPAR.EQ.4)THEN IF(ISET.LE.NUMSET)THEN ICOUNT=0 DO19018I=1,J,4 IF(INT(D2(I)+0.01).EQ.ISET)THEN ICOUNT=ICOUNT+1 TEMP(ICOUNT)=Y2(I) ICOUNT=ICOUNT+1 TEMP(ICOUNT)=Y2(I+1) ICOUNT=ICOUNT+1 TEMP(ICOUNT)=Y2(I+2) ICOUNT=ICOUNT+1 TEMP(ICOUNT)=Y2(I+3) WRITE(IOUNI1,19019)ISET,Y2(I),Y2(I+1),Y2(I+2),Y2(I+3) ENDIF 19018 CONTINUE 19019 FORMAT(I8,4E15.7) ENDIF ELSEIF(NUMPAR.EQ.5)THEN IF(ISET.LE.NUMSET)THEN ICOUNT=0 DO19118I=1,J,5 IF(INT(D2(I)+0.01).EQ.ISET)THEN ICOUNT=ICOUNT+1 TEMP(ICOUNT)=Y2(I) ICOUNT=ICOUNT+1 TEMP(ICOUNT)=Y2(I+1) ICOUNT=ICOUNT+1 TEMP(ICOUNT)=Y2(I+2) ICOUNT=ICOUNT+1 TEMP(ICOUNT)=Y2(I+3) ICOUNT=ICOUNT+1 TEMP(ICOUNT)=Y2(I+4) WRITE(IOUNI1,19119)ISET,Y2(I),Y2(I+1),Y2(I+2), 1 Y2(I+3),Y2(I+4) ENDIF 19118 CONTINUE 19119 FORMAT(I8,5E15.7) ENDIF ENDIF ELSEIF(NGRPV.EQ.2)THEN IF(NUMPAR.EQ.1)THEN IF(ISET.LE.NUMSET)THEN ITAG=(ISET1-1)*NUMSE2 + ISET2 ICOUNT=0 DO19020I=1,J IF(INT(D2(I)+0.01).EQ.ITAG)THEN ICOUNT=ICOUNT+1 TEMP(ICOUNT)=Y2(I) WRITE(IOUNI1,19024)ISET1,ISET2,Y2(I) ENDIF 19020 CONTINUE 19024 FORMAT(2I8,E15.7) ENDIF ELSEIF(NUMPAR.EQ.2)THEN IF(ISET.LE.NUMSET)THEN ITAG=(ISET1-1)*NUMSE2 + ISET2 ICOUNT=0 DO19030I=1,J,2 IF(INT(D2(I)+0.01).EQ.ITAG)THEN ICOUNT=ICOUNT+1 TEMP(ICOUNT)=Y2(I) ICOUNT=ICOUNT+1 TEMP(ICOUNT)=Y2(I+1) WRITE(IOUNI1,19034)ISET1,ISET2,Y2(I),Y2(I+1) ENDIF 19030 CONTINUE 19034 FORMAT(2I8,2E15.7) ENDIF ELSEIF(NUMPAR.EQ.3)THEN IF(ISET.LE.NUMSET)THEN ITAG=(ISET1-1)*NUMSE2 + ISET2 ICOUNT=0 DO19040I=1,J,3 IF(INT(D2(I)+0.01).EQ.ITAG)THEN ICOUNT=ICOUNT+1 TEMP(ICOUNT)=Y2(I) ICOUNT=ICOUNT+1 TEMP(ICOUNT)=Y2(I+1) ICOUNT=ICOUNT+1 TEMP(ICOUNT)=Y2(I+2) WRITE(IOUNI1,19044)ISET1,ISET2,Y2(I),Y2(I+1),Y2(I+2) ENDIF 19040 CONTINUE 19044 FORMAT(2I8,3E15.7) ENDIF ELSEIF(NUMPAR.EQ.4)THEN IF(ISET.LE.NUMSET)THEN ITAG=(ISET1-1)*NUMSE2 + ISET2 ICOUNT=0 DO19050I=1,J,4 IF(INT(D2(I)+0.01).EQ.ITAG)THEN ICOUNT=ICOUNT+1 TEMP(ICOUNT)=Y2(I) ICOUNT=ICOUNT+1 TEMP(ICOUNT)=Y2(I+1) ICOUNT=ICOUNT+1 TEMP(ICOUNT)=Y2(I+2) ICOUNT=ICOUNT+1 TEMP(ICOUNT)=Y2(I+3) WRITE(IOUNI1,19054)ISET1,ISET2,Y2(I),Y2(I+1), 1 Y2(I+2),Y2(I+3) ENDIF 19050 CONTINUE 19054 FORMAT(2I8,4E15.7) ENDIF ELSEIF(NUMPAR.EQ.5)THEN IF(ISET.LE.NUMSET)THEN ITAG=(ISET1-1)*NUMSE2 + ISET2 ICOUNT=0 DO19150I=1,J,5 IF(INT(D2(I)+0.01).EQ.ITAG)THEN ICOUNT=ICOUNT+1 TEMP(ICOUNT)=Y2(I) ICOUNT=ICOUNT+1 TEMP(ICOUNT)=Y2(I+1) ICOUNT=ICOUNT+1 TEMP(ICOUNT)=Y2(I+2) ICOUNT=ICOUNT+1 TEMP(ICOUNT)=Y2(I+3) ICOUNT=ICOUNT+1 TEMP(ICOUNT)=Y2(I+4) WRITE(IOUNI1,19154)ISET1,ISET2,Y2(I),Y2(I+1), 1 Y2(I+2),Y2(I+3),Y2(I+4) ENDIF 19150 CONTINUE 19154 FORMAT(2I8,5E15.7) ENDIF ENDIF ELSE ICOUNT=J IF(NUMPAR.LE.1)THEN DO29110I=1,J WRITE(IOUNI1,29114)Y2(I) TEMP(I)=Y2(I) 29114 FORMAT(E15.7) 29110 CONTINUE ELSEIF(NUMPAR.EQ.2)THEN DO29130I=1,J,2 WRITE(IOUNI1,29134)Y2(I),Y2(I+1) TEMP(I)=Y2(I) TEMP(I+1)=Y2(I+1) 29134 FORMAT(2E15.7) 29130 CONTINUE ELSEIF(NUMPAR.EQ.3)THEN DO29140I=1,J,3 WRITE(IOUNI1,29144)Y2(I),Y2(I+1),Y2(I+2) TEMP(I)=Y2(I) TEMP(I+1)=Y2(I+1) TEMP(I+2)=Y2(I+2) 29144 FORMAT(3E15.7) 29140 CONTINUE ELSEIF(NUMPAR.EQ.4)THEN DO29150I=1,J,4 WRITE(IOUNI1,29154)Y2(I),Y2(I+1),Y2(I+2),Y2(I+3) TEMP(I)=Y2(I) TEMP(I+1)=Y2(I+1) TEMP(I+2)=Y2(I+2) TEMP(I+3)=Y2(I+3) 29154 FORMAT(4E15.7) 29150 CONTINUE ELSEIF(NUMPAR.EQ.5)THEN DO29250I=1,J,5 WRITE(IOUNI1,29254)Y2(I),Y2(I+1),Y2(I+2),Y2(I+3),Y2(I+4) TEMP(I)=Y2(I) TEMP(I+1)=Y2(I+1) TEMP(I+2)=Y2(I+2) TEMP(I+3)=Y2(I+3) TEMP(I+4)=Y2(I+4) 29254 FORMAT(5E15.7) 29250 CONTINUE ENDIF ENDIF C IF(NGRPV.GE.1 .AND. ISET.GT.NUMSET)GOTO11000 C IF(NUMPAR.EQ.1)THEN CALL SORT(TEMP,ICOUNT,TEMP) CALL MEAN(TEMP,ICOUNT,IWRITE,BMEAN,IBUGG3,IERROR) CALL SD(TEMP,ICOUNT,IWRITE,BSD,IBUGG3,IERROR) CALL MEDIAN(TEMP,ICOUNT,IWRITE,XTEMP1,MAXNXT,B50, 1 IBUGG3,IERROR) C APERC=95.0 CALL PERCEN(APERC,TEMP,ICOUNT,IWRITE,XTEMP1,MAXNXT,B95, 1 IBUGG3,IERROR) APERC=5.0 CALL PERCEN(APERC,TEMP,ICOUNT,IWRITE,XTEMP1,MAXNXT,B05, 1 IBUGG3,IERROR) APERC=97.5 CALL PERCEN(APERC,TEMP,ICOUNT,IWRITE,XTEMP1,MAXNXT,B975, 1 IBUGG3,IERROR) APERC=2.5 CALL PERCEN(APERC,TEMP,ICOUNT,IWRITE,XTEMP1,MAXNXT,B025, 1 IBUGG3,IERROR) APERC=99.5 CALL PERCEN(APERC,TEMP,ICOUNT,IWRITE,XTEMP1,MAXNXT,B995, 1 IBUGG3,IERROR) APERC=0.5 CALL PERCEN(APERC,TEMP,ICOUNT,IWRITE,XTEMP1,MAXNXT,B005, 1 IBUGG3,IERROR) C IF(NGRPV.EQ.0)THEN WRITE(IOUNI2,39025)BMEAN,BSD,B50,B025,B975,B05,B95, 1 B005,B995 39025 FORMAT(9E15.7) ELSEIF(NGRPV.EQ.1)THEN WRITE(IOUNI2,39027)ISET,BMEAN,BSD,B50,B025,B975,B05,B95, 1 B005,B995 39027 FORMAT(I8,9E15.7) ELSEIF(NGRPV.EQ.2)THEN WRITE(IOUNI2,39029)ISET1,ISET2,BMEAN,BSD,B50,B025,B975, 1 B05,B95,B005,B995 39029 FORMAT(2I8,9E15.7) ENDIF ELSEIF(NUMPAR.GE.2)THEN DO39110IPAR=1,NUMPAR ICOUNT=0 DO39013I=1,J,NUMPAR IF(INT(D2(I)+0.01).EQ.ISET)THEN ICOUNT=ICOUNT+1 XTEMP1(ICOUNT)=Y2(I+IPAR-1) ENDIF 39013 CONTINUE CALL SORT(XTEMP1,ICOUNT,XTEMP1) C CALL MEAN(XTEMP1,ICOUNT,IWRITE,BMEAN,IBUGG3,IERROR) CALL SD(XTEMP1,ICOUNT,IWRITE,BSD,IBUGG3,IERROR) CALL MEDIAN(XTEMP1,ICOUNT,IWRITE,XTEMP2,MAXNXT,B50, 1 IBUGG3,IERROR) APERC=95.0 CALL PERCEN(APERC,XTEMP1,ICOUNT,IWRITE,XTEMP1,MAXNXT,B95, 1 IBUGG3,IERROR) APERC=5.0 CALL PERCEN(APERC,XTEMP1,ICOUNT,IWRITE,XTEMP1,MAXNXT,B05, 1 IBUGG3,IERROR) APERC=97.5 CALL PERCEN(APERC,XTEMP1,ICOUNT,IWRITE,XTEMP1,MAXNXT,B975, 1 IBUGG3,IERROR) APERC=2.5 CALL PERCEN(APERC,XTEMP1,ICOUNT,IWRITE,XTEMP1,MAXNXT,B025, 1 IBUGG3,IERROR) APERC=99.5 CALL PERCEN(APERC,XTEMP1,ICOUNT,IWRITE,XTEMP1,MAXNXT,B995, 1 IBUGG3,IERROR) APERC=0.5 CALL PERCEN(APERC,XTEMP1,ICOUNT,IWRITE,XTEMP1,MAXNXT,B005, 1 IBUGG3,IERROR) C IF(NGRPV.EQ.0)THEN WRITE(IOUNI2,39125)IPAR,BMEAN,BSD,B50,B025,B975,B05, 1 B95,B005,B995 39125 FORMAT(I8,9E15.7) ELSEIF(NGRPV.EQ.1)THEN WRITE(IOUNI2,39127)IPAR,ISET,BMEAN,BSD,B50,B025,B975, 1 B05,B95,B005,B995 39127 FORMAT(2I8,9E15.7) ELSEIF(NGRPV.EQ.2)THEN WRITE(IOUNI2,39129)IPAR,ISET1,ISET2,BMEAN,BSD,B50,B025, 1 B975,B05,B95,B005,B995 39129 FORMAT(3I8,9E15.7) ENDIF 39110 CONTINUE ENDIF 11000 CONTINUE N2=J NPLOTV=3 C CCCCC IF(NUMSET.GE.1)THEN IENDF1='OFF' IREWI1='ON' CALL DPCLFI(IOUNI1,IFILE1,ISTAT1,IFORM1,IACCE1,IPROT1,ICURS1, 1 IENDF1,IREWI1,ISUBN0,IERRF1,IBUGG3,ISUBRO,IERROR) C IENDF2='OFF' IREWI2='ON' CALL DPCLFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 1 IENDF2,IREWI2,ISUBN0,IERRF2,IBUGG3,ISUBRO,IERROR) C IF(IFEEDB.EQ.'ON')THEN C WRITE(ICOUT,8102) 8102 FORMAT('THE FOLLOWING INFORMATION IS WRITTEN TO FILES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8104) 8104 FORMAT('DPST1F.DAT: THE BOOTSTRAP VALUES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8106) 8106 FORMAT(' FOR GROUPED DATA, THE FIRST ONE (OR ', 1 'TWO) COLUMNS IDENTIFY THE GROUP(S).') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8112) 8112 FORMAT('DPST2F.DAT: STATISTICS BASED ON BOOTSTRAP VALUES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8114) 8114 FORMAT(' MEAN, SD, MEDIAN, B025, ', 1 'B975, B05, B95, B005, B995') CALL DPWRST('XXX','BUG ') IF(NUMPAR.GT.1)THEN WRITE(ICOUT,8118) 8118 FORMAT(' THE FIRST COLUMN IDENTIFIES THE ', 1 'PARAMETER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') ENDIF WRITE(ICOUT,8116) 8116 FORMAT(' FOR GROUPED DATA, THE FIRST ONE (OR ', 1 'TWO) COLUMNS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8117) 8117 FORMAT(' (AFTER THE PARAMETER ID) IDENTIFY ', 1 'THE GROUP(S).') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') C ENDIF C CCCCC ENDIF C IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')THEN IENDF3='OFF' IREWI3='ON' CALL DPCLFI(IOUNI3,IFILE3,ISTAT3,IFORM3,IACCE3,IPROT3,ICURS3, 1 IENDF3,IREWI3,ISUBN0,IERRF3,IBUGG3,ISUBRO,IERROR) C IF(IFEEDB.EQ.'ON')THEN C WRITE(ICOUT,8102) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8131) 8131 FORMAT('DPST3F.DAT: BCa CONFIDENCE INTERVALS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8132) 8132 FORMAT('LOWER INTERVAL, UPPER INTERVAL, Z0HAT, A0HAT, ', 1 'ALPHA1, ALPHA2, GROUP 1 ID, GROUP 2 ID') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8134) 8134 FORMAT('WITH 4E15.7,2F8.4,2F10.0 FORMAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') C ENDIF C ENDIF C C *********************************** C ** STEP 20-- ** C ** COMPUTE VARIOUS PERCENTILES ** C *********************************** C CALL SORT(Y2,N2,TEMP) CALL MEAN(TEMP,N2,IWRITE,BMEAN,IBUGG3,IERROR) CALL SD(TEMP,N2,IWRITE,BSD,IBUGG3,IERROR) CALL MEDIAN(TEMP,N2,IWRITE,XTEMP1,MAXNXT,B50,IBUGG3,IERROR) C APERC=0.20 AN=REAL(N2)*APERC ILOW=INT(AN+0.0000001) IHIGH=ILOW+1 IF(ILOW.LT.1)ILOW=1 IF(ILOW.GT.N2)ILOW=N2 IF(IHIGH.LT.1)ILOW=1 IF(IHIGH.GT.N2)ILOW=N2 AWT2=AN-REAL(ILOW) AWT1=1.0-AWT2 B20=AWT1*TEMP(ILOW) + AWT2*TEMP(IHIGH) C APERC=0.80 AN=REAL(N2)*APERC ILOW=INT(AN+0.0000001) IHIGH=ILOW+1 IF(ILOW.LT.1)ILOW=1 IF(ILOW.GT.N2)ILOW=N2 IF(IHIGH.LT.1)ILOW=1 IF(IHIGH.GT.N2)ILOW=N2 AWT2=AN-REAL(ILOW) AWT1=1.0-AWT2 B80=AWT1*TEMP(ILOW) + AWT2*TEMP(IHIGH) C APERC=0.10 AN=REAL(N2)*APERC ILOW=INT(AN+0.0000001) IHIGH=ILOW+1 IF(ILOW.LT.1)ILOW=1 IF(ILOW.GT.N2)ILOW=N2 IF(IHIGH.LT.1)ILOW=1 IF(IHIGH.GT.N2)ILOW=N2 AWT2=AN-REAL(ILOW) AWT1=1.0-AWT2 B10=AWT1*TEMP(ILOW) + AWT2*TEMP(IHIGH) C APERC=0.90 AN=REAL(N2)*APERC ILOW=INT(AN+0.0000001) IHIGH=ILOW+1 IF(ILOW.LT.1)ILOW=1 IF(ILOW.GT.N2)ILOW=N2 IF(IHIGH.LT.1)ILOW=1 IF(IHIGH.GT.N2)ILOW=N2 AWT2=AN-REAL(ILOW) AWT1=1.0-AWT2 B90=AWT1*TEMP(ILOW) + AWT2*TEMP(IHIGH) C APERC=0.95 AN=REAL(N2)*APERC ILOW=INT(AN+0.0000001) IHIGH=ILOW+1 IF(ILOW.LT.1)ILOW=1 IF(ILOW.GT.N2)ILOW=N2 IF(IHIGH.LT.1)ILOW=1 IF(IHIGH.GT.N2)ILOW=N2 AWT2=AN-REAL(ILOW) AWT1=1.0-AWT2 B95=AWT1*TEMP(ILOW) + AWT2*TEMP(IHIGH) C APERC=0.05 AN=REAL(N2)*APERC ILOW=INT(AN+0.0000001) IHIGH=ILOW+1 IF(ILOW.LT.1)ILOW=1 IF(ILOW.GT.N2)ILOW=N2 IF(IHIGH.LT.1)ILOW=1 IF(IHIGH.GT.N2)ILOW=N2 AWT2=AN-REAL(ILOW) AWT1=1.0-AWT2 B05=AWT1*TEMP(ILOW) + AWT2*TEMP(IHIGH) C APERC=0.975 AN=REAL(N2)*APERC ILOW=INT(AN+0.0000001) IHIGH=ILOW+1 IF(ILOW.LT.1)ILOW=1 IF(ILOW.GT.N2)ILOW=N2 IF(IHIGH.LT.1)ILOW=1 IF(IHIGH.GT.N2)ILOW=N2 AWT2=AN-REAL(ILOW) AWT1=1.0-AWT2 B975=AWT1*TEMP(ILOW) + AWT2*TEMP(IHIGH) C APERC=0.025 AN=REAL(N2)*APERC ILOW=INT(AN+0.0000001) IHIGH=ILOW+1 IF(ILOW.LT.1)ILOW=1 IF(ILOW.GT.N2)ILOW=N2 IF(IHIGH.LT.1)ILOW=1 IF(IHIGH.GT.N2)ILOW=N2 AWT2=AN-REAL(ILOW) AWT1=1.0-AWT2 B025=AWT1*TEMP(ILOW) + AWT2*TEMP(IHIGH) C APERC=0.99 AN=REAL(N2)*APERC ILOW=INT(AN+0.0000001) IHIGH=ILOW+1 IF(ILOW.LT.1)ILOW=1 IF(ILOW.GT.N2)ILOW=N2 IF(IHIGH.LT.1)ILOW=1 IF(IHIGH.GT.N2)ILOW=N2 AWT2=AN-REAL(ILOW) AWT1=1.0-AWT2 B99=AWT1*TEMP(ILOW) + AWT2*TEMP(IHIGH) C APERC=0.01 AN=REAL(N2)*APERC ILOW=INT(AN+0.0000001) IHIGH=ILOW+1 IF(ILOW.LT.1)ILOW=1 IF(ILOW.GT.N2)ILOW=N2 IF(IHIGH.LT.1)ILOW=1 IF(IHIGH.GT.N2)ILOW=N2 AWT2=AN-REAL(ILOW) AWT1=1.0-AWT2 B01=AWT1*TEMP(ILOW) + AWT2*TEMP(IHIGH) C APERC=0.995 AN=REAL(N2)*APERC ILOW=INT(AN+0.0000001) IHIGH=ILOW+1 IF(ILOW.LT.1)ILOW=1 IF(ILOW.GT.N2)ILOW=N2 IF(IHIGH.LT.1)ILOW=1 IF(IHIGH.GT.N2)ILOW=N2 AWT2=AN-REAL(ILOW) AWT1=1.0-AWT2 B995=AWT1*TEMP(ILOW) + AWT2*TEMP(IHIGH) C APERC=0.005 AN=REAL(N2)*APERC ILOW=INT(AN+0.0000001) IHIGH=ILOW+1 IF(ILOW.LT.1)ILOW=1 IF(ILOW.GT.N2)ILOW=N2 IF(IHIGH.LT.1)ILOW=1 IF(IHIGH.GT.N2)ILOW=N2 AWT2=AN-REAL(ILOW) AWT1=1.0-AWT2 B005=AWT1*TEMP(ILOW) + AWT2*TEMP(IHIGH) C APERC=0.999 AN=REAL(N2)*APERC ILOW=INT(AN+0.0000001) IHIGH=ILOW+1 IF(ILOW.LT.1)ILOW=1 IF(ILOW.GT.N2)ILOW=N2 IF(IHIGH.LT.1)ILOW=1 IF(IHIGH.GT.N2)ILOW=N2 AWT2=AN-REAL(ILOW) AWT1=1.0-AWT2 B999=AWT1*TEMP(ILOW) + AWT2*TEMP(IHIGH) C APERC=0.001 AN=REAL(N2)*APERC ILOW=INT(AN+0.0000001) IHIGH=ILOW+1 IF(ILOW.LT.1)ILOW=1 IF(ILOW.GT.N2)ILOW=N2 IF(IHIGH.LT.1)ILOW=1 IF(IHIGH.GT.N2)ILOW=N2 AWT2=AN-REAL(ILOW) AWT1=1.0-AWT2 B001=AWT1*TEMP(ILOW) + AWT2*TEMP(IHIGH) C GOTO9000 C C ****************** C ** STEP 90-- ** C ** EXIT ** C ****************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'PSP2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPJBS2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGG3,ISUBRO,ICASJB,IBOOSS 9012 FORMAT('IBUGG3,ISUBRO,ICASJB,IBOOSS = ',A4,2X,A4,2X,A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ICASPL,N,NUMSET,N2,IERROR 9013 FORMAT('ICASPL,N,NUMSET,N2,IERROR = ',A4,3I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NUMV2,ISIZE 9014 FORMAT('NUMV2,ISIZE = ',2I8) CALL DPWRST('XXX','BUG ') DO9020I=1,N2 WRITE(ICOUT,9021)I,Y2(I),X2(I),D2(I) 9021 FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2) CALL DPWRST('XXX','BUG ') 9020 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPJBS3(TEMP1,N1,ICASJB,IJACIN,ISEED,TEMP2,N2, 1INDX, 1AINDEX, 1IBUGG3,IERROR) C C PURPOSE--GENERATE 1 JACKNIFE SUBSAMPLE OF SIZE N1-1 C OR 1 BOOTSTRAP SUBSAMPLE OF SIZE N1 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--89/2 C ORIGINAL VERSION--JANUARY 1989. C UPDATED --JULY 2002. ADD AN INDEX VARIABLE. USE C FOR CASES WHERE NEED TO C KEEP TWO OR MORE RESPONSE C VARIABLES DEPENDENT (E.G., C CORRELATION KEEPS PAIRING C INTACT). C UPDATED --AUGUST 2005. DUNRAN WAS FIXED TO GO FROM C 0 TO N. THIS ROUTINE WAS C MODIFIED TO CALL A VERSION C THAT GOES FROM 1 TO N. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASJB CHARACTER*4 IBUGG3 CHARACTER*4 IERROR C C--------------------------------------------------------------------- C CCCCC INCLUDE 'DPCOPA.INC' C DIMENSION TEMP1(*) DIMENSION TEMP2(*) DIMENSION AINDEX(*) DIMENSION INDX(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IERROR='NO' C IF(IBUGG3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPJBS3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)N1,ICASJB,IJACIN 52 FORMAT('N1,ICASJB,IJACIN = ',I8,2X,A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGG3 53 FORMAT('IBUGG3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)ISEED 54 FORMAT('ISEED = ',I8) CALL DPWRST('XXX','BUG ') IF(N1.LE.0)GOTO59 DO55I=1,N1 WRITE(ICOUT,56)I,TEMP1(I) 56 FORMAT('I,TEMP1(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 59 CONTINUE 90 CONTINUE C C ************************************************** C ** STEP 11-- ** C ** CHECK THE INPUT NUMBER FOR ERRORS ** C ************************************************** C IF(N1.GE.1)GOTO1119 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1111) 1111 FORMAT('***** ERROR IN DPJBS3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1112) 1112 FORMAT(' THE INPUT RAW DATA SAMPLE SIZE WAS NEGATIVE ', 1'OR ZERO.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1113)N1 1113 FORMAT(' THE INPUT RAW DATA SAMPLE SIZE = ',I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1119 CONTINUE C IF(ICASJB.EQ.'JACK')GOTO1120 GOTO1129 1120 CONTINUE IF(IJACIN.GE.1)GOTO1129 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1121) 1121 FORMAT('***** ERROR IN DPJBS3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1122) 1122 FORMAT(' THE INPUT JACKNIFE INDEX WAS NON-POSITIVE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1123)N1 1123 FORMAT(' THE INPUT JACKNIFE INDEX = ',I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1129 CONTINUE C C ************************************************** C ** STEP 12-- ** C ** GENERATE THE JACKNIFE OR BOOTSTRAP SAMPLE ** C ************************************************** C IF(ICASJB.EQ.'JACK')GOTO1210 GOTO1220 C 1210 CONTINUE J=0 DO1211I=1,N1 IF(I.EQ.IJACIN)GOTO1211 J=J+1 TEMP2(J)=TEMP1(I) INDX(J)=I 1211 CONTINUE N2=J GOTO9000 C 1220 CONTINUE CCCCC CALL DUNRAN(N1,N1,ISEED,AINDEX) CALL DUNRA2(N1,N1,ISEED,AINDEX) DO1221I=1,N1 J=AINDEX(I)+0.5 TEMP2(I)=TEMP1(J) INDX(I)=J 1221 CONTINUE N2=N1 GOTO9000 C C ******************* C ** STEP 90-- ** C ** EXIT ** C ******************* C 9000 CONTINUE IF(IBUGG3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPJBS3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)N1,ICASJB,IJACIN 9012 FORMAT('N1,ICASJB,IJACIN = ',I8,2X,A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IBUGG3 9013 FORMAT('IBUGG3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)N2 9014 FORMAT('N2 = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)IBUGG3 9015 FORMAT('IBUGG3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)ISEED 9016 FORMAT('ISEED = ',I8) CALL DPWRST('XXX','BUG ') IF(N1.LE.0)GOTO9029 DO9021I=1,N1 WRITE(ICOUT,9022)I,TEMP1(I),AINDEX(I),INDX(I) 9022 FORMAT('I,TEMP1(I),AINDEX(I),INDX(I) = ',I8,2E15.7,I8) CALL DPWRST('XXX','BUG ') 9021 CONTINUE 9029 CONTINUE IF(N2.LE.0)GOTO9039 DO9031I=1,N2 WRITE(ICOUT,9032)I,TEMP2(I) 9032 FORMAT('I,TEMP2(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 9031 CONTINUE 9039 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPJBS4(ISET,NUMSET,J,J2,RIGHT,TAGID,XIDTEM,Y2,X2,D2) C C PURPOSE--ADD A COMPUTED POINT TO THE OUTPUT PLOT VECTORS C FOR THE JACKNIFE AND BOOTSTRAP PLOTS. C CAUTION--THE INPUT ARGUMENT J CHANGES WITHIN C THIS ROUTINE AND IS ALSO AN OUTPUT ARGUMENT. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--89/2 C ORIGINAL VERSION--JANUARY 1989. C UPDATED --MARCH 2003. FOR REPLICATION CASE, SET C TAGPLOT (D2) TO REFLECT C REPLICATION NUMBER C UPDATED --JANUARY 2005. SET D2 FOR CASE WHERE MORE C THAN ONE STATISTIC ESTIMATED C (E.G., DISTRIBUTIONAL FITS), C TAGID IDENTIFIES WHICH C STATISTIC C C--------------------------------------------------------------------- C DIMENSION XIDTEM(*) DIMENSION Y2(*) DIMENSION X2(*) DIMENSION D2(*) 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 IF(NUMSET.LE.0)GOTO1100 GOTO1200 C C ************************************************** C ** STEP 11-- ** C ** TREAT THE CASE WHEN HAVE NO (= FULL DATA) SUBSET ** C ************************************************** C 1100 CONTINUE CCCCC IF(ISET.LE.NUMSET)GOTO1110 CCCCC GOTO1120 1110 CONTINUE J=J+1 Y2(J)=RIGHT IF(TAGID.EQ.1.0)THEN J2=J2+1 ENDIF X2(J)=J2 CCCCC D2(J)=1.0 D2(J)=TAGID GOTO1190 1120 CONTINUE GOTO9000 CCCCC J=J+1 CCCCC Y2(J)=RIGHT CCCCC X2(J)=XIDTEM(1) CCCCC D2(J)=2.0 CCCCC J=J+1 CCCCC Y2(J)=RIGHT CCCCC X2(J)=XIDTEM(NUMSET) CCCCC D2(J)=2.0 CCCCC GOTO1190 1190 CONTINUE GOTO9000 C C ************************************************** C ** STEP 12-- ** C ** TREAT THE CASE WHEN HAVE 2 OR MORE SUBSETS ** C ************************************************** C 1200 CONTINUE IF(ISET.LE.NUMSET)GOTO1210 GOTO1220 1210 CONTINUE J=J+1 Y2(J)=RIGHT X2(J)=XIDTEM(ISET) + (TAGID-1.0)/10.0 CCCCC D2(J)=1.0 D2(J)=(TAGID-1.0)*REAL(NUMSET) + REAL(ISET) GOTO1290 1220 CONTINUE GOTO9000 CCCCC J=J+1 CCCCC Y2(J)=RIGHT CCCCC X2(J)=XIDTEM(1) CCCCC D2(J)=2.0 CCCCC J=J+1 CCCCC Y2(J)=RIGHT CCCCC X2(J)=XIDTEM(NUMSET) CCCCC D2(J)=2.0 CCCCC GOTO1290 1290 CONTINUE GOTO9000 C C ******************* C ** STEP 90-- ** C ** EXIT ** C ******************* C 9000 CONTINUE C RETURN END SUBROUTINE DPJBS5(ISET1,ISET2,NUMSE1,NUMSE2,J,RIGHT,XIDTEM, 1 XIDTE2,Y2,X2,D2) C C PURPOSE--ADD A COMPUTED POINT TO THE OUTPUT PLOT VECTORS C FOR THE JACKNIFE AND BOOTSTRAP PLOTS. C THIS IS A SPECIAL VERSION OF DPJBS4 FOR THE CASE C WHEN THERE ARE EXACTLY TWO GROUP VRIABLES. C CAUTION--THE INPUT ARGUMENT J CHANGES WITHIN C THIS ROUTINE AND IS ALSO AN OUTPUT ARGUMENT. 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--2003/7 C ORIGINAL VERSION--JULY 2003. C C--------------------------------------------------------------------- C DIMENSION XIDTEM(*) DIMENSION XIDTE2(*) DIMENSION Y2(*) DIMENSION X2(*) DIMENSION D2(*) 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 IF(ISET1.LE.0 .OR. ISET2.LE.0)GOTO9000 C C ************************************************** C ** STEP 12-- ** C ** TREAT THE CASE WHEN HAVE 2 GROUPS ** C ************************************************** C AINC=0.4/REAL(NUMSE2) ASTRT=XIDTEM(ISET1) - 0.2 XTEMP=ASTRT + REAL(ISET2-1)*AINC J=J+1 Y2(J)=RIGHT X2(J)=XTEMP ITEMP=(ISET1-1)*NUMSE2 + ISET2 D2(J)=REAL(ITEMP) C C ******************* C ** STEP 90-- ** C ** EXIT ** C ******************* C 9000 CONTINUE C RETURN END SUBROUTINE DPJBCP(Y,X,N, 1ICASPL,ICENSO,IMETHD,IPPCDP,MAXOBV,MINMAX, 1Y2,X2,Y3,X3, 1NHOR1,IGEPDF,IADEDF,ILGADF,ISKNDF, 1QP,XPERC,NPERC, 1PPA0,PPA1,SHAPE1,CORRMX, 1IBUGG3,ISUBRO,IERROR) C C PURPOSE--FOR A GIVEN BOOTSTRAP SAMPLE, GENERATE THE PPCC PLOT C TO ESTIMATE THE SHAPE PARAMETER(S) AND THEN THE C PROBABILITY PLOT TO ESTIMATE LOCATION (PPA0) AND C SCALE (PPA1). BOTH UNCENSORED AND CENSORED C PLOTS ARE SUPPORTED. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2005/1 C ORIGINAL VERSION--JANUARY 2005. C UPDATED --OCTOBER 2006. CALL LIST TO TPPF C C SUPPORTED DISTRIBUTIONS ARE: C C 1) WEIBULL C 2) LOGNORMAL C 3) GAMMA C 4) INVERTED GAMMA C 5) LOG GAMMA C 6) INVERTED WEIBULL C 7) GENERALIZED PARETO C 8) T C 9) CHI-SQUARE C 10) CHI C 11) TUKEY-LAMBDA C 12) FRECHET C 13) WALD C 14) FATIGUE LIFE C 15) PARETO C 16) PARETO SECOND KIND C 17) GEOMETRIC EXTREME EXPONENTIAL C 18) BRADFORD C 19) RECIPROCAL C 20) ERROR (SUBBOTIN) C 21) LOG LOGISTIC C 22) DOUBLE WEIBULL C 23) FOLDED T C 24) SKEW LAPLACE (SKEW DOUBLE EXPONENTIAL) C 25) ASYMMETRIC LAPLACE (ASYMMETRIC DOUBLE EXPONENTIAL) C 26) GENERALIZED EXTREME VALUE C 27) LOG DOUBLE EXPONENTIAL (LOG LAPLACE) C 28) POWER C 29) VON MISES C 30) GENERALIZED LOGISTIC C 31) GENERALIZED HALF LOGISTIC C 32) WRAPPED CAUCHY C 33) POWER NORMAL C 34) DOUBLE GAMMA C 35) GENERALIZED LOGISTIC TYPE 2 C 36) GENERALIZED LOGISTIC TYPE 3 C 37) GENERALIZED LOGISTIC TYPE 5 C C FOLLOWING COULD POTENTIALLY BE ADDED: C C 35) SKEW NORMAL C 36) MAXWELL C 37) MCLEISH C 38) TRIANGULAR C C ALL OF THESE SUPPORT BOTH CENSORED AND UNCENSORED DATA C C------------------------------------------------------------------ C CHARACTER*4 ICASPL CHARACTER*4 ICENSO CHARACTER*4 IMETHD CHARACTER*4 IGEPDF CHARACTER*4 IADEDF CHARACTER*4 ILGADF CHARACTER*4 ISKNDF CHARACTER*4 IBUGG3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C DIMENSION Y(*) DIMENSION X(*) DIMENSION Y2(*) DIMENSION X2(*) DIMENSION Y3(*) DIMENSION X3(*) DIMENSION QP(*) DIMENSION XPERC(*) C DOUBLE PRECISION DPPF DOUBLE PRECISION XPAR(3) DOUBLE PRECISION QUAGLO EXTERNAL QUAGLO C CHARACTER*30 IDIST C CHARACTER*4 IWRITE CHARACTER*4 ISTEPN CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 IHP CHARACTER*4 IHP2 CHARACTER*4 LOWLTY CHARACTER*4 UPPLTY 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='DPJB' ISUBN2='CP ' IWRITE='OFF' IR=0 IF(NPERC.GT.0)THEN DO410I=1,NPERC XPERC(I)=0.0 410 CONTINUE ENDIF C C ************************************************** C ** STEP 1-- ** C ** IF SET PPCC Y PLOT DATA POINTS COMMAND ** C ** WAS ENTERED, THIN DATA SET BY COMPUTING ** C ** PERCENTILES OF THE DATA. ONLY DO THIS FOR ** C ** THE UNCENSORED CASE. ** C ************************************************** C ISTEPN='1' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBCP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IPPCDP.GT.0 .AND. ICENSO.EQ.'OFF')THEN NP=MAX(20,IPPCDP) NP=MIN(NP,N) CALL SORT(Y,N,Y2) ASTRT=0.0 ASTOP=100.0 AINC=(ASTOP - ASTRT)/REAL(NP+1) IWRITE='OFF' DO100I=1,NP P100=ASTRT + REAL(I)*AINC CALL PERCEN(P100,Y2,N,IWRITE,X2,MAXOBV, 1 APERC,IBUGG3,IERROR) X2(I)=APERC 100 CONTINUE N=NP DO105I=1,N Y2(I)=X2(I) 105 CONTINUE ELSE DO110I=1,N Y2(I)=Y(I) 110 CONTINUE ENDIF IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'JBCP')THEN WRITE(ICOUT,113)IPPCDP,NP,N 113 FORMAT(' IPPCDP, NP, N = ',3I8) CALL DPWRST('XXX','BUG ') DO117I=1,N WRITE(ICOUT,118)I,Y2(I) 118 FORMAT(' I, Y2(I) = ',I8,G15.7) CALL DPWRST('XXX','BUG ') 117 CONTINUE ENDIF C IF(ICENSO.EQ.'ON')THEN CALL DISTIN(X,N,IWRITE,X2,NDIST,IBUGG3,IERROR) IF(NDIST.EQ.1)THEN DO1102I=1,N X(I)=1.0 1102 CONTINUE ELSEIF(NDIST.EQ.2)THEN IF(X2(1).EQ.1.0 .OR. X2(2).EQ.1.0)THEN DO1103I=1,N IF(X(I).NE.1.0)X(I)=0.0 1103 CONTINUE ELSE ATEMP1=MIN(X2(1),X2(2)) ATEMP2=MAX(X2(1),X2(2)) DO1108I=1,N IF(X(I).EQ.ATEMP1)X(I)=1.0 IF(X(I).EQ.ATEMP2)X(I)=0.0 1108 CONTINUE ENDIF ELSE WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1104) 1104 FORMAT('***** ERROR IN JACKNIFE/BOOTSTRAP PROBABILITY PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1105) 1105 FORMAT(' FOR CENSORED DATA, THE CENSORING VARIABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1106) 1106 FORMAT(' SHOULD CONTAIN AT MOST TWO DISTINCT VALUES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1107)NDIST 1107 FORMAT(' ',I8,' DISTINCT VALUES FOUND.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF CALL SORTC(Y2,X,N,Y2,X) CALL UNIME3(N,X2,X,IMETHD) ELSE CALL SORT(Y2,N,Y2) CALL UNIMED(N,X2) ENDIF C XMIN=Y2(1) C C **************************************************** C ** STEP 2-- ** C ** EXTRACT RANGE FOR SHAPE PARAMETER ** C **************************************************** C ISTEPN='2' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBCP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICNT=0 CORRMX=CPUMIN NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 C IF(ICASPL.EQ.'WECP' .OR. ICASPL.EQ.'IWCP' .OR. 1 ICASPL.EQ.'GACP' .OR. ICASPL.EQ.'GICP' .OR. 1 ICASPL.EQ.'LGCP' .OR. ICASPL.EQ.'GECP' .OR. 1 ICASPL.EQ.'EECP' .OR. ICASPL.EQ.'FLCP' .OR. 1 ICASPL.EQ.'WACP' .OR. ICASPL.EQ.'E2CP' .OR. 1 ICASPL.EQ.'DWCP' .OR. ICASPL.EQ.'GVCP' .OR. 1 ICASPL.EQ.'GZCP' .OR. ICASPL.EQ.'DGCP' .OR. 1 ICASPL.EQ.'PACP' .OR. ICASPL.EQ.'P2CP' .OR. 1 ICASPL.EQ.'G5CP' 1 )THEN C ALOWLM=0. AUPPLM=CPUMAX IF(ICASPL.EQ.'WECP')THEN ADEF1=1.0 ADEF2=50.0 IDIST='WEIBULL' ELSEIF(ICASPL.EQ.'GACP')THEN ADEF1=1.0 ADEF2=50.0 IDIST='GAMMA' ELSEIF(ICASPL.EQ.'GICP')THEN ADEF1=0.5 ADEF2=25.0 IDIST='INVERTED GAMMA' ELSEIF(ICASPL.EQ.'LGCP')THEN ADEF1=0.5 ADEF2=25.0 IDIST='LOG GAMMA' ELSEIF(ICASPL.EQ.'IWCP')THEN ADEF1=0.5 ADEF2=10.0 IDIST='INVERTED WEIBULL' ELSEIF(ICASPL.EQ.'GECP')THEN ALOWLM=CPUMIN ADEF1=-3.0 ADEF2=3.0 IDIST='GENERALIZED PARETO' ELSEIF(ICASPL.EQ.'EECP')THEN ADEF1=0.1 ADEF2=10.0 IDIST='GEOMETRIC EXTREME EXPONENTIAL' ELSEIF(ICASPL.EQ.'FLCP')THEN ADEF1=1.0 ADEF2=50.0 IDIST='FATIGUE LIFE' ELSEIF(ICASPL.EQ.'WACP')THEN ADEF1=0.5 ADEF2=25.0 IDIST='WALD' ELSEIF(ICASPL.EQ.'E2CP')THEN ADEF1=1.0 ADEF2=50.0 IDIST='FRECHET' ELSEIF(ICASPL.EQ.'PACP' .OR. ICASPL.EQ.'P2CP')THEN ADEF1=0.2 ADEF2=5.0 IDIST='PARETO' IF(ICASPL.EQ.'P2CP')IDIST='PARETO SECOND KIND' C IHP='A ' IHP2=' ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF1=1.0 CALL PARCH2(IHP,IHP2,IDIST,A1,ADEF1,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(A1.LE.0.0)A1=1.0 ELSEIF(ICASPL.EQ.'DWCP')THEN ADEF1=0.5 ADEF2=10.0 IDIST='DOUBLE WEIBULL' ELSEIF(ICASPL.EQ.'DGCP')THEN ADEF1=0.5 ADEF2=10.0 IDIST='DOUBLE GAMMA' ELSEIF(ICASPL.EQ.'GVCP')THEN ALOWLM=CPUMIN ADEF1=-5.0 ADEF2=5.0 IDIST='GENERALIZED EXTREME VALUE' ELSEIF(ICASPL.EQ.'GZCP')THEN AUPPLM=5.0 ADEF1=0.1 ADEF2=2.5 IDIST='GENERALIZED HALF LOGISTIC' ELSEIF(ICASPL.EQ.'G5CP')THEN ALOWLM=CPUMIN ADEF1=-5.0 ADEF2=5.0 IDIST='GENERALIZED LOGISTIC TYPE 5' ENDIF IHP='GAMM' IHP2='A1 ' LOWLTY='> ' UPPLTY='<= ' CALL PARCH2(IHP,IHP2,IDIST,VALUE1,ADEF1,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')VALUE1=ADEF1 C IHP='GAMM' IHP2='A2 ' CALL PARCH2(IHP,IHP2,IDIST,VALUE2,ADEF2,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')VALUE2=ADEF2 ELSEIF(ICASPL.EQ.'LNCP')THEN C IDIST='LOGNORMAL' IHP='SIGM' IHP2='A1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,VALUE1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')VALUE1=1.0 C IHP='SIGM' IHP2='A2 ' ADEF=25.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')VALUE2=25.0 ELSEIF(ICASPL.EQ.'LACP' .OR. ICASPL.EQ.'SDCP')THEN C IF(ICASPL.EQ.'LACP')THEN IDIST='TUKEY-LAMBDA' ADEF1=-2.0 ADEF2=2.0 ELSEIF(ICASPL.EQ.'SDCP')THEN IDIST='SKEW DOUBLE EXPONENTIAL' ADEF1=0.0 ADEF2=10.0 ENDIF IHP='LAMB' IHP2='DA1 ' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' CALL PARCH2(IHP,IHP2,IDIST,VALUE1,ADEF1,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')VALUE1=ADEF C IHP='LAMB' IHP2='DA2 ' CALL PARCH2(IHP,IHP2,IDIST,VALUE2,ADEF2,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')VALUE2=ADEF ELSEIF(ICASPL.EQ.'TCP' .OR. ICASPL.EQ.'CSCP' .OR. 1 ICASPL.EQ.'CHCP' .OR. ICASPL.EQ.'FTCP')THEN C IF(ICASPL.EQ.'TCP')IDIST='T' IF(ICASPL.EQ.'CSCP')IDIST='CHI-SQUARE' IF(ICASPL.EQ.'CHCP')IDIST='CHI' IF(ICASPL.EQ.'FTCP')IDIST='FOLDED T' IHP='NU1 ' IHP2=' ' ALOWLM=1. AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' ADEF=1.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GAMMA1=1.0 VALUE1=REAL(INT(VALUE1+0.5)) C IHP='NU2 ' IHP2=' ' ADEF=50.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')VALUE2=50.0 IVAL1=INT(VALUE1+0.5) IVAL2=INT(VALUE2+0.5) ITEMP=ABS(IVAL2-IVAL1)+1 IF(ITEMP.LE.NUMDIS)NUMDIS=ITEMP ELSEIF(ICASPL.EQ.'BRCP')THEN IDIST='BRADFORD' IHP='BETA' IHP2='1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,VALUE1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='BETA' IHP2='2 ' ADEF=25.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ELSEIF(ICASPL.EQ.'RECP' .OR. ICASPL.EQ.'VMCP')THEN IF(ICASPL.EQ.'RECP')THEN IDIST='RECIPROCAL' ALOWLM=1.0 LOWLTY='> ' ADEF1=1.5 ADEF2=20.0 ELSEIF(ICASPL.EQ.'VMCP')THEN IDIST='VON MISES' ALOWLM=0.0 LOWLTY='>= ' ADEF1=0.5 ADEF2=25.0 ENDIF IHP='B1 ' IHP2=' ' AUPPLM=CPUMAX UPPLTY='<= ' CALL PARCH2(IHP,IHP2,IDIST,VALUE1,ADEF1,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='B2 ' IHP2=' ' CALL PARCH2(IHP,IHP2,IDIST,VALUE2,ADEF2,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ELSEIF(ICASPL.EQ.'ERCP' .OR. ICASPL.EQ.'LXCP' .OR. 1 ICASPL.EQ.'GLCP' .OR. ICASPL.EQ.'G2CP' .OR. 1 ICASPL.EQ.'G3CP')THEN IF(ICASPL.EQ.'ERCP')THEN IDIST='ERROR' ADEF1=1.1 ADEF2=5.0 ALOWLM=1. ELSEIF(ICASPL.EQ.'LXCP')THEN IDIST='LOG LAPLACE' ADEF1=0.5 ADEF2=10.0 ALOWLM=0.0 ELSEIF(ICASPL.EQ.'GLCP')THEN IDIST='GENERALIZED LOGISTIC' ADEF1=0.2 ADEF2=5.0 ALOWLM=0.1 ELSEIF(ICASPL.EQ.'G2CP')THEN IDIST='GENERALIZED LOGISTIC TYPE 2' ADEF1=0.1 ADEF2=10.0 ALOWLM=0.0 ELSEIF(ICASPL.EQ.'G3CP')THEN IDIST='GENERALIZED LOGISTIC TYPE 3' ADEF1=0.1 ADEF2=10.0 ALOWLM=0.0 ENDIF IHP='ALPH' IHP2='A1 ' AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCH2(IHP,IHP2,IDIST,VALUE1,ADEF1,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) C IHP='ALPH' IHP2='A2 ' CALL PARCH2(IHP,IHP2,IDIST,VALUE2,ADEF2,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ELSEIF(ICASPL.EQ.'TRCP' .OR. ICASPL.EQ.'PFCP')THEN IF(ICASPL.EQ.'TRCP')THEN IDIST='TRIANGULAR' ADEF1=-1.0 ADEF2=1.0 ALOWLM=-1.0 AUPPLM=1.0 LOWLTY='>= ' ELSE IDIST='POWER' ADEF1=0.5 ADEF2=25.0 ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' ENDIF UPPLTY='<= ' IHP='C1 ' IHP2=' ' CALL PARCH2(IHP,IHP2,IDIST,VALUE1,ADEF1,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='C2 ' IHP2=' ' CALL PARCH2(IHP,IHP2,IDIST,VALUE2,ADEF2,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ELSEIF(ICASPL.EQ.'PNCP' .OR. ICASPL.EQ.'WCCP')THEN IF(ICASPL.EQ.'PNCP')THEN IDIST='POWER NORMAL' AUPPLM=CPUMAX ADEF1=1.0 ADEF2=50.0 LOWLTY='> ' UPPLTY='<= ' ELSEIF(ICASPL.EQ.'WCCP')THEN IDIST='WRAPPED CAUCHY' AUPPLM=1.0 ADEF1=0.0 ADEF2=0.99 LOWLTY='>= ' UPPLTY='< ' ENDIF IHP='P1 ' IHP2=' ' ALOWLM=0. CALL PARCH2(IHP,IHP2,IDIST,VALUE1,ADEF1,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='P2 ' IHP2=' ' CALL PARCH2(IHP,IHP2,IDIST,VALUE2,ADEF2,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ELSEIF(ICASPL.EQ.'LLCP')THEN IDIST='LOG-LOGISTIC' IHP='DELT' IHP2='A1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.2 CALL PARCH2(IHP,IHP2,IDIST,VALUE1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='DELT' IHP2='A2 ' ADEF=25.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ELSEIF(ICASPL.EQ.'ADCP')THEN IDIST='ASYMMETRIC LAPLACE' IF(IADEDF.EQ.'K')THEN IHP='K1 ' IHP2=' ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' ADEF=0.2 CALL PARCH2(IHP,IHP2,IDIST,VALUE1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='K2 ' IHP2=' ' ADEF=10.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ELSE IHP='MU1 ' IHP2=' ' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' ADEF=-5.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='MU2 ' IHP2=' ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ENDIF ELSE PPA0=0.0 PPA1=1.0 SHAPE1=1.0 CORRMX=0.0 GOTO9000 ENDIF C C **************************************************** C ** STEP 3-- ** C ** GENERATE PPCC PLOT FOR GIVEN DISTRIBUTION ** C **************************************************** C ISTEPN='3' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBCP')THEN CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) WRITE(ICOUT,213)VALUE1,VALUE2 213 FORMAT(' VALUE1, VALUE2 = ',2G15.7) CALL DPWRST('XXX','BUG ') ENDIF C ANUMDI=NUMDIS C DO1800IDIS=1,NUMDIS C ICNT=0 AIDIS=IDIS VALUE=VALUE1+((AIDIS-1.0)/(ANUMDI-1.0))*(VALUE2-VALUE1) C IF(ICASPL.EQ.'WECP')THEN DO1011I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1011 ICNT=ICNT+1 CALL WEIPPF(X2(I),VALUE,MINMAX,X3(ICNT)) Y3(ICNT)=Y2(I) 1011 CONTINUE C ELSEIF(ICASPL.EQ.'LNCP')THEN DO1021I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1021 ICNT=ICNT+1 CALL LGNPPF(X2(I),VALUE,X3(ICNT)) Y3(ICNT)=Y2(I) 1021 CONTINUE ELSEIF(ICASPL.EQ.'GACP')THEN DO1031I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1031 ICNT=ICNT+1 CALL GAMPPF(X2(I),VALUE,X3(ICNT)) Y3(ICNT)=Y2(I) 1031 CONTINUE ELSEIF(ICASPL.EQ.'GICP')THEN DO1041I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1041 ICNT=ICNT+1 CALL IGAPPF(X2(I),VALUE,X3(ICNT)) Y3(ICNT)=Y2(I) 1041 CONTINUE ELSEIF(ICASPL.EQ.'LGCP')THEN DO1051I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1051 ICNT=ICNT+1 CALL LGAPPF(X2(I),VALUE,ILGADF,X3(ICNT)) Y3(ICNT)=Y2(I) 1051 CONTINUE ELSEIF(ICASPL.EQ.'IWCP')THEN DO1061I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1061 ICNT=ICNT+1 CALL IWEPPF(X2(I),VALUE,X3(ICNT)) Y3(ICNT)=Y2(I) 1061 CONTINUE ELSEIF(ICASPL.EQ.'GECP')THEN DO1071I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1071 ICNT=ICNT+1 CALL GEPPPF(X2(I),VALUE,MINMAX,IGEPDF,X3(ICNT)) Y3(ICNT)=Y2(I) 1071 CONTINUE ELSEIF(ICASPL.EQ.'TCP')THEN DO1081I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1081 ICNT=ICNT+1 CALL TPPF(X2(I),VALUE,X3(ICNT)) Y3(ICNT)=Y2(I) 1081 CONTINUE ELSEIF(ICASPL.EQ.'CSCP')THEN DO1091I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1091 ICNT=ICNT+1 CALL CHSPPF(X2(I),INT(VALUE+0.5),X3(ICNT)) Y3(ICNT)=Y2(I) 1091 CONTINUE ELSEIF(ICASPL.EQ.'CHCP')THEN DO1101I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1101 ICNT=ICNT+1 CALL CHPPF(X2(I),INT(VALUE+0.5),X3(ICNT)) Y3(ICNT)=Y2(I) 1101 CONTINUE ELSEIF(ICASPL.EQ.'FLCP')THEN DO1111I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1111 ICNT=ICNT+1 CALL FLPPF(X2(I),VALUE,X3(ICNT)) Y3(ICNT)=Y2(I) 1111 CONTINUE ELSEIF(ICASPL.EQ.'WACP')THEN DO1121I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1121 ICNT=ICNT+1 CALL WALPPF(X2(I),VALUE,X3(ICNT)) Y3(ICNT)=Y2(I) 1121 CONTINUE ELSEIF(ICASPL.EQ.'E2CP')THEN DO1131I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1131 ICNT=ICNT+1 CALL EV2PPF(X2(I),VALUE,MINMAX,X3(ICNT)) Y3(ICNT)=Y2(I) 1131 CONTINUE ELSEIF(ICASPL.EQ.'EECP')THEN DO1141I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1141 ICNT=ICNT+1 CALL GEEPPF(X2(I),VALUE,X3(ICNT)) Y3(ICNT)=Y2(I) 1141 CONTINUE ELSEIF(ICASPL.EQ.'LACP')THEN DO1151I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1151 ICNT=ICNT+1 CALL LAMPPF(X2(I),VALUE,X3(ICNT)) Y3(ICNT)=Y2(I) 1151 CONTINUE ELSEIF(ICASPL.EQ.'PACP')THEN A=A1 IF(A.GT.XMIN)A=XMIN DO1161I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1161 ICNT=ICNT+1 CALL PARPPF(X2(I),VALUE,A,X3(ICNT)) Y3(ICNT)=Y2(I) 1161 CONTINUE ELSEIF(ICASPL.EQ.'P2CP')THEN A=A1 IF(A.GT.XMIN)A=XMIN DO1166I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1166 ICNT=ICNT+1 CALL PA2PPF(X2(I),VALUE,A,X3(ICNT)) Y3(ICNT)=Y2(I) 1166 CONTINUE ELSEIF(ICASPL.EQ.'BRCP')THEN DO1171I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1171 ICNT=ICNT+1 CALL BRAPPF(X2(I),VALUE,X3(ICNT)) Y3(ICNT)=Y2(I) 1171 CONTINUE ELSEIF(ICASPL.EQ.'RECP')THEN DO1181I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1181 ICNT=ICNT+1 CALL RECPPF(X2(I),VALUE,X3(ICNT)) Y3(ICNT)=Y2(I) 1181 CONTINUE ELSEIF(ICASPL.EQ.'ERCP')THEN DO1191I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1191 ICNT=ICNT+1 X2IN=X2(I) CALL ERRPPF(X2IN,VALUE,X3(ICNT)) Y3(ICNT)=Y2(I) 1191 CONTINUE ELSEIF(ICASPL.EQ.'TRCP')THEN ZLOWLM=-1.0 ZUPPLM=1.0 DO1201I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1201 ICNT=ICNT+1 CALL TRIPPF(X2(I),VALUE,ZLOWLM,ZUPPLM,X3(ICNT)) Y3(ICNT)=Y2(I) 1201 CONTINUE ELSEIF(ICASPL.EQ.'LLCP')THEN DO1211I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1211 ICNT=ICNT+1 CALL LLGPPF(X2(I),VALUE,X3(ICNT)) Y3(ICNT)=Y2(I) 1211 CONTINUE ELSEIF(ICASPL.EQ.'DWCP')THEN DO1221I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1221 ICNT=ICNT+1 CALL DWEPPF(X2(I),VALUE,X3(ICNT)) Y3(ICNT)=Y2(I) 1221 CONTINUE ELSEIF(ICASPL.EQ.'FTCP')THEN DO1231I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1231 ICNT=ICNT+1 CALL FTPPF(X2(I),INT(VALUE+0.5),X3(ICNT)) Y3(ICNT)=Y2(I) 1231 CONTINUE ELSEIF(ICASPL.EQ.'SDCP')THEN DO1241I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1241 ICNT=ICNT+1 CALL SDEPPF(X2(I),VALUE,X3(ICNT)) Y3(ICNT)=Y2(I) 1241 CONTINUE ELSEIF(ICASPL.EQ.'GVCP')THEN DO1251I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1251 ICNT=ICNT+1 CALL GEVPPF(X2(I),VALUE,MINMAX,X3(ICNT)) Y3(ICNT)=Y2(I) 1251 CONTINUE ELSEIF(ICASPL.EQ.'LXCP')THEN DO1261I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1261 ICNT=ICNT+1 CALL LDEPPF(X2(I),VALUE,X3(ICNT)) Y3(ICNT)=Y2(I) 1261 CONTINUE ELSEIF(ICASPL.EQ.'ADCP')THEN DO1271I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1271 ICNT=ICNT+1 CALL ADEPPF(X2(I),VALUE,IADEDF,X3(ICNT)) Y3(ICNT)=Y2(I) 1271 CONTINUE ELSEIF(ICASPL.EQ.'PFCP')THEN DO1281I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1281 ICNT=ICNT+1 CALL POWPPF(X2(I),VALUE,X3(ICNT)) Y3(ICNT)=Y2(I) 1281 CONTINUE ELSEIF(ICASPL.EQ.'VMCP')THEN DO1291I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1291 ICNT=ICNT+1 CALL VONPPF(X2(I),VALUE,X3(ICNT)) Y3(ICNT)=Y2(I) 1291 CONTINUE ELSEIF(ICASPL.EQ.'WCCP')THEN DO1301I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1301 ICNT=ICNT+1 CALL WCAPPF(X2(I),VALUE,X3(ICNT)) Y3(ICNT)=Y2(I) 1301 CONTINUE ELSEIF(ICASPL.EQ.'GLCP')THEN DO1311I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1311 ICNT=ICNT+1 CALL GLOPPF(X2(I),VALUE,X3(ICNT)) Y3(ICNT)=Y2(I) 1311 CONTINUE ELSEIF(ICASPL.EQ.'GZCP')THEN DO1321I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1321 ICNT=ICNT+1 CALL HFLPPF(X2(I),VALUE,X3(ICNT)) Y3(ICNT)=Y2(I) 1321 CONTINUE ELSEIF(ICASPL.EQ.'DGCP')THEN DO1331I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1331 ICNT=ICNT+1 CALL DGAPPF(X2(I),VALUE,X3(ICNT)) Y3(ICNT)=Y2(I) 1331 CONTINUE ELSEIF(ICASPL.EQ.'PNCP')THEN S=1.0 DO1341I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1341 ICNT=ICNT+1 CALL PNRPPF(X2(I),VALUE,S,X3(ICNT)) Y3(ICNT)=Y2(I) 1341 CONTINUE ELSEIF(ICASPL.EQ.'G2CP')THEN DO1351I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1351 ICNT=ICNT+1 CALL GL2PPF(DBLE(X2(I)),DBLE(VALUE),DPPF) X3(ICNT)=REAL(DPPF) Y3(ICNT)=Y2(I) 1351 CONTINUE ELSEIF(ICASPL.EQ.'G3CP')THEN DO1361I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1361 ICNT=ICNT+1 CALL GL3PPF(DBLE(X2(I)),DBLE(VALUE),DPPF) X3(ICNT)=REAL(DPPF) Y3(ICNT)=Y2(I) 1361 CONTINUE ELSEIF(ICASPL.EQ.'G5CP')THEN XPAR(1)=0.0D0 XPAR(2)=1.0D0 XPAR(3)=DBLE(VALUE) DO1371I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1371 ICNT=ICNT+1 DPPF=QUAGLO(DBLE(X2(I)),XPAR) X3(ICNT)=REAL(DPPF) Y3(ICNT)=Y2(I) 1371 CONTINUE ENDIF C C ************************************************** C ** STEP 4-- ** C ** COMPUTE MAXIMUM PPCC TO FIND VALUE OF SHAPE ** C ** PARAMETER AND THEN ** C ** COMPUTE FITTED LINE TO PROBABILITY PLOT ** C ** TO ESTIMATE LOCATION AND SCALE ** C ************************************************** C ISTEPN='4' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBCP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C N2=ICNT C IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBCP')THEN WRITE(ICOUT,2001)N2 2001 FORMAT('N2 = ',I8) CALL DPWRST('XXX','BUG ') IF(N2.GE.1)THEN DO2110I=1,N2 WRITE(ICOUT,2011)I,Y3(I),X3(I) 2011 FORMAT('I,Y3(I),X3(I) = ',I8,2G15.7) CALL DPWRST('XXX','BUG ') 2110 CONTINUE ENDIF ENDIF C CALL CORR(Y3,X3,N2,IWRITE,CC,IBUGG3,IERROR) C IF(CC.GT.CORRMX)THEN CORRMX=CC SHAPE1=VALUE CALL LINFI2(Y3,X3,N2, 1 PPA0,PPA1, 1 ISUBRO,IBUGG3,IERROR) ENDIF C 1800 CONTINUE C C ************************************************** C ** STEP 5-- ** C ** COMPUTE SELECTED PERCENTILES ** C ************************************************** C ISTEPN='5' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBCP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NPERC.GT.0)THEN IF(ICASPL.EQ.'WECP')THEN DO4110I=1,NPERC QPTEMP=QP(I)/100.0 CALL WEIPPF(QPTEMP,SHAPE1,MINMAX,XPERC(I)) XPERC(I)=PPA0 + PPA1*XPERC(I) 4110 CONTINUE ELSEIF(ICASPL.EQ.'LNCP')THEN DO4120I=1,NPERC QPTEMP=QP(I)/100.0 CALL LGNPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0 + PPA1*XPERC(I) 4120 CONTINUE ELSEIF(ICASPL.EQ.'GACP')THEN DO4130I=1,NPERC QPTEMP=QP(I)/100.0 CALL GAMPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0 + PPA1*XPERC(I) 4130 CONTINUE ELSEIF(ICASPL.EQ.'GICP')THEN DO4140I=1,NPERC QPTEMP=QP(I)/100.0 CALL IGAPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0 + PPA1*XPERC(I) 4140 CONTINUE ELSEIF(ICASPL.EQ.'LGCP')THEN DO4150I=1,NPERC QPTEMP=QP(I)/100.0 CALL LGAPPF(QPTEMP,SHAPE1,ILGADF,XPERC(I)) XPERC(I)=PPA0 + PPA1*XPERC(I) 4150 CONTINUE ELSEIF(ICASPL.EQ.'GECP')THEN DO4160I=1,NPERC QPTEMP=QP(I)/100.0 CALL GEPPPF(QPTEMP,SHAPE1,MINMAX,IGEPDF,XPERC(I)) XPERC(I)=PPA0 + PPA1*XPERC(I) 4160 CONTINUE ELSEIF(ICASPL.EQ.'IWCP')THEN DO4170I=1,NPERC QPTEMP=QP(I)/100.0 CALL IWEPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0 + PPA1*XPERC(I) 4170 CONTINUE ELSEIF(ICASPL.EQ.'CSCP')THEN DO4180I=1,NPERC QPTEMP=QP(I)/100.0 CALL CHSPPF(QPTEMP,INT(SHAPE1+0.5),XPERC(I)) XPERC(I)=PPA0 + PPA1*XPERC(I) 4180 CONTINUE ELSEIF(ICASPL.EQ.'CHCP')THEN DO4190I=1,NPERC QPTEMP=QP(I)/100.0 CALL CHPPF(QPTEMP,INT(SHAPE1+0.5),XPERC(I)) XPERC(I)=PPA0 + PPA1*XPERC(I) 4190 CONTINUE ELSEIF(ICASPL.EQ.'TCP')THEN DO4200I=1,NPERC QPTEMP=QP(I)/100.0 CALL TPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0 + PPA1*XPERC(I) 4200 CONTINUE ELSEIF(ICASPL.EQ.'EECP')THEN DO4210I=1,NPERC QPTEMP=QP(I)/100.0 CALL GEEPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0 + PPA1*XPERC(I) 4210 CONTINUE ELSEIF(ICASPL.EQ.'FLCP')THEN DO4220I=1,NPERC QPTEMP=QP(I)/100.0 CALL FLPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0 + PPA1*XPERC(I) 4220 CONTINUE ELSEIF(ICASPL.EQ.'E2CP')THEN DO4230I=1,NPERC QPTEMP=QP(I)/100.0 CALL EV2PPF(QPTEMP,SHAPE1,MINMAX,XPERC(I)) XPERC(I)=PPA0 + PPA1*XPERC(I) 4230 CONTINUE ELSEIF(ICASPL.EQ.'WACP')THEN DO4240I=1,NPERC QPTEMP=QP(I)/100.0 CALL WALPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0 + PPA1*XPERC(I) 4240 CONTINUE ELSEIF(ICASPL.EQ.'PACP')THEN DO4250I=1,NPERC QPTEMP=QP(I)/100.0 CALL PARPPF(QPTEMP,SHAPE1,XMIN,XPERC(I)) XPERC(I)=PPA0 + PPA1*XPERC(I) 4250 CONTINUE ELSEIF(ICASPL.EQ.'P2CP')THEN DO4255I=1,NPERC QPTEMP=QP(I)/100.0 CALL PA2PPF(QPTEMP,SHAPE1,XMIN,XPERC(I)) XPERC(I)=PPA0 + PPA1*XPERC(I) 4255 CONTINUE ELSEIF(ICASPL.EQ.'LACP')THEN DO4260I=1,NPERC QPTEMP=QP(I)/100.0 CALL LAMPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0 + PPA1*XPERC(I) 4260 CONTINUE ELSEIF(ICASPL.EQ.'BRCP')THEN DO4270I=1,NPERC QPTEMP=QP(I)/100.0 CALL BRAPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0 + PPA1*XPERC(I) 4270 CONTINUE ELSEIF(ICASPL.EQ.'RECP')THEN DO4280I=1,NPERC QPTEMP=QP(I)/100.0 CALL RECPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0 + PPA1*XPERC(I) 4280 CONTINUE ELSEIF(ICASPL.EQ.'ERCP')THEN DO4290I=1,NPERC QPTEMP=QP(I)/100.0 CALL ERRPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0 + PPA1*XPERC(I) 4290 CONTINUE ELSEIF(ICASPL.EQ.'TRCP')THEN ZLOWLM=PPA0 ZUPPLM=PPA0 + PPA1 DO4300I=1,NPERC QPTEMP=QP(I)/100.0 CALL TRIPPF(QPTEMP,SHAPE1,ZLOWLM,ZUPPLM,XPERC(I)) CCCCC XPERC(I)=PPA0 + PPA1*XPERC(I) 4300 CONTINUE ELSEIF(ICASPL.EQ.'LLCP')THEN DO4310I=1,NPERC QPTEMP=QP(I)/100.0 CALL LLGPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0 + PPA1*XPERC(I) 4310 CONTINUE ELSEIF(ICASPL.EQ.'DWCP')THEN DO4320I=1,NPERC QPTEMP=QP(I)/100.0 CALL DWEPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0 + PPA1*XPERC(I) 4320 CONTINUE ELSEIF(ICASPL.EQ.'FTCP')THEN DO4330I=1,NPERC QPTEMP=QP(I)/100.0 CALL FTPPF(QPTEMP,INT(SHAPE1+0.5),XPERC(I)) XPERC(I)=PPA0 + PPA1*XPERC(I) 4330 CONTINUE ELSEIF(ICASPL.EQ.'SDCP')THEN DO4340I=1,NPERC QPTEMP=QP(I)/100.0 CALL SDEPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0 + PPA1*XPERC(I) 4340 CONTINUE ELSEIF(ICASPL.EQ.'ADCP')THEN DO4350I=1,NPERC QPTEMP=QP(I)/100.0 CALL ADEPPF(QPTEMP,SHAPE1,IADEDF,XPERC(I)) XPERC(I)=PPA0 + PPA1*XPERC(I) 4350 CONTINUE ELSEIF(ICASPL.EQ.'GVCP')THEN DO4360I=1,NPERC QPTEMP=QP(I)/100.0 CALL GEVPPF(QPTEMP,SHAPE1,MINMAX,XPERC(I)) XPERC(I)=PPA0 + PPA1*XPERC(I) 4360 CONTINUE ELSEIF(ICASPL.EQ.'LXCP')THEN DO4370I=1,NPERC QPTEMP=QP(I)/100.0 CALL LDEPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0 + PPA1*XPERC(I) 4370 CONTINUE ELSEIF(ICASPL.EQ.'PFCP')THEN DO4380I=1,NPERC QPTEMP=QP(I)/100.0 CALL POWPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0 + PPA1*XPERC(I) 4380 CONTINUE ELSEIF(ICASPL.EQ.'VMCP')THEN DO4390I=1,NPERC QPTEMP=QP(I)/100.0 CALL VONPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0 + PPA1*XPERC(I) 4390 CONTINUE ELSEIF(ICASPL.EQ.'WCCP')THEN DO4400I=1,NPERC QPTEMP=QP(I)/100.0 CALL WCAPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0 + PPA1*XPERC(I) 4400 CONTINUE ELSEIF(ICASPL.EQ.'GLCP')THEN DO4410I=1,NPERC QPTEMP=QP(I)/100.0 CALL GLOPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0 + PPA1*XPERC(I) 4410 CONTINUE ELSEIF(ICASPL.EQ.'GZCP')THEN DO4420I=1,NPERC QPTEMP=QP(I)/100.0 CALL HFLPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0 + PPA1*XPERC(I) 4420 CONTINUE ELSEIF(ICASPL.EQ.'DGCP')THEN DO4430I=1,NPERC QPTEMP=QP(I)/100.0 CALL DGAPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0 + PPA1*XPERC(I) 4430 CONTINUE ELSEIF(ICASPL.EQ.'PNCP')THEN S=1.0 DO4440I=1,NPERC QPTEMP=QP(I)/100.0 CALL PNRPPF(QPTEMP,SHAPE1,S,XPERC(I)) XPERC(I)=PPA0 + PPA1*XPERC(I) 4440 CONTINUE ELSEIF(ICASPL.EQ.'G2CP')THEN DO4450I=1,NPERC QPTEMP=QP(I)/100.0 CALL GL2PPF(DBLE(QPTEMP),DBLE(SHAPE1),DPPF) XPERC(I)=REAL(DPPF) XPERC(I)=PPA0 + PPA1*XPERC(I) 4450 CONTINUE ELSEIF(ICASPL.EQ.'G3CP')THEN DO4460I=1,NPERC QPTEMP=QP(I)/100.0 CALL GL3PPF(DBLE(QPTEMP),DBLE(SHAPE1),DPPF) XPERC(I)=REAL(DPPF) XPERC(I)=PPA0 + PPA1*XPERC(I) 4460 CONTINUE ELSEIF(ICASPL.EQ.'G5CP')THEN XPAR(1)=DBLE(PPA0) XPAR(2)=DBLE(PPA1) XPAR(3)=DBLE(SHAPE1) DO4470I=1,NPERC QPTEMP=QP(I)/100.0 CALL GL3PPF(DBLE(QPTEMP),DBLE(SHAPE1),DPPF) DPPF=QUAGLO(DBLE(QPTEMP),XPAR) XPERC(I)=REAL(DPPF) XPERC(I)=PPA0 + PPA1*XPERC(I) 4470 CONTINUE ENDIF ENDIF C ******************* C ** STEP 90-- ** C ** EXIT ** C ******************* C 9000 CONTINUE C RETURN END SUBROUTINE DPJBC2(Y,X,N, 1ICASPL,ICENSO,IMETHD,IPPCDP,MAXOBV,MINMAX, 1Y2,X2,Y3,X3, 1NHOR1,NHOR2, 1QP,XPERC,NPERC, 1PPA0,PPA1,SHAPE1,SHAPE2,CORRMX, 1IBUGG3,ISUBRO,IERROR) C C PURPOSE--FOR A GIVEN BOOTSTRAP SAMPLE, GENERATE THE PPCC PLOT C TO ESTIMATE THE TWO SHAPE PARAMETER(S) AND THEN THE C PROBABILITY PLOT TO ESTIMATE LOCATION (PPA0) AND C SCALE (PPA1). BOTH UNCENSORED AND CENSORED C PLOTS ARE SUPPORTED. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2005/1 C ORIGINAL VERSION--JANUARY 2005. C C SUPPORTED DISTRIBUTIONS ARE: C C FOLLOWING ARE ACTIVE C 1) G-AND-H C 2) INVERSE GAUSSIAN C 3) GENERALIZED GAMMA C 4) BETA C 5) F C 6) FOLDED NORMAL C 7) GENERALIZED TUKEY LAMBDA C 8) BETA NORMAL C C FOLLOWING ARE DISTRIBUTIONS THAT COULD POTENTIALLY C BE ADDED C 9) GOMPERTZ C 10) EXPONENTIAL POWER C 11) POWER LOGNORMAL C 12) ALPHA C 13) EXPONENTIATED WEIBULL C 14) JOHNSON SB C 15) JOHNSON SU C 16) TWO-SIDED POWER C 17) RECIPROCAL INVERSE GAUSSIAN C 18) SKEW T C 19) INVERTED BETA C 20) LOG-SKEW-NORMAL C 21) NON-CENTRAL T C 22) NON-CENTRAL CHI-SQUARE C 23) FOLDED CAUCHY C 24) TRUNCATED EXPONENTIAL C (ASSUME TRUNCATION POINT X0 IS KNOWN) C 25) GOMPERTZ-MAKEHAM (FOR MEEKER REPARAMETERIZATION TO C CASE WITH TWO SHAPE PARAMETERS AND SCALE PARAMETER) C 26) GENERALIZED ASYMMETRIC LAPLACE C 27) GENERALIZED MCLEISH C NOTE: STILL BEING TESTED C 28) HYPERBOLIC (NOT WORKING) C C C C ALL OF THESE SUPPORT BOTH CENSORED AND UNCENSORED DATA C C------------------------------------------------------------------ C CHARACTER*4 ICASPL CHARACTER*4 ICENSO CHARACTER*4 IMETHD CHARACTER*4 IBUGG3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 IGLDDF C DOUBLE PRECISION DP DOUBLE PRECISION DPPF C DIMENSION Y(*) DIMENSION X(*) DIMENSION Y2(*) DIMENSION X2(*) DIMENSION Y3(*) DIMENSION X3(*) DIMENSION QP(*) DIMENSION XPERC(*) C CHARACTER*30 IDIST C CHARACTER*4 IWRITE CHARACTER*4 ISTEPN CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 IHP CHARACTER*4 IHP2 CHARACTER*4 LOWLTY CHARACTER*4 UPPLTY C INCLUDE 'DPCOMC.INC' 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='DPJB' ISUBN2='C2 ' IWRITE='OFF' IR=0 IF(NPERC.GT.0)THEN DO410I=1,NPERC XPERC(I)=0.0 410 CONTINUE ENDIF C IGLDDF='FMKL' C C ************************************************** C ** STEP 1-- ** C ** IF SET PPCC Y PLOT DATA POINTS COMMAND ** C ** WAS ENTERED, THIN DATA SET BY COMPUTING ** C ** PERCENTILES OF THE DATA. ONLY DO THIS FOR ** C ** THE UNCENSORED CASE. ** C ************************************************** C ISTEPN='1' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBCP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IPPCDP.GT.0 .AND. ICENSO.EQ.'OFF')THEN NP=MAX(20,IPPCDP) NP=MIN(NP,N) CALL SORT(Y,N,Y2) ASTRT=0.0 ASTOP=100.0 AINC=(ASTOP - ASTRT)/REAL(NP+1) IWRITE='OFF' DO100I=1,NP P100=ASTRT + REAL(I)*AINC CALL PERCEN(P100,Y2,N,IWRITE,X2,MAXOBV, 1 APERC,IBUGG3,IERROR) X2(I)=APERC 100 CONTINUE N=NP DO105I=1,N Y2(I)=X2(I) 105 CONTINUE ELSE DO110I=1,N Y2(I)=Y(I) 110 CONTINUE ENDIF IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'JBCP')THEN WRITE(ICOUT,113)IPPCDP,NP,N 113 FORMAT(' IPPCDP, NP, N = ',3I8) CALL DPWRST('XXX','BUG ') DO117I=1,N WRITE(ICOUT,118)I,Y2(I) 118 FORMAT(' I, Y2(I) = ',I8,G15.7) CALL DPWRST('XXX','BUG ') 117 CONTINUE ENDIF C IF(ICENSO.EQ.'ON')THEN CALL DISTIN(X,N,IWRITE,X2,NDIST,IBUGG3,IERROR) IF(NDIST.EQ.1)THEN DO1102I=1,N X(I)=1.0 1102 CONTINUE ELSEIF(NDIST.EQ.2)THEN IF(X2(1).EQ.1.0 .OR. X2(2).EQ.1.0)THEN DO1103I=1,N IF(X(I).NE.1.0)X(I)=0.0 1103 CONTINUE ELSE ATEMP1=MIN(X2(1),X2(2)) ATEMP2=MAX(X2(1),X2(2)) DO1108I=1,N IF(X(I).EQ.ATEMP1)X(I)=1.0 IF(X(I).EQ.ATEMP2)X(I)=0.0 1108 CONTINUE ENDIF ELSE WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1104) 1104 FORMAT('***** ERROR IN JACKNIFE/BOOTSTRAP PROBABILITY PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1105) 1105 FORMAT(' FOR CENSORED DATA, THE CENSORING VARIABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1106) 1106 FORMAT(' SHOULD CONTAIN AT MOST TWO DISTINCT VALUES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1107)NDIST 1107 FORMAT(' ',I8,' DISTINCT VALUES FOUND.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF CALL SORTC(Y2,X,N,Y2,X) CALL UNIME3(N,X2,X,IMETHD) ELSE CALL SORT(Y2,N,Y2) CALL UNIMED(N,X2) ENDIF C C **************************************************** C ** STEP 2-- ** C ** EXTRACT RANGE FOR SHAPE PARAMETER ** C **************************************************** C ISTEPN='2' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBCP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICNT=0 CORRMX=CPUMIN C IF(ICASPL.EQ.'GHCP')THEN C NUMDI1=21 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=41 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 IF(NHOR1.GT.0)NUMDIS=NHOR1 C IDIST='G-H' IHP='G1 ' IHP2=' ' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' ADEF=-1.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='G2 ' IHP2=' ' ADEF=1.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='H1 ' IHP2=' ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' ADEF=0.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE3,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='H2 ' IHP2=' ' ADEF=1.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE4,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ELSEIF(ICASPL.EQ.'LDCP')THEN C NUMDI1=21 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=41 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 IF(NHOR1.GT.0)NUMDIS=NHOR1 C IDIST='GENERALIZED TUKEY-LAMBDA' IHP='LAMB' IHP2='DA31' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' ADEF=-5.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='LAMB' IHP2='DA32' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='LAMB' IHP2='DA41' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' ADEF=-5.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE3,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='LAMB' IHP2='DA42' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE4,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ELSEIF(ICASPL.EQ.'FCP')THEN C IDIST='F ' IHP='NU11' IHP2=' ' ILOWLM=1 IUPPLM=I1MACH(9) LOWLTY='>= ' UPPLTY='<= ' IDEF=1 CALL PARCI2(IHP,IHP2,IDIST,IVAL1,IDEF,ILOWLM,IUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='NU12' IHP2=' ' IDEF=25 CALL PARCI2(IHP,IHP2,IDIST,IVAL2,IDEF,ILOWLM,IUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='NU21' IHP2=' ' IDEF=1 CALL PARCI2(IHP,IHP2,IDIST,IVAL3,IDEF,ILOWLM,IUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='NU22' IHP2=' ' IDEF=25 CALL PARCI2(IHP,IHP2,IDIST,IVAL4,IDEF,ILOWLM,IUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 VALUE1=REAL(IVAL1) VALUE2=REAL(IVAL2) VALUE3=REAL(IVAL3) VALUE4=REAL(IVAL4) C NUMDI1=IVAL2 - IVAL1 + 1 IF(NHOR1.GT.0)NUMDI1=NHOR1 IF(NUMDI1.LT.10)NUMDI1=10 ANMDI1=NUMDI1 NUMDI2=IVAL4 - IVAL3 + 1 IF(NHOR2.GT.0)NUMDI2=NHOR2 IF(NUMDI2.LT.10)NUMDI2=10 ANMDI2=NUMDI2 C ELSEIF(ICASPL.EQ.'IGCP')THEN C NUMDI1=50 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=50 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 IF(NHOR1.GT.0)NUMDIS=NHOR1 C IDIST='INVERSE GAUSSIAN' IHP='GAMM' IHP2='A1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,VALUE1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='GAMM' IHP2='A2 ' ADEF=25.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='MU1 ' IHP2=' ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,VALUE3,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='MU2 ' IHP2=' ' ADEF=25.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE4,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ELSEIF(ICASPL.EQ.'BECP')THEN C NUMDI1=25 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=25 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 IF(NHOR1.GT.0)NUMDIS=NHOR1 C IDIST='BETA' IHP='ALPH' IHP2='A1 ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,VALUE1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='ALPH' IHP2='A2 ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='BETA' IHP2='1 ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,VALUE3,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='BETA' IHP2='2 ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE4,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ELSEIF(ICASPL.EQ.'GGCP')THEN C NUMDI1=25 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=25 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 IF(NHOR1.GT.0)NUMDIS=NHOR1 C IDIST='GENERALIZED GAMMA' IHP='ALPH' IHP2='A1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,VALUE1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='ALPH' IHP2='A2 ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='C1 ' IHP2=' ' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.1 CALL PARCH2(IHP,IHP2,IDIST,VALUE3,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IF(C1.EQ.0.0)C1=ADEF C IHP='C2 ' IHP2=' ' ADEF=3.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE4,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ELSEIF(ICASPL.EQ.'FNCP')THEN C NUMDI1=26 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=26 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 IF(NHOR1.GT.0)NUMDIS=NHOR1 C IDIST='FOLDED NORMAL' IHP='MU1 ' IHP2=' ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' ADEF=0.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='MU2 ' IHP2=' ' ADEF=25.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='SD1 ' IHP2=' ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,VALUE3,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='SD2 ' IHP2=' ' ADEF=25.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE4,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ELSE PPA0=0.0 PPA1=1.0 SHAPE1=1.0 CORRMX=0.0 GOTO9000 ENDIF C C **************************************************** C ** STEP 3-- ** C ** GENERATE PPCC PLOT FOR GIVEN DISTRIBUTION ** C **************************************************** C ISTEPN='3' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBCP')THEN CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) WRITE(ICOUT,213)VALUE1,VALUE2 213 FORMAT(' VALUE1, VALUE2 = ',2G15.7) CALL DPWRST('XXX','BUG ') ENDIF C ANUMDI=NUMDI1 ANUMD2=NUMDI2 DP=-1.0D0 DPPF=0.0D0 C DO1800IDIS=1,NUMDI1 C AIDIS=IDIS VAL1=VALUE1+((AIDIS-1.0)/(ANUMDI-1.0))*(VALUE2-VALUE1) C DO1890IDIS2=1,NUMDI2 AIDI2=IDIS2 VAL2=VALUE3+((AIDI2-1.0)/(ANUMD2-1.0))*(VALUE4-VALUE3) ICNT=0 C IF(ICASPL.EQ.'GHCP')THEN DO1011I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1011 ICNT=ICNT+1 CALL GHPPF(X2(I),VAL1,VAL2,X2OUT,DBLE(X2(I)),DPPF) X3(ICNT)=X2OUT Y3(ICNT)=Y2(I) 1011 CONTINUE C ELSEIF(ICASPL.EQ.'FCP')THEN DO1021I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1021 ICNT=ICNT+1 CALL FPPF(X2(I),INT(VAL1+0.5),INT(VAL2+0.5),X2OUT) X3(ICNT)=X2OUT Y3(ICNT)=Y2(I) 1021 CONTINUE C ELSEIF(ICASPL.EQ.'IGCP')THEN DO1031I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1031 ICNT=ICNT+1 CALL IGPPF(X2(I),VAL1,VAL2,X2OUT) X3(ICNT)=X2OUT Y3(ICNT)=Y2(I) 1031 CONTINUE C ELSEIF(ICASPL.EQ.'GGCP')THEN DO1041I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1041 ICNT=ICNT+1 CALL GGDPPF(X2(I),VAL1,VAL2,X2OUT) X3(ICNT)=X2OUT Y3(ICNT)=Y2(I) 1041 CONTINUE C ELSEIF(ICASPL.EQ.'BECP')THEN DO1051I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1051 ICNT=ICNT+1 CALL BETPPF(X2(I),VAL1,VAL2,X2OUT) X3(ICNT)=X2OUT Y3(ICNT)=Y2(I) 1051 CONTINUE C ELSEIF(ICASPL.EQ.'FNCP')THEN DO1061I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1061 ICNT=ICNT+1 CALL FNRPPF(X2(I),VAL1,VAL2,X2OUT) X3(ICNT)=X2OUT Y3(ICNT)=Y2(I) 1061 CONTINUE C ELSEIF(ICASPL.EQ.'LDCP')THEN DO1071I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1071 ICNT=ICNT+1 CALL GLDPPF(DBLE(X2(I)),DBLE(VAL1),DBLE(VAL2), 1 DPPF,IGLDDF,IWRITE) X3(ICNT)=REAL(DPPF) Y3(ICNT)=Y2(I) 1071 CONTINUE C ENDIF C C ************************************************** C ** STEP 4-- ** C ** COMPUTE MAXIMUM PPCC TO FIND VALUE OF SHAPE ** C ** PARAMETER AND THEN ** C ** COMPUTE FITTED LINE TO PROBABILITY PLOT ** C ** TO ESTIMATE LOCATION AND SCALE ** C ************************************************** C ISTEPN='4' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBCP') 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C N2=ICNT C IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBCP')THEN WRITE(ICOUT,2001)N2 2001 FORMAT('N2 = ',I8) CALL DPWRST('XXX','BUG ') IF(N2.GE.1)THEN DO2110I=1,N2 WRITE(ICOUT,2011)I,Y3(I),X3(I) 2011 FORMAT('I,Y3(I),X3(I) = ',I8,2G15.7) CALL DPWRST('XXX','BUG ') 2110 CONTINUE ENDIF ENDIF C CALL CORR(Y3,X3,N2,IWRITE,CC,IBUGG3,IERROR) C IF(CC.GT.CORRMX)THEN CORRMX=CC SHAPE1=VAL1 SHAPE2=VAL2 CALL LINFI2(Y3,X3,N2, 1 PPA0,PPA1, 1 ISUBRO,IBUGG3,IERROR) ENDIF C 1890 CONTINUE 1800 CONTINUE C C ************************************************** C ** STEP 5-- ** C ** COMPUTE SELECTED PERCENTILES ** C ************************************************** C ISTEPN='5' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBCP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NPERC.GT.0)THEN IF(ICASPL.EQ.'GHCP')THEN DO4110I=1,NPERC QPTEMP=QP(I)/100.0 CALL GHPPF(QPTEMP,SHAPE1,SHAPE2,XPERC(I),DP,DPPF) XPERC(I)=PPA0 + PPA1*XPERC(I) 4110 CONTINUE ELSEIF(ICASPL.EQ.'IGCP')THEN DO4120I=1,NPERC QPTEMP=QP(I)/100.0 CALL IGPPF(QPTEMP,SHAPE1,SHAPE2,XPERC(I)) XPERC(I)=PPA0 + PPA1*XPERC(I) 4120 CONTINUE ELSEIF(ICASPL.EQ.'GGCP')THEN DO4130I=1,NPERC QPTEMP=QP(I)/100.0 CALL GGDPPF(QPTEMP,SHAPE1,SHAPE2,XPERC(I)) XPERC(I)=PPA0 + PPA1*XPERC(I) 4130 CONTINUE ELSEIF(ICASPL.EQ.'BECP')THEN DO4140I=1,NPERC QPTEMP=QP(I)/100.0 CALL BETPPF(QPTEMP,SHAPE1,SHAPE2,XPERC(I)) XPERC(I)=PPA0 + PPA1*XPERC(I) 4140 CONTINUE ELSEIF(ICASPL.EQ.'FCP')THEN DO4150I=1,NPERC QPTEMP=QP(I)/100.0 CALL FPPF(QPTEMP,INT(SHAPE1+0.5),INT(SHAPE2+0.5),XPERC(I)) XPERC(I)=PPA0 + PPA1*XPERC(I) 4150 CONTINUE ELSEIF(ICASPL.EQ.'FNCP')THEN DO4160I=1,NPERC QPTEMP=QP(I)/100.0 CALL FNRPPF(QPTEMP,SHAPE1,SHAPE2,XPERC(I)) XPERC(I)=PPA0 + PPA1*XPERC(I) 4160 CONTINUE ELSEIF(ICASPL.EQ.'LDCP')THEN DO4170I=1,NPERC QPTEMP=QP(I)/100.0 CALL GLDPPF(DBLE(QPTEMP),DBLE(SHAPE1),DBLE(SHAPE2), 1 DPPF,IGLDDF,IWRITE) XPERC(I)=REAL(DPPF) XPERC(I)=PPA0 + PPA1*XPERC(I) 4170 CONTINUE ENDIF ENDIF C ******************* C ** STEP 90-- ** C ** EXIT ** C ******************* C 9000 CONTINUE C RETURN END SUBROUTINE DPJBKS(Y,X,N, 1ICASPL,IMETHD,IPPCDP,MAXOBV,MINMAX,PMAXLO, 1Y2,X2,Y3,X3, 1NHOR1,IGEPDF,IADEDF,ILGADF,ISKNDF,KSLOC,KSSCAL, 1QP,XPERC,NPERC, 1PPA0SV,PPA1SV,SHAPE1,AMINKS, 1IBUGG3,ISUBRO,IERROR) C C PURPOSE--FOR A GIVEN BOOTSTRAP SAMPLE, GENERATE THE KS PLOT C TO ESTIMATE THE SHAPE, LOCATION, AND SCALE C PARAMETERS. THE LOCATION AND SCALE PARAMETERS CAN C OPTIONALLY BE SPECIFIED IN ADVANCE. ONLY UNCENSORED C DATA IS CURRENTLY SUPPORTED. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2005/1 C ORIGINAL VERSION--JANUARY 2005. C MODIFED VERSION--OCTOBER 2006. CALL LIST TO TCDF/TPPF C MODIFED VERSION--OCTOBER 2006. SUPPORT FOR MAXWELL, ADD C PMAXLO TO CALL LIST C C SUPPORTED DISTRIBUTIONS ARE: C C 1) WEIBULL C 2) LOGNORMAL C 3) GAMMA C 4) INVERTED GAMMA C 5) LOG GAMMA C 6) INVERTED WEIBULL C 7) GENERALIZED PARETO C 8) T C 9) CHI-SQUARE C 10) CHI C 11) TUKEY-LAMBDA C 12) FRECHET C 13) WALD C 14) FATIGUE LIFE C 15) PARETO C 16) PARETO SECOND KIND C 17) GEOMETRIC EXTREME EXPONENTIAL C 18) BRADFORD C 19) RECIPROCAL C 20) ERROR (SUBBOTIN) C 21) LOG LOGISTIC C 22) DOUBLE WEIBULL C 23) FOLDED T C 24) SKEW LAPLACE (SKEW DOUBLE EXPONENTIAL) C 25) ASYMMETRIC LAPLACE (ASYMMETRIC DOUBLE EXPONENTIAL) C 26) GENERALIZED EXTREME VALUE C 27) LOG DOUBLE EXPONENTIAL (LOG LAPLACE) C 28) POWER FUNCTION C 29) GENERALIZED LOGISTIC C 30) VON MISES C 31) GENERALIZED HALF LOGISTIC C 32) WRAPPED CAUCHY C 33) POWER NORMAL C 34) DOUBLE GAMMA C 35) GENERALIZED LOGISTIC TYPE 2 C 36) GENERALIZED LOGISTIC TYPE 3 C 37) GENERALIZED LOGISTIC TYPE 5 C 38) MAXWELL C C FOLLOWING COULD POTENTIALLY BE ADDED: C C 39) SKEW NORMAL C 40) MCLEISH C C FOR THE KS PLOT, ONLY UNCENSORED DATA IS CURRENTLY C SUPPORTED. C C------------------------------------------------------------------ C CHARACTER*4 ICASPL CHARACTER*4 IMETHD CHARACTER*4 IGEPDF CHARACTER*4 IADEDF CHARACTER*4 ILGADF CHARACTER*4 ISKNDF CHARACTER*4 IBUGG3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C DIMENSION Y(*) DIMENSION X(*) DIMENSION Y2(*) DIMENSION X2(*) DIMENSION Y3(*) DIMENSION X3(*) DIMENSION QP(*) DIMENSION XPERC(*) C REAL KSLOC REAL KSSCAL C DOUBLE PRECISION DM DOUBLE PRECISION DTEMP1 DOUBLE PRECISION DTEMP2 DOUBLE PRECISION DPPF DOUBLE PRECISION XPAR(3) C CHARACTER*30 IDIST C CHARACTER*4 IWRITE CHARACTER*4 ISTEPN CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 IHP CHARACTER*4 IHP2 CHARACTER*4 LOWLTY CHARACTER*4 UPPLTY 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 DATA PI / 3.1415926535 / C C-----START POINT----------------------------------------------------- C ISUBN1='DPJB' ISUBN2='KS ' IWRITE='OFF' IF(NPERC.GT.0)THEN DO410I=1,NPERC XPERC(I)=0.0 410 CONTINUE ENDIF AMINKS=CPUMAX C IF(ICASPL.EQ.'P2KS' .OR. ICASPL.EQ.'PAKS')THEN IF(KSLOC.EQ.CPUMIN .AND. KSSCAL.EQ.CPUMIN)THEN KSLOC=0.0 KSSCAL=1.0 ENDIF ENDIF C ************************************************** C ** STEP 1-- ** C ** IF SET PPCC Y PLOT DATA POINTS COMMAND ** C ** WAS ENTERED, THIN DATA SET BY COMPUTING ** C ** PERCENTILES OF THE DATA. ONLY DO THIS FOR ** C ** THE UNCENSORED CASE. ** C ************************************************** C ISTEPN='1' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBKS') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IPPCDP.GT.0)THEN NP=MAX(20,IPPCDP) NP=MIN(NP,N) CALL SORT(Y,N,Y2) ASTRT=0.0 ASTOP=100.0 AINC=(ASTOP - ASTRT)/REAL(NP+1) IWRITE='OFF' DO100I=1,NP P100=ASTRT + REAL(I)*AINC CALL PERCEN(P100,Y2,N,IWRITE,X3,MAXOBV, 1 APERC,IBUGG3,IERROR) X2(I)=APERC 100 CONTINUE N=NP DO105I=1,N Y(I)=X2(I) 105 CONTINUE ENDIF C IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'JBKS')THEN WRITE(ICOUT,113)IPPCDP,NP,N 113 FORMAT(' IPPCDP, NP, N = ',3I8) CALL DPWRST('XXX','BUG ') DO117I=1,N WRITE(ICOUT,118)I,Y(I) 118 FORMAT(' I, Y(I) = ',I8,G15.7) CALL DPWRST('XXX','BUG ') 117 CONTINUE ENDIF C 999 FORMAT(1X) C CALL MEDIAN(Y,N,IWRITE,X2,MAXOBV,XMED,IBUGG3,IERROR) CALL MINIM(Y,N,IWRITE,XMIN,IBUGG3,IERROR) CALL SORT(Y,N,Y) CALL UNIMED(N,X) XMIN=Y(1) XMAX=Y(N) C C **************************************************** C ** STEP 2-- ** C ** EXTRACT RANGE FOR SHAPE PARAMETER ** C **************************************************** C ISTEPN='2' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBKS') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICNT=0 AMINKS=CPUMAX NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 C IF(ICASPL.EQ.'WEKS' .OR. ICASPL.EQ.'IWKS' .OR. 1 ICASPL.EQ.'GAKS' .OR. ICASPL.EQ.'GIKS' .OR. 1 ICASPL.EQ.'LGKS' .OR. ICASPL.EQ.'GEKS' .OR. 1 ICASPL.EQ.'EEKS' .OR. ICASPL.EQ.'FLKS' .OR. 1 ICASPL.EQ.'WAKS' .OR. ICASPL.EQ.'E2KS' .OR. 1 ICASPL.EQ.'DWKS' .OR. ICASPL.EQ.'GVKS' .OR. 1 ICASPL.EQ.'GZKS' .OR. ICASPL.EQ.'DGKS' .OR. 1 ICASPL.EQ.'PAKS' .OR. ICASPL.EQ.'P2KS' .OR. 1 ICASPL.EQ.'G5KS' 1 )THEN C ALOWLM=0.0 IF(ICASPL.EQ.'WEKS')THEN ADEF1=1.0 ADEF2=50.0 IDIST='WEIBULL' ELSEIF(ICASPL.EQ.'GAKS')THEN ADEF1=1.0 ADEF2=50.0 IDIST='GAMMA' ELSEIF(ICASPL.EQ.'GIKS')THEN ADEF1=0.5 ADEF2=25.0 IDIST='INVERTED GAMMA' ELSEIF(ICASPL.EQ.'LGKS')THEN ADEF1=0.5 ADEF2=25.0 IDIST='LOG GAMMA' ELSEIF(ICASPL.EQ.'IWKS')THEN ADEF1=0.5 ADEF2=10.0 IDIST='INVERTED WEIBULL' ELSEIF(ICASPL.EQ.'GEKS')THEN ALOWLM=CPUMIN ADEF1=-3.0 ADEF2=3.0 IDIST='GENERALIZED PARETO' ELSEIF(ICASPL.EQ.'EEKS')THEN ADEF1=0.1 ADEF2=10.0 IDIST='GEOMETRIC EXTREME EXPONENTIAL' ELSEIF(ICASPL.EQ.'FLKS')THEN ADEF1=1.0 ADEF2=50.0 IDIST='FATIGUE LIFE' ELSEIF(ICASPL.EQ.'WAKS')THEN ADEF1=0.5 ADEF2=25.0 IDIST='WALD' ELSEIF(ICASPL.EQ.'E2KS')THEN ADEF1=1.0 ADEF2=50.0 IDIST='FRECHET' ELSEIF(ICASPL.EQ.'PAKS' .OR. ICASPL.EQ.'P2KS')THEN ADEF1=0.2 ADEF2=5.0 IDIST='PARETO' IF(ICASPL.EQ.'P2KS')IDIST='PARETO SECOND KIND' C IHP='A ' IHP2=' ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF1=1.0 CALL PARCH2(IHP,IHP2,IDIST,A1,ADEF1,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(A1.LE.0.0)A1=1.0 ELSEIF(ICASPL.EQ.'P2KS')THEN ADEF1=0.2 ADEF2=5.0 IDIST='PARETO' ELSEIF(ICASPL.EQ.'DWKS')THEN ADEF1=0.5 ADEF2=10.0 IDIST='DOUBLE WEIBULL' ELSEIF(ICASPL.EQ.'DGKS')THEN ADEF1=0.5 ADEF2=10.0 IDIST='DOUBLE GAMMA' ELSEIF(ICASPL.EQ.'GVKS')THEN ALOWLM=CPUMIN ADEF1=-5.0 ADEF2=5.0 IDIST='GENERALIZED EXTREME VALUE' ELSEIF(ICASPL.EQ.'GZKS')THEN AUPPLM=5.0 ADEF1=0.1 ADEF2=2.5 IDIST='GENERALIZED HALF LOGISTIC' ELSEIF(ICASPL.EQ.'G5KS')THEN ALOWLM=CPUMIN ADEF1=-5.0 ADEF2=5.0 IDIST='GENERALIZED LOGISTIC TYPE 5' ENDIF IHP='GAMM' IHP2='A1 ' AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCH2(IHP,IHP2,IDIST,VALUE1,ADEF1,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')VALUE1=ADEF1 C IHP='GAMM' IHP2='A2 ' CALL PARCH2(IHP,IHP2,IDIST,VALUE2,ADEF2,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')VALUE2=ADEF2 ELSEIF(ICASPL.EQ.'LNKS' .OR. ICASPL.EQ.'MAKS')THEN C IF(ICASPL.EQ.'LNKS')THEN ADEF1=0.5 ADEF2=25.0 IDIST='LOGNORMAL' ELSEIF(ICASPL.EQ.'MAKS')THEN ADEF1=0.1 ADEF2=10.0 IDIST='MAXWELL' ENDIF IHP='SIGM' IHP2='A1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCH2(IHP,IHP2,IDIST,VALUE1,ADEF1,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')VALUE1=1.0 C IHP='SIGM' IHP2='A2 ' CALL PARCH2(IHP,IHP2,IDIST,VALUE2,ADEF2,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')VALUE2=25.0 ELSEIF(ICASPL.EQ.'LAKS' .OR. ICASPL.EQ.'SDKS')THEN C IF(ICASPL.EQ.'LAKS')THEN IDIST='TUKEY-LAMBDA' ADEF1=-2.0 ADEF2=2.0 ELSEIF(ICASPL.EQ.'SDKS')THEN IDIST='SKEW DOUBLE EXPONENTIAL' ADEF1=0.0 ADEF2=10.0 ENDIF IHP='LAMB' IHP2='DA1 ' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' CALL PARCH2(IHP,IHP2,IDIST,VALUE1,ADEF1,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')VALUE1=ADEF C IHP='LAMB' IHP2='DA2 ' CALL PARCH2(IHP,IHP2,IDIST,VALUE2,ADEF2,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')VALUE2=ADEF ELSEIF(ICASPL.EQ.'TKS' .OR. ICASPL.EQ.'CSKS' .OR. 1 ICASPL.EQ.'CHKS' .OR. ICASPL.EQ.'FTKS')THEN C IF(ICASPL.EQ.'TKS')IDIST='T' IF(ICASPL.EQ.'CSKS')IDIST='CHI-SQUARE' IF(ICASPL.EQ.'CHKS')IDIST='CHI' IF(ICASPL.EQ.'FTKS')IDIST='FOLDED T' IHP='NU1 ' IHP2=' ' ALOWLM=1. AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' ADEF=1.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GAMMA1=1.0 VALUE1=REAL(INT(VALUE1+0.5)) C IHP='NU2 ' IHP2=' ' ADEF=50.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')VALUE2=50.0 IVAL1=INT(VALUE1+0.5) IVAL2=INT(VALUE2+0.5) ITEMP=ABS(IVAL2-IVAL1)+1 IF(ITEMP.LE.NUMDIS)NUMDIS=ITEMP ELSEIF(ICASPL.EQ.'BRKS')THEN IDIST='BRADFORD' IHP='BETA' IHP2='1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,VALUE1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='BETA' IHP2='2 ' ADEF=25.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ELSEIF(ICASPL.EQ.'REKS' .OR. ICASPL.EQ.'VMKS')THEN IF(ICASPL.EQ.'REKS')THEN IDIST='RECIPROCAL' ALOWLM=1.0 LOWLTY='> ' ADEF1=1.5 ADEF2=20.0 ELSEIF(ICASPL.EQ.'VMKS')THEN IDIST='VON MISES' ALOWLM=0.0 LOWLTY='>= ' ADEF1=0.5 ADEF2=25.0 ENDIF IHP='B1 ' IHP2=' ' AUPPLM=CPUMAX UPPLTY='<= ' CALL PARCH2(IHP,IHP2,IDIST,VALUE1,ADEF1,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='B2 ' IHP2=' ' CALL PARCH2(IHP,IHP2,IDIST,VALUE2,ADEF2,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ELSEIF(ICASPL.EQ.'ERKS' .OR. ICASPL.EQ.'LXKS' .OR. 1 ICASPL.EQ.'GLKS' .OR. ICASPL.EQ.'G2KS' .OR. 1 ICASPL.EQ.'G3KS')THEN IF(ICASPL.EQ.'ERKS')THEN IDIST='ERROR' ADEF1=1.1 ADEF2=5.0 ALOWLM=1. ELSEIF(ICASPL.EQ.'LXKS')THEN IDIST='LOG LAPLACE' ADEF1=0.5 ADEF2=10.0 ALOWLM=0.0 ELSEIF(ICASPL.EQ.'GLKS')THEN IDIST='GENERALIZED LOGISTIC' ADEF1=0.2 ADEF2=5.0 ALOWLM=0.1 ELSEIF(ICASPL.EQ.'G2KS')THEN IDIST='GENERALIZED LOGISTIC TYPE 2' ADEF1=0.1 ADEF2=10.0 ALOWLM=0.0 ELSEIF(ICASPL.EQ.'G3KS')THEN IDIST='GENERALIZED LOGISTIC TYPE 3' ADEF1=0.1 ADEF2=10.0 ALOWLM=0.0 ENDIF IHP='ALPH' IHP2='A1 ' AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCH2(IHP,IHP2,IDIST,VALUE1,ADEF1,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) C IHP='ALPH' IHP2='A2 ' CALL PARCH2(IHP,IHP2,IDIST,VALUE2,ADEF2,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ELSEIF(ICASPL.EQ.'TRKS' .OR. ICASPL.EQ.'PFKS')THEN IF(ICASPL.EQ.'TRKS')THEN IDIST='TRIANGULAR' ADEF1=-1.0 ADEF2=1.0 ALOWLM=-1.0 AUPPLM=1.0 LOWLTY='>= ' ELSEIF(ICASPL.EQ.'PFKS')THEN IDIST='POWER FUNCTION' ADEF1=0.5 ADEF2=25.0 ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' ENDIF IHP='C1 ' IHP2=' ' UPPLTY='<= ' CALL PARCH2(IHP,IHP2,IDIST,VALUE1,ADEF1,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='C2 ' IHP2=' ' CALL PARCH2(IHP,IHP2,IDIST,VALUE2,ADEF2,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ELSEIF(ICASPL.EQ.'PNKS' .OR. ICASPL.EQ.'WCKS')THEN IF(ICASPL.EQ.'PNKS')THEN IDIST='POWER NORMAL' AUPPLM=CPUMAX ADEF1=1.0 ADEF2=50.0 LOWLTY='> ' UPPLTY='<= ' ELSEIF(ICASPL.EQ.'WCKS')THEN IDIST='WRAPPED CAUCHY' AUPPLM=1.0 ADEF1=0.0 ADEF2=0.99 LOWLTY='>= ' UPPLTY='< ' ENDIF IHP='P1 ' IHP2=' ' ALOWLM=0. CALL PARCH2(IHP,IHP2,IDIST,VALUE1,ADEF1,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='P2 ' IHP2=' ' CALL PARCH2(IHP,IHP2,IDIST,VALUE2,ADEF2,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ELSEIF(ICASPL.EQ.'LLKS')THEN IDIST='LOG-LOGISTIC' IHP='DELT' IHP2='A1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.2 CALL PARCH2(IHP,IHP2,IDIST,VALUE1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='DELT' IHP2='A2 ' ADEF=25.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ELSEIF(ICASPL.EQ.'ADKS')THEN IDIST='ASYMMETRIC LAPLACE' IF(IADEDF.EQ.'K')THEN IHP='K1 ' IHP2=' ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' ADEF=0.2 CALL PARCH2(IHP,IHP2,IDIST,VALUE1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='K2 ' IHP2=' ' ADEF=10.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ELSE IHP='MU1 ' IHP2=' ' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' ADEF=-5.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='MU2 ' IHP2=' ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ENDIF ELSE PPA0=0.0 PPA1=1.0 SHAPE1=1.0 AMINKS=0.0 GOTO9000 ENDIF C C **************************************************** C ** STEP 3-- ** C ** GENERATE KS PLOT FOR GIVEN DISTRIBUTION ** C **************************************************** C ISTEPN='3' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBKS')THEN CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) WRITE(ICOUT,213)N,VALUE1,VALUE2 213 FORMAT(' N,VALUE1, VALUE2 = ',I8,2G15.7) CALL DPWRST('XXX','BUG ') ENDIF C ANUMDI=NUMDIS IFLAG=0 C DO2800IDIS=1,NUMDIS C ICNT=0 AIDIS=IDIS VALUE=VALUE1+((AIDIS-1.0)/(ANUMDI-1.0))*(VALUE2-VALUE1) C IF(ICASPL.EQ.'WEKS')THEN IF(MINMAX.EQ.1)THEN AMIN=0.0 AMAX=CPUMAX ELSE AMIN=CPUMIN AMAX=0.0 ENDIF IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 C DO1011I=1,N ICNT=ICNT+1 CALL WEIPPF(X(I),VALUE,MINMAX,X2(ICNT)) Y2(ICNT)=Y(I) 1011 CONTINUE C ELSEIF(ICASPL.EQ.'LNKS')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 C DO1021I=1,N ICNT=ICNT+1 CALL LGNPPF(X(I),VALUE,X2(ICNT)) Y2(ICNT)=Y(I) 1021 CONTINUE C ELSEIF(ICASPL.EQ.'GAKS')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 DO1031I=1,N ICNT=ICNT+1 CALL GAMPPF(X(I),VALUE,X2(ICNT)) Y2(ICNT)=Y(I) 1031 CONTINUE C ELSEIF(ICASPL.EQ.'GIKS')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 DO1041I=1,N ICNT=ICNT+1 CALL IGAPPF(X(I),VALUE,X2(ICNT)) Y2(ICNT)=Y(I) 1041 CONTINUE C ELSEIF(ICASPL.EQ.'LGKS')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 DO1051I=1,N ICNT=ICNT+1 CALL LGAPPF(X(I),VALUE,ILGADF,X2(ICNT)) Y2(ICNT)=Y(I) 1051 CONTINUE C ELSEIF(ICASPL.EQ.'IWKS')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 DO1061I=1,N ICNT=ICNT+1 CALL IWEPPF(X(I),VALUE,X2(ICNT)) Y2(ICNT)=Y(I) 1061 CONTINUE C ELSEIF(ICASPL.EQ.'GEKS')THEN IF(IGEPDF.EQ.'JOHN')THEN IF(VALUE.LE.0.0)THEN AMIN=0.0 AMAX=CPUMAX ELSE AMIN=0.0 AMAX=(1.0/VALUE) ENDIF ELSE IF(VALUE.GE.0.0)THEN AMIN=0.0 AMAX=CPUMAX ELSE AMIN=0.0 AMAX=-(1.0/VALUE) ENDIF ENDIF IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 DO1071I=1,N ICNT=ICNT+1 CALL GEPPPF(X(I),VALUE,MINMAX,IGEPDF,X2(ICNT)) Y2(ICNT)=Y(I) 1071 CONTINUE C ELSEIF(ICASPL.EQ.'TKS')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 DO1081I=1,N ICNT=ICNT+1 CALL TPPF(X(I),VALUE,X2(ICNT)) Y2(ICNT)=Y(I) 1081 CONTINUE C ELSEIF(ICASPL.EQ.'CSKS')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 DO1091I=1,N ICNT=ICNT+1 CALL CHSPPF(X(I),INT(VALUE+0.5),X2(ICNT)) Y2(ICNT)=Y(I) 1091 CONTINUE C ELSEIF(ICASPL.EQ.'CHKS')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 DO1101I=1,N ICNT=ICNT+1 CALL CHPPF(X(I),INT(VALUE+0.5),X2(ICNT)) Y2(ICNT)=Y(I) 1101 CONTINUE C ELSEIF(ICASPL.EQ.'EEKS')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 DO1111I=1,N ICNT=ICNT+1 CALL GEEPPF(X(I),VALUE,X2(ICNT)) Y2(ICNT)=Y(I) 1111 CONTINUE C ELSEIF(ICASPL.EQ.'FLKS')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 DO1121I=1,N ICNT=ICNT+1 CALL FLPPF(X(I),VALUE,X2(ICNT)) Y2(ICNT)=Y(I) 1121 CONTINUE C ELSEIF(ICASPL.EQ.'E2KS')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 DO1131I=1,N ICNT=ICNT+1 CALL EV2PPF(X(I),VALUE,MINMAX,X2(ICNT)) Y2(ICNT)=Y(I) 1131 CONTINUE C ELSEIF(ICASPL.EQ.'WAKS')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 DO1141I=1,N ICNT=ICNT+1 CALL WALPPF(X(I),VALUE,X2(ICNT)) Y2(ICNT)=Y(I) 1141 CONTINUE C ELSEIF(ICASPL.EQ.'PAKS')THEN AMU=A1 IF(AMU.GT.XMIN)AMU=XMIN AMIN=AMU AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 DO1151I=1,N ICNT=ICNT+1 CALL PARPPF(X(I),VALUE,AMU,X2(ICNT)) Y2(ICNT)=Y(I) 1151 CONTINUE C ELSEIF(ICASPL.EQ.'P2KS')THEN AMU=A1 IF(AMU.GT.XMIN)AMU=XMIN AMIN=AMU AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 DO1156I=1,N ICNT=ICNT+1 CALL PA2PPF(X(I),VALUE,AMU,X2(ICNT)) Y2(ICNT)=Y(I) 1156 CONTINUE C ELSEIF(ICASPL.EQ.'LAKS')THEN IF(VALUE.EQ.0.0)GOTO9000 IF(VALUE.GT.0.0)THEN AMAX=ABS(1.0/VALUE) AMIN=-AMAX ELSE AMIN=CPUMIN AMAX=CPUMAX ENDIF IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 DO1161I=1,N ICNT=ICNT+1 CALL LAMPPF(X(I),VALUE,X2(ICNT)) Y2(ICNT)=Y(I) 1161 CONTINUE C ELSEIF(ICASPL.EQ.'BRKS')THEN AMIN=0.0 AMAX=1.0 IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 DO1171I=1,N ICNT=ICNT+1 CALL BRAPPF(X(I),VALUE,X2(ICNT)) Y2(ICNT)=Y(I) 1171 CONTINUE ELSEIF(ICASPL.EQ.'REKS')THEN AMIN=1.0/VALUE AMAX=1.0 IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 DO1181I=1,N ICNT=ICNT+1 CALL RECPPF(X(I),VALUE,X2(ICNT)) Y2(ICNT)=Y(I) 1181 CONTINUE ELSEIF(ICASPL.EQ.'ERKS')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 DO1191I=1,N ICNT=ICNT+1 XIN=X(I) CALL ERRPPF(XIN,VALUE,X2(ICNT)) Y2(ICNT)=Y(I) 1191 CONTINUE ELSEIF(ICASPL.EQ.'TRKS')THEN AMIN=-1.0 AMAX=1.0 ZLOWLM=-1.0 ZUPPLM=1.0 IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 DO1201I=1,N ICNT=ICNT+1 CALL TRIPPF(X(I),VALUE,ZLOWLM,ZUPPLM,X2(ICNT)) Y2(ICNT)=Y(I) 1201 CONTINUE ELSEIF(ICASPL.EQ.'LLKS')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 DO1211I=1,N ICNT=ICNT+1 CALL LLGPPF(X(I),VALUE,X2(ICNT)) Y2(ICNT)=Y(I) 1211 CONTINUE ELSEIF(ICASPL.EQ.'DWKS')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 DO1221I=1,N ICNT=ICNT+1 CALL DWEPPF(X(I),VALUE,X2(ICNT)) Y2(ICNT)=Y(I) 1221 CONTINUE ELSEIF(ICASPL.EQ.'FTKS')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 DO1231I=1,N ICNT=ICNT+1 CALL FTPPF(X(I),INT(VALUE+0.5),X2(ICNT)) Y2(ICNT)=Y(I) 1231 CONTINUE ELSEIF(ICASPL.EQ.'SDKS')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 DO1236I=1,N ICNT=ICNT+1 CALL SDEPPF(X(I),VALUE,X2(ICNT)) Y2(ICNT)=Y(I) 1236 CONTINUE ELSEIF(ICASPL.EQ.'GVKS')THEN AMIN=CPUMIN AMAX=CPUMAX IF(MINMAX.EQ.2 .OR. MINMAX.EQ.0)THEN IF(VALUE.GT.0.0)THEN AMIN=CPUMIN AMAX=(1.0/VALUE) - 0.1E-6 ELSE AMIN=(1.0/VALUE) + 0.1E-6 AMAX=CPUMAX ENDIF ELSE IF(VALUE.GT.0.0)THEN AMIN=(-1.0/VALUE) + 0.1E-6 AMAX=CPUMAX ELSE AMIN=CPUMIN AMAX=(-1.0/VALUE) - 0.1E-6 ENDIF ENDIF IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 DO1241I=1,N ICNT=ICNT+1 CALL GEVPPF(X(I),VALUE,MINMAX,X2(ICNT)) Y2(ICNT)=Y(I) 1241 CONTINUE ELSEIF(ICASPL.EQ.'LXKS')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 DO1251I=1,N ICNT=ICNT+1 CALL LDEPPF(X(I),VALUE,X2(ICNT)) Y2(ICNT)=Y(I) 1251 CONTINUE ELSEIF(ICASPL.EQ.'ADKS')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 DO1261I=1,N ICNT=ICNT+1 CALL ADEPPF(X(I),VALUE,IADEDF,X2(ICNT)) Y2(ICNT)=Y(I) 1261 CONTINUE ELSEIF(ICASPL.EQ.'PFKS')THEN AMIN=0.0 AMAX=1.0 IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 DO1271I=1,N ICNT=ICNT+1 CALL POWPPF(X(I),VALUE,X2(ICNT)) Y2(ICNT)=Y(I) 1271 CONTINUE ELSEIF(ICASPL.EQ.'VMKS')THEN AMIN=-PI AMAX=PI IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 DO1281I=1,N ICNT=ICNT+1 CALL VONPPF(X(I),VALUE,X2(ICNT)) Y2(ICNT)=Y(I) 1281 CONTINUE ELSEIF(ICASPL.EQ.'WCKS')THEN AMIN=0.0 AMAX=2.0*PI IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 DO1291I=1,N ICNT=ICNT+1 CALL WCAPPF(X(I),VALUE,X2(ICNT)) Y2(ICNT)=Y(I) 1291 CONTINUE ELSEIF(ICASPL.EQ.'GLKS')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 DO1301I=1,N ICNT=ICNT+1 CALL GLOPPF(X(I),VALUE,X2(ICNT)) Y2(ICNT)=Y(I) 1301 CONTINUE ELSEIF(ICASPL.EQ.'GZKS')THEN AMIN=0.0 AMAX=1.0/VALUE IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 DO1311I=1,N ICNT=ICNT+1 CALL HFLPPF(X(I),VALUE,X2(ICNT)) Y2(ICNT)=Y(I) 1311 CONTINUE ELSEIF(ICASPL.EQ.'DGKS')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 DO1321I=1,N ICNT=ICNT+1 CALL DGAPPF(X(I),VALUE,X2(ICNT)) Y2(ICNT)=Y(I) 1321 CONTINUE ELSEIF(ICASPL.EQ.'PNKS')THEN S=1.0 AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 DO1331I=1,N ICNT=ICNT+1 CALL PNRPPF(X(I),VALUE,S,X2(ICNT)) Y2(ICNT)=Y(I) 1331 CONTINUE ELSEIF(ICASPL.EQ.'G2KS')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 DO1341I=1,N ICNT=ICNT+1 CALL GL2PPF(DBLE(X(I)),DBLE(VALUE),DPPF) X2(ICNT)=REAL(DPPF) Y2(ICNT)=Y(I) 1341 CONTINUE ELSEIF(ICASPL.EQ.'G3KS')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 DO1351I=1,N ICNT=ICNT+1 CALL GL3PPF(DBLE(X(I)),DBLE(VALUE),DPPF) X2(ICNT)=REAL(DPPF) Y2(ICNT)=Y(I) 1351 CONTINUE ELSEIF(ICASPL.EQ.'MAKS')THEN AMIN=0.0 AMAX=CPUMAX KSSCAL=1.0 KSLOC=PMAXLO IF(KSLOC.EQ.CPUMIN)KSLOC=XMIN IF(KSLOC.GT.XMIN)KSLOC=XMIN IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 DO1361I=1,N ICNT=ICNT+1 CALL MAXPPF(X(I),VALUE,PPF) X2(ICNT)=PPF Y2(ICNT)=Y(I) 1361 CONTINUE ENDIF C C ************************************************** C ** STEP 4-- ** C ** COMPUTE MINIMUM KS TO FIND VALUE OF SHAPE ** C ** PARAMETER AND THEN ** C ** COMPUTE FITTED LINE TO PROBABILITY PLOT ** C ** TO ESTIMATE LOCATION AND SCALE ** C ************************************************** C ISTEPN='4' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBKS') 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C 1500 CONTINUE NTEMP=ICNT C IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBKS')THEN WRITE(ICOUT,2001)ICNT,NTEMP 2001 FORMAT('ICNT,NTEMP = ',2I8) CALL DPWRST('XXX','BUG ') IF(NTEMP.GE.1)THEN DO2110I=1,NTEMP WRITE(ICOUT,2011)I,Y2(I),X2(I) 2011 FORMAT('I,Y2(I),X2(I) = ',I8,2G15.7) CALL DPWRST('XXX','BUG ') 2110 CONTINUE ENDIF ENDIF C CCCCC DETERMINE LOCATION AND SCALE PARAMETERS. CCCCC 1) USER SPECIFIED KSLOC AND KSSCALE CCCCC 2) FIT A LINE TO THE PROBABILITY PLOT AND USE INTERCEPT CCCCC AND SLOPE CCCCC 3) FOR BOUNDED DISTRIBUTIONS, CHECK THAT XMIN AND XMAX CCCCC WILL BE IN RANGE. IF NOT, SET LOCATION TO MINIMUM CCCCC AND SCALE TO MAXIMUM - MINIMUM C EPS=0.000001 IF((KSLOC.EQ.CPUMIN .OR. KSSCAL.EQ.CPUMIN) .AND. 1 IFLAG.EQ.0)THEN C C HANDLE TUKEY-LAMBDA SEPARATELY C IF(ICASPL.EQ.'LAKS' .AND. VALUE.GT.0.0)THEN CALL LINFI2(Y2,X2,NTEMP, 1 A0TEMP,A1TEMP, 1 ISUBRO,IBUGG3,IERROR) IF((XMIN-A0TEMP)/A1TEMP.LT.AMIN .OR. 1 (XMAX-A0TEMP)/A1TEMP.GT.AMAX)THEN A0TEMP=XMED ATEMP1=VALUE*ABS(XMAX-A0TEMP) + 0.1 ATEMP2=VALUE*ABS(XMIN-A0TEMP) + 0.1 A1TEMP=MAX(ATEMP1,ATEMP2) ENDIF C C HANDLE VON-MISES, WRAPPED CAUCHY SEPARATELY C ELSEIF(ICASPL.EQ.'VMKS' .OR. ICASPL.EQ.'WCKS')THEN CALL LINFI2(Y2,X2,NTEMP, 1 A0TEMP,A1TEMP, 1 ISUBRO,IBUGG3,IERROR) IF((XMIN-A0TEMP)/A1TEMP.LT.AMIN .OR. 1 (XMAX-A0TEMP)/A1TEMP.GT.AMAX)THEN A0TEMP=XMED A1TEMP=(XMAX-A0TEMP)/AMAX ENDIF C C HANDLE CASE WHERE DOMAIN BOUNDED BOTH ABOVE AND BELOW. SOLVE C C (XMIN-A0)/A1 = AMIN C (XMAX-A0)/A1 = AMAX C ELSEIF(AMIN.GT.CPUMIN .AND. AMAX.LT.CPUMAX)THEN CALL LINFI2(Y2,X2,NTEMP, 1 A0TEMP,A1TEMP, 1 ISUBRO,IBUGG3,IERROR) IF((XMIN-A0TEMP)/A1TEMP.LT.AMIN .OR. 1 (XMAX-A0TEMP)/A1TEMP.GT.AMAX)THEN CMIN=AMIN CMAX=AMAX CONST=CMIN/CMAX A0TEMP=(XMIN-CONST*XMAX)/(1.0+CONST) - EPS A1TEMP=(XMAX-A0TEMP)/CMAX + EPS ENDIF C C HANDLE CASE WHERE DOMAIN BOUNDED ON MINIMUM ONLY C ELSEIF(AMIN.GT.CPUMIN .AND. AMAX.EQ.CPUMAX)THEN CALL LINFI2(Y2,X2,NTEMP, 1 A0TEMP,A1TEMP, 1 ISUBRO,IBUGG3,IERROR) IF((XMIN-A0TEMP)/A1TEMP.LT.AMIN)THEN A0TEMP=XMIN-EPS ENDIF C C HANDLE CASE WHERE DOMAIN BOUNDED ON MAXIMUM ONLY C ELSEIF(AMIN.EQ.CPUMIN .AND. AMAX.LT.CPUMAX)THEN CALL LINFI2(Y2,X2,NTEMP, 1 A0TEMP,A1TEMP, 1 ISUBRO,IBUGG3,IERROR) CTEMP=(XMAX-A0TEMP)/A1TEMP IF(CTEMP.GE.AMAX)THEN A0TEMP=(XMAX+EPS) - A1TEMP*AMAX ENDIF C C HANDLE UNBOUNDED CASE C ELSE CALL LINFI2(Y2,X2,NTEMP, 1 A0TEMP,A1TEMP, 1 ISUBRO,IBUGG3,IERROR) ENDIF C ELSE A0TEMP=KSLOC A1TEMP=KSSCAL ENDIF C J=1 X3(J)=Y(1) Y3(J)=0.0 J=2 X3(J)=Y(1) Y3(J)=1.0/REAL(N) DO200I=2,N J=J+1 X3(J)=Y(I) Y3(J)=REAL(I-1)/REAL(N) J=J+1 X3(J)=Y(I) Y3(J)=REAL(I)/REAL(N) 200 CONTINUE NTEMP=J C PPA0=A0TEMP PPA1=A1TEMP DM=0.0D0 C IF(ICASPL.EQ.'WEKS')THEN DO1610I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL WEICDF(XL,VALUE,MINMAX,XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1610 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'LNKS')THEN DO1620I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL LGNCDF(XL,VALUE,XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1620 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'GAKS')THEN DO1630I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL GAMCDF(XL,VALUE,XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1630 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'GIKS')THEN DO1640I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL IGACDF(XL,VALUE,XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1640 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'LGKS')THEN DO1650I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL LGACDF(XL,VALUE,ILGADF,XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1650 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'IWKS')THEN DO1660I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL IWECDF(XL,VALUE,XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1660 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'GEKS')THEN DO1670I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL GEPCDF(XL,VALUE,MINMAX,IGEPDF,XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1670 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'TKS')THEN DO1680I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CCCCC CALL TCDF(XL,INT(VALUE+0.5),XOUT1) CALL TCDF(XL,VALUE,XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1680 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'CSKS')THEN DO1690I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL CHSCDF(XL,INT(VALUE+0.5),XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1690 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'CHKS')THEN DO1700I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL CHCDF(XL,INT(VALUE+0.5),XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1700 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'EEKS')THEN DO1710I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL GEECDF(XL,VALUE,XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1710 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'FLKS')THEN DO1720I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL FLCDF(XL,VALUE,XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1720 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'WAKS')THEN DO1730I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL WALCDF(XL,VALUE,XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1730 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'E2KS')THEN DO1740I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL EV2CDF(XL,VALUE,MINMAX,XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1740 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'PAKS')THEN AMU=A1 IF(AMU.GT.XMIN)AMU=XMIN DO1750I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL PARCDF(XL,VALUE,AMU,XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1750 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'P2KS')THEN AMU=A1 IF(AMU.GT.XMIN)AMU=XMIN DO1755I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL PA2CDF(XL,VALUE,AMU,XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1755 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'LAKS')THEN DO1760I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL LAMCDF(XL,VALUE,XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1760 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'BRKS')THEN DO1770I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL BRACDF(XL,VALUE,XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1770 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'REKS')THEN DO1780I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL RECCDF(XL,VALUE,XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1780 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'ERKS')THEN DO1790I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL ERRCDF(XL,VALUE,XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1790 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'TRKS')THEN ZLOWLM=PPA0 ZUPPLIM=PPA0 + PPA1 DO1800I=1,NTEMP XL=X3(I) CCCCC XL=(XL-PPA0)/PPA1 CALL TRICDF(XL,VALUE,ZLOWLM,ZUPPLM,XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1800 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'LLKS')THEN DO1810I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL LLGCDF(XL,VALUE,XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1810 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'DWKS')THEN DO1820I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL DWECDF(XL,VALUE,XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1820 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'FTKS')THEN DO1830I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL FTCDF(XL,INT(VALUE+0.5),XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1830 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'SDKS')THEN DO1840I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL SDECDF(XL,VALUE,XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1840 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'GVKS')THEN DO1850I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL GEVCDF(XL,VALUE,MINMAX,XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1850 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'ADKS')THEN DO1860I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL ADECDF(XL,VALUE,IADEDF,XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1860 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'LXKS')THEN DO1870I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL LDECDF(XL,VALUE,XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1870 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'PFKS')THEN DO1880I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL POWCDF(XL,VALUE,XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1880 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'VMKS')THEN DO1890I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL VONCDF(XL,VALUE,XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1890 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'WCKS')THEN DO1900I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL WCACDF(XL,VALUE,XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1900 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'GLKS')THEN DO1910I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL GLOCDF(XL,VALUE,XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1910 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'GZKS')THEN DO1920I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL HFLCDF(XL,VALUE,XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1920 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'DGKS')THEN DO1930I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL DGACDF(XL,VALUE,XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1930 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'PNKS')THEN DO1940I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL PNRCDF(XL,VALUE,XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1940 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'G2KS')THEN DO1950I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL GL2CDF(DBLE(XL),DBLE(VALUE),DPPF) XOUT1=REAL(DPPF) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1950 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'G3KS')THEN DO1960I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL GL3CDF(DBLE(XL),DBLE(VALUE),DPPF) XOUT1=REAL(DPPF) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1960 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'MAKS')THEN DO1970I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL MAXCDF(XL,VALUE,PPF) XOUT1=PPF DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1970 CONTINUE STAT=REAL(DM) ENDIF C IF(STAT.LT.AMINKS)THEN AMINKS=STAT SHAPE1=VALUE PPA0SV=PPA0 PPA1SV=PPA1 ENDIF C 2800 CONTINUE C C ************************************************** C ** STEP 5-- ** C ** COMPUTE SELECTED PERCENTILES ** C ************************************************** C ISTEPN='5' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBKS') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NPERC.GT.0)THEN IF(ICASPL.EQ.'WEKS')THEN DO4110I=1,NPERC QPTEMP=QP(I)/100.0 CALL WEIPPF(QPTEMP,SHAPE1,MINMAX,XPERC(I)) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4110 CONTINUE ELSEIF(ICASPL.EQ.'LNKS')THEN DO4120I=1,NPERC QPTEMP=QP(I)/100.0 CALL LGNPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4120 CONTINUE ELSEIF(ICASPL.EQ.'GAKS')THEN DO4130I=1,NPERC QPTEMP=QP(I)/100.0 CALL GAMPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4130 CONTINUE ELSEIF(ICASPL.EQ.'GIKS')THEN DO4140I=1,NPERC QPTEMP=QP(I)/100.0 CALL IGAPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4140 CONTINUE ELSEIF(ICASPL.EQ.'LGKS')THEN DO4150I=1,NPERC QPTEMP=QP(I)/100.0 CALL LGAPPF(QPTEMP,SHAPE1,ILGADF,XPERC(I)) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4150 CONTINUE ELSEIF(ICASPL.EQ.'GEKS')THEN DO4160I=1,NPERC QPTEMP=QP(I)/100.0 CALL GEPPPF(QPTEMP,SHAPE1,MINMAX,IGEPDF,XPERC(I)) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4160 CONTINUE ELSEIF(ICASPL.EQ.'IWKS')THEN DO4170I=1,NPERC QPTEMP=QP(I)/100.0 CALL IWEPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4170 CONTINUE ELSEIF(ICASPL.EQ.'CSKS')THEN DO4180I=1,NPERC QPTEMP=QP(I)/100.0 CALL CHSPPF(QPTEMP,INT(SHAPE1+0.5),XPERC(I)) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4180 CONTINUE ELSEIF(ICASPL.EQ.'CHKS')THEN DO4190I=1,NPERC QPTEMP=QP(I)/100.0 CALL CHPPF(QPTEMP,INT(SHAPE1+0.5),XPERC(I)) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4190 CONTINUE ELSEIF(ICASPL.EQ.'TKS')THEN DO4200I=1,NPERC QPTEMP=QP(I)/100.0 CCCCC CALL TPPF(QPTEMP,INT(SHAPE1+0.5),XPERC(I)) CALL TPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4200 CONTINUE ELSEIF(ICASPL.EQ.'EEKS')THEN DO4210I=1,NPERC QPTEMP=QP(I)/100.0 CALL GEEPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4210 CONTINUE ELSEIF(ICASPL.EQ.'FLKS')THEN DO4220I=1,NPERC QPTEMP=QP(I)/100.0 CALL FLPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4220 CONTINUE ELSEIF(ICASPL.EQ.'E2KS')THEN DO4230I=1,NPERC QPTEMP=QP(I)/100.0 CALL EV2PPF(QPTEMP,SHAPE1,MINMAX,XPERC(I)) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4230 CONTINUE ELSEIF(ICASPL.EQ.'WAKS')THEN DO4240I=1,NPERC QPTEMP=QP(I)/100.0 CALL WALPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4240 CONTINUE ELSEIF(ICASPL.EQ.'PAKS')THEN DO4250I=1,NPERC QPTEMP=QP(I)/100.0 CALL PARPPF(QPTEMP,SHAPE1,AMU,XPERC(I)) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4250 CONTINUE ELSEIF(ICASPL.EQ.'P2KS')THEN DO4255I=1,NPERC QPTEMP=QP(I)/100.0 CALL PA2PPF(QPTEMP,SHAPE1,AMU,XPERC(I)) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4255 CONTINUE ELSEIF(ICASPL.EQ.'LAKS')THEN DO4260I=1,NPERC QPTEMP=QP(I)/100.0 CALL LAMPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4260 CONTINUE ELSEIF(ICASPL.EQ.'BRKS')THEN DO4270I=1,NPERC QPTEMP=QP(I)/100.0 CALL BRAPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4270 CONTINUE ELSEIF(ICASPL.EQ.'REKS')THEN DO4280I=1,NPERC QPTEMP=QP(I)/100.0 CALL RECPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4280 CONTINUE ELSEIF(ICASPL.EQ.'ERKS')THEN DO4290I=1,NPERC QPTEMP=QP(I)/100.0 CALL ERRPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4290 CONTINUE ELSEIF(ICASPL.EQ.'TRKS')THEN ZLOWLM=PPA0 ZUPPLM=PPA0 + PPA1 DO4300I=1,NPERC QPTEMP=QP(I)/100.0 CALL TRIPPF(QPTEMP,SHAPE1,ZLOWLM,ZUPPLM,XPERC(I)) CCCCC XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4300 CONTINUE ELSEIF(ICASPL.EQ.'LLKS')THEN DO4310I=1,NPERC QPTEMP=QP(I)/100.0 CALL LLGPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4310 CONTINUE ELSEIF(ICASPL.EQ.'DWKS')THEN DO4320I=1,NPERC QPTEMP=QP(I)/100.0 CALL DWEPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4320 CONTINUE ELSEIF(ICASPL.EQ.'FTKS')THEN DO4330I=1,NPERC QPTEMP=QP(I)/100.0 CALL FTPPF(QPTEMP,INT(SHAPE1+0.5),XPERC(I)) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4330 CONTINUE ELSEIF(ICASPL.EQ.'SDKS')THEN DO4340I=1,NPERC QPTEMP=QP(I)/100.0 CALL SDEPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4340 CONTINUE ELSEIF(ICASPL.EQ.'ADKS')THEN DO4350I=1,NPERC QPTEMP=QP(I)/100.0 CALL ADEPPF(QPTEMP,SHAPE1,IADEDF,XPERC(I)) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4350 CONTINUE ELSEIF(ICASPL.EQ.'GVKS')THEN DO4360I=1,NPERC QPTEMP=QP(I)/100.0 CALL GEVPPF(QPTEMP,SHAPE1,MINMAX,XPERC(I)) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4360 CONTINUE ELSEIF(ICASPL.EQ.'LXKS')THEN DO4370I=1,NPERC QPTEMP=QP(I)/100.0 CALL LDEPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4370 CONTINUE ELSEIF(ICASPL.EQ.'PFKS')THEN DO4380I=1,NPERC QPTEMP=QP(I)/100.0 CALL POWPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4380 CONTINUE ELSEIF(ICASPL.EQ.'VMKS')THEN DO4390I=1,NPERC QPTEMP=QP(I)/100.0 CALL VONPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4390 CONTINUE ELSEIF(ICASPL.EQ.'WCKS')THEN DO4400I=1,NPERC QPTEMP=QP(I)/100.0 CALL WCAPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4400 CONTINUE ELSEIF(ICASPL.EQ.'GLKS')THEN DO4410I=1,NPERC QPTEMP=QP(I)/100.0 CALL GLOPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4410 CONTINUE ELSEIF(ICASPL.EQ.'GZKS')THEN DO4420I=1,NPERC QPTEMP=QP(I)/100.0 CALL HFLPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4420 CONTINUE ELSEIF(ICASPL.EQ.'DGKS')THEN DO4430I=1,NPERC QPTEMP=QP(I)/100.0 CALL DGAPPF(QPTEMP,SHAPE1,XPERC(I)) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4430 CONTINUE ELSEIF(ICASPL.EQ.'PNKS')THEN S=1.0 DO4440I=1,NPERC QPTEMP=QP(I)/100.0 CALL PNRPPF(QPTEMP,SHAPE1,S,XPERC(I)) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4440 CONTINUE ELSEIF(ICASPL.EQ.'G2KS')THEN DO4450I=1,NPERC QPTEMP=QP(I)/100.0 CALL GL2PPF(DBLE(QPTEMP),DBLE(SHAPE1),DPPF) XPERC(I)=REAL(DPPF) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4450 CONTINUE ELSEIF(ICASPL.EQ.'G3KS')THEN DO4460I=1,NPERC QPTEMP=QP(I)/100.0 CALL GL3PPF(DBLE(QPTEMP),DBLE(SHAPE1),DPPF) XPERC(I)=REAL(DPPF) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4460 CONTINUE ELSEIF(ICASPL.EQ.'MAKS')THEN DO4470I=1,NPERC QPTEMP=QP(I)/100.0 CALL MAXPPF(QPTEMP,SHAPE1,PPF) XPERC(I)=PPF XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4470 CONTINUE ENDIF ENDIF C ******************* C ** STEP 90-- ** C ** EXIT ** C ******************* C 9000 CONTINUE C RETURN END SUBROUTINE DPJBK2(Y,X,N, 1ICASPL,IMETHD,IPPCDP,MAXOBV,MINMAX, 1Y2,X2,Y3,X3, 1NHOR1,NHOR2,KSLOC,KSSCAL, 1QP,XPERC,NPERC, 1PPA0SV,PPA1SV,SHAPE1,SHAPE2,AMINKS, 1IBUGG3,ISUBRO,IERROR) C C PURPOSE--FOR A GIVEN BOOTSTRAP SAMPLE, GENERATE THE KS PLOT C TO ESTIMATE THE TWO SHAPE, LOCATION, AND SCALE C PARAMETERS. THE LOCATION AND SCALE PARAMETERS CAN C OPTIONALLY BE SPECIFIED IN ADVANCE. ONLY UNCENSORED C DATA IS CURRENTLY SUPPORTED. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2005/2 C ORIGINAL VERSION--FEBRUARY 2005. C C SUPPORTED DISTRIBUTIONS ARE: C C FOLLOWING ARE ACTIVE C 1) G-AND-H C 2) INVERSE GAUSSIAN C 3) GENERALIZED GAMMA C 4) BETA C 5) F C 6) FOLDED NORMAL C C FOLLOWING ARE DISTRIBUTIONS THAT COULD POTENTIALLY C BE ADDED C 7) GOMPERTZ C 8) EXPONENTIAL POWER C 9) POWER LOGNORMAL C 10) ALPHA C 11) EXPONENTIATED WEIBULL C 12) JOHNSON SB C 13) JOHNSON SU C 14) TWO-SIDED POWER C 15) RECIPROCAL INVERSE GAUSSIAN C 16) SKEW T C 17) INVERTED BETA C 18) LOG-SKEW-NORMAL C 19) NON-CENTRAL T C 20) NON-CENTRAL CHI-SQUARE C 21) FOLDED CAUCHY C 22) TRUNCATED EXPONENTIAL C (ASSUME TRUNCATION POINT X0 IS KNOWN) C 23) GOMPERTZ-MAKEHAM (FOR MEEKER REPARAMETERIZATION TO C CASE WITH TWO SHAPE PARAMETERS AND SCALE PARAMETER) C 24) GENERALIZED ASYMMETRIC LAPLACE C 25) GENERALIZED MCLEISH C 26) GENERALIZED LAMBDA C NOTE: STILL BEING TESTED C 27) HYPERBOLIC (NOT WORKING) C C FOR THE KS PLOT, ONLY UNCENSORED DATA IS CURRENTLY C SUPPORTED. C C------------------------------------------------------------------ C CHARACTER*4 ICASPL CHARACTER*4 IMETHD CHARACTER*4 IBUGG3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C DIMENSION Y(*) DIMENSION X(*) DIMENSION Y2(*) DIMENSION X2(*) DIMENSION Y3(*) DIMENSION X3(*) DIMENSION QP(*) DIMENSION XPERC(*) C REAL KSLOC REAL KSSCAL C DOUBLE PRECISION DP DOUBLE PRECISION DPPF C DOUBLE PRECISION DM DOUBLE PRECISION DTEMP1 DOUBLE PRECISION DTEMP2 C CHARACTER*30 IDIST C CHARACTER*4 IWRITE CHARACTER*4 ISTEPN CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 IHP CHARACTER*4 IHP2 CHARACTER*4 LOWLTY CHARACTER*4 UPPLTY C INCLUDE 'DPCOMC.INC' 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='DPJB' ISUBN2='K2 ' IWRITE='OFF' IF(NP.GT.0)THEN DO410I=1,NP XPERC(I)=0.0 410 CONTINUE ENDIF AMINKS=CPUMAX C IF(ICASPL.EQ.'P2KS' .OR. ICASPL.EQ.'PAKS')THEN IF(KSLOC.EQ.CPUMIN .AND. KSSCAL.EQ.CPUMIN)THEN KSLOC=0.0 KSSCAL=1.0 ENDIF ENDIF C ************************************************** C ** STEP 1-- ** C ** IF SET PPCC Y PLOT DATA POINTS COMMAND ** C ** WAS ENTERED, THIN DATA SET BY COMPUTING ** C ** PERCENTILES OF THE DATA. ONLY DO THIS FOR ** C ** THE UNCENSORED CASE. ** C ************************************************** C ISTEPN='1' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBK2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IPPCDP.GT.0)THEN NP=MAX(20,IPPCDP) NP=MIN(NP,N) CALL SORT(Y,N,Y2) ASTRT=0.0 ASTOP=100.0 AINC=(ASTOP - ASTRT)/REAL(NP+1) IWRITE='OFF' DO100I=1,NP P100=ASTRT + REAL(I)*AINC CALL PERCEN(P100,Y2,N,IWRITE,X3,MAXOBV, 1 APERC,IBUGG3,IERROR) X2(I)=APERC 100 CONTINUE N=NP DO105I=1,N Y(I)=X2(I) 105 CONTINUE ENDIF C IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'JBK2')THEN WRITE(ICOUT,113)IPPCDP,NP,N 113 FORMAT(' IPPCDP, NP, N = ',3I8) CALL DPWRST('XXX','BUG ') DO117I=1,N WRITE(ICOUT,118)I,Y(I) 118 FORMAT(' I, Y(I) = ',I8,G15.7) CALL DPWRST('XXX','BUG ') 117 CONTINUE ENDIF C 999 FORMAT(1X) C CALL MEDIAN(Y,N,IWRITE,X2,MAXOBV,XMED,IBUGG3,IERROR) CALL SORT(Y,N,Y) CALL UNIMED(N,X) XMIN=Y(1) XMAX=Y(N) C C **************************************************** C ** STEP 2-- ** C ** EXTRACT RANGE FOR SHAPE PARAMETER ** C **************************************************** C ISTEPN='2' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBK2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICNT=0 AMINKS=CPUMAX C IF(ICASPL.EQ.'GHKS')THEN C NUMDI1=21 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=41 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 IF(NHOR1.GT.0)NUMDIS=NHOR1 C IDIST='G-H' IHP='G1 ' IHP2=' ' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' ADEF=-1.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='G2 ' IHP2=' ' ADEF=1.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='H1 ' IHP2=' ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' ADEF=0.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE3,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='H2 ' IHP2=' ' ADEF=1.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE4,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ELSEIF(ICASPL.EQ.'FKS')THEN C IDIST='F ' IHP='NU11' IHP2=' ' ILOWLM=1 IUPPLM=I1MACH(9) LOWLTY='>= ' UPPLTY='<= ' IDEF=1 CALL PARCI2(IHP,IHP2,IDIST,IVAL1,IDEF,ILOWLM,IUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='NU12' IHP2=' ' IDEF=25 CALL PARCI2(IHP,IHP2,IDIST,IVAL2,IDEF,ILOWLM,IUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='NU21' IHP2=' ' IDEF=1 CALL PARCI2(IHP,IHP2,IDIST,IVAL3,IDEF,ILOWLM,IUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='NU22' IHP2=' ' IDEF=25 CALL PARCI2(IHP,IHP2,IDIST,IVAL4,IDEF,ILOWLM,IUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 VALUE1=REAL(IVAL1) VALUE2=REAL(IVAL2) VALUE3=REAL(IVAL3) VALUE4=REAL(IVAL4) C NUMDI1=IVAL2 - IVAL1 + 1 IF(NHOR1.GT.0)NUMDI1=NHOR1 IF(NUMDI1.LT.10)NUMDI1=10 ANMDI1=NUMDI1 NUMDI2=IVAL4 - IVAL3 + 1 IF(NHOR2.GT.0)NUMDI2=NHOR2 IF(NUMDI2.LT.10)NUMDI2=10 ANMDI2=NUMDI2 C ELSEIF(ICASPL.EQ.'IGKS')THEN C NUMDI1=50 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=50 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 IF(NHOR1.GT.0)NUMDIS=NHOR1 C IDIST='INVERSE GAUSSIAN' IHP='GAMM' IHP2='A1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,VALUE1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='GAMM' IHP2='A2 ' ADEF=25.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='MU1 ' IHP2=' ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,VALUE3,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='MU2 ' IHP2=' ' ADEF=25.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE4,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ELSEIF(ICASPL.EQ.'BEKS')THEN C NUMDI1=25 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=25 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 IF(NHOR1.GT.0)NUMDIS=NHOR1 C IDIST='BETA' IHP='ALPH' IHP2='A1 ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,VALUE1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='ALPH' IHP2='A2 ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='BETA' IHP2='1 ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,VALUE3,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='BETA' IHP2='2 ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE4,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ELSEIF(ICASPL.EQ.'GGKS')THEN C NUMDI1=25 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=25 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 IF(NHOR1.GT.0)NUMDIS=NHOR1 C IDIST='GENERALIZED GAMMA' IHP='ALPH' IHP2='A1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,VALUE1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='ALPH' IHP2='A2 ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='C1 ' IHP2=' ' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.1 CALL PARCH2(IHP,IHP2,IDIST,VALUE3,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IF(C1.EQ.0.0)C1=ADEF C IHP='C2 ' IHP2=' ' ADEF=3.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ELSEIF(ICASPL.EQ.'FNKS')THEN C NUMDI1=51 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=51 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 IF(NHOR1.GT.0)NUMDIS=NHOR1 C IDIST='FOLDED NORMAL' IHP='MU1 ' IHP2=' ' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' ADEF=-25.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='MU2 ' IHP2=' ' ADEF=25.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='SD1 ' IHP2=' ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,VALUE3,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='SD2 ' IHP2=' ' ADEF=25.0 CALL PARCH2(IHP,IHP2,IDIST,VALUE4,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ELSE PPA0=0.0 PPA1=1.0 SHAPE1=1.0 CORRMX=0.0 GOTO9000 ENDIF C C **************************************************** C ** STEP 3-- ** C ** GENERATE KS PLOT FOR GIVEN DISTRIBUTION ** C **************************************************** C ISTEPN='3' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBK2')THEN CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) WRITE(ICOUT,213)N,VALUE1,VALUE2 213 FORMAT(' N,VALUE1, VALUE2 = ',I8,2G15.7) CALL DPWRST('XXX','BUG ') ENDIF C IFLAG=0 ANUMDI=NUMDI1 ANUMD2=NUMDI2 DP=-1.0D0 DPPF=0.0D0 C DO1800IDIS=1,NUMDI1 C AIDIS=IDIS VAL1=VALUE1+((AIDIS-1.0)/(ANUMDI-1.0))*(VALUE2-VALUE1) C DO1890IDIS2=1,NUMDI2 AIDI2=IDIS2 VAL2=VALUE3+((AIDI2-1.0)/(ANUMD2-1.0))*(VALUE4-VALUE3) ICNT=0 C IF(ICASPL.EQ.'GHKS')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 C DO1011I=1,N ICNT=ICNT+1 CALL GHPPF(X(I),VAL1,VAL2,X2(ICNT),DBLE(X(I)),DPPF) Y2(ICNT)=Y(I) 1011 CONTINUE C ELSEIF(ICASPL.EQ.'FKS')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 C DO1021I=1,N ICNT=ICNT+1 CALL FPPF(X(I),INT(VAL1+0.5),INT(VAL2+0.5),X2(ICNT)) Y2(ICNT)=Y(I) 1021 CONTINUE C ELSEIF(ICASPL.EQ.'IGKS')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 C DO1031I=1,N ICNT=ICNT+1 CALL IGPPF(X(I),VAL1,VAL2,X2(ICNT)) Y2(ICNT)=Y(I) 1031 CONTINUE C ELSEIF(ICASPL.EQ.'GGKS')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 C DO1041I=1,N ICNT=ICNT+1 CALL GGDPPF(X(I),VAL1,VAL2,X2(ICNT)) Y2(ICNT)=Y(I) 1041 CONTINUE C ELSEIF(ICASPL.EQ.'BEKS')THEN AMIN=0.0 AMAX=1.0 IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 C DO1051I=1,N ICNT=ICNT+1 CALL BETPPF(X(I),VAL1,VAL2,X2(ICNT)) Y2(ICNT)=Y(I) 1051 CONTINUE C ELSEIF(ICASPL.EQ.'FNKS')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1500 C DO1061I=1,N ICNT=ICNT+1 CALL FNRPPF(X(I),VAL1,VAL2,X2(ICNT)) Y2(ICNT)=Y(I) 1061 CONTINUE C ENDIF C C ************************************************** C ** STEP 4-- ** C ** COMPUTE MINIMUM KS TO FIND VALUE OF SHAPE ** C ** PARAMETERS AND THEN ** C ** COMPUTE FITTED LINE TO PROBABILITY PLOT ** C ** TO ESTIMATE LOCATION AND SCALE ** C ************************************************** C ISTEPN='4' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBK2') 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C 1500 CONTINUE NTEMP=ICNT C IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBK2')THEN WRITE(ICOUT,2001)ICNT,NTEMP 2001 FORMAT('ICNT,NTEMP = ',2I8) CALL DPWRST('XXX','BUG ') IF(NTEMP.GE.1)THEN DO2110I=1,NTEMP WRITE(ICOUT,2011)I,Y2(I),X2(I) 2011 FORMAT('I,Y2(I),X2(I) = ',I8,2G15.7) CALL DPWRST('XXX','BUG ') 2110 CONTINUE ENDIF ENDIF C CCCCC DETERMINE LOCATION AND SCALE PARAMETERS. CCCCC 1) USER SPECIFIED KSLOC AND KSSCALE CCCCC 2) FIT A LINE TO THE PROBABILITY PLOT AND USE INTERCEPT CCCCC AND SLOPE CCCCC 3) FOR BOUNDED DISTRIBUTIONS, CHECK THAT XMIN AND XMAX CCCCC WILL BE IN RANGE. IF NOT, SET LOCATION TO MINIMUM CCCCC AND SCALE TO MAXIMUM - MINIMUM C EPS=0.000001 IF((KSLOC.EQ.CPUMIN .OR. KSSCAL.EQ.CPUMIN) .AND. 1 IFLAG.EQ.0)THEN C C HANDLE BETA SEPARATELY C IF(ICASPL.EQ.'BECP')THEN IF(XMIN.GE.0.0 .AND. XMIN.LE.1.0 .AND. 1 XMAX.GE.0.0 .AND. XMAX.LE.1.0)THEN A0TEMP=0.0 A1TEMP=1.0 ELSE A0TEMP=XMIN-EPS A1TEMP=XMAX+EPS ENDIF C C HANDLE CASE WHERE DOMAIN BOUNDED BOTH ABOVE AND BELOW. SOLVE C C (XMIN-A0)/A1 = AMIN C (XMAX-A0)/A1 = AMAX C ELSEIF(AMIN.GT.CPUMIN .AND. AMAX.LT.CPUMAX)THEN CALL LINFI2(Y2,X2,NTEMP, 1 A0TEMP,A1TEMP, 1 ISUBRO,IBUGG3,IERROR) IF((XMIN-A0TEMP)/A1TEMP.LT.AMIN .OR. 1 (XMAX-A0TEMP)/A1TEMP.GT.AMAX)THEN CMIN=AMIN CMAX=AMAX CONST=CMIN/CMAX A0TEMP=(XMIN-CONST*XMAX)/(1.0+CONST) - EPS A1TEMP=(XMAX-A0TEMP)/CMAX + EPS ENDIF C C HANDLE CASE WHERE DOMAIN BOUNDED ON MINIMUM ONLY C ELSEIF(AMIN.GT.CPUMIN .AND. AMAX.EQ.CPUMAX)THEN CALL LINFI2(Y2,X2,NTEMP, 1 A0TEMP,A1TEMP, 1 ISUBRO,IBUGG3,IERROR) IF((XMIN-A0TEMP)/A1TEMP.LT.AMIN)THEN A0TEMP=XMIN-EPS ENDIF C C HANDLE CASE WHERE DOMAIN BOUNDED ON MAXIMUM ONLY C ELSEIF(AMIN.EQ.CPUMIN .AND. AMAX.LT.CPUMAX)THEN CALL LINFI2(Y2,X2,NTEMP, 1 A0TEMP,A1TEMP, 1 ISUBRO,IBUGG3,IERROR) CTEMP=(XMAX-A0TEMP)/A1TEMP IF(CTEMP.GE.AMAX)THEN A0TEMP=(XMAX+EPS) - A1TEMP*AMAX ENDIF C C HANDLE UNBOUNDED CASE C ELSE CALL LINFI2(Y2,X2,NTEMP, 1 A0TEMP,A1TEMP, 1 ISUBRO,IBUGG3,IERROR) ENDIF C ELSE A0TEMP=KSLOC A1TEMP=KSSCAL ENDIF C J=1 X3(J)=Y(1) Y3(J)=0.0 J=2 X3(J)=Y(1) Y3(J)=1.0/REAL(N) DO200I=2,N J=J+1 X3(J)=Y(I) Y3(J)=REAL(I-1)/REAL(N) J=J+1 X3(J)=Y(I) Y3(J)=REAL(I)/REAL(N) 200 CONTINUE NTEMP=J C PPA0=A0TEMP PPA1=A1TEMP DM=0.0D0 C IF(ICASPL.EQ.'GHKS')THEN DO1610I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL GHCDF(XL,VAL1,VAL2,XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1610 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'IGKS')THEN DO1620I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL IGCDF(XL,VAL1,VAL2,XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1620 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'GDKS')THEN DO1630I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL GGDCDF(XL,VAL1,VAL2,XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1630 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'BEKS')THEN DO1640I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL BETCDF(XL,VAL1,VAL2,XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1640 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'FKS')THEN DO1650I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL FCDF(XL,VAL1,VAL2,XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1650 CONTINUE STAT=REAL(DM) ELSEIF(ICASPL.EQ.'FNKS')THEN DO1660I=1,NTEMP XL=X3(I) XL=(XL-PPA0)/PPA1 CALL FNRCDF(XL,VAL1,VAL2,XOUT1) DTEMP1=DBLE(Y3(I)) DTEMP2=DBLE(XOUT1) DM=MAX(DABS(DTEMP1-DTEMP2),DM) 1660 CONTINUE STAT=REAL(DM) ENDIF C IF(STAT.LT.AMINKS)THEN AMINKS=STAT SHAPE1=VAL1 SHAPE2=VAL2 PPA0SV=PPA0 PPA1SV=PPA1 ENDIF C 1890 CONTINUE 1800 CONTINUE C C ************************************************** C ** STEP 5-- ** C ** COMPUTE SELECTED PERCENTILES ** C ************************************************** C ISTEPN='5' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBK2') 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NPERC.GT.0)THEN IF(ICASPL.EQ.'GHKS')THEN DO4110I=1,NPERC QPTEMP=QP(I)/100.0 CALL GHPPF(QPTEMP,SHAPE1,SHAPE2,XPERC(I),DBLE(QPTEMP),DPPF) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4110 CONTINUE ELSEIF(ICASPL.EQ.'IGKS')THEN DO4120I=1,NPERC QPTEMP=QP(I)/100.0 CALL IGPPF(QPTEMP,SHAPE1,SHAPE2,XPERC(I)) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4120 CONTINUE ELSEIF(ICASPL.EQ.'GGKS')THEN DO4130I=1,NPERC QPTEMP=QP(I)/100.0 CALL GGDPPF(QPTEMP,SHAPE1,SHAPE2,XPERC(I)) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4130 CONTINUE ELSEIF(ICASPL.EQ.'BEKS')THEN DO4140I=1,NPERC QPTEMP=QP(I)/100.0 CALL BETPPF(QPTEMP,SHAPE1,SHAPE2,XPERC(I)) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4140 CONTINUE ELSEIF(ICASPL.EQ.'FKS')THEN DO4150I=1,NPERC QPTEMP=QP(I)/100.0 CALL FPPF(QPTEMP,INT(SHAPE1+0.5),INT(SHAPE2+0.5),XPERC(I)) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4150 CONTINUE ELSEIF(ICASPL.EQ.'FNKS')THEN DO4160I=1,NPERC QPTEMP=QP(I)/100.0 CALL FNRPPF(QPTEMP,SHAPE1,SHAPE2,XPERC(I)) XPERC(I)=PPA0SV + PPA1SV*XPERC(I) 4160 CONTINUE ENDIF ENDIF C ******************* C ** STEP 90-- ** C ** EXIT ** C ******************* C 9000 CONTINUE C RETURN END SUBROUTINE DPJBML(Y,X,N,ICASPL,ICENSO,MAXNXT,MINMAX,PMAXLO, 1Y2,X2, 1DTEMP1, 1ALOC,SCALE, 1QP,XQP,NP, 1IBUGG3,ISUBRO,IERROR) C C PURPOSE--FOR A GIVEN BOOTSTRAP SAMPLE, GENERATE MAXIMUM C LIKELIHOOD ESTIMATES FOR LOCATION (ALOC) AND C SCALE (SCALE). CENSORED ML ESTIMATES ARE SUPPORTED C FOR A FEW DISTRIBUTIONS C C SUPPORTED DISTRIBUTIONS ARE: C C 1) NORMAL C 2) UNIFORM C 3) CAUCHY C 4) LAPLACE (DOUBLE EXPONENTIAL) C 5) LOGISTIC C 6) GUMBEL (EXTREME VALUE TYPE 1) C 7) EXPONENTIAL C 8) RAYLEIGH C 9) FOLDED NORMAL C 10) MAXWELL C C 1) CENSORED NORMAL C 2) CENSORED EXPONENTIAL C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2005/1 C ORIGINAL VERSION--JANUARY 2005. C UPDATED --AUGUST 2005. ADD MAXWELL C C--------------------------------------------------------------------- C CHARACTER*4 ICASPL CHARACTER*4 ICENSO CHARACTER*4 IBUGG3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR CHARACTER*4 ICENS2 C DIMENSION Y(*) DIMENSION X(*) DIMENSION Y2(*) DIMENSION X2(*) DIMENSION QP(*) DIMENSION XQP(*) DOUBLE PRECISION DTEMP1(*) C DOUBLE PRECISION DSUM DOUBLE PRECISION DSUM2 DOUBLE PRECISION DTEMP DOUBLE PRECISION TOL DOUBLE PRECISION XPAR(2) DOUBLE PRECISION FVEC(2) C DOUBLE PRECISION DN DOUBLE PRECISION DX DOUBLE PRECISION DSUM1 DOUBLE PRECISION DXSTRT DOUBLE PRECISION DAE DOUBLE PRECISION DRE DOUBLE PRECISION DXLOW DOUBLE PRECISION DXUP DOUBLE PRECISION XLOWSV DOUBLE PRECISION XUPSV C INTEGER IN DOUBLE PRECISION XBAR COMMON/EV1CO2/XBAR,MINMX2,IN COMMON/NORCML/IR C DOUBLE PRECISION EV1FU2 EXTERNAL LOGFUN EXTERNAL CAUFUN EXTERNAL EV1FU2 EXTERNAL NORFUN C EXTERNAL FNRFUN EXTERNAL RANGE C CHARACTER*4 IWRITE CHARACTER*4 ISTEPN CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 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 DATA PI/3.14159265358979/ C C-----START POINT----------------------------------------------------- C ISUBN1='DPJB' ISUBN2='ML ' IWRITE='OFF' IF(NP.GT.0)THEN DO410I=1,NP XQP(I)=0.0 410 CONTINUE ENDIF C C ************************************************** C ** STEP 1-- ** C ** PROCESS THE CENSORING VARIABLE. ** C ************************************************** C ISTEPN='1' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBML') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO1000I=1,N Y2(I)=Y(I) 1000 CONTINUE C IF(ICENSO.EQ.'ON')THEN IR=0 CALL DISTIN(X,N,IWRITE,X2,NDIST,IBUGG3,IERROR) IF(NDIST.EQ.1)THEN DO1102I=1,N X(I)=1.0 1102 CONTINUE IR=N ELSEIF(NDIST.EQ.2)THEN IF(X2(1).EQ.1.0 .OR. X2(2).EQ.1.0)THEN DO1103I=1,N IF(X(I).NE.1.0)THEN X(I)=2.0 ELSE IR=IR+1 ENDIF 1103 CONTINUE ELSE ATEMP1=MIN(X2(1),X2(2)) ATEMP2=MAX(X2(1),X2(2)) DO1108I=1,N IF(X(I).EQ.ATEMP1)THEN IR=IR+1 X(I)=1.0 ENDIF IF(X(I).EQ.ATEMP2)X(I)=2.0 1108 CONTINUE ENDIF ELSE WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1104) 1104 FORMAT('***** ERROR IN JACKNIFE/BOOTSTRAP MAXIMUM ', 1 'LIKELIHOOD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1105) 1105 FORMAT(' FOR CENSORED DATA, THE CENSORING VARIABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1106) 1106 FORMAT(' SHOULD CONTAIN AT MOST TWO DISTINCT VALUES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1107)NDIST 1107 FORMAT(' ',I8,' DISTINCT VALUES FOUND.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF CALL SORTC(Y2,X,N,Y,X) ELSE CALL SORT(Y2,N,Y) ENDIF ICENS2=ICENSO IF(IR.EQ.N)ICENS2='OFF' C C **************************************************** C ** STEP 2-- ** C ** GENERATE MAXIMUM LIKELIHOOD ESTIMATES ** C ** FOR GIVEN DISTRIBUTION ** C **************************************************** C ISTEPN='2' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBML') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASPL.EQ.'UNML')THEN IF(ICENS2.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1201) 1201 FORMAT('***** ERROR IN JACKNIFE/BOOTSTRAP MAXIMUM ', 1 'LIKELIHOOD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1203) 1203 FORMAT(' CENSORING NOT SUPPORTED FOR THE UNIFORM ', 1 'DISTRIBUTION.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' ELSE CALL MIDRAN(Y,N,IWRITE,XMIDR,IBUGG3,IERROR) CALL RANGE(Y,N,IWRITE,XRANG,IBUGG3,IERROR) HHAT=0.5*XRANG AHAT=XMIDR ALOC=AHAT - HHAT SCALE=AHAT + HHAT ENDIF ELSEIF(ICASPL.EQ.'NOML')THEN IF(ICENS2.EQ.'ON')THEN IF(IR.LT.1)THEN IERROR='YES' ELSE CALL MEAN(Y,IR,IWRITE,XMEAN,IBUGG3,IERROR) CALL SD(Y,IR,IWRITE,XSD,IBUGG3,IERROR) XPAR(1)=DBLE(XMEAN) XPAR(2)=DBLE(XSD) IOPT=2 TOL=1.0D-6 NVAR=2 NPRINT=-1 INFO=0 LWA=MAXNXT CALL DNSQE(NORFUN,JAC,IOPT,NVAR,XPAR,FVEC,TOL, 1 NPRINT,INFO, 1 DTEMP1,MAXNXT,Y,N) ALOC=REAL(XPAR(1)) SCALE=REAL(XPAR(2)) ENDIF ELSE CALL MEAN(Y,N,IWRITE,ALOC,IBUGG3,IERROR) CALL SD(Y,N,IWRITE,SCALE,IBUGG3,IERROR) ENDIF ELSEIF(ICASPL.EQ.'LOML')THEN IF(ICENS2.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1201) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1211) 1211 FORMAT(' CENSORING NOT SUPPORTED FOR THE LOGISTIC ', 1 'DISTRIBUTION.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' ELSE CALL MEAN(Y,N,IWRITE,XMEAN,IBUGG3,IERROR) CALL SD(Y,N,IWRITE,XSD,IBUGG3,IERROR) XPAR(1)=DBLE(XMEAN) XPAR(2)=DBLE((SQRT(3.0)/PI)*XSD) IOPT=2 TOL=1.0D-6 NVAR=2 NPRINT=-1 INFO=0 LWA=MAXNXT CALL DNSQE(LOGFUN,JAC,IOPT,NVAR,XPAR,FVEC,TOL,NPRINT,INFO, 1 DTEMP1,MAXNXT,Y,N) C ALOC=REAL(XPAR(1)) SCALE=REAL(XPAR(2)) ENDIF ELSEIF(ICASPL.EQ.'LAML')THEN IF(ICENS2.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1201) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1213) 1213 FORMAT(' CENSORING NOT SUPPORTED FOR THE LAPLACE ', 1 'DISTRIBUTION.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' ELSE CALL MEDIAN(Y,N,IWRITE,X2,MAXNXT,XMED,IBUGG3,IERROR) ALOC=XMED DSUM=0.0D0 DO2110I=1,N DSUM=DSUM + DBLE(ABS(Y(I) - XMED)) 2110 CONTINUE SCALE=REAL(DSUM)/REAL(N) ENDIF ELSEIF(ICASPL.EQ.'CAML')THEN IF(ICENS2.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1201) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1215) 1215 FORMAT(' CENSORING NOT SUPPORTED FOR THE CAUCHY ', 1 'DISTRIBUTION.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' ELSE CALL MEDIAN(Y,N,IWRITE,X2,MAXNXT,XMED,IBUGG3,IERROR) CALL MAD(Y,N,IWRITE,X2,MAXNXT,XMAD,IBUGG3,IERROR) AN=REAL(N) C IF(N.EQ.3)THEN CALL SORT(Y,N,X2) X1Z=X2(1) X2Z=X2(2) X3Z=X2(3) TERM1=X1Z*(X3Z-X2Z)**2 + X2Z*(X3Z-X1Z)**2 + 1 X3Z*(X2Z-X1Z)**2 TERM2=(X3Z-X2Z)**2 + (X3Z-X1Z)**2 + (X2Z-X1Z)**2 ALOC=TERM1/TERM2 TERM1=SQRT(3.0)*(X3Z-X2Z)*(X3Z-X1Z)*(X2Z-X1Z) SCALE=TERM1/TERM2 ELSEIF(N.EQ.3)THEN CALL SORT(Y,N,X2) X1Z=X2(1) X2Z=X2(2) X3Z=X2(3) X4Z=X2(4) TERM1=X2Z*X4Z - X1Z*X3Z TERM2=X4Z - X3Z + X2Z - X1Z ALOC=TERM1/TERM2 TERM1=(X4Z-X3Z)*(X3Z-X2Z)*(X2Z-X1Z)*(X4Z-X1Z) TERM2=(X4Z - X3Z + X2Z - X1Z)**2 ASCALE=TERM1/TERM2 ELSE XPAR(1)=DBLE(XMED) XPAR(2)=DBLE(XMAD) C IOPT=2 TOL=1.0D-6 NVAR=2 NPRINT=-1 INFO=0 LWA=MAXNXT CALL DNSQE(CAUFUN,JAC,IOPT,NVAR,XPAR,FVEC,TOL, 1 NPRINT,INFO, 1 DTEMP1,MAXNXT,Y,N) c ALOC=REAL(XPAR(1)) SCALE=REAL(XPAR(2)) ENDIF ENDIF ELSEIF(ICASPL.EQ.'EXML')THEN IF(ICENS2.EQ.'ON')THEN CALL MINIM(Y,N,IWRITE,XMIN,IBUGG3,IERROR) ALOC=XMIN DSUM1=0.0D0 DO3020I=1,N DSUM1=DSUM1 + DBLE(Y(I) - XMIN) 3020 CONTINUE IF(IR.GT.0)THEN SCALE=REAL(DSUM1/DBLE(IR)) ELSE SCALE=REAL(DSUM1/DBLE(N)) ENDIF ELSE CALL MEAN(Y,N,IWRITE,XMEAN,IBUGG3,IERROR) CALL MINIM(Y,N,IWRITE,XMIN,IBUGG3,IERROR) ALOC=XMIN SCALE=XMEAN-XMIN ENDIF ELSEIF(ICASPL.EQ.'GUML')THEN IF(ICENS2.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1201) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1219) 1219 FORMAT(' CENSORING NOT SUPPORTED FOR THE GUMBEL ', 1 'DISTRIBUTION.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' ELSE AN=REAL(N) C CALL MEAN(Y,N,IWRITE,XMEAN,IBUGG3,IERROR) CALL SD(Y,N,IWRITE,XSD,IBUGG3,IERROR) CALL MINIM(Y,N,IWRITE,XMIN,IBUGG3,IERROR) CALL MAXIM(Y,N,IWRITE,XMAX,IBUGG3,IERROR) C C MOMENT ESTIMATES (USED FOR STARTING VALUES) ARE: C C MUHAT = XBAR - 0.45006*SD C SHAT = 0.77970*SD C C THE MAXIMUM LIKELIHOOD ESTIMATES ARE: C C THE ML ESTIMATE OF THE SCALE PARAMETER IS THE SOLUTION TO C THE FOLLOWING EQUATION: C C FOR THE MAXIMUM CASE: C C SHAT - XBAR + SUM[i=1 to N][X(I)*EXP(-X(I)/SHAT)]/ C SUM[i=1 to N][EXP(-X(I)/SHAT)] = 0 C C FOR THE MINIMUM CASE: C C SHAT - XBAR + SUM[i=1 to N][X(I)*EXP(X(I)/SHAT)]/ C SUM[i=1 to N][EXP(X(I)/SHAT)] = 0 C C WITH C C SHAT = CURRENT ESTIMATE OF SCALE PARAMETER C XBAR = SAMPLE MEAN C N = SAMPLE SIZE C MINMAX = SPECIFY WHETHER MAXIMUM OR MINIMUM C CASE IS BEING ESTIMATED C C THE ML ESTIMATE OF LOCATION FOR THE MAXIMUM CASE IS C C MUHAT = -SHAT*LOG(SUM[i=1 to N][EXP(-X(I)/SHAT)]/N) C C THE ML ESTIMATE OF LOCATION FOR THE MINIMUM CASE IS C C MUHAT = -SHAT*LOG(SUM[i=1 to N][EXP(X(I)/SHAT)]/N) C C AN=REAL(N) DN=DBLE(N) IF(MINMAX.EQ.2)THEN UHATMO=XMEAN - 0.45006*XSD ELSE UHATMO=XMEAN + 0.45006*XSD ENDIF SCALMO=0.77970*XSD C XBAR=DBLE(XMEAN) MINMX2=MINMAX IN=N C DXSTRT=DBLE(SCALMO) DAE=2.0*0.000001D0*DXSTRT DRE=DAE IFLAG=0 DXLOW=DXSTRT/2.0D0 DXUP=2.0D0*DXSTRT ITBRAC=0 DO3104I=1,N DTEMP1(I)=DBLE(Y(I)) 3104 CONTINUE C 3105 CONTINUE XLOWSV=DXLOW XUPSV=DXUP CALL DFZER2(EV1FU2,DXLOW,DXUP,DXSTRT,DRE,DAE,IFLAG,DTEMP1) C IF(IFLAG.EQ.4 .AND. ITBRAC.LE.100)THEN DXLOW=XLOWSV/2.0D0 DXUP=2.0D0*XUPSV ITBRAC=ITBRAC+1 GOTO3105 ENDIF C IF(IFLAG.EQ.2)THEN C C NOTE: SUPPRESS THIS MESSAGE FOR NOW. CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,3111) C3111 FORMAT('***** WARNING FROM GUMBEL MAXIMUM ', CCCCC1 'LIKELIHOOD--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,3113) C3113 FORMAT(' ESTIMATE OF SIGMA MAY NOT BE COMPUTED TO ', CCCCC1 'DESIRED TOLERANCE.') CCCCC CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.3)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3121) 3121 FORMAT('***** WARNING FROM GUMBEL MAXIMUM LIKELIHOOD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3123) 3123 FORMAT(' ESTIMATE OF SCALE MAY BE NEAR A ', 1 'SINGULAR POINT.') CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.4)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3131) 3131 FORMAT('***** ERROR FROM GUMBEL MAXIMUM LIKELIHOOD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3133) 3133 FORMAT(' APPROPRIATE BRACKETING INTERVAL ', 1 'NOT FOUND.') CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.5)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3141) 3141 FORMAT('***** WARNING FROM GUMBEL MAXIMUM LIKELIHOOD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3143) 3143 FORMAT(' MAXIMUM ITERATIONS EXCEEDED.') CALL DPWRST('XXX','BUG ') ENDIF C SCALE=REAL(DXLOW) C DSUM1=0.0D0 IF(MINMAX.EQ.2)THEN DO3108I=1,N DX=-DBLE(Y(I)) DSUM1=DSUM1 + DEXP(DX/DBLE(SCALE)) 3108 CONTINUE DTERM1=-DBLE(SCALE)*DLOG(DSUM1/DN) ELSE DO3109I=1,N DX=DBLE(Y(I)) DSUM1=DSUM1 + DEXP(DX/DBLE(SCALE)) 3109 CONTINUE DTERM1=DBLE(SCALE)*DLOG(DSUM1/DN) ENDIF ALOC=REAL(DTERM1) ENDIF ELSEIF(ICASPL.EQ.'RAML')THEN IF(ICENS2.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1201) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1217) 1217 FORMAT(' CENSORING NOT SUPPORTED FOR THE RAYLEIGH ', 1 'DISTRIBUTION.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' ELSE CALL MINIM(Y,N,IWRITE,XMIN,IBUGG3,IERROR) ALOC=XMIN DSUM=0.0D0 DO2910I=1,N DSUM=DSUM + DBLE(Y(I) - ALOC)**2 2910 CONTINUE SCALE=REAL(DSQRT(DSUM/(2.0D0*DBLE(N)))) ENDIF ELSEIF(ICASPL.EQ.'MAML')THEN CCCCC OCTOBER 2006. PMAXLO SPECIFIES WHAT VALUE TO USE FOR LOCATION IF(ICENS2.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1201) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3117) 3117 FORMAT(' CENSORING NOT SUPPORTED FOR THE MAXWELL ', 1 'DISTRIBUTION.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' ELSE ALOC=PMAXLO CALL MINIM(Y,N,IWRITE,XMIN,IBUGG3,IERROR) IF(ALOC.EQ.CPUMIN)ALOC=XMIN IF(ALOC.GT.XMIN)ALOC=XMIN DSUM=0.0D0 DSUM2=0.0D0 DO3120I=1,N DSUM=DSUM + DBLE(Y(I) - ALOC)**2 DSUM2=DSUM2 + DBLE(Y(I) - AZERO)**2 3120 CONTINUE DTEMP=DSQRT(DSUM/(3.0D0*DBLE(N))) SCALE=REAL(DTEMP) CCCCC DTEMP=DSQRT(DSUM2/(3.0D0*DBLE(N))) CCCCC SCALEM2=REAL(DTEMP) ENDIF ELSEIF(ICASPL.EQ.'FNML')THEN IF(ICENS2.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1201) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3003) 3003 FORMAT(' CENSORING NOT SUPPORTED FOR THE FOLED ', 1 'NORMAL DISTRIBUTION.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' ELSE CALL MEAN(Y,N,IWRITE,XMEAN,IBUGG3,IERROR) CALL SD(Y,N,IWRITE,XSD,IBUGG3,IERROR) C XPAR(1)=DBLE(XMEAN) XPAR(2)=DBLE(XSD*XSD) C IOPT=2 TOL=1.0D-5 NVAR=2 NPRINT=-1 INFO=0 LWA=MAXNXT CALL DNSQE(FNRFUN,JAC,IOPT,NVAR,XPAR,FVEC,TOL,NPRINT,INFO, 1 DTEMP1,MAXNXT,Y,N) C ALOC=REAL(XPAR(1)) SCALE=REAL(DSQRT(XPAR(2))) ENDIF ELSE ALOC=0.0 SCALE=1.0 GOTO9000 ENDIF IF(IERROR.EQ.'YES')GOTO9000 C C ************************************************** C ** STEP 4-- ** C ** COMPUTE SELECTED PERCENTILES ** C ************************************************** C ISTEPN='4' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBPP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NP.GT.0)THEN IF(ICASPL.EQ.'NOML')THEN DO4110I=1,NP QPTEMP=QP(I)/100.0 CALL NORPPF(QPTEMP,XQP(I)) XQP(I)=ALOC + SCALE*XQP(I) 4110 CONTINUE ELSEIF(ICASPL.EQ.'UNML')THEN DO4120I=1,NP QPTEMP=QP(I)/100.0 CALL UNIPPF(QPTEMP,XQP(I)) XQP(I)=ALOC + SCALE*XQP(I) 4120 CONTINUE ELSEIF(ICASPL.EQ.'LOML')THEN DO4130I=1,NP QPTEMP=QP(I)/100.0 CALL LOGPPF(QPTEMP,XQP(I)) XQP(I)=ALOC + SCALE*XQP(I) 4130 CONTINUE ELSEIF(ICASPL.EQ.'LAML')THEN DO4140I=1,NP QPTEMP=QP(I)/100.0 CALL DEXPPF(QPTEMP,XQP(I)) XQP(I)=ALOC + SCALE*XQP(I) 4140 CONTINUE ELSEIF(ICASPL.EQ.'CAML')THEN DO4150I=1,NP QPTEMP=QP(I)/100.0 CALL CAUPPF(QPTEMP,XQP(I)) XQP(I)=ALOC + SCALE*XQP(I) 4150 CONTINUE ELSEIF(ICASPL.EQ.'EXML')THEN DO4170I=1,NP QPTEMP=QP(I)/100.0 CALL EXPPPF(QPTEMP,XQP(I)) XQP(I)=ALOC + SCALE*XQP(I) 4170 CONTINUE ELSEIF(ICASPL.EQ.'GUML')THEN DO4180I=1,NP QPTEMP=QP(I)/100.0 CALL EV1PPF(QPTEMP,MINMAX,XQP(I)) XQP(I)=ALOC + SCALE*XQP(I) 4180 CONTINUE ELSEIF(ICASPL.EQ.'COML')THEN DO4200I=1,NP QPTEMP=QP(I)/100.0 CALL COSPPF(QPTEMP,XQP(I)) XQP(I)=ALOC + SCALE*XQP(I) 4200 CONTINUE ELSEIF(ICASPL.EQ.'RAML')THEN DO4210I=1,NP QPTEMP=QP(I)/100.0 CALL RAYPPF(QPTEMP,XQP(I)) XQP(I)=ALOC + SCALE*XQP(I) 4210 CONTINUE ELSEIF(ICASPL.EQ.'FNML')THEN DO4220I=1,NP QPTEMP=QP(I)/100.0 CALL FNRPPF(QPTEMP,ALOC,SCALE,XQP(I)) 4220 CONTINUE ELSEIF(ICASPL.EQ.'MAML')THEN DO4230I=1,NP QPTEMP=QP(I)/100.0 CALL MAXPPF(QPTEMP,SCALE,XQP(I)) XQP(I)=ALOC + 1.0*XQP(I) 4230 CONTINUE ENDIF ENDIF C ******************* C ** STEP 90-- ** C ** EXIT ** C ******************* C 9000 CONTINUE C RETURN END SUBROUTINE DPJBM2(Y,X,N,ICASPL,ICENSO,MAXNXT,MINMAX,IGEPDF, 1Y2,X2, 1DTEMP1, 1SCALE,SHAPE, 1QP,XQP,NP, 1IPOTTO, 1IBUGG3,ISUBRO,IERROR) C C PURPOSE--FOR A GIVEN BOOTSTRAP SAMPLE, GENERATE MAXIMUM C LIKELIHOOD ESTIMATES FOR ONE SHAPE (SHAPE) AND C SCALE (SCALE). CENSORED ML ESTIMATES ARE SUPPORTED C FOR A FEW DISTRIBUTIONS C C ALSO SUPPORT CASE FOR TWO SHAPE PARAMETERS BUT C NO LOCATION OR SCALE PARAMETERS. C C SUPPORTED DISTRIBUTIONS ARE: C C 1) LOGNORMAL C 2) WEIBULL (MINIMUM) C 3) GAMMA C 4) GEOMETRIC EXTREME EXPONENTIAL C 5) FATIGUE LIFE C 6) INVERSE GAUSSIAN C 7) PARETO C 8) BETA C 9) GENERALIZED PARETO C A) MAXIMUM LIKELIHOOD C B) METHOD OF MOMENTS C C) DEHAAN C D) CME C 10) FRECHET (MAXIMUM) C 11) INVERTED WEIBULL C C 1) CENSORED LOGNORMAL C 2) CENSORED WEIBULL C 3) CENSORED GAMMA C 4) CENSORED INVERTED WEIBULL C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2005/1 C ORIGINAL VERSION--JANUARY 2005. C UPDATED --MARCH 2005. GENERALIZED PARETO C (ML, MOMENTS) C UPDATED --MAY 2005. GENERALIZED PARETO C (DEHAAN, CME) C UPDATED --AUGUST 2005. FIX TO PERCENT POINT OF PARETO C UPDATED --AUGUST 2005. INVERTED WEIBULL (THIS BASICALLY C USES THE WEIBULL CODE) C UPDATED --NOVEMBER 2006. FIX PERCENTILES FOR INVERSE GAUSSIAN C C--------------------------------------------------------------------- C CHARACTER*4 ICASPL CHARACTER*4 ICENSO CHARACTER*4 IGEPDF CHARACTER*4 IBUGG3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C DIMENSION Y(*) DIMENSION X(*) DIMENSION Y2(*) DIMENSION X2(*) DIMENSION QP(*) DIMENSION XQP(*) DOUBLE PRECISION DTEMP1(*) C DOUBLE PRECISION DSUM DOUBLE PRECISION DTERM1 DOUBLE PRECISION TOL DOUBLE PRECISION XPAR(2) DOUBLE PRECISION FVEC(2) C DOUBLE PRECISION DN DOUBLE PRECISION DR DOUBLE PRECISION DX DOUBLE PRECISION DXSTRT DOUBLE PRECISION DAE DOUBLE PRECISION DRE DOUBLE PRECISION DXLOW DOUBLE PRECISION DXUP DOUBLE PRECISION XSTRT DOUBLE PRECISION XSTART DOUBLE PRECISION XLOW DOUBLE PRECISION XUP DOUBLE PRECISION XLOWSV DOUBLE PRECISION XUPSV DOUBLE PRECISION AE DOUBLE PRECISION RE DOUBLE PRECISION DGAMM1 DOUBLE PRECISION DGAMM2 DOUBLE PRECISION DALPHA DOUBLE PRECISION DALPH2 DOUBLE PRECISION DSUM1 DOUBLE PRECISION DSUM2 DOUBLE PRECISION DSUM3 DOUBLE PRECISION DSUM4 DOUBLE PRECISION TBAR DOUBLE PRECISION H DOUBLE PRECISION DK C DOUBLE PRECISION WEIFUN DOUBLE PRECISION GAMFUN DOUBLE PRECISION GC1FUN DOUBLE PRECISION LG1FUN DOUBLE PRECISION GEEFUN DOUBLE PRECISION BETFUN DOUBLE PRECISION FLFUN DOUBLE PRECISION EV2UN EXTERNAL WEIFUN EXTERNAL GAMFUN EXTERNAL GC1FUN EXTERNAL LG1FUN EXTERNAL GEEFUN EXTERNAL BETFUN EXTERNAL FLFUN EXTERNAL GPAFUN EXTERNAL EV2FUN EXTERNAL SUM INTEGER IN DOUBLE PRECISION DWEISM COMMON/WEICOM/DWEISM,IN DOUBLE PRECISION DLOGGM COMMON/GAMCOM/DLOGGM DOUBLE PRECISION XBAR DOUBLE PRECISION DGEOME INTEGER IN2 INTEGER IR2 COMMON/GC1COM/XBAR,DGEOME,IN2,IR2 DOUBLE PRECISION C INTEGER IN3 INTEGER IM COMMON/LG1COM/C,IN3,IM COMMON /BETAML/ BETALL, BETAUL DOUBLE PRECISION DEV2SM COMMON/EV2COM/DEV2SM,INEV2 C CHARACTER*4 ICENS2 CHARACTER*4 IWRITE CHARACTER*4 ISTEPN CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C CHARACTER*4 IFEESV CHARACTER*4 IPRISV CHARACTER*4 ICAPSW CHARACTER*4 ICAPTY 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 DATA PI/3.14159265358979/ C C-----START POINT----------------------------------------------------- C ISUBN1='DPJB' ISUBN2='M2 ' IWRITE='OFF' SCALE=1.0 SHAPE=1.0 IR=0 IF(NP.GT.0)THEN DO410I=1,NP XQP(I)=0.0 410 CONTINUE ENDIF C C ************************************************** C ** STEP 1-- ** C ** PROCESS THE CENSORING VARIABLE. ** C ************************************************** C ISTEPN='1' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBM2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO1000I=1,N Y2(I)=Y(I) 1000 CONTINUE C IF(ICENSO.EQ.'ON')THEN IR=0 CALL DISTIN(X,N,IWRITE,X2,NDIST,IBUGG3,IERROR) IF(NDIST.EQ.1)THEN DO1102I=1,N X(I)=1.0 1102 CONTINUE IR=N ELSEIF(NDIST.EQ.2)THEN IF(X2(1).EQ.1.0 .OR. X2(2).EQ.1.0)THEN DO1103I=1,N IF(X(I).NE.1.0)THEN X(I)=2.0 ELSE IR=IR+1 ENDIF 1103 CONTINUE ELSE ATEMP1=MIN(X2(1),X2(2)) ATEMP2=MAX(X2(1),X2(2)) DO1108I=1,N IF(X(I).EQ.ATEMP1)THEN IR=IR+1 X(I)=1.0 ENDIF IF(X(I).EQ.ATEMP2)X(I)=2.0 1108 CONTINUE ENDIF ELSE WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1104) 1104 FORMAT('***** ERROR IN JACKNIFE/BOOTSTRAP MAXIMUM ', 1 'LIKELIHOOD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1105) 1105 FORMAT(' FOR CENSORED DATA, THE CENSORING VARIABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1106) 1106 FORMAT(' SHOULD CONTAIN AT MOST TWO DISTINCT VALUES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1107)NDIST 1107 FORMAT(' ',I8,' DISTINCT VALUES FOUND.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF CALL SORTC(Y2,X,N,Y,X) IF(ICASPL.EQ.'LNML')THEN IF(IR.LT.N)THEN AHOLD=Y(IR+1) DO1240I=IR+1,N IF(Y(I).NE.AHOLD)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1241) 1241 FORMAT('***** ERROR FROM CENSORED LOGNORMAL MAXIMUM ', 1 'LIKELIHOOD--') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1243) 1243 FORMAT(' CURRENTLY, ONLY SINGLY CENSORED DATA ', 1 'IS SUPPORTED FOR THE LOGNORMAL DISTRIBUTION.') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1245) 1245 FORMAT(' MULTIPLY CENSORED DATA WAS DETECTED.') CALL DPWRST('XXX','WRIT') IERROR='YES' GOTO9000 ENDIF 1240 CONTINUE C=DBLE(AHOLD) ENDIF ENDIF C ELSE CALL SORT(Y2,N,Y) ENDIF C ICENS2=ICENSO IF(IR.EQ.N)ICENS2='OFF' C C **************************************************** C ** STEP 2-- ** C ** GENERATE MAXIMUM LIKELIHOOD ESTIMATES ** C ** FOR GIVEN DISTRIBUTION ** C **************************************************** C ISTEPN='2' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBM2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASPL.EQ.'LNML')THEN IF(ICENS2.EQ.'ON')THEN AN=REAL(N) C C USE PARAMETERS ESTIMATED FROM FAILURE DATA AS STARTING VALUES C FOR EQUATION SOLVER. C DO1903I=1,IR X2(I)=LOG(Y(I)) 1903 CONTINUE C CALL MEAN(X2,IR,IWRITE,XMEAN,IBUGG3,IERROR) CALL SD(X2,IR,IWRITE,XSD,IBUGG3,IERROR) C XPAR(1)=DBLE(XMEAN) XPAR(2)=DBLE(XSD) C IN3=N IM=N-IR JAC=0 IOPT=2 TOL=1.0D-6 NVAR=2 NPRINT=-1 INFO=0 LWA=MAXNXT FVEC(1)=0.0D0 FVEC(2)=0.0D0 IF(IR.LT.N)THEN CALL DNSQE(LG1FUN,JAC,IOPT,NVAR,XPAR,FVEC,TOL,NPRINT,INFO, 1 DTEMP1,MAXNXT,Y,IR) UHATML=REAL(XPAR(1)) SCALE=EXP(UHATML) SHAPE=REAL(XPAR(2)) ELSE UHAT=XMEAN SCALE=EXP(XMEAN) SHAPE=XSD ENDIF C ELSE C C THE MAXIMUM LIKELIHOOD ESTIMATES ARE: C C NOTE THAT A COMMON PARAMETERIZATION USES C C U = LOG(SCALE) C C UHAT = (1/N)*SUM[i=1 to N][LOG(Y(I))] C SCALEHAT = EXP(UHAT) C SIGMAHAT = SQRT((1/N)*SUM[i=1 to N][(LOG(Y(I)) - UHAT)**2] C AN=REAL(N) DO2003I=1,N X2(I)=LOG(Y(I)) 2003 CONTINUE C CALL MEAN(X2,N,IWRITE,XMEAN,IBUGG3,IERROR) CALL SD(X2,N,IWRITE,XSD,IBUGG3,IERROR) UHAT=XMEAN SCALE=EXP(XMEAN) SHAPE=XSD ENDIF ELSEIF(ICASPL.EQ.'WEML')THEN IF(ICENS2.EQ.'ON')THEN C C FOR THE SHAPE PARAMETER, SOLVE THE EQUATION: C C (1/GHAT) - C SUM[i=1 to n][Y(I)**GHAT*LN(Y(I))]/SUM[i=1 to n][[Y(I)**GHAT] + C (1/N)*SUM[i=1 to n][LN(Y(I))] = 0 C C THEN C C SCALE = ((1/N)*SUM[i=1 to n][Y(I)**GHAT]) C C FOR STARTING VALUE, USE C C GHAT = 1.28/(STD DEV OF LOG(Y)) C DO2160I=1,N IF(Y(I).LE.0.0)THEN IERROR='YES' GOTO9000 ENDIF X2(I)=LOG(Y(I)) 2160 CONTINUE C CALL MEAN(Y,N,IWRITE,XMEAN,IBUGG3,IERROR) CALL SD(Y,N,IWRITE,XSD,IBUGG3,IERROR) CALL SD(X2,N,IWRITE,XLOGSD,IBUGG3,IERROR) C DSUM1=0.0D0 DO2161I=1,N DTEMP1(I)=DBLE(Y(I)) IF(X(I).EQ.1.0)DSUM1=DSUM1 + DLOG(DTEMP1(I)) 2161 CONTINUE DWEISM=DSUM1/DBLE(IR) XSTART=DBLE(1.28/XLOGSD) AE=2.0*0.000001D0*XSTART RE=AE IN=N IFLAG=0 XLOW=XSTART/2.0D0 XUP=2.0D0*XSTART ITBRAC=0 2165 CONTINUE XLOWSV=XLOW XUPSV=XUP CALL DFZER2(WEIFUN,XLOW,XUP,XSTART,RE,AE,IFLAG,DTEMP1) C IF(IFLAG.EQ.4 .AND. ITBRAC.LE.100)THEN XLOW=XLOWSV/2.0D0 XUP=2.0D0*XUPSV ITBRAC=ITBRAC+1 GOTO2165 ENDIF C IF(IFLAG.EQ.2)THEN C C NOTE: SUPPRESS THIS MESSAGE FOR NOW. CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,2111) C2111 FORMAT('***** WARNING FROM CENSORED WEIBULL MAXIMUM ', CCCCC1 'LIKELIHOOD--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,2113) C2113 FORMAT(' ESTIMATE OF GAMMA MAY NOT BE COMPUTED TO ', CCCCC1 'DESIRED TOLERANCE.') CCCCC CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.3)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2171) 2171 FORMAT('***** WARNING FROM CENSORED WEIBULL MAXIMUM ', 1 'LIKELIHOOD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2173) 2173 FORMAT(' ESTIMATE OF SHAPE PARAMETER MAY BE NEAR ', 1 'A SINGULAR POINT.') CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.4)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2181) 2181 FORMAT('***** ERROR FROM CENSORED WEIBULL MAXIMUM ', 1 'LIKELIHOOD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2183) 2183 FORMAT(' APPROPRIATE BRACKETING INTERVAL NOT FOUND.') CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.5)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2171) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2193) 2193 FORMAT(' MAXIMUM ITERATIONS EXCEEDED.') CALL DPWRST('XXX','BUG ') ENDIF C SHAPE=XLOW DSUM1=0.0D0 DO2168I=1,N DSUM1=DSUM1 + DBLE(Y(I)**SHAPE) 2168 CONTINUE SCALE=REAL((DSUM1/DBLE(IR))**DBLE(1.0D0/DBLE(SHAPE))) ELSE C C FOR THE SHAPE PARAMETER, SOLVE THE EQUATION: C C (1/GHAT) - C SUM[i=1 to n][Y(I)**GHAT*LN(Y(I))]/SUM[i=1 to n][[Y(I)**GHAT] + C (1/N)*SUM[i=1 to n][LN(Y(I))] = 0 C C THEN C C SCALE = ((1/N)*SUM[i=1 to n][Y(I)**GHAT]) C C FOR STARTING VALUE, USE C C GHAT = 1.28/(STD DEV OF LOG(Y)) C DO2110I=1,N IF(Y(I).LE.0.0)THEN IERROR='YES' GOTO9000 ENDIF X2(I)=LOG(Y(I)) 2110 CONTINUE C AN=REAL(N) C CALL MEAN(Y,N,IWRITE,XMEAN,IBUGG3,IERROR) CALL SD(Y,N,IWRITE,XSD,IBUGG3,IERROR) CALL SD(X2,N,IWRITE,XLOGSD,IBUGG3,IERROR) CALL SUM(X2,N,IWRITE,XLOGSM,IBUGG3,IERROR) CALL MINIM(Y,N,IWRITE,XMIN,IBUGG3,IERROR) C C ESTIMATES FOR 2-PARAMETER MODEL. USE DFZER2 TO FIND ROOT OF C THE EQUATION GIVEN ABOVE. C DO2101I=1,N DTEMP1(I)=DBLE(Y(I)) 2101 CONTINUE DWEISM=DBLE(XLOGSM/AN) DXSTRT=1.28D0/DBLE(XLOGSD) DAE=2.0*0.000001D0*DXSTRT DRE=DAE IN=N IFLAG=0 DXLOW=DXSTRT/2.0D0 DXUP=2.0D0*DXSTRT ITBRAC=0 2105 CONTINUE XLOWSV=DXLOW XUPSV=DXUP CALL DFZER2(WEIFUN,DXLOW,DXUP,DXSTRT,DRE,DAE,IFLAG,DTEMP1) C IF(IFLAG.EQ.4 .AND. ITBRAC.LE.100)THEN DXLOW=XLOWSV/2.0D0 DXUP=2.0D0*XUPSV ITBRAC=ITBRAC+1 GOTO2105 ENDIF C IF(IFLAG.EQ.2)THEN C C NOTE: SUPPRESS THIS MESSAGE FOR NOW. CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,2111) C2111 FORMAT('***** WARNING FROM WEIBULL MAXIMUM ', CCCCC1 'LIKELIHOOD--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,2113) C2113 FORMAT(' ESTIMATE OF SIGMA MAY NOT BE COMPUTED TO ', CCCCC1 'DESIRED TOLERANCE.') CCCCC CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.3)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2121) 2121 FORMAT('***** WARNING FROM WEIBULL MAXIMUM LIKELIHOOD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2123) 2123 FORMAT(' ESTIMATE OF SHAPE PARAMETER MAY BE NEAR ', 1 'A SINGULAR POINT.') CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.4)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2131) 2131 FORMAT('***** ERROR FROM WEIBULL MAXIMUM LIKELIHOOD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2133) 2133 FORMAT(' APPROPRIATE BRACKETING INTERVAL NOT FOUND.') CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.5)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2141) 2141 FORMAT('***** WARNING FROM WEIBULL MAXIMUM LIKELIHOOD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2143) 2143 FORMAT(' MAXIMUM ITERATIONS EXCEEDED.') CALL DPWRST('XXX','BUG ') ENDIF C SHAPE=REAL(DXLOW) DSUM=0.0D0 DO2108I=1,N DSUM=DSUM + DBLE(Y(I)**SHAPE) 2108 CONTINUE SCALE=REAL((DSUM/DBLE(N))**DBLE(1.0D0/DBLE(SHAPE))) CCCCC BN=1.0 + 2.2/AN**1.13 CCCCC GAMMBC=SHAPE/BN ENDIF ELSEIF(ICASPL.EQ.'GAML')THEN IF(ICENS2.EQ.'ON')THEN IM=N-IR IR2=IR C AR=REAL(IR) DR=DBLE(IR) AN=REAL(N) AM=REAL(IM) C C C THE MAXIMUM LIKELIHOOD EQUATIONS FOR THE CENSORED CASE ARE: C C R*XBAR/SHAT - R*GHAT + SUM[i=1 to M] C [Z(j)**GHAT*EXP(Z(j)/(GAMMA(GHAT) - G(Z(j),GHAT))] = 0 C C R*LOG(GEOMEAN/SHAT) - N*DIGAMMA(GHAT) + SUM[i=1 to M] C [(GAMMA(GHAT)*DIGAMMA(GHAT) J(Z(j),GHAT))/ C (GAMMA(GHAT) - G(Z(j),GHAT))] = 0 C C WHERE C C C XBAR = MEAN OF FAILURE DATA C GEOMEAN = GEOMETRIC MEAN OF FAILURE DATA C R = NUMBER OF FAILURES C M = NUMBER OF CENSORING TIMES C SHAT = FVEC(1) = CURRENT ESTIMATE OF SCALE PARAMETER C GHAT = FVEC(2) = CURRENT ESTIMATE OF SHAPE PARAMETER C Z(j) = jth CENSORING TIME C GAMMA = GAMMA FUNCTION C DIGAMMA = DIGAMMA FUNCTION C G(x,a) = INCOMPLETE GAMMA FUNCTION C J(X,a) = INTEGRAL[0 to x][t**(A-1)*LOG(t)*EXP(-t)]dt C C THESE ARE SOLVED USING THE DNSQE ROUTINE. C CALL MEAN(Y,IR,IWRITE,XMEAN,IBUGG3,IERROR) CALL SD(Y,IR,IWRITE,XSD,IBUGG3,IERROR) CALL GEOMEA(Y,IR,IWRITE,XGEOM,IBUGG3,IERROR) XCOEFV=XSD/XMEAN C C USE MOMENT ESTIMATES OF FAILURE DATA AS STARTING VALUES FOR C EQUATION SOLVER. C GAMMMO=(XMEAN/XSD)**2 SCALMO=XSD**2/XMEAN C XBAR=DBLE(XMEAN) DGEOME=DBLE(XGEOM) XPAR(1)=DBLE(GAMMMO) XPAR(2)=DBLE(SCALMO) C IN2=N JAC=0 IOPT=2 TOL=1.0D-6 NVAR=2 NPRINT=-1 INFO=0 LWA=MAXNXT FVEC(1)=0.0D0 FVEC(2)=0.0D0 CALL DNSQE(GC1FUN,JAC,IOPT,NVAR,XPAR,FVEC,TOL,NPRINT,INFO, 1 DTEMP1,MAXNXT,Y(IR+1),IM) C SHAPE=REAL(XPAR(1)) SCALE=REAL(XPAR(2)) ELSE C C FOR THE SHAPE PARAMETER, SOLVE THE EQUATION: C C LOG(GAMMAHAT) - PHI(GAMMAHAT) - LOG(XBAR/G) = 0 C C WITH G DENOTING THE GEOMETRIC MEAN (PRODUCT[i=1 to n][X(i)**(1/N)] C C THEN C C SCALE = XBAR/GAMMAHAT C C FOR STARTING VALUE, USE THE METHOD OF MOMENT ESTIMATORS C C GAMMAHAT = (XBAR/XSD)**2 C SCALE = XSD**2/XBAR C C AN=REAL(N) C CALL MEAN(Y,N,IWRITE,XMEAN,IBUGG3,IERROR) CALL SD(Y,N,IWRITE,XSD,IBUGG3,IERROR) CALL MINIM(Y,N,IWRITE,XMIN,IBUGG3,IERROR) CALL GEOMEA(Y,N,IWRITE,XGEOM,IBUGG3,IERROR) C GAMMMO=(XMEAN/XSD)**2 SCALMO=XSD**2/XMEAN C C ESTIMATES FOR 2-PARAMETER MODEL. USE DFZER2 TO FIND ROOT OF C THE LIKELIHOOD EQUATION. C DLOGGM=DLOG(DBLE(XMEAN)/DBLE(XGEOM)) DXSTRT=DBLE(GAMMMO) AE=2.0*0.000001D0*DXSTRT RE=AE IFLAG=0 DXLOW=DXSTRT/2.0D0 DXUP=2.0D0*DXSTRT ITBRAC=0 2205 CONTINUE XLOWSV=DXLOW XUPSV=DXUP CALL DFZERO(GAMFUN,DXLOW,DXUP,DXSTRT,RE,AE,IFLAG) C IF(IFLAG.EQ.4 .AND. ITBRAC.LE.100)THEN DXLOW=XLOWSV/2.0D0 DXUP=2.0D0*XUPSV ITBRAC=ITBRAC+1 GOTO2205 ENDIF C IF(IFLAG.EQ.2)THEN C C NOTE: SUPPRESS THIS MESSAGE FOR NOW. CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,2211) C2211 FORMAT('***** WARNING FROM GAMMA MAXIMUM ', CCCCC1 'LIKELIHOOD--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,2213) C2213 FORMAT(' ESTIMATE OF SIGMA MAY NOT BE COMPUTED TO ', CCCCC1 'DESIRED TOLERANCE.') CCCCC CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.3)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2221) 2221 FORMAT('***** WARNING FROM GAMMA MAXIMUM LIKELIHOOD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2223) 2223 FORMAT(' ESTIMATE OF SHAPE PARAMETER MAY BE NEAR ', 1 'A SINGULAR POINT.') CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.4)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2231) 2231 FORMAT('***** ERROR FROM GAMMA MAXIMUM LIKELIHOOD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2233) 2233 FORMAT(' APPROPRIATE BRACKETING INTERVAL NOT FOUND.') CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.5)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2241) 2241 FORMAT('***** WARNING FROM GAMMA MAXIMUM LIKELIHOOD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2243) 2243 FORMAT(' MAXIMUM ITERATIONS EXCEEDED.') CALL DPWRST('XXX','BUG ') ENDIF C SHAPE=REAL(DXLOW) SCALE=XMEAN/SHAPE ENDIF ELSEIF(ICASPL.EQ.'EEML')THEN IF(ICENSO.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2301) 2301 FORMAT('***** ERROR IN JACKNIFE/BOOTSTRAP MAXIMUM ', 1 'LIKELIHOOD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2303) 2303 FORMAT(' CENSORING NOT SUPPORTED FOR THE ', 1 'GEOMETRIC EXTREME EXPONENTIAL DISTRIBUTION.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' ELSE CALL MEAN(Y,N,IWRITE,XMEAN,IBUGG3,IERROR) CALL SD(Y,N,IWRITE,XSD,IBUGG3,IERROR) C XPAR(1)=DBLE(XMEAN) XPAR(2)=DBLE(XSD) C IOPT=2 TOL=1.0D-6 NVAR=2 NPRINT=-1 INFO=0 LWA=MAXNXT CALL DNSQE(GEEFUN,JAC,IOPT,NVAR,XPAR,FVEC,TOL,NPRINT,INFO, 1 DTEMP1,MAXNXT,Y,N) C SHAPE=REAL(XPAR(1)) SCALE=REAL(XPAR(2)) ENDIF ELSEIF(ICASPL.EQ.'FLML')THEN IF(ICENSO.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2501) 2501 FORMAT('***** ERROR IN JACKNIFE/BOOTSTRAP MAXIMUM ', 1 'LIKELIHOOD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2503) 2503 FORMAT(' CENSORING NOT SUPPORTED FOR THE ', 1 'FATIGUE LIFE DISTRIBUTION.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' ELSE CALL MEAN(Y,N,IWRITE,XMEAN,IBUGG3,IERROR) CALL SD(Y,N,IWRITE,XSD,IBUGG3,IERROR) C DN=DBLE(N) DSUM1=0.0D0 DSUM2=0.0D0 DSUM3=0.0D0 DSUM4=0.0D0 DO2610I=1,N DX=DBLE(Y(I)) DSUM1=DSUM1 + DSQRT(DX) DSUM2=DSUM2 + 1.0D0/DSQRT(DX) DSUM3=DSUM3 + DX DSUM4=DSUM4 + 1.0D0/DX 2610 CONTINUE DGAMM1=DSUM1/DSUM2 XPAR(1)=DSQRT(DSUM3/DSUM4) C DSUM1=0.0D0 DO2620I=1,N DX=DBLE(Y(I)) DSUM1=DSUM1 + (DSQRT(DX/DGAMM1) - DSQRT(DGAMM1/DX))**2 2620 CONTINUE DALPHA=DSQRT(DSUM1/DN) SCALE1=REAL(DGAMM1) GAMMA1=REAL(DALPHA) C XPAR(1)=DGAMM1 C IOPT=2 TOL=1.0D-6 NVAR=1 NPRINT=-1 INFO=0 LWA=MAXNXT CALL DNSQE(FLFUN,JAC,IOPT,NVAR,XPAR,FVEC,TOL,NPRINT,INFO, 1 DTEMP1,MAXNXT,Y,N) C DSUM1=0.0D0 DSUM2=0.0D0 DSUM3=0.0D0 C DO2630I=1,N DX=DBLE(Y(I)) DSUM1=DSUM1 + DX DSUM2=DSUM2 + 1.0D0/DX DSUM3=DSUM3 + 1.0D0/(DX + XPAR(1)) 2630 CONTINUE TBAR=DSUM1/DN H=DN/DSUM2 DK=DN/DSUM3 DALPH2=2.0D0*DSQRT(0.5D0* 1 ((TBAR/XPAR(1)) + XPAR(1)/H) - 1.0D0) GAMMA2=REAL(XPAR(1)) SHAPE=REAL(DALPH2) SCALE=GAMMA2 ENDIF ELSEIF(ICASPL.EQ.'IGML')THEN IF(ICENSO.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2701) 2701 FORMAT('***** ERROR IN JACKNIFE/BOOTSTRAP MAXIMUM ', 1 'LIKELIHOOD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2703) 2703 FORMAT(' CENSORING NOT SUPPORTED FOR THE ', 1 'INVERSE GAUSSIAN DISTRIBUTION.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' ELSE DO2710I=1,N IF(Y(I).LT.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2711) 2711 FORMAT('***** NOTE FROM INVERSE GAUSSIAN MAXIMUM ', 1 'LIKELIHOOD ESTIMATION--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2713) 2713 FORMAT(' NON-POSITIVE VALUE DETECTED.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF 2710 CONTINUE C CALL MEAN(Y,N,IWRITE,XMEAN,IBUGG3,IERROR) DSUM=0.0D0 DO2720I=1,N DSUM=DSUM + (1.0D0/DBLE(Y(I)) - 1.0D0/DBLE(XMEAN)) 2720 CONTINUE SHAPE=REAL(DBLE(N)/DSUM) SCALE=XMEAN ENDIF ELSEIF(ICASPL.EQ.'PAML')THEN IF(ICENSO.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2801) 2801 FORMAT('***** ERROR IN JACKNIFE/BOOTSTRAP MAXIMUM ', 1 'LIKELIHOOD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2803) 2803 FORMAT(' CENSORING NOT SUPPORTED FOR THE ', 1 'PARETO DISTRIBUTION.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' ELSE XMIN=Y(1) DSUM=0.0D0 DO2810I=1,N IF(Y(I).LE.0.0)THEN SHAPE=0.0 SCALE=0.0 IERROR='YES' GOTO9000 ENDIF DTERM1=DBLE(LOG(Y(I)/XMIN)) DSUM=DSUM + DTERM1 2810 CONTINUE GAMMA=REAL(DSUM)/REAL(N) GAMMA=1.0/GAMMA SHAPE=GAMMA SCALE=XMIN ENDIF ELSEIF(ICASPL.EQ.'BEML')THEN IF(ICENSO.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2901) 2901 FORMAT('***** ERROR IN JACKNIFE/BOOTSTRAP MAXIMUM ', 1 'LIKELIHOOD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2903) 2903 FORMAT(' CENSORING NOT SUPPORTED FOR THE ', 1 'BETA DISTRIBUTION.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' ELSE CALL MINIM(Y,N,IWRITE,XMIN,IBUGG3,IERROR) CALL MAXIM(Y,N,IWRITE,XMAX,IBUGG3,IERROR) CALL MEAN(Y,N,IWRITE,XMEAN,IBUGG3,IERROR) CALL VAR(Y,N,IWRITE,XVAR,IBUGG3,IERROR) XSD=SQRT(XVAR) C CCCCC ALLOW FOR USER SPECIFIED LOWER AND UPPER LIMITS C AUSER=CPUMIN BUSER=CPUMIN C IF((AUSER.EQ.CPUMIN .OR. BUSER.EQ.CPUMIN) .OR. 1 (AUSER.GE.XMIN .OR. BUSER.LE.XMAX))THEN IF((XMIN.GE.0.0 .AND. XMIN.LE.1.0) .AND. 1 (XMAX.GE.0.0 .AND. XMAX.LE.1.0))THEN A=0.0 B=1.0 ELSE A=XMIN - 1.0E-12 B=XMAX + 1.0E+12 ENDIF BETALL=A BETAUL=B ELSE BETALL=AUSER BETAUL=BUSER A=AUSER B=BUSER ENDIF C XMEAN1=(XMEAN-A)/(B-A) VAR1=XVAR/((B-A)**2) ALPHA1=XMEAN1*(XMEAN1*(1.0-XMEAN1)/VAR1 - 1.0) BETA1=(1.0-XMEAN1)*(XMEAN1*(1.0-XMEAN1)/VAR1 - 1.0) C XPAR(1)=DBLE(ALPHA1) XPAR(2)=DBLE(BETA1) DPROD1=1.0D0 DPROD2=1.0D0 DN=DBLE(N) C DO2911I=1,N DTERM1=DBLE((B-Y(I))/(B-A))**(1.0D0/DN) DTERM2=DBLE( (Y(I)-A)/(B-A))**(1.0D0/DN) IF(DTERM1.NE.0.0D0)DPROD1=DPROD1*DTERM1 IF(DTERM2.NE.0.0D0)DPROD2=DPROD2*DTERM2 2911 CONTINUE XPAR(1)=0.5D0*(1.0D0 - DPROD1)/(1.0D0 - DPROD2 - DPROD1) DO2913I=1,N DTERM1=DBLE((Y(I)-A)/(B-A))**(1.0D0/DN) DTERM2=DBLE( (B-Y(I))/(B-A))**(1.0D0/DN) IF(DTERM1.NE.0.0D0)DPROD1=DPROD1*DTERM1 IF(DTERM2.NE.0.0D0)DPROD2=DPROD2*DTERM2 2913 CONTINUE XPAR(2)=0.5D0*(1.0D0 - DPROD1)/(1.0D0 - DPROD1 - DPROD2) C IOPT=2 TOL=1.0D-6 NVAR=2 NPRINT=-1 INFO=0 LWA=MAXNXT CALL DNSQE(BETFUN,JAC,IOPT,NVAR,XPAR,FVEC,TOL,NPRINT,INFO, 1 DTEMP1,MAXNXT,Y,N) C SCALE=REAL(XPAR(1)) SHAPE=REAL(XPAR(2)) ENDIF ELSEIF(ICASPL.EQ.'GEML' .OR. ICASPL.EQ.'GEMO' .OR. 1 ICASPL.EQ.'GEDE' .OR. ICASPL.EQ.'GECM')THEN IF(ICENSO.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3001) 3001 FORMAT('***** ERROR IN JACKNIFE/BOOTSTRAP MAXIMUM ', 1 'LIKELIHOOD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3003) 3003 FORMAT(' CENSORING NOT SUPPORTED FOR THE ', 1 'GENERALIZED PARETO DISTRIBUTION.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' ELSE CALL MINIM(Y,N,IWRITE,XMIN,IBUGG3,IERROR) CALL MAXIM(Y,N,IWRITE,XMAX,IBUGG3,IERROR) CALL MEAN(Y,N,IWRITE,XMEAN,IBUGG3,IERROR) CALL SD(Y,N,IWRITE,XSD,IBUGG3,IERROR) XVAR=XSD**2 C GAMMA1=0.5*(XMEAN*XMEAN/XVAR - 1.0) SCALE1=0.5*XMEAN*(XMEAN*XMEAN/XVAR + 1.0) C IF(ICASPL.EQ.'GEML')THEN XPAR(1)=DBLE(GAMMA1) XPAR(2)=DBLE(SCALE1) C IOPT=2 TOL=1.0D-6 NVAR=2 NPRINT=-1 INFO=0 LWA=MAXNXT CALL DNSQE(GPAFUN,JAC,IOPT,NVAR,XPAR,FVEC,TOL,NPRINT,INFO, 1 DTEMP1,MAXNXT,Y,N) C GAMMA2=REAL(XPAR(1)) SCALE2=REAL(XPAR(2)) C ELSEIF(ICASPL.EQ.'GEDE')THEN C IFEESV=IFEEDB IPRISV=IPRINT IFEEDB='OFF' IPRINT='OFF' ICAPSW='OFF' ICAPTY='ASCI' C THRESH=CPUMIN CALL DPDEGP(Y,N, 1 Y2,MAXNXT, 1 GAMMA3,SCALE3,GAMMSD,THRESH, 1 GAMMA4,ALOC,SCALE, 1 IGEPDF,ICAPSW,ICAPTY, 1 IPOTTO, 1 ISUBRO,IBUGG3,IERROR) IF(IGEPDF.NE.'SIMI')GAMMA3=-GAMMA3 C IFEEDB=IFEESV IPRINT=IPRISV C ELSEIF(ICASPL.EQ.'GECM')THEN C IFEESV=IFEEDB IPRISV=IPRINT IFEEDB='OFF' IPRINT='OFF' ICAPSW='OFF' ICAPTY='ASCI' C THRESH=0.0 CALL DPCMGP(Y,N, 1 Y2,MAXNXT, 1 GAMMA4,SCALE4,GAMMSD,THRESH, 1 X2,QP,XQP,DTEMP1, 1 IGEPDF,ICAPSW,ICAPTY, 1 IPOTTO, 1 ISUBRO,IBUGG3,IERROR) IF(IGEPDF.NE.'SIMI')GAMMA4=-GAMMA4 C IFEEDB=IFEESV IPRINT=IPRISV C ENDIF C IF(ICASPL.EQ.'GEMO')THEN SCALE=SCALE1 SHAPE=GAMMA1 IF(IGEPDF.EQ.'SIMI')GAMMA1=-GAMMA1 ELSEIF(ICASPL.EQ.'GEDE')THEN SCALE=SCALE3 SHAPE=GAMMA3 ELSEIF(ICASPL.EQ.'GECM')THEN SCALE=SCALE4 SHAPE=GAMMA4 ELSE SCALE=SCALE2 SHAPE=GAMMA2 IF(IGEPDF.EQ.'SIMI')GAMMA2=-GAMMA2 ENDIF ENDIF ELSEIF(ICASPL.EQ.'FRML')THEN IF(ICENS2.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3101) 3101 FORMAT('***** ERROR IN JACKNIFE/BOOTSTRAP MAXIMUM ', 1 'LIKELIHOOD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3003) 3103 FORMAT(' CENSORING NOT SUPPORTED FOR THE ', 1 'FRECHET (MAXIMUM) DISTRIBUTION.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' ELSE C C FOR THE SHAPE PARAMETER, SOLVE THE EQUATION: C C (1/GHAT) - C SUM[i=1 to n][Y(I)**(-GHAT)*LN(Y(I))]/SUM[i=1 to n][[Y(I)**(-GHAT)] C - (1/N)*SUM[i=1 to n][LN(Y(I))] = 0 C C THEN C C SCALE = ((1/N)*SUM[i=1 to n][Y(I)**(-GHAT)])**(-1/GHAT) C C FOR STARTING VALUE, USE C C GHAT = 1.28/(STD DEV OF LOG(Y)) C DO3110I=1,N IF(Y(I).LE.0.0)THEN IERROR='YES' GOTO9000 ENDIF X2(I)=LOG(Y(I)) 3110 CONTINUE C AN=REAL(N) C CALL MEAN(Y,N,IWRITE,XMEAN,IBUGG3,IERROR) CALL SD(Y,N,IWRITE,XSD,IBUGG3,IERROR) CALL SD(X2,N,IWRITE,XLOGSD,IBUGG3,IERROR) CALL SUM(X2,N,IWRITE,XLOGSM,IBUGG3,IERROR) CALL MINIM(Y,N,IWRITE,XMIN,IBUGG3,IERROR) C C ESTIMATES FOR 2-PARAMETER MODEL. USE DFZER2 TO FIND ROOT OF C THE EQUATION GIVEN ABOVE. C DO3111I=1,N DTEMP1(I)=DBLE(Y(I)) 3111 CONTINUE DEV2SM=DBLE(XLOGSM/AN) DXSTRT=DBLE(SQRT(1.645)*XSD) DAE=2.0*0.000001D0*DXSTRT DRE=DAE INEV2=N IFLAG=0 DXLOW=DXSTRT/5.0D0 DXUP=5.0D0*DXSTRT ITBRAC=0 3115 CONTINUE XLOWSV=DXLOW XUPSV=DXUP CALL DFZER2(EV2FUN,DXLOW,DXUP,DXSTRT,DRE,DAE,IFLAG,DTEMP1) C IF(IFLAG.EQ.4 .AND. ITBRAC.LE.100)THEN DXLOW=XLOWSV/2.0D0 DXUP=2.0D0*XUPSV ITBRAC=ITBRAC+1 GOTO3115 ENDIF C IF(IFLAG.EQ.2)THEN C C NOTE: SUPPRESS THIS MESSAGE FOR NOW. CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,3116) C3116 FORMAT('***** WARNING FROM FRECHET MAXIMUM ', CCCCC1 'LIKELIHOOD--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,3118) C3118 FORMAT(' ESTIMATE OF SIGMA MAY NOT BE COMPUTED TO ', CCCCC1 'DESIRED TOLERANCE.') CCCCC CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.3)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3121) 3121 FORMAT('***** WARNING FROM FRECHET MAXIMUM LIKELIHOOD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3123) 3123 FORMAT(' ESTIMATE OF SHAPE PARAMETER MAY BE NEAR ', 1 'A SINGULAR POINT.') CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.4)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3131) 3131 FORMAT('***** ERROR FROM FRECHET MAXIMUM LIKELIHOOD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3133) 3133 FORMAT(' APPROPRIATE BRACKETING INTERVAL NOT FOUND.') CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.5)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3141) 3141 FORMAT('***** WARNING FROM FRECHET MAXIMUM LIKELIHOOD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3143) 3143 FORMAT(' MAXIMUM ITERATIONS EXCEEDED.') CALL DPWRST('XXX','BUG ') ENDIF C SHAPE=REAL(DXLOW) DSUM=0.0D0 DO3138I=1,N DSUM=DSUM + DBLE(Y(I)**(-SHAPE)) 3138 CONTINUE SCALE=REAL((DSUM/DBLE(N))**DBLE(1.0D0/DBLE(-SHAPE))) CCCCC BN=1.0 + 2.2/AN**1.13 CCCCC GAMMBC=SHAPE/BN ENDIF ELSEIF(ICASPL.EQ.'IWML')THEN IF(ICENS2.EQ.'ON')THEN C C INVERTED WEIBULL TAKES (1/X) AND THEN USES THE WEIBULL CODE. AFTER C THE PARAMETERS ARE ESTIMATED, THE ESTIMATE OF SCALE NEEDS TO BE C INVERTED. C C FOR THE SHAPE PARAMETER, SOLVE THE EQUATION: C C (1/GHAT) - C SUM[i=1 to n][Y(I)**GHAT*LN(Y(I))]/SUM[i=1 to n][[Y(I)**GHAT] + C (1/N)*SUM[i=1 to n][LN(Y(I))] = 0 C C THEN C C SCALE = ((1/N)*SUM[i=1 to n][Y(I)**GHAT]) C C FOR STARTING VALUE, USE C C GHAT = 1.28/(STD DEV OF LOG(Y)) C DO3260I=1,N IF(Y(I).LE.0.0)THEN IERROR='YES' GOTO9000 ELSE Y(I)=1.0/Y(I) ENDIF X2(I)=LOG(Y(I)) 3260 CONTINUE C CALL MEAN(Y,N,IWRITE,XMEAN,IBUGG3,IERROR) CALL SD(Y,N,IWRITE,XSD,IBUGG3,IERROR) CALL SD(X2,N,IWRITE,XLOGSD,IBUGG3,IERROR) C DSUM1=0.0D0 DO3261I=1,N DTEMP1(I)=DBLE(Y(I)) IF(X(I).EQ.1.0)DSUM1=DSUM1 + DLOG(DTEMP1(I)) 3261 CONTINUE DWEISM=DSUM1/DBLE(IR) XSTART=DBLE(1.28/XLOGSD) AE=2.0*0.000001D0*XSTART RE=AE IN=N IFLAG=0 XLOW=XSTART/2.0D0 XUP=2.0D0*XSTART ITBRAC=0 3265 CONTINUE XLOWSV=XLOW XUPSV=XUP CALL DFZER2(WEIFUN,XLOW,XUP,XSTART,RE,AE,IFLAG,DTEMP1) C IF(IFLAG.EQ.4 .AND. ITBRAC.LE.100)THEN XLOW=XLOWSV/2.0D0 XUP=2.0D0*XUPSV ITBRAC=ITBRAC+1 GOTO3265 ENDIF C IF(IFLAG.EQ.2)THEN C C NOTE: SUPPRESS THIS MESSAGE FOR NOW. CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,3211) C3211 FORMAT('***** WARNING FROM CENSORED INVERTED WEIBULL MAXIMUM ', CCCCC1 'LIKELIHOOD--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,3213) C3213 FORMAT(' ESTIMATE OF GAMMA MAY NOT BE COMPUTED TO ', CCCCC1 'DESIRED TOLERANCE.') CCCCC CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.3)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3271) 3271 FORMAT('***** WARNING FROM CENSORED INVERTED WEIBULL ', 1 'MAXIMUM LIKELIHOOD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3273) 3273 FORMAT(' ESTIMATE OF SHAPE PARAMETER MAY BE NEAR ', 1 'A SINGULAR POINT.') CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.4)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3281) 3281 FORMAT('***** ERROR FROM CENSORED INVERTED WEIBULL ', 1 'MAXIMUM LIKELIHOOD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3283) 3283 FORMAT(' APPROPRIATE BRACKETING INTERVAL NOT FOUND.') CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.5)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3271) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3293) 3293 FORMAT(' MAXIMUM ITERATIONS EXCEEDED.') CALL DPWRST('XXX','BUG ') ENDIF C SHAPE=XLOW DSUM1=0.0D0 DO3268I=1,N DSUM1=DSUM1 + DBLE(Y(I)**SHAPE) 3268 CONTINUE SCALE=REAL((DSUM1/DBLE(IR))**DBLE(1.0D0/DBLE(SHAPE))) SCALE=1.0/SCALE ELSE C C FOR THE SHAPE PARAMETER, SOLVE THE EQUATION: C C (1/GHAT) - C SUM[i=1 to n][Y(I)**GHAT*LN(Y(I))]/SUM[i=1 to n][[Y(I)**GHAT] + C (1/N)*SUM[i=1 to n][LN(Y(I))] = 0 C C THEN C C SCALE = ((1/N)*SUM[i=1 to n][Y(I)**GHAT]) C C FOR STARTING VALUE, USE C C GHAT = 1.28/(STD DEV OF LOG(Y)) C DO3210I=1,N IF(Y(I).LE.0.0)THEN IERROR='YES' GOTO9000 ELSE Y(I)=1.0/Y(I) ENDIF X2(I)=LOG(Y(I)) 3210 CONTINUE C AN=REAL(N) C CALL MEAN(Y,N,IWRITE,XMEAN,IBUGG3,IERROR) CALL SD(Y,N,IWRITE,XSD,IBUGG3,IERROR) CALL SD(X2,N,IWRITE,XLOGSD,IBUGG3,IERROR) CALL SUM(X2,N,IWRITE,XLOGSM,IBUGG3,IERROR) CALL MINIM(Y,N,IWRITE,XMIN,IBUGG3,IERROR) C C ESTIMATES FOR 2-PARAMETER MODEL. USE DFZER2 TO FIND ROOT OF C THE EQUATION GIVEN ABOVE. C DO3201I=1,N DTEMP1(I)=DBLE(Y(I)) 3201 CONTINUE DWEISM=DBLE(XLOGSM/AN) DXSTRT=1.28D0/DBLE(XLOGSD) DAE=2.0*0.000001D0*DXSTRT DRE=DAE IN=N IFLAG=0 DXLOW=DXSTRT/2.0D0 DXUP=2.0D0*DXSTRT ITBRAC=0 3205 CONTINUE XLOWSV=DXLOW XUPSV=DXUP CALL DFZER2(WEIFUN,DXLOW,DXUP,DXSTRT,DRE,DAE,IFLAG,DTEMP1) C IF(IFLAG.EQ.4 .AND. ITBRAC.LE.100)THEN DXLOW=XLOWSV/2.0D0 DXUP=2.0D0*XUPSV ITBRAC=ITBRAC+1 GOTO3205 ENDIF C IF(IFLAG.EQ.2)THEN C C NOTE: SUPPRESS THIS MESSAGE FOR NOW. CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,3211) C3211 FORMAT('***** WARNING FROM WEIBULL MAXIMUM ', CCCCC1 'LIKELIHOOD--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,3213) C3213 FORMAT(' ESTIMATE OF SIGMA MAY NOT BE COMPUTED TO ', CCCCC1 'DESIRED TOLERANCE.') CCCCC CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.3)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3221) 3221 FORMAT('***** WARNING FROM WEIBULL MAXIMUM LIKELIHOOD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3223) 3223 FORMAT(' ESTIMATE OF SHAPE PARAMETER MAY BE NEAR ', 1 'A SINGULAR POINT.') CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.4)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3231) 3231 FORMAT('***** ERROR FROM WEIBULL MAXIMUM LIKELIHOOD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3233) 3233 FORMAT(' APPROPRIATE BRACKETING INTERVAL NOT FOUND.') CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.5)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3241) 3241 FORMAT('***** WARNING FROM WEIBULL MAXIMUM LIKELIHOOD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3243) 3243 FORMAT(' MAXIMUM ITERATIONS EXCEEDED.') CALL DPWRST('XXX','BUG ') ENDIF C SHAPE=REAL(DXLOW) DSUM=0.0D0 DO3208I=1,N DSUM=DSUM + DBLE(Y(I)**SHAPE) 3208 CONTINUE SCALE=REAL((DSUM/DBLE(N))**DBLE(1.0D0/DBLE(SHAPE))) SCALE=1.0/SCALE CCCCC BN=1.0 + 2.2/AN**1.13 CCCCC GAMMBC=SHAPE/BN ENDIF ELSE SHAPE=1.0 SCALE=1.0 GOTO9000 ENDIF IF(IERROR.EQ.'YES')GOTO9000 C C ************************************************** C ** STEP 4-- ** C ** COMPUTE SELECTED PERCENTILES ** C ************************************************** C ISTEPN='4' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBPP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NP.GT.0)THEN IF(ICASPL.EQ.'LNML')THEN DO4110I=1,NP QPTEMP=QP(I)/100.0 CALL LGNPPF(QPTEMP,SHAPE,XQP(I)) XQP(I)=SCALE*XQP(I) 4110 CONTINUE ELSEIF(ICASPL.EQ.'WEML')THEN DO4120I=1,NP QPTEMP=QP(I)/100.0 CALL WEIPPF(QPTEMP,SHAPE,MINMAX,XQP(I)) XQP(I)=SCALE*XQP(I) 4120 CONTINUE ELSEIF(ICASPL.EQ.'GAML')THEN DO4130I=1,NP QPTEMP=QP(I)/100.0 CALL GAMPPF(QPTEMP,SHAPE,XQP(I)) XQP(I)=SCALE*XQP(I) 4130 CONTINUE ELSEIF(ICASPL.EQ.'FLML')THEN DO4140I=1,NP QPTEMP=QP(I)/100.0 CALL FLPPF(QPTEMP,SHAPE,XQP(I)) XQP(I)=SCALE*XQP(I) 4140 CONTINUE ELSEIF(ICASPL.EQ.'EEML')THEN DO4150I=1,NP QPTEMP=QP(I)/100.0 CALL GEEPPF(QPTEMP,SHAPE,XQP(I)) XQP(I)=SCALE*XQP(I) 4150 CONTINUE ELSEIF(ICASPL.EQ.'IGML')THEN C C NOTE 11/2006: FOR INVERSE GAUSSIAN, SCALE IS ACTUALLY MU C PARAMETER (NO SCALE ESTIMATE). C DO4160I=1,NP QPTEMP=QP(I)/100.0 CALL IGPPF(QPTEMP,SHAPE,SCALE,XQP(I)) CCCCC XQP(I)=SCALE*XQP(I) 4160 CONTINUE ELSEIF(ICASPL.EQ.'PAML')THEN C C FOR PARETO, SCALE IS ACTUALLY LOWER BOUND SHAPE PARAMETER. STANDARD C LOCATION AND SCALE PARAMETERS ARE NOT ESTIMATED. C DO4170I=1,NP QPTEMP=QP(I)/100.0 CALL PARPPF(QPTEMP,SHAPE,SCALE,XQP(I)) CCCCC XQP(I)=SCALE*XQP(I) 4170 CONTINUE ELSEIF(ICASPL.EQ.'GEML')THEN MINMAX=1 DO4180I=1,NP QPTEMP=QP(I)/100.0 CALL GEPPPF(QPTEMP,SHAPE,MINMAX,IGEPDF,XQP(I)) XQP(I)=SCALE*XQP(I) 4180 CONTINUE ELSEIF(ICASPL.EQ.'GEMO')THEN MINMAX=1 DO4190I=1,NP QPTEMP=QP(I)/100.0 CALL GEPPPF(QPTEMP,SHAPE,MINMAX,IGEPDF,XQP(I)) XQP(I)=SCALE*XQP(I) 4190 CONTINUE ELSEIF(ICASPL.EQ.'GEDE')THEN MINMAX=1 DO4200I=1,NP QPTEMP=QP(I)/100.0 CALL GEPPPF(QPTEMP,SHAPE,MINMAX,IGEPDF,XQP(I)) XQP(I)=SCALE*XQP(I) 4200 CONTINUE ELSEIF(ICASPL.EQ.'GECM')THEN MINMAX=1 DO4210I=1,NP QPTEMP=QP(I)/100.0 CALL GEPPPF(QPTEMP,SHAPE,MINMAX,IGEPDF,XQP(I)) XQP(I)=SCALE*XQP(I) 4210 CONTINUE ELSEIF(ICASPL.EQ.'FRML')THEN DO4220I=1,NP QPTEMP=QP(I)/100.0 CALL EV2PPF(QPTEMP,SHAPE,MINMAX,XQP(I)) XQP(I)=SCALE*XQP(I) 4220 CONTINUE ELSEIF(ICASPL.EQ.'IWML')THEN DO4230I=1,NP QPTEMP=QP(I)/100.0 CALL IWEPPF(QPTEMP,SHAPE,XQP(I)) XQP(I)=SCALE*XQP(I) 4230 CONTINUE ENDIF ENDIF C ******************* C ** STEP 90-- ** C ** EXIT ** C ******************* C 9000 CONTINUE C RETURN END SUBROUTINE DPJBM4(Y,X,N,ICASPL,ICENSO,MAXNXT,MINMAX, 1Y2,X2, 1DTEMP1,DALPHA,DBETA,DH, 1IADEDF, 1ALOC,SCALE,SHAPE, 1QP,XQP,NP, 1IUDFLG, 1IBUGG3,ISUBRO,IERROR) C C PURPOSE--FOR A GIVEN BOOTSTRAP SAMPLE, GENERATE MAXIMUM C LIKELIHOOD ESTIMATES FOR ONE SHAPE (SHAPE), C LOCATION (ALOC), AND SCALE (SCALE). C C SUPPORTED DISTRIBUTIONS ARE: C C 1) ASYMMETRIC LAPLACE C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2005/1 C ORIGINAL VERSION--JANUARY 2005. C C--------------------------------------------------------------------- C CHARACTER*4 ICASPL CHARACTER*4 ICENSO CHARACTER*4 IADEDF CHARACTER*4 IBUGG3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C DIMENSION Y(*) DIMENSION X(*) DIMENSION Y2(*) DIMENSION X2(*) DIMENSION QP(*) DIMENSION XQP(*) DOUBLE PRECISION DTEMP1(*) C DOUBLE PRECISION DALPHA(*) DOUBLE PRECISION DBETA(*) DOUBLE PRECISION DH(*) C CCCCC DOUBLE PRECISION DSUM CCCCC DOUBLE PRECISION TOL CCCCC DOUBLE PRECISION XPAR(2) CCCCC DOUBLE PRECISION FVEC(2) C CCCCC DOUBLE PRECISION DN CCCCC DOUBLE PRECISION DR CCCCC DOUBLE PRECISION DX CCCCC DOUBLE PRECISION DXSTRT CCCCC DOUBLE PRECISION DAE CCCCC DOUBLE PRECISION DRE CCCCC DOUBLE PRECISION DXLOW CCCCC DOUBLE PRECISION DXUP CCCCC DOUBLE PRECISION XSTRT CCCCC DOUBLE PRECISION XSTART CCCCC DOUBLE PRECISION XLOW CCCCC DOUBLE PRECISION XUP CCCCC DOUBLE PRECISION XLOWSV CCCCC DOUBLE PRECISION XUPSV CCCCC DOUBLE PRECISION AE CCCCC DOUBLE PRECISION RE CCCCC DOUBLE PRECISION DGAMM1 CCCCC DOUBLE PRECISION DGAMM2 CCCCC DOUBLE PRECISION DALPHA CCCCC DOUBLE PRECISION DALPH2 CCCCC DOUBLE PRECISION DSUM1 CCCCC DOUBLE PRECISION DSUM2 CCCCC DOUBLE PRECISION DSUM3 CCCCC DOUBLE PRECISION DSUM4 CCCCC DOUBLE PRECISION TBAR CCCCC DOUBLE PRECISION H CCCCC DOUBLE PRECISION DK C DOUBLE PRECISION DHMIN DOUBLE PRECISION DSUM1 DOUBLE PRECISION DSUM2 DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTERM4 C CHARACTER*4 ICENS2 CHARACTER*4 IWRITE CHARACTER*4 ISTEPN CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 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 DATA PI/3.14159265358979/ C C-----START POINT----------------------------------------------------- C ISUBN1='DPJB' ISUBN2='M4 ' IWRITE='OFF' IUDFLG=0 ALOC=0.0 SCALE=1.0 SHAPE=1.0 IR=0 IF(NP.GT.0)THEN DO410I=1,NP XQP(I)=0.0 410 CONTINUE ENDIF C C ************************************************** C ** STEP 1-- ** C ** PROCESS THE CENSORING VARIABLE. ** C ************************************************** C ISTEPN='1' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBM4') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO1000I=1,N Y2(I)=Y(I) 1000 CONTINUE C IF(ICENSO.EQ.'ON')THEN IR=0 CALL DISTIN(X,N,IWRITE,X2,NDIST,IBUGG3,IERROR) IF(NDIST.EQ.1)THEN DO1102I=1,N X(I)=1.0 1102 CONTINUE IR=N ELSEIF(NDIST.EQ.2)THEN IF(X2(1).EQ.1.0 .OR. X2(2).EQ.1.0)THEN DO1103I=1,N IF(X(I).NE.1.0)THEN X(I)=2.0 ELSE IR=IR+1 ENDIF 1103 CONTINUE ELSE ATEMP1=MIN(X2(1),X2(2)) ATEMP2=MAX(X2(1),X2(2)) DO1108I=1,N IF(X(I).EQ.ATEMP1)THEN IR=IR+1 X(I)=1.0 ENDIF IF(X(I).EQ.ATEMP2)X(I)=2.0 1108 CONTINUE ENDIF ELSE WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1104) 1104 FORMAT('***** ERROR IN JACKNIFE/BOOTSTRAP MAXIMUM ', 1 'LIKELIHOOD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1105) 1105 FORMAT(' FOR CENSORED DATA, THE CENSORING VARIABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1106) 1106 FORMAT(' SHOULD CONTAIN AT MOST TWO DISTINCT VALUES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1107)NDIST 1107 FORMAT(' ',I8,' DISTINCT VALUES FOUND.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF CALL SORTC(Y2,X,N,Y,X) IF(ICASPL.EQ.'LNML')THEN IF(IR.LT.N)THEN AHOLD=Y(IR+1) DO1240I=IR+1,N IF(Y(I).NE.AHOLD)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1241) 1241 FORMAT('***** ERROR FROM CENSORED LOGNORMAL MAXIMUM ', 1 'LIKELIHOOD--') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1243) 1243 FORMAT(' CURRENTLY, ONLY SINGLY CENSORED DATA ', 1 'IS SUPPORTED FOR THE LOGNORMAL DISTRIBUTION.') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1245) 1245 FORMAT(' MULTIPLY CENSORED DATA WAS DETECTED.') CALL DPWRST('XXX','WRIT') IERROR='YES' GOTO9000 ENDIF 1240 CONTINUE C=DBLE(AHOLD) ENDIF ENDIF C ELSE CALL SORT(Y2,N,Y) ENDIF C ICENS2=ICENSO IF(IR.EQ.N)ICENS2='OFF' C C **************************************************** C ** STEP 2-- ** C ** GENERATE MAXIMUM LIKELIHOOD ESTIMATES ** C ** FOR GIVEN DISTRIBUTION ** C **************************************************** C ISTEPN='2' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBM4') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASPL.EQ.'ADML')THEN IF(ICENS2.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2101) 2101 FORMAT('***** ERROR IN JACKNIFE/BOOTSTRAP MAXIMUM ', 1 'LIKELIHOOD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2103) 2103 FORMAT(' CENSORING NOT SUPPORTED FOR THE ', 1 'ASYMETRIC LAPLACE DISTRIBUTION.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' ELSE XMIN=Y(1) XMAX=Y(N) IR=1 C DHMIN=DBLE(CPUMAX) DO2110I=1,N THETA=Y(I) DSUM1=0.0D0 DSUM2=0.0D0 DO2120J=1,N IF(Y(J).GE.THETA)DSUM1=DSUM1 + DBLE(Y(J) - THETA) IF(Y(J).LE.THETA)DSUM2=DSUM2 + DBLE(THETA - Y(J)) 2120 CONTINUE DALPHA(I)=DSUM1/DBLE(N) DBETA(I)=DSUM2/DBLE(N) DH(I)=2.0D0*DLOG(DSQRT(DALPHA(I)) + DSQRT(DBETA(I))) 1 + DSQRT(DALPHA(I))*DSQRT(DBETA(I)) IF(DH(I).LT.DHMIN)THEN DHMIN=DH(I) IR=I ENDIF 2110 CONTINUE C C TO MAKE THIS PROCEDURE AUTOMATIC: C C 1. IF IR = 1 OR IR = N, MAXIMUM LIKELIHOOD ESTIMATES DO C NOT EXIST. IN THIS CASE, USE IR=2 OR IR = N-1 (ALTHOUGH C THESE ARE NOT EXACT ML ESTIMATES, THIS SEEMS PREFERRABLE C TO RETURNING DUMMY VALUES. HOWEVER, SET THE LOCATION TO C Y(1) OR Y(N) (AS APPROPRIATE). C C 2. ONE ANOMALY THAT CAN HAPPEN IS FOR DALPHA TO BE ZERO FOR C THE LAST SEVERAL VALUES (I.E., WE HAVE TIES FOR THE C MAXIMUM VALUE). IF THIS RESULTS IN THE MINIMUM VALUE, C THIS RESULTS IN A DIVISION BY ZERO IN THE ML COMPUTATIONS. C IN THIS CASE, LOOP BACK UNTIL WE FIND A NON-ZERO VALUE FOR C DALPHA. C C C NOTE 3/2006: INSTEAD OF TRYING TO FAKE ML ESTIMATES, JUST C SET AN ERROR FLAG AND IGNORE THIS BOOTSTRAP SAMPLE. C IF(IR.EQ.1)THEN CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,2131) C2131 FORMAT('***** ERROR FROM ASYMMETRIC DOUBLE EXPONENTIAL ', CCCCC1 'MAXIMUM LIKELIHOOD--') CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,2133) C2133 FORMAT(' ESTIMATE OF LOCATION PARAMTER EQUALS DATA ', CCCCC1 'MINIMUM. THE MAXIMUM') CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,2135) C2135 FORMAT(' LIKELIHOOD ESTIMATES DO NOT EXIST. ', CCCCC1 'HOWEVER, ') CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,2137) C2137 FORMAT(' THIS IMPLIES THAT AN EXPONENTIAL MODEL IS ', CCCCC1 'APPROPRIATE.') CCCCC CALL DPWRST('XXX','WRIT') CCCCC IERROR='YES' CCCCC ALOC=0.0 CCCCC SCALE=1.0 CCCCC SHAPE=-1.0 CCCCC IR=2 CCCCC ALOC=Y(1) IUDFLG=1 GOTO9000 ELSEIF(IR.EQ.N)THEN CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,2131) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,2143) C2143 FORMAT(' ESTIMATE OF LOCATION PARAMTER EQUALS DATA ', CCCCC1 'MAXIMUM. THE MAXIMUM') CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,2145) C2145 FORMAT(' LIKELIHOOD ESTIMATES DO NOT EXIST. ', CCCCC1 'HOWEVER, ') CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,2147) C2147 FORMAT(' THIS IMPLIES THAT A NEGATIVE EXPONENTIAL ', CCCCC1 'MODEL IS APPROPRIATE.') CCCCC CALL DPWRST('XXX','WRIT') CCCCC IERROR='YES' CCCCC ALOC=0.0 CCCCC SCALE=1.0 CCCCC SHAPE=-1.0 CCCCC GOTO9000 CCCCC IR=N-1 CCCCC ALOC=Y(N) IUDFLG=1 GOTO9000 ELSE ALOC=Y(IR) ENDIF C DTERM1=DBETA(IR)**(1.0D0/4.0D0) DTERM2=DALPHA(IR)**(1.0D0/4.0D0) DTERM3=DSQRT(DBETA(IR)) DTERM4=DSQRT(DALPHA(IR)) SCALE=DSQRT(2.0D0)*DTERM2*DTERM1*(DTERM3 + DTERM4) IF(DTERM2.NE.0.0D0)THEN SHAPE=DTERM1/DTERM2 ELSE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,2131) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,2153) C2153 FORMAT(' INFINITE VALUE FOR SHAPE PARAMETER.') CCCCC CALL DPWRST('XXX','WRIT') CCCCC IERROR='YES' CCCCC ALOC=0.0 CCCCC SCALE=1.0 CCCCC SHAPE=-1.0 ILAST=IR DO2350I=ILAST,2,-1 IF(DALPHA(I).GT.0.0D0)THEN IR=I GOTO2359 ENDIF 2350 CONTINUE 2359 CONTINUE DTERM1=DBETA(IR)**(1.0D0/4.0D0) DTERM2=DALPHA(IR)**(1.0D0/4.0D0) DTERM3=DSQRT(DBETA(IR)) DTERM4=DSQRT(DALPHA(IR)) SHAPE=DTERM1/DTERM2 SCALE=DSQRT(2.0D0)*DTERM2*DTERM1*(DTERM3 + DTERM4) ENDIF IF(SHAPE.LE.0.0)SHAPE=0.00001 IF(SCALE.LE.0.0)SCALE=1.0 ENDIF ELSE SHAPE=1.0 SCALE=1.0 ALOC=0.0 GOTO9000 ENDIF IF(IERROR.EQ.'YES')GOTO9000 C C ************************************************** C ** STEP 4-- ** C ** COMPUTE SELECTED PERCENTILES ** C ************************************************** C ISTEPN='4' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBPP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NP.GT.0)THEN IF(ICASPL.EQ.'ADML')THEN DO4110I=1,NP QPTEMP=QP(I)/100.0 CALL ADEPPF(QPTEMP,SHAPE,IADEDF,XQP(I)) XQP(I)=ALOC + SCALE*XQP(I) 4110 CONTINUE ENDIF ENDIF C ******************* C ** STEP 90-- ** C ** EXIT ** C ******************* C 9000 CONTINUE C RETURN END SUBROUTINE DPJBPP(Y,X,N,ICASPL,ICENSO,IMETHD,IPPLDP,MAXOBV, 1MINMAX, 1Y2,X2, 1WEIGHH,WEIGHV,RESBW,PREDBW, 1QP,XQP,NP, 1PPA0,PPA1,CCXY, 1IBUGG3,ISUBRO,IERROR) C C PURPOSE--FOR A GIVEN BOOTSTRAP SAMPLE, GENERATE THE PROBABILITY C PLOT AND RETURN THE ESTIMATES FOR LOCATION (PPA0) AND C SCALE (PPA1). BOTH UNCENSORED AND CENSORED PROBABILITY C PLOTS ARE SUPPORTED. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2005/1 C ORIGINAL VERSION--JANUARY 2005. C C C SUPPORTED DISTRIBUTIONS ARE: C C 1) UNIFORM C 2) NORMAL C 3) LOGISTIC C 4) LAPLACE (DOUBLE EXPONENTIAL) C 5) CAUCHY C 6) HALF NORMAL C 7) EXPONENTIAL C 8) GUMBEL (EXTREME VALUE TYPE 1) C 9) SEMI-CIRCULAR C 10) COSINE C 11) ANGLIT C 12) ARCSINE C 13) HYPERBOLIC SECANT C 14) HALF CAUCHY C 15) RAYLEIGH C 16) SLASH C 17) HALF LOGISTIC C 18) LANDAU (NOT IMPLEMENTED) C C ALL OF THESE SUPPORT BOTH CENSORED AND UNCENSORED DATA C C--------------------------------------------------------------------- C CHARACTER*4 ICASPL CHARACTER*4 ICENSO CHARACTER*4 IMETHD CHARACTER*4 IBUGG3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C DIMENSION Y(*) DIMENSION X(*) DIMENSION Y2(*) DIMENSION X2(*) DIMENSION WEIGHH(*) DIMENSION WEIGHV(*) DIMENSION RESBW(*) DIMENSION PREDBW(*) DIMENSION QP(*) DIMENSION XQP(*) C CHARACTER*4 IWRITE CHARACTER*4 ISTEPN CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 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='DPJB' ISUBN2='PP ' IF(NP.GT.0)THEN DO410I=1,NP XQP(I)=0.0 410 CONTINUE ENDIF C C ************************************************** C ** STEP 1-- ** C ** IF SET PROBABILITY PLOT DATA POINTS COMMAND ** C ** WAS ENTERED, THIN DATA SET BY COMPUTING ** C ** PERCENTILES OF THE DATA. ONLY DO THIS FOR ** C ** THE UNCENSORED CASE. ** C ************************************************** C ISTEPN='1' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBPP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IPPLDP.GT.0 .AND. ICENSO.EQ.'OFF')THEN NPERC=MAX(20,IPPLDP) NPERC=MIN(NPERC,N) CALL SORT(Y,N,Y2) ASTRT=0.0 ASTOP=100.0 AINC=(ASTOP - ASTRT)/REAL(NPERC+1) IWRITE='OFF' DO100I=1,NPERC P100=ASTRT + REAL(I)*AINC CALL PERCEN(P100,Y2,N,IWRITE,X2,MAXOBV, 1 XPERC,IBUGG3,IERROR) X2(I)=XPERC 100 CONTINUE N=NPERC DO105I=1,N Y2(I)=X2(I) 105 CONTINUE ELSE DO110I=1,N Y2(I)=Y(I) 110 CONTINUE ENDIF IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'JBPP')THEN WRITE(ICOUT,113)IPPLDP,NPERC,N 113 FORMAT(' IPPLDP, NPER, N = ',3I8) CALL DPWRST('XXX','BUG ') DO117I=1,N WRITE(ICOUT,118)I,Y2(I) 118 FORMAT(' I, Y2(I) = ',I8,G15.7) CALL DPWRST('XXX','BUG ') 117 CONTINUE ENDIF C IF(ICENSO.EQ.'ON')THEN CALL DISTIN(X,N,IWRITE,X2,NDIST,IBUGG3,IERROR) IF(NDIST.EQ.1)THEN DO1102I=1,N X(I)=1.0 1102 CONTINUE ELSEIF(NDIST.EQ.2)THEN IF(X2(1).EQ.1.0 .OR. X2(2).EQ.1.0)THEN DO1103I=1,N IF(X(I).NE.1.0)X(I)=0.0 1103 CONTINUE ELSE ATEMP1=MIN(X2(1),X2(2)) ATEMP2=MAX(X2(1),X2(2)) DO1108I=1,N IF(X(I).EQ.ATEMP1)X(I)=1.0 IF(X(I).EQ.ATEMP2)X(I)=0.0 1108 CONTINUE ENDIF ELSE WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1104) 1104 FORMAT('***** ERROR IN JACKNIFE/BOOTSTRAP PROBABILITY PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1105) 1105 FORMAT(' FOR CENSORED DATA, THE CENSORING VARIABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1106) 1106 FORMAT(' SHOULD CONTAIN AT MOST TWO DISTINCT VALUES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1107)NDIST 1107 FORMAT(' ',I8,' DISTINCT VALUES FOUND.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF CALL SORTC(Y2,X,N,Y,X) CALL UNIME3(N,X2,X,IMETHD) ELSE CALL SORT(Y2,N,Y) CALL UNIMED(N,X2) ENDIF XMIN=Y(1) XMAX=Y(N) C C ******************************************************** C ** STEP 2-- ** C ** GENERATE PROBABILITY PLOT FOR GIVEN DISTRIBUTION ** C ******************************************************** C ISTEPN='2' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBPP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICNT=0 C IF(ICASPL.EQ.'UNPP')THEN DO1111I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1111 ICNT=ICNT+1 CALL UNIPPF(X2(I),X2OUT) X2(ICNT)=X2OUT 1111 CONTINUE ELSEIF(ICASPL.EQ.'NOPP')THEN DO1121I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1121 ICNT=ICNT+1 CALL NORPPF(X2(I),X2OUT) X2(ICNT)=X2OUT 1121 CONTINUE ELSEIF(ICASPL.EQ.'LOPP')THEN DO1131I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1131 ICNT=ICNT+1 CALL LOGPPF(X2(I),X2OUT) X2(ICNT)=X2OUT 1131 CONTINUE ELSEIF(ICASPL.EQ.'LAPP')THEN DO1141I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1141 ICNT=ICNT+1 CALL DEXPPF(X2(I),X2OUT) X2(ICNT)=X2OUT 1141 CONTINUE ELSEIF(ICASPL.EQ.'CAPP')THEN DO1151I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1151 ICNT=ICNT+1 CALL CAUPPF(X2(I),X2OUT) X2(ICNT)=X2OUT 1151 CONTINUE ELSEIF(ICASPL.EQ.'HNPP')THEN DO1161I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1161 ICNT=ICNT+1 CALL HFNPPF(X2(I),X2OUT) X2(ICNT)=X2OUT 1161 CONTINUE ELSEIF(ICASPL.EQ.'EXPP')THEN DO1171I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1171 ICNT=ICNT+1 CALL EXPPPF(X2(I),X2OUT) X2(ICNT)=X2OUT 1171 CONTINUE ELSEIF(ICASPL.EQ.'GUPP')THEN DO1181I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1181 ICNT=ICNT+1 CALL EV1PPF(X2(I),MINMAX,X2OUT) X2(ICNT)=X2OUT 1181 CONTINUE ELSEIF(ICASPL.EQ.'SEPP')THEN ASCALE=1.0 DO1191I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1191 ICNT=ICNT+1 CALL SEMPPF(X2(I),ASCALE,X2OUT) X2(ICNT)=X2OUT 1191 CONTINUE ELSEIF(ICASPL.EQ.'COPP')THEN DO1201I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1201 ICNT=ICNT+1 CALL COSPPF(X2(I),X2OUT) X2(ICNT)=X2OUT 1201 CONTINUE ELSEIF(ICASPL.EQ.'ANPP')THEN DO1211I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1211 ICNT=ICNT+1 CALL ANGPPF(X2(I),X2OUT) X2(ICNT)=X2OUT 1211 CONTINUE ELSEIF(ICASPL.EQ.'ARPP')THEN DO1221I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1221 ICNT=ICNT+1 CALL ARSPPF(X2(I),X2OUT) X2(ICNT)=X2OUT 1221 CONTINUE ELSEIF(ICASPL.EQ.'HSPP')THEN DO1231I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1231 ICNT=ICNT+1 CALL HSEPPF(X2(I),X2OUT) X2(ICNT)=X2OUT 1231 CONTINUE ELSEIF(ICASPL.EQ.'HCPP')THEN DO1241I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1241 ICNT=ICNT+1 CALL HFCPPF(X2(I),X2OUT) X2(ICNT)=X2OUT 1241 CONTINUE ELSEIF(ICASPL.EQ.'RAPP')THEN DO1251I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1251 ICNT=ICNT+1 CALL RAYPPF(X2(I),X2OUT) X2(ICNT)=X2OUT 1251 CONTINUE ELSEIF(ICASPL.EQ.'SLPP')THEN DO1261I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1261 ICNT=ICNT+1 CALL SLAPPF(X2(I),X2OUT) X2(ICNT)=X2OUT 1261 CONTINUE ELSEIF(ICASPL.EQ.'LUPP')THEN DO1271I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1271 ICNT=ICNT+1 X2OUT=LANPPF(X2(I)) X2(ICNT)=X2OUT 1271 CONTINUE ELSEIF(ICASPL.EQ.'HLPP')THEN GTEMP=-1.0 DO1281I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1281 ICNT=ICNT+1 CALL HFLPPF(X2(I),GTEMP,X2OUT) X2(ICNT)=X2OUT 1281 CONTINUE ELSE PPA0=0.0 PPA1=1.0 GOTO9000 ENDIF C C ************************************************** C ** STEP 3-- ** C ** COMPUTE FITTED LINE TO PROBABILITY PLOT ** C ************************************************** C ISTEPN='3' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBPP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C N2=ICNT ICNT=0 DO1912I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1912 ICNT=ICNT+1 Y2(ICNT)=Y(I) 1912 CONTINUE C IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBPP')THEN WRITE(ICOUT,2001)N2 2001 FORMAT('N2 = ',I8) CALL DPWRST('XXX','BUG ') IF(N2.GE.1)THEN DO2110I=1,N2 WRITE(ICOUT,2011)I,Y2(I),X2(I) 2011 FORMAT('I,Y2(I),X2(I) = ',I8,2G15.7) CALL DPWRST('XXX','BUG ') 2110 CONTINUE ENDIF ENDIF C CALL LINFIT(Y2,X2,N2, 1 PPA0,PPA1,XRESSD,XRESDF,CCXY,SDALPH,SDBETA,CCALBE, 1 ISUBRO,IBUGG3,IERROR) C IF(ICASPL.EQ.'CAPP' .OR. ICASPL.EQ.'HCPP' .OR. 1 ICASPL.EQ.'SLPP')THEN C DO6010I=1,N2 RESBW(I)=Y2(I) - (PPA0 + PPA1*X2(I)) WEIGHH(I)=1.0 WEIGHV(I)=1.0 6010 CONTINUE CALL BIWEIG(RESBW,N2,IWRITE,WEIGHV,IBUGG3,IERROR) C IT=1 I1=1 I2=N2 I3=1 I4=N2 XMAXHF=1.0 C CALL LINEAR(IT,I1,I2,X2,Y2,WEIGHH,WEIGHV,N2,XMAXHF,I3,I4, 1 PPA0BW,PPA1BW,PREDBW,RESBW, 1 ISUBRO,IBUGG3,IERROR) C DO6020I=1,N2 RESBW(I)=Y(I) - (PPA0BW + PPA1BW*X(I)) 6020 CONTINUE CALL BIWEIG(RESBW,N2,IWRITE,WEIGHV,IBUGG3,IERROR) CALL LINEAR(IT,I1,I2,X2,Y2,WEIGHH,WEIGHV,N2,XMAXHF,I3,I4, 1 PPA0BW,PPA1BW,PREDBW,RESBW, 1 ISUBRO,IBUGG3,IERROR) PPA0=PPA0BW PPA1=PPA1BW C ENDIF C C ************************************************** C ** STEP 4-- ** C ** COMPUTE SELECTED PERCENTILES ** C ************************************************** C ISTEPN='4' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBPP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NP.GT.0)THEN IF(ICASPL.EQ.'NOPP')THEN DO4110I=1,NP QPTEMP=QP(I)/100.0 CALL NORPPF(QPTEMP,XQP(I)) XQP(I)=PPA0 + PPA1*XQP(I) 4110 CONTINUE ELSEIF(ICASPL.EQ.'UNPP')THEN DO4120I=1,NP QPTEMP=QP(I)/100.0 CALL UNIPPF(QPTEMP,XQP(I)) XQP(I)=PPA0 + PPA1*XQP(I) 4120 CONTINUE ELSEIF(ICASPL.EQ.'LOPP')THEN DO4130I=1,NP QPTEMP=QP(I)/100.0 CALL LOGPPF(QPTEMP,XQP(I)) XQP(I)=PPA0 + PPA1*XQP(I) 4130 CONTINUE ELSEIF(ICASPL.EQ.'LAPP')THEN DO4140I=1,NP QPTEMP=QP(I)/100.0 CALL DEXPPF(QPTEMP,XQP(I)) XQP(I)=PPA0 + PPA1*XQP(I) 4140 CONTINUE ELSEIF(ICASPL.EQ.'CAPP')THEN DO4150I=1,NP QPTEMP=QP(I)/100.0 CALL CAUPPF(QPTEMP,XQP(I)) XQP(I)=PPA0 + PPA1*XQP(I) 4150 CONTINUE ELSEIF(ICASPL.EQ.'HNPP')THEN DO4160I=1,NP QPTEMP=QP(I)/100.0 CALL HFNPPF(QPTEMP,XQP(I)) XQP(I)=PPA0 + PPA1*XQP(I) 4160 CONTINUE ELSEIF(ICASPL.EQ.'EXPP')THEN DO4170I=1,NP QPTEMP=QP(I)/100.0 CALL EXPPPF(QPTEMP,XQP(I)) XQP(I)=PPA0 + PPA1*XQP(I) 4170 CONTINUE ELSEIF(ICASPL.EQ.'GUPP')THEN DO4180I=1,NP QPTEMP=QP(I)/100.0 CALL EV1PPF(QPTEMP,MINMAX,XQP(I)) XQP(I)=PPA0 + PPA1*XQP(I) 4180 CONTINUE ELSEIF(ICASPL.EQ.'SEPP')THEN DO4190I=1,NP QPTEMP=QP(I)/100.0 CALL SEMPPF(QPTEMP,PPA1,XQP(I)) XQP(I)=PPA0 + XQP(I) 4190 CONTINUE ELSEIF(ICASPL.EQ.'COPP')THEN DO4200I=1,NP QPTEMP=QP(I)/100.0 CALL COSPPF(QPTEMP,XQP(I)) XQP(I)=PPA0 + PPA1*XQP(I) 4200 CONTINUE ELSEIF(ICASPL.EQ.'ANPP')THEN DO4210I=1,NP QPTEMP=QP(I)/100.0 CALL ANGPPF(QPTEMP,XQP(I)) XQP(I)=PPA0 + PPA1*XQP(I) 4210 CONTINUE ELSEIF(ICASPL.EQ.'ARPP')THEN DO4220I=1,NP QPTEMP=QP(I)/100.0 CALL ARSPPF(QPTEMP,XQP(I)) XQP(I)=PPA0 + PPA1*XQP(I) 4220 CONTINUE ELSEIF(ICASPL.EQ.'HSPP')THEN DO4230I=1,NP QPTEMP=QP(I)/100.0 CALL HSEPPF(QPTEMP,XQP(I)) XQP(I)=PPA0 + PPA1*XQP(I) 4230 CONTINUE ELSEIF(ICASPL.EQ.'HCPP')THEN DO4240I=1,NP QPTEMP=QP(I)/100.0 CALL HFCPPF(QPTEMP,XQP(I)) XQP(I)=PPA0 + PPA1*XQP(I) 4240 CONTINUE ELSEIF(ICASPL.EQ.'RAPP')THEN DO4250I=1,NP QPTEMP=QP(I)/100.0 CALL RAYPPF(QPTEMP,XQP(I)) XQP(I)=PPA0 + PPA1*XQP(I) 4250 CONTINUE ELSEIF(ICASPL.EQ.'SLPP')THEN DO4260I=1,NP QPTEMP=QP(I)/100.0 CALL SLAPPF(QPTEMP,XQP(I)) XQP(I)=PPA0 + PPA1*XQP(I) 4260 CONTINUE ELSEIF(ICASPL.EQ.'LUPP')THEN DO4270I=1,NP QPTEMP=QP(I)/100.0 XQP(I)=LANPPF(QPTEMP) XQP(I)=PPA0 + PPA1*XQP(I) 4270 CONTINUE ELSEIF(ICASPL.EQ.'HLPP')THEN GTEMP=-1.0 DO4280I=1,NP QPTEMP=QP(I)/100.0 CALL HFLPPF(QPTEMP,GTEMP,XQP(I)) XQP(I)=PPA0 + PPA1*XQP(I) 4280 CONTINUE ENDIF ENDIF C ******************* C ******************* C ** STEP 90-- ** C ** EXIT ** C ******************* C 9000 CONTINUE C RETURN END SUBROUTINE DPJBRA(ICASRA,ISEED,MINMAX, 1Y,NRAN, 1SHAPE1,SHAPE2,ALOC,SCALE, 1IMAKDF,IGEODF,IBEIDF,IBEKDF,IGEPDF,IADEDF, 1ILGADF,ISKNDF,IGLDDF, 1IBUGG3,ISUBRO,IERROR) C C PURPOSE--THIS ROUTINE IS CALLED BY THE DPJBS2 ROUTINE C (JACKNIFE/BOOTSRAP DISTRIBUTIONAL PLOT). THIS IS C USED TO IMPLEMENT "PARAMETERIC" BOOTSTRAPPING RATHER C THAN "NON-PARAMETRIC" BOOTSTRAPPING. FOR THE C NON-PARAMETRIC BOOTSTRAP, THE DEFAULT, THE BOOTSTRAP C SAMPLES ARE DRAWN FROM THE SAMPLE. FOR THE C PARAMETRIC BOOTSTRAP, THE FULL SAMPLE IS USED TO C ESTIMATE THE DISTRIBUTION PARAMETERS. THEN THESE C PARAMETERS ARE USED TO GENERATE A SAMPLE FROM THAT C ESTIMATED DISTRIBUTION FOR EACH BOOTSTRAP SAMPLE. C THIS ROUTINE IS USED TO GENERATE THAT SAMPLE. C C GENERATE RANDOM NUMBERS C FROM ONE OF THE FOLLOWING DISTRIBUTIONS-- C 1 ) UNIFORM C 2 ) NORMAL C 3 ) LOGISTIC C 4 ) DOUBLE EXPONENTIAL C 5 ) CAUCHY C 6 ) TUKEY LAMBDA C 7 ) LOGNORMAL C 8 ) HALFNORMAL C 9 ) T C 10) CHI-SQUARED C 11) F C 12) EXPONENTIAL C 13) GAMMA C 14) BETA C 15) WEIBULL C 16) EXTREME VALUE TYPE 1 C 17) EXTREME VALUE TYPE 2 C 18) PARETO C 19) BINOMIAL C 20) GEOMETRIC C 21) POISSON C 22) NEGATIVE BINOMIAL C 23) SEMI-CIRCULAR C 24) TRIANGULAR C 25) INVERSE GAUSSIAN C 26) WALD C 27) RECIPROCAL INVERSE GAUSSIAN C 28) FATIGUE LIFE C 29) GENERALIZED PARETO C 30) POWER FUNCTION C 31) HYPERGEOMETRIC C 32) NON-CENTRAL CHI-SQUARE C 33) NON-CENTRAL F C 34) DOUBLY NON-CENTRAL F C 35) FOLDED NORMAL C 36) HALF-CAUCHY C 37) NORMAL MIXTURE C 38) POWER LAW C 39) GENERALIZED TUKEY-LAMBDA C 40) INVERTED WEIBULL C 41) DOUBLE WEIBULL C 42) DOUBLE GAMMA C 43) LOG GAMMA C 44) INVERTED GAMMA C 45) COSINE C 46) ANGLIT C 47) HYPERBOLIC SECANT C 48) ARCSIN C 49) LOG DOUBLE EXPONENTIAL C 50) GENERALIZED EXTREM VALU C 51) EXPONENTIATED WEIBULL C 52) GOMPERTZ C 53) HALF-LOGISTIC C 54) POWER EXPONENTIAL C 55) ALPHA C 56) BRADFORD C 57) RECIPROCAL C 58) JOHNSON SB C 59) JOHNSON SU C 60) POWER NORMAL C 61) LOG-LOGISTIC C 62) GEOMETRIC EXTR EXPO C 63) POWER LOGNORMAL C 64) BETA-BINOMIAL C 65) TWO-SIDED POWER C 66) BIWEIBULL C 66) LOGARITHMIC SERIES C 67) G-AND-H C 68) SLASH C 69) LANDAU C 70) INVERTED BETA C 71) ERROR (=SUBBOTIN C =EXPONENTIAL POWER C =GENERAL ERROR) C 72) TRAPEZOID C 73) VON MISES C 74) PARETO SECOND KIND C 75) WRAPPED CAUCHY C 76) GENERALIZED TRAPEZOID C 77) TRUNCATED NORMAL C 78) CHI C 79) FOLDED CAUCHY C 80) MIELKE'S BETA-KAPPA C 81) GENERALIZED EXPONENTIAL C 82) TRUNCATED EXPONENTIAL C 83) GENERALIZED GAMMA C 84) FOLDED T C 85) SKEWED NORMAL C 86) SKEWED T C 87) ZIPF C 88) GOMPERTZ-MAKEHAM C 89) GENERALIZED INVERSE GAUSSIAN C 90) LOG SKEWED NORMAL C 91) LOG SKEWED T C 92) NON-CENTRAL T C 93) DOUBLY NON-CENTRAL T C 94) GENERALIZED HALF-LOGISTIC C 95) GENERALIZED LOGISTIC C 96) POLYA C 97) HERMITE C 98) YULE C 99) WARING C 100) GENERALIZED WARING C 101) NON-CENTRAL BETA C 102) DOUBLY NON-CENTRAL BETA C 103) SKEW DOUBLE EXPONENTIAL C 104) ASYMMETRIC DOUBLE EXPONENTIAL C 105) MAXWELL C 106) RAYLEIGH C 107) MCLEISH C 108) BESSEL I-FUNCTION C 109) BESSEL K-FUNCTION (NOT WORKING) C 110) GENERALIZED MCLEISH C 111) HYPERBOLIC (NOT WORKING) C 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 INSTITUTE OF STANDARDS AND TECHNOLOGY. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2005/2 C ORIGINAL VERSION--FEBRUARY 2005. C UPDATED --AUGUST 2005. DUNRAN WAS FIXED TO GO FROM C 0 TO N. THIS ROUTINE WAS C MODIFIED TO CALL A VERSION C THAT GOES FROM 1 TO N. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASRA CHARACTER*4 IBUGG3 CHARACTER*4 ISUBRO CHARACTER*4 IWRITE CHARACTER*4 IERROR C CHARACTER*4 IMAKDF CHARACTER*4 IGEODF CHARACTER*4 IGEPDF CHARACTER*4 IADEDF CHARACTER*4 IBEIDF CHARACTER*4 IBEKDF CHARACTER*4 ILGADF CHARACTER*4 ISKNDF CHARACTER*4 IGLDDF C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C CHARACTER*26 IDIST C REAL Y(*) C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C DATA EPS/0.000001/ DATA ALAMLG/0.00001/ C C-----START POINT----------------------------------------------------- C ISUBN1='DPJB' ISUBN2='RA ' C IERROR='NO' C C *********************************************** C ** TREAT THE RANDOM NUMBER GENERATION CASE ** C *********************************************** C IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'JBRA')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPJBRA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGG3,ISUBRO 52 FORMAT('IBUGG3,ISUBRO = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASRA,ISEED,MINMAX 53 FORMAT('ICASRA,ISEED,MINMAX = ',A4,I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)ALOC,SCALE,SHAPE1,SHAPE2 55 FORMAT('ALOC,SCALE,SHAPE1,SHAPE2 = ',4G15.7) CALL DPWRST('XXX','BUG ') ENDIF C C ****************************************** C ** STEP 1-- ** C ** GENERATE NRAN RANDOM NUMBERS ** C ** FROM THE SPECIFIED DISTRIBUTION. ** C ** STORE THEM IN THE VECTOR Y(.). ** C ****************************************** C ISTEPN='1' IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'JBRA') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASRA.EQ.'UNIF')GOTO1010 IF(ICASRA.EQ.'NORM')GOTO1020 IF(ICASRA.EQ.'LOGI')GOTO1030 IF(ICASRA.EQ.'DOUB')GOTO1040 IF(ICASRA.EQ.'CAUC')GOTO1050 IF(ICASRA.EQ.'LAMB')GOTO1060 IF(ICASRA.EQ.'LOGN')GOTO1070 IF(ICASRA.EQ.'HALF')GOTO1080 IF(ICASRA.EQ.'T')GOTO1090 IF(ICASRA.EQ.'CHIS')GOTO1100 IF(ICASRA.EQ.'F')GOTO1110 IF(ICASRA.EQ.'EXPO')GOTO1120 IF(ICASRA.EQ.'GAMM')GOTO1130 IF(ICASRA.EQ.'BETA')GOTO1140 IF(ICASRA.EQ.'WEIB')GOTO1150 IF(ICASRA.EQ.'EXV1')GOTO1160 IF(ICASRA.EQ.'GUMB')GOTO1160 IF(ICASRA.EQ.'EXV2')GOTO1170 IF(ICASRA.EQ.'FREC')GOTO1170 IF(ICASRA.EQ.'PARE')GOTO1180 IF(ICASRA.EQ.'BINO')GOTO1190 IF(ICASRA.EQ.'GEOM')GOTO1200 IF(ICASRA.EQ.'POIS')GOTO1210 IF(ICASRA.EQ.'NEGB')GOTO1220 IF(ICASRA.EQ.'SEMI')GOTO1230 IF(ICASRA.EQ.'TRIA')GOTO1240 IF(ICASRA.EQ.'DIUN')GOTO1250 IF(ICASRA.EQ.'BOOT')GOTO1260 IF(ICASRA.EQ.'PERM')GOTO1270 IF(ICASRA.EQ.'IG')GOTO1290 IF(ICASRA.EQ.'WALD')GOTO1300 IF(ICASRA.EQ.'RIG')GOTO1310 IF(ICASRA.EQ.'FL')GOTO1320 IF(ICASRA.EQ.'GEP')GOTO1330 IF(ICASRA.EQ.'POWF')GOTO1340 IF(ICASRA.EQ.'HYPE')GOTO1350 IF(ICASRA.EQ.'NCCS')GOTO1360 IF(ICASRA.EQ.'NCF ')GOTO1370 IF(ICASRA.EQ.'DNCF')GOTO1380 IF(ICASRA.EQ.'FNRM')GOTO1390 IF(ICASRA.EQ.'HFCA')GOTO1400 IF(ICASRA.EQ.'NMRM')GOTO1410 IF(ICASRA.EQ.'POWL')GOTO1440 IF(ICASRA.EQ.'GLAM')GOTO1460 IF(ICASRA.EQ.'IWEI')GOTO1480 IF(ICASRA.EQ.'DWEI')GOTO1490 IF(ICASRA.EQ.'DGAM')GOTO1500 IF(ICASRA.EQ.'LGAM')GOTO1510 IF(ICASRA.EQ.'IGAM')GOTO1520 IF(ICASRA.EQ.'COSI')GOTO1530 IF(ICASRA.EQ.'ANGL')GOTO1540 IF(ICASRA.EQ.'HSEC')GOTO1550 IF(ICASRA.EQ.'ARCS')GOTO1560 IF(ICASRA.EQ.'LDEX')GOTO1570 IF(ICASRA.EQ.'GEVA')GOTO1580 IF(ICASRA.EQ.'EWEI')GOTO1590 IF(ICASRA.EQ.'GOMP')GOTO1600 IF(ICASRA.EQ.'HALO')THEN IFLGHL=0 GOTO1610 ENDIF IF(ICASRA.EQ.'GHLO')THEN IFLGHL=1 GOTO1610 ENDIF IF(ICASRA.EQ.'POEX')GOTO1620 IF(ICASRA.EQ.'ALPH')GOTO1630 IF(ICASRA.EQ.'BRAD')GOTO1640 IF(ICASRA.EQ.'RECI')GOTO1650 IF(ICASRA.EQ.'JOSB')GOTO1660 IF(ICASRA.EQ.'JOSU')GOTO1670 IF(ICASRA.EQ.'PNOR')GOTO1680 IF(ICASRA.EQ.'LLOG')GOTO1690 IF(ICASRA.EQ.'GEEE')GOTO1700 IF(ICASRA.EQ.'PLNO')GOTO1710 IF(ICASRA.EQ.'BBIN')GOTO1730 IF(ICASRA.EQ.'POLY')GOTO1730 IF(ICASRA.EQ.'STSP')GOTO1760 IF(ICASRA.EQ.'BIWE')GOTO1790 IF(ICASRA.EQ.'LOGS')GOTO1850 IF(ICASRA.EQ.'GH ')GOTO1860 IF(ICASRA.EQ.'SLAS')GOTO1880 IF(ICASRA.EQ.'LAND')GOTO1890 IF(ICASRA.EQ.'IBET')GOTO1900 IF(ICASRA.EQ.'ERRO')GOTO1920 IF(ICASRA.EQ.'TRAP')GOTO1930 IF(ICASRA.EQ.'VONM')GOTO1940 IF(ICASRA.EQ.'PAR2')GOTO1950 IF(ICASRA.EQ.'WRCA')GOTO1960 IF(ICASRA.EQ.'GTRA')GOTO1970 IF(ICASRA.EQ.'TNOR')GOTO2010 IF(ICASRA.EQ.'CHI ')GOTO2040 IF(ICASRA.EQ.'FCAU')GOTO2050 IF(ICASRA.EQ.'BKAP')GOTO2060 IF(ICASRA.EQ.'GEXP')GOTO2090 IF(ICASRA.EQ.'TEXP')GOTO2120 IF(ICASRA.EQ.'GGD ')GOTO2150 IF(ICASRA.EQ.'FT ')GOTO2170 IF(ICASRA.EQ.'SKWN')GOTO2180 IF(ICASRA.EQ.'SKWT')GOTO2190 IF(ICASRA.EQ.'ZIPF')GOTO2200 IF(ICASRA.EQ.'GMAK')GOTO2210 IF(ICASRA.EQ.'GIG ')GOTO2240 IF(ICASRA.EQ.'SKLN')GOTO2270 IF(ICASRA.EQ.'SKLT')GOTO2280 IF(ICASRA.EQ.'NCT ')GOTO2300 IF(ICASRA.EQ.'DNCT')GOTO2310 IF(ICASRA.EQ.'GLOG')GOTO2330 IF(ICASRA.EQ.'HERM')GOTO2340 IF(ICASRA.EQ.'YULE')GOTO2360 IF(ICASRA.EQ.'WARI')GOTO2370 IF(ICASRA.EQ.'GWAR')GOTO2390 IF(ICASRA.EQ.'NCBE')GOTO2420 IF(ICASRA.EQ.'DNCB')GOTO2450 IF(ICASRA.EQ.'SKDE')GOTO2490 IF(ICASRA.EQ.'ASDE')GOTO2500 IF(ICASRA.EQ.'MAXW')GOTO2520 IF(ICASRA.EQ.'RAYL')GOTO2530 IF(ICASRA.EQ.'GASD')GOTO2540 IF(ICASRA.EQ.'MCLE')GOTO2560 IF(ICASRA.EQ.'BESI')GOTO2570 IF(ICASRA.EQ.'BESK')GOTO2600 IF(ICASRA.EQ.'GMCL')GOTO2630 IF(ICASRA.EQ.'HBOL')GOTO2650 C 5950 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5951) 5951 FORMAT('***** INTERNAL ERROR IN DPJBRA') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5952) 5952 FORMAT(' AT BRANCH POINT 1951--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5953) 5953 FORMAT(' ICASRA NOT EQUAL ONE OF THE ALLOWABLE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5954) 5954 FORMAT(' UNIF, NORM, LOGI, DOUB, CAUC, ETC.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5955) 5955 FORMAT(' EVEN THOUGH ICASRA HAD ALREADY PASSED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5956)ICASRA 5956 FORMAT(' THIS TEST ONCE BEFORE. VALUE OF ICASRA = ',A4) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 1010 CONTINUE CALL UNIRAN(NRAN,ISEED,Y) GOTO2990 C 1020 CONTINUE CALL NORRAN(NRAN,ISEED,Y) GOTO2990 C 1030 CONTINUE CALL LOGRAN(NRAN,ISEED,Y) GOTO2990 C 1040 CONTINUE CALL DEXRAN(NRAN,ISEED,Y) GOTO2990 C 1050 CONTINUE CALL CAURAN(NRAN,ISEED,Y) GOTO2990 C 1060 CONTINUE CALL LAMRAN(NRAN,ALAMBA,ISEED,Y) GOTO2990 C 1070 CONTINUE CALL LGNRAN(NRAN,SHAPE1,ISEED,Y) GOTO2990 C 1080 CONTINUE CALL HFNRAN(NRAN,ISEED,Y) GOTO2990 C 1090 CONTINUE CALL TRAN(NRAN,SHAPE1,ISEED,Y) GOTO2990 C 1100 CONTINUE CALL CHSRAN(NRAN,SHAPE1,ISEED,Y) GOTO2990 C 1110 CONTINUE CALL FRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) GOTO2990 C 1120 CONTINUE CALL EXPRAN(NRAN,ISEED,Y) GOTO2990 C 1130 CONTINUE CALL GAMRAN(NRAN,SHAPE1,ISEED,Y) GOTO2990 C 1140 CONTINUE CALL BETRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) GOTO2990 C 1150 CONTINUE CALL WEIRAN(NRAN,SHAPE1,MINMAX,ISEED,Y) GOTO2990 C 1160 CONTINUE CALL EV1RAN(NRAN,MINMAX,ISEED,Y) GOTO2990 C 1170 CONTINUE CALL EV2RAN(NRAN,GAMMA,MINMAX,ISEED,Y) GOTO2990 C 1180 CONTINUE CALL PARRAN(NRAN,GAMMA,A,ISEED,Y) GOTO2990 C 1190 CONTINUE CALL BINRAN(NRAN,P,NPAR,ISEED,Y) GOTO2990 C 1200 CONTINUE IF(IGEODF.EQ.'DLMF')THEN CALL GE2RAN(NRAN,P,ISEED,Y) ELSE CALL GEORAN(NRAN,P,ISEED,Y) ENDIF GOTO2990 C 1210 CONTINUE CALL POIRAN(NRAN,ALAMBA,ISEED,Y) GOTO2990 C 1220 CONTINUE CALL NBRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) GOTO2990 C 1230 CONTINUE CALL SEMRAN(NRAN,ISEED,Y) GOTO2990 C 1240 CONTINUE ZLOWLM=-1.0 ZUPPLM=1.0 CALL TRIRAN(NRAN,C,ZLOWLM,ZUPPLM,ISEED,Y) GOTO2990 C 1250 CONTINUE CALL DUNRAN(NRAN,NPAR,ISEED,Y) GOTO2990 C 1260 CONTINUE CCCCC CALL DUNRAN(NRAN,NRAN,ISEED,Y) CALL DUNRA2(NRAN,NRAN,ISEED,Y) GOTO2990 C 1270 CONTINUE CALL RANPER(NRAN,ISEED,Y) GOTO2990 C 1290 CONTINUE CALL IGRAN(NRAN,SHAPE1,AMU,ISEED,Y) GOTO2990 C 1300 CONTINUE CALL WALRAN(NRAN,SHAPE1,ISEED,Y) GOTO2990 C 1310 CONTINUE CALL RIGRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) GOTO2990 C 1320 CONTINUE CALL FLRAN(NRAN,SHAPE1,ISEED,Y) GOTO2990 C 1330 CONTINUE CALL GEPRAN(NRAN,SHAPE1,MINMAX,IGEPDF,ISEED,Y) GOTO2990 C 1340 CONTINUE CALL POWRAN(NRAN,SHAPE1,ISEED,Y) GOTO2990 C 1350 CONTINUE CCCCC DO1352II=1,NRAN CCCCC CALL HYPRAN(KK,NN1,NN2,ISEED,JX) CCCCC IF(JX.EQ.-1)THEN CCCCC WRITE(ICOUT,1354) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1356)INT(AK),INT(AM),INT(AN) CCCCC CALL DPWRST('XXX','BUG ') CCCCC IERROR='YES' CCCCC GOTO9000 CCCCC ENDIF C1354 FORMAT('****** ERROR IN GENERATING HYPERGEOMETRIC RANDOM ', CCCCC1 'NUMBERS.') C1356 FORMAT(' THE VALUES OF K, M, AND N = ',3I8) CCCCC Y(II)=REAL(JX) C1352 CONTINUE GOTO2990 C 1360 CONTINUE CALL NCCRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) GOTO2990 C 1370 CONTINUE CALL NCFRAN(NRAN,ANU1,ANU2,ALAMB1,ISEED,Y) GOTO2990 C 1380 CONTINUE CALL DNFRAN(NRAN,ANU1,ANU2,ALAMB1,ALAMB2,ISEED,Y) GOTO2990 C 1390 CONTINUE CALL FNRRAN(NRAN,U,SD,ISEED,Y) GOTO2990 C 1400 CONTINUE CALL HFCRAN(NRAN,ISEED,Y) GOTO2990 C 1410 CONTINUE C CCCCC CALL NMXRAN(NRAN,U1,SD1,U2,SD2,P,ISEED,Y) GOTO2990 C 1440 CONTINUE C CALL PWLRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) GOTO2990 C 1460 CONTINUE CALL GLDRAN(NRAN,SHAPE1,SHAPE2,ISEED,IGLDDF,Y) GOTO2990 C 1480 CONTINUE CALL IWERAN(NRAN,SHAPE1,ISEED,Y) GOTO2990 C 1490 CONTINUE CALL DWERAN(NRAN,SHAPE1,ISEED,Y) GOTO2990 C 1500 CONTINUE CALL DGARAN(NRAN,SHAPE1,ISEED,Y) GOTO2990 C 1510 CONTINUE CALL LGARAN(NRAN,SHAPE1,ILGADF,ISEED,Y) GOTO2990 C 1520 CONTINUE CALL IGARAN(NRAN,SHAPE1,ISEED,Y) GOTO2990 C 1530 CONTINUE CALL COSRAN(NRAN,ISEED,Y) GOTO2990 C 1540 CONTINUE CALL ANGRAN(NRAN,ISEED,Y) GOTO2990 C 1550 CONTINUE CALL HSERAN(NRAN,ISEED,Y) GOTO2990 C 1560 CONTINUE CALL ARSRAN(NRAN,ISEED,Y) GOTO2990 C 1570 CONTINUE CALL LDERAN(NRAN,SHAPE1,ISEED,Y) GOTO2990 C 1580 CONTINUE CALL GEVRAN(NRAN,SHAPE1,MINMAX,ISEED,Y) GOTO2990 C 1590 CONTINUE C CALL EWERAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) GOTO2990 C 1600 CONTINUE CALL GOMRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) GOTO2990 C 1610 CONTINUE CALL HFLRAN(NRAN,SHAPE1,ISEED,Y) GOTO2990 C 1620 CONTINUE CALL PEXRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) GOTO2990 C 1630 CONTINUE CALL ALPRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) GOTO2990 C 1640 CONTINUE CALL BRARAN(NRAN,SHAPE1,ISEED,Y) GOTO2990 C 1650 CONTINUE CALL RECRAN(NRAN,SHAPE1,ISEED,Y) GOTO2990 C 1660 CONTINUE CALL JSBRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) GOTO2990 C 1670 CONTINUE CALL JSURAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) GOTO2990 C 1680 CONTINUE CALL PNRRAN(NRAN,SHAPE1,ISEED,Y) GOTO2990 C 1690 CONTINUE CALL LLGRAN(NRAN,SHAPE1,ISEED,Y) GOTO2990 C 1700 CONTINUE CALL GEERAN(NRAN,SHAPE1,ISEED,Y) GOTO2990 C 1710 CONTINUE CALL PLNRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) GOTO2990 C 1730 CONTINUE C IF(ICASRA.EQ.'POLY')THEN IDIST='POLYA DISTRIBUTION' ELSE IDIST='BETA-BINOMIAL DISTRIBUTION' ENDIF C IF(ICASRA.EQ.'POLY')THEN CALL BBNRAN(SHAPE1,SHAPE2,N,NRAN,ISEED,Y) ELSE CALL BBNRAN(SHAPE1,SHAPE2,N,NRAN,ISEED,Y) ENDIF GOTO2990 C 1760 CONTINUE CALL TSPRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) GOTO2990 C 1790 CONTINUE CCCCC CALL BWERAN(NRAN,ASCAL1,GAMMA1,ALOC2,ASCAL2,GAMMA2,ISEED,Y) GOTO2990 C 1850 CONTINUE CALL DLGRAN(NRAN,SHAPE1,ISEED,Y) GOTO2990 C 1860 CONTINUE CALL GHRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) GOTO2990 C 1880 CONTINUE CALL SLARAN(NRAN,ISEED,Y) GOTO2990 C 1890 CONTINUE CALL LANRAN(NRAN,ISEED,Y) GOTO2990 C 1900 CONTINUE CALL IBRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) GOTO2990 C 1920 CONTINUE CALL ERRRAN(NRAN,ALPHA,ISEED,Y) GOTO2990 C 1930 CONTINUE CCCCC CALL TRARAN(NRAN,A,B,C,DZ,ISEED,Y) GOTO2990 C 1940 CONTINUE CALL VONRAN(NRAN,SHAPE1,ISEED,Y) GOTO2990 C 1950 CONTINUE CALL PA2RAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) GOTO2990 C 1960 CONTINUE CALL WCARAN(NRAN,P,ISEED,Y) GOTO2990 C 1970 CONTINUE CCCCC CALL GTRRAN(NRAN,A,B,C,DZ,ANU1,ANU3,ALPHA,ISEED,Y) GOTO2990 C 2010 CONTINUE CCCCC CALL TNRRAN(NRAN,A,B,U,SD,ISEED,Y) GOTO2990 C 2040 CONTINUE CALL CHRAN(NRAN,SHAPE1,ISEED,Y) GOTO2990 C 2050 CONTINUE CALL FCARAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) GOTO2990 C 2060 CONTINUE CCCCC CALL KAPRAN(NRAN,AK,BETA,THETA,ISEED,Y) GOTO2990 C 2090 CONTINUE CCCCC CALL GEXRAN(NRAN,ALAM12,ALAM12,S,ISEED,Y) GOTO2990 C 2120 CONTINUE CCCCC CALL TNERAN(NRAN,X0,AM,SD,ISEED,Y) GOTO2990 C 2150 CONTINUE CALL GGDRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) GOTO2990 C 2170 CONTINUE CALL FTRAN(NRAN,INT(SHAPE1+0.5),ISEED,Y) GOTO2990 C 2180 CONTINUE CALL SNRAN(NRAN,SHAPE1,ISKNDF,ISEED,Y) GOTO2990 C 2190 CONTINUE CALL STRAN(NRAN,INT(SHAPE1+0.5),SHAPE2,ISEED,Y) GOTO2990 C 2200 CONTINUE CALL ZIPRAN(NRAN,SHAPE1,ISEED,Y) GOTO2990 C 2210 CONTINUE IF(IMAKDF.EQ.'DLMF')THEN CCCCC CALL MAKRAN(NRAN,XI,ALAMB,THETA,ISEED,Y) ELSEIF(IMAKDF.EQ.'MEEK')THEN CCCCC XI=GAMMA/AK CCCCC THETA=ALAMB/GAMMA CCCCC ALAMB=AK CCCCC CALL MAKRAN(NRAN,XI,ALAMB,THETA,ISEED,Y) ELSEIF(IMAKDF.EQ.'REPA')THEN C CALL MA2RAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) ENDIF GOTO2990 C 2240 CONTINUE CCCCC CALL GIGRAN(NRAN,CHI,ALAMB,THETA,ISEED,Y) GOTO2990 C 2270 CONTINUE CALL LSNRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) GOTO2990 C 2280 CONTINUE CCCCC CALL LSTRAN(NRAN,NU,ALMBDA,SD,ISEED,Y) GOTO2990 C 2300 CONTINUE CALL NCTRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) GOTO2990 C 2310 CONTINUE CCCCC CALL DNTRAN(NRAN,ANU,ALAMB1,ALAMB2,ISEED,Y) GOTO2990 C 2330 CONTINUE CALL GLORAN(NRAN,SHAPE1,ISEED,Y) GOTO2990 C 2340 CONTINUE CALL HERRAN(SHAPE1,SHAPE2,NRAN,ISEED,Y) GOTO2990 C 2360 CONTINUE CALL YULRAN(NRAN,SHAPE1,ISEED,Y) GOTO2990 C 2370 CONTINUE CCCCC CALL GWARAN(NRAN,A,B,C,ISEED,Y) GOTO2990 C 2390 CONTINUE CCCCC CALL GWARAN(NRAN,A,B,C,ISEED,Y) GOTO2990 C 2420 CONTINUE CCCCC CALL NCBRAN(NRAN,ALPHA,BETA,ALAMB,ISEED,Y) GOTO2990 C 2450 CONTINUE CCCCC CALL DNBRAN(NRAN,ALPHA,BETA,ALAMB1,ALAMB2,ISEED,Y) GOTO2990 C 2490 CONTINUE CALL SDERAN(NRAN,SHAPE1,ISEED,Y) GOTO2990 C 2500 CONTINUE CALL ADERAN(NRAN,SHAPE1,IADEDF,ISEED,Y) C 2520 CONTINUE CALL MAXRAN(NRAN,SHAPE1,ISEED,Y) GOTO2990 C 2530 CONTINUE CALL RAYRAN(NRAN,ISEED,Y) GOTO2990 C 2540 CONTINUE CCCCC CALL GALRAN(NRAN,SHAPE1,SHAPE2,IADEDF,ISEED,Y) GOTO2990 C 2560 CONTINUE CALL MCLRAN(NRAN,SHAPE1,ISEED,Y) GOTO2990 C 2570 CONTINUE CCCCC CALL BEIRAN(NRAN,S1SQ,S2SQ,ANU,IBEIDF,ISEED,Y) C 2600 CONTINUE CCCCC CALL BEKRAN(NRAN,S1SQ,S2SQ,ANU,ISEED,Y) GOTO2990 C 2630 CONTINUE CALL GMCRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) GOTO2990 C 2650 CONTINUE CCCCC CALL HBORAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) GOTO2990 C 2990 CONTINUE C DO3010I=1,N Y(I)=ALOC + SCALE*Y(I) 3010 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'JBRA')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPJBRA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IERROR,IBUGG3,ISUBRO 9013 FORMAT('IERROR,IBUGG3,ISUBRO = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)ICASRA,ISEED,MINMAX 9014 FORMAT('ICASRA,ISEED,MINMAX = ',A4,I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)NRAN 9015 FORMAT('NRAN = ',I8) CALL DPWRST('XXX','BUG ') DO9020I=1,MIN(NRAN,100) WRITE(ICOUT,9021)I,Y(I) 9021 FORMAT('I,Y(I) = ',I8,G15.7) CALL DPWRST('XXX','BUG ') 9020 CONTINUE ENDIF C RETURN END SUBROUTINE DPJUST(ICOM,IHARG,NUMARG, 1IDEFJU, 1ITEXJU, 1IBUGD2,ISUBRO,IFOUND,IERROR) C C PURPOSE--DEFINE THE JUSTIFICATION TYPE FOR C TEXT SCRIPT C ON A PLOT. C THE JUSTIFICATION FOR THE TEXT WILL BE PLACED C IN THE CHARACTER VARIABLE ITEXJU. C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDEFJU C --IBUGD2 C OUTPUT ARGUMENTS--ITEXJU 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 --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICOM CHARACTER*4 IHARG CHARACTER*4 IDEFJU CHARACTER*4 ITEXJU CHARACTER*4 IBUGD2 CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR 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 IF(IBUGD2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPJUST--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICOM,NUMARG,IDEFJU 53 FORMAT('ICOM,NUMARG,IDEFJU = ',A4,2X,I8,2X,A4) CALL DPWRST('XXX','BUG ') DO55I=1,NUMARG WRITE(ICOUT,56)I,IHARG(I) 56 FORMAT('I,IHARG(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ************************************ C ** TREAT THE JUSTIFICATION CASE ** C ************************************ C 1110 CONTINUE IF(ICOM.EQ.'JUST')GOTO1120 IF(ICOM.EQ.'LEFT')GOTO1130 IF(ICOM.EQ.'CENT')GOTO1140 IF(ICOM.EQ.'RIGH')GOTO1150 C 1120 CONTINUE IF(NUMARG.LE.0)GOTO1161 IF(IHARG(NUMARG).EQ.'ON')GOTO1161 IF(IHARG(NUMARG).EQ.'OFF')GOTO1161 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1161 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1165 IF(IHARG(NUMARG).EQ.'?')GOTO8100 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'LEFT')GOTO1161 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CENT')GOTO1162 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'RIGH')GOTO1163 GOTO1170 C 1130 CONTINUE IF(NUMARG.LE.0)GOTO9000 IF(IHARG(NUMARG).EQ.'ON')GOTO1161 IF(IHARG(NUMARG).EQ.'OFF')GOTO1161 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1161 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1165 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'JUST')GOTO1161 GOTO9000 C 1140 CONTINUE IF(NUMARG.LE.0)GOTO9000 IF(IHARG(NUMARG).EQ.'ON')GOTO1162 IF(IHARG(NUMARG).EQ.'OFF')GOTO1162 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1162 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1165 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'JUST')GOTO1162 GOTO9000 C 1150 CONTINUE IF(NUMARG.LE.0)GOTO9000 IF(IHARG(NUMARG).EQ.'ON')GOTO1163 IF(IHARG(NUMARG).EQ.'OFF')GOTO1163 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1163 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1165 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'JUST')GOTO1163 GOTO9000 C 1161 CONTINUE ITEXJU='LEFT' GOTO1180 C 1162 CONTINUE ITEXJU='CENT' GOTO1180 C 1163 CONTINUE ITEXJU='RIGH' GOTO1180 C 1165 CONTINUE ITEXJU=IDEFJU GOTO1180 C 1170 CONTINUE CCCCC IERROR='YES' CCCCC WRITE(ICOUT,1171) C1171 FORMAT('***** ERROR IN DPJUST--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1172) C1172 FORMAT(' ILLEGAL ENTRY FOR JUSTIFICATION ', CCCCC CALL DPWRST('XXX','BUG ') CCCCC1'COMMAND.') CCCCC WRITE(ICOUT,1173) C1173 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE ', CCCCC CALL DPWRST('XXX','BUG ') CCCCC1'PROPER FORM--') CCCCC WRITE(ICOUT,1174) C1174 FORMAT(' SUPPOSE THE THE ANALYST WISHES ') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1175) C1175 FORMAT(' TO HAVE ALL LEGENDS CENTERED,') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1177) C1177 FORMAT(' THEN ALLOWABLE FORMS ARE--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1178) C1178 FORMAT(' JUSTIFICATION CENTER ') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1179) C1179 FORMAT(' CENTER JUSTIFICATION ') CCCCC CALL DPWRST('XXX','BUG ') CCCCC GOTO9000 ITEXJU=IHARG(NUMARG) GOTO1180 C 1180 CONTINUE IFOUND='YES' C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181) 1181 FORMAT('THE JUSTIFICATION (FOR PLOT SCRIPT AND TEXT) ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1182)ITEXJU 1182 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO9000 C C ******************************************** C ** STEP 81-- ** C ** TREAT THE ? CASE-- ** C ** DUMP OUT CURRENT AND DEFAULT VALUES. ** C ******************************************** C 8100 CONTINUE IFOUND='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8111)ITEXJU 8111 FORMAT('THE CURRENT JUSTIFICATION IS ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8112)IDEFJU 8112 FORMAT('THE DEFAULT JUSTIFICATION IS ',A4) CALL DPWRST('XXX','BUG ') GOTO9000 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 DPJUST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGD2,ISUBRO,IFOUND,IERROR 9012 FORMAT('IBUGD2,ISUBRO,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ITEXJU,IDEFJU 9013 FORMAT('ITEXJU,IDEFJU = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPKAPL(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 KAPLAN-MEIER 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 UPDATED --JULY 2005. SUPPORT SWITCH FOR WHETHER C SURVIVAL CURVE (DEFAULT) OR C CDF CURVE DRAWN 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 TAG1(MAXOBV) INCLUDE 'DPCOZZ.INC' EQUIVALENCE (GARBAG(IGARB1),Y1(1)) EQUIVALENCE (GARBAG(IGARB2),TAG1(1)) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' INCLUDE 'DPCOST.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='DPKA' ISUBN2='PL ' 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.'KAPL')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPKAPL--') 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 KAPLAN-MEIER PLOT ** C ********************************** C C ******************************************* C ** STEP 1-- ** C ** SEARCH FOR KAPLAN MEIER, KAPLAN-MEIER** C ** MODIFIED KAPLAN MEIER, OR MODIFIED ** C ** KAPLAN-MEIER ** C ******************************************* C ISTEPN='11' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'KAPL') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASPL='KAPL' IF(NUMARG.GE.1.AND. 1ICOM.EQ.'KAPL'.AND.IHARG(1).EQ.'PLOT') 1GOTO111 C IF(NUMARG.GE.2.AND. 1ICOM.EQ.'KAPL'.AND.IHARG(1).EQ.'MEIE'.AND.IHARG(2).EQ.'PLOT') 1GOTO112 C ICASPL='MKAP' IF(NUMARG.GE.2.AND. 1ICOM.EQ.'MODI'.AND.IHARG(1).EQ.'KAPL'.AND.IHARG(2).EQ.'PLOT') 1GOTO112 C ICASPL='MKAP' IF(NUMARG.GE.3.AND. 1ICOM.EQ.'MODI'.AND.IHARG(1).EQ.'KAPL'.AND.IHARG(2).EQ.'MEIE' 1.AND.IHARG(3).EQ.'PLOT') 1GOTO113 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 113 CONTINUE ILASTC=3 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.'KAPL') 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.'KAPL'.OR.ICASPL.EQ.'MKAP')GOTO270 C 260 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,261) 261 FORMAT('***** INTERNAL ERROR IN DPKAPL') 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 KAPL OR MKAP') 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.'KAPL') 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.'KAPL') 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 DPKAPL--') 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 KAPLAN MEIER 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.'KAPL') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHRIGH=IHARG(2) IHRIG2=IHARG2(2) IHWUSE='V' MESSAG='NO' CALL CHECKN(IHRIGH,IHRIG2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,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 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.'KAPL') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMV.EQ.2.AND.(NLEFT.NE.NRIGHT))THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1411) 1411 FORMAT('***** ERROR IN DPKAPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1412) 1412 FORMAT(' IF TWO VARIABLES ARE SPECIFED FOR THE ', 1 'KAPLAN-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 ENDIF 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.'KAPL') 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.'KAPL')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 KAPLAN MEIER PLOT). ** C *********************************************** C ISTEPN='22' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'KAPL') 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 DPKAPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2252) 2252 FORMAT(' FOR A KAPLAN MEIER 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.'KAPL') 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 DPKAPL--') 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 KAPLAN MEIER 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 TAG1(J)=-1.0 ELSE IJ=MAXN*(ICOLR-1)+I IF(ICOLR.LE.MAXCOL)TAG1(J)=V(IJ) IF(ICOLR.EQ.MAXCP1)TAG1(J)=PRED(I) IF(ICOLR.EQ.MAXCP2)TAG1(J)=RES(I) IF(ICOLR.EQ.MAXCP3)TAG1(J)=YPLOT(I) IF(ICOLR.EQ.MAXCP4)TAG1(J)=XPLOT(I) IF(ICOLR.EQ.MAXCP5)TAG1(J)=X2PLOT(I) IF(ICOLR.EQ.MAXCP6)TAG1(J)=TAGPLO(I) ENDIF 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.'KAPL') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL DPKAP2(Y1,TAG1,NS,NUMV,ICASPL,MAXN, 1IKAPSW, 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.'KAPL')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPKAPL--') 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 DPKAP2(Y1,TAG1,N,NUMV,ICASPL,MAXN, 1IKAPSW, 1Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR) C C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS C THAT WILL DEFINE AN KAPLAN-MEIER PLOT C INPUT ARGUMENTS--Y1 = THE SINGLE PRECISION VECTOR OF C (UNSORTED) OBSERVATIONS C FOR THE FIRST VARIABLE. C TAG1 = 1 = FAILURE TIME, 0 = CENSORED 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 UPDATED --JULY 2005. SWITCH TO SPECIFY WHETHER C SURVIVAL CURVE (DEFAULT) OR C CDF CURVE DRAWN C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IKAPSW CHARACTER*4 IBUGG3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DOUBLE PRECISION DPROD DOUBLE PRECISION DCURR DOUBLE PRECISION DN DOUBLE PRECISION DCORR C DIMENSION Y1(*) DIMENSION TAG1(*) 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='DPKA' ISUBN2='P2 ' C IERROR='NO' C IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'KAP2')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPKAP2--') 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,NUMV 53 FORMAT('N,ICASPL,MAXN,NUMV = ',I8,2X,A4,I8,I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,Y1(I),TAG1(I) 56 FORMAT('I, Y1(I), TAG1(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 DPKAP2--') 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 DPKAP2--') 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 KAPLAN MEIER PLOT** C ** (INCORPORATE STAIR-STEP APPEARANCE) ** C *********************************************** C CALL SORTC(Y1,TAG1,N,Y1,TAG1) IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'KAP2')THEN DO135I=1,N WRITE(ICOUT,136)I,Y1(I),TAG1(I) 136 FORMAT('I, Y1(I), TAG1(I), = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 135 CONTINUE ENDIF C DN=DBLE(N) IF(ICASPL.EQ.'KAPL')THEN IR=0 J=1 X(J)=0.0 Y(J)=1.0 D(J)=1.0 C DPROD=1.0D0 DO200I=1,N IF(NUMV.GE.2 .AND. ABS(TAG1(I)).LT.0.5)GOTO200 J=J+1 X(J)=Y1(I) Y(J)=Y(J-1) D(J)=1.0 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'KAP2')THEN WRITE(ICOUT,203)I,J,X(J),Y(J) 203 FORMAT('I,J,X(J),Y(J)=',2I8,2G15.7) CALL DPWRST('XXX','BUG ') ENDIF DCURR=(DN - DBLE(I))/(DN - DBLE(I) + 1.0D0) DPROD=DPROD*DCURR J=J+1 X(J)=Y1(I) Y(J)=REAL(DPROD) D(J)=1.0 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'KAP2')THEN WRITE(ICOUT,204)I,J,X(J),Y(J) 204 FORMAT('I,J,X(J),Y(J)=',2I8,2G15.7) CALL DPWRST('XXX','BUG ') ENDIF 200 CONTINUE ELSEIF(ICASPL.EQ.'MKAP')THEN IR=0 J=1 X(J)=0.0 Y(J)=1.0 D(J)=1.0 C DPROD=1.0D0 DCORR=(DN + 0.7D0)/(DN + 0.4D0) DO400I=1,N IF(NUMV.GE.2 .AND. ABS(TAG1(I)).LT.0.5)GOTO400 J=J+1 X(J)=Y1(I) Y(J)=Y(J-1) D(J)=1.0 DCURR=(DN - DBLE(I) + 0.7D0)/(DN - DBLE(I) + 1.7D0) DPROD=DPROD*DCURR J=J+1 X(J)=Y1(I) Y(J)=REAL(DCORR*DPROD) D(J)=1.0 400 CONTINUE ENDIF C NPLOTP=J NPLOTV=2 C CCCCC JULY 2005: CONVERT TO CDF FORMAT C IF(IKAPSW.EQ.'CDF')THEN DO510I=1,NPLOTP Y(I)=1.0 - Y(I) 510 CONTINUE ENDIF C GOTO9000 C C ****************** C ** STEP 90-- ** C ** EXIT ** C ****************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'KAP2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPKAP2--') 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 DPKDEN(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IKDENP,PKDEWI,ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) C C PURPOSE--GENERATE A KERNEL DENSITY PLOT USING A C GAUSSIAN WINDOW. USES APPLIED STATISTICS C ALGORITHM 176 (BY B. W. SILVERMAN). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2001/8 C ORIGINAL VERSION--AUGUST 2001. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IAND1 CHARACTER*4 IAND2 CHARACTER*4 ISUBRO CHARACTER*4 IBUGG2 CHARACTER*4 IBUGG3 CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASEQ CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CHARACTER*4 IERRO4 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DOUBLE PRECISION Y1(MAXOBV) DOUBLE PRECISION SMOOTH(MAXOBV) DOUBLE PRECISION FT(MAXOBV) INCLUDE 'DPCOZD.INC' EQUIVALENCE (DGARBG(IDGAR1),Y1(1)) EQUIVALENCE (DGARBG(IDGAR2),SMOOTH(1)) EQUIVALENCE (DGARBG(IDGAR3),FT(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='DPKD' ISUBN2='EN ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C MAXV2=1 MINN2=20 C ICOLR=0 C C *************************************************** C ** TREAT THE KERNEL DENSITY PLOT ** C *************************************************** C IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'KDEN')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPKDEN--') 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 ') ENDIF C C *************************** C ** STEP 1-- ** C ** EXTRACT THE COMMAND ** C *************************** C ISTEPN='1' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'KDEN') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'KERN'.AND.IHARG(1).EQ.'PLOT')GOTO110 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'KERN'.AND.IHARG(1).EQ.'DENS'.AND.IHARG(2).EQ.'PLOT') 1GOTO120 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'DENS'.AND.IHARG(1).EQ.'PLOT')GOTO110 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'DENS'.AND.IHARG(1).EQ.'TRAC')GOTO110 C IFOUND='NO' GOTO9000 C 110 CONTINUE ICASPL='KDEN' ILASTC=1 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO180 C 120 CONTINUE ICASPL='KDEN' 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='1' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'KDEN') 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 C ******************************************** C ** STEP 2-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C ** (THIS WILL BE THE RESPONSE VARIABLE) ** C ******************************************** C ISTEPN='2' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'KDEN') 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) IF(IBUGG2.EQ.'ON')WRITE(ICOUT,211)IHLEFT,IHLEF2,ICOLL,NLEFT 211 FORMAT('IHLEFT,IHLEF2,ICOLL,NLEFT = ',A4,2X,A4,I8,I8) IF(IBUGG2.EQ.'ON')CALL DPWRST('XXX','BUG ') C C ***************************************************** C ** STEP 3-- ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS ** C ** (NLEFT) FOR THE RESPONSE VARIABLE IS POSITIVE. ** C ***************************************************** C ISTEPN='3' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'KDEN') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NLEFT.GE.MINN2)GOTO390 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,311) 311 FORMAT('***** ERROR IN DPKDEN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,312) 312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS FOR WHICH A') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,314) 314 FORMAT(' KERNEL DENSITY PLOT WAS TO HAVE BEEN FORMED MUST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,315)MINN2 315 FORMAT(' BE ',I8,' OR LARGER; SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,317) 317 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,318)(IANS(I),I=1,MIN(IWIDTH,80)) 318 FORMAT(80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 390 CONTINUE C C ***************************************** C ** STEP 4-- ** C ** CHECK TO SEE THE TYPE SUBCASE ** C ** (BASED ON THE QUALIFIER)-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='4' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO480 DO400J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO410 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO410 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO420 400 CONTINUE GOTO490 410 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO490 420 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO490 C 480 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,481) 481 FORMAT('***** INTERNAL ERROR IN DPKDEN AT BRANCH POINT 481--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,483) 483 FORMAT(' NUMARG LESS THAN 1 EVEN THOUGH NUMARG HAD PASSED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,485)NUMARG 485 FORMAT(' THIS TEST ONCE ALREADY. VALUE OF NUMARG = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,486) 486 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,487)(IANS(I),I=1,MIN(80,IWIDTH)) 487 FORMAT(80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 C 490 CONTINUE IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'KDEN')THEN CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) WRITE(ICOUT,491)NUMARG,ILOCQ,ICASEQ 491 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') ENDIF C C ***************************************** C ** STEP 6-- ** C ** BRANCH TO THE APPROPRIATE SUBCASE; ** C ** (BASED ON THE QUALIFIER) ** C ** THEN FORM THE RESPONSE VARIABLE ** C ** AND THE FACTORS ** C ** AND CARRY OUT THE PLOTS. ** C ***************************************** C ISTEPN='6' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'KDEN') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO610 IF(ICASEQ.EQ.'SUBS')GOTO620 IF(ICASEQ.EQ.'FOR')GOTO630 C 610 CONTINUE DO615I=1,NLEFT ISUB(I)=1 615 CONTINUE NQ=NLEFT GOTO650 C 620 CONTINUE NIOLD=NLEFT CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERRO4) NQ=NIOLD GOTO650 C 630 CONTINUE NIOLD=NLEFT CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO650 C 650 CONTINUE J=0 IMAX=NLEFT IF(NQ.LT.NLEFT)IMAX=NQ DO660I=1,IMAX IF(ISUB(I).EQ.0)GOTO660 J=J+1 C IJ=MAXN*(ICOLL-1)+I IF(ICOLL.LE.MAXCOL)Y1(J)=DBLE(V(IJ)) IF(ICOLL.EQ.MAXCP1)Y1(J)=DBLE(PRED(I)) IF(ICOLL.EQ.MAXCP2)Y1(J)=DBLE(RES(I)) IF(ICOLL.EQ.MAXCP3)Y1(J)=DBLE(YPLOT(I)) IF(ICOLL.EQ.MAXCP4)Y1(J)=DBLE(XPLOT(I)) IF(ICOLL.EQ.MAXCP5)Y1(J)=DBLE(X2PLOT(I)) IF(ICOLL.EQ.MAXCP6)Y1(J)=DBLE(TAGPLO(I)) C 660 CONTINUE NLOCAL=J C C ***************************************************** C ** STEP 8-- ** C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** C ** VALUES Y(.) AND X(.) FOR THE PLOT. ** C ** RESET THE VECTOR D(.) TO ALL ONES. ** C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). ** C ***************************************************** C CALL DPKDE2(Y1,FT,SMOOTH, 1NLOCAL,ICASPL,IKDENP,PKDEWI,MINN2, 1Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'KDEN')THEN CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPKDEN--') 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 = ', 1 I8,I8,I8,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IKDENP,PKDEWI 9014 FORMAT('IKDENP,PKDEWI = ',I8,2X,G15.7) 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 ENDIF C RETURN END SUBROUTINE DPKDE2(Y,FT,SMOOTH, 1N,ICASPL,IKDENP,PKDEWI,MINN2, 1Y2,X2,D2,N2,NPLOTV,IBUGG3,ISUBRO,IERROR) C C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS C THAT WILL DEFINE A KERNEL DENSITY PLOT. USES THE C APPLIED STATISTICS ALGORITHM 176 OF B. W. SILVERMAN C (COMPUTES KERNEL ESTIMATE USING THE FFT). C CURRENTLY, ONLY A GAUSSIAN KERNEL FUNCTION IS C SUPPORTED. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2001/8 C ORIGINAL VERSION--AUGUST 2001. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IBUGG3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C DOUBLE PRECISION DH DOUBLE PRECISION DHI DOUBLE PRECISION DLO DOUBLE PRECISION DN DOUBLE PRECISION DSUM DOUBLE PRECISION DX DOUBLE PRECISION DMEAN DOUBLE PRECISION DVAR DOUBLE PRECISION DSD C C--------------------------------------------------------------------- C DOUBLE PRECISION Y(*) DOUBLE PRECISION FT(*) DOUBLE PRECISION SMOOTH(*) DIMENSION Y2(*) DIMENSION X2(*) DIMENSION D2(*) 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='DPKD' ISUBN2='E2 ' C IERROR='NO' C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(N.LT.MINN2)THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,31) 31 FORMAT('***** ERROR IN DPKDE2--THE NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,33) 33 FORMAT(' MUST BE AT LEAST 1;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,34)N 34 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C HOLD=Y(1) DO60I=1,N IF(Y(I).NE.HOLD)GOTO69 60 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61) 61 FORMAT('***** ERROR IN DPKDE2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62) 62 FORMAT(' ALL INPUT HORIZONTAL AXIS ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)HOLD 63 FORMAT(' ARE IDENTICALLY EQUAL TO ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 69 CONTINUE C IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'KDE2')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,70) 70 FORMAT('***** AT THE BEGINNING OF DPKDE2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)N,IKDENP,PKDEWI 72 FORMAT('N,IKDENP,PKDEWI = ',I6,2G15.7) CALL DPWRST('XXX','BUG ') DO73I=1,N WRITE(ICOUT,74)I,REAL(Y(I)) 74 FORMAT('I, Y(I) = ',I8,G15.7) CALL DPWRST('XXX','BUG ') 73 CONTINUE ENDIF C C ********************************************** C ** STEP 2-- ** C ** CALL DENEST ROUTINE TO COMPUTE THE ** C ** KERNEL DENSITY ESTIMATE. ** C ********************************************** C IERROR='NO' ICAL=0 KFLAG=1 CALL DSORT(Y,Y,N,KFLAG,IERROR) DH=DBLE(PKDEWI) IF(PKDEWI.LE.0)THEN DN=N DSUM=0.0D0 DO200I=1,N DX=Y(I) DSUM=DSUM+DX 200 CONTINUE DMEAN=DSUM/DN DSUM=0.0D0 DO300I=1,N DX=Y(I) DSUM=DSUM+(DX-DMEAN)**2 300 CONTINUE DVAR=DSUM/(DN-1.0D0) DSD=0.0D0 IF(DVAR.GT.0.0D0)DSD=DSQRT(DVAR) C P=0.25 AN=REAL(N) ANI=P*(AN+1.0) NI=ANI A2NI=NI REM=ANI-A2NI NIP1=NI+1 IF(NI.LE.1)NI=1 IF(NI.GE.N)NI=N IF(NIP1.LE.1)NIP1=1 IF(NIP1.GE.N)NIP1=N XPERC1=(1.0-REM)*Y(NI)+REM*Y(NIP1) C P=0.75 ANI=P*(AN+1.0) NI=ANI A2NI=NI REM=ANI-A2NI NIP1=NI+1 IF(NI.LE.1)NI=1 IF(NI.GE.N)NI=N IF(NIP1.LE.1)NIP1=1 IF(NIP1.GE.N)NIP1=N XPERC2=(1.0-REM)*Y(NI)+REM*Y(NIP1) AIQ=(XPERC2-XPERC1)/1.34 C CCCCC DH=DBLE(1.06)*DSD*DN**(-1.0D0/5.0D0) DH=0.9D0*MIN(DSD,DBLE(AIQ))*DN**(-1.0D0/5.0D0) ENDIF DLO=Y(1) - 3.0D0*DH DHI=Y(N) + 3.0D0*DH C CALL DENEST(Y,N,DLO,DHI,DH,FT,SMOOTH,IKDENP,ICAL,IERROR) C IF(IERROR.EQ.'YES')GOTO9000 C DO410I=1,IKDENP Y2(I)=REAL(SMOOTH(I)) X2(I)=REAL(DLO + (DBLE(I) - 0.5D0)*(DHI-DLO)/DBLE(IKDENP)) D2(I)=1.0 410 CONTINUE C N2=IKDENP NPLOTV=2 GOTO9000 C C ****************** C ** STEP 90-- ** C ** EXIT ** C ****************** C 9000 CONTINUE IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'KDE2')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPKDE2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ICASPL,IERROR,N2 9012 FORMAT('ICASPL,IERROR,N2 = ',A4,2X,A4,2X,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)REAL(DLO),REAL(DHI),REAL(DH),REAL(DSD) 9013 FORMAT('DLO,DHI,DH,DSD = ',4G15.7) CALL DPWRST('XXX','BUG ') DO9015I=1,N2 WRITE(ICOUT,9016)I,Y2(I),X2(I),D2(I) 9016 FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE ENDIF C RETURN END SUBROUTINE DPKDNP(IHARG,IARGT,ARG,NUMARG, 1IKDENP,IDEFKN,IFOUND,IERROR) C C PURPOSE--DEFINE THE NUMBER OF POINTS USED FOR THE KERNEL DENSITY C CURVE IN THE KERNEL DENSITY PLOT COMMAND. C THE SPECIFIED KERNEL DENSITY POINTS VALUE WILL BE PLACED C IN THE FLOATING POINT VARIABLE IKDENP. C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --ARG (A FLOATING POINT VECTOR) C --NUMARG (AN INTEGER VARIABLE) C --IDEFKN (A FLOATING POINT VARIABLE) C OUTPUT ARGUMENTS--IKDENP (A FLOATING POINT 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-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2001/8 C ORIGINAL VERSION--AUGUST 2001. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION ARG(*) 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 IF(NUMARG.EQ.0)GOTO9000 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'=')GOTO9000 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'POIN')GOTO1110 IF(IHARG(NUMARG).EQ.'?')GOTO8100 GOTO9000 C 1110 CONTINUE IF(IHARG(NUMARG).EQ.'POIN')GOTO1150 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160 GOTO1120 C 1120 CONTINUE IERROR='YES' WRITE(ICOUT,1121) 1121 FORMAT('***** ERROR IN DPKDNP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1122) 1122 FORMAT(' ILLEGAL FORM FOR KERNEL DENSITY POINTS COMMAND.') CALL DPWRST('XXX','BUG ') GOTO9000 C 1150 CONTINUE HOLD=IDEFKN GOTO1180 C 1160 CONTINUE HOLD=ARG(NUMARG) GOTO1180 C 1180 CONTINUE IFOUND='YES' IKDENP=INT(HOLD+0.5) IKLOW=5 IKHIGH=11 IF(IKDENP.LE.2**IKLOW)THEN IKDENP=2**IKLOW ELSEIF(IKDENP.GT.2**IKHIGH)THEN IKDENP=2**IKHIGH ELSE DO1185K=IKLOW,IKHIGH IF(IKDENP.GT.2**(K-1).AND.IKDENP.LE.2**K)THEN IKDENP=2**K GOTO1189 ENDIF 1185 CONTINUE ENDIF 1189 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1289 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1281)IKDENP 1281 FORMAT('THE KERNEL DENSITY POINTS HAS JUST BEEN SET ', 1 'TO ',I8) CALL DPWRST('XXX','BUG ') 1289 CONTINUE GOTO9000 C C ******************************************** C ** STEP 81-- ** C ** TREAT THE ? CASE-- ** C ** DUMP OUT CURRENT AND DEFAULT VALUES. ** C ******************************************** C 8100 CONTINUE IFOUND='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8111)IKDENP 8111 FORMAT('THE CURRENT KERNEL DENSITY POINTS IS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8121)IDEFKN 8121 FORMAT('THE DEFAULT KERNEL DENSITY POINTS IS ',I8) CALL DPWRST('XXX','BUG ') GOTO9000 C 9000 CONTINUE RETURN END SUBROUTINE DPKDWI(IHARG,IARGT,ARG,NUMARG, 1PKDEWI,DEFKWI,IFOUND,IERROR) C C PURPOSE--DEFINE THE SMOOTHING WIDTH FOR THE C TO BE USED FOR THE KERNEL DENSITY ESTIMATOR. C THE SPECIFIED KERNEL DENSITY WIDTH VALUE WILL BE PLACED C IN THE FLOATING POINT VARIABLE PKDEWI. C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --ARG (A FLOATING POINT VECTOR) C --NUMARG (AN INTEGER VARIABLE) C --DEFKWI (A FLOATING POINT VARIABLE) C OUTPUT ARGUMENTS--PKDEWI (A FLOATING POINT 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-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2001/8 C ORIGINAL VERSION--AUGUST 2001. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION ARG(*) 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 IF(NUMARG.EQ.0)GOTO9000 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'=')GOTO9000 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'WIDT')GOTO1110 IF(IHARG(NUMARG).EQ.'?')GOTO8100 GOTO9000 C 1110 CONTINUE IF(IHARG(NUMARG).EQ.'WIDT')GOTO1150 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160 GOTO1120 C 1120 CONTINUE IERROR='YES' WRITE(ICOUT,1121) 1121 FORMAT('***** ERROR IN DPKDWI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1122) 1122 FORMAT(' ILLEGAL FORM FOR KERNEL DENSITY WIDTH COMMAND.') CALL DPWRST('XXX','BUG ') GOTO9000 C 1150 CONTINUE HOLD=DEFKWI GOTO1180 C 1160 CONTINUE HOLD=ARG(NUMARG) GOTO1180 C 1180 CONTINUE IFOUND='YES' PKDEWI=HOLD C IF(IFEEDB.EQ.'OFF')GOTO1289 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') IF(PKDEWI.NE.DEFKWI)THEN WRITE(ICOUT,1281)PKDEWI 1281 FORMAT('THE KERNEL DENSITY WIDTH HAS JUST BEEN SET ', 1 'TO ',G15.7) CALL DPWRST('XXX','BUG ') ELSE WRITE(ICOUT,1291) 1291 FORMAT('THE KERNEL DENSITY WIDTH HAS JUST BEEN SET ', 1 'TO THE DEFAULT.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1293) 1293 FORMAT('DATAPLOT WILL SELECT THE WIDTH BASED ON THE DATA.') CALL DPWRST('XXX','BUG ') ENDIF 1289 CONTINUE GOTO9000 C C ******************************************** C ** STEP 81-- ** C ** TREAT THE ? CASE-- ** C ** DUMP OUT CURRENT AND DEFAULT VALUES. ** C ******************************************** C 8100 CONTINUE IFOUND='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8111)PKDEWI 8111 FORMAT('THE CURRENT KERNEL DENSITY WIDTH IS ',G15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8121)DEFKWI 8121 FORMAT('THE DEFAULT KERNEL DENSITY WIDTH IS ',G15.7) CALL DPWRST('XXX','BUG ') GOTO9000 C 9000 CONTINUE RETURN END SUBROUTINE DPKNOT(IHARG,IHARG2,NUMARG,IDEFK1,IDEFK2, 1IKNOT1,IKNOT2,IFOUND,IERROR) C C PURPOSE--DEFINE THE USER VARIABLE NAME IN WHICH C THE KNOTS FOR SPLINE FITTING RESIDE. C CHARACTERS 1 TO 4 OF THE SPECIFIED KNOT NAME C WILL BE PLACED IN THE HOLLERITH VARIABLE IKNOT1; C CHARACTERS 5 TO 8 OF THE SPECIFIED KNOT NAME C WILL BE PLACED IN THE HOLLERITH VARIABLE IKNOT2. C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IHARG2 (A HOLLERITH VECTOR) C --NUMARG (AN INTEGER VARIABLE) C --IDEFK1 (A HOLLERITH VARIABLE) C --IDEFK2 (A HOLLERITH VARIABLE) C OUTPUT ARGUMENTS--IKNOT1 (A HOLLERITH VARIABLE) C --IKNOT2 (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 --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IHARG2 CHARACTER*4 IDEFK1 CHARACTER*4 IDEFK2 CHARACTER*4 IKNOT1 CHARACTER*4 IKNOT2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD1 CHARACTER*4 IHOLD2 C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IHARG2(*) 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 GOTO1110 C 1110 CONTINUE IF(NUMARG.LE.0)GOTO1150 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 GOTO1160 C 1150 CONTINUE IHOLD1=IDEFK1 IHOLD2=IDEFK2 GOTO1180 C 1160 CONTINUE IHOLD1=IHARG(NUMARG) IHOLD2=IHARG2(NUMARG) GOTO1180 C 1180 CONTINUE IFOUND='YES' IKNOT1=IHOLD1 IKNOT2=IHOLD2 C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181)IKNOT1,IKNOT2 1181 FORMAT('THE KNOTS VARIABLE HAS JUST BEEN DESIGNATED AS ', 1A4,A4) CALL DPWRST('XXX','BUG ') IF(IKNOT1.EQ.' '.AND.IKNOT2.EQ.' ')WRITE(ICOUT,1182) 1182 FORMAT('(THAT IS, THE NO-KNOTS CASE IS BEING ASSUMED)') IF(IKNOT1.EQ.' '.AND.IKNOT2.EQ.' ')CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPKRUS(YTEMP,XTEMP,MAXNXT, 1ICAPSW, 1IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) C C PURPOSE--CARRY OUT KRUSKAL-WALLIS TEST C NON-PARAMETRIC ONE-WAY ANOVA C EXAMPLE--KRUSKAL-WALLIS TEST Y X C REFERENCE--XX C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--99/6 C ORIGINAL VERSION--JUNE 1999. C UPDATED --OCTOBER 2004. SUPPORT FOR HTML AND LATEX C OUTPUT C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICAPSW CHARACTER*4 IBUGA2 CHARACTER*4 IBUGA3 CHARACTER*4 IBUGQ 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 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C CHARACTER*4 IUSE1 CHARACTER*4 IUSE2 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 'DPCOST.INC' INCLUDE 'DPCOPA.INC' C DIMENSION DTAG(MAXOBV) DIMENSION ARANK(MAXOBV) DIMENSION NRANK(MAXOBV) C INCLUDE 'DPCOZZ.INC' EQUIVALENCE(GARBAG(IGARB1),DTAG(1)) EQUIVALENCE(GARBAG(IGARB2),ARANK(1)) C INCLUDE 'DPCOZI.INC' EQUIVALENCE(IGARBG(IIGAR1),NRANK(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='DPKR' ISUBN2='US ' 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=2 C IFOUND='YES' C NLEFT=0 C ICASEQ='UNKN' C C ****************************************** C ** TREAT THE KRUSKAL-WALLIS TEST CASE ** C ****************************************** C IF(IBUGA2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPKRUS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA2,IBUGA3 52 FORMAT('IBUGA2,IBUGA3 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGQ 53 FORMAT('IBUGQ = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)MAXNXT 55 FORMAT('MAXNXT = ',I8) CALL DPWRST('XXX','BUG ') 90 CONTINUE 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=2 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')CALL 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 DPKRUS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' FOR KRUSKAL-WALLIS TEST,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1145) 1145 FORMAT(' BOTH ARGUMENTS 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)WRITE(ICOUT,1150)(IANS(I),I=1,IWIDTH) 1150 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') 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 2 OR MORE. ** C ******************************************************* C ISTEPN='12' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IUSE1.NE.'V')GOTO1290 IF(N1.GE.MINN2)GOTO1290 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1211) 1211 FORMAT('***** ERROR IN DPKRUS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1212) 1212 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1213) 1213 FORMAT(' (FOR WHICH KRUSKAL-WALLIS TEST ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1214) 1214 FORMAT(' WAS TO HAVE BEEN CARRIED OUT)') 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)IH11,IH12 1217 FORMAT(' FOR VARIABLE ',A4,A4,' WHICH HAD') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1218)N1 1218 FORMAT(' NUMBER OF OBSERVATIONS = ',I8,';') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1219) 1219 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1220)(IANS(I),I=1,IWIDTH) 1220 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1290 CONTINUE 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')CALL 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 DPKRUS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2142) 2142 FORMAT(' FOR KRUSKAL-WALLIS TEST,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2145) 2145 FORMAT(' BOTH ARGUMENTS MUST BE A VARIABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2146) 2146 FORMAT(' (AS OPPOSED TO A PARAMETER OR FUNCTION).') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2147) 2147 FORMAT(' 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)WRITE(ICOUT,2150)(IANS(I),I=1,IWIDTH) 2150 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C IUSE2=IUSE(ILOCV) ICOL2=IVALUE(ILOCV) N2=IN(ILOCV) 2190 CONTINUE C C ******************************************************* C ** STEP 22-- ** 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='22' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IUSE2.NE.'V')GOTO2290 IF(N2.EQ.N1)GOTO2290 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2211) 2211 FORMAT('***** ERROR IN DPKRUS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2212) 2212 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2213) 2213 FORMAT(' (FOR VARIABLE 2 OF KRUSKAL-WALLIS TEST ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2214) 2214 FORMAT(' MUST BE THE SAME AS VARIABLE 1') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2215) 2215 FORMAT(' SUCH WAS NOT THE CASE HERE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2216)N1,N2 2216 FORMAT(' N1 = ',I8,' N2 = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2219) 2219 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2220)(IANS(I),I=1,IWIDTH) 2220 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 2290 CONTINUE 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 IF(IBUGA2.EQ.'OFF')GOTO4095 WRITE(ICOUT,4091)NUMARG,ILOCQ 4091 FORMAT('NUMARG,ILOCQ = ',2I8) CALL DPWRST('XXX','BUG ') 4095 CONTINUE 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 IF(IUSE1.NE.'V')GOTO4190 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.GE.MINN2)GOTO4160 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4151) 4151 FORMAT('***** ERROR IN DPKRUS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4152) 4152 FORMAT(' AFTER THE APPROPRIATE SUBSET HAS BEEN ', 1'EXTRACTED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4153)IH11,IH12 4153 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING', 1'FROM VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4154) 4154 FORMAT(' (FOR WHICH KRUSKAL-WALLIS TEST ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4155) 4155 FORMAT(' IS TO BE CARRIED OUT)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4156)MINN2 4156 FORMAT(' 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)WRITE(ICOUT,4159)(IANS(I),I=1,IWIDTH) 4159 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 4160 CONTINUE 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 4170 CONTINUE NS1=J C 4190 CONTINUE C C *********************************************** C ** STEP 42-- ** C ** TEMPORARILY FORM THE VARIABLE X(.) ** C ** WHICH WILL HOLD THE DATAN FROM SAMPLE 2. ** C ** FORM THIS VARIABLE BY ** C ** BRANCHING TO THE APPROPRIATE SUBCASE ** C ** (FULL, SUBSET, OR FOR). ** C *********************************************** C IF(IUSE2.NE.'V')GOTO4290 C ISTEPN='42' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO4210 IF(ICASEQ.EQ.'SUBS')GOTO4220 IF(ICASEQ.EQ.'FOR')GOTO4230 C 4210 CONTINUE DO4215I=1,N2 ISUB(I)=1 4215 CONTINUE NQ=N2 GOTO4250 C 4220 CONTINUE NIOLD=N2 CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO4250 C 4230 CONTINUE NIOLD=N2 CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO4250 C 4250 CONTINUE IF(NQ.GE.MINN2)GOTO4260 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4251) 4251 FORMAT('***** ERROR IN DPKRUS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4252) 4252 FORMAT(' AFTER THE APPROPRIATE SUBSET HAS BEEN ', 1'EXTRACTED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4253)IH21,IH22 4253 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING', 1'FROM VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4254) 4254 FORMAT(' (FOR WHICH KRUSKAL-WALLIS TEST ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4255) 4255 FORMAT(' IS TO BE CARRIED OUT)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4256)MINN2 4256 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4257)NQ 4257 FORMAT(' SUCH WAS NOT THE CASE HERE. (N = ',I8,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4258) 4258 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,4259)(IANS(I),I=1,IWIDTH) 4259 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 4260 CONTINUE J=0 IMAX=N2 IF(NQ.LT.N2)IMAX=NQ DO4270I=1,IMAX IF(ISUB(I).EQ.0)GOTO4270 J=J+1 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 4270 CONTINUE NS2=J C 4290 CONTINUE C C ********************************* C ** STEP 52-- ** C ** DO KRUSKAL-WALLIS TEST ** C ********************************* C ISTEPN='52' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGA2.EQ.'OFF')GOTO5290 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5211) 5211 FORMAT('***** FROM DPKRUS, AS WE ARE ABOUT TO CALL DPKRU2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5212)N1,N2,NS1,NS2,MAXN 5212 FORMAT('N1,N2,NS1,NS2,MAXN = ',5I8) CALL DPWRST('XXX','BUG ') DO5215I=1,NS1 WRITE(ICOUT,5216)I,Y(I) 5216 FORMAT('I,Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 5215 CONTINUE DO5217I=1,NS1 WRITE(ICOUT,5218)I,Y(I) 5218 FORMAT('I,Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 5217 CONTINUE CCCCC IBUGA3='ABCD' WRITE(ICOUT,5231)IBUGA3 5231 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') 5290 CONTINUE C CALL DPKRU2(Y,X,NS1, 1YTEMP,XTEMP,DTAG,ARANK,NRANK,MAXNXT, 1STATVA,STATCD,CUT0,CUT50,CUT75,CUT90,CUT95,CUT99,CUT999, 1ICAPSW,ICAPTY, 1IBUGA3,IERROR) C C *************************************** C ** STEP 61-- ** C ** UPDATE INTERNAL DATAPLOT TABLES ** C *************************************** C ISTEPN='61' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ISUBN0='DPKR' 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.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPKRUS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA2,IBUGA3 9012 FORMAT('IBUGA2,IBUGA3 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IBUGQ 9013 FORMAT('IBUGQ = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NLEFT,NS 9014 FORMAT('NLEFT,NS = ',2I8) 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 ') 9090 CONTINUE C RETURN END SUBROUTINE DPKRU2(Y,TAG,N, 1YTEMP,XTEMP,DTAG,ARANK,NRANK,MAXNXT, 1STATVA,STATCD,CUT0,CUT50,CUT75,CUT90,CUT95,CUTL99,CUTU99, 1ICAPSW,ICAPTY, 1IBUGA3,IERROR) C C PURPOSE--THIS ROUTINE CARRIES OUT KRUSKALL-WALLIS'S TEST C NON-PARAMETRIC ONE-WAY ANOVA C EXAMPLE--KRUSKALL-WALLIS TEST Y TAG C REFERENCE--W. J. CONOVER, "PRACTICAL NONPARAMETRIC C STATISTICS", THIRD EDITION, 1999, WILEY, C PP. 288-297. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--99/6 C ORIGINAL VERSION--JUNE 1999. C UPDATED --OCTOBER 2004. SUPPORT FOR HTML AND LATEX C OUTPUT C UPDATED --OCTOBER 2004. ADD MULTIPLE COMPARISONS C UPDATED --OCTOBER 2006. CALL LIST TO TPPF C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICAPSW CHARACTER*4 ICAPTY CHARACTER*4 IBUGA3 CHARACTER*4 IBASLC CHARACTER*4 IERROR C CHARACTER*4 IWRITE C CHARACTER*3 IATEMP C CHARACTER*6 ICONC1 CHARACTER*6 ICONC2 CHARACTER*6 ICONC3 C CHARACTER*4 ISUBRO CHARACTER*4 ISUBN0 CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN 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 DOUBLE PRECISION DSUM1 DOUBLE PRECISION DSUM2 C EXTERNAL SUM C C--------------------------------------------------------------------- C DIMENSION Y(*) DIMENSION TAG(*) DIMENSION DTAG(*) DIMENSION YTEMP(*) DIMENSION XTEMP(*) DIMENSION ARANK(*) DIMENSION NRANK(*) 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='DPKR' ISUBN2='U2 ' ISUBRO=' ' ISUBN0=' ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,51) 51 FORMAT('**** AT THE BEGINNING OF DPKRU2--') 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) 57 FORMAT('I,Y(I) = ',I8,E15.7) CALL DPWRST('XXX','WRIT') 56 CONTINUE WRITE(ICOUT,65)N 65 FORMAT('N = ',I8) CALL DPWRST('XXX','WRIT') DO66I=1,N WRITE(ICOUT,67)I,TAG(I) 67 FORMAT('I,TAG(I) = ',I8,E15.7) CALL DPWRST('XXX','WRIT') 66 CONTINUE 90 CONTINUE C C ******************************************** C ** STEP 11-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C ISTEPN='11' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(N.GE.1)GOTO1119 WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1111) 1111 FORMAT('***** ERROR IN DPKRU2--THE NUMBER OF OBSERVATIONS ', 1'FOR VARIABLE 1 IS NON-POSITIVE') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1112)N 1112 FORMAT('SAMPLE SIZE = ',I8) CALL DPWRST('XXX','WRIT') IERROR='YES' GOTO9000 1119 CONTINUE C IF(N.EQ.1)GOTO1120 GOTO1129 1120 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1121) 1121 FORMAT('***** NOTE FROM DPKRU2--VARIABLE 1 ', 1'HAS ONLY 1 ELEMENT') CALL DPWRST('XXX','WRIT') GOTO9000 1129 CONTINUE 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 DPKRU2--VARIABLE 1 ', 1'HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','WRIT') GOTO9000 1139 CONTINUE C IF(N.GE.1)GOTO1219 WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1211) 1211 FORMAT('***** ERROR IN DPKRU2--THE NUMBER OF OBSERVATIONS ', 1'FOR VARIABLE 2 IS NON-POSITIVE') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1212)N 1212 FORMAT('SAMPLE SIZE = ',I8) CALL DPWRST('XXX','WRIT') IERROR='YES' GOTO9000 1219 CONTINUE C IF(N.EQ.1)GOTO1220 GOTO1229 1220 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1221) 1221 FORMAT('***** NOTE FROM DPKRU2--VARIABLE 2 ', 1'HAS ONLY 1 ELEMENT') CALL DPWRST('XXX','WRIT') GOTO9000 1229 CONTINUE C HOLD=TAG(1) DO1235I=2,N IF(TAG(I).NE.HOLD)GOTO1239 1235 CONTINUE 1230 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1231)HOLD 1231 FORMAT('***** NOTE FROM DPKRU2--VARIABLE 2 ', 1'HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','WRIT') GOTO9000 1239 CONTINUE C 1290 CONTINUE C C ****************************** C ** STEP 41-- ** C ** CARRY OUT CALCULATIONS ** C ** FOR KRUSKALL-WALLIS TEST ** C ****************************** C 4100 CONTINUE C ISTEPN='41' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IWRITE='OFF' C CALL DISTIN(TAG,N,IWRITE,DTAG,NUMDIS,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 CALL SORTC(TAG,Y,N,TAG,Y) CALL RANK(Y,N,IWRITE,XTEMP,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C CCCCC OCTOBER 2004: THE KRUSKAL-WALLIS STATISTIC FOR THE CASE CCCCC WITH NO TIES IS: CCCCC CCCCC H = [12/(N*(N+1)]*SUM[i=1 to k][R(i)**2/N(i)] - 3*(N+1) CCCCC CCCCC THE FORMULA WITH TIES IS: CCCCC CCCCC H = (1/S**2)*{SUM[i=1 to k][R(i)**2/N(i) - N*(N+1)**2/4} CCCCC CCCCC GO AHEAD AND USE THE TIES FORMULA SINCE IT IS JUST AS EASY CCCCC AND IT ALSO FACILATES THE COMPUTATION OF MULTIPLE COMPARISONS. C CCCCC AFACT=12.0/(REAL(N)*REAL(N+1)) AN=REAL(N) AFACT=AN*(AN+1.0)**2/4.0 C DSUM1=0.0D0 DO4200IDIS=1,NUMDIS J=0 DO4300I=1,N IF(TAG(I).EQ.DTAG(IDIS))THEN J=J+1 YTEMP(J)=XTEMP(I) ENDIF 4300 CONTINUE NRANK(IDIS)=J ANR=REAL(NRANK(IDIS)) CALL SUM(YTEMP,NRANK(IDIS),IWRITE,YSUM,IBUGA3,IERROR) ARANK(IDIS)=YSUM DSUM1=DSUM1 + DBLE(YSUM)**2/DBLE(ANR) 4200 CONTINUE C DSUM2=0.0D0 DO4310I=1,N DSUM2=DSUM2 + DBLE(XTEMP(I))**2 4310 CONTINUE S2=REAL((DSUM2 - DBLE(AFACT))/DBLE(N-1)) C CCCCC CALL MEAN(Y,N,IWRITE,TBAR,IBUGA3,IERROR) C DTERM1=DSUM1 - DBLE(AFACT) STATVA=DTERM1/DBLE(S2) NUMDF=NUMDIS-1 CALL CHSCDF(STATVA,NUMDF,STATCD) C CUT0=0.0 CALL CHSPPF(.50,NUMDF,CUT50) CALL CHSPPF(.75,NUMDF,CUT75) CALL CHSPPF(.90,NUMDF,CUT90) CALL CHSPPF(.95,NUMDF,CUT95) CALL CHSPPF(.99,NUMDF,CUT99) CALL CHSPPF(.999,NUMDF,CUT999) C ICONC1='REJECT' ICONC2='REJECT' ICONC3='REJECT' C IF(STATVA.LE.CUT95)ICONC2='ACCEPT' C IOUNI1=IST1NU IFILE1=IST1NA ISTAT1=IST1ST IFORM1=IST1FO IACCE1=IST1AC IPROT1=IST1PR ICURS1=IST1CS ISUBN0='FRI2' 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 WRITE(IOUNI1,2005) 2005 FORMAT(' I J ', 1 '|Ri/Ni-Rj/nj| ', 1 '90% CV ', 1 '95% CV ', 1 '99% CV ') C IDF=N-NUMDIS ALPHA=0.05 CALL TPPF(1.0-ALPHA/2.0,REAL(IDF),AT95) ALPHA=0.10 CALL TPPF(1.0-ALPHA/2.0,REAL(IDF),AT90) ALPHA=0.01 CALL TPPF(1.0-ALPHA/2.0,REAL(IDF),AT99) AN=REAL(N) AFACT2=SQRT(S2*(AN-1.0-STATVA)/REAL(N-NUMDIS)) C DO2030I=1,NUMDIS DO2039J=1,NUMDIS IF(I.LT.J)THEN ANI=REAL(NRANK(I)) ANJ=REAL(NRANK(J)) ADIFF=ABS((ARANK(I)/ANI) - (ARANK(J)/ANJ)) AFACT3=SQRT((1.0/ANI) + (1.0/ANJ)) ACV90=AT90*AFACT2*AFACT3 ACV95=AT95*AFACT2*AFACT3 ACV99=AT99*AFACT2*AFACT3 IATEMP=' ' IF(ADIFF.GE.ACV90)IATEMP(1:1)='*' IF(ADIFF.GE.ACV95)IATEMP(2:2)='*' IF(ADIFF.GE.ACV99)IATEMP(3:3)='*' WRITE(IOUNI1,2037)I,J,ADIFF,ACV90,ACV95,ACV99,IATEMP 2037 FORMAT(I6,2X,I6,2X,4E15.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 C ******************************** C ** STEP 42-- ** C ** WRITE OUT EVERYTHING ** C ** FOR KRUSKALL-WALLIS TEST ** C ******************************** C ISTEPN='42' IF(IBUGA3.EQ.'ON')CALL 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)NUMDIS 5003 FORMAT('KRUSKAL WALLIS TEST THAT THE ',I8,' GROUPS ', 1 'COME FROM IDENTICAL DISTRIBUTIONS') 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 Groups:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5029)NUMDIS 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,5043) 5043 FORMAT(' Kruskal-Wallis Test Statstic:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)STATVA 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,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 Chi-Square Reference ', 1 'Distribution
    ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5067) 5067 FORMAT(' for Kruskal-Wallis 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.5 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)NUMDIS 5087 FORMAT(' The ',I8,' groups come from identical ', 1 'populations.') ELSE WRITE(ICOUT,5088)NUMDIS 5088 FORMAT(' The ',I8,' groups do not come from ', 1 'identical populations.') 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 KRUSKAL-WALLIS TEST THAT THE ',I8,
     1         'GROUPS COME FROM IDENTICAL DISTRIBUTIONS}')
 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,NUMDIS
        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 Chi-Square ',
     1         'Reference 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 Groups: & ',I8,2X,A1,A1)
 8034   FORMAT(11X,'Kruskal-Wallis Test Statistic: & ',G15.7,
     1         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,' groups come from identical ',
     1         'populations.',2X,A1,A1)
 8043   FORMAT(11X,'The ',I8,' groups do not come from identical ',
     1         'populations.',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.5   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)NUMDIS,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8034)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)NUMDIS,IBASLC,IBASLC
          CALL DPWRST('XXX','WRIT')
        ELSE
          WRITE(ICOUT,8043)NUMDIS,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
      ELSE
C
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7211)
 7211   FORMAT('              KRUSKALL-WALLIS TEST FOR ONE-WAY ANOVA')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,7222)
 7222   FORMAT('1. STATISTICS')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7224)N
 7224   FORMAT(6X,'NUMBER OF OBSERVATIONS    = ',I8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7226)NUMDIS
 7226   FORMAT(6X,'NUMBER OF GROUPS          = ',I8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7228)STATVA
 7228   FORMAT(6X,'KRUSKALL-WALLIS TEST STATISTIC   = ',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 CHI-SQUARE REFERENCE ',
     1         'DISTRIBUTION')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7241)
 7241   FORMAT('   FOR KRUSKALL-WALLIS TEST STATISTIC')
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,7345)CUT0
 7345   FORMAT(6X,'0          % POINT    = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7346)CUT50
 7346   FORMAT(6X,'50         % POINT    = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7347)CUT75
 7347   FORMAT(6X,'75         % POINT    = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7348)CUT90
 7348   FORMAT(6X,'90         % POINT    = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7349)CUT95
 7349   FORMAT(6X,'95         % POINT    = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7350)CUT99
 7350   FORMAT(6X,'99         % POINT    = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7351)CUT999
 7351   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,7247)100.*STATCD,STATVA
 7247   FORMAT(6X,G15.7,'   % Point:  ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,7261)
 7261   FORMAT('3. CONCLUSION (AT THE 5% LEVEL):')
        CALL DPWRST('XXX','WRIT')
        IF(STATVA.LE.CUT95)THEN
          WRITE(ICOUT,7262)NUMDIS
 7262     FORMAT(6X,'THE ',I8,' SAMPLES COME FROM IDENTICAL ',
     1           'POPULATIONS.')
          CALL DPWRST('XXX','WRIT')
        ELSE
          WRITE(ICOUT,7272)NUMDIS
 7272     FORMAT(6X,'THE ',I8,' SAMPLES DO NOT COME FROM IDENTICAL ',
     1           'POPULATIONS.')
          CALL DPWRST('XXX','WRIT')
        ENDIF
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
 7290   CONTINUE
      ENDIF
      ENDIF
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,7401)
 7401 FORMAT('PAIRWISE MULTIPLE COMPARISONS WRITTEN TO FILE ',
     1       'dpst1f.dat.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','WRIT')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPKRU2--')
      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')
      DO9016I=1,N
      WRITE(ICOUT,9017)I,Y(I)
 9017 FORMAT('I,Y(I) = ',I8,E15.7)
      CALL DPWRST('XXX','WRIT')
 9016 CONTINUE
      WRITE(ICOUT,9025)N
 9025 FORMAT('N = ',I8)
      CALL DPWRST('XXX','WRIT')
      DO9026I=1,N
      WRITE(ICOUT,9027)I,TAG(I)
 9027 FORMAT('I,TAG(I) = ',I8,E15.7)
      CALL DPWRST('XXX','WRIT')
 9026 CONTINUE
 9090 CONTINUE
C
      RETURN
      END